program ellipsoidalwing
  use fluidMod,   only: fluid
  use fieldMod,   only: field
  use vectorMod,  only: vfield
  use bodyMod,    only: body
  use mympiMod
  use gridMod
  use imageMod,   only: display
  use geom_shape

  implicit none
!
! -- numerical parameters
  real,parameter    :: C=32               ! resolution (pnts per chord)
  integer,parameter :: ndims=3
  real,parameter    :: dr=2.
  integer           :: n(3)               ! number of points
  logical           :: p(3) = (/.FALSE.,.FALSE.,.FALSE./)

! -- motion params
  real,parameter  :: A_theta=0., A_phi=0.35*pi, A_alpha=pi/4.
  real,parameter  :: fr=.5, f_theta=.5, xi=0.
  real,parameter  :: T = 1./fr*C
  real,parameter  :: Rg = 1.581
  real,parameter  :: c_bar = pi/4.
  real,parameter  :: visc = 0.0273
  real,parameter  :: Re=4*A_phi*fr*Rg*c_bar/visc
  real            :: nu=C/Re

! -- MPI utils
  integer :: b(3) = (/1,1,1/)                                   ! 1 blocks
  integer :: m(3)                                               ! number of points per block
  logical :: root                                               ! root processor
  logical :: there=.false.                                      ! exits the time loop
! -- utils
  real,parameter :: Np = 1.25                                    ! number of period
  real  :: finish =  2*Np*T                                      ! number of timesteps
  real,parameter :: dtPrint = 0.1*T                              ! print rate
! -- variables
  type(fluid) :: flow
  type(body)  :: geom
  real :: dt,t1,pforce(ndims),vforce(ndims),Area

! -- Initialize MPI (if MPI is OFF, b is set to 1)
  call init_mympi(ndims,set_blocks=b(:ndims),set_periodic=p(:ndims))
  root = mympi_rank()==0
  eps2 = 0.5
!
! -- Initialize the 3D ellipse
  n = composite(C*(/4.,3.,3./), prnt=root)
  call xg(1)%stretch(n(1), -3.*C,-1.5*C,  1.5*C,  3*C,h_min=1.,prnt=root)
  call xg(2)%stretch(n(2),-3.5*C,-1.5*C,  0.5*C,2.5*C,h_min=1.,prnt=root)
  call xg(3)%stretch(n(3),-2.25*C,-0.25*C,1.75*C,3.75*C,h_min=1.,prnt=root)
  ! geom = sphere(radius=0.5*C,center=0)&
  !         .map.init_scale(1,lengthx,rate)&
  !         .map.init_scale(2,lengthy,rate)&
  !         .map.init_rigid(3,z)&
  !         .map.init_rigid(6,alpha)&
  !         .map.init_rigid(5,phi)&
  !         .map.init_rigid(4,theta)
  geom =  cylinder(axis=2,radius=0.5*C,center=0).and. &
          plane(norm=(/0,-1,0/),center=(/0.,-dr/2.,0./)).and. &
          plane(norm=(/0, 1,0/),center=(/0., dr/2.,0./))&
          .map.init_scale(1,lengthx,rate)&
          .map.init_rigid(3,z)&
          .map.init_rigid(6,alpha)&
          .map.init_rigid(5,phi)&
          .map.init_rigid(4,theta)

  if(root) then
    print*, 'Simulation parameters:'
    print*, 'DOF:', product(n)
    print*, 'finish', finish
    print*, 'A_alpha',A_alpha
    print*, 'A_theta',A_theta
    print*, 'A_phi',A_phi
    print*, 'fr',fr
    print*, 'f_theta',f_theta
    print*, 'Period',T
    print*, 'Reynolds number',Re
  end if

  Area = pi/2.*C
!
! -- Initialize fluid
  m = n/b
  call flow%init(m, geom, V=[0.,0.,0.], nu=nu)
  call flow%write(geom,lambda=.true.)

  if(root) print *, '-- init complete --'
! -- Time update loop
  finish = finish+flow%time
  flow%dt = 1.
  do while (flow%time<finish .and. .not.there)
    dt = flow%dt                    ! time step
    t1 = flow%time+dt               ! time at the end of this step
    call geom%update(flow%time)
    call flow%update(geom)          ! update N-S
    flow%dt = min(1., flow%dt)
    pforce = -2.*geom%pforce(flow%pressure)/Area
    vforce =  2.*nu*geom%vforce(flow%velocity)/Area
    if(root) write(9,'(f10.4,f8.4,6e16.8,3f10.4)') t1/T,dt,pforce,vforce,&
                   phi(real(flow%time,8)),theta(real(flow%time,8)),alpha(real(flow%time,8))
    if(root) flush(9)
    if(mod(t1,dtPrint)<dt) then
      if(root) print "('Time:',f15.3,'. Time remaining:',f15.3)",t1/C,finish/C-t1/C
      call display(flow%velocity%vorticity_Z(), 'out_vort', lim = 0.5)
      call flow%write(geom,lambda=.true.)
    end if
!
! -- check for kill flag
    inquire(file='.kill', exist=there)
  end do

  call flow%write(geom,lambda=.true.)
  call mympi_end()

  contains
  real(8) pure function lengthx(time)
    real(8), intent(in) :: time
    lengthx = .5
  end function lengthx
  real(8) pure function lengthy(time)
    real(8), intent(in) :: time
    lengthy = .05
  end function lengthy
  real(8) pure function z(time)
    real(8),intent(in) :: time
    z = 0.75*C
  end function z
  real(8) pure function rate(time)
    real(8), intent(in) :: time
    rate = 0.0
  end function rate
  real(8) pure function theta(time)
    real(8),intent(in) :: time
    theta = A_theta*cos(2*pi*f_theta*time/T)
  end function theta
  real(8) pure function phi(time)
    real(8),intent(in) :: time
    phi = A_phi*sin(2*pi*fr*time/T)
  end function phi
  real(8) pure function alpha(time)
    real(8),intent(in) :: time
    alpha = pi/2. - A_alpha*cos(2*pi*fr*time/T + xi)
  end function alpha
end program ellipsoidalwing


c data are 348 monthly values (29 years) in file co2
      real y(348), season(348), trend(348), rw(348), work(372,7)
      logical robust
      read(5,*)(y(i), i=1, 348)
      n=348
      np=12
      ns=35
      nt=19
      nl=13
      no=2
      ni=1
      nsjump=4
      ntjump=2
      nljump=2
      isdeg=1
      itdeg=1
      ildeg=1
      call stl(y,n,np,ns,nt,nl,isdeg,itdeg,ildeg,nsjump,ntjump,
     &nljump,ni,no,rw,season, trend, work)
       write(6,*) (season(i), i=1,348)
       write(6,*) (trend(i), i=1,348)
       write(6,*) (rw(i), i=1,348)
      robust=.true.
      call stlez(y,n,np,ns,isdeg,itdeg,robust,nconv,rw,season,trend,
     &work)
      write(6,*) nconv
       write(6,*) (season(i), i=1,348)
       write(6,*) (trend(i), i=1,348)
       write(6,*) (rw(i), i=1,348)
      end


! Copyright © 2021, UChicago Argonne, LLC, OPEN SOURCE LICENSE
! See (root dir/)LICENSE.TXT

!  Basic Hartree-Fock Proxy Application,  OpenMP parallel version
!  Written by Graham D. Fletcher, Computational Science Division,
!  Argonne National Laboratory
!  Computes the 2-electron (repulsion) term of the Fock operator
!  for a cluster of helium-like atoms

 module params
 real(8)      pi
 parameter  ( pi = 3.1415926535897931d0 )
 real(8)      sqrpi2
 parameter  ( sqrpi2 = ( pi**( -0.5d0 ) )*2.0d0 )
 real(8)      dtol,          rcut
!parameter  ( dtol= 1.0d-10, rcut= 1.0d-12 )
 parameter  ( dtol= 1.0d-12, rcut= 1.0d-12 )
 real(8)      tobohrs
 parameter  ( tobohrs = 1.889725987722d0 )
 end module params

 program   basic_hf_proxy
 use       params
 implicit  none
 integer   natom,ngauss, i,j,ij
 real(8),  allocatable ::  xpnt( : )
 real(8),  allocatable ::  coef( : )
 real(8),  allocatable ::  geom( : , : )
 real(8),  allocatable ::  fock( : , : )
 real(8),  allocatable ::  dens( : , : )
 real(8),  allocatable ::  schwarz( : )
 real(8)   erep

 integer    ib,jb,kb,lb,  nn,kl,k,l
 real(8)    aij,dij,xij,yij,zij, akl,dkl, aijkl,tt,f0t, eri
 integer    nnnn,ijkl,n    !  need i8?

! ngauss is the number of gaussian-type functions (GTF) per atom.
! The GTF are specified by their exponents (xpnt) and contracted
! using the expansion coefficients (coef) to make an orbital which
! is occupied by a pair of opposite-spin electrons.
! Use ngauss (,xpnt,coef) to adjust the per-atom workload.
! natom is the number of helium-like atoms.
 read *,  ngauss, natom

 allocate( xpnt( ngauss ) )
 allocate( coef( ngauss ) )
 allocate( geom( 3, natom ) )

 read *,  ( xpnt( i ), coef( i ), i = 1, ngauss )  !  read atomic basis set
 do  i  =  1,  natom       !  read the geometry
 read *,  ( geom( j, i ), j = 1, 3 )
 end do

 allocate( dens( natom, natom ) )

! Typical Hartree-Fock calculations build the density matrix from
! a guess wave function (not a significant computational effort).
! To simulate this just make a fake density here.
 do  i  =  1,  natom
 do  j  =  1,  natom
 dens( i, j )  =  0.1d0
 end do
 dens( i, i )  =  1.0d0
 end do

! Uncomment the lines below to read a density matrix from a file
! (then broadcast it) to enable a direct comparison with a code
! such as GAMESS. Here, it is assumed that the density is output
! in triangular form.
!do  i  =  1,  natom
!read *,  ( dens( i, j ), j = 1, i )
!do  j  =  1,  i-1
!dens( j, i )  =  dens( i, j )
!end do
!end do

 allocate( fock( natom, natom ) )

! Normalize the primitive GTO weights.
 do i = 1, ngauss
 coef( i ) = coef( i )*( ( 2.0d0*xpnt( i ) )**0.75d0 )
 end do

!  Scale the geometry to Bohrs for energy calculations in AU.
 do  i  =  1,  natom
 geom( 1, i )  =  geom( 1, i )*tobohrs
 geom( 2, i )  =  geom( 2, i )*tobohrs
 geom( 3, i )  =  geom( 3, i )*tobohrs
 end do

 do  i  =  1,  natom
 do  j  =  1,  natom
 fock( i, j )  =  0.0d0
 end do
 end do

! compute Schwarz Inequality factors for integral screening
 nn  =  ((natom**2)+natom)/2
 allocate( schwarz( nn ) )

 ij = 0
 do  i  =  1,  natom
 do  j  =  1,  i
 ij = ij + 1
 call ssss( i, j, i, j, ngauss, xpnt, coef, geom, eri )
 schwarz( ij )  =  sqrt( abs( eri ) )
 end do
 end do

! The following loop (expanded to four indices, with permutational
! symmetry) represents the kernel of Hartree-Fock calculations.
! Integrals are screened to avoid small terms.
 nnnn = ((nn**2)+nn)/2

!$OMP PARALLEL DO PRIVATE(ib,jb,kb,lb,ijkl,ij,i,j,kl,k,l,n,aij,dij,xij,yij,zij,akl,dkl,aijkl,tt,f0t,eri)

 do  ijkl  =  1,  nnnn
! decompose triangular ijkl index into ij>=kl
 ij = sqrt( dble( 2*ijkl ) )
 n = ( ij*ij + ij )/2
 do  while ( n .lt. ijkl )
 ij = ij + 1
 n = ( ij*ij + ij )/2
 end do
 kl  =  ijkl - ( ij*ij - ij )/2
 if ( schwarz( ij )*schwarz( kl ) > dtol ) then

! decompose triangular ij index into i>=j
 i = sqrt( dble( 2*ij ) )
 n = ( i*i + i )/2
 do  while ( n .lt. ij )
 i = i + 1
 n = ( i*i + i )/2
 end do
 j  =  ij - ( i*i - i )/2

! decompose triangular kl index into k>=l
 k = sqrt( dble( 2*kl ) )
 n = ( k*k + k )/2
 do  while ( n .lt. kl )
 k = k + 1
 n = ( k*k + k )/2
 end do
 l  =  kl - ( k*k - k )/2

 eri  =  0.0d0
 do  ib  =  1,  ngauss
 do  jb  =  1,  ngauss
 aij = 1.0d0/( xpnt( ib ) + xpnt( jb ) )
 dij = coef( ib )*coef( jb )*exp( -xpnt( ib )*xpnt( jb )*aij*  &
     ( ( geom( 1, i ) - geom( 1, j ) )**2   &
     + ( geom( 2, i ) - geom( 2, j ) )**2   &
     + ( geom( 3, i ) - geom( 3, j ) )**2  )  )*( aij**1.5d0 )
 if ( abs( dij ) > dtol ) then
 xij = aij*( xpnt( ib )*geom( 1, i ) + xpnt( jb )*geom( 1, j ) )
 yij = aij*( xpnt( ib )*geom( 2, i ) + xpnt( jb )*geom( 2, j ) )
 zij = aij*( xpnt( ib )*geom( 3, i ) + xpnt( jb )*geom( 3, j ) )
 do  kb  =  1,  ngauss
 do  lb  =  1,  ngauss
 akl = 1.0d0/( xpnt( kb ) + xpnt( lb ) )
 dkl = dij*coef( kb )*coef( lb )*exp( -xpnt( kb )*xpnt( lb )*akl*  &
     ( ( geom( 1, k ) - geom( 1, l ) )**2   &
     + ( geom( 2, k ) - geom( 2, l ) )**2   &
     + ( geom( 3, k ) - geom( 3, l ) )**2  )  )*( akl**1.5d0 )
 if ( abs( dkl ) > dtol ) then
 aijkl = ( xpnt( ib ) + xpnt( jb ) )*( xpnt( kb ) + xpnt( lb ) )  &
       / ( xpnt( ib ) + xpnt( jb )  +  xpnt( kb ) + xpnt( lb ) )
 tt = aijkl*( ( xij -akl*( xpnt( kb )*geom( 1, k ) + xpnt( lb )*geom( 1, l ) ) )**2  &
            + ( yij -akl*( xpnt( kb )*geom( 2, k ) + xpnt( lb )*geom( 2, l ) ) )**2  &
            + ( zij -akl*( xpnt( kb )*geom( 3, k ) + xpnt( lb )*geom( 3, l ) ) )**2  )
 f0t  =  sqrpi2
 if ( tt > rcut )  f0t  =  ( tt**( -0.5d0 ) )*erf( sqrt(tt) )
 eri  =  eri  +  dkl*f0t*sqrt(aijkl)
 end if
 end do  ;  end do
 end if
 end do  ;  end do

 if ( i == j ) eri = eri*0.5d0
 if ( k == l ) eri = eri*0.5d0
 if ( i == k .and. j == l ) eri = eri*0.5d0
!$OMP ATOMIC
 fock( i, j )  =  fock( i, j )  +dens( k, l )*eri*4.0d0
!$OMP ATOMIC
 fock( k, l )  =  fock( k, l )  +dens( i, j )*eri*4.0d0
!$OMP ATOMIC
 fock( i, k )  =  fock( i, k )  -dens( j, l )*eri
!$OMP ATOMIC
 fock( i, l )  =  fock( i, l )  -dens( j, k )*eri
!$OMP ATOMIC
 fock( j, k )  =  fock( j, k )  -dens( i, l )*eri
!$OMP ATOMIC
 fock( j, l )  =  fock( j, l )  -dens( i, k )*eri

 end if
 end do
!$OMP END PARALLEL DO

! It is customary to symmetrize the Fock matrix,
! but this is not necessary just to compute the 2e- energy.
!do  i  =  1,  natom
!do  j  =  1,  i - 1
!fock( i, j ) = ( fock( i, j ) + fock( j, i ) )*0.5d0
!fock( j, i ) = fock( i, j )
!end do
!end do
!  Print Fock matrix, not needed for timing, validation only.
!do  i  =  1,  natom
!print *, ( fock( i, j ), j  =  1,  i  )
!end do

