! $Id$
!
!  This module contains code used by the corresponding physics
!  modules to set up various initial conditions (stratitication,
!  perturbations, and other structures). This module is not used
!  during run time (although it is used by the physics modules that
!  are used both during run time and for the initial condition).
!
module Initcond
!
  use Cdata
  use General
  use Messages
  use Mpicomm, only : ipx, ipy, ipz
!
  implicit none
!
  private
!
  include 'eos_params.h'

  public :: arcade_x, vecpatternxy, bipolar, bipolar_restzero
  public :: soundwave,sinwave,sinwave_phase,coswave,coswave_phase,cos_cos_sin
  public :: hatwave
  public :: acosy
  public :: sph_constb,tanh_hyperbola
  public :: gaunoise, posnoise, posnoise_rel
  public :: gaunoise_rprof
  public :: gaussian, gaussian3d, gaussianpos
  public :: ABC_field, beltrami, bessel_x, bessel_az_x
  public :: beltramik_general, beltrami_general, beltrami_complex
  public :: beltrami_old, bhyperz, bihelical
  public :: straining, rolls, tor_pert
  public :: jump, bjump, bjumpz, stratification, stratification_x
  public :: stratification_xz
  public :: modes, modev, modeb, crazy, exponential
  public :: trilinear, baroclinic
  public :: triquad, isotdisk
  public :: diffrot, olddiffrot
  public :: const_omega
  public :: powern, power_randomphase, power_randomphase_hel, bunch_davies
  public :: planet, planet_hc
  public :: random_isotropic_KS, random_isotropic_shell
  public :: htanh, vtube, vtube_peri, htube, htube2, htube_x, hat, hat3d
  public :: htube_erf, xpoint, xpoint2
  public :: htube2_x
  public :: Gaussian_By_z
  public :: wave_uu, wave, parabola, linprof
  public :: sinxsinz, cosx_cosy_cosz, cosx_coscosy_cosz
  public :: x_siny_cosz, x1_siny_cosz, x32_siny_cosz, x1_cosy_cosz, lnx_cosy_cosz
  public :: sinx_siny_sinz, sinx_cosy_cosz, cosx_siny_cosz, sinx_siny_cosz
  public :: sin2x_sin2y_cosz, cos2x_cos2y_cos2z, x3_cosy_cosz, x3_siny_cosz
  public :: cosx_cosz, cosy_cosz, cosy_sinz
  public :: cosxz_cosz, cosyz_sinz
  public :: halfcos_x, halfcos_z, magsupport, vfield
  public :: uniform_x, uniform_y, uniform_z, uniform_phi, phi_comp_over_r
  public :: vfluxlayer, hfluxlayer, hfluxlayer_y, hfluxlayer_y_theta
  public :: vortex_2d
  public :: vfield2
  public :: hawley_etal99a
  public :: robertsflow, rotated_robertsflow
  public :: const_lou
  public :: corona_init,mdi_init,mag_init,mag_Az_init,file_init,temp_hydrostatic
  public :: innerbox
  public :: couette, couette_rings
  public :: strange,phi_siny_over_r2
  public :: ferriere_uniform_x, ferriere_uniform_y
  public :: rotblob, rotblob_yz, pre_stellar_cloud, dipole, dipole_tor, switchback
  public :: quadrupole, quadrupole2, quadrupole3, dipoleA, dipoleB
  public :: read_outside_scal_array, read_outside_vec_array
!
  interface posnoise            ! Overload the `posnoise' function
    module procedure posnoise_vect
    module procedure posnoise_scal
  endinterface
!
  interface posnoise_rel        ! Overload the `posnoise' function
    module procedure posnoise_rel_vect
    module procedure posnoise_rel_scal
  endinterface
!
  interface gaunoise            ! Overload the `gaunoise' function
    module procedure gaunoise_vect
    module procedure gaunoise_scal
    module procedure gaunoise_prof_vect
    module procedure gaunoise_prof_scal
  endinterface
!
  interface gaunoise_rprof      ! Overload the `gaunoise_rprof' function
    module procedure gaunoise_rprof_vect
    module procedure gaunoise_rprof_scal
  endinterface
!
  character(LEN=labellen) :: wave_fmt1='(1x,a,e9.2,3f8.2)'
!
  contains
!***********************************************************************
    subroutine phi_siny_over_r2(f,i)
!
!  A_phi ~ sin(y)/R^2 if R>=0.7 field (in terms of vector potential)
!
!  14-oct-09/irina: coded
!
      integer :: i,j,k
      real, dimension (mx,my,mz,mfarray) :: f
      real :: dmx,radius, dtheta,theta
!
     dmx=(l2-l1)/mx
     dtheta=pi/my
     f(:,:,:,i)=0.0
!
     do j=1,mx
       radius=l1+(j-1)*dmx
     if (radius>=0.7) then
       do k=1,my
        theta=pi*(k-1)*dtheta
        f(j,k,:,i)=sin(theta)/radius**2
       enddo
     endif
    enddo
!
    endsubroutine phi_siny_over_r2
!***********************************************************************
    subroutine sinxsinz(ampl,f,i,kx,ky,kz,KKx,KKy,KKz)
!
!  sinusoidal wave. Note: f(:,:,:,j) with j=i+1 is set.
!
!  26-jul-02/axel: coded
!
      integer :: i,j
      real, dimension (mx,my,mz,mfarray) :: f
      real, optional :: kx,ky,kz,KKx,KKy,KKz
      real :: ampl,kx1=pi/2.,ky1=0.,kz1=pi/2.,KKx1=0.,KKy1=0.,KKz1=0.
!
!  wavenumber k, helicity H=ampl (can be either sign)
!
!  sinx(kx*x)*sin(kz*z)
!
      if (present(kx)) kx1=kx
      if (present(ky)) ky1=ky
      if (present(kz)) kz1=kz
!
!  Gaussian scale heights
!
      if (present(KKx)) KKx1=KKx
      if (present(KKy)) KKy1=KKy
      if (present(KKz)) KKz1=KKz
!
      if (ampl==0) then
        if (lroot) print*,'sinxsinz: ampl=0 in sinx*sinz wave; kx,kz=',kx1,kz1
      else
        if (lroot) print*,'sinxsinz: sinx*sinz wave; ampl,kx,kz=',ampl,kx1,kz1
        j=i+1
        f(:,:,:,j)=f(:,:,:,j)+ampl*(&
          spread(spread(cos(kx1*x)*exp(-.5*(KKx1*x)**2),2,my),3,mz)*&
          spread(spread(cos(ky1*y)*exp(-.5*(KKy1*y)**2),1,mx),3,mz)*&
          spread(spread(cos(kz1*z)*exp(-.5*(KKz1*z)**2),1,mx),2,my))
      endif
!
    endsubroutine sinxsinz
!***********************************************************************
    subroutine sinx_siny_sinz(ampl,f,i,kx,ky,kz)
!
!  sinusoidal wave, adapted from sinxsinz (that routine was already doing
!  this, but under a different name)
!
!  20-jan-07/axel: adapted
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real,optional :: kx,ky,kz
      real :: ampl,kx1=pi/2.,ky1=0.,kz1=pi/2.
!
!  wavenumber k, helicity H=ampl (can be either sign)
!
!  sinx(kx*x)*sin(kz*z)
!
      if (present(kx)) kx1=kx
      if (present(ky)) ky1=ky
      if (present(kz)) kz1=kz
      if (ampl==0) then
        if (lroot) print*,'sinx_siny_sinz: ampl=0'
      else
        if (lroot) write(*,wave_fmt1) 'sinx_siny_sinz: ampl,kx,ky,kz=', &
                                      ampl,kx1,ky1,kz1
        f(:,:,:,i)=f(:,:,:,i)+ampl*(spread(spread(sin(kx1*x),2,my),3,mz)&
                                   *spread(spread(sin(ky1*y),1,mx),3,mz)&
                                   *spread(spread(sin(kz1*z),1,mx),2,my))
!
      endif
!
    endsubroutine sinx_siny_sinz
!***********************************************************************
    subroutine sinx_siny_cosz(ampl,f,i,kx,ky,kz)
!
!  sinusoidal wave, adapted from sinxsinz (that routine was already doing
!  this, but under a different name)
!
!   2-dec-03/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real,optional :: kx,ky,kz
      real :: ampl,kx1=pi/2.,ky1=0.,kz1=pi/2.
!
!  wavenumber k, helicity H=ampl (can be either sign)
!
!  sinx(kx*x)*sin(kz*z)
!
      if (present(kx)) kx1=kx
      if (present(ky)) ky1=ky
      if (present(kz)) kz1=kz
      if (ampl==0) then
        if (lroot) print*,'sinx_siny_cosz: ampl=0'
      else
        if (lroot) write(*,wave_fmt1) 'sinx_siny_cosz: ampl,kx,ky,kz=', &
                                      ampl,kx1,ky1,kz1
        f(:,:,:,i)=f(:,:,:,i)+ampl*(spread(spread(sin(kx1*x),2,my),3,mz)&
                                   *spread(spread(sin(ky1*y),1,mx),3,mz)&
                                   *spread(spread(cos(kz1*z),1,mx),2,my))
      endif
!
    endsubroutine sinx_siny_cosz
!***********************************************************************
    subroutine x3_siny_cosz(ampl,f,i,x1,x2,ky,kz)
!
!  sinusoidal wave, adapted from sinxsinz (that routine was already doing
!  this, but under a different name)
!
!   8-may-12/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real,optional :: ky,kz
      real :: ampl, ky1=0., kz1=pi/2., x1, x2
!
!  wavenumber k, helicity H=ampl (can be either sign)
!
!  (x-x1)*(x2-x)*sin(kz*z)
!
      if (present(ky)) ky1=ky
      if (present(kz)) kz1=kz
      if (ampl==0) then
        if (lroot) print*,'x3_siny_cosz: ampl=0'
      else
        if (lroot) write(*,wave_fmt1) 'x3_siny_cosz: ampl,ky,kz=', &
                                      ampl,ky1,kz1
        f(:,:,:,i)=f(:,:,:,i)+ampl*(spread(spread((x-x1)*(x2-x),2,my),3,mz)&
                                   *spread(spread(sin(ky1*y),1,mx),3,mz)&
                                   *spread(spread(cos(kz1*z),1,mx),2,my))
      endif
!
    endsubroutine x3_siny_cosz
!***********************************************************************
    subroutine x_siny_cosz(ampl,f,i,kx,ky,kz,xbot, nexp)
!
!  sinusoidal wave, adapted from sinxsinz (that routine was already doing
!  this, but under a different name)
!
!   2-dec-03/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real, optional :: kx, ky, kz, xbot, nexp
      real :: ampl, kx1=pi/2., ky1=0., kz1=pi/2., xbot_, nexp_
!
!  wavenumber k, helicity H=ampl (can be either sign)
!
!  sinx(kx*x)^nexp*sin(kz*z)
!
      if (present(kx)) kx1=kx
      if (present(ky)) ky1=ky
      if (present(kz)) kz1=kz
      if (present(xbot)) then
        xbot_=xbot
      else
        xbot_=0.
      endif
!
!  If nexp=0, we have the usual sin(theta) dependence.
!  To concentrate the field more strongly toward the equator,
!  we can ut nexp=1 or larger. (The actual exponent must be even.)
!
      if (present(nexp)) then
        nexp_=nexp
      else
        nexp_=0.
      endif
!
      if (ampl==0) then
        if (lroot) print*,'x_siny_cosz: ampl=0'
      else
        if (lroot) write(*,wave_fmt1) 'x_siny_cosz: ampl,kx,ky,kz=', &
                                      ampl,kx1,ky1,kz1
        f(:,:,:,i)=f(:,:,:,i)+ampl*(spread(spread((x-xbot_),2,my),3,mz)&
                                   *spread(spread(sin(ky1*y)**(1.+2.*nexp_),1,mx),3,mz)&
                                   *spread(spread(cos(kz1*z),1,mx),2,my))
      endif
!
    endsubroutine x_siny_cosz
!***********************************************************************
    subroutine x1_siny_cosz(ampl,f,i,kx,ky,kz,phasey)
!
!  sinusoidal wave, adapted from sinxsinz (that routine was already doing
!  this, but under a different name)
!
!   2-dec-03/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real,optional :: kx,ky,kz,phasey
      real :: ampl,kx1=pi/2.,ky1=0.,kz1=pi/2., phasey1=0.
!
!  wavenumber k, helicity H=ampl (can be either sign)
!
!  sinx(kx*x)*sin(kz*z)
!
      if (present(kx)) kx1=kx
      if (present(ky)) ky1=ky
      if (present(kz)) kz1=kz
      if (present(phasey)) phasey1=phasey
      if (ampl==0) then
        if (lroot) print*,'x1_siny_cosz: ampl=0'
      else
        if (lroot) write(*,wave_fmt1) 'x1_siny_cosz: ampl,kx,ky,kz=', &
                                      ampl,kx1,ky1,kz1
        f(:,:,:,i)=f(:,:,:,i)+ampl*(spread(spread(   ( 1./x),2,my),3,mz)&
                                   *spread(spread(sin(ky1*y+phasey1),1,mx),3,mz)&
                                   *spread(spread(cos(kz1*z),1,mx),2,my))
      endif
!
    endsubroutine x1_siny_cosz
!***********************************************************************
    subroutine x32_siny_cosz(ampl,f,i,kx,ky,kz,phasey)
!
!  sinusoidal wave, adapted from sinxsinz (that routine was already doing
!  this, but under a different name)
!
!  29-may-24/axel: coded
!
      use General, only: roptest
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real,optional :: kx,ky,kz,phasey
!
      real :: ampl,kx1,ky1,kz1,phasey1
!
!  wavenumber k, helicity H=ampl (can be either sign)
!
!  sinx(kx*x)*sin(kz*z)
!
      if (ampl==0) then
        if (lroot) print*,'x32_siny_cosz: ampl=0'
      else
        kx1 = roptest(kx,pi/2.)
        ky1 = roptest(ky,0.)
        kz1 = roptest(kz,pi/2.)
        phasey1 = roptest(phasey,0.)

        if (lroot) write(*,wave_fmt1) 'x32_siny_cosz: ampl,kx,ky,kz=',ampl,kx1,ky1,kz1
        f(:,:,:,i)=f(:,:,:,i)+ampl*(spread(spread(1./x**3-x**2,2,my),3,mz) &
                                   *spread(spread(sin(ky1*y+phasey1),1,mx),3,mz) &
                                   *spread(spread(cos(kz1*z),1,mx),2,my))
      endif
!
    endsubroutine x32_siny_cosz
!***********************************************************************
    subroutine x1_cosy_cosz(ampl,f,i,kx,ky,kz)
!
!  sinusoidal wave, adapted from sinxsinz (that routine was already doing
!  this, but under a different name)
!
!   1-jul-07/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real,optional :: kx,ky,kz
      real :: ampl,kx1=pi/2.,ky1=0.,kz1=pi/2.
!
!  wavenumber k, 1/x radial profile
!
      if (present(kx)) kx1=kx
      if (present(ky)) ky1=ky
      if (present(kz)) kz1=kz
      if (ampl==0) then
        if (lroot) print*,'x1_siny_cosz: ampl=0'
      else
        if (lroot) write(*,wave_fmt1) 'x1_siny_cosz: ampl,kx,ky,kz=', &
                                      ampl,kx1,ky1,kz1
        f(:,:,:,i)=f(:,:,:,i)+ampl*(spread(spread(   ( 1./x),2,my),3,mz)&
                                   *spread(spread(cos(ky1*y),1,mx),3,mz)&
                                   *spread(spread(cos(kz1*z),1,mx),2,my))
      endif
!
    endsubroutine x1_cosy_cosz
!***********************************************************************
    subroutine lnx_cosy_cosz(ampl,f,i,kx,ky,kz)
!
!  sinusoidal wave, adapted from sinxsinz (that routine was already doing
!  this, but under a different name)
!
!   2-jul-07/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real,optional :: kx,ky,kz
      real :: ampl,kx1=pi/2.,ky1=0.,kz1=pi/2.
!
!  wavenumber k, 1/x radial profile
!
      if (present(kx)) kx1=kx
      if (present(ky)) ky1=ky
      if (present(kz)) kz1=kz
      if (ampl==0) then
        if (lroot) print*,'lnx_cosy_cosz: ampl=0'
      else
        if (lroot) write(*,wave_fmt1) 'lnx_cosy_cosz: ampl,kx,ky,kz=', &
                                      ampl,kx1,ky1,kz1
        f(:,:,:,i)=f(:,:,:,i)+ampl*(spread(spread(log(    x),2,my),3,mz)&
                                   *spread(spread(cos(ky1*y),1,mx),3,mz)&
                                   *spread(spread(cos(kz1*z),1,mx),2,my))
      endif
!
    endsubroutine lnx_cosy_cosz
!***********************************************************************
    subroutine cosx_siny_cosz(ampl,f,i,kx,ky,kz)
!
!  sinusoidal wave, adapted from sinxsinz (that routine was already doing
!  this, but under a different name)
!
!  15-mar-07/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real,optional :: kx,ky,kz
      real :: ampl,kx1=pi/2.,ky1=0.,kz1=pi/2.
!
!  wavenumber k, helicity H=ampl (can be either sign)
!
!  sinx(kx*x)*sin(kz*z)
!
      if (present(kx)) kx1=kx
      if (present(ky)) ky1=ky
      if (present(kz)) kz1=kz
      if (ampl==0) then
        if (lroot) print*,'cosx_siny_cosz: ampl=0'
      else
        if (lroot) write(*,wave_fmt1) 'cosx_siny_cosz: ampl,kx,ky,kz=', &
                                      ampl,kx1,ky1,kz1
        f(:,:,:,i)=f(:,:,:,i)+ampl*(spread(spread(cos(kx1*x),2,my),3,mz)&
                                   *spread(spread(sin(ky1*y),1,mx),3,mz)&
                                   *spread(spread(cos(kz1*z),1,mx),2,my))
      endif
!
    endsubroutine cosx_siny_cosz
!***********************************************************************
    subroutine sinx_cosy_cosz(ampl,f,i,kx,ky,kz)
!
!  sinusoidal wave, adapted from cosx_siny_cosz
!
!  26-mar-25/TP: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real,optional :: kx,ky,kz
      real :: ampl,kx1=pi/2.,ky1=0.,kz1=pi/2.
!
!  wavenumber k, helicity H=ampl (can be either sign)
!
!  sinx(kx*x)*sin(kz*z)
!
      if (present(kx)) kx1=kx
      if (present(ky)) ky1=ky
      if (present(kz)) kz1=kz
      if (ampl==0) then
        if (lroot) print*,'sinx_cosy_cosz: ampl=0'
      else
        if (lroot) write(*,wave_fmt1) 'sinx_cosy_cosz: ampl,kx,ky,kz=', &
                                      ampl,kx1,ky1,kz1
        f(:,:,:,i)=f(:,:,:,i)+ampl*(spread(spread(sin(kx1*x),2,my),3,mz)&
                                   *spread(spread(cos(ky1*y),1,mx),3,mz)&
                                   *spread(spread(cos(kz1*z),1,mx),2,my))
      endif
!
    endsubroutine sinx_cosy_cosz
!***********************************************************************
    subroutine sin2x_sin2y_cosz(ampl,f,i,kx,ky,kz)
!
!  sinusoidal wave, adapted from sinxsinz (that routine was already doing
!  this, but under a different name)
!
!   2-dec-03/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real,optional :: kx,ky,kz
      real :: ampl,kx1=pi/2.,ky1=0.,kz1=pi/2.
!
!  wavenumber k, helicity H=ampl (can be either sign)
!
!  sin2(kx*x)*sin2(kz*z)
!
      if (present(kx)) kx1=kx
      if (present(ky)) ky1=ky
      if (present(kz)) kz1=kz
      if (ampl==0) then
        if (lroot) print*,'sin2x_sin2y_cosz: ampl=0'
      else
        if (lroot) write(*,wave_fmt1) 'sin2x_sin2y_cosz: ampl,kx,ky,kz=',&
                                      ampl,kx1,ky1,kz1
        f(:,:,:,i)=f(:,:,:,i)+ampl*(spread(spread(sin(kx1*x)**2,2,my),3,mz)&
                                   +spread(spread(sin(ky1*y)**2,1,mx),3,mz))&
                                   *spread(spread(cos(kz1*z),1,mx),2,my)
      endif
!
    endsubroutine sin2x_sin2y_cosz
!***********************************************************************
    subroutine cosxz_cosz(ampl,f,i,kx,kz)
!
!  sinusoidal wave, adapted from sinxsinz (that routine was already doing
!  this, but under a different name)
!
!  13-aug-09/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real,optional :: kx,kz
      real :: ampl,kx1=pi/2.,kz1=pi/2.
!
!  wavenumber k, helicity H=ampl (can be either sign)
!
!  sinx(kx*x)*sin(kz*z)
!
      if (present(kx)) kx1=kx
      if (present(kz)) kz1=kz
      if (ampl==0) then
        if (lroot) print*,'cosxz_cosz: ampl=0'
      else
        if (lroot) write(*,wave_fmt1) 'cos(x-cosz): ampl,kx,kz=', &
                                      ampl,kx1,kz1
        f(:,:,:,i)=f(:,:,:,i)+ampl*cos( &
          spread(spread(kx1*x,2,my),3,mz)- &
          spread(spread(cos(kz1*z),1,mx),2,my))
      endif
!
    endsubroutine cosxz_cosz
!***********************************************************************
    subroutine cosyz_sinz(ampl,f,i,ky,kz)
!
!  sinusoidal wave, adapted from sinxsinz (that routine was already doing
!  this, but under a different name)
!
!  13-aug-09/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real,optional :: ky,kz
      real :: ampl,ky1=pi/2.,kz1=pi/2.
!
!  wavenumber k, helicity H=ampl (can be either sign)
!
!  sinx(ky*y)*sin(kz*z)
!
      if (present(ky)) ky1=ky
      if (present(kz)) kz1=kz
      if (ampl==0) then
        if (lroot) print*,'cosyz_sinz: ampl=0'
      else
        if (lroot) write(*,wave_fmt1) 'cos(y-sinz): ampl,ky,kz=', &
                                      ampl,ky1,kz1
        f(:,:,:,i)=f(:,:,:,i)+ampl*cos( &
          spread(spread(ky1*y,1,mx),3,mz)- &
          spread(spread(cos(kz1*z),1,mx),2,my))
      endif
!
    endsubroutine cosyz_sinz
!***********************************************************************
    subroutine cosx_cosy_cosz(ampl,f,i,kx,ky,kz)
!
!  sinusoidal wave, adapted from sinxsinz (that routine was already doing
!  this, but under a different name)
!
!   2-dec-03/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real,optional :: kx,ky,kz
      real :: ampl,kx1=pi/2.,ky1=0.,kz1=pi/2.
!
!  wavenumber k, helicity H=ampl (can be either sign)
!
!  sinx(kx*x)*sin(kz*z)
!
      if (present(kx)) kx1=kx
      if (present(ky)) ky1=ky
      if (present(kz)) kz1=kz
      if (ampl==0) then
        if (lroot) print*,'cosx_cosy_cosz: ampl=0'
      else
        if (lroot) write(*,wave_fmt1) 'cosx_cosy_cosz: ampl,kx,ky,kz=', &
                                      ampl,kx1,ky1,kz1
        f(:,:,:,i)=f(:,:,:,i)+ampl*(spread(spread(cos(kx1*x),2,my),3,mz)&
                                   *spread(spread(cos(ky1*y),1,mx),3,mz)&
                                   *spread(spread(cos(kz1*z),1,mx),2,my))
      endif
!
    endsubroutine cosx_cosy_cosz
!***********************************************************************
    subroutine cosx_cosz(ampl,f,i,kx,kz)
!
!  initial condition for potential field test
!
!  15-aug-09/axel: adapted from cosy_sinz
!
      integer :: i,j
      real, dimension (mx,my,mz,mfarray) :: f
      real,optional :: kx,kz
      real :: ampl,kx1=1.,kz1=pi
!
!  wavenumber k
!
      if (present(kx)) kx1=kx
      if (present(kz)) kz1=kz
!
      j=i; f(:,:,:,j)=f(:,:,:,j)+ampl*spread(spread(cos(kx1*x),2,my),3,mz)&
                                     *spread(spread(cos(kz1*z),1,mx),2,my)
!
    endsubroutine cosx_cosz
!***********************************************************************
    subroutine cosy_cosz(ampl,f,i,ky,kz)
!
!  initial condition for potential field test
!
!   06-oct-06/axel: coded
!   11-oct-06/wolf: modified to only set one component of aa
!
      integer :: i,j
      real, dimension (mx,my,mz,mfarray) :: f
      real,optional :: ky,kz
      real :: ampl,ky1=1.,kz1=pi
!
!  wavenumber k
!
      if (present(ky)) ky1=ky
      if (present(kz)) kz1=kz
!
      j=i; f(:,:,:,j)=f(:,:,:,j)+ampl*spread(spread(cos(ky1*y),1,mx),3,mz)&
                                     *spread(spread(cos(kz1*z),1,mx),2,my)
!
    endsubroutine cosy_cosz
!***********************************************************************
    subroutine cosy_sinz(ampl,f,i,ky,kz)
!
!  initial condition for potential field test
!
!   06-oct-06/axel: coded
!   11-oct-06/wolf: modified to only set one component of aa
!
      integer :: i,j
      real, dimension (mx,my,mz,mfarray) :: f
      real,optional :: ky,kz
      real :: ampl,ky1=1.,kz1=pi
!
!  wavenumber k
!
      if (present(ky)) ky1=ky
      if (present(kz)) kz1=kz
!
      j=i; f(:,:,:,j)=f(:,:,:,j)+ampl*spread(spread(cos(ky1*y),1,mx),3,mz)&
                                     *spread(spread(sin(kz1*z),1,mx),2,my)
!
!  Axel, are you OK with this? If so, I'll eliminate j above.
!
!  Don't do this: we now call this twice from magnetic.f90, and setting
!  just Ax /= 0 makes perfect sense for potential bc tests.
!
!      j=i+1; f(:,:,:,j)=f(:,:,:,j)+ampl*spread(spread(sin(ky1*y),1,mx),3,mz)&
!                                       *spread(spread(cos(kz1*z),1,mx),2,my)
!
    endsubroutine cosy_sinz
!***********************************************************************
    subroutine x3_cosy_cosz(ampl,f,i,ky,kz)
!
!  special initial condition for producing toroidal field (ndynd decay test)
!
!   06-oct-06/axel: coded
!   11-oct-06/wolf: modified to only set one component of aa
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real,optional :: ky,kz
      real :: ampl,ky1=1.,kz1=pi
!
!  wavenumber k
!
      if (present(ky)) ky1=ky
      if (present(kz)) kz1=kz
!
      f(:,:,:,i)=f(:,:,:,i)+ampl*spread(spread(x*(1.-x)*(x-.2),2,my),3,mz)&
                                *spread(spread(cos(ky1*y),1,mx),3,mz)&
                                *spread(spread(cos(kz1*z),1,mx),2,my)
!
    endsubroutine x3_cosy_cosz
!***********************************************************************
    subroutine cosx_coscosy_cosz(ampl,f,i,kx,ky,kz)
!
!  sinusoidal wave, adapted from sinxsinz (that routine was already doing
!  this, but under a different name)
!
!   2-dec-03/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real,optional :: kx,ky,kz
      real :: ampl,kx1=pi/2.,ky1=0.,kz1=pi/2.
!
!  wavenumber k, helicity H=ampl (can be either sign)
!
!  sinx(kx*x)*sin(kz*z)
!
      if (present(kx)) kx1=kx
      if (present(ky)) ky1=ky
      if (present(kz)) kz1=kz
      if (ampl==0) then
        if (lroot) print*,'cosx_cosy_cosz: ampl=0'
      else
        if (lroot) write(*,wave_fmt1) 'cosx_cosy_cosz: ampl,kx,ky,kz=', &
                                      ampl,kx1,ky1,kz1
        f(:,:,:,i)=f(:,:,:,i)+ampl*(spread(spread(cos(kx1*x),2,my),3,mz) &
                                   *spread(spread(-cos(ky1*y)*(          &
                                     ((1./9.)*sin(ky*y)**8)+((8./63.)*   &
                                     sin(ky*y)**6)+((16./105.)*          &
                                     sin(ky*y)**4)+((64./315.)*          &
                                     sin(ky*y)**2)                       &
                                     + (128./315.)                       &
                                    ),1,mx),3,mz)                        &
                                   *spread(spread(cos(kz1*z),1,mx),2,my))
      endif
!
    endsubroutine cosx_coscosy_cosz
!***********************************************************************
    subroutine cos2x_cos2y_cos2z(ampl,f,i,kx,ky,kz)
!
!  sinusoidal wave, adapted from sinxsinz (that routine was already doing
!  this, but under a different name)
!
!  21-feb-08/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real,optional :: kx,ky,kz
      real :: ampl,kx1=1.,ky1=1.,kz1=1.
!
!  wavenumber k, helicity H=ampl (can be either sign)
!
!  sinx(kx*x)*sin(kz*z)
!
      if (present(kx)) kx1=kx
      if (present(ky)) ky1=ky
      if (present(kz)) kz1=kz
      if (ampl==0) then
        if (lroot) print*,'cos2x_cos2y_cos2z: ampl=0'
      else
        if (lroot) write(*,wave_fmt1) 'cos2x_cos2y_cos2z: ampl,kx,ky,kz=', &
                                      ampl,kx1,ky1,kz1
        if (ampl>0.) then
          f(:,:,:,i)=f(:,:,:,i)+ampl*tanh(10.* &
              spread(spread(cos(.5*kx1*x)**2,2,my),3,mz) &
             *spread(spread(cos(.5*ky1*y)**2,1,mx),3,mz) &
             *spread(spread(cos(.5*kz1*z)**2,1,mx),2,my))
        else
          f(:,:,:,i)=f(:,:,:,i)-ampl*(1.-tanh(10.* &
              spread(spread(cos(.5*kx1*x)**2,2,my),3,mz) &
             *spread(spread(cos(.5*ky1*y)**2,1,mx),3,mz) &
             *spread(spread(cos(.5*kz1*z)**2,1,mx),2,my)))
        endif
      endif
!
    endsubroutine cos2x_cos2y_cos2z
!***********************************************************************
    subroutine xpoint(ampl,f,i,x0,y0)
!
! Creates a magnetic X point for a 2D run.
! The vector potential is given by A_z = ampl*(x-x0)*(y -y0)
!
!   9-dec-10/bing: coded
!
      integer, intent(in) :: i
      real, dimension (mx,my,mz,mfarray) ,intent(inout) :: f
      real, intent(in) :: ampl,x0,y0
!
      if (ampl==0) then
        if (lroot) print*,'xpoint: ampl=0'
      else
        f(:,:,n1,i)=ampl*spread(x-x0,2,my)*spread(y-y0,1,mx)
      endif
!
    endsubroutine xpoint
!***********************************************************************
    subroutine xpoint2(ampl,f,i,x0,y0)
!
! Creates a magnetic X point (e.g., for a 2D run);
! The vector potential is given by A_z = (1/2)*ampl*[(x-x0)^2-(y-y0)^2]
!
!  21-may-11/axel: coded
!
      integer, intent(in) :: i
      real, dimension (mx,my,mz,mfarray) ,intent(inout) :: f
      real, intent(in) :: ampl,x0,y0
!
      if (ampl==0) then
        if (lroot) print*,'xpoint: ampl=0'
      else
        f(:,:,n1,i)=.5*ampl*(spread(x-x0,2,my)**2-spread(y-y0,1,mx)**2)
      endif
!
    endsubroutine xpoint2
!***********************************************************************
    subroutine innerbox(ampl,ampl2,f,i,width)
!
!  set background value plus a different value inside a box
!
!   9-mar-08/axel: coded
!
      integer :: i,ll1,ll2,mm1,mm2,nn1,nn2
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,ampl2,width
!
      intent(in)  :: ampl,ampl2,i,width
      intent(out) :: f
!
!  inner box
!
      if (ampl==0.and.ampl2==0) then
        if (lroot) print*,'innerbox: ampl=0'
      else
        if (lroot) write(*,wave_fmt1) 'innerbox: ampl,ampl2,width=', &
                                                 ampl,ampl2,width
        f(:,:,:,i)=ampl
        call find_index_range(x,mx,-width,width,ll1,ll2)
        call find_index_range(y,my,-width,width,mm1,mm2)
        call find_index_range(z,mz,-width,width,nn1,nn2)
        if (lroot) print*,'innerbox: ll1,ll2,mm1,mm2,nn1,nn2=', &
                                     ll1,ll2,mm1,mm2,nn1,nn2
        f(ll1:ll2,mm1:mm2,nn1:nn2,i)=ampl2
      endif
!
    endsubroutine innerbox
!***********************************************************************
    subroutine couette(ampl,mu,f,i)
!
!   couette flow,  Omega = a + b/r^2
!
!   12-jul-07/mgellert: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl, mu, omegao, omegai, rinner, router, a, b
!
      rinner=xyz0(1)
      router=xyz1(1)
      omegai=ampl
      omegao=ampl*mu
!
      if (ampl==0) then
        if (lroot) print*,'couette flow: omegai=0'
      else
        if (lroot) write(*,wave_fmt1) 'couette flow: omegai,omegao=', omegai,omegao
        a = ( (omegao/omegai) - (rinner/router)**2 ) / ( 1. - (rinner/router)**2 ) * omegai
        b = ( ( 1. - (omegao/omegai) ) / ( 1. - (rinner/router)**2 ) ) * rinner**2 * omegai
        f(:,:,:,i)=f(:,:,:,i)+spread(spread((a*x + b/x),2,my),3,mz)
      endif
!
    endsubroutine couette
!***********************************************************************
    subroutine couette_rings(ampl,mu,nr,om_nr,gap,f,i)
!
!   * (finite) couette flow  with top/bottom split in several rings
!   * can be used with the 'freeze' condition for top/bottom BCs
!   * gap is the width of the gap between two rings filled with a tanh smoothing profile
!     (in experiments you usually have something around gap=0.05*D)
!
!   18-jul-07/mgellert: coded
!   21-aug-07/mgellert: made compatible with nprocx>1
!   09-oct-07/mgellert: smoothing profile between neighboring rings added
!
      integer                           :: i, k, l, nr
      real, dimension (nr)               :: om_nr, xsteps
      real, dimension (nr+2)             :: om_all, om_diff
      real, dimension (:), allocatable   :: omx
      real, dimension (mx,my,mz,mfarray) :: f
      real                              :: ampl, mu, gap, omegao, omegai, rinner, router, step
      real                              :: x0, y0
      character(len=20)                 :: unfmt
!
      rinner=xyz0(1)
      router=xyz1(1)
      omegai=ampl
      omegao=ampl*mu
!
      allocate(omx(mx))
      omx=0.
!
      step=(router-rinner)/nr
      do k=1,nr
        xsteps(k)=rinner+k*step-gap/2. ! ring boundaries
      enddo
!
      if (gap>tini) then
        om_all(1)=omegai
        om_all(2:nr+1)=om_nr
        om_all(nr+2)=omegao
        om_diff=0.
        om_diff(1:nr+1)=om_all(1:nr+1)-om_all(2:nr+2) ! difference in omega from ring to ring
        omx(l1:l2)=omegai
        do k=1,nr+1
          if (k==1) then
            x0=rinner+gap/2.
          else
            x0=rinner+(k-1)*step-gap/2.
          endif
          y0=0.5*om_diff(k)
          omx(l1:l2) = omx(l1:l2) - ( y0*(1.+tanh((x(l1:l2)-x0)/(0.15*gap+tini))) );
        enddo
      else
        do l=l1,l2
          k=nr
          do while (k>0)
            if (x(l)<=xsteps(k)) omx(l)=om_nr(k)*omegai
            k=k-1
          enddo
        enddo
      endif
!
      if (ampl==0) then
        if (lroot) print*,'couette flow with rings: omegai=0'
      else
        write(unfmt,FMT='(A12,1I2.2,A6)') '(A19,I2,A24,',nr,'2F7.3)'
        if (lroot) write(*,FMT=unfmt) 'couette flow with ',nr,' rings: omegai,omegao = ', omegai,omegao
        write(unfmt,FMT='(A12,1I2.2,A5)') '(A19,I2,A24,',nr,'F7.3)'
        if (lroot) write(*,FMT=unfmt) 'couette flow with ',nr,' rings: omega_rings   = ',om_nr*omegai
        if (lroot) write(*,FMT=unfmt) 'couette flow with ',nr,' rings: radius_rings  = ',xsteps
        f(:,:,:,i)=f(:,:,:,i)+spread(spread((omx*x),2,my),3,mz) ! velocity up=omx*x
      endif
!
      if (allocated(omx)) deallocate(omx)
!
    endsubroutine couette_rings
!***********************************************************************
    subroutine hat(ampl,f,i,width,kx,ky,kz)
!
!  hat bump
!
!   2-may-03/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real,optional :: kx,ky,kz
      real :: ampl,width,k=1.,width2,k2
!
!  prepare
!
      width2=width**2
!
!  set x-hat
!
      if (present(kx)) then
        k=kx
        k2=k**2
        if (ampl==0) then
          if (lroot) print*,'hat: ampl=0; kx=',k
        else
          if (lroot) print*,'hat: kx,i,ampl=',k,i,ampl
          f(:,:,:,i)=f(:,:,:,i)+ampl*spread(spread(.5+.5*tanh(k2*(width2-x**2)),2,my),3,mz)
        endif
      endif
!
!  set y-hat
!
      if (present(ky)) then
        k=ky
        k2=k**2
        if (ampl==0) then
          if (lroot) print*,'hat: ampl=0; ky=',k
        else
          if (lroot) print*,'hat: ky,i,ampl=',k,i,ampl
          f(:,:,:,i)=f(:,:,:,i)+ampl*spread(spread(.5+.5*tanh(k2*(width2-y**2)),1,mx),3,mz)
        endif
      endif
!
!  set z-hat
!
      if (present(kz)) then
        k=kz
        k2=k**2
        if (ampl==0) then
          if (lroot) print*,'hat: ampl=0; kz=',k
        else
          if (lroot) print*,'hat: kz,i,ampl=',k,i,ampl
          f(:,:,:,i)=f(:,:,:,i)+ampl*spread(spread(.5+.5*tanh(k2*(width2-z**2)),1,mx),2,my)
        endif
      endif
!
    endsubroutine hat
!***********************************************************************
    subroutine hat3d(ampl,f,i,width,kx,ky,kz)
!
!  Three-dimensional hat bump
!
!   9-nov-04/anders: coded
!
      integer :: i,l
      real, dimension (mx,my,mz,mfarray) :: f
      real :: kx,ky,kz,kx2,ky2,kz2
      real :: ampl,width,width2
!
!  set hat
!
      if (lroot) print*,'hat3d: kx,ky,kz=',kx,ky,kz
      if (ampl==0) then
        if (lroot) print*,'hat3d: ampl=0'
      else
        if (lroot) print*,'hat3d: ampl=',ampl
        width2=width**2
        kx2=kx**2
        ky2=ky**2
        kz2=kz**2
        do l=l1,l2; do m=m1,m2; do n=n1,n2
            f(l,m,n,i) = f(l,m,n,i) + ampl*( &
                (0.5+0.5*tanh(kx2*(width2-x(l)**2))) * &
                (0.5+0.5*tanh(ky2*(width2-y(m)**2))) * &
                (0.5+0.5*tanh(kz2*(width2-z(n)**2))) )
        enddo; enddo; enddo
      endif
