Subroutine lu2ent(ip, kf1, kf2, pecm)
  Common /lujets/n, k(9000, 5), p(9000, 5), v(9000, 5)
  Save /lujets/
  Common /ludat1/mstu(200), paru(200), mstj(200), parj(200)
  Save /ludat1/
  Common /ludat2/kchg(500, 3), pmas(500, 4), parf(2000), vckm(4, 4)
  Save /ludat2/
  mstu(28) = 0
  If (mstu(12)>=1) Call lulist(0)
  ipa = max(1, iabs(ip))
  If (ipa>mstu(4)-1) Call luerrm(21, '(LU2ENT:) writing outside LUJETS memory')
  kc1 = lucomp(kf1)
  kc2 = lucomp(kf2)
  If (kc1==0 .Or. kc2==0) Call luerrm(12, '(LU2ENT:) unknown flavour code')
  pm1 = 0.
  If (mstu(10)==1) pm1 = p(ipa, 5)
  If (mstu(10)>=2) pm1 = ulmass(kf1)
  pm2 = 0.
  If (mstu(10)==1) pm2 = p(ipa+1, 5)
  If (mstu(10)>=2) pm2 = ulmass(kf2)
  Do i = ipa, ipa + 1
    Do j = 1, 5
      k(i, j) = 0
      p(i, j) = 0.
      v(i, j) = 0.
    End Do
  End Do
  kq1 = kchg(kc1, 2)*isign(1, kf1)
  kq2 = kchg(kc2, 2)*isign(1, kf2)
  If (kq1+kq2/=0 .And. kq1+kq2/=4) Call luerrm(2, '(LU2ENT:) unphysical flavour combination')
  k(ipa, 2) = kf1
  k(ipa+1, 2) = kf2
  If (ip>=0) Then
    k(ipa, 1) = 1
    If (kq1/=0 .And. kq2/=0) k(ipa, 1) = 2
    k(ipa+1, 1) = 1
  Else
    If (kq1==0 .Or. kq2==0) Call luerrm(2, '(LU2ENT:) requested flavours can not develop parton shower')
    k(ipa, 1) = 3
    k(ipa+1, 1) = 3
    k(ipa, 4) = mstu(5)*(ipa+1)
    k(ipa, 5) = k(ipa, 4)
    k(ipa+1, 4) = mstu(5)*ipa
    k(ipa+1, 5) = k(ipa+1, 4)
  End If
  If (pecm<=pm1+pm2) Call luerrm(13, '(LU2ENT:) energy smaller than sum of masses')
  pa = sqrt(max(0.,(pecm**2-pm1**2-pm2**2)**2-(2.*pm1*pm2)**2))/(2.*pecm)
  p(ipa, 3) = pa
  p(ipa, 4) = sqrt(pm1**2+pa**2)
  p(ipa, 5) = pm1
  p(ipa+1, 3) = -pa
  p(ipa+1, 4) = sqrt(pm2**2+pa**2)
  p(ipa+1, 5) = pm2
  n = ipa + 1
  If (ip==0) Call luexec
  Return
End Subroutine lu2ent


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

      SUBROUTINE RADMAC     ( PMSA   , FL     , IPOINT , INCREM, NOSEG ,
     +                        NOFLUX , IEXPNT , IKNMRK , NOQ1  , NOQ2  ,
     +                        NOQ3   , NOQ4   )
!
!*******************************************************************************
!
      IMPLICIT NONE
!
!     Type    Name         I/O Description
!
      REAL(4) PMSA(*)     !I/O Process Manager System Array, window of routine to process library
      REAL(4) FL(*)       ! O  Array of fluxes made by this process in mass/volume/time
      INTEGER IPOINT( 9 ) ! I  Array of pointers in PMSA to get and store the data
      INTEGER INCREM( 9 ) ! I  Increments in IPOINT for segment loop, 0=constant, 1=spatially varying
      INTEGER NOSEG       ! I  Number of computational elements in the whole model schematisation
      INTEGER NOFLUX      ! I  Number of fluxes, increment in the FL array
      INTEGER IEXPNT      ! I  From, To, From-1 and To+1 segment numbers of the exchange surfaces
      INTEGER IKNMRK(*)   ! I  Active-Inactive, Surface-water-bottom, see manual for use
      INTEGER NOQ1        ! I  Nr of exchanges in 1st direction, only horizontal dir if irregular mesh
      INTEGER NOQ2        ! I  Nr of exchanges in 2nd direction, NOQ1+NOQ2 gives hor. dir. reg. grid
      INTEGER NOQ3        ! I  Nr of exchanges in 3rd direction, vertical direction, pos. downward
      INTEGER NOQ4        ! I  Nr of exchanges in the bottom (bottom layers, specialist use only)
      INTEGER IPNT( 9 )   !    Local work array for the pointering
      INTEGER ISEG        !    Local loop counter for computational element loop
!
!*******************************************************************************
!
!     Type    Name         I/O Description                                        Unit
!
      REAL(4) ACTRAD, SATRAD, FRAD, RADTOP, HACT, TOTDEP, LOCDEP, DEPTH,
     J        EXT, ZM, Z1, DZ
      INTEGER IKMRK1, IKMRK2, ITOPSEG

      INTEGER       :: LUNREP
      INTEGER, SAVE :: NR_MSG = 0

!*******************************************************************************
!
      IPNT = IPOINT
!
      DO 9000 ISEG = 1 , NOSEG

      CALL DHKMRK(1,IKNMRK(ISEG),IKMRK1)
      IF (IKMRK1.EQ.1) THEN
      CALL DHKMRK(2,IKNMRK(ISEG),IKMRK2)
      IF ((IKMRK2.EQ.0).OR.(IKMRK2.EQ.3)) THEN

!         Access conditions from the cell where the top of the plant is
          ITOPSEG = NINT(PMSA(IPNT(1)))
          IF (ITOPSEG .LE. 0 ) THEN
             CALL GETMLU( LUNREP )
             WRITE(LUNREP,*) 'RADMAC: top segment missing - needed for light intensity at tip of plant'
             WRITE(LUNREP,*) '   ISEG    =',ISEG
             WRITE(LUNREP,*) '   ITOPSEG =',ITOPSEG
             STOP 'Problem in RADMAC'
          ENDIF

!         Calculate light intensity at the tip of the plant
          RADTOP = PMSA(IPOINT(2)+(ITOPSEG-1)*INCREM(2))
          HACT   = PMSA(IPNT(3))
          TOTDEP = PMSA(IPNT(4))
          LOCDEP = PMSA(IPOINT(5)+(ITOPSEG-1)*INCREM(5))
          DEPTH  = PMSA(IPOINT(6)+(ITOPSEG-1)*INCREM(6))
          EXT    = PMSA(IPOINT(7)+(ITOPSEG-1)*INCREM(7))
          ZM     = TOTDEP - HACT
          Z1     = LOCDEP - DEPTH
          DZ     = ZM-Z1

          IF (DZ.LT.0.0 .OR. DZ.GT.DEPTH) THEN
             NR_MSG = NR_MSG + 1
             IF ( NR_MSG <= 25 ) THEN
                CALL GETMLU( LUNREP )
                WRITE(LUNREP,*) 'RADMAC: depth out of range'
                WRITE(LUNREP,*) '   ISEG  =',ISEG
                WRITE(LUNREP,*) '   ITOPS =',ITOPSEG
                WRITE(LUNREP,*) '   HACT  =',HACT
                WRITE(LUNREP,*) '   TOTDEP=',TOTDEP
                WRITE(LUNREP,*) '   LOCDEP=',LOCDEP
                WRITE(LUNREP,*) '   DEPTH =',DEPTH
                WRITE(LUNREP,*) '   ZM=',ZM
                WRITE(LUNREP,*) '   Z1=',Z1
                WRITE(LUNREP,*) '   DZ=',DZ
                IF ( NR_MSG == 25 ) THEN
                   WRITE(LUNREP,*) 'RADMAC: 25 messages written'
                   WRITE(LUNREP,*) 'RADMAC: further messages will be suppressed'
                ENDIF
             ENDIF
          ENDIF
          ACTRAD = RADTOP*EXP(-EXT*DZ)

!         Calculate and store light efficiency
          SATRAD = PMSA(IPNT(8))

          FRAD = MIN(1.0,ACTRAD/SATRAD)
          PMSA(IPNT(9))  = FRAD
!
      ENDIF
      ENDIF
!
      IPNT = IPNT + INCREM
!
 9000 CONTINUE
!
      RETURN
!
      END


MODULE step_oce
  USE oce
  USE dom_oce
  USE zdf_oce
  USE zdfdrg, ONLY: ln_drgimp
  USE daymod
  USE sbc_oce
  USE sbcmod
  USE sbcrnf
  USE sbccpl
  USE sbcapr
  USE sbctide
  USE sbcwave
  USE traqsr
  USE trasbc
  USE trabbc
  USE trabbl
  USE tradmp
  USE traadv
  USE traldf
  USE trazdf
  USE tranxt
  USE tranpc
  USE eosbn2
  USE divhor
  USE dynadv
  USE dynvor
  USE dynhpg
  USE dynldf
  USE dynzdf
  USE dynspg
  USE dynnxt
  USE stopar
  USE stopts
  USE bdy_oce, ONLY: ln_bdy
  USE bdydta
  USE bdytra
  USE bdydyn3d
  USE sshwzv
  USE domvvl
  USE ldfslp
  USE ldfdyn
  USE ldftra
  USE zdfphy
  USE zdfosm, ONLY: osm_rst, dyn_osm, tra_osm
  USE step_diu
  USE diurnal_bulk
  USE cool_skin
  USE sbc_oce
  USE zpshde
  USE diawri
  USE diaptr
  USE diadct
  USE diaar5
  USE diahth
  USE diahsb
  USE diaharm
  USE diacfl
  USE diaobs
  USE flo_oce
  USE floats
  USE crsfld
  USE asminc
  USE asmbkg
  USE stpctl
  USE restart
  USE prtctl
  USE in_out_manager
  USE iom
  USE lbclnk
  USE timing