!  Trace Fock with the density and print the 2e- energy.
 erep  =  0.0d0
 do  i  =  1,  natom
 do  j  =  1,  natom
 erep  =  erep  +  fock( i, j )*dens( i, j )
 end do
 end do
 print *, '2e- energy= ',erep*0.5d0

 deallocate( schwarz )
 deallocate( xpnt )
 deallocate( coef )
 deallocate( dens )
 deallocate( fock )
 deallocate( geom )
 end program basic_hf_proxy

 subroutine ssss( i, j, k, l, ngauss, xpnt, coef, geom, eri )
 use        params
 implicit   none
 integer    i,j,k,l, ngauss
 real(8)    xpnt(*), coef(*), geom(3,*), eri
 integer    ib,jb,kb,lb
 real(8)    aij,dij,xij,yij,zij, akl,dkl, aijkl,tt,f0t

!  loops over contracted GTOs

 eri  =  0.0d0
 do  ib  =  1,  ngauss
 do  jb  =  1,  ngauss
 aij = 1.0d0/( xpnt( ib ) + xpnt( jb ) )
 dij = coef( ib )*coef( jb )*exp( -xpnt( ib )*xpnt( jb )*aij*  &
     ( ( geom( 1, i ) - geom( 1, j ) )**2   &
     + ( geom( 2, i ) - geom( 2, j ) )**2   &
     + ( geom( 3, i ) - geom( 3, j ) )**2  )  )*( aij**1.5d0 )
 if ( abs( dij ) > dtol ) then
 xij = aij*( xpnt( ib )*geom( 1, i ) + xpnt( jb )*geom( 1, j ) )
 yij = aij*( xpnt( ib )*geom( 2, i ) + xpnt( jb )*geom( 2, j ) )
 zij = aij*( xpnt( ib )*geom( 3, i ) + xpnt( jb )*geom( 3, j ) )
 do  kb  =  1,  ngauss
 do  lb  =  1,  ngauss
 akl = 1.0d0/( xpnt( kb ) + xpnt( lb ) )
 dkl = dij*coef( kb )*coef( lb )*exp( -xpnt( kb )*xpnt( lb )*akl*  &
     ( ( geom( 1, k ) - geom( 1, l ) )**2   &
     + ( geom( 2, k ) - geom( 2, l ) )**2   &
     + ( geom( 3, k ) - geom( 3, l ) )**2  )  )*( akl**1.5d0 )
 if ( abs( dkl ) > dtol ) then
 aijkl = ( xpnt( ib ) + xpnt( jb ) )*( xpnt( kb ) + xpnt( lb ) )  &
       / ( xpnt( ib ) + xpnt( jb )  +  xpnt( kb ) + xpnt( lb ) )
 tt = aijkl*( ( xij -akl*( xpnt( kb )*geom( 1, k ) + xpnt( lb )*geom( 1, l ) ) )**2  &
            + ( yij -akl*( xpnt( kb )*geom( 2, k ) + xpnt( lb )*geom( 2, l ) ) )**2  &
            + ( zij -akl*( xpnt( kb )*geom( 3, k ) + xpnt( lb )*geom( 3, l ) ) )**2  )
 f0t  =  sqrpi2
 if ( tt > rcut )  f0t  =  ( tt**( -0.5d0 ) )*erf( sqrt(tt) )
 eri  =  eri  +  dkl*f0t*sqrt(aijkl)
 end if
 end do  ;  end do
 end if
 end do  ;  end do
 end subroutine ssss


*DECK CFFTI1
      SUBROUTINE CFFTI1 (N, WA, IFAC)
C***BEGIN PROLOGUE  CFFTI1
C***PURPOSE  Initialize a real and an integer work array for CFFTF1 and
C            CFFTB1.
C***LIBRARY   SLATEC (FFTPACK)
C***CATEGORY  J1A2
C***TYPE      COMPLEX (RFFTI1-S, CFFTI1-C)
C***KEYWORDS  FFTPACK, FOURIER TRANSFORM
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***DESCRIPTION
C
C  Subroutine CFFTI1 initializes the work arrays WA and IFAC which are
C  used in both CFFTF1 and CFFTB1.  The prime factorization of N and a
C  tabulation of the trigonometric functions are computed and stored in
C  IFAC and WA, respectively.
C
C  Input Parameter
C
C  N       the length of the sequence to be transformed
C
C  Output Parameters
C
C  WA      a real work array which must be dimensioned at least 2*N.
C
C  IFAC    an integer work array which must be dimensioned at least 15.
C
C          The same work arrays can be used for both CFFTF1 and CFFTB1
C          as long as N remains unchanged.  Different WA and IFAC arrays
C          are required for different values of N.  The contents of
C          WA and IFAC must not be changed between calls of CFFTF1 or
C          CFFTB1.
C
C***REFERENCES  P. N. Swarztrauber, Vectorizing the FFTs, in Parallel
C                 Computations (G. Rodrigue, ed.), Academic Press,
C                 1982, pp. 51-83.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           (a) changing dummy array size declarations (1) to (*),
C           (b) changing references to intrinsic function FLOAT
C               to REAL, and
C           (c) changing definition of variable TPI by using
C               FORTRAN intrinsic function ATAN instead of a DATA
C               statement.
C   881128  Modified by Dick Valent to meet prologue standards.
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900131  Routine changed from subsidiary to user-callable.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CFFTI1
      DIMENSION WA(*), IFAC(*), NTRYH(4)
      SAVE NTRYH
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/3,4,2,5/
C***FIRST EXECUTABLE STATEMENT  CFFTI1
      NL = N
      NF = 0
      J = 0
  101 J = J+1
      IF (J-4) 102,102,103
  102 NTRY = NTRYH(J)
      GO TO 104
  103 NTRY = NTRY+2
  104 NQ = NL/NTRY
      NR = NL-NTRY*NQ
      IF (NR) 101,105,101
  105 NF = NF+1
      IFAC(NF+2) = NTRY
      NL = NQ
      IF (NTRY .NE. 2) GO TO 107
      IF (NF .EQ. 1) GO TO 107
      DO 106 I=2,NF
         IB = NF-I+2
         IFAC(IB+2) = IFAC(IB+1)
  106 CONTINUE
      IFAC(3) = 2
  107 IF (NL .NE. 1) GO TO 104
      IFAC(1) = N
      IFAC(2) = NF
      TPI = 8.*ATAN(1.)
      ARGH = TPI/N
      I = 2
      L1 = 1
      DO 110 K1=1,NF
         IP = IFAC(K1+2)
         LD = 0
         L2 = L1*IP
         IDO = N/L2
         IDOT = IDO+IDO+2
         IPM = IP-1
         DO 109 J=1,IPM
            I1 = I
            WA(I-1) = 1.
            WA(I) = 0.
            LD = LD+L1
            FI = 0.
            ARGLD = LD*ARGH
            DO 108 II=4,IDOT,2
               I = I+2
               FI = FI+1.
               ARG = FI*ARGLD
               WA(I-1) = COS(ARG)
               WA(I) = SIN(ARG)
  108       CONTINUE
            IF (IP .LE. 5) GO TO 109
            WA(I1-1) = WA(I-1)
            WA(I1) = WA(I)
  109    CONTINUE
         L1 = L2
  110 CONTINUE
      RETURN
      END


module shallow_dynamics_mod

use               fms_mod, only: open_namelist_file,   &
                                 open_restart_file,    &
                                 file_exist,           &
                                 check_nml_error,      &
                                 error_mesg,           &
                                 FATAL,                &
                                 write_version_number, &
                                 mpp_pe,               &
                                 mpp_root_pe,          &
                                 read_data,            &
                                 write_data,           &
                                 set_domain,           &
                                 close_file,           &
                                 stdlog

use    time_manager_mod,  only : time_type,      &
                                 get_time,       &
                                 operator(==),   &
                                 operator(-)

use       constants_mod,  only : radius, omega

use         transforms_mod, only: transforms_init,         transforms_end,          &
                                  get_grid_boundaries,     horizontal_advection,    &
                                  trans_spherical_to_grid, trans_grid_to_spherical, &
                                  compute_laplacian,       get_eigen_laplacian,     &
                                  get_sin_lat,             get_cos_lat,             &
                                  get_deg_lon,             get_deg_lat,             &
                                  get_grid_domain,         get_spec_domain,         &
                                  spectral_domain,         grid_domain,             &
                                  vor_div_from_uv_grid,    uv_grid_from_vor_div

use   spectral_damping_mod, only: spectral_damping_init,   compute_spectral_damping

use           leapfrog_mod, only: leapfrog

use       fv_advection_mod, only : fv_advection_init, a_grid_horiz_advection

!======================================================================================
implicit none
private
!======================================================================================

public :: shallow_dynamics_init, shallow_dynamics, shallow_dynamics_end, &
          dynamics_type, grid_type, spectral_type, tendency_type

! version information
!===================================================================
character(len=128) :: version = '$Id: shallow_dynamics.f90,v 10.0 2003/10/24 22:01:02 fms Exp $'
character(len=128) :: tagname = '$Name: latest $'
!===================================================================

type grid_type
   real, pointer, dimension(:,:,:) :: u=>NULL(), v=>NULL(), vor=>NULL(), div=>NULL(), h=>NULL(), trs=>NULL(), tr=>NULL()
   real, pointer, dimension(:,:)   :: stream=>NULL(), pv=>NULL()
end type
type spectral_type
   complex, pointer, dimension(:,:,:) :: vor=>NULL(), div=>NULL(), h=>NULL(), trs=>NULL()
end type
type tendency_type
   real, pointer, dimension(:,:) :: u=>NULL(), v=>NULL(), h=>NULL(), trs=>NULL(), tr=>NULL()
end type
type dynamics_type
   type(grid_type)     :: grid
   type(spectral_type) :: spec
   type(tendency_type) :: tend
   integer             :: num_lon, num_lat
   logical             :: grid_tracer, spec_tracer
end type

integer, parameter :: num_time_levels = 2

integer :: is, ie, js, je, ms, me, ns, ne

logical :: module_is_initialized = .false.

real,  allocatable, dimension(:) :: sin_lat, cos_lat, rad_lat, deg_lat, deg_lon, &
                                    coriolis

real,  allocatable, dimension(:,:) :: eigen

integer :: pe, npes

! namelist parameters with default values

integer :: num_lon            = 256
integer :: num_lat            = 128
integer :: num_fourier        = 85
integer :: num_spherical      = 86
integer :: fourier_inc         = 1
! (these define a standard T85 model)

logical :: check_fourier_imag = .false.
logical :: south_to_north     = .true.
logical :: triang_trunc   = .true.

real    :: robert_coeff        = 0.04
real    :: robert_coeff_tracer = 0.04
real    :: longitude_origin    = 0.0

character(len=64) :: damping_option = 'resolution_dependent'
integer :: damping_order       = 4
real    :: damping_coeff       = 1.e-04
real    :: h_0                 = 3.e04

logical :: spec_tracer      = .true.
logical :: grid_tracer      = .true.

real, dimension(2) :: valid_range_v = (/-1.e3,1.e3/)

namelist /shallow_dynamics_nml/ check_fourier_imag,          &
                          south_to_north, triang_trunc,      &
                          num_lon, num_lat, num_fourier,     &
                          num_spherical, fourier_inc,        &
                          longitude_origin, damping_option,  &
                          damping_order,     damping_coeff,  &
                          robert_coeff, robert_coeff_tracer, &
                          h_0, spec_tracer, grid_tracer,     &
                          valid_range_v

contains

!=======================================================================================

subroutine shallow_dynamics_init (Dyn,  Time, Time_init)

type(dynamics_type), intent(inout)  :: Dyn
type(time_type)    , intent(in)     :: Time, Time_init

integer :: i, j

real,    allocatable, dimension(:)   :: glon_bnd, glat_bnd
real :: xx, yy, dd

integer  :: ierr, io, unit
logical  :: root

! < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < >

call write_version_number (version, tagname)

pe   =  mpp_pe()
root = (pe == mpp_root_pe())

if (file_exist('input.nml')) then
  unit = open_namelist_file ()
  ierr=1
  do while (ierr /= 0)
    read  (unit, nml=shallow_dynamics_nml, iostat=io, end=10)
    ierr = check_nml_error (io, 'shallow_dynamics_nml')
  enddo
  10 call close_file (unit)
endif

if (root) write (stdlog(), nml=shallow_dynamics_nml)

call transforms_init(radius, num_lat, num_lon, num_fourier, fourier_inc, num_spherical, &
         south_to_north=south_to_north,   &
         triang_trunc=triang_trunc,       &
         longitude_origin=longitude_origin       )

call get_grid_domain(is,ie,js,je)
call get_spec_domain(ms,me,ns,ne)

Dyn%num_lon = num_lon
Dyn%num_lat = num_lat
Dyn%spec_tracer  = spec_tracer
Dyn%grid_tracer  = grid_tracer

allocate (sin_lat   (js:je))
allocate (cos_lat   (js:je))
allocate (deg_lat   (js:je))
allocate (deg_lon   (is:ie))
allocate (coriolis  (js:je))

call get_deg_lon (deg_lon)
call get_deg_lat (deg_lat)
call get_sin_lat (sin_lat)
call get_cos_lat (cos_lat)

allocate (glon_bnd  (num_lon + 1))
allocate (glat_bnd  (num_lat + 1))
call get_grid_boundaries (glon_bnd, glat_bnd, global=.true.)

coriolis = 2*omega*sin_lat

call spectral_damping_init(damping_coeff, damping_order, damping_option, num_fourier, num_spherical, 1, 0., 0., 0.)

allocate(eigen(ms:me,ns:ne))
call get_eigen_laplacian(eigen)

allocate (Dyn%spec%vor (ms:me, ns:ne, num_time_levels))
allocate (Dyn%spec%div (ms:me, ns:ne, num_time_levels))
allocate (Dyn%spec%h   (ms:me, ns:ne, num_time_levels))

allocate (Dyn%grid%u   (is:ie, js:je, num_time_levels))
allocate (Dyn%grid%v   (is:ie, js:je, num_time_levels))
allocate (Dyn%grid%vor (is:ie, js:je, num_time_levels))
allocate (Dyn%grid%div (is:ie, js:je, num_time_levels))
allocate (Dyn%grid%h   (is:ie, js:je, num_time_levels))

allocate (Dyn%tend%u        (is:ie, js:je))
allocate (Dyn%tend%v        (is:ie, js:je))
allocate (Dyn%tend%h        (is:ie, js:je))
allocate (Dyn%grid%stream   (is:ie, js:je))
allocate (Dyn%grid%pv       (is:ie, js:je))

call fv_advection_init(num_lon, num_lat, glat_bnd, 360./float(fourier_inc))
if(Dyn%grid_tracer) then
  allocate(Dyn%Grid%tr (is:ie, js:je, num_time_levels))
  allocate(Dyn%Tend%tr (is:ie, js:je))
endif

if(Dyn%spec_tracer) then
  allocate(Dyn%Grid%trs (is:ie, js:je, num_time_levels))
  allocate(Dyn%Tend%trs (is:ie, js:je))
  allocate(Dyn%Spec%trs (ms:me, ns:ne, num_time_levels))
endif

if(Time == Time_init) then

  Dyn%Grid%vor(:,:,1) = 0.0
  Dyn%Grid%div(:,:,1) = 0.0
  Dyn%Grid%h  (:,:,1) = h_0

  call trans_grid_to_spherical(Dyn%Grid%vor(:,:,1), Dyn%Spec%vor(:,:,1))
  call trans_grid_to_spherical(Dyn%Grid%div(:,:,1), Dyn%Spec%div(:,:,1))
  call trans_grid_to_spherical(Dyn%Grid%h  (:,:,1), Dyn%Spec%h  (:,:,1))

  call uv_grid_from_vor_div   (Dyn%Spec%vor(:,:,1), Dyn%Spec%div(:,:,1),  &
                               Dyn%Grid%u  (:,:,1), Dyn%Grid%v  (:,:,1))

  if(Dyn%grid_tracer) then
    Dyn%Grid%tr = 0.0
    do j = js, je
      if(deg_lat(j) > 10.0 .and. deg_lat(j) < 20.0) Dyn%Grid%tr(:,j,1) =  1.0
      if(deg_lat(j) > 70.0 )                        Dyn%Grid%tr(:,j,1) = -1.0
    end do
  endif

  if(Dyn%spec_tracer) then
    Dyn%Grid%trs = 0.0
    do j = js, je
      if(deg_lat(j) > 10.0 .and. deg_lat(j) < 20.0) Dyn%Grid%trs(:,j,1) =  1.0
      if(deg_lat(j) > 70.0 )                        Dyn%Grid%trs(:,j,1) = -1.0
    end do
    call trans_grid_to_spherical(Dyn%Grid%trs(:,:,1), Dyn%Spec%trs(:,:,1))
  endif

