!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      subroutine dlwqng ( a     , j     , c     , lun   , lchar  ,
     &                    action, dlwqd , gridps)

!       Deltares Software Centre

!>\file
!>                         Upwind horizontally, central vertically, GMRES solver (16)
!>
!>                         Performs time dependen integration. Upwind horizontally,
!>                         central vertically, implicit in time. Uses the GMRES
!>                         iterative solver with Krilov sub-spaces.\n
!>                         Forester filter is optional to ensure monotoneous behaviour
!>                         in the vertical.

!     CREATED            : april 1992 by J.v.Gils
!                          Fast solvers enhancements by L.P, R.V, KHT
!                                 sept-nov. 1996
!                              Central discretization vertically
!
!     LAST MODIFIED      : 6 feb 1997
!
!     LOGICAL UNITS      : LUN(19) , output, monitoring file
!                          LUN(20) , output, formatted dump file
!                          LUN(21) , output, unformatted hist. file
!                          LUN(22) , output, unformatted dump file
!                          LUN(23) , output, unformatted dump file
!
!     SUBROUTINES CALLED : DLWQTR, user transport routine
!                          DLWQWQ, user waterquality routine
!                          PROCES, DELWAQ proces system
!                          DLWQO2, DELWAQ output system
!                          DLWQPP, user postprocessing routine
!                          DLWQ13, system postpro-dump routine
!                          DLWQ14, scales waterquality
!                          DLWQ15, wasteload routine
!                          DLWQ17, boundary routine
!                          DLWQ41, updates volumes
!                          DLWQT0, updates other time dependent items
!                          DLWQ62, adds transport to matrix and rhs
!                          DLWQB3, computes volumes
!                          DLWQB4, computation of mass array
!                          DLWQB5, performs mass balance computation
!                          DLWQB6, updates right hand side
!                          DLWQB7, adds open boundaries to deriv
!                          DLWQB8, restores conc array
!                          DLWQF1, initializes matrix pointer administration
!                          DLWQF2, sets diagonal of system of equations
!                          DLWQG3, fills matrix for vertical central discretizat
!                          DLWQF4, sets (scaled) rhs of system of equations
!                          DLWQF6, checks matrix
!                          MOVE,   copies one array to another
!                          PROINT, integration of fluxes
!                          DHOPNF, opens files
!                          SGMRES, solves (iteratively) system of equations
!                          ZERCUM, zero's the cummulative array's
!
!     PARAMETERS    :
!
!     NAME    KIND     LENGTH   FUNC.  DESCRIPTION
!     ---------------------------------------------------------
!     A       REAL       *      LOCAL  real      workspace array
!     J       INTEGER    *      LOCAL  integer   workspace array
!     C       CHARACTER  *      LOCAL  character workspace array
!     LUN     INTEGER    *      INPUT  array with unit numbers
!     LCHAR   CHAR*(*)   *      INPUT  filenames
!
      use grids
      use timers
      use m_timers_waq
      use waqmem                         ! Global memory with allocatable GMRES arrays
      use delwaq2_data
      use m_openda_exchange_items, only : get_openda_buffer
      use report_progress

      implicit none

      include 'actions.inc'
!
!     Declaration of arguments
!
      REAL, DIMENSION(*)          :: A
      INTEGER, DIMENSION(*)       :: J
      INTEGER, DIMENSION(*)       :: LUN
      CHARACTER*(*), DIMENSION(*) :: C
      CHARACTER*(*), DIMENSION(*) :: LCHAR
      INTEGER                     :: ACTION
      TYPE(DELWAQ_DATA), TARGET   :: DLWQD
      type(GridPointerColl)       :: GridPs               ! collection of all grid definitions

!$    include "omp_lib.h"

!
!     COMMON  /  SYSN   /   System characteristics
!
      INCLUDE 'sysn.inc'
!
!     COMMON  /  SYSI  /    Timer characteristics
!
      INCLUDE 'sysi.inc'
!
!     COMMON  /  SYSA   /   Pointers in real array workspace
!
      INCLUDE 'sysa.inc'
!
!     COMMON  /  SYSJ   /   Pointers in integer array workspace
!
      INCLUDE 'sysj.inc'
!
!     COMMON  /  SYSC   /   Pointers in character array workspace
!
      INCLUDE 'sysc.inc'

!
!     Local declarations
!
      REAL                   :: RDUMMY(1)
      LOGICAL                :: IMFLAG , IDFLAG , IHFLAG
      LOGICAL                :: UPDATR , UPDATE , LSTREC , LREWIN
      LOGICAL                :: LITREP , LDUMMY, timon_old
      real(kind=kind(1.0d0)) :: tol
      LOGICAL                :: FORESTER
      INTEGER                :: ITIME
      INTEGER                :: ITIMEL
      INTEGER                :: IFFLAG
      INTEGER                :: IAFLAG
      INTEGER                :: IBFLAG
      INTEGER                :: NDDIM
      INTEGER                :: NVDIM
      INTEGER                :: NOQT
      INTEGER                :: NOWARN
      INTEGER                :: NOPRED
      INTEGER                :: INWTYP
      INTEGER                :: ISYS
      INTEGER                :: NSTEP
      INTEGER         sindex

      integer                :: ithandl
      integer, save          :: ithand1 = 0 ! Make this one "global"
      integer                :: noth
      integer                :: ith

      integer                :: ibnd

      !
      ! Variables specific to this method: leave them SAVEd
      !
      integer, save          :: ioptpc
      integer, save          :: iter
      integer, save          :: iscale

      !
      ! Dummy variables - used in DLWQD
      !
      integer                :: lleng
      integer                :: ioptzb
      integer                :: nosss
      integer                :: noqtt

      INCLUDE 'state_data.inc'

!
!     SPECIAL REMARKS    : MASS-ARRAY IS USED FOR RHS VECTOR!!
!
!     This option is a mix of option 1 (discretization of transport
!     in space) and option 6 (matrix inversion to perform implicit
!     integration in time.
!     The processes part is integrated EXPLICITLY, in order to allow
!     for any complexity of the processes.
!     Strictly speaking, a loop over substances should be added
!     To anticipate this, the method uses an
!     extra VOLUME-array (IVOL2), and uses the AMASS-array (IMASS)
!     for the rhs-matrix, instead of the DERIV-array as in method 6.
!     (JvG, May 8 1992)
!
!     This option implements:
!     1) Euler backward time integration
!     2) upwind differences for advection
!     3) central differences for diffusion
!     The resulting systems of equations are solved by an iterative
!     solution method (GMRES).
!     With such an iterative method, systems with multiple rhs cannot be solved
!     (simultaneously). So we loop over the substances and solve each system
!     individually. So RHS can be reduced to an REAL array of size NOSEG+NOBND.
!
!     possible improvements:
!
!     - Use FGMRES instead of GMRES for solving system of equations.
!       This makes it possible to keep search directions which have already
!       been computed in previous FGMRES calls and hence find the solution
!       of new systems at lower costs!
!
!     - Tune the preconditioner to speed up the iteration process.
!       Only Gaus-Seidel, and SSOR preconditioning has been implemented yet.
!
!     - Integrate processes in an implicit way as well. Enables users to
!       potentially take larger time steps (better stability properties)
!       or even compute steady states in "one time step" (the latter subject
!       to constraint that proces formulation is time independent).
!       Implicit time integration of processes requires the Inexact Newton
!       solution method described in:
!
!       "DELWAQ FASTSOLVER II"
!       Newton-Krylov methods for solving linear and non-linear equations
!       report T1596, January 1996, Deltares
!                                                              (KHT, 13/11/96)

      if ( action == ACTION_FINALISATION ) then
          include 'dlwqdata_restore.inc'
          if ( timon ) call timstrt ( "dlwqng", ithandl )
          goto 50
      endif

      IF ( ACTION == ACTION_INITIALISATION  .OR.
     &     ACTION == ACTION_FULLCOMPUTATION        ) THEN

!
!        some initialisation
!        IOPTPC = preconditioner switch [0 = none, 1 = GS (L), 2 = GS (U),
!        3 = SSOR], ITER = maximum number of iterations [ > 0],
!        TOL = relative tolerance [10^-3, 10^-10], ISCALE = row scaling
!        of system of equations [0 = no, 1 =yes], KLAT = number of
!        layers in preconditioner [1,KMAX]
!
          call dlwqf5 ( lun(19) , nocons  , c(icnam), a(icons), ioptpc  ,
     &                  iter    , tol     , iscale  , litrep  , noseg   ,
     &                  noq3    , noq     , nobnd   , novec   , nomat   ,
     &                  nolay   , intsrt  , intopt  )

          ithandl = 0
          itime   = itstrt
          nstep   = (itstop-itstrt)/idt
          ifflag  = 0
          iaflag  = 0
          ibflag  = 0
          if ( mod(intopt,16) .ge. 8 ) ibflag = 1
          if ( ndspn .eq. 0 ) then
             nddim = nodisp
          else
             nddim = ndspn
          endif
          if ( nveln .eq. 0 ) then
             nvdim = novelo
          else
             nvdim = nveln
          endif
          lstrec   = icflag .eq. 1
          nosss    = noseg + nseg2
          noqtt    = noq   + noq4
          inwtyp   = intyp + nobnd
          noqt     = noq1  + noq2
          lleng    = ileng+noqt*2
          forester = btest(intopt,6)
          nowarn   = 0

          call initialise_progress( dlwqd%progress, nstep, lchar(44) )

!          initialize second volume array with the first one

          call move   ( a(ivol ), a(ivol2) , nosss   )
      ENDIF

!
!     Save/restore the local persistent variables,
!     if the computation is split up in steps
!
!     Note: the handle to the timer (ithandl) needs to be
!     properly initialised and restored
!
      IF ( ACTION == ACTION_INITIALISATION ) THEN
          if ( timon ) call timstrt ( "dlwqng", ithandl )
          INCLUDE 'dlwqdata_save.inc'
          if ( timon ) call timstop ( ithandl )
          RETURN
      ENDIF

      IF ( ACTION == ACTION_SINGLESTEP ) THEN
          INCLUDE 'dlwqdata_restore.inc'
          call apply_operations( dlwqd )
      ENDIF

      if ( timon ) call timstrt ( "dlwqng", ithandl )

      iexseg = 1     !  There is nothing to mask.

!======================= simulation loop ============================

   10 continue

!        Determine the volumes and areas that ran dry at start of time step

         call hsurf  ( noseg    , nopa     , c(ipnam) , a(iparm) , nosfun   ,
     &                 c(isfna) , a(isfun) , surface  , lun(19)  )
         call dryfld ( noseg    , nosss    , nolay    , a(ivol)  , noq1+noq2,
     &                 a(iarea) , nocons   , c(icnam) , a(icons) , surface  ,
     &                 j(iknmr) , iknmkv   )

!          user transport processes

         update = updatr
         call dlwqtr ( notot    , nosys    , nosss    , noq      , noq1     ,
     &                 noq2     , noq3     , nopa     , nosfun   , nodisp   ,
     &                 novelo   , j(ixpnt) , a(ivol)  , a(iarea) , a(iflow) ,
     &                 a(ileng) , a(iconc) , a(idisp) , a(icons) , a(iparm) ,
     &                 a(ifunc) , a(isfun) , a(idiff) , a(ivelo) , itime    ,
     &                 idt      , c(isnam) , nocons   , nofun    , c(icnam) ,
     &                 c(ipnam) , c(ifnam) , c(isfna) , update   , ilflag   ,
     &                 npartp   )
         if ( update ) updatr = .true.

!jvb  Temporary ? set the variables grid-setting for the DELWAQ variables

         call setset ( lun(19)  , nocons   , nopa     , nofun    , nosfun   ,
     &                 nosys    , notot    , nodisp   , novelo   , nodef    ,
     &                 noloc    , ndspx    , nvelx    , nlocx    , nflux    ,
     &                 nopred   , novar    , nogrid   , j(ivset) )

!        return conc and take-over from previous step or initial condition,
!        and do particle tracking of this step (will be back-coupled next call)

         call delpar01( itime   , noseg    , nolay    , noq      , nosys    ,
     &                  notot   , a(ivol)  , surface  , a(iflow) , c(isnam) ,
     &                  nosfun  , c(isfna) , a(isfun) , a(imass) , a(iconc) ,
     &                  iaflag  , intopt   , ndmps    , j(isdmp) , a(idmps) ,
     &                  a(imas2))

