#include "real.h"
module mod_init_disp_sinwave
use mod_grid
use mod_rwg
implicit none

real(kind=8), private :: T = 20.0d0 ! [s]
real(kind=8), private :: a = 0.03d0 ! [m]
integer(kind=4), private :: x_index = 0
integer(kind=4), private :: y_index = 0
! === FILE INPUT ===============================================================
character(len=64), private :: input_file = ''
real(kind=REAL_BYTE), private, allocatable, dimension(:) :: tlist, hlist
! === DEBUG for restart with sinwave/file-input 2016/02/18 =====================
!integer(kind=4), private :: lcount = 0, ccount = 0
integer(kind=4), private :: lcount = 0
integer(kind=4) :: ccount = 0
! ==============================================================================
! ==============================================================================

real(kind=8), private :: pi

contains

#ifndef MULTI
   subroutine specify_sinwave_params(file)
#else
   subroutine specify_sinwave_params(input_dirname, file)
#endif
      character(len=256), intent(in) :: file
#ifdef MULTI
      character(len=128), intent(in) :: input_dirname
      character(len=256) :: file_multi
#endif
! === FILE INPUT ===============================================================
!     namelist /sinwave/ T, a, x_index, y_index
      real(kind=REAL_BYTE) :: t_in, h_in
      namelist /sinwave/ T, a, x_index, y_index, input_file
! ==============================================================================

#ifndef MULTI
      open(1,file=trim(file),action='read',status='old',form='formatted')
#else
      file_multi = trim(input_dirname) // trim(file)
      open(1,file=trim(file_multi),action='read',status='old',form='formatted')
#endif
      read(1,sinwave)
      close(1)

! === FILE INPUT ===============================================================
      if(input_file == '') then
! ==============================================================================
         write(6,'(a)') '============================================================'
         write(6,'(a)') '=== Check Sin Wave initialization! [Begin] ================='
         write(6,'(a)') '============================================================'
         write(6,'(a,a)') '- Filename: ', trim(file)
         write(6,'(a,f15.6)') '- Cycle[s] (T):       ', T
         write(6,'(a,f15.6)') '- Wave height[m] (a): ', a
         write(6,'(a,i8)')    '- X-index (x_index):  ', x_index
         write(6,'(a,i8)')    '- Y-index (y_index):  ', y_index
         write(6,'(a)') '============================================================'
         write(6,'(a)') '=== Check Sin Wave initialization! [End] ==================='
         write(6,'(a)') '============================================================'

         pi = 2.0d0*dasin(1.0d0)
! === FILE INPUT ===============================================================
      else
         write(6,'(a)') '============================================================'
         write(6,'(a)') '=== Check Sin Wave initialization! [Begin] ================='
         write(6,'(a)') '============================================================'
         write(6,'(a,a)') '- Filename: ', trim(file)
         write(6,'(a,a)')     '- Input File (input_file): ', trim(input_file)
         write(6,'(a,i8)')    '- X-index (x_index):       ', x_index
         write(6,'(a,i8)')    '- Y-index (y_index):       ', y_index
         write(6,'(a)') '============================================================'
         write(6,'(a)') '=== Check Sin Wave initialization! [End] ==================='
         write(6,'(a)') '============================================================'

#ifndef MULTI
         open(1,file=trim(input_file),action='read',status='old',form='formatted')
#else
         file_multi = trim(input_dirname) // trim(input_file)
         open(1,file=trim(file_multi),action='read',status='old',form='formatted')
#endif

         lcount=0
         do
            read(1, *, end=100, err=200) t_in, h_in
            lcount = lcount+1
200         continue
         end do
100      continue

         allocate(hlist(lcount)); hlist = 0.0d0
         allocate(tlist(lcount)); tlist = 0.0d0

         rewind(1)
         lcount=0
         do
            read(1, *, end=101, err=201) t_in, h_in
            lcount = lcount+1
            hlist(lcount) = h_in
            tlist(lcount) = t_in
201         continue
         end do
101      continue
      end if
! ==============================================================================

      return
   end subroutine specify_sinwave_params

#ifndef MPI
   subroutine hrise_rwg_sin(wfld,time,nlon,nlat)
#else
   subroutine hrise_rwg_sin(wfld,time,nlon,nlat,kx,ky)
#endif
      type(wave_arrays), target, intent(inout) :: wfld
      real(kind=REAL_BYTE), intent(in) :: time
      integer(kind=4), intent(in) :: nlon, nlat
#ifdef MPI
      integer(kind=4), intent(in) :: kx, ky
#endif

      real(kind=REAL_BYTE), pointer, dimension(:,:) :: hz
      integer(kind=4) :: i, j
#ifdef MPI
      integer(kind=4) :: ig, jg
#endif

      hz => wfld%hz

! === FILE INPUT ===============================================================
      if(lcount == 0) then
! ==============================================================================
#ifndef MPI
         if(x_index /= 0) then
            i = x_index
!$omp parallel do
            do j = 1, nlat
               hz(i,j) = a*dsin(2.0d0*pi/T*time)
            end do
         end if

         if(y_index /= 0) then
            j = y_index
!$omp parallel do
            do i = 1, nlon
               hz(i,j) = a*dsin(2.0d0*pi/T*time)
            end do
         end if
#else
         if(x_index /= 0) then
            do i = 1, nlon
               ig = kx+i-1
               if(ig == x_index) then
!$omp parallel do
                  do j = 1, nlat
                     hz(i,j) = a*dsin(2.0d0*pi/T*time)
                  end do
               end if
            end do
         end if

         if(y_index /= 0) then
            do j = 1, nlat
               jg = ky+j-1
               if(jg == y_index) then
!$omp parallel do
                  do i = 1, nlon
                     hz(i,j) = a*dsin(2.0d0*pi/T*time)
                  end do
               end if
            end do
         end if
#endif
! === FILE INPUT ===============================================================
      else
         ccount = ccount + 1
         if(ccount > lcount) return
!        write(6,'(i8,3e15.6)') ccount, time, tlist(ccount), hlist(ccount)
#ifndef MPI
         if(x_index /= 0) then
            i = x_index
!$omp parallel do
            do j = 1, nlat
               hz(i,j) = hlist(ccount)
            end do
         end if

         if(y_index /= 0) then
            j = y_index
!$omp parallel do
            do i = 1, nlon
               hz(i,j) = hlist(ccount)
            end do
         end if
#else
         if(x_index /= 0) then
            do i = 1, nlon
               ig = kx+i-1
               if(ig == x_index) then
!$omp parallel do
                  do j = 1, nlat
                    hz(i,j) = hlist(ccount)
                  end do
               end if
            end do
         end if

         if(y_index /= 0) then
            do j = 1, nlat
               jg = ky+j-1
               if(jg == y_index) then
!$omp parallel do
                  do i = 1, nlon
                     hz(i,j) = hlist(ccount)
                  end do
               end if
            end do
         end if
#endif
      end if
! ==============================================================================

      return
   end subroutine hrise_rwg_sin

end module mod_init_disp_sinwave


program hm_2bands_bethe
  USE DMFT_FULL_ED
  USE SCIFOR
  USE DMFT_TOOLS
  implicit none
  integer                                     :: iloop,Nb,Le,Nso
  logical                                     :: converged
  !Bath:
  real(8),allocatable                         :: Bath(:),Bath_(:)
  !
  real(8),dimension(2)                        :: Wband
  complex(8),allocatable                      :: Hloc(:,:,:,:)
  real(8),dimension(:,:),allocatable          :: Dbands
  real(8),dimension(:,:),allocatable          :: Ebands
  real(8),dimension(:),allocatable            :: H0,de
  real(8)                                     :: Delta
  complex(8),allocatable,dimension(:,:,:,:,:) :: Weiss,Smats,Sreal,Gmats,Greal
  character(len=16)                           :: finput
  real(8)                                     :: wmixing,Eout(2)

  call parse_cmd_variable(finput,"FINPUT",default='inputED.in')
  call parse_input_variable(Le,"LE",finput,default=500)
  call parse_input_variable(Wband,"WBAND",finput,default=[1d0,1d0])
  call parse_input_variable(delta,"DELTA",finput,default=0d0)
  call parse_input_variable(wmixing,"WMIXING",finput,default=0.5d0)
  !
  call ed_read_input(trim(finput))

  !Add DMFT CTRL Variables:
  call add_ctrl_var(Norb,"norb")
  call add_ctrl_var(Nspin,"nspin")
  call add_ctrl_var(beta,"beta")
  call add_ctrl_var(xmu,"xmu")
  call add_ctrl_var(wini,'wini')
  call add_ctrl_var(wfin,'wfin')
  call add_ctrl_var(eps,"eps")

  if(Nspin/=1.OR.Norb/=2)stop "Wrong setup from input file: Nspin=1; Norb=2"
  Nso=Nspin*Norb

  allocate(Ebands(Nso,Le))
  allocate(Dbands(Nso,Le))
  allocate(de(Nso))
  Ebands(1,:) = linspace(-Wband(1),Wband(1),Le,mesh=de(1))
  Ebands(2,:) = linspace(-Wband(2),Wband(2),Le,mesh=de(2))
  !
  Dbands(1,:) = dens_bethe(Ebands(1,:),Wband(1))*de(1)
  Dbands(2,:) = dens_bethe(Ebands(2,:),Wband(2))*de(2)
  !
  allocate(H0(Nso))
  H0=[-Delta/2,Delta/2]
  call TB_write_Hloc(one*diag(H0))

  !Allocate Weiss Field:
  allocate(Weiss(Nspin,Nspin,Norb,Norb,Lmats))
  allocate(Smats(Nspin,Nspin,Norb,Norb,Lmats))
  allocate(Gmats(Nspin,Nspin,Norb,Norb,Lmats))
  allocate(Sreal(Nspin,Nspin,Norb,Norb,Lreal))
  allocate(Greal(Nspin,Nspin,Norb,Norb,Lreal))
  allocate(Hloc(Nspin,Nspin,Norb,Norb))
  Hloc(1,1,:,:)=diag(H0)

  !setup solver
  Nb=get_bath_dimension()
  allocate(bath(Nb))
  allocate(bath_(Nb))
  call ed_init_solver(bath,Hloc)

  !DMFT loop
  iloop=0;converged=.false.
  do while(.not.converged.AND.iloop<nloop)
     iloop=iloop+1
     call start_loop(iloop,nloop,"DMFT-loop")
     !
     !Solve the EFFECTIVE IMPURITY PROBLEM (first w/ a guess for the bath)
     call ed_solve(bath)
     call ed_get_sigma_matsubara(Smats)
     call ed_get_sigma_real(Sreal)
     !
     ! compute the local gf:
     call dmft_gloc_matsubara(Ebands,Dbands,H0,Gmats,Smats,iprint=1)
     !
     !Get the Weiss field/Delta function to be fitted
     if(cg_scheme=='weiss')then
        call dmft_weiss(Gmats,Smats,Weiss,Hloc,iprint=1)
     else
        call dmft_delta(Gmats,Smats,Weiss,Hloc,iprint=1)
     endif
     !
     !
     !Perform the SELF-CONSISTENCY by fitting the new bath
     call ed_chi2_fitgf(Weiss,bath,ispin=1)
     !
     !MIXING:
     if(iloop>1)Bath = wmixing*Bath + (1.d0-wmixing)*Bath_
     Bath_=Bath

     !Check convergence (if required change chemical potential)
     converged = check_convergence(Weiss(1,1,1,1,:),dmft_error,nsuccess,nloop,reset=.false.)
     !
     call end_loop
  enddo

  call dmft_gloc_realaxis(Ebands,Dbands,H0,Greal,Sreal,iprint=1)
  call dmft_kinetic_energy(Ebands,Dbands,H0,Smats(1,1,:,:,:))

contains

  function dens_flat(ebands,wband) result(dens)
    real(8),dimension(:)            :: ebands
    real(8)                         :: wband
    real(8),dimension(size(ebands)) :: dens
    integer                         :: i
    real(8)                         :: e
    do i=1,size(ebands)
       e=ebands(i)
       dens(i)= step(wband-abs(e))/(2*wband)
    enddo
  end function dens_flat

