program transmission
    implicit none !Define Everything
    real :: a,K=9.0,lam=2.0,T,abs=100,lam2=4.0 !a = Incident Wave Vector; E = K^2; lam = \lambda; T = Transmission Amplitude; abs = Upper limit check for Transmission amplitude
    ! for which loop will terminate; lam2 = \lambda for 2nd peak
    integer :: i =180,M,j,Mmax=16 ! Mmax = Maximum number of matrix multiplication.
    complex :: cs,ct,z,z1,ctn,csn,cs2,ct2 !cs = Complex Resistance Amplitude; ct = complex inverse transmission amplitude, z = phase factor; z1 = complex conjugate of z
	!ct2, cs2 is for the 2nd barrier
	!ctn, csn are to keep continious count
    CALL SYSTEM("touch gnuscript.gnu") !creating the files in advance to prevent any error
    CALL SYSTEM("touch data.dat")

    open(1,file="data.dat",status="old")!Opening file for writing data

    !!!!!!!!!!!!!!!! Main Program starts here !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    do j=1,1000
        K = Float(j)/100.0

        do i = 100, 500
            cs = complex(0,-1*lam/K)
            cs2 = complex(0,-1*lam2/K)
            ct = (1,0)-cs
            ct2 = (1,0) - cs2
            a = Float(i)/100.0
            z = CExp(complex(0,K*a))
            z1 = CExp(complex(0,-1*K*a))
            ctn = z1*ct2*ct2 + z*(CAbs(cs2))**2
            csn = cs2*(z*(ct2*complex(1,-1))+z1*ct2)
            do M = 1, Mmax
		    if (MOD(M,2) == 1) then
		        ctn = z1*ctn*ct + z*csn*cs
		        csn = z*cs*ctn + z1*csn*ct
		        T = real(CAbs(ctn))
		        if ( T>abs) then !checking the value of transmission cofficient if more than abs then the solution is unbounded and exit the loop
		            ! write(1,*) K,a
		            exit
		        end if
		        if ( M==Mmax ) then
		            write(1,*) K,a
		        end if
		    end if
		    if(MOD(M,2)==0) then
		    	ctn = z1*ctn*ct2 + z*csn*cs2
		        csn = z*cs2*ctn + z1*csn*ct2
		        T = real(CAbs(ctn))
		        if ( T>abs) then !checking the value of transmission cofficient if more than abs then the solution is unbounded and exit the loop
		            ! write(1,*) K,a
		            exit
		        end if
		        if ( M==Mmax ) then
		            write(1,*) K,a
		        end if
		    end if
            end do
        end do
    end do

    !!!!!!!!!!!!!!! Main Program Ends Here !!!!!!!!!!!!!!!!!!!!!!!!!!

    close(1)

    !!!!!!!!!!!!!!! Gnuplot graphing starts here !!!!!!!!!!!!!!!!!!!!

    open(2,file="gnuscript.gnu",status="old") ! gnuscipt for plotting

    ! character :: filewrite = 'plot "data.dat" w p pt 7 ps 0.01 \n set xlabel "K" \n set ylabel "Incident wavevector a" \n set title "Plot of the bands using Kronig-Penney model"'
    ! ! filewrite = '

    write(2,*) "plot 'data.dat' w p pt 7 ps 0.1"
    write(2,*) "set xlabel 'K'"
    write(2,*) "set ylabel 'Incident wavevector a'"
    write(2,*) "set title 'Plot of the bands using Kronig-Penney model'"
    write(2,*) "pause 30" !To keep the interactive window
    close(2)

    CALL SYSTEM("gnuplot -persist gnuscript.gnu")
end program transmission

Quantum Transmission in Periodic Potential/q2.f95


      SUBROUTINE metrop(de,t,ans)
      REAL de,t
      LOGICAL ans
CU    USES ran3
      INTEGER jdum
      REAL ran3
      SAVE jdum
      DATA jdum /1/
      ans=(de.lt.0.0).or.(ran3(jdum).lt.exp(-de/t))
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/metrop.for


c=======================================================================
c
c     subroutine EIGENVD
c
c     Singular Value Decomposition   A = U * Diag(S) * VT
c
c-----------------------------------------------------------------------
      SUBROUTINE eigenvd (n, Q, dwork, D, U, info)
c-----------------------------------------------------------------------
c
c     INPUT
c       n : integer, size of matrix Q.
c       Q : (n,m)-double matrix.
c
c     WORKSPACE
c       dwork: double workspace of size n*n + 6*n + 4*n
c
c     OUTPUT
c       D: double (n)-vector of eigenvalues.
c       U: double (n,n)-matrix U.
c       info: integer,
c
c     CALL
c       YM, DGEEV (LAPACK)
c------------------------------------------------------------------------
c
      implicit none
c
c     i/o arguments
      INTEGER n, info
      DOUBLE PRECISION  Q(n,*), dwork(*), U(*), D(*)
c
c     local variables
      INTEGER lwork, ldvl, pdatmp, pdwork, pdwi, pdvl
c
      ldvl  = 1
      lwork = 4*n + 4*n
c
c     double workspace
      pdatmp = 1
c     pdatemp needs n*n
      pdwi = pdatmp + n*n
c     pdwi needs n
      pdvl = pdwi + n
c     pdwl needs n
      pdwork = pdvl + n
c     dwork needds n*n + 6*n + 4*n
c
c     matrix copy
      CALL YM(n, n, Q, dwork(pdatmp))
c
c     DGEEV computes for an N-by-N real nonsymmetric matrix
c     the eigenvalues and eigenvectors
      CALL DGEEV('N', 'V', n, dwork(pdatmp), n, D, dwork(pdwi),
     &           dwork(pdvl), ldvl, U, n, dwork(pdwork), lwork, info)
      RETURN
      END


SUBROUTINE FLEXEFT_CONT
use bio_MOD
implicit none
!INPUT PARAMETERS:
real :: tC,par_
!LOCAL VARIABLES of phytoplankton:
real :: PMUPHY,VARPHY,NO31,PHY1,ZOO1
real :: PMUPHY1,VARPHY1  !State variables
real :: larg
real :: PMU,VAR,PMU1,VAR1,X,B,dXdl,dBdl,KFe_,Fe,dmu0hatdl, d2mu0hatdl2
real :: V0hat,Kn,Lmin,A0N,A0N0, A0hat,dA0hatdl,d2A0hatdl2,fA
real :: VNhat,dVNhatdl,d2VNhatdl2 ! Nutrient uptake variables
real :: mu0hat,muIhat,mu0hatSI,dmu0hatSIdl,d2mu0hatSIdl2
real :: dmuIhatdl,d2muIhatdl2! Growth rate variables
real :: fV,dfVdl,d2fVdl2  !fV
real :: ZINT,dZINdl,d2ZINdl2 !ZINT
real :: aI,SI,dSIdl,d2SIdl2         !Light dependent component
real :: RMchl,Theta,ThetaHat,dThetaHatdl,d2ThetaHatdl2 !Chl related variables
real :: QN,Qs,dQNdl,d2QNdl2  ! cell quota related variables
real :: larg1,dmu0hat_aIdl,d2mu0hat_aIdl2,dlargdl
real :: d2largdl2,W_Y,dWYYdl,daI_mu0hatdl,d2aI_mu0hatdl2
real :: dV0hatdl,d2V0hatdl2,muNet,dmuNetdl,d2muNetdl2
real :: ThetaAvg,QNavg, dgdlbar,d2gdl2bar, alphaA
real :: Q0N,alphaQ,aI0,alphaI,Lref,Penfac
real :: alphaK, K0N
real :: NO3, PHY, ZOO, DET, DET1
!Declarations of zooplankton:
integer :: k,j

real :: pp_PN, pp_NP, PPpn
real :: pCHL(4) = 0d0
real,    external  :: pnorm, WAPR
!-----------------------------------------------------------------------
Ep     = params(iEp)
alphamu= params(ialphamu)
Ez     = params(iEz)

DO k = nlev, 1, -1
   ! Retrieve current (local) state variable values.
   tC     = Temp(k)
   ! Check whether in the MLD or not
   if (k .lt. N_MLD) then
      par_ = PAR(k)
   else
      par_ = PARavg
   endif

   NO3    = max(Vars(iNO3,k)   , 1D-10)
   PHY    = max(Vars(iPHY(1),k), 1D-10)
   PHY    = min(PHY,             1D+10)
   ZOO    = max(Vars(iZOO,k)   , 1D-10)
   DET    = max(Vars(iDET,k)   , 1D-10)
   PMUPHY = max(Vars(iPMU,k)   , 1D-10)
   VARPHY = max(Vars(iVAR,k)   , 1D-10)
!All rates have been multiplied by dtdays to get the real rate correponding to the actual time step
   tf_p   = TEMPBOL(Ep,tC)
   PMU    = min(PMUPHY/PHY, PMUmax)
   PMU    = PMU - log(1d1)  ! Correct PMU to the real one
   VAR    = min(VARPHY/PHY, VARmax)

! Fe related:
   if (do_IRON) then
!      Fe   = Vars(iFER,k)

      !Dissolved Fe concentration
      Fe   = max(Fe,Femin)

      !The half saturation constant of Fe at average size
      KFe_  = ScaleTrait(PMU, K0Fe,alphaFe)
   endif

   alphaQ  = params(ialphaQ)
   Q0N     = params(iQ0N)
   Qs      = ScaleTrait(PMU, Q0N, alphaQ)/2d0
   mu0hat  = dtdays*tf_p*mu0*exp(alphamu*PMU + betamu*PMU**2)
   X       = 0d0
   if (do_IRON) then
     mu0hat  = mu0hat * Fe/(Fe + KFe_)
     X       = alphaFe*KFe_/(Fe + KFe_)
   endif

   dmu0hatdl  = mu0hat*(alphamu + 2D0*betamu*PMU - X)
   d2mu0hatdl2= dmu0hatdl*(alphamu + 2D0*betamu*PMU-X) + mu0hat*2D0*betamu

   if (do_IRON) d2mu0hatdl2 = d2mu0hatdl2 - mu0hat*alphaFe*Fe*X/(Fe+KFe_)

   ! Iron limits nitrogen uptake

   !V0N    = params(iV0N)
   !alphaV = params(ialphaV)
   V0hat  = ScaleTrait(PMU, dtdays*tf_p*V0N, alphaV)

   if (do_IRON) V0hat = V0hat*Fe/(Fe + KFe_)

   dV0hatdl   = V0hat*(alphaV- X)
   d2V0hatdl2 = dV0hatdl*(alphaV - X)

   if (do_Iron) d2V0hatdl2 = d2V0hatdl2 - V0hat*alphaFe*Fe*X/(Fe+KFe_)

   ! Initial slope of P-I curve
   aI0    = params(iaI0)
   alphaI = params(ialphaI)
   aI     = ScaleTrait(PMU, dtdays*aI0, alphaI)

   ! Cost of photosynthesis
   RMchl  = tf_p*RMchl0*dtdays

   ! Threshold irradiance and RMchl is set temperature dependent
   I_zero = zetaChl*RMchl/aI

   !Define VNhat: the saturation function of ambient nutrient concentration
   SELECTCASE(nutrient_uptake)
   ! case 1: Classic Michaelis Menton
   case(1)
   ! Potential maximal nutrient-limited uptake
   ! Half-saturation constant of nitrate uptake
    alphaK = params(ialphaK)
    K0N    = params(iKN)
    Kn     = ScaleTrait(PMU,K0N, alphaK)
    VNhat  = V0hat*NO3/(NO3 + Kn)

    dVNhatdl  = -VNhat*alphaK*Kn/(NO3+Kn) + NO3/(NO3 + Kn)*dV0hatdl

     d2VNhatdl2 = -alphaK*(VNhat * alphaK * NO3/(NO3+Kn)**2*Kn          &
   + Kn/(NO3 + Kn)*dVNhatdl)+ NO3/(NO3+ Kn)*d2V0hatdl2                  &
   - dV0hatdl*NO3/(NO3 + Kn)**2*alphaK*Kn

     ! case 2: optimal uptake based on Pahlow (2005) and Smith et al. (2009)
   case(2)

     Lref  = 0.5       !params(iLref)
     !Penfac= params(iPenfac)
     Penfac= 1d0
     alphaA= params(ialphaA)

     Lmin  = log(Lref**3/6d0*pi) + log(1d0+Penfac)/( Penfac*alphaA)

     A0N0  = params(iA0N)
     A0N   = dtdays*tf_p*A0N0
     A0hat = PenAff(PMU, alphaA, Penfac,Lmin)*ScaleTrait(PMU,A0N,alphaA)
     A0hat = max(A0hat,1D-9*A0N)  ! Maintain positivity

     dA0hatdl = alphaA*A0hat-A0N*exp(PMU*alphaA)*Penfac*alphaA           &
             * exp(Penfac*alphaA *(PMU-Lmin))

     d2A0hatdl2 = alphaA*dA0hatdl                                        &
             - Penfac*alphaA*exp(alphaA*((1d0+Penfac)*PMU-Penfac*Lmin))  &
             * (dA0hatdl + A0hat*alphaA*(1d0+Penfac))

             !Define fA
      fA    = min(1D0/( 1D0 + sqrt(A0hat * NO3/V0hat) ), 0.9999D0 )
      VNhat = (1D0-fA)*V0hat*fA*A0hat*NO3/((1D0-fA)*V0hat+fA*A0hat*NO3)
      VNhat = max(V0hat,1D-9*V0hat)

      !X: temporary variable
      X    = V0hat/A0hat + 2d0*sqrt(V0hat*NO3/A0hat) + NO3

      !B: d(V0/A0)dl
      B    = dV0hatdl/A0hat - V0hat/A0hat**2*dA0hatdl

      dXdl = B*(1d0 + sqrt(NO3*A0hat/V0hat))

      dBdl = d2V0hatdl2/A0hat - dV0hatdl*dA0hatdl/A0hat**2              &
       - (V0hat/A0hat**2*d2A0hatdl2                                     &
       +  dA0hatdl*(dV0hatdl/A0hat**2 - 2d0*V0hat*dA0hatdl/A0hat**3))

      dVNhatdl = NO3*(dV0hatdl/X-V0hat/X**2*B*(1d0+ sqrt(NO3*A0hat/V0hat) ) )

      d2VNhatdl2 = NO3*(d2V0hatdl2/X - dV0hatdl*dXdl/X**2               &
       - (V0hat/X**2*B*(-sqrt(NO3)/2d0*(A0hat/V0hat)                    &
       * sqrt(A0hat/V0hat) * B)                                         &
       + B*(1d0 + sqrt(NO3*A0hat/V0hat) )                               &
       * (dV0hatdl/X**2 - 2d0*V0hat*dXdl/X**3)                          &
       + V0hat/X**2*(1d0+sqrt(NO3*A0hat/V0hat))*dBdl))

   CASE DEFAULT
      write(6,*) 'Error: Incorrect option for nutrient uptake!'
      STOP
   ENDSELECT