!          call PROCES subsystem

         call proces ( notot    , nosss    , a(iconc) , a(ivol)  , itime    ,
     &                 idt      , a(iderv) , ndmpar   , nproc    , nflux    ,
     &                 j(iipms) , j(insva) , j(iimod) , j(iiflu) , j(iipss) ,
     &                 a(iflux) , a(iflxd) , a(istoc) , ibflag   , ipbloo   ,
     &                 ipchar   , ioffbl   , ioffch   , a(imass) , nosys    ,
     &                 itfact   , a(imas2) , iaflag   , intopt   , a(iflxi) ,
     &                 j(ixpnt) , iknmkv   , noq1     , noq2     , noq3     ,
     &                 noq4     , ndspn    , j(idpnw) , a(idnew) , nodisp   ,
     &                 j(idpnt) , a(idiff) , ndspx    , a(idspx) , a(idsto) ,
     &                 nveln    , j(ivpnw) , a(ivnew) , novelo   , j(ivpnt) ,
     &                 a(ivelo) , nvelx    , a(ivelx) , a(ivsto) , a(idmps) ,
     &                 j(isdmp) , j(ipdmp) , ntdmpq   , a(idefa) , j(ipndt) ,
     &                 j(ipgrd) , j(ipvar) , j(iptyp) , j(ivarr) , j(ividx) ,
     &                 j(ivtda) , j(ivdag) , j(ivtag) , j(ivagg) , j(iapoi) ,
     &                 j(iaknd) , j(iadm1) , j(iadm2) , j(ivset) , j(ignos) ,
     &                 j(igseg) , novar    , a        , nogrid   , ndmps    ,
     &                 c(iprna) , intsrt   , j(iowns) , j(iownq) , mypart   ,
     &                 j(iprvpt), j(iprdon), nrref    , j(ipror) , nodef    ,
     &                 surface  , lun(19)  )

!          communicate boundaries (for domain decomposition)

      call timer_start(timer_bound)
         call dlwq_boundio ( lun(19)  , notot    , nosys    , nosss    , nobnd    ,
     &                       c(isnam) , c(ibnid) , j(ibpnt) , a(iconc) , a(ibset) ,
     &                       lchar(19))

!          set new boundaries

         if ( itime .ge. 0   ) then
          ! first: adjust boundaries by OpenDA
            if ( dlwqd%inopenda ) then
               do ibnd = 1,nobnd
                  do isys = 1,nosys
                      call get_openda_buffer(isys,ibnd, 1,1,
     &                                  A(ibset+(ibnd-1)*nosys + isys-1))
                  enddo
               enddo
            endif
            call dlwq17 ( a(ibset), a(ibsav), j(ibpnt), nobnd   , nosys   ,
     &                    notot   , idt     , a(iconc), a(iflow), a(iboun))
         endif
         call timer_stop(timer_bound)
!
!     Call OUTPUT system
!
      call timer_start(timer_output)
      CALL DLWQO2 ( NOTOT   , NOSEG   , NOPA    , NOSFUN  , ITIME   ,
     +              C(IMNAM), C(ISNAM), C(IDNAM), J(IDUMP), NODUMP  ,
     +              A(ICONC), A(ICONS), A(IPARM), A(IFUNC), A(ISFUN),
     +              A(IVOL) , NOCONS  , NOFUN   , IDT     , NOUTP   ,
     +              LCHAR   , LUN     , J(IIOUT), J(IIOPO), A(IRIOB),
     +              C(IOSNM), C(IOUNI), C(IODSC), C(ISSNM), C(ISUNI), C(ISDSC),
     +              C(IONAM), NX      , NY      , J(IGRID), C(IEDIT),
     +              NOSYS   , A(IBOUN), J(ILP)  , A(IMASS), A(IMAS2),
     +              A(ISMAS), NFLUX   , A(IFLXI), ISFLAG  , IAFLAG  ,
     +              IBFLAG  , IMSTRT  , IMSTOP  , IMSTEP  , IDSTRT  ,
     +              IDSTOP  , IDSTEP  , IHSTRT  , IHSTOP  , IHSTEP  ,
     +              IMFLAG  , IDFLAG  , IHFLAG  , NOLOC   , A(IPLOC),
     +              NODEF   , A(IDEFA), ITSTRT  , ITSTOP  , NDMPAR  ,
     +              C(IDANA), NDMPQ   , NDMPS   , J(IQDMP), J(ISDMP),
     +              J(IPDMP), A(IDMPQ), A(IDMPS), A(IFLXD), NTDMPQ  ,
     +              C(ICBUF), NORAAI  , NTRAAQ  , J(IORAA), J(NQRAA),
     +              J(IQRAA), A(ITRRA), C(IRNAM), A(ISTOC), NOGRID  ,
     +              NOVAR   , J(IVARR), J(IVIDX), J(IVTDA), J(IVDAG),
     +              J(IAKND), J(IAPOI), J(IADM1), J(IADM2), J(IVSET),
     +              J(IGNOS), J(IGSEG), A       , NOBND   , NOBTYP  ,
     +              C(IBTYP), J(INTYP), C(ICNAM), NOQ     , J(IXPNT),
     +              INTOPT  , C(IPNAM), C(IFNAM), C(ISFNA), J(IDMPB),
     +              NOWST   , NOWTYP  , C(IWTYP), J(IWAST), J(INWTYP),
     +              A(IWDMP), iknmkv  , J(IOWNS), MYPART  , isegcol )
      call timer_stop(timer_output)

!        zero cumulative arrays

         call timer_start(timer_output)
         if ( imflag .or. ( ihflag .and. noraai .gt. 0 ) ) then
            call zercum ( notot   , nosys   , nflux   , ndmpar  , ndmpq   ,
     &                    ndmps   , a(ismas), a(iflxi), a(imas2), a(iflxd),
     &                    a(idmpq), a(idmps), noraai  , imflag  , ihflag  ,
     &                    a(itrra), ibflag  , nowst   , a(iwdmp))
         endif
         call write_progress( dlwqd%progress )
         call timer_stop(timer_output)

!        simulation done ?

         if ( itime .lt. 0      ) goto 9999
         if ( itime .ge. itstop ) goto 50

!          restore conc-array from mass array

         call timer_start(timer_transport)
         call dlwqb8 ( nosys    , notot    , nototp   , noseg    , a(ivol ) ,
     &                 surface  , a(imass) , a(iconc) )

!        add processes

         call dlwq14 ( a(iderv), notot   , noseg   , itfact  , a(imas2),
     &                 idt     , iaflag  , a(idmps), intopt  , j(isdmp),
     &                 j(iowns), mypart )
         call timer_stop(timer_transport)

!        get new volumes

         itimel = itime
         itime  = itime + idt
         call timer_start(timer_readdata)
         select case ( ivflag )
            case ( 1 )                 !     computation of volumes for computed volumes only
               call move   ( a(ivol)  , a(ivol2) , noseg    )
               call dlwqb3 ( a(iarea) , a(iflow) , a(ivnew) , j(ixpnt) , notot    ,
     &                       noq      , nvdim    , j(ivpnw) , a(ivol2) , intopt   ,
     &                       a(imas2) , idt      , iaflag   , nosys    , a(idmpq) ,
     &                       ndmpq    , j(iqdmp) )
               updatr = .true.
            case ( 2 )                 !     the fraudulent computation option
               call dlwq41 ( lun      , itime    , itimel   , a(iharm) , a(ifarr) ,
     &                       j(inrha) , j(inrh2) , j(inrft) , noseg    , a(ivoll) ,
     &                       j(ibulk) , lchar    , ftype    , isflag   , ivflag   ,
     &                       updatr   , j(inisp) , a(inrsp) , j(intyp) , j(iwork) ,
     &                       lstrec   , lrewin   , a(ivol2) , mypart   , dlwqd    )
               call dlwqf8 ( noseg    , noq      , j(ixpnt) , idt      , iknmkv   ,
     &                       a(ivol ) , a(iflow) , a(ivoll) , a(ivol2) )
               updatr = .true.
               lrewin = .true.
               lstrec = .true.
            case default               !     read new volumes from files
               call dlwq41 ( lun      , itime    , itimel   , a(iharm) , a(ifarr) ,
     &                       j(inrha) , j(inrh2) , j(inrft) , noseg    , a(ivol2) ,
     &                       j(ibulk) , lchar    , ftype    , isflag   , ivflag   ,
     &                       updatr   , j(inisp) , a(inrsp) , j(intyp) , j(iwork) ,
     &                       lstrec   , lrewin   , a(ivoll) , mypart   , dlwqd    )
         end select
         call timer_stop(timer_readdata)

!     Update the info on dry volumes with the new volumes        ( dryfle )
!      Compute new from-topointer on the basis of non-zeroflows  ( zflows )
!       Initialize pointer matices for fast solvers              ( dlwqf1 )

         call dryfle ( noseg    , nosss    , a(ivol2) , nolay    , nocons   ,
     &                 c(icnam) , a(icons) , surface  , j(iknmr) , iknmkv   )
         call zflows ( noq      , noqt     , nolay    , nocons   , c(icnam) ,
     &                 a(iflow) , j(ixpnt) )
         call dlwqf1 ( noseg    , nobnd    , noq      , noq1     , noq2     ,
     &                 nomat    , j(ixpnt) , j(iwrk)  , j(imat)  , rowpnt   ,
     &                 fmat     , tmat     )

!          add the waste loads

         call timer_start(timer_wastes)
         call dlwq15 ( nosys     , notot    , noseg    , noq      , nowst    ,
     &                 nowtyp    , ndmps    , intopt   , idt      , itime    ,
     &                 iaflag    , c(isnam) , a(iconc) , a(ivol)  , a(ivol2) ,
     &                 a(iflow ) , j(ixpnt) , c(iwsid) , c(iwnam) , c(iwtyp) ,
     &                 j(inwtyp) , j(iwast) , iwstkind , a(iwste) , a(iderv) ,
     &                 iknmkv    , nopa     , c(ipnam) , a(iparm) , nosfun   ,
     &                 c(isfna ) , a(isfun) , j(isdmp) , a(idmps) , a(imas2) ,
     &                 a(iwdmp)  , 1        , notot    , j(iowns ), mypart   )
         call timer_stop(timer_wastes)
!
!          Here we implement a loop that inverts the same matrix
!          for series of subsequent substances having the same
!          additional VELO and DISPER array. (JvG, April 24, 1993).
!
!          In solving equations with multiple rhs, the *FULL* fast (or should
!          I say slow?) solver algorithm needs to be applied to each rhs vector
!          So DELMAT may outperform FS when we deal with a large number of
!          substances with the same additional velocity and dispersion field
!          In future we need a smart switch between DELMAT and FS at this place
!          For now always do FS!
!                                                               (KHT, 11/11/96)

      call timer_start(timer_transport)
      if (timon) call timstrt ( "ADE solver", ithand1 )
      timon_old = timon
      noth = OMP_GET_MAX_THREADS()
      if ( noth .gt. 1 ) timon = .false.

!$OMP PARALLEL
!$OMP DO PRIVATE(ith) SCHEDULE(DYNAMIC)
! start of loop over substances

      do 40 isys = 1, nosys
!        ith = 1             !  number of threads for parallel processing
         ith = OMP_GET_THREAD_NUM()+1

!          initialize diagonal

         call dlwqf2 ( noseg         , nobnd         , idt           , a(ivol2)      , gm_diag(1,ith))

!          do the transport itself, fill matrix, scale diagonal

         call dlwqg3 ( noseg         , nobnd         , noq1          , noq2          , noq           ,
     &                 j(ixpnt)      , nddim         , nvdim         , j(idpnw)      , j(ivpnw)      ,
     &                 a(iarea)      , a(iflow)      , a(ileng)      , a(idisp)      , a(idnew)      ,
     &                 a(ivnew)      , isys          , intopt        , ilflag        , nomat         ,
     &                 gm_amat(1,ith), j(imat)       , rowpnt        , gm_diag(1,ith),gm_diac(1,ith),
     &                 iscale        , fmat          , tmat          , iknmkv        )

!          compute RHS (substance after substance)

         call dlwqf4 ( noseg        , nobnd         , nosys         , notot         , isys          ,
     &                 idt          , a(iconc)      , a(iderv)      , a(ivol)       , a(iboun)      ,
     &                 gm_rhs(1,ith), gm_diac(1,ith), gm_sol(1,ith) )

