      SUBROUTINE APD4
C
      EXTERNAL        ORF
      INTEGER         NAM(2),IZ(1),BACK,PSPA,IC(16),EID,PID,CIDBX,SILB,
     1                SCR1,ECTA,BGPA,GPLA,USETA,SILA,ACPT,BUF10,CA4S,
     2                CA4E,PA4S,PA4E,AUSET(6,2),SILC,ORF,USA,UK,EIDB,
     3                SILDX(4),ACSIX(4),CID(5),NECTA(2)
      REAL            VX1(3),VX2(3),ACPL(3,3),RB1(3)
      DIMENSION       AI(6),HEAD(9),IHEAD(9)
      CHARACTER       UFM*23
      COMMON /XMSSG / UFM
      COMMON /BLANK / NK,NJ,LUSETA
      COMMON /APD1C / EID,PID,CP,NSPAN,NCHORD,LSPAN,LCHORD,IGID,
     1                X1,Y1,Z1,X12,X4,Y4,Z4,X43,XOP,X1P,ALZO,MCSTM,
     2                NCST1,NCST2,CIDBX,ACSID,IACS,SILB,NCRD,SCR1,
     3                SCR2,SCR3,SCR4,SCR5,ECTA,BGPA,GPLA,USETA,SILA,
     4                CSTMA,ACPT,BUF10,BUF11,BUF12,NEXT,LEFT,ISILN,
     5                NCAM,NAEF1,NAEF2,
     6                NCA1,NCA2,CA2S,CA2E,CA3S,CA3E,CA4S,CA4E,
     7                NPA1,NPA2,PA2S,PA2E,PA3S,PA3E,PA4S,PA4E
      COMMON /APD1D / ICPL(14),YP4,S1,C1,XP2,XP3,XP4,RA1(3)
      COMMON /ZZZZZZ/ Z(1)
      COMMON /BITPOS/ IBIT(64)
      COMMON /TWO   / ITWO(32)
      COMMON /SYSTEM/ SYSBUF,NOT
      EQUIVALENCE     (ICPL(3),RB1(1)),(ICPL(6),ACPL(1,1)),
     1                (NECTA(1),EIDB),(NECTA(2),CID(1)),
     2                (ACSIX(2),VX2(1)),(Z(1),IZ(1)),(EID,IC(1)),
     3                (SILDX(1),ICID),(SILDX(3),SILC),
     4                (AI(1),DY),(AI(2),BLOC),(AI(3),D),(AI(4),CA),
     5                (AI(5),GAP),(AI(6),NSIZE),(HEAD(1),IHEAD(1))
      DATA     NAM  / 4HAPD4,4H    /
C
      LCA  = 16
      NC4  = ((CA4E-CA4S)+1)/LCA
      NCAM = NCAM + NC4
C
C     INITIAL SETUP
C
      I17 = IBIT(17)
      I18 = IBIT(18)
      I19 = IBIT(19)
      I20 = IBIT(20)
      PSPA= ORF(ITWO(I17),ITWO(I20))
      USA = ORF(PSPA,ITWO(I18))
      UK  = ORF(ITWO(I19),ITWO(I20))
      DO 5 J = 1,2
      DO 5 I = 1,6
    5 AUSET(I,J) = USA
      AUSET(3,2) = UK
      AUSET(5,2) = UK
      IHEAD(1) = 4
      SILC = SILB
C
C     LOOP ON NC4 MOVING CAERO4 CARD TO COMMON
C
      DO 400 I = 1,NC4
      NTOT = 0
      N = (I-1)*LCA - 1
      DO 10 J = 1,LCA
      IC(J) = IZ(CA4S+N+J)
   10 CONTINUE
      MCSTM = MCSTM + 1
      IZ(CA4S+N+2) = MCSTM
      IZ(CA4S+N+8) = 4
      ACSIX(1) = MCSTM
C
C     FIND PAERO4 CARD
C
      CALL APDOE (PID,IZ,PA4S,PA4E,IPID,NPC)
      IF (IPID .EQ. 0) GO TO 999
C
C     FIND NUMBER OF STRIPS
C
      ISPAN = NSPAN
      IAST  = 0
      IF (NSPAN .NE. 0) GO TO 20
      CALL APDOE (NCHORD,IZ,NAEF1,NAEF2,IAST,NSPAN)
      IF (IAST .EQ. 0) GO TO 998
      NSPAN = NSPAN - 1
      IAST  = IAST + 1
   20 IZ(CA4S+N+4) = NSPAN
      IZ(CA4S+N+5) = 1
      IPP = IPID + 5
      NPC = NPC - 4
      NPC = NPC/3
      IF (NPC .LT. NSPAN ) GO TO 997
      IHEAD(8) = NSPAN
C
C     GET POINTS IN PROPER COORD SYSTEM
C
      CALL APDCS
      HEAD(9) = 1.0/SQRT(1.0+((XP4+.25*(X43-X12))/YP4)**2)
      IF (NEXT+6*NSPAN .GT. LEFT) GO TO 996
      IOC = NEXT
C
C     GENERATE DATA FOR BOXES
C
      NCRDP = NCRD
      FSJ1  = APDF(Z(IAST),1,ISPAN)
      YJ1   = FSJ1*YP4
      DJ1   = FSJ1*XP4
      CJ1   = X12 + FSJ1*(X43-X12)
      XIJ1  = DJ1
      XI1J1 = DJ1 + CJ1
      EIDB  = EID - 1
      DO 100 J = 1,NSPAN
      YJ    = YJ1
      FSJ1  = APDF(Z( IAST),J+1,ISPAN)
      YJ1   = FSJ1*YP4
      DJ1   = FSJ1*XP4
      CJ1   = X12 + FSJ1*(X43-X12)
      DY    = (YJ1 - YJ)
      YA    = .5*DY + YJ
      YSP   = YA
      CLOC  = X12 - (X12-X43)*YA/YP4
      BLOC  = CLOC*.5
      DOC   = Z(IPP)
      CAOC  = Z(IPP+1)
      GAPOC = Z(IPP+2)
      IPP   = IPP + 3
      D     = DOC*CLOC
      CA    = CAOC*CLOC
      GAP   = GAPOC*CLOC
      NSIZE = 2
      IF (CAOC .NE. 0.0) NSIZE = 3
      NJ    = NJ + NSIZE
      NK    = NK + NSIZE
      NTOT  = NTOT + NSIZE
      KK    = 0
      DO 40 K = 1,6
      Z(IOC+J+KK) =  AI(K)
      KK = KK + NSPAN
   40 CONTINUE
C
C     EXTERNAL ID S
C
      EIDB   = EIDB + 1
      CID(1) = CIDBX + 1 + 2*(J-1)
      CID(2) = CID(1) + 1
      CID(3) = CID(1) + 2
      CID(4) = CID(3) + 1
      CID(5) = EIDB
      NCID   = CID(4)
C
C     BGPDT , SPL, AND USET
C
      XIJ    = XIJ1
      XI1J   = XI1J1
      XIJ1   = DJ1
      XI1J1  = DJ1 + CJ1
      XIC    = (XIJ+XIJ1+BLOC)*.5
      VX1(3) = 0
      IF (J .NE. 1) GO TO 310
      ASSIGN 300 TO BACK
      ICID   = CID(1)
      VX1(1) = XIJ
      VX1(2) = YJ
      KK     = 1
      GO TO 340
  300 ASSIGN 310 TO BACK
      ICID   = CID(2)
      VX1(1) = XI1J
      VX1(2) = YJ
      KK     = 1
      GO TO 340
  310  ASSIGN 320 TO BACK
      ICID   = CID(3)
      VX1(1) = XIJ1
      VX1(2) = YJ1
      KK     = 1
      GO TO 340
  320 ASSIGN 330 TO BACK
      ICID   = CID(4)
      VX1(1) = XI1J1
      VX1(2) = YJ1
      KK     = 1
      GO TO 340
  330 ASSIGN 360 TO BACK
      ICID   = CID(5)
      VX1(1) = XIC
      IF (NSIZE .EQ. 3) AUSET(6,2) = UK
      VX1(2) = YSP
      KK     = 2
  340 CALL GMMATS (ACPL,3,3,0,VX1,3,1,0,VX2)
      DO 350 K = 1,3
  350 VX2(K) = VX2(K) + RB1(K)
      CALL WRITE (BGPA,ACSIX,4,0)
      CALL WRITE (GPLA,ICID,1,0)
      CALL WRITE (USETA,AUSET(1,KK),6,0)
C
C     SIL AND EQEXIN
C
      NCRD   = NCRD + 1
      SILC   = SILC + 6
      ISILN  = ISILN +6
      SILDX(4) = ISILN
      LUSETA = SILC
      SILDX(2) = 10*SILC + 1
      CALL WRITE (SILA,SILC,1,0)
      CALL WRITE (SCR2,ISILN,1,0)
      CALL WRITE (SCR2,SILC,1,0)
      CALL WRITE (SCR1,ICID,2,0)
      GO TO BACK, (300,310,320,330,360)
C
C     ECT
C
  360 CID(1) = IAPD(1,J  ,1,NCRDP)
      CID(2) = IAPD(2,J  ,1,NCRDP)
      CID(4) = IAPD(1,J+1,1,NCRDP)
      CID(3) = IAPD(2,J+1,1,NCRDP)
      CID(5) = CID(3) + 1
      CALL WRITE (ECTA,NECTA(1),6,0)
      AUSET(6,2) = USA
  100 CONTINUE
      CIDBX = NCID
C
C     PUT OUT ACPT REC
C
      IHEAD(2) = NTOT
      IHEAD(3) = IZ(IPID+1)
      LCLA     = IHEAD(3)
      IHEAD(4) = IZ(IPID+2)
      IHEAD(5) = IZ(IPID+3)
      ICIRC    = IHEAD(5)
      IHEAD(6) = IZ(IPID+4)
      IHEAD(7) = 0
      IL       = 0
      IN       = NSPAN + 1