END MODULE step_oce


       subroutine fitint
c
c      initialize the common blocks in feffit at runtime.
c      see also fitbdt, which does this as block data
c
c      copyright 1993 university of washington         matt newville
c----------------------------------------------------------------------
       include 'fitcom.h'
c  temporary parameters for legths of multiple-dimensioned arrays
       integer lwfft, i, j, k
       parameter (lwfft  = (4*maxpts+15)   )
c
c  single values
       frminp = ' '
       frmout = ' '
       asccmt = '# '
       if (vaxflg) asccmt = '##'
       inpfil = 'feffit.inp'
       mdocxx =  0
       xnidp  =  zero
       inform =  0
       ndata  =  0
       rlast  =  10.d0
       cormin =  0.25d0
       rwght1 =  15.d0
       rwght2 =  25.d0
       tranq  =  2.d0
       allout = .true.
       final  = .false.
       rm2flg = .false.
       dphflg = .false.
       kspcmp = .false.
       kspout = .true.
       rspout = .true.
       bkgout = .true.
       qspout = .true.
       pcout  = .false.
       chkdat = .true.
       prmout = .true.
       noout  = .false.
       nofit  = .false.
       degflg = .true.
       iprint = 0
       chisqr = zero
       usrtol = one
       numvar = 0
       nvuser = 0
       ifxvar = 0
       ierbar = 0
       nerstp = 1
       ixpath = 0
       nmathx = 0
       nconst = 0
c
c loop over mdata
       do 300 i = 1, mdata
          skey(i)   = ' '
          outfil(i) = '_fit'
          chifil(i) = ' '
          bkgfil(i) = ' '
          skeyb(i)  = ' '
          do 30 j = 1, maxdoc
             doc(j,i) = ' '
 30       continue
          do 40 j = 1, mtitle
             titles(j,i) = ' '
 40       continue
          qweigh(i) = zero
          rweigh(i) = zero
          qwin1(i)  = zero
          qwin2(i)  = zero
          rwin1(i)  = zero
          rwin2(i)  = zero
          qmin(i)   = zero
          qmax(i)   = zero
          rmin(i)   = zero
          rmax(i)   = zero
          nqfit(i)  = 0
          nqpts(i)  = 0
          nrpts(i)  = 0
          sqwin(i)  = 'hanning'
          srwin(i)  = 'hanning'
          ifft(i)   = 1
          jffphs(i) = 0
          q1st(i)   = zero
          qlast(i)  = zero
          sigdtr(i) = zero
          sigdtk(i) = zero
          sigdtq(i) = zero
          sigwgt(i) = zero
          weight(i) = zero
          rfactr(i) = zero
          xinfo(i)  = zero
          ndoc(i)   = 0
          nkey(i)   = 0
          nkeyb(i)  = 0
          nchi(i)   = 0
          bkgfit(i) = .false.
          bkgdat(i) = .false.
          nbkg(i)   = 0
          datain(i) = .false.
          rbkg(i)   = zero
          do 70 j = 1, mtknot
             qknot(j,i) = zero
 70       continue
          chi2dt(i) = zero
          do 100 j = 1, maxpts
             chifit(j,i) = zero
             qwindo(j,i) = zero
             rwindo(j,i) = zero
             bkgq(j,i) = zero
             chiq(j,i) = zero
             thiq(j,i) = zero
 100      continue
          do 200 j = 0, mdpths
             jdtpth(j,i) = 0
             jdtusr(j,i) = 0
 200      continue
          do 240 j = 1, mlocal
             icdloc(1,j,i) = 0
 240      continue
 300   continue

c
c  loop over mvarys
       do 350 i = 1, mvarys
          xguess(i) = zero
          xfinal(i) = zero
          delta(i) = zero
          do 320 j = 1, mvarys
             correl(j,i) = zero
 320      continue
 350   continue

c
       do 500 i = 1, mfffil
          feffil(i) = ' '
          do 410 j =  1, mffttl
             fefttl(j,i) = '  '
 410      continue
          degpth(i) = one
          refpth(i) = zero
          rwgpth(i) = zero
          nlgpth(i) = 0
          iffrec(i) = 0
          do 420 j = 1, mffpts
             qfeff(j,i)  = zero
             theamp(j,i) = zero
             thepha(j,i) = zero
             realp(j,i)  = zero
             xlamb(j,i)  = zero
 420      continue
          do 460 j = 0, maxleg
             izpth(j,i)  = 0
             iptpth(j,i) = 0
             do 440 k = 1, 3
                ratpth(k,j,i) = zero
 440         continue
 460      continue
 500   continue

       do 700 i = 1, maxval
          values(i) = zero
          vnames(i) = ' '
          icdval(1,i) = 0
 700   continue
       do 750 i = 1, mpaths
          pthlab(i) = ' '
          jpthff(i) = 0
          do 720 j = 1, mpthpr
             icdpar(1,j,i) = 0
 720      continue
 750   continue
c
       do 780 i = 1, mpthpr
          defalt(i) = zero
 780   continue
       defalt(jps02) = one
       parnam(jps02) = 's02'
       parnam(jpe0)  = 'e0'
       parnam(jpei)  = 'ei'
       parnam(jpdpha)= 'dphase'
       parnam(jpdelr)= 'delr'
       parnam(jpsig2)= 'sigma2'
       parnam(jp3rd) = 'third'
       parnam(jp4th) = 'fourth'
       do 800 i = 1, mconst
          consts(i) = zero
 800   continue

       do 900 i = 1,   lwfft
          wfftc(i) = zero
 900   continue
c
c end subroutine fitint
       end


program example
  implicit none
  != unit (s) :: x
  != unit (m) :: y
  integer :: x, y
  integer :: z
  z = x + y
end program example


module bc_module

  implicit none

  ! these are initialized when you call initialize_bc()
  ! the ordering is velocity, pressure, scalars, transport
  integer, save :: vel_bc_comp, pres_bc_comp, scal_bc_comp, tran_bc_comp

  ! these are set from mandatory arguments to initialize_bc()
  integer, save :: num_scal_bc, num_tran_bc

  ! each application uses a subset of these
  integer, save :: temp_bc_comp, Epot_bc_comp, c_bc_comp, mol_frac_bc_comp, h_bc_comp

  ! These are physical boundary condition types
  ! We set these in the inputs file and they get translated
  ! by define_bc_tower.f90 into the definitions below
  integer, parameter, public ::            INLET  = 11 ! not currently used but needed by BoxLib
  integer, parameter, public ::            OUTLET = 12 ! not currently used but needed by BoxLib
  integer, parameter, public ::          SYMMETRY = 13 ! not currently used but needed by BoxLib

  ! Special BC codes for application codes start at 100 for no-slip walls and 200 for slip walls
  integer, parameter, public :: NO_SLIP_START       = 100
  integer, parameter, public :: NO_SLIP_WALL        = 100
  integer, parameter, public :: NO_SLIP_RESERVOIR   = 101 ! Mass and heat reservoir
  integer, parameter, public :: NO_SLIP_CLOSED      = 102 ! Closed (isolated) system
  integer, parameter, public :: NO_SLIP_IMPERMEABLE = 103 ! Only heat reservoir, no mass flux
  integer, parameter, public :: NO_SLIP_END         = 103

  integer, parameter, public :: SLIP_START       = 200
  integer, parameter, public :: SLIP_WALL        = 200
  integer, parameter, public :: SLIP_RESERVOIR   = 201 ! Mass and heat reservoir
  integer, parameter, public :: SLIP_CLOSED      = 202 ! Closed (isolated) system
  integer, parameter, public :: SLIP_IMPERMEABLE = 203 ! Only heat reservoir, no mass flux
  integer, parameter, public :: SLIP_END         = 203

  ! These specify boundary conditions on phi for the cc mg solver
  integer, parameter, public :: BC_PER       = -1
  integer, parameter, public :: BC_INT       = 0
  integer, parameter, public :: BC_DIR       = 1 ! not currently used but needed by BoxLib
  integer, parameter, public :: BC_NEU       = 2

  ! These specify boundary conditions for the velocity, pressure, and scalars
  integer, parameter, public :: PERIODIC     = -1
  integer, parameter, public :: INTERIOR     =  0
  integer, parameter, public :: EXT_DIR      =  23
  integer, parameter, public :: FOEXTRAP     =  24
  integer, parameter, public :: HOEXTRAP     =  25
  integer, parameter, public :: DIR_VEL      =  26
  integer, parameter, public :: DIR_TRACT    =  27

end module bc_module


C$Procedure      SCT2E ( SCLK ticks to ET )

      SUBROUTINE SCT2E ( SC, SCLKDP, ET )