else

  call read_restart(Dyn)

endif

module_is_initialized = .true.

return
end subroutine shallow_dynamics_init

!========================================================================================

subroutine shallow_dynamics(Time, Time_init, Dyn, previous, current, future, delta_t)

type(time_type)    , intent(in)    :: Time, Time_init
type(dynamics_type), intent(inout) :: Dyn
integer, intent(in   )  :: previous, current, future
real,    intent(in   )  :: delta_t

! < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < >

complex, dimension(ms:me, ns:ne)  :: dt_vors, dt_divs, dt_hs, stream, bs, work
real,    dimension(is:ie, js:je)  :: vorg, bg, h_future, h_dt, dt_vorg
integer :: j

! < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < > < >

if(.not.module_is_initialized) then
  call error_mesg('shallow_dynamics','dynamics has not been initialized ', FATAL)
endif

do j = js,je
  vorg(:,j) = Dyn%Grid%vor(:,j,current) + coriolis(j)
end do
Dyn%Tend%u = Dyn%Tend%u + vorg*Dyn%Grid%v(:,:,current)
Dyn%Tend%v = Dyn%Tend%v - vorg*Dyn%Grid%u(:,:,current)

call vor_div_from_uv_grid (Dyn%Tend%u, Dyn%Tend%v, dt_vors, dt_divs)

call horizontal_advection (Dyn%Spec%h(:,:,current),   &
         Dyn%Grid%u(:,:,current), Dyn%Grid%v(:,:,current), Dyn%Tend%h)

Dyn%Tend%h = Dyn%Tend%h - Dyn%Grid%h(:,:,current)*Dyn%Grid%div(:,:,current)

call trans_grid_to_spherical (Dyn%Tend%h, dt_hs)

bg = (Dyn%Grid%h(:,:,current) + &
   0.5*(Dyn%Grid%u(:,:,current)**2 + Dyn%Grid%v(:,:,current)**2))

call trans_grid_to_spherical(bg, bs)
dt_divs = dt_divs - compute_laplacian(bs)

call implicit_correction (dt_divs, dt_hs, Dyn%Spec%div, Dyn%Spec%h, &
                            delta_t, previous, current)

call compute_spectral_damping(Dyn%Spec%vor(:,:,previous), dt_vors, delta_t)
call compute_spectral_damping(Dyn%Spec%div(:,:,previous), dt_divs, delta_t)
call compute_spectral_damping(Dyn%Spec%h  (:,:,previous), dt_hs  , delta_t)

call leapfrog(Dyn%Spec%vor , dt_vors  , previous, current, future, delta_t, robert_coeff)
call leapfrog(Dyn%Spec%div , dt_divs  , previous, current, future, delta_t, robert_coeff)
call leapfrog(Dyn%Spec%h   , dt_hs    , previous, current, future, delta_t, robert_coeff)

call trans_spherical_to_grid(Dyn%Spec%vor(:,:,future), Dyn%Grid%vor(:,:,future))
call trans_spherical_to_grid(Dyn%Spec%div(:,:,future), Dyn%Grid%div(:,:,future))

call uv_grid_from_vor_div  (Dyn%Spec%vor (:,:,future),  Dyn%Spec%div(:,:,future), &
                            Dyn%Grid%u   (:,:,future),  Dyn%Grid%v  (:,:,future))

call trans_spherical_to_grid (Dyn%Spec%h (:,:,future),  Dyn%Grid%h(:,:,future))

if(minval(Dyn%Grid%v) < valid_range_v(1) .or. maxval(Dyn%Grid%v) > valid_range_v(2)) then
  call error_mesg('shallow_dynamics','meridional wind out of valid range', FATAL)
endif

if(Dyn%spec_tracer) call update_spec_tracer(Dyn%Spec%trs, Dyn%Grid%trs, Dyn%Tend%trs, &
                         Dyn%Grid%u, Dyn%Grid%v, previous, current, future, delta_t)

if(Dyn%grid_tracer) call update_grid_tracer(Dyn%Grid%tr, Dyn%Tend%tr, &
                         Dyn%Grid%u, Dyn%Grid%v, previous, current, future, delta_t)

!  for diagnostics

stream = compute_laplacian(Dyn%Spec%vor(:,:,current), -1) ! for diagnostic purposes
call trans_spherical_to_grid(stream, Dyn%grid%stream)

Dyn%Grid%pv = vorg/Dyn%Grid%h(:,:,current)

return
end subroutine shallow_dynamics
!================================================================================

subroutine implicit_correction(dt_divs, dt_hs, divs, hs, delta_t, previous, current)

complex, intent(inout), dimension(ms:,ns:)   :: dt_divs, dt_hs
complex, intent(in),    dimension(ms:,ns:,:) :: divs, hs
real   , intent(in)                          :: delta_t
integer, intent(in)                          :: previous, current

real :: xi, mu, mu2

xi    = 0.5 ! centered implicit   (for backwards implicit, set xi = 1.0)

mu  = xi*delta_t
mu2 = mu*mu

dt_hs   = dt_hs + h_0*(divs(:,:,current) - divs(:,:,previous))
dt_divs = dt_divs - eigen*(hs(:,:,current) - hs(:,:,previous))

dt_divs = (dt_divs + mu*eigen*dt_hs)/(1.0 + mu2*eigen*h_0)
dt_hs   =  dt_hs - mu*h_0*dt_divs

return
end subroutine implicit_correction

!===================================================================================

subroutine update_spec_tracer(tr_spec, tr_grid, dt_tr, ug, vg, &
                              previous, current, future, delta_t)

complex, intent(inout), dimension(ms:me, ns:ne, num_time_levels) :: tr_spec
real   , intent(inout), dimension(is:ie, js:je, num_time_levels) :: tr_grid
real   , intent(inout), dimension(is:ie, js:je                 ) :: dt_tr
real   , intent(in   ), dimension(is:ie, js:je, num_time_levels) :: ug, vg
real   , intent(in   )  :: delta_t
integer, intent(in   )  :: previous, current, future

complex, dimension(ms:me, ns:ne) :: dt_trs

call horizontal_advection     (tr_spec(:,:,current), ug(:,:,current), vg(:,:,current), dt_tr)
call trans_grid_to_spherical  (dt_tr, dt_trs)
call compute_spectral_damping (tr_spec(:,:,previous), dt_trs, delta_t)
call leapfrog                 (tr_spec, dt_trs, previous, current, future, delta_t, robert_coeff)
call trans_spherical_to_grid  (tr_spec(:,:,future), tr_grid(:,:,future))

return
end subroutine update_spec_tracer
!==========================================================================

subroutine update_grid_tracer(tr_grid, dt_tr_grid, ug, vg, &
                              previous, current, future, delta_t)

real   , intent(inout), dimension(is:ie, js:je, num_time_levels) :: tr_grid
real   , intent(inout), dimension(is:ie, js:je                 ) :: dt_tr_grid
real   , intent(in   ), dimension(is:ie, js:je, num_time_levels) :: ug, vg

real   , intent(in   )  :: delta_t
integer, intent(in   )  :: previous, current, future

real, dimension(is:ie,js:je) :: tr_current, tr_future

tr_future = tr_grid(:,:,previous) + delta_t*dt_tr_grid
dt_tr_grid = 0.0
call a_grid_horiz_advection (ug(:,:,current), vg(:,:,current), tr_future, delta_t, dt_tr_grid)
tr_future = tr_future + delta_t*dt_tr_grid
tr_current = tr_grid(:,:,current) + &
    robert_coeff_tracer*(tr_grid(:,:,previous) + tr_future - 2.0*tr_grid(:,:,current))
tr_grid(:,:,current) = tr_current
tr_grid(:,:,future)  = tr_future

return
end subroutine update_grid_tracer

!==========================================================================

subroutine read_restart(Dyn)

type(dynamics_type), intent(inout)  :: Dyn

integer :: unit, m, n, nt
real, dimension(ms:me, ns:ne) :: real_part, imag_part

if(file_exist('INPUT/shallow_dynamics.res.nc')) then
  do nt = 1, 2
    call read_data('INPUT/shallow_dynamics.res.nc', 'vors_real', real_part, spectral_domain, timelevel=nt)
    call read_data('INPUT/shallow_dynamics.res.nc', 'vors_imag', imag_part, spectral_domain, timelevel=nt)
    do n=ns,ne
      do m=ms,me
        Dyn%Spec%vor(m,n,nt) = cmplx(real_part(m,n),imag_part(m,n))
      end do
    end do
    call read_data('INPUT/shallow_dynamics.res.nc', 'divs_real', real_part, spectral_domain, timelevel=nt)
    call read_data('INPUT/shallow_dynamics.res.nc', 'divs_imag', imag_part, spectral_domain, timelevel=nt)
    do n=ns,ne
      do m=ms,me
        Dyn%Spec%div(m,n,nt) = cmplx(real_part(m,n),imag_part(m,n))
      end do
    end do
    call read_data('INPUT/shallow_dynamics.res.nc', 'hs_real', real_part, spectral_domain, timelevel=nt)
    call read_data('INPUT/shallow_dynamics.res.nc', 'hs_imag', imag_part, spectral_domain, timelevel=nt)
    do n=ns,ne
      do m=ms,me
        Dyn%Spec%h(m,n,nt) = cmplx(real_part(m,n),imag_part(m,n))
      end do
    end do
    if(Dyn%spec_tracer) then
      call read_data('INPUT/shallow_dynamics.res.nc', 'trs_real', real_part, spectral_domain, timelevel=nt)
      call read_data('INPUT/shallow_dynamics.res.nc', 'trs_imag', imag_part, spectral_domain, timelevel=nt)
      do n=ns,ne
        do m=ms,me
          Dyn%Spec%trs(m,n,nt) = cmplx(real_part(m,n),imag_part(m,n))
        end do
      end do
    endif
    call read_data('INPUT/shallow_dynamics.res.nc', 'u',   Dyn%Grid%u  (:,:,nt), grid_domain, timelevel=nt)
    call read_data('INPUT/shallow_dynamics.res.nc', 'v',   Dyn%Grid%v  (:,:,nt), grid_domain, timelevel=nt)
    call read_data('INPUT/shallow_dynamics.res.nc', 'vor', Dyn%Grid%vor(:,:,nt), grid_domain, timelevel=nt)
    call read_data('INPUT/shallow_dynamics.res.nc', 'div', Dyn%Grid%div(:,:,nt), grid_domain, timelevel=nt)
    call read_data('INPUT/shallow_dynamics.res.nc', 'h',   Dyn%Grid%h  (:,:,nt), grid_domain, timelevel=nt)
    if(Dyn%spec_tracer) then
      call read_data('INPUT/shallow_dynamics.res.nc', 'trs', Dyn%Grid%trs(:,:,nt), grid_domain, timelevel=nt)
    endif
    if(Dyn%grid_tracer) then
      call read_data('INPUT/shallow_dynamics.res.nc', 'tr', Dyn%Grid%tr(:,:,nt), grid_domain, timelevel=nt)
    endif
  end do
else if(file_exist('INPUT/shallow_dynamics.res')) then
  unit = open_restart_file(file='INPUT/shallow_dynamics.res',action='read')

  do nt = 1, 2
    call set_domain(spectral_domain)
    call read_data(unit,Dyn%Spec%vor(:,:, nt))
    call read_data(unit,Dyn%Spec%div(:,:, nt))
    call read_data(unit,Dyn%Spec%h  (:,:, nt))
    if(Dyn%spec_tracer) call read_data(unit,Dyn%Spec%trs(:,:, nt))

    call set_domain(grid_domain)
    call read_data(unit,Dyn%Grid%u   (:,:, nt))
    call read_data(unit,Dyn%Grid%v   (:,:, nt))
    call read_data(unit,Dyn%Grid%vor (:,:, nt))
    call read_data(unit,Dyn%Grid%div (:,:, nt))
    call read_data(unit,Dyn%Grid%h   (:,:, nt))
    if(Dyn%spec_tracer) call read_data(unit,Dyn%Grid%trs(:,:, nt))
    if(Dyn%grid_tracer) call read_data(unit,Dyn%Grid%tr (:,:, nt))

  end do
  call close_file(unit)

else
    call error_mesg('read_restart', 'restart does not exist', FATAL)
endif

return
end subroutine read_restart

!====================================================================

subroutine write_restart(Dyn, previous, current)

type(dynamics_type), intent(in)  :: Dyn
integer, intent(in) :: previous, current

integer :: unit, nt, nn

do nt = 1, 2
  if(nt == 1) nn = previous
  if(nt == 2) nn = current
  call write_data('RESTART/shallow_dynamics.res.nc', 'vors_real',  real(Dyn%Spec%vor(:,:,nn)), spectral_domain)
  call write_data('RESTART/shallow_dynamics.res.nc', 'vors_imag', aimag(Dyn%Spec%vor(:,:,nn)), spectral_domain)
  call write_data('RESTART/shallow_dynamics.res.nc', 'divs_real',  real(Dyn%Spec%div(:,:,nn)), spectral_domain)
  call write_data('RESTART/shallow_dynamics.res.nc', 'divs_imag', aimag(Dyn%Spec%div(:,:,nn)), spectral_domain)
  call write_data('RESTART/shallow_dynamics.res.nc', 'hs_real',    real(Dyn%Spec%h  (:,:,nn)), spectral_domain)
  call write_data('RESTART/shallow_dynamics.res.nc', 'hs_imag',   aimag(Dyn%Spec%h  (:,:,nn)), spectral_domain)
  if(Dyn%spec_tracer) then
    call write_data('RESTART/shallow_dynamics.res.nc', 'trs_real',  real(Dyn%Spec%trs(:,:,nn)), spectral_domain)
    call write_data('RESTART/shallow_dynamics.res.nc', 'trs_imag', aimag(Dyn%Spec%trs(:,:,nn)), spectral_domain)
  endif
  call write_data('RESTART/shallow_dynamics.res.nc', 'u',   Dyn%Grid%u  (:,:,nn), grid_domain)
  call write_data('RESTART/shallow_dynamics.res.nc', 'v',   Dyn%Grid%v  (:,:,nn), grid_domain)
  call write_data('RESTART/shallow_dynamics.res.nc', 'vor', Dyn%Grid%vor(:,:,nn), grid_domain)
  call write_data('RESTART/shallow_dynamics.res.nc', 'div', Dyn%Grid%div(:,:,nn), grid_domain)
  call write_data('RESTART/shallow_dynamics.res.nc', 'h',   Dyn%Grid%h  (:,:,nn), grid_domain)
  if(Dyn%spec_tracer) then
    call write_data('RESTART/shallow_dynamics.res.nc', 'trs', Dyn%Grid%trs(:,:,nn), grid_domain)
  endif
  if(Dyn%grid_tracer) then
    call write_data('RESTART/shallow_dynamics.res.nc', 'tr', Dyn%Grid%tr(:,:,nn), grid_domain)
  endif
enddo

!unit = open_restart_file(file='RESTART/shallow_dynamics.res', action='write')

!do n = 1, 2
!  if(n == 1) nn = previous
!  if(n == 2) nn = current
!
!  call set_domain(spectral_domain)
!  call write_data(unit,Dyn%Spec%vor(:,:, nn))
!  call write_data(unit,Dyn%Spec%div(:,:, nn))
!  call write_data(unit,Dyn%Spec%h  (:,:, nn))
!  if(Dyn%spec_tracer) call write_data(unit,Dyn%Spec%trs(:,:, nn))
!
!  call set_domain(grid_domain)
!  call write_data(unit,Dyn%Grid%u   (:,:, nn))
!  call write_data(unit,Dyn%Grid%v   (:,:, nn))
!  call write_data(unit,Dyn%Grid%vor (:,:, nn))
!  call write_data(unit,Dyn%Grid%div (:,:, nn))
!  call write_data(unit,Dyn%Grid%h   (:,:, nn))
!  if(Dyn%spec_tracer) call write_data(unit,Dyn%Grid%trs(:,:, nn))
!  if(Dyn%grid_tracer) call write_data(unit,Dyn%Grid%tr (:,:, nn))
!
!end do