! Calculate thetahat (optimal g Chl/mol C for the chloroplast under nutrient replete conditions)
! Only calculate within the euphotic zone, otherwise many numerical problems.

      if( par_ .gt. I_zero ) then

        larg1 = exp(1d0 + min(aI*par_/(mu0hat*zetaChl),6d2))
        larg  = (1d0 + RMchl/mu0hat)*larg1
        dmu0hat_aIdl   = (dmu0hatdl - alphaI*mu0hat)/aI
        d2mu0hat_aIdl2 = d2mu0hatdl2/aI -alphaI/aI*dmu0hatdl-aI*dmu0hat_aIdl
        daI_mu0hatdl   = -(aI/mu0hat)**2*dmu0hat_aIdl

        d2aI_mu0hatdl2 = -((aI/mu0hat)**2*d2mu0hat_aIdl2                 &
       - 2d0/((mu0hat/aI)*(mu0hat/aI)*(mu0hat/aI))                       &
       * (dmu0hat_aIdl)**2    )

        dlargdl = -RMchl*larg1/(mu0hat**2)*dmu0hatdl                     &
       + (1d0+RMchl/mu0hat)*larg1 * par_/zetaChl*daI_mu0hatdl

        d2largdl2 = -RMchl*(larg1/(mu0hat*mu0hat)*d2mu0hatdl2            &
       + larg1*par_/zetaChl*daI_mu0hatdl/(mu0hat*mu0hat)*dmu0hatdl       &
       + larg1*dmu0hatdl*(-2d0/(mu0hat*mu0hat*mu0hat)*dmu0hatdl))        &
       + par_/zetaChl*((1.+RMchl/mu0hat)*larg1*d2aI_mu0hatdl2            &
       + (1.+RMchl/mu0hat)*larg1*par_/zetaChl*daI_mu0hatdl*daI_mu0hatdl  &
       + RMchl*(-dmu0hatdl/(mu0hat*mu0hat))*larg1*daI_mu0hatdl)

       W_Y      = WAPR(larg)
       ThetaHat = 1d0/zetaChl + (1d0- W_Y)*mu0hat/(aI * par_)

       dThetaHatdl = 1d0/par_*(-W_Y/larg/(1.+W_Y)*dlargdl*mu0hat/aI      &
     +  (1d0-W_Y)*dmu0hat_aIdl)

       dWYYdl = dlargdl*(-W_Y**2/(larg*larg)/((1d0+W_Y)*(1.+W_Y)*(1.+W_Y))  &
       -  W_Y/larg**2/(1d0+W_Y) + W_Y/(larg*(1d0+W_Y))**2)

       d2ThetaHatdl2 = 1d0/par_*(-(W_Y/larg/(1d0+W_Y)*dlargdl*dmu0hat_aIdl  &
       +  W_Y/larg/(1d0+W_Y)*d2largdl2*mu0hat/aI   &
       +  dWYYdl*dlargdl*mu0hat/aI)               &
       -  W_Y/larg/(1d0+W_Y)*dlargdl * dmu0hat_aIdl &
       +  (1d0-W_Y)*d2mu0hat_aIdl2)

        SI = 1d0 - max(exp(-aI*par_*ThetaHat/mu0hat),0d0)

        dSIdl = ( (alphaI- dmu0hatdl/mu0hat)   &
        * ThetaHat + dThetaHatdl) * (1d0-SI)*aI*par_/mu0hat    !confirmed

       d2SIdl2 = par_*(- dSIdl*aI/mu0hat*(ThetaHat*alphaI     &
      - ThetaHat/mu0hat*dmu0hatdl + dThetaHatdl) + (1d0-SI)   &
      * (ThetaHat*alphaI- ThetaHat/mu0hat*dmu0hatdl + dThetaHatdl) &
      * daI_mu0hatdl + (1d0-SI)*aI/mu0hat*(                 &
      - (d2mu0hatdl2/mu0hat - dmu0hatdl**2/mu0hat**2)*ThetaHat  &
      + (alphaI-dmu0hatdl/mu0hat)*dThetaHatdl + d2ThetaHatdl2)  )

       ! Light dependent growth rate
       ! (needs to take into account the cost of dark and light-dependent chl maintenance)
       mu0hatSI = mu0hat*SI  ! Gross specific carbon uptake (photosynthesis)
       muIhat   = mu0hatSI-(mu0hatSI+RMchl)*zetaChl*ThetaHat ! Net specific carbon uptake
       muIhat   = max(muIhat,1D-10*mu0hatSI)

       dmu0hatSIdl   = SI*dmu0hatdl + mu0hat*dSIdl
       d2mu0hatSIdl2 = d2mu0hatdl2*SI+2d0*dmu0hatdl*dSIdl+mu0hat*d2SIdl2 !Correct
       dmuIhatdl = (1D0-zetaChl*ThetaHat)*dmu0hatSIdl - dThetaHatdl*zetaChl*(mu0hatSI+RMchl) !Correct

       d2muIhatdl2=d2mu0hatSIdl2                                      &
       -zetaChl*(ThetaHat*d2mu0hatSIdl2+2d0*dThetaHatdl*dmu0hatSIdl   &
       +mu0hatSI*d2ThetaHatdl2)-zetaChl*RMchl*d2ThetaHatdl2   !Correct

       ZINT   = Qs*(muIhat/VNhat + zetaN)

       dZINdl = Qs*(dmuIhatdl/VNhat - muIhat*dVNhatdl/VNhat**2)+alphaQ*ZINT

       d2ZINdl2 = Qs/VNhat*((alphaQ-dVNhatdl/VNhat)*dmuIhatdl &
       + d2muIhatdl2) - Qs/VNhat**2*(muIhat*d2VNhatdl2        &
       + dVNhatdl*(dmuIhatdl+alphaQ*muIhat-2d0*muIhat          &
       / VNhat*dVNhatdl)) + alphaQ*dZINdl

       fV = (-1d0 + sqrt(1d0 + 1d0/ZINT))*Qs*muIhat/VNhat
       fV = max(fV, 0.01)
    !
       else
    ! Under the conditions of no light:
          ThetaHat      = 0.01  !  a small positive value
          dThetaHatdl   = 0d0
          d2ThetaHatdl2 = 0d0
          ZINT          = Qs*zetaN
          dZINdl        = alphaQ*ZINT
          d2ZINdl2      = alphaQ*dZINdl
          fV            = 0.01
          muIhat        = 0d0
          dmuIhatdl     = 0d0
          d2muIhatdl2   = 0d0
       endif

          ! Optimal nutrient quota:
       QN = (1d0+ sqrt(1d0+1d0/ZINT))*Qs

       dQNdl  = alphaQ*QN-dZINdl*Qs/(2d0*ZINT*sqrt(ZINT*(1d0+ZINT))) !confirmed

       d2QNdl2 = alphaQ*dQNdl - Qs/(2d0*ZINT*sqrt(ZINT*(ZINT+1d0)))  &
        *(d2ZINdl2+alphaQ*dZINdl-(2d0*ZINT+1.5d0)/(ZINT*(ZINT+1d0))*dZINdl**2)      ! Confirmed

       dfVdl = alphaQ*Qs*(1d0/QN+2d0*zetaN)-(zetaN+Qs/QN**2)*dQNdl  !Confirmed

       d2fVdl2 = (alphaQ**2)*Qs*(1d0/QN + 2d0*zetaN)                    &
         -  2d0*alphaQ*Qs*dQNdl/(QN*QN) + 2d0*(dQNdl**2)*Qs/(QN*QN*QN)    &
         -     (zetaN + Qs/(QN*QN)) * d2QNdl2  ! Confirmed

       if (par_ .gt. I_zero) then
        !Net growth rate (d-1) of phytoplankton at the average size
          !muNet = muIhat*X - zetaN*fV*VNhat
          muNet = muIhat*(1D0 - 2D0 * Qs/QN)

!Here the derivative of muNet includes respiratory costs of both N Assim and Chl maintenance
          dmuNetdl = muIhat*(Qs/(QN**2)*dQNdl                           &
      -  alphaQ*Qs/QN-dfVdl) +  X*dmuIhatdl                             &
      -  zetaN*(fV*dVNhatdl+VNhat*dfVdl)

         d2muNetdl2 = (Qs/(QN*QN))*dQNdl*dmuIhatdl                      &
     + muIhat*(Qs/QN**2)*(dQNdl*(alphaQ - 2d0*dQNdl/QN) + d2QNdl2)      &
     - (alphaQ*(Qs/QN*(dmuIhatdl + alphaQ*muIhat)                       &
     - muIhat*Qs/(QN**2)*dQNdl))                                        &
     - (muIhat*d2fVdl2+dfVdl*dmuIhatdl)                                 &
     + dmuIhatdl*(Qs/(QN**2)*dQNdl-alphaQ*Qs/QN-dfVdl)  &
     + X*d2muIhatdl2                   &
     - zetaN*(fV*d2VNhatdl2 + 2d0*dfVdl*dVNhatdl + VNhat*d2fVdl2)  !dC

       else

        muNet      = 0d0
        dmuNetdl   = 0d0
        d2muNetdl2 = 0d0
       endif
          X  = 1d0-fV-Qs/QN
!  chl:C ratio [ g chl / mol C ] of the whole cell, at the mean cell size
       Theta = ThetaHat*X
! Calculate the mean chl:C ratio of phytoplankton (averaged over all sizes)
    ! using the second derivative of the cell quota w.r.t. log size. (Why negative?)
       ThetaAvg = max(Theta + (VAR/2d0)*(d2ThetaHatdl2*X                &
       - ThetaHat*(d2fVdl2 + Qs*(dQNdl**2*(2d0/QN)-d2QNdl2)/(QN*QN))),  &
       params(ithetamin))

      if (ThetaAvg .le. 0.01 .and. k .lt. nlev) then
        ThetaAvg = Varout(oTheta(1),k+1)
     endif

    ! Calculate the mean N:C ratio of phytoplankton (averaged over all sizes)
    ! using the second derivative of the cell quota w.r.t. log size. (How to derive?)
     QNAvg = max(QN/(1d0+((2d0/QN)*dQNdl**2 - d2QNdl2)*VAR/(2d0*QN)),   &
        params(iQNmin))
!=============================================================
  !  ! Calculate the community sinking rate of phytoplankton
  !  ! Phytoplankton sinking rate at the average size
  !  w_p    = ScaleTrait(PMU,abs(w_p0),alphaW)  !Positive

  !  ! Constrain the sinking rate not too large for large cells (Smayda 1970)
  !  w_p    = min(w_p, Wmax)
  !  dwdl   = alphaW*w_p
  !  d2wdl2 = alphaW*dwdl

  !! Sinking rate (m) of phytoplankton
  !  w_pAvg = w_p+0.5*VAR*d2wdl2
  !! sinking rate must be negative!
  !  w_pAvg = -min(w_pAvg, Wmax)

!=============================================================
!! ZOOplankton section:
   tf_z = TEMPBOL(Ez,tC)

!   ! The grazing dependence on total prey
   gbar = grazing(grazing_formulation,params(ikp),PHY)

   !Zooplankton per capita total ingestion rate
    INGES = tf_z*dtdays*params(igmax)*gbar

   !Zooplankton excretion rate (-> DOM)
   RES = INGES*(1d0-GGE-unass)

   !ZOOPLANKTON EGESTION (-> POM)
   EGES = INGES*unass