C$ Abstract
C
C     Convert encoded spacecraft clock (`ticks') to ephemeris
C     seconds past J2000 (ET).
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     SCLK
C     TIME
C
C$ Keywords
C
C     CONVERSION
C     TIME
C
C$ Declarations

      INTEGER               SC
      DOUBLE PRECISION      SCLKDP
      DOUBLE PRECISION      ET

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     SC         I   NAIF spacecraft ID code.
C     SCLKDP     I   SCLK, encoded as ticks since spacecraft clock
C                    start.
C     ET         O   Ephemeris time, seconds past J2000.
C
C$ Detailed_Input
C
C     SC             is a NAIF integer code for a spacecraft, one of
C                    whose encoded clock values is represented by
C                    SCLKDP.
C
C     SCLKDP         is an encoded spacecraft clock value.  SCLKDP
C                    represents time measured from spacecraft clock
C                    start:  partition information IS reflected in the
C                    encoded value.
C
C$ Detailed_Output
C
C     ET             is the epoch, specified as ephemeris seconds past
C                    J2000, that corresponds to SCLKDP.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  This routine assumes that that an SCLK kernel appropriate
C         to the spacecraft clock identified by the input argument SC
C         has been loaded.  If an SCLK kernel has not been loaded,
C         does not contain all of the required data, or contains
C         invalid data, error diagnoses will be performed by routines
C         called by this routine.  The output argument ET will not be
C         modified.
C
C     2)  When using SCLK kernels that map SCLK to a time system other
C         than ET (also called barycentric dynamical time---`TDB'), it
C         is necessary to have a leapseconds kernel loaded at the time
C         this routine is called.  If a leapseconds kernel is required
C         for conversion between SCLK and ET but is not loaded, the
C         error will be diagnosed by routines called by this routine.
C         The output argument ET will not be modified.
C
C         The time system that an SCLK kernel maps SCLK to is indicated
C         by the variable SCLK_TIME_SYSTEM_nn in the kernel, where nn
C         is the negative of the NAIF integer code for the spacecraft.
C         The time system used in a kernel is TDB if and only if the
C         variable is assigned the value 1.
C
C
C     3)  If the clock type for the spacecraft clock identified by
C         SC is not supported by this routine, the error
C         SPICE(NOTSUPPORTED) is signalled.  The output argument ET
C         will not be modified.
C
C     4)  If the input argument SCLKDP is invalid, the error will be
C         diagnosed by routines called by this routine.  The output
C         argument ET will not be modified.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine operates on encoded SCLK values.  These values
C     are obtained by calling the SPICELIB routine SCENCD or other
C     SCLK conversion routines.  The advantage of encoded SCLK, as
C     opposed to character string representations of SCLK is that
C     encoded SCLK values are easy to perform arithmetic operations on.
C     Additionally, working with encoded SCLK reduces the overhead of
C     repeated conversion of character strings to integers or double
C     precision numbers.
C
C     To convert a string representation of an SCLK value to ET, use
C     the SPICELIB routine SCS2E.
C
C     See the SCLK Required Reading for a list of the entire set of
C     SCLK conversion routines.
C
C$ Examples
C
C     1)  Encode a Galileo SCLK string, and convert the encoded value
C         to ET; use these time values to look up both GLL orbiter
C         scan platform's pointing and the GLL--Earth state vector
C         for an epoch specified by an SCLK string.
C
C            During program initialization, load the leapseconds and
C            SCLK kernels.  We will pretend that these files are named
C            "LEAPSECONDS.KER" and "GLLSCLK.KER".  To use this code
C            fragment, you must substitute the actual names of these
C            kernel files for the names used here.
C
C               C
C               C     Load leapseconds and SCLK kernels:
C               C
C                     CALL FURNSH ( 'LEAPSECONDS.KER' )
C                     CALL FURNSH ( 'SCLK.KER'        )
C
C            The mission is Galileo, which has spacecraft ID -77.
C            Let's assume that the SCLK string is
C
C                     1 / 1900000:00:00
C
C            The number 1, followed by a slash, indicates that the
C            epoch is in the first partition.
C
C            The next step is to encode this SCLK string, and also
C            find the corresponding ET value:
C
C                     CALL SCENCD ( -77, '1/ 1900000:00:00', SCLKDP )
C                     CALL SCT2E  ( -77,  SCLKDP,            ET     )
C
C            We'll assume that you've already loaded SPK and CK files
C            containing ephemeris data for the GLL orbiter and the
C            Earth, as well as scan platform pointing.  Now you're
C            ready to call both CKGP, which expects the input epoch to
C            be specified by an encoded SCLK string, and SPKEZ, which
C            expects the epoch to be specified as an ephemeris time.
C
C               C
C               C     Find scan platform pointing CMAT and s/c--target
C               C     vector (first 3 components of STATE) at epoch.
C               C     We assume that CK and SPK kernels have been loaded
C               C     already, via CKLPF and SPKLEF respectively.
C               C
C                     SCANPL = -77001
C                     EARTH  =    399
C
C                     CALL CKGP  ( SCANPL,
C                    .             SCLKDP,
C                    .             TOL,
C                    .             REFSYS,
C                    .             CMAT,
C                    .             CLKOUT,
C                    .             FOUND   )
C
C                     IF ( .NOT. FOUND ) THEN
C
C                        [ Indicate to user that pointing was not
C                          available ]
C
C                     END IF
C
C
C                     CALL SPKEZ ( EARTH,
C                    .             ET,
C                    .             REFSYS,
C                    .             CORR,
C                    .             -77,
C                    .             STATE,
C                    .             LT      )
C
C
C
C     2)  Convert an encoded Voyager 2 SCLK value to UTC, using calendar
C         format, with 3 digits of precision.
C
C            Again, your initialization code must load the leapseconds
C            and SCLK kernels:
C
C               C
C               C     Load leapseconds and SCLK kernels:
C               C
C                     CALL FURNSH ( 'LEAPSECONDS.KER' )
C                     CALL FURNSH ( 'VGR2SCLK.KER'    )
C
C
C            To find the UTC value corresponding to the encoded
C            Voyager 2 SCLK value SCLKDP, you can use the code fragment
C
C                     CALL SCT2E  ( -32,  SCLKDP,     ET  )
C                     CALL ET2UTC (  ET,  'C',    3,  UTC )
C
C$ Restrictions
C
C     1)  An SCLK kernel appropriate to the spacecraft clock identified
C         by SC must be loaded at the time this routine is called.
C
C     2)  If the SCLK kernel used with this routine does not map SCLK
C         directly to barycentric dynamical time, a leapseconds kernel
C         must be loaded at the time this routine is called.
C
C$ Literature_References
C
C     [1]  CK Required Reading
C
C     [2]  SPK Required Reading
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.4, 22-AUG-2006 (EDW)
C
C        Replaced references to LDPOOL with references
C        to FURNSH.
C
C-    SPICELIB Version 1.0.3, 09-MAR-1999 (NJB)
C
C        Explicit list of SCLK conversion routines in Particulars
C        section has been replaced by a pointer to the SCLK Required
C        Reading.
C
C-    SPICELIB Version 1.0.2, 10-APR-1992 (NJB) (WLT)
C
C        The $Brief_I/O section now lists ET correctly as an output
C        from this routine.  Header was updated to reflect possibility
C        of needing to load a leapseconds kernel before calling this
C        routine.  Comment section for permuted index source lines was
C        added following the header.
C
C-    SPICELIB Version 1.0.1, 12-OCT-1990 (NJB)
C
C        Restrictions section no longer states that you must load the
C        leapseconds kernel prior to calling this routine.
C
C        The examples have been slightly re-written.
C
C-    SPICELIB Version 1.0.0, 03-SEP-1990 (NJB)
C
C-&

C$ Index_Entries
C
C     spacecraft_clock ticks to ephemeris time
C
C-&

C$ Revisions
C
C-    SPICELIB Version 1.0.1, 12-OCT-1990 (NJB)
C
C        Restrictions section no longer states that you must load the
C        leapseconds kernel prior to calling this routine.
C
C        The examples have been slightly re-written.  In particular,
C        they no longer use calls to CLPOOL.
C
C-&

C
C     SPICELIB functions
C
      INTEGER               SCTYPE

      LOGICAL               RETURN

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'SCT2E' )
      END IF

C
C     Just hand off the conversion to the appropriate routine.
C
      IF (  SCTYPE ( SC )  .EQ.  1  ) THEN

         CALL SCTE01 ( SC, SCLKDP, ET )

      ELSE

         CALL SETMSG ( 'Clock type # is not supported.' )
         CALL ERRINT ( '#', SCTYPE ( SC )               )
         CALL SIGERR ( 'SPICE(NOTSUPPORTED)'            )
         CALL CHKOUT ( 'SCT2E'                          )
         RETURN

      END IF

      CALL CHKOUT ( 'SCT2E' )
      RETURN
      END


! ******************************************************************************************************************************** !
! ecogem_box.f90
!
! MISCELLANEOUS ROUTINES
! ******************************************************************************************************************************** !

MODULE ecogem_box

  USE ecogem_lib
  IMPLICIT NONE
  SAVE

