      subroutine ncmpvh(acflg,act,actlg,cdrs,cgxj,jflag,
     $ jsflag,losp,mosp,mtxj,nbasp,nbt,nbtmax,ndrs,ndrsmx,
     $ ndrsr,nrr1,nrr2,nstmax,xbar,xbarlg,xlks)
c
c     This subroutine calculates part of the "expansion" of the basis
c     set description regarding a site of a generic ion exchange
c     phase. It assists EQLIB/ncmpve.h. The part of the expansion
c     performed here does not take into account the need for an
c     iterative process to complete the actual expansion; rather, it
c     calculates a tentative part of the expansion. The iterative
c     process is required (at least in the general case, for example
c     Na+ for Ca++ following the Vanselow exchange model) because
c     mtxj (the sum of the number of moles of the species on the site)
c     is known only approximately at the start of the expansion process.
c     This subroutine uses a tentative value of mtxj as an input.
c
c     This subroutine is called by:
c
c       EQLIB/ncmpvh.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c       acflg  = array of logarithms of activity coefficients
c       actlg  = array of logarithms of species activities
c                  (input consists of valid results for aqueous
c                  basis species; output consists of the same
c                  for exchanger species belonging to Vanselow
c                  exchanger phases)
c       cdrs   = array of reaction coefficients
c       mosp   = array of numbers of moles of species
c                  (input contains valid results for basis species
c                  and carry-over values for non-basis species)
c       mtxj   = the sum of the number of moles of exchanger species
c                  in the current site of the current generic ion
c                  exchange phase
c       ndrs   = array parallel to cdrs giving the index of the
c                  corresponding species
c       ndrsr  = array giving the range in the cdrs/ndrs arrays
c                  corresonding to the reaction associated with a
c                  given species
c       nrr1   = the start of the species index range for the
c                  current site of the current ion exchange phase
c       nrr2   = the end of the species index range for the
c                  current site of the current ion exchange phase
c       xlks   = array of equilibrium constants
c
c     Principal output:
c
c       act    = array of species activities
c                  (output consists of the subset for exchanger
c                  species belonging to Vanselow exchanger phases)
c       actlg  = array of logarithms of species activities
c       mosp   = array of numbers of moles of species
c                  (output consists of valid results for non-basis
c                  species; valid results for basis species were
c                  input and are retained)
c       losp   = array of logarithms of numbers of moles of species
c       xbar   = array of mole fractions of species
c       xbarlg = array of logarithms of mole fractions of species
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer nbtmax,ndrsmx,nstmax
c
      integer jflag(nstmax),jsflag(nstmax),nbasp(nbtmax),ndrs(ndrsmx),
     $ ndrsr(2,nstmax)
c
      integer nbt,nrr1,nrr2
c
      real*8 acflg(nstmax),act(nstmax),actlg(nstmax),cdrs(ndrsmx),
     $ losp(nstmax),mosp(nstmax),xbar(nstmax),xbarlg(nstmax),
     $ xlks(nstmax)
c
      real*8 cgxj,mtxj
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer n,nb,nr1,nr2,ns,nss
c
      integer nbasis
c
      real*8 cxs,lax,lx,lxx,mx,xx
c
      real*8 texp,tlg
c
c-----------------------------------------------------------------------
c
c     Estimate the mole fractions and activities of the
c     basis species for the current site.
c
      do ns = nrr1,nrr2
        nb = nbasis(nbasp,nbt,nbtmax,ns)
        if (nb.gt.0 .and. jsflag(ns).le.0) then
          xx = mosp(ns)/mtxj
          xbar(ns) = xx
          lxx = tlg(xx)
          xbarlg(ns) = lxx
          lax = cgxj*(lxx + acflg(ns))
          actlg(ns) = lax
          act(ns) = texp(lax)
        endif
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Estimate the mole fractions and activities of the
c     non-basis species for the current site.
c
      do ns = nrr1,nrr2
        if (jflag(ns).eq.30 .and. jsflag(ns).le.0) then
c
c         Calculate the activities and mole fractions for
c         the exchanger species not in the basis set.
c
          nr1 = ndrsr(1,ns)
          nr2 = ndrsr(2,ns)
          cxs = cdrs(nr1)
          lax = -xlks(ns)
          do n = nr1 + 1,nr2
            nss = ndrs(n)
            lax = lax + cdrs(n)*actlg(nss)
          enddo
          lax = -lax/cxs
          actlg(ns) = lax
          act(ns) = texp(lax)
          lxx = (lax/cgxj) - acflg(ns)
          xbarlg(ns) = lxx
          xx = texp(lxx)
          xbar(ns) = xx
c
c         Also calculate the corresponding numbers of moles.
c
          mx = xx*mtxj
          lx = tlg(mx)
          mosp(ns) = mx
          losp(ns) = lx
        endif
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      end


! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
! H0 X
! H0 X   libAtoms+QUIP: atomistic simulation library
! H0 X
! H0 X   Portions of this code were written by
! H0 X     Albert Bartok-Partay, Silvia Cereda, Gabor Csanyi, James Kermode,
! H0 X     Ivan Solt, Wojciech Szlachta, Csilla Varnai, Steven Winfield.
! H0 X
! H0 X   Copyright 2006-2010.
! H0 X
! H0 X   These portions of the source code are released under the GNU General
! H0 X   Public License, version 2, http://www.gnu.org/copyleft/gpl.html
! H0 X
! H0 X   If you would like to license the source code under different terms,
! H0 X   please contact Gabor Csanyi, gabor@csanyi.net
! H0 X
! H0 X   Portions of this code were written by Noam Bernstein as part of
! H0 X   his employment for the U.S. Government, and are not subject
! H0 X   to copyright in the USA.
! H0 X
! H0 X
! H0 X   When using this software, please cite the following reference:
! H0 X
! H0 X   http://www.libatoms.org
! H0 X
! H0 X  Additional contributions by
! H0 X    Alessio Comisso, Chiara Gattinoni, and Gianpietro Moras
! H0 X
! H0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

!X
!X  Units module
!X
!%  This module holds a collection of our units and conversion factors.
!%  We use Angstroms ($\mathrm{\AA}$), eV, and femtoseconds (fs).
!%
!%  - Length:   Angstroms, ``a.u. * BOHR``
!%  - Energy:   eV,        ``a.u. * HARTREE``
!%  - Time:     fs
!%  - Mass:     $E T^2/L^2$ = ``a.u. * HARTREE * AU_FS**2 / BOHR**2``
!%
!X
!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

module units_module

use system_module, only : dp ! for definition of dp
implicit none
public

#ifdef LEGACY_UNITS
! Values of units pre-2017.
! Since results will vary, keep these around for a while in case
! someone needs consistency with these.
! Tests will fail if these values are used.
real(dp), parameter :: ELECTRONMASS_GPERMOL =  5.48579903e-4_dp !% grams/mol
real(dp), parameter :: ELEM_CHARGE = 1.60217653e-19_dp !% coulombs
real(dp), parameter :: HARTREE = 27.2113961_dp !% eV
real(dp), parameter :: RYDBERG = 0.5_dp*HARTREE !% eV
real(dp), parameter :: BOHR = 0.529177249_dp !% Angstrom
real(dp), parameter :: CUBIC_BOHR = BOHR*BOHR/HARTREE !% QUIP Units of polarisability
real(dp), parameter :: HBAR_EVSEC = 6.5821220e-16_dp !% hbar in eV seconds
real(dp), parameter :: HBAR_AU = 1.0_dp              !% hbar in a.u.
real(dp), parameter :: HBAR = (HBAR_EVSEC*1e+15_dp)    !% hbar in eV fs
real(dp), parameter :: ONESECOND = 1e15_dp           !% 1 second in fs
real(dp), parameter :: ONESECOND_AU = (1.0_dp/(HBAR_EVSEC/(HBAR_AU*HARTREE))) !% 1 second in a.u.
real(dp), parameter :: AU_FS = (1.0_dp/ONESECOND_AU*ONESECOND) !% a.u. time in fs
real(dp), parameter :: MASSCONVERT = (1.0_dp/ELECTRONMASS_GPERMOL*HARTREE*AU_FS*AU_FS/(BOHR*BOHR)) !% = 1e7 / (N_A * ELEM_CHARGE)
real(dp), parameter :: BOLTZMANN_K = 8.617385e-5_dp !% eV/Kelvin
real(dp), parameter :: PI = 3.14159265358979323846264338327950288_dp
real(dp), parameter :: N_A = 6.0221479e23_dp !% Avogadro's number
real(dp), parameter :: KCAL_MOL = 4.3383e-2_dp !% eV
real(dp), parameter :: DEGREES_PER_RADIAN = 180.0_dp / PI
real(dp), parameter :: RADIANS_PER_DEGREE = PI / 180.0_dp
real(dp), parameter :: GPA = 1.6022e-19_dp*1.0e30_dp/1.0e9_dp !% Convert from \textsc{libAtoms} units to Gigapascals (DEPRECATED)
real(dp), parameter :: EV_A3_IN_GPA = 1.6022e-19_dp*1.0e30_dp/1.0e9_dp !% Same thing but with a less misleading name
real(dp), parameter :: GPA_TO_EV_A3 = 1.0e9_dp/ELEM_CHARGE/1.0e30_dp !% The inverse of the above, convention consistent with all other conversion factors
real(dp), parameter :: EPSILON_0 = 8.854187817e-12_dp / ELEM_CHARGE * 1.0e-10_dp !% epsilon_0 in e / V Angstrom
real(dp), parameter :: DEBYE = 1.0e-21_dp/299792458.0_dp/ELEM_CHARGE*1e10_dp !% 1D $= 10^{-18}$ statcoulomb-centrimetre in e-A
real(dp), parameter :: SQRT_TWO = sqrt(2.0_dp)
! not included originally, make sure they're not undefined
real(dp), parameter :: GRAM = 1e-3_dp  !% in kg
real(dp), parameter :: ELECTRONMASS = ELECTRONMASS_GPERMOL*GRAM/N_A
real(dp), parameter :: EPSILON_0_AU = EPSILON_0*ELEM_CHARGE/1.0e-10_dp
real(dp), parameter :: VACUUM_C = 299792458.0_dp  !% exact in m/s
real(dp), parameter :: INVERSE_CM = 1.0e2_dp*VACUUM_C*HBAR_EVSEC*2.0_dp*PI !%
#else
! CODATA 2014 taken from
! http://arxiv.org/pdf/1507.07956.pdf
! Fundamentals
real(dp), parameter :: ELECTRONMASS = 9.10938356e-31_dp  !% electron mass / kg
real(dp), parameter :: N_A = 6.022140857e23_dp  !% Avogadro constant
real(dp), parameter :: ELEM_CHARGE = 1.6021766208e-19_dp  !% e / Coulombs
real(dp), parameter :: HARTREE = 27.21138602_dp  !% EH / eV
real(dp), parameter :: BOHR = 0.52917721067_dp  !% in Angstrom
real(dp), parameter :: HBAR_EVSEC = 6.582119514e-16_dp  !% hbar in eV seconds
real(dp), parameter :: BOLTZMANN_K = 8.6173303e-5_dp  !% eV/kelvin
real(dp), parameter :: EPSILON_0_AU = 8.854187817e-12_dp  !% exact in F/m
real(dp), parameter :: VACUUM_C = 299792458.0_dp  !% exact in m/s

! Others
real(dp), parameter :: GRAM = 1e-3_dp  !% in kg
real(dp), parameter :: PI = 3.14159265358979323846264338327950288_dp
real(dp), parameter :: SQRT_TWO = sqrt(2.0_dp)