!call close_file(unit)

end subroutine write_restart

!====================================================================

subroutine shallow_dynamics_end (Dyn, previous, current)

type(dynamics_type), intent(inout)  :: Dyn
integer, intent(in) :: previous, current

if(.not.module_is_initialized) then
  call error_mesg('shallow_dynamics_end','dynamics has not been initialized ', FATAL)
endif

call write_restart (Dyn, previous, current)

call transforms_end

module_is_initialized = .false.

return
end subroutine shallow_dynamics_end
!===================================================================================

end module shallow_dynamics_mod


C
      SUBROUTINE HARM(A,M,INV,S,IFSET,IFERR)
C
C        SUBROUTINE HARM
C
C        PURPOSE
C           PERFORMS DISCRETE COMPLEX FOURIER TRANSFORMS ON A COMPLEX
C           THREE DIMENSIONAL ARRAY
C
C        USAGE
C           CALL HARM (A,M,INV,S,IFSET,IFERR)
C
C        NOTE
C           THESE COMMENT CARDS HAVE BEEN CORRECTED FOR SIGN ERROR
C           ORIGINALLY PRESENT IN  IFSET  THAT USED TO SPECIFY THE
C           INCORRECT DIRECTION OF THE FFT.
C
C        DESCRIPTION OF PARAMETERS
C           A     - AS INPUT, A CONTAINS THE COMPLEX, 3-DIMENSIONAL
C                   ARRAY TO BE TRANSFORMED.  THE REAL PART OF
C                   A(I1,I2,I3) IS STORED IN VECTOR FASHION IN A CELL
C                   WITH INDEX 2*(I3*N1*N2 + I2*N1 + I1) + 1 WHERE
C                   NI = 2**M(I), I=1,2,3 AND I1 = 0,1,...,N1-1 ETC.
C                   THE IMAGINARY PART IS IN THE CELL IMMEDIATELY
C                   FOLLOWING.  NOTE THAT THE SUBSCRIPT I1 INCREASES
C                   MOST RAPIDLY AND I3 INCREASES LEAST RAPIDLY.
C                   AS OUTPUT, A CONTAINS THE COMPLEX FOURIER
C                   TRANSFORM.  THE NUMBER OF CORE LOCATIONS OF
C                   ARRAY A IS 2*(N1*N2*N3)
C           M     - A THREE CELL VECTOR WHICH DETERMINES THE SIZES
C                   OF THE 3 DIMENSIONS OF THE ARRAY A.   THE SIZE,
C                   NI, OF THE I DIMENSION OF A IS 2**M(I), I = 1,2,3
C           INV   - A VECTOR WORK AREA FOR BIT AND INDEX MANIPULATION
C                   OF DIMENSION ONE FOURTH OF THE LARGEST OF N1,N2,N3
C           S     - A VECTOR WORK AREA FOR SINE TABLES WITH DIMENSION
C                   THE SAME AS INV
C           IFSET - AN OPTION PARAMETER WITH THE FOLLOWING SETTINGS
C                      0    SET UP SINE AND INV TABLES ONLY
C                     -1    SET UP SINE AND INV TABLES ONLY AND
C                           CALCULATE FOURIER TRANSFORM
C                      1    SET UP SINE AND INV TABLES ONLY AND
C                           CALCULATE INVERSE FOURIER TRANSFORM (FOR
C                           THE MEANING OF INVERSE SEE THE EQUATIONS
C                           UNDER METHOD BELOW)
C                     -2    CALCULATE FOURIER TRANSFORM ONLY (ASSUME
C                           SINE AND INV TABLES EXIST)
C                      2    CALCULATE INVERSE FOURIER TRANSFORM ONLY
C                           (ASSUME SINE AND INV TABLES EXIST)
C           IFERR - ERROR INDICATOR.   WHEN IFSET IS 0,+1,-1,
C                   IFERR = 1 MEANS THE MAXIMUM M(I) IS GREATER THAN
C                  20 , I=1,2,3
c                   " WHEN IFSET IS 2,-2 , IFERR = 1
C                   MEANS THAT THE SINE AND INV TABLES ARE NOT LARGE
C                   ENOUGH OR HAVE NOT BEEN COMPUTED ." ..removed as not standard
C                   IF ON RETURN IFERR = 0 THEN NONE OF THE ABOVE
C                   CONDITIONS ARE PRESENT
C
C        REMARKS
C           THIS SUBROUTINE IS TO BE USED FOR COMPLEX, 3-DIMENSIONAL
C           ARRAYS IN WHICH EACH DIMENSION IS A POWER OF 2.  THE
C           MAXIMUM M(I) MUST NOT BE LESS THAN 3 OR GREATER THAN 20,
C           I = 1,2,3
C
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C           NONE
C
C        METHOD
C           FOR IFSET = -1, OR -2, THE FOURIER TRANSFORM OF COMPLEX
C           ARRAY A IS OBTAINED.
C
C                  N1-1   N2-1   N3-1                L1   L2   L3
C     X(J1,J2,J3)=SUM    SUM    SUM    A(K1,K2,K3)*W1  *W2  *W3
C                  K1=0   K2=0   K3=0
C
C                  WHERE WI IS THE N(I) ROOT OF UNITY AND L1=K1*J1,
C                        L2=K2*J2, L3=K3*J3
C
C
C           FOR IFSET = +1, OR +2, THE INVERSE FOURIER TRANSFORM A OF
C           COMPLEX ARRAY X IS OBTAINED.
C
C     A(K1,K2,K3)=
C               1      N1-1   N2-1   N3-1                -L1  -L2  -L3
C           -------- *SUM    SUM    SUM    X(J1,J2,J3)*W1  *W2  *W3
C           N1*N2*N3   J1=0   J2=0   J3=0
C
C
C           SEE J.W. COOLEY AND J.W. TUKEY, @AN ALGORITHM FOR THE
C           MACHINE CALCULATION OF COMPLEX FOURIER SERIES@,
C           MATHEMATICS OF COMPUTATIONS, VOL. 19 (APR. 1965), P. 297.
C
******************************************************************************
*                    THIS ROUTINE IS PUBLIC DOMAIN                           *
******************************************************************************
C
      DIMENSION A(*),N(3),M(3),NP(3),W(2),W2(2),W3(2)
      DIMENSION INV(*),S(*)
      EQUIVALENCE (N1,N(1)),(N2,N(2)),(N3,N(3))
  869 FORMAT(1H ,E13.4)
  879 FORMAT(1H ,6I5)
c
**
**    The following are parameters which may be overwritten.
**    The original coding in fact assumed that these variables
**    would be retained
      MT=MAX0(M(1),M(2),M(3)) -2
      MT=MAX0(2,MT)
      NT=2**MT
**
   10 IF( IABS(IFSET) - 1) 900,900,12
   12 MTT=MAX0(M(1),M(2),M(3)) -2
      ROOT2 = SQRT(2.0)
      IF (MTT-MT ) 14,14,13
   13 IFERR=1
      RETURN
   14 IFERR=0
      M1=M(1)
      M2=M(2)
      M3=M(3)
      N1=2**M1
      N2=2**M2
      N3=2**M3
   16 IF(IFSET) 18,20,20
   18 NX= N1*N2*N3
      FN = NX
c     / may be faster than *
      nnn=nx*2
      DO 19 I = 1,nnn,2
      A(i) = A(i)/fn
   19 A(i+1) = -A(i+1)/FN
   20 NP(1)=N1*2
      NP(2)= NP(1)*N2
      NP(3)=NP(2)*N3
      DO 250 ID=1,3
      IL = NP(3)-NP(ID)
      IL1 = IL+1
      MI = M(ID)
      IF (MI)250,250,30
   30 IDIF=NP(ID)
      KBIT=NP(ID)
      MEV = 2*(MI/2)
      IF (MI - MEV )60,60,40
C
C     M IS ODD. DO L=1 CASE
   40 KBIT=KBIT/2
      KL=KBIT-2
      DO 50 I=1,IL1,IDIF
      KLAST=KL+I
      DO 50 K=I,KLAST,2
      K1=K+KBIT
C
C     DO ONE STEP WITH L=1,J=0
C     A(K)=A(K)+A(K1)
C     A(K1)=A(K)-A(K1)
C
C     NOTE: USE AK0_0 AS A little unwrapping
C      T=A(K1)
C      AK0_0=A(K)
C      A(K1)=AK0_0-T
C      A(K)=AK0_0+T
C
C      T=A(K1+1)
C      AK0_0=A(K+1)
C      A(K1+1)=AK0_0-T
C   50 A(K+1)=AK0_0+T
      AK0_0=A(K)
      AK0_1=A(K+1)
      AK1_0=A(K1)
      AK1_1=A(K1+1)
      A(K)=AK0_0+AK1_0
      A(K+1)=AK0_1+AK1_1
      A(K1)=AK0_0-AK1_0
      A(K1+1)=AK0_1-AK1_1
   50 CONTINUE
      IF (MI - 1)250,250,52
   52 LFIRST =3
C
C     DEF - JLAST = 2**(L-2) -1
      JLAST=1
      GO TO 70
C
C     M IS EVEN
   60 LFIRST = 2
      JLAST=0
   70 DO 240 L=LFIRST,MI,2
      JJDIF=KBIT
      KBIT=KBIT/4
      KL=KBIT-2
C
C     DO FOR J=0
C      CALL CLOCK(TIME1)
      DO 80 I=1,IL1,IDIF
      KLAST=I+KL
      DO 80 K=I,KLAST,2
      K1=K+KBIT
      K2=K1+KBIT
      K3=K2+KBIT
C
C     DO TWO STEPS WITH J=0
C     A(K)=A(K)+A(K2)
C     A(K2)=A(K)-A(K2)
C     A(K1)=A(K1)+A(K3)
C     A(K3)=A(K1)-A(K3)
C
C     A(K)=A(K)+A(K1)
C     A(K1)=A(K)-A(K1)
C     A(K2)=A(K2)+A(K3)*I
C     A(K3)=A(K2)-A(K3)*I
C
C
c     unwind variables
      ak0_0=a(k)
      ak0_1=a(k+1)
      ak1_0=a(k1)
      ak1_1=a(k1+1)
      ak2_0=a(k2)
      ak2_1=a(k2+1)
      ak3_0=a(k3)
      ak3_1=a(k3+1)
c
      T=AK2_0
      AK2_0=ak0_0-T
      AK0_0=ak0_0+T
      T=AK2_1
      AK2_1=ak0_1-T
      AK0_1=ak0_1+T
C
      T=AK3_0
      AK3_0=ak1_0-T
      AK1_0=ak1_0+T
      T=AK3_1
      AK3_1=ak1_1-T
      AK1_1=ak1_1+T
C
c     small change in the order here
C      T=AK1_0
C      R=AK0_0
C      T=AK1_1
C      R=AK0_1
      A(K)=AK0_0+AK1_0
      A(K+1)=AK0_1+AK1_1
      A(K1)=AK0_0-AK1_0
      A(K1+1)=AK0_1-AK1_1
C
C      R=-AK3_1
C      T = AK3_0
C      T2=AK2_0
C      T3=AK2_1
      A(K2)=AK2_0-AK3_1
      A(K2+1)=AK2_1+AK3_0
      A(K3)=AK2_0+AK3_1
      A(K3+1)=AK2_1-AK3_0
   80 continue
      IF (JLAST) 235,235,82
   82 JJ=JJDIF   +1
C
C     DO FOR J=1
      ILAST= IL +JJ
      DO 85 I = JJ,ILAST,IDIF
      KLAST = KL+I
      DO 85 K=I,KLAST,2
      K1 = K+KBIT
      K2 = K1+KBIT
      K3 = K2+KBIT
C
C     LETTING W=(1+I)/ROOT2,W3=(-1+I)/ROOT2,W2=I,
C     A(K)=A(K)+A(K2)*I
C     A(K2)=A(K)-A(K2)*I
C     A(K1)=A(K1)*W+A(K3)*W3
C     A(K3)=A(K1)*W-A(K3)*W3
C
C     A(K)=A(K)+A(K1)
C     A(K1)=A(K)-A(K1)
C     A(K2)=A(K2)+A(K3)*I
C     A(K3)=A(K2)-A(K3)*I
C
C
c     unwind variables
      ak0_0=a(k)
      ak0_1=a(k+1)
      ak1_0=a(k1)
      ak1_1=a(k1+1)
      ak2_0=a(k2)
      ak2_1=a(k2+1)
      ak3_0=a(k3)
      ak3_1=a(k3+1)
      R =-AK2_1
      T = AK2_0
      AK2_0 = AK0_0-R
      AK0_0 = AK0_0+R
      AK2_1=AK0_1-T
      AK0_1=AK0_1+T
C
      AWR=AK1_0-AK1_1
      AWI = AK1_1+AK1_0
      R=-AK3_0-AK3_1
      T=AK3_0-AK3_1
      AK3_0=(AWR-R)/ROOT2
      AK3_1=(AWI-T)/ROOT2
      AK1_0=(AWR+R)/ROOT2
      AK1_1=(AWI+T)/ROOT2
c     order change here
C      T= AK1_0
C      T=AK1_1
      A(K)=AK0_0+ak1_0
      A(K+1)=AK0_1+AK1_1
      A(K1)=AK0_0-AK1_0
      A(K1+1)=AK0_1-AK1_1
c
C      R=-AK3_1
C      T=AK3_0
      A(K2)=AK2_0-AK3_1
      A(K2+1)=AK2_1+AK3_0
      A(K3)=AK2_0+AK3_1
      A(K3+1)=AK2_1-AK3_0
   85 continue
      IF(JLAST-1) 235,235,90
   90 JJ= JJ + JJDIF
C
C     NOW DO THE REMAINING J@S
      DO 230 J=2,JLAST
C     THIS EQUIVALENCE FORCES SOME VARIABLES INTO PERMANENT REGISTER
C      EQUIVALENCE (I2,K,I3CC),(K1,I2C,I3),(K2,I2CC,I3C)
C
C     FETCH W@S
C     DEF- W=W**INV(J), W2=W**2, W3=W**3
   96 I=INV(J+1)
C   98 IC=NT-I
      W(1)=S(NT-I)
      W(2)=S(I)
      K=I+I
      K1=NT-K
      IF(K1)120,110,100
C     2*I IS IN FIRST QUADRANT
  100 W2(1)=S(K1)
      W2(2)=S(K)
      GO TO 130
  110 W2(1)=0.0d0
      W2(2)=1.0d0
      GO TO 130
C
C     2*I IS IN SECOND QUADRANT
  120 K2 = K1+NT
      K1=-K1
      W2(1)=-S(K1)
      W2(2)=S(K2)
  130 K1=I+K
      K2=NT-K1
      IF(K2)160,150,140
C
C     I3 IN FIRST QUADRANT
  140 W3(1)=S(K2)
      W3(2)=S(K1)
      GO TO 200
  150 W3(1)=0.0d0
      W3(2)=1.0d0
      GO TO 200
C
  160 K=K2+NT
      IF(K)190,180,170
C
C     I3 IN SECOND QUADRANT
  170 K2=-K2
      W3(1)=-S(K2)
      W3(2)=S(K)
      GO TO 200
  180 W3(1)=-1.0d0
      W3(2)=0.0d0
      GO TO 200
C
C     3*I IN THIRD QUADRANT
  190 K1=NT+K
      K = -K
      W3(1)=-S(K1)
      W3(2)=-S(K)
  200 ILAST=IL+JJ
      DO 220 I=JJ,ILAST,IDIF
      KLAST=KL+I
      DO 220 K=I,KLAST,2
      K1=K+KBIT
      K2=K1+KBIT