CONTAINS

  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  SUBROUTINE quota_status( &
       & biomass,            &
       & quota               &
       & )

    IMPLICIT NONE
    ! ---------------------------------------------------------- !
    ! DUMMY ARGUMENTS
    ! ---------------------------------------------------------- !
    real,dimension(iomax,npmax),intent(in)  :: biomass
    real,dimension(iomax,npmax),intent(out) :: quota
    ! ---------------------------------------------------------- !
    ! DEFINE LOCAL VARIABLES
    ! ---------------------------------------------------------- !
    integer :: io
    !
    ! *****************************************************************
    ! ******************** Evaluate Quota Status **********************
    ! *****************************************************************

    ! Calculate quotas
    do io = 2,iomax ! skip carbon index; quota = X:C biomass ratio
       ! quota = nutrient biomass to carbon biomass ratio
       quota(io,:) = biomass(io,:) / biomass(iCarb,:)
       ! check for C biomass < 0
       quota(io,:) = merge(qmin(io,:),quota(io,:),biomass(iCarb,:).le.0.0)   ! Qmin if C biomass <=0
       ! check for outside quota min or max
       quota(io,:) = merge(qmax(io,:),quota(io,:),quota(io,:).gt.qmax(io,:)) ! Qmax if Q>Qmax
       quota(io,:) = merge(qmin(io,:),quota(io,:),quota(io,:).lt.qmin(io,:)) ! Qmin if Q<Qmin

    enddo

  END SUBROUTINE quota_status
  !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  SUBROUTINE quota_limitation( &
       & quota,              &
       & limit,              &
       & VLlimit,            &
       & qreg,               &
       & qreg_h              &
       & )

    IMPLICIT NONE
    ! ---------------------------------------------------------- !
    ! DUMMY ARGUMENTS
    ! ---------------------------------------------------------- !
    real,dimension(iomax,npmax),intent(in)  :: quota
    real,dimension(iomax,npmax),intent(out) :: limit
    real,dimension(npmax)      ,intent(out) :: VLlimit
    real,dimension(iomax,npmax),intent(out) :: qreg
    real,dimension(iomax,npmax),intent(out) :: qreg_h
    ! ---------------------------------------------------------- !
    ! DEFINE LOCAL VARIABLES
    ! ---------------------------------------------------------- !
    integer :: io
    !
    ! *****************************************************************
    ! ******************** Evaluate Limitation ***********************
    ! *****************************************************************
    ! VLlimit --> Von Leibig limitation by most limiting nutrient
    !             1 = replete, 0 = no C assimilation
    !             N,Si   - linear from quota
    !             P & Fe - Droop from quota
    !
    ! qreg   --> individual nutrient status for uptake regualtion
    !            0 = quota full, 1 = quota empty
    !            linear for all elements (not needed for Si)
    !            qreg(C,:) = inverse of qreg for most limiting element
    ! qreg_h --> hill number transformed version (qreg_h=qreg^hill)
    !
    ! Initialise
    limit(:,:)       = 0.0 ! (iomax,npmax)
    VLlimit(:)       = 0.0 ! (npmax)
    qreg(:,:)        = 0.0 ! (iomax,npmax)
    qreg_h(:,:)      = 0.0 ! (iomax,npmax)

    ! Calculate quota limitation terms
    ! N and Si take linear form
    if (nquota) limit(iNitr,:) = (quota(iNitr,:) - qmin(iNitr,:)) / ( qmax(iNitr,:) - qmin(iNitr,:))
    if (squota) limit(iSili,:) = (quota(iSili,:) - qmin(iSili,:)) / ( qmax(iSili,:) - qmin(iSili,:))
    ! P and Fe take normalised Droop form
    if (pquota) limit(iPhos,:) = (1.0 - qmin(iPhos,:)/quota(iPhos,:)) / (1.0 - qmin(iPhos,:)/qmax(iPhos,:) )
    if (fquota) limit(iIron,:) = (1.0 - qmin(iIron,:)/quota(iIron,:)) / (1.0 - qmin(iIron,:)/qmax(iIron,:) )

    ! Set Von Leibig limitation according to most limiting nutrient (excluding iCarb=1)
    VLlimit(:) = minval(limit(2:iomax,:),1)

    do io = 2,iomax ! skip carbon index; quota = X:C biomass ratio
       ! Calculate linear regulation term
       qreg(io,:) = (qmax(io,:) - quota(io,:)) / (qmax(io,:) - qmin(io,:) )
       ! Transform regulation term using hill number
       qreg_h(io,:) = qreg(io,:) ** hill
    enddo

  END SUBROUTINE quota_limitation

  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  SUBROUTINE nutrient_uptake(         &
       &                        qreg,    &
       &                        nuts,    &
       &                        gamma_T, &
       &                        up_inorg )

    IMPLICIT NONE
    ! ---------------------------------------------------------- !
    ! DUMMY ARGUMENTS
    ! ---------------------------------------------------------- !
    real,dimension(iomax,npmax),intent(in)    :: qreg
    real,dimension(iimax)      ,intent(in)    :: nuts
    real,                       intent(in)    :: gamma_T
    real,dimension(iimax,npmax),intent(inout) :: up_inorg
    ! ---------------------------------------------------------- !
    ! DEFINE LOCAL VARIABLES
    ! ---------------------------------------------------------- !
    integer :: ii,io
    !
    ! *****************************************************************
    ! ******************** Resource Acquisition ***********************
    ! *****************************************************************

    ! initialise
    up_inorg(2:iimax,:) = 0.0
    ! C-specific nutrient uptake
    do ii=2,iimax ! not carbon...
       ! resource and temperature limited uptake
       if (nuts(ii).gt.0.0) then
          up_inorg(ii,:) = gamma_T * vmax(ii,:) * affinity(ii,:) * nuts(ii) &
               & / (vmax(ii,:) + affinity(ii,:) * nuts(ii))
          ! Equivalent to classic Michaelis-Menten form ...
          !     up_inorg(ii,:) = gamma_T * vmax(ii,:) * nuts(ii) / (nuts(ii) +kn(ii,:))
          if (fundamental) up_inorg(ii,:) = gamma_T * vmax(ii,:)
       else
          up_inorg(ii,:) = 0.0
       endif
    enddo

    ! quota satiation
    do ii=2,iimax
       io=nut2quota(ii)
       up_inorg(ii ,:) = up_inorg(ii ,:) * qreg(io,:)
    enddo

    ! ammonium inhibition to NO3 and NO2
    if (useNH4) then
       if (useNO3) up_inorg(iNO3,:) = up_inorg(iNO3,:) * exp(-amminhib*nuts(iNH4))
       if (useNO2) up_inorg(iNO2,:) = up_inorg(iNO2,:) * exp(-amminhib*nuts(iNH4))
    endif
    ! check > 0.0
    up_inorg(:,:) = MERGE(up_inorg(:,:),0.0,up_inorg(:,:).gt.0.0)

  END SUBROUTINE nutrient_uptake

  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! Temperature dependence functions set by control namelist parameter ctrl_tdep_form
  SUBROUTINE t_limitation( &
       & Tlocal,             &
       & gamma               &
       & )

    IMPLICIT NONE
    ! ---------------------------------------------------------- !
    ! DUMMY ARGUMENTS
    ! ---------------------------------------------------------- !
    real,intent(in)  :: Tlocal
    real,intent(out) :: gamma

    if     (ctrl_tdep_form.eq.'Default')   then ! Ward, Dutkiewicz, Jahn & Follows - L&O (2012) 57(6), 1877-1891
       gamma=exp(temp_A*(Tlocal-273.15-temp_T0))
    elseif (ctrl_tdep_form.eq.'Eppley')    then ! Eppley - Fish. Bull. (1972) 70, 1063-1085
       gamma=0.59*exp(0.0633*(Tlocal-273.15))
    elseif (ctrl_tdep_form.eq.'MEDUSA')    then ! Eppley - Fish. Bull. (1972) 70, 1063-1085
       gamma=1.066**(Tlocal-273.15)
    elseif (ctrl_tdep_form.eq.'Bissinger') then ! Bissinger, Montagnes, Sharples and Atkinson - L&O (2008) 53(2), 487-493
       gamma=0.81*exp(0.0631*(Tlocal-273.15))
    else
       print*,"!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
       print*,"ERROR: ctrl_tdep_form = '"//trim(ctrl_tdep_form)//"' is not a valid temperature dependence function."
       print*,"Stopped in SUBROUTINE t_limitation (ecogem_box)."
       print*,"!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
       STOP
    endif

    if (gamma.le.0.0) then
       print*,"!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
       print*,"ERROR: T-dependence function yields gamma_T<=0."
       print*,"Stopped in SUBROUTINE t_limitation (ecogem_box)."
       print*,"!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
       STOP
    endif

  END SUBROUTINE t_limitation

  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! GEIDER98 - Geider, MacIntyre and Kana (1998) photosynthesis model
  ! Calculates photosynthesis and chlorophyll synthesis.
  ! adapted for multiple nutrients following Moore et al (2002)
  SUBROUTINE photosynthesis(           &
       &                         PARlocal,  &
       &                         biomass,   &
       &                         limit,     &
       &                         VLlimit,   &
       &                         up_inorg,  &
       &                         gamma_T,   &
       &                         PP,        &
       &                         chlsynth,  &
       &                         totPP      &
       &                         )

    IMPLICIT NONE
    ! ---------------------------------------------------------- !
    ! DUMMY ARGUMENTS
    ! ---------------------------------------------------------- !
    real,                            intent(in) ::PARlocal
    real,dimension(iomax+iChl,npmax),intent(in) ::biomass
    real,dimension(iomax,npmax),     intent(in) ::limit
    real,dimension(npmax),           intent(in) ::VLlimit
    real,dimension(iimax,npmax),     intent(in) ::up_inorg
    real,                            intent(in) ::gamma_T
    real,dimension(npmax),           intent(out)::PP
    real,dimension(npmax),           intent(out)::chlsynth
    real,                            intent(out)::totPP
    ! ---------------------------------------------------------- !
    ! DEFINE LOCAL VARIABLES
    ! ---------------------------------------------------------- !
    real,dimension(npmax)::isautotrophic
    real                 ::E0
    real,dimension(npmax)::Cbiomass,chl,VCN,Chl2C,costbiosynth
    real,dimension(npmax)::alpha,PCmax,PCPhot,rhochl

    ! initialise
    PP(:)       = 0.0
    chlsynth(:) = 0.0
    totPP       = 0.0

    if (ctrl_photosynth_form.eq.'Geider98') then ! Geider, MacIntyre and Kana - L&O (1998) 43(4), 679-694
       ! adapted for multiple nutrients following Moore, et al. - DSR2 (2002) 49, 403-462
       !-----------------------------------------------------------------
       E0 = PARlocal/0.2174  ! convert from W m^-2 to muEin m^-2 s^-1
       if (E0.gt.1.e-1) then ! only do if there is some meaningful amount of light
          ! Initialisation
          Cbiomass(:) = biomass(iCarb,:) ! mmol C m^-3
          chl(:)      = biomass(iChlo,:) ! mg Chl m^-3
          ! VCN = total N uptake --> sum of NO3, NO2 and NH4 uptake: (mmol N (mmol C)^-1 s^-1)
          VCN(:) = 0.0
          if (nquota) then
             if (useNO3)  VCN(:) = VCN(:) + up_inorg(iNO3,:)
             if (useNO2)  VCN(:) = VCN(:) + up_inorg(iNO2,:)
             if (useNH4)  VCN(:) = VCN(:) + up_inorg(iNH4,:)
          elseif (pquota) then
             VCN(:) = up_inorg(iPO4,:) * 16.0
          else
             print*,"!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
             print*,"ERROR: Neither nquota nor pquota are set. Needed for chlorophyll synthesis"
             print*,"Stopped in SUBROUTINE photosynthesis (ecogem_box)."
             print*,"!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
             STOP
          endif
          ! iron limitation of light capture: (mmol C (mg chl a)^-1 (mu Ein m^-2)^-1)
          if (useFe) then
             alpha(:) = alphachl(:) * limit(iIron,:)
          else
             alpha(:) = alphachl(:) ! mmol C (mg chl a)^-1 (mu Ein m^-2)^-1
          endif
          ! Photosynthesis Calculations
          ! Chl2C ratio: (mg chl (mmol C)^-1)
          Chl2C(:) = chl(:) / Cbiomass(:)
          Chl2C(:) = MERGE(Chl2C(:),0.0,Cbiomass(:).gt.0.0) ! Check for divide by zero
          ! theoretical light replete photosynthesis given current temperature and nutrient limitation: (s^-1)
          PCmax(:) = vmax(iDIC,:) * VLlimit(:) * gamma_T
          ! light-limited photosynthesis: (s^-1)
          PCPhot(:) = PCmax(:) * (1.0 - exp(-alpha(:)*Chl2C(:)*E0/PCmax))
          PCPhot(:) = MERGE(PCPhot(:),0.0,PCmax.gt.0.0) ! Check for divide by zero
          ! Chlorophyll Synthesis Calculations
          ! Chlorophyll synthesis per mole N uptake: (mg chl (mmol N)^-1)
          rhochl(:) = Chl2Nmax * PCPhot(:) / (alpha(:)*Chl2C(:)*E0)
          rhochl(:) = MERGE(rhochl(:),0.0,(alpha(:)*Chl2C(:)*E0).gt.0.0) ! Check for divide by zero
          ! Chlorophyll synthesis rate: (mg chl m^-3 s^-1)
          chlsynth(:) = rhochl(:) * VCN(:) * Cbiomass(:)
          ! Cost of biosynthesis
          costbiosynth(:) = biosynth*VCN(:)  ! s^-1
          ! Mask strict heterotrophs
          isautotrophic = MERGE(1.0,0.0,autotrophy(:).gt.0.0)
          ! Output variables
          chlsynth(:) =  chlsynth(:) * isautotrophic
          PP(:)       = (PCPhot(:) - costbiosynth(:)) * isautotrophic
          if (fundamental) PP(:) = PCPhot(:) * isautotrophic ! ignore cost of biosynthesis in fund. niche experiment
          totPP       =  sum(PCPhot(:) * Cbiomass(:) * isautotrophic) ! does not include cost of biosynthesis
          !-----------------------------------------------------------------
       else ! else if it is extremely dark
          PP(:)       = 0.0 ! s^-1
          chlsynth(:) = 0.0 ! mg chl m^-3 s^-1
          totPP       = 0.0
       endif
       !-----------------------------------------------------------------
    else
       print*,"!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
       print*,"ERROR: ctrl_photosynth_form = '"//trim(ctrl_photosynth_form)//"' is not a valid photosynthesis function."
       print*,"Stopped in SUBROUTINE photosynthesis (ecogem_box)."
       print*,"!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
       STOP
    endif

  END SUBROUTINE photosynthesis

  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  SUBROUTINE grazing(          &
       &                  biomass,  &
       &                  gamma_T,  &
	   &                  zoolimit,  &
       &                  GrazingMat &
       &                 )

    IMPLICIT NONE
    ! ---------------------------------------------------------- !
    ! DUMMY ARGUMENTS
    ! ---------------------------------------------------------- !
    real,                                  intent(in)  :: gamma_T
    real,dimension(iomax+iChl,npmax)      ,intent(in)  :: biomass
    real,dimension(iomax+iChl,npmax,npmax),intent(out) :: GrazingMat
    real,dimension(npmax,npmax),intent(out)            :: zoolimit
    ! ---------------------------------------------------------- !
    ! DEFINE LOCAL VARIABLES
    ! ---------------------------------------------------------- !
    integer                         :: io,jpred,jprey
    real   ,dimension(npmax)        :: Refuge
    real                            :: tmp1,food1,food2

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !! Matrix based version
    !real   ,dimension(npmax,npmax)  :: Food,Saturation
    !real   ,dimension(npmax,npmax)  :: PreyMat,SwitchMatTop,SwitchMatBot,Switching,X2CRatioMat
    !real   ,dimension(1,npmax)      :: onerow,X2CRatio,PreyC
    !real   ,dimension(npmax,1)      :: onecol,AllGraz,SwitchCol
    !!   PRE-ASSIMILATION grazing of type jpredator by type jprey
    !    GrazingMat(:,:,:)     = 0.0
    !!   Vectors for matrix padding
    !    onerow                = 1.0                                                   ! Row vector
    !    onecol                = 1.0                                                   ! Column vector
    !    PreyC(1,:)            = biomass(iCarb,:)                                      ! Prey biomass vector [1,jprey]
    !!   Predator-dependent (Prey-integrated) terms
    !    Food(:)               = matmul(PreyC(1,:),gkernelT(:,:))                      ! Sum of available prey for each predator [1,jpred] (using transpose of gkernel)
    !    Refuge(:)             = (1.0 - exp(Lambda * Food(:)))                         ! Prey Refuge [1,jpred]
    !    Saturation(:)         = Food(:) / (Food(:)+kg(:))                             ! Saturation of predator feeding by available prey [1,jpred]
    !    Saturation(:)         = MERGE(Saturation(:),0.0,(Food(:)+kg(:)).gt.0.0)       ! check for divide by zeros [ MERGE(TrueSOURCE,FalseSOURCE,CONDITION) ]
    !!   Prey biomass dependent switching
    !    PreyMat(:,:)          = matmul(onecol(:,1:1),PreyC(1:1,:))                    ! Prey biomass replicated in matrix for each predator [jpred,jprey]
    !    SwitchMatTop(:,:)     = (PreyMat(:,:) * gkernel)**ns                          ! Passive (ns=1) or active (ns=2) switching term [jpred,jprey]
    !    SwitchCol(:,1)        = sum(SwitchMatTop,2)                                   ! Sum of switching terms for each predator [jpred,1]
    !    SwitchMatBot(:,:)     = matmul(SwitchCol(:,1:1),onerow(1:1,:))                ! Sum of switching terms replicated in matrix for each prey [jpred,jprey]
    !    Switching(:,:)        = SwitchMatTop(:,:) / SwitchMatBot(:,:)                 ! Switching matrix [jpred,jprey]
    !    Switching(:,:)        = MERGE(Switching(:,:),0.0,SwitchMatBot(:,:).gt.0.0)    ! check for divide by zeros
    !!   Final Grazing Matrix
    !    AllGraz(:,1)          = graz(:) * gamma_T * Saturation(:) * Refuge(:)         ! Temperature limited grazing attack rate down-regulated by saturation and prey refugia  [jpred,1]
    !    GrazingMat(iCarb,:,:) = matmul(AllGraz(:,1:1),onerow(1:1,:)) * Switching(:,:) ! Pad out to matrix and multiply by switching term!  [jpred,jprey]
    !!   Other quotas by prey stoichiometry
    !    do io=2,iomax+iChl
    !      X2CRatio(1,:)       = biomass(io,:) / biomass(iCarb,:)                      ! [1,jprey]
    !      X2CRatio(1,:)       = MERGE(X2CRatio(1,:),0.0,biomass(iCarb,:).gt.0.0)      ! check for divide by zeros
    !      X2CRatioMat(:,:)    = matmul(onecol,X2CRatio)                               ! [jpred,jprey]
    !      GrazingMat(io,:,:)  = GrazingMat(iCarb,:,:) * X2CRatioMat(:,:)              ! [jpred,jprey]
    !    enddo
    !    ! !!!
    !    GrazingMat(:,:,:)     = MERGE(GrazingMat(:,:,:),0.0,GrazingMat(:,:,:).gt.0.0) ! check for -ve values
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! Loop based version
    GrazingMat(:,:,:) = 0.0
    Refuge(:) = 0.0
    tmp1      = 0.0
    do jpred=1,npmax ! loop predators
       if (graz(jpred).gt.0.0) then ! if non-zero max grazing rate
          food1 = 0.0 ! available food
          food2 = 0.0 ! available food ^ ns
          do jprey=1,npmax ! sum all the prey carbon of predator, weighted by availability (preference)
             if (gkernel(jpred,jprey).gt.0.0) then
                food1 = food1 +  gkernel(jpred,jprey)*palatability(jprey)*biomass(iCarb,jprey)      ! available food
                food2 = food2 + (gkernel(jpred,jprey)*palatability(jprey) * biomass(iCarb,jprey))**ns_array(jpred) ! available food ^ ns
             endif
          enddo
          ! calculate grazing effort
          if (food1 + kg(jpred).gt.0.0) then
             Refuge(jpred) = (1.0 - exp(Lambda * food1)) ! pref refuge function
             tmp1  = food1 / (food1 + kg(jpred)) * Refuge(jpred) ! grazing "effort" (max 1*gamma_T)
          endif
          ! loop prey to calculate grazing rates on each prey and element
          do jprey=1,npmax
             if (biomass(iCarb,jprey).gt.0.0.and.food2.gt.0.0) then ! if any prey food available
                GrazingMat(iCarb,jpred,jprey) = tmp1 * gamma_T * graz(jpred)   &                        ! total grazing rate
                     &             * (gkernel(jpred,jprey)*palatability(jprey)*biomass(iCarb,jprey))**ns_array(jpred)/food2 ! * switching
                zoolimit(jpred,jprey) = tmp1 *(gkernel(jpred,jprey)*palatability(jprey)*biomass(iCarb,jprey))**ns_array(jpred)/food2 ! food limitation calulation for zooplankton - Maria May 2019
                ! other organic elements (+ chlorophyll) are grazed in stoichiometric relation to carbon
                do io=2,iomax+iChl
                   if (biomass(iCarb,jprey).gt.0.0) then
                      GrazingMat(io,jpred,jprey) = GrazingMat(iCarb,jpred,jprey) &
                           &                                      * biomass(io,jprey)/biomass(iCarb,jprey)
                   endif
                enddo ! io
             endif ! endif any food available
          enddo ! jprey
       endif  ! endif non-zero max grazing rate
    enddo ! jpred

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  END SUBROUTINE grazing

  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  !ckc fractiontion to calculate nutrient isotopes uptake rates based on up_inorg
  SUBROUTINE nut_fractionation (           &
       up_inorg,    &
       nuts,    &
       nutiso,  &
       diameter,    &
       up_inorgiso  )

    IMPLICIT NONE
    ! ---------------------------------------------------------- !
    ! DUMMY ARGUMENTS
    ! ---------------------------------------------------------- !
    real,dimension(iimax,npmax),     intent(in) ::up_inorg
    real,dimension(iimax),           intent(in) ::nuts
    real,dimension(iimaxiso),        intent(in) ::nutiso
    real,dimension(npmax),           intent(in) ::diameter
    real,dimension(iimaxiso,npmax),  intent(out)::up_inorgiso
    ! ---------------------------------------------------------- !
    ! DEFINE LOCAL VARIABLES
    ! ---------------------------------------------------------- !
    real                             :: fract ! fractionation value

    fract = -25.0  !test
    ! size dependent, need mean size for phytoplankton
    up_inorgiso(iDIC_13C,:) = up_inorg(iDIC,:) * 0.0109 !ckc for testing
    !print*, "up inorgio iDIC_13C  ", up_inorgiso(iDIC_13C,:)

  END SUBROUTINE nut_fractionation

  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! ****************************************************************************************************************************** !
  ! CHECK_EGBG_COMPATIBLE
  ! checks nutrients required by ECOGEM are carried by BIOGEM
  SUBROUTINE check_egbg_compatible()

    implicit none

    logical :: errflag
    integer :: nstr
    character(500) :: errmsg

    errflag=.false.
    errmsg=''
    nstr=0
    if (useNO3  .and. .not. ocn_select(io_NO3) ) then
       errflag=.true.
       errmsg=errmsg(1:nstr)//'NO3, '
       nstr=nstr+5
    endif
    if (useNO2  .and. .not. ocn_select(io_NO2) ) then
       errflag=.true.
       errmsg=errmsg(1:nstr)//'NO2, '
       nstr=nstr+5
    endif
    if (useNH4  .and. .not. ocn_select(io_NH4) ) then
       errflag=.true.
       errmsg=errmsg(1:nstr)//'NH4, '
       nstr=nstr+5
    endif
    if (usePO4  .and. .not. ocn_select(io_PO4) ) then
       errflag=.true.
       errmsg=errmsg(1:nstr)//'PO4, '
       nstr=nstr+5
    endif
    !  if (useFe  .and. .not. ocn_select(io_???) ) then
    !    errflag=.true.
    !    errmsg=errmsg(1:nstr)//'PO4, '
    !    nstr=nstr+5
    !  endif
    if (useSiO2 .and. .not. ocn_select(io_SiO2)) then
       errflag=.true.
       errmsg=errmsg(1:nstr)//'SiO2  '
       nstr=nstr+6
    endif

    if (errflag) then
       print*," "
       print*,"! ERROR !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
       print*,"! ECOGEM wants a nutrient that BIOGEM doesn't have!"
       print*,"! Specifically: ",errmsg(1:nstr-2)
       print*,"!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!"
       print*,"! Change either supply (BIOGEM), or demand (ECOGEM)"
       stop
    endif

  END SUBROUTINE check_egbg_compatible
  ! ****************************************************************************************************************************** !
  ! convert a word to lower case
  subroutine lower_case(word)
    character (len=*) , intent(in out) :: word
    integer                            :: i,ic,nlen
    nlen = len(word)
    do i=1,nlen
       ic = ichar(word(i:i))
       if (ic >= 65 .and. ic <= 90) word(i:i) = char(ic+32)
    end do
  end subroutine lower_case
  ! ****************************************************************************************************************************** !