!          solve linear system of equations

         call sgmres ( noseg+nobnd  , gm_rhs (1,ith), gm_sol (1,ith), novec         , gm_work(1,ith),
     &                 noseg+nobnd  , gm_hess(1,ith), novec+1       , iter          , tol           ,
     &                 nomat        , gm_amat(1,ith), j(imat)       , gm_diag(1,ith), rowpnt        ,
     &                 nolay        , ioptpc        , nobnd         , gm_trid(1,ith), iexseg (1,ith),
     &                 lun(19)      , litrep        )

!           copy solution for this substance into concentration array

         call dlwqf6 ( noseg        , notot         , isys          , 1             , gm_sol(1,ith) ,
     &                 a(iconc)     , iknmkv        )

!        end loop over the substances

   40 continue

!$OMP ENDDO
!$OMP ENDPARALLEL
      if ( noth .gt. 1 ) timon = timon_old

      if ( timon ) call timstop ( ithand1 )

!          mass balance of transport

      CALL DLWQB5 ( A(IDISP), A(IDNEW), A(IAREA), A(IFLOW), A(ILENG),
     *              A(IVNEW), A(ICONC), A(IBOUN), J(IXPNT), NOSYS   ,
     *              NOTOT   , NOQ1    , NOQ2    , NOQ     , NDDIM   ,
     *              NVDIM   , J(IDPNW), J(IVPNW), INTOPT  , A(IMAS2),
     *              ILFLAG  , A(IDMPQ), NDMPQ   , IDT     , J(IQDMP))

!          update mass array, explicit step for passive substances

         call dlwqb4 ( nosys   , notot   , nototp  , noseg   , a(ivol2),
     &                 surface , a(imass), a(iconc), a(iderv), idt     )

!       Forester filter on the vertical

      IF ( FORESTER ) THEN
         CALL DLWQD2 ( LUN(19) , NOSYS   , NOTOT   , NOSEG   , NOQ3    ,
     *                 KMAX    , A(ICONC), A(LLENG), NOWARN  , J(IOWNS),
     *                 MYPART )
      ENDIF

!     calculate closure error

         if ( lrewin .and. lstrec ) then
            call dlwqce ( a(imass), a(ivoll), a(ivol2), nosys , notot ,
     &                    noseg   , lun(19) )
            call move   ( a(ivoll), a(ivol) , noseg   )    !  replace old by new volumes
         else
            call move   ( a(ivol2), a(ivol) , noseg   )    !  replace old by new volumes
         endif

!     integrate the fluxes at dump segments fill asmass with mass
         if ( ibflag .gt. 0 ) then
            call proint ( nflux   , ndmpar  , idt     , itfact  , a(iflxd),
     &                    a(iflxi), j(isdmp), j(ipdmp), ntdmpq  )
         endif
         call timer_stop(timer_transport)

!          new time values, volumes excluded

         call timer_start(timer_readdata)
         call dlwqt0 ( lun      , itime    , itimel   , a(iharm) , a(ifarr) ,
     &                 j(inrha) , j(inrh2) , j(inrft) , idt      , a(ivol)  ,
     &                 a(idiff) , a(iarea) , a(iflow) , a(ivelo) , a(ileng) ,
     &                 a(iwste) , a(ibset) , a(icons) , a(iparm) , a(ifunc) ,
     &                 a(isfun) , j(ibulk) , lchar    , c(ilunt) , ftype    ,
     &                 intsrt   , isflag   , ifflag   , ivflag   , ilflag   ,
     &                 update   , j(iktim) , j(iknmr) , j(inisp) , a(inrsp) ,
     &                 j(intyp) , j(iwork) , .false.  , ldummy   , rdummy   ,
     &                 .false.  , gridps   , dlwqd    )
         if ( update ) updatr = .true.
         call timer_stop(timer_readdata)

!          end of time loop

         if ( action == ACTION_FULLCOMPUTATION ) then
            goto 10
         endif

   50 continue

      if ( action == ACTION_FINALISATION    .or.
     &     action == ACTION_FULLCOMPUTATION      ) then

!     close files, except monitor file
         call timer_start(timer_close)
         call CloseHydroFiles( dlwqd%collcoll )
         call close_files( lun )

!     write restart file
         call dlwq13 ( lun      , lchar , a(iconc) , itime , c(imnam) ,
     &                 c(isnam) , notot , noseg    )
         call timer_stop(timer_close)
      endif

 9999 if ( timon ) call timstop ( ithandl )

      dlwqd%iaflag = iaflag
      dlwqd%itime = itime

      RETURN
      END


      subroutine gdkm_connect(iflg)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!***********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 Identify connections and geometry for gdkm
!D1 Called from add_gdpm to connect 'last' gdpm node to a surrounding
!D1    primary grid matrix block
!D1
!***********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 FEHM Version 3.0
!D2
!D2 Initial implementation: Programmer: George Zyvoloski
!D2 8-May-2010
!D2
!***********************************************************************
!D3
!D3 REQUIREMENTS TRACEABILITY
!D3
!D3 2.3.7 Sources and sinks
!D3 2.6   Provide Input/Output Data Files
!D3 3.0   INPUT AND OUTPUT REQUIREMENTS
!D3
!***********************************************************************
!D4
!D4  SPECIAL COMMENTS AND REFERENCES
!D4
!D4 Requirements from SDN: 10086-RD-2.20-00
!D4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
!D4   FEHM Application Version 2.20
!D4
!***********************************************************************

      use comai
      use combi
      use comci
      use comdi
      use comji
      use comdti
      use comki
      use davidi
      implicit none

      integer i,icode,iflg,neqp1,i1,i2,jj,kb,kc,ii
      integer i3,i4,kk,idir,imodel,j,kcmin,iparchek
      real*8 area_i,area_kb,sx2c,dism,areat,tol_cos
      real*8 cord1,cord2,cord3,cord1j,cord2j,cord3j
      real*8 dis2,dis2i,disx2, disy2, disz2
      real*8 cosxi0,cosyi0,coszi0,cosx,cosy,cosz
      real*8 cosmin,cosikc
      real*8 cosneqx, cosposx
      integer kb_neg,kb_pos,i_pos,kb_pos_neg,i_neg,jk
      integer ic,ngdkm,nlayerm,kblast,nsize,kbmax,kbmin
      integer i_gdkm,i1_gdkm,i2_gdkm, iww
      real*8 cord_kb_pos_neg, cord_i_pos, area_kb_pos
      real*8  cord_i_neg, area_kb_neg
      real*8 disx_max,disx_min
c gaz 060117 added volume fraction cals
      real*8 a11,vfrac,vfrac2,sx1_primary,sx1_total,vf_gdpm
      integer, allocatable :: idum1(:)
      integer, allocatable :: idump(:)
      integer, allocatable :: idumn(:)
      integer, allocatable :: nelm_temp(:)
      integer, allocatable :: istrw_temp(:)
      real*8, allocatable :: sx_12(:,:)
      real*8, allocatable :: sx_temp(:,:)
      parameter(iparchek = 1)
      parameter(tol_cos = 1.d-8)
c
      neqp1 = neq +1
      if(iflg.eq.1) then
c find connections in directions gdkm
c extra storage used later
       allocate(iconn_gdkm(neq_primary,4))
        if(gdpm_flag.eq.11) then
        do i = 1,neq_primary
            areat = 0.0
            cord1 = cord(i,1)
            cord2 = cord(i,2)
            cord3 = 0.0
            if(icnl.eq.0) then
             cord3 = cord(i,3)
            endif
c     loop on neighbors
            cosneqx =0.0
            cosposx =0.0
            kb_neg = 0
            kb_pos = 0
            i1 = nelm(i)+1
            i2 = nelm(i+1)
            do jj = i1,i2
             kb = nelm(jj)
             if(kb.ne.i.and.kb.le.neq_primary) then
              cord1j = cord(kb,1)
              cord2j = cord(kb,2)
              cord3j = 0.0
              if(icnl.eq.0) then
               cord3j = cord(kb,3)
              endif
c calculate distance i-kb
              disx2 = (cord1-cord1j)**2
              disy2 = (cord2-cord2j)**2
              disz2 = (cord3-cord3j)**2
              dis2i = disx2 + disy2 + disz2
c find cosine squared
              cosxi0 = disx2/dis2i
c find min cosine connection in + and - directions
              if(cosxi0.gt.cosneqx+tol_cos
     &         .and.cord1j-cord1.gt.tol_cos) then
               cosneqx = cosxi0
               kb_pos = kb
              endif
              if(cosxi0.gt.cosposx+tol_cos
     &         .and.cord1-cord1j.gt.tol_cos) then
	         cosposx = cosxi0
	         kb_neg = kb
              endif
             endif
            enddo
            iconn_gdkm(i,1) = kb_pos
            iconn_gdkm(i,2) = kb_neg
        if(igdpm(i).gt.0) then
c gdkm nodes
c iconn_gdkm(3) has a different meaning
       i_gdkm = nelm(nelm(i+1))-1
       do kk = 1,ngdpm_layers(igdpm(i))
         i_gdkm = i_gdkm +1
         i1_gdkm = nelm(i_gdkm)+1
         i2_gdkm = nelm(i_gdkm+1)
         kb_neg = 0
         kb_pos = 0
         disx_max = tol_cos
         disx_min = -tol_cos
         do ii =  i1_gdkm, i2_gdkm
            kb = nelm(ii)
            cord1j = cord(kb,1)
            cord2j = cord(kb,2)
            cord3j = 0.0
              if(icnl.eq.0) then
               cord3j = cord(kb,3)
              endif
c find min and max distances in x directions
              disx2 = cord1j-cord1
              if(disx2.gt.disx_max) then
               disx_max = disx2
               kb_pos = kb
              else if(disx2.lt.disx_min) then
               disx_min = disx2
               kb_neg = kb
              endif
         enddo
       enddo
        iconn_gdkm(i,3) = kb_pos
        iconn_gdkm(i,4) = kb_neg
       endif
       enddo
       endif
      else if(iflg.eq.2) then
c make and break connections
       if(gdpm_flag.eq.11) then
c model 11 has x direction nodes
c start counter at number at total nodes
c estimate size of new nelm array
c assume all gdkm nodes are double sided
       allocate(idump(neq))
       allocate(idumn(neq))
       idump = 0
       idumn = 0
       neqp1 = neq+1
       ngdkm = neq-neq_primary
       nsize = nelm(neqp1)+5*ngdkm +ngdkm
       allocate(nelm_temp(nsize))
       nelm_temp(1) = neqp1
       allocate(istrw_temp(nsize-neqp1))
       allocate(idum1(neq))
       idum1 = 0
       allocate(sx_12(neq,2))
       if(isoy.eq.1) then
        allocate(sx_temp(nr+2*neq,1))
       else
        allocate(sx_temp(nr+2*neq,3))
       endif
       ic = neq
c save original connectivity (and stor file pointer)
        do i = 1,neq_primary
         kbmin = neq
         kbmax = 0
         do jj = nelm(i)+1,nelm(i+1)
          kb = nelm(jj)
          kbmin = min(kbmin,kb)
          kbmax = max(kbmax,kb)
          idum1(kb) = istrw(jj-neqp1)
         enddo
         if(igdpm(i).ne.0) then
c kb_pos is global connection in  + x direction
c kb_neg is global connection in  - x direction
          kb_pos = iconn_gdkm(i,1)
          kb_neg = iconn_gdkm(i,2)
          if(kb_pos.gt.0) then
c since i is a gdpm node  find the +x and -x last gdpm nodes
c to these nodes, a new connection will be added
c i_pos is the last gdpm node attached to node i in the +x direction
c i_pos will connect to kb_pos (or a gdpm node attached to kb_pos)
           i_pos = iconn_gdkm(i,3)
           cord_i_pos = cord(i_pos,1)
           area_i = areat_gdpm(i)
c connection to gdpm nodes should be last one: nelm(kb_pos+1)
c connetion in + x direction
c note different meaning of iconn_gdkm for gdpm nodes
          if(igdpm(kb_pos).ne.0) then
           kb_pos_neg = iconn_gdkm(nelm(kb_pos+1),2)
c find first gdkm node in -x direction
           if(kb_pos_neg.ne.0) then
c identify last gdkm node
            cord_kb_pos_neg = cord(kb_pos_neg,1)
c identify area of secondary material
            area_kb_pos = areat_gdpm(kb_pos)