end program hm_2bands_bethe


C................................................................       SOL   10
      SUBROUTINE SOLUTN(X, Z, DMVAL)                                    SOL   20
      implicit real*8 (a-h, o-z)
      COMMON /p3/ EN, S, EL, CONS
      REAL*8 Z(5), DMVAL(2)
      EX = EXP(-EL*X)
      Z(1) = 1. - EX
      Z(2) = EL*EX
      Z(3) = -EL**2*X**2*EX
      Z(4) = (EL**3*X**2-2.*EL**2*X)*EX
      Z(5) = (-EL**4*X**2+4.*EL**3*X-2.*EL**2)*EX
      DMVAL(1) = -EL*Z(2)
      DMVAL(2) = (EL**5*X*X-6.*EL**4*X+6.*EL**3)*EX
      RETURN
      END


module hamiltonian

  use precision
  use mpi
  use globals
  use fft
  use misc
  use potential

  implicit none

contains

  function f_hamiltonian(wavefn, nl, nu) result(hamiltonian)

    !
    ! This function computes the hamiltonian of a wave function
    !

    integer(idp), dimension(2), intent(in) :: nl, nu
    complex(cdp), dimension(nl(1):nu(1), nl(2):nu(2)), intent(in) ::&
         & wavefn
    complex(cdp), dimension(nl(1):nu(1), nl(2):nu(2)) :: hamiltonian

    complex(cdp), dimension(:, :), allocatable, save :: del2, pot,&
         & delwavefnx, delwavefny, delwavefn, delx, dely, delxy,&
         & vecpotfn2
    real(fdp), dimension(:, :), allocatable, save :: vecpotfnx,&
         & vecpotfny, vecpotfn
    integer(idp), dimension(dim), save :: nlold = 0, nuold = 0
    logical, save :: defvecpot = .false., defpot = .false., defdel =&
         & .false.

    !
    ! If the space size changes, deallocate all the stored function
    !

    if (nlold(1) /= nl(1) .or. nlold(2) /= nl(2) .or. nuold(1) /=&
         & nu(1) .or. nuold(2) /= nu(2)) then

       if (defdel) then

          deallocate(del2)

          defdel = .false.

       end if

       if (defvecpot) then

          select case (parameters%gauge)

          case('(-y,0,0)')
             deallocate(delx, vecpotfny, vecpotfn2, delwavefnx)

          case('(-y,x,0)')

             deallocate(delx, dely, vecpotfnx,  vecpotfny, delwavefnx&
                  &, delwavefny, vecpotfn2)

          case('(x-y,x-y,0)', 'fft')
             deallocate(delxy, vecpotfn,  delwavefn, vecpotfn2)

          end select

          defvecpot = .false.

       end if

       if (defpot) then

          deallocate(pot)

          defpot = .false.

       end if

       nlold = nl
       nuold = nu

    end if

    !
    ! If the required function are not allocated and computed,
    ! allocate them and compute them
    !

    if (.not. defdel) then

       allocate(del2(nl(1):nu(1), nl(2):nu(2)))

       call s_momentumfac(del2, nl, nu, (/ 1.0d0, 1.0d0 /)&
            &/dble(product(parameters%n)), (/ 2, 2 /))

       !
       ! Include terms for speed
       !

       del2 = - del2 * hbar**2 / 2.0d0 / parameters%mass

       defdel = .true.

    end if

    if (defined_parameters%potential .and. (.not. defpot) .and.&
         & (.not. defvecpot)) then

       !
       ! Define the potential
       !

       allocate(pot(nl(1):nu(1), nl(2):nu(2)))

       call s_setpotential(pot, nl, nu)

       !
       ! Save the potential to disk for plotting
       !

       if (parameters%plotpot) then

          call s_write2drarray(real(pot), nl, nu, filename='rpot',&
               & incboundary=.true.)
          call s_write2drarray(aimag(pot), nl, nu, filename='ipot',&
               & incboundary=.true.)

       end if

       defpot = .true.

    end if

    if (defined_parameters%externalb .and. (.not. defvecpot) ) then

       select case (parameters%gauge)

       case('(-y,0,0)')

          allocate(delx(nl(1):nu(1), nl(2):nu(2)),&
               & vecpotfny(nl(1):nu(1), nl(2):nu(2)),&
               & vecpotfn2(nl(1):nu(1), nl(2):nu(2)),&
               & delwavefnx(nl(1):nu(1), nl(2):nu(2)))

          call s_bpoty(delx, vecpotfny, vecpotfn2, nl, nu)

       case('(-y,x,0)')

          allocate(delx(nl(1):nu(1), nl(2):nu(2)), dely(nl(1):nu(1),&
               & nl(2):nu(2)), vecpotfnx(nl(1):nu(1), nl(2):nu(2)),&
               & vecpotfny(nl(1):nu(1), nl(2):nu(2)),&
               & vecpotfn2(nl(1):nu(1), nl(2):nu(2)),&
               & delwavefnx(nl(1):nu(1), nl(2):nu(2)),&
               & delwavefny(nl(1):nu(1), nl(2):nu(2)))

          call s_bpotyx(delx, dely, vecpotfnx, vecpotfny, vecpotfn2,&
               & nl, nu)

       case('(x-y,x-y,0)')
          allocate(delxy(nl(1):nu(1), nl(2):nu(2)),&
               & vecpotfn(nl(1):nu(1), nl(2):nu(2)),&
               & vecpotfn2(nl(1):nu(1), nl(2):nu(2)),&
               & delwavefn(nl(1):nu(1), nl(2):nu(2)))

          call s_bpotxyxy(delxy, vecpotfn, vecpotfn2, nl, nu)

       case('fft')
          allocate(delxy(nl(1):nu(1), nl(2):nu(2)),&
               & vecpotfn(nl(1):nu(1), nl(2):nu(2)),&
               & vecpotfn2(nl(1):nu(1), nl(2):nu(2)),&
               & delwavefn(nl(1):nu(1), nl(2):nu(2)))

          call s_bpotfft(delxy, vecpotfn, vecpotfn2, nl, nu)

       end select

       defvecpot = .true.

       if (defpot) then

          vecpotfn2 = vecpotfn2 + pot

          deallocate(pot)

          defpot = .false.

       end if

    end if

    !
    ! Compute the derivatives of the wavefn
    !

    hamiltonian = wavefn

    call s_c2dfft(hamiltonian, nl, nu, fftfor)

    if (defined_parameters%externalb) then

       select case (parameters%gauge)

       case('(-y,0,0)')
          delwavefnx = hamiltonian*delx

          call s_c2dfft(delwavefnx, nl, nu, fftbac)

       case('(-y,x,0)')
          delwavefnx = hamiltonian*delx
          delwavefny = hamiltonian*dely

          call s_c2dfft(delwavefnx, nl, nu, fftbac)
          call s_c2dfft(delwavefny, nl, nu, fftbac)

       case('(x-y,x-y,0)', 'fft')
          delwavefn = hamiltonian*delxy

          call s_c2dfft(delwavefn, nl, nu, fftbac)

       end select

    end if

    hamiltonian = hamiltonian*del2

    call s_c2dfft(hamiltonian, nl, nu, fftbac)

    !
    ! Build up the hamiltonian from its various bits
    !

    if (defined_parameters%externalb .and. defvecpot) then

       select case (parameters%gauge)

       case('(-y,0,0)')
          hamiltonian = hamiltonian + vecpotfny*delwavefnx +&
               & vecpotfn2*wavefn

       case('(-y,x,0)')
          hamiltonian = hamiltonian + vecpotfnx*delwavefny +&
               & vecpotfny*delwavefnx + vecpotfn2*wavefn

       case('(x-y,x-y,0)', 'fft')
          hamiltonian = hamiltonian + vecpotfn*delwavefn + vecpotfn2&
               &*wavefn

       end select

    end if

    if (defined_parameters%potential .and. defpot) then

       hamiltonian = hamiltonian + pot*wavefn

    end if

    !
    ! If we have a magnetic field, ensure the boundary of the wave
    ! function
    ! is zero.  This is a nasty hack, but I think required.
    ! Hopefully it
    ! will make this work well for magnetic fields.
    !

    if(defined_parameters%externalb) then

       call s_smoothedge(hamiltonian, nl, nu, parameters%smooth)

    end if

  end function f_hamiltonian

  function f_wavefnenergy(wavefn, nl, nu) result(energy)

    !
    ! this module calculates the energy of a function
    !

    integer(idp), dimension(dim), intent(in) :: nl, nu
    complex(cdp), dimension(nl(1):nu(1), nl(2):nu(2)), intent(in) ::&
         & wavefn
    real(fdp) :: energy

    !
    !  Compute the hamiltonian
    !

    energy = f_norm(real(conjg(wavefn)*f_hamiltonian(wavefn, nl, nu))&
         &, nl, nu)

  end function f_wavefnenergy

end module hamiltonian


      COMPLEX*16 FUNCTION D040(Q2,P2,MW2,MT2)
*
* This is D0(0,0,0,0,Q2,P2;MW2,0,MW2,MT2)
*
      IMPLICIT NONE
      REAL*8 Q2,P2
      COMPLEX*16 MW2,MT2,SQRT,XSPENZ
      COMPLEX*16 SQW,SQB,X1,X2,X3,X4,X1B,X2B
      COMPLEX*16 Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y8,Y9,Y10,Y11,Y12,Y13,Y14,Y15,Y16
*
      SQW=SQRT(1D0+4D0*MW2/Q2)
      SQB=SQRT(1D0+4D0*MW2/Q2*P2*(MT2+P2-MW2)/(MT2+P2)**2)
      X1 =1D0/2D0*(1D0-SQW)
      X2 =1D0/2D0*(1D0+SQW)
      X3 =1D0/(1D0-MW2/MT2)
      X4 =1D0/(1D0-MW2/(MT2+P2))
      X1B=X4/2D0*(1D0-SQB)
      X2B=X4/2D0*(1D0+SQB)
*
      Y1 =X1/X1B
      Y3 =X2/X1B
      Y5 =X4/X1B
      Y7 =X3/X1B
      Y9 =X1/X2B
      Y11=X2/X2B
      Y13=X4/X2B
      Y15=X3/X2B
      Y2 =(X1-1D0)/(X1B-1D0)
      Y4 =(X2-1D0)/(X1B-1D0)
      Y6 =(X4-1D0)/(X1B-1D0)
      Y8 =(X3-1D0)/(X1B-1D0)
      Y10=(X1-1D0)/(X2B-1D0)
      Y12=(X2-1D0)/(X2B-1D0)
      Y14=(X4-1D0)/(X2B-1D0)
      Y16=(X3-1D0)/(X2B-1D0)
*
      D040=1D0/(Q2*(MT2+P2)*SQB)*(
     &     +XSPENZ(1D0/(1D0-Y1 ))-XSPENZ(1D0/(1D0-Y2 ))
     &     +XSPENZ(1D0/(1D0-Y3 ))-XSPENZ(1D0/(1D0-Y4 ))
     &     +XSPENZ(1D0/(1D0-Y5 ))-XSPENZ(1D0/(1D0-Y6 ))
     &     -XSPENZ(1D0/(1D0-Y7 ))+XSPENZ(1D0/(1D0-Y8 ))
     &     -XSPENZ(1D0/(1D0-Y9 ))+XSPENZ(1D0/(1D0-Y10))
     &     -XSPENZ(1D0/(1D0-Y11))+XSPENZ(1D0/(1D0-Y12))
     &     -XSPENZ(1D0/(1D0-Y13))+XSPENZ(1D0/(1D0-Y14))
     &     +XSPENZ(1D0/(1D0-Y15))-XSPENZ(1D0/(1D0-Y16))
     &                           )
*
      RETURN
      END