C      K3=K2+KBIT
C
C     DO TWO STEPS WITH J NOT 0
C     A(K)=A(K)+A(K2)*W2
C     A(K2)=A(K)-A(K2)*W2
C     A(K1)=A(K1)*W+A(K3)*W3
C     A(K3)=A(K1)*W-A(K3)*W3
C
C     A(K)=A(K)+A(K1)
C     A(K1)=A(K)-A(K1)
C     A(K2)=A(K2)+A(K3)*I
C     A(K3)=A(K2)-A(K3)*I
C
c     unwind variables
      ak0_0=a(k)
      ak0_1=a(k+1)
      ak1_0=a(k1)
      ak1_1=a(k1+1)
      ak2_0=a(k2)
      ak2_1=a(k2+1)
      ak3_0=a(k2+KBIT)
      ak3_1=a(k2+KBIT+1)
      R=ak2_0*W2(1)-ak2_1*W2(2)
      T=ak2_0*W2(2)+ak2_1*W2(1)
      ak2_0=ak0_0-R
      ak0_0=ak0_0+R
      ak2_1=ak0_1-T
      ak0_1=ak0_1+T
C
      R=ak3_0*W3(1)-ak3_1*W3(2)
      T=ak3_0*W3(2)+ak3_1*W3(1)
      AWR=ak1_0*W(1)-ak1_1*W(2)
      AWI=ak1_0*W(2)+ak1_1*W(1)
      ak3_0=AWR-R
      ak3_1=AWI-T
      ak1_0=AWR+R
      ak1_1=AWI+T
c
c     order change
C     T=ak1_0
      a(k)=ak0_0+ak1_0
      a(k+1)=ak0_1+ak1_1
      a(k1)=ak0_0-ak1_0
c     T=ak1_1
      a(k1+1)=ak0_1-ak1_1
c     R=-ak3_1
c     T=ak3_0
      a(k2)=ak2_0-ak3_1
      a(k2+1)=ak2_1+ak3_0
      a(k2+KBIT)=ak2_0+ak3_1
      a(k2+KBIT+1)=ak2_1-ak3_0
  220 continue
C     END OF I AND K LOOPS
C
  230 JJ=JJDIF+JJ
C     END OF J-LOOP
C
  235 JLAST=4*JLAST+3
  240 CONTINUE
C     END OF  L  LOOP
  250 CONTINUE
C     END OF  ID  LOOP
C
C     WE NOW HAVE THE COMPLEX FOURIER SUMS BUT THEIR ADDRESSES ARE
C     BIT-REVERSED.  THE FOLLOWING ROUTINE PUTS THEM IN ORDER
      NTSQ=NT*NT
      M3MT=M3-MT
  350 IF(M3MT) 370,360,360
C
C     M3 GR. OR EQ. MT
  360 IGO3=1
      N3VNT=N3/NT
      MINN3=NT
      GO TO 380
C
C     M3 LESS THAN MT
  370 IGO3=2
      N3VNT=1
      NTVN3=NT/N3
      MINN3=N3
  380 JJD3 = NTSQ/N3
      M2MT=M2-MT
  450 IF (M2MT)470,460,460
C
C     M2 GR. OR EQ. MT
  460 IGO2=1
      N2VNT=N2/NT
      MINN2=NT
      GO TO 480
C
C     M2 LESS THAN MT
  470 IGO2 = 2
      N2VNT=1
      NTVN2=NT/N2
      MINN2=N2
  480 JJD2=NTSQ/N2
      M1MT=M1-MT
  550 IF(M1MT)570,560,560
C
C     M1 GR. OR EQ. MT
  560 IGO1=1
      N1VNT=N1/NT
      MINN1=NT
      GO TO 580
C
C     M1 LESS THAN MT
  570 IGO1=2
      N1VNT=1
      NTVN1=NT/N1
      MINN1=N1
  580 JJD1=NTSQ/N1
  600 JJ3=1
      J=1
      DO 880 JPP3=1,N3VNT
      IPP3=INV(JJ3)
      DO 870 JP3=1,MINN3
      GO TO (610,620),IGO3
  610 IP3=INV(JP3)*N3VNT
      GO TO 630
  620 IP3=INV(JP3)/NTVN3
  630 I3=(IPP3+IP3)*N2
  700 JJ2=1
      DO 870 JPP2=1,N2VNT
      IPP2=INV(JJ2)+I3
      DO 860 JP2=1,MINN2
      GO TO (710,720),IGO2
  710 IP2=INV(JP2)*N2VNT
      GO TO 730
  720 IP2=INV(JP2)/NTVN2
  730 I2=(IPP2+IP2)*N1
  800 JJ1=1
      DO 860 JPP1=1,N1VNT
      IPP1=INV(JJ1)+I2
      DO 850 JP1=1,MINN1
      GO TO (810,820),IGO1
  810 IP1=INV(JP1)*N1VNT
      GO TO 830
  820 IP1=INV(JP1)/NTVN1
  830 I=2*(IPP1+IP1)+1
      IF (J-I) 840,850,850
  840 T=A(I)
      A(I)=A(J)
      A(J)=T
      T=A(I+1)
      A(I+1)=A(J+1)
      A(J+1)=T
  850 J=J+2
  860 JJ1=JJ1+JJD1
C     END OF JPP1 AND JP2
C
  870 JJ2=JJ2+JJD2
C     END OF JPP2 AND JP3 LOOPS
C
  880 JJ3 = JJ3+JJD3
C     END OF JPP3 LOOP
C
  890 IF(IFSET)891,895,895
  891 nnn=nx*2
C      fn=1./nx
C      DO 892 I = 1,Nnn,2
C      a(i)=a(i)*fn
C  892 A(i+1) = -A(i+1)*fn
      DO 892 I=2,Nnn,2
  892 A(I)=-A(I)
  895 RETURN
C
C     THE FOLLOWING PROGRAM COMPUTES THE SIN AND INV TABLES.
C
  900 MT=MAX0(M(1),M(2),M(3)) -2
      MT=MAX0(2,MT)
  904 IF (MT-18) 906,906,13
  906 IFERR=0
      NT=2**MT
      NTV2=NT/2
C
C     SET UP SIN TABLE
C     THETA=PIE/2**(L+1) FOR L=1
c  910 THETA=.7853981634
  910 THETA=asin(1.0)/2.0
C
C     JSTEP=2**(MT-L+1) FOR L=1
      JSTEP=NT
C
C     JDIF=2**(MT-L) FOR L=1
      JDIF=NTV2
      S(JDIF)=SIN(THETA)
      DO 950 L=2,MT
      THETA=THETA/2.0
      JSTEP2=JSTEP
      JSTEP=JDIF
      JDIF=JSTEP/2
      S(JDIF)=SIN(THETA)
      JC1=NT-JDIF
      S(JC1)=COS(THETA)
      JLAST=NT-JSTEP2
      IF(JLAST - JSTEP) 950,920,920
  920 DO 940 J=JSTEP,JLAST,JSTEP
      JC=NT-J
      JD=J+JDIF
  940 S(JD)=S(J)*S(JC1)+S(JDIF)*S(JC)
  950 CONTINUE
C
C     SET UP INV(J) TABLE
C
  960 MTLEXP=NTV2
C
C     MTLEXP=2**(MT-L). FOR L=1
      LM1EXP=1
C
C     LM1EXP=2**(L-1). FOR L=1
      INV(1)=0
      DO 980 L=1,MT
      INV(LM1EXP+1) = MTLEXP
      DO 970 J=2,LM1EXP
      JJ=J+LM1EXP
  970 INV(JJ)=INV(J)+MTLEXP
      MTLEXP=MTLEXP/2
  980 LM1EXP=LM1EXP*2
  982 IF(IFSET)12,895,12
      END


c /***************************************************
c   disksgen.f  for dbulhalo
c  1 Feb. 2011  written by D.Kawata
c ****************************************************/
c70*******************************************************************

c /*****   generating exponential disk *****/
      subroutine diskspgen(np,rdlim,zdlim)
      include 'define.f'

      integer np
      character filen*60
      double precision rdlim,zdlim
      integer i,j
      integer nr,nth,nz,ir,ith,iz,izp
      double precision rlim,zlim,dr,dz,dth
      double precision lzi,lzo,dlz,zip,zop
      double precision thp,zp,dvr,rhop,rp
      double precision mtot
      integer nrp,ndrm
      double precision ri,ro,lri,lro,dlr,rr,mrp

c      nr=1024
c      nth=64
c      nz=64
      nr=256
      nth=32
      nz=64

      rlim=rdlim
      zlim=zdlim
      dr=rlim/dble(nr)
      dth=2.0d0*M_PI/dble(nth)
      mtot=0.0d0
c *** set dz by constant d log z
      lzi= dlog10(zdlim*frini0dz)
      lzo = dlog10(zdlim)
      dlz = (lzo-lzi)/(dble(nz/2))

      write(6,*) ' sample disk z range=',10.0d0**lzi,10.0d0**lzo

c *** generate particles
      np=0
      open(60,file='disks.dat',status='unknown')
      do ith=0,nth-1
        thp=0.5d0*dth+dth*dble(ith)
        do iz=0,nz
          if(iz.lt.nz/2) then
            izp=iz
          else
            izp=iz-nz/2
          endif
          zp=10.0d0**(lzi+dble(izp)*dlz)
          if(izp.gt.0) then
            zip=10.0d0**(lzi+dble(izp-1)*dlz)
          else
            zip=0.0d0
          endif
          zop=10.0d0**(lzi+dble(izp+1)*dlz)
          dz=0.5d0*(zop-zip)
          if(iz.lt.nz/2) then
            zp=-zp
          endif
          do ir=0,nr-1
            rp=dble(ir+1)*dr
            x_p(np)=rp*dcos(thp)
            y_p(np)=rp*dsin(thp)
            z_p(np)=zp
            dvr=dz*(dth*rp)*dr
            dvr_p(np)=dvr
            m_p(np)=0.0d0
            h_p(np)=ETAH*(dvr**(1.0d0/3.0d0))
c
            write(60,'(3(1pE13.5))') x_p(np),y_p(np),z_p(np)
c
            np=np+1
          enddo
        enddo
      enddo
      close(60)
      write(6,*) 'np sample disk =',np
      write(6,*) 'r,z lim=',rlim,zlim
      write(6,*) 'nr,nth,nz=',nr,nth,nz

      return
      end

c /*****   generating exponential disk *****/
      subroutine disksdenm(np,mdisk,hd,zd)
      include 'define.f'

      integer np,np0,nd,idisk
      character filen*60
      double precision mdisk,hd,zd
      integer i,j
      integer nr,nth,nz,ir,ith,iz
      double precision rlim,zlim,dr,dz,dth
      double precision thp,zp,dvr,rhop,rp
      double precision mtot
      integer nrp,ndrm
      double precision ri,ro,lri,lro,dlr,rr,mrp
      mtot=0.0d0
c *** assign density
      do i=0,np-1
        rp=dsqrt(x_p(i)**2+y_p(i)**2)
c *** density ***
        rhop=(mdisk/(4.0d0*M_PI*zd*(hd**2)))
     &   *(1.0d0/(dcosh(z_p(i)/zd)**2))
     &   *dexp(-rp/hd)
        m_p(i)=m_p(i)+rhop*dvr_p(i)
        mtot=mtot+rhop*dvr_p(i)
      enddo
      write(6,*) ' Mtot sdisk=',mtot

      return
      end


! ###################################################################
! Copyright (c) 2013-2022, Marc De Graef Research Group/Carnegie Mellon University
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification, are
! permitted provided that the following conditions are met:
!
!     - Redistributions of source code must retain the above copyright notice, this list
!        of conditions and the following disclaimer.
!     - Redistributions in binary form must reproduce the above copyright notice, this
!        list of conditions and the following disclaimer in the documentation and/or
!        other materials provided with the distribution.
!     - Neither the names of Marc De Graef, Carnegie Mellon University nor the names
!        of its contributors may be used to endorse or promote products derived from
!        this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
! USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ###################################################################

module mod_PGA3D
  !! author: MDG
  !! version: 1.0
  !! date: 07/20/21
  !!
  !! class definition for the PGA3D module (Projective Geometric Algebra in 3D)
  !!
  !! This is based on the file pga3d.cpp from BiVector.net; for a detailed explanation and
  !! applications, see https://bivector.net/PGA4CS.pdf and other documents on bivector.net.

use mod_kinds
use mod_global

IMPLICIT NONE

private
character(5), parameter :: basis(0:15) = (/ "  one","   e0","   e1","   e2","   e3", &
                                            "  e01","  e02","  e03","  e12","  e31","  e23", &
                                            " e021"," e013"," e032"," e123","e0123" /)

intrinsic :: conjg
public :: conjg

interface conjg
  procedure mvec_conjugate_
end interface conjg

! class definition
type, public :: PGA3D_T
private
  real(kind=dbl)        :: mvec(0:15)

contains
private
  procedure, pass(self) :: mvec_setcomp_
  procedure, pass(self) :: mvec_getcomp_
  procedure, pass(self) :: mvec_getgrade_
  procedure, pass(self) :: mvec_log_
  procedure, pass(self) :: mvec_reverse_
  procedure, pass(self) :: mvec_dual_
  procedure, pass(self) :: mvec_conjugate_
  procedure, pass(self) :: mvec_involute_
  procedure, pass(self) :: mvec_mult_
  procedure, pass(self) :: mvec_wedge_
  procedure, pass(self) :: mvec_vee_
  procedure, pass(self) :: mvec_inner_
  procedure, pass(self) :: mvec_commutator_
  procedure, pass(self) :: mvec_sandwich_
  procedure, pass(self) :: mvec_add_
  procedure, pass(self) :: mvec_subtract_
  procedure, pass(self) :: mvec_muls_
  procedure, pass(self) :: mvec_adds_
  procedure, pass(self) :: mvec_norm_
  procedure, pass(self) :: mvec_inorm_
  procedure, pass(self) :: mvec_normalized_

  generic, public :: setcomp => mvec_setcomp_
  generic, public :: getcomp => mvec_getcomp_
  generic, public :: getgrade => mvec_getgrade_
  generic, public :: log => mvec_log_
  generic, public :: operator(.reverse.) => mvec_reverse_
  generic, public :: operator(.dual.) => mvec_dual_
  generic, public :: operator(.involute.) => mvec_involute_
  generic, public :: operator(*) => mvec_mult_
  generic, public :: operator(.wedge.) => mvec_wedge_
  generic, public :: operator(.vee.) => mvec_vee_
  generic, public :: operator(.inner.) => mvec_inner_
  generic, public :: operator(.cross.) => mvec_commutator_
  generic, public :: operator(.sandwich.) => mvec_sandwich_
  generic, public :: operator(+) => mvec_add_
  generic, public :: operator(-) => mvec_subtract_
  generic, public :: operator(.muls.) => mvec_muls_ ! , mvec_smul_
  generic, public :: operator(.adds.) => mvec_adds_ ! , mvec_smul_
  generic, public :: norm => mvec_norm_
  generic, public :: inorm => mvec_inorm_
  generic, public :: normalized => mvec_normalized_

end type PGA3D_T

! interface operator(.smul.)
!   recursive function mvec_smul_(a, b) result(mvout)
!     use mod_global
!     real(kind=dbl), INTENT(IN)           :: a
!     type(PGA3D_T), INTENT(IN)            :: b
!     type(PGA3D_T)                        :: mvout
!   end function mvec_smul_
! end interface

! the constructor routine for this class
interface PGA3D_T
  module procedure PGA3D_constructor
end interface PGA3D_T

contains

!--------------------------------------------------------------------------
type(PGA3D_T) function PGA3D_constructor( val, ind ) result(PGA3D)
!! author: MDG
!! version: 1.0
!! date: 07/20/21
!!
!! constructor for the PGA3D_T Class; initialize the multivector mvec

IMPLICIT NONE

real(kind=dbl),INTENT(IN),OPTIONAL      :: val
integer(kind=irg),INTENT(IN),OPTIONAL   :: ind

PGA3D%mvec = 0.D0

if (present(val).and.present(ind)) then
  PGA3D%mvec(ind) = val
end if

end function PGA3D_constructor

!--------------------------------------------------------------------------
subroutine PGA3D_destructor(self)
!! author: MDG
!! version: 1.0
!! date: 07/20/21
!!
!! destructor for the PGA3D_T Class

IMPLICIT NONE

type(PGA3D_T), INTENT(INOUT)  :: self

call reportDestructor('PGA3D_T')

end subroutine PGA3D_destructor