c primary connection is kb_pos
            idump(i_pos) = kb_pos_neg
            sx_12(i,1) = -((area_i+area_kb_pos)/2.)
     &         /(cord_kb_pos_neg-cord_i_pos)
           endif
          else
c kb_pos has no gdkm nodes- connect to primary nodel
c remember the reciprocal relationship
           idump(i_pos) = kb_pos
           idumn(kb_pos) = i_pos
           sx_12(kb_pos,1) = -(area_i)
     &         /(cord(kb_pos,1)-cord_i_pos)
         endif
         endif
         if(kb_neg.gt.0) then
c since i is a gdpm node  find the +x and -x last gdpm nodes
           i_neg = iconn_gdkm(i,4)
           cord_i_neg = cord(i_neg,1)
           area_i = areat_gdpm(i)
         endif
        endif
       enddo
c now add new connection
c will leave connection from i to kb_pos (may need it later- for stress)
       ii = neqp1
       iww = nr
       if(isoy.eq.1) then
        sx_temp(1:nr,1) = sx(1:nr,1)
       else
        sx_temp(1:nr,1) = sx(1:nr,1)
        sx_temp(1:nr,2) = sx(1:nr,2)
        sx_temp(1:nr,3) = sx(1:nr,3)
       endif
c loop on all nodes
       idum1 = 0
       do i = 1, neq
        kbmin = neq
        kbmax = 0
        i1 = nelm(i)+1
        i2 = nelm(i+1)
        do jj = i1,i2
         kb = nelm(jj)
         kbmin = min(kbmin,kb)
         kbmax = max(kbmax,kb)
         if(kb.ne.i) then
          idum1(kb) = istrw(jj-neqp1)
         else
          idum1(kb) = -1
         endif
        enddo
        if(i.gt.neq_primary.and.idump(i).ne.0) then
         iww = iww + 1
         sx_temp(iww,1) = sx_12(i,1)
         kb = idump(i)
         kbmin = min(kbmin,kb)
         kbmax = max(kbmax,kb)
         idum1(kb) = iww
        endif
        if(i.lt.neq_primary.and.idumn(i).ne.0) then
         iww = iww + 1
         sx_temp(iww,1) = sx_12(i,1)
         kb =  idumn(i)
         kbmin = min(kbmin,kb)
         kbmax = max(kbmax,kb)
         idum1(kb) = iww
        endif
        do kb = kbmin, kbmax
         iw = idum1(kb)
         idum1(kb) = 0
         if(iw.ne.0) then
          ii = ii +1
          nelm_temp(ii)= kb
          istrw_temp(ii-neqp1) = max(iw,0)
          if(kb.eq.i) nelmdg(i) = ii
         endif
        enddo
        nelm_temp(i+1) = ii
       enddo
c copy nelm_temp to nelm
       deallocate(sx,nelm,istrw)
       if(isoy.eq.1)then
        allocate(sx(iww,1))
       else
        allocate(sx(iww,3))
       endif
       allocate(istrw(ii-neqp1))
       allocate(nelm(ii))
       if(isoy.eq.1) then
        sx(1:iww,1) = sx_temp(1:iww,1)
       else
        sx(1:nr,1) = sx_temp(1:nr,1)
        sx(1:nr,2) = sx_temp(1:nr,2)
        sx(1:nr,3) = sx_temp(1:nr,3)
        sx(nr+1:iww,1) = 3.*sx_temp(nr+1:iww,1)
        sx(nr+1:iww,2) = 0.0
        sx(nr+1:iww,2) = 0.0
       endif
       nelm(1:ii) = nelm_temp(1:ii)
       istrw(1:ii-neqp1) = istrw_temp(1:ii-neqp1)
       deallocate(idump,idumn,nelm_temp,istrw_temp,sx_temp)
      neqp1=neq+1
c test of coefficients
       if(iparchek.eq.1) then
       write(ierr,*) 'fe coef. neighbors'
       write(ierr,*)
       do i = 1,neq
        write(ierr,*)' vol node ', i,' = ', sx1(i)
        i1 = nelm(i)+1
        i2 = nelmdg(i)-1
        do j = i1,i2
         kb = nelm(j)
         i3 = nelmdg(kb)+1
         i4 = nelm(kb+1)
         do jj = i3,i4
         if(nelm(jj).eq.i) then
          iw = istrw(jj-neqp1)
          if(iw.gt.0) then
           a11 = sx(iw,isox)+sx(iw,isoy)+sx(iw,isoz)
          else
           a11 = 0.0
          endif
          write(ierr,355)i,kb,iw,a11
          go to 899
         endif
        enddo
899     continue
       enddo
        i1 = nelmdg(i)+1
        i2 = nelm(i+1)
        do j = i1,i2
         kb = nelm(j)
         iw = istrw(j-neqp1)
          if(iw.gt.0) then
           a11 = sx(iw,isox)+sx(iw,isoy)+sx(iw,isoz)
          else
           a11 = 0.0
          endif
         write(ierr,355)i,kb,iw,a11
        enddo
       enddo
355   format(i6,1x,i6,1x,i6,1x,f12.3)
       stop
       endif
       endif
      else if(iflg.eq.3) then
c combine intrinsic permeability with fracture volume
       do i = 1,neq_primary
        imodel= igdpm(i)
c first gdpm node is given last connection of primary node
c check this logic
        kb = nelm(nelm(i+1))
        if(imodel.ne.0) then
          sx1_primary = sx1(i)
	    vfrac = vfrac_primary(imodel)
c multiply pemeabilities by volume fractions
	     pnx(i) = pnx(i)*vfrac
	     pny(i) = pny(i)*vfrac
	     pnz(i) = pnz(i)*vfrac
c save gdkm volume fraction for node
           gdkm_volume_fraction(i) = vfrac
           sx1_total = sx1_primary/vfrac
           do jk = 1, ngdpm_layers(imodel)
            kc = kb+jk-1
            vfrac2 = sx1(kc)/sx1_total
	      pnx(kc) = pnx(kc)*vfrac2
	      pny(kc) = pny(kc)*vfrac2
	      pnz(kc) = pnz(kc)*vfrac2
c save gdkm volume fraction for node
            gdkm_volume_fraction(kc) = vfrac2
           enddo
        endif
       enddo
      else if(iflg.eq.-1) then
       deallocate(iconn_gdkm)
      endif
      return
      end


      SUBROUTINE FORSAV(TIME,DELDIP,IPT,N3,FMATRX, COORD,NVAR,REFH,
     1                  EVECS,JSTART,FCONST)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
      DIMENSION FMATRX(*), DELDIP(3,*), COORD(*), EVECS(*), FCONST(*)
************************************************************************
*
*  FORSAV SAVES AND RESTORES DATA USED IN THE FORCE CALCULATION.
*
* ON INPUT TIME = TOTAL TIME ELAPSED SINCE THE START OF THE CALCULATION.
*          IPT  = LINE OF FORCE MATRIX REACHED, IF IN WRITE MODE,
*               = 0 IF IN READ MODE.
*        FMATRX = FORCE MATRIX
************************************************************************
      COMMON /DENSTY/ P(MPACK), PA(MPACK), PB(MPACK)
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM),
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA,
     2                NCLOSE,NOPEN,NDUMY,FRACT
      OPEN(UNIT=9,FILE='FOR009',STATUS='UNKNOWN',FORM='UNFORMATTED')
      REWIND 9
      OPEN(UNIT=10,FILE='FOR010',STATUS='UNKNOWN',FORM='UNFORMATTED')
      REWIND 10
      IR=9
      IW=9
      IF( IPT .EQ. 0 ) THEN
C
C   READ IN FORCE DATA
C
         READ(IR,END=20,ERR=20)TIME,IPT,REFH
         LINEAR=(NVAR*(NVAR+1))/2
         READ(IR)(COORD(I),I=1,NVAR)
         READ(IR,END=10,ERR=10)(FMATRX(I),I=1,LINEAR)
         READ(IR)((DELDIP(J,I),J=1,3),I=1,IPT)
         N33=NVAR*NVAR
         READ(IR)(EVECS(I),I=1,N33)
         READ(IR)JSTART,(FCONST(I),I=1,NVAR)
         RETURN
      ELSE
C
C    WRITE FORCE DATA
C
         REWIND IW
         IF(TIME.GT.1.D6)TIME=TIME-1.D6
         WRITE(IW)TIME,IPT,REFH
         LINEAR=(NVAR*(NVAR+1))/2
         WRITE(IW)(COORD(I),I=1,NVAR)
         WRITE(IW)(FMATRX(I),I=1,LINEAR)
         WRITE(IW)((DELDIP(J,I),J=1,3),I=1,IPT)
         N33=NVAR*NVAR
         WRITE(IR)(EVECS(I),I=1,N33)
         WRITE(IR)JSTART,(FCONST(I),I=1,NVAR)
         LINEAR=(NORBS*(NORBS+1))/2
         WRITE(10)(PA(I),I=1,LINEAR)
         IF(NALPHA.NE.0)WRITE(10)(PB(I),I=1,LINEAR)
         CLOSE(9)
         CLOSE(10)
      ENDIF
      RETURN
   10 WRITE(6,'(''INSUFFICIENT DATA ON DISK FILES FOR A FORCE '',
     1''CALCULATION'',/10X,''RESTART. PERHAPS THIS STARTED OF AS A '',
     2''FORCE CALCULATION '')')
      WRITE(6,'(10X,''BUT THE GEOMETRY HAD TO BE OPTIMIZED FIRST, '',
     1''IN WHICH CASE '',/10X,''REMOVE THE KEY-WORD "FORCE".'')')
      STOP
   20 WRITE(6,'(//10X,''NO RESTART FILE EXISTS!'')')
      STOP
      END


module soil_methods

use real_precision
use state_methods
use misc_values
use tuning_parameters

implicit none

contains

!**********************************************************************!
!                                                                      !
!                       soil_dynamics2 :: soil_methods                 !
!                       ------------------------------                 !
!                                                                      !
! SUBROUTINE soil_dynamics2(pet,prc,tmp,flow1,flow2,nfix,              !
! nci,sresp,lch,ca,site,year,yr0,yrf,speedc,ft,check_closure)          !
!                                                                      !
!**********************************************************************!
subroutine soil_dynamics2(pet,prc,tmp,flow1,flow2,nfix, &
 nci,sresp,lch,ca,site,year,yr0,yrf,speedc,ft,check_closure)
!**********************************************************************!
real(dp) :: ts,tc,pet,prc,tmp,h2o,flow1,flow2,slnr,rlnr,scl,rcl,ca, &
 nfix,sresp,lch,nci(4),ar,fms,fmr,tm,cal,cap,cas,csp,csa,kr(8),ml,al, &
 c(8),c0(8),n0(8),n(8),slc,rlc,sln,scn,t0,t1,fl(14),minn(3),xft, &
 total_carbon,old_total_carbon,sum
real(dp), dimension(max_cohorts) :: mpet,mprc,mtmp,mh2o,mflow1,mflow2
integer :: ij,yr0,yrf,year,site,ft,i,sddel(max_cohorts),co
logical :: speedc,check_closure
save mpet,mprc,mtmp,mh2o,mflow1,mflow2,sddel
!----------------------------------------------------------------------!

co = ssp%cohort

if ((ssp%iyear == 1).and.(ssp%mnth == 1).and.(ssp%day == 1)) then
  mpet(co) = 0.0
  mprc(co) = 0.0
  mtmp(co) = 0.0
  mh2o(co) = 0.0
  mflow1(co) = 0.0
  mflow2(co) = 0.0
  sddel(co) = 0
  sresp = 0.0
  lch = 0.0
endif

mpet(co) = mpet(co) + pet
mprc(co) = mprc(co) + prc
mtmp(co) = mtmp(co) + tmp
mh2o(co) = mh2o(co) + msv%mv_soilw
mflow1(co) = mflow1(co) + flow1
mflow2(co) = mflow2(co) + flow2
sddel(co) = sddel(co) + 1