c
c   Subroutine to find the JH2 yield stress, which is dependent on
c   pressure, strain rate and damage accumulated. All values are
c   normalized with respect to the HEL (stress wrt SHEL, pressure
c   wrt PHEL).
c
c   inputs
c   ======
c   epd = equivalent strain rate         (history var)
c   P = current hydrostatic pressure     (history var)
c   D = current damage                   (history var)
c   A = intact strength coefficient      (JH2 param.)
c   B = fractured strength coefficient   (JH2 param.)
c   c = strain rate coefficient          (JH2 param.)
c   n = intact strength exponent         (JH2 param.)
c   m = fractured strength exponent      (JH2 param.)
c   EPSI = quasi-static threshold s.rate (JH2 param.)
c   T = hydrostatic pressure to failure  (JH2 param.)
c   SFmax = maximum failure strength     (JH2 param.)
c   PHEL = Pressure comp. of HEL         (JH2 param.)
c   SHEL = Deviatoric comp. of HEL       (JH2 param.)
c
c   outputs
c   =======
c   syield = yield stress
c
        subroutine JH2_yield (
     &             epd,P,D,A,B,c,m,n,EPSI,T,SFmax,HEL,PHEL,syield)
c
         implicit none
         double precision, intent (in) :: epd,P,D,A,B,c,n,m,T,
     &                                    SFmax,HEL,PHEL,EPSI
         double precision, intent (inout) :: syield
         double precision :: si, sf, Ps, Ts, es, SHEL
c
c        Find normalized pressure and tensile strength constant (wrt PHEL)
c        =================================================================
         Ps = P / PHEL
         Ts = T / PHEL
         SHEL = 1.5_8 * (HEL - PHEL)
c
c        Find normalized strain rate (wrt EPSI) and find strain rate term
c        ================================================================
c         es = 1.0_8+c*log(epd/EPSI)
          es = 1.0_8
c
c        Find normalized strength at D=0 (si) , D=1 (sf)
c        ===============================================
         if ((Ps+Ts).gt.0.0_8) then
             si = A * (Ps+Ts) ** n
         else
             si = 0.0_8
         end if
c
         if (Ps.gt.0.0_8) then
             sf = B * Ps ** m
         else
             sf = 0.0_8
         end if
c
c        Check if normalized fractured strength exceeds SFmax, if so sf=SFmax
c        ====================================================================
         if (sf.GT.SFmax) then
            sf = SFmax
         end if
c
c        Calculate flow stress based on si, sf and damage
c        ================================================
         syield = SHEL * (si - D*si + D*sf)
c
         return
c
        end subroutine JH2_yield
c
c  Subroutine to calculate equivalent stress as well as normals
c  required for the plastic loop
c
c  inputs
c  ======
c  A = input tensor
c  cflag = changes outputs of the function (note only cflag=2 is implemented to date)
c
c  outputs
c  =======
c  seq = von Mises stress as output
c  s1d = 1st derivatives of Seq wrt S (is the nomal tensor in case of von Mises)
c  s2d = 2nd derivatives of Seq	wrt S (apparently used for implicit formulations, not implemented here)
c
c
        subroutine vm_box (A, cflag, seq, s1d, s2d)
c
         implicit none
         double precision, intent (in) :: A(9)
         double precision, intent (out) :: seq, s1d(9), s2d(9,9)
         double precision :: S(9),vm
         integer, intent(in) :: cflag
c
c
          call VMS (A,seq)
          vm = seq
          if (seq.lt.1e-20) then
             vm = 1e-20
          end if
c
         s1d = 0.0_8
         s2d = 0.0_8

         if (cflag.eq.2) then
            call A2S (A,S)
            s1d = (1.5_8/vm)*S
         else if (cflag.eq.3) then
         else
         end if
c
         return
c
        end subroutine vm_box
c
c
c
c  inputs
c  ======
c  P = hydrostatic pressure
c  D = damage
c  A = intact strength coefficent
c  B = damaged strength coefficient
c  M = damaged strength exponent
c  N = intact strength exponent
c  HEL = hugoniot elastic limit
c  PHEL = hydrostatic pressure at HEL
c  Lel = elastic tensor
c  N = normal vector (from vm_box)
c  D1 = damage accumulation coefficient
c  D2 = damage accumulation exponent
c
c  outputs
c  =======
c  h = hardening rate (ds_bar/dep)
c
        subroutine JH2_hardening
     &  (epd,P,D,A,B,c,M,N,T,HEL,PHEL,SFmax,EPSI,Lel,NOR,D1,D2,h)

c
          implicit none
          double precision, intent (in) :: epd,P,D,A,B,c,M,N,T
          double precision, intent (in) :: HEL,PHEL,SFmax,EPSI
          double precision, intent (in) :: Lel(9,9), NOR(9), D1, D2
          double precision, intent (inout) :: h
          double precision :: es, si, sf, ef, Ps, Ts, SHEL
          double precision :: alp, bet, kap, KIJ(9), LK(9), NLK
          double precision :: x,y,z
c
c
c        Find normalized pressure and tensile strength constant (wrt PHEL)
c        =================================================================
         Ps = P / PHEL
         Ts = T / PHEL
         SHEL = 1.5 * (HEL - PHEL)
c
c        Find normalized strain rate (wrt EPSI) and find strain rate term
c        ================================================================
         es = 1.0_8+c*log(epd/EPSI)
c
c        Find normalized strength at D=0 (si) , D=1 (sf)
c        ===============================================
         if (Ps+Ts.gt.0.0_8) then
             si = A * (Ps+Ts) ** N
         else
             si = 0.0_8
         end if
c
         if (Ps.gt.0.0_8) then
             sf = B * Ps ** M
         else
             sf = 0.0_8
         end if
c
c        Check if normalized fractured strength exceeds SFmax, if so sf=SFmax
c        ====================================================================
         if (sf.GT.SFmax) then
             sf = SFmax
         end if
c
c        Find failure strain at given pressure
c        =====================================
         if ((Ps+Ts).gt.0.0) then
             ef = D1 * (Ps+Ts) ** D2
         else
             ef = 1e-20_8
         end if
c
c        Find intermediates to find total derivative
c        ===========================================
         call KD (KIJ)
         call tc_4d2 (Lel,KIJ,LK)
         call tc_2d2 (N,LK,NLK)
         kap =  NLK / 3.0_8
         if ((Ps+Ts).gt.0.0_8) then
             alp = SHEL/PHEL * A * N * (Ps+Ts)**(N-1.0_8)
         else
             alp = 0.0_8
         end if
c
         if (Ps.gt.0.0_8) then
             bet = SHEL/PHEL * B * M * (Ps)**(M-1.0_8)
         else
             bet = 0.0_8
         end if
c
         x = (1.0_8-D)*alp*kap
         y = D*bet*kap
         z = SHEL*(sf-si)/ef
         if ((D.lt.0.001).or.(D.gt.0.9999)) then
            z = 0.0_8
         end if
         h = x+y+z
         if (DABS(h).lt.1e-20_8) then
             h = 1e-20
         end if
c
         return
c
        end subroutine JH2_hardening
c
c
        subroutine umat_JH2 (cm, Sio, Dio, hisv, tt, dt, efail)
c
          implicit none
          double precision, intent (in) :: cm (*), Dio (*), tt, dt
          integer, intent (inout) :: efail
          double precision, intent (inout) :: Sio (*), hisv (*)
          double precision :: L4 (9,9), strial (9), dsig(9), E, v
          double precision :: seq, sbar, h, sflow, NOR(9), ph (9,9)
          double precision :: LN (9), NLN, pl_corr(9), SHEL, syield
          double precision :: MID,RO,G,A,B,C,M,N,EPSI,T,SFmax,HEL,PHEL
          double precision :: BETA, D1, D2, K1, K2, K3, FS
          double precision :: P,D, dlam, ddlam, dep, ef, Ps, Ts, sbar_t
          double precision :: tol, epd, deps(9), sig(9)
          integer cnt
c
          sig(1) = Sio (1)
          sig(5) = Sio (2)
          sig(9) = Sio (3)
          sig(2) = Sio (4)
          sig(3) = Sio (5)
          sig(6) = Sio (6)
          sig(4) = sig (2)
          sig(7) = sig (3)
          sig(8) = sig (6)
c
          deps(1) = Dio (1)
          deps(5) = Dio (2)
          deps(9) = Dio (3)
          deps(2) = 0.5_8*Dio (4)
          deps(3) = 0.5_8*Dio (5)
          deps(6) = 0.5_8*Dio (6)
          deps(4) = deps (2)
          deps(7) = deps (3)
          deps(8) = deps (6)

c
c         cm(1) = K     , bulk modulus (for timestep)
c         cm(2) = G     , shear modulus (for timestep)
c         cm(3) = DAM   , element deletion (not used)
c         cm(4) = A     , intact material strength coefficient
c         cm(5) = B     , fractured material strength exponent
c         cm(6) = C     , strain rate coefficent
c         cm(7) = M     , fractured material strength exponent
c         cm(8) = N     , intact material strength coefficient
c         cm(9) = EPSI  , quasi-static strain rate threshold
c         cm(10) = T    , hydrostatic tensile strength
c         cm(11) = SFmax, maximum normalized fractured strength
c         cm(12) = HEL  , hugoniot elastic limit
c         cm(13) = PHEL , pressure component of HEL
c         cm(14) = BETA , fraction of elastic energy converted to pressure
c         cm(17) = D1   , damage accumulation coefficient
c         cm(18) = D2   , damage accumulation exponent
c         cm(19) = K1   , EOS term 1 (if K2,K3=0, K1 is the bulk mod.)
c         cm(20) = K2   , EOS term 2
c         cm(21) = K3   , EOS term 3
c         cm(22) = FS   , failure criteria
c
c         print *,"JH2"
c         print "(8e12.4)",cm(1),cm(2),cm(3),cm(4),
c     &                    cm(5),cm(6),cm(7),cm(8)
c         print "(8e12.4)",cm(9),cm(10),cm(11),cm(12),
c     &                    cm(13),cm(14),cm(15),cm(16)
c         print "(8e12.4)",cm(17),cm(18),cm(19),cm(20),
c     &                    cm(21),cm(22),cm(23),cm(24)
c         print *,""
c
c         print *,"HISV"
c         print "(4e12.4)",hisv(1),hisv(2),hisv(3),hisv(4),
c     &                    hisv(5),hisv(6),hisv(7),hisv(8),
c     &                    hisv(9),hisv(10),hisv(11),hisv(12)
c         print *,""
c
         K1 = cm(1)
         G = cm(2)
         A = cm(4)
         B = cm(5)
         C = cm(6)
         M = cm(7)
         N = cm(8)
         EPSI = cm(9)
         T = cm(10)
         SFmax = cm(11)
         HEL = cm(12)
         PHEL = cm(13)
         BETA = cm(14)
         D1 = cm(17)
         D2 = cm(18)
         K1 = cm(19)
         K2 = cm(20)
         K3 = cm(21)
         FS = cm(22)
         D = 0.0_8
         call I1 (sig, P)
         P = -P / 3.0_8
         syield = 0.0_8
         tol = G * 1.0e-7_8
         epd = 0.0_8
c
         if (tt.eq.0.0) then
            hisv(1) = 0.0
            hisv(2) = 0.0
            hisv(3) = 0.0
            hisv(4) = 0.0
            print *,"Material Constants:"
            print *,"G:",G
            print *,"K:",K1
            print *,""
         end if
c
         if (ABS(epd).lt.1e-20) then
            epd = 1e-20
         end if
c
c ================================
c    1. Calculate Trial Stress
c ================================
c
c         Get elastic constants from G,K
c         ==============================
          E = 9.0_8*G*K1/(3.0_8*K1+G)
          v = (3.0_8*K1-2.0_8*G)/(2.0_8*(3.0_8*K1+G))
          SHEL = 1.5_8*(HEL-PHEL)
c
c         Get elastic fourth order tensor L4
c         ==================================
          call L4_EL (E,v,L4)
c
c         Calculate stress increment (dsig = L:D)
c         =======================================
          call tc_4d2 (L4,deps,dsig)
c
c         Update strial with dsig (sn+1,trial = sn + dsig)
c         ================================================
          strial = sig + dsig
c
c ================================
c      2. Find Seq and Syield
c ================================
c
c         Find equivalent stress and normal using vm_box
c         ==============================================
          call vm_box (sig,2,seq,NOR,ph)
