! $Id$
!
!  Module for boundary conditions. Extracted from (no)mpicomm, since
!  all non-periodic (external) boundary conditions require the same
!  code for serial and parallel runs.
!
module Boundcond
!
  use Cdata
  use Messages
  use Mpicomm
  use Deriv, only: set_ghosts_for_onesided_ders, bval_from_neumann, bval_from_3rd
  use General
!
  implicit none
!
  private
!
  public :: update_ghosts, zero_ghosts, finalize_boundcond
  public :: boundconds, boundconds_x, boundconds_y, boundconds_z
  public :: boundconds_x_c, boundconds_y_c, boundconds_z_c
  public :: bc_pencil
  public :: bc_per_x, bc_per_y, bc_per_z
  public :: set_consistent_density_boundary
  public :: set_consistent_vel_boundary
  public :: copy_BCs
  public :: set_periodic_boundcond_on_aux
  public :: jet_x
  public :: initialize_boundcond
!
  interface update_ghosts
    module procedure update_ghosts_all
    module procedure update_ghosts_range
  endinterface
!
  interface zero_ghosts
    module procedure zero_ghosts_all
    module procedure zero_ghosts_range
  endinterface
!
  interface bc_pencil
    module procedure bc_pencil_scalar
    module procedure bc_pencil_vector
  endinterface
!
  logical :: is_vec=.false.
  integer :: jdone=0

  !real, allocatable, dimension(:,:,:) :: slc_dat_xy, slc_dat_xy2, slc_dat_xz, slc_dat_xz2, &
  !                                       slc_dat_yz, slc_dat_yz2
  type(scattered_array), pointer :: slc_dat_xy, slc_dat_xy2, slc_dat_xz, slc_dat_xz2, &
                                    slc_dat_yz, slc_dat_yz2
  integer :: nt_slices=0
  integer, parameter :: sz_slc_chunk=20
  real, dimension(:), pointer :: hcondADI
!
  real, pointer :: gamma, cp, cv
  real :: gamma1, gamma_m1, cp1

  contains
!***********************************************************************
    subroutine update_ghosts_all(f)
!
!  Update all ghost zones of f.
!
!  21-sep-02/wolf: extracted from wsnaps
!  28-mar-17/MR: added registration of already communicated variable ranges in f. 
!
      use Grid, only: coarsegrid_interp

      real, dimension (:,:,:,:) :: f
!
      if (ighosts_updated>=0) then
!
!  If registration is activated, register all variables to have been communicated.
!
        ighosts_updated=ighosts_updated+1
        updated_var_ranges(:,ighosts_updated)=(/1,min(mcom,size(f,4))/)
      endif
!
      call boundconds_x(f)
      call initiate_isendrcv_bdry(f)
      call finalize_isendrcv_bdry(f)
      if (lcoarse) call coarsegrid_interp(f)
      call boundconds_y(f)
      call boundconds_z(f)
!
    endsubroutine update_ghosts_all
!***********************************************************************
    subroutine update_ghosts_range(f,ivar1,ivar2_opt)
!
!  Update specific ghost zones of f.
!
!  11-aug-11/wlad: adapted from update_ghosts
!  28-mar-17/MR: added registration of already communicated variable ranges in f. 
!
      use General, only: add_merge_range
      use Grid, only: coarsegrid_interp
!
      real, dimension (:,:,:,:) :: f
      integer  :: ivar1,ivar2
      integer, optional :: ivar2_opt
!
      integer :: nact_ranges,i
!
      ivar2=ivar1
      if (present(ivar2_opt)) ivar2=ivar2_opt
!
      if (ighosts_updated>=0) then
!
!  If registration is activated, figure out which variables out of the range (ivar1,ivar2) have yet to be communicated.
!  These are appended as a set of ranges to the list of ranges in updated_var_ranges after position ighosts_updated.
!  The new total number of variable ranges to be communicated is nact_ranges.
!
        nact_ranges=add_merge_range( updated_var_ranges, ighosts_updated, (/ivar1,ivar2/) )
!
        if (nact_ranges>ighosts_updated) then
          do i=ighosts_updated+1,nact_ranges
            call boundconds_x(f,updated_var_ranges(1,i),updated_var_ranges(2,i))
            call initiate_isendrcv_bdry(f,updated_var_ranges(1,i),updated_var_ranges(2,i))
            call finalize_isendrcv_bdry(f,updated_var_ranges(1,i),updated_var_ranges(2,i))
            if (lcoarse) &
              call coarsegrid_interp(f,updated_var_ranges(1,i),updated_var_ranges(2,i))
            call boundconds_y(f,updated_var_ranges(1,i),updated_var_ranges(2,i))
            call boundconds_z(f,updated_var_ranges(1,i),updated_var_ranges(2,i))
          enddo
          ighosts_updated=nact_ranges
        endif
      else
        call boundconds_x(f,ivar1,ivar2)
        call initiate_isendrcv_bdry(f,ivar1,ivar2)
        call finalize_isendrcv_bdry(f,ivar1,ivar2)
        if (lcoarse) call coarsegrid_interp(f)
        call boundconds_y(f,ivar1,ivar2)
        call boundconds_z(f,ivar1,ivar2)
      endif
!
    endsubroutine update_ghosts_range
!***********************************************************************
    subroutine zero_ghosts_all(f)
!
!  Zeros the ghost cells for all variables.
!
!  23-oct-13/ccyang: coded.
!
      real, dimension(mx,my,mz,mfarray), intent(inout) :: f
!
      call zero_ghosts_range(f, 1, mfarray)
!
    endsubroutine zero_ghosts_all
!***********************************************************************
    subroutine zero_ghosts_range(f, ivar1, ivar2_opt)
!
!  Zeros the ghost cells for variables ivar1:ivar2.
!
!  23-oct-13/ccyang: coded.
!
      real, dimension(mx,my,mz,mfarray), intent(inout) :: f
      integer, intent(in) :: ivar1
      integer, intent(in), optional :: ivar2_opt
!
      integer :: ivar2
!
      ivar2 = ivar1
      if (present(ivar2_opt)) ivar2 = ivar2_opt
!
      xdir: if (nxgrid > 1) then
        f(1:nghost,m1:m2,n1:n2,ivar1:ivar2) = 0.0
        f(mx-nghost+1:mx,m1:m2,n1:n2,ivar1:ivar2) = 0.0
      endif xdir
!
      ydir: if (nygrid > 1) then
        f(:,1:nghost,n1:n2,ivar1:ivar2) = 0.0
        f(:,my-nghost+1:my,n1:n2,ivar1:ivar2) = 0.0
      endif ydir
!
      zdir: if (nzgrid > 1) then
        f(:,:,1:nghost,ivar1:ivar2) = 0.0
        f(:,:,mz-nghost+1:mz,ivar1:ivar2) = 0.0
      endif zdir
!
    endsubroutine zero_ghosts_range
!***********************************************************************
    subroutine initialize_boundcond
!
!  Initialization for reading boundary values from slices:
!  bc_slc_dir - working directory where these reside.
!
      use Sub, only: position
      use File_io, only: file_exists
      use Syscalls, only: directory_exists
      use IO, only: IO_strategy
      use HDF5_IO, only: input_dim
      use SharedVariables, only: get_shared_variable

      integer :: ix_bc,ix2_bc,iy_bc,iy2_bc,iz_bc,iz2_bc,idum
      logical :: lread_slice_yz,lread_slice_yz2,lread_slice_xz,lread_slice_xz2, &
                 lread_slice_xy,lread_slice_xy2
      integer ::  mx_in, my_in, mz_in, mvar_in, maux_in, mglobal_in, &
                  nghost_in, nprocx_in, nprocy_in, nprocz_in, nprocz_in_
      logical :: lbcxslc,lbcyslc,lbczslc
      character :: prec_in
      character(LEN=3) :: suff_xy2, suff_xz2, suff_yz2

      call get_shared_variable('gamma',gamma,caller="initialize_boundcond")
      if (gamma==impossible) then
        call warning('initialize_boundcond','invalid value of gamma, set it to 5/3')
        gamma=5./3.
      endif
      gamma1=1./gamma; gamma_m1=gamma-1.

      if (leos_idealgas) then
        call get_shared_variable('cp',cp); cp1=1./cp
        call get_shared_variable('cv',cv)
      endif
      if (lADI) call get_shared_variable('hcondADI', hcondADI)
!
! Set proper BC code for Yin-Yang grid
!
      if (lyinyang) then
        if (lroot) call information('initialize_boundcond', 'all BCs for y and z ignored because of Yin-Yang grid')
        lperi(2:3) = .false.; lpole = .false.
        !bcy='yy'; bcz='yy'    ! not needed when interpolating spherical
                               ! components of vectors
        bcy='nil'; bcz='nil'
      endif
!
      call check_consistency_of_lperi('initialize_boundcond')
!
!  The following is all about reading the BC from a slice.
!
      lbcxslc=any(bcx12=='slc'); lbcyslc=any(bcy12=='slc'); lbczslc=any(bcz12=='slc')
      if (lbcxslc.and..not.lactive_dimension(1)) return
      if (lbcyslc.and..not.lactive_dimension(2)) return
      if (lbczslc.and..not.lactive_dimension(3)) return

      lread_slice_xy=.false.; lread_slice_xy2=.false.
      lread_slice_xz=.false.; lread_slice_xz2=.false.
      lread_slice_yz=.false.; lread_slice_yz2=.false.

      if (lbcxslc.or.lbcyslc.or.lbczslc) then

        if (lroot) then

          if (.not.directory_exists(trim(bc_slc_dir)//'/data')) &
            call fatal_error('initialize_boundconds', 'working directory '//trim(bc_slc_dir)//' for slices not found')

          call input_dim(bc_slc_dir, mx_in, my_in, mz_in, mvar_in, maux_in, mglobal_in, &
                         prec_in, nghost_in, nprocx_in, nprocy_in, nprocz_in)
          call input_dim(bc_slc_dir, mx_in, my_in, mz_in, mvar_in, maux_in, mglobal_in, &
                         prec_in, nghost_in, nprocx_in, nprocy_in, nprocz_in_, local=.true.)
          if (mx/=mx_in.or.my/=my_in) &
            call fatal_error('initialize_boundconds', &
                 'data in working directory '//trim(bc_slc_dir)//'have incompatible x or y dimensions')
        endif

        call mpibarrier
        call mpibcast_int(nprocz_in)

        if (lbcxslc) then

          if (any(bcx12(:,1)=='slc')) then
            idum=1
            call position(idum,ipx,nx,ix_bc,lread_slice_yz)
          endif

          if (any(bcx12(:,2)=='slc')) then
            idum=nxgrid
            call position(idum,ipx,nx,ix2_bc,lread_slice_yz2)
            if (lread_slice_yz) then
              suff_yz2='yz2'
            else
              suff_yz2='yz'
            endif
          endif

        endif

        if (lbcyslc) then

          if (any(bcy12(:,1)=='slc')) then
            idum=1
            call position(idum,ipy,ny,iy_bc,lread_slice_xz)
          endif

          if (any(bcy12(:,2)=='slc')) then
            idum=nygrid
            call position(idum,ipy,ny,iy2_bc,lread_slice_xz2)
            if (lread_slice_xz) then
              suff_xz2='xz2'
            else
              suff_xz2='xz'
            endif
          endif

        endif

        if (lbczslc) then

          if (any(bcz12(:,1)=='slc')) then
            idum=1
            call position(idum,ipz,nz,iz_bc,lread_slice_xy)
          endif

          if (any(bcz12(:,2)=='slc')) then
            idum=nzgrid
            call position(idum,ipz,nz,iz2_bc,lread_slice_xy2)
            if (lread_slice_xy) then
              suff_xy2='xy2'
            else 
              suff_xy2='xy'
            endif
          endif

        endif
!
!  Restricted to slice position 'm'!
!
        if (IO_strategy/='HDF5') then
          if (lread_slice_xy ) then
            call init_scattered_array(slc_dat_xy,nx,ny,mvar,sz_slc_chunk,lreloading)
            call get_slice_data(z(n1),find_proc(ipx,ipy,nprocz_in/2-1),'xy',slc_dat_xy,nt_slices)
          endif
          if (lread_slice_xy2) then 
            call init_scattered_array(slc_dat_xy2,nx,ny,mvar,sz_slc_chunk,lreloading)
            call get_slice_data(z(n2),find_proc(ipx,ipy,nprocz_in/2-1),suff_xy2,slc_dat_xy2,nt_slices)
          endif
          if (lread_slice_xz ) then 
            call init_scattered_array(slc_dat_xz ,nx,nz,mvar,sz_slc_chunk,lreloading)
            call get_slice_data(y(m1),find_proc(ipx,nprocy_in/2-1,ipz),'xz',slc_dat_xz,nt_slices)
          endif
          if (lread_slice_xz2) then 
            call init_scattered_array(slc_dat_xz2,nx,nz,mvar,sz_slc_chunk,lreloading)
            call get_slice_data(y(m2),find_proc(ipx,nprocy_in/2-1,ipz),suff_xz2,slc_dat_xz2,nt_slices)
          endif
          if (lread_slice_yz ) then 
            call init_scattered_array(slc_dat_yz ,ny,nz,mvar,sz_slc_chunk,lreloading)
            call get_slice_data(x(l1),find_proc(nprocx_in/2-1,ipy,ipz),'yz',slc_dat_yz,nt_slices)
          endif
          if (lread_slice_yz2) then 
            call init_scattered_array(slc_dat_yz2,ny,nz,mvar,sz_slc_chunk,lreloading)
            call get_slice_data(x(l2),find_proc(nprocx_in/2-1,ipy,ipz),suff_yz2,slc_dat_yz2,nt_slices)
          endif

          call mpibarrier
        else
          call fatal_error('initialize_boundcond','BC set from slice data not implemented for IO_strategy="HDF5"')
        endif      
      endif      

    endsubroutine initialize_boundcond
!***********************************************************************
    subroutine check_consistency_of_lperi(label)
!
!  Check consistency of lperi.
!
!  18-jul-03/axel: coded
!
      character (len=*) :: label
      logical :: lwarning=.true.
      integer :: j
!
!  Identifier.
!
      if (lroot.and.ip<5) print*,'check_consistency_of_lperi: called from',label
!
!  Make the warnings less dramatic looking, if we are only in start
!  and exit this routine altogether if, in addition, ip > 13.
!
      if (label=='check_consistency_of_lperi'.and.ip>13) return
      if (label=='check_consistency_of_lperi') lwarning=.false.
!
      if (nvar > 0) then
!
!  Check x direction.
!
        j=1
        if (any(bcx(1:nvar)=='p'.or. bcx(1:nvar)=='she').and..not.lperi(j).or.&
            any(bcx(1:nvar)/='p'.and.bcx(1:nvar)/='she').and.lperi(j)) &
            call warning_lperi(lwarning,bcx(1:nvar),lperi,j)
!
!  Check y direction.
!
        j=2
        if (any(bcy(1:nvar)=='p').and..not.lperi(j).or.&
            any(bcy(1:nvar)/='p').and.lperi(j)) &
            call warning_lperi(lwarning,bcy(1:nvar),lperi,j)
!
!  Check z direction.
!
        j=3
        if (any(bcz(1:nvar)=='p').and..not.lperi(j).or.&
            any(bcz(1:nvar)/='p').and.lperi(j)) &
            call warning_lperi(lwarning,bcz(1:nvar),lperi,j)
      endif
!
!  Print final warning.
!  Make the warnings less dramatic looking, if we are only in start.
!
      if (lroot .and. (.not. lwarning)) then
        if (label=='check_consistency_of_lperi') then
          print*,'[bad BCs in start.in only affects post-processing' &
               //' of start data, not the run]'
        else
          print*,'check_consistency_of_lperi(run.in): you better stop and check!'
          print*,'------------------------------------------------------'
          print*
        endif
      endif
!
    endsubroutine check_consistency_of_lperi
!***********************************************************************
    subroutine warning_lperi(lwarning,bc,lperi,j)
!
!  Print consistency warning of lperi.
!
!  18-jul-03/axel: coded
!
      character (len=*), dimension(:), intent(in) :: bc
      logical, dimension(3) :: lperi
      logical :: lwarning
      integer :: j
!
      if (lroot) then
        if (lwarning) then
          print*
          print*,'------------------------------------------------------'
          print*,'W A R N I N G'
          lwarning=.false.
        else
          print*
        endif
!
        print*,'warning_lperi: inconsistency, j=', j, ', lperi(j)=',lperi(j)
        print*,'bc=',bc
        print*,"any(bc=='p'.or. bc=='she'), .not.lperi(j) = ", &
          any(bc=='p'.or. bc=='she'), .not.lperi(j)
        print*, "any(bcx/='p'.and.bcx/='she'), lperi(j) = ", &
          any(bc=='p'.or. bc=='she'), .not.lperi(j)
      endif
!
    endsubroutine warning_lperi
!***********************************************************************
    subroutine get_slice_data(pos,iproc_slc,label,slcdat,nt)
!
      use General, only: itoa
      use File_io, only: file_exists
      use IO, only: input_slice

      real, intent(IN) :: pos
      integer, intent(IN) :: iproc_slc
      character(LEN=*) :: label
      type(scattered_array), pointer :: slcdat
      integer :: nt

      character(LEN=fnlen) :: slicedir, file
      real :: pos_slc
     
      slicedir=trim(bc_slc_dir)//'/data/proc'//trim(itoa(iproc_slc))

      if (lhydro) then
        file=trim(slicedir)//'/slice_uu1.'//trim(label)
        call input_slice(file,pos_slc,slcdat,iux,nt)
!print*, 'pos,pos_slc=', pos,pos_slc
!print*, 'iproc, ux:', minval(slcdat(:,:,iux)), maxval(slcdat(:,:,iux))
        if (abs(pos-pos_slc)>dz) &
          call fatal_error_local('get_slice_data', 'slices in '//trim(file)// &
                                 ' at wrong position')
        file=trim(slicedir)//'/slice_uu2.'//trim(label)
        call input_slice(file,pos_slc,slcdat,iuy,nt)
!print*, 'iproc, uy:', minval(slcdat(:,:,iuy)), maxval(slcdat(:,:,iuy))
        file=trim(slicedir)//'/slice_uu3.'//trim(label)
        call input_slice(file,pos_slc,slcdat,iuz,nt)
!print*, 'iproc, uz:', minval(slcdat(:,:,iuz)), maxval(slcdat(:,:,iuz))
      endif

      if (ldensity) then
        file=trim(slicedir)//'/slice_lnrho.'//trim(label)
        call input_slice(file,pos_slc,slcdat,ilnrho,nt)
        if (abs(pos-pos_slc)>dz) &
          call fatal_error_local('get_slice_data', 'slices in '//trim(file)// &
                                 ' at wrong position')
      endif

      if (lentropy) then
        file=trim(slicedir)//'/slice_ss.'//trim(label)
        call input_slice(file,pos_slc,slcdat,iss,nt)
!print*, 'iproc, ss:', minval(slcdat(:,:,iss)), maxval(slcdat(:,:,iss))
        if (abs(pos-pos_slc)>dz) &
          call fatal_error_local('get_slice_data', 'slices in '//trim(file)// &
                                 ' at wrong position')
      endif

      if (lmagnetic) then
        file=trim(slicedir)//'/slice_aa.'//trim(label)
        call input_slice(file,pos_slc,slcdat,iaa,nt)
        if (abs(pos-pos_slc)>dz) &
          call fatal_error_local('get_slice_data', 'slices in '//trim(file)// &
                                 ' at wrong position')
      endif
 
    endsubroutine get_slice_data
!***********************************************************************
    subroutine set_from_slice_x(f,topbot,j)

      use General, only: get_scattered_array

      real, dimension (:,:,:,:) :: f
      integer, intent(IN) :: topbot
      integer :: j

      integer, save :: ilayer=-1
      real, save :: last_gettime, timediff
      real, dimension(ny,nz,mvar), save :: ahead_data

      if (lfirst) then
        if (ilayer==-1) then
          last_gettime=t
          ilayer=0
        elseif (t-last_gettime>=timediff) then
          ilayer=mod(ilayer+1,nt_slices)
          last_gettime=t
        endif
      endif

      if (topbot==BOT) then
        call get_scattered_array(j,ilayer,slc_dat_yz,f(l1,m1:m2,n1:n2,j),timediff,ahead_data(:,:,j))
      else
        call get_scattered_array(j,ilayer,slc_dat_yz2,f(l2,m1:m2,n1:n2,j),timediff,ahead_data(:,:,j))
      endif

    endsubroutine set_from_slice_x
!***********************************************************************
    subroutine set_from_slice_y(f,topbot,j)

      use General, only: get_scattered_array

      real, dimension (:,:,:,:) :: f
      integer, intent(IN) :: topbot
      integer :: j
    
      integer, save :: ilayer=-1
      real, save :: last_gettime, timediff
      real, dimension(nx,nz,mvar), save :: ahead_data

      if (lfirst) then
        if (ilayer==-1) then
          last_gettime=t
          ilayer=0
        elseif (t-last_gettime>=timediff) then
          ilayer=mod(ilayer+1,nt_slices)
          last_gettime=t
        endif
      endif

      if (topbot==BOT) then
        call get_scattered_array(j,ilayer,slc_dat_xz,f(l1:l2,m1,n1:n2,j),timediff,ahead_data(:,:,j))
      else
        call get_scattered_array(j,ilayer,slc_dat_xz2,f(l1:l2,m2,n1:n2,j),timediff,ahead_data(:,:,j))
      endif

    endsubroutine set_from_slice_y
!***********************************************************************
    subroutine set_from_slice_z(f,topbot,j)

      use General, only: get_scattered_array

      real, dimension (:,:,:,:) :: f
      integer, intent(IN) :: topbot
      integer :: j

      logical :: lget,lboth
      integer, dimension(max(1,mvar)), save :: ilayer=0
      real, dimension(mvar), save :: last_gettime
      real, save :: timediff
      real, dimension(nx,ny,mvar), save :: ahead_data
      real :: w

      lget=.false.
      if (itsub==0.or.lfirst) then   
!
! update only in first substep of integration or before integration has started
!
        if (ilayer(j)==0) then
          last_gettime=t
          ilayer(j)=1
          lget=.true.
        elseif (t-last_gettime(j)>=timediff) then
          if (ilayer(j)==nt_slices) then
            ilayer(j)=1
          else
            ilayer(j)=ilayer(j)+1   !mod(ilayer(j)+1,nt_slices)
          endif
          last_gettime(j)=t
          lget=.true.
        endif
      endif

      lboth = ilayer(j)==1 .or. nt_slices==1
      if (.not.lget) w = (t-last_gettime(j))/timediff

      if (topbot==BOT) then
        if (lget) then
          if (lboth) then
            call get_scattered_array(j,ilayer(j),slc_dat_xy,f(l1:l2,m1:m2,n1,j),timediff,ahead_data(:,:,j))
          else
            f(l1:l2,m1:m2,n1,j)=ahead_data(:,:,j)
            call get_scattered_array(j,ilayer(j)+1,slc_dat_xy,ahead_data(:,:,j),timediff)
          endif
          if (nt_slices>1) f(l1:l2,m1:m2,1,j)=f(l1:l2,m1:m2,n1,j)    ! store obtained slice in unused ghost layer
        else
          if (nt_slices>1) then
            f(l1:l2,m1:m2,n1,j)=(1.-w)*f(l1:l2,m1:m2,1,j)+w*ahead_data(:,:,j)
          else
            f(l1:l2,m1:m2,n1,j)=f(l1:l2,m1:m2,1,j)
          endif
        endif
      else
        if (lget) then
!if (iproc==120) write(103,*) it,itsub,j,ilayer(j)+1,lboth
          if (lboth) then
            call get_scattered_array(j,ilayer(j),slc_dat_xy2,f(l1:l2,m1:m2,n2,j),timediff,ahead_data(:,:,j))
          else
            f(l1:l2,m1:m2,n2,j)=ahead_data(:,:,j)
            call get_scattered_array(j,ilayer(j)+1,slc_dat_xy2,ahead_data(:,:,j),timediff)
          endif
          if (nt_slices>1) f(l1:l2,m1:m2,mz,j)=f(l1:l2,m1:m2,n2,j)    ! store obtained slice in unused ghost layer
        else
!if (iproc==120) write(102,*) it,itsub,j,w
          if (nt_slices>1) then
            f(l1:l2,m1:m2,n2,j)=(1.-w)*f(l1:l2,m1:m2,mz,j)+w*ahead_data(:,:,j)
          else
            f(l1:l2,m1:m2,n2,j)=f(l1:l2,m1:m2,mz,j)
          endif
        endif
      endif

    endsubroutine set_from_slice_z
!***********************************************************************
    subroutine boundconds(f,ivar1_opt,ivar2_opt)
!
!  Apply boundary conditions in all three directions.
!  Note that we _must_ call boundconds_{x,y,z} in this order, or edges and
!  corners will not be OK.
!
!  10-oct-02/wolf: coded
!
      real, dimension (:,:,:,:) :: f
      integer, optional :: ivar1_opt, ivar2_opt
      integer :: ivar1, ivar2
!
      ivar1=1; ivar2=min(mcom,size(f,4))
      if (present(ivar1_opt)) ivar1=ivar1_opt
      if (present(ivar2_opt)) ivar2=ivar2_opt
!
      call boundconds_x(f,ivar1,ivar2)
      call boundconds_y(f,ivar1,ivar2)
      call boundconds_z(f,ivar1,ivar2)
!
    endsubroutine boundconds
!***********************************************************************
    subroutine boundconds_x_c(f,ivar1_opt,ivar2_opt)
!
!  Envelope for being called from C code.
!
      real, dimension (mx,my,mz,mfarray) :: f
      integer, optional :: ivar1_opt, ivar2_opt

      call boundconds_x(f,ivar1_opt,ivar2_opt)

    endsubroutine boundconds_x_c
!***********************************************************************
    subroutine boundconds_x(f,ivar1_opt,ivar2_opt)
!
!  Boundary conditions in x, except for periodic part handled by communication.
!  Remark: boundconds_x() needs to be called before communicating (because we
!  communicate the x-ghost points), boundconds_[yz] after communication
!  has finished (they need some of the data communicated for the edges
!  (yz-'corners').
!
!   8-jul-02/axel: split up into different routines for x,y and z directions
!  11-nov-02/wolf: unified bot/top, now handled by loop
!  15-dec-06/wolf: Replaced "if (bcx1(1)=='she') then" by "any" command
!  30-sep-16/MR: new BCs 'n1s' = Neumann + 1-sided, "c1s" = heatflux + 1-sided (only for z boundaries)
!
      use EquationOfState
      use Shear
      use Special, only: special_boundconds
!
      real, dimension (:,:,:,:) :: f
      integer, optional :: ivar1_opt, ivar2_opt
!
      integer :: ivar1, ivar2, j, topbot
      logical :: ip_ok
      type (boundary_condition) :: bc
      real :: XXi, XXi0, tau_XXi
!
      if (nghost<=0) return

      if (ldebug) print*, 'boundconds_x: ENTER'
!
      ivar1=1; ivar2=min(mcom,size(f,4))
      if (present(ivar1_opt)) ivar1=ivar1_opt
      if (present(ivar2_opt)) ivar2=ivar2_opt
!
!!print*, 'boundconds_x: mcom,mfarray,ivar1,ivar2=', mcom,mfarray,ivar1,ivar2
      select case (nxgrid)
!
      case (1)
        if (ldebug) print*, 'boundconds_x: no x-boundary'
!
!  Boundary conditions in x.
!
      case default
!
!  Use the following construct to keep compiler from complaining if
!  we have no variables (and boundconds) at all (samples/no-modules):
!
        if (all(bcx12(ivar1:ivar2,:)=='she')) then
          call boundcond_shear(f,ivar1,ivar2)
        else
          do topbot=BOT,TOP
            ! loop over 'bot','top'
            if (topbot==BOT) then
              ip_ok=lfirst_proc_x
            else
              ip_ok=llast_proc_x
            endif
!
            do j=ivar1,ivar2
!
! Natalia: the next line is for the dustdensity case.
! If ndustspec is large, it is stupid to set bc for all dust species
! in start.in. But if one does not set them, they become 'p' by default
! Since this problem is crucial only for aerosol + chemistry
! the following condition is used. But this place should be modifyed somehow
! Any ideas?
!
!            if ((bcx12(j,topbot)=='p') .and. lchemistry .and. ldustdensity) bcx12(j,topbot)=''
!
              if (ldebug) write(*,'(A,I1,A,I2,A,A)') ' bcx',topbot,'(',j,')=',bcx12(j,topbot)
              if (bcx12(j,topbot) == 'she') then
                if (bcx12(j,1) /= bcx12(j,2)) &
                  call fatal_error_local('boundconds_x','generalize me to have sheared periodic boundary on only one end')
                if (topbot == BOT) call boundcond_shear(f, j, j)
              elseif (ip_ok) then
                select case (bcx12(j,topbot))
                case ('0')
                  ! BCX_DOC: zero value in ghost zones, free value on boundary
                  call bc_zero_x(f,topbot,j)
                case ('p')
                  ! BCX_DOC: periodic
                  call bc_per_x(f,topbot,j)
                case ('s')
                  ! BCX_DOC: symmetry, $f_{N+i}=f_{N-i}$;
                  ! BCX_DOC: implies $f'(x_N)=f'''(x_0)=0$
                  call bc_sym_x(f,+1,topbot,j)
                case ('sf')
                  ! BCX_DOC: symmetry with respect to interface
                  call bc_sf_x(f,+1,topbot,j)
                case ('ss')
                  ! BCX_DOC: symmetry, plus function value given
                  call bc_symset_x(f,+1,topbot,j,val=fbcx(:,topbot))
                case ('sds')
                  ! BCY_DOC: symmetric-derivative-set
                  call bc_symderset_x(f,topbot,j,val=fbcx(:,topbot))
                case ('s0d')
                  ! BCX_DOC: symmetry, function value such that df/dx=0
                  call bc_symset0der_x(f,topbot,j)
                case ('a')
                  ! BCX_DOC: antisymmetry, $f_{N+i}=-f_{N-i}$;
                  ! BCX_DOC: implies $f(x_N)=f''(x_0)=0$
                  call bc_sym_x(f,-1,topbot,j)
                case ('af')
                  ! BCX_DOC: antisymmetry with respect to interface
                  call bc_sf_x(f,-1,topbot,j)
                case ('a2')
                  ! BCX_DOC: antisymmetry relative to boundary value,
                  ! BCX_DOC: $f_{N+i}=2 f_{N}-f_{N-i}$;
                  ! BCX_DOC: implies $f''(x_0)=0$
                  call bc_sym_x(f,-1,topbot,j,REL=.true.)
                case ('a2v')
                  ! BCX_DOC: set boundary value and antisymmetry relative to it
                  ! BCX_DOC: $f_{N+i}=2 f_{N}-f_{N-i}$;
                  ! BCX_DOC: implies $f''(x_0)=0$
                  call bc_sym_x(f,-1,topbot,j,REL=.true.,val=fbcx(:,topbot))
                case ('a2r')
                  ! BCX_DOC: sets $d^2f/dr^2 +2df/dr- 2f/r^2 = 0$
                  ! BCX_DOC: This is the replacement of zero second derivative
                  ! BCX_DOC: in spherical coordinates, in radial direction.
                  call bc_a2r_x(f,topbot,j)
                case ('cpc')
                  ! BCX_DOC: cylindrical perfect conductor
                  ! BCX_DOC: implies $f''+f'/R=0$
                  call bc_cpc_x(f,topbot,j)
                case ('cpp')
                  ! BCX_DOC: cylindrical perfect conductor for Aphi
                  ! BCX_DOC: implies $RA''+A'=0$
                  call bc_cpp_x(f,topbot,j)
                case ('cpz')
                  ! BCX_DOC: cylindrical perfect conductor for Az
                  ! BCX_DOC: implies $R(RA)''-(RA)'=0$
                  call bc_cpz_x(f,topbot,j)
                case ('spr')
                  ! BCX_DOC: spherical perfect conductor
                  ! BCX_DOC: implies $f''+2f'/R=0$ and $f(x_N)=0$
                  call bc_spr_x(f,topbot,j)
                case ('v')
                  ! BCX_DOC: vanishing third derivative
                  call bc_van_x(f,topbot,j)
                case ('cop')
                  ! BCX_DOC: copy value of last physical point to all ghost cells
                  call bc_copy_x(f,topbot,j)
                case ('1s')
                  ! BCX_DOC: onesided
                  call set_ghosts_for_onesided_ders(f,topbot,j,1)
                case ('d1s')
                  ! BCX_DOC: onesided for 1st/2nd derivative in two first inner points, Dirichlet in boundary point
                  if (topbot==BOT) then
                    f(l1,:,:,j) = fbcx(j,topbot)
                  else
                    f(l2,:,:,j) = fbcx(j,topbot)
                  endif
                  call set_ghosts_for_onesided_ders(f,topbot,j,1,.true.)
                case ('n1s')
                  ! BCX_DOC: onesided for 1st/2nd derivative in two first inner points, Neumann in boundary point
                  call bval_from_neumann(f,topbot,j,1,fbcx(j,topbot))
                  call set_ghosts_for_onesided_ders(f,topbot,j,1,.true.)
                case ('1so')
                  ! BCX_DOC: onesided
                  call bc_onesided_x_old(f,topbot,j)
                case ('cT')
                  ! BCX_DOC: constant temperature (implemented as
                  ! BCX_DOC: condition for entropy $s$ or temperature $T$)
                  call bc_ss_temp_x(f,topbot)
                case ('c1')
                  ! BCX_DOC: constant conductive flux
                  if (j==iss)   call bc_ss_flux_x(f,topbot)
                  if (j==ilnTT) call bc_lnTT_flux_x(f,topbot)
                case ('Fgs')
                  ! BCX_DOC: Fconv = - chi_t*rho*T*grad(s)
                  if (j==iss) call bc_ss_flux_turb_x(f,topbot)
                case ('Fct')
                  ! BCX_DOC: Fbot = - K*grad(T) - chi_t*rho*T*grad(s)
                  if (j==iss) call bc_ss_flux_condturb_x(f,topbot)
                case ('Fcm')
                  ! BCX_DOC: $Fbot = - K*grad(\overline{T})$
                  ! BCX_DOC: $       - chi_t*\overline{rho}*\overline{T}*grad(\overline{s})$
                  if (j==iss) call bc_ss_flux_condturb_mean_x(f,topbot)
                case ('sT')
                  ! BCX_DOC: symmetric temperature, $T_{N-i}=T_{N+i}$;
                  ! BCX_DOC: implies $T'(x_N)=T'''(x_0)=0$
                  if (j==iss) call bc_ss_stemp_x(f,topbot)
                case ('asT')
                  ! BCX_DOC: select entropy for uniform ghost temperature
                  ! BCX_DOC: matching fluctuating boundary value,
                  ! BCX_DOC: $T_{N-i}=T_{N}=$;
                  ! BCX_DOC: implies $T'(x_N)=T'(x_0)=0$
                  if (j==iss) call bc_ss_a2stemp_x(f,topbot)
                case ('db')
                  ! BCX_DOC: low-order one-sided derivatives (``no boundary
                  ! BCX_DOC: condition'') for density
                  call bc_db_x(f,topbot,j)
                case ('f')
                  ! BCX_DOC: ``freeze'' value, i.e. maintain initial value; antisymm wrt boundary
                  call bc_freeze_var_x(topbot,j)
                  call bc_sym_x(f,-1,topbot,j,REL=.true.)
                case ('fg')
                  ! BCX_DOC: ``freeze'' value, i.e. maintain initial
                  ! BCX_DOC: value at boundary, also mantaining the
                  ! BCX_DOC: ghost zones at the initial coded value, i.e.,
                  ! BCX_DOC: keep the gradient frozen as well
                  call bc_freeze_var_x(topbot,j)
                case ('1')
                  ! BCX_DOC: $f=1$ (for debugging)
                  call bc_one_x(f,topbot,j)
                case ('set')
                  ! BCX_DOC: set boundary value to \var{fbcx}
                  call bc_sym_x(f,-1,topbot,j,REL=.true.,val=fbcx(:,topbot))
                case ('st')
                  ! BCX_DOC: set boundary value to \var{fbcx}
                  ! Special time-dependent boundary condition to model temporal changes.
                  ! The functional form and the functional values should be generalized.
                  XXi0=0.04
                  tau_XXi=10.
                  XXi=XXi0*(1.-(1.+t/tau_XXi)*exp(-t/tau_XXi))
                  fbcx(:,topbot)=XXi
                  call bc_sym_x_ydep(f,-1,topbot,j,REL=.true.,val=fbcx(:,topbot))
                case ('der')
                  ! BCX_DOC: set derivative on boundary to \var{fbcx}
                  call bc_set_der_x(f,topbot,j,fbcx(j,topbot))
                case ('slo')
                  ! BCX_DOC: set slope at the boundary = \var{fbcx}
                  call bc_slope_x(f,fbcx(:,topbot),topbot,j)
                case ('slp')
                  ! BCX_DOC: set slope at the boundary and in ghost cells = \var{fbcx}
                  call bc_ghost_slope_x(f,fbcx(:,topbot),topbot,j)
                case ('shx')
                  ! BCX_DOC: set shearing boundary proportional to x with slope=\var{fbcx} and abscissa=\var{fbcx2}
                  call bc_shear_x(f,fbcx(:,topbot),fbcx_2(:,topbot),topbot,j)
                case ('shy')
                  ! BCX_DOC: set shearing boundary proportional to y with slope=\var{fbcx} and abscissa=\var{fbcx2}
                  call bc_shear_y(f,fbcx(:,topbot),fbcx_2(:,topbot),topbot,j)
                case ('shz')
                  ! BCX_DOC: set shearing boundary proportional to z with slope=\var{fbcx} and abscissa=\var{fbcx2}
                  call bc_shear_z(f,fbcx(:,topbot),fbcx_2(:,topbot),topbot,j)
                case ('dr0')
                  ! BCX_DOC: set boundary value [really??]
                  call bc_dr0_x(f,fbcx(:,topbot),topbot,j)
                case ('ovr')
                  ! BCX_DOC: overshoot boundary condition
                  ! BCX_DOC:  ie $(d/dx-1/\mathrm{dist}) f = 0.$
                  call bc_overshoot_x(f,fbcx(:,topbot),topbot,j)
                case ('out')
                  ! BCX_DOC: allow outflow, but no inflow
                  ! BCX_DOC: forces ghost cells and boundary to not point inwards
                  call bc_outflow_x(f,topbot,j,.true.)
                case ('e1o')
                  ! BCX_DOC: allow outflow, but no inflow
                  ! BCX_DOC: uses the e1 extrapolation scheme
                  call bc_outflow_x_e1(f,topbot,j,.true.)
                case ('ant')
                  ! BCX_DOC: stops and prompts for adding documentation
                  call bc_antis_x(f,fbcx(:,topbot),topbot,j)
                case ('e1')
                  ! BCX_DOC: extrapolation [describe]
                  call bcx_extrap_2_1(f,topbot,j)
                case ('e2')
                  ! BCX_DOC: extrapolation [describe]
                  call bcx_extrap_2_2(f,topbot,j)
                case ('e2h')
                  ! BCX_DOC: extrapolation [describe]
                  call bcx_extrap_frac_2(f,topbot,j)
                case ('e3')
                  ! BCX_DOC: extrapolation in log [maintain a power law]
                  call bcx_extrap_2_3(f,topbot,j)
                case ('el')
                  ! BCX_DOC: linear extrapolation from last two active cells
                  call bcx_extrap_linear(f, topbot, j)
                case ('pl')
                  ! BCX_DOC: extrapolate using power law with the power index specified by fbcx
                  if (j==ilnrho) then
                    call bcx_extrap_powerlaw(f,topbot,j,fbcx(j,topbot),llog=.true.)
                  else
                    call bcx_extrap_powerlaw(f,topbot,j,fbcx(j,topbot),llog=.false.)
                  endif
                case ('hat')
                  ! BCX_DOC: top hat jet profile in spherical coordinate.
                  !Defined only for the bottom boundary
                  call bc_set_jethat_x(f,j,topbot,fbcx(:,topbot),fbcx_2(:,topbot))
                case ('jet')
                  ! BCX_DOC: top hat jet profile in cartezian coordinate.
                  !Defined only for the bottom boundary
                  call bc_set_jet_x(f,j,topbot,fbcx(:,topbot),fbcx_2(:,topbot))
                case ('spd')
                  ! BCX_DOC:  sets $d(rA_{\alpha})/dr = \mathtt{fbcx(j)}$
                  call bc_set_spder_x(f,topbot,j,fbcx(j,topbot))
                case ('sfr')
                  ! BCX_DOC: stress-free boundary condition
                  ! BCX_DOC: for spherical coordinate system.
                  if (j==iux) call fatal_error('boundconds_x', &
                             'stress-free BC at r boundary not allowed for uu_r')
                  call bc_set_sfree_x(f,topbot,j)
                case ('sr1')
                  ! BCX_DOC: Stress-free bc for spherical coordinate system.
                  ! BCX_DOC: Implementation with one-sided derivative.
                  call bc_set_sr1_x(f,topbot,j)
                case ('nfr')
                  ! BCX_DOC: Normal-field bc for spherical coordinate system.
                  ! BCX_DOC: Some people call this the ``(angry) hedgehog bc''.
                  call bc_set_nfr_x(f,topbot,j)
                case ('nr1')
                  ! BCX_DOC: Normal-field bc for spherical coordinate system.
                  ! BCX_DOC: Some people call this the ``(angry) hedgehog bc''.
                  ! BCX_DOC: Implementation with one-sided derivative.
                  call bc_set_nr1_x(f,topbot,j)
                case ('sa2')
                  ! BCX_DOC: $(d/dr)(r B_{\phi}) = 0$ imposes
                  ! BCX_DOC: boundary condition on 2nd derivative of
                  ! BCX_DOC: $r A_{\phi}$. Same applies to $\theta$ component.
                  call bc_set_sa2_x(f,topbot,j)
                case ('pfc')
                  ! BCX_DOC: perfect-conductor in spherical
                  ! BCX_DOC: coordinate: $d/dr( A_r) + 2/r = 0$.
!joern: WARNING, this bc will NOT give a perfect-conductor boundary condition
                  call bc_set_pfc_x(f,topbot,j)
                case ('fix')
                  ! BCX_DOC: set boundary value [really??]
                  call bc_fix_x(f,topbot,j,fbcx(j,topbot))
                case ('fil')
                  ! BCX_DOC: set boundary value from a file
                  call bc_file_x(f,topbot,j)
                case ('cfb')
                  ! BCX_DOC: radial centrifugal balance
                  if (lcylindrical_coords) then
                    call bc_lnrho_cfb_r_iso(f,topbot)
                  else
                    call not_implemented('bc_lnrho_cfb_r_iso','for other than cylindrical coordinates')
                  endif
                case ('g')
                  ! BCX_DOC: set to given value(s) or function
                  call bc_force_x(f, -1, topbot, j)
                case ('nil')
                  ! BCX_DOC: do nothing; assume that everything is set
                case ('ioc')
                  ! BCX_DOC: inlet/outlet on western/eastern hemisphere
                  ! BCX_DOC: in cylindrical coordinates
                  call bc_inlet_outlet_cyl(f,topbot,j,fbcx(:,topbot))
                case ('tay')
                  call tayler_expansion(f,topbot,j,'x')
                case ('')
                  ! BCX_DOC: do nothing; assume that everything is set
                case ('exp')
                  ! BCX_DOC: exponentiate x ghost zone of other variable
                  call bc_expother_x(f,topbot,j,int(fbcx(j,topbot)))
                case ('slc')
                  call set_from_slice_x(f,topbot,j)
                  call set_ghosts_for_onesided_ders(f,topbot,j,1,.true.)
                case ('no')
!  don't change anything
                case default
                  bc%bcname=bcx12(j,topbot)
                  bc%ivar=j
                  bc%location=(((topbot-1)*2)-1)   ! -1/1 for x bot/top
                  bc%value1=fbcx(j,topbot)
                  bc%value2=fbcx(j,topbot)
                  bc%done=.false.
!
                  call special_boundconds(f,bc)
!
                  if (.not.bc%done) call fatal_error_local("boundconds_x", &
                    "No such boundary condition bcx1/2 = "//trim(bcx12(j,topbot))//" for j="//trim(itoa(j)))
                endselect
              endif
            enddo
          enddo
        endif
      endselect
!
    endsubroutine boundconds_x
!***********************************************************************
    subroutine boundconds_y_c(f,ivar1_opt,ivar2_opt)
!
!  Envelope for being called from C code.
!
      real, dimension (mx,my,mz,mfarray) :: f
      integer, optional :: ivar1_opt, ivar2_opt

      call boundconds_y(f,ivar1_opt,ivar2_opt)

    endsubroutine boundconds_y_c
!***********************************************************************
    subroutine boundconds_y(f,ivar1_opt,ivar2_opt)
!
!  Boundary conditions in y, except for periodic part handled by communication.
!  Remark: boundconds_x() needs to be called before communicating (because we
!  communicate the x-ghost points), boundconds_[yz] after communication
!  has finished (they need some of the data communicated for the edges
!  (yz-'corners').
!
!   8-jul-02/axel: split up into different routines for x,y and z directions
!  11-nov-02/wolf: unified bot/top, now handled by loop
!
      use General, only: var_is_vec
      use Special, only: special_boundconds
      use EquationOfState
!
      real, dimension (:,:,:,:) :: f
      integer, optional :: ivar1_opt, ivar2_opt
!
      integer :: ivar1, ivar2, j, topbot
      logical :: ip_ok
      type (boundary_condition) :: bc
!
      if (ldebug) print*,'boundconds_y: ENTER'
!
      ivar1=1; ivar2=min(mcom,size(f,4))
      if (present(ivar1_opt)) ivar1=ivar1_opt
      if (present(ivar2_opt)) ivar2=ivar2_opt
!
      select case (nygrid)
!
      case (1)
        if (ldebug) print*,'boundconds_y: no y-boundary'
!
!  Boundary conditions in y
!
      case default
        do topbot=BOT,TOP              ! loop over 'bot','top'
          if (topbot==BOT) then
            ip_ok=lfirst_proc_y
          else
            ip_ok=llast_proc_y
          endif
!
          jdone=0
          do j=ivar1,ivar2
!
! Natalia: the next line is for the dustdensity case.
! If ndustspec is large, it is stupid to set bc for all dust species
! in start.in. But if one does not set them, they becomes 'p' by default
! Since this problem is crutial  only for aerosol + chemistry
! the following condition is used. But this place should be modifyed somehow
! Any ideas?
!
!            if ((bcy12(j,topbot)=='p') .and. lchemistry .and. ldustdensity) bcy12(j,topbot)=''
!
            if (ldebug) write(*,'(A,I1,A,I2,A,A)') ' bcy',topbot,'(',j,')=',bcy12(j,topbot)

            if (ip_ok) then
           
              is_vec = var_is_vec(j)
              select case (bcy12(j,topbot))
              case ('0')
                ! BCY_DOC: zero value in ghost zones, free value on boundary
                call bc_zero_y(f,topbot,j)
              case ('p')
                ! BCY_DOC: periodic
                call bc_per_y(f,topbot,j)
              case ('pp')
                ! BCY_DOC: periodic across the pole
                call bc_pper_y(f,+1,topbot,j)
              case ('yy')
                ! BCY_DOC: Yin-Yang grid
                call bc_yy_y(f,topbot,j)
              case ('ap')
                ! BCY_DOC: anti-periodic across the pole
                call bc_pper_y(f,-1,topbot,j)
              case ('s')
                ! BCY_DOC: symmetry symmetry, $f_{N+i}=f_{N-i}$;
                  ! BCX_DOC: implies $f'(y_N)=f'''(y_0)=0$
                call bc_sym_y(f,+1,topbot,j)
              case ('sf')
                ! BCY_DOC: symmetry with respect to interface
                call bc_sf_y(f,+1,topbot,j)
              case ('ss')
                ! BCY_DOC: symmetry, plus function value given
                call bc_symset_y(f,+1,topbot,j,val=fbcy(:,topbot))
              case ('sds')
                ! BCY_DOC: symmetric-derivative-set
                call bc_symderset_y(f,topbot,j,val=fbcy(:,topbot))
              case ('cds')
                ! BCY_DOC: complex symmetric-derivative-set
                call bc_csymderset_y(f,topbot,j,val=fbcy(:,topbot))
              case ('s0d')
                ! BCY_DOC: symmetry, function value such that df/dy=0
                call bc_symset0der_y(f,topbot,j)
              case ('a')
                ! BCY_DOC: antisymmetry
                call bc_sym_y(f,-1,topbot,j)
              case ('af')
                ! BCY_DOC: antisymmetry with respect to interface
                call bc_sf_y(f,-1,topbot,j)
              case ('a2')
                ! BCY_DOC: antisymmetry relative to boundary value
                call bc_sym_y(f,-1,topbot,j,REL=.true.)
              case ('v')
                ! BCY_DOC: vanishing third derivative
                call bc_van_y(f,topbot,j)
              case ('v3')
                ! BCY_DOC: vanishing third derivative
                call bc_van3rd_y(f,topbot,j)
              case ('out')
                ! BCY_DOC: allow outflow, but no inflow
                ! BCY_DOC: forces ghost cells and boundary to not point inwards
                call bc_outflow_y(f,topbot,j,.true.)
              case ('1s')
                ! BCY_DOC: onesided
                call set_ghosts_for_onesided_ders(f,topbot,j,2)
              case ('d1s')
                ! BCY_DOC: onesided for 1st and 2nd derivative in two first inner points, Dirichlet in boundary point
                if (topbot==BOT) then
                  f(:,m1,:,j) = fbcy(j,topbot)
                else
                  f(:,m2,:,j) = fbcy(j,topbot)
                endif
                call set_ghosts_for_onesided_ders(f,topbot,j,2,.true.)
              case ('n1s')
                ! BCY_DOC: onesided for 1st and 2nd derivative in two first inner points, Neumann in boundary point
                call bval_from_neumann(f,topbot,j,2,fbcy(j,topbot))
                call set_ghosts_for_onesided_ders(f,topbot,j,2,.true.)
              case ('cT')
                ! BCY_DOC: constant temp.
                if (j==iss) call bc_ss_temp_y(f,topbot)
              case ('sT')
                ! BCY_DOC: symmetric temp.
                if (j==iss) call bc_ss_stemp_y(f,topbot)
              case ('asT')
                ! BCY_DOC: select entropy for uniform ghost temperature
                ! BCY_DOC: matching fluctuating boundary value,
                ! BCY_DOC: $T_{N-i}=T_{N}=$;
                ! BCY_DOC: implies $T'(x_N)=T'(x_0)=0$
                if (j==iss) call bc_ss_a2stemp_y(f,topbot)
              case ('f')
                ! BCY_DOC: freeze value
                ! tell other modules not to change boundary value
                call bc_freeze_var_y(topbot,j)
                call bc_sym_y(f,-1,topbot,j,REL=.true.) ! antisymm wrt boundary
              case ('s+f')
                ! BCY_DOC: freeze value
                ! tell other modules not to change boundary value
                call bc_freeze_var_y(topbot,j)
                call bc_sym_y(f,+1,topbot,j) ! symm wrt boundary
              case ('fg')
                ! BCY_DOC: ``freeze'' value, i.e. maintain initial
                !  value at boundary, also mantaining the
                !  ghost zones at the initial coded value, i.e.,
                !  keep the gradient frozen as well
                call bc_freeze_var_y(topbot,j)
              case ('fBs')
                ! BCY_DOC: frozen-in B-field (s)
                call bc_frozen_in_bb(topbot,j)
                call bc_sym_y(f,+1,topbot,j) ! symmetry
              case ('fB')
                ! BCY_DOC: frozen-in B-field (a2)
                call bc_frozen_in_bb(topbot,j)
                !call bc_sym_z(f,-1,topbot,j,REL=.true.) ! antisymm wrt boundary
!AB: wasn't this a mistake??
                call bc_sym_y(f,-1,topbot,j,REL=.true.) ! antisymm wrt boundary
              case ('1')
                ! BCY_DOC: f=1 (for debugging)
                call bc_one_y(f,topbot,j)
              case ('set')
                ! BCY_DOC: set boundary value
                call bc_sym_y(f,-1,topbot,j,REL=.true.,val=fbcy(:,topbot))
              case ('sse')
                ! BCY_DOC:  symmetry, set boundary value
                call bc_sym_y(f,+1,topbot,j,val=fbcy(:,topbot))
              case ('sep')
                ! BCY_DOC: set boundary value
                call bc_sym_y(f,-1,topbot,j,REL=.true.,val=fbcy(:,topbot),val2=fbcy_1(:,topbot),val4=fbcy_2(:,topbot))
              case ('e1')
                ! BCY_DOC: extrapolation
                call bcy_extrap_2_1(f,topbot,j)
              case ('e2')
                ! BCY_DOC: extrapolation
                call bcy_extrap_2_2(f,topbot,j)
              case ('e3')
                ! BCY_DOC: extrapolation in log [maintain a power law]
                call bcy_extrap_2_3(f,topbot,j)
              case ('der')
                ! BCY_DOC: set derivative on the boundary
                call bc_set_der_y(f,topbot,j,fbcy(j,topbot))
              case ('cop')
                ! BCY_DOC: outflow: copy value of last physical point to
                ! BCY_DOC: all ghost cells
                call bc_copy_y(f,topbot,j)
              case ('c+k')
                ! BCY_DOC: no-inflow: copy value of last physical point
                ! BCY_DOC: to all ghost cells, but suppressing any inflow
                call bc_copy_y_noinflow(f,topbot,j)
              case ('sfr')
                ! BCY_DOC: stress-free boundary condition for spherical
                ! BCY_DOC: coordinate system.
                  if (j==iux.or.j==iuy) call fatal_error('boundconds_y', &
                             'stress-free BC at theta boundary only allowed for uu_phi')
                call bc_set_sfree_y(f,topbot,j)
              case ('nfr')
                ! BCY_DOC: Normal-field bc for spherical coordinate system.
                ! BCY_DOC: Some people call this the ``(angry) hedgehog bc''.
                call bc_set_nfr_y(f,topbot,j)
              case ('spt')
                ! BCY_DOC: spherical perfect conducting boundary condition
                ! BCY_DOC: along $\theta$ boundary
                ! BCY_DOC: $f''+\cot\theta f'=0$ and $f(x_N)=0$
                call bc_spt_y(f,topbot,j)
              case ('pfc')
                ! BCY_DOC: perfect conducting boundary condition
                ! BCY_DOC: along $\theta$ boundary
!joern: WARNING, this bc will NOT give a perfect-conductor boundary condition
                call bc_set_pfc_y(f,topbot,j)
              case ('str')
                call bc_stratified_y(f,topbot,j)
              case ('nil','')
                ! BCY_DOC: do nothing; assume that everything is set
              case ('tay')
                call tayler_expansion(f,topbot,j,'y')
              case ('exp')
                ! BCY_DOC: exponentiate y ghost zone of other variable
                call bc_expother_y(f,topbot,j,int(fbcy(j,topbot)))
              case ('slc')
                call set_from_slice_y(f,topbot,j)
                call set_ghosts_for_onesided_ders(f,topbot,j,2,.true.)
              case default
                bc%bcname=bcy12(j,topbot)
                bc%ivar=j
                bc%value1=fbcy(j,topbot)
                bc%value2=fbcy(j,topbot)
                bc%location=(((topbot-1)*4)-2)   ! -2/2 for y bot/top
                bc%done=.false.
!
                if (lspecial) call special_boundconds(f,bc)
!
                if (.not.bc%done) call fatal_error_local("boundconds_y", &
                  "no such boundary condition bcy1/2 = "//trim(bcy12(j,topbot))//" for j="//trim(itoa(j)))
              endselect
            endif
          enddo
        enddo
      endselect
!
    endsubroutine boundconds_y
!***********************************************************************
    subroutine boundconds_z_c(f,ivar1_opt,ivar2_opt)
!
!  Envelope for being called from C code.
!
      real, dimension (mx,my,mz,mfarray) :: f
      integer, optional :: ivar1_opt, ivar2_opt

      call boundconds_z(f,ivar1_opt,ivar2_opt)

    endsubroutine boundconds_z_c
!***********************************************************************
    subroutine boundconds_z(f,ivar1_opt,ivar2_opt)
!
!  Boundary conditions in z, except for periodic part handled by communication.
!  Remark: boundconds_x() needs to be called before communicating (because we
!  communicate the x-ghost points), boundconds_[yz] after communication
!  has finished (they need some of the data communicated for the edges
!  (yz-'corners').
!
!   8-jul-02/axel: split up into different routines for x,y and z directions
!  11-nov-02/wolf: unified bot/top, now handled by loop
!  02-apr-13/MR  : added new boundary condition 'fs' = frozen boundary value
!                  + symmetry about boundary; added 'fa' for alternative reference to
!                  already existing freezing condition (includes antisymmetry)
!  30-dec-16/MR: added BC 'a1s' for constant alpha mean-field model in one dimension
!
      use General, only: var_is_vec
      use Gravity, only: gravz_profile
      use Special, only: special_boundconds
      use EquationOfState
      !!use Energy, only: bc_ss_flux
      use Magnetic_meanfield, only: pc_aasb_const_alpha
!
      real, dimension (:,:,:,:) :: f
      integer, optional :: ivar1_opt, ivar2_opt
      real, dimension (size(f,4)) :: fbcz_zero
      integer :: ivar1, ivar2, j, topbot
      logical :: ip_ok
      type (boundary_condition) :: bc
!
      if (ldebug) print*,'boundconds_z: ENTER'
!
      ivar1=1; ivar2=min(mcom,size(f,4))
      if (present(ivar1_opt)) ivar1=ivar1_opt
      if (present(ivar2_opt)) ivar2=ivar2_opt
!
      select case (nzgrid)
!
      case (1)
        if (ldebug) print*,'boundconds_z: no z-boundary'
!
!  Boundary conditions in z
!
      case default
        do topbot=BOT,TOP                ! loop over 'bot','top'
          if (topbot==BOT) then
            ip_ok=lfirst_proc_z
          else
            ip_ok=llast_proc_z
          endif
!
          jdone=0
          do j=ivar1,ivar2
            if (ldebug) write(*,'(A,I1,A,I2,A,A)') ' bcz',topbot,'(',j,')=',bcz12(j,topbot)
            if (ip_ok) then

              is_vec = var_is_vec(j)

              select case (bcz12(j,topbot))
              case ('0')
                ! BCZ_DOC: zero value in ghost zones, free value on boundary
                call bc_zero_z(f,topbot,j)
              case ('p')
                ! BCZ_DOC: periodic
                call bc_per_z(f,topbot,j)
              case ('yy')
                ! BCZ_DOC: Yin-Yang grid
                call bc_yy_z(f,topbot,j)
              case ('s')
                ! BCZ_DOC: symmetry
                call bc_sym_z(f,+1,topbot,j)
              case ('sf')
                ! BCZ_DOC: symmetry with respect to interface
                call bc_sf_z(f,+1,topbot,j)
              case ('s0d')
                ! BCZ_DOC: symmetry, function value such that df/dz=0
                call bc_symset0der_z(f,topbot,j)
              case ('0ds')
                ! BCZ_DOC: symmetry, function value such that df/dz=0
                call bc_symset0der_z_v2(f,topbot,j)
              case ('a')
                ! BCZ_DOC: antisymmetry
                call bc_sym_z(f,-1,topbot,j)
              case ('a2')
                ! BCZ_DOC: antisymmetry relative to boundary value
                call bc_sym_z(f,-1,topbot,j,REL=.true.)
               case ('a2v')
                  ! BCZ_DOC: set boundary value and antisymmetry relative to it
                  call bc_sym_z(f,-1,topbot,j,REL=.true.,val=fbcz(:,topbot))
              case ('af')
                ! BCZ_DOC: antisymmetry with respect to interface
                call bc_sf_z(f,-1,topbot,j)
              case ('a0d')
                ! BCZ_DOC: antisymmetry with zero derivative
                fbcz_zero=0.
                call bc_sym_z(f,+1,topbot,j,VAL=fbcz_zero)
              case ('v')
                ! BCZ_DOC: vanishing third derivative
                call bc_van_z(f,topbot,j)
              case ('v3')
                ! BCZ_DOC: vanishing third derivative
                call bc_van3rd_z(f,topbot,j)
              case ('1s')
                ! BCZ_DOC: one-sided
                call set_ghosts_for_onesided_ders(f,topbot,j,3)
              case ('d1s')
                ! BCZ_DOC: onesided for 1st and 2nd derivative in two first inner points, Dirichlet in boundary point
                if (topbot==BOT) then
                  f(:,:,n1,j) = fbcz(j,topbot)
                else
                  f(:,:,n2,j) = fbcz(j,topbot)
                endif
                call set_ghosts_for_onesided_ders(f,topbot,j,3,.true.)
              case ('n1s')
                ! BCZ_DOC: onesided for 1st and 2nd derivative in two first inner points, Neumann in boundary point
                call bval_from_neumann(f,topbot,j,3,fbcz(j,topbot))
                call set_ghosts_for_onesided_ders(f,topbot,j,3,.true.)
              case ('a1s')
                ! BCZ_DOC: special for perfect conductor with const alpha and etaT when A considered as B; one-sided for 1st and 2nd derivative in two first inner points
                call pc_aasb_const_alpha(f,topbot,j)
                call set_ghosts_for_onesided_ders(f,topbot,j,3,.true.)
              case ('fg')
                ! BCZ_DOC: ``freeze'' value, i.e. maintain initial
                !  value at boundary, also mantaining the
                !  ghost zones at the initial coded value, i.e.,
                !  keep the gradient frozen as well
                call bc_freeze_var_z(topbot,j)
              case ('c1')
                ! BCZ_DOC: special boundary condition for $\ln\rho$ and $s$:
                ! BCZ_DOC: constant heat flux through the boundary
                if (j==iss) call bc_ss_flux(f,topbot)
                if (j==iaa) call bc_aa_pot(f,topbot)
                if (j==ilnTT) call bc_lnTT_flux_z(f,topbot)
              case ('c1s')
                ! BCZ_DOC: complex
                if (j==iss) call bc_ss_flux(f,topbot,.true.)
              case ('Fgs')
                ! BCZ_DOC: Fconv = - chi_t*rho*T*grad(s)
                if (j==iss) call bc_ss_flux_turb(f,topbot)
              case ('Fct')
                ! BCZ_DOC: Fbot = - K*grad(T) - chi_t*rho*T*grad(s)
                if (j==iss) call bc_ss_flux_condturb_z(f,topbot)
              case ('c3')
                ! BCZ_DOC: constant flux at the bottom with a variable hcond
                if (j==ilnTT) call bc_ADI_flux_z(f,topbot)
              case ('pfe')
                ! BCZ_DOC: potential field extrapolation
                if (j==iaa) call bc_aa_pot_field_extrapol(f,topbot)
              case ('p1D')
                ! BCZ_DOC: potential field extrapolation in 1D
                if (j==iay) call bc_aa_pot_1D(f,topbot)
              case ('pot')
                ! BCZ_DOC: potential magnetic field
                if (j==iaa) call bc_aa_pot2(f,topbot)
              case ('pwd')
                ! BCZ_DOC: a variant of 'pot' for nprocx=1
                if (j==iaa) call bc_aa_pot3(f,topbot)
              case ('d2z')
                ! BCZ_DOC:
                call bc_del2zero(f,topbot,j)
              case ('hds')
                ! BCZ_DOC: hydrostatic equilibrium with a high-frequency filter
                call bc_lnrho_hdss_z_iso(f,topbot)
              case ('cT')
                ! BCZ_DOC: constant temp.
                if (j==ilnrho) call bc_lnrho_temp_z(f,topbot)
                call bc_ss_temp_z(f,topbot)
              case ('cT1')
                ! BCZ_DOC: constant temp.
                call bc_ss_temp_z(f,topbot,.true.)
              case ('cT2')
                ! BCZ_DOC: constant temp. (keep lnrho)
                if (j==iss) call bc_ss_temp2_z(f,topbot)
              case ('cT3')
                ! BCZ_DOC: constant temp. (keep lnrho)
                if (j==iss) call bc_ss_temp3_z(f,topbot)
              case ('hs')
                ! BCZ_DOC: hydrostatic equilibrium
                if (.not. lgrav) call fatal_error('boundconds_z', &
                  'hs boundary condition requires gravity')
                if ((.not. ltemperature .or. ltemperature_nolog) .and. (gravz_profile /= 'const')) &
                  call fatal_error('boundconds_z', 'hs boundary condition requires a constant gravity profile')
                if (.not. lequidist(3)) call fatal_error('boundconds_z', &
                  'hs boundary condition requires symmetric grid distances on the z boundary')
                if ((j==ilnrho) .or. (j==irho_b) .or. (j==iss)) then
                  call bc_lnrho_hds_z_iso(f,topbot)
                elseif (j==ipp) then
                  call bc_pp_hds_z_iso(f,topbot)
                else
                  call fatal_error ('boundconds_z', "hs boundary condition requires density or pressure")
                endif
              case ('hse')
                ! BCZ_DOC: hydrostatic extrapolation
                ! BCZ_DOC: rho or lnrho is extrapolated linearily and the
                ! BCZ_DOC: temperature is calculated in hydrostatic equilibrium.
                if (.not. lgrav) &
                    call fatal_error ('boundconds_z', "'hse' requires gravity")
                if (.not. leos) call fatal_error ('boundconds_z', &
                    "'hse' requires an eos module")
                if ((ilnrho == 0) .or. (ilnTT == 0)) &
                    call fatal_error ('boundconds_z', "'hse' requires lnrho and lnTT")
                if (j == ilnTT) then
                  call bcz_hydrostatic_temp(f,topbot)
                elseif (j == ilnrho) then
                  call bcz_hydrostatic_rho(f,topbot)
                else
                  call fatal_error ('boundconds_z', "'hse' works only in lnrho or lnTT")
                endif
              case ('cp')
                ! BCZ_DOC: constant pressure
                ! BCZ_DOC:
                if (j==ilnrho) call bc_lnrho_pressure_z(f,topbot)
              case ('sT')
                ! BCZ_DOC: symmetric temp.
                ! BCZ_DOC:
                if (j==iss) call bc_ss_stemp_z(f,topbot)
              case ('ctz')
                ! BCZ_DOC: for interstellar runs copy T
                if (j==iss) call bc_ctz(f,topbot,iss)
              case ('cdz')
                ! BCZ_DOC: for interstellar runs limit rho
                call bc_cdz(f,topbot,j)
              case ('ism')
                ! BCZ_DOC: exponential decay/growth in rho/T by scale height
                call bc_ism(f,topbot,j)
              case ('asT')
                ! BCZ_DOC: select entropy for uniform ghost temperature
                ! BCZ_DOC: matching fluctuating boundary value,
                ! BCZ_DOC: $T_{N-i}=T_{N}=$;
                ! BCZ_DOC: implies $T'(x_N)=T'(x_0)=0$
                if (j==iss) call bc_ss_a2stemp_z(f,topbot)
              case ('c2')
                ! BCZ_DOC: special boundary condition for s: constant
                ! BCZ_DOC: temperature at the boundary --- requires
                ! BCZ_DOC: boundary condition 'a2' for $\ln\rho$
                if (j==iss) call bc_ss_temp_old(f,topbot)
              case ('db')
                  ! BCZ_DOC: low-order one-sided derivatives (``no boundary
                  ! BCZ_DOC: condition'') for density
                call bc_db_z(f,topbot,j)
              case ('ce')
                ! BCZ_DOC: complex
                ! BCZ_DOC:
                if (j==iss) call bc_ss_energy(f,topbot)
              case ('e1')
                ! BCZ_DOC: extrapolation
                call bc_extrap_2_1(f,topbot,j)
              case ('e2')
                ! BCZ_DOC: extrapolation
                call bc_extrap_2_2(f,topbot,j)
              case ('ex')
                ! BCZ_DOC: simple linear extrapolation in first order
                call bcz_extrapol(f,topbot,j)
              case ('exf')
                ! BCZ_DOC: simple linear extrapolation in first order
                !  with a fixed value in the first ghost cell
                call bcz_extrapol_fixed(f,topbot,j)
              case ('exd')
                ! BCZ_DOC: simple linear extrapolation in first order
                !  with an included damping to zero (useful for velocities)
                call bcz_extrapol_damped(f,topbot,j)
              case ('exm')
                ! BCZ_DOC: simple linear extrapolation in first order
                !  with an included local averaging of a 7x7 array
                call bcz_extrapol_mean(f,topbot,j)
              case ('b1')
                ! BCZ_DOC: extrapolation with zero value (improved 'a')
                call bc_extrap0_2_0(f,topbot,j)
              case ('b2')
                ! BCZ_DOC: extrapolation with zero value (improved 'a')
                call bc_extrap0_2_1(f,topbot,j)
              case ('b3')
                ! BCZ_DOC: extrapolation with zero value (improved 'a')
                call bc_extrap0_2_2(f,topbot,j)
              case ('f','fa')
                ! BCZ_DOC: freeze value + antisymmetry
                ! tell other modules not to change boundary value
                call bc_freeze_var_z(topbot,j)
                call bc_sym_z(f,-1,topbot,j,REL=.true.) ! antisymm wrt boundary
              case ('fs')
                ! BCZ_DOC: freeze value + symmetry
                ! tell other modules not to change boundary value
                call bc_freeze_var_z(topbot,j)
                call bc_sym_z(f,+1,topbot,j) ! symmetric wrt boundary
              case ('fBs')
                ! BCZ_DOC: frozen-in B-field (s)
                call bc_frozen_in_bb(topbot,j)
                call bc_sym_z(f,+1,topbot,j) ! symmetry
              case ('fB')
                ! BCZ_DOC: frozen-in B-field (a2)
                call bc_frozen_in_bb(topbot,j)
                call bc_sym_z(f,-1,topbot,j,REL=.true.) ! antisymm wrt boundary
              case ('g')
                ! BCZ_DOC: set to given value(s) or function
                 call bc_force_z(f,-1,topbot,j)
              case ('gs')
                ! BCZ_DOC:
                 call bc_force_z(f,+1,topbot,j)
              case ('1')
                ! BCZ_DOC: f=1 (for debugging)
                call bc_one_z(f,topbot,j)
              case ('StS')
                ! BCZ_DOC: solar surface boundary conditions
                if (j==ilnrho) call bc_stellar_surface(f,topbot)
              case ('set')
                ! BCZ_DOC: set boundary value
                call bc_sym_z(f,-1,topbot,j,REL=.true.,val=fbcz(:,topbot))
              case ('sep')
                ! BCY_DOC: set boundary value
                call bc_sym_z(f,-1,topbot,j,REL=.true.,val=fbcz(:,topbot),val2=fbcz_1(:,topbot),val4=fbcz_2(:,topbot))
              case ('der')
                ! BCZ_DOC: set derivative on the boundary
                call bc_set_der_z(f,topbot,j,fbcz(j,topbot))
              case ('div')
                ! BCZ_DOC: set the divergence of $\uv$ to a given value
                ! BCZ_DOC: use bc = 'div' for iuz
                call bc_set_div_z(f,topbot,j,fbcz(j,topbot))
              case ('ovr')
                ! BCZ_DOC: set boundary value
                call bc_overshoot_z(f,fbcz(:,topbot),topbot,j)
              case ('inf')
                ! BCZ_DOC: allow inflow, but no outflow
                call bc_inflow_z(f,topbot,j)
              case ('ouf')
                ! BCZ_DOC: allow outflow, but no inflow
                call bc_outflow_z(f,topbot,j)
              case ('in')
                ! BCZ_DOC: allow inflow, but no outflow
                ! BCZ_DOC: forces ghost cells and boundary to not point outwards
                call bc_inflow_z(f,topbot,j,.true.)
              case ('out')
                ! BCZ_DOC: allow outflow, but no inflow
                ! BCZ_DOC: forces ghost cells and boundary to not point inwards
                call bc_outflow_z(f,topbot,j,.true.)
              case ('crk')
                ! BCY_DOC: no-inflow: copy value of last physical point
                ! BCY_DOC: to all ghost cells, but suppressing any inflow
                call bc_copy_z_noinflow(f,topbot,j)
              case ('in0')
                ! BCZ_DOC: allow inflow, but no outflow
                ! BCZ_DOC: forces ghost cells and boundary to not point outwards
                ! BCZ_DOC: relaxes to vanishing 1st derivative at boundary
                call bc_inflow_zero_deriv_z(f,topbot,j)
              case ('ou0')
                ! BCZ_DOC: allow outflow, but no inflow
                ! BCZ_DOC: forces ghost cells and boundary to not point inwards
                ! BCZ_DOC: relaxes to vanishing 1st derivative at boundary
                call bc_outflow_zero_deriv_z(f,topbot,j)
              case ('ind')
                ! BCZ_DOC: allow inflow, but no outflow
                ! BCZ_DOC: forces ghost cells and boundary to not point outwards
                ! BCZ_DOC: creates inwards pointing or zero 1st derivative at boundary
                call bc_inflow_inwards_deriv_z(f,topbot,j)
              case ('oud')
                ! BCZ_DOC: allow outflow, but no inflow
                ! BCZ_DOC: forces ghost cells and boundary to not point inwards
                ! BCZ_DOC: creates outwards pointing or zero 1st derivative at boundary
                call bc_outflow_outwards_deriv_z(f,topbot,j)
              case ('ubs')
                ! BCZ_DOC: copy boundary outflow, reduce inflow speed outside the boundary
                call bc_steady_z(f,topbot,j)
              case ('win')
                ! BCZ_DOC: forces massflux given as
                ! BCZ_DOC: $\Sigma \rho_i ( u_i + u_0)=\textrm{fbcz1/2}(\rho)$
                if (j==ilnrho) then
                   call bc_wind_z(f,topbot,fbcz(j,topbot))
                   call bc_sym_z(f,+1,topbot,j)           !  's'
                   call bc_sym_z(f,+1,topbot,iuz)         !  's'
                endif
              case ('cop')
                ! BCZ_DOC: copy value of last physical point to all ghost cells
                call bc_copy_z(f,topbot,j)
              case ('nil')
                ! BCZ_DOC: do nothing; assume that everything is set
              case ('tay')
                call tayler_expansion(f,topbot,j,'z')
              case ('exp')
                ! BCZ_DOC: exponentiate z ghost zone of other variable
                call bc_expother_z(f,topbot,j,int(fbcz(j,topbot)))
              case ('slc')
                call set_from_slice_z(f,topbot,j)
                !call set_ghosts_for_onesided_ders(f,topbot,j,3,.true.)
                call bc_sym_z(f,-1,topbot,j,rel=.true.)
              case default
                bc%bcname=bcz12(j,topbot)
                bc%ivar=j
                bc%location=(((topbot-1)*6)-3)   ! -3/3 for z bot/top
                bc%value1=fbcz_1(j,topbot)
                bc%value2=fbcz_2(j,topbot)
                bc%done=.false.
!
                if (lspecial) call special_boundconds(f,bc)
!
                if (.not.bc%done) call fatal_error_local("boundconds_z", &
                  "no such boundary condition bcz1/2 = "//trim(bcz12(j,topbot))//" for j="//trim(itoa(j)))
              endselect
            endif
          enddo
        enddo
      endselect
!
    endsubroutine boundconds_z
!***********************************************************************
    subroutine bc_pencil_scalar(penc, ncell, nghost, bc, d2_bound, bound)
!
! Apply boundary conditions to a 1D scalar of arbitrary size.
!
! 29-may-12/ccyang: coded
!  2-apr-15/MR: optional parameters d2_bound, bound for use in stress-free 
!               and normal-field BCs added; these BCs, 'a' and 's' implemented
!
! Input/Output Arguments
!   penc - a scalar array to be applied boundary conditions
!
! Input Arguments
!   ncell - number of active cells in penc
!   nghost - number of ghost cells in penc
!   bc1 - boundary condition for the lower boundary
!   bc2 - boundary condition for the upper boundary
!   d2_bound - doubled cumulative cell sizes at boundary
!              (d2_bound(-nghost:-1) - at lower, d2_bound(1:nghost) at upper)
!   bound - boundary coordinates
!
      integer, intent(in) :: ncell, nghost
      real, dimension(1-nghost:ncell+nghost), intent(inout) :: penc
      character(len=*), dimension(2), intent(in) :: bc
      real, dimension(-nghost:nghost), optional :: d2_bound
      real, dimension(2), optional :: bound

      integer :: i
!
! Apply lower boundary condition.
!
      lower: select case (bc(1))
!     Nothing
      case ('') lower
!     Periodic
      case ('p') lower
        penc(1-nghost:0) = penc(ncell-nghost+1:ncell)
!     Zero
      case ('0') lower
        penc(1-nghost:0) = 0.0
!     Zeroth-order extrapolation
      case ('cop') lower
        penc(1-nghost:0) = penc(1)
      case ('s') lower
        penc(1-nghost:0) = penc(2:nghost+1)
      case ('a') lower
        penc(1-nghost:0) = -penc(2:nghost+1)
        penc(1) = 0.
      case ('sfr') lower
        do i=1,nghost
          penc(1-i) = penc(1+i) - penc(1)*(d2_bound(-i)/bound(BOT))
        enddo
      case ('nfr') lower
        do i=1,nghost
          penc(1-i) = penc(1+i) + penc(1)*(d2_bound(-i)/bound(BOT))
        enddo
!     Unknown boundary condition
      case default lower
        call fatal_error('bc_pencil_scalar', 'unknown lower boundary condition')
      endselect lower
!
! Apply upper boundary condition.
!
      upper: select case (bc(2))
!     Nothing
      case ('') upper
!     Periodic
      case ('p') upper
        penc(ncell+1:ncell+nghost) = penc(1:nghost)
!     Zero
      case ('0') upper
        penc(ncell+1:ncell+nghost) = 0.0
!     Zeroth-order extrapolation
      case ('cop') upper
        penc(ncell+1:ncell+nghost) = penc(ncell)
      case ('s') upper
        penc(ncell+1:ncell+nghost) = penc(ncell-nghost:ncell-1) 
      case ('a') upper
        penc(ncell+1:ncell+nghost) = -penc(ncell-nghost:ncell-1)
        penc(ncell) = 0.
      case ('sfr') upper
        do i=1,nghost
          penc(1+i) = penc(1-i) + penc(ncell)*(d2_bound(i)/bound(TOP))
        enddo
      case ('nfr') upper
        do i=1,nghost
          penc(1+i) = penc(1-i) - penc(ncell)*(d2_bound(i)/bound(TOP))
        enddo
!     Unknown boundary condition
      case default upper
        call fatal_error('bc_pencil_scalar', 'unknown upper boundary condition')
      endselect upper
!
    endsubroutine bc_pencil_scalar
!***********************************************************************
    subroutine bc_pencil_vector(penc, ncell, nghost, ncomp, bc, d2_bound, bound)
!
! Apply boundary conditions to a 1D vector of arbitrary size.
!
! 22-may-12/ccyang: coded
!  2-apr-15/MR: optional parameters d2_bound, bound for use in stress-free and normal-field BCs added
!
! Input/Output Arguments
!   penc - a vector array to be applied boundary conditions
!
! Input Arguments
!   ncell - number of active cells in penc
!   nghost - number of ghost cells in penc
!   ncomp - number of components of the vector
!   bc1 - boundary condition for the lower boundary
!   bc2 - boundary condition for the upper boundary
!
      integer, intent(in) :: ncell, nghost, ncomp
      real, dimension(1-nghost:ncell+nghost, ncomp), intent(inout) :: penc
      character(len=bclen), dimension(ncomp,2), intent(in) :: bc
      real, dimension(-nghost:nghost), optional :: d2_bound
      real, dimension(2), optional :: bound
!
      integer :: j
!
      comp: do j = 1, ncomp
        call bc_pencil_scalar(penc(:,j), ncell, nghost, bc(j,:), d2_bound, bound)
      enddo comp
!
    endsubroutine bc_pencil_vector
!***********************************************************************
    subroutine bc_per_x(f,topbot,j)
!
!  Periodic boundary condition
!
!  11-nov-02/wolf: coded
!
      real, dimension (:,:,:,:) :: f
      integer :: j
      integer, intent(IN) :: topbot
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        if (nprocx==1) f(1:l1-1,:,:,j) = f(l2i:l2,:,:,j)
!
      case(TOP)               ! top boundary
        if (nprocx==1) f(l2+1:,:,:,j) = f(l1:l1i,:,:,j)
!
      case default
        call fatal_error("bc_per_x: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_per_x
!***********************************************************************
    subroutine bc_per_y(f,topbot,j)
!
!  Periodic boundary condition
!
!  11-nov-02/wolf: coded
!
      real, dimension (:,:,:,:) :: f
      integer :: j
      integer, intent(IN) :: topbot
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        if (nprocy==1) f(:,1:m1-1,:,j) = f(:,m2i:m2,:,j)
!
      case(TOP)               ! top boundary
        if (nprocy==1) f(:,m2+1:,:,j) = f(:,m1:m1i,:,j)
!
      case default
        call fatal_error("bc_per_y: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_per_y
!***********************************************************************
    subroutine bc_yy_y(f,topbot,j)
!
!  After-communication transformation of vector quantities for Yin-Yang grid.
!
!  30-nov-15/MR: coded
!
      use General, only: transform_cart_spher

      real, dimension (:,:,:,:) :: f
      integer :: j
      integer, intent(IN) :: topbot
!
      if (.not.lyinyang) &
        call fatal_error_local('bc_yy_y','BC not legal as no Yin-Yang grid run.')

      if (j<=jdone) return

      if (is_vec) then
!
!  Vector quantities need to be transformed from the Cartesian basis to 
!  the local spherical basis.
!
        jdone=j+2     ! requires adjacent vector components
        if (topbot==BOT) then
          call transform_cart_spher(f,1,nghost,1,mz,j)    ! in-place!
        else
          call transform_cart_spher(f,m2+1,my,1,mz,j)     !  ~
        endif
!
      else
        jdone=0
      endif

    endsubroutine bc_yy_y
!***********************************************************************
    subroutine bc_pper_y(f,sgn,topbot,j)
!
!  Periodic boundary condition across the pole
!
!  15-jun-10/dhruba: aped
!  15-oct-15/fred NB use sgn= 1 for scalars and radial vector components
!                        sgn=-1 for theta and phi vector components
!            In principle similar conditions could apply for R=0
!            for sph/cyl coords, but not yet implemented
!
      real, dimension (:,:,:,:) :: f
      integer :: j,nhalf,sgn
      integer, intent(IN) :: topbot
!
      if (.not.lpole(2)) call fatal_error_local('bc_pper_y',&
        "for 'p' lpole=F,T,F , lperi=F,F,T in start.in")
      if (nprocz>1 .and. modulo(nprocz,2)==1) &
        call fatal_error_local('bc_pper_y',&
             "for 'pp' nprocz must be multiple of 2")
!
      nhalf=(n1+n2)/2
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        if (nprocz==1) then
          f(:,:m1-1,n1:nhalf  ,j) = sgn*f(:,m1i:m1:-1,nhalf+1:n2,j)
          f(:,:m1-1,nhalf+1:n2,j) = sgn*f(:,m1i:m1:-1,n1:nhalf  ,j)
        endif
      case(TOP)               ! top boundary
        if (nprocz==1) then
          f(:,m2+1:,n1:nhalf  ,j) = sgn*f(:,m2:m2i:-1,nhalf+1:n2,j)
          f(:,m2+1:,nhalf+1:n2,j) = sgn*f(:,m2:m2i:-1,n1:nhalf  ,j)
        endif
      case default
        call fatal_error("bc_pper_y: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_pper_y
!***********************************************************************
    subroutine bc_per_z(f,topbot,j)
!
!  Periodic boundary condition
!
!  11-nov-02/wolf: coded
!
      real, dimension (:,:,:,:) :: f
      integer :: j
      integer, intent(IN) :: topbot
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        if (nprocz==1) f(:,:,1:n1-1,j) = f(:,:,n2i:n2,j)
!
      case(TOP)               ! top boundary
        if (nprocz==1) f(:,:,n2+1:,j) = f(:,:,n1:n1i,j)
!
      case default
        call fatal_error("bc_per_z: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_per_z
!***********************************************************************
    subroutine bc_yy_z(f,topbot,j)
!
!  After-communication handling of vector quantities for Yin-Yang grid.
!
!  30-nov-15/MR: coded
!  29-feb-16/MR: avoided double transformation in ghost zone corners 
!                which is already done in bc_yy_y
!
      use General, only: transform_cart_spher

      real, dimension (:,:,:,:) :: f
      integer :: j
      integer, intent(IN) :: topbot

      integer :: iya, iye
!
      if (.not.lyinyang) &
        call fatal_error_local('bc_yy_z','BC not legal as no Yin-Yang grid run.')

      if (j<=jdone) return

      if (is_vec) then
!
!  Vector quantities need to be transformed from the Cartesian basis to 
!  the local spherical basis.
!
        jdone=j+2     ! requires adjacent vector components

        iya=1; iye=my          
        if (lfirst_proc_y) iya=m1
        if (llast_proc_y) iye=m2
      
        if (topbot==BOT) then
          call transform_cart_spher(f,iya,iye,1,nghost,j)  ! in-place!
        else
          call transform_cart_spher(f,iya,iye,n2+1,mz,j)   ! ~  
        endif
      else
        jdone=0
      endif

    endsubroutine bc_yy_z
!***********************************************************************
    subroutine bc_a2r_x(f,topbot,j)
!
!  Setting d^2f/dr^2 + 2*/r*df/dr - 2*f/r^2 =0,
!  to set del2=0 in spherical coordinates.
!
!  24-nov-12/joern: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real :: tmp1,tmp2
      integer ::j
!
      select case (topbot)
!
      case(BOT)  ! bottom boundary
!
        tmp1=dx_1(l1)**2
        tmp2=dx_1(l1)*(1./x(l1)+dx_tilde(l1)/2.)
!
        f(l1-1,:,:,j)=(f(l1,:,:,j)*(-2*tmp1-2/x(l1)**2) &
                      +f(l1+1,:,:,j)*(tmp1+tmp2)) &
                      /(-1*tmp1+tmp2)
        f(l1-2,:,:,j)=(f(l1-1,:,:,j)*16*(tmp1-tmp2) &
                      +f(l1,:,:,j)*(-30*tmp1-24/x(l1)**2) &
                      +f(l1+1,:,:,j)*16*(tmp1+tmp2) &
                      +f(l1+2,:,:,j)*(-1*tmp1-2*tmp2)) &
                      /(tmp1-2*tmp2)
        f(l1-3,:,:,j)=(f(l1-2,:,:,j)*27*(-1*tmp1+2*tmp2) &
                      +f(l1-1,:,:,j)*270*(tmp1-tmp2) &
                      +f(l1,:,:,j)*(-490*tmp1-360/x(l1)**2) &
                      +f(l1+1,:,:,j)*270*(tmp1+tmp2) &
                      +f(l1+2,:,:,j)*27*(-1*tmp1-2*tmp2) &
                      +f(l1+3,:,:,j)*(2*tmp1+6*tmp2)) &
                      /(-2*tmp1+6*tmp2)
!
      case(TOP)               ! top boundary
!
        tmp1=dx_1(l2)**2
        tmp2=dx_1(l2)*(1/x(l2)+dx_tilde(l2)/2.)
!
        f(l2+1,:,:,j)=(f(l2,:,:,j)*(-2*tmp1-2/x(l2)**2) &
                      +f(l2-1,:,:,j)*(tmp1-tmp2)) &
                      /(-1*tmp1-tmp2)
        f(l2+2,:,:,j)=(f(l2+1,:,:,j)*16*(tmp1+tmp2) &
                      +f(l2,:,:,j)*(-30*tmp1-24/x(l2)**2) &
                      +f(l2-1,:,:,j)*16*(tmp1-tmp2) &
                      +f(l2-2,:,:,j)*(-1*tmp1+2*tmp2)) &
                      /(tmp1+2*tmp2)
        f(l2+3,:,:,j)=(f(l2+2,:,:,j)*27*(-1*tmp1-2*tmp2) &
                      +f(l2+1,:,:,j)*270*(tmp1+tmp2) &
                      +f(l2,:,:,j)*(-490*tmp1-360/x(l2)**2) &
                      +f(l2-1,:,:,j)*270*(tmp1-tmp2) &
                      +f(l2-2,:,:,j)*27*(-1*tmp1+2*tmp2) &
                      +f(l2-3,:,:,j)*(2*tmp1-6*tmp2)) &
                      /(-2*tmp1-6*tmp2)
      case default
        call fatal_error("bc_a2r_x: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_a2r_x
!***********************************************************************
    subroutine bc_sym_x(f,sgn,topbot,j,rel,val)
!
!  Symmetry boundary conditions.
!  (f,-1,topbot,j)            --> antisymmetry             (f  =0)
!  (f,+1,topbot,j)            --> symmetry                 (f' =0)
!  (f,-1,topbot,j,REL=.true.) --> generalized antisymmetry (f''=0)
!  Don't combine rel=T and sgn=1, that wouldn't make much sense.
!
!  11-nov-02/wolf: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real, dimension (:), optional :: val
      integer :: sgn,i,j
      logical, optional :: rel
      logical :: relative
!
      if (present(rel)) then; relative=rel; else; relative=.false.; endif
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        if (present(val)) f(l1,:,:,j)=val(j)
        if (relative) then
          do i=1,nghost; f(l1-i,:,:,j)=2*f(l1,:,:,j)+sgn*f(l1+i,:,:,j); enddo
        else
          do i=1,nghost; f(l1-i,:,:,j)=              sgn*f(l1+i,:,:,j); enddo
          if (sgn<0) f(l1,:,:,j) = 0. ! set bdry value=0 (indep of initcond)
        endif
!
      case(TOP)               ! top boundary
        if (present(val)) f(l2,:,:,j)=val(j)
        if (relative) then
          do i=1,nghost; f(l2+i,:,:,j)=2*f(l2,:,:,j)+sgn*f(l2-i,:,:,j); enddo
        else
          do i=1,nghost; f(l2+i,:,:,j)=              sgn*f(l2-i,:,:,j); enddo
          if (sgn<0) f(l2,:,:,j) = 0. ! set bdry value=0 (indep of initcond)
        endif
!
      case default
        call fatal_error("bc_sym_x: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_sym_x
!***********************************************************************
    subroutine bc_sym_x_ydep(f,sgn,topbot,j,rel,val)
!
!  Symmetry boundary conditions.
!  (f,-1,topbot,j)            --> antisymmetry             (f  =0)
!  (f,+1,topbot,j)            --> symmetry                 (f' =0)
!  (f,-1,topbot,j,REL=.true.) --> generalized antisymmetry (f''=0)
!  Don't combine rel=T and sgn=1, that wouldn't make much sense.
!
!  11-nov-02/wolf: coded
!  18-feb-24/axel: adapted from bc_sym_x to model Comisso+15; use -cos instead of +cos(ky).
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real, dimension (:), optional :: val
      integer :: sgn,i,j
      logical, optional :: rel
      logical :: relative
!
      real :: ky
!
      ky=2.*pi/Lxyz(2)
!
      if (present(rel)) then; relative=rel; else; relative=.false.; endif
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        if (present(val)) f(l1,:,:,j)=-.5-val(j)*spread(cos(ky*y),2,mz)
        if (relative) then
          do i=1,nghost; f(l1-i,:,:,j)=2*f(l1,:,:,j)+sgn*f(l1+i,:,:,j); enddo
        else
          do i=1,nghost; f(l1-i,:,:,j)=              sgn*f(l1+i,:,:,j); enddo
          if (sgn<0) f(l1,:,:,j) = 0. ! set bdry value=0 (indep of initcond)
        endif
!
      case(TOP)               ! top boundary
        if (present(val)) f(l2,:,:,j)=-.5-val(j)*spread(cos(ky*y),2,mz)
        if (relative) then
          do i=1,nghost; f(l2+i,:,:,j)=2*f(l2,:,:,j)+sgn*f(l2-i,:,:,j); enddo
        else
          do i=1,nghost; f(l2+i,:,:,j)=              sgn*f(l2-i,:,:,j); enddo
          if (sgn<0) f(l2,:,:,j) = 0. ! set bdry value=0 (indep of initcond)
        endif
!
      case default
        call fatal_error("bc_sym_x_ydep: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_sym_x_ydep
!***********************************************************************
    subroutine bc_cpc_x(f,topbot,j)
!
!  This condition gives A"+A'/R=0.
!  We compute the A1 point using a 2nd-order formula,
!  i.e. A1 = - (1-dx/2R)*A_(-1)/(1+x/2R).
!  Next, we compute A2 using a 4th-order formula,
!  and finally A3 using a 6th-order formula.
!  this can not be used in the setup for -a ..a with cpc on both sides,
!  for both sides A=0 on the boundary does for example not allow a constant Bz
!  removed this restriction in cpp
!  note that for A!=0 boundary conditions for Aphi and Az are not the same,
!  hence cpz
!
!  11-nov-09/axel+koen: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real, dimension (size(f,2),size(f,3)) :: extra1,extra2
      integer :: i,j
      real :: dxR
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        dxR=-dx/x(l1)
        i=-0; f(l2+i,:,:,j)=0.
        i=-1; f(l2+i,:,:,j)=-(1.-.5*dxR)*f(l2-i,:,:,j)/(1.+.5*dxR)
        extra1=(1.+.5*dxR)*f(l2+i,:,:,j)+(1.-.5*dxR)*f(l2-i,:,:,j)
        i=-2; f(l2+i,:,:,j)=(-(1.-   dxR)*f(l2-i,:,:,j)+16.*extra1)/(1.+dxR)
        extra2=(1.+dxR)*f(l2+i,:,:,j)+(1.-dxR)*f(l2-i,:,:,j)-10.*extra1
        i=-3; f(l2+i,:,:,j)=(-(2.-3.*dxR)*f(l2-i,:,:,j)+27.*extra2)/(2.+3.*dxR)
!
      case(TOP)               ! top boundary
        dxR=-dx/x(l2)
        i=0; f(l2+i,:,:,j)=0.
        i=1; f(l2+i,:,:,j)=-(1.-.5*dxR)*f(l2-i,:,:,j)/(1.+.5*dxR)
        extra1=(1.+.5*dxR)*f(l2+i,:,:,j)+(1.-.5*dxR)*f(l2-i,:,:,j)
        i=2; f(l2+i,:,:,j)=(-(1.-   dxR)*f(l2-i,:,:,j)+16.*extra1)/(1.+dxR)
        extra2=(1.+dxR)*f(l2+i,:,:,j)+(1.-dxR)*f(l2-i,:,:,j)-10.*extra1
        i=3; f(l2+i,:,:,j)=(-(2.-3.*dxR)*f(l2-i,:,:,j)+27.*extra2)/(2.+3.*dxR)
!
      case default
        call fatal_error("bc_cpc_x: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_cpc_x
!***********************************************************************
    subroutine bc_cpz_x(f,topbot,j)
!
!  This condition gives R(RA)"-(RA)'=0, i e perfect conductor condition
!  for Az in cylindrical coordinates.
!  We compute the A1 point using a 2nd-order formula,
!  Next, we compute A2 using a 4th-order formula,
!  and finally A3 using a 6th-order formula.
!
!  28-feb-11/koen: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real, dimension (size(f,2),size(f,3)) :: f1_co,f2_co
      integer :: i,j
      real :: dxR
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        dxR=dx/x(l1)
        i=-1; f(l1+i,:,:,j)=(f(l1,:,:,j)*2+f(l1-i,:,:,j)*(dxR/2-1))/(dxR/2+1)
        f1_co=(1+dxR/2)*f(l1+i,:,:,j)+(1-dxR/2)*f(l1-i,:,:,j)
        i=-2; f(l1+i,:,:,j)=(-30*f(l1,:,:,j)+16*f1_co+(dxR-1)*f(l1-i,:,:,j))/(dxR+1)
        f2_co=(1+dxR)*f(l1+i,:,:,j)+(1-dxR)*f(l1-i,:,:,j)
        i=-3; f(l1+i,:,:,j)=(490*f(l1,:,:,j)-270*f1_co+27*f2_co+(3*dxR-2)*f(l1-i,:,:,j))/(3*dxR+2)
!
      case(TOP)               ! top boundary
        dxR=dx/x(l2)
        i=1; f(l2+i,:,:,j)=(f(l2,:,:,j)*(2+dxR**2)+f(l2-i,:,:,j)*(dxR/2-1))/(dxR/2+1)
        f1_co=(1+dxR/2)*f(l2+i,:,:,j)+(1-dxR/2)*f(l2-i,:,:,j)
        i=2; f(l2+i,:,:,j)=(-30*f(l2,:,:,j)+16*f1_co+(dxR-1)*f(l2-i,:,:,j))/(dxR+1)
        f2_co=(1+dxR)*f(l2+i,:,:,j)+(1-dxR)*f(l2-i,:,:,j)
        i=3; f(l2+i,:,:,j)=(490*f(l2,:,:,j)-270*f1_co+27*f2_co+(3*dxR-2)*f(l2-i,:,:,j))/(3*dxR+2)
!
      case default
        call fatal_error("bc_cpz_x: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_cpz_x
!***********************************************************************
    subroutine bc_cpp_x(f,topbot,j)
!
!  This condition gives RA"+A'=0, i e perfect conductor condition
!  for Aphi in cylindrical coordinates.
!  We compute the A1 point using a 2nd-order formula,
!  i.e. A1 = - (1-dx/2R)*A_(-1)/(1+x/2R).
!  Next, we compute A2 using a 4th-order formula,
!  and finally A3 using a 6th-order formula.
!
!  28-feb-11/koen: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real, dimension (size(f,2),size(f,3)) :: f1_co,f2_co
      integer :: i,j
      real :: dxR
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        dxR=dx/x(l1)
        i=-1; f(l1+i,:,:,j)=(f(l1,:,:,j)*(2+dxR**2)+f(l1-i,:,:,j)*(dxR/2-1))/(dxR/2+1)
        f1_co=(1+dxR/2)*f(l1+i,:,:,j)+(1-dxR/2)*f(l1-i,:,:,j)
        i=-2; f(l1+i,:,:,j)=((-30+12*dxR**2)*f(l1,:,:,j)+16*f1_co+(dxR-1)*f(l1-i,:,:,j))/(dxR+1)
        f2_co=(1+dxR)*f(l1+i,:,:,j)+(1-dxR)*f(l1-i,:,:,j)
        i=-3; f(l1+i,:,:,j)=((490+180*dxR**2)*f(l1,:,:,j)-270*f1_co+27*f2_co+(3*dxR-2)*f(l1-i,:,:,j))/(3*dxR+2)
!
      case(TOP)               ! top boundary
        dxR=dx/x(l2)
        i=1; f(l2+i,:,:,j)=(f(l2,:,:,j)*(2+dxR**2)+f(l2-i,:,:,j)*(dxR/2-1))/(dxR/2+1)
        f1_co=(1+dxR/2)*f(l2+i,:,:,j)+(1-dxR/2)*f(l2-i,:,:,j)
        i=2; f(l2+i,:,:,j)=((-30+12*dxR**2)*f(l2,:,:,j)+16*f1_co+(dxR-1)*f(l2-i,:,:,j))/(dxR+1)
        f2_co=(1+dxR)*f(l2+i,:,:,j)+(1-dxR)*f(l2-i,:,:,j)
        i=3; f(l2+i,:,:,j)=((490+180*dxR**2)*f(l2,:,:,j)-270*f1_co+27*f2_co+(3*dxR-2)*f(l2-i,:,:,j))/(3*dxR+2)
!
      case default
        call fatal_error("bc_cpp_x: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_cpp_x

!!***********************************************************************
!    subroutine bc_spr_x(f,topbot,j)
!!
!!  This condition sets values for A_phi and A_theta at the radial boundary.
!!  It solves  A"+2A'/R=0 and A=0 at the boundary.
!!  We compute the A1 point using a 2nd-order formula,
!!  Next, we compute A2 using a 4th-order formula,
!!  and finally A3 using a 6th-order formula.
!!  Has to be used togehter with 's' for A_r.
!!
!!  15-may-13/joern: coded
!!
!      integer, intent(IN) :: topbot
!      real, dimension (:,:,:,:) :: f
!      integer :: j
!      real :: tmp
!!
!      select case (topbot)
!!
!      case(BOT)               ! bottom boundary
!        tmp=x(l1)*dx_1(l1)
!!
!        f(l1,:,:,j)  =0
!        f(l1-1,:,:,j)=(f(l1+1,:,:,j)*(-tmp+1))/(tmp+1)
!        f(l1-2,:,:,j)=(f(l1-1,:,:,j)*16*(tmp-1) &
!                      +f(l1+1,:,:,j)*16*(tmp+1) &
!                      +f(l1+2,:,:,j)*(-tmp-2))/(tmp-2)
!        f(l1-3,:,:,j)=(f(l1-2,:,:,j)*27*(0.5*tmp-1) &
!                      +f(l1-1,:,:,j)*135*(-tmp+1) &
!                      +f(l1+1,:,:,j)*135*(-tmp-1) &
!                      +f(l1+2,:,:,j)*27*(0.5*tmp+1) &
!                      +f(l1+3,:,:,j)*(-tmp-3))/(tmp-3)
!!
!      case(TOP)               ! top boundary
!        tmp=x(l2)*dx_1(l2)
!!
!        f(l2,:,:,j)  =0
!        f(l2+1,:,:,j)=(f(l2-1,:,:,j)*(tmp+1))/(-tmp+1)
!        f(l2+2,:,:,j)=(f(l2+1,:,:,j)*16*(tmp+1) &
!                      +f(l2-1,:,:,j)*16*(tmp-1) &
!                      +f(l2-2,:,:,j)*(tmp-2))/(-tmp-2)
!        f(l2+3,:,:,j)=(f(l2+2,:,:,j)*27*(0.5*tmp+1) &
!                      +f(l2+1,:,:,j)*135*(-tmp-1) &
!                      +f(l2-1,:,:,j)*135*(-tmp+1) &
!                      +f(l2-2,:,:,j)*27*(0.5*tmp-1) &
!                      +f(l2-3,:,:,j)*(-tmp+3))/(tmp+3)
!!
!      case default
!        call fatal_error("bc_spr_x: ","topbot should be BOT or TOP")
!!
!      endselect
!!
!    endsubroutine bc_spr_x
!!***********************************************************************
    subroutine bc_spr_x(f,topbot,j)
!
!  This condition sets values for A_phi and A_theta at the radial boundary.
!  It solves  A"+2A'/R=0 and A=0 at the boundary (A stands for A_phi or A_theta).
!  Has to be used together with 's' for A_r.
!
!  09-may-16/fred: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: ix,j
!
      if (.not.lspherical_coords) &
        call fatal_error('bc_spr_x','only implemented for spherical coordinates')
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
!
        f(l1,:,:,j) = 0.
        do ix=1,nghost
          f(l1-ix,:,:,j) = -f(l1+ix,:,:,j)*x(l1+ix)/x(l1-ix)
        enddo
!
      case(TOP)               ! top boundary
!
        f(l2,:,:,j) = 0.
        do ix=1,nghost
          f(l2+ix,:,:,j) = -f(l2-ix,:,:,j)*x(l1-ix)/x(l1+ix)
        enddo
!
      case default
        call fatal_error("bc_spr_x: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_spr_x
!***********************************************************************
    subroutine bc_symset_x(f,sgn,topbot,j,rel,val)
!
!  This routine works like bc_sym_x, but sets the function value to val
!
!  Symmetry boundary conditions.
!  (f,-1,topbot,j)            --> antisymmetry             (f  =0)
!  (f,+1,topbot,j)            --> symmetry                 (f' =0)
!  (f,-1,topbot,j,REL=.true.) --> generalized antisymmetry (f''=0)
!  Don't combine rel=T and sgn=1, that wouldn't make much sense.
!
!  11-nov-02/wolf: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real, dimension (:), optional :: val
      integer :: sgn,i,j
      logical, optional :: rel
      logical :: relative
!
      if (present(rel)) then; relative=rel; else; relative=.false.; endif
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        if (present(val)) f(l1,m1:m2,n1:n2,j)=val(j)
        if (relative) then
          do i=1,nghost; f(l1-i,:,:,j)=2*f(l1,:,:,j)+sgn*f(l1+i,:,:,j); enddo
        else
          do i=1,nghost; f(l1-i,:,:,j)=              sgn*f(l1+i,:,:,j); enddo
          !f(l1,:,:,j)=(4.*f(l1+1,:,:,j)-f(l1+2,:,:,j))/3.
        endif
!
      case(TOP)               ! top boundary
        if (present(val)) f(l2,m1:m2,n1:n2,j)=val(j)
        if (relative) then
          do i=1,nghost; f(l2+i,:,:,j)=2*f(l2,:,:,j)+sgn*f(l2-i,:,:,j); enddo
        else
          do i=1,nghost; f(l2+i,:,:,j)=              sgn*f(l2-i,:,:,j); enddo
          !f(l2,:,:,j)=(4.*f(l2-1,:,:,j)-f(l2-2,:,:,j))/3.
        endif
!
      case default
        call fatal_error("bc_symset_x: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_symset_x
!***********************************************************************
    subroutine bc_symderset_x(f,topbot,j,val)
!
!  This routine works like bc_sym_y, but sets the derivative value
!
!  30-may-11/axel: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real, dimension (:) :: val
      integer :: i,j
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        do i=1,nghost; f(l1-i,:,:,j)=f(l1+i,:,:,j)-dx2_bound(-i)*val(j); enddo
!
      case(TOP)               ! top boundary
        do i=1,nghost; f(l2+i,:,:,j)=f(l2-i,:,:,j)+dx2_bound( i)*val(j); enddo
!
      case default
        call fatal_error("bc_symderset_x: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_symderset_x
!***********************************************************************
    subroutine bc_symset0der_x(f,topbot,j)
!
!  This routine works like bc_sym_x, but sets the function value to what
!  it should be for vanishing one-sided derivative.
!  This is the routine to be used as regularity condition on the axis.
!
!  12-nov-09/axel+koen: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: i,j,i1=1,i2=2,i3=3,i4=4,i5=5,i6=6
!
      select case (topbot)
!
!  bottom (left end of the domain)
!
      case(BOT)               ! bottom boundary
        f(l1,m1:m2,n1:n2,j)=(360.*f(l1+i1,m1:m2,n1:n2,j) &
                            -450.*f(l1+i2,m1:m2,n1:n2,j) &
                            +400.*f(l1+i3,m1:m2,n1:n2,j) &
                            -225.*f(l1+i4,m1:m2,n1:n2,j) &
                             +72.*f(l1+i5,m1:m2,n1:n2,j) &
                             -10.*f(l1+i6,m1:m2,n1:n2,j))/147.
        do i=1,nghost; f(l1-i,:,:,j)=f(l1+i,:,:,j); enddo
!
!  top (right end of the domain)
!
      case(TOP)               ! top boundary
        f(l2,m1:m2,n1:n2,j)=(360.*f(l2-i1,m1:m2,n1:n2,j) &
                            -450.*f(l2-i2,m1:m2,n1:n2,j) &
                            +400.*f(l2-i3,m1:m2,n1:n2,j) &
                            -225.*f(l2-i4,m1:m2,n1:n2,j) &
                             +72.*f(l2-i5,m1:m2,n1:n2,j) &
                             -10.*f(l2-i6,m1:m2,n1:n2,j))/147.
        do i=1,nghost; f(l2+i,:,:,j)=f(l2-i,:,:,j); enddo
!
      case default
        call fatal_error("bc_symset0der_x: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_symset0der_x
!***********************************************************************
    subroutine bc_slope_x(f,slope,topbot,j,rel,val)
!
! FIXME: Documentation is missing => Axel?
! WARNING: the code for "rel=.true." is currently nowhere used.
!
!  25-feb-07/axel: adapted from bc_sym_x
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real, dimension (:), optional :: val
      real, dimension (:) :: slope
      integer :: i,j
      logical, optional :: rel
      logical :: relative
!
      if (present(rel)) then; relative=rel; else; relative=.false.; endif
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        if (present(val)) f(l1,m1:m2,n1:n2,j)=val(j)
        if (relative) then
          do i=1,nghost
            f(l1-i,:,:,j)=2*f(l1,:,:,j)+slope(j)*f(l1+i,:,:,j)*x(l1+i)/x(l1-i)
          enddo
        else
          do i=1,nghost
            f(l1-i,:,:,j)=f(l1+i,:,:,j)*(x(l1+i)/x(l1-i))**slope(j)
          enddo
!         f(l1,:,:,j)=(2.*x(l1+1)*f(l1+1,:,:,j)-&
!          .5*x(l1+2)*f(l1+2,:,:,j))/(1.5*x(l1))
        endif
!
      case(TOP)               ! top boundary
        if (present(val)) f(l2,m1:m2,n1:n2,j)=val(j)
        if (relative) then
          do i=1,nghost
            f(l2+i,:,:,j)=2*f(l2,:,:,j)+slope(j)*f(l2-i,:,:,j)
          enddo
        else
          do i=1,nghost
            f(l2+i,:,:,j)=f(l2-i,:,:,j)*(x(l2-i)/x(l2+i))**slope(j)
          enddo
!         f(l2,:,:,j)=(2.*x(l2-1)*f(l2-1,:,:,j)-&
!           .5*x(l2-2)*f(l2-2,:,:,j))/(1.5*x(l2))
        endif
!
      case default
        call fatal_error("bc_slope_x: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_slope_x
!***********************************************************************
    subroutine bc_ghost_slope_x(f,slope,topbot,j)
!
!  This maintains a constant slope within the ghost cells.
!
!  02-Sep-2017/PABourdin: coded as a replacement for 'bc_slope_x'
!
      real, dimension(:,:,:,:), intent(inout) :: f
      real, dimension(:), intent(in) :: slope
      integer, intent(IN) :: topbot
      integer, intent(in) :: j
!
      integer :: i
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        do i = 1, nghost
          f(l1-i,:,:,j) = f(l1,:,:,j) + slope(j) * (x(l1-i) - x(l1))
        enddo
!
      case(TOP)               ! top boundary
        do i = 1, nghost
          f(l2+i,:,:,j) = f(l2,:,:,j) + slope(j) * (x(l2+i) - x(l2))
        enddo
!
      case default
        call fatal_error("bc_ghost_slope_x: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_ghost_slope_x
!***********************************************************************
    subroutine bc_shear_x(f,slope,abscissa,topbot,j)
!
!  This maintains a constant shear proportional to x at the boundary.
!
!  02-Sep-2017/PABourdin: coded
!
      real, dimension(:,:,:,:), intent(inout) :: f
      real, dimension(:), intent(in) :: slope, abscissa
      integer, intent(IN) :: topbot
      integer, intent(in) :: j
!
      integer :: i
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        do i = 1, nghost
          f(l1-i,:,:,j) = abscissa(j) + slope(j) * x(l1-i)
        enddo
!
      case(TOP)               ! top boundary
        do i = 1, nghost
          f(l2+i,:,:,j) = abscissa(j) + slope(j) * x(l2+i)
        enddo
!
      case default
        call fatal_error("bc_shear_x: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_shear_x
!***********************************************************************
    subroutine bc_shear_y(f,slope,abscissa,topbot,j)
!
!  This maintains a constant shear proportional to y at the boundary.
!
!  04-Sep-2017/PABourdin: coded
!
      real, dimension(:,:,:,:), intent(inout) :: f
      real, dimension(:), intent(in) :: slope, abscissa
      integer, intent(IN) :: topbot
      integer, intent(in) :: j
!
      integer :: i
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        do i = 1, nghost
          f(:,m1-i,:,j) = abscissa(j) + slope(j) * y(m1-i)
        enddo
!
      case(TOP)               ! top boundary
        do i = 1, nghost
          f(:,m2+i,:,j) = abscissa(j) + slope(j) * y(m2+i)
        enddo
!
      case default
        call fatal_error("bc_shear_y: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_shear_y
!***********************************************************************
    subroutine bc_shear_z(f,slope,abscissa,topbot,j)
!
!  This maintains a constant shear proportional to z at the boundary.
!
!  04-Sep-2017/PABourdin: coded
!
      real, dimension(:,:,:,:), intent(inout) :: f
      real, dimension(:), intent(in) :: slope, abscissa
      integer, intent(IN) :: topbot
      integer, intent(in) :: j
!
      integer :: i
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        do i = 1, nghost
          f(:,:,n1-i,j) = abscissa(j) + slope(j) * z(n1-i)
        enddo
!
      case(TOP)               ! top boundary
        do i = 1, nghost
          f(:,:,n2+i,j) = abscissa(j) + slope(j) * z(n2+i)
        enddo
!
      case default
        call fatal_error("bc_shear_z: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_shear_z
!***********************************************************************
    subroutine bc_dr0_x(f,slope,topbot,j,rel,val)
!
! FIXME: This documentation is almost certainly wrong
!
!  Symmetry boundary conditions.
!  (f,-1,topbot,j)            --> antisymmetry             (f  =0)
!  (f,+1,topbot,j)            --> symmetry                 (f' =0)
!  (f,-1,topbot,j,REL=.true.) --> generalized antisymmetry (f''=0)
!  Don't combine rel=T and sgn=1, that wouldn't make much sense.
!
!  25-feb-07/axel: adapted from bc_sym_x
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real, dimension (:), optional :: val
      real, dimension (:) :: slope
      integer :: i,j
      ! Abbreviations to keep compiler from complaining in 1-d or 2-d:
      integer :: l1_4, l1_5, l1_6
      integer :: l2_4, l2_5, l2_6
      logical, optional :: rel
      logical :: relative
!
      l1_4=l1+4; l1_5=l1+5; l1_6=l1+6
      l2_4=l2-4; l2_5=l2-5; l2_6=l2-6
!
      if (present(rel)) then; relative=rel; else; relative=.false.; endif
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        if (present(val)) f(l1,m1:m2,n1:n2,j)=val(j)
        if (relative) then
          do i=1,nghost
            f(l1-i,:,:,j)=2*f(l1,:,:,j)+slope(j)*f(l1+i,:,:,j)*x(l1+i)/x(l1-i)
          enddo
        else
          f(l1,:,:,j)=(360.*x(l1+1)*f(l1+1,:,:,j)-450.*x(l1+2)*f(l1+2,:,:,j) &
                      +400.*x(l1+3)*f(l1+3,:,:,j)-225.*x(l1_4)*f(l1_4,:,:,j) &
                       +72.*x(l1_5)*f(l1_5,:,:,j)- 10.*x(l1_6)*f(l1_6,:,:,j) &
                      )/(147.*x(l1))
          do i=1,nghost
            f(l1-i,:,:,j)=f(l1+i,:,:,j)+dx2_bound(-i)/x(l1)*f(l1,:,:,j)
          enddo
        endif
!
      case(TOP)               ! top boundary
        if (present(val)) f(l2,m1:m2,n1:n2,j)=val(j)
        if (relative) then
          do i=1,nghost
            f(l2+i,:,:,j)=2*f(l2,:,:,j)+slope(j)*f(l2-i,:,:,j)
          enddo
        else
          f(l2,:,:,j)=(360.*x(l2-1)*f(l2-1,:,:,j)-450.*x(l2-2)*f(l2-2,:,:,j) &
                      +400.*x(l2-3)*f(l2-3,:,:,j)-225.*x(l2_4)*f(l2_4,:,:,j) &
                       +72.*x(l2_5)*f(l2_5,:,:,j)- 10.*x(l2_6)*f(l2_6,:,:,j) &
                      )/(147.*x(l2))
          do i=1,nghost
            f(l2+i,:,:,j)=f(l2-i,:,:,j)-dx2_bound(i)/x(l2)*f(l2,:,:,j)
          enddo
        endif
!
      case default
        call fatal_error("bc_dr0_x: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_dr0_x
!***********************************************************************
    subroutine bc_overshoot_x(f,dist,topbot,j)
!
!  Overshoot boundary conditions, ie (d/dx-1/dist) f = 0.
!  Is implemented as d/dx [ f*exp(-x/dist) ] = 0,
!  so f(l1-i)*exp[-x(l1-i)/dist] = f(l1+i)*exp[-x(l1+i)/dist],
!  or f(l1-i) = f(l1+i)*exp{[x(l1-i)-x(l1+i)]/dist}.
!
!  25-feb-07/axel: adapted from bc_sym_x
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real, dimension (:) :: dist
      integer :: i,j
!
      select case (topbot)
!
!  bottom
!
      case(BOT)               ! bottom boundary
        do i=1,nghost
          f(l1-i,:,:,j)=f(l1+i,:,:,j)*exp(-dx2_bound(-i)/dist(j))
        enddo
!
!  top
!
      case(TOP)               ! top boundary
        do i=1,nghost
          f(l2+i,:,:,j)=f(l2-i,:,:,j)*exp(dx2_bound(i))/dist(j)
        enddo
!
!  default
!
      case default
        call fatal_error("bc_overshoot_x: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_overshoot_x
!***********************************************************************
    subroutine bc_overshoot_z(f,dist,topbot,j)
!
!  Overshoot boundary conditions, ie (d/dz-1/dist) f = 0.
!  Is implemented as d/dz [ f*exp(-z/dist) ] = 0,
!  so f(n1-i)*exp[-z(n1-i)/dist] = f(n1+i)*exp[-z(n1+i)/dist],
!  or f(n1-i) = f(n1+i)*exp{[z(n1-i)-z(n1+i)]/dist}.
!
!  25-feb-07/axel: adapted from bc_sym_z
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real, dimension (:) :: dist
      integer :: i,j
!
      select case (topbot)
!
!  bottom
!
      case(BOT)               ! bottom boundary
        do i=1,nghost
          f(:,:,n1-i,j)=f(:,:,n1+i,j)*exp(-dz2_bound(-i)/dist(j))
        enddo
!
!  top
!
      case(TOP)               ! top boundary
        do i=1,nghost
          f(:,:,n2+i,j)=f(:,:,n2-i,j)*exp(dz2_bound(i)/dist(j))
        enddo
!
!  default
!
      case default
        call fatal_error("bc_overshoot_z: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_overshoot_z
!***********************************************************************
    subroutine bc_antis_x(f,slope,topbot,j,rel,val)
!
!  Print a warning to prompt potential users to document this.
!  This routine seems an experimental one to me (Axel)
!
!  Symmetry boundary conditions.
!  (f,-1,topbot,j)            --> antisymmetry             (f  =0)
!  (f,+1,topbot,j)            --> symmetry                 (f' =0)
!  (f,-1,topbot,j,REL=.true.) --> generalized antisymmetry (f''=0)
!  Don't combine rel=T and sgn=1, that wouldn't make much sense.
!
!  25-feb-07/axel: adapted from bc_slope_x
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real, dimension (:), optional :: val
      real, dimension (:) :: slope
      integer :: i,j
      logical, optional :: rel
      logical :: relative
!
!  Print a warning to prompt potential users to document this.
!
      call fatal_error('bc_antis_x','outdated/invalid? Document if needed')
!
      if (present(rel)) then; relative=rel; else; relative=.false.; endif
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        if (present(val)) f(l1,m1:m2,n1:n2,j)=val(j)
        if (relative) then
          do i=1,nghost
            f(l1-i,:,:,j)=2*f(l1,:,:,j)+slope(j)*f(l1+i,:,:,j)*x(l1+i)/x(l1-i)
          enddo
        else
          f(l1,:,:,j)=0.
          do i=1,nghost
            f(l1-i,:,:,j)=-f(l1+i,:,:,j)*(x(l1+i)/x(l1-i))**slope(j)
          enddo
        endif
!
      case(TOP)               ! top boundary
        if (present(val)) f(l2,m1:m2,n1:n2,j)=val(j)
        if (relative) then
          do i=1,nghost
            f(l2+i,:,:,j)=2*f(l2,:,:,j)+slope(j)*f(l2-i,:,:,j)
          enddo
        else
          f(l2,:,:,j)=0.
          do i=1,nghost
            f(l2+i,:,:,j)=-f(l2-i,:,:,j)*(x(l2-i)/x(l2+i))**slope(j)
          enddo
        endif
!
      case default
        call fatal_error("bc_antis_x: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_antis_x
!***********************************************************************
    subroutine bc_sym_y(f,sgn,topbot,j,rel,val,val2,val4)
!
!  Symmetry boundary conditions.
!  (f,-1,topbot,j)            --> antisymmetry             (f  =0)
!  (f,+1,topbot,j)            --> symmetry                 (f' =0)
!  (f,-1,topbot,j,REL=.true.) --> generalized antisymmetry (f''=0)
!  Don't combine rel=T and sgn=1, that wouldn't make much sense.
!
!  11-nov-02/wolf: coded
!  10-apr-05/axel: added val argument
!   9-jun-11/axel: added val2 argument
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real, dimension (:), optional :: val,val2,val4
      integer :: sgn,i,j
      logical, optional :: rel
      logical :: relative
!
      if (present(rel)) then; relative=rel; else; relative=.false.; endif
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        if (present(val)) f(:,m1,:,j)=val(j)
        if (present(val2)) f(:,m1,:,j)=f(:,m1,:,j)+val2(j)*spread(x**2,2,size(f,3))
        if (present(val4)) f(:,m1,:,j)=f(:,m1,:,j)+val4(j)*spread(x**4,2,size(f,3))
        if (relative) then
          do i=1,nghost; f(:,m1-i,:,j)=2*f(:,m1,:,j)+sgn*f(:,m1+i,:,j); enddo
        else
          do i=1,nghost; f(:,m1-i,:,j)=              sgn*f(:,m1+i,:,j); enddo
          if (sgn<0) f(:,m1,:,j) = 0. ! set bdry value=0 (indep of initcond)
        endif
!
      case(TOP)               ! top boundary
        if (present(val)) f(:,m2,:,j)=val(j)
        if (present(val2)) f(:,m2,:,j)=f(:,m2,:,j)+val2(j)*spread(x**2,2,size(f,3))
        if (present(val4)) f(:,m2,:,j)=f(:,m2,:,j)+val4(j)*spread(x**4,2,size(f,3))
        if (relative) then
          do i=1,nghost; f(:,m2+i,:,j)=2*f(:,m2,:,j)+sgn*f(:,m2-i,:,j); enddo
        else
          do i=1,nghost; f(:,m2+i,:,j)=              sgn*f(:,m2-i,:,j); enddo
          if (sgn<0) f(:,m2,:,j) = 0. ! set bdry value=0 (indep of initcond)
        endif
!
      case default
        call fatal_error("bc_sym_y: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_sym_y
!***********************************************************************
    subroutine bc_stratified_y(f,topbot,j)
!
!  Boundary condition that maintains hydrostatic equilibrium in the meriodional direction.
!  This boundary is coded only for spherical coordinates.
!
!  06-oct-13/wlad: coded
!
      use EquationOfState, only: cs0
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real, dimension(size(f,1)) :: rad,za,zg,H,lnrho
      integer :: i,in,j
!
      if (.not.(j==irho.or.j==ilnrho)) &
           call fatal_error("bc_stratified_y","This boundary condition is specific for density")
      if (.not.lspherical_coords) &
           call fatal_error("bc_stratified_y","This boudary condition is for spherical coordinates only")
!
      rad=x
!
      select case (topbot)
      case(BOT)
        za=rad*costh(m1)
        H=cs0*rad/sqrt(gamma)
        do i=1,nghost
          zg=rad*costh(m1-i)
          do in=1,size(f,3)
            if (ldensity_nolog) then
              lnrho = alog(f(:,m1,in,j)) - (zg**2-za**2)/(2*H**2)
              f(:,m1-i,in,j) = exp(lnrho)
            else
              lnrho = f(:,m1,in,j) - (zg**2-za**2)/(2*H**2)
              f(:,m1-i,in,j) = lnrho
            endif
          enddo
        enddo
!
      case(TOP)
        za=rad*costh(m2)
        H=cs0*rad/sqrt(gamma)
        do i=1,nghost
          zg=rad*costh(m2+i)
          do in=1,size(f,3)
            if (ldensity_nolog) then
              lnrho = alog(f(:,m2,in,j)) - (zg**2-za**2)/(2*H**2)
              f(:,m2+i,in,j) = exp(lnrho)
            else
              lnrho = f(:,m2,in,j) - (zg**2-za**2)/(2*H**2)
              f(:,m2+i,in,j) = lnrho
            endif
          enddo
        enddo
!
      case default
        call fatal_error("bc_sym_y: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_stratified_y
!***********************************************************************
    subroutine bc_stratified_z(f,topbot,j)
!
!  Boundary condition that maintains hydrostatic equilibrium in the meriodional direction.
!  This boundary is coded only for spherical coordinates.
!
!  11-apr-24/wlad: coded
!
      use EquationOfState, only: cs0
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real, dimension(size(f,1)) :: lnrho
      real :: za,zg,H
      integer :: i,im,j
!
      if (.not.(j==irho.or.j==ilnrho)) &
           call fatal_error("bc_stratified_z","This boundary condition is specific for density")
!
      H=cs0/Omega/sqrt(gamma)
!
      select case (topbot)
      case(BOT)
        za=z(n1)
        do i=1,nghost
          zg=z(n1-i)
          do im=1,size(f,2)
            if (ldensity_nolog) then
              lnrho = alog(f(:,im,n1,j)) - (zg**2-za**2)/(2*H**2)
              f(:,im,n1-i,j) = exp(lnrho)
            else
              lnrho = f(:,im,n1,j) - (zg**2-za**2)/(2*H**2)
              f(:,im,n1-i,j) = lnrho
            endif
          enddo
        enddo
!
      case(TOP)
        za=z(n2)
        do i=1,nghost
          zg=z(n2+i)
          do im=1,size(f,3)
            if (ldensity_nolog) then
              lnrho = alog(f(:,im,n2,j)) - (zg**2-za**2)/(2*H**2)
              f(:,im,n2+i,j) = exp(lnrho)
            else
              lnrho = f(:,im,n2,j) - (zg**2-za**2)/(2*H**2)
              f(:,im,n2+i,j) = lnrho
            endif
          enddo
        enddo
!
      case default
        call fatal_error("bc_sym_z: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_stratified_z
!***********************************************************************
    subroutine bc_symset_y(f,sgn,topbot,j,rel,val)
!
!  This routine works like bc_sym_y, but sets the function value to what
!  it should be for vanishing one-sided derivative.
!  At the moment the derivative is only 2nd order accurate.
!
!  Symmetry boundary conditions.
!  (f,-1,topbot,j)            --> antisymmetry             (f  =0)
!  (f,+1,topbot,j)            --> symmetry                 (f' =0)
!  (f,-1,topbot,j,REL=.true.) --> generalized antisymmetry (f''=0)
!  Don't combine rel=T and sgn=1, that wouldn't make much sense.
!
!  11-nov-02/wolf: coded
!  10-apr-05/axel: added val argument
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real, dimension (:), optional :: val
      integer :: sgn,i,j
      logical, optional :: rel
      logical :: relative
!
      if (present(rel)) then; relative=rel; else; relative=.false.; endif
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        if (present(val)) f(l1:l2,m1,n1:n2,j)=val(j)
        if (relative) then
          do i=1,nghost; f(:,m1-i,:,j)=2*f(:,m1,:,j)+sgn*f(:,m1+i,:,j); enddo
        else
          do i=1,nghost; f(:,m1-i,:,j)=              sgn*f(:,m1+i,:,j); enddo
          !f(:,m1,:,j)=(4.*f(:,m1+1,:,j)-f(:,m1+2,:,j))/3.
        endif
!
      case(TOP)               ! top boundary
        if (present(val)) f(l1:l2,m2,n1:n2,j)=val(j)
        if (relative) then
          do i=1,nghost; f(:,m2+i,:,j)=2*f(:,m2,:,j)+sgn*f(:,m2-i,:,j); enddo
        else
          do i=1,nghost; f(:,m2+i,:,j)=              sgn*f(:,m2-i,:,j); enddo
          !f(:,m2,:,j)=(4.*f(:,m2-1,:,j)-f(:,m2-2,:,j))/3.
        endif
!
      case default
        call fatal_error("bc_symset_y: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_symset_y
!***********************************************************************
    subroutine bc_symderset_y(f,topbot,j,val)
!
!  This routine works like bc_sym_y, but sets the derivative value
!
!  30-may-11/axel: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real, dimension (:) :: val
      integer :: i,j
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        do i=1,nghost; f(:,m1-i,:,j)=f(:,m1+i,:,j)-dy2_bound(-i)*val(j); enddo
!
      case(TOP)               ! top boundary
        do i=1,nghost; f(:,m2+i,:,j)=f(:,m2-i,:,j)+dy2_bound(i)*val(j); enddo
!
      case default
        call fatal_error("bc_symderset_y: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_symderset_y
!***********************************************************************
    subroutine bc_csymderset_y(f,topbot,j,val)
!
!  This routine works like bc_sym_y, but sets the derivative value
!
!  30-may-11/axel: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real, dimension (size(f,1),size(f,3)) :: derval
      real, dimension (:) :: val
      integer :: i,j
!
      derval=spread((xyz1(1)-x)*val(j),2,size(f,3))
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        do i=1,nghost; f(:,m1-i,:,j)=f(:,m1+i,:,j)-dy2_bound(-i)*derval; enddo
!
      case(TOP)               ! top boundary
        do i=1,nghost; f(:,m2+i,:,j)=f(:,m2-i,:,j)+dy2_bound(i)*derval; enddo
!
      case default
        call fatal_error("bc_csymderset_y: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_csymderset_y
!***********************************************************************
    subroutine bc_symset0der_y(f,topbot,j)
!
!  This routine works like bc_sym_y, but sets the function value to what
!  it should be for vanishing one-sided derivative.
!  This is the routine to be used as regularity condition on the axis.
!
!  19-nov-09/axel: adapted from bc_symset0der_x
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: i,j,i1=1,i2=2,i3=3,i4=4,i5=5,i6=6
!
      select case (topbot)
!
!  bottom (left end of the domain)
!
      case(BOT)               ! bottom boundary
        f(:,m1,:,j)=(360.*f(:,m1+i1,:,j) &
                    -450.*f(:,m1+i2,:,j) &
                    +400.*f(:,m1+i3,:,j) &
                    -225.*f(:,m1+i4,:,j) &
                     +72.*f(:,m1+i5,:,j) &
                     -10.*f(:,m1+i6,:,j))/147.
        do i=1,nghost; f(:,m1-i,:,j)=f(:,m1+i,:,j); enddo
!
!  top (right end of the domain)
!
      case(TOP)               ! top boundary
        f(:,m2,:,j)=(360.*f(:,m2-i1,:,j) &
                    -450.*f(:,m2-i2,:,j) &
                    +400.*f(:,m2-i3,:,j) &
                    -225.*f(:,m2-i4,:,j) &
                     +72.*f(:,m2-i5,:,j) &
                     -10.*f(:,m2-i6,:,j))/147.
        do i=1,nghost; f(:,m2+i,:,j)=f(:,m2-i,:,j); enddo
!
      case default
        call fatal_error("bc_symset0der_y: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_symset0der_y
!***********************************************************************
    subroutine bc_spt_y(f,topbot,j)
!
!  This condition sets values for A_r or/and A_phi at the theta boundary.
!  It solves A"+\cot(theta)A'=0 and A=0 at the boundary.
!  We compute the A1 point using a 2nd-order formula,
!  Next, we compute A2 using a 4th-order formula,
!  and finally A3 using a 6th-order formula.
!  is has to be used togehter with 'sse' with 'fbcy_top' or 'fbcy_bot'
!  where A_theta=0
!
!  23-may-13/joern: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real :: tmp
      integer :: j
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        tmp=cotth(m1)/dy_1(m1)
!
        f(:,m1,:,j)  =0
        f(:,m1-1,:,j)=(f(:,m1+1,:,j)*(-1-0.5*tmp))/(1-0.5*tmp)
        f(:,m1-2,:,j)=(f(:,m1-1,:,j)*8*(2-tmp) &
                      +f(:,m1+1,:,j)*8*(2+tmp) &
                      +f(:,m1+2,:,j)*(-1-tmp))/(1-tmp)
        f(:,m1-3,:,j)=(f(:,m1-2,:,j)*13.5*(1-tmp) &
                      +f(:,m1-1,:,j)*135*(-1+0.5*tmp) &
                      +f(:,m1+1,:,j)*135*(-1-0.5*tmp) &
                      +f(:,m1+2,:,j)*13.5*(1+tmp) &
                      +f(:,m1+3,:,j)*(-1-1.5*tmp))/(1-1.5*tmp)
!
      case(TOP)               ! top boundary
        tmp=cotth(m2)/dy_1(m2)
!
        f(:,m2,:,j)  =0
        f(:,m2+1,:,j)=(f(:,m2-1,:,j)*(-1-0.5*tmp))/(1-0.5*tmp)
        f(:,m2+2,:,j)=(f(:,m2+1,:,j)*8*(2-tmp) &
                      +f(:,m2+1,:,j)*8*(2+tmp) &
                      +f(:,m2+2,:,j)*(-1-tmp))/(1-tmp)
        f(:,m2+3,:,j)=(f(:,m2+2,:,j)*13.5*(1-tmp) &
                      +f(:,m2+1,:,j)*135*(-1+0.5*tmp) &
                      +f(:,m2-1,:,j)*135*(-1-0.5*tmp) &
                      +f(:,m2-2,:,j)*13.5*(1+tmp) &
                      +f(:,m2-3,:,j)*(-1-1.5*tmp))/(1-1.5*tmp)
!
      case default
        call fatal_error("bc_spt_y: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_spt_y
!***********************************************************************
    subroutine bc_sym_z(f,sgn,topbot,j,rel,val,val2,val4)
!
!  Symmetry boundary conditions.
!  (f,-1,topbot,j)            --> antisymmetry             (f  =0)
!  (f,+1,topbot,j)            --> symmetry                 (f' =0)
!  (f,-1,topbot,j,REL=.true.) --> generalized antisymmetry (f''=0)
!  Don't combine rel=T and sgn=1, that wouldn't make much sense.
!
!  11-nov-02/wolf: coded
!  10-apr-05/axel: added val argument
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real, dimension (:), optional :: val,val2,val4
      integer :: sgn,i,j
      logical, optional :: rel
      logical :: relative
!
      if (present(rel)) then; relative=rel; else; relative=.false.; endif
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        if (present(val)) f(:,:,n1,j)=val(j)
        if (present(val2)) f(:,:,n1,j)=f(:,:,n1,j)+val2(j)*spread(x**2,2,size(f,2))
        if (present(val4)) f(:,:,n1,j)=f(:,:,n1,j)+val4(j)*spread(x**4,2,size(f,2))
        if (relative) then
          do i=1,nghost; f(:,:,n1-i,j)=2*f(:,:,n1,j)+sgn*f(:,:,n1+i,j);
            if (.false..and.j==3) then
!if (i==1) print*, f(4,4:9,n1,j)
!if (i==1) print*, f(4,4:23,n1-1,j)
              if (any(f(4:131,4:131,n1-i,j)/=f(4:131,4:131,n1+i,j))) &
                print'(a,i2,1x,e20.12)','boundcond ghost:i=', i, maxval(abs(f(4:131,4:131,n1-i,j)-f(4:131,4:131,n1+i,j)))
              if (any(f(4:131,4:131,n1-i,j)/=f(4:131,4:131,n1,j))) &
                print'(a,i2,1x,e20.12)','boundcond bound-:i=', i, maxval(abs(f(4:131,4:131,n1-i,j)-f(4:131,4:131,n1,j)))
              if (any(f(4:131,4:131,n1+i,j)/=f(4:131,4:131,n1,j))) &
                print'(a,i2,1x,e20.12)','boundcond bound+:i=', i, maxval(abs(f(4:131,4:131,n1+i,j)-f(4:131,4:131,n1,j)))
            endif
          enddo
        else
!if (ldownsampling) print*, 'size,n1,j=', size(f,1), size(f,2), size(f,3), size(f,4),n1,j 
          do i=1,nghost; f(:,:,n1-i,j)=              sgn*f(:,:,n1+i,j); enddo
          if (sgn<0) f(:,:,n1,j) = 0. ! set bdry value=0 (indep of initcond)
        endif
!
      case(TOP)               ! top boundary
        if (present(val)) f(:,:,n2,j)=val(j)
        if (present(val2)) f(:,:,n2,j)=f(:,:,n2,j)+val2(j)*spread(x**2,2,size(f,2))
        if (present(val4)) f(:,:,n2,j)=f(:,:,n2,j)+val4(j)*spread(x**4,2,size(f,2))
        if (relative) then
          do i=1,nghost; f(:,:,n2+i,j)=f(:,:,n2,j)+(f(:,:,n2,j)+sgn*f(:,:,n2-i,j));
          enddo
        else
          do i=1,nghost; f(:,:,n2+i,j)=              sgn*f(:,:,n2-i,j); enddo
          if (sgn<0) f(:,:,n2,j) = 0. ! set bdry value=0 (indep of initcond)
        endif
!
      case default
        call fatal_error("bc_sym_z: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_sym_z
!***********************************************************************
    subroutine bc_sf_x(f,sgn,topbot,j)
!
!  Symmetric/antisymmetric boundary conditions with respect to the interface.
!  i.e. where the reflection plane is between the last mesh point and first
!  ghost point
!
!    sgn = +1  -->  symmetric
!    sgn = -1  -->  antisymmetric
!
!  12-nov-16/ccyang: coded
!
      real, dimension(:,:,:,:), intent(inout) :: f
      integer, intent(in) :: sgn, j
      integer, intent(IN) :: topbot
!
      integer :: i
!
      select case(topbot)
      case(BOT)               ! bottom boundary
        forall (i=1:nghost) f(l1-i,:,:,j) = real(sgn) * f(l1+i-1,:,:,j)
      case(TOP)               ! top boundary
        forall (i=1:nghost) f(l2+i,:,:,j) = real(sgn) * f(l2-i+1,:,:,j)
      case default
        call fatal_error('bc_sf_x','topbot should be BOT or TOP')
      endselect
!
    endsubroutine bc_sf_x
!***********************************************************************
    subroutine bc_sf_y(f,sgn,topbot,j)
!
!  Symmetric/antisymmetric boundary conditions with respect to the interface.
!  i.e. where the reflection plane is between the last mesh point and first
!  ghost point
!
!    sgn = +1  -->  symmetric
!    sgn = -1  -->  antisymmetric
!
!  12-nov-16/ccyang: coded
!
      real, dimension(:,:,:,:), intent(inout) :: f
      integer, intent(in) :: sgn, j
      integer, intent(IN) :: topbot
!
      integer :: i
!
      select case(topbot)
      case(BOT)               ! bottom boundary
        forall (i=1:nghost) f(:,m1-i,:,j) = real(sgn) * f(:,m1+i-1,:,j)
      case(TOP)               ! top boundary
        forall (i=1:nghost) f(:,m2+i,:,j) = real(sgn) * f(:,m2-i+1,:,j)
      case default
        call fatal_error('bc_sf_y','topbot should be BOT or TOP')
      endselect
!
    endsubroutine bc_sf_y
!***********************************************************************
    subroutine bc_sf_z(f,sgn,topbot,j)
!
!  Symmetric/antisymmetric boundary conditions with respect to the interface.
!  i.e. where the reflection plane is between the last mesh point and first
!  ghost point
!
!    sgn = +1  -->  symmetric
!    sgn = -1  -->  antisymmetric
!
!  14-feb-09/ccyang: coded
!
      real, dimension(:,:,:,:), intent(inout) :: f
      integer, intent(in) :: sgn, j
      integer, intent(IN) :: topbot
!
      integer :: i
!
      select case(topbot)
      case(BOT)               ! bottom boundary
        forall (i=1:nghost) f(:,:,n1-i,j) = real(sgn) * f(:,:,n1+i-1,j)
      case(TOP)               ! top boundary
        forall (i=1:nghost) f(:,:,n2+i,j) = real(sgn) * f(:,:,n2-i+1,j)
      case default
        call fatal_error('bc_sf_z','topbot should be BOT or TOP')
      endselect
!
    endsubroutine bc_sf_z
!***********************************************************************
    subroutine bc_symset0der_z(f,topbot,j)
!
!  This routine works like bc_sym_z, but sets the function value to what
!  it should be for vanishing one-sided derivative.
!  This is the routine to be used as regularity condition on the axis.
!
!  22-nov-09/axel: adapted from bc_symset0der_y
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: i,j,i1=1,i2=2,i3=3,i4=4,i5=5,i6=6
!
      select case (topbot)
!
!  bottom (left end of the domain)
!
      case(BOT)               ! bottom boundary
        f(:,:,n1,j)=(360.*f(:,:,n1+i1,j) &
                    -450.*f(:,:,n1+i2,j) &
                    +400.*f(:,:,n1+i3,j) &
                    -225.*f(:,:,n1+i4,j) &
                     +72.*f(:,:,n1+i5,j) &
                     -10.*f(:,:,n1+i6,j))/147.
        do i=1,nghost; f(:,:,n1-i,j)=f(:,:,n1+i,j); enddo
!
!  top (right end of the domain)
!
      case(TOP)               ! top boundary
        f(:,:,n2,j)=(360.*f(:,:,n2-i1,j) &
                    -450.*f(:,:,n2-i2,j) &
                    +400.*f(:,:,n2-i3,j) &
                    -225.*f(:,:,n2-i4,j) &
                     +72.*f(:,:,n2-i5,j) &
                     -10.*f(:,:,n2-i6,j))/147.
        do i=1,nghost; f(:,:,n2+i,j)=f(:,:,n2-i,j); enddo
!
      case default
        call fatal_error("bc_symset0der_z: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_symset0der_z
!***********************************************************************
    subroutine bc_set_der_x(f,topbot,j,val)
!
!  Sets the derivative on the boundary to a given value.
!
!  14-may-2006/tobi: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent (in) :: j
      real, intent (in) :: val
!
      integer :: i
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        do i=1,nghost; f(l1-i,:,:,j) = f(l1+i,:,:,j) - dx2_bound(-i)*val; enddo
!
      case(TOP)               ! top boundary
        do i=1,nghost; f(l2+i,:,:,j) = f(l2-i,:,:,j) + dx2_bound(i)*val; enddo
!
      case default
        call fatal_error('bc_set_der_x',"topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_set_der_x
!***********************************************************************
    subroutine bc_fix_x(f,topbot,j,val)
!
!  Sets the value of f, particularly:
!    A_{\alpha}= <val>
!  on the boundary to a given value
!
!  27-apr-2007/dhruba: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent (in) :: j
!
      real, intent (in) :: val
      integer :: i
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        do i=1,nghost; f(l1-i,:,:,j)=val; enddo
      case(TOP)               ! top boundary
        do i=1,nghost; f(l2+i,:,:,j)=val; enddo
      case default
        call fatal_error('bc_fix_x',"topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_fix_x
!***********************************************************************
    subroutine bc_file_x(f,topbot,j)
!
!  Sets the value of f from a file
!
!   9-jan-2008/axel+nils+natalia: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent (in) :: j
!
      real, dimension (:,:,:,:), allocatable :: bc_file_x_array
      integer :: i,lbc0,lbc1,lbc2,stat,iszx,io_code
      real :: lbc,frac
      logical, save :: lbc_file_x=.true.
!
      if (ldownsampling) then
        call warning('bc_file_x','Not available for downsampling')
        return
      endif
!
!  Allocate memory for large array.
!
      allocate(bc_file_x_array(mx,my,mz,mvar),stat=stat)
      if (stat>0) call fatal_error('bc_file_x', &
          'Could not allocate memory for bc_file_x_array')
!
      if (lbc_file_x) then
        if (lroot) then
          print*,'opening bc_file_x.dat'
          open(9,file=trim(directory_dist)//'/bc_file_x.dat',form='unformatted')
          read(9,iostat=io_code) bc_file_x_array
          if (io_code < 0) then
            ! end of file
            if (lroot) print*,'need file with dimension: ',mx,my,mz,mvar
            deallocate(bc_file_x_array)
            call stop_it("boundary file bc_file_x.dat has incorrect size")
          endif
          close(9)
        endif
        lbc_file_x=.false.
      endif
      
      iszx=size(f,1)
!
      select case (topbot)
!
!  x - Udrift_bc*t = dx * (ix - Udrift_bc*t/dx)
!
      case(BOT)               ! bottom boundary
        lbc=Udrift_bc*t*dx_1(1)+1.
        lbc0=int(lbc)
        frac=mod(lbc,real(lbc0))
        lbc1=iszx+mod(-lbc0,iszx)
        lbc2=iszx+mod(-lbc0-1,iszx)
        do i=1,nghost
          f(l1-i,:,:,j)=(1-frac)*bc_file_x_array(lbc1,:,:,j) &
                           +frac*bc_file_x_array(lbc2,:,:,j)
        enddo
      case(TOP)               ! top boundary
!
!  note: this "top" thing hasn't been adapted or tested yet.
!  The -lbc0-1 has been changed to +lbc0+1, but has not been tested yet.
!
        lbc=Udrift_bc*t*dx_1(1)+1.
        lbc0=int(lbc)
        frac=mod(lbc,real(lbc0))
        lbc1=iszx+mod(+lbc0,iszx)
        lbc2=iszx+mod(+lbc0+1,iszx)
        do i=1,nghost
          f(l2+i,:,:,j)=(1-frac)*bc_file_x_array(lbc1,:,:,j) &
                           +frac*bc_file_x_array(lbc2,:,:,j)
        enddo
      case default
        call fatal_error('bc_fix_x',"topbot should be BOT or TOP")
!
      endselect
!
      deallocate(bc_file_x_array)
!
    endsubroutine bc_file_x
!***********************************************************************
    subroutine bc_set_spder_x(f,topbot,j,val)
!
!  Sets the derivative, particularly:
!    d(rA_{\alpha})/dr = <val>
!  on the boundary to a given value
!
!  27-apr-2007/dhruba: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent (in) :: j
!
      real, intent (in) :: val
      integer :: i
!
      if (lspherical_coords)then
        select case (topbot)
        case(BOT)               ! bottom boundary
          do i=1,nghost
            f(l1-i,:,:,j)=f(l1+i,:,:,j)-dx2_bound(-i)*(val-f(l1,:,:,j)*r1_mn(1))
          enddo
        case(TOP)               ! top boundary
          do i=1,nghost
            f(l2+i,:,:,j)=f(l2-i,:,:,j)+dx2_bound(i)*(val-f(l2,:,:,j)*r1_mn(nx))
          enddo
!
        case default
          call fatal_error('bc_set_spder_x',"topbot should be BOT or TOP")
!
        endselect
      else
        call stop_it('bc_set_spder_x valid only in spherical coordinate system')
      endif
!
    endsubroutine bc_set_spder_x
! **********************************************************************
    subroutine bc_set_pfc_x(f,topbot,j)
!
!joern: WARNING, this bc will NOT give a perfect-conductor boundary condition
!
!  In spherical polar coordinate system,
!  at a radial boundary set : $A_{\theta} = 0$ and $A_{phi} = 0$,
!  and demand $div A = 0$ gives the condition on $A_r$ to be
!  $d/dr( A_r) + 2 A_r/r = 0$ . This subroutine sets this condition of
!  $j$ the component of f. As this is related to setting the
!  perfect conducting boundary condition we call this "pfc".
!
!  25-Aug-2007/dhruba: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent (in) :: j
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
! The coding assumes we are using 6-th order centered finite difference for our
! derivatives.
        f(l1-1,:,:,j)= f(l1+1,:,:,j) +  2.*60.*f(l1,:,:,j)*dx/(45.*x(l1))
        f(l1-2,:,:,j)= f(l1+2,:,:,j) +  2.*60.*f(l1,:,:,j)*dx/(9.*x(l1))
        f(l1-3,:,:,j)= f(l1+3,:,:,j) +  2.*60.*f(l1,:,:,j)*dx/x(l1)
      case(TOP)               ! top boundary
        f(l2+1,:,:,j)= f(l2-1,:,:,j) -  2.*60.*f(l2,:,:,j)*dx/(45.*x(l2))
        f(l2+2,:,:,j)= f(l2-2,:,:,j) -  2.*60.*f(l2,:,:,j)*dx/(9.*x(l2))
        f(l2+3,:,:,j)= f(l2-3,:,:,j) -  2.*60.*f(l2,:,:,j)*dx/(x(l2))
!
      case default
        call fatal_error('bc_set_pfc_x',"topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_set_pfc_x
!***********************************************************************
    subroutine bc_set_nfr_x(f,topbot,j)
!
!  Normal-field (or angry-hedgehog) boundary condition for spherical
!  coordinate system.
!  d_r(A_{\theta}) = -A_{\theta}/r  with A_r = 0 sets B_{r} to zero
!  in spherical coordinate system.
!  (compare with next subroutine sfree )
!
!  25-Aug-2007/dhruba: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent (in) :: j
      integer :: k
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        do k=1,nghost
          f(l1-k,:,:,j)= f(l1+k,:,:,j)*(x(l1+k)/(x(l1+k)-dx2_bound(-k)))
        enddo
!
     case(TOP)               ! top boundary
       do k=1,nghost
         f(l2+k,:,:,j)= f(l2-k,:,:,j)*(x(l2-k)/(x(l2-k)+dx2_bound(k)))
       enddo
!
      case default
        call fatal_error('bc_set_nfr_x',"topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_set_nfr_x
!***********************************************************************
    subroutine bc_set_nr1_x(f,topbot,j)
!
!  Normal-field (or angry-hedgehog) boundary condition for spherical
!  coordinate system.
!  d_r(A_{\theta}) = -A_{\theta}/r  with A_r = 0 sets B_{r} to zero
!  in spherical coordinate system.
!  Implementation with one-sided derivative.
!
!  13-Dec-2016/MR: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent (in) :: j
!
      if (topbot==BOT) then
        call bval_from_3rd(f,topbot,j,1,-1./x(l1))
      else
        call bval_from_3rd(f,topbot,j,1,-1./x(l2)) 
      endif
      call set_ghosts_for_onesided_ders(f,topbot,j,1,.true.)
!
    endsubroutine bc_set_nr1_x
!***********************************************************************
    subroutine bc_set_sr1_x(f,topbot,j)
!
!  Stress-free boundary condition for spherical
!  coordinate system: \partial_r u_(\theta,\phi)|_r_(i,a) = u_(r_(i,a),\theta,\phi)/r_(i,a)
!  Implementation with one-sided derivative.
!
!  4-Sep-2017/MR: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent (in) :: j
!
      if (topbot==BOT) then
        call bval_from_3rd(f,topbot,j,1,1./x(l1))
      else
        call bval_from_3rd(f,topbot,j,1,1./x(l2))
      endif
      call set_ghosts_for_onesided_ders(f,topbot,j,1,.true.)
!
    endsubroutine bc_set_sr1_x
! **********************************************************************
    subroutine bc_set_sa2_x(f,topbot,j)
!
!  To set the boundary condition:
!  d_r(r B_{\phi} = 0 we need to se
!  (d_r)^2(r A_{\theta}) = 0 which sets the condition 'a2'
!  on r A_{\theta} and vice-versa for A_{\phi}
!
!  03-Dec-2009/dhruba: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent (in) :: j
      integer :: k
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        do k=1,nghost
          f(l1-k,:,:,j)= f(l1,:,:,j)*2.*(x(l1)/x(l1-k))&
                         -f(l1+k,:,:,j)*(x(l1+k)/x(l1-k))
        enddo
!
     case(TOP)               ! top boundary
       do k=1,nghost
         f(l2+k,:,:,j)= f(l2,:,:,j)*2.*(x(l2)/x(l2+k))&
                        -f(l2-k,:,:,j)*(x(l2-k)/x(l2+k))
       enddo
!
      case default
        call fatal_error('bc_set_sa2_x',"topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_set_sa2_x
! **********************************************************************
    subroutine bc_set_sfree_x(f,topbot,j)
!
!  Details are given in an appendix in the manual.
!  Lambda effect : stresses due to Lambda effect are added to the stress-tensor.
!  For rotation along the z direction and also for not very strong rotation such
!  that the breaking of rotational symmetry is only due to gravity, the only
!  new term appears in the r-phi component. This implies that this term
!  affects only the boundary condition of u_{\phi} for the radial boundary.
!
!  25-Aug-2007/dhruba: coded
!  21-Mar-2009/axel: get llambda_effect using get_shared_variable
!   6-Jun-2024/axel+petri: included llambda_scale_with_nu when scaled with nu
!
      use SharedVariables, only : get_shared_variable
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent (in) :: j
!
      real, pointer :: nu,Lambda_V0t,Lambda_V0b,Lambda_V1t,Lambda_V1b
      logical, pointer :: llambda_effect, llambda_scale_with_nu
      integer :: iy, k
      real :: fac,sth,lambda_exp
!
! -------- Either case get the lambda variables first -----------
!
      call get_shared_variable('nu',nu,caller='bc_set_sfree_x')
      call get_shared_variable('llambda_effect',llambda_effect)
      if (llambda_effect) then
        call get_shared_variable('llambda_scale_with_nu',llambda_scale_with_nu)
        call get_shared_variable('Lambda_V0t',Lambda_V0t)
        call get_shared_variable('Lambda_V1t',Lambda_V1t)
        call get_shared_variable('Lambda_V0b',Lambda_V0b)
        call get_shared_variable('Lambda_V1b',Lambda_V1b)
      endif
!
      select case (topbot)
!
! Bottom boundary
!
      case(BOT)
!
        if ((llambda_effect).and.(j==iuz)) then
          do iy=1,size(f,2)
            sth=sinth(iy)
            if (llambda_scale_with_nu) then
              lambda_exp=1.+(Lambda_V0b+Lambda_V1b*sth*sth)
            else
              lambda_exp=1.+(Lambda_V0b+Lambda_V1b*sth*sth)/nu
            endif
            do k=1,nghost
               fac=(1.-dx2_bound(-k)/x(l1+k))**lambda_exp
               if (Omega==0) then
                 f(l1-k,iy,:,j) = f(l1+k,iy,:,j)*fac
               else
                 f(l1-k,iy,:,j) = (f(l1+k,iy,:,j)+Omega*x(l1+k)*sth)*fac &
                                 -Omega*(x(l1+k)-dx2_bound(-k))*sth
               endif
            enddo
          enddo
        else
          do k=1,nghost
            f(l1-k,:,:,j) = f(l1+k,:,:,j)*(1.-dx2_bound(-k)/x(l1+k))
!
!  Alternative formulation
!
            !f(l1-k,:,:,j)= f(l1+k,:,:,j) - f(l1,:,:,j)*(dx2_bound(-k)/x(l1))
          enddo
        endif
!
! Top boundary
!
      case(TOP)
        if ((llambda_effect).and.(j==iuz)) then
          do iy=1,size(f,2)
            sth=sinth(iy)
            if (llambda_scale_with_nu) then
              lambda_exp=1.+(Lambda_V0t+Lambda_V1t*sth*sth)
            else
              lambda_exp=1.+(Lambda_V0t+Lambda_V1t*sth*sth)/nu
            endif
            do k=1,nghost
              fac=(1.+dx2_bound(k)/x(l2-k))**lambda_exp
              if (Omega==0) then
                f(l2+k,iy,:,j) = f(l2-k,iy,:,j)*fac
              else
                f(l2+k,iy,:,j) = (f(l2-k,iy,:,j)+Omega*x(l2-k)*sth)*fac &
                                -Omega*(x(l2-k)+dx2_bound(k))*sth
              endif
            enddo
          enddo
        else
          do k=1,nghost
            f(l2+k,:,:,j)= f(l2-k,:,:,j)*(1.+dx2_bound(k)/x(l2-k))
!
!  Alternative formulation
!
            !f(l2+k,:,:,j)= f(l2-k,:,:,j) + f(l2,:,:,j)*(dx2_bound(k)/x(l2))
          enddo
        endif
!
      case default
        call fatal_error('bc_set_sfree_x',"topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_set_sfree_x
! **********************************************************************
    subroutine bc_set_jethat_x(f,jj,topbot,fracall,uzeroall)
!
!  Sets tophat velocity profile at the inner (bot) boundary
!
!  03-jan-2008/dhruba: coded
!
      use Sub, only: step
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent(in) :: jj
      integer :: i,j,k
      real, dimension(:),intent(in) :: fracall,uzeroall
      real :: frac,uzero,ylim,ymid,y1,zlim,zmid,z1
      real :: yhat_min,yhat_max,zhat_min,zhat_max
      real, parameter :: width_hat=0.01
      real, dimension (m2-m1+1) :: hatprofy
      real, dimension (n2-n1+1) :: hatprofz
!
      y1 = xyz1(2)
      z1 = xyz1(3)
      frac = fracall(jj)
      uzero = uzeroall(jj)
!
      if (lspherical_coords)then
!
        select case (topbot)
        case(BOT)               ! bottom boundary
          ylim = (y1-y0)*frac
          ymid = y0+(y1-y0)/2.
          yhat_min=ymid-ylim/2.
          yhat_max=ymid+ylim/2
          hatprofy=step(y(m1:m2),yhat_min,width_hat)*(1.-step(y(m1:m2),yhat_max,width_hat))
          zlim = (z1-z0)*frac
          zmid = z0+(z1-z0)/2.
          zhat_min=zmid-zlim/2.
          zhat_max=zmid+zlim/2
          hatprofz=step(z(n1:n2),zhat_min,width_hat)*(1.-step(z(n1:n2),zhat_max,width_hat))
          do j=m1,m2
            do k=n1,n2
                f(l1,j,k,iux)= uzero*hatprofy(j)*hatprofz(k)
                do i=1,nghost
                  f(l1-i,j,k,iux)= uzero*hatprofy(j)*hatprofz(k)
                enddo
            enddo
          enddo
        case(TOP)               ! top boundary
          call warning('bc_set_jethat_x','Jet flowing out of the exit boundary ?')
          do i=1,nghost
            f(l2+i,:,:,jj)=0.
          enddo
!
        case default
          call fatal_error('bc_set_jethat_x',"topbot should be BOT or TOP")
        endselect

     else
        call stop_it('Boundary condition jethat is valid only in spherical coordinate system')
     endif
!
    endsubroutine bc_set_jethat_x
! **********************************************************************
    subroutine bc_set_jet_x(f,jj,topbot,velocity,radius)
!
!  Sets tophat velocity profile at the inner (bot) boundary
!
!  06-nov-2013/nils: adapted from bc_set_jethat_x. Made this new routine
!                    because there some awckward choices made in the
!                    other one, and the other one is for spherical geometries.
!
      use Sub, only: step
!
      integer, intent(IN) :: topbot
      real, dimension (m2-m1+1,n2-n1+1) :: prof
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent(in) :: jj
      integer :: i,j,k
      real, dimension(:),intent(in) :: velocity,radius
      real :: vel,rad
!
      vel = velocity(jj)
      rad = radius(jj)
!
      if (lcartesian_coords) then
         select case (topbot)
         case(BOT)               ! bottom boundary
            call jet_x(prof,vel,rad)
            do j=m1,m2
               do k=n1,n2
                  f(l1,j,k,iux)= prof(j-nghost,k-nghost)
                  do i=1,nghost
                     f(l1-i,j,k,iux)= prof(j-nghost,k-nghost)
                  enddo
               enddo
            enddo
!
         case(TOP)               ! top boundary
            call warning('bc_set_jet_x','jet flowing out of the exit boundary')
            do i=1,nghost
               f(l2+i,:,:,jj)=0.
            enddo
!
         case default
            call fatal_error('bc_set_jethat_x',"topbot should be BOT or TOP")
         endselect
!
      else
         call stop_it('Boundary condition jethat is valid only in spherical coordinate system')
      endif
!
    endsubroutine bc_set_jet_x
! **********************************************************************
    subroutine jet_x(prof,vel,rad)
!
!  06-nov-2013/nils: Set jet profile
!
      use Sub, only: step
!
      real, dimension (:,:), intent (out) :: prof
      integer :: j,k
      real :: vel,rad,ymid,y1,zlim,zmid,z1
      real :: yhat_min,yhat_max,zhat_min,zhat_max
      real :: width_hat
      real, dimension (size(prof,1)) :: hatprofy
      real, dimension (size(prof,2)) :: hatprofz
!
      y1 = xyz1(2)
      z1 = xyz1(3)
      width_hat=dy*2
!
      ymid = y0+(y1-y0)/2.
      yhat_min=ymid-rad/2.
      yhat_max=ymid+rad/2
      hatprofy= step(y(m1:m2),yhat_min,width_hat) &
               -step(y(m1:m2),yhat_max,width_hat)
!
      if (nzgrid>1) then
         zlim = (z1-z0)*rad
         zmid = z0+(z1-z0)/2.
         zhat_min=zmid-zlim/2.
         zhat_max=zmid+zlim/2
         hatprofz= step(z(n1:n2),zhat_min,width_hat) &
                  -step(z(n1:n2),zhat_max,width_hat)
      endif
!
      do j=1,size(prof,1)
         do k=1,size(prof,2)
            if (nzgrid>1) then
               prof(j,k)= vel*hatprofy(j)*hatprofz(k)
            else
               prof(j,k)= vel*hatprofy(j)
            endif
         enddo
      enddo
!
    endsubroutine jet_x
! **********************************************************************
    subroutine bc_set_nfr_y(f,topbot,j)
!
!  Normal field boundary condition for spherical coordinate system.
!  d_{\theta}(A_{\phi}) = -A_{\phi}cot(\theta)/r with A_{\theta} = 0 sets
!  B_r = B_{\phi} = 0 in spherical polar coordinate system. This subroutine
!  sets only the first part of this boundary condition for 'j'-th component
!  of f.
!
!  25-Aug-2007/dhruba: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent (in) :: j
      integer :: k
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        do k=1,nghost
          f(:,m1-k,:,j)= f(:,m1+k,:,j)*(sinth(m1+k)/sin(y(m1+k)-dy2_bound(-k)))
        enddo
      case(TOP)               ! top boundary
        do k=1,nghost
          f(:,m2+k,:,j)= f(:,m2-k,:,j)*(sinth(m2-k)/sin(y(m2-k)+dy2_bound(k)))
        enddo
!
      case default
        call fatal_error('bc_set_nfr_y',"topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_set_nfr_y
! **********************************************************************
    subroutine bc_set_sfree_y(f,topbot,j)
!
!  Stress-free boundary condition for spherical coordinate system.
!  d_{\theta}(u_{\phi}) = u_{\phi}cot(\theta)  with u_{\theta} = 0 sets
!  S_{\theta \phi} component of the strain matrix to be zero in spherical
!  coordinate system. This subroutine sets only the first part of this
!  boundary condition for 'j'-th component of f.
!  Note that llambda_scale_with_nu is not implemented here yet.
!
!  25-Aug-2007/dhruba: coded
!
      use SharedVariables, only : get_shared_variable
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent (in) :: j
      real, pointer :: Lambda_H1,nu
      real, pointer :: LH1_rprof(:)
      logical, pointer :: llambda_effect, llambda_scale_with_nu
      integer :: k,ix
      real :: cos2thm_k,cos2thmpk,somega
      real,dimension(size(f,1)):: LH1
!
! -------- Either case get the lambda variables first -----------
!
      call get_shared_variable('nu',nu,caller='bc_set_sfree_y')
      call get_shared_variable('llambda_effect',llambda_effect)
      if (llambda_effect) then
        call get_shared_variable('llambda_scale_with_nu',llambda_scale_with_nu)
        call get_shared_variable('Lambda_H1',Lambda_H1)
        call get_shared_variable('LH1_rprof',LH1_rprof)
        LH1=Lambda_H1*LH1_rprof
      endif
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        if (llambda_effect.and.(j==iuz)) then
          if (Lambda_H1/=0.) then
            do k=1,nghost
              cos2thm_k= costh(m1-k)**2-sinth(m1-k)**2
              cos2thmpk= costh(m1+k)**2-sinth(m1+k)**2
              if (Omega==0) then
                do ix=1,size(f,1)
                  if (llambda_scale_with_nu) then
                    f(ix,m1-k,:,j)= f(ix,m1+k,:,j)* &
                         (exp(LH1(ix)*cos2thmpk/(4.))*sin1th(m1+k)) &
                         *(exp(-LH1(ix)*cos2thm_k/(4.))*sinth(m1-k))
                  else
                    f(ix,m1-k,:,j)= f(ix,m1+k,:,j)* &
                         (exp(LH1(ix)*cos2thmpk/(4.*nu))*sin1th(m1+k)) &
                         *(exp(-LH1(ix)*cos2thm_k/(4.*nu))*sinth(m1-k))
                  endif
                enddo
              else
                do ix=1,size(f,1)
! DM+GG: temporally commented out
!                somega=x(ix)*Omega*sinth(m1-k)*( &
!                   exp(2*cos2thm_k*LH1(ix)/(4.*nu))&
!                        -exp((cos2thmpk+cos2thm_k)*LH1(ix)/(4.*nu)) )
                  if (llambda_scale_with_nu) then
                    somega=x(ix)*Omega*sinth(m1-k)*( &
                       exp(cos2thmpk*LH1(ix)/(4.))&
                            /exp((cos2thm_k)*LH1(ix)/(4.)) -1.)
                    f(ix,m1-k,:,j)= f(ix,m1+k,:,j)* &
                       (exp(LH1(ix)*cos2thmpk/(4.))*sin1th(m1+k)) &
                       *(exp(-LH1(ix)*cos2thm_k/(4.))*sinth(m1-k)) &
                          +somega
                  else
                    somega=x(ix)*Omega*sinth(m1-k)*( &
                       exp(cos2thmpk*LH1(ix)/(4.*nu))&
                            /exp((cos2thm_k)*LH1(ix)/(4.*nu)) -1.)
                    f(ix,m1-k,:,j)= f(ix,m1+k,:,j)* &
                       (exp(LH1(ix)*cos2thmpk/(4.*nu))*sin1th(m1+k)) &
                       *(exp(-LH1(ix)*cos2thm_k/(4.*nu))*sinth(m1-k)) &
                          +somega
                  endif
                enddo
              endif
            enddo
          endif
        else
          do k=1,nghost
            f(:,m1-k,:,j)= f(:,m1+k,:,j)*(sin(y(m1+k)-dy2_bound(-k))*sin1th(m1+k))
          enddo
        endif
      case(TOP)               ! top boundary
        if ((llambda_effect).and.(j==iuz)) then
          if (Lambda_H1/=0.) then
            do k=1,nghost
              cos2thm_k= costh(m2-k)**2-sinth(m2-k)**2
              cos2thmpk= costh(m2+k)**2-sinth(m2+k)**2
              if (Omega==0)then
                do ix=1,size(f,1)
                  if (llambda_scale_with_nu) then
                    f(ix,m2+k,:,j)= f(ix,m2-k,:,j)* &
                     (exp(LH1(ix)*cos2thm_k/(4.))*sin1th(m2-k)) &
                    *(exp(-LH1(ix)*cos2thmpk/(4.))*sinth(m2+k))
                  else
                    f(ix,m2+k,:,j)= f(ix,m2-k,:,j)* &
                     (exp(LH1(ix)*cos2thm_k/(4.*nu))*sin1th(m2-k)) &
                    *(exp(-LH1(ix)*cos2thmpk/(4.*nu))*sinth(m2+k))
                  endif
                enddo
              else
                do ix=1,size(f,1)
! DM+GG: Temporally comented out
!                somega=x(ix)*Omega*sinth(m2+k)*( &
!                   exp(2*cos2thmpk*LH1(ix)/(4.*nu))&
!                        -exp((cos2thmpk+cos2thm_k)*LH1(ix)/(4.*nu)) )
                  if (llambda_scale_with_nu) then
                    somega=x(ix)*Omega*sinth(m2+k)*( &
                      exp(cos2thm_k*LH1(ix)/(4.))    &
                     /exp(cos2thmpk*LH1(ix)/(4.))-1.)
                    f(ix,m2+k,:,j)= f(ix,m2-k,:,j)* &
                       (exp(LH1(ix)*cos2thm_k/(4.))*sin1th(m2-k)) &
                      *(exp(-LH1(ix)*cos2thmpk/(4.))*sinth(m2+k)) &
                        +somega
                  else
                    somega=x(ix)*Omega*sinth(m2+k)*( &
                      exp(cos2thm_k*LH1(ix)/(4.*nu))    &
                     /exp(cos2thmpk*LH1(ix)/(4.*nu))-1.)
                    f(ix,m2+k,:,j)= f(ix,m2-k,:,j)* &
                       (exp(LH1(ix)*cos2thm_k/(4.*nu))*sin1th(m2-k)) &
                      *(exp(-LH1(ix)*cos2thmpk/(4.*nu))*sinth(m2+k)) &
                        +somega
                  endif
                enddo
              endif
            enddo
          endif
        else
          do k=1,nghost
            f(:,m2+k,:,j)= f(:,m2-k,:,j)*(sin(y(m2-k)+dy2_bound(k))*sin1th(m2-k))
          enddo
        endif
!
     case default
        call fatal_error('bc_set_sfree_y',"topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_set_sfree_y
! **********************************************************************
    subroutine bc_set_pfc_y(f,topbot,j)
!
!joern: WARNING, this bc will NOT give a perfect-conductor boundary condition
!
!  In spherical polar coordinate system,
!  at a theta boundary set : $A_{r} = 0$ and $A_{\phi} = 0$,
!  and demand $div A = 0$ gives the condition on $A_{\theta}$ to be
!  $d/d{\theta}( A_{\theta}) + \cot(\theta)A_{\theta} = 0$ .
!  This subroutine sets this condition on
!  $j$ the component of f. As this is related to setting the
!  perfect conducting boundary condition we call this "pfc".
!
!  25-Aug-2007/dhruba: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent (in) :: j
      real :: cottheta
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
!
!  The coding assumes we are using 6-th order centered finite difference for our
!  derivatives.
!
        cottheta= cotth(m1)
        f(:,m1-1,:,j)= f(:,m1+1,:,j) +  60.*dy*cottheta*f(:,m1,:,j)/45.
        f(:,m1-2,:,j)= f(:,m1+2,:,j) -  60.*dy*cottheta*f(:,m1,:,j)/9.
        f(:,m1-3,:,j)= f(:,m1+3,:,j) +  60.*dy*cottheta*f(:,m1,:,j)
      case(TOP)               ! top boundary
        cottheta= cotth(m2)
        f(:,m2+1,:,j)= f(:,m2-1,:,j) -  60.*dy*cottheta*f(:,m2,:,j)/45.
        f(:,m2+2,:,j)= f(:,m2-2,:,j) +  60.*dy*cottheta*f(:,m2,:,j)/9.
        f(:,m2+3,:,j)= f(:,m2-3,:,j) -  60.*dy*cottheta*f(:,m2,:,j)
!
      case default
        call fatal_error('bc_set_pfc_y',"topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_set_pfc_y
!***********************************************************************
    subroutine bc_set_der_y(f,topbot,j,val)
!
!  Sets the derivative on the boundary to a given value.
!
!  14-may-2006/tobi: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent (in) :: j
      real, intent (in) :: val
!
      integer :: i
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        do i=1,nghost; f(:,m1-i,:,j) = f(:,m1+i,:,j) - dy2_bound(-i)*val; enddo
!
      case(TOP)               ! top boundary
        do i=1,nghost; f(:,m2+i,:,j) = f(:,m2-i,:,j) + dy2_bound(i)*val; enddo
!
      case default
        call fatal_error('bc_set_der_y',"topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_set_der_y
!***********************************************************************
    subroutine bc_set_der_z(f,topbot,j,val)
!
!  Sets the derivative on the boundary to a given value.
!
!  14-may-2006/tobi: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent (in) :: j
      real, intent (in) :: val
!
      integer :: i
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        do i=1,nghost; f(:,:,n1-i,j) = f(:,:,n1+i,j) - dz2_bound(-i)*val; enddo
!
      case(TOP)               ! top boundary
        do i=1,nghost; f(:,:,n2+i,j) = f(:,:,n2-i,j) + dz2_bound(i)*val; enddo
!
      case default
        call fatal_error('bc_set_der_z',"topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_set_der_z
!***********************************************************************
    subroutine bc_set_div_z(f,topbot,j,val)
!
!  Sets the derivative on the boundary to a given value
!
!  17-may-2010/bing: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:), intent (inout) :: f
      real, dimension (l2-l1+1,m2-m1+1) :: fac,duz_dz
      real, intent(in) :: val
!
      integer, intent (in) :: j
!
      integer :: iref=-1,pos,nxl,nyl
!
      if (j/=iuz) call fatal_error_local('bc_set_div_z','please set div for uz only')
!
      nxl=l2-l1+1; nyl=m2-m1+1
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        iref = n1
!
      case(TOP)               ! top boundary
        iref = n2
!
      case default
        call fatal_error('bc_set_der_x',"topbot should be BOT or TOP")
!
      endselect
!
! take the x derivative of ux
      if (nxgrid/=1) then
        fac=(1./60)*spread(dx_1(l1:l2),2,nyl)
        duz_dz= fac*(+45.0*(f(l1+1:l2+1,m1:m2,iref,iux)-f(l1-1:l2-1,m1:m2,iref,iux)) &
                     - 9.0*(f(l1+2:l2+2,m1:m2,iref,iux)-f(l1-2:l2-2,m1:m2,iref,iux)) &
                     +     (f(l1+3:l2+3,m1:m2,iref,iux)-f(l1-3:l2-3,m1:m2,iref,iux)))
      else
        if (ip<=5) print*, 'bc_set_div_z: Degenerate case in x-direction'
      endif
!
! take the y derivative of uy and add to dux/dx
      if (nygrid/=1) then
        fac=(1./60)*spread(dy_1(m1:m2),1,nxl)
        duz_dz=duz_dz + fac*(+45.0*(f(l1:l2,m1+1:m2+1,iref,iuy)-f(l1:l2,m1-1:m2-1,iref,iuy)) &
                             - 9.0*(f(l1:l2,m1+2:m2+2,iref,iuy)-f(l1:l2,m1-2:m2-2,iref,iuy)) &
                             +     (f(l1:l2,m1+3:m2+3,iref,iuy)-f(l1:l2,m1-3:m2-3,iref,iuy)))
      else
        if (ip<=5) print*, 'bc_set_div_z: Degenerate case in y-direction'
      endif
!
! add given number to set div(u)=val; default val=0
! duz/dz = val - dux/dx - duy/dy
!
      duz_dz = val - duz_dz
!
! set the derivative of uz at the boundary
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        do pos=1,nghost
          f(l1:l2,m1:m2,n1-pos,j) = f(l1:l2,m1:m2,n1+pos,j) - dz2_bound(-pos)*duz_dz
        enddo
!
      case(TOP)               ! top boundary
        do pos=1,nghost
          f(l1:l2,m1:m2,n2+pos,j) = f(l1:l2,m1:m2,n2-pos,j) + dz2_bound(pos)*duz_dz
        enddo
!
      case default
        call fatal_error('bc_set_div_z',"topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_set_div_z
!***********************************************************************
    subroutine bc_van_x(f,topbot,j)
!
!  Vanishing boundary conditions.
!  (TODO: clarify what this means)
!
!  26-apr-06/tobi: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: i,j
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
          do i=1,nghost
            f(l1-i,:,:,j)=((nghost+1-i)*f(l1,:,:,j))/(nghost+1)
          enddo
!
      case(TOP)               ! top boundary
          do i=1,nghost
            f(l2+i,:,:,j)=((nghost+1-i)*f(l2,:,:,j))/(nghost+1)
          enddo
!
      case default
        call fatal_error("bc_van_x: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_van_x
!***********************************************************************
    subroutine bc_van_y(f,topbot,j)
!
!  Vanishing boundary conditions.
!  (TODO: clarify what this means)
!
!  26-apr-06/tobi: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: i,j
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
          do i=1,nghost
            f(:,m1-i,:,j)=((nghost+1-i)*f(:,m1,:,j))/(nghost+1)
          enddo
!
      case(TOP)               ! top boundary
          do i=1,nghost
            f(:,m2+i,:,j)=((nghost+1-i)*f(:,m2,:,j))/(nghost+1)
          enddo
!
      case default
        call fatal_error("bc_van_y: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_van_y
!***********************************************************************
    subroutine bc_van_z(f,topbot,j)
!
!  Vanishing boundary conditions.
!  (TODO: clarify what this means)
!
!  26-apr-06/tobi: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: i,j
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
          do i=1,nghost
            f(:,:,n1-i,j)=((nghost+1-i)*f(:,:,n1,j))/(nghost+1)
          enddo
!
      case(TOP)               ! top boundary
          do i=1,nghost
            f(:,:,n2+i,j)=((nghost+1-i)*f(:,:,n2,j))/(nghost+1)
          enddo
!
      case default
        call fatal_error("bc_van_z: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_van_z
!***********************************************************************
    subroutine bc_van3rd_y(f,topbot,j)
!
!  Boundary condition with vanishing 3rd derivative
!  (useful for vertical hydrostatic equilibrium in discs)
!
!  30-jul-13/wlad: copied from z
!  18-mar-22/wlad+debanjan: differentiated between log quantities
!                           (lnrho and ss) and linear quantities (rho)     
!
!  TODO: generalize for all log and all linear quantities
!        or else, just code a separate van3rd_log subroutine      
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j
!
      real, dimension (size(f,1),size(f,3)) :: cpoly0,cpoly1,cpoly2
      integer :: i
!
      if (.not.((j==irho).or.(j==ilnrho).or.(j==iss))) &
           call fatal_error("bc_van3rd_y",&
           "boundary coded only for density and entropy")
!
      select case (topbot)
!
      case(BOT)
        if (j==irho) then
          cpoly0(:,:)=alog(f(:,m1,:,j))
          cpoly1(:,:)=-(3*alog(f(:,m1,:,j))-4*alog(f(:,m1+1,:,j))+alog(f(:,m1+2,:,j)))/(2*dy)
          cpoly2(:,:)=-(-alog(f(:,m1,:,j))+2*alog(f(:,m1+1,:,j))-alog(f(:,m1+2,:,j))) /(2*dy**2)
          do i=1,nghost
            f(:,m1-i,:,j) = exp(cpoly0(:,:) - cpoly1(:,:)*i*dy + cpoly2(:,:)*(i*dy)**2)
          enddo
        elseif (j==ilnrho .or. j==iss) then
          cpoly0(:,:)=f(:,m1,:,j)
          cpoly1(:,:)=-(3*f(:,m1,:,j)-4*f(:,m1+1,:,j)+f(:,m1+2,:,j))/(2*dy)
          cpoly2(:,:)=-(-f(:,m1,:,j)+2*f(:,m1+1,:,j)-f(:,m1+2,:,j)) /(2*dy**2)
          do i=1,nghost
            f(:,m1-i,:,j) = cpoly0(:,:) - cpoly1(:,:)*i*dy + cpoly2(:,:)*(i*dy)**2
          enddo
        else
          call fatal_error("bc_van3rd_y","The world is flat and we never got here")
        endif
!
      case(TOP)
        if (j==irho) then
          cpoly0(:,:)=alog(f(:,m2,:,j))
          cpoly1(:,:)=-(-3*alog(f(:,m2,:,j))+4*alog(f(:,m2-1,:,j))-alog(f(:,m2-2,:,j)))/(2*dy)
          cpoly2(:,:)=-(-alog(f(:,m2,:,j))+2*alog(f(:,m2-1,:,j))-alog(f(:,m2-2,:,j)))/(2*dy**2)
          do i=1,nghost
            f(:,m2+i,:,j) = exp(cpoly0(:,:) + cpoly1(:,:)*i*dy + cpoly2(:,:)*(i*dy)**2)
          enddo
        elseif (j==ilnrho .or. j==iss) then
          cpoly0(:,:)=f(:,m2,:,j)
          cpoly1(:,:)=-(-3*f(:,m2,:,j)+4*f(:,m2-1,:,j)-f(:,m2-2,:,j))/(2*dy)
          cpoly2(:,:)=-(-f(:,m2,:,j)+2*f(:,m2-1,:,j)-f(:,m2-2,:,j))/(2*dy**2)
          do i=1,nghost
            f(:,m2+i,:,j) = cpoly0(:,:) + cpoly1(:,:)*i*dy + cpoly2(:,:)*(i*dy)**2
          enddo
        else
          call fatal_error("bc_van3rd_y","The world is flat and we never got here")
        endif
!
      endselect
!
    endsubroutine bc_van3rd_y
!***********************************************************************
    subroutine bc_van3rd_z(f,topbot,j)
!
!  Boundary condition with vanishing 3rd derivative
!  (useful for vertical hydrostatic equilibrium in discs)
!
!  19-aug-03/anders: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j
!
      real, dimension (size(f,1),size(f,2)) :: cpoly0,cpoly1,cpoly2
      integer :: i
!
      select case (topbot)
!
      case(BOT)
        cpoly0=f(:,:,n1,j)
        cpoly1=-(3*f(:,:,n1,j)-4*f(:,:,n1+1,j)+f(:,:,n1+2,j))/(2*dz)
        cpoly2=-(-f(:,:,n1,j)+2*f(:,:,n1+1,j)-f(:,:,n1+2,j)) /(2*dz**2)
        do i=1,nghost
          f(:,:,n1-i,j) = cpoly0 - cpoly1*i*dz + cpoly2*(i*dz)**2
        enddo
!
      case(TOP)
        cpoly0=f(:,:,n2,j)
        cpoly1=-(-3*f(:,:,n2,j)+4*f(:,:,n2-1,j)-f(:,:,n2-2,j))/(2*dz)
        cpoly2=-(-f(:,:,n2,j)+2*f(:,:,n2-1,j)-f(:,:,n2-2,j))/(2*dz**2)
        do i=1,nghost
          f(:,:,n2+i,j) = cpoly0 + cpoly1*i*dz + cpoly2*(i*dz)**2
        enddo
!
      endselect
!
    endsubroutine bc_van3rd_z
!***********************************************************************
    subroutine bc_onesided_x_old(f,topbot,j)
!
!  One-sided conditions.
!  These expressions result from combining Eqs(207)-(210), astro-ph/0109497,
!  corresponding to (9.207)-(9.210) in Ferriz-Mas proceedings.
!
!  05-apr-03/axel: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: i,j,k
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        do i=1,nghost
          k=l1-i
          f(k,:,:,j)=7*f(k+1,:,:,j) &
                   -21*f(k+2,:,:,j) &
                   +35*f(k+3,:,:,j) &
                   -35*f(k+4,:,:,j) &
                   +21*f(k+5,:,:,j) &
                    -7*f(k+6,:,:,j) &
                      +f(k+7,:,:,j)
        enddo
!
      case(TOP)               ! top boundary
        do i=1,nghost
          k=l2+i
          f(k,:,:,j)=7*f(k-1,:,:,j) &
                   -21*f(k-2,:,:,j) &
                   +35*f(k-3,:,:,j) &
                   -35*f(k-4,:,:,j) &
                   +21*f(k-5,:,:,j) &
                    -7*f(k-6,:,:,j) &
                      +f(k-7,:,:,j)
        enddo
!
      case default
        call fatal_error("bc_onesided_x_old ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_onesided_x_old
!***********************************************************************
    subroutine bc_onesided_z_orig(f,topbot,j)
!
!  One-sided conditions.
!  These expressions result from combining Eqs(207)-(210), astro-ph/0109497,
!  corresponding to (9.207)-(9.210) in Ferriz-Mas proceedings.
!
!  05-apr-03/axel: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: i,j,k
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        do i=1,nghost
          k=n1-i
          f(:,:,k,j)=7*f(:,:,k+1,j) &
                   -21*f(:,:,k+2,j) &
                   +35*f(:,:,k+3,j) &
                   -35*f(:,:,k+4,j) &
                   +21*f(:,:,k+5,j) &
                    -7*f(:,:,k+6,j) &
                      +f(:,:,k+7,j)
        enddo
!
      case(TOP)               ! top boundary
        do i=1,nghost
          k=n2+i
          f(:,:,k,j)=7*f(:,:,k-1,j) &
                   -21*f(:,:,k-2,j) &
                   +35*f(:,:,k-3,j) &
                   -35*f(:,:,k-4,j) &
                   +21*f(:,:,k-5,j) &
                    -7*f(:,:,k-6,j) &
                      +f(:,:,k-7,j)
        enddo
!
      case default
        call fatal_error("bc_onesided_z ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_onesided_z_orig
!***********************************************************************
    subroutine bc_extrap_2_1(f,topbot,j)
!
!  Extrapolation boundary condition.
!  Correct for polynomials up to 2nd order, determined 1 further degree
!  of freedom by minimizing L2 norm of coefficient vector.
!
!  19-jun-03/wolf: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        f(:,:,n1-1,j)=0.25*(  9*f(:,:,n1,j)- 3*f(:,:,n1+1,j)- 5*f(:,:,n1+2,j)+ 3*f(:,:,n1+3,j))
        f(:,:,n1-2,j)=0.05*( 81*f(:,:,n1,j)-43*f(:,:,n1+1,j)-57*f(:,:,n1+2,j)+39*f(:,:,n1+3,j))
        f(:,:,n1-3,j)=0.05*(127*f(:,:,n1,j)-81*f(:,:,n1+1,j)-99*f(:,:,n1+2,j)+73*f(:,:,n1+3,j))
!
      case(TOP)               ! top boundary
        f(:,:,n2+1,j)=0.25*(  9*f(:,:,n2,j)- 3*f(:,:,n2-1,j)- 5*f(:,:,n2-2,j)+ 3*f(:,:,n2-3,j))
        f(:,:,n2+2,j)=0.05*( 81*f(:,:,n2,j)-43*f(:,:,n2-1,j)-57*f(:,:,n2-2,j)+39*f(:,:,n2-3,j))
        f(:,:,n2+3,j)=0.05*(127*f(:,:,n2,j)-81*f(:,:,n2-1,j)-99*f(:,:,n2-2,j)+73*f(:,:,n2-3,j))
!
      case default
        call fatal_error("bc_extrap_2_1: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_extrap_2_1
!***********************************************************************
    subroutine bcx_extrap_2_1(f,topbot,j)
!
!  Extrapolation boundary condition for x.
!  Correct for polynomials up to 2nd order, determined 1 further degree
!  of freedom by minimizing L2 norm of coefficient vector.
!
!  19-jun-03/wolf: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        f(l1-1,:,:,j)=0.25*(  9*f(l1,:,:,j)- 3*f(l1+1,:,:,j)- 5*f(l1+2,:,:,j)+ 3*f(l1+3,:,:,j))
        f(l1-2,:,:,j)=0.05*( 81*f(l1,:,:,j)-43*f(l1+1,:,:,j)-57*f(l1+2,:,:,j)+39*f(l1+3,:,:,j))
        f(l1-3,:,:,j)=0.05*(127*f(l1,:,:,j)-81*f(l1+1,:,:,j)-99*f(l1+2,:,:,j)+73*f(l1+3,:,:,j))
!
      case(TOP)               ! top boundary
        f(l2+1,:,:,j)=0.25*(  9*f(l2,:,:,j)- 3*f(l2-1,:,:,j)- 5*f(l2-2,:,:,j)+ 3*f(l2-3,:,:,j))
        f(l2+2,:,:,j)=0.05*( 81*f(l2,:,:,j)-43*f(l2-1,:,:,j)-57*f(l2-2,:,:,j)+39*f(l2-3,:,:,j))
        f(l2+3,:,:,j)=0.05*(127*f(l2,:,:,j)-81*f(l2-1,:,:,j)-99*f(l2-2,:,:,j)+73*f(l2-3,:,:,j))
!
      case default
        call fatal_error("bcx_extrap_2_1: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bcx_extrap_2_1
!***********************************************************************
    subroutine bcy_extrap_2_1(f,topbot,j)
!
!  Extrapolation boundary condition for y.
!  Correct for polynomials up to 2nd order, determined 1 further degree
!  of freedom by minimizing L2 norm of coefficient vector.
!
!  19-jun-03/wolf: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        f(:,m1-1,:,j)=0.25*(  9*f(:,m1,:,j)- 3*f(:,m1+1,:,j)- 5*f(:,m1+2,:,j)+ 3*f(:,m1+3,:,j))
        f(:,m1-2,:,j)=0.05*( 81*f(:,m1,:,j)-43*f(:,m1+1,:,j)-57*f(:,m1+2,:,j)+39*f(:,m1+3,:,j))
        f(:,m1-3,:,j)=0.05*(127*f(:,m1,:,j)-81*f(:,m1+1,:,j)-99*f(:,m1+2,:,j)+73*f(:,m1+3,:,j))
!
      case(TOP)               ! top boundary
        f(:,m2+1,:,j)=0.25*(  9*f(:,m2,:,j)- 3*f(:,m2-1,:,j)- 5*f(:,m2-2,:,j)+ 3*f(:,m2-3,:,j))
        f(:,m2+2,:,j)=0.05*( 81*f(:,m2,:,j)-43*f(:,m2-1,:,j)-57*f(:,m2-2,:,j)+39*f(:,m2-3,:,j))
        f(:,m2+3,:,j)=0.05*(127*f(:,m2,:,j)-81*f(:,m2-1,:,j)-99*f(:,m2-2,:,j)+73*f(:,m2-3,:,j))
!
      case default
        call fatal_error("bcy_extrap_2_1: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bcy_extrap_2_1
!***********************************************************************
    subroutine bc_extrap_2_2(f,topbot,j)
!
!  Extrapolation boundary condition.
!  Correct for polynomials up to 2nd order, determined 2 further degrees
!  of freedom by minimizing L2 norm of coefficient vector.
!
!  19-jun-03/wolf: coded
!  01-jul-03/axel: introduced abbreviations n1p4,n2m4
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j,n1p4,n2m4
!
!  abbreviations, because otherwise the ifc compiler complains
!  for 1-D runs without vertical extent
!
      n1p4=n1+4
      n2m4=n2-4
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        f(:,:,n1-1,j)=0.2   *(  9*f(:,:,n1,j)                 -  4*f(:,:,n1+2,j)- 3*f(:,:,n1+3,j)+ 3*f(:,:,n1p4,j))
        f(:,:,n1-2,j)=0.2   *( 15*f(:,:,n1,j)- 2*f(:,:,n1+1,j)-  9*f(:,:,n1+2,j)- 6*f(:,:,n1+3,j)+ 7*f(:,:,n1p4,j))
        f(:,:,n1-3,j)=1./35.*(157*f(:,:,n1,j)-33*f(:,:,n1+1,j)-108*f(:,:,n1+2,j)-68*f(:,:,n1+3,j)+87*f(:,:,n1p4,j))
!
      case(TOP)               ! top boundary
        f(:,:,n2+1,j)=0.2   *(  9*f(:,:,n2,j)                 -  4*f(:,:,n2-2,j)- 3*f(:,:,n2-3,j)+ 3*f(:,:,n2m4,j))
        f(:,:,n2+2,j)=0.2   *( 15*f(:,:,n2,j)- 2*f(:,:,n2-1,j)-  9*f(:,:,n2-2,j)- 6*f(:,:,n2-3,j)+ 7*f(:,:,n2m4,j))
        f(:,:,n2+3,j)=1./35.*(157*f(:,:,n2,j)-33*f(:,:,n2-1,j)-108*f(:,:,n2-2,j)-68*f(:,:,n2-3,j)+87*f(:,:,n2m4,j))
!
      case default
        call fatal_error("bc_extrap_2_2: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_extrap_2_2
!***********************************************************************
    subroutine bcx_extrap_2_2(f,topbot,j)
!
!  Extrapolation boundary condition.
!  Correct for polynomials up to 2nd order, determined 2 further degrees
!  of freedom by minimizing L2 norm of coefficient vector.
!
!  19-jun-03/wolf: coded
!  01-jul-03/axel: introduced abbreviations n1p4,n2m4
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j,l1p4,l2m4
!
!  abbreviations, because otherwise the ifc compiler complains
!  for 1-D runs without vertical extent
!
      l1p4=l1+4
      l2m4=l2-4
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        f(l1-1,:,:,j)=0.2   *(  9*f(l1,:,:,j)                 -  4*f(l1+2,:,:,j)- 3*f(l1+3,:,:,j)+ 3*f(l1p4,:,:,j))
        f(l1-2,:,:,j)=0.2   *( 15*f(l1,:,:,j)- 2*f(l1+1,:,:,j)-  9*f(l1+2,:,:,j)- 6*f(l1+3,:,:,j)+ 7*f(l1p4,:,:,j))
        f(l1-3,:,:,j)=1./35.*(157*f(l1,:,:,j)-33*f(l1+1,:,:,j)-108*f(l1+2,:,:,j)-68*f(l1+3,:,:,j)+87*f(l1p4,:,:,j))
!
      case(TOP)               ! top boundary
        f(l2+1,:,:,j)=0.2   *(  9*f(l2,:,:,j)                 -  4*f(l2-2,:,:,j)- 3*f(l2-3,:,:,j)+ 3*f(l2m4,:,:,j))
        f(l2+2,:,:,j)=0.2   *( 15*f(l2,:,:,j)- 2*f(l2-1,:,:,j)-  9*f(l2-2,:,:,j)- 6*f(l2-3,:,:,j)+ 7*f(l2m4,:,:,j))
        f(l2+3,:,:,j)=1./35.*(157*f(l2,:,:,j)-33*f(l2-1,:,:,j)-108*f(l2-2,:,:,j)-68*f(l2-3,:,:,j)+87*f(l2m4,:,:,j))
!
      case default
        call fatal_error("bcx_extrap_2_2: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bcx_extrap_2_2
!***********************************************************************
    subroutine bcx_extrap_frac_2(f,topbot,j)
!
!  Extrapolation boundary condition.
!  Correct for polynomials up to 2nd order, determined 2 further degrees
!  of freedom by minimizing L2 norm of coefficient vector.
!
!  19-jun-03/wolf: coded
!  01-jul-03/axel: introduced abbreviations n1p4,n2m4
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real :: frac=0.8
      integer :: j,l1p4,l2m4
!
!  abbreviations, because otherwise the ifc compiler complains
!  for 1-D runs without vertical extent
!
      l1p4=l1+4
      l2m4=l2-4
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        if ((j .eq. ilnrho) .or. (j .eq. ilnTT)) then
          f(l1-1,:,:,j)=0.2*(9*f(l1,:,:,j) -  4*f(l1+2,:,:,j)- 3*f(l1+3,:,:,j)+3*f(l1p4,:,:,j))+alog(frac)
          f(l1-2,:,:,j)=0.2*(15*f(l1,:,:,j)- 2*f(l1+1,:,:,j)-  9*f(l1+2,:,:,j)-6*f(l1+3,:,:,j)+ 7*f(l1p4,:,:,j))+alog(frac)
          f(l1-3,:,:,j)=1.0/35.*(157*f(l1,:,:,j)-33*f(l1+1,:,:,j)-108*f(l1+2,:,:,j)-68*f(l1+3,:,:,j)+87*f(l1p4,:,:,j))+alog(frac)
        else
          f(l1-1,:,:,j)=0.2   *(  9*f(l1,:,:,j)                 -4*f(l1+2,:,:,j)- 3*f(l1+3,:,:,j)+ 3*f(l1p4,:,:,j))
          f(l1-2,:,:,j)=0.2   *( 15*f(l1,:,:,j)- 2*f(l1+1,:,:,j)-9*f(l1+2,:,:,j)- 6*f(l1+3,:,:,j)+ 7*f(l1p4,:,:,j))
          f(l1-3,:,:,j)=1./35.*(157*f(l1,:,:,j)-33*f(l1+1,:,:,j)-108*f(l1+2,:,:,j)-68*f(l1+3,:,:,j)+87*f(l1p4,:,:,j))
        endif
!
      case(TOP)               ! top boundary
        if ((j .eq. ilnrho) .or. (j .eq. ilnTT)) then
          f(l2+1,:,:,j)=0.2*(  9*f(l2,:,:,j)-4*f(l2-2,:,:,j)- 3*f(l2-3,:,:,j)+ 3*f(l2m4,:,:,j))+alog(frac)
          f(l2+2,:,:,j)=0.2*( 15*f(l2,:,:,j)- 2*f(l2-1,:,:,j)-9*f(l2-2,:,:,j)- 6*f(l2-3,:,:,j)+ 7*f(l2m4,:,:,j))+alog(frac)
          f(l2+3,:,:,j)=1.0/35.*(157*f(l2,:,:,j)-33*f(l2-1,:,:,j)-108*f(l2-2,:,:,j)-68*f(l2-3,:,:,j)+87*f(l2m4,:,:,j))+alog(frac)
        else
          f(l2+1,:,:,j)=0.2   *(  9*f(l2,:,:,j)                 - 4*f(l2-2,:,:,j)- 3*f(l2-3,:,:,j)+ 3*f(l2m4,:,:,j))
          f(l2+2,:,:,j)=0.2   *( 15*f(l2,:,:,j)- 2*f(l2-1,:,:,j)-9*f(l2-2,:,:,j)- 6*f(l2-3,:,:,j)+ 7*f(l2m4,:,:,j))
          f(l2+3,:,:,j)=1./35.*(157*f(l2,:,:,j)-33*f(l2-1,:,:,j)-108*f(l2-2,:,:,j)-68*f(l2-3,:,:,j)+87*f(l2m4,:,:,j))
        endif
!
      case default
        call fatal_error("bcx_extrap_frac_2: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bcx_extrap_frac_2
!***********************************************************************
    subroutine bcy_extrap_2_2(f,topbot,j)
!
!  Extrapolation boundary condition.
!  Correct for polynomials up to 2nd order, determined 2 further degrees
!  of freedom by minimizing L2 norm of coefficient vector.
!
!   19-jun-03/wolf: coded
!   01-jul-03/axel: introduced abbreviations n1p4,n2m4
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j,m1p4,m2m4
!
!  abbreviations, because otherwise the ifc compiler complains
!  for 1-D runs without vertical extent
!
      m1p4=m1+4
      m2m4=m2-4
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        f(:,m1-1,:,j)=0.2   *(  9*f(:,m1,:,j)                 -  4*f(:,m1+2,:,j)- 3*f(:,m1+3,:,j)+ 3*f(:,m1p4,:,j))
        f(:,m1-2,:,j)=0.2   *( 15*f(:,m1,:,j)- 2*f(:,m1+1,:,j)-  9*f(:,m1+2,:,j)- 6*f(:,m1+3,:,j)+ 7*f(:,m1p4,:,j))
        f(:,m1-3,:,j)=1./35.*(157*f(:,m1,:,j)-33*f(:,m1+1,:,j)-108*f(:,m1+2,:,j)-68*f(:,m1+3,:,j)+87*f(:,m1p4,:,j))
!
      case(TOP)               ! top boundary
        f(:,m2+1,:,j)=0.2   *(  9*f(:,m2,:,j)                 -  4*f(:,m2-2,:,j)- 3*f(:,m2-3,:,j)+ 3*f(:,m2m4,:,j))
        f(:,m2+2,:,j)=0.2   *( 15*f(:,m2,:,j)- 2*f(:,m2-1,:,j)-  9*f(:,m2-2,:,j)- 6*f(:,m2-3,:,j)+ 7*f(:,m2m4,:,j))
        f(:,m2+3,:,j)=1./35.*(157*f(:,m2,:,j)-33*f(:,m2-1,:,j)-108*f(:,m2-2,:,j)-68*f(:,m2-3,:,j)+87*f(:,m2m4,:,j))
!
      case default
        call fatal_error("bcy_extrap_2_2: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bcy_extrap_2_2
!***********************************************************************
    subroutine bcy_extrap_2_3(f,topbot,j)
!
!  Extrapolation boundary condition in logarithm:
!  It maintains a power law
!
!  18-dec-08/wlad: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j,l,i
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        do i=1,nghost
          do n=1,size(f,3)
            do l=1,size(f,1)
              if (f(l,m1+i,n,j)/=0.) then
                f(l,m1-i,n,j)=f(l,m1,n,j)**2/f(l,m1+i,n,j)
              else
                f(l,m1-i,n,j)=0.
              endif
            enddo
          enddo
        enddo
!
      case(TOP)               ! top boundary
        do i=1,nghost
          do n=1,size(f,3)
            do l=1,size(f,1)
              if (f(l,m2-i,n,j)/=0.) then
                f(l,m2+i,n,j)=f(l,m2,n,j)**2/f(l,m2-i,n,j)
              else
                f(l,m2+i,n,j)=0.
              endif
            enddo
          enddo
        enddo
!
      case default
        call fatal_error("bcy_extrap_2_3: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bcy_extrap_2_3
!***********************************************************************
    subroutine bc_extrap0_2_0(f,topbot,j)
!
!  Extrapolation boundary condition for f(bdry)=0.
!  Correct for polynomials up to 2nd order, determined no further degree
!  of freedom by minimizing L2 norm of coefficient vector.
!
!  09-oct-03/wolf: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j
!
      select case (topbot)
!
! Nyquist-filtering
!
      case(BOT)
! bottom boundary
        f(:,:,n1  ,j)=0.        ! set bdry value=0 (indep of initcond)
        f(:,:,n1-1,j)=(1/11.)*&
             (-17*f(:,:,n1+1,j)- 9*f(:,:,n1+2,j)+ 8*f(:,:,n1+3,j))
        f(:,:,n1-2,j)=      2*&
             (- 2*f(:,:,n1+1,j)-   f(:,:,n1+2,j)+   f(:,:,n1+3,j))
        f(:,:,n1-3,j)=(3/11.)*&
             (-27*f(:,:,n1+1,j)-13*f(:,:,n1+2,j)+14*f(:,:,n1+3,j))
!
      case(TOP)
! top boundary
        f(:,:,n2  ,j)=0.        ! set bdry value=0 (indep of initcond)
        f(:,:,n2+1,j)=(1/11.)*&
             (-17*f(:,:,n2-1,j)- 9*f(:,:,n2-2,j)+ 8*f(:,:,n2-3,j))
        f(:,:,n2+2,j)=      2*&
             (- 2*f(:,:,n2-1,j)-   f(:,:,n2-2,j)+   f(:,:,n2-3,j))
        f(:,:,n2+3,j)=(3/11.)*&
             (-27*f(:,:,n2-1,j)-13*f(:,:,n2-2,j)+14*f(:,:,n2-3,j))
!
      case default
        call fatal_error("bc_extrap0_2_0: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_extrap0_2_0
!***********************************************************************
    subroutine bc_extrap0_2_1(f,topbot,j)
!
!  Extrapolation boundary condition for f(bdry)=0.
!  Correct for polynomials up to 2nd order, determined 1 further degree
!  of freedom by minimizing L2 norm of coefficient vector.
!
!  NOTE: This is not the final formula, but just bc_extrap_2_1() with f(bdry)=0
!
!  09-oct-03/wolf: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        f(:,:,n1  ,j)=0.        ! set bdry value=0 (indep of initcond)
        f(:,:,n1-1,j)=0.25*(- 3*f(:,:,n1+1,j)- 5*f(:,:,n1+2,j)+ 3*f(:,:,n1+3,j))
        f(:,:,n1-2,j)=0.05*(-43*f(:,:,n1+1,j)-57*f(:,:,n1+2,j)+39*f(:,:,n1+3,j))
        f(:,:,n1-3,j)=0.05*(-81*f(:,:,n1+1,j)-99*f(:,:,n1+2,j)+73*f(:,:,n1+3,j))
!
      case(TOP)               ! top boundary
        f(:,:,n2  ,j)=0.        ! set bdry value=0 (indep of initcond)
        f(:,:,n2+1,j)=0.25*(- 3*f(:,:,n2-1,j)- 5*f(:,:,n2-2,j)+ 3*f(:,:,n2-3,j))
        f(:,:,n2+2,j)=0.05*(-43*f(:,:,n2-1,j)-57*f(:,:,n2-2,j)+39*f(:,:,n2-3,j))
        f(:,:,n2+3,j)=0.05*(-81*f(:,:,n2-1,j)-99*f(:,:,n2-2,j)+73*f(:,:,n2-3,j))
!
      case default
        call fatal_error("bc_extrap0_2_1: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_extrap0_2_1
!***********************************************************************
    subroutine bc_extrap0_2_2(f,topbot,j)
!
!  Extrapolation boundary condition for f(bdry)=0.
!  Correct for polynomials up to 2nd order, determined 1 further degree
!  of freedom by minimizing L2 norm of coefficient vector.
!
!  NOTE: This is not the final formula, but just bc_extrap_2_2() with f(bdry)=0
!
!  09-oct-03/wolf: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j,n1p4,n2m4
!
!  abbreviations, because otherwise the ifc compiler complains
!  for 1-D runs without vertical extent
!
      n1p4=n1+4
      n2m4=n2-4
!
      select case (topbot)
!
      case(BOT)
! bottom boundary
        f(:,:,n1  ,j)= 0.       ! set bdry value=0 (indep of initcond)
        f(:,:,n1-1,j)=0.2   *(                 -  4*f(:,:,n1+2,j)- 3*f(:,:,n1+3,j)+ 3*f(:,:,n1p4,j))
        f(:,:,n1-2,j)=0.2   *(- 2*f(:,:,n1+1,j)-  9*f(:,:,n1+2,j)- 6*f(:,:,n1+3,j)+ 7*f(:,:,n1p4,j))
        f(:,:,n1-3,j)=1./35.*(-33*f(:,:,n1+1,j)-108*f(:,:,n1+2,j)-68*f(:,:,n1+3,j)+87*f(:,:,n1p4,j))
!
      case(TOP)
! top boundary
        f(:,:,n2  ,j)= 0.       ! set bdry value=0 (indep of initcond)
        f(:,:,n2+1,j)=0.2   *(                 -  4*f(:,:,n2-2,j)- 3*f(:,:,n2-3,j)+ 3*f(:,:,n2m4,j))
        f(:,:,n2+2,j)=0.2   *(- 2*f(:,:,n2-1,j)-  9*f(:,:,n2-2,j)- 6*f(:,:,n2-3,j)+ 7*f(:,:,n2m4,j))
        f(:,:,n2+3,j)=1./35.*(-33*f(:,:,n2-1,j)-108*f(:,:,n2-2,j)-68*f(:,:,n2-3,j)+87*f(:,:,n2m4,j))
!
      case default
        call fatal_error("bc_extrap0_2_2: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_extrap0_2_2
!***********************************************************************
    subroutine bcx_extrap_2_3(f,topbot,j)
!
!  Extrapolation boundary condition in logarithm:
!  It maintains a power law.
!
!  y_{b+i} = y_b + a * (x_{b+1} - x_b)
!
!  where a = (y_b - y_{b-1})/(x_b-x_{b-1})
!
!  18-dec-08/wlad: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j,i
      real :: yl1,ypi,ymi,xl1,xmi,xpi,yyi,xl2,yl2
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        do i=1,nghost
          do n=1,size(f,3);do m=1,size(f,2)
            yl1=alog(f(l1,m,n,j)) ; ypi=alog(f(l1+i,m,n,j))
            xl1=alog(x(l1)) ; xmi=alog(x(l1-i)) ; xpi=alog(x(l1+i))
!
            yyi = yl1 - (ypi-yl1)*(xl1-xmi)/(xpi-xl1)
            f(l1-i,m,n,j) = exp(yyi)
          enddo;enddo
        enddo
!
      case(TOP)               ! top boundary
        do i=1,nghost
          do n=1,size(f,3);do m=1,size(f,2)
            yl2=alog(f(l2,m,n,j)) ; ymi=alog(f(l2-i,m,n,j))
            xpi=alog(x(l2+i)) ; xl2=alog(x(l2)) ; xmi=alog(x(l2-i))
!
            yyi = yl2 + (yl2-ymi)*(xpi-xl2)/(xl2-xmi)
            f(l2+i,m,n,j) = exp(yyi)
          enddo;enddo
        enddo
!
      case default
        call fatal_error("bcx_extrap_2_3: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bcx_extrap_2_3
!***********************************************************************
    subroutine bcx_extrap_powerlaw(f,topbot,j,pj,llog)
!
!  Extrapolation boundary condition in logarithm:
!  It maintains a power law with index pj.
!
!  17-may-23/hongzhe: coded
!
      real, dimension (:,:,:,:) :: f
      integer, intent(IN) :: topbot
      integer :: j
      real :: pj
      logical, optional :: llog
!
      integer :: i
      logical :: lln=.false.
!
      if (present(llog)) lln=llog
!
      select case (topbot)
!
      case (BOT)
        do i=1,nghost
          if (lln) then
            f(l1-i,:,:,j) = f(l1,:,:,j)+pj*log(x(l1-i)/x(l1))
          else
            f(l1-i,:,:,j) = f(l1,:,:,j)*(x(l1-i)/x(l1))**pj
          endif
        enddo
!
      case (TOP)
        do i=1,nghost
          if (lln) then
            f(l2+i,:,:,j) = f(l2,:,:,j)+pj*log(x(l2+i)/x(l2))
          else
            f(l2+i,:,:,j) = f(l2,:,:,j)*(x(l2+i)/x(l2))**pj
          endif
        enddo
!
      case default
        print*, "bcx_extrap_powerlaw: ", topbot, " should be 'top' or 'bot'"
!
      endselect
!
    endsubroutine bcx_extrap_powerlaw
!***********************************************************************
    subroutine bcx_extrap_linear(f, topbot, j)
!
!  Applies linear extrapolation to the ghost cells.
!
!  05-jun-18/ccyang: coded.
!
      real, dimension(:,:,:,:), intent(inout) :: f
      integer, intent(IN) :: topbot
      integer, intent(in) :: j
!
      integer :: i
      real :: dx1
!
      select case (topbot)
!
      case(BOT)
        ! bottom (left end of the domain)
        dx1 = 1.0 / (x(l1+1) - x(l1))
        do i = 1, nghost
          f(l1-i,:,:,j) = (dx1 * (x(l1+1) - x(l1-i))) * f(l1,:,:,j) + (dx1 * (x(l1-i) - x(l1))) * f(l1+1,:,:,j)
        enddo
!
      case(TOP)
        ! top (right end of the domain)
        dx1 = 1.0 / (x(l2) - x(l2-1))
        do i = 1, nghost
          f(l2+i,:,:,j) = (dx1 * (x(l2) - x(l2+i))) * f(l2-1,:,:,j) + (dx1 * (x(l2+i) - x(l2-1))) * f(l2,:,:,j)
        enddo
!
      case default
        call fatal_error('bcx_extrap_linear', 'topbot should be BOT or TOP', lfirst_proc_xy)
!
      endselect
!
    endsubroutine bcx_extrap_linear
!***********************************************************************
    subroutine bcz_extrapol(f,topbot,j)
!
!  Simple linear extrapolation in first order.
!  The last two grid points are used to determine the slope.
!
!  23-nov-10/Bourdin.KIS: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: i, j
!
      real, dimension (size(f,1),size(f,2)) :: slope
!
!
      select case (topbot)
      case(BOT)
        ! bottom (left end of the domain)
        slope = (f(:,:,n1+1,j) - f(:,:,n1,j)) / dz2_bound(-1) 
        do i = 1, nghost
          f(:,:,n1-i,j) = f(:,:,n1,j) - slope * dz2_bound(-i) 
        enddo
      case(TOP)
        ! top (right end of the domain)
        slope = (f(:,:,n2,j) - f(:,:,n2-1,j)) / dz2_bound(1)
        do i = 1, nghost
          f(:,:,n2+i,j) = f(:,:,n2,j) + slope * dz2_bound(i) 
        enddo
      case default
        call fatal_error ('bcz_extrapol', 'topbot should be BOT or TOP', lfirst_proc_xy)
      endselect
!
    endsubroutine bcz_extrapol
!***********************************************************************
    subroutine bcz_extrapol_fixed(f,topbot,j)
!
!  Simple linear extrapolation in first order
!  with a fixed value in the first ghost cell.
!  The last two grid points are used to determine the slope.
!
!  23-nov-10/Bourdin.KIS: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: i, j
!
      real, dimension (size(f,1),size(f,2)) :: m
!
!
      select case (topbot)
      case(BOT)
        ! bottom (left end of the domain)
        m = (f(:,:,n1+1,j) - f(:,:,n1,j)) / (z(n1+1) - z(n1))
        do i = 2, nghost
          f(:,:,n1-i,j) = f(:,:,n1-1,j) + m * (z(n1-i) - z(n1-1))
        enddo
      case(TOP)
        ! top (right end of the domain)
        m = (f(:,:,n2,j) - f(:,:,n2-1,j)) / (z(n2) - z(n2-1))
        do i = 2, nghost
          f(:,:,n2+i,j) = f(:,:,n2+1,j) + m * (z(n2+i) - z(n2+1))
        enddo
      case default
        call fatal_error ('bcz_extrapol_fixed', 'topbot should be BOT or TOP', lfirst_proc_xy)
      endselect
!
    endsubroutine bcz_extrapol_fixed
!***********************************************************************
    subroutine bcz_extrapol_damped(f,topbot,j)
!
!  Simple linear extrapolation in first order
!  with an included damping to zero (useful for velocities).
!  The last two grid points are used to determine the slope.
!  The parameters 'fbcz_bot' and 'fbcz_top' are used as damping factors,
!  which should have values between 0.0 (no damping) and 1.0 (full damping).
!  A typical value of 0.001 corresponds to a half-value time of ~1000 timesteps.
!  Negative values let the damping be persistent, even if 'lfade_damp' is true.
!
!  23-nov-10/Bourdin.KIS: coded
!
      use SharedVariables, only: get_shared_variable
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: i, j
!
      real, dimension (size(f,1),size(f,2)) :: slope
      real :: gamma_bot, gamma_top, tau, fade_fact
      real, pointer :: tdamp, tfade_start
      logical, pointer :: ldamp_fade
!
!
      ! bottom and top damping factors:
      gamma_bot = 1.0 - abs (fbcz_bot(j))
      gamma_top = 1.0 - abs (fbcz_top(j))
!
      call get_shared_variable ('ldamp_fade', ldamp_fade, caller='bcz_extrapol_damped')
      if (ldamp_fade) then
        ! fading of damping is active
        call get_shared_variable ('tdamp', tdamp)
        call get_shared_variable ('tfade_start', tfade_start)
        if (t > tfade_start) then
          if (t < tdamp) then
            ! tau is a normalized t, the transition interval is [-0.5, 0.5]:
            tau = (t-tfade_start) / (tdamp-tfade_start) - 0.5
            fade_fact = 0.5 * (1 - tau * (3 - 4*tau**2))
            ! apply damping with fading:
            gamma_bot = 1.0 - abs (fbcz_bot(j)) * fade_fact
            gamma_top = 1.0 - abs (fbcz_top(j)) * fade_fact
          else
            ! damping has already ended (t >= tdamp)
            gamma_bot = 1.0
            gamma_top = 1.0
          endif
          ! apply fading-persistent damping:
          if (fbcz_bot(j) < 0.0) gamma_bot = 1.0 - abs (fbcz_bot(j))
          if (fbcz_top(j) < 0.0) gamma_top = 1.0 - abs (fbcz_top(j))
        endif
      endif
!
      select case (topbot)
      case(BOT)
        ! bottom (left end of the domain)
        slope = (f(:,:,n1+1,j) - f(:,:,n1,j)) / dz2_bound(-1)
        do i = 1, nghost
          f(:,:,n1-i,j) = (f(:,:,n1,j) - slope * dz2_bound(-i)) * gamma_bot**i
        enddo
        f(:,:,n1,j) = 0.5*(f(:,:,n1-1,j) + f(:,:,n1+1,j))
      case(TOP)
        ! top (right end of the domain)
        slope = (f(:,:,n2,j) - f(:,:,n2-1,j)) / dz2_bound(1)
        do i = 1, nghost
          f(:,:,n2+i,j) = (f(:,:,n2,j) + slope * dz2_bound(i)) * gamma_top**i
        enddo
        f(:,:,n2,j) = 0.5*(f(:,:,n2-1,j) + f(:,:,n2+1,j))
      case default
        call fatal_error ('bcz_extrapol_damped', 'topbot should be BOT or TOP', lfirst_proc_xy)
      endselect
!
    endsubroutine bcz_extrapol_damped
!***********************************************************************
    subroutine bcz_extrapol_mean (f, topbot, j)
!
!  Simple linear extrapolation in first order
!  with an included local averaging of a 7x7 array.
!  The last two grid points in z are used to determine the slope.
!  The 3 neighbouring grid points in x and y contribute to the local average.
!
!  11-apr-11/Bourdin.KIS: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:), intent(inout) :: f
      integer, intent(in) :: j
!
      integer :: i
      real, dimension (size(f,1),size(f,2)) :: slope, rho_ref
!
      select case (topbot)
      case(BOT)
        ! bottom (left end of the domain)
        rho_ref = f(:,:,n1,j)
        call average_xy (rho_ref, 3)
        slope = (f(:,:,n1+1,j) - rho_ref) / dz2_bound(-1)
        do i = 1, nghost
          f(:,:,n1-i,j) = rho_ref - slope * dz2_bound(-i)
        enddo
        f(:,:,n1,j) = 0.5*(f(:,:,n1-1,j) + f(:,:,n1+1,j))
      case(TOP)
        ! top (right end of the domain)
        rho_ref = f(:,:,n2,j)
        call average_xy (rho_ref, 3)
        slope = (rho_ref - f(:,:,n2-1,j)) / dz2_bound(1)
        do i = 1, nghost
          f(:,:,n2+i,j) = rho_ref + slope * dz2_bound(i)
        enddo
        f(:,:,n2,j) = 0.5*(f(:,:,n2-1,j) + f(:,:,n2+1,j))
      case default
        call fatal_error ('bcz_extrapol_mean', 'topbot should be BOT or TOP', lfirst_proc_xy)
      endselect
!
    endsubroutine bcz_extrapol_mean
!***********************************************************************
    subroutine average_xy (data, num)
!
!  Simple averaging over a num*num array in x and y direction.
!
!  11-apr-11/Bourdin.KIS: coded
!
      use Mpicomm, only: communicate_xy_ghosts
!
      real, dimension (:,:), intent(inout) :: data
      integer, intent(in) :: num
!
      real, dimension (size(data,1),size(data,2)) :: out
      integer :: px, py
!
!
      out = 0.0
      do px = l1, l2
        do py = m1, m2
          out(px,py) = sum (data(px-num:px+num,py-num:py+num))
        enddo
      enddo
      data = out / (num*2+1)**2
!
      call communicate_xy_ghosts (data)
!
    endsubroutine average_xy
!***********************************************************************
    subroutine bc_db_z(f,topbot,j)
!
!  "One-sided" boundary condition for density.
!  Set ghost zone to reproduce one-sided boundary condition
!  (2nd order):
!  Finding the derivatives on the boundary using a one
!  sided final difference method. This derivative is being
!  used to calculate the boundary points. This will probably
!  only be used for ln(rho)
!
!  may-2002/nils: coded
!  11-jul-2002/nils: moved into the density module
!  13-aug-2002/nils: moved into boundcond
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j
!
      real, dimension (size(f,1),size(f,2)) :: fder
      integer :: i
!
      select case (topbot)
!
! Bottom boundary
!
      case(BOT)
        do i=1,nghost
          fder=(-3*f(:,:,n1-i+1,j)+4*f(:,:,n1-i+2,j)&
               -f(:,:,n1-i+3,j))/(2*dz)
          f(:,:,n1-i,j)=f(:,:,n1-i+2,j)-2*dz*fder
        enddo
      case(TOP)
        do i=1,nghost
          fder=(3*f(:,:,n2+i-1,j)-4*f(:,:,n2+i-2,j)&
               +f(:,:,n2+i-3,j))/(2*dz)
          f(:,:,n2+i,j)=f(:,:,n2+i-2,j)+2*dz*fder
        enddo
      case default
        call fatal_error('bc_db_z','topbot should be BOT or TOP')
      endselect
!
    endsubroutine bc_db_z
!***********************************************************************
    subroutine bc_db_x(f,topbot,j)
!
!  "One-sided" boundary condition for density.
!  Set ghost zone to reproduce one-sided boundary condition
!  (2nd order):
!  Finding the derivatives on the boundary using a one
!  sided final difference method. This derivative is being
!  used to calculate the boundary points. This will probably
!  only be used for ln(rho)
!
!  may-2002/nils: coded
!  11-jul-2002/nils: moved into the density module
!  13-aug-2002/nils: moved into boundcond
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j
!
      real, dimension (size(f,2),size(f,3)) :: fder
      integer :: i
!
      select case (topbot)
!
! Bottom boundary
!
      case(BOT)
        do i=1,nghost
          fder=(-3*f(l1-i+1,:,:,j)+4*f(l1-i+2,:,:,j)&
               -f(l1-i+3,:,:,j))/(2*dx)
          f(l1-i,:,:,j)=f(l1-i+2,:,:,j)-2*dx*fder
        enddo
      case(TOP)
        do i=1,nghost
          fder=(3*f(l2+i-1,:,:,j)-4*f(l2+i-2,:,:,j)&
               +f(l2+i-3,:,:,j))/(2*dx)
          f(l2+i,:,:,j)=f(l2+i-2,:,:,j)+2*dx*fder
        enddo
      case default
        call fatal_error("bc_db_x","topbot should be BOT or TOP")
      endselect
!
    endsubroutine bc_db_x
!***********************************************************************
    subroutine bc_force_z(f,sgn,topbot,j)
!
!  Force values of j-th variable on vertical boundary topbot.
!  This can either be used for freezing variables at the boundary, or for
!  enforcing a certain time-dependent function of (x,y).
!
!  Currently this is hard-coded for velocity components (ux,uy) and quite
!  useless. Plan is to read time-dependent velocity field from disc and
!  apply it as boundary condition here.
!
!  26-apr-2004/wolf: coded
!
      use EquationOfState, only: cs2top, cs2bot
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: sgn,i,j
!
      select case (topbot)
!
!  lower boundary
!
      case(BOT)
         select case (force_lower_bound)
         case ('uxy_sin-cos')
            call bc_force_uxy_sin_cos(f,n1,j)
         case ('axy_sin-cos')
            call bc_force_axy_sin_cos(f,n1,j)
         case ('uxy_convection')
            call uu_driver(f)
         !case ('kepler')
         !   call bc_force_kepler(f,n1,j)
         case ('mag_time')
            call bc_force_aa_time(f)
         case ('mag_convection')
            call bc_force_aa_time(f)
            call uu_driver(f)
         case ('cT')
            f(:,:,n1,j) = log(cs2bot/gamma_m1)
         case ('vel_time')
            call bc_force_ux_time(f,n1,j)
         case default
            if (lroot) print*, "No such value for force_lower_bound: <", &
                 trim(force_lower_bound),">"
            call stop_it("")
         endselect
         !
         !  Now fill ghost zones imposing antisymmetry w.r.t. the values just set:
         !
         do i=1,nghost; f(:,:,n1-i,j)=2*f(:,:,n1,j)+sgn*f(:,:,n1+i,j); enddo
!
!  upper boundary
!
      case(TOP)
         select case (force_upper_bound)
         case ('uxy_sin-cos')
            call bc_force_uxy_sin_cos(f,n2,j)
         case ('axy_sin-cos')
            call bc_force_axy_sin_cos(f,n2,j)
         case ('uxy_convection')
            call uu_driver(f)
         !case ('kepler')
         !   call bc_force_kepler(f,n2,j)
         case ('cT')
            f(:,:,n2,j) = log(cs2top/gamma_m1)
         case ('vel_time')
            call bc_force_ux_time(f,n2,j)
         case default
            if (lroot) print*, "No such value for force_upper_bound: <", &
                 trim(force_upper_bound),">"
            call stop_it("")
         endselect
         !
         !  Now fill ghost zones imposing antisymmetry w.r.t. the values just set:
         !
         do i=1,nghost; f(:,:,n2+i,j)=2*f(:,:,n2,j)+sgn*f(:,:,n2-i,j); enddo
      case default
        call fatal_error("bc_force_z","topbot should be BOT or TOP")
      endselect
!
    endsubroutine bc_force_z
!***********************************************************************
    subroutine bc_force_x(f, sgn, topbot, j)
!
!  Force values of j-th variable on x-boundaries topbot.
!
!  09-mar-2007/dintrans: coded
!
      use SharedVariables, only : get_shared_variable
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real, pointer :: ampl_forc, k_forc, w_forc
      integer :: sgn, i, j
!
      select case (topbot)
!
!  lower boundary
!
      case(BOT)
         select case (force_lower_bound)
         case ('vel_time')
           if (j /= iuy) call stop_it("BC_FORCE_X: only valid for uy")
           call get_shared_variable('ampl_forc', ampl_forc, caller='bc_force_x')
           call get_shared_variable('k_forc', k_forc)
           call get_shared_variable('w_forc', w_forc)
           if (headtt) print*, 'BC_FORCE_X: ampl_forc, k_forc, w_forc=',&
               ampl_forc, k_forc, w_forc
           f(l1,:,:,iuy) = spread(ampl_forc*sin(k_forc*y)*cos(w_forc*t), 2, size(f,3))
         case default
            if (lroot) print*, "No such value for force_lower_bound: <", &
                 trim(force_lower_bound),">"
            call stop_it("")
         endselect
         !
         !  Now fill ghost zones imposing antisymmetry w.r.t. the values just set:
         !
         do i=1,nghost; f(l1-i,:,:,j)=2*f(l1,:,:,j)+sgn*f(l1+i,:,:,j); enddo
!
!  upper boundary
!
      case(TOP)
         select case (force_upper_bound)
         case ('vel_time')
            if (j /= iuy) call stop_it("BC_FORCE_X: only valid for uy")
            call get_shared_variable('ampl_forc', ampl_forc, caller='bc_force_x')
            call get_shared_variable('k_forc', k_forc)
            call get_shared_variable('w_forc', w_forc)
            if (headtt) print*, 'BC_FORCE_X: ampl_forc, k_forc, w_forc=',ampl_forc, k_forc, w_forc
            f(l2,:,:,iuy) = spread(ampl_forc*sin(k_forc*y)*cos(w_forc*t), 2, size(f,3))
         case default
            call fatal_error("bc_force_x","no such force_upper_bound: //trim(force_upper_bound)")
         endselect
         !
         !  Now fill ghost zones imposing antisymmetry w.r.t. the values just set:
         !
         do i=1,nghost; f(l2+i,:,:,j)=2*f(l2,:,:,j)+sgn*f(l2-i,:,:,j); enddo
      case default
        call fatal_error("bc_force_x","topbot should be BOT or TOP")
      endselect
!
    endsubroutine bc_force_x
!***********************************************************************
    subroutine bc_force_uxy_sin_cos(f,idz,j)
!
!  Set (ux, uy) = (cos y, sin x) in vertical layer
!
!  26-apr-2004/wolf: coded
!
      real, dimension (:,:,:,:) :: f
      integer :: idz,j
      real :: kx,ky
!
      if (iuz == 0) call stop_it("BC_FORCE_UXY_SIN_COS: Bad idea...")
!
      if (j==iux) then
        if (Ly>0) then; ky=2*pi/Ly; else; ky=0.; endif
        f(:,:,idz,j) = spread(cos(ky*y),1,size(f,1))
      elseif (j==iuy) then
        if (Lx>0) then; kx=2*pi/Lx; else; kx=0.; endif
        f(:,:,idz,j) = spread(sin(kx*x),2,size(f,2))
      elseif (j==iuz) then
        f(:,:,idz,j) = 0.
      endif
!
    endsubroutine bc_force_uxy_sin_cos
!***********************************************************************
    subroutine bc_force_axy_sin_cos(f,idz,j)
!
!  Set (ax, ay) = (cos y, sin x) in vertical layer
!
!  26-apr-2004/wolf: coded
!  10-apr-2005/axel: adapted for A
!
      real, dimension (:,:,:,:) :: f
      integer :: idz,j
      real :: kx,ky
!
      if (iaz == 0) call stop_it("BC_FORCE_AXY_SIN_COS: Bad idea...")
!
      if (j==iax) then
        if (Ly>0) then; ky=2*pi/Ly; else; ky=0.; endif
        f(:,:,idz,j) = spread(cos(ky*y),1,size(f,1))
      elseif (j==iay) then
        if (Lx>0) then; kx=2*pi/Lx; else; kx=0.; endif
        f(:,:,idz,j) = spread(sin(kx*x),2,size(f,2))
      elseif (j==iaz) then
        f(:,:,idz,j) = 0.
      endif
!
    endsubroutine bc_force_axy_sin_cos
!***********************************************************************
    subroutine bc_one_x(f,topbot,j)
!
!  Set bdry values to 1 for debugging purposes
!
!  11-jul-02/wolf: coded
!
      real, dimension (:,:,:,:) :: f
      integer :: j
      integer, intent(IN) :: topbot
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
          f(1:l1-1,:,:,j)=1.
!
      case(TOP)               ! top boundary
          f(l2+1:,:,:,j)=1.
!
      case default
        call fatal_error("bc_one_x: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_one_x
!***********************************************************************
    subroutine bc_one_y(f,topbot,j)
!
!  Set bdry values to 1 for debugging purposes
!
!  11-jul-02/wolf: coded
!
      real, dimension (:,:,:,:) :: f
      integer :: j
      integer, intent(IN) :: topbot
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
          f(:,1:m1-1,:,j)=1.
!
      case(TOP)               ! top boundary
          f(:,m2+1:,:,j)=1.
!
      case default
        call fatal_error("bc_one_y: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_one_y
!***********************************************************************
    subroutine bc_one_z(f,topbot,j)
!
!  Set bdry values to 1 for debugging purposes
!
!  11-jul-02/wolf: coded
!
      real, dimension (:,:,:,:) :: f
      integer :: j
      integer, intent(IN) :: topbot
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
          f(:,:,1:n1-1,j)=1.
!
      case(TOP)               ! top boundary
          f(:,:,n2+1:,j)=1.
!
      case default
        call fatal_error("bc_one_z: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_one_z
!***********************************************************************
    subroutine bc_freeze_var_x(topbot,j)
!
!  Tell other modules that variable with slot j is to be frozen in on
!  given boundary
!
      integer :: j
      integer, intent(IN) :: topbot
!
      lfrozen_bcs_x = .true.    ! set flag
!
      select case (topbot)
      case(BOT)               ! bottom boundary
        lfrozen_bot_var_x(j) = .true.
      case(TOP)               ! top boundary
        lfrozen_top_var_x(j) = .true.
      case default
        call fatal_error("bc_freeze_var_x: ","topbot should be BOT or TOP")
      endselect
!
    endsubroutine bc_freeze_var_x
!***********************************************************************
    subroutine bc_freeze_var_y(topbot,j)
!
!  Tell other modules that variable with slot j is to be frozen in on
!  given boundary
!
      integer :: j
      integer, intent(IN) :: topbot
!
      lfrozen_bcs_y = .true.    ! set flag
!
      select case (topbot)
      case(BOT)               ! bottom boundary
        lfrozen_bot_var_y(j) = .true.
      case(TOP)               ! top boundary
        lfrozen_top_var_y(j) = .true.
      case default
        call fatal_error("bc_freeze_var_y: ","topbot should be BOT or TOP")
      endselect
!
    endsubroutine bc_freeze_var_y
!***********************************************************************
    subroutine bc_freeze_var_z(topbot,j)
!
!  Tell other modules that variable with slot j is to be frozen in on
!  given boundary
!
      integer :: j
      integer, intent(IN) :: topbot
!
      lfrozen_bcs_z = .true.    ! set flag
!
      select case (topbot)
      case(BOT)               ! bottom boundary
        lfrozen_bot_var_z(j) = .true.
      case(TOP)               ! top boundary
        lfrozen_top_var_z(j) = .true.
      case default
        call fatal_error("bc_freeze_var_z: ","topbot should be BOT or TOP")
      endselect
!
    endsubroutine bc_freeze_var_z
!***********************************************************************
     subroutine uu_driver(f,quenching)
!
!  Simulated velocity field used as photospherec motions
!  Use of velocity field produced by Boris Gudiksen
!
!  27-mai-04/bing: coded
!  11-aug-06/axel: make it compile with nprocx>0, renamed quenching -> quen
!  18-jun-08/bing: quenching depends on B^2, not only Bz^2
!
       use EquationOfState, only : cs20,lnrho0
       use File_io, only : file_exists
       use Mpicomm, only : mpisend_real, mpirecv_real
!
       real, dimension (:,:,:,:), intent (inout) :: f
       logical, optional :: quenching
!
       real, dimension (nx,ny), save :: uxl,uxr,uyl,uyr
       real, dimension (:,:), allocatable :: tmp
       real, dimension (nx,ny) :: uxd,uyd,quen,pp,betaq,fac,bbx,bby,bbz,bb2

       integer :: tag_xl=321,tag_yl=322,tag_xr=323,tag_yr=324
       integer :: tag_tl=345,tag_tr=346,tag_dt=347
       integer :: lend=0,ierr,frame=0,pos,iref,px,py,partner
       real, save :: tl=0.,tr=0.,delta_t=0.
       real  :: zmin
       logical :: quench
!
       character (len=*), parameter :: vel_times_dat = 'driver/vel_times.dat'
       character (len=*), parameter :: vel_field_dat = 'driver/vel_field.dat'
       integer :: unit=1
!
       if (ldownsampling) then
         call warning('uu_driver','Not available for downsampling')
         return
       endif
!
       if (lroot .and. .not. file_exists(vel_times_dat)) &
           call fatal_error_local('uu_driver','Could not find file "'//trim(vel_times_dat)//'"')
       if (lroot .and. .not. file_exists(vel_field_dat)) &
           call fatal_error_local('uu_driver', 'Could not find file "'//trim(vel_field_dat)//'"')
!
       if (present(quenching)) then
         quench = quenching
       else
         ! Right now quenching is per default active
         quench=.true.
       endif
!
!  Read the time table
!
       if ((t*unit_time<tl+delta_t) .or. (t*unit_time>=tr+delta_t)) then
!
         if (lroot) then
           inquire(IOLENGTH=lend) tl
           open (unit,file=vel_times_dat,form='unformatted',status='unknown',recl=lend,access='direct')
!
           ierr = 0
           frame = 0
           do while (ierr == 0)
             frame=frame+1
             read (unit,rec=frame,iostat=ierr) tl
             read (unit,rec=frame+1,iostat=ierr) tr
             if (ierr /= 0) then
               frame=1
               delta_t = t*unit_time                  ! EOF is reached => read again
               read (unit,rec=frame,iostat=ierr) tl
               read (unit,rec=frame+1,iostat=ierr) tr
               ierr=-1
             else
               if (t*unit_time>=tl+delta_t .and. t*unit_time<tr+delta_t) ierr=-1
               ! correct time step is reached
             endif
           enddo
           close (unit)
!
           do px=0, nprocx-1
             do py=0, nprocy-1
               if ((px /= 0) .or. (py /= 0)) then
                 partner = find_proc(px,py,0)
                 call mpisend_real (tl, partner, tag_tl)
                 call mpisend_real (tr, partner, tag_tr)
                 call mpisend_real (delta_t, partner, tag_dt)
               endif
             enddo
           enddo
         else
           call mpirecv_real (tl, 0, tag_tl)
           call mpirecv_real (tr, 0, tag_tr)
           call mpirecv_real (delta_t, 0, tag_dt)
         endif
!
! Read velocity field
!
         if (lroot) then

           allocate(tmp(nxgrid,nygrid),stat=ierr)
!
           if (ierr>0) call fatal_error('uu_driver', &
              'Could not allocate memory for array please check', .true.)

           open (unit,file=vel_field_dat,form='unformatted',status='unknown',recl=lend*nxgrid*nygrid,access='direct')
!
           read (unit,rec=2*frame-1) tmp
           do px=0, nprocx-1
             do py=0, nprocy-1
               if ((px /= 0) .or. (py /= 0)) then
                 uxl = tmp(px*nx+1:(px+1)*nx,py*ny+1:(py+1)*ny)
                 call mpisend_real (uxl, (/ nx, ny /), find_proc(px,py,0), tag_xl)
               endif
             enddo
           enddo
           uxl = tmp(1:nx,1:ny)
!
           read (unit,rec=2*frame) tmp
           do px=0, nprocx-1
             do py=0, nprocy-1
               if ((px /= 0) .or. (py /= 0)) then
                 uyl = tmp(px*nx+1:(px+1)*nx,py*ny+1:(py+1)*ny)
                 call mpisend_real (uyl, (/ nx, ny /), find_proc(px,py,0), tag_yl)
               endif
             enddo
           enddo
           uyl = tmp(1:nx,1:ny)
!
           read (unit,rec=2*frame+1) tmp
           do px=0, nprocx-1
             do py=0, nprocy-1
               if ((px /= 0) .or. (py /= 0)) then
                 uxr = tmp(px*nx+1:(px+1)*nx,py*ny+1:(py+1)*ny)
                 call mpisend_real (tmp(px*nx+1:(px+1)*nx,py*ny+1:(py+1)*ny), (/ nx, ny /), find_proc(px,py,0), tag_xr)
               endif
             enddo
           enddo
           uxr = tmp(1:nx,1:ny)
!
           read (unit,rec=2*frame+2) tmp
           uyr = tmp(1:nx,1:ny)
           do px=0, nprocx-1
             do py=0, nprocy-1
               if ((px /= 0) .or. (py /= 0)) then
                 uyr = tmp(px*nx+1:(px+1)*nx,py*ny+1:(py+1)*ny)
                 call mpisend_real (tmp(px*nx+1:(px+1)*nx,py*ny+1:(py+1)*ny), (/ nx, ny /), find_proc(px,py,0), tag_yr)
               endif
             enddo
           enddo
           uyr = tmp(1:nx,1:ny)
!
           close (unit)
           deallocate(tmp)
         else
           call mpirecv_real (uxl, (/ nx, ny /), 0, tag_xl)
           call mpirecv_real (uyl, (/ nx, ny /), 0, tag_yl)
           call mpirecv_real (uxr, (/ nx, ny /), 0, tag_xr)
           call mpirecv_real (uyr, (/ nx, ny /), 0, tag_yr)
         endif
!
         uxl = uxl / 10. / unit_velocity
         uxr = uxr / 10. / unit_velocity
         uyl = uyl / 10. / unit_velocity
         uyr = uyr / 10. / unit_velocity
!
       endif
!
!   simple linear interploation between timesteps
!
       if (tr /= tl) then
         uxd  = (t*unit_time - (tl+delta_t)) * (uxr - uxl) / (tr - tl) + uxl
         uyd  = (t*unit_time - (tl+delta_t)) * (uyr - uyl) / (tr - tl) + uyl
       else
         uxd = uxl
         uyd = uyl
       endif
!
!   suppress footpoint motion at low plasma beta
!
       zmin = minval(abs(z(n1:n2)))
       iref = n1
       do pos=n1,n2
         if (abs(z(pos))==zmin) iref=pos; exit
       enddo
!
!   Calculate B^2 for plasma beta
!
       if (quench) then
!-----------------------------------------------------------------------
         if (nygrid/=1) then
           fac=(1./60)*spread(dy_1(m1:m2),1,nx)
           bbx= fac*(+ 45.0*(f(l1:l2,m1+1:m2+1,iref,iaz)-f(l1:l2,m1-1:m2-1,iref,iaz)) &
               -  9.0*(f(l1:l2,m1+2:m2+2,iref,iaz)-f(l1:l2,m1-2:m2-2,iref,iaz)) &
               +      (f(l1:l2,m1+3:m2+3,iref,iaz)-f(l1:l2,m1-3:m2-3,iref,iaz)))
         else
           if (ip<=5) print*, 'uu_driver: Degenerate case in y-direction'
           bbx=0.
         endif
         if (nzgrid/=1) then
           fac=(1./60)*spread(spread(dz_1(iref),1,nx),2,ny)
           bbx= bbx -fac*(+ 45.0*(f(l1:l2,m1:m2,iref+1,iay)-f(l1:l2,m1:m2,iref-1,iay)) &
               -  9.0*(f(l1:l2,m1:m2,iref+2,iay)-f(l1:l2,m1:m2,iref-2,iay)) &
               +      (f(l1:l2,m1:m2,iref+3,iay)-f(l1:l2,m1:m2,iref-2,iay)))
         else
           if (ip<=5) print*, 'uu_driver: Degenerate case in z-direction'
         endif
!-----------------------------------------------------------------------
         if (nzgrid/=1) then
           fac=(1./60)*spread(spread(dz_1(iref),1,nx),2,ny)
           bby= fac*(+ 45.0*(f(l1:l2,m1:m2,iref+1,iax)-f(l1:l2,m1:m2,iref-1,iax)) &
               -  9.0*(f(l1:l2,m1:m2,iref+2,iax)-f(l1:l2,m1:m2,iref-2,iax)) &
               +      (f(l1:l2,m1:m2,iref+3,iax)-f(l1:l2,m1:m2,iref-3,iax)))
         else
           if (ip<=5) print*, 'uu_driver: Degenerate case in z-direction'
           bby=0.
         endif
         if (nxgrid/=1) then
           fac=(1./60)*spread(dx_1(l1:l2),2,ny)
           bby=bby-fac*(+45.0*(f(l1+1:l2+1,m1:m2,iref,iaz)-f(l1-1:l2-1,m1:m2,iref,iaz)) &
               -  9.0*(f(l1+2:l2+2,m1:m2,iref,iaz)-f(l1-2:l2-2,m1:m2,iref,iaz)) &
               +      (f(l1+3:l2+3,m1:m2,iref,iaz)-f(l1-3:l2-3,m1:m2,iref,iaz)))
         else
           if (ip<=5) print*, 'uu_driver: Degenerate case in x-direction'
         endif
!-----------------------------------------------------------------------
         if (nxgrid/=1) then
           fac=(1./60)*spread(dx_1(l1:l2),2,ny)
           bbz= fac*(+ 45.0*(f(l1+1:l2+1,m1:m2,iref,iay)-f(l1-1:l2-1,m1:m2,iref,iay)) &
               -  9.0*(f(l1+2:l2+2,m1:m2,iref,iay)-f(l1-2:l2-2,m1:m2,iref,iay)) &
               +      (f(l1+3:l2+3,m1:m2,iref,iay)-f(l1-3:l2-3,m1:m2,iref,iay)))
         else
           if (ip<=5) print*, 'uu_driver: Degenerate case in x-direction'
           bbz=0.
         endif
         if (nygrid/=1) then
           fac=(1./60)*spread(dy_1(m1:m2),1,nx)
           bbz=bbz-fac*(+45.0*(f(l1:l2,m1+1:m2+1,iref,iax)-f(l1:l2,m1-1:m2-1,iref,iax)) &
               -  9.0*(f(l1:l2,m1+2:m2+2,iref,iax)-f(l1:l2,m1-2:m2-2,iref,iax)) &
               +      (f(l1:l2,m1+3:m2+3,iref,iax)-f(l1:l2,m1-3:m2-3,iref,iax)))
         else
           if (ip<=5) print*, 'uu_driver: Degenerate case in y-direction'
         endif
!-----------------------------------------------------------------------
!
         bb2 = bbx*bbx + bby*bby + bbz*bbz
         bb2 = bb2/(2.*mu0)
!
         if (ltemperature) then
           pp=gamma_m1*gamma1*exp(f(l1:l2,m1:m2,iref,ilnrho)+f(l1:l2,m1:m2,iref,ilnTT))
         else if (lentropy) then
           if (pretend_lnTT) then
             pp=gamma_m1*gamma1*exp(f(l1:l2,m1:m2,iref,ilnrho)+f(l1:l2,m1:m2,iref,iss))
           else
             pp=gamma*(f(l1:l2,m1:m2,iref,iss)+ &
                 f(l1:l2,m1:m2,iref,ilnrho))-gamma_m1*lnrho0
             pp=exp(pp) * cs20*gamma1
           endif
         else
           pp=gamma1*cs20*exp(lnrho0)
         endif
!
!   limit plasma beta
!
         betaq = pp / max(tini,bb2)*1e-3
!
         quen=(1.+betaq**2)/(10.+betaq**2)
       else
         quen(:,:)=1.
       endif
!
!   Fill z=0 layer with velocity field
!
       f(l1:l2,m1:m2,iref,iux)=uxd*quen
       f(l1:l2,m1:m2,iref,iuy)=uyd*quen
       if (iref/=n1) f(l1:l2,m1:m2,n1,iux:iuz)=0.
!
     endsubroutine uu_driver
!***********************************************************************
    subroutine bc_force_aa_time(f)
!
!  Reads in time series of magnetograms
!
!  17-feb-10/bing: coded
!  25-jul-10/Bourdin.KIS: parallelized
!
      use Fourier, only : setup_extrapol_fact, field_extrapol_z_parallel
      use Mpicomm, only : mpisend_real, mpirecv_real, &
                          mpisend_logical, mpirecv_logical
!
      real, dimension (:,:,:,:) :: f
      real, save :: t_l=0., t_r=0., delta_t=0.
      integer :: ierr, lend, frame, stat, rec_l, rec_r
      integer :: rec_vxl, rec_vxr, rec_vyl, rec_vyr ! l- and r-record position if file
      integer, parameter :: bnx=nxgrid, bny=ny/nprocx ! data in pencil shape
      integer, parameter :: enx=nygrid, eny=nx/nprocy ! transposed data in pencil shape
      integer :: px, py, partner
      integer, parameter :: tag_l=208, tag_r=209, tag_dt=210
      logical, save :: luse_vel_field = .false., first_run = .true.
      logical :: ex
!
      ! temporal storage for frames before (l) and after (r) current time step:
      real, dimension (:,:), allocatable, save :: Bz0_l, Bz0_r
      real, dimension (:,:), allocatable, save :: vx_l, vx_r, vy_l, vy_r
      real, dimension (:,:), allocatable :: vx_tmp, vy_tmp
      ! current magnetic field z-component (interpolated between l and r):
      real, dimension (:,:), allocatable :: Bz0
      ! current velocity x- and y-component (interpolated between l and r):
      real, dimension (:,:), allocatable, save :: vx, vy
!
      real, dimension (:,:,:), allocatable, save :: exp_fact ! exponential factor
      integer :: i
      real, parameter :: reduce_factor=0.25
!
      real :: time_SI
!
      character (len=*), parameter :: mag_field_dat = 'driver/mag_field.dat'
      character (len=*), parameter :: mag_times_dat = 'driver/mag_times.dat'
      character (len=*), parameter :: mag_vel_field_dat = 'driver/mag_vel_field.dat'
!
      if (ldownsampling) then
        call warning('bc_force_aa_time','Not available for downsampling')
        return
      endif
!
      if (first_run) then
!
!  Check for consistency:
        if ((.not. lequidist(1)) .or. (.not. lequidist(2))) &
            call fatal_error ('bc_force_aa_time', 'not yet implemented for non-equidistant grids', lfirst_proc_xy)
        if (mod (nygrid, nprocxy) /= 0) &
            call fatal_error ('bc_force_aa_time', 'nygrid needs to be an integer multiple of nprocx*nprocy', lfirst_proc_xy)
        if (mod (nxgrid, nprocxy) /= 0) &
            call fatal_error ('bc_force_aa_time', 'nxgrid needs to be an integer multiple of nprocx*nprocy', lfirst_proc_xy)
!
!  Check for existence of necessary driver files:
        if (lfirst_proc_xy) then
          inquire (file=mag_field_dat, exist=ex)
          if (.not. ex) call fatal_error ('bc_force_aa_time', 'File does not exists: '//trim(mag_field_dat), .true.)
          inquire (file=mag_times_dat, exist=ex)
          if (.not. ex) call fatal_error ('bc_force_aa_time', 'File does not exists: '//trim(mag_times_dat), .true.)
          inquire (file=mag_vel_field_dat, exist=ex)
          if (ex) then
            luse_vel_field = .true.
            print *, 'bc_force_aa_time: using time dependant magnetogram _with_ corresponding horizontal velocities.'
          else
            print *, 'bc_force_aa_time: using time dependant magnetogram _without_ corresponding horizontal velocities.'
          endif
        endif
!
        do i=1,nprocxy-1
          partner = find_proc(modulo(i,nprocx),i/nprocx,0)
          if (lroot) then
            call mpisend_logical(luse_vel_field,partner,partner)
          elseif (iproc==partner) then
            call mpirecv_logical(luse_vel_field,0,partner)
          endif
        enddo
!
!  Initialization of magnetograms and velocity fields.
        allocate(Bz0_l(bnx,bny),stat=stat)
        if (stat>0) call fatal_error('bc_force_aa_time','Could not allocate memory for Bz0_l',.true.)
        allocate(Bz0_r(bnx,bny),stat=stat)
        if (stat>0) call fatal_error('bc_force_aa_time','Could not allocate memory for Bz0_r',.true.)
        if (luse_vel_field) then
          allocate(vx_l(nx,ny),stat=stat)
          if (stat>0) call fatal_error('bc_force_aa_time','Could not allocate memory for vx_l',.true.)
          allocate(vx_r(nx,ny),stat=stat)
          if (stat>0) call fatal_error('bc_force_aa_time','Could not allocate memory for vx_r',.true.)
          allocate(vy_l(nx,ny),stat=stat)
          if (stat>0) call fatal_error('bc_force_aa_time','Could not allocate memory for vy_l',.true.)
          allocate(vy_r(nx,ny),stat=stat)
          if (stat>0) call fatal_error('bc_force_aa_time','Could not allocate memory for vy_r',.true.)
          allocate(vx(nx,ny),stat=stat)
          if (stat>0) call fatal_error('bc_force_aa_time','Could not allocate memory for vx',.true.)
          allocate(vy(nx,ny),stat=stat)
          if (stat>0) call fatal_error('bc_force_aa_time','Could not allocate memory for vy',.true.)
        endif
!
        first_run = .false.
!
      endif
!
      allocate(Bz0(bnx,bny),stat=stat)
      if (stat>0) call fatal_error('bc_force_aa_time','Could not allocate memory for Bz0',.true.)
!
      time_SI = t*unit_time
!
      if (t_r+delta_t <= time_SI) then
!
        if (lfirst_proc_xy) then
!  Read and distribute Bz data (in pencil shape)
!
          inquire (IOLENGTH=lend) t_l
          open (10,file=mag_times_dat,form='unformatted',status='unknown', &
              recl=lend,access='direct')
!
          ierr = 0
          t_l = 0.
          frame = 0
          do while (ierr == 0)
            frame=frame+1
            read (10,rec=frame,iostat=ierr) t_l
            read (10,rec=frame+1,iostat=ierr) t_r
            if (ierr /= 0) then
              ! EOF is reached => read again
              delta_t = time_SI
              frame=1
              read (10,rec=frame,iostat=ierr) t_l
              read (10,rec=frame+1,iostat=ierr) t_r
              ierr=-1
            else
              ! test, if correct time step is reached
              if ((t_l+delta_t < time_SI) .and. (t_r+delta_t > time_SI)) ierr = -1
            endif
          enddo
          close (10)
!
          if (luse_vel_field) then
            allocate (vx_tmp(nxgrid,nygrid), stat=stat)
            if (stat>0) call fatal_error ('bc_force_aa_time', 'Could not allocate memory for vx_tmp', .true.)
            allocate (vy_tmp(nxgrid,nygrid), stat=stat)
            if (stat>0) call fatal_error ('bc_force_aa_time', 'Could not allocate memory for vy_tmp', .true.)
            open (10, file=mag_vel_field_dat, form='unformatted', status='unknown', &
                recl=lend*nxgrid*nygrid, access='direct')
!
            rec_vxl = 1 + (frame-1)*nprocxy*2
            rec_vxr = 1 + frame*nprocxy*2
            rec_vyl = rec_vxl + frame*nprocxy
            rec_vyr = rec_vxr + frame*nprocxy
!
            ! read _l data in the order of occurence in file
            read (10,rec=rec_vxl) vx_l
            read (10,rec=rec_vyl) vy_l
!
            ! send _l data to remote
            do py = 1, nprocy
              do px = 1, nprocx
                partner = find_proc(px-1,py-1,ipz)
                if (partner == iproc) cycle
                vx_l = vx_tmp(1+(px-1)*nprocx:px*nprocx,1+(py-1)*nprocy:py*nprocy)
                vy_l = vy_tmp(1+(px-1)*nprocx:px*nprocx,1+(py-1)*nprocy:py*nprocy)
                call mpisend_real (vx_l, (/ nx, ny /), partner, tag_l)
                call mpisend_real (vy_l, (/ nx, ny /), partner, tag_r)
              enddo
            enddo
            ! read local _l data
            vx_l = vx_tmp(1:nprocx,1:nprocy)
            vy_l = vy_tmp(1:nprocx,1:nprocy)
!
            ! read _r data in the order of occurence in file
            read (10,rec=rec_vxr) vx_r
            read (10,rec=rec_vyr) vy_r
!
            ! send _r data to remote
            do py = 1, nprocy
              do px = 1, nprocx
                partner = find_proc(px-1,py-1,ipz)
                if (partner == iproc) cycle
                vx_r = vx_tmp(1+(px-1)*nprocx:px*nprocx,1+(py-1)*nprocy:py*nprocy)
                vy_r = vy_tmp(1+(px-1)*nprocx:px*nprocx,1+(py-1)*nprocy:py*nprocy)
                call mpisend_real (vx_r, (/ nx, ny /), partner, tag_l)
                call mpisend_real (vy_r, (/ nx, ny /), partner, tag_r)
              enddo
            enddo
            ! read local _r data
            vx_r = vx_tmp(1:nprocx,1:nprocy)
            vy_r = vy_tmp(1:nprocx,1:nprocy)
!
            close (10)
            if (allocated (vx_tmp)) deallocate (vx_tmp)
            if (allocated (vy_tmp)) deallocate (vy_tmp)
          endif
!
          open (10,file=mag_field_dat,form='unformatted',status='unknown', &
              recl=lend*bnx*bny,access='direct')
          rec_l = 1 + (frame-1)*nprocxy
          rec_r = 1 + frame*nprocxy
          do py=1, nprocxy-1
            partner = find_proc(modulo(py,nprocx),py/nprocx,ipz)
            ! read Bz data for remote processors
            read (10,rec=rec_l+py) Bz0_l
            read (10,rec=rec_r+py) Bz0_r
            ! send Bz data to remote
            call mpisend_real (Bz0_l, (/ bnx, bny /), partner, tag_l)
            call mpisend_real (Bz0_r, (/ bnx, bny /), partner, tag_r)
            call mpisend_real (t_l, partner, tag_l)
            call mpisend_real (t_r, partner, tag_r)
            call mpisend_real (delta_t, partner, tag_dt)
          enddo
          ! read local Bz data
          read (10,rec=rec_l) Bz0_l
          read (10,rec=rec_r) Bz0_r
          close (10)
!
        else
!
          partner = find_proc(0,0,ipz)
          if (luse_vel_field) then
            ! wait for vx and vy data from root processor
            call mpirecv_real (vx_l, (/ nx, ny /), partner, tag_l)
            call mpirecv_real (vy_l, (/ nx, ny /), partner, tag_r)
            call mpirecv_real (vx_r, (/ nx, ny /), partner, tag_l)
            call mpirecv_real (vy_r, (/ nx, ny /), partner, tag_r)
          endif
!
          ! wait for Bz data from root processor
          call mpirecv_real (Bz0_l, (/ bnx, bny /), partner, tag_l)
          call mpirecv_real (Bz0_r, (/ bnx, bny /), partner, tag_r)
          call mpirecv_real (t_l    , partner, tag_l)
          call mpirecv_real (t_r    , partner, tag_r)
          call mpirecv_real (delta_t, partner, tag_dt)
!
        endif
!
        ! Gauss to Tesla and SI to PENCIL units
        Bz0_l = Bz0_l * 1e-4 / unit_magnetic
        Bz0_r = Bz0_r * 1e-4 / unit_magnetic
!
        if (luse_vel_field) then
          vx_l = vx_l / unit_velocity
          vy_l = vy_l / unit_velocity
          vx_r = vx_r / unit_velocity
          vy_r = vy_r / unit_velocity
        endif
!
      endif
!
      Bz0 = (time_SI - (t_l+delta_t)) * (Bz0_r - Bz0_l) / (t_r - t_l) + Bz0_l
!
      if (luse_vel_field) then
        vx = (time_SI - (t_l+delta_t)) * (vx_r - vx_l) / (t_r - t_l) + vx_l
        vy = (time_SI - (t_l+delta_t)) * (vy_r - vy_l) / (t_r - t_l) + vy_l
      endif
!
!  Fourier Transform of Bz0:
!
      if (.not. allocated (exp_fact)) then
        ! Setup exponential factor for bottom boundary
        allocate (exp_fact(enx,eny,nghost+1), stat=stat)
        if (stat > 0) call fatal_error ('bc_force_aa_time', 'Could not allocate memory for exp_fact', .true.)
        call setup_extrapol_fact (z(1:n1), z(n1), exp_fact, reduce_factor)
      endif
!
      call field_extrapol_z_parallel (Bz0, f(l1:l2,m1:m2,n1-nghost:n1,iax:iay), exp_fact)
      call communicate_vect_field_ghosts(f,BOT)
      if (luse_vel_field) call communicate_vect_field_ghosts(f,BOT, iux)
!
      if (allocated(Bz0)) deallocate(Bz0)
!
    endsubroutine bc_force_aa_time
!***********************************************************************
    subroutine bc_lnTT_flux_x(f,topbot)
!
!  Constant flux boundary condition for temperature (called when bcx='c1')
!
!  12-Mar-2007/dintrans: coded
!
      use SharedVariables, only: get_shared_variable
!
      real, dimension (:,:,:,:) :: f
      integer, intent(IN) :: topbot
!
      real, pointer :: hcond0, hcond1, Fbot
      real, dimension (size(f,2),size(f,3)) :: tmp_yz
      integer :: i
!
!  Do the 'c1' boundary condition (constant heat flux) for lnTT.
!  check whether we want to do top or bottom (this is processor dependent)
!
      call get_shared_variable('hcond0',hcond0,caller='bc_lnTT_flux_x')
      call get_shared_variable('hcond1',hcond1)
      call get_shared_variable('Fbot',Fbot)
!
      if (headtt) print*,'bc_lnTT_flux_x: Fbot,hcond,dx=',Fbot,hcond0*hcond1,dx
!
      select case (topbot)
!
!  bottom boundary
!  ===============
!
      case(BOT)
        tmp_yz=-Fbot/(hcond0*hcond1)/exp(f(l1,:,:,ilnTT))
!
!  enforce dlnT/dx = - Fbot/(K*T)
!
        do i=1,nghost
          f(l1-i,:,:,ilnTT)=f(l1+i,:,:,ilnTT)-dx2_bound(-i)*tmp_yz
        enddo
!
      case default
        call fatal_error('bc_lnTT_flux_x','topbot should be BOT or TOP')
!
      endselect
!
    endsubroutine bc_lnTT_flux_x
!***********************************************************************
    subroutine bc_lnTT_flux_z(f,topbot)
!
!  Constant flux boundary condition for temperature
!  (called when bcz='c1')
!
!  12-May-07/dintrans: coded
!
      use SharedVariables, only: get_shared_variable
!
      real, dimension (:,:,:,:) :: f
      integer, intent(IN) :: topbot
!
      real, dimension (size(f,1),size(f,2)) :: tmp_xy
      real, pointer :: hcond0, Fbot
      integer :: i
!
!  Do the 'c1' boundary condition (constant heat flux) for lnTT or TT (if
!  ltemperature_nolog=.true.) at the bottom _only_.
!  lnTT version: enforce dlnT/dz = - Fbot/(K*T)
!    TT version: enforce   dT/dz = - Fbot/K
!
      call get_shared_variable('hcond0',hcond0,caller='bc_lnTT_flux_z')
      call get_shared_variable('Fbot',Fbot)
!
      if (headtt) print*,'bc_lnTT_flux_z: Fbot,hcond,dz=',Fbot,hcond0,dz
!
      select case (topbot)
      case(BOT)
        if (ltemperature_nolog) then
          tmp_xy=-Fbot/hcond0
        else
          tmp_xy=-Fbot/hcond0/exp(f(:,:,n1,ilnTT))
        endif
        do i=1,nghost
          f(:,:,n1-i,ilnTT)=f(:,:,n1+i,ilnTT)-dz2_bound(-i)*tmp_xy
        enddo
!
      case default
        call fatal_error('bc_lnTT_flux_z','topbot should be BOT or TOP')
!
      endselect
!
    endsubroutine bc_lnTT_flux_z
!***********************************************************************
    subroutine bc_ss_flux_x(f,topbot)
!
!  Constant flux boundary condition for entropy (called when bcx='c1')
!
!  17-mar-07/dintrans: coded
!  16-apr-12/MR: eliminated cs2_yz; allocation of rho_yz -> work_yz only if necessary;
!                introduced heatflux_boundcond_x (necessary for nonequidistant grid)
!   5-feb-15/MR: added reference state
!  11-feb-15/MR: corrected use of reference state
!  27-feb-2024/Kishore: implemented for iheatcond=chi-const
!  21-jun-2024/Kishore: account for bounds on Kramers conductivity
!
      use EquationOfState, only: lnrho0, cs20
      use SharedVariables, only: get_shared_variable
!
      real, dimension (:,:,:,:) :: f
      integer, intent(IN) :: topbot
!
      real, dimension (:,:), allocatable :: tmp_yz, work_yz, Krho1kr_yz
      real, pointer :: FbotKbot, FtopKtop, Fbot, Ftop, cp, chi
      real, pointer :: hcond0_kramers, nkramers, chimax_kramers, chimin_kramers
      logical, pointer :: lheatc_kramers, lheatc_chiconst
      logical, pointer :: lheatc_Kprof, lheatc_Kconst
      integer :: i,stat
      real, dimension (:,:), pointer :: reference_state
      real :: fac
!
!  Do the 'c1' boundary condition (constant heat flux) for entropy.
!
      call get_shared_variable('lheatc_kramers',lheatc_kramers, caller='bc_ss_flux_x')
      call get_shared_variable('lheatc_chiconst',lheatc_chiconst, caller='bc_ss_flux_x')
      call get_shared_variable('lheatc_Kprof',lheatc_Kprof)
      call get_shared_variable('lheatc_Kconst',lheatc_Kconst)
      if (lheatc_kramers.and.lheatc_chiconst) call fatal_error('bc_ss_flux_x', &
        'Having both Kramers and chi-const at the same time is not supported')
!
!  Allocate memory for large arrays.
!
      allocate(tmp_yz(size(f,2),size(f,3)),stat=stat)
      if (stat>0) call fatal_error('bc_ss_flux_x', &
          'Could not allocate memory for tmp_yz')
!
      if (lheatc_kramers) then
!
        call get_shared_variable('hcond0_kramers',hcond0_kramers)
        call get_shared_variable('nkramers',nkramers)
        call get_shared_variable('cp',cp)
        call get_shared_variable('chimax_kramers',chimax_kramers)
        call get_shared_variable('chimin_kramers',chimin_kramers)
!
      endif
      if (lheatc_chiconst) then
        call get_shared_variable('chi',chi)
        call get_shared_variable('cp',cp)
      endif
!
      if (lheatc_kramers.or.lheatc_chiconst.or.lreference_state) then
        allocate(work_yz(size(f,2),size(f,3)),stat=stat)
        if (stat>0) call fatal_error('bc_ss_flux_x', &
                                     'Could not allocate memory for work_yz')
      endif
      if (lheatc_kramers) then
        allocate(Krho1kr_yz(size(f,2),size(f,3)),stat=stat)
        if (stat>0) call fatal_error('bc_ss_flux_x', &
                                     'Could not allocate memory for Krho1kr_yz')
      endif
!
      if (lreference_state) &
        call get_shared_variable('reference_state',reference_state)
! 
      fac=gamma_m1/gamma
!
! Check whether we want to do top or bottom (this is processor dependent)
!
      select case (topbot)
!
!  bottom boundary
!  ===============
!
      case(BOT)
!
        if (pretend_lnTT.or..not.(lheatc_chiconst.or.lheatc_kramers)) then
          if (headtt.and..not.(lheatc_Kprof.or.lheatc_Kconst)) then
!           Kishore: I am not sure if FbotKbot is correctly set for any
!           other iheatcond, so I will leave this as a warning for now.
            call warning('bc_ss_flux_x', 'FbotKbot may not be correctly set. Please check it.')
          endif
          call get_shared_variable('FbotKbot',FbotKbot)
          if (headtt) print*,'bc_ss_flux_x: FbotKbot=',FbotKbot
        endif
!
!  Deal with the simpler pretend_lnTT=T case first. Now ss is actually
!  lnTT and the boundary condition reads glnTT=FbotKbot/T
!
        if (pretend_lnTT) then      ! TODO: non-equidistant grid
          do i=1,nghost
            f(l1-i,:,:,iss)=f(l1+i,:,:,iss)+dx2_bound(-i)*FbotKbot/exp(f(l1,:,:,iss))
          enddo
        else
!
!  calculate Fbot/(K*cs2)
!
!       cs2_yz=cs20*exp(gamma_m1*(f(l1,:,:,ilnrho)-lnrho0)+cv1*f(l1,:,:,iss))
!
!  Both, bottom and top boundary conditions are corrected for linear density
!
          if (ldensity_nolog) then
            if (lheatc_kramers.or.lheatc_chiconst) work_yz=f(l1,:,:,irho)
            if (lreference_state) then
              tmp_yz= cs20*exp(gamma_m1*(log(f(l1,:,:,irho)+reference_state(1,iref_rho))-lnrho0)  &
                     +gamma*(f(l1,:,:,iss)+reference_state(1,iref_s)))
            else
              tmp_yz=cs20*exp(gamma_m1*(log(f(l1,:,:,irho))-lnrho0)+gamma*f(l1,:,:,iss))
            endif
          else
            if (lheatc_kramers.or.lheatc_chiconst) work_yz=exp(f(l1,:,:,ilnrho))
            tmp_yz=cs20*exp(gamma_m1*(f(l1,:,:,ilnrho)-lnrho0)+gamma*f(l1,:,:,iss))
          endif
!
          if (lheatc_kramers.or.lheatc_chiconst) then
            call get_shared_variable('Fbot',Fbot)
            if ((headtt) .and. (lroot)) print*,'bc_ss_flux_x: Fbot=',Fbot
          endif
!
          if (lheatc_kramers) then
            Krho1kr_yz = hcond0_kramers*work_yz**(-2*nkramers-1)*(tmp_yz/(cp*gamma_m1))**(6.5*nkramers)
!
            if (chimin_kramers>0) Krho1kr_yz = max(Krho1kr_yz, chimin_kramers*cp)
            if (chimax_kramers>0) Krho1kr_yz = min(Krho1kr_yz, chimax_kramers*cp)
!
            tmp_yz=Fbot/(work_yz*Krho1kr_yz*tmp_yz)
          else if (lheatc_chiconst) then
            tmp_yz=Fbot/(work_yz*chi*cp*tmp_yz)
          else
            tmp_yz=FbotKbot/tmp_yz
          endif
!
!  enforce ds/dx           + gamma_m1/gamma*dlnrho/dx = - gamma_m1/gamma*Fbot/(K*cs2)
!  or with reference state:
!                + ds_0/dx + gamma_m1/gamma*d/dx(ln(rho'+rho_0)) = - gamma_m1/gamma*Fbot/(K*cs2)
!
          if (lreference_state) then
            work_yz= 1./(f(l1,:,:,irho)+reference_state(1,iref_rho))
            tmp_yz = tmp_yz + reference_state(1,iref_gs)/fac + reference_state(1,iref_grho)*work_yz
            call heatflux_boundcond_x( f, tmp_yz, fac, BOT, work_yz )
          else
            call heatflux_boundcond_x( f, tmp_yz, fac, BOT )
          endif
!
        endif
!
!  top boundary
!  ============
!
      case(TOP)
!
        if (pretend_lnTT.or..not.(lheatc_chiconst.or.lheatc_kramers)) then
          if (headtt.and..not.(lheatc_Kprof.or.lheatc_Kconst)) then
!           Kishore: I am not sure if FtopKtop is correctly set for any
!           other iheatcond, so I will leave this as a warning for now.
            call warning('bc_ss_flux_x', 'FtopKtop may not be correctly set. Please check it.')
          endif
          call get_shared_variable('FtopKtop',FtopKtop)
          if (headtt) print*,'bc_ss_flux_x: FtopKtop=',FtopKtop
        endif
!
!  Deal with the simpler pretend_lnTT=T case first. Now ss is actually
!  lnTT and the boundary condition reads glnTT=FtopKtop/T
!
        if (pretend_lnTT) then
          do i=1,nghost
            f(l2+i,:,:,iss)=f(l2-i,:,:,iss)-dx2_bound(i)*FtopKtop/exp(f(l2,:,:,iss))
          enddo
        else
!
!  calculate Ftop/(K*cs2)
!
          if (ldensity_nolog) then
            if (lheatc_kramers.or.lheatc_chiconst) work_yz=f(l2,:,:,irho)
            if (lreference_state) then
              tmp_yz=cs20*exp(gamma_m1*(log(f(l2,:,:,irho)+reference_state(nx,iref_rho))-lnrho0) &
                     +gamma*(f(l2,:,:,iss)+reference_state(nx,iref_s)))
            else
              tmp_yz=cs20*exp(gamma_m1*(log(f(l2,:,:,irho))-lnrho0)+gamma*f(l2,:,:,iss))
            endif
          else
            if (lheatc_kramers.or.lheatc_chiconst) work_yz=exp(f(l2,:,:,ilnrho))
            tmp_yz=cs20*exp(gamma_m1*(f(l2,:,:,ilnrho)-lnrho0)+gamma*f(l2,:,:,iss))
          endif
!
          if (lheatc_kramers.or.lheatc_chiconst) then
            call get_shared_variable('Fbot',Fbot)
            if ((headtt) .and. (lroot)) print*,'bc_ss_flux_x: Fbot=',Fbot
          endif
!
          if (lheatc_kramers) then
            Krho1kr_yz = hcond0_kramers*work_yz**(-2*nkramers-1)*(tmp_yz/(cp*gamma_m1))**(6.5*nkramers)
!
            if (chimin_kramers>0) Krho1kr_yz = max(Krho1kr_yz, chimin_kramers*cp)
            if (chimax_kramers>0) Krho1kr_yz = min(Krho1kr_yz, chimax_kramers*cp)
!
            tmp_yz=Ftop/(work_yz*Krho1kr_yz*tmp_yz)
          else if (lheatc_chiconst) then
            tmp_yz=Ftop/(work_yz*chi*cp*tmp_yz)
          else
            tmp_yz=FtopKtop/tmp_yz
          endif
!
          if (lreference_state) &
            tmp_yz = tmp_yz + reference_state(nx,iref_gs)
!
!  enforce ds/dx + gamma_m1/gamma*dlnrho/dx = gamma_m1/gamma*Ftop/(K*cs2)   ! check sign
!
          if (lreference_state) then
            work_yz= 1./(f(l2,:,:,irho)+reference_state(nx,iref_rho))
            tmp_yz = tmp_yz + reference_state(nx,iref_gs)/fac + reference_state(nx,iref_grho)*work_yz
            call heatflux_boundcond_x( f, -tmp_yz, fac, TOP, work_yz )     ! check sign of tmp_yz
          else
            call heatflux_boundcond_x( f, -tmp_yz, fac, TOP )
          endif
!
        endif
!
        case default
          call fatal_error('bc_ss_flux_x','topbot should be BOT or TOP')
!
        endselect
!
!  Deallocate large arrays.
!
      if (allocated(tmp_yz)) deallocate(tmp_yz)
      if (allocated(work_yz)) deallocate(work_yz)
!
    endsubroutine bc_ss_flux_x
!************************************************************************
    subroutine heatflux_boundcond_x( f, inh, fac, topbot, coef )
!
!  encapsules BC 'prescribed heat flux at x boundary'
!
!  17-apr-12/MR: outsourced from bc_ss_flux_x
!  11-feb-15/MR: optional parameter coef for correct use of reference state
!
      use Deriv, only: heatflux_deriv_x
!
      real, dimension(:,:,:,:),       intent(INOUT):: f
      real, dimension(:,:),           intent(IN)   :: inh
      real, dimension(:,:), optional, intent(IN)   :: coef
      real                          , intent(IN)   :: fac
      integer                       , intent(IN)   :: topbot
!
      integer :: i,ll,ia,ie
!
      if ( .not.lequidist(1) ) then
        if ( heatflux_deriv_x( f, inh, fac, topbot ) ) return
      endif
!
      if (topbot==BOT) then
        ll=l1; ia=1; ie=nghost
      else
        ll=l2; ia=-nghost; ie=-1
      endif

      do i=ia,ie
        if (ldensity_nolog) then
          if (present(coef)) then
            f(ll-i,:,:,iss)=f(ll+i,:,:,iss)+fac* &
                ( (f(ll+i,:,:,irho)-f(ll-i,:,:,irho))*coef + dx2_bound(-i)*inh )
          else
            f(ll-i,:,:,iss)=f(ll+i,:,:,iss)+fac* &
                (log(f(ll+i,:,:,irho)/f(ll-i,:,:,irho)) + dx2_bound(-i)*inh)
          endif
        else
          f(ll-i,:,:,iss)=f(ll+i,:,:,iss)+fac* &
              (f(ll+i,:,:,ilnrho)-f(ll-i,:,:,ilnrho) + dx2_bound(-i)*inh)
        endif
      enddo
!
  endsubroutine heatflux_boundcond_x
!***********************************************************************
    subroutine bc_del2zero(f,topbot,j)
!
!  Potential field boundary condition
!
!  11-oct-06/wolf: Adapted from Tobi's bc_aa_pot2
!
      use Fourier, only: fourier_transform_xy_xy, kx_fft, ky_fft
!
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent(IN) :: topbot
      integer, intent (in) :: j
!
      real, dimension (l2-l1+1,m2-m1+1) :: kx,ky,kappa,exp_fact,tmp_re,tmp_im
      integer :: i,nxl,nyl
!
!  Allocate memory for large arrays.
!
      nxl=l2-l1+1; nyl=m2-m1+1
!
!  Get local wave numbers
!
      kx = spread(kx_fft(ipx*nxl+1:ipx*nxl+nxl),2,nyl)
      ky = spread(ky_fft(ipy*nyl+1:ipy*nyl+nyl),1,nxl)
!
!  Calculate 1/k^2, zero mean
!
      if (lshear) then
        kappa = sqrt((kx+deltay*ky/Lx)**2+ky**2)
      else
        kappa = sqrt(kx**2 + ky**2)
      endif
!
!  Check whether we want to do top or bottom (this is processor dependent)
!
      select case (topbot)
!
!  Potential field condition at the bottom
!
      case(BOT)
!
        do i=1,nghost
!
! Calculate delta_z based on z(), not on dz to improve behavior for
! non-equidistant grid (still not really correct, but could be OK)
!
          exp_fact = exp(-kappa*dz2_bound(-i))
!
!  Determine potential field in ghost zones
!
          !  Fourier transforms of x- and y-components on the boundary
          tmp_re = f(l1:l2,m1:m2,n1+i,j)
          tmp_im = 0.0
          call fourier_transform_xy_xy(tmp_re,tmp_im)
          tmp_re = tmp_re*exp_fact
          tmp_im = tmp_im*exp_fact
          ! Transform back
          call fourier_transform_xy_xy(tmp_re,tmp_im,linv=.true.)
          f(l1:l2,m1:m2,n1-i,j) = tmp_re
!
        enddo
!
!  Potential field condition at the top
!
      case(TOP)
!
        do i=1,nghost
!
! Calculate delta_z based on z(), not on dz to improve behavior for
! non-equidistant grid (still not really correct, but could be OK)
!
          exp_fact = exp(-kappa*dz2_bound(i))
!
!  Determine potential field in ghost zones
!
          !  Fourier transforms of x- and y-components on the boundary
          tmp_re = f(l1:l2,m1:m2,n2-i,j)
          tmp_im = 0.0
          call fourier_transform_xy_xy(tmp_re,tmp_im)
          tmp_re = tmp_re*exp_fact
          tmp_im = tmp_im*exp_fact
          ! Transform back
          call fourier_transform_xy_xy(tmp_re,tmp_im,linv=.true.)
          f(l1:l2,m1:m2,n2+i,j) = tmp_re
!
        enddo
!
      case default
!
        call fatal_error("bc_del2zero","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_del2zero
!***********************************************************************
    subroutine bc_zero_x(f,topbot,j)
!
!  Zero value in the ghost zones.
!
!  11-aug-2009/anders: implemented
!
      real, dimension (:,:,:,:) :: f
      integer, intent(IN) :: topbot
      integer :: j
!
      select case (topbot)
!
!  Bottom boundary.
!
      case(BOT)
        f(1:l1-1,:,:,j)=0.0
!
!  Top boundary.
!
      case(TOP)
        f(l2+1:,:,:,j)=0.0
!
!  Default.
!
      case default
        call fatal_error("bc_zero_x: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_zero_x
!***********************************************************************
    subroutine bc_zero_y(f,topbot,j)
!
!  Zero value in the ghost zones.
!
!  13-jul-2011/Tijmen: adapted from bc_zero_x
!
      real, dimension (:,:,:,:) :: f
      integer, intent(IN) :: topbot
      integer :: j
!
      select case (topbot)
!
!  Bottom boundary.
!
      case(BOT)
        f(:,1:m1-1,:,j)=0.0
!
!  Top boundary.
!
      case(TOP)
        f(:,m2+1:,:,j)=0.0
!
!  Default.
!
      case default
        call fatal_error("bc_zero_y: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_zero_y
!***********************************************************************
    subroutine bc_zero_z(f,topbot,j)
!
!  Zero value in the ghost zones.
!
!  13-aug-2007/anders: implemented
!
      real, dimension (:,:,:,:) :: f
      integer, intent(IN) :: topbot
      integer :: j
!
      select case (topbot)
!
!  Bottom boundary.
!
      case(BOT)
        f(:,:,1:n1-1,j)=0.0
!
!  Top boundary.
!
      case(TOP)
        f(:,:,n2+1:,j)=0.0
!
!  Default.
!
      case default
        call fatal_error("bc_zero_z: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_zero_z
!***********************************************************************
    subroutine bc_inflow_z(f,topbot,j,lforce_ghost)
!
!  Inflow boundary conditions.
!
!  If the velocity vector points out of the box, the velocity boundary
!  condition is set to 's', otherwise it is set to 'a'.
!  If 'lforce_ghost' is true, the boundary and ghost cell values are forced
!  to not point outwards. Otherwise the boundary value is forced to be 0.
!
!  25-dec-2010/Bourdin.KIS: adapted from 'bc_outflow_z'
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j
      logical, optional :: lforce_ghost
!
      integer :: i, ix, iy
      logical :: lforce
!
      lforce = .false.
      if (present (lforce_ghost)) lforce = lforce_ghost
!
      select case (topbot)
!
!  Bottom boundary.
!
      case(BOT)
        do iy=1,size(f,2); do ix=1,size(f,1)
          if (f(ix,iy,n1,j)>0.0) then  ! 's'
            do i=1,nghost; f(ix,iy,n1-i,j)=+f(ix,iy,n1+i,j); enddo
          else                         ! 'a'
            do i=1,nghost; f(ix,iy,n1-i,j)=-f(ix,iy,n1+i,j); enddo
            f(ix,iy,n1,j)=0.0
          endif
          if (lforce) then
            do i = 0, nghost
              if (f(ix,iy,n1-i,j) < 0.0) f(ix,iy,n1-i,j) = 0.0
            enddo
          endif
        enddo; enddo
!
!  Top boundary.
!
      case(TOP)
        do iy=1,size(f,2); do ix=1,size(f,1)
          if (f(ix,iy,n2,j)<0.0) then  ! 's'
            do i=1,nghost; f(ix,iy,n2+i,j)=+f(ix,iy,n2-i,j); enddo
          else                         ! 'a'
            do i=1,nghost; f(ix,iy,n2+i,j)=-f(ix,iy,n2-i,j); enddo
            f(ix,iy,n2,j)=0.0
          endif
          if (lforce) then
            do i = 0, nghost
              if (f(ix,iy,n2+i,j) > 0.0) f(ix,iy,n2+i,j) = 0.0
            enddo
          endif
        enddo; enddo
!
!  Default.
!
      case default
        call fatal_error("bc_inflow_z: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_inflow_z
!***********************************************************************
    subroutine bc_outflow_x(f,topbot,j,lforce_ghost)
!
!  Outflow boundary conditions.
!
!  If the velocity vector points out of the box, the velocity boundary
!  condition is set to 's', otherwise it is set to 'a'.
!  If 'lforce_ghost' is true, the boundary and ghost cell values are forced
!  to not point inwards. Otherwise the boundary value is forced to be 0.
!
!  14-jun-2011/axel: adapted from bc_outflow_z
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j
      logical, optional :: lforce_ghost
!
      integer :: i, iy, iz
      logical :: lforce
!
      lforce = .false.
      if (present (lforce_ghost)) lforce = lforce_ghost
!
      select case (topbot)
!
!  Bottom boundary.
!
      case(BOT)
        do iy=1,size(f,2); do iz=1,size(f,3)
          if (f(l1,iy,iz,j)<0.0) then  ! 's'
            do i=1,nghost; f(l1-i,iy,iz,j)=+f(l1+i,iy,iz,j); enddo
          else                         ! 'a'
            do i=1,nghost; f(l1-i,iy,iz,j)=-f(l1+i,iy,iz,j); enddo
            f(l1,iy,iz,j)=0.0
          endif
          if (lforce) then
            do i = 0, nghost
              if (f(l1-i,iy,iz,j) > 0.0) f(l1-i,iy,iz,j) = 0.0
            enddo
          endif
        enddo; enddo
!
!  Top boundary.
!
      case(TOP)
        do iy=1,size(f,2); do iz=1,size(f,3)
          if (f(l2,iy,iz,j)>0.0) then  ! 's'
            do i=1,nghost; f(l2+i,iy,iz,j)=+f(l2-i,iy,iz,j); enddo
          else                         ! 'a'
            do i=1,nghost; f(l2+i,iy,iz,j)=-f(l2-i,iy,iz,j); enddo
            f(l2,iy,iz,j)=0.0
          endif
          if (lforce) then
            do i = 0, nghost
              if (f(l2+i,iy,iz,j) < 0.0) f(l2+i,iy,iz,j) = 0.0
            enddo
          endif
        enddo; enddo
!
!  Default.
!
      case default
        call fatal_error("bc_outflow_x: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_outflow_x
!***********************************************************************
    subroutine bc_outflow_x_e1(f,topbot,j,lforce_ghost)
!
!  Outflow boundary conditions.
!
!  If the velocity vector points out of the box, the velocity boundary
!  condition is set to 's', otherwise it is set to 'a'.
!  If 'lforce_ghost' is true, the boundary and ghost cell values are forced
!  to not point inwards. Otherwise the boundary value is forced to be 0.
!
!  14-jun-2011/axel: adapted from bc_outflow_x
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j
      logical, optional :: lforce_ghost
!
      integer :: i, iy, iz
      logical :: lforce
!
      lforce = .false.
      if (present (lforce_ghost)) lforce = lforce_ghost
!
      select case (topbot)
!
!  Bottom boundary.
!
      case(BOT)
        do iy=1,size(f,2); do iz=1,size(f,3)
          if (f(l1,iy,iz,j)<0.0) then  ! 's'
            do i=1,nghost; f(l1-i,iy,iz,j)=+f(l1+i,iy,iz,j); enddo
            f(l1-1,iy,iz,j)=0.25*(  9*f(l1,iy,iz,j)- 3*f(l1+1,iy,iz,j)- 5*f(l1+2,iy,iz,j)+ 3*f(l1+3,iy,iz,j))
            f(l1-2,iy,iz,j)=0.05*( 81*f(l1,iy,iz,j)-43*f(l1+1,iy,iz,j)-57*f(l1+2,iy,iz,j)+39*f(l1+3,iy,iz,j))
            f(l1-3,iy,iz,j)=0.05*(127*f(l1,iy,iz,j)-81*f(l1+1,iy,iz,j)-99*f(l1+2,iy,iz,j)+73*f(l1+3,iy,iz,j))
          else                         ! 'a'
            do i=1,nghost; f(l1-i,iy,iz,j)=-f(l1+i,iy,iz,j); enddo
            f(l1,iy,iz,j)=0.0
          endif
          if (lforce) then
            do i = 0, nghost
              if (f(l1-i,iy,iz,j) > 0.0) f(l1-i,iy,iz,j) = 0.0
            enddo
          endif
        enddo; enddo
!
!  Top boundary.
!
      case(TOP)
        do iy=1,size(f,2); do iz=1,size(f,3)
          if (f(l2,iy,iz,j)>0.0) then  ! 's'
            f(l2+1,iy,iz,j)=0.25*(  9*f(l2,iy,iz,j)- 3*f(l2-1,iy,iz,j)- 5*f(l2-2,iy,iz,j)+ 3*f(l2-3,iy,iz,j))
            f(l2+2,iy,iz,j)=0.05*( 81*f(l2,iy,iz,j)-43*f(l2-1,iy,iz,j)-57*f(l2-2,iy,iz,j)+39*f(l2-3,iy,iz,j))
            f(l2+3,iy,iz,j)=0.05*(127*f(l2,iy,iz,j)-81*f(l2-1,iy,iz,j)-99*f(l2-2,iy,iz,j)+73*f(l2-3,iy,iz,j))
          else                         ! 'a'
            do i=1,nghost; f(l2+i,iy,iz,j)=-f(l2-i,iy,iz,j); enddo
            f(l2,iy,iz,j)=0.0
          endif
          if (lforce) then
            do i = 0, nghost
              if (f(l2+i,iy,iz,j) < 0.0) f(l2+i,iy,iz,j) = 0.0
            enddo
          endif
        enddo; enddo
!
!  Default.
!
      case default
        call fatal_error("bc_outflow_x: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_outflow_x_e1
!***********************************************************************
    subroutine bc_outflow_y(f,topbot,j,lforce_ghost)
!
!  Outflow boundary conditions.
!
!  If the velocity vector points out of the box, the velocity boundary
!  condition is set to 's', otherwise it is set to 'a'.
!  If 'lforce_ghost' is true, the boundary and ghost cell values are forced
!  to not point inwards. Otherwise the boundary value is forced to be 0.
!
!  08-oct-2013/wlad: copied from z
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j
      logical, optional :: lforce_ghost
!
      integer :: i, ix, iz
      logical :: lforce
!
      lforce = .false.
      if (present (lforce_ghost)) lforce = lforce_ghost
!
      select case (topbot)
!
!  Bottom boundary.
!
      case(BOT)
        do iz=1,size(f,3); do ix=1,size(f,1)
          if (f(ix,m1,iz,j)<0.0) then  ! 's'
            do i=1,nghost; f(ix,m1-i,iz,j)=+f(ix,m1+i,iz,j); enddo
          else                         ! 'a'
            do i=1,nghost; f(ix,m1-i,iz,j)=-f(ix,m1+i,iz,j); enddo
            f(ix,m1,iz,j)=0.0
          endif
          if (lforce) then
            do i = 0, nghost
              if (f(ix,m1-i,iz,j) > 0.0) f(ix,m1-i,iz,j) = 0.0
            enddo
          endif
        enddo; enddo
!
!  Top boundary.
!
      case(TOP)
        do iz=1,size(f,3); do ix=1,size(f,1)
          if (f(ix,m2,iz,j)>0.0) then  ! 's'
            do i=1,nghost; f(ix,m2+i,iz,j)=+f(ix,m2-i,iz,j); enddo
          else                         ! 'a'
            do i=1,nghost; f(ix,m2+i,iz,j)=-f(ix,m2-i,iz,j); enddo
            f(ix,m2,iz,j)=0.0
          endif
          if (lforce) then
            do i = 0, nghost
              if (f(ix,m2+i,iz,j) < 0.0) f(ix,m2+i,iz,j) = 0.0
            enddo
          endif
        enddo; enddo
!
!  Default.
!
      case default
        call fatal_error("bc_outflow_y: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_outflow_y
!***********************************************************************
    subroutine bc_outflow_z(f,topbot,j,lforce_ghost)
!
!  Outflow boundary conditions.
!
!  If the velocity vector points out of the box, the velocity boundary
!  condition is set to 's', otherwise it is set to 'a'.
!  If 'lforce_ghost' is true, the boundary and ghost cell values are forced
!  to not point inwards. Otherwise the boundary value is forced to be 0.
!
!  12-aug-2007/anders: implemented
!  25-dec-2010/Bourdin.KIS: added forcing of boundary and ghost cell values
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j
      logical, optional :: lforce_ghost
!
      integer :: i, ix, iy
      logical :: lforce
!
      lforce = .false.
      if (present (lforce_ghost)) lforce = lforce_ghost
!
      select case (topbot)
!
!  Bottom boundary.
!
      case(BOT)
        do iy=1,size(f,2); do ix=1,size(f,1)
          if (f(ix,iy,n1,j)<0.0) then  ! 's'
            do i=1,nghost; f(ix,iy,n1-i,j)=+f(ix,iy,n1+i,j); enddo
          else                         ! 'a'
            do i=1,nghost; f(ix,iy,n1-i,j)=-f(ix,iy,n1+i,j); enddo
            f(ix,iy,n1,j)=0.0
          endif
          if (lforce) then
            do i = 0, nghost
              if (f(ix,iy,n1-i,j) > 0.0) f(ix,iy,n1-i,j) = 0.0
            enddo
          endif
        enddo; enddo
!
!  Top boundary.
!
      case(TOP)
        do iy=1,size(f,2); do ix=1,size(f,1)
          if (f(ix,iy,n2,j)>0.0) then  ! 's'
            do i=1,nghost; f(ix,iy,n2+i,j)=+f(ix,iy,n2-i,j); enddo
          else                         ! 'a'
            do i=1,nghost; f(ix,iy,n2+i,j)=-f(ix,iy,n2-i,j); enddo
            f(ix,iy,n2,j)=0.0
          endif
          if (lforce) then
            do i = 0, nghost
              if (f(ix,iy,n2+i,j) < 0.0) f(ix,iy,n2+i,j) = 0.0
            enddo
          endif
        enddo; enddo
!
!  Default.
!
      case default
        call fatal_error("bc_outflow_z: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_outflow_z
!***********************************************************************
    subroutine bc_inflow_zero_deriv_z(f,topbot,j)
!
!  Inflow boundary condition, tries to create zero 1st derivative at boundary.
!
!  If the velocity vector points out of the box, the velocity boundary
!  condition is set to 's', otherwise it is set to relax to zero derivative.
!  The boundary and ghost cell values are forced to not point outwards.
!
!  27-dec-2010/Bourdin.KIS: adapted from 'bc_outflow_const_deriv_z'
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j
!
      integer :: i, ix, iy
!
      select case (topbot)
!
      ! bottom boundary
      case(BOT)
        do iy = 1, size(f,2)
          do ix = 1, size(f,1)
            ! 's' boundary condition
            do i = 1, nghost
              f(ix,iy,n1-i,j) = f(ix,iy,n1+i,j)
            enddo
            ! force inflow
            do i = 0, nghost
              if (f(ix,iy,n1-i,j) < 0.0) f(ix,iy,n1-i,j) = 0.0
            enddo
          enddo
        enddo
!
      ! top boundary
      case(TOP)
        do iy = 1, size(f,2)
          do ix = 1, size(f,1)
            ! 's' boundary condition
            do i = 1, nghost
              f(ix,iy,n2+i,j) = f(ix,iy,n2-i,j)
            enddo
            ! force inflow
            do i = 0, nghost
              if (f(ix,iy,n2+i,j) > 0.0) f(ix,iy,n2+i,j) = 0.0
            enddo
          enddo
        enddo
!
      case default
        call fatal_error("bc_inflow_zero_deriv_z: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_inflow_zero_deriv_z
!***********************************************************************
    subroutine bc_outflow_zero_deriv_z(f,topbot,j)
!
!  Outflow boundary condition, tries to create zero 1st derivative at boundary.
!
!  If the velocity vector points out of the box, the velocity boundary
!  condition is set to 's', otherwise it is set to relax to zero derivative.
!  The boundary and ghost cell values are forced to not point inwards.
!
!  27-dec-2010/Bourdin.KIS: adapted from 'bc_outflow_z'
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j
!
      integer :: i, ix, iy
!
      select case (topbot)
!
      ! bottom boundary
      case(BOT)
        do iy = 1, size(f,2)
          do ix = 1, size(f,1)
            ! 's' boundary condition
            do i = 1, nghost
              f(ix,iy,n1-i,j) = f(ix,iy,n1+i,j)
            enddo
            ! force outflow
            do i = 0, nghost
              if (f(ix,iy,n1-i,j) > 0.0) f(ix,iy,n1-i,j) = 0.0
            enddo
          enddo
        enddo
!
      ! top boundary
      case(TOP)
        do iy = 1, size(f,2)
          do ix = 1, size(f,1)
            ! 's' boundary condition
            do i = 1, nghost
              f(ix,iy,n2+i,j) = f(ix,iy,n2-i,j)
            enddo
            ! force outflow
            do i = 0, nghost
              if (f(ix,iy,n2+i,j) < 0.0) f(ix,iy,n2+i,j) = 0.0
            enddo
          enddo
        enddo
!
      case default
        call fatal_error("bc_outflow_zero_deriv_z: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_outflow_zero_deriv_z
!***********************************************************************
    subroutine bc_inflow_inwards_deriv_z(f,topbot,j)
!
!  Inflow boundary condition with inwards 1st derivative at boundary.
!
!  The velocity boundary condition is set to 's' or 'a' for steady flows.
!  The boundary and ghost cell values are forced to not point outwards.
!
!  10-jul-2012/Bourdin.KIS: adapted from 'bc_inflow_zero_deriv_z'
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j
!
      integer :: i, ix, iy
!
      select case (topbot)
!
      ! bottom boundary
      case(BOT)
        do iy = 1, size(f,2)
          do ix = 1, size(f,1)
            ! 's' or 'a' boundary condition for forced inflow
            do i = 1, nghost
              f(ix,iy,n1-i,j) = abs (f(ix,iy,n1+i,j))
            enddo
            if (f(ix,iy,n1,j) < 0.0) f(ix,iy,n1,j) = 0.0
          enddo
        enddo
!
      ! top boundary
      case(TOP)
        do iy = 1, size(f,2)
          do ix = 1, size(f,1)
            ! 's' or 'a' boundary condition for forced inflow
            do i = 1, nghost
              f(ix,iy,n2+i,j) = -abs (f(ix,iy,n2-i,j))
            enddo
            if (f(ix,iy,n2,j) > 0.0) f(ix,iy,n2,j) = 0.0
          enddo
        enddo
!
      case default
        call fatal_error("bc_inflow_inwards_deriv_z: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_inflow_inwards_deriv_z
!***********************************************************************
    subroutine bc_outflow_outwards_deriv_z(f,topbot,j)
!
!  Outflow boundary condition with outwards 1st derivative at boundary.
!
!  The velocity boundary condition is set to 's' or 'a' for steady flows.
!  The boundary and ghost cell values are forced to not point inwards.
!
!  10-jul-2012/Bourdin.KIS: adapted from 'bc_outflow_zero_deriv_z'
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j
!
      integer :: i, ix, iy
!
      select case (topbot)
!
      ! bottom boundary
      case(BOT)
        do iy = 1, size(f,2)
          do ix = 1, size(f,1)
            ! 's' or 'a' boundary condition for forced outflow
            do i = 1, nghost
              f(ix,iy,n1-i,j) = -abs (f(ix,iy,n1+i,j))
            enddo
            if (f(ix,iy,n1,j) > 0.0) f(ix,iy,n1,j) = 0.0
          enddo
        enddo
!
      ! top boundary
      case(TOP)
        do iy = 1, size(f,2)
          do ix = 1, size(f,1)
            ! 's' or 'a' boundary condition for forced outflow
            do i = 1, nghost
              f(ix,iy,n2+i,j) = abs (f(ix,iy,n2-i,j))
            enddo
            if (f(ix,iy,n2,j) < 0.0) f(ix,iy,n2,j) = 0.0
          enddo
        enddo
!
      case default
        call fatal_error("bc_outflow_outwards_deriv_z: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_outflow_outwards_deriv_z
!***********************************************************************
    subroutine bc_steady_z(f,topbot,j)
!
!  Steady in/outflow boundary conditions.
!
!  Match ghost to outward velocity on boundary. Impose positive inward
!  gradient in ghost zones for inflow on boundary.
!
!  06-nov-2010/fred: implemented
!  14-mar-2011/fred: amended
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j
!
      integer :: i, ix, iy
!
      select case (topbot)
!
!  Bottom boundary.
!
      case(BOT)
        do iy=1,size(f,2); do ix=1,size(f,1)
          if (f(ix,iy,n1,j) <= 0.0) then
            do i=1,nghost; f(ix,iy,n1-i,j)=f(ix,iy,n1,j); enddo
          else
            if (f(ix,iy,n1,j) > f(ix,iy,n1+1,j)) then
              f(ix,iy,n1-1,j)=0.5*(f(ix,iy,n1,j)    +f(ix,iy,n1+1,j))
            else
              f(ix,iy,n1-1,j)=2.0* f(ix,iy,n1,j)    -f(ix,iy,n1+1,j)
            endif
            do i=2,nghost
              f(ix,iy,n1-i,j)=2.0* f(ix,iy,n1-i+1,j)-f(ix,iy,n1-i+2,j)
            enddo
          endif
        enddo; enddo
!
!  Top boundary.
!
      case(TOP)
        do iy=1,size(f,2); do ix=1,size(f,1)
          if (f(ix,iy,n2,j) >= 0.0) then
            do i=1,nghost; f(ix,iy,n2+i,j)=f(ix,iy,n2,j); enddo
          else
            if (f(ix,iy,n2,j) < f(ix,iy,n2-1,j)) then
              f(ix,iy,n2+1,j)=0.5*(f(ix,iy,n2,j)    +f(ix,iy,n2-1,j))
            else
              f(ix,iy,n2+1,j)=2.0* f(ix,iy,n2,j)    -f(ix,iy,n2-1,j)
            endif
            do i=2,nghost
              f(ix,iy,n2+i,j)=2.0* f(ix,iy,n2+i-1,j)-f(ix,iy,n2+i-2,j)
            enddo
          endif
        enddo; enddo
!
!  Default.
!
      case default
        call fatal_error("bc_steady_z: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_steady_z
!***********************************************************************
    subroutine bc_copy_x(f,topbot,j)
!
!  Copy value in last grid point to all ghost cells.
!
!  11-aug-2009/anders: implemented
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j
!
      integer :: i
!
      select case (topbot)
!
!  Bottom boundary.
!
      case(BOT)
        do i=1,nghost; f(l1-i,:,:,j)=f(l1,:,:,j); enddo
!
!  Top boundary.
!
      case(TOP)
        do i=1,nghost; f(l2+i,:,:,j)=f(l2,:,:,j); enddo
!
!  Default.
!
      case default
        call fatal_error("bc_copy_x: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_copy_x
!***********************************************************************
    subroutine bc_copy_y(f,topbot,j)
!
!  Copy value in last grid point to all ghost cells.
!
!  08-june-2010/wlyra: implemented
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j
!
      integer :: i
!
      select case (topbot)
!
!  Bottom boundary.
!
      case(BOT)
        do i=1,nghost; f(:,m1-i,:,j)=f(:,m1,:,j); enddo
!
!  Top boundary.
!
      case(TOP)
        do i=1,nghost; f(:,m2+i,:,j)=f(:,m2,:,j); enddo
!
!  Default.
!
      case default
        call fatal_error("bc_copy_y: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_copy_y
!***********************************************************************
    subroutine bc_copy_y_noinflow(f,topbot,j)
!
!  Copy value in last grid point to all ghost cells. Set to zero if
!  the sign is wrong. This bc is different from outflow (cop). Outflow
!  just copies the last point to the ghost cells, thus permitting both
!  outflow (uy pointing out of the box) and inflow (uy pointing back to
!  the box). 'c+k' is a no-inflow, purely outflow boundary. It sets the
!  velocity to zero if that was pointing back to the box. The 'k' means
!  "kill". "copy if outflow, kill if inflow".
!
!  08-june-2010/wlyra: implemented
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real :: value
      integer :: j,l,n
!
      integer :: i
!
      select case (topbot)
!
!  Bottom boundary.
!
      case(BOT)
        do l=1,size(f,1); do n=1,size(f,3)
          value=0.
          if (f(l,m1,n,j)<0) value=f(l,m1,n,j)
          do i=1,nghost
            f(l,m1-i,n,j)=value
          enddo
        enddo;enddo
!
!  Top boundary.
!
      case(TOP)
        do l=1,size(f,1); do n=1,size(f,3)
          value=0.
          if (f(l,m2,n,j) > 0) value=f(l,m2,n,j)
          do i=1,nghost
            f(l,m2+i,n,j)=value
          enddo
        enddo; enddo
!
!  Default.
!
      case default
        call fatal_error("bc_copy_y_noinflow: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_copy_y_noinflow
!***********************************************************************
    subroutine bc_copy_z(f,topbot,j)
!
!  Copy value in last grid point to all ghost cells.
!
!  15-aug-2007/anders: implemented
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j
!
      integer :: i
!
      select case (topbot)
!
!  Bottom boundary.
!
      case(BOT)
        forall(i=1:nghost) f(:,:,n1-i,j) = f(:,:,n1,j)
!
!  Top boundary.
!
      case(TOP)
        forall(i=1:nghost) f(:,:,n2+i,j) = f(:,:,n2,j)
!
!  Default.
!
      case default
        call fatal_error("bc_copy_z: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_copy_z
!***********************************************************************
    subroutine bc_expother_x(f,topbot,j,jsrc)

      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j,jsrc

      select case (topbot)
!
!  Bottom boundary.
!
      case(BOT)
        f(1:nghost,:,:,j) = exp(f(1:nghost,:,:,jsrc))
!
!  Top boundary.
!
      case(TOP)
        f(l2+1:mx,:,:,j) = exp(f(l2+1:mx,:,:,jsrc))
!
!  Default.
!
      case default
        call fatal_error("bc_expother_x: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_expother_x
!***********************************************************************
    subroutine bc_expother_y(f,topbot,j,jsrc)

      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j,jsrc

      select case (topbot)
!
!  Bottom boundary.
!
      case(BOT)
        f(:,1:nghost,:,j) = exp(f(:,1:nghost,:,jsrc))
!
!  Top boundary.
!
      case(TOP)
        f(:,m2+1:my,:,j) = exp(f(:,m2+1:my,:,jsrc))
!
!  Default.
!
      case default
        call fatal_error("bc_expother_y: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_expother_y
!***********************************************************************
    subroutine bc_expother_z(f,topbot,j,jsrc)

      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j,jsrc

      select case (topbot)
!
!  Bottom boundary.
!
      case(BOT)
        f(:,:,1:nghost,j) = exp(f(:,:,1:nghost,jsrc))
!
!  Top boundary.
!
      case(TOP)
        f(:,:,n2+1:mz,j) = exp(f(:,:,n2+1:mz,jsrc))
!
!  Default.
!
      case default
        call fatal_error("bc_expother_z: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_expother_z
!***********************************************************************
    subroutine bc_copy_z_noinflow(f,topbot,j)
!
!  Copy value in last grid point to all ghost cells. Set to zero if
!  the sign is wrong. This bc is different from outflow (cop). Outflow
!  just copies the last point to the ghost cells, thus permitting both
!  outflow (uy pointing out of the box) and inflow (uy pointing back to
!  the box). 'crk' is a no-inflow, purely outflow boundary. It sets the
!  velocity to zero if that was pointing back to the box. The 'k' means
!  "kill". "copy amd reduce if outflow, kill if inflow". Additionally the velocity
!  in the ghost zones are reduced by a factor 
!  2i, where i is the i-th ghost zone
!
!  22-mar-2018/piyali: copied from bc_copy_z_noinflow
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j
!
      real :: value
      integer :: i,l
!
      select case (topbot)
!
!  Bottom boundary.
!
      case(BOT)
        do l=1,size(f,1); do m=1,size(f,2)
          value=0.
          if (f(l,m,n1,j)<0) value=f(l,m,n1,j)
          do i=1,nghost
            f(l,m,n1-i,j)=value/(1.0*i)
          enddo
        enddo;enddo
!
!  Top boundary.
!
      case(TOP)
        do l=1,size(f,1); do m=1,size(f,2)
          do i=1,nghost
            value=0.
            if (f(l,m,n2,j) > 0) value=f(l,m,n2-i,j)
            f(l,m,n2+i,j)=value/(1.0*i)
          enddo
        enddo; enddo
!
!  Default.
!
      case default
        call fatal_error("bc_copy_z_noinflow: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_copy_z_noinflow
!***********************************************************************
    subroutine bc_frozen_in_bb(topbot,j)
!
!  Set flags to indicate that magnetic flux is frozen-in at the
!  boundary. The implementation occurs in daa_dt where magnetic
!  diffusion is switched off in the corresponding layer.
!
      use SharedVariables, only: get_shared_variable
!
      integer, intent(IN) :: topbot
      integer :: j
!
      logical, save :: lfirstcall=.true.
      logical, pointer, save, dimension (:) :: lfrozen_bb_bot, lfrozen_bb_top
!
      if (lfirstcall) then
        call get_shared_variable('lfrozen_bb_bot',lfrozen_bb_bot,caller='bc_frozen_in_bb')
        call get_shared_variable('lfrozen_bb_top',lfrozen_bb_top)
      endif
!
      select case (topbot)
      case(BOT)               ! bottom boundary
        lfrozen_bb_bot(j-iax+1) = .true.    ! set flag
      case(TOP)               ! top boundary
        lfrozen_bb_top(j-iax+1) = .true.    ! set flag
      case default
        call fatal_error("bc_frozen_in_bb: ","topbot should be BOT or TOP")
      endselect
!
      lfirstcall=.false.
!
    endsubroutine bc_frozen_in_bb
!***********************************************************************
    subroutine bcz_hydrostatic_temp(f,topbot)
!
!  The logarithmic density in the ghost cells is used to calculate the
!  logarithmic temperature under the assumption of a hydrostatic equilibrium.
!
!  19-nov-2010/Bourdin.KIS: coded
!
      use SharedVariables, only: get_shared_variable
!
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent(IN) :: topbot
!
      integer :: i
      real, dimension (size(f,1),size(f,2)) :: T_inv, grad_rho
      real :: g_ref, delta_z, inv_cp_cv
      real, dimension (:), pointer :: gravz_zpencil
!
!
      call get_shared_variable ('gravz_zpencil', gravz_zpencil, caller='bcz_hydrostatic_temp')
      inv_cp_cv = gamma / gamma_m1 * cp1
!
      select case (topbot)
      case(BOT)
        ! bottom (left end of the domain)
        do i = 1, nghost
          delta_z = z(n1-i) - z(n1-i+1)
          g_ref = gravz_zpencil(n1-i+1)
          T_inv = exp (-f(:,:,n1-i+1,ilnTT))
          grad_rho = f(:,:,n1-i+1,ilnrho) - f(:,:,n1-i,ilnrho)
          f(:,:,n1-i,ilnTT) = f(:,:,n1-i+1,ilnTT) + grad_rho + g_ref*delta_z*inv_cp_cv*T_inv
        enddo
      case(TOP)
        ! top (right end of the domain)
        do i = 1, nghost
          delta_z = z(n2+i) - z(n2+i-1)
          g_ref = gravz_zpencil(n2+i-1)
          T_inv = exp (-f(:,:,n2+i-1,ilnTT))
          grad_rho = f(:,:,n2+i-1,ilnrho) - f(:,:,n2+i,ilnrho)
          f(:,:,n2+i,ilnTT) = f(:,:,n2+i-1,ilnTT) + grad_rho + g_ref*delta_z*inv_cp_cv*T_inv
        enddo
      case default
        call fatal_error ('bcz_hydrostatic_temp', 'topbot should be BOT or TOP', lfirst_proc_xy)
      endselect
!
    endsubroutine bcz_hydrostatic_temp
!***********************************************************************
    subroutine bcz_hydrostatic_rho(f,topbot)
!
!  The logarithmic temperature in the ghost cells is used to calculate the
!  logarithmic density under the assumption of a hydrostatic equilibrium.
!
!  24-May-2019/PABourdin: adapted from bcz_hydrostatic_temp
!
      use SharedVariables, only: get_shared_variable
!
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent(IN) :: topbot
!
      integer :: i
      real, dimension (size(f,1),size(f,2)) :: T_inv
      real :: g_ref, delta_z, inv_cp_cv
      real, dimension (:), pointer :: gravz_zpencil
!
!
      call get_shared_variable ('gravz_zpencil', gravz_zpencil, caller='bcz_hydrostatic_rho')
      inv_cp_cv = gamma / gamma_m1 * cp1
!
      select case (topbot)
      case(BOT)
        ! bottom (left end of the domain)
        do i = 1, nghost
          delta_z = z(n1-i) - z(n1-i+1)
          g_ref = 0.5 * (gravz_zpencil(n1-i) + gravz_zpencil(n1-i+1))
          T_inv = exp (-0.5 * (f(:,:,n1-i,ilnTT) + f(:,:,n1-i+1,ilnTT)))
          f(:,:,n1-i,ilnrho) = f(:,:,n1-i+1,ilnrho) + g_ref*delta_z*inv_cp_cv*T_inv
        enddo
      case(TOP)
        ! top (right end of the domain)
        do i = 1, nghost
          delta_z = z(n2+i) - z(n2+i-1)
          g_ref = 0.5 * (gravz_zpencil(n2+i) + gravz_zpencil(n2+i-1))
          T_inv = exp (-0.5 * (f(:,:,n2+i,ilnTT) + f(:,:,n2+i-1,ilnTT)))
          f(:,:,n2+i,ilnrho) = f(:,:,n2+i-1,ilnrho) + g_ref*delta_z*inv_cp_cv*T_inv
        enddo
      case default
        call fatal_error ('bcz_hydrostatic_rho', 'topbot should be BOT or TOP', lfirst_proc_xy)
      endselect
!
    endsubroutine bcz_hydrostatic_rho
!***********************************************************************
    subroutine finalize_boundcond(f)
!
!  Call finalization routines, i.e. freeing allocated memory.
!
! 15-aug-2011/Bourdin.KIS: adapted from finalize_modules
!
      use General, only: keep_compiler_quiet
!
      real, dimension(:,:,:,:) :: f
!
      call bc_aa_pot_field_extrapol(f,BOT,.true.)
      call bc_aa_pot_field_extrapol(f,TOP,.true.)
!
    endsubroutine finalize_boundcond
!***********************************************************************
    subroutine bc_aa_pot_field_extrapol(f,topbot,lfinalize)
!
!  Potential field extrapolation in z-direction for the ghost cells.
!  To have a smooth transition at the boundary from non-force-free to a
!  force-free field, the Az component is also extrapolated in the same way.
!  This reduces strong currents at the top boundary.
!  At the bottom boundary the extrapolation increases contrasts in A.
!  This mimicks flux tubes that become narrower below the photosphere.
!
!  9-jul-2010/Bourdin.KIS: coded
!
      use Fourier, only: vect_pot_extrapol_z_parallel, kx_fft, ky_fft
      use General, only: loptest
!
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent(IN) :: topbot
      logical, optional :: lfinalize
!
      real, dimension (:,:,:), allocatable, save :: exp_fact_top, exp_fact_bot
      integer, parameter :: bnx=nygrid, bny=nx/nprocy
      integer :: kx_start, stat, pos_z
      real :: delta_z, reduce_factor=1.
!
      if (ldownsampling) then
        call warning('bc_force_aa_time','Not available for downsampling')       
        return
      endif

      if (loptest(lfinalize)) then
        if (allocated (exp_fact_bot)) deallocate (exp_fact_bot)
        if (allocated (exp_fact_top)) deallocate (exp_fact_top)
        return
      endif
!
      ! reduce_factor reduces the structure increase at the bottom boundary
      ! to help numerically resolving the strong gradients in the ghost cells.
      ! Set reduce_factor to [0,1] by using fbcz_bot(iaa) in run_pars.
      ! A value of 1 (default) switches this reducing-mechanism off.
      ! A value of 0 just clones the vector field A from the n1-layer.
      if (fbcz_bot(iaa) /= 0.) reduce_factor = fbcz_bot(iaa)
!
      if (mod (nx, nprocy) /= 0) &
          call fatal_error ('bc_aa_pot_field_extrapol', 'nx needs to be an integer multiple of nprocy.', lfirst_proc_xy)
!
!  Check whether we want to do top or bottom z boundary
!
      select case (topbot)
      case(BOT)
        if (.not. allocated (exp_fact_bot)) then
          ! Setup exponential factor for bottom boundary
          allocate (exp_fact_bot(bnx,bny,nghost), stat=stat)
          if (stat > 0) call fatal_error ('bc_aa_pot_field_extrapol', 'could not allocate exp_fact_bot', .true.)
          ! Get wave numbers already in transposed pencil shape and calculate exp(|k|)
          kx_start = (ipx+ipy*nprocx)*bny
          exp_fact_bot = spread (exp (sqrt (spread (ky_fft(1:bnx), 2, bny) ** 2 + &
                                            spread (kx_fft(kx_start+1:kx_start+bny), 1, bnx) ** 2)), 3, nghost)
          do pos_z = 1, nghost
            ! dz is positive => enhance structures or contrast
            delta_z = reduce_factor * (z(n1) - z(n1-nghost+pos_z-1))
            ! Include normalization factor for fourier transform: 1/(nxgrid*nygrid)
            exp_fact_bot(:,:,pos_z) = exp_fact_bot(:,:,pos_z) ** delta_z / (nxgrid*nygrid)
          enddo
        endif
        call vect_pot_extrapol_z_parallel &
             (f(l1:l2,m1:m2,n1,iax:iaz), f(l1:l2,m1:m2,n1-nghost:n1-1,iax:iaz), exp_fact_bot)
      case(TOP)
        if (.not. allocated (exp_fact_top)) then
          ! Setup exponential factor for top boundary
          allocate (exp_fact_top(bnx,bny,nghost), stat=stat)
          if (stat > 0) call fatal_error ('bc_aa_pot_field_extrapol', 'could not allocate exp_fact_top', .true.)
          ! Get wave numbers already in transposed pencil shape and calculate exp(|k|)
          kx_start = (ipx+ipy*nprocx)*bny
          exp_fact_top = spread (exp (sqrt (spread (ky_fft(1:bnx), 2, bny) ** 2 + &
                                            spread (kx_fft(kx_start+1:kx_start+bny), 1, bnx) ** 2)), 3, nghost)
          do pos_z = 1, nghost
            ! dz is negative => decay of structures
            delta_z = z(n2) - z(n2+pos_z)
            ! Include normalization factor for fourier transform: 1/(nxgrid*nygrid)
            exp_fact_top(:,:,pos_z) = exp_fact_top(:,:,pos_z) ** delta_z / (nxgrid*nygrid)
          enddo
        endif
        call vect_pot_extrapol_z_parallel &
             (f(l1:l2,m1:m2,n2,iax:iaz), f(l1:l2,m1:m2,n2+1:n2+nghost,iax:iaz), exp_fact_top)
      case default
        call fatal_error ('bc_aa_pot_field_extrapol', 'topbot should be BOT or TOP', lfirst_proc_xy)
      endselect
!
!  The vector potential needs to be known outside of (l1:l2,m1:m2) as well
!
      call communicate_vect_field_ghosts(f,topbot)
!
    endsubroutine bc_aa_pot_field_extrapol
!***********************************************************************
    subroutine bc_aa_pot3(f,topbot)
!
!  Potential field boundary condition
!
!  11-oct-06/wolf: Adapted from Tobi's bc_aa_pot2
!
      use Fourier, only: fourier_transform_xy_xy, kx_fft, ky_fft
!
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent(IN) :: topbot
!
      real, dimension (l2-l1+1,m2-m1+1,iax:iaz) :: aa_re,aa_im
      real, dimension (l2-l1+1,m2-m1+1) :: kx,ky,kappa,exp_fact,tmp_re,tmp_im
      real    :: delta_z
      integer :: i,j,nxl,nyl
!
!  Get local wave numbers
!
      nxl=l2-l1+1; nyl=m2-m1+1
      kx = spread(kx_fft(ipx*nxl+1:ipx*nxl+nxl),2,nyl)
      ky = spread(ky_fft(ipy*nyl+1:ipy*nyl+nyl),1,nxl)
!
!  Calculate 1/k^2, zero mean
!
      kappa = sqrt(kx**2 + ky**2)
!
!  Fourier transforms of x- and y-components on the boundary
!  Check whether we want to do top or bottom (this is processor dependent)
!
      select case (topbot)
!
      case(BOT)
        ! Potential field condition at the bottom
        do j=1,nghost
!
! Calculate delta_z based on z(), not on dz to improve behavior for
! non-equidistant grid (still not really correct, but could be OK)
!
          delta_z  = z(n1+j) - z(n1-j)
          exp_fact = exp(-kappa*delta_z)
          ! Determine potential field in ghost zones
          do i=iax,iaz
            tmp_re = f(l1:l2,m1:m2,n1+j,i)
            tmp_im = 0.0
            call fourier_transform_xy_xy(tmp_re,tmp_im)
            aa_re(:,:,i) = tmp_re*exp_fact
            aa_im(:,:,i) = tmp_im*exp_fact
          enddo
         ! Transform back
          do i=iax,iaz
            tmp_re = aa_re(:,:,i)
            tmp_im = aa_im(:,:,i)
            call fourier_transform_xy_xy(tmp_re,tmp_im,linv=.true.)
            f(l1:l2,m1:m2,n1-j,i) = tmp_re
          enddo
        enddo
!
      case(TOP)
        ! Potential field condition at the top
        do j=1,nghost
!
! Calculate delta_z based on z(), not on dz to improve behavior for
! non-equidistant grid (still not really correct, but could be OK)
!
          delta_z  = z(n2+j) - z(n2-j)
          exp_fact = exp(-kappa*delta_z)
          ! Determine potential field in ghost zones
          do i=iax,iaz
            tmp_re = f(l1:l2,m1:m2,n2-j,i)
            tmp_im = 0.0
            call fourier_transform_xy_xy(tmp_re,tmp_im)
            aa_re(:,:,i) = tmp_re*exp_fact
            aa_im(:,:,i) = tmp_im*exp_fact
          enddo
          ! Transform back
          do i=iax,iaz
            tmp_re = aa_re(:,:,i)
            tmp_im = aa_im(:,:,i)
            call fourier_transform_xy_xy(tmp_re,tmp_im,linv=.true.)
            f(l1:l2,m1:m2,n2+j,i) = tmp_re
          enddo
        enddo
!
      case default
        call fatal_error('bc_aa_pot3', 'topbot should be BOT or TOP', lfirst_proc_xy)
!
      endselect
!
!  The vector potential needs to be known outside of (l1:l2,m1:m2) as well
!
      call communicate_vect_field_ghosts(f,topbot)
!
    endsubroutine bc_aa_pot3
!***********************************************************************
    subroutine bc_aa_pot2(f,topbot)
!
!  Potential field boundary condition
!
!  10-oct-06/tobi: Coded
!
      use Fourier, only: fourier_transform_xy_xy, fourier_transform_y_y, kx_fft, ky_fft
!
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent(IN) :: topbot
!
      real, dimension (l2-l1+1,m2-m1+1,iax:iaz) :: aa_re,aa_im
      real, dimension (l2-l1+1,m2-m1+1) :: kx,ky,kappa
      real, dimension (l2-l1+1,m2-m1+1) :: tmp_re,tmp_im,fac
      integer :: i,j,nxl,nyl
!
      nxl=l2-l1+1; nyl=m2-m1+1
!
!  Get local wave numbers
!
      if (nxgrid>1) then
        kx = spread(kx_fft(ipx*nxl+1:ipx*nxl+nxl),2,nyl)
        ky = spread(ky_fft(ipy*nyl+1:ipy*nyl+nyl),1,nxl)
      else
        kx(1,:) = 0.0
        ky(1,:) = ky_fft(ipy*nyl+1:ipy*nyl+nyl)
      endif
!
!  Calculate 1/k^2, zero mean
!
      kappa = sqrt(kx**2 + ky**2)
!
!  Fourier transforms of x- and y-components on the boundary
!  Check whether we want to do top or bottom (this is processor dependent)
!
      select case (topbot)
!
      case(BOT)
        ! Potential field condition at the bottom
        do i=iax,iaz
          tmp_re = f(l1:l2,m1:m2,n1,i)
          tmp_im = 0.0
          if (nxgrid>1) then
            call fourier_transform_xy_xy(tmp_re,tmp_im)
          else
            call fourier_transform_y_y(tmp_re,tmp_im)
          endif
          aa_re(:,:,i) = tmp_re
          aa_im(:,:,i) = tmp_im
        enddo
        ! Determine potential field in ghost zones
        do j=1,nghost
          fac = exp(-j*kappa*dz)
          do i=iax,iaz
            tmp_re = fac*aa_re(:,:,i)
            tmp_im = fac*aa_im(:,:,i)
            if (nxgrid>1) then
              call fourier_transform_xy_xy(tmp_re,tmp_im,linv=.true.)
            else
              call fourier_transform_y_y(tmp_re,tmp_im,linv=.true.)
            endif
            f(l1:l2,m1:m2,n1-j,i) = tmp_re
          enddo
        enddo
!
      case(TOP)
        ! Potential field condition at the top
        do i=iax,iaz
          tmp_re = f(l1:l2,m1:m2,n2,i)
          tmp_im = 0.0
          if (nxgrid>1) then
            call fourier_transform_xy_xy(tmp_re,tmp_im)
          else
            call fourier_transform_y_y(tmp_re,tmp_im)
          endif
          aa_re(:,:,i) = tmp_re
          aa_im(:,:,i) = tmp_im
        enddo
        ! Determine potential field in ghost zones
        do j=1,nghost
          fac = exp(-j*kappa*dz)
          do i=iax,iaz
            tmp_re = fac*aa_re(:,:,i)
            tmp_im = fac*aa_im(:,:,i)
            if (nxgrid>1) then
              call fourier_transform_xy_xy(tmp_re,tmp_im,linv=.true.)
            else
              call fourier_transform_y_y(tmp_re,tmp_im,linv=.true.)
            endif
            f(l1:l2,m1:m2,n2+j,i) = tmp_re
          enddo
        enddo
!
      case default
        call fatal_error('bc_aa_pot2', 'topbot should be BOT or TOP', lfirst_proc_xy)
!
      endselect
!
!  The vector potential needs to be known outside of (l1:l2,m1:m2) as well
!
        call communicate_vect_field_ghosts(f,topbot)
!
    endsubroutine bc_aa_pot2
!***********************************************************************
      subroutine bc_aa_pot(f,topbot)
!
!  Potential field boundary condition for magnetic vector potential at
!  bottom or top boundary (in z).
!
!  14-jun-2002/axel: adapted from similar
!   8-jul-2002/axel: introduced topbot argument
!
      real, dimension (:,:,:,:) :: f
      integer, intent(IN) :: topbot
!
      real, dimension (l2-l1+1,m2-m1+1) :: f2,f3
      real, dimension (l2-l1+1,m2-m1+1,nghost+1) :: fz
      integer :: j
!
!  potential field condition
!  check whether we want to do top or bottom (this is processor dependent)
!
      select case (topbot)
!
!  potential field condition at the bottom
!
      case(BOT)
        if (headtt) print*,'bc_aa_pot: pot-field bdry cond at bottom'
        if (mod(nxgrid,nygrid)/=0) &
             call fatal_error("bc_aa_pot", "pot-field doesn't work "//&
                 "with mod(nxgrid,nygrid)/=0", lfirst_proc_xy)
        do j=0,1
          f2=f(l1:l2,m1:m2,n1+1,iax+j)
          f3=f(l1:l2,m1:m2,n1+2,iax+j)
          call potential_field(fz,f2,f3,-1)
          f(l1:l2,m1:m2,1:n1,iax+j)=fz
        enddo
!
        f2=f(l1:l2,m1:m2,n1,iax)
        f3=f(l1:l2,m1:m2,n1,iay)
        call potentdiv(fz,f2,f3,-1)
        f(l1:l2,m1:m2,1:n1,iaz)=-fz
!
!  potential field condition at the top
!
      case(TOP)
        if (headtt) print*,'bc_aa_pot: pot-field bdry cond at top'
        if (mod(nxgrid,nygrid)/=0) &
             call fatal_error("bc_aa_pot", "pot-field doesn't work "//&
                 "with mod(nxgrid,nygrid)/=0", lfirst_proc_xy)
        do j=0,1
          f2=f(l1:l2,m1:m2,n2-1,iax+j)
          f3=f(l1:l2,m1:m2,n2-2,iax+j)
          call potential_field(fz,f2,f3,+1)
          f(l1:l2,m1:m2,n2:,iax+j)=fz
        enddo
!
        f2=f(l1:l2,m1:m2,n2,iax)
        f3=f(l1:l2,m1:m2,n2,iay)
        call potentdiv(fz,f2,f3,+1)
        f(l1:l2,m1:m2,n2:,iaz)=-fz
      case default
        call fatal_error('bc_aa_pot', 'topbot should be BOT or TOP', lfirst_proc_xy)
      endselect
!
      call communicate_vect_field_ghosts(f,topbot)
!
      endsubroutine bc_aa_pot
!***********************************************************************
      subroutine potential_field(fz,f2,f3,irev)
!
!  solves the potential field boundary condition;
!  fz is the boundary layer, and f2 and f3 are the next layers inwards.
!  The condition is the same on the two sides.
!
!  20-jan-00/axel+wolf: coded
!  22-mar-00/axel: corrected sign (it is the same on both sides)
!  29-sep-06/axel: removed multiple calls, removed normalization, non-para
!
      use Fourier, only: fourier_transform_xy_xy, kx_fft, ky_fft
!
      real, dimension (:,:,:) :: fz
      real, dimension (:,:) :: f2,f3
      integer :: irev
!
      real, dimension(l2-l1+1,m2-m1+1) :: fac,kk,f1r,f1i,g1r,g1i,f2r,f2i,f3r,f3i
      real :: delz
      integer :: i,nxl,nyl
!
      nxl=l2-l1+1; nyl=m2-m1+1
!
!  initialize workspace
!
      f2r=f2; f2i=0
      f3r=f3; f3i=0
!
!  Transform; real and imaginary parts
!
      call fourier_transform_xy_xy(f2r,f2i)
      call fourier_transform_xy_xy(f3r,f3i)
!
!  define wave vector
!  calculate sqrt(k^2)
!
      kk=sqrt(spread(kx_fft(ipx*nxl+1:ipx*nxl+nxl)**2,2,nyl)+spread(ky_fft(ipy*nyl+1:ipy*nyl+nyl)**2,1,nxl))
!
!  one-sided derivative
!
      fac=1./(3.+2.*dz*kk)
      f1r=fac*(4.*f2r-f3r)
      f1i=fac*(4.*f2i-f3i)
!
!  set ghost zones
!
      do i=0,nghost
        delz=i*dz
        fac=exp(-kk*delz)
        g1r=fac*f1r
        g1i=fac*f1i
!
!  Transform back
!
        call fourier_transform_xy_xy(g1r,g1i,linv=.true.)
!
!  reverse order if irev=-1 (if we are at the bottom)
!
        if (irev==+1) fz(:,:,       i+1) = g1r
        if (irev==-1) fz(:,:,nghost-i+1) = g1r
      enddo
!
    endsubroutine potential_field
!***********************************************************************
    subroutine potentdiv(fz,f2,f3,irev)
!
!  solves the divA=0 for potential field boundary condition;
!  f2 and f3 correspond to Ax and Ay (input) and fz corresponds to Ax (out)
!  In principle we could save some ffts, by combining with the potential
!  subroutine above, but this is now easier
!
!  22-mar-02/axel: coded
!  29-sep-06/axel: removed multiple calls, removed normalization, non-para
!   7-oct-06/axel: corrected sign for irev==+1.
!
      use Fourier, only: fourier_transform_xy_xy
!
      real, dimension (:,:,:) :: fz
      real, dimension (:,:) :: f2,f3
      integer :: irev
!
      real, dimension (l2-l1+1,m2-m1+1) :: fac,kk,kkkx,kkky, &
                                           f1r,f1i,g1r,g1i,f2r,f2i,f3r,f3i
      real, dimension (nygrid) :: ky
      real, dimension (nx) :: kx
      real :: delz
      integer :: i, nxl, nyl
!
      if (ldownsampling) then
        call warning('bc_force_aa_time','Not available for downsampling')      
        return
      endif
!
      nxl=l2-l1+1; nyl=m2-m1+1
      f2r=f2; f2i=0
      f3r=f3; f3i=0
!
!  Transform
!
      call fourier_transform_xy_xy(f2r,f2i)
      call fourier_transform_xy_xy(f3r,f3i)
!
!  define wave vector
!
      kx=cshift((/(i-nxl/2,i=0,nxl-1)/),+nxl/2)*2*pi/Lx
      ky=cshift((/(i-nygrid/2,i=0,nygrid-1)/),+nygrid/2)*2*pi/Ly
!
!  calculate 1/k^2, zero mean
!
      kk=sqrt(spread(kx**2,2,nyl)+spread(ky(ipy*nyl+1:(ipy+1)*nyl)**2,1,nxl))
      kkkx=spread(kx,2,nyl)
      kkky=spread(ky(ipy*nyl+1:(ipy+1)*nyl),1,nxl)
!
!  calculate 1/kk
!
      kk(1,1)=1.
      fac=1./kk
      fac(1,1)=0.
!
      f1r=fac*(-kkkx*f2i-kkky*f3i)
      f1i=fac*(+kkkx*f2r+kkky*f3r)
!
!  set ghost zones
!
      do i=0,nghost
        delz=i*dz
        fac=exp(-kk*delz)
        g1r=fac*f1r
        g1i=fac*f1i
!
!  Transform back
!
        call fourier_transform_xy_xy(g1r,g1i,linv=.true.)
!
!  reverse order if irev=-1 (if we are at the bottom)
!  but reverse sign if irev=+1 (if we are at the top)
!
        if (irev==+1) fz(:,:,       i+1) = -g1r
        if (irev==-1) fz(:,:,nghost-i+1) = +g1r
      enddo
!
    endsubroutine potentdiv
!***********************************************************************
    subroutine bc_wind_z(f,topbot,massflux)
!
!  Calculates u_0 so that rho*(u+u_0)=massflux.
!  Set 'win' for rho and
!  massflux can be set as fbcz1/2(rho) in run.in.
!
!  18-06-2008/bing: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: i,j,ipt,ntb=-1
      real :: massflux,u_add
      real :: local_flux,local_mass
      real :: total_flux,total_mass
      real :: get_lf,get_lm
      integer :: nroot
!
      if (ldownsampling) then
        call warning('bc_force_aa_time','not available for downsampling')    
        return
      endif
!
      if (headtt) then
        print*,'bc_wind: Massflux',massflux
!
!   check wether routine can be implied
!
        if (.not.(lequidist(1) .and. lequidist(2))) &
            call not_implemented('bc_wind_z','non-equidistant grid in x and y')
!
!   check for warnings
!
        if (.not. ldensity) call warning('bc_wind',"no defined density, using rho=1 ?")
      endif
!
      select case (topbot)
!
!  Bottom boundary.
!
      case(BOT)
        ntb = n1
        nroot = 0
!
!  Top boundary.
!
      case(TOP)
        ntb = n2
        nroot = find_proc(0,0,ipz)
!
!  Default.
!
      case default
        call fatal_error("bc_wind: ","topbot should be BOT or TOP")
      endselect
!
      local_flux=sum(exp(f(l1:l2,m1:m2,ntb,ilnrho))*f(l1:l2,m1:m2,ntb,iuz))
      local_mass=sum(exp(f(l1:l2,m1:m2,ntb,ilnrho)))
!
!  One  processor has to collect the data
!
      if (iproc/=nroot) then
        ! send to first processor at given height
        !
        call mpisend_real(local_flux,nroot,111+iproc)
        call mpisend_real(local_mass,nroot,211+iproc)
      else
        total_flux=local_flux
        total_mass=local_mass
        do i=0,nprocx-1
          do j=0,nprocy-1
            ipt = find_proc(i,j,ipz)
            if (ipt/=nroot) then
              call mpirecv_real(get_lf,ipt,111+ipt)
              call mpirecv_real(get_lm,ipt,211+ipt)
              total_flux=total_flux+get_lf
              total_mass=total_mass+get_lm
            endif
          enddo
        enddo
!
!  Get u0 addition rho*(u+u0) = wind
!  rho*u + u0 *rho =wind
!  u0 = (wind-rho*u)/rho
!
        u_add = (massflux-total_flux) / total_mass
      endif
!
!  now distribute u_add
!
      if (iproc/=nroot) then
        call mpirecv_real(u_add,nroot,311+iproc)
      else
        do i=0,nprocx-1
          do j=0,nprocy-1
            ipt = find_proc(i,j,ipz)
            if (ipt/=nroot) call mpisend_real(u_add,ipt,311+ipt)
          enddo
        enddo
      endif
!
!  Set boundary
!
      f(l1:l2,m1:m2,ntb,iuz) =  f(l1:l2,m1:m2,ntb,iuz)+u_add
!
    endsubroutine bc_wind_z
!***********************************************************************
    subroutine bc_ADI_flux_z(f,topbot)
!
!  Constant flux boundary condition for temperature (called when bcz='c3')
!  at the bottom _only_ in the ADI case where hcond(n1)=hcond(x)
!  TT version: enforce dT/dz = - Fbot/K
!  30-jan-2009/dintrans: coded
!
      use SharedVariables, only: get_shared_variable
!
      real, pointer :: Fbot
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      real, dimension (size(f,1)) :: tmp_x
      integer :: i
!
      if (.not.lADI) call fatal_error('bc_ADI_flux_z','not usable for lADI=F')
!
      call get_shared_variable('Fbot', Fbot, caller='bc_ADI_flux_z')
!
      if (headtt) print*,'bc_ADI_flux_z: Fbot, hcondADI, dz=', Fbot, hcondADI, dz
!
      if (topbot==BOT) then
        tmp_x=-Fbot/hcondADI
        do i=1,nghost
          f(:,4,n1-i,ilnTT)=f(:,4,n1+i,ilnTT)-dz2_bound(-i)*tmp_x
        enddo
      else
        call not_implemented('bc_ADI_flux_z', 'for top z boundary')
      endif
!
    endsubroutine bc_ADI_flux_z
!***********************************************************************
    subroutine bc_force_ux_time(f, idz, j)
!
!  Set ux = ampl_forc*sin(k_forc*x)*cos(w_forc*t)
!
!  05-jun-2009/dintrans: coded from bc_force_uxy_sin_cos
!  Note: the ampl_forc, k_forc & w_forc run parameters are set in
!  'hydro' and shared using the 'shared_variables' module
!
      use SharedVariables, only : get_shared_variable
!
      real, dimension (:,:,:,:) :: f
      integer :: idz, j
      real    :: kx
      real, pointer, save :: ampl_forc, k_forc, w_forc, x_forc, dx_forc
      logical, save :: l1st=.true.
!
      if (headtt) then
        if (iuz == 0) call stop_it("BC_FORCE_UX_TIME: Bad idea...")
        if (Lx  == 0) call stop_it("BC_FORCE_UX_TIME: Lx cannot be 0")
        if (j /= iux) call stop_it("BC_FORCE_UX_TIME: only valid for ux")
      endif
!
      if (l1st) then
        call get_shared_variable('ampl_forc', ampl_forc, caller='bc_force_ux_time')
        call get_shared_variable('k_forc', k_forc)
        call get_shared_variable('w_forc', w_forc)
        call get_shared_variable('x_forc', x_forc)
        call get_shared_variable('dx_forc', dx_forc)
        if (headt) print*, 'bc_force_ux_time: ampl_forc, k_forc, '//&
             'w_forc, x_forc, dx_forc=', ampl_forc, k_forc, w_forc, &
             x_forc, dx_forc
        l1st=.false.
      endif
!
      if (k_forc /= impossible) then
        kx=2*pi/Lx*k_forc
        f(:,:,idz,j) = spread(ampl_forc*sin(kx*x)*cos(w_forc*t), 2, size(f,2))
      else
        f(:,:,idz,j) = spread(ampl_forc*exp(-((x-x_forc)/dx_forc)**2)*cos(w_forc*t), 2, size(f,2))
      endif
!
    endsubroutine bc_force_ux_time
!***********************************************************************
    subroutine bc_inlet_outlet_cyl(f,topbot,j,val)
!
! For pi/2 < y < 3pi/4,
! set r and theta velocity corresponding to a constant x-velocity
! and symmetric for lnrho/rho.
!
! Otherwise, set symmetric for velocities, and constant
! for lnrho/rho.
!
! NB! Assumes y to have the range 0 < y < 2pi
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j,i
      real, dimension(:) :: val
!
      select case (topbot)
      case(BOT)
        call fatal_error('bc_inlet_outlet_cyl', &
          'this boundary condition is not allowed for bottom boundary')
      case(TOP)
        do m=m1,m2
          if (      (y(m)>=xyz0(2) +   Lxyz(2)/4)&
              .and. (y(m)<=xyz0(2) + 3*Lxyz(2)/4)) then
            if (j==iux) then
              f(l2,m,:,j) = cos(y(m))*val(j)
              do i=1,nghost; f(l2+i,m,:,j) = 2*f(l2,m,:,j) - f(l2-i,m,:,j); enddo
            elseif (j==iuy) then
              f(l2,m,:,j) = -sin(y(m))*val(j)
              do i=1,nghost; f(l2+i,m,:,j) = 2*f(l2,m,:,j) - f(l2-i,m,:,j); enddo
            elseif ((j==ilnrho) .or. (j==irho)) then
              do i=1,nghost; f(l2+i,m,:,j) = f(l2-i,m,:,j); enddo
            endif
!
          else
            if (j==iux) then
              do i=1,nghost; f(l2+i,m,:,j) = f(l2-i,m,:,j); enddo
            elseif (j==iuy) then
              do i=1,nghost; f(l2+i,m,:,j) = f(l2-i,m,:,j); enddo
            elseif ((j==ilnrho) .or. (j==irho)) then
              f(l2,m,:,j) = val(j)
              do i=1,nghost; f(l2+i,m,:,j) = 2*f(l2,m,:,j) - f(l2-i,m,:,j); enddo
            endif
          endif
        enddo
      endselect
!
    endsubroutine bc_inlet_outlet_cyl
!***********************************************************************
    subroutine bc_pp_hds_z_iso(f,topbot)
!
!  Boundary condition for pressure
!
!  This sets \partial_{z} p = \rho g_{z},
!  i.e. it enforces hydrostatic equlibrium at the boundary for the
!  pressure with an isothermal EOS.
!
!  16-dec-2009/dintrans: coded
!
      use Gravity, only: gravz
      use EquationOfState, only : cs20
!
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent(IN) :: topbot
      real    :: haut
      integer :: i
!
      haut=cs20/gravz
      if (topbot==BOT) then
        do i=1,nghost
          f(:,:,n1-i,ipp) = f(:,:,n1+i,ipp)-dz2_bound(-i)*f(:,:,n1,ipp)/haut
        enddo
      else
        do i=1,nghost
          f(:,:,n2+i,ipp) = f(:,:,n2-i,ipp)+dz2_bound(i)*f(:,:,n2,ipp)/haut
        enddo
      endif
!
    endsubroutine bc_pp_hds_z_iso
!***********************************************************************
    subroutine bc_symset0der_z_v2(f,topbot,j)
!
!  This routine modified from bc_sym_z, but to a lower order.
!  Only available for z axis, activate with "0ds"
!  This is the routine to be used as regularity condition on the axis.
!
!  25-Oct-10/tijmen & bing: coded
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: i,j
!
      select case (topbot)
!
!  bottom (left end of the domain)
      case(BOT)
        f(:,:,n1,j)=(-18.*f(:,:,n1+1,j) &
                     +9.*f(:,:,n1+2,j) &
                     -2.*f(:,:,n1+3,j))/11.
!
        do i=1,nghost; f(:,:,n1-i,j)=f(:,:,n1+i,j); enddo
!
!  top (right end of the domain)
      case(TOP)
        f(:,:,n2,j)=(+18.*f(:,:,n2-1,j) &
                     -9.*f(:,:,n2-2,j) &
                     +2.*f(:,:,n2-3,j))/11.
!
        do i=1,nghost; f(:,:,n2+i,j)=f(:,:,n2-i,j); enddo
!
      case default
        call fatal_error("bc_symset0der_z_v2: ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_symset0der_z_v2
!***********************************************************************
    subroutine bc_aa_pot_1D(f,topbot)
!
!  Computes a potential field extrapolation for a
!  1D magnetic field boundary with nprocx >= 1
!
!  27-Oct-10/bing: coded
!
      use Fourier, only: fourier_transform_other, kx_fft
!
      real, dimension (:,:,:,:), intent (inout) :: f
      integer, intent(IN) :: topbot
      real, dimension (nxgrid) :: fft_az_r,fft_az_i,A_r,A_i,exp_fact
      real, dimension (nxgrid) :: iay_global
      integer :: i,j,ipos,dir
!
      if (ldownsampling) then
        call warning('bc_force_aa_time','downsampling not available')
        return
      endif
!
      select case (topbot)
!
!  bottom (left end of the domain)
      case(BOT)
        ipos = n1
        dir = -1
!
!  top (right end of the domain)
      case(TOP)
        ipos = n2
        dir = 1
!
      case default
        call fatal_error("bc_aa_pot_1D: ","topbot should be BOT or TOP")
      endselect
!
      if (nygrid>1) call fatal_error('bc_aa_pot_1D','only for nygrid=1')
!
      if (iproc==0) then
        iay_global(1:nx) = f(l1:l2,m1,ipos,iay)
        if (nprocx>1) then
          do j=1,nprocx-1
            call mpirecv_real(iay_global(j*nx+1:(j+1)*nx),nx,find_proc(j,0,0),j*100)
          enddo
        endif
        fft_az_r=iay_global
        call fourier_transform_other(fft_az_r,fft_az_i)
      else
        if (nprocx>1) call mpisend_real(f(l1:l2,m1,ipos,iay),nx,0,iproc*100)
      endif
!
      do i=1,nghost
        if (iproc==0) then
!
          exp_fact = exp(-abs(kx_fft)*(z(ipos+dir*i)-z(ipos)))
!
          A_r = exp_fact*fft_az_r
          A_i = exp_fact*fft_az_i
!
          call fourier_transform_other(A_r,A_i,linv=.true.)
!
          f(l1:l2,m1,ipos+dir*i,iay) = A_r(1:nx)
!
          if (nprocx>1) then
            do j=1,nprocx-1
              call mpisend_real(A_r(j*nx+1:(j+1)*nx),nx,find_proc(j,0,0),j*100)
            enddo
          endif
        else
          if (nprocx>1) call mpirecv_real(f(l1:l2,m1,ipos+dir*i,iay),nx,0,iproc*100)
        endif
!
      enddo
!
    endsubroutine bc_aa_pot_1D
!***********************************************************************
    subroutine bc_ctz(f,topbot,j)
!
!  Set entropy to match temperature in the ghost zones to boundary value
!  value with small increment. Density ghost zones need to be calculated
!  again here and corners must be included to avoid NAN's.
!
!  14-mar-11/fred: check that 'cdz' is also set for bcz density.
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j,k
      real, dimension (size(f,1),size(f,2),size(f,3)) :: lnrho_
!
      call bc_cdz(f,topbot,j-1)
!
      lnrho_=f(:,:,:,j-1)
      if (ldensity_nolog) then
        where (lnrho_<=0) lnrho_=tini
        lnrho_=log(lnrho_)
      endif
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        do k=1,3
          f(:,:,n1-k,j)=f(:,:,n1-k+1,j)+(cp-cv)*&
              (lnrho_(:,:,n1-k+1)-lnrho_(:,:,n1-k))
        enddo
!
      case(TOP)               ! top boundary
        do k=1,3
          f(:,:,n2+k,j)=f(:,:,n2+k-1,j)+(cp-cv)*&
              (lnrho_(:,:,n2+k-1)-lnrho_(:,:,n2+k))
        enddo
!
      case default
        call fatal_error("bc_ctz ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_ctz
!***********************************************************************
    subroutine bc_cdz(f,topbot,j)
!
!  Set ghost values to diminishing amplitude of boundary value.
!  Motivation density spikes in 'ism' runs leading to temp spikes that
!  crash the code on outflows, but halo density much lower so 'cop'
!  induces mass inflows which are too high to be physically sustainable.
!
!  13-feb-11/fred: adapted from bc_ctz
!  16-apr-14/fred: revised constant from 10. to 1.11 to preserve exponential
!                  reduction in density with height ref Ferriere Review 2001
!                  Eq.(5)
!
      integer, intent(IN) :: topbot
      real, dimension (:,:,:,:) :: f
      integer :: j,k
!
      select case (topbot)
!
      case(BOT)               ! bottom boundary
        do k=1,3
          f(:,:,n1-k,j)=f(:,:,n1-k+1,j)*(1.0-1.11*dz)
        enddo
!
      case(TOP)               ! top boundary
        do k=1,3
          f(:,:,n2+k,j)=f(:,:,n2+k-1,j)*(1.0-1.11*dz)
        enddo
!
      case default
        call fatal_error("bc_cdz ","topbot should be BOT or TOP")
!
      endselect
!
    endsubroutine bc_cdz
!***********************************************************************
    subroutine set_consistent_density_boundary(f,dirn,boundtype,topbot,rhob,lsuccess)
!
!  This subroutine checks, if the density paramters like type, topbot
!  and boundary value are set consistently with eg. the initial condition.
!
!  26-jun-12/dhruba+joern: coded
!
!  dirn       =     direction                    : 'x','y','z'
!  boundtype  =     type of boundary condition   : 'set','a',...
!  topbot     =     top or bottom boundary       : BOT,TOP
!  rhob       =     value at the boundary        : 4.04, 8.35, 10.1
!  lsuccess   =     switch, if it was successful : .true., .false.
!
!  At the moment only the x-direction is implemented
!
      real, dimension (:,:,:,:) :: f
      real, intent(in) :: rhob
      character (len=bclen), intent(in) :: boundtype,dirn
      integer, intent(IN) :: topbot
      logical, intent(out) :: lsuccess
!
      character (len=bclen) :: btyp
      logical :: lconsistent=.true.
      real :: boundrho
!
! check for consistency
!
      if (ldensity_nolog) then
        boundrho=rhob
      else
        boundrho=log(rhob)
      endif
      btyp=trim(boundtype)
      select case (dirn)
        case ('x')
          select case (topbot)
            case(BOT)
              if ((btyp/=bcx12(ilnrho,1)) .or. (rhob/=fbcx(ilnrho,1))) then
                lconsistent=.false.
                bcx12(ilnrho,1)=btyp
                fbcx(ilnrho,1)=boundrho
                call boundconds_x(f,ilnrho,ilnrho)
                if (lroot) print*,'boundcond: density in x at the bottom set to: ', &
                    bcx12(ilnrho,1),', with the value ',fbcx(ilnrho,1)
              endif
            case(TOP)
              if ((btyp/=bcx12(ilnrho,2)) .or. (rhob/=fbcx(ilnrho,2))) then
                lconsistent=.false.
                bcx12(ilnrho,2)=btyp
                fbcx(ilnrho,2)=boundrho
                call boundconds_x(f,ilnrho,ilnrho)
                if (lroot) print*,'boundcond: density in x at the top set to: ', &
                    bcx12(ilnrho,2),', with the value ',fbcx(ilnrho,2)
              endif
            case default
              call fatal_error('set_consistent_density_boundary','topbot does not match any, aborting')
          endselect
        case ('y')
          call not_implemented('set_consistent_density_boundary','y direction')
        case ('z')
          call not_implemented('set_consistent_density_boundary','z direction')
        case default
          call fatal_error('set_consistent_density_boundary','you have to choose either x,y or z direction')
      endselect
      lsuccess=.true.
!
! density set consistently at the boundary.
!
    endsubroutine set_consistent_density_boundary
!***********************************************************************
    subroutine set_consistent_vel_boundary(f,dirn,boundtype,topbot,comp,lsuccess)
!
!  This subroutine checks, if the velocity paramters like type and  topbot
!  are set consistently with eg. the initial condition.
!
!  14-sep-12/joern: coded, adapted from subroutine set_consistent_density_boundary
!
!  dirn       =     direction                    : 'x','y','z'
!  boundtype  =     type of boundary condition   : 'set','a',...
!  topbot     =     top or bottom boundary       : BOT,TOP
!  comp       =     component of the velocity    : 'x','y','z'
!  lsuccess   =     switch, if it was successful : .true., .false.
!
!  At the moment only the x-direction is implemented
!
      real, dimension (:,:,:,:) :: f
      character (len=bclen), intent(in) :: boundtype,dirn,comp
      integer, intent(in) :: topbot
      logical, intent(out) :: lsuccess
!
      character (len=bclen) :: btyp
      logical :: lconsistent=.true.
!
! check for consistency
!
      btyp=trim(boundtype)
      select case (dirn)
        case ('x')
          select case (topbot)
            case(BOT)
              select case (comp)
                case('x')
                  if (btyp/=bcx12(iux,1)) then
                    lconsistent=.false.
                    bcx12(iux,1)=btyp
                    call boundconds_x(f,iux,iux)
                    if (lroot) print*,'boundcond: x velocity in x at the bottom set to: ',bcx12(iux,1)
                  endif
                case('y')
                  if (btyp/=bcx12(iuy,1)) then
                    lconsistent=.false.
                    bcx12(iuy,1)=btyp
                    call boundconds_x(f,iuy,iuy)
                    if (lroot) print*,'boundcond: y velocity in x at the bottom set to: ',bcx12(iuy,1)
                  endif
                case('z')
                  if (btyp/=bcx12(iuz,1)) then
                    lconsistent=.false.
                    bcx12(iuz,1)=btyp
                    call boundconds_x(f,iuz,iuz)
                    if (lroot) print*,'boundcond: z velocity in x at the bottom set to: ',bcx12(iuz,1)
                  endif
                case default
                  call fatal_error('set_consistent_vel_boundary','component does not match any, aborting')
              endselect
            case(TOP)
              select case (comp)
                case('x')
                  if (btyp/=bcx12(iux,2)) then
                    lconsistent=.false.
                    bcx12(iux,2)=btyp
                    call boundconds_x(f,iux,iux)
                    if (lroot) print*,'boundcond: x velocity in x at the top set to: ',bcx12(iux,2)
                  endif
                case('y')
                  if (btyp/=bcx12(iuy,2)) then
                    lconsistent=.false.
                    bcx12(iuy,2)=btyp
                    call boundconds_x(f,iuy,iuy)
                    if (lroot) print*,'boundcond: y velocity in x at the top set to: ',bcx12(iuy,2)
                  endif
                case('z')
                  if (btyp/=bcx12(iuz,2)) then
                    lconsistent=.false.
                    bcx12(iuz,2)=btyp
                    call boundconds_x(f,iuz,iuz)
                    if (lroot) print*,'boundcond: z velocity in x at the top set to: ',bcx12(iuz,2)
                  endif
                case default
                  call fatal_error('set_consistent_vel_boundary','component does not match any, aborting')
              endselect
            case default
              call fatal_error('set_consistent_vel_boundary','topbot does not match any, aborting')
          endselect
        case ('y')
          call fatal_error('set_consistent_velovity_boundary','y direction not implemented yet')
        case ('z')
          call fatal_error('set_consistent_vel_boundary','z direction not implemented yet')
        case default
          call fatal_error('set_consistent_vel_boundary','you have to choose either x,y or z direction')
      endselect
      lsuccess=.true.
!
! velocity set consistently at the boundary.
!
    endsubroutine set_consistent_vel_boundary
!***********************************************************************
    subroutine set_periodic_boundcond_on_aux(f,ivar)
!
! sets periodic boundary condition on auxiliar variables
!
      real, dimension (:,:,:,:) :: f
      integer :: ivar
!
      call bc_per_x(f,TOP,ivar); call bc_per_x(f,BOT,ivar)
      call bc_per_y(f,TOP,ivar); call bc_per_y(f,BOT,ivar)
      call bc_per_z(f,TOP,ivar); call bc_per_z(f,BOT,ivar)
!
    endsubroutine set_periodic_boundcond_on_aux
!***********************************************************************
    subroutine tayler_expansion(f,topbot,j,dir)
!
      real, dimension (:,:,:,:) :: f
      integer, intent(IN) :: topbot
      integer :: j
      character :: dir

      integer :: k,p
      real, dimension(0:3,3), parameter :: coefs=reshape( &
                                           (/ 4., -6., 4., -1., &
                                             10.,-20.,15., -4., &
                                             20.,-45.,36.,-10./),(/4,3/))
      select case (dir)
      case ('x')
        select case (topbot)
        case(TOP)
          do k=1,3
            f(l2+k,:,:,j)=0.    
            do p=0,3
              f(l2+k,:,:,j) = f(l2+k,:,:,j)+coefs(p,k)*f(l2-p,:,:,j)
            enddo
          enddo
        case(BOT)
          do k=1,3
            f(l1-k,:,:,j)=0.
            do p=0,3
              f(l1-k,:,:,j) = f(l1-k,:,:,j)+coefs(p,k)*f(l1+p,:,:,j)
            enddo
          enddo
        endselect
      case ('y')
        select case (topbot)
        case(TOP)
          do k=1,3
            f(:,m2+k,:,j) = 0.
            do p=0,3
              f(:,m2+k,:,j) = f(:,m2+k,:,j)+coefs(p,k)*f(:,m2-p,:,j)
            enddo
          enddo
        case(BOT)
          do k=1,3
            f(:,m1-k,:,j) = 0.
            do p=0,3
              f(:,m1-k,:,j) = f(:,m1-k,:,j)+coefs(p,k)*f(:,m1+p,:,j)
            enddo
          enddo
        endselect
      case ('z')
        select case (topbot)
        case(TOP)
          do k=1,3
            f(:,:,n2+k,j) = 0.
            do p=0,3
              f(:,:,n2+k,j) = f(:,:,n2+k,j) + coefs(p,k)*f(:,:,n2-p,j)
            enddo
          enddo
        case(BOT)
          do k=1,3
            f(:,:,n1-k,j) = 0.
            do p=0,3
              f(:,:,n1-k,j) = f(:,:,n1-k,j) + coefs(p,k)*f(:,:,n1+p,j)
            enddo
          enddo
        endselect
      endselect
!
    endsubroutine tayler_expansion
!***********************************************************************
    subroutine copy_BCs(isrc,itarg,num)
!
!  14-apr-15/MR: coded
!
      integer, intent(IN) :: isrc,itarg,num

      integer :: iet, ies

      if (isrc/=0) then

        ies = isrc +num-1
        iet = itarg+num-1

        if (nxgrid>1) then
          bcx (itarg:iet) = bcx (isrc:ies)
          bcx12(itarg:iet,:) = bcx12(isrc:ies,:)
        endif

        if (nygrid>1) then
          bcy (itarg:iet) = bcy (isrc:ies)
          bcy12(itarg:iet,:) = bcy12(isrc:ies,:)
        endif

        if (nzgrid>1) then
          bcz (itarg:iet) = bcz (isrc:ies)
          bcz12(itarg:iet,:) = bcz12(isrc:ies,:)
        endif

      endif
!
    endsubroutine copy_BCs
!***********************************************************************
endmodule Boundcond