if (ssp%day == 30) then
  mpet(co) = mpet(co)/real(sddel(co))*30.0
  mprc(co) = mprc(co)/real(sddel(co))*30.0
  mtmp(co) = mtmp(co)/real(sddel(co))
  mh2o(co) = mh2o(co)/real(sddel(co))
  mflow1(co) = mflow1(co)/real(sddel(co))*30.0
  mflow2(co) = mflow2(co)/real(sddel(co))*30.0

  call SOIL_DYNAMICS(mpet(co),mprc(co),mtmp(co),mh2o(co),mflow1(co),&
 mflow2(co),nfix,nci,sresp,lch,ca,site,year,yr0,yrf,speedc,ft,&
 check_closure)
 sresp = sresp/30.0
 lch = lch/30.0

  mpet(co) = 0.0
  mprc(co) = 0.0
  mtmp(co) = 0.0
  mh2o(co) = 0.0
  mflow1(co) = 0.0
  mflow2(co) = 0.0
  sddel(co) = 0
endif

!**********************************************************************!
end subroutine soil_dynamics2
!**********************************************************************!

!**********************************************************************!
!                                                                      !
!                       soil_dynamics :: soil_methods                  !
!                       ------------------------------                 !
!                                                                      !
! SUBROUTINE soil_dynamics(avmnpet,avmnppt,avmnt,h2o,flow1,flow2,nfix, !
! nci,srespm,lchm,ca,site,year,yr0,yrf,speedc,ft,check_closure)        !
!                                                                      !
!**********************************************************************!
subroutine soil_dynamics(avmnpet,avmnppt,avmnt,h2o,flow1,flow2,nfix, &
 nci,srespm,lchm,ca,site,year,yr0,yrf,speedc,ft,check_closure)
!**********************************************************************!
real(dp) :: ts,tc,avmnpet,avmnppt,avmnt,h2o,flow1,flow2,slnr,rlnr,scl,&
 rcl,ca,nfix,srespm,lchm,nci(4),ar,fms,fmr,tm,cal,cap,cas,csp,csa,&
 kr(8),ml,al,c(8),c0(8),n0(8),n(8),slc,rlc,sln,scn,t0,t1,fl(14),&
 minn(3),xft,total_carbon,old_total_carbon,sum
integer :: ij,yr0,yrf,year,site,ft,i
logical :: speedc,check_closure
!----------------------------------------------------------------------!

!----------------------------------------------------------------------!
! Check carbon closure.
!----------------------------------------------------------------------!
  if (check_closure) call SUM_CARBON(old_total_carbon,.false.)
!----------------------------------------------------------------------!

ts = ssp%sand
tc = ssp%clay

slc = ssv(ft)%slc*12.0/ssv(ft)%cov
rlc = ssv(ft)%rlc*12.0/ssv(ft)%cov
sln = ssv(ft)%sln*12.0/ssv(ft)%cov

ssv(ft)%slc = 0.0
ssv(ft)%rlc = 0.0
ssv(ft)%sln = 0.0

sum = 0.0
do i=1,8
  sum = sum + ssv(ft)%c(i)
  c0(i) = ssv(ft)%c(i)
  n0(i) = ssv(ft)%n(i)
enddo
sum = sum + slc/12.0 + rlc/12.0

do i=1,3
  minn(i) = ssv(ft)%minn(i)
enddo

!----------------------------------------------------------------------!
! Calculate lignin to nitrogen ratios based on the C02 concentration.  !
!----------------------------------------------------------------------!
slnr = 0.18*ca + 2.7
rlnr = 0.18*ca + 2.7

scl = 0.12   ! Fractions of surface carbon that are lignin.
rcl = 0.35   ! Fractions of root carbon that are lignin.

if (slc*sln>1e-6) then
  scn = slc/sln ! Ratio of surface carbon to nitrogen.
else
  scn = 10.0
endif

!----------------------------------------------------------------------!
! Compute monthly accumulation of values required by century.          !
!----------------------------------------------------------------------!
call SETCENPAR(ts,tc,avmnpet,avmnppt,avmnt,h2o,flow2,slnr, &
 rlnr,ar,fms,fmr,scl,rcl,tm,xft,cal,cap,cas,csp,csa,kr)

!----------------------------------------------------------------------!
! Using century model compute the new carbon and nitrogen pools.       !
!----------------------------------------------------------------------!

t0 = 0.0
t1 = 1.0/12.0
srespm = 0.0
lchm = 0.0

if (c0(1)+c0(2)+c0(3)+c0(4)+c0(5)+c0(6)+c0(7)+c0(8)>1000.0) then
  call CDYN(c0,c,t0,t1,slc,rlc,scl,rcl,kr,csa,cas,csp,cap, &
 cal,fms,fmr,xft,srespm,lchm,year,yr0,yrf,speedc)

  call FLOWS(c0,c,t0,t1,fl,slc,rlc,scl,rcl,fms,fmr,csa,csp,cas,cap)

  call NDYN(n0,n,minn,t0,t1,fl,c,flow1,flow2,ts,ml,al,scn,nfix,cal,nci,site)

  if (srespm<0.0) then
    write(*,*) 'Error: soil respiration negative'
    write(*,'(''c : '',8f8.0)') c0
    write(*,'(''slc rlc scl rcl : '',4f8.3)') slc,rlc,scl,rcl
    stop
  endif

else

  do ij=1,8
    c(ij) = c0(ij)
    n(ij) = n0(ij)
  enddo

  c(1) = c(1) + (1.0 - fms)*slc/12.0
  c(2) = c(2) + (1.0 - fmr)*rlc/12.0
  c(5) = c(5) + fms*slc/12.0
  c(6) = c(6) + fmr*rlc/12.0

  srespm = 0.0
  lchm = 0.0

endif

!CALL SOILCLOSS(c0,soilcl,scl,kr,rcl,xft,cal)

do i=1,8
  sum = sum - c(i)
  ssv(ft)%c(i) = c(i)
  ssv(ft)%n(i) = n(i)
enddo

do i=1,3
  ssv(ft)%minn(i) = minn(i)
enddo

!----------------------------------------------------------------------!
! Check carbon closure.
!----------------------------------------------------------------------!
if (check_closure) then
  call SUM_CARBON(total_carbon,.false.)
  if (abs(total_carbon-old_total_carbon+(srespm+lchm)*ssv(ft)%cov) > &
 1.0e-1) then
    write(*,*) 'Breach of carbon closure in DOLYMONTH:',&
 total_carbon+(srespm+lchm)*ssv(ft)%cov-old_total_carbon,' g/m^2.'
    write(*,*) &
 total_carbon,srespm*ssv(ft)%cov,lchm*ssv(ft)%cov,old_total_carbon
    stop
  endif
endif

!**********************************************************************!
end subroutine soil_dynamics
!**********************************************************************!

!**********************************************************************!
!                                                                      !
!                       fcap :: soil_methods                           !
!                       --------------------                           !
!                                                                      !
! FCAP computes the field capacities and the wilting points of the     !
! soil layers, from the soil sand and clay contents.                   !
!                                                                      !
! subroutine fcap(ts,tc,adp,sfc,sw)                                    !
!                                                                      !
!**********************************************************************!
subroutine fcap(ts,tc,adp,sfc,sw)
real(dp) :: ts,tc,adp(4),sfc(4),sw(4),t1,t2,t3,t4,t5,t6,t7,t8,t9,t10,&
 t11,t12,t13,t14,t15,x,y,class(12)
!**********************************************************************!
integer sumx
!----------------------------------------------------------------------!

x=ts*100.00
y=tc*100.00

t1 = x - 44.32
t2 = y - 39.33
t3 = y + x - 59.55
if ((t3>=0.0).and.(t2>=0.0).and.(t1<=0.0)) then
  sumx = 1
else
  t4 = y - 34.83
  if ((t1>=0.0).and.(t4>=0.0)) then
  sumx = 5
  else
    if (t2>=0.0) then
      sumx = 2
    else
      t10 = y - 19.78
      t15 = y + x - 71.78
      if ((t15>=0.0).and.(t10>=0.0).and.(t1>=0.0)) then
        sumx = 6
      else
        t5 = y - 26.97
        t6 = x - 21.59
        if ((t5>=0.0).and.(t6>=0.0)) then
          sumx = 4
        else
          if (t5>=0.0) then
            sumx = 3
          else
            t7 = y + x - 50.00
            t11 = x - 52.27
            t12 = y - 7.87
            if ((t7>=0.0).and.(t12>=0.0).and.(t11<=0.0)) then
              sumx = 7
            else
              t13 = y - 0.98*x + 69.04
              if ((t7>=0.0).and.(t13>=0.0)) then
                sumx = 12
              else
                t14 = y - 2.31*x + 197.92
                if ((t13<=0.0).and.(t14>=0.0)) then
                  sumx = 10
                else
                  if (t14<=0.0) then
                    sumx = 11
                  else
                    t8 = y + x - 20.00
                    t9 = y - 10.00
                    if ((t9>=0.0).or.(t8>=0.0)) then
                      sumx = 8
                    else
                      sumx = 9
                    endif
                  endif
                endif
              endif
            endif
          endif
        endif
      endif
    endif
  endif
endif

class(1) = 0.468      ! Clay
class(2) = 0.468      ! Silty Clay
class(3) = 0.464      ! Silty Clay Loam
class(4) = 0.465      ! Clay Loam
class(5) = 0.406      ! Sandy Clay
class(6) = 0.404      ! Sandy Clay Loam
class(7) = 0.439      ! Loam
class(8) = 0.476      ! Silty loam
class(9) = 0.476      ! Silt
class(10) = 0.421     ! Loamy Sand
class(11) = 0.339     ! Sand
class(12) = 0.434     ! Sandy Loam

sfc(1) = class(sumx)*adp(1)*1.0
sfc(2) = class(sumx)*(adp(2) - adp(1))*1.0
sfc(3) = class(sumx)*(adp(3) - adp(2))*1.0
sfc(4) = class(sumx)*(adp(4) - adp(3))*1.0
sw(1) = 10.0
sw(2) = 10.0
sw(3) = 10.0
sw(4) = 10.0

!**********************************************************************!
end subroutine fcap
!**********************************************************************!

!**********************************************************************!
!                                                                      !
!                        setcenpar :: soil_methods                     !
!                        -------------------------                     !
!                                                                      !
! SETCENPAR sets the century parameters.                               !
!                                                                      !
! subroutine setcenpar(ts,tc,pet,ppt,tmp,h2o,flow2,slnr,rlnr,ar,fms,   !
! fmr,scl,rcl,tm,ft,cal,cap,cas,csp,csa,kr)                            !
!                                                                      !
!                                                                      !
!**********************************************************************!
subroutine setcenpar(ts,tc,pet,ppt,tmp,h2o,flow2,slnr,rlnr,ar,fms, &
 fmr,scl,rcl,tm,ft,cal,cap,cas,csp,csa,kr)
!**********************************************************************!
real(dp) :: ts,tc,pet,ppt,tmp,h2o,flow2,slnr,rlnr,ar,fms,fmr,scl,rcl,&
 tm,ft,cal,cap,cas,csp,csa,kr(8),smois,lcs,lcr,t
!----------------------------------------------------------------------!
! ppt and pet are monthly totals

if (pet>0.0) then
  smois = (h2o + ppt*1.0)/pet*0.2
else
  smois = 1000.0
endif
ar =-eow(smois)*eot(tmp)
if (tmp<0.0) ar = 0.0

fms = 0.85 - 0.018*slnr
fmr = 0.85 - 0.018*rlnr

if (fms<0.001)  fms = 0.001
if (fmr<0.001)  fmr = 0.001

lcs = exp(-3.0*scl)
lcr = exp(-3.0*rcl)

t = 1.0 - ts/100.0
tm = (1.0 - 0.75*t)

ft = 0.85 - 0.68*t
cal = (flow2/18.0)*(0.01 + 0.04*ts/100.0)
cap = 0.003 + 0.032*tc/100.0
cas = (1.0 - cap - cal - ft)

csp = 0.003 - 0.009*tc/100.0
csa = 1.0 - csp - 0.55

kr(1) = 3.9*ar*lcs*tgp%p_kscale
kr(2) = 4.8*ar*lcr*tgp%p_kscale
kr(3) = 7.3*ar*tm*tgp%p_kscale
kr(4) = 6.0*ar*tgp%p_kscale
kr(5) = 14.8*ar*tgp%p_kscale
kr(6) = 18.5*ar*tgp%p_kscale
kr(7) = 0.2*ar*tgp%p_kscale
kr(8) = 0.0045*ar*tgp%p_kscale

!**********************************************************************!
end subroutine setcenpar
!**********************************************************************!