END MODULE ecogem_box


	SUBROUTINE ILINE ( np, ix, iy, iret )
C************************************************************************
C* ILINE								*
C*									*
C* This subroutine draws lines on a graphics device.  The points are 	*
C* first clipped.							*
C*									*
C* ILINE ( NP, IX, IY, IRET )						*
C*									*
C* Input parameters:							*
C*	NP		INTEGER		Number of points		*
C*	IX (NP)		INTEGER		X coordinates in device units	*
C*	IY (NP)		INTEGER		Y coordinates in device units	*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* M. desJardins/612	 5/85	GEMPLT Version 3.1			*
C* M. desJardins/612	10/87	Cleaned up				*
C* M. Linda/GSC		 6/96	Replaced local buffers with GBUFFT	*
C************************************************************************
	INCLUDE		'DVWNDW.CMN'
	INCLUDE 	'ERROR.PRM'
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'GBUFFT.CMN'
C*
	INTEGER 	ix (*), iy (*)
	LOGICAL		bounds, clip, linvis
C
C*	This statement function checks whether a point is within the
C*	current clipping area.
C
	bounds (j) = (( ispanx * (ix(j)  - icleft) .ge. 0 ) .and.
     +		      ( ispanx * (icrght - ix(j) ) .ge. 0 ) .and.
     +		      ( ispany * (iy(j)  - icbot ) .ge. 0 ) .and.
     +		      ( ispany * (ictop  - iy(j) ) .ge. 0 ))