C
C     PROPERTY DATA
C
      IF (LCLA.EQ.0 .AND. ICIRC.EQ.0) GO TO 70
      IF (LCLA .EQ. 0) GO TO 50
      CALL APDOE (IHEAD(4),IZ,NAEF1,NAEF2,IL,NW)
      IF (IL .EQ. 0) GO TO 994
      IF (MOD(NW,IN) .NE. 0) GO TO 994
      IHEAD(7) = NW/IN
      GO TO 70
   50 IF (ICIRC .EQ. 0) GO TO 70
      CALL APDOE (IHEAD(6),IZ,NAEF1,NAEF2,IL,NW)
      IF (IL .EQ. 0) GO TO 995
      IN = 2 + 2*ICIRC
      IF (MOD(NW,IN) .NE. 0) GO TO 995
      IHEAD(7) = NW/IN
   70 CALL WRITE (ACPT,IHEAD,9,0)
      CALL WRITE (ACPT,Z(IOC+1),NSPAN*6,0)
      IF (IL .NE. 0) CALL WRITE (ACPT,Z(IL+1),NW,0)
      CALL WRITE (ACPT,0,0,1)
  400 CONTINUE
      SILB = SILC
 1001 RETURN
C
C     ERROR MESSAGES
C
  994 I = IHEAD(4)
 9941 WRITE  (NOT,9942) UFM,I,EID
 9942 FORMAT (A23,' 2429, WRONG NUMBER OF WORDS OR CARD NOT FOUND FOR ',
     1       'CARD ID',I9, /29X,'ASSOCIATED WITH CAERO4 ID',I9)
      GO TO 1000
  995 I = IHEAD(6)
      GO TO 9941
  996 CALL MESAGE (-8,0,NAM)
  997 I = PID
      GO TO 9941
  998 I = NCHORD
      GO TO 9941
  999 CALL EMSG (0,2323,1,2,0)
      WRITE  (NOT,891) PID,EID
  891 FORMAT (10X,16HPAERO4 CARD NO. ,I8,31H REFERENCED BY CAERO4 CARD N
     *O. ,I8,15H DOES NOT EXIST)
      GO TO 1000
 1000 CALL MESAGE (-61,0,NAM)
      GO TO 1001
      END


      SUBROUTINE readi(NA,ND,NT,NE,NAX,NDX,NTX,NEX,NF,NFX,NTZ
     2,NTZX,NHW,NHE,NVN,NVS)
C
C     THIS SUBROUTINE READS ALL SOIL AND TOPOGRAPHIC INPUT FILES
C
      include "parameters.h"
      include "filec.h"
      include "files.h"
      include "blkc.h"
      include "blk2a.h"
      include "blk2b.h"
      include "blk2c.h"
      include "blk8a.h"
      include "blk8b.h"
      include "blk17.h"
      include "blk11a.h"
      DIMENSION NA(10),ND(10),NM(JY,JX),DHI(JX),DVI(JY)
      CHARACTER*16 DATA(30),DATAC(30,250,250),DATAP(JP,JY,JX)
     2,DATAM(JP,JY,JX),DATAX(JP),DATAY(JP),DATAZ(JP,JY,JX)
     3,OUTS(10),OUTP(10),OUTFILS(10,JY,JX),OUTFILP(10,JP,JY,JX)
      CHARACTER*3 CHOICE(102,20)
      CHARACTER*8 CDATE
      CHARACTER*16 OUTW,OUTI,OUTT,OUTN,OUTF
      CHARACTER*4 CHARY
      CHARACTER*1 TTYPE,CTYPE,IVAR(20),VAR(50),TYP(50)
      CHARACTER*80 PREFIX
      DIMENSION IDAT(20),DAT(50),DATK(50)
      PARAMETER (TWILGT=0.06976)