! derived units for QUIP
real(dp), parameter :: ELECTRONMASS_GPERMOL = ELECTRONMASS*N_A/GRAM  !% grams/mol
real(dp), parameter :: RYDBERG = 0.5_dp*HARTREE !% eV
real(dp), parameter :: CUBIC_BOHR = BOHR*BOHR/HARTREE !% QUIP Units of polarisability
real(dp), parameter :: HBAR_AU = 1.0_dp              !% hbar in a.u.
real(dp), parameter :: HBAR = (HBAR_EVSEC*1e+15_dp)    !% hbar in eV fs
real(dp), parameter :: ONESECOND = 1e15_dp           !% 1 second in fs
real(dp), parameter :: ONESECOND_AU = (1.0_dp/(HBAR_EVSEC/(HBAR_AU*HARTREE))) !% 1 second in a.u.
real(dp), parameter :: AU_FS = (1.0_dp/ONESECOND_AU*ONESECOND) !% a.u. time in fs
real(dp), parameter :: MASSCONVERT = (1.0_dp/ELECTRONMASS_GPERMOL*HARTREE*AU_FS*AU_FS/(BOHR*BOHR)) !% = 1e7 / (N_A * ELEM_CHARGE)
real(dp), parameter :: KCAL_MOL = 4.184*1000/(ELEM_CHARGE*N_A) !% Thermochemical definition in eV
real(dp), parameter :: DEGREES_PER_RADIAN = 180.0_dp / PI
real(dp), parameter :: RADIANS_PER_DEGREE = PI / 180.0_dp
real(dp), parameter :: GPA = ELEM_CHARGE*1.0e30_dp/1.0e9_dp !% Convert from \textsc{libAtoms} units to Gigapascals (DEPRECATED)
real(dp), parameter :: EV_A3_IN_GPA = ELEM_CHARGE*1.0e30_dp/1.0e9_dp !% Same thing but with a less misleading name
real(dp), parameter :: GPA_TO_EV_A3 = 1.0e9_dp/ELEM_CHARGE/1.0e30_dp !% The inverse of the above, convention consistent with all other conversion factors
real(dp), parameter :: EPSILON_0 = EPSILON_0_AU/ELEM_CHARGE*1.0e-10_dp !% epsilon_0 in e / V Angstrom
real(dp), parameter :: DEBYE = 1.0e-21_dp/VACUUM_C/ELEM_CHARGE*1e10_dp !% 1D $= 10^{-18}$ statcoulomb-centrimetre in e-A
real(dp), parameter :: INVERSE_CM = 1.0e2_dp*VACUUM_C*HBAR_EVSEC*2.0_dp*PI !% cm^{-1} * h * c
#endif

complex(dp), parameter :: CPLX_ZERO = (0.0_dp,0.0_dp)
complex(dp), parameter :: CPLX_IMAG = (0.0_dp,1.0_dp)
complex(dp), parameter :: CPLX_ONE  = (1.0_dp,0.0_dp)

! Make the values of some compiler macros available at runtime
#ifdef HAVE_LOTF
integer, parameter :: have_lotf = 1
#else
integer, parameter :: have_lotf = 0
#endif

#ifdef HAVE_CP2K
integer, parameter :: have_cp2k = 1
#else
integer, parameter :: have_cp2k = 0
#endif

#ifdef HAVE_NETCDF4
integer, parameter :: have_netcdf = 1
#else
integer, parameter :: have_netcdf = 0
#endif

end module units_module


        SUBROUTINE  LS_MAWX ( lsfrpt, ipt, iret )
C************************************************************************
C* LS_MAWX                                                              *
C*                                                                      *
C* This subroutine decodes the present and past weather group,          *
C* 7wwW(1)W(2) from a manned station or 7w(a)w(a)W(a1)W(a2) from an     *
C* automatic station.  The ww's and WW's are WMO code table values.     *
C* The station indicator IXIND has a value of 1 or 4 for a manned       *
C* station, and a value of 7 for an automated station.                  *
C*                                                                      *
C* LS_MAWX  ( LSFRPT, IPT, IRET )                                       *
C*                                                                      *
C* Input parameters:                                                    *
C*      LSFRPT         	CHAR*           Report array                    *
C*      IXIND          	INTEGER         Indicator for type of station   *
C*                                      operation and WX data           *
C* Input and output parameters:                                         *
C*	IPT		INTEGER		On input, points to first 'w' in*
C*					7wwWW; on output, points to last*
C*					'W' in group                    *
C*                                                                      *
C* Output parameters:                                                   *
C*      RIVALS(IRWWMO) 	REAL            Present weather WMO table 4677  *
C*      RIVALS(IRWWMA) 	REAL            Present weather WMO table 4680  *
C*      RIVALS(IRPWWM) 	REAL            Past weather 1 WMO table 4561   *
C*      RIVALS(IRPWWA) 	REAL            Past weather 1 WMO table 4531   *
C*      RIVALS(IRPSW2) 	REAL            Past weather 2 WMO table 4561   *
C*      RIVALS(IRPWA2) 	REAL            Past weather 2 WMO table 4531   *
C*      IRET            INTEGER         Return code                     *
C*                                        0 = Normal return             *
C*                                        1 = Problems                  *
C*                                                                      *
C**								        *
C* Log:							                *
C* R. Hollern/NCEP      6/96                                            *
C* R. Hollern/NCEP     12/96    Replaced ST_C2R with ST_INTG            *
C* R. Hollern/NCEP      1/98    Changes based on MA_MAWX                *
C* R. Hollern/NCEP      8/99	Defined interface array variable for    *
C*                              past weather 2 from an automatic station*
C************************************************************************
        INCLUDE 	'GEMPRM.PRM'
        INCLUDE  	'lscmn.cmn'
C*
        CHARACTER*(*)   lsfrpt
C*
        CHARACTER       fld2*2, fld1*1
C------------------------------------------------------------------------
        iret = 0
C
C*      Get present weather.
C
        IF ( lsfrpt ( ipt:ipt+1 ) .ne. '//' ) THEN
            fld2 = lsfrpt ( ipt:ipt+1 )
            CALL  ST_INTG ( fld2, ival, ier )
            IF ( ier .eq. 0 ) THEN
                IF ( ixind .eq. 1 .or. ixind .eq. 4 ) THEN
                    rivals ( irwwmo ) = FLOAT ( ival )
                  ELSE IF ( ixind .eq. 7  ) THEN
                    rivals ( irwwma ) = FLOAT ( ival )
                END IF
            END IF
        END IF
C
C*      Get past weather 1.
C
        ipt = ipt + 2
        IF ( lsfrpt ( ipt:ipt ) .ne. '/' ) THEN
            fld1 = lsfrpt ( ipt:ipt )
            CALL  ST_INTG ( fld1, ival, ier )
            IF ( ier .eq. 0 ) THEN
                IF ( ixind .eq. 1 .or. ixind .eq. 4 ) THEN
                    rivals ( irpwwm ) = FLOAT ( ival )
                  ELSE IF ( ixind .eq. 7 ) THEN
                    rivals ( irpwwa ) = FLOAT ( ival )
                END IF
            END IF
        END IF
C
C*      Get past weather 2.
C
        ipt = ipt + 1
        IF ( lsfrpt ( ipt:ipt ) .ne. '/' ) THEN
            fld1 = lsfrpt ( ipt:ipt )
            CALL  ST_INTG ( fld1, ival, ier )
            IF ( ier .eq. 0 ) THEN
                IF ( ixind .eq. 1 .or. ixind .eq. 4 ) THEN
                    rivals ( irpsw2 ) = FLOAT ( ival )
                ELSE IF ( ixind .eq. 7 ) THEN
                    rivals ( irpwa2 ) = FLOAT ( ival )
                END IF
            END IF
        END IF
C*
        RETURN
        END


      SUBROUTINE DA7SST(IV, LIV, LV, V)
C
C  ***  ASSESS CANDIDATE STEP (***SOL VERSION 2.3)  ***
C
      INTEGER LIV, LV
      INTEGER IV(LIV)
      DOUBLE PRECISION V(LV)