C------------------------------------------------------------------------
	iret = NORMAL
C
C*	Check to see that there are at least two points on the line.
C
	IF ( np .le. 1 ) RETURN
C*
	clip = .false.
	n = 0
	i = 1
C
C*	Loop through all the points.
C
	DO  i = 1, np
C
C*	    If the last point was not clipped and this point is inbounds,
C*	    add this point to the buffer.
C
	    IF  ( (.not. clip) .and. bounds(i) ) THEN
		n = n + 1
		igx (n) = ix(i)
		igy (n) = iy(i)
C
C*	      If the last point was clipped and this point is inbounds,
C*	      clip this line segment and start a new buffer.
C
	      ELSE IF ( bounds (i) ) THEN
C
		CALL ICLIP ( ix(i-1), iy(i-1), ix(i),  iy(i),
     +			     igx(1),  igy(1),  igx(2), igy(2), linvis )
		clip = .false.
		n = 2
C
C*	      If the first point is out of bounds, set the clip flag to true.
C
	      ELSE IF ( (.not. bounds(i)) .and. ( i .eq. 1) ) THEN
C
		clip = .true.
C
C*	      If the last point was in bounds and this point is out of bounds,
C*	      clip the line segment, add to buffer and dump buffer.
C
	      ELSE IF ( .not. clip ) THEN
C
		n = n + 1
		CALL ICLIP ( ix(i-1), iy(i-1), ix(i),   iy(i),
     +			     j1,      j2,      igx(n), igy(n), linvis )
C
		CALL IDASH ( n, igx, igy, ier )
		n = 0
		clip = .true.
C
C*	      If both the last point and this point are out of bounds,
C*	      clip the line segment.  If the line was visible, send the two
C*	      points to be drawn.
C
	      ELSE
C
		CALL ICLIP ( ix(i-1), iy(i-1), ix(i),  iy(i),
     +			     igx(1),  igy(1),  igx(2), igy(2), linvis )
C
		IF ( linvis ) CALL IDASH ( 2, igx, igy, ier )
		n    = 0
		clip = .true.
C
	    END IF
C
	END DO
C
C*	Flush the buffer if necessary.
C
	IF  ( n .gt. 0 ) CALL IDASH ( n, igx, igy, ier )
C*
	RETURN
	END


C
      SUBROUTINE TRANFR
C
C FORMAL SOLVES THE TRANSFER EQUATION WITH GIVEN SOURCE FUNCTION 'SOURCE'.
C 'ERROR' IS THE RESULTING ERROR IN THE DEFINITION OF THE CONTINUUM
C SCATTERING SOURCE FUNCTION. TRANSFR CALCULATES THE MATRIX ELEMENTS
C OF THE PROBLEM. INTENSITIES AT TAU=0 ARE RETURNED IN /CSURF/.
C 80.08.05 *NORD*
C
C Updated 04-jun-89/aake:  All mu-quadratures are over even functions
C of mu, and use TRQUA2.
C
      INCLUDE 'spectrum.inc'
C
      COMMON /CTRAN/X(NDP),S(NDP),BPLAN(NDP),XJ(NDP),XH(NDP),XK(NDP),
     &  FJ(NDP),SOURCE(NDP),TAUS(NDP),DTAUS(NDP),JTAU0,JTAU1,ISCAT
      COMMON /TAUC/TAU(NDP),DTAULN(NDP),JTAU
      COMMON /SPACE2/ERROR(NDP),FACT(NDP),DSO(NDP),
     &  P(NDP),DUM(NDP,3),
     &  SP1(NDP,NRAYS),SP2(NDP,NRAYS),SP3(NDP,NRAYS),AD(NDP,NRAYS),
     &  BD(NDP,NRAYS),EX(NRAYS),
     &  NIMPAC,KIMPAC(NRAYS),PIMPAC(NRAYS),MMU(NDP),
     &  TAUT(NDP),DTAUT(NDP),
     &  PFEAU(NRAYS,NDP),XMU(NRAYS,NDP)
      COMMON /CSPHER/NCORE,DIFLOG,RADIUS,RR(NDP)
      COMMON /CSURF/HSURF,YSURF(NRAYS)
      COMMON /ROSSC/ROSS(NDP),CDUMM(NDP) /RHOC/RHO(NDP)
      COMMON /TRDBUG/IDEBUG
