! -----------------------------------------------------------------------------
!     OpenMM(tm) HelloSodiumChloride example in Fortran 95 (June 2009)
! ------------------------------------------------------------------------------
! This is a complete, self-contained "hello world" example demonstrating
! GPU-accelerated constant temperature simulation of a very simple system with
! just nonbonded forces, consisting of several sodium (Na+) and chloride (Cl-)
! ions in implicit solvent. A multi-frame PDB file is written to stdout which
! can be read by VMD or other visualization tool to produce an animation of the
! resulting trajectory.
!
! Pay particular attention to the handling of units in this example. Incorrect
! handling of units is a very common error; this example shows how you can
! continue to work with Amber-style units like Angstroms, kCals, and van der
! Waals radii while correctly communicating with OpenMM in nm, kJ, and sigma.
!
! This example is written entirely in Fortran 95, using the OpenMM Fortran
! interface module.
! ------------------------------------------------------------------------------

INCLUDE 'OpenMMFortranModule.f90'

!-------------------------------------------------------------------------------
!                ATOM, FORCE FIELD, AND SIMULATION PARAMETERS
!-------------------------------------------------------------------------------
! We'll define this module as a simplified example of the kinds of data
! structures that may already be in an MD program that is to be converted
! to use OpenMM. Note that we're using data in Angstrom and kcal units; we'll
! show how to safely convert to and from OpenMM's internal units as we go.
MODULE MyAtomInfo
    ! Simulation parameters
    ! ---------------------
    real*8 Temperature, FrictionInPerPs, SolventDielectric, SoluteDielectric
    parameter(Temperature        = 300) !Kelvins
    parameter(FrictionInPerPs    = 91)  !collisions per picosecond
    parameter(SolventDielectric  = 80)  !typical for water
    parameter(SoluteDielectric   = 2)   !typical for protein

    real*8 StepSizeInFs, ReportIntervalInFs, SimulationTimeInPs
    parameter(StepSizeInFs       = 4)   !integration step size (fs)
    parameter(ReportIntervalInFs = 50)  !how often for PDB frame (fs)
    parameter(SimulationTimeInPs = 100) !total simulation time (ps)

    logical, parameter :: WantEnergy = .true.

    ! Atom and force field information
    ! --------------------------------
    type Atom
        character*4       pdb
        real*8            mass, charge, vdwRadiusInAng, vdwEnergyInKcal
        real*8            gbsaRadiusInAng, gbsaScaleFactor
        real*8            initPosInAng(3)
        real*8            posInAng(3) ! leave room for runtime state info
    end type
    integer, parameter :: NumAtoms = 6
    type (Atom) :: atoms(NumAtoms) = (/ &
    ! pdb   mass charge vdwRad vdwEnergy  gbRad gbScale   initPos      runtime
Atom(' NA ',22.99,  1,  1.8680, 0.00277,  1.992,  0.8, (/ 8, 0,  0/), (/0,0,0/)),&
Atom(' CL ',35.45, -1,  2.4700, 0.1000,   1.735,  0.8, (/-8, 0,  0/), (/0,0,0/)),&
Atom(' NA ',22.99,  1,  1.8680, 0.00277,  1.992,  0.8, (/ 0, 9,  0/), (/0,0,0/)),&
Atom(' CL ',35.45, -1,  2.4700, 0.1000,   1.735,  0.8, (/ 0,-9,  0/), (/0,0,0/)),&
Atom(' NA ',22.99,  1,  1.8680, 0.00277,  1.992,  0.8, (/ 0, 0,-10/), (/0,0,0/)),&
Atom(' CL ',35.45, -1,  2.4700, 0.1000,   1.735,  0.8, (/ 0, 0, 10/), (/0,0,0/)) &
    /)
END MODULE

!-------------------------------------------------------------------------------
!                                MAIN PROGRAM
!-------------------------------------------------------------------------------
! This makes use of four subroutines that encapsulate all the OpenMM calls:
!     myInitializeOpenMM
!     myStepWithOpenMM
!     myGetOpenMMState
!     myTerminateOpenMM
! and one minimalist PDB file writer that has nothing to do with OpenMM:
!     myWritePDBFrame
! All of these subroutines can be found later in this file. For use in a real
! MD code you would need to write your own interface routines along these lines.
! Note that the main program does NOT include the OpenMM module.
PROGRAM HelloSodiumChloride
    use MyAtomInfo

    ! Calculate the number of PDB frames we want to write out and how
    ! many steps to take on the GPU in between.
    integer NumReports, NumSilentSteps
    parameter(NumReports = (SimulationTimeInPs*1000 / ReportIntervalInFs + 0.5))
    parameter(NumSilentSteps = (ReportIntervalInFs / StepSizeInFs + 0.5))

    character*10 platformName; real*8 timeInPs, energyInKcal; integer frame

    ! This is an opaque handle to a container that holds the OpenMM runtime
    ! objects. You can use any type for this purpose as long as it is
    ! big enough to hold a pointer. (If you use a pointer type you'll have
    ! to declare the subroutine interfaces before calling them.)
    integer*8 ommHandle

    ! Set up OpenMM data structures; returns platform name and handle.
    call myInitializeOpenMM(ommHandle, platformName)

    ! Run the simulation:
    !  (1) Write the first line of the PDB file and the initial configuration.
    !  (2) Run silently entirely within OpenMM between reporting intervals.
    !  (3) Write a PDB frame when the time comes.
    print "('REMARK  Using OpenMM platform ', A)", platformName
    call myGetOpenMMState(ommHandle, timeInPs, energyInKcal)
    call myWritePDBFrame(0, timeInPs, energyInKcal)

    do frame = 1, NumReports
        call myStepWithOpenMM(ommHandle, NumSilentSteps)
        call myGetOpenMMState(ommHandle, timeInPs, energyInKcal)
        call myWritePDBFrame(frame, timeInPs, energyInKcal)
    end do

    ! Clean up OpenMM data structures.
    call myTerminateOpenMM(ommHandle)
END PROGRAM

!-------------------------------------------------------------------------------
!                                PDB FILE WRITER
!-------------------------------------------------------------------------------
! Given state data which was written into the atoms array of the MyAtomInfo
! module, output a single frame (pdb "model") of the trajectory. This has
! nothing to do with OpenMM.
SUBROUTINE myWritePDBFrame(frameNum, timeInPs, energyInKcal)
    use MyAtomInfo; implicit none
    integer frameNum; real*8 timeInPs, energyInKcal

    integer n
    print "('MODEL',5X,I0)", frameNum
    print "('REMARK 250 time=', F0.3, ' picoseconds; Energy=', F0.3, ' kcal/mole')", &
        timeInPs, energyInKcal
    do n = 1,NumAtoms
        print "('ATOM  ', I5, ' ', A4, ' SLT     1    ', 3F8.3, '  1.00  0.00')",    &
            n, atoms(n)%pdb, atoms(n)%posInAng
    end do
    print "('ENDMDL')"
END SUBROUTINE

!-------------------------------------------------------------------------------
!                            OpenMM-USING CODE
!-------------------------------------------------------------------------------
! The OpenMM Fortran interface module is included only at this point and below.
! Normally these subroutines would be in a separate compilation module; we're
! including them here for simplicity. We suggest that you write them in C++
! if possible, using extern "C" functions to make then callable from your
! Fortran main program. (See the C++ version of this example program for
! an implementation of very similar routines.) However, these routines are
! reimplemented entirely in Fortran 95 below in case you prefer.

! ------------------------------------------------------------------------------
!                      INITIALIZE OpenMM DATA STRUCTURES
! ------------------------------------------------------------------------------
! We take these actions here:
! (1) Load any available OpenMM plugins, e.g. Cuda and Brook.
! (2) Fill the OpenMM::System with the force field parameters we want to
!     use and the particular set of atoms to be simulated.
! (3) Create an Integrator and a Context associating the Integrator with
!     the System.
! (4) Select the OpenMM platform to be used.
! (5) Return an opaque handle to the Context object and the name of the
!     Platform in use.
!
! Note that this routine must understand the calling MD code's molecule and
! force field data structures so will need to be customized for each MD code.

SUBROUTINE myInitializeOpenMM(ommHandle, platformName)
    use OpenMM; use MyAtomInfo; implicit none
    integer*8,    intent(out) :: ommHandle
    character*10, intent(out) :: platformName

    ! These are the objects we'll create here thare are stored in the
    ! Context for later access. Don't forget to delete them at the end.
    type (OpenMM_System)             system
    type (OpenMM_BAOABLangevinIntegrator) langevin
    type (OpenMM_Context)            context

    ! These are temporary OpenMM objects used and discarded here.
    type (OpenMM_StringArray)        pluginList
    type (OpenMM_Vec3Array)          initialPosInNm
    type (OpenMM_NonbondedForce)     nonbond
    type (OpenMM_GBSAOBCForce)       gbsa
    type (OpenMM_Platform)           platform
    character*100                    dirName
    integer*4                        n, ix
    real*8                           posInNm(3)

    ! Get the name of the default plugins directory,
    ! and then load all the plugins found there.
    call OpenMM_Platform_getDefaultPluginsDirectory(dirName)
    call OpenMM_Platform_loadPluginsFromDirectory(dirName, pluginList)
    call OpenMM_StringArray_destroy(pluginList)

    ! Create a System and Force objects for it. The System will take
    ! over ownership of the Forces; don't destroy them yourself.
    call OpenMM_System_create(system)
    call OpenMM_NonbondedForce_create(nonbond)
    call OpenMM_GBSAOBCForce_create(gbsa)

    ! Convert specific force types to generic OpenMM_Force so that we can
    ! add them to the OpenMM_System.
    ix = OpenMM_System_addForce(system, transfer(nonbond, OpenMM_Force(0)))
    ix = OpenMM_System_addForce(system, transfer(gbsa,    OpenMM_Force(0)))

    ! Specify dielectrics for GBSA implicit solvation.
    call OpenMM_GBSAOBCForce_setSolventDielectric(gbsa, SolventDielectric)
    call OpenMM_GBSAOBCForce_setSoluteDielectric(gbsa, SoluteDielectric)

    ! Specify the atoms and their properties:
    !  (1) System needs to know the masses.
    !  (2) NonbondedForce needs charges,van der Waals properties (in MD units!).
    !  (3) GBSA needs charge, radius, and scale factor.
    !  (4) Collect default positions for initializing the simulation later.
    call OpenMM_Vec3Array_create(initialPosInNm, NumAtoms)
    do n=1,NumAtoms
        ix = OpenMM_System_addParticle(system, atoms(n)%mass)

        ix = OpenMM_NonbondedForce_addParticle(nonbond,                 &
                atoms(n)%charge,                                        &
                atoms(n)%vdwRadiusInAng  * OpenMM_NmPerAngstrom         &
                                         * OpenMM_SigmaPerVdwRadius,    &
                atoms(n)%vdwEnergyInKcal * OpenMM_KJPerKcal)

        ix = OpenMM_GBSAOBCForce_addParticle(gbsa,                      &
                atoms(n)%charge,                                        &
                atoms(n)%gbsaRadiusInAng * OpenMM_NmPerAngstrom,        &
                atoms(n)%gbsaScaleFactor)

        ! Sets initPos(n) = atoms(n)%initPos * nm/Angstrom.
        call OpenMM_Vec3_scale(atoms(n)%initPosInAng,                   &
                               OpenMM_NmPerAngstrom, posInNm)
        call OpenMM_Vec3Array_set(initialPosInNm, n, posInNm)
    end do

    ! Choose an Integrator for advancing time, and a Context connecting the
    ! System with the Integrator for simulation. Let the Context choose the
    ! best available Platform. Initialize the configuration from the default
    ! positions we collected above. Initial velocities will be zero but could
    ! have been set here.
    call OpenMM_BAOABLangevinIntegrator_create(langevin,                     &
                                          Temperature, FrictionInPerPs, &
                                          StepSizeInFs * OpenMM_PsPerFs)

    ! Convert BAOABLangevinIntegrator to generic Integrator type for this call.
    call OpenMM_Context_create(context, system,                         &
                               transfer(langevin, OpenMM_Integrator(0)))
    call OpenMM_Context_setPositions(context, initialPosInNm)

    ! Get the platform name to return.
    call OpenMM_Context_getPlatform(context, platform)
    call OpenMM_Platform_getName(platform, platformName)

    ! References to the System and Integrator are in the Context, so
    ! we can extract them later for stepping and cleanup. Return an opaque
    ! reference to the Context for use by the main program.
    ommHandle = transfer(context, ommHandle)
END SUBROUTINE

!-------------------------------------------------------------------------------
!                     COPY STATE BACK TO CPU FROM OpenMM
!-------------------------------------------------------------------------------
SUBROUTINE myGetOpenMMState(ommHandle, timeInPs, energyInKcal)
    use OpenMM; use MyAtomInfo; implicit none
    integer*8, intent(in) :: ommHandle
    real*8, intent(out)   :: timeInPs, energyInKcal

    type (OpenMM_State)     state
    type (OpenMM_Vec3Array) posArrayInNm
    integer                 infoMask, n
    real*8                  posInNm(3)

    type (OpenMM_Context)         context

    context = transfer(ommHandle, context)

    infoMask = OpenMM_State_Positions
    if (WantEnergy) then
        infoMask = infoMask + OpenMM_State_Velocities ! for KE (cheap)
        infoMask = infoMask + OpenMM_State_Energy     ! for PE (very expensive)
    end if
    ! Forces are also available (and cheap).

    ! Don't forget to destroy this State when you're done with it.
    call OpenMM_Context_getState(context, infoMask, OpenMM_False, state)
    timeInPs = OpenMM_State_getTime(state) ! OpenMM time is in ps already.

    ! Positions are maintained as a Vec3Array inside the State. This will give
    ! us access, but don't destroy it yourself -- it will go away with the State.
    call OpenMM_State_getPositions(state, posArrayInNm)
    do n = 1, NumAtoms
        ! Sets atoms(n)%pos = posArray(n) * Angstroms/nm.
        call OpenMM_Vec3Array_get(posArrayInNm, n, posInNm)
        call OpenMM_Vec3_scale(posInNm, OpenMM_AngstromsPerNm, &
                               atoms(n)%posInAng)
    end do

    energyInKcal = 0
    if (WantEnergy) then
        energyInKcal = (  OpenMM_State_getPotentialEnergy(state)   &
                        + OpenMM_State_getKineticEnergy(state))    &
                       * OpenMM_KcalPerKJ
    end if

    ! Clean up the State memory
    call OpenMM_State_destroy(state)