C
C  ***  PURPOSE  ***
C
C        THIS SUBROUTINE IS CALLED BY AN UNCONSTRAINED MINIMIZATION
C     ROUTINE TO ASSESS THE NEXT CANDIDATE STEP.  IT MAY RECOMMEND ONE
C     OF SEVERAL COURSES OF ACTION, SUCH AS ACCEPTING THE STEP, RECOM-
C     PUTING IT USING THE SAME OR A NEW QUADRATIC MODEL, OR HALTING DUE
C     TO CONVERGENCE OR FALSE CONVERGENCE.  SEE THE RETURN CODE LISTING
C     BELOW.
C
C--------------------------  PARAMETER USAGE  --------------------------
C
C  IV (I/O) INTEGER PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION
C             BELOW OF IV VALUES REFERENCED.
C LIV (IN)  LENGTH OF IV ARRAY.
C  LV (IN)  LENGTH OF V ARRAY.
C   V (I/O) REAL PARAMETER AND SCRATCH VECTOR -- SEE DESCRIPTION
C             BELOW OF V VALUES REFERENCED.
C
C  ***  IV VALUES REFERENCED  ***
C
C    IV(IRC) (I/O) ON INPUT FOR THE FIRST STEP TRIED IN A NEW ITERATION,
C             IV(IRC) SHOULD BE SET TO 3 OR 4 (THE VALUE TO WHICH IT IS
C             SET WHEN STEP IS DEFINITELY TO BE ACCEPTED).  ON INPUT
C             AFTER STEP HAS BEEN RECOMPUTED, IV(IRC) SHOULD BE
C             UNCHANGED SINCE THE PREVIOUS RETURN OF DA7SST.
C                ON OUTPUT, IV(IRC) IS A RETURN CODE HAVING ONE OF THE
C             FOLLOWING VALUES...
C                  1 = SWITCH MODELS OR TRY SMALLER STEP.
C                  2 = SWITCH MODELS OR ACCEPT STEP.
C                  3 = ACCEPT STEP AND DETERMINE V(RADFAC) BY GRADIENT
C                       TESTS.
C                  4 = ACCEPT STEP, V(RADFAC) HAS BEEN DETERMINED.
C                  5 = RECOMPUTE STEP (USING THE SAME MODEL).
C                  6 = RECOMPUTE STEP WITH RADIUS = V(LMAXS) BUT DO NOT
C                       EVALUATE THE OBJECTIVE FUNCTION.
C                  7 = X-CONVERGENCE (SEE V(XCTOL)).
C                  8 = RELATIVE FUNCTION CONVERGENCE (SEE V(RFCTOL)).
C                  9 = BOTH X- AND RELATIVE FUNCTION CONVERGENCE.
C                 10 = ABSOLUTE FUNCTION CONVERGENCE (SEE V(AFCTOL)).
C                 11 = SINGULAR CONVERGENCE (SEE V(LMAXS)).
C                 12 = FALSE CONVERGENCE (SEE V(XFTOL)).
C                 13 = IV(IRC) WAS OUT OF RANGE ON INPUT.
C             RETURN CODE I HAS PRECEDENCE OVER I+1 FOR I = 9, 10, 11.
C IV(MLSTGD) (I/O) SAVED VALUE OF IV(MODEL).
C  IV(MODEL) (I/O) ON INPUT, IV(MODEL) SHOULD BE AN INTEGER IDENTIFYING
C             THE CURRENT QUADRATIC MODEL OF THE OBJECTIVE FUNCTION.
C             IF A PREVIOUS STEP YIELDED A BETTER FUNCTION REDUCTION,
C             THEN IV(MODEL) WILL BE SET TO IV(MLSTGD) ON OUTPUT.
C IV(NFCALL) (IN)  INVOCATION COUNT FOR THE OBJECTIVE FUNCTION.
C IV(NFGCAL) (I/O) VALUE OF IV(NFCALL) AT STEP THAT GAVE THE BIGGEST
C             FUNCTION REDUCTION THIS ITERATION.  IV(NFGCAL) REMAINS
C             UNCHANGED UNTIL A FUNCTION REDUCTION IS OBTAINED.
C IV(RADINC) (I/O) THE NUMBER OF RADIUS INCREASES (OR MINUS THE NUMBER
C             OF DECREASES) SO FAR THIS ITERATION.
C IV(RESTOR) (OUT) SET TO 1 IF V(F) HAS BEEN RESTORED AND X SHOULD BE
C             RESTORED TO ITS INITIAL VALUE, TO 2 IF X SHOULD BE SAVED,
C             TO 3 IF X SHOULD BE RESTORED FROM THE SAVED VALUE, AND TO
C             0 OTHERWISE.
C  IV(STAGE) (I/O) COUNT OF THE NUMBER OF MODELS TRIED SO FAR IN THE
C             CURRENT ITERATION.
C IV(STGLIM) (IN)  MAXIMUM NUMBER OF MODELS TO CONSIDER.
C IV(SWITCH) (OUT) SET TO 0 UNLESS A NEW MODEL IS BEING TRIED AND IT
C             GIVES A SMALLER FUNCTION VALUE THAN THE PREVIOUS MODEL,
C             IN WHICH CASE DA7SST SETS IV(SWITCH) = 1.
C IV(TOOBIG) (I/O)  IS NONZERO ON INPUT IF STEP WAS TOO BIG (E.G., IF
C             IT WOULD CAUSE OVERFLOW).  IT IS SET TO 0 ON RETURN.
C   IV(XIRC) (I/O) VALUE THAT IV(IRC) WOULD HAVE IN THE ABSENCE OF
C             CONVERGENCE, FALSE CONVERGENCE, AND OVERSIZED STEPS.
C
C  ***  V VALUES REFERENCED  ***
C
C V(AFCTOL) (IN)  ABSOLUTE FUNCTION CONVERGENCE TOLERANCE.  IF THE
C             ABSOLUTE VALUE OF THE CURRENT FUNCTION VALUE V(F) IS LESS
C             THAN V(AFCTOL) AND DA7SST DOES NOT RETURN WITH
C             IV(IRC) = 11, THEN DA7SST RETURNS WITH IV(IRC) = 10.
C V(DECFAC) (IN)  FACTOR BY WHICH TO DECREASE RADIUS WHEN IV(TOOBIG) IS
C             NONZERO.
C V(DSTNRM) (IN)  THE 2-NORM OF D*STEP.
C V(DSTSAV) (I/O) VALUE OF V(DSTNRM) ON SAVED STEP.
C   V(DST0) (IN)  THE 2-NORM OF D TIMES THE NEWTON STEP (WHEN DEFINED,
C             I.E., FOR V(NREDUC) .GE. 0).
C      V(F) (I/O) ON BOTH INPUT AND OUTPUT, V(F) IS THE OBJECTIVE FUNC-
C             TION VALUE AT X.  IF X IS RESTORED TO A PREVIOUS VALUE,
C             THEN V(F) IS RESTORED TO THE CORRESPONDING VALUE.
C   V(FDIF) (OUT) THE FUNCTION REDUCTION V(F0) - V(F) (FOR THE OUTPUT
C             VALUE OF V(F) IF AN EARLIER STEP GAVE A BIGGER FUNCTION
C             DECREASE, AND FOR THE INPUT VALUE OF V(F) OTHERWISE).
C V(FLSTGD) (I/O) SAVED VALUE OF V(F).
C     V(F0) (IN)  OBJECTIVE FUNCTION VALUE AT START OF ITERATION.
C V(GTSLST) (I/O) VALUE OF V(GTSTEP) ON SAVED STEP.
C V(GTSTEP) (IN)  INNER PRODUCT BETWEEN STEP AND GRADIENT.
C V(INCFAC) (IN)  MINIMUM FACTOR BY WHICH TO INCREASE RADIUS.
C  V(LMAXS) (IN)  MAXIMUM REASONABLE STEP SIZE (AND INITIAL STEP BOUND).
C             IF THE ACTUAL FUNCTION DECREASE IS NO MORE THAN TWICE
C             WHAT WAS PREDICTED, IF A RETURN WITH IV(IRC) = 7, 8, OR 9
C             DOES NOT OCCUR, IF V(DSTNRM) .GT. V(LMAXS) OR THE CURRENT
C             STEP IS A NEWTON STEP, AND IF
C             V(PREDUC) .LE. V(SCTOL) * ABS(V(F0)), THEN DA7SST RETURNS
C             WITH IV(IRC) = 11.  IF SO DOING APPEARS WORTHWHILE, THEN
C            DA7SST REPEATS THIS TEST (DISALLOWING A FULL NEWTON STEP)
C             WITH V(PREDUC) COMPUTED FOR A STEP OF LENGTH V(LMAXS)
C             (BY A RETURN WITH IV(IRC) = 6).
C V(NREDUC) (I/O)  FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR
C             NEWTON STEP.  IF DA7SST IS CALLED WITH IV(IRC) = 6, I.E.,
C             IF V(PREDUC) HAS BEEN COMPUTED WITH RADIUS = V(LMAXS) FOR
C             USE IN THE SINGULAR CONVERGENCE TEST, THEN V(NREDUC) IS
C             SET TO -V(PREDUC) BEFORE THE LATTER IS RESTORED.
C V(PLSTGD) (I/O) VALUE OF V(PREDUC) ON SAVED STEP.
C V(PREDUC) (I/O) FUNCTION REDUCTION PREDICTED BY QUADRATIC MODEL FOR
C             CURRENT STEP.
C V(RADFAC) (OUT) FACTOR TO BE USED IN DETERMINING THE NEW RADIUS,
C             WHICH SHOULD BE V(RADFAC)*DST, WHERE  DST  IS EITHER THE
C             OUTPUT VALUE OF V(DSTNRM) OR THE 2-NORM OF
C             DIAG(NEWD)*STEP  FOR THE OUTPUT VALUE OF STEP AND THE
C             UPDATED VERSION, NEWD, OF THE SCALE VECTOR D.  FOR
C             IV(IRC) = 3, V(RADFAC) = 1.0 IS RETURNED.
C V(RDFCMN) (IN)  MINIMUM VALUE FOR V(RADFAC) IN TERMS OF THE INPUT
C             VALUE OF V(DSTNRM) -- SUGGESTED VALUE = 0.1.
C V(RDFCMX) (IN)  MAXIMUM VALUE FOR V(RADFAC) -- SUGGESTED VALUE = 4.0.
C  V(RELDX) (IN) SCALED RELATIVE CHANGE IN X CAUSED BY STEP, COMPUTED
C             (E.G.) BY FUNCTION  DRLDST  AS
C                 MAX (D(I)*ABS(X(I)-X0(I)), 1 .LE. I .LE. P) /
C                    MAX (D(I)*(ABS(X(I))+ABS(X0(I))), 1 .LE. I .LE. P).
C V(RFCTOL) (IN)  RELATIVE FUNCTION CONVERGENCE TOLERANCE.  IF THE
C             ACTUAL FUNCTION REDUCTION IS AT MOST TWICE WHAT WAS PRE-
C             DICTED AND  V(NREDUC) .LE. V(RFCTOL)*ABS(V(F0)),  THEN
C            DA7SST RETURNS WITH IV(IRC) = 8 OR 9.
C  V(SCTOL) (IN)  SINGULAR CONVERGENCE TOLERANCE -- SEE V(LMAXS).
C V(STPPAR) (IN)  MARQUARDT PARAMETER -- 0 MEANS FULL NEWTON STEP.
C V(TUNER1) (IN)  TUNING CONSTANT USED TO DECIDE IF THE FUNCTION
C             REDUCTION WAS MUCH LESS THAN EXPECTED.  SUGGESTED
C             VALUE = 0.1.
C V(TUNER2) (IN)  TUNING CONSTANT USED TO DECIDE IF THE FUNCTION
C             REDUCTION WAS LARGE ENOUGH TO ACCEPT STEP.  SUGGESTED
C             VALUE = 10**-4.
C V(TUNER3) (IN)  TUNING CONSTANT USED TO DECIDE IF THE RADIUS
C             SHOULD BE INCREASED.  SUGGESTED VALUE = 0.75.
C  V(XCTOL) (IN)  X-CONVERGENCE CRITERION.  IF STEP IS A NEWTON STEP
C             (V(STPPAR) = 0) HAVING V(RELDX) .LE. V(XCTOL) AND GIVING
C             AT MOST TWICE THE PREDICTED FUNCTION DECREASE, THEN
C            DA7SST RETURNS IV(IRC) = 7 OR 9.
C  V(XFTOL) (IN)  FALSE CONVERGENCE TOLERANCE.  IF STEP GAVE NO OR ONLY
C             A SMALL FUNCTION DECREASE AND V(RELDX) .LE. V(XFTOL),
C             THEN DA7SST RETURNS WITH IV(IRC) = 12.
C
C-------------------------------  NOTES  -------------------------------
C
C  ***  APPLICATION AND USAGE RESTRICTIONS  ***
C
C        THIS ROUTINE IS CALLED AS PART OF THE NL2SOL (NONLINEAR
C     LEAST-SQUARES) PACKAGE.  IT MAY BE USED IN ANY UNCONSTRAINED
C     MINIMIZATION SOLVER THAT USES DOGLEG, GOLDFELD-QUANDT-TROTTER,
C     OR LEVENBERG-MARQUARDT STEPS.
C
C  ***  ALGORITHM NOTES  ***
C
C        SEE (1) FOR FURTHER DISCUSSION OF THE ASSESSING AND MODEL
C     SWITCHING STRATEGIES.  WHILE NL2SOL CONSIDERS ONLY TWO MODELS,
C    DA7SST IS DESIGNED TO HANDLE ANY NUMBER OF MODELS.
C
C  ***  USAGE NOTES  ***
C
C        ON THE FIRST CALL OF AN ITERATION, ONLY THE I/O VARIABLES
C     STEP, X, IV(IRC), IV(MODEL), V(F), V(DSTNRM), V(GTSTEP), AND
C     V(PREDUC) NEED HAVE BEEN INITIALIZED.  BETWEEN CALLS, NO I/O
C     VALUES EXCEPT STEP, X, IV(MODEL), V(F) AND THE STOPPING TOLER-
C     ANCES SHOULD BE CHANGED.
C        AFTER A RETURN FOR CONVERGENCE OR FALSE CONVERGENCE, ONE CAN
C     CHANGE THE STOPPING TOLERANCES AND CALL DA7SST AGAIN, IN WHICH
C     CASE THE STOPPING TESTS WILL BE REPEATED.
C
C  ***  REFERENCES  ***
C
C     (1) DENNIS, J.E., JR., GAY, D.M., AND WELSCH, R.E. (1981),
C        AN ADAPTIVE NONLINEAR LEAST-SQUARES ALGORITHM,
C        ACM TRANS. MATH. SOFTWARE, VOL. 7, NO. 3.
C
C     (2) POWELL, M.J.D. (1970)  A FORTRAN SUBROUTINE FOR SOLVING
C        SYSTEMS OF NONLINEAR ALGEBRAIC EQUATIONS, IN NUMERICAL
C        METHODS FOR NONLINEAR ALGEBRAIC EQUATIONS, EDITED BY
C        P. RABINOWITZ, GORDON AND BREACH, LONDON.
C
C  ***  HISTORY  ***
C
C        JOHN DENNIS DESIGNED MUCH OF THIS ROUTINE, STARTING WITH
C     IDEAS IN (2). ROY WELSCH SUGGESTED THE MODEL SWITCHING STRATEGY.
C        DAVID GAY AND STEPHEN PETERS CAST THIS SUBROUTINE INTO A MORE
C     PORTABLE FORM (WINTER 1977), AND DAVID GAY CAST IT INTO ITS
C     PRESENT FORM (FALL 1978), WITH MINOR CHANGES TO THE SINGULAR
C     CONVERGENCE TEST IN MAY, 1984 (TO DEAL WITH FULL NEWTON STEPS).
C
C  ***  GENERAL  ***
C
C     THIS SUBROUTINE WAS WRITTEN IN CONNECTION WITH RESEARCH
C     SUPPORTED BY THE NATIONAL SCIENCE FOUNDATION UNDER GRANTS
C     MCS-7600324, DCR75-10143, 76-14311DSS, MCS76-11989, AND
C     MCS-7906671.
C
C------------------------  EXTERNAL QUANTITIES  ------------------------
C
C  ***  NO EXTERNAL FUNCTIONS AND SUBROUTINES  ***
C
C--------------------------  LOCAL VARIABLES  --------------------------
C
      LOGICAL GOODX
      INTEGER I, NFC
      DOUBLE PRECISION EMAX, EMAXS, GTS, RFAC1, XMAX
      DOUBLE PRECISION HALF, ONE, ONEP2, TWO, ZERO
C
C  ***  SUBSCRIPTS FOR IV AND V  ***
C
      INTEGER AFCTOL, DECFAC, DSTNRM, DSTSAV, DST0, F, FDIF, FLSTGD, F0,
     1        GTSLST, GTSTEP, INCFAC, IRC, LMAXS, MLSTGD, MODEL, NFCALL,
     2        NFGCAL, NREDUC, PLSTGD, PREDUC, RADFAC, RADINC, RDFCMN,
     3        RDFCMX, RELDX, RESTOR, RFCTOL, SCTOL, STAGE, STGLIM,
     4        STPPAR, SWITCH, TOOBIG, TUNER1, TUNER2, TUNER3, XCTOL,
     5        XFTOL, XIRC
C
C  ***  DATA INITIALIZATIONS  ***
C
C/6
C     DATA HALF/0.5D+0/, ONE/1.D+0/, ONEP2/1.2D+0/, TWO/2.D+0/,
C    1     ZERO/0.D+0/
C/7
      PARAMETER (HALF=0.5D+0, ONE=1.D+0, ONEP2=1.2D+0, TWO=2.D+0,
     1           ZERO=0.D+0)
C/
C
C/6
C     DATA IRC/29/, MLSTGD/32/, MODEL/5/, NFCALL/6/, NFGCAL/7/,
C    1     RADINC/8/, RESTOR/9/, STAGE/10/, STGLIM/11/, SWITCH/12/,
C    2     TOOBIG/2/, XIRC/13/
C/7
      PARAMETER (IRC=29, MLSTGD=32, MODEL=5, NFCALL=6, NFGCAL=7,
     1           RADINC=8, RESTOR=9, STAGE=10, STGLIM=11, SWITCH=12,
     2           TOOBIG=2, XIRC=13)