C
      DIMENSION FUN(NRAYS),DER(NRAYS*2),DMU(NRAYS+1)
      DIMENSION TAULOG(NDP),XMU1(NRAYS)
C
C MU LOOP
      DO 131 I=1,NIMPAC
      NTAU=KIMPAC(I)
      NTAU1=NTAU-1
C
C CALCULATE DTAUT ALONG THE RAY
      ZOLD=0.0
      DO 100 K=1,NTAU
      Z=SQRT(RR(NTAU-K+1)**2-PIMPAC(I)**2)
      XMU(I,NTAU-K+1)=-Z/RR(NTAU-K+1)
      IF (K.EQ.1) GO TO 100
      DZ=Z-ZOLD
      DZDR=DZ/(RR(NTAU-K+1)-RR(NTAU-K+2))
      DTAUT(NTAU-K+2)=DZDR*0.5*(X(NTAU-K+1)+S(NTAU-K+1)
     & +X(NTAU-K+2)+S(NTAU-K+2))*(TAU(NTAU-K+2)-TAU(NTAU-K+1))
100   ZOLD=Z
      TAUT(1)=DZDR*(X(1)+S(1))*TAU(1)
      DO 101 K=2,NTAU
101   TAUT(K)=TAUT(K-1)+DTAUT(K)
C
C SAVE THE TAU SCALE FOR THE RADIAL RAY (I=1).  THIS IS USED IN
C THE EXTRA/INTERPOLATION OF THE PFEAU FOR MU=0., FURTHER DOWN.
C
      IF (I.EQ.1) THEN
        DO 102 K=1,NTAU
          TAULOG(K)=ALOG(TAUT(K))
cccc          print*,k,tau(k),taut(k),taulog(k)
102     continue
      ENDIF
C
C K=1
      A=1./DTAUT(2)
      B=A**2
      SP2(1,I)=1.+2.*A
      SP3(1,I)=-2.*B
      EX(I)=TAUT(1)*(1.-0.5*TAUT(1)*(1.-TAUT(1)/3.)*(1.-taut(1)/4.))
      IF (TAUT(1).GT.0.01) then
        EX(I)=1.-EXP(-TAUT(1))
      endif
      SP2(1,I)=SP2(1,I)/(1.+2.*A*EX(I))
      SP3(1,I)=SP3(1,I)/(1.+2.*A*EX(I))
C
C K=2,NTAU-1
      DO 110 K=2,NTAU1
      DTAUC=0.5*(DTAUT(K)+DTAUT(K+1))
C...      AD(K,I)=0.1666667*DTAUT(K)/DTAUC
C...      BD(K,I)=0.1666667*DTAUT(K+1)/DTAUC
      AD(K,I)=0.
      BD(K,I)=0.
      SP1(K,I)=-1./(DTAUT(K)*DTAUC)+AD(K,I)
      SP2(K,I)=1.
110   SP3(K,I)=-1./(DTAUT(K+1)*DTAUC)+BD(K,I)
C
C K=NTAU
      AD(NTAU,I)=0.0
      BD(NTAU,I)=0.0
      SP1(NTAU,I)=0.0
      SP2(NTAU,I)=1.0
      SP3(NTAU,I)=0.0
      IF (I.LE.NCORE) GO TO 120
      AD(NTAU,I)=0.3333333
      SP1(NTAU,I)=0.3333333-2./DTAUT(NTAU)**2
120   CONTINUE
C
C ELIMINATE SUBDIAGONAL
      DO 130 K=1,NTAU1
      SP1(K,I)=-SP1(K+1,I)/(SP2(K,I)-SP3(K,I))
      SP2(K+1,I)=SP2(K+1,I)+SP1(K,I)*SP2(K,I)
130   SP2(K,I)=SP2(K,I)-SP3(K,I)
131   CONTINUE
C
C FIND A GOOD RAY FOR TRANSC.  THE XMU VALUES ARE INCREASING FROM
C -1.0 TOWARDS 0.0, AND WE THUS ALWAYS FIND A VALUE FOR ISCAT.
C
C      IMAX=MIN0(MMU(JTAU0),NCORE)
C
C NCORE MUST BE SMALLER THAN MMU(K) FOR ALL K, SO EFFECTIVELY THE
C MIN0(MMU(),NCORE) IS EQUAL TO NCORE.  SHOULD ONE REQUIRE ISCAT TO
C BE A CORE RAY?  PROBABLY NOT, SINCE WITH A LARGE TAUM (ALLOWED),
C THE ISCAT RAY IS FORCED TOWARDS SMALLER IMPACT PARAMETERS, WHICH
C DEGRADES PERFORMANCE.
C
      IMAX=MMU(JTAU0)
      TMP1=1.
      DO 132 I=1,IMAX
C
C      IF (XMU(I,JTAU0).LT.-0.577) ISCAT=I
C
C  Better to look for the ray which is closest to the Eddington angle
C
	TMP2=ABS(XMU(I,JTAU0)+0.577)
	IF (TMP2.LT.TMP1) THEN
	  TMP1=TMP2
	  ISCAT=I
	ENDIF
132   CONTINUE
      RETURN
C---------------------------------------------------------------------
C
      ENTRY FORMAL
C
C MU LOOP
      DO 170 I=1,NIMPAC
      NTAU=KIMPAC(I)
      NTAU1=NTAU-1
C
C INITIATE
      P(1)=SOURCE(1)
ccc      print*,'p(','1',') ',p(1)
      DO 140 K=2,NTAU
      P(K)=(1.-AD(K,I)-BD(K,I))*SOURCE(K)+AD(K,I)*SOURCE(K-1)+
     & BD(K,I)*SOURCE(min(K+1,ntau))
ccc      print*,'p(',k,') ',p(k)
140   continue
      IF(I.LE.NCORE) P(JTAU1)=SOURCE(JTAU1)+XMU(I,JTAU1)**2*XH(JTAU1)
ccc      print*,'p(jtau1) ',jtau1,p(jtau1)
C
C ACCUMULATE RIGHT HAND SIDE
      DO 150 K=1,NTAU1
150   P(K+1)=P(K+1)+SP1(K,I)*P(K)
ccc        print*,'accumulated p'
ccc      do k=1,ntau
ccc        print*,k,p(k)
ccc      enddo
C
C BACKSUBSTITUTE
      PFEAU(I,NTAU)=P(NTAU)/SP2(NTAU,I)
ccc       print*,i,ntau,pfeAU(i,ntau),p(ntau),sp2(ntau,i)
      DO 160 K=1,NTAU1
      PFEAU(I,NTAU-K)=(P(NTAU-K)-
     & SP3(NTAU-K,I)*PFEAU(I,NTAU-K+1))/SP2(NTAU-K,I)
       if (k.eq.1) then
ccc       print*,i,ntau-k,pfeAU(i,ntau-k)
       endif
      IF (PFEAU(I,NTAU-K).LE.0.0) GO TO 230
160   CONTINUE
C
C END MU LOOP
      YSURF(I)=2.*(1.-EX(I))*PFEAU(I,1)+EX(I)**2*SOURCE(1)
      FUN(I)=-XMU(I,1)*(PFEAU(I,1)-SOURCE(1)*EX(I))
      IF (YSURF(I).LE.0.0) GO TO 231
170   CONTINUE
C
C  INTERPOLATE TO PFEAU AT MU=0 FOR THOSE K THAT HAVE NO RAY
*  THIS IS THE ORIGINAL CODE, WHICH EXTRAPOLATES IN MU, FOR CONSTANT K.
*  THIS WAS FOUND TO PRODUCE BAD RESULTS FOR THE FLUX, WHICH IS A
*  DERIVATIVE OF XK, WHICH IS THE SECOND MOMENT OF THE FUNCTION
*  BEING EXTRAPOLATED TO ZERO.
*      DO 181 K=1,JTAU1
*      II=MMU(K)
*      IF (KIMPAC(II).EQ.K) GO TO 181
*      PX=-XMU(II-2,K)/(XMU(II-1,K)-XMU(II-2,K))
*      QX=1.-PX
*      PFEAU(II,K)=EXP(ALOG(PFEAU(II-2,K))*QX+ALOG(PFEAU(II-1,K))*PX)
*181   CONTINUE
*
*  INTERPOLATE/EXTRAPOLATE IN K FOR PFEAU AT MU=0
*  THIS SHOWS WHAT IS INTENDED TO BE DONE, IF USING AN EXTERNAL
*  INTERPOLATION ROUTINE.
*       DO 181 I=1,NIMPAC
*         K=KIMPAC(I)
*         F(I)=PFEAU(I,K)
*         X(I)=ALOG(TAU(K))
*181   CONTINUE
*      DO 182 K=1,JTAU1
*        XX(K)=ALOG(TAU(K))
*182   CONTINUE
*      CALL INTERP(NIMPAC,X,F,JTAU1,XX,FF)
*      DO 183 K=1,JTAU1
*        I=MMU(K)
*        PFEAU(I,K)=FF(K)
*183   CONITNUE
C
C  DO IT INLINE:  EXTRAPOLATE/INTERPOLATE THE PFEAU IN ALOG(TAU), FOR MU=0.
C   START WITH 3 OUTERMOST POINTS (YOU PROBABLY NOTICED THAT KIMPAC(NIMPAC)=4)
C   JUMP OVER THE RAYS (WHERE PFEAU(MU=0.) IS ALREADY CALCULATED), AND
C   INTERPOLATE THE REST OF THE TIME.
C
      IF (NCORE.EQ.NIMPAC) THEN