!--------------------------------------------------------------------------
function mvec_reverse_( self ) result(mvout)
!DEC$ ATTRIBUTES DLLEXPORT :: mvec_reverse_
!! author: MDG
!! version: 1.0
!! date: 07/20/21
!!
!! reverse a multivector using the .reverse. operator

IMPLICIT NONE

class(PGA3D_T),INTENT(IN)  :: self
type(PGA3D_T)              :: mvout

mvout%mvec = self%mvec
mvout%mvec(5:14) = -mvout%mvec(5:14)

end function mvec_reverse_

!--------------------------------------------------------------------------
function mvec_dual_( self ) result(mvout)
!DEC$ ATTRIBUTES DLLEXPORT :: mvec_dual_
!! author: MDG
!! version: 1.0
!! date: 07/20/21
!!
!! Poincare duality operation

IMPLICIT NONE

class(PGA3D_T),INTENT(IN)   :: self
type(PGA3D_T)               :: mvout

integer(kind=irg)           :: i

do i=0,15
  mvout%mvec(i) = self%mvec(15-i)
end do

end function mvec_dual_

!--------------------------------------------------------------------------
recursive function mvec_getcomp_(self, ind) result(c)
!DEC$ ATTRIBUTES DLLEXPORT :: mvec_getcomp_
!! author: MDG
!! version: 1.0
!! date: 07/20/21
!!
!! get a multivector component

IMPLICIT NONE

class(PGA3D_T), INTENT(INOUT)         :: self
integer(kind=irg),INTENT(IN)          :: ind
real(kind=dbl)                        :: c

c = self%mvec(ind)

end function mvec_getcomp_

!--------------------------------------------------------------------------
recursive subroutine mvec_setcomp_(self, val, ind)
!DEC$ ATTRIBUTES DLLEXPORT :: mvec_setcomp_
!! author: MDG
!! version: 1.0
!! date: 07/20/21
!!
!! set a multivector component

IMPLICIT NONE

class(PGA3D_T), INTENT(INOUT)         :: self
real(kind=dbl),INTENT(IN)             :: val
integer(kind=irg),INTENT(IN)          :: ind

self%mvec(ind) = val

end subroutine mvec_setcomp_

!--------------------------------------------------------------------------
recursive function mvec_getgrade_(self, ind) result(c)
!DEC$ ATTRIBUTES DLLEXPORT :: mvec_getgrade_
!! author: MDG
!! version: 1.0
!! date: 07/20/21
!!
!! get grade ind from a multivector

IMPLICIT NONE

class(PGA3D_T), INTENT(INOUT)         :: self
integer(kind=irg),INTENT(IN)          :: ind
real(kind=dbl),allocatable            :: c(:)

integer(kind=irg),parameter           :: gr(0:4) = (/ 1, 4, 6, 4, 1 /)
integer(kind=irg)                     :: i

allocate( c(gr(ind)) )
select case (ind)
  case (0)
    c(1) = self%mvec_getcomp_(0)
  case (1)
    do i = 1, 4
      c(i) = self%mvec_getcomp_(i)
    end do
  case (2)
    do i = 1, 6
      c(i) = self%mvec_getcomp_(i+4)
    end do
  case (3)
    do i = 1, 4
      c(i) = self%mvec_getcomp_(i+10)
    end do
  case (4)
    c(1) = self%mvec_getcomp_(15)
end select

end function mvec_getgrade_

!--------------------------------------------------------------------------
recursive function mvec_conjugate_(self) result(mvout)
!DEC$ ATTRIBUTES DLLEXPORT :: mvec_conjugate_
!! author: MDG
!! version: 1.0
!! date: 07/20/21
!!
!! conjugate a multivector

IMPLICIT NONE

class(PGA3D_T), INTENT(INOUT)         :: self
type(PGA3D_T)                         :: mvout

mvout%mvec = self%mvec
mvout%mvec(1:10) = -self%mvec(1:10)

end function mvec_conjugate_

!--------------------------------------------------------------------------
recursive function mvec_involute_(self) result(mvout)
!DEC$ ATTRIBUTES DLLEXPORT :: mvec_involute_
!! author: MDG
!! version: 1.0
!! date: 07/20/21
!!
!! involute a multivector

IMPLICIT NONE

class(PGA3D_T), INTENT(IN)         :: self
type(PGA3D_T)                      :: mvout

mvout%mvec = self%mvec
mvout%mvec(1:4) = -self%mvec(1:4)
mvout%mvec(11:14) = -self%mvec(11:14)

end function mvec_involute_

!--------------------------------------------------------------------------
recursive function mvec_mult_(self, mvb) result(mvout)
!DEC$ ATTRIBUTES DLLEXPORT :: mvec_mult_
!! author: MDG
!! version: 1.0
!! date: 07/20/21
!!
!! involute a multivector

IMPLICIT NONE

class(PGA3D_T), INTENT(IN)          :: self
type(PGA3D_T), INTENT(IN)           :: mvb
type(PGA3D_T)                       :: mvout

real(kind=dbl)                      :: a(0:15), b(0:15)

a = self%mvec
b = mvb%mvec

mvout%mvec = (/ b(0)*a(0)+b(2)*a(2)+b(3)*a(3)+b(4)*a(4)-b(8)*a(8)-b(9)*a(9)-b(10)*a(10)-b(14)*a(14), &
                b(1)*a(0)+b(0)*a(1)-b(5)*a(2)-b(6)*a(3)-b(7)*a(4)+b(2)*a(5)+b(3)*a(6)+b(4)*a(7) &
                +b(11)*a(8)+b(12)*a(9)+b(13)*a(10)+b(8)*a(11)+b(9)*a(12)+b(10)*a(13)+b(15)*a(14)-b(14)*a(15), &
                b(2)*a(0)+b(0)*a(2)-b(8)*a(3)+b(9)*a(4)+b(3)*a(8)-b(4)*a(9)-b(14)*a(10)-b(10)*a(14), &
                b(3)*a(0)+b(8)*a(2)+b(0)*a(3)-b(10)*a(4)-b(2)*a(8)-b(14)*a(9)+b(4)*a(10)-b(9)*a(14), &
                b(4)*a(0)-b(9)*a(2)+b(10)*a(3)+b(0)*a(4)-b(14)*a(8)+b(2)*a(9)-b(3)*a(10)-b(8)*a(14), &
                b(5)*a(0)+b(2)*a(1)-b(1)*a(2)-b(11)*a(3)+b(12)*a(4)+b(0)*a(5)-b(8)*a(6)+b(9)*a(7)+b(6)*a(8) &
                -b(7)*a(9)-b(15)*a(10)-b(3)*a(11)+b(4)*a(12)+b(14)*a(13)-b(13)*a(14)-b(10)*a(15), &
                b(6)*a(0)+b(3)*a(1)+b(11)*a(2)-b(1)*a(3)-b(13)*a(4)+b(8)*a(5)+b(0)*a(6)-b(10)*a(7)-b(5)*a(8) &
                -b(15)*a(9)+b(7)*a(10)+b(2)*a(11)+b(14)*a(12)-b(4)*a(13)-b(12)*a(14)-b(9)*a(15), &
                b(7)*a(0)+b(4)*a(1)-b(12)*a(2)+b(13)*a(3)-b(1)*a(4)-b(9)*a(5)+b(10)*a(6)+b(0)*a(7)-b(15)*a(8) &
                +b(5)*a(9)-b(6)*a(10)+b(14)*a(11)-b(2)*a(12)+b(3)*a(13)-b(11)*a(14)-b(8)*a(15), &
                b(8)*a(0)+b(3)*a(2)-b(2)*a(3)+b(14)*a(4)+b(0)*a(8)+b(10)*a(9)-b(9)*a(10)+b(4)*a(14), &
                b(9)*a(0)-b(4)*a(2)+b(14)*a(3)+b(2)*a(4)-b(10)*a(8)+b(0)*a(9)+b(8)*a(10)+b(3)*a(14), &
                b(10)*a(0)+b(14)*a(2)+b(4)*a(3)-b(3)*a(4)+b(9)*a(8)-b(8)*a(9)+b(0)*a(10)+b(2)*a(14), &
                b(11)*a(0)-b(8)*a(1)+b(6)*a(2)-b(5)*a(3)+b(15)*a(4)-b(3)*a(5)+b(2)*a(6)-b(14)*a(7)-b(1)*a(8) &
                +b(13)*a(9)-b(12)*a(10)+b(0)*a(11)+b(10)*a(12)-b(9)*a(13)+b(7)*a(14)-b(4)*a(15), &
                b(12)*a(0)-b(9)*a(1)-b(7)*a(2)+b(15)*a(3)+b(5)*a(4)+b(4)*a(5)-b(14)*a(6)-b(2)*a(7)-b(13)*a(8) &
                -b(1)*a(9)+b(11)*a(10)-b(10)*a(11)+b(0)*a(12)+b(8)*a(13)+b(6)*a(14)-b(3)*a(15), &
                b(13)*a(0)-b(10)*a(1)+b(15)*a(2)+b(7)*a(3)-b(6)*a(4)-b(14)*a(5)-b(4)*a(6)+b(3)*a(7)+b(12)*a(8) &
                -b(11)*a(9)-b(1)*a(10)+b(9)*a(11)-b(8)*a(12)+b(0)*a(13)+b(5)*a(14)-b(2)*a(15), &
                b(14)*a(0)+b(10)*a(2)+b(9)*a(3)+b(8)*a(4)+b(4)*a(8)+b(3)*a(9)+b(2)*a(10)+b(0)*a(14), &
                b(15)*a(0)+b(14)*a(1)+b(13)*a(2)+b(12)*a(3)+b(11)*a(4)+b(10)*a(5)+b(9)*a(6)+b(8)*a(7)+b(7)*a(8) &
                +b(6)*a(9)+b(5)*a(10)-b(4)*a(11)-b(3)*a(12)-b(2)*a(13)-b(1)*a(14)+b(0)*a(15) /)

end function mvec_mult_

!--------------------------------------------------------------------------
recursive function mvec_wedge_(self, mvb) result(mvout)
!DEC$ ATTRIBUTES DLLEXPORT :: mvec_wedge_
!! author: MDG
!! version: 1.0
!! date: 07/20/21
!!
!! wedge product of two multivectors

IMPLICIT NONE

class(PGA3D_T), INTENT(IN)          :: self
type(PGA3D_T), INTENT(IN)           :: mvb
type(PGA3D_T)                       :: mvout

real(kind=dbl)                      :: a(0:15), b(0:15)

a = self%mvec
b = mvb%mvec

mvout%mvec = (/ b(0)*a(0), b(1)*a(0)+b(0)*a(1), b(2)*a(0)+b(0)*a(2), b(3)*a(0)+b(0)*a(3), b(4)*a(0)+b(0)*a(4), &
                b(5)*a(0)+b(2)*a(1)-b(1)*a(2)+b(0)*a(5), b(6)*a(0)+b(3)*a(1)-b(1)*a(3)+b(0)*a(6), &
                b(7)*a(0)+b(4)*a(1)-b(1)*a(4)+b(0)*a(7), b(8)*a(0)+b(3)*a(2)-b(2)*a(3)+b(0)*a(8), &
                b(9)*a(0)-b(4)*a(2)+b(2)*a(4)+b(0)*a(9), b(10)*a(0)+b(4)*a(3)-b(3)*a(4)+b(0)*a(10), &
                b(11)*a(0)-b(8)*a(1)+b(6)*a(2)-b(5)*a(3)-b(3)*a(5)+b(2)*a(6)-b(1)*a(8)+b(0)*a(11), &
                b(12)*a(0)-b(9)*a(1)-b(7)*a(2)+b(5)*a(4)+b(4)*a(5)-b(2)*a(7)-b(1)*a(9)+b(0)*a(12), &
                b(13)*a(0)-b(10)*a(1)+b(7)*a(3)-b(6)*a(4)-b(4)*a(6)+b(3)*a(7)-b(1)*a(10)+b(0)*a(13), &
                b(14)*a(0)+b(10)*a(2)+b(9)*a(3)+b(8)*a(4)+b(4)*a(8)+b(3)*a(9)+b(2)*a(10)+b(0)*a(14), &
                b(15)*a(0)+b(14)*a(1)+b(13)*a(2)+b(12)*a(3)+b(11)*a(4)+b(10)*a(5)+b(9)*a(6)+b(8)*a(7) &
                +b(7)*a(8)+b(6)*a(9)+b(5)*a(10)-b(4)*a(11)-b(3)*a(12)-b(2)*a(13)-b(1)*a(14)+b(0)*a(15) /)

end function mvec_wedge_

!--------------------------------------------------------------------------
recursive function mvec_vee_(self, mvb) result(mvout)
!DEC$ ATTRIBUTES DLLEXPORT :: mvec_vee_
!! author: MDG
!! version: 1.0
!! date: 07/20/21
!!
!! Vee (or regressive) product of two multivectors

IMPLICIT NONE

class(PGA3D_T), INTENT(IN)          :: self
type(PGA3D_T), INTENT(IN)           :: mvb
type(PGA3D_T)                       :: mvout

real(kind=dbl)                      :: a(0:15), b(0:15), c(0:15)
integer(kind=irg)                   :: i

a = self%mvec
b = mvb%mvec

c(0:15) = (/ 1*(a(15)*b(15)), -1*(a(14)*-1*b(15)+a(15)*b(14)*-1), -1*(a(13)*-1*b(15)+a(15)*b(13)*-1), &
            -1*(a(12)*-1*b(15)+a(15)*b(12)*-1), &
            -1*(a(11)*-1*b(15)+a(15)*b(11)*-1), 1*(a(10)*b(15)+a(13)*-1*b(14)*-1-a(14)*-1*b(13)*-1+a(15)*b(10)), &
            1*(a(9)*b(15)+a(12)*-1*b(14)*-1-a(14)*-1*b(12)*-1+a(15)*b(9)), &
            1*(a(8)*b(15)+a(11)*-1*b(14)*-1-a(14)*-1*b(11)*-1+a(15)*b(8)), &
            1*(a(7)*b(15)+a(12)*-1*b(13)*-1-a(13)*-1*b(12)*-1+a(15)*b(7)), &
            1*(a(6)*b(15)-a(11)*-1*b(13)*-1+a(13)*-1*b(11)*-1+a(15)*b(6)), &
            1*(a(5)*b(15)+a(11)*-1*b(12)*-1-a(12)*-1*b(11)*-1+a(15)*b(5)), &
            1*(a(4)*b(15)-a(7)*b(14)*-1+a(9)*b(13)*-1-a(10)*b(12)*-1-a(12)*-1*b(10)+a(13)*-1*b(9)-a(14)*-1*b(7)+a(15)*b(4)), &
            1*(a(3)*b(15)-a(6)*b(14)*-1-a(8)*b(13)*-1+a(10)*b(11)*-1+a(11)*-1*b(10)-a(13)*-1*b(8)-a(14)*-1*b(6)+a(15)*b(3)), &
            1*(a(2)*b(15)-a(5)*b(14)*-1+a(8)*b(12)*-1-a(9)*b(11)*-1-a(11)*-1*b(9)+a(12)*-1*b(8)-a(14)*-1*b(5)+a(15)*b(2)), &
            1*(a(1)*b(15)+a(5)*b(13)*-1+a(6)*b(12)*-1+a(7)*b(11)*-1+a(11)*-1*b(7)+a(12)*-1*b(6)+a(13)*-1*b(5)+a(15)*b(1)), &
            1*(a(0)*b(15)+a(1)*b(14)*-1+a(2)*b(13)*-1+a(3)*b(12)*-1+a(4)*b(11)*-1+a(5)*b(10)+a(6)*b(9)+a(7)*b(8)+a(8)*b(7)&
            +a(9)*b(6)+a(10)*b(5)-a(11)*-1*b(4)-a(12)*-1*b(3)-a(13)*-1*b(2)-a(14)*(-1)*b(1)+a(15)*b(0)) /)

do i=0,15
  mvout%mvec(i) = c(15-i)
end do

end function mvec_vee_

!--------------------------------------------------------------------------
recursive function mvec_inner_(self, mvb) result(mvout)
!DEC$ ATTRIBUTES DLLEXPORT :: mvec_inner_
!! author: MDG
!! version: 1.0
!! date: 07/20/21
!!
!! dot product of two multivectors

IMPLICIT NONE

