From fe62e38508854512b395ff3ce9612a700375ae0f Mon Sep 17 00:00:00 2001 From: Joseph Hughes Date: Wed, 5 Jul 2023 16:25:44 -0500 Subject: [PATCH] update source files --- true-binary/filespec.inc | 59 + true-binary/mt3dms5.for | 608 +++++++++ true-binary/mt_adv5.for | 2761 ++++++++++++++++++++++++++++++++++++++ true-binary/mt_btn5.for | 1585 ++++++++++++++++++++++ true-binary/mt_dsp5.for | 1030 ++++++++++++++ true-binary/mt_fmi5.for | 1288 ++++++++++++++++++ true-binary/mt_gcg5.for | 844 ++++++++++++ true-binary/mt_hss5.for | 571 ++++++++ true-binary/mt_rct5.for | 990 ++++++++++++++ true-binary/mt_ssm5.for | 857 ++++++++++++ true-binary/mt_tob5.for | 1017 ++++++++++++++ true-binary/mt_utl5.for | 1002 ++++++++++++++ 12 files changed, 12612 insertions(+) diff --git a/true-binary/filespec.inc b/true-binary/filespec.inc index e69de29..2767820 100644 --- a/true-binary/filespec.inc +++ b/true-binary/filespec.inc @@ -0,0 +1,59 @@ +C +C ********************************************************************** +C Code in this file defines values for OPEN-statement specifiers. Some +C of the values are extensions to ANSI Fortran 90 and 95. One of the +C specifiers is not included in ANSI FORTRAN 77. The included +C specifiers are ACCESS, FORM and ACTION. +C ********************************************************************** +C Modified from Harbaugh et al. (2000) +C Last change: 05/28/2003 +C + CHARACTER*20 ACCESS,FORM,ACTION(2) +C +C +C Specifiers for OPEN statements for unformatted files, which are +C sometimes compiler specific. +C The included specifiers are ACCESS and FORM. +C +C ACCESS specifier -- +C +C Standard Fortran -- Use unless there is a reason to do otherwise. + DATA ACCESS/'SEQUENTIAL'/ +C +C Non-standard Fortran that causes code compiled by Lahey LF90 +C or Absoft Fortran to use unstructured non-formatted +C files. This may make it possible for the non-formatted files used +C by MT3DMS to be used with programs that are compiled by other +C compilers. +C DATA ACCESS/'TRANSPARENT'/ +C +C FORM specifier -- +C +C Standard Fortran, which results in vender dependent (non-portable) +C files. Use unless there is a reason to do otherwise. +C DATA FORM/'UNFORMATTED'/ +C +C Non-standard Fortran that causes code compiled by Compaq Visual +C Fortran or Lahey Fortran 95 to use unstructured non-formatted +C files. This may make it possible for the non-formatted files used +C by MT3DMS to be used with programs that are compiled by other +C compilers. + DATA FORM/'BINARY'/ +C +C +C OPEN-statement specifiers related to file-sharing. +C +C ACTION specifier -- +C +C Standard FORTRAN 77 -- Eliminate the ACTION= specifier from all +C OPEN statements in the source-code files. +C +C Standard Fortran 90 and 95 -- Use unless there is a reason to do +C otherwise. + DATA (ACTION(I),I=1,2)/'READ','READWRITE'/ +C +C Non-standard Fortran that causes code compiled by the Lahey LF90 +C compiler to create files that can be shared. For use when parallel +C processing is used or to enable an editor to view output files +C while the program is running. +C DATA (ACTION(I),I=1,2)/'READ,DENYWRITE','READWRITE,DENYNONE'/ \ No newline at end of file diff --git a/true-binary/mt3dms5.for b/true-binary/mt3dms5.for index e69de29..8b2bf98 100644 --- a/true-binary/mt3dms5.for +++ b/true-binary/mt3dms5.for @@ -0,0 +1,608 @@ +C +C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +C % +C MT3DMS % +C a modular three-dimensional multi-species transport model % +C for simulation of advection, dispersion and chemical reactions % +C of contaminants in groundwater systems % +C % +C For Technical Information Contact % +C Chunmiao Zheng % +C Department of Geological Sciences % +C University of Alabama % +C Tuscaloosa, AL 35487, USA % +C Email: czheng@ua.edu % +C Web site: http://hydro.geo.ua.edu/mt3d % +C % +C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +C +C MT3DMS is based on MT3D originally developed by Chunmiao Zheng +C at S.S. Papadopulos & Associates, Inc. and documented for +C the United States Environmental Protection Agency. +C MT3DMS is written by Chunmiao Zheng and P. Patrick Wang +C with the iterative solver routine by Tsun-Zee Mai. +C Funding for MT3DMS development is provided, in part, by +C U.S. Army Corps of Engineers, Research and Development Center. +C +C Copyright, 1998-2010, The University of Alabama. All rights reserved. +C +C This program is provided without any warranty. +C No author or distributor accepts any responsibility +C to anyone for the consequences of using it +C or for whether it serves any particular purpose. +C The program may be copied, modified and redistributed, +C but ONLY under the condition that the above copyright notice +C and this notice remain intact. +C +C======================================================================= +C Version history: 06-23-1998 (3.00.A) +C 05-10-1999 (3.00.B) +C 11-15-1999 (3.50.A) +C 08-15-2000 (3.50.B) +C 08-12-2001 (4.00) +C 05-27-2003 (4.50) +C 02-15-2005 (5.00) +C 10-25-2005 (5.10) +C 10-30-2006 (5.20) +C 02-20-2010 (5.30) +C +C--SET MAXIMUM ARRAY DIMENSIONS +C--MXTRNOP: MAXIMUM NUMBER OF TRANSPORT OPTIONS (PACKAGES) +C--MXPRS: MAXIMUM NUMBER OF TIMES AT WHICH RESULTS ARE SAVED +C--MXSTP: MAXIMUM NUMBER OF TIME STEPS IN FLOW MODEL +C--MXOBS: MAXIMUM NUMBER OF OBSERVATION POINTS +C--MXCOMP: MAXIMUM NUMBER OF CHEMICAL COMPONENTS +C ===================================================================== +C + IMPLICIT NONE + CHARACTER,PARAMETER :: VID*14='[Version 5.30]' + INTEGER,PARAMETER :: MXTRNOP=50,MXCOMP=100, + & MXPRS=1000,MXSTP=1000,MXOBS=200 + INTEGER IX,ISUMX,ISUMIX,ISUM,ISUM2,NCOL,NROW,NLAY,NCOMP,MCOMP, + & INBTN,INADV,INDSP,INSSM,INRCT,INGCG,INTOB,INHSS,INFTL, + & IOUT,ICNF,IUCN,IUCN2,IOBS,IMAS,ICBM,ISSGOUT, + & LCLAYC,LCDELR,LCDELC,LCDZ,LCPR,LCXBC,LCYBC,LCZBC,LCQX, + & LCQY,LCQZ,LCDH,LCIB,LCCOLD,LCCNEW,LCCADV,LCRETA,LCBUFF, + & MIXELM,MXPART,LCXP,LCYP,LCZP,LCCNPT,LCCHEK, + & NCOUNT,NPINS,NRC,LCAL,LCTRPT,LCTRPV,LCDM,LCDXX,LCDXY, + & LCDXZ,LCDYX,LCDYY,LCDYZ,LCDZX,LCDZY,LCDZZ,LCSSMC, + & LCIRCH,LCRECH,LCCRCH,LCIEVT,LCEVTR,LCCEVT,MXSS,LCSS, + & LCSSG,ISOTHM,IREACT,LCRHOB,LCPRSITY2,LCFRAC,LCRETA2, + & LCSP1,LCSP2,LCRC1,LCRC2,INTERP, + & ISEED,ITRACK,NPL,NPH,NPMIN,NPMAX,NPLANE,NLSINK,NPSINK, + & NPRS,NOBS,LOCOBS,NSS,KSTP,KPER,NTSS,I,N,NPS, + & IFMTCN,IFMTNP,IFMTRF,IFMTDP,MXSTRN, + & NPER,NSTP,ISTAT,LCQSTO,LCHTOP,LCCWGT,LCSR, + & LCINDX,LCINDY,LCINDZ,ISS,IVER,NPROBS,NPRMAS,IRCTOP, + & MXITER,IPRGCG,NADVFD,ITP,NODES,ICNVG,ITER1,ITO, + & ISOLVE,LCA,LCQ,LCWK,LCCNCG,LCLRCH,LCRHS, + & IMPSOL,NCRS,ISPD,IGETSC,L,INDEX,ICOMP,NPERFL,IERR + INTEGER iNameFile,iFLen,IC,iFTLfmt,iUnitTRNOP, + & MaxConcObs,MaxFluxObs,MaxFluxCells,inSaveObs, + & LCMLAYER,LCCOBS,LCPRLAYER,LCTEMP,LCFLUXGROUP, + & LCGROUPDATA,InConcObs,nConcObs,iOutCobs,iConcLOG, + & iConcINTP,inFluxObs,nFluxGroup,nFluxObs,iOutFlux, + & iSSTrans,MaxHSSSource,MaxHSSCells,MaxHSSStep, + & LCHSSData,LCHSSLoc,iHSSLoc,nHSSSource,iRunHSSM + REAL X,TIMPRS,TSLNGH,PERCEL,HORIGN,XMAX,YMAX,ZMAX,CINACT, + & TMASIO,RMASIO,DCEPS,SRMULT,WD,DCHMOC,HT1,HT2,TIME1, + & TIME2,DT0,DELT,DTRACK,DTDISP,DTRANS,THKMIN, + & DTSSM,DTRCT,DTRACK2,RFMIN,TMASS,ACCL,CCLOSE, + & TTSMULT,TTSMAX,TMASIN,TMASOT,ERROR,ERROR2, + & start_time,end_time,total_time,CScale,FScale, + & faclength,factime,facmass + LOGICAL UNIDX,UNIDY,UNIDZ,SAVUCN,SAVCBM,CHKMAS, + & FWEL,FDRN,FRCH,FEVT,FRIV,FGHB,PRTOUT,UPDLHS,EXISTED, + & FSTR,FRES,FFHB,FIBS,FTLK,FLAK,FMNW,FDRT,FETS, + & FSWT,FSFR,FUZF + CHARACTER FLNAME*50,FINDEX*30,TUNIT*4,LUNIT*4,MUNIT*4,FPRT*1, + & LINE*80,NameTRNOP*4,cobsnam*12,fobsnam*12,HSSNAM*12 + DIMENSION X(:),IX(:),cobsnam(:),fobsnam(:),HSSNAM(:), + & TIMPRS(MXPRS),TSLNGH(MXSTP),LOCOBS(3,MXOBS), + & NCOUNT(MXCOMP),NPINS(MXCOMP),NRC(MXCOMP), + & TMASIO(122,2,MXCOMP),RMASIO(122,2,MXCOMP), + & TMASS(4,3,MXCOMP),TMASIN(MXCOMP),TMASOT(MXCOMP), + & ERROR(MXCOMP),ERROR2(MXCOMP), + & NameTRNOP(MXTRNOP),iUnitTRNOP(MXTRNOP) + ALLOCATABLE :: X,IX,cobsnam,fobsnam,HSSNAM + COMMON /PD/HORIGN,XMAX,YMAX,ZMAX,UNIDX,UNIDY,UNIDZ + COMMON /FC/FWEL,FDRN,FRCH,FEVT,FRIV,FGHB,FSTR,FRES,FFHB, + & FIBS,FTLK,FLAK,FMNW,FDRT,FETS,FSWT,FSFR,FUZF + COMMON /OC/IFMTCN,IFMTNP,IFMTRF,IFMTDP,SAVUCN, + & SAVCBM,CHKMAS,NPRMAS + COMMON /AD/PERCEL,ITRACK,WD,ISEED,DCEPS,NPLANE,NPL,NPH, + & NPMIN,NPMAX,SRMULT,INTERP,NLSINK,NPSINK,DCHMOC + COMMON /GCGIDX/L(19) + COMMON /FTL/iFTLfmt + DATA NameTRNOP/'ADV ', 'DSP ', 'SSM ', 'RCT ', 'GCG ', + & ' ', ' ', ' ', ' ', ' ', + & 'TOB ', ' ', 'HSS ', ' ', ' ', + & ' ', ' ', ' ', ' ', ' ', + & 30*' '/ + DATA INBTN/1/, INFTL/10/, IOUT/16/, + & INADV/2/, INDSP/3/, INSSM/4/, INRCT/8/, INGCG/9/, + & INTOB/12/, INHSS/13/, ICNF/17/, + & IUCN/200/, IUCN2/300/,IOBS/400/, IMAS/600/, ICBM/800/ +C +C--Get CPU time at the start of simulation + Call CPU_TIME(start_time) +C +C--WRITE AN IDENTIFIER TO SCREEN + WRITE(*,101) VID + 101 FORMAT(1X,'MT3DMS - Modular 3-D Multi-Species Transport Model ', + & A14/1X,'Developed at University of Alabama', + & ' for U.S. Department of Defense'/) +C +C--INITIALIZE CHARACTER VARIABLES + FLNAME=' ' + FPRT=' ' +C +C--The following statement should be uncommented in order to use +C--GETCL to retrieve a command line argument. The call to GETCL may +C--be commented out for compilers that do not support it. + CALL GETARG(1,FLNAME) +C +C--Get Name of NAME File from Screen + IF(FLNAME.EQ.' ') THEN + write(*,102) + 102 format(1x,'Enter Name of the MT3DMS NAME File: ') + read(*,'(a)') flname + ENDIF +C +C-Open files using the Name File method as in MODFLOW-2000 + iflen=index(flname,' ')-1 + inquire(file=flname(1:iflen),exist=existed) + if(.not.existed) then + flname=flname(1:iflen)//'.nam' + inquire(file=flname(1:iflen+4),exist=existed) + if(.not.existed) then + write(*,103) flname(1:iflen),flname(1:iflen+4) + call ustop(' ') + endif + endif + 103 format(1x,'STOP. Specified Name file does not exist: ', + & a,' or ',a) + WRITE(*,104) FLNAME + 104 FORMAT(1x,'Using NAME File: ',a) + iNameFile=99 + OPEN(iNameFile,file=flname,status='old') + CALL BTN5OPEN(iNameFile,IOUT,INBTN,INADV,INDSP,INSSM,INRCT, + & INGCG,INTOB,INHSS,INFTL,FPRT,MXTRNOP,iUnitTRNOP,NameTRNOP) + CLOSE (iNameFile) +C +C--WRITE PROGRAM TITLE TO OUTPUT FILE + WRITE(IOUT,11) + 11 FORMAT(/30X,71('+')/30X,'+',69X,'+' + & /30X,'+',28X,' MT3DMS',32X,'+' + & /30X,'+',13X,'A Modular 3D Multi-Species Transport Model ', + & 13X,'+' + & /30X,'+', 4X,'For Simulation of Advection, Dispersion and', + & ' Chemical Reactions',3X,'+' + & /30X,'+',16X,'of Contaminants in Groundwater Systems',15X,'+' + & /30X,'+',69X,'+'/30X,71('+')/) +C +C--DEFINE PROBLEM DIMENSION AND SIMULATION OPTIONS + CALL BTN5DF(INBTN,IOUT,ISUM,ISUM2,NCOL,NROW,NLAY,NPER, + & NCOMP,MCOMP,MXTRNOP,iUnitTRNOP,NameTRNOP, + & TUNIT,LUNIT,MUNIT,NODES,MXCOMP,iNameFile) + IF(FPRT.EQ.' ') FPRT='N' +C +C--ALLOCATE STORAGE SPACE FOR DATA ARRAYS + CALL BTN5AL(INBTN,IOUT,ISUM,ISUM2,NCOL,NROW,NLAY,NCOMP, + & LCLAYC,LCDELR,LCDELC,LCHTOP,LCDZ,LCPR,LCXBC,LCYBC,LCZBC, + & LCQX,LCQY,LCQZ,LCQSTO,LCDH,LCIB,LCCOLD,LCCNEW,LCCWGT, + & LCCADV,LCRETA,LCSR,LCBUFF,ISOTHM,LCRHOB,LCPRSITY2,LCRETA2) + CALL FMI5AL(INFTL,IOUT,MXTRNOP,iUnitTRNOP,NPERFL,ISS,IVER) + IF(iUnitTRNOP(1).GT.0) + & CALL ADV5AL(iUnitTRNOP(1),IOUT,ISUM,ISUM2,NCOL,NROW,NLAY, + & MCOMP,MIXELM,MXPART,PERCEL,NADVFD,LCXP,LCYP,LCZP, + & LCINDX,LCINDY,LCINDZ,LCCNPT,LCCHEK) + IF(iUnitTRNOP(2).GT.0) + & CALL DSP5AL(iUnitTRNOP(2),IOUT,ISUM,ISUM2,NCOL,NROW,NLAY, + & MCOMP,LCAL,LCTRPT,LCTRPV,LCDM,LCDXX,LCDXY,LCDXZ, + & LCDYX,LCDYY,LCDYZ,LCDZX,LCDZY,LCDZZ) + IF(iUnitTRNOP(3).GT.0) + & CALL SSM5AL(iUnitTRNOP(3),IOUT,ISSGOUT,ISUM,ISUM2, + & NCOL,NROW,NLAY,NCOMP,LCIRCH,LCRECH,LCCRCH,LCIEVT,LCEVTR, + & LCCEVT,MXSS,LCSS,IVER,LCSSMC,LCSSG) + IF(iUnitTRNOP(4).GT.0) + & CALL RCT5AL(iUnitTRNOP(4),IOUT,ISUM,ISUM2, + & NCOL,NROW,NLAY,NCOMP,ISOTHM,IREACT,IRCTOP,IGETSC,LCRHOB, + & LCPRSITY2,LCRETA2,LCFRAC,LCSP1,LCSP2,LCRC1,LCRC2) + IF(iUnitTRNOP(5).GT.0) + & CALL GCG5AL(iUnitTRNOP(5),IOUT,ISUM,ISUM2,NCOL,NROW,NLAY, + & MXITER,ITER1,NCRS,ISOLVE,LCA,LCQ,LCWK,LCCNCG,LCLRCH,LCRHS) + IF(iUnitTRNOP(11).GT.0) THEN + CALL TOB5AL(iUnitTRNOP(11),IOUT,ISUM,ISUM2,NCOL,NROW,NLAY, + & MaxConcObs,MaxFluxObs,MaxFluxCells,LCMLAYER,LCCOBS, + & LCPRLAYER,LCTEMP,LCFLUXGROUP,LCGROUPDATA) + ALLOCATE (cobsnam(MaxConcObs),fobsnam(MaxFluxObs),stat=ierr) + IF(IERR.NE.0) THEN + WRITE(*,105) + 105 FORMAT(1X,'ERROR ALLOCATING MEMORY FOR COBSNAM/FOBSNAM') + CALL USTOP(' ') + ENDIF + ENDIF + IF(iUnitTRNOP(13).GT.0) THEN + CALL HSS5AL(iUnitTRNOP(13),IOUT,ISUM,ISUM2,NCOL,NROW,NLAY, + & MaxHSSSource,MaxHSSCells,MaxHSSStep, + & LCHSSData,LCHSSLoc,iRunHSSM) + ALLOCATE (HSSNAM(MaxHSSSource),stat=ierr) + IF(IERR.NE.0) THEN + WRITE(*,205) + 205 FORMAT(1X,'ERROR ALLOCATING MEMORY FOR HSSNAM') + CALL USTOP(' ') + ENDIF + ENDIF +C +C--CHECK WHETHER ARRAYS X AND IX ARE DIMENSIONED LARGE ENOUGH. +C--IF NOT STOP + ISUMX=ISUM + ISUMIX=ISUM2 + WRITE(IOUT,20) ISUMX,ISUMIX + 20 FORMAT(1X,42('.')/1X,'ELEMENTS OF THE X ARRAY USED =',I10, + & /1X,'ELEMENTS OF THE IX ARRAY USED =',I10, + & /1X,42('.')/) +C + ALLOCATE (X(0:ISUMX),IX(0:ISUMIX),STAT=IERR) + IF(IERR.NE.0) THEN + WRITE(*,106) + 106 FORMAT(1X,'STOP. NOT ENOUGH MEMORY') + CALL USTOP(' ') + ENDIF +C +C--INITIALIZE VARIABLES. + IF(iUnitTRNOP(5).EQ.0) THEN + WRITE(*,107) + 107 FORMAT(1X,'STOP. GCG SOLVER PACKAGE MUST BE ACTIVATED') + CALL USTOP(' ') + ENDIF + IMPSOL=1 + ISPD=1 + IF(MIXELM.EQ.0) ISPD=0 +C +C--INITILIZE ARRAYS. + DO I=1,ISUMX + X(I)=0. + ENDDO + DO I=1,ISUMIX + IX(I)=0 + ENDDO + DO IC=1,NCOMP + DO I=1,122 + TMASIO(I,1,IC)=0. + TMASIO(I,2,IC)=0. + ENDDO + DO I=1,4 + TMASS(I,1,IC)=0. + TMASS(I,2,IC)=0. + TMASS(I,3,IC)=0. + ENDDO + ENDDO +C +C--READ AND PREPARE INPUT DATA RELEVANT TO +C--THE ENTIRE SIMULATION + CALL BTN5RP(INBTN,IOUT,IUCN,IUCN2,IOBS,IMAS,ICNF,ICBM, + & NCOL,NROW,NLAY,NCOMP,ISOTHM,IX(LCLAYC),X(LCDELR),X(LCDELC), + & X(LCHTOP),X(LCDZ),X(LCPR),IX(LCIB),X(LCCOLD),X(LCCNEW), + & X(LCCADV),CINACT,THKMIN,X(LCXBC),X(LCYBC),X(LCZBC), + & X(LCRETA),RFMIN,X(LCBUFF),MXPRS,NPRS,TIMPRS, + & MXOBS,NOBS,NPROBS,LOCOBS,TUNIT,LUNIT,MUNIT) + IF(iUnitTRNOP(1).GT.0) + & CALL ADV5RP(iUnitTRNOP(1),IOUT,NCOL,NROW,NLAY, + & MCOMP,MIXELM,MXPART,NADVFD,NCOUNT) + IF(iUnitTRNOP(2).GT.0) + & CALL DSP5RP(iUnitTRNOP(2),IOUT,NCOL,NROW,NLAY,MCOMP, + & X(LCBUFF),X(LCAL),X(LCTRPT),X(LCTRPV),X(LCDM)) + IF(iUnitTRNOP(4).GT.0) + & CALL RCT5RP(iUnitTRNOP(4),IOUT,NCOL,NROW,NLAY, + & NCOMP,IX(LCIB),X(LCCOLD),X(LCPR),ISOTHM,IREACT,IRCTOP,IGETSC, + & X(LCRHOB),X(LCSP1),X(LCSP2),X(LCSR),X(LCRC1),X(LCRC2),X(LCRETA), + & X(LCBUFF),X(LCPRSITY2),X(LCRETA2),X(LCFRAC),RFMIN,IFMTRF,DTRCT) + IF(iUnitTRNOP(5).GT.0) + & CALL GCG5RP(iUnitTRNOP(5),IOUT,MXITER, + & ITER1,ISOLVE,ACCL,CCLOSE,IPRGCG) + IF(iUnitTRNOP(11).GT.0) + & CALL TOB5RP(iUnitTRNOP(11),IOUT,NCOL,NROW,NLAY, + & NCOMP,MaxConcObs,MaxFluxObs,MaxFluxCells,inConcObs,nConcObs, + & CScale,iOutCobs,iConcLOG,iConcINTP,COBSNAM, + & X(LCCOBS),IX(LCMLAYER),X(LCPRLAYER),X(LCTEMP), + & inFluxObs,nFluxGroup,nFluxObs,FScale, + & iOutFlux,inSaveObs,FOBSNAM,X(LCFLUXGROUP),X(LCGROUPDATA)) + IF(iUnitTRNOP(13).GT.0) + & CALL HSS5RP(iUnitTRNOP(13),IOUT,NCOL,NROW,NLAY,NCOMP, + & IX(LCIB),X(LCDELR),X(LCDELC),X(LCXBC),X(LCYBC),MaxHSSSource, + & MaxHSSCells,MaxHSSStep,nHSSSource,faclength,factime,facmass, + & X(LCHSSData),IX(LCHSSLoc),HSSNAM,iRunHSSM) +C +C--FOR EACH STRESS PERIOD*********************************************** + HT1=0. + HT2=0. + DTRANS=0. + NPS=1 + DO KPER=1,NPER +C +C--WRITE AN INDENTIFYING MESSAGE + WRITE(*,50) KPER + WRITE(IOUT,51) KPER + WRITE(IOUT,'(1X)') + 50 FORMAT(/1X,'STRESS PERIOD NO.',I5) + 51 FORMAT(//35X,62('+')/55X,'STRESS PERIOD NO.',I5.3/35X,62('+')) +C +C--GET STRESS TIMING INFORMATION + CALL BTN5ST(INBTN,IOUT,NSTP,MXSTP,TSLNGH,DT0,MXSTRN,TTSMULT, + & TTSMAX,TUNIT,iSSTrans) +C +C--READ AND PREPARE INPUT INFORMATION WHICH IS CONSTANT +C--WITHIN EACH STRESS PERIOD + IF(iUnitTRNOP(3).GT.0) + & CALL SSM5RP(iUnitTRNOP(3),IOUT,KPER, + & NCOL,NROW,NLAY,NCOMP,IX(LCIB),X(LCCNEW),X(LCCRCH), + & X(LCCEVT),MXSS,NSS,X(LCSS),X(LCSSMC)) +C +C--FOR EACH FLOW TIME STEP---------------------------------------------- + DO KSTP=1,NSTP + DELT=TSLNGH(KSTP) + HT1=HT2 + HT2=HT2+DELT +C +C--WRITE AN INDENTIFYING MESSAGE + WRITE(*,60) KSTP,HT1,HT2 + WRITE(IOUT,61) KSTP,HT1,HT2 + WRITE(IOUT,'(1X)') + 60 FORMAT(/1X,'TIME STEP NO.',I5 + & /1X,'FROM TIME =',G13.5,' TO ',G13.5/) + 61 FORMAT(//42X,48('=')/57X,'TIME STEP NO.',I5.3/42X,48('=') + & //1X,'FROM TIME =',G13.5,' TO ',G13.5) +C +C--READ AND PROCESS SATURATED THICKNESS, VELOCITY COMPONENTS +C--ACROSS CELL INTERFACES, AND SINK/SOURCE INFORMATION +C--(NOTE THAT THESE ITEMS ARE READ ONLY ONCE IF FLOW MODEL +C--IS STEADY-STATE AND HAS SINGLE STRESS PERIOD) + IF(KPER*KSTP.GT.1.AND.ISS.NE.0.AND.NPERFL.EQ.1) GOTO 70 +C + CALL FMI5RP1(INFTL,IOUT,KPER,KSTP,NCOL,NROW,NLAY, + & NCOMP,FPRT,IX(LCLAYC),IX(LCIB),HORIGN,X(LCDH),X(LCPR), + & X(LCDELR),X(LCDELC),X(LCDZ),X(LCXBC),X(LCYBC),X(LCZBC), + & X(LCQSTO),X(LCCOLD),X(LCCNEW),X(LCRETA),X(LCQX), + & X(LCQY),X(LCQZ),DTRACK,DTRACK2,THKMIN,ISS,IVER) + IF(iUnitTRNOP(3).GT.0) + & CALL FMI5RP2(INFTL,IOUT,KPER,KSTP,NCOL,NROW,NLAY, + & NCOMP,FPRT,IX(LCLAYC),IX(LCIB),X(LCDH),X(LCPR),X(LCDELR), + & X(LCDELC),IX(LCIRCH),X(LCRECH),IX(LCIEVT),X(LCEVTR), + & MXSS,NSS,NTSS,X(LCSS),X(LCBUFF),DTSSM) +C +C--CALCULATE COEFFICIENTS THAT VARY WITH FLOW-MODEL TIME STEP + IF(iUnitTRNOP(2).GT.0) + & CALL DSP5CF(IOUT,KSTP,KPER,NCOL,NROW,NLAY,MCOMP, + & IX(LCIB),X(LCPR),X(LCDELR),X(LCDELC),X(LCDH), + & X(LCQX),X(LCQY),X(LCQZ),X(LCAL),X(LCTRPT),X(LCTRPV), + & X(LCDM),DTDISP,X(LCDXX),X(LCDXY),X(LCDXZ),X(LCDYX), + & X(LCDYY),X(LCDYZ),X(LCDZX),X(LCDZY),X(LCDZZ),IFMTDP) +C + 70 CONTINUE +C +C--FOR EACH TRANSPORT STEP.............................................. + TIME2=HT1 + DO N=1,MXSTRN +C +C--ADVANCE ONE TRANSPORT STEP + CALL BTN5AD(IOUT,N,MXTRNOP,iUnitTRNOP,iSSTrans, + & TIME1,TIME2,HT2,DELT, + & KSTP,NSTP,MXPRS,TIMPRS,DT0,MXSTRN,MIXELM,DTRACK,DTRACK2, + & PERCEL,DTDISP,DTSSM,DTRCT,RFMIN,NPRS,NPS,DTRANS,PRTOUT, + & NCOL,NROW,NLAY,NCOMP,IX(LCIB),X(LCCNEW),X(LCCOLD), + & CINACT,UPDLHS,IMPSOL,TTSMULT,TTSMAX,KPER,X(LCDELR), + & X(LCDELC),X(LCDH),X(LCPR),X(LCSR),X(LCRHOB),X(LCRETA), + & X(LCPRSITY2),X(LCRETA2),ISOTHM,TMASIO,RMASIO,TMASS) +C +C--FOR EACH COMPONENT...... + DO ICOMP=1,NCOMP +C +C--SOLVE TRANSPORT TERMS WITH EXPLICIT SCHEMES + IF(MIXELM.EQ.0) GOTO 1500 +C +C--FORMULATE AND SOLVE + CALL BTN5SV(NCOL,NROW,NLAY,NCOMP,ICOMP,IX(LCIB), + & X(LCCNEW),X(LCCWGT),CINACT,RMASIO) + IF(iUnitTRNOP(1).GT.0 .AND. ICOMP.LE.MCOMP) + & CALL ADV5SV(IOUT,NCOL,NROW,NLAY,MCOMP,ICOMP, + & MIXELM,MXPART,NCOUNT,NPINS,NRC,IX(LCCHEK), + & X(LCXP),X(LCYP),X(LCZP),IX(LCINDX),IX(LCINDY), + & IX(LCINDZ),X(LCCNPT),IX(LCIB),X(LCDELR),X(LCDELC), + & X(LCDZ),X(LCXBC),X(LCYBC),X(LCZBC),X(LCDH), + & X(LCPR),X(LCQX),X(LCQY),X(LCQZ),X(LCRETA), + & X(LCCOLD),X(LCCWGT),X(LCCNEW),X(LCCADV), + & X(LCBUFF),DTRANS,IMPSOL,NADVFD,RMASIO) +C + 1500 CONTINUE +C +C--SOLVE TRANSPORT TERMS WITH IMPLICIT SCHEMES + IF(DTRANS.EQ.0) THEN + ICNVG=1 + GOTO 110 + ENDIF +C +C--ALWAYS UPDATE MATRIX IF NONLINEAR SORPTION OR MULTICOMPONENT + IF(iUnitTRNOP(4).GT.0.AND.ISOTHM.GT.1) UPDLHS=.TRUE. + IF(NCOMP.GT.1) UPDLHS=.TRUE. +C +C--FOR EACH OUTER ITERATION... + DO ITO=1,MXITER +C +C--UPDATE COEFFICIENTS THAT VARY WITH ITERATIONS + IF(iUnitTRNOP(4).GT.0.AND.ISOTHM.GT.1) + & CALL RCT5CF(NCOL,NROW,NLAY,NCOMP,ICOMP,IX(LCIB), + & X(LCPR),X(LCCNEW),X(LCRETA),RFMIN,X(LCRHOB),X(LCSP1), + & X(LCSP2),X(LCRC1),X(LCRC2),X(LCPRSITY2),X(LCRETA2), + & X(LCFRAC),X(LCSR),ISOTHM,IREACT,DTRANS) +C +C--FORMULATE MATRIX COEFFICIENTS + CALL BTN5FM(NCOL,NROW,NLAY,NCOMP,ICOMP,IX(LCIB), + & X(LCCADV),X(LCCOLD),X(LCRETA),X(LCPR),X(LCDELR), + & X(LCDELC),X(LCDH),DTRANS, + & X(LCA),X(LCRHS),NODES,UPDLHS,NCRS,MIXELM,iSSTrans) + IF(iUnitTRNOP(1).GT.0.AND.MIXELM.EQ.0 + & .AND. ICOMP.LE.MCOMP) + & CALL ADV5FM(NCOL,NROW,NLAY,MCOMP,ICOMP,IX(LCIB), + & X(LCDELR),X(LCDELC),X(LCDH),X(LCQX),X(LCQY),X(LCQZ), + & NADVFD,NODES,X(LCA),UPDLHS) + IF(iUnitTRNOP(2).GT.0 .AND. ICOMP.LE.MCOMP) + & CALL DSP5FM(NCOL,NROW,NLAY,MCOMP,ICOMP,IX(LCIB), + & X(LCDELR),X(LCDELC),X(LCDH),X(LCDXX),X(LCDXY), + & X(LCDXZ),X(LCDYX),X(LCDYY),X(LCDYZ),X(LCDZX), + & X(LCDZY),X(LCDZZ),X(LCA),NODES,UPDLHS,X(LCCNEW), + & X(LCRHS),NCRS) + IF(iUnitTRNOP(3).GT.0 .AND. ICOMP.LE.MCOMP) + & CALL SSM5FM(NCOL,NROW,NLAY,NCOMP,ICOMP,IX(LCIB), + & X(LCDELR),X(LCDELC),X(LCDH),IX(LCIRCH),X(LCRECH), + & X(LCCRCH),IX(LCIEVT),X(LCEVTR),X(LCCEVT),MXSS,NTSS, + & X(LCSS),X(LCSSMC),X(LCSSG),X(LCQSTO),X(LCCNEW),ISS, + & X(LCA),X(LCRHS),NODES,UPDLHS,MIXELM) + IF(iUnitTRNOP(13).GT.0 .AND. ICOMP.LE.MCOMP) + & CALL HSS5FM(NCOL,NROW,NLAY,NCOMP,ICOMP,MIXELM,UPDLHS, + & MaxHSSSource,MaxHSSStep,MaxHSSCells,nHSSSource, + & TIME1,TIME2,IX(LCIB),X(LCA),X(LCRHS),NODES, + & X(LCHSSData),IX(LCHSSLoc)) + IF(iUnitTRNOP(4).GT.0) + & CALL RCT5FM(NCOL,NROW,NLAY,NCOMP,ICOMP, + & IX(LCIB),X(LCPR),X(LCDELR),X(LCDELC),X(LCDH),ISOTHM, + & IREACT,X(LCRHOB),X(LCSP1),X(LCSP2),X(LCSR),X(LCRC1), + & X(LCRC2),X(LCPRSITY2),X(LCRETA2),X(LCFRAC),X(LCA), + & X(LCRHS),NODES,UPDLHS,DTRANS) + IF(iUnitTRNOP(5).GT.0) + & CALL GCG5AP(IOUT,MXITER,ITER1,ITO,ITP,ISOLVE,ACCL, + & CCLOSE,ICNVG,X(LCCNCG),IX(LCLRCH),NCOL,NROW,NLAY, + & NODES,N,KSTP,KPER,TIME2,HT2,UPDLHS,IPRGCG, + & IX(LCIB+(ICOMP-1)*NODES),CINACT,X(LCA), + & X(LCCNEW+(ICOMP-1)*NODES),X(LCRHS),X(LCQ),X(LCWK), + & NCRS,ISPD) +C +C--IF CONVERGED, GO TO NEXT OUTER ITERATION + IF(ICNVG.EQ.1) GOTO 110 +C +C--END OF OUTER ITERATION LOOP + ENDDO + 110 CONTINUE +C +C--END OF COMPONENT LOOP + ENDDO +C +C--CALCULATE MASS BUDGETS AND SAVE RESULTS FOR ALL COMPONENTS + DO ICOMP=1,NCOMP +C +C--CALCULATE MASS BUDGETS FOR IMPLICIT SCHEMES +C + IF(iUnitTRNOP(1).GT.0.AND.MIXELM.EQ.0 + & .AND. ICOMP.LE.MCOMP) + & CALL ADV5BD(IOUT,NCOL,NROW,NLAY,MCOMP,ICOMP,NADVFD, + & IX(LCIB),X(LCDELR),X(LCDELC),X(LCDH),X(LCQX),X(LCQY), + & X(LCQZ),X(LCCNEW),DTRANS,RMASIO) + IF(iUnitTRNOP(2).GT.0 .AND. ICOMP.LE.MCOMP) + & CALL DSP5BD(NCOL,NROW,NLAY,MCOMP,ICOMP,IX(LCIB), + & X(LCDELR),X(LCDELC),X(LCDH),X(LCDXX),X(LCDXY),X(LCDXZ), + & X(LCDYX),X(LCDYY),X(LCDYZ),X(LCDZX),X(LCDZY),X(LCDZZ), + & X(LCCNEW),X(LCBUFF),DTRANS,RMASIO) + IF(iUnitTRNOP(3).GT.0 .AND. ICOMP.LE.MCOMP) + & CALL SSM5BD(NCOL,NROW,NLAY,NCOMP,ICOMP,IX(LCIB), + & X(LCDELR),X(LCDELC),X(LCDH),IX(LCIRCH),X(LCRECH), + & X(LCCRCH),IX(LCIEVT),X(LCEVTR),X(LCCEVT),MXSS,NTSS, + & X(LCSS),X(LCSSMC),X(LCSSG),X(LCQSTO),X(LCCNEW),X(LCRETA), + & DTRANS,ISS,RMASIO) + IF(iUnitTRNOP(13).GT.0 .AND. ICOMP.LE.MCOMP) + & CALL HSS5BD(NCOL,NROW,NLAY,NCOMP,ICOMP,NODES,IX(LCIB), + & MaxHSSSource,MaxHSSStep,MaxHSSCells,nHSSSource,50, + & TIME1,TIME2,X(LCHSSData),IX(LCHSSLoc),RMASIO,DTRANS) + IF(iUnitTRNOP(4).GT.0) + & CALL RCT5BD(NCOL,NROW,NLAY,NCOMP,ICOMP, + & IX(LCIB),X(LCPR),X(LCDELR),X(LCDELC),X(LCDH),DTRANS, + & ISOTHM,IREACT,X(LCRHOB),X(LCSP1),X(LCSP2),X(LCSR), + & X(LCRC1),X(LCRC2),X(LCPRSITY2),X(LCRETA2),X(LCFRAC), + & X(LCCNEW),X(LCRETA),RFMIN,RMASIO) +C +C--CALCULATE GLOBAL MASS BUDGETS AND CHECK MASS BALANCE + CALL BTN5BD(KPER,KSTP,N,NCOL,NROW,NLAY,NCOMP,ICOMP, + & ISS,iSSTrans,IX(LCIB),X(LCDELR),X(LCDELC),X(LCDH), + & X(LCPR),X(LCRETA),X(LCCNEW),X(LCCOLD),X(LCRHOB), + & X(LCSR),X(LCPRSITY2),X(LCRETA2),ISOTHM, + & DTRANS,TMASIN,TMASOT,ERROR,ERROR2,TMASIO,RMASIO,TMASS) +C +C--SAVE OUTPUTS + CALL BTN5OT(NCOL,NROW,NLAY,KPER,KSTP,N,NCOMP,ICOMP,IOUT, + & IOBS,IUCN,IUCN2,IMAS,ICBM,MXOBS,NOBS,NPROBS,LOCOBS, + & IX(LCIB),TIME2,X(LCCNEW),MIXELM,NCOUNT,NPINS,NRC, + & IX(LCCHEK),ISOTHM,X(LCRETA),X(LCSR),TMASIN,TMASOT, + & ERROR,ERROR2,MXTRNOP,iUnitTRNOP,TUNIT,MUNIT,PRTOUT, + & TMASIO,RMASIO,TMASS) + IF(FMNW) CALL SSM5OT(NCOL,NROW,NLAY,KPER,KSTP,N,NCOMP, + & ICOMP,IX(LCIB),MXSS,NTSS,NSS,X(LCSS),X(LCSSG),PRTOUT, + & TIME2,IOUT,ISSGOUT) + IF(iUnitTRNOP(11).GT.0) THEN + if(inConcOBS.GT.0) then + call ConcObs(inConcObs,iout,ncol,nrow,nlay,ncomp, + & kper,kstp,n,time1,time2,X(LCCNEW),cinact, + & IX(LCIB),X(LCdelr),X(LCdelc), + & X(LCxbc),X(LCybc),nConcObs,X(LCCOBS),cobsnam, + & IX(LCMLAYER),X(LCPRLAYER),X(LCTEMP),inSaveObs, + & iOutCobs,iConcLOG,iConcINTP) + endif + if(inFluxObs.GT.0) then + call MassFluxObs(inFluxObs,iout,ncol,nrow,nlay,ncomp, + & MaxFluxCells,nFLuxGroup,nFLuxObs,kper,kstp,n, + & time1,time2,X(LCCNEW),IX(LCIB),mxss,ntss,X(LCSS), + & X(LCSSMC),X(LCdelr),X(LCdelc),X(LCdh),IX(LCIRCH), + & X(LCRECH),X(LCCRCH),IX(LCIEVT),X(LCEVTR),X(LCCEVT), + & X(LCFluxGroup),X(LCGroupData), + & fobsnam,x(LCTEMP),inSaveObs,iOutFlux) + endif + ENDIF +C + ENDDO !done with budget and output +C + IF(TIME2.GE.HT2) GOTO 900 + IF(ICNVG.EQ.0) THEN + WRITE(*,808) + 808 FORMAT(1X,'STOP. GCG SOLVER FAILED TO CONVERGE.') + CALL USTOP(' ') + ENDIF +C +C--END OF TRANSPORT STEP LOOP + ENDDO +C + IF(TIME2.LT.HT2) THEN + WRITE(IOUT,810) MXSTRN + 810 FORMAT(/1X,'NUMBER OF TRANSPORT STEPS EXCEEDS', + & ' SPECIFIED MAXIMUM (MXSTRN) =',I10) + CALL USTOP(' ') + ENDIF + 900 CONTINUE +C +C--END OF FLOW TIME STEP LOOP + ENDDO +C +C--END OF STRESS PERIOD LOOP + ENDDO +C +C--DEALLOCATE MEMORY + DEALLOCATE (X,IX) + if(iUnitTRNOP(11).GT.0) DEALLOCATE (COBSNAM,FOBSNAM) + if(iUnitTRNOP(13).GT.0) DEALLOCATE (HSSNAM) +C +C--PROGRAM COMPLETED + WRITE(IOUT,1200) + WRITE(IOUT,1225) + WRITE(IOUT,1200) + 1200 FORMAT(1X,' ----- ') + 1225 FORMAT(1X,'| M T |' + & /1X,'| 3 D | END OF MODEL OUTPUT') +C +C--Get CPU time at the end of simulation +C--and print out total elapsed time in seconds + Call CPU_TIME(end_time) + total_time = end_time - start_time + Write(*,2010) int(total_time/60.),mod(total_time,60.) + 2010 FORMAT(/1X,'Program completed. ', + & 'Total CPU time:',i5.3,' minutes ',f6.3,' seconds') +C + STOP + END \ No newline at end of file diff --git a/true-binary/mt_adv5.for b/true-binary/mt_adv5.for index e69de29..cea691a 100644 --- a/true-binary/mt_adv5.for +++ b/true-binary/mt_adv5.for @@ -0,0 +1,2761 @@ +C + SUBROUTINE ADV5AL(INADV,IOUT,ISUM,ISUM2,NCOL,NROW,NLAY,MCOMP, + & MIXELM,MXPART,PERCEL,NADVFD,LCXP,LCYP,LCZP,LCINDX,LCINDY, + & LCINDZ,LCCNPT,LCCHEK) +C ********************************************************************** +C THIS SUBROUTINE ALLOCATES SPACE FOR ARRAYS NEEDED BY THE ADVECTION +C (ADV) PACKAGE. +C ********************************************************************** +C last modified: 02-20-2010 +C + IMPLICIT NONE + INTEGER INADV,IOUT,ISUM,ISUM2,NCOL,NROW,NLAY,MIXELM,MXPART, + & NADVFD,LCXP,LCYP,LCZP,LCCNPT,LCCHEK,ISUMX,ISUMIX, + & NODES,LCINDX,LCINDY,LCINDZ,ISOLD,ISOLD2,IERR,MCOMP + REAL PERCEL +C +C--PRINT PACKAGE NAME AND VERSION NUMBER + WRITE(IOUT,1030) INADV + 1030 FORMAT(1X,'ADV5 -- ADVECTION PACKAGE,', + & ' VERSION 5, FEBRUARY 2010, INPUT READ FROM UNIT',I3) +C +C--READ ADVECTION SOLUTION OPTION AND MAXIMUM PARTICLES ALLOWED + MIXELM=0 + PERCEL=0 + MXPART=0 + NADVFD=0 + READ(INADV,'(I10,F10.0,2I10)',ERR=10,IOSTAT=IERR) + & MIXELM,PERCEL,MXPART,NADVFD + 10 IF(IERR.NE.0) THEN + REWIND(INADV) + READ(INADV,'(I10,F10.0,I10)') + & MIXELM,PERCEL,MXPART + ENDIF + IF(MIXELM.EQ.0 .AND. NADVFD.NE.1.AND.NADVFD.NE.2) NADVFD=1 + IF(MIXELM.GT.0) NADVFD=1 +C +C--ECHO AND CHECK POTENTIAL INPUT ERRORS +C + IF(MIXELM.EQ.1) WRITE(IOUT,1000) + IF(MIXELM.EQ.2) WRITE(IOUT,1002) + IF(MIXELM.EQ.3) WRITE(IOUT,1004) + IF(MIXELM.EQ.0.AND.NADVFD.EQ.1) WRITE(IOUT,1006) + IF(MIXELM.EQ.0.AND.NADVFD.EQ.2) WRITE(IOUT,1007) + IF(MIXELM.EQ.-1) WRITE(IOUT,2007) + IF(MIXELM.LT.-1.OR.MIXELM.GT.3) THEN + WRITE(*,1008) MIXELM + CALL USTOP(' ') + ENDIF +C + WRITE(IOUT,1038) PERCEL + IF(PERCEL.LE.1.E-5) THEN + WRITE(*,1040) + CALL USTOP(' ') + ENDIF + IF(MIXELM.LT.0.AND.PERCEL.GT.1.0) THEN + WRITE(*,1043) + PERCEL=1.0 + ENDIF +C + IF(MIXELM.EQ.1.OR.MIXELM.EQ.3) THEN + WRITE(IOUT,1050) MXPART + IF(MXPART.LE.0) THEN + WRITE(*,1052) + CALL USTOP(' ') + ENDIF + ENDIF +C + 1000 FORMAT(1X,'ADVECTION IS SOLVED WITH THE [MOC] SCHEME') + 1002 FORMAT(1X,'ADVECTION IS SOLVED WITH THE [MMOC] SCHEME') + 1004 FORMAT(1X,'ADVECTION IS SOLVED WITH', + & ' THE HYBRID [MOC]/[MMOC] SCHEME') + 1006 FORMAT(1X,'ADVECTION IS SOLVED WITH', + & ' THE UPSTREAM FINITE DIFFERENCE SCHEME') + 1007 FORMAT(1X,'ADVECTION IS SOLVED WITH', + & ' THE CENTRAL FINITE DIFFERENCE SCHEME') + 2007 FORMAT(1X,'ADVECTION IS SOLVED WITH', + & ' THE ULTIMATE SCHEME') + 1008 FORMAT(/1X,'ERROR: INPUT VALUE FOR [MIXELM] =',I3, + & /1X,'ENTER A VALUE BETWEEN -1 AND 3') + 1038 FORMAT(1X,'COURANT NUMBER ALLOWED IN SOLVING', + & ' THE ADVECTION TERM =',G10.3) + 1040 FORMAT(/1X,'ERROR: COURANT NUMBER [PERCEL] MUST BE >0.', + & /1X,'ENTER A VALID VALUE OF [PERCEL] IN ADVECTION INPUT FILE.') + 1043 FORMAT(/1X,'WARNING: COURANT NUMBER [PERCEL] MUST NOT EXCEED 1.0', + &/1X,'FOR THE 3RD-ORDER ULTIMATE SCHEME; RESET TO DEFAULT OF 1.0.') + 1050 FORMAT(1X,'MAXIMUM NUMBER OF MOVING PARTICLES ALLOWED =',I8) + 1052 FORMAT(/1X,'ERROR: MAXIMUM NUMBER OF PARTICLES MUST BE >0 ', + & ' FOR MOC/HMOC SOLUTION OPTION', + & /1X,'ENTER A VALID VALUE FOR [MXPART] IN ADVECTION INPUT FILE') +C +C--ALLOCATE SPACE FOR ARRAYS + ISOLD=ISUM + ISOLD2=ISUM2 + NODES=NCOL*NROW*NLAY +C +C--INTEGER ARRAYS + LCCHEK=ISUM2 + IF(MIXELM.GT.0) ISUM2=ISUM2+NODES * MCOMP + LCINDX=ISUM2 + IF(NCOL.GT.1.AND.MIXELM.GT.0) ISUM2=ISUM2+MXPART * MCOMP + LCINDY=ISUM2 + IF(NROW.GT.1.AND.MIXELM.GT.0) ISUM2=ISUM2+MXPART * MCOMP + LCINDZ=ISUM2 + IF(NLAY.GT.1.AND.MIXELM.GT.0) ISUM2=ISUM2+MXPART * MCOMP +C +C--REAL ARRAYS + LCXP=ISUM + IF(NCOL.GT.1.AND.MIXELM.GT.0) ISUM=ISUM+MXPART * MCOMP + LCYP=ISUM + IF(NROW.GT.1.AND.MIXELM.GT.0) ISUM=ISUM+MXPART * MCOMP + LCZP=ISUM + IF(NLAY.GT.1.AND.MIXELM.GT.0) ISUM=ISUM+MXPART * MCOMP + LCCNPT=ISUM + IF(MIXELM.GT.0) ISUM=ISUM+MXPART*2 * MCOMP +C +C--CHECK HOW MANY ELEMENTS OF THE X AND IX ARRAYS ARE USED + ISUMX=ISUM-ISOLD + ISUMIX=ISUM2-ISOLD2 + WRITE(IOUT,1090) ISUMX,ISUMIX + 1090 FORMAT(1X,I10 ,' ELEMENTS OF THE X ARRAY USED BY THE ADV PACKAGE' + & /1X,I10,' ELEMENTS OF THE IX ARRAY USED BY THE ADV PACKAGE'/) +C +C--NORMAL RETURN + RETURN + END +C +C + SUBROUTINE ADV5RP(IN,IOUT,NCOL,NROW,NLAY,MCOMP,MIXELM, + & MXPART,NADVFD,NCOUNT) +C ********************************************************************* +C THIS SUBROUTINE READS AND PREPARES INPUT DATA NEEDED BY THE ADVECTION +C (ADV) PACKAGE. +C********************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER IN,IOUT,NCOL,NROW,NLAY,MCOMP,MIXELM,NCOUNT, + & ITRACK,NPLANE,NPL,NPH,NPMIN,NPMAX,INTERP,NLSINK, + & NPSINK,ISEED,MXPART,NADVFD,INDEX + REAL PERCEL,WD,DCEPS,SRMULT,DCHMOC + DIMENSION NCOUNT(MCOMP) + COMMON /AD/PERCEL,ITRACK,WD,ISEED,DCEPS,NPLANE,NPL,NPH, + & NPMIN,NPMAX,SRMULT,INTERP,NLSINK,NPSINK,DCHMOC +C +C--READ AND PRINT SOLUTION OPTIONS + WRITE(IOUT,1000) + 1000 FORMAT(//1X,'ADVECTION SOLUTION OPTIONS'/1X,26('-')/) +C + IF(MIXELM.EQ.1) WRITE(IOUT,100) + IF(MIXELM.EQ.2) WRITE(IOUT,102) + IF(MIXELM.EQ.3) WRITE(IOUT,104) + IF(MIXELM.EQ.0.AND.NADVFD.EQ.1) WRITE(IOUT,106) + IF(MIXELM.EQ.0.AND.NADVFD.EQ.2) WRITE(IOUT,107) + IF(MIXELM.EQ.-1) WRITE(IOUT,207) + WRITE(IOUT,238) PERCEL + IF(MIXELM.GT.0) WRITE(IOUT,250) MXPART + 100 FORMAT(1X,'ADVECTION IS SOLVED WITH THE [MOC] SCHEME') + 102 FORMAT(1X,'ADVECTION IS SOLVED WITH THE [MMOC] SCHEME') + 104 FORMAT(1X,'ADVECTION IS SOLVED WITH', + & ' THE HYBRID [MOC]/[MMOC] SCHEME') + 106 FORMAT(1X,'ADVECTION IS SOLVED WITH', + & ' THE UPSTREAM FINITE DIFFERENCE SCHEME') + 107 FORMAT(1X,'ADVECTION IS SOLVED WITH', + & ' THE CENTRAL FINITE DIFFERENCE SCHEME') + 207 FORMAT(1X,'ADVECTION IS SOLVED WITH', + & ' THE ULTIMATE SCHEME') + 238 FORMAT(1X,'COURANT NUMBER ALLOWED IN SOLVING', + & ' THE ADVECTION TERM =',G10.3) + 250 FORMAT(1X,'MAXIMUM NUMBER OF MOVING PARTICLES ALLOWED =',I8) + + IF(MIXELM.EQ.1.OR.MIXELM.EQ.2.OR.MIXELM.EQ.3) THEN + READ(IN,'(I10,F10.0)') ITRACK,WD + IF(ITRACK.EQ.1) THEN + WRITE(IOUT,1030) + ELSEIF(ITRACK.EQ.2) THEN + WRITE(IOUT,1032) + ELSEIF(ITRACK.EQ.3) THEN + WRITE(IOUT,1034) + ELSE + WRITE(IOUT,1036) + ITRACK=1 + ENDIF + WRITE(IOUT,1040) WD + IF(WD.LT.0.5) THEN + WRITE(IOUT,1042) + WD=0.5 + ENDIF + ELSE + WD=0. + ENDIF + 1030 FORMAT(1X,'METHOD FOR PARTICLE TRACKING IS [1ST ORDER]') + 1032 FORMAT(1X,'METHOD FOR PARTICLE TRACKING IS [4TH ORDER]') + 1034 FORMAT(1X,'METHOD FOR PARTICLE TRACKING IS [MIXED ORDER]') + 1036 FORMAT(1X,'METHOD FOR PARTICLE TRACKING IS UNDEFINED.', + & /1X,'THE 1ST ORDER METHOD IS USED AS DEFAULT.') + 1040 FORMAT(1X,'CONCENTRATION WEIGHTING FACTOR [WD] =',F10.3) + 1042 FORMAT(1X,'ERROR: [WD] MUST BE GREATER OR EQUAL TO 0.5;', + & /1X,' THE DEFAULT VALUE OF 0.5 IS USED.') +C +C--IF MIXELM=1 OR 3, READ PARTICLE CONTROL PARAMETERS + IF(MIXELM.EQ.1.OR.MIXELM.EQ.3) THEN + READ(IN,1045) DCEPS,NPLANE,NPL,NPH,NPMIN,NPMAX + 1045 FORMAT(F10.0,5I10) +C +C--SET [SRMULT] TO DEFAULT VALUE OF 1. + SRMULT=1.0 +C + WRITE(IOUT,1020) DCEPS + IF(NPLANE.GT.0) THEN + WRITE(IOUT,1022) NPLANE + ELSE + WRITE(IOUT,1025) + ENDIF + WRITE(IOUT,1050) NPL,NPH,NPMIN,NPMAX,SRMULT + ENDIF + 1020 FORMAT(1X,'THE CONCENTRATION GRADIENT CONSIDERED NEGLIGIBLE', + & ' [DCEPS] =',G15.7) + 1022 FORMAT(1X,'INITIAL PARTICLES ARE PLACED ON ',I2, + & ' VERTICAL PLANE(S) WITHIN CELL BLOCK') + 1025 FORMAT(1X,'INITIAL PARTICLES ARE PLACED RANDOMLY', + & ' WITHIN CELL BLOCK') + 1050 FORMAT(1X,'PARTICLE NUMBER PER CELL IF DCCELL =< DCEPS =',I5, + & /1X,'PARTICLE NUMBER PER CELL IF DCCELL > DCEPS =',I5, + & /1X,'MINIMUM PARTICLE NUMBER ALLOWD PER CELL =',I5, + & /1X,'MAXIMUM PARTICLE NUMBER ALLOWD PER CELL =',I5, + & /1X,'MULTIPLIER OF PARTICLE NUMBER AT SOURCE =',G10.3) +C +C--IF MIXELM=2 OR 3, READ INTERPOLATION OPTION + IF(MIXELM.EQ.2.OR.MIXELM.EQ.3) THEN + READ(IN,'(3I10)') INTERP,NLSINK,NPSINK + INTERP=1 + WRITE(IOUT,1052) + IF(NLSINK.GT.0) THEN + WRITE(IOUT,1058) NLSINK + ELSE + WRITE(IOUT,1059) + ENDIF + WRITE(IOUT,1060) NPSINK + ENDIF + 1052 FORMAT(1X,'SCHEME FOR CONCENTRATION INTERPOLATION IS [LINEAR]') + 1058 FORMAT(1X,'PARTICLES FOR APPROXIMATING', + & ' A SINK CELL IN THE [MMOC] SCHEME'/1X,'ARE PLACED ON ',I2, + & ' VERTICAL PLANE(S) WITHIN CELL BLOCK') + 1059 FORMAT(1X,'PARTICLES FOR APPROXIMATING', + & ' A SINK CELL IN THE [MMOC] SCHEME', + & /1X,'ARE PLACED RANDOMLY WITHIN CELL BLOCK') + 1060 FORMAT(1X,'NUMBER OF PARTICLES USED TO APPROXIMATE A SINK CELL', + & ' IN THE [MMOC] SCHEME =',I4) +C +C--READ IF HYBRID [MOC]/[MMOC] SCHEME IS USED + IF(MIXELM.EQ.3) THEN + READ(IN,'(F10.0)') DCHMOC + WRITE(IOUT,1070) DCHMOC + ENDIF + 1070 FORMAT(1X,'CRITICAL CONCENTRATION GRADIENT USED IN ', + & 'THE "HMOC" SCHEME [DCHMOC] =',G11.4, + & /1X,'THE "MOC" SOLUTION IS USED WHEN DCCELL > DCHMOC' + & /1X,'THE "MMOC" SOLUTION IS USED WHEN DCCELL =< DCHMOC') +C +C--INITIALIZE PARTICLE NUMBER COUNTER [NCOUNT] +C--AND RANDOM NUMBER GENERATOR SEED [ISEED] IN CASE IT IS NEEDED + DO INDEX=1,MCOMP + NCOUNT(INDEX)=0 + ENDDO + ISEED=-NCOL*NROW*NLAY +C +C--RETURN + RETURN + END +C +C + SUBROUTINE ADV5SV(IOUT,NCOL,NROW,NLAY,MCOMP,ICOMP,MIXELM,MXPART, + & NCOUNT,NPINS,NRC,NPCHEK,XP,YP,ZP,INDEXX,INDEXY,INDEXZ,CNPT, + & ICBUND,DELR,DELC,DZ,XBC,YBC,ZBC,DH,PRSITY,QX,QY,QZ,RETA,COLD, + & CWGT,CNEW,CADV,BUFF,DTRANS,IMPSOL,NADVFD,RMASIO) +C ********************************************************************** +C THIS SUBROUTINE CALCULATES CONCENTRATIONS AT THE INTERMEDIATE TIME +C LEVEL DUE TO ADVECTION WITH THE MIXED EULERIAN-LAGRANGIAN SCHEMES. +C ALSO INCLUDED ARE EXPLICIT UPSTREAM FINITE DIFFERENCE AND THIRD-ORDER +C TVD (ULTIMATE) SCHEMES. +C ********************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER IOUT,NCOL,NROW,NLAY,MCOMP,ICOMP,NCOUNT,NPCHEK,ICBUND, + & MIXELM,MXPART,J,I,K,ITRACK,NPL,NPH,NPMIN, + & NPMAX,INTERP,NLSINK,NPSINK,NPLANE,NPINS,NRC, + & ISEED,INDEXX,INDEXY,INDEXZ,IMPSOL,NADVFD + REAL XP,YP,ZP,CNPT,DELR,DELC,DZ,XBC,YBC,ZBC,DH, + & PRSITY,QX,QY,QZ,RETA,COLD,CNEW,CADV,RMASIO,WD, + & CWGT,DTRANS,BUFF,SADV5Q,QCTMP, + & DCEPS,SRMULT,DCHMOC,HORIGN,XMAX,YMAX,ZMAX,PERCEL + LOGICAL UNIDX,UNIDY,UNIDZ + DIMENSION XP(MXPART,MCOMP),YP(MXPART,MCOMP),ZP(MXPART,MCOMP), + & CNPT(MXPART,2,MCOMP),INDEXX(MXPART,MCOMP), + & INDEXY(MXPART,MCOMP),INDEXZ(MXPART,MCOMP), + & NPCHEK(NCOL,NROW,NLAY,MCOMP),ICBUND(NCOL,NROW,NLAY,MCOMP), + & DELR(NCOL),DELC(NROW),DZ(NCOL,NROW,NLAY),XBC(NCOL), + & YBC(NROW),ZBC(NCOL,NROW,NLAY),DH(NCOL,NROW,NLAY), + & PRSITY(NCOL,NROW,NLAY),QX(NCOL,NROW,NLAY), + & QY(NCOL,NROW,NLAY),QZ(NCOL,NROW,NLAY), + & RETA(NCOL,NROW,NLAY,MCOMP),COLD(NCOL,NROW,NLAY,MCOMP), + & CNEW(NCOL,NROW,NLAY,MCOMP),CADV(NCOL,NROW,NLAY,MCOMP), + & CWGT(NCOL,NROW,NLAY,MCOMP),BUFF(NCOL,NROW,NLAY), + & RMASIO(122,2,MCOMP),NCOUNT(MCOMP),NPINS(MCOMP),NRC(MCOMP) + COMMON /PD/HORIGN,XMAX,YMAX,ZMAX,UNIDX,UNIDY,UNIDZ + COMMON /AD/PERCEL,ITRACK,WD,ISEED,DCEPS,NPLANE,NPL,NPH, + & NPMIN,NPMAX,SRMULT,INTERP,NLSINK,NPSINK,DCHMOC +C +C--IF FINITE DIFFERENCE OR ULTIMATE OPTION IS USED + IF(MIXELM.EQ.0) THEN + CALL SADV5F(NCOL,NROW,NLAY,ICBUND(1,1,1,ICOMP),DELR,DELC,DH, + & PRSITY,CNEW(1,1,1,ICOMP),COLD(1,1,1,ICOMP),QX,QY,QZ, + & RETA(1,1,1,ICOMP),DTRANS,RMASIO(1,1,ICOMP)) + ELSEIF(MIXELM.EQ.-1) THEN + CALL SADV5U(NCOL,NROW,NLAY,ICBUND(1,1,1,ICOMP),DELR,DELC,DH, + & PRSITY,CNEW(1,1,1,ICOMP),COLD(1,1,1,ICOMP),CADV(1,1,1,ICOMP), + & BUFF,QX,QY,QZ,RETA(1,1,1,ICOMP),DTRANS, + & RMASIO(1,1,ICOMP)) + ENDIF +C +C--IF [MOC] OR [HMOC] IS USED + IF(MIXELM.EQ.1 .OR. MIXELM.EQ.3) THEN +C +C--CALCULATE RELATIVE CELL CONCENTRATION GRADIENTS IF NEEDED +C--AND STORE THEM IN BUFFER ARRAY [BUFF] + IF(MIXELM.EQ.3 .OR. MIXELM.EQ.1.AND.NPL.NE.NPH) THEN + CALL CNGRAD(NCOL,NROW,NLAY,ICBUND(1,1,1,ICOMP), + & COLD(1,1,1,ICOMP),BUFF) + ENDIF +C +C--UPDATE PARTICLE CONCENTRATIONS WITH CONCENTRATION CHANGES CONTAINED +C--IN THE [DC] ARRAY, AND DELET/INSERT PARTICLES AS NECESSARY + CALL PARMGR(IOUT,NCOL,NROW,NLAY,MIXELM,MXPART,NCOUNT(ICOMP), + & NPINS(ICOMP),NRC(ICOMP), + & NPCHEK(1,1,1,ICOMP),ICBUND(1,1,1,ICOMP),DELR,DELC,DZ,DH,PRSITY, + & XBC,YBC,ZBC,XP(1,ICOMP),YP(1,ICOMP),ZP(1,ICOMP), + & INDEXX(1,ICOMP),INDEXY(1,ICOMP),INDEXZ(1,ICOMP), + & CNPT(1,1,ICOMP),COLD(1,1,1,ICOMP),CADV(1,1,1,ICOMP),BUFF) +C +C--CALCULATE CNEW WITH FORWARD TRACKING PROCEDURE + CALL SADV5M(NCOL,NROW,NLAY,MXPART,NCOUNT(ICOMP), + & NPCHEK(1,1,1,ICOMP),XP(1,ICOMP),YP(1,ICOMP),ZP(1,ICOMP), + & INDEXX(1,ICOMP),INDEXY(1,ICOMP),INDEXZ(1,ICOMP), + & CNPT(1,1,ICOMP),ICBUND(1,1,1,ICOMP),DELR,DELC,DZ,XBC,YBC,ZBC, + & DH,PRSITY,QX,QY,QZ,RETA(1,1,1,ICOMP),COLD(1,1,1,ICOMP), + & CNEW(1,1,1,ICOMP),CADV(1,1,1,ICOMP),DTRANS) +C + ENDIF +C +C--IF [MMOC] OR [HMOC] IS USED +C--CALCULATE CNEW WITH BACKWARD TRACKING PROCEDURE + IF(MIXELM.EQ.2 .OR. MIXELM.EQ.3) THEN + CALL SADV5B(NCOL,NROW,NLAY,MIXELM, + & ICBUND(1,1,1,ICOMP),DELR,DELC,DZ,XBC,YBC,ZBC,DH, + & PRSITY,QX,QY,QZ,RETA(1,1,1,ICOMP),COLD(1,1,1,ICOMP), + & CNEW(1,1,1,ICOMP),BUFF,DTRANS) + ENDIF +C +C--IF CONSTANT CONCENTRATION CELL, ASSIGN [COLD] TO [CNEW] +C--AND COMPUTE ADVECTIVE MASS IN OR OUT + IF(MIXELM.LE.0) GOTO 100 +C + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K,ICOMP).GE.0) CYCLE + CNEW(J,I,K,ICOMP)=COLD(J,I,K,ICOMP) + QCTMP=SADV5Q(NCOL,NROW,NLAY,J,I,K,ICBUND(1,1,1,ICOMP), + & DELR,DELC,DH,COLD(1,1,1,ICOMP),QX,QY,QZ,DTRANS,NADVFD) + IF(QCTMP.GT.0) THEN + RMASIO(6,1,ICOMP)=RMASIO(6,1,ICOMP)+QCTMP + ELSE + RMASIO(6,2,ICOMP)=RMASIO(6,2,ICOMP)+QCTMP + ENDIF + ENDDO + ENDDO + ENDDO +C + 100 CONTINUE +C +C--CALCULATE WEIGHTED CONCENTRATION [CWGT] FOR USE IN EVALUATING +C--CONCENTRAION CHANGES DUE TO DISPERSION, SINK/SOURCE, AND/OR +C--CHEMICAL REACTIONS; SAVE NEW CONC. DUE TO ADVECTION IN [CADV] + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K,ICOMP).EQ.0) CYCLE + CWGT(J,I,K,ICOMP)=(1.-WD)*COLD(J,I,K,ICOMP) + & +WD*CNEW(J,I,K,ICOMP) + CADV(J,I,K,ICOMP)=CNEW(J,I,K,ICOMP) + ENDDO + ENDDO + ENDDO +C +C--RETURN + RETURN + END +C +C + SUBROUTINE SADV5M(NCOL,NROW,NLAY,MXPART,NCOUNT,NPCHEK,XP,YP,ZP, + & INDEXX,INDEXY,INDEXZ,CNPT,ICBUND,DELR,DELC,DZ,XBC,YBC,ZBC,DH, + & PRSITY,QX,QY,QZ,RETA,COLD,CNEW,CADV,DTRANS) +C ********************************************************************** +C THIS SUBROUTINE CALCULATES CONCENTRATIONS AT THE INTERMEDIATE TIME +C LEVEL DUE TO ADVECTION USING THE FORWARD TRACKING MOC PROCEDURE. +C ********************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER NCOL,NROW,NLAY,NCOUNT,NPCHEK,NP,ICBUND, + & MXPART,JJ,II,KK,J,I,K,JP,IP,KP, + & NN,ITRACK,NPL,NPH,NPMIN,NPMAX,INTERP,NLSINK, + & NPSINK,NPLANE,ISEED,INDEXX,INDEXY,INDEXZ + REAL XP,YP,ZP,CNPT,DELR,DELC,DZ,XBC,YBC,ZBC,DH, + & PRSITY,QX,QY,QZ,RETA,COLD,CNEW,CADV,WD, + & P,V,DT,DTRANS,UPFACE,ALPHA,CF,ZMIN, + & DCEPS,SRMULT,DCHMOC,HORIGN,XMAX,YMAX,ZMAX,PERCEL + LOGICAL UNIDX,UNIDY,UNIDZ + DIMENSION XP(MXPART),YP(MXPART),ZP(MXPART),CNPT(MXPART,2), + & NPCHEK(NCOL,NROW,NLAY),ICBUND(NCOL,NROW,NLAY), + & DELR(NCOL),DELC(NROW),DZ(NCOL,NROW,NLAY),XBC(NCOL), + & YBC(NROW),ZBC(NCOL,NROW,NLAY),DH(NCOL,NROW,NLAY), + & PRSITY(NCOL,NROW,NLAY),QX(NCOL,NROW,NLAY), + & QY(NCOL,NROW,NLAY),QZ(NCOL,NROW,NLAY), + & RETA(NCOL,NROW,NLAY),COLD(NCOL,NROW,NLAY), + & CNEW(NCOL,NROW,NLAY),CADV(NCOL,NROW,NLAY),P(3),V(3), + & INDEXX(MXPART),INDEXY(MXPART),INDEXZ(MXPART) + COMMON /PD/HORIGN,XMAX,YMAX,ZMAX,UNIDX,UNIDY,UNIDZ + COMMON /AD/PERCEL,ITRACK,WD,ISEED,DCEPS,NPLANE,NPL,NPH, + & NPMIN,NPMAX,SRMULT,INTERP,NLSINK,NPSINK,DCHMOC +C +C--CLEAR [CNEW] ARRAY TO ACCUMULATE CONC.*VOL. OF PARTICLES +C--AND CLEAR [CADV] ARRAY TO ACCUMULATE VOL. OF PARTICLES + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K).NE.0) THEN + CNEW(J,I,K)=0. + CADV(J,I,K)=0. + ENDIF + ENDDO + ENDDO + ENDDO +C +C--MOVE EACH PARTICLE OVER TIME INCREMENT DT...... + DT=DTRANS + P(1)=XBC(1) + P(2)=YBC(1) + P(3)=ZBC(1,1,1) + V(1)=0. + V(2)=0. + V(3)=0. + JJ=1 + II=1 + KK=1 + DO NP=1,NCOUNT + NN=NP + IF(NCOL.GT.1) THEN + P(1)=XP(NN) + JJ=INDEXX(NN) + ENDIF + IF(NROW.GT.1) THEN + P(2)=YP(NN) + II=INDEXY(NN) + ENDIF + IF(NLAY.GT.1) THEN + P(3)=ZP(NN) + KK=INDEXZ(NN) + ENDIF + NPCHEK(JJ,II,KK)=NPCHEK(JJ,II,KK)-1 + IF(NPCHEK(JJ,II,KK).LT.0) CNPT(NN,1)=COLD(JJ,II,KK) + IF(ICBUND(JJ,II,KK).EQ.0) GOTO 100 +C +C--GET VELOCITY COMPONENTS AT POINT P + IF(NCOL.GT.1) THEN + ALPHA=(P(1)-XBC(JJ)+0.5*DELR(JJ))/DELR(JJ) + IF(JJ-1.LT.1) THEN + V(1)=ALPHA*QX(JJ,II,KK)/(PRSITY(JJ,II,KK)*RETA(JJ,II,KK)) + ELSE + V(1)=(ALPHA*QX(JJ,II,KK)+(1.-ALPHA)*QX(JJ-1,II,KK)) + & /(PRSITY(JJ,II,KK)*RETA(JJ,II,KK)) + ENDIF + ENDIF + IF(NROW.GT.1) THEN + ALPHA=(P(2)-YBC(II)+0.5*DELC(II))/DELC(II) + IF(II-1.LT.1) THEN + V(2)=ALPHA*QY(JJ,II,KK)/(PRSITY(JJ,II,KK)*RETA(JJ,II,KK)) + ELSE + V(2)=(ALPHA*QY(JJ,II,KK)+(1.-ALPHA)*QY(JJ,II-1,KK)) + & /(PRSITY(JJ,II,KK)*RETA(JJ,II,KK)) + ENDIF + ENDIF + IF(NLAY.GT.1) THEN + UPFACE=ZBC(JJ,II,KK)+0.5*DZ(JJ,II,KK)-DH(JJ,II,KK) + ALPHA=(P(3)-UPFACE)/DH(JJ,II,KK) + IF(ALPHA.LT.0) ALPHA=0 + IF(KK-1.LT.1) THEN + V(3)=ALPHA*QZ(JJ,II,KK)/(PRSITY(JJ,II,KK)*RETA(JJ,II,KK)) + ELSE + V(3)=(ALPHA*QZ(JJ,II,KK)+(1.-ALPHA)*QZ(JJ,II,KK-1)) + & /(PRSITY(JJ,II,KK)*RETA(JJ,II,KK)) + ENDIF + ENDIF + IF(ITRACK.EQ.2.OR.ITRACK.EQ.3.AND.(ICBUND(JJ,II,KK).GE.1000. + & AND.ICBUND(JJ,II,KK).LE.1030.OR.ICBUND(JJ,II,KK).LT.0)) THEN + CALL VRK4(P,V,DT,JJ,II,KK,NCOL,NROW,NLAY,ICBUND, + & DELR,DELC,DZ,XBC,YBC,ZBC,DH,PRSITY,QX,QY,QZ,RETA) + ENDIF +C +C--MOVE PARTICLE FORWARD + JP=JJ + IP=II + KP=KK +C +C--ALONG THE X DIRECTION... + IF(NCOL.LT.2) GOTO 10 + P(1)=P(1)+V(1)*DT +C +C--REFLECTION OF PARTICLE AT MODEL EDGE OR BOUNDARY IF NEEDED + IF(P(1)-XBC(JP).LT.0.5*DELR(JP).AND. + & P(1)-XBC(JP).GE.-0.5*DELR(JP)) GOTO 10 + IF(P(1).GT.XMAX) THEN + P(1)=2.0*XMAX-P(1) + ELSEIF(P(1)-XBC(JP).GT.0.5*DELR(JP)) THEN + IF(JP.LT.NCOL.AND.ICBUND(JP+1,IP,KP).EQ.0) THEN + P(1)=2.0*(XBC(JP)+0.5*DELR(JP))-P(1) + ENDIF + ELSEIF(P(1).LT.0) THEN + P(1)=-P(1) + ELSEIF(P(1)-XBC(JP).LT.-0.5*DELR(JP)) THEN + IF(JP.GT.1.AND.ICBUND(JP-1,IP,KP).EQ.0) THEN + P(1)=2.0*(XBC(JP)-0.5*DELR(JP))-P(1) + ENDIF + ENDIF + IF(P(1).GT.XMAX) P(1)=XMAX + IF(P(1).LT.0) P(1)=0 +C +C--UPDATE THE J INDEX FOR THE NEW X COORDINATE + IF(UNIDX) THEN + JP=INT(P(1)/DELR(1))+1 + IF(JP.GT.NCOL) JP=NCOL + ELSEIF(V(1)*DT.LT.0) THEN + DO J=JJ,1,-1 + IF(P(1).GE.XBC(J)-0.5*DELR(J) .AND. + & P(1).LT.XBC(J)+0.5*DELR(J)) THEN + JP=J + GOTO 1 + ENDIF + ENDDO + 1 CONTINUE + ELSEIF(V(1)*DT.GT.0) THEN + DO J=JJ,NCOL + IF(P(1).GE.XBC(J)-0.5*DELR(J) .AND. + & P(1).LT.XBC(J)+0.5*DELR(J)) THEN + JP=J + GOTO 2 + ENDIF + ENDDO + 2 CONTINUE + ENDIF +C +C--ALONG THE Y DIRECTION... + 10 IF(NROW.LT.2) GOTO 20 + P(2)=P(2)+V(2)*DT +C +C--REFLECTION OF PARTICLE AT MODEL EDGE OR BOUNDARY IF NEEDED + IF(P(2)-YBC(IP).LT.0.5*DELC(IP).AND. + & P(2)-YBC(IP).GE.-0.5*DELC(IP)) GOTO 20 + IF(P(2).GT.YMAX) THEN + P(2)=2.0*YMAX-P(2) + ELSEIF(P(2)-YBC(IP).GT.0.5*DELC(IP)) THEN + IF(IP.LT.NROW.AND.ICBUND(JP,IP+1,KP).EQ.0) THEN + P(2)=2.0*(YBC(IP)+0.5*DELC(IP))-P(2) + ENDIF + ELSEIF(P(2).LT.0) THEN + P(2)=-P(2) + ELSEIF(P(2)-YBC(IP).LT.-0.5*DELC(IP)) THEN + IF(IP.GT.1.AND.ICBUND(JP,IP-1,KP).EQ.0) THEN + P(2)=2.0*(YBC(IP)-0.5*DELC(IP))-P(2) + ENDIF + ENDIF + IF(P(2).GT.YMAX) P(2)=YMAX + IF(P(2).LT.0) P(2)=0 +C +C--UPDATE THE I INDEX FOR THE NEW Y COORDINATE + IF(UNIDY) THEN + IP=INT(P(2)/DELC(1))+1 + IF(IP.GT.NROW) IP=NROW + ELSEIF(V(2)*DT.LT.0) THEN + DO I=II,1,-1 + IF(P(2).GE.YBC(I)-0.5*DELC(I) .AND. + & P(2).LT.YBC(I)+0.5*DELC(I)) THEN + IP=I + GOTO 3 + ENDIF + ENDDO + 3 CONTINUE + ELSEIF(V(2)*DT.GT.0) THEN + DO I=II,NROW + IF(P(2).GE.YBC(I)-0.5*DELC(I) .AND. + & P(2).LT.YBC(I)+0.5*DELC(I)) THEN + IP=I + GOTO 4 + ENDIF + ENDDO + 4 CONTINUE + ENDIF +C +C--ALONG THE Z DIRECTION... + 20 IF(NLAY.LT.2) GOTO 30 + P(3)=P(3)+V(3)*DT +C +C-ADJUSTED FOR DISTORTED GRID IF NECESSARY + IF(ABS(ZBC(JP,IP,KK)-ZBC(JJ,II,KK)).GT.1.E-5 + & .OR.ABS(DZ(JP,IP,KK)-DZ(JJ,II,KK)).GT.1.E-5) THEN + IF(DZ(JJ,II,KK).GT.0) THEN + CF=DZ(JP,IP,KK)/DZ(JJ,II,KK)* + & (P(3)-V(3)*DT-ZBC(JJ,II,KK)) + P(3)=V(3)*DT+CF+ZBC(JP,IP,KK) + ENDIF + ENDIF +C +C--REFLECTION OF PARTICLE AT MODEL EDGE OR BOUNDARY IF NEEDED + IF(P(3)-ZBC(JP,IP,KK).LT.0.5*DZ(JP,IP,KK).AND. + & P(3)-ZBC(JP,IP,KK).GE.-0.5*DZ(JP,IP,KK)) GOTO 30 + ZMIN=ZBC(JP,IP,1)-0.5*DZ(JP,IP,1) + ZMAX=ZBC(JP,IP,NLAY)+0.5*DZ(JP,IP,NLAY) + IF(P(3).GT.ZMAX) THEN + P(3)=2.0*ZMAX-P(3) + ELSEIF(P(3)-ZBC(JP,IP,KK).GT.0.5*DZ(JP,IP,KK)) THEN + IF(KK.LT.NLAY.AND.ICBUND(JP,IP,KK+1).EQ.0) THEN + P(3)=2.0*(ZBC(JP,IP,KK)+0.5*DZ(JP,IP,KK))-P(3) + ENDIF + ELSEIF(P(3).LT.ZMIN) THEN + P(3)=2.0*ZMIN-P(3) + ELSEIF(P(3)-ZBC(JP,IP,KK).LT.-0.5*DZ(JP,IP,KK)) THEN + IF(KK.GT.1.AND.ICBUND(JP,IP,KK-1).EQ.0) THEN + P(3)=2.0*(ZBC(JP,IP,KK)-0.5*DZ(JP,IP,KK))-P(3) + ENDIF + ENDIF + IF(P(3).GT.ZMAX) P(3)=ZMAX + IF(P(3).LT.0) P(3)=0 +C +C--UPDATE THE K INDEX FOR THE NEW Z COORDINATE + IF(UNIDZ) THEN + KP=INT(P(3)/DZ(JP,IP,1))+1 + IF(KP.GT.NLAY) KP=NLAY + ELSEIF(V(3)*DT.LT.0) THEN + DO K=KK,1,-1 + IF(P(3).GE.ZBC(JP,IP,K)-0.5*DZ(JP,IP,K) .AND. + & P(3).LT.ZBC(JP,IP,K)+0.5*DZ(JP,IP,K)) THEN + KP=K + GOTO 5 + ENDIF + ENDDO + 5 CONTINUE + ELSEIF(V(3)*DT.GT.0) THEN + DO K=KK,NLAY + IF(P(3).GE.ZBC(JP,IP,K)-0.5*DZ(JP,IP,K) .AND. + & P(3).LT.ZBC(JP,IP,K)+0.5*DZ(JP,IP,K)) THEN + KP=K + GOTO 6 + ENDIF + ENDDO + 6 CONTINUE + ENDIF +C +C--UPDATE PARTICLE ARRAYS AND ACCUMULATE CONCENTRATION IN [CNEW] + 30 IF(NCOL.GT.1) THEN + XP(NN)=P(1) + INDEXX(NN)=JP + ENDIF + IF(NROW.GT.1) THEN + YP(NN)=P(2) + INDEXY(NN)=IP + ENDIF + IF(NLAY.GT.1) THEN + ZP(NN)=P(3) + INDEXZ(NN)=KP + ENDIF + NPCHEK(JP,IP,KP)=NPCHEK(JP,IP,KP)+1 + CNEW(JP,IP,KP)=CNEW(JP,IP,KP)+CNPT(NN,1)*CNPT(NN,2) + CADV(JP,IP,KP)=CADV(JP,IP,KP)+CNPT(NN,2) +C + 100 ENDDO +C +C--CALCULATE INTERMEDIATE CELL CONCENTRATIONS +C--BY DIVIDING ACCUMULATED CONC.*VOL. BY ACCUMULATED VOL. + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K).GT.0) THEN + IF(NPCHEK(J,I,K).LT.0) NPCHEK(J,I,K)=NPCHEK(J,I,K)+1000 + IF(CADV(J,I,K).GT.0) THEN + CNEW(J,I,K)=CNEW(J,I,K)/CADV(J,I,K) + ELSE + CNEW(J,I,K)=COLD(J,I,K) + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO +C +C--RETURN + RETURN + END +C +C + SUBROUTINE SADV5B(NCOL,NROW,NLAY,MIXELM,ICBUND,DELR,DELC,DZ, + & XBC,YBC,ZBC,DH,PRSITY,QX,QY,QZ,RETA,COLD,CNEW,BUFF,DTRANS) +C ********************************************************************** +C THIS SUBROUTINE CALCULATES CONCENTRATIONS AT THE INTERMEDIATE TIME +C LEVEL DUE TO ADVECTION WITH THE BACKWARD TRACKING MMOC PROCEDURE. +C ********************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER NMAX,NCOL,NROW,NLAY,NP,ICBUND,MIXELM, + & JJ,II,KK,J,I,K,ITRACK,NPL,NPH,NPMIN, + & NPMAX,INTERP,NLSINK,NPSINK,NPLANE,NPOINT, + & ISEED,KM1,IM1,JM1,JLO,ILO,KLO,JHI,IHI,KHI,JP,IP,KP + PARAMETER (NMAX=128) + REAL DELR,DELC,DZ,XBC,YBC,ZBC,DH,PRSITY,QX,QY,QZ,RETA, + & COLD,CNEW,WD,DT,DTRANS,D2,D2SUM,BUFF, + & DCEPS,SRMULT,DCHMOC,HORIGN,XMAX,YMAX,ZMAX,PERCEL, + & XTMP,YTMP,ZTMP,UPFACE,ALPHA,CF,ZMIN,RAN0, + & CPOINT,WX,WY,WZ,CTMP,P,V + LOGICAL UNIDX,UNIDY,UNIDZ + DIMENSION ICBUND(NCOL,NROW,NLAY), + & DELR(NCOL),DELC(NROW),DZ(NCOL,NROW,NLAY),XBC(NCOL), + & YBC(NROW),ZBC(NCOL,NROW,NLAY),DH(NCOL,NROW,NLAY), + & PRSITY(NCOL,NROW,NLAY),QX(NCOL,NROW,NLAY), + & QY(NCOL,NROW,NLAY),QZ(NCOL,NROW,NLAY), + & RETA(NCOL,NROW,NLAY),COLD(NCOL,NROW,NLAY), + & CNEW(NCOL,NROW,NLAY),BUFF(NCOL,NROW,NLAY), + & XTMP(NMAX),YTMP(NMAX),ZTMP(NMAX),P(3),V(3) + COMMON /PD/HORIGN,XMAX,YMAX,ZMAX,UNIDX,UNIDY,UNIDZ + COMMON /AD/PERCEL,ITRACK,WD,ISEED,DCEPS,NPLANE,NPL,NPH, + & NPMIN,NPMAX,SRMULT,INTERP,NLSINK,NPSINK,DCHMOC +C +C--INITIALIZE + V(:)=0. +C +C--SET DT TO NEGATIVE FOR BACKWARD TRACKING + DT=-DTRANS +C +C--LOOP OVER ALL ACTIVE CELLS + DO KK=1,NLAY + DO II=1,NROW + DO JJ=1,NCOL +C + IF(ICBUND(JJ,II,KK).LE.0) GOTO 999 + IF(MIXELM.EQ.3.AND.BUFF(JJ,II,KK).GT.DCHMOC) GOTO 999 + CNEW(JJ,II,KK)=0. + D2SUM=0. +C +C--PLACE ONE PARTICLE AT NODAL POINT + NPOINT=1 + XTMP(NPOINT)=XBC(JJ) + YTMP(NPOINT)=YBC(II) + ZTMP(NPOINT)=ZBC(JJ,II,KK) +C +C--IF CELL CONTAINS SINK, MULTIPLE PARTICLES ARE NEEDED. +C--RANDOMLY GENERATE THEIR LOCATIONS + IF(ICBUND(JJ,II,KK).GT.1000 .AND. + & ICBUND(JJ,II,KK).LT.1010) THEN +C + IF(NPLANE.LE.0) THEN + NPOINT=NPSINK + ELSE + NPOINT=NPSINK*NPLANE + IF(NPOINT.GT.NMAX) NPOINT=NMAX + ENDIF + DO NP=1,NPOINT + XTMP(NP)=XBC(JJ) + YTMP(NP)=YBC(II) + ZTMP(NP)=ZBC(JJ,II,KK) + IF(NCOL.GT.1) + & XTMP(NP)=XBC(JJ)+(RAN0(ISEED)-0.5)*DELR(JJ) + IF(NROW.GT.1) + & YTMP(NP)=YBC(II)+(RAN0(ISEED)-0.5)*DELC(II) + IF(NLAY.GT.1) + & ZTMP(NP)=ZBC(JJ,II,KK)+0.5*DZ(JJ,II,KK) + & -RAN0(ISEED)*DH(JJ,II,KK) + ENDDO +C + ENDIF +C +C--MOVE EACH PARTICLE BACKWARD OVER TIME INCREMENT DT + NP=1 +C + 100 CONTINUE + JP=JJ + IP=II + KP=KK + P(1)=XTMP(NP) + P(2)=YTMP(NP) + P(3)=ZTMP(NP) + IF(NPOINT.GT.1) THEN + D2=(P(1)-XBC(JJ))*(P(1)-XBC(JJ))+ + & (P(2)-YBC(II))*(P(2)-YBC(II))+ + & (P(3)-ZBC(JJ,II,KK))*(P(3)-ZBC(JJ,II,KK)) + IF(D2.NE.0) D2SUM=D2SUM+1./D2 + ENDIF +C +C--GET VELOCITY COMPONENTS AT POINT P + IF(NCOL.GT.1) THEN + ALPHA=(P(1)-XBC(JJ)+0.5*DELR(JJ))/DELR(JJ) + JM1=JJ-1 + IF(JM1.LT.1) JM1=1 + V(1)=(ALPHA*QX(JJ,II,KK)+(1.-ALPHA)*QX(JM1,II,KK)) + & /(PRSITY(JJ,II,KK)*RETA(JJ,II,KK)) + ENDIF + IF(NROW.GT.1) THEN + ALPHA=(P(2)-YBC(II)+0.5*DELC(II))/DELC(II) + IM1=II-1 + IF(IM1.LT.1) IM1=1 + V(2)=(ALPHA*QY(JJ,II,KK)+(1.-ALPHA)*QY(JJ,IM1,KK)) + & /(PRSITY(JJ,II,KK)*RETA(JJ,II,KK)) + ENDIF + IF(NLAY.GT.1) THEN + UPFACE=ZBC(JJ,II,KK)+0.5*DZ(JJ,II,KK)-DH(JJ,II,KK) + ALPHA=(P(3)-UPFACE)/DH(JJ,II,KK) + KM1=KK-1 + IF(KM1.LT.1) KM1=1 + IF(ALPHA.LT.0) ALPHA=0 + V(3)=(ALPHA*QZ(JJ,II,KK)+(1.-ALPHA)*QZ(JJ,II,KM1)) + & /(PRSITY(JJ,II,KK)*RETA(JJ,II,KK)) + ENDIF + IF(ITRACK.EQ.2.OR.ITRACK.EQ.3.AND.(ICBUND(JJ,II,KK).GE.1000. + & AND.ICBUND(JJ,II,KK).LE.1030.OR.ICBUND(JJ,II,KK).LT.0)) THEN + CALL VRK4(P,V,DT,JJ,II,KK,NCOL,NROW,NLAY,ICBUND, + & DELR,DELC,DZ,XBC,YBC,ZBC,DH,PRSITY,QX,QY,QZ,RETA) + ENDIF +C +C--MOVE PARTICLE FORWARD +C +C--ALONG THE X DIRECTION... + IF(NCOL.LT.2) GOTO 10 + P(1)=P(1)+V(1)*DT +C +C--REFLECTION OF PARTICLE AT MODEL EDGE OR BOUNDARY IF NEEDED + IF(P(1)-XBC(JP).LT.0.5*DELR(JP).AND. + & P(1)-XBC(JP).GE.-0.5*DELR(JP)) GOTO 10 + IF(P(1).GT.XMAX) THEN + P(1)=2.0*XMAX-P(1) + ELSEIF(P(1)-XBC(JP).GT.0.5*DELR(JP)) THEN + IF(JP.LT.NCOL.AND.ICBUND(JP+1,IP,KP).EQ.0) THEN + P(1)=2.0*(XBC(JP)+0.5*DELR(JP))-P(1) + ENDIF + ELSEIF(P(1).LT.0) THEN + P(1)=-P(1) + ELSEIF(P(1)-XBC(JP).LT.-0.5*DELR(JP)) THEN + IF(JP.GT.1.AND.ICBUND(JP-1,IP,KP).EQ.0) THEN + P(1)=2.0*(XBC(JP)-0.5*DELR(JP))-P(1) + ENDIF + ENDIF +C +C--UPDATE THE J INDEX FOR THE NEW X COORDINATE + IF(UNIDX) THEN + JP=INT(P(1)/DELR(1))+1 + IF(JP.GT.NCOL) JP=NCOL + ELSEIF(V(1)*DT.LT.0) THEN + DO J=JJ,1,-1 + IF(P(1).GE.XBC(J)-0.5*DELR(J) .AND. + & P(1).LT.XBC(J)+0.5*DELR(J)) THEN + JP=J + GOTO 1 + ENDIF + ENDDO + 1 CONTINUE + ELSEIF(V(1)*DT.GT.0) THEN + DO J=JJ,NCOL + IF(P(1).GE.XBC(J)-0.5*DELR(J) .AND. + & P(1).LT.XBC(J)+0.5*DELR(J)) THEN + JP=J + GOTO 2 + ENDIF + ENDDO + 2 CONTINUE + ENDIF +C +C--ALONG THE Y DIRECTION... + 10 IF(NROW.LT.2) GOTO 20 + P(2)=P(2)+V(2)*DT +C +C--REFLECTION OF PARTICLE AT MODEL EDGE OR BOUNDARY IF NEEDED + IF(P(2)-YBC(IP).LT.0.5*DELC(IP).AND. + & P(2)-YBC(IP).GE.-0.5*DELC(IP)) GOTO 20 + IF(P(2).GT.YMAX) THEN + P(2)=2.0*YMAX-P(2) + ELSEIF(P(2)-YBC(IP).GT.0.5*DELC(IP)) THEN + IF(IP.LT.NROW.AND.ICBUND(JP,IP+1,KP).EQ.0) THEN + P(2)=2.0*(YBC(IP)+0.5*DELC(IP))-P(2) + ENDIF + ELSEIF(P(2).LT.0) THEN + P(2)=-P(2) + ELSEIF(P(2)-YBC(IP).LT.-0.5*DELC(IP)) THEN + IF(IP.GT.1.AND.ICBUND(JP,IP-1,KP).EQ.0) THEN + P(2)=2.0*(YBC(IP)-0.5*DELC(IP))-P(2) + ENDIF + ENDIF +C +C--UPDATE THE I INDEX FOR THE NEW Y COORDINATE + IF(UNIDY) THEN + IP=INT(P(2)/DELC(1))+1 + IF(IP.GT.NROW) IP=NROW + ELSEIF(V(2)*DT.LT.0) THEN + DO I=II,1,-1 + IF(P(2).GE.YBC(I)-0.5*DELC(I) .AND. + & P(2).LT.YBC(I)+0.5*DELC(I)) THEN + IP=I + GOTO 3 + ENDIF + ENDDO + 3 CONTINUE + ELSEIF(V(2)*DT.GT.0) THEN + DO I=II,NROW + IF(P(2).GE.YBC(I)-0.5*DELC(I) .AND. + & P(2).LT.YBC(I)+0.5*DELC(I)) THEN + IP=I + GOTO 4 + ENDIF + ENDDO + 4 CONTINUE + ENDIF +C +C--ALONG THE Z DIRECTION... + 20 IF(NLAY.LT.2) GOTO 30 + P(3)=P(3)+V(3)*DT +C +C-ADJUSTED FOR DISTORTED GRID IF NECESSARY + IF(ABS(ZBC(JP,IP,KK)-ZBC(JJ,II,KK)).GT.1.E-5 + & .OR.ABS(DZ(JP,IP,KK)-DZ(JJ,II,KK)).GT.1.E-5) THEN + IF(DZ(JJ,II,KK).GT.0) THEN + CF=DZ(JP,IP,KK)/DZ(JJ,II,KK)* + & (P(3)-V(3)*DT-ZBC(JJ,II,KK)) + P(3)=V(3)*DT+CF+ZBC(JP,IP,KK) + ENDIF + ENDIF +C +C--REFLECTION OF PARTICLE AT MODEL EDGE OR BOUNDARY IF NEEDED + IF(P(3)-ZBC(JP,IP,KK).LT.0.5*DZ(JP,IP,KK).AND. + & P(3)-ZBC(JP,IP,KK).GE.-0.5*DZ(JP,IP,KK)) GOTO 30 + ZMIN=ZBC(JP,IP,1)-0.5*DZ(JP,IP,1) + ZMAX=ZBC(JP,IP,NLAY)+0.5*DZ(JP,IP,NLAY) + IF(P(3).GT.ZMAX) THEN + P(3)=2.0*ZMAX-P(3) + ELSEIF(P(3)-ZBC(JP,IP,KK).GT.0.5*DZ(JP,IP,KK)) THEN + IF(KK.LT.NLAY.AND.ICBUND(JP,IP,KK+1).EQ.0) THEN + P(3)=2.0*(ZBC(JP,IP,KK)+0.5*DZ(JP,IP,KK))-P(3) + ENDIF + ELSEIF(P(3).LT.ZMIN) THEN + P(3)=2.0*ZMIN-P(3) + ELSEIF(P(3)-ZBC(JP,IP,KK).LT.-0.5*DZ(JP,IP,KK)) THEN + IF(KK.GT.1.AND.ICBUND(JP,IP,KK-1).EQ.0) THEN + P(3)=2.0*(ZBC(JP,IP,KK)-0.5*DZ(JP,IP,KK))-P(3) + ENDIF + ENDIF +C +C--UPDATE THE K INDEX FOR THE NEW Z COORDINATE + IF(UNIDZ) THEN + KP=INT(P(3)/DZ(JP,IP,1))+1 + IF(KP.GT.NLAY) KP=NLAY + ELSEIF(V(3)*DT.LT.0) THEN + DO K=KK,1,-1 + IF(P(3).GE.ZBC(JP,IP,K)-0.5*DZ(JP,IP,K) .AND. + & P(3).LT.ZBC(JP,IP,K)+0.5*DZ(JP,IP,K)) THEN + KP=K + GOTO 5 + ENDIF + ENDDO + 5 CONTINUE + ELSEIF(V(3)*DT.GT.0) THEN + DO K=KK,NLAY + IF(P(3).GE.ZBC(JP,IP,K)-0.5*DZ(JP,IP,K) .AND. + & P(3).LT.ZBC(JP,IP,K)+0.5*DZ(JP,IP,K)) THEN + KP=K + GOTO 6 + ENDIF + ENDDO + 6 CONTINUE + ENDIF +C + 30 CONTINUE +C +C--DEFINE LOWER AND UPPER BOUNDS FOR MULTI-LINEAR INTERPOLATION + IF(P(1).GT.XBC(JP)) THEN + JLO=JP + ELSE + JLO=JP-1 + ENDIF + IF(P(2).GT.YBC(IP)) THEN + ILO=IP + ELSE + ILO=IP-1 + ENDIF + IF(P(3).GT.ZBC(JP,IP,KP)) THEN + KLO=KP + ELSE + KLO=KP-1 + ENDIF + JHI=JLO+1 + IHI=ILO+1 + KHI=KLO+1 + IF(JLO.LT.1) JLO=1 + IF(JHI.GT.NCOL) JHI=NCOL + IF(ILO.LT.1) ILO=1 + IF(IHI.GT.NROW) IHI=NROW + IF(KLO.LT.1) KLO=1 + IF(KHI.GT.NLAY) KHI=NLAY +C +C--CALCULATING LINEAR INTERPOLATION FACTORS + IF(JLO.NE.JHI) THEN + WX=(P(1)-XBC(JLO))/(0.5*DELR(JHI)+0.5*DELR(JLO)) + ELSE + WX=0 + ENDIF + IF(ILO.NE.IHI) THEN + WY=(P(2)-YBC(ILO))/(0.5*DELC(IHI)+0.5*DELC(ILO)) + ELSE + WY=0 + ENDIF + IF(KLO.NE.KHI) THEN + WZ=(P(3)-ZBC(JP,IP,KLO))/(0.5*DZ(JP,IP,KHI)+ + & 0.5*DZ(JP,IP,KLO)) + ELSE + WZ=0 + ENDIF +C +C--PERFORM INTERPOLATION + CPOINT=0 +C + CTMP=COLD(JLO,ILO,KLO) + IF(ICBUND(JLO,ILO,KLO).EQ.0) CTMP=COLD(JP,IP,KP) + CPOINT=CPOINT+(1.-WX)*(1.-WY)*(1.-WZ)*CTMP + CTMP=COLD(JLO,IHI,KLO) + IF(ICBUND(JLO,IHI,KLO).EQ.0) CTMP=COLD(JP,IP,KP) + CPOINT=CPOINT+(1.-WX)*WY*(1.-WZ)*CTMP + CTMP=COLD(JHI,ILO,KLO) + IF(ICBUND(JHI,ILO,KLO).EQ.0) CTMP=COLD(JP,IP,KP) + CPOINT=CPOINT+WX*(1.-WY)*(1.-WZ)*CTMP + CTMP=COLD(JHI,IHI,KLO) + IF(ICBUND(JHI,IHI,KLO).EQ.0) CTMP=COLD(JP,IP,KP) + CPOINT=CPOINT+WX*WY*(1.-WZ)*CTMP +C + IF(NLAY.GT.1) THEN + CTMP=COLD(JLO,ILO,KHI) + IF(ICBUND(JLO,ILO,KHI).EQ.0) CTMP=COLD(JP,IP,KP) + CPOINT=CPOINT+(1.-WX)*(1.-WY)*WZ*CTMP + CTMP=COLD(JLO,IHI,KHI) + IF(ICBUND(JLO,IHI,KHI).EQ.0) CTMP=COLD(JP,IP,KP) + CPOINT=CPOINT+(1.-WX)*WY*WZ*CTMP + CTMP=COLD(JHI,ILO,KHI) + IF(ICBUND(JHI,ILO,KHI).EQ.0) CTMP=COLD(JP,IP,KP) + CPOINT=CPOINT+WX*(1.-WY)*WZ*CTMP + CTMP=COLD(JHI,IHI,KHI) + IF(ICBUND(JHI,IHI,KHI).EQ.0) CTMP=COLD(JP,IP,KP) + CPOINT=CPOINT+WX*WY*WZ*CTMP + ENDIF +C +C--ASSIGN INTERPOLATED CONCENTRATION TO [CNEW] + IF(NPOINT.EQ.1 .OR. D2.EQ.0) THEN + CNEW(JJ,II,KK)=CPOINT + ELSE + CNEW(JJ,II,KK)=CNEW(JJ,II,KK)+CPOINT/D2 + ENDIF +C +C--IF MULTIPLE PARTICLES USED AT A SINGLE CELL, +C--REPEAT THE ABOVE STEPS FOR ALL PARTICLES + IF(NP.LT.NPOINT) THEN + NP=NP+1 + GOTO 100 + ENDIF +C +C--CALCULATE AVERAGE CONCENTARTION IF MORE THAN ONE PARTICLE IS USED + IF(NPOINT.GT.1 .AND. D2SUM.GT.0) THEN + CNEW(JJ,II,KK)=CNEW(JJ,II,KK)/D2SUM + ENDIF +C + 999 ENDDO + ENDDO + ENDDO +C +C--RETURN + RETURN + END +C +C + SUBROUTINE CNGRAD(NCOL,NROW,NLAY,ICBUND,COLD,BUFF) +C ******************************************************************** +C THIS SUBROUTINE CALCULATES THE RELATIVE CELL CONCENTRATION GRADIENT +C FOR EACH ACTIVE CELL IN THE GRID. +C ******************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER NCOL,NROW,NLAY,ICBUND,J,I,K,JM1,JP1,IM1,IP1,KM1,KP1, + & JJJ,III,KKK + REAL COLD,BUFF,DCMIN,DCMAX,CMIN,CMAX + DIMENSION ICBUND(NCOL,NROW,NLAY),COLD(NCOL,NROW,NLAY), + & BUFF(NCOL,NROW,NLAY) +C +C--FIND MAXIMUM AND MINIMUM CONCENTRATIONS IN THE ENTIR GRID +C--AND CLEAR THE BUFFER ARRAY + CMAX=-1.E30 + CMIN=1.E30 + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K).NE.0) THEN + IF(COLD(J,I,K).LT.CMIN) CMIN=COLD(J,I,K) + IF(COLD(J,I,K).GT.CMAX) CMAX=COLD(J,I,K) + BUFF(J,I,K)=0. + ENDIF + ENDDO + ENDDO + ENDDO + IF(CMAX.LE.0.OR.CMAX-CMIN.LE.0) RETURN +C +C--CALCULATE RELATIVE CELL CONCENTRATION GRADIENT AND +C--STORE IN BUFFER ARRAY [BUFF] + DO K=1,NLAY + KM1=MAX(K-1,1) + KP1=MIN(K+1,NLAY) + DO I=1,NROW + IM1=MAX(I-1,1) + IP1=MIN(I+1,NROW) + DO J=1,NCOL + JM1=MAX(J-1,1) + JP1=MIN(J+1,NCOL) +C + IF(ICBUND(J,I,K).NE.0) THEN + DCMIN=COLD(J,I,K) + DCMAX=COLD(J,I,K) + DO KKK=KM1,KP1 + DO III=IM1,IP1 + DO JJJ=JM1,JP1 + IF(ICBUND(JJJ,III,KKK).NE.0) THEN + IF(COLD(JJJ,III,KKK).LT.DCMIN) + & DCMIN=COLD(JJJ,III,KKK) + IF(COLD(JJJ,III,KKK).GT.DCMAX) + & DCMAX=COLD(JJJ,III,KKK) + ENDIF + ENDDO + ENDDO + ENDDO + BUFF(J,I,K)=(DCMAX-DCMIN)/CMAX + ENDIF +C + ENDDO + ENDDO + ENDDO +C +C--NORMAL RETURN + RETURN + END +C +C + SUBROUTINE PARMGR(IOUT,NCOL,NROW,NLAY,MIXELM,MXPART,NCOUNT,NPINS, + & NRC,NPCHEK,ICBUND,DELR,DELC,DZ,DH,PRSITY,XBC,YBC,ZBC,XP,YP,ZP, + & INDEXX,INDEXY,INDEXZ,CNPT,COLD,CADV,BUFF) +C ********************************************************************** +C THIS SUBROUTINE MANAGES THE DISTRIBUTION OF MOVING PARTICLES, +C DELETING OR INSERTING PARTICLES AS NECESSARY. +C ********************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER IOUT,NCOL,NROW,NLAY,NCOUNT,MXPART,ICBUND,NPCHEK, + & NPL,NPH,NPMIN,NPMAX,NPCELL,J,I,K,ITRACK,NPLANE,INTERP, + & NPSINK,NLSINK,NPALL,NPINS,NRC,ISEED,NADD, + & JJ,II,KK,NP,MIXELM,NLAST,NN,INDEXX,INDEXY,INDEXZ,NCOLD + REAL DELR,DELC,DZ,DH,PRSITY,XBC,YBC,ZBC,XP,YP,ZP,CNPT,COLD, + & DCEPS,SRMULT,DCHMOC,WD,PERCEL,CADV,BUFF, + & HORIGN,XMAX,YMAX,ZMAX,DCTMP + LOGICAL UNIDX,UNIDY,UNIDZ + DIMENSION XP(MXPART),YP(MXPART),ZP(MXPART),CNPT(MXPART,2), + & XBC(NCOL),YBC(NROW),ZBC(NCOL,NROW,NLAY), + & DELR(NCOL),DELC(NROW),DZ(NCOL,NROW,NLAY), + & DH(NCOL,NROW,NLAY),COLD(NCOL,NROW,NLAY), + & CADV(NCOL,NROW,NLAY),BUFF(NCOL,NROW,NLAY), + & PRSITY(NCOL,NROW,NLAY), + & NPCHEK(NCOL,NROW,NLAY),ICBUND(NCOL,NROW,NLAY), + & INDEXX(MXPART),INDEXY(MXPART),INDEXZ(MXPART) + COMMON /PD/HORIGN,XMAX,YMAX,ZMAX,UNIDX,UNIDY,UNIDZ + COMMON /AD/PERCEL,ITRACK,WD,ISEED,DCEPS,NPLANE,NPL,NPH, + & NPMIN,NPMAX,SRMULT,INTERP,NLSINK,NPSINK,DCHMOC +C +C--REMOVE PARTICLES THAT ARE NO LONGER NEEDED +C--AND UPDATE CONCENTRATIONS OF ACTIVE MOVING PARTICLES + JJ=1 + II=1 + KK=1 + NRC=0 + DO NP=NCOUNT,1,-1 + NN=NP + IF(NCOL.GT.1) JJ=INDEXX(NN) + IF(NROW.GT.1) II=INDEXY(NN) + IF(NLAY.GT.1) KK=INDEXZ(NN) +C +C--DETERMINE WHETHER PARTICLE SHOULD BE REMOVED + IF(NPCHEK(JJ,II,KK).LT.0) GOTO 100 + IF(NPCHEK(JJ,II,KK).EQ.0) GOTO 106 + IF(ICBUND(JJ,II,KK).EQ.0) GOTO 105 + IF(MIXELM.EQ.3.AND.BUFF(JJ,II,KK).LE.DCHMOC) GOTO 105 + IF(NPCHEK(JJ,II,KK).GT.NPMAX) GOTO 105 + +C +C--UPDATE PARTICLE CONCENTRATION + IF(ICBUND(JJ,II,KK).LT.0) THEN + CNPT(NN,1)=COLD(JJ,II,KK) + ELSE + DCTMP=COLD(JJ,II,KK)-CADV(JJ,II,KK) + CNPT(NN,1)=CNPT(NN,1)+DCTMP + IF(CNPT(NN,1).LT.0) THEN + NPCHEK(JJ,II,KK)=NPCHEK(JJ,II,KK)-1000 + GOTO 100 + ENDIF + ENDIF + GOTO 100 +C +C--REMOVE PARTICLE AND REARRANGE PARTICLE ARRAYS TO SAVE STORAGE + 105 NPCHEK(JJ,II,KK)=0 + 106 NLAST=NCOUNT-NRC + IF(NN.LT.NLAST) THEN + IF(NCOL.GT.1) THEN + XP(NN)=XP(NLAST) + INDEXX(NN)=INDEXX(NLAST) + ENDIF + IF(NROW.GT.1) THEN + YP(NN)=YP(NLAST) + INDEXY(NN)=INDEXY(NLAST) + ENDIF + IF(NLAY.GT.1) THEN + ZP(NN)=ZP(NLAST) + INDEXZ(NN)=INDEXZ(NLAST) + ENDIF + CNPT(NN,1)=CNPT(NLAST,1) + CNPT(NN,2)=CNPT(NLAST,2) + ENDIF + NRC=NRC+1 +C + 100 ENDDO +C +C--UPDATE NUMBER OF PARTICLES AFTER DELETION + NCOUNT=NCOUNT-NRC +C +C--SAVE TOTAL NUMBER OF PARTICLES BEFORE INSERTION + NPALL=NCOUNT +C +C--INSERT NEW PARTICLES IF NECESSARY. + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL +C +C--SKIP IF AT INACTIVE CELL +C--OR CONCENTRATION GRADIENT IS LESS THAN SPECIFIED VALUE +C--OR NUMBER OF PARTICLES IS GREATER THAN SPECIFIED MINIMUM + IF(ICBUND(J,I,K).EQ.0) GOTO 220 + IF(MIXELM.EQ.3.AND.BUFF(J,I,K).LE.DCHMOC) GOTO 220 + IF(NPCHEK(J,I,K).GT.NPMIN) GOTO 220 + IF(NPCHEK(J,I,K).LT.0.AND.NPCHEK(J,I,K)+1000.GT.NPMIN) GOTO 220 +C +C--CALCULATE NUMBER OF PARTICLES TO BE INSERTED +C--BASED UPON THE CONCENTRATION GRADIENT WITH ADJACENT CELLS + IF(BUFF(J,I,K).LE.DCEPS) THEN + NPCELL=NPL + ELSE + NPCELL=NPH + ENDIF + IF(ICBUND(J,I,K).GT.1020.AND.ICBUND(J,I,K).LT.1030) THEN + NPCELL=NPCELL*SRMULT + ENDIF +C +C--INSERT [NADD] NEW PARTICLES WITH CERTAIN PATTERN OR RANDOMLY + NADD=NPCELL + IF(NADD.LE.0) GOTO 220 + NCOLD=NCOUNT + IF(NPLANE.GT.0) THEN + CALL GENPTN(NCOL,NROW,NLAY,MXPART,NCOUNT,NPCHEK,J,I,K, + & XP,YP,ZP,CNPT,DELR,DELC,DZ,DH,PRSITY, + & XBC,YBC,ZBC,COLD,NADD,NPLANE) + ELSE + CALL GENPTR(NCOL,NROW,NLAY,MXPART,NCOUNT,NPCHEK,J,I,K, + & XP,YP,ZP,CNPT,DELR,DELC,DZ,DH,PRSITY, + & XBC,YBC,ZBC,COLD,NADD,ISEED) + ENDIF + IF(NCOUNT.GT.MXPART) GOTO 999 + DO NP=NCOLD+1,NCOUNT + IF(NCOL.GT.1) INDEXX(NP)=J + IF(NROW.GT.1) INDEXY(NP)=I + IF(NLAY.GT.1) INDEXZ(NP)=K + ENDDO +C + 220 ENDDO + ENDDO + ENDDO +C +C--UPDATE NUMBER OF TOTAL PARTICLES AFTER INSERTION + NPINS=NCOUNT-NPALL + NPALL=NCOUNT +C +C--CHECK WHETHER TOTAL NUMBER OF PARTICLES +C--HAS EXCEEDED THE SPECIFIED MAXIMUM. IF SO STOP + 999 IF(NCOUNT.GT.MXPART) THEN + WRITE(*,1000) MXPART,NCOUNT + CALL USTOP(' ') + ENDIF +1000 FORMAT(/1X,'ERROR: MAXIMUM NUMBER OF PARTICLES ALLOWED', + & ' [MXPART] IS',I10/ + & 1X,' ACTUAL NUMBER OF PARTICLES NEEDED AT THIS POINT', + & I10/1X,'INCREASE VALUE OF [MXPART] IN ADVECTION INPUT FILE') +C +C--NORMAL RETURN + RETURN + END +C +C + SUBROUTINE GENPTR(NCOL,NROW,NLAY,MXPART,NCOUNT,NPCHEK,JJ,II,KK, + & XP,YP,ZP,CNPT,DELR,DELC,DZ,DH,PRSITY, + & XBC,YBC,ZBC,COLD,NADD,ISEED) +C ******************************************************************** +C THIS SUBROUTINE INSERTS [NADD] NEW PARTICLES AT CELL (JJ,II,KK) +C RANDOMLY INSIDE THE CELL BLOCK. +C ******************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER NCOL,NROW,NLAY,JJ,II,KK,N,NP,NCOUNT,MXPART,NPCHEK, + & NADD,ISEED + REAL XP,YP,ZP,XBC,YBC,ZBC,DELC,DELR,DZ,DH,CNPT,COLD,RAN0, + & PRSITY + DIMENSION XP(MXPART),YP(MXPART),ZP(MXPART),CNPT(MXPART,2), + & DELR(NCOL),XBC(NCOL),DELC(NROW),YBC(NROW), + & ZBC(NCOL,NROW,NLAY),DZ(NCOL,NROW,NLAY), + & DH(NCOL,NROW,NLAY),COLD(NCOL,NROW,NLAY), + & PRSITY(NCOL,NROW,NLAY),NPCHEK(NCOL,NROW,NLAY) +C +C--SAVE NUMBER OF PARTICLES BEFORE INSERTION + NP=NCOUNT +C +C--RETURN IF NUMBER OF PARTICLES AFTER INSERTION WILL CAUSE +C--TOTAL NUMBER OF PARTICLES TO EXCEED PREDEFINED MAXIMUM. + NCOUNT=NP+NADD + NPCHEK(JJ,II,KK)=NPCHEK(JJ,II,KK)+NADD + IF(NCOUNT.GT.MXPART) RETURN +C +C--RANDOMLY INSERT NEW PARTICLES + DO N=NP+1,NCOUNT + IF(NCOL.GT.1) XP(N)=XBC(JJ)+(RAN0(ISEED)-0.5)*DELR(JJ) + IF(NROW.GT.1) YP(N)=YBC(II)+(RAN0(ISEED)-0.5)*DELC(II) + IF(NLAY.GT.1) ZP(N)=ZBC(JJ,II,KK)+0.5*DZ(JJ,II,KK) + & -RAN0(ISEED)*DH(JJ,II,KK) + CNPT(N,1)=COLD(JJ,II,KK) + CNPT(N,2)=DELR(JJ)*DELC(II)*DH(JJ,II,KK)*PRSITY(JJ,II,KK) + ENDDO +C + RETURN + END +C +C + FUNCTION RAN0(IDUM) +C ****************************************************************** +C THIS FUNCTION RETURNS A RANDOM NUMBER BETWEEN 0.0 AND 1.0. +C SET IDUM TO ANY NONZERO INTEGER TO INITIALIZE THE SEQUENCE. +C [MODIFIED FROM PRESS ET AL. (1992)]. +C ****************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER IDUM,IA,IM,IQ,IR,MASK,K + REAL RAN0,AM + PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836, + & MASK=123459876) +C + IDUM=IEOR(IDUM,MASK) + K=IDUM/IQ + IDUM=IA*(IDUM-K*IQ)-IR*K + IF(IDUM.LT.0) IDUM=IDUM+IM + RAN0=AM*IDUM + IDUM=IEOR(IDUM,MASK) +C + RETURN + END +C +C + SUBROUTINE GENPTN(NCOL,NROW,NLAY,MXPART,NCOUNT,NPCHEK,JJ,II,KK, + & XP,YP,ZP,CNPT,DELR,DELC,DZ,DH,PRSITY, + & XBC,YBC,ZBC,COLD,NADD,NPLANE) +C ******************************************************************** +C THIS SUBROUTINE INSERTS NEW PARTICLES AT CELL (JJ,II,KK) WITH +C A FIXED PATTERN BASED ON THE VALUES OF [NADD] AND [NPLANE]. +C ******************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER NCOL,NROW,NLAY,JJ,II,KK,N,NP,NCOUNT,MXPART,NPCHEK, + & NADD,NPLANE + REAL XP,YP,ZP,XBC,YBC,ZBC,DELR,DELC,DZ,DH, + & PRSITY,CNPT,COLD,UPFACE + DIMENSION XP(MXPART),YP(MXPART),ZP(MXPART),CNPT(MXPART,2), + & DELR(NCOL),XBC(NCOL),DELC(NROW),YBC(NROW), + & COLD(NCOL,NROW,NLAY),DZ(NCOL,NROW,NLAY), + & DH(NCOL,NROW,NLAY),ZBC(NCOL,NROW,NLAY), + & PRSITY(NCOL,NROW,NLAY),NPCHEK(NCOL,NROW,NLAY) +C +C--CALCULATE NUMBER OF PARTICLES TO BE PLACED PER "PLANE" + NADD=NADD/NPLANE +C +C--[NADD] MUST BE ONE OF THESE VALUES: 1, 4, 5, 8, 9 OR 16. +C--IF NOT, SET IT TO ONE OF THEM + IF(NADD.GT.1.AND.NADD.LT.4) NADD=4 + IF(NADD.GT.5.AND.NADD.LT.8) NADD=8 + IF(NADD.GT.9.AND.NADD.LT.16) NADD=9 + IF(NADD.GT.16) NADD=16 +C +C--SAVE NUMBER OF PARTICLES BEFORE INSERTION + NP=NCOUNT +C +C--RETURN IF NUMBER OF PARTICLES AFTER INSERTION WILL CAUSE +C--TOTAL NUMBER OF PARTICLES TO EXCEED PREDEFINED MAXIMUM. + NCOUNT=NP+NADD*NPLANE + NPCHEK(JJ,II,KK)=NPCHEK(JJ,II,KK)+NADD*NPLANE + IF(NCOUNT.GT.MXPART) RETURN +C +C-ASSIGN PARTICLE CONCENTRATION AND COORDINATES + DO N=NP+1,NCOUNT + CNPT(N,1)=COLD(JJ,II,KK) + CNPT(N,2)=DELR(JJ)*DELC(II)*DH(JJ,II,KK)*PRSITY(JJ,II,KK) + ENDDO + UPFACE=ZBC(JJ,II,KK)+0.5*DZ(JJ,II,KK)-DH(JJ,II,KK) +C + DO N=1,NPLANE +C +C--PLACE 1 PARTICLE AT NODAL CENTER IF [NADD]=1, 5, OR 9 + IF(NADD.EQ.1.OR.NADD.EQ.5.OR.NADD.EQ.9) THEN + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ) + IF(NROW.GT.1) YP(NP)=YBC(II) + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + ENDIF +C +C--PLACE 4 PARTICLES IN THE CELL IF [NADD]=4, 5, 8, OR 9 + IF(NADD.GT.1.AND.NADD.LT.16) THEN + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ)-DELR(JJ)/4. + IF(NROW.GT.1) YP(NP)=YBC(II)-DELC(II)/4. + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ)+DELR(JJ)/4. + IF(NROW.GT.1) YP(NP)=YBC(II)-DELC(II)/4. + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ)-DELR(JJ)/4. + IF(NROW.GT.1) YP(NP)=YBC(II)+DELC(II)/4. + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ)+DELR(JJ)/4. + IF(NROW.GT.1) YP(NP)=YBC(II)+DELC(II)/4. + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + ENDIF +C +C--ADD 4 MORE PARTICLES IN THE CELL IF [NADD]=8, OR 9 + IF(NADD.EQ.8.OR.NADD.EQ.9) THEN + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ) + IF(NROW.GT.1) YP(NP)=YBC(II)-DELC(II)/4. + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ)-DELR(JJ)/4. + IF(NROW.GT.1) YP(NP)=YBC(II) + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ)+DELR(JJ)/4. + IF(NROW.GT.1) YP(NP)=YBC(II) + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ) + IF(NROW.GT.1) YP(NP)=YBC(II)+DELC(II)/4. + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + ENDIF +C +C--PLACE 16 PARTICLES IN THE CELL IF [NADD]=16 + IF(NADD.EQ.16) THEN + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ)-DELR(JJ)*3./8. + IF(NROW.GT.1) YP(NP)=YBC(II)-DELC(II)*3./8. + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ)-DELR(JJ)/8. + IF(NROW.GT.1) YP(NP)=YBC(II)-DELC(II)*3/8. + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ)+DELR(JJ)/8. + IF(NROW.GT.1) YP(NP)=YBC(II)-DELC(II)*3./8. + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ)+DELR(JJ)*3./8. + IF(NROW.GT.1) YP(NP)=YBC(II)-DELC(II)*3./8. + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ)-DELR(JJ)*3./8. + IF(NROW.GT.1) YP(NP)=YBC(II)-DELC(II)/8. + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ)-DELR(JJ)/8. + IF(NROW.GT.1) YP(NP)=YBC(II)-DELC(II)/8. + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ)+DELR(JJ)/8. + IF(NROW.GT.1) YP(NP)=YBC(II)-DELC(II)/8. + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ)+DELR(JJ)*3./8. + IF(NROW.GT.1) YP(NP)=YBC(II)-DELC(II)/8. + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ)-DELR(JJ)*3./8. + IF(NROW.GT.1) YP(NP)=YBC(II)+DELC(II)/8. + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ)-DELR(JJ)/8. + IF(NROW.GT.1) YP(NP)=YBC(II)+DELC(II)/8. + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ)+DELR(JJ)/8. + IF(NROW.GT.1) YP(NP)=YBC(II)+DELC(II)/8. + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ)+DELR(JJ)*3./8. + IF(NROW.GT.1) YP(NP)=YBC(II)+DELC(II)/8. + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ)-DELR(JJ)*3./8. + IF(NROW.GT.1) YP(NP)=YBC(II)+DELC(II)*3./8. + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ)-DELR(JJ)/8. + IF(NROW.GT.1) YP(NP)=YBC(II)+DELC(II)*3/8. + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ)+DELR(JJ)/8. + IF(NROW.GT.1) YP(NP)=YBC(II)+DELC(II)*3./8. + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + NP=NP+1 + IF(NCOL.GT.1) XP(NP)=XBC(JJ)+DELR(JJ)*3./8. + IF(NROW.GT.1) YP(NP)=YBC(II)+DELC(II)*3./8. + IF(NLAY.GT.1) ZP(NP)=UPFACE+N*DH(JJ,II,KK)/(NPLANE+1) + ENDIF +C + ENDDO +C +C--NORMAL RETURN + RETURN + END +C +C + FUNCTION SADV5Q(NCOL,NROW,NLAY,JJ,II,KK,ICBUND,DELR,DELC,DH, + & COLD,QX,QY,QZ,DTRANS,NADVFD) +C ******************************************************************* +C THIS FUNCTION COMPUTES ADVECTIVE MASS FLUX BETWEEN CELL (JJ,II,KK) +C AND THE SURROUNDING CELLS DURING TIME INCREMENT DTRANS. MASS IS +C MOVING OUT OF THE CELL IF SADV5Q > 0, INTO THE CELL IF SADV5Q < 0. +C NADVFD=1 IS FOR THE UPSTREAM SCHEME; NADVFD=2 IS FOR THE CENTRAL +C WEIGHTING SCHEME. +C ******************************************************************* +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER ICBUND,NCOL,NROW,NLAY,JJ,II,KK,NADVFD + REAL SADV5Q,COLD,QX,QY,QZ,DELR,DELC,DH,AREA,DTRANS,QCTMP, + & WW,THKSAT,ALPHA,CTMP + DIMENSION ICBUND(NCOL,NROW,NLAY),COLD(NCOL,NROW,NLAY), + & QX(NCOL,NROW,NLAY),QY(NCOL,NROW,NLAY), + & QZ(NCOL,NROW,NLAY),DELR(NCOL),DELC(NROW), + & DH(NCOL,NROW,NLAY) +C +C--SET QCTMP = 0 FOR ACCUMULATING Q*C*DTRANS IN ALL FACES + QCTMP=0. +C +C--CALCULATE IN THE Z DIRECTION + IF(NLAY.LT.2) GOTO 410 + AREA=DELR(JJ)*DELC(II) +C--TOP FACE + IF(KK.GT.1.AND.ICBUND(JJ,II,KK-1).NE.0) THEN + WW=DH(JJ,II,KK)/(DH(JJ,II,KK-1)+DH(JJ,II,KK)) + ALPHA=0. + IF(QZ(JJ,II,KK-1).GT.0) ALPHA=1. + IF(NADVFD.EQ.2) ALPHA=WW + CTMP=COLD(JJ,II,KK-1)*ALPHA + COLD(JJ,II,KK)*(1.-ALPHA) + QCTMP=QCTMP-QZ(JJ,II,KK-1)*CTMP*AREA*DTRANS + ENDIF +C--BOTTOM FACE + IF(KK.LT.NLAY.AND.ICBUND(JJ,II,KK+1).NE.0) THEN + WW=DH(JJ,II,KK+1)/(DH(JJ,II,KK)+DH(JJ,II,KK+1)) + ALPHA=0. + IF(QZ(JJ,II,KK).GT.0) ALPHA=1. + IF(NADVFD.EQ.2) ALPHA=WW + CTMP=COLD(JJ,II,KK)*ALPHA + COLD(JJ,II,KK+1)*(1.-ALPHA) + QCTMP=QCTMP+QZ(JJ,II,KK)*CTMP*AREA*DTRANS + ENDIF +C +C--CALCULATE IN THE Y DIRECTION + 410 IF(NROW.LT.2) GOTO 420 +C--BACK FACE + IF(II.GT.1.AND.ICBUND(JJ,II-1,KK).NE.0) THEN + WW=DELC(II)/(DELC(II)+DELC(II-1)) + THKSAT=DH(JJ,II-1,KK)*WW+DH(JJ,II,KK)*(1.-WW) + AREA=DELR(JJ)*THKSAT + ALPHA=0. + IF(QY(JJ,II-1,KK).GT.0) ALPHA=1. + IF(NADVFD.EQ.2) ALPHA=WW + CTMP=COLD(JJ,II-1,KK)*ALPHA + COLD(JJ,II,KK)*(1.-ALPHA) + QCTMP=QCTMP-QY(JJ,II-1,KK)*CTMP*AREA*DTRANS + ENDIF +C--FRONT FACE + IF(II.LT.NROW.AND.ICBUND(JJ,II+1,KK).NE.0) THEN + WW=DELC(II+1)/(DELC(II+1)+DELC(II)) + THKSAT=DH(JJ,II,KK)*WW+DH(JJ,II+1,KK)*(1.-WW) + AREA=DELR(JJ)*THKSAT + ALPHA=0. + IF(QY(JJ,II,KK).GT.0) ALPHA=1. + IF(NADVFD.EQ.2) ALPHA=WW + CTMP=COLD(JJ,II,KK)*ALPHA + COLD(JJ,II+1,KK)*(1.-ALPHA) + QCTMP=QCTMP+QY(JJ,II,KK)*CTMP*AREA*DTRANS + ENDIF +C +C--CALCULATE IN THE X DIRECTION + 420 IF(NCOL.LT.2) GOTO 430 +C--LEFT FACE + IF(JJ.GT.1.AND.ICBUND(JJ-1,II,KK).NE.0) THEN + WW=DELR(JJ)/(DELR(JJ)+DELR(JJ-1)) + THKSAT=DH(JJ-1,II,KK)*WW+DH(JJ,II,KK)*(1.-WW) + AREA=DELC(II)*THKSAT + ALPHA=0. + IF(QX(JJ-1,II,KK).GT.0) ALPHA=1. + IF(NADVFD.EQ.2) ALPHA=WW + CTMP=COLD(JJ-1,II,KK)*ALPHA + COLD(JJ,II,KK)*(1.-ALPHA) + QCTMP=QCTMP-QX(JJ-1,II,KK)*CTMP*AREA*DTRANS + ENDIF +C--RIGHT FACE + IF(JJ.LT.NCOL.AND.ICBUND(JJ+1,II,KK).NE.0) THEN + WW=DELR(JJ+1)/(DELR(JJ+1)+DELR(JJ)) + THKSAT=DH(JJ,II,KK)*WW+DH(JJ+1,II,KK)*(1.-WW) + AREA=DELC(II)*THKSAT + ALPHA=0. + IF(QX(JJ,II,KK).GT.0) ALPHA=1. + IF(NADVFD.EQ.2) ALPHA=WW + CTMP=COLD(JJ,II,KK)*ALPHA + COLD(JJ+1,II,KK)*(1.-ALPHA) + QCTMP=QCTMP+QX(JJ,II,KK)*CTMP*AREA*DTRANS + ENDIF +C +C--ASSIGN QCTMP TO THE FUNCTION AND RETURN + 430 SADV5Q=QCTMP +C + RETURN + END +C +C + SUBROUTINE SADV5F(NCOL,NROW,NLAY,ICBUND,DELR,DELC,DH,PRSITY, + & CNEW,COLD,QX,QY,QZ,RETA,DTRANS,RMASIO) +C ********************************************************************* +C THIS SUBROUTINE SOLVES THE ADVECTION TERM WITH THE UPSTREAM WEIGHTING +C FINITE DIFFERENCE SCHEME. +C ********************************************************************* +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER ICBUND,NCOL,NROW,NLAY,JJ,II,KK + REAL COLD,QX,QY,QZ,DELR,DELC,DH,CNEW,PRSITY, + & RETA,RMASIO,QCTMP,DTRANS,AREA,THKSAT,WW + DIMENSION ICBUND(NCOL,NROW,NLAY),QX(NCOL,NROW,NLAY), + & QY(NCOL,NROW,NLAY),QZ(NCOL,NROW,NLAY),DELR(NCOL), + & DELC(NROW),DH(NCOL,NROW,NLAY),COLD(NCOL,NROW,NLAY), + & CNEW(NCOL,NROW,NLAY),RETA(NCOL,NROW,NLAY), + & PRSITY(NCOL,NROW,NLAY),RMASIO(122,2) +C +C--LOOP THROUGH ALL CELLS + DO KK=1,NLAY + DO II=1,NROW + DO JJ=1,NCOL +C + IF(ICBUND(JJ,II,KK).EQ.0) CYCLE +C +C--SET QCTMP = 0 FOR ACCUMULATING Q*C*DTRANS IN ALL FACES + QCTMP=0. +C +C--CALCULATE IN THE Z DIRECTION + IF(NLAY.LT.2) GOTO 410 + AREA=DELR(JJ)*DELC(II) +C--TOP FACE + IF(KK.GT.1.AND.ICBUND(JJ,II,KK-1).NE.0) THEN + IF(QZ(JJ,II,KK-1).GT.0) THEN + QCTMP=QCTMP-QZ(JJ,II,KK-1)*COLD(JJ,II,KK-1)*AREA*DTRANS + ELSE + QCTMP=QCTMP-QZ(JJ,II,KK-1)*COLD(JJ,II,KK)*AREA*DTRANS + ENDIF + ENDIF +C--BOTTOM FACE + IF(KK.LT.NLAY.AND.ICBUND(JJ,II,KK+1).NE.0) THEN + IF(QZ(JJ,II,KK).GT.0) THEN + QCTMP=QCTMP+QZ(JJ,II,KK)*COLD(JJ,II,KK)*AREA*DTRANS + ELSE + QCTMP=QCTMP+QZ(JJ,II,KK)*COLD(JJ,II,KK+1)*AREA*DTRANS + ENDIF + ENDIF +C +C--CALCULATE IN THE Y DIRECTION + 410 IF(NROW.LT.2) GOTO 420 +C--BACK FACE + IF(II.GT.1.AND.ICBUND(JJ,II-1,KK).NE.0) THEN + WW=DELC(II)/(DELC(II)+DELC(II-1)) + THKSAT=DH(JJ,II-1,KK)*WW+DH(JJ,II,KK)*(1.-WW) + AREA=DELR(JJ)*THKSAT + IF(QY(JJ,II-1,KK).GT.0) THEN + QCTMP=QCTMP-QY(JJ,II-1,KK)*COLD(JJ,II-1,KK)*AREA*DTRANS + ELSE + QCTMP=QCTMP-QY(JJ,II-1,KK)*COLD(JJ,II,KK)*AREA*DTRANS + ENDIF + ENDIF +C--FRONT FACE + IF(II.LT.NROW.AND.ICBUND(JJ,II+1,KK).NE.0) THEN + WW=DELC(II+1)/(DELC(II+1)+DELC(II)) + THKSAT=DH(JJ,II,KK)*WW+DH(JJ,II+1,KK)*(1.-WW) + AREA=DELR(JJ)*THKSAT + IF(QY(JJ,II,KK).GT.0) THEN + QCTMP=QCTMP+QY(JJ,II,KK)*COLD(JJ,II,KK)*AREA*DTRANS + ELSE + QCTMP=QCTMP+QY(JJ,II,KK)*COLD(JJ,II+1,KK)*AREA*DTRANS + ENDIF + ENDIF +C +C--CALCULATE IN THE X DIRECTION + 420 IF(NCOL.LT.2) GOTO 430 +C--LEFT FACE + IF(JJ.GT.1.AND.ICBUND(JJ-1,II,KK).NE.0) THEN + WW=DELR(JJ)/(DELR(JJ)+DELR(JJ-1)) + THKSAT=DH(JJ-1,II,KK)*WW+DH(JJ,II,KK)*(1.-WW) + AREA=DELC(II)*THKSAT + IF(QX(JJ-1,II,KK).GT.0) THEN + QCTMP=QCTMP-QX(JJ-1,II,KK)*COLD(JJ-1,II,KK)*AREA*DTRANS + ELSE + QCTMP=QCTMP-QX(JJ-1,II,KK)*COLD(JJ,II,KK)*AREA*DTRANS + ENDIF + ENDIF +C--RIGHT FACE + IF(JJ.LT.NCOL.AND.ICBUND(JJ+1,II,KK).NE.0) THEN + WW=DELR(JJ+1)/(DELR(JJ+1)+DELR(JJ)) + THKSAT=DH(JJ,II,KK)*WW+DH(JJ+1,II,KK)*(1.-WW) + AREA=DELC(II)*THKSAT + IF(QX(JJ,II,KK).GT.0) THEN + QCTMP=QCTMP+QX(JJ,II,KK)*COLD(JJ,II,KK)*AREA*DTRANS + ELSE + QCTMP=QCTMP+QX(JJ,II,KK)*COLD(JJ+1,II,KK)*AREA*DTRANS + ENDIF + ENDIF + 430 CONTINUE +C +C--UPDATE CONCENTRATION AT ACTIVE CELL AND +C--SAVE MASS INTO OR OUT OF CONSTANT-CONCENTRATION CELL + IF(ICBUND(JJ,II,KK).LT.0) THEN + IF(QCTMP.GT.0) THEN + RMASIO(6,1)=RMASIO(6,1)+QCTMP + ELSE + RMASIO(6,2)=RMASIO(6,2)+QCTMP + ENDIF + ELSEIF(ICBUND(JJ,II,KK).GT.0) THEN + CNEW(JJ,II,KK)=COLD(JJ,II,KK)-QCTMP/(DELR(JJ)*DELC(II)* + & DH(JJ,II,KK)*PRSITY(JJ,II,KK)*RETA(JJ,II,KK)) + ENDIF +C + ENDDO + ENDDO + ENDDO +C +C--RETURN + RETURN + END +C +C + SUBROUTINE VRK4(P,V,DT,J0,I0,K0,NCOL,NROW,NLAY,ICBUND, + & DELR,DELC,DZ,XBC,YBC,ZBC,DH,PRSITY,QX,QY,QZ,RETA) +C ******************************************************************* +C THIS SUBROUTINE CALCULATES WEIGHTED VELOCITY NEEDED FOR MOVING +C PARTICLE P OVER DT USING THE 4TH-ORDER RUNGE-KUTTA SOLUTION. +C ******************************************************************* +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER NCOL,NROW,NLAY,ICBUND,JP,IP,KP,J0,I0,K0,J,I,K,N + REAL P,PT,V,VM,VT,DELR,DELC,DZ,XBC,YBC,ZBC,DH,PRSITY, + & QX,QY,QZ,DTHALF,DT,RETA,HORIGN,XMAX,YMAX,ZMAX, + & ALPHA,UPFACE + LOGICAL UNIDX,UNIDY,UNIDZ + DIMENSION ICBUND(NCOL,NROW,NLAY), + & DELR(NCOL),DELC(NROW),DZ(NCOL,NROW,NLAY), + & XBC(NCOL),YBC(NROW),ZBC(NCOL,NROW,NLAY), + & DH(NCOL,NROW,NLAY),PRSITY(NCOL,NROW,NLAY), + & QX(NCOL,NROW,NLAY),QY(NCOL,NROW,NLAY), + & QZ(NCOL,NROW,NLAY),RETA(NCOL,NROW,NLAY), + & P(3),V(3),PT(3),VM(3),VT(3) + COMMON /PD/HORIGN,XMAX,YMAX,ZMAX,UNIDX,UNIDY,UNIDZ +C +C--INITIALIZE + DTHALF=DT*0.5 + JP=J0 + IP=I0 + KP=K0 + DO N=1,3 + VT(N)=0. + VM(N)=0. + ENDDO +C +C--GET POSITION OF FIRST TRIAL MIDPOINT + DO N=1,3 + PT(N)=P(N)+DTHALF*V(N) + ENDDO +C +C--LOCATE INDICES OF FIRST TRIAL MIDPOINT + IF(UNIDX) THEN + JP=INT(PT(1)/DELR(1))+1 + IF(JP.LT.1) JP=1 + IF(JP.GT.NCOL) JP=NCOL + ELSE + JP=NCOL + DO J=1,NCOL + IF(PT(1).LT.XBC(J)+0.5*DELR(J)) THEN + JP=J + GOTO 11 + ENDIF + ENDDO + ENDIF + 11 IF(UNIDY) THEN + IP=INT(PT(2)/DELC(1))+1 + IF(IP.LT.1) IP=1 + IF(IP.GT.NROW) IP=NROW + ELSE + IP=NROW + DO I=1,NROW + IF(PT(2).LT.YBC(I)+0.5*DELC(I)) THEN + IP=I + GOTO 12 + ENDIF + ENDDO + ENDIF + 12 IF(UNIDZ) THEN + KP=INT(PT(3)/DZ(JP,IP,1))+1 + IF(KP.LT.1) KP=1 + IF(KP.GT.NLAY) KP=NLAY + ELSE + KP=NLAY + DO K=1,NLAY + IF(PT(3).LT.ZBC(JP,IP,K)+0.5*DZ(JP,IP,K)) THEN + KP=K + GOTO 13 + ENDIF + ENDDO + ENDIF + 13 IF(ICBUND(JP,IP,KP).EQ.0) GOTO 14 +C +C--GET VELOCITY AT FIRST TRIAL MIDPOINT + IF(NCOL.GT.1) THEN + ALPHA=(PT(1)-XBC(JP)+0.5*DELR(JP))/DELR(JP) + IF(JP-1.LT.1) THEN + VT(1)=ALPHA*QX(JP,IP,KP)/(PRSITY(JP,IP,KP)*RETA(JP,IP,KP)) + ELSE + VT(1)=(ALPHA*QX(JP,IP,KP)+(1.-ALPHA)*QX(JP-1,IP,KP)) + & /(PRSITY(JP,IP,KP)*RETA(JP,IP,KP)) + ENDIF + ENDIF + IF(NROW.GT.1) THEN + ALPHA=(PT(2)-YBC(IP)+0.5*DELC(IP))/DELC(IP) + IF(IP-1.LT.1) THEN + VT(2)=ALPHA*QY(JP,IP,KP)/(PRSITY(JP,IP,KP)*RETA(JP,IP,KP)) + ELSE + VT(2)=(ALPHA*QY(JP,IP,KP)+(1.-ALPHA)*QY(JP,IP-1,KP)) + & /(PRSITY(JP,IP,KP)*RETA(JP,IP,KP)) + ENDIF + ENDIF + IF(NLAY.GT.1) THEN + UPFACE=ZBC(JP,IP,KP)+0.5*DZ(JP,IP,KP)-DH(JP,IP,KP) + ALPHA=(PT(3)-UPFACE)/DH(JP,IP,KP) + IF(ALPHA.LT.0) ALPHA=0 + IF(KP-1.LT.1) THEN + VT(3)=ALPHA*QZ(JP,IP,KP)/(PRSITY(JP,IP,KP)*RETA(JP,IP,KP)) + ELSE + VT(3)=(ALPHA*QZ(JP,IP,KP)+(1.-ALPHA)*QZ(JP,IP,KP-1)) + & /(PRSITY(JP,IP,KP)*RETA(JP,IP,KP)) + ENDIF + ENDIF +C +C--GET POSITION OF SECOND TRIAL MIDPOINT + 14 DO N=1,3 + PT(N)=P(N)+DTHALF*VT(N) + ENDDO +C +C--LOCATE INDICES OF SECOND TRIAL MIDPOINT + IF(UNIDX) THEN + JP=INT(PT(1)/DELR(1))+1 + IF(JP.LT.1) JP=1 + IF(JP.GT.NCOL) JP=NCOL + ELSE + JP=NCOL + DO J=1,NCOL + IF(PT(1).LT.XBC(J)+0.5*DELR(J)) THEN + JP=J + GOTO 21 + ENDIF + ENDDO + ENDIF + 21 IF(UNIDY) THEN + IP=INT(PT(2)/DELC(1))+1 + IF(IP.LT.1) IP=1 + IF(IP.GT.NROW) IP=NROW + ELSE + IP=NROW + DO I=1,NROW + IF(PT(2).LT.YBC(I)+0.5*DELC(I)) THEN + IP=I + GOTO 22 + ENDIF + ENDDO + ENDIF + 22 IF(UNIDZ) THEN + KP=INT(PT(3)/DZ(JP,IP,1))+1 + IF(KP.LT.1) KP=1 + IF(KP.GT.NLAY) KP=NLAY + ELSE + KP=NLAY + DO K=1,NLAY + IF(PT(3).LT.ZBC(JP,IP,K)+0.5*DZ(JP,IP,K)) THEN + KP=K + GOTO 23 + ENDIF + ENDDO + ENDIF + 23 IF(ICBUND(JP,IP,KP).EQ.0) GOTO 24 +C +C-GET VELOCITY AT SECOND TRIAL MIDPOINT + IF(NCOL.GT.1) THEN + ALPHA=(PT(1)-XBC(JP)+0.5*DELR(JP))/DELR(JP) + IF(JP-1.LT.1) THEN + VM(1)=ALPHA*QX(JP,IP,KP)/(PRSITY(JP,IP,KP)*RETA(JP,IP,KP)) + ELSE + VM(1)=(ALPHA*QX(JP,IP,KP)+(1.-ALPHA)*QX(JP-1,IP,KP)) + & /(PRSITY(JP,IP,KP)*RETA(JP,IP,KP)) + ENDIF + ENDIF + IF(NROW.GT.1) THEN + ALPHA=(PT(2)-YBC(IP)+0.5*DELC(IP))/DELC(IP) + IF(IP-1.LT.1) THEN + VM(2)=ALPHA*QY(JP,IP,KP)/(PRSITY(JP,IP,KP)*RETA(JP,IP,KP)) + ELSE + VM(2)=(ALPHA*QY(JP,IP,KP)+(1.-ALPHA)*QY(JP,IP-1,KP)) + & /(PRSITY(JP,IP,KP)*RETA(JP,IP,KP)) + ENDIF + ENDIF + IF(NLAY.GT.1) THEN + UPFACE=ZBC(JP,IP,KP)+0.5*DZ(JP,IP,KP)-DH(JP,IP,KP) + ALPHA=(PT(3)-UPFACE)/DH(JP,IP,KP) + IF(ALPHA.LT.0) ALPHA=0 + IF(KP-1.LT.1) THEN + VM(3)=ALPHA*QZ(JP,IP,KP)/(PRSITY(JP,IP,KP)*RETA(JP,IP,KP)) + ELSE + VM(3)=(ALPHA*QZ(JP,IP,KP)+(1.-ALPHA)*QZ(JP,IP,KP-1)) + & /(PRSITY(JP,IP,KP)*RETA(JP,IP,KP)) + ENDIF + ENDIF +C +C--GET POSITION OF TRIAL END POINT AND +C--ACCUMULATE VELOCITIES AT TWO TRIAL MIDPOINTS + 24 DO N=1,3 + PT(N)=P(N)+DT*VM(N) + VM(N)=VT(N)+VM(N) + ENDDO +C +C--LOCATE INDICES OF TRIAL END POINT + IF(UNIDX) THEN + JP=INT(PT(1)/DELR(1))+1 + IF(JP.LT.1) JP=1 + IF(JP.GT.NCOL) JP=NCOL + ELSE + JP=NCOL + DO J=1,NCOL + IF(PT(1).LT.XBC(J)+0.5*DELR(J)) THEN + JP=J + GOTO 31 + ENDIF + ENDDO + ENDIF + 31 IF(UNIDY) THEN + IP=INT(PT(2)/DELC(1))+1 + IF(IP.LT.1) IP=1 + IF(IP.GT.NROW) IP=NROW + ELSE + IP=NROW + DO I=1,NROW + IF(PT(2).LT.YBC(I)+0.5*DELC(I)) THEN + IP=I + GOTO 32 + ENDIF + ENDDO + ENDIF + 32 IF(UNIDZ) THEN + KP=INT(PT(3)/DZ(JP,IP,1))+1 + IF(KP.LT.1) KP=1 + IF(KP.GT.NLAY) KP=NLAY + ELSE + KP=NLAY + DO K=1,NLAY + IF(PT(3).LT.ZBC(JP,IP,K)+0.5*DZ(JP,IP,K)) THEN + KP=K + GOTO 33 + ENDIF + ENDDO + ENDIF + 33 IF(ICBUND(JP,IP,KP).EQ.0) GOTO 34 +C +C--GET VELOCITY AT TRIAL END POINT + IF(NCOL.GT.1) THEN + ALPHA=(PT(1)-XBC(JP)+0.5*DELR(JP))/DELR(JP) + IF(JP-1.LT.1) THEN + VT(1)=ALPHA*QX(JP,IP,KP)/(PRSITY(JP,IP,KP)*RETA(JP,IP,KP)) + ELSE + VT(1)=(ALPHA*QX(JP,IP,KP)+(1.-ALPHA)*QX(JP-1,IP,KP)) + & /(PRSITY(JP,IP,KP)*RETA(JP,IP,KP)) + ENDIF + ENDIF + IF(NROW.GT.1) THEN + ALPHA=(PT(2)-YBC(IP)+0.5*DELC(IP))/DELC(IP) + IF(IP-1.LT.1) THEN + VT(2)=ALPHA*QY(JP,IP,KP)/(PRSITY(JP,IP,KP)*RETA(JP,IP,KP)) + ELSE + VT(2)=(ALPHA*QY(JP,IP,KP)+(1.-ALPHA)*QY(JP,IP-1,KP)) + & /(PRSITY(JP,IP,KP)*RETA(JP,IP,KP)) + ENDIF + ENDIF + IF(NLAY.GT.1) THEN + UPFACE=ZBC(JP,IP,KP)+0.5*DZ(JP,IP,KP)-DH(JP,IP,KP) + ALPHA=(PT(3)-UPFACE)/DH(JP,IP,KP) + IF(ALPHA.LT.0) ALPHA=0 + IF(KP-1.LT.1) THEN + VT(3)=ALPHA*QZ(JP,IP,KP)/(PRSITY(JP,IP,KP)*RETA(JP,IP,KP)) + ELSE + VT(3)=(ALPHA*QZ(JP,IP,KP)+(1.-ALPHA)*QZ(JP,IP,KP-1)) + & /(PRSITY(JP,IP,KP)*RETA(JP,IP,KP)) + ENDIF + ENDIF +C +C--GET FINAL WEIGHTED VELOCITY + 34 DO N=1,3 + V(N)=(V(N)+VT(N)+2.*VM(N))/6. + ENDDO +C +C--NORMAL EXIT + RETURN + END +C +C + SUBROUTINE ADV5FM(NCOL,NROW,NLAY,MCOMP,ICOMP,ICBUND,DELR,DELC,DH, + & QX,QY,QZ,NADVFD,NODES,A,UPDLHS) +C ********************************************************************* +C THIS SUBROUTINE FORMULATES COEFFICIENT MATRICES FOR THE ADVECTION +C TERM WITH THE OPTIONS OF UPSTREAM (NADVFD=1) AND CENTRAL (NADVFD=2) +C WEIGHTING. +C ********************************************************************* +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER ICBUND,NCOL,NROW,NLAY,NODES,MCOMP,ICOMP,NADVFD,J, + & I,K,N,NCR,IUPS,ICTRL + REAL QX,QY,QZ,DELR,DELC,DH,A,WW,THKSAT,AREA,ALPHA + LOGICAL UPDLHS + DIMENSION ICBUND(NODES,MCOMP),QX(NODES),QY(NODES),QZ(NODES), + & DELR(NCOL),DELC(NROW),DH(NODES),A(NODES,*) + PARAMETER (IUPS=1,ICTRL=2) +C +C--RETURN IF COEFF MATRICES ARE NOT TO BE UPDATED + IF(.NOT.UPDLHS) GOTO 999 +C +C--LOOP THROUGH ALL ACTIVE CELLS + NCR=NROW*NCOL + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + N=(K-1)*NCR + (I-1)*NCOL + J +C +C--SKIP IF INACTIVE OR CONSTANT CELL + IF(ICBUND(N,ICOMP).LE.0) CYCLE +C +C--------CALCULATE IN THE Z DIRECTION + IF(NLAY.LT.2) GOTO 410 + AREA=DELR(J)*DELC(I) +C-----------TOP FACE + IF(K.GT.1) THEN + ALPHA = 0. + IF(NADVFD.EQ.ICTRL) ALPHA=DH(N-NCR)/(DH(N-NCR)+DH(N)) + IF(NADVFD.EQ.IUPS.AND.QZ(N-NCR).LT.0.) ALPHA=1.0 + A(N,1)=A(N,1)+ALPHA*QZ(N-NCR)*AREA + A(N,2)=A(N,2)+(1.-ALPHA)*QZ(N-NCR)*AREA + ENDIF +C-----------BOTTOM FACE + IF(K.LT.NLAY) THEN + ALPHA = 0. + IF(NADVFD.EQ.ICTRL) ALPHA=DH(N)/(DH(N)+DH(N+NCR)) + IF(NADVFD.EQ.IUPS.AND.QZ(N).LT.0.) ALPHA=1.0 + A(N,1)=A(N,1)-(1.-ALPHA)*QZ(N)*AREA + A(N,3)=A(N,3)-ALPHA*QZ(N)*AREA + ENDIF +C +C--------CALCULATE IN THE Y DIRECTION + 410 IF(NROW.LT.2) GOTO 420 +C-----------BACK FACE + IF(I.GT.1) THEN + WW=DELC(I)/(DELC(I)+DELC(I-1)) + THKSAT=DH(N-NCOL)*WW+DH(N)*(1.-WW) + AREA=DELR(J)*THKSAT + ALPHA = 0. + IF(NADVFD.EQ.ICTRL) ALPHA=DELC(I-1)/(DELC(I-1)+DELC(I)) + IF(NADVFD.EQ.IUPS.AND.QY(N-NCOL).LT.0.) ALPHA=1.0 + A(N,1)=A(N,1)+ALPHA*QY(N-NCOL)*AREA + A(N,4)=A(N,4)+(1.-ALPHA)*QY(N-NCOL)*AREA + ENDIF +C-----------FRONT FACE + IF(I.LT.NROW) THEN + WW=DELC(I+1)/(DELC(I+1)+DELC(I)) + THKSAT=DH(N)*WW+DH(N+NCOL)*(1.-WW) + AREA=DELR(J)*THKSAT + ALPHA = 0. + IF(NADVFD.EQ.ICTRL) ALPHA=DELC(I)/(DELC(I)+DELC(I+1)) + IF(NADVFD.EQ.IUPS.AND.QY(N).LT.0.) ALPHA=1.0 + A(N,1)=A(N,1)-(1.-ALPHA)*QY(N)*AREA + A(N,5)=A(N,5)-ALPHA*QY(N)*AREA + ENDIF +C +C----------CALCULATE IN THE X DIRECTION + 420 IF(NCOL.LT.2) GOTO 430 +C-----------LEFT FACE + IF(J.GT.1) THEN + WW=DELR(J)/(DELR(J)+DELR(J-1)) + THKSAT=DH(N-1)*WW+DH(N)*(1.-WW) + AREA=DELC(I)*THKSAT + ALPHA = 0. + IF(NADVFD.EQ.ICTRL) ALPHA=DELR(J-1)/(DELR(J-1)+DELR(J)) + IF(NADVFD.EQ.IUPS.AND.QX(N-1).LT.0.) ALPHA=1.0 + A(N,1)=A(N,1)+ALPHA*QX(N-1)*AREA + A(N,6)=A(N,6)+(1.-ALPHA)*QX(N-1)*AREA + ENDIF +C-----------RIGHT FACE + IF(J.LT.NCOL) THEN + WW=DELR(J+1)/(DELR(J+1)+DELR(J)) + THKSAT=DH(N)*WW+DH(N+1)*(1.-WW) + AREA=DELC(I)*THKSAT + ALPHA = 0. + IF(NADVFD.EQ.ICTRL) ALPHA=DELR(J)/(DELR(J)+DELR(J+1)) + IF(NADVFD.EQ.IUPS.AND.QX(N).LT.0.) ALPHA=1.0 + A(N,1)=A(N,1)-(1-ALPHA)*QX(N)*AREA + A(N,7)=A(N,7)-ALPHA*QX(N)*AREA + ENDIF +C + 430 CONTINUE + ENDDO + ENDDO + ENDDO +C +C--RETURN + 999 RETURN + END +C +C + SUBROUTINE ADV5BD(IOUT,NCOL,NROW,NLAY,MCOMP,ICOMP,NADVFD, + & ICBUND,DELR,DELC,DH,QX,QY,QZ,CNEW,DTRANS,RMASIO) +C ********************************************************************** +C THIS SUBROUTINE CALCULATES MASS BUDGET OF CONSTANT-CONCENTRATION NODES +C DUE TO ADVECTION. +C ********************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER IOUT,NCOL,NROW,NLAY,MCOMP,ICOMP,ICBUND,J,I,K,NADVFD + REAL DELR,DELC,DH,QX,QY,QZ,CNEW,RMASIO, + & DTRANS,SADV5Q,QCTMP + DIMENSION ICBUND(NCOL,NROW,NLAY,MCOMP),DELR(NCOL),DELC(NROW), + & DH(NCOL,NROW,NLAY),QX(NCOL,NROW,NLAY), + & QY(NCOL,NROW,NLAY),QZ(NCOL,NROW,NLAY), + & CNEW(NCOL,NROW,NLAY,MCOMP),RMASIO(122,2,MCOMP) +C +C--LOOP OVER ALL MODEL CELLS + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL +C +C--SKIP IF NOT CONSTANT-CONCENTRATION CELLS + IF(ICBUND(J,I,K,ICOMP).LT.0) THEN + QCTMP=SADV5Q(NCOL,NROW,NLAY,J,I,K,ICBUND(1,1,1,ICOMP), + & DELR,DELC,DH,CNEW(1,1,1,ICOMP),QX,QY,QZ,DTRANS,NADVFD) + IF(QCTMP.GT.0) THEN + RMASIO(6,1,ICOMP)=RMASIO(6,1,ICOMP)+QCTMP + ELSE + RMASIO(6,2,ICOMP)=RMASIO(6,2,ICOMP)+QCTMP + ENDIF + ENDIF +C + ENDDO + ENDDO + ENDDO +C +C--RETURN + RETURN + END +C +C + SUBROUTINE SADV5U(NCOL,NROW,NLAY,ICBUND,DELR,DELC,DH,PRSITY, + & CNEW,COLD,CTOP,CBCK,QX,QY,QZ,RETA,DTRANS,RMASIO) +C ********************************************************************* +C THIS SUBROUTINE SOLVES THE ADVECTION TERM WITH THE 3RD ORDER TVD +C SCHEME (ULTIMATE). +C ********************************************************************* +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER ICBUND,NCOL,NROW,NLAY,J,I,K,IX,IY,IZ + REAL COLD,QX,QY,QZ,DELR,DELC,DH,CNEW,PRSITY,RETA,DTRANS, + & CBCK,CTMP,WW,CTOP,CRGT,CTOTAL,CFACE,RMASIO + DIMENSION ICBUND(NCOL,NROW,NLAY),QX(NCOL,NROW,NLAY), + & QY(NCOL,NROW,NLAY),QZ(NCOL,NROW,NLAY),DELR(NCOL), + & DELC(NROW),DH(NCOL,NROW,NLAY),COLD(NCOL,NROW,NLAY), + & CNEW(NCOL,NROW,NLAY),RETA(NCOL,NROW,NLAY), + & CTOP(NCOL,NROW,NLAY),PRSITY(NCOL,NROW,NLAY), + & CBCK(NCOL,NROW,NLAY),RMASIO(122,2) + PARAMETER (IX=1,IY=2,IZ=3) +C +C--CLEAR TEMPORARY ARRAYS + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K).EQ.0) CYCLE + CTOP(J,I,K)=0. + CBCK(J,I,K)=0. + ENDDO + ENDDO + ENDDO +C +C--LOOP THROUGH ALL CELLS + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + CTOTAL=0. +C +C--SKIP IF CELL IS INACTIVE + IF(ICBUND(J,I,K).EQ.0) CYCLE +C +C--CALCULATE FACE VALUES IN Z DIRECTION +C ==================================== + IF(NLAY.LT.2) GOTO 410 +C +C--TOP FACE... +C--THE TOP FACE HAS BEEN COMPUTED AND SAVED AT PREVIOUS BOTTOM FACE + IF(K.GT.1.AND.ICBUND(J,I,K-1).NE.0) + & CTOTAL=CTOTAL-CTOP(J,I,K-1)*QZ(J,I,K-1)/DH(J,I,K) +C +C--BOTTOM FACE... + IF(K.LT.NLAY.AND.ICBUND(J,I,K+1).NE.0) THEN +C +C--CALCULATE THE FACE VALUE AT (J,I,K+1/2) + CTMP=CFACE(NCOL,NROW,NLAY,J,I,K+1,IZ,DELR,DELC,DH, + & COLD,PRSITY,DTRANS,QX,QY,QZ,ICBUND) + CTOTAL=CTOTAL+CTMP*QZ(J,I,K)/DH(J,I,K) +C +C--SAVE THE FACE VALUE FOR NEXT CELL + CTOP(J,I,K)=CTMP + ENDIF +C +C--CALCULATE FACE VALUES IN Y DIRECTION +C ==================================== +C + 410 IF(NROW.LT.2) GOTO 420 +C +C--BACK FACE... +C--THE BACK FACE HAS BEEN COMPUTED AND SAVED AT PREVIOUS FRONT FACE + IF(I.GT.1.AND.ICBUND(J,I-1,K).NE.0) THEN + WW=DH(J,I-1,K)/DH(J,I,K) + CTOTAL=CTOTAL-CBCK(J,I-1,K)*WW*QY(J,I-1,K)/DELC(I) + ENDIF +C +C--FRONT FACE... + IF(I.LT.NROW.AND.ICBUND(J,I+1,K).NE.0) THEN +C +C--CALCULATE THE FACE VALUE AT (J,I+1/2,K) + CTMP=CFACE(NCOL,NROW,NLAY,J,I+1,K,IY,DELR,DELC,DH, + & COLD,PRSITY,DTRANS,QX,QY,QZ,ICBUND) + CTOTAL=CTOTAL+CTMP*QY(J,I,K)/DELC(I) +C +C--SAVE THE FACE VALUE FOR NEXT CELL + CBCK(J,I,K)=CTMP + ENDIF +C +C--CALCULATE IN THE X DIRECTION +C ============================ +C + 420 IF(NCOL.LT.2) GOTO 430 +C +C--LEFT FACE... +C--THE LEFT FACE HAS BEEN COMPUTED AND SAVED AT PREVIOUS RIGHT FACE + IF(J.GT.1.AND.ICBUND(J-1,I,K).NE.0) THEN + WW=DH(J-1,I,K)/DH(J,I,K) + CTOTAL=CTOTAL-CRGT*WW*QX(J-1,I,K)/DELR(J) + ENDIF +C +C--RIGHT FACE... + IF(J.LT.NCOL.AND.ICBUND(J+1,I,K).NE.0) THEN +C +C--CALCULATE FACE VALUE AT (J+1/2,I,K) + CRGT=CFACE(NCOL,NROW,NLAY,J+1,I,K,IX,DELR,DELC,DH, + & COLD,PRSITY,DTRANS,QX,QY,QZ,ICBUND) + CTOTAL=CTOTAL+CRGT*QX(J,I,K)/DELR(J) + ENDIF +C +C--TOTAL CHANGES + 430 CTOTAL=CTOTAL*DTRANS/(RETA(J,I,K)*PRSITY(J,I,K)) +C +C--UPDATE CONCENTRATION AT ACTIVE CELL AND +C--SAVE MASS INTO OR OUT OF CONSTANT-CONCENTRATION CELL + IF(ICBUND(J,I,K).GT.0) THEN + CNEW(J,I,K)=COLD(J,I,K)-CTOTAL + ELSEIF(ICBUND(J,I,K).LT.0) THEN + IF(CTOTAL.GT.0) THEN + RMASIO(6,1)=RMASIO(6,1)+CTOTAL*RETA(J,I,K)* + & DELR(J)*DELC(I)*DH(J,I,K)*PRSITY(J,I,K) + ELSE + RMASIO(6,2)=RMASIO(6,2)+CTOTAL*RETA(J,I,K)* + & DELR(J)*DELC(I)*DH(J,I,K)*PRSITY(J,I,K) + ENDIF + ENDIF +C + ENDDO + ENDDO + ENDDO +C +C--NORMAL RETURN + RETURN + END +C +C + FUNCTION CFACE(NCOL,NROW,NLAY,J,I,K,LL,DELR,DELC,DH,C,PRSITY, + & DTRANS,QX,QY,QZ,ICBUND) +C********************************************************************** +C THIS FUNCTION COMPUTES THE (LEFT,BACK,OR TOP) FACE VALUE DEPENDING +C ON THE VALUE OF LL USING THE ULTIMATE SCHEME. +C LL = 1: LEFT FACE +C 2: BACK FACE +C 3: TOP FACE +C********************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER ICBUND,NCOL,NROW,NLAY,J,I,K,IP1,IM1,IM2,JP1,JM1,JM2, + & KP1,KM1,KM2,LL,IX,IY,IZ + REAL C,QX,QY,QZ,DELR,DELC,DH,DTRANS,DX,DY,DZ,DXP1,DXM1,DYP1, + & DYM1,DZP1,DZM1,CP,CW,GRADX,GRADY,GRADZ,GRADXP,GRADXM, + & GRADXMM,GRADXPM,GRADYM,GRADYP,GRADYPM,GRADYMM,GRADZM, + & GRADX2,GRADY2,GRADZ2,CURV,TWIST, + & GRADZP,GRADZPM,GRADZMM,CURVX,CURVY,CURVZ,TWISTX,TWISTY, + & TWISTZ,VX,VY,VZ,S2,S3,S4,UL,SL,ULIMIT,WW,CRNT,SETA, + & PRSITY,EPSILON,TINY,CFACE,U + DIMENSION C(NCOL,NROW,NLAY),ICBUND(NCOL,NROW,NLAY), + & QX(NCOL,NROW,NLAY),QY(NCOL,NROW,NLAY), + & QZ(NCOL,NROW,NLAY),DELR(NCOL),DELC(NROW), + & DH(NCOL,NROW,NLAY),PRSITY(NCOL,NROW,NLAY) + PARAMETER (IX=1,IY=2,IZ=3,EPSILON=0.5E-6,TINY=1.E-30) +C +C--INITIALIZE + IP1=MIN(NROW,I+1) + IM1=MAX(1,I-1) + IM2=MAX(1,I-2) + JP1=MIN(NCOL,J+1) + JM1=MAX(1,J-1) + JM2=MAX(1,J-2) + KP1=MIN(NLAY,K+1) + KM1=MAX(1,K-1) + KM2=MAX(1,K-2) + GRADX=0. + GRADXP=0. + GRADXM=0. + GRADXPM=0. + GRADXMM=0. + GRADY=0. + GRADYP=0. + GRADYM=0. + GRADYPM=0. + GRADYMM=0. + GRADZ=0. + GRADZP=0. + GRADZM=0. + GRADZPM=0. + GRADZMM=0. + GRADX2=0. + GRADY2=0. + GRADZ2=0. + CURVX=0. + CURVY=0. + CURVZ=0. + TWISTX=0. + TWISTY=0. + TWISTZ=0. + VX=0. + VY=0. + VZ=0. +C +C--COMPUTE THE DISTANCES BETWEEN CELLS + DX = 0.5*(DELR(JM1)+DELR(J)) + DXM1=0.5*(DELR(JM2)+DELR(JM1)) + DXP1=0.5*(DELR(JP1)+DELR(J)) + DY = 0.5*(DELC(IM1)+DELC(I)) + DYM1=0.5*(DELC(IM2)+DELC(IM1)) + DYP1=0.5*(DELC(IP1)+DELC(I)) + DZ = 0.5*(DH(J,I,KM1)+DH(J,I,K)) + DZM1=0.5*(DH(J,I,KM2)+DH(J,I,KM1)) + DZP1=0.5*(DH(J,I,KP1)+DH(J,I,K)) +C +C--SIX GRADIENTS AROUND CELL (J, I, K) + CP=C(J,I,K) + IF(ICBUND(JM1,I,K).NE.0) GRADX = (CP-C(JM1,I,K))/DX + IF(ICBUND(JP1,I,K).NE.0) GRADXP= (C(JP1,I,K)-CP)/DXP1 + IF(ICBUND(J,IM1,K).NE.0) GRADY = (CP-C(J,IM1,K))/DY + IF(ICBUND(J,IP1,K).NE.0) GRADYP= (C(J,IP1,K)-CP)/DYP1 + IF(ICBUND(J,I,KM1).NE.0) GRADZ = (CP-C(J,I,KM1))/DZ + IF(ICBUND(J,I,KP1).NE.0) GRADZP= (C(J,I,KP1)-CP)/DZP1 +C +C--COMPUTE FACE VALUE AT (J-1/2, I, K) + IF (LL.EQ.IX) THEN +C +C--COMPUTE THE VELOCITIES AT FACE (J-1/2, I, K) + WW=DELR(J)/(DELR(JM1)+DELR(J)) + VX=QX(JM1,I,K) +C + IF(NROW.GT.1) + & VY=0.5*(QY(JM1,IM1,K)+QY(JM1,I,K))*WW + & +0.5*(QY(J,IM1,K)+QY(J,I,K))*(1.-WW) + IF(NLAY.GT.1) + & VZ=0.5*(QZ(JM1,I,KM1)+QZ(JM1,I,K))*WW + & +0.5*(QZ(J,I,KM1)+QZ(J,I,K))*(1.-WW) + SETA=WW*PRSITY(JM1,I,K)+(1.-WW)*PRSITY(J,I,K) + VX=VX*DTRANS/SETA + VY=VY*DTRANS/SETA + VZ=VZ*DTRANS/SETA + CW=C(JM1,I,K) +C +C--SET CONC. TO UPSTREAM NODE AND RETURN IF NEXT TO INACTIVE CELL + IF(VX.GT.0.0.AND.ICBUND(JM2,I,K).EQ.0) THEN + CFACE=CW + GOTO 999 + ENDIF + IF(VX.LT.0.0.AND.ICBUND(JP1,I,K).EQ.0) THEN + CFACE=CP + GOTO 999 + ENDIF +C +C--FIVE ADDITIONAL GRADIENTS AROUND CELL (JM1, I, K) + IF(ICBUND(JM2,I,K).NE.0) GRADXM = (CW-C(JM2,I,K)) /DXM1 + IF(ICBUND(JM1,IP1,K).NE.0) GRADYPM = (C(JM1,IP1,K)-CW)/DYP1 + IF(ICBUND(JM1,IM1,K).NE.0) GRADYMM = (CW-C(JM1,IM1,K))/DY + IF(ICBUND(JM1,I,KP1).NE.0) GRADZPM = (C(JM1,I,KP1)-CW)/DZP1 + IF(ICBUND(JM1,I,KM1).NE.0) GRADZMM = (CW-C(JM1,I,KM1))/DZ +C +C--CURVTURES + IF (VX.GT.0) THEN + CURVX=(GRADX - GRADXM) /DELR(JM1) + CURVY=(GRADYPM - GRADYMM) /DELC(I) + CURVZ=(GRADZPM - GRADZMM) /DH(J,I,K) + ELSE + CURVX=(GRADXP - GRADX)/DELR(J) + CURVY=(GRADYP - GRADY) /DELC(I) + CURVZ=(GRADZP - GRADZ) /DH(J,I,K) + ENDIF +C +C--TWIST NORMAL TO X DIRECTION + IF(ICBUND(J,I,KM1).NE.0 .AND.ICBUND(JM1,I,KM1).NE.0) THEN + GRADY2=(C(J,I,KM1)-C(JM1,I,KM1))/DY + TWISTX = (GRADY-GRADY2)/DZ + ENDIF +C +C--TWIST AND GRADIENT IN Y DIRECTION + IF (VY.GT.0) THEN + TWISTY=(GRADY-GRADYMM)/DX + IF(VX.GT.0) GRADY = GRADYMM + ELSE + TWISTY=(GRADYP-GRADYPM)/DX + IF(VX.GT.0) THEN + GRADY = GRADYPM + ELSE + GRADY = GRADYP + ENDIF + ENDIF +C +C--TWIST AND GRADIENT IN Z DIRECTION + IF (VZ.GT.0) THEN + TWISTZ=(GRADZ-GRADZMM)/DX + IF(VX.GT.0) GRADZ = GRADZMM + ELSE + TWISTZ=(GRADZP-GRADZPM)/DX + IF(VX.GT.0) THEN + GRADZ=GRADZPM + ELSE + GRADZ=GRADZP + ENDIF + ENDIF +C +C--FACE VALUE BEFORE APPLYING UNIVERSAL LIMITER + CURV= - (DX*DX-VX**2)*CURVX/6. + & + (VY*VY/6.-DY*VY/4.)*CURVY + & + (VZ*VZ/6.-DZ*VZ/4.)*CURVZ + TWIST= + (VX*VY/3.-DX*VY/4.)*TWISTY + & + (VX*VZ/3.-DX*VZ/4.)*TWISTZ + & + (VY*VZ/3.)*TWISTX + CFACE= WW*CW+(1.-WW)*CP + & - 0.5*(VX*GRADX+VY*GRADY+VZ*GRADZ) + & + CURV + TWIST +C +C--ASSIGN VALUES FOR COMPUTING UNIVERSAL LIMITER + CRNT = VX/DX + IF(VX.GT.0) THEN + S4=CP + S3=CW + S2=C(JM2,I,K) + ELSE + S2=C(JP1,I,K) + S3=CP + S4=CW + ENDIF +C +C--COMPUTE FACE VALUE AT (J, I-1/2, K) + ELSE IF (LL.EQ.IY) THEN +C +C--CALCULATE VELOCITIES AT INTERFACE (J, I-1/2, K) + WW=DELC(I)/(DELC(IM1)+DELC(I)) + VY=QY(J,IM1,K) +C + IF(NCOL.GT.1) + & VX=0.5*(QX(J,IM1,K)+QX(JM1,IM1,K))*WW + & +0.5*(QX(J,I,K)+QX(JM1,I,K))*(1.-WW) + IF(NLAY.GT.1) + & VZ=0.5*(QZ(J,IM1,K)+QZ(J,IM1,KM1))*WW + & +0.5*(QZ(J,I,K)+QZ(J,I,KM1))*(1.-WW) + + SETA=WW*PRSITY(J,IM1,K)+(1.-WW)*PRSITY(J,I,K) + VX=VX*DTRANS/SETA + VY=VY*DTRANS/SETA + VZ=VZ*DTRANS/SETA + CW=C(J,IM1,K) +C +C--SET CONC. TO UPSTREAM NODE AND RETURN IF NEXT TO INACTIVE CELL + IF(VY.GT.0.0.AND.ICBUND(J,IM2,K).EQ.0) THEN + CFACE=CW + GOTO 999 + ENDIF + IF(VY.LT.0.0.AND.ICBUND(J,IP1,K).EQ.0) THEN + CFACE=CP + GOTO 999 + ENDIF +C +C--FIVE ADDITIONAL GRADIENTS AROUND CELL (J, I-1, K) + IF(ICBUND(J,IM2,K).NE.0) GRADYM = (CW-C(J,IM2,K)) /DYM1 + IF(ICBUND(JP1,IM1,K).NE.0) GRADXPM = (C(JP1,IM1,K)-CW)/DXP1 + IF(ICBUND(JM1,IM1,K).NE.0) GRADXMM = (CW-C(JM1,IM1,K))/DX + IF(ICBUND(J,IM1,KP1).NE.0) GRADZPM = (C(J,IM1,KP1)-CW)/DZP1 + IF(ICBUND(J,IM1,KM1).NE.0) GRADZMM = (CW-C(J,IM1,KM1))/DZ +C +C--CURVTURES + IF (VY.GT.0) THEN + CURVY=(GRADY - GRADYM) /DELC(IM1) + CURVX=(GRADXPM - GRADXMM) /DELR(J) + CURVZ=(GRADZPM - GRADZMM) /DH(J,I,K) + ELSE + CURVY=(GRADYP - GRADY)/DELC(I) + CURVX=(GRADXP - GRADX)/DELR(J) + CURVZ=(GRADZP - GRADZ)/DH(J,I,K) + ENDIF +C +C--TWIST AND GRADIENT IN X DIRECTION + IF (VX.GT.0) THEN + TWISTX=(GRADX-GRADXMM)/DY + IF(VY.GT.0) GRADX = GRADXMM + ELSE + TWISTX=(GRADXP-GRADXPM)/DY + IF(VY.GT.0) THEN + GRADX = GRADXPM + ELSE + GRADX = GRADXP + ENDIF + ENDIF +C +C--TWIST NORMAL TO Y DIRECTION + IF(ICBUND(JM1,I,K).NE.0 .AND.ICBUND(JM1,I,KM1).NE.0) THEN + GRADZ2=(C(JM1,I,K)-C(JM1,I,KM1))/DZ + TWISTY = (GRADZ-GRADZ2)/DX + ENDIF +C +C--TWIST AND GRADIENT IN Z DIRECTION + IF (VZ.GT.0) THEN + TWISTZ=(GRADZ-GRADZMM)/DY + IF(VY.GT.0) GRADZ = GRADZMM + ELSE + TWISTZ=(GRADZP-GRADZPM)/DY + IF(VY.GT.0) THEN + GRADZ = GRADZPM + ELSE + GRADZ = GRADZP + ENDIF + ENDIF +C +C--FACE VALUE BEFORE APPLYING UNIVERSAL LIMITER + CURV= - (DY*DY-VY**2)*CURVY/6. + & + (VX*VX/6.-DX*VX/4.)*CURVX + & + (VZ*VZ/6.-DZ*VZ/4.)*CURVZ + TWIST= + (VX*VY/3.-DY*VX/4.)*TWISTX + & + (VY*VZ/3.-DY*VZ/4.)*TWISTZ + & + (VX*VZ/3.)*TWISTY + CFACE = WW*CW+(1.-WW)*CP + & - 0.5*(VX*GRADX+VY*GRADY+VZ*GRADZ) + & + CURV + TWIST +C +C--ASSIGN VALUES FOR COMPUTING UNIVERSAL LIMITER + CRNT = VY/DY + IF(VY.GT.0) THEN + S4=CP + S3=CW + S2=C(J,IM2,K) + ELSE + S2=C(J,IP1,K) + S3=CP + S4=CW + ENDIF +C +C--COMPUTE FACE VALUE AT (J, I, K-1/2) + ELSE +C +C--CALCULATE VELOCITIES AT INTERFACE (J,I,K-1/2) + WW=DH(J,I,K)/(DH(J,I,KM1)+DH(J,I,K)) + VZ=QZ(J,I,KM1) +C + IF(NCOL.GT.1) + & VX=0.5*(QX(JM1,I,KM1)+QX(J,I,KM1))*WW + & +0.5*(QX(JM1,I,K)+QX(J,I,K))*(1.-WW) + IF(NROW.GT.1) + & VY=0.5*(QY(J,IM1,KM1)+QY(J,I,KM1))*WW + & +0.5*(QY(J,IM1,K)+QY(J,I,K))*(1.-WW) + SETA=WW*PRSITY(J,I,KM1)+(1.-WW)*PRSITY(J,I,K) + VX=VX*DTRANS/SETA + VY=VY*DTRANS/SETA + VZ=VZ*DTRANS/SETA + CW=C(J,I,KM1) +C +C--SET CONC. TO UPSTREAM NODE AND RETURN IF NEXT TO INACTIVE CELL + IF(VZ.GT.0.0.AND.ICBUND(J,I,KM2).EQ.0) THEN + CFACE=CW + GOTO 999 + ENDIF + IF(VZ.LT.0.0.AND.ICBUND(J,I,KP1).EQ.0) THEN + CFACE=CP + GOTO 999 + ENDIF +C +C--FIVE ADDITIONAL GRADIENTS AT CELL (J, I, KM1) + IF(ICBUND(J,I,KM2).NE.0) GRADZM =(CW-C(J,I,KM2)) /DZM1 + IF(ICBUND(J,IP1,KM1).NE.0) GRADYPM=(C(J,IP1,KM1)-CW)/DYP1 + IF(ICBUND(J,IM1,KM1).NE.0) GRADYMM=(CW-C(J,IM1,KM1))/DY + IF(ICBUND(JP1,I,KM1).NE.0) GRADXPM=(C(JP1,I,KM1)-CW)/DXP1 + IF(ICBUND(JM1,I,KM1).NE.0) GRADXMM=(CW-C(JM1,I,KM1))/DX +C +C--CURVTURES + IF (VZ.GT.0) THEN + CURVZ=(GRADZ - GRADZM) /DH(J,I,KM1) + CURVY=(GRADYPM - GRADYMM) /DELC(I) + CURVX=(GRADXPM - GRADXMM) /DELR(J) + ELSE + CURVZ=(GRADZP - GRADZ)/DH(J,I,K) + CURVY=(GRADYP - GRADY) /DELC(I) + CURVX=(GRADXP - GRADX) /DELR(J) + ENDIF +C +C--TWIST AND GRADIENT IN Y DIRECTION + IF (VY.GT.0) THEN + TWISTY=(GRADY-GRADYMM)/DZ + IF(VZ.GT.0) GRADY = GRADYMM + ELSE + TWISTY=(GRADYP-GRADYPM)/DZ + IF(VZ.GT.0) THEN + GRADY = GRADYPM + ELSE + GRADY = GRADYP + ENDIF + ENDIF +C +C--TWIST AND GRADIENT IN X DIRECTION + IF (VX.GT.0) THEN + TWISTX=(GRADX-GRADXMM)/DZ + IF(VZ.GT.0) GRADX = GRADXMM + ELSE + TWISTX=(GRADXP-GRADXPM)/DZ + IF(VZ.GT.0) THEN + GRADX = GRADXPM + ELSE + GRADX = GRADXP + ENDIF + ENDIF +C +C--TWIST NORMAL TO Z DIRECTION + IF(ICBUND(J,IM1,K).NE.0 .AND.ICBUND(JM1,IM1,K).NE.0) THEN + GRADX2=(C(J,IM1,K)-C(JM1,IM1,K))/DX + TWISTY = (GRADX-GRADX2)/DY + ENDIF +C +C--FACE VALUE BEFORE APPLYING UNIVERSAL LIMITER + CURV= - (DZ*DZ-VZ**2)*CURVZ/6. + & + (VY*VY/6.-DY*VY/4.)*CURVY + & + (VX*VX/6.-DX*VX/4.)*CURVX + TWIST= + (VZ*VY/3.-DZ*VY/4.)*TWISTY + & + (VZ*VX/3.-DZ*VX/4.)*TWISTX + & + (VX*VY/3.)*TWISTZ + CFACE = WW*CW+(1.-WW)*CP + & - 0.5*(VX*GRADX+VY*GRADY+VZ*GRADZ) + & + CURV + TWIST +C +C--ASSIGN VALUES FOR COMPUTING UNIVERSAL LIMITER + CRNT = VZ/DZ + IF (VZ .GT. 0) THEN + S4=CP + S3=CW + S2=C(J,I,KM2) + ELSE + S2=C(J,I,KP1) + S3=CP + S4=CW + ENDIF + ENDIF +C +C--APPLY UNIVERSAL LIMITER + U=S4 + CRNT=ABS(CRNT) + IF(S2.GE.S3.AND.S3.GE.S4) THEN + IF(CRNT.GT.TINY) THEN + U=MAX(S4, S2+(S3-S2)/CRNT) + ENDIF + IF(CFACE.GT.S3) CFACE=S3 + IF(CFACE.LT.U) CFACE=U + ELSEIF(S2.LE.S3.AND.S3.LE.S4) THEN + IF(CRNT.GT.TINY) THEN + U=MIN(S4, S2+(S3-S2)/CRNT) + ENDIF + IF(CFACE.LT.S3) CFACE=S3 + IF(CFACE.GT.U) CFACE=U + ELSE + CFACE=S3 + ENDIF +C +C--NORMAL RETURN + 999 RETURN + END \ No newline at end of file diff --git a/true-binary/mt_btn5.for b/true-binary/mt_btn5.for index e69de29..246fca3 100644 --- a/true-binary/mt_btn5.for +++ b/true-binary/mt_btn5.for @@ -0,0 +1,1585 @@ +C + SUBROUTINE BTN5OPEN(INUNIT,IOUT,INBTN,INADV,INDSP,INSSM,INRCT, + & INGCG,INTOB,INHSS,INFTL,FPRT,MXTRNOP,iUnitTRNOP,NameTRNOP) +C ******************************************************************* +C OPEN FILES, USING THE METHOD OF MODFLOW-96, 2000 & 2005 +c NOTE: THE STYLE OF UNFORMATTED FILES IS SPECIFIED IN THE +C INCLUDE FILE 'filespec.inc' +C ******************************************************************* +C Last modified: 02-20-2010 +C + INTEGER INUNIT,IOUT,INBTN,INADV,INDSP,INSSM,INRCT,INGCG, + & INTOB,INHSS,INFTL,ILIST,IBTN,IFTL,IFLEN,IFTLFMT, + & MXTRNOP,iUnitTRNOP + LOGICAL LOP + CHARACTER*200 LINE,FNAME + CHARACTER*20 FMTARG,ACCARG,FILACT + CHARACTER*4 NameTRNOP(MXTRNOP) + CHARACTER FILSTAT*7,FPRT*1 + DIMENSION iUnitTRNOP(MXTRNOP) + COMMON /FTL/IFTLFMT +C + INCLUDE 'filespec.inc' +C +C--INITIALIZE. + ILIST=0 + IBTN=0 + IFTL=0 + DO I=1,MXTRNOP + iUnitTRNOP(I)=0 + ENDDO +C +C--READ A LINE; IGNORE BLANK LINES AND PRINT COMMENT LINES. + 10 READ(INUNIT,'(A)',END=1000) LINE + IF(LINE.EQ.' ') GOTO 10 + IF(LINE(1:1).EQ.'#') THEN + IF(ILIST.NE.0) WRITE(IOUT,'(A)') LINE + GOTO 10 + ENDIF +C +C--DECODE THE FILE TYPE AND UNIT NUMBER. + LLOC=1 + CALL URWORD(LINE,LLOC,ITYP1,ITYP2,1,N,R,IOUT,INUNIT) + CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,IU,R,IOUT,INUNIT) +C +C--DECODE THE FILE NAME. + CALL URWORD(LINE,LLOC,INAM1,INAM2,0,N,R,IOUT,INUNIT) + IFLEN=INAM2-INAM1+1 + FNAME(1:IFLEN)=LINE(INAM1:INAM2) +C +C--CHECK FOR A VALID FILE TYPE. + FMTARG='FORMATTED' + ACCARG='SEQUENTIAL' + FILSTAT='UNKNOWN' + FILACT=ACTION(2) +C +C--FIRST ENTRY MUST BE FILE-TYPE "LIST". + IF(ILIST.EQ.0) THEN + IF(LINE(ITYP1:ITYP2).NE.'LIST') THEN + WRITE(*,11) + 11 FORMAT(1X,'FIRST ENTRY IN NAME FILE MUST BE "LIST".') + CALL USTOP(' ') + ENDIF + IF(IU.EQ.0) THEN + IU=IOUT + ELSEIF(IU.GT.0) THEN + IOUT=IU + ENDIF +C +C--CHECK FOR "BTN" FILE TYPE. + ELSEIF(LINE(ITYP1:ITYP2).EQ.'BTN') THEN + IBTN=1 + FILSTAT='OLD ' + FILACT=ACTION(1) + IF(IU.EQ.0) THEN + IU=INBTN + ELSEIF(IU.GT.0) THEN + INBTN=IU + ENDIF +C +C--CHECK FOR "FTL" FILE TYPE. + ELSEIF(LINE(ITYP1:ITYP2).EQ.'FTL') THEN +C +C--DECODE OPTIONAL FORMAT AND OUTPUT KEYWORDS + CALL URWORD(LINE,LLOC,ISTART,ISTOP,1,N,R,IOUT,INUNIT) + CALL URWORD(LINE,LLOC,ISTART2,ISTOP2,1,N,R,IOUT,INUNIT) + IFTL=1 + IFTLFMT=0 + FILSTAT='OLD ' + FILACT=ACTION(1) + FMTARG=FORM + ACCARG=ACCESS + IF(IU.EQ.0) THEN + IU=INFTL + ELSE + INFTL=IU + ENDIF + IF(LINE(ISTART:ISTOP) .EQ.'FREE' .OR. + & LINE(ISTART2:ISTOP2).EQ.'FREE') THEN + IFTLFMT=1 + FMTARG='FORMATTED' + ACCARG='SEQUENTIAL' + ENDIF + IF(LINE(ISTART:ISTOP) .EQ.'PRINT' .OR. + & LINE(ISTART2:ISTOP2).EQ.'PRINT') THEN + FPRT='Y' + ENDIF +C +C--CHECK FOR "UNFORMATTED" FILE TYPE. + ELSEIF(LINE(ITYP1:ITYP2).EQ.'DATA(BINARY)') THEN + FMTARG=FORM + ACCARG=ACCESS +C +C--CHECK FOR "FORMATTED FILE TYPE. + ELSEIF(LINE(ITYP1:ITYP2).EQ.'DATA') THEN + FMTARG='FORMATTED' + ACCARG='SEQUENTIAL' +C +C--CHECK FOR MAJOR OPTIONS. + ELSE + DO I=1,MXTRNOP + IF(LINE(ITYP1:ITYP2).EQ.NameTRNOP(I)) THEN + IF(IU.EQ.0) THEN + if(NameTRNOP(i).EQ.'ADV') THEN + IU=INADV + elseif(NameTRNOP(i).EQ.'DSP') THEN + IU=INDSP + elseif(NameTRNOP(i).EQ.'SSM') THEN + IU=INSSM + elseif(NameTRNOP(i).EQ.'RCT') THEN + IU=INRCT + elseif(NameTRNOP(i).EQ.'GCG') THEN + IU=INGCG + elseif(NameTRNOP(i).EQ.'TOB') THEN + IU=INTOB + elseif(NameTRNOP(i).EQ.'HSS') THEN + IU=INHSS + else + WRITE(*,20) LINE(ITYP1:ITYP2) + 20 FORMAT(1X,'UNDEFINED UNIT # FOR FILE TYPE: ',A) + CALL USTOP(' ') + endif + ENDIF + iUnitTRNOP(I)=IU + FILSTAT='OLD ' + FILACT=ACTION(1) + GO TO 30 + ENDIF + ENDDO + WRITE(*,21) LINE(ITYP1:ITYP2) + 21 FORMAT(1X,'ILLEGAL FILE TYPE IN NAME FILE: ',A) + CALL USTOP(' ') + 30 CONTINUE + ENDIF +C +C--WRITE THE FILE NAME IF THE FILE IS NOT THE +C--LISTING FILE. THEN OPEN THE FILE. + INQUIRE(UNIT=IU,OPENED=LOP) + IF(LOP) CLOSE(UNIT=IU) + IF(ILIST.NE.0) WRITE(IOUT,36) LINE(INAM1:INAM2), + & LINE(ITYP1:ITYP2),IU + 36 FORMAT(1X,/1X,'OPENING ',A,/ + & 1X,'FILE TYPE:',A,' UNIT',I4) + OPEN(UNIT=IU,FILE=FNAME(1:IFLEN),STATUS=FILSTAT, + & FORM=FMTARG,ACCESS=ACCARG,ACTION=FILACT) +C +C--IF THE OPENED FILE IS THE LISTING FILE, WRITE ITS NAME. +C--GO BACK AND READ NEXT RECORD. + IF(ILIST.EQ.0) WRITE(IOUT,37) LINE(INAM1:INAM2),IU + 37 FORMAT(1X,'LISTING FILE: ',A,/25X,'UNIT',I4) + ILIST=1 + GOTO 10 +C +C--END OF NAME FILE. RETURN PROVIDED THAT LISTING FILE, +C--FTL and BTN FILES HAVE BEEN OPENED. + 1000 IF(ILIST.EQ.0) THEN + WRITE(*,1001) + CALL USTOP(' ') + ELSEIF(IFTL.EQ.0) THEN + WRITE(IOUT,1002) + CALL USTOP(' ') + ELSEIF(IBTN.EQ.0) THEN + WRITE(IOUT,1003) + CALL USTOP(' ') + ENDIF + 1001 FORMAT(1X,'NAME FILE IS EMPTY.') + 1002 FORMAT(1X,'Flow-Transport Link FILE HAS NOT BEEN OPENED.') + 1003 FORMAT(1X,'BTN PACKAGE FILE HAS NOT BEEN OPENED.') +c + RETURN + END +C +C + SUBROUTINE BTN5DF(INBTN,IOUT,ISUM,ISUM2,NCOL,NROW,NLAY,NPER, + & NCOMP,MCOMP,MXTRNOP,iUnitTRNOP,NameTRNOP,TUNIT,LUNIT,MUNIT, + & NODES,MXCOMP,iNameFile) +C **************************************************************** +C THIS SUBROUTINE READS PROBLEM DIMENSIONS AND TRANSPORT OPTIONS. +C **************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER INBTN,IOUT,ISUM,ISUM2,NCOL,NROW,NLAY,NPER, + & NCOMP,MCOMP,I,NODES,IERR,MXCOMP,iNameFile, + & MXTRNOP,iUnitTRNOP + CHARACTER HEADNG*80,Line*80, + & TUNIT*4,LUNIT*4,MUNIT*4,NameTRNOP*4 + DIMENSION HEADNG(2), + & NameTRNOP(MXTRNOP),iUnitTRNOP(MXTRNOP) +C +C--READ AND PRINT HEADING + READ(INBTN,'(A80)') (HEADNG(I),I=1,2) + WRITE(IOUT,10) + WRITE(IOUT,15) (HEADNG(I),I=1,2) + WRITE(IOUT,10) + 10 FORMAT(1X,' ----- ') + 15 FORMAT(1X,'| M T | ',A80/1X,'| 3 D | ',A80) +C +C--READ AND PRINT NO. OF LAYERS, ROWS, COLUMNS, AND STRESS PERIODS, +C--COMPONENTS + READ(INBTN,'(6I10)',ERR=25,IOSTAT=IERR) + & NLAY,NROW,NCOL,NPER,NCOMP,MCOMP + IF(NCOMP.LT.1) NCOMP=1 + IF(MCOMP.LT.1) MCOMP=1 + IF(NCOMP.GT.MXCOMP.OR.MCOMP.GT.MXCOMP) THEN + WRITE(*,1005) + CALL USTOP(' ') + ENDIF + 25 IF(IERR.NE.0) THEN + BACKSPACE(INBTN) + READ(INBTN,'(4I10)') NLAY,NROW,NCOL,NPER + NCOMP=1 + MCOMP=1 + ENDIF + WRITE(IOUT,1000) NLAY,NROW,NCOL,NPER,NCOMP,MCOMP + 1000 FORMAT(1X,'THE TRANSPORT MODEL CONSISTS OF ',I5,' LAYER(S)',I5, + & ' ROW(S)',I5,' COLUMN(S)', + & /1X,'NUMBER OF STRESS PERIOD(S) FOR TRANSPORT SIMULATION =',I5, + & /1X,'NUMBER OF ALL COMPONENTS INCLUDED IN SIMULATION =',I5, + & /1X,'NUMBER OF MOBILE COMPONENTS INCLUDED IN SIMULATION =',I5) + 1005 FORMAT(/1X,'ERROR: MAXIMUM NUMBER OF COMPONENTS EXCEEDED!', + & /1X,'INCREASE DIMENSION OF [MXCOMP] IN THE MAIN PROGRAM.') +C +C--READ AND PRINT UNITS FOR TIME, LENGTH AND MASS TO BE USED + READ(INBTN,'(3A4)') TUNIT,LUNIT,MUNIT + WRITE(IOUT,1010) TUNIT,LUNIT,MUNIT + 1010 FORMAT(1X,'UNIT FOR TIME IS ',A4,';',2X,'UNIT FOR LENGTH IS ', + & A4,';',2X,'UNIT FOR MASS IS ',A4) +C +C--IGNORE TRANSPORT OPTIONS INPUT WHICH ARE DEFINED THROUGH NameFile + READ(INBTN,'(A)',ERR=100) Line + 100 WRITE(IOUT,1020) + DO I=1,MXTRNOP + IF(iUnitTRNOP(I).GT.0) + & WRITE(IOUT,1022) NameTRNOP(I),iUnitTRNOP(I) + ENDDO + WRITE(IOUT,1024) + 1020 FORMAT(1X,'OPTIONAL PACKAGES INCLUDED IN CURRENT SIMULATION:') + 1022 FORMAT(1X,' o ',A, ' ON UNIT',I3) + 1024 FORMAT(1X) +C +C--INITIALIZE ARRAY POINTERS FOR ALLOCATING MEMORY + ISUM=1 + ISUM2=1 +C +C--GET TOTAL NUMBER OF MODEL NODES + NODES=NCOL*NROW*NLAY +C +C--NORMAL RETURN + RETURN + END +C +C + SUBROUTINE BTN5AL(INBTN,IOUT,ISUM,ISUM2,NCOL,NROW,NLAY,NCOMP, + & LCLAYC,LCDELR,LCDELC,LCHTOP,LCDZ,LCPR,LCXBC,LCYBC,LCZBC, + & LCQX,LCQY,LCQZ,LCQSTO,LCDH,LCIB,LCCOLD,LCCNEW,LCCWGT, + & LCCADV,LCRETA,LCSR,LCBUFF,ISOTHM,LCRHOB,LCPRSITY2,LCRETA2) +C ********************************************************************** +C THIS SUBROUTINE ALLOCATES SPACE FOR ARRAYS NEEDED BY THE ENTIRE MODEL. +C ********************************************************************** +C last modified: 02-20-2010 +C + IMPLICIT NONE + INTEGER INBTN,IOUT,ISUM,ISUM2,NCOL,NROW,NLAY,NCOMP,LCSR, + & LCLAYC,LCDELR,LCDELC,LCHTOP,LCDZ,LCPR,LCXBC,LCYBC, + & LCZBC,LCQX,LCQY,LCQZ,LCDH,LCIB,LCCOLD,LCCNEW,LCCWGT,LCCADV, + & LCRETA,LCBUFF,NODES,ISUMX,ISUMIX,ISOLD,ISOLD2,LCQSTO, + & ISOTHM,LCRHOB,LCPRSITY2,LCRETA2 +C +C--PRINT PACKAGE NAME AND VERSION NUMBER + WRITE(IOUT,1030) INBTN + 1030 FORMAT(1X,'BTN5 -- BASIC TRANSPORT PACKAGE,', + & ' VERSION 5, FEBRUARY 2010, INPUT READ FROM UNIT',I3) +C +C--ALLOCATE SPACE FOR ARRAYS + ISOLD=ISUM + ISOLD2=ISUM2 + NODES=NCOL*NROW*NLAY +C +C--INTEGER ARRAYS + LCLAYC=ISUM2 + ISUM2=ISUM2+NLAY + LCIB=ISUM2 + ISUM2=ISUM2+NODES * NCOMP +C +C--REAL ARRAYS + LCDELR=ISUM + ISUM=ISUM+NCOL + LCDELC=ISUM + ISUM=ISUM+NROW + LCHTOP=ISUM + ISUM=ISUM+NCOL*NROW + LCDZ=ISUM + ISUM=ISUM+NODES + LCPR=ISUM + ISUM=ISUM+NODES + LCXBC=ISUM + ISUM=ISUM+NCOL + LCYBC=ISUM + ISUM=ISUM+NROW + LCZBC=ISUM + ISUM=ISUM+NODES + LCQX=ISUM + ISUM=ISUM+NODES + LCQY=ISUM + ISUM=ISUM+NODES + LCQZ=ISUM + ISUM=ISUM+NODES + LCQSTO=ISUM + ISUM=ISUM+NODES + LCDH=ISUM + ISUM=ISUM+NODES + LCCOLD=ISUM + ISUM=ISUM+NODES * NCOMP + LCCNEW=ISUM + ISUM=ISUM+NODES * NCOMP + LCCWGT=ISUM + ISUM=ISUM+NODES * NCOMP + LCCADV=ISUM + ISUM=ISUM+NODES * NCOMP + LCRETA=ISUM + ISUM=ISUM+NODES * NCOMP + LCSR=ISUM + ISUM=ISUM+NODES * NCOMP + LCBUFF=ISUM + ISUM=ISUM+NODES +C +C--INITIALIZE VARIABLES WHOSE VALUES DEPEND ON OTHER PACKAGES + ISOTHM=0 + LCRHOB=0 + LCPRSITY2=0 + LCRETA2=0 +C +C--CHECK HOW MANY ELEMENTS OF THE X AND IX ARRAYS ARE USED + ISUMX=ISUM-ISOLD + ISUMIX=ISUM2-ISOLD2 + WRITE(IOUT,1090) ISUMX,ISUMIX + 1090 FORMAT(1X,I10,' ELEMENTS OF THE X ARRAY USED BY THE BTN PACKAGE' + & /1X,I10,' ELEMENTS OF THE IX ARRAY USED BY THE BTN PACKAGE'/) +C +C--NORMAL RETURN + RETURN + END +C +C + SUBROUTINE BTN5RP(IN,IOUT,IUCN,IUCN2,IOBS,IMAS,ICNF,ICBM,NCOL, + & NROW,NLAY,NCOMP,ISOTHM,LAYCON,DELR,DELC,HTOP,DZ,PRSITY,ICBUND, + & COLD,CNEW,CADV,CINACT,THKMIN,XBC,YBC,ZBC,RETA,RFMIN,BUFF, + & MXPRS,NPRS,TIMPRS,MXOBS,NOBS,NPROBS,LOCOBS,TUNIT,LUNIT,MUNIT) +C ********************************************************************** +C THIS SUBROUTINE READS AND PREPARES INPUT DATA RELEVANT TO THE ENTIRE +C SIMULATION. +C*********************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER IN,IOUT,IUCN,IOBS,IMAS,ICNF,ICBM,NCOL,NROW,NLAY,LAYCON, + & NCOMP,ICBUND,MXPRS,NPRS,MXOBS,NOBS,LOCOBS,IFMTCN,IFMTNP, + & IFMTRF,IFMTDP,N,J,I,K,IP1,IERR,NPROBS,NPRMAS,INDEX, + & IUCN2,ISOTHM + REAL DELR,DELC,HORIGN,HTOP,DZ,PRSITY,CNEW,COLD,CINACT,TIMPRS, + & XBC,YBC,ZBC,ZZ,XMAX,YMAX,ZMAX,RETA,RFMIN,BUFF,TEMP,CADV, + & THKMIN,CDRY + LOGICAL UNIFOR,UNIDX,UNIDY,UNIDZ,SAVUCN,SAVCBM,CHKMAS + CHARACTER ANAME*24,FLNAME*50,FINDEX*30,TUNIT*4,LUNIT*4,MUNIT*4 + DIMENSION LAYCON(NLAY),ICBUND(NCOL,NROW,NLAY,NCOMP),DELR(NCOL), + & DELC(NROW),DZ(NCOL,NROW,NLAY),PRSITY(NCOL,NROW,NLAY), + & HTOP(NCOL,NROW),XBC(NCOL),YBC(NROW),ZBC(NCOL,NROW,NLAY), + & CNEW(NCOL,NROW,NLAY,NCOMP),COLD(NCOL,NROW,NLAY,NCOMP), + & RETA(NCOL,NROW,NLAY,NCOMP),BUFF(NCOL,NROW,NLAY), + & CADV(NCOL,NROW,NLAY,NCOMP),TIMPRS(MXPRS),LOCOBS(3,MXOBS) + COMMON /PD/HORIGN,XMAX,YMAX,ZMAX,UNIDX,UNIDY,UNIDZ + COMMON /OC/IFMTCN,IFMTNP,IFMTRF,IFMTDP,SAVUCN,SAVCBM,CHKMAS,NPRMAS +C +C--READ INPUT DATA +C =============== +C +C--READ AND ECHO LAYER TYPE CODES + READ(IN,'(40I2)') (LAYCON(K),K=1,NLAY) + WRITE(IOUT,1000) + 1000 FORMAT(1X,'LAYER NUMBER AQUIFER TYPE', + & /1X,'------------ ------------') + DO K=1,NLAY + WRITE(IOUT,1010) K,LAYCON(K) + ENDDO + 1010 FORMAT(1X,4X,I3,10X,I3) +C +C--CALL RARRAY TO READ IN CELL WIDTH ALONG ROWS + ANAME='WIDTH ALONG ROWS (DELR)' + CALL RARRAY(DELR(1),ANAME,1,NCOL,0,IN,IOUT) +C +C--CHECK WHETHER ELEMENTS OF DELR ARE UNIFROM + UNIDX=UNIFOR(DELR(1),NCOL,1,1) +C +C--CALL RARRAY TO READ IN CELL WIDTH ALONG COLUMNS + ANAME='WIDTH ALONG COLS (DELC)' + CALL RARRAY(DELC(1),ANAME,1,NROW,0,IN,IOUT) +C +C--CHECK WHETHER ELEMENTS OF DELC ARE UNIFROM + UNIDY=UNIFOR(DELC(1),NROW,1,1) +C +C--CALL RARRAY TO READ IN TOP ELEVATION OF 1ST LAYER + ANAME='TOP ELEV. OF 1ST LAYER' + CALL RARRAY(HTOP,ANAME,NROW,NCOL,0,IN,IOUT) +C +C--CALL RARRAY TO READ IN THICKNESS ONE LAYER AT A TIME + ANAME='CELL THICKNESS (DZ)' + DO K=1,NLAY + CALL RARRAY(DZ(1,1,K),ANAME,NROW,NCOL,K,IN,IOUT) + ENDDO +C +C--CHECK WHETHER VERTICAL DISCRTIZATION IS HORIZONTAL + UNIDZ=UNIFOR(HTOP,NCOL,NROW,1) + & .AND.UNIFOR(DZ,NCOL,NROW,NLAY) +C +C--CALL RARRAY TO READ IN POROSITY ONE LAYER AT A TIME + ANAME='POROSITY' + DO K=1,NLAY + CALL RARRAY(PRSITY(1,1,K),ANAME,NROW,NCOL,K,IN,IOUT) + ENDDO +C +C--CALL IARRAY TO READ IN CONCENTRATION BOUNDARY ARRAY + ANAME='CONCN. BOUNDARY ARRAY' + DO K=1,NLAY + CALL IARRAY(ICBUND(1,1,K,1),ANAME,NROW,NCOL,K,IN,IOUT) + ENDDO +C +C--CALL RARRAY TO READ IN INITIAL CONCENTRATION + ANAME='INITIAL CONC.: COMP. NO.' + DO INDEX=1,NCOMP + WRITE(ANAME(22:24),'(I3.2)') INDEX + DO K=1,NLAY + CALL RARRAY(COLD(1,1,K,INDEX),ANAME,NROW,NCOL,K,IN,IOUT) + ENDDO + ENDDO +C +C--READ AND ECHO CINACT,THKMIN + READ(IN,'(2F10.0)',ERR=50,IOSTAT=IERR) CINACT,THKMIN + IF(THKMIN.LT.0) THKMIN=0. + 50 IF(IERR.NE.0) THEN + BACKSPACE (IN) + READ(IN,'(F10.0)') CINACT + THKMIN=0. + ENDIF + WRITE(IOUT,1020) CINACT,THKMIN + IF(THKMIN.GT.0.05) THEN + WRITE(IOUT,1022) + THKMIN=0.01 + ENDIF + 1020 FORMAT(/1X,'VALUE INDICATING INACTIVE CONCENTRATION CELLS = ', + & G15.7/1X,'MINIMUM SATURATED THICKNESS [THKMIN] ', + & 'ALLOWED =',F8.4,' OF TOTAL CELL THICKNESS') + 1022 FORMAT(1X,'WARNING: [THKMIN] MUST BE < OR = 0.05;', + & /10X,'RESET TO DEFAULT OF 0.01 OR 1% OF TOTAL CELL THICKNESS') +C +C--READ AND ECHO OUTPUT CONTROL OPTIONS + READ(IN,'(4I10,L10)') IFMTCN,IFMTNP,IFMTRF,IFMTDP,SAVUCN + SAVCBM=.FALSE. + WRITE(IOUT,1025) +C + IF(IFMTCN.NE.0) WRITE(IOUT,1030) IFMTCN + IF(IFMTCN.EQ.0) WRITE(IOUT,1032) + 1025 FORMAT(//1X,'OUTPUT CONTROL OPTIONS'/1X,22('-')) + 1030 FORMAT(/1X,'PRINT CELL CONCENTRATION USING FORMAT CODE:',I5) + 1032 FORMAT(/1X,'DO NOT PRINT CELL CONCENTRATION') +C + IF(IFMTNP.NE.0) WRITE(IOUT,1034) IFMTNP + IF(IFMTNP.EQ.0) WRITE(IOUT,1036) + 1034 FORMAT(1X,'PRINT PARTICLE NUMBER IN EACH CELL', + & ' USING FORMAT CODE:',I5) + 1036 FORMAT(1X,'DO NOT PRINT PARTICLE NUMBER IN EACH CELL') +C + IF(IFMTNP.NE.0) WRITE(IOUT,1038) IFMTRF + IF(IFMTNP.EQ.0) WRITE(IOUT,1040) + 1038 FORMAT(1X,'PRINT RETARDATION FACTOR USING FORMAT CODE:',I5) + 1040 FORMAT(1X,'DO NOT PRINT RETARDATION FACTOR') +C + IF(IFMTDP.NE.0) WRITE(IOUT,1042) IFMTDP + IF(IFMTDP.EQ.0) WRITE(IOUT,1044) + 1042 FORMAT(1X,'PRINT DISPERSION COEFFICIENT USING FORMAT CODE:',I5) + 1044 FORMAT(1X,'DO NOT PRINT DISPERSION COEFFICIENT') +C + IF(SAVUCN) THEN + WRITE(IOUT,1046) IUCN+1 + FLNAME='MT3Dnnn.UCN' + DO INDEX=1,NCOMP + WRITE(FLNAME(5:7),'(I3.3)') INDEX + CALL OPENFL(-(IUCN+INDEX),0,FLNAME,1,FINDEX) + ENDDO + IF(ISOTHM.GT.0) THEN + WRITE(IOUT,2046) IUCN2+1 + FLNAME='MT3DnnnS.UCN' + DO INDEX=1,NCOMP + WRITE(FLNAME(5:7),'(I3.3)') INDEX + CALL OPENFL(-(IUCN2+INDEX),0,FLNAME,1,FINDEX) + ENDDO + ENDIF + ELSE + WRITE(IOUT,1047) + ENDIF + 1046 FORMAT(1X,'SAVE DISSOLVED PHASE CONCENTRATIONS ', + & 'IN UNFORMATTED FILES [MT3Dnnn.UCN]'/1X,' FOR EACH SPECIES ', + & 'ON UNITS ',I3,' AND ABOVE') + 2046 FORMAT(1X,'SAVE SORBED/IMMOBILE PHASE CONCENTRATIONS ', + & 'IN UNFORMATTED FILES [MT3DnnnS.UCN]'/1X,' FOR EACH SPECIES ', + & 'ON UNITS ',I3,' AND ABOVE, ', + & 'IF SORPTION/MASS TRANSFER SIMULATED') + 1047 FORMAT(1X,'DO NOT SAVE CONCENTRATIONS IN UNFORMATTED FILES') +C +C--READ NUMBER OF TIMES AT WHICH SIMULATION RESULTS SHOULD BE SAVED +C--IN STANDARD OUTPUT FILE OR RECORDED IN UNFORMATTED FILE + READ(IN,'(I10)') NPRS + IF(NPRS.LT.0) THEN + WRITE(IOUT,1050) -NPRS + ELSE + WRITE(IOUT,1052) NPRS + ENDIF + IF(NPRS.GT.MXPRS) THEN + WRITE(*,1054) MXPRS + CALL USTOP(' ') + ENDIF + IF(NPRS.GT.0) THEN + READ(IN,'(8F10.0)') (TIMPRS(I),I=1,NPRS) +C +C--MAKE SURE ELEMENTS IN ARRAY [TIMPRS] ARE MONOTONICALLY INCREASING + DO I=1,NPRS-1 + DO IP1=I+1,NPRS + IF(TIMPRS(I).GT.TIMPRS(IP1)) THEN + TEMP=TIMPRS(I) + TIMPRS(I)=TIMPRS(IP1) + TIMPRS(IP1)=TEMP + ENDIF + ENDDO + ENDDO + WRITE(IOUT,1055) (TIMPRS(I),I=1,NPRS) + ENDIF + 1050 FORMAT(/1X,'SIMULATION RESULTS ARE SAVED EVERY ',I3, + & ' TRANSPORT STEP(S)') + 1052 FORMAT(/1X,'NUMBER OF TIMES AT WHICH SIMULATION RESULTS', + &' ARE SAVED =',I5) + 1054 FORMAT(/1X,'ERROR: MAXIMUM NUMBER OF TIMES AT WHICH', + & ' SIMULATION RESULTS CAN BE SAVED IS',I5, + & /1X,'INCREASE DIMENSION OF [MXPRS] IN THE MAIN PROGRAM') + 1055 FORMAT(1X,'TOTAL ELAPSED TIMES AT WHICH SIMULATION RESULTS ', + & 'ARE SAVED: ',100(/1X,8G13.5)) +C +C--READ NUMBER OF OBSERVATION POINTS + READ(IN,'(2I10)',ERR=100,IOSTAT=IERR) NOBS,NPROBS + IF(NPROBS.LT.1) NPROBS=1 + 100 IF(IERR.NE.0) THEN + BACKSPACE (IN) + READ(IN,'(I10)') NOBS + NPROBS=1 + ENDIF + WRITE(IOUT,1056) NOBS + IF(NOBS.GT.MXOBS) THEN + WRITE(*,1058) MXOBS + CALL USTOP(' ') + ENDIF + IF(NOBS.GT.0) THEN + WRITE(IOUT,1062) IOBS+1,NPROBS + WRITE(IOUT,1060) + DO N=1,NOBS + READ(IN,'(3I10)') (LOCOBS(I,N),I=1,3) + WRITE(IOUT,'(I4,4X,3(I5,2X))') N,(LOCOBS(I,N),I=1,3) + ENDDO + FLNAME='MT3Dnnn.OBS' + DO INDEX=1,NCOMP + WRITE(FLNAME(5:7),'(I3.3)') INDEX + CALL OPENFL(IOBS+INDEX,0,FLNAME,1,FINDEX) + WRITE(IOBS+INDEX,1063) ((LOCOBS(I,N),I=1,3),N=1,NOBS) + ENDDO + ENDIF + 1056 FORMAT(/1X,'NUMBER OF OBSERVATION POINTS =',I5) + 1058 FORMAT(/1X,'ERROR: MAXIMUM NUMBER OF OBSERVATION POINTS IS',I5, + & /1X,'INCREASE DIMENSION OF [MXOBS] IN THE MAIN PROGRAM') + 1060 FORMAT(1X,'LOCATION OF OBSERVATION POINTS'/1X,30('.') + & /1X,'NUMBER LAYER ROW COLUMN') + 1062 FORMAT(1X,'SAVE CONCENTRATIONS AT OBSERVATION POINTS IN FILES ', + & '[MT3Dnnn.OBS]'/1X,' FOR EACH SPECIES ', + & 'ON UNITS ',I3,' AND ABOVE, EVERY',I3,' TRANSPORT STEPS') + 1063 FORMAT(1X,' STEP TOTAL TIME', + & ' LOCATION OF OBSERVATION POINTS (K,I,J)' + & /1X,17X,16(1X,3I4,1X)/(1X,17X,16(1X,3I4,1X))) +C +C--READ AND ECHO LOGICAL FLAG CHKMAS + READ(IN,'(L10,I10)',ERR=105,IOSTAT=IERR) CHKMAS,NPRMAS + IF(NPRMAS.LT.1) NPRMAS=1 + 105 IF(IERR.NE.0) THEN + BACKSPACE (IN) + READ(IN,'(L10)') CHKMAS + NPRMAS=1 + ENDIF + IF(CHKMAS) THEN + WRITE(IOUT,1064) IMAS+1,NPRMAS + FLNAME='MT3Dnnn.MAS' + DO INDEX=1,NCOMP + WRITE(FLNAME(5:7),'(I3.3)') INDEX + CALL OPENFL(IMAS+INDEX,0,FLNAME,1,FINDEX) + WRITE(IMAS+INDEX,1066) + WRITE(IMAS+INDEX,1068) TUNIT,MUNIT,MUNIT,MUNIT,MUNIT + ENDDO + ELSE + WRITE(IOUT,1065) + ENDIF + 1064 FORMAT(/1X,'SAVE ONE-LINE SUMMARY OF MASS BUDGETS IN FILES ', + & '[MT3Dnnn.MAS]'/1X,' FOR EACH SPECIES ', + & 'ON UNITS ',I3,' AND ABOVE, EVERY',I3,' TRANSPORT STEPS') + 1065 FORMAT(/1X,'DO NOT SAVE ONE-LINE SUMMARY OF MASS BUDGETS') + 1066 FORMAT(1X,' TIME TOTAL IN TOTAL OUT SOURCES', + & ' SINKS NET MASS FROM TOTAL MASS', + & ' DISCREPANCY(%)') + 1068 FORMAT(1X,5(4X,'(',A4,')',4X), + & ' FLUID-STORAGE IN AQUIFER (TOTAL IN-OUT) (ALTERNATIVE)') +C +C--SAVE MODEL GRID CONFIGURATION IN FILE [MT3D.CNF] +C--FOR USE WITH UNFORMATTED CONCENTRATION FILE BY POST-PROCESSOR + IF(SAVUCN) THEN + CDRY=CINACT + FLNAME='MT3D.CNF' + CALL OPENFL(ICNF,0,FLNAME,1,FINDEX) + WRITE(ICNF,*) NLAY,NROW,NCOL + WRITE(ICNF,*) (DELR(J),J=1,NCOL) + WRITE(ICNF,*) (DELC(I),I=1,NROW) + WRITE(ICNF,*) ((HTOP(J,I),J=1,NCOL),I=1,NROW) + WRITE(ICNF,*) (((DZ(J,I,K),J=1,NCOL),I=1,NROW),K=1,NLAY) + WRITE(ICNF,*) CINACT,CDRY + CLOSE(ICNF) + ENDIF +C +C--PROCESS INPUT DATA +C ================== +C +C--ASSIGN SHARED ICBUND ARRAY TO ALL SPECIES + + DO INDEX=2,NCOMP + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + ICBUND(J,I,K,INDEX)=ICBUND(J,I,K,1) + ENDDO + ENDDO + ENDDO + ENDDO +C +C--ASSIGN CINACT TO INACTIVE CELLS AND COPY COLD TO CNEW + DO INDEX=1,NCOMP + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K,INDEX).EQ.0) COLD(J,I,K,INDEX)=CINACT + CNEW(J,I,K,INDEX)=COLD(J,I,K,INDEX) + CADV(J,I,K,INDEX)=COLD(J,I,K,INDEX) + ENDDO + ENDDO + ENDDO + ENDDO +C +C--SET PRSITY=0 IN CELLS WHERE ICBUND=0 +C--AND ENSURE ICBUND=0 IF POROSITY IS ZERO + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K,1).EQ.0) THEN + PRSITY(J,I,K)=0 + ELSEIF(PRSITY(J,I,K).EQ.0) THEN + DO INDEX=1,NCOMP + ICBUND(J,I,K,INDEX)=0 + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO +C +C--CALCULATE COORDINATE ARRAYS XBC, YBC AND ZBC +C--AND MAXIMUN WIDTHS ALONG ROWS, COLUMNS AND LAYERS + HORIGN=HTOP(1,1) + XBC(1)=DELR(1)/2. + YBC(1)=DELC(1)/2. + DO J=2,NCOL + XBC(J)=XBC(J-1)+(DELR(J-1)+DELR(J))/2. + ENDDO + DO I=2,NROW + YBC(I)=YBC(I-1)+(DELC(I-1)+DELC(I))/2. + ENDDO + XMAX=XBC(NCOL)+DELR(NCOL)/2. + YMAX=YBC(NROW)+DELC(NROW)/2. + ZMAX=0 + DO I=1,NROW + DO J=1,NCOL + ZBC(J,I,1)=DZ(J,I,1)/2.+(HORIGN-HTOP(J,I)) + ZZ=DZ(J,I,1) + DO K=2,NLAY + ZBC(J,I,K)=ZBC(J,I,K-1)+(DZ(J,I,K-1)+DZ(J,I,K))/2. + ZZ=ZZ+DZ(J,I,K) + ENDDO + ZMAX=MAX(ZMAX,ZZ) + ENDDO + ENDDO + WRITE(IOUT,1300) XMAX,YMAX,ZMAX + 1300 FORMAT(/1X,'MAXIMUM LENGTH ALONG THE X (J) AXIS =',G15.7, + & /1X,'MAXIMUM LENGTH ALONG THE Y (I) AXIS =',G15.7, + & /1X,'MAXIMUM LENGTH ALONG THE Z (K) AXIS =',G15.7) +C +C--INITIALIZE RETARDATION FACTOR ARRAY AND THE MINUMIN + DO INDEX=1,NCOMP + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + RETA(J,I,K,INDEX)=1. + ENDDO + ENDDO + ENDDO + ENDDO + RFMIN=1. +C +C--RETURN + RETURN + END +C +C + SUBROUTINE BTN5ST(IN,IOUT,NSTP,MXSTP,TSLNGH,DT0,MXSTRN, + & TTSMULT,TTSMAX,TUNIT,iSSTrans) +C ***************************************************************** +C THIS SUBROUTINE GETS TIMING INFORMATION FOR EACH STRESS PERIOD. +C ***************************************************************** +C last modified: 02-20-2010 +C + IMPLICIT NONE + INTEGER IN,IOUT,NSTP,MXSTRN,N,MXSTP, + & iSSTrans,LLOC,inam1,inam2,itmp + REAL TSLNGH,DT0,PERLEN,TSMULT,TTSMULT,TTSMAX,EPSILON,R + CHARACTER TUNIT*4,Line*200 + DIMENSION TSLNGH(MXSTP) + PARAMETER (EPSILON=0.5E-6) +C +C--READ AND PRINT OUT TIMING INFORMATION + READ(IN,'(F10.0,I10,F10.0)') PERLEN,NSTP,TSMULT + WRITE(IOUT,22) PERLEN,NSTP,TSMULT +C +C--Read an optional flag for steady-state transport simulation + backspace (in) + read(in,'(a)') Line + LLOC=31 + CALL URWORD(Line,LLOC,inam1,inam2,1,ITMP,R,IOUT,IN) + if(Line(inam1:inam2).eq.'SSTATE') then + iSSTrans=1 + write(iout,23) + else + iSSTrans=0 + write(iout,24) + endif +C + 22 FORMAT(/1X,'LENGTH OF CURRENT STRESS PERIOD =',G15.7, + & /1X,'NUMBER OF TIME STEPS FOR CURRENT STRESS PERIOD =',I5, + & /1X,'TIME STEP MULTIPLIER USED IN FLOW SOLUTION =',G15.7) + 23 FORMAT(/1X,'***Type of Transport Simulation is STEADY-STATE'/) + 24 FORMAT(/1X,'***Type of Transport Simulation is TRANSIENT'/) +C + IF(NSTP.GT.MXSTP) THEN + WRITE(*,25) + 25 FORMAT(/1X,'ERROR: MAXIMUM NUMBER OF TIME STEPS EXCEEDED!', + & /1X,'INCREASE DIMENSION OF [MXSTP] IN THE MAIN PROGRAM.') + CALL USTOP(' ') + ENDIF +C +C--IF [TSMULT] IS A NUMBER GREATER THAN ZERO, THE LENGTH OF +C--EACH TIME STEP FOR CURRENT STRESS PERIOD IS CALCULATED BY +C--PROGRAM USING THE GEOMETRIC PROGRESSION. +C--IF TSMULT IS A NUMBER LESS THAN OR EQUAL TO ZERO, +C--READ IN SPECIFIED LENGTH OF EACH TIME STEP. + IF(TSMULT.LE.0) THEN + READ(IN,'(8F10.0)') (TSLNGH(N),N=1,NSTP) + WRITE(IOUT,30) (TSLNGH(N),N=1,NSTP) + 30 FORMAT(1X,'SPECIFIED LENGTH OF EACH TIME STEP:',/1X,8G15.7) + GOTO 50 + ELSEIF(ABS(TSMULT-1.).LT.ABS(TSMULT+1.)*EPSILON) THEN + TSLNGH(1)=PERLEN/FLOAT(NSTP) + ELSE + TSLNGH(1)=PERLEN*(1.-TSMULT)/(1.-TSMULT**NSTP) + ENDIF + DO N=2,NSTP + TSLNGH(N)=TSLNGH(N-1)*TSMULT + ENDDO +C + 50 CONTINUE +C +C--READ INITIAL TRANSPORT STEPSIZE AND MAXIMUM NUMBER OF STEPS + TTSMULT=1.0 + TTSMAX=0.0 + READ(IN,'(F10.0,I10,2F10.0)',ERR=100) DT0,MXSTRN,TTSMULT,TTSMAX + GOTO 101 + 100 BACKSPACE(IN) + READ(IN,'(F10.0,I10)') DT0,MXSTRN + 101 IF(TTSMULT.LT.1.0) TTSMULT=1.0 + WRITE(IOUT,51) DT0,TUNIT,MXSTRN,TTSMULT,TTSMAX,TUNIT + 51 FORMAT(1X,'USER-SPECIFIED TRANSPORT STEPSIZE =',G15.7,A4 + & /1X,'MAXIMUM NUMBER OF TRANSPORT STEPS ALLOWED ', + & ' IN ONE FLOW TIME STEP =',I10, + & /1X,'MULTIPLIER FOR SUCCESSIVE TRANSPORT STEPS ', + & ' [USED IN IMPLICIT SCHEMES] =',F10.3, + & /1X,'MAXIMUM TRANSPORT STEP SIZE ', + & ' [USED IN IMPLICIT SCHEMES] =',G15.7,A4) +C + IF(DT0.LT.0) WRITE(*,55) + 55 FORMAT(/1X,'NEGATIVE VALUE FOR INPUT VARIABLE [DT0] DETECTED; ', + & /1X,'MODEL-CALCULATED TRANSPORT STEPSIZE REPLACED WITH [-DT0]', + & /1X,'REGARDLESS OF STABILITY CONSTRAINTS FOR EXPLICIT SCHEMES', + & /1X,'OR TRANSPORT STEP MULTIPLIER FOR IMPLICIT SCHEMES.') +C + RETURN + END +C +C + SUBROUTINE BTN5AD(IOUT,NTRANS,MXTRNOP,iUnitTRNOP,iSSTrans, + & TIME1,TIME2,HT2,DELT,KSTP,NSTP,MXPRS,TIMPRS,DT0,MXSTRN,MIXELM, + & DTRACK,DTRACK2,PERCEL,DTDISP,DTSSM,DTRCT,RFMIN,NPRS,NPS,DTRANS, + & PRTOUT,NCOL,NROW,NLAY,NCOMP,ICBUND,CNEW,COLD,CINACT,UPDLHS, + & IMPSOL,TTSMULT,TTSMAX,KPER,DELR,DELC,DH,PRSITY,SRCONC,RHOB, + & RETA,PRSITY2,RETA2,ISOTHM,TMASIO,RMASIO,TMASS) +C ********************************************************************** +C THIS SUBROUTINE ADVANCES THE TRANSPORT SIMULATION ONE STEP, +C DETERMINING THE STEPSIZE TO BE USED AND WHETHER PRINTOUT IS REQUIRED +C FOR NEXT TRANSPORT STEP. IT ALSO COMPUTES TOTAL MASS IN THE AQUIFER +C AT THE FIRST TRANSPORT STEP OF EACH TRANSPORT LOOP. +C ********************************************************************** +C last modified: 02-20-2010 +C + IMPLICIT NONE + INTEGER NTRANS,KSTP,NSTP,NPS,NPRS,MXPRS,MXSTRN,MIXELM,INDEX, + & ICBUND,K,I,J,NCOL,NROW,NLAY,NCOMP,IMPSOL,KPER,ISOTHM, + & MXTRNOP,iUnitTRNOP,iSSTrans,IOUT + REAL TIME1,TIME2,DT0,DTRACK,DTRACK2,PERCEL,DTRANS,DTDISP, + & HT2,TIMPRS,DTSSM,DTRCT,DELT,RFMIN,CNEW,COLD,CINACT, + & TMASIO,RMASIO,TMASS,DTOLD,TTSMULT,DELR,DELC,DH, + & PRSITY,PRSITY2,RETA2,CMML,CMMS,CIML,CIMS, + & SRCONC,RHOB,RETA,VOLUME,TTSMAX,EPSILON,TEMP,TTMP + DIMENSION iUnitTRNOP(MXTRNOP),ICBUND(NCOL,NROW,NLAY,NCOMP), + & CNEW(NCOL,NROW,NLAY,NCOMP),COLD(NCOL,NROW,NLAY,NCOMP), + & DELR(NCOL),DELC(NROW),DH(NCOL,NROW,NLAY), + & PRSITY(NCOL,NROW,NLAY),RHOB(NCOL,NROW,NLAY), + & SRCONC(NCOL,NROW,NLAY,NCOMP),RETA(NCOL,NROW,NLAY,NCOMP), + & RETA2(NCOL,NROW,NLAY,NCOMP),PRSITY2(NCOL,NROW,NLAY) + LOGICAL PRTOUT,UPDLHS + DIMENSION TIMPRS(MXPRS),TMASIO(122,2,NCOMP),RMASIO(122,2,NCOMP), + & TMASS(4,3,NCOMP),TEMP(4) + PARAMETER (EPSILON=0.5E-6) +C +C--SAVE PREVIOUS TRANSPORT STEPSIZE + DTOLD=DTRANS +C +C--DETERMINE STEPSIZE FOR NEXT TRANSPORT STEP + IF(MIXELM.EQ.0) THEN !fully implicit fd scheme + DTRANS=DELT + IF(iUnitTRNOP(1).GT.0) DTRANS=MIN(DTRANS,DTRACK*PERCEL*RFMIN) + IF(DT0.GT.0) DTRANS=DT0 + IF(TTSMULT.GT.1) THEN + TTMP=LOG10(DTRANS)+(NTRANS-1)*LOG10(TTSMULT) + IF(TTMP.GE.10.) THEN + DTRANS=10.**TTMP + ELSE + DTRANS=DTRANS*TTSMULT**(NTRANS-1) + ENDIF + ENDIF + IF(TTSMAX.GT.0.AND.DTRANS.GT.TTSMAX) DTRANS=TTSMAX + ELSE !moc/mmoc/hmoc/tvd schemes + DTRANS=DELT + IF(iUnitTRNOP(1).GT.0.AND.MIXELM.GT.0) THEN + DTRANS=MIN(DTRANS,DTRACK*PERCEL*RFMIN) + ELSEIF(iUnitTRNOP(1).GT.0.AND.MIXELM.LT.0) THEN + DTRANS=MIN(DTRANS,DTRACK2*PERCEL*RFMIN) + ENDIF + IF(DT0.GT.0.AND.DT0.LT.DTRANS) DTRANS=DT0 + IF(TTSMAX.GT.0.AND.DTRANS.GT.TTSMAX) DTRANS=TTSMAX + ENDIF +C +C--IF DT0 NEGATIVE, USE |DT0| AS DEFAULT TRANSPORT STEPSIZE + IF(DT0.LT.0) DTRANS=ABS(DT0) +c +c--IF steady-state transport simulation, reset time step + IF(iSSTrans.EQ.1) THEN + if(MIXELM.NE.0) then + write(iout,101) + write(*,101) + call ustop(' ') + endif + DTRANS=DELT + ENDIF + 101 format(1x,'ERROR: Steady-state transport can only be simulated', + & /1x,'with fully implicit finite-difference [MIXELM=0].') +C +C--UPDATES TOTAL ELASPED TIME + TIME1=TIME2 + TIME2=TIME1+DTRANS +C +C--DETERMIN IF PRINTOUT OF SIMULATION RESULTS +C--IS NEEDED FOR NEXT STEP + PRTOUT=.FALSE. + IF(NTRANS.EQ.MXSTRN) THEN + PRTOUT=.TRUE. + ELSEIF(NPRS.LT.0) THEN + IF(MOD(NTRANS,-NPRS).EQ.0) PRTOUT=.TRUE. + ENDIF +C +C--IF TOTAL ELAPSED TIME AT NEXT TRANSPORT STEP EXCEEDS +C--THE LIMIT OF CURRENT TIME STEP, CUT DOWN STEPSIZE + IF(TIME2.GE.HT2) THEN + TIME2=HT2 + DTRANS=TIME2-TIME1 + IF(KSTP.EQ.NSTP) PRTOUT=.TRUE. + ENDIF +C +C--IF TOTAL ELAPSED TIME AT NEXT STEP EXCEEDS TIME AT WHICH +C--PRINTOUT IS REQUESTED, CUT DOWN STEPSIZE + IF(NPRS.GT.0.AND.NPS.LE.NPRS) THEN + IF(TIME2.GE.TIMPRS(NPS)) THEN + IF(TIME2.GT.TIMPRS(NPS)) THEN + TIME2=TIMPRS(NPS) + DTRANS=TIME2-TIME1 + ENDIF + PRTOUT=.TRUE. + NPS=NPS+1 + ENDIF + ENDIF +C + UPDLHS=.TRUE. + IF(ABS(DTRANS-DTOLD).LT.ABS(DTRANS+DTOLD)*EPSILON + & .AND. NTRANS.GT.1) UPDLHS=.FALSE. +C +C--PRINT OUT AN IDENTIFYING MSGGAGE + WRITE(*,70) NTRANS,DTRANS,TIME2 + 70 FORMAT(1X,'Transport Step:',I5,3X,'Step Size:',1PG12.4, + & ' Total Elapsed Time:',G13.5) +C +C--COPY ARRAY [CNEW] TO [COLD] + DO INDEX=1,NCOMP + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K,INDEX).EQ.0) THEN + CNEW(J,I,K,INDEX)=CINACT + ELSE + COLD(J,I,K,INDEX)=CNEW(J,I,K,INDEX) + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO +C +C--CLEAR RMASIO ARRAY FOR ACCUMULATING MASS IN/OUT +C--AT NEXT TRANSPORT STEP + DO INDEX=1,NCOMP + DO I=1,122 + RMASIO(I,1,INDEX)=0. + RMASIO(I,2,INDEX)=0. + ENDDO + ENDDO +C +C--CALCAULTE TOTAL MASS IN AQUIFER AT THE FIRST TRANSPORT STEP + IF(NTRANS.GT.1) GOTO 9999 +C +C--1: MOBILE-LIQUID (MML) PHASE +C--2: MOBILE-SORBED (MMS) PHASE +C--3: IMMOBILE-LIQUID (IML) PHASE +C--4: IMMOBILE-SORBED (IMS) PHASE +C + DO INDEX=1,NCOMP + TEMP(1)=0. + TEMP(2)=0. + TEMP(3)=0. + TEMP(4)=0. + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K,INDEX).LE.0) CYCLE + VOLUME=DELR(J)*DELC(I)*DH(J,I,K) + CMML=COLD(J,I,K,INDEX)*PRSITY(J,I,K)*VOLUME + CMMS=0. + CIML=0. + CIMS=0. + IF(ISOTHM.EQ.1) THEN + CMMS=(RETA(J,I,K,INDEX)-1.)*CMML + ELSEIF(ISOTHM.GT.1.AND.ISOTHM.LE.4) THEN + CMMS=SRCONC(J,I,K,INDEX)*RHOB(J,I,K)*VOLUME + ELSEIF(ISOTHM.GT.4) THEN + CMMS=(RETA(J,I,K,INDEX)-1.)*CMML + CIML=PRSITY2(J,I,K)*SRCONC(J,I,K,INDEX)*VOLUME + CIMS=(RETA2(J,I,K,INDEX)-1.)*CIML + ENDIF + TEMP(1)=TEMP(1)+CMML + TEMP(2)=TEMP(2)+CMMS + TEMP(3)=TEMP(3)+CIML + TEMP(4)=TEMP(4)+CIMS + ENDDO + ENDDO + ENDDO +C +C--STORE INITIAL MASS IF THE CURRENT TRANSPORT STEP +C--IS AT THE BEGINNING OF SIMULATION + IF(KPER*KSTP.EQ.1) THEN + TMASS(1,1,INDEX)=TEMP(1) + TMASS(2,1,INDEX)=TEMP(2) + TMASS(3,1,INDEX)=TEMP(3) + TMASS(4,1,INDEX)=TEMP(4) +C +C--OTHERWISE DETERMINE AND ACCUMULATE CHANGE IN MASS STORAGE +C--CAUSED BY CHANGE IN SATURATED THICKNESS OF UNCONFINED AQUIFER + ELSE + TEMP(1)=TMASS(1,2,INDEX)-TEMP(1) + TEMP(2)=TMASS(2,2,INDEX)-TEMP(2) + TEMP(3)=TMASS(3,2,INDEX)-TEMP(3) + TEMP(4)=TMASS(4,2,INDEX)-TEMP(4) + TMASS(1,3,INDEX)=TMASS(1,3,INDEX)+TEMP(1) + TMASS(2,3,INDEX)=TMASS(2,3,INDEX)+TEMP(2) + TMASS(3,3,INDEX)=TMASS(3,3,INDEX)+TEMP(3) + TMASS(4,3,INDEX)=TMASS(4,3,INDEX)+TEMP(4) + ENDIF + ENDDO +C + 9999 CONTINUE +C + RETURN + END +C +C + SUBROUTINE BTN5SV(NCOL,NROW,NLAY,NCOMP,ICOMP,ICBUND,CNEW, + & CWGT,CINACT,RMASIO) +C ************************************************************** +C THIS SUBROUTINE UPDATES CELL CONCENTRATION AND MASS IN/OUT +C ACCUMULATING ARRAY TO PREPARE FOR SIMULATION AT NEXT STEP. +C ************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER NCOL,NROW,NLAY,NCOMP,ICOMP,J,I,K,ICBUND + REAL CNEW,CWGT,CINACT,RMASIO + DIMENSION ICBUND(NCOL,NROW,NLAY,NCOMP), + & CNEW(NCOL,NROW,NLAY,NCOMP), + & CWGT(NCOL,NROW,NLAY,NCOMP),RMASIO(122,2,NCOMP) +C +C--COPY CNEW TO CWGT + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K,ICOMP).EQ.0) CYCLE + CWGT(J,I,K,ICOMP)=CNEW(J,I,K,ICOMP) + ENDDO + ENDDO + ENDDO +C +C--CLEAR RMASIO ARRAY FOR ACCUMULATING MASS IN/OUT +C--AT NEXT TRANSPORT STEP + DO I=1,122 + RMASIO(I,1,ICOMP)=0. + RMASIO(I,2,ICOMP)=0. + ENDDO +C + RETURN + END +C +C + SUBROUTINE BTN5BD(KPER,KSTP,NTRANS,NCOL,NROW,NLAY,NCOMP,ICOMP, + & iSS,iSSTrans,ICBUND,DELR,DELC,DH,PRSITY,RETA,CNEW,COLD,RHOB, + & SRCONC,PRSITY2,RETA2,ISOTHM,DTRANS,TMASIN,TMASOT, + & ERROR,ERROR2,TMASIO,RMASIO,TMASS) +C ********************************************************************** +C THIS SUBROUTINE SUMMARIZES VOLUMETRIC MASS BUDGETS AND CALCULATES +C MASS BALANCE DISCREPANCY SINCE THE BEGINNING OF THE SIMULATION. +C ********************************************************************** +C last modified: 02-20-2010 +C + IMPLICIT NONE + INTEGER KPER,KSTP,NCOL,NROW,NLAY,NCOMP,ICOMP,ICBUND,K,I,J,IQ, + & NTRANS,ISOTHM,iSS,iSSTrans + REAL DELR,DELC,DH,PRSITY,RETA,CNEW,COLD,TMASIN,TMASOT, + & TMASIO,RMASIO,DMSTRG,ERROR,ERROR2,TMASS, + & SOURCE,SINK,TM1,TM2,DTRANS,RHOB,SRCONC,PRSITY2,RETA2, + & CMML,CMMS,CIML,CIMS,VOLUME,STRMAS + DIMENSION DELR(NCOL),DELC(NROW),DH(NCOL,NROW,NLAY), + & RHOB(NCOL,NROW,NLAY),SRCONC(NCOL,NROW,NLAY,NCOMP), + & PRSITY(NCOL,NROW,NLAY),RETA(NCOL,NROW,NLAY,NCOMP), + & PRSITY2(NCOL,NROW,NLAY),RETA2(NCOL,NROW,NLAY,NCOMP), + & CNEW(NCOL,NROW,NLAY,NCOMP),COLD(NCOL,NROW,NLAY,NCOMP), + & ICBUND(NCOL,NROW,NLAY,NCOMP),TMASIN(NCOMP), + & TMASOT(NCOMP),ERROR(NCOMP),ERROR2(NCOMP), + & TMASIO(122,2,NCOMP),RMASIO(122,2,NCOMP),TMASS(4,3,NCOMP) +C +C--CALCULATE SOLUTE AND SORBED MASS STORAGE CHANGES (MOBILE-DOMAIN) +C--FOR THE CURRENT TRANSPORT STEP + IF(iSSTrans.ne.0) goto 1110 !skip if steady-state transport + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K,ICOMP).GT.0.AND.DTRANS.GT.0) THEN + DMSTRG=(CNEW(J,I,K,ICOMP)-COLD(J,I,K,ICOMP)) + & *DELR(J)*DELC(I)*DH(J,I,K)*PRSITY(J,I,K) + IF(DMSTRG.LT.0) THEN + RMASIO(119,1,ICOMP)=RMASIO(119,1,ICOMP)-DMSTRG + RMASIO(120,1,ICOMP)=RMASIO(120,1,ICOMP) + & -(RETA(J,I,K,ICOMP)-1.)*DMSTRG + ELSE + RMASIO(119,2,ICOMP)=RMASIO(119,2,ICOMP)-DMSTRG + RMASIO(120,2,ICOMP)=RMASIO(120,2,ICOMP) + & -(RETA(J,I,K,ICOMP)-1.)*DMSTRG + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + 1110 Continue +C +C--ACCUMULATE MASS IN/OUT FOR VARIOUS SINK/SOURCE TERMS AND +C--MASS STOAGE CHANGES SINCE THE BEGINNING OF SIMULATION + DO IQ=1,122 + TMASIO(IQ,1,ICOMP)=TMASIO(IQ,1,ICOMP)+RMASIO(IQ,1,ICOMP) + TMASIO(IQ,2,ICOMP)=TMASIO(IQ,2,ICOMP)+RMASIO(IQ,2,ICOMP) + ENDDO +C +C--DETERMINE TOTAL MASS IN AND OUT + TMASIN(ICOMP)=0. + TMASOT(ICOMP)=0. + DO IQ=1,122 + TMASIN(ICOMP)=TMASIN(ICOMP)+TMASIO(IQ,1,ICOMP) + TMASOT(ICOMP)=TMASOT(ICOMP)+TMASIO(IQ,2,ICOMP) + ENDDO +C +C--COMPUTE ACCUMULATIVE DISCREPANCY BETWEEN MASS IN AND OUT + ERROR(ICOMP)=0. + IF(ABS(TMASIN(ICOMP))+ABS(TMASOT(ICOMP)).NE.0) THEN + ERROR(ICOMP)=100.*(TMASIN(ICOMP)+TMASOT(ICOMP)) + & /(0.5*(ABS(TMASIN(ICOMP))+ABS(TMASOT(ICOMP)))) + ENDIF +C +C--CALCULATE TOTAL MASS IN AQUIFER FOR CURRENT TRANSPORT STEP + TMASS(1,2,ICOMP)=0. + TMASS(2,2,ICOMP)=0. + TMASS(3,2,ICOMP)=0. + TMASS(4,2,ICOMP)=0. + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K,ICOMP).LE.0) CYCLE + VOLUME=DELR(J)*DELC(I)*DH(J,I,K) + CMML=CNEW(J,I,K,ICOMP)*PRSITY(J,I,K)*VOLUME + CMMS=0. + CIML=0. + CIMS=0. + IF(ISOTHM.EQ.1) THEN + CMMS=(RETA(J,I,K,ICOMP)-1.)*CMML + ELSEIF(ISOTHM.GT.1.AND.ISOTHM.LE.4) THEN + CMMS=SRCONC(J,I,K,ICOMP)*RHOB(J,I,K)*VOLUME + ELSEIF(ISOTHM.GT.4) THEN + CMMS=(RETA(J,I,K,ICOMP)-1.)*CMML + CIML=PRSITY2(J,I,K)*SRCONC(J,I,K,ICOMP)*VOLUME + CIMS=(RETA2(J,I,K,ICOMP)-1.)*CIML + ENDIF + TMASS(1,2,ICOMP)=TMASS(1,2,ICOMP)+CMML + TMASS(2,2,ICOMP)=TMASS(2,2,ICOMP)+CMMS + TMASS(3,2,ICOMP)=TMASS(3,2,ICOMP)+CIML + TMASS(4,2,ICOMP)=TMASS(4,2,ICOMP)+CIMS + ENDDO + ENDDO + ENDDO +C +C--COMPUTE TOTAL SOURCE AND SINK EXCLUDING MASS +C--FROM OR INTO FLUID-STORAGE IN TRANSIENT FLOW FIELD + SOURCE=0. + SINK=0. + DO IQ=1,117 + SOURCE=SOURCE+TMASIO(IQ,1,ICOMP) + SINK=SINK+TMASIO(IQ,2,ICOMP) + ENDDO +C +C--GET SUM OF TOTAL SOURCE AND INITIAL MASS + TM1=ABS(SOURCE)+TMASS(1,1,ICOMP)+TMASS(2,1,ICOMP) + & +TMASS(3,1,ICOMP)+TMASS(4,1,ICOMP) +C +C--GET SUM OF TOTAL SINK AND CURRENT MASS + TM2=ABS(SINK)+TMASS(1,2,ICOMP)+TMASS(2,2,ICOMP) + & +TMASS(3,2,ICOMP)+TMASS(4,2,ICOMP) +C +C--CORRECT FOR NET MASS FROM/INTO FLUID-STORAGE + STRMAS=(TMASIO(118,1,ICOMP)+TMASIO(118,2,ICOMP)) + & -(TMASS(1,3,ICOMP)+TMASS(2,3,ICOMP) + & +TMASS(3,3,ICOMP)+TMASS(4,3,ICOMP)) + TM1=TM1+STRMAS +C +C--COMPUTE ALTERNATVE MEASURE OF MASS DISCREPANCY + ERROR2(ICOMP)=0. + if(iSSTrans.ne.0) goto 1120 !skip if steady-state transport + IF( TM1+TM2 .NE.0. ) THEN + ERROR2(ICOMP)=100.*(TM1-TM2)/(0.5*(TM1+TM2)) + ENDIF + 1120 continue +C +C--RETURN + RETURN + END +C +C + SUBROUTINE BTN5OT(NCOL,NROW,NLAY,KPER,KSTP,NTRANS,NCOMP,ICOMP, + & IOUT,IOBS,IUCN,IUCN2,IMAS,ICBM,MXOBS,NOBS,NPROBS,LOCOBS,ICBUND, + & TIME2,CNEW,MIXELM,NCOUNT,NPINS,NRC,NPCHEK,ISOTHM,RETA,SRCONC, + & TMASIN,TMASOT,ERROR,ERROR2,MXTRNOP,iUnitTRNOP,TUNIT,MUNIT, + & PRTOUT,TMASIO,RMASIO,TMASS) +C ********************************************************************** +C THIS SUBROUTINE SAVES SIMULATION RESULTS IN THE STANDARD OUTPUT FILE +C AND VARIOUS OPTIONAL OUTPUT FILES, ACCORDING TO THE OUTPUT CONTROL +C OPTIONS SPECIFIED IN THE BASIC TRANSPORT INPUT FILE. +C ********************************************************************** +C last modified: 02-20-2010 +C + IMPLICIT NONE + INTEGER NCOL,NROW,NLAY,KPER,KSTP,NTRANS,IOUT,IOBS,IUCN,IUCN2, + & IMAS,ICBM,MIXELM,NCOUNT,NPINS,NRC,ISOTHM,NPCHEK, + & MXOBS,NOBS,NPROBS,LOCOBS,IFMTCN,IFMTNP,IFMTRF,IFMTDP, + & K,I,J,N,NPRMAS,ICBUND,NCOMP,ICOMP,MXTRNOP,iUnitTRNOP + REAL TIME2,CNEW,RETA,TMASIN,TMASOT,ERROR,TMASIO,RMASIO, + & TMASS,ERROR2,SOURCE,SINK,STRMAS,TOTMAS,SRCONC + LOGICAL FWEL,FDRN,FRCH,FEVT,FRIV,FGHB,FSTR,FRES,FFHB,FIBS, + & FTLK,FLAK,FMNW,FDRT,FETS,FSWT,FSFR,FUZF, + & PRTOUT,CHKMAS,SAVUCN,SAVCBM + CHARACTER TEXT*16,TUNIT*4,MUNIT*4 + DIMENSION CNEW(NCOL,NROW,NLAY,NCOMP),NPCHEK(NCOL,NROW,NLAY,NCOMP), + & RETA(NCOL,NROW,NLAY,NCOMP),SRCONC(NCOL,NROW,NLAY,NCOMP), + & ICBUND(NCOL,NROW,NLAY,NCOMP),LOCOBS(3,MXOBS), + & TMASIO(122,2,NCOMP),RMASIO(122,2,NCOMP), + & TMASS(4,3,NCOMP),NCOUNT(NCOMP),NPINS(NCOMP),NRC(NCOMP), + & TMASIN(NCOMP),TMASOT(NCOMP),ERROR(NCOMP),ERROR2(NCOMP), + & iUnitTRNOP(MXTRNOP) + COMMON /FC/FWEL,FDRN,FRCH,FEVT,FRIV,FGHB,FSTR,FRES,FFHB,FIBS, + & FTLK,FLAK,FMNW,FDRT,FETS,FSWT,FSFR,FUZF + COMMON /OC/IFMTCN,IFMTNP,IFMTRF,IFMTDP,SAVUCN,SAVCBM,CHKMAS,NPRMAS +C +C--PRINT OUT CONCENTRATIONS AT SPECIFIED OBSERVATION POINTS +C--TO FILE [MT3Dnnn.OBS] IF REQUESTED. + IF(NOBS.GT.0.AND.(MOD(NTRANS-1,NPROBS).EQ.0.OR.PRTOUT)) THEN + IF(NOBS.LE.16) THEN + WRITE(IOBS+ICOMP,1000) NTRANS,TIME2,(CNEW(LOCOBS(3,N), + & LOCOBS(2,N),LOCOBS(1,N),ICOMP),N=1,NOBS) + ELSE + WRITE(IOBS+ICOMP,1010) NTRANS,TIME2,(CNEW(LOCOBS(3,N), + & LOCOBS(2,N),LOCOBS(1,N),ICOMP),N=1,NOBS) + ENDIF + ENDIF + 1000 FORMAT(1X,I5,1X,1PG13.5,1X,16(G13.5,1X)) + 1010 FORMAT(1X,I5,1X,1PG13.5,1X,16(G13.5,1X)/(1X,20X,16(G13.5,1X))) +C +C--WRITE A ONE-LINE SUMMARY OF MASS BALANCE +C--TO FILE [MT3Dnnn.MAS] IF REQUESTED + IF(CHKMAS.AND.(MOD(NTRANS-1,NPRMAS).EQ.0.OR.PRTOUT)) THEN + SOURCE=0. + SINK=0. + DO N=1,117 + SOURCE=SOURCE+TMASIO(N,1,ICOMP) + SINK=SINK+TMASIO(N,2,ICOMP) + ENDDO + STRMAS=(TMASIO(118,1,ICOMP)+TMASIO(118,2,ICOMP)) + & -(TMASS(1,3,ICOMP)+TMASS(2,3,ICOMP) + & +TMASS(3,3,ICOMP)+TMASS(4,3,ICOMP)) + TOTMAS=TMASS(1,2,ICOMP)+TMASS(2,2,ICOMP) + & +TMASS(3,2,ICOMP)+TMASS(4,2,ICOMP) + WRITE(IMAS+ICOMP,1012) TIME2,TMASIN(ICOMP),TMASOT(ICOMP), + & SOURCE,SINK,STRMAS,TOTMAS, + & ERROR(ICOMP),ERROR2(ICOMP) + ENDIF + 1012 FORMAT(1X,1P,7(G13.5,1X),4X,G10.3,5X,G10.3) +C +C--SAVE CELL CONCENTRATIONS TO UNFORMATTED FILES IF REQUESTED + IF(SAVUCN .AND. PRTOUT) THEN + TEXT='CONCENTRATION' +C +C--DISSOLVED PHASE CONCENTRATION TO FILE [MT3Dnnn.UCN] + DO K=1,NLAY + WRITE(IUCN+ICOMP) NTRANS,KSTP,KPER,TIME2,TEXT,NCOL,NROW,K + WRITE(IUCN+ICOMP) ((CNEW(J,I,K,ICOMP),J=1,NCOL),I=1,NROW) + ENDDO +C +C--SORBED/IMMOBILE PHASE CONCENTRATIONS TO FILE [MT3DnnnS.UCN] + IF(ISOTHM.GT.0) THEN + DO K=1,NLAY + WRITE(IUCN2+ICOMP) NTRANS,KSTP,KPER,TIME2,TEXT,NCOL,NROW,K + WRITE(IUCN2+ICOMP) ((SRCONC(J,I,K,ICOMP),J=1,NCOL),I=1,NROW) + ENDDO + ENDIF + ENDIF +C +C--WRITE SIMULATION RESULTS AND MASS BUDGET TERMS +C--TO THE STANDARD OUTFILE IF NEEDED + IF(.NOT.PRTOUT) GOTO 9999 +C +C--PRINT A HEADER + WRITE(IOUT,1019) ICOMP + 1019 FORMAT(///1X,55('>'),'FOR COMPONENT NO.',I3.2,55('<')) +C + WRITE(IOUT,1020) NTRANS,TIME2,TUNIT + 1020 FORMAT(//44X,43('-')/54X,'TRANSPORT STEP NO.',I5/44X,43('-') + & //1X,'TOTAL ELAPSED TIME SINCE BEGINNING OF SIMULATION =', + & G15.7,A4/1X,69('.')) +C +C--PRINT CELL CONCENTRATIONS IF NEEDED + IF(IFMTCN.EQ.0) GOTO 40 +C + TEXT='CONCENTRATIONS' + DO K=1,NLAY + CALL RPRINT(CNEW(1,1,K,ICOMP),TEXT, + & NTRANS,KSTP,KPER,NCOL,NROW,K,IFMTCN,IOUT) + ENDDO +C +C--PRINT NONLINEAR RETARDATION FACTOR IF NEEDED + 40 IF(iUnitTRNOP(4).EQ.0) GOTO 50 + IF(ISOTHM.NE.2.AND.ISOTHM.NE.3) GOTO 50 + IF(IFMTRF.EQ.0) GOTO 50 +C + TEXT='RETARD. FACTOR' + DO K=1,NLAY + CALL RPRINT(RETA(1,1,K,ICOMP),TEXT, + & NTRANS,KSTP,KPER,NCOL,NROW,K,IFMTRF,IOUT) + ENDDO +C +C--PRINT PARTICLE USAGE INFORMATION IF NECESSARY + 50 IF(iUnitTRNOP(1).EQ.0) GOTO 70 + IF(MIXELM.LE.0) GOTO 70 +C + WRITE(IOUT,1030) NCOUNT(ICOMP),NPINS(ICOMP),NRC(ICOMP) + 1030 FORMAT(/1X,'TOTAL PARTICLES USED IN THE CURRENT STEP =',I10 + & /1X,'PARTICLES ADDED AT BEGINNING OF THE STEP =',I10 + & /1X,'PARTICLES REMOVED AT END OF LAST STEP =',I10) +C +C--PRINT PARTICLE NUMBER PER CELL IF NEEDED + IF(IFMTNP.EQ.0) GOTO 70 +C + TEXT='PARTICLE NUMBER ' + DO K=1,NLAY + CALL IPRINT(NPCHEK(1,1,K,ICOMP),TEXT, + & NTRANS,KSTP,KPER,NCOL,NROW,K,IFMTNP,IOUT) + ENDDO +C +C--PRINT OUT ACCUMULATIVE MASS BALANCE INFORMATION + 70 WRITE(IOUT,1110) NTRANS,KSTP,KPER + WRITE(IOUT,1114) + WRITE(IOUT,1122) TMASIO(6,1,ICOMP),TMASIO(6,2,ICOMP) + WRITE(IOUT,1120) TMASIO(1,1,ICOMP),TMASIO(1,2,ICOMP) + IF(FWEL) WRITE(IOUT,1130) TMASIO(2,1,ICOMP),TMASIO(2,2,ICOMP) + IF(FDRN) WRITE(IOUT,1140) TMASIO(3,1,ICOMP),TMASIO(3,2,ICOMP) + IF(FRIV) WRITE(IOUT,1150) TMASIO(4,1,ICOMP),TMASIO(4,2,ICOMP) + IF(FGHB) WRITE(IOUT,1160) TMASIO(5,1,ICOMP),TMASIO(5,2,ICOMP) + IF(FRCH) WRITE(IOUT,1162) TMASIO(7,1,ICOMP),TMASIO(7,2,ICOMP) + IF(FEVT) WRITE(IOUT,1164) TMASIO(8,1,ICOMP),TMASIO(8,2,ICOMP) + IF(TMASIO(15,1,ICOMP)-TMASIO(15,2,ICOMP).NE.0) + & WRITE(IOUT,1165) TMASIO(15,1,ICOMP),TMASIO(15,2,ICOMP) +C + IF(FSTR) WRITE(IOUT,2100) TMASIO(21,1,ICOMP),TMASIO(21,2,ICOMP) + IF(FRES) WRITE(IOUT,2102) TMASIO(22,1,ICOMP),TMASIO(22,2,ICOMP) + IF(FFHB) WRITE(IOUT,2104) TMASIO(23,1,ICOMP),TMASIO(23,2,ICOMP) + IF(FIBS) WRITE(IOUT,2106) TMASIO(24,1,ICOMP),TMASIO(24,2,ICOMP) + IF(FTLK) WRITE(IOUT,2108) TMASIO(25,1,ICOMP),TMASIO(25,2,ICOMP) + IF(FLAK) WRITE(IOUT,2110) TMASIO(26,1,ICOMP),TMASIO(26,2,ICOMP) + IF(FMNW) WRITE(IOUT,2112) TMASIO(27,1,ICOMP),TMASIO(27,2,ICOMP) + IF(FDRT) WRITE(IOUT,2114) TMASIO(28,1,ICOMP),TMASIO(28,2,ICOMP) + IF(FETS) WRITE(IOUT,2116) TMASIO( 8,1,ICOMP),TMASIO( 8,2,ICOMP) + IF(iUnitTRNOP(13).GT.0) + & WRITE(IOUT,2118) TMASIO(50,1,ICOMP),TMASIO(50,2,ICOMP) + IF(FSWT) WRITE(IOUT,2200) TMASIO(51,1,ICOMP),TMASIO(51,2,ICOMP) + IF(FSFR) WRITE(IOUT,2202) TMASIO(52,1,ICOMP),TMASIO(52,2,ICOMP) + IF(FUZF) WRITE(IOUT,2204) TMASIO(53,1,ICOMP),TMASIO(53,2,ICOMP) +C + IF(iUnitTRNOP(4).GT.0) + & WRITE(IOUT,1166) TMASIO(9,1,ICOMP),TMASIO(9,2,ICOMP) + WRITE(IOUT,1170) TMASIO(119,1,ICOMP),TMASIO(119,2,ICOMP) + IF(iUnitTRNOP(4).GT.0.AND.ISOTHM.GT.0) + & WRITE(IOUT,1172) TMASIO(120,1,ICOMP),TMASIO(120,2,ICOMP) + IF(iUnitTRNOP(4).GT.0.AND.ISOTHM.GT.4) THEN + WRITE(IOUT,1173) + WRITE(IOUT,1174) TMASIO(10,1,ICOMP),TMASIO(10,2,ICOMP) + WRITE(IOUT,1175) TMASIO(121,1,ICOMP),TMASIO(121,2,ICOMP) + WRITE(IOUT,1176) TMASIO(122,1,ICOMP),TMASIO(122,2,ICOMP) + ENDIF + WRITE(IOUT,1180) TMASIN(ICOMP),MUNIT,TMASOT(ICOMP),MUNIT, + & TMASIN(ICOMP)+TMASOT(ICOMP),ERROR(ICOMP) +C + 1110 FORMAT(/21X,'CUMMULATIVE MASS BUDGETS AT END OF TRANSPORT STEP', + & I5,', TIME STEP',I5,', STRESS PERIOD',I5/21X,90('-')) + 1114 FORMAT(/30X,24X,7X,'IN',8X,13X,6X,'OUT', + & /30X,24X,16('-'),13X,16('-')) + 1122 FORMAT(30X,' CONSTANT CONCENTRATION: ',G15.7,13X,G15.7) + 1120 FORMAT(30X,' CONSTANT HEAD: ',G15.7,13X,G15.7) + 1130 FORMAT(30X,' WELLS: ',G15.7,13X,G15.7) + 1140 FORMAT(30X,' DRAINS: ',G15.7,13X,G15.7) + 1150 FORMAT(30X,' RIVERS: ',G15.7,13X,G15.7) + 1160 FORMAT(30X,'HEAD-DEPENDENT BOUNDARY: ',G15.7,13X,G15.7) + 1162 FORMAT(30X,' RECHARGE: ',G15.7,13X,G15.7) + 1164 FORMAT(30X,' EVAPOTRANSPIRATION: ',G15.7,13X,G15.7) + 1165 FORMAT(30X,' MASS LOADING: ',G15.7,13X,G15.7) +C + 2100 FORMAT(30X,' STREAMFLOW ROUTING: ',G15.7,13X,G15.7) + 2102 FORMAT(30X,' RESERVOIR: ',G15.7,13X,G15.7) + 2104 FORMAT(30X,' FLOW AND HEAD BOUNDARY: ',G15.7,13X,G15.7) + 2106 FORMAT(30X,' INTERBED STORAGE FLOW: ',G15.7,13X,G15.7) + 2108 FORMAT(30X,' TRANSIENT LEACKAGE: ',G15.7,13X,G15.7) + 2110 FORMAT(30X,' LAKE: ',G15.7,13X,G15.7) + 2112 FORMAT(30X,' MULTI-NODE WELL: ',G15.7,13X,G15.7) + 2114 FORMAT(30X,' DRAIN WITH RETURN FLOW: ',G15.7,13X,G15.7) + 2116 FORMAT(30X,' SEGMENTED ET: ',G15.7,13X,G15.7) + 2118 FORMAT(30X,'HSS TIME-VARYING SOURCE: ',G15.7,13X,G15.7) + 2200 FORMAT(30X,' USER-DEFINED NO.1: ',G15.7,13X,G15.7) + 2202 FORMAT(30X,' USER-DEFINED NO.2: ',G15.7,13X,G15.7) + 2204 FORMAT(30X,' USER-DEFINED NO.3: ',G15.7,13X,G15.7) +C + 1166 FORMAT(30X,' 1ST/0TH ORDER REACTION: ',G15.7,13X,G15.7) + 1170 FORMAT(30X,' MASS STORAGE (SOLUTE): ',G15.7,13X,G15.7) + 1172 FORMAT(30X,' MASS STORAGE (SORBED): ',G15.7,13X,G15.7) + 1173 FORMAT(30X,'....immobile domain....') + 1174 FORMAT(30X,' 1ST/0TH ORDER REACTION: ',G15.7,13X,G15.7) + 1175 FORMAT(30X,' MASS STORAGE (SOLUTE): ',G15.7,13X,G15.7) + 1176 FORMAT(30X,' MASS STORAGE (SORBED): ',G15.7,13X,G15.7) + 1180 FORMAT(28X,75('-'), + & /30X,' [TOTAL]: ',G15.7,1X,A4,8X,G15.7, + & 1X,A4//40X,' NET (IN - OUT): ',G15.7, + & /40X,' DISCREPANCY (PERCENT): ',G15.7) +C +C--RETURN + 9999 RETURN + END +C +C + SUBROUTINE BTN5FM(NCOL,NROW,NLAY,NCOMP,ICOMP,ICBUND,CADV,COLD, + & RETA,PRSITY,DELR,DELC,DZ,DTRANS,A,RHS,NODES,UPDLHS,NCRS, + * MIXELM,iSSTrans) +C ********************************************************************* +C THIS SUBROUTINE INITIALIZES ALL MATRICES FOR THE IMPLICIT SCHEME. +C ********************************************************************* +C last modified: 02-20-2010 +C + IMPLICIT NONE + INTEGER NCOL,NROW,NLAY,NCOMP,ICOMP,J,I,K,ICBUND,NODES,N,NRC, + & NCRS,NSIZE,L,MIXELM,iSSTrans + REAL CADV,COLD,A,RHS,PRSITY,DTRANS,DZ,RETA,DELR,DELC,TEMP + LOGICAL UPDLHS + DIMENSION ICBUND(NODES,NCOMP),CADV(NODES,NCOMP),COLD(NODES,NCOMP), + & RETA(NODES,NCOMP),PRSITY(NODES),DZ(NODES),DELR(NCOL), + & DELC(NROW),A(*),RHS(NODES) + COMMON /GCGIDX/L(19) +C +C--GET RIGHT-HAND-SIDE ARRAY [RHS] + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + N=(K-1)*NCOL*NROW + (I-1)*NCOL + J + IF(MIXELM.EQ.0) THEN + TEMP=COLD(N,ICOMP) + ELSE + TEMP=CADV(N,ICOMP) + ENDIF + IF(ICBUND(N,ICOMP).LE.0) THEN + RHS(N)=-TEMP + + elseif(iSSTrans.eq.1) then + rhs(n)=0. + + ELSE + RHS(N)=-TEMP*RETA(N,ICOMP)/DTRANS*PRSITY(N) + & *DELR(J)*DELC(I)*DZ(N) + ENDIF + ENDDO + ENDDO + ENDDO +C +C--RETURN IF COEFF MATRIX [A] NOT TO BE UPDATED + IF(.NOT.UPDLHS) GOTO 999 +C +C--RESET COEFF MATRIX [A] +C--IF ALL CROSS TERMS ARE INVOLVED, ARRAY [A] HAS +C--LENGTH OF 19 * NODES + IF(NCRS.EQ.1) THEN + NSIZE=19*NODES +C +C--OTHERWISE IT HAS LENGTH OF 7 * NODES + ELSE + NSIZE=7*NODES + ENDIF +C +C--CLEAR THE ARRAY + DO I=1,NSIZE + A(I)=0. + ENDDO +C +C--LOOP THROUGH ALL CELLS AND RESET A + N=0 + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + N=N+1 +C +C--IF INACTIVE OR CONSTANT CELL + IF(ICBUND(N,ICOMP).LE.0) THEN + A(N)=-1. + + ELSE if(iSSTrans.eq.0) then + + A(N)=-RETA(N,ICOMP)/DTRANS*PRSITY(N) + & *DELR(J)*DELC(I)*DZ(N) + ENDIF + ENDDO + ENDDO + ENDDO +C +C--CALCULATE MATRIX INDICES FOR THE GCG SOLVER + NRC = NROW*NCOL + L(1) = 0 + L(2) = -NRC + L(3) = NRC + L(4) = -NCOL + L(5) = NCOL + L(6) = -1 + L(7) = 1 + L(8) = -NCOL-NRC + L(9) = -1-NRC + L(10)= 1-NRC + L(11)= NCOL-NRC + L(12)=-NCOL+NRC + L(13)=-1+NRC + L(14)= 1+NRC + L(15)= NCOL+NRC + L(16)=-1-NCOL + L(17)= 1-NCOL + L(18)=-1+NCOL + L(19)= 1+NCOL +C +C--NORMAL RETURN + 999 RETURN + END +C +C + LOGICAL FUNCTION UNIFOR(A,NC,NR,NL) +C *************************************************** +C THIS FUNCTION CHECKS WHETHER ELEMENTS IN AN ARRAY +C ARE UNIFORM. +C *************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER NC,NR,NL,J,I,K + REAL A,AI,EPSILON + PARAMETER (EPSILON=0.5E-6) + DIMENSION A(NC,NR,NL) +C +C--GET THE 1ST ELEMENT + AI=A(1,1,1) +C +C--COMPARE REST OF ELEMENTS WITH THE 1ST ELEMENT + DO K=1,NL + DO I=1,NR + DO J=1,NC + IF(ABS(A(J,I,K)-AI).GT.ABS(A(J,I,K)+AI)*EPSILON) THEN + UNIFOR=.FALSE. + RETURN + ENDIF + ENDDO + ENDDO + ENDDO +C +C--IF ALL ELEMENTS ARE EQUAL, SET [UNIFOR] TO T + UNIFOR=.TRUE. + RETURN + END \ No newline at end of file diff --git a/true-binary/mt_dsp5.for b/true-binary/mt_dsp5.for index e69de29..06a12d1 100644 --- a/true-binary/mt_dsp5.for +++ b/true-binary/mt_dsp5.for @@ -0,0 +1,1030 @@ +C + SUBROUTINE DSP5AL(INDSP,IOUT,ISUM,ISUM2,NCOL,NROW,NLAY,MCOMP, + & LCAL,LCTRPT,LCTRPV,LCDM,LCDXX,LCDXY,LCDXZ,LCDYX,LCDYY,LCDYZ, + & LCDZX,LCDZY,LCDZZ) +C ********************************************************************** +C THIS SUBROUTINE ALLOCATES SPACE FOR ARRAYS NEEDED IN THE DISPERSION +C (DSP) PACKAGE. +C ********************************************************************** +C last modified: 02-20-2010 +C + IMPLICIT NONE + INTEGER INDSP,IOUT,ISUM,ISUM2,NCOL,NROW,NLAY,ISOLD,ISOLD2, + & LCDXX,LCDXY,LCDXZ,LCDYX,LCDYY,LCDYZ,LCDZX,LCDZY,LCDZZ, + & LCAL,LCTRPT,LCTRPV,LCDM,NODES,ISUMX,ISUMIX,MCOMP +C +C--PRINT PACKAGE NAME AND VERSION NUMBER + WRITE(IOUT,1030) INDSP + 1030 FORMAT(1X,'DSP5 -- DISPERSION PACKAGE,', + & ' VERSION 5, FEBRUARY 2010, INPUT READ FROM UNIT',I3) +C +C--ALLOCATE SPACE FOR ARRAYS + ISOLD=ISUM + ISOLD2=ISUM2 + NODES=NCOL*NROW*NLAY +C +C--REAL ARRAYS + LCAL=ISUM + ISUM=ISUM+NODES + LCTRPT=ISUM + ISUM=ISUM+NLAY + LCTRPV=ISUM + ISUM=ISUM+NLAY + LCDM=ISUM + ISUM=ISUM + NODES * MCOMP + LCDXX=ISUM + ISUM=ISUM + NODES * MCOMP + LCDXY=ISUM + ISUM=ISUM+NODES + LCDXZ=ISUM + ISUM=ISUM+NODES + LCDYX=ISUM + ISUM=ISUM+NODES + LCDYY=ISUM + ISUM=ISUM + NODES * MCOMP + LCDYZ=ISUM + ISUM=ISUM+NODES + LCDZX=ISUM + ISUM=ISUM+NODES + LCDZY=ISUM + ISUM=ISUM+NODES + LCDZZ=ISUM + ISUM=ISUM + NODES * MCOMP +C +C--CHECK WHETHER ARRAYS X AND IX ARE DIMENSIONED LARGE ENOUGH + ISUMX=ISUM-ISOLD + ISUMIX=ISUM2-ISOLD2 + WRITE(IOUT,1090) ISUMX,ISUMIX + 1090 FORMAT(1X,I10,' ELEMENTS OF THE X ARRAY USED BY THE DSP PACKAGE' + & /1X,I10,' ELEMENTS OF THE IX ARRAY USED BY THE DSP PACKAGE'/) +C +C--NORMAL RETURN + RETURN + END +C +C + SUBROUTINE DSP5RP(IN,IOUT,NCOL,NROW,NLAY,MCOMP,BUFF, + & AL,TRPT,TRPV,DMCOEF) +C ******************************************************************** +C THIS SUBROUTINE READS AND PREPARES INPUT DATA NEEDED BY THE +C DISPERSION (DSP) PACKAGE. +C********************************************************************* +C last modified: 10-30-2006 +C + IMPLICIT NONE + INTEGER IN,IOUT,NCOL,NROW,NLAY,MCOMP,ICOMP,IMSD,J,I,K, + & IFLEN,LLOC,INAM1,INAM2,N + REAL AL,TRPT,TRPV,DMCOEF,BUFF,R + CHARACTER ANAME*24,LINE*200,KEYWORD*200 + DIMENSION AL(NCOL,NROW,NLAY),TRPT(NLAY),TRPV(NLAY), + & DMCOEF(NCOL,NROW,NLAY,MCOMP),BUFF(NCOL*NROW*NLAY) +C +C--PRINT A HEADER + WRITE(IOUT,1000) + 1000 FORMAT(//1X,'DISPERSION INPUT PARAMETERS'/1X,27('-')/) +C +C--READ INPUT KEYWORDS AS A TEXT STRING + 10 READ(IN,'(A)',END=20) LINE + IF(LINE.EQ.' ') GOTO 10 + IF(LINE(1:1).EQ.'#') THEN + WRITE(IOUT,'(A)') LINE + GOTO 10 + ELSEIF(LINE(1:1).EQ.'$') THEN + IMSD=1 + GOTO 30 + ENDIF +C +C--NO KEYWORD LINE, REWIND INPUT FILE + 20 REWIND(IN) + IMSD=0 + GOTO 50 +C +C--DECODE KEYWORD LINE + 30 LLOC=2 + CALL URWORD(LINE,LLOC,INAM1,INAM2,1,N,R,IOUT,IN) + IFLEN=INAM2-INAM1+1 + KEYWORD(1:IFLEN)=LINE(INAM1:INAM2) + IF(KEYWORD(1:IFLEN).EQ.'MULTIDIFFUSION') THEN + WRITE(IOUT,40) KEYWORD(1:IFLEN) + ELSE + WRITE(IOUT,42) + CALL USTOP('ERROR: INVALID DISPERSION PACKAGE INPUT KEYWORDS') + ENDIF + 40 FORMAT(1X,'DISPERSION PACKAGE INPUT KEYWORDS: ',A) + 42 FORMAT(1X,'ERROR: INVALID DISPERSION PACKAGE INPUT KEYWORDS') +C +C--CALL RARRAY TO READ LONGITUDINAL DISPERSIVITY ONE LAYER A TIME + 50 DO K=1,NLAY + ANAME='LONG. DISPERSIVITY (AL)' + CALL RARRAY(AL(1,1,K),ANAME,NROW,NCOL,K,IN,IOUT) + ENDDO +C +C--CALL RARRAY TO READ RATIO OF HORIZONAL TRANSVERSE +C--TO LONGITUDINAL DISPERSIVITY ONE VALUE PER LAYER + ANAME='H. TRANS./LONG. DISP.' + CALL RARRAY(TRPT(1),ANAME,1,NLAY,0,IN,IOUT) +C +C--CALL RARRAY TO READ RATIO OF VERTICAL TRANSVERSE TO +C--LONGITUDINAL DISPERSIVITY ONE VALUE PER LAYER + ANAME='V. TRANS./LONG. DISP.' + CALL RARRAY(TRPV(1),ANAME,1,NLAY,0,IN,IOUT) +C +C--CALL RARRAY TO READ EFFECTIVE MOLECULAR DIFFUSION COEFFICIENT +C--OPTION 1: ONE VALUE PER LAYER FOR ALL CHEMICAL COMPONENTS + IF(IMSD.EQ.0) THEN + ANAME='DIFFUSION COEFFICIENT' + CALL RARRAY(BUFF(1),ANAME,1,NLAY,0,IN,IOUT) + DO ICOMP=1,MCOMP + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + DMCOEF(J,I,K,ICOMP)=BUFF(K) + ENDDO + ENDDO + ENDDO + ENDDO +C--OPTION 2: ONE VALUE PER MODEL CELL PER CHEMICAL COMPONENT + ELSEIF(IMSD.EQ.1) THEN + ANAME='DIFFUSION COEFF. COMP ##' + DO ICOMP=1,MCOMP + WRITE(ANAME(23:24),'(I2.2)') ICOMP + DO K=1,NLAY + CALL RARRAY(DMCOEF(1,1,K,ICOMP),ANAME,NROW,NCOL,K,IN,IOUT) + ENDDO + ENDDO + ENDIF +C +C--RETURN + RETURN + END +C +C + SUBROUTINE DSP5CF(IOUT,KSTP,KPER,NCOL,NROW,NLAY,MCOMP,ICBUND, + & PRSITY,DELR,DELC,DZ,QX,QY,QZ,ALPHAL,TRPT,TRPV,DMCOEF,DTDISP, + & DXX,DXY,DXZ,DYX,DYY,DYZ,DZX,DZY,DZZ,IFMTDP) +C*********************************************************************** +C THIS SUBROUTINE CALCULATES COMPONENTS OF THE HYDRODYNAMIC DISPERSION +C COEFFICIENT (Dij) AT CELL INTERFACES. +C NOTE: Dij IS CALCULATED USING DARCY FLUX COMPONENTS INSTEAD OF +C ==== LINEAR VELOCITY COMPONENTS. TO CONVERT THIS APPARENT Dij TO +C ACTUAL DISPERSION COEFFICIENT, IT IS DIVIDED BY POROSITY. +C*********************************************************************** +C last modified: 10-30-2005 +C + IMPLICIT NONE + INTEGER IOUT,KSTP,KPER,NCOL,NROW,NLAY,K,I,J,ICBUND,KM1,IM1,JM1, + & KP1,IP1,JP1,JD,ID,KD,IFMTDP,MCOMP,ICOMP + REAL DELR,DELC,DZ,QX,QY,QZ,PRSITY,DXX,DXY,DXZ,DYX,DYY,DYZ, + & DZX,DZY,DZZ,V,WW,PF,AL,AT,AV,DM,VX,VY,VZ,ALPHAL, + & TRPT,TRPV,DMCOEF,DTDISP,TD,AREA + CHARACTER TEXT*16 + DIMENSION ICBUND(NCOL,NROW,NLAY),DELR(NCOL),DELC(NROW), + & DZ(NCOL,NROW,NLAY),PRSITY(NCOL,NROW,NLAY), + & ALPHAL(NCOL,NROW,NLAY),TRPT(NLAY),TRPV(NLAY), + & DMCOEF(NCOL,NROW,NLAY,MCOMP), + & QX(NCOL,NROW,NLAY), QY(NCOL,NROW,NLAY), QZ(NCOL,NROW,NLAY), + & DXX(NCOL,NROW,NLAY,MCOMP), + & DXY(NCOL,NROW,NLAY),DXZ(NCOL,NROW,NLAY),DYX(NCOL,NROW,NLAY), + & DYY(NCOL,NROW,NLAY,MCOMP), + & DYZ(NCOL,NROW,NLAY),DZX(NCOL,NROW,NLAY),DZY(NCOL,NROW,NLAY), + & DZZ(NCOL,NROW,NLAY,MCOMP) +C +C--INITIALIZE + DTDISP=1.E30 + KD=0 + ID=0 + JD=0 +C +C--FOR EACH CHEMICAL COMPONENT WITH A DIFFERENT DIFFUSION COEFFICIENT + DO ICOMP=1,MCOMP +C +C--FOR COEFFICIENTS ALONG THE X DIRECTION +C ====================================== + IF(NCOL.LT.2) GOTO 100 +C + DO K=1,NLAY + KP1=MIN(K+1,NLAY) + KM1=MAX(1,K-1) + DO I=1,NROW + IP1=MIN(I+1,NROW) + IM1=MAX(1,I-1) + DO J=1,NCOL + JP1=MIN(J+1,NCOL) + JM1=MAX(1,J-1) + IF(ICBUND(J,I,K).EQ.0.OR.ICBUND(JP1,I,K).EQ.0) CYCLE +C +C--CALCULATE VALUES AT INTERFACES + WW=DELR(JP1)/(DELR(J)+DELR(JP1)) + PF=1. + AL=ALPHAL(J,I,K)*WW+ALPHAL(JP1,I,K)*(1.-WW) + AT=AL*TRPT(K) + AV=AL*TRPV(K) + DM=(DMCOEF(J,I,K,ICOMP)*WW+DMCOEF(JP1,I,K,ICOMP)*(1.-WW)) + & *(PRSITY(J,I,K)*WW+PRSITY(JP1,I,K)*(1.-WW)) + VX=QX(J,I,K) + IF(NROW.GT.1) THEN + VY=0.5*(QY(J,IM1,K)+QY(J,I,K))*WW + & +0.5*(QY(JP1,IM1,K)+QY(JP1,I,K))*(1.-WW) + ELSE + VY=0 + ENDIF + IF(NLAY.GT.1) THEN + VZ=0.5*(QZ(J,I,KM1)+QZ(J,I,K))*WW + & +0.5*(QZ(JP1,I,KM1)+QZ(JP1,I,K))*(1.-WW) + ELSE + VZ=0 + ENDIF + V=SQRT(VX*VX+VY*VY+VZ*VZ) +C +C--CALCULATE DISPERSION COEFFICIENTS + IF(V.EQ.0) THEN + DXX(J,I,K,ICOMP)=DM + IF(NROW.GT.1) DXY(J,I,K)=0 + IF(NLAY.GT.1) DXZ(J,I,K)=0 + ELSE + DXX(J,I,K,ICOMP)= + & AL*VX*VX/V/PF+AT*VY*VY/V/PF+AV*VZ*VZ/V/PF+DM + IF(NROW.GT.1) DXY(J,I,K)=(AL-AT)*VX*VY/V/PF + IF(NLAY.GT.1) DXZ(J,I,K)=(AL-AV)*VX*VZ/V/PF + ENDIF + ENDDO + ENDDO + ENDDO +C +C--FOR COEFFICIENTS ALONG THE Y DIRECTION +C ====================================== + 100 IF(NROW.LT.2) GOTO 200 +C + DO K=1,NLAY + KP1=MIN(K+1,NLAY) + KM1=MAX(1,K-1) + DO J=1,NCOL + JP1=MIN(J+1,NCOL) + JM1=MAX(1,J-1) + DO I=1,NROW + IP1=MIN(I+1,NROW) + IM1=MAX(1,I-1) + IF(ICBUND(J,I,K).EQ.0.OR.ICBUND(J,IP1,K).EQ.0) CYCLE +C +C--CALCULATE VALUES AT INTERFACES + WW=DELC(IP1)/(DELC(I)+DELC(IP1)) + PF=1. + AL=ALPHAL(J,I,K)*WW+ALPHAL(J,IP1,K)*(1.-WW) + AT=AL*TRPT(K) + AV=AL*TRPV(K) + DM=(DMCOEF(J,I,K,ICOMP)*WW+DMCOEF(J,IP1,K,ICOMP)*(1.-WW)) + & *(PRSITY(J,I,K)*WW+PRSITY(J,IP1,K)*(1.-WW)) + VY=QY(J,I,K) + IF(NCOL.GT.1) THEN + VX=0.5*(QX(J,I,K)+QX(JM1,I,K))*WW + & +0.5*(QX(J,IP1,K)+QX(JM1,IP1,K))*(1.-WW) + ELSE + VX=0 + ENDIF + IF(NLAY.GT.1) THEN + VZ=0.5*(QZ(J,I,K)+QZ(J,I,KM1))*WW + & +0.5*(QZ(J,IP1,K)+QZ(J,IP1,KM1))*(1.-WW) + ELSE + VZ=0 + ENDIF + V=SQRT(VX*VX+VY*VY+VZ*VZ) +C +C--CALCULATE DISPERSION COEFFICIENTS + IF(V.EQ.0) THEN + DYY(J,I,K,ICOMP)=DM + IF(NCOL.GT.1) DYX(J,I,K)=0 + IF(NLAY.GT.1) DYZ(J,I,K)=0 + ELSE + DYY(J,I,K,ICOMP)= + & AL*VY*VY/V/PF+AT*VX*VX/V/PF+AV*VZ*VZ/V/PF+DM + IF(NCOL.GT.1) DYX(J,I,K)=(AL-AT)*VY*VX/V/PF + IF(NLAY.GT.1) DYZ(J,I,K)=(AL-AV)*VY*VZ/V/PF + ENDIF + ENDDO + ENDDO + ENDDO +C +C--FOR COEFFICIENTS ALONG THE Z DIRECTION +C ====================================== + 200 IF(NLAY.LT.2) GOTO 300 +C + DO I=1,NROW + IP1=MIN(I+1,NROW) + IM1=MAX(1,I-1) + DO J=1,NCOL + JP1=MIN(J+1,NCOL) + JM1=MAX(1,J-1) + DO K=1,NLAY + KP1=MIN(K+1,NLAY) + KM1=MAX(1,K-1) + IF(ICBUND(J,I,K).EQ.0.OR.ICBUND(J,I,KP1).EQ.0) CYCLE +C +C--CALCULATE VALUES AT INTERFACES + WW=DZ(J,I,KP1)/(DZ(J,I,K)+DZ(J,I,KP1)) + PF=1. + AL=ALPHAL(J,I,K)*WW+ALPHAL(J,I,KP1)*(1.-WW) + AT=ALPHAL(J,I,K)*TRPT(K)*WW+ + & ALPHAL(J,I,KP1)*TRPT(KP1)*(1.-WW) + AV=ALPHAL(J,I,K)*TRPV(K)*WW+ + & ALPHAL(J,I,KP1)*TRPV(KP1)*(1.-WW) + DM=(DMCOEF(J,I,K,ICOMP)*WW+DMCOEF(J,I,KP1,ICOMP)*(1.-WW)) + & *(PRSITY(J,I,K)*WW+PRSITY(J,I,KP1)*(1.-WW)) + VZ=QZ(J,I,K) + IF(NCOL.GT.1) THEN + VX=0.5*(QX(JM1,I,K)+QX(J,I,K))*WW + & +0.5*(QX(JM1,I,KP1)+QX(J,I,KP1))*(1.-WW) + ELSE + VX=0 + ENDIF + IF(NROW.GT.1) THEN + VY=0.5*(QY(J,IM1,K)+QY(J,I,K))*WW + & +0.5*(QY(J,IM1,KP1)+QY(J,I,KP1))*(1.-WW) + ELSE + VY=0 + ENDIF + V=SQRT(VX*VX+VY*VY+VZ*VZ) +C +C--CALCULATE DISPERSION COEFFICIENTS + IF(V.EQ.0) THEN + DZZ(J,I,K,ICOMP)=DM + IF(NCOL.GT.1) DZX(J,I,K)=0 + IF(NROW.GT.1) DZY(J,I,K)=0 + ELSE + DZZ(J,I,K,ICOMP)= + & AL*VZ*VZ/V/PF+AV*VX*VX/V/PF+AV*VY*VY/V/PF+DM + IF(NCOL.GT.1) DZX(J,I,K)=(AL-AV)*VZ*VX/V/PF + IF(NROW.GT.1) DZY(J,I,K)=(AL-AV)*VZ*VY/V/PF + ENDIF + ENDDO + ENDDO + ENDDO +C + 300 CONTINUE +C +C--SET DISPERSION COEFFICIENTS TO ZERO IN INACTIVE CELLS + DO K=1,NLAY + KP1=MIN(K+1,NLAY) + KM1=MAX(1,K-1) + DO I=1,NROW + IP1=MIN(I+1,NROW) + IM1=MAX(1,I-1) + DO J=1,NCOL + JP1=MIN(J+1,NCOL) + JM1=MAX(1,J-1) + IF(ICBUND(J,I,K).NE.0) CYCLE +C + IF(NCOL.GT.1) THEN + DXX(J ,I,K,ICOMP)=0. + DXX(JM1,I,K,ICOMP)=0. + IF(NROW.GT.1) THEN + DXY(J, IM1,K)=0. + DXY(J, I, K)=0. + DXY(J, IP1,K)=0. + DXY(JM1,IM1,K)=0. + DXY(JM1,I, K)=0. + DXY(JM1,IP1,K)=0. + ENDIF + IF(NLAY.GT.1) THEN + DXZ(J, I,KM1)=0. + DXZ(J, I,K )=0. + DXZ(J, I,KP1)=0. + DXZ(JM1,I,KM1)=0. + DXZ(JM1,I,K )=0. + DXZ(JM1,I,KP1)=0. + ENDIF + ENDIF +C + IF(NROW.GT.1) THEN + DYY(J,IM1,K,ICOMP)=0. + DYY(J, I,K,ICOMP)=0. + IF(NCOL.GT.1) THEN + DYX(JM1,I ,K)=0. + DYX(J ,I ,K)=0. + DYX(JP1,I ,K)=0. + DYX(JM1,IM1,K)=0. + DYX(J ,IM1,K)=0. + DYX(JP1,IM1,K)=0. + ENDIF + IF(NLAY.GT.1) THEN + DYZ(J,I ,KM1)=0. + DYZ(J,I ,K )=0. + DYZ(J,I ,KP1)=0. + DYZ(J,IM1,KM1)=0. + DYZ(J,IM1,K )=0. + DYZ(J,IM1,KP1)=0. + ENDIF + ENDIF +C + IF(NLAY.GT.1) THEN + DZZ(J,I,K ,ICOMP)=0. + DZZ(J,I,KM1,ICOMP)=0. + IF(NCOL.GT.1) THEN + DZX(JM1,I,K)=0. + DZX(J ,I,K)=0. + DZX(JP1,I,K)=0. + DZX(JM1,I,KM1)=0. + DZX(J ,I,KM1)=0. + DZX(JP1,I,KM1)=0. + ENDIF + IF(NROW.GT.1) THEN + DZY(J,IM1,K )=0. + DZY(J,I ,K )=0. + DZY(J,IP1,K )=0. + DZY(J,IM1,KM1)=0. + DZY(J,I ,KM1)=0. + DZY(J,IP1,KM1)=0. + ENDIF + ENDIF +C + ENDDO + ENDDO + ENDDO +C +C--CALCULATE MAXIMUM TIME INCREMENT WHICH MEETS STABILITY CRITERION +C--FOR SOLVING THE EXPLICIT FINITE-DIFFERENCE DISPERSION EQUATIONS + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL +C + IF(ICBUND(J,I,K).NE.0) THEN + TD=0. + IF(NCOL.GT.1.AND.J.LT.NCOL) THEN + IF(ICBUND(J+1,I,K).NE.0) + & TD=TD+DXX(J,I,K,ICOMP)/(0.5*DELR(J)+0.5*DELR(J+1))**2 + ENDIF + IF(NROW.GT.1.AND.I.LT.NROW) THEN + IF(ICBUND(J,I+1,K).NE.0) + & TD=TD+DYY(J,I,K,ICOMP)/(0.5*DELC(I)+0.5*DELC(I+1))**2 + ENDIF + IF(NLAY.GT.1.AND.K.LT.NLAY) THEN + IF(ICBUND(J,I,K+1).NE.0) + & TD=TD+DZZ(J,I,K,ICOMP)/(0.5*DZ(J,I,K)+0.5*DZ(J,I,K+1))**2 + ENDIF + IF(TD.GT.0) THEN + TD=0.5/TD*PRSITY(J,I,K) + IF(TD.LT.DTDISP) THEN + DTDISP=TD + JD=J + ID=I + KD=K + ENDIF + ENDIF + ENDIF +C + ENDDO + ENDDO + ENDDO +C +C--PRINT OUT DISPERSION COEFFICIENT IF REQUESTED + IF(IFMTDP.EQ.0) GOTO 980 +C + WRITE(IOUT,510) + 510 FORMAT(/1X,'PRINTED DISPERSION COEFFICIENTS ARE APPARENT Dij', + & ' CALCULATED USING DARCY FLUX RATHER THAN SEEPAGE VELOCITY') +C + IF(NCOL.LT.2) GOTO 920 + TEXT='Dxx^ Comp. # XXX' + WRITE(TEXT(14:16),'(I3.3)') ICOMP + DO K=1,NLAY + CALL RPRINT(DXX(1,1,K,ICOMP),TEXT, + & 0,KSTP,KPER,NCOL,NROW,K,IFMTDP,IOUT) + ENDDO +C + IF(NROW.LT.2.OR.ICOMP.GT.1) GOTO 910 + TEXT='Dxy^ Comp. ALL ' + DO K=1,NLAY + CALL RPRINT(DXY(1,1,K),TEXT, + & 0,KSTP,KPER,NCOL,NROW,K,IFMTDP,IOUT) + ENDDO +C + 910 IF(NLAY.LT.2.OR.ICOMP.GT.1) GOTO 920 + TEXT='Dxz^ Comp. ALL ' + DO K=1,NLAY + CALL RPRINT(DXZ(1,1,K),TEXT, + & 0,KSTP,KPER,NCOL,NROW,K,IFMTDP,IOUT) + ENDDO +C + 920 IF(NROW.LT.2) GOTO 950 + TEXT='Dyy^ Comp. # XXX' + WRITE(TEXT(14:16),'(I3.3)') ICOMP + DO K=1,NLAY + CALL RPRINT(DYY(1,1,K,ICOMP),TEXT, + & 0,KSTP,KPER,NCOL,NROW,K,IFMTDP,IOUT) + ENDDO +C + IF(NCOL.LT.2.OR.ICOMP.GT.1) GOTO 940 + TEXT='Dyx^ Comp. ALL ' + DO K=1,NLAY + CALL RPRINT(DYX(1,1,K),TEXT, + & 0,KSTP,KPER,NCOL,NROW,K,IFMTDP,IOUT) + ENDDO +C + 940 IF(NLAY.LT.2.OR.ICOMP.GT.1) GOTO 950 + TEXT='Dyz^ Comp. ALL ' + DO K=1,NLAY + CALL RPRINT(DYZ(1,1,K),TEXT, + & 0,KSTP,KPER,NCOL,NROW,K,IFMTDP,IOUT) + ENDDO +C + 950 IF(NLAY.LT.2) GOTO 980 + TEXT='Dzz^ Comp. # XXX' + WRITE(TEXT(14:16),'(I3.3)') ICOMP + DO K=1,NLAY + CALL RPRINT(DZZ(1,1,K,ICOMP),TEXT, + & 0,KSTP,KPER,NCOL,NROW,K,IFMTDP,IOUT) + ENDDO +C + IF(NCOL.LT.2.OR.ICOMP.GT.1) GOTO 970 + TEXT='Dzx^ Comp. ALL ' + DO K=1,NLAY + CALL RPRINT(DZX(1,1,K),TEXT, + & 0,KSTP,KPER,NCOL,NROW,K,IFMTDP,IOUT) + ENDDO +C + 970 IF(NROW.LT.2.OR.ICOMP.GT.1) GOTO 980 + TEXT='Dzy^ Comp. ALL ' + DO K=1,NLAY + CALL RPRINT(DZY(1,1,K),TEXT, + & 0,KSTP,KPER,NCOL,NROW,K,IFMTDP,IOUT) + ENDDO +C + 980 CONTINUE +C +C--CONVERT DISPERSION COEFFICIENTS TO DISPERSION CONDUCTANCES + DO K=1,NLAY + KP1=MIN(K+1,NLAY) + KM1=MAX(1,K-1) + DO I=1,NROW + IP1=MIN(I+1,NROW) + IM1=MAX(1,I-1) + DO J=1,NCOL + JP1=MIN(J+1,NCOL) + JM1=MAX(1,J-1) +C + IF(ICBUND(J,I,K).EQ.0) CYCLE +C +C--ALONG THE X-DIRECTION: DXX, DXY AND DXZ + WW=DELR(JP1)/(DELR(J)+DELR(JP1)) + AREA=DELC(I)*(DZ(J,I,K)*WW+DZ(JP1,I,K)*(1.-WW)) + IF(NCOL.GT.1.AND.AREA.GT.0) THEN + DXX(J,I,K,ICOMP)= + & AREA*DXX(J,I,K,ICOMP)/(0.5*DELR(JP1)+0.5*DELR(J)) + IF(NROW.GT.1) THEN + DXY(J,I,K)=AREA*DXY(J,I,K)/ + & (0.5*DELC(IM1)+DELC(I)+0.5*DELC(IP1)) + ENDIF + IF(NLAY.GT.1) THEN + DXZ(J,I,K)=AREA*DXZ(J,I,K)/((0.5*DZ(J,I,KM1) + & +DZ(J,I,K)+0.5*DZ(J,I,KP1))*WW + (0.5*DZ(JP1,I,KM1) + & +DZ(JP1,I,K)+0.5*DZ(JP1,I,KP1))*(1.-WW) ) + ENDIF + ENDIF +C +C--ALONG THE Y-DIRECTION: DYX, DYY AND DYZ + WW=DELC(IP1)/(DELC(I)+DELC(IP1)) + AREA=DELR(J)*(DZ(J,I,K)*WW+DZ(J,IP1,K)*(1.-WW)) + IF(NROW.GT.1.AND.AREA.GT.0) THEN + DYY(J,I,K,ICOMP)= + & AREA*DYY(J,I,K,ICOMP)/(0.5*DELC(IP1)+0.5*DELC(I)) + IF(NCOL.GT.1) THEN + DYX(J,I,K)=AREA*DYX(J,I,K)/ + & (0.5*DELR(JM1)+DELR(J)+0.5*DELR(JP1)) + ENDIF + IF(NLAY.GT.1) THEN + DYZ(J,I,K)=AREA*DYZ(J,I,K)/((0.5*DZ(J,I,KM1) + & +DZ(J,I,K)+0.5*DZ(J,I,KP1))*WW + (0.5*DZ(J,IP1,KM1) + & +DZ(J,IP1,K)+0.5*DZ(J,IP1,KP1))*(1.-WW) ) + ENDIF + ENDIF +C +C--ALONG THE Z DIRECTION: DZX, DZY AND DZZ + AREA=DELR(J)*DELC(I) + IF(NLAY.GT.1.AND.AREA.GT.0) THEN + DZZ(J,I,K,ICOMP)=AREA*DZZ(J,I,K,ICOMP)/ + & (0.5*DZ(J,I,KP1)+0.5*DZ(J,I,K)) + IF(NCOL.GT.1) THEN + DZX(J,I,K)=AREA*DZX(J,I,K)/ + & (0.5*DELR(JM1)+DELR(J)+0.5*DELR(JP1)) + ENDIF + IF(NROW.GT.1) THEN + DZY(J,I,K)=AREA*DZY(J,I,K)/ + & (0.5*DELC(IM1)+DELC(I)+0.5*DELC(IP1)) + ENDIF + ENDIF +C + ENDDO + ENDDO + ENDDO +C + ENDDO !LOOP OVER ALL CHEMICAL COMPONENTS +C +C--PRINT OUT INFORMATION ON DTDISP + WRITE(IOUT,1500) DTDISP,KD,ID,JD + 1500 FORMAT(/1X,'MAXIMUM STEPSIZE WHICH MEETS STABILITY CRITERION', + & ' OF THE DISPERSION TERM'/1X,'=',G11.4, + & '(WHEN MIN. R.F.=1) AT K=',I4,', I=',I4, + & ', J=',I4) +C +C--RETURN + RETURN + END +C +C + SUBROUTINE DSP5FM(NCOL,NROW,NLAY,MCOMP,ICOMP,ICBUND,DELR,DELC,DZ, + & DXX,DXY,DXZ,DYX,DYY,DYZ,DZX,DZY,DZZ,A,NODES,UPDLHS,COLD,RHS,NCRS) +C ********************************************************************** +C THIS SUBROUTINE FORMULATES THE COEFFICIENT MATRIX FOR THE DISPERSION +C TERM USING THE IMPLICIT FINITE-DIFFERENCE SCHEME. +C ********************************************************************** +C last modified: 10-30-2006 +C + IMPLICIT NONE + INTEGER NCOL,NROW,NLAY,K,I,J,KP1,KM1,IP1,IM1,JP1,JM1,ICBUND, + & NODES,N,NCRS,II,L,INDEX,MCOMP,ICOMP + REAL WXP,WXM,WYP,WYM,WZP,WZM,DELR,DELC,DZ,COLD,RHS, + & DXX,DXY,DXZ,DYX,DYY,DYZ,DZX,DZY,DZZ,A,TEMP1,TEMP2,BNDTMP + LOGICAL UPDLHS + DIMENSION ICBUND(NODES,MCOMP),DELR(NCOL),DELC(NROW), + & DZ(NCOL,NROW,NLAY), DXX(NCOL,NROW,NLAY,MCOMP), + & DXY(NCOL,NROW,NLAY),DXZ(NCOL,NROW,NLAY), + & DYX(NCOL,NROW,NLAY),DYY(NCOL,NROW,NLAY,MCOMP), + & DYZ(NCOL,NROW,NLAY),DZX(NCOL,NROW,NLAY), + & DZY(NCOL,NROW,NLAY),DZZ(NCOL,NROW,NLAY,MCOMP), + & COLD(NODES,MCOMP),RHS(NODES),A(NODES,*), + & TEMP1(7),TEMP2(19) + COMMON /GCGIDX/L(19) +C +C--LOOP THROUGH EVERY FINITE DIFFERENCE CELL + DO K=1,NLAY + KP1=MIN(K+1,NLAY) + KM1=MAX(1,K-1) + DO I=1,NROW + IP1=MIN(I+1,NROW) + IM1=MAX(1,I-1) + DO J=1,NCOL + JP1=MIN(J+1,NCOL) + JM1=MAX(1,J-1) +C +C--CALCULATE THE CELL INDEX + N=(K-1)*NCOL*NROW+(I-1)*NCOL+J +C +C--SET TEMP. ARRAYS FOR PRINCIPAL AND CROSS TERMS + DO II=1,7 + TEMP1(II)=0. + ENDDO + DO II=1,19 + TEMP2(II)=0. + ENDDO +C +C--SKIP IF AT CONSTANT-CONCENTRATION OR INACTIVE CELL + IF(ICBUND(N,ICOMP).LE.0) CYCLE +C +C--CALCULATE CELL INTERFACE WEIGHTING FACTORS + WXP=DELR(JP1)/(DELR(J)+DELR(JP1)) + WXM=DELR(J)/(DELR(JM1)+DELR(J)) + IF(J.EQ.1) WXM=1. + WYP=DELC(IP1)/(DELC(I)+DELC(IP1)) + WYM=DELC(I)/(DELC(IM1)+DELC(I)) + IF(I.EQ.1) WYM=1. + WZP=DZ(J,I,KP1)/(DZ(J,I,K)+DZ(J,I,KP1)) + WZM=DZ(J,I,K)/(DZ(J,I,KM1)+DZ(J,I,K)) + IF(K.EQ.1) WZM=1. +C +C--COEF. FOR (J,I,K) + IF(J.GT.1) TEMP1(1)=TEMP1(1)-DXX(JM1,I,K,ICOMP) + IF(I.GT.1) TEMP1(1)=TEMP1(1)-DYY(J,IM1,K,ICOMP) + IF(K.GT.1) TEMP1(1)=TEMP1(1)-DZZ(J,I,KM1,ICOMP) + IF(J.LT.NCOL) TEMP1(1)=TEMP1(1)-DXX(J,I,K,ICOMP) + IF(I.LT.NROW) TEMP1(1)=TEMP1(1)-DYY(J,I,K,ICOMP) + IF(K.LT.NLAY) TEMP1(1)=TEMP1(1)-DZZ(J,I,K,ICOMP) + +C--BOUNDAY CONDITIONS + BNDTMP=-DXY(J,I,K)*WXP+DXY(JM1,I,K)*(1.-WXM) + IF(I.EQ.1) TEMP2(1)=TEMP2(1)+BNDTMP + IF(I.EQ.NROW) TEMP2(1)=TEMP2(1)-BNDTMP + BNDTMP=-DXZ(J,I,K)*WXP+DXZ(JM1,I,K)*(1.-WXM) + IF(K.EQ.1) TEMP2(1)=TEMP2(1)+BNDTMP + IF(K.EQ.NLAY) TEMP2(1)=TEMP2(1)-BNDTMP + BNDTMP=-DYX(J,I,K)*WYP+DYX(J,IM1,K)*(1.-WYM) + IF(J.EQ.1) TEMP2(1)=TEMP2(1)+BNDTMP + IF(J.EQ.NCOL) TEMP2(1)=TEMP2(1)-BNDTMP + BNDTMP=-DYZ(J,I,K)*WYP+DYZ(J,IM1,K)*(1.-WYM) + IF(K.EQ.1) TEMP2(1)=TEMP2(1)+BNDTMP + IF(K.EQ.NLAY) TEMP2(1)=TEMP2(1)-BNDTMP + BNDTMP=-DZX(J,I,K)*WZP+DZX(J,I,KM1)*(1.-WZM) + IF(J.EQ.1) TEMP2(1)=TEMP2(1)+BNDTMP + IF(J.EQ.NCOL) TEMP2(1)=TEMP2(1)-BNDTMP + BNDTMP=-DZY(J,I,K)*WZP+DZY(J,I,KM1)*(1.-WZM) + IF(I.EQ.1) TEMP2(1)=TEMP2(1)+BNDTMP + IF(I.EQ.NROW) TEMP2(1)=TEMP2(1)-BNDTMP +C +C--COEF. FOR (J,I,K-1) + IF(K.GT.1) THEN + TEMP1(2)=DZZ(J,I,KM1,ICOMP) + TEMP2(2)=-DXZ(J,I,K)*WXP+DXZ(JM1,I,K)*(1-WXM) + & -DYZ(J,I,K)*WYP+DYZ(J,IM1,K)*(1-WYM) +C--BOUNDARY CONDITION + IF(J.EQ.1) TEMP2(2)=TEMP2(2)+DZX(J,I,KM1)*WZM + IF(J.EQ.NCOL) TEMP2(2)=TEMP2(2)-DZX(J,I,KM1)*WZM + IF(I.EQ.1) TEMP2(2)=TEMP2(2)+DZY(J,I,KM1)*WZM + IF(I.EQ.NROW) TEMP2(2)=TEMP2(2)-DZY(J,I,KM1)*WZM + ENDIF +C +C--COEF. FOR (J,I,K+1) + IF(K.LT.NLAY) THEN + TEMP1(3)=DZZ(J,I,K,ICOMP) + TEMP2(3)=+DXZ(J,I,K)*WXP-DXZ(JM1,I,K)*(1-WXM) + & +DYZ(J,I,K)*WYP-DYZ(J,IM1,K)*(1-WYM) +C--BOUNDARY CONDITION + IF(J.EQ.1) TEMP2(3)=TEMP2(3)-DZX(J,I,K)*(1-WZP) + IF(J.EQ.NCOL) TEMP2(3)=TEMP2(3)+DZX(J,I,K)*(1-WZP) + IF(I.EQ.1) TEMP2(3)=TEMP2(3)-DZY(J,I,K)*(1-WZP) + IF(I.EQ.NROW) TEMP2(3)=TEMP2(3)+DZY(J,I,K)*(1-WZP) + ENDIF +C +C--COEF. FOR (J,I-1,K) + IF(I.GT.1) THEN + TEMP1(4)=DYY(J,IM1,K,ICOMP) + TEMP2(4)=-DXY(J,I,K)*WXP+DXY(JM1,I,K)*(1-WXM) + & -DZY(J,I,K)*WZP+DZY(J,I,KM1)*(1-WZM) +C--BOUNDARY CONDITION + IF(J.EQ.1) TEMP2(4)=TEMP2(4)+DYX(J,IM1,K)*WYM + IF(J.EQ.NCOL) TEMP2(4)=TEMP2(4)-DYX(J,IM1,K)*WYM + IF(K.EQ.1) TEMP2(4)=TEMP2(4)+DYZ(J,IM1,K)*WYM + IF(K.EQ.NLAY) TEMP2(4)=TEMP2(4)-DYZ(J,IM1,K)*WYM + ENDIF +C +C--COEF. FOR (J,I+1,K) + IF(I.LT.NROW) THEN + TEMP1(5)=DYY(J,I,K,ICOMP) + TEMP2(5)=+DXY(J,I,K)*WXP-DXY(JM1,I,K)*(1-WXM) + & +DZY(J,I,K)*WZP-DZY(J,I,KM1)*(1-WZM) +C--BOUNDARY CONDITION + IF(J.EQ.1) TEMP2(5)=TEMP2(5)-DYX(J,I,K)*(1-WYP) + IF(J.EQ.NCOL) TEMP2(5)=TEMP2(5)+DYX(J,I,K)*(1-WYP) + IF(K.EQ.1) TEMP2(5)=TEMP2(5)-DYZ(J,I,K)*(1-WYP) + IF(K.EQ.NLAY) TEMP2(5)=TEMP2(5)+DYZ(J,I,K)*(1-WYP) + ENDIF +C +C--COEF. FOR (J-1,I,K) + IF(J.GT.1) THEN + TEMP1(6)=DXX(JM1,I,K,ICOMP) + TEMP2(6)=-DYX(J,I,K)*WYP+DYX(J,IM1,K)*(1-WYM) + & -DZX(J,I,K)*WZP+DZX(J,I,KM1)*(1-WZM) +C--BOUNDARY CONDITION + IF(I.EQ.1) TEMP2(6)=TEMP2(6)+DXY(JM1,I,K)*WXM + IF(I.EQ.NROW) TEMP2(6)=TEMP2(6)-DXY(JM1,I,K)*WXM + IF(K.EQ.1) TEMP2(6)=TEMP2(6)+DXZ(JM1,I,K)*WXM + IF(K.EQ.NLAY) TEMP2(6)=TEMP2(6)-DXZ(JM1,I,K)*WXM + ENDIF +C +C--COEF. FOR (J+1,I,K) + IF(J.LT.NCOL) THEN + TEMP1(7)=DXX(J,I,K,ICOMP) + TEMP2(7)=+DYX(J,I,K)*WYP-DYX(J,IM1,K)*(1-WYM) + & +DZX(J,I,K)*WZP-DZX(J,I,KM1)*(1-WZM) +C--BOUNDARY CONDITION + IF(I.EQ.1) TEMP2(7)=TEMP2(7)-DXY(J,I,K)*(1-WXP) + IF(I.EQ.NROW) TEMP2(7)=TEMP2(7)+DXY(J,I,K)*(1-WXP) + IF(K.EQ.1) TEMP2(7)=TEMP2(7)-DXZ(J,I,K)*(1-WXP) + IF(K.EQ.NLAY) TEMP2(7)=TEMP2(7)+DXZ(J,I,K)*(1-WXP) + ENDIF +C +C--COEF. FOR (J,I-1,K-1) + IF(I.GT.1.AND.K.GT.1) + & TEMP2(8)=DYZ(J,IM1,K)*WYM+DZY(J,I,KM1)*WZM +C +C--COEF. FOR (J-1,I,K-1) + IF(J.GT.1.AND.K.GT.1) + & TEMP2(9)=DXZ(JM1,I,K)*WXM+DZX(J,I,KM1)*WZM +C +C--COEF. FOR (J+1,I,K-1) + IF(J.LT.NCOL.AND.K.GT.1) + & TEMP2(10)=-DXZ(J,I,K)*(1-WXP)-DZX(J,I,KM1)*WZM +C +C--COEF. FOR (J,I+1,K-1) + IF(I.LT.NROW.AND.K.GT.1) + & TEMP2(11)=-DYZ(J,I,K)*(1-WYP)-DZY(J,I,KM1)*WZM +C +C--COEF. FOR (J,I-1,K+1) + IF(I.GT.1.AND.K.LT.NLAY) + & TEMP2(12)=-DYZ(J,IM1,K)*WYM-DZY(J,I,K)*(1-WZP) +C +C--COEF. FOR (J-1,I,K+1) + IF(J.GT.1.AND.K.LT.NLAY) + & TEMP2(13)=-DXZ(JM1,I,K)*WXM-DZX(J,I,K)*(1-WZP) +C +C--COEF. FOR (J+1,I,K+1) + IF(J.LT.NCOL.AND.K.LT.NLAY) + & TEMP2(14)=+DXZ(J,I,K)*(1-WXP)+DZX(J,I,K)*(1-WZP) +C +C--COEF. FOR (J,I+1,K+1) + IF(I.LT.NROW.AND.K.LT.NLAY) + & TEMP2(15)=+DYZ(J,I,K)*(1-WYP)+DZY(J,I,K)*(1-WZP) +C +C--COEF. FOR (J-1,I-1,K) + IF(I.GT.1.AND.J.GT.1) + & TEMP2(16)=+DXY(JM1,I,K)*WXM+DYX(J,IM1,K)*WYM +C +C--COEF. FOR (J+1,I-1,K) + IF(I.GT.1.AND.J.LT.NCOL) + & TEMP2(17)=-DXY(J,I,K)*(1-WXP)-DYX(J,IM1,K)*WYM +C +C--COEF. FOR (J-1,I+1,K) + IF(I.LT.NROW.AND.J.GT.1) + & TEMP2(18)=-DXY(JM1,I,K)*WXM-DYX(J,I,K)*(1-WYP) +C +C--COEF. FOR (J+1,I+1,K) + IF(I.LT.NROW.AND.J.LT.NCOL) THEN + TEMP2(19)=+DXY(J,I,K)*(1-WXP)+DYX(J,I,K)*(1-WYP) + ENDIF +C +C--ASSIGN COEF. OF PRINCIPAL DIRECTIONS TO ARRAY [A] OR [RHS] + DO II=1,7 + INDEX=N+L(II) + IF(INDEX.GE.1.AND.INDEX.LE.NODES) THEN +C +C--UPDATE MATRIX A IF NEIGHBOR CELL IS ACTIVE + IF(ICBUND(INDEX,ICOMP).GT.0) THEN + IF(UPDLHS) A(N,II)=A(N,II)+TEMP1(II) +C +C--SHIFT COEF. TO THE RIGHT-HAND-SIDE, OTHERWISE + ELSE + RHS(N)=RHS(N)-TEMP1(II)*COLD(INDEX,ICOMP) + ENDIF + ENDIF + ENDDO +C +C--ASSIGN COEF. OF CROSS TERMS TO ARRAY [A] OR [RHS] + DO II=1,19 + INDEX=N+L(II) + IF(INDEX.GE.1.AND.INDEX.LE.NODES) THEN +C +C--IF CROSS TERMS INCLUDED + IF(NCRS.GT.0.AND.ICBUND(INDEX,ICOMP).GT.0) THEN + IF(UPDLHS) A(N,II)=A(N,II)+TEMP2(II) +C +C--SHIFT CROSSING TERMS TO THE RIGHT-HAND-SIDE, OTHERWISE + ELSE + RHS(N)=RHS(N)-TEMP2(II)*COLD(INDEX,ICOMP) + ENDIF + ENDIF + ENDDO +C + ENDDO + ENDDO + ENDDO +C +C--NORMAL RETURN + RETURN + END +C +C + SUBROUTINE DSP5BD(NCOL,NROW,NLAY,MCOMP,ICOMP,ICBUND,DELR,DELC,DH, + & DXX,DXY,DXZ,DYX,DYY,DYZ,DZX,DZY,DZZ,CNEW,BUFF,DTRANS,RMASIO) +C ********************************************************************** +C THIS SUBROUTINE CALCULATES MASS BUDGET OF CONSTANT-CONCENTRATION NODES +C DUE TO DISPERSION. +C ********************************************************************** +C last modified: 10-30-2006 +C + IMPLICIT NONE + INTEGER NCOL,NROW,NLAY,K,I,J,KP1,KM1,IP1,IM1,JP1,JM1,ICBUND, + & MCOMP,ICOMP + REAL DCFLUX,DTRANS,BUFF,RMASIO,WXP,WXM,WYP,WYM,WZP,WZM,DELR, + & DELC,DH,DXX,DXY,DXZ,DYX,DYY,DYZ,DZX,DZY,DZZ,CNEW + DIMENSION ICBUND(NCOL,NROW,NLAY,MCOMP),DELR(NCOL),DELC(NROW), + & DH(NCOL,NROW,NLAY),CNEW(NCOL,NROW,NLAY,MCOMP), + & DXX(NCOL,NROW,NLAY,MCOMP),DXY(NCOL,NROW,NLAY), + & DXZ(NCOL,NROW,NLAY),DYX(NCOL,NROW,NLAY), + & DYY(NCOL,NROW,NLAY,MCOMP),DYZ(NCOL,NROW,NLAY), + & DZX(NCOL,NROW,NLAY),DZY(NCOL,NROW,NLAY), + & DZZ(NCOL,NROW,NLAY,MCOMP),BUFF(NCOL,NROW,NLAY), + & RMASIO(122,2,MCOMP) +C +C--LOAD CNEW FOR COMPONENT [ICOMP] INTO BUFF + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + BUFF(J,I,K)=CNEW(J,I,K,ICOMP) + ENDDO + ENDDO + ENDDO +C +C--LOOP THROUGH EVERY FINITE DIFFERENCE CELL + DO K=1,NLAY + KP1=MIN(K+1,NLAY) + KM1=MAX(1,K-1) + DO I=1,NROW + IP1=MIN(I+1,NROW) + IM1=MAX(1,I-1) + DO J=1,NCOL + JP1=MIN(J+1,NCOL) + JM1=MAX(1,J-1) +C +C--SKIP IF CELL IS NOT CONSTANT-CONCENTRATION + IF(ICBUND(J,I,K,ICOMP).GE.0) CYCLE +C +C--CALCULATE INTERFACE WEIGHTING FACTORS + WXP=DELR(JP1)/(DELR(J)+DELR(JP1)) + WXM=DELR(J)/(DELR(JM1)+DELR(J)) + WYP=DELC(IP1)/(DELC(I)+DELC(IP1)) + WYM=DELC(I)/(DELC(IM1)+DELC(I)) + WZP=DH(J,I,KP1)/(DH(J,I,K)+DH(J,I,KP1)) + WZM=DH(J,I,K)/(DH(J,I,KM1)+DH(J,I,K)) +C +C--ACCUMULATE ALL COMPONENTS OF THE DISPERSIVE FLUX + DCFLUX=0. +C +C--COMPONENTS ACROSS LEFT AND RIGHT FACES IN THE X-DIRECTION + IF(NCOL.GT.1) THEN + DCFLUX=DCFLUX+DXX(J,I,K,ICOMP)*(BUFF(JP1,I,K)-BUFF(J,I,K)) + & -DXX(JM1,I,K,ICOMP)*(BUFF(J,I,K)-BUFF(JM1,I,K)) + IF(NROW.GT.1) THEN + DCFLUX=DCFLUX+DXY(J,I,K)*(BUFF(JP1,IP1,K)*(1.-WXP) + & +BUFF(J,IP1,K)*WXP + & -BUFF(JP1,IM1,K)*(1.-WXP)-BUFF(J,IM1,K)*WXP) + IF(J.GT.1) THEN + DCFLUX=DCFLUX-DXY(JM1,I,K)*(BUFF(J,IP1,K)*(1.-WXM) + & +BUFF(JM1,IP1,K)*WXM + & -BUFF(J,IM1,K)*(1.-WXM)-BUFF(JM1,IM1,K)*WXM) + ENDIF + ENDIF + IF(NLAY.GT.1) THEN + DCFLUX=DCFLUX+DXZ(J,I,K)*(BUFF(JP1,I,KP1)*(1.-WXP) + & +BUFF(J,I,KP1)*WXP + & -BUFF(JP1,I,KM1)*(1.-WXP)-BUFF(J,I,KM1)*WXP) + IF(J.GT.1) THEN + DCFLUX=DCFLUX-DXZ(JM1,I,K)*(BUFF(J,I,KP1)*(1.-WXM) + & +BUFF(JM1,I,KP1)*WXM + & -BUFF(J,I,KM1)*(1.-WXM)-BUFF(JM1,I,KM1)*WXM) + ENDIF + ENDIF + ENDIF +C +C--COMPONENTS ACROSS BACK AND FRONT FACES IN THE Y-DIRECTION + IF(NROW.GT.1) THEN + DCFLUX=DCFLUX+DYY(J,I,K,ICOMP)*(BUFF(J,IP1,K)-BUFF(J,I,K)) + & -DYY(J,IM1,K,ICOMP)*(BUFF(J,I,K)-BUFF(J,IM1,K)) + IF(NCOL.GT.1) THEN + DCFLUX=DCFLUX+DYX(J,I,K)*(BUFF(JP1,IP1,K)*(1.-WYP) + & +BUFF(JP1,I,K)*WYP + & -BUFF(JM1,IP1,K)*(1.-WYP)-BUFF(JM1,I,K)*WYP) + IF(I.GT.1) THEN + DCFLUX=DCFLUX-DYX(J,IM1,K)*(BUFF(JP1,I,K)*(1.-WYM) + & +BUFF(JP1,IM1,K)*WYM + & -BUFF(JM1,I,K)*(1.-WYM)-BUFF(JM1,IM1,K)*WYM) + ENDIF + ENDIF + IF(NLAY.GT.1) THEN + DCFLUX=DCFLUX+DYZ(J,I,K)*(BUFF(J,IP1,KP1)*(1.-WYP) + & +BUFF(J,I,KP1)*WYP + & -BUFF(J,IP1,KM1)*(1.-WYP)-BUFF(J,I,KM1)*WYP) + IF(I.GT.1) THEN + DCFLUX=DCFLUX-DYZ(J,IM1,K)*(BUFF(J,I,KP1)*(1.-WYM) + & +BUFF(J,IM1,KP1)*WYM + & -BUFF(J,I,KM1)*(1.-WYM)-BUFF(J,IM1,KM1)*WYM) + ENDIF + ENDIF + ENDIF +C +C--COMPONENTS ACROSS UPPER AND LOWER FACES IN THE Z-DIRECTION + IF(NLAY.GT.1) THEN + DCFLUX=DCFLUX+DZZ(J,I,K,ICOMP)*(BUFF(J,I,KP1)-BUFF(J,I,K)) + & -DZZ(J,I,KM1,ICOMP)*(BUFF(J,I,K)-BUFF(J,I,KM1)) + IF(NCOL.GT.1) THEN + DCFLUX=DCFLUX+DZX(J,I,K)*(BUFF(JP1,I,KP1)*(1.-WZP) + & +BUFF(JP1,I,K)*WZP + & -BUFF(JM1,I,KP1)*(1.-WZP)-BUFF(JM1,I,K)*WZP) + IF(K.GT.1) THEN + DCFLUX=DCFLUX-DZX(J,I,KM1)*(BUFF(JP1,I,K)*(1.-WZM) + & +BUFF(JP1,I,KM1)*WZM + & -BUFF(JM1,I,K)*(1.-WZM)-BUFF(JM1,I,KM1)*WZM) + ENDIF + ENDIF + IF(NROW.GT.1) THEN + DCFLUX=DCFLUX+DZY(J,I,K)*(BUFF(J,IP1,KP1)*(1.-WZP) + & +BUFF(J,IP1,K)*WZP + & -BUFF(J,IM1,KP1)*(1.-WZP)-BUFF(J,IM1,K)*WZP) + IF(K.GT.1) THEN + DCFLUX=DCFLUX-DZY(J,I,KM1)*(BUFF(J,IP1,K)*(1.-WZM) + & +BUFF(J,IP1,KM1)*WZM + & -BUFF(J,IM1,K)*(1.-WZM)-BUFF(J,IM1,KM1)*WZM) + ENDIF + ENDIF + ENDIF +C +C--ACCUMULATE MASS IN OR OUT. + IF(DCFLUX.GT.0) THEN + RMASIO(6,2,ICOMP)=RMASIO(6,2,ICOMP)-DCFLUX*DTRANS + ELSE + RMASIO(6,1,ICOMP)=RMASIO(6,1,ICOMP)-DCFLUX*DTRANS + ENDIF +C + ENDDO + ENDDO + ENDDO +C +C--RETURN + RETURN + END \ No newline at end of file diff --git a/true-binary/mt_fmi5.for b/true-binary/mt_fmi5.for index e69de29..19e5d71 100644 --- a/true-binary/mt_fmi5.for +++ b/true-binary/mt_fmi5.for @@ -0,0 +1,1288 @@ +C + SUBROUTINE FMI5AL(INFTL,IOUT,MXTRNOP,iUnitTRNOP,NPERFL,ISS,IVER) +C ********************************************************************** +C THIS SUBROUTINE CHECKS FLOW-TRANSPORT LINK FILE AND ALLOCATES SPACE +C FOR ARRAYS THAT MAY BE NEEDED BY FLOW MODEL-INTERFACE (FMI) PACKAGE. +C ********************************************************************** +C last modified: 02-20-2010 +C + IMPLICIT NONE + INTEGER INFTL,IOUT,MXTRNOP,iUnitTRNOP,NPERFL, + & MTWEL,MTDRN,MTRCH,MTEVT,MTRIV,MTGHB,MTCHD,ISS,IVER, + & IFTLFMT,MTSTR,MTFHB,MTRES,MTTLK,MTIBS,MTLAK, + & MTDRT,MTETS,MTMNW,MTSWT,MTSFR,MTUZF,IERR + CHARACTER VERSION*11 + LOGICAL FWEL,FDRN,FRCH,FEVT,FRIV,FGHB,FSTR,FRES,FFHB,FIBS, + & FTLK,FLAK,FMNW,FDRT,FETS,FSWT,FSFR,FUZF + DIMENSION iUnitTRNOP(MXTRNOP) + COMMON /FC/FWEL,FDRN,FRCH,FEVT,FRIV,FGHB,FSTR,FRES,FFHB,FIBS, + & FTLK,FLAK,FMNW,FDRT,FETS,FSWT,FSFR,FUZF + COMMON /FTL/IFTLFMT + DATA MTWEL,MTDRN,MTRCH,MTEVT,MTRIV,MTGHB,MTCHD,MTSTR, + & MTFHB,MTRES,MTTLK,MTIBS,MTLAK,MTDRT,MTETS,MTMNW, + & MTSWT,MTSFR,MTUZF/19*0/ +C +C--PRINT PACKAGE NAME AND VERSION NUMBER + WRITE(IOUT,1030) INFTL + 1030 FORMAT(1X,'FMI5 -- FLOW MODEL INTERFACE PACKAGE,', + & ' VERSION 5, FEBRUARY 2010, INPUT READ FROM UNIT',I3) +C +C--INITIALIZE + ISS=1 + NPERFL=0 + IVER=2 + VERSION=' ' + FWEL=.FALSE. + FDRN=.FALSE. + FRCH=.FALSE. + FEVT=.FALSE. + FRIV=.FALSE. + FGHB=.FALSE. + FSTR=.FALSE. + FRES=.FALSE. + FFHB=.FALSE. + FIBS=.FALSE. + FTLK=.FALSE. + FLAK=.FALSE. + FMNW=.FALSE. + FDRT=.FALSE. + FETS=.FALSE. + FSWT=.FALSE. + FSFR=.FALSE. + FUZF=.FALSE. +C +C--READ HEADER OF FLOW-TRANSPORT LINK FILE + IF(IFTLFMT.EQ.0) THEN + READ(INFTL,ERR=100,IOSTAT=IERR) VERSION,MTWEL,MTDRN,MTRCH, + & MTEVT,MTRIV,MTGHB,MTCHD,ISS,NPERFL + ELSEIF(IFTLFMT.EQ.1) THEN + READ(INFTL,*,ERR=100,IOSTAT=IERR) VERSION,MTWEL,MTDRN,MTRCH, + & MTEVT,MTRIV,MTGHB,MTCHD,ISS,NPERFL + ENDIF +C + 100 IF(VERSION(1:4).NE.'MT3D'.OR.IERR.NE.0) THEN + GOTO 500 + ELSEIF(VERSION(1:11).EQ.'MT3D4.00.00') THEN + REWIND(INFTL) + IF(IFTLFMT.EQ.0) THEN + READ(INFTL) VERSION,MTWEL,MTDRN,MTRCH,MTEVT, + & MTRIV,MTGHB,MTCHD,ISS,NPERFL, + & MTSTR,MTRES,MTFHB,MTDRT,MTETS,MTTLK,MTIBS,MTLAK,MTMNW, + & MTSWT,MTSFR,MTUZF + ELSEIF(IFTLFMT.EQ.1) THEN + READ(INFTL,*) VERSION,MTWEL,MTDRN,MTRCH,MTEVT, + & MTRIV,MTGHB,MTCHD,ISS,NPERFL, + & MTSTR,MTRES,MTFHB,MTDRT,MTETS,MTTLK,MTIBS,MTLAK,MTMNW, + & MTSWT,MTSFR,MTUZF + ENDIF + ENDIF +C +C--DETERMINE WHICH FLOW COMPONENTS USED IN FLOW MODEL + IF(MTWEL.GT.0) FWEL=.TRUE. + IF(MTDRN.GT.0) FDRN=.TRUE. + IF(MTRCH.GT.0) FRCH=.TRUE. + IF(MTEVT.GT.0) FEVT=.TRUE. + IF(MTRIV.GT.0) FRIV=.TRUE. + IF(MTGHB.GT.0) FGHB=.TRUE. + IF(MTSTR.GT.0) FSTR=.TRUE. + IF(MTRES.GT.0) FRES=.TRUE. + IF(MTFHB.GT.0) FFHB=.TRUE. + IF(MTIBS.GT.0) FIBS=.TRUE. + IF(MTTLK.GT.0) FTLK=.TRUE. + IF(MTLAK.GT.0) FLAK=.TRUE. + IF(MTMNW.GT.0) FMNW=.TRUE. + IF(MTDRT.GT.0) FDRT=.TRUE. + IF(MTETS.GT.0) FETS=.TRUE. + IF(MTSWT.GT.0) FSWT=.TRUE. + IF(MTSFR.GT.0) FSFR=.TRUE. + IF(MTUZF.GT.0) FUZF=.TRUE. +C +C--DETERMINE IF THE SSM PACKAGE IS REQUIRED + 200 IF(iUnitTRNOP(3).EQ.0) THEN + IF(FWEL.OR.FDRN.OR.FRCH.OR.FEVT.OR.FRIV.OR.FGHB.OR. + & FSTR.OR.FRES.OR.FFHB.OR.FIBS.OR.FTLK.OR.FLAK.OR.FMNW.OR. + & FDRT.OR.FETS.OR.FSWT.OR.FSFR.OR.FUZF) THEN + WRITE(*,300) + CALL USTOP(' ') + ELSEIF(MTCHD.GT.0) THEN + WRITE(*,302) + CALL USTOP(' ') + ELSEIF(ISS.EQ.0) THEN + WRITE(*,304) + CALL USTOP(' ') + ENDIF + ENDIF + 300 FORMAT(/1X,'ERROR: THE SSM PACKAGE MUST BE USED', + & ' IN THE CURRENT SIMULATION', + & /1X,'BECAUSE THE FLOW MODEL INCLUDES A SINK/SOURCE PACKAGE.') + 302 FORMAT(/1X,'ERROR: THE SSM PACKAGE MUST BE USED', + & ' IN THE CURRENT SIMULATION', + & /1X,'BECAUSE THE FLOW MODEL CONTAINS CONSTANT-HEAD CELLS.') + 304 FORMAT(/1X,'ERROR: THE SSM PACKAGE MUST BE USED', + & ' IN THE CURRENT SIMULATION', + & /1X,'BECAUSE THE FLOW MODEL IS TRANSIENT.') +C +C--PRINT KEY INFORMATION OF THE FLOW MODEL + IF(ISS.EQ.0) THEN + WRITE(IOUT,310) + ELSE + WRITE(IOUT,320) + ENDIF + IF(MTCHD.GT.0) WRITE(IOUT,330) + WRITE(IOUT,'(1X)') + 310 FORMAT(1X,'FLOW MODEL IS TRANSIENT') + 320 FORMAT(1X,'FLOW MODEL IS STEADY-STATE') + 330 FORMAT(1X,'FLOW MODEL CONTAINS CONSTANT-HEAD CELLS') +C +C--DONE, RETURN + GOTO 1000 +C +C--ERROR READING THE FLOW-TRANSPORT LINK FILE + 500 WRITE(*,600) + WRITE(IOUT,600) + CALL USTOP(' ') + 600 FORMAT(/1X,'Error Reading Flow-Transport Link File', + & ' Possibly Caused by:', + & /1X,'1. Incompatible Styles of Unformatted Files', + & ' Used by MODFLOW and MT3DMS;' + & /1X,'2. Unformatted Flow-Transport Link File Saved by', + & ' Verison 1 of LinkMT3D', + & /1X,' Package Which Is No Longer Supported by MT3DMS.') +C + 1000 RETURN + END +C +C + SUBROUTINE FMI5RP1(INUF,IOUT,KPER,KSTP,NCOL,NROW,NLAY,NCOMP, + & FPRT,LAYCON,ICBUND,HORIGN,DH,PRSITY,DELR,DELC,DZ,XBC,YBC,ZBC, + & QSTO,COLD,CNEW,RETA,QX,QY,QZ,DTRACK,DTRACK2,THKMIN,ISS,IVER) +C ********************************************************************** +C THIS SUBROUTINE READS SATURATED CELL THICKNESS, FLUXES ACROSS CELL +C INTERFACES, AND FLOW RATE TO OR FROM TRANSIENT STORAGE +C FROM AN UNFORMATTED FILE SAVED BY THE FLOW MODEL, AND PREPARES THEM +C IN THE FORMS NEEDED BY THE TRANSPORT MODEL. +C ********************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER INUF,IOUT,NCOL,NROW,NLAY,LAYCON,ICBUND,J,I,K,KPER,KSTP, + & JTRACK,ITRACK,KTRACK,IVER,ISS,NCOMP,INDEX + REAL DH,PRSITY,DELR,DELC,DZ,XBC,YBC,ZBC,HORIGN,QX,QY,QZ,WW, + & WTBL,THKSAT,DTRACK,TK,CNEW,COLD,RETA,CTMP,CREWET,QSTO, + & THKMIN,THKMIN0,DTRACK2 + CHARACTER FPRT*1,TEXT*16 + DIMENSION LAYCON(NLAY),ICBUND(NCOL,NROW,NLAY,NCOMP), + & DH(NCOL,NROW,NLAY), + & DELR(NCOL),DELC(NROW),DZ(NCOL,NROW,NLAY),XBC(NCOL), + & YBC(NROW),ZBC(NCOL,NROW,NLAY),QX(NCOL,NROW,NLAY), + & QY(NCOL,NROW,NLAY),QZ(NCOL,NROW,NLAY), + & PRSITY(NCOL,NROW,NLAY),CNEW(NCOL,NROW,NLAY,NCOMP), + & COLD(NCOL,NROW,NLAY,NCOMP),RETA(NCOL,NROW,NLAY,NCOMP), + & QSTO(NCOL,NROW,NLAY) +C +C--READ SATURATED THICKNESS (UNIT: L). + IF(IVER.EQ.2) THEN + TEXT='THKSAT' + ELSEIF(IVER.EQ.1) THEN + TEXT='HEAD' + ENDIF + CALL READHQ(INUF,IOUT,NCOL,NROW,NLAY,KSTP,KPER,TEXT,DH,FPRT) +C +C--READ RIGHT-FACE FLOW TERMS IF MORE THAN ONE COLUMN (UNIT: L**3/T). + IF(NCOL.LT.2) GOTO 100 + TEXT='QXX' + CALL READHQ(INUF,IOUT,NCOL,NROW,NLAY,KSTP,KPER,TEXT,QX,FPRT) +C +C--READ FRONT-FACE FLOW TERMS IF MORE THAN ONE ROW (UNIT: L**3/T). + 100 IF(NROW.LT.2) GOTO 110 + TEXT='QYY' + CALL READHQ(INUF,IOUT,NCOL,NROW,NLAY,KSTP,KPER,TEXT,QY,FPRT) +C +C--READ LOWER-FACE FLOW TERMS IF MORE THAN ONE LAYER (UNIT: L**3/T). + 110 IF(NLAY.LT.2) GOTO 120 + TEXT='QZZ' + CALL READHQ(INUF,IOUT,NCOL,NROW,NLAY,KSTP,KPER,TEXT,QZ,FPRT) +C +C--READ STORAGE TERM (UNIT: L**3/T). + 120 TEXT='STO' + IF(IVER.EQ.2.AND.ISS.EQ.0) THEN + CALL READHQ(INUF,IOUT,NCOL,NROW,NLAY,KSTP,KPER,TEXT,QSTO,FPRT) + ENDIF +C +C--SET ICBUND=0 IF CELL IS DRY OR INACTIVE (INDICATED BY FLAG 1.E30) +C--AND REACTIVATE DRY CELL IF REWET AND ASSIGN CONC AT REWET CELL + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ABS(DH(J,I,K)-1.E30).LT.1.E-5) THEN + ICBUND(J,I,K,1)=0 + ELSEIF(ICBUND(J,I,K,1).EQ.0.AND.PRSITY(J,I,K).GT.0) THEN + ICBUND(J,I,K,1)=30000 + DO INDEX=1,NCOMP + CTMP=CREWET(NCOL,NROW,NLAY,CNEW(1,1,1,INDEX), + & ICBUND,XBC,YBC,ZBC,J,I,K) + CTMP=(COLD(J,I,K,INDEX)*(RETA(J,I,K,INDEX)-1.0)+CTMP) + & /RETA(J,I,K,INDEX) + CNEW(J,I,K,INDEX)=CTMP + WRITE(IOUT,122) K,I,J,INDEX,CNEW(J,I,K,INDEX) + ENDDO + ENDIF + ENDDO + ENDDO + ENDDO + 122 FORMAT(/1X,'DRY CELL REACTIVATED AT K =',I4,', I=',I4, + & ', J=',I4/1X,'FOR SPECIES ',I3.3, + & ' WITH STARTING CONCENTRATION =',G13.5) +C +C--SET SATURATED THICKNESS [DH] TO LAYER THICKNESS [DZ] +C--FOR CONFINED LAYERS IF THE FLOW-TRANSPORT LINK FILE +C--IS SAVED BY LKMT PACKAGE VERSION 2 OR LATER + IF(IVER.EQ.2) THEN + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K,1).EQ.0) CYCLE + IF(LAYCON(K).EQ.0.OR.INT(DH(J,I,K)).EQ.-111) THEN + DH(J,I,K)=DZ(J,I,K) + ENDIF + ENDDO + ENDDO + ENDDO +C +C--CALCULATE SATURATED THICKNESS FROM INPUT ARRAYS [HTOP] AND [DZ] +C--IF THE FLOW-TRANSPORT LINK FILE IS SAVED BY LKMT PACKAGE VER 1 + ELSEIF(IVER.EQ.1) THEN + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K,1).EQ.0) CYCLE + IF(LAYCON(K).EQ.0) THEN + THKSAT=DZ(J,I,K) + ELSE + WTBL=HORIGN-DH(J,I,K) + THKSAT=ZBC(J,I,K)+0.5*DZ(J,I,K)-WTBL + THKSAT=MIN(THKSAT,DZ(J,I,K)) + ENDIF + DH(J,I,K)=THKSAT + ENDDO + ENDDO + ENDDO + ENDIF +C +C--SET CELLS TO INACTIVE IF SATURATED THICKNESS < OR = 0, OR +C--IF SATURATED THICKNESS IS BELOW USER-SPECIFIED MINIMUM [THKMIN] + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K,1).EQ.0) CYCLE + IF(DH(J,I,K).LE.0) THEN + WRITE(IOUT,355) DH(J,I,K),K,I,J + ICBUND(J,I,K,1)=0 + ELSEIF(THKMIN.GT.0) THEN + THKMIN0=THKMIN*DZ(J,I,K) + IF(DH(J,I,K).LT.THKMIN0) THEN + WRITE(IOUT,365) DH(J,I,K),THKMIN0,K,I,J + ICBUND(J,I,K,1)=0 + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + 355 FORMAT(/1X,'WARNING: SATURATED THICKNESS =',G13.5, + & ' NOT ALLOWED IN TRANSPORT MODEL' + & /10X,'AT ACTIVE CELL K =',I4,', I=',I4,', J=',I4, + & '; RESET AS INACTIVE') + 365 FORMAT(/1X,'WARNING: SATURATED THICKNESS =',G13.5, + & ' BELOW SPECIFIED MINIMUM =',G13.5, + & /10X,'AT ACTIVE CELL K =',I4,', I=',I4,', J=',I4, + & '; RESET AS INACTIVE') +C +C--DETERMINE MAXIMUM TIME INCREMENT DURING WHICH ANY PARTICLE +C--CANNOT MOVE MORE THAN ONE CELL IN ANY DIRECTION. + DTRACK=1.E30 +C + IF(NCOL.LT.2) GOTO 410 + DO K=1,NLAY + DO I=1,NROW + DO J=2,NCOL +C + IF(ICBUND(J,I,K,1).NE.0) THEN + TK=0.5*(QX(J-1,I,K)+QX(J,I,K)) + IF(TK.EQ.0) CYCLE + TK=DELR(J)*DELC(I)*DH(J,I,K)*PRSITY(J,I,K)/TK + IF(ABS(TK).LT.DTRACK) THEN + DTRACK=ABS(TK) + JTRACK=J + ITRACK=I + KTRACK=K + ENDIF + ENDIF +C + ENDDO + ENDDO + ENDDO +C + 410 IF(NROW.LT.2) GOTO 420 + DO K=1,NLAY + DO J=1,NCOL + DO I=2,NROW +C + IF(ICBUND(J,I,K,1).NE.0) THEN + TK=0.5*(QY(J,I-1,K)+QY(J,I,K)) + IF(TK.EQ.0) CYCLE + TK=DELR(J)*DELC(I)*DH(J,I,K)*PRSITY(J,I,K)/TK + IF(ABS(TK).LT.DTRACK) THEN + DTRACK=ABS(TK) + JTRACK=J + ITRACK=I + KTRACK=K + ENDIF + ENDIF +C + ENDDO + ENDDO + ENDDO +C + 420 IF(NLAY.LT.2) GOTO 430 + DO J=1,NCOL + DO I=1,NROW + DO K=2,NLAY +C + IF(ICBUND(J,I,K,1).NE.0) THEN + TK=0.5*(QZ(J,I,K-1)+QZ(J,I,K)) + IF(TK.EQ.0) CYCLE + TK=DELR(J)*DELC(I)*DH(J,I,K)*PRSITY(J,I,K)/TK + IF(ABS(TK).LT.DTRACK) THEN + DTRACK=ABS(TK) + JTRACK=J + ITRACK=I + KTRACK=K + ENDIF + ENDIF +C + ENDDO + ENDDO + ENDDO +C +C--PRINT INFORMATION ON DTRACK + 430 WRITE(IOUT,500) DTRACK,KTRACK,ITRACK,JTRACK + 500 FORMAT(/1X,'MAXIMUM STEPSIZE DURING WHICH ANY PARTICLE CANNOT', + & ' MOVE MORE THAN ONE CELL'/1X,'=',G11.4, + & '(WHEN MIN. R.F.=1) AT K=',I4,', I=',I4, + & ', J=',I4) +C +C--DETERMINE STABILITY CRITERION ASSOCIATED WITH EXPLICIT FINITE +C--DIFFERENCE SOLUTION OF THE ADVECTION TERM + DTRACK2=1.E30 +C + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K,1).EQ.0) CYCLE + TK=0. + IF(J.GT.1) TK=TK+MAX(ABS(QX(J-1,I,K)),ABS(QX(J,I,K))) + IF(I.GT.1) TK=TK+MAX(ABS(QY(J,I-1,K)),ABS(QY(J,I,K))) + IF(K.GT.1) TK=TK+MAX(ABS(QZ(J,I,K-1)),ABS(QZ(J,I,K))) + IF(TK.EQ.0) CYCLE + TK=DELR(J)*DELC(I)*DH(J,I,K)*PRSITY(J,I,K)/TK + IF(TK.LT.DTRACK2) THEN + DTRACK2=TK + JTRACK=J + ITRACK=I + KTRACK=K + ENDIF + ENDDO + ENDDO + ENDDO +C +C--PRINT INFORMATION ON DTRACK2 + WRITE(IOUT,550) DTRACK2,KTRACK,ITRACK,JTRACK + 550 FORMAT(/1X,'MAXIMUM STEPSIZE WHICH MEETS STABILITY CRITERION', + & ' OF THE ADVECTION TERM'/1X, + & '(FOR PURE FINITE-DIFFERENCE OPTION, MIXELM=0) '/1X,'=',G11.4, + & '(WHEN MIN. R.F.=1) AT K=',I4,', I=',I4,', J=',I4) +C +C--DIVIDE VOLUMETRIC QX, QY AND QZ BY AREAS +C--TO GET SPECIFIC DISCHAGES ACROSS EACH CELL INTERFACE + IF(NCOL.LT.2) GOTO 910 + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL-1 + WW=DELR(J+1)/(DELR(J+1)+DELR(J)) + THKSAT=DH(J,I,K)*WW+DH(J+1,I,K)*(1.-WW) + IF(THKSAT.LE.0.OR.ICBUND(J,I,K,1).EQ.0) THEN + QX(J,I,K)=0 + IF(J.GT.1) QX(J-1,I,K)=0. + ELSE + QX(J,I,K)=QX(J,I,K)/(DELC(I)*THKSAT) + ENDIF + ENDDO + IF(ICBUND(NCOL,I,K,1).EQ.0) QX(NCOL-1,I,K)=0. + ENDDO + ENDDO +C + 910 IF(NROW.LT.2) GOTO 920 + DO K=1,NLAY + DO J=1,NCOL + DO I=1,NROW-1 + WW=DELC(I+1)/(DELC(I+1)+DELC(I)) + THKSAT=DH(J,I,K)*WW+DH(J,I+1,K)*(1.-WW) + IF(THKSAT.LE.0.OR.ICBUND(J,I,K,1).EQ.0) THEN + QY(J,I,K)=0 + IF(I.GT.1) QY(J,I-1,K)=0. + ELSE + QY(J,I,K)=QY(J,I,K)/(DELR(J)*THKSAT) + ENDIF + ENDDO + IF(ICBUND(J,NROW,K,1).EQ.0) QY(J,NROW-1,K)=0. + ENDDO + ENDDO +C + 920 IF(NLAY.LT.2) GOTO 990 + DO J=1,NCOL + DO I=1,NROW + DO K=1,NLAY + THKSAT=DH(J,I,K) + IF(THKSAT.LE.0.OR.ICBUND(J,I,K,1).EQ.0) THEN + QZ(J,I,K)=0 + IF(K.GT.1) QZ(J,I,K-1)=0. + ELSE + QZ(J,I,K)=QZ(J,I,K)/(DELR(J)*DELC(I)) + ENDIF + ENDDO + ENDDO + ENDDO +C +C--DIVIDE STORAGE BY CELL VOLUME TO GET DIMENSION (1/TIME) + 990 CONTINUE + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + THKSAT=DH(J,I,K) + IF(THKSAT.LE.0.OR.ICBUND(J,I,K,1).EQ.0) THEN + QSTO(J,I,K)=0 + ELSE + QSTO(J,I,K)=QSTO(J,I,K)/(THKSAT*DELR(J)*DELC(I)) + ENDIF + ENDDO + ENDDO + ENDDO +C +C--SYNCHRONIZE ICBUND CONDITIONS OF ALL SPECIES + IF(NCOMP.EQ.1) GOTO 999 + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + DO INDEX=2,NCOMP + IF(ICBUND(J,I,K,INDEX).GE.0) THEN + ICBUND(J,I,K,INDEX)=IABS(ICBUND(J,I,K,1)) + ELSEIF(ICBUND(J,I,K,1).EQ.0) THEN + ICBUND(J,I,K,INDEX)=0 + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO +C +C--RETURN + 999 RETURN + END +C +C + SUBROUTINE FMI5RP2(INUF,IOUT,KPER,KSTP,NCOL,NROW,NLAY,NCOMP, + & FPRT,LAYCON,ICBUND,DH,PRSITY,DELR,DELC, + & IRCH,RECH,IEVT,EVTR,MXSS,NSS,NTSS,SS,BUFF,DTSSM) +C ********************************************************************** +C THIS SUBROUTINE READS THE LOCATIONS AND FLOW RATES OF SINKS & SOURCES +C FROM AN UNFORMATTED FILE SAVED BY THE FLOW MODEL, AND PREPARES THEM +C IN THE FORMS NEEDED BY THE TRANSPORT MODEL. +C ********************************************************************** +C last modified: 02-20-2010 +C + IMPLICIT NONE + INTEGER INUF,IOUT,NCOL,NROW,NLAY,MXSS,NSS,LAYCON,ICBUND,J,I,K, + & NUM,KPER,KSTP,IRCH,IEVT,NTSS,IQ,KSSM,ISSM,JSSM, + & JJ,II,KK,JM1,JP1,IM1,IP1,KM1,KP1,NCOMP,INDEX + REAL DH,PRSITY,DELR,DELC,SS,BUFF,VOLAQU,EVTR,RECH,DTSSM,TM + LOGICAL FWEL,FDRN,FRCH,FEVT,FRIV,FGHB, + & FSTR,FRES,FFHB,FIBS,FTLK,FLAK,FMNW,FDRT,FETS, + & FSWT,FSFR,FUZF + CHARACTER FPRT*1,TEXT*16 + DIMENSION LAYCON(NLAY),ICBUND(NCOL,NROW,NLAY,NCOMP), + & DH(NCOL,NROW,NLAY), + & DELR(NCOL),DELC(NROW),PRSITY(NCOL,NROW,NLAY), + & IRCH(NCOL,NROW),RECH(NCOL,NROW),IEVT(NCOL,NROW), + & EVTR(NCOL,NROW),SS(7,MXSS),BUFF(NCOL,NROW,NLAY) + COMMON /FC/FWEL,FDRN,FRCH,FEVT,FRIV,FGHB,FSTR,FRES,FFHB, + & FIBS,FTLK,FLAK,FMNW,FDRT,FETS,FSWT,FSFR,FUZF +C +C--RESET TOTAL NUMBER OF POINT SINKS/SOURCES AND CLEAR FLOW RATES + NTSS=NSS + DO NUM=1,NTSS + SS(5,NUM)=0. + ENDDO +C +C--RESET [ICBUND] VALUE AT ACTIVE CELLS TO UNITY + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K,1).GT.0) ICBUND(J,I,K,1)=1 + ENDDO + ENDDO + ENDDO +C +C--READ CONSTANT-HEAD FLOW TERM (UNIT: L**3/T). + TEXT='CNH' + IQ=1 + CALL READPS(INUF,IOUT,NCOL,NROW,NLAY,KSTP,KPER,TEXT, + & BUFF,IQ,MXSS,NTSS,NSS,SS,ICBUND,FPRT) +C +C--READ WELL FLOW TERM (L**3/T) IF WELL OPTION USED IN FLOW MODEL. + IF(FWEL) THEN + TEXT='WEL' + IQ=2 + CALL READPS(INUF,IOUT,NCOL,NROW,NLAY,KSTP,KPER,TEXT, + & BUFF,IQ,MXSS,NTSS,NSS,SS,ICBUND,FPRT) + ENDIF +C +C--READ DRAIN FLOW TERM (L**3/T) IF DRAIN OPTION USED IN FLOW MODEL. + IF(FDRN) THEN + TEXT='DRN' + IQ=3 + CALL READPS(INUF,IOUT,NCOL,NROW,NLAY,KSTP,KPER,TEXT, + & BUFF,IQ,MXSS,NTSS,NSS,SS,ICBUND,FPRT) + ENDIF +C +C--READ RECHARGE FLOW TERM (L**3/T) +C--IF RECHARGE OPTION USED IN FLOW MODEL + IF(FRCH) THEN + TEXT='RCH' + CALL READDS(INUF,IOUT,NCOL,NROW,NLAY,KSTP,KPER,TEXT, + & RECH,IRCH,FPRT) + ENDIF +C +C--READ ET FLOW TERM (L**3/T) IF EVT OPTION USED IN FLOW MODEL + IF(FEVT) THEN + TEXT='EVT' + CALL READDS(INUF,IOUT,NCOL,NROW,NLAY,KSTP,KPER,TEXT, + & EVTR,IEVT,FPRT) + ENDIF +C +C--READ ET FLOW TERM (L**3/T) IF SEGMENTED ET USED IN FLOW MODEL + IF(FETS) THEN + TEXT='ETS' + CALL READDS(INUF,IOUT,NCOL,NROW,NLAY,KSTP,KPER,TEXT, + & EVTR,IEVT,FPRT) + ENDIF +C +C--READ RIVER FLOW TERM (L**3/T) IF RIVER OPTION USED IN FLOW MODEL. + IF(FRIV) THEN + TEXT='RIV' + IQ=4 + CALL READPS(INUF,IOUT,NCOL,NROW,NLAY,KSTP,KPER,TEXT, + & BUFF,IQ,MXSS,NTSS,NSS,SS,ICBUND,FPRT) + ENDIF +C +C--READ GERENAL HEAD DEPENDENT BOUNDARY FLOW TERM (L**3/T) +C--IF GHB OPTION IS USED IN FLOW MODEL. + IF(FGHB) THEN + TEXT='GHB' + IQ=5 + CALL READPS(INUF,IOUT,NCOL,NROW,NLAY,KSTP,KPER,TEXT, + & BUFF,IQ,MXSS,NTSS,NSS,SS,ICBUND,FPRT) + ENDIF +C +C--READ STREAMFLOW-ROUTING FLOW TERM (L**3/T) +C--IF STR OPTION IS USED IN FLOW MODEL. + IF(FSTR) THEN + TEXT='STR' + IQ=21 + CALL READPS(INUF,IOUT,NCOL,NROW,NLAY,KSTP,KPER,TEXT, + & BUFF,IQ,MXSS,NTSS,NSS,SS,ICBUND,FPRT) + ENDIF +C +C--READ RESERVOIR FLOW TERM (L**3/T) +C--IF RES OPTION IS USED IN FLOW MODEL. + IF(FRES) THEN + TEXT='RES' + IQ=22 + CALL READPS(INUF,IOUT,NCOL,NROW,NLAY,KSTP,KPER,TEXT, + & BUFF,IQ,MXSS,NTSS,NSS,SS,ICBUND,FPRT) + ENDIF +C +C--READ SPECIFIED FLOW AND HEAD BOUNDARY FLOW TERM (L**3/T) +C--IF FHB OPTION IS USED IN FLOW MODEL. + IF(FFHB) THEN + TEXT='FHB' + IQ=23 + CALL READPS(INUF,IOUT,NCOL,NROW,NLAY,KSTP,KPER,TEXT, + & BUFF,IQ,MXSS,NTSS,NSS,SS,ICBUND,FPRT) + ENDIF +C +C--READ MULTI-NODE WELL FLOW TERM (L**3/T) +C--IF MNW OPTION IS USED IN FLOW MODEL. + IF(FMNW) THEN + TEXT='MNW' + IQ=27 + CALL READGS(INUF,IOUT,NCOL,NROW,NLAY,KSTP,KPER,TEXT, + & BUFF,IQ,MXSS,NTSS,NSS,SS,ICBUND,FPRT) + ENDIF +C +C--READ DRAIN-RETURN FLOW TERM (L**3/T) +C--IF DRT OPTION IS USED IN FLOW MODEL. + IF(FDRT) THEN + TEXT='DRT' + IQ=28 + CALL READGS(INUF,IOUT,NCOL,NROW,NLAY,KSTP,KPER,TEXT, + & BUFF,IQ,MXSS,NTSS,NSS,SS,ICBUND,FPRT) + ENDIF +C +C--CHECK IF MAXIMUM NUMBER OF POINT SINKS/SOURCES EXCEEDED. +C--IF SO STOP + WRITE(IOUT,801) NTSS + 801 FORMAT(//1X,'TOTAL NUMBER OF POINT SOURCES/SINKS PRESENT', + & ' IN THE FLOW MODEL =',I6) + IF(NTSS.GT.MXSS) THEN + WRITE(*,802) MXSS + 802 FORMAT(/1X,'ERROR: MAXIMUM NUMBER OF SINKS/SOURCES ALLOWED', + & ' [MXSS] =',I6 + & /1X,'INCREASE VALUE OF [MXSS] IN [SSM] PACKAGE INPUT FILE') + CALL USTOP(' ') + ENDIF +C +C--IDENTIFY CELLS IN THE VICINITY OF POINT SINKS OR SOURCES + DO NUM=1,NTSS + K=SS(1,NUM) + I=SS(2,NUM) + J=SS(3,NUM) + KM1=MAX(K-1,1) + KP1=MIN(K+1,NLAY) + DO KK=KM1,KP1 + IM1=MAX(I-1,1) + IP1=MIN(I+1,NROW) + DO II=IM1,IP1 + JM1=MAX(J-1,1) + JP1=MIN(J+1,NCOL) + DO JJ=JM1,JP1 + IF(ICBUND(JJ,II,KK,1).EQ.1) ICBUND(JJ,II,KK,1)=1000 + ENDDO + ENDDO + ENDDO + ENDDO +C +C--DIVIDE RECH, EVTR, Q_SS BY AQUIFER VOLUME +C--TO GET FLUXES OF SINKS/SOURCES PER UNIT AQUIFER VOLUME. +C--ALSO DETERMINE STEPSIZE WHICH MEETS STABILITY CRITERION +C--FOR SOLVING THE SINK/SOURCE TERM WITH EXPLICIT SCHEME. + DTSSM=1.E30 + KSSM=0 + ISSM=0 + JSSM=0 +C + IF(.NOT.FRCH) GOTO 950 + DO I=1,NROW + DO J=1,NCOL + K=IRCH(J,I) + IF(K.EQ.0) CYCLE + VOLAQU=DELR(J)*DELC(I)*DH(J,I,K) + IF(ICBUND(J,I,K,1).EQ.0.OR.VOLAQU.LE.0) THEN + RECH(J,I)=0. + ELSE + RECH(J,I)=RECH(J,I)/VOLAQU + ENDIF + IF(RECH(J,I).LE.0 .OR. ICBUND(J,I,K,1).EQ.0) CYCLE + TM=PRSITY(J,I,K)/RECH(J,I) + IF(ABS(TM).LT.DTSSM) THEN + DTSSM=ABS(TM) + KSSM=K + ISSM=I + JSSM=J + ENDIF + ENDDO + ENDDO +C + 950 IF(.NOT.FEVT .AND. .NOT.FETS) GOTO 960 + DO I=1,NROW + DO J=1,NCOL + K=IEVT(J,I) + IF(K.EQ.0) CYCLE + VOLAQU=DELR(J)*DELC(I)*DH(J,I,K) + IF(ICBUND(J,I,K,1).EQ.0.OR.VOLAQU.LE.0) THEN + EVTR(J,I)=0 + ELSE + EVTR(J,I)=EVTR(J,I)/VOLAQU + ENDIF + IF(EVTR(J,I).EQ.0 .OR. ICBUND(J,I,K,1).EQ.0) CYCLE + TM=PRSITY(J,I,K)/EVTR(J,I) + IF(ABS(TM).LT.DTSSM) THEN + DTSSM=ABS(TM) + KSSM=K + ISSM=I + JSSM=J + ENDIF + ENDDO + ENDDO +C + 960 IF(NTSS.LE.0) GOTO 990 + DO NUM=1,NTSS + K=SS(1,NUM) + I=SS(2,NUM) + J=SS(3,NUM) + VOLAQU=DELR(J)*DELC(I)*DH(J,I,K) + IF(ICBUND(J,I,K,1).EQ.0.OR.VOLAQU.LE.0) THEN + SS(5,NUM)=0 + ELSE + SS(5,NUM)=SS(5,NUM)/VOLAQU + ENDIF + IF(SS(5,NUM).LE.0 .OR. ICBUND(J,I,K,1).EQ.0) CYCLE + TM=PRSITY(J,I,K)/SS(5,NUM) + IF(ABS(TM).LT.DTSSM) THEN + DTSSM=ABS(TM) + KSSM=K + ISSM=I + JSSM=J + ENDIF + ENDDO +C +C--PRINT INFORMATION ON DTSSM + 990 WRITE(IOUT,1000) DTSSM,KSSM,ISSM,JSSM + 1000 FORMAT(/1X,'MAXIMUM STEPSIZE WHICH MEETS STABILITY CRITERION', + & ' OF THE SINK & SOURCE TERM'/1X,'=',G11.4, + & '(WHEN MIN. R.F.=1) AT K=',I4,', I=',I4, + & ', J=',I4) +C +C--SYNCHRONIZE ICBUND CONDITIONS OF ALL SPECIES + IF(NCOMP.EQ.1) GOTO 1999 + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + DO INDEX=2,NCOMP + IF(ICBUND(J,I,K,INDEX).GE.0) THEN + ICBUND(J,I,K,INDEX)=IABS(ICBUND(J,I,K,1)) + ELSEIF(ICBUND(J,I,K,1).EQ.0) THEN + ICBUND(J,I,K,INDEX)=0 + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO +C +C--RETURN + 1999 RETURN + END +C +C + SUBROUTINE READHQ(INUF,IOUT,NCOL,NROW,NLAY,KSTP,KPER,TEXT, + & BUFF,FPRT) +C ***************************************************************** +C THIS SUBROUTINE READS HEADS AND VOLUMETRIC FLUXES ACROSS CELL +C INTERFACES FROM AN UNFORMATTED FILE SAVED BY THE FLOW MODEL. +C ***************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER KSTP,KPER,INUF,NCOL,NROW,NLAY,IOUT,IPRTFM,K,I,J, + & KKSTP,KKPER,NC,NR,NL,IFTLFMT + REAL BUFF + CHARACTER TEXT*16,FPRT*1,LABEL*16 + DIMENSION BUFF(NCOL,NROW,NLAY) + COMMON /FTL/IFTLFMT +C +C--WRITE IDENTIFYING INFORMATION + WRITE(IOUT,1) TEXT,KSTP,KPER,INUF +C +C--READ IDENTIFYING RECORD + IF(IFTLFMT.EQ.0) THEN + READ(INUF) KKPER,KKSTP,NC,NR,NL,LABEL + ELSEIF(IFTLFMT.EQ.1) THEN + READ(INUF,*) KKPER,KKSTP,NC,NR,NL,LABEL + ENDIF +C +C--CHECK INTERFACE + IF(LABEL.NE.TEXT) THEN + WRITE(*,4) TEXT,LABEL + CALL USTOP(' ') + ELSEIF(KKPER.NE.KPER.OR.KKSTP.NE.KSTP) THEN + WRITE(*,3) KKPER,KKSTP + CALL USTOP(' ') + ELSEIF(NC.NE.NCOL.OR.NR.NE.NROW.OR.NL.NE.NLAY) THEN + WRITE(*,2) NC,NR,NL + CALL USTOP(' ') + ENDIF +C +C--READ AN UNFORMATTED RECORD CONTAINING VALUES FOR +C--EACH CELL IN THE GRID + IF(IFTLFMT.EQ.0) THEN + READ(INUF) (((BUFF(J,I,K),J=1,NCOL),I=1,NROW),K=1,NLAY) + ELSEIF(IFTLFMT.EQ.1) THEN + READ(INUF,*) (((BUFF(J,I,K),J=1,NCOL),I=1,NROW),K=1,NLAY) + ENDIF +C +C--PRINT OUT INPUT FOR CHECKING IF REQUESTED + IF(FPRT.NE.'Y'.AND.FPRT.NE.'y') RETURN + IPRTFM=1 + DO K=1,NLAY + WRITE(IOUT,50) K + CALL RPRINT(BUFF(1,1,K),TEXT, + & 0,KSTP,KPER,NCOL,NROW,0,IPRTFM,IOUT) + ENDDO +C +C--PRINT FORMATS + 1 FORMAT(/20X,'"',A16,'" FLOW TERMS FOR TIME STEP',I3, + & ', STRESS PERIOD',I3,' READ UNFORMATTED ON UNIT',I3 + & /20X,92('-')) + 2 FORMAT(1X,'ERROR: INVALID NUMBER OF COLUMNS, ROWS OR LAYERS', + & ' IN FLOW-TRANSPORT LINK FILE.' + & /1X,'NUMBER OF COLUMNS IN FLOW-TRANSPORT LINK FILE =',I5 + & /1X,'NUMBER OF ROWS IN FLOW-TRANSPORT LINK FILE =',I5, + & /1X,'NUMBER OF LAYERS FLOW-TRANSPORT LINK FILE =',I5) + 3 FORMAT(/1X,'ERROR: INVALID NUMBER OF STRESS PERIOD OR TIME STEP', + & ' IN FLOW-TRANSPORT LINK FILE.' + & /1X,'NUMBER OF STRESS PERIOD IN FLOW-TRANSPORT LINK FILE =',I3, + & /1X,'NUMBER OF TIME STEP IN FLOW-TRANSPORT LINK FILE =',I3) + 4 FORMAT(/1X,'ERROR READING FLOW-TRANSPORT LINK FILE.'/1X, + & 'NAME OF THE FLOW TERM REQUIRED =',A16/1X, + & 'NAME OF THE FLOW TERM SAVED IN FLOW-TRANSPORT LINK FILE =',A16) + 10 FORMAT(/44X,'LAYER LOCATION OF ',A16,'FLOW TERM' + & /44X,43('-')) + 50 FORMAT(/61X,'LAYER ',I3) +C +C--RETURN + RETURN + END +C +C + SUBROUTINE READDS(INUF,IOUT,NCOL,NROW,NLAY,KSTP,KPER,TEXT, + & BUFF,LOCLAY,FPRT) +C ***************************************************************** +C THIS SUBROUTINE READS LOCATIONS AND FLOW RATES OF DIFFUSIVE +C SINK/SOURCE TERMS (RECHARGE AND EVAPOTRANSPIRATION) FROM AN +C UNFORMATTED FILE SAVED BY THE FLOW MODEL. +C ***************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER KSTP,KPER,INUF,NCOL,NROW,NLAY,IOUT,IPRTFM,I,J, + & KKSTP,KKPER,NC,NR,NL,LOCLAY,IFTLFMT + REAL BUFF + CHARACTER TEXT*16,FPRT*1,LABEL*16 + DIMENSION BUFF(NCOL,NROW),LOCLAY(NCOL,NROW) + COMMON /FTL/IFTLFMT +C +C--WRITE IDENTIFYING INFORMATION + WRITE(IOUT,1) TEXT,KSTP,KPER,INUF +C +C--READ IDENTIFYING RECORD + IF(IFTLFMT.EQ.0) THEN + READ(INUF) KKPER,KKSTP,NC,NR,NL,LABEL + ELSEIF(IFTLFMT.EQ.1) THEN + READ(INUF,*) KKPER,KKSTP,NC,NR,NL,LABEL + ENDIF +C +C--CHECK INTERFACE + IF(LABEL.NE.TEXT) THEN + WRITE(*,4) TEXT,LABEL + CALL USTOP(' ') + ELSEIF(KKPER.NE.KPER.OR.KKSTP.NE.KSTP) THEN + WRITE(*,3) KKPER,KKSTP + CALL USTOP(' ') + ELSEIF(NC.NE.NCOL.OR.NR.NE.NROW.OR.NL.NE.NLAY) THEN + WRITE(*,2) NC,NR,NL + CALL USTOP(' ') + ENDIF +C +C--READ LAYER LOCATION IF FLOW TERM IS RECHARGE OR E.T. + IF(IFTLFMT.EQ.0) THEN + READ(INUF) ((LOCLAY(J,I),J=1,NCOL),I=1,NROW) + ELSEIF(IFTLFMT.EQ.1) THEN + READ(INUF,*) ((LOCLAY(J,I),J=1,NCOL),I=1,NROW) + ENDIF +C +C--READ AN UNFORMATTED RECORD CONTAINING VALUES FOR +C--EACH CELL IN THE GRID + IF(IFTLFMT.EQ.0) THEN + READ(INUF) ((BUFF(J,I),J=1,NCOL),I=1,NROW) + ELSEIF(IFTLFMT.EQ.1) THEN + READ(INUF,*) ((BUFF(J,I),J=1,NCOL),I=1,NROW) + ENDIF +C +C--PRINT OUT INPUT FOR CHECKING IF REQUESTED + IF(FPRT.NE.'Y'.AND.FPRT.NE.'y') RETURN + IPRTFM=1 + CALL RPRINT(BUFF(1,1),TEXT, + & 0,KSTP,KPER,NCOL,NROW,0,IPRTFM,IOUT) + IPRTFM=3 + WRITE(IOUT,10) + CALL IPRINT(LOCLAY(1,1),TEXT,0,KSTP,KPER,NCOL,NROW, + & 0,IPRTFM,IOUT) +C +C--PRINT FORMATS + 1 FORMAT(/20X,'"',A16,'" FLOW TERMS FOR TIME STEP',I3, + & ', STRESS PERIOD',I3,' READ UNFORMATTED ON UNIT',I3 + & /20X,92('-')) + 2 FORMAT(1X,'ERROR: INVALID NUMBER OF COLUMNS, ROWS OR LAYERS', + & ' IN FLOW-TRANSPORT LINK FILE.' + & /1X,'NUMBER OF COLUMNS IN FLOW-TRANSPORT LINK FILE =',I5 + & /1X,'NUMBER OF ROWS IN FLOW-TRANSPORT LINK FILE =',I5, + & /1X,'NUMBER OF LAYERS FLOW-TRANSPORT LINK FILE =',I5) + 3 FORMAT(/1X,'ERROR: INVALID NUMBER OF STRESS PERIOD OR TIME STEP', + & ' IN FLOW-TRANSPORT LINK FILE.' + & /1X,'NUMBER OF STRESS PERIOD IN FLOW-TRANSPORT LINK FILE =',I3, + & /1X,'NUMBER OF TIME STEP IN FLOW-TRANSPORT LINK FILE =',I3) + 4 FORMAT(/1X,'ERROR READING FLOW-TRANSPORT LINK FILE.'/1X, + & 'NAME OF THE FLOW TERM REQUIRED =',A16/1X, + & 'NAME OF THE FLOW TERM SAVED IN FLOW-TRANSPORT LINK FILE =',A16) + 10 FORMAT(/60X,'LAYER INDEX') +C +C--RETURN + RETURN + END +C +C + SUBROUTINE READPS(INUF,IOUT,NCOL,NROW,NLAY,KSTP,KPER,TEXT, + & BUFF,IQ,MXSS,NTSS,NSS,SS,ICBUND,FPRT) +C ********************************************************************* +C THIS SUBROUTINE READS LOCATIONS AND FLOW RATES OF POINT SINK/SOURCE +C FLOW TERMS FROM AN UNFORMATTED FILE SAVED BY THE FLOW MODEL. +C ********************************************************************* +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER KSTP,KPER,INUF,NCOL,NROW,NLAY,IOUT,K,I,J,KKSTP,KKPER, + & NC,NR,NL,NUM,N,MXSS,NTSS,NSS,ICBUND,IQ,ID,IFTLFMT, + & KKK,III,JJJ,ITEMP + REAL BUFF,SS,QSS,QSTEMP + CHARACTER TEXT*16,FPRT*1,LABEL*16 + DIMENSION BUFF(NCOL,NROW,NLAY),ICBUND(NCOL,NROW,NLAY),SS(7,MXSS) + COMMON /FTL/IFTLFMT +C +C--WRITE IDENTIFYING INFORMATION + WRITE(IOUT,1) TEXT,KSTP,KPER,INUF +C +C--READ IDENTIFYING RECORD + IF(IFTLFMT.EQ.0) THEN + READ(INUF) KKPER,KKSTP,NC,NR,NL,LABEL,NUM + ELSEIF(IFTLFMT.EQ.1) THEN + READ(INUF,*) KKPER,KKSTP,NC,NR,NL,LABEL,NUM + ENDIF +C +C--CHECK INTERFACE + IF(LABEL.NE.TEXT) THEN + WRITE(*,4) TEXT,LABEL + CALL USTOP(' ') + ELSEIF(KKPER.NE.KPER.OR.KKSTP.NE.KSTP) THEN + WRITE(*,3) KKPER,KKSTP + CALL USTOP(' ') + ELSEIF(NC.NE.NCOL.OR.NR.NE.NROW.OR.NL.NE.NLAY) THEN + WRITE(*,2) NC,NR,NL + CALL USTOP(' ') + ENDIF +C +C--RETURN IF NUM=0 + IF(NUM.LE.0) RETURN +C +C--READ AN UNFORMATTED RECORD CONTAINING VALUES FOR +C--EACH POINT SINK OR SOURCE + DO N=1,NUM + IF(IFTLFMT.EQ.0) THEN + READ(INUF) K,I,J,QSTEMP + ELSEIF(IFTLFMT.EQ.1) THEN + READ(INUF,*) K,I,J,QSTEMP + ENDIF + IF(FPRT.EQ.'Y'.OR.FPRT.EQ.'y') + & WRITE(IOUT,50) K,I,J,QSTEMP +C +C--IF ALREADY DEFINED AS A SOURCE OF USER-SPECIFIED CONCENTRATION, +C--STORE FLOW RATE QSTEMP + DO ITEMP=1,NSS + KKK=SS(1,ITEMP) + III=SS(2,ITEMP) + JJJ=SS(3,ITEMP) + QSS=SS(5,ITEMP) + ID =SS(6,ITEMP) + IF(KKK.NE.K.OR.III.NE.I.OR.JJJ.NE.J.OR.ID.NE.IQ) CYCLE + IF(ABS(QSS).GT.0) CYCLE + SS(5,ITEMP)=QSTEMP + SS(7,ITEMP)=0 +C +C--MARK CELLS NEAR THE SINK/SOURCE + IF(QSTEMP.LT.0 .AND. ICBUND(J,I,K).GT.0) THEN + ICBUND(J,I,K)=1000+IQ + ELSEIF(ICBUND(J,I,K).GT.0 ) THEN + ICBUND(J,I,K)=1020+IQ + ENDIF + GOTO 100 + ENDDO +C +C--OTHERWISE, ADD TO THE SS ARRAY + NTSS=NTSS+1 + IF(NTSS.GT.MXSS) CYCLE + SS(1,NTSS)=K + SS(2,NTSS)=I + SS(3,NTSS)=J + SS(4,NTSS)=0. + SS(5,NTSS)=QSTEMP + SS(6,NTSS)=IQ + SS(7,NTSS)=0. + IF(QSTEMP.LT.0 .AND. ICBUND(J,I,K).GT.0) THEN + ICBUND(J,I,K)=1000+IQ + ELSEIF(ICBUND(J,I,K).GT.0) THEN + ICBUND(J,I,K)=1020+IQ + ENDIF + 100 CONTINUE + ENDDO +C +C--PRINT FORMATS + 1 FORMAT(/20X,'"',A16,'" FLOW TERMS FOR TIME STEP',I3, + & ', STRESS PERIOD',I3,' READ UNFORMATTED ON UNIT',I3 + & /20X,92('-')) + 2 FORMAT(1X,'ERROR: INVALID NUMBER OF COLUMNS, ROWS OR LAYERS', + & ' IN FLOW-TRANSPORT LINK FILE.' + & /1X,'NUMBER OF COLUMNS IN FLOW-TRANSPORT LINK FILE =',I5 + & /1X,'NUMBER OF ROWS IN FLOW-TRANSPORT LINK FILE =',I5, + & /1X,'NUMBER OF LAYERS FLOW-TRANSPORT LINK FILE =',I5) + 3 FORMAT(/1X,'ERROR: INVALID NUMBER OF STRESS PERIOD OR TIME STEP', + & ' IN FLOW-TRANSPORT LINK FILE.' + & /1X,'NUMBER OF STRESS PERIOD IN FLOW-TRANSPORT LINK FILE =',I3, + & /1X,'NUMBER OF TIME STEP IN FLOW-TRANSPORT LINK FILE =',I3) + 4 FORMAT(/1X,'ERROR READING FLOW-TRANSPORT LINK FILE'/1X, + & 'NAME OF THE FLOW TERM REQUIRED =',A16/1X, + & 'NAME OF THE FLOW TERM SAVED IN FLOW-TRANSPORT LINK FILE =',A16) + 50 FORMAT(1X,'LAYER',I5,5X,'ROW',I5,5X,'COLUMN',I5,5X,'RATE',G15.7) +C +C--RETURN + RETURN + END +C +C + SUBROUTINE READGS(INUF,IOUT,NCOL,NROW,NLAY,KSTP,KPER,TEXT, + & BUFF,IQ,MXSS,NTSS,NSS,SS,ICBUND,FPRT) +C ********************************************************************* +C THIS SUBROUTINE READS LOCATIONS AND FLOW RATES OF SINK/SOURCE GROUPS +C THAT ARE CONNECTED FROM THE FLOW-TRANSPORT LINK FILE +C ********************************************************************* +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER KSTP,KPER,INUF,NCOL,NROW,NLAY,IOUT,K,I,J,KKSTP,KKPER, + & NC,NR,NL,NUM,N,MXSS,NTSS,NSS,ICBUND,IQ,ID,IFTLFMT, + & KKK,III,JJJ,ITEMP,IGROUP + REAL BUFF,SS,QSS,QSTEMP,QSW + CHARACTER TEXT*16,FPRT*1,LABEL*16 + DIMENSION BUFF(NCOL,NROW,NLAY),ICBUND(NCOL,NROW,NLAY),SS(7,MXSS) + COMMON /FTL/IFTLFMT +C +C--WRITE IDENTIFYING INFORMATION + WRITE(IOUT,1) TEXT,KSTP,KPER,INUF +C +C--READ IDENTIFYING RECORD + IF(IFTLFMT.EQ.0) THEN + READ(INUF) KKPER,KKSTP,NC,NR,NL,LABEL,NUM + ELSEIF(IFTLFMT.EQ.1) THEN + READ(INUF,*) KKPER,KKSTP,NC,NR,NL,LABEL,NUM + ENDIF +C +C--CHECK INTERFACE + IF(LABEL.NE.TEXT) THEN + WRITE(*,4) TEXT,LABEL + CALL USTOP(' ') + ELSEIF(KKPER.NE.KPER.OR.KKSTP.NE.KSTP) THEN + WRITE(*,3) KKPER,KKSTP + CALL USTOP(' ') + ELSEIF(NC.NE.NCOL.OR.NR.NE.NROW.OR.NL.NE.NLAY) THEN + WRITE(*,2) NC,NR,NL + CALL USTOP(' ') + ENDIF +C +C--RETURN IF NUM=0 + IF(NUM.LE.0) RETURN +C +C--READ AN UNFORMATTED RECORD CONTAINING VALUES FOR +C--EACH POINT SINK OR SOURCE + DO N=1,NUM + IF(IFTLFMT.EQ.0) THEN + READ(INUF) K,I,J,QSTEMP,IGROUP,QSW + ELSEIF(IFTLFMT.EQ.1) THEN + READ(INUF,*) K,I,J,QSTEMP,IGROUP,QSW + ENDIF + IF(FPRT.EQ.'Y'.OR.FPRT.EQ.'y') + & WRITE(IOUT,50) K,I,J,QSTEMP,IGROUP,QSW +C +C--IF ALREADY DEFINED AS A SOURCE OF USER-SPECIFIED CONCENTRATION, +C--STORE FLOW RATE QSTEMP + DO ITEMP=1,NSS + KKK=SS(1,ITEMP) + III=SS(2,ITEMP) + JJJ=SS(3,ITEMP) + QSS=SS(5,ITEMP) + ID =SS(6,ITEMP) + IF(KKK.NE.K.OR.III.NE.I.OR.JJJ.NE.J.OR.ID.NE.IQ) CYCLE + IF(ABS(QSS).GT.0) CYCLE + SS(5,ITEMP)=QSTEMP + SS(7,ITEMP)=IGROUP +C +C--MAKR CELLS NEAR THE SINK/SOURCE + IF(QSTEMP.LT.0 .AND. ICBUND(J,I,K).GT.0 ) THEN + ICBUND(J,I,K)=1000+IQ + ELSEIF(ICBUND(J,I,K).GT.0) THEN + ICBUND(J,I,K)=1020+IQ + ENDIF + GOTO 100 + ENDDO +C +C--OTHERWISE, ADD TO THE SS ARRAY + NTSS=NTSS+1 + IF(NTSS.GT.MXSS) CYCLE + SS(1,NTSS)=K + SS(2,NTSS)=I + SS(3,NTSS)=J + SS(4,NTSS)=0. + SS(5,NTSS)=QSTEMP + SS(6,NTSS)=IQ + SS(7,NTSS)=IGROUP + IF(QSTEMP.LT.0 .AND. ICBUND(J,I,K).GT.0) THEN + ICBUND(J,I,K)=1000+IQ + ELSEIF(ICBUND(J,I,K).GT.0) THEN + ICBUND(J,I,K)=1020+IQ + ENDIF + 100 CONTINUE + ENDDO +C +C--PRINT FORMATS + 1 FORMAT(/20X,'"',A16,'" FLOW TERMS FOR TIME STEP',I3, + & ', STRESS PERIOD',I3,' READ UNFORMATTED ON UNIT',I3 + & /20X,92('-')) + 2 FORMAT(1X,'ERROR: INVALID NUMBER OF COLUMNS, ROWS OR LAYERS', + & ' IN FLOW-TRANSPORT LINK FILE.' + & /1X,'NUMBER OF COLUMNS IN FLOW-TRANSPORT LINK FILE =',I5 + & /1X,'NUMBER OF ROWS IN FLOW-TRANSPORT LINK FILE =',I5, + & /1X,'NUMBER OF LAYERS FLOW-TRANSPORT LINK FILE =',I5) + 3 FORMAT(/1X,'ERROR: INVALID NUMBER OF STRESS PERIOD OR TIME STEP', + & ' IN FLOW-TRANSPORT LINK FILE.' + & /1X,'NUMBER OF STRESS PERIOD IN FLOW-TRANSPORT LINK FILE =',I3, + & /1X,'NUMBER OF TIME STEP IN FLOW-TRANSPORT LINK FILE =',I3) + 4 FORMAT(/1X,'ERROR READING FLOW-TRANSPORT LINK FILE'/1X, + & 'NAME OF THE FLOW TERM REQUIRED =',A16/1X, + & 'NAME OF THE FLOW TERM SAVED IN FLOW-TRANSPORT LINK FILE =',A16) + 50 FORMAT(1X,'LAYER',I5,5X,'ROW',I5,5X,'COLUMN',I5,5X,'RATE',G15.7, + & ' SS CODE',I5,5X,'EXTERNAL FLOW',G15.7) +C +C--RETURN + RETURN + END +C +C + FUNCTION CREWET(NCOL,NROW,NLAY,CNEW,ICBUND,XBC,YBC,ZBC, + & JJ,II,KK) +C ***************************************************************** +C THIS FUNCTION OBTAINS CONCENTRATION AT A REWET CELL (JJ,II,KK) +C FROM CONCENTRATIONS AT NEIGHBORING NODES WITH INVERSE DISTANCE +C (POWER 2) WEIGHTING . +C ***************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER NCOL,NROW,NLAY,ICBUND,JJ,II,KK + REAL XBC,YBC,ZBC,CTMP,CNEW,CREWET,D2,D2SUM + DIMENSION ICBUND(NCOL,NROW,NLAY),CNEW(NCOL,NROW,NLAY), + & XBC(NCOL),YBC(NROW),ZBC(NCOL,NROW,NLAY) +C +C--INITIALIZE + D2SUM=0 + CTMP=0 +C +C--ACCUMULATE CONCENTRATIONS AT NEIGHBORING NODELS +C--IN THE LAYER DIRECTION + IF(NLAY.EQ.1) GOTO 10 + IF(KK-1.GT.0) THEN + IF(ICBUND(JJ,II,KK-1).NE.0) THEN + D2=(ZBC(JJ,II,KK)-ZBC(JJ,II,KK-1))**2 + IF(D2.NE.0) THEN + D2SUM=D2SUM+1./D2 + CTMP=CTMP+CNEW(JJ,II,KK-1)/D2 + ELSE + CTMP=CNEW(JJ,II,KK-1) + GOTO 100 + ENDIF + ENDIF + ENDIF + IF(KK+1.LE.NLAY) THEN + IF(ICBUND(JJ,II,KK+1).NE.0) THEN + D2=(ZBC(JJ,II,KK)-ZBC(JJ,II,KK+1))**2 + IF(D2.NE.0) THEN + D2SUM=D2SUM+1./D2 + CTMP=CTMP+CNEW(JJ,II,KK+1)/D2 + ELSE + CTMP=CNEW(JJ,II,KK+1) + GOTO 100 + ENDIF + ENDIF + ENDIF +C +C--IN THE ROW DIRECTION + 10 IF(NROW.EQ.1) GOTO 20 + IF(II-1.GT.0) THEN + IF(ICBUND(JJ,II-1,KK).NE.0) THEN + D2=(YBC(II)-YBC(II-1))**2 + IF(D2.NE.0) THEN + D2SUM=D2SUM+1./D2 + CTMP=CTMP+CNEW(JJ,II-1,KK)/D2 + ELSE + CTMP=CNEW(JJ,II-1,KK) + GOTO 100 + ENDIF + ENDIF + ENDIF + IF(II+1.LE.NROW) THEN + IF(ICBUND(JJ,II+1,KK).NE.0) THEN + D2=(YBC(II)-YBC(II+1))**2 + IF(D2.NE.0) THEN + D2SUM=D2SUM+1./D2 + CTMP=CTMP+CNEW(JJ,II+1,KK)/D2 + ELSE + CTMP=CNEW(JJ,II+1,KK) + GOTO 100 + ENDIF + ENDIF + ENDIF +C +C--IN THE COLUMN DIRECTION + 20 IF(NCOL.EQ.1) GOTO 30 + IF(JJ-1.GT.0) THEN + IF(ICBUND(JJ-1,II,KK).NE.0) THEN + D2=(XBC(JJ)-XBC(JJ-1))**2 + IF(D2.NE.0) THEN + D2SUM=D2SUM+1./D2 + CTMP=CTMP+CNEW(JJ-1,II,KK)/D2 + ELSE + CTMP=CNEW(JJ-1,II,KK) + GOTO 100 + ENDIF + ENDIF + ENDIF + IF(JJ+1.LE.NCOL) THEN + IF(ICBUND(JJ+1,II,KK).NE.0) THEN + D2=(XBC(JJ)-XBC(JJ+1))**2 + IF(D2.NE.0) THEN + D2SUM=D2SUM+1./D2 + CTMP=CTMP+CNEW(JJ+1,II,KK)/D2 + ELSE + CTMP=CNEW(JJ+1,II,KK) + GOTO 100 + ENDIF + ENDIF + ENDIF +C +C--OBTAIN WEIGHTED CONCENTRATION + 30 IF(D2SUM.EQ.0) THEN + ICBUND(JJ,II,KK)=0 + ELSE + CTMP=CTMP/D2SUM + ENDIF +C +C--ASSIGN WEIGHTED CONCENTRATION TO CREWET + 100 CREWET=CTMP +C +C--NORMAL RETURN + RETURN + END \ No newline at end of file diff --git a/true-binary/mt_gcg5.for b/true-binary/mt_gcg5.for index e69de29..bfe79a2 100644 --- a/true-binary/mt_gcg5.for +++ b/true-binary/mt_gcg5.for @@ -0,0 +1,844 @@ +C + SUBROUTINE GCG5AL(INGCG,IOUT,ISUM,ISUM2,NCOL,NROW,NLAY,MXITER, + & ITER1,NCRS,ISOLVE,LCA,LCQ,LCWK,LCCNCG,LCLRCH,LCRHS) +C ******************************************************************** +C ALLOCATE STORAGE IN THE X AND IX ARRAYS FOR GCG ARRAYS +C ******************************************************************** +C last modified: 02-20-2010 +C + IMPLICIT NONE + INTEGER INGCG,IOUT,ISUM,ISUM2,NCOL,NROW,NLAY,MXITER,ITER1, + & NCRS,ISOLVE,LCA,LCQ,LCWK,LCCNCG, + & LCLRCH,LCRHS,NODES,ISUMX,ISUMIX,ISOLD,ISOLD2 + +C--PRINT A MESSAGE IDENTIFYING GCG PACKAGE + WRITE(IOUT,1) INGCG + 1 FORMAT(1X,'GCG5 -- GENERALIZED CONJUGATE GRADIENT SOLVER PACKAGE', + & ', VERSION 5, FEBRUARY 2010',' INPUT READ FROM UNIT',I3) +C +C--READ AND PRINT MXITER AND ISOLVE + READ(INGCG,*) MXITER,ITER1,ISOLVE,NCRS + WRITE(IOUT,3) MXITER,ITER1 + 3 FORMAT(1X,'MAXIMUM OF',I5,' OUTER ITERATIONS', + & /1X,' AND',I5,' INNER ITERATIONS ALLOWED FOR CLOSURE') + IF(MXITER.LE.0) THEN + WRITE(*,5) + CALL USTOP(' ') + ELSEIF(ITER1.LE.0) THEN + WRITE(*,7) + CALL USTOP(' ') + ENDIF + IF(ISOLVE.EQ.1) THEN + WRITE(IOUT,13) + ELSEIF(ISOLVE.EQ.2) THEN + WRITE(IOUT,23) + ELSEIF(ISOLVE.EQ.3) THEN + WRITE(IOUT,33) + ELSE + WRITE(IOUT,43) + CALL USTOP(' ') + ENDIF + 5 FORMAT(/1X,'ERROR: OUTER ITERATION NUMBER MUST BE > 0.') + 7 FORMAT(/1X,'ERROR: INNER ITERATION NUMBER MUST BE > 0.') + 13 FORMAT(1X,'THE PRECONDITIONING TYPE SELECTED IS JACOBI.') + 23 FORMAT(1X,'THE PRECONDITIONING TYPE SELECTED IS SSOR.') + 33 FORMAT(1X,'THE PRECONDITIONING TYPE SELECTED IS ', + & 'MODIFIED INCOMPLETE CHOLESKY (MIC).') + 43 FORMAT(1X,'ERROR: INVALID PRECONDITIONING TYPE.') +C + IF(NCRS.GT.0) THEN + WRITE(IOUT,50) + ELSE + WRITE(IOUT,52) + ENDIF + 50 FORMAT(1X,'FULL DISPERSION TENSOR INCLUDED IN IMPLICIT SOLUTION') + 52 FORMAT(1X,'DISPERSION CROSS TERMS LUMPED INTO RIGHT-HAND-SIDE') +C +C--SET NCRS TO 0 FOR 1D PROBLEMS + IF(NCOL*NROW.EQ.1 .OR. NCOL*NLAY.EQ.1 .OR. NROW*NLAY.EQ.1) NCRS=0 +C +C--ALLOCATE SPACE FOR THE GCG ARRAYS + ISOLD=ISUM + ISOLD2=ISUM2 + NODES=NLAY*NROW*NCOL +C +C--INTEGER ARRAYS + LCLRCH=ISUM2 + ISUM2=ISUM2+MXITER*ITER1*3 +C +C--REAL ARRAYS + LCA=ISUM + IF(NCRS.GT.0) THEN + ISUM=ISUM+NODES*19 + ELSE + ISUM=ISUM+NODES*7 + ENDIF + LCQ=ISUM + IF(ISOLVE.EQ.3) THEN + IF(NCRS.GT.0) THEN + ISUM=ISUM+NODES*19 + ELSE + ISUM=ISUM+NODES*7 + ENDIF + ENDIF + LCWK=ISUM + ISUM=ISUM+NODES*7 + LCCNCG=ISUM + ISUM=ISUM+MXITER*ITER1 + LCRHS=ISUM + ISUM=ISUM+NODES +C +C--CHECK HOW MANY ELEMENTS OF THE X AND IX ARRAYS ARE USED + ISUMX=ISUM-ISOLD + ISUMIX=ISUM2-ISOLD2 + WRITE(IOUT,1090) ISUMX,ISUMIX + 1090 FORMAT(1X,I10,' ELEMENTS OF THE X ARRAY USED BY THE GCG PACKAGE' + & /1X,I10,' ELEMENTS OF THE IX ARRAY USED BY THE GCG PACKAGE'/) +C +C--NORMAL RETURN + RETURN + END +C +C + SUBROUTINE GCG5RP(INGCG,IOUT,MXITER,ITER1, + & ISOLVE,ACCL,CCLOSE,IPRGCG) +C *************************************************************** +C READ INPUT DATA FOR GCG PACKAGE +C *************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER INGCG,IOUT,MXITER,ITER1,ISOLVE,IPRGCG + REAL ACCL,CCLOSE +C +C--READ ACCL,CCLOSE,IPRGCG + READ(INGCG,*) ACCL,CCLOSE,IPRGCG + IF(ACCL.EQ.0.) ACCL=1. +C +C--PRINT DATA VALUES JUST READ + WRITE(IOUT,100) + 100 FORMAT(///47X,'SOLUTION BY THE GENERALIZED CONJUGATE GRADIENT', + & ' METHOD'/47X,53('-')) + WRITE(IOUT,115) MXITER + 115 FORMAT(37X,'MAXIMUM OUTER ITERATIONS ALLOWED FOR CLOSURE =',I9) + WRITE(IOUT,116) ITER1 + 116 FORMAT(37X,'MAXIMUM INNER ITERATIONS ALLOWED FOR CLOSURE =',I9) + WRITE(IOUT,117) ISOLVE + 117 FORMAT(52X,'PRECONDITIONING TYPE SELECTED =',I5) + WRITE(IOUT,120) ACCL + 120 FORMAT(59X,'ACCELERATION PARAMETER =',G15.5) + WRITE(IOUT,125) CCLOSE + 125 FORMAT(39X,'CONCENTRATION CHANGE CRITERION FOR CLOSURE =',E15.5) + IF(IPRGCG.LE.0) IPRGCG=999 + WRITE(IOUT,130) IPRGCG + 130 FORMAT(39X,'GCG CONCENTRATION CHANGE PRINTOUT INTERVAL =',I9) +C +C--NORMAL RETURN + RETURN + END +C +C + SUBROUTINE SGCG5P(CNCG,LRCH,ITP,MXITER,ITER1,IOUT) +C****************************************************************** +C PRINT MAXIMUM CONCENTRATION CHANGES FOR EACH ITERATION DURING +C A TRANSPORT TIME STEP +C****************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER LRCH,ITP,MXITER,ITER1,IOUT,I,J + REAL CNCG + DIMENSION CNCG(MXITER*ITER1),LRCH(3,MXITER*ITER1) +C + WRITE(IOUT,5) + 5 FORMAT(1X,' MAXIMUM CONCENTRATION CHANGES FOR EACH ITERATION:' + & /1X, 5(' MAX. CHANGE LAYER,ROW,COL')/1X,132('-')) + WRITE(IOUT,10) (CNCG(J),(LRCH(I,J),I=1,3),J=1,ITP) + 10 FORMAT((1X,5(G12.4,' (',I3,',',I3,',',I3,')'))) +C + RETURN + END +C +C + SUBROUTINE GCG5AP(IOUT,MXITER,ITER1,ITO,ITP,METHOD,RELAX,CCLOSE, + & ICNVG,CNCG,LRCH,NCOL,NROW,NLAY,NODES,NTRANS,KSTP,KPER,TIME2, + & HT2,UPDLHS,IPRGCG,ICBUND,CINACT,A,CNEW,RHS,Q,WK,NCRS,ISPD) +C ********************************************************************** +C SOLUTION BY THE GENERALIZED CONJUGATE GRADIENT METHODS, +C USING ONE OF THE THREE PRECONDITIONERS (JACOBI, SSOR, AND MIC) +C WITH LANCZOS/ORTHOMIN ACCELERATION, UP TO ITER1 ITERATIONS. +C HOWEVER, IF IT IS A FLOW PROBLEM OR IT IS A SYMMETRIC CASE, +C (I.E., ISPD>0), THE ORDINARY CG IS USED. +C ********************************************************************** +C PARAMETER LIST +C IOUT : INTEGER, OUTPUT UNIT NUMBER.(INPUT) +C MXITER : INTEGER, OUTER LOOP MAX NUMBER.(INPUT) +C ITER1 : INTEGER, MAXIMUM NUMBER OF ITERATIONS ALLOWED.(INPUT) +C ITO : INTEGER, OUTER LOOP COUNTER.(INPUT) +C ITP : INTEGER, ACTUAL NUMBER OF ITERATION REQUIRED.(OUTPUT) +C METHOD : INTEGER, BASIC PRECONDITIONER SELECTION.(INPUT) +C 1=JACOBI, 2=SSOR, 3=MIC +C RELAX : REAL, RELAXATION FACTOR FOR THE SSOR METHOD.(INPUT) +C CCLOSE : REAL, STOPPING CRITERION.(INPUT) +C ICNVG : INTEGER, GLOBAL CONVERGENCE FLAG.(OUTPUT) +C 1=GLOBAL CONVERGENCE, 0=NOT CONVERGED +C LICNVG : INTEGER, LOCAL CONVERGENCE FLAG.(OUTPUT) +C 1=LOCAL CONVERGENCE, 0=NO CONVERGED +C LITP : INTEGER, LOCAL ITERATION COUNTER. +C CNCG : REAL ARRAY, CONTAINS MAXIMUM CHANGE OF CONCENTRATION +C AT EVERY ITERATION.(OUTPUT) +C LRCH : INTEGER 2-D ARRAY, CONTAINS THE LOCATIONS OF THE +C MAXIMUM CHANGE OF CONCENTRATION AT EVERY ITERATION. +C NCOL,NROW,NLAY: +C INTEGERS, NUMBER OF COLUMNS, ROWS, AND LAYERS.(INPUT) +C NODES : INTEGER, DIMENSION OF THE MATRIX.(INPUT) +C NTRANS : INTEGER, TRANSPORT STEP INDEX.(INPUT) +C KSTP : INTERGE, FLOW TIME STEP INDEX.(INPUT) +C KPER : INTERGE, STRESS PERIOD INDEX.(INPUT) +C TIME2 : REAL, TOTAL ELAPSED TIME.(INPUT) +C HT2 : REAL, ACCUMULATED TIME IN CURRENT STRESS PERIOD.(INPUT) +C UPDLHS : LOGICAL, FLAG FOR UPDATING COEFF. MATRIX.(INPUT) +C IPRGCG : INTEGER, INTERVAL FOR PRINTING MAX. CHANGES.(INPUT) +C ICBUND : INTEGER, BOUNDART TYPE INDICATOR.(INPUT) +C A : COEFF. MATRIX.(INPUT) +C CNEW : REAL ARRAY, CONTAINS CONCENTRATION.(OUTPUT) +C RHS : REAL ARRAY, CONTAINS RIGHT HAND SIDE OF THE SYSTEM.(INPUT) +C Q,DQ : BASIC ITERATIVE METHOD PRECONDITIONING MATRIX STORAGE. +C WK : REAL ARRAY OF LENGTH 7*NCOL*NROW*NLAY, WORK SPACES. +C NCRS : INTEGER, 7 OR 19 DIAGONALS INDICATOR. +C ISPD : INPUT INTEGER, SYMMETRIC CASE INDICATOR. +C ********************************************************************** +C last modified: 2-15-2005 +C + IMPLICIT NONE + INTEGER NCOL,NROW,NLAY,NODES,LRCH,I,IDELTA,IRDEL,IPN, + & IPA,IAPN,IATPN,IWK,NTRANS,IOUT,II, + & ITP,LITP,ITO,ICNVG,LICNVG,IPLACE,MXITER,ITER1, + & KSTP,KPER,ICBUND,KLAYER,IROW,JCOLMN,IJ,METHOD, + & IPRGCG,NCRS,ISPD + REAL CNEW,A,RHS,Q,WK,DELC,DCOLD,ALN,CHANGE,CTEMP,CHTMP, + & RLN,CCLOSE,RELAX,HT2,TIME2,CNCG,DELPN,PNAPN,SCALE, + & DELAPN,APNPA,GSTOP,RHSNORM,TINY,CINACT + LOGICAL UPDLHS + DIMENSION A(*),CNEW(NODES), + & RHS(NODES),Q(*),WK(7*NODES), + & CNCG(MXITER*ITER1),LRCH(3,MXITER*ITER1),ICBUND(NODES) + PARAMETER (TINY=1.E-30) +C + IDELTA = 1 + IPN = IDELTA+NODES + IAPN = IPN +NODES + IWK = IAPN +NODES +C +C--THE FOLLOWING WORK SPACE ALLOCATIONS ARE NEEDED FOR +C--NONSYMMETRIC CASES + IF (ISPD.EQ.0) THEN + IRDEL = IWK +NODES + IPA = IRDEL +NODES + IATPN = IPA +NODES + ENDIF +C + IF(ITO.EQ.1) ITP=0 + LITP = 0 + ICNVG=0 + LICNVG=0 +C +C--NORMALIZE CNEW AND RHS TO AVOID TOO BIG OR TOO SMALL QUANTITIES +C--NORMALIZATION FACTOR IS MAX (CNEW) + SCALE = 0. + DO I = 1,NODES + IF (ICBUND(I).NE.0) THEN + IF (ABS(CNEW(I)).GT.SCALE) SCALE = CNEW(I) + ENDIF + ENDDO + IF (SCALE .GT. TINY) THEN + DO I = 1,NODES + IF (ICBUND(I).NE.0) THEN + RHS(I) = RHS(I)/SCALE + CNEW(I) = CNEW(I)/SCALE + ENDIF + ENDDO + ENDIF +C +C--COMPUTE RESIDUAL VECTOR R=RHS-A*CNEW AND TEST FOR SOLUTION + CALL MVPRD (NODES,NCRS,ICBUND,A,CNEW,WK(IWK)) + GSTOP=0. + RHSNORM = 0. + DO I = 1,NODES + IF (ICBUND(I).NE.0) THEN + WK(IWK-1+I) = RHS(I)-WK(IWK-1+I) + RHSNORM = RHSNORM+RHS(I)*RHS(I) + GSTOP =GSTOP+WK(IWK-1+I)*WK(IWK-1+I) + ENDIF + ENDDO + RHSNORM = SQRT(RHSNORM) + GSTOP = SQRT(GSTOP) + IF (RHSNORM.NE.0) GSTOP = GSTOP / RHSNORM + IF(GSTOP.LE. MIN(1.E-6,CCLOSE) ) THEN + CHANGE = 0. + IPLACE = 1 + ITP = ITP + 1 + LITP= LITP+ 1 + IF(UPDLHS.AND.METHOD.EQ.3) CALL MIC (NODES,NCRS,A,Q) + GO TO 300 + ENDIF +C +C--COMPUTE PSEUDO-RESIDUAL DELTA = Q^-1*(RHS-A*CNEW) + IF (METHOD.EQ.3) THEN + IF(UPDLHS) CALL MIC (NODES,NCRS,A,Q) + ENDIF +C...... JACOBI OR SSOR METHOD ..... + IF(METHOD.EQ.1.OR.METHOD.EQ.2) THEN + CALL QSOLVE (NODES,METHOD,RELAX,NCRS,A,WK(IWK),WK(IDELTA)) + ELSE +C...... MIC METHOD ..... + CALL QSOLVE (NODES,METHOD,RELAX,NCRS,Q,WK(IWK),WK(IDELTA)) + ENDIF +C +C--BRANCH FOR THE NONSYMMETRIC CASE +C--LANCZOS/ORTHOMIN ACCELERATION IS USED + IF (ISPD.NE.0) GO TO 200 + DO II = 1,NODES + WK(IPN-1+II) = WK(IDELTA-1+II) + WK(IRDEL-1+II) = WK(IDELTA-1+II) + WK(IPA-1+II) = WK(IDELTA-1+II) + ENDDO + DELC = 0. + DO II = 1,NODES + IF (ICBUND(II).NE.0) + & DELC = DELC + WK(IDELTA-1+II)*WK(IRDEL-1+II) + ENDDO + GO TO 100 +C +C--COMPUTE DIRECTION VECTORS + 90 CONTINUE + DCOLD = DELC + DELC = 0. + DO II = 1, NODES + IF (ICBUND(II).NE.0) + & DELC = DELC + WK(IDELTA-1+II)*WK(IRDEL-1+II) + ENDDO + ALN = DELC / DCOLD + DO I = 1,NODES + WK(IPN-1+I) = WK(IDELTA-1+I) + ALN * WK(IPN-1+I) + WK(IPA-1+I) = WK(IRDEL-1+I) + ALN * WK(IPA-1+I) + ENDDO +C +C--COMPUTE NEW ITERATES + 100 CONTINUE + ITP = ITP + 1 + LITP = LITP + 1 + CALL MVPRD (NODES,NCRS,ICBUND,A,WK(IPN),WK(IWK)) + IF(METHOD.EQ.1.OR.METHOD.EQ.2) THEN + CALL QSOLVE (NODES,METHOD,RELAX,NCRS,A,WK(IWK),WK(IAPN)) + CALL QTSLVE (NODES,METHOD,RELAX,NCRS,A,WK(IPA),WK(IWK)) + ELSE + CALL QSOLVE (NODES,METHOD,RELAX,NCRS,Q,WK(IWK),WK(IAPN)) + CALL QTSLVE (NODES,METHOD,RELAX,NCRS,Q,WK(IPA),WK(IWK)) + ENDIF +C + CALL MTVPRD (NODES,NCRS,ICBUND,A,WK(IWK),WK(IATPN)) + APNPA = 0. + DO II = 1, NODES + IF(ICBUND(II).NE.0) + & APNPA = APNPA + WK(IAPN-1+II)*WK(IPA-1+II) + ENDDO + IF(APNPA.NE.0) RLN = DELC / APNPA + CHANGE = 0.0 + IPLACE = 1 + DO I = 1,NODES + CTEMP = CNEW(I) + CNEW(I) = CNEW(I) + RLN * WK(IPN-1+I) + WK(IDELTA-1+I) = WK(IDELTA-1+I) - RLN * WK(IAPN-1+I) + WK(IRDEL-1+I) = WK(IRDEL-1+I) - RLN * WK(IATPN-1+I) + CHTMP = ABS(CNEW(I)-CTEMP) + IF (CHTMP.GT.CHANGE) THEN + CHANGE = CHTMP + IPLACE = I + ENDIF + ENDDO + GO TO 300 + 200 CONTINUE +C +C--THE FOLLOWING IS FOR THE SYMMETRIC CASE +C--ORDINARY CG ACCELERATION IS USED + DO II = 1, NODES + WK(IPN-1+II) = WK(IDELTA-1+II) + ENDDO + GO TO 220 +C +C--COMPUTE DIRECTION VECTORS + 210 CONTINUE + DELAPN = 0. + DO II = 1, NODES + IF(ICBUND(II).NE.0) + & DELAPN = DELAPN + WK(IDELTA-1+II)*WK(IAPN-1+II) + ENDDO + ALN = -DELAPN / PNAPN + DO I = 1,NODES + WK(IPN-1+I) = WK(IDELTA-1+I) + ALN * WK(IPN-1+I) + ENDDO +C +C--COMPUTE NEW ITERATES + 220 CONTINUE + ITP = ITP + 1 + LITP = LITP + 1 + DELPN = 0. + DO II = 1, NODES + IF(ICBUND(II).NE.0) + & DELPN = DELPN + WK(IDELTA-1+II)*WK(IPN-1+II) + ENDDO + CALL MVPRD (NODES,NCRS,ICBUND,A,WK(IPN),WK(IWK)) + IF(METHOD.EQ.1.OR.METHOD.EQ.2) THEN + CALL QSOLVE (NODES,METHOD,RELAX,NCRS,A,WK(IWK),WK(IAPN)) + ELSE + CALL QSOLVE (NODES,METHOD,RELAX,NCRS,Q,WK(IWK),WK(IAPN)) + ENDIF + PNAPN = 0. + DO II = 1, NODES + IF(ICBUND(II).NE.0) + & PNAPN = PNAPN + WK(IAPN-1+II)*WK(IPN-1+II) + ENDDO + IF(PNAPN.NE.0) RLN = DELPN / PNAPN + CHANGE = 0.0 + IPLACE = 1 + DO I = 1,NODES + CTEMP = CNEW(I) + CNEW(I) = CNEW(I) + RLN * WK(IPN-1+I) + WK(IDELTA-1+I) = WK(IDELTA-1+I) - RLN * WK(IAPN-1+I) + CHTMP = ABS(CNEW(I)-CTEMP) + IF (CHTMP.GT.CHANGE) THEN + CHANGE = CHTMP + IPLACE = I + ENDIF + ENDDO +C + 300 CONTINUE +C +C--STORE MAXIMUM CHANGE VALUE AND LOCATION + CNCG(ITP) = CHANGE + KLAYER = (IPLACE-1) / (NCOL*NROW) + 1 + IJ = IPLACE - (KLAYER-1)*NCOL*NROW + IROW = (IJ-1)/NCOL + 1 + JCOLMN = IJ - (IROW-1)*NCOL + LRCH(1,ITP) = KLAYER + LRCH(2,ITP) = IROW + LRCH(3,ITP) = JCOLMN +C + WRITE(*,1111) ITO,LITP,CHANGE,KLAYER,IROW,JCOLMN + 1111 FORMAT(1X,'Outer Iter.',I3,' Inner Iter.',I3, + & ': Max. DC =',G12.4,' [K,I,J]',3I5) +C +C--CHECK CONVERGENCE ...... + IF(CHANGE.LE.CCLOSE) THEN + LICNVG=1 + ENDIF + IF(MXITER.EQ.1) THEN + IF(LICNVG.EQ.1) ICNVG=1 + ELSEIF(ITO.GT.1) THEN + IF(LICNVG.EQ.1.AND.LITP.EQ.1) ICNVG=1 + ENDIF +C +C--LOCAL CONVERGENCE NOT MET, LOOP BACK + IF(LICNVG.EQ.0 .AND. LITP.LT.ITER1) THEN + IF(ISPD.EQ.0) THEN + GOTO 90 + ELSE + GOTO 210 + ENDIF + ENDIF + IF(ICNVG.EQ.0 .AND. ITO.NE.MXITER) GOTO 600 + IF(NTRANS.EQ.1) WRITE(IOUT,1000) + 1000 FORMAT(/1X) + WRITE(IOUT,1010) ITO,NTRANS,KSTP,KPER,ITP + 1010 FORMAT(1X,I5,' CALLS TO GCG PACKAGE FOR TRANSPORT TIME STEP',I4, + & ' IN FLOW TIME STEP',I4,' STRESS PERIOD',I4, + & /1X,I5,' TOTAL ITERATIONS') +C + IF(ICNVG.EQ.0 .OR. TIME2.GE.HT2 .OR. MOD(NTRANS,IPRGCG).EQ.0) + & CALL SGCG5P(CNCG,LRCH,ITP,MXITER,ITER1,IOUT) +C + 600 CONTINUE +C +C--BEFORE RETURN UNSCALE CNEW AND RHS + IF (SCALE .GT. TINY) THEN + DO I = 1,NODES + IF (ICBUND(I).NE.0) THEN + RHS(I) = RHS(I)*SCALE + CNEW(I) = CNEW(I)*SCALE + ELSE + CNEW(I)=CINACT + ENDIF + ENDDO + ENDIF + RETURN + END +C +C + SUBROUTINE MVPRD (N,NCRS,ICBUND,A,X,Y) +C******************************************************************* +C... THIS SUBROUTINE, MVPRD, PERFORMS AX=Y +C... WHERE THE MATRIX A IS STORED IN DIAGONAL FORM +C******************************************************************* +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER N,L,IDIAG,I,JCOL,K,ICBUND,NCRS + REAL A,X,Y + DIMENSION A(N,*), X(N), Y(N), ICBUND(N) + COMMON /GCGIDX/L(19) +C + IDIAG = 7 + IF(NCRS.GT.0) IDIAG = 19 + DO I = 1,N + Y(I) = 0. + DO K = 1,IDIAG + JCOL = I + L(K) + IF (JCOL.GE.1.AND.JCOL.LE.N) THEN + IF(ICBUND(JCOL).NE.0) Y(I) = Y(I)+A(I,K)*X(JCOL) + ENDIF + ENDDO + ENDDO +C + RETURN + END +C +C + SUBROUTINE MTVPRD (N,NCRS,ICBUND,A,X,Y) +C********************************************************************* +C.... THIS SUBROUTINE, MTVPRD, PERFORMS A^TX=Y +c********************************************************************* +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER N,L,IDIAG,I,JCOL,ICBUND,NCRS,J + REAL A,X,Y + DIMENSION A(N,*),X(N),Y(N),ICBUND(N) + COMMON /GCGIDX/L(19) +C + IDIAG = 7 + IF(NCRS.GT.0) IDIAG = 19 + DO I = 1,N + Y(I) = 0. + ENDDO + DO I = 1,N + DO J = 1,IDIAG + JCOL = I + L(J) + IF(JCOL.GE.1.AND.JCOL.LE.N) THEN + IF (ICBUND(JCOL).NE.0) Y(JCOL) = Y(JCOL)+A(I,J)*X(I) + ENDIF + ENDDO + ENDDO +C + RETURN + END +C +C + SUBROUTINE QSOLVE(N,METHOD,RELAX,NCRS,A,SY,Y) +C********************************************************************* +C*... FUNCTION: +C* +C* THIS SUBROUTINE, QSOLVE, PERFORMS THE FORWARD AND BACKWARD +C* SUBSTITUTION. WHICH SOLVES Q * Y = SY FOR THE JACOBI +C* SSOR, AND MIC METHODS. +C* +C*... PARAMETER LIST +C* +C* N : INPUT INTEGER, THE DIMENSION OF THE SYSTEM +C* METHOD : INPUT INTEGER, DEFINES BASIC ITERATIVE METHOD +C* RELAX : INPUT REAL, RELAXATION FACTOR FOR SSOR +C* NCRS : INPUT INTEGER, 7 OR 19 DIAGONALS INDICATOR. +C* A : INPUT REAL ARRAY. CONTAINS THE NONZERO ELEMENTS +C* OF THE COEFFICIENT MATRIX A. +C* SY : INPUT REAL ARRAY. THE RIGHT HAND SIDE OF THE +C* SYSTEM. +C* Y : OUTPUT REAL ARRAY. CONTAINS THE SOLUTION. +C********************************************************************* +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER N,METHOD,NCRS,LL,LU,I,J,K,II,IDIAG,JCOL,L + REAL Y,SY,A,RELAX + DIMENSION Y(N),SY(N),A(N,*),LL(9),LU(9) + COMMON /GCGIDX/ L(19) +C + DO II = 1,N + Y(II) = SY(II) + ENDDO +C + IF (METHOD .NE. 1) GO TO 5 +C +C ... JACOBI METHOD +C ... NOTE: THE FIRST ELEMENT IN EACH ROW OF THE MATRIX A IS THE +C .... DIAGONAL ELEMENT OF THE ROW. +C + DO I=1,N + Y(I)=Y(I)/A(I,1) + ENDDO + RETURN +C +C SOLVE LDUY=Y +C + 5 CONTINUE + IF (METHOD .NE. 2) RELAX = 1.0 + IF (NCRS.GT.0) THEN + IDIAG = 9 + ELSE + IDIAG = 3 + ENDIF +C + LL(1) = 2 + LL(2) = 4 + LL(3) = 6 + LU(1) = 3 + LU(2) = 5 + LU(3) = 7 + IF (NCRS.GT.0) THEN + LL(4) = 8 + LL(5) = 9 + LL(6) = 10 + LL(7) = 11 + LL(8) = 16 + LL(9) = 17 + LU(4) = 12 + LU(5) = 13 + LU(6) = 14 + LU(7) = 15 + LU(8) = 18 + LU(9) = 19 + ENDIF +C +C ... SOLVE LOWER TRIANGULAR SYSTEM FOR THE SSOR METHOD +C + DO I=1,N + DO J = 1,IDIAG + JCOL = I + L(LL(J)) + IF (JCOL.GT.0) Y(I) = Y(I) - A(I,LL(J))*Y(JCOL) + ENDDO + Y(I) = RELAX*Y(I) / A(I,1) + ENDDO +C +C SOLVE DY=Y +C + IF (METHOD .EQ. 2) THEN + DO I = 1,N + Y(I) = (2.0-RELAX)/RELAX * Y(I) * A(I,1) + ENDDO + ELSE + DO I=1,N + Y(I)=Y(I)*A(I,1) + ENDDO + ENDIF +C +C SOLVE UY=Y +C + DO I=N,1,-1 + DO K=1,IDIAG + JCOL = I + L(LU(K)) + IF (JCOL.LE.N) Y(I)=Y(I)-A(I,LU(K))*Y(JCOL) + ENDDO + Y(I)=RELAX*Y(I)/A(I,1) + ENDDO +C + RETURN + END +C +C + SUBROUTINE QTSLVE(N,METHOD,RELAX,NCRS,A,SY,Y) +C*********************************************************************** +C*... FUNCTION: +C* +C* THIS SUBROUTINE, QTSLVE, PERFORMS THE DRIVER OF SOLVING +C* THE SYSTEM Q ** (T) * Y = SY WHERE THE MATRIX Q IS IN THE +C* L * D * U FORM. +C* +C*... PARAMETER LIST: +C* +C* N : INPUT INTEGER, THE DIMENSION OF THE SYSTEM +C* METHOD : INPUT INTEGER, DEFINES BASIC ITERATIVE METHOD +C* RELAX : INPUT REAL, RELAXATION FACTOR FOR SSOR +C* NCRS : INPUT INTEGER, 7 OR 19 DIAGONALS INDICATOR +C* A : INPUT REAL ARRAY, THE COEFFICIENT MATRIX +C* SY : INPUT REAL ARRAY. IT CONTAINS THE RIGHT HAND +C* SIDE OF THIS SYSTEM. +C* Y : OUTPUT REAL ARRAY. IT CONTAINS THE SOLUTION OF +C* THIS SYSTEM. +C*********************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER N,METHOD,NCRS,LL,LU,I,J,K,II,IDIAG,JCOL,L + REAL Y,SY,A,RELAX + DIMENSION Y(N),SY(N),A(N,*),LL(9),LU(9) + COMMON /GCGIDX/ L(19) +C + DO II = 1,N + Y(II) = SY(II) + ENDDO +C + IF (METHOD .NE. 1) GOTO 5 +C +C ... JACOBI METHOD +C + DO I = 1,N + Y(I) = Y(I) / A(I,1) + ENDDO + RETURN +C +C ... SOLVE LDU ** (T) * Y = Y +C + 5 CONTINUE + IF (METHOD .NE. 2) RELAX = 1.0 + IF (NCRS.GT.0) THEN + IDIAG = 9 + ELSE + IDIAG = 3 + ENDIF +C + LL(1) = 2 + LL(2) = 4 + LL(3) = 6 + LU(1) = 3 + LU(2) = 5 + LU(3) = 7 + IF (NCRS.GT.0) THEN + LL(4) = 8 + LL(5) = 9 + LL(6) = 10 + LL(7) = 11 + LL(8) = 16 + LL(9) = 17 + LU(4) = 12 + LU(5) = 13 + LU(6) = 14 + LU(7) = 15 + LU(8) = 18 + LU(9) = 19 + ENDIF +C +C ... SOLVE (UT)Y = Y +C + DO I=1,N + Y(I) = RELAX * Y(I) / A(I,1) + DO J = 1,IDIAG + JCOL = I + L(LU(J)) + IF (JCOL.LE.N) Y(JCOL) = Y(JCOL) - A(I,LU(J))*Y(I) + ENDDO + ENDDO +C +C SOLVE DY=Y +C + IF (METHOD .EQ. 2) THEN + DO I = 1,N + Y(I) = (2.0-RELAX)/RELAX * Y(I) * A(I,1) + ENDDO + ELSE + DO I=1,N + Y(I)=Y(I)*A(I,1) + ENDDO + ENDIF +C +C SOLVE (LT)Y=Y +C + DO I=N,1,-1 + Y(I) = RELAX * Y(I) / A(I,1) + DO K = 1,IDIAG + JCOL = I + L(LL(K)) + IF (JCOL.GT.0) Y(JCOL) = Y(JCOL) - A(I,LL(K))*Y(I) + ENDDO + ENDDO +C + RETURN + END +C +C + SUBROUTINE MIC(N,NCRS,A,Q) +C*********************************************************************** +C*... FUNCTION: +C* +C* THIS SUBROUTINE, MIC, PERFORMS +C* THE MODIFIED INCOMPLETE CHOLESKY FACTORIZATION. +C* +C*... PARAMETER USED IN THIS SUBROUTINE: +C* +C* N INPUT INTEGER. DIMENSION OF THE MATRIX A. (= N) +C* NCOL NUMBER OF COLUMNS +C* NRC NUMBER OF COLUMNS TIMES NUMBER OF ROWS +C* NCRS INPUT INTEGER, 7 OR 19 DIAGONALS INDICATOR +C* A INPUT REAL VECTOR. CONTAINS THE NONZERO ELEMENTS +C* OF THE MATRIX. +C* Q OUTPUT, CONTAINS THE COMPACT LDU FORM FOR THE MIC +C********************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER K,II,IJ,IPVT,IICOL,ILST,IROW,JP,JCOL,KK,LL,IERR, + & LU,NCRS,IDIAG,L,N,J,NRC,NCOL + REAL A,Q,QMULT,TINY + PARAMETER (TINY=1.E-30) + DIMENSION A(N,*),Q(N,*),LU(9) + COMMON /GCGIDX/ L(19) +C +C ... SET INITIAL PARAMETERS +C + NRC = L(3) + NCOL = L(5) + LU(1) = 3 + LU(2) = 5 + LU(3) = 7 + IF (NCRS.GT.0) THEN + LU(4) = 12 + LU(5) = 13 + LU(6) = 14 + LU(7) = 15 + LU(8) = 18 + LU(9) = 19 + ENDIF + IF (NCRS.GT.0) THEN + IDIAG = 19 + ILST = 9 + ELSE + IDIAG = 7 + ILST = 3 + IF(NCOL.EQ.1) ILST = 2 + IF(NRC.EQ.1) ILST = 1 + ENDIF + DO K = 1,N + DO J = 1, IDIAG + Q(K,J) = A(K,J) + ENDDO + ENDDO + IF(ABS(Q(1,1)).LT.TINY) Q(1,1)=1. +C + DO IPVT = 1,N-1 + DO KK = 1,ILST + IROW = IPVT+L(LU(KK)) + IF(IROW.GT.N) CYCLE + DO II = 1,IDIAG + IICOL = IROW + L(II) + IF (IICOL .EQ. IPVT) GO TO 95 + ENDDO + CYCLE + 95 QMULT = Q(IROW,II) + DO LL = 1,ILST + JCOL = IPVT + L(LU(LL)) + IERR = 1 + DO IJ = 1,IDIAG + JP = IROW + L(IJ) + IF(JP .EQ. JCOL) THEN + IERR = 0 + EXIT + ENDIF + ENDDO + IF(IERR.EQ.0) THEN + Q(IROW,IJ)=Q(IROW,IJ)-QMULT*Q(IPVT,LU(LL))/Q(IPVT,1) + ELSE + Q(IROW,1) =Q(IROW,1) -QMULT*Q(IPVT,LU(LL))/Q(IPVT,1) + IF(ABS(Q(IROW,1)).LT.TINY) Q(IROW,1)=1. + ENDIF + ENDDO + ENDDO + ENDDO +C + RETURN + END \ No newline at end of file diff --git a/true-binary/mt_hss5.for b/true-binary/mt_hss5.for index e69de29..463bb69 100644 --- a/true-binary/mt_hss5.for +++ b/true-binary/mt_hss5.for @@ -0,0 +1,571 @@ +C + SUBROUTINE HSS5AL(INHSS,IOUT,ISUM,ISUM2,NCOL,NROW,NLAY, + & MaxHSSSource,MaxHSSCells,MaxHSSStep, + & LCHSSData,LCHSSLoc,iRunHSSM) +C ******************************************************************** +C THIS SUBROUTINE ALLOCATES SPACE FOR ARRAYS NEEDED BY THE HSSM-MT3DMS +C INTERFACE (HSS) PACKAGE. +C ******************************************************************** +C Last modified: 02-20-2010 +C + IMPLICIT NONE + INTEGER INHSS,IOUT,ISUM,ISUM2,ISOLD,ISOLD2,ISUMX,ISUMIX, + & NCOL,NROW,NLAY,MaxHSSSource,MaxHSSCells,MaxHSSStep, + & LCHSSData,LCHSSLoc,LLOC,ISTART,ISTOP,ITMP, + & inam1,inam2,iRunHSSM + REAL R + CHARACTER LINE*200 +C +C--PRINT PACKAGE NAME AND VERSION NUMBER + WRITE(IOUT,1030) INHSS + 1030 FORMAT(1X,'HSS5 -- MT3DMS-HSSM INTERFACE PACAKGE,', + & ' VERSION 5, FEBRUARY 2010, INPUT READ FROM UNIT ',I5) +C +C--READ INPUT LINE AS A TEXT STRING + 2 READ(INHSS,'(A)') LINE + IF(LINE.EQ.' ') GOTO 2 + IF(LINE(1:1).EQ.'#') THEN + WRITE(IOUT,'(A)') LINE + GOTO 2 + ENDIF +C +C--DECODE THE INPUT VARIABLES + LLOC=1 + CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,ITMP,R,IOUT,INHSS) + MaxHSSSource=ITMP + CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,ITMP,R,IOUT,INHSS) + MaxHSSCells=ITMP + CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,ITMP,R,IOUT,INHSS) + MaxHSSStep=ITMP + CALL URWORD(LINE,LLOC,inam1,inam2, 1,ITMP,R,IOUT,INHSS) + IF(LINE(inam1:inam2).EQ.'RUNHSSM') THEN + iRunHSSM=1 + ELSE + iRunHSSM=0 + ENDIF +C +C--ECHO INPUT VARIABLES + WRITE(IOUT,10) MaxHSSSource,MaxHSSCells,MaxHSSStep + 10 FORMAT(1X,'MAXIMUM NO. OF HSS SOURCES =',I4, + & /1X,'MAXIMUM NO. OF MODEL CELLS FOR A HSS SOURCE =',I4, + & /1X,'MAXIMUM NO. OF TIME STEPS DEFINING A HSS SOURCE =',I4) +C +C--ALLOCATE SPACE FOR ARRAYS + ISOLD=ISUM + ISOLD2=ISUM2 +C +C--INTEGER ARRAYS + LCHSSLoc=ISUM2 + ISUM2=ISUM2+MaxHSSCells*MaxHSSStep*MaxHSSSource +C +C--REAL ARRAYS + LCHSSData=ISUM + ISUM=ISUM+(4+MaxHSSCells)*MaxHSSStep*MaxHSSSource +C +C--CHECK HOW MANY ELEMENTS OF THE X AND IX ARRAYS ARE USED + ISUMX=ISUM-ISOLD + ISUMIX=ISUM2-ISOLD2 + WRITE(IOUT,1090) ISUMX,ISUMIX + 1090 FORMAT(1X,I10,' ELEMENTS OF THE X ARRAY USED BY THE HSS PACKAGE', + & /1X,I10,' ELEMENTS OF THE IX ARRAY USED BY THE HSS PACKAGE'/) +C +C--NORMAL RETURN + RETURN + END +C +C + SUBROUTINE HSS5RP(INHSS,IOUT,NCOL,NROW,NLAY,NCOMP,ICBUND, + & DELR,DELC,XBC,YBC,MaxHSSSource,MaxHSSCells,MaxHSSStep,nHSSSource, + & faclength,factime,facmass,HSSData,iHSSLoc,HSSNAM,iRunHSSM) +C ********************************************************************** +C This subroutine reads input data for the HSS package +C ********************************************************************** +C last modified: 02-20-2010 +C +!hss DLL_IMPORT HSSM + IMPLICIT NONE + integer,parameter :: nPoint=51, nSubGrid=25 + INTEGER INHSS,IOUT,NCOL,NROW,NLAY,LLOC,INAM1,INAM2,N,IU, + & ISTART,ISTOP,IFLEN,nHSSSource,inHSSFile,i,j,k, + & MaxHSSSource,MaxHSSCells,MaxHSSStep,iHSSLoc, + & it,icbund,ncomp,iHSSComp,num,iRunHSSM, + & jSource,iSource,kSource,iStep,NStep,nr,itmp,inode + REAL HSSData,faclength,factime,facmass,time,radius_lnapl, + & sourcemassflux,r_distance,delr,delc,xbc,ybc,R, + & area_cell,area_source,area_total,degree,p + CHARACTER HSSNAM*12,SourceName*12,LINE*200,HSSFileName*200 + DIMENSION ICBUND(ncol,nrow,nlay,ncomp),DELR(ncol),DELC(nrow), + & iHSSLoc(MaxHSSCells,MaxHSSStep,MaxHSSSource), + & HSSData(4+MaxHSSCells,MaxHSSStep,MaxHSSSource), + & HSSNAM(MaxHSSSource),XBC(ncol),YBC(nrow), + & p(2,nPoint) +C +C--READ INPUT DATA + read(inhss,*) faclength,factime,facmass + write(iout,10) faclength,factime,facmass + read(inhss,*) nHSSSource + write(iout,12) nHSSSource + 10 format(//1x,'INPUT DATA FOR HSS LNAPL SOURCES', + & /1x, '--------------------------------', + &//1x,'LENGTH UNIT CONVERSION FACTOR FROM HSSM TO MT3DMS =',G12.4, + & /1x,'TIME UNIT CONVERSION FACTOR FROM HSSM TO MT3DMS =',G12.4, + & /1x,'MASS UNIT CONVERSION FACTOR FROM HSSM TO MT3DMS =',G12.4) + 12 format(/1x,'TOTAL NUMBER OF HSS SOURCES IN THIS SIMULATION =',I4) +C + if(nHSSSource.gt.MaxHSSSource) then + call ustop ('[MaxHSSSource] exceeded!') + endif +C + DO n=1,nHSSSource !go over each HSS source +C +C--READ INPUT LINE AS A TEXT STRING +C + READ(INHSS,'(A)') LINE +C--DECODE THE HSS SOURCE DEFINITION FILE NAME + LLOC=1 + CALL URWORD(LINE,LLOC,INAM1,INAM2,0,IU,R,IOUT,INHSS) + IFLEN=INAM2-INAM1+1 + HSSFileName(1:IFLEN)=LINE(INAM1:INAM2) +C +C--DECODE SOURCE DEFINITION FILE INPUT UNIT + CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,IU,R,IOUT,INHSS) + inHSSFile=IU +C +C--ECHO INPUT DATA + write(iout,20) n,HSSFileName(1:IFLEN),inHSSFile + 20 format(/1x,'HSS Source No. ',I4.4, + & /1x,'Source Definition File Name: ',a, + & /1x,'Source Definition File Read from Unit: ',i4) +C +C--GET HSS SOURCE LOCATION AND NAME + READ(inhss,*) ksource,isource,jsource,iHSSComp,sourcename +C + HSSNAM(n)=sourcename + write(iout,30) ksource,isource,jsource,iHSSComp,sourcename + 30 format(1x,'[Layer,Row,Column]:',3i5,'; Species:',i3, + & /1x,'Source Name: ',A) +C +C--Run external HSSMKO DLL if necessary (uncomment to activate) + IF(iRunHSSM.eq.1) then +!hss WRITE(*,33) HSSFileName(1:IFLEN) !HSSFileName is c*200 +!hss CALL HSSM(1,0,HSSFileName(1:IFLEN-4)) + ENDIF + 33 format(/'***Running HSSMKO ', + & 'to generate source definition file: ',a/) +C +C--READ HSSM INPUT FILE + OPEN(inHSSFile,file=HSSFileName(1:IFLEN),STATUS='OLD') + write(iout,40) + 40 FORMAT(1x,' Time LNAPL_Plume_Radius', + & ' Mass_Loading_Rate') +C + it=0 + 50 read(inHSSFile,*,end=100) time,radius_lnapl,sourcemassflux + write(iout,60) time,radius_lnapl,sourcemassflux + 60 format(1x,g12.4,3x,g15.7,4x,g15.7) + it=it+1 + if(it.gt.MaxHSSStep) then + call ustop ('[MaxHSSStep] exceeded!') + endif + HSSData(1,it,n)=time * factime + HSSData(2,it,n)=radius_lnapl * faclength + HSSData(3,it,n)=sourcemassflux * facmass / factime + HSSData(4,it,n)=iHSSComp + goto 50 + 100 close (inHSSFile) +C +C--DISTRIBUTE LNAPL SOURCE into MULTIPLE CELLS at MULTIPLE times +C--(based on area weighting) + NStep=it + write(iout,110) + 110 format(1x,'Source Allocation Statistics', + & /1x,' Time Layer Row Col', + & ' Redistributed Rate') +c + DO iStep=1,NStep +c +c compute source area + radius_lnapl=HSSData(2,iStep,n) + if(radius_lnapl.le.0) then + area_source=-999. + else + area_source=3.14159*radius_lnapl**2 + endif +c +c distribute to starting source cell + num=1 + iHSSLoc(num,iStep,n)= + & (ksource-1)*ncol*nrow+(isource-1)*ncol+jsource + area_cell=delr(jsource)*delc(isource) + if(area_source .lt. area_cell) then + HSSData(4+num,iStep,n)=HSSData(3,iStep,n) + write(iout,120) HSSData(1,iStep,n), + & ksource,isource,jsource,HSSData(4+num,iStep,n) + cycle + endif +c +c distribute to multiple cells + do nr=1,nPoint !discretize source perimeter into polygon + degree=(nr-1)*2.*3.14159/nPoint + p(1,nr)=xbc(jsource)+radius_lnapl*cos(degree) + p(2,nr)=ybc(isource)+radius_lnapl*sin(degree) + enddo +c + num=0 + area_total=0 + do i=1,nrow + do j=1,ncol + R=sqrt((xbc(j)-xbc(jsource))**2+(ybc(i)-ybc(isource))**2) + R=R-0.5*sqrt(delr(j)**2+delc(i)**2) + if(R.gt.1.5*radius_lnapl) cycle !1.5 is a safety factor + call GetArea(ncol,nrow,nPoint,p,nSubGrid,delr,xbc, + & delc,ybc,j,i,area_cell) +c + if(area_cell.le.0) cycle + num=num+1 + if(num.gt.MaxHSSCells) then + call ustop('[MaxHSSCells] exceeded!') + endif + iHSSLOC(num,iStep,n)=(ksource-1)*ncol*nrow+(i-1)*ncol+j + HSSData(4+num,iStep,n)=area_cell + area_total=area_total+area_cell + enddo + enddo +c + do itmp=1,num + inode=iHSSLoc(itmp,iStep,n) + if(inode.le.0) cycle + i = mod((inode-1),ncol*nrow)/ncol + 1 + j = mod((inode-1),ncol) + 1 + area_cell=HSSData(4+itmp,iStep,n) + R=area_cell/area_total + HSSData(4+itmp,iStep,n)=R*HSSData(3,iStep,n) + write(iout,120) HSSData(1,iStep,n),ksource,i,j, + & HSSData(4+itmp,iStep,n) + enddo +c + ENDDO + 120 FORMAT(1x,g12.4,3i6,4x,g15.7) +C + ENDDO !done with all HSS sources +C +C--normal return + 1000 CONTINUE + RETURN + END +C +C + Subroutine HSS5FM(NCOL,NROW,NLAY,NCOMP,ICOMP,MIXELM,UPDLHS, + & MaxHSSSource,MaxHSSStep,MaxHSSCells,nHSSSource,time1,time2, + & ICBUND,A,RHS,NODES,HSSData,iHSSLoc) +C ********************************************************************** +C THIS SUBROUTINE FORMULATES MATRIX COEFFICIENTS FOR THE HSS SOURCE +C TERM UNDER THE IMPLICIT FINITE-DIFFERENCE METHOD. +C ********************************************************************** +C last modified: 02-20-2010 +C + IMPLICIT NONE + INTEGER NCOL,NROW,NLAY,NCOMP,ICOMP,ICBUND,is,it,icell,iHSSLoc, + & N,NODES,MIXELM,iStep,MaxHSSSource, + & MaxHSSCells,MaxHSSStep,nHSSSource,iHSSComp + REAL A,RHS,ctmp,ctmp1,ctmp2,tstart,tend,time1,time2,HSSData + LOGICAL UPDLHS + DIMENSION ICBUND(NODES,NCOMP),A(NODES),RHS(NODES), + & HSSData(4+MaxHSSCells,MaxHSSStep,MaxHSSSource), + & iHSSLoc(MaxHSSCells,MaxHSSStep,MaxHSSSource) +C +C--FORMULATE [RHS] MATRIX FOR EULERIAN & EULERIAN-LAGRANGIAN SCHEMES + DO is=1,nHSSSource +c + iHSSComp=int(HSSData(4,1,is)) + if(iHSSComp.ne.ICOMP) cycle +c + 666 DO icell=1,MaxHSSCells + N=iHSSLoc(icell,1,is) + IF(ICBUND(N,ICOMP).le.0) cycle +c + CALL TVSource(NCOL,NROW,NLAY,iStep,iCell,is, + & MaxHSSSource,MaxHSSStep,MaxHSSCells,time1,time2, + & HSSData,CTMP) +c +c--add contribution to [RHS] if ctmp is positive + IF(CTMP.LT.0) THEN + CALL USTOP('Error in HSS Source Definition File!') + ELSE + RHS(N)=RHS(N)-CTMP + ENDIF + ENDDO +C + ENDDO +C +C--RETURN + RETURN + END +C +C + Subroutine HSS5BD(NCOL,NROW,NLAY,NCOMP,ICOMP,NODES,ICBUND, + & MaxHSSSource,MaxHSSStep,MaxHSSCells,nHSSSource,IQ, + & time1,time2,HSSData,iHSSLoc,RMASIO,DTRANS) +C ********************************************************************** +C THIS SUBROUTINE CALCULATES MASS BUDGETS ASSOCIATED WITH THE HSS +C SOURCE TERM. +C ********************************************************************** +C last modified: 02-20-2010 +C + IMPLICIT NONE + INTEGER NCOL,NROW,NLAY,NCOMP,ICOMP,ICBUND,NODES,MaxHSSStep, + & MaxHSSSource,MaxHSSCells,is,it,icell,iHSSLoc,N,iStep, + & nHSSSource,iHSSComp,IQ !IQ is iSSType for HSS source + REAL DTRANS,ctmp,ctmp1,ctmp2,tstart,tend,time1,time2, + & RMASIO,HSSData + DIMENSION ICBUND(NODES,NCOMP),RMASIO(122,2,NCOMP), + & HSSData(4+MaxHSSCells,MaxHSSStep,MaxHSSSource), + & iHSSLoc(MaxHSSCells,MaxHSSStep,MaxHSSSource) +C +C--LOOP over all HSS_LNAPL sources + DO is=1,nHSSSource +c + iHSSComp=int(HSSData(4,1,is)) + if(iHSSComp.ne.ICOMP) cycle +c + 666 DO icell=1,MaxHSSCells +c + N=iHSSLoc(icell,1,is) + IF(ICBUND(N,icomp).le.0) cycle +c + CALL TVSource(NCOL,NROW,NLAY,iStep,iCell,is, + & MaxHSSSource,MaxHSSStep,MaxHSSCells,time1,time2, + & HSSData,CTMP) +c + IF(CTMP.GT.0) THEN + RMASIO(IQ,1,ICOMP)=RMASIO(IQ,1,ICOMP)+CTMP*DTRANS + ELSE + RMASIO(IQ,2,ICOMP)=RMASIO(IQ,2,ICOMP)+CTMP*DTRANS + ENDIF + ENDDO +C + ENDDO +C +C--RETURN + RETURN + END +C +C + SUBROUTINE TVSource(NCOL,NROW,NLAY,iStep,iCell,iSource, + & MaxHSSSource,MaxHSSStep,MaxHSSCells,time1,time2,HSSData,CTMP) +C ********************************************************************** +C THIS SUBROUTINE CALCULATES AN AVERAGE MASS LOADING RATE BETWEEN TIME +C INTERVAL [Time1, Time2] FROM AN ARBITRARILY DEFINED SOURCE SERIES +C ********************************************************************** +C last modified: 02-20-2010 +C + IMPLICIT NONE + INTEGER NCOL,NROW,NLAY,isource,it,icell, + & iStep,MaxHSSSource,iTime1,iTime2, + & MaxHSSCells,MaxHSSStep,nHSSSource,iHSSComp + REAL ctmp,ctmp1,ctmp2,tstart,tend,time1,time2,HSSData, + & cmtmp,tmtmp,cTime1,cTime2,cstart,cend,ttmp + DIMENSION HSSData(4+MaxHSSCells,MaxHSSStep,MaxHSSSource) +c +c--get starting and ending indices of transport step in source series + iTime2=1 + do it=MaxHSSStep,1,-1 + ttmp=HSSData(1,it,iSource) + if(ttmp.gt.0 .and. time2.ge.ttmp ) then + iTime2=it + exit + endif + enddo +c + iTime1=1 + do it=iTime2,1,-1 + ttmp=HSSData(1,it,iSource) + if(ttmp.gt.0. and. time1.ge.ttmp) then + iTime1=it + exit + endif + enddo +c +c--get interpolated conc at beginning and ending of transport step + cTime1=0. + if(iTime1.lt.MaxHSSStep) then + cstart=HSSData(4+icell,iTime1, isource) + cend= HSSData(4+icell,iTime1+1,isource) + tstart=HSSData(1,iTime1, isource) + tend =HSSData(1,iTime1+1,isource) + if(tend.ne.tstart.and.time1.ge.tstart.and.time1.le.tend) then + cTime1=((cend-cstart)/(tend-tstart))*(time1-tstart)+cstart + endif + endif +c + cTime2=0. + if(iTime2.lt.MaxHSSStep) then + cstart=HSSData(4+icell,iTime2, isource) + cend= HSSData(4+icell,iTime2+1,isource) + tstart=HSSData(1,iTime2, isource) + tend =HSSData(1,iTime2+1,isource) + if(tend.ne.tstart.and.time2.ge.tstart.and.time2.le.tend) then + cTime2=((cend-cstart)/(tend-tstart))*(time2-tstart)+cstart + endif + endif +c +c--integrate time-averaged mass loading rate over source series + cmtmp=0. + tmtmp=0. + ctmp=0. + do it=iTime1,iTime2 + tstart=HSSData(1,it, isource) + tend =HSSData(1,it+1,isource) + cstart=HSSData(4+icell,it, isource) + cend= HSSData(4+icell,it+1,isource) + if(tend.lt.tstart) then + tend=tstart + cend=cstart + endif + if(time2.lt.tstart .or.time1.gt.tend) then + cycle + endif +c + if(time1.gt.tstart.and.time1.le.tend) then + tstart=time1 + cstart=cTime1 + endif + if(time2.gt.tstart.and.time2.le.tend) then + tend=time2 + cend=cTime2 + endif + cmtmp=cmtmp+0.5*(cstart+cend)*(tend-tstart) + tmtmp=tmtmp+(tend-tstart) + enddo + if(time2.ne.time1) ctmp=cmtmp/(time2-time1) +C +C--RETURN + RETURN + END +C +C + subroutine GetArea(ncol,nrow,nPoint,p,nSubGrid, + & delr,xbc,delc,ybc,j,i,area) +c ********************************************************************** +c This subroutine calculates the portion of a finite-difference cell +C that is intersected by a polygon defined in array P of dimension +C [nPoint]. The finite-difference cell is discritized into a subgrid +C of dimension [nSubgrid] x [nSubgrid]. +c ********************************************************************** +c last modified: 01-10-2006 +c + implicit none + integer ncol,nrow,nPoint,nSubgrid,j,i,nx,ny,nsub + real delr,delc,xbc,ybc,area,pmin,pmax,p,subpoint, + & x0,y0,dx,dy + logical inside + dimension delr(ncol),delc(nrow),xbc(ncol),ybc(nrow), + & p(2,npoint),subpoint(2),pmin(2),pmax(2) +c + pmin(1)=0 + pmin(2)=0 + pmax(1)=xbc(ncol)+0.5*delr(ncol) + pmax(2)=ybc(nrow)+0.5*delc(nrow) +c + dx=delr(j)/nSubgrid + dy=delc(i)/nSubgrid + x0=xbc(j)-0.5*delr(j)-0.5*dx + y0=ybc(i)-0.5*delc(i)-0.5*dy + nsub=0 + do nx=1,nSubgrid + subpoint(1)=x0+nx*dx + do ny=1,nSubgrid + subpoint(2)=y0+ny*dy + if(inside(npoint,p,subpoint,pmin) .and. + & inside(npoint,p,subpoint,pmax)) then + nsub=nsub+1 + endif + enddo + enddo + if(nsub.gt.0) then + area=float(nsub)/float(nSubgrid*nSubgrid)* + & delr(j)*delc(i) + else + area=0. + endif +c + return + end +C +C + LOGICAL FUNCTION INSIDE(NP,P,P1,P2) +C ......................................................... +C This function checks whether a point P1 is inside +C a polygon defined by a [NP] number of points P. If yes, +C the function returns a logical value .TRUE. Otherwise, +C it returns .FAUSE. +C ......................................................... +C last modified: 01-10-2006 +C + DIMENSION P(2,NP),P1(2),P2(2),PL1(2),PL2(2) + LOGICAL CROSS +C +C--COUNT THE THE NUMBER OF INTERSECTION +C--BETWEEN THE LINE (P1,P2) +C--AND EACH LINE SEGMENT ALONG THE POLYGON + NCOUNT=0 + NN=1 + DO 140 N=1,NP + PL1(1)=P(1,N) + PL1(2)=P(2,N) + PL2(1)=P(1,N) + PL2(2)=P(2,N) + IF(.NOT.CROSS(PL1,PL2,P1,P2)) THEN + PL2(1)=P(1,NN) + PL2(2)=P(2,NN) + NN=N + IF(CROSS(PL1,PL2,P1,P2)) THEN + NCOUNT=NCOUNT+1 + ENDIF + ENDIF + 140 CONTINUE +C +C--IF THE INTERSECTION NUMBER IS ODD, +C--THEN THE DATA POINT IS WITHIN THE POLYGON + IF(MOD(NCOUNT,2).NE.0) THEN + INSIDE=.TRUE. + ELSE + INSIDE=.FALSE. + ENDIF + 130 CONTINUE + 120 CONTINUE +C +C--PROGRAM COMPLETED + RETURN + END +C +C + LOGICAL FUNCTION CROSS(PL1,PL2,PL3,PL4) +C................................................... + DIMENSION PL1(2),PL2(2),PL3(2),PL4(2) +C + IF(SAME(PL1,PL2,PL3,PL4).lt.0. .AND. + & SAME(PL3,PL4,PL1,PL2).lt.0.) THEN + CROSS=.TRUE. + ELSE + CROSS=.FALSE. + ENDIF +C + RETURN + END +C +C + FUNCTION SAME(PL1,PL2,P1,P2) +C................................................... + DIMENSION PL1(2),PL2(2),P1(2),P2(2) +C + DX=PL2(1)-PL1(1) + DY=PL2(2)-PL1(2) + DX1=P1(1)-PL1(1) + DY1=P1(2)-PL1(2) + DX2=P2(1)-PL2(1) + DY2=P2(2)-PL2(2) + SAME=(DX*DY1-DY*DX1)*(DX*DY2-DY*DX2) +C + RETURN + END \ No newline at end of file diff --git a/true-binary/mt_rct5.for b/true-binary/mt_rct5.for index e69de29..8f5fa9f 100644 --- a/true-binary/mt_rct5.for +++ b/true-binary/mt_rct5.for @@ -0,0 +1,990 @@ +C + SUBROUTINE RCT5AL(INRCT,IOUT,ISUM,ISUM2,NCOL,NROW,NLAY,NCOMP, + & ISOTHM,IREACT,IRCTOP,IGETSC,LCRHOB,LCPRSITY2,LCRETA2,LCFRAC, + & LCSP1,LCSP2,LCRC1,LCRC2) +C ********************************************************************** +C THIS SUBROUTINE ALLOCATES SPACE FOR ARRAYS NEEDED BY THE CHEMICAL +C REACTION (RCT) PACKAGE. +C ********************************************************************** +C last modified: 02-20-2010 +C + IMPLICIT NONE + INTEGER INRCT,IOUT,ISUM,ISUM2,NCOL,NROW,NLAY,NCOMP, + & ISOTHM,IREACT,IGETSC,LCRHOB,LCPRSITY2,LCFRAC, + & LCSP1,LCSP2,LCRC1,LCRC2,LCRETA2, + & NODES,ISUMX,ISUMIX,ISOLD,ISOLD2,IRCTOP,IERR +C +C--PRINT PACKAGE NAME AND VERSION NUMBER + WRITE(IOUT,1000) INRCT + 1000 FORMAT(1X,'RCT5 -- CHEMICAL REACTION PACKAGE,', + & ' VERSION 5, FEBRUARY 2010, INPUT READ FROM UNIT',I3) +C +C--READ AND ECHO SORPTION ISOTHERM TYPE AND FLAG IREACT + READ(INRCT,'(4I10)',ERR=100,IOSTAT=IERR) + & ISOTHM,IREACT,IRCTOP,IGETSC + 100 IF(IERR.NE.0) THEN + IRCTOP=1 + IGETSC=0 + BACKSPACE (INRCT) + READ(INRCT,'(2I10)') ISOTHM,IREACT + ENDIF +C + IF(ISOTHM.EQ.1) THEN + WRITE(IOUT,1022) + ELSEIF(ISOTHM.EQ.2) THEN + WRITE(IOUT,1024) + ELSEIF(ISOTHM.EQ.3) THEN + WRITE(IOUT,1026) + ELSEIF(ISOTHM.EQ.4) THEN + WRITE(IOUT,1027) + ELSEIF(ISOTHM.EQ.5) THEN + WRITE(IOUT,2027) + ELSEIF(ISOTHM.EQ.6) THEN + WRITE(IOUT,3027) + ELSE + WRITE(IOUT,1028) + ENDIF + IF(IREACT.EQ.0) THEN + WRITE(IOUT,1030) + ELSEIF(ireact.eq.1) THEN + WRITE(IOUT,1032) + ELSEIF(ireact.eq.100) THEN + WRITE(IOUT,1034) + ENDIF + 1022 FORMAT(1X,'TYPE OF SORPTION SELECTED IS [LINEAR]') + 1024 FORMAT(1X,'TYPE OF SORPTION SELECTED IS [FREUNDLICH]') + 1026 FORMAT(1X,'TYPE OF SORPTION SELECTED IS [LANGMUIR]') + 1027 FORMAT(1X,'TYPE OF SORPTION SELECTED IS [NON-EQUILIBRIUM]') + 2027 FORMAT(1X,'DUAL DOMAIN MASS TRANSFER IS SIMULATED') + 3027 FORMAT(1X,'DUAL DOMAIN MASS TRANSFER WITH SORPTION IS SIMULATED') + 1028 FORMAT(1X,'NO SORPTION [OR DUAL-DOMAIN MODEL] IS SIMULATED') + 1030 FORMAT(1X,'NO FIRST-ORDER RATE REACTION IS SIMULATED') + 1032 FORMAT(1X,'FIRST-ORDER IRREVERSIBLE REACTION', + & ' [RADIOACTIVE DECAY OR BIODEGRADATION] IS SIMULATED') + 1034 FORMAT(1X,'ZEROTH-ORDER DECAY OR PRODUCTION IS SIMULATED') +C + IF(IRCTOP.LE.1) THEN + IRCTOP=1 + WRITE(*,1050) + ELSEIF(IRCTOP.GE.2) THEN + IRCTOP=2 + WRITE(IOUT,1052) + ENDIF + 1050 FORMAT(/1X,'WARNING: INPUT FILE FOR VER 1 OF [RCT] PACKAGE', + & ' DETECTED;'/1X,'REACTION COEFFICIENTS ASSIGNED ONE VALUE', + & ' PER LAYER'/) + 1052 FORMAT(1X,'REACTION COEFFICIENTS ASSIGNED CELL-BY-CELL') + IF(IGETSC.EQ.0) THEN + WRITE(IOUT,1060) + ELSEIF(IGETSC.GT.0.AND.ISOTHM.LE.3) THEN + WRITE(*,1061) + CALL USTOP(' ') + ELSEIF(IGETSC.GT.0.AND.ISOTHM.GT.3) THEN + WRITE(IOUT,1062) + ENDIF + 1060 FORMAT(1X,'INITIAL SORBED/IMMOBILE PHASE CONCENTRATION', + & ' ASSIGNED BY DEFAULT') + 1061 FORMAT(1X,'ERROR: INITIAL SORBED CONCENTRATION FOR', + & ' EQUILIBRIUM-CONTROLLED SORPTION CANNOT BE SPECIFIED;', + & /1X,'INPUT VALUE FOR [IGETSC] MUST BE SET TO ZERO') + 1062 FORMAT(1X,'INITIAL SORBED/IMMOBILE PHASE CONCENTRATION', + & ' READ FROM INPUT FILE') +C +C--ALLOCATE SPACE FOR ARRAYS + ISOLD=ISUM + ISOLD2=ISUM2 + NODES=NCOL*NROW*NLAY +C +C--REAL ARRAYS + LCRHOB=ISUM + IF(ISOTHM.NE.0) ISUM=ISUM+NODES + LCPRSITY2=ISUM + IF(ISOTHM.EQ.5.OR.ISOTHM.EQ.6) ISUM=ISUM+NODES + LCFRAC=ISUM + IF(ISOTHM.EQ.5.OR.ISOTHM.EQ.6) ISUM=ISUM+NODES + LCRETA2=ISUM + IF(ISOTHM.EQ.5.OR.ISOTHM.EQ.6) ISUM=ISUM+NODES * NCOMP + LCSP1=ISUM + IF(ISOTHM.NE.0) ISUM=ISUM+NODES * NCOMP + LCSP2=ISUM + IF(ISOTHM.NE.0) ISUM=ISUM+NODES * NCOMP + LCRC1=ISUM + IF(IREACT.NE.0) ISUM=ISUM+NODES * NCOMP + LCRC2=ISUM + IF(IREACT.NE.0) ISUM=ISUM+NODES * NCOMP +C +C--CHECK WHETHER ARRAYS X AND IX ARE DIMENSIONED LARGE ENOUGH + ISUMX=ISUM-ISOLD + ISUMIX=ISUM2-ISOLD2 + WRITE(IOUT,1090) ISUMX,ISUMIX + 1090 FORMAT(1X,I10,' ELEMENTS OF THE X ARRAY USED BY THE RCT PACKAGE' + & /1X,I10,' ELEMENTS OF THE IX ARRAY USED BY THE RCT PACKAGE'/) +C +C--NORMAL RETURN + RETURN + END +C +C + SUBROUTINE RCT5RP(IN,IOUT,NCOL,NROW,NLAY,NCOMP,ICBUND,COLD, + & PRSITY,ISOTHM,IREACT,IRCTOP,IGETSC,RHOB,SP1,SP2,SRCONC, + & RC1,RC2,RETA,BUFF,PRSITY2,RETA2,FRAC,RFMIN,IFMTRF,DTRCT) +C ********************************************************************** +C THIS SUBROUTINE READS AND PREPARES INPUT DATA NEEDED BY THE CHEMICAL +C REACTION (RCT) PACKAGE. +C*********************************************************************** +C last modified: 10-01-2005 +C + IMPLICIT NONE + INTEGER IN,IOUT,NCOL,NROW,NLAY,ICBUND,ISOTHM,IREACT,IFMTRF, + & J,I,K,JR,IR,KR,IRCTOP,NCOMP,IGETSC,INDEX + REAL COLD,PRSITY,RHOB,SP1,SP2,SRCONC,RC1,RC2,RETA,RFMIN, + & DTRCT,TR,BUFF,PRSITY2,FRAC,TINY,EPSILON,TOTPOR,RETA2 + CHARACTER ANAME*24 + DIMENSION ICBUND(NCOL,NROW,NLAY,NCOMP),COLD(NCOL,NROW,NLAY,NCOMP), + & PRSITY(NCOL,NROW,NLAY),RETA(NCOL,NROW,NLAY,NCOMP), + & RHOB(NCOL,NROW,NLAY),PRSITY2(NCOL,NROW,NLAY), + & FRAC(NCOL,NROW,NLAY),SRCONC(NCOL,NROW,NLAY,NCOMP), + & SP1(NCOL,NROW,NLAY,NCOMP),SP2(NCOL,NROW,NLAY,NCOMP), + & RC1(NCOL,NROW,NLAY,NCOMP),RC2(NCOL,NROW,NLAY,NCOMP), + & RETA2(NCOL,NROW,NLAY,NCOMP),BUFF(NCOL*NROW*NLAY) + PARAMETER (TINY=1.E-30,EPSILON=0.5E-6) +C +C--PRINT A HEADER + WRITE(IOUT,1000) + 1000 FORMAT(//1X,'SORPTION AND 1ST/0TH ORDER REACTION PARAMETERS', + & /1X,46('-')/) +C +C--CALL RARRAY TO READ IN SORPTION PARAMETERS IF SORPTION SIMULATED + IF(ISOTHM.LE.0) GOTO 2000 +C + IF(ISOTHM.EQ.5) GOTO 111 + ANAME='BULK DENSITY (RHOB) ' + IF(IRCTOP.EQ.2) THEN + DO K=1,NLAY + CALL RARRAY(RHOB(1,1,K),ANAME,NROW,NCOL,K,IN,IOUT) + ENDDO + ELSEIF(IRCTOP.EQ.1) THEN + CALL RARRAY(BUFF,ANAME,1,NLAY,0,IN,IOUT) + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + RHOB(J,I,K)=BUFF(K) + ENDDO + ENDDO + ENDDO + ENDIF + 111 CONTINUE +C + IF(ISOTHM.NE.5.AND.ISOTHM.NE.6) GOTO 222 + ANAME='IMMOBILE DOMAIN POROSITY' + IF(IRCTOP.EQ.2) THEN + DO K=1,NLAY + CALL RARRAY(PRSITY2(1,1,K),ANAME,NROW,NCOL,K,IN,IOUT) + ENDDO + ELSEIF(IRCTOP.EQ.1) THEN + CALL RARRAY(BUFF,ANAME,1,NLAY,0,IN,IOUT) + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + PRSITY2(J,I,K)=BUFF(K) + ENDDO + ENDDO + ENDDO + ENDIF + 222 CONTINUE +C + IF(IGETSC.EQ.0) GOTO 333 + DO INDEX=1,NCOMP + ANAME='STARTING S/IM.C COMP. NO' + WRITE(ANAME(22:24),'(I3.2)') INDEX + IF(IRCTOP.EQ.2) THEN + DO K=1,NLAY + CALL RARRAY(SRCONC(1,1,K,INDEX),ANAME,NROW,NCOL,K,IN,IOUT) + ENDDO + ELSEIF(IRCTOP.EQ.1) THEN + CALL RARRAY(BUFF,ANAME,1,NLAY,0,IN,IOUT) + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + SRCONC(J,I,K,INDEX)=BUFF(K) + ENDDO + ENDDO + ENDDO + ENDIF + ENDDO + 333 CONTINUE +C + DO INDEX=1,NCOMP + ANAME='1ST SORP. COEF. COMP. NO' + WRITE(ANAME(22:24),'(I3.2)') INDEX + IF(IRCTOP.EQ.2) THEN + DO K=1,NLAY + CALL RARRAY(SP1(1,1,K,INDEX),ANAME,NROW,NCOL,K,IN,IOUT) + ENDDO + ELSEIF(IRCTOP.EQ.1) THEN + CALL RARRAY(BUFF,ANAME,1,NLAY,0,IN,IOUT) + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + SP1(J,I,K,INDEX)=BUFF(K) + ENDDO + ENDDO + ENDDO + ENDIF + ENDDO +C + DO INDEX=1,NCOMP + ANAME='2ND SORP. COEF. COMP. NO' + WRITE(ANAME(22:24),'(I3.2)') INDEX + IF(IRCTOP.EQ.2) THEN + DO K=1,NLAY + CALL RARRAY(SP2(1,1,K,INDEX),ANAME,NROW,NCOL,K,IN,IOUT) + ENDDO + ELSEIF(IRCTOP.EQ.1) THEN + CALL RARRAY(BUFF,ANAME,1,NLAY,0,IN,IOUT) + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + SP2(J,I,K,INDEX)=BUFF(K) + ENDDO + ENDDO + ENDDO + ENDIF + ENDDO +C +C--ENSURE NO SORPTION (SP1=0) IF ISOTHM=5 +C--(ISOTHM=5 IS EQUIVALENT TO ISOTHM=6 WITH SP1=0) + IF(ISOTHM.EQ.5) THEN + DO INDEX=1,NCOMP + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + SP1(J,I,K,INDEX)=0.0 + ENDDO + ENDDO + ENDDO + ENDDO + ENDIF +C +C--PRESET FRACTION OF SORPTION SITES IN CONTACT WITH MOBILE WATER +C--TO RATIO OF MOBILE TO TOTAL POROSITIES + IF(ISOTHM.EQ.6) THEN + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + FRAC(J,I,K)=1.0 + TOTPOR=PRSITY(J,I,K)+PRSITY2(J,I,K) + IF(TOTPOR.GT.TINY) FRAC(J,I,K)=PRSITY(J,I,K)/TOTPOR + ENDDO + ENDDO + ENDDO + ENDIF +C + 2000 CONTINUE +C +C--CALL RARRAY TO READ IN 1st/0th ORDER REACTION RATE CONSTANTS +C--IF NECESSARY + IF(IREACT.ne.1.and.IREACT.ne.100) GOTO 3000 +C + DO INDEX=1,NCOMP + ANAME='SOLUTE RXN RATE: COMP NO' + WRITE(ANAME(22:24),'(I3.2)') INDEX + IF(IRCTOP.EQ.2) THEN + DO K=1,NLAY + CALL RARRAY(RC1(1,1,K,INDEX),ANAME,NROW,NCOL,K,IN,IOUT) + ENDDO + ELSEIF(IRCTOP.EQ.1) THEN + CALL RARRAY(BUFF,ANAME,1,NLAY,0,IN,IOUT) + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + RC1(J,I,K,INDEX)=BUFF(K) + ENDDO + ENDDO + ENDDO + ENDIF + ENDDO +C + DO INDEX=1,NCOMP + ANAME='SORBED RXN RATE: COMP NO' + WRITE(ANAME(22:24),'(I3.2)') INDEX + IF(IRCTOP.EQ.2) THEN + DO K=1,NLAY + CALL RARRAY(RC2(1,1,K,INDEX),ANAME,NROW,NCOL,K,IN,IOUT) + ENDDO + ELSEIF(IRCTOP.EQ.1) THEN + CALL RARRAY(BUFF,ANAME,1,NLAY,0,IN,IOUT) + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + RC2(J,I,K,INDEX)=BUFF(K) + ENDDO + ENDDO + ENDDO + ENDIF + ENDDO +C + 3000 CONTINUE +C +C--DETERMINE DEFAULT CONCENTRATION FOR THE NONEQUILIBRIUM PHASE +C--WHICH REPRESENTS SORBED PHASE IN SINGLE-DOMAIN MODEL (ISOTHM=4) +C--OR IMMOBILE-LIQUID PHASE IN DUAL-DOMAIN MODEL (ISOTHM=5 OR 6) + IF(IGETSC.EQ.0) THEN + DO INDEX=1,NCOMP + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K,INDEX).EQ.0) CYCLE + IF(ISOTHM.EQ.4) THEN + SRCONC(J,I,K,INDEX)=SP1(J,I,K,INDEX)*COLD(J,I,K,INDEX) + ELSEIF(ISOTHM.EQ.5.OR.ISOTHM.EQ.6) THEN + SRCONC(J,I,K,INDEX)=0. + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO + ENDIF +C +C--CALL [SRCT5R] TO CALCULATE RETARDATION FACTORS FOR BOTH DOMAINS +C--AND SORBED CONCENTRATION (SINGLE-DOMAIN MODEL) +C--OR IMMOBILE-LIQUID PHASE CONCENTRATION (DUAL-DOMAIN MODEL) + IF(ISOTHM.GT.0) THEN + RFMIN=1.E30 + TR=0. + DO INDEX=1,NCOMP + CALL SRCT5R(NCOL,NROW,NLAY,ICBUND(1,1,1,INDEX),PRSITY, + & COLD(1,1,1,INDEX),RETA(1,1,1,INDEX),RFMIN,RHOB, + & SP1(1,1,1,INDEX),SP2(1,1,1,INDEX),RC1(1,1,1,INDEX), + & RC2(1,1,1,INDEX),PRSITY2,RETA2(1,1,1,INDEX),FRAC, + & SRCONC(1,1,1,INDEX),ISOTHM,IREACT,TR) + ENDDO + ENDIF +C +C--CALCULATE SETPSIZE WHICH MEETS STABILITY CRITERION +C--OF 1ST ORDER REACTION TERM IF AN EXPLICIT SOLUTION SCHEME IS USED + DTRCT=1.E30 + KR=0 + IR=0 + JR=0 + IF(IREACT.ne.1.AND.ISOTHM.LE.3) GOTO 4000 +C + DO INDEX=1,NCOMP + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K,INDEX).GT.0) THEN + TR=0. + IF(IREACT.eq.1) TR=ABS(RC1(J,I,K,INDEX)) + IF(IREACT.eq.1.AND.ISOTHM.GT.0) + & TR=TR+ABS(RC2(J,I,K,INDEX)) + IF(ISOTHM.GT.4) THEN + TR=TR+ABS(SP2(J,I,K,INDEX))/PRSITY(J,I,K) + ENDIF + IF(TR.GT.TINY) TR=1./TR + IF(TR.GT.TINY.AND.TR.LT.DTRCT) THEN + DTRCT=TR + KR=K + IR=I + JR=J + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDDO +C +C--PRINT OUT INFORMATION ON DTRCT + WRITE(IOUT,3050) DTRCT,KR,IR,JR + 3050 FORMAT(/1X,'MAXIMUM STEPSIZE WHICH MEETS STABILITY CRITERION', + & ' OF THE REACTION TERM'/1X,'=',G11.4, + & ' AT K=',I4,', I=',I4,', J=',I4) +C +C--PRINT OUT RETARDATION FACTOR IF REQUESTED + 4000 IF(IFMTRF.EQ.0) GOTO 5000 +C + DO INDEX=1,NCOMP + ANAME='RETARD. FACTOR: COMP. NO' + WRITE(ANAME(22:24),'(I3.2)') INDEX + DO K=1,NLAY + CALL RPRINT(RETA(1,1,K,INDEX), + & ANAME,0,1,1,NCOL,NROW,K,IFMTRF,IOUT) + ENDDO + ENDDO +C +C--RETURN + 5000 RETURN + END +C +C + SUBROUTINE SRCT5R(NCOL,NROW,NLAY,ICBUND,PRSITY,COLD,RETA,RFMIN, + & RHOB,SP1,SP2,RC1,RC2,PRSITY2,RETA2,FRAC,SRCONC, + & ISOTHM,IREACT,DTRANS) +C ******************************************************************** +C THIS SUBROUTINE CALCULATES RETARDATION FACTOR AND CONCENTRATION +C OF SORBED (UNIT: MASS/MASS) FOR SINGLE-DOMAIN MODEL OR +C IMMOBILE-LIQUID PHASE (UNIT: MASS/VOLUME) FOR DUAL-DOMAIN MODEL. +C ******************************************************************** +C last modified: 10-01-2005 +C + IMPLICIT NONE + INTEGER NCOL,NROW,NLAY,ICBUND,ISOTHM,IREACT,J,I,K + REAL PRSITY,COLD,RETA,RFMIN,RHOB,SP1,SP2,RC1,RC2, + & PRSITY2,FRAC,SRCONC,DTRANS,TINY, + & RETA2,TERM1,RC1TMP,RC2TMP + DIMENSION PRSITY(NCOL,NROW,NLAY),ICBUND(NCOL,NROW,NLAY), + & COLD(NCOL,NROW,NLAY),RETA(NCOL,NROW,NLAY), + & RHOB(NCOL,NROW,NLAY),SRCONC(NCOL,NROW,NLAY), + & SP1(NCOL,NROW,NLAY),SP2(NCOL,NROW,NLAY), + & RC1(NCOL,NROW,NLAY),RC2(NCOL,NROW,NLAY), + & PRSITY2(NCOL,NROW,NLAY),FRAC(NCOL,NROW,NLAY), + & RETA2(NCOL,NROW,NLAY) + PARAMETER (TINY=1.E-30) +C +C--EVALUATE RETARDATION FACTOR AND SORBED CONCONCENTRATION +C--DEPENDING ON TYPES OF SORPTION SELECTED +C +C--1. LINEAR EQUILIBRIUM... + IF(ISOTHM.EQ.1) THEN + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K).EQ.0) CYCLE + RETA(J,I,K)=1.+RHOB(J,I,K)/PRSITY(J,I,K)*SP1(J,I,K) + RFMIN=MIN(RFMIN,RETA(J,I,K)) + SRCONC(J,I,K)=SP1(J,I,K)*COLD(J,I,K) + ENDDO + ENDDO + ENDDO +C +C--2. FREUNDLICH EQUILIBRIUM... + ELSEIF(ISOTHM.EQ.2) THEN + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K).EQ.0) CYCLE + IF(COLD(J,I,K).LE.0) THEN + RETA(J,I,K)=1. + SRCONC(J,I,K)=0. + ELSE + RETA(J,I,K)=1.+RHOB(J,I,K)/PRSITY(J,I,K)* + & SP1(J,I,K)*SP2(J,I,K)*COLD(J,I,K)**(SP2(J,I,K)-1.) + SRCONC(J,I,K)=SP1(J,I,K)*COLD(J,I,K)**SP2(J,I,K) + ENDIF + RFMIN=MIN(RFMIN,RETA(J,I,K)) + ENDDO + ENDDO + ENDDO +C +C--3. LANGMUIR EQUILIBRIUM... + ELSEIF(ISOTHM.EQ.3) THEN + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K).EQ.0) CYCLE + IF(COLD(J,I,K).LT.0) THEN + RETA(J,I,K)=1. + SRCONC(J,I,K)=0. + ELSE + RETA(J,I,K)=1.+RHOB(J,I,K)/PRSITY(J,I,K)* + & SP1(J,I,K)*SP2(J,I,K)/(1.+SP1(J,I,K)*COLD(J,I,K))**2 + SRCONC(J,I,K)=SP1(J,I,K)*SP2(J,I,K)*COLD(J,I,K) + & /(1.+SP1(J,I,K)*COLD(J,I,K)) + ENDIF + RFMIN=MIN(RFMIN,RETA(J,I,K)) + ENDDO + ENDDO + ENDDO +C +C--4. LINEAR NON-EQUILIBRIUM... + ELSEIF(ISOTHM.EQ.4) THEN + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K).EQ.0.OR.DTRANS.LT.TINY) CYCLE + RC2TMP=0. + IF(IREACT.eq.1.or.IREACT.eq.100) RC2TMP=RC2(J,I,K) +C--if with no reaction or with first-order reaction + if(ireact.eq.0.or.ireact.eq.1) then + SRCONC(J,I,K)=(SP2(J,I,K)*COLD(J,I,K)+ + & RHOB(J,I,K)/DTRANS*SRCONC(J,I,K))/ + & (RHOB(J,I,K)/DTRANS+SP2(J,I,K)/SP1(J,I,K) + & +RC2TMP*RHOB(J,I,K)) +C--if with zeroth-order reaction + elseif(ireact.eq.100) then + SRCONC(J,I,K)=(SP2(J,I,K)*COLD(J,I,K)+ + & RHOB(J,I,K)/DTRANS*SRCONC(J,I,K) + & -RC2TMP*RHOB(J,I,K))/ + & (RHOB(J,I,K)/DTRANS+SP2(J,I,K)/SP1(J,I,K)) + endif + ENDDO + ENDDO + ENDDO + RFMIN=1. +C +C--5/6. DUAL DOMAIN MASS TRANSFER WITHOUT/WITH LINEAR SORPTION + ELSEIF(ISOTHM.EQ.5.OR.ISOTHM.EQ.6) THEN + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K).EQ.0) CYCLE + RETA(J,I,K)=1.+FRAC(J,I,K)*RHOB(J,I,K) + & *SP1(J,I,K)/PRSITY(J,I,K) + RFMIN=MIN(RFMIN,RETA(J,I,K)) + RETA2(J,I,K)=1.0 + IF(PRSITY2(J,I,K).GT.TINY) + & RETA2(J,I,K)=1.+(1.-FRAC(J,I,K)) + & *RHOB(J,I,K)*SP1(J,I,K)/PRSITY2(J,I,K) + IF(DTRANS.LT.TINY) CYCLE + RC1TMP=0. + RC2TMP=0. + IF(IREACT.eq.1.or.IREACT.eq.100) THEN + RC1TMP=RC1(J,I,K) + RC2TMP=RC2(J,I,K) + ENDIF +C--if with no reaction or with first-order reaction + if(ireact.eq.0.or.ireact.eq.1) then + TERM1=PRSITY2(J,I,K)*RETA2(J,I,K)/DTRANS+SP2(J,I,K) + & +RC1TMP*PRSITY2(J,I,K) + & +RC2TMP*PRSITY2(J,I,K)*(RETA2(J,I,K)-1.) + SRCONC(J,I,K)=(SP2(J,I,K)*COLD(J,I,K) + & +PRSITY2(J,I,K)*RETA2(J,I,K)/DTRANS*SRCONC(J,I,K)) + & /TERM1 +C--if with zeroth-order reaction + elseif(ireact.eq.100) then + TERM1=PRSITY2(J,I,K)*RETA2(J,I,K)/DTRANS+SP2(J,I,K) + SRCONC(J,I,K)=(SP2(J,I,K)*COLD(J,I,K) + & -RC1TMP*PRSITY2(J,I,K) + & -RC2TMP*(1.-FRAC(J,I,K))*RHOB(J,I,K) + & +PRSITY2(J,I,K)*RETA2(J,I,K)/DTRANS*SRCONC(J,I,K)) + & /TERM1 + endif + ENDDO + ENDDO + ENDDO + ENDIF +C +C--RETURN + RETURN + END +C +C + SUBROUTINE RCT5FM(NCOL,NROW,NLAY,NCOMP,ICOMP,ICBUND,PRSITY, + & DELR,DELC,DH,ISOTHM,IREACT,RHOB,SP1,SP2,SRCONC,RC1,RC2, + & PRSITY2,RETA2,FRAC,A,RHS,NODES,UPDLHS,DTRANS) +C ******************************************************************* +C THIS SUBROUTINE FORMULATES THE COEFFICIENT MATRIX [A] AND THE +C RIGHT-HAND-SIDE MATRIX [RHS] FOR SORPTION AND 1ST/0TH ORDER +C REACTION TERMS USING THE IMPLICIT FINITE-DIFFERENCE SCHEME. +C ******************************************************************* +C last modified: 10-01-2005 +C + IMPLICIT NONE + INTEGER NCOL,NROW,NLAY,NCOMP,ICOMP,ICBUND,ISOTHM,IREACT, + & K,I,J,N,NODES + REAL PRSITY,RHOB,SP1,SP2,RC1,RC2,PRSITY2,FRAC,DTRANS, + & SRCONC,DELR,DELC,DH,A,RHS,RETA2,TERM1,TINY, + & RC1TMP,RC2TMP + LOGICAL UPDLHS + DIMENSION ICBUND(NODES,NCOMP),PRSITY(NODES), + & RHOB(NODES),SP1(NODES,NCOMP),SP2(NODES,NCOMP), + & RC1(NODES,NCOMP),RC2(NODES,NCOMP),SRCONC(NODES,NCOMP), + & DELR(NCOL),DELC(NROW),DH(NODES),A(NODES),RHS(NODES), + & PRSITY2(NODES),RETA2(NODES,NCOMP),FRAC(NODES) + PARAMETER (TINY=1.E-30) +C +C--CONTRIBUTIONS TO [A] AND [RHS] FROM NONEQUILIBRIUM SORPTION +C + IF(ISOTHM.EQ.4) THEN + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + N=(K-1)*NCOL*NROW+(I-1)*NCOL+J +C +C--SKIP IF INACTIVE OR CONSTANT CONCENTRATION CELL + IF(ICBUND(N,ICOMP).LE.0) CYCLE +C +C--UPDATE COEFFICIENT MATRIX A AND RHS IF NECESSARY + RC2TMP=0. + IF(IREACT.eq.1.or.IREACT.eq.100) RC2TMP=RC2(N,ICOMP) +C--if with no reaction or with first-order reaction + if(ireact.eq.0.or.ireact.eq.1) then + IF(UPDLHS) A(N)=A(N)-SP2(N,ICOMP)*DELR(J)*DELC(I) + & *DH(N)*(1.-SP2(N,ICOMP)/SP1(N,ICOMP) + & /(RHOB(N)/DTRANS+SP2(N,ICOMP)/SP1(N,ICOMP) + & +RC2TMP*RHOB(N))) + RHS(N)=RHS(N)-SP2(N,ICOMP)/SP1(N,ICOMP)*DELR(J)*DELC(I) + & *DH(N)*RHOB(N)*SRCONC(N,ICOMP)/DTRANS + & /(RHOB(N)/DTRANS+SP2(N,ICOMP)/SP1(N,ICOMP) + & +RC2TMP*RHOB(N)) +C--if with zeroth-order reaction + elseif(ireact.eq.100) then + IF(UPDLHS) A(N)=A(N)-SP2(N,ICOMP)*DELR(J)*DELC(I) + & *DH(N)*(1.-SP2(N,ICOMP)/SP1(N,ICOMP) + & /(RHOB(N)/DTRANS+SP2(N,ICOMP)/SP1(N,ICOMP))) + RHS(N)=RHS(N)+(SP2(N,ICOMP)/SP1(N,ICOMP) + & *DELR(J)*DELC(I)*DH(N)*RHOB(N) + & *(RC2TMP-SRCONC(N,ICOMP)/DTRANS)) + & /(RHOB(N)/DTRANS+SP2(N,ICOMP)/SP1(N,ICOMP)) + endif + ENDDO + ENDDO + ENDDO + ENDIF +C +C--CONTRIBUTIONS TO [A] AND [RHS] FROM DUAL-DOMAIN MASS TRANSFER +C + IF(ISOTHM.EQ.5.OR.ISOTHM.EQ.6) THEN + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + N=(K-1)*NCOL*NROW+(I-1)*NCOL+J +C +C--SKIP IF INACTIVE OR CONSTANT CONCENTRATION CELL + IF(ICBUND(N,ICOMP).LE.0) CYCLE +C +C--UPDATE COEFFICIENT MATRIX A AND RHS IF NECESSARY + RC1TMP=0. + RC2TMP=0. + IF(IREACT.eq.1.or.IREACT.eq.100) THEN + RC1TMP=RC1(N,ICOMP) + RC2TMP=RC2(N,ICOMP) + ENDIF +C--if with no reaction or with first-order reaction + if(ireact.eq.0.or.ireact.eq.1) then + TERM1=PRSITY2(N)*RETA2(N,ICOMP)/DTRANS+SP2(N,ICOMP) + & +RC1TMP*PRSITY2(N) + & +RC2TMP*PRSITY2(N)*(RETA2(N,ICOMP)-1.) + IF(UPDLHS) A(N)=A(N)-SP2(N,ICOMP) + & *DELR(J)*DELC(I)*DH(N)*(1.-SP2(N,ICOMP)/TERM1) + RHS(N)=RHS(N)-SP2(N,ICOMP) + & *PRSITY2(N)*RETA2(N,ICOMP)*DELR(J)*DELC(I)*DH(N) + & *SRCONC(N,ICOMP)/(DTRANS*TERM1) +C--if with zeroth-order reaction + elseif(ireact.eq.100) then + TERM1=PRSITY2(N)*RETA2(N,ICOMP)/DTRANS+SP2(N,ICOMP) + IF(UPDLHS) A(N)=A(N)-SP2(N,ICOMP) + & *DELR(J)*DELC(I)*DH(N)*(1.-SP2(N,ICOMP)/TERM1) + RHS(N)=RHS(N)-SP2(N,ICOMP)*DELR(J)*DELC(I)*DH(N) + & *(-RC1TMP*PRSITY2(N)-RC2TMP*(1.-FRAC(N))*RHOB(N) + & +PRSITY2(N)*RETA2(N,ICOMP)*SRCONC(N,ICOMP)/DTRANS) + & /TERM1 + endif + ENDDO + ENDDO + ENDDO + ENDIF +C +C--CONTRIBUTIONS TO [A] AND [RHS] FROM 1ST ORDER KINETIC REACTION +C + IF(ireact.eq.1) THEN + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + N=(K-1)*NCOL*NROW+(I-1)*NCOL+J +C +C--SKIP IF INACTIVE OR CONSTANT CONCENTRATION CELL + IF(ICBUND(N,ICOMP).LE.0) CYCLE +C +C--DISSOLVED PHASE + IF(UPDLHS) A(N)=A(N)-RC1(N,ICOMP)*PRSITY(N) + & *DELR(J)*DELC(I)*DH(N) +C +C--SORBED PHASE FOR EQUILIBRIUM-CONTROLLED ISOTHERMS + IF(ISOTHM.EQ.1) THEN + IF(UPDLHS) A(N)=A(N)-RC2(N,ICOMP)*RHOB(N) + & *DELR(J)*DELC(I)*DH(N)*SP1(N,ICOMP) + ELSEIF(ISOTHM.EQ.2.OR.ISOTHM.EQ.3) THEN + RHS(N)=RHS(N)+RC2(N,ICOMP)*DELR(J)*DELC(I)*DH(N) + & *RHOB(N)*SRCONC(N,ICOMP) + ELSEIF(ISOTHM.EQ.6) THEN + IF(UPDLHS) A(N)=A(N)-RC2(N,ICOMP)*FRAC(N)* + & RHOB(N)*DELR(J)*DELC(I)*DH(N)*SP1(N,ICOMP) + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF +C +C--CONTRIBUTIONS TO [A] AND [RHS] FROM ZEROTH-ORDER REACTION +C + IF(ireact.eq.100) THEN + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + N=(K-1)*NCOL*NROW+(I-1)*NCOL+J +C +C--SKIP IF INACTIVE OR CONSTANT CONCENTRATION CELL + IF(ICBUND(N,ICOMP).LE.0) CYCLE +C +C--DISSOLVED PHASE + RHS(N)=RHS(N)+RC1(N,ICOMP)*PRSITY(N) + & *DELR(J)*DELC(I)*DH(N) +C +C--SORBED PHASE FOR EQUILIBRIUM-CONTROLLED ISOTHERMS + IF(ISOTHM.EQ.1.OR.ISOTHM.EQ.2.OR.ISOTHM.EQ.3) THEN + RHS(N)=RHS(N)+RC2(N,ICOMP)*RHOB(N) + & *DELR(J)*DELC(I)*DH(N) + ELSEIF(ISOTHM.EQ.6) THEN + RHS(N)=RHS(N)+RC2(N,ICOMP)*FRAC(N)* + & RHOB(N)*DELR(J)*DELC(I)*DH(N) + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF +C +C--RETURN + RETURN + END +C +C + SUBROUTINE RCT5BD(NCOL,NROW,NLAY,NCOMP,ICOMP,ICBUND,PRSITY, + & DELR,DELC,DH,DTRANS,ISOTHM,IREACT,RHOB,SP1,SP2,SRCONC,RC1, + & RC2,PRSITY2,RETA2,FRAC,CNEW,RETA,RFMIN,RMASIO) +C ********************************************************************** +C THIS SUBROUTINE CALCULATES MASS BUDGET ASSOCIATED WITH REACTIONS. +C ********************************************************************** +C last modified: 10-01-2005 +C + IMPLICIT NONE + INTEGER NCOL,NROW,NLAY,NCOMP,ICOMP,ICBUND,ISOTHM,IREACT,K,I,J + REAL PRSITY,DTRANS,RHOB,SP1,SP2,RC1,RC2,RETA,RFMIN,RETA2, + & PRSITY2,FRAC,CNEW,RMASIO,DCRCT,SRCONC,DELR,DELC,DH, + & CMML,CMMS,CIML,CIMS,VOLUME,DCRCT2 + DIMENSION ICBUND(NCOL,NROW,NLAY,NCOMP),PRSITY(NCOL,NROW,NLAY), + & RHOB(NCOL,NROW,NLAY),RETA(NCOL,NROW,NLAY,NCOMP), + & PRSITY2(NCOL,NROW,NLAY),FRAC(NCOL,NROW,NLAY), + & SP1(NCOL,NROW,NLAY,NCOMP),SP2(NCOL,NROW,NLAY,NCOMP), + & RC1(NCOL,NROW,NLAY,NCOMP),RC2(NCOL,NROW,NLAY,NCOMP), + & CNEW(NCOL,NROW,NLAY,NCOMP),SRCONC(NCOL,NROW,NLAY,NCOMP), + & RETA2(NCOL,NROW,NLAY,NCOMP),DELR(NCOL),DELC(NROW), + & DH(NCOL,NROW,NLAY),RMASIO(122,2,NCOMP) +C +C--UPDATE RETARDATION FACTOR AND SORBED/IMMOBILE-PHASE CONCENTRATION +C + IF(ISOTHM.GT.0) THEN + CALL SRCT5R(NCOL,NROW,NLAY,ICBUND(1,1,1,ICOMP),PRSITY, + & CNEW(1,1,1,ICOMP),RETA(1,1,1,ICOMP),RFMIN,RHOB, + & SP1(1,1,1,ICOMP),SP2(1,1,1,ICOMP),RC1(1,1,1,ICOMP), + & RC2(1,1,1,ICOMP),PRSITY2,RETA2(1,1,1,ICOMP),FRAC, + & SRCONC(1,1,1,ICOMP),ISOTHM,IREACT,DTRANS) + ENDIF +C +C--CALCULATE MASS BUDGETS FOR +C--NONEQUILIBRIUM SORPTION IN SINGLE-DOMAIN MODEL +C + IF(ISOTHM.EQ.4) THEN + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL +C +C--SKIP IF INACTIVE OR CONSTANT CONCENTRATION CELL + IF(ICBUND(J,I,K,ICOMP).LE.0) CYCLE +C +C--CALCULATE SOLUTE MASS CHANGE + DCRCT=-SP2(J,I,K,ICOMP)*(CNEW(J,I,K,ICOMP) + & -SRCONC(J,I,K,ICOMP)/SP1(J,I,K,ICOMP)) + & *DTRANS*DELR(J)*DELC(I)*DH(J,I,K) +C +C--RECORD SORBED MASS STORAGE CHANGE + IF(DCRCT.LT.0) THEN + RMASIO(120,2,ICOMP)=RMASIO(120,2,ICOMP)+DCRCT + ELSE + RMASIO(120,1,ICOMP)=RMASIO(120,1,ICOMP)+DCRCT + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF +C +C--CALCULATE MASS BUDGETS FOR +C--MASS TRANSFER IN DUAL-DOMAIN MODEL +C + IF(ISOTHM.EQ.5.OR.ISOTHM.EQ.6) THEN + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL +C +C--SKIP IF INACTIVE OR CONSTANT CONCENTRATION CELL + IF(ICBUND(J,I,K,ICOMP).LE.0) CYCLE +C +C--CALCULATE CHANGE IN CONCENTRATION OF MOBILE-LIQUID PHASE + DCRCT=-SP2(J,I,K,ICOMP)*(CNEW(J,I,K,ICOMP) + & -SRCONC(J,I,K,ICOMP))*DTRANS + & *DELR(J)*DELC(I)*DH(J,I,K) +C +C--RECORD MASS STORAGE CHANGE IN IMMOBILE DOMAIN + IF(DCRCT.LT.0) THEN + RMASIO(121,2,ICOMP)=RMASIO(121,2,ICOMP)+DCRCT + & /RETA2(J,I,K,ICOMP) + RMASIO(122,2,ICOMP)=RMASIO(122,2,ICOMP)+DCRCT + & *(RETA2(J,I,K,ICOMP)-1.)/RETA2(J,I,K,ICOMP) + ELSE + RMASIO(121,1,ICOMP)=RMASIO(121,1,ICOMP)+DCRCT + & /RETA2(J,I,K,ICOMP) + RMASIO(122,1,ICOMP)=RMASIO(122,1,ICOMP)+DCRCT + & *(RETA2(J,I,K,ICOMP)-1.)/RETA2(J,I,K,ICOMP) + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF +C +C--CALCULATE MASS BUDGETS FOR +C--1st/0th ORDER IRREVERSIBLE REACTION +C + IF(IREACT.ne.1.and.IREACT.ne.100) goto 9999 +C +C--SKIP IF NOT SINGLE-DOMAIN MODEL + IF(ISOTHM.EQ.5.OR.ISOTHM.EQ.6) GOTO 1000 +C + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL +C +C--SKIP IF INACTIVE OR CONSTANT CONCENTRATION CELL + IF(ICBUND(J,I,K,ICOMP).LE.0) CYCLE +C +C--SKIP IF CONCENTRATION IS NOT POSITIVE + IF(CNEW(J,I,K,ICOMP).LE.0) CYCLE +C +C--DISSOLVED PHASE + IF(ireact.eq.1) THEN + DCRCT=-RC1(J,I,K,ICOMP)*CNEW(J,I,K,ICOMP) + & *DTRANS*DELR(J)*DELC(I)*DH(J,I,K)*PRSITY(J,I,K) + ELSEIF(ireact.eq.100) THEN + DCRCT=-RC1(J,I,K,ICOMP) + & *DTRANS*DELR(J)*DELC(I)*DH(J,I,K)*PRSITY(J,I,K) + ENDIF +C--SORBED PHASE + DCRCT2=0. + IF(ISOTHM.GT.0.and.ireact.eq.1) THEN + DCRCT2=-RC2(J,I,K,ICOMP)*RHOB(J,I,K) + & *SRCONC(J,I,K,ICOMP)*DTRANS + & *DELR(J)*DELC(I)*DH(J,I,K) + ELSEIF(ISOTHM.GT.0.and.ireact.eq.100) THEN + DCRCT2=-RC2(J,I,K,ICOMP)*RHOB(J,I,K) + & *DTRANS*DELR(J)*DELC(I)*DH(J,I,K) + ENDIF +C +C--CALCULATE MASS LOSS/GAIN DUE TO 1st/0th ORDER REACTION + IF(DCRCT+DCRCT2.LT.0) THEN + RMASIO(9,2,ICOMP)=RMASIO(9,2,ICOMP)+DCRCT+DCRCT2 + ELSE + RMASIO(9,1,ICOMP)=RMASIO(9,1,ICOMP)+DCRCT+DCRCT2 + ENDIF +C +C--UPDATE SORBED MASS STORAGE CHANGE FOR NONEQUILIBRIUM SORPTION + IF(ISOTHM.EQ.4.AND.DCRCT2.GT.0) THEN + RMASIO(120,2,ICOMP)=RMASIO(120,2,ICOMP)-DCRCT2 + ELSEIF(ISOTHM.EQ.4.AND.DCRCT2.LT.0) THEN + RMASIO(120,1,ICOMP)=RMASIO(120,1,ICOMP)-DCRCT2 + ENDIF + ENDDO + ENDDO + ENDDO +C +C--1ST/0TH ORDER REACTION IN DUAL-DOMAIN MODEL + 1000 IF(ISOTHM.NE.5.AND.ISOTHM.NE.6) GOTO 9999 +C + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL +C +C--SKIP IF INACTIVE OR CONSTANT CONCENTRATION CELL + IF(ICBUND(J,I,K,ICOMP).LE.0) CYCLE +C +C--SKIP IF CONCENTRATION IS NOT POSITIVE + IF(CNEW(J,I,K,ICOMP).LE.0) CYCLE +C +C--compute mass loss/gain in each cell for all 4 phases: +C--mobile liquid, mobile sorbed, immobile liquid, immobile sorbed + VOLUME=DELR(J)*DELC(I)*DH(J,I,K) + CMML=CNEW(J,I,K,ICOMP)*PRSITY(J,I,K)*VOLUME + CMMS=(RETA(J,I,K,ICOMP)-1.)*CMML + CIML=PRSITY2(J,I,K)*SRCONC(J,I,K,ICOMP)*VOLUME + CIMS=(RETA2(J,I,K,ICOMP)-1.)*CIML +C--for 1st-order reaction + if(ireact.eq.1) then + CMML=-RC1(J,I,K,ICOMP)*CMML*DTRANS + CMMS=-RC2(J,I,K,ICOMP)*CMMS*DTRANS + CIML=-RC1(J,I,K,ICOMP)*CIML*DTRANS + CIMS=-RC2(J,I,K,ICOMP)*CIMS*DTRANS +C--for zero-order reaction + elseif(ireact.eq.100) then + CMML=-RC1(J,I,K,ICOMP)*VOLUME*PRSITY(J,I,K)*DTRANS + CMMS=-RC2(J,I,K,ICOMP)*VOLUME*RHOB(J,I,K)*DTRANS + & *FRAC(J,I,K) + CIML=-RC1(J,I,K,ICOMP)*VOLUME*PRSITY2(J,I,K)*DTRANS + CIMS=-RC2(J,I,K,ICOMP)*VOLUME*RHOB(J,I,K)*DTRANS + & *(1.-FRAC(J,I,K)) + endif +C +C--CALCULATE MASS LOSS/GAIN DUE TO REACTION IN MOBILE DOMAIN + IF(CMML+CMMS.LT.0) THEN + RMASIO(9,2,ICOMP)=RMASIO(9,2,ICOMP)+CMML+CMMS + ELSE + RMASIO(9,1,ICOMP)=RMASIO(9,1,ICOMP)+CMML+CMMS + ENDIF +C +C--CALCULATE MASS LOSS/GAIN DUE TO REACTION IN IMMOBILE DOMAIN + IF(CIML+CIMS.LT.0) THEN + RMASIO(10,2,ICOMP)=RMASIO(10,2,ICOMP)+CIML+CIMS + ELSE + RMASIO(10,1,ICOMP)=RMASIO(10,1,ICOMP)+CIML+CIMS + ENDIF +C +C--RECORD MASS STORAGE CHANGE IN IMMOBILE DOMAIN + IF(CIML.GT.0) THEN + RMASIO(121,2,ICOMP)=RMASIO(121,2,ICOMP)-CIML + ELSE + RMASIO(121,1,ICOMP)=RMASIO(121,1,ICOMP)-CIML + ENDIF + IF(CIMS.GT.0) THEN + RMASIO(122,2,ICOMP)=RMASIO(122,2,ICOMP)-CIMS + ELSE + RMASIO(122,1,ICOMP)=RMASIO(122,1,ICOMP)-CIMS + ENDIF + ENDDO + ENDDO + ENDDO +C + 9999 CONTINUE +C +C--RETURN + RETURN + END +C +C + SUBROUTINE RCT5CF(NCOL,NROW,NLAY,NCOMP,ICOMP,ICBUND,PRSITY, + & COLD,RETA,RFMIN,RHOB,SP1,SP2,RC1,RC2,PRSITY2,RETA2,FRAC, + & SRCONC,ISOTHM,IREACT,DTRANS) +C ******************************************************************** +C THIS SUBROUTINE UPDATES NONLINEAR REACTION COEFFICIENTS. +C ******************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER NCOL,NROW,NLAY,NCOMP,ICOMP,ICBUND,ISOTHM,IREACT + REAL PRSITY,COLD,RETA,RFMIN,RHOB,SP1,SP2,SRCONC,DTRANS, + & RC1,RC2,PRSITY2,RETA2,FRAC + DIMENSION PRSITY(NCOL,NROW,NLAY),ICBUND(NCOL,NROW,NLAY,NCOMP), + & COLD(NCOL,NROW,NLAY,NCOMP),RETA(NCOL,NROW,NLAY,NCOMP), + & RHOB(NCOL,NROW,NLAY),SRCONC(NCOL,NROW,NLAY,NCOMP), + & SP1(NCOL,NROW,NLAY,NCOMP),SP2(NCOL,NROW,NLAY,NCOMP), + & RC1(NCOL,NROW,NLAY,NCOMP),RC2(NCOL,NROW,NLAY,NCOMP), + & PRSITY2(NCOL,NROW,NLAY),FRAC(NCOL,NROW,NLAY), + & RETA2(NCOL,NROW,NLAY,NCOMP) +C + IF(ISOTHM.EQ.2.OR.ISOTHM.EQ.3) THEN + CALL SRCT5R(NCOL,NROW,NLAY,ICBUND(1,1,1,ICOMP),PRSITY, + & COLD(1,1,1,ICOMP),RETA(1,1,1,ICOMP),RFMIN,RHOB, + & SP1(1,1,1,ICOMP),SP2(1,1,1,ICOMP),RC1(1,1,1,ICOMP), + & RC2(1,1,1,ICOMP),PRSITY2,RETA2(1,1,1,ICOMP),FRAC, + & SRCONC(1,1,1,ICOMP),ISOTHM,IREACT,DTRANS) + ENDIF +C +C--RETURN + RETURN + END \ No newline at end of file diff --git a/true-binary/mt_ssm5.for b/true-binary/mt_ssm5.for index e69de29..1c04754 100644 --- a/true-binary/mt_ssm5.for +++ b/true-binary/mt_ssm5.for @@ -0,0 +1,857 @@ +C + SUBROUTINE SSM5AL(INSSM,IOUT,ISSGOUT,ISUM,ISUM2,NCOL,NROW,NLAY, + & NCOMP,LCIRCH,LCRECH,LCCRCH,LCIEVT,LCEVTR,LCCEVT,MXSS,LCSS, + & IVER,LCSSMC,LCSSG) +C ********************************************************************** +C THIS SUBROUTINE ALLOCATES SPACE FOR ARRAYS NEEDED IN THE SINK & SOURCE +C MIXING (SSM) PACKAGE. +C ********************************************************************** +C last modified: 02-20-2010 +C + IMPLICIT NONE + INTEGER INSSM,IOUT,ISSGOUT,ISUM,ISUM2,NCOL,NROW,NLAY,NCOMP, + & LCIRCH,LCRECH,LCCRCH,LCIEVT,LCEVTR,LCCEVT,MXSS,LCSS, + & ISUMX,ISUMIX,NCR,ISOLD,ISOLD2,IVER,LCSSMC,LCSSG, + & IERR,IOSTAT + CHARACTER LINE*200 + LOGICAL FWEL,FDRN,FRCH,FEVT,FRIV,FGHB,FSTR,FRES,FFHB,FIBS, + & FTLK,FLAK,FMNW,FDRT,FETS,FSWT,FSFR,FUZF + COMMON /FC/FWEL,FDRN,FRCH,FEVT,FRIV,FGHB,FSTR,FRES,FFHB,FIBS, + & FTLK,FLAK,FMNW,FDRT,FETS,FSWT,FSFR,FUZF +C +C--PRINT PACKAGE NAME AND VERSION NUMBER + WRITE(IOUT,1000) INSSM + 1000 FORMAT(1X,'SSM5 -- SINK & SOURCE MIXING PACKAGE,', + & ' VERSION 5, FEBRUARY 2010, INPUT READ FROM UNIT',I3) +C +C--READ AND PRINT FLAGS INDICATING WHICH SINK/SOURCE OPTIONS +C--ARE USED IN FLOW MODEL + IF(IVER.EQ.1) THEN + READ(INSSM,'(6L2)') FWEL,FDRN,FRCH,FEVT,FRIV,FGHB + ELSEIF(IVER.EQ.2) THEN + READ(INSSM,'(A)') LINE + WRITE(IOUT,1010) LINE + ENDIF + WRITE(IOUT,1020) + IF(FWEL) WRITE(IOUT,1340) + IF(FDRN) WRITE(IOUT,1342) + IF(FRCH) WRITE(IOUT,1344) + IF(FEVT) WRITE(IOUT,1346) + IF(FRIV) WRITE(IOUT,1348) + IF(FGHB) WRITE(IOUT,1350) + IF(FSTR) WRITE(IOUT,1400) + IF(FRES) WRITE(IOUT,1402) + IF(FFHB) WRITE(IOUT,1404) + IF(FIBS) WRITE(IOUT,1406) + IF(FTLK) WRITE(IOUT,1408) + IF(FLAK) WRITE(IOUT,1410) + IF(FMNW) WRITE(IOUT,1412) + IF(FDRT) WRITE(IOUT,1414) + IF(FETS) WRITE(IOUT,1416) + IF(FSWT) WRITE(IOUT,1418) + IF(FSFR) WRITE(IOUT,1420) + IF(FUZF) WRITE(IOUT,1422) + 1010 FORMAT(1X,'HEADER LINE OF THE SSM PACKAGE INPUT FILE:',/1X,A) + 1020 FORMAT(1X,'MAJOR STRESS COMPONENTS PRESENT IN THE FLOW MODEL:') + 1340 FORMAT(1X,' o WELL [WEL]') + 1342 FORMAT(1X,' o DRAIN [DRN]') + 1344 FORMAT(1X,' o RECHARGE [RCH]') + 1346 FORMAT(1X,' o EVAPOTRANSPIRATION [EVT]') + 1348 FORMAT(1X,' o RIVER [RIV]') + 1350 FORMAT(1X,' o GENERAL-HEAD-DEPENDENT BOUNDARY [GHB]') + 1400 FORMAT(1X,' o STREAM [STR]') + 1402 FORMAT(1X,' o RESERVOIR [RES]') + 1404 FORMAT(1X,' o SPECIFIED-HEAD-FLOW BOUNDARY [FHB]') + 1406 FORMAT(1X,' o INTERBED STORAGE [IBS]') + 1408 FORMAT(1X,' o TRANSIENT LEAKAGE [TLK]') + 1410 FORMAT(1X,' o LAKE [LAK]') + 1412 FORMAT(1X,' o MULTI-NODE WELL [MNW]') + 1414 FORMAT(1X,' o DRAIN WITH RETURN FLOW [DRT]') + 1416 FORMAT(1X,' o SEGMENTED EVAPOTRANSPIRATION [ETS]') + 1418 FORMAT(1X,' o SUBSIDENCE-WATER TABLE [SWT]') + 1420 FORMAT(1X,' o STREAMFLOW-ROUTING [SFR]') + 1422 FORMAT(1X,' o UNSATURATED-ZONE FLOW [UZF]') +C +C--READ AND PRINT MAXIMUM NUMBER OF +C--POINT SINKS/SOURCES PRESENT IN THE FLOW MODEL + ISSGOUT=0 + READ(INSSM,'(2I10)',ERR=1,IOSTAT=IERR) MXSS,ISSGOUT + 1 IF(IERR.NE.0) THEN + BACKSPACE (INSSM) + READ(INSSM,'(I10)') MXSS + ENDIF + WRITE(IOUT,1580) MXSS + 1580 FORMAT(1X,'MAXIMUM NUMBER OF POINT SINKS/SOURCES =',I8) + IF(ISSGOUT.GT.0) THEN + WRITE(IOUT,1582) ISSGOUT + 1582 FORMAT(1X,'AVERAGE CONCENTRATIONS FOR LINKED GROUP', + & ' SINKS/SOURCES SAVED In UNIT:',I3) + ENDIF +C +C--ALLOCATE SPACE FOR ARRAYS + ISOLD=ISUM + ISOLD2=ISUM2 + NCR=NCOL*NROW +C +C--INTEGER ARRAYS + LCIRCH=ISUM2 + IF(FRCH) ISUM2=ISUM2+NCR + LCIEVT=ISUM2 + IF(FEVT.OR.FETS) ISUM2=ISUM2+NCR +C +C--REAL ARRAYS + LCRECH=ISUM + IF(FRCH) ISUM=ISUM+NCR + LCCRCH=ISUM + IF(FRCH) ISUM=ISUM+NCR * NCOMP + LCEVTR=ISUM + IF(FEVT.OR.FETS) ISUM=ISUM+NCR + LCCEVT=ISUM + IF(FEVT.OR.FETS) ISUM=ISUM+NCR * NCOMP + LCSS=ISUM + ISUM=ISUM + 7*MXSS + LCSSMC=ISUM + ISUM=ISUM+NCOMP*MXSS + LCSSG=ISUM + ISUM=ISUM + 5*MXSS +C +C--CHECK HOW MANY ELEMENTS OF ARRAYS X AND IX ARE USED + ISUMX=ISUM-ISOLD + ISUMIX=ISUM2-ISOLD2 + WRITE(IOUT,1090) ISUMX,ISUMIX + 1090 FORMAT(1X,I10,' ELEMENTS OF THE X ARRAY USED BY THE SSM PACKAGE' + & /1X,I10,' ELEMENTS OF THE IX ARRAY BY THE SSM PACKAGE'/) +C +C--NORMAL RETURN + RETURN + END +C +C + SUBROUTINE SSM5RP(IN,IOUT,KPER,NCOL,NROW,NLAY,NCOMP,ICBUND,CNEW, + & CRCH,CEVT,MXSS,NSS,SS,SSMC) +C ******************************************************************** +C THIS SUBROUTINE READS CONCENTRATIONS OF SOURCES OR SINKS NEEDED BY +C THE SINK AND SOURCE MIXING (SSM) PACKAGE. +C ******************************************************************** +C last modified: 02-20-2010 +C + IMPLICIT NONE + INTEGER IN,IOUT,KPER,NCOL,NROW,NLAY,NCOMP,ICBUND, + & MXSS,NSS,JJ,II,KK,NUM,IQ,INCRCH,INCEVT,NTMP,INDEX + REAL CRCH,CEVT,SS,SSMC,CSS,CNEW + LOGICAL FWEL,FDRN,FRIV,FGHB,FRCH,FEVT,FSTR,FRES,FFHB,FIBS, + & FTLK,FLAK,FMNW,FDRT,FETS,FSWT,FSFR,FUZF + CHARACTER ANAME*24,TYPESS(-1:100)*15 + DIMENSION SS(7,MXSS),SSMC(NCOMP,MXSS),CRCH(NCOL,NROW,NCOMP), + & CEVT(NCOL,NROW,NCOMP), + & ICBUND(NCOL,NROW,NLAY,NCOMP),CNEW(NCOL,NROW,NLAY,NCOMP) + COMMON /FC/FWEL,FDRN,FRCH,FEVT,FRIV,FGHB,FSTR,FRES,FFHB,FIBS, + & FTLK,FLAK,FMNW,FDRT,FETS,FSWT,FSFR,FUZF +C +C--INITIALIZE. + TYPESS(-1)='CONSTANT CONC. ' + TYPESS(1) ='CONSTANT HEAD ' + TYPESS(2) ='WELL ' + TYPESS(3) ='DRAIN ' + TYPESS(4) ='RIVER ' + TYPESS(5) ='HEAD DEP BOUND ' + TYPESS(15)='MASS LOADING ' + TYPESS(21)='STREAM ' + TYPESS(22)='RESERVOIR ' + TYPESS(23)='SP FLW HD BOUND' + TYPESS(24)='INTERBED STRG ' + TYPESS(25)='TRANSIENT LEAK ' + TYPESS(26)='LAKE ' + TYPESS(27)='MULTI-NODE WELL' + TYPESS(28)='DRN W RET FLOW ' + TYPESS(29)='SEGMENTED ET ' + TYPESS(50)='HSS MAS LOADING' + TYPESS(51)='SUBSIDENCE-WT ' + TYPESS(52)='STREAM FL ROUT.' + TYPESS(53)='UNSAT ZONE FLOW' +C +C--READ CONCENTRATION OF DIFFUSIVE SOURCES/SINKS (RECHARGE/E.T.) +C--FOR CURRENT STRESS PERIOD IF THEY ARE SIMULATED IN FLOW MODEL + IF(.NOT.FRCH) GOTO 10 +C +C--READ FLAG INCRCH INDICATING HOW TO READ RECHARGE CONCENTRATION + READ(IN,'(I10)') INCRCH +C +C--IF INCRCH < 0, CONCENTRATIN REUSED FROM LAST STRESS PERIOD + IF(INCRCH.LT.0) THEN + WRITE(IOUT,1) + GOTO 10 + ENDIF + 1 FORMAT(/1X,'CONCENTRATION OF RECHARGE FLUXES', + & ' REUSED FROM LAST STRESS PERIOD') +C +C--IF INCRCH >= 0, READ AN ARRAY +C--CONTAING CONCENTRATION OF RECHARGE FLUX [CRCH] + WRITE(IOUT,2) KPER + ANAME='RECH. CONC. COMP. NO.' + DO INDEX=1,NCOMP + WRITE(ANAME(19:21),'(I3.2)') INDEX + CALL RARRAY(CRCH(1,1,INDEX),ANAME,NROW,NCOL,0,IN,IOUT) + ENDDO + 2 FORMAT(/1X,'CONCENTRATION OF RECHARGE FLUXES', + & ' WILL BE READ IN STRESS PERIOD',I3) +C +C--READ CONCENTRAION OF EVAPOTRANSPIRATION FLUX + 10 IF(.NOT.FEVT .AND. .NOT.FETS) GOTO 20 +C + IF(KPER.EQ.1) THEN + DO INDEX=1,NCOMP + DO II=1,NROW + DO JJ=1,NCOL + CEVT(JJ,II,INDEX)=-1.E-30 + ENDDO + ENDDO + ENDDO + ENDIF + READ(IN,'(I10)') INCEVT + IF(INCEVT.LT.0) THEN + WRITE(IOUT,11) + GOTO 20 + ENDIF + 11 FORMAT(/1X,'CONCENTRATION OF E. T. FLUXES', + & ' REUSED FROM LAST STRESS PERIOD') +C + WRITE(IOUT,12) KPER + ANAME='E. T. CONC. COMP. NO.' + DO INDEX=1,NCOMP + WRITE(ANAME(19:21),'(I3.2)') INDEX + CALL RARRAY(CEVT(1,1,INDEX),ANAME,NROW,NCOL,0,IN,IOUT) + ENDDO + 12 FORMAT(/1X,'CONCENTRATION OF E. T. FLUXES', + & ' WILL BE READ IN STRESS PERIOD',I3) +C + 20 CONTINUE +C +C--READ AND ECHO POINT SINKS/SOURCES OF SPECIFIED CONCENTRATIONS + READ(IN,'(I10)') NTMP +C +C--RESET OLD CONCENTRATIONS IF REUSE OPTION NOT IN EFFECT + IF(KPER.GT.1.AND.NTMP.GE.0) THEN + DO NUM=1,NSS + SS(4,NUM)=0. + DO INDEX=1,NCOMP + SSMC(INDEX,NUM)=0. + ENDDO + ENDDO + ENDIF +C + IF(NTMP.GT.MXSS) THEN + WRITE(*,30) + CALL USTOP(' ') + ELSEIF(NTMP.LT.0) THEN + WRITE(IOUT,40) + RETURN + ELSEIF(NTMP.EQ.0) THEN + WRITE(IOUT,50) NTMP,KPER + NSS=0 + RETURN + ELSE + NSS=NTMP + ENDIF +C + WRITE(IOUT,60) + DO NUM=1,NSS +C + IF(NCOMP.EQ.1) THEN + READ(IN,'(3I10,F10.0,I10)') KK,II,JJ,CSS,IQ + SSMC(1,NUM)=CSS + ELSE + READ(IN,'(3I10,F10.0,I10)',ADVANCE='NO') KK,II,JJ,CSS,IQ + READ(IN,*) (SSMC(INDEX,NUM),INDEX=1,NCOMP) + ENDIF +C + IF(IQ.EQ.-1) THEN + DO INDEX=1,NCOMP + IF(SSMC(INDEX,NUM).GE.0) THEN + CNEW(JJ,II,KK,INDEX)=SSMC(INDEX,NUM) + ICBUND(JJ,II,KK,INDEX)=-ABS(ICBUND(JJ,II,KK,INDEX)) + ENDIF + ENDDO + ELSEIF(IQ.EQ.15) THEN + SS(5,NUM)=0. + ELSEIF(IQ.EQ.2.AND.CSS.LT.0) THEN + NTMP=-INT(CSS) + IF(NTMP.LT.1.OR.NTMP.GT.NCOL*NROW*NLAY) THEN + WRITE(*,79) + CALL USTOP(' ') + ENDIF + ELSEIF(IQ.LT.1.OR.IQ.GT.100) THEN + WRITE(*,80) + CALL USTOP(' ') + ENDIF + SS(1,NUM)=KK + SS(2,NUM)=II + SS(3,NUM)=JJ + SS(4,NUM)=CSS + SS(6,NUM)=IQ +C + DO INDEX=1,NCOMP + CSS=SSMC(INDEX,NUM) + IF(CSS.NE.0 .OR. ICBUND(JJ,II,KK,INDEX).LT.0) + & WRITE(IOUT,70) NUM,KK,II,JJ,CSS,TYPESS(IQ),INDEX + IF(CSS.LT.0 .AND. IQ.EQ.2) + & WRITE(IOUT,71) -INT(CSS) + ENDDO +C + ENDDO + 30 FORMAT(/1X,'ERROR: MAXIMUM NUMBER OF POINT SINKS/SOURCES', + & ' EXCEEDED'/1X,'INCREASE [MXSS] IN SSM INPUT FILE') + 40 FORMAT(/1X,'POINT SINKS/SOURCES OF SPECIFIED CONCENTRATION', + & ' REUSED FROM LAST STRESS PERIOD') + 50 FORMAT(/1X,'NO. OF POINT SINKS/SOURCES OF SPECIFIED', + & ' CONCONCENTRATIONS =',I5,' IN STRESS PERIOD',I3) + 60 FORMAT(/5X,' NO LAYER ROW COLUMN CONCENTRATION', + & ' TYPE COMPONENT') + 70 FORMAT(3X,4(I5,3X),1X,G15.7,5X,A15,I6) + 71 FORMAT(8X,'>>RECIRCULATION WELL; INPUT CONCENTRATION', + & ' FROM NODE #',I10.8) + 79 FORMAT(/1X,'ERROR: INVALID CELL LOCATION FOR RECIRCULATION', + & /1X,' WELL CONCENTRATION IN THE SSM INPUT FILE') + 80 FORMAT(/1X,'ERROR: INVALID CODE FOR POINT SINK/SOURCE TYPE', + & /1X,' IN THE SSM INPUT FILE') +C +C--RETURN + RETURN + END +C +C + SUBROUTINE SSM5FM(NCOL,NROW,NLAY,NCOMP,ICOMP,ICBUND,DELR,DELC, + & DH,IRCH,RECH,CRCH,IEVT,EVTR,CEVT,MXSS,NTSS,SS,SSMC,SSG, + & QSTO,CNEW,ISS,A,RHS,NODES,UPDLHS,MIXELM) +C ****************************************************************** +C THIS SUBROUTINE FORMULATES MATRIX COEFFICIENTS FOR THE SINK/ +C SOURCE TERMS UNDER THE IMPLICIT FINITE-DIFFERENCE SCHEME. +C ****************************************************************** +C last modified: 02-20-2010 +C + IMPLICIT NONE + INTEGER NCOL,NROW,NLAY,NCOMP,ICOMP,ICBUND,IRCH,IEVT,MXSS, + & NTSS,NUM,IQ,K,I,J,ISS,N,NODES,MIXELM,IGROUP, + & MHOST,KHOST,IHOST,JHOST + REAL CNEW,RECH,CRCH,EVTR,CEVT,SS,SSMC,SSG, + & CTMP,QSS,QCTMP,DELR,DELC,DH,QSTO,A,RHS + LOGICAL UPDLHS,FWEL,FDRN,FRCH,FEVT,FRIV,FGHB,FSTR,FRES, + & FFHB,FIBS,FTLK,FLAK,FMNW,FDRT,FETS,FSWT,FSFR,FUZF + DIMENSION ICBUND(NCOL,NROW,NLAY,NCOMP),SS(7,MXSS),SSG(5,MXSS), + & SSMC(NCOMP,MXSS),RECH(NCOL,NROW),IRCH(NCOL,NROW), + & CRCH(NCOL,NROW,NCOMP),EVTR(NCOL,NROW), + & IEVT(NCOL,NROW),CEVT(NCOL,NROW,NCOMP), + & DELR(NCOL),DELC(NROW),CNEW(NCOL,NROW,NLAY,NCOMP), + & DH(NCOL,NROW,NLAY),QSTO(NCOL,NROW,NLAY), + & A(NODES),RHS(NODES) + COMMON /FC/FWEL,FDRN,FRCH,FEVT,FRIV,FGHB,FSTR,FRES,FFHB,FIBS, + & FTLK,FLAK,FMNW,FDRT,FETS,FSWT,FSFR,FUZF +C +C--DETERMINE AVERAGE CONCENTRATION FOR LINKED SINK/SOURCE GROUPS + CALL CGROUP(NCOL,NROW,NLAY,NCOMP,ICOMP,MXSS,NTSS, + & SS,SSMC,SSG,ICBUND,CNEW,DELR,DELC,DH) +C +C--FORMULATE [A] AND [RHS] MATRICES FOR EULERIAN SCHEMES + IF(MIXELM.GT.0) GOTO 1000 +C +C--TRANSIENT FLUID STORAGE TERM + IF(ISS.EQ.0 .AND. UPDLHS) THEN + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K,ICOMP).GT.0) THEN + N=(K-1)*NCOL*NROW+(I-1)*NCOL+J + A(N)=A(N)+QSTO(J,I,K)*DELR(J)*DELC(I)*DH(J,I,K) + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF +C +C--AREAL SINK/SOURCE TERMS +C--(RECHARGE) + IF(.NOT.FRCH) GOTO 10 + DO I=1,NROW + DO J=1,NCOL + K=IRCH(J,I) + IF(K.GT.0 .AND. ICBUND(J,I,K,ICOMP).GT.0) THEN + N=(K-1)*NCOL*NROW+(I-1)*NCOL+J + IF(RECH(J,I).LT.0) THEN + IF(UPDLHS) A(N)=A(N)+RECH(J,I)*DELR(J)*DELC(I)*DH(J,I,K) + ELSE + RHS(N)=RHS(N) + & -RECH(J,I)*CRCH(J,I,ICOMP)*DELR(J)*DELC(I)*DH(J,I,K) + ENDIF + ENDIF + ENDDO + ENDDO +C +C--(EVAPOTRANSPIRATION) + 10 IF(.NOT.FEVT .AND. .NOT.FETS) GOTO 20 + DO I=1,NROW + DO J=1,NCOL + K=IEVT(J,I) + IF(K.GT.0 .AND. ICBUND(J,I,K,ICOMP).GT.0) THEN + N=(K-1)*NCOL*NROW+(I-1)*NCOL+J + IF(EVTR(J,I).LT.0.AND.(CEVT(J,I,ICOMP).LT.0 .OR. + & CEVT(J,I,ICOMP).GE.CNEW(J,I,K,ICOMP))) THEN + IF(UPDLHS) A(N)=A(N)+EVTR(J,I)*DELR(J)*DELC(I)*DH(J,I,K) + ELSEIF(CEVT(J,I,ICOMP).GT.0) THEN + RHS(N)=RHS(N) + & -EVTR(J,I)*CEVT(J,I,ICOMP)*DELR(J)*DELC(I)*DH(J,I,K) + ENDIF + ENDIF + ENDDO + ENDDO +C +C--POINT SINK/SOURCE TERMS + 20 DO NUM=1,NTSS + K=SS(1,NUM) + I=SS(2,NUM) + J=SS(3,NUM) + CTMP=SS(4,NUM) + IF(NCOMP.GT.1) CTMP=SSMC(ICOMP,NUM) + QSS=SS(5,NUM) + IQ=SS(6,NUM) + IF(ICBUND(J,I,K,ICOMP).LE.0.OR.IQ.LE.0) CYCLE +C +C--RESET QSS FOR MASS-LOADING SOURCES (IQ=15) + IF(IQ.EQ.15) THEN + QSS=1./(DELR(J)*DELC(I)*DH(J,I,K)) +C +C--GET AVERAGE CONC FOR LINKED SINK/SOURCE GROUPS (IQ=27) + ELSEIF(IQ.EQ.27) THEN + IGROUP=SS(7,NUM) + CTMP=SSG(4,IGROUP) +C +C--GET RETURN FLOW CONC FOR DRAINS WITH RETURN FLOW (IQ=28) + ELSEIF(IQ.EQ.28 .AND. QSS.GT.0) THEN + MHOST=SS(7,NUM) + KHOST=(MHOST-1)/(NCOL*NROW) + 1 + IHOST=MOD((MHOST-1),NCOL*NROW)/NCOL + 1 + JHOST=MOD((MHOST-1),NCOL) + 1 + CTMP=CNEW(JHOST,IHOST,KHOST,ICOMP) +C +C--GET CONCENTRATION FOR RECIRCULATED INJECTION WELL +C--(IF INPUT CONCENTRATION WAS SET TO A NEGATIVE INTEGER) + ELSEIF(IQ.EQ.2 .AND. CTMP.LT.0 .AND. QSS.GT.0) THEN + MHOST=-INT(CTMP) + KHOST=(MHOST-1)/(NCOL*NROW) + 1 + IHOST=MOD((MHOST-1),NCOL*NROW)/NCOL + 1 + JHOST=MOD((MHOST-1),NCOL) + 1 + CTMP=CNEW(JHOST,IHOST,KHOST,ICOMP) + ENDIF +C +C--ADD CONTRIBUTIONS TO MATRICES [A] AND [RHS] + N=(K-1)*NCOL*NROW+(I-1)*NCOL+J + IF(QSS.LT.0) THEN + IF(UPDLHS) A(N)=A(N)+QSS*DELR(J)*DELC(I)*DH(J,I,K) + ELSE + RHS(N)=RHS(N)-QSS*CTMP*DELR(J)*DELC(I)*DH(J,I,K) + ENDIF + ENDDO +C +C--DONE WITH EULERIAN SCHEMES + GOTO 2000 +C +C--FORMULATE [A] AND [RHS] MATRICES FOR EULERIAN-LAGRANGIAN SCHEMES + 1000 CONTINUE +C +C--AREAL SINK/SOURCE TERMS +C--(RECHARGE) + IF(.NOT.FRCH) GOTO 30 + DO I=1,NROW + DO J=1,NCOL + K=IRCH(J,I) + IF(K.GT.0 .AND. ICBUND(J,I,K,ICOMP).GT.0 + & .AND. RECH(J,I).GT.0) THEN + N=(K-1)*NCOL*NROW+(I-1)*NCOL+J + IF(UPDLHS) A(N)=A(N)-RECH(J,I)*DELR(J)*DELC(I)*DH(J,I,K) + RHS(N)=RHS(N) + & -RECH(J,I)*CRCH(J,I,ICOMP)*DELR(J)*DELC(I)*DH(J,I,K) + ENDIF + ENDDO + ENDDO +C +C--(EVAPOTRANSPIRATION) + 30 IF(.NOT.FEVT .AND. .NOT.FETS) GOTO 40 + DO I=1,NROW + DO J=1,NCOL + K=IEVT(J,I) + IF(K.GT.0 .AND. ICBUND(J,I,K,ICOMP).GT.0) THEN + N=(K-1)*NCOL*NROW+(I-1)*NCOL+J + IF(EVTR(J,I).LT.0.AND.(CEVT(J,I,ICOMP).LT.0 .OR. + & CEVT(J,I,ICOMP).GE.CNEW(J,I,K,ICOMP))) THEN + CYCLE + ELSEIF(CEVT(J,I,ICOMP).GE.0) THEN + IF(UPDLHS) A(N)=A(N)-EVTR(J,I)*DELR(J)*DELC(I)*DH(J,I,K) + RHS(N)=RHS(N) + & -EVTR(J,I)*CEVT(J,I,ICOMP)*DELR(J)*DELC(I)*DH(J,I,K) + ENDIF + ENDIF + ENDDO + ENDDO +C +C--POINT SINK/SOURCE TERMS + 40 DO NUM=1,NTSS + K=SS(1,NUM) + I=SS(2,NUM) + J=SS(3,NUM) + CTMP=SS(4,NUM) + IF(NCOMP.GT.1) CTMP=SSMC(ICOMP,NUM) + QSS=SS(5,NUM) + IQ=SS(6,NUM) +C +C--SKIP IF NOT ACTIVE CELL + IF(ICBUND(J,I,K,ICOMP).LE.0.OR.IQ.LE.0) CYCLE +C +C--SKIP IF SINK CELL + IF(QSS.LE.0.AND.IQ.NE.15) CYCLE +C +C--COMPUTE PRODUCT OF Q*C + QCTMP=QSS*CTMP +C +C--RESET Q*C FOR MASS-LOADING SOURCES (IQ=15) + IF(IQ.EQ.15) THEN + QSS=1./(DELR(J)*DELC(I)*DH(J,I,K)) + QCTMP=QSS*CTMP + QSS=0. +C +C--RESET Q*C FOR LINKED SINK/SOURCE GROUPS (IQ=27) + ELSEIF(IQ.EQ.27) THEN + IGROUP=SS(7,NUM) + CTMP=SSG(4,IGROUP) + QCTMP=QSS*CTMP +C +C--RESET Q*C FOR DRAINS WITH RETURN FLOW (IQ=28) + ELSEIF(IQ.EQ.28.AND.QSS.GT.0) THEN + MHOST=SS(7,NUM) + KHOST=(MHOST-1)/(NCOL*NROW) + 1 + IHOST=MOD((MHOST-1),NCOL*NROW)/NCOL + 1 + JHOST=MOD((MHOST-1),NCOL) + 1 + CTMP=CNEW(JHOST,IHOST,KHOST,ICOMP) + QCTMP=QSS*CTMP +C +C--GET CONCENTRATION FOR RECIRCULATED INJECTION WELL +C--(IF INPUT CONCENTRATION WAS SET TO A NEGATIVE INTEGER) + ELSEIF(IQ.EQ.2 .AND. CTMP.LT.0 .AND. QSS.GT.0) THEN + MHOST=-INT(CTMP) + KHOST=(MHOST-1)/(NCOL*NROW) + 1 + IHOST=MOD((MHOST-1),NCOL*NROW)/NCOL + 1 + JHOST=MOD((MHOST-1),NCOL) + 1 + CTMP=CNEW(JHOST,IHOST,KHOST,ICOMP) + QCTMP=QSS*CTMP + ENDIF +C +C--ADD CONTRIBUTIONS TO MATRICES [A] AND [RHS] + N=(K-1)*NCOL*NROW+(I-1)*NCOL+J + IF(UPDLHS) A(N)=A(N)-QSS*DELR(J)*DELC(I)*DH(J,I,K) + RHS(N)=RHS(N)-QCTMP*DELR(J)*DELC(I)*DH(J,I,K) + ENDDO +C +C--DONE WITH EULERIAN-LAGRANGIAN SCHEMES + 2000 CONTINUE +C +C--RETURN + RETURN + END +C +C + SUBROUTINE SSM5BD(NCOL,NROW,NLAY,NCOMP,ICOMP,ICBUND,DELR,DELC, + & DH,IRCH,RECH,CRCH,IEVT,EVTR,CEVT,MXSS,NTSS,SS,SSMC,SSG, + & QSTO,CNEW,RETA,DTRANS,ISS,RMASIO) +C ******************************************************************** +C THIS SUBROUTINE CALCULATES MASS BUDGETS ASSOCIATED WITH ALL SINK/ +C SOURCE TERMS. +C ******************************************************************** +C last modified: 02-20-2010 +C + IMPLICIT NONE + INTEGER NCOL,NROW,NLAY,NCOMP,ICOMP,ICBUND,IRCH,IEVT,MXSS, + & NTSS,NUM,IQ,K,I,J,ISS,IGROUP,MHOST,KHOST,IHOST,JHOST + REAL DTRANS,RECH,CRCH,EVTR,CEVT,SS,SSMC,SSG,CNEW, + & CTMP,QSS,RMASIO,DELR,DELC,DH,QSTO,RETA + LOGICAL FWEL,FDRN,FRCH,FEVT,FRIV,FGHB,FSTR,FRES,FFHB,FIBS, + & FTLK,FLAK,FMNW,FDRT,FETS,FSWT,FSFR,FUZF + DIMENSION ICBUND(NCOL,NROW,NLAY,NCOMP),SS(7,MXSS),SSG(5,MXSS), + & SSMC(NCOMP,MXSS),RECH(NCOL,NROW),IRCH(NCOL,NROW), + & CRCH(NCOL,NROW,NCOMP),EVTR(NCOL,NROW), + & IEVT(NCOL,NROW),CEVT(NCOL,NROW,NCOMP), + & CNEW(NCOL,NROW,NLAY,NCOMP),DELR(NCOL),DELC(NROW), + & DH(NCOL,NROW,NLAY),QSTO(NCOL,NROW,NLAY), + & RETA(NCOL,NROW,NLAY,NCOMP),RMASIO(122,2,NCOMP) + COMMON /FC/FWEL,FDRN,FRCH,FEVT,FRIV,FGHB,FSTR,FRES,FFHB,FIBS, + & FTLK,FLAK,FMNW,FDRT,FETS,FSWT,FSFR,FUZF +C +C--DETERMINE AVERAGE CONCENTRATION FOR LINKED SINK/SOURCE GROUPS + CALL CGROUP(NCOL,NROW,NLAY,NCOMP,ICOMP,MXSS,NTSS, + & SS,SSMC,SSG,ICBUND,CNEW,DELR,DELC,DH) +C +C--TRANSIENT GROUNDWATER STORAGE TERM + IF(ISS.NE.0) GOTO 50 +C +C--RECORD MASS STORAGE CHANGES FOR DISSOLVED AND SORBED PHASES + DO K=1,NLAY + DO I=1,NROW + DO J=1,NCOL + IF(ICBUND(J,I,K,ICOMP).LE.0) CYCLE + CTMP=CNEW(J,I,K,ICOMP) + IF(QSTO(J,I,K).GT.0) THEN + RMASIO(118,1,ICOMP)=RMASIO(118,1,ICOMP) + & +QSTO(J,I,K)*CTMP*DTRANS*DELR(J)*DELC(I)*DH(J,I,K) + ELSE + RMASIO(118,2,ICOMP)=RMASIO(118,2,ICOMP) + & +QSTO(J,I,K)*CTMP*DTRANS*DELR(J)*DELC(I)*DH(J,I,K) + ENDIF + ENDDO + ENDDO + ENDDO +C +C--AREAL SINK/SOURCE TERMS +C--(RECHARGE) + 50 IF(.NOT.FRCH) GOTO 100 +C + DO I=1,NROW + DO J=1,NCOL + K=IRCH(J,I) + IF(K.EQ.0 .OR. ICBUND(J,I,K,ICOMP).LE.0) CYCLE + CTMP=CRCH(J,I,ICOMP) + IF(RECH(J,I).LT.0) CTMP=CNEW(J,I,K,ICOMP) + IF(RECH(J,I).GT.0) THEN + RMASIO(7,1,ICOMP)=RMASIO(7,1,ICOMP)+RECH(J,I)*CTMP*DTRANS* + & DELR(J)*DELC(I)*DH(J,I,K) + ELSE + RMASIO(7,2,ICOMP)=RMASIO(7,2,ICOMP)+RECH(J,I)*CTMP*DTRANS* + & DELR(J)*DELC(I)*DH(J,I,K) + ENDIF + ENDDO + ENDDO +C +C--(EVAPOTRANSPIRATION) + 100 IF(.NOT.FEVT .AND. .NOT.FETS) GOTO 200 +C + DO I=1,NROW + DO J=1,NCOL + K=IEVT(J,I) + IF(K.EQ.0 .OR. ICBUND(J,I,K,ICOMP).LE.0) CYCLE + CTMP=CEVT(J,I,ICOMP) + IF(EVTR(J,I).LT.0.AND.(CTMP.LT.0 .or. + & CTMP.GE.CNEW(J,I,K,ICOMP))) THEN + CTMP=CNEW(J,I,K,ICOMP) + ELSEIF(CTMP.LT.0) THEN + CTMP=0. + ENDIF + IF(EVTR(J,I).GT.0) THEN + RMASIO(8,1,ICOMP)=RMASIO(8,1,ICOMP)+EVTR(J,I)*CTMP*DTRANS* + & DELR(J)*DELC(I)*DH(J,I,K) + ELSE + RMASIO(8,2,ICOMP)=RMASIO(8,2,ICOMP)+EVTR(J,I)*CTMP*DTRANS* + & DELR(J)*DELC(I)*DH(J,I,K) + ENDIF + ENDDO + ENDDO +C +C--POINT SINK/SOURCE TERMS + 200 DO NUM=1,NTSS + K=SS(1,NUM) + I=SS(2,NUM) + J=SS(3,NUM) + QSS=SS(5,NUM) + IQ=SS(6,NUM) + CTMP=SS(4,NUM) + IF(NCOMP.GT.1) CTMP=SSMC(ICOMP,NUM) +C +C--SKIP IF NOT ACTIVE CELL + IF(ICBUND(J,I,K,ICOMP).LE.0.OR.IQ.LE.0) CYCLE +C +C--RESET QSS FOR MASS-LOADING SOURCES (IQ=15) + IF(IQ.EQ.15) THEN + QSS=1./(DELR(J)*DELC(I)*DH(J,I,K)) +C +C--GET AVERAGE CONC FOR LINKED SINK/SOURCE GROUPS (IQ=27) + ELSEIF(IQ.EQ.27) THEN + IGROUP=SS(7,NUM) + CTMP=SSG(4,IGROUP) +C +C--GET RETURN FLOW CONC FOR DRAINS WITH RETURN FLOW (IQ=28) + ELSEIF(IQ.EQ.28 .AND. QSS.GT.0) THEN + MHOST=SS(7,NUM) + KHOST=(MHOST-1)/(NCOL*NROW) + 1 + IHOST=MOD((MHOST-1),NCOL*NROW)/NCOL + 1 + JHOST=MOD((MHOST-1),NCOL) + 1 + CTMP=CNEW(JHOST,IHOST,KHOST,ICOMP) +C +C--GET CONCENTRATION FOR RECIRCULATED INJECTION WELL +C--(IF INPUT CONCENTRATION WAS SET TO A NEGATIVE INTEGER) + ELSEIF(IQ.EQ.2 .AND. CTMP.LT.0 .AND. QSS.GT.0) THEN + MHOST=-INT(CTMP) + KHOST=(MHOST-1)/(NCOL*NROW) + 1 + IHOST=MOD((MHOST-1),NCOL*NROW)/NCOL + 1 + JHOST=MOD((MHOST-1),NCOL) + 1 + CTMP=CNEW(JHOST,IHOST,KHOST,ICOMP) + ENDIF +C + IF(QSS.LT.0) CTMP=CNEW(J,I,K,ICOMP) +C + IF(ICBUND(J,I,K,ICOMP).GT.0.AND.IQ.GT.0) THEN + IF(QSS.GT.0) THEN + RMASIO(IQ,1,ICOMP)=RMASIO(IQ,1,ICOMP)+QSS*CTMP*DTRANS* + & DELR(J)*DELC(I)*DH(J,I,K) + ELSE + RMASIO(IQ,2,ICOMP)=RMASIO(IQ,2,ICOMP)+QSS*CTMP*DTRANS* + & DELR(J)*DELC(I)*DH(J,I,K) + ENDIF + ENDIF +C + ENDDO +C +C--RETURN + 400 RETURN + END +C +C + SUBROUTINE SSM5OT(NCOL,NROW,NLAY,KPER,KSTP,NTRANS,NCOMP,ICOMP, + & ICBUND,MXSS,NTSS,NSS,SS,SSG,PRTOUT,TIME2,IOUT,ISSGOUT) +C ****************************************************************** +C THIS SUBROUTINE SAVES INFORMATION FOR MULTI-NODE WELLS. +C ****************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER NCOL,NROW,NLAY,kper,kstp,ntrans,NCOMP,ICOMP,ICBUND, + & MXSS,NTSS,NSS,NUM,IQ,K,I,J,iGroup,IOUT,iFlag, + & ISSGOUT,IU + REAL SS,CTMP,TIME2,SSG + LOGICAL PRTOUT + DIMENSION ICBUND(NCOL,NROW,NLAY,NCOMP),SS(7,MXSS),SSG(5,MXSS) + +C--IF ISSGOUT = 0, SAVE AVERAGE CONC. OF MULTI-NODE WELLS TO +C--STANDARD OUTPUT FILE WHENEVER PRTOUT IS TRUE +C--OTHERWISE SAVE TO UNIT DEFINED BY ISSGOUT + + IF(ISSGOUT.LE.0) THEN + IF(.NOT.PRTOUT) GOTO 1200 + IU=IOUT + WRITE(IU,1000) + WRITE(IU,1002) + ELSE + IU=ISSGOUT + IF(KPER*KSTP*NTRANS.EQ.1) WRITE(IU,1002) + ENDIF + + DO NUM=1,NTSS + K =ss(1,num) + I =ss(2,num) + J =ss(3,num) + IQ=ss(6,num) + iGroup=ss(7,num) + if(iGroup.le.0) cycle + ctmp=ssg(4,iGroup) + iFlag=int(ssg(1,iGroup)) + if(iFlag.ne.-999) then + ssg(1,iGroup)=-999 + write(IU,1004) kper,kstp,ntrans,time2,iGroup,k,i,j,ctmp + endif + ENDDO + + IF(ISSGOUT.LE.0) WRITE(IU,1010) + + 1000 format(/1x,80('.')) + 1002 format(1x,'Stress Time Transport Total MNW Layer', + & ' Row Column Average', + & /1x,'Period Step Step Elapsed Time Group [K] ', + & ' [I] [J] Conc. ') + 1004 format(1x, i4, 2x, i5, 3x, i5, 3x, g15.7, 2x, 4i6, 1x, g15.7) + 1010 format(1x,80('.')/) +C + 1200 RETURN + END +C +C + subroutine cgroup(ncol,nrow,nlay,ncomp,icomp,mxss,ntss, + & ss,ssmc,ssg,icbund,cnew,delr,delc,dh) +c ********************************************************************** +c this subroutine calculates the average concentration for a linked +c group sink/source such as a multi-node well +c ********************************************************************** +c last modification: 02-15-2005 +c + implicit none + integer k,i,j,iGroup,num,IQ,icbund,icomp,ncomp,mxss,ntss, + & ncol,nrow,nlay + real ss,ssmc,ssg,cold,cnew,delr,delc,dh,ctmp,qss,csink, + & QC_group,Q_group,Qnet_group,cavg + dimension ss(7,mxss),ssmc(ncomp,mxss),ssg(5,mxss), + & cnew(ncol,nrow,nlay,ncomp),delr(ncol),delc(nrow), + & dh(ncol,nrow,nlay),icbund(ncol,nrow,nlay,ncomp) +c +c--clear storage array +c + do iGroup=1,ntss + do i=1,5 + ssg(i,iGroup)=0. + enddo + enddo +c +c--get cumulative QC and Q (sinks only), and net Q (sinks/sources) +c + do num=1,ntss + k=ss(1,num) + i=ss(2,num) + j=ss(3,num) + ctmp=ss(4,num) + if(icomp.gt.1) ctmp=ssmc(icomp,num) + qss=ss(5,num) + IQ=ss(6,num) + iGroup=ss(7,num) +c +c--skip if at an inactive cell + if(icbund(j,i,k,icomp).le.0) cycle +c +c--skip if not a linked group sink/source + if(iGroup.eq.0 .or. IQ.ne.27) cycle +c +c--get cell concentration + csink=cnew(j,i,k,icomp) +c +c--get volumetric |Q|*C, |Q|, and Q + if(qss.lt.0) then + QC_group=abs(qss)*delr(j)*delc(i)*dh(j,i,k)*csink + Q_group =abs(qss)*delr(j)*delc(i)*dh(j,i,k) + else + QC_group=0. + Q_group =0. + endif + Qnet_group = qss*delr(j)*delc(i)*dh(j,i,k) +c +c--cumulate and store in ssg + ssg(1,iGroup) = ssg(1,iGroup) + QC_group + ssg(2,iGroup) = ssg(2,iGroup) + Q_group + ssg(5,iGroup) = ssg(5,iGroup) + Qnet_group +c +c--get user-specified conc for any cell in the group + ssg(3,iGroup) = max( ctmp,ssg(3,iGroup) ) +c +c--done + enddo +c +c--get composite concentrations +c + do iGroup=1,ntss + cavg = 0. + QC_group = ssg(1,iGroup) + Q_group = ssg(2,iGroup) + Qnet_group = ssg(5,iGroup) + ctmp = ssg(3,iGroup) + if(Qnet_group.gt.0) then + cavg=(QC_group+Qnet_group*ctmp)/(Q_group+Qnet_group) + elseif(Q_group.gt.0) then + cavg =QC_group/Q_group + endif + ssg(4,iGroup) = cavg + enddo +c +c--normal return +c + return + end \ No newline at end of file diff --git a/true-binary/mt_tob5.for b/true-binary/mt_tob5.for index e69de29..2d5e9aa 100644 --- a/true-binary/mt_tob5.for +++ b/true-binary/mt_tob5.for @@ -0,0 +1,1017 @@ +C + SUBROUTINE TOB5AL(INTOB,IOUT,ISUM,ISUM2,NCOL,NROW,NLAY, + & MaxConcObs,MaxFluxObs,MaxFluxCells, + & LCMLAYER,LCCOBS,LCPRLAYER,LCTEMP,LCFLUXGROUP,LCGROUPDATA) +C ********************************************************************** +C THIS SUBROUTINE ALLOCATES SPACE FOR ARRAYS NEEDED BY THE TRANSPORT +C OBSERVATION (TOB) PACKAGE. +C ********************************************************************** +C last modified: 02-20-2010 +C + IMPLICIT NONE + INTEGER INTOB,IOUT,ISUM,ISUM2,ISOLD,ISOLD2,ISUMX,ISUMIX, + & NCOL,NROW,NLAY,MaxConcObs,MaxFluxObs,MaxFluxCells, + & LCMLAYER,LCCOBS,LCPRLAYER,LCTEMP, + & LCFLUXGROUP,LCGROUPDATA,LLOC,ISTART,ISTOP,ITMP + REAL R + CHARACTER LINE*200 +C +C--PRINT PACKAGE NAME AND VERSION NUMBER + WRITE(IOUT,1030) INTOB + 1030 FORMAT(1X,'TOB5 -- TRANSPORT OBSERVATION PACKAGE,', + & ' VERSION 5, FEBRUARY 2010, INPUT READ FROM UNIT',I3) +C +C--READ INPUT LINE AS A TEXT STRING + 2 READ(INTOB,'(A)') LINE + IF(LINE.EQ.' ') GOTO 2 + IF(LINE(1:1).EQ.'#') THEN + WRITE(IOUT,'(A)') LINE + GOTO 2 + ENDIF +C +C--DECODE INPUT LINE + LLOC=1 + CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,ITMP,R,IOUT,INTOB) + MaxConcObs=ITMP + CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,ITMP,R,IOUT,INTOB) + MaxFluxObs=ITMP + CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,ITMP,R,IOUT,INTOB) + MaxFluxCells=ITMP +C +C--PRINT MAXIMUM DIMENSIONS + WRITE(iout,10) MaxConcObs,MaxFluxObs,MaxFluxCells + 10 FORMAT(1x,'MAXIMUM NUMBER OF CONC OBSERVATION WELLS =',i7, + & /1x,'MAXIMUM NUMBER OF MASS-FLUX OBSERVATIONS =',i7, + & /1x,'MAXIMUM NUMBER OF CELLS IN A FLUX OBJECT =',i7) +C +C--SET MINIMUM DIMENSION AT ONE + IF(MaxConcObs.lt.1) MaxConcObs=1 + IF(MaxFluxObs.lt.1) MaxFluxObs=1 + If(MaxFluxCells.lt.1) MaxFluxCells=1 +C +C--ALLOCATE SPACE FOR ARRAYS + ISOLD=ISUM + ISOLD2=ISUM2 +C +C--INTEGER ARRAYS + LCMLAYER=ISUM2 + ISUM2=ISUM2+NLAY*MaxConcObs +C +C--REAL ARRAYS + LCCOBS=ISUM + ISUM=ISUM+9*MaxConcObs + LCPRLAYER=ISUM + ISUM=ISUM+NLAY*MaxConcObs + LCTEMP=ISUM + ISUM=ISUM+3*max(MaxConcObs,MaxFluxObs) + LCFluxGroup=ISUM + ISUM=ISUM+(3+2*MaxFluxCells)*MaxFluxObs + LCGroupData=ISUM + ISUM=ISUM+7*MaxFluxObs +C +C--CHECK HOW MANY ELEMENTS OF THE X AND IX ARRAYS ARE USED + ISUMX=ISUM-ISOLD + ISUMIX=ISUM2-ISOLD2 + WRITE(IOUT,1090) ISUMX,ISUMIX + 1090 FORMAT(1X,I10,' ELEMENTS OF THE X ARRAY USED BY THE TOB PACKAGE', + & /1X,I10,' ELEMENTS OF THE IX ARRAY USED BY THE TOB PACKAGE'/) +C +C--NORMAL RETURN + RETURN + END +C +C + SUBROUTINE TOB5RP(INTOB,IOUT,NCOL,NROW,NLAY,NCOMP,MaxConcObs, + & MaxFluxObs,MaxFluxCells,inConcObs,nConcObs,CScale,iOutCobs, + & iConcLOG,iConcINTP,COBSNAM,COBSWEL,mLAYER,prLAYER,TEMP, + & inFluxObs,nFluxGroup,nFluxObs,FScale,iOutFlux,inSaveObs, + & FOBSNAM,FLUXGROUP,GROUPDATA) +C ********************************************************************* +C THIS SUBROUTINE READS INPUT DATA for THE TOB PACKAGE. +C ********************************************************************* +C last modified: 02-20-2010 +C + IMPLICIT NONE + INTEGER INTOB,IOUT,LLOC,IFLEN,INAM1,INAM2,ISTART,ISTOP,N, + & NCOL,NROW,NLAY,inConcObs,inFluxObs,inSaveObs,IU, + & nConcObs,MaxConcObs,iOutCobs,iConcLOG,iConcINTP, + & kk,kp,ip,jp,mLayer,MaxFluxObs,MaxFluxCells, + & nFluxGroup,iOutFlux,nFluxTimeObs,nCells,iSSType, + & nFluxObs,kc,ic,jc,icell,ig,icomp,ncomp,it + REAL CScale,COBSWEL,FScale,TimeObs,Roff,Coff,weight, + & temp,prLayer,cobs,FluxTimeObs,FluxObs, + & FluxGroup,GroupData,R,fraction + CHARACTER LINE*200,FNAME*80,FTMP*80,NAMTMP*12,header*15, + & COBSNAM*12,FOBSNAM*12,TYPESS(-1:100)*15 + DIMENSION mLayer(nlay,MaxConcObs),prLayer(nlay,MaxConcObs), + & COBSWEL(9,MaxConcObs),COBSNAM(MaxConcObs), + & FluxGroup(3+2*MaxFluxCells,MaxFluxObs), + & GroupData(7,MaxFluxObs),FOBSNAM(MaxFluxObs) +C +C--INITIALIZE + TYPESS(-1)='UNSUPPORTED ' + TYPESS(1) ='CONSTANT HEAD ' + TYPESS(2) ='WELL ' + TYPESS(3) ='DRAIN ' + TYPESS(4) ='RIVER ' + TYPESS(5) ='HEAD DEP BOUND ' + TYPESS(7) ='RECHARGE ' + TYPESS(8) ='E-T FLUX ' + TYPESS(15)='MASS LOADING ' + TYPESS(21)='STREAM ' + TYPESS(22)='RESERVOIR ' + TYPESS(23)='SP FLW HD BOUND' + TYPESS(24)='INTERBED STRG ' + TYPESS(25)='TRANSIENT LEAK ' + TYPESS(26)='LAKE ' + TYPESS(27)='MULTI-NODE WELL' + TYPESS(28)='DRN W RET FLOW ' + TYPESS(29)='SEGMENTED ET ' + TYPESS(50)='HSS MAS LOADING' + TYPESS(51)='SUBSIDENCE-WT ' + TYPESS(52)='STREAM FL ROUT.' + TYPESS(53)='UNSAT ZONE FLOW' +C +C--READ INPUT LINE AS A TEXT STRING + 2 READ(INTOB,'(A)') LINE + IF(LINE.EQ.' ') GOTO 2 + IF(LINE(1:1).EQ.'#') THEN + WRITE(IOUT,'(A)') LINE + GOTO 2 + ENDIF +C +C--DECODE THE TOB OUTPUT FILE ROOT NAME + LLOC=1 + CALL URWORD(LINE,LLOC,INAM1,INAM2,0,N,R,IOUT,INTOB) + IFLEN=INAM2-INAM1+1 + FNAME(1:IFLEN)=LINE(INAM1:INAM2) +C +C--DECODE OUTPUT FILE UNITS + CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,IU,R,IOUT,INTOB) + inConcObs=IU + CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,IU,R,IOUT,INTOB) + inFluxObs=IU + CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,IU,R,IOUT,INTOB) + inSaveObs=IU +C +C--OPEN OUTPUT FILES + if(inConcObs.gt.0) then + ftmp=fname(1:iflen)//'.ocn' + CALL OPENFL(inConcObs,0,ftmp,1,ftmp) + write(inConcObs,10) + endif + if(inFluxObs.gt.0) then + ftmp=fname(1:iflen)//'.mfx' + CALL OPENFL(inFluxObs,0,ftmp,1,ftmp) + write(inFluxObs,20) + endif + if(inSaveObs.gt.0) then + header='MT3DMS_TOB_5.00' + ftmp=fname(1:iflen)//'.pst' + CALL OPENFL(-inSaveObs,0,ftmp,1,ftmp) + write(inSaveObs) header + endif + 10 format(/1x,'CONCENTRATION OBSERVATION OUTPUT FILE', + & /1X,37('=')) + 20 format(/1x,'MASS FLUX OBJECT OBSERVATION OUTPUT FILE', + & /1X,40('=')) +C +C--get input data for concentration observation wells + if(inConcObs.le.0) goto 1000 +C + read(intob,*) nConcObs,CScale,iOutCobs,iConcLOG,iConcINTP + write(iout,98) + 98 format(//1x,'TRANSPORT OBSERVATION INPUT DATA'/1x,32('-')) + write(iout,100) nCOncObs,CScale,iOutCobs,iConcLOG,iConcINTP + 100 format(/1x,'NUMBER OF CONCENTRATION OBSERVATION WELLS: ',i5, + & /1x,' MULTIPLIER FOR OBSERVED CONCENTRATIONS: ',g12.4, + & /1x,' OPTION FOR CALCULATING RESIDUAL ERRORS: ',i5, + & /1x,' OPTION FOR LOGARITHMIC CONVERSION: ',i5, + & /1x,'OPTION FOR INTERPOLATING CALCULATED CONC.: ',i5, + & //1x,'OBS_NAME LAYER ROW COL. SPECIES OBS_TIME', + & 3x,'ROW_OFFSET',2x,'COL_OFFSET',4x,'WEIGHT',6x,'OBS_CONC', + & /1x,99('.')) +C + IF(nConcObs.gt.MaxConcObs) then + write(*,102) + 102 format(1x,'Number of conc. observation wells', + & ' exceeds specified maximum') + call ustop(' ') + ENDIF +C + DO n=1, nConcObs + + read(intob,*) NAMTMP,kp,ip,jp,icomp, + & TimeObs,Roff,Coff,weight,COBS + write(iout,120) NAMTMP,kp,ip,jp,icomp, + & TimeObs,Roff,Coff,weight,COBS + 120 format(1x,a12,3i5,2x,i5,3x,4g12.4,g14.5) + + COBSNAM(n)=NAMTMP + cobswel(1,n)=kp + cobswel(2,n)=ip + cobswel(3,n)=jp + cobswel(4,n)=icomp + cobswel(5,n)=TimeObs + cobswel(6,n)=Roff + cobswel(7,n)=Coff + cobswel(8,n)=weight + cobswel(9,n)=cobs * CScale + + IF(iOutCobs.gt.0 .and. iConcLOG.gt.0) then + if(weight.gt.0 .and. Cobs.le.0) then + write(*,121) + 121 format(1x,'Observed conc. invalid for log conversion') + call ustop(' ') + endif + ENDIF + + if(kp.lt.0) then + read(intob,*) (mLayer(kk,n),prLayer(kk,n), kk=1,iabs(kp)) + write(iout,122) (mLayer(kk,n),prLayer(kk,n), kk=1,iabs(kp)) + endif + 122 format(1x,' @Layer',i4,' Proportion=',g12.4) + + ENDDO +C +C--get input data for mass flux objects + 1000 if(inFluxObs.le.0) goto 2000 +C + read(intob,*) nFluxGroup,FScale,iOutFlux + write(iout,200) nFluxGroup,FScale,iOutFlux + 200 format(/1x,' NUMBER OF MASS FLUX OBJECTS: ',i5, + & /1x,' MULTIPLIER FOR OBSERVED MASS FLUXES: ',g12.4, + & /1x,'OPTION FOR CALCULATING RESIDUAL ERRORS: ',i5) +C + if(nFluxGroup.gt.MaxFluxObs) then + write(*,202) + 202 format(1x,'Number of mass flux objects', + & ' exceeds specified maximum') + call ustop(' ') + endif +C + nFluxObs=0 + DO ig=1, nFluxGroup + + read(intob,*) nFluxTimeObs,nCells,iSSType + write(iout,220) ig,nFluxTimeObs,nCells,TYPESS(iSSType) + 220 format(/1x,' MASS FLUX OBJECT NO.: ',i5, + & /1x,' NUMBER OF OBSERVATION TIMES: ',i5, + & /1x,'NUMBER OF MODEL CELLS INCLUDED: ',i5, + & /1x,' TYPE OF MASS FLUX OBJECT: ',a15, + & //1x,'OBS_NAME',4x,'SPECIES',2x,'OBS_TIME', + & 5x,'WEIGHT',7x,'OBS_FLUX'/1x,55('.')) + + if(nCells.gt.MaxFluxCells) then + write(*,222) + 222 format(1x,'Number of cells in a flux object', + & ' exceeds specified maximum') + call ustop(' ') + endif + if(iSSType.lt.0) then + write(*,224) + 224 format(1x,'iSSType code supported must be > 0') + call ustop(' ') + endif + + FluxGroup(1,ig)=nFluxTimeObs + FluxGroup(2,ig)=nCells + FluxGroup(3,ig)=iSSType + + do it=1, nFluxTimeObs + + read(intob,*) NAMTMP,icomp,TimeObs,weight,FluxObs + write(iout,240) NAMTMP,icomp,TimeObs,weight,FluxObs + 240 format(1x,a12,i5,3x,2g12.4,g14.5) + + nFluxObs = nFluxObs+1 + + if(nFluxObs.gt.MaxFluxObs) then + write(*,242) + 242 format(1x,'Number of total observations for', + & ' all mass flux objects exceeds specified maximum') + call ustop(' ') + endif + + FOBSNAM(nFluxObs)=NAMTMP + GroupData(1,nFluxObs)=ig + GroupData(2,nFluxObs)=icomp + GroupData(3,nFluxObs)=TimeObs + GroupData(4,nFluxObs)=weight + GroupData(5,nFluxObs)=FluxObs * FScale + + enddo + + do icell=1,nCells + read(intob,*) kc, ic, jc, fraction + write(iout,260) kc, ic, jc, fraction + FluxGroup(3+icell,ig)= (kc-1)*ncol*nrow + (ic-1)*ncol + jc + FluxGroup(3+MaxFluxCells+icell,ig)=fraction + if(fraction.gt.1 .or. fraction.lt.0) then + write(*,244) + 244 format(1x,'contributing fraction for any cell', + & ' in a mass flux object must be between 0 and 1') + call ustop(' ') + endif + enddo + 260 format(1x,'@Layer:',i4,'; Row:',i5,'; Column:',i5, + & '; Fraction:',f8.3) + + ENDDO +C +C--normal return + 2000 CONTINUE + RETURN + END +C +C + Subroutine ConcObs(inConcObs,iout,ncol,nrow,nlay,ncomp,kper,kstp, + & ntrans,time1,time2,cnew,cinact,icbund,delr,delc,xbc,ybc, + & nConcObs,cobswel,cobsnam,mLayer,prLayer,temp,inSaveObs, + & iOutCobs,iConcLOG,iConcINTP) +C ********************************************************************** +C This subroutine gets calculated concentration values at observation +C points and computes residual errors between calculated and observed +C if necessary +C ********************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER IOUT,NCOL,NROW,NLAY,ntrans,n,inConcObs,nConcObs,itmp, + & nobs_active,iOutCobs,iConcLOG,iConcINTP,ktmp,kp,ip,jp, + & jlo,ilo,jhi,ihi,kstart,kend,ncal,layer,mLayer, + & icbund,icomp,ncomp,kstp,kper,inSaveObs,iErrMsg, + & nobs_current + REAL time1,time2,errsum,abserrsum,TimeObs,Roff,Coff,weight, + & xx2,yy2,xbc,ybc,delr,delc,wlayer,cnew,cobswel,cwgt, + & ccal,cobs,prLayer,wx,wy,ctmp,temp,error,cinact, + & AVE,ADEV,SDEV,VAR,CURT,R,PROB,Z,SKEW + CHARACTER cobsnam*12,ErrMsg*24 + DIMENSION cobswel(9,nConcObs),cobsnam(nConcObs),temp(nConcObs,3), + & mLayer(nlay,nConcObs),prLayer(nlay,nConcObs), + & cnew(ncol,nrow,nlay,ncomp),icbund(ncol,nrow,nlay,ncomp), + & delr(ncol),delc(nrow),xbc(ncol),ybc(nrow) +C +C--print headers to conc obs output file +C + WRITE(inConcObs,2) kper,kstp,ntrans,time2 + IF(iOutCobs.gt.0) THEN + IF(iConcLOG.eq.0) WRITE(inConcObs,4) + IF(iConcLOG.gt.0) WRITE(inConcObs,6) + ELSEIF(iOutCobs.eq.0) THEN + WRITE(inConcObs,8) + ENDIF + 2 format(//1x,30('*'), + & /1x,' STRESS PERIOD: ',i5, + & /1x,' TIME STEP: ',i5, + & /1x,' TRANSPORT STEP: ',i5, + & /1x,'TOTAL ELAPSED TIME: ',g12.4, + & /1x,30('*')/) + 4 format(1x,'WELLID X_GRID Y_GRID LAYER ROW COLUMN', + & ' SPECIES CALCULATED OBSERVED WEIGHT (CAL.-OBS.)' + & /1x,108('.')) + 6 format(1x,'WELLID X_GRID Y_GRID LAYER ROW COLUMN', + & ' SPECIES CALCULATED OBSERVED WEIGHT LogCAL-LogOBS' + & /1x,110('.')) + 8 format(1x,'WELLID X_GRID Y_GRID LAYER ROW COLUMN', + & ' SPECIES CALCULATED ' + & /1x,75('.')) + +C--reset accumulators + + nobs_active=0 + nobs_current=0 + errsum=0 + abserrsum=0 + +C--loop over all observation wells + + do n=1,nConcObs + + kp= cobswel(1,n) + ip= cobswel(2,n) + jp= cobswel(3,n) + icomp= cobswel(4,n) + TimeObs=cobswel(5,n) + Roff= cobswel(6,n) + Coff= cobswel(7,n) + weight= cobswel(8,n) + cobs= cobswel(9,n) + + if(TimeObs.lt.0) then + itmp=-int(TimeObs) + if(mod(ntrans,itmp).ne.0) then + cycle !skip if not even multiple + else + TimeObs=time2 + endif + elseif(TimeObs.le.time1 .or. TimeObs.gt.time2) then + cycle !skip if not at current time step + endif + + nobs_current=nobs_current+1 + xx2=xbc(jp)+Coff*delr(jp) + yy2=ybc(ip)+Roff*delc(ip) + jlo=max(1,jp-1) + ilo=max(1,ip-1) + if(xx2.gt.xbc(jp)) jlo=jp + if(yy2.gt.ybc(ip)) ilo=ip + jhi=min(jlo+1,ncol) + ihi=min(ilo+1,nrow) + + if(kp.gt.0) then + kstart=1 + kend=1 + else + kstart=1 + kend=abs(kp) + endif + + cwgt=0 + ncal=0 + do ktmp=kstart,kend + + if(kp.gt.0) then + layer=kp + wlayer=1. + elseif(kp.lt.0) then + layer=mLayer(ktmp,n) + wlayer=prLayer(ktmp,n) + endif + + if(icbund(jp,ip,layer,iComp).eq.0) then + wlayer=0 + ccal=cinact + else + ncal=ncal+1 + ccal=cnew(jp,ip,layer,iComp) + + IF(iConcINTP.gt.0) then !interpolate if requested + IF(JLO.NE.JHI) THEN + WX=(xx2-XBC(JLO))/(0.5*DELR(JHI)+0.5*DELR(JLO)) + ELSE + WX=0 + ENDIF + IF(ILO.NE.IHI) THEN + WY=(yy2-YBC(ILO))/(0.5*DELC(IHI)+0.5*DELC(ILO)) + ELSE + WY=0 + ENDIF + ccal=0 + CTMP=cnew(JLO,ILO,layer,iComp) + IF(ICBUND(JLO,ILO,layer,iComp).EQ.0) + & CTMP=cnew(JP,IP,layer,iComp) + ccal=ccal+(1.-WX)*(1.-WY)*CTMP + CTMP=cnew(JLO,IHI,layer,iComp) + IF(ICBUND(JLO,IHI,layer,iComp).EQ.0) + & CTMP=cnew(JP,IP,layer,iComp) + ccal=ccal+(1.-WX)*WY*CTMP + CTMP=cnew(JHI,ILO,layer,iComp) + IF(ICBUND(JHI,ILO,layer,iComp).EQ.0) + & CTMP=cnew(JP,IP,layer,iComp) + ccal=ccal+WX*(1.-WY)*CTMP + CTMP=cnew(JHI,IHI,layer,iComp) + IF(ICBUND(JHI,IHI,layer,iComp).EQ.0) + & CTMP=cnew(JP,IP,layer,iComp) + ccal=ccal+WX*WY*CTMP + endif !end of interpolation block + + endif + + cwgt = cwgt + ccal * wlayer + + enddo ! end of multi-layer weighting + + iErrMsg=0 + ErrMsg=' ' + if(ncal.le.0) then !obs at dry cell + iErrMsg=1 + ErrMsg='obs well at a dry cell' + cwgt=cinact + elseif(iOutCobs*iConcLOG.gt.0 .and. cwgt.le.0) then + iErrMsg=2 + ErrMsg='invalid log conversion' + elseif(weight .lt. 0) then !for well without obs conc. + iErrMsg=-1 + ErrMsg='no observed conc given' + elseif(iOutCobs.gt.0) then !active + nobs_active=nobs_active+1 + if(iConcLOG.le.0) then + temp(nobs_active,1)=cobs + temp(nobs_active,2)=cwgt + error=(cwgt-cobs)*weight + elseif(iConcLOG.gt.0) then + temp(nobs_active,1)=log10(cobs) + temp(nobs_active,2)=log10(cwgt) + error=(log10(cwgt)-log10(cobs))*weight + endif + errsum=errsum+error*error + abserrsum=abserrsum+abs(error) + temp(nobs_active,3)=error + endif + + if(iOutCobs.gt.0 .and. iErrMsg.eq.0) then + write(inConcObs,30) + & cobsnam(n),xx2,yy2,kp,ip,jp,icomp,cwgt,cobs,weight,error + elseif(iOutCobs.gt.0 .and. iErrMsg.ne.0) then + write(inConcObs,32) + & cobsnam(n),xx2,yy2,kp,ip,jp,icomp,cwgt,ErrMsg + elseif(iOutCobs.eq.0 .and. iErrMsg.eq.0) then + write(inConcObs,34) + & cobsnam(n),xx2,yy2,kp,ip,jp,icomp,cwgt + elseif(iOutCobs.eq.0 .and. iErrMsg.gt.0) then + write(inConcObs,36) + & cobsnam(n),xx2,yy2,kp,ip,jp,icomp,cwgt,ErrMsg + endif + if(inSaveObs.gt.0) then + write(inSaveObs) cobsnam(n),TimeObs,cwgt + endif + + enddo !end of obs wel loop + + 30 format(1x,a12,1p,2g12.4,3i5,3x,i4,2x,4g12.4) + 32 format(1x,a12,1p,2g12.4,3i5,3x,i4,2x,1g12.4,3x,a) + 34 format(1x,a12,1p,2g12.4,3i5,3x,i4,2x,1g12.4) + 36 format(1x,a12,1p,2g12.4,3i5,3x,i4,2x,1g12.4,3x,a) + +c--calculate statistics + if(iOutCobs.gt.0.and.nobs_active.gt.1) then + CALL MOMENT(temp(1,3),nobs_active,AVE,ADEV,SDEV,VAR,SKEW,CURT) + CALL PEARSN(temp(1,1),temp(1,2),nobs_active,R,PROB,Z) + else + goto 1000 + endif + +c--print statastics + write(inConcObs,50) nobs_active + write(inConcObs,60) AVE + write(inConcObs,62) SDEV + write(inConcObs,64) abserrsum/nobs_active + write(inConcObs,66) SQRT(ERRSUM/nobs_active) + if(nobs_active.gt.2) then + write(inConcObs,70) R + write(inConcObs,72) PROB + endif + + 50 FORMAT(/1x,' NUMBER OF ACTIVE OBSERVATION POINTS = ',I5) + 60 FORMAT( 1x,' MEAN OF RESIDUALS (M) = ',G15.7) + 62 FORMAT( 1x,'STANDARD DEVIATION OF RESIDUALS (SDEV) = ',G15.7) + 64 FORMAT( 1x,' MEAN OF ABSOLUTE RESIDUALS (MA) = ',G15.7) + 66 FORMAT( 1x,' ROOT MEAN SQUARED RESIDUALS (RMS) = ',G15.7) + 70 FORMAT( 1x,' CORRELATION COEFFICIENT = ',G15.7) + 72 FORMAT( 1x,' PROBABILITY OF UN-CORRELATION = ',G15.7) +c + 1000 IF(nobs_current.le.0) write(inConcObs,1080) + 1080 FORMAT(1x,'[No obs wells active at current transport step]') +C +C--normal return + RETURN + END +C +C + Subroutine MassFluxObs(inFluxObs,iout,ncol,nrow,nlay,ncomp, + & MaxFluxCells,nFLuxGroup,nFLuxObs,kper,kstp,ntrans,time1,time2, + & cnew,icbund,mxss,ntss,ss,ssmc,delr,delc,dh, + & irch,rech,crch,ievt,evtr,cevt, + & FluxGroup,GroupData,fobsnam,grouptmp,inSaveObs,iOutFlux) +C ********************************************************************** +C This subroutine gets calculated mass fluxes at user specified +C locations and computes residual errors between calculated and +C observed if necessary +C ********************************************************************** +C last modified: 02-20-2010 +C + IMPLICIT NONE + INTEGER NCOL,NROW,NLAY,ntrans,inFluxObs,iout,n,iGroup, + & nFluxGroup,nFluxTimeObs,MaxFluxCells,nFluxObs, + & nobs_active,icell,nCells,iSSType,it,inode,k,i,j, + & num,mxss,ntss,IQ,kp,ip,jp,icbund,icomp,ncomp, + & irch,ievt,kstp,kper,iOutFlux, + & inSaveObs,issLink,iErrMsg,itmp,nobs_current + REAL time1,time2,FluxGroup,GroupData,GroupTmp,TimeObs, + & FluxObs,FluxCal,ss,ssmc,qss,cnew,csink,ctmp,error, + & delr,delc,dh,QC,Q,weight,errsum,abserrsum, + & rech,crch,evtr,cevt, + & SKEW,AVE,ADEV,SDEV,VAR,CURT,R,PROB,Z,fraction + CHARACTER fobsnam*12,ErrMsg*24 + LOGICAL FWEL,FDRN,FRCH,FEVT,FRIV,FGHB,FSTR,FRES,FFHB,FIBS, + & FTLK,FLAK,FMNW,FDRT,FETS,FSWT,FSFR,FUZF + DIMENSION FluxGroup(3+2*MaxFluxCells,nFluxGroup), + & fobsnam(nFluxObs),GroupData(7,nFluxObs), + & GroupTmp(nFluxObs,3),cnew(ncol,nrow,nlay,ncomp), + & icbund(ncol,nrow,nlay,ncomp),ss(7,mxss), + & ssmc(ncomp,mxss),rech(ncol,nrow),evtr(ncol,nrow), + & crch(ncol,nrow,ncomp),cevt(ncol,nrow,ncomp), + & irch(ncol,nrow),ievt(ncol,nrow), + & delr(ncol),delc(nrow),dh(ncol,nrow,nlay) + COMMON /FC/FWEL,FDRN,FRCH,FEVT,FRIV,FGHB,FSTR,FRES,FFHB, + & FIBS,FTLK,FLAK,FMNW,FDRT,FETS,FSWT,FSFR,FUZF +c +c--print headers to output file +c + WRITE(inFluxObs,2) kper,kstp,ntrans,time2 + IF(iOutFlux.gt.0) THEN + WRITE(inFluxObs,4) + ELSEIF(iOutFlux.eq.0) THEN + WRITE(inFluxObs,6) + ENDIF + 2 format(//1x,30('*'), + & /1x,' STRESS PERIOD: ',i5, + & /1x,' TIME STEP: ',i5, + & /1x,' TRANSPORT STEP: ',i5, + & /1x,'TOTAL ELAPSED TIME: ',g12.4, + & /1x,30('*')/) + 4 format(1x,' NO. NAME TIME SPECIES ', + & 'CALCULATED OBSERVED WEIGHT (CAL.-OBS.)'/1x,88('.')) + 6 format(1x,' NO. NAME TIME SPECIES ', + & 'CALCULATED '/1x,54('.')) +c +c--reset accumulators +c + nobs_active=0 + nobs_current=0 + errsum=0 + abserrsum=0 +c +c--clear temporary storage arrays +c + do n=1,nfluxobs + GroupTmp(n,1)=0. + GroupTmp(n,2)=0. + GroupTmp(n,3)=0. + enddo +c +c--loop through all mass flux observations +c + do n=1,nfluxobs + + iGroup= GroupData(1,n) + iComp= GroupData(2,n) + TimeObs=GroupData(3,n) + weight =GroupData(4,n) + FluxObs=GroupData(5,n) + GroupData(6,n)=0. + GroupData(7,n)=0. + + if(TimeObs.lt.0) then + itmp=-int(TimeObs) + if(mod(ntrans,itmp).ne.0) then + cycle !skip if not even multiple + else + TimeObs=time2 + endif + elseif(TimeObs.le.time1 .or. TimeObs.gt.time2) then + cycle !skip if not at current time step + endif + + 100 nFluxTimeObs=FluxGroup(1,iGroup) + nCells=FluxGroup(2,iGroup) + iSSType=FluxGroup(3,iGroup) + +c--loop through all cells in the current flux object + + do icell=1,nCells + + inode=int( FluxGroup(3+icell,iGroup) ) + kp = (inode-1) / (ncol*nrow) + 1 + ip = mod((inode-1),ncol*nrow)/ncol + 1 + jp = mod((inode-1),ncol) + 1 + fraction=FluxGroup(3+MaxFluxCells+icell,iGroup) + +c--if recharge flux + + if(iSSType.eq.7 .and. FRCH) then + if(kp.ne.irch(jp,ip)) cycle + if(icbund(jp,ip,kp,icomp).le.0) cycle + ctmp=crch(jp,ip,icomp) + qss=rech(jp,ip) + if(qss.lt.0) ctmp=cnew(jp,ip,kp,icomp) +c--get volumetric Q*C and Q + QC=qss*delr(jp)*delc(ip)*dh(jp,ip,kp)*ctmp + Q =qss*delr(jp)*delc(ip)*dh(jp,ip,kp) +c--cumulate in GroupData + GroupData(6,n) = GroupData(6,n) + QC * fraction + GroupData(7,n) = GroupData(7,n) + Q * fraction + cycle + endif + +c--if evapotranspiration flux + + if(iSSType.eq.8 .and. (FEVT.or.FETS) ) then + if(kp.ne.ievt(jp,ip)) cycle + if(icbund(jp,ip,kp,icomp).le.0) cycle + ctmp=cevt(jp,ip,icomp) + qss=evtr(jp,ip) + if(qss.lt.0 .and. (ctmp.lt.0. or. + & ctmp.ge.cnew(jp,ip,kp,icomp))) then + ctmp=cnew(jp,ip,kp,icomp) + elseif(ctmp.lt.0) then + ctmp=0. + endif +c--get volumetric Q*C and Q + QC=qss*delr(jp)*delc(ip)*dh(jp,ip,kp)*ctmp + Q =qss*delr(jp)*delc(ip)*dh(jp,ip,kp) +c--cumulate in GroupData + GroupData(6,n) = GroupData(6,n) + QC * fraction + GroupData(7,n) = GroupData(7,n) + Q * fraction + cycle + endif + +c--if point sinks/sources + + do num=1,ntss + k=ss(1,num) + i=ss(2,num) + j=ss(3,num) + ctmp=ss(4,num) + if(icomp.gt.1) ctmp=ssmc(icomp,num) + qss=ss(5,num) + if(qss.lt.0) ctmp=cnew(j,i,k,icomp) + IQ=ss(6,num) + issLink=ss(7,num) +c--skip if not same ss type + if(iSSType.ne.IQ) cycle +c--skip if not same cell + if(kp.ne.k .or. ip.ne.i .or. jp.ne.j) cycle +c--skip if not an active cell + if(icbund(j,i,k,icomp).le.0) cycle +c--skip if at a linked group sink/source + if(issLink.gt.0) cycle +c--get volumetric Q*C and Q + QC=qss*delr(j)*delc(i)*dh(j,i,k)*ctmp + Q =qss*delr(j)*delc(i)*dh(j,i,k) +c--cumulate in GroupData + GroupData(6,n) = GroupData(6,n) + QC * fraction + GroupData(7,n) = GroupData(7,n) + Q * fraction + enddo !end of point sink/source loop + + enddo !end of the cell loop in the current flux object + + nobs_current=nobs_current+1 + iErrMsg=0 + ErrMsg=' ' + fluxcal=GroupData(6,n) + if(weight.lt.0) then + iErrMsg=-1 + ErrMsg='no observed flux given' + elseif(iOutFlux.gt.0) then + nobs_active=nobs_active+1 + grouptmp(nobs_active,1)=fluxobs + grouptmp(nobs_active,2)=fluxcal + error=(fluxcal-fluxobs)*weight + errsum=errsum+error*error + abserrsum=abserrsum+abs(error) + grouptmp(nobs_active,3)=error + endif + + if(iOutFlux.gt.0 .and. iErrMsg.eq.0) then + write(inFluxObs,30) iGroup,fobsnam(n),timeobs, + & icomp,fluxcal,fluxobs,weight,error + elseif(iOutFlux.gt.0 .and. iErrMsg.ne.0) then + write(inFluxObs,32) iGroup,fobsnam(n),timeobs, + & icomp,fluxcal,ErrMsg + elseif(iOutFlux.eq.0) then + write(inFluxObs,34) iGroup,fobsnam(n),timeobs, + & icomp,fluxcal + endif + if(inSaveObs.gt.0) then + write(inSaveObs) fobsnam(n),TimeObs,fluxcal + endif + + enddo !end of mass flux object loop + + 30 format(1x,i4,2x,a12,1p,g12.4,i4,6x,4g12.4) + 32 format(1x,i4,2x,a12,1p,g12.4,i4,6x,1g12.4,3x,a) + 34 format(1x,i4,2x,a12,1p,g12.4,i4,6x,1g12.4) +c +c--calculate statistics +c + if(iOutFlux.gt.0.and.nobs_active.gt.1) then + CALL MOMENT(grouptmp(1,3),nobs_active,AVE,ADEV, + & SDEV,VAR,SKEW,CURT) + CALL PEARSN(grouptmp(1,1),grouptmp(1,2), + & nobs_active,R,PROB,Z) + else + goto 1000 + endif +c +c--print statastics +c + write(inFluxObs,50) nobs_active + write(inFluxObs,60) AVE + write(inFluxObs,62) SDEV + write(inFluxObs,64) abserrsum/nobs_active + write(inFluxObs,66) SQRT(ERRSUM/nobs_active) + if(nobs_active.gt.2) then + write(inFluxObs,70) R + write(inFluxObs,72) PROB + endif + 50 FORMAT(/1x,' NUMBER OF ACTIVE OBSERVATION POINTS = ',I5) + 60 FORMAT( 1x,' MEAN OF RESIDUALS (M) = ',G15.7) + 62 FORMAT( 1x,'STANDARD DEVIATION OF RESIDUALS (SDEV) = ',G15.7) + 64 FORMAT( 1x,' MEAN OF ABSOLUTE RESIDUALS (MA) = ',G15.7) + 66 FORMAT( 1x,' ROOT MEAN SQUARED RESIDUALS (RMS) = ',G15.7) + 70 FORMAT( 1x,' CORRELATION COEFFICIENT = ',G15.7) + 72 FORMAT( 1x,' PROBABILITY OF UN-CORRELATION = ',G15.7) +c + 1000 IF(nobs_current.le.0) write(inFluxObs,1080) + 1080 FORMAT(1x,'[No flux object active at current transport step]') +c +c--normal return + RETURN + END +C +C + SUBROUTINE MOMENT(DATA,N,AVE,ADEV,SDEV,VAR,SKEW,CURT) +C ***************************************************************** +C This subroutine computes mean, variance, skewness, and kurtosis +C for an array of data points data(n). +C ***************************************************************** +C modified from Press et al. (1992) +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER n,j + REAL adev,ave,curt,sdev,skew,var,data,p,s,ep + DIMENSION data(n) +C + if(n.le.1) then + call ustop ('N must be at least 2 in subroutine MOMENT', + & ' used by TOB Package') + endif + s=0. + do j=1,n + s=s+data(j) + enddo + ave=s/n + adev=0. + var=0. + skew=0. + curt=0. + ep=0. + do j=1,n + s=data(j)-ave + ep=ep+s + adev=adev+abs(s) + p=s*s + var=var+p + p=p*s + skew=skew+p + p=p*s + curt=curt+p + enddo + adev=adev/n + var=(var-ep**2/n)/(n-1) + sdev=sqrt(var) + if(var.ne.0.)then + skew=skew/(n*sdev**3) + curt=curt/(n*var**2)-3. + else +CZ pause 'no skew or kurtosis when zero variance in moment' + endif +C + RETURN + END +C +C + SUBROUTINE PEARSN(X,Y,N,R,PROB,Z) +C ************************************************************* +C modified from Press et al. (1992) +C + IMPLICIT NONE + REAL,PARAMETER :: TINY=1.e-20 + INTEGER n,j + REAL prob,r,z,x,y,ax,ay,df,sxx,sxy,syy,t,xt,yt,betai + DIMENSION x(n),y(n) +C + if(n.le.2) goto 1 !added by CZ +C + ax=0. + ay=0. + do j=1,n + ax=ax+x(j) + ay=ay+y(j) + enddo + ax=ax/n + ay=ay/n + sxx=0. + syy=0. + sxy=0. + do j=1,n + xt=x(j)-ax + yt=y(j)-ay + sxx=sxx+xt**2 + syy=syy+yt**2 + sxy=sxy+xt*yt + enddo + r=sxy/(sqrt(sxx*syy) + TINY) !TINY added by CZ + z=0.5*log(((1.+r)+TINY)/((1.-r)+TINY)) + df=n-2 + t=r*sqrt(df/(((1.-r)+TINY)*((1.+r)+TINY))) + prob=betai(0.5*df,0.5,df/(df+t**2+TINY)) !TINY added by CZ +C prob=erfcc(abs(z*sqrt(n-1.))/1.4142136) + + 1 RETURN + END +C +C + FUNCTION BETAI(A,B,X) +C ******************************************************** +C modified from Press et al. (1992) +C + IMPLICIT NONE + REAL betai,a,b,x,bt,betacf,gammln +C + if(x.lt.0. .or. x.gt.1.) then + call ustop('Bad argument x in subroutine BETAI', + & ' used by TOB Package') + endif + if(x.eq.0. .or. x.eq.1.) then + bt=0. + else + bt=exp(gammln(a+b)-gammln(a)-gammln(b) + & +a*log(x)+b*log(1.-x)) + endif + if(x.lt.(a+1.)/(a+b+2.)) then + betai=bt*betacf(a,b,x)/a + return + else + betai=1.-bt*betacf(b,a,1.-x)/b + return + endif +C + END +C +C + FUNCTION BETACF(A,B,X) +C ******************************************************** +C modified from Press et al. (1992) +C + IMPLICIT NONE + INTEGER,PARAMETER :: MAXIT=100 + REAL,PARAMETER :: EPS=3.e-7,FPMIN=1.e-30 + INTEGER m,m2 + REAL betacf,a,b,x, + & aa,c,d,del,h,qab,qam,qap +C + qab=a+b + qap=a+1. + qam=a-1. + c=1. + d=1.-qab*x/qap + if(abs(d).lt.FPMIN) d=FPMIN + d=1./d + h=d + do m=1,MAXIT + m2=2*m + aa=m*(b-m)*x/((qam+m2)*(a+m2)) + d=1.+aa*d + if(abs(d).lt.FPMIN) d=FPMIN + c=1.+aa/c + if(abs(c).lt.FPMIN) c=FPMIN + d=1./d + h=h*d*c + aa=-(a+m)*(qab+m)*x/((a+m2)*(qap+m2)) + d=1.+aa*d + if(abs(d).lt.FPMIN) d=FPMIN + c=1.+aa/c + if(abs(c).lt.FPMIN) c=FPMIN + d=1./d + del=d*c + h=h*del + if(abs(del-1.).lt.EPS) goto 1 + enddo + call ustop('a or b too big, or MAXIT too small', + & ' in subroutine BETACF used by TOB Package') + 1 betacf=h +C + RETURN + END +C +C + FUNCTION GAMMLN(XX) +C ******************************************************************* +C modified from Press et al. (1992) +C + IMPLICIT NONE + INTEGER j + REAL gammln,xx + DOUBLE PRECISION ser,stp,tmp,x,y,cof(6) + SAVE cof,stp + DATA cof,stp/76.18009172947146d0,-86.50532032941677d0, + *24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2, + *-.5395239384953d-5,2.5066282746310005d0/ +C + x=xx + y=x + tmp=x+5.5d0 + tmp=(x+0.5d0)*log(tmp)-tmp + ser=1.000000000190015d0 + do j=1,6 + y=y+1.d0 + ser=ser+cof(j)/y + enddo + gammln=tmp+log(stp*ser/x) +C + RETURN + END \ No newline at end of file diff --git a/true-binary/mt_utl5.for b/true-binary/mt_utl5.for index e69de29..d8e321b 100644 --- a/true-binary/mt_utl5.for +++ b/true-binary/mt_utl5.for @@ -0,0 +1,1002 @@ +C + SUBROUTINE OPENFL(IN,ISTAT,FLNAME,IDFL,FINDEX) +C ****************************************************************** +C THIS SUBROUTINE OPENS AN INPUT/OUTPUT FILE ASSOCIATED WITH +C UNIT [IN], STATUS [ISTAT], AND FILE NAME [FLNAME]. +C FILE IS OPENED AS 'FORMATTED' IF [IN]>0; 'UNFORMATTED' IF [IN]<0. +C FILE STATUS IS 'OLD' IF [ISTAT]>0; 'NEW' IF <0; 'UNKNOWN' IF =0. +C IF [IDFL]>0, FILE WILL BE GIVEN THE DEFAULT NAME [FLNAME], +C OTHERWISE, THE SUBROUTINE WILL PROPMT FOR THE FILE NAME. +C THE CONTENT OF THE PROMPT IS IN [FINDEX]. +c NOTE: THE STYLE OF UNFORMATTED FILES IS SPECIFIED IN THE +C INCLUDE FILE 'filespec.inc' +C ****************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER IN,ISTAT,I,IDFL + LOGICAL LOP + CHARACTER FINDEX*30,FLNAME*50,FLFORM*15,FLSTAT*15,FILACT*20, + & ACCARG*20 +C + INCLUDE 'filespec.inc' +C +C--DETERMINE FILE FORM AND STATUS + IF(IN.GT.0) THEN + FLFORM='FORMATTED' + ACCARG='SEQUENTIAL' + ELSEIF(IN.LT.0) THEN + FLFORM=FORM + ACCARG=ACCESS + ELSE + WRITE(*,100) + CALL USTOP(' ') + ENDIF + IF(ISTAT.GT.0) THEN + FLSTAT='OLD' + FILACT=ACTION(1) + ELSEIF(ISTAT.LT.0) THEN + FLSTAT='NEW' + FILACT=ACTION(2) + ELSEIF(ISTAT.EQ.0) THEN + FLSTAT='UNKNOWN' + FILACT=ACTION(2) + ENDIF + 100 FORMAT(/1X,'ERROR: FILE CANNOT BE OPENED ON UNIT 0.') +C +C--GET FILE NAME IF NO DEFAULT NAME GIVEN + IF(IDFL.GT.0) GOTO 200 +C + IF(FINDEX.EQ.' ') THEN + IF(IN.GT.0) WRITE(*,101) IN + IF(IN.LT.0) WRITE(*,102) -IN + ELSE + WRITE(*,103) FINDEX + ENDIF + 10 READ(*,'(A50)') FLNAME + IF(FLNAME.EQ.' ') THEN + WRITE(*,*) 'Error: File Name Not Given.' + WRITE(*,*) 'Please Try Again =>' + GOTO 10 + ENDIF + 101 FORMAT(1X,'Enter Name of Formatted File for Unit',I3,': ') + 102 FORMAT(1X,'Enter Name of Unformatted File for Unit',I3,': ') + 103 FORMAT(1X,'Enter Name for ',A30) +C +C--OPEN FILE + 200 INQUIRE(UNIT=ABS(IN),OPENED=LOP) + IF(.NOT.LOP) THEN + I=INDEX(FLNAME,' ')-1 + OPEN(ABS(IN),FILE=FLNAME(1:I),ERR=20, + & FORM=FLFORM,STATUS=FLSTAT,ACCESS=ACCARG,ACTION=FILACT) + ENDIF + GOTO 30 + 20 IF(IDFL.GT.0) THEN + WRITE(*,2) FLNAME + CALL USTOP(' ') + ELSE + WRITE(*,3) FLNAME + GOTO 10 + ENDIF + 2 FORMAT(1X,'Error: File Cannot Be Found or Opened =>',A50) + 3 FORMAT(1X,'Error: File Cannot Be Found or Opened =>',A50 + & /1X,'Please Try Again =>') +C +C--FILE OPENED SUCCESSFUL, REWIND AND RETURN + 30 REWIND (ABS(IN)) + RETURN + END +C +C + SUBROUTINE IARRAY(IA,ANAME,II,JJ,K,IN,IOUT) +C ************************************************************ +C THIS SUBROUTINE IS USED TO INPUT 1 OR 2D INTEGER ARRAYS +C BY BLOCK, ZONAL, LIST-DIRECTED, UNFORMATTED, +C OR ANY USER-SPECIFIED FORMAT. +C ************************************************************ +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER NZMAX + PARAMETER (NZMAX=200) + INTEGER IA,II,JJ,K,IN,IOUT,IZV,IREAD,ICONST,IPRN, + & NBLOCK,NZONES,I1,I2,J1,J2,IZ,NN,I,J,N + LOGICAL OPD + CHARACTER ANAME*24,FMTIN*20,FINDEX*30,FLNAME*50 + DIMENSION IA(JJ,II),IZV(NZMAX) +C +C--READ ARRAY CONTROL RECORD +C ========================= + READ (IN,1) IREAD,ICONST,FMTIN,IPRN + 1 FORMAT(I10,I10,A20,I10) +C +C--IF IREAD=0, SET ALL ARRAY VALUES EQUAL TO ICONST. +C ================================================= + IF(IREAD.NE.0) GOTO 50 +C + DO 10 I=1,II + DO 12 J=1,JJ + IA(J,I)=ICONST + 12 CONTINUE + 10 CONTINUE + IF(K.GT.0) WRITE(IOUT,14) ANAME,ICONST,K + 14 FORMAT(39X,A24,' =',I15,' FOR LAYER',I3) + IF(K.LE.0) WRITE(IOUT,16) ANAME,ICONST + 16 FORMAT(39X,A24,' =',I15) + GOTO 500 +C +C--IF IREAD=100, INPUT ARRAY USING FORMAT FMTIN +C ============================================ + 50 IF(IREAD.NE.100) GOTO 90 +C + IF(K.GT.0) WRITE(IOUT,20) ANAME,K,IN,FMTIN + IF(K.LE.0) WRITE(IOUT,22) ANAME,IN,FMTIN + 20 FORMAT(/21X,A24,' FOR LAYER',I3,' READ ON UNIT', + & I3,' USING FORMAT: "',A20,'"'/21X,90('-')) + 22 FORMAT(/27X,A24,' READ ON UNIT', + & I3,' USING FORMAT: "',A20,'"'/27X,77('-')) + DO 30 I=1,II + READ (IN,FMTIN) (IA(J,I),J=1,JJ) + 30 CONTINUE + GOTO 300 +C +C--IF IREAD=101, INPUT ARRAY USING BLOCK FORMAT +C ============================================ + 90 IF(IREAD.NE.101) GOTO 100 +C + IF(K.GT.0) WRITE(IOUT,55) ANAME,K,IN + IF(K.LE.0) WRITE(IOUT,60) ANAME,IN + 55 FORMAT(/29X,A24,' FOR LAYER',I3,' READ ON UNIT', + & I3,' USING BLOCK FORMAT'/29X,72('-')) + 60 FORMAT(/35X,A24,' READ ON UNIT', + & I3,' USING BLOCK FORMAT'/35X,59('-')) +C +C--READ NUMBER OF BLOCKS + READ(IN,*) NBLOCK +C +C--READ VALUE OF EACH BLOCK +C--AND ASSIGN VALUE TO CELLS WITHIN THE BLOCK + DO 70 N=1,NBLOCK + READ(IN,*) I1,I2,J1,J2,IZ + DO 72 I=I1,I2 + DO 74 J=J1,J2 + IA(J,I)=IZ + 74 CONTINUE + 72 CONTINUE + 70 CONTINUE + GOTO 300 +C +C--IF IREAD=102, INPUT ARRAY USING ZONAL FORMAT +C ============================================ + 100 IF(IREAD.NE.102) GOTO 200 +C + IF(K.GT.0) WRITE(IOUT,150) ANAME,K,IN + IF(K.LE.0) WRITE(IOUT,160) ANAME,IN + 150 FORMAT(/29X,A24,' FOR LAYER',I3,' READ ON UNIT', + & I3,' USING ZONAL FORMAT'/29X,72('-')) + 160 FORMAT(/35X,A24,' READ ON UNIT', + & I3,' USING ZONAL FORMAT'/35X,59('-')) +C +C--READ NUMBER OF ZONES + READ(IN,*) NZONES + IF(NZONES.GT.NZMAX) THEN + WRITE(*,165) + CALL USTOP(' ') + ENDIF + 165 FORMAT(/1X,'ERROR: MAXIMUM NUMBER OF ZONES EXCEEDED' + & /1X,'INCREASE DIMENSION OF [NZMAX] IN SUBROUTINE [IARRAY]') +C +C--READ ZONAL MAP WITH FORMAT FMTIN + READ(IN,*) (IZV(N),N=1,NZONES) + DO 175 I=1,II + READ(IN,FMTIN) (IA(J,I),J=1,JJ) + 175 CONTINUE +C +C--ASSIGN ZONAL VALUES + DO 176 I=1,II + DO 177 J=1,JJ + NN=IA(J,I) + IF(NN.EQ.0) THEN + IA(J,I)=0 + ELSE + IA(J,I)=IZV(NN) + ENDIF + 177 CONTINUE + 176 CONTINUE + GOTO 300 +C +C--IF IREAD=103, INPUT ARRAY USING FREE FORMAT +C =========================================== + 200 IF(IREAD.NE.103) GOTO 250 +C + IF(K.GT.0) WRITE(IOUT,210) ANAME,K,IN + IF(K.LE.0) WRITE(IOUT,220) ANAME,IN + 210 FORMAT(/29X,A24,' FOR LAYER',I3,' READ ON UNIT', + & I3,' USING FREE FORMAT'/29X,71('-')) + 220 FORMAT(/35X,A24,' READ ON UNIT', + & I3,' USING FREE FORMAT'/35X,58('-')) +C +C--READ ARRAY VALUES WITH FREE FORMAT + READ(IN,*) ((IA(J,I),J=1,JJ),I=1,II) + GOTO 300 +C +C--IF IREAD IS EQUAL TO ANY OTHER VALUES, +C--READ ARRAY VALUES FROM AN EXTERNAL FILE ON UNIT [IREAD] +C ======================================================= +C +C--CHECK IF THE EXTERNAL FILE HAS BEEN OPENED. IF NOT, OPEN + 250 INQUIRE(UNIT=IABS(IREAD),OPENED=OPD) + IF(.NOT.OPD) THEN + FINDEX=' ' + CALL OPENFL(IREAD,1,FLNAME,0,FINDEX) + ENDIF +C +C--IF IREAD<0, INPUT ARRAY FROM AN UNFORMATTED FILE OM UNIT [-IREAD] + IF(IREAD.LT.0) THEN + IF(K.GT.0) WRITE(IOUT,256) ANAME,K,-IREAD + IF(K.LE.0) WRITE(IOUT,258) ANAME,-IREAD + 256 FORMAT(/33X,A24,' FOR LAYER',I3,' READ UNFORMATTED', + & ' ON UNIT',I3/33X,65('-')) + 258 FORMAT(/40X,A24,' READ UNFORMATTED ON UNIT', + & I3/40X,52('-')) +C +C--READ AN UNFORMATTED DUMMY RECORD FIRST. + READ(-IREAD) + READ(-IREAD) IA + ELSE +C +C--ELSE IF IREAD>0, INPUT ARRAY FROM AN FORMATTED FILE ON UNIT [IREAD] +C--WITH FORMAT FMTIN + IF(K.GT.0) WRITE(IOUT,20) ANAME,K,IREAD,FMTIN + IF(K.LE.0) WRITE(IOUT,22) ANAME,IREAD,FMTIN + DO 270 I=1,II + READ (IREAD,FMTIN) (IA(J,I),J=1,JJ) + 270 CONTINUE + ENDIF +C +C--IF ICONST NOT ZERO THEN MULTIPLY ARRAY VALUES BY ICONST. + 300 IF(ICONST.EQ.0) GO TO 320 + DO 302 I=1,II + DO 304 J=1,JJ + IA(J,I)=IA(J,I)*ICONST + 304 CONTINUE + 302 CONTINUE +C +C--IF PRINT CODE (IPRN) =>0 THEN PRINT ARRAY VALUES + 320 IF(IPRN.LT.0) GOTO 500 + CALL IPRINT(IA,ANAME,0,0,0,JJ,II,0,IPRN,IOUT) +C +C--RETURN + 500 RETURN + END +C +C + SUBROUTINE RARRAY(A,ANAME,II,JJ,K,IN,IOUT) +C ******************************************************** +C THIS SUBROUTINE IS USED TO INPUT 1 OR 2D REAL ARRAYS, +C BY BLOCK, ZONAL, LIST-DIRECTED, UNFORMATTED, +C OR ANY USER-SPECIFIED FORMAT. +C ******************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER NZMAX + PARAMETER (NZMAX=200) + INTEGER I,J,N,II,JJ,K,IN,IOUT,IREAD,IPRN, + & NBLOCK,NZONES,I1,I2,J1,J2,NN, + & NTRANS,KSTP,KPER,NC,NR,ILAY + REAL A,ZV,CONST,ZZ,TOTIM + LOGICAL OPD + CHARACTER ANAME*24,FMTIN*20,FINDEX*30,FLNAME*50,TEXT*16 + DIMENSION A(JJ,II),ZV(NZMAX) +C +C--READ ARRAY CONTROL RECORD +C ========================= + READ (IN,1) IREAD,CONST,FMTIN,IPRN + 1 FORMAT(I10,F10.0,A20,I10) +C +C--IF IREAD=0, SET ALL ARRAY VALUES EQUAL TO CONST. +C ================================================ + IF(IREAD.NE.0) GOTO 50 +C + DO 10 I=1,II + DO 12 J=1,JJ + A(J,I)=CONST + 12 CONTINUE + 10 CONTINUE + IF(K.GT.0) WRITE(IOUT,14) ANAME,CONST,K + 14 FORMAT(39X,A24,' =',G15.7,' FOR LAYER',I3) + IF(K.LE.0) WRITE(IOUT,16) ANAME,CONST + 16 FORMAT(39X,A24,' =',G15.7) + GOTO 500 +C +C--IF IREAD=100, INPUT ARRAY USING FORMAT FMTIN +C ============================================ + 50 IF(IREAD.NE.100) GOTO 90 +C + IF(K.GT.0) WRITE(IOUT,20) ANAME,K,IN,FMTIN + IF(K.LE.0) WRITE(IOUT,22) ANAME,IN,FMTIN + 20 FORMAT(/21X,A24,' FOR LAYER',I3,' READ ON UNIT', + & I3,' USING FORMAT: "',A20,'"'/21X,90('-')) + 22 FORMAT(/27X,A24,' READ ON UNIT', + & I3,' USING FORMAT: "',A20,'"'/27X,77('-')) + DO 30 I=1,II + READ (IN,FMTIN) (A(J,I),J=1,JJ) + 30 CONTINUE + GOTO 300 +C +C--IF IREAD=101, INPUT ARRAY USING BLOCK FORMAT +C ============================================ + 90 IF(IREAD.NE.101) GOTO 100 +C + IF(K.GT.0) WRITE(IOUT,55) ANAME,K,IN + IF(K.LE.0) WRITE(IOUT,60) ANAME,IN + 55 FORMAT(/29X,A24,' FOR LAYER',I3,' READ ON UNIT', + & I3,' USING BLOCK FORMAT'/29X,72('-')) + 60 FORMAT(/35X,A24,' READ ON UNIT', + & I3,' USING BLOCK FORMAT'/35X,59('-')) +C +C--READ NUMBER OF BLOCKS + READ(IN,*) NBLOCK +C +C--READ VALUE OF EACH BLOCK +C--AND ASSIGN VALUE TO CELLS WITHIN THE BLOCK + DO 70 N=1,NBLOCK + READ(IN,*) I1,I2,J1,J2,ZZ + DO 72 I=I1,I2 + DO 74 J=J1,J2 + A(J,I)=ZZ + 74 CONTINUE + 72 CONTINUE + 70 CONTINUE + GOTO 300 +C +C--IF IREAD=102, INPUT ARRAY USING ZONAL FORMAT +C ============================================ + 100 IF(IREAD.NE.102) GOTO 200 +C + IF(K.GT.0) WRITE(IOUT,150) ANAME,K,IN + IF(K.LE.0) WRITE(IOUT,160) ANAME,IN + 150 FORMAT(/29X,A24,' FOR LAYER',I3,' READ ON UNIT', + & I3,' USING ZONAL FORMAT'/29X,72('-')) + 160 FORMAT(/35X,A24,' READ ON UNIT', + & I3,' USING ZONAL FORMAT'/35X,59('-')) +C +C--READ NUMBER OF ZONES + READ(IN,*) NZONES + IF(NZONES.GT.NZMAX) THEN + WRITE(*,165) + CALL USTOP(' ') + ENDIF + 165 FORMAT(1X,'ERROR: MAXIMUM NUMBER OF ZONES EXCEEDED' + & /1X,'INCREASE DIMENSION OF [NZMAX] IN SUBROUTINE [RARRAY]') +C +C--READ ZONAL MAP WITH FORMAT FMTIN + READ(IN,*) (ZV(N),N=1,NZONES) + DO 175 I=1,II + READ(IN,FMTIN) (A(J,I),J=1,JJ) + 175 CONTINUE +C +C--ASSIGN ZONAL VALUES + DO 176 I=1,II + DO 177 J=1,JJ + NN=A(J,I) + IF(NN.EQ.0) THEN + A(J,I)=0 + ELSE + A(J,I)=ZV(NN) + ENDIF + 177 CONTINUE + 176 CONTINUE + GOTO 300 +C +C--IF IREAD=103, INPUT ARRAY USING FREE FORMAT +C =========================================== + 200 IF(IREAD.NE.103) GOTO 250 +C + IF(K.GT.0) WRITE(IOUT,210) ANAME,K,IN + IF(K.LE.0) WRITE(IOUT,220) ANAME,IN + 210 FORMAT(/29X,A24,' FOR LAYER',I3,' READ ON UNIT', + & I3,' USING FREE FORMAT'/29X,71('-')) + 220 FORMAT(/35X,A24,' READ ON UNIT', + & I3,' USING FREE FORMAT'/35X,58('-')) +C +C--READ ARRAY VALUES WITH FREE FORMAT + READ(IN,*) ((A(J,I),J=1,JJ),I=1,II) + GOTO 300 +C +C--IF IREAD IS EQUAL TO ANY OTHER VALUES, +C--READ ARRAY VALUES FROM AN EXTERNAL FILE ON UNIT [IREAD] +C ======================================================= +C +C--CHECK IF THE EXTERNAL FILE HAS BEEN OPENED. IF NOT, OPEN + 250 INQUIRE(UNIT=IABS(IREAD),OPENED=OPD) + IF(.NOT.OPD) THEN + FINDEX=' ' + CALL OPENFL(IREAD,1,FLNAME,0,FINDEX) + ENDIF +C +C--IF IREAD<0, INPUT ARRAY FROM AN UNFORMATTED FILE OM UNIT [-IREAD] + IF(IREAD.LT.0) THEN + IF(K.GT.0) WRITE(IOUT,256) ANAME,K,-IREAD + IF(K.LE.0) WRITE(IOUT,258) ANAME,-IREAD + 256 FORMAT(/33X,A24,' FOR LAYER',I3,' READ UNFORMATTED', + & ' ON UNIT',I3/33X,65('-')) + 258 FORMAT(/40X,A24,' READ UNFORMATTED ON UNIT', + & I3/40X,52('-')) +C +C--READ AN UNFORMATTED DUMMY RECORD FIRST. + READ(-IREAD) NTRANS,KSTP,KPER,TOTIM,TEXT,NC,NR,ILAY + READ(-IREAD) A + ELSE +C +C--ELSE IF IREAD>0, INPUT ARRAY FROM AN FORMATTED FILE ON UNIT [IREAD] +C--WITH FORMAT FMTIN + IF(K.GT.0) WRITE(IOUT,20) ANAME,K,IREAD,FMTIN + IF(K.LE.0) WRITE(IOUT,22) ANAME,IREAD,FMTIN + DO 270 I=1,II + READ (IREAD,FMTIN) (A(J,I),J=1,JJ) + 270 CONTINUE + ENDIF +C +C--IF CONST NOT ZERO THEN MULTIPLY ARRAY VALUES BY CONST. + 300 IF(CONST.EQ.0) GO TO 320 + DO 302 I=1,II + DO 304 J=1,JJ + A(J,I)=A(J,I)*CONST + 304 CONTINUE + 302 CONTINUE +C +C--IF PRINT CODE (IPRN) =>0 THEN PRINT ARRAY VALUES. + 320 IF(IPRN.LT.0) RETURN + CALL RPRINT(A,ANAME,0,0,0,JJ,II,0,IPRN,IOUT) +C +C8------RETURN + 500 RETURN + END +C +C + SUBROUTINE IPRINT(IA,TEXT,KTRN,KSTP,KPER,NCOL,NROW, + & ILAY,IPRN,IOUT) +C ************************************************************ +C PRINT AN INTEGER 1 OR 2D ARRAY IN WRAP OR STRIP FORM. +C [MODIFIED FROM MCDONALD AND HARBAUGH (1988)]. +C ************************************************************ +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER IA,KTRN,KSTP,KPER,NCOL,NROW,ILAY,IPRN,IOUT, + & IP,NCPF,NCAP,J1,J2,NSTRIP,ISP,J,I,N + CHARACTER TEXT*16 + DIMENSION IA(NCOL,NROW) +C +C--PRINT A HEADER + IF(ILAY.LE.0) GO TO 5 + IF(KTRN.GT.0) GO TO 4 + WRITE(IOUT,1) TEXT,ILAY,KSTP,KPER + 1 FORMAT(/35X,A16,' IN LAYER',I3, + & ' FOR TIME STEP',I3,', STRESS PERIOD',I3/35X,63('-')) + GOTO 5 +C + 4 WRITE(IOUT,2) TEXT,ILAY,KTRN,KSTP,KPER + 2 FORMAT(/21X,A16,' IN LAYER',I3,' AT END OF TRANSPORT STEP',I5, + & ', TIME STEP',I3,', STRESS PERIOD',I3/21X,90('-')) +C +C--MAKE SURE IPRN VALUE IS WITHIN PRINT FORMAT-CODE RANGE + 5 IP=IPRN + IF(IP.GT.5.OR.IP.LT.-5) IP=0 + IF(IP.GE.0) IP=IP+1 + IF(IP.LT.0) IP=IP-1 +C +C--DETERMINE THE NUMBER OF VALUES (NCAP) PRINTED ON ONE LINE, +C--NUMBER OF BLANK SPACES TO LEAVE AT START OF THE LINE (ISP) +C--AND NUMBER OF SPACES IN EACH COLUMN FIELD (NCPF) + IF(IABS(IP).EQ.1) THEN + NCPF=12 + ISP=4 + NCAP=10 + ELSEIF(IABS(IP).GT.1) THEN + NCPF=IABS(IP) + ISP=4 + NCAP=125/IABS(IP)/5*5 + ENDIF +C +C--IF IP>0, ARRAY IS PRINTED IN WRAP FORMAT + IF(IP.GT.0.OR.NCOL.LE.NCAP) THEN + NSTRIP=1 + J1=1 + J2=NCOL +C +C--ELSE IF IP<0, ARRAY IS PRINTED IN STRIP FORMAT. +C--NUMBER OF STRIPS IS CALCULATED AS [NSTRIP] + ELSE + NSTRIP=(NCOL-1)/NCAP+1 + J1=1-NCAP + J2=0 + ENDIF +C +C--LOOP THROUGH THE STRIPS + DO 400 N=1,NSTRIP +C +C--CALCULATE FIRST(J1) & LAST(J2) COLUMNS FOR THIS STRIP +C--IF STRIP FORM IS USED + IF(NSTRIP.GT.1) THEN + J1=J1+NCAP + J2=J2+NCAP + IF(J2.GT.NCOL) J2=NCOL + ENDIF +C +C--PRINT COLUMN NUMBERS ABOVE THE STRIP. + CALL UCOLNO(J1,J2,ISP,NCAP,NCPF,IOUT) +C +C--PRINT EACH ROW + DO 410 I=1,NROW +C +C--SELECT THE FORMAT + GOTO (401,402,403,404,405,406), IABS(IP) +C +C--FORMAT 10I11 + 401 IF(IP.GT.0) WRITE(IOUT,1001) I,(IA(J,I),J=J1,J2) + IF(IP.LT.0) WRITE(IOUT,2001) I,(IA(J,I),J=J1,J2) + 1001 FORMAT(1X,I3,2X,I11,9(1X,I11)/(5X,10(1X,I11))) + 2001 FORMAT(1X,I3,2X,I11,9(1X,I11)) + GO TO 410 +C +C--FORMAT 60I1 + 402 IF(IP.GT.0) WRITE(IOUT,1002) I,(IA(J,I),J=J1,J2) + IF(IP.LT.0) WRITE(IOUT,2002) I,(IA(J,I),J=J1,J2) + 1002 FORMAT(1X,I3,1X,60(1X,I1)/(5X,60(1X,I1))) + 2002 FORMAT(1X,I3,1X,60(1X,I1)) + GO TO 410 +C +C--FORMAT 40I2 + 403 IF(IP.GT.0) WRITE(IOUT,1003) I,(IA(J,I),J=J1,J2) + IF(IP.LT.0) WRITE(IOUT,2003) I,(IA(J,I),J=J1,J2) + 1003 FORMAT(1X,I3,1X,40(1X,I2)/(5X,40(1X,I2))) + 2003 FORMAT(1X,I3,1X,40(1X,I2)) + GO TO 410 +C +C--FORMAT 30I3 + 404 IF(IP.GT.0) WRITE(IOUT,1004) I,(IA(J,I),J=J1,J2) + IF(IP.LT.0) WRITE(IOUT,2004) I,(IA(J,I),J=J1,J2) + 1004 FORMAT(1X,I3,1X,30(1X,I3)/(5X,30(1X,I3))) + 2004 FORMAT(1X,I3,1X,30(1X,I3)) + GO TO 410 +C +C--FORMAT 25I4 + 405 IF(IP.GT.0) WRITE(IOUT,1005) I,(IA(J,I),J=J1,J2) + IF(IP.LT.0) WRITE(IOUT,2005) I,(IA(J,I),J=J1,J2) + 1005 FORMAT(1X,I3,1X,25(1X,I4)/(5X,25(1X,I4))) + 2005 FORMAT(1X,I3,1X,25(1X,I4)) + GO TO 410 +C +C--FORMAT 20I5 + 406 IF(IP.GT.0) WRITE(IOUT,1006) I,(IA(J,I),J=J1,J2) + IF(IP.LT.0) WRITE(IOUT,2006) I,(IA(J,I),J=J1,J2) + 1006 FORMAT(1X,I3,1X,20(1X,I5)/(5X,20(1X,I5))) + 2006 FORMAT(1X,I3,1X,20(1X,I5)) + 410 CONTINUE +C + 400 CONTINUE +C +C--RETURN + RETURN + END +C +C + SUBROUTINE RPRINT(BUFF,TEXT,KTRN,KSTP,KPER,NCOL,NROW, + & ILAY,IPRN,IOUT) +C **************************************************************** +C PRINT A REAL 1 OR 2D ARRAY IN WRAP OR STRIP FORM. +C [MODIFIED FROM MCDONALD AND HARBAUGH (1988)]. +C **************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER KTRN,KSTP,KPER,NCOL,NROW,ILAY,IPRN,IOUT,IP,J,I, + & J1,J2,NCPF,NCAP,NSTRIP,ISP,N + REAL BUFF + CHARACTER TEXT*16 + DIMENSION BUFF(NCOL,NROW) +C +C--PRINT A HEADER + IF(ILAY.LE.0) GO TO 5 + IF(KTRN.GT.0) GO TO 4 + WRITE(IOUT,1) TEXT,ILAY,KSTP,KPER + 1 FORMAT(/35X,A16,' IN LAYER',I3, + & ' FOR TIME STEP',I3,', STRESS PERIOD',I3/35X,63('-')) + GOTO 5 +C + 4 WRITE(IOUT,2) TEXT,ILAY,KTRN,KSTP,KPER + 2 FORMAT(/21X,A16,' IN LAYER',I3,' AT END OF TRANSPORT STEP',I5, + & ', TIME STEP',I3,', STRESS PERIOD',I3/21X,90('-')) +C +C--MAKE SURE IPRN VALVE IS WITHIN PRINT-FORMAT CODE RANGE + 5 IP=IPRN + IF(IP.GT.12) IP=12 + IF(IP.LT.-12) IP=-12 + IF(IP.EQ.0) IP=12 +C +C--DETERMINE THE NUMBER OF VALUES (NCAP) PRINTED ON ONE LINE, +C--NUMBER OF BLANK SPACES TO LEAVE AT START OF THE LINE (ISP) +C--AND NUMBER OF SPACES IN EACH COLUMN FIELD (NCPF) + IF(IABS(IP).EQ.1) NCAP=11 + IF(IABS(IP).EQ.2) NCAP=9 + IF(IABS(IP).GT.2 .AND. IABS(IP).LT.7) NCAP=15 + IF(IABS(IP).GT.6 .AND. IABS(IP).LT.12) NCAP=20 + IF(IABS(IP).EQ.12) NCAP=10 + NCPF=129/NCAP + ISP=0 + IF(NCAP.GT.12) ISP=3 +C +C--IF IP>0, ARRAY IS PRINTED IN WRAP FORM + IF(IP.GT.0.OR.NCOL.LE.NCAP) THEN + NSTRIP=1 + J1=1 + J2=NCOL +C +C--ELSE IF IP<0, ARRAY IS PRINTED IN STRIP FORM. +C--NUMBER OF STRIPS IS CALCULATED AS [NSTRIP] + ELSE + NSTRIP=(NCOL-1)/NCAP + 1 + J1=1-NCAP + J2=0 + ENDIF +C +C--LOOP THROUGH THE STRIPS + DO 2000 N=1,NSTRIP +C +C--CALCULATE FIRST(J1) & LAST(J2) COLUMNS FOR THIS STRIP +C--IF STRIP FORM IS USED + IF(NSTRIP.GT.1) THEN + J1=J1+NCAP + J2=J2+NCAP + IF(J2.GT.NCOL) J2=NCOL + ENDIF +C +C--PRINT COLUMN NUMBERS ABOVE THE STRIP + CALL UCOLNO(J1,J2,ISP,NCAP,NCPF,IOUT) +C +C--LOOP THROUGH THE ROWS PRINTING COLS J1 THRU J2 WITH FORMAT IP + DO 1000 I=1,NROW + GO TO(10,20,30,40,50,60,70,80,90,100,110,120), IABS(IP) +C +C--FORMAT 11G10.3 + 10 IF(IP.GT.0) WRITE(IOUT,11) I,(BUFF(J,I),J=J1,J2) + IF(IP.LT.0) WRITE(IOUT,12) I,(BUFF(J,I),J=J1,J2) + 11 FORMAT(1X,I3,2X,1PG10.3,10(1X,G10.3)/(5X,11(1X,G10.3))) + 12 FORMAT(1X,I3,2X,1PG10.3,10(1X,G10.3)) + GO TO 1000 +C +C--FORMAT 9G13.6 + 20 IF(IP.GT.0) WRITE(IOUT,21) I,(BUFF(J,I),J=J1,J2) + IF(IP.LT.0) WRITE(IOUT,22) I,(BUFF(J,I),J=J1,J2) + 21 FORMAT(1X,I3,2X,1PG13.6,8(1X,G13.6)/(5X,9(1X,G13.6))) + 22 FORMAT(1X,I3,2X,1PG13.6,8(1X,G13.6)) + GO TO 1000 +C +C--FORMAT 15F7.1 + 30 IF(IP.GT.0) WRITE(IOUT,31) I,(BUFF(J,I),J=J1,J2) + IF(IP.LT.0) WRITE(IOUT,32) I,(BUFF(J,I),J=J1,J2) + 31 FORMAT(1X,I3,1X,15(1X,F7.1)/(5X,15(1X,F7.1))) + 32 FORMAT(1X,I3,1X,15(1X,F7.1)) + GO TO 1000 +C +C--FORMAT 15F7.2 + 40 IF(IP.GT.0) WRITE(IOUT,41) I,(BUFF(J,I),J=J1,J2) + IF(IP.LT.0) WRITE(IOUT,42) I,(BUFF(J,I),J=J1,J2) + 41 FORMAT(1X,I3,1X,15(1X,F7.2)/(5X,15(1X,F7.2))) + 42 FORMAT(1X,I3,1X,15(1X,F7.2)) + GO TO 1000 +C +C--FORMAT 15F7.3 + 50 IF(IP.GT.0) WRITE(IOUT,51) I,(BUFF(J,I),J=J1,J2) + IF(IP.LT.0) WRITE(IOUT,52) I,(BUFF(J,I),J=J1,J2) + 51 FORMAT(1X,I3,1X,15(1X,F7.3)/(5X,15(1X,F7.3))) + 52 FORMAT(1X,I3,1X,15(1X,F7.3)) + GO TO 1000 +C +C--FORMAT 15F7.4 + 60 IF(IP.GT.0) WRITE(IOUT,61) I,(BUFF(J,I),J=J1,J2) + IF(IP.LT.0) WRITE(IOUT,62) I,(BUFF(J,I),J=J1,J2) + 61 FORMAT(1X,I3,1X,15(1X,F7.4)/(5X,15(1X,F7.4))) + 62 FORMAT(1X,I3,1X,15(1X,F7.4)) + GO TO 1000 +C +C--FORMAT 20F5.0 + 70 IF(IP.GT.0) WRITE(IOUT,71) I,(BUFF(J,I),J=J1,J2) + IF(IP.LT.0) WRITE(IOUT,72) I,(BUFF(J,I),J=J1,J2) + 71 FORMAT(1X,I3,1X,20(1X,F5.0)/(5X,20(1X,F5.0))) + 72 FORMAT(1X,I3,1X,20(1X,F5.0)) + GO TO 1000 +C +C--FORMAT 20F5.1 + 80 IF(IP.GT.0) WRITE(IOUT,81) I,(BUFF(J,I),J=J1,J2) + IF(IP.LT.0) WRITE(IOUT,82) I,(BUFF(J,I),J=J1,J2) + 81 FORMAT(1X,I3,1X,20(1X,F5.1)/(5X,20(1X,F5.1))) + 82 FORMAT(1X,I3,1X,20(1X,F5.1)) + GO TO 1000 +C +C--FORMAT 20F5.2 + 90 IF(IP.GT.0) WRITE(IOUT,91) I,(BUFF(J,I),J=J1,J2) + IF(IP.LT.0) WRITE(IOUT,92) I,(BUFF(J,I),J=J1,J2) + 91 FORMAT(1X,I3,1X,20(1X,F5.2)/(5X,20(1X,F5.2))) + 92 FORMAT(1X,I3,1X,20(1X,F5.2)) + GO TO 1000 +C +C--FORMAT 20F5.3 + 100 IF(IP.GT.0) WRITE(IOUT,101) I,(BUFF(J,I),J=J1,J2) + IF(IP.LT.0) WRITE(IOUT,102) I,(BUFF(J,I),J=J1,J2) + 101 FORMAT(1X,I3,1X,20(1X,F5.3)/(5X,20(1X,F5.3))) + 102 FORMAT(1X,I3,1X,20(1X,F5.3)) + GO TO 1000 +C +C--FORMAT 20F5.4 + 110 IF(IP.GT.0) WRITE(IOUT,111) I,(BUFF(J,I),J=J1,J2) + IF(IP.LT.0) WRITE(IOUT,112) I,(BUFF(J,I),J=J1,J2) + 111 FORMAT(1X,I3,1X,20(1X,F5.4)/(5X,20(1X,F5.4))) + 112 FORMAT(1X,I3,1X,20(1X,F5.4)/(5X,20(1X,F5.4))) + GO TO 1000 +C +C--FORMAT 10G11.4 + 120 IF(IP.GT.0) WRITE(IOUT,121) I,(BUFF(J,I),J=J1,J2) + IF(IP.LT.0) WRITE(IOUT,122) I,(BUFF(J,I),J=J1,J2) + 121 FORMAT(1X,I3,2X,1PG11.4,9(1X,G11.4)/(5X,10(1X,G11.4))) + 122 FORMAT(1X,I3,2X,1PG11.4,9(1X,G11.4)) +C + 1000 CONTINUE + 2000 CONTINUE +C +C--RETURN + RETURN + END +C +C + SUBROUTINE UCOLNO(NLBL1,NLBL2,NSPACE,NCPL,NDIG,IOUT) +C **************************************************************** +C OUTPUT COLUMN NUMBERS ABOVE A MATRIX PRINTOUT. +C [MODIFIED FROM MCDONALD AND HARBAUGH (1988)]. +C **************************************************************** +C last modified: 02-15-2005 +C + IMPLICIT NONE + INTEGER NLBL1,NLBL2,NSPACE,NCPL,NDIG,IOUT,N, + & J1,J2,J,I1,I2,I3,I,NTOT,NWRAP,NBF,NLBL + CHARACTER DOT*4,SPACE*4,DG*4,BF*4 + DIMENSION BF(130),DG(10) +C +C--ASSIGN CHARACTER STRING + DG(1)='0 ' + DG(2)='1 ' + DG(3)='2 ' + DG(4)='3 ' + DG(5)='4 ' + DG(6)='5 ' + DG(7)='6 ' + DG(8)='7 ' + DG(9)='8 ' + DG(10)='9 ' + DOT='. ' + SPACE=' ' +C +C--CALCULATE # OF COLUMNS TO BE PRINTED (NLBL), WIDTH +C--OF A LINE (NTOT), NUMBER OF LINES (NWRAP). + WRITE(IOUT,1) + 1 FORMAT(1X) + NLBL=NLBL2-NLBL1+1 + N=NLBL + IF(NLBL.GT.NCPL) N=NCPL + NTOT=NSPACE+N*NDIG + IF(NTOT.GT.130) GO TO 50 + NWRAP=(NLBL-1)/NCPL + 1 + J1=NLBL1-NCPL + J2=NLBL1-1 +C +C--BUILD AND PRINT EACH LINE + DO 40 N=1,NWRAP +C +C--CLEAR THE BUFFER (BF). + DO 20 I=1,130 + BF(I)=SPACE + 20 CONTINUE + NBF=NSPACE +C +C--DETERMINE FIRST (J1) AND LAST (J2) COLUMN # FOR THIS LINE. + J1=J1+NCPL + J2=J2+NCPL + IF(J2.GT.NLBL2) J2=NLBL2 +C +C--LOAD THE COLUMN #'S INTO THE BUFFER. + DO 30 J=J1,J2 + NBF=NBF+NDIG + I2=J/10 + I1=J-I2*10+1 + BF(NBF)=DG(I1) + IF(I2.EQ.0) GO TO 30 + I3=I2/10 + I2=I2-I3*10+1 + BF(NBF-1)=DG(I2) + IF(I3.EQ.0) GO TO 30 + BF(NBF-2)=DG(I3+1) + 30 CONTINUE +C +C--PRINT THE CONTENTS OF THE BUFFER (I.E. PRINT THE LINE). + WRITE(IOUT,31) (BF(I),I=1,NBF) + 31 FORMAT(1X,130A1) +C + 40 CONTINUE +C +C--PRINT A LINE OF DOTS (FOR ESTHETIC PURPOSES ONLY). + 50 NTOT=NTOT+5 + IF(NTOT.GT.130) NTOT=130 + WRITE(IOUT,51) (DOT,I=1,NTOT) + 51 FORMAT(1X,130A1) +C +C--RETURN + RETURN + END +C +C + SUBROUTINE URWORD(LINE,ICOL,ISTART,ISTOP,NCODE,N,R,IOUT,IN) +C ****************************************************************** +C ROUTINE TO EXTRACT A WORD FROM A LINE OF TEXT, AND OPTIONALLY +C CONVERT THE WORD TO A NUMBER. +C ISTART AND ISTOP WILL BE RETURNED WITH THE STARTING AND +C ENDING CHARACTER POSITIONS OF THE WORD. +C THE LAST CHARACTER IN THE LINE IS SET TO BLANK SO THAT IF ANY +C PROBLEMS OCCUR WITH FINDING A WORD, ISTART AND ISTOP WILL +C POINT TO THIS BLANK CHARACTER. THUS, A WORD WILL ALWAYS BE +C RETURNED UNLESS THERE IS A NUMERIC CONVERSION ERROR. BE SURE +C THAT THE LAST CHARACTER IN LINE IS NOT AN IMPORTANT CHARACTER +C BECAUSE IT WILL ALWAYS BE SET TO BLANK. +C A WORD STARTS WITH THE FIRST CHARACTER THAT IS NOT A SPACE OR +C COMMA, AND ENDS WHEN A SUBSEQUENT CHARACTER THAT IS A SPACE +C OR COMMA. NOTE THAT THESE PARSING RULES DO NOT TREAT TWO +C COMMAS SEPARATED BY ONE OR MORE SPACES AS A NULL WORD. +C FOR A WORD THAT BEGINS WITH "'", THE WORD STARTS WITH THE +C CHARACTER AFTER THE QUOTE AND ENDS WITH THE CHARACTER +C PRECEDING A SUBSEQUENT QUOTE. THUS, A QUOTED WORD CAN +C INCLUDE SPACES AND COMMAS. THE QUOTED WORD CANNOT CONTAIN +C A QUOTE CHARACTER. +C IF NCODE IS 1, THE WORD IS CONVERTED TO UPPER CASE. +C IF NCODE IS 2, THE WORD IS CONVERTED TO AN INTEGER. +C IF NCODE IS 3, THE WORD IS CONVERTED TO A REAL NUMBER. +C NUMBER CONVERSION ERROR IS WRITTEN TO UNIT IOUT IF IOUT IS +C POSITIVE; ERROR IS WRITTEN TO DEFAULT OUTPUT IF IOUT IS 0; +C NO ERROR MESSAGE IS WRITTEN IF IOUT IS NEGATIVE. +C ****************************************************************** +C MODIFIED FROM MODFLOW-96 by HARBAUGH and McDONALD. +C VERSION 1003 05AUG1992 URWORD +C + CHARACTER*(*) LINE + CHARACTER*20 RW,STRING +C +C1------Set last char in LINE to blank and set ISTART and ISTOP to point +C1------to this blank as a default situation when no word is found. If +C1------starting location in LINE is out of bounds, do not look for a +C1------word. + LINLEN=LEN(LINE) + LINE(LINLEN:LINLEN)=' ' + ISTART=LINLEN + ISTOP=LINLEN + LINLEN=LINLEN-1 + IF(ICOL.LT.1 .OR. ICOL.GT.LINLEN) GO TO 100 +C +C2------Find start of word, which is indicated by first character that +C2------is not a blank and not a comma. + DO 10 I=ICOL,LINLEN + IF(LINE(I:I).NE.' ' .AND. LINE(I:I).NE.',') GO TO 20 +10 CONTINUE + ICOL=LINLEN+1 + GO TO 100 +C +C3------Found start of word. Look for end. +C3A-----When word is quoted, only a quote can terminate it. +20 IF(LINE(I:I).EQ.'''') THEN + I=I+1 + IF(I.LE.LINLEN) THEN + DO 25 J=I,LINLEN + IF(LINE(J:J).EQ.'''') GO TO 40 +25 CONTINUE + END IF +C +C3B-----When word is not quoted, space or comma will terminate. + ELSE + DO 30 J=I,LINLEN + IF(LINE(J:J).EQ.' ' .OR. LINE(J:J).EQ.',') GO TO 40 +30 CONTINUE + END IF +C +C3C-----End of line without finding end of word; set end of word to +C3C-----end of line. + J=LINLEN+1 +C +C4------Found end of word; set J to point to last character in WORD and +C-------set ICOL to point to location for scanning for another word. +40 ICOL=J+1 + J=J-1 + IF(J.LT.I) GO TO 100 + ISTART=I + ISTOP=J +C +C5------Convert word to upper case and RETURN if NCODE is 1. + IF(NCODE.EQ.1) THEN + IDIFF=ICHAR('a')-ICHAR('A') + DO 50 K=ISTART,ISTOP + IF(LINE(K:K).GE.'a' .AND. LINE(K:K).LE.'z') + 1 LINE(K:K)=CHAR(ICHAR(LINE(K:K))-IDIFF) +50 CONTINUE + RETURN + END IF +C +C6------Convert word to a number if requested. +100 IF(NCODE.EQ.2 .OR. NCODE.EQ.3) THEN + RW=' ' + L=20-ISTOP+ISTART + IF(L.LT.1) GO TO 200 + RW(L:20)=LINE(ISTART:ISTOP) + IF(NCODE.EQ.2) READ(RW,'(I20)',ERR=200) N + IF(NCODE.EQ.3) READ(RW,'(F20.0)',ERR=200) R + END IF + RETURN +C +C7------Number conversion error. +200 IF(NCODE.EQ.3) THEN + STRING= 'A REAL NUMBER' + L=13 + ELSE + STRING= 'AN INTEGER' + L=10 + END IF +C +C7A-----If output unit is negative, set last character of string to 'E'. + IF(IOUT.LT.0) THEN + N=0 + R=0. + LINE(LINLEN+1:LINLEN+1)='E' + RETURN +C +C7B-----If output unit is positive; write a message to output unit. + ELSE IF(IOUT.GT.0) THEN + IF(IN.GT.0) THEN + WRITE(IOUT,201) IN,LINE(ISTART:ISTOP),STRING(1:L),LINE + ELSE + WRITE(IOUT,202) LINE(ISTART:ISTOP),STRING(1:L),LINE + END IF +201 FORMAT(1X,/1X,'FILE UNIT',I4,' : ERROR CONVERTING "',A, + 1 '" TO ',A,' IN LINE:',/1X,A) +202 FORMAT(1X,/1X,'KEYBOARD INPUT : ERROR CONVERTING "',A, + 1 '" TO ',A,' IN LINE:',/1X,A) +C +C7C-----If output unit is 0; write a message to default output. + ELSE + IF(IN.GT.0) THEN + WRITE(*,201) IN,LINE(ISTART:ISTOP),STRING(1:L),LINE + ELSE + WRITE(*,202) LINE(ISTART:ISTOP),STRING(1:L),LINE + END IF + END IF +C +C7D-----STOP after writing message. + CALL USTOP(' ') + END +C +C + SUBROUTINE USTOP(STOPMESS) +C ****************************************************************** +C STOP PROGRAM, WITH OPTION TO PRINT MESSAGE BEFORE STOPPING +C ****************************************************************** +C MODIFIED FROM MODFLOW-2000 by HARBAUGH et al. 2000 +C +C SPECIFICATIONS: +C ------------------------------------------------------------------ + CHARACTER STOPMESS*(*) +C ------------------------------------------------------------------ + 10 FORMAT(1X,A) +C + IF (STOPMESS.NE.' ') THEN + WRITE(*,10) STOPMESS + ENDIF + STOP +C + END \ No newline at end of file