END SUBROUTINE

!-------------------------------------------------------------------------------
!                     TAKE MULTIPLE STEPS USING OpenMM
!-------------------------------------------------------------------------------
SUBROUTINE myStepWithOpenMM(ommHandle, numSteps)
    use OpenMM; implicit none
    integer*8, intent(in) :: ommHandle
    integer,   intent(in) :: numSteps

    type (OpenMM_Context)    context
    type (OpenMM_Integrator) integrator

    context = transfer(ommHandle, context)
    call OpenMM_Context_getIntegrator(context, integrator)

    call OpenMM_Integrator_step(integrator, numSteps)
END SUBROUTINE

!-------------------------------------------------------------------------------
!                      DEALLOCATE ALL OpenMM OBJECTS
!-------------------------------------------------------------------------------
SUBROUTINE myTerminateOpenMM(ommHandle)
    use OpenMM; implicit none
    integer*8, intent(inout) :: ommHandle

    type (OpenMM_Context)    context
    type (OpenMM_Integrator) integrator
    type (OpenMM_System)     system

    context = transfer(ommHandle, context)
    call OpenMM_Context_getIntegrator(context, integrator)
    call OpenMM_Context_getSystem(context, system)

    call OpenMM_Context_destroy(context)
    call OpenMM_Integrator_destroy(integrator)
    call OpenMM_System_destroy(system)
END SUBROUTINE


fl

\ fswrite lac.f

1 wconstant build_LogicAnalyzer
\
\
\ define this constant if the console code is needed

{
\ demo run on cog6

\ example1
\ 40 cycles clkfreq 40 2* /

c" 0 1000000 setHza 1  500000 setHzb" 0 cogx
c" 2  250000 setHza 3  125000 setHzb" 1 cogx
lac

\ example2
\ 41 cycles clkfreq 41 2* /
c" 0 975610 setHza 1 487805 setHzb" 0 cogx
c" 2 243902 setHza 3 121951 setHzb" 1 cogx
lac

\ example3
\ 50 cycles clkfreq 50 2* /

c" 0 800000 setHza 1 400000 setHzb" 0 cogx
c" 2 200000 setHza 3 100000 setHzb" 1 cogx
lac

\
\
\ if laconsole is not defined
\ example1
\ 40 cycles clkfreq 40 2* /

c" 0 1000000 setHza 1  500000 setHzb" 0 cogx
c" 2  250000 setHza 3  125000 setHzb" 1 cogx
80 0 la_sample+Trigger
40 0 la_sample+Trigger
20 0 la_sample+Trigger
4 0 la_sample+Trigger
1 0 la_sample+Trigger

\ example2
\ 41 cycles clkfreq 41 2* /
c" 0 975610 setHza 1 487805 setHzb" 0 cogx
c" 2 243902 setHza 3 121951 setHzb" 1 cogx
82 0 la_sample+Trigger
41 0 la_sample-Trigger
20 0 la_sample-Trigger
4 0 la_sample-Trigger
1 0 la_sample-Trigger

\ example3
\ 50 cycles clkfreq 50 2* /

c" 0 800000 setHza 1 400000 setHzb" 0 cogx
c" 2 200000 setHza 3 100000 setHzb" 1 cogx
50 la_sampleNoTrigger
25 la_sampleNoTrigger
4 la_sampleNoTrigger
1 la_sampleNoTrigger

}

\ a cog special register
[ifndef ctra
h1F8	wconstant ctra
]

\ a cog special register
[ifndef ctrb
h1F9	wconstant ctrb
]

\ a cog special register
[ifndef frqa
h1FA	wconstant frqa
]

\ a cog special register
[ifndef frqb
h1FB	wconstant frqb
]

\ a cog special register
[ifndef phsa
h1FC	wconstant phsa
]

\ a cog special register
[ifndef phsb
h1FD	wconstant phsb
]

[ifndef $C_a_dovarl
    h4D wconstant $C_a_dovarl
]

\
\ variable ( -- ) skip blanks parse the next word and create a variable, allocate a long, 4 bytes
[ifndef variable
: variable
	lockdict create $C_a_dovarl w, 0 l, forthentry freedict
;
]

\
\ abs ( n1 -- abs_n1 ) absolute value of n1
[ifndef abs
: abs
	_xasm1>1 h151 _cnip
;
]

\
\ waitcnt ( n1 n2 -- n1 ) \ wait until n1, add n2 to n1
[ifndef waitcnt
: waitcnt
	_xasm2>1 h1F1 _cnip
;
]
\
\
\ 2* ( n1 -- n1<<1 ) n2 is shifted logically left 1 bit
[ifndef 2*
: 2* _xasm2>1IMM h0001 _cnip h05F _cnip ;
]
\
\
\ key? ( -- t/f) true if there is a key ready for input
[ifndef key?
: key?
	io W@ h100 and 0=
;
]

\ u*/mod ( u1 u2 u3 -- u4 u5 ) u5 = (u1*u2)/u3, u4 is the remainder. Uses a 64bit intermediate result.
[ifndef u*/mod
: u*/mod rot2 um* rot um/mod ;
]

\ u*/ ( u1 u2 u3 -- u4 ) u4 = (u1*u2)/u3 Uses a 64bit intermediate result.
[ifndef u*/
: u*/ rot2 um* rot um/mod nip ;
]

\ _cfo ( n1 -- n2 ) n1 - desired frequency, n2 freq a
[ifndef _cfo
: _cfo clkfreq 1- min 0 swap clkfreq um/mod swap clkfreq 2/ >= abs + ;
]

\ setHza ( n1 n2 -- ) n1 is the pin, n2 is the freq, uses ctra
\ set the pin oscillating at the specified frequency
[ifndef setHza
: setHza _cfo frqa COG! dup pinout h10000000 + ctra COG! ;
]

\ qHzb ( n1 n2 -- n3 ) n1 - the pin, n2 - the # of msec to sample, n3 the frequency
[ifndef qHzb
: qHzb
	swap h28000000 + 1 frqb COG! ctrb COG!
	h3000 min clkfreq over h3E8 u*/ h310 - phsb COG@ swap cnt COG@ + 0 waitcnt
	phsb COG@ nip swap - h3E8 rot u*/ ;
]

\ setHzb ( n1 n2 -- ) n1 is the pin, n2 is the freq, uses ctrb
\ set the pin oscillating at the specified frequency
[ifndef setHzb
: setHzb _cfo frqb COG! dup pinout h10000000 + ctrb COG! ;
]

\ crcl ( -- ) cr and clear the line (for an ansi terminal)
[ifndef crcl
: crcl ." ~h0D~h1B~h5B~h4B" ;
]

\ hm ( -- ) ansi home
[ifndef hm
: hm ." ~h1B~h5B~h48" ;
]

\ hmclr ( -- ) ansi home and clear screen
[ifndef hmclr
: hmclr ." ~h1B~h5B~h48~h1B~h5B~h4A" ;
]

\
\ #C ( c1 -- ) prepend the character c1 to the number currently being formatted
[ifndef #C
: #C
	-1 >out W+! pad>out C!

;
]

\
\ _nf ( n1 -- cstr ) formats n1 to a fixed format 16 wide, leading spaces variable, one trailing space
[ifndef _nf
: _nf
	<# bl #C # # # h2C #C # # # h2C #C # # #  h2C #C # # # #>
	dup C@++ bounds
	do
		i C@ dup isdigit swap todigit 0<> and
		if
			leave

		else
			bl i C!
		then
	loop
;
]

\
\ .num ( n1 -- ) print n1 as a fixed format number
[ifndef .num
: .num
	_nf .cstr
;
]

[ifndef freeDictStart
\ freeDictStart ( -- addr ) the start address of the unused dictionary, long aligned
: freeDictStart
	here W@ alignl
;
]

[ifndef freeDictEnd
\ freeDictEnd ( -- addr ) the end address of the unused dictionary, long aligned
: freeDictEnd
	dictend W@ h3 andn
;
]

[ifndef zeroFreeDict
\ zeroFreeDict ( -- ) zeros out all the unused dictionary
: zeroFreeDict
	freeDictEnd freeDictStart
	do
		0 i L!
	h4 +loop
;
]

\ This block is low level code which sets up and manipulates the assembler necessary

\ variable definitions and addresses for assembler routines

\
\ _la_asample41+ ( baseaddr numsamples samplecycle triggerbefore triggerafter triggermask -- numsamples)
\ _la_asample18+ ( baseaddr numsamples samplecycle triggerbefore triggerafter triggermask -- numsamples)
\ _la_asample4 ( baseaddr numsamples samplecycle triggerbefore triggerafter triggermask -- numsamples)
\ _la_sample1 ( baseaddr startcount -- numsamples )
\