class(PGA3D_T), INTENT(IN)          :: self
type(PGA3D_T), INTENT(IN)           :: mvb
type(PGA3D_T)                       :: mvout

real(kind=dbl)                      :: a(0:15), b(0:15), c(0:15)
integer(kind=irg)                   :: i

a = self%mvec
b = mvb%mvec

mvout%mvec = (/ b(0)*a(0)+b(2)*a(2)+b(3)*a(3)+b(4)*a(4)-b(8)*a(8)-b(9)*a(9)-b(10)*a(10)-b(14)*a(14), &
                b(1)*a(0)+b(0)*a(1)-b(5)*a(2)-b(6)*a(3)-b(7)*a(4)+b(2)*a(5)+b(3)*a(6)+b(4)*a(7)+b(11)*a(8) &
                +b(12)*a(9)+b(13)*a(10)+b(8)*a(11)+b(9)*a(12)+b(10)*a(13)+b(15)*a(14)-b(14)*a(15), &
                b(2)*a(0)+b(0)*a(2)-b(8)*a(3)+b(9)*a(4)+b(3)*a(8)-b(4)*a(9)-b(14)*a(10)-b(10)*a(14), &
                b(3)*a(0)+b(8)*a(2)+b(0)*a(3)-b(10)*a(4)-b(2)*a(8)-b(14)*a(9)+b(4)*a(10)-b(9)*a(14), &
                b(4)*a(0)-b(9)*a(2)+b(10)*a(3)+b(0)*a(4)-b(14)*a(8)+b(2)*a(9)-b(3)*a(10)-b(8)*a(14), &
                b(5)*a(0)-b(11)*a(3)+b(12)*a(4)+b(0)*a(5)-b(15)*a(10)-b(3)*a(11)+b(4)*a(12)-b(10)*a(15), &
                b(6)*a(0)+b(11)*a(2)-b(13)*a(4)+b(0)*a(6)-b(15)*a(9)+b(2)*a(11)-b(4)*a(13)-b(9)*a(15), &
                b(7)*a(0)-b(12)*a(2)+b(13)*a(3)+b(0)*a(7)-b(15)*a(8)-b(2)*a(12)+b(3)*a(13)-b(8)*a(15), &
                b(8)*a(0)+b(14)*a(4)+b(0)*a(8)+b(4)*a(14), &
                b(9)*a(0)+b(14)*a(3)+b(0)*a(9)+b(3)*a(14), &
                b(10)*a(0)+b(14)*a(2)+b(0)*a(10)+b(2)*a(14), &
                b(11)*a(0)+b(15)*a(4)+b(0)*a(11)-b(4)*a(15), &
                b(12)*a(0)+b(15)*a(3)+b(0)*a(12)-b(3)*a(15), &
                b(13)*a(0)+b(15)*a(2)+b(0)*a(13)-b(2)*a(15), &
                b(14)*a(0)+b(0)*a(14), &
                b(15)*a(0)+b(0)*a(15) /)

end function mvec_inner_

!--------------------------------------------------------------------------
recursive function mvec_commutator_(self, mvb) result(mvout)
!DEC$ ATTRIBUTES DLLEXPORT :: mvec_commutator_
!! author: MDG
!! version: 1.0
!! date: 07/23/21
!!
!! cross (Commutator) product of two multivectors

IMPLICIT NONE

class(PGA3D_T), INTENT(IN)          :: self
type(PGA3D_T), INTENT(IN)           :: mvb
type(PGA3D_T)                       :: mvout

mvout = self%mvec_mult_(mvb)
mvout = mvout%mvec_subtract_( mvb%mvec_mult_(self) )
mvout = mvout%mvec_muls_(0.5D0)

end function mvec_commutator_

!--------------------------------------------------------------------------
recursive function mvec_sandwich_(self, mvb) result(mvout)
!DEC$ ATTRIBUTES DLLEXPORT :: mvec_sandwich_
!! author: MDG
!! version: 1.0
!! date: 07/23/21
!!
!! sandwhich product of two multivectors

IMPLICIT NONE

class(PGA3D_T), INTENT(IN)          :: self
type(PGA3D_T), INTENT(IN)           :: mvb
type(PGA3D_T)                       :: mvout

type(PGA3D_T)                       :: p

p = self
mvout = self%mvec_mult_( mvb%mvec_mult_( p%mvec_conjugate_() ) )

end function mvec_sandwich_

!--------------------------------------------------------------------------
recursive function mvec_add_(self, mvb) result(mvout)
!DEC$ ATTRIBUTES DLLEXPORT :: mvec_add_
!! author: MDG
!! version: 1.0
!! date: 07/20/21
!!
!! add two multivectors

IMPLICIT NONE

class(PGA3D_T), INTENT(IN)          :: self
type(PGA3D_T), INTENT(IN)           :: mvb
type(PGA3D_T)                       :: mvout

mvout%mvec = self%mvec + mvb%mvec

end function mvec_add_

!--------------------------------------------------------------------------
recursive function mvec_adds_(self, s) result(mvout)
!DEC$ ATTRIBUTES DLLEXPORT :: mvec_adds_
!! author: MDG
!! version: 1.0
!! date: 07/20/21
!!
!! add a scalar to a multivector

IMPLICIT NONE

class(PGA3D_T), INTENT(IN)          :: self
real(kind=dbl), INTENT(IN)          :: s
type(PGA3D_T)                       :: mvout

mvout%mvec = self%mvec
mvout%mvec(0) = mvout%mvec(0) + s

end function mvec_adds_

!--------------------------------------------------------------------------
recursive function mvec_subtract_(self, mvb) result(mvout)
!DEC$ ATTRIBUTES DLLEXPORT :: mvec_subtract_
!! author: MDG
!! version: 1.0
!! date: 07/20/21
!!
!! add two multivectors

IMPLICIT NONE

class(PGA3D_T), INTENT(IN)          :: self
type(PGA3D_T), INTENT(IN)           :: mvb
type(PGA3D_T)                       :: mvout

mvout%mvec = self%mvec - mvb%mvec

end function mvec_subtract_

!--------------------------------------------------------------------------
recursive function mvec_smul_(a, b) result(mvout)
!DEC$ ATTRIBUTES DLLEXPORT :: mvec_smul_
!! author: MDG
!! version: 1.0
!! date: 07/20/21
!!
!! scalar times multivector

IMPLICIT NONE

real(kind=dbl), INTENT(IN)           :: a
type(PGA3D_T), INTENT(IN)            :: b
type(PGA3D_T)                        :: mvout

mvout%mvec = a * b%mvec

end function mvec_smul_

!--------------------------------------------------------------------------
recursive function mvec_muls_(self, b) result(mvout)
!DEC$ ATTRIBUTES DLLEXPORT :: mvec_muls_
!! author: MDG
!! version: 1.0
!! date: 07/20/21
!!
!! multivector times scalar

IMPLICIT NONE

class(PGA3D_T), INTENT(IN)          :: self
real(kind=dbl), INTENT(IN)          :: b
type(PGA3D_T)                       :: mvout

mvout%mvec = self%mvec * b

end function mvec_muls_

!--------------------------------------------------------------------------
recursive function mvec_norm_(self) result(n)
!DEC$ ATTRIBUTES DLLEXPORT :: mvec_norm_
!! author: MDG
!! version: 1.0
!! date: 07/21/21
!!
!! norm of a multivector

IMPLICIT NONE

class(PGA3D_T), INTENT(IN)          :: self
real(kind=dbl)                      :: n

type(PGA3D_T)                       :: b, c

b = self
c = b%mvec_mult_(b%mvec_conjugate_())
n = sqrt(abs(c%mvec(0)))

end function mvec_norm_

!--------------------------------------------------------------------------
recursive function mvec_inorm_(self) result(n)
!DEC$ ATTRIBUTES DLLEXPORT :: mvec_inorm_
!! author: MDG
!! version: 1.0
!! date: 07/21/21
!!
!! ideal norm of a multivector

IMPLICIT NONE

class(PGA3D_T), INTENT(IN)          :: self
real(kind=dbl)                      :: n

type(PGA3D_T)                       :: b, c

b = self%mvec_dual_()
c = b%mvec_mult_(b%mvec_conjugate_())
n = sqrt(abs(c%mvec(0)))

end function mvec_inorm_

!--------------------------------------------------------------------------
recursive function mvec_normalized_(self) result(mvout)
!DEC$ ATTRIBUTES DLLEXPORT :: mvec_normalized_
!! author: MDG
!! version: 1.0
!! date: 07/21/21
!!
!! normalize a multivector

IMPLICIT NONE

class(PGA3D_T), INTENT(IN)          :: self
type(PGA3D_T)                       :: mvout

mvout = self%mvec_muls_(1.D0/self%mvec_norm_())

end function mvec_normalized_

!--------------------------------------------------------------------------
recursive subroutine mvec_log_(self, pre)
!DEC$ ATTRIBUTES DLLEXPORT :: mvec_log_
!! author: MDG
!! version: 1.0
!! date: 07/20/21
!!
!! output the components of a multivector if they are non-zero

use mod_IO

IMPLICIT NONE

class(PGA3D_T), INTENT(INOUT)         :: self
character(*), INTENT(IN), OPTIONAL    :: pre

integer(kind=irg)                     :: n, i, j
real(kind=dbl)                        :: c
character(fnlen)                      :: str
character(3),parameter                :: plus = ' + '
character(3),parameter                :: minus = ' - '
character(3)                          :: sgn
character(30)                         :: entry
type(IO_T)                            :: Message

str = ''
if (present(pre)) call Message%printMessage(pre, frm="(A,' : ',$)")
do i=0,15
  c = self%mvec(i)
  if (c.ne.0.0) then
! get the sign
    sgn = plus
    if (c.lt.0.0) then
      sgn = minus
      c = -c
    end if
! create the substring entry
    entry = ''
    write (entry,"(F14.6)") c
    entry = sgn//trim(adjustl(entry))//' '//trim(adjustl(basis(i)))
! add to the output string
    call Message%printMessage(entry, frm="(A,$)")
  end if
end do

call Message%printMessage(str, frm="(A)")

end subroutine mvec_log_

end module mod_PGA3D


c       allm97, NMC published measured points Q2>0.75 GeV2
c       for values Q<1 use data of E665!
c       parameterization of F2 , according to
c       H.Abramowicz and A.Levy, hep-ph/9712415
c
c       3*10-6 < x  < 0.85, W2>3GeV2
c       0.   < Q2 < 5000 GeV2, dof=0.97
c

      SUBROUTINE f2allm(x,q2,f2a)

      IMPLICIT NONE

      REAL*8 x,q2,M22,f2a
      REAL*8 SP,AP,BP,SR,AR,BR,S,XP,XR,F2P,F2R
      REAL*8 S11,A11,B11,M12,S21,A21,B21,M02,LAM2,Q02
      REAL*8 S12,S13,A12,A13,B12,B13,S22,S23,A22,A23
      REAL*8 B22,B23,w2,w,z
      REAL*8 ALFA,XMP2
C  POMERON
      PARAMETER (
     , S11   =   0.28067, S12   =   0.22291, S13   =   2.1979,
     , A11   =  -0.0808 , A12   =  -0.44812, A13   =   1.1709,
     , B11   =   0.60243**2, B12   =   1.3754**2, B13   =   1.8439,
     , M12   =  49.457 )

C  REGGEON
      PARAMETER (
     , S21   =   0.80107, S22   =   0.97307, S23   =   3.4942,
     , A21   =   0.58400, A22   =   0.37888, A23   =   2.6063,
     , B21   =   0.10711**2, B22   =   1.9386**2, B23   =   0.49338,
     , M22   =   0.15052 )
C
      PARAMETER ( M02=0.31985, LAM2=0.065270, Q02=0.46017 +LAM2 )
      PARAMETER ( ALFA=112.2, XMP2=0.8802)

C
      W2=q2*(1./x -1.)+xmp2
      W=sqrt(w2)

C
      IF(Q2.EQ.0.) THEN
       S=0.
       Z=1.

C
C   POMERON
C
       XP=1./(1.+(W2-XMP2)/(Q2+M12))
       AP=A11
       BP=B11
       SP=S11
       F2P=SP*XP**AP
C
C   REGGEON
C
       XR=1./(1.+(W2-XMP2)/(Q2+M22))
       AR=A21
       BR=B21
       SR=S21
       F2R=SR*XR**AR
C
      ELSE
       S=LOG(LOG((Q2+Q02)/LAM2)/LOG(Q02/LAM2))
       Z=1.-X
C
C   POMERON
C
       XP=1./(1.+(W2-XMP2)/(Q2+M12))
       AP=A11+(A11-A12)*(1./(1.+S**A13)-1.)
       BP=B11+B12*S**B13
       SP=S11+(S11-S12)*(1./(1.+S**S13)-1.)
       F2P=SP*XP**AP*Z**BP
C
C   REGGEON
C
       XR=1./(1.+(W2-XMP2)/(Q2+M22))
       AR=A21+A22*S**A23
       BR=B21+B22*S**B23
       SR=S21+S22*S**S23
       F2R=SR*XR**AR*Z**BR

C
      ENDIF

      f2a = q2/(q2+m02)*(F2P+F2R)

      RETURN
      END


      subroutine tcftr(ca,n,conj)
      implicit none
      integer*4 idim
      parameter (idim=30)
      integer*4 ,intent(in):: n
      integer*4 i,ln,j,l,ka,kb,k
      complex*16 ,intent(inout):: ca(n)
      complex*16 ch,cw,cw1
      logical*4 ,intent(in):: conj
      integer*4 ,parameter ::m(1:idim)=[
     $     1,2,4,8,16,
     $     32,64,128,256,512,
     $     1024,2048,4096,8192,16384,
     $     32768,65536,131072,262144,524288,
     $     1048576,2097152,4194304,8388608,16777216,
     $     33554432,67108864,134217728,268435456,536870912]
      complex*16,parameter :: cex(1:idim)=[
     $     (-1.d0                 ,0.d0),
     $     (0.d0                  ,1.d0),
     $     (0.707106781186547524d0,0.707106781186547524d0),
     $     (0.923879532511286756d0,0.382683432365089772d0),
     $     (0.980785280403230449d0,0.195090322016128268d0),
     $     (0.995184726672196886d0,0.098017140329560602d0),
     $     (0.998795456205172393d0,0.0490676743274180143d0),
     $     (0.99969881869620422d0 ,0.024541228522912288d0),
     $     (0.999924701839144541d0,0.01227153828571992608d0),
     $     (0.999981175282601143d0,0.00613588464915447536d0),
     $     (0.999995293809576172d0,0.00306795676296597627d0),
     $     (0.99999882345170191d0 ,0.001533980186284765612d0),
     $     (0.999999705862882219d0,0.000766990318742704527d0),
     $     (0.999999926465717851d0,0.000383495187571395589d0),
     $     (0.999999981616429294d0,0.000191747597310703307d0),
     $     (0.999999995404107313d0,0.0000958737990959773459d0),
     $     (0.999999998851026828d0,0.0000479368996030668845d0),
     $     (0.999999999712756707d0,0.0000239684498084182187d0),
     $     (0.999999999928189177d0,0.00001198422490506970642d0),
     $     (0.999999999982047294d0,5.99211245264242784d-6),
     $     (0.999999999995511824d0,2.99605622633466075d-6),
     $     (0.999999999998877956d0,1.498028113169011229d-6),
     $     (0.999999999999719489d0,7.49014056584715721d-7),
     $     (0.999999999999929872d0,3.74507028292384124d-7),
     $     (0.999999999999982468d0,1.87253514146195345d-7),
     $     (0.999999999999995617d0,9.36267570730980828d-8),
     $     (0.999999999999998904d0,4.68133785365490927d-8),
     $     (0.999999999999999726d0,2.34066892682745528d-8),
     $     (0.999999999999999932d0,1.170334463413727718d-8),
     $     (0.999999999999999983d0,5.85167231706863869d-9)
     $     ]
      do 10 i=1,idim-1
        if(n .eq. m(i+1))then
          ln=i
          go to 1
        endif
 10   continue
      return
 1    j=1
      do 20 i=1,n-1
        if( j .gt. i )then