!
    endsubroutine hat3d
!***********************************************************************
    subroutine gaussian(ampl,f,i,kx,ky,kz)
!
!  gaussian bump
!
!   2-may-03/axel: coded
!  20-sep-03/axel: added 1/2 factor in defn; hopefully ok with everyone?
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real,optional :: kx,ky,kz
      real :: ampl,k=1.
!
!  wavenumber k
!
!  set x-wave
!
      if (present(kx)) then
        k=kx
        if (ampl==0) then
          if (lroot) print*,'gaussian: ampl=0; kx=',k
        else
          if (lroot) print*,'gaussian: kx,i=',k,i
          f(:,:,:,i)=f(:,:,:,i)+ampl*spread(spread(exp(-.5*(k*x)**2),2,my),3,mz)
        endif
      endif
!
!  set y-wave
!
      if (present(ky)) then
        k=ky
        if (ampl==0) then
          if (lroot) print*,'gaussian: ampl=0; ky=',k
        else
          if (lroot) print*,'gaussian: ky,i=',k,i
          f(:,:,:,i)=f(:,:,:,i)+ampl*spread(spread(exp(-.5*(k*y)**2),1,mx),3,mz)
        endif
      endif
!
!  set z-wave
!
      if (present(kz)) then
        k=kz
        if (ampl==0) then
          if (lroot) print*,'gaussian: ampl=0; kz=',k
        else
          if (lroot) print*,'gaussian: kz,i=',k,i
          f(:,:,:,i)=f(:,:,:,i)+ampl*spread(spread(exp(-.5*(k*z)**2),1,mx),2,my)
        endif
      endif
!
    endsubroutine gaussian
!***********************************************************************
    subroutine gaussian3d(ampl,f,i,radius)
!
!  gaussian 3-D bump
!
!  28-may-03/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,radius,radius21
!
      radius21=1./radius**2
      do n=n1,n2; do m=m1,m2
        f(l1:l2,m,n,i)=f(l1:l2,m,n,i)+ampl*exp(-(x(l1:l2)**2+y(m)**2+z(n)**2)*radius21)
      enddo; enddo
!
    endsubroutine gaussian3d
!***********************************************************************
    subroutine gaussianpos(ampl,f,i,radius,posx,posy,posz,prefac,slope)
!
!  gaussian 3-D bump centered in specific position
!
!  21-sep-09/rplasson: coded from gaussian3d
!  Maybe could have been done by extending gaussian3d, but didn't want to interfere
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,radius,posx, posy, posz, radius21, alp
      real, dimension (nx) :: phase_factor
      real, optional :: slope
      character(len=*), optional :: prefac
!
!  compute slope
!
      if (present(slope)) then
        alp=slope
      else
        alp=-1.
      endif
!
!  compute phase_factor
!
      radius21=1./radius**2
      do n=n1,n2; do m=m1,m2
        if (present(prefac)) then
          select case (prefac)
          case ('cosx'); phase_factor=+cos(alp*x(l1:l2))
          case ('sinx'); phase_factor=-sin(alp*x(l1:l2))
          case default; phase_factor=1.
          endselect
        else
          phase_factor=1.
        endif
!
!  add Gaussian blob to f(l1:l2,m,n,i) with phase_factor
!
        f(l1:l2,m,n,i)=f(l1:l2,m,n,i)+ampl*phase_factor &
            *exp(-((x(l1:l2)-posx)**2+(y(m)-posy)**2+(z(n)-posz)**2)*radius21)
!        do l=l1,l2
!          print*,"c(",x(l),",",y(m),",",z(n),")=", f(l,m,n,i)
!        enddo
      enddo; enddo
!
    endsubroutine gaussianpos
!***********************************************************************
    subroutine parabola(ampl,f,i,kx,ky,kz)
!
!  gaussian bump
!
!   2-may-03/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real, optional :: kx,ky,kz
      real :: ampl,k=1.
!
!  wavenumber k
!
!  set x-wave
!
      if (present(kx)) then
        k=kx
        if (ampl==0) then
          if (lroot) print*,'parabola: ampl=0; kx=',k
        else
          if (lroot) print*,'parabola: kx,i=',k,i
          f(:,:,:,i)=f(:,:,:,i)+ampl*spread(spread((-(k*x)**2),2,my),3,mz)
        endif
      endif
!
!  set y-wave
!
      if (present(ky)) then
        k=ky
        if (ampl==0) then
          if (lroot) print*,'parabola: ampl=0; ky=',k
        else
          if (lroot) print*,'parabola: ky,i=',k,i
          f(:,:,:,i)=f(:,:,:,i)+ampl*spread(spread((-(k*y)**2),1,mx),3,mz)
        endif
      endif
!
!  set z-wave
!
      if (present(kz)) then
        k=kz
        if (ampl==0) then
          if (lroot) print*,'parabola: ampl=0; kz=',k
        else
          if (lroot) print*,'parabola: kz,i=',k,i
          f(:,:,:,i)=f(:,:,:,i)+ampl*spread(spread((-(k*z)**2),1,mx),2,my)
        endif
      endif
!
    endsubroutine parabola
!***********************************************************************
    subroutine wave(ampl,f,i,kx,ky,kz)
!
!  sinusoidal wave
!
!   6-jul-02/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real, optional :: kx,ky,kz
      real :: ampl,k=1.
!
!  wavenumber k
!
!  set x-wave
!
      if (present(kx)) then
        k=kx
        if (ampl==0) then
          if (lroot) print*,'wave: ampl=0; kx=',k
        else
          if (lroot) print*,'wave: kx,i=',k,i
          f(:,:,:,i)=f(:,:,:,i)+ampl*spread(spread(sin(k*x),2,my),3,mz)
        endif
      endif
!
!  set y-wave
!
      if (present(ky)) then
        k=ky
        if (ampl==0) then
          if (lroot) print*,'wave: ampl=0; ky=',k
        else
          if (lroot) print*,'wave: ky,i=',k,i
          f(:,:,:,i)=f(:,:,:,i)+ampl*spread(spread(sin(k*y),1,mx),3,mz)
        endif
      endif
!
!  set z-wave
!
      if (present(kz)) then
        k=kz
        if (ampl==0) then
          if (lroot) print*,'wave: ampl=0; kz=',k
        else
          if (lroot) print*,'wave: kz,i=',k,i
          f(:,:,:,i)=f(:,:,:,i)+ampl*spread(spread(sin(k*z),1,mx),2,my)
        endif
      endif
!
    endsubroutine wave
!***********************************************************************
    subroutine linprof(ampl,f,i,kx,ky,kz)
!
!  periodic linear profile
!
!  21-sep-09/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real, optional :: kx,ky,kz
      real :: ampl,k=1.
!
!  wavenumber k
!
!  set x-linprof
!
      if (present(kx)) then
        k=kx
        if (ampl==0) then
          if (lroot) print*,'linprof: ampl=0; kx=',k
        else
          if (lroot) print*,'linprof: kx,i=',k,i
          f(:,:,:,i)=f(:,:,:,i)+ampl*spread(spread(asin(sin(k*x)),2,my),3,mz)
        endif
      endif
!
!  set y-linprof
!
      if (present(ky)) then
        k=ky
        if (ampl==0) then
          if (lroot) print*,'linprof: ampl=0; ky=',k
        else
          if (lroot) print*,'linprof: ky,i=',k,i
          f(:,:,:,i)=f(:,:,:,i)+ampl*spread(spread(asin(sin(k*y)),1,mx),3,mz)
        endif
      endif
!
!  set z-linprof
!
      if (present(kz)) then
        k=kz
        if (ampl==0) then
          if (lroot) print*,'linprof: ampl=0; kz=',k
        else
          if (lroot) print*,'linprof: kz,i=',k,i
          f(:,:,:,i)=f(:,:,:,i)+ampl*spread(spread(asin(sin(k*z)),1,mx),2,my)
        endif
      endif
!
    endsubroutine linprof
!***********************************************************************
    subroutine wave_uu(ampl,f,i,kx,ky,kz)
!
!  sinusoidal wave
!
!  14-apr-03/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real, optional :: kx,ky,kz
      real :: ampl,k=1.
!
!  wavenumber k
!
!  set x-wave
!
      if (present(kx)) then
        k=kx
        if (ampl==0) then
          if (lroot) print*,'wave_uu: ampl=0; kx=',k
        else
          if (lroot) print*,'wave_uu: kx,i=',k,i
          f(:,:,:,i)=log(1.+ampl*spread(spread(sin(k*x),2,my),3,mz)*f(:,:,:,iux))
        endif
      endif
!
!  set y-wave
!
      if (present(ky)) then
        k=ky
        if (ampl==0) then
          if (lroot) print*,'wave_uu: ampl=0; ky=',k
        else
          if (lroot) print*,'wave_uu: ky,i=',k,i
          f(:,:,:,i)=log(1.+ampl*spread(spread(sin(k*y),1,mx),3,mz)*f(:,:,:,iuy))
        endif
      endif
!
!  set z-wave
!
      if (present(kz)) then
        k=kz
        if (ampl==0) then
          if (lroot) print*,'wave_uu: ampl=0; kz=',k
        else
          if (lroot) print*,'wave_uu: kz,i=',k,i,iuz
          f(:,:,:,i)=log(1.+ampl*spread(spread(sin(k*z),1,mx),2,my)*f(:,:,:,iuz))
        endif
      endif
!
    endsubroutine wave_uu
!***********************************************************************
    subroutine acosy(ampl,f,i,ky)
!
!  mode
!
!  30-oct-03/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,ky
!
      do n=n1,n2; do m=m1,m2
        f(l1:l2,m,n,i)=ampl*cos(ky*y(m))
        f(l1:l2,m,n,i+1)=0.
        f(l1:l2,m,n,i+2)=0
      enddo; enddo
!
    endsubroutine acosy
!***********************************************************************
    subroutine modes(ampl,coef,f,i,kx,ky,kz)
!
!  mode
!
!  30-oct-03/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      complex :: coef
      complex :: ii=(0.,1.)
      real :: ampl,kx,ky,kz
!
      do n=n1,n2; do m=m1,m2
        f(l1:l2,m,n,i)=ampl*real(coef*exp(ii*(kx*x(l1:l2)+ky*y(m)+kz*z(n))))
      enddo; enddo
!
    endsubroutine modes
!***********************************************************************
    subroutine modev(ampl,coef,f,i,kx,ky,kz)
!
!  mode
!
!  30-oct-03/axel: coded
!
      integer :: i,ivv
      real, dimension (mx,my,mz,mfarray) :: f
      complex, dimension (3) :: coef
      complex :: ii=(0.,1.)
      real :: ampl,kx,ky,kz
!
      do n=n1,n2; do m=m1,m2
        do ivv=0,2
          f(l1:l2,m,n,ivv+i)=ampl*real(coef(ivv+1)*exp(ii*(kx*x(l1:l2)+ky*y(m)+kz*z(n))))
        enddo
      enddo;enddo
!
    endsubroutine modev
!***********************************************************************
    subroutine modeb(ampl,coefb,f,i,kx,ky,kz)
!
!  mode
!
!  30-oct-03/axel: coded
!
      integer :: i,ivv
      real, dimension (mx,my,mz,mfarray) :: f
      complex, dimension (3) :: coef,coefb
      complex :: ii=(0.,1.)
      real :: ampl,kx,ky,kz,k2
!
      print*,'print Ak coefficients from Bk coefficients'
      k2=kx**2+ky**2+kz**2
      coef(1)=(ky*coefb(3)-kz*coefb(2))/k2
      coef(2)=(kz*coefb(1)-kx*coefb(3))/k2
      coef(3)=(kx*coefb(2)-ky*coefb(1))/k2
      print*,'coef=',coef
!
      do n=n1,n2; do m=m1,m2
        do ivv=0,2
          f(l1:l2,m,n,ivv+i)=ampl*real(coef(ivv+1)*exp(ii*(kx*x(l1:l2)+ky*y(m)+kz*z(n))))
        enddo
      enddo; enddo
!
    endsubroutine modeb
!***********************************************************************
    subroutine jump(f,i,fleft,fright,width,xmid,ymid,zmid,dir)
!
!  jump
!
!  19-sep-02/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (mx,my) :: profxy
      real, dimension (mx) :: profx
      real, dimension (my) :: profy
      real, dimension (mz) :: profz
      real :: fleft,fright,width
      real :: xmid,ymid,zmid
      character(len=*) :: dir
      integer :: l,m
!
!  jump; check direction
!
      select case (dir)
!
      case ('x')
        profx=fleft+(fright-fleft)*.5*(1.+tanh((x-xmid)/width))
        f(:,:,:,i)=f(:,:,:,i)+spread(spread(profx,2,my),3,mz)
!
      case ('y')
        profy=fleft+(fright-fleft)*.5*(1.+tanh((y-ymid)/width))
        f(:,:,:,i)=f(:,:,:,i)+spread(spread(profy,1,mx),3,mz)
!
      case ('z')
        profz=fleft+(fright-fleft)*.5*(1.+tanh((z-zmid)/width))
        f(:,:,:,i)=f(:,:,:,i)+spread(spread(profz,1,mx),2,my)
!
!  2-D shocks
!
      case ('xy')
        do l=1,mx
        do m=1,my
          profxy(l,m)=fleft+(fright-fleft)*.25* &
            (1.+tanh((x(l)-xmid)/width))*(1.+tanh((y(m)-ymid)/width))
        enddo
        enddo
        f(:,:,:,i)=f(:,:,:,i)+spread(profxy,3,mz)
!
!  2-D diagonal shocks
!
      case ('x-y')
        do l=1,mx
        do m=1,my
          profxy(l,m)=fleft+(fright-fleft)*.5*(1.+tanh(((x(l)-xmid)+(y(m)-ymid))/width))
        enddo
        enddo
        f(:,:,:,i)=f(:,:,:,i)+spread(profxy,3,mz)
!
      case default
        print*,'jump: no default value'
!
      endselect
!
    endsubroutine jump
!***********************************************************************
    subroutine bjump(f,i,fyleft,fyright,fzleft,fzright,width,dir)
!
!  jump in B-field (in terms of magnetic vector potential)
!
!   9-oct-02/wolf+axel: coded
!  21-apr-05/axel: added possibility of Bz component
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (mx) :: profy,profz,alog_cosh_xwidth
      real :: fyleft,fyright,fzleft,fzright,width
      character(len=*) :: dir
!
!  jump; check direction
!
      select case (dir)
!
!  use correct signs when calling this routine
!  Ay=+int Bz dx
!  Az=-int By dx
!
!  alog(cosh(x/width)) =
!
      case ('x')
        alog_cosh_xwidth=abs(x/width)+log(.5*(1.+exp(-2*abs(x/width))))
        profz=.5*(fyright+fyleft)*x &
             +.5*(fyright-fyleft)*width*alog_cosh_xwidth
        profy=.5*(fzright+fzleft)*x &
             +.5*(fzright-fzleft)*width*alog_cosh_xwidth
        f(:,:,:,i+1)=f(:,:,:,i+1)+spread(spread(profy,2,my),3,mz)
        f(:,:,:,i+2)=f(:,:,:,i+2)-spread(spread(profz,2,my),3,mz)
!
      case default
        print*,'bjump: no default value'
!
      endselect
!
    endsubroutine bjump
!***********************************************************************
    subroutine bjumpz(f,i,fxleft,fxright,fyleft,fyright,width,dir)
!
!  jump in B-field (in terms of magnetic vector potential)
!
!   9-oct-02/wolf+axel: coded
!  21-apr-05/axel: added possibility of Bz component
!
      integer :: i,il,im
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (mz) :: profx,profy,alog_cosh_zwidth
      real :: fyleft,fyright,fxleft,fxright,width
      character(len=*) :: dir
!
      select case (dir)
      case ('z')
        alog_cosh_zwidth=abs(z/width)+log(.5*(1.+exp(-2*abs(z/width))))
        profx=.5*(fyright+fyleft)*z &
             +.5*(fyright-fyleft)*width*alog_cosh_zwidth
        profy=.5*(fxright+fxleft)*z &
             +.5*(fxright-fxleft)*width*alog_cosh_zwidth
        do il=1,mx
        do im=1,my
          f(il,im,:,i ) =f(il,im,:,i  )+profx
          f(il,im,:,i+1)=f(il,im,:,i+1)-profy
        enddo
        enddo
      case default
        print*,'bjump: no default value'
!
      endselect
!
    endsubroutine bjumpz
!***********************************************************************
    subroutine beltrami_old(ampl,f,i,kx,ky,kz,kx2,ky2,kz2,phase)
!
!  Beltrami field (as initial condition)
!
!  19-jun-02/axel: coded
!   5-jul-02/axel: made additive (if called twice), kx,ky,kz are optional
!
      integer :: i,j
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (mx) :: sfuncx,cfuncx
      real, dimension (my) :: sfuncy,cfuncy
      real, dimension (mz) :: sfuncz,cfuncz
      real, optional :: kx,ky,kz,kx2,ky2,kz2,phase
      real :: ampl,k=1.,ph
!
!  This routine should be removed by 2020
!
      call fatal_error('beltrami_old','email Axel if you need this routine')
!
!  possibility of shifting the Beltrami wave by phase ph
!
      if (present(phase)) then
        if (lroot) print*,'Beltrami: phase=',phase
        ph=phase
      else
        ph=0.
      endif
!
!  wavenumber k, helicity H=ampl (can be either sign)
!
!  set x-dependent Beltrami field
!
      if (present(kx)) then
        k=abs(kx)
        if (k==0) print*,'beltrami_old: k must not be zero!'
        cfuncx=sign(sqrt(abs(ampl/k)),kx)*cos(k*x+ph)
        sfuncx=sign(sqrt(abs(ampl/k)),kx)*sin(k*x+ph)
        if (present(kx2)) sfuncx=sfuncx*sin(kx2*x+ph)
        if (ampl==0) then
          if (lroot) print*,'beltrami_old: ampl=0; kx=',k
        elseif (ampl>0) then
          if (lroot) print*,'beltrami_old: Beltrami field (pos-hel): kx,i=',k,i
          j=i+1; f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncx,2,my),3,mz)
          j=i+2; f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncx,2,my),3,mz)
        elseif (ampl<0) then
          if (lroot) print*,'beltrami_old: Beltrami field (neg-hel): kx,i=',k,i
          j=i+1; f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncx,2,my),3,mz)
          j=i+2; f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncx,2,my),3,mz)
        endif
      endif
!
!  set y-dependent Beltrami field
!
      if (present(ky)) then
        k=abs(ky)
        if (k==0) print*,'beltrami_old: k must not be zero!'
        cfuncy=sign(sqrt(abs(ampl/k)),ky)*cos(k*y+ph)
        sfuncy=sign(sqrt(abs(ampl/k)),ky)*sin(k*y+ph)
        if (present(ky2)) sfuncy=sfuncy*sin(ky2*y+ph)
        if (ampl==0) then
          if (lroot) print*,'beltrami_old: ampl=0; ky=',k
        elseif (ampl>0) then
          if (lroot) print*,'beltrami_old: Beltrami field (pos-hel): ky,i=',k,i
          j=i;   f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncy,1,mx),3,mz)
          j=i+2; f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncy,1,mx),3,mz)
        elseif (ampl<0) then
          if (lroot) print*,'beltrami_old: Beltrami field (neg-hel): ky,i=',k,i
          j=i;   f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncy,1,mx),3,mz)
          j=i+2; f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncy,1,mx),3,mz)
        endif
      endif
!
!  set z-dependent Beltrami field
!
      if (present(kz)) then
        k=abs(kz)
        if (k==0) print*,'beltrami_old: k must not be zero!'
        cfuncz=sign(sqrt(abs(ampl/k)),kz)*cos(k*z+ph)
        sfuncz=sign(sqrt(abs(ampl/k)),kz)*sin(k*z+ph)
        if (present(kz2)) sfuncz=sfuncz*sin(kz2*z+ph)
        if (ampl==0) then
          if (lroot) print*,'beltrami_old: ampl=0; kz=',k
        elseif (ampl>0) then
          if (lroot) print*,'beltrami_old: Beltrami field (pos-hel): kz,i=',k,i
          j=i;   f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncz,1,mx),2,my)
          j=i+1; f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncz,1,mx),2,my)
        elseif (ampl<0) then
          if (lroot) print*,'beltrami_old: Beltrami field (neg-hel): kz,i=',k,i
          j=i;   f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncz,1,mx),2,my)
          j=i+1; f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncz,1,mx),2,my)
        endif
      endif
!
    endsubroutine beltrami_old
!***********************************************************************
    subroutine ABC_field(f,i,kx,ky,kz,ABC,x0,y0,z0,width,sigma)
!
!  ABC field (as initial condition)
!
!  24-aug-19/axel: coded
!
      use Sub, only: cubic_step
!
      integer :: i,j,l,m,n
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (mx) :: sfuncx,cfuncx,xprof
      real, dimension (my) :: sfuncy,cfuncy,yprof
      real, dimension (mz) :: sfuncz,cfuncz,zprof
      real, dimension (3) :: ABC, width
      real :: kx,ky,kz, x0,y0,z0, prof, sigma1
      real, optional :: sigma
!
      if (present(sigma)) then
        sigma1=sigma
      else
        sigma1=1.
      endif
!
!  Envelope profile (can turn it off by setting x0=0.).
!
      if (lroot) print*,'ABC_field: x0,width=',x0,width(1)
      if (x0>0.) then
        xprof=cubic_step(x,-x0,width(1))-cubic_step(x,x0,width(1))
        if (lroot) print*,'xprof=',xprof
      else
        xprof=1.
      endif
!
!  Envelope profile (can turn it off by setting y0=0.).
!
      if (lroot) print*,'ABC_field: y0,width=',y0,width(2)
      if (y0>0.) then
        yprof=cubic_step(y,-y0,width(2))-cubic_step(y,y0,width(2))
        if (lroot) print*,'yprof=',yprof
      else
        yprof=1.
      endif
!
!  Envelope profile (can turn it off by setting z0=0.).
!
      if (lroot) print*,'ABC_field: z0,width=',z0,width(3)
      if (z0>0.) then
        zprof=cubic_step(z,-z0,width(3))-cubic_step(z,z0,width(3))
        if (lroot) print*,'zprof=',zprof
      else
        zprof=1.
      endif
!
!  Set x-dependent part of ABC field.
!
      sfuncx=ABC(2)*sin(kx*x)*xprof
      cfuncx=ABC(2)*cos(kx*x)*xprof
!
!  Set y-dependent part of ABC field.
!
      sfuncy=ABC(3)*sin(ky*y)*yprof
      cfuncy=ABC(3)*cos(ky*y)*yprof
!
!  Set z-dependent part of ABC field.
!
      sfuncz=ABC(1)*sin(kz*z)*zprof
      cfuncz=ABC(1)*cos(kz*z)*zprof
!
      do n=n1,n2
      do m=m1,m2
      do l=l1,l2
        prof=xprof(l)*yprof(m)*zprof(n)
        j=i  ; f(l,m,n,j)=f(l,m,n,j)+prof*(sigma1*sfuncz(n)+cfuncy(m))
        j=i+1; f(l,m,n,j)=f(l,m,n,j)+prof*(sigma1*sfuncx(l)+cfuncz(n))
        j=i+2; f(l,m,n,j)=f(l,m,n,j)+prof*(sigma1*sfuncy(m)+cfuncx(l))
      enddo
      enddo
      enddo
!
    endsubroutine ABC_field
!***********************************************************************
    subroutine beltrami(ampl,f,i,kx,ky,kz,kx2,ky2,kz2,phase,sigma,z0,width)
!
!  Beltrami field (as initial condition)
!
!  19-jun-02/axel: coded
!   5-jul-02/axel: made additive (if called twice), kx,ky,kz are optional
!
      use Sub, only: cubic_step
!
      integer :: i,j
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (mx) :: sfuncx,cfuncx
      real, dimension (my) :: sfuncy,cfuncy
      real, dimension (mz) :: sfuncz,cfuncz,zprof
      real, optional :: kx,ky,kz,kx2,ky2,kz2,phase,sigma,z0,width
      real :: ampl,k,ph,sig
!
!  possibility of shifting the Beltrami wave by phase ph
!
      if (present(phase)) then
        if (lroot) print*,'Beltrami: phase=',phase
        ph=phase
      else
        ph=0.
      endif
!
!  possibility of a fractional helicity
!
      if (present(sigma)) then
        if (lroot) print*,'Beltrami: sigma=',sigma
        sig=sigma
      else
        sig=1.
      endif
!
!  possibility of envelope profile
!
      if (present(z0)) then
        if (.not.present(width)) call fatal_error('beltrami','width?')
        if (lroot) print*,'Beltrami: z0,width=',z0,width
        if (z0>0.) then
          zprof=cubic_step(z,-z0,width)-cubic_step(z,z0,width)
        else
          zprof=1.
        endif
      else
        zprof=1.
      endif
!
!  wavenumber k, helicity H=ampl (can be either sign)
!
!  set x-dependent Beltrami field
!
      if (present(kx)) then
        k=kx
        if (k==0) print*,'beltrami: k must not be zero!'
        cfuncx=ampl*cos(k*x+ph)
        sfuncx=ampl*sin(k*x+ph)
        if (present(kx2)) sfuncx=sfuncx*sin(kx2*x+ph)
        if (ampl==0) then
          if (lroot) print*,'beltrami: ampl=0; kx=',k
        elseif (ampl>0) then
          if (lroot) print*,'beltrami: Beltrami field (pos-hel): kx,i=',k,i
          j=i+1; f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncx,2,my),3,mz)*sig
          j=i+2; f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncx,2,my),3,mz)
        elseif (ampl<0) then
          if (lroot) print*,'beltrami: Beltrami field (neg-hel): kx,i=',k,i
          j=i+1; f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncx,2,my),3,mz)
          j=i+2; f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncx,2,my),3,mz)*sig
        endif
      endif
!
!  set y-dependent Beltrami field
!
      if (present(ky)) then
        k=ky
        if (k==0) print*,'beltrami: k must not be zero!'
        cfuncy=ampl*cos(k*y+ph)
        sfuncy=ampl*sin(k*y+ph)
        if (present(ky2)) sfuncy=sfuncy*sin(ky2*y+ph)
        if (ampl==0) then
          if (lroot) print*,'beltrami: ampl=0; ky=',k
        elseif (ampl>0) then
          if (lroot) print*,'beltrami: Beltrami field (pos-hel): ky,i=',k,i
          j=i;   f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncy,1,mx),3,mz)
          j=i+2; f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncy,1,mx),3,mz)*sig
        elseif (ampl<0) then
          if (lroot) print*,'beltrami: Beltrami field (neg-hel): ky,i=',k,i
          j=i;   f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncy,1,mx),3,mz)*sig
          j=i+2; f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncy,1,mx),3,mz)
        endif
      endif
!
!  set z-dependent Beltrami field
!
      if (present(kz)) then
        k=kz
        if (k==0) print*,'beltrami: k must not be zero!'
        cfuncz=ampl*cos(k*z+ph)*zprof
        sfuncz=ampl*sin(k*z+ph)*zprof
        if (present(kz2)) sfuncz=sfuncz*sin(kz2*z+ph)
        if (ampl==0) then
          if (lroot) print*,'beltrami: ampl=0; kz=',k
        elseif (ampl>0) then
          if (lroot) print*,'beltrami: Beltrami field (pos-hel): kz,i=',k,i
          j=i;   f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncz,1,mx),2,my)*sig
          j=i+1; f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncz,1,mx),2,my)
        elseif (ampl<0) then
          if (lroot) print*,'beltrami: Beltrami field (neg-hel): kz,i=',k,i
          j=i;   f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncz,1,mx),2,my)
          j=i+1; f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncz,1,mx),2,my)*sig
        endif
      endif
!
    endsubroutine beltrami
!***********************************************************************
    subroutine beltramik_general(ampl,f,i,kx,ky,kz,phase)
!
!  Beltrami field (as initial condition)
!  Currently not additive
!
!  16-apr-21/axel: coded
!
      integer :: i,j
      real, dimension (mx,my,mz,mfarray) :: f
      integer :: kx, ky, kz
      real :: ampl, phase
      complex :: phase_factor_x
!
!  preparations; j is the first index of the array for the complex part.
!  phase_factor is the phase factor.
!
      j=i+3
      phase_factor_x=exp(cmplx(0.,phase+xyz0(1)))
!
      if (kx>0.and.kx<=nx-1) then
        if (ipx==0) then
          f(l1+kx,m1,n1,i+1)=+ampl*real(phase_factor_x)
          f(l1+kx,m1,n1,j+2)=-ampl*real(phase_factor_x)
        endif
!
        if (ipx==nprocx-1) then
          f(l2+1-kx,m1,n1,i+1)=+ampl*aimag(phase_factor_x)
          f(l2+1-kx,m1,n1,j+2)=+ampl*aimag(phase_factor_x)
        endif
      endif
!
    endsubroutine beltramik_general
!***********************************************************************
    subroutine beltrami_general(ampl,f,i,kx,ky,kz,phase)
!
!  Beltrami field (as initial condition)
!
!  19-jun-02/axel: coded
!   5-jul-02/axel: made additive (if called twice), kx,ky,kz are optional
!
      integer :: i,j,l,m,n
      real, dimension (mx,my,mz,mfarray) :: f
      real :: kx, ky, kz, phase, k, cfunc, sfunc
      !real :: ex=.1, ey=.33, ez=.58
      !real :: ex=1., ey=.0, ez=1.
      !real :: ex=1., ey=.0, ez=0.
      real :: ex=0., ey=.0, ez=1.
      real :: kxe_x, kxe_y, kxe_z, kxkxe_x, kxkxe_y, kxkxe_z
      real :: ampl
!
!  wavenumber k, helicity H=ampl (can be either sign)
!
      kxe_x=ky*ez-kz*ey
      kxe_y=kz*ex-kx*ez
      kxe_z=kx*ey-ky*ex
!
      kxkxe_x=ky*kxe_z-kz*kxe_y
      kxkxe_y=kz*kxe_x-kx*kxe_z
      kxkxe_z=kx*kxe_y-ky*kxe_x
!
      k=sqrt(kx**2+ky**2+kz**2)
!
      do n=1,mz
      do m=1,my
      do l=1,mx
        cfunc=abs(ampl)*cos(kx*x(l)+ky*y(m)+kz*z(n)+phase)
        sfunc=    ampl *sin(kx*x(l)+ky*y(m)+kz*z(n)+phase)
        j=i  ; f(l,m,n,j)=f(l,m,n,j)+kxkxe_x*cfunc+k*kxe_x*sfunc
        j=i+1; f(l,m,n,j)=f(l,m,n,j)+kxkxe_y*cfunc+k*kxe_y*sfunc
        j=i+2; f(l,m,n,j)=f(l,m,n,j)+kxkxe_z*cfunc+k*kxe_z*sfunc
      enddo
      enddo
      enddo
!
    endsubroutine beltrami_general
!***********************************************************************
    subroutine bihelical(ampl,f,i,kx,ky,kz,kx2,ky2,kz2,phase,sym)
!
!  Bihelical field (as initial condition)
!
!  19-jun-02/axel: coded
!   5-jul-02/axel: made additive (if called twice), kx,ky,kz are optional
!
      integer :: i,j
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (mx) :: sfuncx,cfuncx
      real, dimension (my) :: sfuncy,cfuncy
      real, dimension (mz) :: sfuncz,cfuncz
      logical, optional :: sym
      real, optional :: kx,ky,kz,kx2,ky2,kz2,phase
      real :: ampl,k=1.,kp,km,ph
!
!  possibility of shifting the Bihelical wave by phase ph
!
      if (present(phase)) then
        if (lroot) print*,'Bihelical: phase=',phase
        ph=phase
      else
        ph=0.
      endif
!
!  wavenumber k, helicity H=ampl (can be either sign)
!
!  set x-dependent Bihelical field
!
      if (present(kx)) then
        if (present(sym)) then
          km=kx-.5
          kp=kx+.5
        else
          km=kx
          kp=kx+1.
        endif
        if (k==0) print*,'bihelical: k must not be zero!'
        cfuncx=ampl*cos(km*x+ph)
        sfuncx=ampl*sin(kp*x+ph)
        if (present(kx2)) sfuncx=sfuncx*sin(kx2*x+ph)
        if (ampl==0) then
          if (lroot) print*,'bihelical: ampl=0; kx=',k
        elseif (ampl>0) then
          if (lroot) print*,'bihelical: Bihelical field (pos-hel): kx,i=',k,i
          j=i+1; f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncx,2,my),3,mz)
          j=i+2; f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncx,2,my),3,mz)
        elseif (ampl<0) then
          if (lroot) print*,'bihelical: Bihelical field (neg-hel): kx,i=',k,i
          j=i+1; f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncx,2,my),3,mz)
          j=i+2; f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncx,2,my),3,mz)
        endif
      endif
!
!  set y-dependent Bihelical field
!
      if (present(ky)) then
        if (present(sym)) then
          km=ky-.5
          kp=ky+.5
        else
          km=ky
          kp=ky+1.
        endif
        if (k==0) print*,'bihelical: k must not be zero!'
        cfuncy=ampl*cos(km*y+ph)
        sfuncy=ampl*sin(kp*y+ph)
        if (present(ky2)) sfuncy=sfuncy*sin(ky2*y+ph)
        if (ampl==0) then
          if (lroot) print*,'bihelical: ampl=0; ky=',k
        elseif (ampl>0) then
          if (lroot) print*,'bihelical: Bihelical field (pos-hel): ky,i=',k,i
          j=i;   f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncy,1,mx),3,mz)
          j=i+2; f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncy,1,mx),3,mz)
        elseif (ampl<0) then
          if (lroot) print*,'bihelical: Bihelical field (neg-hel): ky,i=',k,i
          j=i;   f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncy,1,mx),3,mz)
          j=i+2; f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncy,1,mx),3,mz)
        endif
      endif
!
!  set z-dependent Bihelical field
!
      if (present(kz)) then
        if (present(sym)) then
          km=kz-.5
          kp=kz+.5
        else
          km=kz
          kp=kz+1.
        endif
        if (k==0) print*,'bihelical: k must not be zero!'
        cfuncz=ampl*cos(km*z+ph)
        sfuncz=ampl*sin(kp*z+ph)
        if (present(kz2)) sfuncz=sfuncz*sin(kz2*z+ph)
        if (ampl==0) then
          if (lroot) print*,'bihelical: ampl=0; kz=',k
        elseif (ampl>0) then
          if (lroot) print*,'bihelical: Bihelical field (pos-hel): kz,i=',k,i
          j=i;   f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncz,1,mx),2,my)
          j=i+1; f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncz,1,mx),2,my)
        elseif (ampl<0) then
          if (lroot) print*,'bihelical: Bihelical field (neg-hel): kz,i=',k,i
          j=i;   f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncz,1,mx),2,my)
          j=i+1; f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncz,1,mx),2,my)
        endif
      endif
!
    endsubroutine bihelical
!***********************************************************************
    subroutine bhyperz(ampl,f,i,kz,nfactor)
!
!  Beltrami field with wavelengths that are cube roots of unity
!
      integer :: i
      integer :: ix,iy,iz
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,kz,nfactor,maxAx,maxAy,zmax,zmin,zzm !,maxA
      complex :: omega,Ax,Ay
!
!  set z-dependent Beltrami field
!
      omega=cmplx(1./2.,sqrt(3.)/2.)
      zmin=xyz0(3)
      zmax=xyz1(3)
      zzm=max(abs(zmin),abs(zmax))
      maxAx= abs(sin(omega*kz*zzm)+sin(omega*omega*kz*zzm))
      maxAy= abs(cos(omega*kz*zzm)+cos(omega*omega*kz*zzm))
!      maxA = max(maxAx,maxAy)
      do ix=1,mx; do iy=1,my;do iz=1,mz
        Ax = (1.-nfactor)*cos(kz*z(iz))+ nfactor*real(sin(omega*kz*z(iz)))
        Ay = (1.-nfactor)*sin(kz*z(iz))+ nfactor*real(cos(omega*kz*z(iz)))
!        Ax = real(sin(omega*kz*z(iz)))
!        Ay = real(cos(omega*kz*z(iz)))
        f(ix,iy,iz,i) = ampl*real(Ax)/kz
        f(ix,iy,iz,i+1) = ampl*real(Ay)/kz
      enddo;enddo;enddo
!
    endsubroutine bhyperz
!***********************************************************************
    subroutine beltrami_complex(ampl,f,i,kx,ky,kz,kx2,ky2,kz2,phase)
!
!  Beltrami field (as initial condition)
!
!  23-sep-10/dhruba: adapted from beltrami
!
      integer :: i,j
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (mx) :: sfuncx,cfuncx
      real, dimension (my) :: sfuncy,cfuncy
      real, dimension (mz) :: sfuncz,cfuncz
      real, optional :: kx,ky,kz,kx2,ky2,kz2,phase
      real :: ampl,k=1.,ph
      complex :: omg,omgsqr
!
! complex cube roots of unity
!
      omg=cmplx(-sqrt(2.),sqrt(3.)/2.)
      omgsqr=conjg(omg)
!
!  possibility of shifting the Beltrami wave by phase ph
!
      if (present(phase)) then
        if (lroot) print*,'Beltrami: phase=',phase
        ph=phase
      else
        ph=0.
      endif
!
!  wavenumber k, helicity H=ampl (can be either sign)
!
!  set x-dependent Beltrami field
!
      if (present(kx)) then
        k=abs(kx)
        if (k==0) print*,'beltrami: k must not be zero!'
        cfuncx=sign(sqrt(abs(ampl/k)),kx)*&
            real(cos(k*x+ph)+omgsqr*cos(omg*k*x+ph)+omg*cos(omgsqr*k*x+ph))
        sfuncx=sign(sqrt(abs(ampl/k)),kx)*&
            real(sin(k*x+ph)+omgsqr*sin(omg*k*x+ph)+omg*sin(omgsqr*k*x+ph))
        if (present(kx2)) sfuncx=sfuncx*sin(kx2*x+ph)
        if (ampl==0) then
          if (lroot) print*,'beltrami: ampl=0; kx=',k
        elseif (ampl>0) then
          if (lroot) print*,'beltrami: Beltrami field (pos-hel): kx,i=',k,i
          j=i+1; f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncx,2,my),3,mz)
          j=i+2; f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncx,2,my),3,mz)
        elseif (ampl<0) then
          if (lroot) print*,'beltrami: Beltrami field (neg-hel): kx,i=',k,i
          j=i+1; f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncx,2,my),3,mz)
          j=i+2; f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncx,2,my),3,mz)
        endif
      endif