C/
C/6
C     DATA AFCTOL/31/, DECFAC/22/, DSTNRM/2/, DST0/3/, DSTSAV/18/,
C    1     F/10/, FDIF/11/, FLSTGD/12/, F0/13/, GTSLST/14/, GTSTEP/4/,
C    2     INCFAC/23/, LMAXS/36/, NREDUC/6/, PLSTGD/15/, PREDUC/7/,
C    3     RADFAC/16/, RDFCMN/24/, RDFCMX/25/, RELDX/17/, RFCTOL/32/,
C    4     SCTOL/37/, STPPAR/5/, TUNER1/26/, TUNER2/27/, TUNER3/28/,
C    5     XCTOL/33/, XFTOL/34/
C/7
      PARAMETER (AFCTOL=31, DECFAC=22, DSTNRM=2, DST0=3, DSTSAV=18,
     1           F=10, FDIF=11, FLSTGD=12, F0=13, GTSLST=14, GTSTEP=4,
     2           INCFAC=23, LMAXS=36, NREDUC=6, PLSTGD=15, PREDUC=7,
     3           RADFAC=16, RDFCMN=24, RDFCMX=25, RELDX=17, RFCTOL=32,
     4           SCTOL=37, STPPAR=5, TUNER1=26, TUNER2=27, TUNER3=28,
     5           XCTOL=33, XFTOL=34)
C/
C
C+++++++++++++++++++++++++++++++  BODY  ++++++++++++++++++++++++++++++++
C
      NFC = IV(NFCALL)
      IV(SWITCH) = 0
      IV(RESTOR) = 0
      RFAC1 = ONE
      GOODX = .TRUE.
      I = IV(IRC)
      IF (I .GE. 1 .AND. I .LE. 12)
     1             GO TO (20,30,10,10,40,280,220,220,220,220,220,170), I
         IV(IRC) = 13
         GO TO 999
C
C  ***  INITIALIZE FOR NEW ITERATION  ***
C
 10   IV(STAGE) = 1
      IV(RADINC) = 0
      V(FLSTGD) = V(F0)
      IF (IV(TOOBIG) .EQ. 0) GO TO 110
         IV(STAGE) = -1
         IV(XIRC) = I
         GO TO 60
C
C  ***  STEP WAS RECOMPUTED WITH NEW MODEL OR SMALLER RADIUS  ***
C  ***  FIRST DECIDE WHICH  ***
C
 20   IF (IV(MODEL) .NE. IV(MLSTGD)) GO TO 30
C        ***  OLD MODEL RETAINED, SMALLER RADIUS TRIED  ***
C        ***  DO NOT CONSIDER ANY MORE NEW MODELS THIS ITERATION  ***
         IV(STAGE) = IV(STGLIM)
         IV(RADINC) = -1
         GO TO 110
C
C  ***  A NEW MODEL IS BEING TRIED.  DECIDE WHETHER TO KEEP IT.  ***
C
 30   IV(STAGE) = IV(STAGE) + 1
C
C     ***  NOW WE ADD THE POSSIBILITY THAT STEP WAS RECOMPUTED WITH  ***
C     ***  THE SAME MODEL, PERHAPS BECAUSE OF AN OVERSIZED STEP.     ***
C
 40   IF (IV(STAGE) .GT. 0) GO TO 50
C
C        ***  STEP WAS RECOMPUTED BECAUSE IT WAS TOO BIG.  ***
C
         IF (IV(TOOBIG) .NE. 0) GO TO 60
C
C        ***  RESTORE IV(STAGE) AND PICK UP WHERE WE LEFT OFF.  ***
C
         IV(STAGE) = -IV(STAGE)
         I = IV(XIRC)
         GO TO (20, 30, 110, 110, 70), I
C
 50   IF (IV(TOOBIG) .EQ. 0) GO TO 70
C
C  ***  HANDLE OVERSIZE STEP  ***
C
      IV(TOOBIG) = 0
      IF (IV(RADINC) .GT. 0) GO TO 80
         IV(STAGE) = -IV(STAGE)
         IV(XIRC) = IV(IRC)
C
 60      IV(TOOBIG) = 0
         V(RADFAC) = V(DECFAC)
         IV(RADINC) = IV(RADINC) - 1
         IV(IRC) = 5
         IV(RESTOR) = 1
         V(F) = V(FLSTGD)
         GO TO 999
C
 70   IF (V(F) .LT. V(FLSTGD)) GO TO 110
C
C     *** THE NEW STEP IS A LOSER.  RESTORE OLD MODEL.  ***
C
      IF (IV(MODEL) .EQ. IV(MLSTGD)) GO TO 80
         IV(MODEL) = IV(MLSTGD)
         IV(SWITCH) = 1
C
C     ***  RESTORE STEP, ETC. ONLY IF A PREVIOUS STEP DECREASED V(F).
C
 80   IF (V(FLSTGD) .GE. V(F0)) GO TO 110
         IF (IV(STAGE) .LT. IV(STGLIM)) THEN
            GOODX = .FALSE.
         ELSE IF (NFC .LT. IV(NFGCAL) + IV(STGLIM) + 2) THEN
            GOODX = .FALSE.
         ELSE IF (IV(SWITCH) .NE. 0) THEN
            GOODX = .FALSE.
            ENDIF
         IV(RESTOR) = 3
         V(F) = V(FLSTGD)
         V(PREDUC) = V(PLSTGD)
         V(GTSTEP) = V(GTSLST)
         IF (IV(SWITCH) .EQ. 0) RFAC1 = V(DSTNRM) / V(DSTSAV)
         V(DSTNRM) = V(DSTSAV)
         IF (GOODX) THEN
C
C     ***  ACCEPT PREVIOUS SLIGHTLY REDUCING STEP ***
C
            V(FDIF) = V(F0) - V(F)
            IV(IRC) = 4
            V(RADFAC) = RFAC1
            GO TO 999
            ENDIF
         NFC = IV(NFGCAL)
C
 110  V(FDIF) = V(F0) - V(F)
      IF (V(FDIF) .GT. V(TUNER2) * V(PREDUC)) GO TO 140
      IF (IV(RADINC) .GT. 0) GO TO 140
C
C        ***  NO (OR ONLY A TRIVIAL) FUNCTION DECREASE
C        ***  -- SO TRY NEW MODEL OR SMALLER RADIUS
C
         IF (V(F) .LT. V(F0)) GO TO 120
              IV(MLSTGD) = IV(MODEL)
              V(FLSTGD) = V(F)
              V(F) = V(F0)
              IV(RESTOR) = 1
              GO TO 130
 120     IV(NFGCAL) = NFC
 130     IV(IRC) = 1
         IF (IV(STAGE) .LT. IV(STGLIM)) GO TO 160
              IV(IRC) = 5
              IV(RADINC) = IV(RADINC) - 1
              GO TO 160
C
C  ***  NONTRIVIAL FUNCTION DECREASE ACHIEVED  ***
C
 140  IV(NFGCAL) = NFC
      RFAC1 = ONE
      V(DSTSAV) = V(DSTNRM)
      IF (V(FDIF) .GT. V(PREDUC)*V(TUNER1)) GO TO 190
C
C  ***  DECREASE WAS MUCH LESS THAN PREDICTED -- EITHER CHANGE MODELS
C  ***  OR ACCEPT STEP WITH DECREASED RADIUS.
C
      IF (IV(STAGE) .GE. IV(STGLIM)) GO TO 150
C        ***  CONSIDER SWITCHING MODELS  ***
         IV(IRC) = 2
         GO TO 160
C
C     ***  ACCEPT STEP WITH DECREASED RADIUS  ***
C
 150  IV(IRC) = 4
C
C  ***  SET V(RADFAC) TO FLETCHER*S DECREASE FACTOR  ***
C
 160  IV(XIRC) = IV(IRC)
      EMAX = V(GTSTEP) + V(FDIF)
      V(RADFAC) = HALF * RFAC1
      IF (EMAX .LT. V(GTSTEP)) V(RADFAC) = RFAC1 * DMAX1(V(RDFCMN),
     1                                           HALF * V(GTSTEP)/EMAX)
C
C  ***  DO FALSE CONVERGENCE TEST  ***
C
 170  IF (V(RELDX) .LE. V(XFTOL)) GO TO 180
         IV(IRC) = IV(XIRC)
         IF (V(F) .LT. V(F0)) GO TO 200
              GO TO 230
C
 180  IV(IRC) = 12
      GO TO 240
C
C  ***  HANDLE GOOD FUNCTION DECREASE  ***
C
 190  IF (V(FDIF) .LT. (-V(TUNER3) * V(GTSTEP))) GO TO 210
C
C     ***  INCREASING RADIUS LOOKS WORTHWHILE.  SEE IF WE JUST
C     ***  RECOMPUTED STEP WITH A DECREASED RADIUS OR RESTORED STEP
C     ***  AFTER RECOMPUTING IT WITH A LARGER RADIUS.
C
      IF (IV(RADINC) .LT. 0) GO TO 210
      IF (IV(RESTOR) .EQ. 1) GO TO 210
      IF (IV(RESTOR) .EQ. 3) GO TO 210
C
C        ***  WE DID NOT.  TRY A LONGER STEP UNLESS THIS WAS A NEWTON
C        ***  STEP.
C
         V(RADFAC) = V(RDFCMX)
         GTS = V(GTSTEP)
         IF (V(FDIF) .LT. (HALF/V(RADFAC) - ONE) * GTS)
     1            V(RADFAC) = DMAX1(V(INCFAC), HALF*GTS/(GTS + V(FDIF)))
         IV(IRC) = 4
         IF (V(STPPAR) .EQ. ZERO) GO TO 230
         IF (V(DST0) .GE. ZERO .AND. (V(DST0) .LT. TWO*V(DSTNRM)
     1             .OR. V(NREDUC) .LT. ONEP2*V(FDIF)))  GO TO 230
C             ***  STEP WAS NOT A NEWTON STEP.  RECOMPUTE IT WITH
C             ***  A LARGER RADIUS.
              IV(IRC) = 5
              IV(RADINC) = IV(RADINC) + 1
C
C  ***  SAVE VALUES CORRESPONDING TO GOOD STEP  ***
C
 200  V(FLSTGD) = V(F)
      IV(MLSTGD) = IV(MODEL)
      IF (IV(RESTOR) .EQ. 0) IV(RESTOR) = 2
      V(DSTSAV) = V(DSTNRM)
      IV(NFGCAL) = NFC
      V(PLSTGD) = V(PREDUC)
      V(GTSLST) = V(GTSTEP)
      GO TO 230
C
C  ***  ACCEPT STEP WITH RADIUS UNCHANGED  ***
C
 210  V(RADFAC) = ONE
      IV(IRC) = 3
      GO TO 230
C
C  ***  COME HERE FOR A RESTART AFTER CONVERGENCE  ***
C
 220  IV(IRC) = IV(XIRC)
      IF (V(DSTSAV) .GE. ZERO) GO TO 240
         IV(IRC) = 12
         GO TO 240
C
C  ***  PERFORM CONVERGENCE TESTS  ***
C
 230  IV(XIRC) = IV(IRC)
 240  IF (IV(RESTOR) .EQ. 1 .AND. V(FLSTGD) .LT. V(F0)) IV(RESTOR) = 3
      IF (DABS(V(F)) .LT. V(AFCTOL)) IV(IRC) = 10
      IF (HALF * V(FDIF) .GT. V(PREDUC)) GO TO 999
      EMAX = V(RFCTOL) * DABS(V(F0))
      EMAXS = V(SCTOL) * DABS(V(F0))
      IF (V(PREDUC) .LE. EMAXS .AND. (V(DSTNRM) .GT. V(LMAXS) .OR.
     1     V(STPPAR) .EQ. ZERO)) IV(IRC) = 11
      IF (V(DST0) .LT. ZERO) GO TO 250
      I = 0
      IF ((V(NREDUC) .GT. ZERO .AND. V(NREDUC) .LE. EMAX) .OR.
     1    (V(NREDUC) .EQ. ZERO. AND. V(PREDUC) .EQ. ZERO))  I = 2
      IF (V(STPPAR) .EQ. ZERO .AND. V(RELDX) .LE. V(XCTOL)
     1                        .AND. GOODX)                  I = I + 1
      IF (I .GT. 0) IV(IRC) = I + 6
