!************************************************************************
  MODULE si3d_Mixing
!************************************************************************
!
!  Purpose: Define vertical mixing coefficients for momentum and mass
!           Includes the schemes originally coded by Peter Smith and
!           the 2 Eqs. model proposed by Mellor&Yamada (level 2.5) and later
!           modified by Kantha & Clayson.
!
!-------------------------------------------------------------------------

  USE si3d_Types
  USE turbulence,  only: turb_method
  USE turbulence,  only: init_turbulence, do_turbulence
  USE turbulence,  only: num,nuh,nus
  USE turbulence,  only: eps, L, tke, tkeo
  USE turbulence,  only: const_num,const_nuh
  USE turbulence,  only: gamu,gamv,gamh,gams
  USE turbulence,  only: kappa
  USE kpp,         only: init_kpp,do_kpp
  USE mtridiagonal,only: init_tridiagonal,clean_tridiagonal
  USE eqstate,     only: init_eqstate
  USE si3d_Utils

  IMPLICIT NONE
  SAVE

  CONTAINS

!***********************************************************************
SUBROUTINE UpdateMixingCoefficients(Bstart,Bend,istep,uairB,vairB,cdwB, &
& ShearProduction,BuoyancyProduction, Dissipation, TKinE)
!***********************************************************************
!
!  Purpose: To compute the vertical distribution of the vertical
!           eddy coefficients at all horizontal nodal points. The
!           choice of a turbulence model depends on the parameter
!           `iturb'.
!
!             if iturb = 0 --> eddy coefficients are constants
!             if iturb = 1 --> eddy viscosities & diffusivities calculated
!                              from TKE & a length scale using the
!                              quasi-equilibrium turbulent energy model of
!                              Galperin et. al 81988) (Mellor Yamada 2.5)
!             it iturb = -1--> GOTM libraries
!
!           Note: The vertical eddy coefficients are defined at the
!                 interfaces located vertically between pressure-pts.
!                 Later in subroutine  matmom  they are interpolated to
!                 the interfaces located vertically between the u-pts
!                 and the v-pts where they are used in the computations.
!                 The index  k  for a particular layer references the
!                 eddy coefficients at the upper interface of the layer.
!
!-----------------------------------------------------------------------

   INTEGER, INTENT(IN) :: istep
   INTEGER, INTENT(IN) :: Bstart,Bend
   REAL, DIMENSION (Bstart:Bend+1), INTENT(INOUT) :: uairB,vairB,cdwB
   REAL(real_G1), INTENT(INOUT) :: ShearProduction,BuoyancyProduction, Dissipation, TKinE

   !.....Local variables.....
   INTEGER :: i, j, k, ll, kms, k1s, nwlayers, m,liter
   REAL (real_G1), DIMENSION(1 :km1) :: drhodz, rhoavg, N2, xl, deltaz
   REAL (real_G1) :: Sm, Sh, Gh, Rt
   double precision :: depth, ustars, ustarb, z0s, z0b, copydt
   REAL, DIMENSION(1:km1) :: dudz, dvdz, ssu, ssv
   double precision, DIMENSION(0:km ) :: NN, MM, hl
   REAL  :: taub, taus, usurf, vsurf, &
            uup, uupo, udn, udno, vup, vupo, vdn, vdno
   REAL, PARAMETER :: charnock_val = 1400.0, z0s_min = 0.02, h0b = 0.05
   !.....Timing.....
   REAL, EXTERNAL :: TIMER
   REAL :: btime, etime

   ! ... Time counter & No. of calls to turbulence submodel
   btime = TIMER(0.0)
   n_turb = n_turb + 1
   copydt = dt

   SELECT CASE (iturb)

   !          ----- Inteface with GOTM -------
   CASE(-1)

     ! ... Solve only on the last iteration in each time step
     IF ( lastiter < 1) RETURN

     !.....Sweep over wet pressure points
     DO liter = lhi(omp_get_thread_num ( )+1), lhf(omp_get_thread_num ( )+1)

        ll = id_column(liter)

       ! .... Map 3D-(i,j) and l- index
       !i = l2i(ll); j = l2j(ll);

       !.....Compute the number of wet layers.....
       kms = kmz(ll); k1s = k1z(ll)
       nwlayers = (kms-k1s) + 1

       ! ... Ignore 1-layer colums
       IF (nwlayers <= 1) CYCLE

       ! ... Initialize & calculate MM & NN frequencies
       ! Note that MM, NN, and hl are ordered from bottom to top
       ! i.e. bottom layer (km) = 1 and top layer = nwlayers
       ! following Gotm convention
       MM = 0.0; NN = 0.0; m = 0; depth = 0; hl = 0.0;
       DO k = kms, k1s+1,-1

         ! ... Update counter
         m = m + 1

         ! ... Depth & layer thikness
         depth = depth + hp(k,ll)
         hl(m) = hp(k,ll)

         ! ... Calculate buoyancy frequency MM
         deltaz(k) = 0.5 * (hp  (k-1,ll) + hp  (k,ll))
         rhoavg(k) = 0.5 * (rhop(k-1,ll) + rhop(k,ll)) + 1000.
         drhodz(k) = (rhop(k-1,ll) - rhop(k,ll))/deltaz(k)
         NN    (m) = - g * drhodz(k) / rhoavg(k)

         ! ... Evaluate shear frequency MM
         !dudz  (k) = 0.5*(up(k-1,ll)+up(k-1,lWC(ll))-   &
         !&                up(k  ,ll)-up(k  ,lWC(ll)))/deltaz(k)
         !dvdz  (k) = 0.5*(vp(k-1,ll)+vp(k-1,lSC(ll))-   &
         !&                vp(k  ,ll)-vp(k  ,lSC(ll)))/deltaz(k)
         !MM    (m) =  dudz(k) **2. + dvdz(k)**2.

         ! ... The following lines follow GOTM meanflow routines
         uup  = 0.5*(u  (k-1,ll)+u  (k-1,lWC(ll)))
         udn  = 0.5*(u  (k  ,ll)+u  (k  ,lWC(ll)))
         uupo = 0.5*(upp(k-1,ll)+upp(k-1,lWC(ll)))
         udno = 0.5*(upp(k  ,ll)+upp(k  ,lWC(ll)))
         ssu(k)= 0.5*(                                      &
                     (theta    *(uup -udn )*(uup -udno)+    &
                     (1.-theta)*(uupo-udno)*(uupo-udn ))    &
                    /deltaz(k) / hp(k,ll)                  &
                    +(theta    *(uup -udn )*(uupo-udn )+    &
                     (1.-theta)*(uupo-udno)*(uup -udno))    &
                     /deltaz(k) / hp(k,ll)                  )

         vup  = 0.5*(v  (k-1,ll)+v  (k-1,lSC(ll)))
         vdn  = 0.5*(v  (k  ,ll)+v  (k  ,lSC(ll)))
         vupo = 0.5*(vpp(k-1,ll)+vpp(k-1,lSC(ll)))
         vdno = 0.5*(vpp(k  ,ll)+vpp(k  ,lSC(ll)))
         ssv(k)= 0.5*(                                      &
                     (theta    *(vup -vdn )*(vup -vdno)+    &
                     (1.-theta)*(vupo-vdno)*(vupo-vdn ))    &
                     /deltaz(k) / hp(k,ll)                  &
                    +(theta    *(vup -vdn )*(vupo-vdn )+    &
                     (1.-theta)*(vupo-vdno)*(vup -vdno))    &
                     /deltaz(k) / hp(k,ll)                  )
         MM(m) = ssu(k) + ssv(k)
       END DO

       ! ... Add conttribution of the top-most layer
       hl(m+1) = hp(k1s,ll)
       depth   = depth + hp(k1s,ll)

       ! ... Bottom friction velocity .......................
       taub  = cd  * ( (0.5*(u(kms,ll) + u(kms,lWC(ll))))**2.&
       &            +  (0.5*(v(kms,ll) + v(kms,lSC(ll))))**2.)

       !  compute the friction velocity at the bottom (from gotm code friction.F90)
       !  compute the factor r (version 1, with log-law)
       !rr=kappa/(log((z0b+dz(kms)/2)/z0b))
       !ustarb = rr*sqrt( u(kms)*u(kms) + v(kms)*v(kms) )

       !  compute the friction velocity at the bottom (original)
       ustarb = sqrt(taub)

       ! ... Surface friction velocity ......................
       usurf = 0.5*(up(k1u(ll),ll) + up(k1u(lWC(ll)),lWC(ll)) )
       vsurf = 0.5*(vp(k1v(ll),ll) + vp(k1v(lSC(ll)),lSC(ll)) )
       taus  = cdw(ll)*rhoair * ((uair(ll)-usurf)**2.+     &
       &                          (vair(ll)-vsurf)**2.)
       ustars = sqrt(taus/1000.)

       ! ... Calculate bottom roughness z0b
       z0b = 0.03*h0b

       ! ... Calculate surface roughness z0s
       z0s = MAX(charnock_val * (ustars**2.)/g, z0s_min)

       ! ... Set tke, eps, L & diff. to stored values in si3d
       m = 0
       DO k = kms, k1s+1,-1
         m = m + 1
         L   (m) = si3dlen(k,ll)
         eps (m) = si3deps(k,ll)
         tke (m) = si3dtke(k,ll)
         tkeo(m) = si3dtke(k,ll)
         num (m) = Av     (k,ll) - AvMolecular
         nuh (m) = Dv     (k,ll) - DvMolecular
       ENDDO

       ! ... Udate tke, eps, L & diff.
       CALL do_turbulence(nwlayers,copydt,depth,ustars,ustarb,z0s,z0b,  &
                          hl(0:nwlayers),NN(0:nwlayers),MM(0:nwlayers))

       ! ... Save updated tke, eps, L & diff. in si3d variables
       m = 0
       DO k = kms, k1s+1,-1
         m = m + 1
         si3dlen(k,ll) = L   (m)
         si3deps(k,ll) = eps (m)
         si3dtke(k,ll) = tke (m)
         Av     (k,ll) = num (m) + AvMolecular
         Dv     (k,ll) = nuh (m) + DvMolecular
       ENDDO

       ! ... Assign transfer coefficients at top & bottom surfaces
       Av(1:k1s,ll) = 0.0; Av(kms+1:km1,ll) = 0.0
       Dv(1:k1s,ll) = 0.0; Dv(kms+1:km1,ll) = 0.0

     ENDDO

   !PRINT *, ustarb;

   !          ----- Method 0: Constant eddy coefficients -------
   CASE (0)

     ! ... Eddy viscosity & diffusivity already initialized
     RETURN

   !          ----- Method 1: 2-equation level coefficients -----
   CASE(1:)

     ! ... Solve for q2 and q2l for next time step
     CALL SolveTKEandLengthScale(Bstart,Bend,istep,uairB,vairB,cdwB, &
     & ShearProduction,BuoyancyProduction, Dissipation, TKinE)

     !.....Sweep over wet pressure points
     DO liter = lhi(omp_get_thread_num ( )+1), lhf(omp_get_thread_num ( )+1)

        ll = id_column(liter)

       ! .... Map 3D-(i,j) from 2L-l index
!       i = l2i(ll); j = l2j(ll);

       !.....Compute the number of wet layers.....
       kms = kmz(ll); k1s = k1z(ll)
       nwlayers = (kms-k1s) + 1

       ! ... Ignore 1-layer colums
       IF (nwlayers <= 1) CYCLE

       DO k = k1s+1, kms

         ! ... Calculate density gradients @ interfaces
         deltaz(k) = 0.5 * (hp  (k-1,ll) + hp  (k,ll))
         rhoavg(k) = 0.5 * (rhop(k-1,ll) + rhop(k,ll)) + 1000.
         drhodz(k) = (rhop(k-1,ll) - rhop(k,ll))/deltaz(k)
         N2(k)     = - g * drhodz(k) / rhoavg(k)

         ! ... Calculate length scale at time n
         xl(k)    = q2lp (k,ll) / q2p (k,ll)

         ! ... Length scale limitation from Galperin et al (1988)
         IF(N2(k)>0.0) xl(k)=MIN(xl(k),0.53*DSQRT(q2p(k,ll)/N2(k)))

         ! ... Evaluate transfer coefficients at time n
         Gh = - N2(k) * xl(k)**2 / q2p(k,ll)
         Gh = MAX( Gh_min_Kc,MIN(Gh_max_Kc, Gh) )
         Sh = t_1/(1.- Gh * t_2)
         Sm = (t_3 + Sh * Gh * t_4 )/(1.-t_5*Gh)
         Rt = DSQRT (q2p(k,ll)) * xl(k)
         Av(k,ll) =  Rt * Sm +  AvMolecular
         Dv(k,ll) =  Rt * Sh +  DvMolecular

       END DO

       IF (hp(k1s,ll)<1.E-2) THEN
         Av(k1s+1,ll) = MAX(Av(k1s+1,ll),1.E-4);
         Dv(k1s+1,ll) = MAX(Dv(k1s+1,ll),1.E-4);
       ENDIF

       ! ... Assign transfer coefficients at top & bottom surfaces
       Av(1:k1s,ll) = 0.0; Av(kms+1:km1,ll) = 0.0
       Dv(1:k1s,ll) = 0.0; Dv(kms+1:km1,ll) = 0.0

     END DO

   END SELECT

   !.....Compute CPU time spent in subroutine.....
   etime = TIMER(0.0)
   t_turb = t_turb + (etime - btime)

END SUBROUTINE UpdateMixingCoefficients

!***********************************************************************
SUBROUTINE SolveTKEandLengthScale(Bstart,Bend,istep,uairB,vairB,cdwB, &
& ShearProduction,BuoyancyProduction, Dissipation, TKinE)
!***********************************************************************
!
!  Purpose: Solve a 2 equation model for turbulence quantities (2*TKE &
!           a generic length scale variable - in this case 2*TKE*l).
!
!  Replace l (index) by m so that there ins not any overlap with variable
!  L (length scale) used in gotm
!
!-----------------------------------------------------------------------

   INTEGER, INTENT(IN) :: istep
   INTEGER, INTENT(IN) :: Bstart,Bend
   REAL(real_G1), INTENT(INOUT) :: ShearProduction,BuoyancyProduction, Dissipation, TKinE
   REAL, DIMENSION (Bstart:Bend+1), INTENT(INOUT) :: uairB,vairB,cdwB

   !.....Local variables.....
   REAL (real_G1), DIMENSION(1:km1) ::  zfromb, zfromt, deltaz, deltazp
   REAL (real_G1), DIMENSION(1:km1) ::  drhodz, rhoavg, xl, dvdz, dudz, &
   &                                     ShearP, BuoyP, dcoeff, N2, N2p, rho_c
   REAL (real_G1) :: Sm, Sh, Gh, dum_1, taurb, taurs, zfromb0, zfromt0, Dissipijk
   INTEGER        :: i, j, k, m, istat, nwlayers, kms, k1s, nn, in, jn, liter
   REAL           :: twodt1, htot, vsurf, usurf, ustar, rhoxh
   REAL (real_G1), DIMENSION(1:km1) :: dsTh
   REAL (real_G1), DIMENSION(3,1:km1+1) :: aaTh
   REAL (real_G1), DIMENSION(1:ndz+1) :: sal1Th

   ! .. Initialize twodt1
   twodt1 = twodt/istep

   ! ... Initialize variables for basin scale energy balances
   IF ( iobal > 0 .AND. istep > 1) THEN
     ShearProduction    = 0.E0
     BuoyancyProduction = 0.E0
     Dissipation        = 0.E0
     TKinE              = 0.E0
   ENDIF

   !.....Sweep over wet pressure points
   DO liter = lhi(omp_get_thread_num ( )+1), lhf(omp_get_thread_num ( )+1)

       m = id_column(liter)

       ! ... 3D-(i,j) indexes for l (= m)
!       i = l2i(m); j = l2j(m);

       !.....Compute the number of wet layers.....
       kms = kmz(m); k1s = k1z(m);
       nwlayers = (kms-k1s) + 1

       !.....Ignore 1-layer columns
       IF (nwlayers <= 1) CYCLE

       !.....Calculate total depth
       htot = SUM(hp(k1s:kms,m));

       ! Compute the array of vertical distances from the bottom
       ! of the water column to the top of each layer
       zfromb0 = 0.0
       DO k = kms, k1s+1, -1
          zfromb0 = zfromb0 + hp(k,m)
          zfromb(k) = zfromb0
       END DO
       zfromb(k1s  ) = htot
       zfromb(kms+1) = 0.0E0

       ! Compute the array of vertical distances from the top
       ! of the water column to the top of each layer
       zfromt0 = 0.0
       DO k = k1s+1, kms
          zfromt0   = zfromt0 + hp(k-1,m)
          zfromt(k) = zfromt0
       END DO
       zfromt(k1s  ) = 0.0E0
       zfromt(kms+1) = htot

       ! ... Calculate length scale at time n
       xl(k1s+1:kms) = q2lp(k1s+1:kms,m)/ q2p(k1s+1:kms,m)
       xl(k1s)   = 0.0
       xl(kms+1) = 0.0

       ! ----- TURBULENT KINETIC ENERGY ( q2 ) equations -----------------

       ! ... Calculate shear & buoyancy source terms
       DO k = k1s+1, kms

         ! ... Calculate density  gradients @ time n
         deltaz(k) = 0.5 * (hp  (k-1,m) + hp  (k,m))
         rhoavg(k) = 0.5 * (rhop(k-1,m) + rhop(k,m)) + 1000.
         drhodz(k) =       (rhop(k-1,m) - rhop(k,m))/deltaz(k)
         N2(k)     = - g / rhoavg(k) * drhodz (k)

         ! ... Evaluate shear
         dudz(k)  = 0.5*( up(k-1,m)+up(k-1,lWC(m)) -   &
         &                up(k  ,m)-up(k  ,lWC(m)) ) / deltaz(k)
         dvdz(k)  = 0.5*( vp(k-1,m)+vp(k-1,lSC(m)) -   &
         &                vp(k  ,m)-vp(k  ,lSC(m)) ) / deltaz(k)

         ! ... Length scale limitation from Galperin et al (1988)
         IF (N2(k)>0.0E0) xl(k)=MIN(xl(k),0.53*DSQRT(q2p(k,m)/N2(k)))

         ! ... Calculate production of TKE @ interfaces
         ShearP(k)=  Av(k,m)*( dudz(k) **2. + dvdz(k)**2. )
         BuoyP (k)= -Dv(k,m)*( N2 (k)                     )

       END DO

       ! ... Form diffusion coefficients for q2 & q2l & time n
       dcoeff (k1s:kms) = Sq * 0.50* (xl(k1s:kms  )+ xl(k1s+1:kms+1  )) *  &
       &               DSQRT ( 0.50*(q2p(k1s:kms,m)+q2p(k1s+1:kms+1,m)) )

       ! ... Form tridiagonal matrix [aa] ...............................

       ! a. Define upper diagonal terms
       aaTh(3,k1s     ) = 0.0
       aaTh(3,k1s+1:kms) = - dcoeff(k1s+1:kms) /                            &
       &  (hp(k1s+1:kms,m) * 0.50 * (hp(k1s+1:kms,m)+hp(k1s:kms-1,m)))
       aaTh(3,kms+1   ) = 0.0

       ! b. Define lower diagonal terms
       aaTh(1,kms+1   ) = 0.0
       aaTh(1,k1s+1:kms) = - dcoeff(k1s :kms-1) /                           &
       &  (hp(k1s:kms-1,m)  * 0.50 * (hp(k1s+1:kms,m)+hp(k1s:kms-1,m)))
       aaTh(1,k1s     ) = 0.0

       ! c. Define center diagonal terms
       aaTh(2,k1s     )  = 3./twodt1
       aaTh(2,k1s+1:kms) = 3./twodt1 - aaTh(1,k1s+1:kms) - aaTh(3,k1s+1:kms)  &
       &          + 2. * ( DSQRT(q2p(k1s+1:kms,m))/ (B_1*xl(k1s+1:kms)) )
       aaTh(2,kms+1   )  = 3./twodt1

       !.....Form r.h.s. matrix [ds_t]................................
       dsTh(k1s+1:kms)  = 4. * q2p (k1s+1:kms,m)/twodt1                     &
                       -      q2pp(k1s+1:kms,m)/twodt1
       DO k = k1s+1, kms
         IF ( BuoyP(k) >= 0.0 ) THEN
            dsTh(k) = dsTh(k) + 2. * (ShearP(k) + BuoyP(k))
         ELSE
            dsTh(k) = dsTh(k) + 2. * (ShearP(k)           )
            aaTh(2,k) = aaTh(2,k)               - BuoyP(k) * 2. / q2p(k,m)
         ENDIF
       ENDDO

       ! ... Bottom boundary condition ...............................
       ustar = cd  * ( (0.5*(u(kms,m) + u(kms,lWC(m))))**2                 &
       &            +  (0.5*(v(kms,m) + v(kms,lSC(m))))**2 )
       dsTh(kms+1) = 3.*B_1**(2./3.)*ustar/twodt1

       ! ... Surface boundary condition ..............................
       usurf = 0.5*(up(k1u(m),m) + up(k1u(lWC(m)),lWC(m)) )
       vsurf = 0.5*(vp(k1v(m),m) + vp(k1v(lSC(m)),lSC(m)) )
       ustar = cdw(m)*rhoair * ((uair(m)-usurf)**2.+     &
                                  (vair(m)-vsurf)**2.)/1000.
       dsTh(k1s  ) = 3.*B_1**(2./3.)*ustar/twodt1

       !.....Solve tridiagonal system for vertical distribution of TKE
       CALL tridT (aaTh, dsTh, sal1Th, k1s, kms+1, kms+2, nwlayers+1)

       !.....Define TKE at next time step....
       q2(k1s:kms+1,m) = MAX(q2_min,sal1Th(1:nwlayers+1))
       q2(k1 :k1s-1,m) = q2(k1s,m)

       ! ... Define variables for basin scale energy balances
       IF (iobal > 0 .AND. istep > 1) THEN
         DO k = k1s+1, kms
           rhoxh = (rhop(k,m)+1000.)*hp(k,m)
           Dissipijk  = q2(k,m) * DSQRT(q2p(k,m))/ (B_1*xl(k))
           ShearProduction    = ShearProduction    + ShearP(k)*rhoxh
           BuoyancyProduction = BuoyancyProduction + BuoyP (k)*rhoxh
           Dissipation        = Dissipation        + Dissipijk*rhoxh
           TKinE              = TKinE              + q2(k,m)  *rhoxh
         ENDDO
       ENDIF

       ! ----- EQUATIONS for TURBULENT LENGTH SCALE ( q2l ) ----------

       ! ... Form tridiagonal matrix [aa] ............................

       ! a. Define upper diagonal terms (same as for q2)

       ! b. Define lower diagonal terms (same as for q2)

       ! c. Define center diagonal terms - Wall function as proposed by M&Y
       DO k = k1s+1, kms
         aaTh(2,k) = 3./twodt1 - aaTh(1,k) - aaTh(3,k)                      &
                  + DSQRT(q2p(k,m))/ (B_1*xl(k))  *                      &
         &   ( 1. + E_2 * ( xl(k)/(kappaS*zfromb(k)))** 2. +              &
         &          E_3 * ( xl(k)/(kappaS*zfromt(k)))** 2. )
       ENDDO
       aaTh(2,k1s  ) = 3./twodt1
       aaTh(2,kms+1) = 3./twodt1

       !.....Form r.h.s. matrix [ds_t].....................................
       SELECT CASE (iturb)
       CASE (1) ! Original MY2.5 formulation
         DO k = k1s+1, kms
          IF ( BuoyP(k) >= 0 ) THEN
            dsTh(k  ) = xl(k   )*(E_1*ShearP(k)+E_1*BuoyP(k))
          ELSE
            dsTh(k  ) = xl(k   )*(E_1*ShearP(k)             )
            aaTh(2,k) = aaTh(2,k)              - E_1*BuoyP(k)/q2p(k,m)
          ENDIF
         ENDDO
       CASE (2:) !k-kl implementation of Burchard et. al 1999
         DO k = k1s+1, kms
          IF ( BuoyP(k) >= 0 ) THEN
            dsTh(k  ) = xl(k   )*(E_1*ShearP(k)+2.00*BuoyP(k))
          ELSE
            dsTh(k  ) = xl(k   )*(E_1*ShearP(k)              )
            aaTh(2,k) = aaTh(2,k)              - 5.06*BuoyP(k)/q2p(k,m)
          ENDIF
        ENDDO
       END SELECT

       dsTh(k1s+1:kms) = dsTh(k1s+1:kms)                       &
        &             + 4 * q2lp (k1s+1:kms,m)/twodt1        &
        &             -     q2lpp(k1s+1:kms,m)/twodt1

       ! ... Enforce Dirichlet bottom boundary condition ................
       dsTh(kms+1) = 0.0

       ! ... Enforce Dirichlet surface boundary condition ...............
       dsTh(k1s  ) = 0.0

       !.....Solve tridiagonal system for vertical distribution of TKE .
       CALL tridT (aaTh, dsTh, sal1Th, k1s, kms+1, kms+2, nwlayers+1)

       !.....Define TKE at next time step....
       !     Make sure that Lc > alpha * Lk -Ivey&Imberger, 1991)
       q2l(k1s:kms+1,m) = MAX(q2l_min,sal1Th(1:nwlayers+1))
       q2l(k1 :k1s-1,m) = q2l(k1s,m)

   END DO

   IF (iobal > 0 .AND. istep == 1) THEN
     ShearProduction    = ShearProduction    * dx * dy * dt
     BuoyancyProduction = BuoyancyProduction * dx * dy * dt
     Dissipation        = Dissipation        * dx * dy * dt
     TKinE              = 0.5 * TKinE        * dx * dy * dt
     !$omp critical
     ShearCum = ShearCum + ShearProduction
     BuocyCum = BuocyCum + BuoyancyProduction
     DisspCum = DisspCum + Dissipation
     !$omp end critical
   ENDIF

END SUBROUTINE SolveTKEandLengthScale

!***********************************************************************
SUBROUTINE tridT ( acoef, ds, sal, k1, km, km1, n )
!***********************************************************************
!
!  Purpose: Tridiagonal matrix solver for scalar equation using
!           the double-sweep method
!
!  Revisions:
!    Date            Programmer        Description of revision
!    ----            ----------        -----------------------
!   3/7/00           F.F. Rueda        Original f90 code
!
!-----------------------------------------------------------------------

   !.....Dimensioning parameter.....
   INTEGER, PARAMETER :: kmax = 500

   !.....Arguments.....
   INTEGER, INTENT(IN) :: k1, km, km1, n
   REAL(real_G1), DIMENSION(km), INTENT(INOUT)  :: ds
   REAL(real_G1), DIMENSION(n),  INTENT(INOUT)  :: sal
   REAL(real_G1), DIMENSION(3,km1), INTENT(IN)  :: acoef

   !.....Local variables.....
   INTEGER :: k, kk
   REAL(real_G1), DIMENSION(kmax) :: a, b, c, d, e, f

   ! Note: n = number of 3-d layers (also number of unknowns)

   !.....Load diagonals of coefficient matrix into
   !     1-d arrays and rename r.h.s. vector.....
   k = 0
   DO kk = k1, km
      k = k + 1
      a(k) = acoef(1,kk)
      b(k) = acoef(2,kk)
      c(k) = acoef(3,kk)
      d(k) = ds(kk)
   END DO

   !.....Initialize for forward sweep.....
   e(1) = -c(1)/b(1)
   f(1) =  d(1)/b(1)

   !.....Forward sweep (solve for  e  and  f  vectors).....
   IF(n == 2) GO TO 1
   DO k = 2, n-1
      e(k) = -c(k)/(b(k)+a(k)*e(k-1))
      f(k) = (d(k)-a(k)*f(k-1))/(b(k)+a(k)*e(k-1))
   END DO

   !.....Compute scalar in bottom layer.....
 1 sal(n) = (d(n)-a(n)*f(n-1))/(b(n)+a(n)*e(n-1))

   !.....Backward sweep (solve for scalar vector).....
   DO k = n-1, 1, -1
      sal(k) = e(k) * sal(k+1) + f(k)
   END DO

END SUBROUTINE tridT

!***********************************************************************
 SUBROUTINE InitializeTurbulenceModel
!***********************************************************************
!
!  Purpose: To define initial conditions for turbulent quantities.
!
!  Replace l (index) by m so that there ins not any overlap with variable
!  L (length scale) used in gotm
!
!-----------------------------------------------------------------------

   ! ... Local variables
   INTEGER :: i,j,k,m, ll
   INTEGER :: kms, k1s
   REAL    :: zfromb0, zfromt0, htot
   REAL, DIMENSION (km1) :: mixl, zfromb, zfromt
   INTEGER, PARAMETER :: namlst = 10

   SELECT CASE (iturb)

   ! ... GOTM
   CASE(-1)

     CALL init_turbulence(namlst,'gotmturb.nml',km)
     CALL init_tridiagonal(km)
     ! Note - if we do not use KPP methods we do not have to initializeq
     ! equation of state or kpp -
     DO m = 1, lm
       si3dtke(k1:km1,m) = tke
       si3deps(k1:km1,m) = eps
       si3dlen(k1:km1,m) = L
       Av     (k1:km1,m) = num
       Dv     (k1:km1,m) = nuh
     ENDDO

   ! ... Fixed eddy viscosity & diffusivity
   CASE (0)

     !.....Loop horizontally over pressure-points.....
     DO ll = 1, lm

       ! .... Map 3D-(i,j) from 2L-l index
       i = l2i(ll); j = l2j(ll);

       ! ... Define top & bottom layers
       kms = kmz(ll); k1s = k1z(ll)

       ! Set eddy coefficients at the free surface to zero
       Av(k1s,ll) = 0.0; Dv(k1s,ll) = 0.0   ! unnecessary
       IF ( kms > k1s ) THEN   ! Two or more layers
         DO k = k1s+1, kms
           Av(k,ll) = Av0;
           Dv(k,ll) = Dv0;
         END DO
       END IF
       ! Set eddy coefficients at the bottom boundary to zero
       Av(kms+1,ll) = 0.0; Dv(kms+1,ll) = 0.0
     END DO

   ! ... Original si3D implementation
   CASE (1)

     ! ... Fundamental parameters & combinations for the quasi-equilibrium
     !     stability functions of Kantha & Clayson (1994).
     t_1 = A_2 * (1.-6.*A_1/B_1)
     t_2 = 3.*A_2*(6.*A_1+B_2*(1.- C_3))
     t_3 = B_1**(-1./3.)
     t_4 = 9.*A_1*(2.*A_1+A_2*(1.-C_2))
     t_5 = 9.*A_1*A_2

     q2   = q2_min;
     q2p  = q2_min;
     q2pp = q2_min;

     DO m = 1, lm
       ! ... 3D-(i,j) indexes for l
       i = l2i(m);
       j = l2j(m);
       ! Calculate mixing length
       kms = kmz(m);
       k1s = k1z(m);
       htot = SUM(hp(:,m))
       IF ( kms > k1s ) THEN
         ! Compute the array of vertical distances from the bottom
         ! of the water column to the top of each layer
         zfromb0 = 0.0
         DO k = kms, k1s+1, -1
             zfromb0   = zfromb0 + hp(k,m)
             zfromb(k) = zfromb0
         END DO
         ! Compute the array of vertical distances from the top
         ! of the water column to the top of each layer
         zfromt0 = 0.0
         DO k = k1s+1, kms
             zfromt0   = zfromt0 + hp(k-1,m)
             zfromt(k) = zfromt0
         END DO
         DO k = k1s+1, kms
           mixl(k) = kappaS*zfromt(k)*SQRT(MAX(1.-(zfromt(k)/htot),0.0E0))
           q2l(k,m) = q2(k,m)*mixl(k)
         END DO
         q2l(k1s,m) = 0.0; q2l(kms+1,m) = 0.0;
       END IF
     END DO
     !q2l   = q2l_min;
     q2lp  = q2l;
     q2lpp = q2l;

   END SELECT

 END SUBROUTINE InitializeTurbulenceModel

!***********************************************************************
SUBROUTINE settrap_2EqTVars
!***********************************************************************
!
!  Purpose: To setup the arrays at the  n  and  n+1/2  time levels
!           for use in the first iteration of the  trapezoidal step.
!           q2 and q2l at next time level are only solved once
!           in a iteration cycle.
!
!  Replace l (index) by m so that there ins not any overlap with variable
!  L (length scale) used in gotm
!
!-----------------------------------------------------------------------

   INTEGER :: i,j,k,m,k1s,kms,liter

   DO liter = lhi(omp_get_thread_num ( )+1), lhf(omp_get_thread_num ( )+1)

     m = id_column(liter)

     ! ... 3D-(i,j) indexes for l (= m)
!     i = l2i(m); j = l2j(m);

     ! ... Top & bottom cells
     kms = kmz(m); k1s = k1z(m);

     DO k = k1, kms

       q2pp (k,m) = q2p (k,m)
       q2lpp(k,m) = q2lp(k,m)
       q2p  (k,m) = 0.5*(q2 (k,m)+q2pp (k,m))
       q2lp (k,m) = 0.5*(q2l(k,m)+q2lpp(k,m))

     ENDDO

     ! ... Define values at subsurface if wetting occurs
     k = k1s;
     IF ( hpp(k,m) <= ZERO ) THEN
        q2lp(k+1,m)=q2lp(k+2,m);
        q2p (k+1,m)=q2p (k+2,m);
     ENDIF

  ENDDO

END SUBROUTINE settrap_2EqTVars

!***********************************************************************
SUBROUTINE settrap2_2EqTVars
!***********************************************************************
!
!  Purpose: To setup the arrays at the  n  and  n+1/2  time levels
!           for use in the first iteration of the  trapezoidal step.
!           q2 and q2l at next time level are only solved once
!           in a iteration cycle.
!
!  Replace l (index) by m so that there ins not any overlap with variable
!  L (length scale) used in gotm
!
!-----------------------------------------------------------------------

   INTEGER :: i,j,k,m,k1s,kms,liter

   DO liter = lhi(omp_get_thread_num ( )+1), lhf(omp_get_thread_num ( )+1)

     m = id_column(liter)

     ! ... 3D-(i,j) indexes for l (= m)
!     i = l2i(m); j = l2j(m);

     ! ... Top & bottom cells
     kms = kmz(m); k1s = k1z(m);

     DO k = k1, kms
       q2p (k,m) = 0.5*(q2 (k,m)+q2pp (k,m))
       q2lp(k,m) = 0.5*(q2l(k,m)+q2lpp(k,m))
     ENDDO

     ! ... Redefine q2&q2l at subsurface cell if wetting occurs
     !     from n+1/2(n) to n+1
     k = k1s;
     IF ( hpp(k,m) <= ZERO ) THEN
        q2lp(k+1,m)=q2lp(k+2,m);
        q2p (k+1,m)=q2p (k+2,m);
     ENDIF

  ENDDO

END SUBROUTINE settrap2_2EqTVars

!***********************************************************************
SUBROUTINE save_2EqTvars(istep)
!***********************************************************************
!
!  Purpose: To save solution of variables implicated in 2-Equation
!           turbulence models
!
!  Replace l (index) by m so that there ins not any overlap with variable
!  L (length scale) used in gotm
!
!-----------------------------------------------------------------------

   INTEGER, INTENT(IN) :: istep

   INTEGER :: i,j,k,m,k1s,kms,liter

   SELECT CASE (istep)
   CASE (1)

       q2pp(:,lm1)  = q2p(:,lm1) ;
       q2p(:,lm1)   = q2(:,lm1)  ;
       q2lpp(:,lm1) = q2lp(:,lm1);
       q2lp(:,lm1)  = q2l(:,lm1) ;

     DO liter = lhi(omp_get_thread_num ( )+1), lhf(omp_get_thread_num ( )+1)

     m = id_column(liter)

       q2pp(:,m)  = q2p(:,m) ;
       q2p(:,m)   = q2(:,m)  ;
       q2lpp(:,m) = q2lp(:,m);
       q2lp(:,m)  = q2l(:,m) ;
       ! ... 3D-(i,j) indexes for l (= m)
!       i = l2i(m); j = l2j(m);
       ! ... Top & bottom cells
       k1s = k1z(m);
       ! ... Redo calculations if wetting occurs in
       IF ( hpp(k1s,m) <= ZERO ) THEN
          q2lp(k1s+1,m)=q2lp(k1s+2,m);
          q2p (k1s+1,m)=q2p (k1s+2,m);
       ENDIF
     ENDDO

   CASE (2)

     q2p(:,lm1)   = q2(:,lm1)  ;
     q2lp(:,lm1)  = q2l(:,lm1) ;

     DO liter = lhi(omp_get_thread_num ( )+1), lhf(omp_get_thread_num ( )+1)

     m = id_column(liter)

       q2p(:,m)   = q2(:,m)  ;
       q2lp(:,m)  = q2l(:,m) ;
       ! ... 3D-(i,j) indexes for l (= m)
!       i = l2i(m); j = l2j(m);
       ! ... Top & bottom cells
       k1s = k1z(m);
       IF ( km1 - k1s > 1 ) THEN
       ! ... Redo calculations if wetting occurs in
          IF ( hpp(k1s,m) <= ZERO ) THEN
             q2lp(k1s+1,m)=q2lp(k1s+2,m);
             q2p (k1s+1,m)=q2p (k1s+2,m);
          ENDIF
       ENDIF
     ENDDO

   END SELECT

END SUBROUTINE save_2EqTvars

!************************************************************************
 SUBROUTINE UpdateHorizontalMixingCoefficients
!************************************************************************
!
!  Purpose: Calculate horizontal turbulence coefficients following
!  Alan Blumberg ( Turbulent Mixing Processes in Lakes, Reservours and
!  Impoundments, Ch.4 in Physics based Modeling of Lakes ASCE). Based
!  on Smagorinsky Model.
!
!  Revisions:
!    Date            Programmer        Description of revision
!    ----            ----------        -----------------------
!   10/21/05         F.J. Rueda        Original f90 code
!   10/27/05         F.J. Rueda        Allow to choose Smag. vs. fixed ax0
!
!------------------------------------------------------------------------

  INTEGER :: istat, i, j, l, k, k1s, kms,aux_index,liter
  REAL :: dudx, dvdy, dudy, dvdx
  REAL, PARAMETER :: horcon = 0.03;

  ! ... Return is fixed values of eddy viscosity are set
  SELECT CASE (ihd)

  CASE (0,1)   ! ... Fixed horizontal eddy viscosity values entered in input file

    !Nothing

  CASE DEFAULT  ! ... Smagorinsky-type closure

    ! ... Loop over centers of cells computin kh
    IF(omp_get_thread_num ( )+1 == num_threads)THEN
       aux_index=lhf(omp_get_thread_num ( )+1)
    ELSE
       aux_index=lhfE(omp_get_thread_num ( )+1)
    END IF
   DO liter = lhiW(omp_get_thread_num ( )+1), aux_index
     if(liter==0) CYCLE

     l = id_column(liter)

      ! ... Map 3D-(i,j) from 2D-l indexes
      !i = l2i(l); j = l2j(l);

      ! ... Define top & bottom layers
      kms = kmz(l); k1s = k1z(l)

      ! ... Horizontal viscosity/diffusivity (at cell centers) - POM .......
      DO k = k1s, kms
        IF ( hp(k,lWC(l)) <= ZERO .OR. &
             hp(k,lEC(l)) <= ZERO .OR. &
             hp(k,lSC(l)) <= ZERO .OR. &
             hp(k,lNC(l)) <= ZERO ) THEN
          kh(k,l) = Ax0
        ELSE
          ! HORCON*DX*DY*SQRT((DU/DX)**2+(DV/DY)**2+.5*(DU/DY+DV/DX)**2)
          dudx = ( upp(k,l) - upp(k,lWC(l)) )/dx
          dvdy = ( vpp(k,l) - vpp(k,lSC(l)) )/dy
          dudy = ((upp(k,lNC(l)) + upp(k,lNC(lWC(l)))) -      &
              &   (upp(k,lSC(l)) + upp(k,lSC(lWC(l))))) / fourdy
          dvdx = ((vpp(k,lEC(l)) + vpp(k,lEC(lSC(l)))) -      &
              &   (vpp(k,lWC(l)) + vpp(k,lWC(lSC(l))))) / fourdx
          kh(k,l) = MAX(Ax0, horcon*dx*dy* &
                    SQRT(dudx**2.+dvdy**2.+.5*(dudy+dvdx)**2.))
        ENDIF
      ENDDO

    ENDDO

  END SELECT

  END SUBROUTINE UpdateHorizontalMixingCoefficients

END MODULE si3d_Mixing


! This code is from QEDMOD with minor modifications.
!
!   V.M. Shabaev, I.I. Tupitsyn, V.A. Yerokhin, QEDMOD: Fortran program for calculating
!   the model Lamb-shift operator, Computer Physics Communications, Volume 189, 2015,
!   Pages 175-181, ISSN 0010-4655, http://dx.doi.org/10.1016/j.cpc.2014.12.002.
!
! For a description of the changes made, see the README.
!
! Original code is distributed under the CPC non-profit use licence
! (http://cpc.cs.qub.ac.uk/licence/licence.html). Redistributed here as part of
! GRASP2K with permission from the authors.
!
! Originally from: f/potgen/potuse2.f
!
c=======================================================================
        subroutine SHAB_wfunc_interpolate(KA,NnA,x,GA,FA)
c
c 5-point interpolation of the stored wave function
c
        implicit real*8 (a-h,o-z)
        parameter (numRadPo = 10000)
        real*8 Fg(0:10),Ff(0:10)

        parameter (numwfMax = 10)
        common /SHAB_DF/xr(numRadPo,numwfMax),Gc(numRadPo,numwfMax),
     &  Fc(numRadPo,numwfMax),npoints(numwfMax),nc,KC(numwfMax),
     &  NnC(numwfMax)

        save left
        data left/0/
c--
        inum = 0
        do j = 1,nc
           if ((KA.eq.KC(j)).and.(NnA.eq.NnC(j))) inum = j
        enddo
        if (inum.eq.0) then
           print *,"kappa = ",KA," n = ",NnA
           stop 'wf_DF_int: 1'
        end if
c-
        GA = 0.d0
        FA = 0.d0
        nmax = npoints(inum)

        if (x.gt.xr(nmax,inum)) return
c-
        if ((left.ge.nmax).or.(left.lt.1)) left=1
        if (x.lt.xr(left,inum)) left=1

        do while ((left.lt.nmax).and.(x.gt.xr(left+1,inum)))
           left = left+1
        enddo

        imin = max(1,   left-2)
        imax = min(nmax,left+2)
        if (imin.eq.1) imax = 3
        if (imax.eq.nmax) imin = nmax-4

        do j = imin,imax
           Fg(j-imin) = Gc(j,inum)
           Ff(j-imin) = Fc(j,inum)
        enddo

        do j = imin+1,imax
           do i = j,imax
              Fg(i-imin) = (Fg(j-imin-1)-Fg(i-imin))
     >                                /(xr(j-1,inum)-xr(i,inum))
              Ff(i-imin) = (Ff(j-imin-1)-Ff(i-imin))
     >                                /(xr(j-1,inum)-xr(i,inum))
           enddo
        enddo

        GA = Fg(imax-imin)
        FA = Ff(imax-imin)
        do i = imax-1,imin,-1
           GA = Fg(i-imin)+ (x-xr(i,inum))* GA
           FA = Ff(i-imin)+ (x-xr(i,inum))* FA
        enddo
c--
        return
        end


program main
  implicit none
  integer x, order, degree

  factorial(x) = gamma(x-1)
  do order=1,20
    do degree=0,order+1)
        print*, (binomial(order, degree), ' ')
    end
    print('\Vn')
end


!>---------------
!! MP-DATA flux correction core code
!!
!!  @author
!!  Ethan Gutmann (gutmann@ucar.edu)
!!
!!---------------
! For Reference, this is the core 1D implementation of mpdata included earlier in the code from adv_mpdata_core.f90
!
! It is stored in a separate file so that the same code can
! be used for advect_u, advect_v, and advect_w after l, r, etc. are set up
!
!     ! First Calculate the standard upwind advection
!     call flux1(l,r,U2,f)
!
!     ! q1 is a temporary array to store the data while working with it here.
!     q1(1)=l(1)
!     q1(n)=r(n-1)
!     q1(2:n-1) = l(2:n-1) + (f(:n-2) - f(2:n-1))
!
!     ! This is the MPDATA diffusion correction term for 1D flow
!     ! U is defined on the mass grid for the pseudo-velocities?
!     ! left and right pseudo (diffusive) velocities
!
!     ! we will copy the q1 data into r to potentially minimize aliasing problems
!     ! for the compiler, and improve memory alignment for vectorization
!     r  = q1(2:n)
!     ! l  = q1(1:n-1) ! no need to copy these data over again
!
!     ! In MPDATA papers (r-l)/(r+l) is usually refered to as "A"
!     ! compute the denomenator first so we can check that it is not zero
!     denom=(r + q1(1:n-1))
!     where(denom==0) denom=1e-10
!     ! U2 is the diffusive pseudo-velocity
!     U2 = abs(U2) - U2**2
!     U2 = U2 * (r-q1(1:n-1)) / denom
!
!     ! now calculate the MPDATA flux term
!     call flux1(q1(1:n-1),r,U2,f)

! Fluxes are added to the original scalar field in the advect_u and advect_v subroutines

! This is the Flux Corrected Transport option described in :
! Smolarkiewicz and Grabowski (1990) J. of Comp. Phys. v86 p355-375

! for now at least this is in a loop instead of vectorized.  I'm not sure how easy this would be to vectorize.
    do i=1,n-1
        ! first find the min and max values allowable in the final field based on the initial (stored in l) and upwind (q1) fields
        ! min and max are taken from the grid cells on either side of the flux cell wall to be corrected
        if (i==1) then
            ! l still equals q0
            qmax_i=max(q1(i),q1(i+1),l(i),l(i+1))
            qmin_i=min(q1(i),q1(i+1),l(i),l(i+1))
            qmax_i2=max(q1(i),q1(i+1),q1(i+2),l(i),l(i+1),l(i+2))
            qmin_i2=min(q1(i),q1(i+1),q1(i+2),l(i),l(i+1),l(i+2))
        elseif (i/=(n-1)) then
            ! l still equals q0
            qmax_i=qmax_i2
            qmin_i=qmin_i2
            qmax_i2=max(q1(i),q1(i+1),q1(i+2),l(i),l(i+1),l(i+2))
            qmin_i2=min(q1(i),q1(i+1),q1(i+2),l(i),l(i+1),l(i+2))
        else
            ! for the boundary, q1(i+1)==q0(i+1), l is only 1:n-1
            qmax_i=qmax_i2
            qmin_i=qmin_i2
            qmax_i2=max(q1(i),q1(i+1),l(i))
            qmin_i2=min(q1(i),q1(i+1),l(i))
        endif

        ! next compute the total fluxes into and out of the upwind and downwind cells
        ! these are the fluxes into and out of the "left-hand" cell (which is just the previous "right-hand" cell)
        if (i/=1) then
            fin_i  = fin_i2
            fout_i = fout_i2
        else
            if (flux_is_w) then
                fin_i = 0. - min(0.,f(i))
                fout_i = max(0.,f(i))
            else
                ! No flux limitations to the boundary cell
                fin_i  = 0
                fout_i = 0
            endif

        endif

        ! these are the fluxes into and out of the "right-hand" cell
        if (i/=(n-1)) then
            fin_i2 = max(0.,f(i)) - min(0.,f(i+1))
            fout_i2 = max(0.,f(i+1)) - min(0.,f(i))
        else
            if (flux_is_w) then
                fin_i2 = max(0.,f(i)) - min(0.,f(i))
                fout_i2 = max(0.,f(i)) - min(0.,f(i))
            else
                ! No flux limitations to the boundary cell
                fin_i2  = 0
                fout_i2 = 0
            endif
        endif

        ! if wind is left to right we limit based on flow out of the left cell and into the right cell
        if (U2(i)>0) then
            beta_out_i = (q1(i)-qmin_i) / (fout_i+1e-15)
            beta_in_i2 = (qmax_i2-q1(i+1)) / (fin_i2+1e-15)

            U2(i) = min(1.,beta_in_i2, beta_out_i) * U2(i)

        ! if wind is right to left we limit based on flow out of the right cell and into the left cell
        elseif (U2(i)<0) then
            beta_in_i = (qmax_i-q1(i)) / (fin_i+1e-15)
            beta_out_i2 = (q1(i+1)-qmin_i2) / (fout_i2+1e-15)

            U2(i) = min(1.,beta_in_i, beta_out_i2) * U2(i)
        endif
    end do


*> \brief \b CQRT04
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE CQRT04(M,N,NB,RESULT)
*
*       .. Scalar Arguments ..
*       INTEGER M, N, NB, LDT
*       .. Return values ..
*       REAL RESULT(6)
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CQRT04 tests CGEQRT and CGEMQRT.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          Number of rows in test matrix.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          Number of columns in test matrix.
*> \endverbatim
*>
*> \param[in] NB
*> \verbatim
*>          NB is INTEGER
*>          Block size of test matrix.  NB <= Min(M,N).
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*>          RESULT is REAL array, dimension (6)
*>          Results of each of the six tests below.
*>
*>          RESULT(1) = | A - Q R |
*>          RESULT(2) = | I - Q^H Q |
*>          RESULT(3) = | Q C - Q C |
*>          RESULT(4) = | Q^H C - Q^H C |
*>          RESULT(5) = | C Q - C Q |
*>          RESULT(6) = | C Q^H - C Q^H |
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date April 2012
*
*> \ingroup complex_lin
*
*  =====================================================================
      SUBROUTINE CQRT04(M,N,NB,RESULT)
      IMPLICIT NONE
*
*  -- LAPACK test routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     April 2012
*
*     .. Scalar Arguments ..
      INTEGER M, N, NB, LDT
*     .. Return values ..
      REAL RESULT(6)
*
*  =====================================================================
*
*     ..
*     .. Local allocatable arrays
      COMPLEX, ALLOCATABLE :: AF(:,:), Q(:,:),
     $  R(:,:), WORK( : ), T(:,:),
     $  CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
      REAL, ALLOCATABLE :: RWORK(:)
*
*     .. Parameters ..
      REAL ZERO
      COMPLEX ONE, CZERO
      PARAMETER( ZERO = 0.0, ONE = (1.0,0.0), CZERO=(0.0,0.0) )
*     ..
*     .. Local Scalars ..
      INTEGER INFO, J, K, L, LWORK
      REAL   ANORM, EPS, RESID, CNORM, DNORM
*     ..
*     .. Local Arrays ..
      INTEGER            ISEED( 4 )
*     ..
*     .. External Functions ..
      REAL SLAMCH
      REAL CLANGE, CLANSY
      LOGICAL  LSAME
      EXTERNAL SLAMCH, CLANGE, CLANSY, LSAME
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC  MAX, MIN
*     ..
*     .. Data statements ..
      DATA ISEED / 1988, 1989, 1990, 1991 /
*
      EPS = SLAMCH( 'Epsilon' )
      K = MIN(M,N)
      L = MAX(M,N)
      LWORK = MAX(2,L)*MAX(2,L)*NB
*
*     Dynamically allocate local arrays
*
      ALLOCATE ( A(M,N), AF(M,N), Q(M,M), R(M,L), RWORK(L),
     $           WORK(LWORK), T(NB,N), C(M,N), CF(M,N),
     $           D(N,M), DF(N,M) )
*
*     Put random numbers into A and copy to AF
*
      LDT=NB
      DO J=1,N
         CALL CLARNV( 2, ISEED, M, A( 1, J ) )
      END DO
      CALL CLACPY( 'Full', M, N, A, M, AF, M )
*
*     Factor the matrix A in the array AF.
*
      CALL CGEQRT( M, N, NB, AF, M, T, LDT, WORK, INFO )
*
*     Generate the m-by-m matrix Q
*
      CALL CLASET( 'Full', M, M, CZERO, ONE, Q, M )
      CALL CGEMQRT( 'R', 'N', M, M, K, NB, AF, M, T, LDT, Q, M,
     $              WORK, INFO )
*
*     Copy R
*
      CALL CLASET( 'Full', M, N, CZERO, CZERO, R, M )
      CALL CLACPY( 'Upper', M, N, AF, M, R, M )
*
*     Compute |R - Q'*A| / |A| and store in RESULT(1)
*
      CALL CGEMM( 'C', 'N', M, N, M, -ONE, Q, M, A, M, ONE, R, M )
      ANORM = CLANGE( '1', M, N, A, M, RWORK )
      RESID = CLANGE( '1', M, N, R, M, RWORK )
      IF( ANORM.GT.ZERO ) THEN
         RESULT( 1 ) = RESID / (EPS*MAX(1,M)*ANORM)
      ELSE
         RESULT( 1 ) = ZERO
      END IF
*
*     Compute |I - Q'*Q| and store in RESULT(2)
*
      CALL CLASET( 'Full', M, M, CZERO, ONE, R, M )
      CALL CHERK( 'U', 'C', M, M, REAL(-ONE), Q, M, REAL(ONE), R, M )
      RESID = CLANSY( '1', 'Upper', M, R, M, RWORK )
      RESULT( 2 ) = RESID / (EPS*MAX(1,M))
*
*     Generate random m-by-n matrix C and a copy CF
*
      DO J=1,N
         CALL CLARNV( 2, ISEED, M, C( 1, J ) )
      END DO
      CNORM = CLANGE( '1', M, N, C, M, RWORK)
      CALL CLACPY( 'Full', M, N, C, M, CF, M )
*
*     Apply Q to C as Q*C
*
      CALL CGEMQRT( 'L', 'N', M, N, K, NB, AF, M, T, NB, CF, M,
     $             WORK, INFO)
*
*     Compute |Q*C - Q*C| / |C|
*
      CALL CGEMM( 'N', 'N', M, N, M, -ONE, Q, M, C, M, ONE, CF, M )
      RESID = CLANGE( '1', M, N, CF, M, RWORK )
      IF( CNORM.GT.ZERO ) THEN
         RESULT( 3 ) = RESID / (EPS*MAX(1,M)*CNORM)
      ELSE
         RESULT( 3 ) = ZERO
      END IF
*
*     Copy C into CF again
*
      CALL CLACPY( 'Full', M, N, C, M, CF, M )
*
*     Apply Q to C as QT*C
*
      CALL CGEMQRT( 'L', 'C', M, N, K, NB, AF, M, T, NB, CF, M,
     $             WORK, INFO)
*
*     Compute |QT*C - QT*C| / |C|
*
      CALL CGEMM( 'C', 'N', M, N, M, -ONE, Q, M, C, M, ONE, CF, M )
      RESID = CLANGE( '1', M, N, CF, M, RWORK )
      IF( CNORM.GT.ZERO ) THEN
         RESULT( 4 ) = RESID / (EPS*MAX(1,M)*CNORM)
      ELSE
         RESULT( 4 ) = ZERO
      END IF
*
*     Generate random n-by-m matrix D and a copy DF
*
      DO J=1,M
         CALL CLARNV( 2, ISEED, N, D( 1, J ) )
      END DO
      DNORM = CLANGE( '1', N, M, D, N, RWORK)
      CALL CLACPY( 'Full', N, M, D, N, DF, N )
*
*     Apply Q to D as D*Q
*
      CALL CGEMQRT( 'R', 'N', N, M, K, NB, AF, M, T, NB, DF, N,
     $             WORK, INFO)
*
*     Compute |D*Q - D*Q| / |D|
*
      CALL CGEMM( 'N', 'N', N, M, M, -ONE, D, N, Q, M, ONE, DF, N )
      RESID = CLANGE( '1', N, M, DF, N, RWORK )
      IF( CNORM.GT.ZERO ) THEN
         RESULT( 5 ) = RESID / (EPS*MAX(1,M)*DNORM)
      ELSE
         RESULT( 5 ) = ZERO
      END IF
*
*     Copy D into DF again
*
      CALL CLACPY( 'Full', N, M, D, N, DF, N )
*
*     Apply Q to D as D*QT
*
      CALL CGEMQRT( 'R', 'C', N, M, K, NB, AF, M, T, NB, DF, N,
     $             WORK, INFO)
*
*     Compute |D*QT - D*QT| / |D|
*
      CALL CGEMM( 'N', 'C', N, M, M, -ONE, D, N, Q, M, ONE, DF, N )
      RESID = CLANGE( '1', N, M, DF, N, RWORK )
      IF( CNORM.GT.ZERO ) THEN
         RESULT( 6 ) = RESID / (EPS*MAX(1,M)*DNORM)
      ELSE
         RESULT( 6 ) = ZERO
      END IF
*
*     Deallocate all arrays
*
      DEALLOCATE ( A, AF, Q, R, RWORK, WORK, T, C, D, CF, DF)
*
      RETURN
      END


      subroutine pest_enrsb

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine calculates the enrichment ratio for nutrient and
!!    pesticide transport with runoff

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    surfq(:)    |mm H2O        |surface runoff generated on day in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    enratio     |none          |enrichment ratio
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use hru_module, only : hru, surfq, sedyld, sanyld, silyld, clayld, sagyld, lagyld, ihru, enratio

      implicit none

      integer :: j           !none          |HRU number
      real :: cy             !              |

      j = ihru

      if (sedyld(j) < 1.e-4) then
        sedyld(j) = 0.0
        sanyld(j) = 0.0
        silyld(j) = 0.0
        clayld(j) = 0.0
        sagyld(j) = 0.0
        lagyld(j) = 0.0
      endif

      !! CREAMS method for calculating enrichment ratio
      cy = .1 * sedyld(j) / (hru(j)%area_ha * surfq(j) + 1.e-6)
      if (cy > 1.e-6) then
        enratio = .78 * cy ** (-.2468)
      else
        enratio = 0.
      endif

      if (enratio > 3.0) enratio = 3.0

      return
      end subroutine pest_enrsb


!***********************************************************************
!                                                                      *
      SUBROUTINE MANEIG(IATJPO, IASPAR, NELMNT_a)
!                                                                      *
!   This module  manages the  operation of the  eigensolvers and the   *
!   storage of the eigenpairs.  There are two principal branches:      *
!                                                                      *
!      (1) Matrix of order 1: the trivial case                         *
!      (2) Matrix of order greater than 1: there are two branches      *
!             (i) Matrices of order less than or equal to IOLPCK:      *
!                 eigenpairs are found using LAPACK SUBROUTINEs        *
!            (ii) Matrices of order greater than IOLPCK: eigenpairs    *
!                 are found using DVDSON; this involves up to three    *
!                 steps:                                               *
!                    (a) The matrix is analysed to determine its       *
!                        block structure (only irreducibe matrices     *
!                        are correctly treated by DVDSON)              *
!                    (b) Eigenpairs are extracted for each block       *
!                    (c) The appropriate eigenpairs are selected and   *
!                        stored                                        *
!                 Different methods of storage and different           *
!                 versions of the matrix-vector multiply are used      *
!                 depending upon the order and density of the matrix   *
!
!cjb comments [re-introduced] from GRASP-2013
!   iatjpo - Output. (2j+1) of the dominant coefficients
!   iaspar - Output, Parity (1 or -1) of the dominant coefficients
!   nelmnt - Number of non-zero matrix elements on the current process *
!            stored in the common block                                *
!   nelmnt_a - The maximum number of non-zero matrix elements for all  *
!             nodes                                                    *
!                                                                      *
!     value  meaning  of  method used IV                               *
!       1    LAPACK                  =>  ncf < IOLPCK                  *
!       2    Davidson, Dense-Memory  =>  dense requires less memory    *
!       3    Davidson, Sparse-Memory =>  sparse requires less memory   *
!       4    Davidson, Sparse-Disk   =>  memory requirement too large  *
!                                        for at least one  process     *
!                                                                      *
!   Call(s) to: [LIB92]: ALLOC, DALLOC, ISPAR, ITJPO, posfile,         *
!                        RALLOC.                                       *
!               [RCI92]: DNICMV, SPICMV2, SPODMV.                      *
!               [DVDSON]: DVDSON.                                      *
!               [AUXBLAS]: DINIT/SINIT.                                *
!               [BLAS]: DCOPY/SCOPY, DSWAP/SSWAP.                      *
!               [LAPACK]: DSPEVX/SSPEVX.                               *
!                                                                      *
!   Written by Farid A. Parpia            Last revision: 27 Sep 1993   *
!   Modified Misha Saparov                                  Feb 1997   *
!            Charlotte F. Fischer                           May 1997   *
!                 Except for the disk version, all matrices have       *
!                 diagonals  shifted by EAV                            *
!  All arrays allocated here are de-allocated except pneval and pnevec *
!  which will be de-allocated in matrix.                               *
!  Block Version  By Xinghong He          Last revision: 18 Jun 1998   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:07:38   1/ 5/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY: DOUBLE, LONG
      USE memory_man
      USE eigv_C
      USE fposition_C
      USE hmat_C
      USE orb_C,           ONLY: ncf, nw, iqa
      USE prnt_C
      USE where_C
      USE WCHBLK_C
      USE iounit_C
      USE mpi_C
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE dnicmv_I
      USE spicmv2_I
      USE spodmv_I
      USE posfile_I
      USE dinit_I
      USE dspevx_I
      USE iniestsd_I
      USE gdvd_I
      USE iniest2_I
      USE iniestdm_I
      USE itjpo_I
      USE ispar_I
      USE spicmvmpi_I
      IMPLICIT NONE
!-----------------------------------------------
!  E x t e r n a l   F u n c t i o n s
!-----------------------------------------------
      REAL(DOUBLE) :: DLAMCH
      EXTERNAL     :: DLAMCH
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(OUT) :: IATJPO
      INTEGER, INTENT(OUT) :: IASPAR
      INTEGER(LONG)        :: NELMNT_a
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      INTEGER, PARAMETER      :: IOLPCK = 2000
! GG      REAL(DOUBLE), PARAMETER :: ABSTOL = 1.0D-10
!cjb  NINCOR
!cjb  INTEGER, PARAMETER      :: NINCOR = 1         ! To enforce DISK
      INTEGER, PARAMETER      :: NINCOR = 268435456 ! = 2 GB or  memory
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
!cff   ... variable for deciding between sparse or dense
!     Memory need:
!     sparse : nstore_s = nelmnt + (isize*(nelmnt + ncf+1))/8
!     dense  : nstore_d = (ncf*ncf+1))/(2*nprocs)    (on average)
!     Use Davidson (disk)  if nstore_s > NINCOR
!     Use Davidson (memory, sparse) if nstore_s < nstore_d
!     Use Davidson (memory, dense) if nstore_d < nstore_s
!-----------------------------------------------
      INTEGER(LONG) :: NSTORE_s, NSTORE_d
      INTEGER :: NROWS, I, NDENSE, NCFDUM, ICCUTDUM, MYIDDUM, &
         NPROCSDUM, IOFSET, NELC, IR, NVECMN, NVEX, M, INFO, LOC, NBRKEV,   &
         IMV, NDENSE_L, LIM, LWORK, LIWORK, MAXITR, MBLOCK, NEND, &
         ILOW, IHIGH, NIV, NLOOPS, NMV, J, IA,   &
         idummy
      REAL(DOUBLE) :: ELSTO,  DUMMY, &
          DIATMP, CRITE, CRITC, CRITR, ORTHO, DMUNGO, AMAX, WA, ABSTOL
! GG          DIATMP, CRITE, CRITC, CRITR, ORTHO, DMUNGO, AMAX, WA
      LOGICAL :: HIEND, LDISC, SPARSE
      CHARACTER(LEN=8) :: CNUM
      REAL(DOUBLE), DIMENSION(:), pointer :: w, z, work, diag
      INTEGER, DIMENSION(:), pointer :: iwork, ifail, jwork

!-----------------------------------------------------------------------
! CYC Modifications for step by step diagonalization
      INTEGER IRESTART_GDVD, ISTEP, NSTEP, IITMP, NMV0
      INTEGER TIME0, TIME1, TIME2
! CYC
!-----------------------------------------------------------------------
      ABSTOL = 2*DLAMCH('S')
      IF (MYID == 0) WRITE (6, *) 'Calling maneig...'

!  (nrows+1) is the number of records of the present block's .res file

      NROWS = (NCF - MYID - 1 + NPROCS)/NPROCS
      IF (NCF < NPROCS) NROWS = NCF/(MYID + 1)
      !CALL posfile (1, imcdf, nrows+1)
      CALL POSFILE (0, IMCDF, NPOSITION)

      IF (NCF == 1) THEN
!-----------------------------------------------------------------------
!
! (1) - Trivial    ncf = 1
!
!-------------------------------------------------------
         IF (myid .EQ. 0) WRITE (24, *) 'Trivial eigenvalue problem.'

!   Matrix of order 1: the trivial case; we assume that the value
!   of EAV is available

         CALL ALLOC (EVAL, 1,'EVAL', 'MANEIG' )
         CALL ALLOC (EVEC, 1, 'EVECO', 'MANEIG')
         EVAL(1) = 0.D0
         EVEC(1) = 1.D0

         ! Still read through the .res file
!GG
!GG Gediminas NIST 2005.11.03
!GG         READ (imcdf)
         DO I = 1, NROWS + 1
            READ (IMCDF)
         END DO

      ELSE                                       !if-2
!-----------------------------------------------------------------------
!
! (2) - Non trivial
!
!-------------------------------------------------------
         if(myid==0) write(*,*) "ncf=",ncf, " iolpck=", iolpck
         IF (NCF <= IOLPCK) THEN
!-----------------------------------------------------------------------
!
! (2.1) - LAPACK    Dense, Memory,
!
!-------------------------------------------------------
            IF (MYID == 0) THEN
               WRITE (6, *) &
                  'LAPACK routine DSPEVX selected for eigenvalue problem.'
               WRITE (24, *) &
                  'LAPACK routine DSPEVX selected for eigenvalue problem.'
            ENDIF

!   Allocate storage for the dense representation of the matrix
!   and initialize emt

            NDENSE = (NCF*(NCF + 1))/2
            CALL ALLOC (EMT, NDENSE, 'EMT', 'MANEIG')
            CALL DINIT (NDENSE, 0.0D00, EMT, 1)

!   Read the matrix into position from the disc file; it's already
!   been properly positioned.

            CALL ALLOC (WORK, NCF,'WORK', 'MANEIG' )
            CALL ALLOC (IROW, NCF, 'IROW', 'MANEIG')
            READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM
            IF (NCF/=NCFDUM .OR. MYID/=MYIDDUM .OR. NPROCSDUM/=NPROCS) STOP &
               'maneig:1'

            DO I = MYID + 1, NCF, NPROCS
               IOFSET = (I*(I - 1))/2
               READ (IMCDF) NELC, ELSTO, (WORK(IR),IR=1,NELC), (IROW(IR),IR=1,&
                  NELC)
               ! In the row-mode of the lower triangle,
               ! diagonal is the last one
               DO IR = 1, NELC - 1
                  EMT(IOFSET+IROW(IR)) = WORK(IR)
               END DO
               EMT(IOFSET+IROW(NELC)) = WORK(NELC) - EAV

            END DO

            CALL DALLOC (WORK, 'WORK', 'MANEIG')
            CALL DALLOC (IROW, 'IROW', 'MANEIG')

! Let each node have a complete copy of EMT

            CALL gdsummpi (EMT, NDENSE)

!   Find the eigenpairs
!
!    ivec() - serial numbers of eigenstates of the current block
!    iccmin() - serial numbers of eigenstates of all blocks.
!    nvecmn - minimum serial number of the eigenstates of the block
!    nvecmx - maximum .............
!    nvex - clear from def: NVECMX-NVECMN+1

            NVECMN = NCF
            DO I = 1, NVEC
               NVECMN = MIN(NVECMN,IVEC(I))
            END DO
            NVEX = NVECMX - NVECMN + 1
            CALL ALLOC (W, NVEX, 'W', 'MANEIG')
            CALL ALLOC (Z, NCF*NVEX,'Z', 'MANEIG' )
            CALL ALLOC (WORK, NCF*8,'WORK', 'MANEIG' )
            CALL ALLOC (IWORK, NCF*5,'IWORK', 'MANEIG' )
! GG            CALL ALLOC (IFAIL, NVEX, 'IFAIL', 'MANEIG')
            CALL ALLOC (IFAIL, NCF, 'IFAIL', 'MANEIG')
            CALL DSPEVX ('V', 'I', 'U', NCF, EMT, DUMMY, DUMMY, NVECMN, NVECMX&
               , ABSTOL, M, W, Z, NCF, WORK, IWORK, IFAIL, INFO)
            IF (INFO /= 0)                                             &
                CALL STOPMPI('maneig: Failure in DSPEVX [LAPACK]',myid)
            CALL DALLOC (WORK, 'WORK', 'MANEIG')
            CALL DALLOC (IWORK, 'IWORK', 'MANEIG')
            CALL DALLOC (IFAIL, 'IFAIL', 'MANEIG')
            CALL DALLOC (EMT, 'EMT', 'MANEIG')

!   Store the eigenpairs in their proper positions EVAL() and EVEC()

            CALL ALLOC (EVAL, NVEC,'EVAL', 'MANEIG')
            CALL ALLOC (EVEC, NCF*NVEC, 'EVEC', 'MANEIG')

            DO I = 1, NVEC
               LOC = IVEC(I)
               EVAL(I) = W(LOC - NVECMN + 1)
               IOFSET = NCF*(I - 1)
               LOC = NCF*(LOC - NVECMN)
               CALL DCOPY (NCF, Z(LOC + 1), 1, EVEC(IOFSET+1), 1)
            END DO
            CALL DALLOC (W, 'W', 'MANEIG')
            CALL DALLOC (Z, 'Z', 'MANEIG')

         ELSE
!-----------------------------------------------------------------------

! (2.2) - DVDSON --- preparation work
!
!-------------------------------------------------------
            IF (myid == 0) WRITE (24,*)'DVDSON routine selected' &
                                      //' for eigenvalue problem;'
!--------------------------------------------------------------
            IF (myid == 0) print *,'zou: nelmnt',NELMNT
!            print *, 'myid, nprocs,nincor', myid, nprocs, nincor

!           If on any process more memory is needed than NINCOR, use disc.
!           If not, should the matrix be sparse or dense (distributed)?
!           sparse requires = nelmnt + (isize*(nelmnt+ncf+1))/8
!           dense  storage = (ncf*(ncf+1)/2/nproc - on average
!           (because of integer arithmetic nproc-1 is added to numerator

!           This is a comparion of matrix elements only.
!
            NSTORE_s = NELMNT_a
            NSTORE_d = ((ncf+nprocs-1)/nprocs)
            NSTORE_d = NSTORE_d*((ncf+1)/2)
            IF (myid .EQ. 0) write(*,*) "nstore_s=", nstore_s,   &
                             "nstore_d=", nstore_d, 'nincor=', nincor
            LDISC = .FALSE.
            IF ( NSTORE_s > NINCOR) THEN
!              .. we need to use disk
               LDISC =.TRUE.
               SPARSE=.TRUE.
            ELSE

               IF (NSTORE_s .LT. NSTORE_d ) THEN
                  SPARSE = .TRUE.
               ELSE
                  SPARSE = .FALSE.
               ENDIF
            ENDIF

            CALL ALLOC (DIAG,NCF,'DIAG', 'MANEIG')
            CALL dinit (ncf, 0.d0, diag, 1)
            IF (LDISC) THEN
!-----------------------------------------------------------------------
!
! (2.2.1) - DVDSON --- Disk, load diagonal
!
!-------------------------------------------------------
               IF (myid == 0)  THEN
                  WRITE (*, *) ' matrix stored on disc;'
                  WRITE (24, *) ' matrix stored on disc;'
               END IF

!   Disk storage; necessarily sparse; one column of the matrix in
!   memory

               IMV = 1

!   Load diagonal - Each node will have the same, complete copy
!   after this if block
               print *, myid, 'Reading diagonal, unit imcdf =', imcdf
               READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM
               IF (NCF/=NCFDUM .OR. MYID/=MYIDDUM .OR. NPROCSDUM/=NPROCS) STOP &
                  'maneig:2'

               DO I = MYID + 1, NCF, NPROCS
                  READ (IMCDF) NELC, ELSTO, (dummy,IR=2,NELC), DIATMP, &
                                            (idummy, ir=1,nelc)
                  DIAG(I) = DIATMP - EAV
               END DO
               print *, ' finished'
            ELSE
!-----------------------------------------------------------------------
!
! (2.2.2) - DVDSON --- Memory, load all
!
!-------------------------------------------------------
!
!   Core storage; load matrix into memory
!
               LDISC = .FALSE.
               IF (SPARSE) THEN
!-----------------------------------------------------------------------

! (2.2.2.1) - DVDSON --- Memory, load all, sparse
!
!-------------------------------------------------------
                  IF (MYID == 0) THEN
                     WRITE (24, *) ' sparse matrix stored in memory'
                     WRITE ( *, *) ' sparse matrix stored in memory'
                  END IF

                  IMV = 2
                  WRITE (6, *) 'nelmnt = ', NELMNT
                  CALL ALLOC (EMT, NELMNT, 'EMT', 'MANEIG')
                  CALL ALLOC (IROW, NELMNT, 'IROW', 'MANEIG')
                  CALL ALLOC (IENDC, 0, NCF , 'IENDC', 'MANEIG')
                  IOFSET = 0
                  IENDC(0) = 0

                  READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM
                  IF (NCF/=NCFDUM .OR. MYID/=MYIDDUM .OR. NPROCSDUM/=NPROCS) &
                     STOP 'maneig:3'
                  DO I = MYID + 1, NCF, NPROCS
                     READ (IMCDF) NELC, ELSTO, (EMT(IR+IOFSET),IR=1,NELC), (&
                        IROW(IR + IOFSET),IR=1,NELC)
                     EMT(NELC+IOFSET) = EMT(NELC+IOFSET) - EAV
                     DIAG(I) = EMT(NELC+IOFSET)
                     IOFSET = IOFSET + NELC
                     IENDC(I) = IOFSET
                  END DO
               ELSE
!-----------------------------------------------------------------------
!
! (2.2.2.2) - DVDSON --- Memory, load all, dense
!
!-------------------------------------------------------
                  IF (myid .EQ. 0) THEN
                     WRITE (24,*) ' full matrix stored in in memory'
                     WRITE ( *,*) ' full matrix stored in in memory'
                  END IF

                  IMV = 3

! Find NDENSE_L, the number of elements on the node (dense form)

                  NDENSE_L = 0
                  DO I = MYID + 1, NCF, NPROCS
                     NDENSE_L = NDENSE_L + I
                  END DO

                  CALL ALLOC (EMT, NDENSE_L, 'EMT', 'MANEIG')
                  CALL DINIT (NDENSE_L, 0.0D00, EMT, 1)
                  CALL ALLOC (WORK, NCF, 'WORK', 'MANEIG')
                  CALL ALLOC (IROW, NCF, 'IROW', 'MANEIG')

                  READ (IMCDF) NCFDUM, ICCUTDUM, MYIDDUM, NPROCSDUM
                  IF (NCF/=NCFDUM .OR. MYID/=MYIDDUM .OR. NPROCSDUM/=NPROCS) &
                     STOP 'maneig:4'

                  IOFSET = 0
                  DO I = MYID + 1, NCF, NPROCS
                     READ (IMCDF) NELC, ELSTO, (WORK(IR),IR=1,NELC), (IROW(IR),&
                        IR=1,NELC)
                     WORK(NELC) = WORK(NELC) - EAV
                     DIAG(I) = WORK(NELC)
                     DO IR = 1, NELC
                        EMT(IOFSET+IROW(IR)) = WORK(IR)
                     END DO
                     IOFSET = IOFSET + I
                  END DO
                  CALL DALLOC (WORK, 'WORK', 'MANEIG')
                  CALL DALLOC (IROW, 'IROW', 'MANEIG')

               ENDIF
!               ...Memory mode - sparse or dense
!-----------------------------------------------------------------------
!  (2.2.2.3e)          *** E n d   o f   D V D S O N   m e m o r y
!-----------------------------------------------------------------------
            ENDIF
!            ...Disk or Memory
!-----------------------------------------------------------------------
!  (2.2.3e)      *** E n d   o f   D V D S O N
!-----------------------------------------------------------------------

! Make diagonals global, no matter it is disk or memory mode

            CALL gdsummpi (DIAG, NCF)
!
!   Allocate storage for workspace; see the header of DVDSON for
!   the expression below; the value of LIM can be reduced to NVECMX
!   plus a smaller number if storage is severely constrained
!
            LIM = MIN(NCF,2*NVECMX + 60)
!           lwork = 2*ncf*lim + lim*lim + (nvecmx+10)*lim + nvecmx
            LWORK = 2*NCF*LIM + LIM*LIM*2 + 11*LIM + NVECMX
            CALL ALLOC (WORK, LWORK, 'WORK', 'MANEIG')
            work(1:lwork) = 0.0d0
            LIWORK = 6*LIM + NVECMX
            CALL ALLOC (IWORK, LIWORK, 'IWORK', 'MANEIG')
!*changed by Misha 02/12/97
            CRITE = 1.0D-17
!GG            CRITC = 1.0D-08
!GG            CRITR = 1.0D-08
!GG            ORTHO = MAX(1D-8,CRITR)
            CRITC = 1.0D-09
            CRITR = 1.0D-09
            ORTHO = MAX(1D-9,CRITR)
! end of changes

!            maxitr = MAX (nvecmx*100, ncf/10)
            MAXITR = MAX(NVECMX*100,NCF/10)
            !maxitr = MIN (nvect*100, ncf)  ! FROM RSCFVU !!!
            CALL ALLOC (JWORK, LIM,'JWORK', 'MANEIG' )

            CALL ALLOC (EVAL, NVECMX, 'EVAL', 'MANEIG')
            CALL ALLOC (EVEC, NCF*NVECMX, 'EVEC', 'MANEIG')

            DMUNGO = 10.D99
            CALL DINIT (NVECMX, DMUNGO, EVAL, 1)

!   Compute the eigenpairs in each block

            NVEX = NVECMX
            IF (LDISC) THEN
               MBLOCK = NVEX
            ELSE
               MBLOCK = 1
            ENDIF
            NEND = NCF*NVEX

            ILOW = 1
            IHIGH = NVEX
            NIV = NVEX
!************************************************************************
!
!   Call Davidson eigensolver
!
            SELECT CASE (IMV)
            CASE (1)
!******************** sparse and matrix on disk **********************
              IF (myid .EQ. 0) print *, ' Sparse - Disk, iniestsd'
               CALL POSFILE (0, IMCDF, NPOSITION)! was within iniestsd before
               CALL INIESTSD (IOLPCK, NCF, MYID, NPROCS, NIV, WORK, IMCDF, EAV)
              print *, 'Returned from iniestsd '
              if (ncf.gt. IOLPCK) then
                print *, 'Calling GDVD'
                CALL GDVD (SPODMV,IRESTART_GDVD,NCF,LIM,DIAG,ILOW,IHIGH,            &
                  JWORK,NIV,MBLOCK,CRITE,CRITC, CRITR,ORTHO,MAXITR,   &
                  WORK,LWORK,IWORK,LIWORK,HIEND,NLOOPS,               &
                  NMV,IERR)
              end if

            CASE (2)
!******************** sparse and matrix in memory ********************
               IF (myid .EQ. 0) print *, ' Sparse - Memory, iniestmpi'
               CALL iniestmpi (IOLPCK, NCF,NIV,WORK,EMT,IENDC,IROW)
               if(ncf.gt. IOLPCK) then
!-----------------------------------------------------------------------
! CYC: Try to diagonalize step by step
                IRESTART_GDVD = 0
                TIME0 = MPI_WTIME()
! More tests should be performed for istep, it could be set as 1
                ISTEP = 5
                NMV = 0
                IF (NCF.GT.2.0E5 .AND. NVEX.GT.ISTEP) THEN
                 NSTEP = NVEX / ISTEP
                 IF (MOD(NVEX,ISTEP).LE.ISTEP/2) NSTEP = NSTEP - 1
                 DO IITMP = 1, NSTEP
! NIV could be changed to nvecmx+1 in dvdson:initdvd procedure
                  NIV = NVEX
                  ILOW = 1
                  IHIGH = IITMP * ISTEP
                  IF (IITMP .EQ. 1 ) THEN
                    IRESTART_GDVD = 0
                  ELSE
                    IRESTART_GDVD = 1
                  ENDIF
                  NMV0 = NMV
                  TIME1 = MPI_WTIME()

                  CALL GDVD (SPICMVmpi,IRESTART_GDVD,NCF,LIM,DIAG,ILOW,IHIGH, &
                  JWORK,NIV,MBLOCK,CRITE,CRITC, CRITR,ORTHO,MAXITR,   &
                  WORK,LWORK,IWORK,LIWORK,HIEND,NLOOPS,               &
                  NMV,IERR)

                  TIME2 = MPI_WTIME()
                  IF (MYID .EQ. 0) THEN
                    WRITE (*, *)' IITMP= ', IITMP,  &
                                ' Time (s)=', TIME2 - TIME1
                    WRITE (*,*) ' ', NMV - NMV0, &
                      'Matrix-vector multiplies for this loop.'
                    WRITE (*,*) ' ', NMV,  &
                      ' Total matrix-vector multiplies by now.'
                  ENDIF
                 ENDDO
                ENDIF

! Search the remaining (NVEX - ISTEP * NSTEP) EIGENPAIRS
                NIV = NVEX
                ILOW = 1
                IHIGH = NVEX
                NMV0 = NMV
                TIME1 = MPI_WTIME()

                CALL GDVD(SPICMVmpi,IRESTART_GDVD,NCF,LIM,DIAG,ILOW,IHIGH, &
                JWORK,NIV,MBLOCK,CRITE,CRITC, CRITR,ORTHO,MAXITR,   &
                WORK,LWORK,IWORK,LIWORK,HIEND,NLOOPS,               &
                NMV,IERR)

                TIME2 = MPI_WTIME()
                IF (MYID .EQ. 0) THEN
                  WRITE (*, *)' IITMP= ', IITMP,  &
                              ' Time (s)=', TIME2 - TIME1
                  WRITE (*,*) ' ', NMV - NMV0, &
                    'Matrix-vector multiplies for this loop.'
                  WRITE (*,*) ' ', NMV,  &
                    ' Total matrix-vector multiplies by now.'
                  WRITE (*, *)' Total time (m)=', (TIME2 - TIME0) / 60.0
                ENDIF
! CYC
!-----------------------------------------------------------------------
               end if

               CALL DALLOC (EMT, 'EMT', 'MANEIG')
               CALL DALLOC (IROW, 'IROW', 'MANEIG')
               CALL DALLOC (IENDC, 'IENDC', 'MANEIG')

            CASE (3)
!*************************** dense and in memory **********************
               IF (myid .EQ. 0) print *, ' Dense - Memory, iniestdm'
              CALL INIESTDM (IOLPCK,NCF,NIV,WORK,EMT)
              if (ncf.gt. IOLPCK) then
                CALL GDVD (DNICMV,IRESTART_GDVD,NCF,LIM,DIAG,ILOW,IHIGH,            &
                    JWORK,NIV,MBLOCK,CRITE,CRITC, CRITR,ORTHO,MAXITR, &
                    WORK,LWORK,IWORK,LIWORK,HIEND,NLOOPS,             &
                    NMV,IERR)
              end if
               CALL DALLOC (EMT, 'EMT', 'MANEIG')
            END SELECT
!************************************************************************
            CALL DALLOC (DIAG, 'DIAG', 'MANEIG')
            CALL DALLOC (IWORK, 'IWORK', 'MANEIG')
            CALL DALLOC (JWORK, 'JWORK', 'MANEIG')
            IF (myid .EQ. 0) THEN
               WRITE (24, *) ' ', NLOOPS, ' iterations;'
               WRITE (24, *) ' ', NMV, ' matrix-vector multiplies.'
            ENDIF
            IF (IERR /= 0) THEN
               WRITE (ISTDE, *) 'MANEIG: Returned from DVDSON with'
               WRITE (ISTDE, *) ' IERR = ', IERR, '.'
               STOP 'maneig: DVDSON wrong'
            ENDIF

!   Put the eigenpairs in order, overwriting as necessary

            CALL DCOPY (NVEX, WORK(NEND+1), 1, EVAL, 1)
            CALL DCOPY (NCF*NVEX, WORK(1), 1, EVEC, 1)
            CALL DALLOC (WORK, 'WORK', 'MANEIG')

!   Rearrange and reallocate storage for the eigenpairs
!   as necessary

            IF (NVEC < NVECMX) THEN
               CALL ALLOC (IWORK, NVECMX, 'IWORK', 'MANEIG')
               DO I = 1, NVECMX
                  IWORK(I) = I
               END DO
               DO I = 1, NVEC
                  IOFSET = IVEC(I)
                  LOC = IWORK(I)
                  IF (IOFSET == LOC) CYCLE
                  CALL DSWAP (1, EVAL(IOFSET), 1, EVAL(I), 1)
                  IWORK(I) = IWORK(IOFSET)
                  IWORK(IOFSET) = LOC
                  IOFSET = NCF*(IOFSET - 1)
                  LOC = NCF*(I - 1)
                  CALL DSWAP (NCF, EVEC(IOFSET+1), 1, EVEC(LOC+1), 1)
               END DO
               CALL DALLOC (IWORK, 'IWORK', 'MANEIG')
               CALL RALLOC (EVAL,  NVEC, 'EVAL', 'MANEIG')
               CALL RALLOC (EVEC, NCF*NVEC, 'EVEC', 'MANEIG' )

            ENDIF

         ENDIF
! (2.3e)              *** E N D   O F    N O N - T R I V I A L   C A S E

      ENDIF
! (3e)               *** E N D   O F    A L L

!--------------------------------------------------------------------
! Only the following quantities are needed after this routine is
! finished:
!   eval(), evec(), iatjpo, iaspar
!--------------------------------------------------------------------
!
!   Clean up eigenvectors; determine their J/P values
!
      DO J = 1, NVEC

!         Find the dominant component of each eigenvector

         IOFSET = (J - 1)*NCF

         AMAX = 0.D0
         DO I = 1, NCF
            WA = ABS(EVEC(I+IOFSET))
            IF (WA <= AMAX) CYCLE
            AMAX = WA
            IA = I
         END DO

!          Find the angular momentum and parity of the dominant component

         IATJPO = ITJPO(IA)
         IASPAR = ISPAR(IA)

!          Change sign of eigenvactor if dominant component is negative

         IF (EVEC(IA+IOFSET) >= 0.D0) CYCLE
         EVEC(1+IOFSET:NCF+IOFSET) = -EVEC(1+IOFSET:NCF+IOFSET)
      END DO

      RETURN
      END SUBROUTINE MANEIG


      SUBROUTINE INPHYS (HSG,PPL,RLAT)
C--
C--   SUBROUTINE INPHYS (HSG,PPL,RLAT)
C--
C--   Purpose: Initialize common blocks for physical parametrization routines
C--   Input :  HSG  : sigma at half levels
C--            PPL  : pressure levels for post-processing
C--            RLAT : gaussian-grid latitudes
C--   Initialized common blocks: PHYCON, FSIGLT, FORCON,
C--                              CNVCON, LSCCON, RADCON, SFLCON, VDICON
C--
C     Resolution parameters
C
      include "atparam.h"
      include "atparam1.h"
C
      PARAMETER ( NLON=IX, NLAT=IL, NLEV=KX, NGP=NLON*NLAT )
C
C     Physical constants + functions of sigma and latitude
C
      include "com_physcon.h"

C     Surface properties

      include "com_surfcon.h"
C
C     Constants for sub-grid-scale physics
C
      include "com_cnvcon.h"
      include "com_lsccon.h"
      include "com_radcon.h"
      include "com_sflcon.h"
      include "com_vdicon.h"
C
      REAL HSG(0:NLEV), PPL(NLEV), RLAT(NLAT)
C
C---  1. Time independent parameters and arrays
C
C     1.1 Physical constants
C
      P0 = 1.e+5
      GG = 9.81
      RD = 287.
      CP = 1004.
C     Latent heat is in J/g for consistency with spec.hum. in g/Kg
      ALHC = 2501.0
cfk#if defined(KNMI)
cfk      ALHS = 2801.0
cfk#endif
      SBC = 5.67e-8
C
C     1.2 Functions of sigma and latitude
C
      SIGH(0)=HSG(0)
C
      DO K=1,NLEV
       SIG(K)  = 0.5*(HSG(K)+HSG(K-1))
       SIGL(K) = LOG(SIG(K))
       SIGH(K) = HSG(K)
       DSIG(K) = HSG(K)-HSG(K-1)
       POUT(K) = PPL(K)
       GRDSIG(K) = GG/(DSIG(K)*P0)
       GRDSCP(K) = GRDSIG(K)/CP
      ENDDO
C
C     Weights for vertical interpolation at half-levels(1,nlev) and surface
C     Note that for phys.par. half-lev(k) is between full-lev k and k+1
C     Fhalf(k) = Ffull(k)+WVI(K,2)*(Ffull(k+1)-Ffull(k))
C     Fsurf = Ffull(nlev)+WVI(nlev,2)*(Ffull(nlev)-Ffull(nlev-1))
C
      DO K=1,NLEV-1
       WVI(K,1)=1./(SIGL(K+1)-SIGL(K))
       WVI(K,2)=(LOG(SIGH(K))-SIGL(K))*WVI(K,1)
      ENDDO
C
      WVI(NLEV,1)=0.
      WVI(NLEV,2)=(LOG(0.99)-SIGL(NLEV))*WVI(NLEV-1,1)
C
      DO J=1,NLAT
       SLAT(J)=SIN(RLAT(J))
       CLAT(J)=COS(RLAT(J))
      ENDDO

C--   2. Constants for physical parametrization routines:

      include "cls_inphys.h"

C---
      RETURN
      END


c
c	This subroutine is responsible for deteriming the total electron
c	density as a function of position within the ionosphere and
c	plasmasphere at the magnetic equator.
c
c     modified by dlg 1/6/2009 to send itime to ne_inner_ps routine
c
	function ne_iri_ps_trough_eq(al,amlt,akp,itime)
c
	real pi,amltrad,fact,amlt_o,akp_o
	parameter (pi=3.1415927,amltrad=pi/12.0)
	parameter (fact=0.013/pi)
	real al,amlt,akp,ne_iri_ps_trough_eq,ne_inner_ps
	real outf(20,100),oarr(50),a8,ne_eq_trough,re
	real aheight,pp_factor,pp_profile,ps_inner,am1
	real b1,transh,alpha,ano,x1,x2,y1,y2,am2,b2
	real xintercept,rintercept,ps_bridge,scale,off
	real swtch1,swtch2,switchon,swtch3,alatr,along
	real swtch4,swtch5,ne_eq_trough_den,zl,x234
	integer*4 itime(2),itime1_o,itime2_o
	data re/6371.0/
	data amlt_o/-99.0/akp_o/-99.0/
	data itime1_o/-99/,itime2_o/-99/

c	  print*,'entering ne_iri_ps_trough_eq:',al,amlt,akp,itime
c
c  We don't do inside the earth; we're just not that kind of model, humph!
	if(al.le.1.0) then
	  ne_iri_ps_trough_eq=0.0
c 	  print*,'leaving ne_iri_ps_trough_eq early',ne_iri_ps_trough_eq
	  return
	end if
c
c
c  altitude of point of interest
	aheight=(al-1.0)*re
	pp_factor=pp_profile(al,amlt,akp,a8)
c	  print*,'from pp_profile:',pp_factor,al,amlt,akp,a8

	ps_inner=ne_inner_ps(al,amlt,itime,am1,b1,x234)*1.0e6
c	  print*,'from ne_inner_ps:',ps_inner,al,amlt,am1,b1,x234

	if(amlt.ne.amlt_o .or. akp.ne.akp_o .or.
     &	itime(1).ne.itime1_o .or. itime(2).ne.itime2_o) then
c
c  determine the height power law fit parameters that connect the
c  topside ionosphere to the plasmasphere
	  call iri_ps_eq_bridge(al,amlt,itime,transh,
     &              alpha,ano,am1,b1,x234,rintercept)
c	  print*,'from iri_ps_eq_bridge:',
c    &       r,amlt,itime,transh,alpha,ano,rintercept

	  amlt_o=amlt
	  akp_o=akp
	  itime1_o=itime(1)
	  itime2_o=itime(2)
	end if
c	  print*,'values 1:',a8,am1,b1

	  ps_bridge=ano*aheight**(-alpha)
c 	  print*,'bridge-ps n:',ps_inner,ps_bridge
        off=0.0
        transwidth=0.02
	  swtch2=switchon(al,rintercept+off,transwidth)
	  swtch3=switchon(al,rintercept-off,transwidth)

	    alatr=0.0
	    along=(amlt-12.0)*amltrad
c	    along=along - (1.0-sign(1.0,(12.0-amlt)))*pi
	    call iri_sm(alatr,along,al,itime,outf,oarr)
	    swtch1=switchon(aheight,transh,5.0)
c	  print*,'entering ne_eq_trough:',swtch1,aheight,transh
          ne_eq_trough_den=ne_eq_trough(al,amlt,akp)
c	  print*,'entering check_crossing:',ne_eq_trough_den
          zl=check_crossing(a8,am1,b1,x234,amlt,akp)
          diff=a8-zl
          offset=(0.0166513
     &            - 0.0450188*diff)*(1.0-switchon(diff,0.3698744,0.05))
c          offset=amax1(0.0,0.02*((zl-a8-0.2)/0.15))
c    	  print*,'offset:',akp,a8,zl,(a8-zl),offset
	    swtch4=switchon(al,zl+offset,0.3)
	    swtch5=switchon(al,zl-offset,0.3)
	    ne_iri_ps_trough_eq=outf(1,1)*(1.0-swtch1) +
     &  ((ps_bridge*(1.0-swtch2)*swtch1 +
     &	ps_inner*swtch3)*pp_factor)*(1.0-swtch4) +
     &	ne_eq_trough_den*1.0e6*swtch5
c	  print*,'** ',swtch1,swtch2,swtch3,swtch4,swtch5
c	  print*,al,rintercept,off,aheight,transh,pp_factor
c	  print*,outf(1,1),ps_bridge,ps_inner,ne_eq_trough_den
c	  print*,ne_iri_ps_trough_eq
c

	return
	end


module evolve_mod

  use real_type_mod
  use parameters_mod
  use variables_mod
  use conversion_mod
  use master_function_mod

  implicit none

contains

  subroutine evolve(n_up, n_down, mu_up, mu_down, n_sqd)

    real(kind=wp), dimension(NF, NV, 1-gz:np+gz), intent(inout) :: &
         n_up, n_down, mu_up, mu_down
    real(kind=wp), dimension(NFF, 1-gz:np+gz), intent(inout) :: n_sqd

    real(kind=wp), dimension(:, :, :), allocatable :: q_new
    real(kind=wp), dimension(:, :), allocatable :: rhs, auxl, q

    integer :: i, j, nt, istat

    allocate(q_new(rk_order+1, NEVOLVE, 1-gz:np+gz), &
             q(NEVOLVE, 1-gz:np+gz), &
             auxl(NF, 1-gz:np+gz), &
             rhs (NEVOLVE, 1-gz:np+gz), &
             STAT=istat)
    if (istat .ne. 0) then
      write(*,*) 'Allocation error in evolve'
      stop
    end if

    q_new = 0.0_wp
    rhs = 0.0_wp

    do i = 1, NF
      q_new(1, i, :) = n_up(i, 1, :)
      do j = 1, ND
        q_new(1, j*NF + i, :) = mu_down(i, 1+j, :)
      end do
    end do
    q = q_new(1, :, :)

    do nt = 1, rk_order

!!$    Auxilliary variables are the timelike components of mu, for the moment
      auxl = mu_down(:, 1, :)

      call compute_rhs(q, n_up, mu_down, rhs)

      call RK_step(q, q_new, rhs, nt, rk_order)

      q = q_new(nt+1, :, :)

      call boundaries(q, NEVOLVE)
      do i = 1-gz, np+gz

        call all_from_evolved_pt(q(:, i), &
             n_up(:, :, i), n_down(:, :, i), &
             mu_up(:, :, i), mu_down(:, :, i), &
             n_sqd(:, i))
      end do
    end do

    deallocate(q_new, q, auxl, rhs)

  end subroutine evolve

  subroutine compute_rhs(q, n_up, mu_down, rhs)

    real(kind=wp), dimension(NEVOLVE, 1-gz:np+gz), intent(in) :: q
    real(kind=wp), dimension(NF, NV, 1-gz:np+gz), intent(in) :: n_up, mu_down
    real(kind=wp), dimension(NEVOLVE, 1-gz:np+gz), intent(out) :: rhs

    real(kind=wp), dimension(:, :), allocatable :: deriv_n, deriv_mu, &
         source, deriv_dissip_q

    integer :: i, istat, f

    rhs = 0.0_wp

    allocate(deriv_n (NF, 1-gz:np+gz), &
             deriv_mu(NF, 1-gz:np+gz), &
             source(NEVOLVE, 1-gz:np+gz), &
             deriv_dissip_q(NEVOLVE, 1-gz:np+gz), &
             STAT=istat)
    if (istat .ne. 0) then
      write(*,*) 'Allocation error in compute_rhs'
      stop
    end if

    deriv_n  = 0.0_wp
    deriv_mu = 0.0_wp
    select case (differencing_order)

      case (2)

        do i = 1, np
          do f = 1, NF
!!$        Second order central differencing
            deriv_n (f, i) = I2DX * (n_up   (f, 2, i+1) - n_up   (f, 2, i-1))
            deriv_mu(f, i) = I2DX * (mu_down(f, 1, i+1) - mu_down(f, 1, i-1))
          end do
        end do

      case (4)

        do i = 1, np
          do f = 1, NF
!!$        Fourth order central differencing
            deriv_n (f, i) = I12DX * &
                 (-n_up(f, 2, i+2) + n_up   (f, 2, i-2) + &
         8.0_wp * (n_up(f, 2, i+1) - n_up   (f, 2, i-1)) )
            deriv_mu(f, i) = I12DX * &
                 (-mu_down(f, 1, i+2) + mu_down(f, 1, i-2) + &
         8.0_wp * (mu_down(f, 1, i+1) - mu_down(f, 1, i-1)) )
          end do
        end do

      case default

        write(*,*) 'Unknown value of ''differencing order''', &
             differencing_order
        stop

    end select

    deriv_dissip_q = 0.0_wp
    select case (dissipation_order)

      case (0)

        deriv_dissip_q = 0.0_wp

      case (3)

        do i = 1, np
!!$      Third order dissipation
          deriv_dissip_q (:, i) = I16DX * &
               (          q(:, i+2) + q(:, i-2)  - &
                4.0_wp * (q(:, i+1) + q(:, i-1)) + &
                6.0_wp *  q(:, i)                  )
        end do

      case (5)

        do i = 1, np
!!$      Fifth order dissipation
          deriv_dissip_q (:, i) = I64DX * &
               (          q(:, i+3) + q(:, i-3)  - &
                6.0_wp * (q(:, i+2) + q(:, i-2)) + &
               15.0_wp * (q(:, i+1) + q(:, i-1)) - &
               20.0_wp *  q(:, i)                  )
        end do

      case default

        write(*,*) 'Unknown value of ''dissipation order''', &
             dissipation_order
        stop

    end select

    source = 0.0_wp
!!$      Source terms due to inter-fluid or external forces
    do i = 1, np
      call force_terms(q(:, i), n_up(:, :, i), mu_down(:, :, i), source(:, i))
    end do

!!$    Note that we should add a source term here for the external forces
!!$    Need to consider the mu term correctly - divide by n
    do i = 1, np
      do f = 1, NF
        rhs(f     , i) = -deriv_n (f, i) + source(     f, i)
        rhs(NF + f, i) =  deriv_mu(f, i) + source(NF + f, i)
      end do
      rhs(:, i) = rhs(:, i) + eps_dissipation * deriv_dissip_q(:, i)
    end do

    deallocate(deriv_n, deriv_mu, source, deriv_dissip_q)

  end subroutine compute_rhs

  subroutine rk_step(q, q_new, rhs, n, order)

    integer, intent(in) :: n, order
    real(kind=wp), dimension(NEVOLVE, 1-gz:np+gz), intent(in) :: q, rhs
    real(kind=wp), dimension(order + 1, NEVOLVE, 1-gz:np+gz), intent(out) :: &
         q_new

    integer :: i

    select case (order)

      case (1)

        if (n .ne. 1) then
          write(*,*) 'In RK_step, order 1, n not 1!? ', n
          stop
        end if

        q_new(2, :, :) = q_new(1, :, :) + dt * rhs

      case (2)

        select case (n)

          case (1)

            q_new(2, :, :) = q_new(1, :, :) + dt * rhs

          case (2)

            q_new(3, :, :) = 0.5_wp * &
                 (q_new(1, :, :) + q_new(2, :, :) + dt * rhs)

          case default

            write(*,*) 'In RK_step, order 2, n not 1, 2!? ', n
            stop

        end select

      case (3)

        select case (n)

          case (1)

            q_new(2, :, :) = q_new(1, :, :) + dt * rhs

          case (2)

            q_new(3, :, :) = 0.25_wp * &
                 (3.0_wp * q_new(1, :, :) + q_new(2, :, :) + dt * rhs)

          case (3)

            q_new(4, :, :) = 1.0_wp / 3.0_wp * &
                 (q_new(1, :, :) + 2.0_wp * q_new(3, :, :) + &
                 2.0_wp * dt * rhs)

          case default

            write(*,*) 'In RK_step, order 3, n not 1-3!? ', n
            stop

        end select

      case (4)

        select case (n)

          case (1)

            q_new(2, :, :) = q_new(1, :, :) + 0.5_wp * dt * rhs

          case (2)

            q_new(3, :, :) = q_new(1, :, :) + 0.5_wp * dt * rhs

          case (3)

            q_new(4, :, :) = q_new(1, :, :) + dt * rhs

          case (4)

            q_new(5, :, :) = 1.0_wp / 6.0_wp * &
                 ( -2.0_wp * q_new(1, :, :) + &
                    2.0_wp * q_new(2, :, :) + &
                    4.0_wp * q_new(3, :, :) + &
                    2.0_wp * q_new(4, :, :) + &
                    dt * rhs )

          case default

            write(*,*) 'In RK_step, order 4, n not 1-4!? ', n
            stop

        end select

      case default

        write(*,*) 'Expected the RK order to be in 1-4; found ', order
        stop

    end select

  end subroutine rk_step

  subroutine boundaries(q, nv)

    integer, intent(in) :: nv
    real(kind=wp), dimension(nv, 1-gz:np+gz), intent(inout) :: q

    integer :: i

!!$    Periodic

    do i = 1, gz
      q(:, 1-i ) = q(:, np-i+1)
      q(:, np+i) = q(:, i)
    end do

  end subroutine boundaries

end module evolve_mod


c
c------------------------------------------------------------
c
       subroutine reg_slopes2(qp,qx,qy,qxx,qxy,qyy,mitot,mjtot,irr,
     &                   lstgrd,lwidth,hx,hy,xlow,ylow,mptr,nvar,istage)

       use amr_module
       implicit double precision(a-h,o-z)

       dimension qp(nvar,mitot,mjtot),qx(nvar,mitot,mjtot),
     &           qy(nvar,mitot,mjtot),irr(mitot,mjtot)
       dimension qxx(nvar,mitot,mjtot), qyy(nvar,mitot,mjtot)
       dimension qxy(nvar,mitot,mjtot)
       dimension qxxx(nvar,mitot,mjtot),qyyy(nvar,mitot,mjtot)
       dimension qxxy(nvar,mitot,mjtot),qxyy(nvar,mitot,mjtot)
       logical  quad, nolimiter
       include "cuserdt.i"
       common /order2/ ssw, quad, nolimiter

c
c  Set all slopes, even for irregular or solid.
c  Will be fixed in slope routines for irregular/solid cells called afterwards

c      # ssw = slope switch (1. for slopes, 0 for donor cell 0 slopes)
c      # now set in amrcart
c
c   ssw = 0 for ctu (no slopes), 1 for muscl (second order).
c   compute slopes using muscl limiter
c   q contains either conserved or primitive variables
c
c  Here do more accurate quadratic reconstruction.
c  Construct cubic but only use quadratic part. Limiting done elsewhere
c  initialized in method (in case no slopes at all)

c
      do j = 3, mjtot-2
      do i = 3, mitot-2

      qyyy(:,i,j) = (2*qp(:,i,j-1) - qp(:,i,j-2) - 2*qp(:,i,j+1)
     .+ qp(:,i,j+2) + 2*qp(:,i-1,j-1) - qp(:,i-1,j-2) - 2*qp(:,i-1,j+1)
     .+ qp(:,i-1,j+2) + 2*qp(:,i-2,j-1) - qp(:,i-2,j-2)
     . - 2*qp(:,i-2,j+1) + qp(:,i-2,j+2) +  2*qp(:,i+1,j-1)
     . - qp(:,i+1,j-2) - 2*qp(:,i+1,j+1) + qp(:,i+1,j+2)
     .+  2*qp(:,i+2,j-1) - qp(:,i+2,j-2) - 2*qp(:,i+2,j+1)
     . + qp(:,i+2,j+2))/(10.*hy**3)

      qxyy(:,i,j) = (2*qp(:,i-1,j) + qp(:,i-1,j-1) - 2*qp(:,i-1,j-2)
     . + qp(:,i-1,j+1) - 2*qp(:,i-1,j+2) + 4*qp(:,i-2,j)
     .+ 2*qp(:,i-2,j-1) - 4*qp(:,i-2,j-2) + 2*qp(:,i-2,j+1)
     .- 4*qp(:,i-2,j+2) - 2*qp(:,i+1,j) - qp(:,i+1,j-1) +2*qp(:,i+1,j-2)
     .- qp(:,i+1,j+1) + 2*qp(:,i+1,j+2) - 4*qp(:,i+2,j)
     .-2*qp(:,i+2,j-1) + 4*qp(:,i+2,j-2) - 2*qp(:,i+2,j+1)
     .+ 4*qp(:,i+2,j+2))/(70.*hx*hy**2)

      qxxy(:,i,j) = (2*qp(:,i,j-1) + 4*qp(:,i,j-2) - 2*qp(:,i,j+1)
     .- 4*qp(:,i,j+2) +qp(:,i-1,j-1) + 2*qp(:,i-1,j-2) - qp(:,i-1,j+1)
     . - 2*qp(:,i-1,j+2) - 2*qp(:,i-2,j-1) - 4*qp(:,i-2,j-2)
     . + 2*qp(:,i-2,j+1) + 4*qp(:,i-2,j+2)+ qp(:,i+1,j-1)
     . + 2*qp(:,i+1,j-2) - qp(:,i+1,j+1)
     .- 2*qp(:,i+1,j+2) -2*qp(:,i+2,j-1) - 4*qp(:,i+2,j-2)
     . + 2*qp(:,i+2,j+1) + 4*qp(:,i+2,j+2))/(70.*hx**2*hy)

      qxxx(:,i,j) = (2*qp(:,i-1,j) + 2*qp(:,i-1,j-1) + 2*qp(:,i-1,j-2)
     . + 2*qp(:,i-1,j+1) + 2*qp(:,i-1,j+2) - qp(:,i-2,j) - qp(:,i-2,j-1)
     . - qp(:,i-2,j-2) - qp(:,i-2,j+1) - qp(:,i-2,j+2) - 2*qp(:,i+1,j)
     . - 2*qp(:,i+1,j-1) - 2*qp(:,i+1,j-2) - 2*qp(:,i+1,j+1)
     . - 2*qp(:,i+1,j+2) + qp(:,i+2,j) + qp(:,i+2,j-1) + qp(:,i+2,j-2)
     . + qp(:,i+2,j+1) +  qp(:,i+2,j+2))/(10.*hx**3)

      qyy(:,i,j) = (-350*qp(:,i,j) + 17*qp(:,i,j-1) + 68*qp(:,i,j-2)
     . + 17*qp(:,i,j+1) + 68*qp(:,i,j+2) - 10*qp(:,i-1,j)
     . + 7*qp(:,i-1,j-1) + 58*qp(:,i-1,j-2)  + 7*qp(:,i-1,j+1)
     . + 58*qp(:,i-1,j+2) - 40*qp(:,i-2,j) -  23*qp(:,i-2,j-1)
     . + 28*qp(:,i-2,j-2) - 23*qp(:,i-2,j+1) + 28*qp(:,i-2,j+2)
     . - 10*qp(:,i+1,j) + 7*qp(:,i+1,j-1) + 58*qp(:,i+1,j-2)
     . + 7*qp(:,i+1,j+1) + 58*qp(:,i+1,j+2) -  40*qp(:,i+2,j)
     . - 23*qp(:,i+2,j-1) + 28*qp(:,i+2,j-2) - 23*qp(:,i+2,j+1)
     . + 28*qp(:,i+2,j+2))/(945.*hy**2)

      qxy(:,i,j) = (qp(:,i-1,j-1) + 2*qp(:,i-1,j-2) - qp(:,i-1,j+1)
     . - 2*qp(:,i-1,j+2) + 2*qp(:,i-2,j-1) + 4*qp(:,i-2,j-2)
     . - 2*qp(:,i-2,j+1) - 4*qp(:,i-2,j+2)- qp(:,i+1,j-1)
     . - 2*qp(:,i+1,j-2) + qp(:,i+1,j+1) + 2*qp(:,i+1,j+2)
     . - 2*qp(:,i+2,j-1) - 4*qp(:,i+2,j-2) + 2*qp(:,i+2,j+1)
     . + 4*qp(:,i+2,j+2))/(100.*hx*hy)

      qxx(:,i,j) = (-350*qp(:,i,j) - 10*qp(:,i,j-1) - 40*qp(:,i,j-2)
     . - 10*qp(:,i,j+1) - 40*qp(:,i,j+2) + 17*qp(:,i-1,j)
     . + 7*qp(:,i-1,j-1) - 23*qp(:,i-1,j-2) + 7*qp(:,i-1,j+1)
     . - 23*qp(:,i-1,j+2) + 68*qp(:,i-2,j) + 58*qp(:,i-2,j-1)
     . + 28*qp(:,i-2,j-2) + 58*qp(:,i-2,j+1) + 28*qp(:,i-2,j+2)
     . + 17*qp(:,i+1,j) + 7*qp(:,i+1,j-1) - 23*qp(:,i+1,j-2)
     . + 7*qp(:,i+1,j+1) - 23*qp(:,i+1,j+2) + 68*qp(:,i+2,j)
     . + 58*qp(:,i+2,j-1) + 28*qp(:,i+2,j-2) + 58*qp(:,i+2,j+1)
     . + 28*qp(:,i+2,j+2))/(945.*hx**2)

         qy(:,i,j)  = (-288*qp(:,i,j-1) - 65*qp(:,i,j-2)
     . + 288*qp(:,i,j+1) + 65*qp(:,i,j+2) - 263*qp(:,i-1,j-1)
     .  - 15*qp(:,i-1,j-2) + 263*qp(:,i-1,j+1) + 15*qp(:,i-1,j+2)
     . - 188*qp(:,i-2,j-1) + 135*qp(:,i-2,j-2) + 188*qp(:,i-2,j+1)
     . - 135*qp(:,i-2,j+2) - 263*qp(:,i+1,j-1) - 15*qp(:,i+1,j-2)
     . + 263*qp(:,i+1,j+1) + 15*qp(:,i+1,j+2) - 188*qp(:,i+2,j-1)
     .  + 135*qp(:,i+2,j-2) + 188*qp(:,i+2,j+1)
     .  - 135*qp(:,i+2,j+2))/(1680.*hy)

         qx(:,i,j)  = (-288*qp(:,i-1,j) - 263*qp(:,i-1,j-1)
     . - 188*qp(:,i-1,j-2) - 263*qp(:,i-1,j+1) - 188*qp(:,i-1,j+2)
     . - 65*qp(:,i-2,j) - 15*qp(:,i-2,j-1) + 135*qp(:,i-2,j-2)
     . - 15*qp(:,i-2,j+1) + 135*qp(:,i-2,j+2) + 288*qp(:,i+1,j)
     . + 263*qp(:,i+1,j-1) + 188*qp(:,i+1,j-2) + 263*qp(:,i+1,j+1)
     . + 188*qp(:,i+1,j+2) + 65*qp(:,i+2,j) + 15*qp(:,i+2,j-1)
     . - 135*qp(:,i+2,j-2) + 15*qp(:,i+2,j+1)
     . - 135*qp(:,i+2,j+2))/(1680.*hx)

       end do
       end do

       return
       end


      subroutine rat(x,eps,n,d,fail)
c!but
c     ce sous programme approximme un reel x par un rationnel n/d
c!liste d'appel
c
c       subroutine rat(x,eps,n,d,fail)
c     double precision x,eps
c     integer n,d,fail
c
c     x: reel contenant le nombre a approximer
c     eps: precision requise : (abs(x-n/d))<eps
c     n,d:entiers contenant respectivement le numerateur et le
c         denominateur du resultat
c     fail:indicateur d'erreur
c           fail=0 : ok
c           fail.ne.0 precision requise trop grande ou nombre trop
c           grand ou trop petit pour etre code sous cette forme
c!origine
c     s steer inria
c!
c
c     Copyright INRIA
      double precision x,eps,z,err,dz,xn,xd,ax
      integer n,d,nmax,n0,d0,n1,d1,bm,fail
c possibly the largest integer (hum ???)
      nmax=2147483647
      fail=0
      n0=0
      d0=1
      n1=1
      d1=0
      z=abs(x)
      ax=z
   10 err=abs(d1*ax-n1)
      if(err.le.d1*eps) goto 20
      if(z.gt.nmax) goto 30
      bm=int(z)
      dz=z-bm
      if(dz.eq.0.0d+0) goto 15
      z=1.0d+0/dz
   15 xn=n0+dble(bm)*n1
      xd=d0+dble(bm)*d1
      if(xn.gt.nmax.or.xd.gt.nmax) goto 30
      n0=n1
      d0=d1
      n1=int(xn)
      d1=int(xd)
      if(dz.eq.0.0d+0) goto 20
      goto 10
   20 n=n1
      d=d1
      if (x.lt.0.0d+0) n=-n
      return
   30 fail=1
      return
      end