!
!  set y-dependent Beltrami field
!
      if (present(ky)) then
        k=abs(ky)
        if (k==0) print*,'beltrami: k must not be zero!'
        cfuncy=sign(sqrt(abs(ampl/k)),ky)*&
            real(cos(k*y+ph)+omgsqr*cos(omg*k*y+ph)+omg*cos(omgsqr*k*y+ph))
        sfuncy=sign(sqrt(abs(ampl/k)),ky)*&
            real(sin(k*y+ph)+omgsqr*sin(omg*k*y+ph)+omg*sin(omgsqr*k*y+ph))
        if (present(ky2)) sfuncy=sfuncy*sin(ky2*y+ph)
        if (ampl==0) then
          if (lroot) print*,'beltrami: ampl=0; ky=',k
        elseif (ampl>0) then
          if (lroot) print*,'beltrami: Beltrami field (pos-hel): ky,i=',k,i
          j=i;   f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncy,1,mx),3,mz)
          j=i+2; f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncy,1,mx),3,mz)
        elseif (ampl<0) then
          if (lroot) print*,'beltrami: Beltrami field (neg-hel): ky,i=',k,i
          j=i;   f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncy,1,mx),3,mz)
          j=i+2; f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncy,1,mx),3,mz)
        endif
      endif
!
!  set z-dependent Beltrami field
!
      if (present(kz)) then
        k=abs(kz)
        if (k==0) print*,'beltrami: k must not be zero!'
        cfuncz=sign(sqrt(abs(ampl/k)),kz)*&
            real(cos(k*z+ph)-omgsqr*cos(omg*k*z+ph)-omg*cos(omgsqr*k*z+ph))
        sfuncz=sign(sqrt(abs(ampl/k)),kz)*&
            real(sin(k*z+ph)-omgsqr*sin(omg*k*z+ph)-omg*sin(omgsqr*k*z+ph))
        if (present(kz2)) sfuncz=sfuncz*sin(kz2*z+ph)
        if (ampl==0) then
          if (lroot) print*,'beltrami: ampl=0; kz=',k
        elseif (ampl>0) then
          if (lroot) print*,'beltrami: Beltrami field (pos-hel): kz,i=',k,i
          j=i;   f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncz,1,mx),2,my)
          j=i+1; f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncz,1,mx),2,my)
        elseif (ampl<0) then
          if (lroot) print*,'beltrami: Beltrami field (neg-hel): kz,i=',k,i
          j=i;   f(:,:,:,j)=f(:,:,:,j)+spread(spread(cfuncz,1,mx),2,my)
          j=i+1; f(:,:,:,j)=f(:,:,:,j)+spread(spread(sfuncz,1,mx),2,my)
        endif
      endif
!
    endsubroutine beltrami_complex
!***********************************************************************
    subroutine bessel_x(ampl,f,i,kx)
!
!  Bessel function field (as initial condition)
!
!  12-nov-09/axel: coded
!
      integer :: i,j,l
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (mx) :: J0,J1
      real :: ampl,kx,kx1
!
!  set x-dependent Bessel function field.
!  For Az, subtract value on boundary so that it matches
!  the perfect conductor boundary condition.
!
      if (ampl==0) then
        if (lroot) print*,'bessel_x: ampl=0; kx=',kx
      else
        if (lroot) print*,'bessel_x: Bessel function field: kx,i=',kx,i
        kx1=1./kx
        do l=1,mx
          J0(l)=kx1*(bessj(0,kx*x(l))-bessj(0,kx*xyz1(1)))
          J1(l)=kx1*bessj(1,kx*x(l))
        enddo
        j=i+1; f(:,:,:,j)=f(:,:,:,j)+ampl*spread(spread(J1,2,my),3,mz)
        j=i+2; f(:,:,:,j)=f(:,:,:,j)+ampl*spread(spread(J0,2,my),3,mz)
      endif
!
    endsubroutine bessel_x
!***********************************************************************
    subroutine bessel_az_x(ampl,f,i,kx)
!
!  Bessel function field (as initial condition)
!
!  12-nov-09/axel: coded
!
      integer :: i,j,l
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (mx) :: J0
      real :: ampl,kx,kx1
!
!  set x-dependent Bessel function field
!
      if (ampl==0) then
        if (lroot) print*,'bessel_az_x: ampl=0; kx=',kx
      else
        if (lroot) print*,'bessel_az_x: Bessel function field: kx,i=',kx,i
        kx1=1./kx
        do l=1,mx
          J0(l)=kx1*bessj(0,kx*x(l))
        enddo
        j=i+2; f(:,:,:,j)=f(:,:,:,j)+ampl*spread(spread(J0,2,my),3,mz)
      endif
!
    endsubroutine bessel_az_x
!***********************************************************************
    subroutine straining(ampl,f,i,kx,ky,kz,dimensionality)
!
!  convection straining (as initial condition)
!
!  23-mar-16/axel: coded
!
      integer :: i,j,dimensionality
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,kx,ky,kz
!
!  check input parameters
!
      if (lroot) print*,'straining: i,kx,ky,kz=',i,kx,ky,kz
!
!  set stream function psi=sin(kx*x)*sin(kz*(z-zbot))
!
      j=i
      f(:,:,:,j)=f(:,:,:,j)+ampl*spread(spread(sin(kx*x),2,my),3,mz)&
                                *spread(spread(cos(ky*y),1,mx),3,mz)&
                                *spread(spread(cos(kz*z),1,mx),2,my)
      j=i+1
      f(:,:,:,j)=f(:,:,:,j)+ampl*spread(spread(cos(kx*x),2,my),3,mz)&
                                *spread(spread(sin(ky*y),1,mx),3,mz)&
                                *spread(spread(cos(kz*z),1,mx),2,my)
      j=i+2
      f(:,:,:,j)=f(:,:,:,j)+ampl*spread(spread(cos(kx*x),2,my),3,mz)&
                                *spread(spread(cos(ky*y),1,mx),3,mz)&
                                *spread(spread(sin(kz*z),1,mx),2,my)&
                                *(-1.)*(dimensionality-1)
!
    endsubroutine straining
!***********************************************************************
    subroutine rolls(ampl,f,i,kx,kz)
!
!  convection rolls (as initial condition)
!
!  21-aug-07/axel: coded
!
      integer :: i,j
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,kx,kz,zbot
!
!  check input parameters
!
      zbot=xyz0(3)
      if (lroot) print*,'rolls: i,kx,kz,zbot=',i,kx,kz,zbot
!
!  set stream function psi=sin(kx*x)*sin(kz*(z-zbot))
!
      j=i
      f(:,:,:,j)=f(:,:,:,j)-ampl*kz*spread(spread(sin(kx*x       ),2,my),3,mz)&
                                   *spread(spread(cos(kz*(z-zbot)),1,mx),2,my)
      j=i+2
      f(:,:,:,j)=f(:,:,:,j)+ampl*kx*spread(spread(cos(kx*x       ),2,my),3,mz)&
                                   *spread(spread(sin(kz*(z-zbot)),1,mx),2,my)
!
    endsubroutine rolls
!***********************************************************************
    subroutine robertsflow(ampl,f,i,relhel,kx,flow)
!
!  Roberts Flow (as initial condition)
!
!   9-jun-05/axel: coded
!
      integer :: i,j
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,k=1.,kf,fac1,fac2,relhel
      real, optional :: kx
      character (len=labellen) :: flowtype='I'
      character (len=labellen), optional :: flow
!
!  Possibility of changing the wavenumber
!
      if (present(kx)) then
        k=kx
      endif
!
!  Possibility of changing the flow
!
      if (present(flow)) then
        flowtype=flow
      endif
!
!  prepare coefficients
!
      kf=k*sqrt(2.)
      fac1=sqrt(2.)*ampl*k/kf
      fac2=sqrt(2.)*ampl*relhel
!
      if (flowtype=='I-shift' .or. flowtype=='II-shift') then
!
!  shifted by 90 degrees in the x and y directions
!
        j=i+0; f(:,:,:,j)=f(:,:,:,j)+fac1*spread(spread(sin(k*x),2,my),3,mz)&
                                         *spread(spread(cos(k*y),1,mx),3,mz)
!
        j=i+1; f(:,:,:,j)=f(:,:,:,j)-fac1*spread(spread(cos(k*x),2,my),3,mz)&
                                         *spread(spread(sin(k*y),1,mx),3,mz)
!
        if (flowtype=='I-shift') then
          j=i+2; f(:,:,:,j)=f(:,:,:,j)+fac2*spread(spread(sin(k*x),2,my),3,mz)&
                                           *spread(spread(sin(k*y),1,mx),3,mz)
        elseif (flowtype=='II-shift') then
          j=i+2; f(:,:,:,j)=f(:,:,:,j)+fac2*spread(spread(cos(k*x),2,my),3,mz)&
                                           *spread(spread(cos(k*y),1,mx),3,mz)
        else
          call fatal_error('robertsflow','no such flowtype')
        endif
      else
!
!  original, where field = curl(phi*zz)+phi*zz and curl(phi*zz)+tilde(phi)*zz
!  with phi=cosk0x*cosk0y for flows I and II, respectively.
!
        j=i+0; f(:,:,:,j)=f(:,:,:,j)-fac1*spread(spread(cos(k*x),2,my),3,mz)&
                                         *spread(spread(sin(k*y),1,mx),3,mz)
!
        j=i+1; f(:,:,:,j)=f(:,:,:,j)+fac1*spread(spread(sin(k*x),2,my),3,mz)&
                                         *spread(spread(cos(k*y),1,mx),3,mz)
!
        if (flowtype=='I') then
          j=i+2; f(:,:,:,j)=f(:,:,:,j)+fac2*spread(spread(cos(k*x),2,my),3,mz)&
                                           *spread(spread(cos(k*y),1,mx),3,mz)
        elseif (flowtype=='II') then
          j=i+2; f(:,:,:,j)=f(:,:,:,j)+fac2*spread(spread(sin(k*x),2,my),3,mz)&
                                           *spread(spread(sin(k*y),1,mx),3,mz)
        else
          call fatal_error('robertsflow','no such flowtype')
        endif
      endif
!
    endsubroutine robertsflow
!***********************************************************************
    subroutine rotated_robertsflow(ampl,f,i,relhel,kx,flow)
!
!  By 45 degrees rotated Roberts Flow (as initial condition)
!
!   6-jan-25/axel: coded
!
      integer :: i,j
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,k=1.,kf,fac1,fac2,relhel
      real, optional :: kx
      character (len=labellen) :: flowtype='I'
      character (len=labellen), optional :: flow
!
!  Possibility of changing the wavenumber
!
      if (present(kx)) then
        k=kx
      endif
!
!  Possibility of changing the flow
!
      if (present(flow)) then
        flowtype=flow
      endif
!
!  prepare coefficients
!
      kf=k*sqrt(2.)
      fac1=sqrt(2.)*ampl*k/kf
      fac2=sqrt(2.)*ampl*relhel
!
      j=i+0; f(:,:,:,j)=f(:,:,:,j)+fac1*spread(spread(sin(k*y),1,mx),3,mz)
!
      j=i+1; f(:,:,:,j)=f(:,:,:,j)+fac1*spread(spread(sin(k*x),2,my),3,mz)
!
      if (flowtype=='I') then
        j=i+2; f(:,:,:,j)=f(:,:,:,j)+fac1*(spread(spread(cos(k*x),2,my),3,mz)&
                                          -spread(spread(cos(k*y),1,mx),3,mz))
      elseif (flowtype=='II') then
        j=i+2; f(:,:,:,j)=f(:,:,:,j)+fac1*(spread(spread(cos(k*x),2,my),3,mz)&
                                          +spread(spread(cos(k*y),1,mx),3,mz))
      else
        call fatal_error('robertsflow','no such flowtype')
      endif
!
    endsubroutine rotated_robertsflow
!***********************************************************************
    subroutine exponential(ampl,f,j,KKz)
!
!  horizontal pattern with exponential decay (as initial condition)
!
!   2-mar-13/axel: coded
!
      integer :: j
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,KKz,fact
!
!  By(z)=B0*exp(-z/2H), and put KKz=1/2H, so
!  Ax(z)=-2*H*B0*exp(-z/2H)
!
      fact=-ampl/KKz
      f(:,:,:,j)=f(:,:,:,j)+fact*spread(spread(exp(-KKz*z),1,mx),2,my)
!
    endsubroutine exponential
!***********************************************************************
    subroutine vecpatternxy(ampl,f,i,kx,ky,kz)
!
!  horizontal pattern with exponential decay (as initial condition)
!
!   9-jun-05/axel: coded
!
      integer :: i,j
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,kx,ky,kz
!
!  prepare coefficients
!
      j=i+0; f(:,:,:,j)=f(:,:,:,j)-ampl*spread(spread(sin(ky*y),1,mx),3,mz) &
        *spread(spread(exp(-abs(kz*z)),1,mx),2,my)
      j=i+1; f(:,:,:,j)=f(:,:,:,j)+ampl*spread(spread(sin(kx*x),2,my),3,mz) &
        *spread(spread(exp(-abs(kz*z)),1,mx),2,my)
!
    endsubroutine vecpatternxy
!***********************************************************************
    subroutine bipolar(ampl,f,i,kx,ky,kz)
!
!  horizontal pattern with exponential decay (as initial condition)
!
!  24-may-09/axel: coded
!
      integer :: i,j
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,kx,ky,kz
!
!  sets up a nearly force-free bipolar region
!
      j=i+1; f(:,:,:,j)=f(:,:,:,j)+ampl &
        *spread(spread(exp(-(kx*x)**2),2,my),3,mz) &
        *spread(spread(exp(-(ky*y)**2),1,mx),3,mz) &
        *spread(spread(exp(-abs(kz*z)),1,mx),2,my)
      j=i+2; f(:,:,:,j)=f(:,:,:,j)+ampl &
        *spread(spread(exp(-(kx*x)**2)*(-2*x),2,my),3,mz)*kx**2 &
        *spread(spread(exp(-(ky*y)**2),1,mx),3,mz) &
        *spread(spread(exp(-abs(kz*z)),1,mx),2,my)
!
    endsubroutine bipolar
!***********************************************************************
    subroutine bipolar_restzero(ampl,f,i,kx,ky)
!
!  horizontal pattern with exponential decay (as initial condition)
!
!  24-may-09/axel: coded
!
      integer :: i,j
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,kx,ky
!
!  sets up a nearly force-free bipolar region
!
      if (lfirst_proc_z) then
        j=i+1; f(:,:,n1,j)=f(:,:,n1,j)+ampl &
          *spread(exp(-(kx*x)**2),2,my) &
          *spread(exp(-(ky*y)**2),1,mx)
        j=i+2; f(:,:,n1,j)=f(:,:,n1,j)+ampl &
          *spread(exp(-(kx*x)**2)*(-2*x),2,my)*kx**2 &
          *spread(exp(-(ky*y)**2),1,mx)
      endif
!
    endsubroutine bipolar_restzero
!***********************************************************************
    subroutine soundwave(ampl,f,i,kx,ky,kz,width)
!
!  sound wave (as initial condition)
!
!   2-aug-02/axel: adapted from Beltrami
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (mx) :: envelope_x
      real, optional :: kx,ky,kz,width
      real :: ampl, k=1., fac
!
!  wavenumber k
!
!  set x-dependent sin wave
!
      if (present(kx)) then
        envelope_x=1.
        if (present(width)) then
          if (width/=0.) envelope_x=exp(-.5*(x/width)**2)
        endif
        k=kx; if (k==0) print*,'soundwave: k must not be zero!'; fac=sqrt(abs(ampl/k))
        if (ampl==0) then
          if (lroot) print*,'soundwave: ampl=0; kx=',k
        else
          if (lroot) print*,'soundwave: kx,i=',k,i
          f(:,:,:,i)=f(:,:,:,i)+fac*spread(spread(envelope_x*sin(k*x),2,my),3,mz)
        endif
      endif
!
!  set y-dependent sin wave field
!
      if (present(ky)) then
        k=ky; if (k==0) print*,'soundwave: k must not be zero!'; fac=sqrt(abs(ampl/k))
        if (ampl==0) then
          if (lroot) print*,'soundwave: ampl=0; ky=',k
        else
          if (lroot) print*,'soundwave: ky,i=',k,i
          f(:,:,:,i)=f(:,:,:,i)+fac*spread(spread(sin(k*y),1,mx),3,mz)
        endif
      endif
!
!  set z-dependent sin wave field
!
      if (present(kz)) then
        k=kz; if (k==0) print*,'soundwave: k must not be zero!'; fac=sqrt(abs(ampl/k))
        if (ampl==0) then
          if (lroot) print*,'soundwave: ampl=0; kz=',k
        else
          if (lroot) print*,'soundwave: kz,i=',k,i
          f(:,:,:,i)=f(:,:,:,i)+fac*spread(spread(sin(k*z),1,mx),2,my)
        endif
      endif
!
    endsubroutine soundwave
!***********************************************************************
    subroutine coswave(ampl,f,i,kx,ky,kz)
!
!  cosine wave (as initial condition)
!
!  14-nov-03/axel: adapted from sinwave
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real, optional :: kx, ky, kz
      real :: ampl, k=1., fac
      real :: kx1, ky1, kz1
!
!  wavenumber k
!
!  set x-dependent cos wave
!
      if (present(kx)) then
        k=kx; if (k==0) print*,'coswave: k must not be zero!'
        if (ampl==0) then
          if (lroot) print*,'coswave: ampl=0; kx=',k
        else
          if (lroot) print*,'coswave: kx,i=',k,i
          f(:,:,:,i)=f(:,:,:,i)+fac*spread(spread(cos(k*x),2,my),3,mz)
        endif
      endif
!
!  set y-dependent cos wave field
!
      if (present(ky)) then
        k=ky; if (k==0) print*,'coswave: k must not be zero!'; fac=ampl
        if (ampl==0) then
          if (lroot) print*,'coswave: ampl=0; ky=',k
        else
          if (lroot) print*,'coswave: ky,i=',k,i
          f(:,:,:,i)=f(:,:,:,i)+fac*spread(spread(cos(k*y),1,mx),3,mz)
        endif
      endif
!
!  set z-dependent cos wave field
!
      if (present(kz)) then
        k=kz; if (k==0) print*,'coswave: k must not be zero!'; fac=ampl
        if (ampl==0) then
          if (lroot) print*,'coswave: ampl=0; kz=',k
        else
          if (lroot) print*,'coswave: kz,i=',k,i
          f(:,:,:,i)=f(:,:,:,i)+fac*spread(spread(cos(k*z),1,mx),2,my)
        endif
      endif
!
    endsubroutine coswave
!***********************************************************************
!* 26-sep-12/ccyang: This routine does not work with my machine when not
!*                   all k's are present.
!    subroutine coswave(ampl,f,i,kx,ky,kz)
!!
!!  cosine wave (as initial condition)
!!
!!  14-nov-03/axel: adapted from sinwave
!!
!      integer :: i
!      real, dimension (mx,my,mz,mfarray) :: f
!      real,optional :: kx,ky,kz
!      real :: ampl
!!
!      f(:,:,:,i)=f(:,:,:,i)+ampl*cos( &
!        spread(spread(kx*x,2,my),3,mz)+ &
!        spread(spread(ky*y,1,mx),3,mz)+ &
!        spread(spread(kz*z,1,mx),2,my))
!!
!    endsubroutine coswave
!***********************************************************************
    subroutine sph_constb(ampl,f,izero)
!
!  Antisymmetric (about equator) toroidal B field and zero poloidal
!  B field in spherical polar coordinate.
!
!  27-aug-09/dhruba: adapted from sinwave
!
      integer :: izero,l,m
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl
!
! set minimum and maximum values for r and theta
!
! set A_{phi} = 0 (izero should be iaa)
!
      f(:,:,:,izero+2)=0.
! set A_r and A_{\theta}
      do l=1,mx
        do m=1,my
          f(l,m,:,izero)=ampl*x(l)*y(m)
          f(l,m,:,izero+1)=ampl*x(l)
        enddo
      enddo
!
    endsubroutine sph_constb
!***********************************************************************
    subroutine hatwave(ampl,f,i,width,kx,ky,kz,power,pos)
!
!  cosine wave (as initial condition)
!
!   9-jan-08/axel: adapted from coswave
!  22-jul-22/axel: added keyword pos for positive values only
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real, optional :: kx, ky, kz, power, pos
      real :: ampl,k=1.,fac,width,pow=1.
!
!  wavenumber k
!
      if (present(power)) pow=power
!
!  set x-dependent hat wave
!
      if (present(kx)) then
        k=kx; if (k==0) print*,'hatwave: k must not be zero!'; fac=.5*ampl
        if (ampl==0) then
          if (lroot) print*,'hatwave: ampl=0; kx=',k
        else
          if (lroot) print*,'hatwave: kx,i=',k,i
          !f(:,:,:,i)=f(:,:,:,i)+fac*spread(spread(1+tanh((cos(k*x)**pow)/width),2,my),3,mz)
          if (present(pos)) then
            f(:,:,:,i)=f(:,:,:,i)+.5*fac*(1.+spread(spread(tanh((cos(k*x)**pow)/width),2,my),3,mz))
          else
            f(:,:,:,i)=f(:,:,:,i)+fac*spread(spread(tanh((cos(k*x)**pow)/width),2,my),3,mz)
          endif
        endif
      endif
!
!  set y-dependent hat wave field
!
      if (present(ky)) then
        k=ky; if (k==0) print*,'hatwave: k must not be zero!'; fac=.5*ampl
        if (ampl==0) then
          if (lroot) print*,'hatwave: ampl=0; ky=',k
        else
          if (lroot) print*,'hatwave: ky,i=',k,i
          f(:,:,:,i)=f(:,:,:,i)+fac*spread(spread(1+tanh(5*cos(k*y)),1,mx),3,mz)
        endif
      endif
!
!  set z-dependent hat wave field
!
      if (present(kz)) then
        k=kz; if (k==0) print*,'hatwave: k must not be zero!'; fac=.5*ampl
        if (ampl==0) then
          if (lroot) print*,'hatwave: ampl=0; kz=',k
        else
          if (lroot) print*,'hatwave: kz,i=',k,i
          f(:,:,:,i)=f(:,:,:,i)+fac*spread(spread(1+tanh(5*cos(k*z)),1,mx),2,my)
        endif
      endif
!
    endsubroutine hatwave
!***********************************************************************
    subroutine sinwave(ampl,f,i,kx,ky,kz)
!
!  sine wave (as initial condition)
!
!  14-nov-03/axel: adapted from sound wave
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real, optional :: kx,ky,kz
      real :: ampl,k=1.,fac
!
!  wavenumber k
!
!  set x-dependent sin wave
!
      if (present(kx)) then
        k=kx; if (k==0) print*,'sinwave: k must not be zero!'; fac=ampl
        if (ampl==0) then
          if (lroot) print*,'sinwave: ampl=0; kx=',k
        else
          if (lroot) print*,'sinwave: kx,i=',k,i
          f(:,:,:,i)=f(:,:,:,i)+fac*spread(spread(sin(k*x),2,my),3,mz)
        endif
      endif
!
!  set y-dependent sin wave field
!
      if (present(ky)) then
        k=ky; if (k==0) print*,'sinwave: k must not be zero!'; fac=ampl
        if (ampl==0) then
          if (lroot) print*,'sinwave: ampl=0; ky=',k
        else
          if (lroot) print*,'sinwave: ky,i=',k,i
          f(:,:,:,i)=f(:,:,:,i)+fac*spread(spread(sin(k*y),1,mx),3,mz)
        endif
      endif
!
!  set z-dependent sin wave field
!
      if (present(kz)) then
        k=kz; if (k==0) print*,'sinwave: k must not be zero!'; fac=ampl
        if (ampl==0) then
          if (lroot) print*,'sinwave: ampl=0; kz=',k
        else
          if (lroot) print*,'sinwave: kz,i=',k,i
          f(:,:,:,i)=f(:,:,:,i)+fac*spread(spread(sin(k*z),1,mx),2,my)
        endif
      endif
!
    endsubroutine sinwave
!***********************************************************************
    subroutine sinwave_phase(f,i,ampl,kx,ky,kz,phase,lnorm_kk)
!
!  Sine wave (as initial condition)
!
!  23-jan-06/anders: adapted from sinwave.
!
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl, kx, ky, kz, phase, fact, k2
      integer :: i
      logical, optional :: lnorm_kk
!
!  possibility to normalize by 1/k if the initial amplitude
!  is meant to be an amplitude for the B-field.
!
      if (present(lnorm_kk)) then
        k2=kx**2+ky**2+kz**2
        if (lnorm_kk .and. k2/=0.) then
          fact=ampl/sqrt(k2)
        else
          fact=ampl
        endif
      else
        fact=ampl
      endif
!
!  Set sin wave
!
      if (lroot) print*, 'sinwave_phase: i, fact, kx, ky, kz, phase=', &
          i, fact, kx, ky, kz, phase
!
      do m=m1,m2; do n=n1,n2
        f(l1:l2,m,n,i) = f(l1:l2,m,n,i) + &
            fact*sin(kx*x(l1:l2)+ky*y(m)+kz*z(n)+phase)
      enddo; enddo
!
    endsubroutine sinwave_phase
!***********************************************************************
    subroutine coswave_phase(f,i,ampl,kx,ky,kz,phase,lnorm_kk)
!
!  Cosine wave (as initial condition)
!
!  13-jun-06/anders: adapted from sinwave-phase.
!
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl, kx, ky, kz, phase, fact, k2
      integer :: i
      logical, optional :: lnorm_kk
!
!  possibility to normalize by 1/k if the initial amplitude
!  is meant to be an amplitude for the B-field.
!
      if (present(lnorm_kk)) then
        k2=kx**2+ky**2+kz**2
        if (lnorm_kk .and. k2/=0.) then
          fact=ampl/sqrt(k2)
        else
          fact=ampl
        endif
      else
        fact=ampl
      endif
!
!  Set cos wave
!
      if (lroot) print*, 'coswave_phase: i, fact, kx, ky, kz, phase=', &
          i, fact, kx, ky, kz, phase
!
      do m=m1,m2; do n=n1,n2
        f(l1:l2,m,n,i) = f(l1:l2,m,n,i) + &
            fact*cos(kx*x(l1:l2)+ky*y(m)+kz*z(n)+phase)
      enddo; enddo
!
    endsubroutine coswave_phase
!***********************************************************************
    subroutine hawley_etal99a(ampl,f,i,Lxyz)
!
!  velocity perturbations as used by Hawley et al (1999, ApJ,518,394)
!
!  13-jun-05/maurice reyes: sent to axel via email
!
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (mx) :: funx
      real, dimension (my) :: funy
      real, dimension (mz) :: funz
      real, dimension (3) :: Lxyz
      real :: k1,k2,k3,k4,phi1,phi2,phi3,phi4,ampl
      integer :: i,l,m,n
!
!  velocity perturbations as used by Hawley et al (1999, ApJ,518,394)
!
      if (lroot) print*,'init_uu: hawley-et-al'
      k1=2.0*pi/(Lxyz(1))
      k2=4.0*pi/(Lxyz(1))
      k3=6.0*pi/(Lxyz(1))
      k4=8.0*pi/(Lxyz(1))
      phi1=k1*0.226818
      phi2=k2*0.597073
      phi3=k3*0.962855
      phi4=k4*0.762091
!
!  use l,m,n as loop variables; inner loop should be on first index
!
      funx=sin(k1*x+phi1)+sin(k2*x+phi2)+sin(k3*x+phi3)+sin(k4*x+phi4)
      funy=sin(k1*y+phi1)+sin(k2*y+phi2)+sin(k3*y+phi3)+sin(k4*y+phi4)
      funz=sin(k1*z+phi1)+sin(k2*z+phi2)+sin(k3*z+phi3)+sin(k4*z+phi4)
      do n=1,mz; do m=1,my; do l=1,mx
        f(l,m,n,i)=ampl*funx(l)*funy(m)*funz(n)
      enddo; enddo; enddo
!
    endsubroutine hawley_etal99a
!***********************************************************************
    subroutine error_stratification_dat_size(lnoghost_strati)
!
!   For use in subroutine stratification; changes the printed error message
!   depending on the value of lnoghost_strati
!
!   20-Aug-2025/Kishore: coded
!
      logical, intent(in) :: lnoghost_strati
!
      if (lnoghost_strati) then
        call fatal_error('stratification','file invalid or too big - ghost cells may have been included')
      else
        call fatal_error('stratification','file invalid or too short; ghost cells may be missing')
      endif
!
    endsubroutine error_stratification_dat_size
!***********************************************************************
    subroutine stratification(f,strati_type)
!
!  Read mean stratification from "stratification.dat".
!
!   8-apr-03/axel: coded
!  23-may-04/anders: made structure for other input variables
!  30-apr-16/axel: adapted for polytropic eos
!  28-jun-19/nishant: added an option to use stratification file without
!                     the ghost cells; use lnoghost_strati=T in init_pars
!  20-Aug-2025/Kishore: cleaned up handling of lnoghost_strati (reduced duplicated code)
!
      use EquationOfState, only: eoscalc, cs2top, cs2bot
      use Sub, only: write_zprof
      use Cdata, only: lnoghost_strati
!
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (mzgrid) :: lnrho0,ss0,lnTT0,acc0
      real, dimension (mz) :: lnrho_mz,ss_mz,lnTT_mz
      real :: tmp,var1,var2,var3
      logical :: exist
      integer :: stat, nmin, nmax, n_top, n_bot
      character (len=labellen) :: strati_type