c
c         Find yield stress using JH2_yield
c         =================================
          call JH2_yield
     &    (epd,P,D,A,B,c,M,N,EPSI,T,SFmax,HEL,PHEL,syield)
c
c         Check for yielding
c         ==================
          sflow = seq - syield
c
          if (sflow.lt.0.0_8) then
             sig = strial
          else
c         =====================
c         Initiate PLASTIC LOOP
c         =====================
          call JH2_hardening
     &    (epd,P,hisv(2),A,B,c,M,N,T,HEL,PHEL,SFmax,EPSI,L4,NOR,D1,D2,h)
c
c  prime the loop, set all counters to 0
c  set sflow = 100 to ensure this runs once
c
          if ((P+T).gt.0.0_8) then
            dlam = 0.0_8
            dep = 0.0_8
            cnt = 1
            sflow = tol*100
            call tc_4d2(L4,NOR,LN)
c
c           plastic loop time!
c
            do while (DABS(sflow).gt.tol.AND.cnt.lt.5)
c
c            +  use normal and elastic tensor to calculate
c            +  plastic correction
c
               pl_corr = dlam * LN
               sig = strial - pl_corr
c
c            +  recalculate seq and sflow to determine whether
c            +  material is still yielding
c
               call VMS (sig,seq)
               sbar_t = syield + h*dep
               sflow = seq - sbar_t
c
c            +  update plastic multiplier increment, plastic multiplier
c            +  and plastic strain (the same in assoc. flow) to reflect
c            +  plastic correction
c
               call tc_2d2 (NOR,LN,NLN)
               ddlam = sflow / (NLN+h)
               dlam = dlam + ddlam
               dep = dlam
               cnt = cnt + 1
            end do
c
            hisv(1) = hisv(1) + dep
            hisv(3) = seq
c
c           +  update damage variable based on plastic strain increment
c
            Ps = P / PHEL
            Ts = T / PHEL
c
            ef = D1 * (Ps+Ts) ** D2
            D = dep/ef
c
            hisv(2) = hisv (2) + ABS(D)
c
            if (hisv(2).gt.1.0) then
               hisv (2) = 1.0_8
            end if
c
c
          else
            hisv(2) = 1.0_8
            hisv(4) = 1.0_8
            call EEQ (deps,dep)
            hisv(1) = hisv(1) + dep
            sig = 0.0_8
            efail = 1
c (P+T)>0
         end if
c (Sflow)>0
         end if
c
          Sio (1) = sig(1)
          Sio (2) = sig(5)
          Sio (3) = sig(9)
          Sio (4) = 0.5_8*(sig(2)+sig(4))
          Sio (5) = 0.5_8*(sig(3)+sig(7))
          Sio (6) = 0.5_8*(sig(6)+sig(8))
c
          return
c
        end subroutine umat_JH2
c


subroutine raylist_brute(ipart,iptmass,n,tmax)
!********************************************
! Given a particle, ray vector and maximum distance
! subroutine creates a list of all particles intersected
! by ray
! This subroutine is a brute force calculation O(N^2)
!*******************************************

use sphdata
use treedata

implicit none

integer, intent(in) :: ipart,iptmass
real,intent(in) :: tmax
real,dimension(3),intent(in) :: n

integer :: jpart,k
real :: t_try

nray = 0
t_sphere(:) = 0.0

do jpart=1,npart

   if(jpart==ipart .or.jpart==listpm(iptmass)) cycle ! Ignore self and sink

   if(iphase(jpart)/=0) cycle
 ! Calculate t_min

        t_try = 0.0

        do k=1,3
           t_try = t_try + n(k)*(xyzmh(k,jpart)-xyzmh(k,ipart))
        enddo

        ! t must be less than tmax, otherwise goes past sink
        if(t_try>tmax) cycle

        ! Calculate b - impact parameter with ray

        b(jpart) = 0.0

        do k=1,3
           b(jpart) = b(jpart) + &
                (xyzmh(k,ipart) + t_try*n(k) - xyzmh(k,jpart))**2
        enddo

        b(jpart) = SQRT(b(jpart))

        t_sphere(jpart) = 2.0d0*SQRT(4.0d0*xyzmh(5,jpart)**2 - b(jpart)*b(jpart))

        ! If t -ve and sufficiently distant, jpart is behind ray
        ! should not be counted
        if(t_try<0.0d0 .and. ABS(t_try)>0.5*t_sphere(jpart)) cycle

        ! If b < 2*h_i, then add to list

        if(b(jpart) < 2.0*xyzmh(5,jpart)) then

           ! Add particle to raylist
           nray = nray +1
           ray(nray) = jpart
           t_min(nray) = t_try
        endif

     enddo
    ! End of loop over jpart

end subroutine raylist_brute


C
C**************************  FVGDSE ************************************
C
C  calculate derivative of effective saturation with respect to pressure
C  head using van Genuchten characteristic equation
C
C***********************************************************************
C
      DOUBLE PRECISION FUNCTION FVGDSE(PSI,INOD)
C
      IMPLICIT NONE
      INCLUDE 'CATHY.H'
      INTEGER  INOD
      REAL*8   BETA,B1,B1R
      REAL*8   PSI
      INCLUDE 'SOILCHAR.H'
C
      IF (PSI .LT. -1.0D-14) THEN
         BETA=(ABS(PSI/VGPSAT(INOD)))**VGN(INOD)
         B1=BETA+1.0D0
         B1R=1.0D0/B1
         FVGDSE=VGN1(INOD)*((ABS(PSI)**VGN1(INOD))/VGPSN(INOD))*
     1          (ABS(B1)**VGNR(INOD))*B1R*B1R
      ELSE
         FVGDSE=0.0D0
      END IF
C
      RETURN
      END


      subroutine long_force(q, vlong, dvl)

      implicit real*8(a-h,o-z)

      include 'sizes.h'

      include 'qsats.h'

      common /bincom/ bin, binvrs, r2min

      real*8, intent(in)  :: q(NATOM3)
      real*8, intent(out) :: vlong, dvl(NATOM3)

      real*8 :: a(10)

      h2k = 3.157746d5

      a(1) = -0.189998e+01
      a(2) =  -0.421551E-02
      a(3) = 0.177780E-03
      a(4) = 0.603591E-04
      a(5) =  -0.417010E-01
      a(6) =  -0.414189E-01
      a(7) = -0.341826E-01
      a(8) = 0.363379E-03
      a(9) = -0.124138E-04
      a(10) = 0.224261E-05

      vlong = 0d0
      do i=1,NATOMS
        x = q(3*i-2)
        y = q(3*i-1)
        z = q(3*i)

        vlong = vlong + a(1) +
     +           a(2)*q(3*i-2)          +
     +           a(3)*q(3*i-1)          +
     +           a(4)*q(3*i)            +
     +           a(5)*q(3*i-2)**2       +
     +           a(6)*q(3*i-1)**2       +
     +           a(7)*q(3*i)**2         +
     +           a(8)*q(3*i-2)*q(3*i-1) +
     +           a(9)*q(3*i-1)*q(3*i)   +
     +           a(10)*q(3*i-2)*q(3*i)

!        vlong = vlong  - 0.147941E+01           -
!     +           0.278253E-02*q(3*i-2)          +
!     +           0.112328E-03*q(3*i-1)          +
!     +           0.382942E-04*q(3*i)            -
!     +           0.290524E-01*q(3*i-2)**2       -
!     +           0.288602E-01*q(3*i-1)**2       -
!     +           0.237969E-01*q(3*i)**2         +
!     +           0.239032E-03*q(3*i-2)*q(3*i-1) -
!     +           0.780090E-05*q(3*i-1)*q(3*i)   +
!     +           0.103676E-05*q(3*i-2)*q(3*i)

        dvl(3*i-2) = a(2)+2d0*a(5)*x + a(8)*y + a(10)*z
        dvl(3*i-1) = a(3)+2d0*a(6)*y + a(8)*x + a(9)*z
        dvl(3*i)   = a(4)+2d0*a(7)*z + a(9)*y + a(10)*x
      enddo

c --- energy units conversion K ---> Hartree

      vlong = vlong/h2k
      dvl = dvl/h2k

      return
      end subroutine