!**********************************************************************!
!                                                                      !
!                       soilcloss :: soil_methods                      !
!                       -------------------------                      !
!                                                                      !
! SOILCLOSS calculates carbon losses in the soil due to resperation    !
! and leaching, given the soil carbon pool values.                     !
!                                                                      !
! subroutine soilcloss(c,tot,scl,kr,rcl,ft,cal)                        !
!                                                                      !
!**********************************************************************!
subroutine soilcloss(c,tot,scl,kr,rcl,ft,cal)
!**********************************************************************!
implicit none
real(dp) :: c(8),tot,scl,kr(8),rcl,ft,cal
!----------------------------------------------------------------------!

tot = -0.3*scl*kr(1)*c(1) - 0.6*(1.0 - scl)*kr(1)*c(1) - &
 0.55*(1 - rcl)*kr(2)*c(2) - 0.3*rcl*kr(2)*c(2) - &
 0.6*kr(5)*c(5) - 0.55*kr(6)*c(6) - 0.6*kr(4)*c(4) - &
 0.55*kr(7)*c(7) - 0.55*kr(8)*c(8) - ft*kr(3)*c(3) - cal*kr(3)*c(3)

!**********************************************************************!
end subroutine soilcloss
!**********************************************************************!

!**********************************************************************!
!                                                                      !
!                        cdyn :: soil_methods                          !
!                        --------------------                          !
!                                                                      !
! Uses the NAG routine 2EBF to solve the differential equaitons        !
! given by the carbon dynamics.                                        !
!                                                                      !
! subroutine cdyn(c0,c1,t0,t1,slc,rlc,scl,rcl,kr,csa,cas,csp,cap,      !
! cal,fms,fmr,ft,sresp,lch,year,yr0,yrf,speedc)                        !
!                                                                      !
!**********************************************************************!
subroutine cdyn(c0,c1,t0,t1,slc,rlc,scl,rcl,kr,csa,cas,csp,cap, &
 cal,fms,fmr,ft,sresp,lch,year,yr0,yrf,speedc)
!**********************************************************************!
real(dp) :: c0(8),c1(8),t0,t1,slc,rlc,scl,rcl,kr(8),csa,cas,csp,cap, &
 cal,fms,fmr,sresp,lch,t01,t11,cp(10),cjac(10,10),ft,sc(8)
real(dp) :: cslc,crlc,cscl,crcl,ckr(8),ccsa,ccas,ccsp,ccap,ccal,cfms,&
 cfmr,cft
integer :: i,year,yrf,yr0,j
logical :: speedc
common /cder/cslc,crlc,cscl,crcl,ckr,ccsa,ccas,ccsp,ccap,ccal,cfms,&
 cfmr,cft
!----------------------------------------------------------------------!

cslc = slc
crlc = rlc
cscl = scl
crcl = rcl
ccsa = csa
ccas = cas
ccsp = csp
ccap = cap
ccal = cal
cfms = fms
cfmr = fmr
cft = ft
do i=1,8
  c1(i)=c0(i)
  ckr(i) = kr(i)
enddo

t01 = t0
t11 = t1

call DER(c1,cp)
call PDER(cjac)

if (speedc) then
  sc(7) = 10.0*1.0
  sc(8) = 500.0*1.0
  cp(7) = cp(7)*sc(7)
  cp(8) = cp(8)*sc(8)
  do i=1,10
    do j=7,8
      cjac(j,i) = cjac(j,i)*(sc(j) - (sc(j) - 1.0)/ &
 real(yrf - yr0 + 1)*real(year - yr0 + 1))
    enddo
  enddo
endif

call diffeq(t01,t11,c1,cp,cjac,sresp,lch)

!**********************************************************************!
end subroutine cdyn
!**********************************************************************!

!**********************************************************************!
!                                                                      !
!                        diffeq :: soil_methods                        !
!                        ----------------------                        !
!                                                                      !
! Gives the Jacobean corresponding to the differential carbon          !
! equations.                                                           !
!                                                                      !
! subroutine diffeq(t01,t11,c1,cp,cjac,sresp,lch)                      !
!                                                                      !
!**********************************************************************!
subroutine diffeq(t01,t11,c1,cp,cjac,sresp,lch)
!**********************************************************************!
real(dp) :: t01,t11,c1(8),cp(10),cjac(10,10),secder(10),delt,sresp,lch
integer  :: i,j
!----------------------------------------------------------------------!

delt = t11 - t01

do i=1,8
  secder(i) = 0.0
  do j=1,8
    secder(i) = secder(i) + cjac(i,j)*cp(j)
  enddo
  c1(i) = c1(i) + cp(i)*delt + secder(i)*delt**2.0/2.0
enddo

secder(9) = 0.0
secder(10) = 0.0
do j=1,10
  secder(9) = secder(9) + cjac(9,j)*cp(j)
  secder(10) = secder(10) + cjac(10,j)*cp(j)
enddo
sresp = sresp + cp(9)*delt + secder(9)*delt**2.0/2.0
lch = lch + cp(10)*delt + secder(10)*delt**2.0/2.0

!**********************************************************************!
end subroutine diffeq
!**********************************************************************!

!**********************************************************************!
!                                                                      !
!                         der :: soil_methods                          !
!                         -------------------                          !
!                                                                      !
! Returns the carbon derivative calculated from the carbon state.      !
!                                                                      !
! subroutine der(c,f)                                                  !
!                                                                      !
!**********************************************************************!
subroutine der(c,f)
!**********************************************************************!
implicit none
real(dp) :: c(8),f(10)
real(dp) :: cslc,crlc,cscl,crcl,ckr(8),ccsa,ccas,ccsp,ccap,ccal,cfms,&
 cfmr,cft
common /cder/cslc,crlc,cscl,crcl,ckr,ccsa,ccas,ccsp,ccap,ccal,cfms,&
 cfmr,cft
!----------------------------------------------------------------------!

f(1) = cslc*(1.0 - cfms) + ckr(1)*c(1)
f(2) = crlc*(1.0 - cfmr) + ckr(2)*c(2)
f(3) =-0.45*(1.0 - crcl)*ckr(2)*c(2) - 0.45*ckr(6)*c(6) - &
 0.45*ckr(8)*c(8) - ckr(7)*c(7)*ccsa + ckr(3)*c(3)
f(4) =-0.4*(1.0 - cscl)*ckr(1)*c(1) - 0.4*ckr(5)*c(5) + &
 ckr(4)*c(4)
f(5) = cslc*cfms + ckr(5)*c(5)
f(6) = crlc*cfmr + ckr(6)*c(6)
f(7) =-0.7*cscl*ckr(1)*c(1) - 0.4*ckr(4)*c(4) - &
 0.7*crcl*ckr(2)*c(2) - ckr(3)*c(3)*ccas + ckr(7)*c(7)
f(8) =-ckr(3)*c(3)*ccap - ckr(7)*c(7)*ccsp + ckr(8)*c(8)
f(9) =-(0.6-0.3*cscl)*ckr(1)*c(1) - (0.55-0.25*crcl)*ckr(2)*c(2) - &
 cft*ckr(3)*c(3) - 0.6*ckr(4)*c(4) - 0.6*ckr(5)*c(5) - &
 0.55*ckr(6)*c(6) - 0.55*ckr(7)*c(7) - 0.55*ckr(8)*c(8)
f(10) = -ckr(3)*c(3)*ccal

!**********************************************************************!
end subroutine der
!**********************************************************************!

!**********************************************************************!
!                                                                      !
!                          pder :: soil_methods                        !
!                          --------------------                        !
!                                                                      !
! PDER gives the Jacobean corresponding to the differential carbon     !
! equations.                                                           !
!                                                                      !
! subroutine pder(jac)                                                 !
!                                                                      !
!**********************************************************************!
subroutine pder(jac)
!**********************************************************************!
real(dp) :: jac(10,10)
integer i,j
real(dp) :: cslc,crlc,cscl,crcl,ckr(8),ccsa,ccas,ccsp,ccap,ccal,cfms,&
 cfmr,cft
common /cder/cslc,crlc,cscl,crcl,ckr,ccsa,ccas,ccsp,ccap,ccal,cfms,&
 cfmr,cft
!----------------------------------------------------------------------!

do i=1,10
  do j=1,10
    jac(i,j) = 0.0
  enddo
enddo
jac(1,1) = ckr(1)
jac(2,2) = ckr(2)
jac(3,2) =-0.45*(1.0 - crcl)*ckr(2)
jac(3,3) = ckr(3)
jac(3,6) =-0.45*ckr(6)
jac(3,7) =-ccsa*ckr(7)
jac(3,8) =-0.45*ckr(8)
jac(4,1) =-0.4*(1.0 - cscl)*ckr(1)
jac(4,4) = ckr(4)
jac(4,5) =-0.4*ckr(5)
jac(5,5) = ckr(5)
jac(6,6) = ckr(6)
jac(7,1) =-0.7*cscl*ckr(1)
jac(7,2) =-0.7*crcl*ckr(2)
jac(7,3) =-ccas*ckr(3)
jac(7,4) =-0.4*ckr(4)
jac(7,7) = ckr(7)
jac(8,3) =-ccap*ckr(3)
jac(8,7) =-ccsp*ckr(7)
jac(8,8) = ckr(8)
jac(9,1) =-(0.6 - 0.3*cscl)*ckr(1)
jac(9,2) =-(0.55 - 0.25*crcl)*ckr(2)
jac(9,3) =-cft*ckr(3)
jac(9,4) =-0.6*ckr(4)
jac(9,5) =-0.6*ckr(5)
jac(9,6) =-0.55*ckr(6)
jac(9,7) =-0.55*ckr(7)
jac(9,8) =-0.55*ckr(8)
jac(9,9) = 0.0
jac(10,3) = -ckr(3)*ccal

!**********************************************************************!
end subroutine pder
!**********************************************************************!

!**********************************************************************!
!                                                                      !
!                        clsasi :: soil_methods                        !
!                        ----------------------                        !
!                                                                      !
! This subroutine returns the persentages of soil clay sand and silt.  !
! These are estimated from the soil classification on the islscp data  !
! file 'soltex'. This results in the folowing classifications:         !
!                                                                      !
!        ISLSCP Index      Clay  Sand  Silt       Comments             !
!              1             7    80    13        loamy sand           !
!              2            12    62    26        sandy loam           !
!              3            18    42    40        loam                 !
!              4            27    63    10        sandy clay loam      !
!              5            30    35    35        clay loam            !
!              6             0     0     0        ice                  !
!              7            18    42    40        loam                 !
!              0             0     0     0        ocean                !
!                                                                      !
! subroutine clsasi(tex,tc,ts,tsi)                                     !
!                                                                      !
!**********************************************************************!
subroutine clsasi(tex,tc,ts,tsi)
!**********************************************************************!
real(dp) :: tc,ts,tsi
integer :: tex
!----------------------------------------------------------------------!

if ((tex==0).or.(tex==6)) then
  tc = 0.0
  ts = 0.0
  tsi = 0.0
else
  if (tex==1) then
    tc = 7.0
    ts = 80.0
  elseif (tex==2) then
    tc = 12.0
    ts = 62.0
  elseif (tex==3) then
    tc = 18.0
    ts = 42.0
  elseif (tex==4) then
    tc = 27.0
    ts = 63.0
  elseif (tex==5) then
    tc = 30.0
    ts = 35.0
  elseif (tex==7) then
    tc = 18.0
    ts = 42.0
  endif
  tsi = 100.0 - tc -ts
endif

!**********************************************************************!
end subroutine clsasi
!**********************************************************************!

!**********************************************************************!
!                                                                      !
!                         ndyn :: soil_methods                         !
!                         --------------------                         !
!                                                                      !
! Calculate nitrogen dynamics from the carbon dynamics and the carbon  !
! flows calculated using FLOWS.                                        !
!                                                                      !
! subroutine ndyn(n0,n,minn,t0,t1,fl,c,flow1,flow2,ts,ml,al,scn,nfix,  !
! cal,nci,site)                                                        !
!                                                                      !
!----------------------------------------------------------------------!
subroutine ndyn(n0,n,minn,t0,t1,fl,c,flow1,flow2,ts,ml,al,scn,nfix,cal,&
 nci,site)
!**********************************************************************!
real(dp) :: n0(8),n(8),minn(3),t0,t1,fl(14),c(8),flow1,flow2,ts,ml,al,&
 scn,nfix,cal,nci(4),ncsm,nca,ncs,ncp,soiln,plantn,delt,x,totn, &
 ratminn,f1,f2,nin,az,bz,cz,dz,ez,fz,gz,hz,iz
