C
C    recent modifiactions:  9/01
C
C    immiscible plume source boundary conditions converted to no-diffusive flow 
C    boundaries when residual plume volume content becomes < 0.0001
C
C    recent modifications:  1/01
C    updated flux calculations for 1-D scenarios to account for biodegradation
C    removed crank-nicolson approximation of biodegradation term
C    
C    recent modifications:  11/00
C    established independent (i.e. non-source) boundary conditions for O2 which 
C    can be applied in biodegradation simulations.  
C
C
C
C    THIS PROGRAM SOLVES THE RADIALLY SYMMETRIC EQUATIONS FOR SOLUTE AND
C    VAPOR TRANSPORT ORIGINATING FROM AN IMMOBILE SOURCE IN A HETERGENEOUS
C    UNSATURATED ZONE UNDER NATURAL CONDITIONS (NO AIR FLOW AND WATER FLOW
C    IN VERTICAL DIRECTION ONLY)
C    THE SPATIAL DERIVITIVES ARE DESCRETIZED WITH EQUALLY SPACED NODES
C    AND IN THIS VERSION PROJECTIONS ARE MADE(SEE PARAMATER IPROJ)
C    AND THEN REFINED WITH GAUSS SIEDEL. ALL BASED ON STANDARD
C    CRANK-NICOLSON DIFFERENCE APPROXIMATION
C
C
      PROGRAM RUNSAT
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER(NHR=501,NHZ=501,NHL=5,NHK=8,NHW=3,I9=NHK+1,
     1NHRZ=NHR+NHZ+1)
      CHARACTER TITLE*70,FNAMEPOR*38,FNAMETHW*38,M*30,
     1FNAMETA*38,FNAMEBD*38,FNAMEICDAT*38,FNAMEMIF*38,FNAMECAL*38,
     2FNAMEOUT1*38,FNAMEOUT2*38,FNAMEOUT3*38,FNAMEOUT4*38,FNAMEOUT5*38,
     3FNAMEOUT6*38,FNAMEOUT7*38,FNAMEOUT8*38,FNAMEOUT9*38,FNAMEOUT10*38,
     4FNAMEOUT11*38,FNAMEOUT12*38,FNAMEOUT13*38,FNAMEOUT14*38,
     5FNAMEOUT15*38,FNAMEOUT16*38,FNAMEOUT17*38,FNAMEOUT18*38,
     6FNAMEOUT19*38,FNAMEOUT20*38,FNAMEOUT21*38,FNAMEOUT22*38,
     7FNAMEOUT23*38,FNAMEOUT24*38,
     8FNAMEBCDAT*38
      COMMON/DEP0/ Y0,Y1,Y2,Y3,DTY
      COMMON/DEP/  Y,TOT,RBIO
      COMMON/CHAR/ M,FNAMETA,FNAMEBD,FNAMECAL,FNAMEMIF,
     3FNAMEICDAT,FNAMEPOR,FNAMETHW,FNAMEBCDAT,TITLE,
     5FNAMEOUT1,FNAMEOUT2,FNAMEOUT3,FNAMEOUT4,FNAMEOUT5,
     6FNAMEOUT6,FNAMEOUT7,FNAMEOUT8,FNAMEOUT9,FNAMEOUT10,
     7FNAMEOUT11,FNAMEOUT12,FNAMEOUT13,FNAMEOUT14,FNAMEOUT15,FNAMEOUT16,
     8FNAMEOUT17,FNAMEOUT18,FNAMEOUT19,FNAMEOUT20,FNAMEOUT21,FNAMEOUT22,
     9FNAMEOUT23,FNAMEOUT24
      COMMON/XNRNZNK/ BR,BZ,CR,CZ,PP,DKA,SUMDK
      COMMON/XNRNZ/ PT
      COMMON/XNZNK/ FIRF,A
      COMMON/XNRNK/ FIZT,FIZW,FLX
      COMMON/XNKNK/ DKAB
      COMMON/XNR/ R,BC
      COMMON/XNZ/ Z,TA,TW,BD,POR,THA,THW
      COMMON/YTRP/ YTRAP,ZTRAP
      COMMON/XNK/  XIK0,HAW,HSW,RK,TIFIP,TIFB,TIFT,TIRBIO,TIFRF,
     1TMASS,TMASS0,CRY,VK,WK,HWIK,XMASSB,XMASST,ATCONC,IBIO,ICON,
     2TMASSW,DV,DKW,VC,VM,BMLX,FLXDT,IOUTOPT,IREF,IFLX
     3,RCON,RLAMBDA,RMAX,HSAT,GWAT,FTOP,FBOT,FRIM,DFLXDT
      COMMON/XNL/AL,ALT,ZLAY,PORL,TAL,THWL,THAL,BDL
      COMMON/XNW/RVW,ZVW
      COMMON/ARRAY/ XINIT,UINIT,XPT,YPT,SLPZ,SLPR,BZZ,BRR,SXLM
      COMMON/ISC/NR,NZ,NL,NK,NT,IRIM,IRASP,IZLOW,IZHI,IZBAS,IRVW,IZVW,
     1IPROJ,NITER,IRNORM,IZNORM,ITER,ITER0,ISS,IRFP,IW,IL,IK,IKK,I,
     2NW,IZLAY,JK,IDAT,NDAT,ICOUNT,IOX,IIX,ICUT,IDT,IU2,IU3,IU4,KONS
      COMMON/INT/IFIL,IMOD,IMILQ,IOPT,INOPT,IBC0,IOUT,ICOMP,ISURF,
     1NDATIN,NDATCAL,NIPTS,ISNAP,ITIME,ICONX,IWARN,ICNTER,IDIM,
     2ISTRAT,IBDRY,INCHECK,IDISP,IWAT,IFLAG,IN,JN,IRMAX,IHSAT
      COMMON/XSC/DT,DR,DZ,SUM,AR1,AR2,AR3,AR4,AZ1,AZ2,ATOX,RHOIM,CSA,
     1TIME,VIMM,DARCY,THI0,EPS,ENORM,ATM,ZBAS,ZWAT,ZSURF,ZLOW,ZHI,
     2DT1,DT2,DTM,TRANS,TEND,YPR1,YPR2,SKIP,SKIP2,TEMP,RIM,RF,DTHI0
      COMMON/CONS/FLUX,UP,UW,D,DS,GAM,B,C,XL,PI,XFD,BP,DP,WAT,AIR,
     1XMM,DBIN,XM0,XB0,YNM,TMAX,DELT,HENRY,SWPC,BULK,XLL,TSNAP,TOR,
     2XB,ZOUT,GASBOT
      COMMON/RC1/ C6,C7
      COMMON/RC2/C1,C2,C3,C4,C5
C
C
C
C****DIMENSION THE FOLLOWING (NR,NZ,NK+1)
C
      DIMENSION Y0(NHR,NHZ,I9),DTY(NHR,NHZ,I9),PP(NHR,NHZ,I9)
     1,BR(NHR,NHZ,I9),BZ(NHR,NHZ,I9),CR(NHR,NHZ,I9),CZ(NHR,NHZ,I9)
     2,C1(NHR,NHZ,I9),C2(NHR,NHZ,I9),C3(NHR,NHZ,I9),C4(NHR,NHZ,I9)
     3,C5(NHR,NHZ,I9),DKA(NHR,NHZ,I9),SUMDK(NHR,NHZ,I9)
     4,Y(NHR,NHZ,I9),Y3(NHR,NHZ,I9)
C
C****DIMENSION THE FOLLOWING (NR,NZ)
      DIMENSION TOT(NHR,NHZ),PT(NHR,NHZ)
      DIMENSION C6(NHR,NHZ),C7(NHR,NHZ),RBIO(NHR,NHZ)
C
C******DIMENSION THE FOLLOWING AS (NZ,NK+1)
C
      DIMENSION FIRF(NHZ,I9),A(NHZ,I9),Y1(NHZ,I9)
C
C******DIMENSION THE FOLLOWING AS (NR,NK+1)
C
      DIMENSION FIZT(NHR,I9),FIZW(NHR,I9),FLX(NHR,I9),Y2(NHR,I9)
C
C******DIMENSION THE FOLLOWING AS (I9,I9)
C
      DIMENSION DKAB(I9,I9)
C
C******DIMENSION THE FOLLOWING AS (NR+NZ)
C
      DIMENSION YTRAP(NHRZ),ZTRAP(NHRZ)
C
C******DIMENSION THE FOLLOWING AS (NHZ)
C
      DIMENSION Z(NHZ),POR(NHZ),TA(NHZ),TW(NHZ),THA(NHZ)
     1,THW(NHZ),BD(NHZ)
C
C******DIMENSION THE FOLLOWING AS (NHR)
C
      DIMENSION R(NHR),BC(NHR)
C
C******DIMENSION THE FOLLOWING AS (NL)
C
      DIMENSION AL(NHL),ALT(NHL),ZLAY(NHL),IZLAY(NHL),
     1PORL(NHL),THWL(NHL),THAL(NHL),TAL(NHL),BDL(NHL)
C
C********DIMENSION THE FOLLOWING AS (NW)
C
      DIMENSION RVW(NHW),ZVW(NHW),IRVW(NHW),IZVW(NHW)
C
C********DIMENSION THE FOLLOWING (NHK+1)
C
      DIMENSION TIFIP(I9),TIFB(I9),TIFT(I9),TIRBIO(I9),TIFRF(I9),
     1TMASS0(I9),TMASSW(I9),TMASS(I9),XMASSB(I9),XMASST(I9),CRY(I9)
     2,FTOP(I9),GWAT(I9),FBOT(I9),FRIM(I9),FLXDT(I9),DFLXDT(I9)
C
C*******DIMENSION THE FOLLOWING (NHK+2)
C
      DIMENSION WK(I9),VC(I9),VM(I9),DV(I9),IBIO(I9),ICON(I9)
C
C*******DIMENSION THE FOLLOWING (NK)
C
      DIMENSION XIK0(NHK),BMLX(NHK),HWIK(NHK),HAW(NHK),RK(NHK)
     1,HSW(NHK),VK(NHK),ATCONC(NHK),DKW(NHK),IOUTOPT(NHK)
     2,IREF(NHK),IFLX(NHK),RLAMBDA(NHK),RCON(NHK)
     3,RMAX(NHK),HSAT(NHK)
C
C*******DIMENSION THE FOLLOWING
C
      DIMENSION SXLM(10000),XINIT(1001),UINIT(1001),XPT(1001),YPT(1001),
     1SLPZ(1001),SLPR(1001),BZZ(1001),BRR(1001)
C
C
C
      I=0
C
      IMOD=0
      IFIL=0
      CALL PREMAIN
      IF(IFIL.EQ.1) THEN
      IF(IMOD.EQ.1) THEN
      CALL NEWNUM
      ELSE
      CALL NEWANAL
      END IF
      ELSE
      OPEN(UNIT=12,FILE=FNAMEMIF)
      READ(12,*) IMOD
C
C
      IF(IMOD.EQ.1) THEN
      WRITE(*,302)
 302  FORMAT (/80('*')/20X,'EXECUTING THE NUMERICAL SOLUTION'/80('*')/)
C
      R0=0.0
      ZWAT=0.0
	READ(12,946) IDIM
      IF(IDIM.GE.2) THEN
      READ(12,83) RF
      READ(12,*) NR
      ELSE
      READ(12,83) CSA
      RF=(CSA/3.14159)**0.5
      NR=4
      RIM=RF
      DR=(RF-R0)/(NR-1)
      END IF
      READ(12,*) ZSURF
      IF(IDIM.EQ.1 .OR. IDIM.EQ.3) THEN
      READ(12,*) NZ
      ELSE
      NZ=3
      ZHI=ZSURF
      ZLOW=0.0
      RIM=R(2)
      DZ=(ZSURF-ZWAT)/(NZ-1)
      END IF
      IF(IDIM.GE.2) READ(12,*) DR
      IF(IDIM.EQ.1 .OR. IDIM.EQ.3) READ(12,*) DZ
C
C   GENERATE EQUALLY SPACED NODAL COORDINATES
C
      DO 355 IZ=1,NZ
      Z(IZ)=ZWAT+(IZ-1)*DZ
 355  CONTINUE
      DO 360 IR=1,NR
      R(IR)=R0+(IR-1)*DR
 360  CONTINUE
C
      READ(12,*) TEMP
      READ(12,*) ATM
      READ(12,*) DARCY
      DARCY=-DARCY/3.1536E07
C
      IDISP=0.0
      IF(ABS(DARCY).GT.0) THEN
      READ(12,*) IDISP
      READ(12,89) NK
      ELSE
      READ(12,84) NK
      END IF
C
C
      IFLAG=0
      DO 405 IK=1,NK
      IBIO(IK)=0
      IOX=0
      IND=0
      READ(12,84) ICON(IK)
      IF(ICON(IK).EQ.2) IOX=1
      READ(12,*) WK(IK)
      READ(12,*) DV(IK)
      READ(12,*) HAW(IK)
      IF(ICON(IK).EQ.4 .OR. ICON(IK).GE.6) READ(12,86) HSW(IK)
      IF(ICON(IK).EQ.5) HSW(IK)=1.0
      IF(ICON(IK).LE.3) HSW(IK)=0.0
C
      IF(IK.EQ.NK .AND. IK.GT.1) THEN
	IF(IOX.EQ.1) THEN
	DO 699 IKK=2,NK
	IF(IBIO(IKK-1).EQ.2) IBIO(NK)=2
	IF(IBIO(IKK-1).EQ.3) IBIO(NK)=3
	IF(IBIO(IKK-1).EQ.4) IBIO(NK)=4
	IF(IBIO(IKK-1).EQ.5) IBIO(NK)=5
 699  CONTINUE
	GO TO 566
	END IF
	END IF
C
      IF(ICON(IK).EQ.4 .OR.ICON(IK).GE.6) THEN
      READ(12,*) IBIO(IK)
	ELSE
      READ(12,87) IBIO(IK)
      END IF
 566  CONTINUE
      IF(IBIO(IK).GE.3) IOX=1
	IF(IBIO(IK).EQ.0) IFLAG=0
      IF(IBIO(IK).EQ.1) IFLAG=1
      IF(IBIO(IK).EQ.2) IFLAG=2
      IF(IBIO(IK).EQ.3) IFLAG=3
      IF(IBIO(IK).EQ.4) IFLAG=4
      IF(IBIO(IK).EQ.5) IFLAG=5
      IF(IBIO(IK).EQ.6) IFLAG=6
      DO 914 IR=1,NR
      DO 914 IZ=1,NZ
      RBIO(IR,IZ)=0.0
 914  CONTINUE
C
      IF(IBIO(IK).EQ.0) READ(12,833) ATCONC(IK)
      IF(IBIO(IK).EQ.1) THEN
      READ(12,833) RCON(IK)
      READ(12,*) ATCONC(IK)
      END IF
C
      IF(IBIO(IK).EQ.2) THEN
      IF(IK.LT.NK) THEN
      READ(12,833) RLAMBDA(IK)
      READ(12,*) ATCONC(IK)
      END IF
	IF(IK.EQ.NK) THEN
      IF(NK.EQ.1) THEN
	READ(12,833) RLAMBDA(IK)
	ELSE
	READ(12,833) RLAMBDA(IK)
	END IF
	READ(12,*) ATCONC(IK)
	END IF
	END IF
C
      IF(IBIO(IK).EQ.3) THEN
      IF(IK.LT.NK) THEN
      READ(12,833) RK(IK)
      READ(12,*) RLAMBDA(IK)
      READ(12,*) ATCONC(IK)
      END IF
      IF(IK.EQ.NK) READ(12,86)ATCONC(IK)
	END IF
C
      IF(IBIO(IK).EQ.4) THEN
      IF(IK.LT.NK) THEN
      READ(12,833) RK(IK)
      READ(12,*) ATCONC(IK)
      ELSE
      READ(12,86) ATCONC(IK)
      END IF
      END IF
      IF(IBIO(IK).EQ.5) THEN
      IF(IK.LT.NK) THEN
      READ(12,833) RK(IK)
      READ(12,*) RMAX(IK)
      READ(12,*) HSAT(IK)
      READ(12,*) ATCONC(IK)
      ELSE
	READ(12,86) HSAT(IK)
      READ(12,*) ATCONC(IK)
      END IF
      END IF
      IF(IBIO(IK).EQ.6) THEN
      READ(12,86) ATCONC(IK)
      END IF
C
      READ(12,85) DKW(IK)
C
 405  CONTINUE
C   
      READ(12,84) IOPT
C
      DO 410 IK=1,NK
      IND=0
C
      IF(IFLAG.LE.2) THEN
C
	IF(IOPT.EQ.1) THEN
      IF(IDIM.EQ.3) THEN
      IF(IK.EQ.1) READ(12,945) IBDRY
      IF(IK.GT.1 .AND. IND.EQ.0) READ(12,933) IBDRY
      IF(IK.GT.1 .AND. IND.EQ.1) READ(12,83) IBDRY
      ELSE
      IBDRY=0
      END IF
      IF(IBDRY.EQ.0) THEN
      IND=1
      IF(IK.EQ.1) THEN
      IF(IDIM.LE.2) READ(12,998) FLX(1,IK)
      IF(IDIM.EQ.3) READ(12,85) FLX(1,IK)
      ELSE
      IF(IDIM.LE.2) READ(12,83) FLX(1,IK)
      IF(IDIM.EQ.3) READ(12,85) FLX(1,IK)
      END IF
      DO 588 IR=1,NR
      FLX(IR,IK)=FLX(1,IK)
 588  CONTINUE
      ELSE
      OPEN(UNIT=13,FILE='BC.MAP')
      READ(13,*) ICOUNT
      READ(13,206) (FLX(IR,IK),IR=1,NR)
      END IF
      END IF
C
      IF(IOPT.EQ.2) THEN
      IF(IDIM.EQ.3) THEN
      IF(IK.EQ.1) READ(12,945) IBDRY
      IF(IK.GT.1 .AND. IND.EQ.0) READ(12,933) IBDRY
      IF(IK.GT.1 .AND. IND.EQ.1) READ(12,83) IBDRY
      ELSE
      IBDRY=0
      END IF
      IF(IBDRY.EQ.0) THEN
      IND=1
      IF(IK.EQ.1) THEN
      IF(IDIM.LE.2) READ(12,998) Y0(2,2,IK)
      IF(IDIM.EQ.3) READ(12,85) Y0(2,2,IK)
      ELSE
      IF(IDIM.LE.2) READ(12,83) Y0(2,2,IK)
      IF(IDIM.EQ.3) READ(12,85) Y0(2,2,IK)
      END IF
      DO 188 IR=1,NR
      Y0(IR,2,IK)=Y0(2,2,IK)
 188  CONTINUE
      ELSE
      OPEN(UNIT=13,FILE='BC.MAP')
      READ(13,*) ICOUNT
      READ(13,206) (Y0(IR,2,IK),IR=1,NR)
      END IF
      END IF
C
      ELSE
C
      IF(IK.LT.NK) THEN
	IF(IOPT.EQ.1) THEN
      IF(IDIM.EQ.3) THEN
      IF(IK.EQ.1) READ(12,945) IBDRY
      IF(IK.GT.1 .AND. IND.EQ.0) READ(12,933) IBDRY
      IF(IK.GT.1 .AND. IND.EQ.1) READ(12,83) IBDRY
      ELSE
      IBDRY=0
      END IF
      IF(IBDRY.EQ.0) THEN
      IND=1
      IF(IK.EQ.1) THEN
      IF(IDIM.LE.2) READ(12,998) FLX(1,IK)
      IF(IDIM.EQ.3) READ(12,85) FLX(1,IK)
      ELSE
      IF(IDIM.LE.2) READ(12,83) FLX(1,IK)
      IF(IDIM.EQ.3) READ(12,85) FLX(1,IK)
      END IF
      DO 568 IR=1,NR
      FLX(IR,IK)=FLX(1,IK)
 568  CONTINUE
      ELSE
      OPEN(UNIT=13,FILE='BC.MAP')
      READ(13,*) ICOUNT
      READ(13,206) (FLX(IR,IK),IR=1,NR)
      END IF
      END IF
C
      IF(IOPT.EQ.2) THEN
      IF(IDIM.EQ.3) THEN
      IF(IK.EQ.1) READ(12,945) IBDRY
      IF(IK.GT.1 .AND. IND.EQ.0) READ(12,933) IBDRY
      IF(IK.GT.1 .AND. IND.EQ.1) READ(12,83) IBDRY
      ELSE
      IBDRY=0
      END IF
      IF(IBDRY.EQ.0) THEN
      IND=1
      IF(IK.EQ.1) THEN
      IF(IDIM.LE.2) READ(12,998) Y0(2,2,IK)
      IF(IDIM.EQ.3) READ(12,85) Y0(2,2,IK)
      ELSE
      IF(IDIM.LE.2) READ(12,83) Y0(2,2,IK)
      IF(IDIM.EQ.3) READ(12,85) Y0(2,2,IK)
      END IF
      DO 288 IR=1,NR
      Y0(IR,2,IK)=Y0(2,2,IK)
 288  CONTINUE
      ELSE
      OPEN(UNIT=13,FILE='BC.MAP')
      READ(13,*) ICOUNT
      READ(13,206) (Y0(IR,2,IK),IR=1,NR)
      END IF
      END IF
	END IF
C
      END IF
C
      IF(IOPT.EQ.3) THEN
      IF(IK.EQ.1) THEN
      READ(12,998) XIK0(IK)
      READ(12,*) KONS
      ELSE
      READ(12,83) XIK0(IK)
      END IF
      READ(12,*) HWIK(IK)
      READ(12,*) VK(IK)
      END IF
C
      IF(IOPT.EQ.4) THEN
	IRIM=1
      IF(IFLAG.LE.2) THEN
	IF(IK.EQ.1) THEN
      READ(12,998) FLX(1,IK)
      ELSE
      READ(12,83) FLX(1,IK)
      END IF
C
      ELSE
C
	IF(IK.LT.NK) THEN
	IF(IK.EQ.1) THEN
      READ(12,998) FLX(1,IK)
      ELSE
	READ(12,83) FLX(1,IK)
	END IF
	END IF
	END IF
	END IF
 410  CONTINUE
C
	IF(IOPT.LE.2) THEN
      IF(NK.EQ.1) THEN
      IF(IBDRY.EQ.0) READ(12,83) ZLOW
      IF(IBDRY.EQ.1) READ(12,856) ZLOW
      ELSE
      IF(IBDRY.EQ.0) READ(12,83) ZLOW
      IF(IBDRY.EQ.1) READ(12,833) ZLOW
      END IF
      READ(12,*) ZHI
      READ(12,*) RIM
      END IF
C
      IF(IOPT.EQ.3) THEN
      READ(12,83) THI0
      READ(12,*) ZLOW
      READ(12,*) ZHI
      READ(12,*) RIM
      END IF
C
      IF(IOPT.EQ.4) THEN
      READ(12,83) ZLOW
      READ(12,*) ZHI
      READ(12,*) RIM
      END IF
C
      IF(IOPT.EQ.5) THEN
      READ(12,998) ZLOW
      READ(12,*) ZHI
      READ(12,*) RIM
      END IF
C     
	READ(12,*) IFAR
      READ(12,85) ZBAS
      READ(12,*) AZ1
      READ(12,*) AZ2
      READ(12,87) ISURF
      READ(12,85) RASP
      READ(12,*) AR1
      READ(12,*) AR2
      READ(12,86) AR3
      READ(12,*) AR4
C
      IF(AR3.GT.0) THEN
      DO 55 IK=1,NK
      IF(IK.EQ.NK .AND. IFLAG.GE.3) GO TO 55
	READ(12,86) GWAT(IK)
 55   CONTINUE
	END IF
C
      IF(IFLAG.GE.3 .AND. AR4.GT.0) READ(12,86) GWAT(NK)
C
      IND=0
      IF(IFLAG.GE.3 .AND. IDIM.EQ.1) IND=1
      IF(IND.EQ.1 .AND. ZHI.GE.ZSURF) READ(12,86) ATOX
C
C  FIND INDICIES FOR SPECIAL COORDINATES
C
      IF(IOPT.LE.3 .OR. IOPT.EQ.5) CALL NODLOC(1,IRIM,RIM)
      CALL NODLOC(1,IRASP,RASP)
      CALL NODLOC(1,IRFP,RFP)
      CALL NODLOC(2,IZLOW,ZLOW)
	IF(IOPT.EQ.3 .AND. IZLOW.EQ.1) IZLOW=IZLOW+1
	IF(IOPT.EQ.5 .AND. IZLOW.EQ.1) IZLOW=IZLOW+1
      CALL NODLOC(2,IZHI,ZHI)
	IF(IOPT.EQ.3 .AND. IZHI.EQ.NZ) IZHI=IZHI-1
	IF(IOPT.EQ.5 .AND. IZHI.EQ.NZ) IZHI=IZHI-1
      CALL NODLOC(2,IZBAS,ZBAS)
C
C
C
C  DETERMINE INITIAL VOLUME AND MASS OF CONSTITUENTS IN MODEL DOMAIN FOR A
C  MASS BALANCE ANALYSIS (IOPT=3 ONLY).
C
      IF(IOPT.EQ.3) THEN
      VIMM=((3.14159)*R(IRIM)**2)*(Z(IZHI)-Z(IZLOW))
      SUM=0.0
      DO 400 IK=1,NK
      TMASS0(IK)=0.0
      TMASS0(IK)=VIMM*THI0*XIK0(IK)
      IF(TMASS0(IK).LT.1E-10) TMASS0(IK)=1.0E-10
      SUM=SUM+XIK0(IK)/WK(IK)
 400  CONTINUE
      END IF
C
      OPEN(UNIT=15,FILE='DKA.MAP')
      DO 418 IK=1,NK
      READ(15,*) ICOUNT
      DO 418 IZ=1,NZ
      READ(15,209) (DKA(IR,IZ,IK),IR=1,NR)
 418  CONTINUE
C
C
      IF(IOPT.EQ.5) OPEN(UNIT=84,FILE='IC.INPUT')
      IF(IOPT.LT.5) OPEN(UNIT=14,FILE='IC.MAP')
      DO 414 IK=1,NK
      IF(IOPT.LT.5) READ(14,*) IKK
      IF(IOPT.EQ.5) READ(84,*) IKK
      DO 414 IZ=1,NZ
      IF(IOPT.LT.5) READ(14,209) (Y0(IR,IZ,IKK),IR=1,NR)
      IF(IOPT.EQ.5) READ(84,209) (Y0(IR,IZ,IKK),IR=1,NR)
 414  CONTINUE
C
      IF(IOPT.LT.5) THEN
      READ(12,844) ISTRAT
      ELSE
      READ(12,70) ISTRAT
      END IF
C
      IF(ISTRAT.EQ.0) THEN
      NL=1
	IL=NL
      CALL NODLOC(2,IZLAY(IL),ZLAY(IL))
      READ(12,*) POR(NZ)
      READ(12,*) THW(NZ)
      THA(NZ)=POR(NZ)-THW(NZ)
      READ(12,*) TA(NZ)
      READ(12,*) BD(NZ)
      AL(NL)=0.0
      ALT(NL)=0.0
      IF(IDISP.EQ.1) THEN
      IF(IDIM.EQ.1 .OR. IDIM.EQ.3) READ(12,*) AL(NL)
      IF(IDIM.EQ.2 .OR. IDIM.EQ.3) READ(12,*) ALT(NL)
      END IF
      DO 830 IZ=1,NZ
      POR(IZ)=POR(NZ)
      THW(IZ)=THW(NZ)
      THA(IZ)=THA(NZ)
      TA(IZ)=TA(NZ)
      TW(IZ)=(THW(NZ)**(7.0/3.0))/(POR(NZ)**2)
      BD(IZ)=BD(NZ)
 830  CONTINUE
      ZLAY(NL)=Z(NZ)
      END IF
C
      IF(ISTRAT.EQ.1) THEN
      NL=1
      IL=NL
      CALL NODLOC(2,IZLAY(IL),ZLAY(IL))
      OPEN(UNIT=16,FILE='POR.MAP')
      OPEN(UNIT=17,FILE='THW.MAP')
      OPEN(UNIT=18,FILE='THA.MAP')
      OPEN(UNIT=19,FILE='TA.MAP')
      OPEN(UNIT=20,FILE='TW.MAP')
      OPEN(UNIT=29,FILE='BD.MAP')
      READ(16,206) (POR(IZ),IZ=1,NZ)
      READ(17,206) (THW(IZ),IZ=1,NZ)
      READ(18,206) (THA(IZ),IZ=1,NZ)
      READ(19,206) (TA(IZ),IZ=1,NZ)
      READ(29,206) (BD(IZ),IZ=1,NZ)
      READ(20,206) (TW(IZ),IZ=1,NZ)
      AL(NL)=0.0
      ALT(NL)=0.0
      IF(IDISP.EQ.1) THEN
      IF(IDIM.EQ.1 .OR. IDIM.EQ.3) READ(12,*) AL(NL)
      IF(IDIM.EQ.2 .OR. IDIM.EQ.3) READ(12,*) ALT(NL)
      END IF
      ZLAY(NL)=Z(NZ)
      END IF
C
      IF(ISTRAT.EQ.2) THEN
      READ(12,*) NL
      DO 415 IL=1,NL
      IF(NL.NE.1) THEN
      READ(12,83) ZLAY(IL)
      CALL NODLOC(2,IZLAY(IL),ZLAY(IL))
      END IF
      READ(12,*) PORL(IL)
      READ(12,*) THWL(IL)
      READ(12,*) TAL(IL)
      READ(12,*) BDL(IL)
      AL(IL)=0.0
      ALT(IL)=0.0
      IF(IDISP.EQ.1) THEN
      IF(IDIM.EQ.1 .OR. IDIM.EQ.3) READ(12,*) AL(IL)
      IF(IDIM.EQ.2 .OR. IDIM.EQ.3) READ(12,*) ALT(IL)
      END IF
 415  CONTINUE
      END IF
C
      IF(ISTRAT.EQ.2) THEN
      IL=1
      DO 497 IZ=1,NZ
      IF(Z(IZ).GE.Z(IZLAY(IL))) IL=IL+1
      IF(IL.GT.NL) IL=NL
      THW(IZ)=THWL(IL)
      POR(IZ)=PORL(IL)
      THAL(IL)=PORL(IL)-THWL(IL)
      THA(IZ)=THAL(IL)
      TA(IZ)=TAL(IL)
      TW(IZ)=(THWL(IL)**(7.0/3.0))/(PORL(IL)**2)
      BD(IZ)=BDL(IL)
 497  CONTINUE
      END IF
C
      IF(ISTRAT.EQ.1) THEN
      IF(IDISP.EQ.0) THEN
      READ(12,968) ITIME
      ELSE
      READ(12,968) ITIME
      END IF
      ELSE
      READ(12,84) ITIME
      END IF
      READ(12,85) DT1
      DT1=DT1*3600
      IF(ITIME.EQ.0) THEN
      DT2=DT1
      DTM=1.0
      TRANS=TEND
      ELSE
      READ(12,*) DT2
      DT2=DT2*3600
      READ(12,*) IDT
      READ(12,83) TRANS
      TRANS=TRANS*3600
      IF(IDT.EQ.1) THEN
      READ(12,*) DTM
      ELSE
      DTM=1.0
      END IF
      END IF
      READ(12,*) TEND
      TEND=TEND*3600
      READ(12,*) ISS
      READ(12,82) NITER
      READ(12,*) EPS
      READ(12,87) IPROJ
      ISNAP=0
      READ(12,844) IOUT
C
      IF(IOUT.EQ.0) THEN
      TSNAP=TEND
      READ(12,85) YPR1
      YPR1=YPR1*3600
      ELSE
      READ(12,82) ISNAP
      READ(12,85) TSNAP
      TSNAP=TSNAP*3600
      END IF
C
      IF(IOUT.EQ.0 .OR. ISNAP.EQ.0) THEN
      READ(12,*) NW
      DO 101 IW=1,NW
      IF(IDIM.EQ.1) RVW(IW)=R(2)
      IF(IDIM.EQ.1) READ(12,83) ZVW(IW)
      IF(IDIM.GE.2) READ(12,83) RVW(IW)
      IF(IDIM.EQ.2) ZVW(IW)=Z(2)
      IF(IDIM.EQ.3) READ(12,*) ZVW(IW)
 101  CONTINUE
      END IF
C
C
      UFLX=0.0
      DO 898 IK=1,NK
C     
      IF(IK.EQ.1) THEN
      READ(12,84) IOUTOPT(IK)
      ELSE
      READ(12,945) IOUTOPT(IK)
      END IF
C
C   IF OUTPUT DATA IS DESIRED (IOUTOPT(IK)=1) THEN READ AND
C   OPEN OUTPUT FILES (NAMES SPECIFIED BY USER)
C
      IF(IOUTOPT(IK).EQ.1) THEN
C
C  OUTPUT FILES FOR ENTIRE MODEL DOMAIN DATA (ISNAP=1)
C
      IF(ISNAP.EQ.1) THEN
	IF(IK.EQ.1) THEN
      READ(12,256) FNAMEOUT1
      OPEN(UNIT=60,FILE=FNAMEOUT1)
      END IF
      IF(IK.EQ.2) THEN
      READ(12,256) FNAMEOUT2
      OPEN(UNIT=61,FILE=FNAMEOUT2)
      END IF
      IF(IK.EQ.3) THEN
      READ(12,256) FNAMEOUT3
      OPEN(UNIT=62,FILE=FNAMEOUT3)
      END IF
      IF(IK.EQ.4) THEN
      READ(12,256) FNAMEOUT4
      OPEN(UNIT=63,FILE=FNAMEOUT4)
      END IF
      IF(IK.EQ.5) THEN
      READ(12,256) FNAMEOUT5
      OPEN(UNIT=64,FILE=FNAMEOUT5)
      END IF
      IF(IK.EQ.6) THEN
      READ(12,256) FNAMEOUT6
      OPEN(UNIT=65,FILE=FNAMEOUT6)
      END IF
      IF(IK.EQ.7) THEN
      READ(12,256) FNAMEOUT7
      OPEN(UNIT=66,FILE=FNAMEOUT7)
      END IF
      IF(IK.EQ.8) THEN
      READ(12,256) FNAMEOUT8
      OPEN(UNIT=67,FILE=FNAMEOUT8)
      END IF
C
C  FROM SPECIFIED LOCATIONS (ISNAP=0 OR IOUT=0)
C
      ELSE
      DO 102 IW=1,NW
      IF(IK.EQ.1) THEN
      IF(IW.EQ.1) THEN
      READ(12,256) FNAMEOUT1
      OPEN(UNIT=60,FILE=FNAMEOUT1)
      END IF
      IF(IW.EQ.2) THEN
      READ(12,257) FNAMEOUT9
      OPEN(UNIT=68,FILE=FNAMEOUT9)
      END IF
      IF(IW.EQ.3) THEN
      READ(12,257) FNAMEOUT17
      OPEN(UNIT=76,FILE=FNAMEOUT17)
      END IF
      END IF
      IF(IK.EQ.2) THEN
      IF(IW.EQ.1) THEN
      READ(12,256) FNAMEOUT2
      OPEN(UNIT=61,FILE=FNAMEOUT2)
      END IF
      IF(IW.EQ.2) THEN
      READ(12,257) FNAMEOUT10
      OPEN(UNIT=69,FILE=FNAMEOUT10)
      END IF
      IF(IW.EQ.3) THEN
      READ(12,257) FNAMEOUT18
      OPEN(UNIT=77,FILE=FNAMEOUT18)
      END IF
      END IF
      IF(IK.EQ.3) THEN
      IF(IW.EQ.1) THEN
      READ(12,256) FNAMEOUT3
      OPEN(UNIT=62,FILE=FNAMEOUT3)
      END IF
      IF(IW.EQ.2) THEN
      READ(12,257) FNAMEOUT11
      OPEN(UNIT=70,FILE=FNAMEOUT11)
      END IF
      IF(IW.EQ.3) THEN
      READ(12,257) FNAMEOUT19
      OPEN(UNIT=78,FILE=FNAMEOUT19)
      END IF
      END IF
      IF(IK.EQ.4) THEN
      IF(IW.EQ.1) THEN
      READ(12,256) FNAMEOUT4
      OPEN(UNIT=63,FILE=FNAMEOUT4)
      END IF
      IF(IW.EQ.2) THEN
      READ(12,257) FNAMEOUT12
      OPEN(UNIT=71,FILE=FNAMEOUT12)
      END IF
      IF(IW.EQ.3) THEN
      READ(12,257) FNAMEOUT20
      OPEN(UNIT=79,FILE=FNAMEOUT20)
      END IF
      END IF
      IF(IK.EQ.5) THEN
      IF(IW.EQ.1) THEN
      READ(12,256) FNAMEOUT5
      OPEN(UNIT=64,FILE=FNAMEOUT5)
      END IF
      IF(IW.EQ.2) THEN
      READ(12,257) FNAMEOUT13
      OPEN(UNIT=72,FILE=FNAMEOUT13)
      END IF
      IF(IW.EQ.3) THEN
      READ(12,257) FNAMEOUT21
      OPEN(UNIT=80,FILE=FNAMEOUT21)
      END IF
      END IF
      IF(IK.EQ.6) THEN
      IF(IW.EQ.1) THEN
      READ(12,256) FNAMEOUT6
      OPEN(UNIT=65,FILE=FNAMEOUT6)
      END IF
      IF(IW.EQ.2) THEN
      READ(12,257) FNAMEOUT14
      OPEN(UNIT=73,FILE=FNAMEOUT14)
      END IF
      IF(IW.EQ.3) THEN
      READ(12,257) FNAMEOUT22
      OPEN(UNIT=81,FILE=FNAMEOUT22)
      END IF
      END IF
      IF(IK.EQ.7) THEN
      IF(IW.EQ.1) THEN
      READ(12,256) FNAMEOUT7
      OPEN(UNIT=66,FILE=FNAMEOUT7)
      END IF
      IF(IW.EQ.2) THEN
      READ(12,257) FNAMEOUT15
      OPEN(UNIT=74,FILE=FNAMEOUT15)
      END IF
      IF(IW.EQ.3) THEN
      READ(12,257) FNAMEOUT23
      OPEN(UNIT=82,FILE=FNAMEOUT23)
      END IF
      END IF
      IF(IK.EQ.8) THEN
      IF(IW.EQ.1) THEN
      READ(12,256) FNAMEOUT8
      OPEN(UNIT=67,FILE=FNAMEOUT8)
      END IF
      IF(IW.EQ.2) THEN
      READ(12,257) FNAMEOUT16
      OPEN(UNIT=75,FILE=FNAMEOUT16)
      END IF
      IF(IW.EQ.3) THEN
      READ(12,257) FNAMEOUT24
      OPEN(UNIT=83,FILE=FNAMEOUT24)
      END IF
      END IF
 102  CONTINUE
      END IF
      END IF
C
      IF(IOUTOPT(IK).EQ.0) READ(12,89) IREF(IK)
      IF(IOUTOPT(IK).EQ.1) READ(12,87) IREF(IK)
C
      READ(12,71) IFLX(IK)
C
C
C  OPEN OUTPUT FLUX DATA FILES (optional)
C
      IF(IFLX(IK).EQ.1) THEN
      UFLX=1.0
	IF(IK.EQ.1) OPEN(UNIT=50,FILE='FLXDT.1')
      IF(IK.EQ.2) OPEN(UNIT=51,FILE='FLXDT.2')
      IF(IK.EQ.3) OPEN(UNIT=52,FILE='FLXDT.3')
      IF(IK.EQ.4) OPEN(UNIT=53,FILE='FLXDT.4')
      IF(IK.EQ.5) OPEN(UNIT=54,FILE='FLXDT.5')
      IF(IK.EQ.6) OPEN(UNIT=55,FILE='FLXDT.6')
      IF(IK.EQ.7) OPEN(UNIT=56,FILE='FLXDT.7')
      IF(IK.EQ.8) OPEN(UNIT=57,FILE='FLXDT.8')
      END IF
C
C     
 898  CONTINUE
C
	IF(UFLX.GT.0) THEN
      READ(12,998) YPR2
	YPR2=YPR2*3600
      ELSE
      YPR2=1E20
      END IF
C
      IF(ISTRAT.EQ.2) THEN
      DO 667 IL=1,NL
      CALL NODLOC(2,IZLAY(IL),ZLAY(IL))
 667  CONTINUE
      END IF
      IF(IOUT.EQ.0 .OR. ISNAP.EQ.0) THEN
      DO 599 IW=1,NW
      CALL NODLOC(1,IRVW(IW),RVW(IW))
      CALL NODLOC(2,IZVW(IW),ZVW(IW))
 599  CONTINUE
      END IF
C
C
C  MENU FOR READING IN DATA FOR ANALYTICAL SOLUTIONS
C
      ELSE
      WRITE(*,303)
 303  FORMAT (/72('*')/20X,'EXECUTING THE ANALYTICAL SOLUTION'/72('*')/)
      OPEN(UNIT=12,FILE=FNAMEMIF)
      READ(12,846) IBC0
      IF(IBC0.EQ.4) THEN
      READ(12,*) UW
      UW=UW/1.0E6
      READ(12,86) BP
      READ(12,*) DP
      READ(12,86) UP
      UP=UP/1.0E6
      END IF
      IF(IBC0.EQ.3) THEN
      READ(12,*) FLUX
      READ(12,*) BP
      READ(12,*) DP
      READ(12,86) UP
      UP=UP/1.0E6
      END IF
      IF(IBC0.EQ.2) THEN
      READ(12,*) UW
      READ(12,86) UP
      UW=UW/1.0E6
      UP=UP/1.0E6
      END IF
      IF(IBC0.EQ.1) THEN
      READ(12,*) FLUX
      READ(12,*) UP
      UP=UP/1.0E6
      END IF
      IF(IBC0.LE.2) READ(12,*) INOPT
      IF(IBC0.GE.3) READ(12,87) INOPT
      IF(INOPT.EQ.0) XM0=0
      IF(INOPT.LE.1) READ(12,88) XB0
      XB0=XB0/1.0E6
      IF(INOPT.EQ.2) THEN
      READ(12,254) FNAMEICDAT
 254  FORMAT(/////61X,A20)
      OPEN(UNIT=6,FILE=FNAMEICDAT)
      READ(6,*) NDATIN
      END IF
      READ(12,83) DBIN
      READ(12,*) HENRY
      READ(12,86) SWPC
      READ(12,83) XL
      READ(12,*) VOID
      READ(12,*) WAT
      READ(12,*) AIR
      READ(12,*) TOR
      READ(12,*) BULK
      READ(12,*) DEFF
C
      READ(12,84) IOUT
      IF(IOUT.EQ.0) THEN
      READ(12,85) TMAX
      READ(12,*) DELT
      END IF
      IF(IOUT.EQ.1) THEN
      READ(12,82) ISNAP
      READ(12,85) TSNAP
      IF(ISNAP.EQ.1) THEN
      READ(12,*) XLL
      READ(12,80) NIPTS
 80   FORMAT(I10)
      END IF
      END IF
      IF(IOUT.EQ.0 .OR. ISNAP.EQ.0) READ(12,*) ZOUT
      IF(IOUT.EQ.2) ISNAP=1
      IF(IOUT.LE.1) THEN
      IF(IOUT.EQ.0 .OR. ISNAP.EQ.0) READ(12,255) FNAMEOUT1
      IF(IOUT.EQ.1 .AND. ISNAP.EQ.1) READ(12,253) FNAMEOUT1
 253  FORMAT(/52X,A20)
 255  FORMAT(/53X,A20)
 256  FORMAT(///54X,A20)
 257  FORMAT(/54X,A20)
      OPEN(UNIT=60,FILE=FNAMEOUT1)
      ELSE
      READ(12,258) FNAMECAL
 258  FORMAT(////64X,A20)
      OPEN(UNIT=11,FILE=FNAMECAL)
      READ(11,*) NDATCAL
      END IF
C
 70   FORMAT(////I10)
 71   FORMAT(//////I10)
 78   FORMAT(//////////E10.4)
 79   FORMAT(/////////I10)
 81   FORMAT(//////////I10)
 82   FORMAT(//I10)
 83   FORMAT(///E10.4)
 84   FORMAT(///I10)
 85   FORMAT(//E10.4)
 86   FORMAT(/E10.4)
 87   FORMAT(/I10)
 88   FORMAT(////E10.4)
 89   FORMAT(/////I10)
 833  FORMAT(///////E10.4)
 844  FORMAT(//////I10)
 846  FORMAT(////////////I10)
 855  FORMAT(/////////E10.4)
 856  FORMAT(/////E10.4)
 889  FORMAT(//////E10.4)
 922  FORMAT(///////////I10)
 923  FORMAT(//////////////I10)
 924  FORMAT(/////////////////I10)
 925  FORMAT(//////////////////I10)
 933  FORMAT(///////I10)
 945  FORMAT(////////I10)
 946  FORMAT(////////////I10)
 967  FORMAT(///////////////////I10)
 968  FORMAT(///////////////I10)
 998  FORMAT(////////E10.4)
 999  FORMAT(////////////E10.4)
C
 206  FORMAT(11X,E11.4)
 209  FORMAT(10G11.4)
 218  FORMAT(10G13.4)
C
      END IF
      END IF
C
      IF(IMOD.EQ.1) THEN
      TIME=0.0
      SKIP=0.0
      SKIP2=0.0
C
C    TIME LOOP
C
      DT=DT1
      IIX=0
      DO 100 I=1,1000000000
      IF(I.EQ.1) ICNTER=0
      IF(I.EQ.1) IIX=0
      IF(I.EQ.2) ITFIX=ITER0
      IF(IDT.EQ.2) GO TO 777
      IF(TIME.LT.TRANS+1.0) DT=DT*DTM
      IF(DT.GT.DT2) DT=DT2
      IF(TIME.GT.TRANS) DT=DT2
      GO TO 778
  777 IF(I.EQ.1) DT=DT1
      IF(I.EQ.1) GO TO 778
      U1=ITFIX
      U2=ITER0
      DT=(U1/U2)*DT1
      IF(DT.GT.DT2) DT=DT2
  778 TIME=TIME+DT
      IF(ICNTER.EQ.1) GO TO 1954
      IF(IOUT.EQ.1 .AND. TIME.GE.TSNAP) THEN
      IF(TIME.GT.TSNAP) THEN
      TIME=TIME-TSNAP
      TIME=TEND
      END IF
      ICNTER=ICNTER+1
      END IF
      IF(TIME.GT.TEND) GO TO 1954
      SKIP=SKIP+DT
      SKIP2=SKIP2+DT
C
C
C  IF IMMISCIBLE PLUME CONCENTRATION IS TO REMAIN CONSTANT
C  THEN SKIP IMMISCIBLE PHASE CONCENTRATION ADJUSTMENT BELOW.
C
      IF(KONS.EQ.0) GO TO 543
C
C    REDEFINE IMMISCIBLE PHASE COMPOSITION AND CONTENT BASED
C    ON CONSTITUENT SPECIFIC MASS FLUX INTEGRATED OVER LAST TIME STEP
C
C    FIRST GET CHANGE IN VOLUMETRIC CONTENT ACCOUNTING FOR CONSTITUENT
C    FLUX AND BIDEGRADATION DUE TO O2 FLUX INTO IMMISCIBLE PLUME
C
	IF(IOPT.EQ.3 .AND. THI0.GT.0) THEN
      DTHI0=0.0
      IF(I.EQ.1) RHOIM=1.0E10
      IF(IFLAG.EQ.4) THEN
	DO 14 IK=1,NK-1
      U1=XIK0(IK)/RHOIM
      U2=-FLXDT(NK)/RK(IK)
      BMLX(IK)=U1*U2
      U2=U2*VK(IK)
	DTHI0=DTHI0 + U1*U2
   14 CONTINUE
      END IF
	DO 15 IK=1,NK-1
      IF(I.EQ.1 .OR. FLXDT(IK).GT.0.0) FLXDT(IK)=0.0
      DTHI0=DTHI0+FLXDT(IK)*VK(IK)
   15 CONTINUE
	IF(NK.EQ.1) DTHI0=DTHI0+FLXDT(1)*VK(1)
C     
      DTHI0=DTHI0/VIMM
      U1=THI0
      THI0=THI0+DTHI0
C
	IF(THI0.LT.1.0E-03) THEN
      THI0=0.0
	RHOIM=1E10
	SUM=1E10
	DO 39 IK=1,NK
	XIK0(IK)=0.0E-10
   39 CONTINUE
	GO TO 543
      END IF
C
C    GET CHANGE IN XIK0, DENOMINATOR OF MOLE FRACTION, DENSITY
C
      SUM=0.0
      RHOIM=0.0
	DO 16 IK=1,NK-1
      IF(IFLAG.NE.4) BMLX(IK)=0.0
	U3=(FLXDT(IK)+BMLX(IK))/VIMM
	XIK0(IK)=(U3 + U1*XIK0(IK))/THI0
	IF(XIK0(IK).LE.0) THEN
	XIK0(IK)=0.0E-10
	SUM=1E10
	RHOIM=1E10
	ELSE
	SUM=SUM+XIK0(IK)/WK(IK)
      RHOIM=RHOIM+XIK0(IK)
	END IF
   16 CONTINUE
      END IF
C
  820 FORMAT(4E13.4,I5)
  543 CONTINUE
C
C    REDEFINE TOTAL DEGRADABLE CONTAMINANT CONCENTRATION
C    OR IF CONDUCTING MASS BALANCE ..
C
      DO 17 IZ=1,NZ
      DO 17 IR=1,NR
      TOT(IR,IZ)=0.0
      DO 18 IK=1,NK
      IF(ICON(IK).EQ.4 .OR. ICON(IK).GE.6) THEN
	IF(IBIO(IK).GE.3) THEN
      U1=((THW(IZ)/HAW(IK))+THA(IZ)+(HSW(IK)*BD(IZ)/HAW(IK)))*
     1Y0(IR,IZ,IK)
      TOT(IR,IZ)=TOT(IR,IZ)+U1
      END IF
	END IF
   18 CONTINUE
   17 CONTINUE
C
C
C  STEADY-STATE REFERENCE CALCULATIONS
C
C
      IF(I.GT.1) GO TO 435
      IU1=40
      DO 436 IK=1,NK
	IF(IREF(IK).EQ.0) GO TO 434
C
      IF(ABS(DARCY).GT.1E-12) THEN
C
C  STEADY-STATE REFERENCE CALCULATIONS CONSIDERING ADVECTION (RECHARGE)
C
C
C   1-D STEADY-STATE REFERENCE CALCULATION (Z-DIRECTION)
C   ASSUMING CONSTANT FLUX SOURCE ACROSS H2O TABLE (IOPT=1)
C
      IF(IOPT.EQ.1) THEN
      H1=HAW(IK)
      D1=DKW(IK)
      D2=DKA(2,2,IK)
      U3=D2*THA(2)*TA(2)
      U3=U3+D1*THW(2)*TW(2)/H1
      U3=U3+ABS(DARCY/THW(2))*AL(1)/H1
      U3=(-DARCY/(H1*U3))
      U4=U3*Z(NZ)
      U4=EXP(-U4)
      U5=FLX(1,IK)*H1/DARCY
      DO 430 IZ=IZHI,NZ
      U6=EXP(-U3*Z(IZ))
      Y1(IZ,IK)=((ATCONC(IK)-U5)*(U6/U4))+U5
 430  CONTINUE
      GO TO 30
      END IF
C
C   1-D STEADY STATE REFERENCE CALCULATION (Z-DIRECTION)
C   ASSUMING CONSTANT CONCENTRATION SOURCE (IOPT=2,IOPT=3)
C
      IF(IOPT.EQ.2 .OR. IOPT.EQ.3) THEN
      H1=HAW(IK)
      D1=DKW(IK)
      D2=DKA(2,IZHI,IK)
      U2=ATCONC(IK)
      U3=-D2*THA(IZHI)*TA(IZHI)
      U3=U3-D1*THW(IZHI)*TW(IZHI)/H1
      U3=U3-ABS(DARCY/THW(IZHI))*AL(1)/H1
      U3=-(DARCY/H1)/U3
      U4=U3*Z(IZHI)
      U5=U3*Z(NZ)
      U4=EXP(U4)
      U5=EXP(U5)
      DO 425 IZ=IZHI,NZ
      U6=EXP(U3*Z(IZ))
      IF(IOPT.EQ.3) THEN
      U1=(((XIK0(IK)/WK(IK))/SUM)*HWIK(IK))*H1
      ELSE
      U1=Y0(2,IZHI,IK)
      END IF
      Y1(IZ,IK)=((U2-U1)/(U5-U4))*(U6-U4)+U1
      IF(Y1(IZ,IK).LE.0) Y1(IZ,IK)=1.0E-20
 425  CONTINUE
      GO TO 30
      END IF
C
C
      ELSE
C
C  THE FOLLOWING ARE STEADY STATE SOLUTIONS TO THE DIFFUSIVE TRANSPORT
C  EQUATION WITHOUT CONSIDERING THE ADVECTIVE (RECHARGE) TERM.
C
C  1-D STEADY-STATE SOLUTION FOR CONSTANT VERTICAL FLUX (IOPT=1)
C
      IF(IOPT.EQ.1) THEN
      H1=HAW(IK)
      D1=DKW(IK)
      D2=DKA(2,IZHI,IK)
      U3=-D2*THA(IZHI)*TA(IZHI)
      U3=U3-D1*THW(IZHI)*TW(IZHI)/H1
      U3=U3-ABS(DARCY/THW(IZHI))*AL(NL)/H1
      DO 67 IZ=IZHI,NZ
      U5=(-FLX(1,IK)/U3)*(Z(NZ)-Z(IZ))+ATCONC(IK)
      Y1(IZ,IK)=U5
 67   CONTINUE
      GO TO 30
      END IF
C
C  1-D STEADY-STATE SOLUTION FOR CONSTANT CONC. BOUNDARY (IOPT=2,3)
C
      IF(IOPT.EQ.2) THEN
      DO 47 IZ=IZHI,NZ
      U1=Y0(2,IZHI,IK)/(Z(NZ)-Z(IZHI))
      U2=Z(NZ)-Z(IZ)
      U2=U1*U2
      Y1(IZ,IK)=U2
 47   CONTINUE
      END IF
C
      IF(IOPT.EQ.3) THEN
      IF(IDIM.EQ.1) THEN
      DO 26 IZ=IZHI,NZ
      U1=HWIK(IK)*HAW(IK)/(Z(NZ)-Z(IZHI))
      U2=Z(NZ)-Z(IZ)
      U2=U1*U2
      Y1(IZ,IK)=U2
   26 CONTINUE
      ELSE
      DO 27 IR=IRIM,NR
      U1=(HWIK(IK)*HAW(IK))/DLOG(R(IRIM)/R(NR))
      U2=DLOG(R(IR)/R(NR))
      U2=U1*U2
      Y2(IR,IK)=U2
   27 CONTINUE
      GO TO 30
      END IF
      END IF
C
      END IF
C
C   1-D STEADY-STATE REFERENCE CALCULATION (R-DIRECTION)
C   CONSTANT RADIAL FLUX SOURCE (IOPT=4)
C
      IF(IOPT.EQ.4) THEN
      H1=HAW(IK)
      D1=DKW(IK)
      D2=DKA(2,2,IK)
      U3=-D2*THA(2)*TA(2)
      U3=U3-D1*THW(2)*TW(2)/H1
      U3=U3-ABS(DARCY/THW(2))*AL(1)/H1
      U6=-FLX(1,IK)/U3*DLOG(R(NR))+ATCONC(IK)
      Y2(1,IK)=U6
      DO 31 IR=IRIM,NR
      U4=DLOG(R(NR)/R(IR))
      U5=ATCONC(IK)+U4*RIM*(-FLX(1,IK)/U3)
      Y2(IR,IK)=U5
 31   CONTINUE
      END IF
C
C
 30   CONTINUE
C
C
C   OPEN FILES FOR REFERENCE CALCULATIONS
C
      IF(NK.GE.1 .AND. IREF(1).EQ.1) OPEN(UNIT=40,FILE='REF.1')
      IF(NK.GE.2 .AND. IREF(2).EQ.1) OPEN(UNIT=41,FILE='REF.2')
      IF(NK.GE.3 .AND. IREF(3).EQ.1) OPEN(UNIT=42,FILE='REF.3')
      IF(NK.GE.4 .AND. IREF(4).EQ.1) OPEN(UNIT=43,FILE='REF.4')
      IF(NK.GE.5 .AND. IREF(5).EQ.1) OPEN(UNIT=44,FILE='REF.5')
      IF(NK.GE.6 .AND. IREF(6).EQ.1) OPEN(UNIT=45,FILE='REF.6')
      IF(NK.GE.7 .AND. IREF(7).EQ.1) OPEN(UNIT=46,FILE='REF.7')
      IF(NK.EQ.8 .AND. IREF(8).EQ.1) OPEN(UNIT=47,FILE='REF.8')
C
C   WRITE REFERENCE SOLUTIONS TO OUTPUT FILES
C
      WRITE(IU1,229)
      IF(IDIM.EQ.1) WRITE(IU1,230) (Z(IZ),Y1(IZ,IK),IZ=IZHI,NZ)
      IF(IDIM.EQ.2) WRITE(IU1,230) (R(IR),Y2(IR,IK),IR=IRIM,NR)
      IU1=IU1+1
 434  CONTINUE
      IU1=IU1+1
 436  CONTINUE
C
 229  FORMAT('DISTANCE (CM)',5X,'CONCENTRATION (G/CM3)'/13('-'),5X,21('-
     1')/)
 230  FORMAT(1X,F8.2,14X,E10.4)
C
C
 435  CONTINUE
C
C
C
C
C   SOLVE FOR EACH CONSTITUENT
C
      WCT=0.0
      IU2=50
      IU3=30
      IU4=60
      DO 90 IK=1,NK
      IND=0
C
C    APPLY BOUNDARY CONDITIONS FOR THIS TIME STEP
C
C
      CALL BDRY
C
C
C    DEFINE COEFFICIENTS OF TRANSPORT EQUATION ON INTERIOR
C    FOR STEADY HYDROLOGY AND UNCOUPLED EQUILIBRIUM CHEMISTRY
C    THESE COEFFICIENTS ARE CONSTANT W.R.T. TIME BUT IN GENERAL
C    WILL BE TIME DEPENDENT
C
C
      CALL COEF1
C
C    OBTAIN PROJECTION OR ESTIMATE OF CONCENTRATIONS AT NEXT TIME STEP
C    NEEDED FOR GAUSS-SEIDEL MATRIX SOLVER.  THIS CAN BE DONE IN SEVERAL WAYS
C    AS DETERMINED IN THE SUBROUTINE PROJ.
C
      CALL PROJ
C
C    NOW GAUSS-SIEDEL REFINMENT BASED ON CRANK NICOLSON DIFF. APPROX.
C
C
      CALL GAUSDL
C
C    EVALUATE FLUXES AT BOUNDARIES AND VOLUME INTEGRALS
C
C
C   ITERATIVE DO LOOP SET AT IU2=50 PRIOR TO CONSITUENT LOOP
C
      IF(IFLX(IK).EQ.1) THEN
      IF(I.EQ.1) THEN
      WRITE(IU2,908) IK
      WRITE(IU2,909)
      END IF
      END IF
C
C
      CALL FATE 
C
C
      IF(I.EQ.1) GO TO 94
      IF(TIME.LT.TSNAP .AND. IOUT.EQ.1) GO TO 93
      IF(SKIP.LT.YPR1) GO TO 93
 94   CALL OUTPUT
      IF(IK.EQ.NK) SKIP=0.0
      IF(I.EQ.1) SKIP=DT*1
 93   CONTINUE
C
C
C  RESET FOR NEXT TIME STEP
C
      DO 91 IZ=1,NZ
      DO 91 IR=1,NR
      DTY(IR,IZ,IK)=(Y(IR,IZ,IK)-Y0(IR,IZ,IK))/DT
      Y0(IR,IZ,IK)=Y(IR,IZ,IK)
      Y3(IR,IZ,IK)=RBIO(IR,IZ)
   91 CONTINUE
      IU2=IU2+1
      IU3=IU3+1
      IU4=IU4+1
   90 CONTINUE
  100 CONTINUE
      ELSE
      CALL ANALYTICAL
      END IF
 1954 CONTINUE
C
C
  908 FORMAT('CONSTITUENT= ',I2,' TIME (HRS),',' FLUX (G/CM2-S)'/)
  909 FORMAT(4X,'TIME',7X,'ATMOSPHERE',7X,'AQUIFER',6X,'SOURCE-TOP',5
     1X,'SOURCE-BOT.'/4X,4('-'),7X,10('-'),7X,7('-'),6X,10('-'),5X
     1,11('-'))
      END
C
C
C
      SUBROUTINE PREMAIN
C
      CHARACTER TITLE*70,FNAMEPOR*38,FNAMETHW*38,M*30,
     1FNAMETA*38,FNAMEBD*38,FNAMEICDAT*38,FNAMEMIF*38,FNAMECAL*38,
     2FNAMEOUT1*38,FNAMEOUT2*38,FNAMEOUT3*38,FNAMEOUT4*38,FNAMEOUT5*38,
     3FNAMEOUT6*38,FNAMEOUT7*38,FNAMEOUT8*38,FNAMEOUT9*38,FNAMEOUT10*38,
     4FNAMEOUT11*38,FNAMEOUT12*38,FNAMEOUT13*38,FNAMEOUT14*38,
     5FNAMEOUT15*38,FNAMEOUT16*38,FNAMEOUT17*38,FNAMEOUT18*38,
     6FNAMEOUT19*38,FNAMEOUT20*38,FNAMEOUT21*38,FNAMEOUT22*38,
     7FNAMEOUT23*38,FNAMEOUT24*38,
     8FNAMEBCDAT*38
      COMMON/CHAR/ M,FNAMETA,FNAMEBD,FNAMECAL,FNAMEMIF,
     3FNAMEICDAT,FNAMEPOR,FNAMETHW,FNAMEBCDAT,TITLE,
     5FNAMEOUT1,FNAMEOUT2,FNAMEOUT3,FNAMEOUT4,FNAMEOUT5,
     6FNAMEOUT6,FNAMEOUT7,FNAMEOUT8,FNAMEOUT9,FNAMEOUT10,
     7FNAMEOUT11,FNAMEOUT12,FNAMEOUT13,FNAMEOUT14,FNAMEOUT15,FNAMEOUT16,
     8FNAMEOUT17,FNAMEOUT18,FNAMEOUT19,FNAMEOUT20,FNAMEOUT21,FNAMEOUT22,
     9FNAMEOUT23,FNAMEOUT24
      COMMON/INT/IFIL,IMOD,IMILQ,IOPT,INOPT,IBC0,IOUT,ICOMP,ISURF,
     1NDATIN,NDATCAL,NIPTS,ISNAP,ITIME,ICONX,IWARN,ICNTER,IDIM,
     2ISTRAT,IBDRY,INCHECK,IDISP,IWAT,IFLAG,IN,JN,IRMAX,IHSAT
C
C
C  THIS SUBROUTINE ALLOWS THE USER TO CREATE A NEW INPUT
C  FILE OR ACCESS AN EXISTING ONE. IN ADDITION, THE USER
C  IS ALLOWED TO SELECT BETWEEN THE NUMERICAL OR ANALYTICAL
C  MODEL SOLVER.
C
      WRITE(*,400)
      WRITE(*,410)
      READ(*,*) IFIL
      IF(IFIL.EQ.1) THEN
      WRITE(*,440)
      READ(*,*) IMOD
      ELSE
      WRITE(*,420)
      READ(*,430) FNAMEMIF
      END IF
C
 400  FORMAT(72('-')//6X,'R-UNSAT:  A COMPUTER MODEL FOR THE SIMULATION
     1OF REACTIVE,'/7X,'MULTISPECIES TRANSPORT IN THE UNSATURATED ZONE (
     2Ver 1.0)'//15X,'DEVELOPED BY:  MATTHEW A. LAHVIS'//31X,'ARTHUR L.
     3BAEHR'/72('-')//)
 410  FORMAT(5X,'SELECT:'/15X,'1:  TO CREATE NEW MODEL INPUT DATA'//15
     1X,'2:  TO RUN R-UNSAT USING EXISTING MODEL INPUT'//)
 420  FORMAT(2X,'PLEASE TYPE IN THE NAME OF THE INPUT FILE WHICH YOU WIS
     1H TO ACCESS'//)
 430  FORMAT(A20)
 440  FORMAT(2X,'SELECT:'/15X,'1:  TO IMPLEMENT THE NUMERICAL SOLVER'/
     1/15X,'2:  TO IMPLEMENT THE ANALYTICAL SOLVER'//)
C
      RETURN
      END
C
C
      SUBROUTINE NEWNUM
C
C     A SUBROUTINE TO READ AND WRITE MODEL PARAMETERS
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER(NHR=501,NHZ=501,NHL=5,NHK=8,NHW=3,I9=NHK+1,
     1NHRZ=NHR+NHZ+1)
      CHARACTER TITLE*70,FNAMEPOR*38,FNAMETHW*38,M*30,
     1FNAMETA*38,FNAMEBD*38,FNAMEICDAT*38,FNAMEMIF*38,FNAMECAL*38,
     2FNAMEOUT1*38,FNAMEOUT2*38,FNAMEOUT3*38,FNAMEOUT4*38,FNAMEOUT5*38,
     3FNAMEOUT6*38,FNAMEOUT7*38,FNAMEOUT8*38,FNAMEOUT9*38,FNAMEOUT10*38,
     4FNAMEOUT11*38,FNAMEOUT12*38,FNAMEOUT13*38,FNAMEOUT14*38,
     5FNAMEOUT15*38,FNAMEOUT16*38,FNAMEOUT17*38,FNAMEOUT18*38,
     6FNAMEOUT19*38,FNAMEOUT20*38,FNAMEOUT21*38,FNAMEOUT22*38,
     7FNAMEOUT23*38,FNAMEOUT24*38,
     8FNAMEBCDAT*38
      COMMON/DEP0/ Y0,Y1,Y2,Y3,DTY
      COMMON/DEP/ Y,TOT,RBIO
      COMMON/CHAR/ M,FNAMETA,FNAMEBD,FNAMECAL,FNAMEMIF,
     3FNAMEICDAT,FNAMEPOR,FNAMETHW,FNAMEBCDAT,TITLE,
     5FNAMEOUT1,FNAMEOUT2,FNAMEOUT3,FNAMEOUT4,FNAMEOUT5,
     6FNAMEOUT6,FNAMEOUT7,FNAMEOUT8,FNAMEOUT9,FNAMEOUT10,
     7FNAMEOUT11,FNAMEOUT12,FNAMEOUT13,FNAMEOUT14,FNAMEOUT15,FNAMEOUT16,
     8FNAMEOUT17,FNAMEOUT18,FNAMEOUT19,FNAMEOUT20,FNAMEOUT21,FNAMEOUT22,
     9FNAMEOUT23,FNAMEOUT24
      COMMON/XNRNZNK/ BR,BZ,CR,CZ,PP,DKA,SUMDK
      COMMON/XNRNZ/ PT
      COMMON/XNZNK/ FIRF,A
      COMMON/XNRNK/ FIZT,FIZW,FLX
      COMMON/XNKNK/ DKAB
      COMMON/XNR/ R,BC
      COMMON/XNZ/ Z,TA,TW,BD,POR,THA,THW
      COMMON/YTRP/YTRAP,ZTRAP
      COMMON/XNK/  XIK0,HAW,HSW,RK,TIFIP,TIFB,TIFT,TIRBIO,TIFRF,
     1TMASS,TMASS0,CRY,VK,WK,HWIK,XMASSB,XMASST,ATCONC,IBIO,ICON,
     2TMASSW,DV,DKW,VC,VM,BMLX,FLXDT,IOUTOPT,IREF,IFLX
     3,RCON,RLAMBDA,RMAX,HSAT,GWAT,FTOP,FBOT,FRIM,DFLXDT
      COMMON/XNL/AL,ALT,ZLAY,PORL,TAL,THWL,THAL,BDL
      COMMON/XNW/RVW,ZVW
      COMMON/ARRAY/ XINIT,UINIT,XPT,YPT,SLPZ,SLPR,BZZ,BRR,SXLM
      COMMON/ISC/NR,NZ,NL,NK,NT,IRIM,IRASP,IZLOW,IZHI,IZBAS,IRVW,IZVW,
     1IPROJ,NITER,IRNORM,IZNORM,ITER,ITER0,ISS,IRFP,IW,IL,IK,IKK,I,
     2NW,IZLAY,JK,IDAT,NDAT,ICOUNT,IOX,IIX,ICUT,IDT,IU2,IU3,IU4,KONS
      COMMON/INT/IFIL,IMOD,IMILQ,IOPT,INOPT,IBC0,IOUT,ICOMP,ISURF,
     1NDATIN,NDATCAL,NIPTS,ISNAP,ITIME,ICONX,IWARN,ICNTER,IDIM,
     2ISTRAT,IBDRY,INCHECK,IDISP,IWAT,IFLAG,IN,JN,IRMAX,IHSAT
      COMMON/XSC/DT,DR,DZ,SUM,AR1,AR2,AR3,AR4,AZ1,AZ2,ATOX,RHOIM,CSA,
     1TIME,VIMM,DARCY,THI0,EPS,ENORM,ATM,ZBAS,ZWAT,ZSURF,ZLOW,ZHI,
     2DT1,DT2,DTM,TRANS,TEND,YPR1,YPR2,SKIP,SKIP2,TEMP,RIM,RF,DTHI0
      COMMON/CONS/FLUX,UP,UW,D,DS,GAM,B,C,XL,PI,XFD,BP,DP,WAT,AIR,
     1XMM,DBIN,XM0,XB0,YNM,TMAX,DELT,HENRY,SWPC,BULK,XLL,TSNAP,TOR,
     2XB,ZOUT,GASBOT
      COMMON/RC1/C6,C7
      COMMON/RC2/C1,C2,C3,C4,C5
C
C
C****DIMENSION THE FOLLOWING (NR,NZ,NHK+1)
C
      DIMENSION Y0(NHR,NHZ,I9),DTY(NHR,NHZ,I9),PP(NHR,NHZ,I9)
     1,BR(NHR,NHZ,I9),BZ(NHR,NHZ,I9),CR(NHR,NHZ,I9),CZ(NHR,NHZ,I9)
     2,C1(NHR,NHZ,I9),C2(NHR,NHZ,I9),C3(NHR,NHZ,I9),C4(NHR,NHZ,I9)
     3,C5(NHR,NHZ,I9),DKA(NHR,NHZ,I9),SUMDK(NHR,NHZ,I9)
     4,Y(NHR,NHZ,I9),Y3(NHR,NHZ,I9)
C
C****DIMENSION THE FOLLOWING (NR,NZ)
      DIMENSION TOT(NHR,NHZ),PT(NHR,NHZ)
      DIMENSION C6(NHR,NHZ),C7(NHR,NHZ),RBIO(NHR,NHZ)
C
C******DIMENSION THE FOLLOWING AS (NZ,NHK+1)
C
      DIMENSION FIRF(NHZ,I9),A(NHZ,I9),Y1(NHZ,I9)
C
C******DIMENSION THE FOLLOWING AS (NR,NHK+1)
C
      DIMENSION FIZT(NHR,I9),FIZW(NHR,I9),FLX(NHR,I9),Y2(NHR,I9)
C
C******DIMENSION THE FOLLOWING AS (I9,I9)
C
      DIMENSION DKAB(I9,I9)
C
C******DIMENSION THE FOLLOWING AS (NR+NZ)
C
      DIMENSION YTRAP(NHRZ),ZTRAP(NHRZ)
C
C******DIMENSION THE FOLLOWING AS (NHZ)
C
      DIMENSION Z(NHZ),POR(NHZ),TA(NHZ),TW(NHZ),THA(NHZ)
     1,THW(NHZ),BD(NHZ)
C
C******DIMENSION THE FOLLOWING AS (NHR)
C
      DIMENSION R(NHR),BC(NHR)
C
C******DIMENSION THE FOLLOWING AS (NL)
C
      DIMENSION AL(NHL),ALT(NHL),ZLAY(NHL),IZLAY(NHL),
     1PORL(NHL),THWL(NHL),THAL(NHL),TAL(NHL),BDL(NHL)
C
C********DIMENSION THE FOLLOWING AS (NW)
C
      DIMENSION RVW(NHW),ZVW(NHW),IRVW(NHW),IZVW(NHW)
C
C********DIMENSION THE FOLLOWING (NHK+1)
C
      DIMENSION TIFIP(I9),TIFB(I9),TIFT(I9),TIRBIO(I9),TIFRF(I9),
     1TMASS0(I9),TMASSW(I9),TMASS(I9),XMASSB(I9),XMASST(I9),CRY(I9)
     2,FTOP(I9),GWAT(I9),FBOT(I9),FRIM(I9),FLXDT(I9),DFLXDT(I9)
C
C*******DIMENSION THE FOLLOWING (NHK+2)
C
      DIMENSION WK(I9),VC(I9),VM(I9),DV(I9),IBIO(I9),ICON(I9)
C
C*******DIMENSION THE FOLLOWING (NK)
C
      DIMENSION XIK0(NHK),BMLX(NHK),HWIK(NHK),HAW(NHK),RK(NHK)
     1,HSW(NHK),VK(NHK),ATCONC(NHK),DKW(NHK),IOUTOPT(NHK)
     2,IREF(NHK),IFLX(NHK),RLAMBDA(NHK),RCON(NHK)
     3,RMAX(NHK),HSAT(NHK)
C
C*******DIMENSION THE FOLLOWING
C
      DIMENSION SXLM(10000),XINIT(1001),UINIT(1001),XPT(1001),YPT(1001),
     1SLPZ(1001),SLPR(1001),BZZ(1001),BRR(1001)
C
      WRITE(*,1)     
 1    FORMAT(80('-')/)
 2    FORMAT(/80('-')/)
      WRITE(*,3)
 3    FORMAT(/'THE FOLLOWING INPUT IS NECESSARY TO EXECUTE THE NUMERICAL
     1 SOLUTIONS.'/'THE INPUT IS STORED IN A MAIN DATA FILE (NAMED BY US
     2ER) AND SUPPLEMENTAL MAP'/'FILES, FORMATTED FOR USE IN R-UNSAT.  T
     3HESE FORMATTED DATA FILES MAY BE MODIFIED'/'FOR SUBSEQUENT MODEL R
     4UNS OR FOR MODEL CALIBRATION PURPOSES.  ALL INPUT DATA'/'(UNLESS O
     5THERWISE SPECIFIED) MUST BE IN CGS UNITS.'/)
      WRITE(*,4)
 4    FORMAT('SPECIFY A NAME FOR THE INPUT FILE')
      READ(*,911) FNAMEMIF
 911  FORMAT(A20)
 255  FORMAT(A20)
      OPEN(UNIT=12,FILE=FNAMEMIF,STATUS='NEW')
      WRITE(12,*) IMOD
      WRITE(12,5)
 5    FORMAT(80('*')/26X,'NUMERICAL MODEL INPUT'/80('*')/)
      WRITE(*,6)
 6    FORMAT('INPUT THE PROJECT TITLE -- DATE')
      READ(*,401) TITLE
      WRITE(12,402) TITLE
 401  FORMAT(A70)
 402  FORMAT('TITLE -  ',A70)
      WRITE(12,289)
 289  FORMAT(/2X,'VALUE',5X,'MODEL CODE',10X,'DEFINITION',8X,'[cgs units
     1]'/12X,'DESIGNATION'/2X,5('-'),5X,11('-'),9X,10('-'),8X,11('-'))
      WRITE(*,159)
      WRITE(12,159)
 159  FORMAT(/27('*'),' MODEL DOMAIN PARAMETERS ',28('*')/)
C
      R0=0.0
      ZWAT=0.0
      WRITE(*,900)
 900  FORMAT('MODEL DIMENSIONALITY OPTION'/5X,'1: 1-DIMENSIONAL (VERTICA
     1L: z - DIRECTION)'/5X,'2: 1-DIMENSIONAL (RADIAL: r - DIRECTION)'/5
     2X,'3: 2-DIMENSIONAL (r,z DIRECTIONS)'/)
      READ(*,*) IDIM
      WRITE(12,931) IDIM
 931  FORMAT(I5, 8X,'(IDIM)',10X,'MODEL DIMENSIONALITY'/31X,'1: 1-D VERT
     1ICAL (z - DIRECTION)'/31X,'2: 1-D RADIAL (r - DIRECTION)'/31X,'3:
     22-D (r,z DIRECTIONS)')
      IF(IDIM.GE.2) THEN
      WRITE(*,168)
 168  FORMAT('LENGTH OF MODEL DOMAIN IN r - DIRECTION [cm]')
      READ(*,*) RF
      WRITE(12,769) RF
 769  FORMAT(E10.4, 3X,'(RF)',12X,'LENGTH OF MODEL DOMAIN IN r - DIRECTI
     1ON [cm]')
      WRITE(*,8)
 8    FORMAT('NUMBER OF NODES IN r - DIRECTION')
      READ(*,*) NR
      WRITE(12,608) NR
 608  FORMAT(I5, 8X,'(NR)',12X,'NUMBER OF NODES IN r - DIRECTION')
      ELSE
      NR=4
      WRITE(*,902)
 902  FORMAT('CROSS-SECTIONAL AREA OF MODEL DOMAIN [cm]')
      READ(*,*) CSA
      WRITE(12,932) CSA
 932  FORMAT(E10.4, 3X,'(CSA)',11X,'CROSS-SECTIONAL AREA [cm]')
      RF=(CSA/3.14159)**0.5
      RIM=RF
      END IF
      WRITE(*,184)
 184  FORMAT('LENGTH OF DOMAIN IN z - DIRECTION [cm]')
      READ(*,*) ZSURF
      WRITE(12,785) ZSURF
 785  FORMAT(E10.4, 3X,'(ZSURF)',9X,'LENGTH OF DOMAIN IN z - DIRECTION [
     1cm]')
      IF(IDIM.EQ.2) THEN
      NZ=3
      ZHI=ZSURF
      ZLOW=ZWAT
      RIM=R(2)
      ELSE
      WRITE(*,12)
 12   FORMAT('NUMBER OF NODES IN z - DIRECTION')
      READ(*,*) NZ
      WRITE(12,612) NZ
 612  FORMAT(I5, 8X,'(NZ)',12X,'NUMBER OF NODES IN z - DIRECTION')
      END IF
C
C   GENERATE EQUALLY SPACED NODAL COORDINATES
C
      DZ=(ZSURF-ZWAT)/(NZ-1.0)
      DO 355 IZ=1,NZ
      Z(IZ)=ZWAT+(IZ-1)*DZ
 355  CONTINUE
      DR=(RF-R0)/(NR-1.0)
      DO 360 IR=1,NR
      R(IR)=R0+(IR-1)*DR
 360  CONTINUE
      IF(IDIM.GE.2) WRITE(12,361) DR
 361  FORMAT(E10.4, 3X,'(DR)',12X,'NODAL SPACING IN THE RADIAL DIRECTION
     1 [cm]')
      IF(IDIM.EQ.1 .OR. IDIM.EQ.3) WRITE(12,362) DZ
 362  FORMAT(E10.4, 3X,'(DZ)',12X,'NODAL SPACING IN THE VERTICAL DIRECTI
     1ON [cm]')
C
      WRITE(*,108)
 108  FORMAT('UNSATURATED-ZONE TEMPERATURE [Celsius]')
      READ(*,*) TEMP
      WRITE(12,708) TEMP
 708  FORMAT(E10.4, 3X,'(TEMP)',10X,'UNSATURATED-ZONE TEMPERATURE [C]')
      WRITE(*,120)
 120  FORMAT('UNSATURATED-ZONE PRESSURE [mm Hg] (std. atmosphere at sea
     1level = 760 mm)')
  17  FORMAT(A20)
      READ(*,*) ATM
      WRITE(12,720) ATM
 720  FORMAT(E10.4,3X,'(ATM)',11X,'UNSATURATED-ZONE PRESSURE [mm Hg]')
      IF(IDIM.EQ.2) THEN
      DARCY=0.0
      ELSE
      WRITE(*,125)
 125  FORMAT('RECHARGE RATE [cm/yr]')
      READ(*,*) DARCY
      END IF
      WRITE(12,725) DARCY
      DARCY=-DARCY/3.1536E07
 725  FORMAT(E10.4,3X,'(DARCY)',9X,'RECHARGE RATE [cm/yr]')
      IF(ABS(DARCY).GT.0) THEN
      WRITE(*,137)
 137  FORMAT('AQUEOUS-PHASE DISPERSION OPTION'/5X,'0: NEGLECT AQUEOUS-PH
     1ASE DISPERSION'/5X,'1: ACCOUNT FOR AQUEOUS-PHASE DISPERSION')
      READ(*,*) IDISP
      WRITE(12,724) IDISP
 724  FORMAT(I5, 8X,'(IDISP)',9X,'AQUEOUS-PHASE DISPERSION OPTION'/31X,'
     10: NEGLECT AQUEOUS-PHASE DISPERSION'/31X,'1: ACCOUNT FOR AQUEOUS-P
     2HASE DISPERSION')
      ELSE
      IDISP=0
      END IF
C
C
      ICOMP=0
      WRITE(*,126)
      WRITE(12,126)
 126  FORMAT(/28('*'),' CONSTITUENT PROPERTIES ',28('*'))
C
      WRITE(*,20)
 20   FORMAT(/'NUMBER OF MODELED CONSTITUENTS'/'(THE TOTAL NUMBER OF GAS
     1-PHASE CONSTITUENTS CAN NOT EXCEED 7.'/'IN ADDITION, THIS NUMBER M
     2UST NOT INCLUDE THE CONSTITUENTS THAT COMPRISE'/' THE BULK SOIL-GA
     3S PHASE.)')
      READ(*,*) NK
 620  FORMAT(/I5, 8X,'(NK)',12X,'NUMBER OF MODEL CONSTITUENTS')
      WRITE(*,21)
 21   FORMAT('IS THIS NUMBER EQUIVALENT TO THE TOTAL NUMBER OF UNSATURAT
     1ED-ZONE'/'GAS-PHASE CONSTITUENTS?'/'IF NO...ENTER 0, IF YES...ENTE
     2R 1)')
      READ(*,*) ICOMP
C
      IOX=0
      IFLAG=0
      IND=0
      IND1=0
      DO 405 IK=1,NK
	IBIO(IK)=0
      ICON(IK)=0
      WRITE(*,127) IK
 127  FORMAT(/32('-'),' CONSTITUENT',I3,1X,32('-')/)
 930  FORMAT(32('-'),' CONSTITUENT',I3,1X,32('-')/)
      WRITE(*,129)
 129  FORMAT(5X,'INDEX',3X,'CONSTITUENT'/5X,'-----',3X,'-----------'/6X,
     1'(1):',4X,'CARBON DIOXIDE - CO2'/6X,'(2):',4X,'OXYGEN - O2  ** (SE
     2E NOTE)'/6X,'(3):',4X,'NITROGEN - N2'/6X,'(4):',4X,'METHANE - CH4'
     3/6X,'(5):',4X,'WATER VAPOR - H2O'/6X,'(6):',4X,'MTBE - (CH3)3C0CH3
     4'/6X,'(7):',4X,'HYDROCARBON - CnHm'/6X,'(8):',4X,'OTHER - ??'/80('
     5-')/'(** NOTE if selecting O2, make it the last modeled constituen
     6t)'/80('-')/)
      WRITE(*,130) IK
 130  FORMAT('ENTER THE CONSTITUENT INDEX FOR CONSTITUENT ',I2)
      READ(*,*) ICON(IK)
      IF(ICON(IK).EQ.1) THEN
      WK(IK)=44.10
      DV(IK)=26.90
      HWIK(IK)=1.40E-5
      VK(IK)=0.693
      ATCONC(IK)=6.23E-7
      HSW(IK)=0.0
      END IF
      IF(ICON(IK).EQ.2) THEN
      IOX=1
      HSAT(IK)=0.1E-6
      WK(IK)=32.00
      DV(IK)=16.30
      HWIK(IK)=8.83E-6
      VK(IK)=0.901
      ATCONC(IK)=2.79E-4
      HSW(IK)=0.0
      END IF
      IF(ICON(IK).EQ.3) THEN
      WK(IK)=28.02
      DV(IK)=18.50
      HWIK(IK)=0.0
      VK(IK)=1.03
      ATCONC(IK)=9.10E-4
      HSW(IK)=0.0
      END IF
      IF(ICON(IK).EQ.4) THEN
      HSAT(IK)=0.2E-6
      RMAX(IK)=2.5E-10
      WK(IK)=16.00
      DV(IK)=25.14
      HWIK(IK)=0.0
      VK(IK)=1.81
      ATCONC(IK)=0.0
      VK(IK)=2.35
      RK(IK)=4.0
      END IF
      IF(ICON(IK).EQ.5) THEN
      WK(IK)=18.0
      DV(IK)=13.1
      VK(IK)=1.0
      HWIK(IK)=1.0
      ATCONC(IK)=0.0
      HSW(IK)=1.0
      END IF
      IF(ICON(IK).EQ.6) THEN
      HSAT(IK)=0.2E-6
      RMAX(IK)=7.5E-12
      WK(IK)=88.15
      DV(IK)=113.3
      VK(IK)=1.35
      HWIK(IK)=0.048
      ATCONC(IK)=0.0
      HSW(IK)=0.055
      RK(IK)=3.0
      END IF
 730  FORMAT(I5, 8X,'(ICON)',10X,'CONSTITUENT INDEX FOR: ',A30)
      IF(ICON(IK).LE.3 .OR. ICON(IK).EQ.5) THEN
      DO 945 IR=1,NR
      DO 945 IZ=1,NZ
      RBIO(IR,IZ)=0.0
 945  CONTINUE
      END IF
      IF(ICON(IK).LE.6) GO TO 348
      IF(ICON(IK).EQ.7) THEN
      WRITE(*,124)
 124  FORMAT(5X,'INDEX',3X,'CONSTITUENT'/5X,'-----',3X,'-----------'/6X,
     1'(9):',4X,'C6 AROMATIC (e.g. benzene) - C6H6'/6X,'(10):',4X,'C7 AR
     2OMATIC (e.g. toluene) - C7H8'/5X,'(11):',4X,'C8 AROMATICS (e.g. xy	
     3lene) - C8H10'/5X,'(12):',4X,'C9 AROMATICS (e.g. tri-methyl benzen
     4e)- C9H12'/5X,'(13):',4X,'C5 ALKANES (e.g. pentane) - C5H12'/5X,'(
     514):',4X,'C6 ALKANES (e.g. hexane) - C6H14'/5X,'(15):',4X,'C7 ALKA
     6NES (e.g. heptane) - C7H16'/5X,'(16):',4X,'C8 ALKANES (e.g. octane
     7) - C8H18'/5X,'(17):',4X,'C9 ALKANES (e.g. nonane) - C9H20'/5X,'(1
     88):',4X,'C10 ALKANES (e.g. decane) - C10H22'/5X,'(19):',4X,'C5 ALK
     9ENES (e.g. pentene) - C5H10'/5X,'(20):',4X,'C6 ALKENES (e.g. hexen
     9e)- C6H12'/5X,'(21):',4X,'C6 NAPTHENES (e.g. cyclohexene) - C6H12'
     9/5X,'(22):',4X,'OTHER - ??'/55('-'))
      WRITE(*,131)
 131  FORMAT('ENTER THE CONSTITUENT INDEX FOR THE HYDROCARBON')
      READ(*,*) ICON(IK)
      IF(ICON(IK).EQ.9) THEN
      HSAT(IK)=0.2E-6
      RMAX(IK)=2.5E-10
      WK(IK)=78.11
      DV(IK)=90.96
      HWIK(IK)=1.78E-3
      VK(IK)=1.13
      ATCONC(IK)=0.0
      RK(IK)=3.08
      END IF
      IF(ICON(IK).EQ.10) THEN
      HSAT(IK)=0.2E-6
      RMAX(IK)=2.5E-10
      WK(IK)=92.14
      DV(IK)=111.5
      HWIK(IK)=5.15E-4
      VK(IK)=1.15
      ATCONC(IK)=0.0
      RK(IK)=3.13
      END IF
      IF(ICON(IK).EQ.11) THEN
      HSAT(IK)=0.2E-6
      RMAX(IK)=2.5E-10
      WK(IK)=106.17
      DV(IK)=132.0
      HWIK(IK)=1.52E-4
      VK(IK)=1.15
      ATCONC(IK)=0.0
      RK(IK)=3.17
      END IF
      IF(ICON(IK).EQ.12) THEN
      HSAT(IK)=0.2E-6
      RMAX(IK)=2.5E-10
      WK(IK)=120.2
      DV(IK)=152.5
      HWIK(IK)=5.7E-2
      VK(IK)=1.15
      ATCONC(IK)=0.0
      RK(IK)=3.19
      END IF
      IF(ICON(IK).EQ.13) THEN
      HSAT(IK)=0.2E-6
      RMAX(IK)=2.5E-10
      WK(IK)=72.15
      DV(IK)=107.2
      HWIK(IK)=1.48E-4
      VK(IK)=1.60
      ATCONC(IK)=0.0
      RK(IK)=3.55
      END IF
      IF(ICON(IK).EQ.14) THEN
      HSAT(IK)=0.2E-6
      RMAX(IK)=2.5E-10
      WK(IK)=86.18
      DV(IK)=127.7
      HWIK(IK)=0.0095E-3
      VK(IK)=1.52
      ATCONC(IK)=0.0
      RK(IK)=3.53
      END IF
      IF(ICON(IK).EQ.15) THEN
      HSAT(IK)=0.2E-6
      RMAX(IK)=2.5E-10
      WK(IK)=100.2
      DV(IK)=148.3
      HWIK(IK)=3.0E-06
      VK(IK)=1.46
      ATCONC(IK)=0.0
      RK(IK)=3.51
      END IF
      IF(ICON(IK).EQ.16) THEN
      HSAT(IK)=0.2E-6
      RMAX(IK)=2.5E-10
      WK(IK)=114.2
      DV(IK)=168.8
      HWIK(IK)=6.6E-7
      VK(IK)=1.42
      ATCONC(IK)=0.0
      RK(IK)=3.50
      END IF
      IF(ICON(IK).EQ.17) THEN
      HSAT(IK)=0.2E-6
      RMAX(IK)=2.5E-10
      WK(IK)=128.3
      DV(IK)=189.3
      HWIK(IK)=0.0
      VK(IK)=1.39
      ATCONC(IK)=0.0
      RK(IK)=3.49
      END IF
      IF(ICON(IK).EQ.18) THEN
      HSAT(IK)=0.2E-6
      RMAX(IK)=2.5E-10
      WK(IK)=142.3
      DV(IK)=209.8
      HWIK(IK)=0.0
      VK(IK)=1.37
      ATCONC(IK)=0.0
      RK(IK)=3.49
      END IF
      IF(ICON(IK).EQ.19) THEN
      HSAT(IK)=0.2E-6
      RMAX(IK)=2.5E-10
      WK(IK)=70.13
      DV(IK)=102.6
      HWIK(IK)=0.0
      VK(IK)=1.56
      ATCONC(IK)=0.0
      RK(IK)=3.43
      END IF
      IF(ICON(IK).EQ.20) THEN
      HSAT(IK)=0.2E-6
      RMAX(IK)=2.5E-10
      WK(IK)=84.16
      DV(IK)=123.1
      HWIK(IK)=5.0E-5
      VK(IK)=1.49
      ATCONC(IK)=0.0
      RK(IK)=3.43
      END IF
      IF(ICON(IK).EQ.21) THEN
      HSAT(IK)=0.2E-6
      RMAX(IK)=2.5E-10
      WK(IK)=84.16
      DV(IK)=104.8
      HWIK(IK)=0.000055
      VK(IK)=1.28
      ATCONC(IK)=0.0
      RK(IK)=3.43
      END IF
      END IF
	IF(ICON(IK).EQ.8 .OR. ICON(IK).EQ.22) THEN
      HSAT(IK)=0.2E-6
      RMAX(IK)=2.5E-10
      ATCONC(IK)=0.0
      RK(IK)=3.43
      END IF
      IF(ICON(IK).EQ.8 .OR. ICON(IK).EQ.22) THEN
      ATCONC(IK)=0.0
      WRITE(*,128)
 128  FORMAT('MOLECULAR WEIGHT [g]')
      READ(*,*) WK(IK)
 728  FORMAT(E10.4,3X,'(WK(IK))',8X,'MOLECULAR WEIGHT OF CONSTITUENT [g]
     1')
      WRITE(*,132)
 132  FORMAT(/'-- ATOMIC DIFFUSION VOLUME TABLE -- (from Reid et al., 19
     187)'/60('-')/3X,'C',5X,'15.9',10X,'H',5X,'2.31',10X,'O',5X,'6.11'/
     23X,'N',5X,'4.54',10X,'Cl',4X,'21.0',10X,'Br',4X,'21.9'/3X,'F',5X,'
     314.7',10X,'I',5X,'29.8',10X,'S',5X,'22.9'/3X,'Aromatic ring',3X,'-
     418.3',5X,'Heterocyclic ring',3X,'-18.3'/60('-')/3X,'H2',4X,'6.12',
     510X,'N2',4X,'18.5',10X,'O2',4X,'16.3'/3X,'Air',3X,'19.7',10X,'CO',
     64X,'18.0',10X,'CO2',3X,'26.9'/3X,'N2O',3X,'35.9',10X,'NH3',3X,'20.
     77',10X,'H2O',3X,'13.1'/3X,'Cl2',3X,'38.4',10X,'Br2',3X,'69.0',10X,
     8'SO2',3X,'41.8'/60('-')/)
      WRITE(*,133)
 133  FORMAT('ATOMIC DIFFUSION VOLUME [dimensionless]')
      READ(*,*) DV(IK)
 732  FORMAT(E10.4,3X,'(DV(IK))',8X,'ATOMIC DIFFUSION VOLUME [dimensionl
     1ess]')
      END IF
 348  CONTINUE
      WRITE(*,148)
 148  FORMAT('HENRYS LAW PARTITION COEFFICIENT (air/water) [dimensionles
     1s]')
      READ(*,*) HAW(IK)
 748  FORMAT(E10.4, 3X,'(HAW(IK))',7X,'HENRYS LAW PARTITION COEFFICIENT
     1(air/water)'/31X,'[dimensionless]')
      IND=0
      IF(ICON(IK).EQ.4 .OR. ICON(IK).GE.6) THEN
      WRITE(*,152)
 152  FORMAT('ADSORPTION ISOTHERM (soil/water) [cm3 water/g soil]')
      READ(*,*) HSW(IK)
      END IF
C
      IF(ICON(IK).NE.5) THEN
	IND=0
	IF(IK.EQ.NK .AND. IK.GT.1) THEN
	IF(IOX.EQ.1) THEN
	DO 699 IKK=2,NK
	IF(IBIO(IKK-1).EQ.3) IBIO(NK)=3
	IF(IBIO(IKK-1).EQ.4) IBIO(NK)=4
	IF(IBIO(IKK-1).EQ.5) IBIO(NK)=5
 699  CONTINUE
	GO TO 552
	END IF
	END IF
      WRITE(*,84)
 84   FORMAT('SOURCE-SINK OPTION'/5X,'0: NO SOURCE OR SINK'/5X,'1: ZERO
     1ORDER KINETICS (i.e. rk=constant)'/5X,'2: 1ST-ORDER KINETICS (do n
     2ot consider O2 transport)'/5X,'3: 1ST-ORDER KINETICS (consider O2
     3 transport)'/5X,'4: KINETICS COUPLED TO OXYGEN AVAILABILITY'/5X,'5 
     4: 2ND-ORDER MONOD KINETICS (substrate AND oxygen limited)'/5X,'6: 
     5SOURCE-SINK MODEL SUPPLIED BY USER (subroutine "bio2")')
      READ(*,*) IBIO(IK)
C
 552  CONTINUE
C
	IF(IBIO(IK).EQ.0) IFLAG=0
      IF(IBIO(IK).EQ.1) IFLAG=1
      IF(IBIO(IK).EQ.2) IFLAG=2
      IF(IBIO(IK).EQ.3) IFLAG=3
      IF(IBIO(IK).EQ.4) IFLAG=4
      IF(IBIO(IK).EQ.5) IFLAG=5
      IF(IBIO(IK).EQ.6) IFLAG=6
      DO 946 IR=1,NR
      DO 946 IZ=1,NZ
      RBIO(IR,IZ)=0.0
 946  CONTINUE
C
      IF(IBIO(IK).EQ.1) THEN
      WRITE(*,155)
 155  FORMAT('REACTION-RATE CONSTANT [g/cm3] (- = source, + = sink)')
      READ(*,*) RCON(IK)
      END IF
C     
      IND=0
      IF(IBIO(IK).EQ.2) THEN
	WRITE(*,153)
 153  FORMAT('1ST-ORDER RATE CONSTANT [1/s] (- = source, + = sink)')
      READ(*,*) RLAMBDA(IK)
      END IF
C
      IND=0
      IF(IBIO(IK).EQ.3) THEN
      IOX=1
	IF(IK.LT.NK) THEN
	WRITE(*,153)
      READ(*,*) RLAMBDA(IK)
	END IF
	END IF
C
	IF(IBIO(IK).EQ.4) THEN
 	IOX=1
	END IF
C
      IF(IBIO(IK).EQ.5) THEN
      IOX=1
	IF(ICON(IK).EQ.4 .OR. ICON(IK).GE.6) THEN
      WRITE(*,157)
 157  FORMAT('MAXIMUM RATE CONSTANT IN AQUEOUS PHASE IS: RMAX=0.9 mG/L-h
     1r.'/' IS THIS ACCEPTABLE?  ENTER 0 (YES), 1 (NO)')
      READ(*,*) IRMAX
      IF(IRMAX.EQ.1) THEN
      WRITE(*,158)
 158  FORMAT('MAXIMUM RATE CONSTANT IN AQUEOUS PHASE (mG/L-hr)')
      READ(*,*) RMAX(IK)
      RMAX(IK)=RMAX(IK)/(1000.*1000.*3600.)
      END IF
      WRITE(*,136)
 136  FORMAT('HALF-SATURATION CONSTANT IN AQUEOUS PHASE IS: HSAT=0.2 mG/
     1L.'/' IS THIS VALUE ACCEPTABLE?  ENTER 0 (YES), 1 (NO)')
      READ(*,*) IHSAT
      IF(IHSAT.EQ.1) THEN
      WRITE(*,162)
 162  FORMAT('HALF SATURATION CONSTANT (mG/L)')
      READ(*,*) HSAT(IK)
      HSAT(IK)=HSAT(IK)/(1000*1000)
      END IF
	END IF
	END IF
C
      IF(IBIO(IK).EQ.6) THEN
	WRITE(*,749)
	IOX=1
 749  FORMAT('MODEL WILL IMPLEMENT (subroutine "BIO2") SUPPLIED BY USER'
     1/'MUST COMPUTE SINK TERM OF TYPE: "RBIO(IR,IZ)"'/)
      END IF
C
      IF(IBIO(IK).EQ.5 .AND. IK.EQ.NK) THEN
      WRITE(*,161)
 161  FORMAT('HALF-SATURATION CONSTANT FOR OXYGEN IN AQUEOUS PHASE IS: H
     1SAT=0.1 mG/L.'/' IS THIS VALUE ACCEPTABLE?  ENTER 0 (YES), 1 (NO)'
     2)
      READ(*,*) IHSAT
      IF(IHSAT.EQ.1) THEN
      WRITE(*,162)
      READ(*,*) HSAT(NK)
      HSAT(NK)=HSAT(NK)/(1000*1000)
      END IF
      END IF
	END IF
C
	IATM=0
      IF(IDIM.EQ.1 .OR. IDIM.EQ.3) WRITE(*,140)
 140  FORMAT('GAS-PHASE CONCENTRATION [g/cm3] ABOVE UPPER BOUNDARY'/5X,
     1'0: ATMOSPHERIC'/5X,'1: OTHER')
      IF(IDIM.EQ.2) WRITE(*,141)
 141  FORMAT('GAS-PHASE CONCENTRATION [g/cm3] BEYOND FAR LATERAL BOUNDAR
     1Y'/5X,'0: ATMOSPHERIC'/5X,'1: OTHER')
      READ(*,*) IATM
      IF(IATM.EQ.1) THEN
      IF(IDIM.EQ.1 .OR. IDIM.EQ.3) WRITE(*,139)
 139  FORMAT('GAS-PHASE CONCENTRATION [g/cm3] ABOVE UPPER BOUNDARY')
      IF(IDIM.EQ.2) WRITE(*,138)
 138  FORMAT('GAS-PHASE CONCENTRATION [g/cm3] BEYOND FAR LATERAL BOUNDAR
     1Y')
      READ(*,*) ATCONC(IK)
      END IF
C
	IF(IFLAG.GE.3) THEN
      IF(IOX.EQ.0 .AND. IK.EQ.NK) THEN
      IND=3
      WRITE(*,154) NK+1
 154  FORMAT(/'** WARNING ** OXYGEN MUST ALSO BE A MODELED CONSTITUENT.'
     1/'PLEASE ENTER ALL REQUIRED INPUT DATA FOR O2, THE',I2,' MODELED C
     2ONSITUENT'/)
      HSAT(NK+1)=0.1E-6
      WK(NK+1)=32.00
      DV(NK+1)=16.30
      VC(NK+1)=73.4
      HWIK(NK+1)=0.0
      VK(NK+1)=0.901
      IBIO(NK+1)=0
      ATCONC(NK+1)=2.79E-4
      HSW(NK+1)=0.0
      IOX=1
      IBIO(NK+1)=IFLAG
      WRITE(*,147)
 147  FORMAT('HENRYS LAW PARTITION COEFFICIENT (air/water) - FOR OXYGEN
     1[dimensionless]')
      READ(*,*) HAW(NK+1)
      IATM=0
      WRITE(*,140)
      READ(*,*) IATM
      IF(IATM.EQ.1) THEN
      WRITE(*,139)
      READ(*,*) ATCONC(NK+1)
      END IF
      END IF
      END IF
C
      DKW(IK)=1.0E-5
C
 405  CONTINUE
C
C
      IF(IND.EQ.3) NK=NK+1
C
      DO 404 IK=1,NK
      IF(ICON(IK).EQ.1) M='CARBON DIOXIDE'
      IF(ICON(IK).EQ.2) M='OXYGEN'
      IF(ICON(IK).EQ.3) M='NITROGEN'
      IF(ICON(IK).EQ.4) M='METHANE'
      IF(ICON(IK).EQ.5) M='WATER VAPOR'
      IF(ICON(IK).EQ.6) M='MTBE'
      IF(ICON(IK).EQ.8) M='OTHER'
      IF(ICON(IK).EQ.9) M='BENZENE'
      IF(ICON(IK).EQ.10) M='TOLUENE'
      IF(ICON(IK).EQ.11) M='C8 AROMATIC'
      IF(ICON(IK).EQ.12) M='C9 AROMATIC'
      IF(ICON(IK).EQ.13) M='C5 ALKANE'
      IF(ICON(IK).EQ.14) M='C6 ALKANE'
      IF(ICON(IK).EQ.15) M='C7 ALKANE'
      IF(ICON(IK).EQ.16) M='C8 ALKANE'
      IF(ICON(IK).EQ.17) M='C9 ALKANE'
      IF(ICON(IK).EQ.18) M='C10 ALKANE'
      IF(ICON(IK).EQ.19) M='C5 ALKENE'
      IF(ICON(IK).EQ.20) M='C6 ALKENE'
      IF(ICON(IK).EQ.21) M='C6 NAPTHENE (e.g. cyclohexene)'
      IF(ICON(IK).EQ.22) M='OTHER HYDROCARBON'
      IF(IND.EQ.3 .AND. IK.EQ.NK) THEN
      ICON(NK)=2
      M='OXYGEN'
      END IF
      IF(IK.EQ.1) WRITE(12,620) NK
      WRITE(12,127) IK
      WRITE(12,730) ICON(IK),M
      WRITE(12,728) WK(IK)
      WRITE(12,732) DV(IK)
      WRITE(12,748) HAW(IK)
C
      IF(ICON(IK).EQ.4 .OR. ICON(IK).GE.6) THEN
      WRITE(12,752) HSW(IK)
 752  FORMAT(E10.4, 3X,'(HSW(IK))',7X,'ADSORPTION ISOTHERM (linear) [cm
     13 water/g soil]')
      END IF
C
      IF(ICON(IK).NE.5) THEN
      IF(IOX.EQ.1 .AND. IK.EQ.NK) THEN
	IF(IBIO(IK).GE.3) GO TO 529
	END IF
      WRITE(12,684) IBIO(IK)
 684  FORMAT(I5, 8X,'(IBIO(IK))',6X,'SOURCE-SINK OPTION'/31X,'0: NO SOUR
     1CES OR SINKS'/31X,'1: ZERO-ORDER KINETICS'/31X,'2: 1ST-ORDER KINET
     2ICS (DO NOT CONSIDER O2 TRANSPORT)'/31X,'3: 1ST-ORDER KINETICS (CO
     3NSIDER O2 TRANSPORT)'/31X,'4: KINETICS COUPLED TO O2 AVAILABILITY'
     4/31X,'5: SECOND-ORDER MONOD KINETICS'/31X,'6: SOURCE-SINK MODEL SU
     5PPLIED BY USER')
 529  CONTINUE
      END IF
C
      IF(IBIO(IK).EQ.1) THEN
      WRITE(12,727) RCON(IK)
 727  FORMAT(E10.4,3X,'(RCON(IK))',6X,'REACTION-RATE CONSTANT [g/cm3]')
      END IF
C
      IF(IBIO(IK).EQ.2) THEN
	WRITE(12,753) RLAMBDA(IK)
	END IF
C
	IF(IBIO(IK).EQ.3) THEN
	IF(IK.LT.NK) WRITE(12,756) RK(IK)
	IF(IK.LT.NK) WRITE(12,753) RLAMBDA(IK)
	END IF
C
 753  FORMAT(E10.4,3X,'(RLAMBDA(IK))',3X,'1ST-ORDER RATE CONSTANT [1/s]'
     1)
C
      IF(IBIO(IK).EQ.4 .OR. IBIO(IK).EQ.5) THEN
      IF(IK.LT.NK) WRITE(12,756) RK(IK)
 756  FORMAT(E10.4,3X,'(RK(IK))',8X,'STOICHIOMETRIC CONSTANT [dimensionl
     1less]')
      END IF
      IF(IBIO(IK).EQ.5) THEN
      IF(IK.LT.NK) WRITE(12,757) RMAX(IK)
 757  FORMAT(E10.4,3X,'(RMAX(IK))',6X,'MAXIMUM RATE CONSTANT [g/cm3-s]')
      WRITE(12,758) HSAT(IK)
 758  FORMAT(E10.4,3X,'(HSAT(IK))',6X,'HALF-SATURATION CONSTANT [g/cm3]'
     1)
      END IF
C
      IF(IDIM.EQ.1 .OR. IDIM.EQ.3) WRITE(12,740) ATCONC(IK)
      IF(IDIM.EQ.2) WRITE(12,741) ATCONC(IK)
 740  FORMAT(E10.4,3X,'(ATCONC(IK))',4X,'GAS-PHASE CONCENTRATION ABOVE U
     1PPER'/29X,'BOUNDARY [g/cm3]')
 741  FORMAT(E10.4,3X,'(ATCONC(IK))',4X,'GAS-PHASE CONCENTRATION BEYOND
     1FAR LATERAL'/29X,'BOUNDARY [g/cm3]')
      WRITE(12,662)
 662  FORMAT(10X, 3X,'(DKA(IK))',7X,'GASEOUS-PHASE DIFFUSIVITY (** SEE M
     1AP FILE-DKA.MAP)')
      WRITE(12,666) DKW(IK)
 666  FORMAT(E10.4, 3X,'(DKW(IK))',7X,'AQUEOUS-PHASE DIFFUSIVITY')
 404  CONTINUE
C
C
      WRITE(*,202)
      WRITE(12,202)
 202  FORMAT(/22('*'),' INITIAL AND BOUNDARY CONDITIONS ',23('*'))
C
C **************** BOUNDARY CONDITION INPUT *******************
C
      WRITE(*,80)
 80   FORMAT(/'SOURCE BOUNDARY CONDITION OPTION'/5X,'1: SPECIFIED FLUX A
     1T LOWER BOUNDARY(z=0)'/5X,'2: SPECIFIED CONCENTRATION AT LOWER BOU
     2NDARY(z=0)'/5X,'3: HYDROCARBON PLUME IN UNSATURATED ZONE'/5X,'4: C
     3ONSTANT RADIAL FLUX AT r=0'/5X,'5: SOURCE REMOVED (coupled to opti
     4ons 1-4 above)')
      READ(*,*) IOPT
      WRITE(12,680) IOPT
 680  FORMAT(/I5, 8X,'(IOPT)',10X,'SOURCE BOUNDARY CONDITION OPTION'/31X
     1,'1: SPECIFIED FLUX AT LOWER BOUNDARY(z=0)'/31X,'2: SPECIFIED CONC
     2ENTRATION AT LOWER BOUNDARY(z=0)'/31X,'3: HYDROCARBON PLUME IN UNS
     3ATURATED ZONE'/31X,'4: CONSTANT RADIAL FLUX AT R=0'/31X,'5: NO SOU
     4RCE')
C
C
      DO 410 IK=1,NK
      IBDRY=0
      IF(IFLAG.LE.2 .OR. IOPT.EQ.3) THEN
	IF(IOPT.LT.5) WRITE(*,127) IK
      IF(IOPT.LT.5) WRITE(12,127) IK
	END IF
	IF(IFLAG.GE.3 .AND. IOPT.NE.3) THEN
	IF(IK.LT.NK) THEN
	IF(IOPT.LT.5) WRITE(*,127) IK
      IF(IOPT.LT.5) WRITE(12,127) IK
	END IF
	END IF
      IF(IOPT.LE.2) THEN
      IF(IDIM.GE.2) THEN
	IF(IFLAG.LE.2) THEN
      WRITE(*,211)
 211  FORMAT('BOUNDARY CONDITION OPTION'/5X,'0: BOUNDARY CONDITION IS CO
     1NSTANT ACROSS LOWER BOUNDARY(z=0)'/5X,'1: BOUNDARY CONDITION VARIE
     2S ACROSS LOWER BOUNDARY(z=0)'/8X,'AND IS SPECIFIED IN SEPARATE INP
     3UT FILE')
      READ(*,*) IBDRY
      WRITE(12,808) IBDRY
 808  FORMAT(I5, 8X,'(IBDRY)',9X,'BOUNDARY CONDITION OPTION'/31X,'0: BOU
     1NDARY CONDITION IS CONSTANT'/31X,'1: BOUNDARY CONDITION VARIES')
      ELSE
	IF(IK.LT.NK) THEN
	WRITE(*,211)
	READ(*,*) IBDRY
	WRITE(12,808) IBDRY
	END IF
	END IF
	ELSE
      IBDRY=0
      END IF
C
	IF(IFLAG.LE.2) THEN
C
      IF(IBDRY.EQ.0) THEN
	IF(IOPT.EQ.1) THEN
      WRITE(*,220)
 220  FORMAT('GAS FLUX ACROSS LOWER BOUNDARY(z=0) [g/cm2-s]'/'(POSITIVE:
     1 FLUX INTO DOMAIN, NEGATIVE: FLUX OUT OF DOMAIN)')
      READ(*,*) FLX(1,IK)
      WRITE(12,820) FLX(1,IK)
 820  FORMAT(E10.4,3X,'(FLX(IR,IK))',4X,'GAS FLUX ACROSS LOWER BOUNDARY(
     1z=0) [g/cm2-s]')
      DO 420 IR=1,NR
      FLX(IR,IK)=FLX(1,IK)
 420  CONTINUE
      END IF
C
      IF(IOPT.EQ.2) THEN
      WRITE(*,224)
 224  FORMAT('GAS-PHASE CONCENTRATION [g/cm3] AT LOWER BOUNDARY (z=0)')
      READ(*,*) GASBOT
      WRITE(12,824) GASBOT
 824  FORMAT(E10.4,3X,'(Y0(IR,IZHI,IK))',1X,'GAS-PHASE CONCENTRATION AT'
     1,' ','LOWER BOUNDARY [g/cm3]')
      DO 425 IR=1,NR
      Y0(IR,2,IK)=GASBOT
 425  CONTINUE
      END IF
      ELSE
C
      IF(IK.EQ.1) THEN
      WRITE(*,228)
 228  FORMAT('SPECIFY THE NAME OF THE INPUT FILE CONTAINING THE BOUNDARY
     1 CONDITION DATA')
      READ(*,17) FNAMEBCDAT
      OPEN(UNIT=4,FILE=FNAMEBCDAT)
      END IF
      READ(4,*) ICOUNT,NDAT
      DO 493 IDAT=1,NDAT
      READ(4,*) XPT(IDAT),YPT(IDAT)
 493  CONTINUE
      IDAT=1
      DO 492 IR=1,NR
      IF(R(IR).LT.XPT(1) .OR. R(IR).GT.XPT(NDAT)) THEN
      IF(R(IR).LT.XPT(1)) BC(IR)=YPT(1)
      IF(R(IR).GT.XPT(NDAT)) BC(IR)=YPT(NDAT)
      ELSE
      IF(R(IR).GT.XPT(IDAT+1)) THEN
      IDAT=IDAT+1
      IF(IDAT.GT.NDAT) IDAT=NDAT
      END IF
      SLPR(IDAT)=(YPT(IDAT+1)-YPT(IDAT))/(XPT(IDAT+1)-XPT(IDAT))
      BRR(IDAT)=YPT(IDAT)-SLPR(IDAT)*XPT(IDAT)
      BC(IR)=SLPR(IDAT)*R(IR)+BRR(IDAT)
      END IF
      IF(IOPT.EQ.1) FLX(IR,ICOUNT)=BC(IR)
      IF(IOPT.EQ.2) Y0(IR,2,ICOUNT)=BC(IR)
 492  CONTINUE
      END IF
C
	ELSE
C
      IF(IK.LT.NK) THEN
      IF(IBDRY.EQ.0) THEN
	IF(IOPT.EQ.1) THEN
	WRITE(*,220)
      READ(*,*) FLX(1,IK)
      WRITE(12,820) FLX(1,IK)
      DO 920 IR=1,NR
      FLX(IR,IK)=FLX(1,IK)
 920  CONTINUE
      END IF
C
      IF(IOPT.EQ.2) THEN
	WRITE(*,224)
      READ(*,*) GASBOT
      WRITE(12,824) GASBOT
      DO 926 IR=1,NR
      Y0(IR,2,IK)=GASBOT
 926  CONTINUE
      END IF
C
      ELSE
      IF(IK.EQ.1) THEN
      WRITE(*,228)
      READ(*,17) FNAMEBCDAT
      OPEN(UNIT=4,FILE=FNAMEBCDAT)
      END IF
      READ(4,*) ICOUNT,NDAT
      DO 993 IDAT=1,NDAT
      READ(4,*) XPT(IDAT),YPT(IDAT)
 993  CONTINUE
      IDAT=1
      DO 992 IR=1,NR
      IF(R(IR).LT.XPT(1) .OR. R(IR).GT.XPT(NDAT)) THEN
      IF(R(IR).LT.XPT(1)) BC(IR)=YPT(1)
      IF(R(IR).GT.XPT(NDAT)) BC(IR)=YPT(NDAT)
      ELSE
      IF(R(IR).GT.XPT(IDAT+1)) THEN
      IDAT=IDAT+1
      IF(IDAT.GT.NDAT) IDAT=NDAT
      END IF
      SLPR(IDAT)=(YPT(IDAT+1)-YPT(IDAT))/(XPT(IDAT+1)-XPT(IDAT))
      BRR(IDAT)=YPT(IDAT)-SLPR(IDAT)*XPT(IDAT)
      BC(IR)=SLPR(IDAT)*R(IR)+BRR(IDAT)
      END IF
      IF(IOPT.EQ.1) FLX(IR,ICOUNT)=BC(IR)
      IF(IOPT.EQ.2) Y0(IR,2,ICOUNT)=BC(IR)
 992  CONTINUE
      END IF
	END IF
	END IF
C
      IF(IDIM.EQ.3 .AND. IBDRY.EQ.1) THEN
      OPEN(UNIT=13,FILE='BC.MAP')
      WRITE(13,*) IK
      IF(IOPT.EQ.1) WRITE(13,210) (R(IR),FLX(IR,IK),IR=1,NR)
      IF(IOPT.EQ.2) WRITE(13,210) (R(IR),Y0(IR,2,IK),IR=1,NR)
      IF(NK.EQ.1) WRITE(12,827)
      IF(NK.GT.1) WRITE(12,828)
 827  FORMAT(/'*** DISCRETIZED BOUNDARY CONDITION DATA CONTAINED IN FILE
     1-"BC.MAP"'/)
 828  FORMAT(/'*** DISCRETIZED BOUNDARY CONDITION DATA CONTAINED IN FILE
     1-"BC.MAP"')
      END IF
      END IF
C
      IF(IOPT.EQ.3) THEN
      IF(ICON(IK).GE.6) THEN
      WRITE(*,212)
 212  FORMAT('INITIAL IMMISCIBLE-PHASE CONCENTRATION [g/cm3]')
      READ(*,*) XIK0(IK)
      IF(IK.EQ.1) THEN
      WRITE(*,213)
 213  FORMAT('SOURCE BOUNDARY CONDITION OPTION'//'THE IMMISCIBLE PHASE C
     1ONCENTRATION CAN BE CONSTANT FOR ALL'/'CONSTITUENTS (ENTER 0) OR T
     2IME-DEPENDENT (ENTER 1)')
      READ(*,*) KONS
      END IF
      ELSE
      XIK0(IK)=0.00
      END IF
      WRITE(12,812) XIK0(IK)
 812  FORMAT(E10.4,3X,'(XIK0(IK))',6X,'INITIAL IMMISCIBLE-PHASE CONCENTR
     1ATION [g/cm3]')
      IF(IK.EQ.1) WRITE(12,813) KONS
 813  FORMAT(I5,8X,'(KONS)',10X,'SOURCE BOUNDARY COND. OPTION: 0=CONSTA
     1NT, 1=TIME DEPENDENT')
      IF(ICON(IK).EQ.8 .OR. ICON(IK).EQ.22) THEN
      ISOL=1
      ELSE
      WRITE(*,396)
 396  FORMAT('THE SOLUBILITY AND SPECIFIC VOLUME (e.g. reciprocal of spe
     1cific gravity)'/'OF THE MODELED CONSTITUENTS ARE SPECIFIED AT 20 D
     2EGREES CELSIUS.  ARE THESE'/'VALUES ACCEPTABLE ??  IF YES (ENTER 0)
     3, IF NO (ENTER 1)')
      READ(*,*) ISOL
      END IF
      IF(ISOL.EQ.1) THEN
      IF(IOPT.NE.3) WRITE(*,127) IK
      WRITE(*,160)
 160  FORMAT('SOLUBILITY [g/cm3]')
      READ(*,*) HWIK(IK)
      WRITE(*,144)
 144  FORMAT('SPECIFIC VOLUME [cm3/g]')
      READ(*,*) VK(IK)
      END IF
      WRITE(12,735) HWIK(IK)
 735  FORMAT(E10.4,3X,'(HWIK(IK))',6X,'SOLUBILITY [g/cm3]')
      WRITE(12,744) VK(IK)
 744  FORMAT(E10.4,3X,'(VK(IK))',8X,'SPECIFIC VOLUME [cm3/g]')
      END IF
C
	IF(IOPT.EQ.4) THEN
      IRIM=1
	IF(IFLAG.LE.2) THEN
	WRITE(*,216)
 216  FORMAT('GAS FLUX [g/cm2-s] ACROSS RADIAL BOUNDARY')
      READ(*,*) FLX(1,IK)
      WRITE(12,816) FLX(1,IK)
 816  FORMAT(E10.4,3X,'(FLX(1,IK))',8X,'GAS FLUX ACROSS RADIAL BOUNDARY
     1[g/cm2-s]')
      ELSE
	IF(IK.LT.NK) THEN
	WRITE(*,216)
      READ(*,*) FLX(1,IK)
      WRITE(12,816) FLX(1,IK)
	END IF
	END IF
	END IF
C
C
      IF(IFLAG.LE.2) THEN
	IF(IK.EQ.NK .AND. NK.GT.1) WRITE(*,1)
	ELSE
	IF(IK.LT.NK) THEN
	IF(IK.EQ.NK .AND. NK.GT.1) WRITE(*,1)
      END IF
	END IF
      IF(IK.EQ.NK .AND. NK.GE.1) WRITE(12,2)
C     
 410  CONTINUE
C
C
      IF(IOPT.LE.2) THEN
      ZLOW=0
      ZHI=Z(2)
      RIM=RF
      END IF
C
      IF(IOPT.EQ.3 .OR. IOPT.EQ.4) THEN
      IF(IOPT.EQ.3) THEN
      WRITE(*,204)
 204  FORMAT('IMMISCIBLE PLUME VOLUMETRIC CONTENT [dimensionless]')
      READ(*,*) THI0
      WRITE(12,804) THI0
 804  FORMAT(E10.4,3X,'(THI0)',10X,'IMMISCIBLE PLUME VOLUMETRIC CONTENT
     1 [dimensionless]')
      END IF
      IF(IDIM.GE.2) THEN
      IF(IOPT.EQ.3) WRITE(*,172)
 172  FORMAT('RADIUS OF SOURCE [cm]')
      IF(IOPT.EQ.4) WRITE(*,217)
 217  FORMAT('RADIUS [cm] OVER WHICH FLUX IS APPLIED')
      READ(*,*) RIM
      ELSE
      RIM=RF
      END IF
      IF(IDIM.NE.2) THEN
      WRITE(*,192)
 192  FORMAT('LOWER SOURCE BOUNDARY: z - LOCATION [cm]')
      READ(*,*) ZLOW
      WRITE(*,196)
 196  FORMAT('UPPER SOURCE BOUNDARY: z - LOCATION [cm]')
      READ(*,*) ZHI
      ELSE
      ZLOW=ZWAT
      ZHI=Z(NZ)
      END IF
      END IF
C
      IF(IOPT.EQ.5) THEN
      OPEN(UNIT=84,FILE='IC.INPUT')
      READ(84,*) IK
      DO 701 IZ=1,NZ
      READ(84,208) (Y0(IR,IZ,1),IR=1,NR)
 701  CONTINUE
      IF(IDIM.EQ.1) THEN
	R0=R(1)
	RIM=R(NR)
	ZLOW=Z(1)
	ZHI=Z(2)
	IZLOW=1
	IZHI=2
      END IF
      IF(IDIM.EQ.2) THEN
	R0=R(1)
	RIM=R(2)
	ZLOW=Z(1)
	ZHI=Z(NZ)
      IZLOW=1
      IZHI=NZ
	END IF
	IF(IDIM.EQ.3) THEN
      WRITE(*,73)
  73  FORMAT('FORMER RADIUS [cm] OF SOURCE')
      READ(*,*) RIM
      WRITE(*,93)
  93  FORMAT('FORMER LOWER SOURCE BOUNDARY: z - LOCATION [cm]')
      READ(*,*) ZLOW
      WRITE(*,97)
  97  FORMAT('FORMER UPPER SOURCE BOUNDARY: z - LOCATION [cm]')
      READ(*,*) ZHI
      END IF    
      END IF
C
C
C -- IF MODELING O2 TRANSPORT FOR BIODEGRADATION ANALYSIS THEN
C    TOP BOUNDARY CONDITION CAN BE INDEPENDENTLY SPECIFIED FOR
C    CASES WHERE PLUME IS AT LAND SURFACE
C
      IND=0
      IATM=0
      IF(IFLAG.GE.3 .AND. IDIM.EQ.1) IND=1
      IF(IND.EQ.1 .AND. ZHI.GE.ZSURF) THEN
      WRITE(*,303)
 303  FORMAT('GAS-PHASE CONCENTRATION [g/cm3] FOR OXYGEN AT LAND SURFACE
     1'/5X,'0: ATMOSPHERIC, 1: OTHER')
      READ(*,*)IATM
      IF(IATM.EQ.0) THEN
      ATOX=279E-6
      ELSE
      WRITE(*,307)
 307  FORMAT('GAS-PHASE CONCENTRATION [g/cm3] FOR OXYGEN')
      READ(*,*) ATOX
      END IF
      END IF
C
      WRITE(12,792) ZLOW
 792  FORMAT(E10.4, 3X,'(ZLOW)',10X,'LOWER SOURCE BOUNDARY: z - LOCATION
     1 [cm]')
      WRITE(12,796) ZHI
 796  FORMAT(E10.4, 3X,'(ZHI)',11X,'UPPER SOURCE BOUNDARY: z - LOCATION
     1[cm]')
      IF(IOPT.LE.3 .OR. IOPT.EQ.5) WRITE(12,772) RIM
 772  FORMAT(E10.4, 3X,'(RIM)',11X,'RADIUS OF SOURCE [cm]')
      IF(IOPT.EQ.4) WRITE(12,817) RIM
 817  FORMAT(E10.4,3X,'(RIM)',11X,'RADIUS OVER WHICH FLUX IS APPLIED [cm
     1]')
C
C
C  ---NON SOURCE BOUNDARY CONDITIONS
C
C
      IF(IDIM.EQ.3) THEN
      WRITE(*,198)
 198  FORMAT('CHARACTERIZE THE OUTER RADIAL BOUNDARY (r = RF)'/5X,'0: UN
     1IFORM'/5X,'1: VARIABLE')
      READ(*,*) IFAR
      ELSE
      IFAR=0
      END IF
C
      IF(IDIM.EQ.1) THEN
      ZBAS=ZWAT
      AZ1=0.0
      AZ2=0.0
      END IF
C
      IF(IDIM.GE.2) THEN
      IF(IFAR.EQ.0) THEN
      ZBAS=ZWAT
      WRITE(*,232)
 232  FORMAT(13X,'BOUNDARY CONDITION PARAMETER MENU'/62('-')/3X,'0 CORRE
     1SPONDS TO dG/dr or dG/dz = 0 (i.e., no gradient)'/3X,'1 CORRESPOND
     2S TO G = Go'/3X,'0.0 < X < 1.0 INTERMEDIATE CONDITION'/62('-')/)
      WRITE(*,539)
 539  FORMAT('BOUNDARY CONDITION PARAMETER: OUTER RADIAL BOUNDARY (r = R
     1F)')
      READ(*,*) AZ1
      AZ2=AZ1
      ELSE
      WRITE(*,200)
 200  FORMAT('VERTICAL DISTANCE (z = ZBAS) [cm] WHERE TRANSITION OCCURS
     1ALONG: r = RF')
      READ(*,*) ZBAS
      WRITE(*,232)
      WRITE(*,244)
 244  FORMAT('BOUNDARY CONDITION PARAMETER: (0 < z <= ZBAS)')
      READ(*,*) AZ1
      WRITE(*,248)
 248  FORMAT('BOUNDARY CONDITION PARAMETER: (ZBAS < z < UPPER BOUNDARY)'
     1)
      READ(*,*) AZ2
      END IF
      END IF
C
      IF(IDIM.EQ.3) THEN
      WRITE(*,176)
 176  FORMAT('CHARACTERIZE THE UPPER BOUNDARY (z = ZSURF)'/5X,'0: UNIFOR
     1M'/5X,'1: VARIABLE')
      READ(*,*) ISURF
      ELSE
      ISURF=0
      END IF
C
      IF(IDIM.EQ.1) THEN
      RASP=0.0
      IF(ZHI.LT.ZSURF) THEN
      WRITE(*,232)
      WRITE(*,231)
 231  FORMAT('BOUNDARY CONDITION PARAMETER: z = UPPER VERTICAL BOUNDARY'
     1)
      READ(*,*) AR1
      ELSE
      AR1=1.0
      END IF
      AR2=AR1
      END IF
C
      IF(IDIM.EQ.2) THEN
      RASP=RF
      AR1=0.0
      AR2=0.0
      AR3=0.0
      AR4=0.0
      END IF
C
      IF(IDIM.EQ.3) THEN
      IF(ZHI.LT.ZSURF) THEN
      IF(ISURF.EQ.0) THEN
      RASP=0.0
      WRITE(*,232)
      WRITE(*,231)
      READ(*,*) AR1
      AR2=AR1
      ELSE
      WRITE(*,177)
 177  FORMAT('RADIAL DISTANCE (r = RASP) [cm] WHERE TRANSITION OCCURS AL
     1ONG'/' z = UPPER VERTICAL BOUNDARY')
      READ(*,*) RASP
      WRITE(*,232)
      WRITE(*,236)
 236  FORMAT('BOUNDARY CONDITION PARAMETER: (0 < r <= RASP)')
      READ(*,*) AR1
      WRITE(*,240)
 240  FORMAT('BOUNDARY CONDITION PARAMETER: (RASP < r < OUTER BOUNDARY)'
     1)
      READ(*,*) AR2
      END IF
      ELSE
      AR1=1.0
      AR2=AR1
      END IF
      END IF
C
      IF(IDIM.EQ.1 .OR. IDIM.EQ.3) THEN
      IF(IFLAG.GE.3) THEN
      IF(IOPT.GE.3) THEN
	WRITE(*,232)
      WRITE(*,104) NK
 104  FORMAT('BOUNDARY CONDITION PARAMETER: z = LOWER VERTICAL BOUNDARY'
     1/'  --FOR ALL CONSTITUENTS <',I2)
      READ(*,*) AR3
      END IF
	WRITE(*,105)
 105  FORMAT('BOUNDARY CONDITION PARAMETER: z = LOWER VERTICAL BOUNDARY-
     1-FOR OXYGEN')
      READ(*,*) AR4
      ELSE
      IF(IOPT.GE.3) THEN
	WRITE(*,232)
      WRITE(*,109)
 109  FORMAT('BOUNDARY CONDITION PARAMETER: z = LOWER VERTICAL BOUNDARY'
     1)
      READ(*,*) AR3
      AR4=AR3
      END IF
	END IF
      ELSE
      AR3=0.0
      AR4=AR3
      END IF

C
      WRITE(12,698) IFAR
 698  FORMAT(I5, 8X,'(IFAR)',10X,'OUTER BOUNDARY CHARACTERIZATION'/31X,'
     10: UNIFORM'/31X,'1: VARIABLE')
      WRITE(12,800) ZBAS
 800  FORMAT(E10.4, 3X,'(ZBAS)',10X,'VERTICAL DISTANCE WHERE TRANSITION
     1OCCURS [cm]')
      WRITE(12,844) AZ1
 844  FORMAT(E10.4,3X,'(AZ1)',11X,'BOUNDARY CONDITION PARAMETER: (0 < z
     1< ZBAS)')
      WRITE(12,848) AZ2
 848  FORMAT(E10.4,3X,'(AZ2)',11X,'BOUNDARY CONDITION PARAMETER:'/31X,'(
     1ZBAS < z < UPPER BOUNDARY)')
      WRITE(12,775) ISURF
 775  FORMAT(I5, 8X,'(ISURF)',9X,'UPPER BOUNDARY CHARACTERIZATION'/31X,'
     10: UNIFORM'/31X,'1: VARIABLE')
      WRITE(12,767) RASP
 767  FORMAT(E10.4,3X,'(RASP)',10X,'RADIAL DISTANCE WHERE TRANSITION OCC
     1URS [cm]')
      WRITE(12,836) AR1
 836  FORMAT(E10.4,3X,'(AR1)',11X,'BOUNDARY CONDITION PARAMETER: (0 < r
     1< RASP)')
      WRITE(12,840) AR2
 840  FORMAT(E10.4,3X,'(AR2)',11X,'BOUNDARY CONDITION PARAMETER:'/31X,'(
     1RASP < r < OUTER BOUNDARY)')
      WRITE(12,111) AR3
 111  FORMAT(E10.4,3X,'(AR3)',11X,'BOUNDARY CONDITION PARAMETER: LOWER B
     1OUNDARY')
      WRITE(12,113) AR4
 113  FORMAT(E10.4,3X,'(AR4)',11X,'BOUNDARY CONDITION PARAMETER: LOWER B
     1OUNDARY'/31X,'--FOR OXYGEN')
C
      IF(AR3.GT.0 .AND. IOPT.GT.2) THEN
	DO 411 IK=1,NK
	IF(IK.EQ.NK .AND. IFLAG.GE.3) GO TO 411
	WRITE(*,193) IK
 193  FORMAT('GAS-PHASE CONCENTRATION (Go) [g/cm3] OF CONSTITUENT',I2,' 
     1AT THE WATER TABLE (z=0)')
      READ(*,*) GWAT(IK)
      WRITE(12,793) GWAT(IK),IK
 793  FORMAT(E10.4, 3X,'(GWAT(IK))',6X,'GAS-PHASE CONCENTRATION Go OF TH
     1E',I2,' CONSTITUENT'/31X,'AT THE WATER TABLE [g/cm3]')
 411  CONTINUE
	END IF
C
      IF(AR4.GT.0) THEN
      IF(IFLAG.GE.3) THEN
	WRITE(*,194)
 194  FORMAT('GAS-PHASE CONCENTRATION [g/cm3] OF OXYGEN AT THE WATER TAB
     1BLE (z=0)')
      READ(*,*) GWAT(NK)
      WRITE(12,794) GWAT(NK)
 794  FORMAT(E10.4, 3X,'(GWAT(NK))',6X,'GAS-PHASE CONCENTRATION OF OXYGE
     1N AT THE'/31X,'WATER TABLE [g/cm3]')
	END IF
      END IF
C
      IND=0
      IF(IFLAG.GE.3 .AND. IDIM.EQ.1) IND=1
      IF(IND.EQ.1 .AND. ZHI.GE.ZSURF) WRITE(12,305) ATOX
 305  FORMAT(E10.4, 3X,'(ATOX)',10X,'GAS-PHASE CONCENTRATION FOR O2'/31X
     1,'AT LAND SURFACE [g/cm3]')
C
C
C  FIND INDICIES FOR SPECIAL COORDINATES
C
      IF(IOPT.LE.3 .OR. IOPT.EQ.5) CALL NODLOC(1,IRIM,RIM)
      CALL NODLOC(1,IRASP,RASP)
      CALL NODLOC(1,IRFP,RFP)
      CALL NODLOC(2,IZLOW,ZLOW)
	IF(IOPT.EQ.3 .AND. IZLOW.EQ.1) IZLOW=IZLOW+1
	IF(IOPT.EQ.5 .AND. IZLOW.EQ.1) IZLOW=IZLOW+1
      CALL NODLOC(2,IZHI,ZHI)
	IF(IOPT.EQ.3 .AND. IZHI.EQ.NZ) IZHI=IZHI-1
	IF(IOPT.EQ.5 .AND. IZHI.EQ.NZ) IZHI=IZHI-1
      CALL NODLOC(2,IZBAS,ZBAS)
C
C
C **********************INITIAL CONDITION INPUT*************************
C
C ** LABEL 556 IS A GO TO STATEMENT IF INITIAL CONDITION MUST BE
C     REDEFINED BY USER
C
 556  CONTINUE
C
      IF(IOPT.LT.5) THEN
      DO 430 IK=1,NK
      WRITE(*,256) IK
 256  FORMAT('INITIAL CONDITION FOR CONSTITUENT',I3,' (ENTIRE MODEL DOMA
     1IN)'/5X,'0: CONSTANT'/5X,'1: LINEAR VARIATION: z - DIRECTION'/5X,'
     22: LINEAR VARIATION: r - DIRECTION'/5X,'3: WARM START - VARIES IN
     3BOTH r and z - DIRECTIONS'/8X,'AND IS SPECIFIED IN A SEPARATE INPU
     4T FILE')
      READ(*,15) INOPT
C
      IF(INOPT.EQ.0) THEN
      WRITE(*,260) IK
 260  FORMAT('INITIAL CONCENTRATION [g/cm3] FOR CONSTITUENT',I3)
      READ(*,*) U0
      END IF
C
      IF(INOPT.EQ.1) THEN
      WRITE(*,359)
 359  FORMAT('SPECIFY THE INITIAL CONCENTRATION [g/cm3] AT THE LOWER BOU
     1NDARY')
      READ(*,*) U1
      WRITE(*,363)
 363  FORMAT('SPECIFY THE INITIAL CONCENTRATION [g/cm3] AT THE UPPER BOU
     1NDARY')
      READ(*,*) U2
      U11=(U2-U1)/NZ
      END IF
C
      IF(INOPT.EQ.2) THEN
      WRITE(*,358)
 358  FORMAT('SPECIFY THE INITIAL CONCENTRATION [g/cm3] AT THE INNER RAD
     1IAL BOUNDARY')
      READ(*,*) U1
      WRITE(*,357)
 357  FORMAT('SPECIFY THE INITIAL CONCENTRATION [g/cm3] AT THE OUTER RAD
     1IAL BOUNDARY')
      READ(*,*) U2
      U22=(U2-U1)/NR
      END IF
C
      IF(INOPT.EQ.3) THEN
      IF(IK.EQ.1) THEN
      WRITE(*,261)
 261  FORMAT('SPECIFY THE NAME OF THE INPUT FILE CONTAINING THE INITIAL
     1CONDITION')
      READ(*,17) FNAMEICDAT
      OPEN(UNIT=6,FILE=FNAMEICDAT)
      END IF
      READ(6,*) ICOUNT
      DO 481 IZ=1,NZ
      READ(6,208) (Y0(IR,IZ,ICOUNT),IR=1,NR)
 481  CONTINUE
      END IF
C
      DO 431 IR=1,NR
      DO 431 IZ=1,NZ
      IND=0
      IF(IZ.GE.IZLOW .AND. IZ.LE.IZHI) IND=1
      IF(IND.EQ.1 .AND. IR.LE.IRIM) GO TO 431
      IF(INOPT.EQ.0) Y0(IR,IZ,IK)=U0
      IF(INOPT.EQ.1) Y0(IR,IZ,IK)=(U11*IZ)+U1
      IF(INOPT.EQ.2) Y0(IR,IZ,IK)=(U22*IR)+U1
      IF(INOPT.EQ.3) Y0(IR,IZ,IK)=Y0(IR,IZ,IK)
 431  CONTINUE
C
 430  CONTINUE
C     
C
C
C   DETERMINE WHETHER TOTAL PRESSURE OF GAS-PHASE [PT(IR,IZ)] EXCEEDS
C   ATMOSPERIC PRESSURE [PP(IR,IZ,IK) = PARTIAL PRESSURE]
C
C
      IWARN=0
C
      DO 471 IR=1,NR
      DO 471 IZ=1,NZ
      PT(IR,IZ)=0.0
 471  CONTINUE
C
      DO 469 IK=1,NK
      DO 469 IR=1,NR
      DO 469 IZ=1,NZ
      IND=0
      IF(IZ.GT.IZLOW .AND. IZ.LT.IZHI) IND=1
      IF(IND.EQ.1 .AND. IR.LT.IRIM) GO TO 469
      PP(IR,IZ,IK)=(Y0(IR,IZ,IK)*(273.15+TEMP)*82.057)/WK(IK)
      IF(PP(IR,IZ,IK).LT.1E-5) PP(IR,IZ,IK)=1E-5
      PT(IR,IZ)=PP(IR,IZ,IK)+PT(IR,IZ)
 469  CONTINUE
C
C    ICOMP = 0, EXTRA GASEOUS-PHASE CONSTITUENT (PP=ATMOSPHERIC - PT)
C    ICOMP = 1, ALL GASEOUS-PHASE CONSTITUENTS ACCOUTED FOR
C
      DO 472 IR=1,NR
      DO 472 IZ=1,NZ
      IND=0
      IF(IZ.GT.IZLOW .AND. IZ.LT.IZHI) IND=1
      IF(IND.EQ.1 .AND. IR.LT.IRIM) GO TO 472
      IF(ICOMP.EQ.0) THEN
      IF(PT(IR,IZ).LE.(ATM/760)) THEN
      PP(IR,IZ,NK+1)=(ATM/760)-PT(IR,IZ)
      ELSE
      PP(IR,IZ,NK+1)=0.00001
      IWARN=1
      END IF
      ELSE
      IF(PT(IR,IZ).GT.(ATM/760) .OR. PT(IR,IZ).LT.(ATM/760)) IWARN=1
      END IF
 472  CONTINUE
C
C
      IF(IWARN.EQ.0) THEN
      GO TO 697
      ELSE
      INCHECK=1
      IF(ICOMP.EQ.0) THEN
      WRITE(*,333)
 333  FORMAT('** PARTIAL PRESSURE EXCEEDS ATMOSPHERIC PRESSURE AT CERTAI
     1N NODES'/3X,'IN MODEL DOMAIN')
      WRITE(*,336)
      ELSE
      WRITE(*,335)
 335  FORMAT('** PARTIAL PRESSURE OF GASEOUS-PHASE DOES NOT EQUAL ATMOSP
     1HERIC PRESSURE AT'/'CERTAIN NODES IN MODEL DOMAIN')
      WRITE(*,336)
 336  FORMAT(/'INITIAL CONDITION OPTION'/5X,'0: INITIAL CONDITION REDEFI
     1NED BY USER'/5X,'1: INITIAL CONDITION READJUSTED SO THAT PARTIAL P
     2RESSURE = ATMOSPHERIC')
      END IF
      READ(*,*) INCHECK
      END IF
C
      IF(INCHECK.EQ.0) THEN
      IF(INOPT.EQ.3) THEN
      WRITE(*,661) FNAMEICDAT
 661  FORMAT('PLEASE REDEFINE INITIAL CONDITION IN THE INPUT FILE ',A10)
      CLOSE(UNIT=6)
      ELSE
      GO TO 556
      END IF
      ELSE
C
C - ADJUST INITIAL CONDITION SO THAT PT(IR,IZ)=ATMOSPHERIC
C
      DO 477 IK=1,NK
      DO 477 IR=1,NR
      DO 477 IZ=1,NZ
      IND=0
      IF(IZ.GT.IZLOW .AND. IZ.LT.IZHI) IND=1
      IF(IND.EQ.1 .AND. IR.LT.IRIM) GO TO 477
      PP(IR,IZ,IK)=PP(IR,IZ,IK)*(ATM/(760*PT(IR,IZ)))
      Y0(IR,IZ,IK)=PP(IR,IZ,IK)*WK(IK)/((273.15+TEMP)*82.057)
 477  CONTINUE
      END IF
 697  CONTINUE
C
      WRITE(12,829)
 829  FORMAT(/'*** DISCRETIZED INITIAL CONDITION DATA CONTAINED IN FILE-
     1"IC.MAP"')
      DO 468 IK=1,NK
      OPEN(UNIT=14,FILE='IC.MAP')
      DO 468 IZ=1,NZ
      IF(IZ.EQ.1) WRITE(14,*) IK
      WRITE(14,208) (Y0(IR,IZ,IK),IR=1,NR)
 468  CONTINUE
      END IF
C
      IF(ICOMP.EQ.0) THEN
      WRITE(*,263)
 263  FORMAT('SELECT THE CONSTITUENT COMPRISING THE REMAINDER OF THE UNS
     1ATURATED-ZONE'/'GAS-PHASE COMPOSITION'/45('-')/5X,'(1):',4X,'NITRO
     2GEN - N2'/5X,'(2):',4X,'OXYGEN - O2'/5X,'(3):',4X,'CARBON DIOXIDE
     3- CO2'/5X,'(4):',4X,'AIR - (78% N2, 21% O2, 1% Ar)'/5X,'(5):',4X,'
     4WATER VAPOR - H2O'/)
      READ(*,*) ICONX
      IF(ICONX.EQ.1) THEN
      M='NITROGEN'
      WK(NK+1)=28.02
      DV(NK+1)=18.5
      END IF
      IF(ICONX.EQ.2) THEN
      M='OXYGEN'
      WK(NK+1)=32.00
      DV(NK+1)=16.3
      END IF
      IF(ICONX.EQ.3) THEN
      M='CARBON DIOXIDE'
      WK(NK+1)=44.01
      DV(NK+1)=26.9
      END IF
      IF(ICONX.EQ.4) THEN
      M='AIR'
      WK(NK+1)=28.97
      DV(NK+1)=19.7
      END IF
      IF(ICONX.EQ.5) THEN
      M='WATER VAPOR'
      WK(NK+1)=18.00
      DV(NK+1)=25.14
      END IF
 863  FORMAT(I5, 8X,'(ICONX)',9X,'CONSTITUENT COMPRISING REMAINDER OF UN
     1SATURATED-'/31X,'ZONE GAS-PHASE COMPOSITION= ',A30)
      END IF
C
C  CALCULATE BINARY DIFFUSIVITIES ACCORDING TO METHOD OF
C  FULLER E.N., SCHETTER P.D., AND GIDDINGS J.C. (IND. ENG. CHEM. 58:18. 1966)
C  A FUNCTION OF TEMPERATURE AND PRESSURE
C
C
      DO 315 IK=1,NK
      DO 316 JK=2,NK+1
      IF(ICOMP.EQ.1 .AND. JK.EQ.NK+1) GO TO 316
      IF(JK.GT.IK) THEN
      U10=2.0/(1.0/WK(IK)+1.0/WK(JK))
      U10=U10**(0.5)
      U11=(DV(IK)**(1.0/3.0)+DV(JK)**(1.0/3.0))
      U11=U11*U11
      DKAB(IK,JK)=(1.087*((TEMP+273.15)**1.75))/(ATM*U10*U11)
      DKAB(JK,IK)=DKAB(IK,JK)
      END IF
 316  CONTINUE
 315  CONTINUE
C
C  DETERMINE THE EFFECTIVE DIFFUSIVITIES
C
      CALL DIFF
C
      OPEN(UNIT=15,FILE='DKA.MAP')
C
C     IF(IDIM.EQ.1 .OR. IDIM.EQ.3) THEN
      DO 444 IK=1,NK
      DO 444 IZ=1,NZ
      DKA(1,IZ,IK)=DKA(2,IZ,IK)
 444  CONTINUE
C     END IF
      IF(IDIM.EQ.2) THEN
      DO 443 IK=1,NK
      DO 443 IR=1,NR
      DKA(IR,2,IK)=DKA(IR,3,IK)
 443  CONTINUE
      END IF
C
      DO 445 IK=1,NK
      WRITE(15,*) IK
      DO 445 IZ=1,NZ
      WRITE(15,208) (DKA(IR,IZ,IK),IR=1,NR)
 445  CONTINUE
C
C  DETERMINE INITIAL VOLUME AND MASS OF CONSTITUENTS IN MODEL DOMAIN FOR A
C  MASS BALANCE ANALYSIS (IOPT=3 ONLY).
C
      IF(IOPT.EQ.3) THEN
      VIMM=((3.14159)*R(IRIM)**2)*(Z(IZHI)-Z(IZLOW))
      SUM=0.0
      DO 400 IK=1,NK
      TMASS0(IK)=0.0
      TMASS0(IK)=VIMM*THI0*XIK0(IK)
      IF(TMASS0(IK).LT.1E-10) TMASS0(IK)=1.0E-10
      SUM=SUM+XIK0(IK)/WK(IK)
 400  CONTINUE
      END IF
C
C
      WRITE(*,268)
      WRITE(12,268)
 268  FORMAT(/19('*'),' PHYSICAL PROPERTIES OF THE POROUS MEDIA ',20('*'
     1)/)
      WRITE(*,269)
 269  FORMAT('UNSATURATED-ZONE SEDIMENT CHARACTERIZATION'/5X,'0: HOMOGEN
     1EOUS'/5X,'1: HETEROGENEOUS (sediment properties specified in separ
     2ate input files'/8X,'for porosity, moisture content,tortuosity, an
     3d bulk density)'/5X,'2: STRATIFIED (sediment properties are unifor
     4m for individual layers)')
      READ(*,*) ISTRAT
      IF(ISTRAT.EQ.0) THEN
      NL=1
	IL=NL
      CALL NODLOC(2,IZLAY(IL),ZLAY(IL))
      ALT(NL)=0.0
      AL(NL)=0.0
      WRITE(12,806) ISTRAT
 806  FORMAT(I5, 8X,'(ISTRAT)',8X,'HOMOGENEOUS UNSATURATED ZONE')
      WRITE(*,459)
 459  FORMAT('POROSITY OF UNSATURATED ZONE [dimensionless]')
      READ(*,*) POR(NZ)
      WRITE(12,755) POR(NZ)
 755  FORMAT(E10.4, 3X,'(POR(NZ))',7X,'POROSITY OF UNSATURATED ZONE [dim
     1ensionless]')
      WRITE(*,557)
 557  FORMAT('MOISTURE CONTENT (AQUEOUS-FILLED POROSITY) OF UNSATURATED
     1ZONE [dimensionless]')
      READ(*,*) THW(NZ)
      WRITE(12,553) THW(NZ)
 553  FORMAT(E10.4, 3X,'(THW(NZ))',7X,'MOISTURE CONTENT OF UNSAT. ZONE [
     1dimensionless]')
      WRITE(*,292)
      READ(*,15) IMILQ
      THA(NZ)=POR(NZ)-THW(NZ)
      IF(IMILQ.EQ.0) THEN
      TA(NZ)=(THA(NZ)**(7.0/3.0))/(POR(NZ)**2)
      ELSE
      WRITE(*,296)
      READ(*,*) TA(NZ)
      END IF
      WRITE(12,886) TA(NZ)
      WRITE(*,312)
 312  FORMAT('BULK DENSITY [g/cm3]')
      READ(*,*) BD(NZ)
      WRITE(12,912) BD(NZ)
      IF(IDISP.EQ.1) THEN
      IF(IDIM.EQ.1 .OR. IDIM.EQ.3) THEN
      WRITE(*,304)
      READ(*,*) AL(NL)
      WRITE(12,904) AL(NL)
      END IF
      IF(IDIM.EQ.2 .OR. IDIM.EQ.3) THEN
      WRITE(*,308)
      READ(*,*) ALT(NL)
      WRITE(12,908) ALT(NL)
      END IF
      END IF
      END IF
C
      IF(ISTRAT.EQ.1) THEN
      OPEN(UNIT=16,FILE='POR.MAP')
      OPEN(UNIT=17,FILE='THW.MAP')
      OPEN(UNIT=18,FILE='THA.MAP')
      OPEN(UNIT=19,FILE='TA.MAP')
      OPEN(UNIT=20,FILE='TW.MAP')
      OPEN(UNIT=29,FILE='BD.MAP')
      NL=1
	IL=NL
      ALT(NL)=0.0
      AL(NL)=0.0
      CALL NODLOC(2,IZLAY(IL),ZLAY(IL))
      WRITE(12,807) ISTRAT
 807  FORMAT(I5, 8X,'(ISTRAT)',8X,'HETEROGENEOUS UNSATURATED ZONE')
      WRITE(*,306)
 306  FORMAT('SPECIFY THE NAME OF THE INPUT FILE CONTAINING POROSITY DAT
     1A')
      READ(*,17) FNAMEPOR
      OPEN(UNIT=7,FILE=FNAMEPOR)
      READ(7,*) NDAT
      DO 499 IDAT=1,NDAT
      READ(7,*) XPT(IDAT),YPT(IDAT)
 499  CONTINUE
      IDAT=1
      DO 786 IZ=1,NZ
      IF(Z(IZ).LT.XPT(1) .OR. Z(IZ).GT.XPT(NDAT)) THEN
      IF(Z(IZ).LT.XPT(1)) POR(IZ)=YPT(1)
      IF(Z(IZ).GT.XPT(NDAT)) POR(IZ)=YPT(NDAT)
      ELSE
      IF(Z(IZ).GT.XPT(IDAT+1)) THEN
      IDAT=IDAT+1
      IF(IDAT.GT.NDAT) IDAT=NDAT
      END IF
      SLPZ(IDAT)=(YPT(IDAT+1)-YPT(IDAT))/(XPT(IDAT+1)-XPT(IDAT))
      BZZ(IDAT)=YPT(IDAT)-SLPZ(IDAT)*XPT(IDAT)
      POR(IZ)=SLPZ(IDAT)*Z(IZ)+BZZ(IDAT)
      END IF
 786  CONTINUE
      WRITE(*,297)
 297  FORMAT('SPECIFY THE NAME OF THE INPUT FILE CONTAINING MOISTURE CON
     1TENT DATA')
      READ(*,17) FNAMETHW
      OPEN(UNIT=8,FILE=FNAMETHW)
      READ(8,*) NDAT
      DO 495 IDAT=1,NDAT
      READ(8,*) XPT(IDAT),YPT(IDAT)
      IF(Z(IDAT).EQ.XPT(IDAT)) THW(IDAT)=YPT(IDAT)
 495  CONTINUE
      IDAT=1
      DO 787 IZ=1,NZ
      IF(Z(IZ).LT.XPT(1) .OR. Z(IZ).GT.XPT(NDAT)) THEN
      IF(Z(IZ).LT.XPT(1)) THW(IZ)=YPT(1)
      IF(Z(IZ).GT.XPT(NDAT)) THW(IZ)=YPT(NDAT)
      ELSE
      IF(Z(IZ).GT.XPT(IDAT+1)) THEN
      IDAT=IDAT+1
      IF(IDAT.GT.NDAT) IDAT=NDAT
      END IF
      SLPZ(IDAT)=(YPT(IDAT+1)-YPT(IDAT))/(XPT(IDAT+1)-XPT(IDAT))
      BZZ(IDAT)=YPT(IDAT)-SLPZ(IDAT)*XPT(IDAT)
      THW(IZ)=SLPZ(IDAT)*Z(IZ)+BZZ(IDAT)
      END IF
      THA(IZ)=POR(IZ)-THW(IZ)
 787  CONTINUE
      WRITE(*,298)
 298  FORMAT('SPECIFY THE NAME OF THE INPUT FILE CONTAINING TORTUOSITY D
     1ATA')
      READ(*,17) FNAMETA
      OPEN(UNIT=9,FILE=FNAMETA)
      READ(9,*) NDAT
      DO 496 IDAT=1,NDAT
      READ(9,*) XPT(IDAT),YPT(IDAT)
 496  CONTINUE
      IDAT=1
      DO 788 IZ=1,NZ
      IF(Z(IZ).LT.XPT(1) .OR. Z(IZ).GT.XPT(NDAT)) THEN
      IF(Z(IZ).LT.XPT(1)) TA(IZ)=YPT(1)
      IF(Z(IZ).GT.XPT(NDAT)) TA(IZ)=YPT(NDAT)
      ELSE
      IF(Z(IZ).GT.XPT(IDAT+1)) THEN
      IDAT=IDAT+1
      IF(IDAT.GT.NDAT) IDAT=NDAT
      END IF
      SLPZ(IDAT)=(YPT(IDAT+1)-YPT(IDAT))/(XPT(IDAT+1)-XPT(IDAT))
      BZZ(IDAT)=YPT(IDAT)-SLPZ(IDAT)*XPT(IDAT)
      TA(IZ)=SLPZ(IDAT)*Z(IZ)+BZZ(IDAT)
      END IF
 788  CONTINUE
      WRITE(*,798)
 798  FORMAT('SPECIFY THE NAME OF THE INPUT FILE CONTAINING BULK DENSITY
     1 DATA')
      READ(*,17) FNAMEBD
      OPEN(UNIT=10,FILE=FNAMEBD)
      READ(10,*) NDAT
      DO 654 IDAT=1,NDAT
      READ(10,*) XPT(IDAT),YPT(IDAT)
 654  CONTINUE
      IDAT=1
      DO 754 IZ=1,NZ
      IF(Z(IZ).LT.XPT(1) .OR. Z(IZ).GT.XPT(NDAT)) THEN
      IF(Z(IZ).LT.XPT(1)) BD(IZ)=YPT(1)
      IF(Z(IZ).GT.XPT(NDAT)) BD(IZ)=YPT(NDAT)
      ELSE
      IF(Z(IZ).GT.XPT(IDAT+1)) THEN
      IDAT=IDAT+1
      IF(IDAT.GT.NDAT) IDAT=NDAT
      END IF
      SLPZ(IDAT)=(YPT(IDAT+1)-YPT(IDAT))/(XPT(IDAT+1)-XPT(IDAT))
      BZZ(IDAT)=YPT(IDAT)-SLPZ(IDAT)*XPT(IDAT)
      BD(IZ)=SLPZ(IDAT)*Z(IZ)+BZZ(IDAT)
      END IF
 754  CONTINUE
C
C  THE TORTUOSITY (WATER-PHASE) IS COMPUTED BY MILLINGTON-QUIRK
C
      DO 559 IZ=1,NZ
      TW(IZ)=(THW(IZ)**(7.0/3.0))/(POR(IZ)**2)
 559  CONTINUE
C
      IF(IDISP.EQ.1) THEN
      IF(IDIM.EQ.1 .OR. IDIM.EQ.3) THEN
      WRITE(*,304)
      READ(*,*) AL(NL)
      WRITE(12,904) AL(NL)
      END IF
      IF(IDIM.EQ.2 .OR. IDIM.EQ.3) THEN
      WRITE(*,308)
      READ(*,*) ALT(NL)
      WRITE(12,908) ALT(NL)
      END IF
      ELSE
      AL(NL)=0.0
      ALT(NL)=0.0
      END IF
      END IF
C
      IF(ISTRAT.EQ.2) THEN
      WRITE(*,272)
 272  FORMAT(/'** WARNING **  SHARP DISCONTINUTIES IN THE PHYSICAL PROPE
     1RTIES OF ADJOINING'/15X,'STRATIGRAPHIC UNITS MAY CAUSE THE ALGORIT
     2HM TO FAIL'/)
      WRITE(12,803) ISTRAT
 803  FORMAT(I5, 8X,'(ISTRAT)',8X,'STRATIFIED UNSATURATED ZONE')
      WRITE(*,16)
 16   FORMAT('NUMBER OF STRATIGRAPHIC UNITS IN MODEL DOMAIN')
      READ(*,*) NL
      WRITE(12,616) NL
 616  FORMAT(I5, 8X,'(NL)',12X,'NUMBER OF STRATIGRAPHIC UNITS')
      DO 450 IL=1,NL
      IF(NL.NE.1) THEN
      WRITE(*,276) IL
      WRITE(12,276) IL
 276  FORMAT(/35('-'),' LAYER ',I2,1X,35('-')/)
      IF(IL.LT.NL) THEN
      WRITE(*,280)
 280  FORMAT('TOP ELEVATION OF LAYER [cm]')
      READ(*,*) ZLAY(IL)
      ELSE
      ZLAY(NL)=ZSURF
      END IF
      WRITE(12,883) ZLAY(IL)
 883  FORMAT(E10.4, 3X,'(ZLAY(IL))',6X,'TOP ELEVATION OF LAYER [cm]')
      CALL NODLOC(2,IZLAY(IL),ZLAY(IL))
      END IF
      WRITE(*,284)
 284  FORMAT('POROSITY OF LAYER [dimensionless]')
      READ(*,*) PORL(IL)
      WRITE(12,884) PORL(IL)
 884  FORMAT(E10.4, 3X,'(PORL(IL))',6X,'POROSITY OF LAYER [dimensionless
     1]')
      WRITE(*,288)
 288  FORMAT('MOISTURE CONTENT (AQUEOUS-FILLED POROSITY) OF LAYER [dimen
     1sionless]')
      READ(*,*) THWL(IL)
      WRITE(12,888) THWL(IL)
 888  FORMAT(E10.4, 3X,'(THWL(IL))',6X,'MOISTURE CONTENT OF LAYER [dimens
     1ionless]')
      THAL(IL)=PORL(IL)-THWL(IL)
      WRITE(*,292)
 292  FORMAT('TORTUOSITY OPTION'/5X,'0: TORTUOSITY COMPUTED ACCORDING TO
     1 MILLINGTON-QUIRK (1966) RELATION'/5X,'1: TORTUOSITY VALUE INPUT B
     2Y USER')
      READ(*,15) IMILQ
      IF(IMILQ.EQ.0) THEN
      TAL(IL)=(THAL(IL)**(7.0/3.0))/(PORL(IL)**2)
      ELSE
      WRITE(*,296)
 296  FORMAT('TORTUOSITY [dimensionless]')
      READ(*,*) TAL(IL)
      END IF
      WRITE(12,886) TAL(IL)
 886  FORMAT(E10.4, 3X,'(TAL(IL))',7X,'TORTUOSITY [dimensionless]')
      WRITE(*,312)
      READ(*,*) BDL(IL)
      WRITE(12,912) BDL(IL)
 912  FORMAT(E10.4, 3X,'(BDL(IL))',7X,'BULK DENSITY [g/cm3]')
      ALT(IL)=0.0
      AL(IL)=0.0
      IF(IDISP.EQ.1) THEN
      IF(IDIM.EQ.1 .OR. IDIM.EQ.3) THEN
      WRITE(*,304)
 304  FORMAT('LONGITUDINAL DISPERSIVITY [cm]')
      READ(*,*) AL(IL)
      WRITE(12,904) AL(IL)
 904  FORMAT(E10.4, 3X,'(AL(IL))',8X,'LONGITUDINAL DISPERSIVITY [cm]')
      END IF
      IF(IDIM.EQ.2 .OR. IDIM.EQ.3) THEN
      WRITE(*,308)
 308  FORMAT('TRANSVERSE DISPERSIVITY [cm]')
      READ(*,*) ALT(IL)
      WRITE(12,908) ALT(IL)
 908  FORMAT(E10.4, 3X,'(ALT(IL))',7X,'TRANSVERSE DISPERSIVITY [cm]')
      END IF
      END IF
 450  CONTINUE
      END IF
C
      IF(ISTRAT.EQ.1) THEN
      WRITE(12,896)
 896  FORMAT(/'* POROSITY DATA CONTAINED IN FILE-"POR.MAP"')
      WRITE(12,897)
 897  FORMAT(/'* MOISTURE CONTENT DATA CONTAINED IN FILE-"THW.MAP"')
      WRITE(12,925)
 925  FORMAT(/'* GAS-FILLED POROSITY DATA CONTAINED IN FILE-"THA.MAP"')
      WRITE(12,898)
 898  FORMAT(/'* GAS-PHASE TORTUOSITY DATA CONTAINED IN FILE-"TA.MAP"')
      WRITE(12,921)
 921  FORMAT(/'* AQUEOUS-PHASE TORTUOSITY DATA CONTAINED IN FILE-"TW.MAP
     1"')
      WRITE(12,778)
 778  FORMAT(/'* BULK DENSITY DATA CONTAINED IN FILE-"BD.MAP"')
      END IF
C
C
      IF(ISTRAT.EQ.0) THEN
      DO 588 IZ=1,NZ
      THW(IZ)=THW(NZ)
      POR(IZ)=POR(NZ)
      THA(IZ)=THA(NZ)
      TA(IZ)=TA(NZ)
      TW(IZ)=(THW(NZ)**(7.0/3.0))/(POR(NZ)**2)
      BD(IZ)=BD(NZ)
 588  CONTINUE
      END IF
C
      IF(ISTRAT.EQ.1) THEN
      WRITE(16,210) (Z(IZ),POR(IZ),IZ=1,NZ)
      WRITE(17,210) (Z(IZ),THW(IZ),IZ=1,NZ)
      WRITE(18,210) (Z(IZ),THA(IZ),IZ=1,NZ)
      WRITE(19,210) (Z(IZ),TA(IZ),IZ=1,NZ)
      WRITE(20,210) (Z(IZ),TW(IZ),IZ=1,NZ)
      WRITE(29,210) (Z(IZ),BD(IZ),IZ=1,NZ)
      END IF
C
      IF(ISTRAT.EQ.2) THEN
      IL=1
      DO 497 IZ=1,NZ
      IF(Z(IZ).GE.Z(IZLAY(IL))) IL=IL+1
      IF(IL.GT.NL) IL=NL
      THW(IZ)=THWL(IL)
      POR(IZ)=PORL(IL)
      THA(IZ)=THAL(IL)
      TA(IZ)=TAL(IL)
      TW(IZ)=(THWL(IL)**(7.0/3.0))/(PORL(IL)**2)
      BD(IZ)=BDL(IL)
 497  CONTINUE
      END IF
C
      WRITE(*,7)
      WRITE(12,7)
 7    FORMAT(/29('*'),' ALGORITHM PARAMETERS ',29('*')/)
      WRITE(*,41)
 41   FORMAT('TIME-STEP OPTION'/5X,'0: CONSTANT TIME-STEP'/5X,'1: VARIAB
     1LE TIME-STEP')
      READ(*,*) ITIME
      WRITE(12,541) ITIME
 541  FORMAT(I5, 8X,'(ITIME)',9X,'TIME-STEP ADJUSTMENT OPTION'/31X,'0: C
     1ONSTANT TIME-STEP'/31X,'1: VARIABLE TIME-STEP')
      WRITE(*,40)
 40   FORMAT('INITIAL TIME-STEP [hrs]')
      READ(*,*) DT1
      WRITE(12,640) DT1
      DT1=DT1*3600
 640  FORMAT(E10.4,3X,'(DT1)',11X,'TIME-STEP [hrs]')
      IF(ITIME.EQ.0) THEN
      DT2=DT1
      DTM=1.0
      ELSE
      WRITE(*,44)
 44   FORMAT('MAXIMUM TIME-STEP [hrs]')
      READ(*,*) DT2
      WRITE(12,644) DT2
      DT2=DT2*3600
 644  FORMAT(E10.4,3X,'(DT2)',11X,'MAXIMUM TIME-STEP [hrs]')
      WRITE(*,60)
 60   FORMAT('TIME-STEP MULTIPLIER OPTION'/5X,'0: NO MULTIPLIER'/5X,'1:
     1CONSTANT MULTIPLIER'/5X,'2: VARIABLE MULTIPLIER LINKED TO NUMBER O
     2F ITERATIONS')
      READ(*,*) IDT
      WRITE(12,660) IDT
 660  FORMAT(I5, 8X,'(IDT)',11X,'TIME-STEP MULTIPLIER OPTION'/31X,'0: NO
     1 MULTIPLIER'/31X,'1: CONSTANT TIME-STEP MULTIPLIER'/31X,'2: VARIAB
     2LE MULTIPLIER LINKED TO # OF ITERATIONS')
      WRITE(*,52)
 52   FORMAT('TRANSITION TIME (e.g. time when time-step adjustment is ap
     1plied [hrs])')
      READ(*,*) TRANS
      WRITE(12,652) TRANS
 652  FORMAT(E10.4,3X,'(TRANS)',9X,'TRANSITION TIME [hrs]')
      TRANS=TRANS*3600
      IF(IDT.EQ.1) THEN
      WRITE(*,48)
 48   FORMAT('TIME-STEP MULTIPLIER')
      READ(*,*) DTM
      WRITE(12,648) DTM
 648  FORMAT(E10.4,3X,'(DTM)',11X,'TIME STEP MULTIPLIER [dimensionless]'
     1)
      ELSE
      DTM=1
      END IF
      END IF
      WRITE(*,56)
 56   FORMAT('ENDING TIME [hrs]')
      READ(*,*) TEND
      WRITE(12,656) TEND
      TEND=TEND*3600
      IF(ITIME.EQ.0) TRANS=TEND
 656  FORMAT(E10.4,3X,'(TEND)',10X,'ENDING TIME [hrs]')
      WRITE(*,76)
 76   FORMAT('STEADY-STATE DEFAULT OPTION'/5X,'0: DO NOT ZERO-OUT STORAG
     1E TERM'/5X,'1: ZERO-OUT STORAGE TERM')
      READ(*,*) ISS
      WRITE(12,676) ISS
 676  FORMAT(I5, 8X,'(ISS)',11X,'STEADY-STATE DEFAULT OPTION'/31X,'0: DO
     1 NOT ZERO-OUT STORAGE TERM'/31X,'1: ZERO-OUT STORAGE TERM')
      WRITE(*,32)
 32   FORMAT('MAXIMUM NUMBER OF ITERATIONS PER TIME STEP (recommended va
     1lue = 500)')
      READ(*,*) NITER
      WRITE(12,632) NITER
 632  FORMAT(I5, 8X,'(NITER)',9X,'MAX. # OF ITERATIONS PER TIME STEP')
      WRITE(*,36)
 36   FORMAT('CONVERGENCE CRITERIA - ACCEPTABLE MAXIMUM RELATIVE ERROR (
     1Y2-Y1)/Y1'/'(recommended value = 0.001)')
      READ(*,*) EPS
      WRITE(12,636) EPS
 636  FORMAT(E10.4,3X,'(EPS)',11X,'CONVERGENCE CRITERIA - ACCEPTABLE MAX
     1.'/31X,'RELATIVE ERROR')
      WRITE(*,72)
 72   FORMAT('MATRIX-SOLVER SEED (recommended option = 0)'/5X,'0: PREVIO
     1US TIME-STEP'/5X,'1: LINEAR PROJECTION FROM PREVIOUS TIME-STEP'/5X
     2,'2: DIRECT PROJECTION')
      READ(*,*) IPROJ
      WRITE(12,672) IPROJ
 672  FORMAT(I5, 8X,'(IPROJ)',9X,'MATRIX-SOLVER SEED'/31X,'0: PREVIOUS T
     1IME-STEP'/31X,'1: LINEAR PROJECTION FROM PREVIOUS TIME-STEP'/31X,'
     22: DIRECT PROJECTION')
C
      ISNAP=0
      WRITE(*,259)
      WRITE(12,259)
 259  FORMAT(/30('*'),' OUTPUT PARAMETERS ',31('*')/)
      WRITE(*,64)
 64   FORMAT('OUTPUT OPTION'/5X,'0: CONCENTRATION VERSUS TIME (breakthro
     1ugh) DATA'/5X,'1: CONCENTRATION VERSUS DISTANCE (snapshot) DATA')
      READ(*,15) IOUT
 15   FORMAT(I2)
      WRITE(12,664) IOUT
 664  FORMAT(I5, 8X,'(IOUT)',10X,'OUTPUT OPTION'/31X,'0: CONCENTRATION V
     1S. TIME (breakthrough)'/31X,'1: CONCENTRATION VS. DISTANCE (snapsh
     2ot)')
      IF(IOUT.EQ.0) THEN
      TSNAP=TEND
      WRITE(*,68)
 68   FORMAT('PRINTOUT INCREMENT FOR BREAKTHROUGH DATA [hrs]')
      READ(*,*) YPR1
      WRITE(12,668) YPR1
      YPR1=YPR1*3600
 668  FORMAT(E10.4,3X,'(YPR1)',10X,'PRINTOUT INCREMENT FOR BREAKTHROUGH
     1DATA [hrs]')
      ELSE
      WRITE(*,61)
 61   FORMAT('DO YOU WISH SNAPSHOT DATA AT SPECIFIC LOCATIONS...(ENTER 0
     1)'/'OR FOR THE ENTIRE MODEL DOMAIN...(ENTER 1)')
      READ(*,15) ISNAP
      WRITE(12,515) ISNAP
 515  FORMAT(I5, 8X,'(ISNAP)',9X,'SNAPSHOT OPTION'/31X,'0: AT SPECIFIC L
     1OCATION'/31X,'1: ENTIRE MODEL DOMAIN')
      WRITE(*,62)
 62   FORMAT('ENTER THE TIME [hrs] FOR SNAPSHOT')
      READ(*,*) TSNAP
      WRITE(12,63) TSNAP
 63   FORMAT(E10.4, 3X,'(TSNAP)',9X,'TIME [hrs] FOR SNAPSHOT')
      TSNAP=TSNAP*3600
      END IF
      IF(IOUT.EQ.0 .OR. ISNAP.EQ.0) THEN
      WRITE(*,65)
 65   FORMAT('NUMBER OF LOCATIONS FOR OUTPUT DATA (MAXIMUM = 3)')
      READ(*,*) NW
      WRITE(12,665) NW
 665  FORMAT(I5, 8X,'(NW)',12X,'# OF LOCATIONS FOR OUTPUT DATA')
      DO 399 IW=1,NW
      WRITE(*,66) IW
      WRITE(12,66) IW
 66   FORMAT(/31('-'),' OUTPUT LOCATION',I2,1X,30('-')/)
      IF(IDIM.GE.2) THEN
      WRITE(*,67)
 67   FORMAT('RADIAL LOCATION [cm]')
      READ(*,*) RVW(IW)
      WRITE(12,667) RVW(IW)
 667  FORMAT(E10.4, 3X,'(RVW(IW))',7X,'RADIAL LOCATION FOR OUTPUT DATA [
     1cm]')
      ELSE
      RVW(IW)=R(2)
      END IF
      CALL NODLOC(1,IRVW(IW),RVW(IW))
      IF(IDIM.NE.2) THEN
      WRITE(*,69)
 69   FORMAT('VERTICAL LOCATION [cm]')
      READ(*,*) ZVW(IW)
      WRITE(12,689) ZVW(IW)
 689  FORMAT(E10.4, 3X,'(ZVW(IW))',7X,'VERTICAL LOCATION FOR OUTPUT DATA
     1 [cm]')
      ELSE
      ZVW(IW)=Z(2)
      END IF
      CALL NODLOC(2,IZVW(IW),ZVW(IW))
      IF(IW.EQ.NW) THEN
      WRITE(*,2)
      END IF
 399  CONTINUE
      END IF
C
C
      DO 417 IK=1,NK
      IF(IK.GT.1) THEN
      WRITE(12,930) IK
      ELSE
      WRITE(12,127) IK
      END IF
      WRITE(*,548) IK
 548  FORMAT('IS OUTPUT DATA DESIRED FOR CONSTITUENT ',I2/'(ENTER 0)...N
     1O, (ENTER 1)...YES')
      READ(*,*) IOUTOPT(IK)
      WRITE(12,558) IOUTOPT(IK)
 558  FORMAT(I5, 8X,'(IOUTOPT(IK))',3X,'OUTPUT OPTION'/31X,'0: NO OUTPUT
     1 DATA REQUESTED'/31X,'1: OUTPUT DATA REQUESTED'/)
      IF(IOUTOPT(IK).GT.0) THEN
      IF(IOUT.EQ.1) THEN
      WRITE(*,519) IK
 519  FORMAT('SPECIFY A NAME FOR THE OUTPUT FILE FOR CONSTITUENT ',I2)
      IF(IK.EQ.1) THEN
      READ(*,255) FNAMEOUT1
      OPEN(UNIT=60,FILE=FNAMEOUT1)
      WRITE(12,517) FNAMEOUT1
      END IF
      IF(IK.EQ.2) THEN
      READ(*,255) FNAMEOUT2
      OPEN(UNIT=61,FILE=FNAMEOUT2)
      WRITE(12,517) FNAMEOUT2
      END IF
      IF(IK.EQ.3) THEN
      READ(*,255) FNAMEOUT3
      OPEN(UNIT=62,FILE=FNAMEOUT3)
      WRITE(12,517) FNAMEOUT3
      END IF
      IF(IK.EQ.4) THEN
      READ(*,255) FNAMEOUT4
      OPEN(UNIT=63,FILE=FNAMEOUT4)
      WRITE(12,517) FNAMEOUT4
      END IF
      IF(IK.EQ.5) THEN
      READ(*,255) FNAMEOUT5
      OPEN(UNIT=64,FILE=FNAMEOUT5)
      WRITE(12,517) FNAMEOUT5
      END IF
      IF(IK.EQ.6) THEN
      READ(*,255) FNAMEOUT6
      OPEN(UNIT=65,FILE=FNAMEOUT6)
      WRITE(12,517) FNAMEOUT6
      END IF
      IF(IK.EQ.7) THEN
      READ(*,255) FNAMEOUT7
      OPEN(UNIT=66,FILE=FNAMEOUT7)
      WRITE(12,517) FNAMEOUT7
      END IF
      IF(IK.EQ.8) THEN
      READ(*,255) FNAMEOUT8
      OPEN(UNIT=67,FILE=FNAMEOUT8)
      WRITE(12,517) FNAMEOUT8
      END IF
      ELSE
      DO 299 IW=1,NW
      WRITE(*,520) IK,IW
 520  FORMAT('SPECIFY A NAME FOR THE OUTPUT FILE FOR CONSTITUENT ',I2,'
     1AND LOCATION ',I2)
      IF(IK.EQ.1) THEN
      IF(IW.EQ.1) THEN
      READ(*,255) FNAMEOUT1
      OPEN(UNIT=60,FILE=FNAMEOUT1)
      WRITE(12,517) FNAMEOUT1
      END IF
      IF(IW.EQ.2) THEN
      READ(*,255) FNAMEOUT9
      OPEN(UNIT=68,FILE=FNAMEOUT9)
      WRITE(12,517) FNAMEOUT9
      END IF
      IF(IW.EQ.3) THEN
      READ(*,255) FNAMEOUT17
      OPEN(UNIT=76,FILE=FNAMEOUT17)
      WRITE(12,517) FNAMEOUT17
      END IF
      END IF
      IF(IK.EQ.2) THEN
      IF(IW.EQ.1) THEN
      READ(*,255) FNAMEOUT2
      OPEN(UNIT=61,FILE=FNAMEOUT2)
      WRITE(12,517) FNAMEOUT2
      END IF
      IF(IW.EQ.2) THEN
      READ(*,255) FNAMEOUT10
      OPEN(UNIT=69,FILE=FNAMEOUT10)
      WRITE(12,517) FNAMEOUT10
      END IF
      IF(IW.EQ.3) THEN
      READ(*,255) FNAMEOUT18
      OPEN(UNIT=77,FILE=FNAMEOUT18)
      WRITE(12,517) FNAMEOUT18
      END IF
      END IF
      IF(IK.EQ.3) THEN
      IF(IW.EQ.1) THEN
      READ(*,255) FNAMEOUT3
      OPEN(UNIT=62,FILE=FNAMEOUT3)
      WRITE(12,517) FNAMEOUT3
      END IF
      IF(IW.EQ.2) THEN
      READ(*,255) FNAMEOUT11
      OPEN(UNIT=70,FILE=FNAMEOUT11)
      WRITE(12,517) FNAMEOUT11
      END IF
      IF(IW.EQ.3) THEN
      READ(*,255) FNAMEOUT19
      OPEN(UNIT=78,FILE=FNAMEOUT19)
      WRITE(12,517) FNAMEOUT19
      END IF
      END IF
      IF(IK.EQ.4) THEN
      IF(IW.EQ.1) THEN
      READ(*,255) FNAMEOUT4
      OPEN(UNIT=63,FILE=FNAMEOUT4)
      WRITE(12,517) FNAMEOUT4
      END IF
      IF(IW.EQ.2) THEN
      READ(*,255) FNAMEOUT12
      OPEN(UNIT=71,FILE=FNAMEOUT12)
      WRITE(12,517) FNAMEOUT12
      END IF
      IF(IW.EQ.3) THEN
      READ(*,255) FNAMEOUT20
      OPEN(UNIT=79,FILE=FNAMEOUT20)
      WRITE(12,517) FNAMEOUT20
      END IF
      END IF
      IF(IK.EQ.5) THEN
      IF(IW.EQ.1) THEN
      READ(*,255) FNAMEOUT5
      OPEN(UNIT=64,FILE=FNAMEOUT5)
      WRITE(12,517) FNAMEOUT5
      END IF
      IF(IW.EQ.2) THEN
      READ(*,255) FNAMEOUT13
      OPEN(UNIT=72,FILE=FNAMEOUT13)
      WRITE(12,517) FNAMEOUT13
      END IF
      IF(IW.EQ.3) THEN
      READ(*,255) FNAMEOUT21
      OPEN(UNIT=80,FILE=FNAMEOUT21)
      WRITE(12,517) FNAMEOUT21
      END IF
      END IF
      IF(IK.EQ.6) THEN
      IF(IW.EQ.1) THEN
      READ(*,255) FNAMEOUT6
      OPEN(UNIT=65,FILE=FNAMEOUT6)
      WRITE(12,517) FNAMEOUT6
      END IF
      IF(IW.EQ.2) THEN
      READ(*,255) FNAMEOUT14
      OPEN(UNIT=73,FILE=FNAMEOUT14)
      WRITE(12,517) FNAMEOUT14
      END IF
      IF(IW.EQ.3) THEN
      READ(*,255) FNAMEOUT22
      OPEN(UNIT=81,FILE=FNAMEOUT22)
      WRITE(12,517) FNAMEOUT22
      END IF
      END IF
      IF(IK.EQ.7) THEN
      IF(IW.EQ.1) THEN
      READ(*,255) FNAMEOUT7
      OPEN(UNIT=66,FILE=FNAMEOUT7)
      WRITE(12,517) FNAMEOUT7
      END IF
      IF(IW.EQ.2) THEN
      READ(*,255) FNAMEOUT15
      OPEN(UNIT=74,FILE=FNAMEOUT15)
      WRITE(12,517) FNAMEOUT15
      END IF
      IF(IW.EQ.3) THEN
      READ(*,255) FNAMEOUT23
      OPEN(UNIT=82,FILE=FNAMEOUT23)
      WRITE(12,517) FNAMEOUT23
      END IF
      END IF
      IF(IK.EQ.8) THEN
      IF(IW.EQ.1) THEN
      READ(*,255) FNAMEOUT8
      OPEN(UNIT=67,FILE=FNAMEOUT8)
      WRITE(12,517) FNAMEOUT8
      END IF
      IF(IW.EQ.2) THEN
      READ(*,255) FNAMEOUT16
      OPEN(UNIT=75,FILE=FNAMEOUT16)
      WRITE(12,517) FNAMEOUT16
      END IF
      IF(IW.EQ.3) THEN
      READ(*,255) FNAMEOUT24
      OPEN(UNIT=83,FILE=FNAMEOUT24)
      WRITE(12,517) FNAMEOUT24
      END IF
      END IF
 299  CONTINUE
      END IF
      ELSE
      WRITE(12,514) IK
      END IF
C
 514  FORMAT(2X,'*** NO OUTPUT DATA SPECIFIED FOR CONSTITUENT ',I1/)
 517  FORMAT(2X,'*** OUTPUT DATA (t,G) [hrs,g/cm3] CONTAINED IN FILE-',A
     120/)
C
      IF(ISTRAT.EQ.0 .AND. IBIO(IK).EQ.0) THEN
      IF(IDIM.EQ.1 .AND. ZLOW.LE.ZWAT) THEN
      WRITE(*,149)
 149  FORMAT('1-D ANALYTICAL SOLUTION REFERENCE CALCULATION OPTION'/5X,'
     10: NO REFERENCE CALCULATIONS DESIRED'/5X,'1: REFERENCE CALCULATION
     2S DESIRED')
      READ(*,*) IREF(IK)
      END IF
      IF(IDIM.EQ.2 .AND. RIM.LT.R(NR)) THEN
      WRITE(*,149)
      READ(*,*)IREF(IK)
      END IF
      ELSE
      IREF(IK)=0
      END IF
      WRITE(12,747) IREF(IK)
 747  FORMAT(I5, 8X,'(IREF(IK))',6X,'REFERENCE CALCULATION OPTION'/31X
     1,'0: NO REFERENCE CALCULATIONS DESIRED OR'/34X,'OPTION NOT AVAILA
     2BLE'/31X,'1: REFERENCE CALCULATIONS DESIRED'/)
      IF(IREF(IK).EQ.0)  WRITE(12,521) IK
      IF(IREF(IK).EQ.1)  WRITE(12,516) IK
 521  FORMAT(2X,'*** NO REFERENCE CALCULATIONS FOR CONSTITUENT ',I1/)
 516  FORMAT(2X,'*** REFERENCE DATA (z,G) [cm,g/cm3] CONTAINED IN FILE-
     1REF.',I1/)
C
      IF(IOPT.GT.1 .AND. IDIM.NE.2) THEN
      WRITE(*,151)
 151  FORMAT('FLUX CALCULATION OPTION'/5X,'0: DO NOT CALCULATE FLUX ACRO
     1SS LOWER BOUNDARY'/5X,'1: CALCULATE FLUX ACROSS LOWER BOUNDARY')
      READ(*,*) IFLX(IK)
      ELSE
      IFLX(IK)=0
      END IF
      WRITE(12,751) IFLX(IK)
 751  FORMAT(I5, 8X,'(IFLX(IK))',6X,'FLUX CALCULATION OPTION'/31X,'0: DO
     1NOT CALCULATE FLUX ACROSS LOWER BOUNDARY OR'/34X,'OPTION NOT AVAIL
     2ABLE'/31X,'1: CALCULATE FLUX ACROSS LOWER BOUNDARY')
C
      IF(IOPT.GT.1 .AND. IFLX(IK).GT.0) THEN
      IF(IK.EQ.1) OPEN(UNIT=50,FILE='FLXDT.1')
      IF(IK.EQ.2) OPEN(UNIT=51,FILE='FLXDT.2')
      IF(IK.EQ.3) OPEN(UNIT=52,FILE='FLXDT.3')
      IF(IK.EQ.4) OPEN(UNIT=53,FILE='FLXDT.4')
      IF(IK.EQ.5) OPEN(UNIT=54,FILE='FLXDT.5')
      IF(IK.EQ.6) OPEN(UNIT=55,FILE='FLXDT.6')
      IF(IK.EQ.7) OPEN(UNIT=56,FILE='FLXDT.7')
      IF(IK.EQ.8) OPEN(UNIT=57,FILE='FLXDT.8')
      END IF
C
      IF(IFLX(IK).EQ.0) WRITE(12,251) IK
      IF(IFLX(IK).EQ.1) WRITE(12,252) IK
 251  FORMAT(/2X,'*** NO FLUX DATA SPECIFIED FOR CONSTITUENT ',I1/)
 252  FORMAT(/2X,'*** FLUX DATA CONTAINED IN FILE-"FLXDT.',I1,'"'/)
C
      IF(IK.EQ.NK) WRITE(12,1)
 417  CONTINUE
C
      IFLXX=0
      IF(IOPT.GT.1) THEN
      DO 39,IK=1,NK
      IF(IFLX(IK).GT.0) IFLXX=1
  39  CONTINUE
      IF(IFLXX.EQ.1) THEN
      WRITE(*,150)
 150  FORMAT('PRINTOUT INCREMENT FOR FLUX DATA [hrs]')
      READ(*,*) YPR2
      WRITE(12,671) YPR2
      YPR2=YPR2*3600
      ELSE
      YPR2=1E20
      END IF
 671  FORMAT(E10.4,3X,'(YPR2)',10X,'PRINTOUT INCREMENT FOR FLUX DATA [hr
     1s]')
      END IF
C
      WRITE(12,763)
 763  FORMAT(/27('*'),' MODEL DOMAIN COORDINATES ',27('*')/)
      WRITE(12,768) R(NR)
 768  FORMAT(E10.4, 3X,'(R(NR))',9X,'r - COORDINATE: OUTER BOUNDARY [cm]
     1')
      IF(IOPT.LE.3) WRITE(12,733) R(IRIM)
 733  FORMAT(E10.4, 3X,'(R(IRIM))',7X,'r - COORDINATE: RADIUS OF SOURCE
     1[cm]')
      IF(R(IRASP).GT.R(1)) WRITE(12,776) R(IRASP)
 776  FORMAT(E10.4, 3X,'(R(IRASP))',6X,'r - COORDINATE: RADIUS OF SURFAC
     1E FEATURE [cm]')
      WRITE(12,780) Z(1)
 780  FORMAT(E10.4, 3X,'(Z(1))',10X,'z - COORDINATE: LOWER BOUNDARY [cm]
     1')
      WRITE(12,784) Z(NZ)
 784  FORMAT(E10.4, 3X,'(Z(NZ))',9X,'z - COORDINATE: SURFACE BOUNDARY [c
     1m]')
      WRITE(12,795) Z(IZLOW)
 795  FORMAT(E10.4, 3X,'(Z(IZLOW))',6X,'z - COORDINATE: LOWER SOURCE BOU
     1NDARY [cm]')
      WRITE(12,797) Z(IZHI)
 797  FORMAT(E10.4, 3X,'(Z(IZHI))',7X,'z - COORDINATE: UPPER SOURCE BOUN
     1DARY [cm]')
      IF(Z(IZBAS).GT.Z(1)) WRITE(12,801) Z(IZBAS)
 801  FORMAT(E10.4, 3X,'(Z(IZBAS))',6X,'z - COORDINATE: OUTER RADIAL BOU
     1NDARY'/34X,'TRANSITION [cm]')
      DO 669 IL=1,NL
      IF(ISTRAT.EQ.2) WRITE(12,880) Z(IZLAY(IL)),IL
 880  FORMAT(E10.4, 3X,'(ZLAY(IL))',6X,'z - COORDINATE: TOP OF LAYER ',I
     12,' [cm]')
 669  CONTINUE
      IF(IOUT.EQ.0 .OR. ISNAP.EQ.0) THEN
      DO 555 IW=1,NW
      WRITE(12,889) R(IRVW(IW)),IW
      WRITE(12,779) Z(IZVW(IW)),IW
 889  FORMAT(E10.4, 3X,'(R(IRVW(IW)))',3X,'r - COORDINATE: OUTPUT LOCATI
     1ON',I2,' [cm]')
 779  FORMAT(E10.4, 3X,'(Z(IZVW(IW)))',3X,'z - COORDINATE: OUTPUT LOCATI
     1ON',I2,' [cm]')
 555  CONTINUE
      END IF
      WRITE(12,1)
C
C
      WRITE(*,302)
 302  FORMAT (/80('*')/20X,'EXECUTING THE NUMERICAL SOLUTION'/80('*')/)
C
C
 206  FORMAT(3E10.4)
 207  FORMAT(I5,5X,E10.4)
 208  FORMAT(10G11.4)
 209  FORMAT(10G10.4)
 210  FORMAT(2E11.4)
 218  FORMAT(10G13.4)
      RETURN
      END
C
C
C
      SUBROUTINE DIFF
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER(NHR=501,NHZ=501,NHL=5,NHK=8,NHW=3,I9=NHK+1,
     1NHRZ=NHR+NHZ+1)
      CHARACTER TITLE*70,FNAMEPOR*38,FNAMETHW*38,M*30,
     1FNAMETA*38,FNAMEBD*38,FNAMEICDAT*38,FNAMEMIF*38,FNAMECAL*38,
     2FNAMEOUT1*38,FNAMEOUT2*38,FNAMEOUT3*38,FNAMEOUT4*38,FNAMEOUT5*38,
     3FNAMEOUT6*38,FNAMEOUT7*38,FNAMEOUT8*38,FNAMEOUT9*38,FNAMEOUT10*38,
     4FNAMEOUT11*38,FNAMEOUT12*38,FNAMEOUT13*38,FNAMEOUT14*38,
     5FNAMEOUT15*38,FNAMEOUT16*38,FNAMEOUT17*38,FNAMEOUT18*38,
     6FNAMEOUT19*38,FNAMEOUT20*38,FNAMEOUT21*38,FNAMEOUT22*38,
     7FNAMEOUT23*38,FNAMEOUT24*38,
     8FNAMEBCDAT*38
      COMMON/DEP0/ Y0,Y1,Y2,Y3,DTY
      COMMON/DEP/  Y,TOT,RBIO
      COMMON/CHAR/ M,FNAMETA,FNAMEBD,FNAMECAL,FNAMEMIF,
     3FNAMEICDAT,FNAMEPOR,FNAMETHW,FNAMEBCDAT,TITLE,
     5FNAMEOUT1,FNAMEOUT2,FNAMEOUT3,FNAMEOUT4,FNAMEOUT5,
     6FNAMEOUT6,FNAMEOUT7,FNAMEOUT8,FNAMEOUT9,FNAMEOUT10,
     7FNAMEOUT11,FNAMEOUT12,FNAMEOUT13,FNAMEOUT14,FNAMEOUT15,FNAMEOUT16,
     8FNAMEOUT17,FNAMEOUT18,FNAMEOUT19,FNAMEOUT20,FNAMEOUT21,FNAMEOUT22,
     9FNAMEOUT23,FNAMEOUT24
      COMMON/XNRNZNK/ BR,BZ,CR,CZ,PP,DKA,SUMDK
      COMMON/XNRNZ/ PT
      COMMON/XNZNK/ FIRF,A
      COMMON/XNRNK/ FIZT,FIZW,FLX
      COMMON/XNKNK/ DKAB
      COMMON/XNR/ R,BC
      COMMON/XNZ/ Z,TA,TW,BD,POR,THA,THW
      COMMON/YTRP/ YTRAP,ZTRAP
      COMMON/XNK/  XIK0,HAW,HSW,RK,TIFIP,TIFB,TIFT,TIRBIO,TIFRF,
     1TMASS,TMASS0,CRY,VK,WK,HWIK,XMASSB,XMASST,ATCONC,IBIO,ICON,
     2TMASSW,DV,DKW,VC,VM,BMLX,FLXDT,IOUTOPT,IREF,IFLX
     3,RCON,RLAMBDA,RMAX,HSAT,GWAT,FTOP,FBOT,FRIM,DFLXDT
      COMMON/XNL/AL,ALT,ZLAY,PORL,TAL,THWL,THAL,BDL
      COMMON/XNW/RVW,ZVW
      COMMON/ARRAY/ XINIT,UINIT,XPT,YPT,SLPZ,SLPR,BZZ,BRR,SXLM
      COMMON/ISC/NR,NZ,NL,NK,NT,IRIM,IRASP,IZLOW,IZHI,IZBAS,IRVW,IZVW,
     1IPROJ,NITER,IRNORM,IZNORM,ITER,ITER0,ISS,IRFP,IW,IL,IK,IKK,I,
     2NW,IZLAY,JK,IDAT,NDAT,ICOUNT,IOX,IIX,ICUT,IDT,IU2,IU3,IU4,KONS
      COMMON/INT/IFIL,IMOD,IMILQ,IOPT,INOPT,IBC0,IOUT,ICOMP,ISURF,
     1NDATIN,NDATCAL,NIPTS,ISNAP,ITIME,ICONX,IWARN,ICNTER,IDIM,
     2ISTRAT,IBDRY,INCHECK,IDISP,IWAT,IFLAG,IN,JN,IRMAX,IHSAT
      COMMON/XSC/DT,DR,DZ,SUM,AR1,AR2,AR3,AR4,AZ1,AZ2,ATOX,RHOIM,CSA,
     1TIME,VIMM,DARCY,THI0,EPS,ENORM,ATM,ZBAS,ZWAT,ZSURF,ZLOW,ZHI,
     2DT1,DT2,DTM,TRANS,TEND,YPR1,YPR2,SKIP,SKIP2,TEMP,RIM,RF,DTHI0
      COMMON/CONS/FLUX,UP,UW,D,DS,GAM,B,C,XL,PI,XFD,BP,DP,WAT,AIR,
     1XMM,DBIN,XM0,XB0,YNM,TMAX,DELT,HENRY,SWPC,BULK,XLL,TSNAP,TOR,
     2XB,ZOUT,GASBOT
      COMMON/RC1/ C6,C7
      COMMON/RC2/C1,C2,C3,C4,C5
C
C
C****DIMENSION THE FOLLOWING (NR,NZ,NHK+1)
C
      DIMENSION Y0(NHR,NHZ,I9),DTY(NHR,NHZ,I9),PP(NHR,NHZ,I9)
     1,BR(NHR,NHZ,I9),BZ(NHR,NHZ,I9),CR(NHR,NHZ,I9),CZ(NHR,NHZ,I9)
     2,C1(NHR,NHZ,I9),C2(NHR,NHZ,I9),C3(NHR,NHZ,I9),C4(NHR,NHZ,I9)
     3,C5(NHR,NHZ,I9),DKA(NHR,NHZ,I9),SUMDK(NHR,NHZ,I9)
     4,Y(NHR,NHZ,I9),Y3(NHR,NHZ,I9)
C
C****DIMENSION THE FOLLOWING (NR,NZ)
      DIMENSION TOT(NHR,NHZ),PT(NHR,NHZ)
      DIMENSION C6(NHR,NHZ),C7(NHR,NHZ),RBIO(NHR,NHZ)
C
C******DIMENSION THE FOLLOWING AS (NZ,NHK+1)
C
      DIMENSION FIRF(NHZ,I9),A(NHZ,I9),Y1(NHZ,I9)
C
C******DIMENSION THE FOLLOWING AS (NR,NHK+1)
C
      DIMENSION FIZT(NHR,I9),FIZW(NHR,I9),FLX(NHR,I9),Y2(NHR,I9)
C
C******DIMENSION THE FOLLOWING AS (I9,I9)
C
      DIMENSION DKAB(I9,I9)
C
C******DIMENSION THE FOLLOWING AS (NR+NZ)
C
      DIMENSION YTRAP(NHRZ),ZTRAP(NHRZ)
C
C******DIMENSION THE FOLLOWING AS (NHZ)
C
      DIMENSION Z(NHZ),POR(NHZ),TA(NHZ),TW(NHZ),THA(NHZ)
     1,THW(NHZ),BD(NHZ)
C
C******DIMENSION THE FOLLOWING AS (NHR)
C
      DIMENSION R(NHR),BC(NHR)
C
C******DIMENSION THE FOLLOWING AS (NL)
C
      DIMENSION AL(NHL),ALT(NHL),ZLAY(NHL),IZLAY(NHL),
     1PORL(NHL),THWL(NHL),THAL(NHL),TAL(NHL),BDL(NHL)
C
C********DIMENSION THE FOLLOWING AS (NW)
C
      DIMENSION RVW(NHW),ZVW(NHW),IRVW(NHW),IZVW(NHW)
C
C********DIMENSION THE FOLLOWING (NHK+1)
C
      DIMENSION TIFIP(I9),TIFB(I9),TIFT(I9),TIRBIO(I9),TIFRF(I9),
     1TMASS0(I9),TMASSW(I9),TMASS(I9),XMASSB(I9),XMASST(I9),CRY(I9)
     2,FTOP(I9),GWAT(I9),FBOT(I9),FRIM(I9),FLXDT(I9),DFLXDT(I9)
C
C*******DIMENSION THE FOLLOWING (NHK+2)
C
      DIMENSION WK(I9),VC(I9),VM(I9),DV(I9),IBIO(I9),ICON(I9)
C
C*******DIMENSION THE FOLLOWING (NK)
C
      DIMENSION XIK0(NHK),BMLX(NHK),HWIK(NHK),HAW(NHK),RK(NHK)
     1,HSW(NHK),VK(NHK),ATCONC(NHK),DKW(NHK),IOUTOPT(NHK)
     2,IREF(NHK),IFLX(NHK),RLAMBDA(NHK),RCON(NHK)
     3,RMAX(NHK),HSAT(NHK)
C
C*******DIMENSION THE FOLLOWING
C
      DIMENSION SXLM(10000),XINIT(1001),UINIT(1001),XPT(1001),YPT(1001),
     1SLPZ(1001),SLPR(1001),BZZ(1001),BRR(1001)
C
C
C  THE PURPOSE OF THIS SUBROUTINE IS TO COMPUTE THE BULK DIFFUSION
C  COEFFICIENT (DKA).
C
      IF(ICOMP.EQ.0) THEN
      NT=NK+1
      ELSE
      NT=NK
      END IF
C
      DO 200 IR=1,NR
      DO 200 IZ=1,NZ
      DO 201 IK=1,NK
      DKA(IR,IZ,IK)=0.0
      SUMDK(IR,IZ,IK)=0.0
      IND=0
      IF(IZ.GE.IZLOW .AND. IZ.LE.IZHI) IND=1
      IF(IND.EQ.1 .AND. IR.LE.IRIM) GO TO 200
      U1=0.0
      DO 203 JK=1,NT
      IF(JK.NE.IK) THEN
      U1=PP(IR,IZ,JK)/DKAB(IK,JK)
      SUMDK(IR,IZ,IK)=SUMDK(IR,IZ,IK)+U1
      END IF
 203  CONTINUE
      DKA(IR,IZ,IK)=((ATM/760)-PP(IR,IZ,IK))/SUMDK(IR,IZ,IK)
      IF(DKA(IR,IZ,IK).GT.1) DKA(IR,IZ,IK)=1.0
 201  CONTINUE
 200  CONTINUE
C
C  ASSIGN DIFFUSIVITIES TO SOURCE BOUNDARY NODES
C
      DO 300 IK=1,NK
      DO 300 IR=1,NR
      DO 300 IZ=1,NZ
      IF(IZLOW.GT.2) THEN
      DKA(IR,IZLOW,IK)=DKA(IR,IZLOW-1,IK)
      END IF
      IF(IZHI.LT.NZ-1) THEN
      DKA(IR,IZHI,IK)=DKA(IR,IZHI+1,IK)
      END IF
      IF(IRIM.LT.NR-1) THEN
      DKA(IRIM,IZ,IK)=DKA(IRIM+1,IZ,IK)
      END IF
 300  CONTINUE
C
C
      RETURN
      END
C
C
      SUBROUTINE COEF1
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER(NHR=501,NHZ=501,NHL=5,NHK=8,NHW=3,I9=NHK+1,
     1NHRZ=NHR+NHZ+1)
      CHARACTER TITLE*70,FNAMEPOR*38,FNAMETHW*38,M*30,
     1FNAMETA*38,FNAMEBD*38,FNAMEICDAT*38,FNAMEMIF*38,FNAMECAL*38,
     2FNAMEOUT1*38,FNAMEOUT2*38,FNAMEOUT3*38,FNAMEOUT4*38,FNAMEOUT5*38,
     3FNAMEOUT6*38,FNAMEOUT7*38,FNAMEOUT8*38,FNAMEOUT9*38,FNAMEOUT10*38,
     4FNAMEOUT11*38,FNAMEOUT12*38,FNAMEOUT13*38,FNAMEOUT14*38,
     5FNAMEOUT15*38,FNAMEOUT16*38,FNAMEOUT17*38,FNAMEOUT18*38,
     6FNAMEOUT19*38,FNAMEOUT20*38,FNAMEOUT21*38,FNAMEOUT22*38,
     7FNAMEOUT23*38,FNAMEOUT24*38,
     8FNAMEBCDAT*38
      COMMON/DEP0/ Y0,Y1,Y2,Y3,DTY
      COMMON/DEP/  Y,TOT,RBIO
      COMMON/CHAR/ M,FNAMETA,FNAMEBD,FNAMECAL,FNAMEMIF,
     3FNAMEICDAT,FNAMEPOR,FNAMETHW,FNAMEBCDAT,TITLE,
     5FNAMEOUT1,FNAMEOUT2,FNAMEOUT3,FNAMEOUT4,FNAMEOUT5,
     6FNAMEOUT6,FNAMEOUT7,FNAMEOUT8,FNAMEOUT9,FNAMEOUT10,
     7FNAMEOUT11,FNAMEOUT12,FNAMEOUT13,FNAMEOUT14,FNAMEOUT15,FNAMEOUT16,
     8FNAMEOUT17,FNAMEOUT18,FNAMEOUT19,FNAMEOUT20,FNAMEOUT21,FNAMEOUT22,
     9FNAMEOUT23,FNAMEOUT24
      COMMON/XNRNZNK/ BR,BZ,CR,CZ,PP,DKA,SUMDK
      COMMON/XNRNZ/ PT
      COMMON/XNZNK/ FIRF,A
      COMMON/XNRNK/ FIZT,FIZW,FLX
      COMMON/XNKNK/ DKAB
      COMMON/XNR/ R,BC
      COMMON/XNZ/ Z,TA,TW,BD,POR,THA,THW
      COMMON/YTRP/ YTRAP,ZTRAP
      COMMON/XNK/  XIK0,HAW,HSW,RK,TIFIP,TIFB,TIFT,TIRBIO,TIFRF,
     1TMASS,TMASS0,CRY,VK,WK,HWIK,XMASSB,XMASST,ATCONC,IBIO,ICON,
     2TMASSW,DV,DKW,VC,VM,BMLX,FLXDT,IOUTOPT,IREF,IFLX
     3,RCON,RLAMBDA,RMAX,HSAT,GWAT,FTOP,FBOT,FRIM,DFLXDT
      COMMON/XNL/AL,ALT,ZLAY,PORL,TAL,THWL,THAL,BDL
      COMMON/XNW/RVW,ZVW
      COMMON/ARRAY/ XINIT,UINIT,XPT,YPT,SLPZ,SLPR,BZZ,BRR,SXLM
      COMMON/ISC/NR,NZ,NL,NK,NT,IRIM,IRASP,IZLOW,IZHI,IZBAS,IRVW,IZVW,
     1IPROJ,NITER,IRNORM,IZNORM,ITER,ITER0,ISS,IRFP,IW,IL,IK,IKK,I,
     2NW,IZLAY,JK,IDAT,NDAT,ICOUNT,IOX,IIX,ICUT,IDT,IU2,IU3,IU4,KONS
      COMMON/INT/IFIL,IMOD,IMILQ,IOPT,INOPT,IBC0,IOUT,ICOMP,ISURF,
     1NDATIN,NDATCAL,NIPTS,ISNAP,ITIME,ICONX,IWARN,ICNTER,IDIM,
     2ISTRAT,IBDRY,INCHECK,IDISP,IWAT,IFLAG,IN,JN,IRMAX,IHSAT
      COMMON/XSC/DT,DR,DZ,SUM,AR1,AR2,AR3,AR4,AZ1,AZ2,ATOX,RHOIM,CSA,
     1TIME,VIMM,DARCY,THI0,EPS,ENORM,ATM,ZBAS,ZWAT,ZSURF,ZLOW,ZHI,
     2DT1,DT2,DTM,TRANS,TEND,YPR1,YPR2,SKIP,SKIP2,TEMP,RIM,RF,DTHI0
      COMMON/CONS/FLUX,UP,UW,D,DS,GAM,B,C,XL,PI,XFD,BP,DP,WAT,AIR,
     1XMM,DBIN,XM0,XB0,YNM,TMAX,DELT,HENRY,SWPC,BULK,XLL,TSNAP,TOR,
     2XB,ZOUT,GASBOT
      COMMON/RC1/ C6,C7
      COMMON/RC2/C1,C2,C3,C4,C5
C
C
C
C****DIMENSION THE FOLLOWING (NR,NZ,NHK+1)
C
      DIMENSION Y0(NHR,NHZ,I9),DTY(NHR,NHZ,I9),PP(NHR,NHZ,I9)
     1,BR(NHR,NHZ,I9),BZ(NHR,NHZ,I9),CR(NHR,NHZ,I9),CZ(NHR,NHZ,I9)
     2,C1(NHR,NHZ,I9),C2(NHR,NHZ,I9),C3(NHR,NHZ,I9),C4(NHR,NHZ,I9)
     3,C5(NHR,NHZ,I9),DKA(NHR,NHZ,I9),SUMDK(NHR,NHZ,I9)
     4,Y(NHR,NHZ,I9),Y3(NHR,NHZ,I9)
C
C****DIMENSION THE FOLLOWING (NR,NZ)
      DIMENSION TOT(NHR,NHZ),PT(NHR,NHZ)
      DIMENSION C6(NHR,NHZ),C7(NHR,NHZ),RBIO(NHR,NHZ)
C
C******DIMENSION THE FOLLOWING AS (NZ,NHK+1)
C
      DIMENSION FIRF(NHZ,I9),A(NHZ,I9),Y1(NHZ,I9)
C
C******DIMENSION THE FOLLOWING AS (NR,NHK+1)
C
      DIMENSION FIZT(NHR,I9),FIZW(NHR,I9),FLX(NHR,I9),Y2(NHR,I9)
C
C******DIMENSION THE FOLLOWING AS (I9,I9)
C
      DIMENSION DKAB(I9,I9)
C
C******DIMENSION THE FOLLOWING AS (NR+NZ)
C
      DIMENSION YTRAP(NHRZ),ZTRAP(NHRZ)
C
C******DIMENSION THE FOLLOWING AS (NHZ)
C
      DIMENSION Z(NHZ),POR(NHZ),TA(NHZ),TW(NHZ),THA(NHZ)
     1,THW(NHZ),BD(NHZ)
C
C******DIMENSION THE FOLLOWING AS (NHR)
C
      DIMENSION R(NHR),BC(NHR)
C
C******DIMENSION THE FOLLOWING AS (NL)
C
      DIMENSION AL(NHL),ALT(NHL),ZLAY(NHL),IZLAY(NHL),
     1PORL(NHL),THWL(NHL),THAL(NHL),TAL(NHL),BDL(NHL)
C
C********DIMENSION THE FOLLOWING AS (NW)
C
      DIMENSION RVW(NHW),ZVW(NHW),IRVW(NHW),IZVW(NHW)
C
C********DIMENSION THE FOLLOWING (NHK+1)
C
      DIMENSION TIFIP(I9),TIFB(I9),TIFT(I9),TIRBIO(I9),TIFRF(I9),
     1TMASS0(I9),TMASSW(I9),TMASS(I9),XMASSB(I9),XMASST(I9),CRY(I9)
     2,FTOP(I9),GWAT(I9),FBOT(I9),FRIM(I9),FLXDT(I9),DFLXDT(I9)
C
C*******DIMENSION THE FOLLOWING (NHK+2)
C
      DIMENSION WK(I9),VC(I9),VM(I9),DV(I9),IBIO(I9),ICON(I9)
C
C*******DIMENSION THE FOLLOWING (NK)
C
      DIMENSION XIK0(NHK),BMLX(NHK),HWIK(NHK),HAW(NHK),RK(NHK)
     1,HSW(NHK),VK(NHK),ATCONC(NHK),DKW(NHK),IOUTOPT(NHK)
     2,IREF(NHK),IFLX(NHK),RLAMBDA(NHK),RCON(NHK)
     3,RMAX(NHK),HSAT(NHK)
C
C*******DIMENSION THE FOLLOWING
C
      DIMENSION SXLM(10000),XINIT(1001),UINIT(1001),XPT(1001),YPT(1001),
     1SLPZ(1001),SLPR(1001),BZZ(1001),BRR(1001)
C
C
      IF(I.GT.1) GO TO 99
      H1=HAW(IK)
      H2=HSW(IK)
      D1=DKW(IK)
C
      U1=DR*DR
      U2=2.0*DR
      U3=DZ*DZ
      U4=2.0*DZ
C
C
      IL=1
      DO 6 IZ=2,NZ-1
      IF(Z(IZ).GE.Z(IZLAY(IL))) IL=IL+1
      IF(IL.GT.NL) IL=NL
      A(IZ,IK)=((THW(IZ)/H1)+THA(IZ)+H2*BD(IZ)/H1)
      IF(ISS.EQ.1) A(IZ,IK)=1.0E-20
C
      U5=THA(IZ+1)-THA(IZ-1)
      U6=TA(IZ+1)-TA(IZ-1)
      U7=THW(IZ+1)-THW(IZ-1)
      U8=TW(IZ+1)-TW(IZ-1)
      U10=((1.0/THW(IZ+1))-(1.0/THW(IZ-1)))/U4
      U11=((D1*U7*TW(IZ))+(D1*THW(IZ)*U8))/U4
C
C
      DO 6 IR=2,NR-1
c     IF(IOPT.EQ.5) GO TO 11
C
      IND=0
      IF(IFLAG.GE.3 .AND. IDIM.EQ.1) IND=1
      IF(IND.EQ.1 .AND. ZHI.GE.ZSURF) IND=2
      IF(IND.EQ.2 .AND. IK.EQ.NK) GO TO 11
C
      IND=0
 	IF(IOPT.LE.2 .AND. IFLAG.GE.3) IND=1
      IF(IND.EQ.1 .AND. IZ.GE.IZHI) IND=2
	IF(IND.EQ.2 .AND. IK.EQ.NK) GO TO 11
C
	IND=0
	IF(IZ.LE.IZHI.AND.IZ.GE.IZLOW) IND=1
      IF(IND.EQ.1 .AND. IR.LE.IRIM) GO TO 6
C
 11   D2=DKA(IR,IZ,IK)
      U16=((D2*U5*TA(IZ))+(D2*THA(IZ)*U6))/U4
C
      U31=-D2*THA(IZ)*TA(IZ)
      U32=-D1*THW(IZ)*TW(IZ)/H1
      U33=-ABS(DARCY/THW(IZ))
      U34=U33*ALT(IL)/H1
      U35=U33*AL(IL)/H1
      BR(IR,IZ,IK)=U31+U32+U34
      BZ(IR,IZ,IK)=U31+U32+U35
      CZ(IR,IZ,IK)=(DARCY/H1)-(U16)-(U11/H1)
     1-(U10*AL(IL)*ABS(DARCY)/H1)
      CR(IR,IZ,IK)=(BR(IR,IZ,IK)/R(IR))
C
      U18=BZ(IR,IZ,IK)/U3
      U19=CZ(IR,IZ,IK)/U4
      U20=BR(IR,IZ,IK)/U1
      U21=CR(IR,IZ,IK)/U2
C
C  ALPHA (THE CRANK-NICOLSON TIME DERIVATIVE) = 0.5
C
      C1(IR,IZ,IK)=(0.5)*(U20+U21)
      C2(IR,IZ,IK)=(0.5)*(U20-U21)
      C3(IR,IZ,IK)=(0.5)*(U18+U19)
      C4(IR,IZ,IK)=(0.5)*(U18-U19)
      C5(IR,IZ,IK)=A(IZ,IK)/DT+(0.5*(-2.0*(BR(IR,IZ,IK)/U1
     1+BZ(IR,IZ,IK)/U3)))
    6 CONTINUE
   99 CONTINUE
C
C
C
C    EVALUATE RHS C6(IR,IZ)
C
 238  FORMAT(2I5,3E13.4)     
      U1=DR*DR
      U2=2.0*DR
      U3=DZ*DZ
      U4=2.0*DZ
      DO 20 IZ=2,NZ-1
      DO 20 IR=2,NR-1
      IND=0
c     IF(IOPT.EQ.5) GO TO 13
C
      IND=0
      IF(IFLAG.GE.3 .AND. IDIM.EQ.1) IND=1
      IF(IND.EQ.1 .AND. ZHI.GE.ZSURF) IND=2
      IF(IND.EQ.2 .AND. IK.EQ.NK) GO TO 13
C
      IND=0
 	IF(IOPT.LE.2 .AND. IFLAG.GE.3) IND=1
      IF(IND.EQ.1 .AND. IZ.GT.IZHI) IND=2
	IF(IND.EQ.2 .AND. IK.EQ.NK) GO TO 13
C
	IND=0
	IF(IZ.LE.IZHI .AND. IZ.GE.IZLOW) IND=1
      IF(IND.EQ.1 .AND. IR.LE.IRIM) GO TO 2020
C 
 13   U45=Y0(IR+1,IZ,IK)-2.0*Y0(IR,IZ,IK)+Y0(IR-1,IZ,IK)
      U46=Y0(IR,IZ+1,IK)-2.0*Y0(IR,IZ,IK)+Y0(IR,IZ-1,IK)
      U47=Y0(IR+1,IZ,IK)-Y0(IR-1,IZ,IK)
      U48=Y0(IR,IZ+1,IK)-Y0(IR,IZ-1,IK)
      U49=Y0(IR,IZ,IK)
C
      C6(IR,IZ)=(A(IZ,IK)/DT)*U49-(0.5*(BR(IR,IZ,IK)*U45/U1+
     1BZ(IR,IZ,IK)*U46/U3+CR(IR,IZ,IK)*U47/U2+CZ(IR,IZ,IK)*U48/U4))
C
C********* C7 IS FOR FULLY EXPLICIT PROJECTION
C
      IF(IPROJ.EQ.2) THEN
      C7(IR,IZ)=(A(IZ,IK)/DT)*U49-(1.0*(BR(IR,IZ,IK)*U45/U1+
     1BZ(IR,IZ,IK)*U46/U3+CR(IR,IZ,IK)*U47/U2+CZ(IR,IZ,IK)*U48/U4))
      ELSE
      C7(IR,IZ)=0.0
      END IF
C
	IF(IFLAG.GE.2) THEN
      IN=IR
      JN=IZ
      IF(I.EQ.1) Y3(IR,IZ,IK)=0.0
      RBIO(IR,IZ)=0.0
      IF(IBIO(IK).GE.1 .AND. IBIO(IK).LE.5) CALL BIO1(IN,JN)
      IF(IBIO(IK).EQ.6) CALL BIO2(IN,JN)
      Y3(IR,IZ,IK)=RBIO(IR,IZ)
      C6(IR,IZ)=C6(IR,IZ)-RBIO(IR,IZ)
      IF(IPROJ.EQ.2) C7(IR,IZ)=(DT/A(IZ,IK))*(C7(IR,IZ)-RBIO(IR,IZ))
      END IF
      GO TO 20
 2020 C6(IR,IZ)=0.0
      C7(IR,IZ)=0.0
   20 CONTINUE
      RETURN
      END
C
C
C
      SUBROUTINE PROJ
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER(NHR=501,NHZ=501,NHL=5,NHK=8,NHW=3,I9=NHK+1,
     1NHRZ=NHR+NHZ+1)
      CHARACTER TITLE*70,FNAMEPOR*38,FNAMETHW*38,M*30,
     1FNAMETA*38,FNAMEBD*38,FNAMEICDAT*38,FNAMEMIF*38,FNAMECAL*38,
     2FNAMEOUT1*38,FNAMEOUT2*38,FNAMEOUT3*38,FNAMEOUT4*38,FNAMEOUT5*38,
     3FNAMEOUT6*38,FNAMEOUT7*38,FNAMEOUT8*38,FNAMEOUT9*38,FNAMEOUT10*38,
     4FNAMEOUT11*38,FNAMEOUT12*38,FNAMEOUT13*38,FNAMEOUT14*38,
     5FNAMEOUT15*38,FNAMEOUT16*38,FNAMEOUT17*38,FNAMEOUT18*38,
     6FNAMEOUT19*38,FNAMEOUT20*38,FNAMEOUT21*38,FNAMEOUT22*38,
     7FNAMEOUT23*38,FNAMEOUT24*38,
     8FNAMEBCDAT*38
      COMMON/DEP0/ Y0,Y1,Y2,Y3,DTY
      COMMON/DEP/  Y,TOT,RBIO
      COMMON/CHAR/ M,FNAMETA,FNAMEBD,FNAMECAL,FNAMEMIF,
     3FNAMEICDAT,FNAMEPOR,FNAMETHW,FNAMEBCDAT,TITLE,
     5FNAMEOUT1,FNAMEOUT2,FNAMEOUT3,FNAMEOUT4,FNAMEOUT5,
     6FNAMEOUT6,FNAMEOUT7,FNAMEOUT8,FNAMEOUT9,FNAMEOUT10,
     7FNAMEOUT11,FNAMEOUT12,FNAMEOUT13,FNAMEOUT14,FNAMEOUT15,FNAMEOUT16,
     8FNAMEOUT17,FNAMEOUT18,FNAMEOUT19,FNAMEOUT20,FNAMEOUT21,FNAMEOUT22,
     9FNAMEOUT23,FNAMEOUT24
      COMMON/XNRNZNK/ BR,BZ,CR,CZ,PP,DKA,SUMDK
      COMMON/XNRNZ/ PT
      COMMON/XNZNK/ FIRF,A
      COMMON/XNRNK/ FIZT,FIZW,FLX
      COMMON/XNKNK/ DKAB
      COMMON/XNR/ R,BC
      COMMON/XNZ/ Z,TA,TW,BD,POR,THA,THW
      COMMON/YTRP/ YTRAP,ZTRAP
      COMMON/XNK/  XIK0,HAW,HSW,RK,TIFIP,TIFB,TIFT,TIRBIO,TIFRF,
     1TMASS,TMASS0,CRY,VK,WK,HWIK,XMASSB,XMASST,ATCONC,IBIO,ICON,
     2TMASSW,DV,DKW,VC,VM,BMLX,FLXDT,IOUTOPT,IREF,IFLX
     3,RCON,RLAMBDA,RMAX,HSAT,GWAT,FTOP,FBOT,FRIM,DFLXDT
      COMMON/XNL/AL,ALT,ZLAY,PORL,TAL,THWL,THAL,BDL
      COMMON/XNW/RVW,ZVW
      COMMON/ARRAY/ XINIT,UINIT,XPT,YPT,SLPZ,SLPR,BZZ,BRR,SXLM
      COMMON/ISC/NR,NZ,NL,NK,NT,IRIM,IRASP,IZLOW,IZHI,IZBAS,IRVW,IZVW,
     1IPROJ,NITER,IRNORM,IZNORM,ITER,ITER0,ISS,IRFP,IW,IL,IK,IKK,I,
     2NW,IZLAY,JK,IDAT,NDAT,ICOUNT,IOX,IIX,ICUT,IDT,IU2,IU3,IU4,KONS
      COMMON/INT/IFIL,IMOD,IMILQ,IOPT,INOPT,IBC0,IOUT,ICOMP,ISURF,
     1NDATIN,NDATCAL,NIPTS,ISNAP,ITIME,ICONX,IWARN,ICNTER,IDIM,
     2ISTRAT,IBDRY,INCHECK,IDISP,IWAT,IFLAG,IN,JN,IRMAX,IHSAT
      COMMON/XSC/DT,DR,DZ,SUM,AR1,AR2,AR3,AR4,AZ1,AZ2,ATOX,RHOIM,CSA,
     1TIME,VIMM,DARCY,THI0,EPS,ENORM,ATM,ZBAS,ZWAT,ZSURF,ZLOW,ZHI,
     2DT1,DT2,DTM,TRANS,TEND,YPR1,YPR2,SKIP,SKIP2,TEMP,RIM,RF,DTHI0
      COMMON/CONS/FLUX,UP,UW,D,DS,GAM,B,C,XL,PI,XFD,BP,DP,WAT,AIR,
     1XMM,DBIN,XM0,XB0,YNM,TMAX,DELT,HENRY,SWPC,BULK,XLL,TSNAP,TOR,
     2XB,ZOUT,GASBOT
      COMMON/RC1/ C6,C7
      COMMON/RC2/C1,C2,C3,C4,C5
C
C
C
C****DIMENSION THE FOLLOWING (NR,NZ,NHK+1)
C
      DIMENSION Y0(NHR,NHZ,I9),DTY(NHR,NHZ,I9),PP(NHR,NHZ,I9)
     1,BR(NHR,NHZ,I9),BZ(NHR,NHZ,I9),CR(NHR,NHZ,I9),CZ(NHR,NHZ,I9)
     2,C1(NHR,NHZ,I9),C2(NHR,NHZ,I9),C3(NHR,NHZ,I9),C4(NHR,NHZ,I9)
     3,C5(NHR,NHZ,I9),DKA(NHR,NHZ,I9),SUMDK(NHR,NHZ,I9)
     4,Y(NHR,NHZ,I9),Y3(NHR,NHZ,I9)
C
C****DIMENSION THE FOLLOWING (NR,NZ)
      DIMENSION TOT(NHR,NHZ),PT(NHR,NHZ)
      DIMENSION C6(NHR,NHZ),C7(NHR,NHZ),RBIO(NHR,NHZ)
C
C******DIMENSION THE FOLLOWING AS (NZ,NHK+1)
C
      DIMENSION FIRF(NHZ,I9),A(NHZ,I9),Y1(NHZ,I9)
C
C******DIMENSION THE FOLLOWING AS (NR,NHK+1)
C
      DIMENSION FIZT(NHR,I9),FIZW(NHR,I9),FLX(NHR,I9),Y2(NHR,I9)
C
C******DIMENSION THE FOLLOWING AS (I9,I9)
C
      DIMENSION DKAB(I9,I9)
C
C******DIMENSION THE FOLLOWING AS (NR+NZ)
C
      DIMENSION YTRAP(NHRZ),ZTRAP(NHRZ)
C
C******DIMENSION THE FOLLOWING AS (NHZ)
C
      DIMENSION Z(NHZ),POR(NHZ),TA(NHZ),TW(NHZ),THA(NHZ)
     1,THW(NHZ),BD(NHZ)
C
C******DIMENSION THE FOLLOWING AS (NHR)
C
      DIMENSION R(NHR),BC(NHR)
C
C******DIMENSION THE FOLLOWING AS (NL)
C
      DIMENSION AL(NHL),ALT(NHL),ZLAY(NHL),IZLAY(NHL),
     1PORL(NHL),THWL(NHL),THAL(NHL),TAL(NHL),BDL(NHL)
C
C********DIMENSION THE FOLLOWING AS (NW)
C
      DIMENSION RVW(NHW),ZVW(NHW),IRVW(NHW),IZVW(NHW)
C
C********DIMENSION THE FOLLOWING (NHK+1)
C
      DIMENSION TIFIP(I9),TIFB(I9),TIFT(I9),TIRBIO(I9),TIFRF(I9),
     1TMASS0(I9),TMASSW(I9),TMASS(I9),XMASSB(I9),XMASST(I9),CRY(I9)
     2,FTOP(I9),GWAT(I9),FBOT(I9),FRIM(I9),FLXDT(I9),DFLXDT(I9)
C
C*******DIMENSION THE FOLLOWING (NHK+2)
C
      DIMENSION WK(I9),VC(I9),VM(I9),DV(I9),IBIO(I9),ICON(I9)
C
C*******DIMENSION THE FOLLOWING (NK)
C
      DIMENSION XIK0(NHK),BMLX(NHK),HWIK(NHK),HAW(NHK),RK(NHK)
     1,HSW(NHK),VK(NHK),ATCONC(NHK),DKW(NHK),IOUTOPT(NHK)
     2,IREF(NHK),IFLX(NHK),RLAMBDA(NHK),RCON(NHK)
     3,RMAX(NHK),HSAT(NHK)
C
C*******DIMENSION THE FOLLOWING
C
      DIMENSION SXLM(10000),XINIT(1001),UINIT(1001),XPT(1001),YPT(1001),
     1SLPZ(1001),SLPR(1001),BZZ(1001),BRR(1001)
C
C
      IF(IPROJ.EQ.0) GO TO 40
      IF(IPROJ.EQ.1) GO TO 41
      IF(IPROJ.EQ.2) GO TO 42
C
C
C
   40 CONTINUE
C
C    SIMPLY PREVIOUS TIME STEP
C
      DO 10 IZ=1,NZ
      DO 10 IR=1,NR
      Y(IR,IZ,IK)=Y0(IR,IZ,IK)
   10 CONTINUE
      GO TO 50
   41 CONTINUE
C
C    TAYLOR FIRST ORDER
C
      DO 11 IZ=1,NZ
      DO 11 IR=1,NR
      Y(IR,IZ,IK)=Y0(IR,IZ,IK)+DTY(IR,IZ,IK)*DT
      IF(I.EQ.1) Y(IR,IZ,IK)=Y0(IR,IZ,IK)
   11 CONTINUE
      GO TO 50
   42 CONTINUE
C
C    FULLY EXPLICIT ALGORITHM
C
      DO 12 IZ=1,NZ
      DO 12 IR=1,NR
      Y(IR,IZ,IK)=C7(IR,IZ)
      IF(IZ.EQ.1.OR.IZ.EQ.NZ) Y(IR,IZ,IK)=Y0(IR,IZ,IK)
      IF(IR.EQ.1.OR.IR.EQ.NR) Y(IR,IZ,IK)=Y0(IR,IZ,IK)
      IF(I.EQ.1) Y(IR,IZ,IK)=Y0(IR,IZ,IK)
   12 CONTINUE
      DO 13 IZ=IZLOW,IZHI
      Y(IRIM,IZ,IK)=Y0(IRIM,IZ,IK)
   13 CONTINUE
      DO 14 IR=1,IRIM
      Y(IR,IZLOW,IK)=Y0(IR,IZLOW,IK)
      Y(IR,IZHI,IK)=Y0(IR,IZHI,IK)
   14 CONTINUE
   50 RETURN
      END
C
C
      SUBROUTINE GAUSDL
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER(NHR=501,NHZ=501,NHL=5,NHK=8,NHW=3,I9=NHK+1,
     1NHRZ=NHR+NHZ+1)
      CHARACTER TITLE*70,FNAMEPOR*38,FNAMETHW*38,M*30,
     1FNAMETA*38,FNAMEBD*38,FNAMEICDAT*38,FNAMEMIF*38,FNAMECAL*38,
     2FNAMEOUT1*38,FNAMEOUT2*38,FNAMEOUT3*38,FNAMEOUT4*38,FNAMEOUT5*38,
     3FNAMEOUT6*38,FNAMEOUT7*38,FNAMEOUT8*38,FNAMEOUT9*38,FNAMEOUT10*38,
     4FNAMEOUT11*38,FNAMEOUT12*38,FNAMEOUT13*38,FNAMEOUT14*38,
     5FNAMEOUT15*38,FNAMEOUT16*38,FNAMEOUT17*38,FNAMEOUT18*38,
     6FNAMEOUT19*38,FNAMEOUT20*38,FNAMEOUT21*38,FNAMEOUT22*38,
     7FNAMEOUT23*38,FNAMEOUT24*38,
     8FNAMEBCDAT*38
      COMMON/DEP0/ Y0,Y1,Y2,Y3,DTY
      COMMON/DEP/  Y,TOT,RBIO
      COMMON/CHAR/ M,FNAMETA,FNAMEBD,FNAMECAL,FNAMEMIF,
     3FNAMEICDAT,FNAMEPOR,FNAMETHW,FNAMEBCDAT,TITLE,
     5FNAMEOUT1,FNAMEOUT2,FNAMEOUT3,FNAMEOUT4,FNAMEOUT5,
     6FNAMEOUT6,FNAMEOUT7,FNAMEOUT8,FNAMEOUT9,FNAMEOUT10,
     7FNAMEOUT11,FNAMEOUT12,FNAMEOUT13,FNAMEOUT14,FNAMEOUT15,FNAMEOUT16,
     8FNAMEOUT17,FNAMEOUT18,FNAMEOUT19,FNAMEOUT20,FNAMEOUT21,FNAMEOUT22,
     9FNAMEOUT23,FNAMEOUT24
      COMMON/XNRNZNK/ BR,BZ,CR,CZ,PP,DKA,SUMDK
      COMMON/XNRNZ/ PT
      COMMON/XNZNK/ FIRF,A
      COMMON/XNRNK/ FIZT,FIZW,FLX
      COMMON/XNKNK/ DKAB
      COMMON/XNR/ R,BC
      COMMON/XNZ/ Z,TA,TW,BD,POR,THA,THW
      COMMON/YTRP/ YTRAP,ZTRAP
      COMMON/XNK/  XIK0,HAW,HSW,RK,TIFIP,TIFB,TIFT,TIRBIO,TIFRF,
     1TMASS,TMASS0,CRY,VK,WK,HWIK,XMASSB,XMASST,ATCONC,IBIO,ICON,
     2TMASSW,DV,DKW,VC,VM,BMLX,FLXDT,IOUTOPT,IREF,IFLX
     3,RCON,RLAMBDA,RMAX,HSAT,GWAT,FTOP,FBOT,FRIM,DFLXDT
      COMMON/XNL/AL,ALT,ZLAY,PORL,TAL,THWL,THAL,BDL
      COMMON/XNW/RVW,ZVW
      COMMON/ARRAY/ XINIT,UINIT,XPT,YPT,SLPZ,SLPR,BZZ,BRR,SXLM
      COMMON/ISC/NR,NZ,NL,NK,NT,IRIM,IRASP,IZLOW,IZHI,IZBAS,IRVW,IZVW,
     1IPROJ,NITER,IRNORM,IZNORM,ITER,ITER0,ISS,IRFP,IW,IL,IK,IKK,I,
     2NW,IZLAY,JK,IDAT,NDAT,ICOUNT,IOX,IIX,ICUT,IDT,IU2,IU3,IU4,KONS
      COMMON/INT/IFIL,IMOD,IMILQ,IOPT,INOPT,IBC0,IOUT,ICOMP,ISURF,
     1NDATIN,NDATCAL,NIPTS,ISNAP,ITIME,ICONX,IWARN,ICNTER,IDIM,
     2ISTRAT,IBDRY,INCHECK,IDISP,IWAT,IFLAG,IN,JN,IRMAX,IHSAT
      COMMON/XSC/DT,DR,DZ,SUM,AR1,AR2,AR3,AR4,AZ1,AZ2,ATOX,RHOIM,CSA,
     1TIME,VIMM,DARCY,THI0,EPS,ENORM,ATM,ZBAS,ZWAT,ZSURF,ZLOW,ZHI,
     2DT1,DT2,DTM,TRANS,TEND,YPR1,YPR2,SKIP,SKIP2,TEMP,RIM,RF,DTHI0
      COMMON/CONS/FLUX,UP,UW,D,DS,GAM,B,C,XL,PI,XFD,BP,DP,WAT,AIR,
     1XMM,DBIN,XM0,XB0,YNM,TMAX,DELT,HENRY,SWPC,BULK,XLL,TSNAP,TOR,
     2XB,ZOUT,GASBOT
      COMMON/RC1/ C6,C7
      COMMON/RC2/C1,C2,C3,C4,C5
C
C
C
C****DIMENSION THE FOLLOWING (NR,NZ,NHK+1)
C
      DIMENSION Y0(NHR,NHZ,I9),DTY(NHR,NHZ,I9),PP(NHR,NHZ,I9)
     1,BR(NHR,NHZ,I9),BZ(NHR,NHZ,I9),CR(NHR,NHZ,I9),CZ(NHR,NHZ,I9)
     2,C1(NHR,NHZ,I9),C2(NHR,NHZ,I9),C3(NHR,NHZ,I9),C4(NHR,NHZ,I9)
     3,C5(NHR,NHZ,I9),DKA(NHR,NHZ,I9),SUMDK(NHR,NHZ,I9)
     4,Y(NHR,NHZ,I9),Y3(NHR,NHZ,I9)
C
C****DIMENSION THE FOLLOWING (NR,NZ)
      DIMENSION TOT(NHR,NHZ),PT(NHR,NHZ)
      DIMENSION C6(NHR,NHZ),C7(NHR,NHZ),RBIO(NHR,NHZ)
C
C******DIMENSION THE FOLLOWING AS (NZ,NHK+1)
C
      DIMENSION FIRF(NHZ,I9),A(NHZ,I9),Y1(NHZ,I9)
C
C******DIMENSION THE FOLLOWING AS (NR,NHK+1)
C
      DIMENSION FIZT(NHR,I9),FIZW(NHR,I9),FLX(NHR,I9),Y2(NHR,I9)
C
C******DIMENSION THE FOLLOWING AS (I9,I9)
C
      DIMENSION DKAB(I9,I9)
C
C******DIMENSION THE FOLLOWING AS (NR+NZ)
C
      DIMENSION YTRAP(NHRZ),ZTRAP(NHRZ)
C
C******DIMENSION THE FOLLOWING AS (NHZ)
C
      DIMENSION Z(NHZ),POR(NHZ),TA(NHZ),TW(NHZ),THA(NHZ)
     1,THW(NHZ),BD(NHZ)
C
C******DIMENSION THE FOLLOWING AS (NHR)
C
      DIMENSION R(NHR),BC(NHR)
C
C******DIMENSION THE FOLLOWING AS (NL)
C
      DIMENSION AL(NHL),ALT(NHL),ZLAY(NHL),IZLAY(NHL),
     1PORL(NHL),THWL(NHL),THAL(NHL),TAL(NHL),BDL(NHL)
C
C********DIMENSION THE FOLLOWING AS (NW)
C
      DIMENSION RVW(NHW),ZVW(NHW),IRVW(NHW),IZVW(NHW)
C
C********DIMENSION THE FOLLOWING (NHK+1)
C
      DIMENSION TIFIP(I9),TIFB(I9),TIFT(I9),TIRBIO(I9),TIFRF(I9),
     1TMASS0(I9),TMASSW(I9),TMASS(I9),XMASSB(I9),XMASST(I9),CRY(I9)
     2,FTOP(I9),GWAT(I9),FBOT(I9),FRIM(I9),FLXDT(I9),DFLXDT(I9)
C
C*******DIMENSION THE FOLLOWING (NHK+2)
C
      DIMENSION WK(I9),VC(I9),VM(I9),DV(I9),IBIO(I9),ICON(I9)
C
C*******DIMENSION THE FOLLOWING (NK)
C
      DIMENSION XIK0(NHK),BMLX(NHK),HWIK(NHK),HAW(NHK),RK(NHK)
     1,HSW(NHK),VK(NHK),ATCONC(NHK),DKW(NHK),IOUTOPT(NHK)
     2,IREF(NHK),IFLX(NHK),RLAMBDA(NHK),RCON(NHK)
     3,RMAX(NHK),HSAT(NHK)
C
C*******DIMENSION THE FOLLOWING
C
      DIMENSION SXLM(10000),XINIT(1001),UINIT(1001),XPT(1001),YPT(1001),
     1SLPZ(1001),SLPR(1001),BZZ(1001),BRR(1001)
C
C
      DO 10 ITER=1,NITER
      ENORM=0.0
      RRBIG=0.0
      DO 20 IZ=2,NZ-1
      DO 20 IR=2,NR-1
C
      IND=0
      IF(IFLAG.GE.3 .AND. IDIM.EQ.1) IND=1
      IF(IND.EQ.1 .AND. ZHI.GE.ZSURF) IND=2
      IF(IND.EQ.2 .AND. IK.EQ.NK) GO TO 13
C
      IND=0
 	IF(IOPT.LE.2 .AND. IFLAG.GE.3) IND=1
      IF(IND.EQ.1 .AND. IZ.GT.IZHI) IND=2
	IF(IND.EQ.2 .AND. IK.EQ.NK) GO TO 13
C
      IND=0
	IF(IZ.LE.IZHI .AND. IZ.GE.IZLOW) IND=1
      IF(IND.EQ.1 .AND. IR.LE.IRIM) GO TO 20
C
 13   AAA=0.0
      BBB=0.0
      DDD=0.0
      EEE=0.0
      BB=0.0
      AAA=-C2(IR,IZ,IK)/C5(IR,IZ,IK)
      BBB=-C1(IR,IZ,IK)/C5(IR,IZ,IK)
      DDD=-C4(IR,IZ,IK)/C5(IR,IZ,IK)
      EEE=-C3(IR,IZ,IK)/C5(IR,IZ,IK)
      BB=C6(IR,IZ)/C5(IR,IZ,IK)
C
C       CALCULATE INTERIOR NODE SUBMATRIX NORM
C
      XNORM=ABS(AAA)+ABS(BBB)+ABS(DDD)+ABS(EEE)
      IF(XNORM.LT.ENORM) GO TO 1
      ENORM=XNORM
      IRNORM=IR
      IZNORM=IZ
    1 CONTINUE
C
C    NOW GET VALUE AT NEXT ITERATION
C
      U1=Y(IR,IZ,IK)
      Y(IR,IZ,IK)=AAA*Y(IR-1,IZ,IK)+BBB*Y(IR+1,IZ,IK)+DDD
     1*Y(IR,IZ-1,IK)+EEE*Y(IR,IZ+1,IK)+BB
      IF(U1.LT.(1.0E-30)) GO TO 20
      RR=ABS((Y(IR,IZ,IK)-U1)/U1)
      IF(RR.GT.RRBIG) RRBIG=RR
   20 CONTINUE
      IF(RRBIG.LT.EPS) GO TO 100
   10 CONTINUE
  100 CONTINUE
      IF(IFLAG.GE.2) IKKK=0
      IF(IK.EQ.IKKK) ITER0=ITER
      RETURN
      END
C
C
C
      SUBROUTINE NODLOC(IROZ,III,XRZ)
C
C    THIS SUBROUTINE LOCATES INDICIES FOR SPECIAL COORDINATES
C
C    IROZ=1 INDICATES AN R COORDINATE
C    IROZ=2 INDICATES A  Z COORDINATE
C
C   III IS THE DESIRED INDEX
C
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER(NHR=501,NHZ=501,NHL=5,NHK=8,NHW=3,I9=NHK+1,
     1NHRZ=NHR+NHZ+1)
      CHARACTER TITLE*70,FNAMEPOR*38,FNAMETHW*38,M*30,
     1FNAMETA*38,FNAMEBD*38,FNAMEICDAT*38,FNAMEMIF*38,FNAMECAL*38,
     2FNAMEOUT1*38,FNAMEOUT2*38,FNAMEOUT3*38,FNAMEOUT4*38,FNAMEOUT5*38,
     3FNAMEOUT6*38,FNAMEOUT7*38,FNAMEOUT8*38,FNAMEOUT9*38,FNAMEOUT10*38,
     4FNAMEOUT11*38,FNAMEOUT12*38,FNAMEOUT13*38,FNAMEOUT14*38,
     5FNAMEOUT15*38,FNAMEOUT16*38,FNAMEOUT17*38,FNAMEOUT18*38,
     6FNAMEOUT19*38,FNAMEOUT20*38,FNAMEOUT21*38,FNAMEOUT22*38,
     7FNAMEOUT23*38,FNAMEOUT24*38,
     8FNAMEBCDAT*38
      COMMON/DEP0/ Y0,Y1,Y2,Y3,DTY
      COMMON/DEP/  Y,TOT,RBIO
      COMMON/CHAR/ M,FNAMETA,FNAMEBD,FNAMECAL,FNAMEMIF,
     3FNAMEICDAT,FNAMEPOR,FNAMETHW,FNAMEBCDAT,TITLE,
     5FNAMEOUT1,FNAMEOUT2,FNAMEOUT3,FNAMEOUT4,FNAMEOUT5,
     6FNAMEOUT6,FNAMEOUT7,FNAMEOUT8,FNAMEOUT9,FNAMEOUT10,
     7FNAMEOUT11,FNAMEOUT12,FNAMEOUT13,FNAMEOUT14,FNAMEOUT15,FNAMEOUT16,
     8FNAMEOUT17,FNAMEOUT18,FNAMEOUT19,FNAMEOUT20,FNAMEOUT21,FNAMEOUT22,
     9FNAMEOUT23,FNAMEOUT24
      COMMON/XNRNZNK/ BR,BZ,CR,CZ,PP,DKA,SUMDK
      COMMON/XNRNZ/ PT
      COMMON/XNZNK/ FIRF,A
      COMMON/XNRNK/ FIZT,FIZW,FLX
      COMMON/XNKNK/ DKAB
      COMMON/XNR/ R,BC
      COMMON/XNZ/ Z,TA,TW,BD,POR,THA,THW
      COMMON/YTRP/ YTRAP,ZTRAP
      COMMON/XNK/  XIK0,HAW,HSW,RK,TIFIP,TIFB,TIFT,TIRBIO,TIFRF,
     1TMASS,TMASS0,CRY,VK,WK,HWIK,XMASSB,XMASST,ATCONC,IBIO,ICON,
     2TMASSW,DV,DKW,VC,VM,BMLX,FLXDT,IOUTOPT,IREF,IFLX
     3,RCON,RLAMBDA,RMAX,HSAT,GWAT,FTOP,FBOT,FRIM,DFLXDT
      COMMON/XNL/AL,ALT,ZLAY,PORL,TAL,THWL,THAL,BDL
      COMMON/XNW/RVW,ZVW
      COMMON/ARRAY/ XINIT,UINIT,XPT,YPT,SLPZ,SLPR,BZZ,BRR,SXLM
      COMMON/ISC/NR,NZ,NL,NK,NT,IRIM,IRASP,IZLOW,IZHI,IZBAS,IRVW,IZVW,
     1IPROJ,NITER,IRNORM,IZNORM,ITER,ITER0,ISS,IRFP,IW,IL,IK,IKK,I,
     2NW,IZLAY,JK,IDAT,NDAT,ICOUNT,IOX,IIX,ICUT,IDT,IU2,IU3,IU4,KONS
      COMMON/INT/IFIL,IMOD,IMILQ,IOPT,INOPT,IBC0,IOUT,ICOMP,ISURF,
     1NDATIN,NDATCAL,NIPTS,ISNAP,ITIME,ICONX,IWARN,ICNTER,IDIM,
     2ISTRAT,IBDRY,INCHECK,IDISP,IWAT,IFLAG,IN,JN,IRMAX,IHSAT
      COMMON/XSC/DT,DR,DZ,SUM,AR1,AR2,AR3,AR4,AZ1,AZ2,ATOX,RHOIM,CSA,
     1TIME,VIMM,DARCY,THI0,EPS,ENORM,ATM,ZBAS,ZWAT,ZSURF,ZLOW,ZHI,
     2DT1,DT2,DTM,TRANS,TEND,YPR1,YPR2,SKIP,SKIP2,TEMP,RIM,RF,DTHI0
      COMMON/CONS/FLUX,UP,UW,D,DS,GAM,B,C,XL,PI,XFD,BP,DP,WAT,AIR,
     1XMM,DBIN,XM0,XB0,YNM,TMAX,DELT,HENRY,SWPC,BULK,XLL,TSNAP,TOR,
     2XB,ZOUT,GASBOT
      COMMON/RC1/ C6,C7
      COMMON/RC2/C1,C2,C3,C4,C5
C
C
C
C****DIMENSION THE FOLLOWING (NR,NZ,NHK+1)
C
      DIMENSION Y0(NHR,NHZ,I9),DTY(NHR,NHZ,I9),PP(NHR,NHZ,I9)
     1,BR(NHR,NHZ,I9),BZ(NHR,NHZ,I9),CR(NHR,NHZ,I9),CZ(NHR,NHZ,I9)
     2,C1(NHR,NHZ,I9),C2(NHR,NHZ,I9),C3(NHR,NHZ,I9),C4(NHR,NHZ,I9)
     3,C5(NHR,NHZ,I9),DKA(NHR,NHZ,I9),SUMDK(NHR,NHZ,I9)
     4,Y(NHR,NHZ,I9),Y3(NHR,NHZ,I9)
C
C****DIMENSION THE FOLLOWING (NR,NZ)
      DIMENSION TOT(NHR,NHZ),PT(NHR,NHZ)
      DIMENSION C6(NHR,NHZ),C7(NHR,NHZ),RBIO(NHR,NHZ)
C
C******DIMENSION THE FOLLOWING AS (NZ,NHK+1)
C
      DIMENSION FIRF(NHZ,I9),A(NHZ,I9),Y1(NHZ,I9)
C
C******DIMENSION THE FOLLOWING AS (NR,NHK+1)
C
      DIMENSION FIZT(NHR,I9),FIZW(NHR,I9),FLX(NHR,I9),Y2(NHR,I9)
C
C******DIMENSION THE FOLLOWING AS (I9,I9)
C
      DIMENSION DKAB(I9,I9)
C
C******DIMENSION THE FOLLOWING AS (NR+NZ)
C
      DIMENSION YTRAP(NHRZ),ZTRAP(NHRZ)
C
C******DIMENSION THE FOLLOWING AS (NHZ)
C
      DIMENSION Z(NHZ),POR(NHZ),TA(NHZ),TW(NHZ),THA(NHZ)
     1,THW(NHZ),BD(NHZ)
C
C******DIMENSION THE FOLLOWING AS (NHR)
C
      DIMENSION R(NHR),BC(NHR)
C
C******DIMENSION THE FOLLOWING AS (NL)
C
      DIMENSION AL(NHL),ALT(NHL),ZLAY(NHL),IZLAY(NHL),
     1PORL(NHL),THWL(NHL),THAL(NHL),TAL(NHL),BDL(NHL)
C
C********DIMENSION THE FOLLOWING AS (NW)
C
      DIMENSION RVW(NHW),ZVW(NHW),IRVW(NHW),IZVW(NHW)
C
C********DIMENSION THE FOLLOWING (NHK+1)
C
      DIMENSION TIFIP(I9),TIFB(I9),TIFT(I9),TIRBIO(I9),TIFRF(I9),
     1TMASS0(I9),TMASSW(I9),TMASS(I9),XMASSB(I9),XMASST(I9),CRY(I9)
     2,FTOP(I9),GWAT(I9),FBOT(I9),FRIM(I9),FLXDT(I9),DFLXDT(I9)
C
C*******DIMENSION THE FOLLOWING (NHK+2)
C
      DIMENSION WK(I9),VC(I9),VM(I9),DV(I9),IBIO(I9),ICON(I9)
C
C*******DIMENSION THE FOLLOWING (NK)
C
      DIMENSION XIK0(NHK),BMLX(NHK),HWIK(NHK),HAW(NHK),RK(NHK)
     1,HSW(NHK),VK(NHK),ATCONC(NHK),DKW(NHK),IOUTOPT(NHK)
     2,IREF(NHK),IFLX(NHK),RLAMBDA(NHK),RCON(NHK)
     3,RMAX(NHK),HSAT(NHK)
C
C*******DIMENSION THE FOLLOWING
C
      DIMENSION SXLM(10000),XINIT(1001),UINIT(1001),XPT(1001),YPT(1001),
     1SLPZ(1001),SLPR(1001),BZZ(1001),BRR(1001)
C
C
      IF(IROZ.EQ.2) GO TO 5
      ERR=1.0E20
      DO 10 IR=1,NR
      ER=ABS(XRZ-R(IR))
      IF(ER.GT.ERR) GO TO 10
      ERR=ER
      III=IR
   10 CONTINUE
      IF(IROZ.EQ.1) GO TO 13
    5 CONTINUE
      ERR=1.0E20
      DO 11 IZ=1,NZ
      ER=ABS(XRZ-Z(IZ))
      IF(ER.GT.ERR) GO TO 11
      ERR=ER
      III=IZ
   11 CONTINUE
   13 RETURN
      END
C
C
      SUBROUTINE BDRY
C
C   THIS SUBROUTINE APPLYS BOUNDARY CONDITIONS FOR RADIALLY SYMETRIC DOMAIN
C
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER(NHR=501,NHZ=501,NHL=5,NHK=8,NHW=3,I9=NHK+1,
     1NHRZ=NHR+NHZ+1)
      CHARACTER TITLE*70,FNAMEPOR*38,FNAMETHW*38,M*30,
     1FNAMETA*38,FNAMEBD*38,FNAMEICDAT*38,FNAMEMIF*38,FNAMECAL*38,
     2FNAMEOUT1*38,FNAMEOUT2*38,FNAMEOUT3*38,FNAMEOUT4*38,FNAMEOUT5*38,
     3FNAMEOUT6*38,FNAMEOUT7*38,FNAMEOUT8*38,FNAMEOUT9*38,FNAMEOUT10*38,
     4FNAMEOUT11*38,FNAMEOUT12*38,FNAMEOUT13*38,FNAMEOUT14*38,
     5FNAMEOUT15*38,FNAMEOUT16*38,FNAMEOUT17*38,FNAMEOUT18*38,
     6FNAMEOUT19*38,FNAMEOUT20*38,FNAMEOUT21*38,FNAMEOUT22*38,
     7FNAMEOUT23*38,FNAMEOUT24*38,
     8FNAMEBCDAT*38
      COMMON/DEP0/ Y0,Y1,Y2,Y3,DTY
      COMMON/DEP/  Y,TOT,RBIO
      COMMON/CHAR/ M,FNAMETA,FNAMEBD,FNAMECAL,FNAMEMIF,
     3FNAMEICDAT,FNAMEPOR,FNAMETHW,FNAMEBCDAT,TITLE,
     5FNAMEOUT1,FNAMEOUT2,FNAMEOUT3,FNAMEOUT4,FNAMEOUT5,
     6FNAMEOUT6,FNAMEOUT7,FNAMEOUT8,FNAMEOUT9,FNAMEOUT10,
     7FNAMEOUT11,FNAMEOUT12,FNAMEOUT13,FNAMEOUT14,FNAMEOUT15,FNAMEOUT16,
     8FNAMEOUT17,FNAMEOUT18,FNAMEOUT19,FNAMEOUT20,FNAMEOUT21,FNAMEOUT22,
     9FNAMEOUT23,FNAMEOUT24
      COMMON/XNRNZNK/ BR,BZ,CR,CZ,PP,DKA,SUMDK
      COMMON/XNRNZ/ PT
      COMMON/XNZNK/ FIRF,A
      COMMON/XNRNK/ FIZT,FIZW,FLX
      COMMON/XNKNK/ DKAB
      COMMON/XNR/ R,BC
      COMMON/XNZ/ Z,TA,TW,BD,POR,THA,THW
      COMMON/YTRP/ YTRAP,ZTRAP
      COMMON/XNK/  XIK0,HAW,HSW,RK,TIFIP,TIFB,TIFT,TIRBIO,TIFRF,
     1TMASS,TMASS0,CRY,VK,WK,HWIK,XMASSB,XMASST,ATCONC,IBIO,ICON,
     2TMASSW,DV,DKW,VC,VM,BMLX,FLXDT,IOUTOPT,IREF,IFLX
     3,RCON,RLAMBDA,RMAX,HSAT,GWAT,FTOP,FBOT,FRIM,DFLXDT
      COMMON/XNL/AL,ALT,ZLAY,PORL,TAL,THWL,THAL,BDL
      COMMON/XNW/RVW,ZVW
      COMMON/ARRAY/ XINIT,UINIT,XPT,YPT,SLPZ,SLPR,BZZ,BRR,SXLM
      COMMON/ISC/NR,NZ,NL,NK,NT,IRIM,IRASP,IZLOW,IZHI,IZBAS,IRVW,IZVW,
     1IPROJ,NITER,IRNORM,IZNORM,ITER,ITER0,ISS,IRFP,IW,IL,IK,IKK,I,
     2NW,IZLAY,JK,IDAT,NDAT,ICOUNT,IOX,IIX,ICUT,IDT,IU2,IU3,IU4,KONS
      COMMON/INT/IFIL,IMOD,IMILQ,IOPT,INOPT,IBC0,IOUT,ICOMP,ISURF,
     1NDATIN,NDATCAL,NIPTS,ISNAP,ITIME,ICONX,IWARN,ICNTER,IDIM,
     2ISTRAT,IBDRY,INCHECK,IDISP,IWAT,IFLAG,IN,JN,IRMAX,IHSAT
      COMMON/XSC/DT,DR,DZ,SUM,AR1,AR2,AR3,AR4,AZ1,AZ2,ATOX,RHOIM,CSA,
     1TIME,VIMM,DARCY,THI0,EPS,ENORM,ATM,ZBAS,ZWAT,ZSURF,ZLOW,ZHI,
     2DT1,DT2,DTM,TRANS,TEND,YPR1,YPR2,SKIP,SKIP2,TEMP,RIM,RF,DTHI0
      COMMON/CONS/FLUX,UP,UW,D,DS,GAM,B,C,XL,PI,XFD,BP,DP,WAT,AIR,
     1XMM,DBIN,XM0,XB0,YNM,TMAX,DELT,HENRY,SWPC,BULK,XLL,TSNAP,TOR,
     2XB,ZOUT,GASBOT
      COMMON/RC1/ C6,C7
      COMMON/RC2/C1,C2,C3,C4,C5
C
C
C
C****DIMENSION THE FOLLOWING (NR,NZ,NHK+1)
C
      DIMENSION Y0(NHR,NHZ,I9),DTY(NHR,NHZ,I9),PP(NHR,NHZ,I9)
     1,BR(NHR,NHZ,I9),BZ(NHR,NHZ,I9),CR(NHR,NHZ,I9),CZ(NHR,NHZ,I9)
     2,C1(NHR,NHZ,I9),C2(NHR,NHZ,I9),C3(NHR,NHZ,I9),C4(NHR,NHZ,I9)
     3,C5(NHR,NHZ,I9),DKA(NHR,NHZ,I9),SUMDK(NHR,NHZ,I9)
     4,Y(NHR,NHZ,I9),Y3(NHR,NHZ,I9)
C
C****DIMENSION THE FOLLOWING (NR,NZ)
      DIMENSION TOT(NHR,NHZ),PT(NHR,NHZ)
      DIMENSION C6(NHR,NHZ),C7(NHR,NHZ),RBIO(NHR,NHZ)
C
C******DIMENSION THE FOLLOWING AS (NZ,NHK+1)
C
      DIMENSION FIRF(NHZ,I9),A(NHZ,I9),Y1(NHZ,I9)
C
C******DIMENSION THE FOLLOWING AS (NR,NHK+1)
C
      DIMENSION FIZT(NHR,I9),FIZW(NHR,I9),FLX(NHR,I9),Y2(NHR,I9)
C
C******DIMENSION THE FOLLOWING AS (I9,I9)
C
      DIMENSION DKAB(I9,I9)
C
C******DIMENSION THE FOLLOWING AS (NR+NZ)
C
      DIMENSION YTRAP(NHRZ),ZTRAP(NHRZ)
C
C******DIMENSION THE FOLLOWING AS (NHZ)
C
      DIMENSION Z(NHZ),POR(NHZ),TA(NHZ),TW(NHZ),THA(NHZ)
     1,THW(NHZ),BD(NHZ)
C
C******DIMENSION THE FOLLOWING AS (NHR)
C
      DIMENSION R(NHR),BC(NHR)
C
C******DIMENSION THE FOLLOWING AS (NL)
C
      DIMENSION AL(NHL),ALT(NHL),ZLAY(NHL),IZLAY(NHL),
     1PORL(NHL),THWL(NHL),THAL(NHL),TAL(NHL),BDL(NHL)
C
C********DIMENSION THE FOLLOWING AS (NW)
C
      DIMENSION RVW(NHW),ZVW(NHW),IRVW(NHW),IZVW(NHW)
C
C********DIMENSION THE FOLLOWING (NHK+1)
C
      DIMENSION TIFIP(I9),TIFB(I9),TIFT(I9),TIRBIO(I9),TIFRF(I9),
     1TMASS0(I9),TMASSW(I9),TMASS(I9),XMASSB(I9),XMASST(I9),CRY(I9)
     2,FTOP(I9),GWAT(I9),FBOT(I9),FRIM(I9),FLXDT(I9),DFLXDT(I9)
C
C*******DIMENSION THE FOLLOWING (NHK+2)
C
      DIMENSION WK(I9),VC(I9),VM(I9),DV(I9),IBIO(I9),ICON(I9)
C
C*******DIMENSION THE FOLLOWING (NK)
C
      DIMENSION XIK0(NHK),BMLX(NHK),HWIK(NHK),HAW(NHK),RK(NHK)
     1,HSW(NHK),VK(NHK),ATCONC(NHK),DKW(NHK),IOUTOPT(NHK)
     2,IREF(NHK),IFLX(NHK),RLAMBDA(NHK),RCON(NHK)
     3,RMAX(NHK),HSAT(NHK)
C
C*******DIMENSION THE FOLLOWING
C
      DIMENSION SXLM(10000),XINIT(1001),UINIT(1001),XPT(1001),YPT(1001),
     1SLPZ(1001),SLPR(1001),BZZ(1001),BRR(1001)
C
C  SPECIAL CASES FOR O2 IF MODELING BIODEGRADATION
C
C
      IND=0
      IF(IFLAG.GE.3 .AND. IDIM.EQ.1) IND=1
      IF(IND.EQ.1 .AND. ZHI.GE.ZSURF) IND=2
      IF(IND.EQ.2 .AND. IK.EQ.NK) GO TO 19
C
	IND=0
	IF(IOPT.LE.2 .OR. IOPT.EQ.4) IND=1
	IF(IND.EQ.1 .AND. IFLAG.GE.3) IND=2
	IF(IND.EQ.2 .AND. IK.EQ.NK) GO TO 19
C
C     
C    INSIDE SOURCE BOUNDARY ZERO FOR INTEGRATION PURPOSES
C
      IF(IOPT.LE.3) THEN
	DO 20 IR=1,NR
      DO 20 IZ=1,NZ
      IND=0
      IF(IZ.LT.IZHI.AND.IZ.GT.IZLOW) IND=1
      IF(IND.EQ.1.AND.IR.LT.IRIM) Y0(IR,IZ,IK)=0.0
      IF(IND.EQ.1.AND.IR.LT.IRIM) Y(IR,IZ,IK)=0.0
   20 CONTINUE
      END IF
C
C  --IOPT=1, SPECIFIED FLUX BOUNDARY AT z=0
C
	IF(IOPT.EQ.1) THEN
      D1=DKW(IK)
      H1=HAW(IK)
      DO 13 IR=1,NR
      D2=DKA(IR,IZHI,IK)
      U3=D2*THA(IZHI)*TA(IZHI)
      U3=U3+(D1*THW(IZHI)*TW(IZHI)/H1)
      U3=U3+(ABS(DARCY/THW(IZHI))*AL(1)/H1)
      U4=FLX(IR,IK)*DZ/U3
      U5=(DARCY*DZ)/(H1*U3)
      Y0(IR,IZHI,IK)=(U4+Y0(IR,IZHI+1,IK))/(U5+1)
 13   CONTINUE
      GO TO 19
      END IF
C
C
C  --IOPT=2, SPECIFIED CONCENTRATION AT z=0
C
      IF(IOPT.EQ.2) THEN
	DO 17 IR=1,NR
      Y0(IR,IZHI,IK)=Y0(IR,2,IK)
 17   CONTINUE
      GO TO 19
      END IF
C
C
C  --IOPT=3, TIME DEPENDENT CONCENTRATION BDRY, (IMMISCIBLE PLUME)
C    AT EDGE OF IMMISCIBLE PLUME FIRST KIND BOUNDARY
C
      IF(IOPT.EQ.3) THEN
	DO 1 IR=1,IRIM
      IF(IFLAG.GE.3 .AND. IK.EQ.NK) THEN
	Y0(IR,IZHI,NK)=0.0
	ELSE
	IF(THI0.GT.0) THEN
      Y0(IR,IZHI,IK)=(((XIK0(IK)/WK(IK))/SUM)*HWIK(IK))*HAW(IK)
      Y0(IR,IZLOW,IK)=(((XIK0(IK)/WK(IK))/SUM)*HWIK(IK))*HAW(IK)
	ELSE
	Y0(IR,IZHI,IK)=Y0(IR,IZHI+1,IK)
	Y0(IR,IZLOW,IK)=Y0(IR,IZLOW-1,IK)
      END IF
	END IF
    1 CONTINUE
      DO 2 IZ=IZLOW,IZHI
      IF(IFLAG.GE.3 .AND. IK.EQ.NK) THEN
	Y0(IRIM,IZ,NK)=0.0
      ELSE
	IF(THI0.GT.0) THEN
      Y0(IRIM,IZ,IK)=(((XIK0(IK)/WK(IK))/SUM)*HWIK(IK))*HAW(IK)
	ELSE
	Y0(IRIM,IZ,IK)=Y0(IRIM+1,IZ,IK)
	END IF
	END IF
    2 CONTINUE
 	GO TO 19
      END IF
C
C
C  --IOPT=4, CONSTANT RADIAL FLUX SOURCE
C
C  --AT BOTTOM AND TOP OF INJECTION PROBE, FIRST KIND BOUNDARIES
C
      IF(IOPT.EQ.4) THEN
      IF(IZHI.LT.NZ) Y0(1,IZHI,IK)=Y0(1,IZHI+1,IK)
      IF(IZLOW.GT.1) Y0(1,IZLOW,IK)=Y0(1,IZLOW-1,IK)
C
C  --AT EDGE OF INJECTION PROBE,CONSTANT FLUX BOUNDARY
C
      H1=HAW(IK)
      IL=1
      DO 12 IZ=IZLOW,IZHI
      IF(Z(IZ).GE.Z(IZLAY(IL))) IL=IL+1
      IF(IL.GT.NL) IL=NL
      D1=DKW(IK)
      D2=DKA(2,IZ,IK)
      U3=-D2*THA(IZ)*TA(IZ)
      U3=U3-D1*THW(IZ)*TW(IZ)/H1
      U3=U3-ABS(DARCY/THW(IZ))*AL(IL)/H1
      Y0(1,IZ,IK)=(-FLX(1,IK)*DR/U3)+Y0(2,IZ,IK)
 12   CONTINUE
      END IF
C
C
C  --IOPT=5, FALL-OFF FROM "HOT-START" INITIAL CONDITION
C  ESTABLISH NO-DIFFUSIVE FLUX BOUNDARY CONDITIONS AROUND FORMER SOURCE
C  BOUNDARIES
C
      DO 14 IR=1,IRIM
      Y0(IR,IZLOW,IK)=Y0(IR,IZLOW-1,IK)
      Y0(IR,IZHI,IK)=Y0(IR,IZHI+1,IK)
 14   CONTINUE
      DO 15 IZ=IZLOW,IZHI
      Y0(IRIM,IZ,IK)=Y0(IRIM+1,IZ,IK)
 15   CONTINUE
C
 19   CONTINUE
C
C  --AT R=R0  DY/DR=0
C
      DO 3 IZ=2,IZLOW-1
      Y0(1,IZ,IK)=Y0(2,IZ,IK)
    3 CONTINUE
      DO 4 IZ=IZHI+1,NZ-1
      Y0(1,IZ,IK)=Y0(2,IZ,IK)
    4 CONTINUE
C
C   --AT THE GROUND SURFACE
C    CAUCHY,ROBBINS,OR THIRD KIND
C    ALPHA*U +DZ*(1-ALPHA)*DU/DZ =0 FOR MODELED CONSTITUENT
C
      IND=0
      IF(IFLAG.GE.3 .AND. IDIM.EQ.1) IND=1
      IF(IND.EQ.1 .AND. ZHI.GE.ZSURF) IND=2
      IF(IND.EQ.2 .AND. IK.EQ.NK) THEN
      DO 56 IR=1,NR
      Y0(IR,NZ,NK)=ATOX
   56 CONTINUE
      GO TO 16
      END IF
      DO 55 IR=1,NR
      IF(IR.LE.IRASP) U1=AR1
      IF(IR.GT.IRASP) U1=AR2
      Y0(IR,NZ,IK)=(1.0-U1)*Y0(IR,NZ-1,IK) + U1*ATCONC(IK)
   55 CONTINUE
C
   16 CONTINUE
C
C   --AT R=RF (FAR-LATERAL BOUNDARY)
C    CAUCHY ROBBINS OR THIRD KIND ALSO
C    ALPHA*U +DR*(1-ALPHA)*DU/DR = 0 FOR MODELED CONSTITUENT
C
      DO 66 IZ=2,NZ-1
      IF(IZ.LE.IZBAS) U1=AZ1
      IF(IZ.GT.IZBAS) U1=AZ2
      Y0(NR,IZ,IK)=(1.0-U1)*Y0(NR-1,IZ,IK) + U1*ATCONC(IK)
 66   CONTINUE
C
C   --AT LOWER BOUNDARY (z=0)
C    THIRD KIND  ALPHA*U -DZ*(1-ALPHA)*DU/DZ=Go  
C    FOR MODELED CONSTITUENT
C
      IND=0
      IF(IK.LT.NK) U1=AR3
      IF(IK.EQ.NK) U1=AR4
	IF(AR3.LE.0 .OR. AR4.LE.0) GWAT(IK)=0.0
	DO 7 IR=1,NR
      IF(IOPT.GE.3) Y0(IR,1,IK)=(1.0-U1)*Y0(IR,2,IK) + U1*GWAT(IK)
C
C   SPECIAL CASE FOR SOURCE AT WATER TABLE IF MODELING BIODEGRADATION AND 
C   O2 TRANSPORT
C
	IF(IOPT.LE.2 .AND. IFLAG.GE.3) THEN
	IF(I.EQ.1 .AND. IK.EQ.NK) Y0(IR,1,NK)=0.0
      IF(I.GE.1 .AND. IK.EQ.NK) Y0(IR,2,NK)=(1.0-U1)*Y0(IR,3,NK) + U1*GW
	1AT(NK)
	END IF
    7 CONTINUE
      RETURN
      END
C
C
C
      SUBROUTINE BIO(IR,IZ)
C
C   THIS SUBROUTINE COMPUTES THE REACTION RATE (RBIO(IR,IZ)) FOR EACH
C   CONSTITUENT (IK) ASSUMING EITHER ZERO- OR FIRST-ORDER KINETICS.
C
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER(NHR=501,NHZ=501,NHL=5,NHK=8,NHW=3,I9=NHK+1,
     1NHRZ=NHR+NHZ+1)
      CHARACTER TITLE*70,FNAMEPOR*38,FNAMETHW*38,M*30,
     1FNAMETA*38,FNAMEBD*38,FNAMEICDAT*38,FNAMEMIF*38,FNAMECAL*38,
     2FNAMEOUT1*38,FNAMEOUT2*38,FNAMEOUT3*38,FNAMEOUT4*38,FNAMEOUT5*38,
     3FNAMEOUT6*38,FNAMEOUT7*38,FNAMEOUT8*38,FNAMEOUT9*38,FNAMEOUT10*38,
     4FNAMEOUT11*38,FNAMEOUT12*38,FNAMEOUT13*38,FNAMEOUT14*38,
     5FNAMEOUT15*38,FNAMEOUT16*38,FNAMEOUT17*38,FNAMEOUT18*38,
     6FNAMEOUT19*38,FNAMEOUT20*38,FNAMEOUT21*38,FNAMEOUT22*38,
     7FNAMEOUT23*38,FNAMEOUT24*38,
     8FNAMEBCDAT*38
      COMMON/DEP0/ Y0,Y1,Y2,Y3,DTY
      COMMON/DEP/  Y,TOT,RBIO
      COMMON/CHAR/ M,FNAMETA,FNAMEBD,FNAMECAL,FNAMEMIF,
     3FNAMEICDAT,FNAMEPOR,FNAMETHW,FNAMEBCDAT,TITLE,
     5FNAMEOUT1,FNAMEOUT2,FNAMEOUT3,FNAMEOUT4,FNAMEOUT5,
     6FNAMEOUT6,FNAMEOUT7,FNAMEOUT8,FNAMEOUT9,FNAMEOUT10,
     7FNAMEOUT11,FNAMEOUT12,FNAMEOUT13,FNAMEOUT14,FNAMEOUT15,FNAMEOUT16,
     8FNAMEOUT17,FNAMEOUT18,FNAMEOUT19,FNAMEOUT20,FNAMEOUT21,FNAMEOUT22,
     9FNAMEOUT23,FNAMEOUT24
      COMMON/XNRNZNK/ BR,BZ,CR,CZ,PP,DKA,SUMDK
      COMMON/XNRNZ/ PT
      COMMON/XNZNK/ FIRF,A
      COMMON/XNRNK/ FIZT,FIZW,FLX
      COMMON/XNKNK/ DKAB
      COMMON/XNR/ R,BC
      COMMON/XNZ/ Z,TA,TW,BD,POR,THA,THW
      COMMON/YTRP/ YTRAP,ZTRAP
      COMMON/XNK/  XIK0,HAW,HSW,RK,TIFIP,TIFB,TIFT,TIRBIO,TIFRF,
     1TMASS,TMASS0,CRY,VK,WK,HWIK,XMASSB,XMASST,ATCONC,IBIO,ICON,
     2TMASSW,DV,DKW,VC,VM,BMLX,FLXDT,IOUTOPT,IREF,IFLX
     3,RCON,RLAMBDA,RMAX,HSAT,GWAT,FTOP,FBOT,FRIM,DFLXDT
      COMMON/XNL/AL,ALT,ZLAY,PORL,TAL,THWL,THAL,BDL
      COMMON/XNW/RVW,ZVW
      COMMON/ARRAY/ XINIT,UINIT,XPT,YPT,SLPZ,SLPR,BZZ,BRR,SXLM
      COMMON/ISC/NR,NZ,NL,NK,NT,IRIM,IRASP,IZLOW,IZHI,IZBAS,IRVW,IZVW,
     1IPROJ,NITER,IRNORM,IZNORM,ITER,ITER0,ISS,IRFP,IW,IL,IK,IKK,I,
     2NW,IZLAY,JK,IDAT,NDAT,ICOUNT,IOX,IIX,ICUT,IDT,IU2,IU3,IU4,KONS
      COMMON/INT/IFIL,IMOD,IMILQ,IOPT,INOPT,IBC0,IOUT,ICOMP,ISURF,
     1NDATIN,NDATCAL,NIPTS,ISNAP,ITIME,ICONX,IWARN,ICNTER,IDIM,
     2ISTRAT,IBDRY,INCHECK,IDISP,IWAT,IFLAG,IN,JN,IRMAX,IHSAT
      COMMON/XSC/DT,DR,DZ,SUM,AR1,AR2,AR3,AR4,AZ1,AZ2,ATOX,RHOIM,CSA,
     1TIME,VIMM,DARCY,THI0,EPS,ENORM,ATM,ZBAS,ZWAT,ZSURF,ZLOW,ZHI,
     2DT1,DT2,DTM,TRANS,TEND,YPR1,YPR2,SKIP,SKIP2,TEMP,RIM,RF,DTHI0
      COMMON/CONS/FLUX,UP,UW,D,DS,GAM,B,C,XL,PI,XFD,BP,DP,WAT,AIR,
     1XMM,DBIN,XM0,XB0,YNM,TMAX,DELT,HENRY,SWPC,BULK,XLL,TSNAP,TOR,
     2XB,ZOUT,GASBOT
      COMMON/RC1/ C6,C7
      COMMON/RC2/C1,C2,C3,C4,C5
C
C
C
C****DIMENSION THE FOLLOWING (NR,NZ,NHK+1)
C
      DIMENSION Y0(NHR,NHZ,I9),DTY(NHR,NHZ,I9),PP(NHR,NHZ,I9)
     1,BR(NHR,NHZ,I9),BZ(NHR,NHZ,I9),CR(NHR,NHZ,I9),CZ(NHR,NHZ,I9)
     2,C1(NHR,NHZ,I9),C2(NHR,NHZ,I9),C3(NHR,NHZ,I9),C4(NHR,NHZ,I9)
     3,C5(NHR,NHZ,I9),DKA(NHR,NHZ,I9),SUMDK(NHR,NHZ,I9)
     4,Y(NHR,NHZ,I9),Y3(NHR,NHZ,I9)
C
C****DIMENSION THE FOLLOWING (NR,NZ)
      DIMENSION TOT(NHR,NHZ),PT(NHR,NHZ)
      DIMENSION C6(NHR,NHZ),C7(NHR,NHZ),RBIO(NHR,NHZ)
C
C******DIMENSION THE FOLLOWING AS (NZ,NHK+1)
C
      DIMENSION FIRF(NHZ,I9),A(NHZ,I9),Y1(NHZ,I9)
C
C******DIMENSION THE FOLLOWING AS (NR,NHK+1)
C
      DIMENSION FIZT(NHR,I9),FIZW(NHR,I9),FLX(NHR,I9),Y2(NHR,I9)
C
C******DIMENSION THE FOLLOWING AS (I9,I9)
C
      DIMENSION DKAB(I9,I9)
C
C******DIMENSION THE FOLLOWING AS (NR+NZ)
C
      DIMENSION YTRAP(NHRZ),ZTRAP(NHRZ)
C
C******DIMENSION THE FOLLOWING AS (NHZ)
C
      DIMENSION Z(NHZ),POR(NHZ),TA(NHZ),TW(NHZ),THA(NHZ)
     1,THW(NHZ),BD(NHZ)
C
C******DIMENSION THE FOLLOWING AS (NHR)
C
      DIMENSION R(NHR),BC(NHR)
C
C
C******DIMENSION THE FOLLOWING AS (NL)
C
      DIMENSION AL(NHL),ALT(NHL),ZLAY(NHL),IZLAY(NHL),
     1PORL(NHL),THWL(NHL),THAL(NHL),TAL(NHL),BDL(NHL)
C
C********DIMENSION THE FOLLOWING AS (NW)
C
      DIMENSION RVW(NHW),ZVW(NHW),IRVW(NHW),IZVW(NHW)
C
C********DIMENSION THE FOLLOWING (NHK+1)
C
      DIMENSION TIFIP(I9),TIFB(I9),TIFT(I9),TIRBIO(I9),TIFRF(I9),
     1TMASS0(I9),TMASSW(I9),TMASS(I9),XMASSB(I9),XMASST(I9),CRY(I9)
     2,FTOP(I9),GWAT(I9),FBOT(I9),FRIM(I9),FLXDT(I9),DFLXDT(I9)
C
C*******DIMENSION THE FOLLOWING (NHK+2)
C
      DIMENSION WK(I9),VC(I9),VM(I9),DV(I9),IBIO(I9),ICON(I9)
C
C*******DIMENSION THE FOLLOWING (NK)
C
      DIMENSION XIK0(NHK),BMLX(NHK),HWIK(NHK),HAW(NHK),RK(NHK)
     1,HSW(NHK),VK(NHK),ATCONC(NHK),DKW(NHK),IOUTOPT(NHK)
     2,IREF(NHK),IFLX(NHK),RLAMBDA(NHK),RCON(NHK)
     3,RMAX(NHK),HSAT(NHK)
C
C*******DIMENSION THE FOLLOWING
C
      DIMENSION SXLM(10000),XINIT(1001),UINIT(1001),XPT(1001),YPT(1001),
     1SLPZ(1001),SLPR(1001),BZZ(1001),BRR(1001)
C
C
C
C---------------------------------
      ENTRY BIO1(IR,IZ)
C---------------------------------
C
	IF(I.EQ.1) RBIO(IR,IZ)=0.0
      IF(I.EQ.1) GO TO 10
      ICUT=0
	IF(Y(IR,IZ,IK).LT.(1.0E-20)) ICUT=1
	IF(Y(IR,IZ,NK).LT.(1.0E-20)) ICUT=1
      IF(ICUT.EQ.1) RBIO(IR,IZ)=0.0
      IF(ICUT.EQ.1) GO TO 10
C
C  ZERO-ORDER REACTION KINETICS MODEL
C
      IF(IBIO(IK).EQ.1) THEN
      RBIO(IR,IZ)=RCON(IK)
      GO TO 10
      END IF
C
C  1ST-ORDER KINETICS MODEL LINKED TO SUBSTRATE AVAILABILITY IN
C  AQUEOUS PHASE
C
C  1ST-ORDER MODEL DOES NOT CONSIDER O2 TRANSPORT
C
      IF(IBIO(IK).EQ.2) THEN
      U1=Y(IR,IZ,IK)/HAW(IK)
      RBIO(IR,IZ)=U1*RLAMBDA(IK)
	GO TO 10
	END IF
C
C  1ST-ORDER MODEL CONSIDERS O2 TRANSPORT
C	
      IF(IBIO(IK).EQ.3) THEN
      IF(IK.EQ.NK .AND. IOX.EQ.1) GO TO 70
      U1=Y(IR,IZ,IK)/HAW(IK)
      RBIO(IR,IZ)=U1*RLAMBDA(IK)
	GO TO 10
 70   CONTINUE
      RBIO(IR,IZ)=0.0
	DO 71 IKK=1,NK-1
	IF(IBIO(IKK).EQ.3) THEN
	U1=Y(IR,IZ,IKK)/HAW(IKK)
      RBIO(IR,IZ)=U1*RLAMBDA(IKK)*RK(IKK)+RBIO(IR,IZ)
	END IF
 71   CONTINUE
      GO TO 10
      END IF
C
C  KINETICS MODEL LINKED TO AVAILABILITY OF
C  EITHER OXYGEN OR THE HYDROCARBON IN AQUEOUS-PHASE (WHICH EVER IS LESS)
C
      IF(IBIO(IK).EQ.4) THEN
      RB=0.0
	IF(IK.EQ.NK) GO TO 80
      U1=(THW(IZ)/HAW(IK)+THA(IZ)+HSW(IK)*BD(IZ)/HAW(IK))*Y(IR,IZ,IK)
	U2=U1/TOT(IR,IZ)
      U3=(THW(IZ)/HAW(NK)+THA(IZ))*Y(IR,IZ,NK)
	U4=(U2*U3)/(RK(IK)*DT)
	U5=U1/DT
      RBIO(IR,IZ)=U4
	IF(U4.GT.U5) RBIO(IR,IZ)=U5 
      GO TO 10     
 80   CONTINUE
      RBIO(IR,IZ)=0.0
      DO 81 IKK=1,NK-1
      IF(IBIO(IKK).EQ.4) THEN
      U1=(THW(IZ)/HAW(IKK)+THA(IZ)+HSW(IKK)*BD(IZ)/HAW(IKK))*Y(IR,IZ,IKK
     1)
	U2=U1/TOT(IR,IZ)
      U3=(THW(IZ)/HAW(NK)+THA(IZ))*Y(IR,IZ,NK)
	U4=(U2*U3)/(RK(IKK)*DT)
	U5=U1/DT 
	RB=U4
	IF(U4.GT.U5) RB=U5
      RBIO(IR,IZ)=RBIO(IR,IZ)+RB*RK(IKK)
      END IF
 81   CONTINUE
      GO TO 10
      END IF
C
C  2ND-ORDER MONOD KINETICS MODEL
C
C   This code segment calculates the reaction rate for a dual Monod kinetics model.
C   The rate of oxygen utilization at a particular node will be need to be
C   calculated for each substrate component
C   (e.g., MTBE, benzene, "others") and then summed to obtain an overall
C   oxygen utilization rate.
C
C   If the user specifies dual Monod kinetics, and if the component
C   is not oxygen, calculate RBIO as follows:
C
C
      IF(IBIO(IK).EQ.5) THEN
	IF(IK.LT.NK) THEN
      IF(ICON(IK).EQ.4 .OR. ICON(IK).GE.6) THEN
      U1=Y(IR,IZ,IK)/HAW(IK)
      U2=Y(IR,IZ,NK)/HAW(NK)
      RBIO(IR,IZ)=THW(IZ)*RMAX(IK)*(U1/(U1+HSAT(IK)))*
     1(U2/(U2+HSAT(NK)))
      END IF
	ELSE
      RB=0.0
      DO 90 IKK=1,NK-1
      IF(ICON(IKK).EQ.4 .OR. ICON(IKK).GE.6) THEN
	U1=Y(IR,IZ,IKK)/HAW(IKK) 
      U2=Y(IR,IZ,NK)/HAW(NK)
      RBIO(IR,IZ)=THW(IZ)*RMAX(IKK)*(U1/(U1+HSAT(IKK)))*
     1(U2/(U2+HSAT(NK)))
      RB=RB+(RBIO(IR,IZ)*RK(IKK))
	END IF
 90   CONTINUE
      RBIO(IR,IZ)=RB
	END IF
      GO TO 10
      END IF
   10 RETURN
C
C--------------------------------
       ENTRY BIO2(IR,IZ)
C--------------------------------
C
C  THIS SUBROUTINE IS SET ASIDE FOR A USER-SPECIFIED REACTION RATE
C  MODEL.  THE USER MUST DEFINE THE VARIABLE RBIO(IR,IZ).  THE
C  VARIABLE WHICH REPRESENTS THE GAS-PHASE CONCENTRATION OF THE
C  CONSTITUENT IS GIVEN BY: Y0(IR,IZ,IK). RBIO REPRESENTS THE REACTION IN
C  THE AQUEOUS PHASE.  THE SINK (VAPOR-PHASE EQUIVALENT) IS DETERMINED IN
C  THE SUBROUTINE COEF.   OXYGEN IS THE ALWAYS THE LAST CONSTITUENT (e.g. 
C  Y0(IR,IZ,NK).
C
      RETURN
      END
C
C
C
C
      SUBROUTINE FATE
C
C   THIS SUBROUTINE INTEGRATES FLUXES ACROSS MODEL BOUNDARIES, SUCH AS
C   THE ATMOSPHERE, WATER TABLE, FAR BOUNDARY, AND SOURCE. THE
C   SUBROUTINE ALSO CALCULATES THE BIODEGRADATION MASS LOSSES AND
C   CONSTITUENT MASSES WITHIN THE MODEL DOMAIN.  THESE CALCULATIONS
C   SERVE AS A MASS BALANCE CHECK OF THE ALGORITHM.
C
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER(NHR=501,NHZ=501,NHL=5,NHK=8,NHW=3,I9=NHK+1,
     1NHRZ=NHR+NHZ+1)
      CHARACTER TITLE*70,FNAMEPOR*38,FNAMETHW*38,M*30,
     1FNAMETA*38,FNAMEBD*38,FNAMEICDAT*38,FNAMEMIF*38,FNAMECAL*38,
     2FNAMEOUT1*38,FNAMEOUT2*38,FNAMEOUT3*38,FNAMEOUT4*38,FNAMEOUT5*38,
     3FNAMEOUT6*38,FNAMEOUT7*38,FNAMEOUT8*38,FNAMEOUT9*38,FNAMEOUT10*38,
     4FNAMEOUT11*38,FNAMEOUT12*38,FNAMEOUT13*38,FNAMEOUT14*38,
     5FNAMEOUT15*38,FNAMEOUT16*38,FNAMEOUT17*38,FNAMEOUT18*38,
     6FNAMEOUT19*38,FNAMEOUT20*38,FNAMEOUT21*38,FNAMEOUT22*38,
     7FNAMEOUT23*38,FNAMEOUT24*38,
     8FNAMEBCDAT*38
      COMMON/DEP0/ Y0,Y1,Y2,Y3,DTY
      COMMON/DEP/ Y,TOT,RBIO
      COMMON/CHAR/ M,FNAMETA,FNAMEBD,FNAMECAL,FNAMEMIF,
     3FNAMEICDAT,FNAMEPOR,FNAMETHW,FNAMEBCDAT,TITLE,
     5FNAMEOUT1,FNAMEOUT2,FNAMEOUT3,FNAMEOUT4,FNAMEOUT5,
     6FNAMEOUT6,FNAMEOUT7,FNAMEOUT8,FNAMEOUT9,FNAMEOUT10,
     7FNAMEOUT11,FNAMEOUT12,FNAMEOUT13,FNAMEOUT14,FNAMEOUT15,FNAMEOUT16,
     8FNAMEOUT17,FNAMEOUT18,FNAMEOUT19,FNAMEOUT20,FNAMEOUT21,FNAMEOUT22,
     9FNAMEOUT23,FNAMEOUT24
      COMMON/XNRNZNK/ BR,BZ,CR,CZ,PP,DKA,SUMDK
      COMMON/XNRNZ/ PT
      COMMON/XNZNK/ FIRF,A
      COMMON/XNRNK/ FIZT,FIZW,FLX
      COMMON/XNKNK/ DKAB
      COMMON/XNR/ R,BC
      COMMON/XNZ/ Z,TA,TW,BD,POR,THA,THW
      COMMON/YTRP/YTRAP,ZTRAP
      COMMON/XNK/  XIK0,HAW,HSW,RK,TIFIP,TIFB,TIFT,TIRBIO,TIFRF,
     1TMASS,TMASS0,CRY,VK,WK,HWIK,XMASSB,XMASST,ATCONC,IBIO,ICON,
     2TMASSW,DV,DKW,VC,VM,BMLX,FLXDT,IOUTOPT,IREF,IFLX
     3,RCON,RLAMBDA,RMAX,HSAT,GWAT,FTOP,FBOT,FRIM,DFLXDT
      COMMON/XNL/AL,ALT,ZLAY,PORL,TAL,THWL,THAL,BDL
      COMMON/XNW/RVW,ZVW
      COMMON/ARRAY/ XINIT,UINIT,XPT,YPT,SLPZ,SLPR,BZZ,BRR,SXLM
      COMMON/ISC/NR,NZ,NL,NK,NT,IRIM,IRASP,IZLOW,IZHI,IZBAS,IRVW,IZVW,
     1IPROJ,NITER,IRNORM,IZNORM,ITER,ITER0,ISS,IRFP,IW,IL,IK,IKK,I,
     2NW,IZLAY,JK,IDAT,NDAT,ICOUNT,IOX,IIX,ICUT,IDT,IU2,IU3,IU4,KONS
      COMMON/INT/IFIL,IMOD,IMILQ,IOPT,INOPT,IBC0,IOUT,ICOMP,ISURF,
     1NDATIN,NDATCAL,NIPTS,ISNAP,ITIME,ICONX,IWARN,ICNTER,IDIM,
     2ISTRAT,IBDRY,INCHECK,IDISP,IWAT,IFLAG,IN,JN,IRMAX,IHSAT
      COMMON/XSC/DT,DR,DZ,SUM,AR1,AR2,AR3,AR4,AZ1,AZ2,ATOX,RHOIM,CSA,
     1TIME,VIMM,DARCY,THI0,EPS,ENORM,ATM,ZBAS,ZWAT,ZSURF,ZLOW,ZHI,
     2DT1,DT2,DTM,TRANS,TEND,YPR1,YPR2,SKIP,SKIP2,TEMP,RIM,RF,DTHI0
      COMMON/CONS/FLUX,UP,UW,D,DS,GAM,B,C,XL,PI,XFD,BP,DP,WAT,AIR,
     1XMM,DBIN,XM0,XB0,YNM,TMAX,DELT,HENRY,SWPC,BULK,XLL,TSNAP,TOR,
     1XB,ZOUT,GASBOT
      COMMON/RC1/C6,C7
      COMMON/RC2/C1,C2,C3,C4,C5
C
C
C****DIMENSION THE FOLLOWING (NR,NZ,NHK+1)
C
      DIMENSION Y0(NHR,NHZ,I9),DTY(NHR,NHZ,I9),PP(NHR,NHZ,I9)
     1,BR(NHR,NHZ,I9),BZ(NHR,NHZ,I9),CR(NHR,NHZ,I9),CZ(NHR,NHZ,I9)
     2,C1(NHR,NHZ,I9),C2(NHR,NHZ,I9),C3(NHR,NHZ,I9),C4(NHR,NHZ,I9)
     3,C5(NHR,NHZ,I9),DKA(NHR,NHZ,I9),SUMDK(NHR,NHZ,I9)
     4,Y(NHR,NHZ,I9),Y3(NHR,NHZ,I9)
C
C****DIMENSION THE FOLLOWING (NR,NZ)
      DIMENSION TOT(NHR,NHZ),PT(NHR,NHZ)
      DIMENSION C6(NHR,NHZ),C7(NHR,NHZ),RBIO(NHR,NHZ)
C
C******DIMENSION THE FOLLOWING AS (NZ,NHK+1)
C
      DIMENSION FIRF(NHZ,I9),A(NHZ,I9),Y1(NHZ,I9)
C
C******DIMENSION THE FOLLOWING AS (NR,NHK+1)
C
      DIMENSION FIZT(NHR,I9),FIZW(NHR,I9),FLX(NHR,I9),Y2(NHR,I9)
C
C******DIMENSION THE FOLLOWING AS (I9,I9)
C
      DIMENSION DKAB(I9,I9)
C
C******DIMENSION THE FOLLOWING AS (NR+NZ)
C
      DIMENSION YTRAP(NHRZ),ZTRAP(NHRZ)
C
C******DIMENSION THE FOLLOWING AS (NHZ)
C
      DIMENSION Z(NHZ),POR(NHZ),TA(NHZ),TW(NHZ),THA(NHZ)
     1,THW(NHZ),BD(NHZ)
C
C******DIMENSION THE FOLLOWING AS (NHR)
C
      DIMENSION R(NHR),BC(NHR)
C
C******DIMENSION THE FOLLOWING AS (NL)
C
      DIMENSION AL(NHL),ALT(NHL),ZLAY(NHL),IZLAY(NHL),
     1PORL(NHL),THWL(NHL),THAL(NHL),TAL(NHL),BDL(NHL)
C
C********DIMENSION THE FOLLOWING AS (NW)
C
      DIMENSION RVW(NHW),ZVW(NHW),IRVW(NHW),IZVW(NHW)
C
C********DIMENSION THE FOLLOWING (NHK+1)
C
      DIMENSION TIFIP(I9),TIFB(I9),TIFT(I9),TIRBIO(I9),TIFRF(I9),
     1TMASS0(I9),TMASSW(I9),TMASS(I9),XMASSB(I9),XMASST(I9),CRY(I9)
     2,FTOP(I9),GWAT(I9),FBOT(I9),FRIM(I9),FLXDT(I9),DFLXDT(I9)
C
C*******DIMENSION THE FOLLOWING (NHK+2)
C
      DIMENSION WK(I9),VC(I9),VM(I9),DV(I9),IBIO(I9),ICON(I9)
C
C*******DIMENSION THE FOLLOWING (NK)
C
      DIMENSION XIK0(NHK),BMLX(NHK),HWIK(NHK),HAW(NHK),RK(NHK)
     1,HSW(NHK),VK(NHK),ATCONC(NHK),DKW(NHK),IOUTOPT(NHK)
     2,IREF(NHK),IFLX(NHK),RLAMBDA(NHK),RCON(NHK)
     3,RMAX(NHK),HSAT(NHK)
C
C*******DIMENSION THE FOLLOWING
C
      DIMENSION SXLM(10000),XINIT(1001),UINIT(1001),XPT(1001),YPT(1001),
     1SLPZ(1001),SLPR(1001),BZZ(1001),BRR(1001)
C
C
C  FLUX CALCULATION ACROSS TIME-DEPENDENT CONCENTRATION
C  SOURCE BOUNDARY (IOPT=3)
C
	IL=1
      IF(ISTRAT.EQ.2) THEN
      DO 3 IZ=1,IZHI
      IF(Z(IZ).GE.Z(IZLAY(IL))) IL=IL+1
      IF(IL.GT.NL) IL=NL
 3    CONTINUE
      END IF
C     
C
      IND=0
      IF(I.EQ.1) TIFIP(IK)=0.0
      IF(IOPT.EQ.3) THEN
      IF(IZHI.EQ.NZ) THEN
      FLXDT(IK)=0.0
      TIFIP(IK)=0.0
      FTOP(IK)=0.0
      END IF
      U4=DKW(IK)*TW(IZHI)*THW(IZHI)/HAW(IK)
      U5=AL(IL)*ABS(DARCY/THW(IZHI))/HAW(IK)
      DO 5 IR=1,IRIM
      IF(IZHI.EQ.NZ) THEN
	U6=-DARCY*(Y0(IR,NZ,IK)+Y(IR,NZ,IK))*(0.5)/HAW(IK)
	U7=0.0
	ELSE
      U3=DKA(IR,IZHI,IK)*TA(IZHI)*THA(IZHI)
	U6=-DARCY*(Y0(IR,IZHI+1,IK)+Y(IR,IZHI+1,IK))*(0.5)/HAW(IK)
      U7=Y0(IR,IZHI+1,IK)-Y0(IR,IZHI,IK)
      U7=U7+Y(IR,IZHI+1,IK)-Y0(IR,IZHI,IK)
      U7=U7*(0.5)/DZ
	END IF
      YTRAP(IR)=(U6+(U3+U4+U5)*U7)*R(IR)
    5 CONTINUE
      CALL TRAP(IRIM,DR,XINT)
      U8=(DT*2.0*3.14159)*XINT
      TIFIP(IK)=TIFIP(IK)+U8
      FLXDT(IK)=U8
      FTOP(IK)=U8/(DT*(R(NR)**2)*3.14159)
C     
      IND=0
      IF(IZLOW.EQ.1) FBOT(IK)=0.0
      U4=-DKW(IK)*TW(IZLOW)*THW(IZLOW)/HAW(IK)
      U5=-AL(IL)*ABS(DARCY/THW(IZLOW))/HAW(IK)
      DO 6 IR=1,IRIM
      U3=-DKA(IR,IZLOW,IK)*TA(IZLOW)*THA(IZLOW)
      U6=DARCY*Y0(IR,IZLOW,IK)/HAW(IK)
      IF(IZLOW.EQ.1) GO TO 7
	U7=Y0(IR,IZLOW,IK)-Y0(IR,IZLOW-1,IK)
      U7=U7+Y0(IR,IZLOW,IK)-Y(IR,IZLOW-1,IK)
      U7=U7*(0.5)/DZ
    7 IF(IZLOW.EQ.1) U7=0.0
      YTRAP(IR)=(U6+(U3+U4+U5)*U7)*R(IR)
    6 CONTINUE
      CALL TRAP(IRIM,DR,XINT)
      U8=(DT*2.0*3.14159)*XINT
      TIFIP(IK)=TIFIP(IK)+U8
      FLXDT(IK)=FLXDT(IK)+U8
      FBOT(IK)=U8/(DT*(R(NR)**2)*3.14159)
C   
      IZZ=0
      IND=0
      IF(IRIM.EQ.NR) GO TO 8
      DO 10 IZ=IZLOW,IZHI
      IZZ=IZZ+1
      U3=DKA(IRIM,IZ,IK)*TA(IZ)*THA(IZ)
      U4=DKW(IK)*TW(IZ)*THW(IZ)/HAW(IK)
      U5=AL(IL)*ABS(DARCY/THW(IZ))/HAW(IK)
      U7=Y0(IRIM+1,IZ,IK)-Y0(IRIM,IZ,IK)
      U7=U7+Y(IRIM+1,IZ,IK)-Y0(IRIM,IZ,IK)
      U7=U7*(0.5)/DR
      YTRAP(IZZ)=(U3+U4+U5)*U7
   10 CONTINUE
      CALL TRAP(IZHI-IZLOW+1,DZ,XINT)
      U8=(DT*2.0*3.14159*R(IRIM))*XINT
      FLXDT(IK)=FLXDT(IK)+U8
      FRIM(IK)=U8/(DT*2.0*3.14159*R(IRIM)*(Z(IZHI)-Z(IZLOW)))
    8 CONTINUE
      END IF
C     
C
C 
C  FLUX CALCULATION ACROSS CONSTANT-RADIAL FLUX SOURCE (IOPT=4)
C
      IF(IOPT.EQ.4) THEN
      U8=-FLX(1,IK)*DT
      FLXDT(IK)=U8
      U8=(DT*2*3.14159*RIM*(Z(IZHI)-Z(IZLOW)))*FLX(1,IK)
      TIFIP(IK)=TIFIP(IK)+U8
      END IF
C
C
C  FLUX CALCULATION ACROSS WATER TABLE FOR SOURCES LOCATED
C  ABOVE LOWER BOUNDARY (e.g., IOPT=3,4,5)
C
      IF(IOPT.GE.3) THEN
      IF(I.EQ.1) TIFB(IK)=0.0
      U4=-DKW(IK)*TW(1)*THW(1)/HAW(IK)
      U5=-AL(1)*ABS(DARCY/THW(1))/HAW(IK)
      DO 15 IR=1,NR
      IF(I.EQ.1) FIZW(IR,IK)=0.0
      U3=-DKA(IR,1,IK)*TA(1)*THA(1)
      U6=DARCY*Y0(IR,1,IK)/HAW(IK)
      U7=Y0(IR,2,IK)-Y0(IR,1,IK)
      U7=U7/DZ
      U8=U6+(U3+U4+U5)*U7
      FIZW(IR,IK)=FIZW(IR,IK)-U8*DT
      YTRAP(IR)=-U8*R(IR)
   15 CONTINUE
      CALL TRAP(NR,DR,XINT)
      U8=(DT*2.0*3.14159)*XINT
      TIFB(IK)=TIFB(IK)+U8
      XMASSB(IK)=U8/DT
      GO TO 71
      END IF
C
C  FLUX CALCULATION ACROSS CONSTANT-FLUX SOURCE BOUNDARY
C  LOCATED AT LOWER BOUNDARY (IOPT=1)
C
      IF(IOPT.EQ.1) THEN
      U8=0.0
      DO 556 IR=1,NR
      IF(IR.EQ.1) THEN
	U11=-FLX(IR,IK)*3.14159*R(1)
	ELSE
	U2=3.14159*(R(IR)**2)
      U3=3.14159*(R(IR-1)**2)
      U11=(-FLX(IR,IK)*U2)-(-FLX(IR,IK)*U3)
      END IF
	U8=U8+U11
 556  CONTINUE
      U8=U8*DT
      TIFIP(IK)=TIFIP(IK)+U8
      FLXDT(IK)=U8
      GO TO 71
      END IF
C
C
C  FLUX CALCULATION ACROSS CONSTANT-CONCENTRATION SOURCE LOCATED
C  AT LOWER BOUNDARY (IOPT=2)
C
      IF(IOPT.EQ.2) THEN
      DO 115 IR=1,IRIM
      U1=-DKA(IR,IZHI,IK)*TA(IZHI)*THA(IZHI)
      U2=-DKW(IK)*TW(IZHI)*THW(IZHI)/HAW(IK)
      U3=-AL(1)*ABS(DARCY/THW(IZHI))/HAW(IK)
      U11=-DKA(IR,NZ,IK)*TA(NZ)*THA(NZ)
      U12=-DKW(IK)*TW(NZ)*THW(NZ)/HAW(IK)
      U13=-AL(NL)*ABS(DARCY/THW(NZ))/HAW(IK)
      U4=DARCY*(Y0(IR,IZHI+1,IK)+Y(IR,IZHI+1,IK))*(0.5)/HAW(IK)
      U5=Y0(IR,IZHI+1,IK)-Y0(IR,IZHI,IK)
      U5=U5+Y(IR,IZHI+1,IK)-Y0(IR,IZHI,IK)
      U5=U5*(0.5)/DZ
      YTRAP(IR)=(U4+(U1+U2+U3)*U5)*R(IR)
 115  CONTINUE
      CALL TRAP(IRIM,DR,XINT)
      U8=(DT*2*3.14159)*XINT
      TIFIP(IK)=TIFIP(IK)+U8
      FLXDT(IK)=U8
      FTOP(IK)=U8/(DT*(R(NR)**2)*3.14159)
      END IF
C
C
 71   CONTINUE
C
C FLUX CALCUATION ACROSS UPPER BOUNDARY (e.g., LAND SURFACE)
C
      IF(I.EQ.1) TIFT(IK)=0.0
      IF(I.EQ.1 .OR. IZHI.EQ.NZ) THEN
      XMASST(IK)=0.0
      DO 27 IR=1,NR
      FIZT(IR,IK)=0.0
   27 CONTINUE
      ELSE
      U4=-DKW(IK)*TW(NZ)*THW(NZ)/HAW(IK)
      U5=-AL(NL)*ABS(DARCY/THW(NZ))/HAW(IK)
      DO 17 IR=1,NR
      IF(I.EQ.1) FIZT(IR,IK)=0.0
      U3=-DKA(IR,NZ,IK)*TA(NZ)*THA(NZ)
      U6=DARCY*Y0(IR,NZ,IK)/HAW(IK)
      U7=Y0(IR,NZ,IK)-Y0(IR,NZ-1,IK)
      U7=U7/DZ
      U8=U6+(U3+U4+U5)*U7
      FIZT(IR,IK)=FIZT(IR,IK)+U8*DT
      YTRAP(IR)=U8*R(IR)
   17 CONTINUE
      CALL TRAP(NR,DR,XINT)
      U8=(DT*2.0*3.14159)*XINT
      TIFT(IK)=TIFT(IK)+U8
      XMASST(IK)=U8/DT
      END IF
C
C  FLUX CALCULATION ACROSS FAR BOUNDARY
C
      IF(I.EQ.1) TIFRF(IK)=0.0
      IL=1
      IF(IOPT.EQ.3) THEN
      DO 20 IZ=1,NZ
      IF(Z(IZ).GE.Z(IZLAY(IL))) IL=IL+1
      IF(IL.GT.NL) IL=NL
      IF(I.EQ.1) FIRF(IZ,IK)=0.0
      U3=-DKA(NR,IZ,IK)*TA(IZ)*THA(IZ)
      U4=-DKW(IK)*TW(IZ)*THW(IZ)/HAW(IK)
      U5=-ALT(IL)*ABS(DARCY/THW(IZ))/HAW(IK)
      U7=Y0(NR,IZ,IK)-Y0(NR-1,IZ,IK)
      U7=U7/DR
      U8=(U3+U4+U5)*U7
      FIRF(IZ,IK)=FIRF(IZ,IK) +U8*DT
      YTRAP(IZ)=U8
   20 CONTINUE
      ELSE
      DO 23 IZ=2,NZ
      IF(Z(IZ).GE.Z(IZLAY(IL))) IL=IL+1
      IF(IL.GT.NL) IL=NL
      IF(I.EQ.1) FIRF(IZ,IK)=0.0
      U3=-DKA(NR,IZ,IK)*TA(IZ)*THA(IZ)
      U4=-DKW(IK)*TW(IZ)*THW(IZ)/HAW(IK)
      U5=-ALT(IL)*ABS(DARCY/THW(IZ))/HAW(IK)
      U7=Y0(NR,IZ,IK)-Y0(NR-1,IZ,IK)
      U7=U7/DR
      U8=(U3+U4+U5)*U7
      FIRF(IZ,IK)=FIRF(IZ,IK) +U8*DT
      YTRAP(IZ)=U8
   23 CONTINUE
      END IF
      CALL TRAP(NZ,DZ,XINT)
      U8=(DT*2.0*3.14159*R(NR))*XINT
      TIFRF(IK)=TIFRF(IK)+U8
C
C  INTEGRATE OVER REGION TO GET TMASS TMASSW TIRBIO
C
      IF(I.EQ.1) TIRBIO(IK)=0.0
      H1=HAW(IK)
      H2=HSW(IK)
      IF(IFLAG.EQ.0) GO TO 28
      IF(IDIM.EQ.1) GO TO 55
      DO 25 IZ=2,NZ-1
      DO 24 IR=1,NR-1
      YTRAP(IR)=RBIO(IR+1,IZ)*R(IR+1)
   24 CONTINUE
      CALL TRAP(NR-1,DR,XINT)
      ZTRAP(IZ-1)=XINT
   25 CONTINUE
   55 DO 26 IZ=1,NZ-1
      IF(IDIM.EQ.1) THEN
	YTRAP(IZ)=RBIO(2,IZ)
	ELSE
	YTRAP(IZ)=ZTRAP(IZ)
	END IF
   26 CONTINUE
      CALL TRAP(NZ-1,DZ,XINT)
      IF(IDIM.EQ.1) THEN
	TIRBIO(IK)=TIRBIO(IK) + XINT*CSA*DT
	ELSE
	TIRBIO(IK)=TIRBIO(IK) + XINT*2.0*3.14159*DT
	END IF
   28 CONTINUE
C
C
C
      IF(IDIM.EQ.1) GO TO 37
      DO 35 IZ=2,NZ-1
      DO 34 IR=1,NR-2
      YTRAP(IR)=A(IZ,IK)*Y0(IR+1,IZ,IK)*R(IR+1)
   34 CONTINUE
      CALL TRAP(NR-2,DR,XINT)
      ZTRAP(IZ-1)=XINT
   35 CONTINUE
   37 DO 36 IZ=1,NZ-2
      IF(IDIM.EQ.1) THEN
      YTRAP(IZ)=A(IZ,IK)*Y0(2,IZ,IK)
      ELSE
      YTRAP(IZ)=ZTRAP(IZ)
      END IF
   36 CONTINUE
      CALL TRAP(NZ-2,DZ,XINT)
      IF(IDIM.EQ.1) THEN
      TMASS(IK)=XINT*CSA
      ELSE
      TMASS(IK)=XINT*2.0*3.14159
      END IF
      IF(IOPT.NE.3) TMASS0(IK)=0.0
      IF(I.EQ.1) TMASS0(IK)=TMASS0(IK)+TMASS(IK)
      IF(IDIM.EQ.1) GO TO 47
      DO 45 IZ=2,NZ-1
      DO 44 IR=1,NR-2
      YTRAP(IR)=THW(IZ)*Y0(IR+1,IZ,IK)*R(IR+1)/H1
   44 CONTINUE
      CALL TRAP(NR-2,DR,XINT)
      ZTRAP(IZ-1)=XINT
   45 CONTINUE
   47 DO 46 IZ=1,NZ-2
      IF(IDIM.EQ.1) THEN
      YTRAP(IZ)=THW(IZ)*Y0(2,IZ,IK)/H1
      ELSE
      YTRAP(IZ)=ZTRAP(IZ)
      END IF
   46 CONTINUE
      CALL TRAP(NZ-2,DZ,XINT)
      IF(IDIM.EQ.1) THEN
      TMASSW(IK)=XINT*CSA
      ELSE
      TMASSW(IK)=XINT*2.0*3.14159
      END IF
C
C
      IF(I.EQ.1 .OR. IOPT.NE.3) GO TO 988
C
      IF(IBIO(IK).GT.3 .AND. IOX.EQ.1) THEN
      IF(IK.LT.NK) U1=VIMM*THI0*XIK0(IK)+
     1TMASS(IK)+TIFT(IK)+TIFRF(IK)+TIFB(IK)+TIRBIO(IK)
      IF(IK.EQ.NK) U1=TIFIP(IK)+TMASS(IK)+TIFRF(IK)+
     1TIFB(IK)+TIRBIO(IK)+TIFT(IK)
      ELSE
      IF(IK.LE.NK) U1=VIMM*THI0*XIK0(IK)+
     1TMASS(IK)+TIFT(IK)+TIFRF(IK)+TIFB(IK)+TIRBIO(IK)
      END IF
      CRY(IK)=U1/TMASS0(IK)
  988 IF(I.EQ.1 .OR. IOPT.NE.3) CRY(IK)=1.0
C
      IF(IOPT.EQ.3) THEN
      IF(IBIO(IK).GT.3 .AND. IOX.EQ.1) THEN
      IF(IK.LT.NK) THEN
      U1=THI0*VIMM*XIK0(IK)
      ELSE
      U1=TIFIP(IK)
      END IF
      ELSE
      U1=THI0*VIMM*XIK0(IK)
      END IF
      ELSE
      U1=TIFIP(IK)
      END IF
C     
C
      IF(I.EQ.1) THEN
      IF(NK.GE.1) OPEN(UNIT=30,FILE='FATE.1')
      IF(NK.GE.2) OPEN(UNIT=31,FILE='FATE.2')
      IF(NK.GE.3) OPEN(UNIT=32,FILE='FATE.3')
      IF(NK.GE.4) OPEN(UNIT=33,FILE='FATE.4')
      IF(NK.GE.5) OPEN(UNIT=34,FILE='FATE.5')
      IF(NK.GE.6) OPEN(UNIT=35,FILE='FATE.6')
      IF(NK.GE.7) OPEN(UNIT=36,FILE='FATE.7')
      IF(NK.GE.8) OPEN(UNIT=37,FILE='FATE.8')
C
      IF(IOPT.NE.3) WRITE(IU3,210) IK
	IF(IOPT.EQ.3) WRITE(IU3,211) IK
      END IF
C 
C
	IF(I.EQ.1 .AND. IOPT.NE.3) WRITE(IU3,220) TIME/3600.,U1,TMASS(IK)
     1,TIFT(IK),TIFB(IK),TIFRF(IK),TIRBIO(IK)
      IF(I.EQ.1 .AND. IOPT.EQ.3) WRITE(IU3,220) TIME/3600.,U1,TMASS(IK)
     1,TIFT(IK),TIFB(IK),TIFRF(IK),TIRBIO(IK),THI0,XIK0(IK),CRY(IK) 
	IF(IOUT.EQ.1 .AND. SKIP2.LT.YPR2) GO TO 96
      IF(IOPT.NE.3) WRITE(IU3,220) TIME/3600.,U1,TMASS(IK),TIFT(IK),
     1TIFB(IK),TIFRF(IK),TIRBIO(IK)
      IF(IOPT.EQ.3) WRITE(IU3,220) TIME/3600.,U1,TMASS(IK),TIFT(IK),
     1TIFB(IK),TIFRF(IK),TIRBIO(IK),THI0,XIK0(IK),CRY(IK)
C
      IF(IFLX(IK).EQ.1) THEN
      IF(IOPT.EQ.1) WRITE(IU2,419) TIME/3600,XMASST(IK)/((R(NR)**2)*3.14
     1159),FLXDT(IK)
      IF(IOPT.EQ.2) WRITE(IU2,419) TIME/3600,XMASST(IK)/((R(NR)**2)*3.14
     1159),FTOP(IK)
      IF(IOPT.GE.3) THEN
      IF(IDIM.EQ.1 .AND. ZLOW.GT.ZWAT) THEN
      WRITE(IU2,420) TIME/3600,XMASST(IK)/((R(NR)**2)*3.14159),XMASSB(IK
     1)/((R(NR)**2)*(-1*3.14159)),FTOP(IK),FBOT(IK)
      ELSE
      IF(IOPT.EQ.3) WRITE(IU2,420) TIME/3600,XMASST(IK)/((R(NR)**2)*3.14
     1159),XMASSB(IK)/((R(NR)**2)*(-1*3.14159)),FTOP(IK),FBOT(IK)
      IF(IOPT.GE.4) WRITE(IU2,421) TIME/3600,XMASST(IK)/((R(NR)**2)*3.14
     1159),XMASSB(IK)/((R(NR)**2)*(-1*3.14159))
      END IF
      END IF
      END IF
C
      IF(IK.EQ.NK) SKIP2=0.0
      IF(I.EQ.1) SKIP2=DT*1
 96   CONTINUE
C
  210 FORMAT('CONSTITUENT = ',I3/'   TIME (HR)    SOURCE   INTERIOR  AT
     1MOSPHERE  AQUIFER    FAR BOUND.    BIO'/)
  211 FORMAT('CONSTITUENT = ',I3/'   TIME (HR)    SOURCE   INTERIOR  AT
     1MOSPHERE  AQUIFER    FAR BOUND.    BIO        THI0       XIK0    M
     2ASS CHECK'/)
  220 FORMAT(1X,10E11.4)
  280 FORMAT(1X,I5,4E13.4)
  419 FORMAT(1X,F10.2,2X,E13.4,2X,E13.4,2X,E13.4)
  420 FORMAT(1X,F10.2,2X,E13.4,2X,E13.4,2X,E13.4,2X,E13.4)
  421 FORMAT(1X,F10.2,2X,E13.4,2X,E13.4)
C
      RETURN
      END
C
C
C
      SUBROUTINE TRAP(NTRAP,DZZ,XINT)
C
C  THIS SUBROUTINE IS USED TO NUMERICALLY INTEGRATE MASS FLUXES
C  AND CONCENTRATIONS ACCORDING TO THE TRAPEZOIDAL RULE

      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER(NHR=501,NHZ=501,NHL=5,NHK=8,NHW=3,I9=NHK+1,
     1NHRZ=NHR+NHZ+1)
      CHARACTER TITLE*70,FNAMEPOR*38,FNAMETHW*38,M*30,
     1FNAMETA*38,FNAMEBD*38,FNAMEICDAT*38,FNAMEMIF*38,FNAMECAL*38,
     2FNAMEOUT1*38,FNAMEOUT2*38,FNAMEOUT3*38,FNAMEOUT4*38,FNAMEOUT5*38,
     3FNAMEOUT6*38,FNAMEOUT7*38,FNAMEOUT8*38,FNAMEOUT9*38,FNAMEOUT10*38,
     4FNAMEOUT11*38,FNAMEOUT12*38,FNAMEOUT13*38,FNAMEOUT14*38,
     5FNAMEOUT15*38,FNAMEOUT16*38,FNAMEOUT17*38,FNAMEOUT18*38,
     6FNAMEOUT19*38,FNAMEOUT20*38,FNAMEOUT21*38,FNAMEOUT22*38,
     7FNAMEOUT23*38,FNAMEOUT24*38,
     8FNAMEBCDAT*38
      COMMON/DEP0/ Y0,Y1,Y2,Y3,DTY
      COMMON/DEP/  Y,TOT,RBIO
      COMMON/CHAR/ M,FNAMETA,FNAMEBD,FNAMECAL,FNAMEMIF,
     3FNAMEICDAT,FNAMEPOR,FNAMETHW,FNAMEBCDAT,TITLE,
     5FNAMEOUT1,FNAMEOUT2,FNAMEOUT3,FNAMEOUT4,FNAMEOUT5,
     6FNAMEOUT6,FNAMEOUT7,FNAMEOUT8,FNAMEOUT9,FNAMEOUT10,
     7FNAMEOUT11,FNAMEOUT12,FNAMEOUT13,FNAMEOUT14,FNAMEOUT15,FNAMEOUT16,
     8FNAMEOUT17,FNAMEOUT18,FNAMEOUT19,FNAMEOUT20,FNAMEOUT21,FNAMEOUT22,
     9FNAMEOUT23,FNAMEOUT24
      COMMON/XNRNZNK/ BR,BZ,CR,CZ,PP,DKA,SUMDK
      COMMON/XNRNZ/ PT
      COMMON/XNZNK/ FIRF,A
      COMMON/XNRNK/ FIZT,FIZW,FLX
      COMMON/XNKNK/ DKAB
      COMMON/XNR/ R,BC
      COMMON/XNZ/ Z,TA,TW,BD,POR,THA,THW
      COMMON/YTRP/ YTRAP,ZTRAP
      COMMON/XNK/  XIK0,HAW,HSW,RK,TIFIP,TIFB,TIFT,TIRBIO,TIFRF,
     1TMASS,TMASS0,CRY,VK,WK,HWIK,XMASSB,XMASST,ATCONC,IBIO,ICON,
     2TMASSW,DV,DKW,VC,VM,BMLX,FLXDT,IOUTOPT,IREF,IFLX
     3,RCON,RLAMBDA,RMAX,HSAT,GWAT,FTOP,FBOT,FRIM,DFLXDT
      COMMON/XNL/AL,ALT,ZLAY,PORL,TAL,THWL,THAL,BDL
      COMMON/XNW/RVW,ZVW
      COMMON/ARRAY/ XINIT,UINIT,XPT,YPT,SLPZ,SLPR,BZZ,BRR,SXLM
      COMMON/ISC/NR,NZ,NL,NK,NT,IRIM,IRASP,IZLOW,IZHI,IZBAS,IRVW,IZVW,
     1IPROJ,NITER,IRNORM,IZNORM,ITER,ITER0,ISS,IRFP,IW,IL,IK,IKK,I,
     2NW,IZLAY,JK,IDAT,NDAT,ICOUNT,IOX,IIX,ICUT,IDT,IU2,IU3,IU4,KONS
      COMMON/INT/IFIL,IMOD,IMILQ,IOPT,INOPT,IBC0,IOUT,ICOMP,ISURF,
     1NDATIN,NDATCAL,NIPTS,ISNAP,ITIME,ICONX,IWARN,ICNTER,IDIM,
     2ISTRAT,IBDRY,INCHECK,IDISP,IWAT,IFLAG,IN,JN,IRMAX,IHSAT
      COMMON/XSC/DT,DR,DZ,SUM,AR1,AR2,AR3,AR4,AZ1,AZ2,ATOX,RHOIM,CSA,
     1TIME,VIMM,DARCY,THI0,EPS,ENORM,ATM,ZBAS,ZWAT,ZSURF,ZLOW,ZHI,
     2DT1,DT2,DTM,TRANS,TEND,YPR1,YPR2,SKIP,SKIP2,TEMP,RIM,RF,DTHI0
      COMMON/CONS/FLUX,UP,UW,D,DS,GAM,B,C,XL,PI,XFD,BP,DP,WAT,AIR,
     1XMM,DBIN,XM0,XB0,YNM,TMAX,DELT,HENRY,SWPC,BULK,XLL,TSNAP,TOR,
     2XB,ZOUT,GASBOT
      COMMON/RC1/ C6,C7
      COMMON/RC2/C1,C2,C3,C4,C5
C
C
C
C****DIMENSION THE FOLLOWING (NR,NZ,NHK+1)
C
      DIMENSION Y0(NHR,NHZ,I9),DTY(NHR,NHZ,I9),PP(NHR,NHZ,I9)
     1,BR(NHR,NHZ,I9),BZ(NHR,NHZ,I9),CR(NHR,NHZ,I9),CZ(NHR,NHZ,I9)
     2,C1(NHR,NHZ,I9),C2(NHR,NHZ,I9),C3(NHR,NHZ,I9),C4(NHR,NHZ,I9)
     3,C5(NHR,NHZ,I9),DKA(NHR,NHZ,I9),SUMDK(NHR,NHZ,I9)
     4,Y(NHR,NHZ,I9),Y3(NHR,NHZ,I9)
C
C****DIMENSION THE FOLLOWING (NR,NZ)
      DIMENSION TOT(NHR,NHZ),PT(NHR,NHZ)
      DIMENSION C6(NHR,NHZ),C7(NHR,NHZ),RBIO(NHR,NHZ)
C
C******DIMENSION THE FOLLOWING AS (NZ,NHK+1)
C
      DIMENSION FIRF(NHZ,I9),A(NHZ,I9),Y1(NHZ,I9)
C
C******DIMENSION THE FOLLOWING AS (NR,NHK+1)
C
      DIMENSION FIZT(NHR,I9),FIZW(NHR,I9),FLX(NHR,I9),Y2(NHR,I9)
C
C******DIMENSION THE FOLLOWING AS (I9,I9)
C
      DIMENSION DKAB(I9,I9)
C
C******DIMENSION THE FOLLOWING AS (NR+NZ)
C
      DIMENSION YTRAP(NHRZ),ZTRAP(NHRZ)
C
C******DIMENSION THE FOLLOWING AS (NHZ)
C
      DIMENSION Z(NHZ),POR(NHZ),TA(NHZ),TW(NHZ),THA(NHZ)
     1,THW(NHZ),BD(NHZ)
C
C******DIMENSION THE FOLLOWING AS (NHR)
C
      DIMENSION R(NHR),BC(NHR)
C
C******DIMENSION THE FOLLOWING AS (NL)
C
      DIMENSION AL(NHL),ALT(NHL),ZLAY(NHL),IZLAY(NHL),
     1PORL(NHL),THWL(NHL),THAL(NHL),TAL(NHL),BDL(NHL)
C
C********DIMENSION THE FOLLOWING AS (NW)
C
      DIMENSION RVW(NHW),ZVW(NHW),IRVW(NHW),IZVW(NHW)
C
C********DIMENSION THE FOLLOWING (NHK+1)
C
      DIMENSION TIFIP(I9),TIFB(I9),TIFT(I9),TIRBIO(I9),TIFRF(I9),
     1TMASS0(I9),TMASSW(I9),TMASS(I9),XMASSB(I9),XMASST(I9),CRY(I9)
     2,FTOP(I9),GWAT(I9),FBOT(I9),FRIM(I9),FLXDT(I9),DFLXDT(I9)
C
C*******DIMENSION THE FOLLOWING (NHK+2)
C
      DIMENSION WK(I9),VC(I9),VM(I9),DV(I9),IBIO(I9),ICON(I9)
C
C*******DIMENSION THE FOLLOWING (NK)
C
      DIMENSION XIK0(NHK),BMLX(NHK),HWIK(NHK),HAW(NHK),RK(NHK)
     1,HSW(NHK),VK(NHK),ATCONC(NHK),DKW(NHK),IOUTOPT(NHK)
     2,IREF(NHK),IFLX(NHK),RLAMBDA(NHK),RCON(NHK)
     3,RMAX(NHK),HSAT(NHK)
C
C*******DIMENSION THE FOLLOWING
C
      DIMENSION SXLM(10000),XINIT(1001),UINIT(1001),XPT(1001),YPT(1001),
     1SLPZ(1001),SLPR(1001),BZZ(1001),BRR(1001)
C
C
C
      XINT=YTRAP(1)+YTRAP(NTRAP)
      DO 1 JX=2,NTRAP-1
      XINT=XINT+2.0*YTRAP(JX)
    1 CONTINUE
      XINT=(DZZ/2.0)*XINT
      RETURN
      END
C
C
C
      SUBROUTINE OUTPUT
C
C  THIS SUBROUTINE WRITES DATA TO ALL OUTPUT FILES
C

      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER(NHR=501,NHZ=501,NHL=5,NHK=8,NHW=3,I9=NHK+1,
     1NHRZ=NHR+NHZ+1)
      CHARACTER TITLE*70,FNAMEPOR*38,FNAMETHW*38,M*30,
     1FNAMETA*38,FNAMEBD*38,FNAMEICDAT*38,FNAMEMIF*38,FNAMECAL*38,
     2FNAMEOUT1*38,FNAMEOUT2*38,FNAMEOUT3*38,FNAMEOUT4*38,FNAMEOUT5*38,
     3FNAMEOUT6*38,FNAMEOUT7*38,FNAMEOUT8*38,FNAMEOUT9*38,FNAMEOUT10*38,
     4FNAMEOUT11*38,FNAMEOUT12*38,FNAMEOUT13*38,FNAMEOUT14*38,
     5FNAMEOUT15*38,FNAMEOUT16*38,FNAMEOUT17*38,FNAMEOUT18*38,
     6FNAMEOUT19*38,FNAMEOUT20*38,FNAMEOUT21*38,FNAMEOUT22*38,
     7FNAMEOUT23*38,FNAMEOUT24*38,
     8FNAMEBCDAT*38
      COMMON/DEP0/ Y0,Y1,Y2,Y3,DTY
      COMMON/DEP/  Y,TOT,RBIO
      COMMON/CHAR/ M,FNAMETA,FNAMEBD,FNAMECAL,FNAMEMIF,
     3FNAMEICDAT,FNAMEPOR,FNAMETHW,FNAMEBCDAT,TITLE,
     5FNAMEOUT1,FNAMEOUT2,FNAMEOUT3,FNAMEOUT4,FNAMEOUT5,
     6FNAMEOUT6,FNAMEOUT7,FNAMEOUT8,FNAMEOUT9,FNAMEOUT10,
     7FNAMEOUT11,FNAMEOUT12,FNAMEOUT13,FNAMEOUT14,FNAMEOUT15,FNAMEOUT16,
     8FNAMEOUT17,FNAMEOUT18,FNAMEOUT19,FNAMEOUT20,FNAMEOUT21,FNAMEOUT22,
     9FNAMEOUT23,FNAMEOUT24
      COMMON/XNRNZNK/ BR,BZ,CR,CZ,PP,DKA,SUMDK
      COMMON/XNRNZ/ PT
      COMMON/XNZNK/ FIRF,A
      COMMON/XNRNK/ FIZT,FIZW,FLX
      COMMON/XNKNK/ DKAB
      COMMON/XNR/ R,BC
      COMMON/XNZ/ Z,TA,TW,BD,POR,THA,THW
      COMMON/YTRP/ YTRAP,ZTRAP
      COMMON/XNK/  XIK0,HAW,HSW,RK,TIFIP,TIFB,TIFT,TIRBIO,TIFRF,
     1TMASS,TMASS0,CRY,VK,WK,HWIK,XMASSB,XMASST,ATCONC,IBIO,ICON,
     2TMASSW,DV,DKW,VC,VM,BMLX,FLXDT,IOUTOPT,IREF,IFLX
     3,RCON,RLAMBDA,RMAX,HSAT,GWAT,FTOP,FBOT,FRIM,DFLXDT
      COMMON/XNL/AL,ALT,ZLAY,PORL,TAL,THWL,THAL,BDL
      COMMON/XNW/RVW,ZVW
      COMMON/ARRAY/ XINIT,UINIT,XPT,YPT,SLPZ,SLPR,BZZ,BRR,SXLM
      COMMON/ISC/NR,NZ,NL,NK,NT,IRIM,IRASP,IZLOW,IZHI,IZBAS,IRVW,IZVW,
     1IPROJ,NITER,IRNORM,IZNORM,ITER,ITER0,ISS,IRFP,IW,IL,IK,IKK,I,
     2NW,IZLAY,JK,IDAT,NDAT,ICOUNT,IOX,IIX,ICUT,IDT,IU2,IU3,IU4,KONS
      COMMON/INT/IFIL,IMOD,IMILQ,IOPT,INOPT,IBC0,IOUT,ICOMP,ISURF,
     1NDATIN,NDATCAL,NIPTS,ISNAP,ITIME,ICONX,IWARN,ICNTER,IDIM,
     2ISTRAT,IBDRY,INCHECK,IDISP,IWAT,IFLAG,IN,JN,IRMAX,IHSAT
      COMMON/XSC/DT,DR,DZ,SUM,AR1,AR2,AR3,AR4,AZ1,AZ2,ATOX,RHOIM,CSA,
     1TIME,VIMM,DARCY,THI0,EPS,ENORM,ATM,ZBAS,ZWAT,ZSURF,ZLOW,ZHI,
     2DT1,DT2,DTM,TRANS,TEND,YPR1,YPR2,SKIP,SKIP2,TEMP,RIM,RF,DTHI0
      COMMON/CONS/FLUX,UP,UW,D,DS,GAM,B,C,XL,PI,XFD,BP,DP,WAT,AIR,
     1XMM,DBIN,XM0,XB0,YNM,TMAX,DELT,HENRY,SWPC,BULK,XLL,TSNAP,TOR,
     2XB,ZOUT,GASBOT
      COMMON/RC1/ C6,C7
      COMMON/RC2/C1,C2,C3,C4,C5
C
C
C
C****DIMENSION THE FOLLOWING (NR,NZ,NHK+1)
C
      DIMENSION Y0(NHR,NHZ,I9),DTY(NHR,NHZ,I9),PP(NHR,NHZ,I9)
     1,BR(NHR,NHZ,I9),BZ(NHR,NHZ,I9),CR(NHR,NHZ,I9),CZ(NHR,NHZ,I9)
     2,C1(NHR,NHZ,I9),C2(NHR,NHZ,I9),C3(NHR,NHZ,I9),C4(NHR,NHZ,I9)
     3,C5(NHR,NHZ,I9),DKA(NHR,NHZ,I9),SUMDK(NHR,NHZ,I9)
     4,Y(NHR,NHZ,I9),Y3(NHR,NHZ,I9)
C
C****DIMENSION THE FOLLOWING (NR,NZ)
      DIMENSION TOT(NHR,NHZ),PT(NHR,NHZ)
      DIMENSION C6(NHR,NHZ),C7(NHR,NHZ),RBIO(NHR,NHZ)
C
C******DIMENSION THE FOLLOWING AS (NZ,NHK+1)
C
      DIMENSION FIRF(NHZ,I9),A(NHZ,I9),Y1(NHZ,I9)
C
C******DIMENSION THE FOLLOWING AS (NR,NHK+1)
C
      DIMENSION FIZT(NHR,I9),FIZW(NHR,I9),FLX(NHR,I9),Y2(NHR,I9)
C
C******DIMENSION THE FOLLOWING AS (I9,I9)
C
      DIMENSION DKAB(I9,I9)
C
C******DIMENSION THE FOLLOWING AS (NR+NZ)
C
      DIMENSION YTRAP(NHRZ),ZTRAP(NHRZ)
C
C******DIMENSION THE FOLLOWING AS (NHZ)
C
      DIMENSION Z(NHZ),POR(NHZ),TA(NHZ),TW(NHZ),THA(NHZ)
     1,THW(NHZ),BD(NHZ)
C
C******DIMENSION THE FOLLOWING AS (NHR)
C
      DIMENSION R(NHR),BC(NHR)
C
C******DIMENSION THE FOLLOWING AS (NL)
C
      DIMENSION AL(NHL),ALT(NHL),ZLAY(NHL),IZLAY(NHL),
     1PORL(NHL),THWL(NHL),THAL(NHL),TAL(NHL),BDL(NHL)
C
C********DIMENSION THE FOLLOWING AS (NW)
C
      DIMENSION RVW(NHW),ZVW(NHW),IRVW(NHW),IZVW(NHW)
C
C********DIMENSION THE FOLLOWING (NHK+1)
C
      DIMENSION TIFIP(I9),TIFB(I9),TIFT(I9),TIRBIO(I9),TIFRF(I9),
     1TMASS0(I9),TMASSW(I9),TMASS(I9),XMASSB(I9),XMASST(I9),CRY(I9)
     2,FTOP(I9),GWAT(I9),FBOT(I9),FRIM(I9),FLXDT(I9),DFLXDT(I9)
C
C*******DIMENSION THE FOLLOWING (NHK+2)
C
      DIMENSION WK(I9),VC(I9),VM(I9),DV(I9),IBIO(I9),ICON(I9)
C
C*******DIMENSION THE FOLLOWING (NK)
C
      DIMENSION XIK0(NHK),BMLX(NHK),HWIK(NHK),HAW(NHK),RK(NHK)
     1,HSW(NHK),VK(NHK),ATCONC(NHK),DKW(NHK),IOUTOPT(NHK)
     2,IREF(NHK),IFLX(NHK),RLAMBDA(NHK),RCON(NHK)
     3,RMAX(NHK),HSAT(NHK)
C
C*******DIMENSION THE FOLLOWING
C
      DIMENSION SXLM(10000),XINIT(1001),UINIT(1001),XPT(1001),YPT(1001),
     1SLPZ(1001),SLPR(1001),BZZ(1001),BRR(1001)
C
C
C   THE NUMERICAL PERFORMANCE CRITERIA REQUIRES A SEPARATE DEFINITION FOR O2
C   IF NEAR 1 THEN ALGORITHM ADHERS TO CONSERVATION OF MASS
C
C
      IF(IOUTOPT(IK).EQ.0) GO TO 2
C
      DO 456 IR=1,NR
      IF(Y2(IR,IK).LE.0) Y2(IR,IK)=1E-20
 456  CONTINUE
      DO 466 IZ=1,NZ
      IF(Y1(IZ,IK).LE.0) Y1(IZ,IK)=1E-20
 466  CONTINUE
C
C
C   OUTPUT FOR ENTIRE MODEL DOMAIN (SNAPSHOT OPTION ONLY)
C   IU4=60 SET PRIOR TO DO LOOP 90 (MAIN PROGRAM)
C
      IF(ISNAP.EQ.1) THEN
      OPEN(UNIT=84,FILE='IC.INPUT')
      IF(I.EQ.1) WRITE(IU4,401) TSNAP/3600,IK
      IF(I.GT.1) WRITE(84,*) IK
      IF(IDIM.EQ.1 .AND. I.EQ.1) WRITE(IU4,407)
      IF(IDIM.GT.1 .AND. I.EQ.1) WRITE(IU4,402)
      IF(IDIM.EQ.1 .AND. I.GT.1) THEN
      DO 23, IZ=3,NZ
	WRITE(84,412) (Y0(IR,IZ,IK),IR=1,NR)
 23   CONTINUE
      WRITE(IU4,419) (Z(IZ),Y0(2,IZ,IK),IZ=1,NZ)
      END IF
      IF(IDIM.EQ.2 .AND. I.GT.1) WRITE(IU4,404) (R(IR),Z(1),Y0
     1(IR,1,IK),IR=1,NR)
      IF(IDIM.EQ.3 .AND. I.GT.1) THEN
      DO 20 IR=1,NR
      WRITE(IU4,404) (R(IR),Z(IZ),Y0(IR,IZ,IK),IZ=1,NZ)
 20   CONTINUE
      IF(I.GT.1) THEN
	DO 21 IZ=1,NZ
      WRITE(84,412) (Y0(IR,IZ,IK),IR=1,NR)
 21   CONTINUE
      END IF     
      END IF
C
C   IF OUTPUT DATA AT SPECIFIC LOCATIONS (ISNAP=0)
C
      ELSE
      DO 559 IW=1,NW
      IF(IOUT.EQ.0) THEN
      IF(I.EQ.1) WRITE(IU4,405) IK,R(IRVW(IW)),Z(IZVW(IW))
      IF(I.EQ.1) WRITE(IU4,406)
      WRITE(IU4,410) TIME/3600.,Y0(IRVW(IW),IZVW(IW),IK)
      IF(IW.EQ.1) IU5=IU4
      IU4=IU4+8
      ELSE
      IF(I.GT.1) THEN
      WRITE(IU4,401) TIME/3600.,IK
      WRITE(IU4,402)
      WRITE(IU4,403) R(IRVW(IW)),Z(IZVW(IW)),Y0(IRVW(IW),IZVW(IW),IK)
      IF(IW.EQ.1) IU5=IU4
      IU4=IU4+8
      END IF
      END IF
 559  CONTINUE
      IU4=IU5
      END IF
C
C

  401 FORMAT(1X,'TIME (HOURS)= ',E13.4,4X,'CONSTITUENT= ',I2/)
  402 FORMAT('R-COORDINATE (CM)',5X,'Z-COORDINATE (CM)',7X,'CONCENTRATIO
     1N (G/CM3)'/17('-'),5X,17('-'),5X,24('-'))
  403 FORMAT(4X,E10.4,10X,E10.4,14X,E13.4)
  404 FORMAT(4X,E10.4,11X,E10.4,12X,E13.4)
  405 FORMAT(1X,'CONSTITUENT= ',I2,2X,'LOCATION : R-COORDINATE (CM)= ',E
     110.4,3X,'Z-COORDINATE (CM)= ',E10.4)
  406 FORMAT(8X,'TIME (HOURS)',5X,'CONCENTRATION (G/CM3)'/8X,13('-'),5X,
     120('-')/)
  407 FORMAT('Z-COORDINATE (CM)',7X,'CONCENTRATION (G/CM3)'/17('-'),5X,2
     14('-'))
  409 FORMAT(E13.4)
  410 FORMAT(6X,F13.4,11X,E11.4)
  411 FORMAT(1X,10G11.4)
  412 FORMAT(10G11.4)
  419 FORMAT(E13.4,13X,E13.4)
C
    2 RETURN
      END
C
C
      SUBROUTINE NEWANAL
C
C  A SUBROUTINE TO READ AND WRITE INPUT FOR ANALYTICAL MODEL
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER(NHR=501,NHZ=501,NHL=5,NHK=8,NHW=3,I9=NHK+1,
     1NHRZ=NHR+NHZ+1)
      CHARACTER TITLE*70,FNAMEPOR*38,FNAMETHW*38,M*30,
     1FNAMETA*38,FNAMEBD*38,FNAMEICDAT*38,FNAMEMIF*38,FNAMECAL*38,
     2FNAMEOUT1*38,FNAMEOUT2*38,FNAMEOUT3*38,FNAMEOUT4*38,FNAMEOUT5*38,
     3FNAMEOUT6*38,FNAMEOUT7*38,FNAMEOUT8*38,FNAMEOUT9*38,FNAMEOUT10*38,
     4FNAMEOUT11*38,FNAMEOUT12*38,FNAMEOUT13*38,FNAMEOUT14*38,
     5FNAMEOUT15*38,FNAMEOUT16*38,FNAMEOUT17*38,FNAMEOUT18*38,
     6FNAMEOUT19*38,FNAMEOUT20*38,FNAMEOUT21*38,FNAMEOUT22*38,
     7FNAMEOUT23*38,FNAMEOUT24*38,
     8FNAMEBCDAT*38
      COMMON/DEP0/ Y0,Y1,Y2,Y3,DTY
      COMMON/DEP/  Y,TOT,RBIO
      COMMON/CHAR/ M,FNAMETA,FNAMEBD,FNAMECAL,FNAMEMIF,
     3FNAMEICDAT,FNAMEPOR,FNAMETHW,FNAMEBCDAT,TITLE,
     5FNAMEOUT1,FNAMEOUT2,FNAMEOUT3,FNAMEOUT4,FNAMEOUT5,
     6FNAMEOUT6,FNAMEOUT7,FNAMEOUT8,FNAMEOUT9,FNAMEOUT10,
     7FNAMEOUT11,FNAMEOUT12,FNAMEOUT13,FNAMEOUT14,FNAMEOUT15,FNAMEOUT16,
     8FNAMEOUT17,FNAMEOUT18,FNAMEOUT19,FNAMEOUT20,FNAMEOUT21,FNAMEOUT22,
     9FNAMEOUT23,FNAMEOUT24
      COMMON/XNRNZNK/ BR,BZ,CR,CZ,PP,DKA,SUMDK
      COMMON/XNRNZ/ PT
      COMMON/XNZNK/ FIRF,A
      COMMON/XNRNK/ FIZT,FIZW,FLX
      COMMON/XNKNK/ DKAB
      COMMON/XNR/ R,BC
      COMMON/XNZ/ Z,TA,TW,BD,POR,THA,THW
      COMMON/YTRP/ YTRAP,ZTRAP
      COMMON/XNK/  XIK0,HAW,HSW,RK,TIFIP,TIFB,TIFT,TIRBIO,TIFRF,
     1TMASS,TMASS0,CRY,VK,WK,HWIK,XMASSB,XMASST,ATCONC,IBIO,ICON,
     2TMASSW,DV,DKW,VC,VM,BMLX,FLXDT,IOUTOPT,IREF,IFLX
     3,RCON,RLAMBDA,RMAX,HSAT,GWAT,FTOP,FBOT,FRIM,DFLXDT
      COMMON/XNL/AL,ALT,ZLAY,PORL,TAL,THWL,THAL,BDL
      COMMON/XNW/RVW,ZVW
      COMMON/ARRAY/ XINIT,UINIT,XPT,YPT,SLPZ,SLPR,BZZ,BRR,SXLM
      COMMON/ISC/NR,NZ,NL,NK,NT,IRIM,IRASP,IZLOW,IZHI,IZBAS,IRVW,IZVW,
     1IPROJ,NITER,IRNORM,IZNORM,ITER,ITER0,ISS,IRFP,IW,IL,IK,IKK,I,
     2NW,IZLAY,JK,IDAT,NDAT,ICOUNT,IOX,IIX,ICUT,IDT,IU2,IU3,IU4,KONS
      COMMON/INT/IFIL,IMOD,IMILQ,IOPT,INOPT,IBC0,IOUT,ICOMP,ISURF,
     1NDATIN,NDATCAL,NIPTS,ISNAP,ITIME,ICONX,IWARN,ICNTER,IDIM,
     2ISTRAT,IBDRY,INCHECK,IDISP,IWAT,IFLAG,IN,JN,IRMAX,IHSAT
      COMMON/XSC/DT,DR,DZ,SUM,AR1,AR2,AR3,AR4,AZ1,AZ2,ATOX,RHOIM,CSA,
     1TIME,VIMM,DARCY,THI0,EPS,ENORM,ATM,ZBAS,ZWAT,ZSURF,ZLOW,ZHI,
     2DT1,DT2,DTM,TRANS,TEND,YPR1,YPR2,SKIP,SKIP2,TEMP,RIM,RF,DTHI0
      COMMON/CONS/FLUX,UP,UW,D,DS,GAM,B,C,XL,PI,XFD,BP,DP,WAT,AIR,
     1XMM,DBIN,XM0,XB0,YNM,TMAX,DELT,HENRY,SWPC,BULK,XLL,TSNAP,TOR,
     2XB,ZOUT,GASBOT
      COMMON/RC1/ C6,C7
      COMMON/RC2/C1,C2,C3,C4,C5
C
C
C
C****DIMENSION THE FOLLOWING (NR,NZ,NK+1)
C
      DIMENSION Y0(NHR,NHZ,I9),DTY(NHR,NHZ,I9),PP(NHR,NHZ,I9)
     1,BR(NHR,NHZ,I9),BZ(NHR,NHZ,I9),CR(NHR,NHZ,I9),CZ(NHR,NHZ,I9)
     2,C1(NHR,NHZ,I9),C2(NHR,NHZ,I9),C3(NHR,NHZ,I9),C4(NHR,NHZ,I9)
     3,C5(NHR,NHZ,I9),DKA(NHR,NHZ,I9),SUMDK(NHR,NHZ,I9)
     4,Y(NHR,NHZ,I9),Y3(NHR,NHZ,I9)
C
C****DIMENSION THE FOLLOWING (NR,NZ)
      DIMENSION TOT(NHR,NHZ),PT(NHR,NHZ)
      DIMENSION C6(NHR,NHZ),C7(NHR,NHZ),RBIO(NHR,NHZ)
C
C******DIMENSION THE FOLLOWING AS (NZ,NK+1)
C
      DIMENSION FIRF(NHZ,I9),A(NHZ,I9),Y1(NHZ,I9)
C
C******DIMENSION THE FOLLOWING AS (NR,NK+1)
C
      DIMENSION FIZT(NHR,I9),FIZW(NHR,I9),FLX(NHR,I9),Y2(NHR,I9)
C
C******DIMENSION THE FOLLOWING AS (I9,I9)
C
      DIMENSION DKAB(I9,I9)
C
C******DIMENSION THE FOLLOWING AS (NR+NZ)
C
      DIMENSION YTRAP(NHRZ),ZTRAP(NHRZ)
C
C******DIMENSION THE FOLLOWING AS (NHZ)
C
      DIMENSION Z(NHZ),POR(NHZ),TA(NHZ),TW(NHZ),THA(NHZ)
     1,THW(NHZ),BD(NHZ)
C
C******DIMENSION THE FOLLOWING AS (NHR)
C
      DIMENSION R(NHR),BC(NHR)
C
C******DIMENSION THE FOLLOWING AS (NL)
C
      DIMENSION AL(NHL),ALT(NHL),ZLAY(NHL),IZLAY(NHL),
     1PORL(NHL),THWL(NHL),THAL(NHL),TAL(NHL),BDL(NHL)
C
C********DIMENSION THE FOLLOWING AS (NW)
C
      DIMENSION RVW(NHW),ZVW(NHW),IRVW(NHW),IZVW(NHW)
C
C********DIMENSION THE FOLLOWING (NHK+1)
C
      DIMENSION TIFIP(I9),TIFB(I9),TIFT(I9),TIRBIO(I9),TIFRF(I9),
     1TMASS0(I9),TMASSW(I9),TMASS(I9),XMASSB(I9),XMASST(I9),CRY(I9)
     2,FTOP(I9),GWAT(I9),FBOT(I9),FRIM(I9),FLXDT(I9),DFLXDT(I9)
C
C*******DIMENSION THE FOLLOWING (NHK+2)
C
      DIMENSION WK(I9),VC(I9),VM(I9),DV(I9),IBIO(I9),ICON(I9)
C
C*******DIMENSION THE FOLLOWING (NK)
C
      DIMENSION XIK0(NHK),BMLX(NHK),HWIK(NHK),HAW(NHK),RK(NHK)
     1,HSW(NHK),VK(NHK),ATCONC(NHK),DKW(NHK),IOUTOPT(NHK)
     2,IREF(NHK),IFLX(NHK),RLAMBDA(NHK),RCON(NHK)
     3,RMAX(NHK),HSAT(NHK)
C
C*******DIMENSION THE FOLLOWING
C
      DIMENSION SXLM(10000),XINIT(1001),UINIT(1001),XPT(1001),YPT(1001),
     1SLPZ(1001),SLPR(1001),BZZ(1001),BRR(1001)
C
C
C
C   THIS SUBROUTINE CREATES THE INPUT REQUIRED TO EXECUTE THE ANALYTICAL
C   MODEL.
C
C
      WRITE(*,200)
 200  FORMAT(/80('-')/)
      WRITE(*,201)
 201  FORMAT(/'THE FOLLOWING INPUT IS NECESSARY TO EXECUTE THE ANALYTICA
     1L SOLUTIONS.'/'THE INPUT IS STORED IN A DATA FILE (NAMED BY USER)
     2WHICH MAY BE'/'ACCESSED FOR SUBSEQUENT MODEL RUNS.  CREATING A NEW
     3 INPUT FILE IS'/'NOT NESSARY ONCE AN INITIAL INPUT FILE HAS BEEN C
     4ONSTRUCTED.  THIS INPUT'/'FILE CAN ALSO BE MODIFIED FOR MODEL CALI
     5BRATION PURPOSES.  ALL INPUT'/'VALUES ARE REQUIRED TO BE IN CGS UN
     6ITS UNLESS OTHERWISE SPECIFIED.'//)
      WRITE(*,203)
 203  FORMAT('SPECIFY A NAME FOR THE INPUT FILE')
      READ(*,219) FNAMEMIF
 219  FORMAT(A20)
      OPEN(UNIT=12,FILE=FNAMEMIF,STATUS='NEW')
      WRITE(12,*) IMOD
      WRITE(12,202)
 202  FORMAT(80('*')/20X,'ANALYTICAL MODEL INPUT'/80('*')/)
      WRITE(*,204)
 204  FORMAT('INPUT THE PROJECT TITLE -- DATE')
      READ(*,205) TITLE
      WRITE(12,505) TITLE
 205  FORMAT(A70)
 505  FORMAT('TITLE -  ',A70)
      WRITE(12,289)
 289  FORMAT(/2X,'VALUE',5X,'MODEL CODE',10X,'DEFINITION',8X,'[cgs units
     1]'/12X,'DESIGNATION'/2X,5('-'),5X,11('-'),9X,10('-'),8X,9('-')/)
      WRITE(*,244)
      WRITE(12,244)
 244  FORMAT(22('*'),' BOUNDARY AND INITIAL CONDITIONS ',23('*')/)
      WRITE(*,248)
 248  FORMAT('SELECT THE APPROPRIATE BOUNDARY CONDITIONS AT:'//10X,'z=0
     1(LOWER BOUNDARY)',10X,'z=L (UPPER BOUNDARY)'/10X,17('-'),10X,20('-
     2'),/5X,'1:',3X,'SPECIFIED FLUX',13X,'SPECIFIED CONCENTRATION'/5X,'
     32:',3X,'SPECIFIED CONCENTRATION',4X,'SPECIFIED CONCENTRATION'/5X,'
     43:',3X,'SPECIFIED FLUX',13X,'CONFINING UNIT'/5X,'4:',3X,'SPECIFIED
     5 CONCENTRATION',4X,'CONFINING UNIT')
      READ(*,*) IBC0
      WRITE(12,548) IBC0
 548  FORMAT(I5, 8X,'(IBC0)',6X,'BOUNDARY CONDITION OPTION')
      IF(IBC0.EQ.4) THEN
      WRITE(*,252)
 252  FORMAT('ENTER THE GAS-PHASE CONCENTRATION AT THE LOWER BOUNDARY [m
     1g/L] (z = 0)')
      READ(*,*) UW
      WRITE(12,552) UW
 552  FORMAT(E10.4, 3X,'(UW)',8X,'GAS-PHASE CONCENTRATION AT THE LOWER B
     1OUNDARY'/27X,'(z = 0) [mg/l]')
      UW=UW/1.0E6
      WRITE(*,256)
 256  FORMAT('THICKNESS OF CONFINING UNIT [cm] AT (z = L)')
      READ(*,*) BP
      WRITE(12,556) BP
 556  FORMAT(E10.4, 3X,'(BP)',8X,'THICKNESS OF CONFINING UNIT AT (z = L)
     1[cm]')
      WRITE(*,260)
 260  FORMAT('EFFECTIVE DIFFUSION COEFFICIENT [cm2/s] FOR CONFINING UNIT
     1 AT (z = L)')
      READ(*,*) DP
      WRITE(12,560) DP
 560  FORMAT(E10.4, 3X,'(DP)',8X,'EFFECTIVE DIFFUSION COEFFICIENT OF CON
     1FINING'/27X,'UNIT AT (z = L) [cm2/s]')
      WRITE(*,264)
 264  FORMAT('GAS-PHASE CONCENTRATION [mg/l] ABOVE CONFINING UNIT (z > L
     1)')
      READ(*,*) UP
      WRITE(12,564) UP
 564  FORMAT(E10.4, 3X,'(UP)',8X,'GAS-PHASE CONCENTRATION ABOVE CONFININ
     1G UNIT'/27X,'(z > L) [mg/l]')
      UP=UP/1.0E6
      END IF
      IF(IBC0.EQ.3) THEN
      WRITE(*,268)
 268  FORMAT('ENTER THE GAS FLUX AT THE LOWER BOUNDARY [g/cm2-s] (z = 0)
     1'/'(POSITIVE: FLUX INTO DOMAIN, NEGATIVE: FLUX OUT OF DOMAIN)')
      READ(*,*) FLUX
      WRITE(12,568) FLUX
 568  FORMAT(E10.4, 3X,'(FLUX)',6X,'GAS FLUX AT THE LOWER BOUNDARY(z=0)
     1[g/cm2-s]')
      WRITE(*,256)
      READ(*,*) BP
      WRITE(12,556) BP
      WRITE(*,260)
      READ(*,*) DP
      WRITE(12,560) DP
      WRITE(*,264)
      READ(*,*) UP
      WRITE(12,564) UP
      UP=UP/1.0E6
      END IF
      IF(IBC0.EQ.2) THEN
      WRITE(*,252)
      READ(*,*) UW
      WRITE(12,552) UW
      WRITE(*,286)
 286  FORMAT('GAS-PHASE CONCENTRATION [mg/l] AT (z = L)')
      READ(*,*) UP
      WRITE(12,586) UP
 586  FORMAT(E10.4, 3X,'(UP)',8X,'GAS-PHASE CONCENTRATION AT (z = L) [mg
     1/l]')
      UW=UW/1.0E6
      UP=UP/1.0E6
      END IF
      IF(IBC0.EQ.1) THEN
      WRITE(*,268)
      READ(*,*) FLUX
      WRITE(12,568) FLUX
      WRITE(*,286)
      READ(*,*) UP
      WRITE(12,586) UP
      UP=UP/1.0E6
      END IF
      WRITE(*,298)
 298  FORMAT('INITIAL CONDITION OPTION'/5X,'0: CONSTANT'/5X,'1: LINEARLY
     1 VARIABLE'/5X,'2: INITIAL CONDITION SPECIFIED IN SEPARATE INPUT FI
     2LE OF TYPE:'/7X,' [z(cm),G(mg/l)]')
      READ(*,*) INOPT
      WRITE(12,598) INOPT
 598  FORMAT(I5, 8X,'(INOPT)',5X,'INITIAL CONDITION OPTION'/27X,'0: CONS
     1TANT'/27X,'1: LINEARLY VARIABLE'/27X,'2: INITIAL CONDITION SPECIFI
     2ED IN SEPARATE'/30X,'INPUT FILE OF TYPE: [z(cm),G(mg/l)]')
      IF(INOPT.EQ.0) THEN
      WRITE(*,301)
 301  FORMAT('INITIAL CONCENTRATION [mg/l] OF CONSTITUENT')
      READ(*,*) XB0
      WRITE(12,601) XB0
 601  FORMAT(E10.4, 3X,'(XB0)',7X,'INITIAL CONCENTRATION OF CONSTITUENT
     1[g/cm3]')
      XB0=XB0/1.0E6
      END IF
      IF(INOPT.EQ.1) THEN
      IF(IBC0.EQ.1 .OR. IBC0.EQ.3) THEN
      WRITE(*,302)
 302  FORMAT('INITIAL CONCENTRATION [mg/l] OF CONSTITUENT AT z = 0')
      READ(*,*) XB0
      ELSE
      XB0=UW*1E6
      END IF
      WRITE(12,602) XB0
 602  FORMAT(E10.4, 3X,'(XB0)',7X,'INITIAL CONCENTRATION OF CONSTITUENT
     1AT z = 0 [mg/l]')
      XB0=XB0/1.0E6
      END IF
      IF(INOPT.EQ.2) THEN
      WRITE(*,310)
 310  FORMAT('SPECIFY THE NAME OF THE INPUT FILE CONTAINING THE INITIAL
     1CONDITION DATA')
      READ(*,219) FNAMEICDAT
      WRITE(12,610) FNAMEICDAT
 610  FORMAT(/'*** INITIAL CONDITION DATA [z(cm),G(mg/l)] CONTAINED IN F
     1ILE-',A20)
      OPEN(UNIT=6,FILE=FNAMEICDAT)
      READ(6,*) NDATIN
      END IF
      WRITE(*,314)
      WRITE(12,314)
 314  FORMAT(/19('*'),' PHYSICAL PROPERTIES OF THE CONSTITUENT',1X,19('*
     1')/)
      WRITE(*,318)
 318  FORMAT('DIFFUSIVITY OF CONSTITUENT IN BULK GAS PHASE [cm2/s]')
      READ(*,*) DBIN
      WRITE(12,618) DBIN
 618  FORMAT(E10.4, 3X,'(DBIN)',6X,'DIFFUSIVITY OF CONSTITUENT IN BULK G
     1AS PHASE [cm2/s]')
      WRITE(*,322)
 322  FORMAT('HENRYS LAW PARTITION COEFFICIENT (air/water) [dimensionles
     1s]')
      READ(*,*) HENRY
      WRITE(12,622) HENRY
 622  FORMAT(E10.4, 3X,'(HENRY)',5X,'HENRYS LAW PARTITION COEFFICIENT (a
     1ir/water)'/27X,'[dimensionless]')
      WRITE(*,326)
 326  FORMAT('ADSORPTION COEFFIECIENT (soil/water) [dimensionless]')
      READ(*,*) SWPC
      WRITE(12,626) SWPC
 626  FORMAT(E10.4, 3X,'(SWPC)',6X,'ADSORPTION COEFFICIENT (soil/water)
     1[dimensionless]')
      WRITE(*,334)
      WRITE(12,334)
 334  FORMAT(/19('*'),' PHYSICAL PROPERTIES OF THE POROUS MEDIA ',20('*'
     1)/)
      WRITE(*,332)
 332  FORMAT('LENGTH OF MODEL DOMAIN [cm]')
      READ(*,*) XL
      WRITE(12,632) XL
 632  FORMAT(E10.4, 3X,'(XL)',8X,'LENGTH OF MODEL DOMAIN [cm]')
      WRITE(*,338)
 338  FORMAT('POROSITY [dimensionless]')
      READ(*,*) VOID
      WRITE(12,638) VOID
 638  FORMAT(E10.4, 3X,'(VOID)',6X,'POROSITY [dimensionless]')
      WRITE(*,342)
 342  FORMAT('MOISTURE CONTENT [dimensionless]')
      READ(*,*) WAT
      WRITE(12,642) WAT
 642  FORMAT(E10.4, 3X,'(WAT)',7X,'AQUEOUS-PHASE POROSITY [dimensionless
     1]')
C
      AIR=VOID-WAT
C
      WRITE(12,643) AIR
 643  FORMAT(E10.4, 3X,'(AIR)',7X,'GASEOUS-PHASE POROSITY [dimensionless
     1]')
      WRITE(*,346)
 346  FORMAT('TORTUOSITY OPTION'/5X,'0: TORTUOSITY COMPUTED ACCORDING TO
     1 MILLINGTON-QUIRK (1966) RELATION'/5X,'1: TORTUOSITY VALUE INPUT B
     2Y USER')
      READ(*,215) IMILQ
      IF(IMILQ.EQ.0) THEN
      TOR=(AIR**(7.0/3.0))/(VOID**2)
      ELSE
      WRITE(*,347)
 347  FORMAT('TORTUOSITY [dimensionless]')
      READ(*,*) TOR
      END IF
      WRITE(12,646) TOR
 646  FORMAT(E10.4, 3X,'(TOR)',7X,'TORTUOSITY [dimensionless]')
      WRITE(*,350)
 350  FORMAT('BULK DENSITY [g/cm3]')
      READ(*,*) BULK
      WRITE(12,650) BULK
 650  FORMAT(E10.4, 3X,'(BULK)',6X,'BULK DENSITY [dimensionless]')
C
      WRITE(12,654) DBIN*TOR*AIR
 654  FORMAT(E10.4, 3X,'(DEFF)',6X,'EFFECTIVE DIFFUSION COEFFICIENT [cm2
     1/s]')
      WRITE(*,299)
      WRITE(12,299)
 299  FORMAT(/31('*'),' OUTPUT PARAMETERS ',30('*')/)
      WRITE(*,212)
 212  FORMAT('OUTPUT OPTION'/5X,'0: CONCENTRATION VERSUS TIME (breakthro
     1ugh) DATA'/5X,'1: CONCENTRATION VERSUS DISTANCE (snapshot) DATA')
      READ(*,215) IOUT
 215  FORMAT(I2)
      WRITE(12,512) IOUT
 512  FORMAT(I5, 8X,'(IOUT)',6X,'OUTPUT OPTION'/27X,'0: CONCENTRATION VS
     1. TIME (breakthrough)'/27X,'1: CONCENTRATION VS. DISTANCE (snapsho
     2t)')
      IF(IOUT.EQ.0) THEN
      ISNAP=0
      WRITE(*,211)
 211  FORMAT('MAXIMUM TIME FOR BREAKTHROUGH DATA [hrs]')
      READ(*,*) TMAX
      WRITE(12,511) TMAX
 511  FORMAT(E10.4, 3X,'(TMAX)',6X,'MAXIMUM TIME FOR BREAKTHROUGH DATA [
     1hrs]')
      WRITE(*,213)
 213  FORMAT('TIME INCREMENT FOR BREAKTHROUGH DATA [hrs]')
      READ(*,*) DELT
      WRITE(12,513) DELT
 513  FORMAT(E10.4, 3X,'(DELT)',6X,'TIME INCREMENT FOR BREAKTHROUGH DATA
     1 [hrs]')
      END IF
      IF(IOUT.EQ.1) THEN
      WRITE(*,216)
 216  FORMAT('DO YOU WISH OUTPUT DATA AT SPECIFIED LOCATIONS (ENTER 0) O
     1R FOR THE ENTIRE'/'MODEL DOMAIN (ENTER 1)')
      READ(*,215) ISNAP
      WRITE(12,515) ISNAP
 515  FORMAT(I5, 8X,'(ISNAP)',5X,'SNAPSHOT OPTION'/27X,'0: AT SPECIFIC L
     1OCATIONS'/27X,'1: ENTIRE MODEL DOMAIN')
      WRITE(*,220)
 220  FORMAT('ENTER THE TIME [hrs] FOR SNAPSHOT')
      READ(*,*) TSNAP
      WRITE(12,520) TSNAP
 520  FORMAT(E10.4, 3X,'(TSNAP)',5X,'TIME FOR SNAPSHOT [hrs]')
      IF(ISNAP.EQ.1) THEN
      WRITE(*,228)
 228  FORMAT('ENDPOINT FOR SNAPSHOT DATA [cm]')
      READ(*,*) XLL
      WRITE(12,528) XLL
 528  FORMAT(E10.4, 3X,'(XLL)',7X,'ENDPOINT FOR SNAPSHOT DATA [cm]')
      WRITE(*,218)
 218  FORMAT('NUMBER OF OUTPUT DATA POINTS TO PLOT')
      READ(*,*) NIPTS
      WRITE(12,518) NIPTS
 518  FORMAT(I5, 8X,'(NIPTS)',5X,'# OF OUTPUT DATA POINTS')
      END IF
      END IF
      IF(IOUT.EQ.2) ISNAP=1
      IF(IOUT.EQ.0 .OR. ISNAP.EQ.0) THEN
      WRITE(*,232)
 232  FORMAT('Z-COORDINATE FOR OUTPUT DATA [cm]')
      READ(*,*) ZOUT
      WRITE(12,532) ZOUT
 532  FORMAT(E10.4, 3X,'(ZOUT)',6X,'VERTICAL COORDINATE OF OUTPUT DATA [
     1cm]')
      END IF
      IF(IOUT.LE.1) THEN
      WRITE(*,519)
 519  FORMAT('SPECIFY A NAME FOR THE OUTPUT FILE')
      READ(*,219) FNAMEOUT1
      OPEN(UNIT=60,FILE=FNAMEOUT1)
      IF(IOUT.EQ.0 .OR. ISNAP.EQ.0) WRITE(12,501) FNAMEOUT1
      IF(IOUT.EQ.1 .AND. ISNAP.EQ.1) WRITE(12,517) FNAMEOUT1
 501  FORMAT(/2X,'*** OUTPUT DATA [t(hrs),G(mg/l)] CONTAINED IN FILE-',A
     120)
 517  FORMAT(/2X,'*** OUTPUT DATA [z(cm),G(mg/l)] CONTAINED IN FILE-',A2
     10)
      ELSE
      WRITE(*,240)
 240  FORMAT('SPECIFY THE NAME OF THE FILE CONTAINING THE CALIBRATION DA
     1TA')
      READ(*,219) FNAMECAL
      OPEN(UNIT=11,FILE=FNAMECAL)
      WRITE(12,516) FNAMECAL
 516  FORMAT(/2X,'*** CALIBRATION DATA [z(cm),t(hrs),G(mg/l)] CONTAINED
     1IN FILE-',A20)
      READ(11,*) NDATCAL
      END IF
      IF(IBC0.EQ.2 .OR. IBC0.EQ.4) THEN
      OPEN(UNIT=50,FILE='FLUX.DAT')
      WRITE(12,658)
 658  FORMAT(/'*** FLUX DATA AT THE LOWER BOUNDARY (z = 0) CONTAINED IN
     1FILE "FLUX.DAT"'/4X,'[t(hrs),G(mg/l),J(g/cm2-s)]')
      END IF
C
      IF(INOPT.LE.1) THEN
      NDATIN=2
      IF(INOPT.EQ.0) THEN
      XM0=0
      ELSE
      XM0=(UP-XB0)/XL
      END IF
      XINIT(1)=0.0
      XINIT(2)=XL
      UINIT(1)=XB0
      UINIT(2)=UP
      END IF
C
      WRITE(12,412)
  412 FORMAT(80('-'))
      WRITE(*,303)
 303  FORMAT (/72('*')/20X,'EXECUTING THE ANALYTICAL SOLUTION'/72('*')/)
C
      RETURN
      END
C
C
      SUBROUTINE ANALYTICAL
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      PARAMETER(NHR=501,NHZ=501,NHL=5,NHK=8,NHW=3,I9=NHK+1,
     1NHRZ=NHR+NHZ+1)
      CHARACTER TITLE*70,FNAMEPOR*38,FNAMETHW*38,M*30,
     1FNAMETA*38,FNAMEBD*38,FNAMEICDAT*38,FNAMEMIF*38,FNAMECAL*38,
     2FNAMEOUT1*38,FNAMEOUT2*38,FNAMEOUT3*38,FNAMEOUT4*38,FNAMEOUT5*38,
     3FNAMEOUT6*38,FNAMEOUT7*38,FNAMEOUT8*38,FNAMEOUT9*38,FNAMEOUT10*38,
     4FNAMEOUT11*38,FNAMEOUT12*38,FNAMEOUT13*38,FNAMEOUT14*38,
     5FNAMEOUT15*38,FNAMEOUT16*38,FNAMEOUT17*38,FNAMEOUT18*38,
     6FNAMEOUT19*38,FNAMEOUT20*38,FNAMEOUT21*38,FNAMEOUT22*38,
     7FNAMEOUT23*38,FNAMEOUT24*38,
     8FNAMEBCDAT*38
      COMMON/DEP0/ Y0,Y1,Y2,Y3,DTY
      COMMON/DEP/  Y,TOT,RBIO
      COMMON/CHAR/ M,FNAMETA,FNAMEBD,FNAMECAL,FNAMEMIF,
     3FNAMEICDAT,FNAMEPOR,FNAMETHW,FNAMEBCDAT,TITLE,
     5FNAMEOUT1,FNAMEOUT2,FNAMEOUT3,FNAMEOUT4,FNAMEOUT5,
     6FNAMEOUT6,FNAMEOUT7,FNAMEOUT8,FNAMEOUT9,FNAMEOUT10,
     7FNAMEOUT11,FNAMEOUT12,FNAMEOUT13,FNAMEOUT14,FNAMEOUT15,FNAMEOUT16,
     8FNAMEOUT17,FNAMEOUT18,FNAMEOUT19,FNAMEOUT20,FNAMEOUT21,FNAMEOUT22,
     9FNAMEOUT23,FNAMEOUT24
      COMMON/XNRNZNK/ BR,BZ,CR,CZ,PP,DKA,SUMDK
      COMMON/XNRNZ/ PT
      COMMON/XNZNK/ FIRF,A
      COMMON/XNRNK/ FIZT,FIZW,FLX
      COMMON/XNKNK/ DKAB
      COMMON/XNR/ R,BC
      COMMON/XNZ/ Z,TA,TW,BD,POR,THA,THW
      COMMON/YTRP/ YTRAP,ZTRAP
      COMMON/XNK/  XIK0,HAW,HSW,RK,TIFIP,TIFB,TIFT,TIRBIO,TIFRF,
     1TMASS,TMASS0,CRY,VK,WK,HWIK,XMASSB,XMASST,ATCONC,IBIO,ICON,
     2TMASSW,DV,DKW,VC,VM,BMLX,FLXDT,IOUTOPT,IREF,IFLX
     3,RCON,RLAMBDA,RMAX,HSAT,GWAT,FTOP,FBOT,FRIM,DFLXDT
      COMMON/XNL/AL,ALT,ZLAY,PORL,TAL,THWL,THAL,BDL
      COMMON/XNW/RVW,ZVW
      COMMON/ARRAY/ XINIT,UINIT,XPT,YPT,SLPZ,SLPR,BZZ,BRR,SXLM
      COMMON/ISC/NR,NZ,NL,NK,NT,IRIM,IRASP,IZLOW,IZHI,IZBAS,IRVW,IZVW,
     1IPROJ,NITER,IRNORM,IZNORM,ITER,ITER0,ISS,IRFP,IW,IL,IK,IKK,I,
     2NW,IZLAY,JK,IDAT,NDAT,ICOUNT,IOX,IIX,ICUT,IDT,IU2,IU3,IU4,KONS
      COMMON/INT/IFIL,IMOD,IMILQ,IOPT,INOPT,IBC0,IOUT,ICOMP,ISURF,
     1NDATIN,NDATCAL,NIPTS,ISNAP,ITIME,ICONX,IWARN,ICNTER,IDIM,
     2ISTRAT,IBDRY,INCHECK,IDISP,IWAT,IFLAG,IN,JN,IRMAX,IHSAT
      COMMON/XSC/DT,DR,DZ,SUM,AR1,AR2,AR3,AR4,AZ1,AZ2,ATOX,RHOIM,CSA,
     1TIME,VIMM,DARCY,THI0,EPS,ENORM,ATM,ZBAS,ZWAT,ZSURF,ZLOW,ZHI,
     2DT1,DT2,DTM,TRANS,TEND,YPR1,YPR2,SKIP,SKIP2,TEMP,RIM,RF,DTHI0
      COMMON/CONS/FLUX,UP,UW,D,DS,GAM,B,C,XL,PI,XFD,BP,DP,WAT,AIR,
     1XMM,DBIN,XM0,XB0,YNM,TMAX,DELT,HENRY,SWPC,BULK,XLL,TSNAP,TOR,
     2XB,ZOUT,GASBOT
      COMMON/RC1/ C6,C7
      COMMON/RC2/C1,C2,C3,C4,C5
C
C
C
C****DIMENSION THE FOLLOWING (NR,NZ,NK+1)
C
      DIMENSION Y0(NHR,NHZ,I9),DTY(NHR,NHZ,I9),PP(NHR,NHZ,I9)
     1,BR(NHR,NHZ,I9),BZ(NHR,NHZ,I9),CR(NHR,NHZ,I9),CZ(NHR,NHZ,I9)
     2,C1(NHR,NHZ,I9),C2(NHR,NHZ,I9),C3(NHR,NHZ,I9),C4(NHR,NHZ,I9)
     3,C5(NHR,NHZ,I9),DKA(NHR,NHZ,I9),SUMDK(NHR,NHZ,I9)
     4,Y(NHR,NHZ,I9),Y3(NHR,NHZ,I9)
C
C****DIMENSION THE FOLLOWING (NR,NZ)
      DIMENSION TOT(NHR,NHZ),PT(NHR,NHZ)
      DIMENSION C6(NHR,NHZ),C7(NHR,NHZ),RBIO(NHR,NHZ)
C
C******DIMENSION THE FOLLOWING AS (NZ,NK+1)
C
      DIMENSION FIRF(NHZ,I9),A(NHZ,I9),Y1(NHZ,I9)
C
C******DIMENSION THE FOLLOWING AS (NR,NK+1)
C
      DIMENSION FIZT(NHR,I9),FIZW(NHR,I9),FLX(NHR,I9),Y2(NHR,I9)
C
C******DIMENSION THE FOLLOWING AS (I9,I9)
C
      DIMENSION DKAB(I9,I9)
C
C******DIMENSION THE FOLLOWING AS (NR+NZ)
C
      DIMENSION YTRAP(NHRZ),ZTRAP(NHRZ)
C
C******DIMENSION THE FOLLOWING AS (NHZ)
C
      DIMENSION Z(NHZ),POR(NHZ),TA(NHZ),TW(NHZ),THA(NHZ)
     1,THW(NHZ),BD(NHZ)
C
C******DIMENSION THE FOLLOWING AS (NHR)
C
      DIMENSION R(NHR),BC(NHR)
C
C******DIMENSION THE FOLLOWING AS (NL)
C
      DIMENSION AL(NHL),ALT(NHL),ZLAY(NHL),IZLAY(NHL),
     1PORL(NHL),THWL(NHL),THAL(NHL),TAL(NHL),BDL(NHL)
C
C********DIMENSION THE FOLLOWING AS (NW)
C
      DIMENSION RVW(NHW),ZVW(NHW),IRVW(NHW),IZVW(NHW)
C
C********DIMENSION THE FOLLOWING (NHK+1)
C
      DIMENSION TIFIP(I9),TIFB(I9),TIFT(I9),TIRBIO(I9),TIFRF(I9),
     1TMASS0(I9),TMASSW(I9),TMASS(I9),XMASSB(I9),XMASST(I9),CRY(I9)
     2,FTOP(I9),GWAT(I9),FBOT(I9),FRIM(I9),FLXDT(I9),DFLXDT(I9)
C
C*******DIMENSION THE FOLLOWING (NHK+2)
C
      DIMENSION WK(I9),VC(I9),VM(I9),DV(I9),IBIO(I9),ICON(I9)
C
C*******DIMENSION THE FOLLOWING (NK)
C
      DIMENSION XIK0(NHK),BMLX(NHK),HWIK(NHK),HAW(NHK),RK(NHK)
     1,HSW(NHK),VK(NHK),ATCONC(NHK),DKW(NHK),IOUTOPT(NHK)
     2,IREF(NHK),IFLX(NHK),RLAMBDA(NHK),RCON(NHK)
     3,RMAX(NHK),HSAT(NHK)
C
C*******DIMENSION THE FOLLOWING
C
      DIMENSION SXLM(10000),XINIT(1001),UINIT(1001),XPT(1001),YPT(1001),
     1SLPZ(1001),SLPR(1001),BZZ(1001),BRR(1001)
C
C
C
      IF(IOUT.EQ.1) TSNAP=TSNAP*3600.
      IF(IOUT.EQ.1 .AND. ISNAP.EQ.1) DDXX=XLL/(NIPTS-1)
      D=DBIN*AIR*TOR
      IF(IBC0.EQ.3 .OR. IBC0.EQ.4) GAM=DP/BP
      IF(IBC0.EQ.3 .OR. IBC0.EQ.4) B=GAM*UP
      IF(IBC0.EQ.4) XMM=(B-GAM*UW)/(GAM*XL+D)
      IF(IBC0.EQ.2) XMM=(UP-UW)/XL
      IF(IBC0.EQ.3) C=(B+FLUX)/GAM  +  FLUX*XL/D
      IF(IBC0.EQ.1) C=UP + FLUX*XL/D
      AA=WAT/HENRY + SWPC*BULK/HENRY + AIR
      XFD=FLUX/D
      DS=D/AA
      PI=3.14159
C
      IF(INOPT.EQ.2) THEN
      DO 44 IDAT=1,NDATIN
      READ(6,*) XINIT(IDAT),UINIT(IDAT)
      UINIT(IDAT)=UINIT(IDAT)*1E-6
 44   CONTINUE
      END IF
C
C
C
C
C   FIND EIGENVALUES BY NEWTON'S METHOD
C
      IF(IBC0.EQ.4) THEN
      CCC=D/(XL*GAM)
      DO 8 N=1,10000
      SXL0=(N-.25)*PI/XL
      XN0=XL*SXL0
      DO 1 I=1,1000000
      U1=COS(XN0)
      F=SIN(XN0)/U1 + CCC*XN0
      FP=1.0/(U1*U1) + CCC
      XN=XN0 - F/FP
      IF(ABS((XN-XN0)/XN).LT.(1.0E-6)) GO TO 2
      XN0=XN
    1 CONTINUE
    2 IF(I.GE.999999) WRITE(*,989)
      SXLM(N)=XN/XL
    8 CONTINUE
      END IF
      IF(IBC0.EQ.3) THEN
      CCC=GAM*XL/D
      DO 9 N=1,10000
      SXL0=(N-1)*PI/XL
      IF(N.EQ.1) SXL0=1.0/XL
      XN0=XL*SXL0
      DO 3 I=1,1000000
      U1=COS(XN0)
      F=SIN(XN0)/U1 - CCC/XN0
      FP=1.0/(U1*U1) + CCC/(XN0*XN0)
      XN=XN0 - F/FP
      IF(ABS((XN-XN0)/XN).LT.(1.0E-6)) GO TO 4
      XN0=XN
    3 CONTINUE
    4 IF(I.GE.999999) WRITE(*,989)
      SXLM(N)=XN/XL
    9 CONTINUE
      END IF
      IF(IBC0.EQ.1) THEN
      DO 10 N=1,10000
      SXLM(N)=N*PI/XL
 10   CONTINUE
      END IF
      IF(IBC0.EQ.2) THEN
      DO 12 N=1,10000
      SXLM(N)=(PI*(2*N-1))/(2*XL)
 12   CONTINUE
      END IF
  989 FORMAT('NEWTON METHOD FOR FINDING EIGENVALUE DID NOT CONVERGE')
      IF(IOUT.EQ.1) GO TO 29
      IF(IOUT.EQ.2) GO TO 37
      TSNAP=0.0
      ISNAP=0
      XB=ZOUT
      TMAX=TMAX*3600.
      DELT=DELT*3600.
      U00=XM0*XB+XB0
      DO 35 IT=1,100000000
      TSNAP=TSNAP+DELT
      IF(TSNAP.GT.TMAX) GO TO 30
      T=TSNAP
      CALL REBOUND(U,T,XB)
      IF(IBC0.EQ.2 .OR. IBC0.EQ.4) THEN
      CALL WTFLX(FXX,T)
      IF(IT.EQ.1) THEN
      OPEN(UNIT=50,FILE='FLUX.DAT')
      WRITE(50,404)
  404 FORMAT(4X,'TIME (HRS)',8X,'CONCENTRATION (mg/l)',8X,'FLUX (G/CM2-S
     1)'/4X,10('-'),8X,20('-'),8X,14('-')/)
      END IF
      IF(ABS(U).GT.(1.0E-20)) E=ABS((U-U00)/U)
      IF(IT.GT.1 .AND. E.GT.(1.0E-4)) THEN
      WRITE(50,300) T/3600,U*1E6,FXX
      END IF
      END IF
      IF(IT.EQ.1) WRITE(60,408) XB
  408 FORMAT(1X,'BREAKTHROUGH LOCATION ABOVE Z=0 (CM)= ',E13.4/)
      IF(IT.EQ.1) WRITE(60,406)
  406 FORMAT(6X,'TIME (HRS)',10X,'CONCENTRATION (MG/L)'/6X,10('-'),10X,2
     10('-')/)
      IF(IOUT.EQ.0) WRITE(60,600) T/3600,U*1E6
  300 FORMAT(E15.6,8X,E15.6,10X,E15.6)
  600 FORMAT(3X,E15.6,10X,E15.6)
      IF(IT.GT.1.AND.E.GT.(1.0E-4)) U00=U
   35 CONTINUE
   29 CONTINUE
      T=TSNAP
      XB=ZOUT
      IF(ISNAP.EQ.1) THEN
      XB=0.0
      DO 36 ISST=1,NIPTS
      IF(ISST.EQ.1) THEN
      WRITE(60,401) T/3600
      WRITE(60,402)
  401 FORMAT(1X,'TIME (HOURS)= ',E13.4)
  402 FORMAT(/1X,'DISTANCE FROM Z=0 (CM)',5X,'CONCENTRATION (MG/L)'/1X,2
     12('-'),5X,20('-')/)
      END IF
      IF(ISST.GT.1) XB=XB+DDXX
      CALL REBOUND(U,T,XB)
      IF(IOUT.EQ.1) WRITE(60,600) XB,U*1E6
   36 CONTINUE
      ELSE
      CALL REBOUND(U,T,XB)
      WRITE(60,401) T/3600
      WRITE(60,402)
      WRITE(60,600) XB,U*1E6
      END IF
      IF(IOUT.GE.1) GO TO 30
   37 SMY=0.0
      DO 38 IDAT=1,NDATCAL
      READ(11,*) XD,TD,UD
      TD=TD*3600.
      CALL REBOUND(U,TD,XD)
      SM=(U-UD)*(U-UD)
      SMY=SMY+SM
      IF(IOUT.EQ.0) WRITE(60,408) XD
      IF(IOUT.EQ.0) WRITE(60,406)
      IF(IOUT.EQ.0) WRITE(60,600) TD,U*1E6
   38 CONTINUE
      RMSE=SMY/NDATCAL
      RMSE=SQRT(RMSE)
      WRITE(*,821) RMSE
  821 FORMAT(//'ROOT MEAN SQUARE ERROR=',E17.8)
      RETURN
   30 END
C
C
      SUBROUTINE REBOUND(U,T,X)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      CHARACTER TITLE*70,FNAMEPOR*38,FNAMETHW*38,M*30,
     1FNAMETA*38,FNAMEBD*38,FNAMEICDAT*38,FNAMEMIF*38,FNAMECAL*38,
     2FNAMEOUT1*38,FNAMEOUT2*38,FNAMEOUT3*38,FNAMEOUT4*38,FNAMEOUT5*38,
     3FNAMEOUT6*38,FNAMEOUT7*38,FNAMEOUT8*38,FNAMEOUT9*38,FNAMEOUT10*38,
     4FNAMEOUT11*38,FNAMEOUT12*38,FNAMEOUT13*38,FNAMEOUT14*38,
     5FNAMEOUT15*38,FNAMEOUT16*38,FNAMEOUT17*38,FNAMEOUT18*38,
     6FNAMEOUT19*38,FNAMEOUT20*38,FNAMEOUT21*38,FNAMEOUT22*38,
     7FNAMEOUT23*38,FNAMEOUT24*38,
     8FNAMEBCDAT*38
      COMMON/INT/IFIL,IMOD,IMILQ,IOPT,INOPT,IBC0,IOUT,ICOMP,ISURF,
     1NDATIN,NDATCAL,NIPTS,ISNAP,ITIME,ICONX,IWARN,ICNTER,IDIM,
     2ISTRAT,IBDRY,INCHECK,IDISP,IWAT,IFLAG,IN,JN,IRMAX,IHSAT
      COMMON/CHAR/ M,FNAMETA,FNAMEBD,FNAMECAL,FNAMEMIF,
     3FNAMEICDAT,FNAMEPOR,FNAMETHW,FNAMEBCDAT,TITLE,
     5FNAMEOUT1,FNAMEOUT2,FNAMEOUT3,FNAMEOUT4,FNAMEOUT5,
     6FNAMEOUT6,FNAMEOUT7,FNAMEOUT8,FNAMEOUT9,FNAMEOUT10,
     7FNAMEOUT11,FNAMEOUT12,FNAMEOUT13,FNAMEOUT14,FNAMEOUT15,FNAMEOUT16,
     8FNAMEOUT17,FNAMEOUT18,FNAMEOUT19,FNAMEOUT20,FNAMEOUT21,FNAMEOUT22,
     9FNAMEOUT23,FNAMEOUT24
      COMMON/ARRAY/ XINIT,UINIT,XPT,YPT,SLPZ,SLPR,BZZ,BRR,SXLM
      COMMON/CONS/FLUX,UP,UW,D,DS,GAM,B,C,XL,PI,XFD,BP,DP,WAT,AIR,
     1XMM,DBIN,XM0,XB0,YNM,TMAX,DELT,HENRY,SWPC,BULK,XLL,TSNAP,TOR,
     2XB,ZOUT,GASBOT
C
      DIMENSION SXLM(10000),XINIT(1001),UINIT(1001),XPT(1001),YPT(1001),
     1SLPZ(1001),SLPR(1001),BZZ(1001),BRR(1001)
C
      V=0.0
      DO 5 N=1,10000
      IN=N
      IF(INOPT.EQ.2) CALL CNX(CN,IN,XLM)
      IF(INOPT.EQ.2) GO TO 2
      ARG=XL*SXLM(N)
      U1=COS(ARG)
      U2=SIN(ARG)
      XLM=SXLM(N)*SXLM(N)
      IF(IBC0.EQ.2 .OR. IBC0.EQ.4) GO TO 1
      U3=U1 + ARG*U2 -1.0
      YNM=XFD+XM0
      U3=(YNM/XLM)*U3
      U3=U3+ ((XB0-C)/SXLM(N))*U2
      CN=(2.0/XL)*U3
      IF(IBC0.EQ.1 .OR. IBC0.EQ.3) GO TO 2
    1 CONTINUE
      U3=U2-ARG*U1
      YNM=-XMM+XM0
      U3=(YNM/XLM)*U3
      U3=U3-((XB0-UW)/SXLM(N))*(U1-1.0)
      CN=(2.0/XL)*U3
    2 CONTINUE
      AEXP=-XLM*DS*T
      V0=V
      IF(IBC0.EQ.2 .OR. IBC0.EQ.4) ZPHI=SIN(X*SXLM(N))
      IF(IBC0.EQ.1 .OR. IBC0.EQ.3) ZPHI=COS(X*SXLM(N))
      UEY=CN*ZPHI*EXP(AEXP)
      IF(ABS(UEY).LT.(1.0E-20)) GO TO 6
      V=V+UEY
      E=ABS((V-V0)/V)
      IF(N.GT.3.AND.E.LT.(1.0E-20)) GO TO 6
    5 CONTINUE
    6 CONTINUE
      IF(N.GE.9999) WRITE(*,878)
  878 FORMAT('SERIES SOL. DID NOT CONVERGE')
      IF(IBC0.EQ.2 .OR. IBC0.EQ.4) UK=XMM*X + UW
      IF(IBC0.EQ.1 .OR. IBC0.EQ.3) UK=-XFD*X + C
      U=V+UK
      RETURN
      END
C
C
      SUBROUTINE WTFLX(FXX,T)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      CHARACTER TITLE*70,FNAMEPOR*38,FNAMETHW*38,M*30,
     1FNAMETA*38,FNAMEBD*38,FNAMEICDAT*38,FNAMEMIF*38,FNAMECAL*38,
     2FNAMEOUT1*38,FNAMEOUT2*38,FNAMEOUT3*38,FNAMEOUT4*38,FNAMEOUT5*38,
     3FNAMEOUT6*38,FNAMEOUT7*38,FNAMEOUT8*38,FNAMEOUT9*38,FNAMEOUT10*38,
     4FNAMEOUT11*38,FNAMEOUT12*38,FNAMEOUT13*38,FNAMEOUT14*38,
     5FNAMEOUT15*38,FNAMEOUT16*38,FNAMEOUT17*38,FNAMEOUT18*38,
     6FNAMEOUT19*38,FNAMEOUT20*38,FNAMEOUT21*38,FNAMEOUT22*38,
     7FNAMEOUT23*38,FNAMEOUT24*38,
     8FNAMEBCDAT*38
      COMMON/INT/IFIL,IMOD,IMILQ,IOPT,INOPT,IBC0,IOUT,ICOMP,ISURF,
     1NDATIN,NDATCAL,NIPTS,ISNAP,ITIME,ICONX,IWARN,ICNTER,IDIM,
     2ISTRAT,IBDRY,INCHECK,IDISP,IWAT,IFLAG,IN,JN,IRMAX,IHSAT
      COMMON/CHAR/ M,FNAMETA,FNAMEBD,FNAMECAL,FNAMEMIF,
     3FNAMEICDAT,FNAMEPOR,FNAMETHW,FNAMEBCDAT,TITLE,
     5FNAMEOUT1,FNAMEOUT2,FNAMEOUT3,FNAMEOUT4,FNAMEOUT5,
     6FNAMEOUT6,FNAMEOUT7,FNAMEOUT8,FNAMEOUT9,FNAMEOUT10,
     7FNAMEOUT11,FNAMEOUT12,FNAMEOUT13,FNAMEOUT14,FNAMEOUT15,FNAMEOUT16,
     8FNAMEOUT17,FNAMEOUT18,FNAMEOUT19,FNAMEOUT20,FNAMEOUT21,FNAMEOUT22,
     9FNAMEOUT23,FNAMEOUT24
      COMMON/ARRAY/ XINIT,UINIT,XPT,YPT,SLPZ,SLPR,BZZ,BRR,SXLM
      COMMON/CONS/FLUX,UP,UW,D,DS,GAM,B,C,XL,PI,XFD,BP,DP,WAT,AIR,
     1XMM,DBIN,XM0,XB0,YNM,TMAX,DELT,HENRY,SWPC,BULK,XLL,TSNAP,TOR,
     2XB,ZOUT,GASBOT
C
      DIMENSION SXLM(10000),UINIT(1001),XINIT(1001),XPT(1001),YPT(1001),
     1SLPZ(1001),SLPR(1001),BZZ(1001),BRR(1001)
C
C  THIS SUBROUTINE CALCULATES THE FLUX AT LOWER BOUNDARY Z=0
C  IF CONCENTRATION IS SPECIFIED THERE
C
C
      V=0.0
      DO 5 N=1,10000
      IN=N
      IF(INOPT.EQ.1) CALL CNX(CN,IN,XLM)
      IF(INOPT.EQ.1) GO TO 69
      ARG=XL*SXLM(N)
      U1=COS(ARG)
      U2=SIN(ARG)
      XLM=SXLM(N)*SXLM(N)
      U3=U2-ARG*U1
      YNM=-XMM+XM0
      U3=(YNM/XLM)*U3
      U3=U3-((XB0-UW)/SXLM(N))*(U1-1.0)
      CN=(2.0/XL)*U3
 69   CONTINUE
      AEXP=-XLM*DS*T
      V0=V
      UEY=SXLM(N)*CN*EXP(AEXP)
      IF(ABS(UEY).LT.(1.0E-20)) GO TO 6
      V=V+UEY
      E=ABS((V-V0)/V)
      IF(N.GT.3.AND.E.LT.(1.0E-10)) GO TO 6
    5 CONTINUE
    6 CONTINUE
      IF(N.GE.9999) WRITE(*,879)
  879 FORMAT('FLUX SERIES DID NOT CONVERGE')
      FXX=-D*(XMM+V)
      RETURN
      END
C
      SUBROUTINE CNX(CN,N,XLM)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      CHARACTER TITLE*70,FNAMEPOR*38,FNAMETHW*38,M*30,
     1FNAMETA*38,FNAMEBD*38,FNAMEICDAT*38,FNAMEMIF*38,FNAMECAL*38,
     2FNAMEOUT1*38,FNAMEOUT2*38,FNAMEOUT3*38,FNAMEOUT4*38,FNAMEOUT5*38,
     3FNAMEOUT6*38,FNAMEOUT7*38,FNAMEOUT8*38,FNAMEOUT9*38,FNAMEOUT10*38,
     4FNAMEOUT11*38,FNAMEOUT12*38,FNAMEOUT13*38,FNAMEOUT14*38,
     5FNAMEOUT15*38,FNAMEOUT16*38,FNAMEOUT17*38,FNAMEOUT18*38,
     6FNAMEOUT19*38,FNAMEOUT20*38,FNAMEOUT21*38,FNAMEOUT22*38,
     7FNAMEOUT23*38,FNAMEOUT24*38,
     8FNAMEBCDAT*38
      COMMON/INT/IFIL,IMOD,IMILQ,IOPT,INOPT,IBC0,IOUT,ICOMP,ISURF,
     1NDATIN,NDATCAL,NIPTS,ISNAP,ITIME,ICONX,IWARN,ICNTER,IDIM,
     2ISTRAT,IBDRY,INCHECK,IDISP,IWAT,IFLAG,IN,JN,IRMAX,IHSAT
      COMMON/CHAR/ M,FNAMETA,FNAMEBD,FNAMECAL,FNAMEMIF,
     3FNAMEICDAT,FNAMEPOR,FNAMETHW,FNAMEBCDAT,TITLE,
     5FNAMEOUT1,FNAMEOUT2,FNAMEOUT3,FNAMEOUT4,FNAMEOUT5,
     6FNAMEOUT6,FNAMEOUT7,FNAMEOUT8,FNAMEOUT9,FNAMEOUT10,
     7FNAMEOUT11,FNAMEOUT12,FNAMEOUT13,FNAMEOUT14,FNAMEOUT15,FNAMEOUT16,
     8FNAMEOUT17,FNAMEOUT18,FNAMEOUT19,FNAMEOUT20,FNAMEOUT21,FNAMEOUT22,
     9FNAMEOUT23,FNAMEOUT24
      COMMON/ARRAY/ XINIT,UINIT,XPT,YPT,SLPZ,SLPR,BZZ,BRR,SXLM
      COMMON/CONS/FLUX,UP,UW,D,DS,GAM,B,C,XL,PI,XFD,BP,DP,WAT,AIR,
     1XMM,DBIN,XM0,XB0,YNM,TMAX,DELT,HENRY,SWPC,BULK,XLL,TSNAP,TOR,
     2XB,ZOUT,GASBOT
C
      DIMENSION SXLM(10000),UINIT(1001),XINIT(1001),XPT(1001),YPT(1001),
     1SLPZ(1001),SLPR(1001),BZZ(1001),BRR(1001)
C
C   THIS SUBROUTINE CALUCULATES THE COEFFICIENT CN FOR A VARIABLE
C   INITIAL CONCENTRATION DISTRIBUTION THROUGHOUT THE DOMAIN. THE
C   COEFFICIENT CN MUST BE DETERMINED USING THIS SUBROUTINE IF SHARP
C   CONCENTRATION GRADIENTS ARE OBSERVED IN THE UNSATURATED ZONE.
C
      IF(IBC0.EQ.2 .OR. IBC0.EQ.4) GO TO 11
      SUM=0.0
      DO 22 INX=1,NDATIN-1
      ARGL=XINIT(INX)*SXLM(N)
      ARGU=XINIT(INX+1)*SXLM(N)
      XLM=SXLM(N)*SXLM(N)
      U1=(UINIT(INX+1)-UINIT(INX))
      U2=(XINIT(INX+1)-XINIT(INX))
      UM=U1/U2
      YNM=UM+XFD
      UB=-(UM*XINIT(INX))+UINIT(INX)-C
      U3=(YNM/XLM)*(COS(ARGU)+(ARGU*SIN(ARGU)))+((UB/SXLM(N))*SIN(ARGU))
      U4=(YNM/XLM)*(COS(ARGL)+(ARGL*SIN(ARGL)))+((UB/SXLM(N))*SIN(ARGL))
      SUM=SUM + (U3-U4)
 22   CONTINUE
      CN=(2/XL)*SUM
      IF(IBC0.EQ.1 .OR. IBC0.EQ.3) GO TO 24
 11   CONTINUE
      SUM=0.0
      DO 23 INX=1,NDATIN-1
      ARGL=XINIT(INX)*SXLM(N)
      ARGU=XINIT(INX+1)*SXLM(N)
      XLM=SXLM(N)*SXLM(N)
      U1=(UINIT(INX+1)-UINIT(INX))
      U2=(XINIT(INX+1)-XINIT(INX))
      UM=U1/U2
      YNM=UM-XMM
      UB=-(UM*XINIT(INX))+UINIT(INX)-UW
      U3=(YNM/XLM)*(SIN(ARGU)-(ARGU*COS(ARGU)))-((UB/SXLM(N))*COS(ARGU))
      U4=(YNM/XLM)*(SIN(ARGL)-(ARGL*COS(ARGL)))-((UB/SXLM(N))*COS(ARGL))
      SUM=SUM + (U3-U4)
 23   CONTINUE
      CN=(2/XL)*SUM
 24   CONTINUE
      RETURN
      END