!***************************************************************************************************************************
! This is the code from the section (DYNAMIC == RATE) lines 4707 - 5046 of the original CSCAS code. The names of the
! dummy arguments are the same as in the original CSCAS code and the call statement and are declared here. The variables
! that are not arguments are declared in module YCA_First_Trans_m. Unless identified as by MF, all comments are those of
! the original CSCAS.FOR code.
!
! Subroutine YCA_Growth_Part calculates assimilation partitioning, growth of storage roots, leaves, stems and Plant. sticks.
!***************************************************************************************************************************

    SUBROUTINE YCA_Growth_Part ( &
        BRSTAGE     , ISWNIT      , NFP         &
        )

        USE ModuleDefs
        USE YCA_First_Trans_m

        IMPLICIT NONE

        INTEGER :: BR                      ! Index for branch number/cohorts#          ! (From SeasInit)
        INTEGER :: LF                      ! Loop counter leaves            #          !LPM 21MAR15 to add a leaf counter
        REAL    :: Lcount                   ! counter for iterations in leafs (Lcount)
        CHARACTER(LEN=1) ISWNIT
        REAL    BRSTAGE     , NFP

        REAL    CSYVAL      , TFAC4     , TFAC5                                                           ! Real function call !LPM 19SEP2017 Added tfac5

        ! Full NODEWTGB equation
        ! NDDAED = NDDAE/d
        ! NODEWTGB = 1/(1+(NDLEV/b)**c)  *  (e * (NDDAED)**f / (NDDAE * ((NDDAED**g)+1)**2))  * VF * TT
        REAL, PARAMETER :: NDLEV_B = 86.015564      ! this is 'b' from  1/(1+(NDLEV/b)**c) see issue #24
        REAL, PARAMETER :: NDLEV_C = 6.252552       ! this is 'c' from  1/(1+(NDLEV/b)**c) see issue #24
        REAL, PARAMETER :: NDDAE_D = 235.16408564   ! this is 'd' from  NDDAE/d
        REAL, PARAMETER :: NDDAE_E = 0.007610082    ! this is 'e' from  (e * (NDDAED)**f / (NDDAE * ((NDDAED**g)+1)**2))
        REAL, PARAMETER :: NDDAE_F = -2.045472      ! this is 'f' from  (e * (NDDAED)**f / (NDDAE * ((NDDAED**g)+1)**2))
        REAL, PARAMETER :: NDDAE_G = -1.045472      ! this is 'g' from  (e * (NDDAED)**f / (NDDAE * ((NDDAED**g)+1)**2))
        REAL NDDAED

        !-----------------------------------------------------------------------
        !           Partitioning of C to above ground and roots (minimum)
        !-----------------------------------------------------------------------

        CARBOT = AMAX1(0.0,(CARBOBEG+CARBOADJ))                                                                         !EQN 283

        LAWL(1) = LAWS
        !-----------------------------------------------------------------------
        !           Leaf growth
        !-----------------------------------------------------------------------

        GROLF = 0.0
        GROLFADJ = 0.0
        GROLFP = 0.0
        GROLSRS = 0.0
        GROLS = 0.0
        GROLSA = 0.0
        GROLSP = 0.0
        GROLSRT = 0.0
        GROLSSEN = 0.0
        GROLSRTN = 0.0
        GROLSSD = 0.0
        !LAGEG = 0.0   !LPM 28MAR15 This variable is not used
        !PLAGS2 = 0.0  !LPM 23MAR15 non necessary PLAGSB2 considers all the branches and shoots
        SHLAG2 = 0.0
        SHLAG2B = 0.0  !LPM 23MAR15 add new variable
        SHLAGB2 = 0.0
        SHLAGB3 = 0.0
        SHLAGB4 = 0.0

        ! Potential leaf size for next growing leaf - main shoot
        IF (DAE > 0.0) THEN
            LNUMNEED = FLOAT(INT(LNUM+1)) - LNUM                                                                           !EQN 332
            IF (ABS(LNUMNEED) <= 1.0E-6) LNUMNEED = 0.0
            !LPM 25/02/2015 the next lines are commented out to change the strategy to estimate the potential leaf area

            IF (DAWWP < 900) THEN
                node(BRSTAGE,(LNUMSIMSTG(BRSTAGE)+1))%LAPOTX =  LAXS*((DAWWP*1E-3)+0.10)                  ! LPM 07MAR15
            ELSE
                IF (DAWWP-TT< 900) DALSMAX = DAE                                 ! LPM 28FEB15 to define the day with the maximum leaf size
                !LPM 12JUL2015 test with thermal time with optimum of 20 C
                !LPM 24APR2016 Use of DALS (considering water stress) instead of TTCUMLS
                node(BRSTAGE,(LNUMSIMSTG(BRSTAGE)+1))%LAPOTX = LAXS/((1+(5.665259E-3*(DALS))))
            ENDIF

            DO BR = 0, BRSTAGE                                                                                !LPM 23MAR15 To consider cohorts
               SHLAG2B(BR) = 0.0
                DO LF = 1, LNUMSIMSTG(BR)
                    IF (node(BR,LF)%LAGETT <= LLIFGTT) THEN
                ! Basic leaf growth calculated on chronological time base.
                ! Basic response (cm2/day) considering a maximum growing duration of 10 days
                        node(BR,LF)%LATLPREV = node(BR,LF)%LATL
                        node(BR,LF)%LAPOTX2 = node(BR,LF)%LAPOTX*Tflfgrowth
                        node(BR,LF)%LAGL=node(BR,LF)%LAPOTX2*(TTlfgrowth/LLIFGTT)
                        IF (node(BR,LF)%LAGL > (node(BR,LF)%LAPOTX2-node(BR,LF)%LATL3)) THEN                                           !DA IF there is something left to grow
                            node(BR,LF)%LAGL = node(BR,LF)%LAPOTX2-node(BR,LF)%LATL3
                        ENDIF
                        IF (node(BR,LF)%LAGL < 0.0) THEN
                            node(BR,LF)%LAGL = 0.0
                        ENDIF
                        node(BR,LF)%LATL = node(BR,LF)%LATL + node(BR,LF)%LAGL                              !Leaf area = Leaf area + leaf growth    !EQN 323
                        node(BR,LF)%LATL = AMIN1(node(BR,LF)%LATL, node(BR,LF)%LAPOTX)                                                            ! DA 28OCT2016 Limiting LATL to not get over the maximum potential
                        node(BR,LF)%LATL2 = node(BR,LF)%LATL2 + node(BR,LF)%LAGL                                  !EQN 324 !LPM 24APR2016 LATL2 with the same value than LATL
                        node(BR,LF)%LATL2 = AMIN1(node(BR,LF)%LATL2, node(BR,LF)%LAPOTX)                                               !DA 28OCT2016 Limiting LATL2 to not get over the maximum potential
                        SHLAG2B(BR) = SHLAG2B(BR) + node(BR,LF)%LAGL                                    !EQN 325

                        !LPM 15NOV15 Variables LAGLT and LATL2T created to save the leaf are by cohort (all the plant (all branches and shoots))
                        node(BR,LF)%LAGLT = node(BR,LF)%LAGL * BRNUMST(BR) ! To initialize before adding over shoots
                        node(BR,LF)%LATL2T = node(BR,LF)%LATL2 * BRNUMST(BR)
                        DO L = 2,INT(SHNUM+2) ! L is shoot cohort,main=cohort 1
                            IF (SHNUM-FLOAT(L-1) > 0.0) THEN
                                node(BR,LF)%LAGLT = node(BR,LF)%LAGLT+(node(BR,LF)%LAGL*BRNUMST(BR))*SHGR(L) * AMAX1(0.,AMIN1(FLOAT(L),SHNUM)-FLOAT(L-1))
                                node(BR,LF)%LATL2T = node(BR,LF)%LATL2T+(node(BR,LF)%LATL2*BRNUMST(BR))*SHGR(L) * AMAX1(0.,AMIN1(FLOAT(L),SHNUM)-FLOAT(L-1))
                            ENDIF
                        ENDDO

                    ! The 2 at the end of the names indicates that 2 groups
                    ! of stresses have been taken into account
                    ! Stress factors for individual leaves
                        IF (node(BR,LF)%LAPOTX2 > 0.0) THEN
                            node(BR,LF)%WFLF =  AMIN1(1.0, node(BR,LF)%WFLF+WFG  * node(BR,LF)%LAGL/node(BR,LF)%LAPOTX2)                                        !EQN 326
                            node(BR,LF)%NFLF =  AMIN1(1.0, node(BR,LF)%NFLF+NFG  * node(BR,LF)%LAGL/node(BR,LF)%LAPOTX2)                                        !EQN 327
                            node(BR,LF)%NFLFP = AMIN1(1.0, node(BR,LF)%NFLFP+NFP * node(BR,LF)%LAGL/node(BR,LF)%LAPOTX2)                                      !EQN 328
                            node(BR,LF)%TFGLF = AMIN1(1.0, node(BR,LF)%TFGLF+TFG * node(BR,LF)%LAGL/node(BR,LF)%LAPOTX2)                                      !EQN 329
                            node(BR,LF)%TFDLF = AMIN1(1.0, node(BR,LF)%TFDLF+TFD * node(BR,LF)%LAGL/node(BR,LF)%LAPOTX2)                                      !EQN 330
                        ELSE
                            node(BR,LF)%WFLF =  1.0                                   !EQN 326
                            node(BR,LF)%NFLF =  1.0                                   !EQN 327
                            node(BR,LF)%NFLFP = 1.0                                   !EQN 328
                            node(BR,LF)%TFGLF = 1.0                                   !EQN 329
                            node(BR,LF)%TFDLF = 1.0                                   !EQN 330
                        ENDIF

                            ! New LEAF
                        IF (LF == LNUMSIMSTG(BR) .AND. LNUMG > LNUMNEED .AND. BR == BRSTAGE) THEN                                             ! This is where new leaf is initiated
                            node(BR,LF+1)%LAPOTX2 = node(BR,LF+1)%LAPOTX * Tflfgrowth
                            node(BR,LF+1)%LAGL = node(BR,LF+1)%LAPOTX2 * (TTlfgrowth/LLIFGTT)* EMRGFR * ((LNUMG-LNUMNEED)/LNUMG)   !LPM 02SEP2016 To register the growth of the leaf according LAGL(BR,LF) (see above)
                            IF (node(BR,LF+1)%LAGL < 0.0) THEN
                                node(BR,LF+1)%LAGL = 0.0
                            ENDIF
                            node(BR,LF+1)%LATL = node(BR,LF+1)%LATL + node(BR,LF+1)%LAGL                                                   ! LATL(LNUMX)         ! Leaf area,shoot,lf#,potential  cm2/l   !EQN 333
                            node(BR,LF+1)%LATL2 = node(BR,LF+1)%LATL2 + node(BR,LF+1)%LAGL                              ! LATL2(LNUMX)        ! Leaf area,shoot,lf#,+h2o,n,tem cm2/l   !EQN 334
                            SHLAG2B(BR) = SHLAG2B(BR) + node(BR,LF+1)%LAGL                              ! SHLAG2(25)          ! Shoot lf area gr,1 axis,H2oNt  cm2     !EQN 335
                            node(BR,LF+1)%LBIRTHDAP = DAP                                                                ! LBIRTHDAP(LCNUMX)   ! DAP on which leaf initiated #

                            node(BR,LF+1)%LAGLT = node(BR,LF+1)%LAGL*BRNUMST(BR)
                            node(BR,LF+1)%LATL2T = node(BR,LF+1)%LATL2*BRNUMST(BR)
                            DO L = 2,INT(SHNUM+2) ! L is shoot cohort,main=cohort 1
                                IF (SHNUM-FLOAT(L-1) > 0.0) THEN
                                    node(BR,LF+1)%LAGLT = node(BR,LF+1)%LAGLT+(node(BR,LF+1)%LAGL*BRNUMST(BR))*SHGR(L) * AMAX1(0.,AMIN1(FLOAT(L),SHNUM)-FLOAT(L-1))
                                    node(BR,LF+1)%LATL2T = node(BR,LF+1)%LATL2T+(node(BR,LF+1)%LATL2*BRNUMST(BR))*SHGR(L) * AMAX1(0.,AMIN1(FLOAT(L),SHNUM)-FLOAT(L-1))
                                ENDIF
                            ENDDO

                            ! Stress factors for individual leaves
                            node(BR,LF+1)%WFLF = AMIN1(1.0,node(BR,LF+1)%WFLF+WFG * node(BR,LF+1)%LAGL/node(BR,LF+1)%LAPOTX)                                             !EQN 336
                            node(BR,LF+1)%NFLF = AMIN1(1.0,node(BR,LF+1)%NFLF+NFG * node(BR,LF+1)%LAGL/node(BR,LF+1)%LAPOTX)                                             !EQN 337
                            node(BR,LF+1)%NFLFP = AMIN1(1.0,node(BR,LF+1)%NFLFP+NFP * node(BR,LF+1)%LAGL/node(BR,LF+1)%LAPOTX)                                           !EQN 338
                            node(BR,LF+1)%TFGLF = AMIN1(1.0,node(BR,LF+1)%TFGLF+TFG * node(BR,LF+1)%LAGL/node(BR,LF+1)%LAPOTX)                                           !EQN 339
                            node(BR,LF+1)%TFDLF = AMIN1(1.0,node(BR,LF+1)%TFDLF+TFD * node(BR,LF+1)%LAGL/node(BR,LF+1)%LAPOTX)                                           !EQN 340
                        ENDIF
                    ENDIF
                ENDDO
            SHLAG2(1) = SHLAG2(1)+(SHLAG2B(BR)*BRNUMST(BR))                                                                                !LPM 23MAR15 To have the leaf area fro one shoot considering all the branches (axis)
            ENDDO

            ! Leaf area increase:growing leaves on 1 axis,all shoots
            PLAGSB2 = SHLAG2(1) ! To initialize before adding over shoots
            DO L = 2,INT(SHNUM+2) ! L is shoot cohort,main=cohort 1
                IF (SHNUM-FLOAT(L-1) > 0.0) THEN
                    PLAGSB2 = PLAGSB2+SHLAG2(1)*SHGR(L) * AMAX1(0.,AMIN1(FLOAT(L),SHNUM)-FLOAT(L-1))                         !EQN 341
                    SHLAG2(L) = SHLAG2(1)*SHGR(L) * AMAX1(0.,AMIN1(FLOAT(L),SHNUM)-FLOAT(L-1))                             !EQN 342
                ENDIF
            ENDDO

            !! Leaf area increase:growing leaves on all axes,all shoots                                                     !LPM 23MAR15  It is not necessary, previously defined in the loop as SHLAG2
            !PLAGSB2 = PLAGS2*BRNUMST                                                                                !EQN 343
            !SHLAGB2(1) = SHLAG2(1)*BRNUMST                                                                                !EQN 344
            !DO L = 2,INT(SHNUM+2) ! L is shoot cohort,main= 1
            !    SHLAGB2(L) =  SHLAG2(L)*BRNUMST
            !ENDDO

            ! Potential leaf weight increase.
            IF (LAWL(1) > 0.0) THEN
                GROLFP = (PLAGSB2/LAWL(1)) / (1.0-LPEFR)                                                   !EQN 297
            ENDIF
        ENDIF

        !LPM 11APR15  Rate of node weight increase by branch level and cohort
        node%NODEWTG = 0.0
        GROSTP = 0.0
        GROCRP = 0.0
        Lcount = 0
        !IF (DAE > 0.0) THEN !LPM 01SEP16 putting a conditional DAE > 0.0 to avoid illogical values of NODEWTGB
        IF (DAG > 0.0) THEN !LPM 10JUL2017 DAG instead of DAE To consider root and stem develpment after germination and before emergence (planting stick below-ground)
          DO BR = 0, BRSTAGE               ! for each branch
            DO LF = 1, LNUMSIMSTG(BR)    ! and each node of the branches
                Lcount = Lcount+1

                NDDAED=(DAG-node(BR,LF)%NDDAE+1)/NDDAE_D

                !LPM23FEB2017 New high initial rate
                node(BR,LF)%NODEWTGB = (1/(1+(((Lcount)/NDLEV_B)**NDLEV_C)))  *  (NDDAE_E*(((NDDAED)**NDDAE_F) / ((NDDAED**NDDAE_G)+1)**2))  *  TFG  * WFG *NODWT !LPM12JUL2017 adding water factor of growth

                node(BR,LF)%NODEWTG = node(BR,LF)%NODEWTGB
                !IF (BR == 0.AND.LF == 1.AND.DAE == 1.AND.SEEDUSES > 0.0) NODEWTG(BR,LF) = SEEDUSES + NODEWTGB(BR) !LPM 22MAR2016 To add the increase of weight from reserves
                node(BR,LF)%NODEWT = node(BR,LF)%NODEWT + node(BR,LF)%NODEWTG
                GROSTP = GROSTP + (node(BR,LF)%NODEWTG*BRNUMST(BR)) !LPM08JUN2015 added BRNUMST(BR) to consider the amount of branches by br. level
                STWTP = STWTP + (node(BR,LF)%NODEWTG*BRNUMST(BR))

                ENDDO
            ENDDO
        ENDIF