integer i,site
!----------------------------------------------------------------------!

delt = t1 - t0
soiln = minn(3)
plantn = 100.0/(scn + 1.0)
!...check whether 'scn' is correct, 'scn' = surface carbon/surface
! nitrogen, should this be litter carbon/litter nitrogen.

nca = 1.0/ncrata(soiln)

do i=1,8
  n(i)=n0(i)
enddo

!----------------------------------------------------------------------!
! Find mineral nitrogen leaching due to the water flows between the    !
! soil layers.                                                         !
!----------------------------------------------------------------------!
!      ml = minn(2)*flow2*delt*(0.2 + 0.7*ts/100.0)/18.0
!      minn(2) = minn(2) - ml
!      IF (minn(1).GT.0.0) THEN
!        temp = minn(1)*flow1*delt*(0.2 + 0.7*ts/100.0)/18.0
!        minn(1) = minn(1) - temp
!        minn(2) = minn(2) + temp
!      ENDIF

!      minn(1) = minn(1) + nfix*delt + (1.0 - nup)*(sln + rln)*delt

if (flow1<1.0e-10) flow1 = 0.0
if (flow2<1.0e-10) flow2 = 0.0

f1 = flow1*(0.2 + 0.7*ts/100.0)/18.0
f2 = flow2*(0.2 + 0.7*ts/100.0)/18.0
nin = nfix
if (abs(f1-f2)<1.0e-6) then
  f2 = f2 - 0.001
endif

if (flow1>0.0) then
  bz = nin/f1
  az = minn(1) - bz
  minn(1) = az*exp(-f1*delt) + bz
  if (flow2>0.0) then
    dz = f1*az/(f2 - f1)
    ez = f1*bz/f2
    cz = minn(2) - dz - ez
    minn(2) = cz*exp(-f2*delt) + dz*exp(-f1*delt) + ez
    fz = -cz
    gz = -dz*f2/f1
    hz = f2*ez
    iz = -fz - gz
    ml = fz*exp(-f2*delt) + gz*exp(-f1*delt) + hz*delt + iz
  else
    cz = -az
    dz = f1*bz
    ez = minn(2) - cz
    minn(2) = cz*exp(-f1*delt) + dz*delt + ez
    fz = -cz*f2/f1
    gz = f2*dz/2.0
    hz = f2*ez
    iz =-fz
    ml = fz*exp(-f1*delt) + gz*delt**2.0 + hz*delt + iz
  endif
else
  if (flow2>0.0) then
    minn(1) = nfix*delt + minn(1)
    cz = minn(2)
    minn(2) = cz*exp(-f2*delt)
    ml = -cz*exp(-f2*delt) + cz
  else
    minn(1) = nfix*delt + minn(1)
    minn(2) = minn(2)
  endif
endif

if (.not.(minn(2)<10000.0))  &
 write(11,'(''minn(2) > 10000, '',i5,7f12.4)') &
 site,minn(2),cz,f2,dz,f1,ez,delt

if (minn(3)<2.0) then
  al = fl(12)*cal/(15.0 - 6.0*minn(3))
else
  al = fl(12)*cal/3.0
endif

!----------------------------------------------------------------------!
! Calculate total nitrogen and then find how much of that is mineral.  !
!----------------------------------------------------------------------!
totn = minn(1)+minn(2)+n(1)+n(2)+n(3)+n(4)+n(5)+n(6)+n(7)+n(8)-al

if (.not.(minn(1)<10000.0))  &
 write(11,'(''minn(1) > 10000, '',i5,4f12.4)') &
 site,flow1,flow2,minn(1),minn(2)

call NBAL(c,totn,x,scn,nci)
if (.not.(minn(1)<10000.0)) &
 write(11,'(''minn(1) > 10000, '',i5,4f12.4)') &
 site,flow1,flow2,minn(1),minn(2)

!----------------------------------------------------------------------!
! Adjust all nitrogen pools accordingly.                               !
!----------------------------------------------------------------------!
if (minn(2)>0.0) then
  ratminn = minn(1)/minn(2)
  minn(1) = x/(1.0 + 1.0/ratminn)
  minn(2) = x/(1.0 + ratminn)
  minn(3) = x
else
  minn(1) = x
  minn(2) = 0.0
  minn(3) = x
endif

if (.not.(minn(1)<10000.0)) &
 write(11,'(''minn(1) > 10000, '',i5,6f12.4)') &
 site,flow1,flow2,minn(1),minn(2),x,ratminn

ncsm = 1.0/ncratsm(plantn)
nca = 1.0/ncrata(x)
ncs = 1.0/ncrats(x)
ncp = 1.0/ncratp(x)

n(1) = c(1)*nci(1)
n(5) = c(5)*nci(2)
n(2) = c(2)*nci(3)
n(6) = c(6)*nci(4)
n(4) = ncsm*c(4)
n(8) = ncp*c(8)
n(7) = ncs*c(7)
n(3) = nca*c(3)

!**********************************************************************!
end subroutine ndyn
!**********************************************************************!

!**********************************************************************!
!                                                                      !
!                        nbal :: soil_methods                          !
!                        --------------------                          !
!                                                                      !
! Computes the mineral nitrogen pool, given the value of the           !
! total nitrogen content of the soil. To do this a quartic equation    !
! needs to be solved, this is done using the Newton Raphson method.    !
!                                                                      !
! subroutine nbal(c,tn,x,scn,nci)                                      !
!                                                                      !
!**********************************************************************!
subroutine nbal(c,tn,x,scn,nci)
!**********************************************************************!
real(dp) :: c(8),tn,x,scn,nci(4),const,ncsm,plantn,fx0,fx05,fx1,fx15,&
 fx2,b,at
integer :: i
!----------------------------------------------------------------------!

plantn = 100.0/(scn + 1.0)
ncsm = 1.0/ncratsm(plantn)

const = tn - c(1)*nci(1) - c(5)*nci(2) - c(2)*nci(3) - c(6)*nci(4) - &
 c(4)*ncsm

!      cx1 =-7.2
!      cx2 = 102.0 + 7.2*const
!      cx3 = 4.8*c(8) + 1.8*c(7) + 1.2*c(3) - 450.0 - 102.0*const
!      cx4 =-36.0*c(8) - 16.5*c(7) - 14.0*c(3) + 600.0 + 450.0*const
!      cx5 = 60.0*c(8) + 30.0*c(7)  + 40.0*c(3) - 600.0*const

x=0.0
fx0 = 60.0*c(8) - 36.0*c(8)*x + 4.8*c(8)*x**2 + 30.0*c(7) - &
 16.5*c(7)*x +1.8*c(7)*x**2 + 40.0*c(3) - 14.0*c(3)*x + &
 1.2*c(3)*x**2 + 600.0*x - 450.0*x**2 + 102.0*x**3 - 7.2*x**4 - &
 600.0*const + 450.0*const*x - 102.0*const*x**2 + 7.2*const*x**3
x=0.5
 fx05 = 60.0*c(8) - 36.0*c(8)*x + 4.8*c(8)*x**2 + 30.0*c(7) - &
 16.5*c(7)*x +1.8*c(7)*x**2 + 40.0*c(3) - 14.0*c(3)*x + &
 1.2*c(3)*x**2 + 600.0*x - 450.0*x**2 + 102.0*x**3 - 7.2*x**4 - &
 600.0*const + 450.0*const*x - 102.0*const*x**2 + 7.2*const*x**3
x=1.0
 fx1 = 60.0*c(8) - 36.0*c(8)*x + 4.8*c(8)*x**2 + 30.0*c(7) - &
 16.5*c(7)*x +1.8*c(7)*x**2 + 40.0*c(3) - 14.0*c(3)*x + &
 1.2*c(3)*x**2 + 600.0*x - 450.0*x**2 + 102.0*x**3 - 7.2*x**4 - &
 600.0*const + 450.0*const*x - 102.0*const*x**2 + 7.2*const*x**3
x=1.5
 fx15 = 60.0*c(8) - 36.0*c(8)*x + 4.8*c(8)*x**2 + 30.0*c(7) - &
 16.5*c(7)*x +1.8*c(7)*x**2 + 40.0*c(3) - 14.0*c(3)*x + &
 1.2*c(3)*x**2 + 600.0*x - 450.0*x**2 + 102.0*x**3 - 7.2*x**4 - &
 600.0*const + 450.0*const*x - 102.0*const*x**2 + 7.2*const*x**3
x=2.0
 fx2 = 60.0*c(8) - 36.0*c(8)*x + 4.8*c(8)*x**2 + 30.0*c(7) - &
 16.5*c(7)*x +1.8*c(7)*x**2 + 40.0*c(3) - 14.0*c(3)*x + &
 1.2*c(3)*x**2 + 600.0*x - 450.0*x**2 + 102.0*x**3 - 7.2*x**4 - &
 600.0*const + 450.0*const*x - 102.0*const*x**2 + 7.2*const*x**3

if ((fx0<0.0).and.(fx2>0.0)) then
  if (fx15<0.0) then
    x = 0.5*fx15/(fx15 - fx2) + 1.5
  elseif (fx1<0.0) then
    x = 0.5*fx1/(fx1 - fx15) + 1.0
  elseif (fx05<0.0) then
    x = 0.5*fx05/(fx05 - fx1) + 0.5
  else
    x = 0.5*fx0/(fx0 - fx05)
  endif
  do i=1,4
    at = 60.0*c(8) - 36.0*c(8)*x + 4.8*c(8)*x**2 + &
 30.0*c(7) - 16.5*c(7)*x +1.8*c(7)*x**2 + 40.0*c(3) - &
 14.0*c(3)*x + 1.2*c(3)*x**2 + 600.0*x - 450.0*x**2 + &
 102.0*x**3 - 7.2*x**4 - 600.0*const + 450.0*const*x - &
 102.0*const*x**2 + 7.2*const*x**3
  b =-36.0*c(8) + 9.6*c(8)*x - 16.5*c(7) + 3.6*c(7)*x - &
 14.0*c(3) + 2.4*c(3)*x + 600.0 - 900.0*x + 306.0*x**2 - &
 28.8*x**3 + 450.0*const - 204.0*const*x + 21.6*const*x**2
  x = x - at/b
  enddo
else if ((fx0>0.0).and.(fx2>0.0)) then
  x = 0.0
else if ((fx0<0.0).and.(fx2<0.0)) then
  x = const - c(3)/3.0 - c(7)/12.0 - c(8)/7.0
endif

!**********************************************************************!
end subroutine nbal
!**********************************************************************!

!**********************************************************************!
!                                                                      !
!                        flows :: soil_methods                         !
!                        ---------------------                         !
!                                                                      !
! Computes the fourteen carbon flows associated with the carbon        !
! dynamics.                                                            !
!                                                                      !
! subroutine flows(c0,c,t0,t1,fl,slc,rlc,scl,rcl,fms,fmr,csa,csp,cas,  !
! cap)                                                                 !
!                                                                      !
!**********************************************************************!
subroutine flows(c0,c,t0,t1,fl,slc,rlc,scl,rcl,fms,fmr,csa,csp,cas,cap)
!**********************************************************************!
real(dp) :: c0(8),c(8),t0,t1,fl(14),slc,rlc,scl,rcl,fms,fmr,csa,csp,&
 cas,cap,delt
!----------------------------------------------------------------------!

delt = t1 - t0

fl(1) = slc*(1.0 - fms)*delt
fl(2) = slc*fms*delt
fl(7) = rlc*(1.0 - fmr)*delt
fl(8) = rlc*fmr*delt
fl(3) = (c0(1) - c(1) + fl(1))*scl
fl(4) = (c0(1) - c(1) + fl(1))*(1.0 - scl)
fl(5) = c0(5) - c(5) + fl(2)
fl(9) = (c0(2) - c(2) + fl(7))*rcl
fl(10) = (c0(2) - c(2) + fl(7))*(1.0 - rcl)
fl(11) = c0(6) - c(6) + fl(8)
fl(6) = c0(4) - c(4) + 0.4*fl(4) + 0.4*fl(5)

!----------------------------------------------------------------------!
! Solve three simultaneous equations to find fl(12),fl(13) and fl(14). !
!----------------------------------------------------------------------!
fl(12) = (c0(3) - c(3) + 0.45*fl(10) + 0.45*fl(11) + &
 csa*(c0(7) - c(7) + 0.7*fl(3) + 0.4*fl(6) + 0.7*fl(9)) + &
 0.45*(c0(8) - c(8) + csp*(c0(7) - c(7) + 0.7*fl(3) + &
 0.4*fl(6) + 0.7*fl(9))))/(1.0 - csa*cas - 0.45*csp*cas - 0.45*cap)