*     VOPTION NOFVAL
          ch=ca(j)
          ca(j)=ca(i)
          ca(i)=ch
        endif
        l=ln
 2      if(j .le. m(l))then
          j=j+m(l)
        else
          j=j-m(l)
          l=l-1
          go to 2
        endif
 20   continue
      do 110 i=1,ln
        cw=(1.d0,0.d0)
        cw1=merge(conjg(cex(i)),cex(i),conj)
        do 120 j=1,m(i)
*     VOPTION NOFVAL
          do 130 k=0,n-1,m(i+1)
            ka=k+j
            kb=ka+m(i)
            ch=cw*ca(kb)
            ca(kb)=ca(ka)-ch
            ca(ka)=ca(ka)+ch
 130      continue
          cw=cw*cw1
 120    continue
 110  continue
      return
      end

      subroutine trftr(a,m,conj)
      use iso_c_binding
      implicit none
      integer*4 ,intent(in):: m
      integer*4 i,i2,j2
      real*8 , target::a(0:m-1)
      real*8 pi,w,ci,si,ai2,ai21,aj2,aj21,a1
      parameter (pi=3.14159265358979324d0)
      logical*4 ,intent(in):: conj
      complex*16 , pointer ::ca(:)
      call c_f_pointer(c_loc(a),ca,[m/2])
      call tcftr(ca,m/2,conj)
      w=merge(-2.d0,2.d0,conj)*pi/m
      do i=1,m/4
        ci=cos(w*i)
        si=sin(w*i)
        i2  =i*2
        j2  =m-i2
        ai2 =a(i2)
        ai21=a(i2+1)
        aj2 =a(j2)
        aj21=a(j2+1)
        a(i2  )=.5d0*(ai2 +aj2 +ci*(ai21+aj21)+si*(ai2-aj2))
        a(j2  )=.5d0*(ai2 +aj2 -ci*(ai21+aj21)-si*(ai2-aj2))
        a(i2+1)=.5d0*(ai21-aj21+si*(ai21+aj21)-ci*(ai2-aj2))
        a(j2+1)=.5d0*(aj21-ai21+si*(ai21+aj21)-ci*(ai2-aj2))
      enddo
      a1=a(1)
      a(1)=a(0)-a1
      a(0)=a(0)+a1
      return
      end

      subroutine tftrr(a,m,conj)
c
c Inversion of trftr
c tftrr(trftr(f)) = m*f
c
      use iso_c_binding
      implicit none
      integer*4 m,i,i2,j2
      real*8 ,target:: a(0:m-1)
      real*8 pi,w,ci,si,ai2,ai21,aj2,aj21,a1
      parameter (pi=3.14159265358979324d0)
      logical*4 conj
      complex*16 ,pointer :: ca(:)
      w= merge(2.d0,-2.d0,conj)*pi/m
      do i=1,m/4
        ci=cos(w*i)
        si=sin(w*i)
        i2  =i*2
        j2  =m-i2
        ai2 =a(i2)
        ai21=a(i2+1)
        aj2 =a(j2)
        aj21=a(j2+1)
        a(i2  )=ai2 +aj2 -ci*(ai21+aj21)+si*(ai2-aj2)
        a(j2  )=ai2 +aj2 +ci*(ai21+aj21)-si*(ai2-aj2)
        a(i2+1)=ai21-aj21+si*(ai21+aj21)+ci*(ai2-aj2)
        a(j2+1)=aj21-ai21+si*(ai21+aj21)+ci*(ai2-aj2)
      enddo
      a1=a(1)
      a(1)=a(0)-a1
      a(0)=a(0)+a1
      call c_f_pointer(c_loc(a),ca,[m/2])
      call tcftr(ca,m/2,conj)
      return
      end


module energy_balance

    use iso_fortran_env, only: r64 => real64
    use globals
    use slf_threshold

    implicit none

    real(r64) ::   fcool_heat, &
                & fcool_pgas, &
                & fcool_prad, &
                & fcool_trad

contains

    pure subroutine fcool(logTemp,y,dy)

        real(r64), intent(in) :: logTemp
        real(r64), intent(out) :: y
        real(r64), intent(out), optional :: dy
        real(r64) :: xxA2kesPradk_over_mec, xx4sgT4_m_3cPrad, xx4sgT4, xxA
        real(r64) :: rho,kabs,cool
        real(r64) :: Temp

        Temp = exp(logTemp)

        rho = fcool_pgas * miu * cgs_mhydr / ( cgs_boltz * Temp )
        kabs = fkabs(rho,temp)

        xx4sgT4 = 4 * cgs_stef * Temp**4
        xx4sgT4_m_3cPrad = xx4sgT4 - 3 * cgs_c * fcool_Prad
        xxA2kesPradk_over_mec = 12 * kappa_es * fcool_prad * cgs_k_over_mec

        xxA = kabs * xx4sgT4_m_3cPrad + xxA2kesPradk_over_mec * ( Temp - fcool_Trad )

        cool = xxA * rho

        y = fcool_heat - cool

        if ( present(dy) ) then
            xxA = 4 * (xx4sgT4 - 9 * xx4sgT4_m_3cPrad / 8) * kabs &
                & + xxA2kesPradk_over_mec * Temp
            dy =  - ( rho * xxA - cool )
        end if

    end subroutine

    pure subroutine calc_compswitch(pgas, tgas, compsw)
        real(r64), intent(in) :: tgas,pgas
        real(r64), intent(out) ::compsw
        real(r64) :: rho, epsi, taues, compy, kabs

        rho =  pgas * miu * cgs_mhydr / ( cgs_boltz * tgas )

        kabs = fkabs(rho, tgas)
        epsi = kabs / (kabs + kappa_es)
        taues = (1 - epsi) / sqrt(epsi)
        compy = 4 * cgs_boltz * tgas &
            & / ( cgs_mel * cgs_c**2 ) &
            & * max( taues, taues**2 )
        compsw = thrtanh( log(compy) / log(2d0) )

    end subroutine

    pure subroutine calc_compW(heat, pgas, prad, heat_max, compw)
        real(r64), intent(in) :: heat, pgas, prad
        real(r64), intent(out) :: heat_max, compw

        heat_max = 12 * cgs_kapes * prad  &
            & * ( pgas * miu * cgs_mhydr ) &
            & / ( cgs_mel * cgs_c )

        compw = heat / ( heat_max - heat )
    end subroutine

end module


c
c	This subroutine provides polar cap densities based on IRI
c     and on the GCPM polar cap model.
c
c     D. Gallagher 08/06/2007
c
c INPUT:
c r	= radial distance (RE)
c alatr	= geomagnetic latitude in radians
c alatd	= geomagnetic latitude in degrees
c amlt	= geomagnetic local time in hours
c
c OUTPUT:
c The density bridge has the form:
c	density = exp(-2.8618*log(r)+refn)
c		where r is height in km
c refn	= this is obtained from the IRI density at 350km altitude
c		and at the latitude, L-shell, magnetic local time,
c		and local time of the point provided by the
c		empirical model user.  It is units of m-3, like the IRI
c		total electron density.
c powern = -2.8618
c refalt = reference altitude where polar cap profile and IRI are made
c          to agree
c
c The mathematical form of the density model comes from Persoon et al. and
c Chandler et al, 1991.  It approximates Alouette/ISIS, DE 1 RIMS, and DE 1
c PWI observations, while allowing for the density to rise and fall with
c the IRI model through the refn parameter.
c
	function ne_iri_cap(r,alatr,amlt,itime)
c
	real*4 alatr,along,rz12,outf(20,100),oarr(50)
	real*4 nb1,ahcrit, r
	real*4 refn,powern
	real*4 ne_iri_cap,aheight,edensity_iri
	integer*4 itime(2)
	logical jf(12)
c
c  ahcrit = center height for transition between iri and polar cap profile
c  overlap = +- range over which transition occurs
	data chrrad/2.6179939e-1/
	data ahcrit/350.0/,overlap/50.0/
	data re/6371.0/
c
	aheight=(r-1.0)*re
c setup input parameters to IRI
	along=(amlt-12.0)*chrrad
c
c	  print*,'into cap:',r,alatr,amlt,aheight,along

	if(aheight.lt. (ahcrit-overlap) ) then
c  if a low enough altitude, then will only need to get density from IRI
	  call iri_sm(alatr,along,r,itime,outf,oarr)
	  ne_iri_cap=outf(1,1)
	else
c
	  call iri_sm(alatr,along,(ahcrit+re)/re,itime,outf,oarr)
	  nb1=outf(1,1)
c
c  compute the refn parameter
c    refn=log(nb1)+2.8618*log(350)
	  refn=log(nb1)+16.764
	  powern=-2.8618
c
c aheight = height in km
c bridge density = exp(powern*log(aheight)+refn)
	  ne_iri_cap=exp(powern*log(aheight)+refn)+0.001
c	  print*,'cap setup:',nb1,refn,powern,ne_iri_cap
c
	  if(aheight.le. (ahcrit+overlap) ) then
	    call iri_sm(alatr,along,r,itime,outf,oarr)
	    edensity_iri=outf(1,1)
c
	    refhh=ahcrit
	    spred=-0.16
	    widthh=overlap
	    refh2=refhh-spred
	    refh3=refhh+spred
	    switch2=switchon(aheight,refh2,widthh)
	    switch3=switchon(aheight,refh3,widthh)
	    ne_iri_cap=edensity_iri*(1.0-switch3)+ne_iri_cap*switch2
c	  print*,'cap height trans:',edensity_iri,ne_iri_cap,switch2,switch3
	  end if
	end if
c
c	  print*,'leaving cap:',ne_iri_cap
	return
	end


!     material constant c,cpp,cuu,cup
!cccccccccccccccccccccccccc
!     oCUPP, oCUP, oCPP
!cccccccccccccccccccccccccc

subroutine r_sboc(obc,ocpp,ocuu,ocup,xmj,dxmj,ddxmj)
  use r_common, only: rc1,rc2,rk,cpre,bpre,dbpre,ddbpre
  use solid_variables, only: nsd_solid

  implicit none

  real(8) :: ocpp
  real(8) :: obc(2*nsd_solid,2*nsd_solid),xmj(3),dxmj(3,2*nsd_solid)
  real(8) :: ddxmj(3,2*nsd_solid,2*nsd_solid),ocuu(2*nsd_solid,2*nsd_solid),ocup(2*nsd_solid)

  integer :: i,j

  ocpp=-1.0d0/rk
  do i=1,2*nsd_solid
     ocup(i)=-ocpp*dbpre(i)
     do j=1,2*nsd_solid
        obc(i,j)  = rc1*ddxmj(1,i,j) + rc2*ddxmj(2,i,j) + rk*dxmj(3,i)*dxmj(3,j) + rk*ddxmj(3,i,j)*(xmj(3)-1.0d0)
        ocuu(i,j) = obc(i,j) + ocpp*dbpre(i)*dbpre(j) + ocpp*(bpre-cpre)*ddbpre(i,j)
     enddo
  enddo

  return
end subroutine r_sboc


subroutine eosread
  !-----------------------------------------------------------------------
  ! Reads the equation of state tables
  ! Updated to fortran 90 PJC 22/05/2008
  ! Extended to opacities DHF 01/09/2009
  !
  ! Note the columns (== k values) are as follows:
  !   1) density
  !   2) temperature
  !   3) internal energy
  !   4) mean molecular weight
  !	5) Mass Weighted Opacity
  !	6) Mass-weighted Opacity
  !
  !-----------------------------------------------------------------------

  use eosdata

  implicit none
  integer :: i,j,k,check
  real :: cv, gamma
  ! Open eos data file and read in values

  open(50,file="/data/dhf3/programs/sphng_tau_calculator/myeos.dat", &
       status='old',iostat=check,action='read')
  if (check /= 0) then
     print*, 'Input file myeos.dat not found'
     stop
  endif
  print*, "Reading equation of state tables"

  read(50,*) nrhopoints, nUpoints

  ! Allocate input data array
  allocate(eostable(nrhopoints,nUpoints,6))
  allocate(cstab(nrhopoints,nUpoints))
  do i = 1,nrhopoints
     do j = 1,nUpoints
        read(50,*) (eostable(i,j,k),k=1,6)

        !	Now calculate sound speed values for interpolation
	cv = eostable(i,j,3)/eostable(i,j,2)
	gamma = 1.0d0 + (Boltzmannk / &
             (mH*eostable(i,j,4)*cv))
	cstab(i,j) = sqrt(gamma*(gamma-1.0)*eostable(i,j,3))
     enddo
  enddo
  close(50)

  print*, "Equation of state tables read in successfully"
  print*, "-----------------------------------------------"

  return
end subroutine eosread


!================================================================
!================================================================
!================================================================
!================================================================
subroutine condinit(x,u,dx,nn)
  use amr_parameters
  use hydro_parameters
  implicit none
  integer ::nn                            ! Number of cells
  real(dp)::dx                            ! Cell size
  real(dp),dimension(1:nvector,1:nvar)::u ! Conservative variables
  real(dp),dimension(1:nvector,1:ndim)::x ! Cell center position.
  !================================================================
  ! This routine generates initial conditions for RAMSES.
  ! Positions are in user units:
  ! x(i,1:3) are in [0,boxlen]**ndim.
  ! U is the conservative variable vector. Conventions are here:
  ! U(i,1): d, U(i,2:ndim+1): d.u,d.v,d.w and U(i,ndim+2): E.
  ! Q is the primitive variable vector. Conventions are here:
  ! Q(i,1): d, Q(i,2:ndim+1):u,v,w and Q(i,ndim+2): P.
  ! If nvar >= ndim+3, remaining variables are treated as passive
  ! scalars in the hydro solver.
  ! U(:,:) and Q(:,:) are in user units.
  !================================================================
  integer::ivar,i
  real(dp),dimension(1:nvector,1:nvar),save::q   ! Primitive variables
  real(dp)::scale_nH,scale_T2,scale_l,scale_d,scale_t,scale_v, r
  real(dp),parameter::n0=3.2, r0=0.0915 !cm-2 and kpc

  ! Call built-in initial condition generator
  call region_condinit(x,q,dx,nn)

  ! Add here, if you wish, some user-defined initial conditions
  ! ........

  ! Iliev7_profile patch -------------------------------------------------
  ! setup of a density profile for test 6 in Iliev's
  ! comparison project, w. 100K temperature everywhere.
  ! the profile is:
  !                        /  n0               if   r<=r0
  !                n(r) = |
  !                        \  n0(r/r0)**-2     if   r>=r0
  ! Conversion factor from user units to cgs units
  call units(scale_l,scale_t,scale_d,scale_v,scale_nH,scale_T2)
  do i=1,nn
     r=sqrt(x(i,1)**2+x(i,2)**2+x(i,3)**2)! radius from origin in kpc
     if(r .le. r0) then
        q(i,1) = n0/scale_nH
     else
        q(i,1) = n0 * (r0/r)**2 /scale_nH
     endif
     q(i,ndim+2) = 100./scale_T2 * q(i,1)
  end do
  ! Iliev7_profile patch end ---------------------------------------------

  ! Convert primitive to conservative variables
  ! density -> density
  u(1:nn,1)=q(1:nn,1)
  ! velocity -> momentum
  u(1:nn,2)=q(1:nn,1)*q(1:nn,2)
#if NDIM>1
  u(1:nn,3)=q(1:nn,1)*q(1:nn,3)
#endif
#if NDIM>2
  u(1:nn,4)=q(1:nn,1)*q(1:nn,4)
#endif
  ! kinetic energy
  u(1:nn,ndim+2)=0.0d0
  u(1:nn,ndim+2)=u(1:nn,ndim+2)+0.5*q(1:nn,1)*q(1:nn,2)**2
#if NDIM>1
  u(1:nn,ndim+2)=u(1:nn,ndim+2)+0.5*q(1:nn,1)*q(1:nn,3)**2
#endif
#if NDIM>2
  u(1:nn,ndim+2)=u(1:nn,ndim+2)+0.5*q(1:nn,1)*q(1:nn,4)**2
#endif
  ! pressure -> total fluid energy
  u(1:nn,ndim+2)=u(1:nn,ndim+2)+q(1:nn,ndim+2)/(gamma-1.0d0)
#if NVAR > NDIM + 2
  ! passive scalars
  do ivar=ndim+3,nvar
     u(1:nn,ivar)=q(1:nn,1)*q(1:nn,ivar)
  end do
#endif

end subroutine condinit