!       chp 2019-04-10 added zero divide protection
        if (nodlt > 1.e-6) then
          GROCRP = node(0,1)%NODEWTGB * SPRL/NODLT   !LPM 02OCT2015 Added to consider the potential increase of the planting stick
        else
          GROCRP = 0.0
        endif

        CRWTP = CRWTP + GROCRP    !LPM 23MAY2015 Added to keep the potential planting stick weight
        GRORP = (GROLFP + GROSTP)*PTFA
        !GRORP = (GROLFP + GROSTP)*(0.05+0.1*EXP(-0.005*Tfgem)) !LPM 09JAN2017 Matthews & Hunt, 1994 (GUMCAS)
        !GRORP = (GROLFP + GROSTP)*(0.05+0.1*EXP(-0.005*Tfd)) !LPM 09JAN2017 Matthews & Hunt, 1994 (GUMCAS)
        GROLSP = GROLFP + GROSTP + GROCRP + GRORP  !LPM 02OCT2015 Added to consider the potential increase of the planting stick

        IF (GROLSP > 0.0) THEN
            ! Leaf+stem weight increase from assimilates
            !GROLSA = AMAX1(0.,AMIN1(GROLSP,CARBOT-GROSR))                                                              !EQN 298 !LPM 05JUN2105 GROSR or basic growth of storage roots will not be used
            GROLSA = AMAX1(0.,AMIN1(GROLSP,CARBOT))                                                                     !EQN 298
            ! Leaf+stem weight increase from senescence
            IF (GROLSA < GROLSP) THEN

                GROLSSEN = AMIN1(GROLSP-GROLSA,SENLFGRS)
            ENDIF

            IF (GROLSA+GROLSSEN < GROLSP) THEN
                ! Leaf+stem weight increase from seed reserves
                ! LAH May need to restrict seed use.To use by roots?
                IF (DAE <= 0.0)THEN !LPM 23MAR2016 Before emergence use the SEEDUSED according with CS_growth_Init.f90
                    GROLSSD = AMIN1((GROLSP-GROLSA-GROLSSEN),SEEDUSED)                                                     !EQN 300
                ELSE
                    GROLSSD = AMIN1((GROLSP-GROLSA-GROLSSEN),SEEDRSAV)                                                     !EQN 300
                    SEEDRSAV = SEEDRSAV - GROLSSD                                                                          !EQN 288
                ENDIF

                IF ( LAI <= 0.0.AND.GROLSSD <= 0.0.AND.SEEDRSAV <= 0.0.AND.ESTABLISHED /= 'Y') THEN
                    CFLFAIL = 'Y'
                    WRITE (Message(1),'(A41)') 'No seed reserves to initiate leaf growth '
                    WRITE (Message(2),'(A33,F8.3,F6.1)') '  Initial seed reserves,seedrate ',seedrsi,sdrate
                    WRITE (Message(3),'(A33,F8.3,F6.1)') '  Reserves %,plant population    ',sdrs,pltpop    !LPM 22MAR2016 Keep value SDRS
                    CALL WARNING(3,'CSYCA',MESSAGE)
                ENDIF
            ENDIF
            ! Leaf+stem weight increase from plant reserves
            IF (GROLSA+GROLSSD+GROLSSEN < GROLSP) THEN
                GROLSRS =  AMIN1(RSWT*RSUSE,GROLSP-GROLSA-GROLSSD-GROLSSEN)                                            !EQN 301
            ENDIF
            ! Leaf+stem weight increase from roots (after drought)
            GROLSRT = 0.0
            GROLSRTN = 0.0
            IF ((GROLSA+GROLSSD+GROLSRS+GROLSSEN) < GROLSP.AND.SHRTD < 1.0.AND.RTUFR > 0.0.AND.ESTABLISHED == 'Y') THEN
                GROLSRT = AMIN1(RTWT*RTUFR,(GROLSP-GROLSA-GROLSSD-GROLSSEN-GROLSRS))                                   !EQN 302
                IF (ISWNIT /= 'N') THEN
                    GROLSRTN = GROLSRT * RANC                                                                          !EQN 244
                ELSE
                    GROLSRTN = 0.0
                ENDIF
                WRITE(Message(1),'(A16,A12,F3.1,A8,F7.4,A7,F7.4,A9,F7.4)') &
                    'Roots -> leaves ',' Shoot/root ',shrtd,' Grolsp ',grolsp,' Grols ',grols,' Grolsrt ',grolsrt
                CALL WARNING(1,'CSYCA',MESSAGE)
            ENDIF
            ! Leaf+stem weight increase from all sources
            GROLS = GROLSA + GROLSSEN + GROLSSD + GROLSRS+GROLSRT                                                      !EQN 303
            ! Leaf weight increase from all sources
            IF ((GROLSP) > 0.0) THEN
                GROLF = GROLS * GROLFP/GROLSP                                                                          !EQN 304
            ELSE
                GROLF = 0.0
            ENDIF
            ! Check if enough assimilates to maintain SLA within limits
            !AREAPOSSIBLE = GROLF*(1.0-LPEFR)*(LAWL(1)*(1.0+LAWFF))                                                     !EQN 148 !LPM 12DEC2016 Delete temperature, water and leaf position factors in SLA
            AREAPOSSIBLE = GROLF*(1.0-LPEFR)*LAWL(1)
            ! If not enough assim.set assimilate factor
            IF (PLAGSB2 > AREAPOSSIBLE.AND.PLAGSB2 > 0.0)THEN
                node(0,0)%AFLF = AREAPOSSIBLE/PLAGSB2                                                                         !EQN 149
            ELSE
                node(0,0)%AFLF = 1.0
            ENDIF
            IF (CFLAFLF == 'N') node(0,0)%AFLF = 1.0                                                                            !MF 21AU16 ErrorFix Added second subscript to AFLF.

        ENDIF                                                                                !MF 21AU16 ErrorFix. Added to terminate block

        !-----------------------------------------------------------------------
        !           Stem and Plant. stick growth
        !-----------------------------------------------------------------------

        GROCR = 0.0
        GROSTCRP = 0.0
        GROST = 0.0
        GROSTCR = 0.0
        STAIG = 0.0
        STAIS = 0.0
        GROSTCRP = GROSTP                                                                                !EQN 381a

        IF (GROLFP+GROSTCRP > 0.0) THEN
            GROSTCR = GROLS * GROSTCRP/(GROLSP) * (1.0-RSFRS)                         !EQN 383 !LPM 02OCT2015 Modified to consider GROLSP
        ENDIF

        GROST = GROSTCR

        IF (GROLSP > 0.0) THEN
            GROCR = GROLS*(GROCRP/GROLSP)   !LPM 05OCT2015 To avoid wrong values for GROCR
            RTWTG = GROLS*(GRORP/GROLSP) !LPM 22DEC2016 Root development
        ENDIF

        !CRWTP = CRWTP + GROCR                 !LPM 020CT2015 Deleted to consider before (line 320)

    END SUBROUTINE YCA_Growth_Part


  function qints (sDCM, x, lq)

! ======================================================================
!
!      Parabolic interpolation of tabulated cross sections.
!      For lq = 1-4 and 15-19, use a parabola in log(sigma) vs. log(E)
!      for energies (x) less than the 2nd point.
!
!    Called by: BINEL ISOBAR SIGMAT8
!
!    CEM95 written by S. G. Mashnik
!    Edited by A. J. Sierk,  LANL  T-2  February, 1996.
!    Modified for new cross section tables, June, 1997 (AJS)
!    Edited by A. J. Sierk, LANL T-16, October, 2003.
!    Modified to define once an array of a, b, c coefficients
!      to speed up code.  AJS  February, 2005.
!    Edited by AJS, LANL T-2, December, 2011.
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64
    use standardDCMParams, only: zro, one
    use standardDCMData,   only: sigma, argus, aa, bb, cc, iiQints

    implicit none
    class(StandardDCM), intent(inout) :: sDCM
    real(real64),   intent(in   ) :: x
    integer(int32), intent(in   ) :: lq
    real(real64)                  :: qints

    integer(int32) :: i, lpha, lpmax, lqEff
    real(real64)   :: y
    logical        :: ilog

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

    qints = zro
    lpmax = 31
    ilog = .false.
    lqEff = lq
    if (lqEff <= 4) then
       ilog = .true.
       lpmax = 30
    elseif (lqEff > 14 .and. lqEff <= 19) then
       ilog = .true.
    elseif (lqEff == 20 .or. lqEff == 21 .or. lqEff == 28) then
       ilog = .true.
    elseif (lqEff >= 23 .and. lqEff <= 27) then
       ilog = .true.
    elseif (lqEff < 1 .or. lqEff > 28) then
       write(sDCM%io%message, 1000) lqEff
       call sDCM%io%print(2, 3, sDCM%io%message)

       ! Approximate to nearest valid point
       if ( lqEff > 28 ) lqEff = 28
       if ( lqEff <  1 ) lqEff =  1

       write(sDCM%io%message, 1010) lqEff
       call sDCM%io%print(2, 3, sDCM%io%message)

    endif
    i = iiQints(lqEff)
    lpha = 1

10  if (abs(x - argus(lpha,i)) <= 1.d-4) then
!  If x =~ table value, set cross section to tabulated one.
       qints = sigma(lpha,lqEff)
       return
    elseif (x > argus(lpha,i)) then
!  Increment lpha until x is <= tabulated x.
       if (lpha >= lpmax-1) then
          lpha = lpmax - 1
       else
          lpha = lpha + 1
          go to 10
       endif
    elseif (x < argus(lpha,i)) then
       if (lpha <= 1 .and. .not.ilog .and. i == 3) then
!  If x < first table value and not using parabolic log interpolation;
!  below threshold; set cross section to 0.
          qints = zro
          return
       elseif (lpha <= 1 .and. i == 2) then
!  For pi+N reactions with energy < 0; use 0-energy cross section:
          qints = sigma(1,lqEff)
          return
       else
          lpha = max(2,lpha)
          lpha = min(lpmax-1,lpha)
       endif
    endif
    y = x
    if (ilog .and. lpha == 2) y = log(x)
    qints = aa(lpha,lqEff)*y**2 + bb(lpha,lqEff)*y + cc(lpha,lqEff)
    if (ilog .and. lpha == 2) then
       qints = exp(qints)
    else
       qints = max(qints, zro)
    endif
    return

! ======================================================================
1000 format("An invalid 'lq' index (", i3, ") was detected in 'qints.f90'.")
1010 format("   Approximating lq to nearest valid point (", i3, ").")
! ======================================================================
  end function qints


      SUBROUTINE INDYNS
C--
C--   SUBROUTINE INDYNS
C--
C--   Purpose : set time-stepping constants and initialize coefficients
C--             and spectral operators for model dynamics
C--   Initialized common blocks: DYNC0, DYNC1,  DYNC2,  DYNC3,  DYNC4,
C--                              HDIFC1, HDIFC3,
C--                              common blocks for spectral transforms
C--                              (through routine PARMTR)
C--
      include "atparam.h"
      include "atparam1.h"

      include "com_tsteps.h"
      include "com_lflags.h"

      include "com_dyncon0.h"
      include "com_dyncon1.h"
      include "com_hdifcon.h"
      include "com_spectral.h"