lockdict create _la_asample41+ forthentry
$C_a_lxasm w, h12A  h113  1- tuck - h9 lshift or here W@ alignl cnt COG@ dup h10 rshift xor h3 andn xor h10 lshift or l,
z2WiQBB l, z1SyLI[ l, z2WiQ3B l, z1SyLI[ l, z2WiPuB l, z1SyLI[ l, z2WiPmB l, z1SyLI[ l,
z2WiPeB l, z1SyLI[ l, z2WiPZB l, z2WiPRD l, z3jFPuH l, z3jFQ3H l, z2WiQFl l, z2WiQ7k l,
z20iQ3E l, z8FQBC l, z3riQ3E l, z2WiQFl l, z20yPW4 l, z3[yPf[ l, z1SV01X l,
freedict

lockdict create _la_asample18+ forthentry
$C_a_lxasm w, h131  h113  1- tuck - h9 lshift or here W@ alignl cnt COG@ dup h10 rshift xor h3 andn xor h10 lshift or l,
z2WiQBB l, z1SyLI[ l, z2WiQ3B l, z1SyLI[ l, z2WiPuB l, z1SyLI[ l, z2WiPmB l, z1SyLI[ l,
z1SyLI[ l, z2WiPZB l, z2WyPij l, z24yPfi l, z2WiPRD l, z3jFPuH l, z3jFQ3H l, z2Wi\yl l,
z2WiQ7k l, z20iQ3E l, z3riQ3E l, z2Wi]7l l, z20i[m2 l, z3[yPf\ l, z2WiPeB l, z8F\uC l,
z20i\J2 l, z20yPW4 l, z3[yPfd l, z1SV01X l, 0 l, 0 l,
freedict

lockdict create _la_asample4 forthentry
$C_a_lxasm w, h135  h113  1- tuck - h9 lshift or here W@ alignl cnt COG@ dup h10 rshift xor h3 andn xor h10 lshift or l,
z2WiQBB l, z1SyLI[ l, z2WiQ3B l, z1SyLI[ l, z2WiPuB l, z1SyLI[ l, z1SyLI[ l, z1SyLI[ l,
z2WiPZB l, z2WyPij l, z24yPb1 l, z1Ki\3D l, z24yPfn l, z2WiPRD l, z2Wi][j l, z1Ky][n l,
z20i[B2 l, z20i[J2 l, z20y[G1 l, z3[yPfX l, z1Gy]Cd l, z2Wi04k l, z1SV04l l, z2WiPeB l,
z8F]ZC l, z20i\R2 l, z20yPW4 l, z3[yPfe l, z1SV01X l, z2Wi07l l, z1SV000 l, z3jFPuH l,
z3jFQ3H l, 0 l,
freedict

lockdict create _la_asample1 forthentry
$C_a_lxasm w, h12E  h113  1- tuck - h9 lshift or here W@ alignl cnt COG@ dup h10 rshift xor h3 andn xor h10 lshift or l,
z2WiQBB l, z1SyLI[ l, z2WiPZB l, z2WyPij l, z24yPb1 l, z1Ki[JD l, z24yPfg l, z2WiPRD l,
z2Wi\fd l, z1Ky\fg l, z20iZR2 l, z20iZZ2 l, z20yZW1 l, z3[yPfR l, z1Gy\S[ l, z2Wi04e l,
z1SV04f l, z2WiPeB l, z8F\eC l, z20i[e2 l, z20yPWG l, z3[yPf\ l, z1SV01X l, z2Wi07l l,
z1SV000 l, z3ryQ80 l, 0 l,
freedict

\ this variable which is used to synch the 4 cogs which are doing interleaved sampling
variable _la_s1time

wvariable _la_s1addr

\ this variable value is the first of 4 sequential cogs used to sample every clock cycle, default to this cog 2

wvariable _la_s1cog 2 _la_s1cog W!
wvariable _la_s1size

\ _la_is1 ( -- ) this is the interleaved routine used by 4 cogs to sample very clock cycle
: _la_is1
	_la_s1addr W@ cogid _la_s1cog W@ - 2* 2* +
	_la_s1time L@ cogid _la_s1cog W@ - +
	_la_asample1
	2* 2* _la_s1size W!
;

\ _la_sample1 ( baseaddr numsamples samplecycle triggerbefore triggerafter triggermask -- numsamples)
: _la_sample1
	3drop 2drop
	_la_s1addr W!
	_la_s1cog W@ dup cogreset
	1+ dup cogreset
	1+ dup cogreset
	1+ cogreset
	zeroFreeDict
	h10 delms
	clkfreq cnt COG@ + _la_s1time L!
	c" _la_is1"
	dup _la_s1cog W@ cogx
	dup _la_s1cog W@ 1+ cogx
	dup _la_s1cog W@ 2+ cogx
	_la_s1cog W@ h3 + cogx
	_la_s1time L@ h8000 + 0 waitcnt drop
	_la_s1size W@
;

\ _la_sample ( baseaddr numsamples samplecycle triggerbefore triggerafter triggermask -- numSamples )
: _la_sample
	h4 ST@ h310 >=
	if
		h3 ST@ h29 >=
		if
			_la_asample41+
		else

			h3 ST@ h12 >=
			if
				_la_asample18+
			else

				h3 ST@ h4 =
				if
					_la_asample4
				else

					h3 ST@ 1 =
					if
						_la_sample1
					else

						3drop 3drop 0
					then
				then
			then
		then
	else
		3drop 3drop 0
	then
;

\ _la_displayPin ( n1 n2 -- ) show 128 samples starting at position n1 for pin n2
: _la_displayPin
	>m swap 2* 2* freeDictStart + h200 bounds
	do
		i L@ over and if h2D else h5F then emit
	h4 +loop
	drop
;

wvariable _la_current 0 _la_current W!
wvariable _la_end h80 _la_end W!

variable _la_trigger 0 _la_trigger L!
variable _la_triggerEdge 1 _la_triggerEdge L!
variable _la_lastTriggerEdge 1 _la_lastTriggerEdge L!

variable _la_triggerFrequency 0 _la_triggerFrequency L!

variable _la_sampleInterval h28 _la_sampleInterval L!
variable _la_lastSampleInterval h28 _la_lastSampleInterval L!

variable _la_L10nc
\ _la_L10nc 10,000,000 / (clkfreq/1000) - the number of nS per clock count x 10
h989680 clkfreq h3E8 u/ u/ _la_L10nc L!

\ _la_L1 ( n1 -- ) emit n1 as decimal ###.#
: _la_L1
	hA u/mod swap <# # drop h2E #C # # # #> .cstr
;

\ _la_LST ( n1 -- ) emit n1 in (x)Seconds format
: _la_LST
	_la_L10nc L@ u* dup h2710 <
	if
		_la_L1 ."  nS"
	else
		h3E8 u/ dup h2710 <
		if
			_la_L1 ."  uS"
		else
			h3E8 u/ dup h2710 <
			if
				_la_L1 ."  mS"
			else
				drop
	thens
;

\
\ _lacv ( -- ) print out vertical lines every 16 position leaving 2 spaces at the beginning
: _lacv
	h11 spaces h7C emit
	h7 0
	do
		hF spaces h7C emit
	loop
	cr
;

\
\ _la_interval ( n1 -- ) adjust the sample interval by n1
: _la_interval
	_la_sampleInterval L@
	dup _la_lastSampleInterval L!
	over +
	_la_sampleInterval L!
	0<
	if
		_la_sampleInterval L@ h12 <
		if
			_la_sampleInterval L@ h4 <
			if
				1
				_la_triggerEdge L@ _la_lastTriggerEdge L!
				0 _la_triggerEdge L!
			else
				h4
			then
			_la_sampleInterval L!
		then
	else
		_la_sampleInterval L@ h12 <
		if
			_la_sampleInterval L@ h4 <
			if
				h4
				0 _la_triggerEdge L!
			else
				h12
			then
			_la_sampleInterval L!
		then
	then
	_la_lastSampleInterval L@ 1 =
	_la_sampleInterval L@ 1 <> and
	if
		_la_lastTriggerEdge L@ _la_triggerEdge L!
	then

;

\
\ _la_dStart ( flag flag n1 -- 0 -1 ) adjust the starting diplay position
: _la_dStart
	_la_current W@ + 0 max
	_la_end W@ h80 - 0 max min
	_la_current W!
	2drop 0 -1
;

\
\ _la_pin ( n1 -- ) adjust the trigger pin
: _la_pin
	_la_trigger L@ + 0 max h1F min
	_la_triggerEdge L@ 0= _la_sampleInterval 1 =  or
	if
		0 _la_triggerFrequency L!
	else
		dup hF0 qHzb _la_triggerFrequency L!
	then
	_la_trigger L!
;

\ _la_k1 ( key flag -- key flag ) process key input
: _la_k1
	over h7A = if
		-1 _la_dStart
	else over h78 = if
		h-A _la_dStart
	else over h63 = if
		h-64 _la_dStart
	else over h76 = if
		h-3E8 _la_dStart
	else over h5A = if
		1 _la_dStart
	else over h58 = if
		hA _la_dStart
	else over h43 = if
		h64 _la_dStart
	else over h56 = if
		h3E8 _la_dStart
	else over h61 = if
		-1 _la_interval
	else over h73 = if
		h-A _la_interval
	else over h64 = if
		h-64 _la_interval
	else over h66 = if
		h-3E8 _la_interval
	else over h67 = if
		h-2710 _la_interval
	else over h41 = if
		1 _la_interval
	else over h53 = if
		hA _la_interval
	else over h44 = if
		h64 _la_interval
	else over h46 = if
		h3E8 _la_interval
	else over h47 = if
		h2710 _la_interval
	thens
;

\
\ _la_h ( -- ) display header
: _la_h
	hm crcl
	."     Trigger Pin      -q    +Q: " _la_triggerEdge W@ 0= if ." NONE" else  _la_trigger L@ . then crcl
	."    Trigger Edge   -w +W SPACE: " _la_triggerEdge L@ 0=
		if ." NONE" else  _la_triggerEdge L@ 0< if ." --__" else  ." __--" else  then then crcl
	." Trigger Frequency         eE : "
	_la_triggerEdge L@ if _la_triggerFrequency L@ .num else ." NO TRIGGER FOUND" then crcl

	." Sample Interval -asdfg +ASDFG: " _la_sampleInterval L@ dup _la_LST  .num ." clock cycles" crcl
	."          Sample     <ENTER>" crcl
	."          Quit         <ESC>" crcl
	." Sample Display  -zxcv  +ZXCV : " _la_current W@ .num ." clock cycles of " _la_end W@ .num crcl
;

\ _la_k ( -- key flag ) process key input
: _la_k
\ ( key 0 -- )
	key 0
	over h71 = if
		-1 _la_pin
	else over h51 = if
		1 _la_pin
	else over h65 = if
		_la_trigger L@ h3E8 qHzb _la_triggerFrequency L!
	else over h45 = if
		_la_trigger L@ h7D0 qHzb _la_triggerFrequency L!
	else over h20 = if
		0 _la_triggerEdge L!
		0 _la_trigger L!
		0 _la_triggerFrequency L!
	else over h77 = if
		-1 _la_triggerEdge L!
		0 _la_pin
	else over h57 = if
		1 _la_triggerEdge L!
		0 _la_pin
	else over hD = if
		_la_sampleInterval L@ 1 =
		if
			hmclr
		then
\ _la_sample ( baseaddr numsamples samplecycle triggerbefore triggerafter triggermask -- numSamples )
			zeroFreeDict
			freeDictStart
			freeDictEnd over - 2/ 2/
			_la_sampleInterval L@

			_la_triggerFrequency L@
			if
				_la_triggerEdge L@ 0>
				if
					0
					_la_trigger L@ >m
					dup
				else
					_la_trigger L@ >m
					0
					over
				then
			else
				0 0 0
			then
			_la_sample
			_la_end W!
\		then

		2drop 0 -1
	else over h1B = if
		2drop -1 -1
	thens
	_la_k1
;

\
\ lac ( -- )
: lac
	0 _la_pin
	zeroFreeDict
	hmclr _la_h

	begin
		0
		begin
			drop key?
			if
				_la_k _la_h
			else
				0 0
			then
		until
		dup 0=
		if
			h20 0
			do
				_lacv
				space space
				_la_current W@ h10 + h80 bounds
				do
					h7 spaces _la_current W@ _la_sampleInterval L@ i u* + _la_LST h7C emit
				h10 +loop
				cr
				_lacv

				i h4 bounds
				do
					h1F i - dup <# # # #> .cstr
					_la_current W@ swap _la_displayPin
					crcl
				loop
			h4 +loop
			hm
		then

	until
	hmclr
;

\ la_displaySamples ( n1 n2 -- ) display samples starting at position n1 for 8 pins starting at pin n2
: la_displaySamples
	dup h8 + swap
	do
		i <# # # #> .cstr
		dup i _la_displayPin
		cr
	loop drop
;

\ la_sampleNoTrigger ( n1 -- ) sample every n1 clocks and display 128 samples starting from position 0
: la_sampleNoTrigger
	>r
	freeDictStart freeDictEnd over - 2/ 2/
	r>
	0 0 0 _la_sample drop
 	0 0  la_displaySamples
 	0 h8  la_displaySamples
 	0 h10 la_displaySamples
 	0 h18 la_displaySamples
;

\ la_sample+Trigger ( n1 n2 -- ) sample every n1 clock +ve edge and display 128 samples starting from position 0,
\ trigger on pin n2
: la_sample+Trigger
	>r >r
	freeDictStart freeDictEnd over - 2/ 2/
	r>
 	0 r> >m dup _la_sample drop
 	0 0  la_displaySamples
 	0 h8  la_displaySamples
 	0 h10 la_displaySamples
 	0 h18 la_displaySamples
;

\ la_sample-Trigger ( n1 n2 -- ) sample every n1 clock -ve edge and display 128 samples starting from position 0,
\ trigger on la_triggerPin
: la_sample-Trigger
	>r >r
	freeDictStart freeDictEnd over - 2/ 2/
	r>
 	r> >m 0 over _la_sample drop
 	0 0  la_displaySamples
 	0 h8  la_displaySamples
 	0 h10 la_displaySamples
 	0 h18 la_displaySamples
;

{

fl

hA state orC!

\ _la_asample41+ ( baseaddr numsamples samplecycle triggerbefore triggerafter triggermask -- numsamples)
build_BootOpt :rasm
\ trigger mask
	mov	$C_treg6 , $C_stTOS
	spop
\ trigger after
	mov	$C_treg5 , $C_stTOS
	spop
\ trigger before
	mov	$C_treg4 , $C_stTOS
	spop

\ sample cycle
	mov	$C_treg3 , $C_stTOS
	spop

\ num samples
	mov	$C_treg2 , $C_stTOS
	spop

\ base address - $C_treg1
	mov	$C_treg1 , $C_stTOS

	mov	$C_stTOS , $C_treg2
\
\ $C_treg1 - baseaddr
\ $C_treg2 - numsamples
\ $C_treg3 - samplecycle
\ $C_treg4 - triggerbefore
\ $C_treg5 - triggerafter
\ $C_treg6 - triggermask
\
\
\ wait for trigger
\
	waitpeq $C_treg4 , $C_treg6
	waitpeq $C_treg5 , $C_treg6
\
\ get the sample and set up the count for the next sample
\
\
\                                               t = 0
	mov	$C_treg6 , ina
\                                               t = 4
	mov	$C_treg5 , cnt
\                                               t = 8
	add	$C_treg5 , $C_treg3
\
\ $C_treg1 - baseaddr
\ $C_treg2 - numsamples
\ $C_treg3 - samplecycle
\ $C_treg4 - triggerbefore
\ $C_treg5 - nextcounttosample
\ $C_treg6 - current sample
\
__1
\
\ write out the sample
\
\                                               t = 12
	wrlong	$C_treg6 , $C_treg1
\
\ wait for the next sample time
\
\                                               t = 20 - 35
	waitcnt $C_treg5 , $C_treg3
\                                               t = 26 - 41
\                                                            t = 0
	mov	$C_treg6 , ina
\                                                            t = 4
	add	$C_treg1 , # 4
\                                                            t = 8
	djnz	$C_treg2 , # __1
\                                                            t = 12

\ we are done
	jexit
\
;asm _la_asample41+

\ _la_asample18+ ( baseaddr numsamples samplecycle triggerbefore triggerafter triggermask -- numsamples )
build_BootOpt :rasm
\ trigger mask
	mov	$C_treg6 , $C_stTOS
	spop
\ trigger after
	mov	$C_treg5 , $C_stTOS
	spop
\ trigger before
	mov	$C_treg4 , $C_stTOS
	spop

\ sample cycle
	mov	$C_treg3 , $C_stTOS
	spop

\ num samples
\	mov	$C_treg2 , $C_stTOS
	spop

\ base address - $C_treg1
	mov	$C_treg1 , $C_stTOS

	mov	$C_treg2 , # par
	sub	$C_treg2 , # __buffer
	mov	$C_stTOS , $C_treg2
\
\ $C_treg1 - baseaddr
\ $C_treg2 - numsamples
\ $C_treg3 - samplecycle
\ $C_treg4 - triggerbefore
\ $C_treg5 - triggerafter
\ $C_treg6 - triggermask
\
\
\ wait for trigger
\
	waitpeq $C_treg4 , $C_treg6
	waitpeq $C_treg5 , $C_treg6
\
\ get the sample and set up the count for the next sample
\
\
\                                               t = 0
	mov	__buffer , ina
\                                               t = 4
	mov	$C_treg5 , cnt
\                                               t = 8
	add	$C_treg5 , $C_treg3
\
\ $C_treg1 - baseaddr
\ $C_treg2 - numsamples
\ $C_treg3 - samplecycle
\ $C_treg4 - triggerbefore
\ $C_treg5 - nextcounttosample
\ $C_treg6 - current sample
\
__1
\
\ wait for the next sample time
\
\                                               t = 12
	waitcnt $C_treg5 , $C_treg3
\                                               t = 18
\                                                            t = 0
__2
	mov	__buffer1 , ina
\                                                            t = 4
	add	__2 , $C_fDestInc
\                                                            t = 8
	djnz	$C_treg2 , # __1
\                                                            t = 12

	mov	$C_treg2 , $C_stTOS
__3
	wrlong	__buffer , $C_treg1

	add	__3 , $C_fDestInc
	add	$C_treg1 , # 4

	djnz	$C_treg2 , # __3

\ we are done
	jexit
__buffer
 0
__buffer1
 0
\
;asm _la_asample18+

\ _la_asample4 ( baseaddr numsamples samplecycle triggerbefore triggerafter triggermask -- numsamples )
build_BootOpt :rasm
\ trigger mask
	mov	$C_treg6 , $C_stTOS
	spop
\ trigger after
	mov	$C_treg5 , $C_stTOS
	spop
\ trigger before
	mov	$C_treg4 , $C_stTOS
	spop

\ sample cycle
	spop

\ num samples
	spop

\ base address - $C_treg1
	mov	$C_treg1 , $C_stTOS

	mov	$C_treg2 , # par
	sub	$C_treg2 , # 1
	movd	__3 , $C_treg2

	sub	$C_treg2 , # __buffer
	mov	$C_stTOS , $C_treg2

__1
	mov	__buffer , __inainst
__2
	movd	__buffer , # __buffer
	add	__1 , $C_fDestInc
	add	__2 , $C_fDestInc
	add	__2 , # 1
	djnz	$C_treg2 , # __1

	movs	__jmpinst , # __4
__3
	mov	0 , __jmpinst

	jmp	# __sample

__4

	mov	$C_treg2 , $C_stTOS
__5
	wrlong	__buffer , $C_treg1

	add	__5 , $C_fDestInc
	add	$C_treg1 , # 4

	djnz	$C_treg2 , # __5

\ we are done
	jexit

__inainst
	hA0BC01F2
__jmpinst
	h5C7C0000
\
\ wait for trigger
\
__sample
	waitpeq $C_treg4 , $C_treg6
	waitpeq $C_treg5 , $C_treg6
__buffer
 0

\
;asm _la_asample4

\ _la_asample1 ( baseaddr startcount -- numsamples )
build_BootOpt :rasm
\ startcount
	mov	$C_treg6 , $C_stTOS
	spop

\ base address
	mov	$C_treg1 , $C_stTOS

	mov	$C_treg2 , # par
	sub	$C_treg2 , # 1
	movd	__3 , $C_treg2

	sub	$C_treg2 , # __buffer
	mov	$C_stTOS , $C_treg2

__1
	mov	__buffer , __inainst
__2
	movd	__buffer , # __buffer
	add	__1 , $C_fDestInc
	add	__2 , $C_fDestInc
	add	__2 , # 1
	djnz	$C_treg2 , # __1

	movs	__jmpinst , # __4
__3
	mov	0 , __jmpinst

	jmp	# __sample

__4

	mov	$C_treg2 , $C_stTOS
__5
	wrlong	__buffer , $C_treg1

	add	__5 , $C_fDestInc
	add	$C_treg1 , # h10

	djnz	$C_treg2 , # __5

\ we are done
	jexit

__inainst
	hA0BC01F2
__jmpinst
	h5C7C0000
\
\ wait for trigger
\
__sample
	waitcnt $C_treg6 , # 0
__buffer
 0

\
;asm _la_asample1

hA state andC!

}

...


!=======================================================================
!  COPYRIGHT 1998-2010 The University of Georgia, Griffin, Georgia
!                      University of Florida, Gainesville, Florida
!                      Iowa State University, Ames, Iowa
!                      International Center for Soil Fertility and
!                       Agricultural Development, Muscle Shoals, Alabama
!                      University of Guelph, Guelph, Ontario
!  ALL RIGHTS RESERVED
!=======================================================================
!  SOIL, Subroutine
!-----------------------------------------------------------------------
!  Soil Processes subroutine.  Calls the following modules:
!     SOILDYN     - integrates soil properties variables
!     WATBAL      - soil water balance
!     SoilN_inorg - inorganic soil N (from NTRANS)
!     SoilPi      - inorganic soil P
!     SoilKi      - inorganic soil K
!     SoilOrg     - Ceres soil organic matter (from NTRANS)
!     CENTURY     - Century soil organic matter
!-----------------------------------------------------------------------
!  REVISION HISTORY
!  11/02/2001 CHP Written
!  04/20/2002 GH  Modified for crop rotations
!  10/24/2005 CHP Put weather variables in constructed variable.
!  10/25/2005 CHP Removed NTRANS_OLD module
!  02/22/2006 CHP Added tiledrain.
!  03/03/2006 CHP Added tillage (A.Andales & WDBatchelor).
!  03/21/2006 CHP Added mulch effects
!  07/14/2006 CHP Added P model, split inorganic and organic N routines,
!                 move fertilizer and organic matter placement routines
!                 to management module.
!  10/31/2007 CHP Added simple K model.
C=====================================================================

      SUBROUTINE SOIL(CONTROL, ISWITCH,
     &    ES, FERTDATA, HARVRES, IRRAMT, KTRANS,          !Input
     &    KUptake, OMAData, PUptake, SENESCE, ST,         !Input
     &    FracRts, SWDELTX,TILLVALS, UNH4, UNO3, UPFLOW,  !Input
     &    WEATHER, XHLAI, FLOODN, FLOODWAT, MULCH,        !I/O
     &    NH4_plant, NO3_plant, SKi_AVAIL, SNOW,          !Output
     &    SPi_AVAIL, SOILPROP, SomLitC, SomLitE,          !Output
     &    SW, SWDELTS, SWDELTU, UPPM, WINF, YREND)        !Output

!-----------------------------------------------------------------------
      USE ModuleDefs
      USE FloodModule
      IMPLICIT NONE
      SAVE
!-----------------------------------------------------------------------
!     Interface variables:
!-----------------------------------------------------------------------
!     Input:
      TYPE (ControlType) , INTENT(IN) :: CONTROL
      TYPE (SwitchType)  , INTENT(IN) :: ISWITCH
      REAL               , INTENT(IN) :: ES
      TYPE (FertType)    , INTENT(IN) :: FERTDATA
      Type (ResidueType) , INTENT(IN) :: HARVRES
      REAL               , INTENT(IN) :: IRRAMT
      REAL               , INTENT(IN) :: KTRANS
      TYPE (OrgMatAppType),INTENT(IN) :: OMAData
      REAL, DIMENSION(NL), INTENT(IN) :: PUptake, KUptake
      Type (ResidueType) , INTENT(IN) :: SENESCE
!     REAL               , INTENT(IN) :: SRFTEMP
      REAL, DIMENSION(NL), INTENT(IN) :: ST
      REAL, DIMENSION(NL), INTENT(IN) :: FracRts
      REAL, DIMENSION(NL), INTENT(IN) :: SWDELTX
      TYPE (TillType)    , INTENT(IN) :: TILLVALS
      REAL, DIMENSION(NL), INTENT(IN) :: UNH4, UNO3
      TYPE (WeatherType) , INTENT(IN) :: WEATHER
      REAL               , INTENT(IN) :: XHLAI

      REAL, DIMENSION(NL) :: SomLit

!     Input/Output:
      REAL, DIMENSION(NL), INTENT(INOUT) :: UPFLOW
      TYPE (FloodNType)   FLOODN
      TYPE (FloodWatType) FLOODWAT
      TYPE (MulchType)    MULCH

!     Output:
      REAL, DIMENSION(NL), INTENT(OUT) :: NH4_plant
      REAL, DIMENSION(NL), INTENT(OUT) :: NO3_plant
      REAL, DIMENSION(NL), INTENT(OUT) :: UPPM
      REAL, DIMENSION(NL), INTENT(OUT) :: SPi_AVAIL, SKi_AVAIL
      REAL               , INTENT(OUT) :: SNOW
      TYPE (SoilType)    , INTENT(OUT) :: SOILPROP
      REAL, DIMENSION(NL), INTENT(OUT) :: SW
      REAL, DIMENSION(NL), INTENT(OUT) :: SWDELTS
      REAL, DIMENSION(NL), INTENT(OUT) :: SWDELTU
      REAL               , INTENT(OUT) :: WINF
      INTEGER            , INTENT(OUT) :: YREND
      REAL, DIMENSION(0:NL) :: SomLitC
      REAL, DIMENSION(0:NL,NELEM) :: SomLitE

!-----------------------------------------------------------------------
!     Local variables:
      CHARACTER*1  MESOM

      INTEGER DYNAMIC

      REAL, DIMENSION(0:NL) :: newCO2 !DayCent
      REAL, DIMENSION(NL) :: DRN
      REAL, DIMENSION(NL) :: SPi_Labile, NO3, NH4
      REAL, DIMENSION(0:NL) :: LITC, SSOMC
      REAL, DIMENSION(0:NL,NELEM) :: IMM, MNR

!     Added for tile drainage:
      REAL TDFC
      INTEGER TDLNO

!-----------------------------------------------------------------------
!     Transfer values from constructed data types into local variables.
      DYNAMIC = CONTROL % DYNAMIC
      MESOM   = ISWITCH % MESOM

!***********************************************************************
!     Call Soil Dynamics module
!      IF (DYNAMIC < OUTPUT) THEN
        CALL SOILDYN(CONTROL, ISWITCH,
     &    KTRANS, MULCH, SomLit, SomLitC, SW, TILLVALS,   !Input
     &    WEATHER, XHLAI,                                 !Input
     &    SOILPROP)                                       !Output
!      ENDIF

!     Call WATBAL first for all except seasonal initialization
      IF (DYNAMIC /= SEASINIT) THEN
        CALL WATBAL(CONTROL, ISWITCH,
     &    ES, IRRAMT, SOILPROP, SWDELTX,                  !Input
     &    TILLVALS, WEATHER,                              !Input
     &    FLOODWAT, MULCH, SWDELTU,                       !I/O
     &    DRN, SNOW, SW, SWDELTS,                         !Output
     &    TDFC, TDLNO, UPFLOW, WINF)                      !Output
      ENDIF

!     Soil organic matter modules
      IF (MESOM .EQ. 'P') THEN
!       Parton (Century-based) soil organic matter module
        CALL CENTURY(CONTROL, ISWITCH,
     &    FERTDATA, FLOODWAT, FLOODN, HARVRES, NH4,       !Input
     &    NO3, OMADATA, SENESCE, SOILPROP, SPi_Labile,    !Input
     &    ST, SW, TILLVALS,                               !Input
     &    IMM, LITC, MNR, MULCH, SomLit, SomLitC,         !Output
     &    SomLitE, SSOMC,                                 !Output
     &    newCO2)             !for DayCent in SOILNI added by PG
      ELSE
!      ELSEIF (MESOM .EQ. 'G') THEN
!       Godwin (Ceres-based) soil organic matter module (formerly NTRANS)
        CALL SoilOrg (CONTROL, ISWITCH,
     &    FLOODWAT, FLOODN, HARVRES, NH4, NO3, OMAData,   !Input
     &    SENESCE, SOILPROP, SPi_Labile, ST, SW, TILLVALS,!Input
     &    IMM, LITC, MNR, MULCH, newCO2, SomLit, SomLitC, !Output
     &    SomLitE, SSOMC)                                 !Output
      ENDIF

!     Inorganic N (formerly NTRANS)
      CALL SoilNi (CONTROL, ISWITCH,
     &    DRN, ES, FERTDATA, FLOODWAT, IMM, LITC, MNR,    !Input
     &    newCO2, SNOW, SOILPROP, SSOMC, ST, SW, TDFC,    !Input
     &    TDLNO, TILLVALS, UNH4, UNO3, UPFLOW, WEATHER,   !Input
     &    XHLAI,                                          !Input
     &    FLOODN,                                         !I/O
     &    NH4, NO3, NH4_plant, NO3_plant, UPPM)           !Output

!     Inorganic P
      CALL SoilPi(CONTROL, ISWITCH, FLOODWAT,
     &    FERTDATA, IMM, MNR, PUptake, SOILPROP,          !Input
     &    FracRts, SW, TillVals,                          !Input
     &    SPi_AVAIL, SPi_Labile, YREND)                   !Output

!     Inorganic K
      CALL SoilKi(CONTROL, ISWITCH,
     &    FERTDATA, KUptake, SOILPROP, TILLVALS,          !Input
     &    SKi_Avail)                                      !Output

      IF (DYNAMIC == SEASINIT) THEN
!       Soil water balance -- call last for initialization
        CALL WATBAL(CONTROL, ISWITCH,
     &    ES, IRRAMT, SOILPROP, SWDELTX,                  !Input
     &    TILLVALS, WEATHER,                              !Input
     &    FLOODWAT, MULCH, SWDELTU,                       !I/O
     &    DRN, SNOW, SW, SWDELTS,                         !Output
     &    TDFC, TDLNO, UPFLOW, WINF)                      !Output
      ENDIF

!***********************************************************************

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

      RETURN
      END SUBROUTINE SOIL

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


!******************************************************************
!Copyright 2013-2016 SEISCOPE II project, All rights reserved.
!
!Redistribution and use in source and binary forms, with or
!without modification, are permitted provided that the following
!conditions are met:
!
!    *  Redistributions of source code must retain the above copyright
!       notice, this list of conditions and the following disclaimer.
!    *  Redistributions in binary form must reproduce the above
!       copyright notice, this list of conditions and the following
!       disclaimer in the documentation and/or other materials provided
!       with the distribution.
!    *  Neither the name of the SEISCOPE project nor the names of
!       its contributors may be used to endorse or promote products
!       derived from this software without specific prior written permission.
!
!Warranty Disclaimer:
!THIS SOFTWARE IS PROVIDED BY THE SEISCOPE PROJECT AND CONTRIBUTORS
!"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
!LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
!FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
!SEISCOPE PROJECT OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
!INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
!BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
!LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
!CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
!STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
!IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!POSSIBILITY OF SUCH DAMAGE.

module opt_PNLCG
use, intrinsic :: iso_c_binding
use typedef
use miscellaneous
use opt_PSTD, only : xk, descent

private
real, allocatable, dimension(:) :: grad_prev, descent_prev
public PNLCG, grad_prev, descent_prev

!Module procedures have access to module variables through host association.

contains

subroutine pnlcg_centry(n,x,fcost,grad,grad_preco,optim,flag,lb,ub) bind(c, name='PNLCG')
  !IN
  integer(c_int), value  :: n                   !dimension of the problem
  real(c_float)   :: fcost                      !cost associated with x
  real(c_float),dimension(n) :: grad,grad_preco !gradient and preconditioned gradient at x
  !IN/OUT
  integer(c_int)  :: flag
  real(c_float),dimension(n) :: x               !current point
  type(optim_type) :: optim                     !data structure
  type(c_ptr), value  :: lb,ub
  real(c_float), pointer, dimension(:) :: lb_pass, ub_pass

  nullify(lb_pass)
  nullify(ub_pass)
  if (c_associated(ub)) call c_f_pointer(ub, ub_pass, (/n/))
  if (c_associated(lb)) call c_f_pointer(lb, lb_pass, (/n/))
  call pnlcg(n,x,fcost,grad,grad_preco,optim,flag,lb_pass,ub_pass)
end subroutine pnlcg_centry

!*****************************************************!
!*          SEISCOPE OPTIMIZATION TOOLBOX            *!
!*****************************************************!
! Computation of the descent direction given by the
! preconditioned nonlinear conjugate gradient algorithm
! of Dai and Yuan
! Y. DAI AND Y. YUAN, A nonlinear conjugate gradient  !
! method with a strong global convergence property,   !
! SIAM Journal on Optimization, 10 (1999), pp. 177–182!
!                                                     !
! See also Nocedal, Numerical optimization,           !
! 2nd edition p.132                                   !
!-----------------------------------------------------!
! INPUT  : integer :: n (dimension)                   !
!          real,dimension(n) :: grad,grad_preco       !
! INPUT/OUTPUT : optim_typ optim (data structure)     !
!-----------------------------------------------------!
subroutine descent_PNLCG(n,grad,grad_preco)

  implicit none
  !IN
  integer :: n
  real,dimension(n) :: grad,grad_preco
  !Local variables
  real :: gkpgk,skpk,beta
  real,dimension(:),allocatable :: sk

  !------------------------------------------------------------!
  ! Storing old descent direction                              !
  !------------------------------------------------------------!
  descent_prev(:)=descent(:)

  !------------------------------------------------------------!
  ! Computation of beta                                        !
  !------------------------------------------------------------!  !
  gkpgk =dot_product(grad,grad_preco)
  allocate(sk(n))
  sk(:)=grad(:)-grad_prev(:)
  skpk = dot_product(sk,descent_prev)
  beta=gkpgk/skpk

  !------------------------------------------------------------!
  ! Safeguard (may be useful in some cases)                    !
  !------------------------------------------------------------!
  if((beta.ge.1e5).or.(beta.le.-1e5)) then
     beta=0.
  endif

  !------------------------------------------------------------!
  ! Computation of the descent direction                       !
  !------------------------------------------------------------!
  descent(:)=-1.*grad_preco(:)+beta*descent_prev(:)

  !------------------------------------------------------------!
  ! Deallocation                                               !
  !------------------------------------------------------------!
  deallocate(sk)

end subroutine descent_PNLCG
!*********************************************!
!*    SEISCOPE OPTIMIZATION TOOLBOX          *!
!*********************************************!
! This routine is used to deallocate all the  !
! arrays that have been used during the       !
! PSTD optimization                           !
!---------------------------------------------!
! INPUT/OUT:  optim_type optim                !
!---------------------------------------------!
subroutine finalize_PNLCG

  implicit none

  deallocate(xk)
  deallocate(grad_prev)
  deallocate(descent)
  deallocate(descent_prev)

end subroutine finalize_PNLCG
!*****************************************************!
!*          SEISCOPE OPTIMIZATION TOOLBOX            *!
!*****************************************************!
! This routine is used for the initialization of the  !
! reverse communication mode preconditioned nonlinear !
! conjugate gradient algorithm from the TOOLBOX.      !
!                                                     !
! The parameters for the linesearch are set here, as  !
! well as the data structure allocations required for !
! the use of the algorithm                            !
!-----------------------------------------------------!
! INPUT : integer n, dimension of the problem         !
!       : real fcost                                  !
!       : real,dimension(n) x,grad,grad_preco         !
!                           first iterate, gradient   !
!                           preconditioned gradient   !
! INPUT/OUTPUT : optim_type optim data structure      !
!-----------------------------------------------------!
subroutine init_PNLCG(n,x,fcost,grad_preco,optim)

  implicit none

  !IN
  integer :: n
  real :: fcost
  real,dimension(n) :: x,grad_preco
  !IN/OUT
  type(optim_type) :: optim !data structure

  !---------------------------------------!
  ! set counters                          !
  !---------------------------------------!
  optim%cpt_iter=0
  optim%f0=fcost
  optim%nfwd_pb=0

  !---------------------------------------!
  ! initialize linesearch parameters      !
  ! by default, the max number of         !
  ! linesearch iteration is set to 20     !
  ! and the initial steplength is set to 1!
  !---------------------------------------!
  optim%m1=1e-4 ! Wolfe conditions parameter 1 (Nocedal value)
  optim%m2=0.9  ! Wolfe conditions parameter 2 (Nocedal value)
  optim%mult_factor=10 ! Bracketting parameter (Gilbert value)
  optim%fk=fcost
  optim%nls_max=30 ! max number of linesearch
  optim%cpt_ls=0
  optim%first_ls=.true.
  optim%alpha=1. ! first value for the linesearch steplength

  !---------------------------------------!
  ! memory allocations                    !
  !---------------------------------------!
  allocate(grad_prev(n))
  allocate(descent_prev(n))
  allocate(xk(n))
  xk(:)=x(:)
  allocate(descent(n))

  !---------------------------------------!
  ! first descent direction               !
  !---------------------------------------!
  descent(:)=-1.*grad_preco(:)

end subroutine init_PNLCG
!*****************************************************!
!*          SEISCOPE OPTIMIZATION TOOLBOX            *!
!*****************************************************!
! This routine is the reverse communication mode      !
! preconditioned nonlinear conjugate gradient         !
! algorithm of Dai and Yuan                           !
! Y. DAI AND Y. YUAN, A nonlinear conjugate gradient  !
! method with a strong global convergence property,   !
! SIAM Journal on Optimization, 10 (1999), pp. 177–182!
!                                                     !
! See also Nocedal, Numerical optimization,           !
! 2nd edition p.132                                   !
!                                                     !
! This routine performs an iterative                  !
! minimization of a function f following the          !
! recurrence                                          !
!                                                     !
! x_{0}=x0                                            !
! x_{k+1}=x_k+\alpha_k d_k                            !
!                                                     !
! where the descent direction d_k is                  !
!                                                     !
! d_k=-Q_k \nabla f_k + \beta_k d_{k-1}               !
!                                                     !
! where Q_k       : preconditioner at iteration k     !
!      \nabla f_k : gradient of f in x_k              !
!      \beta_k    : scalar computed through the       !
!                   Dai and Yuan formula              !
!                                                     !
! and alpha_k is the steplength computed through the  !
! common linesearch algorithm of the TOOLBOX          !
!                                                     !
! The first call to the algorithm must be done with   !
! FLAG='INIT'. For this first call, the initial point !
! x0 is given through the variable x. The input       !
! variables fcost and grad, grad_preco must correspond!
! respectively to the misfit, gradient and            !
! preconditioned gradient at x0.                      !
!                                                     !
! The reverse communication with the user is          !
! performed through the variable FLAG. This           !
! variable indicates to the user on return what action!
! he has to do, or the state of the algorithm.        !
! Possible values are                                 !
! - FLAG='GRAD' => the user must compute the cost,    !
!                  gradient and preconditioned        !
!                  gradient at current point x        !
! - FLAG='CONV' => a minimizer has been found         !
! - FLAG='NSTE' => a new step is performed            !
! - FLAG='FAIL' => the linesearch has failed          !
!-----------------------------------------------------!
! INPUT  : integer :: n (dimension)                   !
!          real fcost (current cost)                  !
!          real,dimension(n) grad                     !
!          real,dimension(n) grad_preco               !
! INPUT/OUTPUT : real,dimension(n) x                  !
!                optim_typ optim (data structure)     !
!                character*4 FLAG (communication)     !
!-----------------------------------------------------!
subroutine PNLCG(n,x,fcost,grad,grad_preco,optim,flag,lb,ub)

  implicit none

  !IN
  integer  :: n                           !dimension of the problem
  real   :: fcost                       !cost associated with x
  real,dimension(n) :: grad,grad_preco !gradient and preconditioned gradient at x
  !IN/OUT
  integer  :: flag
  real,dimension(n) :: x               !current point
  real(c_float),optional, dimension(n) :: lb,ub
  type(optim_type) :: optim            !data structure
  !Local variable
  logical :: test_conv

  if(FLAG.eq. 0) then
     !-----------------------------------------------------!
     ! if FLAG is INIT, call the dedicated initialization  !
     ! subroutine to allocate data structure optim and     !
     ! initialize the linesearch process                   !
     !-----------------------------------------------------!
     call init_PNLCG(n,x,fcost,grad_preco,optim)
     call std_linesearch(n,x,fcost,grad,xk,descent,optim,lb,ub) !lb,ub,optim
     call print_info(n,'CG',optim,fcost,grad,FLAG)
     FLAG=1
     optim%nfwd_pb=optim%nfwd_pb+1
     !Store current gradient before the user compute the new one
     grad_prev(:)=grad(:)
  else
     !-----------------------------------------------------!
     ! else call the linesearch process                    !
     !-----------------------------------------------------!
     call std_linesearch(n,x,fcost,grad,xk,descent,optim,lb,ub) !lb,ub,optim
     if(optim%task.eq. 0) then
        optim%cpt_iter=optim%cpt_iter+1
        !-----------------------------------------------------!
        ! test for convergence                                !
        !-----------------------------------------------------!
        call std_test_conv(optim,fcost,test_conv)
        if(test_conv) then
           FLAG=2
           !print info on current iteration
           call print_info(n,'CG',optim,fcost,grad,FLAG)
           call finalize_PNLCG
        else
           FLAG=3
           !-----------------------------------------------------!
           ! if a NEW_STEP is taken, compute a new descent       !
           ! direction using current descent, gradient and       !
           ! preconditioned gradient                             !
           !-----------------------------------------------------!
           call descent_PNLCG(n,grad,grad_preco)
           !print info on current iteration
           call print_info(n,'CG',optim,fcost,grad,FLAG)
        endif
     elseif(optim%task.eq. 1) then
        !-----------------------------------------------------!
        ! if the linesearch needs a new gradient then ask the !
        ! user to provide it
        !-----------------------------------------------------!
        FLAG=1
        optim%nfwd_pb=optim%nfwd_pb+1
        !Store current gradient before the user compute the new one
        grad_prev(:)=grad(:)
     elseif(optim%task.eq. 2) then
        !-----------------------------------------------------!
        ! if the linesearch has failed, inform the user       !
        !-----------------------------------------------------!
        FLAG=4
        !print info on current iteration
        call print_info(n,'CG',optim,fcost,grad,FLAG)
        call finalize_PNLCG
     endif
  endif

end subroutine PNLCG

end module opt_PNLCG


module io_read_wf_general_module

  use parallel_module, only: para, myrank_s,myrank_k,myrank_b,myrank_g
  use watch_module, only: watchb
  use wf_module, only: unk

  implicit none

  private
  public :: read_wf_general

contains

  subroutine read_wf_general( pinfo0,pinfo1,ML1,ML2,Ml3,MB0,MBZ0,MSP0,MB1,MBZ1,MSP1,type_wf )
    implicit none
    type(para),intent(in) :: pinfo0, pinfo1
    integer,intent(in) :: ML1,ML2,ML3,MB0,MBZ0,MSP0,MB1,MBZ1,MSP1
    integer,intent(in) :: type_wf
    real(8) :: ttmp(2),tt(2)
    logical :: disp
    integer :: p1,p2,p3,p4,p5,p6,irank_g,irank_g_old,g0,g1,g2,g3
    integer :: s0,s1,k0,k1,b0,b1,i1_0,i1_1,i2_0,i2_1,i3_0,i3_1
    integer :: i1_2,i1_3,i2_2,i2_3,i3_2,i3_3
    integer :: s,k,b,i1,i2,i3,irank_old,s2,s3,k2,k3,b2,b3,n,i,ng
    integer :: ig, ig_old, n11, n12
    character(13) :: filename
    character(7) :: basename
    character(5) :: crank
    integer,allocatable :: ir_new(:,:), id_new(:,:)
    integer,allocatable :: ir_old(:,:), id_old(:,:)
    real(8),allocatable :: dtmp(:)
    complex(8),allocatable :: utmp(:)
    integer,parameter :: u=3

    call write_border( 0, " read_wf_general(start)" )
    call check_disp_switch( disp, 0 )
    call watchb( ttmp, barrier='on' ); tt=0.0d0

    basename = 'wf.dat1'

    s2 = pinfo1%spin%id(myrank_s)+1
    s3 = s2 + pinfo1%spin%ir(myrank_s)-1
    k2 = pinfo1%bzsm%id(myrank_k)+1
    k3 = k2 + pinfo1%bzsm%ir(myrank_k)-1
    b2 = pinfo1%band%id(myrank_b)+1
    b3 = b2 + pinfo1%band%ir(myrank_b)-1
    g2 = pinfo1%grid%id(myrank_g)+1
    g3 = g2 + pinfo1%grid%ir(myrank_g)-1

    n = maxval( pinfo1%np(1:3) )
    allocate( ir_new(0:n-1,3) ); ir_new=0
    allocate( id_new(0:n-1,3) ); id_new=0
    do i1 = 0, ML1-1
      n = mod( i1, pinfo1%np(1) )
      ir_new(n,1) = ir_new(n,1) + 1
    end do
    do i2 = 0, ML2-1
      n = mod( i2, pinfo1%np(2) )
      ir_new(n,2) = ir_new(n,2) + 1
    end do
    do i3 = 0, ML3-1
      n = mod( i3, pinfo1%np(3) )
      ir_new(n,3) = ir_new(n,3) + 1
    end do
    do i = 1, 3
      do n = 0, pinfo1%np(i)-1
        id_new(n,i) = sum( ir_new(0:n,i) ) - ir_new(n,i)
      end do
    end do

    n = maxval( pinfo0%np(1:3) )
    allocate( ir_old(0:n-1,3) ); ir_old=0
    allocate( id_old(0:n-1,3) ); id_old=0
    do i1 = 0, ML1-1
      n = mod( i1, pinfo0%np(1) )
      ir_old(n,1) = ir_old(n,1) + 1
    end do
    do i2 = 0, ML2-1
      n = mod( i2, pinfo0%np(2) )
      ir_old(n,2) = ir_old(n,2) + 1
    end do
    do i3 = 0, ML3-1
      n = mod( i3, pinfo0%np(3) )
      ir_old(n,3) = ir_old(n,3) + 1
    end do
    do i = 1, 3
      do n = 0, pinfo0%np(i)-1
        id_old(n,i) = sum( ir_old(0:n,i) ) - ir_old(n,i)
      end do
    end do

    loop_i3: do i3 = 0, pinfo1%np(3)-1
             do i2 = 0, pinfo1%np(2)-1
             do i1 = 0, pinfo1%np(1)-1
               irank_g = i1 + i2*pinfo1%np(1) + i3*pinfo1%np(1)*pinfo1%np(2)
               if ( irank_g == myrank_g ) then
                 i1_2 = id_new(i1,1)
                 i1_3 = id_new(i1,1) + ir_new(i1,1) - 1
                 i2_2 = id_new(i2,2)
                 i2_3 = id_new(i2,2) + ir_new(i2,2) - 1
                 i3_2 = id_new(i3,3)
                 i3_3 = id_new(i3,3) + ir_new(i3,3) - 1
                 n11 = i1_3 - i1_2 + 1
                 n12 = n11*(i2_3-i2_2+1)
                 exit loop_i3
               end if
             end do
             end do
             end do loop_i3

    n=maxval(pinfo0%grid%ir)
    if ( type_wf == 1 ) then ! real-wf
      allocate( dtmp(n) ); dtmp=0.0d0
    else ! complex-wf
      allocate( utmp(n) ); utmp=(0.0d0,0.0d0)
    end if

    irank_old = -1

    do p6 = 0, pinfo0%np(6)-1
      s0 = pinfo0%spin%id(p6)+1
      s1 = s0 + pinfo0%spin%ir(p6)-1
    do p5 = 0, pinfo0%np(5)-1
      k0 = pinfo0%bzsm%id(p5)+1
      k1 = k0 + pinfo0%bzsm%ir(p5)-1
    do p4 = 0, pinfo0%np(4)-1
      b0 = pinfo0%band%id(p4)+1
      b1 = b0 + pinfo0%band%ir(p4)-1

      irank_g_old = -1

      do p3 = 0, pinfo0%np(3)-1
        i3_0 = id_old(p3,3)
        i3_1 = i3_0 + ir_old(p3,3) - 1
      do p2 = 0, pinfo0%np(2)-1
        i2_0 = id_old(p2,2)
        i2_1 = i2_0 + ir_old(p2,2) - 1
      do p1 = 0, pinfo0%np(1)-1
        i1_0 = id_old(p1,1)
        i1_1 = i1_0 + ir_old(p1,1) - 1

        irank_g_old = irank_g_old + 1
        g0 = pinfo0%grid%id(irank_g_old)+1
        g1 = g0 + pinfo0%grid%ir(irank_g_old)-1

        irank_old = irank_old + 1

        write(crank,'(i5.5)') irank_old
        filename = basename//'.'//crank

        if ( (s3<s0 .or. s1<s2) .or. (k3<k0 .or. k1<k2) .or. (b3<b0 .or. b1<b2) .or. &
              (i1_3<i1_0 .or. i1_1<i1_2) .or. (i2_3<i2_0 .or. i2_1<i2_2) .or. &
              (i3_3<i3_0 .or. i3_1<i3_2) ) cycle

        open(u,file=filename,status='old',form='unformatted')

        ng = g1 - g0 + 1
        do s = s0, s1
        do k = k0, k1
        do b = b0, b1

          if ( s<s2 .or. s3<s .or. k<k2 .or. k3<k .or. b<b2 .or. b3<b ) then
            read(u)
            cycle
          end if

          if ( type_wf == 1 ) then ! real-wf

            read(u) dtmp(1:ng)

            ! if ( s<s2 .or. s3<s .or. k<k2 .or. k3<k .or. b<b2 .or. b3<b ) cycle

            ig_old=0
            do i3 = i3_0, i3_1
            do i2 = i2_0, i2_1
            do i1 = i1_0, i1_1
              ig_old = ig_old + 1
              if ( i1<i1_2 .or. i1_3<i1 .or. i2<i2_2 .or. i2_3<i2 .or. i3<i3_2 .or. i3_3<i3 ) cycle
              ig = g2 + i1-i1_2 + n11*(i2-i2_2) + n12*(i3-i3_2)
              unk(ig,b,k,s)=dtmp(ig_old)
            end do
            end do
            end do

          else ! complex-wf

            read(u) utmp(1:ng)

            ! if ( s<s2 .or. s3<s .or. k<k2 .or. k3<k .or. b<b2 .or. b3<b ) cycle

            ig_old=0
            do i3 = i3_0, i3_1
            do i2 = i2_0, i2_1
            do i1 = i1_0, i1_1
              ig_old = ig_old + 1
              if ( i1<i1_2 .or. i1_3<i1 .or. i2<i2_2 .or. i2_3<i2 .or. i3<i3_2 .or. i3_3<i3 ) cycle
              ig = g2 + i1-i1_2 + n11*(i2-i2_2) + n12*(i3-i3_2)
              unk(ig,b,k,s)=utmp(ig_old)
            end do
            end do
            end do

          end if

        end do !b
        end do !k
        end do !s

        close(u)

      end do !p1
      end do !p2
      end do !p3

    end do !p4
    end do !p5
    end do !p6

    deallocate( id_old )
    deallocate( ir_old )
    deallocate( id_new )
    deallocate( ir_new )
    if ( allocated(dtmp) ) deallocate(dtmp)
    if ( allocated(utmp) ) deallocate(utmp)

    call watchb( ttmp, tt, barrier='on' )
    if ( disp ) then
      write(*,*) "time(read_wf_general)=",tt
    end if
    call write_border( 0, " read_wf_general(end)" )

  end subroutine read_wf_general

end module io_read_wf_general_module


      subroutine endchn(npart,nraint,traint,nptsc,toplen,nyear,ichplt)
c
c     + + + PURPOSE + + +
c
c     SR ENDCHN writes the hydrologic and erosion summary
c     for the entire simulation period.
c
c     Called from: SR WSHDRV
c     Author(s): Ascough II, Livingston, R. van der Zweep
c     Reference in User Guide:
c
c     Version:
c     Date recoded:
c     Recoded by: Jim Ascough II
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
      include 'pmxcsg.inc'
      include 'pmxelm.inc'
      include 'pmximp.inc'
      include 'pmxhil.inc'
      include 'pmxpln.inc'
      include 'pmxprt.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      real traint, toplen
      integer npart, nptsc, nraint, nyear, ichplt
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     traint -
c     toplen -
c     npart  -
c     nptsc  -
c     nraint -
c     nyear  -
c     ichplt -
c
c     + + + COMMON BLOCKS + + +
c
      include 'cchcon.inc'
      include 'cchpar.inc'
      include 'cchpek.inc'
      include 'cchprt.inc'
      include 'cchsed.inc'
      include 'cenrpa1.inc'
      include 'cimeos.inc'
      include 'coutchn.inc'
      include 'cpart2.inc'
      include 'cseddet.inc'
      include 'cslpopt.inc'
      include 'cstore.inc'
      include 'cstruc.inc'
      include 'cstruct.inc'
      include 'csumirr.inc'
      include 'cimacl.inc'
c
c     + + + LOCAL VARIABLES + + +
c
      real y(mxcseg), concpc, dx, frac, ppm, tcncpc, tconc,
     1    tgs(mxelem), tppm, trunsi, xchn, conv, sdr, wdet,tothill
c
      integer i, k, iseg, ipond,ni
c
c     + + + LOCAL DEFINITIONS + + +
c
c     Real Variables
c
c     y(mxcseg) -
c     concpc    -
c     dx        -
c     frac      -
c     ni        - impoundment clean times(<100)
c     ppm       -
c     tcncpc    -
c     tconc     -
c     tgs       -
c     tppm      -
c     trunsi    -
c     xchn      -
c     conv      -  conversion factor from lbs to kg (0.4536)
c     sdr       -
c     wdet      -
c
c     Integer Variables
c
c     i     -
c     k     -
c     iseg  -
c     ipond -
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     enrcmp
c
c     + + + DATA INITIALIZATIONS + + +
c
c
      ichan = 0
      ipond = 0
      sdr = 0.00
      wdet = 0.0
      conv = 0.4536
c
c     + + + END SPECIFICATIONS + + +
c
c
c     override ichplt so that plotting sections of code not
c     entered
c
      ichplt = 0
c
c
      write (38,1000)nyear
      write (38,1100)
c
      tothill = 0

      do 10 k = 1, nhill
        write (38,1300) k,hrot(k)/nyear,sbrvty(k)/nyear,dett(k)/nyear,
     1    (dept(k)/nyear) * (-1), hsedt(k)/nyear
        wdet = wdet + dett(k)
   10 continue
c
      tothill = wdet
      write (38,1200)
c
      do 30 ielmt = nhill + 1, nelmt
c
        tgs(ielmt) = 0.0
c
        if (elmt(ielmt).eq.2) then
          ichan = ichan + 1
        else
          ipond = ipond + 1
        end if
c
c       get total sediment delivery for each channel
c
        if (elmt(ielmt).eq.3) then
          tgs(ielmt) = coute(ipond) / conv
        else
c
          do 20 k = 1, npart
            tgs(ielmt) = tgs(ielmt) + tgst(k,ielmt)
   20     continue
c
        end if
c
c       convert lbs to total kg soil loss or deposition on channel
c
        wdet = wdet + (cdett(ielmt)*conv)
c
        if (elmt(ielmt).eq.2) write (38,1400) ichan, trunt(ielmt)/nyear,
     1      (tgs(ielmt)/nyear) * conv / 1000.0,
     1      (cdett(ielmt)*conv)/nyear,
     1      tronvt(ielmt)/nyear, sbrvtt(ielmt)/nyear
        if (elmt(ielmt).eq.3) write (38,1500) ipond, trunt(ielmt)/nyear,
     1      (tgs(ielmt)/nyear) * conv / 1000.0
c
        cdett(ielmt) = 0.0
        cdept(ielmt) = 0.0
c
   30 continue
c
      do 40 ielmt = nhill + 1, nelmt
c
c       convert total runoff volume at the watershed outlet from
c       m^3 to mm using the local variable trunsi (si units)
c
        trunsi = (trunt(ielmt)/wsarea(ielmt)) * 1000.0
c
        if (ielmt.eq.nelmt) then
c
c         write to summary output
c
          write (38,1600) nraint/nyear, traint/nyear
c
          write (38,1700) nrunt/nyear, trunsi/nyear
c
          if (wdet.gt.0) sdr = tgs(nelmt) * conv / wdet
          if (wdet.le.0) sdr = 0.0
c
          write (38,2500) wsarea(nelmt) / 10000,
     1        (wsarea(nelmt) * (traint/1000))/nyear, tirrt/nyear,
     1        trunt(nelmt)/nyear,
     1        (tothill/1000)/nyear,((wdet-tothill)/1000)/nyear,
     1        (tgs(nelmt) * conv/1000.)/nyear,
     1        (((tgs(nelmt)*conv)/1000) / (wsarea(nelmt)/10000))/nyear
     1        , sdr
        end if
c
   40 continue
c
      if (nrunt.gt.0) then
c
        ichan = 0
        ipond = 0
c
        do 60 ielmt = nhill + 1, nelmt
c
          if (elmt(ielmt).eq.2) then
            ichan = ichan + 1
          else
            ipond = ipond + 1
          end if
c
c         write output if total soil loss for the simulation is > 1 kg
c
          if (tgs(ielmt).gt.2.205) then
c
            if (elmt(ielmt).eq.2) then
              if (watsum.le.2.and.ielmt.eq.nelmt) write (38,1800)
            else
              if (watsum.le.2.and.ielmt.eq.nelmt) write (38,1900)
            end if
c
            tconc = 0.0
            tcncpc = 0.0
            tppm = 0.0
c
            do 50 k = 1, npart
c
              if (elmt(ielmt).eq.2) then
                conc(k,ielmt) = (tgst(k,ielmt)*0.4536) / trunt(ielmt)
              else
                conc(1,ielmt) = cloute(ipond) / trunt(ielmt)
                conc(2,ielmt) = sloute(ipond) / trunt(ielmt)
                conc(3,ielmt) = saoute(ipond) / trunt(ielmt)
                conc(4,ielmt) = laoute(ipond) / trunt(ielmt)
                conc(5,ielmt) = sdoute(ipond) / trunt(ielmt)
              end if
c
              concpc = conc(k,ielmt) / (wtdh2o*16.0211)
              ppm = concpc * 1.0e+06
c
              if (elmt(ielmt).eq.2) then
                frac = tgst(k,ielmt) / tgs(ielmt)
              else
                frac = conc(k,ielmt) * trunt(ielmt) / coute(ipond)
              end if
c
              if (elmt(ielmt).eq.2) then
c
                if (watsum.le.2.and.ielmt.eq.nelmt) write (38,2000) k,
     1              crdia(k,ielmt) * 1000 / 3.281 , crspg(k),
     1              frsnd(k,ielmt) * 100, frslt(k,ielmt) * 100,
     1              frcly(k,ielmt) * 100, frorg(k,ielmt) * 100, frac
c
              else
c
                if (watsum.le.2.and.ielmt.eq.nelmt) write (38,2100) k,
     1              frac
c
                if (watsum.ge.3) write (38,2100) k, frac
c
              end if
c
              tconc = tconc + conc(k,ielmt)
              tcncpc = tcncpc + concpc
              tppm = tppm + ppm
c
   50       continue
c
            if (ielmt.eq.nelmt) call enrcmp(2,ielmt,nelmt,tgs,
     1          elmt(ielmt))
c
          else
c
            if (watsum.le.2.and.ielmt.eq.nelmt) write (38,2200)
c
          end if
c
   60   continue
c
      else
c
      end if
c
      if (ichplt.eq.1) then
c
c       write out channel profile plotting data
c
        write (37,2300)
c
        iseg = nptsc
        y(iseg) = 0.0
c
        do 70 i = 1, nptsc - 1
          dx = (chnx(ichan,iseg)-chnx(ichan,iseg-1)) * 3.281
          y(iseg-1) = y(iseg) + dx * chnslp(ichan,iseg)
          iseg = iseg - 1
   70   continue
c
        do 80 iseg = 1, nptsc
          xchn = (chnx(ichan,iseg)-toplen) * 3.281
          write (37,2400) xchn, y(iseg), nsedt(iseg) / nyear, -
     1        csedt(iseg) / nyear
   80   continue
c
      end if
c
c      Added by S.Dun
        ipond=0
        do 100 ielmt = nhill + 1, nelmt
c
          if (elmt(ielmt).eq.2) goto 100
          ipond = ipond + 1
          write(38,3000) ipond,alnum(ipond)
                 ni=alnum(ipond)
                if (ni.gt.100) ni=100
                do 90 i=1,ni
                  write( 38,3100) i,alvol(ipond,i)/3.28**3,
     1               aldate(ipond,i),alyear(ipond,i),alhs(ipond,i)/3.281
   90           continue
  100    continue
c        end add
      return
c
c
 1000 format (////,16x,i5,' YEAR AVERAGE ANNUAL VALUES FOR WATERSHED',/,
     1    15x,    '------ ---- ------- ------ ------ --- ---------',//)
 1100 format (/17x,'Runoff',8x,'Subrunoff',5x,'Soil',10x,'Sediment',6x,
     1    'Sediment',/,17x,
     1    'Volume',8x,'Volume',8x,'Loss',10x,'Deposition',4x,'Yield',/,
     1    'Hillslopes',7x,'(m^3)',9x,'(m^3)',9x,'(kg)',10x,'(kg)',10x,
     1    '(kg)',/,10('-'),7x,5(10('-'),4x))
cd 1200 format (///,'Channels',9x,'Discharge',5x,'Sediment',6x,/,'and',
cd     1    14x,'Volume',8x,'Yield',/,'Impoundments',5x,'(m^3/yr)',6x,
cd     1    '(tonne/yr)',/,12('-'),5x,2(10('-'),4x),/)
 1200 format (///'Channels',9x,'Discharge',5x,'Sediment',6x,'Soil',10x,
     1        'Upland',8x,'Subsuface Flow'/,
     1        'and',14x,'Volume',8x,'Yield',9x,'Loss',10x,'Charge',8x,
     1        'Volume' /,'Impoundments',5x,'(m^3)',9x,
     1         '(tonne)',7x,'(kg)',10x,'(m^3)',9x,'(m^3)'/,12('-'),5x,
     1         2(10('-'),4x),3(10('-'),3x),/)
 1300 format ('Hill    ',i4,5(2x,f12.2))
 1400 format ('Channel  ',1x,i4,1x,5(f12.1,2x))
 1500 format ('Impoundment',1x,i2,1x,2(f9.1,5x))
 1600 format (/,i4,' storms produced ',f8.2,' mm. of rainfall on',
     1    ' an AVERAGE ANNUAL basis')
 1700 format (/,i4,' events produced ',f8.2,' mm. of runoff',/,5x,
     1    'passing through the watershed outlet on',
     1    ' an AVERAGE ANNUAL basis',/)
 1800 format ('Sediment Particle Information Leaving Channel:',/,/,
     1    '-----------------------------------------------',
     1    '------------------------',/,
     1    '                             Particle Composition',
     1    '              Fraction',/,'Class  Diameter  Specific  ',
     1    '------------------------            In Flow',/,9x,
     1    '(mm)    Gravity   % Sand   % Silt   % Clay   % O.M.',
     1    '   Exiting',/,
     1    '-------------------------------------------------------',
     1    '------------------------')
 1900 format ('Sediment Particle Information Leaving Impoundment:',//,
     1    '-------------------------------------------------------',/,
     1    '             Fraction',/,'Class        In Flow',/,
     1    '             Exiting',/,
     1    '-------------------------------------------------------')
 2000 format (1x,i2,4x,f6.3,6x,f4.2,4x,f5.1,4x,f5.1,4x,f5.1,4x,f5.1,5x,
     1    f5.3,4x,f5.3)
 2100 format (1x,i2,10x,f5.3)
 2200 format (/,19x,'*** total soil loss < 1 kg ***')
 2300 format (//,10x,'Annual Average Sediment Yield',//,10x,
     1    '     x       y        sed yld      chan',/,10x,
     1    '   (ft)    (ft)       (t/ac)     (lbs/ft ch)',/,10x,
     1    '   ----    ----       -------     -------')
 2400 format (12x,f5.1,3x,f5.1,6x,f9.2,3x,f9.2)
 2500 format (/,' Average Annual Delivery From Channel Outlet:',/,
     1   ' ------- ------ -------- ---- ------- ------',/,/,
     1   'Total contributing area to outlet                   =   ',
     1   f10.2,
     1   ' ha',/,'Avg. Ann. Precipitation volume in contributing',
     1   ' area = ',f10.0,'   m^3/yr',/,
     1   'Avg. Ann. irrigation volume in contributing area    = ',
     1   f10.0,
     1   '   m^3/yr',/,'Avg. Ann. water discharge from outlet         ',
     1   '      = ',f10.0,'   m^3/yr',/,
     1   'Avg. Ann. total hillslope soil loss                 =',
     1   f12.1,1x,' tonnes/yr',/,
     1   'Avg. Ann. total channel soil loss                   =',
     1   f12.1,1x,' tonnes/yr',/,
     1   'Avg. Ann. sediment discharge from outlet            =',
     1   f12.1,1x,' tonnes/yr',/,
     1    'Avg. Ann. Sed. delivery per unit area of watershed  ',
     1    '= ',f11.1,'  T/ha/yr',/,
     1    'Sediment Delivery Ratio for Watershed               =    ',
     1    f10.3,//)
3000   format('Impoundment',1x,i3,1x,'automatically cleaned',
     1       1x,i3,1x,'times',/,
     1       '--------------------------------------------')
3100  format('No.',1x,i3,1x,'cleaned out',1x,f10.2,1x,'m^3 sediment at',
     1 ' Day',1x,i3,1x,'of Year',1x,i3,1x,'sed-stage=',f8.2,' m')
c        end add
      end


	SUBROUTINE DSDARR ( szdarw, szdarh, idarwd, idartp, size,
     +                      sizehd, jdarwd, jdartp, iret )
C************************************************************************
C* DSDARR								*
C* 									*
C* This subroutine sets the directional arrow size, arrow head size,  	*
C* width multipliers and the arrow type.  If these parameters are not 	*
C* positive no changes are made. 					*
C* 									*
C* DSDARR  ( SZDARW, SZDARH, IDARWD, IDARTP, SIZE, SIZEHD, JDARWD, 	*
C* JDARTP, IRET )							*
C*                                                                    	*
C* Input parameters:							*
C* 	SZDARW		REAL		Arrow size multiplier		*
C* 				   	  <=0 = no change		*
C*      SZDARH		REAL		Arrow head size multiplier	*
C*					  <=0 = no change		*
C*      IDARWD		INTEGER		Arrow width multiplier		*
C*					  <=0 = no change		*
C* 	IDARTP		INTEGER		Arrow type			*
C*					  <=0 = no change		*
C* Output parameters:							*
C*	SIZE		REAL		Actual size			*
C*	SIZEHD		REAL		Actual head size		*
C* 	JDARWD		INTEGER		Arrow width			*
C* 	JDARTP		INTEGER		Arrow type			*
C* 	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* I. Durham/GSC	03/98						*
C************************************************************************
	INCLUDE 	'FUNCCODE.PRM'
	INCLUDE		'ERROR.PRM'
	INCLUDE		'DEVACT.CMN'
C*
	INTEGER 	isend (3), ircv (2)
C------------------------------------------------------------------------
C*	Load input parameters into buffer and write them to the mailbox.
C
	isend (1) = 6
	isend (2) = CSDARR
	CALL GPUT  ( isend,  2, iret )
	IF  ( iret .ne. NORMAL )  RETURN
C
	CALL GPUTR  ( szdarw, 1, iret )
	IF  ( iret .ne. NORMAL )  RETURN
C
	CALL GPUTR  ( szdarh, 1, iret )
	IF  ( iret .ne. NORMAL )  RETURN
C
	isend (1) = idarwd
	isend (2) = idartp
	CALL GPUT  ( isend, 2, iret )
	IF  ( iret .ne. NORMAL ) RETURN
C
C*	Get output parameters.
C
	CALL GGET  ( iret, 1, ier )
	IF  ( ier .ne. NORMAL )  iret = ier
C*
	CALL GGETR  ( size, 1, ier )
	IF  ( ier .ne. NORMAL )  THEN
	    iret = ier
	ELSE
C
C*	    Save the ACTIVE wind arrow size common block variable.
C
	    twdasz = size
	END IF
C*
	CALL GGETR  ( sizehd, 1, ier )
	IF  ( ier .ne. NORMAL )  THEN
	    iret = ier
	  ELSE
C
C*	    Save the ACTIVE wind arrow head size common block variable.
C
	    tdahsz = sizehd
	END IF
C
	CALL GGET  ( ircv, 2, ier )
	IF  ( ier .ne. NORMAL ) THEN
	    iret = ier
	ELSE
C
C*	    Save the ACTIVE wind arrow width and type in commmon block
C*	    and output parameters
C
	    jdarwd = ircv (1)
	    jdartp = ircv (2)
	    mdarwd = jdarwd
	    mdartp = jdartp
	END IF
C*
	RETURN
	END


      subroutine dormant

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine checks the dormant status of the different plant types

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name           |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    alai_min(:)    |m**2/m**2     |minimum LAI during winter dormant period
!!    bio_leaf(:)    |none          |fraction of biomass that drops during
!!                                  |dormancy (for trees only)
!!    bio_ms(:)      |kg/ha         |land cover/crop biomass (dry weight)
!!    bio_yrms(:)    |metric tons/ha|annual biomass (dry weight) in the HRU
!!    dayl(:)        |hours         |day length for current day
!!    daylmn(:)      |hours         |shortest daylength occurring during the
!!                                  |year
!!    dormhr(:)      |hour          |time threshold used to define dormant
!!                                  |period for plant (when daylength is within
!!                                  |the time specified by dormhr from the minimum
!!                                  |daylength for the area, the plant will go
!!                                  |dormant)
!!    icr(:)         |none          |sequence number of crop grown within the
!!                                  |current year
!!    idc(:)         |none          |crop/landcover category:
!!                                  |1 warm season annual legume
!!                                  |2 cold season annual legume
!!                                  |3 perennial legume
!!                                  |4 warm season annual
!!                                  |5 cold season annual
!!                                  |6 perennial
!!                                  |7 trees
!!    idorm(:)       |none          |dormancy status code:
!!                                  |0 land cover growing
!!                                  |1 land cover dormant
!!    idplt(:)       |none          |land cover code from crop.dat
!!    ihru           |none          |HRU number
!!    nro(:)         |none          |sequence number for year in rotation
!!    phuacc(:)      |none          |fraction of plant heat units accumulated
!!    plantn(:)      |kg N/ha       |amount of nitrogen in plant biomass
!!    plantp(:)      |kg P/ha       |amount of phosphorus in plant biomass
!!    pltfr_n(:)     |none          |fraction of plant biomass that is nitrogen
!!    pltfr_p(:)     |none          |fraction of plant biomass that is phosphorus
!!    sol_fon(:,:)   |kg N/ha       |amount of nitrogen stored in the fresh
!!                                  |organic (residue) pool
!!    sol_fop(:,:)   |kg P/ha       |amount of phosphorus stored in the fresh
!!                                  |organic (residue) pool
!!    sol_rsd(:,:)   |kg/ha         |amount of organic matter in the soil
!!                                  |classified as residue
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    laiday(:)   |m**2/m**2     |leaf area index
!!    bio_ms(:)   |kg/ha         |land cover/crop biomass (dry weight)
!!    bio_yrms(:) |metric tons/ha|annual biomass (dry weight) in the HRU
!!    idorm(:)    |none          |dormancy status code:
!!                               |0 land cover growing
!!                               |1 land cover dormant
!!    phuacc(:)   |none          |fraction of plant heat units accumulated
!!    plantn(:)   |kg N/ha       |amount of nitrogen in plant biomass
!!    plantp(:)   |kg P/ha       |amount of phosphorus in plant biomass
!!    sol_fon(:,:)|kg N/ha       |amount of nitrogen stored in the fresh
!!                               |organic (residue) pool
!!    sol_fop(:,:)|kg P/ha       |amount of phosphorus stored in the fresh
!!                               |organic (residue) pool
!!    sol_rsd(:,:)|kg/ha         |amount of organic matter in the soil
!!                               |classified as residue
!!    strsw(:)    |none          |fraction of potential plant growth achieved
!!                               |on the day where the reduction is caused by
!!                               |water stress
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    j           |none          |HRU number
!!    resnew      |
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Max

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      real :: resnew
      integer :: j

      !!by zhang
      !!====================

      real :: BLG1, BLG2, BLG3,  CLG, sf
      real :: sol_min_n,  resnew_n, resnew_ne
      real :: LMF, LSF, LSLF, LSNF,LMNF
      orgc_f = 0.
      BLG1 = 0.
      BLG2 = 0.
      BLG3 = 0.
      CLG = 0.
      sf = 0.
      sol_min_n = 0.
      resnew = 0.
      resnew_n = 0.
      resnew_ne = 0.
      LMF = 0.
      LSF = 0.
      LSLF = 0.
      LSNF = 0.
      LMNF = 0.

      !!by zhang
      !!====================

      j = 0
      j = ihru

!! check for beginning of dormant season
      if (idc(idplt(j)) == 1 .or. idc(idplt(j)) == 4) return
      if (idorm(j) == 0 .and. dayl(j)-dormhr(j) < daylmn(hru_sub(j)))
     &                                                              then

        select case (idc(idplt(j)))

          !! make sure all operations are scheduled during growing season of warm season annual
          case (1,4)
            dorm_flag = 1
            call operatn
            dorm_flag = 0

          !! beginning of forest dormant period
          case (7)
            idorm(j) = 1
            resnew = 0.
            resnew = bio_ms(j) * bio_leaf(idplt(j))

            !!add by zhang
            !!===================
            if (cswat == 2) then
                rsdc_d(j) = rsdc_d(j) + resnew*0.42
            end if
            !!add by zhang
            !!===================

            !!insert new biomss by zhang
            !!=============================
            if (cswat == 2) then
	          !!all the lignin from STD is assigned to LSL,
	            !!add STDL calculation
	          !!
	          !sol_LSL(k,ihru) = sol_STDL(k,ihru)
	          !CLG=BLG(3,JJK)*HUI(JJK)/(HUI(JJK)+EXP(BLG(1,JJK)-BLG(2,JJK)*&HUI(JJK))
	          ! 52  BLG1 = LIGNIN FRACTION IN PLANT AT .5 MATURITY
                ! 53  BLG2 = LIGNIN FRACTION IN PLANT AT MATURITY
                !CROPCOM.dat BLG1 = 0.01 BLG2 = 0.10
                !SUBROUTINE ASCRV(X1,X2,X3,X4)
                !EPIC0810
                !THIS SUBPROGRAM COMPUTES S CURVE PARMS GIVEN 2 (X,Y) POINTS.
                !USE PARM
                !XX=LOG(X3/X1-X3)
                !X2=(XX-LOG(X4/X2-X4))/(X4-X3)
                !X1=XX+X3*X2
                !RETURN
                !END
                !HUI(JJK)=HU(JJK)/XPHU

                BLG1 = 0.01/0.10
                BLG2 = 0.99
                BLG3 = 0.10
                XX = log(0.5/BLG1-0.5)
                BLG2 = (XX -log(1./BLG2-1.))/(1.-0.5)
                BLG1 = XX + 0.5*BLG2
                CLG=BLG3*phuacc(j)/(phuacc(j)+
     &              EXP(BLG1-BLG2*phuacc(j)))

	          !if (k == 1) then
		        sf = 0.05
	          !else
		        !sf = 0.1
	          !end if

               !kg/ha
	          sol_min_n = 0.
	          sol_min_n = (sol_no3(1,j)+sol_nh3(1,j))

	          resnew = bio_ms(j) * bio_leaf(idplt(j))
	          resnew_n = resnew * pltfr_n(j)
        	    resnew_ne = resnew_n + sf * sol_min_n
        	        !Not sure 1000 should be here or not!
        	    !RLN = 1000*(resnew * CLG/(resnew_n+1.E-5))
        	    RLN = (resnew * CLG/(resnew_n+1.E-5))
        	    RLR = MIN(.8, resnew * CLG/1000/(resnew/1000+1.E-5))

        	    LMF = 0.85 - 0.018 * RLN
        	    if (LMF <0.01) then
        	        LMF = 0.01
        	    else
        	        if (LMF >0.7) then
        	            LMF = 0.7
        	        end if
        	    end if
	          !if ((resnew * CLG/(resnew_n+1.E-5)) < 47.22) then
		        !    LMF = 0.85 - 0.018 * (resnew * CLG/(resnew_n+1.E-5))
	          !else
		        !    LMF = 0.
	          !end if

	          LSF =  1 - LMF

	          sol_LM(1,j) = sol_LM(1,j) + LMF * resnew
	          sol_LS(1,j) = sol_LS(1,j) + LSF * resnew

	          !here a simplified assumption of 0.5 LSL
	          LSLF = 0.0
	          LSLF = CLG

	          sol_LSL(1,j) = sol_LSL(1,j) + RLR* LSF * resnew
	          sol_LSC(1,j) = sol_LSC(1,j) + 0.42*LSF * resnew

	          sol_LSLC(1,j) = sol_LSLC(1,j) + RLR*0.42*LSF * resnew
	          sol_LSLNC(1,j) = sol_LSC(1,j) - sol_LSLC(1,j)

                !X3 = MIN(X6,0.42*LSF * resnew/150)

	          if (resnew_ne >= (0.42 * LSF * resnew /150)) then
		         sol_LSN(1,j) = sol_LSN(1,j) + 0.42 * LSF * resnew / 150
		         sol_LMN(1,j) = sol_LMN(1,j) + resnew_ne -
     &                         (0.42 * LSF * resnew / 150) + 1.E-25
	          else
		         sol_LSN(1,j) = sol_LSN(1,j) + resnew_ne
		         sol_LMN(1,j) = sol_LMN(1,j) + 1.E-25
	          end if

	          !LSNF = sol_LSN(1,j)/(sol_LS(1,j)+1.E-5)

	          sol_LMC(1,j) = sol_LMC(1,j) + 0.42 * LMF * resnew
	          !LMNF = sol_LMN(1,j)/(sol_LM(1,j) + 1.E-5)

                !update no3 and nh3 in soil
                sol_no3(1,j) = sol_no3(1,j) * (1-sf)
                sol_nh3(1,j) = sol_nh3(1,j) * (1-sf)
            end if
            !!insert new biomss by zhang
            !!===========================

            sol_rsd(1,j) = sol_rsd(1,j) + resnew
            sol_rsd(1,j) = Max(sol_rsd(1,j),0.)
            sol_fon(1,j) = resnew * pltfr_n(j) + sol_fon(1,j)
            sol_fop(1,j) = resnew * pltfr_p(j) + sol_fop(1,j)
            bio_hv(icr(j),j) = bio_ms(j) + bio_hv(icr(j),j)
            bio_yrms(j) = bio_yrms(j) + bio_ms(j) / 1000.
            bio_ms(j) = bio_ms(j) * (1. - bio_leaf(idplt(j)))
            plantn(j) = plantn(j) - resnew * pltfr_n(j)
            plantp(j) = plantp(j) - resnew * pltfr_p(j)
            strsw(j) = 1.
            laiday(j) = alai_min(idplt(j))
            phuacc(j) = 0.
            laimxfr(j) = 0.        !Sue White - dormancy
            ncrops(icr(j),j) = ncrops(icr(j),j) + 1

          !! beginning of perennial (pasture/alfalfa) dormant period
          case (3, 6)
            idorm(j) = 1
            resnew = 0.
            resnew = bm_dieoff(idplt(j)) * bio_ms(j)

            !!add by zhang
            !!===================
            if (cswat == 2) then
                rsdc_d(j) = rsdc_d(j) + resnew*0.42
            end if
            !!add by zhang
            !!===================

            !!insert new biomss by zhang
            !!=============================
            if (cswat == 2) then
	          !!all the lignin from STD is assigned to LSL,
	            !!add STDL calculation
	          !!
	          !sol_LSL(k,ihru) = sol_STDL(k,ihru)
	          !CLG=BLG(3,JJK)*HUI(JJK)/(HUI(JJK)+EXP(BLG(1,JJK)-BLG(2,JJK)*&HUI(JJK))
	          ! 52  BLG1 = LIGNIN FRACTION IN PLANT AT .5 MATURITY
                ! 53  BLG2 = LIGNIN FRACTION IN PLANT AT MATURITY
                !CROPCOM.dat BLG1 = 0.01 BLG2 = 0.10
                !SUBROUTINE ASCRV(X1,X2,X3,X4)
                !EPIC0810
                !THIS SUBPROGRAM COMPUTES S CURVE PARMS GIVEN 2 (X,Y) POINTS.
                !USE PARM
                !XX=LOG(X3/X1-X3)
                !X2=(XX-LOG(X4/X2-X4))/(X4-X3)
                !X1=XX+X3*X2
                !RETURN
                !END
                !HUI(JJK)=HU(JJK)/XPHU

                BLG1 = 0.01/0.10
                BLG2 = 0.99
                BLG3 = 0.10
                XX = log(0.5/BLG1-0.5)
                BLG2 = (XX -log(1./BLG2-1.))/(1.-0.5)
                BLG1 = XX + 0.5*BLG2
                CLG=BLG3*phuacc(j)/(phuacc(j)+
     &              EXP(BLG1-BLG2*phuacc(j)))

	          !if (k == 1) then
		        sf = 0.05
	          !else
		        !sf = 0.1
	          !end if

               !kg/ha
	          sol_min_n = 0.
	          sol_min_n = (sol_no3(1,j)+sol_nh3(1,j))

	          resnew = bm_dieoff(idplt(j)) * bio_ms(j)
	          resnew_n = bm_dieoff(idplt(j)) * plantn(j)
        	    resnew_ne = resnew_n + sf * sol_min_n
        	        !Not sure 1000 should be here or not!
        	    !RLN = 1000*(resnew * CLG/(resnew_n+1.E-5))
        	    RLN = (resnew * CLG/(resnew_n+1.E-5))
        	    RLR = MIN(.8, resnew * CLG/1000/(resnew/1000+1.E-5))

        	    LMF = 0.85 - 0.018 * RLN
        	    if (LMF <0.01) then
        	        LMF = 0.01
        	    else
        	        if (LMF >0.7) then
        	            LMF = 0.7
        	        end if
        	    end if
	          !if ((resnew * CLG/(resnew_n+1.E-5)) < 47.22) then
		        !    LMF = 0.85 - 0.018 * (resnew * CLG/(resnew_n+1.E-5))
	          !else
		        !    LMF = 0.
	          !end if

	          LSF =  1 - LMF

	          sol_LM(1,j) = sol_LM(1,j) + LMF * resnew
	          sol_LS(1,j) = sol_LS(1,j) + LSF * resnew

	          !here a simplified assumption of 0.5 LSL
	          !LSLF = 0.0
	          !LSLF = CLG

	          sol_LSL(1,j) = sol_LSL(1,j) + RLR*resnew
	          sol_LSC(1,j) = sol_LSC(1,j) + 0.42*LSF * resnew

	          sol_LSLC(1,j) = sol_LSLC(1,j) + RLR*0.42*resnew
	          sol_LSLNC(1,j) = sol_LSC(1,j) - sol_LSLC(1,j)

                !X3 = MIN(X6,0.42*LSF * resnew/150)

	          if (resnew_ne >= (0.42 * LSF * resnew /150)) then
		         sol_LSN(1,j) = sol_LSN(1,j) + 0.42 * LSF * resnew / 150
		         sol_LMN(1,j) = sol_LMN(1,j) + resnew_ne -
     &                         (0.42 * LSF * resnew / 150) + 1.E-25
	          else
		         sol_LSN(1,j) = sol_LSN(1,j) + resnew_ne
		         sol_LMN(1,j) = sol_LMN(1,j) + 1.E-25
	          end if

	          !LSNF = sol_LSN(1,j)/(sol_LS(1,j)+1.E-5)

	          sol_LMC(1,j) = sol_LMC(1,j) + 0.42 * LMF * resnew
	          !LMNF = sol_LMN(1,j)/(sol_LM(1,j) + 1.E-5)

                !update no3 and nh3 in soil
                sol_no3(1,j) = sol_no3(1,j) * (1-sf)
                sol_nh3(1,j) = sol_nh3(1,j) * (1-sf)
            end if
            !!insert new biomss by zhang
            !!===========================

            sol_rsd(1,j) = sol_rsd(1,j) + resnew
            sol_rsd(1,j) = Max(sol_rsd(1,j),0.)
            sol_fon(1,j) = sol_fon(1,j) +
     &         bm_dieoff(idplt(j)) * plantn(j)
            sol_fop(1,j) = sol_fop(1,j) +
     &         bm_dieoff(idplt(j)) * plantp(j)
            bio_hv(icr(j),j) = bio_ms(j) *
     &        bm_dieoff(idplt(j)) +
     &	    bio_hv(icr(j),j)
            bio_yrms(j) = bio_yrms(j) + bio_ms(j) *
     &         bm_dieoff(idplt(j)) / 1000.
            bio_ms(j) = (1. - bm_dieoff(idplt(j))) *
     &         bio_ms(j)
            plantn(j) = (1. - bm_dieoff(idplt(j))) *
     &         plantn(j)
            plantp(j) = (1. - bm_dieoff(idplt(j))) *
     &         plantp(j)
            strsw(j) = 1.
             laiday(j) = alai_min(idplt(j))
             phuacc(j) = 0.
!            ncrops(icr(j),j) = ncrops(icr(j),j) + 1

          !! beginning of cool season annual dormant period
          case (2, 5)
            if (phuacc(j) < 0.75) then
              idorm(j) = 1
              strsw(j) = 1.
            end if
          end select
           if (imgt == 1) then
            write (143,1000) subnum(j), hruno(j), iyr, i_mo, iida,
     *       hru_km(j),
     *       cpnm(idplt(j)),"START-DORM", phubase(j), phuacc(j),
     *       sol_sw(j),bio_ms(j), sol_rsd(1,j), sol_sumno3(j),
     *       sol_sumsolp(j)
           end if

          end if

!! check if end of dormant period
        if (idorm(j) == 1 .and. dayl(j)-dormhr(j) >= daylmn(hru_sub(j)))
     &                                                              then

          select case (idc(idplt(j)))

            !! end of perennial dormant period
            case (3, 6, 7)
              idorm(j) = 0

            !! end of cool season annual dormant period
            case (2, 5)
              idorm(j) = 0
              phuacc(j) = 0.

            end select

            if (imgt == 1) then
                 write (143,1000) subnum(j), hruno(j), iyr, i_mo, iida,
     *       hru_km(j),
     *       cpnm(idplt(j)), "END-DORM", phubase(j), phuacc(j),
     *       sol_sw(j), bio_ms(j), sol_rsd(1,j), sol_sumno3(j),
     *       sol_sumsolp(j)
            end if

        end if

1000  format (a5,1x,a4,3i6,1x,e10.5,1x,2a15,7f10.2)
      return
      end