C
C  ***  CONSIDER RECOMPUTING STEP OF LENGTH V(LMAXS) FOR SINGULAR
C  ***  CONVERGENCE TEST.
C
 250  IF (IV(IRC) .GT. 5 .AND. IV(IRC) .NE. 12) GO TO 999
      IF (V(STPPAR) .EQ. ZERO) GO TO 999
      IF (V(DSTNRM) .GT. V(LMAXS)) GO TO 260
         IF (V(PREDUC) .GE. EMAXS) GO TO 999
              IF (V(DST0) .LE. ZERO) GO TO 270
                   IF (HALF * V(DST0) .LE. V(LMAXS)) GO TO 999
                        GO TO 270
 260  IF (HALF * V(DSTNRM) .LE. V(LMAXS)) GO TO 999
      XMAX = V(LMAXS) / V(DSTNRM)
      IF (XMAX * (TWO - XMAX) * V(PREDUC) .GE. EMAXS) GO TO 999
 270  IF (V(NREDUC) .LT. ZERO) GO TO 290
C
C  ***  RECOMPUTE V(PREDUC) FOR USE IN SINGULAR CONVERGENCE TEST  ***
C
      V(GTSLST) = V(GTSTEP)
      V(DSTSAV) = V(DSTNRM)
      IF (IV(IRC) .EQ. 12) V(DSTSAV) = -V(DSTSAV)
      V(PLSTGD) = V(PREDUC)
      I = IV(RESTOR)
      IV(RESTOR) = 2
      IF (I .EQ. 3) IV(RESTOR) = 0
      IV(IRC) = 6
      GO TO 999
C
C  ***  PERFORM SINGULAR CONVERGENCE TEST WITH RECOMPUTED V(PREDUC)  ***
C
 280  V(GTSTEP) = V(GTSLST)
      V(DSTNRM) = DABS(V(DSTSAV))
      IV(IRC) = IV(XIRC)
      IF (V(DSTSAV) .LE. ZERO) IV(IRC) = 12
      V(NREDUC) = -V(PREDUC)
      V(PREDUC) = V(PLSTGD)
      IV(RESTOR) = 3
 290  IF (-V(NREDUC) .LE. V(SCTOL) * DABS(V(F0))) IV(IRC) = 11
C
 999  RETURN
C
C  ***  LAST LINE OF DA7SST FOLLOWS  ***
      END


      FUNCTION IUPBS3(MBAY,S3MNEM)

C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:    IUPBS3
C   PRGMMR: ATOR             ORG: NP12       DATE: 2009-03-23
C
C ABSTRACT: THIS FUNCTION UNPACKS AND RETURNS A SPECIFIED INTEGER VALUE
C   FROM SECTION 3 OF THE BUFR MESSAGE STORED IN ARRAY MBAY.  IT WILL
C   WORK ON ANY MESSAGE ENCODED USING BUFR EDITION 2, 3 OR 4.  THE START
C   OF THE BUFR MESSAGE (I.E. THE STRING "BUFR") MUST BE ALIGNED ON THE
C   FIRST FOUR BYTES OF MBAY, AND THE VALUE TO BE UNPACKED IS SPECIFIED
C   VIA THE MNEMONIC S3MNEM, AS EXPLAINED IN FURTHER DETAIL BELOW.
C
C PROGRAM HISTORY LOG:
C 2009-03-23  J. ATOR    -- ORIGINAL AUTHOR
C
C USAGE:    IUPBS3 (MBAY, S3MNEM)
C   INPUT ARGUMENT LIST:
C     MBAY     - INTEGER: *-WORD PACKED BINARY ARRAY CONTAINING
C                BUFR MESSAGE
C     S3MNEM   - CHARACTER*(*): MNEMONIC SPECIFYING VALUE TO BE
C                UNPACKED FROM SECTION 3 OF BUFR MESSAGE:
C                  'NSUB'  = NUMBER OF DATA SUBSETS
C                  'IOBS'  = FLAG INDICATING WHETHER THE MESSAGE
C                            CONTAINS OBSERVED DATA:
C                              0 = NO
C                              1 = YES
C                  'ICMP'  = FLAG INDICATING WHETHER THE MESSAGE
C                            CONTAINS COMPRESSED DATA:
C                              0 = NO
C                              1 = YES
C
C   OUTPUT ARGUMENT LIST:
C     IUPBS3   - INTEGER: UNPACKED INTEGER VALUE
C                  -1 = THE INPUT S3MNEM MNEMONIC WAS INVALID
C
C REMARKS:
C    THIS ROUTINE CALLS:        GETLENS  IUPB
C    THIS ROUTINE IS CALLED BY: CKTABA   CPDXMM   DUMPBF   MESGBC
C                               RDBFDX   READERME STNDRD   WRITLC
C                               Also called by application programs.
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 77
C   MACHINE:  PORTABLE TO ALL PLATFORMS
C
C$$$

	DIMENSION	MBAY(*)

	CHARACTER*(*)	S3MNEM

C-----------------------------------------------------------------------
C-----------------------------------------------------------------------

C	Call subroutine WRDLEN to initialize some important information
C	about the local machine, just in case subroutine OPENBF hasn't
C	been called yet.

	CALL WRDLEN

C	Skip to the beginning of Section 3.

	CALL GETLENS(MBAY,3,LEN0,LEN1,LEN2,LEN3,L4,L5)
	IPT = LEN0 + LEN1 + LEN2

C	Unpack the requested value.

	IF(S3MNEM.EQ.'NSUB') THEN
	    IUPBS3 = IUPB(MBAY,IPT+5,16)
	ELSE IF( (S3MNEM.EQ.'IOBS') .OR. (S3MNEM.EQ.'ICMP') ) THEN
	    IVAL = IUPB(MBAY,IPT+7,8)
	    IF(S3MNEM.EQ.'IOBS') THEN
		IMASK = 128
	    ELSE
		IMASK = 64
	    ENDIF
	    IUPBS3 = MIN(1,IAND(IVAL,IMASK))
	ELSE
	    IUPBS3 = -1
	ENDIF

	RETURN
	END


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE BCROSS (MXND, MLN, XN, YN, ZN, LXK, KXL, NXL, LXN,
     &   LNODES, I1, I2, J1, J2, NLOOP, BOK, LLL, XMIN, XMAX, YMIN,
     &   YMAX, ZMIN, ZMAX, DEV1, KREG, ERR)
C***********************************************************************

C  SUBROUTINE BCROSS = CHECKS TO MAKE SURE THAT A BOUNDARY IS NOT
C                      BECOMING A PERMANENT CROSS

C***********************************************************************

      DIMENSION XN(MXND), YN(MXND), ZN(MXND)
      DIMENSION NXL(2, 3*MXND), LXN(4, MXND)
      DIMENSION LXK(4, MXND), KXL(2, 3*MXND)
      DIMENSION LNODES(MLN, MXND)

      LOGICAL BOK, LCROSS, ERR

      CHARACTER*3 DEV1

      BOK = .TRUE.
      ERR = .FALSE.

      J0 = LNODES(2, J1)
      J3 = LNODES(3, J2)

C  IF J0 TO I2, OR J3 TO I1 IS TO BECOME A BOUNDARY LINE,
C  THEN TEST THE CONNECTION TO SEE IF IT INTERSECTS ANY OTHER
C  BOUNDARY LINES

      KOUNT = 0

C  FIRST TEST THE J0 TO I2 LINE

      IF ((LXN(2, J0) .LT. 0) .AND. (LXN(2, I2) .LT. 0)) THEN
         NODE1 = I1
         NODE2 = I2
  100    CONTINUE
         NODE1 = NODE2
         NODE2 = LNODES(3, NODE2)
         IF ((LXN(2, NODE1) .LT. 0) .AND. (LXN(2, NODE2) .LT. 0)) THEN
            IF (NODE2 .EQ. J0) THEN
               CALL GETANG (MXND, MLN, XN, YN, LNODES, LXK, KXL,
     &            NXL, LXN, NODE1, J0, J1, ANGLE, ERR)
               IF (ANGLE .LT. 0) THEN
                  BOK = .FALSE.
                  GOTO 130
               ELSE
                  GOTO 110
               ENDIF

            ELSE
               CALL INTSCT (XN(NODE1), YN(NODE1), XN(NODE2), YN(NODE2),
     &            XN(J0), YN(J0), XN(I2), YN(I2), U, W, LCROSS)
               IF (LCROSS) THEN
                  BOK = .FALSE.
                  GOTO 130
               ENDIF
            ENDIF
         ENDIF
         KOUNT = KOUNT + 1
         IF (KOUNT .LT. NLOOP) THEN
            GOTO 100
         ELSE
            ERR = .TRUE.
            GOTO 130
         ENDIF
      ENDIF

  110 CONTINUE

C  NEXT TEST THE J3 TO I1 LINE

      KOUNT = 0
      IF ((LXN(2, J3) .LT. 0) .AND. (LXN(2, I1) .LT. 0)) THEN
         NODE1 = J3
         NODE2 = LNODES(3, J3)
  120    CONTINUE
         NODE1 = NODE2
         NODE2 = LNODES(3, NODE2)
         IF ((LXN(2, NODE1) .LT. 0) .AND. (LXN(2, NODE2) .LT. 0)) THEN
            IF (NODE2 .EQ. I1) THEN
               CALL GETANG (MXND, MLN, XN, YN, LNODES, LXK, KXL,
     &            NXL, LXN, NODE1, I1, I2, ANGLE, ERR)
               IF (ANGLE .LT. 0) THEN
                  BOK = .FALSE.
                  GOTO 130
               ELSE
                  GOTO 130
               ENDIF

            ELSE
               CALL INTSCT (XN(NODE1), YN(NODE1), XN(NODE2), YN(NODE2),
     &            XN(J3), YN(J3), XN(I1), YN(I1), U, W, LCROSS)
               IF (LCROSS) THEN
                  BOK = .FALSE.
                  GOTO 130
               ENDIF
            ENDIF
         ENDIF
         KOUNT = KOUNT + 1
         IF (KOUNT .LT. NLOOP) THEN
            GOTO 120
         ELSE
            ERR = .TRUE.
            GOTO 130
         ENDIF
      ENDIF

  130 CONTINUE

      RETURN

      END