! Grazing rate on the mean size of PHY (specific to N-based Phy biomass, unit: d-1) (Eq. 12)
   gbar      = INGES*ZOO/PHY*sqrt(params(ialphaG))
   dgdlbar   = 0d0
   d2gdl2bar = (1d0-params(ialphaG))/VAR*gbar
!!End of zooplankton section
!=============================================================
!! Solve ODE functions:
   Zmort = ZOO*ZOO*dtdays*params(imz)*tf_z  !Mortality term for ZOO

   if (d2gdl2bar .lt. 0d0) then
      VAR1 = VAR*(1d0-VAR*d2gdl2bar)
   else
      VAR1 = VAR/(1d0+VAR*d2gdl2bar)
   endif

   ! Update PMU and VAR:
   if (d2muNetdl2 .gt. 0d0) then
! self%dVARdt=VAR*VAR*(self%d2muNetdl2- self%d2gdl2bar-self%d2wdl2)  !Eq. 19
      VAR1 =VAR1*(1d0+VAR*d2muNetdl2)
   else
      VAR1 =VAR1/(1d0-VAR*d2muNetdl2)
   endif
!   VAR1    =VAR1/(1d0+VAR*d2wdl2)

   !Eq. 18, Update PMU:
   !   self%dPMUdt = self%p%VAR*(self%dmuNetdl - self%dgdlbar - self%dwdl)
   PMU = PMU + log(1D1)  ! Restore to positive values
   if (dmuNetdl .gt. 0d0) then
      PMU1 = PMU  + VAR * dmuNetdl
   else
      PMU1 = PMU/(1d0-VAR/PMU*dmuNetdl)
   endif

!   PMU1 = PMU1/(1d0 + VAR/PMU*dwdl)
   !Contrain the PMU and VAR:
   PMU1 = min(max(PMU1,0.01),PMUmax)
   VAR1 = min(max(VAR1,0.01),VARmax)

    ! For production/destruction matrix:

   pp_ND=dtdays*params(irDN)*DET*tf_z
   pp_NZ=ZOO*RES
   pp_DZ=ZOO*EGES+Zmort
   pp_ZP=ZOO*INGES
   PPpn =PHY*(muNet + 0.5*VAR*d2muNetdl2)
   pp_PN=max(0.5*( PPpn + abs(PPpn)), 0d0)
   pp_NP=max(0.5*(-PPpn + abs(PPpn)), 0d0)
   DET1 = (DET + pp_DZ)/(1d0 + dtdays*params(irDN)*tf_z)
   DET1 = max(DET1,1D-16)
   NO31 = (NO3+pp_ND+pp_NZ+pp_NP)/(1d0+pp_PN/NO3)

   PHY1 = (PHY+pp_PN)/(1d0+(pp_ZP+pp_NP )/PHY)
   ZOO1 = (ZOO+pp_ZP)/(1d0+ EGES+ZOO*dtdays*params(imz)*tf_z+RES)

   PMUPHY1 =(PMUPHY+PHY*PMU1+PMU*PHY1)/(1d0+ 2d0*PHY*PMU/PMUPHY)
   VARPHY1 =(VARPHY+PHY*VAR1+VAR*PHY1)/(1d0+ 2d0*PHY*VAR/VARPHY)

   Varout(oNO3,k)   = NO31
   Varout(oPHY(1),k)= PHY1
   Varout(oZOO,k)   = ZOO1

   ! Calculate total CHL:
   Varout(oCHLt,k)  = PHY1 / QNAvg * ThetaAvg
   Varout(oCHL(1),k)= Varout(oCHLt,k)
   Varout(oPPt,k)   = pp_PN/ QNAvg / dtdays
   Varout(oDET,k)   = DET1
   Varout(oPMU,k)   = PMUPHY1
   Varout(oVAR,k)   = VARPHY1

   if(do_IRON) Varout(oFER,k) = Fe

   Varout(oTheta(1),k) = ThetaAvg
   Varout(oQN(1)   ,k) = QNAvg
   Varout(omuNet(1),k) = PP_PN/dtdays/PHY
   Varout(oGraz(1) ,k) = PP_ZP/dtdays/PHY
   Varout(oZ2N     ,k) = PP_NZ/dtdays
   Varout(oD2N     ,k) = PP_ND/dtdays
   Varout(odmudl   ,k) = dmuNetdl/dtdays
   Varout(od2mu    ,k) = d2muNetdl2/dtdays
   Varout(od2gdl   ,k) = d2gdl2bar/dtdays
   !Varout(ow_p(1)  ,k) = w_pAvg  !Should not corrected by dtdays

   ! Calculate size-fractionated Chl
   ! Calculate the proportions of different phyto size fractions
   ! Here the PMU1 is already the normal PMU + log(10) (to avoid negative values)
   pCHL(4) = pnorm(PMU_1 , PMU1, sqrt(VAR1))
   pCHL(3) = pnorm(PMU_3 , PMU1, sqrt(VAR1))
   pCHL(2) = pnorm(PMU_10, PMU1, sqrt(VAR1))
   pCHL(1) = 1d0    -pCHL(2)
   pCHL(2) = pCHL(2)-pCHL(3)
   pCHL(3) = pCHL(3)-pCHL(4)
   do j = 1, 4
      !Varout(oCHLs(j),k) = pCHL(j) * Varout(oCHLt,k) ! Absolute concentration
      Varout(oCHLs(j),k) = pCHL(j) ! Percentage of one size class
   enddo

ENDDO
END SUBROUTINE FLEXEFT_CONT


	    SUBROUTINE MR_INTZ  ( nlev, ipt, stndat, iret )
C************************************************************************
C* MR_INTZ								*
C*									*
C* This subroutine computes heights for significant temperature data	*
C* by interpolating mandatory heights linearly with respect to log p.	*
C* Any heights that cannot be interpolated (i.e., at levels above the	*
C* top mandatory level) are computed using the moist hydrostatic 	*
C* height.								*
C*									*
C* MR_INTZ  ( NLEV, IPT, STNDAT, IRET )				*
C*									*
C* Input parameters:							*
C*	NLEV		INTEGER		Number of levels		*
C*	IPT    ( NLEV )	INTEGER		Pointers to ordered data	*
C*									*
C* Input and output parameters:						*
C*	STNDAT (6,NLEV)	REAL		Station data			*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 9/87	Rewritten for GEMPAK4			*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		stndat (6,*)
	INTEGER		ipt (*)
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret =  0
	IF  ( nlev .le. 1 )  RETURN
C
C*	Find the top wind which contains height.
C
	maxlev = 0
	ilev   = nlev
	DO WHILE  ( ilev .ge. 1 )
	    IF  ( .not. ERMISS ( stndat ( 6, ipt (ilev) ) ) )  THEN
		maxlev = ilev
		ilev   = 0
	      ELSE
		ilev   = ilev - 1
	    END IF
	END DO
C
C*	Interpolate all levels up to MAXLEV.
C
	pbot = RMISSD
	DO  i = 1, maxlev
C
C*	    Get pressure and height at this level.
C
	    pres = stndat ( 1, ipt ( i ) )
	    hght = stndat ( 6, ipt ( i ) )
C
C*	    Skip data if there is no pressure (only surface).
C
	    IF  ( ERMISS ( pres ) )  THEN
C*		! Ignore.
C
C*		If height is not missing, use this as bottom level.
C
	      ELSE IF  ( .not. ERMISS ( hght ) )  THEN
		pbot = pres
		hbot = hght
		ptop = 2000.0
C
C*		Skip level if no lower bounding level has been found.
C
	      ELSE IF  ( ERMISS ( pbot ) )  THEN
C*		! Ignore level
C
C*		Otherwise, try to interpolate data.
C
	      ELSE
C
C*		Find next level with height.
C
		ilev = i + 1
		DO WHILE  ( pres .le. ptop )
		    IF ( .not. ERMISS ( stndat (6,ipt(ilev) ))) THEN
			ptop = stndat ( 1, ipt (ilev) )
			htop = stndat ( 6, ipt (ilev) )
		      ELSE
			ilev = ilev + 1
		    END IF
		END DO
C
C*		Interpolate data if a level was found.
C
		stndat ( 6, ipt (i) ) = hbot + ( htop - hbot ) *
     +			  ( ALOG ( pres/pbot )  /  ALOG ( ptop/pbot ) )
	    END IF
	END DO
C
C*	Check for missing heights in sounding.  Replace with moist
C*	hydrostatic height.
C
C*	Check if sounding is complete.
C
	IF  ( maxlev .ge. nlev )  RETURN
C
C*	Get variables at MAXLEV.
C
	IF  ( maxlev .gt. 0 )  THEN
	    pb  = stndat ( 1, ipt ( maxlev ) )
	    hb  = stndat ( 6, ipt ( maxlev ) )
	    tb  = stndat ( 2, ipt ( maxlev ) )
	    tdb = stndat ( 3, ipt ( maxlev ) )
	  ELSE
	    pb  = RMISSD
	    hb  = RMISSD
	    tb  = RMISSD
	    tdb = RMISSD
	END IF
C
C*	Loop through remaining levels and compute hydrstatic height.
C
	DO  i = maxlev + 1, nlev
	    IF  ( ERMISS ( stndat ( 6, ipt (i) ) ) )  THEN
		tt  = stndat ( 2, ipt (i) )
		tdt = stndat ( 2, ipt (i) )
		pt  = stndat ( 1, ipt (i) )
		stndat (6, ipt(i) ) = PC_MHGT (tb,tt,tdb,tdt,pb,pt,hb)
	    END IF
C
C*	    Reset bottom level.
C
	    IF  ( ( .not. ERMISS ( stndat ( 2, ipt (i) ) ) ) .and.
     +		  ( .not. ERMISS ( stndat ( 6, ipt (i) ) ) ) )  THEN
		pb  = stndat ( 1, ipt (i) )
		tb  = stndat ( 2, ipt (i) )
		tdb = stndat ( 3, ipt (i) )
		hb  = stndat ( 6, ipt (i) )
	    END IF
	END DO
C*
	RETURN
	END


Subroutine stabenerg(npoint,dens,told,tnew,qold,qnew,D7e,D7q,Cji,dt)

implicit none

Integer,parameter	:: npt=500
Integer			:: npoint,i
Real			:: Cji,dt
Real,parameter		:: omega=.9
Real, dimension(npoint)	:: dens,told,tnew,qold,qnew,d7e,d7q
Real, dimension(npt)	:: a1,a2,d1,d2
Real, dimension(npt)	:: x1,x2,y1,y2,cf

Real, dimension(npt)	::LO,LN(NPT),AH,RLN,LH,RLH,ROH,RNH,ADUGTH
Common  /FCT_GRID/ LO, LN, AH, RLN, LH, RLH, ROH, RNH, ADUGTH

cf(1:npoint)=Cji*dt*omega*RLN(1:npoint)

y1(1:npoint:2)=(tnew(1:npoint:2)-told(1:npoint:2))*dens(1:npoint:2)*omega
!y1(1:npoint:2)=(tnew(1:npoint:2)-told(1:npoint:2))*omega
y1(2:npoint:2)=(qnew(2:npoint:2)-qold(2:npoint:2))*omega

d1(1:npoint:2)=1.-dt*D7e(1:npoint:2)
d1(2:npoint:2)=1.-dt*D7q(2:npoint:2)
a1(1:npoint:2)=cf(1:npoint:2)/3.
a1(2:npoint:2)=1.25*told(2:npoint:2)*cf(2:npoint:2)
!a1(1:npoint:2)=cf(1:npoint:2)/3./dens(1:npoint:2)
!a1(2:npoint:2)=1.25*told(2:npoint:2)*dens(2:npoint:2)*cf(2:npoint:2)

y2(1:npoint:2)=(qnew(1:npoint:2)-qold(1:npoint:2))*omega
y2(2:npoint:2)=(tnew(2:npoint:2)-told(2:npoint:2))*dens(2:npoint:2)*omega
!y2(2:npoint:2)=(tnew(2:npoint:2)-told(2:npoint:2))*omega

d2(1:npoint:2)=1.-dt*D7q(1:npoint:2)
d2(2:npoint:2)=1.-dt*D7e(2:npoint:2)
a2(1:npoint:2)=1.25*told(1:npoint:2)*cf(1:npoint:2)
a2(2:npoint:2)=cf(2:npoint:2)/3.
!a2(1:npoint:2)=1.25*told(1:npoint:2)*dens(1:npoint:2)*cf(1:npoint:2)
!a2(2:npoint:2)=cf(2:npoint:2)/3./dens(2:npoint:2)

y1(2:npoint-1)=d1(2:npoint-1)*y1(2:npoint-1)
y2(2:npoint-1)=d2(2:npoint-1)*y2(2:npoint-1)

d1(1)=1.
a1(1)=0.

d2(1)=1.
a2(1)=0.