C--   1. Definition of constants

      IF (MOD(NSTEPS,2).NE.0) STOP ' Invalid no. of time steps'
      DELT=86400./NSTEPS
      DELT2=2.*DELT

c     ROB = Robert filter parameter
      ROB  = 0.05

c     WIL = Williams filter parameter
c      WIL = 1.0
      WIL = 0.53

c     ALPH = 0 ---- forward step for gravity wave terms
c     ALPH = 1 ---- backward implicit -----------------
c     ALPH = 0.5 -- centered implicit -----------------
      ALPH = 0.5

C     1.2 Physical constants required by the dynamical core

      REARTH = 6.371E+6
      OMEGA  = 7.292E-05
      GRAV   = 9.81
      AKAP   = 2./7.
      RGAS   = AKAP*1004.

      PI = 4.*ATAN(1.)
      A  = REARTH
      G  = GRAV

C     1.3 Reference vertical profiles of temperature and humidity
C         and horizontal diffusion constants

      include "cls_indyns.h"

c     Power of Laplacian in horizontal diffusion
      NPOWHD = 4

C--   2. Definition of model levels

C     2.1 Half (vertical velocity) levels

      IF (KX.EQ.5) THEN
        HSG(1)=0.000
        HSG(2)=0.150
        HSG(3)=0.350
        HSG(4)=0.650
        HSG(5)=0.900
        HSG(6)=1.000
      ELSE IF (KX.EQ.7) THEN
        HSG(1)=0.020
        HSG(2)=0.140
        HSG(3)=0.260
        HSG(4)=0.420
        HSG(5)=0.600
        HSG(6)=0.770
        HSG(7)=0.900
        HSG(8)=1.000
       ELSE IF (KX.EQ.8) THEN
        HSG(1)=0.000
        HSG(2)=0.050
        HSG(3)=0.140
        HSG(4)=0.260
        HSG(5)=0.420
        HSG(6)=0.600
        HSG(7)=0.770
        HSG(8)=0.900
        HSG(9)=1.000
      ENDIF

      DO K=1,KXP
        PRINT *, ' Model half-level (*1000)', k, nint(HSG(k)*1000)
      ENDDO

c     2.2 Layer thicknesses and full (u,v,T) levels

      DO K=1,KX
        DHS(K)=HSG(K+1)-HSG(K)
        FSG(K)=0.5*(HSG(K+1)+HSG(K))
      ENDDO

      DO K=1,KX
        PRINT *, ' Model full-level (*1000)', k, nint(FSG(k)*1000)
      ENDDO

c    2.3 Additional functions of sigma

      DO K=1,KX
        DHSR(K)=0.5/DHS(K)
        FSGR(K)=AKAP/(2.*FSG(K))
      ENDDO

C--   3. Horizontal functions and spectral operators

C     3.1 Initialization of spectral operators

      CALL PARMTR (REARTH)

C     3.2 Latitudes and functions of latitude
C         NB: J=1 is Southernmost point!

      DO J=1,IY
        JJ=IL+1-J
        RAD1=ASIN(SIA(J))
        RADANG(J) =-RAD1
        RADANG(JJ)= RAD1
        GSIN(J)   =-SIA(J)
        GSIN(JJ)  = SIA(J)
      ENDDO

      DO J=1,IL
        GCOS(J)=COSG(J)
        CORIOL(J)=2.*OMEGA*GSIN(J)
      ENDDO

C--   4. Coefficients to compute geopotential

      DO K=1,KX
        XGEOP1(K)=RGAS*LOG(HSG(K+1)/FSG(K))
        IF(K.NE.KX) XGEOP2(K+1)=RGAS*LOG(FSG(K+1)/HSG(K+1))
      ENDDO

C--   5. Coefficients for horizontal diffusion

C     5.1 Spectral damping coefficients

      HDIFF = 1./(THD *3600.)
      HDIFD = 1./(THDD*3600.)
      HDIFS = 1./(THDS*3600.)
      RLAP  = 1./FLOAT(MTRUN*(MTRUN+1))

      DO N=1,NX
        DO M=1,MX
          TWN =FLOAT(ISC*(M-1)+N-1)
          ELAP=(TWN*(TWN+1.)*RLAP)
          ELAPN=ELAP**NPOWHD
          DMP (M,N)=HDIFF*ELAPN
          DMPD(M,N)=HDIFD*ELAPN
          DMPS(M,N)=HDIFS*ELAP
        ENDDO
C       DMPS(1,N)=0.
      ENDDO

C     5.2 Orographic correction terms for temperature and humidity
C         (vertical component)

      RGAM = RGAS*GAMMA/(1000.*GRAV)
      QEXP = HSCALE/HSHUM

      TCORV(1)=0.
      QCORV(1)=0.
      QCORV(2)=0.

      DO K=2,KX
        TCORV(K)=FSG(K)**RGAM
        IF (K.GT.2) QCORV(K)=FSG(K)**QEXP
        print *, ' temp/hum correction at level ', k, TCORV(k), QCORV(k)
      ENDDO

C--
      RETURN
      END


	subroutine tracesini()