C
C     OPEN OUTPUT LOGFILES,AND SITE,TOPOGRAPHY FILES FROM
C     FILE NAMES IN DATA ARRAYS LOADED IN 'MAIN'
C
      OPEN(18,FILE='logfile1',STATUS='UNKNOWN')
      OPEN(19,FILE='logfile2',STATUS='UNKNOWN')
      OPEN(20,FILE='logfile3',STATUS='UNKNOWN')
      OPEN(1,FILE=TRIM(PREFIX)//DATA(1),STATUS='OLD')
      OPEN(7,FILE=TRIM(PREFIX)//DATA(2),STATUS='OLD')
      WRITE(18,5000)' 08 JUL 2021'
5000  FORMAT(A16)
      NF=1
      NFX=1
      NTZ=0
C
C     READ SITE DATA
C
C     ALATG,ALTIG,ATCAG=latitude,altitude,MAT(oC)
C     IDTBLG=water table flag
C        :0=none
C        :1,2=natural stationary,mobile
C        :3,4=artificial stationary,mobile
C     OXYEG,Z2GEG,CO2EIG,CH4EG,Z2OEG,ZNH3EG=atm O2,N2,CO2,CH4,N2O,NH3 (ppm)
C     IETYPG,ISALTG,IERSNG=Koppen climate zone,salt,erosion options
C     NCNG=1:lateral connections between grid cells,3:no connections
C     DTBLIG,DTBLDIG=depth of natural,artificial water table (IDTBLG)
C     DTBLGG=slope of natural water table relative to landscape surface
C     RCHQNG,RCHQEG,RCHQSG,RCHQWG=boundary condns for N,E,S,W surface runoff
C     RCHGNUG,RCHGEUG,RCHGSUG,RCHGWUG=bound condns for N,E,S,W subsurf flow
C     RCHGNTG,RCHGETG,RCHGSTG,RCHGWTG=N,E,S,W distance to water table (m)
C     RCHGDG=lower boundary conditions for water flow
C     DHI=width of each W-E landscape column
C     DVI=width of each N-S landscape row
C
      READ(1,*)ALATG,ALTIG,ATCAG,IDTBLG
      READ(1,*)OXYEG,Z2GEG,CO2EIG,CH4EG,Z2OEG,ZNH3EG
      READ(1,*)IETYPG,ISALTG,IERSNG,NCNG,DTBLIG,DTBLDIG,DTBLGG
      READ(1,*)RCHQNG,RCHQEG,RCHQSG,RCHQWG,RCHGNUG,RCHGEUG,RCHGSUG
     2,RCHGWUG,RCHGNTG,RCHGETG,RCHGSTG,RCHGWTG,RCHGDG
      READ(1,*)(DHI(NX),NX=1,NHE)
      READ(1,*)(DVI(NY),NY=1,NVS)
      CLOSE(1)
      DO 9895 NX=NHW,NHE
      DO 9890 NY=NVN,NVS
      ALAT(NY,NX)=ALATG
      ALTI(NY,NX)=ALTIG
      ATCAI(NY,NX)=ATCAG
      IDTBL(NY,NX)=IDTBLG
      OXYE(NY,NX)=OXYEG
      Z2GE(NY,NX)=Z2GEG
      CO2EI(NY,NX)=CO2EIG
      CH4E(NY,NX)=CH4EG
      Z2OE(NY,NX)=Z2OEG
      ZNH3E(NY,NX)=ZNH3EG
      IETYP(NY,NX)=IETYPG
      NCN(NY,NX)=NCNG
      DTBLI(NY,NX)=DTBLIG
      DTBLDI(NY,NX)=DTBLDIG
      DTBLG(NY,NX)=DTBLGG
      RCHQN(NY,NX)=RCHQNG
      RCHQE(NY,NX)=RCHQEG
      RCHQS(NY,NX)=RCHQSG
      RCHQW(NY,NX)=RCHQWG
      RCHGNU(NY,NX)=RCHGNUG
      RCHGEU(NY,NX)=RCHGEUG
      RCHGSU(NY,NX)=RCHGSUG
      RCHGWU(NY,NX)=RCHGWUG
      RCHGNT(NY,NX)=RCHGNTG
      RCHGET(NY,NX)=RCHGETG
      RCHGST(NY,NX)=RCHGSTG
      RCHGWT(NY,NX)=RCHGWTG
      RCHGD(NY,NX)=RCHGDG
      DH(NY,NX)=DHI(NX)
      DV(NY,NX)=DVI(NY)
      CO2E(NY,NX)=CO2EI(NY,NX)
      H2GE(NY,NX)=1.0E-03
C
C     CALCULATE MAXIMUM DAYLENTH FOR PLANT PHENOLOGY
C
C     DYLM=maximum daylength (h)
C
      IF(ALAT(NY,NX).GT.0.0)THEN
      XI=173
      ELSE
      XI=356
      ENDIF
      DECDAY=XI+100
      DECLIN=SIN((DECDAY*0.9863)*1.7453E-02)*(-23.47)
      AZI=SIN(ALAT(NY,NX)*1.7453E-02)*SIN(DECLIN*1.7453E-02)
      DEC=COS(ALAT(NY,NX)*1.7453E-02)*COS(DECLIN*1.7453E-02)
      IF(AZI/DEC.GE.1.0-TWILGT)THEN
      DYLM(NY,NX)=24.0
      ELSEIF(AZI/DEC.LE.-1.0+TWILGT)THEN
      DYLM(NY,NX)=0.0
      ELSE
      DYLM(NY,NX)=12.0*(1.0+2.0/3.1416*ASIN(TWILGT+AZI/DEC))
      ENDIF
9890  CONTINUE
9895  CONTINUE
C
C     READ TOPOGRAPHY DATA AND SOIL FILE NAME FOR EACH GRID CELL
C
C     for each unit within the landscape:
C     NH1,NV1,NH2,NV2=NW,SE column,row
C     ASPX=N,E,S,W aspect (o)
C     SL1,SL2=EW,NS slope (o)
C     DPTHSX=initial snowpack depth
C
50    READ(7,*,END=20)NH1,NV1,NH2,NV2,ASPX,SL0,SLX,DPTHSX
      READ(7,52)DATA(7)
52    FORMAT(A16)
C
C     OPEN AND READ SOIL FILE
C
      OPEN(9,FILE=TRIM(PREFIX)//DATA(7),STATUS='OLD')
      DO 9995 NX=NH1,NH2
      DO 9990 NY=NV1,NV2
C
C     SURFACE SLOPES AND ASPECTS
C
      ASP(NY,NX)=ASPX
      SL(NY,NX)=SL0
      DPTHS(NY,NX)=DPTHSX
C
C     CONVERT ASPECT TO GEOMETRIC FORMAT
C
      ASP(NY,NX)=450.0-ASP(NY,NX)
      IF(ASP(NY,NX).GE.360.0)ASP(NY,NX)=ASP(NY,NX)-360.0
C
C     SURFACE PROPERTIES
C
C     PSIFC,PSIWP=water potentials at field capacity,wilting point (MPa)
C     ALBS=wet soil albedo
C     PH=litter pH
C     RSC,RSC,RSP=C,N,P in fine(1,0),woody(0,0),manure(2,0) surface litter (g m-2)
C     IXTYP=surface litter type:1=plant,2=manure
C     NUI,NJ=number of soil surface layer,maximum rooting layer
C     NL1,NL2=number of additional layers below NJ with,without data in file
C     ISOILR=natural(0),reconstructed(1) soil profile
C
      READ(9,*)PSIFC(NY,NX),PSIWP(NY,NX),ALBS(NY,NX),PH(0,NY,NX)
     2,RSC(1,0,NY,NX),RSN(1,0,NY,NX),RSP(1,0,NY,NX)
     3,RSC(0,0,NY,NX),RSN(0,0,NY,NX),RSP(0,0,NY,NX)
     4,RSC(2,0,NY,NX),RSN(2,0,NY,NX),RSP(2,0,NY,NX)
     5,IXTYP(1,NY,NX),IXTYP(2,NY,NX)
     6,NUI(NY,NX),NJ(NY,NX),NL1,NL2,ISOILR(NY,NX)
      NU(NY,NX)=NUI(NY,NX)
      NK(NY,NX)=NJ(NY,NX)+1
      NM(NY,NX)=NJ(NY,NX)+NL1
      NLI(NY,NX)=NM(NY,NX)+NL2
      NL(NY,NX)=NLI(NY,NX)
C
C     PHYSICAL PROPERTIES
C
C     CDPTH=depth to bottom (m)
C     BKDSI=initial bulk density (Mg m-3,0=water)
C
      READ(9,*)(CDPTH(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(BKDSI(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
C
C     HYDROLOGIC PROPERTIES
C
C     FC,WP=field capacity,wilting point:<0=unknown (m3 m-3)
C     SCNV,SCNH=vertical,lateral Ksat:<0=unknown (mm h-1)
C
      READ(9,*)(FC(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(WP(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(SCNV(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(SCNH(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
C
C     PHYSICAL PROPERTIES
C
C     CSAND,CSILT=sand,silt contents (kg Mg-1)
C     FHOL,ROCK=macropore,rock fraction
C
      READ(9,*)(CSAND(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CSILT(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(FHOL(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(ROCK(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
C
C     CHEMICAL PROPERTIES
C
C     PH=pH
C     CEC,AEC=cation,anion exchange capacity:CEC<0=unknown (cmol Kg-1)
C
      READ(9,*)(PH(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CEC(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(AEC(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
C
C     ORGANIC C, N AND P CONCENTRATIONS
C
C     CORGC,CORGR=total SOC,POC(part of SOC) (kg Mg-1)
C     CORGN,CORGP=SON,SOP:<0=unknown (g Mg-1)
C
      READ(9,*)(CORGC(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CORGR(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CORGN(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CORGP(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
C
C     INORGANIC N AND P CONCENTRATIONS
C
C     CNH4,CNO3,CPO4=soluble+exchangeable NH4,NO3,H2PO4 (g Mg-1)
C
      READ(9,*)(CNH4(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CNO3(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CPO4(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
C
C     CATION AND ANION CONCENTRATIONS
C
C     C*=soluble concentration from sat. paste extract (g Mg-1)
C     AL,FE,CA,MG,NA,KA,SO4,CL=Al,Fe,Ca,Mg,Na,K,SO4-S,Cl
C
      READ(9,*)(CAL(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CFE(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CCA(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CMG(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CNA(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CKA(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CSO4(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CCL(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
C
C     PRECIPITATED MINERAL CONCENTRATIONS
C
C     CALPO,CFEPO,CCAPD,CCAPH=AlPO4,FePO4,CaHPO4,apatite (g Mg-1)
C     CALOH,CFEOH,CCACO,CCASO=AlOH3,FeOH3,CaSO4,CaCO3 (g Mg-1)
C
      READ(9,*)(CALPO(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CFEPO(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CCAPD(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CCAPH(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CALOH(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CFEOH(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CCACO(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(CCASO(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
C
C     GAPON SELECTIVITY CO-EFFICIENTS
C
C     GKC4,GKCH,GKCA,GKCM,GKCN,GKCK=Gapon selectivity coefficients for
C     Ca-NH4,Ca-H,Ca-Al,Ca-Mg,Ca-Na,Ca-K
C
      READ(9,*)(GKC4(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(GKCH(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(GKCA(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(GKCM(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(GKCN(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(GKCK(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
C
C     INITIAL WATER, ICE CONTENTS
C
      READ(9,*)(THW(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(THI(L,NY,NX),L=NU(NY,NX),NM(NY,NX))
C
C     THW,THI=initial water,ice:>1=satd,1=FC,0=WP,<0=0,0-1=m3 m-3
C
C     INITIAL PLANT AND ANIMAL RESIDUE C, N AND P
C
C     RSC,RSC,RSP=C,N,P in fine(1),woody(0),manure(2) litter (g m-2)
C
      READ(9,*)(RSC(1,L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(RSN(1,L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(RSP(1,L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(RSC(0,L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(RSN(0,L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(RSP(0,L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(RSC(2,L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(RSN(2,L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      READ(9,*)(RSP(2,L,NY,NX),L=NU(NY,NX),NM(NY,NX))
      REWIND(9)
      RSC(1,0,NY,NX)=AMAX1(1.0E-06,RSC(1,0,NY,NX))
      RSN(1,0,NY,NX)=AMAX1(0.04E-06,RSN(1,0,NY,NX))
      RSP(1,0,NY,NX)=AMAX1(0.004E-06,RSP(1,0,NY,NX))
      SCNV(0,NY,NX)=10.0*0.098
C
C     SET FLAGS FOR ESTIMATING FC,WP,SCNV,SCNH IF UNKNOWN
C
C     ISOIL=flag for calculating FC(1),WP(2),SCNV(3),SCNH(4)
C
      DO 25 L=NU(NY,NX),NM(NY,NX)
      IF(FC(L,NY,NX).LT.0.0)THEN
      ISOIL(1,L,NY,NX)=1
      PSIFC(NY,NX)=-0.033
      ELSE
      ISOIL(1,L,NY,NX)=0
      ENDIF
      IF(WP(L,NY,NX).LT.0.0)THEN
      ISOIL(2,L,NY,NX)=1
      PSIWP(NY,NX)=-1.5
      ELSE
      ISOIL(2,L,NY,NX)=0
      ENDIF
      IF(SCNV(L,NY,NX).LT.0.0)THEN
      ISOIL(3,L,NY,NX)=1
      ELSE
      ISOIL(3,L,NY,NX)=0
      ENDIF
      IF(SCNH(L,NY,NX).LT.0.0)THEN
      ISOIL(4,L,NY,NX)=1
      ELSE
      ISOIL(4,L,NY,NX)=0
      ENDIF
25    CONTINUE
C
C     FILL OUT SOIL BOUNDARY LAYERS ABOVE ROOTING ZONE (NOT USED)
C
      IF(NU(NY,NX).GT.1)THEN
      DO 31 L=NU(NY,NX)-1,0,-1
      IF(BKDSI(L+1,NY,NX).GT.0.025)THEN
      CDPTH(L,NY,NX)=CDPTH(L+1,NY,NX)-0.01
      ELSE
      CDPTH(L,NY,NX)=CDPTH(L+1,NY,NX)-0.02
      ENDIF
      IF(L.GT.0)THEN
      BKDSI(L,NY,NX)=BKDSI(L+1,NY,NX)
      FC(L,NY,NX)=FC(L+1,NY,NX)
      WP(L,NY,NX)=WP(L+1,NY,NX)
      SCNV(L,NY,NX)=SCNV(L+1,NY,NX)
      SCNH(L,NY,NX)=SCNH(L+1,NY,NX)
      CSAND(L,NY,NX)=CSAND(L+1,NY,NX)
      CSILT(L,NY,NX)=CSILT(L+1,NY,NX)
      CCLAY(L,NY,NX)=CCLAY(L+1,NY,NX)
      FHOL(L,NY,NX)=FHOL(L+1,NY,NX)
      ROCK(L,NY,NX)=ROCK(L+1,NY,NX)
      PH(L,NY,NX)=PH(L+1,NY,NX)
      CEC(L,NY,NX)=CEC(L+1,NY,NX)
      AEC(L,NY,NX)=AEC(L+1,NY,NX)
      CORGC(L,NY,NX)=1.00*CORGC(L+1,NY,NX)
      CORGR(L,NY,NX)=1.00*CORGR(L+1,NY,NX)
      CORGN(L,NY,NX)=1.00*CORGN(L+1,NY,NX)
      CORGP(L,NY,NX)=1.00*CORGP(L+1,NY,NX)
      CNH4(L,NY,NX)=CNH4(L+1,NY,NX)
      CNO3(L,NY,NX)=CNO3(L+1,NY,NX)
      CPO4(L,NY,NX)=CPO4(L+1,NY,NX)
      CAL(L,NY,NX)=CAL(L+1,NY,NX)
      CFE(L,NY,NX)=CFE(L+1,NY,NX)
      CCA(L,NY,NX)=CCA(L+1,NY,NX)
      CMG(L,NY,NX)=CMG(L+1,NY,NX)
      CNA(L,NY,NX)=CNA(L+1,NY,NX)
      CKA(L,NY,NX)=CKA(L+1,NY,NX)
      CSO4(L,NY,NX)=CSO4(L+1,NY,NX)
      CCL(L,NY,NX)=CCL(L+1,NY,NX)
      CALOH(L,NY,NX)=CALOH(L+1,NY,NX)
      CFEOH(L,NY,NX)=CFEOH(L+1,NY,NX)
      CCACO(L,NY,NX)=CCACO(L+1,NY,NX)
      CCASO(L,NY,NX)=CCASO(L+1,NY,NX)
      CALPO(L,NY,NX)=CALPO(L+1,NY,NX)
      CFEPO(L,NY,NX)=CFEPO(L+1,NY,NX)
      CCAPD(L,NY,NX)=CCAPD(L+1,NY,NX)
      CCAPH(L,NY,NX)=CCAPH(L+1,NY,NX)
      GKC4(L,NY,NX)=GKC4(L+1,NY,NX)
      GKCH(L,NY,NX)=GKCH(L+1,NY,NX)
      GKCA(L,NY,NX)=GKCA(L+1,NY,NX)
      GKCM(L,NY,NX)=GKCM(L+1,NY,NX)
      GKCN(L,NY,NX)=GKCN(L+1,NY,NX)
      GKCK(L,NY,NX)=GKCK(L+1,NY,NX)
      THW(L,NY,NX)=THW(L+1,NY,NX)
      THI(L,NY,NX)=THI(L+1,NY,NX)
      ISOIL(1,L,NY,NX)=ISOIL(1,L+1,NY,NX)
      ISOIL(2,L,NY,NX)=ISOIL(2,L+1,NY,NX)
      ISOIL(3,L,NY,NX)=ISOIL(3,L+1,NY,NX)
      ISOIL(4,L,NY,NX)=ISOIL(4,L+1,NY,NX)
      RSC(1,L,NY,NX)=0.0
      RSN(1,L,NY,NX)=0.0
      RSP(1,L,NY,NX)=0.0
      RSC(0,L,NY,NX)=0.0
      RSN(0,L,NY,NX)=0.0
      RSP(0,L,NY,NX)=0.0
      RSC(2,L,NY,NX)=0.0
      RSN(2,L,NY,NX)=0.0
      RSP(2,L,NY,NX)=0.0
      ENDIF
31    CONTINUE
      ENDIF
C
C     ADD SOIL BOUNDARY LAYERS BELOW SOIL ZONE
C
      DO 32 L=NM(NY,NX)+1,JZ
      CDPTH(L,NY,NX)=2.0*CDPTH(L-1,NY,NX)-1.0*CDPTH(L-2,NY,NX)
      BKDSI(L,NY,NX)=BKDSI(L-1,NY,NX)
      FC(L,NY,NX)=FC(L-1,NY,NX)
      WP(L,NY,NX)=WP(L-1,NY,NX)
      SCNV(L,NY,NX)=SCNV(L-1,NY,NX)
      SCNH(L,NY,NX)=SCNH(L-1,NY,NX)
      CSAND(L,NY,NX)=CSAND(L-1,NY,NX)
      CSILT(L,NY,NX)=CSILT(L-1,NY,NX)
      CCLAY(L,NY,NX)=CCLAY(L-1,NY,NX)
      FHOL(L,NY,NX)=FHOL(L-1,NY,NX)
      ROCK(L,NY,NX)=ROCK(L-1,NY,NX)
      PH(L,NY,NX)=PH(L-1,NY,NX)
      CEC(L,NY,NX)=CEC(L-1,NY,NX)
      AEC(L,NY,NX)=AEC(L-1,NY,NX)
C     IF(IDTBL(NY,NX).EQ.0)THEN
      CORGC(L,NY,NX)=0.25*CORGC(L-1,NY,NX)
      CORGR(L,NY,NX)=0.25*CORGR(L-1,NY,NX)
      CORGN(L,NY,NX)=0.25*CORGN(L-1,NY,NX)
      CORGP(L,NY,NX)=0.25*CORGP(L-1,NY,NX)
C     ELSE
C     CORGC(L,NY,NX)=CORGC(L-1,NY,NX)
C     CORGR(L,NY,NX)=CORGR(L-1,NY,NX)
C     CORGN(L,NY,NX)=CORGN(L-1,NY,NX)
C     CORGP(L,NY,NX)=CORGP(L-1,NY,NX)
C     ENDIF
      CNH4(L,NY,NX)=CNH4(L-1,NY,NX)
      CNO3(L,NY,NX)=CNO3(L-1,NY,NX)
      CPO4(L,NY,NX)=CPO4(L-1,NY,NX)
      CAL(L,NY,NX)=CAL(L-1,NY,NX)
      CFE(L,NY,NX)=CFE(L-1,NY,NX)
      CCA(L,NY,NX)=CCA(L-1,NY,NX)
      CMG(L,NY,NX)=CMG(L-1,NY,NX)
      CNA(L,NY,NX)=CNA(L-1,NY,NX)
      CKA(L,NY,NX)=CKA(L-1,NY,NX)
      CSO4(L,NY,NX)=CSO4(L-1,NY,NX)
      CCL(L,NY,NX)=CCL(L-1,NY,NX)
      CALOH(L,NY,NX)=CALOH(L-1,NY,NX)
      CFEOH(L,NY,NX)=CFEOH(L-1,NY,NX)
      CCACO(L,NY,NX)=CCACO(L-1,NY,NX)
      CCASO(L,NY,NX)=CCASO(L-1,NY,NX)
      CALPO(L,NY,NX)=CALPO(L-1,NY,NX)
      CFEPO(L,NY,NX)=CFEPO(L-1,NY,NX)
      CCAPD(L,NY,NX)=CCAPD(L-1,NY,NX)
      CCAPH(L,NY,NX)=CCAPH(L-1,NY,NX)
      GKC4(L,NY,NX)=GKC4(L-1,NY,NX)
      GKCH(L,NY,NX)=GKCH(L-1,NY,NX)
      GKCA(L,NY,NX)=GKCA(L-1,NY,NX)
      GKCM(L,NY,NX)=GKCM(L-1,NY,NX)
      GKCN(L,NY,NX)=GKCN(L-1,NY,NX)
      GKCK(L,NY,NX)=GKCK(L-1,NY,NX)
      THW(L,NY,NX)=THW(L-1,NY,NX)
      THI(L,NY,NX)=THI(L-1,NY,NX)
      ISOIL(1,L,NY,NX)=ISOIL(1,L-1,NY,NX)
      ISOIL(2,L,NY,NX)=ISOIL(2,L-1,NY,NX)
      ISOIL(3,L,NY,NX)=ISOIL(3,L-1,NY,NX)
      ISOIL(4,L,NY,NX)=ISOIL(4,L-1,NY,NX)
      RSC(1,L,NY,NX)=0.0
      RSN(1,L,NY,NX)=0.0
      RSP(1,L,NY,NX)=0.0
      RSC(0,L,NY,NX)=0.0
      RSN(0,L,NY,NX)=0.0
      RSP(0,L,NY,NX)=0.0
      RSC(2,L,NY,NX)=0.0
      RSN(2,L,NY,NX)=0.0
      RSP(2,L,NY,NX)=0.0
32    CONTINUE
C
C     CALCULATE DERIVED SOIL PROPERTIES FROM INPUT SOIL PROPERTIES
C
C     FMPR=micropore fraction excluding macropore,rock
C     SCNV,SCNH=vertical,lateral Ksat converted to m2 MPa-1 h-1
C     CSAND,CSILT,CCLAY=sand,silt,clay content converted to g Mg-1
C     CORGC,CORGR=SOC,POC converted to g Mg-1
C     CEC,AEC=cation,anion exchange capacity converted to mol Mg-1
C     CNH4...=solute concentrations converted to mol Mg-1
C
      DO 28 L=1,NL(NY,NX)
C     BKDSI(L,NY,NX)=BKDSI(L,NY,NX)/(1.0-FHOL(L,NY,NX))
      BKDS(L,NY,NX)=BKDSI(L,NY,NX)
      IF(BKDS(L,NY,NX).EQ.0.0)FHOL(L,NY,NX)=0.0
      FMPR(L,NY,NX)=(1.0-ROCK(L,NY,NX))*(1.0-FHOL(L,NY,NX))
C     FC(L,NY,NX)=FC(L,NY,NX)/(1.0-FHOL(L,NY,NX))
C     WP(L,NY,NX)=WP(L,NY,NX)/(1.0-FHOL(L,NY,NX))
      SCNV(L,NY,NX)=0.098*SCNV(L,NY,NX)*FMPR(L,NY,NX)
      SCNH(L,NY,NX)=0.098*SCNH(L,NY,NX)*FMPR(L,NY,NX)
      CCLAY(L,NY,NX)=AMAX1(0.0,1.0E+03-(CSAND(L,NY,NX)
     2+CSILT(L,NY,NX)))
      CORGC(L,NY,NX)=CORGC(L,NY,NX)*1.0E+03
      CORGR(L,NY,NX)=CORGR(L,NY,NX)*1.0E+03
      CORGCI(L,NY,NX)=CORGC(L,NY,NX)
      FHOLI(L,NY,NX)=FHOL(L,NY,NX)
      CSAND(L,NY,NX)=CSAND(L,NY,NX)
     2*1.0E-03*AMAX1(0.0,(1.0-CORGC(L,NY,NX)/0.55E+06))
      CSILT(L,NY,NX)=CSILT(L,NY,NX)
     2*1.0E-03*AMAX1(0.0,(1.0-CORGC(L,NY,NX)/0.55E+06))
      CCLAY(L,NY,NX)=CCLAY(L,NY,NX)
     2*1.0E-03*AMAX1(0.0,(1.0-CORGC(L,NY,NX)/0.55E+06))
      CEC(L,NY,NX)=CEC(L,NY,NX)*10.0
      AEC(L,NY,NX)=AEC(L,NY,NX)*10.0
      CNH4(L,NY,NX)=CNH4(L,NY,NX)/14.0
      CNO3(L,NY,NX)=CNO3(L,NY,NX)/14.0
      CPO4(L,NY,NX)=CPO4(L,NY,NX)/31.0
      CAL(L,NY,NX)=CAL(L,NY,NX)/27.0
      CFE(L,NY,NX)=CFE(L,NY,NX)/56.0
      CCA(L,NY,NX)=CCA(L,NY,NX)/40.0
      CMG(L,NY,NX)=CMG(L,NY,NX)/24.3
      CNA(L,NY,NX)=CNA(L,NY,NX)/23.0
      CKA(L,NY,NX)=CKA(L,NY,NX)/39.1
      CSO4(L,NY,NX)=CSO4(L,NY,NX)/32.0
      CCL(L,NY,NX)=CCL(L,NY,NX)/35.5
      CALPO(L,NY,NX)=CALPO(L,NY,NX)/31.0
      CFEPO(L,NY,NX)=CFEPO(L,NY,NX)/31.0
      CCAPD(L,NY,NX)=CCAPD(L,NY,NX)/31.0
      CCAPH(L,NY,NX)=CCAPH(L,NY,NX)/(31.0*3.0)
      CALOH(L,NY,NX)=CALOH(L,NY,NX)/27.0
      CFEOH(L,NY,NX)=CFEOH(L,NY,NX)/56.0
      CCACO(L,NY,NX)=CCACO(L,NY,NX)/40.0
      CCASO(L,NY,NX)=CCASO(L,NY,NX)/40.0
C
C     ESTIMATE SON,SOP,CEC IF UNKNOWN
C     BIOCHEMISTRY 130:117-131
C
      IF(CORGN(L,NY,NX).LT.0.0)THEN
      CORGN(L,NY,NX)=AMIN1(0.125*CORGC(L,NY,NX)
     2,8.9E+02*(CORGC(L,NY,NX)/1.0E+04)**0.80)
C     WRITE(*,1111)'CORGN',L,CORGN(L,NY,NX),CORGC(L,NY,NX)
      ENDIF
      IF(CORGP(L,NY,NX).LT.0.0)THEN
      CORGP(L,NY,NX)=AMIN1(0.0125*CORGC(L,NY,NX)
     2,1.2E+02*(CORGC(L,NY,NX)/1.0E+04)**0.52)
C     WRITE(*,1111)'CORGP',L,CORGP(L,NY,NX),CORGC(L,NY,NX)
      ENDIF
      IF(CEC(L,NY,NX).LT.0.0)THEN
      CEC(L,NY,NX)=10.0*(200.0*2.0*CORGC(L,NY,NX)/1.0E+06
     2+80.0*CCLAY(L,NY,NX)+20.0*CSILT(L,NY,NX)
     3+5.0*CSAND(L,NY,NX))
      ENDIF
28    CONTINUE
      CORGC(0,NY,NX)=0.55E+06
      FMPR(0,NY,NX)=1.0
9990  CONTINUE
9995  CONTINUE
      CLOSE(9)
      GO TO 50
20    CONTINUE
      CLOSE(7)
      DO 9975 NX=NHW,NHE
      NL(NVS+1,NX)=NL(NVS,NX)
C     WRITE(*,2223)'NHE',NX,NHW,NHE,NVS,NL(NVS,NX)
9975  CONTINUE
      DO 9970 NY=NVN,NVS
      NL(NY,NHE+1)=NL(NY,NHE)
C     WRITE(*,2223)'NVS',NY,NVN,NVS,NHE,NL(NY,NHE)
2223  FORMAT(A8,6I4)
9970  CONTINUE
      NL(NVS+1,NHE+1)=NL(NVS,NHE)
      IOLD=0
      RETURN
      END


!
!***********************************************************************
!                                                                      *
      MODULE terms_C
!                                                                      *
!***********************************************************************
!...Created by Pacific-Sierra Research 77to90  4.3E  06:16:25   2/14/04
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
      implicit none
      INTEGER, DIMENSION(31) :: ITAB
      INTEGER, DIMENSION(32) :: JTAB
      INTEGER, DIMENSION(327) :: NTAB
      INTEGER :: NROWS
      INTEGER, PRIVATE :: i
      DATA NROWS/ 31/
!
!   A row is defined by a subshell angular momentum and an occupation
!   number
!
!   Each entry ITAB gives the number of terms in a row
!
!   Each entry JTAB gives the starting location -1 of the first triad
!   in a row
!
!   Each triad in NTAB is (v,w,2J+1); here v is the seniority,
!   w resolves any degeneracy in the seniority scheme, and J is the
!   subshell total angular momentum
!
!   Empty subshell or full subshell
!
      DATA (ITAB(I),I=1,1)/ 1/
      DATA (JTAB(I),I=1,1)/ 0/
      DATA (NTAB(I),I=1,3)/ 0, 0, 1/
!
!   s, p-   (j = 1/2)
!
      DATA (ITAB(I),I=2,2)/ 1/
      DATA (JTAB(I),I=2,2)/ 3/
      DATA (NTAB(I),I=4,6)/ 1, 0, 2/
!
!   p, d-   (j = 3/2)
!
      DATA (ITAB(I),I=3,4)/ 1, 2/
      DATA (JTAB(I),I=3,4)/ 6, 9/
      DATA (NTAB(I),I=7,15)/ 1, 0, 4, 0, 0, 1, 2, 0, 5/
!
!  d, f-   (j = 5/2)
!
      DATA (ITAB(I),I=5,7)/ 1, 3, 3/
      DATA (JTAB(I),I=5,7)/ 15, 18, 27/
      DATA (NTAB(I),I=16,36)/ 1, 0, 6, 0, 0, 1, 2, 0, 5, 2, 0, 9, 1, 0, 6, 3, 0&
         , 4, 3, 0, 10/
!
!   f, g-   (j = 7/2)
!
      DATA (ITAB(I),I=8,11)/ 1, 4, 6, 8/
      DATA (JTAB(I),I=8,11)/ 36, 39, 51, 69/
      DATA (NTAB(I),I=37,93)/ 1, 0, 8, 0, 0, 1, 2, 0, 5, 2, 0, 9, 2, 0, 13, 1, &
         0, 8, 3, 0, 4, 3, 0, 6, 3, 0, 10, 3, 0, 12, 3, 0, 16, 0, 0, 1, 2, 0, 5&
         , 2, 0, 9, 2, 0, 13, 4, 0, 5, 4, 0, 9, 4, 0, 11, 4, 0, 17/
!
!   g, h-   (j = 9/2)
!
      DATA (ITAB(I),I=12,16)/ 1, 5, 10, 18, 20/
      DATA (JTAB(I),I=12,16)/ 93, 96, 111, 141, 195/
      DATA (NTAB(I),I=94,255)/ 1, 0, 10, 0, 0, 1, 2, 0, 5, 2, 0, 9, 2, 0, 13, 2&
         , 0, 17, 1, 0, 10, 3, 0, 4, 3, 0, 6, 3, 0, 8, 3, 0, 10, 3, 0, 12, 3, 0&
         , 14, 3, 0, 16, 3, 0, 18, 3, 0, 22, 0, 0, 1, 2, 0, 5, 2, 0, 9, 2, 0, &
         13, 2, 0, 17, 4, 0, 1, 4, 0, 5, 4, 0, 7, 4, 0, 9, 4, 1, 9, 4, 0, 11, 4&
         , 0, 13, 4, 1, 13, 4, 0, 15, 4, 0, 17, 4, 0, 19, 4, 0, 21, 4, 0, 25, 1&
         , 0, 10, 3, 0, 4, 3, 0, 6, 3, 0, 8, 3, 0, 10, 3, 0, 12, 3, 0, 14, 3, 0&
         , 16, 3, 0, 18, 3, 0, 22, 5, 0, 2, 5, 0, 6, 5, 0, 8, 5, 0, 10, 5, 0, &
         12, 5, 0, 14, 5, 0, 16, 5, 0, 18, 5, 0, 20, 5, 0, 26/
!
!   h, i-   (j = 11/2)
!
!   h, i-   (j = 11/2)
!
!   First two rows only
!
      DATA (ITAB(I),I=17,18)/ 1, 6/
      DATA (JTAB(I),I=17,19)/ 255, 258, 277/
      DATA (NTAB(I),I=256,276)/ 1, 0, 12, 0, 0, 1, 2, 0, 5, 2, 0, 9, 2, 0, 13, &
         2, 0, 17, 2, 0, 21/
!
!   i, k-   (j = 13/2)
!
!   First two rows only
!
      DATA (ITAB(I),I=23,24)/ 1, 7/
      DATA (JTAB(I),I=23,25)/ 276, 279, 301/
      DATA (NTAB(I),I=277,300)/ 1, 0, 14, 0, 0, 1, 2, 0, 5, 2, 0, 9, 2, 0, 13, &
         2, 0, 17, 2, 0, 21, 2, 0, 25/
!
!   k, l-   (j = 15/2)
!
!   First two rows only
!
      DATA (ITAB(I),I=30,31)/ 1, 8/
      DATA (JTAB(I),I=30,32)/ 300, 303, 328/
      DATA (NTAB(I),I=301,327)/ 1, 0, 16, 0, 0, 1, 2, 0, 5, 2, 0, 9, 2, 0, 13, &
         2, 0, 17, 2, 0, 21, 2, 0, 25, 2, 0, 29/
      END MODULE terms_C


      SUBROUTINE PHO_SELCOL(Ico1,Ico2,Icoa1,Icoa2,Icob1,Icob2,Imode)
C********************************************************************
C
C    color combinatorics
C
C    input:         ICO1,2   colors of incoming particle
C                   IMODE    -2  output of initialization status
C                            -1  initialization
C                                   ICINP(1) selection mode
C                                            0   QCD
C                                            1   large N_c expansion
C                                   ICINP(2) max. allowed color
C                            0   clear internal color counter
C                            1   hadron into two colored objects
C                            2   quark into quark gluon
C                            3   gluon into gluon gluon
C                            4   gluon into quark antiquark
C
C    output:        ICOA1,2  colors of first outgoing particle
C                   ICOB1,2  colors of second outgoing particle
C
C********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION DT_RNDM , dum
      INTEGER ici1 , ici2 , Ico1 , Ico2 , Icoa1 , Icoa2 , Icob1 ,
     &        Icob2 , ii , Imode , maxcol , method
      SAVE

C  input/output channels
      INCLUDE 'inc/poinou'
C  event debugging information
      INCLUDE 'inc/podebg'

      DATA method/0/ , ii/0/

      ici1 = Ico1
      ici2 = Ico2
      IF ( method.NE.0 ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,I5)')
     &         'PHO_SELCOL:ERROR:unsupported method selected' , method
         CALL PHO_ABORT

      ELSE IF ( Imode.EQ.1 ) THEN
         ii = ii + 1
         IF ( ii.GT.maxcol )
     &        ii = INT(MIN(DT_RNDM(dum)*DBLE(maxcol)+1.00001D+00,
     &        DBLE(maxcol)))
         Icoa1 = ii
         Icoa2 = 0
         Icob1 = -ii
         Icob2 = 0
      ELSE IF ( Imode.EQ.2 ) THEN
         ii = ii + 1
         IF ( ii.GT.maxcol )
     &        ii = INT(MIN(DT_RNDM(dum)*DBLE(maxcol)+1.00001D+00,
     &        DBLE(maxcol)))
         Icoa2 = 0
         IF ( ici1.GT.0 ) THEN
            Icoa1 = ii
            Icob1 = ici1
            Icob2 = -ii
         ELSE
            Icoa1 = -ii
            Icob1 = ii
            Icob2 = ici1
         END IF
      ELSE IF ( Imode.EQ.3 ) THEN
         ii = ii + 1
         IF ( ii.GT.maxcol )
     &        ii = INT(MIN(DT_RNDM(dum)*DBLE(maxcol)+1.00001D+00,
     &        DBLE(maxcol)))
         IF ( DT_RNDM(dum).GT.0.5D0 ) THEN
            Icoa1 = ici1
            Icoa2 = -ii
            Icob1 = ii
            Icob2 = ici2
         ELSE
            Icob1 = ici1
            Icob2 = -ii
            Icoa1 = ii
            Icoa2 = ici2
         END IF
      ELSE IF ( Imode.EQ.4 ) THEN
         Icoa1 = ici1
         Icoa2 = 0
         Icob1 = ici2
         Icob2 = 0
      ELSE IF ( Imode.EQ.0 ) THEN
         ii = 0
      ELSE IF ( Imode.EQ.-1 ) THEN
         method = ici1
         maxcol = ici2
      ELSE IF ( Imode.EQ.-2 ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,2I5)')
     &         'PHO_SELCOL: METHOD,MAXCOL' , method , maxcol
      ELSE
         IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,I5)')
     &         'PHO_SELCOL:ERROR: unsupported mode' , Imode
         CALL PHO_ABORT

      END IF

      ii = ABS(ii)
      IF ( IDEb(75).GE.10 ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,'(1X,A,I5,I12,I5)')
     &         'PHO_SELCOL: IMODE,MAXCOL,II' , Imode , maxcol , ii
         IF ( LPRi.GT.4 ) WRITE (LO,'(10X,A,2I5)') 'input  colors' ,
     &        ici1 , ici2
         IF ( LPRi.GT.4 ) WRITE (LO,'(10X,A,4I5)') 'output colors' ,
     &        Icoa1 , Icoa2 , Icob1 , Icob2
      END IF

      END SUBROUTINE


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     Subroutine egrad_water: Calculates energy and gradient of a box
!      of water molecules with the flexible SPC water model
!
!     part of EVB
!

subroutine egrad_water(xyz_act,g_act,e_act)
use evb_mod
use general
use qmdff
implicit none
!     Loop indices
integer::i,j
!     The current coordinates (bohr)
real(kind=8),intent(in)::xyz_act(3,natoms)
!     The calculated gradient (hartree/bohr)
real(kind=8),intent(out)::g_act(3,natoms)
!     The calculated energy (hartree)
real(kind=8),intent(out)::e_act
integer::i_O,i_H1,i_H2
!     The flexible SPC parameters
real(kind=8)::r_zero,theta_0,d_e,a_par,k_theta,k_rtheta
real(kind=8)::k_rr,e_H,e_O,sigma_OO,eps_OO,r_0HH
real(kind=8)::OH1_vec(3),OH2_vec(3),HH_vec(3)  ! the current distance vectors
real(kind=8)::dist_vec(3)
real(kind=8)::r_OH1,r_OH2,r_HH,rij  ! the current distances
real(kind=8)::dr_OH1,dr_OH2,dr_HH ! the current distance deviations from minimum
real(kind=8)::oner,sigr6
real(kind=8)::exp1,exp2,de1,de2,e0
real(kind=8)::g_vec(3)
real(kind=8)::g_local_a(3),g_local_b(3)  ! for virial tensor
!
!     Initialize the local parameters
!
r_zero=water_pars(1)
r_0HH=water_pars(2)
d_e=water_pars(3)
a_par=water_pars(4)
k_theta=water_pars(5)
k_rtheta=water_pars(6)
k_rr=water_pars(7)
e_H=water_pars(8)
e_O=water_pars(9)
sigma_OO=water_pars(10)
eps_OO=water_pars(11)

!
!     First, calculate the intramolecular energy part
!
e_act=0.d0
g_act=0.d0
do i=1,nwater
   i_O=(i-1)*3+1
   i_H1=(i-1)*3+2
   i_H2=(i-1)*3+3
!
!     Calculate all needed distances between the atoms
!
   OH1_vec=xyz_act(:,i_O)-xyz_act(:,i_H1)
   if (periodic) then
      call box_image(OH1_vec)
   end if
   OH2_vec=xyz_act(:,i_O)-xyz_act(:,i_H2)
   if (periodic) then
      call box_image(OH2_vec)
   end if
   HH_vec=xyz_act(:,i_H1)-xyz_act(:,i_H2)
   if (periodic) then
      call box_image(HH_vec)
   end if
   r_OH1=sqrt(dot_product(OH1_vec,OH1_vec))
   dr_OH1=r_OH1-r_zero
   r_OH2=sqrt(dot_product(OH2_vec,OH2_vec))
   dr_OH2=r_OH2-r_zero
   r_HH=sqrt(dot_product(HH_vec,HH_vec))
   dr_HH=r_HH-r_0HH

!
!     Calculate the OH bond stretches (Morse potentials)
!
   exp1=exp(a_par*dr_OH1)
   exp2=exp(a_par*dr_OH2)

   e_act=e_act+d_e*(1.d0-exp1)**2
   e_act=e_act+d_e*(1.d0-exp2)**2
!
!     Calculate gradients of OH bond stretches
!
   de1=-2d0*a_par*d_e*exp1*(1.d0-exp1)/r_OH1

   g_local_a(:)=de1*OH1_vec(:)
   g_act(:,i_H1)=g_act(:,i_H1)-g_local_a(:)
   g_act(:,i_O)=g_act(:,i_O)+g_local_a(:)

!
!     the components of the virial tensor, if needed
!
   if (calc_vir) then
      vir_ten(1,1)=vir_ten(1,1)+OH1_vec(1)*g_local_a(1)
      vir_ten(2,1)=vir_ten(2,1)+OH1_vec(2)*g_local_a(1)
      vir_ten(3,1)=vir_ten(3,1)+OH1_vec(3)*g_local_a(1)
      vir_ten(1,2)=vir_ten(1,2)+OH1_vec(1)*g_local_a(2)
      vir_ten(2,2)=vir_ten(2,2)+OH1_vec(2)*g_local_a(2)
      vir_ten(3,2)=vir_ten(3,2)+OH1_vec(3)*g_local_a(2)
      vir_ten(1,3)=vir_ten(1,3)+OH1_vec(1)*g_local_a(3)
      vir_ten(2,3)=vir_ten(2,3)+OH1_vec(2)*g_local_a(3)
      vir_ten(3,3)=vir_ten(3,3)+OH1_vec(3)*g_local_a(3)
   end if

   de2=-2d0*a_par*d_e*exp2*(1.d0-exp2)/r_OH2

   g_local_a(:)=de2*OH2_vec(:)
   g_act(:,i_H2)=g_act(:,i_H2)-g_local_a(:)
   g_act(:,i_O)=g_act(:,i_O)+g_local_a(:)

!
!     the components of the virial tensor, if needed
!
   if (calc_vir) then
      vir_ten(1,1)=vir_ten(1,1)+OH2_vec(1)*g_local_a(1)
      vir_ten(2,1)=vir_ten(2,1)+OH2_vec(2)*g_local_a(1)
      vir_ten(3,1)=vir_ten(3,1)+OH2_vec(3)*g_local_a(1)
      vir_ten(1,2)=vir_ten(1,2)+OH2_vec(1)*g_local_a(2)
      vir_ten(2,2)=vir_ten(2,2)+OH2_vec(2)*g_local_a(2)
      vir_ten(3,2)=vir_ten(3,2)+OH2_vec(3)*g_local_a(2)
      vir_ten(1,3)=vir_ten(1,3)+OH2_vec(1)*g_local_a(3)
      vir_ten(2,3)=vir_ten(2,3)+OH2_vec(2)*g_local_a(3)
      vir_ten(3,3)=vir_ten(3,3)+OH2_vec(3)*g_local_a(3)
   end if

!
!     Calculate the HH bond stretch (Harmonic potential)
!

   e_act=e_act+0.5d0*k_theta*dr_HH**2

!
!     Gradients of the HH bond stretch
!
   g_local_a(:)=k_theta*(HH_vec(:))*dr_HH/r_HH

   g_act(:,i_H1)=g_act(:,i_H1)+g_local_a(:)
   g_act(:,i_H2)=g_act(:,i_H2)-g_local_a(:)

!
!     the components of the virial tensor, if needed
!

   if (calc_vir) then
      vir_ten(1,1)=vir_ten(1,1)+HH_vec(1)*g_local_a(1)
      vir_ten(2,1)=vir_ten(2,1)+HH_vec(2)*g_local_a(1)
      vir_ten(3,1)=vir_ten(3,1)+HH_vec(3)*g_local_a(1)
      vir_ten(1,2)=vir_ten(1,2)+HH_vec(1)*g_local_a(2)
      vir_ten(2,2)=vir_ten(2,2)+HH_vec(2)*g_local_a(2)
      vir_ten(3,2)=vir_ten(3,2)+HH_vec(3)*g_local_a(2)
      vir_ten(1,3)=vir_ten(1,3)+HH_vec(1)*g_local_a(3)
      vir_ten(2,3)=vir_ten(2,3)+HH_vec(2)*g_local_a(3)
      vir_ten(3,3)=vir_ten(3,3)+HH_vec(3)*g_local_a(3)
   end if

!
!     Calculate the bond-angle coupling term
!
   e_act=e_act+k_rtheta*dr_HH*(dr_OH1+dr_OH2)
!
!     Gradients of the bond-angle coupling term
!
   g_local_a(:)=dr_HH/r_OH1*OH1_vec(:)*k_rtheta
   g_local_b(:)=dr_HH/r_OH2*OH2_vec(:)*k_rtheta

   g_act(:,i_H1)=g_act(:,i_H1)+k_rtheta*2d0*dr_OH1/r_HH*HH_vec(:)- &
                    & g_local_a
   g_act(:,i_H2)=g_act(:,i_H2)-k_rtheta*2d0*dr_OH2/r_HH*HH_vec(:)- &
                    & g_local_b
   g_act(:,i_O)=g_act(:,i_O)+g_local_a + g_local_b

!
!     the components of the virial tensor, if needed
!
   if (calc_vir) then
      vir_ten(1,1)=vir_ten(1,1)+OH1_vec(1)*g_local_a(1)+OH2_vec(1)*g_local_b(1)
      vir_ten(2,1)=vir_ten(2,1)+OH1_vec(2)*g_local_a(1)+OH2_vec(2)*g_local_b(1)
      vir_ten(3,1)=vir_ten(3,1)+OH1_vec(3)*g_local_a(1)+OH2_vec(3)*g_local_b(1)
      vir_ten(1,2)=vir_ten(1,2)+OH1_vec(1)*g_local_a(2)+OH2_vec(1)*g_local_b(2)
      vir_ten(2,2)=vir_ten(2,2)+OH1_vec(2)*g_local_a(2)+OH2_vec(2)*g_local_b(2)
      vir_ten(3,2)=vir_ten(3,2)+OH1_vec(3)*g_local_a(2)+OH2_vec(3)*g_local_b(2)
      vir_ten(1,3)=vir_ten(1,3)+OH1_vec(1)*g_local_a(3)+OH2_vec(1)*g_local_b(3)
      vir_ten(2,3)=vir_ten(2,3)+OH1_vec(2)*g_local_a(3)+OH2_vec(2)*g_local_b(3)
      vir_ten(3,3)=vir_ten(3,3)+OH1_vec(3)*g_local_a(3)+OH2_vec(3)*g_local_b(3)
   end if

!
!     Calculate the bond-bond coupling term
!
   e_act=e_act+k_rr*dr_OH1*dr_OH2
!
!     Gradients of the bond-bond coupling term
!
   g_local_a(:)=k_rr*(dr_OH2/r_OH1*OH1_vec(:))
   g_local_b(:)=k_rr*(dr_OH1/r_OH2*OH2_vec(:))

   g_act(:,i_H1)=g_act(:,i_H1)-g_local_a(:)
   g_act(:,i_H2)=g_act(:,i_H2)-g_local_b(:)
   g_act(:,i_O)=g_act(:,i_O)+g_local_b(:)+ g_local_a(:)

   if (calc_vir) then
      vir_ten(1,1)=vir_ten(1,1)+OH1_vec(1)*g_local_a(1)+OH2_vec(1)*g_local_b(1)
      vir_ten(2,1)=vir_ten(2,1)+OH1_vec(2)*g_local_a(1)+OH2_vec(2)*g_local_b(1)
      vir_ten(3,1)=vir_ten(3,1)+OH1_vec(3)*g_local_a(1)+OH2_vec(3)*g_local_b(1)
      vir_ten(1,2)=vir_ten(1,2)+OH1_vec(1)*g_local_a(2)+OH2_vec(1)*g_local_b(2)
      vir_ten(2,2)=vir_ten(2,2)+OH1_vec(2)*g_local_a(2)+OH2_vec(2)*g_local_b(2)
      vir_ten(3,2)=vir_ten(3,2)+OH1_vec(3)*g_local_a(2)+OH2_vec(3)*g_local_b(2)
      vir_ten(1,3)=vir_ten(1,3)+OH1_vec(1)*g_local_a(3)+OH2_vec(1)*g_local_b(3)
      vir_ten(2,3)=vir_ten(2,3)+OH1_vec(2)*g_local_a(3)+OH2_vec(2)*g_local_b(3)
      vir_ten(3,3)=vir_ten(3,3)+OH1_vec(3)*g_local_a(3)+OH2_vec(3)*g_local_b(3)
   end if

end do
!
!      Second, calculate the intermolecular energy part
!
do i=1,natoms
   do j=i+1,natoms
!
!      Only between atoms of different water molecules
!
      if (water_act(i) .ne. water_act(j)) then
         dist_vec=xyz_act(:,i)-xyz_act(:,j)
         if (periodic) then
            call box_image(dist_vec)
         end if
         rij=sqrt(dot_product(dist_vec,dist_vec))
!
!      Only below the cutoff
!
         if (rij .lt. coul_cut .or. .not. periodic) then
!
!      The Coulomb interaction
!
            oner=1.d0/rij
!
!      Use the Zahn smooth cutoff method, if ordered
!
            if (zahn) then
               e0=q(i)*q(j)*((erfc(zahn_a*rij)*oner)-zahn_par*(rij-coul_cut))
            else
               e0=q(i)*q(j)*oner
            end if

            e_act=e_act+e0
!
!      The Coulomb interaction gradient
!
            g_vec=e0*oner*oner*dist_vec(:)
            g_act(:,i)=g_act(:,i)-g_vec
            g_act(:,j)=g_act(:,j)+g_vec
!
!     the components of the virial tensor, if needed
!
            if (calc_vir) then
               vir_ten(1,1)=vir_ten(1,1)-dist_vec(1)*g_vec(1)
               vir_ten(2,1)=vir_ten(2,1)-dist_vec(2)*g_vec(1)
               vir_ten(3,1)=vir_ten(3,1)-dist_vec(3)*g_vec(1)
               vir_ten(1,2)=vir_ten(1,2)-dist_vec(1)*g_vec(2)
               vir_ten(2,2)=vir_ten(2,2)-dist_vec(2)*g_vec(2)
               vir_ten(3,2)=vir_ten(3,2)-dist_vec(3)*g_vec(2)
               vir_ten(1,3)=vir_ten(1,3)-dist_vec(1)*g_vec(3)
               vir_ten(2,3)=vir_ten(2,3)-dist_vec(2)*g_vec(3)
               vir_ten(3,3)=vir_ten(3,3)-dist_vec(3)*g_vec(3)
             end if

!
!      The dispersion (LJ 12-6) interaction: only between O and H!
!
            if (name(i) .eq. "O" .and. name(i) .eq. "O") then
               sigr6=(sigma_OO*oner)**6
               e_act=e_act+4d0*eps_OO*(sigr6**2-sigr6)
!
!      The dispersion gradient
!
               g_vec=24.d0*eps_OO*oner*oner*dist_vec(:)* &
                             & sigr6*(2.d0*sigr6-1.d0)
               g_act(:,i)=g_act(:,i)-g_vec
               g_act(:,j)=g_act(:,j)+g_vec
!
!     the components of the virial tensor, if needed
!
               if (calc_vir) then
                  vir_ten(1,1)=vir_ten(1,1)+dist_vec(1)*g_vec(1)
                  vir_ten(2,1)=vir_ten(2,1)+dist_vec(2)*g_vec(1)
                  vir_ten(3,1)=vir_ten(3,1)+dist_vec(3)*g_vec(1)
                  vir_ten(1,2)=vir_ten(1,2)+dist_vec(1)*g_vec(2)
                  vir_ten(2,2)=vir_ten(2,2)+dist_vec(2)*g_vec(2)
                  vir_ten(3,2)=vir_ten(3,2)+dist_vec(3)*g_vec(2)
                  vir_ten(1,3)=vir_ten(1,3)+dist_vec(1)*g_vec(3)
                  vir_ten(2,3)=vir_ten(2,3)+dist_vec(2)*g_vec(3)
                  vir_ten(3,3)=vir_ten(3,3)+dist_vec(3)*g_vec(3)
               end if
            end if
         end if
      end if
   end do
end do
!stop "gup"
return
end subroutine egrad_water


      PROGRAM DPMJET

      IMPLICIT NONE
      DOUBLE PRECISION dum , elab , epn
      INTEGER ICAsca , idp , iemu , ievt , irej , kkmat , NEVent ,
     &        nevts , npchar , npmass , ntchar , ntmass
      SAVE

C block data in DPMJET library (uncomment these declarations if library
C option is used)
C     EXTERNAL DT_BDEVAP,DT_BDNOPT,DT_BDPREE,DT_HADPRP,DT_BLKD46,
C    &         DT_BLKD47,DT_RUNTT,DT_NONAME,DT_ZK,DT_BLKD43

C     EXTERNAL PYDATA

C event flag
      COMMON /DTEVNO/ NEVent , ICAsca
      INCLUDE 'inc/dtflka'
C-----------------------------------------------------------------------
C initialization
      LPRi = 20
      LOUt = 6
C   the following statement provides a call to DT_USRHIS(MODE=1) for
C   histogram initialization etc.
      CALL DT_DTUINI(nevts,epn,npmass,npchar,ntmass,ntchar,idp,iemu)
      WRITE (6,*) "****************************"
      WRITE (6,*) nevts , epn , npmass , npchar , ntmass , ntchar ,
     &            idp , iemu
C-----------------------------------------------------------------------
C generation of events

      DO ievt = 1 , nevts

C   some defaults, do not change!
         NEVent = ievt
         kkmat = -1
         elab = epn
C   uncomment if dpmjet3 is linked to particle transport code
C        ICASCA = 1

C***********************************************************************
C The following lines show how to select the target nucleus for runs
C with composite targets (and fixed projectile and energy!).
C
C   Sampling of the target nucleus (mass number NTMASS, charge NTCHAR)
C   according to the fractions defined with EMULSION input-cards.
C   The different nuclei are numbered as KKMAT = 1,2,3,...  according to
C   their appearance in the input-file.
         IF ( iemu.GT.0 ) THEN
C   Replace this selection by your own one if needed.
            CALL DT_GETEMU(ntmass,ntchar,kkmat,0)
C   Kkmat has to be negative for composite targets!
            kkmat = -kkmat
         END IF
C***********************************************************************

C***********************************************************************
C The following lines show how to define projectile, target and energy
C for this event in runs with Glauber-data file pre-initialized for a
C certain range of projectiles, targets and energies. The definitions
C have to be within the pre-initialized parameter range.
C
C   projectile-id (for hadron projectiles)
C        IDP    = 1
C   projectile mass and charge numbers
C        NPMASS = 12
C        NPCHAR = 6
C   target mass and charge numbers
C        NTMASS = 16
C        NTCHAR = 8
C   lab energy
C        ELAB = 200.0D0
C***********************************************************************

C***********************************************************************
C If an energy-range has been defined with the ENERGY input-card the
C laboratory energy ELAB can be set to any value within that range. For
C example:
C        ELO  = 10.0D0
C        EHI  = 1000.0D0
C        ELAB = DT_RNDM(ELAB)*(EHI-ELO)+ELO
C***********************************************************************

C   sampling of one event
         CALL DT_KKINC(npmass,npchar,ntmass,ntchar,idp,elab,kkmat,irej)
c          WRITE (6,*) "EVE" , npmass , npchar , ntmass , ntchar , idp ,
c      &               elab , kkmat , irej

C   the following statement provides a call to DT_USRHIS(MODE=2) from
C   where the final state particles can be obtained

         IF ( irej.EQ.0 ) CALL PHO_PHIST(2000,dum)

      END DO

C-----------------------------------------------------------------------
C output, statistics etc.

C   the following statement provides a call to DT_USRHIS(MODE=3) in
C   order to calculate histograms etc.
      CALL DT_DTUOUT

      END PROGRAM

C *$ CREATE DT_USRHIS.FOR
C *COPY DT_USRHIS
C *
C *===usrhis=============================================================*
C *
C       SUBROUTINE DT_USRHIS(MODE)

C       IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C       SAVE
C *
C * COMMON /DTEVT1/ :
C *                   NHKK         number of entries in common block
C *                   NEVHKK       number of the event
C *                   ISTHKK(i)    status code for entry i
C *                   IDHKK(i)     identifier for the entry
C *                                (for particles: identifier according
C *                                 to the PDG numbering scheme)
C *                   JMOHKK(1,i)  pointer to the entry of the first mother
C *                                of entry i
C *                   JMOHKK(2,i)  pointer to the entry of the second mother
C *                                of entry i
C *                   JDAHKK(1,i)  pointer to the entry of the first daughter
C *                                of entry i
C *                   JDAHKK(2,i)  pointer to the entry of the second daughter
C *                                of entry i
C *                   PHKK(1..3,i) 3-momentum
C *                   PHKK(4,i)    energy
C *                   PHKK(5,i)    mass
C *
C * event history
C         include 'dtevt1'
C * extended event history
C         include 'dtevt2'

C         GOTO (1,2,3) MODE

C *------------------------------------------------------------------
C *
C     1 CONTINUE
C *
C * initializations
C *
C *  Called with MODE=1 once at the beginning of the run.
C *
C         RETURN
C *
C *------------------------------------------------------------------
C *
C     2 CONTINUE
C *
C * scoring of the present event
C *
C *  Called with MODE=2 every time one event has been finished.
C *
C *  The final state particles from the actual event (number NEVHKK)
C *  can be found in DTEVT1 and identified by their status:
C *
C *     ISTHKK(i) = 1    final state particle produced in
C *                      photon-/hadron-/nucleon-nucleon collisions or
C *                      in intranuclear cascade processes
C *                -1    nucleons, deuterons, H-3, He-3, He-4 evaporated
C *                      from excited nucleus and
C *                      photons produced in nuclear deexcitation processes
C *                1001  residual nucleus (ground state)
C *
C *  The types of these particles/nuclei are given in IDHKK as follows
C *
C *     all final state part. except nuclei :
C *       IDHKK(i)=particle identifier according to PDG numbering scheme
C *     nuclei (evaporation products, and residual nucleus) :
C *       IDHKK(i)=80000, IDRES(i)=mass number, IDXRES(i)=charge number
C *
C *  The 4-momenta and masses can be found in PHKK (target nucleus rest frame):
C *                   PHKK(1..3,i) 3-momentum (p_x,p_y,p_z)
C *                   PHKK(4,i)    energy
C *                   PHKK(5,i)    mass
C *
C *
C *
C *  Pick out the final state particles from DTEVT1 in each event for
C *  instance by the following loop (NHKK=number of entries in the present
C *  event) and fill your histograms
C C     DO 20 I=1,NHKK
C C        IF (ABS(ISTHKK(I)).EQ.1) THEN
C C        ELSEIF (ABS(ISTHKK(I)).EQ.1001) THEN
C C        ENDIF
C C  20 CONTINUE

C *  At any time during the run a list of the actual entries in DTEVT1 and
C *  DTEVT2 can be obtained (output unit 6) by the following statement:
C C     CALL DT_EVTOUT(4)

C       RETURN
C *
C *------------------------------------------------------------------
C *
C     3 CONTINUE
C *
C * output/statistics/histograms etc.
C *
C *  Called with MODE=3 once after all events have been sampled.
C *
C       RETURN

C       END


	module comcomp
!***********************************************************************
! Copyright 2010 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!	phi	  Pressure in water-phase (comdi)
!	phil	  Pressure in oil-phase
!	phig	  Pressure in gas-phase
!	pcp	  Array for oil-gas capillary pressure (comdi)
!	pcpo	  Array for oil-water capillary pressure
!	fl	  Saturation of oil (comco2)
!	fg	  Saturation of gas (comco2)
!	fw	  Saturation of water (comco2)
!	fk	  Saturation of kerogen
!	yo	  Mass fraction of oil in gas-phase
!	xo	  Mass fraction of oil in oil-phase
!	yg	  Mass fraction of gas in gas-phase
!	xg	  Mass fraction of gas in oil-phase
!	yw	  Mass fraction of water in gas-phase (comco2)
!	xw	  Mass fraction of water in oil-phase (comco2)
!	rl_l	  Array for relative permeability of oil-phase (comco2)
!	rl_g	  Array for relative permeability of gas-phase
!	rl_w	  Array for relative permeability of water-phase (comco2)
!	oil_prop	Array for oil properties
!	gas_prop	Array for gas properties
!	wat_prop	Array for water properties (comco2)
!	sto1	  Mass in accumulation term
!	sto1	  Energy in accumulation term
!	diw	  Advection in water-phase (comco2)
!	dil	  Advection in oil-phase (comco2)
!	div	  Advection in gas-phase (comci)
!	sk	  Water mass source/sink term (comdi)
!	qh	  Water energy source/sink term (comdi)
!	sko	  Oil mass source/sink term
!	qho	  Oil energy source/sink term
!	skg	  Gas mass source/sink term
!	qhg	  Gas energy source/sink term
!***********************************************************************

	real*8, allocatable :: pcrit(:)
	real*8, allocatable :: tcrit(:)
	real*8, allocatable :: rcrit(:)
	real*8, allocatable :: zcrit(:)
	real*8, allocatable :: ent0(:)
	real*8, allocatable :: hcap(:,:)
	real*8, allocatable :: accn(:)
	real*8, allocatable :: flcomp(:)
	real*8, allocatable :: mwt(:)
	real*8, allocatable :: bicof(:,:)

	real*8, allocatable :: phil(:)
	real*8, allocatable :: phig(:)
	real*8, allocatable :: phol(:)
	real*8, allocatable :: phog(:)
	real*8, allocatable :: pcpow(:)
	real*8, allocatable :: pcpog(:)
	real*8, allocatable :: fk(:)
	real*8, allocatable :: fok(:)
	real*8, allocatable :: rl_g(:)
	real*8, allocatable :: sko(:)
	real*8, allocatable :: qho(:)
	real*8, allocatable :: esko(:)
	real*8, allocatable :: skg(:)
	real*8, allocatable :: qhg(:)
	real*8, allocatable :: eskg(:)
	real*8, allocatable :: skk(:)
	real*8, allocatable :: qhk(:)
	real*8, allocatable :: oil_prop(:)
	real*8, allocatable :: gas_prop(:)

	real*8, allocatable :: diwg(:)
	real*8, allocatable :: diwk(:)
	real*8, allocatable :: divg(:)
	real*8, allocatable :: divk(:)
	real*8, allocatable :: dilg(:)
	real*8, allocatable :: dilk(:)

	real*8, allocatable :: dmgf(:)
	real*8, allocatable :: dmkf(:)
	real*8, allocatable :: degf(:)
	real*8, allocatable :: dekf(:)

	real*8, allocatable ::  dqg(:)
	real*8, allocatable ::  dqk(:)
	real*8, allocatable ::  deqg(:)
	real*8, allocatable ::  deqk(:)
	real*8, allocatable ::  dqhg(:)
	real*8, allocatable ::  dqhk(:)

	real*8, allocatable ::  denoili(:)
	real*8, allocatable ::  denoilh(:)
	real*8, allocatable ::  deneoili(:)
	real*8, allocatable ::  deneoilh(:)

	real*8, allocatable ::  dengasi(:)
	real*8, allocatable ::  dengash(:)
	real*8, allocatable ::  denegasi(:)
	real*8, allocatable ::  denegash(:)

	real*8, allocatable ::  denkeri(:)
	real*8, allocatable ::  denkerh(:)
	real*8, allocatable ::  denekeri(:)
	real*8, allocatable ::  denekerh(:)

	real*8, allocatable ::  pflowoil(:)
	real*8, allocatable ::  eflowoil(:)
	real*8, allocatable ::  pflowgas(:)
	real*8, allocatable ::  eflowgas(:)

	real*8, allocatable :: xoi(:)
	real*8, allocatable :: xg(:)
!	real*8, allocatable :: xw(:)
	real*8, allocatable :: yoi(:)
	real*8, allocatable :: yg(:)
!	real*8, allocatable :: yw(:)

	real*8, allocatable :: xoo(:)
	real*8, allocatable :: xog(:)
!	real*8, allocatable :: xow(:)
	real*8, allocatable :: yoo(:)
	real*8, allocatable :: yog(:)
!	real*8, allocatable :: yow(:)

	real*8, allocatable :: dentmp(:)
	real*8, allocatable :: mutmp(:)
	real*8, allocatable :: entmp(:)
	real*8, allocatable :: eosa(:)
	real*8, allocatable :: eosb(:)
	real*8, allocatable :: ddenp(:)
	real*8, allocatable :: ddent(:)
	real*8, allocatable :: dmudt(:)
	real*8, allocatable :: dmudp(:)
	real*8, allocatable :: dentt(:)
	real*8, allocatable :: dentp(:)

	real*8, allocatable :: cpr_zero(:,:)
	real*8, allocatable :: cpr_one(:,:)

	real*8, allocatable :: tkval(:)
	real*8, allocatable :: pkval(:)
	real*8, allocatable :: kval(:)
	integer, allocatable :: itind(:)
	integer, allocatable :: ipind(:)

	integer, allocatable :: kao(:)
	integer, allocatable :: kag(:)
	character*10, allocatable :: compin(:)

	integer ncomp, ioiltype, ioil, idof_oil, nkvt, nkvp, nkv

	end module comcomp