fl(13) = c0(7) - c(7) + 0.7*fl(3) + 0.4*fl(6) + 0.7*fl(9) + cas*fl(12)
fl(14) = c0(8) - c(8) + csp*fl(13) + cap*fl(12)

!     WRITE(*,*) 'c1',c(1)-c0(1),fl(1)-fl(3)-fl(4)
!     WRITE(*,*) 'c2',c(2)-c0(2),fl(7)-fl(9)-fl(10)
!     WRITE(*,*) 'c3',c(3)-c0(3),fl(13)*csa+fl(10)*.45+fl(11)*.45+
!   & fl(14)*.45-fl(12)
!     WRITE(*,*) 'c4',c(4)-c0(4),.4*fl(4)+.4*fl(5)-fl(6)
!     WRITE(*,*) 'c5',c(5)-c0(5),fl(2)-fl(5)
!     WRITE(*,*) 'c6',c(6)-c0(6),fl(8)-fl(11)
!     WRITE(*,*) 'c7',c(7)-c0(7),.7*fl(3)+.4*fl(6)+.7*fl(9)+
!   & cas*fl(12)-fl(13)
!     WRITE(*,*) 'c8',c(8)-c0(8),csp*fl(13)+cap*fl(12)-fl(14)

!**********************************************************************!
end subroutine flows
!**********************************************************************!

!**********************************************************************!
!                          FUNCTIONS                                   !
!**********************************************************************!

!**********************************************************************!
!                                                                      !
!                        ncrata :: soil_methods                        !
!                        ----------------------                        !
!                                                                      !
! Calculates N:C for the active organic matter pool.                   !
!                                                                      !
! function ncrata(x)                                                   !
!                                                                      !
!**********************************************************************!
real(dp) function ncrata(x)
!**********************************************************************!
real(dp) :: x
!----------------------------------------------------------------------!

if (x>2.0) then
  ncrata = 3.0
else
  ncrata = 15.0 - 6.0*x
endif
if (x<0.0) then
  ncrata = 15.0
endif

!**********************************************************************!
end function ncrata
!**********************************************************************!

!**********************************************************************!
!                                                                      !
!                         ncrats :: soil_methods                       !
!                         ----------------------                       !
!                                                                      !
! Calculates N:C for the slow organic matter pool.            !
!                                                                      !
! function ncrats(x)                                                   !
!                                                                      !
!**********************************************************************!
real(dp) function ncrats(x)
!----------------------------------------------------------------------!
real(dp) :: x
!----------------------------------------------------------------------!

if (x>2.0) then
  ncrats = 12.0
else
  ncrats = 20.0 - 4.0*x
endif
if (x<0.0) then
  ncrats = 20.0
endif

!**********************************************************************!
end function ncrats
!**********************************************************************!

!**********************************************************************!
!                                                                      !
!                       ncratp :: soil_methods                         !
!                       ----------------------                         !
!                                                                      !
! Calculates N:C for the passive organic matter pool.                  !
!                                                                      !
! real(dp) function ncratp(x)                                          !
!                                                                      !
!**********************************************************************!
real(dp) function ncratp(x)
!**********************************************************************!
real(dp) :: x
!----------------------------------------------------------------------!

if (x>2.0) then
  ncratp = 7.0
else
  ncratp = 10.0 - 1.5*x
endif
if (x<0.0) then
  ncratp = 10.0
endif

!**********************************************************************!
end function ncratp
!**********************************************************************!

!**********************************************************************!
!                                                                      !
!                       ncratsm :: soil_methods                        !
!                       -----------------------                        !
!                                                                      !
! Calculates N:C for the surface microbe pool.                         !
!                                                                      !
! real(dp) function ncratsm(x)                                         !
!                                                                      !
!**********************************************************************!
real(dp) function ncratsm(x)
!**********************************************************************!
real(dp) :: x
!----------------------------------------------------------------------!

if (x>2.0) then
  ncratsm = 10.0
else
  ncratsm = 20.0 - 5.0*x
endif
if (x<0.0) then
  ncratsm = 20.0
endif

!**********************************************************************!
end function ncratsm
!**********************************************************************!

!**********************************************************************!
!                                                                      !
!                       eot :: soil_methods                            !
!                       -------------------                            !
!                                                                      !
! Calculates the effect of temperature used to calculate the           !
! decay rate multiplier 'a'.                                           !
!                                                                      !
! real(dp) function eot(x)                                             !
!                                                                      !
!**********************************************************************!
real(dp) function eot(x)
!**********************************************************************!
real(dp) :: x
!----------------------------------------------------------------------!

if (x<0.0) then
  eot = 0.04
elseif (x<10.0) then
  eot = (0.16 - 0.03)*(x - 0.0)/(10.0 - 0.0) + 0.03
elseif (x<20.0) then
  eot = (0.50 - 0.16)*(x - 10.0)/(20.0 - 10.0) + 0.16
elseif (x<30.0) then
  eot = (0.88 - 0.50)*(x - 20.0)/(30.0 - 20.0) + 0.50
elseif (x<40.0) then
  eot = (0.96 - 0.88)*(x - 30.0)/(40.0 - 30.0) + 0.88
elseif (x<47.0) then
  eot = (0.86 - 0.96)*(x - 40.0)/(47.0 - 40.0) + 0.96
else
  eot = 0.0
endif

!**********************************************************************!
end function eot
!**********************************************************************!

!**********************************************************************!
!                                                                      !
!                       eot1 :: soil_methods                           !
!                       --------------------                           !
!                                                                      !
! Calculates the effect of temperature used to calculate the           !
! decay rate multiplier 'a'.                                           !
!                                                                      !
! real(dp) function eot1(x)                                            !
!                                                                      !
!**********************************************************************!
real(dp) function eot1(x)
!**********************************************************************!
real(dp) :: x,a,b
!----------------------------------------------------------------------!

a = (45.0 - x)/10.0
b = exp(0.076*(1.0 - a**2.63))
eot1 = (a**0.2)*b

!**********************************************************************!
end function eot1
!**********************************************************************!

!**********************************************************************!
!                                                                      !
!                       eow :: soil_methods                            !
!                       -------------------                            !
!                                                                      !
! Calculates the effect of water used to calculate the decay           !
! rate multiplier 'a'.                                                 !
!                                                                      !
! real(dp) function eow(x)                                             !
!                                                                      !
!**********************************************************************!
real(dp) function eow(x)
!**********************************************************************!
real(dp) :: x
!----------------------------------------------------------------------!

if (x<0.2) then
  eow = (0.21 - 0.09)*(x - 0.0)/(0.2 - 0.0) + 0.09
elseif (x<0.4) then
  eow = (0.48 - 0.21)*(x - 0.2)/(0.4 - 0.2) + 0.21
elseif (x<0.6) then
  eow = (0.82 - 0.48)*(x - 0.4)/(0.6 - 0.4) + 0.48
elseif (x<0.8) then
  eow = (0.97 - 0.82)*(x - 0.6)/(0.8 - 0.6) + 0.82
elseif (x<1.0) then
  eow = (0.97 - 0.97)*(x -0.8)/(1.0 - 0.8) + 0.97
elseif (x<2.0) then
  eow = (0.63 - 0.97)*(x - 1.0)/(2.0 - 1.0) + 0.97
else
  eow = (0.29 - 0.63)*(x - 2.0)/(3.0 - 2.0) + 0.63
endif

if ((eow<0.0).and.(x>1.0)) then
  eow = 0.1
endif

!**********************************************************************!
end function eow
!**********************************************************************!

!**********************************************************************!
!                                                                      !
!                       eow1 :: soil_methods                           !
!                       --------------------                           !
!                                                                      !
! Calculates the effect of water used to calculate the decay           !
! rate multiplier 'a'.                                                 !
!                                                                      !
! real(dp) function eow1(x)                                            !
!                                                                      !
!**********************************************************************!
real(dp) function eow1(x)
!**********************************************************************!
real(dp) :: x
!----------------------------------------------------------------------!

if (x<1.5) then
  eow1 = 1.0/(1.0 + 30.0*exp(-8.5*x))
else
  eow1 = 1.0 - 0.7*(x - 1.5)/1.5
endif

if (eow1<0.0001)  eow1 = 0.0001

!**********************************************************************!
end function eow1
!**********************************************************************!

!**********************************************************************!
!                                                                      !
!                        wsparam :: soil_methods                       !
!                        -----------------------                       !
!                                                                      !
! Sets some system parameters for both the water and soils             !
! models.                                                              !
!                                                                      !
! subroutine wsparam(l_b_and_c,nupc,awl,kd,kx,nci,nfix,adp,topsl,sfc,  !
! sw,sswc)                                                             !
!                                                                      !
!**********************************************************************!
subroutine wsparam(l_b_and_c,nupc,awl,kd,kx,nci,nfix,adp,topsl,sfc,sw,&
 sswc)
!**********************************************************************!
real(dp) :: nupc,awl(4),kd,kx,nci(4),nfix,adp(4),sfc(4),sw(4),sswc(4),&
 topsl,bc_wres,bc_wqs,ans1,bc_a,bc_l
logical :: l_b_and_c
!----------------------------------------------------------------------!

awl(1) = 0.05 ! Relative root density of the ith layer.
awl(2) = 0.05 !                  "
awl(3) = 0.03 !                  "
awl(4) = 0.01 !                  "
kd = 0.5    ! Fraction of excess water flowing to deep storage.
kx = 0.2    !                   "                 stream.
nci(1) = 0.04       ! NC ratio of litter pools.
nci(2) = 0.06666667 !          "
nci(3) = 0.04       !          "
nci(4) = 0.06666667 !          "
nupc = 1.0   ! Amount of nitrogen uptake ratio to litter.
nfix = 0.5   ! Soil deposition plus N fixation (g/m2/y).

if (l_b_and_c) then

!----------------------------------------------------------------------!
!                        Brookes Corey                                 !
!----------------------------------------------------------------------!
bc_wres = 0.0
bc_wqs = 1.0-ssp%bulk/2.65
ans1 = -0.475662 +0.005165*ssp%sand + 0.002066*ssp%silt - &
 0.023327*ssp%clay - 0.040628*ssp%bulk + 0.006824*ssp%orgc - &
 0.000136162*ssp%sand**2 - 0.0000954716*ssp%silt**2 + &
 0.000298891*ssp%clay**2 - 0.0637*ssp%bulk**2 - &
 0.00031679*ssp%orgc**2 + 0.0000010388*ssp%sand**3 + &
 0.0000010299*ssp%silt**3 - 0.0000013251*ssp%clay**3

bc_l = 10**ans1

ans1 = 0.4104 + 0.002684*ssp%sand + 0.006354*ssp%silt + &
 0.17766*ssp%bulk + 0.00013855*ssp%clay**2

bc_a = 1/10**ans1

ssp%wilt = bc_wres + (bc_wqs - bc_wres)*(15300.0*bc_a)**(-bc_l)
ssp%field = bc_wres + (bc_wqs - bc_wres)*(51.0*bc_a)**(-bc_l)
ssp%sat = 1.0-ssp%bulk/2.65

endif

!----------------------------------------------------------------------!
! Convert soil layer height into mm of water.                          !
!----------------------------------------------------------------------!
adp(1) = topsl*10.0
adp(2) = (ssp%soil_depth/3.0 - topsl)*10.0
adp(3) = ssp%soil_depth*10.0/3.0
adp(4) = ssp%soil_depth*10.0/3.0
sfc(1) = ssp%field*adp(1)
!      sfc(1) = adp(1)
sfc(2) = ssp%field*adp(2)
sfc(3) = ssp%field*adp(3)
sfc(4) = ssp%field*adp(4)
sw(1) = ssp%wilt*adp(1)
sw(2) = ssp%wilt*adp(2)
sw(3) = ssp%wilt*adp(3)
sw(4) = ssp%wilt*adp(4)
sswc(1) = ssp%sat*adp(1)
sswc(2) = ssp%sat*adp(2)
sswc(3) = ssp%sat*adp(3)
sswc(4) = ssp%sat*adp(4)

!**********************************************************************!
end subroutine wsparam
!**********************************************************************!

end module soil_methods