do i=2,npoint-1
  d1(i)=d1(i)+a1(i)*a1(i-1)
  y1(i)  =(y1(i)  +a1(i)*y1(i-1))/d1(i)
  a1(i)=a1(i)/d1(i)

  d2(i)=d2(i)+a2(i)*a2(i-1)
  y2(i)  =(y2(i)  +a2(i)*y2(i-1))/d2(i)
  a2(i)=a2(i)/d2(i)
enddo

x1(1:npoint)=y1(1:npoint)
x2(1:npoint)=y2(1:npoint)

do i=npoint-1,2,-1
  x1(i)=y1(i)-a1(i)*x1(i+1)
  x2(i)=y2(i)-a2(i)*x2(i+1)
enddo

y2=x2
x2(2:npoint:2)=x1(2:npoint:2)
x1(2:npoint:2)=y2(2:npoint:2)

tnew(2:npoint-1)=told(2:npoint-1)+x1(2:npoint-1)/dens(2:npoint-1)/omega
!tnew(2:npoint-1)=told(2:npoint-1)+x1(2:npoint-1)/omega
qnew(2:npoint-1)=qold(2:npoint-1)+x2(2:npoint-1)/omega

return

End subroutine stabenerg


C$Procedure   LSTLEI ( Last integer element less than or equal to )

      INTEGER FUNCTION  LSTLEI ( X, N, ARRAY )

C$ Abstract
C
C      Given a number X and an array of non-decreasing numbers,
C      find the index of the largest array element less than or equal
C      to X.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C      SEARCH,  ARRAY
C
C$ Declarations

      INTEGER          X
      INTEGER          N
      INTEGER          ARRAY ( * )

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C      X          I   Value to search against.
C      ARRAY      I   Array of possible lower bounds.
C      N          I   Number elements in ARRAY.
C      LSTLEI     O   the index of the last element of ARRAY <= X.
C
C$ Detailed_Input
C
C      X       Integer for which one desires to find
C              the last ARRAY element less than or equal to X.
C
C      ARRAY   Array of integers that forms a
C              non-decreasing sequence.  We will find the last element
C              of the sequence that is less than or equal to X.
C
C      N       Total number of elements in ARRAY
C
C$ Detailed_Output
C
C      LSTLEI  Index of the last element of the non-decreasing sequence:
C              {ARRAY(I) : 0 < I < N + 1} that is less than or equal
C              to X. (Note that LSTLEI = I for some I in the range 1 to
C              N  unless X is less than all of these elements in which
C              case LSTLEI = 0.)
C
C              In the case that N is input with value less than or equal
C              to zero, LSTLEI is returned as zero.
C
C$ Parameters
C
C      None.
C
C$ Particulars
C
C
C      An array of integers is given.  The array
C      ARRAY(I) (0 < I < N ) forms a non-decreasing sequence of
C      numbers.  Given a real number X, there will be a last one of
C      these numbers that is less than or equal to X.  This routine
C      finds the index LSTLEI such that ARRAY(LSTLEI) is that number.
C
C      If X is not greater than ARRAY(1), INDEX will be set to zero.
C
C      This routine uses a binary search algorithm and so requires
C      at most LOG_2(N) steps to find the value of LSTLEI.
C
C      Note:  If you need to find the first element of the array that
C             is greater than X, simply add 1 to the result returned
C             by this function and check to see if the result is
C             within the array bounds given by N.
C
C$ Examples
C
C     Suppose that you have an reasonably large ordered array of
C     integers, into which you want to insert a few more without
C     destroying the ordering.
C
C     Depending upon your application, it may be desirable to
C     not insert duplicates, to insert duplicates before
C     existing entries or to insert them after existing entries.
C
C     The code fragment below, illustrates an insertion scheme
C     that will insert duplicate items after existing items
C     and simultaneously update a second parallel array of
C     double precision numbers.
C
C           get the pair to insert
C
C           READ (*,*) KEY, VALUE
C
C           locate the place to insert the new KEY into the sorted
C           array of keys.
C
C           LOC = LSTLEI ( KEY, NKEYS, KEYS ) + 1
C
C           insert the key and its associated value into the
C           KEYS and  VALUES arrays at location LOC
C
C           CALL INSLAI ( KEY,   1, LOC, NKEYS, KEYS   )
C           CALL INSLAD ( VALUE, 1, LOC, NVALS, VALUES )
C
C     If at the READ statement the arrays KEYS and VALUES looked like:
C
C           KEYS     VALUES     NKEYS = 6, NVALS = 6
C           ----     -------
C             2       3.00D0
C             5       1.00D0
C             7       3.14D0
C            16       7.11D0
C            18       2.14D0
C            23      12.12D0
C
C     and 9 and 33.33D3 were read into KEY and VALUE respectively
C     then LSTLEI (KEY, NKEYS, KEYS ) would be 3 and LOC would be 4.
C     After the calls to the routines INSLAI and INSLAD we would have
C
C           KEYS     VALUES     NKEYS = 7, NVALS = 7
C           ----     -------
C             2       3.00D0
C             5       1.00D0
C             7       3.14D0
C             9      33.33D3     <===== inserted items.
C            16       7.11D0
C            18       2.14D0
C            23      12.12D0
C
C     If 7 and 33.33D3 were read into KEY and VALUE respectively
C     then again LSTLEI (KEY, NKEYS, KEYS ) would be 3 and LOC would
C     be 4. After the calls to the routines INSLAI and INSLAD we
C     would have:
C
C           KEYS     VALUES     NKEYS = 7, NVALS = 7
C           ----     -------
C             2       3.00D0
C             5       1.00D0
C             7       3.14D0
C             7      33.33D3     <===== inserted items.
C            16       7.11D0
C            18       2.14D0
C            23      12.12D0
C
C     If we replaced the line of code
C
C           LOC = LSTLEI ( KEY, NKEYS, KEYS ) + 1
C     by
C
C           LOC = LSTLTI ( KEY, NKEYS, KEYS ) + 1
C
C     we would obtain a routine that inserted duplicates before
C     existing entries. (LSTLTI is similar to LSTLEI except it finds
C     the last occurrance of an integer strictly less than a value.)
C     Using 7 and 33.33D3 for KEY and VALUE again, the modified code
C     fragment would yield the results shown below.
C
C           KEYS     VALUES     NKEYS = 7, NVALS = 7
C           ----     -------
C             2       3.00D0
C             5       1.00D0
C             7      33.33D3     <===== inserted items.
C             7       3.14D0
C            16       7.11D0
C            18       2.14D0
C            23      12.12D0
C
C
C     (Note: you should NOT use the
C     code outlined above as the basis of a sorting algorithm.
C     The NAIF routines SHELLI, SHELLD, SHELLC, ORDERI, ORDERD, ORDERC,
C     REORDI, REORDD and REORDC are much more efficient routines for
C     sorting arrays or sorting a set of parallel arrays using
C     one of the set as a key. The fragment presented here is useful
C     for performing update insertions into previously ordered arrays.)
C
C     For more ideas regarding the use of this routine, see LSTLEC
C     and LSTLTC.
C
C$ Restrictions
C
C      If the sequence does not non-decreasing, the program will run
C      to completion but the index found will not mean anything.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C      None.
C
C$ Author_and_Institution
C
C      H.A. Neilan     (JPL)
C      W.L. Taber      (JPL)
C
C$ Literature_References
C
C      None.
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     last integer element less_than_or_equal_to
C
C-&

C$ Revisions
C
C-    Beta Version 1.1.0, 9-MAR-1989 (HAN)
C
C        Declaration of the variable I was removed from the code. The
C        variable was declared but not used.
C
C-     Beta Version 1.0.1, 1-Feb-1989 (WLT)
C
C      Example section of header upgraded.
C
C-&

C
C     Local variables
C
      INTEGER          J

      INTEGER          BEGIN
      INTEGER          END
      INTEGER          MIDDLE
      INTEGER          ITEMS

      ITEMS = N

      BEGIN = 1
      END   = N

      IF      ( N .LE. 0            ) THEN

C
C        There's nobody home---that is there is nothing in the array
C        to compare against.  Zero is the only sensible thing to return.
C
         LSTLEI = 0

      ELSE IF ( X .LT. ARRAY(BEGIN) ) THEN

C
C        None of the array elements are less than or equal to X
C
         LSTLEI = 0

      ELSE IF ( X .GE. ARRAY(END)   ) THEN

C
C        X is greater than or equal to all elements of the array.  Thus
C        the last element of the array is the last item less than or
C        equal to X.
C
         LSTLEI = END

      ELSE

C
C        X lies between some pair of elements of the array
C

         DO WHILE ( ITEMS .GT. 2 )

            J        = ITEMS/2
            MIDDLE   = BEGIN + J

            IF ( ARRAY(MIDDLE) .LE. X ) THEN
               BEGIN = MIDDLE
            ELSE
               END   = MIDDLE
            END IF

            ITEMS    = 1 + (END - BEGIN)
         END DO

         LSTLEI = BEGIN

      END IF

      RETURN
      END


      program wsac
      implicit none

!     Maximum Size of Array, in 2-D
      integer MAX
      parameter (MAX=36)

!     Size of arrays to store the data
      real dummy, zdata
      dimension dummy(MAX), zdata(MAX)

!     Define variables to be passed into wsac0()
      character*10 kname
      integer i, j, k
      integer nerr
      integer nx, ny
      real minimum, maximum

!     Define the file to be written and the min and max of the 2-D Array
      kname   = 'xyzdata'
      minimum = 1.0
      maximum = 6.0
      nx      = 6
      ny      = 6

      ! Create the 2D Data
      k = 1
      do i = 1,nx
         do j = 1,ny
            zdata(k) = sqrt(j * 1.0 * j + i * 1.0 * i)
            k = k + 1
         enddo
      enddo

      ! Create a new Header and fill it
      !   We are defining the data type, iftype to be 'ixyz', a 2-D Array
      call newhdr
      call setnhv('npts',     MAX,     nerr)
      call setlhv('leven',    .true.,  nerr)
      call setihv('iftype',   'ixyz',  nerr)
      call setnhv('nxsize',   nx,      nerr)
      call setnhv('nysize',   ny,      nerr)
      call setfhv('xminimum', minimum, nerr)
      call setfhv('xmaximum', maximum, nerr)
      call setfhv('yminimum', minimum, nerr)
      call setfhv('ymaximum', maximum, nerr)

!     Write the SAC file kname
!       - kname holds the name of the file to be written
!       - dummy Input Amplitude Data
!       - zdata Input Time Data
!       - nerr Error return Flag
      call wsac0(kname,dummy,zdata,nerr)

!     Check the Error status
!       - 0 on Success
!       - Non-Zero on Error
      if(nerr .NE. 0) then
         write(*,*)'Error writing SAC File: ', kname,nerr
         call exit(-1)
      endif

      call exit(0)

      end


module random_mod
    use, intrinsic :: iso_fortran_env, only : I8 => INT64
    implicit none

    private

    public :: random_bitvector

contains

    function random_bitvector(n) result(vector)
        implicit none
        integer(kind=I8), value :: n
        logical, dimension(:), allocatable :: vector
        real, dimension(:), allocatable :: real_vector

        allocate (real_vector(n))
        allocate (vector(n))
        call random_number(real_vector)
        vector = real_vector < 0.5
        deallocate (real_vector)
    end function random_bitvector

end module random_mod