!
! Copyright (C) 2013 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!----------------------------------------------------------------------------
SUBROUTINE run_driver ( srvaddress, exit_status )
  !! author: Paolo Giannozzi
  !! license: GNU
  !! summary: Run an instance of the Plane Wave Self-Consistent Field code
  !!
  !! Run an instance of the Plane Wave Self-Consistent Field code
  !! MPI initialization and input data reading is performed in the
  !! calling code - returns in exit_status the exit code for pw.x,
  !! returned in the shell. Values are:
  !! * 0: completed successfully
  !! * 1: an error has occurred (value returned by the errore() routine)
  !! * 2-127: convergence error
  !!   * 2: scf convergence error
  !!   * 3: ion convergence error
  !! * 128-255: code exited due to specific trigger
  !!   * 255: exit due to user request, or signal trapped,
  !!          or time > max_seconds
  !!     (note: in the future, check_stop_now could also return a value
  !!     to specify the reason of exiting, and the value could be used
  !!     to return a different value for different reasons)
  !! Will be eventually merged with NEB
  !!
  !! @Note
  !! 10/01/17 Samuel Ponce: Add Ford documentation
  !! @endnote
  !!
  !!
  USE io_global,        ONLY : stdout, ionode, ionode_id
  USE parameters,       ONLY : ntypx, npk, lmaxx
  USE check_stop,       ONLY : check_stop_init
  USE mp_global,        ONLY : mp_bcast, mp_global_end, intra_image_comm
  USE control_flags,    ONLY : gamma_only, conv_elec, istep, ethr, lscf, lmd
  USE cellmd,           ONLY : lmovecell
  USE force_mod,        ONLY : lforce, lstres
  USE ions_base,        ONLY : tau
  USE cell_base,        ONLY : alat, at, omega, bg
  USE cellmd,           ONLY : omega_old, at_old, calc
  USE force_mod,        ONLY : force
  USE ener,             ONLY : etot
  USE f90sockets,       ONLY : readbuffer, writebuffer
  USE extrapolation,    ONLY : update_file, update_pot
  USE qmmm,             ONLY : qmmm_mode, qmmm_initialization, set_mm_natoms, &
                               set_qm_natoms, set_ntypes, set_cell_mm, &
                               read_mm_charge, read_mm_mask, read_mm_coord, &
                               read_types, read_mass, write_ec_force, &
                               write_mm_force, qmmm_center_molecule, &
                               qmmm_minimum_image, read_aradii
  USE scf,              ONLY : rho
  USE lsda_mod,         ONLY : nspin
  USE fft_base,         ONLY : dfftp
  !
  IMPLICIT NONE
  INTEGER, INTENT(OUT) :: exit_status
  !! Gives the exit status at the end
  CHARACTER(*), INTENT(IN) :: srvaddress
  !! Gives the socket address
  !
  ! Local variables
  INTEGER, PARAMETER :: MSGLEN=12
  REAL*8, PARAMETER :: gvec_omega_tol= 1.0D-1
  LOGICAL :: isinit=.false., hasdata=.false., firststep=.true., exst, lgreset
  CHARACTER*12 :: header
  CHARACTER*1024 :: parbuffer
  INTEGER :: socket, nat, rid, ccmd, i, info, rid_old=-1
  REAL*8 :: sigma(3,3), omega_reset, at_reset(3,3), dist_reset, ang_reset
  REAL *8 :: cellh(3,3), cellih(3,3), vir(3,3), pot, mtxbuffer(9)
  REAL*8, ALLOCATABLE :: combuf(:)
  REAL*8 :: dist_ang(6), dist_ang_reset(6)
  !----------------------------------------------------------------------------
  !
  lscf      = .true.
  lforce    = .true.
  lstres    = .true.
  lmd       = .true.
  lmovecell = .true.
  !
  exit_status = 0
  IF ( ionode ) WRITE( unit = stdout, FMT = 9010 ) ntypx, npk, lmaxx
  !
  !<<<
  WRITE(6,*)'At start of run_driver'
  !>>>
  IF (ionode) CALL plugin_arguments()
  !<<<
  WRITE(6,*)'Calling plugin_arguments_bcast'
  !>>>
  CALL plugin_arguments_bcast( ionode_id, intra_image_comm )
  !
  ! ... needs to come before iosys() so some input flags can be
  !     overridden without needing to write PWscf specific code.
  !
  ! ... convert to internal variables
  !
  !<<<
  WRITE(6,*)'Calling iosys'
  !>>>
  CALL iosys()
  !
  IF ( gamma_only ) WRITE( UNIT = stdout, &
       & FMT = '(/,5X,"gamma-point specific algorithms are used")' )
  !
  ! call to void routine for user defined / plugin patches initializations
  !
  !<<<
  WRITE(6,*)'Calling plugin_initialization'
  !>>>
  CALL plugin_initialization()
  !
  CALL check_stop_init()
  !
  ! ... We do a fake run so that the G vectors are initialized
  ! ... based on the pw input. This is needed to guarantee smooth energy
  ! ... upon PW restart in NPT runs. Probably can be done in a smarter way
  ! ... but we have to figure out how...
  !
  ! call setup()
  ! call init_run()
  !<<<
  WRITE(6,*)'Doing initialization work'
  !>>>
  CALL initialize_g_vectors
  !<<<
  ! the iPI interfaceran an SCF calculation here, but that is no longer necessary
  !CALL electrons()
  !>>>
  CALL update_file()
  !<<<
  WRITE(6,*)'Calling create socket'
  !>>>
  !
  IF (ionode) CALL create_socket(srvaddress)
  !<<<
  WRITE(6,*)'Finished calling create socket'
  !>>>
  !
  driver_loop: DO
     !
     IF ( ionode ) CALL readbuffer(socket, header, MSGLEN)
     CALL mp_bcast( header, ionode_id, intra_image_comm )
     !
     IF ( ionode ) write(*,*) " @ DRIVER MODE: Message from server: ", trim( header )
     !
     SELECT CASE ( trim( header ) )
     CASE( "STATUS" )
        !
        IF (ionode) THEN
           IF (hasdata) THEN
              CALL writebuffer( socket, "HAVEDATA    ", MSGLEN )
           ELSE IF (isinit) THEN
              CALL writebuffer( socket, "READY       ", MSGLEN )
           ELSE IF (.not. isinit) THEN
              CALL writebuffer( socket, "NEEDINIT    ", MSGLEN )
           ELSE
              exit_status = 129
              RETURN
           END IF
        END IF
        !
     CASE( "INIT" )
        CALL driver_init()
        isinit=.true.
        !
     CASE( "POSDATA" )
        CALL driver_posdata()
        hasdata=.true.
        !
     CASE( "GETFORCE" )
        CALL driver_getforce()
        !
        ! ... resets init to get replica index again at next step
        !
        isinit = .false.
        hasdata=.false.
        firststep = .false.
        !
     !<<<
     CASE( ">RID" )
        CALL set_replica_id()
        isinit=.true.
        !
     CASE( ">NAT" )
        CALL set_nat()
        !
     CASE( ">MM_NAT" )
        CALL read_nat_mm()
        !
     CASE( ">NTYPES" )
        CALL read_ntypes()
        !
     CASE( ">CELL" )
        CALL read_cell()
        CALL update_cell()
        !
     CASE( ">COORD" )
        CALL read_coordinates()
        !
     CASE( ">QMMM_MODE" )
        CALL read_qmmm_mode()
        !
     CASE( ">MM_CELL" )
        CALL read_cell_mm()
        !
     CASE( ">MM_CHARGE" )
        CALL read_mm_charge(socket)
        !
     CASE( ">MM_MASK" )
        CALL read_mm_mask(socket)
        !
     CASE( ">MM_COORD" )
        CALL read_mm_coord(socket)
        !
     CASE( ">MM_TYPE" )
        CALL read_types(socket)
        !
     CASE( ">MM_MASS" )
        CALL read_mass(socket)
        !
     CASE( ">ARADII" )
        CALL read_aradii(socket)
        !
     CASE( "RECENTER" )
        CALL qmmm_center_molecule()
        CALL qmmm_minimum_image()
        IF ( ionode ) WRITE(*,*) " @ DRIVER MODE: recentered coords ",tau
        !
     CASE( "SCF" )
        CALL run_scf()
        !
     CASE( "<ENERGY" )
        CALL write_energy()
        !
     CASE( "<FORCE" )
        CALL write_forces()
        !
     CASE( "<EC_FORCE" )
        CALL write_ec_force(socket)
        !
     CASE( "<MM_FORCE" )
        CALL write_mm_force(socket, rho%of_r, nspin, dfftp)
        !
     CASE( "EXIT" )
        exit_status = 0
        RETURN
        !
     !>>>
     CASE DEFAULT
        exit_status = 130
        RETURN
     END SELECT
     !
  END DO driver_loop
  !
9010 FORMAT( /,5X,'Current dimensions of program PWSCF are:', &
          & /,5X,'Max number of different atomic species (ntypx) = ',I2,&
          & /,5X,'Max number of k-points (npk) = ',I6,&
          & /,5X,'Max angular momentum in pseudopotentials (lmaxx) = ',i2)
  !