! Initialize trace gaz vertical profiles

        use grid
        use rad
        use params, only: notracegases

	implicit none

	integer nzls,nzls0
	parameter (nzls0=500)
	real zls(nzls0)
	real pls(nzls0)
	real o3ls(nzls0)
	real n2ols(nzls0)
	real ch4ls(nzls0)
	real cfc11ls(nzls0)
	real cfc12ls(nzls0)

	real zz(nzm)
	integer k,m,n

	do k=1,nzm
	  zz(nz-k)=z(k)
	end do

	open(88,file=trim(rundatadir)//'/trc', status='old',form='formatted')

	read(88,*) nzls
	read(88,*)
	do k=1,nzls
         read(88,*) zls(k),pls(k),o3ls(k),n2ols(k), &
					ch4ls(k),cfc11ls(k),cfc12ls(k)
	 zls(k)=zls(k)*1000.
	end do
	close (88)
        if(notracegases) then
           o3ls = o3ls*0.01
           n2ols = 0.
           ch4ls = 0.
	   cfc11ls = 0.
           cfc12ls = 0.
        end if
        n=1
	do k=1,nzm
	  if(zz(k).ge.zls(1)) then
           o3(k)=o3ls(1)
           n2o(k)=n2ols(1)
           ch4(k)=ch4ls(1)
           cfc11(k)=cfc11ls(1)
           cfc12(k)=cfc11ls(1)
	  elseif (zz(k).le.zls(nzls)) then
           o3(k)=o3ls(nzls)
           n2o(k)=n2ols(nzls)
           ch4(k)=ch4ls(nzls)
           cfc11(k)=cfc11ls(nzls)
           cfc12(k)=cfc11ls(nzls)
	  else
	   do m=n,nzls-1
            if(zz(k).gt.zls(m)) then
              n=m-1
	      goto 111
	    endif
	   end do
 111	   continue
	   o3(k)=o3ls(n)+(zz(k)-zls(n))/(zls(n+1)-zls(n))* &
						(o3ls(n+1)-o3ls(n))
	   n2o(k)=n2ols(n)+(zz(k)-zls(n))/(zls(n+1)-zls(n))* &
						(n2ols(n+1)-n2ols(n))
	   ch4(k)=ch4ls(n)+(zz(k)-zls(n))/(zls(n+1)-zls(n))* &
						(ch4ls(n+1)-ch4ls(n))
	   cfc11(k)=cfc11ls(n)+(zz(k)-zls(n))/(zls(n+1)-zls(n))* &
					(cfc11ls(n+1)-cfc11ls(n))
	   cfc12(k)=cfc12ls(n)+(zz(k)-zls(n))/(zls(n+1)-zls(n))* &
					(cfc12ls(n+1)-cfc12ls(n))
	  endif
	end do
	if(rank.eq.0) then

	print*,'CEM.trace: number of levels=',nzls
	print*,'gas traces vertical profiles (g/g):'
	print*,'  z    o3   n2o   ch4   cfc11   cfc12'
	do k=nzm,1,-1
	 write(6,'(6g12.4)') zz(k),o3(k),n2o(k),ch4(k),cfc11(k),cfc12(k)
	end do
	print*,'done...'

	endif

	return
	end


!	gradient of log conditional probability of an observation.
!	rbetamap is the reduced beta map.
!	mask is the response mask.
!	condprobcat contains conditional item probabilities.
!	meanth is the mean of theta.
!	mean2th is the mean of products of elements of theta.
!	newtheta is the transformed latent vector.
!	probcat contains item probabilities.
!	theta is the latent vector.
!	thpr is the independent vector.
function gradvec(rbetamap,mask,condprobcat,meanth,mean2th,newtheta,probcat,theta,thpr)

implicit none
integer,intent(in)::rbetamap(:,:)
logical,intent(in)::mask(:)
real(kind=8),intent(in)::condprobcat(:),meanth(:),mean2th(:,:),newtheta(:),probcat(:),theta(:),thpr(:)
real(kind=8)::gradvec(size(rbetamap,2))
!	row is a counter.
integer::row

gradvec=0.0_8

do row=1,size(gradvec)

	if(rbetamap(1,row)>0)then
		if(mask(rbetamap(1,row)))then
			if(rbetamap(3,row)==0)then
!	Intercept
				gradvec(row)=condprobcat(rbetamap(2,row))-probcat(rbetamap(2,row))
			else
!	Slope
				gradvec(row)=newtheta(rbetamap(3,row))*(condprobcat(rbetamap(2,row))-probcat(rbetamap(2,row)))
			endif
		endif
	else
		if(rbetamap(4,row)==0)then
!	Linear
			gradvec(row)=thpr(rbetamap(5,row))*(theta(rbetamap(3,row))-meanth(rbetamap(3,row)))
		else
!	Quadratic
			gradvec(row)=thpr(rbetamap(5,row))*&
				(theta(rbetamap(3,row))*theta(rbetamap(4,row))-mean2th(rbetamap(3,row),rbetamap(4,row)))
		end if
	end if
end do
return
end function gradvec


       SUBROUTINE SEEING  !I
CM     PROGRAM MSEEING    !M
C++
C
C SEEING - create a simulated seeing PSF using the method
C          described by Saglia et al, MNRAS,264,961
C
C This is an IRAF application written using the F77/VOS.
C
C Purpose:
C
C Create a seeing disc simulation using user specified
C values of FWHM and gamma, the exponent. The PSF is circularly
C symmetric.
C
C Note:
C
C This code doesn't work well if the PSF is very large or small
C relative to the frame. In rough terms the minimum in the "input
C image" should be small (eg, 10-8) and so should the minimum in
C the output, relative to the peak (eg, a factor of 10-6 lower).
C
C History:
C
C First version, Richard Hook, ST-ECF, Apr 94
C Modified to have different FWHM in X and Y, Jan 95
C Modified to use a different "b" expression, Apr 96
C Modified to use lower-case parameters names, April 2000
C (also release as part of the stecf package)
C--
      IMPLICIT NONE

C Iraf global space
      DOUBLE PRECISION MEMD(1) !I
      COMMON /MEM/MEMD         !I

C MIDAS global storage
CM    INTEGER MEMD(1)          !M
CM    COMMON /VMR/MEMD         !M

C Local variables
      INTEGER NX,NY,DIMS(2),ID,ISTAT,IPNT,TEMP
      DOUBLE PRECISION SCRATCH(1024)
      CHARACTER*80 IMAGE
      DOUBLE PRECISION BX,BY,FWHMX,FWHMY,GAMMA
C++

C Start of code

C Midas initialisation
CM    CALL STSPRO('MSEEING') !M

C Announce the version
      CALL UMSPUT('+ SEEING Version 1.3 (April 2000)', !I
     :            1,0,ISTAT)                                      !I
CM    CALL UMSPUT('+ MSEEING Version 1.3 (April 2000)', !M
CM   :            1,0,ISTAT)                                      !M

C Get the name of the output image
      CALL UCLGST('output',IMAGE,ISTAT)

C and its dimensions
      CALL UCLGSI('xdim',NX,ISTAT)
      CALL UCLGSI('ydim',NY,ISTAT)

      DIMS(1)=NX
      DIMS(2)=NY

C and the size and gamma parameters
C X and Y are separate
      CALL UCLGSD('fwhmx',FWHMX,ISTAT)
      CALL UCLGSD('fwhmy',FWHMY,ISTAT)

      CALL UCLGSD('gamma',GAMMA,ISTAT)

C we convert this value to "b" values in the two directions
C
C The full formula is:
C
C b =    FWHM * pi
C     ---------------
C     N.2.sqrt(ln(2))       [N is the number of pixels in X or Y]
C
C In version  1.2 this is modified to:
C
C b =    FWHM * pi
C     ---------------
C     N.2.(ln(2)**(1/gamma))  [N is the number of pixels in X or Y]
C
C This expression is more or less a guess (which is certainly correct
C when gamma=2)

C
CC      BX=FWHMX*3.141592653/(DBLE(NX)*1.6651092)
CC      BY=FWHMY*3.141592653/(DBLE(NY)*1.6651092)
      BX=FWHMX*3.141592653/(DBLE(NX)*2.0*(LOG(2.0)**(1.0/GAMMA)))
      BY=FWHMY*3.141592653/(DBLE(NY)*2.0*(LOG(2.0)**(1.0/GAMMA)))

C Create the image
      CALL UIMCRE(IMAGE,7,2,DIMS,ID,ISTAT)
      IF(ISTAT.NE.0) THEN
         CALL UMSPUT('Unable to create output image',
     :               1,0,ISTAT)
         GO TO 99
      ENDIF

C Allocate memory for the image
      CALL UDMGET(NX*NY,7,IPNT,ISTAT)
      IF(ISTAT.NE.0) THEN
         CALL UMSPUT('Unable to allocate memory for data',
     :               1,0,ISTAT)
         GO TO 99
      ENDIF

C Allocate memory for the temp image
      CALL UDMGET(NX*NY*2,7,TEMP,ISTAT)
      IF(ISTAT.NE.0) THEN
         CALL UMSPUT('Unable to allocate memory for FFT',
     :               1,0,ISTAT)
         GO TO 99
      ENDIF

C Fill the FFT images
      CALL SEEFFT(NX,NY,BX,BY,GAMMA,MEMD(TEMP))

C Take the inverse FFT to give the output image
      CALL DFOURT(MEMD(TEMP),DIMS,2,1,1,SCRATCH)

C Quadrant swap to put the peak in the middle
      CALL QUAD(MEMD(TEMP),NX,NY,MEMD(IPNT))

C Write out the result
      CALL UIPS2D(ID,1,NX,1,NY,MEMD(IPNT),ISTAT)

 99   CONTINUE
      CALL UIMCLO(ID,ISTAT)
      CALL UDMFRE(IPNT,7,ISTAT)
      CALL UDMFRE(TEMP,7,ISTAT)

C Close down MIDAS
CM    CALL STSEPI    !M

      END

      SUBROUTINE SEEFFT(NX,NY,BX,BY,GAMMA,TEMP)
C
C Fill an array with an exponential disc of the
C form: v=exp[-(kb)**gamma]
C
C where k is the radial distance from the specified point
C
C This routine allows the b coefficient to be different
C in X and Y. b is scaled so that k can be in pixel coordinates
C in the FFT arrays
C
      IMPLICIT NONE

      INTEGER NX,NY
      DOUBLE PRECISION BX,BY,GAMMA
      DOUBLE PRECISION TEMP(NX*NY*2),IMIN,IMAX,DX,DY
      INTEGER I,J,II,JJ,IP,ISTAT
      CHARACTER*80 CHARS

      IP=1

      DO J=-NY/2+1,NY/2
          DO I=-NX/2+1,NX/2
             DX=DBLE(I-1)
             DY=DBLE(J-1)
             II=I
             JJ=J
             IF(I.LT.1) II=I+NX
             IF(J.LT.1) JJ=J+NY
             IP=(JJ-1)*NX*2+II*2-1
             TEMP(IP)=DEXP(-(SQRT((DX*BX)**2
     :                          +(DY*BY)**2))**GAMMA)
             TEMP(IP+1)=0.0D0
          ENDDO
      ENDDO

      IMIN=1.0E30
      IMAX=-IMIN

      DO I=1,2*NX*NY-1,2
         IF(TEMP(I).LT.IMIN) IMIN=TEMP(I)
         IF(TEMP(I).GT.IMAX) IMAX=TEMP(I)
      ENDDO

      WRITE(CHARS,'(''-Extreme values in input array: '',
     :              2G12.4)') imin,imax
      CALL UMSPUT(CHARS,1,0,ISTAT)

      RETURN
      END

      SUBROUTINE QUAD(WORK,NX,NY,OUT)
C
C Quadrant swap the results of the inverse FFT
C
      INTEGER NX,NY
      DOUBLE PRECISION WORK(NX*NY*2),OUT(NX,NY),FAC
      DOUBLE PRECISION IMIN,IMAX
      INTEGER ISTAT
      CHARACTER*80 CHARS

      FAC=DFLOAT(NX*NY)
      IP=1

      NX2=MAX(1,NX/2)
      NY2=MAX(1,NY/2)

C Check the imaginary range
      IMIN=1.0E30
      IMAX=-IMIN

      DO I=2,2*NX*NY,2
         IF(WORK(I).LT.IMIN) IMIN=WORK(I)
         IF(WORK(I).GT.IMAX) IMAX=WORK(I)
      ENDDO

      WRITE(CHARS,'(
     :   ''-Extreme values in output imaginary part: '',
     :              2G12.4)') IMIN,IMAX
      CALL UMSPUT(CHARS,1,0,ISTAT)

      IMIN=1.0E30
      IMAX=-IMIN

      DO I=1,2*NX*NY-1,2
         IF(WORK(I).LT.IMIN) IMIN=WORK(I)
         IF(WORK(I).GT.IMAX) IMAX=WORK(I)
      ENDDO

      WRITE(CHARS,'(
     :   ''-Extreme values in output real part: '',
     :              2G12.4)') IMIN,IMAX
      CALL UMSPUT(CHARS,1,0,ISTAT)

       DO J=1,NY2
          DO I=1,NX2
             OUT(I+NX/2,J+NY/2)=WORK(IP)/FAC
             IP=IP+2
          ENDDO
          IP=IP+NX
       ENDDO

       IP=NX+1
       DO J=1,NY2
          DO I=1,NX2
             OUT(I,J+NY/2)=WORK(IP)/FAC
             IP=IP+2
          ENDDO
          IP=IP+NX
       ENDDO

       IP=NX*NY+1
       DO J=1,NY2
          DO I=1,NX2
             OUT(I+NX/2,J)=WORK(IP)/FAC
             IP=IP+2
          ENDDO
          IP=IP+NX
       ENDDO

       IP=NX*NY+NX+1
       DO J=1,NY2
          DO I=1,NX2
             OUT(I,J)=WORK(IP)/FAC
             IP=IP+2
          ENDDO
          IP=IP+NX
       ENDDO

      RETURN
      END


C$Id: hipass3d.f,v 1.1 1996/04/19 17:10:11 ty7777 Exp $
C$Log: hipass3d.f,v $
c Revision 1.1  1996/04/19  17:10:11  ty7777
c Initial revision
c
c
      subroutine hipass3d (image, nx, ny, nz, cmppix, f0)

c     Author: Avi Snyder 19-Dec-95	! modified gauss3d.f
c
c     inputs: real*4 image(nx,ny,nz)	! image to be filtered
c             real*4 cmppix(3)		! x, y, z voxel dimensions in cm
c             real*4 f0			! half amplitude frequency in cycles/cm
c
c     variables modified: image         ! input image overwritten
c
c     subroutines called:  FFT, REALT in FORTRAN source fftsun.f
c                          FFT algorithm by Richard C. Singleton via FFTPE.FTN
c
c     restrictions: mixed radix FFT accepts any nx, ny, nz but
c                   nx must be divisible by 2
c                   memory allocation requirement 8*(nx/2+1)*ny*nz bytes

      character*256 rcsid/'$Header: /data/petsun4/src_solaris/librms/RCS/hipass3d.f,v 1.1 1996/04/19 17:10:11 ty7777 Exp $'/
      real*4 image(nx,ny,nz)
      real*4 cmppix(3)
      pointer (pa,a),(pb,b)
      real*4 a((nx/2+1)*ny*nz),b((nx/2+1)*ny*nz)

      pa=malloc(4*(nx/2+1)*ny*nz)
      pb=malloc(4*(nx/2+1)*ny*nz)

      i=1
      do 21 iz=1,nz
      do 21 iy=1,ny
      do 21 ix=1,nx,2
      a(i)=image(ix,iy,iz)
      b(i)=image(ix+1,iy,iz)
   21 i=i+1

      n1=nx/2
      n=n1*ny*nz
      call FFT(a,b,ny*nz,n1,1,-1)
      call REALT(a,b,ny*nz,n1,1,-1)
      call FFT(a(n+1),b(n+1),nz,ny,1,-1)
      call FFT(a(n+1),b(n+1),1,nz,ny,-1)
      call FFT(a,b,nz,ny,n1,-1)
      call FFT(a,b,1,nz,n1*ny,-1)

      i=1
      do 31 iz=1,nz
      if(iz.le.nz/2+1)then
        fz=float(iz-1)/(float(nz)*cmppix(3))
      else
        fz=float(nz-iz+1)/(float(nz)*cmppix(3))
      endif
      do 31 iy=1,ny
      if(iy.le.ny/2+1)then
        fy=float(iy-1)/(float(ny)*cmppix(2))
      else
        fy=float(ny-iy+1)/(float(ny)*cmppix(2))
      endif
      do 31 ix=1,n1
      fx=float(ix-1)/(float(nx)*cmppix(1))
      f=sqrt(fx**2+fy**2+fz**2)
      factor=1.-exp(-f/f0)
      a(i)=factor*a(i)
      b(i)=factor*b(i)
   31 i=i+1
      fx=0.5/cmppix(1)
      do 32 iz=1,nz
      if(iz.le.nz/2+1)then
        fz=float(iz-1)/(float(nz)*cmppix(3))
      else
        fz=float(nz-iz+1)/(float(nz)*cmppix(3))
      endif
      do 32 iy=1,ny
      if(iy.le.ny/2+1)then
        fy=float(iy-1)/(float(ny)*cmppix(2))
      else
        fy=float(ny-iy+1)/(float(ny)*cmppix(2))
      endif
      f=sqrt(fx**2+fy**2+fz**2)
      factor=1.-exp(-f/f0)
      a(i)=factor*a(i)
      b(i)=factor*b(i)
   32 i=i+1

      call FFT(a,b,1,nz,n1*ny,+1)
      call FFT(a,b,nz,ny,n1,+1)
      call FFT(a(n+1),b(n+1),1,nz,ny,+1)
      call FFT(a(n+1),b(n+1),nz,ny,1,+1)
      call REALT(a,b,ny*nz,n1,1,+1)
      call FFT(a,b,ny*nz,n1,1,+1)

      i=1
      do 29 iz=1,nz
      do 29 iy=1,ny
      do 29 ix=1,nx,2
      image(ix,iy,iz)=a(i)
      image(ix+1,iy,iz)=b(i)
   29 i=i+1

      call free(pa)
      call free(pb)

      return
      end


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine dt_evolve(it)
  use global_variables
  implicit none
  integer,intent(in) :: it
  integer,parameter :: Nexp=4
  integer :: iexp
  complex(zp) :: zfact

! Propagator = Taylor expantions
  zfact = 1d0
  ztmp_wfn=zwfn
  do iexp = 1,Nexp
    zfact = zfact*(-zI*dt)/dble(iexp)
    call zhpsi
    zwfn = zwfn + zfact*ztmp_hwfn
    ztmp_wfn = ztmp_hwfn
  end do

end subroutine dt_evolve