subroutine fprint(no,ncase,neqn,t,u)
!
!  Subroutine fprint displays the numerical and
!  exact solutions to the linear PDE problem
!
!  Double precision coding is used
implicit double precision(a-h,l,o-z)
!
!  Size the arrays
dimension u(neqn)
!
!  Problem parameters
call par(xl,xu,pi)
!
!  Print a heading for the solution at t = 0
if(t.le.0.0d0)then
!
!  Label for ODE integrator
!
!  Fixed step modfied Euler
if(ncase.eq.1)then
write(no,11)
11 format(//,' euler2a integrator')
!
!  Variable step modified Euler
else if(ncase.eq.2)then
write(no,12)
12 format(//,' euler2b integrator')
!
!  Fixed step classical fourth order RK
else if(ncase.eq.3)then
write(no,13)
13 format(//,' rkc4a integrator')
!
!  Variable step classical fourth order RK
else if(ncase.eq.4)then
write(no,14)
14 format(//,' rkc4b integrator')
!
!  Fixed step RK Fehlberg 45
else if(ncase.eq.5)then
write(no,15)
15 format(//,' rkf45a integrator')
!
!  Variable step RK Fehlberg 45
else if(ncase.eq.6)then
write(no,16)
16 format(//,' rkf45b integrator')
end if
!
!  Heading
write(no,4)ncase,neqn
4 format(/,' ncase = ',i1,' neqn = ',i2)
write(no,2)
2 format(/,4x,'t',4x,'u1(num)',5x,'u1(ex)',8x,'diff1',/)
!
!  End of t = 0 heading
end if
!
!  Numerical and analytical solution output
!
!  Midpoint value of x
x=(xu-xl)/2.0d0
!
!  Analytical solution at midpoint
ue=dexp(-pi*pi*t)*dsin(pi*x)
!
!  Grid index of midpoint
im=dfloat((neqn+1)/2)
!
!  Display the numerical and exact solutions, and their
!  difference
write(no,3)t,u(im),ue,u(im)-ue
3 format(f5.2,2f11.6,e13.4)
return
!
!  End of fprint
end


! RUN: ${F18} -fopenmp -funparse-with-symbols %s 2>&1 | ${FileCheck} %s
! CHECK-NOT: do *[1-9]
! CHECK: omp simd

program P
implicit none
integer N, I
parameter (N=100)
real A(N), B(N), C(N)

!$OMP SIMD
do 10 I = 1, N
   A(I) = I * 1.0
10 continue

B = A

!$OMP SIMD
do 20 I = 1, N
   C(I) = A(I) + B(I)
   write (*,100) I, C(I)
20 continue

100 format(" C(", I3, ")=", F8.2)
end program P


  subroutine src1(meqn,mbc,mx,xlower,dx,q,maux,aux,t,dt)

      use bous_module
      use grid_module, only: mx_grid, xgrid, radial
      use geoclaw_module, only: dry_tolerance, grav, DEG2RAD
      use geoclaw_module, only: friction_forcing
      use geoclaw_module, only: frictioncoeff => friction_coefficient

      implicit none

      integer, intent(in) :: meqn,mbc,mx,maux
      real(kind=8), intent(inout) ::   q(meqn,1-mbc:mx+mbc)
      real(kind=8), intent(in) :: aux(maux,1-mbc:mx+mbc)
      real(kind=8), intent(in) :: xlower, dx, t, dt

      real(kind=8) gamma, rcell, u

      real(kind=8)  q0(meqn,1-mbc:mx+mbc)
      real(kind=8) psi(mx+2)

      real(kind=8)   rk_stage(1:mx,4)
      real(kind=8) :: delt
      integer ::  i,k,ii,nstep,rk_order
      integer(kind=4) INFO

      INTEGER            LDB
      INTEGER            IPIV( mx+2 )
      DOUBLE PRECISION   D(mx+2), DL(mx+1), DU(mx+1), DU2(1:mx)

      logical verbose

      verbose=.False.

      if (frictioncoeff.gt.0.d0 .and. friction_forcing) then
          ! integrate source term based on Manning formula
            do i=1,mx
               if (q(1,i)<=dry_tolerance) then
                  q(2,i) = 0.0
               else
                  gamma= dsqrt(q(2,i)**2)*(grav*frictioncoeff**2)/(q(1,i)**(7.0/3.0))
                  q(2,i)= q(2,i)/(1.d0 + dt*gamma)
              endif
            enddo
        endif

!      ----------------------------------------------------------------

      if (radial) then
          ! radial source term:
          do i=1,mx
             ! assume radial about left edge!
             rcell = 0.5*(xgrid(i) + xgrid(i+1)) - xgrid(1)
             q(1,i) = q(1,i) - dt/rcell * q(2,i)
             if (q(1,i) .gt. dry_tolerance) then
                 u = q(2,i)/q(1,i)
               else
                 u = 0.d0
               endif
             q(2,i) = q(2,i) - dt/rcell * q(1,i)*u**2
             enddo
         endif

!      ----------------------------------------------------------------

     if (bouss) then
!
!      Boussinesq terms

     !nstep=ceiling(dt/dx*2*sqrt(2.))  ! ???
     !write(6,*) '+++ nstep = ',nstep
     nstep = 1

     k = 1

     delt=dt/nstep

     LDB = mx+2
     D  =0.d0
     DU =0.d0
     DL =0.d0
     DU2=0.d0

     rk_order = 2

     do ii=1,nstep

          call set_diag(mx,meqn,mbc,dx,q,maux,aux, DL, D, DU)

          call DGTTRF( mx+2, DL, D, DU, DU2, IPIV, INFO )

          psi = 0.d0
          rk_stage = 0.d0
          q0  = q

          !-----------------------
          if (rk_order == 1) then
          ! Forward Euler

          call set_psi(mx,meqn,mbc,dx,q0,maux,aux,psi)

          call DGTTRS( 'N', mx+2, 1, DL, D, DU, DU2 &
                      , IPIV, psi, LDB,INFO )

          q(2,1:mx) = q(2,1:mx) - delt*psi(2:mx+1)
          endif

          !-----------------------
          if (rk_order == 2) then
          ! RK2

          ! First Stage

          call set_psi(mx,meqn,mbc,dx,q0,maux,aux,psi)

          call DGTTRS( 'N', mx+2, 1, DL, D, DU, DU2 &
                      , IPIV, psi, LDB,INFO )

          rk_stage(1:mx,1) = psi(2:mx+1)

          q0(2,1:mx)=q(2,1:mx)-delt/2.d0*rk_stage(1:mx,1)

          ! Second Stage

          call set_psi(mx,meqn,mbc,dx,q0,maux,aux,psi)

          call DGTTRS( 'N', mx+2, 1, DL, D, DU, DU2 &
                      , IPIV, psi, LDB,INFO )

          rk_stage(1:mx,2)=psi(2:mx+1)

          q(2,1:mx) = q(2,1:mx)- delt*rk_stage(1:mx,2)

          endif ! rk_order==2

          !-----------------------
          if (rk_order == 4) then
          ! RK4

          ! First Stage

          call set_psi(mx,meqn,mbc,dx,q0,maux,aux,psi)

          call DGTTRS( 'N', mx+2, 1, DL, D, DU, DU2 &
                      , IPIV, psi, LDB,INFO )

          rk_stage(1:mx,1) = psi(2:mx+1)

          q0(2,1:mx)=q(2,1:mx)-delt/2.d0*rk_stage(1:mx,1)

          ! Second Stage

          call set_psi(mx,meqn,mbc,dx,q0,maux,aux,psi)

          call DGTTRS( 'N', mx+2, 1, DL, D, DU, DU2 &
                      , IPIV, psi, LDB,INFO )

          rk_stage(1:mx,2)=psi(2:mx+1)

          q0(2,1:mx)=q(2,1:mx)-delt/2.d0*rk_stage(1:mx,2)

          ! Third Stage

          call set_psi(mx,meqn,mbc,dx,q0,maux,aux,psi)

          call DGTTRS( 'N', mx+2, 1, DL, D, DU, DU2 &
                      , IPIV, psi, LDB,INFO )

          rk_stage(1:mx,3)=psi(2:mx+1)

          q0(2,1:mx)=q(2,1:mx)-delt*rk_stage(1:mx,3)

          ! Fourth Stage

          call set_psi(mx,meqn,mbc,dx,q0,maux,aux,psi)

          call DGTTRS( 'N', mx+2, 1, DL, D, DU, DU2 &
                      , IPIV, psi, LDB,INFO )

          rk_stage(1:mx,4)=psi(2:mx+1)

          q(2,1:mx) = q(2,1:mx)- delt/6.d0*(rk_stage(1:mx,1) &
               + 2.d0*rk_stage(1:mx,2) &
               + 2.d0*rk_stage(1:mx,3) + rk_stage(1:mx,4))

          endif ! rk_order==4

      enddo

    endif ! end of Bouss terms

  end subroutine src1

! =========================================================
      subroutine set_diag(mx,meqn,mbc,dx,q,maux,aux, DL, D, DU)
! =========================================================
      use bous_module, only: B_param, sw_depth0
      use geoclaw_module, only: sea_level
      use grid_module, only: xcell, dxm, dxc, cm, cp, c0

      implicit none

      integer(kind=4), intent(in) :: mx,meqn,mbc,maux
      real(kind=8), intent(in) ::  dx
      real(kind=8), intent(in) ::    q(meqn,1-mbc:mx+mbc)
      real(kind=8), intent(in) ::  aux(maux,1-mbc:mx+mbc)
      real(kind=8), intent(out) ::   D(mx+2), DL(mx+1), DU(mx+1)

      real(kind=8), dimension(1-mbc:mx+mbc) :: h0, hh, hhh
      real(kind=8) :: tol
      integer(kind=4) :: i,k,mxy

      h0 = sea_level - aux(1,:)
      tol = 1d-4   ! for testing h0 and q(1).  Good value?

        do i=1-mbc,mx+mbc
           hh(i)=(max(0.,h0(i)))**2
           hhh(i)=(max(0.,h0(i)))**3
        enddo

        ! initialize to identity matrix:
        D = 1.d0
        DU= 0.d0
        DL= 0.d0

        do i=1,mx

            if ((h0(i) > sw_depth0) .and. &
                (minval(q(1,i-2:i+2)) >= tol) .and. &
                (minval(h0(i-2:i+2)) >= tol)) then

              ! replace this row of identity matrix with dispersion terms:

              D(i+1) = 1.d0 + c0(i)*((B_param+.5d0)*hh(i) &
                    - 1.d0/6.d0*hhh(i)/h0(i))

              DU(i+1)= -cp(i)*((B_param+.5d0)*hh(i) &
                    - 1.d0/6.d0*hhh(i)/h0(i+1))

              DL(i)= -cm(i)*((B_param+.5d0)*hh(i) &
                    - 1.d0/6.d0*hhh(i)/h0(i-1))

            endif

        enddo

      if (.true.) then
         ! for wall-reflecting BC at left: impose Q_0 = -Q_1
         D(2) = D(2) - DL(1)
         DL(1) = 0.d0
         endif

      return
      end subroutine set_diag

!======================================================================
      subroutine set_psi(mx,meqn,mbc,dx,q,maux,aux,psi)

      use geoclaw_module, only: g => grav, sea_level, dry_tolerance
      use bous_module, only: B_param, sw_depth0, sw_depth1
      use grid_module, only: xcell, dxm, dxc, cm, cp, c0

      implicit none

      integer, intent(in) :: mx,meqn,mbc,maux
      real(kind=8), intent(in) :: dx

      real(kind=8), intent(in) ::  q(meqn,1-mbc:mx+mbc)
      real(kind=8), intent(in) :: aux(maux,1-mbc:mx+mbc)
      real(kind=8), intent(out) :: psi(mx+2)

      real(kind=8)  depth
      real(kind=8), dimension(1-mbc:mx+mbc) :: h0, hh, hhh, eta, hu2
      real(kind=8), dimension(1-mbc:mx+mbc) :: hetax,detax,s1,s1_h
      real(kind=8)  detaxxx,s1xx,s1_hxx
      integer :: i,j,k,kk,iL,iR

      h0 = sea_level - aux(1,:)

         do i=1-mbc,mx+mbc
           if (q(1,i).gt.dry_tolerance) then
              hu2(i)= q(2,i)**2/q(1,i)
             else
              hu2(i)= 0.d0
             endif
           eta(i)= q(1,i) - h0(i)
           hh(i)=(max(0.d0,h0(i)))**2
           hhh(i)=(max(0.d0,h0(i)))**3
        enddo

     hetax = 0.d0
     detax = 0.d0
     !write(6,*) '+++ eta(0:1): ',eta(0),eta(1)

         do i= 1,mx
         if (minval(h0(i-1:i+1)) > 0.d0) then
            if (i<1) then
                !write(6,*) '+++ dxm = ', (dxm(j), j=1,4)
                hetax(i)= q(1,i)*(eta(i+1)-eta(i))/dxm(i+1)
                detax(i)= h0(i)*(eta(i+1)-eta(i))/dxm(i+1)
            elseif (i>mx) then
                hetax(i)= q(1,i)*(eta(i)-eta(i-1))/dxm(i)
                detax(i)= h0(i)*(eta(i)-eta(i-1))/dxm(i)
            else
                hetax(i)= q(1,i)*(eta(i+1)-eta(i-1))/dxc(i)
                detax(i)= h0(i)*(eta(i+1)-eta(i-1))/dxc(i)
            endif
         endif
        enddo

     s1=0.d0
     s1_h=0.d0

     !write(6,*) '+++ hu2(0:1): ',hu2(0),hu2(1)
     do i=1,mx
          if (i<1) then
             s1(i)= (hu2(i+1)-hu2(i))/dxm(i+1)
          elseif (i>mx) then
             s1(i)= (hu2(i)-hu2(i-1))/dxm(i)
          else
             s1(i)= (hu2(i+1)-hu2(i-1))/dxc(i)
          endif

          s1(i)= s1(i)+g*hetax(i)

           if (h0(i) > 0.1d0) then
              s1_h(i)=s1(i)/h0(i)
           else
              s1_h(i)=0.d0
           endif
     enddo

     !write(6,*) '+++ s1(0:1): ',s1(0),s1(1)
     !write(6,*) '+++ s1_h(0:1): ',s1_h(0),s1_h(1)
     !write(6,*) '+++ detax(0:1): ',detax(0),detax(1)
     s1(0) = s1(1)
     s1_h(0) = s1_h(1)
     detax(0) = detax(1)

      psi = 0.d0

        do i=1,mx

           k = i+1

           if (h0(i) <= sw_depth0) then
              ! no dispersive term:
              psi(k) = 0.d0

           else

              ! check if we need to use one-sided differences:
              if (i<1) then
                 j = i+1
              elseif (i>mx) then
                 j = i-1
              else
                 j = i
              endif

              s1xx = cp(j)*s1(j+1) - c0(j)*s1(j) + cm(j)*s1(j-1)
              detaxxx = cp(j)*detax(j+1) - c0(j)*detax(j) + &
                        cm(j)*detax(j-1)
              s1_hxx = cp(j)*s1_h(j+1) - c0(j)*s1_h(j) + cm(j)*s1_h(j-1)

              psi(k) = (B_param+.5d0)*hh(i)*s1xx - B_param*g*hh(i)*detaxxx &
                  -hhh(i)/6.d0 * s1_hxx

           endif

        if ((h0(i) > sw_depth0) .and. (h0(i) < sw_depth1)) then
            ! reduce psi linearly between sw_depth0 and sw_depth1:
            psi(k) = psi(k) * (h0(i)-sw_depth0)/(sw_depth1-sw_depth0)
            endif

        enddo

      return
      end subroutine set_psi


C     LAST UPDATE 16/03/89
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE POLCAL (XDATA,YDATA,A,B,C,MDEG,ICH1,ICH2)
      IMPLICIT NONE
C
C Purpose: Calculates a polynomial of degree M, between selected
C          channels at points determined by abscissa data.
C
      REAL    XDATA(1),YDATA(1),A(1),B(1),C(1)
      INTEGER MDEG,ICH1,ICH2
C
C XDATA  : Abscissa data
C YDATA  : Ordinate data
C A      : Coefficients given by Harwell library routine VC01A
C B      : Coefficients given by Harwell library routine VC01A
C C      : Coefficients given by Harwell library routine VC01A
C MDEG   : Degree of the polynomial
C ICH1	 : First channel of interest
C ICH2   : Last channel of interest
C
C Calls   0:
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      REAL   W1,W2,YY
      INTEGER I,J,K
C
C W1     :
C W2     :
C YY     :
C
C-----------------------------------------------------------------------
      DO 10 I=ICH1,ICH2
         W2=0.0
         YY=C(MDEG+1)
         DO 20 J=1,MDEG
            K=MDEG-J+1
            W1=W2
            W2=YY
            YY=C(K)+(XDATA(I)-A(K))*W2-B(K+1)*W1
20       CONTINUE
         YDATA(I)=YY
10    CONTINUE
      RETURN
      END


SUBROUTINE p115(input_file,output_file)
!------------------------------------------------------------------------------
! Program 11.5 Forced vibration of a rectangular elastic solid in plane
!              strain using uniform 8-node quadrilaterals. Lumped mass.
!              Mesh numbered in y-direction. Complex response.
!------------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::i,iel,k,nband,ndim=2,ndof=16,nels,neq,nip=9,nlen,nn,nod=8,      &
   nodof=2,npri,nprops=4,np_types,nr,nres,nst=3,nstep,nxe,nye
 REAL(iwp)::a,area,b,det,dr,dtim,d2=2.0_iwp,omega=0.3,one=1.0_iwp,        &
   time,zero=0.0_iwp
 CHARACTER(len=15)::argv,element='quadrilateral'
!----------------------------- dynamic arrays----------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),g_num(:,:),nf(:,:),num(:)
 REAL(iwp),ALLOCATABLE::bee(:,:),cm(:,:),coord(:,:),dee(:,:),der(:,:),    &
   deriv(:,:),g_coord(:,:),jac(:,:),km(:,:),mm(:,:),points(:,:),prop(:,:),&
   weights(:),x_coords(:),y_coords(:)
 COMPLEX(iwp),ALLOCATABLE::kc(:),loads(:)
!-----------------------input and initialisation-------------------------------
 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nxe,nye,np_types
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 ALLOCATE(nf(nodof,nn),points(nip,ndim),g(ndof), g_coord(ndim,nn),        &
   dee(nst,nst),coord(nod,ndim),jac(ndim,ndim),weights(nip),der(ndim,nod),&
   deriv(ndim,nod),bee(nst,ndof),km(ndof,ndof),num(nod),g_num(nod,nels),  &
   g_g(ndof,nels),mm(ndof,ndof),cm(ndof,ndof),prop(nprops,np_types),      &
   etype(nels),x_coords(nxe+1),y_coords(nye+1))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)x_coords,y_coords,dtim,nstep,npri,nres
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 CALL sample(element,points,weights)
 nband=0
!---------------loop the elements to find bandwidth--------------------
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,'y')
   call num_to_g(num,nf,g)
   g_num(:,iel)=num
   g_g(:,iel)=g
   g_coord(:,num)=transpose(coord)
   IF(nband<bandwidth(g))nband=bandwidth(g)
 END DO elements_1
 WRITE(11,'(2(A,I5))')                                                    &
   "There are ",neq,"  equations and the half-bandwidth is", nband
 ALLOCATE(kc(neq*(nband+1)),loads(0:neq))
 kc=(0.0_iwp,0.0_iwp)
!----------------- element stiffness integration and assembly----------------
 elements_2: DO iel=1,nels
   CALL deemat(dee,prop(1,etype(iel)),prop(2,etype(iel)))
   num=g_num(:,iel)
   coord=transpose(g_coord(:,num))
   g=g_g(:,iel)
   area=(coord(5,1)-coord(1,1))*(coord(5,2)-coord(1,2))
   CALL elmat(area,prop(3,etype(iel)),mm)
   km=zero
   gauss_points_1: DO i=1,nip
     CALL shape_der(der,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     CALL beemat(bee,deriv)
     km=km+MATMUL(MATMUL(TRANSPOSE(bee),dee),bee)*det*weights(i)
   END DO gauss_points_1
   dr=prop(4,etype(iel))
   cm=km*d2*dr*SQRT(one-dr*dr)
   km=km*(one-d2*dr*dr)-mm*omega**2
   CALL formkc(kc,km,cm,g,neq)
 END DO elements_2
!---------------------complex equation solution------------------------------
 loads=(0.0_iwp,0.0_iwp)
 loads(neq)=(1.0_iwp,0.0_iwp)
 CALL comred(kc,neq)
 CALL comsub(kc,loads)
 a=REAL(loads(neq))
 b=AIMAG(loads(neq))
!----------------------- time stepping loop ----------------------------------
 WRITE(11,'(/A,I5)')" Result at node",nres
 WRITE(11,'(A)')"    time        load        y-disp"
 timesteps: DO i=0,nstep
   time=i*dtim
   IF(i/npri*npri==i)WRITE(11,'(3E12.4)')time,               &
     COS(omega*time),a*COS(omega*time)-b*SIN(omega*time)
 END DO timesteps
END SUBROUTINE p115


module field
  use mpi
  implicit none

  private

  public :: field__init, field__fdtd_i

  logical, save :: is_init = .false.
  integer, save :: ndim, np, nsp, nxgs, nxge, nygs, nyge, nys, nye
  integer, save :: mnpr, ncomw, opsum
  integer       :: nerr
  real(8), parameter :: pi = 4.0D0*atan(1.0D0)
  real(8), save :: delx, delt, u0, c, gfac_in, d_delx, d_delt, gfac
  real(8), save :: f1, f2, f3, f4, f5
  real(8), allocatable :: q(:), r(:)

contains

  subroutine field__init(ndim_in,np_in,nsp_in,nxgs_in,nxge_in,nygs_in,nyge_in,nys_in,nye_in, &
                         mnpr_in,ncomw_in,opsum_in,nerr_in,                                  &
                         delx_in,delt_in,c_in,q_in,r_in,gfac_in)

    integer, intent(in) :: ndim_in, np_in, nsp_in
    integer, intent(in) :: nxgs_in, nxge_in, nygs_in, nyge_in, nys_in, nye_in
    integer, intent(in) :: mnpr_in, ncomw_in, opsum_in, nerr_in
    real(8), intent(in) :: delx_in, delt_in, c_in, q_in(nsp_in), r_in(nsp_in), gfac_in

    ndim  = ndim_in
    np    = np_in
    nsp   = nsp_in
    nxgs  = nxgs_in
    nxge  = nxge_in
    nygs  = nygs_in
    nyge  = nyge_in
    nys   = nys_in
    nye   = nye_in
    mnpr  = mnpr_in
    ncomw = ncomw_in
    opsum = opsum_in
    nerr  = nerr_in
    delx  = delx_in
    delt  = delt_in
    c     = c_in
    allocate(q(nsp))
    allocate(r(nsp))
    q     = q_in
    r     = r_in
    gfac  = gfac_in

    f1    = c*delt/delx
    f2    = gfac*f1*f1
    f3    = 4.0*pi*delx/c
    f4    = 4.0D0+(delx/(c*delt*gfac))**2
    f5    = (delx/(c*delt*gfac))**2
    d_delx = 1./delx
    d_delt = 1./delt

    is_init = .true.

  end subroutine field__init

  subroutine field__fdtd_i(uf,up,gp,cumcnt,nxs,nxe, &
       & set_boundary_dfield, &
       & set_boundary_curre, &
       & set_boundary_phi)

    interface
       ! set boundary for field
       subroutine set_boundary_dfield(df,nxs,nxe,nys,nye,nxgs,nxge)
         real(8), intent(inout) :: df(6,nxgs-2:nxge+2,nys-2:nye+2)
         integer, intent(in)    :: nxs, nxe, nys, nye, nxgs, nxge
       end subroutine set_boundary_dfield

       ! set boundary for current
       subroutine set_boundary_curre(uj,nxs,nxe,nys,nye,nxgs,nxge)
         real(8), intent(inout) :: uj(3,nxgs-2:nxge+2,nys-2:nye+2)
         integer, intent(in)    :: nxs, nxe, nys, nye, nxgs, nxge
       end subroutine set_boundary_curre

       ! set boundary for potential
       subroutine set_boundary_phi(phi,nxs,nxe,nys,nye,l)
         real(8), intent(inout) :: phi(nxs-1:nxe+1,nys-1:nye+1)
         integer, intent(in)    :: nxs, nxe, nys, nye, l
       end subroutine set_boundary_phi
    end interface

    integer, intent(in)    :: nxs, nxe
    integer, intent(in)    :: cumcnt(nxgs:nxge+1,nys:nye,nsp)
    real(8), intent(in)    :: gp(ndim,np,nys:nye,nsp)
    real(8), intent(in)    :: up(ndim,np,nys:nye,nsp)
    real(8), intent(inout) :: uf(6,nxgs-2:nxge+2,nys-2:nye+2)
    logical, save              :: lflag=.true.
    integer                    :: i, j, ieq
    real(8), save, allocatable :: df(:,:,:), gkl(:,:,:), uj(:,:,:)

    if(.not.is_init)then
       write(6,*)'Initialize first by calling field__init()'
       stop
    endif

    if(lflag)then
       allocate(df(6,nxgs-2:nxge+2,nys-2:nye+2))
       allocate(gkl(3,nxgs:nxge,nys:nye))
       allocate(uj(3,nxgs-2:nxge+2,nys-2:nye+2))
!$OMP PARALLEL WORKSHARE
       df(1:6,nxgs-2:nxge+2,nys-2:nye+2) = 0.0D0
!$OMP END PARALLEL WORKSHARE
!$OMP PARALLEL WORKSHARE
       gkl(1:3,nxgs:nxge,nys:nye) = 0.0D0
!$OMP END PARALLEL WORKSHARE
!$OMP PARALLEL WORKSHARE
       uj(1:3,nxgs-2:nxge+2,nys-2:nye+2) = 0.0D0
!$OMP END PARALLEL WORKSHARE
       lflag=.false.
    endif

    call ele_cur(uj,up,gp,cumcnt,nxs,nxe)
    call set_boundary_curre(uj,nxs,nxe,nys,nye,nxgs,nxge)

    !calculation
!$OMP PARALLEL DO PRIVATE(i,j)
    do j=nys,nye
    do i=nxs,nxe
       gkl(1,i,j) = +f2*(+uf(1,i,j-1)                          &
                         +uf(1,i-1,j)-4.*uf(1,i,j)+uf(1,i+1,j) &
                         +uf(1,i,j+1)                          &
                         +f3*(-uj(3,i,j-1)+uj(3,i,j)) )        &
                    -f1*(-uf(6,i,j-1)+uf(6,i,j))
       gkl(2,i,j) = +f2*(+uf(2,i,j-1)                          &
                         +uf(2,i-1,j)-4.*uf(2,i,j)+uf(2,i+1,j) &
                         +uf(2,i,j+1)                          &
                         -f3*(-uj(3,i-1,j)+uj(3,i,j)) )        &
                    +f1*(-uf(6,i-1,j)+uf(6,i,j))
       gkl(3,i,j) = +f2*(+uf(3,i,j-1)                          &
                         +uf(3,i-1,j)-4.*uf(3,i,j)+uf(3,i+1,j) &
                         +uf(3,i,j+1)                          &
                         +f3*(-uj(2,i-1,j)+uj(2,i,j)           &
                              +uj(1,i,j-1)-uj(1,i,j)) )        &
                    -f1*(-uf(5,i-1,j)+uf(5,i,j)+uf(4,i,j-1)-uf(4,i,j))
    enddo
    enddo
!$OMP END PARALLEL DO

    !solve  < bx, by & bz >
    call cgm(df,gkl,nxs,nxe,set_boundary_phi)

    call set_boundary_dfield(df,nxs,nxe,nys,nye,nxgs,nxge)

    !solve  < ex, ey & ez >
!$OMP PARALLEL DO PRIVATE(i,j)
    do j=nys,nye
    do i=nxs,nxe
       df(4,i,j) = +f1*(+gfac*(-df(3,i,j)+df(3,i,j+1))   &
                        +     (-uf(3,i,j)+uf(3,i,j+1)) ) &
                   -4.*pi*delt*uj(1,i,j)
       df(5,i,j) = -f1*(+gfac*(-df(3,i,j)+df(3,i+1,j))   &
                        +     (-uf(3,i,j)+uf(3,i+1,j)) ) &
                   -4.*pi*delt*uj(2,i,j)

       df(6,i,j) = +f1*(+gfac*(-df(2,i,j)+df(2,i+1,j)    &
                               +df(1,i,j)-df(1,i,j+1))   &
                        +     (-uf(2,i,j)+uf(2,i+1,j)    &
                               +uf(1,i,j)-uf(1,i,j+1)) ) &
                   -4.*pi*delt*uj(3,i,j)
    enddo
    enddo
!$OMP END PARALLEL DO

    call set_boundary_dfield(df,nxs,nxe,nys,nye,nxgs,nxge)

    !===== Update fields ======
!$OMP PARALLEL DO PRIVATE(i,j,ieq)
    do j=nys-2,nye+2
    do i=nxs-2,nxe+2
       do ieq=1,6
          uf(ieq,i,j) = uf(ieq,i,j)+df(ieq,i,j)
       enddo
    enddo
    enddo
!$OMP END PARALLEL DO

  end subroutine field__fdtd_i

  subroutine ele_cur(uj,up,gp,cumcnt,nxs,nxe)

    integer, intent(in)  :: nxs, nxe
    integer, intent(in)  :: cumcnt(nxgs:nxge+1,nys:nye,nsp)
    real(8), intent(in)  :: gp(ndim,np,nys:nye,nsp)
    real(8), intent(in)  :: up(ndim,np,nys:nye,nsp)
    real(8), intent(out) :: uj(3,nxgs-2:nxge+2,nys-2:nye+2)

    integer            :: ii, i, j, isp, i2, inc, ip, jp
    real(8), parameter :: fac = 1.D0/3.D0
    real(8)            :: dh, gvz, s1_1, s1_2, s1_3, smo_1, smo_2, smo_3
    real(8)            :: s0(-2:2,2), ds(-2:2,2)
    real(8)            :: pjx(-2:2,-2:2), pjy(-2:2,-2:2), pjz(-2:2,-2:2), pjtmp(-2:2,-2:2)

!$OMP PARALLEL WORKSHARE
    uj(1:3,nxs-2:nxe+2,nys-2:nye+2) = 0.D0
!$OMP END PARALLEL WORKSHARE

    !--------------Charge Conservation Method -------------!
    !---- Density Decomposition (Esirkepov, CPC, 2001) ----!
!$OMP PARALLEL DO PRIVATE(ii,i,j,i2,isp,inc,ip,jp,dh,s0,ds,pjx,pjy,pjz,pjtmp, &
!$OMP                     gvz,s1_1,s1_2,s1_3,smo_1,smo_2,smo_3) &
!$OMP REDUCTION(+:uj)
    do j=nys,nye
    do i=nxs,nxe

       pjx(-2:2,-2:2) = 0.D0
       pjy(-2:2,-2:2) = 0.D0
       pjz(-2:2,-2:2) = 0.D0

       isp=1

       do ii=cumcnt(i,j,isp)+1,cumcnt(i+1,j,isp)

          !second order shape function
          dh = up(1,ii,j,isp)*d_delx-0.5-i
          s0(-2,1) = 0.D0
          s0(-1,1) = 0.5*(0.5-dh)*(0.5-dh)
          s0( 0,1) = 0.75-dh*dh
          s0(+1,1) = 0.5*(0.5+dh)*(0.5+dh)
          s0(+2,1) = 0.D0

          dh = up(2,ii,j,isp)*d_delx-0.5-j
          s0(-2,2) = 0.D0
          s0(-1,2) = 0.5*(0.5-dh)*(0.5-dh)
          s0( 0,2) = 0.75-dh*dh
          s0(+1,2) = 0.5*(0.5+dh)*(0.5+dh)
          s0(+2,2) = 0.D0

          i2 = int(gp(1,ii,j,isp)*d_delx)
          dh = gp(1,ii,j,isp)*d_delx-0.5-i2
          inc = i2-i
          s1_1 = 0.5*(0.5-dh)*(0.5-dh)
          s1_2 = 0.75-dh*dh
          s1_3 = 0.5*(0.5+dh)*(0.5+dh)
          smo_1 = -(inc-abs(inc))*0.5+0
          smo_2 = -abs(inc)+1
          smo_3 = (inc+abs(inc))*0.5+0
          ds(-2,1) = s1_1*smo_1
          ds(-1,1) = s1_1*smo_2+s1_2*smo_1
          ds( 0,1) = s1_2*smo_2+s1_3*smo_1+s1_1*smo_3
          ds(+1,1) = s1_3*smo_2+s1_2*smo_3
          ds(+2,1) = s1_3*smo_3

          i2 = int(gp(2,ii,j,isp)*d_delx)
          dh = gp(2,ii,j,isp)*d_delx-0.5-i2
          inc = i2-j
          s1_1 = 0.5*(0.5-dh)*(0.5-dh)
          s1_2 = 0.75-dh*dh
          s1_3 = 0.5*(0.5+dh)*(0.5+dh)
          smo_1 = -(inc-abs(inc))*0.5+0
          smo_2 = -abs(inc)+1
          smo_3 = (inc+abs(inc))*0.5+0
          ds(-2,2) = s1_1*smo_1
          ds(-1,2) = s1_1*smo_2+s1_2*smo_1
          ds( 0,2) = s1_2*smo_2+s1_3*smo_1+s1_1*smo_3
          ds(+1,2) = s1_3*smo_2+s1_2*smo_3
          ds(+2,2) = s1_3*smo_3

          ds(-2:2,1:2) = ds(-2:2,1:2)-s0(-2:2,1:2)

          gvz = gp(5,ii,j,isp)/dsqrt(1.+(+gp(3,ii,j,isp)*gp(3,ii,j,isp) &
                                         +gp(4,ii,j,isp)*gp(4,ii,j,isp) &
                                         +gp(5,ii,j,isp)*gp(5,ii,j,isp))/(c*c) )

          pjtmp(-2:2,-2:2) = 0.D0
          do jp=-2,2
             do ip=-2,1
                pjtmp(ip+1,jp) = pjtmp(ip,jp) &
                                -q(isp)*delx*d_delt*ds(ip,1)*(s0(jp,2)+0.5*ds(jp,2))
             enddo
          enddo
          pjx = pjx+pjtmp

          pjtmp(-2:2,-2:2) = 0.D0
          do jp=-2,1
             do ip=-2,2
                pjtmp(ip,jp+1) = pjtmp(ip,jp) &
                                -q(isp)*delx*d_delt*ds(jp,2)*(s0(ip,1)+0.5*ds(ip,1))
             enddo
          enddo
          pjy = pjy+pjtmp

          do jp=-2,2
             do ip=-2,2
                pjz(ip,jp) = pjz(ip,jp)                                           &
                            +q(isp)*gvz*(+s0(ip,1)*s0(jp,2)+0.5*ds(ip,1)*s0(jp,2) &
                                         +0.5*s0(ip,1)*ds(jp,2)+fac*ds(ip,1)*ds(jp,2))
             enddo
          enddo

       enddo

       isp = 2

       do ii=cumcnt(i,j,isp)+1,cumcnt(i+1,j,isp)

          !second order shape function
          dh = up(1,ii,j,isp)*d_delx-0.5-i
          s0(-2,1) = 0.D0
          s0(-1,1) = 0.5*(0.5-dh)*(0.5-dh)
          s0( 0,1) = 0.75-dh*dh
          s0(+1,1) = 0.5*(0.5+dh)*(0.5+dh)
          s0(+2,1) = 0.D0

          dh = up(2,ii,j,isp)*d_delx-0.5-j
          s0(-2,2) = 0.D0
          s0(-1,2) = 0.5*(0.5-dh)*(0.5-dh)
          s0( 0,2) = 0.75-dh*dh
          s0(+1,2) = 0.5*(0.5+dh)*(0.5+dh)
          s0(+2,2) = 0.D0

          i2 = int(gp(1,ii,j,isp)*d_delx)
          dh = gp(1,ii,j,isp)*d_delx-0.5-i2
          inc = i2-i
          s1_1 = 0.5*(0.5-dh)*(0.5-dh)
          s1_2 = 0.75-dh*dh
          s1_3 = 0.5*(0.5+dh)*(0.5+dh)
          smo_1 = -(inc-abs(inc))*0.5+0
          smo_2 = -abs(inc)+1
          smo_3 = (inc+abs(inc))*0.5+0
          ds(-2,1) = s1_1*smo_1
          ds(-1,1) = s1_1*smo_2+s1_2*smo_1
          ds( 0,1) = s1_2*smo_2+s1_3*smo_1+s1_1*smo_3
          ds(+1,1) = s1_3*smo_2+s1_2*smo_3
          ds(+2,1) = s1_3*smo_3

          i2 = int(gp(2,ii,j,isp)*d_delx)
          dh = gp(2,ii,j,isp)*d_delx-0.5-i2
          inc = i2-j
          s1_1 = 0.5*(0.5-dh)*(0.5-dh)
          s1_2 = 0.75-dh*dh
          s1_3 = 0.5*(0.5+dh)*(0.5+dh)
          smo_1 = -(inc-abs(inc))*0.5+0
          smo_2 = -abs(inc)+1
          smo_3 = (inc+abs(inc))*0.5+0
          ds(-2,2) = s1_1*smo_1
          ds(-1,2) = s1_1*smo_2+s1_2*smo_1
          ds( 0,2) = s1_2*smo_2+s1_3*smo_1+s1_1*smo_3
          ds(+1,2) = s1_3*smo_2+s1_2*smo_3
          ds(+2,2) = s1_3*smo_3

          ds(-2:2,1:2) = ds(-2:2,1:2)-s0(-2:2,1:2)

          gvz = gp(5,ii,j,isp)/dsqrt(1.+(+gp(3,ii,j,isp)*gp(3,ii,j,isp) &
                                         +gp(4,ii,j,isp)*gp(4,ii,j,isp) &
                                         +gp(5,ii,j,isp)*gp(5,ii,j,isp))/(c*c) )

          pjtmp(-2:2,-2:2) = 0.D0
          do jp=-2,2
             do ip=-2,1
                pjtmp(ip+1,jp) = pjtmp(ip,jp) &
                                -q(isp)*delx*d_delt*ds(ip,1)*(s0(jp,2)+0.5*ds(jp,2))
             enddo
          enddo
          pjx = pjx+pjtmp

          pjtmp(-2:2,-2:2) = 0.D0
          do jp=-2,1
             do ip=-2,2
                pjtmp(ip,jp+1) = pjtmp(ip,jp) &
                                -q(isp)*delx*d_delt*ds(jp,2)*(s0(ip,1)+0.5*ds(ip,1))
             enddo
          enddo
          pjy = pjy+pjtmp

          do jp=-2,2
             do ip=-2,2
                pjz(ip,jp) = pjz(ip,jp)                                           &
                            +q(isp)*gvz*(+s0(ip,1)*s0(jp,2)+0.5*ds(ip,1)*s0(jp,2) &
                                         +0.5*s0(ip,1)*ds(jp,2)+fac*ds(ip,1)*ds(jp,2))
             enddo
          enddo

       enddo

       do jp=-2,2
          do ip=-2,2
             uj(1,i+ip,j+jp) = uj(1,i+ip,j+jp)+pjx(ip,jp)
             uj(2,i+ip,j+jp) = uj(2,i+ip,j+jp)+pjy(ip,jp)
             uj(3,i+ip,j+jp) = uj(3,i+ip,j+jp)+pjz(ip,jp)
          enddo
       enddo

    enddo
    enddo
!$OMP END PARALLEL DO

  end subroutine ele_cur

  subroutine cgm(db,gkl,nxs,nxe,set_boundary_phi)

    !-----------------------------------------------------------------------
    !  #  conjugate gradient method
    !  #  this routine will be stoped after itaration number = ite_max
    !-----------------------------------------------------------------------

    interface
       ! set boundary for potential
       subroutine set_boundary_phi(phi,nxs,nxe,nys,nye,l)
         real(8), intent(inout) :: phi(nxs-1:nxe+1,nys-1:nye+1)
         integer, intent(in)    :: nxs, nxe, nys, nye, l
       end subroutine set_boundary_phi
    end interface

    integer, intent(in)    :: nxs, nxe
    real(8), intent(in)    :: gkl(3,nxgs:nxge,nys:nye)
    real(8), intent(inout) :: db(6,nxgs-2:nxge+2,nys-2:nye+2)
    integer, parameter :: ite_max = 100 ! maximum number of interation
    integer            :: i, j, l, ite
    real(8), parameter :: err = 1d-6
    real(8)            :: eps, sumr, sum, sum1, sum2, av, bv
    real(8)            :: sumr_g, sum_g, sum1_g, sum2_g
    real(8)            :: phi(nxs-1:nxe+1,nys-1:nye+1), p(nxs-1:nxe+1,nys-1:nye+1)
    real(8)            :: r(nxs:nxe,nys:nye), b(nxs:nxe,nys:nye)
    real(8)            :: ap(nxs:nxe,nys:nye)
    real(8)            :: bff_snd(2), bff_rcv(2)

    do l=1,3

       ! initial guess
       ite = 0
       sum = 0.0D0
!$OMP PARALLEL DO PRIVATE(i,j) REDUCTION(+:sum)
       do j=nys,nye
       do i=nxs,nxe
          phi(i,j) = db(l,i,j)
          b(i,j) = f5*gkl(l,i,j)
          sum = sum+b(i,j)*b(i,j)
       enddo
       enddo
!$OMP END PARALLEL DO

       call MPI_ALLREDUCE(sum,sum_g,1,mnpr,opsum,ncomw,nerr)

       eps = dsqrt(sum_g)*err

       !------ boundary condition of phi ------
       call set_boundary_phi(phi,nxs,nxe,nys,nye,l)
       !------ end of  ------

       sumr = 0.0D0
!$OMP PARALLEL DO PRIVATE(i,j) REDUCTION(+:sumr)
       do j=nys,nye
       do i=nxs,nxe
          r(i,j) = b(i,j)+phi(i,j-1)                    &
                         +phi(i-1,j)-f4*phi(i,j)+phi(i+1,j) &
                         +phi(i,j+1)
          p(i,j) = r(i,j)
          sumr = sumr+r(i,j)*r(i,j)
       enddo
       enddo
!$OMP END PARALLEL DO

       call MPI_ALLREDUCE(sumr,sumr_g,1,mnpr,opsum,ncomw,nerr)

       if(dsqrt(sumr_g) > eps)then

          do while(sum_g > eps)

             ite = ite+1

             !------boundary condition of p------
             call set_boundary_phi(p,nxs,nxe,nys,nye,l)
             !------ end of --------

             sumr = 0.0D0
             sum2 = 0.0D0
!$OMP PARALLEL DO PRIVATE(i,j) REDUCTION(+:sumr,sum2)
             do j=nys,nye
             do i=nxs,nxe
                ap(i,j) = -p(i,j-1)                    &
                          -p(i-1,j)+f4*p(i,j)-p(i+1,j) &
                          -p(i,j+1)
                sumr = sumr+r(i,j)*r(i,j)
                sum2 = sum2+p(i,j)*ap(i,j)
             enddo
             enddo
!$OMP END PARALLEL DO

             bff_snd(1) = sumr
             bff_snd(2) = sum2
             call MPI_ALLREDUCE(bff_snd,bff_rcv,2,mnpr,opsum,ncomw,nerr)
             sumr_g = bff_rcv(1)
             sum2_g = bff_rcv(2)

             av = sumr_g/sum2_g

!$OMP PARALLEL DO PRIVATE(i,j)
             do j=nys,nye
             do i=nxs,nxe
                phi(i,j) = phi(i,j)+av* p(i,j)
                r(i,j) = r(i,j)-av*ap(i,j)
             enddo
             enddo
!$OMP END PARALLEL DO

             sum_g = dsqrt(sumr_g)
             if(ite >= ite_max) then
                write(6,*)'********** stop at cgm after ite_max **********'
                stop
             endif

             sum1 = 0.0D0
!$OMP PARALLEL DO PRIVATE(i,j) REDUCTION(+:sum1)
             do j=nys,nye
             do i=nxs,nxe
                sum1 = sum1+r(i,j)*r(i,j)
             enddo
             enddo
!$OMP END PARALLEL DO

             call MPI_ALLREDUCE(sum1,sum1_g,1,mnpr,opsum,ncomw,nerr)
             bv = sum1_g/sumr_g

!$OMP PARALLEL DO PRIVATE(i,j)
             do j=nys,nye
             do i=nxs,nxe
                p(i,j) = r(i,j)+bv*p(i,j)
             enddo
             enddo
!$OMP END PARALLEL DO

          enddo
       endif

!$OMP PARALLEL WORKSHARE
       db(l,nxs:nxe,nys:nye) = phi(nxs:nxe,nys:nye)
!$OMP END PARALLEL WORKSHARE

    end do

  end subroutine cgm

end module field


      subroutine compute_jsthth(n_PHI2,n_PI2,n_U,n_a2,n_b1,Nx,res)
      implicit none
      integer i
      integer Nx
      real*8 n_PHI2(Nx)
      real*8 n_PI2(Nx)
      real*8 n_U(Nx)
      real*8 n_a2(Nx)
      real*8 n_b1(Nx)
      real*8 res(Nx)
      real*8 qb
      do i=1, Nx, 1
      qb = (0.5000000000000000D0 * (n_PI2(i) - 0.1D1 * n_PHI2(i)) / n_a2
     #(i) - 0.5000000000000000D0 * n_U(i)) * n_b1(i) ** 2
      res(i)=qb
      end do
      END


MODULE CONVERTWGS84
! ** CONVERT GEOGRAPHIC COORDINATES TO UTM AND REVERSE
! ** AUTHOR: DH CHUNG
! ** START : 2008
! ** UPDATE: 2016-06-16

USE GLOBAL,ONLY:RKD,PI,HEMI,UTMZ

IMPLICIT NONE

! ** HEMI = HEMISPHERE  (1:NORTH/2SOUTH)
! ** UTMZ = ZONE NUMBER (1:60)
! ** GEOGRAPHY SYSTEM:
! ** 1.WGS84/NAD83 /2.GRS80 /3.WGS72

CHARACTER(20):: GEOSYS='1.WGS84/NAD83'
REAL(RKD):: R_MJR      !SEMI MAJOR AXIS
REAL(RKD):: R_MNR      !SEMI MINOR AXIS
REAL(RKD):: SCLF       !SCALE ALONG CENTRAL MERIDIAN
REAL(RKD):: FE         !X OFFSET IN METER
REAL(RKD):: FN         !Y OFFSET IN METER
REAL(RKD):: LAM0       !CENTRAL MERIDIAN OF ZONE    [DEGREE]
REAL(RKD):: FLA,E2,EP2

CONTAINS

  SUBROUTINE UTMPARS
  ! ** UTM PARAMETERS

  IF (HEMI==1) THEN
    FN=0
  ELSEIF(HEMI==2) THEN
    FN=1.D7
  ENDIF

  FE=500000._RKD
  SCLF=0.9996_RKD

  IF (GEOSYS(1:1)=='1') THEN
    R_MJR = 6378137._RKD
    FLA =1._RKD/298.257223563_RKD
  ELSEIF(GEOSYS(1:1)=='2') THEN
    R_MJR = 6378137._RKD
    FLA =1._RKD/298.257222101_RKD
  ELSEIF(GEOSYS(1:1)=='3') THEN
    R_MJR = 6378135._RKD
    FLA =1._RKD/298.26_RKD
  ENDIF

  E2=2*FLA-FLA**2
  EP2=E2/(1-E2)
  R_MNR=R_MJR*SQRT(1-E2)
  LAM0 = 6*(UTMZ-30)-3    !CENTRAL MERIDIAN IN DEGREE

  END SUBROUTINE

  SUBROUTINE UTM_WGS84(LON,LAT,XUTM,YUTM)
  ! *********************************************************
  ! ** INPUT:
  ! LAT   = LATITUDE OF POINTS          [DECIMAL DEGREE]
  ! LON   = LONGITUDE OF POINTS         [DECIMAL DEGREE]
  ! ** OUTPUT:
  ! XUTM = ABSCISSA OF POINTS: XUTM    [M]
  ! YUTM = ORDINATE OF POINTS: YUTM    [M]

  REAL(RKD)  ,INTENT(IN )::LON(:),LAT(:)
  REAL(RKD)  ,INTENT(OUT)::XUTM(:),YUTM(:)
  REAL(RKD):: F2,AP,BP,CP,DP,EP,L0
  REAL(RKD),DIMENSION(SIZE(LON))::A2,A4,A6,B1,B3,B5,DLAM,RN,LEN1,TAPH,ETA2,LAM,PHI

  L0 =PI*LAM0/180
  LAM = PI*LON/180
  PHI = PI*LAT/180
  DLAM= LAM-L0

  RN=R_MJR/SQRT(1-E2*SIN(PHI)**2)
  F2=(R_MJR-R_MNR)/(R_MJR+R_MNR)

  AP=R_MJR*(1-F2+(5._RKD/4)*(F2**2-F2**3)+(81._RKD/64)*(F2**4-F2**5))
  BP=(3._RKD/2)*R_MJR*F2*(1-F2+(7._RKD/8)*(F2**2-F2**3)+(55._RKD/64)*(F2**4-F2**5))
  CP=(15._RKD/16)*R_MJR*F2**2*(1-F2+(3._RKD/4)*(F2**2-F2**3))
  DP=(35._RKD/48)*R_MJR*F2**3*(1-F2+(11._RKD/16)*(F2**2-F2**3))
  EP=(315._RKD/51)*(R_MJR*F2**4)*(1-F2)
  LEN1=AP*PHI-BP*SIN(2*PHI)+CP*SIN(4*PHI)-DP*SIN(6*PHI)+EP*SIN(8*PHI)
  ETA2=EP2*COS(PHI)**2
  TAPH = TAN(PHI)**2
  A2=RN/2*SIN(PHI)*COS(PHI)
  A4=RN/24*SIN(PHI)*COS(PHI)**3*(5-TAPH+9*ETA2+4*ETA2**2)
  A6=RN/720*SIN(PHI)*COS(PHI)**5*(61-58*TAPH+TAPH**2+270*ETA2-330*ETA2*TAPH)
  B1=RN*COS(PHI)
  B3=RN/6*COS(PHI)**3*(1-TAPH+ETA2)
  B5=RN/120*COS(PHI)**5*(5-18*TAPH+TAPH**2+14*ETA2-58*ETA2*TAPH+13*ETA2**2-64*ETA2**2*TAPH)

  YUTM=SCLF*(LEN1+A2*DLAM**2+A4*DLAM**4+A6*DLAM**6)+FN
  XUTM=SCLF*(B1*DLAM+B3*DLAM**3+B5*DLAM**5)+FE

  END SUBROUTINE

  SUBROUTINE UTMR_WGS84(XUTM,YUTM,LON,LAT)
  ! ** INPUT:
  ! XUTM           [M]
  ! YUTM           [M]
  ! ** OUTPUT:
  ! LON  = LONGITUDE (DECIMAL DEGREE)
  ! LAT  = LATITUDE  (DECIMAL DEGREE)

  REAL(RKD), INTENT(IN )::XUTM(:),YUTM(:)
  REAL(RKD), INTENT(OUT)::LON(:),LAT(:)
  REAL(RKD)::E1,J1,J2,J3,J4,L0
  REAL(RKD),DIMENSION(SIZE(XUTM))::RM,MU,BX,ETAX2,VX2,NX,TX,A2,A4,A6,B1,B3,B5,Y

  L0 =PI*LAM0/180
  RM  = YUTM/SCLF
  MU = RM/(R_MJR*(1-E2/4-3*E2**2/64 - 5*E2**3/256))

  E1 = (1-SQRT(1-E2))/(1+SQRT(1-E2))
  J1 = 3*E1/2 - 27*E1**3/32
  J2 = 21*E1**2/16 - 55*E1**4/32
  J3 = 151*E1**3/96
  J4 = 1097*E1**4/512
  BX = MU+J1*SIN(2*MU)+J2*SIN(4*MU)+J3*SIN(6*MU)+J4*SIN(8*MU)
  ETAX2=EP2*COS(BX)**2
  VX2=1+ETAX2
  NX =R_MJR/SQRT(1-E2*SIN(BX)**2)
  TX =TAN(BX)
  A2 =-VX2*TX/(2*NX**2)
  A4 =-A2/(12*NX**2)*(5+3*TX**2+ETAX2-9*ETAX2*TX**2-4*ETAX2**2)
  A6 =-A2/(360*NX**4)*(61-90*TX**2+45*TX**4-46*ETAX2)

  B1 = 1/(NX*COS(BX))
  B3 =-B1/(6*NX**2)*(1+2*TX**2+ETAX2)
  B5 =-B1/(120*NX**4)*(5+28*TX**2+24*TX**4+6*ETAX2+8*ETAX2*TX**2)
  Y  =(XUTM-FE)/SCLF
  LAT=BX+A2*Y**2+A4*Y**4+A6*Y**6
  LON=B1*Y+B3*Y**3+B5*Y**5 +L0
  LAT=LAT*180/PI ! TO DEGREE
  LON=LON*180/PI ! TO DEGREE

  END SUBROUTINE

END MODULE