C
C  TEMPORARY SECURITY TO AVOID DIVIDE BY ZERO ERRORS IN COMPUTATION OF PX,
C  WHEN THE OPACITY IS SO LARGE THAT THERE ARE ONLY NCORE RAYS.
C  IN THAT CASE, ONE USES THE OLD INTERPOLATION ROUTINE
C
      print*,'NCORE = NIMPAC. INTERPOLATION IN MU USED'
      DO 1810 K=1,JTAU1
        II=MMU(K)
        IF (KIMPAC(II).EQ.K) GO TO 1810
        PX=-XMU(II-2,K)/(XMU(II-1,K)-XMU(II-2,K))
        QX=1.-PX
        PFEAU(II,K)=EXP(ALOG(PFEAU(II-2,K))*QX+ALOG(PFEAU(II-1,K))*PX)
      if(pfeau(ii,k).lt.0)
     &       print*, 'k',k,ii,pfeau(ii,k),' <0 pfeau'
1810   CONTINUE

      ELSE
C
C HERE IS THE NORMAL ONE.  EXTRAPOLATE FOR K<4, THEN INTERPOLATE
C
      I=NIMPAC
      DO 181 K=1,JTAU1
        IF (K.NE.KIMPAC(I)) THEN
          PX=(TAULOG(K)-TAULOG(KIMPAC(I)))/
     &       (TAULOG(KIMPAC(I-1))-TAULOG(KIMPAC(I)))
          QX=1.-PX
*
ccc      print*,ALOG(PFEAU(MMU(KIMPAC(I)),KIMPAC(I)))*QX+
ccc     &     ALOG(PFEAU(MMU(KIMPAC(I-1)),KIMPAC(I-1)))*PX
ccc          if ( ALOG(PFEAU(MMU(KIMPAC(I)),KIMPAC(I)))*QX+
ccc     &     ALOG(PFEAU(MMU(KIMPAC(I-1)),KIMPAC(I-1)))*PX .gt.-20.) then
cc       print*,mmu(kimpac(i)),kimpac(i),PFEAU(MMU(KIMPAC(I)),KIMPAC(I)),
cc     &        mmu(kimpac(i-1)),kimpac(i-1),
cc     &        PFEAU(MMU(KIMPAC(I-1)),KIMPAC(I-1))
*
           PFEAU(MMU(K),K)=sngl(dEXP(
     &       dLOG(dble(PFEAU(MMU(KIMPAC(I)),KIMPAC(I))))*QX+
     &       dLOG(dble(PFEAU(MMU(KIMPAC(I-1)),KIMPAC(I-1))))*PX))
ccc          else
ccc           pfeau(mmu(k),k)=1.e-15
ccc          endif
*
        ENDIF
        IF (K.EQ.(KIMPAC(I-1)-1)) THEN
          I=I-1
        ENDIF
181   CONTINUE

      ENDIF

C
C CALCULATE MEAN INTENSITY USING CUBIC SPLINE WITH CENTRAL DIFFERENCE
      DO 190 K=1,JTAU1
        XJ(K)=TRQUA2(MMU(K),XMU(1,K),PFEAU(1,K),DMU,DER)
        ERROR(K)=(XJ(K)*S(K)+BPLAN(K)*X(K))/(X(K)+S(K))-SOURCE(K)
190   CONTINUE
      RETURN
C--------------------------------------------------------------------
C
      ENTRY TRMOM
C
C FLUX AT TAU(1)
      XH(1)=TRQUA2(MMU(1),XMU,FUN,DMU,DER)
C
C  CALCULATE SECOND MOMENT XK
C
      DO 201 K=1,JTAU1
      NMU=MMU(K)
      DO 200 I=1,NMU
200     FUN(I)=PFEAU(I,K)*XMU(I,K)**2
201   XK(K)=TRQUA2(NMU,XMU(1,K),FUN,DMU,DER)
C
C CALCULATE FIRST MOMENT, XH, FROM MOMENT RELATION
      DO 211 K=JTAU1+1,JTAU
211   XH(K)=( XK(K)-XK(K-1)+
     &       (XJ(K)+XJ(K-1)-3.*(XK(K)+XK(K-1)))*
     &       (RR(K-1)-RR(K))/(RR(K)+RR(K-1))    )*2.0/
     &          ( (TAU(K)-TAU(K-1)) * (X(K)+S(K)+X(K-1)+S(K-1)) )
C
C CALCULATE FIRST MOMENT BY USING R=DP/DTAU.  THIS IS MORE ACCURATE
C IN THE OPTICALLY THIN PARTS.
      ZOLD=0.0
      DO 212 K=2,JTAU1
        NMU=MMU(K)
        DO 213 I=1,NMU-1
          DZDR=(XMU(I,K)*RR(K)-XMU(I,K-1)*RR(K-1))/(RR(K-1)-RR(K))
          DTAU=DZDR*0.5*(X(K-1)+S(K-1)+X(K)+S(K))*(TAU(K)-TAU(K-1))
          XMU1(I)=
     &      -(XMU(I,K)*RR(K)+XMU(I,K-1)*RR(K-1))/(RR(K)+RR(K-1))
          FUN(I)=XMU1(I)*(PFEAU(I,K)-PFEAU(I,K-1))/DTAU
213     CONTINUE
        FUN(NMU)=0.
        XMU1(NMU)=0.
        XH(K)=-TRQUA2(NMU,XMU1,FUN,DMU,DER)
212   CONTINUE
C
C SURFACE FLUX
      NMU=MMU(1)
      PX=-XMU(NMU-2,1)/(XMU(NMU-1,1)-XMU(NMU-2,1))
      QX=1.-PX
      YSURF(NMU)=EXP(ALOG(YSURF(NMU-2))*QX+ALOG(YSURF(NMU-1))*PX)
      DO 220 I=1,NMU
220   FUN(I)=-XMU(I,1)*YSURF(I)
      HSURF=0.5*TRQUA2(NMU,XMU,FUN,DMU,DER)

cc      Print*,'check surf flux:',hsurf/xh(1)
      RETURN
C------------------------------------------------------------------
C
C EMERGENCY EXIT
230   KK=NTAU-K
      IDEBUG=2
      PRINT 232,I,KK,JTAU0,JTAU1,NTAU
232   FORMAT('0NON-POSITIVE RESULT AT I,K,J0,J1,N=',5I3)
      GO TO 233
231   KK=0
      IDEBUG=3
      PRINT 232,I,KK,JTAU0,JTAU1,NTAU
233   PRINT 237,NCORE,ISCAT,DIFLOG,RADIUS,EX(I)
237   FORMAT(' NCORE,ISCAT,DIFLOG,RADIUS,EX(I)=',2I3,3G12.3)
CCCCC      WRITE (13,*) JTAU,TAU,X,S,BPLAN,RADIUS,RR,RHO,ROSS
      PRINT 236,TAU,X,S,BPLAN,RR,RHO,ROSS,SOURCE
     & ,(YSURF(I),(PFEAU(I,K),K=1,39),I=1,NMU)
236   FORMAT('0TAU=',10(/10E12.4)/'0X=',10(/10E12.4)/'0S=',10(/10E12.4)
     & /'0BPLAN=',10(/10E12.4)/'0RR=',10(/10E12.4)/'0RHO=',10(/10E12.4)
     & /'0ROSS=',10(/10E12.4)/'0SOURCE=',10(/10E12.4)
     & /'0YSURF,PFEAU='/(10E12.4))
CCCCC      PRINT 238
238   FORMAT(' DEBUG INFORMATION WRITTEN ON UNIT 13')
      RETURN
      END


      PROGRAM moldyn

      implicit none

      include 'p_input.inc'
      include 'p_array.inc'

      integer iseed,istep
      integer ntype,nprnt,nstep,nequl
      integer ncons,ntcons,consatm
      integer nbond,ntbond,bondatm
      integer nshel,ntshel,shelatm

      real*8 ekin,ecoul,eshrt,ebond,eshel,ewald1
      real*8 tstep,ivv,etime1,etime2

      logical lveloc,lupdate

      dimension ivv(mxatms,3)
      dimension consatm(mxcons,2),bondatm(mxbond,2),shelatm(mxshel,2)

      etime1=0.0
      etime2=0.0
      call cpu_time(etime1)

      open(unit=output,file='OUTPUT')

      call md_inpt(iseed,tstep,nstep,nequl,nprnt,ntype,ncons,consatm,
     $    nbond,bondatm,nshel,shelatm,lveloc)

      call md_init(iseed,ntype,ncons,ntcons,consatm,nbond,ntbond,
     $    bondatm,nshel,ntshel,shelatm,lveloc,ewald1)

      call cpu_time(etime2)
      write(output,'(/,a,f20.3)')'Set-up CPU time : ',(etime2-etime1)

      call write_velo(70)
      do istep=1,nstep

       call verlt_test(tstep,ivv,lupdate)

       if(lupdate)call list_verlt()

       call md_frce(ntype,ecoul,eshrt,ebond,ntbond,eshel,ntshel,ewald1)

       if(ntcons.eq.0)call inte_leapf(tstep,ekin)
       if(ntcons.gt.0)call inte_shake(tstep,ntcons,ekin)

c       if(istep.le.nequl)call md_scle(ntshel)

       call print_output(istep,nprnt,ekin,ecoul,eshrt,ebond,eshel)

      enddo

      call print_final()

      call cpu_time(etime2)
      write(output,'(/,a,f20.3)')'Total CPU time : ',(etime2-etime1)

      END
c $Id$