CONTAINS
  !
  !
  SUBROUTINE create_socket (srvaddress)
    USE f90sockets,       ONLY : open_socket
    IMPLICIT NONE
    CHARACTER(*), INTENT(IN)  :: srvaddress
    CHARACTER(256) :: address
    INTEGER :: port, inet, field_sep_pos
    !
    ! ... Parses host name, port and socket type
    field_sep_pos = INDEX(srvaddress,':',back=.true.)
    address = srvaddress(1:field_sep_pos-1)
    !
    ! ... Check if UNIX type socket
    IF ( trim(srvaddress(field_sep_pos+1 :)) == 'UNIX' ) then
       !<<<
       WRITE(6,*)'Opening a unix socket'
       !>>>
       port = 1234 ! place-holder
       inet = 0
       write(*,*) " @ DRIVER MODE: Connecting to ", trim(address), " using UNIX socket"
    ELSE
       !<<<
       WRITE(6,*)'Opening a TCP socket'
       !>>>
       read ( srvaddress ( field_sep_pos+1 : ), * ) port
       inet = 1
       write(*,*) " @ DRIVER MODE: Connecting to ", trim ( address ), &
                  ":", srvaddress ( field_sep_pos+1 : )
       !<<<
       write(6,*) " @ DRIVER MODE: Connecting to ", trim ( address ), &
                  ":", srvaddress ( field_sep_pos+1 : )
       !>>>
    END IF
    !
    ! ... Create the socket
    !<<<
    WRITE(6,*)'Calling open_socket'
    !>>>
    CALL open_socket ( socket, inet, port, trim(address)//achar(0) )
    !<<<
    WRITE(6,*)'Finished calling open_socket'
    !>>>
    !
  END SUBROUTINE create_socket
  !
  !
  SUBROUTINE driver_init()
    !
    ! ... Check if the replica id (rid) is the same as in the last run
    !
    IF ( ionode ) CALL readbuffer( socket, rid )
    CALL mp_bcast( rid, ionode_id, intra_image_comm )
    !
    IF ( ionode ) WRITE(*,*) " @ DRIVER MODE: Receiving replica", rid, rid_old
    IF ( rid .NE. rid_old .AND. .NOT. firststep ) THEN
       !
       ! ... If a different replica reset the history
       ! ... the G-vectors will be reinitialized only if needed!
       ! ... see lgreset below
       !
       IF ( ionode ) write(*,*) " @ DRIVER MODE: Resetting scf history "
       CALL close_files(.TRUE.)
    END IF
    !
    rid_old = rid
    !
    IF ( ionode ) THEN
       !
       ! ... Length of parameter string -- ignored at present!
       !
       CALL readbuffer( socket, nat )
       CALL readbuffer( socket, parbuffer, nat )
    END IF
    !
  END SUBROUTINE driver_init
  !
  !
  SUBROUTINE driver_posdata()
    !
    ! ... Receives the positions & the cell data
    !
    !
    IF ( .NOT. firststep) THEN
       at_old = at
       omega_old = omega
    END IF
    !
    ! ... Read the atomic position from ipi and share to all processes
    !
    CALL read_and_share()
    !
    IF ( ionode ) WRITE(*,*) " @ DRIVER MODE: Received positions "
    !
    ! ... Recompute cell data
    !
    CALL recips( at(1,1), at(1,2), at(1,3), bg(1,1), bg(1,2), bg(1,3) )
    CALL volume( alat, at(1,1), at(1,2), at(1,3), omega )
    !
    ! ... Check if the cell is changed too much and in that case reset the
    ! ... g-vectors
    !
    lgreset = ( ABS ( omega_reset - omega ) / omega .GT. gvec_omega_tol )
    !
    ! ... Initialize the G-Vectors when needed
    !
    IF ( lgreset ) THEN
       !
       ! ... Reinitialize the G-Vectors if the cell is changed
       !
       CALL initialize_g_vectors()
       !
    ELSE
       !
       ! ... Update only atomic position and potential from the history
       ! ... if the cell did not change too much
       !
       CALL update_pot()
       CALL hinit1()
    END IF
    !
    ! ... Compute everything
    !
    CALL electrons()
    IF ( .NOT. conv_elec ) THEN
       CALL punch( 'all' )
       CALL stop_run( conv_elec )
    ENDIF
    CALL forces()
    CALL stress(sigma)
    !
    ! ... Converts energy & forces to the format expected by i-pi
    ! ... (so go from Ry to Ha)
    !
    combuf=RESHAPE(force, (/ 3 * nat /) ) * 0.5   ! force in a.u.
    pot=etot * 0.5                                ! potential in a.u.
    vir=TRANSPOSE( sigma ) * omega * 0.5          ! virial in a.u & no omega scal.
    !
    ! ... Updates history
    !
    istep = istep+1
    CALL update_file()
    !
  END SUBROUTINE driver_posdata
  !
  !
  SUBROUTINE driver_getforce()
    !
    ! ... communicates energy info back to i-pi
    !
    IF ( ionode ) WRITE(*,*) " @ DRIVER MODE: Returning v,forces,stress "
    IF ( ionode ) CALL writebuffer( socket, "FORCEREADY  ", MSGLEN)
    IF ( ionode ) CALL writebuffer( socket, pot)
    IF ( ionode ) CALL writebuffer( socket, nat)
    IF ( ionode ) CALL writebuffer( socket, combuf, 3 * nat)
    IF ( ionode ) CALL writebuffer( socket, RESHAPE( vir, (/9/) ), 9)
    !
    ! ... Note: i-pi can also receive an arbitrary string, that will be printed
    ! ... out to the "extra" trajectory file. This is useful if you want to
    ! ... return additional information, e.g. atomic charges, wannier centres,
    ! ... etc. one must return the number of characters, then the string. Here
    ! .... we just send back zero characters.
    !
    nat = 0
    IF ( ionode ) CALL writebuffer( socket, nat )
    CALL punch( 'config' )
    !
  END SUBROUTINE driver_getforce
  !
  !
  SUBROUTINE read_and_share()
    ! ... First reads cell and the number of atoms
    !
    IF ( ionode ) CALL readbuffer(socket, mtxbuffer, 9)
    cellh = RESHAPE(mtxbuffer, (/3,3/))
    IF ( ionode ) CALL readbuffer(socket, mtxbuffer, 9)
    cellih = RESHAPE(mtxbuffer, (/3,3/))
    IF ( ionode ) CALL readbuffer(socket, nat)
    !
    ! ... Share the received data
    !
    CALL mp_bcast( cellh,  ionode_id, intra_image_comm )
    CALL mp_bcast( cellih, ionode_id, intra_image_comm )
    CALL mp_bcast(    nat, ionode_id, intra_image_comm )
    !
    ! ... Allocate the dummy array for the atoms coordinate and share it
    !
    IF ( .NOT. ALLOCATED( combuf ) ) THEN
       ALLOCATE( combuf( 3 * nat ) )
    END IF
    IF ( ionode ) CALL readbuffer(socket, combuf, nat*3)
    CALL mp_bcast( combuf, ionode_id, intra_image_comm)
    !
    ! ... Convert the incoming configuration to the internal pwscf format
    !
    cellh  = TRANSPOSE(  cellh )                 ! row-major to column-major
    cellih = TRANSPOSE( cellih )
    tau = RESHAPE( combuf, (/ 3 , nat /) )/alat  ! internally positions are in alat
    at = cellh / alat                            ! and so the cell
    !
  END SUBROUTINE read_and_share
  !<<<
  !
  !
  SUBROUTINE set_replica_id()
    !
    ! ... Check if the replica id (rid) is the same as in the last run
    !
    IF ( ionode ) CALL readbuffer( socket, rid )
    CALL mp_bcast( rid, ionode_id, intra_image_comm )
    !
    IF ( ionode ) WRITE(*,*) " @ DRIVER MODE: Receiving replica", rid, rid_old
    IF ( rid .NE. rid_old .AND. .NOT. firststep ) THEN
       !
       ! ... If a different replica reset the history
       ! ... the G-vectors will be reinitialized only if needed!
       ! ... see lgreset below
       !
       IF ( ionode ) write(*,*) " @ DRIVER MODE: Resetting scf history "
       CALL close_files(.TRUE.)
    END IF
    !
    rid_old = rid
    !
  END SUBROUTINE set_replica_id
  !
  !
  SUBROUTINE set_nat()
    ! ... Reads the number of atoms
    !
    IF ( ionode ) CALL readbuffer(socket, nat)
    CALL mp_bcast(    nat, ionode_id, intra_image_comm )
    !
    ! ... Allocate the dummy array for the atoms coordinates
    !
    IF ( .NOT. ALLOCATED( combuf ) ) THEN
       ALLOCATE( combuf( 3 * nat ) )
    END IF
    !
    IF ( ionode ) write(*,*) " @ DRIVER MODE: Read number of atoms: ",nat
    !
    CALL set_qm_natoms(nat)
    !
  END SUBROUTINE set_nat
  !
  !
  SUBROUTINE read_nat_mm()
    INTEGER :: natoms_in
    ! ... Reads the number of mm atoms
    !
    IF ( ionode ) CALL readbuffer(socket, natoms_in)
    !
    IF ( ionode ) write(*,*) " @ DRIVER MODE: Read mm natoms: ",natoms_in
    !
    CALL set_mm_natoms(natoms_in)
    !
  END SUBROUTINE read_nat_mm
  !
  !
  SUBROUTINE read_ntypes()
    INTEGER :: ntypes_in
    ! ... Reads the number of atom types
    !
    IF ( ionode ) CALL readbuffer(socket, ntypes_in)
    !
    IF ( ionode ) write(*,*) " @ DRIVER MODE: Read ntypes: ",ntypes_in
    !
    CALL set_ntypes(ntypes_in)
    !
  END SUBROUTINE read_ntypes
  !
  !
  SUBROUTINE read_qmmm_mode()
    ! ... Reads the number of atoms
    !
    IF ( ionode ) CALL readbuffer(socket, qmmm_mode)
    CALL mp_bcast( qmmm_mode, ionode_id, intra_image_comm )
    !
    IF ( ionode ) write(*,*) " @ DRIVER MODE: Read qmmm mode: ",qmmm_mode
    !
    CALL qmmm_initialization()
    !
  END SUBROUTINE read_qmmm_mode
  !
  !
  SUBROUTINE read_cell()
    !
    IF ( ionode ) WRITE(*,*) " @ DRIVER MODE: Reading cell "
    !
    IF ( .NOT. firststep) THEN
       at_old = at
       omega_old = omega
    END IF
    !
    ! ... First reads cell and the number of atoms
    !
    IF ( ionode ) CALL readbuffer(socket, mtxbuffer, 9)
    IF ( ionode ) WRITE(*,*) " @ DRIVER MODE: Received cell "
    IF ( ionode ) WRITE(*,*) " @ DRIVER MODE: mtxbuffer: ",mtxbuffer
    cellh = RESHAPE(mtxbuffer, (/3,3/))
    !
    ! ... Share the received data
    !
    CALL mp_bcast( cellh,  ionode_id, intra_image_comm )
    IF ( ionode ) WRITE(*,*) " @ DRIVER MODE: cellh: ",cellh
    !
    ! ... Convert the incoming configuration to the internal pwscf format
    !
    cellh  = TRANSPOSE(  cellh )                 ! row-major to column-major
    IF ( ionode ) WRITE(*,*) " @ DRIVER MODE: alat ",alat
    IF ( ionode ) WRITE(*,*) " @ DRIVER MODE: at before ",at
    at = cellh / alat                            ! internally cell is in alat
    IF ( ionode ) WRITE(*,*) " @ DRIVER MODE: at after ",at
    !
  END SUBROUTINE read_cell
  !
  !
  SUBROUTINE update_cell()
    !
    IF ( ionode ) WRITE(*,*) " @ DRIVER MODE: Updating cell "
    !
    ! ... Recompute cell data
    !
    CALL recips( at(1,1), at(1,2), at(1,3), bg(1,1), bg(1,2), bg(1,3) )
    CALL volume( alat, at(1,1), at(1,2), at(1,3), omega )
    !
    ! ... Check if the cell is changed too much and in that case reset the
    ! ... g-vectors
    !
    lgreset = ( ABS ( omega_reset - omega ) / omega .GT. gvec_omega_tol )
    !
  END SUBROUTINE update_cell
  !
  !
  SUBROUTINE read_cell_mm()
    !
    IF ( ionode ) WRITE(*,*) " @ DRIVER MODE: Reading MM cell "
    !
    ! ... Read the dimensions of the MM cell
    !
    IF ( ionode ) CALL readbuffer(socket, mtxbuffer, 9)
    !
    CALL set_cell_mm(mtxbuffer)
    !
  END SUBROUTINE read_cell_mm
  !
  !
  SUBROUTINE read_coordinates()
    !
    IF ( ionode ) WRITE(*,*) " @ DRIVER MODE: Reading coordinates "
    !
    ! ... Read the atoms coordinates and share them
    !
    IF ( ionode ) CALL readbuffer(socket, combuf, nat*3)
    CALL mp_bcast( combuf, ionode_id, intra_image_comm)
    !
    WRITE(6,*)" @ DRIVER MODE: input coordinates"
    DO i=1, nat
       WRITE(6,*)i,combuf(i*3+0),combuf(i*3+1),combuf(i*3+2)
    END DO
    !
    ! ... Convert the incoming configuration to the internal pwscf format
    !
    IF ( ionode ) WRITE(*,*) " @ DRIVER MODE: old coords ",tau
    tau = RESHAPE( combuf, (/ 3 , nat /) )/alat  ! internally positions are in alat
    IF ( ionode ) WRITE(*,*) " @ DRIVER MODE: new coords ",tau
    !
  END SUBROUTINE read_coordinates
  !NOTE:
  !ALSO NEED qm_charge, mm_charge_all, mm_coord_all, mm_mask_all, type, mass
  !
  !
  SUBROUTINE run_scf()
    !
    ! ... Initialize the G-Vectors when needed
    !
    IF ( lgreset ) THEN
       !
       ! ... Reinitialize the G-Vectors if the cell is changed
       !
       CALL initialize_g_vectors()
       !<<<
       !lgreset = .false.
       !>>>
       !
    ELSE
       !
       ! ... Update only atomic position and potential from the history
       ! ... if the cell did not change too much
       !
       CALL update_pot()
       CALL hinit1()
    END IF
    !
    ! ... Run an scf calculation
    !
    CALL electrons()
    IF ( .NOT. conv_elec ) THEN
       CALL punch( 'all' )
       CALL stop_run( conv_elec )
    ENDIF
    !
  END SUBROUTINE run_scf
  !
  !
  SUBROUTINE write_energy()
    !
    ! ... Write the total energy in a.u.
    !
    IF ( ionode ) WRITE(*,*) " @ DRIVER MODE: Sending energy: ",0.5*etot
    IF ( ionode ) CALL writebuffer(socket, 0.5*etot)
    !
  END SUBROUTINE write_energy
  !
  !
  SUBROUTINE write_forces()
    !
    ! ... Compute forces
    !
    CALL forces()
    !
    ! ... Converts forces to a.u.
    ! ... (so go from Ry to Ha)
    !
    combuf=RESHAPE(force, (/ 3 * nat /) ) * 0.5   ! force in a.u.
    !
    ! ... Write the forces
    !
    IF ( ionode ) CALL writebuffer( socket, combuf, 3 * nat)
    !
  END SUBROUTINE write_forces
  !>>>
  !
  !
  SUBROUTINE initialize_g_vectors()
    !
    IF (ionode) THEN
       IF (firststep) WRITE(*,*) " @ DRIVER MODE: initialize G-vectors "
       IF (lgreset .AND. .NOT. firststep ) WRITE(*,*) &
            " @ DRIVER MODE: reinitialize G-vectors "
    END IF
    !
    ! ... Keep trace of the last time the gvectors have been initialized
    !
    IF ( firststep ) CALL setup()
    !
    ! ... Reset the history
    !
    CALL clean_pw( .FALSE. )
    IF ( .NOT. firststep) CALL close_files(.TRUE.)
    !
    CALL init_run()
    !
    CALL mp_bcast( at,        ionode_id, intra_image_comm )
    CALL mp_bcast( at_old,    ionode_id, intra_image_comm )
    CALL mp_bcast( omega,     ionode_id, intra_image_comm )
    CALL mp_bcast( omega_old, ionode_id, intra_image_comm )
    CALL mp_bcast( bg,        ionode_id, intra_image_comm )
    !
    omega_reset = omega
    dist_ang_reset = dist_ang
    !<<<
    !
    lgreset = .false.
    !>>>
    !
  END SUBROUTINE initialize_g_vectors
  !
END SUBROUTINE run_driver


      subroutine json_read_pot(mpot, nph, ntitle, ihole, ipr1, iafolp,
     1       ixc, ispec, nmix, nohole, jumprm, inters, nscmt, icoul,
     2       lfms1, iunf, gamach, rgrd, ca1, ecv, totvol, rfms1,
     3       title, iz, lmaxsc, xnatph, xion, folp, novr,
     4       iphovr, nnovr, rovr )

      use json_module
      implicit double precision (a-h, o-z)
      logical :: found
      character*7 vname
      type(json_file) :: json   !the JSON structure read from the file:
      double precision toss
      integer,dimension(:),allocatable :: intgs
      character*80,dimension(:),allocatable :: strings
      double precision,dimension(:),allocatable :: dbpcs

      include '../HEADERS/const.h'
      include '../HEADERS/dim.h'

cc    mod1.inp
        character*80 title(nheadx)
c        character*80 head(nheadx)
c        integer lhead(nheadx)
        integer mpot, nph, ntitle, ihole, ipr1, iafolp, ixc, ispec,
     1     iunf, nmix, nohole, jumprm, inters, nscmt, icoul, lfms1
        integer iz(0:nphx), lmaxsc(0:nphx)
        real rfms1
        double precision gamach, rgrd, ca1, ecv, totvol
        double precision  xnatph(0:nphx), folp(0:nphx), xion(0:nphx)
c       for OVERLAP option
        integer novr(0:nphx), iphovr(novrx,0:nphx), nnovr(novrx,0:nphx)
        double precision  rovr(novrx,0:nphx)

      call json%load_file('pot.json')
      if (json_failed()) then   !if there was an error reading the file
         print *, "failed to read pot.json"
         stop
      else
         call json%get('mpot',   mpot, found)
                   if (.not. found) call bailout('mpot', 'pot.json')
         call json%get('nph',    nph, found)
                   if (.not. found) call bailout('nph', 'pot.json')
         call json%get('ntitle', ntitle, found)
                   if (.not. found) call bailout('ntitle', 'pot.json')
         call json%get('ihole',  ihole, found)
                   if (.not. found) call bailout('ihole', 'pot.json')
         call json%get('ipr1',   ipr1, found)
                   if (.not. found) call bailout('ipr1', 'pot.json')
         call json%get('iafolp', iafolp, found)
                   if (.not. found) call bailout('iafolp', 'pot.json')
         call json%get('ixc',    ixc, found)
                   if (.not. found) call bailout('ixc', 'pot.json')
         call json%get('ispec',  ispec, found)
                   if (.not. found) call bailout('ispec', 'pot.json')

         call json%get('nmix',   nmix, found)
                   if (.not. found) call bailout('nmix', 'pot.json')
         call json%get('nohole', nohole, found)
                   if (.not. found) call bailout('nohole', 'pot.json')
         call json%get('jumprm', jumprm, found)
                   if (.not. found) call bailout('jumprm', 'pot.json')
         call json%get('inters', inters, found)
                   if (.not. found) call bailout('inters', 'pot.json')
         call json%get('nscmt',  nscmt, found)
                   if (.not. found) call bailout('nscmt', 'pot.json')
         call json%get('icoul',  icoul, found)
                   if (.not. found) call bailout('icoul', 'pot.json')
         call json%get('lfms1',  lfms1, found)
                   if (.not. found) call bailout('lfms1', 'pot.json')
         call json%get('iunf',   iunf, found)
                   if (.not. found) call bailout('iunf', 'pot.json')

         call json%get('gamach', gamach, found)
                   if (.not. found) call bailout('gamach', 'pot.json')
         call json%get('rgrd',   rgrd, found)
                   if (.not. found) call bailout('rgrd', 'pot.json')
         call json%get('ca1',    ca1, found)
                   if (.not. found) call bailout('ca1', 'pot.json')
         call json%get('ecv',    ecv, found)
                   if (.not. found) call bailout('ecv', 'pot.json')
         call json%get('totvol', totvol, found)
                   if (.not. found) call bailout('totvol', 'pot.json')
         call json%get('rfms1',  toss, found)
                   if (.not. found) call bailout('rfms1', 'pot.json')
         rfms1 = real(toss)

         call json%get('titles', strings, found)
                   if (.not. found) call bailout('titles', 'pot.json')
         do 1000 itit = 1, nheadx
            title(itit) = strings(itit)
 1000    continue
         call json%get('iz', intgs, found)
                   if (.not. found) call bailout('iz', 'pot.json')
         do 1010 iph = 0, nphx
            iz(iph) = intgs(iph+1)
 1010    continue
         call json%get('lmaxsc', intgs, found)
                   if (.not. found) call bailout('lmaxsc', 'pot.json')
         do 1020 iph = 0, nphx
            lmaxsc(iph) = intgs(iph+1)
 1020    continue
         call json%get('xnatph', dbpcs, found)
                   if (.not. found) call bailout('xnatph', 'pot.json')
         do 1030 iph = 0, nphx
            xnatph(iph) = dbpcs(iph+1)
 1030    continue
         call json%get('xion', dbpcs, found)
                   if (.not. found) call bailout('xion', 'pot.json')
         do 1040 iph = 0, nphx
            xion(iph) = dbpcs(iph+1)
 1040    continue
         call json%get('folp', dbpcs, found)
                   if (.not. found) call bailout('folp', 'pot.json')
         do 1050 iph = 0, nphx
            folp(iph) = dbpcs(iph+1)
 1050    continue
         call json%get('novr', intgs, found)
                   if (.not. found) call bailout('novr', 'pot.json')
         do 1060 iph = 0, nphx
            novr(iph) = intgs(iph+1)
 1060    continue

c        the following reconstructed all the overlap 2D arrays, see
c        RDINP/wrtjsn.f line 131 and following
         do 1200 iph = 0, nph
            write (vname, "(A6,I1)") "iphovr", iph
            call json%get(vname, intgs, found)
                      if (.not. found) call bailout(vname, 'pot.json')
            do 1220 iovr = 1, novr(iph)
               iphovr(iovr, iph) = intgs(iovr)
 1220       continue

            write (vname, "(A5,I1)") "nnovr", iph
            call json%get(vname, intgs, found)
                      if (.not. found) call bailout(vname, 'pot.json')
            do 1230 iovr = 1, novr(iph)
               nnovr(iovr, iph) = intgs(iovr)
 1230       continue

            write (vname, "(A4,I1)") "rovr", iph
            call json%get(vname, dbpcs, found)
                      if (.not. found) call bailout(vname, 'pot.json')
            do 1240 iovr = 1, novr(iph)
               rovr(iovr, iph) = dbpcs(iovr)
 1240       continue
 1200    continue

         call json%destroy()
      end if

      return
      end


c               Copyright 1993 Colorado State University
c                       All Rights Reserved

C ... DECLIG.F

      subroutine declig(aminrl,ligcon,lyr,nelem,nlr,ps1co2,rnew,
     &                  rsplig,tcflow,tcstva,csrsnk,cstatv,elstva,
     &                  gromin,minerl,netmnr,resp,som1ci,som1e,
     &                  som2ci,som2e,cflowtosom1,cflowtosom2,newminrl)

      implicit none
      include 'const.inc'

c ... Argument declarations
      integer   lyr, nelem, nlr
      double precision aminrl(MAXIEL), ligcon, ps1co2(2),
     &          rnew(MAXIEL,2), rsplig, tcflow, tcstva(nlr),
     &          csrsnk(ISOS), cstatv(nlr,ISOS), elstva(nlr,MAXIEL),
     &          gromin(MAXIEL), minerl(MAXLYR,MAXIEL),
     &          netmnr(nlr,MAXIEL),resp(ISOS), som1ci(2,ISOS),
     &          som1e(2,MAXIEL), som2ci(2,ISOS), som2e(2,MAXIEL)
      double precision cflowtosom1,cflowtosom2
      double precision newminrl

c ... Decompose stuff containing lignin (structural and wood).
c ... Call the compartment to be decomposed 'Box A'.
c ... C/E ratios of new material are computed once at the beginning of
c ... the simulation.

c ... Modified to flow to either soil or surface SOM2

c ... Input:
c ...   aminrl(iel) - iel=1,3 available mineral N, P, S.
c ...                 the sum of the positive layers of minerl
c ...                 before uptake by plants
c ...   ligcon      - lignin content of Box A
c ...   lyr         - layer (1=surface, 2=soil)
c ...   nelem       - number of elements (besides C) to be simulated
c ...   nlr         - total number of layers modeled for Box A;
c ...                 (=2 for structural, metabolic, som1, som2;
c ...                  =1 for som3, wood compartments)
c ...   ps1co2(lyr) - controls amount of co2 loss when structural
c ...                 decomposes to som1, subscripted for surface
c ...                 and soil layer (1)=surface, (2)=soil
c ...   rnew(iel,1) - C/E ratio of new material being added to som1
c ...                 (iel=1,3)
c ...   rnew(iel,2) - C/E ratio of new material being added to som2
c ...                 (iel=1,3)
c ...   rsplig      - fraction of lignin flow lost to respiration
c ...                 (rsplig was formerly named psco2l)
c ...   tcflow      - total C flow out of Box A
c ...   tcstva      - total C (unlabeled + labeled) in layer 'lyr' of
c ...                 Box A.  For components with only 1 layer,
c ...                 tcstva will be dimensioned (1).
c ... Transput:
c ...   csrsnk(iso)     - C source/sink (iso=1,2)
c ...   cstatv(lyr,iso) - C state variables for Box A;
c ...                     cstatv(lyr,iso) represents C in layer 'lyr',
c ...                     isotope 'iso' where iso=1 for unlabeled C
c ...                     and iso=2 for labeled C.  For components with
c ...                     only 1 layer, the 1st dimension of cstatv will
c ...                     be 1.
c ...   elstva(lyr,iel) - N, P, and S in Box A by layer and element
c ...                     (iel=1,3)
c ...   gromin(iel)     - gross mineralization (iel=1,3)
c ...   minerl(1,iel)   - labile N, P, or S in layer 1 (iel=1,3).
c ...   netmnr(lyr,iel) - net mineralization for layer lyr (N, P, or S)
c ...                     For components with only 1 layer, the 1st
c ...                     dimension of netmnr will be 1 (iel=1,3).
c ...   resp(iso)       - output variable; annual accumulator for C flows
c ...                     associated with microbial respiration (iso=1,2)
c ...   som1ci(lyr,iso) - C by isotope in soil organic matter with fast
c ...                     turnover rate (g/m2)
c ...                     (iso=1,2) (1)=unlabeled; (2)=labeled
c ...   som1e(lyr,iel)  - N, P, and S in soil organic matter with fast
c ...                     turnover rate (g/m2)
c ...                     (iel=1,3) (1)=N     (2)=P    (3)=S
c ...   som2ci(lyr,iso) - C by isotope in soil organic matter with
c ...                     intermediate turnover rate (g/m2)
c ...                     (iso=1,2) (1) unlabeled; (2) labeled
c ...   som2e(lyr,iel)  - N, P, and S in soil organic matter with
c ...                     intermediate turnover rate (g/m2)
c ...                     (iel=1,3) (1)=N     (2)=P     (3)=S

c ... Function declarations
      logical   candec
      external  candec

c ... Local variables
      integer   iel, actlyr, llyr
      double precision accum(ISOS), co2los, mnrflo, tosom1, tosom2,
     &          rnew1(MAXIEL)

      accum(LABELD) = 0.0
      accum(UNLABL) = 0.0

c ... actlyr (actual layer) is used when coarse roots are decomposed.
c ... In this case lyr = 2 and nlr = 1.  An error results when
c ... tcstva(lyr) is accessed because tcstva is dimensioned with nlr.
c ... Set actlyr to lyr and lyr to 1 for the special case.

c ... llyr (temporary variable) is used instead of 'lyr' so that it can
c ... be modified by the special case of SOIL=2 and nlr=1.

      llyr = lyr
      actlyr = lyr
      if ((lyr .eq. 2) .and. (nlr .eq. 1)) llyr = 1

c ... Store the C/E ratios for what goes to SOM1 in
c ... an array of correct size to be passed to CANDEC
      do 5 iel = 1, MAXIEL
        rnew1(iel) = rnew(iel,1)
5     continue

c ... See if Box A can decompose to som1.
c ... If it can go to som1, it will also go to som2.
c ... If it can't go to som1, it can't decompose at all.

c ... If Box A can decompose

      if (candec(nelem,aminrl,tcstva(llyr),elstva,nlr,
     &           llyr,rnew1)) then

c .....         Decompose Box A to SOM2
c .....         -----------------------
c ..... Gross C flow to som2
        tosom2 = tcflow * ligcon

c ..... Respiration associated with decomposition to som2
        co2los = tosom2 * rsplig

        call respir(co2los,nlr,llyr,tcstva,cstatv,csrsnk,resp,
     &              elstva,minerl,gromin,netmnr,newminrl)

c ..... Net C flow to SOM2
        tosom2 = tosom2 - co2los
        cflowtosom2 = tosom2

c ..... Partition and schedule C flows by isotope

        call csched(tosom2,cstatv(llyr,LABELD),tcstva(llyr),
     &              cstatv(llyr,UNLABL),som2ci(actlyr,UNLABL),
     &              cstatv(llyr,LABELD),som2ci(actlyr,LABELD),
     &              1.0,accum)

c ..... Compute and schedule N, P, and S flows.

c ..... Update mineralization accumulators.
        do 10 iel = 1, nelem

          call esched(tosom2,tcstva(llyr),rnew(iel,2),
     &                elstva(llyr,iel),som2e(actlyr,iel),
     &                minerl(1,iel),mnrflo)
          call mnracc(mnrflo,gromin(iel),netmnr(llyr,iel))
          if (iel .eq. N) then
            newminrl = newminrl + mnrflo
          endif
10      continue

c .....         Decompose Box A to SOM1
c .....         -----------------------

c ..... Gross C flow to som1
        tosom1 = tcflow - tosom2 - co2los

c ..... Respiration associated with decomposition to som1
        co2los = tosom1 * ps1co2(llyr)

        call respir(co2los,nlr,llyr,tcstva,cstatv,csrsnk,resp,
     &              elstva,minerl,gromin,netmnr,newminrl)

c ..... Net C flow to SOM1
        tosom1 = tosom1 - co2los
        cflowtosom1 = tosom1

c ..... Partition and schedule C flows by isotope

        call csched(tosom1,cstatv(llyr,LABELD),tcstva(llyr),
     &              cstatv(llyr,UNLABL),som1ci(actlyr,UNLABL),
     &              cstatv(llyr,LABELD),som1ci(actlyr,LABELD),
     &              1.0,accum)

c ..... Compute and schedule N, P, and S flows.

c ..... Update mineralization accumulators.
        do 20 iel = 1, nelem

          call esched(tosom1,tcstva(llyr),rnew(iel,1),
     &                elstva(llyr,iel),som1e(actlyr,iel),
     &                minerl(1,iel),mnrflo)
          call mnracc(mnrflo,gromin(iel),netmnr(llyr,iel))
          if (iel .eq. N) then
            newminrl = newminrl + mnrflo
          endif
20      continue

      endif

      return
      end