!
!  Read mean stratification and write into array.
!  If file is not found in run directory, search under trim(directory).
!
      inquire(file='stratification.dat',exist=exist)
      if (exist) then
        open(19,file='stratification.dat')
      else
        inquire(file=trim(directory)//'/stratification.ascii',exist=exist)
        if (exist) then
          open(19,file=trim(directory)//'/stratification.ascii')
        else
          call fatal_error('stratification','no input file')
        endif
      endif
!
      if (lnoghost_strati) then
        if (lroot) print*,'ghost cells are not needed in stratification.dat'
        nmin = 1 + nghost
        nmax = nzgrid + nghost
      else
        if (lroot) print*,'ghost cells are needed in stratification.dat'
        nmin = 1
        nmax = mzgrid
      endif
!
!     indices of the top/bottom boundary points in an array of size mzgrid
      n_bot = nghost+1
      n_top = nzgrid+nghost
!
!  Read data - first the entire stratification file.
!
      select case (strati_type)
!
      case ('lnrho_ss')
!
      do n=nmin,nmax
        read(19,*,iostat=stat) tmp,var1,var2
        if (stat==0) then
          if (ip<5) print*, 'stratification: z, var1, var2=', tmp, var1, var2
          if (ldensity) lnrho0(n)=var1
          if (lentropy) ss0(n)=var2
        else
          call error_stratification_dat_size(lnoghost_strati)
        endif
      enddo
!
      case ('lnrho_lnTT')
        do n=nmin,nmax
          read(19,*,iostat=stat) tmp,var1,var2
          if (stat==0) then
            if (ip<5) print*, 'stratification: z, var1, var2=', tmp, var1, var2
            if (ldensity) lnrho0(n)=var1
            if (ltemperature) lnTT0(n)=var2
            if (lentropy) then
              call eoscalc(ilnrho_lnTT,var1,var2,ss=tmp)
              ss0(n)=tmp
            endif
          else
            call error_stratification_dat_size(lnoghost_strati)
          endif
        enddo
!
      case ('lnrho_lnTT_acc')
        do n=nmin,nmax
          read(19,*,iostat=stat) tmp,var1,var2,var3
          if (stat==0) then
            if (ip<5) print*, 'stratification: z, var1, var2, var3=', tmp, var1, var2, var3
            if (ldensity) lnrho0(n)=var1
            if (ltemperature) lnTT0(n)=var2
            if (lentropy) then
              call eoscalc(ilnrho_lnTT,var1,var2,ss=tmp)
              ss0(n)=tmp
            endif
            if (lascalar) acc0(n)=var3
          else
            call error_stratification_dat_size(lnoghost_strati)
          endif
        enddo
!
      case ('lnrho')
        do n=nmin,nmax
          read(19,*,iostat=stat) tmp,var1
          if (stat==0) then
            if (ip<5) print*, 'stratification: z, var1=', tmp, var1
            if (ldensity) lnrho0(n)=var1
          else
            call error_stratification_dat_size(lnoghost_strati)
          endif
!
        enddo
      endselect
!
!  Select the right region for the processor afterwards.
!
      if (lnoghost_strati) then
        nmin = n1
        nmax = n2
      else
        nmin = 1
        nmax = mz
      endif
!
      do n=nmin,nmax
        f(:,:,n,ilnrho)=lnrho0(ipz*nz+n)
      enddo
!
!  Kishore: simplified the below assuming lentropy and ltemperature cannot simultaneously be true.
!
      if (lentropy) then
        do n=nmin,nmax
          f(:,:,n,iss)=ss0(ipz*nz+n)
        enddo
        call eoscalc(ilnrho_ss, lnrho0(n_top), ss0(n_top), cs2=cs2top)
        call eoscalc(ilnrho_ss, lnrho0(n_bot), ss0(n_bot), cs2=cs2bot)
      elseif (ltemperature.and..not.lascalar) then
        do n=nmin,nmax
          f(:,:,n,ilnTT)=lnTT0(ipz*nz+n)
        enddo
        call warning('stratification', &
          'cs2bot and cs2top are not set according to stratification.dat')
!  Kishore: since eoscalc_point is not implemented in eos_temperature_ionization,
!  Kishore: uncommenting the below breaks
!  Kishore: samples/1d-tests/solar-atmosphere-temperature
        !call eoscalc(ilnrho_TT, lnrho0(n_top), lnTT0(n_top), cs2=cs2top)
        !call eoscalc(ilnrho_TT, lnrho0(n_bot), lnTT0(n_bot), cs2=cs2bot)
      elseif (ltemperature.and.lascalar) then
        do n=nmin,nmax
          f(:,:,n,ilnTT)=lnTT0(ipz*nz+n)
          f(:,:,n,iacc)=acc0(ipz*nz+n)
        enddo
        call warning('stratification', &
          'cs2bot and cs2top are not set according to stratification.dat')
!  Kishore: leaving this out for now as eoscalc_point is not implemented
!  Kishore: in eos_idealgas_vapor
        !call eoscalc(ilnrho_TT, lnrho0(n_top), lnTT0(n_top), cs2=cs2top)
        !call eoscalc(ilnrho_TT, lnrho0(n_bot), lnTT0(n_bot), cs2=cs2bot)
      endif
!
!  occupy profile arrays
!
!  Kishore: lnrho_mz seems to never be used
!
      if (lentropy) then
        do n=1,mz
          lnrho_mz(n)=lnrho0(ipz*nz+n)
          ss_mz(n)=ss0(ipz*nz+n)
        enddo
        if (lcooling_ss_mz) call write_zprof('ss_mz',ss_mz)
      endif
      if (ltemperature) then
        do n=1,mz
          lnrho_mz(n)=lnrho0(ipz*nz+n)
          lnTT_mz(n)=lnTT0(ipz*nz+n)
        enddo
        if (lcooling_ss_mz) call write_zprof('lnTT_mz',lnTT_mz)
      endif
      if (.not.lentropy.and..not.ltemperature) then
        do n=1,mz
          lnrho_mz(n)=lnrho0(ipz*nz+n)
        enddo
      endif
!
      close(19)
!
    endsubroutine stratification
!***********************************************************************
    subroutine stratification_x(f,strati_type)
!
!  read mean stratification from "stratification.dat"
!
!   02-mar-09/petri: adapted from stratification
!
      use EquationOfState, only: eoscalc
!
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (mxgrid) :: lnrho0,ss0,lnTT0
      real :: tmp,var1,var2
      logical :: exist
      integer :: stat
      character (len=labellen) :: strati_type
!
!  read mean stratification and write into array
!  if file is not found in run directory, search under trim(directory)
!
      inquire(file='stratification.dat',exist=exist)
      if (exist) then
        open(19,file='stratification.dat')
      else
        inquire(file=trim(directory)//'/stratification.ascii',exist=exist)
        if (exist) then
          open(19,file=trim(directory)//'/stratification.ascii')
        else
          call fatal_error('stratification','no input file')
        endif
      endif
!
!  read data
!  first the entire stratification file
!
      select case (strati_type)
      case ('lnrho_ss')
        do n=1,mxgrid
          read(19,*,iostat=stat) tmp,var1,var2
          if (stat>=0) then
            if (ip<5) print*,"stratification: ",tmp,var1,var2
            if (ldensity) lnrho0(n)=var1
            if (lentropy) ss0(n)=var2
          else
            exit
          endif
        enddo
!
      case ('lnrho_lnTT')
        do n=1,mxgrid
          read(19,*,iostat=stat) tmp,var1,var2
          if (stat>=0) then
            if (ip<5) print*,"stratification: ",tmp,var1,var2
            if (ldensity) lnrho0(n)=var1
            if (ltemperature) lnTT0(n)=var2
            if (lentropy) then
              call eoscalc(ilnrho_lnTT,var1,var2,ss=tmp)
              ss0(n)=tmp
            endif
          else
            exit
          endif
        enddo
      endselect
!
!  select the right region for the processor afterwards
!
!--   select case (n)
  !
  !  without ghost zones
  !
!--   case (nxgrid+1)
      if (n==nxgrid+1) then
        if (lentropy) then
          do n=l1,l2
            f(n,:,:,ilnrho)=lnrho0(ipx*nx+(n-nghost))
            f(n,:,:,iss)=ss0(ipx*nx+(n-nghost))
          enddo
        endif
        if (ltemperature) then
          do n=l1,l2
            f(n,:,:,ilnrho)=lnrho0(ipx*nx+(n-nghost))
            f(n,:,:,ilnTT)=lnTT0(ipx*nx+(n-nghost))
          enddo
        endif
  !
  !  with ghost zones
  !
!--   case (mxgrid+1)
      elseif (n==mxgrid+1) then
        if (lentropy) then
          do n=1,mx
            f(n,:,:,ilnrho)=lnrho0(ipx*nx+n)
            f(n,:,:,iss)=ss0(ipx*nx+n)
          enddo
        endif
        if (ltemperature) then
          do n=1,mx
            f(n,:,:,ilnrho)=lnrho0(ipx*nx+n)
            f(n,:,:,ilnTT)=lnTT0(ipx*nx+n)
          enddo
        endif
!
!--   case default
      else
        if (lroot) then
          print '(A,I4,A,I4,A,I4,A)','ERROR: The stratification file '// &
                'for this run is allowed to contain either',nxgrid, &
                ' lines (without ghost zones) or more than',mxgrid, &
                ' lines (with ghost zones). It does contain',n-1, &
                ' lines though.'
        endif
        call fatal_error('','')
!
!--   endselect
      endif
!
      close(19)
!
    endsubroutine stratification_x
!***********************************************************************
    subroutine stratification_xz(f,strati_type)
!
!  read mean stratification from "stratification_xz.dat"
!
!  09-aug-14/axel: adapted from stratification
!
      use EquationOfState, only: eoscalc
!
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (nxgrid,nzgrid,mvar) :: slice
      logical :: exist
      integer :: stat
      character (len=labellen) :: strati_type
!
!  read mean stratification and write into array
!  if file is not found in run directory, search under trim(directory)
!
      inquire(file='stratification_xz.dat',exist=exist)
      if (exist) then
        open(19,file='stratification_xz.dat')
      else
        call fatal_error('stratification_xz','no input file')
      endif
!
!  read data
!  first the entire stratification file
!
      select case (strati_type)
      case ('5variables')
        read(19,"(8e10.3)",iostat=stat) slice
        if (stat>=0) then
          if (lroot) print*,"stratification_xz: ",slice(1,1,:)
        else
          call fatal_error('stratification_xz','error reading input file')
        endif
!
      endselect
      close(19)
!
!  select the right region for the processor
!
      do m=m1,m2
        f(l1:l2,m,n1:n2,1:mvar)=slice(ipx*nx+1:(ipx+1)*nx,ipz*nz+1:(ipz+1)*nz,:)
      enddo
      if (lroot) print*,"var file initialized with slice data"
!
    endsubroutine stratification_xz
!***********************************************************************
    subroutine planet_hc(ampl,f,eps,radius,gamma,cs20,rho0,width)
!
!  Ellipsoidal planet solution (Goldreich, Narayan, Goodman 1987)
!
!   6-jul-02/axel: coded
!  22-feb-03/axel: fixed 3-D background solution for enthalpy
!  26-Jul-03/anders: Revived from June 1 version
!
      use Mpicomm, only: mpireduce_sum, mpibcast_real, MPI_COMM_PENCIL
!
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (nx) :: hh, xi
      real, dimension (mz) :: hz
      real :: delS,ampl,sigma2,sigma,delta2,delta,eps,radius,a_ell,b_ell,c_ell
      real :: gamma,cs20,gamma_m1,eps2,radius2,width
      real :: lnrhosum_thisbox,rho0
      real :: lnrhosum_thisbox_tmp,lnrhosum_wholebox
      integer :: l
!
!  calculate sigma
!
      if (lroot) print*,'planet_hc: qshear,eps=',qshear,eps
      eps2=eps**2
      radius2=radius**2
      sigma2=2*qshear/(1.-eps2)
      if (sigma2<0.) then
        if (lroot) print*, &
          'planet_hc: sigma2<0 not allowed; choose another value of eps_planet'
      else
        sigma=sqrt(sigma2)
      endif
!
!  calculate delta
!
      delta2=(2.-sigma)*sigma
      if (lroot) print*,'planet_hc: sigma,delta2,radius=',sigma,delta2,radius
      if (delta2<=0.) then
        if (lroot) print*,'planet_hc: delta2<=0 not allowed'
      else
        delta=sqrt(delta2)
      endif
!
!  calculate gamma_m1
!
      gamma_m1=gamma-1.
      if (lroot) print*,'planet_hc: gamma=',gamma
!
!  ellipse parameters
!
      b_ell = radius
      a_ell = radius/eps
      c_ell = radius*delta
      if (lroot) print*,'planet_hc: Ellipse axes (b_ell,a_ell,c_ell)=', &
          b_ell,a_ell,c_ell
      if (lroot) print*,"planet_hc: integrate hot corona"
!
!  xi=1 inside vortex, and 0 outside
!
      do n=n1,n2; do m=m1,m2
        hh=0.5*delta2*Omega**2*(radius2-x(l1:l2)**2-eps2*y(m)**2)-.5*Omega**2*z(n)**2
        xi=0.5+0.5*tanh(hh/width)
!
!  Calculate velocities (Kepler speed subtracted)
!
        f(l1:l2,m,n,iux)=   eps2*sigma *Omega*y(m)    *xi
        f(l1:l2,m,n,iuy)=(qshear-sigma)*Omega*x(l1:l2)*xi
        if (lentropy) f(l1:l2,m,n,iss)=-log(ampl)*xi
      enddo; enddo
!
      do m=m1,m2; do l=l1,l2
!
!  add continuous vertical stratification to horizontal planet solution
!  NOTE: if width is too small, the vertical integration below may fail.
!
        hz(n2)=1.0  !(initial condition)
        do n=n2-1,n1,-1
          delS=f(l,m,n+1,iss)-f(l,m,n,iss)
          hz(n)=(hz(n+1)*(1.0-0.5*delS)+ &
               Omega**2*0.5*(z(n)+z(n+1))*dz)/(1.0+0.5*delS)
        enddo
!
!  calculate density, depending on what gamma is
!
        if (lentropy) then
          f(l,m,n1:n2,ilnrho)= &
               (log(gamma_m1*hz(n1:n2)/cs20)-gamma*f(l,m,n1:n2,iss))/gamma_m1
          if (lroot) &
            print*,'planet_hc: planet solution with entropy for gamma=',gamma
        else
          if (gamma==1.) then
            f(l,m,n1:n2,ilnrho)=hz(n1:n2)/cs20
            if (lroot) print*,'planet_hc: planet solution for gamma=1'
          else
            f(l,m,n1:n2,ilnrho)=log(gamma_m1*hz(n1:n2)/cs20)/gamma_m1
            if (lroot) print*,'planet_hc: planet solution for gamma=',gamma
          endif
        endif
!
      enddo; enddo
!
      if (gamma_m1<0. .and. lroot) &
          print*,'planet_hc: must have gamma>1 for planet solution'
!
!  Use average density of box as unit density
!
      lnrhosum_thisbox = sum(f(l1:l2,m1:m2,n1:n2,ilnrho))
      if (ip<14) &
        print*,'planet_hc: iproc,lnrhosum_thisbox=',iproc,lnrhosum_thisbox
!
!  Must put sum_thisbox in 1-dimensional array
!
      lnrhosum_thisbox_tmp = lnrhosum_thisbox
!
!  Add sum_thisbox up for all processors, deliver to root
!
      call mpireduce_sum(lnrhosum_thisbox_tmp,lnrhosum_wholebox)
      if (lroot .and. ip<14) &
        print*,'planet_hc: lnrhosum_wholebox=',lnrhosum_wholebox
!
!  Calculate <rho> and send to all processors
!
      if (lroot) rho0 = exp(-lnrhosum_wholebox/nwgrid)
      call mpibcast_real(rho0,comm=MPI_COMM_PENCIL)
      if (ip<14) print*,'planet_hc: iproc,rho0=',iproc,rho0
!
!  Multiply density by rho0 (divide by <rho>)
!
      f(l1:l2,m1:m2,n1:n2,ilnrho) = f(l1:l2,m1:m2,n1:n2,ilnrho) + log(rho0)
!
    endsubroutine planet_hc
!***********************************************************************
    subroutine planet(rbound,f,eps,radius,gamma,cs20,rho0,width,hh0)
!
!  Cylindrical planet solution (Goldreich, Narayan, Goodman 1987)
!
!   jun-03/anders: coded (adapted from old 'planet', now 'planet_hc')
!
      use Mpicomm, only: mpireduce_sum, mpibcast_real, MPI_COMM_PENCIL
!
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (nx) :: hh, xi, r_ell
      real :: rbound,sigma2,sigma,delta2,delta,eps,radius
      real :: gamma,eps2,radius2,width,a_ell,b_ell,c_ell
      real :: gamma_m1,ztop,cs20,hh0
      real :: lnrhosum_thisbox,rho0
      real :: lnrhosum_thisbox_tmp,lnrhosum_wholebox
!
!  calculate sigma
!
      if (lroot) print*,'planet: qshear,eps=',qshear,eps
      eps2=eps**2
      radius2=radius**2
      sigma2=2*qshear/(1.-eps2)
      if (sigma2<0. .and. lroot) then
        print*, &
            'planet: sigma2<0 not allowed; choose another value of eps_planet'
      else
        sigma=sqrt(sigma2)
      endif
!
      gamma_m1=gamma-1.
!
!  calculate delta
!
      delta2=(2.-sigma)*sigma
      if (lroot) print*,'planet: sigma,delta2,radius=',sigma,delta2,radius
      if (delta2<0. .and. lroot) then
        print*,'planet: delta2<0 not allowed'
      else
        delta=sqrt(delta2)
      endif
!
      ztop=z0+lz
      if (lroot) print*,'planet: ztop=', ztop
!
!  Cylinder vortex 3-D solution (b_ell along x, a_ell along y)
!
      b_ell = radius
      a_ell = radius/eps
      c_ell = radius*delta
      if (lroot) print*,'planet: Ellipse axes (b_ell,a_ell,c_ell)=', &
          b_ell,a_ell,c_ell
      if (lroot) print*,'planet: width,rbound',width,rbound
!
      do n=n1,n2; do m=m1,m2
        r_ell = sqrt(x(l1:l2)**2/b_ell**2+y(m)**2/a_ell**2)
!
!  xi is 1 inside vortex and 0 outside
!
        xi = 1/(exp((1/width)*(r_ell-rbound))+1.0)
!
!  Calculate enthalpy inside vortex
!
        hh = 0.5*delta2*Omega**2*(radius2-x(l1:l2)**2-eps2*y(m)**2) &
             -0.5*Omega**2*z(n)**2 + 0.5*Omega**2*ztop**2 + hh0
!
!  Calculate enthalpy outside vortex
!
        where (r_ell>1.0) hh=-0.5*Omega**2*z(n)**2 + 0.5*Omega**2*ztop**2 + hh0
!
!  Calculate velocities (Kepler speed subtracted)
!
        f(l1:l2,m,n,iux)=   eps2*sigma *Omega*y(m)*xi
        f(l1:l2,m,n,iuy)=(qshear-sigma)*Omega*x(l1:l2)*xi
!
!  calculate density, depending on what gamma is
!
        if (lentropy) then
          f(l1:l2,m,n,ilnrho)=(log(gamma_m1*hh/cs20)-gamma*f(l1:l2,m,n,iss))/gamma_m1
        else
          if (gamma==1.) then
            f(l1:l2,m,n,ilnrho) = hh/cs20
          else
            f(l1:l2,m,n,ilnrho) = log(gamma_m1*hh/cs20)/gamma_m1
          endif
        endif
      enddo; enddo
!
!  Use average density of box as unit density
!
      lnrhosum_thisbox = sum(f(l1:l2,m1:m2,n1:n2,ilnrho))
      if (ip<14) &
        print*,'planet_hc: iproc,lnrhosum_thisbox=',iproc,lnrhosum_thisbox
!
!  Must put sum_thisbox in 1-dimensional array
!
      lnrhosum_thisbox_tmp = lnrhosum_thisbox
!
!  Add sum_thisbox up for all processors, deliver to root
!
      call mpireduce_sum(lnrhosum_thisbox_tmp,lnrhosum_wholebox)
      if (lroot .and. ip<14) &
          print*,'planet_hc: lnrhosum_wholebox=',lnrhosum_wholebox
!
!  Calculate <rho> and send to all processors
!
      if (lroot) rho0 = exp(-lnrhosum_wholebox/nwgrid)
      call mpibcast_real(rho0,comm=MPI_COMM_PENCIL)
      if (ip<14) print*,'planet_hc: iproc,rho0=',iproc,rho0
!
!  Multiply density by rho0 (divide by <rho>)
!
      f(l1:l2,m1:m2,n1:n2,ilnrho) = f(l1:l2,m1:m2,n1:n2,ilnrho) + log(rho0)
!
    endsubroutine planet
!***********************************************************************
    subroutine vortex_2d(f,b_ell,width,rbound)
!
!  Ellipsoidal planet solution (Goldreich, Narayan, Goodman 1987)
!
!   8-jun-04/anders: adapted from planet
!
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (nx) :: r_ell, xi
      real :: sigma,eps_ell,a_ell,b_ell,width,rbound
!
!  calculate sigma
!
      eps_ell=0.5
      if (lroot) print*,'vortex_2d: qshear,eps_ell=',qshear,eps_ell
      sigma=sqrt(2*qshear/(1.-eps_ell**2))
!
!  ellipse parameters
!
      a_ell = b_ell/eps_ell
      if (lroot) print*,'vortex_2d: Ellipse axes (b_ell,a_ell)=', b_ell,a_ell
!
!  Limit vortex to within r_ell
!
      do n=n1,n2; do m=m1,m2
        r_ell = sqrt(x(l1:l2)**2/b_ell**2+y(m)**2/a_ell**2)
        xi = 1./(exp((1/width)*(r_ell-rbound))+1.)
!
!  Calculate velocities (Kepler speed subtracted)
!
        f(l1:l2,m,n,iux)=eps_ell**2*sigma*Omega*y(m)*xi
        f(l1:l2,m,n,iuy)=(qshear-sigma)  *Omega*x(l1:l2)*xi
      enddo; enddo
!
    endsubroutine vortex_2d
!***********************************************************************
    subroutine baroclinic(f,gamma,dlnrhobdx,co1_ss,co2_ss,cs20)
!
!  Remark 4-dez-09 bing: this routine is nowhere called! Is it still in use?
!
!  Baroclinic shearing sheet initial condition
!  11-nov-03/anders: coded
!
      real, dimension (mx,my,mz,mfarray) :: f
      real :: sz,I_int
      real :: gamma,dlnrhobdx,co1_ss,co2_ss,cs20
!
!  Specify vertical entropy and integral of exp(-sz/cp)*z
!
      do n=n1,n2; do m=m1,m2
        if (co1_ss/=0.0 .and. co2_ss==0.0) then
          if (lroot) print*,'baroclinic: sz =', co1_ss,'*abs(z(n))'
          sz = co1_ss*abs(z(n))
          I_int = 1/(co1_ss**2)*( 1 - exp(-sz) * (1+co1_ss*abs(z(n))) )
        elseif (co1_ss==0.0 .and. co2_ss/=0.0) then
          if (lroot) print*,'baroclinic: sz =', co2_ss,'*zz**2'
          sz = co2_ss*z(n)**2
          I_int = -1/(2*co2_ss)*( exp(-co2_ss*z(n)**2)-1 )
        elseif (lroot) then
          print*, 'baroclinic: no valid sz specified'
        endif
!
        f(l1:l2,m,n,iss) = sz
!
!  Solution to hydrostatic equlibrium in the z-direction
!
        f(l1:l2,m,n,ilnrho) = 1/(gamma-1)*log( (1-gamma)/cs20 * I_int + 1 ) - sz
!
!  Toroidal velocity comes from hyd. stat. eq. equ. in the x-direction
!
        f(l1:l2,m,n,iuy) = cs20/(2*Omega)*exp( gamma*f(l1:l2,m,n,iss) + &
            (gamma-1)*f(l1:l2,m,n,ilnrho) ) * dlnrhobdx/gamma
!
      enddo; enddo
!
    endsubroutine baroclinic
!***********************************************************************
    subroutine crazy(ampl,f,i)
!
!  A crazy initial condition
!  (was useful to initialize all points with finite values)
!
!  19-may-02/axel: coded
!
      integer :: i,j
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl
!
      if (lroot) print*, 'crazy: sinusoidal magnetic field: for debugging purposes'
      j=i; f(:,:,:,j)=f(:,:,:,j)+ampl*&
        spread(spread(sin(2*x),2,my),3,mz)*&
        spread(spread(sin(3*y),1,mx),3,mz)*&
        spread(spread(cos(1*z),1,mx),2,my)
      j=i+1; f(:,:,:,j)=f(:,:,:,j)+ampl*&
        spread(spread(sin(5*x),2,my),3,mz)*&
        spread(spread(sin(1*y),1,mx),3,mz)*&
        spread(spread(cos(2*z),1,mx),2,my)
      j=i+2; f(:,:,:,j)=f(:,:,:,j)+ampl*&
        spread(spread(sin(3*x),2,my),3,mz)*&
        spread(spread(sin(4*y),1,mx),3,mz)*&
        spread(spread(cos(2*z),1,mx),2,my)
!
    endsubroutine crazy
!***********************************************************************
    subroutine strange(ampl,f,i)
!
!  A strange initial condition !
!
!  24-april-09/dhruba: coded
!
      integer :: i,ix,iy
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl
!      real :: arg1,arg2
!
      if (lroot) print*, 'strange: magnetic field that satisfies open', &
          'vf condn: for debugging purposes'
      do ix=l1,l2
        do iy=m1,m2
!          arg1= pi*(x(ix)-xyz0(1))/(xyz1(1)-xyz0(1))
!          arg2= pi*(y(iy)-xyz0(2))/(xyz1(2)-xyz0(2))
          f(ix,iy,:,i)=ampl*cos(y(iy))
          f(ix,iy,:,i+1)=0.
          f(ix,iy,:,i+2)=0.
       enddo
     enddo
!
    endsubroutine strange
!***********************************************************************
    subroutine htanh(ampl,f,i1,eps)
!
!  Horizontal flux tanh (for vector potential, or passive scalar)
!
!  30-may-11/axel: tanh layer
!
      integer :: i1
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,eps
!
      if (ampl==0) then
        f(:,:,:,i1)=0
        if (lroot) print*,'htanh: set variable to zero; i1=',i1
      else
        if (lroot) then
          print*,'htanh: implement y-dependent flux tanh in xz-plane; i1=',i1
          print*,'htanh: eps=',eps
        endif
!
! completely quenched "gaussian"
!
        do n=n1,n2; do m=m1,m2
          f(l1:l2,m,n,i1)=ampl*log(cosh(eps*y(m)))
        enddo; enddo
      endif
!
    endsubroutine htanh
!***********************************************************************
    subroutine vtube(ampl,f,i1,i2,radius)
!
!  Vertical flux tube (for vector potential)
!  Note: in Cartesian coords this cannot be used for periodic xy mesh
!
!   1-apr-13/axel+MR: coded for cylindrical coordinates
!  14-jul-13/axel: adapted for Cartesian coordinates
!
      integer :: i1,i2
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (nx) :: rr,rr2,pp,Ap
      real :: ampl,radius
!
!  Aphi=[R^6-(R^2-r^2)^3]/6r, gives Bz=(R^2-r^2)^2
!
      if (ampl==0) then
        f(:,:,:,i1:i2)=0
        if (lroot) print*,'vtube: set variable to zero; i1,i2=',i1,i2
      else
        if (lroot) then
          print*,'vtube: r-dep tube in z-direction; ampl,radius=',ampl,radius
          if (i1==i2) then
            print*,'vtube: set scalar'
          else
            print*,'vtube: set vector'
          endif
        endif
!
!  Start with n=1 to set ghost zone (for freeze-ghost condition).
!  Br is close to zero.
!
        do n=1,n2; do m=m1,m2
!
!  check whether vector or scalar
!
          if (i1==i2) then
            f(l1:l2,m,n,i1)=0.
          elseif (i1+2==i2) then
            if (lcartesian_coords) then
              rr2=x(l1:l2)**2+y(m)**2; rr=sqrt(rr2); pp=atan2(y(m),x(l1:l2))
              Ap=ampl/(6.*rr)*(radius**6-max(radius**2-rr2,0.)**3)
              f(l1:l2,m,n,i1  )=f(l1:l2,m,n,i1  )-Ap*sin(pp)
              f(l1:l2,m,n,i1+1)=f(l1:l2,m,n,i1+1)+Ap*cos(pp)
            elseif (lcylindrical_coords) then
              Ap=ampl*rcyl_mn1/6.*(radius**6-max(radius**2-x(l1:l2)**2,0.)**3)
              f(l1:l2,m,n,i1+1)=f(l1:l2,m,n,i1+1)+Ap
            endif
          else
            if (lroot) print*,'vtube: bad value of i2=',i2
          endif
!
        enddo; enddo
      endif
!
    endsubroutine vtube
!***********************************************************************
    subroutine vtube_peri(ampl,f,i1,i2,radius)
!
!  Vertical flux tube (for vector potential) for periodic xy mesh
!
!  14-jul-13/axel: coded
!
      integer :: i1,i2
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (nx) :: rr2,tmp
      real :: ampl,radius
!
!  Aphi=[R^6-(R^2-r^2)^3]/6r, gives Bz=(R^2-r^2)^2
!
      if (ampl==0) then
        f(:,:,:,i1:i2)=0
        if (lroot) print*,'vtube: set variable to zero; i1,i2=',i1,i2
      else
        if (lroot) then
          print*,'vtube: r-dep tube in z-direction; ampl,radius=',ampl,radius
          if (i1==i2) then
            print*,'vtube: set scalar'
          else
            print*,'vtube: set vector'
          endif
        endif
!
!  Start with n=1 to set ghost zone (for freeze-ghost condition).
!  Br is close to zero.
!
        do n=1,n2; do m=m1,m2
!
!  check whether vector or scalar
!
          if (i1==i2) then
            f(l1:l2,m,n,i1)=0.
          elseif (i1+2==i2) then
            rr2=x(l1:l2)**2+y(m)**2
            tmp=ampl*exp(-.5*rr2/radius**2)/radius**2
            f(l1:l2,m,n,i1  )=f(l1:l2,m,n,i1  )-tmp*y(m)
            f(l1:l2,m,n,i1+1)=f(l1:l2,m,n,i1+1)+tmp*x(l1:l2)
          else
            if (lroot) print*,'vtube: bad value of i2=',i2
          endif
!
        enddo; enddo
      endif
!
    endsubroutine vtube_peri
!***********************************************************************
    subroutine htube(ampl,f,i1,i2,radius,eps,center1_x,center1_z)
!
!  Horizontal flux tube (for vector potential, or passive scalar)
!
!   7-jun-02/axel+vladimir: coded
!  11-sep-02/axel: allowed for scalar field (if i1=i2)
!
      integer :: i1,i2
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (nx) :: tmp,tube_radius_sqr !,modulate
      real :: ampl,radius,eps
      real :: center1_x,center1_z
!
      if (ampl==0) then
        f(:,:,:,i1:i2)=0
        if (lroot) print*,'htube: set variable to zero; i1,i2=',i1,i2
      else
        if (lroot) then
          print*,'htube: implement y-dependent flux tube in xz-plane; i1,i2=',i1,i2
          print*,'htube: radius,eps=',radius,eps
          if (i1==i2) then
            print*,'htube: set scalar'
          else
            print*,'htube: set vector'
          endif
        endif
!
! completely quenched "gaussian"
!
        do n=n1,n2; do m=m1,m2
          tube_radius_sqr=(x(l1:l2)-center1_x)**2+(z(n)-center1_z)**2
!         tmp=.5*ampl/modulate*exp(-tube_radius_sqr)/&
!                   (max((radius*modulate)**2-tube_radius_sqr,1e-6))
          tmp=ampl/(1.+tube_radius_sqr/radius**2)
!
!  check whether vector or scalar
!
          if (i1==i2) then
            f(l1:l2,m,n,i1)=tmp
          elseif (i1+2==i2) then
            f(l1:l2,m,n,i1 )=+(z(n)-center1_z)*tmp
            f(l1:l2,m,n,i1+1)=tmp*eps
            f(l1:l2,m,n,i1+2)=-(x(l1:l2)-center1_x)*tmp
          else
            if (lroot) print*,'htube: bad value of i2=',i2
          endif
!
        enddo; enddo
      endif
!
    endsubroutine htube
!***********************************************************************
    subroutine htube_x(ampl,f,i1,i2,radius,eps,center1_y,center1_z)
!
!  Horizontal flux tube pointing in the x-direction
!  (for vector potential, or passive scalar)
!
!  14-apr-09/axel: adapted from htube, used in paper with Violaine Auger
!                  in Vermersch & Brandenburg (2009, AN 330, 797-806).
!
      integer :: i1,i2
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (nx) :: tmp,modulate,tube_radius_sqr
      real :: ampl,radius,eps,kx
      real :: center1_y,center1_z
!
      if (ampl==0) then
        f(:,:,:,i1:i2)=0
        if (lroot) print*,'htube_x: set variable to zero; i1,i2=',i1,i2
      else
        kx=2*pi/Lx
        if (lroot) then
          print*,'htube_x: implement y-dependent flux tube in xz-plane; i1,i2=',i1,i2
          print*,'htube_x: radius,eps=',radius,eps
        endif
!
!  modulation pattern
!
        if (eps==0.) then
          modulate=1.
        else
          modulate=1.+eps*cos(kx*x(l1:l2))
        endif
!
! completely quenched "gaussian"
!
        do n=n1,n2; do m=m1,m2
          tube_radius_sqr=(y(m)-center1_y)**2+(z(n)-center1_z)**2
          tmp=modulate/(1.+tube_radius_sqr/radius**2)
!
!  check whether vector or scalar
!
          if (i1==i2) then
            if (lroot.and.ip<10) print*,'htube_x: set scalar'
            f(l1:l2,m,n,i1)=tmp
          elseif (i1+2==i2) then
            if (lroot.and.ip<10) print*,'htube_x: set vector'
            f(l1:l2,m,n,i1  )=+0.
            f(l1:l2,m,n,i1+1)=-(z(n)-center1_z)*tmp
            f(l1:l2,m,n,i1+2)=+(y(m)-center1_y)*tmp
         else
            if (lroot) print*,'htube_x: bad value of i2=',i2
          endif
!
        enddo; enddo
      endif
!
    endsubroutine htube_x
!***********************************************************************
    subroutine htube_erf(ampl,f,i1,i2,a,eps,center1_x,center1_z,width)
!
!  Horizontal flux tube (for vector potential) which gives
!  error-function border profile for the magnetic field., or passive scalar
!
!   18-mar-09/dhruba: adapted from htube
!
      use Sub, only: erfunc
!
      integer :: i1,i2,l
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,a,eps,width,tmp,radius,r_minus_a
      real :: center1_x,center1_z
!
      if (ampl==0) then
        f(:,:,:,i1:i2)=0
        if (lroot) print*,'htube_erf: set variable to zero; i1,i2=',i1,i2
      else
        if (lroot) then
          print*,'htube_erf: implement y-dependent flux tube in xz-plane; i1,i2=',i1,i2
          print*,'htube_erf: radius,eps=',a,eps
          if (i1==i2) then
            print*,'htube_erf: set scalar'
          else
            print*,'htube_erf: set vector'
          endif
        endif
!
! An integral of error function.
!
        do n=n1,n2; do l=l1,l2
          radius= sqrt((x(l)-center1_x)**2+(z(n)-center1_z)**2)
          r_minus_a= radius -a
          if (radius > tini) then
!            tmp = (-(exp(-width*a_minus_r**2))/(4.*sqrt(pi)*width) +  &
!                radius*(1+erfunc(width*a_minus_r))/4. + &
!                2*a*(exp(-(a**2)*(width**2)) - exp(-(a_minus_r**2)*(width**2)))/(8.*radius*width) + &
!                (1+2*(a**2)*(width**2))*(erfunc(a*width) - erfunc(width*a_minus_r))/(8.*radius*width**2))/radius
            tmp = (radius**2/2-0.5*(radius+a)*(r_minus_a*erfunc(r_minus_a/width)+width*exp(-r_minus_a**2/width**2)/sqrt(pi))&
                  +0.25*width**2*erfunc(r_minus_a/width)+0.5*a*(-a*erfunc(-a/width)+width*exp(-a**2/width**2)/sqrt(pi))&
                  -0.25*width**2*erfunc(-a/width))/radius**2
          else
            tmp = 0
            write(*,*) 'radius <  tini',radius,tini
          endif
!
!  check whether vector or scalar
!
          if (i1==i2) then
            f(l,:,n,i1)=tmp
          elseif (i1+2==i2) then
            f(l,:,n,i1 )=f(l,:,n,i1)-(z(n)-center1_z)*tmp*ampl
            f(l,:,n,i1+1)=f(l,:,n,i1+1)+tmp*eps
            f(l,:,n,i1+2)=f(l,:,n,i1+2)+(x(l)-center1_x)*tmp*ampl
         else
            if (lroot) print*,'htube_erf: bad value of i2=',i2
          endif
!
        enddo; enddo
      endif
!
    endsubroutine htube_erf
!***********************************************************************
    subroutine htube2(ampl,f,i1,i2,radius,epsilon_nonaxi)
!
!  Horizontal flux tube (for vector potential, or passive scalar)
!
!   7-jun-02/axel+vladimir: coded
!  11-sep-02/axel: allowed for scalar field (if i1=i2)
!
      integer :: i1,i2
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (nx) :: tmp,modulate
      real :: ampl,radius,epsilon_nonaxi,ky
!
      if (ampl==0) then
        f(:,:,:,i1:i2)=0
        if (lroot) print*,'htube2: set variable to zero; i1,i2=',i1,i2
      else
        ky=2*pi/Ly
        if (lroot) then
          print*,'htube2: implement y-dependent flux tube in xz-plane; i1,i2=',i1,i2
          print*,'htube2: radius,epsilon_nonaxi=',radius,epsilon_nonaxi
        endif
!
!  constant, when epsilon_nonaxi; otherwise modulation about zero
!
        do n=n1,n2; do m=m1,m2
          if (epsilon_nonaxi==0) then
            modulate(:)=1.0
          else
            modulate=epsilon_nonaxi*sin(ky*y(m))
          endif
!
! completely quenched "gaussian"
!
          tmp=.5*ampl*modulate*exp(-(x(l1:l2)**2+z(n)**2)/radius**2)
!
!  check whether vector or scalar
!
          if (i1==i2) then
            if (lroot .and. n==n1 .and. m==m1) print*,'htube2: set scalar'
            f(l1:l2,m,n,i1)=tmp
          elseif (i1+2==i2) then
            if (lroot .and. n==n1 .and. m==m1) print*,'htube2: set vector'
            f(l1:l2,m,n,i1 )=+z(n)*tmp
            f(l1:l2,m,n,i1+1)=0.
            f(l1:l2,m,n,i1+2)=-x(l1:l2)*tmp
          else
            if (lroot) print*,'htube2: bad value of i2=',i2
          endif
        enddo; enddo
      endif
!
    endsubroutine htube2
!***********************************************************************
    subroutine htube2_x(ampl,f,i1,i2,radius,epsilon_nonaxi,qtube,center1_y,center1_z,scale_y)
!
!
!  Horizontal twisted flux tube in the x-direction (for vector potential, or passive scalar)
!  y axis can be stretched to form a flattened tube
!
!  17-may-15/piyali.chatterjee: coded from  htube2
!
      integer :: i1,i2
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (mx) :: tmp,modulate
      real :: ampl,radius,epsilon_nonaxi,kx,qtube
      real :: center1_y,center1_z,rhorad
      real, optional :: scale_y
!
        kx=2*pi/Lx
        if (lroot) then
          print*,'htube2_x: implement x-dependent flux tube in yz-plane; i1,i2=',i1,i2
          print*,'htube2_x: radius,epsilon_nonaxi=',radius,epsilon_nonaxi
        endif
!
!  constant, when epsilon_nonaxi; otherwise modulation about zero
!
        do n=1,mz; do m=1,my
          if (epsilon_nonaxi==0) then
            modulate(:)=1.0
          else
            modulate(:)=epsilon_nonaxi*sin(kx*x(:))
          endif
!
! completely quenched "gaussian"
          if (present(scale_y))  then
            rhorad=sqrt((scale_y*(y(m)-center1_y))**2+(z(n)-center1_z)**2)
            tmp=.5*ampl*modulate*radius**2*&
                (1.-exp(-(rhorad/radius)**2))/rhorad
          else
            rhorad=sqrt((y(m)-center1_y)**2+(z(n)-center1_z)**2)
            tmp=.5*ampl*modulate*radius**2*&
                (1.-exp(-(rhorad/radius)**2))/rhorad
          endif
!
!  check whether vector or scalar
!
          if (i1==i2) then
            if (lroot.and.ip<10) print*,'htube2_x: set scalar'
            f(:,m,n,i1)=f(:,m,n,i1)+tmp
          elseif (i1+2==i2) then
            if (lroot.and.ip<10) print*,'htube2_x: set vector'
            f(:,m,n,i1  )=f(:,m,n,i1)+qtube*tmp*rhorad
            f(:,m,n,i1+1)=f(:,m,n,i1+1)-(z(n)-center1_z)*tmp/rhorad
            f(:,m,n,i1+2)=f(:,m,n,i1+2)+(y(m)-center1_y)*tmp/rhorad
         else
            if (lroot) print*,'htube2_x: bad value of i2=',i2
          endif
!
        enddo; enddo
!
    endsubroutine htube2_x
!***********************************************************************
    subroutine magsupport(ampl,f,gravz,cs0,rho0)
!
!  magnetically supported horizontal flux layer
!  (for aa):  By^2 = By0^2 * exp(-z/H),
!  where H=2*cs20/abs(gravz) and ampl=cs0*sqrt(2*rho0)
!  should be used when invoking this routine.
!  Here, ampl=pmag/pgas.
!
!   7-dec-02/axel: coded
!
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,H,A0,gravz,cs0,rho0,lnrho0
!
      if (ampl==0) then
        if (lroot) print*,'magsupport: do nothing'
      else
        lnrho0=log(rho0)
        H=(1+ampl)*cs0**2/abs(gravz)
        A0=-2*H*ampl*cs0*sqrt(2*rho0)
        if (lroot) print*,'magsupport: H,A0=',H,A0
        do n=n1,n2; do m=m1,m2
          f(l1:l2,m,n,iaa)=A0*exp(-.5*z(n)/H)
          f(l1:l2,m,n,ilnrho)=lnrho0-z(n)/H
        enddo; enddo
      endif
!
    endsubroutine magsupport
!***********************************************************************
    subroutine hfluxlayer(ampl,f,i,zflayer,width)
!
!  Horizontal flux layer (for vector potential)
!
!  19-jun-02/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,zflayer,width
!
      if (ampl==0) then
        f(:,:,:,i:i+2)=0
        if (lroot) print*,'hfluxlayer: set variable to zero; i=',i
      else
        if (lroot) print*,'hfluxlayer: horizontal flux layer; i=',i
        if ((ip<=16).and.lroot) print*,'hfluxlayer: ampl,width=',ampl,width
        do n=n1,n2; do m=m1,m2
          f(l1:l2,m,n,i  )=0.0
          f(l1:l2,m,n,i+1)=ampl*tanh((z(n)-zflayer)/width)
          f(l1:l2,m,n,i+2)=0.0
        enddo; enddo
      endif
!
    endsubroutine hfluxlayer
!***********************************************************************
    subroutine hfluxlayer_y(ampl,f,i,zflayer,width,ladd_bb)
!
!  Horizontal flux layer (for vector potential)
!
!  09-apr-10/piyali: copied from hfluxlayer
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,zflayer,width
      logical, intent(in), optional :: ladd_bb
!
      if (ampl==0) then
        f(:,:,:,i:i+2)=0
        if (lroot) print*,'hfluxlayer-y: set variable to zero; i=',i
      else
        if (lroot) print*,'hfluxlayer-y: horizontal flux layer; i=',i
        if ((ip<=16).and.lroot) print*,'hfluxlayer-y: ampl,width=',ampl,width
        if (ladd_bb) then
          do n=n1,n2; do m=m1,m2
            f(l1:l2,m,n,i  )=f(l1:l2,m,n,i  )+ampl*tanh((z(n)-zflayer)/width)
            f(l1:l2,m,n,i+1)=f(l1:l2,m,n,i+1)
            f(l1:l2,m,n,i+2)=f(l1:l2,m,n,i+2)
          enddo; enddo
        else
          do n=n1,n2; do m=m1,m2
            f(l1:l2,m,n,i  )=ampl*tanh((z(n)-zflayer)/width)
            f(l1:l2,m,n,i+1)=0.0
            f(l1:l2,m,n,i+2)=0.0
          enddo; enddo
        endif
      endif
!
    endsubroutine hfluxlayer_y
!***********************************************************************
    subroutine hfluxlayer_y_theta(ampl,f,i)
!
!  Horizontal flux layer (for vector potential)
!
!  19-jul-13/axel+illa: copied from hfluxlayer_y
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl
!
      if (ampl==0) then
        f(:,:,:,i:i+2)=0
        if (lroot) print*,'hfluxlayer-y-theta: set variable to zero; i=',i
      else
        if (lroot) print*,'hfluxlayer-y-theta: horizontal flux layer; i=',i
        if ((ip<=16).and.lroot) print*,'hfluxlayer-y-theta: ampl=',ampl
        do n=n1,n2; do m=m1,m2
          f(l1:l2,m,n,i  )=-ampl*max(-z(n),0.)
          f(l1:l2,m,n,i+1)=0.0
          f(l1:l2,m,n,i+2)=0.0
        enddo; enddo
      endif
!
    endsubroutine hfluxlayer_y_theta
!***********************************************************************
    subroutine vfluxlayer(ampl,f,i,xflayer,width)
!
!  Vertical flux layer (for vector potential)
!
!  22-mar-04/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,xflayer,width
!
      if (ampl==0) then
        f(:,:,:,i:i+2)=0
        if (lroot) print*,'hfluxlayer: set variable to zero; i=',i
      else
        if (lroot) print*,'hfluxlayer: horizontal flux layer; i=',i
        if ((ip<=16).and.lroot) print*,'hfluxlayer: ampl,width=',ampl,width
        do n=n1,n2; do m=m1,m2
          f(l1:l2,m,n,i  )=0.0
          f(l1:l2,m,n,i+1)=0.0
          f(l1:l2,m,n,i+2)=-ampl*tanh((x(l1:l2)-xflayer)/width)
        enddo; enddo
      endif
!
    endsubroutine vfluxlayer
!***********************************************************************
    subroutine arcade_x(ampl,f,i,kx,kz)
!
!  Arcade-like structures around x=0
!
!  17-jun-04/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,kx,kz,zmid
!
      if (ampl==0) then
        f(:,:,:,i:i+2)=0
        if (lroot) print*,'expcos_x: set variable to zero; i=',i
      else
        zmid=.5*(xyz0(3)+xyz1(3))
        if ((ip<=16).and.lroot) then
          print*,'arcade_x: i,zmid=',i,zmid
          print*,'arcade_x: ampl,kx,kz=',ampl,kx,kz
        endif
!
        do n=n1,n2; do m=m1,m2
!         f(l1:l2,m,n,i+1)=f(l1:l2,m,n,i+1)+ampl*exp(-.5*(kx*x(l1:l2))**2)* &
!           cos(min(abs(kz*(z(n)-zmid)),.5*pi))
          f(l1:l2,m,n,i+1)=f(l1:l2,m,n,i+1) &
            +ampl*cos(kx*x(l1:l2))*exp(-abs(kz*z(n)))
        enddo; enddo
!
      endif
!
    endsubroutine arcade_x
!***********************************************************************
    subroutine halfcos_x(ampl,f,i)
!
!  Half-cosine (i.e., like gaussian bump, but periodic) for Bx field
!
!  19-jun-02/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,kz,zbot
!
      if (ampl==0) then
        f(:,:,:,i:i+2)=0
        if (lroot) print*,'halfcos_x: set variable to zero; i=',i
      else
        print*,'halscos_x: half cosine x-field ; i=',i
        kz=0.5*pi/Lz
        zbot=xyz0(3)
        if ((ip<=16).and.lroot) print*,'halfcos_x: ampl,kz=',ampl,kz
        do n=n1,n2; do m=m1,m2
          f(l1:l2,m,n,i  )=0.0
          f(l1:l2,m,n,i+1)=-ampl*sin(kz*(z(n)-zbot))
          f(l1:l2,m,n,i+2)=0.0
        enddo; enddo
      endif
!
    endsubroutine halfcos_x
!***********************************************************************
    subroutine halfcos_z(ampl,f,i)
!
!  Half-cosine (i.e., like gaussian bump, but periodic) for Bz field
!
!  19-jun-02/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,kx
!
      if (ampl==0) then
        f(:,:,:,i:i+2)=0
        if (lroot) print*,'halfcos_z: set variable to zero; i=',i
      else
        print*,'halscos_z: half cosine z-field ; i=',i
        kx=2*pi/Lx
        if ((ip<=16).and.lroot) print*,'halfcos_z: ampl,kz=',ampl,kx
        do n=n1,n2; do m=m1,m2
          f(l1:l2,m,n,i  )=0.0
          f(l1:l2,m,n,i+1)=ampl/kx*sin(kx*x(l1:l2))
          f(l1:l2,m,n,i+2)=0.0
        enddo; enddo
      endif
!
    endsubroutine halfcos_z
!***********************************************************************
    subroutine uniform_x(ampl,f,i)
!
!  Uniform B_x field (for vector potential)
!
!  19-jun-02/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl
!
      if (ampl==0) then
        f(:,:,:,i:i+2)=0
        if (lroot) print*,'uniform_x: set variable to zero; i=',i
      else
        print*,'uniform_x: uniform x-field ; i=',i
        if ((ip<=16).and.lroot) print*,'uniform_x: ampl=',ampl
        do n=1,mz; do m=1,my
          f(:,m,n,i  )=0.0
          f(:,m,n,i+1)=-ampl*z(n)
          f(:,m,n,i+2)=0.0
        enddo; enddo
      endif
!
    endsubroutine uniform_x
!***********************************************************************
    subroutine uniform_y(ampl,f,i)
!
!  Uniform B_y field (for vector potential)
!
!  27-jul-02/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl
!
      if (ampl==0) then
        f(:,:,:,i:i+2)=0
        if (lroot) print*,'uniform_y: set variable to zero; i=',i
      else
        print*,'uniform_y: uniform y-field ; i=',i
        if ((ip<=16).and.lroot) print*,'uniform_y: ampl=',ampl
        do n=n1,n2; do m=m1,m2
          f(l1:l2,m,n,i  )=ampl*z(n)
          f(l1:l2,m,n,i+1)=0.0
          f(l1:l2,m,n,i+2)=0.0
        enddo; enddo
      endif
!
    endsubroutine uniform_y
!***********************************************************************
    subroutine uniform_z(ampl,f,i)
!
!  Uniform B_z field (for vector potential)
!
!  24-jul-03/axel: adapted from uniform_x
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl
!
      if (ampl==0) then
        f(:,:,:,i:i+2)=0
        if (lroot) print*,'uniform_z: set variable to zero; i=',i
      else
        print*,'uniform_z: uniform z-field ; i=',i
        if ((ip<=16).and.lroot) print*,'uniform_z: ampl=',ampl
        do n=n1,n2; do m=m1,m2
          if (lcartesian_coords) then
            f(l1:l2,m,n,i  )=0.0
            f(l1:l2,m,n,i+1)=+ampl*x(l1:l2)
            f(l1:l2,m,n,i+2)=0.0
          elseif (lcylindrical_coords) then
            f(l1:l2,m,n,i  )=0.0
            f(l1:l2,m,n,i+1)=-ampl*x(l1:l2)*y(m)
            f(l1:l2,m,n,i+2)=0.0
          endif
        enddo; enddo
      endif
!
    endsubroutine uniform_z
!***********************************************************************
    subroutine uniform_phi(ampl,f,i)
!
!  Uniform B_phi field (for vector potential)
!
!  27-jul-02/axel: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real, dimension (nx) :: rr
      real :: ampl
!
      if (ampl==0) then
        f(:,:,:,i:i+2)=0
        if (lroot) print*,'uniform_phi: set variable to zero; i=',i
      else
        print*,'uniform_phi: uniform phi-field ; i=',i
        if ((ip<=16).and.lroot) print*,'uniform_phi: ampl=',ampl
        do n=n1,n2; do m=m1,m2
          rr=sqrt(x(l1:l2)**2+y(m)**2)
          f(l1:l2,m,n,i  )=0.0
          f(l1:l2,m,n,i+1)=0.0
          f(l1:l2,m,n,i+2)=-ampl*rr
        enddo; enddo
      endif
!
    endsubroutine uniform_phi
!***********************************************************************
    subroutine Gaussian_By_z(ampl,f,i,z0_gaussian,width_gaussian)
!
!  Gaussian B_y field (for vector potential)
!
!  29-mar-23/nishant+rajesh: coded
!
      use Sub, only: erfunc

      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl, z0_gaussian, width_gaussian
!
      if (ampl==0) then
        f(:,:,:,i:i+2)=0
        if (lroot) print*,'uniform_y: set variable to zero; i=',i
      else
        print*,'uniform_y: uniform y-field ; i=',i
        if ((ip<=16).and.lroot) print*,'uniform_y: ampl=',ampl
        do n=n1,n2; do m=m1,m2
          f(l1:l2,m,n,i  )=ampl*erfunc((z(n)-z0_gaussian)/width_gaussian)
          f(l1:l2,m,n,i+1)=0.0
          f(l1:l2,m,n,i+2)=0.0
        enddo; enddo
      endif
!
    endsubroutine Gaussian_By_z
!***********************************************************************
    subroutine phi_comp_over_r(ampl,f,i)
!
!  B_phi ~ 1/R field (in terms of vector potential)
!  meaningful mainly in cylindrical coordinates, otherwise it will be By~1/x
!
!  05-jul-07/mgellert: coded
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl
!
      if (ampl==0) then
        f(:,:,:,i:i+2)=0
        if (lroot) print*,'phi_comp_over_r: set variable to zero; i=',i
      else
        if (coord_system=='cylindric') then
          print*,'phi_comp_over_r: set Bphi ~ 1/r ; i=',i
        else
          print*,'phi_comp_over_r: set By ~ 1/x ; i=',i
        endif
        if ((ip<=16).and.lroot) print*,'phi_comp_over_r: ampl=',ampl
        do n=n1,n2; do m=m1,m2
          f(l1:l2,m,n,i  )=0.0!ampl*z(n)/x(l1:l2)
          f(l1:l2,m,n,i+1)=0.0
          f(l1:l2,m,n,i+2)=-ampl*log(x(l1:l2))
        enddo; enddo
      endif
!
    endsubroutine phi_comp_over_r
!***********************************************************************
    subroutine vfield(ampl,f,i,kx)
!
!  Vertical field, for potential field test
!
!  14-jun-02/axel: coded
!  02-aug-2005/joishi: allowed for arbitrary kx
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl
      real, optional :: kx
      real :: k
!
      if (present(kx)) then
         k = kx
      else
         k = 2*pi/Lx
      endif
!
      if (ampl==0) then
        f(:,:,:,i:i+2)=0
        if (lroot) print*,'vfield: set variable to zero; i=',i
      else
        if (lroot) print*,'vfield: implement x-dependent vertical field'
        if ((ip<=8).and.lroot) print*,'vfield: x-dependent vertical field'
        do n=n1,n2; do m=m1,m2
          f(l1:l2,m,n,i  )=0.0
          f(l1:l2,m,n,i+1)=ampl*sin(k*x(l1:l2))
          f(l1:l2,m,n,i+2)=0.0
        enddo; enddo
      endif
!
    endsubroutine vfield
!***********************************************************************
    subroutine vfield2(ampl,f,i)
!
!  Vertical field, zero on boundaries
!
!  22-jun-04/anders: adapted from vfield
!
      integer :: i
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,kx
!
      if (ampl==0) then
        f(:,:,:,i:i+2)=0
        if (lroot) print*,'vfield2: set variable to zero; i=',i
      else
        kx=2*pi/Lx
        if (lroot) print*,'vfield2: implement x-dependent vertical field'
        do n=n1,n2; do m=m1,m2
          f(l1:l2,m,n,i  )=0.0
          f(l1:l2,m,n,i+1)=ampl*cos(kx*x(l1:l2))
          f(l1:l2,m,n,i+2)=0.0
        enddo; enddo
      endif
!
    endsubroutine vfield2
!***********************************************************************
    subroutine posnoise_vect(ampl,f,i1,i2)
!
!  Add Gaussian noise (= normally distributed) white noise for variables i1:i2
!
!  28-may-04/axel: adapted from gaunoise
!
      integer :: i,i1,i2
      real, dimension (mx) :: tmp
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl
!
!  set gaussian random noise vector
!
      if (ampl==0) then
        if (lroot) print*,'posnoise_vect: ampl=0 for i1,i2=',i1,i2
      else
        if ((ip<=8).and.lroot) print*,'posnoise_vect: i1,i2=',i1,i2
        do n=1,mz; do m=1,my
          do i=i1,i2
            call random_number_wrapper(tmp)
            f(:,m,n,i)=f(:,m,n,i)+ampl*tmp
          enddo
        enddo; enddo
      endif
!
    endsubroutine posnoise_vect
!***********************************************************************
    subroutine posnoise_scal(ampl,f,i)
!
!  Add Gaussian (= normally distributed) white noise for variable i
!
!  28-may-04/axel: adapted from gaunoise
!
      integer :: i
      real, dimension (mx) :: tmp
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl
!
!  set positive random noise vector
!
      if (ampl==0) then
        if (lroot) print*,'posnoise_scal: ampl=0 for i=',i
      else
        if ((ip<=8).and.lroot) print*,'posnoise_scal: i=',i
        if (lroot) print*,'posnoise_scal: variable i=',i
        do n=1,mz; do m=1,my
          call random_number_wrapper(tmp)
          f(:,m,n,i)=f(:,m,n,i)+ampl*tmp
        enddo; enddo
      endif
!
!  Wouldn't the following be equivalent (but clearer)?
!
!  call posnoise_vect(ampl,f,i,i)
!
!
    endsubroutine posnoise_scal
!***********************************************************************
    subroutine posnoise_rel_vect(ampl,ampl_rel,f,i1,i2)
!
!  Add noise (= box distributed) white noise for variables i1:i2
!
!  28-may-04/axel: adapted from gaunoise
!
      integer :: i,i1,i2
      real, dimension (mx) :: tmp
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,ampl_rel
!
!  set random noise vector
!
      if (ampl==0) then
        if (lroot) print*,'posnoise_vect: ampl=0 for i1,i2=',i1,i2
      else
        if ((ip<=8).and.lroot) print*,'posnoise_vect: i1,i2=',i1,i2
        do n=1,mz; do m=1,my
          do i=i1,i2
            call random_number_wrapper(tmp)
            f(:,m,n,i)=f(:,m,n,i)+ampl*(1.+ampl_rel*(tmp-0.5))
          enddo
        enddo; enddo
      endif
!
    endsubroutine posnoise_rel_vect
!***********************************************************************
    subroutine posnoise_rel_scal(ampl,ampl_rel,f,i)
!
!  Add noise (= box distributed) white noise for variables i1:i2
!
!  28-may-04/axel: adapted from gaunoise
!
      integer :: i
      real, dimension (mx) :: tmp
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,ampl_rel
!
!  set random noise vector
!
      if (ampl==0) then
        if (lroot) print*,'posnoise_vect: ampl=0 for i=',i
      else
        if ((ip<=8).and.lroot) print*,'posnoise_vect: i=',i
          if (lroot) print*,'posnoise_vect: variable i=',i
        do n=1,mz; do m=1,my
          call random_number_wrapper(tmp)
          f(:,m,n,i)=f(:,m,n,i)+ampl*(1.+ampl_rel*(tmp-0.5))
        enddo; enddo
      endif
!
    endsubroutine posnoise_rel_scal
!***********************************************************************
    subroutine gaunoise_vect(ampl,f,i1,i2)
!
!  Add Gaussian noise (= normally distributed) white noise for variables i1:i2
!
!  23-may-02/axel: coded
!  10-sep-03/axel: result only *added* to whatever f array had before
!
      real :: ampl
      real, dimension (mx,my,mz,mfarray) :: f
      integer :: i1,i2
!
      intent(in)    :: ampl,i1,i2
      intent(inout) :: f
!
      real, dimension (mx) :: r,p,tmp
      integer :: i,n,m
!
!  set gaussian random noise vector
!
      if (ampl==0) then
        if (lroot) print*,'gaunoise_vect: ampl=0 for i1,i2=',i1,i2
      else
        if ((ip<=8).and.lroot) print*,'gaunoise_vect: i1,i2=',i1,i2
        do n=1,mz; do m=1,my
          do i=i1,i2
            if (lroot.and.m==1.and.n==1) print*,'gaunoise_vect: variable i=',i
            if (modulo(i-i1,2)==0) then
              call random_number_wrapper(r)
              call random_number_wrapper(p)
              tmp=sqrt(-2*log(r))*sin(2*pi*p)
            else
              tmp=sqrt(-2*log(r))*cos(2*pi*p)
            endif
            f(:,m,n,i)=f(:,m,n,i)+ampl*tmp
          enddo
        enddo; enddo
      endif
!
    endsubroutine gaunoise_vect
!***********************************************************************
    subroutine gaunoise_scal(ampl,f,i)
!
!  Add Gaussian (= normally distributed) white noise for variable i
!
!  23-may-02/axel: coded
!  10-sep-03/axel: result only *added* to whatever f array had before
!
      real :: ampl
      real, dimension (mx,my,mz,mfarray) :: f
      integer :: i
!
      real, dimension (mx) :: r,p,tmp
!
      intent(in)    :: ampl,i
      intent(inout) :: f
!
!  set gaussian random noise vector
!
      if (ampl==0) then
        if (lroot) print*,'gaunoise_scal: ampl=0 for i=',i
      else
        if ((ip<=8).and.lroot) print*,'gaunoise_scal: i=',i
        if (lroot) print*,'gaunoise_scal: variable i=',i
        do n=1,mz; do m=1,my
          call random_number_wrapper(r)
          call random_number_wrapper(p)
          tmp=sqrt(-2*log(r))*sin(2*pi*p)
          f(:,m,n,i)=f(:,m,n,i)+ampl*tmp
        enddo; enddo
      endif
!
!  Wouldn't the following be equivalent (but clearer)?
!
!  call gaunoise_vect(ampl,f,i,i)
!
!
    endsubroutine gaunoise_scal
!***********************************************************************
    subroutine gaunoise_prof_vect(ampl,f,i1,i2)
!
!  Add Gaussian (= normally distributed) white noise for variables i1:i2
!  with amplitude profile AMPL.
!
! 18-apr-04/wolf: adapted from gaunoise_vect
!
      real, dimension (nz) :: ampl
      real, dimension (mx,my,mz,mfarray) :: f
      integer :: i1,i2
!
      real, dimension (mx) :: r,p,tmp
      integer :: i
!
      intent(in)    :: ampl,i1,i2
      intent(inout) :: f
!
      if ((ip<=8).and.lroot) print*,'GAUNOISE_PROF_VECT: i1,i2=',i1,i2
      do n=n1,n2; do m=1,my
        do i=i1,i2
          if (lroot.and.m==1.and.n==n1) print*,'gaunoise_vect: variable i=',i
          if (modulo(i-i1,2)==0) then
            call random_number_wrapper(r)
            call random_number_wrapper(p)
            tmp=sqrt(-2.*log(r))*sin(2.*pi*p)
          else
            tmp=sqrt(-2.*log(r))*cos(2.*pi*p)
          endif
          f(:,m,n,i)=f(:,m,n,i)+ampl(n-nghost)*tmp
        enddo
      enddo; enddo
!
    endsubroutine gaunoise_prof_vect
!***********************************************************************
    subroutine gaunoise_prof_scal(ampl,f,i)
!
!  Add Gaussian (= normally distributed) white noise for variable i with
!  amplitude profile AMPL.
!
! 18-apr-04/wolf: coded
!
      real, dimension (nz) :: ampl
      real, dimension (mx,my,mz,mfarray) :: f
      integer :: i
!
      intent(in)    :: ampl,i
      intent(inout) :: f
!
      if ((ip<=8).and.lroot) print*,'GAUNOISE_PROF_SCAL: i=',i
      call gaunoise_prof_vect(ampl,f,i,i)
!
    endsubroutine gaunoise_prof_scal
!***********************************************************************
    subroutine gaunoise_rprof_vect(ampl,f,i1,i2,rnoise_int,rnoise_ext)
!
!  Add Gaussian noise within rnoise_int < r < rnoise_ext.
!  Use PROF as buffer variable so we don't need to allocate a large
!  temporary.
!
!  18-apr-04/wolf: coded
!
      use Sub, only: cubic_step, get_radial_distance
!
      real :: ampl,rnoise_int,rnoise_ext
      real, dimension (mx,my,mz,mfarray) :: f
      integer :: i1,i2
!
      real, dimension (mx) :: prof, rr, r, p, tmp, rr_cyl, rr_sph
      real :: dr
      integer :: i
!
      intent(in)  :: ampl,i1,i2
      intent(inout) :: f
!
!  The default is noise in the range r_int < r < r_ext, but the user
!  is allowed to use a different range by initializing the variables
!  rnoise_int and rnoise_ext
!
      if (rnoise_int == impossible) rnoise_int=r_int
      if (rnoise_ext == impossible) rnoise_ext=r_ext
!
!  set up profile
!
      dr = rnoise_ext-max(0.,rnoise_int)
!
      do n=1,mz; do m=1,my
        call get_radial_distance(rr_sph,rr_cyl)
        if (lcylindrical_coords.or.lcylinder_in_a_box) rr=rr_cyl
        if (lspherical_coords  .or.lsphere_in_a_box)   rr=rr_sph
        prof = 1 - cubic_step(rr,rnoise_ext,0.25*dr,SHIFT=-1.)
!
        if (r_int>0.) then
          prof = prof*cubic_step(rr,rnoise_int,0.25*dr,SHIFT=1.)
        endif
        prof = ampl*prof
!
        do i=i1,i2
          if (lroot.and.m==1.and.n==1) print*,'gaunoise_vect: variable i=',i
          if (modulo(i-i1,2)==0) then
            call random_number_wrapper(r)
            call random_number_wrapper(p)
            tmp=sqrt(-2*log(r))*sin(2*pi*p)
          else
            tmp=sqrt(-2*log(r))*cos(2*pi*p)
          endif
          f(:,m,n,i)=f(:,m,n,i)+prof*tmp
        enddo
!
      enddo; enddo
!
    endsubroutine gaunoise_rprof_vect
!***********************************************************************
    subroutine gaunoise_rprof_scal(ampl,f,i,rnoise_int,rnoise_ext)
!
!  Add Gaussian noise within r_int < r < r_ext.
!  Use PROF as buffer variable so we don't need to allocate a large
!  temporary.
!
!  18-apr-04/wolf: coded
!
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,rnoise_int,rnoise_ext
      integer :: i
!
      intent(in) :: ampl,i
      intent(out) :: f
!
      call gaunoise_rprof_vect(ampl,f,i,i,rnoise_int,rnoise_ext)
!
    endsubroutine gaunoise_rprof_scal
!***********************************************************************
    subroutine trilinear(f,ivar,amplx,amply,amplz)
!
!  Produce a profile that is linear in any non-periodic direction, but
!  periodic in periodic ones (for testing purposes).
!
!  5-nov-02/wolf: coded
! 23-nov-02/axel: included scaling factor ampl, corrected lperi argument
!
      real :: amplx,amply,amplz
      real, dimension (mx,my,mz,mfarray) :: f
      integer :: ivar
!
      real, dimension (nx) :: tmp
!
      if (lroot) print*, 'trilinear: ivar = ', ivar
!
!  x direction
!
      do n=n1,n2; do m=m1,m2
        if (lperi(1)) then
          tmp = amplx*sin(2*pi/Lx*(x(l1:l2)-xyz0(1)-0.25*Lxyz(1)))
        else
          tmp = amplx*x(l1:l2)
        endif
!
!  y direction
!
        if (lperi(2)) then
          tmp = tmp + amply*sin(2*pi/Ly*(y(m)-xyz0(2)-0.25*Lxyz(2)))
        else
          tmp = tmp + amply*y(m)
        endif
!
!  z direction
!
        if (lperi(3)) then
          tmp = tmp + amplz*sin(2*pi/Lz*(z(n)-xyz0(3)-0.25*Lxyz(3)))
        else
          tmp = tmp + amplz*z(n)
        endif
!
        f(l1:l2,m,n,ivar) = tmp
!
      enddo; enddo
!
    endsubroutine trilinear
!***********************************************************************
    subroutine triquad(ampl,f,ivar,kx,ky,kz,kxx,kyy,kzz)
!
!  Produce a profile that is quadratic in any non-periodic direction, but
!  constant in periodic ones, with optional coefficients.
!
!  20-jul-09/hubbard: coded
!
      real :: ampl
      real, dimension (mx,my,mz,mfarray) :: f
      integer :: ivar
!
      real, dimension (nx) :: tmp
!
      real, optional :: kx,ky,kz,kxx,kyy,kzz
!
      if (lroot) print*, 'triquad: ivar = ', ivar
!
!  linear portion
!
!  x direction
!
      do n=n1,n2; do m=m1,m2
        tmp = 0.
        if (.not. lperi(1)) then
          if (present(kx)) then
            tmp = kx*x(l1:l2)
          endif
        endif
!
!  y direction
!
        if (.not. lperi(2)) then
          if (present(ky)) then
            tmp = tmp + ky*y(m)
          endif
        endif
!
!  z direction
!
        if (.not. lperi(3)) then
          if (present(kz)) then
            tmp = tmp + kz*z(n)
          endif
        endif
!
        f(l1:l2,m,n,ivar) = ampl*tmp
!
      enddo; enddo
!
!  quadratic portion
!  negative ampl is because parabola is based on -x**2
!
  if (present(kxx)) call parabola(-ampl*abs(kxx)/kzz,f,icc,kx=kxx)
  if (present(kyy)) call parabola(-ampl*abs(kyy)/kzz,f,icc,ky=kyy)
  if (present(kzz)) call parabola(-ampl*abs(kzz)/kzz,f,icc,kz=kzz)
!
    endsubroutine triquad
!***********************************************************************
    subroutine isotdisk(powerlr,f,ivar,zoverh,hoverr)
!
!  eek
!
! 21-jul-09/hubbard: coded
!
      real :: powerlr
      real, dimension (mx,my,mz,mfarray) :: f
      integer :: ivar
!
      real :: zoverh, hoverr
!
      if (lroot) print*, 'isotdisk: ivar = ', ivar
!
!
      do n=1,mz; do m=1,my
        f(1:mx,m,n,ivar) = f(1:mx,m,n,ivar) + ((1.5*zoverh**2-powerlr)*x(1:mx) &
            -zoverh/(hoverr)*z(n) &
            +(powerlr/2-3*zoverh**2)*x(1:mx)**2 &
            -0.5/(hoverr**2)*z(n)**2 &
            +3.*zoverh/hoverr*z(n)*x(1:mx))
!
      enddo; enddo
!
    endsubroutine isotdisk
!***********************************************************************
    subroutine cos_cos_sin(ampl,f,ivar)
!
!  Produce a profile that is linear in any non-periodic direction, but
!  periodic in periodic ones (for testing purposes).
!
!  7-dec-02/axel: coded
!
      integer :: ivar
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,kx,ky,kz
!
      if (lroot) print*, 'cos_cos_sin: ivar = ', ivar
!
      kx=2*pi/Lx*3
      ky=2*pi/Ly*3
      kz=pi/Lz
      do n=n1,n2; do m=m1,m2
        f(l1:l2,m,n,ivar) = ampl*cos(kx*x(l1:l2))*cos(ky*y(m))*sin(kz*z(n))
      enddo; enddo
!
    endsubroutine cos_cos_sin
!***********************************************************************
    subroutine tor_pert(ampl,f,ivar)
!
!  Produce a profile that is periodic in the y- and z-directions.
!  For testing the Balbus-Hawley instability of a toroidal magnetic field
!
!  12-feb-03/ulf: coded
!
      integer :: ivar
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,ky,kz
!
      if (lroot) print*, 'tor_pert: sinusoidal modulation of ivar = ', ivar
!
      ky=2*pi/Ly
      kz=2.*pi/Lz
      do n=n1,n2; do m=m1,m2
        f(l1:l2,m,n,ivar) = ampl*cos(ky*y(m))*cos(kz*z(n))
      enddo; enddo
!
    endsubroutine tor_pert
!***********************************************************************
    subroutine const_omega(ampl,f,ivar)
!
!  Set up profile for differential rotation
!
!  16-jul-03/axel: coded
!
      real :: ampl
      real, dimension (mx,my,mz,mfarray) :: f
      integer :: ivar
!
      if (lroot) print*, 'const_omega: constant angular velcoity  = ', ivar
!
      do n=n1,n2; do m=m1,m2
        f(l1:l2,m,n,ivar) = ampl*x(l1:l2)*sinth(m)
      enddo; enddo
!
    endsubroutine const_omega
!***********************************************************************
    subroutine diffrot(ampl,f,ivar)
!
!  Set up profile for differential rotation
!
!  16-jul-03/axel: coded
!
      real :: ampl
      real, dimension (mx,my,mz,mfarray) :: f
      integer :: ivar
!
      if (lroot) print*, 'diffrot: sinusoidal modulation of ivar = ', ivar
!
      do n=n1,n2; do m=m1,m2
        f(l1:l2,m,n,ivar) = ampl*cos(x(l1:l2))*cos(z(n))
      enddo; enddo
!
    endsubroutine diffrot
!***********************************************************************
    subroutine olddiffrot(ampl,f,ivar)
!
!  Set up profile for differential rotation
!
!  16-jul-03/axel: coded
!
      real :: ampl
      real, dimension (mx,my,mz,mfarray) :: f
      integer :: ivar
!
      real :: kx,kz
!
      if (lroot) print*, 'olddiffrot: sinusoidal modulation of ivar = ', ivar
!
      kx=.5*pi/Lx
      kz=.5*pi/Lz
      do n=n1,n2; do m=m1,m2
        f(l1:l2,m,n,ivar) = ampl*sin(kx*x(l1:l2))*cos(kz*z(n))
      enddo; enddo
!
    endsubroutine olddiffrot
!***********************************************************************
    subroutine powern(ampl,initpower,cutoff,f,i1,i2)
!
!   Produces k^initpower*exp(-k**2/cutoff**2)  spectrum.
!   Still just one processor (but can be remeshed afterwards).
!
!   07-may-03/tarek: coded
!
      use Fourier, only: fourier_transform
!
      real :: ampl,initpower,cutoff
      real, dimension (mx,my,mz,mfarray) :: f
      integer :: i1,i2
!
      real, dimension (:,:,:), allocatable :: k2, u_re, u_im
      real, dimension (nx) :: k2x
      real, dimension (ny) :: k2y
      real, dimension (nz) :: k2z
!
      integer :: i, stat
!
!  Allocate memory for arrays.
!
      allocate(k2(nx,ny,nz),stat=stat)
      if (stat>0) call fatal_error('powern','Could not allocate memory for k2')
      allocate(u_re(nx,ny,nz),stat=stat)
      if (stat>0) call fatal_error('powern','Could not allocate memory for u_re')
      allocate(u_im(nx,ny,nz),stat=stat)
      if (stat>0) call fatal_error('powern','Could not allocate memory for u_im')
!
      if (ampl==0) then
        f(:,:,:,i1:i2)=0
        if (lroot) print*,'powern: set variable to zero; i1,i2=',i1,i2
      else
        call gaunoise_vect(ampl,f,i1,i2) ! which has a k^2. spectrum
!
        if ((initpower/=2.).or.(cutoff/=0.)) then
!
          k2x = cshift((/(i-(nx+1)/2,i=0,nx-1)/),+(nx+1)/2)*2*pi/Lx
          k2 =      (spread(spread(k2x,2,ny),3,nz))**2
!
          k2y = cshift((/(i-(ny+1)/2,i=0,ny-1)/),+(ny+1)/2)*2*pi/Ly
          k2 = k2 + (spread(spread(k2y,1,nx),3,nz))**2
!
          k2z = cshift((/(i-(nz+1)/2,i=0,nz-1)/),+(nz+1)/2)*2*pi/Lz
          k2 = k2 + (spread(spread(k2z,1,nx),2,ny))**2
!
          k2(1,1,1) = 1.  ! Avoid division by zero
!
          do i=i1,i2
            u_re=f(l1:l2,m1:m2,n1:n2,i)
            u_im=0.
            !  fft of gausian noise w/ k^2 spectrum
            call fourier_transform(u_re,u_im)
            ! change to k^n spectrum
            u_re =(k2)**(.25*initpower-.5)*u_re
            u_im =(k2)**(.25*initpower-.5)*u_im
            ! cutoff (changed to hyperviscous cutoff filter)
            if (cutoff /= 0.) then
              u_re = u_re*exp(-(k2/cutoff**2.)**2)
              u_im = u_im*exp(-(k2/cutoff**2.)**2)
            endif
            ! back to real space
            call fourier_transform(u_re,u_im,linv=.true.)
            f(l1:l2,m1:m2,n1:n2,i)=u_re
!
            if (lroot) then
              if (cutoff==0) then
                print*,'powern: k^',initpower,' spectrum : var  i=',i
              else
                print*,'powern: with cutoff : k^n*exp(-k^4/k0^4) w/ n=', &
                    initpower,', k0 =',cutoff,' : var  i=',i
              endif
            endif
          enddo !i
        endif !(initpower/=2.).or.(cutoff/=0.)
!
      endif !(ampl==0)
!
!  Deallocate arrays.
!
      if (allocated(k2)) deallocate(k2)
      if (allocated(u_re)) deallocate(u_im)
!
    endsubroutine powern
!***********************************************************************
    subroutine power_randomphase(ampl,initpower,kgaussian,kpeak,cutoff, &
      f,i1,i2,lscale_tobox)
!
!  Produces k^initpower*exp(-k**2/cutoff**2) spectrum.
!  However, initpower=-3 produces a k^{-1} spectrum.
!
!  07-may-03/tarek: coded
!  08-may-08/nils: adapted to work on multiple processors
!  06-jul-08/nils+andre: Fixed problem when running on
!      mult. procs (thanks to Andre Kapelrud for finding the bug)
!  08-feb-21/jennifer: added a Gaussian (adapted from power_randomphase_hel
!      but with a shift in k)
!
      use Fourier, only: fft_xyz_parallel
!
      logical, intent(in), optional :: lscale_tobox
      logical :: lscale_tobox1
      integer :: i,i1,i2,ikx,iky,ikz,stat
      real, dimension (:,:,:), allocatable :: k2, u_re, u_im, r
      real, dimension (:,:,:), allocatable :: k2mkpeak
      real, dimension (:), allocatable :: kx, ky, kz
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,initpower,mhalf,cutoff,scale_factor
      real :: nfact=4.,kpeak,kpeak1,kpeak21,nexp1,nexp2,kgaussian,fact
!
      if (present(lscale_tobox)) then
        lscale_tobox1 = lscale_tobox
      else
        lscale_tobox1 = .true.
      endif
!
!  Allocate memory for arrays.
!
      allocate(k2(nx,ny,nz),stat=stat)
      if (stat>0) call fatal_error('powern','Could not allocate memory for k2')
      if (kgaussian /= 0.) then
         allocate(k2mkpeak(nx,ny,nz),stat=stat)
         if (stat>0) call fatal_error('powern','Could not allocate memory for k2mkpeak')
      endif
      allocate(u_re(nx,ny,nz),stat=stat)
      if (stat>0) call fatal_error('powern','Could not allocate memory for u_re')
      allocate(u_im(nx,ny,nz),stat=stat)
      if (stat>0) call fatal_error('powern','Could not allocate memory for u_im')
      allocate(r(nx,ny,nz),stat=stat)
      if (stat>0) call fatal_error('powern','Could not allocate memory for r')
      allocate(kx(nxgrid),stat=stat)
      if (stat>0) call fatal_error('powern', &
          'Could not allocate memory for kx')
      allocate(ky(nygrid),stat=stat)
      if (stat>0) call fatal_error('powern', &
          'Could not allocate memory for ky')
      allocate(kz(nzgrid),stat=stat)
      if (stat>0) call fatal_error('powern', &
          'Could not allocate memory for kz')
!
      if (ampl==0) then
        if (lroot) print*,'power_randomphase: zero, nothing added to variables i1,i2=',i1,i2
      else
!
!  calculate k^2
!
        scale_factor=1
        if (.not.lscale_tobox1) scale_factor=2*pi/Lx
        kx=cshift((/(i-(nxgrid+1)/2,i=0,nxgrid-1)/),+(nxgrid+1)/2)*scale_factor
!
        scale_factor=1
        if (.not.lscale_tobox1) scale_factor=2*pi/Ly
        ky=cshift((/(i-(nygrid+1)/2,i=0,nygrid-1)/),+(nygrid+1)/2)*scale_factor
!
        scale_factor=1
        if (.not.lscale_tobox1) scale_factor=2*pi/Lz
        kz=cshift((/(i-(nzgrid+1)/2,i=0,nzgrid-1)/),+(nzgrid+1)/2)*scale_factor
!
!  integration over shells
!
        if (lroot .AND. ip<10) &
               print*,'power_randomphase:fft done; now integrate over shells...'
!  In 2-D
        if (nz==1) then
          ikz=1
          do iky=1,ny
            do ikx=1,nx
              k2(ikx,iky,ikz)=kx(ikx+ipx*nx)**2+ky(iky+ipy*ny)**2
              if (kgaussian /= 0.) then
                k2mkpeak(ikx,iky,ikz)=(kx(ikx+ipx*nx)-kpeak)**2+(ky(iky+ipy*ny)-kpeak)**2
              endif
            enddo
          enddo
!  In 3-D
        else
          do ikz=1,nz
            do iky=1,ny
              do ikx=1,nx
                k2(ikx,iky,ikz)=kx(ikx+ipx*nx)**2+ky(iky+ipy*ny)**2+kz(ikz+ipz*nz)**2
                if (kgaussian /= 0.) then
                  k2mkpeak(ikx,iky,ikz)=(kx(ikx+ipx*nx)-kpeak)**2+(ky(iky+ipy*ny)-kpeak)**2 &
                  +(kz(ikz+ipz*nz)-kpeak)**2
                endif
              enddo
            enddo
          enddo
        endif
!
        if (lroot) k2(1,1,1) = 1.  ! Avoid division by zero
!
!  To get the shell integrated power spectrum E ~ k^n, we need u ~ k^m
!  and since (in 3-D): E(k) ~ u^2 k^2 we have n=2m+2, so m=n/2-1.
!  but in 2-D, we have: E(k) ~ u^2 k, so we have n=2m+1, so m=(n-1)/2.
!  Further, since we operate on k^2, we need m/2 (called mhalf below)
!
        mhalf=.5*(.5*initpower-1)
!
!  generate all 3 velocity components separately
!
        do i=i1,i2
          ! generate k^n spectrum with random phase (between -pi and pi)
          call random_number_wrapper(r); u_re=ampl*k2**mhalf*cos(pi*(2*r-1))
          call random_number_wrapper(r); u_im=ampl*k2**mhalf*sin(pi*(2*r-1))
          ! cutoff (changed to hyperviscous cutoff filter)
          if (cutoff /= 0.) then
            u_re = u_re*exp(-(k2/cutoff**2.)**2)
            u_im = u_im*exp(-(k2/cutoff**2.)**2)
          endif
!
! Gaussian (adapted from power_randomphase_hel)
!
          if (kgaussian /= 0.) then
            nexp1=.25*nfact*initpower
            nexp2=1./nfact
            kpeak1=1./kpeak
            kpeak21=1./kpeak**2
!
!  Multiply by kpeak1**1.5 to eliminate scaling with kpeak,
!  which comes from a kpeak^3 factor in the k^2 dk integration.
!  The 1/2 factor comes from setting uk (as opposed to uk^2).
!
            fact=(kpeak1*scale_factor)**1.5
            fact=fact*kgaussian**(-.5*(initpower+1.))
            r=fact*((k2*kpeak21)**mhalf)/(1.+(k2*kpeak21)**nexp1)**nexp2
!
!  for kpeak /= 0, we have a gaussian centered around kpeak.
!  There are two options, neither of them are currently well normalized.
!
            if (kpeak /= 0.) then
               !r=r*exp(-.5*(((sqrt(k2)-kpeak)/kgaussian)**2))
               r=r*exp(-.5*(((k2-kpeak**2)/kgaussian**2)**2))
            else
               r=r*exp(-.25*(k2/kgaussian**2.-1.))
            endif
            u_re = r*u_re
            u_im = r*u_im
          endif
!
          ! back to real space
          call fft_xyz_parallel(u_re,u_im,linv=.true.)
          f(l1:l2,m1:m2,n1:n2,i)=f(l1:l2,m1:m2,n1:n2,i)+u_re
          if (lroot) then
            if (cutoff==0) then
              print*,'powern: k^',initpower,' spectrum : var  i=',i
            else
              print*,'powern: with cutoff : k^n*exp(-k^4/k0^4) w/ n=', &
                  initpower,', k0 =',cutoff,' : var  i=',i
            endif
          endif
        enddo !i
!
      endif !(ampl==0)
!
!  Deallocate arrays.
!
      if (allocated(k2))   deallocate(k2)
      if (allocated(k2mkpeak)) deallocate(k2mkpeak)
      if (allocated(u_re)) deallocate(u_re)
      if (allocated(u_im)) deallocate(u_im)
      if (allocated(r))  deallocate(r)
      if (allocated(kx)) deallocate(kx)
      if (allocated(ky)) deallocate(ky)
      if (allocated(kz)) deallocate(kz)
!
    endsubroutine power_randomphase
!***********************************************************************
    subroutine power_randomphase_hel(ampl,initpower,initpower2, &
      cutoff,ncutoff,kpeak,f,i1,i2,relhel,kgaussian, &
      lskip_projection,lvectorpotential,lscale_tobox, lsquash, &
      k1hel, k2hel,lremain_in_fourier,lpower_profile_file, power_filename, &
      qexp, lno_noise,nfact0,lfactors0,compk0,llogbranch0,initpower_med0, &
      kpeak_log0,kbreak0,ldouble0,nfactd0,qirro,lsqrt_qirro,time, &
      cs,lreinit,ltime_old,ltime_new,lrho_nonuni,ilnr,l2d, &
      lnot_amp, lrandom_ampl, lfixed_phase)
!
!  Produces helical (q**n * (1+q)**(N-n))*exp(-k**l/cutoff**l) spectrum
!  when kgaussian=0, where q=k/kpeak, n=initpower, N=initpower2,
!  and l=2*ncutoff.
!  The relative helicity is relhel.
!
!  initpower=0 -> k^2  (if used for vector potential)
!           =2 -> k^4
!          =-3 -> k^{-1}
!          =-3.67 k^{-5/3}
!          =-5 -> k^{-3}
!
!  Note that the rms value is unchanged if kpeak is changed.
!  Thus, to reproduce an unchanged subinertial range after increasing kpeak,
!  for example, one has to *increase* ampl by a factor 1/kpeak**2.5,
!  e.g., from 3e-4 to 17e-4.
!
!  08-sep-14/axel: adapted from power_randomphase
!  17-sep-18/axel: added optional wavenumber interval for helical field.
!  28-jan-19/axel: special treatment of 2-D case (nz==1)
!  14-aug-20/axel: adapted for fft_xyz_parallel
!  7-aug-22/alberto: added optional logarithmic branch and double
!                    broken power law
!
      use Fourier, only: fft_xyz_parallel
      use General, only: loptest, roptest
!
      logical, intent(in), optional :: lscale_tobox, lsquash, lremain_in_fourier, ltime_old
      logical, intent(in), optional :: ltime_new, lrho_nonuni, lnot_amp, lrandom_ampl, lfixed_phase
      logical, intent(in), optional :: lpower_profile_file, lno_noise, lfactors0
      logical, intent(in), optional :: llogbranch0,ldouble0, lreinit, l2d, lsqrt_qirro
      logical :: lvectorpotential, lscale_tobox1, lsquash1, lremain_in_fourier1, lno_noise1
      logical :: lskip_projection,lfactors,llogbranch,ldouble, ltime, ltime_old1
      logical :: ltime_new1, lrho_nonuni1, l2d1, lsqrt_qirro1, lnot_amp1, lrandom_ampl1
      logical :: lfixed_phase1
      real, dimension (mx,my,mz,mfarray) :: f
      integer :: i, i1, i2, ikx, iky, ikz, stat, ik, nk, ilnr1
      integer, intent(in), optional :: ilnr
      real, intent(in), optional :: k1hel, k2hel, qexp, nfact0, compk0
      real, intent(in), optional :: initpower_med0, kpeak_log0, kbreak0
      real, intent(in), optional :: nfactd0, qirro, time, cs
      real, dimension (:,:,:,:), allocatable :: u_re, u_im
      real, dimension(3) :: v_re, v_im
      real, dimension (:,:,:), allocatable :: k2, r
      real, dimension (:), allocatable :: kx, ky, kz
      real, dimension (:), allocatable :: kk, lgkk, power_factor, lgff
      real :: ampl,initpower,initpower2,mhalf,cutoff,kpeak,scale_factor,relhel
      real :: nfact, kpeak1, kpeak21, nexp1,nexp2,ncutoff,kgaussian,fact
      real :: lgk0, dlgk, lgf, lgk, lgf2, lgf1, lgk2, lgk1, D1, D2, D3, compk
      real :: kpeak_log, kbreak, kbreak1, kbreak2, kbreak21, initpower_med, initpower_log
      real :: nfactd,nexp3,nexp4
      real :: qexp1, qexp11, qirro1, p, p2, time1, cs1, om, ctime, stime
      character(len=*), intent(in), optional :: power_filename
      character(len=labellen) :: power_filename1
!
      if (ampl==0.) then
        if (lroot) print*,'power_randomphase: set variable to zero; i1,i2=',i1,i2
        f(:,:,:,i1:i2) = 0.
        return
      endif
!
!  By default, don't scale wavenumbers to the box size.
!
      lscale_tobox1 = loptest(lscale_tobox,.true.)
!
      lsquash1 = loptest(lsquash,.true.)
!
!  Check whether or not we want to remain in Fourier space
!
      lremain_in_fourier1 = loptest(lremain_in_fourier)
!
!  Check whether or not we want ltime_old
!
      ltime_old1 = loptest(ltime_old)
!
!  Check whether or not we want ltime_new
!
      ltime_new1 = loptest(ltime_new)
!
!  Check whether or not we want lrho_nonuni
!
      lrho_nonuni1 = loptest(lrho_nonuni)
      if (lrho_nonuni1) then
        ilnr1 = ioptest(ilnr)
        if (ilnr1 <= 0) call fatal_error('power_randomphase_hel','must provide ilnr')
      endif
!
!  Check whether we want random amplitudes or not
!
      lrandom_ampl1 = loptest(lrandom_ampl)
!
!  Check whether we want no_noise or not
!
      lno_noise1 = loptest(lno_noise)
!
!  Check whether we want lfixed_phase or not
!
      lfixed_phase1 = loptest(lfixed_phase)
!
!  Check whether we want l2d or not
!
      l2d1 = loptest(l2d)
!
!  qexp for q-exponential, qexp=1 by default
!
     qexp1 = roptest(qexp, rdef=1.)
!
!  qirro, is the vortical contribution, qirro=1 for fully irrotational.
!
     qirro1 = roptest(qirro)
!
! added option to use sqrt(qirro) to have correct normalization for trace
! of two-point correlation (added by antonino, madeline, alberto)
!
     lsqrt_qirro1 = loptest(lsqrt_qirro)
     !print*,'value of qirro1',lsqrt_qirro1
!
!  time
!
     time1 = roptest(time)
     ltime = time1/=0.
!
!  cs
!
     cs1 = roptest(cs,1.)
!
!  alberto: added option to compensate spectral shape by a power of k
!
     compk = roptest(compk0)
!
!  alberto: added option to use different values of nfact
!  Here, nfact is the exponent on k/k0, with an 1/nfact outside [1+(k/k0)^n]^(1/nfact).
!  By default, we use a large nfact=4 to have a sharp transition.
!
     nfact = roptest(nfact0,4.)
     lfactors = loptest(lfactors0)
     lnot_amp1 = loptest(lnot_amp)
!
!  alberto: added option to include additional logarithmic branch
!
      llogbranch = loptest(llogbranch0)
!
!  alberto: added option to use double smoothed broken power laws
!           logbranch is set to False if ldouble is used
!
      ldouble = loptest(ldouble0)
      if (ldouble) llogbranch = .false.
!
!  Check if the parameters of the logarithmic branch or the
!  double broken power law are given
!
      if (llogbranch.or.ldouble) then

        initpower_med = roptest(initpower_med0,1.)
        kbreak = roptest(kbreak0,.5)
        kbreak1=1./kbreak
        kbreak2=kbreak**2
        kbreak21=kbreak1**2

        if (llogbranch) kpeak_log = roptest(kpeak_log0,1.)
        if (ldouble) nfactd = roptest(nfactd0,4.)

      endif
!
!  Debug output
!
      if (lroot.and.ip<10) then
        print*,'i1,i2=',i1,i2
        print*,'ampl,initpower,initpower2=',ampl,initpower,initpower2
        print*,'cutoff,ncutoff,kpeak,i1,i2,relhel,kgaussian=',cutoff,ncutoff,kpeak,i1,i2,relhel,kgaussian
        !print*,'lskip_projection,lvectorpotential,lscale_tobox1=',lskip_projection,lvectorpotential,lscale_tobox1
        print*,'lskip_projection,lscale_tobox1,lsquash1=',lskip_projection,lscale_tobox1,lsquash1
        !print*,'k1hel,k2hel,lremain_in_fourier,lpower_profile_file,qexp=',k1hel,k2hel,lremain_in_fourier,lpower_profile_file,qexp
        print*,'lremain_in_fourier1',lremain_in_fourier1
  !     print*,'lno_noise,nfact,lfactors=',lno_noise,nfact,lfactors
  !     print*,'compk,llogbranch,initpower_med=',compk,llogbranch,initpower_med
  !     print*,'kpeak_log,kbreak,ldouble,nfactd,qirro1=',kpeak_log,kbreak,ldouble,nfactd,qirro1
      endif
!
!  Allocate memory for arrays.
!
      allocate(k2(nx,ny,nz),stat=stat)
      if (stat>0) call fatal_error('power_randomphase_hel','Could not allocate k2')
      allocate(r(nx,ny,nz),stat=stat)
      if (stat>0) call fatal_error('power_randomphase_hel','Could not allocate r')
!
      if (i2==i1) then
        allocate(u_re(nx,ny,nz,1),stat=stat)
        if (stat>0) call fatal_error('power_randomphase_hel','Could not allocate u_re')
        allocate(u_im(nx,ny,nz,1),stat=stat)
        if (stat>0) call fatal_error('power_randomphase_hel','Could not allocate u_im')
      else
        allocate(u_re(nx,ny,nz,3),stat=stat)
        if (stat>0) call fatal_error('power_randomphase_hel','Could not allocate u_re')
        allocate(u_im(nx,ny,nz,3),stat=stat)
        if (stat>0) call fatal_error('power_randomphase_hel','Could not allocate u_im')
      endif
!
      allocate(kx(nxgrid),stat=stat)
      if (stat>0) call fatal_error('power_randomphase_hel','Could not allocate kx')
      allocate(ky(nygrid),stat=stat)
      if (stat>0) call fatal_error('power_randomphase_hel','Could not allocate ky')
      allocate(kz(nzgrid),stat=stat)
      if (stat>0) call fatal_error('power_randomphase_hel','Could not allocate kz')
!
!  calculate k^2. If lscale_tobox1=T, then k is calculated as if the
!  box is 2pi in all three directions.
!  If lsquash_aa=T, then the box size in the y and z directions is the
!  same as in the x direction. It is called that way, because, if the
!  aspect ratio is is different from unity, it makes the field squashed.
!
      scale_factor=1
      if (.not.lscale_tobox1) scale_factor=2*pi/Lx
      kx=cshift((/(i-nxgrid/2,i=0,nxgrid-1)/),nxgrid/2)*scale_factor
      if (lroot.and.ip<10) print*,'AXEL: kx=',kx
!
      if (.not. lsquash1) then
        scale_factor=1
        if (.not.lscale_tobox1) scale_factor=2*pi/Ly
      endif
      ky=cshift((/(i-nygrid/2,i=0,nygrid-1)/),nygrid/2)*scale_factor
      if (lroot.and.ip<10) print*,'AXEL: ky=',ky
!
      if (.not. lsquash1) then
        scale_factor=1
        if (.not.lscale_tobox1) scale_factor=2*pi/Lz
      endif
      kz=cshift((/(i-nzgrid/2,i=0,nzgrid-1)/),nzgrid/2)*scale_factor
      if (lroot.and.ip<10) print*,'AXEL: kz=',kz
!
!  Generate flat spectrum with random phase (between -pi and pi).
!  When lrandom_ampl=T, we multiply by a sqrt(-2*alog(k2)) factor, as in the
!  gaunoise routine; the variable k2 is borrowed before it is used for k^2.
!  For qexp /= 1, we use the q-logarithm, the inverse of the q-exponential,
!  alog_q(x) = [x^(1-q)-1]/(1-q), and define qexp11 = 1-q for clearer notation.
!
      if (lno_noise1) then
        u_re=ampl
        u_im=0.
      else
        do i=1,i2-i1+1
          call random_number_wrapper(r)
          if (lrandom_ampl1) then
            call random_number_wrapper(k2)
            if (qexp1==1.) then
              u_im(:,:,:,i)=ampl*sqrt(-2*alog(k2))
            else
              qexp11=1.-qexp1
              u_im(:,:,:,i)=ampl*sqrt(-2*(k2**qexp11-1.)/qexp11)
            endif
!           if (lfixed_phase1) then
!             u_re(:,:,:,i)=u_im(:,:,:,i)
!           else
            if (.not. lfixed_phase1) then
              u_re(:,:,:,i)=u_im(:,:,:,i)*cos(pi*(2*r-1))
              u_im(:,:,:,i)=u_im(:,:,:,i)*sin(pi*(2*r-1))
            endif
          else
            u_re(:,:,:,i)=ampl*cos(pi*(2*r-1))
            u_im(:,:,:,i)=ampl*sin(pi*(2*r-1))
          endif
        enddo
      endif
!
!  Set k^2 array.
!
!  Note: for multiple processors, there may still be a problem in 1-D
!
!  In 1-D
      if (nzgrid==1.and.nygrid==1) then
        ikz=1
        iky=1
        do ikx=1,nx
          k2(ikx,iky,ikz)=kx(ikx+ipx*nx)**2
        enddo
!  In 2-D
      elseif (nzgrid==1) then
        ikz=1
        do iky=1,ny
          do ikx=1,nx
            k2(ikx,iky,ikz)=kx(ikx+ipx*nx)**2+ky(iky+ipy*ny)**2
          enddo
        enddo
!  In 3-D
      else
        do ikz=1,nz
          do iky=1,ny
              do ikx=1,nx
                k2(ikx,iky,ikz)=kx(ikx+ipx*nx)**2+ky(iky+ipy*ny)**2+kz(ikz+ipz*nz)**2
              enddo
          enddo
        enddo
      endif
      if (lroot) k2(1,1,1) = 1.  ! Avoid division by zero
!
!  Do phase correction
!
      if (lfixed_phase1) then
        do i=1,i2-i1+1
          u_re(:,:,:,i)=u_im(:,:,:,i)*cos(-sqrt(k2)*t)
          u_im(:,:,:,i)=u_im(:,:,:,i)*sin(-sqrt(k2)*t)
        enddo
      endif
!
!  To get the shell integrated power spectrum E ~ k^n, we need u ~ k^m
!  and since E(k) ~ u^2 k^2 we have n=2m+2, so m=n/2-1 in 3-D.
!  In general, E(k) ~ u^2 k^(D-1), so we have n=2m+D-1, so m=(n-D+1)/2
!  Further, since we operate on k^2, we need m/2 (called mhalf below)
!
      mhalf=.25*(initpower-dimensionality+1)
!
!  generate all 3 velocity components separately
!  generate k^n spectrum with random phase (between -pi and pi)
!
      nexp1=.25*nfact*(initpower-initpower2)
      !
      !  alberto: adapt input power law exponents to parameters that appear in the
      !           broken power law when a logarithmic branch is included or when
      !           a double broken power law is included
      !
      if (llogbranch.or.ldouble) then
        nexp1=.25*nfact*(initpower_med-initpower2)
        initpower_log=.5*(initpower-initpower_med)
      endif
      if (ldouble) then
        mhalf=.25*(initpower_med-dimensionality+1)
        nexp3=1./nfactd
        nexp4=.5*nfactd*initpower_log
      endif
      nexp2=1./nfact
      kpeak1=1./kpeak
      kpeak21=1./kpeak**2
!
!  alberto: added option to compensate amplitude and peak using D1 and D2
!           such that the maximum of the spectrum is located at kpeak
!           or at the plateau (if present)
!
      D1=0.
      D2=1.
      D3=1.
      fact=1.
      if (lfactors) then
        if (llogbranch) then
          !  alberto: changing sign of nfact allows to use spectral shapes with
          !           initpower - initpower2 > 0
          if (initpower_med<initpower2) then
            nexp1=-nexp1
            nexp2=-nexp2
            nfact=-nfact
          endif
          if (initpower2/=0) then
            if (initpower_med/=0) then
              if (initpower2*initpower_med<0) then
                D1=-initpower_med/initpower2
              else
                D1=1.
              endif
              D2=D1
            endif
            fact=fact*log(1+kpeak_log*kpeak1)**(-initpower_log)
          else
            if (initpower_med==0) fact=fact*(1+D2)**nexp2
            fact=fact*(kpeak_log*kpeak1)**(-initpower_log)
          endif
          if ((initpower>=0).and.(initpower_med<0)) then
            fact=(1+D1)**(-nexp2)*(kbreak*kpeak1)**(-.5*initpower)
            fact=fact*(1+D2*(kbreak*kpeak1)**(.5*nfact*(initpower_med-initpower2)))**(-nexp2)
            fact=fact*log(1+kpeak_log*kbreak1)**(-initpower_log)
            if (initpower_med==initpower2) fact=fact*(1+D2)**(2*nexp2)
          endif
        elseif (ldouble) then
          !  alberto: changing sign of nfact allows to use spectral shapes with
          !           initpower - initpower2 > 0
          if (initpower_med<initpower2) then
            nexp1=-nexp1
            nexp2=-nexp2
          endif
          if (initpower<initpower_med) then
            nexp3=-nexp3
            nexp4=-nexp4
          endif
          if (initpower2/=0) then
            if (initpower_med/=0) then
              if (initpower_med*initpower2<0) then
                D1=-initpower_med/initpower2
              else
                D1=1.
              endif
              D2=D1
            endif
            fact=fact*(1+D3*(kpeak*kbreak1)**(-2*nexp4))**nexp3
          else
            if (initpower_med==0) then
              fact=fact*(1+D2)**nexp2
              if (initpower==0) then
                fact=fact*(1+D1)**nexp2*(1+D3)**nexp3
              endif
            endif
          endif
          if ((initpower>=0).and.(initpower_med<0)) then
            fact=1.
            if ((initpower_med*initpower<0).and.(initpower2/=0)) then
              D1=-initpower_med/initpower2
              D2=D1
            endif
            if (initpower2*initpower_med>0) D2=1.
            if (initpower/=0) then
              D3=-initpower_med/initpower
              fact=fact*(1 + D3)**nexp3
            endif
            fact=fact*(1+D1)**(-nexp2)*(kbreak*kpeak1)**(-.5*initpower_med)
            fact=fact*(1+D2*(kbreak*kpeak1)**(2*nexp1))**nexp2
          endif
        else  ! (ldouble)
          !  alberto: changing sign of nfact allows to use spectral shapes with
          !           initpower - initpower2 > 0
          if ((initpower-initpower2)<0) then
            nexp1=-nexp1
            nexp2=-nexp2
          endif
          if ((initpower*initpower2)<0) then
            D1=-initpower/initpower2
            D2=D1
          elseif ((initpower*initpower2)==0) then
            if ((initpower==0).and.(initpower2)==0) then
              fact=fact*(1+D2)**nexp2
            elseif (initpower2==0) then
              fact=fact*D2**nexp2
            endif
          else
            fact=fact*(1+D2)**nexp2
          endif
          !D1=abs(initpower/initpower2)
          !D2=-1/initpower2
          !if (initpower/=0) then
          !  D2=D2*abs(initpower)
          !endif
        endif
      endif  ! (lfactors)
!
      fact=fact*(1+D1)**nexp2
!
!  Multiply by kpeak1**1.5 to eliminate scaling with kpeak,
!  which comes from a kpeak^3 factor in the k^2 dk integration.
!  The 1/2 factor comes from setting uk (as opposed to uk^2).
!
!  alberto: if lfactor is chosen, the amplitude of the spectrum is
!           independent of kpeak instead of the integrated energy,
!           and it takes the value ampl at kpeak (tested for hydro
!           fields, for magnetic one can choose compk_aa=-.5 to obtain
!           a magnetic field spectrum with value ampl at kpeak)
!
      if (lfactors) then
        !print*,'TEST Lx, kpeak',Lx,kpeak
        if (lnot_amp1) then
          fact=fact*(2*pi/Lx)**0.5
        else
          fact=fact*kpeak1*scale_factor**1.5/(2*pi*ampl)**0.5
          !
          ! alberto: compensate for contribution due to helicity
          ! taking into account generic qirro (only correct when
          ! lsqrt_qirro is true)
          !
          fact=fact/(1 + relhel**2*(1 - qirro1))**0.5
          ! compensate when compk is non-zero
          fact=fact*kpeak21**compk
          !fact=fact*(kpeak1*scale_factor)
        endif
      else
        fact=fact*(kpeak1*scale_factor)**1.5
      endif
!
!  If lvectorpotential, we given slopes are meant to be for the magnetic
!  vector potential, so we use (initpower+3.) instead of (initpower+1.).
!
      if (lvectorpotential) then
        fact=fact*kpeak1
        if (kgaussian /= 0.) fact=fact*kgaussian**(-.5*(initpower+3.))
      else
        if (kgaussian /= 0.) fact=fact*kgaussian**(-.5*(initpower+1.))
      endif
      r=fact*((k2*kpeak21)**mhalf)/(1.+D2*(k2*kpeak21)**nexp1)**nexp2
      if (lroot.and.ip<10) print*,'kpeak,mhalf,nexp1,nexp2=',kpeak,mhalf,nexp1,nexp2
!
!  Examples: for initpower=4., initpower2=-2., get mhalf,nexp1,nexp2 = 0.75, 6.0, 0.25
!  while for Jani Dahl setup, we put: initpower=3., initpower2=-3., nfact_uu=.6666667
!  and get mhalf, nexp1, nexp2 = 0.5, 1.0, 1.5.
!
!  alberto: added possibility to multiply spectrum by a power of k (useful for GW for example)
!           the final spectrum will be compensated by k^(4*compk)
!
      r=r*k2**compk
!
!  alberto: added model for double smoothed broken power law
!
      if (ldouble) r=r/(1.+D3*(k2*kbreak21)**(-nexp4))**nexp3
!
!  alberto: multiply the broken power law by the logarithmic branch using
!           the condition k < kbreak
!
!  Produces a 'double' broken power law for GW spectrum using a logarithmic branch based
!  on Roper Pol, Caprini, Neronov, Semikoz, 2022 (arXiv:2201.05630) by multiplying
!  TauGW to the spectrum, where TauGW is:
!  ln (1 + kpeak_log/kbreak)**n when k <= kbreak and
!  ln (1 + kpeak_log/k)**n when k > kbreak
!
!  The resulting spectrum asymptotically has slopes k^initpower at k < kbreak,
!  k^initpower_med at kbreak < k < kpeak, k^(-initpower2) at k > kpeak
!
      if (llogbranch) then
        where (k2<kbreak2)
          r = r*log(1+kpeak_log*kbreak1)**initpower_log
        elsewhere
          r = r*log(1+kpeak_log/sqrt(k2))**initpower_log
        endwhere
      endif
!
!  cutoff (changed to hyperviscous cutoff filter).
!  The 1/2 factor is needed to account for the fact that the
!  spectrum (velocity squared) is proportional to exp(-k^2/cutoff^2).
!  For ncutoff/=1, one has exp(-(k^2/cutoff^2)^ncutoff).
!
      if (cutoff /= 0.) r=r*exp(-.5*(k2/cutoff**2.)**ncutoff)
!
!  apply Gaussian on top of everything
!
      if (kgaussian /= 0.) r=r*exp(-.25*(k2/kgaussian**2.-1.))
!
!  apply additional profile read from file;
!  first check whether or not we want to read from file
!  Ram: check if initial spectra file name (optional) is provided, otherwise
!  set to default name " power_profile.dat"
!
      if (loptest(lpower_profile_file)) then
        if (present(power_filename)) then
          power_filename1=power_filename
        else
          power_filename1='power_profile.dat'
        endif
        open(9,file=power_filename1,status='old')
        read(9,*) nk,lgk0,dlgk
        if (lroot) print*,'power_randomphase_hel: nk,lgk0,dlgk=',nk,lgk0,dlgk
        if (allocated(kk)) deallocate(kk,power_factor,lgkk,lgff)
        allocate(kk(nk),power_factor(nk),lgkk(nk),lgff(nk))
        do ik=1,nk
          read(9,*) kk(ik),power_factor(ik)
        enddo
        close(9)
        lgkk=alog10(kk)
        lgff=alog10(power_factor)
!
!  Go through each mesh point and interpolate logarithmically to the
!  correct scaling factor for the power (energy) spectrum.
!
        do ikz=1,nz
          do iky=1,ny
            do ikx=1,nx
              lgk=alog10(sqrt(k2(ikx,iky,ikz)))
              ik=int((lgk-lgk0)/dlgk)+1
              if (ik<1.or.ik>nk) then
                print*,'ikz,iky,ikx,lgk,ik,k2=',ikz,iky,ikx,lgk,ik,k2(ikx,iky,ikz)
                call fatal_error('power_randomphase_hel','ik<1.or.ik>nk')
              endif
              lgk1=lgkk(ik)
              lgk2=lgkk(ik+1)
              lgf1=lgff(ik)
              lgf2=lgff(ik+1)
              lgf=lgf1+(lgk-lgk1)*(lgf2-lgf1)/(lgk2-lgk1)
              r(ikx,iky,ikz)=r(ikx,iky,ikz)*10**lgf
              if (ip<14) print*,'iproc,lgk1,lgk,lgk2=',iproc,lgk1,lgk,lgk2
            enddo
          enddo
        enddo
      endif
!
!  Scale with r: allow for special case with *scalars* here.
!  Note that this adds to anything that was set previously.
!
      if (i2==i1) then
        u_re(:,:,:,1)=r*u_re(:,:,:,1)
        u_im(:,:,:,1)=r*u_im(:,:,:,1)
        if (lremain_in_fourier1) then
          f(l1:l2,m1:m2,n1:n2,i1  )=f(l1:l2,m1:m2,n1:n2,i1  )+u_re(:,:,:,1)
          f(l1:l2,m1:m2,n1:n2,i1+1)=f(l1:l2,m1:m2,n1:n2,i1+1)+u_im(:,:,:,1)
        else
          call fft_xyz_parallel(u_re(:,:,:,1),u_im(:,:,:,1),linv=.true.)
          f(l1:l2,m1:m2,n1:n2,i1)=f(l1:l2,m1:m2,n1:n2,i1)+u_re(:,:,:,1)
        endif
      else
        do i=1,3
          u_re(:,:,:,i)=r*u_re(:,:,:,i)
          u_im(:,:,:,i)=r*u_im(:,:,:,i)
        enddo
!
!  Apply projection operator
!  Use r=1/k^2 for normalization in khat_i * khat_j = ki*kj/k2.
!  Remember that for the return transform, data have to be
!  arranged in the order (kz,kx,ky).
!  To allow also for the possibility of longitudinal initial fields, we write
!  (1-q)*(delij-kikj) + q*kikj = (1-q)*delij - (1-2*q)*kikj.
!
!
!  Here, u_re, u_im is what was v_re, v_im before!
!
        if (.not.lskip_projection) then
!
!  Allow for possibility of irrotational contributions of fraction q,
!  so the vortical fraction is (1-q) == p.
!
          if (lsqrt_qirro1) then
            p=sqrt(1.-qirro1)
            p2=sqrt(1.-qirro1)-sqrt(2.*qirro1)
          else
            p=1.-qirro1
            p2=1.-2.*qirro1
          endif
!
!  In 2-D
!
          if (nz==1) then
            ikz=1
            do iky=1,ny
              do ikx=1,nx
!
!  Real part of (ux, uy, uz) -> vx, vy, vz
!  (kk.uu)/k2, ==> vi = ui - ki kj uj, but now we write:
!  (kk.uu)/k2, ==> vi = (1-q)*ui - (1-2q) ki kj uj
!
                !r(ikx,iky,ikz)=(1.-2.*qirro1) * (kx(ikx+ipx*nx)*u_re(ikx,iky,ikz,1) &
                r(ikx,iky,ikz)=p2 * (kx(ikx+ipx*nx)*u_re(ikx,iky,ikz,1) &
                                                +ky(iky+ipy*ny)*u_re(ikx,iky,ikz,2))/k2(ikx,iky,ikz)
                u_re(ikx,iky,ikz,1)=p*u_re(ikx,iky,ikz,1)-kx(ikx+ipx*nx)*r(ikx,iky,ikz)
                u_re(ikx,iky,ikz,2)=p*u_re(ikx,iky,ikz,2)-ky(iky+ipy*ny)*r(ikx,iky,ikz)
                u_re(ikx,iky,ikz,3)=p*u_re(ikx,iky,ikz,3)
!
!  Imaginary part of (ux, uy, uz) -> vx, vy, vz
!  (kk.uu)/k2, vi = ui - ki kj uj
!
                !r(ikx,iky,ikz)=(1.-2.*qirro1) * (kx(ikx+ipx*nx)*u_im(ikx,iky,ikz,1) &
                r(ikx,iky,ikz)=p2 * (kx(ikx+ipx*nx)*u_im(ikx,iky,ikz,1) &
                                                +ky(iky+ipy*ny)*u_im(ikx,iky,ikz,2))/k2(ikx,iky,ikz)
                u_im(ikx,iky,ikz,1)=p*u_im(ikx,iky,ikz,1)-kx(ikx+ipx*nx)*r(ikx,iky,ikz)
                u_im(ikx,iky,ikz,2)=p*u_im(ikx,iky,ikz,2)-ky(iky+ipy*ny)*r(ikx,iky,ikz)
                u_im(ikx,iky,ikz,3)=p*u_im(ikx,iky,ikz,3)
              enddo
            enddo
!  In 3-D
          else
            do ikz=1,nz
              do iky=1,ny
                do ikx=1,nx
!
!  Real part of (ux, uy, uz) -> vx, vy, vz
!  (kk.uu)/k2, vi = ui - ki kj uj
!
                  !r(ikx,iky,ikz)=(1.-2.*qirro1)* &
                  r(ikx,iky,ikz)=p2 * &
                      (kx(ikx+ipx*nx)*u_re(ikx,iky,ikz,1) &
                      +ky(iky+ipy*ny)*u_re(ikx,iky,ikz,2) &
                      +kz(ikz+ipz*nz)*u_re(ikx,iky,ikz,3))/k2(ikx,iky,ikz)
!
!  Possibility of a kinematic time dependence.
!  Commented out for now. This does not seem correct here and would overwrite r
!  when the keyword is set. There is another ltime implementation below which
!  seems to be the correct one.
!  AB: Out-commented part to be deleted.
!
!                    if (ltime) then
!                      om=cs1*sqrt(k2(ikx,iky,ikz))
!                      r(ikx,iky,ikz)=r(ikx,iky,ikz)*sin(om*time1)
!                    endif
!
                  u_re(ikx,iky,ikz,1)=p*u_re(ikx,iky,ikz,1)-kx(ikx+ipx*nx)*r(ikx,iky,ikz)
                  u_re(ikx,iky,ikz,2)=p*u_re(ikx,iky,ikz,2)-ky(iky+ipy*ny)*r(ikx,iky,ikz)
                  u_re(ikx,iky,ikz,3)=p*u_re(ikx,iky,ikz,3)-kz(ikz+ipz*nz)*r(ikx,iky,ikz)
!
!  Imaginary part of (ux, uy, uz) -> vx, vy, vz
!  (kk.uu)/k2, vi = ui - ki kj uj
!
                  !r(ikx,iky,ikz)=(1.-2.*qirro1)* &
                  r(ikx,iky,ikz)=p2 * &
                      (kx(ikx+ipx*nx)*u_im(ikx,iky,ikz,1) &
                      +ky(iky+ipy*ny)*u_im(ikx,iky,ikz,2) &
                      +kz(ikz+ipz*nz)*u_im(ikx,iky,ikz,3))/k2(ikx,iky,ikz)
                  u_im(ikx,iky,ikz,1)=p*u_im(ikx,iky,ikz,1)-kx(ikx+ipx*nx)*r(ikx,iky,ikz)
                  u_im(ikx,iky,ikz,2)=p*u_im(ikx,iky,ikz,2)-ky(iky+ipy*ny)*r(ikx,iky,ikz)
                  u_im(ikx,iky,ikz,3)=p*u_im(ikx,iky,ikz,3)-kz(ikz+ipz*nz)*r(ikx,iky,ikz)
                enddo
              enddo
            enddo
          endif  ! 3D
        endif  !(.not.lskip_projection)
!
!  Make it helical, i.e., multiply by delta_ij + epsilon_ijk ikhat_k*sigma.
!  Use r=sigma/k for normalization of sigma*khat_i = sigma*ki/sqrt(k2).
!  Put r(k=0)=0, but this is only true for the root processor.
!
!  From now on, k2 := sqrt(k2)!
!
        k2=sqrt(k2)
        r=relhel/k2
        if (lroot) r(1,1,1)=0.
!
!  put sigma=0 outside [r1hel,r2hel]
!
        if (present(k1hel) .and. present(k2hel)) then
          if (k1hel>0. .and. k2hel<max_real) then
            where (k2<k1hel .or. k2>k2hel) r = 0.
          endif
        endif
!
!  In 2-D
        if (nz==1) then
          do iky=1,ny
            do ikx=1,nx
              ikz=1
!
!  (vx, vy, vz) -> ux, but put ux=uy=0 then l2d=T. This option only
!  makes sense for the nagnetic vector potential, but the same effect
!  can there be achieved by setting lset_AxAy_zero=T in magnetic.
!  In hydro, we would instead put lset_uz_zero=T.
!
              v_re = u_re(ikx,iky,ikz,:); v_im = u_im(ikx,iky,ikz,:)
              if (l2d1) then
                u_re(ikx,iky,ikz,1:2)=0.
                u_im(ikx,iky,ikz,1:2)=0.
              else
!
                u_re(ikx,iky,ikz,1)=v_re(1) - ky(iky+ipy*ny)*v_im(3)*r(ikx,iky,ikz)
                u_im(ikx,iky,ikz,1)=v_im(1) + ky(iky+ipy*ny)*v_re(3)*r(ikx,iky,ikz)
!
!  (vx, vy, vz) -> uy
!
                u_re(ikx,iky,ikz,2)=v_re(2) + kx(ikx+ipx*nx)*v_im(3)*r(ikx,iky,ikz)
                u_im(ikx,iky,ikz,2)=v_im(2) - kx(ikx+ipx*nx)*v_re(3)*r(ikx,iky,ikz)
              endif
!
!  (vx, vy, vz) -> uz
!
              u_re(ikx,iky,ikz,3)=v_re(3) + ky(iky+ipy*ny)*v_im(1)*r(ikx,iky,ikz) &
                                          - kx(ikx+ipx*nx)*v_im(2)*r(ikx,iky,ikz)
              u_im(ikx,iky,ikz,3)=v_im(3) - ky(iky+ipy*ny)*v_re(1)*r(ikx,iky,ikz) &
                                          + kx(ikx+ipx*nx)*v_re(2)*r(ikx,iky,ikz)
            enddo
          enddo
!  In 3-D
        else
          do ikz=1,nz
            do iky=1,ny
              do ikx=1,nx
!
                v_re = u_re(ikx,iky,ikz,:); v_im = u_im(ikx,iky,ikz,:)
!
!  (vx, vy, vz) -> ux
!
                u_re(ikx,iky,ikz,1)=v_re(1) + kz(ikz+ipz*nz)*v_im(2)*r(ikx,iky,ikz) &
                                            - ky(iky+ipy*ny)*v_im(3)*r(ikx,iky,ikz)
                u_im(ikx,iky,ikz,1)=v_im(1) - kz(ikz+ipz*nz)*v_re(2)*r(ikx,iky,ikz) &
                                            + ky(iky+ipy*ny)*v_re(3)*r(ikx,iky,ikz)
!
!  (vx, vy, vz) -> uy
!
                u_re(ikx,iky,ikz,2)=v_re(2) + kx(ikx+ipx*nx)*v_im(3)*r(ikx,iky,ikz) &
                                            - kz(ikz+ipz*nz)*v_im(1)*r(ikx,iky,ikz)
                u_im(ikx,iky,ikz,2)=v_im(2) - kx(ikx+ipx*nx)*v_re(3)*r(ikx,iky,ikz) &
                                            + kz(ikz+ipz*nz)*v_re(1)*r(ikx,iky,ikz)
!
!  (vx, vy, vz) -> uz
!
                u_re(ikx,iky,ikz,3)=v_re(3) + ky(iky+ipy*ny)*v_im(1)*r(ikx,iky,ikz) &
                                            - kx(ikx+ipx*nx)*v_im(2)*r(ikx,iky,ikz)
                u_im(ikx,iky,ikz,3)=v_im(3) - ky(iky+ipy*ny)*v_re(1)*r(ikx,iky,ikz) &
                                            + kx(ikx+ipx*nx)*v_re(2)*r(ikx,iky,ikz)
!
              enddo
            enddo
          enddo
        endif
!
!  Possibility of a kinematic time dependence.
!
        if (ltime) then
          if (ltime_new1.and..not.lskip_projection) &
            call fatal_error('power_randomphase_hel','must have lskip_projection=T')
          do ikz=1,nz
            do iky=1,ny
              do ikx=1,nx
                  om=cs1*k2(ikx,iky,ikz)
                  ctime=cos(om*time1); stime=sin(om*time1)
                  if (ltime_new1) then
!
!  Pretend that u_re(ikx,iky,ikz,1) and u_im(ikx,iky,ikz,1) is a complex random number,
!  then, after multiplying by i, we have i*z = i*(z'+i*z") = -z" + i*z'.
!
                  u_re(ikx,iky,ikz,1)=-kx(ikx+ipx*nx)*u_im(ikx,iky,ikz,1)*ctime
                  u_im(ikx,iky,ikz,1)=+kx(ikx+ipx*nx)*u_re(ikx,iky,ikz,1)*ctime
                  u_re(ikx,iky,ikz,2)=-ky(iky+ipy*ny)*u_im(ikx,iky,ikz,1)*ctime
                  u_im(ikx,iky,ikz,2)=+ky(iky+ipy*ny)*u_re(ikx,iky,ikz,1)*ctime
                  u_re(ikx,iky,ikz,3)=-kz(ikz+ipz*nz)*u_im(ikx,iky,ikz,1)*ctime
                  u_im(ikx,iky,ikz,3)=+kz(ikz+ipz*nz)*u_re(ikx,iky,ikz,1)*ctime
                elseif (ltime_old1) then
                  u_re(ikx,iky,ikz,1:3)=+u_re(ikx,iky,ikz,1:3)*stime
                  u_im(ikx,iky,ikz,1:3)=-u_im(ikx,iky,ikz,1:3)*ctime
                else
                  u_re(ikx,iky,ikz,1:3)=+u_re(ikx,iky,ikz,1:3)*ctime
                  u_im(ikx,iky,ikz,1:3)=+u_im(ikx,iky,ikz,1:3)*ctime
                endif
              enddo
            enddo
          enddo
        endif
!
!  back to real space, unless lremain_in_fourier=T, in which case
!  we assume that the imaginary part is just next to the real part.
!
        if (lremain_in_fourier1) then
          f(l1:l2,m1:m2,n1:n2,i1  :i2  )=f(l1:l2,m1:m2,n1:n2,i1  :i2  )+u_re
          f(l1:l2,m1:m2,n1:n2,i1+3:i2+3)=f(l1:l2,m1:m2,n1:n2,i1+3:i2+3)+u_im
        else
          do i=1,3
            call fft_xyz_parallel(u_re(:,:,:,i),u_im(:,:,:,i),linv=.true.)
          enddo
          if (loptest(lreinit)) then
            f(l1:l2,m1:m2,n1:n2,i1:i2)=u_re
          else
            f(l1:l2,m1:m2,n1:n2,i1:i2)=f(l1:l2,m1:m2,n1:n2,i1:i2)+u_re
          endif
!
          if (lrho_nonuni1) then
!
!  u_re, u_im now used for lnrho.
!
            do ikz=1,nz
              do iky=1,ny
                do ikx=1,nx
                  u_re(ikx,iky,ikz,1)=(kx(ikx+ipx*nx)*u_re(ikx,iky,ikz,1) &
                                      +ky(iky+ipy*ny)*u_re(ikx,iky,ikz,2) &
                                      +kz(ikz+ipz*nz)*u_re(ikx,iky,ikz,3) &
                                      )/(cs1*k2(ikx,iky,ikz))
                  u_im(ikx,iky,ikz,1)=(kx(ikx+ipx*nx)*u_im(ikx,iky,ikz,1) &
                                      +ky(iky+ipy*ny)*u_im(ikx,iky,ikz,2) &
                                      +kz(ikz+ipz*nz)*u_im(ikx,iky,ikz,3) &
                                      )/(cs1*k2(ikx,iky,ikz))
                enddo
              enddo
            enddo
            call fft_xyz_parallel(u_re(:,:,:,1),u_im(:,:,:,1),linv=.true.)
            f(l1:l2,m1:m2,n1:n2,ilnr1)=u_re(:,:,:,1)
          endif
        endif
      endif   !(i2==i1)
!
!  notification
!
      if (lroot.and..not.ltime) then
        if (cutoff==0) then
          print*,'power_randomphase_hel: k^',initpower,' spectrum: var  i=',i
        else
          print*,'power_randomphase_hel: with cutoff : k^n*exp(-k^4/k0^4) w/ n=', &
                 initpower,', k0 =',cutoff,' : var  i=',i
        endif
      endif
!
!  Deallocate arrays.
!
      if (allocated(k2)) deallocate(k2)
      if (allocated(r))  deallocate(r)
      if (allocated(u_re)) deallocate(u_re)
      if (allocated(u_im)) deallocate(u_im)
      if (allocated(kx)) deallocate(kx)
      if (allocated(ky)) deallocate(ky)
      if (allocated(kz)) deallocate(kz)
!
    endsubroutine power_randomphase_hel
!***********************************************************************
    subroutine bunch_davies(f,i1a,i1b,i2a,i2b,ampl,kpeak,deriv_prefactor)
!
!  21-mar-25/axel: adapted from power_randomphase_hel
!  21-may-25/axel: when kpeak<0, interpret is as sharp cutoff; powerlaw otherwise.
!
      use Fourier, only: fft_xyz_parallel
      use General, only: loptest, roptest
!
      real, dimension (mx,my,mz,mfarray) :: f
      integer :: i, i1a, i1b, i2a, i2b, ikx, iky, ikz, stat, ik, nk, ndim_u, ndim_v
      real, dimension (:,:,:,:), allocatable :: u_re, u_im, v_re, v_im
      real, dimension (:,:,:), allocatable :: k1, r
      real, dimension (:), allocatable :: kx, ky, kz
      real, dimension (:), allocatable :: kk
      real :: ampl, kpeak, deriv_prefactor, scale_factor=1.,ksteepness=5.
!
      if (ampl==0.) then
        if (lroot) print*,'bunch_davies: set variables to zero; i1a,i1b,i2a,i2b=',i1a,i1b,i2a,i2b
        !f(:,:,:,i1a:i1b) = 0.
        !f(:,:,:,i2a:i2b) = 0.
        return
      endif
!
!  Allocate memory for arrays r and k1.
!
      allocate(k1(nx,ny,nz),stat=stat)
      if (stat>0) call fatal_error('bunch_davies','Could not allocate k1')
      allocate(r(nx,ny,nz),stat=stat)
      if (stat>0) call fatal_error('bunch_davies','Could not allocate r')
!
!  Complex auxiliary arrary (u_re,u_im) and (v_re,v_im) 
!
      ndim_u=i1b-i1a+1
      ndim_v=i2b-i2a+1
      allocate(u_re(nx,ny,nz,ndim_u),stat=stat)
      if (stat>0) call fatal_error('bunch_davies','Could not allocate u_re')
      allocate(u_im(nx,ny,nz,ndim_u),stat=stat)
      if (stat>0) call fatal_error('bunch_davies','Could not allocate u_im')
      allocate(v_re(nx,ny,nz,ndim_v),stat=stat)
      if (stat>0) call fatal_error('bunch_davies','Could not allocate v_re')
      allocate(v_im(nx,ny,nz,ndim_v),stat=stat)
      if (stat>0) call fatal_error('bunch_davies','Could not allocate v_im')
!
!  One-dimensional wavevector arrays.
!
      allocate(kx(nxgrid),stat=stat)
      if (stat>0) call fatal_error('bunch_davies','Could not allocate kx')
      allocate(ky(nygrid),stat=stat)
      if (stat>0) call fatal_error('bunch_davies','Could not allocate ky')
      allocate(kz(nzgrid),stat=stat)
      if (stat>0) call fatal_error('bunch_davies','Could not allocate kz')
!
!  Scale factors if box size is not 2*pi
!
      scale_factor=2*pi/Lx
      kx=cshift((/(i-nxgrid/2,i=0,nxgrid-1)/),nxgrid/2)*scale_factor
      if (lroot.and.ip<10) print*,'AXEL: kx=',kx
!
      ky=cshift((/(i-nygrid/2,i=0,nygrid-1)/),nygrid/2)*scale_factor
      if (lroot.and.ip<10) print*,'AXEL: ky=',ky
!
      kz=cshift((/(i-nzgrid/2,i=0,nzgrid-1)/),nzgrid/2)*scale_factor
      if (lroot.and.ip<10) print*,'AXEL: kz=',kz
!
!  Set the 3 components of v_im to Gaussian-distributed random values.
!  If it is a scalar, then there should be only one entry.
!
      do i=1,1+i1b-i1a
        call random_number_wrapper(r)
        call random_number_wrapper(k1)
        v_re(:,:,:,i)=sqrt(-2*log(r))*cos(2*pi*k1)
        v_im(:,:,:,i)=sqrt(-2*log(r))*sin(2*pi*k1)
      enddo
!
!  Set k1 = |k| array.
!
!  In 1-D
      if (nzgrid==1.and.nygrid==1) then
        ikz=1
        iky=1
        do ikx=1,nx
          k1(ikx,iky,ikz)=sqrt(kx(ikx+ipx*nx)**2)
        enddo
!  In 2-D
      elseif (nzgrid==1) then
        ikz=1
        do iky=1,ny
          do ikx=1,nx
            k1(ikx,iky,ikz)=sqrt(kx(ikx+ipx*nx)**2+ky(iky+ipy*ny)**2)
          enddo
        enddo
!  In 3-D
      else
        do ikz=1,nz
          do iky=1,ny
              do ikx=1,nx
                k1(ikx,iky,ikz)=sqrt(kx(ikx+ipx*nx)**2+ky(iky+ipy*ny)**2+kz(ikz+ipz*nz)**2)
              enddo
          enddo
        enddo
      endif
      if (lroot) k1(1,1,1) = 1.  ! To avoid division by zero.
!
!  Put cutoff at kpeak in v_im.
!
!     if (kpeak<0.) then
!       where(k1>=abs(kpeak))
!         v_im(:,:,:,1)=0.
!         v_im(:,:,:,2)=0.
!         v_im(:,:,:,3)=0.
!       endwhere
!     else
!       where(k1>=kpeak)
!         v_im(:,:,:,1)=v_im(:,:,:,1)*(kpeak/k1)**3
!         v_im(:,:,:,2)=v_im(:,:,:,2)*(kpeak/k1)**3
!         v_im(:,:,:,3)=v_im(:,:,:,3)*(kpeak/k1)**3
!       endwhere
!     endif
!
!  Compute Bunch-Davies vacuum, A = e^(-i*k*eta)/sqrt(2*k), so
!  E = -dA/deta = +i*k*e^(-i*k*eta)/sqrt(2*k) = i*e^(-i*k*eta)*sqrt(k/2)
!  Here, v_im serves as a temporary array until the last line.
!  The correct prefactor ampl of H = Hscript/a should be applied in the
!  call tp this routine.
!  exp(-i*k1) = cos(-i*k1) + i*sin(-i*k1)
!
      do i=1,1+i1b-i1a
        !u_re(:,:,:,i)=+ampl*v_im(:,:,:,i)*cos(-k1)/sqrt(k1*2.)
        !u_im(:,:,:,i)=+ampl*v_im(:,:,:,i)*sin(-k1)/sqrt(k1*2.)
        u_re(:,:,:,i)=+ampl*v_re(:,:,:,i)/sqrt(2.*k1)*.5*(1.-tanh(ksteepness*(k1/kpeak-1.)))
        u_im(:,:,:,i)=+ampl*v_im(:,:,:,i)/sqrt(2.*k1)*.5*(1.-tanh(ksteepness*(k1/kpeak-1.)))
        v_re(:,:,:,i)=-k1*u_im(:,:,:,i)
        v_im(:,:,:,i)=+k1*u_re(:,:,:,i)
      enddo
!
!  Fourier transform to real space.
!
      do i=1,1+i1b-i1a
        call fft_xyz_parallel(u_re(:,:,:,i),u_im(:,:,:,i),linv=.true.)
        call fft_xyz_parallel(v_re(:,:,:,i),v_im(:,:,:,i),linv=.true.)
      enddo
!
!  Use real parts of u and v for A and E.
!
      f(l1:l2,m1:m2,n1:n2,i1a:i1b)=f(l1:l2,m1:m2,n1:n2,i1a:i1b)+u_re
      f(l1:l2,m1:m2,n1:n2,i2a:i2b)=f(l1:l2,m1:m2,n1:n2,i2a:i2b)+v_re*deriv_prefactor
!
!  Deallocate arrays.
!
      if (allocated(k1)) deallocate(k1)
      if (allocated(r))  deallocate(r)
      if (allocated(u_re)) deallocate(u_re)
      if (allocated(u_im)) deallocate(u_im)
      if (allocated(v_re)) deallocate(v_re)
      if (allocated(v_im)) deallocate(v_im)
      if (allocated(kx)) deallocate(kx)
      if (allocated(ky)) deallocate(ky)
      if (allocated(kz)) deallocate(kz)
!
    endsubroutine bunch_davies
!***********************************************************************
    subroutine random_isotropic_KS(initpower,f,i1,N_modes)
!
!   produces random, isotropic field from energy spectrum following the
!   KS method (Malik and Vassilicos, 1999.)
!
!   more to do; unsatisfactory so far - at least for a steep power-law energy spectrum
!
!   24-sept-04/snod: coded first attempt
!
      use Sub, only: cross, dot, dot2
!
      integer :: modeN,N_modes,l,n,m,i1
      real, dimension (mx,my,mz,mfarray) :: f
!
! how many wavenumbers?
      real, dimension (3,1024) :: kk,RA,RB !or through whole field for each wavenumber?
      real, dimension (3) :: k_unit,vec,ee,e1,e2,field
      real :: initpower,kmin,ps,k,phi,theta,alpha,beta,dk
      real :: ex,ey,ez,norm,kdotx,r
!
!    minlen=Lxyz(1)/(nx-1)
!    kmax=2.*pi/minlen
!    N_modes=int(0.5*(nx-1))
!    hh=Lxyz(1)/(nx-1)
!    pta=(nx)**(1.0/(nx-1))
!    do modeN=1,N_modes
!       ggt=(kkmax-kkmin)/(N_modes-1)
!       ggt=(kkmax/kkmin)**(1./(N_modes-1))
!        k(modeN)=kmin+(ggt*(modeN-1))
!        k(modeN)=(modeN+3)*2*pi/Lxyz(1)
!       k(modeN)=kkmin*(ggt**(modeN-1)
!    enddo
!
!    do modeN=1,N_modes
!       if (modeN==1)delk(modeN)=(k(modeN+1)-K(modeN))
!       if (modeN==N_modes)delk(modeN)=(k(modeN)-k(modeN-1))
!       if (modeN>1.and.modeN<N_modes)delk(modeN)=(k(modeN+1)-k(modeN-2))/2.0
!    enddo
!          mk=(k2*k2)*((1.0 + (k2/(bk_min*bk_min)))**(0.5*initpower-2.0))
!
!  set kmin
!
      kmin=2.*pi/Lxyz(1)
!
      do modeN=1,N_modes
!
!  pick wavenumber
!
        k=modeN*kmin
!
!  calculate dk
!
        dk=1.0*kmin
!
!   pick 4 random angles for each mode
!
!
        call random_number_wrapper(r); theta=pi*(2*r - 0.)
        call random_number_wrapper(r); phi=pi*(2*r - 0.)
        call random_number_wrapper(r); alpha=pi*(2*r - 0.)
        call random_number_wrapper(r); beta=pi*(2*r - 0.)
!       call random_number_wrapper(r); gamma(modeN)=pi*(2*r - 0.)  ! random phase?
!
!
!   make a random unit vector by rotating fixed vector to random position
!   (alternatively make a random transformation matrix for each k)
!
        k_unit(1)=sin(theta)*cos(phi)
        k_unit(2)=sin(theta)*sin(phi)
        k_unit(3)=cos(theta)
!
!   make a vector kk of length k from the unit vector for each mode
!
        kk(:,modeN)=k*k_unit(:)
!
!   construct basis for plane having rr normal to it
!   (bit of code from forcing to construct x', y')
!
        if ((k_unit(2)==0).and.(k_unit(3)==0)) then
          ex=0.; ey=1.; ez=0.
        else
          ex=1.; ey=0.; ez=0.
        endif
        ee = (/ex, ey, ez/)
        call cross(k_unit(:),ee,e1)
        call dot2(e1,norm); e1=e1/sqrt(norm) ! e1: unit vector perp. to kk
        call cross(k_unit(:),e1,e2)
        call dot2(e2,norm); e2=e2/sqrt(norm) ! e2: unit vector perp. to kk, e1
!
!   make two random unit vectors RB and RA in the constructed plane
!
        RA(:,modeN) = cos(alpha)*e1 + sin(alpha)*e2
        RB(:,modeN) = cos(beta)*e1  + sin(beta)*e2
!
!   define the power spectrum (ps=sqrt(2.*power_spectrum(k)*delta_k/3.))
!
        ps=(k**(initpower/2.))*sqrt(dk*2./3.)
!
!   give RA and RB length ps
!
        RA(:,modeN)=ps*RA(:,modeN)
        RB(:,modeN)=ps*RB(:,modeN)
!
!   form RA = RA x k_unit and RB = RB x k_unit
!
        call cross(RA(:,modeN),k_unit(:),RA(:,modeN))
        call cross(RB(:,modeN),k_unit(:),RB(:,modeN))
!
      enddo
!
!   make the field
!
      do n=n1,n2
        do m=m1,m2
          do l=l1,l2
            field=0.  ! initialize field
            vec(1)=x(l)    ! local coordinates?
            vec(2)=y(m)
            vec(3)=z(n)
            do modeN=1,N_modes  ! sum over N_modes modes
              call dot(kk(:,modeN),vec,kdotx)
              field = field + cos(kdotx)*RA(:,modeN) + sin(kdotx)*RB(:,modeN)
            enddo
            f(l,m,n,i1)   = f(l,m,n,i1)   + field(1)
            f(l,m,n,i1+1) = f(l,m,n,i1+1) + field(2)
            f(l,m,n,i1+2) = f(l,m,n,i1+2) + field(3)
          enddo
        enddo
      enddo
!
    endsubroutine random_isotropic_KS
!***********************************************************************
    subroutine random_isotropic_shell(f,jf,ampl0,z1,z2)
!
!   random_isotropic_shell
!
!   25-jun-15/axel: coded
!
      use Sub, only: cross, dot, dot2
!
      real, dimension (mx,my,mz,mfarray) :: f
!
      character (len=1) :: dummy
      complex :: ii=(0.,1.)
      integer :: jf,i,nvect,ivect
      real, dimension (3) :: ee,kk,exk
      real, dimension (nx) :: kdotx
      real :: exk2,phik,ampl,ampl0,prof,zeta,z1,z2
!
!  read header
!
      open(10,file='kvect.dat')
      read(10,*) nvect
      read(10,*) dummy
!
!  loop through all vectors
!
      f(:,:,:,jf:jf+2)=0.
      do ivect=1,nvect
        read(10,*) kk,ee,phik,ampl
        call cross(ee,kk,exk)
        call dot2(exk,exk2)
        exk=exk/sqrt(exk2)
!
!  allow for the possibility of a profile
!
        do n=n1,n2
          if (z1/=z2) then
            if (z(n)>z1.and.z(n)<z2) then
              zeta=(z(n)-z1)/(z2-z1)-.5
              prof=cos(pi*zeta)**2
            else
              prof=0.
            endif
          else
            prof=1.
          endif
          prof=prof*ampl0*ampl
!
          do m=m1,m2
            kdotx=kk(1)*x(l1:l2)+kk(2)*y(m)+kk(3)*z(n)
            do i=1,3
              f(l1:l2,m,n,jf+i-1)=f(l1:l2,m,n,jf+i-1) &
                +prof*exk(i)*real(exp(ii*(kdotx+phik)))
            enddo
          enddo
        enddo
      enddo
      close(10)

    endsubroutine random_isotropic_shell
!***********************************************************************
    subroutine corona_init(f,gamma)
!
!  Initialize the density for a given temperature profile
!  in the vertical (z) direction by solving for hydrostatic
!  equilibrium.
!  The temperature is hard coded as three polynomials.
!
!  07-dec-05/bing : coded.
!
      use EquationOfState, only: lnrho0,cs20,cs2top,cs2bot
      use Mpicomm, only: mpibcast_real
!
      real, dimension (mx,my,mz,mfarray) :: f
      real :: tmp,ztop,zbot,gamma,gamma_m1,dummy=1.
      integer, parameter :: prof_nz=150
      real, dimension (prof_nz) :: prof_lnT,prof_lnrho,prof_z
      integer :: i,lend,j
!
      ! file location settings
      character (len=*), parameter :: lnrho_dat = 'driver/b_lnrho.dat'
      character (len=*), parameter :: lnT_dat = 'driver/b_lnT.dat'
!
      ! temperature given as function lnT(z) in SI units
      ! [T] = K   &   [z] = Mm   & [rho] = kg/m^3
      if (pretend_lnTT) call not_implemented('corona_init','for pretend_lnTT=T')
!
      if (lroot) then
        inquire(IOLENGTH=lend) dummy
        open (10,file=lnT_dat,form='unformatted',status='unknown',recl=lend*prof_nz)
        read (10) prof_lnT
        read (10) prof_z
        close (10)
!
        open (10,file=lnrho_dat,form='unformatted',status='unknown',recl=lend*prof_nz)
        read (10) prof_lnrho
        close (10)
      endif
!
      call mpibcast_real(prof_lnT,prof_nz)
      call mpibcast_real(prof_z,prof_nz)
      call mpibcast_real(prof_lnrho,prof_nz)
!
      prof_z = prof_z*1.e6/unit_length
      prof_lnT = prof_lnT - alog(real(unit_temperature))
      prof_lnrho = prof_lnrho - alog(real(unit_density))

      gamma_m1=gamma-1.
!
! simple linear interpolation
!
      do j=n1,n2
         do i=1,prof_nz-1
            if (z(j) >= prof_z(i) .and. z(j) < prof_z(i+1) ) then
               f(:,:,j,ilnrho) = (prof_lnrho(i)*(prof_z(i+1) - z(j)) +   &
                    prof_lnrho(i+1)*(z(j)-prof_z(i)) ) / (prof_z(i+1)-prof_z(i))
!
               tmp =  (prof_lnT(i)*(prof_z(i+1) - z(j)) +   &
                    prof_lnT(i+1)*(z(j)-prof_z(i)) ) / (prof_z(i+1)-prof_z(i))
!
               if (ltemperature) then
                  f(:,:,j,ilnTT) = tmp
               elseif (lentropy) then
                  f(:,:,j,iss) = (log(gamma_m1/cs20)+tmp- &
                       gamma_m1*(f(l1,m1,j,ilnrho)-lnrho0))/gamma
               endif
               exit
            endif
         enddo
         if (z(j) >= prof_z(prof_nz)) then
            f(:,:,j,ilnrho) = prof_lnrho(prof_nz)
!
            tmp =  prof_lnT(prof_nz)
!
            if (ltemperature) then
               f(:,:,j,ilnTT) = tmp
            elseif (lentropy) then
               f(:,:,j,iss) = (log(gamma_m1/cs20)+tmp- &
                    gamma_m1*(f(l1,m1,j,ilnrho)-lnrho0))/gamma
            endif
         endif
      enddo
!
      ztop=xyz0(3)+Lxyz(3)
      zbot=xyz0(3)
!
      do i=1,prof_nz-1
         if (ztop >= prof_z(i) .and. ztop < prof_z(i+1) ) then
!
            tmp =  (prof_lnT(i)*(prof_z(i+1) - ztop) +   &
                 prof_lnT(i+1)*(ztop-prof_z(i)) ) / (prof_z(i+1)-prof_z(i))
            cs2top = gamma_m1*exp(tmp)
!
         elseif (ztop >= prof_z(prof_nz)) then
            cs2top = gamma_m1*exp(prof_lnT(prof_nz))
         endif
         if (zbot >= prof_z(i) .and. zbot < prof_z(i+1) ) then
!
            tmp =  (prof_lnT(i)*(prof_z(i+1) - zbot) +   &
                 prof_lnT(i+1)*(zbot-prof_z(i)) ) / (prof_z(i+1)-prof_z(i))
            cs2bot = gamma_m1*exp(tmp)
!
         endif
      enddo
!
    endsubroutine corona_init
!***********************************************************************
    subroutine mdi_init(f,periodic,z0aa)
!
!  Intialize the vector potential
!  by potential field extrapolation
!  of a mdi magnetogram
!
!  13-dec-05/bing : coded.
!
      use Fourier, only: fourier_transform_other, kx_fft, ky_fft
      use Mpicomm, only: mpibcast_real,stop_it_if_any
!
      real, dimension (mx,my,mz,mfarray), intent (inout) :: f
!
      real, dimension (:,:), allocatable :: kx,ky,k2,Bz0_i,Bz0_r,A_r,A_i
      logical, intent (in) :: periodic
      real, intent (in) :: z0aa
      real :: zref,Bzflux
      logical :: exists
      integer :: i,j,idx2,idy2,stat,iostat,lend
      integer :: nxinit,nyinit,itmp
!
      ! file location settings
      character (len=*), parameter :: mag_field_dat = 'driver/mag_field.dat'
!
!  Allocate memory for arrays.
!
      if (.not.lequidist(1).or..not.lequidist(2)) call not_implemented('mdi_init', &
          'for non-equidistant grids')
!
      iostat = 0
      if (periodic) then
        nxinit=nxgrid
        nyinit=nygrid
      else
        nxinit=2*nxgrid
        nyinit=2*nygrid
      endif
!
      allocate(kx(nxinit,nyinit),stat=stat);     iostat=max(stat,iostat)
      allocate(ky(nxinit,nyinit),stat=stat);     iostat=max(stat,iostat)
      allocate(k2(nxinit,nyinit),stat=stat);     iostat=max(stat,iostat)
      allocate(Bz0_i(nxinit,nyinit),stat=stat);  iostat=max(stat,iostat)
      allocate(Bz0_r(nxinit,nyinit),stat=stat);  iostat=max(stat,iostat)
      allocate(A_r(nxinit,nyinit),stat=stat);    iostat=max(stat,iostat)
      allocate(A_i(nxinit,nyinit),stat=stat);    iostat=max(stat,iostat)
!
      call stop_it_if_any((iostat>0),'mdi_init: '// &
          'Could not allocate memory for variables, please check')
!
!  Auxiliary quantities:
!
!  idx2 and idy2 are essentially =2, but this makes compilers
!  complain if nyinit=1 (in which case this is highly unlikely to be
!  correct anyway), so we try to do this better:
      idx2 = min(2,nxinit)
      idy2 = min(2,nyinit)
!
      if (periodic) then
        kx = spread(kx_fft,2,nyinit)
        ky = spread(ky_fft,1,nxinit)
      else
        kx=spread( &
            cshift((/(i-(nxinit+1)/2,i=0,nxinit-1)/),+(nxinit+1)/2)*pi/Lx &
            ,2,nyinit)
        ky=spread( &
            cshift((/(i-(nyinit+1)/2,i=0,nyinit-1)/),+(nyinit+1)/2)*pi/Ly &
            ,1,nxinit)
      endif
!
      k2 = kx*kx + ky*ky
!
      if (lroot) then
        inquire(file=mag_field_dat,exist=exists)
        call stop_it_if_any(.not.exists, &
            'mdi_init: Magnetogram file not found: "'//trim(mag_field_dat)//'"')
        inquire(IOLENGTH=lend) unit_magnetic
        open (11,file=mag_field_dat,form='unformatted',status='unknown', &
            recl=lend*nxgrid*nygrid,access='direct')
        read (11,rec=1) Bz0_r(1:nxgrid,1:nygrid)
        close (11)
        if (.not.periodic) then
          do i=1,nxgrid
            do j=1,nygrid
              Bz0_r(nxgrid+i,j)=Bz0_r(nxgrid+1-i,j)
              Bz0_r(i,nygrid+j)=Bz0_r(i,nygrid+1-j)
              Bz0_r(nxgrid+i,nygrid+j)=Bz0_r(nxgrid+1-i,nygrid+1-j)
            enddo
          enddo
        endif
      else
        call stop_it_if_any(.false.,'')
      endif
      call mpibcast_real(Bz0_r,(/nxinit,nyinit/))
!
      if (lroot) then
        if (nxgrid==1.and.nygrid/=1) then
          Bzflux =  sum(abs(Bz0_r * 1e-4))*dy*unit_length
          write (*,'(A,E10.2)') 'Bz flux sum(|B|)*dl [Tm] :',Bzflux
        elseif (nxgrid/=1.and.nygrid==1) then
          Bzflux =  sum(abs(Bz0_r * 1e-4))*dx*unit_length
          write (*,'(A,E10.2)') 'Bz flux sum(|B|)*dl [Tm] :',Bzflux
        elseif (nxgrid/=1.and.nygrid/=1) then
          Bzflux =  sum(abs(Bz0_r * 1e-4))*dx*unit_length*dy*unit_length
          write (*,'(A,E10.2)') 'Bz flux sum(|B|)*dA [Tm^2] :',Bzflux
        endif
      endif
!
      Bz0_i = 0.
      Bz0_r = Bz0_r * 1e-4 / unit_magnetic ! Gauss to Tesla and SI to PENCIL units
!
!  Fourier Transform of Bz0:
!
      call fourier_transform_other(Bz0_r,Bz0_i)
!
      do i=1,mz
!
!  Calculate transformed vector potential for every z layer
!
        zref = max(0.,z(i) - z0aa)
        if (abs(z(i)-z0aa) <= dz/2. ) then
          itmp = i
          print*,'Height of reference irefz for run.in: ',itmp
        endif
!
        if (nygrid > 1) then
          where (k2 /= 0 )
            A_r = -Bz0_i*ky/k2*exp(-sqrt(k2)*zref )
            A_i =  Bz0_r*ky/k2*exp(-sqrt(k2)*zref )
          elsewhere
            A_r = -Bz0_i*ky/ky(1,idy2)*exp(-sqrt(k2)*zref )
            A_i =  Bz0_r*ky/ky(1,idy2)*exp(-sqrt(k2)*zref )
          endwhere
!
          call fourier_transform_other(A_r,A_i,linv=.true.)
!
          f(l1:l2,m1:m2,i,iax)=A_r(ipx*nx+1:(ipx+1)*nx,ipy*ny+1:(ipy+1)*ny)
        else
          f(l1:l2,m1:m2,i,iax)=0.
        endif
!
        if (nxgrid > 1) then
          where (k2 /= 0 )
            A_r =  Bz0_i*kx/k2*exp(-sqrt(k2)*zref )
            A_i = -Bz0_r*kx/k2*exp(-sqrt(k2)*zref )
          elsewhere
            A_r =  Bz0_i*kx/kx(idx2,1)*exp(-sqrt(k2)*zref )
            A_i = -Bz0_r*kx/kx(idx2,1)*exp(-sqrt(k2)*zref )
          endwhere
!
          call fourier_transform_other(A_r,A_i,linv=.true.)
!
          f(l1:l2,m1:m2,i,iay)=A_r(ipx*nx+1:(ipx+1)*nx,ipy*ny+1:(ipy+1)*ny)
        else
          f(l1:l2,m1:m2,i,iay)=0.
        endif
!
        f(l1:l2,m1:m2,i,iaz)=0.
      enddo
!
!  Deallocate arrays.
!
      if (allocated(kx)) deallocate(kx)
      if (allocated(ky)) deallocate(ky)
      if (allocated(k2)) deallocate(k2)
      if (allocated(Bz0_i)) deallocate(Bz0_i)
      if (allocated(Bz0_r)) deallocate(Bz0_r)
      if (allocated(A_r)) deallocate(A_r)
      if (allocated(A_i)) deallocate(A_i)
!
!  Save initial vector potential
      if (ipz==0) then
        open (11,file=trim(directory_snap)//trim('/Ax_init.dat'),form='unformatted')
        write (11) f(l1:l2,m1:m2,itmp,iax)
        close (11)
        open (11,file=trim(directory_snap)//trim('/Ay_init.dat'),form='unformatted')
        write (11) f(l1:l2,m1:m2,itmp,iay)
        close (11)
        open (11,file=trim(directory_snap)//trim('/Az_init.dat'),form='unformatted')
        write (11) f(l1:l2,m1:m2,itmp,iaz)
        close (11)
      endif
!
    endsubroutine mdi_init
!***********************************************************************
    subroutine mag_init(f)
!
!  Intialize the vector potential with a potential field extrapolation.
!
!  29-Mar-2011/Bourdin.KIS : coded, adapted parts from 'mdi_init'.
!
      use Fourier, only: setup_extrapol_fact, field_extrapol_z_parallel
      use Mpicomm, only: stop_it_if_any, mpisend_real, mpirecv_real, sum_xy
!
      real, dimension (mx,my,mz,mfarray), intent(inout) :: f
!
      real, dimension (:,:), allocatable :: Bz
      real, dimension (:,:,:), allocatable :: exp_fact
      integer, parameter :: bnx=nxgrid, bny=ny/nprocx ! data in pencil shape
      integer, parameter :: enx=nygrid, eny=nx/nprocy ! transposed data in pencil shape
      integer, parameter :: unit=11
      integer, parameter :: tag_xy=131, tag_z=132
      integer :: py, pz, partner
      real :: Bz_flux, Bz_flux_local
      logical :: exists
      integer :: alloc_err, rec_len
      integer(KIND=ikind8) :: rlen
      real, parameter :: reduce_factor=0.25
!
      ! file location settings
      character (len=*), parameter :: mag_field_dat = 'driver/mag_field.dat'
!
      if (.not. lperi(1) .or. .not. lperi(2)) call fatal_error ('mag_init', &
          'Currently only implemented for xy-periodic setups!')
      if (.not. lequidist(1) .or. .not. lequidist(2)) call not_implemented('mag_init', &
          'for non-equidistant grids')
      if (mod (nygrid, nprocxy) /= 0) call fatal_error ('mag_init', &
          'nygrid needs to be an integer multiple of nprocx*nprocy')
      if (mod (nxgrid, nprocxy) /= 0) call fatal_error ('mag_init', &
          'nxgrid needs to be an integer multiple of nprocx*nprocy')
!
!  Allocate memory for arrays.
!
      allocate (Bz(bnx,bny), stat=alloc_err)
      if (alloc_err > 0) call fatal_error('mag_init','Could not allocate Bz', .true.)
      allocate (exp_fact(enx,eny,mz), stat=alloc_err)
      if (alloc_err > 0) call fatal_error('mag_init','Could not allocate exp_fact', .true.)
!
      if (lroot) then
        inquire (file=mag_field_dat, exist=exists)
        call stop_it_if_any(.not. exists, &
            'mag_init: Magnetogram file not found: "'//trim(mag_field_dat)//'"')
        inquire (iolength=rec_len) 1.0d0
        rlen=rec_len*bnx*bny
        open (unit, file=mag_field_dat, form='unformatted', recl=rlen, access='direct')
        do py = 1, nprocxy-1
          partner = find_proc(modulo(py,nprocx),py/nprocx,0)
          ! read Bz data for remote processors
          read (unit, rec=1+py) Bz
          ! send Bz data to remote
          call mpisend_real (Bz, (/ bnx, bny /), partner, tag_xy)
        enddo
        ! read local Bz data
        read (unit, rec=1) Bz
        close (unit)
      else
        call stop_it_if_any(.false.,'')
        if (lfirst_proc_z) then
          ! receive Bz data
          call mpirecv_real (Bz, (/ bnx, bny /), 0, tag_xy)
        endif
      endif
!
      if (nprocz > 1) then
        ! distribute Bz along the z-direction
        if (lfirst_proc_z) then
          do pz = 1, nprocz-1
            partner = find_proc(ipx,ipy,pz)
            call mpisend_real (Bz, (/ bnx, bny /), partner, tag_z)
          enddo
        else
          partner = find_proc(ipx,ipy,0)
          call mpirecv_real (Bz, (/ bnx, bny /), partner, tag_z)
        endif
      endif
!
      ! Gauss to Tesla and SI to PENCIL units
      Bz = Bz * 1e-4 / unit_magnetic
!
      if (lfirst_proc_z) then
        if ((nxgrid==1).and.(nygrid/=1)) then
          Bz_flux_local = sum(abs(Bz)) * dy * unit_magnetic*unit_length
          call sum_xy (Bz_flux_local, Bz_flux)
          if (lroot) write (*,*) 'Total vertical flux: sum(|Bz|)*dy [T*m] =', Bz_flux
        elseif ((nxgrid/=1).and.(nygrid==1)) then
          Bz_flux_local = sum(abs(Bz)) * dx * unit_magnetic*unit_length
          call sum_xy (Bz_flux_local, Bz_flux)
          if (lroot) write (*,*) 'Total vertical flux: sum(|Bz|)*dx [T*m] =', Bz_flux
        elseif ((nxgrid/=1).and.(nygrid/=1)) then
          Bz_flux_local = sum(abs(Bz)) * dx*dy * unit_magnetic*unit_length**2
          call sum_xy (Bz_flux_local, Bz_flux)
          if (lroot) write (*,*) 'Total vertical flux: sum(|Bz|)*(dx*dy) [T*m^2] =', Bz_flux
        endif
      endif
!
!  Perform the field extrapolation in parallel.
!
      call setup_extrapol_fact (z, xyz0(3), exp_fact, reduce_factor)
      call field_extrapol_z_parallel (Bz, f(l1:l2,m1:m2,:,iax:iay), exp_fact)
!
      deallocate (Bz, exp_fact)
!
!  Save initial vector potential
      if (ipz==0) then
        open (11,file=trim(directory_snap)//trim('/Ax_init.dat'),form='unformatted')
        write (11) f(l1:l2,m1:m2,n1,iax)
        close (11)
        open (11,file=trim(directory_snap)//trim('/Ay_init.dat'),form='unformatted')
        write (11) f(l1:l2,m1:m2,n1,iay)
        close (11)
        open (11,file=trim(directory_snap)//trim('/Az_init.dat'),form='unformatted')
        write (11) f(l1:l2,m1:m2,n1,iaz)
        close (11)
      endif
!
    endsubroutine mag_init
!***********************************************************************
    subroutine mag_Az_init(f)
!
!  Intialize the vector potential A with a potential field extrapolation from the bottom boundary read from a file.
!
!  30-Mar-2018/Bourdin.KIS : coded.
!
      use Mpicomm, only: stop_it_if_any, distribute_xy
!
      real, dimension (mx,my,mz,mfarray), intent(inout) :: f
!
      real, dimension (:,:), allocatable :: A_global, A_local
      integer, parameter :: unit=11
      logical :: exists
      integer :: alloc_err, rec_len
!
      ! file location settings
      character (len=*), parameter :: Az_init_dat = 'Az_init.dat'
!
!  Allocate memory for arrays.
!
      if (lroot) then
        allocate (A_global(nxgrid,nygrid), stat=alloc_err)
        if (alloc_err > 0) call fatal_error('mag_Az_init', &
            'Could not allocate memory for A_global', .true.)
      endif
      if (lfirst_proc_z) then
        allocate (A_local(nx,ny), stat=alloc_err)
        if (alloc_err > 0) call fatal_error('mag_Az_init', &
            'Could not allocate memory for A_local', .true.)
      endif
!
      call mag_init(f)
!
      if (lroot) then
        inquire (file=Az_init_dat, exist=exists)
        call stop_it_if_any(.not. exists, &
            'mag_Az_init: file not found: "'//trim(Az_init_dat)//'"')
        inquire (iolength=rec_len) 1.0d0
        open (unit, file=Az_init_dat, form='unformatted', recl=rec_len*nxgrid*nygrid, access='direct')
        ! read A components for each ipz layer
        read (unit, rec=1) A_global
        close (unit)
        ! distribute A component
        call distribute_xy(A_local, A_global)
        f(l1:l2,m1:m2,1,iaz) = A_local
      elseif (lfirst_proc_z) then
        call stop_it_if_any(.false.,'')
        call distribute_xy(A_local)
        f(l1:l2,m1:m2,1,iaz) = A_local
      else
        call stop_it_if_any(.false.,'')
      endif
!
      if (lroot) deallocate (A_global)
      if (lfirst_proc_z) deallocate (A_local)
!
    endsubroutine mag_Az_init
!***********************************************************************
    subroutine file_init(f)
!
!  Intialize the vector potential with a vector potential A from a file.
!
!  30-Mar-2018/Bourdin.KIS : coded.
!
      use Mpicomm, only: stop_it_if_any, distribute_xy, mpisend_real, mpirecv_real
!
      real, dimension (mx,my,mz,mfarray), intent(inout) :: f
!
      real, dimension (:,:,:), allocatable :: A_global, A_local
      integer, parameter :: unit=11
      integer, parameter :: tag_z=133
      logical :: exists
      integer :: partner, pz, comp, alloc_err, rec_len
!
      ! file location settings
      character (len=*), parameter :: A_init_dat = 'Axyz_init.dat'
!
!  Allocate memory for arrays.
!
      if (lfirst_proc_xy) then
        allocate (A_global(nxgrid,nygrid,nz), stat=alloc_err)
        if (alloc_err > 0) call fatal_error('file_init', &
            'Could not allocate memory for A_global', .true.)
      endif
      allocate (A_local(nx,ny,nz), stat=alloc_err)
      if (alloc_err > 0) call fatal_error('file_init', &
          'Could not allocate memory for A_local', .true.)
!
      if (lroot) then
        inquire (file=A_init_dat, exist=exists)
        call stop_it_if_any(.not. exists, &
            'file_init: file not found: "'//trim(A_init_dat)//'"')
        inquire (iolength=rec_len) 1.0d0
        open (unit, file=A_init_dat, form='unformatted', recl=rec_len*nxgrid*nygrid*nz, access='direct')
        ! read A components for each ipz layer
        do comp = 1, 3
          do pz = 0, nprocz-1
            read (unit, rec=1+pz+nprocz*(comp-1)) A_global
            ! distribute A component
            if (pz == ipz) then
              call distribute_xy(A_local, A_global)
              f(l1:l2,m1:m2,n1:n2,iax+(comp-1)) = A_local
              if (iglobal_ax_ext/=0 .and. comp == 1) then
                f(:,:,:, iglobal_ax_ext)=0.
                f(l1:l2,m1:m2,n1:n2,iglobal_ax_ext) = A_local
              endif
              if (iglobal_ay_ext/=0 .and. comp == 2) then
                f(:,:,:, iglobal_ay_ext)=0.
                f(l1:l2,m1:m2,n1:n2,iglobal_ay_ext) = A_local
              endif
              if (iglobal_az_ext/=0 .and. comp == 3) then
                f(:,:,:, iglobal_az_ext)=0.
                f(l1:l2,m1:m2,n1:n2,iglobal_az_ext) = A_local
              endif
            else
              partner = find_proc(ipx,ipy,pz)
              call mpisend_real (A_global, (/ nxgrid, nygrid, nz /), partner, tag_z)
            endif
          enddo
        enddo
        close (unit)
      else
        call stop_it_if_any(.false.,'')
        do comp = 1, 3
          if (lfirst_proc_xy) then
            partner = find_proc(ipx,ipy,0)
            call mpirecv_real (A_global, (/ nxgrid, nygrid, nz /), partner, tag_z)
            call distribute_xy(A_local, A_global)
          else
            call distribute_xy(A_local)
          endif
          f(l1:l2,m1:m2,n1:n2,iax+(comp-1)) = A_local
          if (iglobal_ax_ext/=0 .and. comp == 1) then
            f(:,:,:, iglobal_ax_ext)=0.
            f(l1:l2,m1:m2,n1:n2,iglobal_ax_ext) = A_local
          endif
          if (iglobal_ay_ext/=0 .and. comp == 2) then
            f(:,:,:, iglobal_ay_ext)=0.
            f(l1:l2,m1:m2,n1:n2,iglobal_ay_ext) = A_local
          endif
          if (iglobal_az_ext/=0 .and. comp == 3) then
            f(:,:,:, iglobal_az_ext)=0.
            f(l1:l2,m1:m2,n1:n2,iglobal_az_ext) = A_local
          endif
        enddo
      endif
!
      if (lfirst_proc_xy) deallocate (A_global)
      deallocate (A_local)
!
    endsubroutine file_init
!***********************************************************************
    subroutine temp_hydrostatic(f,rho0,gamma)
!
! 07-dec-05/bing : coded.
!      intialize the density for a given temperature profile in vertical
!      z direction by solving the hydrostatic equilibrium:
!      dlnrho = - dlnTT + (cp-cv)/T g dz
!
      use EquationOfState, only: lnrho0,cs2top,cs2bot
      use Gravity, only: gravz
      use Mpicomm, only: mpibcast_real
!
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ztop,zbot,dummy=1.
      integer, parameter :: prof_nz=150
      real, dimension (prof_nz) :: prof_lnT,prof_z
      real :: tmprho,tmpT,tmpdT,tmpz,dz_step,lnrho_0,rho0,gamma
      integer :: i,lend,j
!
      ! file location settings
      character (len=*), parameter :: lnT_dat = 'driver/b_lnT.dat'
!
      ! temperature given as function lnT(z) in SI units
      ! [T] = K   &   [z] = Mm   & [rho] = kg/m^3
      if (pretend_lnTT) call not_implemented('temp_hydrostatic','for pretend_lnTT=T')
!
      if (lnrho0 > 0.99*log(impossible)) then
        call warning("temp_hydrostatic", &
                     "lnrho0 from eos module not useful, use rho_const from density instead")
        lnrho_0 = log(rho0)
      else
        lnrho_0 = lnrho0
      endif
!
      if (lroot) then
        inquire(IOLENGTH=lend) dummy
        open (10,file=lnT_dat,form='unformatted',status='unknown',recl=lend*prof_nz)
        read (10) prof_lnT
        read (10) prof_z
        close (10)
      endif
      !
      call mpibcast_real(prof_lnT,prof_nz)
      call mpibcast_real(prof_z,prof_nz)
      !
      prof_z = prof_z*1.e6/unit_length
      prof_lnT = prof_lnT - alog(real(unit_temperature))
      !
      ! get step width
      ! should be smaler than grid width and
      ! data width
      !
      dz_step = min((prof_z(2)-prof_z(1)),minval(1./dz_1))
      dz_step = dz_step/10.
      !
      do j=n1,n2
         tmprho = lnrho_0
         tmpT = prof_lnT(1)
         tmpz = prof_z(1)
         !
         ztop=xyz0(3)+Lxyz(3)
         zbot=xyz0(3)
         !
         do while (tmpz <= ztop)
            if (abs(tmpz-zbot) < dz_step) cs2bot = (gamma-1.)*exp(tmpT)
            if (abs(tmpz-ztop) < dz_step) cs2top = (gamma-1.)*exp(tmpT)
            if (abs(tmpz-z(j)) <= dz_step) then
               f(:,:,j,ilnrho) = tmprho
               f(:,:,j,ilnTT)  = tmpT
            endif
            ! new z coord
            tmpz = tmpz+dz_step
            ! get T at new z
            do i=1,prof_nz-1
               if (tmpz >= prof_z(i)  .and. tmpz < prof_z(i+1) ) then
                  tmpdT = (prof_lnT(i+1)-prof_lnT(i))/(prof_z(i+1)-prof_z(i)) * (tmpz-prof_z(i)) + prof_lnT(i) -tmpT
                  tmpT = tmpT + tmpdT
               elseif (tmpz >= prof_z(prof_nz)) then
                  tmpdT = prof_lnT(prof_nz) - tmpT
                  tmpT = tmpT + tmpdT
               endif
            enddo
            tmprho = tmprho - tmpdT + gamma/(gamma-1.)*gravz*exp(-tmpT) * dz_step
         enddo
      enddo
!
    endsubroutine temp_hydrostatic
!***********************************************************************
    subroutine const_lou(ampl,f,i)
!
!  PLEASE ADD A DESCRIPTION
!
!  5-nov-05/weezy: coded
!
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl
      integer::i
!
      do n=n1,n2; do m=m1,m2
        f(l1:l2,m,n,i  )=ampl*cos(2.*pi*y(m))/32.*pi
        f(l1:l2,m,n,i+1)=ampl*cos(2.*pi*z(n))/32.*pi
        f(l1:l2,m,n,i+2)=ampl*cos(2.*pi*x(l1:l2))/32.*pi
      enddo; enddo
!
    endsubroutine const_lou
!***********************************************************************
    subroutine ferriere_uniform_x(ampl,f,i)
!
!  Uniform B_x field propto rho (for vector potential)
!
!  This routine sets up an initial magnetic field x-parallel with a
!  magnitude directly proportional to the density. In entropy.f90 we require
!  Galactic-hs or Ferriere-hs to be set for initss, in density.f90
!  Galactic-hs should be set for initlnrho and in gravity_simple.f90 use
!  Ferriere for gravz_profile
!
!  09-jan-10/fred: coded
!
      use Mpicomm, only: mpireduce_sum, mpibcast_real
!
      integer :: i,icpu
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,tmp1,tmp3
      real, dimension(ncpus)::sumtmp,tmp2
!
      tmp2(:)=0.0
      sumtmp(:)=0.0
      if (ldensity_nolog) then
        tmp1=sum(f(l1:l2,m1,n1:n2,irho))
      else
        tmp1=sum(exp(f(l1:l2,m1,n1:n2,ilnrho)))
      endif
!
!  Calculate the total mass on each processor tmp1 and identify it with the
!  appropriate processor in the array tmp2
!
      do icpu=1,ncpus
        tmp3=tmp1
        call mpibcast_real(tmp3,icpu-1)
        tmp2(icpu)=tmp3
      enddo
!
!  If nprocz is 1 then start summing mass below from zero (sumtmp above).
!  Otherwise sum the masses on the processors below from which to start
!  summing the mass on this processor.
!
      if (ncpus>nprocy) then
        do icpu=nprocy+1,ncpus
          sumtmp(icpu)=sumtmp(icpu-nprocy)+tmp2(icpu-nprocy)
        enddo
      endif
      if (lroot) print*,'sumtmp =',sumtmp
      print*,'sumtmp on iproc =',sumtmp(iproc+1),iproc
      if (ampl==0) then
        f(:,:,:,i:i+2)=0
        if (lroot) print*,'ferriere_uniform_x: set B field to zero; i=',i
      else
        print*,'ferriere_uniform_x: uniform x-field propto rho; i=',i
        if ((ip<=16).and.lroot) print*,'uniform_x: ampl=',ampl
        do n=n1,n2
        do m=m1,m2
          f(l1:l2,m,n,i  )=0.0
          if (ldensity_nolog) then
            f(l1:l2,m,n,i+1)=ampl*(sumtmp(iproc+1)+&
                sum(f(l1:l2,m,n1:n,irho)))*dx*dz
          else
            f(l1:l2,m,n,i+1)=ampl*(sumtmp(iproc+1)+&
                sum(exp(f(l1:l2,m,n1:n,ilnrho))))*dx*dz
          endif
          f(l1:l2,m,n,i+1)=-ampl*(sumtmp(iproc+1)+&
              sum(exp(f(l1:l2,m,n1:n,ilnrho))))*dx*dz
          f(l1:l2,m,n,i+2)=0.0
        enddo
        enddo
      endif
!
    endsubroutine ferriere_uniform_x
!*****************************************************************************
    subroutine ferriere_uniform_y(ampl,f,i)
!
!  Uniform B_y field (for vector potential)
!
!  22-jan-10/fred
!
!  This routine sets up an initial magnetic field y-parallel(azimuthal) with a
!  magnitude directly proportional to the density. In entropy.f90 we require
!  Galactic-hs or Ferriere-hs to be set for initss, in density.f90
!  Galactic-hs should be set for initlnrho and in gravity_simple.f90 use
!  Ferriere for gravz_profile
!
      use Mpicomm, only: mpireduce_sum, mpibcast_real
!
      integer :: i ,icpu
      real, dimension (mx,my,mz,mfarray) :: f
      real :: ampl,tmp1,tmp3
      real, dimension(ncpus)::sumtmp,tmp2
!
      tmp2(:)=0.0
      sumtmp(:)=0.0
      if (ldensity_nolog) then
        tmp1=sum(f(l1:l2,m1,n1:n2,irho))
      else
        tmp1=sum(exp(f(l1:l2,m1,n1:n2,ilnrho)))
      endif
!
!  Calculate the total mass on each processor tmp1 and identify it with the
!  appropriate processor in the array tmp2
!
      do icpu=1,ncpus
        tmp3=tmp1
        call mpibcast_real(tmp3,icpu-1)
        tmp2(icpu)=tmp3
      enddo
!
!  If nprocz is 1 then start summing mass below from zero (sumtmp above).
!  Otherwise sum the masses on the processors below from which to start
!  summing the mass on this processor.
!
      if (ncpus>nprocy) then
        do icpu=nprocy+1,ncpus
          sumtmp(icpu)=sumtmp(icpu-nprocy)+tmp2(icpu-nprocy)
        enddo
      endif
      if (lroot) print*,'sumtmp =',sumtmp
      print*,'sumtmp on iproc =',sumtmp(iproc+1),iproc
      if (ampl==0) then
        f(:,:,:,i:i+2)=0
        if (lroot) print*,'ferriere_uniform_y: set B field to zero; i=',i
      else
        print*,'ferriere_uniform_y: uniform y-field approx rho; i=',i
        if ((ip<=16).and.lroot) print*,'uniform_y: ampl=',ampl
        do n=n1,n2
        do m=m1,m2
          if (ldensity_nolog) then
            f(l1:l2,m,n,i)=ampl*(sumtmp(iproc+1)+&
                sum(f(l1:l2,m,n1:n,irho)))*dx*dz
          else
            f(l1:l2,m,n,i)=ampl*(sumtmp(iproc+1)+&
                sum(exp(f(l1:l2,m,n1:n,ilnrho))))*dx*dz
          endif
          f(l1:l2,m,n,i+1)=0.0
          f(l1:l2,m,n,i+2)=0.0
        enddo
        enddo
      endif
!
    endsubroutine ferriere_uniform_y
!*****************************************************************************
    subroutine rotblob(ampl,incl_alpha,f,i,radius,xsphere,ysphere,zsphere)
!
!  Rigid rotating sphere initial velocity
!  with inclination angle alpha.
!
!  18-feb-10/mvaisala: coded
!
      integer :: i,j,l
      real, dimension (mx,my,mz,mfarray) :: f
      real, optional :: xsphere,ysphere,zsphere
      real :: omega, radius, phi, rr_rot, ampl, x01=0.
      real :: y01=0., z01=0., x_real, y_real, z_real
      real :: incl_alpha, theta, vel_phi
!
!  Rotating sphere
!
      omega = ampl/radius
      if (present(xsphere)) x01=xsphere
      if (present(ysphere)) y01=ysphere
      if (present(zsphere)) z01=zsphere
      if (omega==0) then
        if (lroot) print*,'The sphere does not rotate!'
      else
        do n = n1,n2
          do m = m1,m2
            do l = l1,l2
              x_real = x(l) - x01
              y_real = y(m) - y01
              z_real = z(n) - z01
              rr_rot = sqrt((x_real)**2+(y_real)**2+(z_real)**2)
              theta  = atan(abs(z_real)/sqrt((x_real)**2+(y_real)**2))
              phi    = atan(y_real/x_real)
              vel_phi = omega*rr_rot*cos(theta)
              if (rr_rot <= radius) then
                j = i
                f(l,m,n,j) = vel_phi*sin(phi)
                j = i+1
                f(l,m,n,j) = -vel_phi*cos(phi)*cos(incl_alpha)
                j = i+2
                f(l,m,n,j) = vel_phi*cos(phi)*sin(incl_alpha)
                if (x_real < 0.0) then
                  j = i
                  f(l,m,n,j) = -f(l,m,n,j)
                  j = i+1
                  f(l,m,n,j) = -f(l,m,n,j)
                endif
              endif
            enddo
          enddo
        enddo
      endif
!
    endsubroutine rotblob
!***********************************************************************
    subroutine rotblob_yz(ampl,f,i,radius,xsphere,ysphere,zsphere)
!
!  Rigid rotating sphere initial velocity
!  with inclination angle alpha.
!
!  18-feb-10/mvaisala: coded
!
      integer :: i,j,l
      real, dimension (mx,my,mz,mfarray) :: f
      real, optional :: xsphere,ysphere,zsphere
      real :: omega, radius, phi, rr_rot, ampl, x01=0.
      real :: y01=0., z01=0., x_real, y_real, z_real
      real :: theta, vel_phi
!
!  Rotating sphere
!
      omega = ampl/radius
      if (present(xsphere)) x01=xsphere
      if (present(ysphere)) y01=ysphere
      if (present(zsphere)) z01=zsphere
      if (omega==0) then
        if (lroot) print*,'The sphere does not rotate!'
      else
        do n = n1,n2
          do m = m1,m2
            do l = l1,l2
              x_real = x(l) - x01 !
              y_real = y(m) - y01 !
              z_real = z(n) - z01 !
              rr_rot = sqrt((x_real)**2+(y_real)**2+(z_real)**2) !
              theta  = atan(abs(x_real)/sqrt((x_real)**2+(z_real)**2)) !
              phi    = atan(y_real/z_real) !
              vel_phi = omega*rr_rot*cos(theta) !
              if (rr_rot <= radius) then
                j = i+1
                f(l,m,n,j) = -vel_phi*cos(phi)
                j = i+2
                f(l,m,n,j) = vel_phi*sin(phi)
                if (z_real < 0.0) then
                  j = i+1
                  f(l,m,n,j) = -f(l,m,n,j)
                  j = i+2
                  f(l,m,n,j) = -f(l,m,n,j)
                endif
              endif
            enddo
          enddo
        enddo
      endif
!
    endsubroutine rotblob_yz
!***********************************************************************
    subroutine dipole(f,ix,amp,r_inner_,r_outer_)
!
!  initial vector potential for a
!  purely poloidal axisymmetric field \vec{B} \sim [f_r \cos\theta, f_\theta \sin\theta, 0]
!
!  18-jun-13/MR: coded
!
      real, dimension (mx,my,mz,mfarray) :: f
      integer :: ix
      real :: amp, rpart, rr2, pom2, r_inner, r_outer
      real, optional :: r_inner_, r_outer_

      integer :: l,m,n
!
      if (present(r_inner_).and.present(r_outer_)) then
        r_inner=r_inner_
        r_outer=r_outer_
      else
        r_inner=xyz0(1)
        r_outer=xyz1(1)
      endif
!
!  Dipolar in the z direction in Cartesian coordinates
!
      if (lcartesian_coords) then
        do n=n1,n2
        do m=m1,m2
        do l=l1,l2
          pom2=x(l)**2+y(m)**2
          rr2=pom2+z(n)**2
          if (rr2<=1.) then
            f(l,m,n,ix+1)=amp*sqrt(pom2)
          else
            f(l,m,n,ix+1)=amp*sqrt(pom2/rr2**3)
          endif
        enddo
        enddo
        enddo
!
!  Dipole in spherical coordinantes
!
      elseif (lspherical_coords) then
        !do m = m1,m2
        !  do l = l1,l2
        do m = 1,my
          do l = 1,mx
            !rpart = amp*(xyz0(1)-x(l))*(xyz1(1)-x(l))
            rpart = amp*(r_inner-x(l))*(r_outer-x(l))
            f(l,m,:,ix:ix+1) = 0.
            !if (y(m1)==0.and.y(m2)==pi) then
              f(l,m,:,ix+2) = rpart*sin(y(m))
            !else
            !  f(l,m,:,ix+2) = rpart*sin(pi*(y(m)-xyz0(2))/Lxyz(2))
            !endif
          enddo
        enddo
      endif
!
    endsubroutine dipole
!***********************************************************************
    subroutine quadrupole(f,ix,amp,r_inner_,r_outer_)
!
!  initial vector potential for a
!  purely poloidal axisymmetric field \vec{B} \sim [f_r \cos\theta, f_\theta \sin\theta, 0]
!
!  30-nov-25/axel: adapted from dipole
!
      real, dimension (mx,my,mz,mfarray) :: f
      integer :: ix
      real :: amp, rpart, rr2, pom2, r_inner, r_outer
      real, optional :: r_inner_, r_outer_
      integer :: l,m,n
!
      if (present(r_inner_).and.present(r_outer_)) then
        r_inner=r_inner_
        r_outer=r_outer_
      else
        r_inner=xyz0(1)
        r_outer=xyz1(1)
      endif
!
!  Dipolar in the z direction in Cartesian coordinates
!
      if (lcartesian_coords) then
        call fatal_error('quadrupole', 'not yet programmed')
        do n=n1,n2
        do m=m1,m2
        do l=l1,l2
          pom2=x(l)**2+y(m)**2
          rr2=pom2+z(n)**2
          if (rr2<=1.) then
            f(l,m,n,ix+1)=amp*sqrt(pom2)
          else
            f(l,m,n,ix+1)=amp*sqrt(pom2/rr2**3)
          endif
        enddo
        enddo
        enddo
!
!  Quadrupole in spherical coordinantes.
!  Want B_phi=P_1^1(costh)/r^2, so A_r=-P_1(costh)/r
!
      elseif (lspherical_coords) then
        do m = 1,my
          do l = 1,mx
            rpart = amp/x(l)
            f(l,m,:,ix) = rpart*cos(y(m))
            f(l,m,:,ix+1:ix+2) = 0.
          enddo
        enddo
      endif
!
    endsubroutine quadrupole
!***********************************************************************
    subroutine quadrupole2(f,ix,amp,r_inner_,r_outer_)
!
!  initial vector potential for a
!  purely poloidal axisymmetric field \vec{B} \sim [f_r \cos\theta, f_\theta \sin\theta, 0]
!
!  30-nov-25/axel: adapted from dipole
!
      real, dimension (mx,my,mz,mfarray) :: f
      integer :: ix
      real :: amp, rpart, rr2, pom2, r_inner, r_outer
      real, optional :: r_inner_, r_outer_
      integer :: l,m,n
!
      if (present(r_inner_).and.present(r_outer_)) then
        r_inner=r_inner_
        r_outer=r_outer_
      else
        r_inner=xyz0(1)
        r_outer=xyz1(1)
      endif
!
!  Dipolar in the z direction in Cartesian coordinates
!
      if (lcartesian_coords) then
        call fatal_error('quadrupole', 'not yet programmed')
        do n=n1,n2
        do m=m1,m2
        do l=l1,l2
          pom2=x(l)**2+y(m)**2
          rr2=pom2+z(n)**2
          if (rr2<=1.) then
            f(l,m,n,ix+1)=amp*sqrt(pom2)
          else
            f(l,m,n,ix+1)=amp*sqrt(pom2/rr2**3)
          endif
        enddo
        enddo
        enddo
!
!  Quadrupole in spherical coordinantes.
!  Want B_phi=P_1^1(costh)/r^2, so A_r=-P_1(costh)/r
!
      elseif (lspherical_coords) then
        do m = 1,my
          do l = 1,mx
            rpart = amp/x(l)**2
            f(l,m,:,ix+1) = f(l,m,:,ix+1)+rpart*3.*sin(y(m))*cos(y(m))
          enddo
        enddo
      endif
!
    endsubroutine quadrupole2
!***********************************************************************
    subroutine quadrupole3(f,ix,amp,r_inner_,r_outer_)
!
!  initial vector potential for a
!  purely poloidal axisymmetric field \vec{B} \sim [f_r \cos\theta, f_\theta \sin\theta, 0]
!
!  30-nov-25/axel: adapted from dipole
!
      real, dimension (mx,my,mz,mfarray) :: f
      integer :: ix
      real :: amp, rpart, rr2, pom2, r_inner, r_outer
      real, optional :: r_inner_, r_outer_
      integer :: l,m,n
!
      if (present(r_inner_).and.present(r_outer_)) then
        r_inner=r_inner_
        r_outer=r_outer_
      else
        r_inner=xyz0(1)
        r_outer=xyz1(1)
      endif
!
!  Dipolar in the z direction in Cartesian coordinates
!
      if (lcartesian_coords) then
        call fatal_error('quadrupole', 'not yet programmed')
        do n=n1,n2
        do m=m1,m2
        do l=l1,l2
          pom2=x(l)**2+y(m)**2
          rr2=pom2+z(n)**2
          if (rr2<=1.) then
            f(l,m,n,ix+1)=amp*sqrt(pom2)
          else
            f(l,m,n,ix+1)=amp*sqrt(pom2/rr2**3)
          endif
        enddo
        enddo
        enddo
!
!  Quadrupole in spherical coordinantes.
!  Want B_phi=P_1^1(costh)/r^2, so A_r=-P_1(costh)/r
!
      elseif (lspherical_coords) then
        do m = 1,my
          do l = 1,mx
            rpart = amp/x(l)**4
            f(l,m,:,ix+2) = f(l,m,:,ix+1)+rpart*3.*sin(y(m))*cos(y(m))
          enddo
        enddo
      endif
!
    endsubroutine quadrupole3
!***********************************************************************
    subroutine dipoleA(f,ix,amp,r,angle)
!
!  initial vector potential for dipole A
!
      real, dimension (mx,my,mz,mfarray) :: f
      integer :: ix
      real :: amp, rr, r, angle
!
      integer :: l,m,n
!
      if (lcartesian_coords) then
        do n=n1,n2
        do m=m1,m2
        do l=l1,l2
          rr=sqrt(x(l)**2+y(m)**2+z(n)**2)
          if (rr<=r) then
            f(l,m,n,ix)=f(l,m,n,ix) -(amp*y(m)*cos(angle))
            f(l,m,n,ix+1)=f(l,m,n,ix+1)+(amp*(x(l)*cos(angle)-z(n)*sin(angle)))
            f(l,m,n,ix+2)=f(l,m,n,ix+2)+(amp*y(m)*sin(angle))
          else
            f(l,m,n,ix)=f(l,m,n,ix)-(amp*y(m)*cos(angle))/(rr)**3
            f(l,m,n,ix+1)=f(l,m,n,ix+1)+(amp*(x(l)*cos(angle)-z(n)*sin(angle)))/(rr)**3
            f(l,m,n,ix+2)=f(l,m,n,ix+2)+(amp*y(m)*sin(angle))/(rr)**3
          endif
        enddo
        enddo
        enddo
      endif
!
    endsubroutine dipoleA
!
!***********************************************************************
    subroutine dipoleB(f,ix,amp,e, angle)
!
!  initial vector potential for dipole B
!
      real, dimension (mx,my,mz,mfarray) :: f
      integer :: ix
      real :: amp, rr, e, angle
!
      integer :: l,m,n
!
      if (lcartesian_coords) then
        do n=n1,n2
        do m=m1,m2
        do l=l1,l2
          rr=sqrt(x(l)**2+y(m)**2+z(n)**2)
          f(l,m,n,ix)=f(l,m,n,ix)-(amp*y(m)*cos(angle))/(rr+e)**3
          f(l,m,n,ix+1)=f(l,m,n,ix+1)+(amp*(x(l)*cos(angle)-z(n)*sin(angle)))/(rr+e)**3
          f(l,m,n,ix+2)=f(l,m,n,ix+2)+(amp*y(m)*sin(angle))/(rr+e)**3
        enddo
        enddo
        enddo
      endif
!
    endsubroutine dipoleB
!***********************************************************************
    subroutine switchback(f,ix,amp,amp2,r_inner_,r_outer_)
!
!  initial vector potential for a
!  purely poloidal axisymmetric field \vec{B} \sim [f_r \cos\theta, f_\theta \sin\theta, 0]
!
!  18-jun-13/MR: coded
!
      real, dimension (mx,my,mz,mfarray) :: f
      integer :: ix
      real :: amp, amp2, rpart, rr2, pom2, r_inner, r_outer
      real, optional :: r_inner_, r_outer_

      integer :: l,m,n
!
      if (present(r_inner_).and.present(r_outer_)) then
        r_inner=r_inner_
        r_outer=r_outer_
      else
        r_inner=xyz0(1)
        r_outer=xyz1(1)
      endif
!
!  Dipolar in the z direction in Cartesian coordinates
!
      if (lcartesian_coords) then
        do n=n1,n2
        do m=m1,m2
        do l=l1,l2
          pom2=x(l)**2+y(m)**2
          rr2=pom2+z(n)**2
          if (rr2<=1.) then
            f(l,m,n,ix+1)=amp*sqrt(pom2)
          else
            f(l,m,n,ix+1)=amp*sqrt(pom2/rr2**3)
          endif
        enddo
        enddo
        enddo
!
!  Dipole in spherical coordinantes
!
      elseif (lspherical_coords) then
        !do m = m1,m2
        !  do l = l1,l2
        do m = 1,my
          do l = 1,mx
            if (x(l)>=r_inner.and.x(l)<=r_outer) then
              rpart=amp*sin(2.*pi*(x(l)-r_inner)/(r_outer-r_inner))
            else
              rpart=0.
            endif
            f(l,m,:,ix:ix+1)=0.
            f(l,m,:,ix+2)=rpart+amp2/x(l)
          enddo
        enddo
      endif
!
    endsubroutine switchback
!***********************************************************************
    subroutine dipole_tor(f,ix,amp,ladd)
!
!  initial vector potential for a
!  purely toroidal axisymmetric field B_\phi \sim \sin\theta.
!  Radial dependence parabolic and vanishing at boundaries.
!
!  18-jun-13/MR: coded
!
      use General, only: loptest

      real, dimension (mx,my,mz,mfarray) :: f
      integer :: ix
      real :: amp, rpart
      logical, optional :: ladd

      integer :: m,l

      if (lspherical_coords) then
        do m = 1,my
          do l = 1,mx
            rpart = amp*(xyz0(1)-x(l))*(xyz1(1)-x(l))
            if (loptest(ladd)) then
              f(l,m,:,ix)   = f(l,m,:,ix)  + 2.*rpart*cos(y(m))
              f(l,m,:,ix+1) = f(l,m,:,ix+1)+    rpart*sin(y(m))
            else
              f(l,m,:,ix)   = 2.*rpart*cos(y(m))
              f(l,m,:,ix+1) =    rpart*sin(y(m))
              f(l,m,:,ix+2) = 0.
            endif
          enddo
        enddo
      else
        call not_implemented('dipole_tor', &
        'dipolar toroidal field for non-spherical coordinates')
      endif
!
    endsubroutine dipole_tor
!***********************************************************************
    subroutine tanh_hyperbola(amp,f,ix,yzero,delta,kk)
!
!  initial vector potential as used by Moffatt and Hunt, "A model for magnetic
!  reconnection", 2002.

!
!  23 June 2016/dhruba.mitra
!
      real, dimension (mx,my,mz,mfarray) :: f
      real :: amp,yzero,delta,kk
      integer, intent(in) :: ix
      integer :: m,l
      do m = m1,m2
          do l = l1,l2
             f(l,m,:,ix)   = 0.
            f(l,m,:,ix+1) = 0.
            f(l,m,:,ix+2) = 0.5*amp*tanh((y(m)*y(m) - yzero*yzero-kk*kk*x(l)*x(l))/(delta*delta))
          enddo
        enddo

!
    endsubroutine
!***********************************************************************
    subroutine pre_stellar_cloud(f, datafile, mass_cloud,  &
        cloud_mode, T_cloud_out_rel, dens_coeff, &
        temp_coeff, temp_trans, temp_coeff_out)
!
!  Creates a isothermal or modified Bonnor-Ebert Sphere to be used as
!  a prestellar cloud.
!
!  datafile: The file that includes the density and temp distribution
!  BE_resolution: The resolution of isothemal BE-solutions
!  mass_cloud: mass of the cloud in solar masses
!
!  13-jul-10/mvaisala: created
!
      use EquationOfState, only: eoscalc
!
      integer :: jj, test, n, m, l, len_file
      integer, parameter :: BE_resolution = 2000
      logical :: exist !
      real, dimension (mx,my,mz,mfarray), intent(inout) :: f
      real, dimension (BE_resolution) :: lnTT_file, lnrho_r, r_rho
      real :: tmp, var1, var2, var3
      real :: bigr, mass_cloud
      real :: x01 = 0.0, y01 = 0.0, z01 = 0.0
      real :: x_real, y_real, z_real, rr_box, counter
      real :: M_sun = 1.98892e30 ! kg (SI)
      real :: T_cloud_out_rel, lnTTpoint
      real :: lnTTpoint0, dens_coeff, temp_coeff, temp_coeff_out
      real :: x_wave, wavelength, QQQ, temp_trans, T_cloud_out_rel0
!
      character (len=fnlen) :: datafile
      character (len=labellen) :: cloud_mode
!
      write (*,*) 'Solar mass:', M_sun
      write (*,*) 'unit_mass:', unit_mass
      write (*,*) 'unit_temperature', unit_temperature
      mass_cloud = (mass_cloud * M_sun) / unit_mass
!
      select case (cloud_mode)
!
         case ('read_modified')
!
! Read a radial density and temperature distribution from a file with a chosen
! name. The file must be in the format:
! 1st line: BIGR (cm)    BE_RESOLUTION (int)
! others:   RADIUS (cm)  DENSITY (g/cm^3)  TEMPERATURE (K)
!
           inquire(file=datafile, exist=exist)
           if (exist) then
             open(19, file=datafile)
           else
             call fatal_error('Bonnor-Ebert Sphere', 'No input file')
           endif
           read(19,*) var1, len_file
           bigr = var1/unit_length
           write (*,*) '(Modified BE-sphere) R = ', var1, 'cm =',&
                        bigr, 'pc_units'
           do jj = 1, len_file
             read(19,*) var1, var2, var3
             r_rho(jj) = var1/unit_length
             lnrho_r(jj) = log(var2/unit_density)
             lnTT_file(jj) = log(var3/unit_temperature)
           enddo
!
           counter = 0
           do n = n1,n2
             do m = m1,m2
               do l = l1,l2
                 x_real = x(l) - x01
                 y_real = y(m) - y01
                 z_real = z(n) - z01
                 rr_box = sqrt((x_real)**2+(y_real)**2+(z_real)**2)
                 test = 0
                 if (rr_box <= bigr) then
                   do while (r_rho(test+1) <= rr_box)
                      test = test + 1
                   enddo
                   f(l,m,n,ilnrho) = lnrho_r(test)
                   call eoscalc(ilnrho_lnTT, lnrho_r(test), lnTT_file(test),&
                                ss=tmp)
                   f(l,m,n,iss) = tmp
                   counter = counter+1
                 else
                   do while (r_rho(test+1) <= bigr)
                      test = test + 1
                   enddo
                   if (rr_box <= temp_trans*bigr) then
                      x_wave = rr_box-bigr
                      wavelength = 2.0*bigr*(temp_trans-1)
                      QQQ = 0.5*(sin(2.0*pi*x_wave/wavelength - pi/2.0) + 1.0)
                      T_cloud_out_rel0 = 1 + QQQ*(T_cloud_out_rel-1.0)
                   else
                      T_cloud_out_rel0 = T_cloud_out_rel
                   endif
                   f(l,m,n,ilnrho) = log(exp(lnrho_r(test))/T_cloud_out_rel0)
                   lnTTpoint = log(exp(lnTT_file(test))* &
                       T_cloud_out_rel0*temp_coeff_out)
                   call eoscalc(ilnrho_lnTT, f(l,m,n,ilnrho), &
                                lnTTpoint, ss=tmp)
                   f(l,m,n,iss) = tmp
                 endif
               enddo
             enddo
           enddo
           write (*,*) 'Covers:', counter, '/', &
                       (abs(n1-n2)*abs(m1-m2)*abs(l1-l2)), 'cells'
!
         case ('read_isothermal')
!
! Read a radial density distribution from a file with a chosen
! name. The file must be in the format:
! 1st line: BIGR (cm)    BE_RESOLUTION (int)   TEMPERATURE (K)
! others:   RADIUS (cm)  DENSITY (g/cm^3)
!
           inquire(file=datafile, exist=exist)
           if (exist) then
             open(19, file=datafile)
           else
             write (*,*) datafile
             call fatal_error('Bonnor-Ebert Sphere', 'No input file')
           endif
           read(19,*) var1, len_file, var2
           bigr = var1/unit_length
           lnTTpoint0 = log(var2*temp_coeff/unit_temperature)
           write (*,*) '(Isothermal BE-sphere) R =', var1, 'cm =',&
                        bigr, 'pc_units, T =', var2, 'K'
           do jj = 1, len_file
             read(19,*) var1, var2
             r_rho(jj) = var1/unit_length
             lnrho_r(jj) = log(var2*dens_coeff/unit_density)
           enddo
           write (*,*) 'Temperature, lnTT = ', lnTTpoint0
!
           counter = 0
           do n = n1,n2
             do m = m1,m2
               do l = l1,l2
                 lnTTpoint = lnTTpoint0
                 x_real = x(l) - x01
                 y_real = y(m) - y01
                 z_real = z(n) - z01
                 rr_box = sqrt((x_real)**2+(y_real)**2+(z_real)**2)
                 test = 0
                 if (rr_box <= bigr) then
                   do while (r_rho(test+1) <= rr_box)
                     test = test + 1
                   enddo
                   f(l,m,n,ilnrho) = lnrho_r(test)
                   call eoscalc(ilnrho_lnTT, f(l,m,n,ilnrho), lnTTpoint, ss=tmp)
                   f(l,m,n,iss) = tmp
                   counter = counter+1
                 else
                   do while (r_rho(test+1) <= bigr)
                     test = test + 1
                   enddo
                   if (rr_box <= temp_trans*bigr) then
                      x_wave = rr_box-bigr
                      wavelength = 2.0*bigr*(temp_trans-1)
                      QQQ = 0.5*(sin(2.0*pi*x_wave/wavelength - pi/2.0) + 1.0)
                      T_cloud_out_rel0 = 1 + QQQ*(T_cloud_out_rel-1.0)
                   else
                      T_cloud_out_rel0 = T_cloud_out_rel
                   endif
                   !WRITE (*,*) 'T_cloud_out_rel:', T_cloud_out_rel0
                   f(l,m,n,ilnrho) = log(exp(lnrho_r(test))/T_cloud_out_rel0)
                   lnTTpoint = log(exp(lnTTpoint0)* &
                       T_cloud_out_rel0*temp_coeff_out)
                   call eoscalc(ilnrho_lnTT, f(l,m,n,ilnrho), lnTTpoint, ss=tmp)
                   f(l,m,n,iss) = tmp
                 endif
               enddo
             enddo
           enddo
           write (*,*) 'Covers:', counter, '/', &
                       (abs(n1-n2)*abs(m1-m2)*abs(l1-l2)), 'cells'
           write (*,*) (temp_trans*bigr-bigr), wavelength/2.0, 4.0*wavelength/2.0
!
         case default
      end select
!
    endsubroutine pre_stellar_cloud
!***********************************************************************
    subroutine read_outside_scal_array(f, datafile, i)
!
!   Reads a pre-generated setup of a scalar variable (i.e. lnrho) from an ascii file,
!   generated by an external script.
!   13-may-13/mvaisala: created
!
      real, dimension (mx,my,mz,mfarray), intent(inout) :: f
      logical :: exfile
      integer :: l,m,n, lfile, mfile, nfile, io_status, i
      real :: value
      character(len=*) :: datafile
!
      inquire (file=datafile, exist=exfile)
      if (.NOT. exfile) then
        call fatal_error(datafile,' no input file')
      else
        open(19,file=datafile)
      end if

!
!   Every processor reads from the same datafile. Depending on the indices,
!   a specific data point in written into proper domain.
!   Format of the data:
!   l  m  n  value
!   The datafiles do not include boundary zones!
!
      io_status = 0
      do while (io_status == 0)
        read (19,*, iostat=io_status) lfile, mfile, nfile, value
        l = lfile - ipx*nx + 3
        m = mfile - ipy*ny + 3
        n = nfile - ipz*nz + 3
        if (l >= l1 .AND. m >= m1 .AND. n >= n1 .AND. l <= l2 .AND. m <= m2 .AND. n <= n2) then
          f(l,m,n,i) = value
        end if
      end do
!
      close(19)
!
    endsubroutine read_outside_scal_array
!***********************************************************************
    subroutine read_outside_vec_array(f, datafile, i, lbinary,ampl)
!
!   Reads a pre-generated setup of a vector variable (i.e. uu) from an ascii file,
!   generated by an external script.
!   13-may-13/mvaisala: created
!
      use IO, only: input_snap, input_snap_finalize
      real, dimension (mx,my,mz,mfarray), intent(inout) :: f
      real, dimension (mx,my,mz,3) :: apot
      logical :: exfile, lbin=.false.
      logical, optional :: lbinary
      integer :: l,m,n, lfile, mfile, nfile, io_status, i
      real :: value1, value2, value3, scale_aa=1.0
      real, optional :: ampl
      character(len=*) :: datafile
!
      inquire (file=datafile, exist=exfile)
      if (present(lbinary)) lbin=lbinary
      if (present(ampl)) scale_aa=ampl
      if (.NOT. exfile) then
        call fatal_error(datafile,' no input file')
      else
        if (lbin) then
          call input_snap(datafile,apot,3,0)
          call input_snap_finalize()
!          apot(:,:,:,1)=0.0
!          apot(:,:,:,2)=spread(spread(0.1*(alog(exp((x+2)/0.2)+exp(-(x+2)/0.2))-&
!                       alog(exp((x+1)/0.2)+exp(-(x+1)/0.2))),2,my),3,mz)-&
!                       spread(spread(0.1*(alog(exp((x-1)/0.2)+exp(-(x-1)/0.2))-&
!                       alog(exp((x-2)/0.2)+exp(-(x-2)/0.2))),2,my),3,mz)
!          apot(:,:,:,2)=spread(spread(0.1*(alog(exp((x+5)/0.2)+exp(-(x+5)/0.2))-&
!                       alog(exp((x+4)/0.2)+exp(-(x+4)/0.2))),2,my),3,mz)-&
!                       spread(spread(0.1*(alog(exp((x+1)/0.2)+exp(-(x+1)/0.2))-&
!                       alog(exp((x-0)/0.2)+exp(-(x-0)/0.2))),2,my),3,mz) + &
!                       -spread(spread(0.1*(alog(exp((x+0)/0.2)+exp(-(x+0)/0.2))-&
!                       alog(exp((x-1)/0.2)+exp(-(x-1)/0.2))),2,my),3,mz)-&
!                       spread(spread(0.1*(alog(exp((x-5)/0.2)+exp(-(x-5)/0.2))-&
!                       alog(exp((x-4)/0.2)+exp(-(x-4)/0.2))),2,my),3,mz)
!          apot(:,:,:,3)=0.0
          f(:,:,:,i  ) = f(:,:,:,i  )+scale_aa*apot(:,:,:,1)
          f(:,:,:,i+1) = f(:,:,:,i+1)+scale_aa*apot(:,:,:,2)
          f(:,:,:,i+2) = f(:,:,:,i+2)+scale_aa*apot(:,:,:,3)
          return
        else
          open(19,file=datafile)
        endif
      end if
!
!   Every processor reads from the same datafile. Depending on the indices,
!   a specific data point in written into proper domain.
!   Format of the data:
!   l  m  n  value_x  value_y  value_z
!   The datafiles do not include boundary zones!
!
      io_status = 0
      do while (io_status == 0)
        read (19,*, iostat=io_status) lfile, mfile, nfile, value1, value2, value3
        l = lfile - ipx*nx + 3
        m = mfile - ipy*ny + 3
        n = nfile - ipz*nz + 3
        if (l >= l1 .AND. m >= m1 .AND. n >= n1 .AND. l <= l2 .AND. m <= m2 .AND. n <= n2) then
          f(l,m,n,i) = value1
          f(l,m,n,i+1) = value2
          f(l,m,n,i+2) = value3
        end if
      end do
!
      close(19)
!
    endsubroutine read_outside_vec_array
!***********************************************************************
endmodule Initcond
