!! Copyright (C) Stichting Deltares, 2005-2020.
!!
!! This file is part of iMOD.
!!
!! This program is free software: you can redistribute it and/or modify
!! it under the terms of the GNU General Public License as published by
!! the Free Software Foundation, either version 3 of the License, or
!! (at your option) any later version.
!!
!! This program is distributed in the hope that it will be useful,
!! but WITHOUT ANY WARRANTY; without even the implied warranty of
!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!! GNU General Public License for more details.
!!
!! You should have received a copy of the GNU General Public License
!! along with this program. If not, see .Q*
!!
!! Contact: imod.support@deltares.nl
!! Stichting Deltares
!! P.O. Box 177
!! 2600 MH Delft, The Netherlands.
!!
MODULE MOD_PMANAGER_MF2005
USE WINTERACTER
USE RESOURCE
USE MOD_PMANAGER_PAR
USE MOD_PMANAGER_UTL
USE IMODVAR
USE MOD_IDF
USE MOD_UTL
USE MOD_IDF_PAR
USE MOD_ISG_PAR
USE MOD_ISG_GRID
USE MOD_ISG_UTL
USE MOD_POLINT
USE MOD_QKSORT
USE MOD_ASC2IDF_HFB
USE MOD_ASC2IDF_PAR
USE MOD_ASC2IDF_UTL
USE MOD_OSD
USE MOD_IPEST_GLM, ONLY : IPEST_GLM_SETGROUPS
CONTAINS
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEPST(IU,IOPTION,DIR,ISS,IITER)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IU,IOPTION,ISS,IITER
CHARACTER(LEN=*),INTENT(IN) :: DIR
INTEGER :: I,N,M,SCL_UP,SCL_D,IOS,ICOL,IROW
REAL(KIND=DP_KIND) :: Z
PMANAGER_SAVEPST=.FALSE.
!## write model dimensions into pst file
IF(IOPTION.EQ.2)THEN
WRITE(IU,*) PRJIDF%NCOL,PRJIDF%NROW,PRJNLAY,PRJNPER,ISS
WRITE(IU,*) PRJIDF%XMIN,PRJIDF%YMIN,PRJIDF%XMAX,PRJIDF%YMAX,PRJIDF%IEQ
IF(PRJIDF%IEQ.EQ.0)THEN
WRITE(IU,*) PRJIDF%DX
ELSE
WRITE(IU,*) (PRJIDF%SX(ICOL),ICOL=0,PRJIDF%NCOL)
WRITE(IU,*) (PRJIDF%SY(IROW),IROW=0,PRJIDF%NROW)
ENDIF
ENDIF
IF(IOPTION.NE.1)THEN
IF(ASSOCIATED(PEST%MEASURES))THEN
I=SIZE(PEST%MEASURES)
IF(PEST%IIPF.EQ.1)I=-1*I
LINE=TRIM(ITOS(I))
WRITE(IU,'(A)') TRIM(LINE)
DO I=1,SIZE(PEST%MEASURES)
LINE=CHAR(39)//TRIM(PEST%MEASURES(I)%IPFNAME)//CHAR(39)//','// &
TRIM(ITOS(PEST%MEASURES(I)%IPFTYPE))//','// &
TRIM(ITOS(PEST%MEASURES(I)%IXCOL)) //','// &
TRIM(ITOS(PEST%MEASURES(I)%IYCOL)) //','// &
TRIM(ITOS(PEST%MEASURES(I)%ILCOL)) //','// &
TRIM(ITOS(PEST%MEASURES(I)%IMCOL)) //','// &
TRIM(ITOS(PEST%MEASURES(I)%IVCOL))
IF(PEST%MEASURES(I)%IDCOL.GT.0)LINE=TRIM(LINE)//','//TRIM(ITOS(PEST%MEASURES(I)%IDCOL))
WRITE(IU,'(A)') TRIM(LINE)
ENDDO
ELSE
LINE=TRIM(ITOS(0))
WRITE(IU,'(A)') TRIM(LINE)
ENDIF
ENDIF
IF(IOPTION.EQ.2)THEN
IF(PBMAN%IIES.EQ.0)THEN
LINE=TRIM(ITOS(SIZE(PEST%PARAM)))
ELSE
LINE='0'
ENDIF
WRITE(IU,'(A)') TRIM(LINE)
ENDIF
N=0; IF(ASSOCIATED(PEST%S_PERIOD)) N=SIZE(PEST%S_PERIOD)
M=0; IF(ASSOCIATED(PEST%B_FRACTION))M=SIZE(PEST%B_FRACTION)
I=PEST%PE_MXITER; IF(IITER.EQ.-1.AND.PBMAN%IPESTP.EQ.1)I=-1
LINE=TRIM(ITOS(I)) //','//TRIM(RTOS(PEST%PE_STOP,'G',7)) //','// &
TRIM(RTOS(PEST%PE_SENS,'G',7)) //','//TRIM(ITOS(N)) //','// &
TRIM(ITOS(M)) //','//TRIM(RTOS(PEST%PE_TARGET(1),'G',7))//','// &
TRIM(RTOS(PEST%PE_TARGET(2),'G',7))//','//TRIM(ITOS(PEST%PE_SCALING-1)) //','// &
TRIM(RTOS(PEST%PE_PADJ,'G',7)) //','//TRIM(RTOS(PEST%PE_DRES,'G',7)) //','// &
TRIM(ITOS(PEST%PE_KTYPE)) //','//TRIM(RTOS(PEST%PE_KRANGE,'G',7)) //','// &
TRIM(ITOS(PEST%PE_REGULARISATION))
WRITE(IU,'(A)') TRIM(LINE)
!## write blankout idf
IF(PEST%PE_KTYPE.LT.0)THEN
IF(IOPTION.EQ.1)THEN
WRITE(IU,'(A)') TRIM(PEST%PPBNDIDF)
ELSEIF(IOPTION.EQ.2)THEN
!## upscale is using number 7, most frequent
SCL_UP=7; SCL_D=0
!## read/clip/scale idf file
IF(.NOT.IDFREADSCALE(PEST%PPBNDIDF,PRJIDF,SCL_UP,SCL_D,1.0D0,0))RETURN
!## save array, do not correct for boundary condition as we not yet know for what layer the zone will apply
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\PST1\PPBNDIDF.ARR',PRJIDF,0,IU,1,0))RETURN
ENDIF
ENDIF
IF(N.GT.0)THEN
DO I=1,SIZE(PEST%S_PERIOD)
LINE=TRIM(PEST%S_PERIOD(I))//','//TRIM(PEST%E_PERIOD(I))
WRITE(IU,'(A)') TRIM(LINE)
ENDDO
ENDIF
IF(M.GT.0)THEN
DO I=1,SIZE(PEST%B_FRACTION)
LINE=TRIM(RTOS(PEST%B_FRACTION(I),'G',7))//','//CHAR(39)//TRIM(PEST%B_BATCHFILE(I))//CHAR(39)//','//CHAR(39)//TRIM(PEST%B_OUTFILE(I))//CHAR(39)
WRITE(IU,'(A)') TRIM(LINE)
ENDDO
ENDIF
IF(ASSOCIATED(PEST%PARAM))THEN
DO I=1,SIZE(PEST%PARAM)
LINE=TRIM(ITOS(PEST%PARAM(I)%PACT)) //','// &
TRIM(PEST%PARAM(I)%PPARAM) //','// &
TRIM(ITOS(PEST%PARAM(I)%PILS)) //','// &
TRIM(ITOS(PEST%PARAM(I)%PIZONE)) //','// &
TRIM(RTOS(PEST%PARAM(I)%PINI,'G',7)) //','// &
TRIM(RTOS(PEST%PARAM(I)%PDELTA,'G',7)) //','// &
TRIM(RTOS(PEST%PARAM(I)%PMIN,'G',7)) //','// &
TRIM(RTOS(PEST%PARAM(I)%PMAX,'G',7)) //','// &
TRIM(RTOS(PEST%PARAM(I)%PINCREASE,'G',7))//','// &
TRIM(ITOS(ABS(PEST%PARAM(I)%PIGROUP))) //','// &
TRIM(ITOS(PEST%PARAM(I)%PLOG)) //','// &
'"'//TRIM(PEST%PARAM(I)%ACRONYM) //'",'// &
TRIM(RTOS(PEST%PARAM(I)%PPRIOR,'G',7))
IF(PBMAN%IIES.EQ.0)WRITE(IU,'(A)') TRIM(LINE)
ENDDO
ENDIF
WRITE(6,'(A)') '+Reading/writing PST-files ...'
IF(ASSOCIATED(PEST%IDFFILES))THEN
LINE=TRIM(ITOS(SIZE(PEST%IDFFILES)))
WRITE(IU,'(A)') TRIM(LINE)
DO I=1,SIZE(PEST%IDFFILES)
WRITE(6,'(A)') '+Reading/writing PST-files ('//TRIM(RTOS(REAL(100*I,8)/REAL(SIZE(PEST%IDFFILES),8),'F',2))//'%)'
LINE=TRIM(PEST%IDFFILES(I))
IF(IOPTION.EQ.2)THEN
Z=INT(UTL_GETREAL(LINE,IOS))
IF(IOS.EQ.0)THEN
PRJIDF%X=Z
!## save array, do not correct for boundary condition as we not yet know for what layer the zone will apply
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\PST1\ZONE_IZ'//TRIM(ITOS(I))//'.ARR',PRJIDF,0,IU,1,0))RETURN
ELSE
!## read idf
IF(INDEX(UTL_CAP(LINE,'U'),'.IDF',.TRUE.).GT.0)THEN
!## upscale is using number 15 is not completely correct but for reasons of backward compatibility. Undesired results can be overcome through additional file
PRJIDF%FNAME=LINE; SCL_UP=15; SCL_D=0
!## read/clip/scale idf file
IF(.NOT.IDFREADSCALE(PRJIDF%FNAME,PRJIDF,SCL_UP,SCL_D,1.0D0,0))RETURN
!## replace nodata for zero
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
IF(PRJIDF%X(ICOL,IROW).EQ.PRJIDF%NODATA)PRJIDF%X(ICOL,IROW)=0.0D0
ENDDO; ENDDO
!## save array, do not correct for boundary condition as we not yet know for what layer the zone will apply
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\PST1\ZONE_IZ'//TRIM(ITOS(I))//'.ARR',PRJIDF,0,IU,1,0))RETURN
ELSE
WRITE(IU,'(A)') TRIM(LINE)
ENDIF
ENDIF
ELSE
WRITE(IU,'(A)') TRIM(LINE)
ENDIF
ENDDO
ELSE
WRITE(IU,'(A)') '0'
ENDIF
PMANAGER_SAVEPST=.TRUE.
END FUNCTION PMANAGER_SAVEPST
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVERUN(FNAME,IBATCH)
!###======================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: FNAME
INTEGER,INTENT(IN) :: IBATCH
CHARACTER(LEN=52) :: CDATE1,CDATE2
CHARACTER(LEN=256) :: BNDFNAME
INTEGER(KIND=8) :: ITIME,JTIME
INTEGER :: IU,I,J,K,IPER,KPER,N,NSCL
LOGICAL :: LDAYS,LEX
TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: IDF
CHARACTER(LEN=256) :: LINE
PMANAGER_SAVERUN=.FALSE.
!## get active packages, set default values
IF(.NOT.PMANAGER_GETPACKAGES(1,IBATCH))RETURN
!## overrule ipst if not as keyword given
IF(IBATCH.EQ.1.AND.PBMAN%IPEST.EQ.0)TOPICS(TPST)%IACT_MODEL=0
IF(IBATCH.EQ.1.AND.PBMAN%IIES.EQ.0) TOPICS(TIES)%IACT_MODEL=0
DO I=1,MAXTOPICS
SELECT CASE (I)
CASE (TFHB,TUZF,TMNW,TSFR,TLAK)
IF(TOPICS(I)%IACT_MODEL.EQ.1)THEN
CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'You cannot use the package '//TRIM(TOPICS(I)%TNAME)//CHAR(13)// &
'to save for a RUN-file. Select the option MODFLOW2005 instead','Information')
RETURN
ENDIF
END SELECT
ENDDO
!## remove last timestep sinces it is the final date
IF(PRJNPER.GT.1)PRJNPER=PRJNPER-1
PRJNLAY=PRJMXNLAY
!## check on RUN file
CALL UTL_CREATEDIR(FNAME(1:INDEX(FNAME,'\',.TRUE.)-1))
IF(IBATCH.EQ.0)THEN
INQUIRE(FILE=FNAME,EXIST=LEX)
IF(LEX)THEN
CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Are you sure to overwrite'//CHAR(13)//TRIM(FNAME),'Question')
IF(WINFODIALOG(4).NE.1)RETURN
ENDIF
ENDIF
IU=UTL_GETUNIT()
CALL OSD_OPEN(IU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE,DENYREAD',FORM='FORMATTED')
IF(IU.EQ.0)RETURN
!## write Data set 1
IF(IBATCH.EQ.1)THEN
IF(TRIM(PBMAN%OUTPUT).EQ.'')THEN
WRITE(IU,'(A)') CHAR(39)//FNAME(1:INDEX(FNAME,'\',.TRUE.)-1)//CHAR(39)
ELSE
WRITE(IU,'(A)') CHAR(39)//TRIM(PBMAN%OUTPUT)//CHAR(39)
ENDIF
ELSE
WRITE(IU,'(A)') CHAR(39)//TRIM(PBMAN%OUTPUT)//CHAR(39)
ENDIF
N=0; IF(ASSOCIATED(PEST%MEASURES))THEN
N=SIZE(PEST%MEASURES); IF(PEST%IIPF.EQ.1)N=-1*N
ENDIF
!## metaswap
IARMWP=0
IF(TOPICS(TCAP)%IACT_MODEL.EQ.1)THEN
IF(ASSOCIATED(TOPICS(TCAP)%STRESS))THEN
LINE=TOPICS(TCAP)%STRESS(1)%FILES(8,1)%FNAME
IF(INDEX(UTL_CAP(LINE,'U'),'IPF').GT.0)IARMWP=1
ENDIF
ENDIF
NSCL=1
IF(PBMAN%IWINDOW.EQ.3)NSCL=0
IF(PBMAN%IWINDOW.EQ.2)THEN
IF(SUBMODEL(7).GT.0.0D0)NSCL=2
ENDIF
WRITE(IU,'(12(I10,1X))') PRJNLAY,PRJMXNLAY,PRJNPER,PBMAN%ISAVEENDDATE,NSCL,0,PBMAN%ICONCHK,N,0,PBMAN%IFVDL,IARMWP
!## write measures
IF(N.NE.0)THEN
DO I=1,SIZE(PEST%MEASURES)
LINE=TRIM(PEST%MEASURES(I)%IPFNAME) //','// &
TRIM(ITOS(PEST%MEASURES(I)%IPFTYPE))//','// &
TRIM(ITOS(PEST%MEASURES(I)%IXCOL)) //','// &
TRIM(ITOS(PEST%MEASURES(I)%IYCOL)) //','// &
TRIM(ITOS(PEST%MEASURES(I)%ILCOL)) //','// &
TRIM(ITOS(PEST%MEASURES(I)%IMCOL)) //','// &
TRIM(ITOS(PEST%MEASURES(I)%IVCOL))
WRITE(IU,'(A)') TRIM(LINE)
ENDDO
ENDIF
!## Data set 4
IF(PBMAN%IWINDOW.EQ.3)THEN
LINE='0'
ELSE
LINE='1'
ENDIF
LINE=TRIM(LINE)//',0,'//TRIM(ITOS(PBMAN%IDOUBLE))//',0,0,'//TRIM(ITOS(PBMAN%SSYSTEM))
IF(PBMAN%MINKD.NE.0.0D0.OR.PBMAN%MINC.NE.0.0D0)THEN
LINE=TRIM(LINE)//','//TRIM(RTOS(PBMAN%MINKD,'G',5))//','//TRIM(RTOS(PBMAN%MINC ,'G',5))
ENDIF
WRITE(IU,'(A)') TRIM(LINE)
!## Data set 5
IF(PCG%PARTOPT.GT.1)PCG%NOUTER=-ABS(PCG%NOUTER)
LINE=TRIM(ITOS(PCG%NOUTER))//','//TRIM(ITOS(PCG%NINNER))//','// &
TRIM(RTOS(PCG%HCLOSE,'E',7))//','//TRIM(RTOS(PCG%RCLOSE,'E',7))//','// &
TRIM(RTOS(PCG%RELAX,'E',7))
IF(PCG%PARTOPT.GT.1)THEN
!## PKS options
LINE=TRIM(LINE)//','//TRIM(ITOS(PCG%PARTOPT-2))//','//TRIM(ITOS(PCG%IMERGE))
ELSE
!## PCG option
LINE=TRIM(LINE)//','//TRIM(ITOS(PCG%NPCOND))
ENDIF
WRITE(IU,'(A)') TRIM(LINE)
IF(PCG%PARTOPT.EQ.3.AND.TRIM(PCG%MRGFNAME).EQ.'')THEN
CLOSE(IU); CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You need to specify a pointer IDF-file when selecting the RCB partition method.','Error')
RETURN
ENDIF
IF(PCG%PARTOPT.EQ.3)THEN
WRITE(IU,'(A)') '"'//TRIM(PCG%MRGFNAME)//'"'
ENDIF
!## Data set 6; non-equistantial network
IF(PBMAN%IWINDOW.EQ.3)THEN
BNDFNAME=PBMAN%BNDFILE
ELSE
ALLOCATE(IDF(1)); CALL IDFNULLIFY(IDF(1))
IF(.NOT.PMANAGER_INIT_SIMAREA(IDF(1),IBATCH))RETURN
BNDFNAME=IDF(1)%FNAME
IF(ISUBMODEL.EQ.0)THEN
WRITE(IU,'(6(F15.3,A1))') IDF(1)%XMIN,',',IDF(1)%YMIN,',',IDF(1)%XMAX,',',IDF(1)%YMAX,',',IDF(1)%DX,',',0.0D0
ELSE
IF(SUBMODEL(6).GT.0.0D0.AND.SUBMODEL(7).GT.0.0D0)THEN
WRITE(IU,'(7(F15.3,A1))') SUBMODEL(1),',',SUBMODEL(2),',',SUBMODEL(3),',',SUBMODEL(4),',',SUBMODEL(5),',',SUBMODEL(7),',',SUBMODEL(6)
ELSE
WRITE(IU,'(6(F15.3,A1))') SUBMODEL(1),',',SUBMODEL(2),',',SUBMODEL(3),',',SUBMODEL(4),',',SUBMODEL(5),',',SUBMODEL(6)
ENDIF
ENDIF
CALL IDFDEALLOCATE(IDF,SIZE(IDF)); DEALLOCATE(IDF)
ENDIF
WRITE(IU,'(A)') 'ACTIVE MODULES'
!## Data set 8
DO I=1,MAXTOPICS
IF(TOPICS(I)%IACT_MODEL.EQ.0)CYCLE
!## skip pcg
IF(I.EQ.TPCG)CYCLE
!## pst module is exception
IF(I.EQ.TPST)THEN; WRITE(IU,'(A)') '1,0 '//TRIM(TOPICS(I)%TNAME); CYCLE; ENDIF
! IF(I.EQ.TIES)THEN; WRITE(IU,'(A)') '1,0 '//TRIM(TOPICS(I)%TNAME); CYCLE; ENDIF
IF(.NOT.ASSOCIATED(TOPICS(I)%STRESS))CYCLE
IF(.NOT.ASSOCIATED(TOPICS(I)%STRESS(1)%FILES))CYCLE
CALL PMANAGER_SAVEMF2005_RUN_ISAVE(PBMAN%ISAVE(I)%ILAY,TOPICS(I)%TNAME(1:5),IU)
ENDDO
!## write bndfile, Data set 9
WRITE(IU,'(A)') CHAR(39)//TRIM(BNDFNAME)//CHAR(39)
WRITE(IU,'(A)') 'MODULES FOR EACH LAYER'
!## write modules not timedependent
DO I=1,MAXTOPICS
IF(TOPICS(I)%IACT_MODEL.EQ.0)CYCLE !## only active
IF(TOPICS(I)%TIMDEP)CYCLE !## only time independent
!## skip pcg
IF(I.EQ.TPCG)CYCLE
!## pst module is exception
IF(I.EQ.TPST)THEN
LINE=TRIM(ITOS(SIZE(PEST%PARAM)))//',(PST)'; WRITE(IU,'(A)') TRIM(LINE)
IF(.NOT.PMANAGER_SAVEPST(IU,1,'',0,0))THEN; ENDIF; CYCLE
ENDIF
! IF(I.EQ.TIES)THEN
! LINE=TRIM(ITOS(SIZE(PEST%PARAM)))//',(IES)'; WRITE(IU,'(A)') TRIM(LINE)
! IF(.NOT.PMANAGER_SAVEPST(IU,1,'',0,0))THEN; ENDIF; CYCLE
! ENDIF
IF(.NOT.ASSOCIATED(TOPICS(I)%STRESS))CYCLE
IF(.NOT.ASSOCIATED(TOPICS(I)%STRESS(1)%FILES))CYCLE
!## check the number of active packages
IF(I.EQ.TCAP)THEN
N=SIZE(TOPICS(I)%STRESS(1)%FILES,1)
IF(ASSOCIATED(TOPICS(I)%STRESS(1)%INPFILES))THEN
N=N+SIZE(TOPICS(I)%STRESS(1)%INPFILES)
ENDIF
ELSE
K=1; N=0
DO J=1,SIZE(TOPICS(I)%STRESS(1)%FILES,2)
IF(TOPICS(I)%STRESS(1)%FILES(K,J)%IACT.EQ.1)N=N+1
ENDDO
ENDIF
WRITE(IU,'(I3.3,A)') N,','//TRIM(TOPICS(I)%TNAME)
IF(N.GT.0)THEN
!## number of subtopics
DO K=1,SIZE(TOPICS(I)%STRESS(1)%FILES,1)
!## number of systems
DO J=1,SIZE(TOPICS(I)%STRESS(1)%FILES,2)
!## skip temporary deactivated packages
IF(TOPICS(I)%STRESS(1)%FILES(K,J)%IACT.EQ.0)CYCLE
!## msp/pwt - skip ilay
IF(I.EQ.TCAP.OR.I.EQ.TPWT)THEN
WRITE(LINE,'(5X, 2(G15.7,A1))') &
TOPICS(I)%STRESS(1)%FILES(K,J)%FCT ,',', &
TOPICS(I)%STRESS(1)%FILES(K,J)%IMP ,','
ELSE
WRITE(LINE,'(1X,I5,2(A1,G15.7),A1)') &
TOPICS(I)%STRESS(1)%FILES(K,J)%ILAY,',', &
TOPICS(I)%STRESS(1)%FILES(K,J)%FCT ,',', &
TOPICS(I)%STRESS(1)%FILES(K,J)%IMP ,','
ENDIF
IF(TOPICS(I)%STRESS(1)%FILES(K,J)%ICNST.EQ.1)THEN
LINE=TRIM(LINE)//TRIM(RTOS(TOPICS(I)%STRESS(1)%FILES(K,J)%CNST,'G',7))
ELSEIF(TOPICS(I)%STRESS(1)%FILES(K,J)%ICNST.EQ.2)THEN
LINE=TRIM(LINE)//CHAR(39)//TRIM(TOPICS(I)%STRESS(1)%FILES(K,J)%FNAME)//CHAR(39)
ENDIF
WRITE(IU,'(A)') TRIM(LINE)
ENDDO
ENDDO
!## write extra files only for MetaSWAP
IF(I.EQ.TCAP)THEN
IF(ASSOCIATED(TOPICS(I)%STRESS(1)%INPFILES))THEN
K=SIZE(TOPICS(I)%STRESS(1)%INPFILES)
DO J=1,K; WRITE(IU,'(1X,A)') TRIM(TOPICS(I)%STRESS(1)%INPFILES(J)); ENDDO
ENDIF
ENDIF
ENDIF
ENDDO
WRITE(IU,'(A)') 'PACKAGES FOR EACH LAYER AND STRESS-PERIOD '
!## only days available
LDAYS=.TRUE.
DO KPER=1,PRJNPER
IF(SIM(KPER)%IHR+SIM(KPER)%IMT+SIM(KPER)%ISC.GT.0)THEN; LDAYS=.FALSE.; EXIT; ENDIF
ENDDO
!## write packages - incl./excl. steady-state
DO KPER=1,PRJNPER
!## steady-state
IF(SIM(KPER)%DELT.EQ.0.0D0)THEN
WRITE(IU,'(I5.5,A1,F15.7,A1,A,2(A1,I1))') KPER,',',SIM(KPER)%DELT,',',TRIM(SIM(KPER)%CDATE),',',SIM(KPER)%ISAVE,',',SIM(KPER)%ISUM
!## transient (use final date as well, used for labeling file-names!)
ELSE
IF(LDAYS)THEN
WRITE(CDATE1,'(I4.4,2I2.2)') SIM(KPER)%IYR ,SIM(KPER)%IMH ,SIM(KPER)%IDY
ELSE
WRITE(CDATE1,'(I4.4,5I2.2)') SIM(KPER)%IYR ,SIM(KPER)%IMH ,SIM(KPER)%IDY ,SIM(KPER)%IHR ,SIM(KPER)%IMT ,SIM(KPER)%ISC
ENDIF
IF(LDAYS)THEN
WRITE(CDATE2,'(I4.4,2I2.2)') SIM(KPER+1)%IYR,SIM(KPER+1)%IMH,SIM(KPER+1)%IDY
ELSE
WRITE(CDATE2,'(I4.4,5I2.2)') SIM(KPER+1)%IYR,SIM(KPER+1)%IMH,SIM(KPER+1)%IDY,SIM(KPER+1)%IHR,SIM(KPER+1)%IMT,SIM(KPER+1)%ISC
ENDIF
WRITE(IU,'(I5.5,A1,F15.7,A1,A,2(A1,I1),A)') KPER,',',SIM(KPER)%DELT,',',TRIM(CDATE1),',',SIM(KPER)%ISAVE,',',SIM(KPER)%ISUM,','//TRIM(CDATE2)
ENDIF
DO I=1,MAXTOPICS
IF(TOPICS(I)%IACT_MODEL.EQ.0)CYCLE
IF(.NOT.TOPICS(I)%TIMDEP)CYCLE
IF(.NOT.ASSOCIATED(TOPICS(I)%STRESS))CYCLE
IF(.NOT.ASSOCIATED(TOPICS(I)%STRESS(1)%FILES))CYCLE
IPER=PMANAGER_GETCURRENTIPER(KPER,I,ITIME,JTIME)
!## overrule wel/isg packages per stress-period
SELECT CASE (I)
CASE (TWEL); IF(PBMAN%DWEL.EQ.1)IPER=ABS(IPER)
CASE (TISG); IF(PBMAN%DISG.EQ.1)IPER=ABS(IPER)
CASE (TSFR); IF(PBMAN%DSFR.EQ.1)IPER=ABS(IPER)
END SELECT
!## reuse previous timestep
IF(IPER.LE.0)THEN
N=MAX(IPER,-1)
WRITE(IU,'(I3,A)') N,','//TRIM(TOPICS(I)%TNAME)
ELSE
!## check the number of active packages
K=1; N=0
DO J=1,SIZE(TOPICS(I)%STRESS(IPER)%FILES,2)
IF(TOPICS(I)%STRESS(IPER)%FILES(K,J)%IACT.EQ.1)N=N+1
ENDDO
WRITE(IU,'(I3,A)') N,','//TRIM(TOPICS(I)%TNAME)
IF(N.GT.0)THEN
!## number of subtopics
DO K=1,SIZE(TOPICS(I)%STRESS(IPER)%FILES,1)
!## number of systems
DO J=1,SIZE(TOPICS(I)%STRESS(IPER)%FILES,2)
!## skip temporary deactivated packages
IF(TOPICS(I)%STRESS(IPER)%FILES(K,J)%IACT.EQ.0)CYCLE
IF(TOPICS(I)%STRESS(IPER)%FILES(K,J)%ICNST.EQ.1)THEN
WRITE(IU,'(1X,I5,3(A1,G15.7))') &
TOPICS(I)%STRESS(IPER)%FILES(K,J)%ILAY,',', &
TOPICS(I)%STRESS(IPER)%FILES(K,J)%FCT ,',', &
TOPICS(I)%STRESS(IPER)%FILES(K,J)%IMP ,',', &
TOPICS(I)%STRESS(IPER)%FILES(K,J)%CNST
ELSEIF(TOPICS(I)%STRESS(IPER)%FILES(K,J)%ICNST.EQ.2)THEN
WRITE(IU,'(1X,I5,2(A1,G15.7),A1,A)') &
TOPICS(I)%STRESS(IPER)%FILES(K,J)%ILAY,',', &
TOPICS(I)%STRESS(IPER)%FILES(K,J)%FCT ,',', &
TOPICS(I)%STRESS(IPER)%FILES(K,J)%IMP ,',', &
CHAR(39)//TRIM(TOPICS(I)%STRESS(IPER)%FILES(K,J)%FNAME)//CHAR(39)
ENDIF
ENDDO
ENDDO
ENDIF
ENDIF
ENDDO
ENDDO
CLOSE(IU)
!## copy RUN file to RUNFILES folder
CALL IOSCOPYFILE(TRIM(PBMAN%RUNFILE),TRIM(PREFVAL(1))//'\RUNFILES\'//TRIM(PBMAN%MODELNAME)//'.RUN')
PMANAGER_SAVERUN=.TRUE.
END FUNCTION PMANAGER_SAVERUN
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005(FNAME,IBATCH)
!###======================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: FNAME
INTEGER,INTENT(IN) :: IBATCH
CHARACTER(LEN=512) :: DIRMNAME,DIR,MAINDIR
INTEGER(KIND=8) :: ITIME,JTIME
INTEGER,ALLOCATABLE,DIMENSION(:,:) :: NEX
INTEGER,ALLOCATABLE,DIMENSION(:) :: SUBNLAY
INTEGER :: IULAK,ISTEADY,IPER,INIPER,LPER,KPER,IINI,IPRT,I,J,N
LOGICAL :: LTB
PMANAGER_SAVEMF2005=.FALSE.; LYESNO=.FALSE.
!## remove final stress as it is the final timestep
IF(PRJNPER.GT.1)PRJNPER=PRJNPER-1
ISTEADY=0; IF(SIM(1)%DELT.EQ.0.0D0)ISTEADY=1
!## time information
ISS=0; DO KPER=1,PRJNPER; IF(SIM(KPER)%DELT.NE.0.0D0)ISS=1; ENDDO
!## overwrite nstep/nmult in case imodbatch is used
IF(IBATCH.EQ.1)THEN
DO KPER=1,PRJNPER; SIM(KPER)%TMULT=PBMAN%NMULT; SIM(KPER)%NSTP=PBMAN%NSTEP; ENDDO
ENDIF
!## output unit numbers
IHEDUN =51; IBCFCB =52; IRCHCB =53; IEVTCB =54; IDRNCB =55
IRIVCB =56; IGHBCB =57; ICHDCB =58; IWELCB =59
ISFRCB =60 !## output unit numbers for sfr package
ISFRCB2=61 !## detailed output for sfr package
IFHBCB =62 !## output fhb package
ILAKCB =63 !## output lak package
IUZFCB1=64 !## output uzg package
IWL2CB =65 !## output mnw package
!## get active packages
IF(.NOT.PMANAGER_GETPACKAGES(1,IBATCH))RETURN
!## overrule ipst if not as keyword given
IF(IBATCH.EQ.1.AND.(PBMAN%IPEST+PBMAN%IPESTP).EQ.0)TOPICS(TPST)%IACT_MODEL=0
IF(IBATCH.EQ.1.AND.PBMAN%IIES.EQ.0)TOPICS(TPST)%IACT_MODEL=0
!## write nam file
IF(.NOT.PMANAGER_SAVEMF2005_NAM(FNAME,MAINDIR,DIR,DIRMNAME,IPRT,ISS))RETURN
!## get area of simulation / allocate arrays
IF(.NOT.PMANAGER_SAVEMF2005_SIM(IBATCH))RETURN
!## allocate memory
IF(.NOT.PMANAGER_SAVEMF2005_SIM_ALLOC(ISS))RETURN
!## write meta-data file
IF(.NOT.PMANAGER_SAVEMF2005_MET(DIR,DIRMNAME))RETURN
!## write time-discretisation file
IF(.NOT.PMANAGER_SAVEMF2005_TDIS(TRIM(MAINDIR)//'\MFSIM'))RETURN
!##================
!## reading section
!##================
!## read bnd/shd files
IF(.NOT.PMANAGER_SAVEMF2005_BAS_READ(IPRT))RETURN
!## read top/bot information
IF(.NOT.PMANAGER_SAVEMF2005_DIS_READ(LTB,IPRT))RETURN
!## read bcf
IF(.NOT.PMANAGER_SAVEMF2005_BCF_READ(ISS,IPRT))RETURN
!## read lpf
IF(.NOT.PMANAGER_SAVEMF2005_LPF_READ(ISS,IPRT))RETURN
!## read lpf
IF(.NOT.PMANAGER_SAVEMF2005_CON_READ(IPRT))RETURN
!## compute kdw/vcw
CALL PMANAGER_SAVEMF2005_COMPUTE_KDW_VCW()
!## read ani
IF(.NOT.PMANAGER_SAVEMF2005_ANI_READ(IPRT))RETURN
!## read top/bot information
IF(.NOT.PMANAGER_SAVEMF2005_LAK_READ(0,IPRT,INIPER))RETURN
!## read top/kh information
IF(.NOT.PMANAGER_SAVEMF2005_SFT_READ(IPRT))RETURN
!##================
!## checking section
!##================
!## apply consistency checks
CALL PMANAGER_SAVEMF2005_CONSISTENCY(LTB)
!## recompute kdw/vcw
CALL PMANAGER_SAVEMF2005_COMPUTE_KDW_VCW()
!## get lak position and conductances
IF(.NOT.PMANAGER_SAVEMF2005_LAK_CONFIG())RETURN
!##================
!## writing section
!##================
!## write pst-file
IF(.NOT.PMANAGER_SAVEMF2005_PST_READWRITE(DIR,DIRMNAME,IBATCH,ISS))RETURN
!## write metaswap
IF(.NOT.PMANAGER_SAVEMF2005_MSP(DIR,DIRMNAME,IBATCH,IPRT))RETURN
!## save bas file
IF(.NOT.PMANAGER_SAVEMF2005_BAS_SAVE(DIR,DIRMNAME,IBATCH))RETURN
!## save ic file
IF(.NOT.PMANAGER_SAVEMF2005_IC_SAVE(DIR,DIRMNAME,IBATCH))RETURN
!## save dis file
IF(.NOT.PMANAGER_SAVEMF2005_DIS_SAVE(DIR,DIRMNAME,IBATCH))RETURN
!## save bcf file
IF(.NOT.PMANAGER_SAVEMF2005_BCF_SAVE(DIR,DIRMNAME,IBATCH,ISS))RETURN
!## save lpf file
IF(.NOT.PMANAGER_SAVEMF2005_LPF_SAVE(DIR,DIRMNAME,IBATCH,ISS))RETURN
!## save vdf file
IF(.NOT.PMANAGER_SAVEMF2005_CON_SAVE(DIR,DIRMNAME,IBATCH))RETURN
!## save npf file
IF(.NOT.PMANAGER_SAVEMF2005_NPF_SAVE(DIR,DIRMNAME,IBATCH))RETURN
!## save sto file
IF(.NOT.PMANAGER_SAVEMF2005_STO_SAVE(DIR,DIRMNAME,IBATCH,ISS))RETURN
!## save ani file
IF(.NOT.PMANAGER_SAVEMF2005_ANI_SAVE(DIR,DIRMNAME,IBATCH))RETURN
!## save hfb file
IF(.NOT.PMANAGER_SAVEMF2005_HFB(IBATCH,DIRMNAME,IPRT,LTB))RETURN
!## save pcg file
IF(.NOT.PMANAGER_SAVEMF2005_IMS(TRIM(MAINDIR)//'\MFSIM'))RETURN
!## save pcg file
IF(.NOT.PMANAGER_SAVEMF2005_PCG(DIRMNAME))RETURN
!## save pks file
IF(.NOT.PMANAGER_SAVEMF2005_PKS(DIRMNAME))RETURN
!## save oc file
IF(.NOT.PMANAGER_SAVEMF2005_OCD(DIRMNAME,MAINDIR))RETURN
!## save uzf package
IF(.NOT.PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,TOPICS(TUZF)%IACT_MODEL,TUZF,IUZFCB1,'UZF',(/1,2,3,4,5,6,7,8/),IPRT))RETURN
!## save mnw package
IF(.NOT.PMANAGER_SAVEMF2005_MNW(DIRMNAME,IBATCH,TOPICS(TMNW)%IACT_MODEL,TMNW,IWL2CB,'MNW',IPRT))RETURN
!## save wel package
IF(.NOT.PMANAGER_SAVEMF2005_WEL(DIR,DIRMNAME,IBATCH,TOPICS(TWEL)%IACT_MODEL,TWEL,IWELCB,'WEL',IPRT))RETURN
!## save drn package
IF(.NOT.PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,TOPICS(TDRN)%IACT_MODEL,TDRN,IDRNCB,'DRN',(/2,1/),IPRT))RETURN
!## save isg package (always before riv in case of dmm-files)
IF(.NOT.TOPICS(TRIV)%DEFINED)THEN
IF(.NOT.PMANAGER_SAVEMF2005_ISG(DIR,DIRMNAME,IBATCH,TOPICS(TISG)%IACT_MODEL,TISG,IRIVCB,'RIV',IPRT))RETURN
ELSE
IF(.NOT.PMANAGER_SAVEMF2005_ISG(DIR,DIRMNAME,IBATCH,TOPICS(TISG)%IACT_MODEL,TISG,IRIVCB,'ISG',IPRT))RETURN
ENDIF
!## save riv package
IF(TOPICS(TCON)%IACT_MODEL.EQ.1)THEN
IF(.NOT.PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,TOPICS(TRIV)%IACT_MODEL,TRIV,IRIVCB,'RIV',(/2,1,3,4,5/),IPRT))RETURN
ELSE
IF(.NOT.PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,TOPICS(TRIV)%IACT_MODEL,TRIV,IRIVCB,'RIV',(/2,1,3,4/),IPRT))RETURN
ENDIF
!## save evt package
IF(.NOT.PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,TOPICS(TEVT)%IACT_MODEL,TEVT,IEVTCB,'EVT',(/2,1,3/),IPRT))RETURN
!## save ghb package
IF(TOPICS(TCON)%IACT_MODEL.EQ.1)THEN
IF(.NOT.PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,TOPICS(TGHB)%IACT_MODEL,TGHB,IGHBCB,'GHB',(/2,1,3/),IPRT))RETURN
ELSE
IF(.NOT.PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,TOPICS(TGHB)%IACT_MODEL,TGHB,IGHBCB,'GHB',(/2,1/),IPRT))RETURN
ENDIF
!## save rch package
IF(.NOT.PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,TOPICS(TRCH)%IACT_MODEL,TRCH,IRCHCB,'RCH',(/1/),IPRT))RETURN
!## save olf package
IF(.NOT.TOPICS(TDRN)%DEFINED)THEN
IF(.NOT.PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,TOPICS(TOLF)%IACT_MODEL,TOLF,IDRNCB,'DRN',(/1/),IPRT))RETURN
ELSE
IF(.NOT.PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,TOPICS(TOLF)%IACT_MODEL,TOLF,IDRNCB,'OLF',(/1/),IPRT))RETURN
ENDIF
!## save chd package
IF(TOPICS(TCON)%IACT_MODEL.EQ.1)THEN
IF(.NOT.PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,TOPICS(TCHD)%IACT_MODEL,TCHD,ICHDCB,'CHD',(/1,2/),IPRT))RETURN
ELSE
IF(.NOT.PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,TOPICS(TCHD)%IACT_MODEL,TCHD,ICHDCB,'CHD',(/1/),IPRT))RETURN
ENDIF
!## save sfr package
IF(.NOT.PMANAGER_SAVEMF2005_ISG(DIR,DIRMNAME,IBATCH,TOPICS(TSFR)%IACT_MODEL,TSFR,ISFRCB,'SFR',IPRT))RETURN
!## save fhb package
IF(.NOT.PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,TOPICS(TFHB)%IACT_MODEL,TFHB,IFHBCB,'FHB',(/1,2/),IPRT))RETURN
IF(TOPICS(TLAK)%DEFINED)THEN
!## save rest of lak package
LPER=0; DO IPER=1,PRJNPER
!## get appropriate stress-period to store in runfile
KPER=PMANAGER_GETCURRENTIPER(IPER,TLAK,ITIME,JTIME)
!## kper is stress period for which lakes are firstly defined
IINI=0; IF(KPER.EQ.INIPER)IINI=1
!## read in new values in case not previous one can be used
IF(ABS(KPER).NE.LPER)THEN
KPER=ABS(KPER)
IF(.NOT.PMANAGER_SAVEMF2005_LAK_READ(IPER,IPRT,KPER))RETURN
ENDIF
IF(.NOT.PMANAGER_SAVEMF2005_LAK_SAVE(IULAK,IINI,IBATCH,DIR,KPER=IPER,DIRMNAME=DIRMNAME))RETURN
!## store previous stress-period information for this timestep
LPER=ABS(KPER)
ENDDO
CLOSE(IULAK)
ENDIF
!## combine olf/drn and isg/riv
IF(TOPICS(TOLF)%DEFINED.AND.TOPICS(TDRN)%DEFINED)THEN
IF(PBMAN%ICONCHK.EQ.0)THEN
IF(.NOT.PMANAGER_SAVEMF2005_COMBINE(DIR,DIRMNAME,(/'OLF','DRN','DRN_'/),IDRNCB,'AUX ISUB DSUBSYS ISUB NOPRINT'))RETURN
ELSE
IF(.NOT.PMANAGER_SAVEMF2005_COMBINE(DIR,DIRMNAME,(/'OLF','DRN','DRN_'/),IDRNCB,'AUX ISUB DSUBSYS ISUB ICONCHK IC NOPRINT'))RETURN
ENDIF
ENDIF
IF(TOPICS(TISG)%DEFINED.AND.TOPICS(TRIV)%DEFINED)THEN
IF(.NOT.PMANAGER_SAVEMF2005_COMBINE(DIR,DIRMNAME,(/'ISG','RIV','RIV_'/),IRIVCB,'AUX RFCT AUX ISUB RFACT RFCT RSUBSYS ISUB NOPRINT'))RETURN
ENDIF
!## create connections
IF(PBMAN%IFORMAT.EQ.3.AND.PBMAN%ISUBMODEL.EQ.PBMAN%NSUBMODEL)THEN
DO; I=LEN_TRIM(MAINDIR); IF(MAINDIR(I:I).NE.'\')EXIT; MAINDIR(I:I)=' '; ENDDO
ALLOCATE(NEX(PBMAN%NSUBMODEL,PBMAN%NSUBMODEL)); NEX=0
!## associated via imodbatch or submodel with variable layering
IF(.NOT.ASSOCIATED(PBMAN%SM))THEN
ALLOCATE(PBMAN%SM(PBMAN%NSUBMODEL))
DO I=1,PBMAN%NSUBMODEL
ALLOCATE(PBMAN%SM(I)%ILAY(PRJNLAY)); DO J=1,PRJNLAY; PBMAN%SM(I)%ILAY(J)=J; ENDDO
ENDDO
ENDIF
DO I=1,PBMAN%NSUBMODEL; ALLOCATE(PBMAN%SM(I)%CON(3)); ENDDO; ALLOCATE(SUBNLAY(PBMAN%NSUBMODEL)); SUBNLAY=0
DO I=1,PBMAN%NSUBMODEL; DO J=1,PBMAN%NSUBMODEL
IF(I.EQ.J)CYCLE; N=NEX(J,I)
CALL PMANAGER_SAVEMF6_EXG(MAINDIR,DIRMNAME,I,J,N,SUBNLAY(I)); NEX(I,J)=N
ENDDO; ENDDO
DEALLOCATE(NEX)
!## exchange connections might be changed due to the HFB package
IF(TOPICS(THFB)%DEFINED)THEN
DO I=1,PBMAN%NSUBMODEL
CALL PMANAGER_SAVEMF6_EXG_MODIFYHFB(MAINDIR,DIRMNAME,I,SUBNLAY)
ENDDO
ENDIF
DEALLOCATE(SUBNLAY)
DO I=1,PBMAN%NSUBMODEL
IF(ASSOCIATED(PBMAN%SM(I)%CON(1)%X))THEN
PBMAN%SM(I)%CON(1)%FNAME=TRIM(MAINDIR)//'\GWF_'//TRIM(ITOS(I))//'\CON_TOP.IDF'
IF(.NOT.IDFWRITE(PBMAN%SM(I)%CON(1),PBMAN%SM(I)%CON(1)%FNAME,1))THEN; ENDIF
CALL IDFDEALLOCATEX(PBMAN%SM(I)%CON(1))
ENDIF
IF(ASSOCIATED(PBMAN%SM(I)%CON(2)%X))THEN
PBMAN%SM(I)%CON(2)%FNAME=TRIM(MAINDIR)//'\GWF_'//TRIM(ITOS(I))//'\CON_BOT.IDF'
IF(.NOT.IDFWRITE(PBMAN%SM(I)%CON(2),PBMAN%SM(I)%CON(2)%FNAME,1))THEN; ENDIF
CALL IDFDEALLOCATEX(PBMAN%SM(I)%CON(2))
ENDIF
IF(ASSOCIATED(PBMAN%SM(I)%CON(3)%X))THEN
PBMAN%SM(I)%CON(3)%FNAME=TRIM(MAINDIR)//'\GWF_'//TRIM(ITOS(I))//'\CON_LAT.IDF'
IF(.NOT.IDFWRITE(PBMAN%SM(I)%CON(3),PBMAN%SM(I)%CON(3)%FNAME,1))THEN; ENDIF
CALL IDFDEALLOCATEX(PBMAN%SM(I)%CON(3))
ENDIF
DEALLOCATE(PBMAN%SM(I)%CON)
ENDDO
!## remove from nam if no packages exists anymore
DO I=1,PBMAN%NSUBMODEL
CALL PMANAGER_SAVEMF6_CLEANNAM(MAINDIR,DIRMNAME,I)
ENDDO
ENDIF
!## modify files if needed for ies
IF(.NOT.PMANAGER_SAVEMF2005_IES_READWRITE(DIRMNAME,IBATCH))RETURN
PMANAGER_SAVEMF2005=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005
!###======================================================================
SUBROUTINE PMANAGER_SAVEMF6_CLEANNAM(DIR,DIRMNAME,M)
!###======================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME
INTEGER,INTENT(IN) :: M
INTEGER :: IU,JU,KU,IOS,N
CHARACTER(LEN=256) :: FNAME,LINE,STRING
CHARACTER(LEN=52) :: MDLNAME
CHARACTER(LEN=4),DIMENSION(6) :: PCK
LOGICAL :: LEX
DATA PCK/'CHD6','WEL6','DRN6','RCH6','RIV6','HFB6'/
MDLNAME=DIRMNAME(INDEX(DIRMNAME,'\',.TRUE.)+1:); MDLNAME=UTL_CAP(MDLNAME,'U')
FNAME=TRIM(DIR)//'\GWF_'//TRIM(ITOS(M))//'\'//TRIM(MDLNAME)//'.NAM'
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=FNAME,STATUS='OLD',ACTION='READ',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=TRIM(FNAME)//'_',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(JU.EQ.0)THEN; CLOSE(IU); RETURN; ENDIF
DO
READ(IU,'(A256)',IOSTAT=IOS) LINE
IF(IOS.NE.0)EXIT
WRITE(JU,'(A)') TRIM(LINE)
IF(TRIM(LINE).EQ.'BEGIN PACKAGES')THEN
DO
READ(IU,'(A256)',IOSTAT=IOS) LINE
IF(IOS.NE.0)EXIT
LEX=.FALSE.;
DO I=1,SIZE(PCK)
IF(INDEX(LINE,PCK(I)).GT.0)THEN
!## check whether there are packages defined
FNAME=TRIM(DIR)//'\GWF_'//TRIM(ITOS(M))//'\MODELINPUT\'//TRIM(MDLNAME)//'.'//TRIM(PCK(I))
KU=UTL_GETUNIT(); CALL OSD_OPEN(KU,FILE=FNAME,STATUS='OLD',ACTION='READ',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
LEX=.TRUE.
DO
READ(KU,'(A256)') STRING
IF(INDEX(STRING,'MAXBOUND').GT.0)THEN
READ(STRING(9:),*) N
IF(N.GT.0)WRITE(JU,'(A)') TRIM(LINE)
EXIT
ENDIF
IF(INDEX(STRING,'MAXHFB').GT.0)THEN
READ(STRING(7:),*) N
IF(N.GT.0)WRITE(JU,'(A)') TRIM(LINE)
EXIT
ENDIF
ENDDO
CLOSE(KU)
ENDIF
ENDDO
IF(.NOT.LEX)WRITE(JU,'(A)') TRIM(LINE)
ENDDO
ENDIF
ENDDO
CLOSE(IU,STATUS='DELETE'); CLOSE(JU)
FNAME=TRIM(DIR)//'\GWF_'//TRIM(ITOS(M))//'\'//TRIM(MDLNAME)//'.NAM'
CALL IOSRENAMEFILE(TRIM(FNAME)//'_',FNAME)
END SUBROUTINE PMANAGER_SAVEMF6_CLEANNAM
!###======================================================================
SUBROUTINE PMANAGER_SAVEMF6_EXG(DIR,MNAME,M1,M2,NEX,NLAY)
!###======================================================================
IMPLICIT NONE
REAL(KIND=DP_KIND),PARAMETER :: CDISTANCE=0.0D0
CHARACTER(LEN=*),INTENT(IN) :: DIR,MNAME
INTEGER,INTENT(IN) :: M1,M2
INTEGER,INTENT(INOUT) :: NEX
INTEGER,INTENT(OUT) :: NLAY
REAL(KIND=DP_KIND) :: XP,YP,T,B,Z1,Z2
INTEGER :: IU,JU,I,J,K,IM,N,IOS,II,ILAY,JLAY,MAXNLAY,IROW,ICOL,JROW,JCOL,ID
TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:,:) :: BND,TOP,BOT
TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: ICON1,ICON2
INTEGER,DIMENSION(2) :: MNLAY
CHARACTER(LEN=256) :: FNAME,LINE
CHARACTER(LEN=52) :: TXT,MDLNAME
CHARACTER(LEN=1),DIMENSION(6) :: CID=['N','S','W','E','T','B']
LOGICAL :: LEX,LTOP,LBOT,LLAT
MDLNAME=MNAME(INDEX(MNAME,'\',.TRUE.)+1:)
FNAME=TRIM(DIR)//'\MFSIM_M'//TRIM(ITOS(M1))//'_M'//TRIM(ITOS(M2))//'.EXG'
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=FNAME,STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# '//TRIM(FNAME(INDEX(FNAME,'\',.TRUE.)+1:))//' File Generated by '//TRIM(UTL_IMODVERSION())
WRITE(IU,'(/A/)') '#General Options'
WRITE(IU,'(A)') 'BEGIN OPTIONS'
IF(TOPICS(TANI)%IACT_MODEL.EQ.1)WRITE(IU,'(A)') 'AUXILIARY ANGLDEGX'
!## only output of one of the flowfluxes is active
DO I=1,SIZE(TFLX)
IF(ASSOCIATED(PBMAN%ISAVE(TFLX(I))%ILAY))THEN
WRITE(IU,'(1X,A)') 'SAVE_FLOWS'; EXIT
ENDIF
ENDDO
! WRITE(IU,'(1X,A)') 'PRINT_INPUT' - no geprint in file
! WRITE(IU,'(1X,A)') 'PRINT_FLOWS' - no geprint in file
! WRITE(IU,'(1X,A)') 'HARMONIC'
! WRITE(IU,'(A)') '[VARIABLECV [DEWATERED]]'
! WRITE(IU,'(A)') '[NEWTON]'
! WRITE(IU,'(A)') '[GNC6 FILEIN ]' !## ghost-node correction
! WRITE(IU,'(A)') '[MVR6 FILEIN ]' !## water mover
! WRITE(IU,'(A)') '[OBS6 FILEIN ]' !## observation
WRITE(IU,'(A)') 'END OPTIONS'
!## read boundary-files
DO II=1,2
MAXNLAY=0
DO IM=1,2
JU=UTL_GETUNIT()
IF(IM.EQ.1)OPEN(JU,FILE=TRIM(DIR)//'\GWF_'//TRIM(ITOS(M1))//'\MODELINPUT\'//TRIM(MDLNAME)//'.DIS6',STATUS='OLD',ACTION='READ')
IF(IM.EQ.2)OPEN(JU,FILE=TRIM(DIR)//'\GWF_'//TRIM(ITOS(M2))//'\MODELINPUT\'//TRIM(MDLNAME)//'.DIS6',STATUS='OLD',ACTION='READ')
DO
READ(JU,'(A256)',IOSTAT=IOS) LINE; IF(IOS.NE.0)EXIT
IF(INDEX(LINE,'BEGIN DIMENSIONS').GT.0)THEN
READ(JU,*) TXT,MNLAY(IM); MAXNLAY=MAX(MAXNLAY,MNLAY(IM)); IF(IM.EQ.1)NLAY=MNLAY(IM)
IF(II.EQ.2)THEN
IF(IM.EQ.1)THEN
!## read bnd as is
DO I=1,MNLAY(IM); IF(.NOT.IDFREAD(BND(1,I),TRIM(DIR)//'\GWF_'//TRIM(ITOS(M1))//'\MODELINPUT\DIS6\BND_L'//TRIM(ITOS(I))//'.IDF',1))RETURN; ENDDO
ELSE
DO I=1,MNLAY(IM); IF(.NOT.IDFREAD(BND(2,I),TRIM(DIR)//'\GWF_'//TRIM(ITOS(M2))//'\MODELINPUT\DIS6\BND_L'//TRIM(ITOS(I))//'.IDF',1))RETURN; ENDDO
ENDIF
EXIT
ENDIF
ENDIF
ENDDO
CLOSE(JU)
ENDDO
IF(II.EQ.1)THEN
ALLOCATE(BND(2,MAXNLAY)); DO I=1,SIZE(BND,1); DO J=1,SIZE(BND,2); CALL IDFNULLIFY(BND(I,J)); ENDDO; ENDDO
ENDIF
ENDDO
!## check whether the first is smaller than the second first - return otherwise, it will come along later
IF(BND(2,1)%DX.LT.BND(1,1)%DX.OR.NEX.GT.0)THEN
DO I=1,SIZE(BND,1); DO J=1,SIZE(BND,2); CALL IDFDEALLOCATEX(BND(I,J)); ENDDO; ENDDO
WRITE(IU,'(/A/)') '#Dimensions'
WRITE(IU,'(A)') 'BEGIN DIMENSIONS'
WRITE(IU,'(1X,A)') 'NEXG '//TRIM(ITOS(0))
WRITE(IU,'(A)') 'END DIMENSIONS'
WRITE(IU,'(/A/)') '#Exchange Data'
WRITE(IU,'(A)') 'BEGIN EXCHANGEDATA'
WRITE(IU,'(/A)') 'END EXCHANGEDATA'
DEALLOCATE(BND); CLOSE(IU); RETURN
ENDIF
ALLOCATE(TOP(2,MAXNLAY),BOT(2,MAXNLAY),ICON1(MNLAY(1)),ICON2(MNLAY(2)))
DO I=1,SIZE(TOP,1); DO J=1,SIZE(TOP,2); CALL IDFNULLIFY(TOP(I,J)); ENDDO; ENDDO
DO I=1,SIZE(BOT,1); DO J=1,SIZE(BOT,2); CALL IDFNULLIFY(BOT(I,J)); ENDDO; ENDDO
!## correct the idomain
DO K=1,2; DO ILAY=1,MNLAY(K); DO IROW=1,BND(K,1)%NROW; DO ICOL=1,BND(K,1)%NCOL
BND(K,ILAY)%X(ICOL,IROW)=MIN(1.0D0,BND(K,ILAY)%X(ICOL,IROW))
!## inactive
IF(BND(K,ILAY)%X(ICOL,IROW).EQ.0.0D0)BND(K,ILAY)%X(ICOL,IROW)=BND(K,ILAY)%NODATA
!## vertically inactive idomain.le.0
IF(BND(K,ILAY)%X(ICOL,IROW).LT.0.0D0)BND(K,ILAY)%X(ICOL,IROW)=BND(K,ILAY)%NODATA
ENDDO; ENDDO; ENDDO; ENDDO
!## save connections
DO ILAY=1,MNLAY(1); CALL IDFCOPY(BND(1,1),ICON1(ILAY)); ENDDO
DO ILAY=1,MNLAY(2); CALL IDFCOPY(BND(2,1),ICON2(ILAY)); ENDDO
LTOP=.FALSE.; LBOT=.FALSE.; LLAT=.FALSE.
!## determine whether layers are onm top,bottom or next to eachother
ILAY=PBMAN%SM(M1)%ILAY(1)
JLAY=PBMAN%SM(M2)%ILAY(1)
IF(ILAY.LT.JLAY)THEN
LBOT=.TRUE.
ELSEIF(ILAY.GT.JLAY)THEN
LTOP=.TRUE.
ELSE
LLAT=.TRUE.
ENDIF
!## coarse model is on top of fine model
IF(LTOP)THEN
IF(.NOT.ASSOCIATED(PBMAN%SM(M1)%CON(1)%X))THEN
CALL IDFCOPY(BND(1,1),PBMAN%SM(M1)%CON(1))
IF(.NOT.IDFALLOCATEX(PBMAN%SM(M1)%CON(1)))RETURN
PBMAN%SM(M1)%CON(1)%X=0.0D0
ENDIF
!## coarse model is on the bottom of fine model
ELSEIF(LBOT)THEN
IF(.NOT.ASSOCIATED(PBMAN%SM(M1)%CON(2)%X))THEN
CALL IDFCOPY(BND(1,1),PBMAN%SM(M1)%CON(2))
IF(.NOT.IDFALLOCATEX(PBMAN%SM(M1)%CON(2)))RETURN
PBMAN%SM(M1)%CON(2)%X=0.0D0
ENDIF
!## coarse model is lateral of fine model
ELSEIF(LLAT)THEN
IF(.NOT.ASSOCIATED(PBMAN%SM(M1)%CON(3)%X))THEN
CALL IDFCOPY(BND(1,1),PBMAN%SM(M1)%CON(3))
IF(.NOT.IDFALLOCATEX(PBMAN%SM(M1)%CON(3)))RETURN
PBMAN%SM(M1)%CON(3)%X=0.0D0
ENDIF
ENDIF
!## read top/bottom in coarse-resolution
DO IM=1,2
JU=UTL_GETUNIT()
IF(IM.EQ.1)THEN
DO I=1,MNLAY(IM); IF(.NOT.IDFREAD(TOP(1,I),TRIM(DIR)//'\GWF_'//TRIM(ITOS(M1))//'\MODELINPUT\DIS6\TOPM_L'//TRIM(ITOS(I))//'.IDF',1))RETURN; ENDDO
DO I=1,MNLAY(IM); IF(.NOT.IDFREAD(BOT(1,I),TRIM(DIR)//'\GWF_'//TRIM(ITOS(M1))//'\MODELINPUT\DIS6\BOTM_L'//TRIM(ITOS(I))//'.IDF',1))RETURN; ENDDO
ELSE
DO I=1,MNLAY(IM); IF(.NOT.IDFREAD(TOP(2,I),TRIM(DIR)//'\GWF_'//TRIM(ITOS(M2))//'\MODELINPUT\DIS6\TOPM_L'//TRIM(ITOS(I))//'.IDF',1))RETURN; ENDDO
DO I=1,MNLAY(IM); IF(.NOT.IDFREAD(BOT(2,I),TRIM(DIR)//'\GWF_'//TRIM(ITOS(M2))//'\MODELINPUT\DIS6\BOTM_L'//TRIM(ITOS(I))//'.IDF',1))RETURN; ENDDO
ENDIF
ENDDO
DO I=1,2
N=0
!## keep track of type of connections
DO ILAY=1,MNLAY(1); ICON1(ILAY)%X=0.0D0; ENDDO
DO ILAY=1,MNLAY(2); ICON2(ILAY)%X=0.0D0; ENDDO
!## vertical connections
IF(LTOP)THEN
DO IROW=1,BND(1,1)%NROW; DO ICOL=1,BND(1,1)%NCOL
!## already created a link upwards
IF(PBMAN%SM(M1)%CON(1)%X(ICOL,IROW).NE.0.0D0)CYCLE
!## find first top-layer to be potential connected to an upper layer
ILAYLOOP1: DO ILAY=1,MNLAY(1)
!## skip inactive cells
IF(BND(1,ILAY)%X(ICOL,IROW).EQ.BND(1,ILAY)%NODATA)CYCLE
!## if active in other model - probably vertical connection to the top/bottom
CALL IDFGETLOC(BND(1,1),IROW,ICOL,XP,YP); CALL IDFIROWICOL(BND(2,1),JROW,JCOL,XP,YP)
Z1=TOP(1,ILAY)%X(JCOL,JROW); Z2=BOT(1,ILAY)%X(JCOL,JROW)
!## try top connection
LEX=.FALSE.; DO JLAY=MNLAY(2),1,-1
!## only try active layer on top
T=TOP(2,JLAY)%X(JCOL,JROW); B=BOT(2,JLAY)%X(JCOL,JROW)
IF(T-B.GT.0.0D0)THEN
IF(PMANAGER_SAVEMF6_EXG_CONNECTIONS('T',IU,ILAY,IROW,ICOL,JLAY,BND,TOP,BOT,I))THEN
IF(I.EQ.2)PBMAN%SM(M1)%CON(1)%X(ICOL,IROW)=M2
N=N+1
!## id number of cell to be connected to
ICON1(ILAY)%X(ICOL,IROW)=N
ICON2(JLAY)%X(JCOL,JROW)=N
!## stop looking
EXIT ILAYLOOP1
ENDIF
ENDIF
ENDDO
ENDDO ILAYLOOP1
ENDDO; ENDDO
ENDIF
!## vertical connections
IF(LBOT)THEN
DO IROW=1,BND(1,1)%NROW; DO ICOL=1,BND(1,1)%NCOL
!## already created a link downwards
IF(PBMAN%SM(M1)%CON(2)%X(ICOL,IROW).NE.0.0D0)CYCLE
!## find first bottom-layer to be potential connected to a lower layer
ILAYLOOP2: DO ILAY=MNLAY(1),1,-1
!## skip inactive cells
IF(BND(1,ILAY)%X(ICOL,IROW).EQ.BND(1,ILAY)%NODATA)CYCLE
!## if active in other model - probably vertical connection to the top/bottom
CALL IDFGETLOC(BND(1,1),IROW,ICOL,XP,YP); CALL IDFIROWICOL(BND(2,1),JROW,JCOL,XP,YP)
Z1=TOP(1,ILAY)%X(JCOL,JROW); Z2=BOT(1,ILAY)%X(JCOL,JROW)
!## try bot connection
LEX=.FALSE.; DO JLAY=1,MNLAY(2)
!## only try active layer on top
T=TOP(2,JLAY)%X(JCOL,JROW); B=BOT(2,JLAY)%X(JCOL,JROW)
IF(T-B.GT.0.0D0)THEN
IF(PMANAGER_SAVEMF6_EXG_CONNECTIONS('B',IU,ILAY,IROW,ICOL,JLAY,BND,TOP,BOT,I))THEN
IF(I.EQ.2)PBMAN%SM(M1)%CON(2)%X(ICOL,IROW)=M2
N=N+1
!## id number of cell to be connected to
ICON1(ILAY)%X(ICOL,IROW)=N
ICON2(JLAY)%X(JCOL,JROW)=N
!## stop looking
EXIT ILAYLOOP2
ENDIF
ENDIF
ENDDO
ENDDO ILAYLOOP2
ENDDO; ENDDO
ENDIF
IF(LLAT)THEN
DO ILAY=1,MNLAY(1)
!## connections
DO IROW=1,BND(1,ILAY)%NROW; DO ICOL=1,BND(1,ILAY)%NCOL
!## skip inactive cells
IF(BND(1,ILAY)%X(ICOL,IROW).EQ.BND(1,ILAY)%NODATA)CYCLE
!## found boundary cell
DO ID=1,4
LEX=.FALSE.
SELECT CASE (CID(ID))
!## north
CASE ('N')
IF(IROW.EQ.1)LEX=.TRUE.
IF(IROW.GT.1)THEN; LEX=BND(1,ILAY)%X(ICOL,IROW-1).EQ.BND(1,ILAY)%NODATA; ENDIF
!## south
CASE ('S')
IF(IROW.EQ.BND(1,ILAY)%NROW)LEX=.TRUE.
IF(IROW.LT.BND(1,ILAY)%NROW)THEN; LEX=BND(1,ILAY)%X(ICOL,IROW+1).EQ.BND(1,ILAY)%NODATA; ENDIF
!## west
CASE ('W')
IF(ICOL.EQ.1)LEX=.TRUE.
IF(ICOL.GT.1)THEN; LEX=BND(1,ILAY)%X(ICOL-1,IROW).EQ.BND(1,ILAY)%NODATA; ENDIF
!## east
CASE ('E')
IF(ICOL.EQ.BND(1,ILAY)%NCOL)LEX=.TRUE.
IF(ICOL.LT.BND(1,ILAY)%NCOL)THEN; LEX=BND(1,ILAY)%X(ICOL+1,IROW).EQ.BND(1,ILAY)%NODATA; ENDIF
END SELECT
IF(.NOT.LEX)CYCLE
IF(PMANAGER_SAVEMF6_EXG_CONNECTIONS(CID(ID),IU,ILAY,IROW,ICOL,0,BND,TOP,BOT,I))THEN
IF(I.EQ.2)PBMAN%SM(M1)%CON(3)%X(ICOL,IROW)=M2
N=N+1
!## id number of cell to be connected to
ICON1(ILAY)%X(ICOL,IROW)=N
CALL IDFGETLOC(BND(1,1),IROW,ICOL,XP,YP); CALL IDFIROWICOL(BND(2,1),JROW,JCOL,XP,YP)
ICON2(ILAY)%X(JCOL,JROW)=N
ENDIF
ENDDO
ENDDO; ENDDO
ENDDO
ENDIF
IF(I.EQ.1)THEN
WRITE(IU,'(/A/)') '#Dimensions'
WRITE(IU,'(A)') 'BEGIN DIMENSIONS'
WRITE(IU,'(1X,A)') 'NEXG '//TRIM(ITOS(N)); NEX=N
WRITE(IU,'(A)') 'END DIMENSIONS'
WRITE(IU,'(/A/)') '#Exchange Data'
WRITE(IU,'(A)') 'BEGIN EXCHANGEDATA'
ELSE
WRITE(IU,'(A)') 'END EXCHANGEDATA'
ENDIF
ENDDO
CLOSE(IU)
!## write connections
DO I=1,MNLAY(1)
ICON1(I)%FNAME=TRIM(DIR)//'\GWF_'//TRIM(ITOS(M1))//'\GWF_EXCHANGE\GWF_'//TRIM(ITOS(M1))//'_L'//TRIM(ITOS(I))//'_GWF_'//TRIM(ITOS(M2))//'.IDF'
IF(MAXVAL(ICON1(I)%X).EQ.0.0D0)CYCLE
IF(.NOT.IDFWRITE(ICON1(I),ICON1(I)%FNAME,1))THEN; ENDIF
ENDDO
DO I=1,MNLAY(2)
ICON2(I)%FNAME=TRIM(DIR)//'\GWF_'//TRIM(ITOS(M2))//'\GWF_EXCHANGE\GWF_'//TRIM(ITOS(M2))//'_L'//TRIM(ITOS(I))//'_GWF_'//TRIM(ITOS(M1))//'.IDF'
IF(MAXVAL(ICON2(I)%X).EQ.0.0D0)CYCLE
IF(.NOT.IDFWRITE(ICON2(I),ICON2(I)%FNAME,1))THEN; ENDIF
ENDDO
DO I=1,SIZE(BND,1); DO J=1,SIZE(BND,2); CALL IDFDEALLOCATEX(BND(I,J)); ENDDO; ENDDO
DO I=1,SIZE(TOP,1); DO J=1,SIZE(TOP,2); CALL IDFDEALLOCATEX(TOP(I,J)); ENDDO; ENDDO
DO I=1,SIZE(BOT,1); DO J=1,SIZE(BOT,2); CALL IDFDEALLOCATEX(BOT(I,J)); ENDDO; ENDDO
DEALLOCATE(BND,TOP,BOT)
DO I=1,SIZE(ICON1); CALL IDFDEALLOCATEX(ICON1(I)); ENDDO
DO I=1,SIZE(ICON2); CALL IDFDEALLOCATEX(ICON2(I)); ENDDO
DEALLOCATE(ICON1,ICON2)
END SUBROUTINE PMANAGER_SAVEMF6_EXG
!###======================================================================
SUBROUTINE PMANAGER_SAVEMF6_EXG_MODIFYHFB(MAINDIR,MNAME,M1,SUBNLAY)
!###======================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: MNAME,MAINDIR
INTEGER,INTENT(IN),DIMENSION(:) :: SUBNLAY
INTEGER,INTENT(IN) :: M1
CHARACTER(LEN=256) :: FNAME,STRING,MDLNAME
CHARACTER(LEN=52) :: TXT
CHARACTER(LEN=1) :: CDIR,CHV
INTEGER :: IU,JU,KU,IOS,ILAY,IROW,ICOL,N,IHC,M,M2,IHFB,NEXG,MM,II
REAL(KIND=DP_KIND) :: HWVA,AREA,F
REAL(KIND=DP_KIND),DIMENSION(2) :: CL
TYPE HFBOBJ
INTEGER,DIMENSION(2) :: ICOL,IROW
INTEGER :: ILAY,IBND
CHARACTER(LEN=1) :: CHV
REAL(KIND=DP_KIND) :: C,F
END TYPE HFBOBJ
TYPE(HFBOBJ),ALLOCATABLE,DIMENSION(:,:) :: HFB
INTEGER,DIMENSION(2,3) :: CELLID
INTEGER,DIMENSION(2) :: NHFB
MDLNAME=MNAME(INDEX(MNAME,'\',.TRUE.)+1:)
!## correct any exchange, if needed, for this submodel
DO M2=1,PBMAN%NSUBMODEL
IF(M2.EQ.M1)CYCLE
FNAME=TRIM(MAINDIR)//'\MFSIM_M'//TRIM(ITOS(M1))//'_M'//TRIM(ITOS(M2))//'.EXG'
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=FNAME,STATUS='OLD',ACTION='READ',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
FNAME=TRIM(MAINDIR)//'\MFSIM_M'//TRIM(ITOS(M1))//'_M'//TRIM(ITOS(M2))//'.EXG_'
KU=UTL_GETUNIT(); CALL OSD_OPEN(KU,FILE=FNAME,STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(KU.EQ.0)RETURN
DO
READ(IU,'(A256)',IOSTAT=IOS) STRING
!## file probably empty
IF(IOS.NE.0)EXIT
IF(TRIM(STRING).EQ.'BEGIN DIMENSIONS')THEN
WRITE(KU,'(A)') TRIM(STRING)
READ(IU,'(A256)',IOSTAT=IOS) STRING
READ(STRING,*) TXT,NEXG
ENDIF
IF(TRIM(STRING).EQ.'BEGIN EXCHANGEDATA')THEN
WRITE(KU,'(A)') TRIM(STRING)
!## load all hfbs on boundaries for both sub models
ALLOCATE(HFB(2,1)); NHFB=0
!## exchange existing
IF(NEXG.GT.0)THEN
DO I=1,2
M=0; DO IHFB=1,2
IF(IHFB.EQ.1)MM=M1; IF(IHFB.EQ.2)MM=M2
N=0; DO ILAY=1,SUBNLAY(MM)
FNAME=TRIM(MAINDIR)//'\GWF_'//TRIM(ITOS(MM))//'\MODELINPUT\'//TRIM(MDLNAME)//'_HFB_L'//TRIM(ITOS(ILAY))//'.DAT'
JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=FNAME,STATUS='OLD',ACTION='READ',FORM='FORMATTED',IQUESTION=0)
IF(JU.GT.0)THEN
READ(JU,*)
DO
N=N+1
IF(I.EQ.1)THEN
M=M+1; IF(I.EQ.1)N=1
ELSE
IF(N.GT.NHFB(IHFB))EXIT
ENDIF
READ(JU,'(11X,F15.0,17X,F15.0,10X,5I10)',IOSTAT=IOS) HFB(IHFB,N)%C, HFB(IHFB,N)%F, HFB(IHFB,N)%ICOL(1), &
HFB(IHFB,N)%IROW(1),HFB(IHFB,N)%ICOL(2),HFB(IHFB,N)%IROW(2), &
HFB(IHFB,N)%IBND
IF(IOS.NE.0)EXIT
HFB(IHFB,N)%ILAY=ILAY
!## horizontal
IF(HFB(IHFB,N)%ICOL(1).LT.HFB(IHFB,N)%ICOL(2))HFB(IHFB,N)%CHV='H'
IF(HFB(IHFB,N)%ICOL(1).GT.HFB(IHFB,N)%ICOL(2))HFB(IHFB,N)%CHV='H'
!## vertical
IF(HFB(IHFB,N)%IROW(1).LT.HFB(IHFB,N)%IROW(2))HFB(IHFB,N)%CHV='V'
IF(HFB(IHFB,N)%IROW(1).GT.HFB(IHFB,N)%IROW(2))HFB(IHFB,N)%CHV='V'
ENDDO
M=M-1; IF(I.EQ.1)NHFB(IHFB)=M; CLOSE(JU)
ENDIF
ENDDO
ENDDO
IF(MAXVAL(NHFB).GT.0)THEN
IF(I.EQ.1)THEN
DEALLOCATE(HFB); ALLOCATE(HFB(2,MAXVAL(NHFB)))
ENDIF
ELSE
!## nothing found - continue
EXIT
ENDIF
ENDDO
ENDIF
!## check whether hfb urges to modify exchange
DO
READ(IU,'(A256)',IOSTAT=IOS) STRING; IF(IOS.NE.0)EXIT; IF(LEN_TRIM(STRING).EQ.0)EXIT
IF(TRIM(STRING).EQ.'END EXCHANGEDATA')EXIT
READ(STRING,'(7I10,5G15.7,3X,A1)') (CELLID(1,I),I=1,3),(CELLID(2,I),I=1,3),IHC,CL(1),CL(2),HWVA,AREA,CDIR
SELECT CASE (CDIR); CASE ('E','W'); CHV='H'; CASE DEFAULT; CHV='V'; END SELECT
DO IHFB=1,2
!## look for fault
ILAY=CELLID(IHFB,1)
IROW=CELLID(IHFB,2)
ICOL=CELLID(IHFB,3)
IILOOP: DO I=1,NHFB(IHFB)
!## skip if not on a potential boundary
IF(HFB(IHFB,I)%IBND.EQ.0)CYCLE
DO II=1,2
IF(HFB(IHFB,I)%ILAY .EQ.ILAY.AND. &
HFB(IHFB,I)%IROW(II).EQ.IROW.AND. &
HFB(IHFB,I)%ICOL(II).EQ.ICOL.AND. &
HFB(IHFB,I)%CHV .EQ.CHV)THEN
!## no flow at all - remove exchange --- this need to be solved by the USGS
F=HUGE(1.0)
!## found hfb location in between current sub model - apply factor
CL=CL*F; EXIT IILOOP
ENDIF
ENDDO
ENDDO IILOOP
IF(IHFB.EQ.2.OR.I.LE.NHFB(IHFB))THEN
WRITE(KU,'(7I10,5G15.7,1X,A3)') (CELLID(1,I),I=1,3),(CELLID(2,I),I=1,3),IHC,CL(1),CL(2),HWVA,AREA,CDIR
EXIT
ENDIF
ENDDO
ENDDO
DEALLOCATE(HFB)
WRITE(KU,'(A)') TRIM(STRING)
ELSE
WRITE(KU,'(A)') TRIM(STRING)
ENDIF
ENDDO
CLOSE(IU,STATUS='DELETE'); CLOSE(KU)
CALL IOSRENAMEFILE(TRIM(MAINDIR)//'\MFSIM_M'//TRIM(ITOS(M1))//'_M'//TRIM(ITOS(M2))//'.EXG_', &
TRIM(MAINDIR)//'\MFSIM_M'//TRIM(ITOS(M1))//'_M'//TRIM(ITOS(M2))//'.EXG')
ENDDO
END SUBROUTINE PMANAGER_SAVEMF6_EXG_MODIFYHFB
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF6_EXG_CONNECTIONS(CDIR,IU,ILAY,IROW,ICOL,KLAY,BND,TOP,BOT,IIU)
!###======================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: CDIR
INTEGER,INTENT(IN) :: ILAY,IROW,ICOL,IU,IIU,KLAY
TYPE(IDFOBJ),INTENT(IN),DIMENSION(:,:) :: BND,TOP,BOT
INTEGER,DIMENSION(2,3) :: CELLID
INTEGER :: JROW,JCOL,JLAY,IHC,I
REAL(KIND=DP_KIND) :: HWVA,XP1,YP1,XP2,YP2,X1,X2,Y1,Y2,Z1,Z2,XP,YP,ZP1,ZP2,DX1,DX2,DY1,DY2,DZ1,DZ2, &
XINT1,YINT1,ZINT1,XINT2,YINT2,ZINT2,ANGLDEGX,DX,DY
REAL(KIND=DP_KIND),DIMENSION(2) :: CL
PMANAGER_SAVEMF6_EXG_CONNECTIONS=.FALSE.
!## active cell?
IF(BND(1,ILAY)%X(ICOL,IROW).EQ.BND(1,ILAY)%NODATA)RETURN
!## current centre location of fine model
CALL IDFGETLOC (BND(1,ILAY),IROW,ICOL,XP1,YP1)
!## get location in coarse-model use ilay=1
CALL IDFGETEDGE (BND(1,ILAY),IROW,ICOL,X1 ,Y1 ,X2 ,Y2)
!## get vertical position of node
Z2=TOP(1,ILAY)%X(ICOL,IROW); Z1=BOT(1,ILAY)%X(ICOL,IROW)
DZ1=Z2-Z1; ZP1=Z1+0.5D0*DZ1
!## get cellsize of fine model
CALL IDFGETDXDY(BND(1,ILAY),IROW,ICOL,DX1,DY1)
!## get location of nearest course model
SELECT CASE (CDIR)
CASE ('N'); CALL IDFGETLOC(BND(1,ILAY),IROW-1,ICOL,XP,YP); IHC=1; JLAY=ILAY
CASE ('S'); CALL IDFGETLOC(BND(1,ILAY),IROW+1,ICOL,XP,YP); IHC=1; JLAY=ILAY
CASE ('W'); CALL IDFGETLOC(BND(1,ILAY),IROW,ICOL-1,XP,YP); IHC=1; JLAY=ILAY
CASE ('E'); CALL IDFGETLOC(BND(1,ILAY),IROW,ICOL+1,XP,YP); IHC=1; JLAY=ILAY
CASE ('T'); CALL IDFGETLOC(BND(1,ILAY),IROW,ICOL ,XP,YP); IHC=0; JLAY=KLAY
CASE ('B'); CALL IDFGETLOC(BND(1,ILAY),IROW,ICOL ,XP,YP); IHC=0; JLAY=KLAY
END SELECT
!## outside parent model
CALL IDFIROWICOL(BND(2,JLAY),JROW,JCOL,XP,YP); IF(JROW.LE.0.OR.JCOL.LE.0)RETURN
!## check if location is active
IF(BND(2,JLAY)%X(JCOL,JROW).EQ.BND(2,JLAY)%NODATA)RETURN
!## get location of cell outside submodel
CALL IDFGETLOC(BND(2,JLAY),JROW,JCOL,XP2,YP2)
!## get vertical position of node
DZ2=TOP(2,JLAY)%X(JCOL,JROW)-BOT(2,JLAY)%X(JCOL,JROW)
ZP2=BOT(2,JLAY)%X(JCOL,JROW)+0.5D0*DZ2
!## get cellsize of course model
CALL IDFGETDXDY(BND(2,JLAY),JROW,JCOL,DX2,DY2)
DX=XP2-XP1
DY=YP2-YP1
ANGLDEGX=ATAN2(DY,DX)
ANGLDEGX=(ANGLDEGX*360.0D0)/(2.0D0*PI)
IF(ANGLDEGX.LT.0.0D0)ANGLDEGX=ANGLDEGX+360.0D0
CELLID(1,1)=ILAY
CELLID(1,2)=IROW
CELLID(1,3)=ICOL
CELLID(2,1)=JLAY
CELLID(2,2)=JROW
CELLID(2,3)=JCOL
!## find point on shared interface
SELECT CASE (CDIR)
CASE ('W')
XINT1=X1; YINT1=YP1
XINT2=X1; YINT2=YP2
CASE ('E')
XINT1=X2; YINT1=YP1
XINT2=X2; YINT2=YP2
CASE ('N')
XINT1=XP1; YINT1=Y2
XINT2=XP2; YINT2=Y2
CASE ('S')
XINT1=XP1; YINT1=Y1
XINT2=XP2; YINT2=Y1
CASE ('T')
ZINT1=Z2; XINT1=XP1; YINT1=YP1
ZINT2=Z2; XINT2=XP2; YINT2=YP2
CASE ('B')
ZINT1=Z1; XINT1=XP1; YINT1=YP1
ZINT2=Z1; XINT2=XP2; YINT2=YP2
END SELECT
!## area of connection in vertical
HWVA=0.0D0
!## width of connection
IF(IHC.EQ.1)THEN
!## distance to shared interface
CL(1)=UTL_DIST(XP1,YP1,XINT1,YINT1)
CL(2)=UTL_DIST(XP2,YP2,XINT2,YINT2)
HWVA=X2-X1
!## area of connection
ELSEIF(IHC.EQ.0)THEN
!## ook 2d denk ik ... gewoon recht naar het vlak toe
CL(1)=UTL_DIST_3D(XP1,YP1,ZP1,XINT1,YINT1,ZINT1)
CL(2)=UTL_DIST_3D(XP2,YP2,ZP2,XINT2,YINT2,ZINT2)
HWVA=(X2-X1)*(Y2-Y1)
ENDIF
IF(IIU.EQ.2)THEN
IF(TOPICS(TANI)%IACT_MODEL.EQ.1)THEN
WRITE(IU,'(7I10,5G15.7,1X,A3)') (CELLID(1,I),I=1,3),(CELLID(2,I),I=1,3),IHC,CL(1),CL(2),HWVA,ANGLDEGX,CDIR
ELSE
WRITE(IU,'(7I10,5G15.7,1X,A3)') (CELLID(1,I),I=1,3),(CELLID(2,I),I=1,3),IHC,CL(1),CL(2),HWVA,0.0D0,CDIR
ENDIF
ENDIF
PMANAGER_SAVEMF6_EXG_CONNECTIONS=.TRUE.
END FUNCTION PMANAGER_SAVEMF6_EXG_CONNECTIONS
!###======================================================================
SUBROUTINE PMANAGER_SAVEMF2005_CONSISTENCY(LTB)
!###======================================================================
IMPLICIT NONE
LOGICAL,INTENT(IN) :: LTB
INTEGER :: IROW,ICOL,ILAY,JLAY,N
REAL(KIND=DP_KIND),DIMENSION(:),ALLOCATABLE :: TP,BT,HK,VK,VA,TP_BU,BT_BU,HK_BU,VK_BU,VA_BU
REAL(KIND=DP_KIND),DIMENSION(:,:),ALLOCATABLE :: TH
INTEGER,DIMENSION(:),ALLOCATABLE :: IB
REAL(KIND=DP_KIND) :: ST,SB
!## make sure nodata for anisotropy factors is 1.0D0
IF(TOPICS(TANI)%DEFINED)THEN
!## apply consistency check anisotropy factor to be in between 0.0D0-1.0D0
DO ILAY=1,PRJNLAY; DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
ANF(ILAY)%X(ICOL,IROW)=MAX(0.0D0,MIN(1.0D0,ANF(ILAY)%X(ICOL,IROW)))
ENDDO; ENDDO; ENDDO
ENDIF
!## in case of modflow6 overrule consistency check to option 1
IF(PBMAN%IFORMAT.EQ.3)THEN
PBMAN%ICONSISTENCY=1; PBMAN%MINTHICKNESS=0.0D0
ENDIF
!## clean from bottom to top inactive layers with zero conductance - in case of iconsistency.eq.1
IF(PBMAN%ICONSISTENCY.NE.2)THEN
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
DO ILAY=PRJNLAY,1,-1
IF(KDW(ILAY)%X(ICOL,IROW).LE.0.0D0)THEN
IF(ILAY.GT.1)VCW(ILAY-1)%X(ICOL,IROW)=0.0D0
KDW(ILAY)%X(ICOL,IROW)=0.0D0
BND(ILAY)%X(ICOL,IROW)=0.0D0
ELSE
!## stop search for this location
EXIT
ENDIF
ENDDO
ENDDO; ENDDO
ENDIF
IF(.NOT.LTB)RETURN
!## apply consistency check top/bot
IF(PBMAN%ICONSISTENCY.EQ.1)THEN
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL; JLAY=0; DO ILAY=1,PRJNLAY
IF(BND(ILAY)%X(ICOL,IROW).EQ.0)CYCLE
SB=BOT(ILAY)%X(ICOL,IROW)
ST=TOP(ILAY)%X(ICOL,IROW)
SB=MIN(ST,SB)
BOT(ILAY)%X(ICOL,IROW)=SB
IF(JLAY.GT.0)THEN
!## minimal aquifer thickness
SB=BOT(JLAY)%X(ICOL,IROW)
ST=TOP(ILAY)%X(ICOL,IROW)
ST=MIN(SB,ST)
TOP(ILAY)%X(ICOL,IROW)=ST
ENDIF
!## store last active layer
JLAY=ILAY
ENDDO; ENDDO; ENDDO
ELSEIF(PBMAN%ICONSISTENCY.EQ.2)THEN
IF(ALLOCATED(KHV).AND.ALLOCATED(KVA).AND.ALLOCATED(KVV))THEN
ALLOCATE(TP(PRJNLAY) ,BT(PRJNLAY) ,HK(PRJNLAY) ,VK(PRJNLAY) ,VA(PRJNLAY) ,IB(PRJNLAY),TH(PRJNLAY,2), &
TP_BU(PRJNLAY),BT_BU(PRJNLAY),HK_BU(PRJNLAY),VK_BU(PRJNLAY),VA_BU(PRJNLAY))
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
DO ILAY=1,PRJNLAY ; IB(ILAY)=BND(ILAY)%X(ICOL,IROW); ENDDO
DO ILAY=1,PRJNLAY ; TP(ILAY)=TOP(ILAY)%X(ICOL,IROW); ENDDO
DO ILAY=1,PRJNLAY ; BT(ILAY)=BOT(ILAY)%X(ICOL,IROW); ENDDO
DO ILAY=1,PRJNLAY ; HK(ILAY)=KHV(ILAY)%X(ICOL,IROW); ENDDO
DO ILAY=1,PRJNLAY ; VA(ILAY)=KVA(ILAY)%X(ICOL,IROW); ENDDO
VK=0.0D0; DO ILAY=1,PRJNLAY-1; VK(ILAY)=KVV(ILAY)%X(ICOL,IROW); ENDDO
CALL UTL_MINTHICKNESS(TP,BT,HK,VK,VA,TP_BU,BT_BU,HK_BU,VK_BU,VA_BU,IB,TH,PBMAN%MINTHICKNESS,PRJNLAY,ICOL,IROW)
DO ILAY=1,PRJNLAY ; IB(ILAY)=BND(ILAY)%X(ICOL,IROW); ENDDO
DO ILAY=1,PRJNLAY ; TOP(ILAY)%X(ICOL,IROW)=TP(ILAY); ENDDO
DO ILAY=1,PRJNLAY ; BOT(ILAY)%X(ICOL,IROW)=BT(ILAY); ENDDO
DO ILAY=1,PRJNLAY ; KHV(ILAY)%X(ICOL,IROW)=HK(ILAY); ENDDO
DO ILAY=1,PRJNLAY ; KVA(ILAY)%X(ICOL,IROW)=VA(ILAY); ENDDO
DO ILAY=1,PRJNLAY-1; KVV(ILAY)%X(ICOL,IROW)=VK(ILAY); ENDDO
!## clean
DO ILAY=1,PRJNLAY
IF(IB(ILAY).EQ.0)THEN
TOP(ILAY)%X(ICOL,IROW)=TOP(ILAY)%NODATA
KHV(ILAY)%X(ICOL,IROW)=KHV(ILAY)%NODATA
KVA(ILAY)%X(ICOL,IROW)=KVA(ILAY)%NODATA
IF(ILAY.LT.PRJNLAY)KVV(ILAY)%X(ICOL,IROW)=KVV(ILAY)%NODATA
!## skip bottom as well as layer below is nodata
IF(ILAY.LT.PRJNLAY)THEN
IF(IB(ILAY+1).EQ.0)BOT(ILAY)%X(ICOL,IROW)=BOT(ILAY)%NODATA
ENDIF
ENDIF
ENDDO
ENDDO; ENDDO
DEALLOCATE(TP,BT,HK,VK,VA,IB,TH,TP_BU,BT_BU,HK_BU,VK_BU,VA_BU)
ENDIF
ENDIF
!## constant head is not allowed in cell with thickness of 0.0
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL; DO ILAY=1,PRJNLAY
IF(BND(ILAY)%X(ICOL,IROW).LT.0)THEN
IF(TOP(ILAY)%X(ICOL,IROW)-BOT(ILAY)%X(ICOL,IROW).LE.0.0)BND(ILAY)%X(ICOL,IROW)=ABS(BND(ILAY)%X(ICOL,IROW))
ENDIF
ENDDO; ENDDO; ENDDO
!## apply consistency check constant head and top/bot - only whenever CHD is not active
IF(PBMAN%ICHKCHD.EQ.1)THEN
N=0
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL; DO ILAY=1,PRJNLAY
IF(BND(ILAY)%X(ICOL,IROW).LT.0)THEN
!## head is in within current layer
IF(SHD(ILAY)%X(ICOL,IROW).GT.BOT(ILAY)%X(ICOL,IROW))CYCLE
N=N+1
!## constant head cell dry - becomes active node - shift to an appropriate model layer where the head is actually in
DO JLAY=ILAY,PRJNLAY
IF(SHD(ILAY)%X(ICOL,IROW).LE.BOT(JLAY)%X(ICOL,IROW))THEN
BND(JLAY)%X(ICOL,IROW)=1.0D0
SHD(JLAY)%X(ICOL,IROW)=SHD(ILAY)%X(ICOL,IROW)
ELSE
BND(JLAY)%X(ICOL,IROW)=-99.0D0
SHD(JLAY)%X(ICOL,IROW)=SHD(ILAY)%X(ICOL,IROW)
!## exit
EXIT
ENDIF
ENDDO
ENDIF
ENDDO; ENDDO; ENDDO
WRITE(*,'(/A/)') 'iMOD corrected '//TRIM(ITOS(N))//' constant heads cell which were inappropriate regarding there levels.'
ENDIF
!## if unconfined modify (nodata) head for dry cells, check from bottom to top
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL; DO ILAY=PRJNLAY-1,1,-1
IF(LAYCON(ILAY).NE.2)CYCLE
IF(SHD(ILAY)%X(ICOL,IROW).EQ.HNOFLOW.AND.BND(ILAY)%X(ICOL,IROW).GT.0)THEN
SHD(ILAY)%X(ICOL,IROW)=SHD(ILAY+1)%X(ICOL,IROW)
ENDIF
ENDDO; ENDDO; ENDDO
!## clean from bottom to top inactive layers with zero conductance
IF(PBMAN%ICONSISTENCY.NE.2)THEN
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
DO ILAY=PRJNLAY,1,-1
IF(KDW(ILAY)%X(ICOL,IROW).LE.0.0D0)THEN
IF(ILAY.GT.1)VCW(ILAY-1)%X(ICOL,IROW)=0.0D0
KDW(ILAY)%X(ICOL,IROW)=0.0D0
BND(ILAY)%X(ICOL,IROW)=0.0D0
ELSE
!## stop search for this location
EXIT
ENDIF
ENDDO
ENDDO; ENDDO
ENDIF
END SUBROUTINE PMANAGER_SAVEMF2005_CONSISTENCY
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_NAM(FNAME,MAINDIR,DIR,DIRMNAME,IPRT,ISS)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ISS
INTEGER,INTENT(OUT) :: IPRT
CHARACTER(LEN=*),INTENT(IN) :: FNAME
CHARACTER(LEN=*),INTENT(OUT) :: DIR,DIRMNAME,MAINDIR
INTEGER :: IU,I,J,N1,N2
CHARACTER(LEN=52) :: MNAME
CHARACTER(LEN=256) :: NAME
PMANAGER_SAVEMF2005_NAM=.FALSE.
IF(TOPICS(TUZF)%DEFINED)THEN
IF(LAYCON(1).NE.2)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'It is compulsory to use an unconfined first model layer for the UZF package','Error')
RETURN
ENDIF
ENDIF
!## result main folder
IF(LEN_TRIM(PBMAN%OUTPUT).EQ.0)THEN
MAINDIR=FNAME(:INDEX(FNAME,'\',.TRUE.)-1)
ELSE
MAINDIR=TRIM(PBMAN%OUTPUT)
ENDIF
MAINDIR=UTL_CAP(MAINDIR,'U'); CALL UTL_CREATEDIR(MAINDIR)
!## modelname
MNAME=FNAME(INDEX(FNAME,'\',.TRUE.)+1:INDEX(FNAME,'.',.TRUE.)-1); MNAME=UTL_CAP(MNAME,'U')
!## write *.nam file for modflow 6
IF(PBMAN%IFORMAT.EQ.3.AND.PBMAN%ISUBMODEL.EQ.1)THEN
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(MAINDIR)//'\MFSIM.NAM',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# MFSIM.NAM File Generated by '//TRIM(UTL_IMODVERSION())
WRITE(IU,'(/A/)') '#General Options'
WRITE(IU,'(A)') 'BEGIN OPTIONS'
![CONTINUE]
![NOCHECK]
![MEMORY_PRINT_OPTION ]
WRITE(IU,'(A)') 'END OPTIONS'
WRITE(IU,'(/A/)') '#Timing Options'
WRITE(IU,'(A)') 'BEGIN TIMING'
WRITE(IU,'(A)') ' TDIS6 .\MFSIM.TDIS6'
WRITE(IU,'(A)') 'END TIMING'
WRITE(IU,'(/A/)') '#List of Models'
WRITE(IU,'(A)') 'BEGIN MODELS'
!## multiply models
DO I=1,PBMAN%NSUBMODEL
WRITE(IU,'(A)') ' GWF6 .\GWF_'//TRIM(ITOS(I))//'\'//TRIM(MNAME)//'.NAM GWF_'//TRIM(ITOS(I))
ENDDO
WRITE(IU,'(A)') 'END MODELS'
WRITE(IU,'(/A/)') '#List of Exchanges'
WRITE(IU,'(A)') 'BEGIN EXCHANGES'
DO I=1,PBMAN%NSUBMODEL
DO J=1,PBMAN%NSUBMODEL
IF(I.EQ.J)CYCLE
WRITE(IU,'(A)') ' GWF6-GWF6 .\MFSIM_M'//TRIM(ITOS(I))//'_M'//TRIM(ITOS(J))//'.EXG GWF_'//TRIM(ITOS(I))//' GWF_'//TRIM(ITOS(J))
ENDDO
ENDDO
WRITE(IU,'(A)') 'END EXCHANGES'
WRITE(IU,'(/A/)') '#Definition of Numerical Solution'
WRITE(IU,'(A)') 'BEGIN SOLUTIONGROUP 1'
WRITE(IU,'(A)') ' MXITER 1'
WRITE(IU,'(A,99A)') ' IMS6 .\MFSIM.IMS6',(' GWF_'//TRIM(ITOS(I)),I=1,PBMAN%NSUBMODEL)
WRITE(IU,'(A)') 'END SOLUTIONGROUP'
CLOSE(IU)
ENDIF
!## loop over multiply models
DIR=MAINDIR; IF(PBMAN%IFORMAT.EQ.3)DIR=TRIM(MAINDIR)//'\GWF_'//TRIM(ITOS(PBMAN%ISUBMODEL))
!## result folder including the modelname
DIRMNAME='MODELINPUT\'//TRIM(MNAME)
CALL UTL_CREATEDIR(TRIM(DIR)//'\MODELINPUT')
IF(TOPICS(TCAP)%DEFINED)CALL UTL_CREATEDIR(TRIM(DIR)//'\MSWAPINPUT')
IF(PBMAN%IFORMAT.EQ.3)THEN
DIRMNAME='GWF_'//TRIM(ITOS(PBMAN%ISUBMODEL))//'\'//TRIM(DIRMNAME)
DIRMNAME='.\'//TRIM(DIRMNAME)
!## write *.nam file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIR)//'\'//TRIM(MNAME)//'.NAM',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# '//TRIM(MNAME)//'.NAM File Generated by '//TRIM(UTL_IMODVERSION())
WRITE(IU,'(/A/)') '#General Options'
WRITE(IU,'(A)') 'BEGIN OPTIONS'
WRITE(IU,'(A)') ' LIST .\GWF_'//TRIM(ITOS(PBMAN%ISUBMODEL))//'\'//TRIM(MNAME)//'.LST'
!## debug option
! IF()WRITE(IU,'(A)') 'PRINT_INPUT'
!## print budgets
! IF()WRITE(IU,'(A)') 'PRINT_FLOWS'
!SAVE FLOWS—keyword to indicate that all model package flow terms will be written to the file specified
!with “BUDGET FILEOUT” in Output Control.
! IF()WRITE(IU,'(A)') 'SAVE_FLOWS'
!NEWTON—keyword that activates the Newton-Raphson formulation for groundwater flow between connected,
!convertible groundwater cells and stress packages that support calculation of Newton-
!Raphson terms for groundwater exchanges. Cells will not dry when this option is used. By default,
!the Newton-Raphson formulation is not applied.
!UNDER RELAXATION—keyword that indicates whether the groundwater head in a cell will be underrelaxed
!when water levels fall below the bottom of the model below any given cell. By default,
!Newton-Raphson UNDER RELAXATION is not applied.
! IF()WRITE(IU,'(A)') 'NEWTON [UNDER_RELAXATION]'
WRITE(IU,'(A)') 'END OPTIONS'
WRITE(IU,'(/A/)') '#List of Packages'
WRITE(IU,'(A)') 'BEGIN PACKAGES'
WRITE(IU,'(A)') ' DIS6 '//TRIM(DIRMNAME)//'.DIS6'
WRITE(IU,'(A)') ' IC6 '//TRIM(DIRMNAME)//'.IC6'
WRITE(IU,'(A)') ' NPF6 '//TRIM(DIRMNAME)//'.NPF6'
WRITE(IU,'(A)') ' OC6 '//TRIM(DIRMNAME)//'.OC6'
IF(ISS.EQ.1)WRITE(IU,'(A)') ' STO6 '//TRIM(DIRMNAME)//'.STO6'
IF(TOPICS(TCHD)%IACT_MODEL.NE.0) WRITE(IU,'(A)') ' CHD6 '//TRIM(DIRMNAME)//'.CHD6'
IF(TOPICS(TWEL)%IACT_MODEL.NE.0) WRITE(IU,'(A)') ' WEL6 '//TRIM(DIRMNAME)//'.WEL6'
IF(TOPICS(TDRN)%IACT_MODEL.NE.0) WRITE(IU,'(A)') ' DRN6 '//TRIM(DIRMNAME)//'.DRN6'
IF(TOPICS(TRCH)%IACT_MODEL.NE.0) WRITE(IU,'(A)') ' RCH6 '//TRIM(DIRMNAME)//'.RCH6'
IF(TOPICS(TRIV)%IACT_MODEL.NE.0) WRITE(IU,'(A)') ' RIV6 '//TRIM(DIRMNAME)//'.RIV6'
IF(TOPICS(TISG)%IACT_MODEL.NE.0) WRITE(IU,'(A)') ' RIV6 '//TRIM(DIRMNAME)//'.RIV6'
IF(TOPICS(TGHB)%IACT_MODEL.NE.0) WRITE(IU,'(A)') ' GHB6 '//TRIM(DIRMNAME)//'.GHB6'
IF(TOPICS(THFB)%IACT_MODEL.NE.0) WRITE(IU,'(A)') ' HFB6 '//TRIM(DIRMNAME)//'.HFB6'
WRITE(IU,'(A)') 'END PACKAGES'
CLOSE(IU)
ELSE
DIRMNAME='.\'//TRIM(DIRMNAME)
!## write *.nam file(s)
N1=1; N2=1
IF(PBMAN%IPESTP.EQ.1)THEN
N1=-PBMAN%NLINESEARCH; N2=SIZE(PEST%PARAM)
ELSEIF(PBMAN%IIES.EQ.1)THEN
N1=1; N2=PEST%NREALS
ENDIF
DO I=N1,N2
!## skip zero
IF(I.EQ.0)CYCLE
IU=UTL_GETUNIT()
IF(PBMAN%IPESTP+PBMAN%IIES.EQ.0)THEN
CALL OSD_OPEN(IU,FILE=TRIM(FNAME),STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED')
ELSEIF(PBMAN%IPESTP.EQ.1)THEN
IF(I.GT.0)THEN
IF(PEST%PARAM(I)%PACT.EQ.0.OR.PEST%PARAM(I)%PIGROUP.LT.0)CYCLE
NAME=FNAME(:INDEX(FNAME,'.',.TRUE.)-1)//'_P#'//TRIM(ITOS(I))//'.NAM'
ELSE
NAME=FNAME(:INDEX(FNAME,'.',.TRUE.)-1)//'_L#'//TRIM(ITOS(ABS(I)))//'.NAM'
ENDIF
CALL OSD_OPEN(IU,FILE=TRIM(NAME),STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED')
ELSEIF(PBMAN%IIES.EQ.1)THEN
NAME=FNAME(:INDEX(FNAME,'.',.TRUE.)-1)//'_R#'//TRIM(ITOS(I))//'.NAM'
CALL OSD_OPEN(IU,FILE=TRIM(NAME),STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED')
ENDIF
IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# Nam File Generated by '//TRIM(UTL_IMODVERSION())
IF(PBMAN%IPESTP+PBMAN%IIES.EQ.0)THEN
WRITE(IU,'(A)') 'LIST 10 '//CHAR(39)//'.\'//TRIM(MNAME)//'.LIST'//CHAR(39)
WRITE(IU,'(A)') 'MET 11 '//CHAR(39)//TRIM(DIRMNAME)//'.MET7'//CHAR(39)
ELSEIF(PBMAN%IPESTP.EQ.1)THEN
IF(I.GT.0)THEN
WRITE(IU,'(A)') 'LIST 10 '//CHAR(39)//'.\'//TRIM(MNAME)//'_P#'//TRIM(ITOS(I))//'.LIST'//CHAR(39)
WRITE(IU,'(A)') 'MET 11 '//CHAR(39)//TRIM(DIRMNAME)//'_P#'//TRIM(ITOS(I))//'.MET7'//CHAR(39)
ELSE
WRITE(IU,'(A)') 'LIST 10 '//CHAR(39)//'.\'//TRIM(MNAME)//'_L#'//TRIM(ITOS(ABS(I)))//'.LIST'//CHAR(39)
WRITE(IU,'(A)') 'MET 11 '//CHAR(39)//TRIM(DIRMNAME)//'_L#'//TRIM(ITOS(ABS(I)))//'.MET7'//CHAR(39)
ENDIF
ELSEIF(PBMAN%IIES.EQ.1)THEN
WRITE(IU,'(A)') 'LIST 10 '//CHAR(39)//'.\'//TRIM(MNAME)//'_R#'//TRIM(ITOS(I))//'.LIST'//CHAR(39)
WRITE(IU,'(A)') 'MET 11 '//CHAR(39)//TRIM(DIRMNAME)//'_R#'//TRIM(ITOS(I))//'.MET7'//CHAR(39)
ENDIF
WRITE(IU,'(A)') 'BAS6 12 '//CHAR(39)//TRIM(DIRMNAME)//'.BAS6'//CHAR(39)
WRITE(IU,'(A)') 'DIS 13 '//CHAR(39)//TRIM(DIRMNAME)//'.DIS6'//CHAR(39)
IF(LBCF) WRITE(IU,'(A)') 'BCF6 14 '//CHAR(39)//TRIM(DIRMNAME)//'.BCF6'//CHAR(39)
IF(LLPF)THEN
IF(PBMAN%IIES.EQ.0)THEN
WRITE(IU,'(A)') 'LPF 14 '//CHAR(39)//TRIM(DIRMNAME)//'.LPF7'//CHAR(39)
ELSE
WRITE(IU,'(A)') 'LPF 14 '//CHAR(39)//TRIM(DIRMNAME)//'_R#'//TRIM(ITOS(I))//'.LPF7'//CHAR(39)
ENDIF
ENDIF
IF(TOPICS(TPCG)%IACT_MODEL.EQ.1) WRITE(IU,'(A)') 'PCG 15 '//CHAR(39)//TRIM(DIRMNAME)//'.PCG7'//CHAR(39)
IF(LPKS) WRITE(IU,'(A)') 'PKS 15 '//CHAR(39)//TRIM(DIRMNAME)//'.PKS'//CHAR(39)
IF(PBMAN%IPESTP.EQ.1)THEN
IF(I.GT.0)THEN
WRITE(IU,'(A)') 'OC 16 '//CHAR(39)//TRIM(DIRMNAME)//'_P.OC'//CHAR(39)
ELSE
WRITE(IU,'(A)') 'OC 16 '//CHAR(39)//TRIM(DIRMNAME)//'_L.OC'//CHAR(39)
ENDIF
ELSE
WRITE(IU,'(A)') 'OC 16 '//CHAR(39)//TRIM(DIRMNAME)//'.OC'//CHAR(39)
ENDIF
IF(TOPICS(TRCH)%IACT_MODEL.EQ.1) WRITE(IU,'(A)') 'RCH 17 '//CHAR(39)//TRIM(DIRMNAME)//'.RCH7'//CHAR(39)
IF(TOPICS(TEVT)%IACT_MODEL.EQ.1) WRITE(IU,'(A)') 'EVT 18 '//CHAR(39)//TRIM(DIRMNAME)//'.EVT7'//CHAR(39)
IF(TOPICS(TDRN)%IACT_MODEL.EQ.1.OR.TOPICS(TOLF)%IACT_MODEL.EQ.1) WRITE(IU,'(A)') 'DRN 19 '//CHAR(39)//TRIM(DIRMNAME)//'.DRN7'//CHAR(39)
IF(TOPICS(TRIV)%IACT_MODEL.EQ.1.OR.TOPICS(TISG)%IACT_MODEL.EQ.1) WRITE(IU,'(A)') 'RIV 20 '//CHAR(39)//TRIM(DIRMNAME)//'.RIV7'//CHAR(39)
IF(TOPICS(TGHB)%IACT_MODEL.EQ.1) WRITE(IU,'(A)') 'GHB 21 '//CHAR(39)//TRIM(DIRMNAME)//'.GHB7'//CHAR(39)
IF(TOPICS(TCHD)%IACT_MODEL.EQ.1) WRITE(IU,'(A)') 'CHD 22 '//CHAR(39)//TRIM(DIRMNAME)//'.CHD7'//CHAR(39)
IF(TOPICS(TWEL)%IACT_MODEL.EQ.1) WRITE(IU,'(A)') 'WEL 23 '//CHAR(39)//TRIM(DIRMNAME)//'.WEL7'//CHAR(39)
IF(TOPICS(THFB)%IACT_MODEL.EQ.1) WRITE(IU,'(A)') 'HFB6 24 '//CHAR(39)//TRIM(DIRMNAME)//'.HFB7'//CHAR(39)
IF(TOPICS(TSFR)%IACT_MODEL.EQ.1) WRITE(IU,'(A)') 'SFR 25 '//CHAR(39)//TRIM(DIRMNAME)//'.SFR7'//CHAR(39)
IF(TOPICS(TFHB)%IACT_MODEL.EQ.1)THEN; WRITE(IU,'(A)') 'FHB 26 '//CHAR(39)//TRIM(DIRMNAME)//'.FHB7'//CHAR(39); IFHBUN=26; ENDIF
IF(TOPICS(TLAK)%IACT_MODEL.EQ.1) WRITE(IU,'(A)') 'LAK 27 '//CHAR(39)//TRIM(DIRMNAME)//'.LAK7'//CHAR(39)
IF(TOPICS(TUZF)%IACT_MODEL.EQ.1) WRITE(IU,'(A)') 'UZF 28 '//CHAR(39)//TRIM(DIRMNAME)//'.UZF7'//CHAR(39)
IF(TOPICS(TMNW)%IACT_MODEL.EQ.1) WRITE(IU,'(A)') 'MNW2 29 '//CHAR(39)//TRIM(DIRMNAME)//'.MNW7'//CHAR(39)
IF(TOPICS(TANI)%IACT_MODEL.EQ.1) WRITE(IU,'(A)') 'ANI 30 '//CHAR(39)//TRIM(DIRMNAME)//'.ANI1'//CHAR(39)
IF(TOPICS(TCAP)%IACT_MODEL.EQ.1) WRITE(IU,'(A)') 'DXC 31 '//CHAR(39)//TRIM(DIRMNAME)//'.DXC'//CHAR(39)
IF(TOPICS(TCON)%IACT_MODEL.EQ.1) WRITE(IU,'(A)') 'VDF 32 '//CHAR(39)//TRIM(DIRMNAME)//'.VDF1'//CHAR(39)
WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',IHEDUN,' '//CHAR(39)//'HEAD'//CHAR(39)
WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',IBCFCB,' '//CHAR(39)//'BDGSTO BDGBND BDGFRF BDGFFF BDGFLF'//CHAR(39)
IF(TOPICS(TRCH)%IACT_MODEL.EQ.1)WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',IRCHCB,' '//CHAR(39)//'BDGRCH'//CHAR(39)
IF(TOPICS(TEVT)%IACT_MODEL.EQ.1)WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',IEVTCB,' '//CHAR(39)//'BDGEVT'//CHAR(39)
IF(TOPICS(TDRN)%IACT_MODEL.EQ.1.OR.TOPICS(TOLF)%IACT_MODEL.EQ.1)WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',IDRNCB,' '//CHAR(39)//'BDGDRN'//CHAR(39)
IF(TOPICS(TRIV)%IACT_MODEL.EQ.1.OR.TOPICS(TISG)%IACT_MODEL.EQ.1)WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',IRIVCB,' '//CHAR(39)//'BDGRIV'//CHAR(39)
IF(TOPICS(TGHB)%IACT_MODEL.EQ.1)WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',IGHBCB,' '//CHAR(39)//'BDGGHB'//CHAR(39)
IF(TOPICS(TCHD)%IACT_MODEL.EQ.1)WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',ICHDCB,' '//CHAR(39)//'BDGCHD'//CHAR(39)
IF(TOPICS(TWEL)%IACT_MODEL.EQ.1)WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',IWELCB,' '//CHAR(39)//'BDGWEL'//CHAR(39)
IF(TOPICS(TSFR)%IACT_MODEL.EQ.1)THEN
WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',ISFRCB,' '//CHAR(39)//'BDGSFR'//CHAR(39)
IF(ISFRCB2.GT.0)WRITE(IU,'(A,I3,A)') 'DATA ',ISFRCB2,' '//CHAR(39)//'.\'//TRIM(MNAME)//'_FSFR.TXT'//CHAR(39)
ENDIF
IF(TOPICS(TFHB)%IACT_MODEL.EQ.1)WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',IFHBCB ,' '//CHAR(39)//'BDGFHB'//CHAR(39)
IF(TOPICS(TLAK)%IACT_MODEL.EQ.1)WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',ILAKCB ,' '//CHAR(39)//'BDGLAK'//CHAR(39)
IF(TOPICS(TUZF)%IACT_MODEL.EQ.1)WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',IUZFCB1,' '//CHAR(39)//'UZFINF BDGGRC BDGGET UZFRUN UZFET UZFSFR'//CHAR(39)
IF(TOPICS(TMNW)%IACT_MODEL.EQ.1)WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',IWL2CB ,' '//CHAR(39)//'BDGMNW'//CHAR(39)
! IF(TOPICS(TUZF)%IACT_MODEL.EQ.1)THEN
! DO J=1,PBMAN%NLOGLOC
! WRITE(IU,'(A,I3,A)') 'DATA ',99+J ,' '//CHAR(39)//'UZF_LOG_ROW'//TRIM(ITOS(PBMAN%ILOC(J,1)))//'-COL'//TRIM(ITOS(PBMAN%ILOC(J,2)))//'.TXT'//CHAR(39)
! ENDDO
! ENDIF
ENDDO
ENDIF
CLOSE(IU)
!## result folder including the modelname
DIRMNAME=TRIM(DIR)//'\MODELINPUT\'//TRIM(MNAME)
DIR =TRIM(DIR)//'\MODELINPUT'
!## echo used files from the prj-file
IPRT=UTL_GETUNIT(); CALL OSD_OPEN(IPRT,FILE=TRIM(DIR)//'\USED_FILES.TXT',STATUS='UNKNOWN',ACTION='WRITE')
PMANAGER_SAVEMF2005_NAM=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_NAM
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_SIM(IBATCH)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IBATCH
REAL(KIND=DP_KIND) :: X1,Y1,X2,Y2
!## reads idf for model dimensions
!## creates IDF objects to store parameter values
PMANAGER_SAVEMF2005_SIM=.FALSE.
!## read idf for dimensions
CALL IDFNULLIFY(PRJIDF); IFULL=0
IF(.NOT.PMANAGER_INIT_SIMAREA(PRJIDF,IBATCH))RETURN
IF(PBMAN%IWINDOW.EQ.1)THEN
IF(SUBMODEL(5).NE.0.0D0)THEN
PRJIDF%DX=SUBMODEL(5)
PRJIDF%DY=SUBMODEL(5)
CALL UTL_IDFSNAPTOGRID_LLC(PRJIDF%XMIN,PRJIDF%XMAX,PRJIDF%YMIN,PRJIDF%YMAX,PRJIDF%DX,PRJIDF%DY,PRJIDF%NCOL,PRJIDF%NROW,LLC=.TRUE.)
ENDIF
ENDIF
IF(ISUBMODEL.EQ.1)THEN
X1=SUBMODEL(1); Y1=SUBMODEL(2); X2=SUBMODEL(3); Y2=SUBMODEL(4)
!## include buffer to simulation window
SUBMODEL(1)=SUBMODEL(1)-SUBMODEL(6); SUBMODEL(2)=SUBMODEL(2)-SUBMODEL(6)
SUBMODEL(3)=SUBMODEL(3)+SUBMODEL(6); SUBMODEL(4)=SUBMODEL(4)+SUBMODEL(6)
!## make sure size of model (including buffer) does not exceed total model domain
SUBMODEL(1)=MAX(SUBMODEL(1),PRJIDF%XMIN); SUBMODEL(2)=MAX(SUBMODEL(2),PRJIDF%YMIN)
SUBMODEL(3)=MIN(SUBMODEL(3),PRJIDF%XMAX); SUBMODEL(4)=MIN(SUBMODEL(4),PRJIDF%YMAX)
!## see what boundary (submodel?)
IF(SUBMODEL(1).GT.PRJIDF%XMIN)IFULL(1)=1; IF(SUBMODEL(2).GT.PRJIDF%YMIN)IFULL(2)=1
IF(SUBMODEL(3).LT.PRJIDF%XMAX)IFULL(3)=1; IF(SUBMODEL(4).LT.PRJIDF%YMAX)IFULL(4)=1
!## compute dimensions of submodel
CALL UTL_IDFSNAPTOGRID_LLC(SUBMODEL(1),SUBMODEL(3),SUBMODEL(2),SUBMODEL(4),SUBMODEL(5),SUBMODEL(5),PRJIDF%NCOL,PRJIDF%NROW,LLC=.TRUE.)
IF(PRJIDF%NCOL.LE.0.OR.PRJIDF%NROW.LE.0)THEN
IF(IBATCH.EQ.0)WRITE(*,'(A)') 'Model dimensions are outside maximal modeling domain'
IF(IBATCH.EQ.1)CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Model dimensions are outside maximal modeling domain','Error')
RETURN
ENDIF
PRJIDF%XMIN=SUBMODEL(1); PRJIDF%YMIN=SUBMODEL(2); PRJIDF%XMAX=SUBMODEL(3); PRJIDF%YMAX=SUBMODEL(4)
PRJIDF%DX=SUBMODEL(5); PRJIDF%DY=SUBMODEL(5);
IF(SUBMODEL(7).EQ.0.0D0)THEN
PRJIDF%IEQ=0
ELSE
!## create non-equidistantial network
IF(.NOT.PMANAGER_SAVEMF2005_COARSEGRID(PRJIDF,X1,Y1,X2,Y2,SUBMODEL(7)))RETURN
ENDIF
ENDIF
IF(.NOT.ASSOCIATED(PRJIDF%X))THEN
IF(.NOT.IDFALLOCATEX(PRJIDF))RETURN; PRJIDF%X=0.0D0
ENDIF
!## fill sx/sy variable in idf
IF(.NOT.IDFFILLSXSY(PRJIDF))RETURN
PMANAGER_SAVEMF2005_SIM=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_SIM
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_SIM_ALLOC(ISS)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ISS
INTEGER :: ILAY
ALLOCATE(BND(PRJNLAY)); DO ILAY=1,SIZE(BND); CALL IDFNULLIFY(BND(ILAY)); ENDDO
ALLOCATE(SHD(PRJNLAY)); DO ILAY=1,SIZE(SHD); CALL IDFNULLIFY(SHD(ILAY)); ENDDO
ALLOCATE(TOP(PRJNLAY)); DO ILAY=1,SIZE(TOP); CALL IDFNULLIFY(TOP(ILAY)); ENDDO
ALLOCATE(BOT(PRJNLAY)); DO ILAY=1,SIZE(BOT); CALL IDFNULLIFY(BOT(ILAY)); ENDDO
ALLOCATE(KDW(PRJNLAY)); DO ILAY=1,SIZE(KDW); CALL IDFNULLIFY(KDW(ILAY)); ENDDO
ALLOCATE(VCW(PRJNLAY-1)); DO ILAY=1,SIZE(VCW); CALL IDFNULLIFY(VCW(ILAY)); ENDDO
ALLOCATE(KHV(PRJNLAY)); DO ILAY=1,SIZE(KHV); CALL IDFNULLIFY(KHV(ILAY)); ENDDO
IF(ISS.EQ.1)THEN
ALLOCATE(STO(PRJNLAY)); DO ILAY=1,SIZE(STO); CALL IDFNULLIFY(STO(ILAY)); ENDDO
ALLOCATE(SPY(PRJNLAY)); DO ILAY=1,SIZE(SPY); CALL IDFNULLIFY(SPY(ILAY)); ENDDO
ENDIF
IF(LLPF.OR.LNPF)THEN
ALLOCATE(KVV(PRJNLAY-1)); DO ILAY=1,SIZE(KVV); CALL IDFNULLIFY(KVV(ILAY)); ENDDO
ALLOCATE(KVA(PRJNLAY)); DO ILAY=1,SIZE(KVA); CALL IDFNULLIFY(KVA(ILAY)); ENDDO
ENDIF
IF(TOPICS(TANI)%DEFINED)THEN
ALLOCATE(ANA(PRJNLAY)); DO ILAY=1,SIZE(ANA); CALL IDFNULLIFY(ANA(ILAY)); ENDDO
ALLOCATE(ANF(PRJNLAY)); DO ILAY=1,SIZE(ANF); CALL IDFNULLIFY(ANF(ILAY)); ENDDO
ENDIF
IF(TOPICS(TLAK)%DEFINED)THEN
ALLOCATE(LAK(10)); DO ILAY=1,SIZE(LAK); CALL IDFNULLIFY(LAK(ILAY)); ENDDO
ALLOCATE(LBD(PRJNLAY)); DO ILAY=1,SIZE(LBD); CALL IDFNULLIFY(LBD(ILAY)); ENDDO
ALLOCATE(LCD(PRJNLAY)); DO ILAY=1,SIZE(LCD); CALL IDFNULLIFY(LCD(ILAY)); ENDDO
ENDIF
IF(TOPICS(TCON)%DEFINED)THEN
ALLOCATE(CON(PRJNLAY)); DO ILAY=1,SIZE(CON); CALL IDFNULLIFY(CON(ILAY)); ENDDO
ENDIF
!IF(TOPICS(TSFT)%DEFINED)THEN
ALLOCATE(SFT(2)); DO ILAY=1,SIZE(SFT); CALL IDFNULLIFY(SFT(ILAY)); ENDDO
! ENDIF
DO ILAY=1,SIZE(TOP); CALL IDFCOPY(PRJIDF,TOP(ILAY)); ENDDO
DO ILAY=1,SIZE(BOT); CALL IDFCOPY(PRJIDF,BOT(ILAY)); ENDDO
DO ILAY=1,SIZE(KDW); CALL IDFCOPY(PRJIDF,KDW(ILAY)); ENDDO
DO ILAY=1,SIZE(VCW); CALL IDFCOPY(PRJIDF,VCW(ILAY)); ENDDO
DO ILAY=1,SIZE(KHV); CALL IDFCOPY(PRJIDF,KHV(ILAY)); ENDDO
IF(LLPF.OR.LNPF)THEN
DO ILAY=1,SIZE(KVV); CALL IDFCOPY(PRJIDF,KVV(ILAY)); ENDDO
DO ILAY=1,SIZE(KVA); CALL IDFCOPY(PRJIDF,KVA(ILAY)); ENDDO
ENDIF
IF(ISS.EQ.1)THEN
DO ILAY=1,SIZE(STO); CALL IDFCOPY(PRJIDF,STO(ILAY)); ENDDO
DO ILAY=1,SIZE(SPY); CALL IDFCOPY(PRJIDF,SPY(ILAY)); ENDDO
ENDIF
IF(TOPICS(TANI)%DEFINED)THEN
DO ILAY=1,SIZE(ANF); CALL IDFCOPY(PRJIDF,ANF(ILAY)); ENDDO
DO ILAY=1,SIZE(ANA); CALL IDFCOPY(PRJIDF,ANA(ILAY)); ENDDO
ENDIF
IF(TOPICS(TLAK)%DEFINED)THEN
DO ILAY=1,SIZE(LBD); CALL IDFCOPY(PRJIDF,LBD(ILAY)); ENDDO
DO ILAY=1,SIZE(LCD); CALL IDFCOPY(PRJIDF,LCD(ILAY)); ENDDO
ENDIF
IF(TOPICS(TSFT)%DEFINED)THEN
DO ILAY=1,SIZE(SFT); CALL IDFCOPY(PRJIDF,SFT(ILAY)); ENDDO
ENDIF
IF(TOPICS(TCON)%DEFINED)THEN
DO ILAY=1,SIZE(CON); CALL IDFCOPY(PRJIDF,CON(ILAY)); ENDDO
ENDIF
PMANAGER_SAVEMF2005_SIM_ALLOC=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_SIM_ALLOC
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_PST_READWRITE(DIR,DIRMNAME,IBATCH,ISS)
!####====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME
INTEGER,INTENT(IN) :: IBATCH,ISS
INTEGER :: I,J,N,N1,N2,IU
CHARACTER(LEN=256) :: CFNAME
PMANAGER_SAVEMF2005_PST_READWRITE=.TRUE.
IF(.NOT.TOPICS(TPST)%DEFINED.AND. &
.NOT.TOPICS(TIES)%DEFINED)RETURN
!## overrule is by imod batch
IF(IBATCH.EQ.1.AND.PBMAN%IPEST+PBMAN%IPESTP+PBMAN%IIES.EQ.0)RETURN
PMANAGER_SAVEMF2005_PST_READWRITE=.FALSE.
N=0; IF(ASSOCIATED(PEST%MEASURES))THEN; N=SIZE(PEST%MEASURES); ENDIF
IF(N.EQ.0.AND.PEST%PE_MXITER.GT.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You need to specify measurements to use the PST module.','Error'); RETURN
ENDIF
IF(IBATCH.EQ.0)CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIRMNAME)//'.PST1'//'...')
IF(IBATCH.EQ.1)WRITE(*,'(/1X,A)') 'Writing '//TRIM(DIRMNAME)//'.PST1'//'...'
N1=1; N2=1; J=0; IF(PBMAN%IPESTP.EQ.1)THEN; N1=-PBMAN%NLINESEARCH; N2=SIZE(PEST%PARAM); ENDIF; CFNAME=''
DO I=N1,N2
!## skip zero
IF(I.EQ.0)CYCLE
IU=UTL_GETUNIT()
IF(PBMAN%IPESTP.EQ.0)THEN
CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.PST1',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED')
ELSE
IF(I.GT.0)THEN
IF(PEST%PARAM(I)%PACT.EQ.0.OR.PEST%PARAM(I)%PIGROUP.LT.0)CYCLE
IF(J.EQ.0)THEN
CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'_P#'//TRIM(ITOS(I))//'.PST1',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED')
CFNAME=TRIM(DIRMNAME)//'_P#'//TRIM(ITOS(I))//'.PST1'
ELSE
CALL IOSCOPYFILE(CFNAME,TRIM(DIRMNAME)//'_P#'//TRIM(ITOS(I))//'.PST1')
ENDIF
ELSE
IF(J.EQ.0)THEN
CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'_L#'//TRIM(ITOS(ABS(I)))//'.PST1',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED')
CFNAME=TRIM(DIRMNAME)//'_L#'//TRIM(ITOS(ABS(I)))//'.PST1'
ELSE
CALL IOSCOPYFILE(CFNAME,TRIM(DIRMNAME)//'_L#'//TRIM(ITOS(ABS(I)))//'.PST1')
ENDIF
ENDIF
ENDIF
IF(J.EQ.0)THEN
IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# PST1 File Generated by '//TRIM(UTL_IMODVERSION())
!## pst module is exception
IF(.NOT.PMANAGER_SAVEPST(IU,2,DIR,ISS,-1))RETURN
CLOSE(IU)
ENDIF
J=1
ENDDO
PMANAGER_SAVEMF2005_PST_READWRITE=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_PST_READWRITE
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_IES_READWRITE(DIRMNAME,IBATCH)
!####====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIRMNAME
INTEGER,INTENT(IN) :: IBATCH
INTEGER :: I,J,K,N,IU,JU,IOS,ILAY
PMANAGER_SAVEMF2005_IES_READWRITE=.TRUE.
IF(.NOT.TOPICS(TIES)%DEFINED)RETURN
!## overrule is by imod batch
IF(IBATCH.EQ.1.AND.PBMAN%IIES.EQ.0)RETURN
PMANAGER_SAVEMF2005_IES_READWRITE=.FALSE.
N=0; IF(ASSOCIATED(PEST%MEASURES))THEN; N=SIZE(PEST%MEASURES); ENDIF
IF(N.EQ.0.OR.PEST%PE_MXITER.LE.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You need to specify measurements to use the IES module.','Error'); RETURN
ENDIF
!## change lpf (copy) for now into an #.lpf
DO I=1,PEST%NREALS
IU=UTL_GETUNIT()
CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.LPF7' ,STATUS='OLD' ,ACTION='READ' ,FORM='FORMATTED')
JU=UTL_GETUNIT()
CALL OSD_OPEN(JU,FILE=TRIM(DIRMNAME)//'_R#'//TRIM(ITOS(I))//'.LPF7',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED')
DO
READ(IU,'(A256)',IOSTAT=IOS) LINE; IF(IOS.NE.0)EXIT
DO J=1,SIZE(PEST%PARAM)
DO K=1,SIZE(PEST%PARAM(J)%ILS)
ILAY=PEST%PARAM(J)%ILS(K)
SELECT CASE (PEST%PARAM(J)%PPARAM)
CASE ('KH')
LINE=UTL_SUBST(LINE,'HK_L'//TRIM(ITOS(ILAY))//'.ARR','HK_L'//TRIM(ITOS(ILAY))//'_R#'//TRIM(ITOS(I))//'.ARR')
END SELECT
ENDDO
ENDDO
WRITE(JU,'(A)') TRIM(LINE)
ENDDO
CLOSE(IU); CLOSE(JU)
ENDDO
PMANAGER_SAVEMF2005_IES_READWRITE=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_IES_READWRITE
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_BAS_READ(IPRT)
!####====================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IPRT
INTEGER :: ITOPIC,SCL_D,SCL_U,ILAY
INTEGER,DIMENSION(:,:),ALLOCATABLE :: ISIZE
PMANAGER_SAVEMF2005_BAS_READ=.FALSE.
ALLOCATE(FNAMES(PRJNLAY),PRJILIST(1),ISIZE(4,PRJNLAY))
!## bnd settings
ITOPIC=TBND; SCL_D=0; SCL_U=1; PRJILIST=ITOPIC; IF(PMANAGER_GETFNAMES(1,PRJNLAY,0,1,0).LE.0)RETURN
DO ILAY=1,PRJNLAY
WRITE(6,'(A)') '+Reading BND-files ('//TRIM(RTOS(REAL(100*ILAY,8)/REAL(PRJNLAY,8),'F',2))//'%) '
CALL IDFCOPY(PRJIDF,BND(ILAY))
IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(BND(ILAY),ITOPIC,ILAY,SCL_D,SCL_U,0,IPRT,ISIZE=ISIZE(:,ILAY)))RETURN
ENDDO
!## adjust boundary for submodel()
CALL PMANAGER_SAVEMF2005_BND(ISIZE)
!## shd settings
ITOPIC=TSHD; SCL_D=PBMAN%INT(TSHD); SCL_U=2; PRJILIST=ITOPIC; IF(PMANAGER_GETFNAMES(1,PRJNLAY,0,1,0).LE.0)RETURN
DO ILAY=1,PRJNLAY
WRITE(6,'(A)') '+Reading SHD-files ('//TRIM(RTOS(REAL(100*ILAY,8)/REAL(PRJNLAY,8),'F',2))//'%) '
CALL IDFCOPY(PRJIDF,SHD(ILAY))
IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(SHD(ILAY),ITOPIC,ILAY,SCL_D,SCL_U,0,IPRT))RETURN
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,SHD(ILAY),0,ITOPIC)
ENDDO
DEALLOCATE(FNAMES,PRJILIST,ISIZE)
PMANAGER_SAVEMF2005_BAS_READ=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_BAS_READ
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_BAS_SAVE(DIR,DIRMNAME,IBATCH)
!####====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME
INTEGER,INTENT(IN) :: IBATCH
INTEGER :: IU,ILAY,IFBND
PMANAGER_SAVEMF2005_BAS_SAVE=.TRUE.; IF(PBMAN%IFORMAT.EQ.3)RETURN
PMANAGER_SAVEMF2005_BAS_SAVE=.FALSE.
IF(IBATCH.EQ.0)CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIRMNAME)//'.BAS6'//'...')
IF(IBATCH.EQ.1)WRITE(*,'(/1X,A)') 'Writing '//TRIM(DIRMNAME)//'.BAS6'//'...'
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.BAS6',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# BAS6 File Generated by '//TRIM(UTL_IMODVERSION())
LINE='FREE'
IF(PCG%IQERROR.EQ.0)THEN
WRITE(IU,'(A)') 'FREE'
ELSE
WRITE(IU,'(A,G12.5)') 'FREE STOPERROR ',PCG%QERROR
ENDIF
IFBND=0
DO ILAY=1,PRJNLAY
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\BAS6\IBOUND_L'//TRIM(ITOS(ILAY))//'.ARR', &
BND(ILAY),1,IU,ILAY,IFBND))RETURN
ENDDO
WRITE(IU,'(A)') TRIM(RTOS(HNOFLOW,'G',7))
IFBND=1
!## include a minor modification to ensure a save in ARR files
IF(PBMAN%IPESTP.EQ.1)IFBND=-1
DO ILAY=1,PRJNLAY
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\BAS6\STRT_L'//TRIM(ITOS(ILAY))//'.ARR', &
SHD(ILAY),0,IU,ILAY,IFBND))RETURN
ENDDO
CLOSE(IU)
PMANAGER_SAVEMF2005_BAS_SAVE=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_BAS_SAVE
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_IC_SAVE(DIR,DIRMNAME,IBATCH)
!####====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME
INTEGER,INTENT(IN) :: IBATCH
INTEGER :: IU,ILAY,JLAY,IFBND
PMANAGER_SAVEMF2005_IC_SAVE=.TRUE.; IF(PBMAN%IFORMAT.EQ.2)RETURN
PMANAGER_SAVEMF2005_IC_SAVE=.FALSE.
IF(IBATCH.EQ.0)CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIRMNAME)//'.IC6'//'...')
IF(IBATCH.EQ.1)WRITE(*,'(/1X,A)') 'Writing '//TRIM(DIRMNAME)//'.IC6'//'...'
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.IC6',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# IC6 File Generated by '//TRIM(UTL_IMODVERSION())
WRITE(IU,'(/A/)') '#General Options'
WRITE(IU,'(A)') 'BEGIN OPTIONS'
WRITE(IU,'(A)') 'END OPTIONS'
WRITE(IU,'(/A/)') '#Initial Head Data'
WRITE(IU,'(A)') 'BEGIN GRIDDATA'
WRITE(IU,'(A)') ' STRT LAYERED'
JLAY=0; DO ILAY=1,SIZE(PBMAN%ILAY)
IF(PBMAN%ILAY(ILAY).EQ.0)CYCLE
JLAY=JLAY+1
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\IC6\IC_L'//TRIM(ITOS(JLAY))//'.ARR', &
SHD(ILAY),0,IU,ILAY,IFBND))RETURN
ENDDO
WRITE(IU,'(A)') 'END GRIDDATA'
CLOSE(IU)
PMANAGER_SAVEMF2005_IC_SAVE=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_IC_SAVE
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_DIS_READ(LTB,IPRT)
!####====================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IPRT
LOGICAL,INTENT(OUT) :: LTB
INTEGER :: ILAY,IINV,SCL_D,SCL_U,ITOPIC
LOGICAL :: LEX
PMANAGER_SAVEMF2005_DIS_READ=.FALSE.
ALLOCATE(FNAMES(1),PRJILIST(1))
!## check top/bottom
LTB=.TRUE.; IINV=0
!## top settings
SCL_D=PBMAN%INT(TTOP); SCL_U=2
DO ILAY=1,PRJNLAY
WRITE(6,'(A)') '+Reading TOP/BOT-files ('//TRIM(RTOS(REAL(100*ILAY,8)/REAL(PRJNLAY,8),'F',2))//'%) '
!## top data
ITOPIC=TTOP; LEX=.FALSE.
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))THEN
PRJILIST=ITOPIC; IF(PMANAGER_GETFNAMES(ILAY,ILAY,0,1,0).LE.0)RETURN
IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(TOP(ILAY),ITOPIC,1,SCL_D,SCL_U,IINV,IPRT))RETURN
LEX=.TRUE.
ENDIF
ENDIF
IF(.NOT.LEX)THEN; TOP(ILAY)%X=0.0D0; LTB=.FALSE.; ENDIF
!## bot data
ITOPIC=TBOT; LEX=.FALSE.
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))THEN
PRJILIST=ITOPIC; IF(PMANAGER_GETFNAMES(ILAY,ILAY,0,1,0).LE.0)RETURN
IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(BOT(ILAY),ITOPIC,1,SCL_D,SCL_U,IINV,IPRT))RETURN
LEX=.TRUE.
ENDIF
ENDIF
IF(.NOT.LEX)THEN; BOT(ILAY)%X=0.0D0; LTB=.FALSE.; ENDIF
ENDDO
DEALLOCATE(FNAMES,PRJILIST)
PMANAGER_SAVEMF2005_DIS_READ=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_DIS_READ
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_DIS_SAVE(DIR,DIRMNAME,IBATCH)
!####====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME
INTEGER,INTENT(IN) :: IBATCH
INTEGER :: IU,ILAY,JLAY,KPER,KKPER,ITOPIC,ICOL,IROW,N,I,LHMS,IFBND
INTEGER,ALLOCATABLE,DIMENSION(:) :: LCBD
REAL(KIND=DP_KIND) :: T
CHARACTER(LEN=52) :: CLINE
PMANAGER_SAVEMF2005_DIS_SAVE=.FALSE.
IF(IBATCH.EQ.0)CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIRMNAME)//'.DIS6'//'...')
IF(IBATCH.EQ.1)WRITE(*,'(/1X,A)') 'Writing '//TRIM(DIRMNAME)//'.DIS6'//'...'
!## construct dis-file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.DIS6',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# DIS6 File Generated by '//TRIM(UTL_IMODVERSION())
IF(PBMAN%IFORMAT.EQ.2)THEN
LINE=TRIM(ITOS(PRJNLAY))//','//TRIM(ITOS(PRJIDF%NROW))//','//TRIM(ITOS(PRJIDF%NCOL))//','//TRIM(ITOS(PRJNPER))//',4,2 TBCHECK'
WRITE(IU,'(A)') TRIM(LINE)
ALLOCATE(LCBD(PRJNLAY))
!## laycbd code
LINE=''
DO ILAY=1,PRJNLAY
IF(ILAY.LT.PRJNLAY)THEN
!## quasi-3d scheme
IF(LQBD)THEN
LCBD(ILAY)=1
!## 3d no quasi confining bed
ELSE
LCBD(ILAY)=0
ENDIF
ELSE
!## lowest layer has never a quasi-confining bed
LCBD(ILAY)=0
ENDIF
ENDDO
WRITE(IU,'(999I2)') LCBD
DEALLOCATE(LCBD)
IF(PRJIDF%IEQ.EQ.0)THEN
WRITE(IU,'(A)') 'CONSTANT '//TRIM(RTOS(PRJIDF%DX,'E',7)); WRITE(IU,'(A)') 'CONSTANT '//TRIM(RTOS(PRJIDF%DY,'E',7))
ELSE
WRITE(IU,'(A)') 'INTERNAL,1.0D0,(FREE),-1'
WRITE(IU,*) (PRJIDF%SX(ICOL)-PRJIDF%SX(ICOL-1),ICOL=1,PRJIDF%NCOL)
WRITE(IU,'(A)') 'INTERNAL,1.0D0,(FREE),-1'
WRITE(IU,*) (PRJIDF%SY(IROW-1)-PRJIDF%SY(IROW),IROW=1,PRJIDF%NROW)
ENDIF
DO ILAY=1,PRJNLAY
ITOPIC=TTOP
!## no check with bnd
IFBND=0
!## quasi-3d scheme add top aquifer modellayer
IF(LQBD.OR.ILAY.EQ.1)THEN
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\DIS6\TOP_L'//TRIM(ITOS(ILAY))//'.ARR', &
TOP(ILAY),0,IU,ILAY,IFBND))RETURN
ENDIF
ITOPIC=TBOT
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\DIS6\BOTM_L'//TRIM(ITOS(ILAY))//'.ARR', &
BOT(ILAY),0,IU,ILAY,IFBND))RETURN
ENDDO
!## time information
LHMS=0; DO KPER=1,PRJNPER
!## set delt.eq.1 otherwise crash in UZF package
IF(SIM(KPER)%DELT.GT.0.0D0)THEN
IF(SIM(KPER)%IHR+SIM(KPER)%IMT+SIM(KPER)%ISC.NE.0)THEN; LHMS=1; EXIT; ENDIF
ENDIF
ENDDO
!## time information
DO KPER=1,PRJNPER
!## set delt.eq.1 otherwise crash in UZF package
IF(SIM(KPER)%DELT.EQ.0.0D0)THEN
LINE=TRIM(RTOS(1.0D0,'G',7))//','// &
TRIM(ITOS(SIM(KPER)%NSTP)) //','// &
TRIM(RTOS(SIM(KPER)%TMULT,'G',7))
ELSE
LINE=TRIM(RTOS(SIM(KPER)%DELT,'G',7))//','// &
TRIM(ITOS(SIM(KPER)%NSTP)) //','// &
TRIM(RTOS(SIM(KPER)%TMULT,'G',7))
ENDIF
IF(SIM(KPER)%DELT.EQ.0.0D0)LINE=TRIM(LINE)//',SS'
IF(SIM(KPER)%DELT.NE.0.0D0)LINE=TRIM(LINE)//',TR'
IF(SIM(KPER)%DELT.EQ.0.0D0)THEN
CLINE='STEADY-STATE'
ELSE
KKPER=KPER; IF(PBMAN%ISAVEENDDATE.EQ.1)KKPER=KKPER+1
IF(LHMS.EQ.0)THEN
WRITE(CLINE,'(I4.4,2I2.2)') SIM(KKPER)%IYR,SIM(KKPER)%IMH,SIM(KKPER)%IDY
ELSE
WRITE(CLINE,'(I4.4,5I2.2)') SIM(KKPER)%IYR,SIM(KKPER)%IMH,SIM(KKPER)%IDY,SIM(KKPER)%IHR,SIM(KKPER)%IMT,SIM(KKPER)%ISC
ENDIF
ENDIF
LINE=TRIM(LINE)//' ['//TRIM(CLINE)//']'
WRITE(IU,'(A)') TRIM(LINE)
ENDDO
ELSE
WRITE(IU,'(/A/)') 'General Options'
WRITE(IU,'(A)') 'BEGIN OPTIONS'
WRITE(IU,'(A)') ' LENGTH_UNITS METERS'
!WRITE(IU,'(A)') ' NOGRB'
WRITE(IU,'(A)') ' XORIGIN '//TRIM(RTOS(PRJIDF%SX(0),'F',3))
WRITE(IU,'(A)') ' YORIGIN '//TRIM(RTOS(PRJIDF%SY(PRJIDF%NROW),'F',3))
WRITE(IU,'(A)') ' ANGROT 0.0'
WRITE(IU,'(A)') 'END OPTIONS'
WRITE(IU,'(/A/)') '#Model Dimensions'
WRITE(IU,'(A)') 'BEGIN DIMENSIONS'
N=0; DO I=1,SIZE(PBMAN%ILAY); IF(PBMAN%ILAY(I).EQ.1)N=N+1; ENDDO
WRITE(IU,'(A)') ' NLAY '//TRIM(ITOS(N))
WRITE(IU,'(A)') ' NROW '//TRIM(ITOS(PRJIDF%NROW))
WRITE(IU,'(A)') ' NCOL '//TRIM(ITOS(PRJIDF%NCOL))
WRITE(IU,'(A)') 'END DIMENSIONS'
WRITE(IU,'(/A/)') '#Cell Sizes'
WRITE(IU,'(A)') 'BEGIN GRIDDATA'
WRITE(IU,'(A)') ' DELR'
IF(PRJIDF%IEQ.EQ.0)THEN
WRITE(IU,'(A)') ' CONSTANT '//TRIM(RTOS(PRJIDF%DX,'E',7))
ELSE
WRITE(IU,'(A)') ' INTERNAL FACTOR 1.0'
WRITE(IU,*) (PRJIDF%SX(ICOL)-PRJIDF%SX(ICOL-1),ICOL=1,PRJIDF%NCOL)
ENDIF
WRITE(IU,'(A)') ' DELC'
IF(PRJIDF%IEQ.EQ.0)THEN
WRITE(IU,'(A)') ' CONSTANT '//TRIM(RTOS(PRJIDF%DY,'E',7))
ELSE
WRITE(IU,'(A)') ' INTERNAL FACTOR 1.0'
WRITE(IU,*) (PRJIDF%SY(IROW-1)-PRJIDF%SY(IROW),IROW=1,PRJIDF%NROW)
ENDIF
!## Only 3d model
WRITE(IU,'(/A/)') '#Vertical Configuration'
ITOPIC=TTOP
!## check by boundary
IFBND=0
!## get first model layer
DO I=1,SIZE(PBMAN%ILAY); IF(PBMAN%ILAY(I).EQ.1)EXIT; ENDDO
ITOPIC=TBOT
JLAY=0; DO ILAY=I,SIZE(PBMAN%ILAY)
IF(PBMAN%ILAY(ILAY).EQ.0)CYCLE
JLAY=JLAY+1
IF(JLAY.EQ.1)WRITE(IU,'(A)') 'TOP'
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\DIS6\TOPM_L'//TRIM(ITOS(JLAY))//'.ARR', &
TOP(ILAY),0,IU,ILAY,IFBND))RETURN
IF(JLAY.EQ.1.OR.N.EQ.1)WRITE(IU,'(A)') 'BOTM LAYERED'
!## write idf for connection-purposes
IF(.NOT.IDFWRITE(TOP(ILAY),TRIM(DIR)//'\DIS6\TOPM_L'//TRIM(ITOS(JLAY))//'.IDF',1))RETURN
IF(JLAY.EQ.N)THEN
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\DIS6\BOTM_L'//TRIM(ITOS(JLAY))//'.ARR', &
BOT(ILAY),0,IU,ILAY,IFBND))RETURN
ENDIF
!## write idf for connection-purposes
IF(.NOT.IDFWRITE(BOT(ILAY),TRIM(DIR)//'\DIS6\BOTM_L'//TRIM(ITOS(JLAY))//'.IDF',1))RETURN
ENDDO
WRITE(IU,'(/A/)') '#Boundary Settings'
WRITE(IU,'(A)') 'IDOMAIN LAYERED'
JLAY=0; DO ILAY=1,SIZE(PBMAN%ILAY)
IF(PBMAN%ILAY(ILAY).EQ.0)CYCLE
JLAY=JLAY+1
!## modify bnd for idomain parameter
PRJIDF%X=BND(ILAY)%X; PRJIDF%NODATA=BND(ILAY)%NODATA
!## clean idomain which was the boundary condition
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
IF(PRJIDF%X(ICOL,IROW).EQ.PRJIDF%NODATA)PRJIDF%X(ICOL,IROW)=0.0D0
IF(PRJIDF%X(ICOL,IROW).LT.0.0) PRJIDF%X(ICOL,IROW)=1.0D0
IF(PRJIDF%X(ICOL,IROW).GT.1.0) PRJIDF%X(ICOL,IROW)=1.0D0
ENDDO; ENDDO
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
IF(BND(ILAY)%X(ICOL,IROW).EQ.0.0D0)CYCLE
T=TOP(ILAY)%X(ICOL,IROW)-BOT(ILAY)%X(ICOL,IROW)
IF(T.LE.0.0D0)THEN
PRJIDF%X(ICOL,IROW)=-1.0D0
!## make sure an active cells are not allowed on thickness of zero
BND(ILAY)%X(ICOL,IROW)=0.0
ENDIF
ENDDO; ENDDO
!## modify idomain a bit in case MF6 is used to force an export to an ARR-file
IRLOOP: DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
IF(PRJIDF%X(ICOL,IROW).GT.0)THEN
PRJIDF%X(ICOL,IROW)=2.0D0
EXIT IRLOOP
ENDIF
ENDDO; ENDDO IRLOOP
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\DIS6\IBOUND_L'//TRIM(ITOS(JLAY))//'.ARR', &
PRJIDF,1,IU,ILAY,0))RETURN
!## write idf for connection-purposes
IF(.NOT.IDFWRITE(PRJIDF,TRIM(DIR)//'\DIS6\BND_L'//TRIM(ITOS(JLAY))//'.IDF',1))RETURN
!idomain—is an optional array that characterizes the existence status of a cell. If the IDOMAIN array
!is not specified, then all model cells exist within the solution. If the IDOMAIN value for a cell is 0,
!the cell does not exist in the simulation. Input and output values will be read and written for the cell,
!but internal to the program, the cell is excluded from the solution. If the IDOMAIN value for a cell
!is 1, the cell exists in the simulation. If the IDOMAIN value for a cell is -1, the cell does not exist in
!the simulation. Furthermore, the first existing cell above will be connected to the first existing cell
!below. This type of cell is referred to as a “vertical pass through” cell.
ENDDO
WRITE(IU,'(A)') 'END GRIDDATA'
ENDIF
CLOSE(IU)
PMANAGER_SAVEMF2005_DIS_SAVE=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_DIS_SAVE
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_BCF_READ(ISS,IPRT)
!####====================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ISS,IPRT
INTEGER :: ILAY,SCL_D,SCL_U,IINV,ITOPIC
PMANAGER_SAVEMF2005_BCF_READ=.TRUE.
!## use bcf6
IF(.NOT.LBCF)RETURN
PMANAGER_SAVEMF2005_BCF_READ=.FALSE.
ALLOCATE(FNAMES(1),PRJILIST(1))
DO ILAY=1,PRJNLAY
WRITE(6,'(A)') '+Reading BCF-files ('//TRIM(RTOS(REAL(100*ILAY,8)/REAL(PRJNLAY,8),'F',2))//'%) '
!## transient simulation
IF(ISS.EQ.1)THEN
!## sf1
ITOPIC=TSTO; SCL_D=PBMAN%INT(TSTO); SCL_U=2; IINV=0
PRJILIST=ITOPIC; IF(PMANAGER_GETFNAMES(ILAY,ILAY,0,1,0).LE.0)RETURN
IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(STO(ILAY),ITOPIC,1,SCL_D,SCL_U,IINV,IPRT))RETURN
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,STO(ILAY),0,ITOPIC)
ENDIF
!## kdw
ITOPIC=TKDW; SCL_D=PBMAN%INT(TKDW); SCL_U=3; IINV=0
PRJILIST=ITOPIC; IF(PMANAGER_GETFNAMES(ILAY,ILAY,0,1,0).LE.0)RETURN
IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(KDW(ILAY),ITOPIC,1,SCL_D,SCL_U,IINV,IPRT))RETURN
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,KDW(ILAY),0,ITOPIC)
IF(ILAY.NE.PRJNLAY)THEN
!## vcont
ITOPIC=TVCW; SCL_D=PBMAN%INT(TVCW); SCL_U=6; IINV=1
PRJILIST=ITOPIC; IF(PMANAGER_GETFNAMES(ILAY,ILAY,0,1,0).LE.0)RETURN
IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(VCW(ILAY),ITOPIC,1,SCL_D,SCL_U,IINV,IPRT))RETURN
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,VCW(ILAY),0,ITOPIC)
ENDIF
ENDDO
DEALLOCATE(FNAMES,PRJILIST)
PMANAGER_SAVEMF2005_BCF_READ=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_BCF_READ
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_BCF_SAVE(DIR,DIRMNAME,IBATCH,ISS)
!####====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME
INTEGER,INTENT(IN) :: IBATCH,ISS
INTEGER :: IU,ILAY,IFBND
PMANAGER_SAVEMF2005_BCF_SAVE=.TRUE.
!## use bcf6
IF(.NOT.LBCF)RETURN; IF(PBMAN%IFORMAT.EQ.3)RETURN
PMANAGER_SAVEMF2005_BCF_SAVE=.FALSE.
IF(IBATCH.EQ.0)CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIRMNAME)//'.BCF6'//'...')
IF(IBATCH.EQ.1)WRITE(*,'(/1X,A)') 'Writing '//TRIM(DIRMNAME)//'.BCF6'//'...'
!## construct bcf6-file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.BCF6',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
LINE=TRIM(ITOS(IBCFCB))//','//TRIM(RTOS(HNOFLOW,'G',7))//',0,1.0D0,1,0'
IF(PBMAN%MINKD.NE.0.0D0)LINE=TRIM(LINE)//',MINKD '//TRIM(RTOS(PBMAN%MINKD,'G',5))
IF(PBMAN%MINC .NE.0.0D0)LINE=TRIM(LINE)//',MINC ' //TRIM(RTOS(PBMAN%MINC ,'G',5))
WRITE(IU,'(A)') TRIM(LINE)
!## ltype code
LINE=''; DO ILAY=1,PRJNLAY; LINE=TRIM(LINE)//'00,'
IF(MOD(ILAY,40).EQ.0)THEN; WRITE(IU,'(A)') TRIM(LINE); LINE=''; ENDIF
ENDDO
IF(LEN_TRIM(LINE).NE.0)WRITE(IU,'(A)') TRIM(LINE)
WRITE(IU,'(A)') 'CONSTANT 1.0D0' !## trpy
IFBND=1
DO ILAY=1,PRJNLAY
!## transient simulation
IF(ISS.EQ.1)THEN
!## sf1
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\BCF6\SF1_L'//TRIM(ITOS(ILAY))//'.ARR', &
STO(ILAY),0,IU,ILAY,IFBND))RETURN
ENDIF
!## kdw
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\BCF6\TRAN_L'//TRIM(ITOS(ILAY))//'.ARR', &
KDW(ILAY),0,IU,ILAY,IFBND))RETURN
IF(ILAY.NE.PRJNLAY)THEN
!## vcont
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\BCF6\VCONT_L'//TRIM(ITOS(ILAY))//'.ARR', &
VCW(ILAY),0,IU,ILAY,IFBND))RETURN
ENDIF
ENDDO
CLOSE(IU)
PMANAGER_SAVEMF2005_BCF_SAVE=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_BCF_SAVE
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_LPF_READ(ISS,IPRT)
!####====================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ISS,IPRT
INTEGER :: ILAY,SCL_D,SCL_U,IINV,ITOPIC
PMANAGER_SAVEMF2005_LPF_READ=.TRUE.
!## use lpf6
IF(.NOT.LLPF.AND..NOT.LNPF)RETURN
ALLOCATE(FNAMES(1),PRJILIST(1))
PMANAGER_SAVEMF2005_LPF_READ=.FALSE.
DO ILAY=1,PRJNLAY
WRITE(6,'(A)') '+Reading LPF-files ('//TRIM(RTOS(REAL(100*ILAY,8)/REAL(PRJNLAY,8),'F',2))//'%) '
!## hkv
ITOPIC=TKHV; SCL_D=PBMAN%INT(TKHV); SCL_U=3; IINV=0
PRJILIST=ITOPIC; IF(PMANAGER_GETFNAMES(ILAY,ILAY,0,1,0).LE.0)RETURN
IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(KHV(ILAY),ITOPIC,1,SCL_D,SCL_U,IINV,IPRT))RETURN
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,KHV(ILAY),0,ITOPIC)
!## vka
ITOPIC=TKVA; SCL_D=PBMAN%INT(TKVA); SCL_U=2; IINV=1
PRJILIST=ITOPIC; IF(PMANAGER_GETFNAMES(ILAY,ILAY,0,1,0).LE.0)RETURN
IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(KVA(ILAY),ITOPIC,1,SCL_D,SCL_U,IINV,IPRT))RETURN
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,KVA(ILAY),0,ITOPIC)
!## transient simulation
IF(ISS.EQ.1)THEN
!## sf1 - specific storage
ITOPIC=TSTO; SCL_D=PBMAN%INT(TSTO); SCL_U=2; IINV=0
PRJILIST=ITOPIC; IF(PMANAGER_GETFNAMES(ILAY,ILAY,0,1,0).LE.0)RETURN
IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(STO(ILAY),ITOPIC,1,SCL_D,SCL_U,IINV,IPRT))RETURN
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,STO(ILAY),0,ITOPIC)
!## sf2 - specific yield in case not confined
IF(LAYCON(ILAY).NE.1)THEN
ITOPIC=TSPY; SCL_D=PBMAN%INT(TSPY); SCL_U=2; IINV=0
PRJILIST=ITOPIC; IF(PMANAGER_GETFNAMES(ILAY,ILAY,0,1,0).LE.0)RETURN
IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(SPY(ILAY),ITOPIC,1,SCL_D,SCL_U,IINV,IPRT))RETURN
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,SPY(ILAY),0,ITOPIC)
ENDIF
ENDIF
!## quasi-3d scheme add vertical hydraulic conductivity of interbed
IF(LQBD.AND.ILAY.NE.PRJNLAY)THEN
!## kvv
ITOPIC=TKVV; SCL_D=PBMAN%INT(TKVV); SCL_U=3; IINV=0
PRJILIST=ITOPIC; IF(PMANAGER_GETFNAMES(ILAY,ILAY,0,1,0).LE.0)RETURN
IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(KVV(ILAY),ITOPIC,1,SCL_D,SCL_U,IINV,IPRT))RETURN
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,KVV(ILAY),0,ITOPIC)
ENDIF
ENDDO
DEALLOCATE(FNAMES,PRJILIST)
PMANAGER_SAVEMF2005_LPF_READ=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_LPF_READ
!####====================================================================
SUBROUTINE PMANAGER_SAVEMF2005_COMPUTE_KDW_VCW()
!####====================================================================
IMPLICIT NONE
INTEGER :: ILAY,IROW,ICOL
REAL(KIND=DP_KIND) :: T,B,K,T1,T2,T3,KD
!## skip if bcf6 is used
IF(LBCF)RETURN
!## compute transmissivity - could be used by packages to assign to modellayers
DO ILAY=1,PRJNLAY; DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
T=TOP(ILAY)%X(ICOL,IROW); B=BOT(ILAY)%X(ICOL,IROW); K=KHV(ILAY)%X(ICOL,IROW)
KD=(T-B)*K; KD=MAX(PBMAN%MINKD,KD)
IF(T-B.GT.0.0D0)THEN
KHV(ILAY)%X(ICOL,IROW)=KD/(T-B)
ELSE
KHV(ILAY)%X(ICOL,IROW)=1.0D0
ENDIF
IF(T.NE.TOP(ILAY)%NODATA.AND.B.NE.BOT(ILAY)%NODATA.AND.K.NE.KHV(ILAY)%NODATA)THEN
KDW(ILAY)%X(ICOL,IROW)=(T-B)*KHV(ILAY)%X(ICOL,IROW)
ELSE
KDW(ILAY)%X(ICOL,IROW)=HNOFLOW
ENDIF
ENDDO; ENDDO; ENDDO
DO ILAY=1,PRJNLAY-1; DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
IF(BND(ILAY)%X(ICOL,IROW).NE.0.AND.BND(ILAY+1)%X(ICOL,IROW).NE.0)THEN
!## top aquifer
T =0.5D0*(TOP(ILAY)%X(ICOL,IROW)-BOT(ILAY)%X(ICOL,IROW))
T1=0.0D0; IF(T.GT.0.0D0.AND. &
KHV(ILAY)%X(ICOL,IROW).GT.0.0D0.AND. &
KVA(ILAY)%X(ICOL,IROW).GT.0.0D0)T1=T/(KHV(ILAY)%X(ICOL,IROW)/KVA(ILAY)%X(ICOL,IROW))
!## intermediate aquitard
T =BOT(ILAY)%X(ICOL,IROW)-TOP(ILAY+1)%X(ICOL,IROW)
T2=0.0D0
!## zero permeability - make sure resistance is equal to minc
IF(KVV(ILAY)%X(ICOL,IROW).LE.0.0D0)THEN
IF(T.GT.0.0D0)THEN
IF(PBMAN%MINC.GT.0.0D0)THEN
KVV(ILAY)%X(ICOL,IROW)=T/PBMAN%MINC
ELSE
KVV(ILAY)%X(ICOL,IROW)=1.0D0
ENDIF
ELSE
!## irrelevant but need to have some value otherwise MF turns it into inactive nodes
KVV(ILAY)%X(ICOL,IROW)=1.0D0
ENDIF
ENDIF
T2=T/KVV(ILAY)%X(ICOL,IROW)
!## bottom aquifer
T =0.5D0*(TOP(ILAY+1)%X(ICOL,IROW)-BOT(ILAY+1)%X(ICOL,IROW))
! IF(T.GT.0.0D0.AND.KHV(ILAY+1)%X(ICOL,IROW).LE.0.0D0)THEN
! WRITE(*,'(/3G15.7,2I5/)') T,KHV(ILAY+1)%X(ICOL,IROW),KVA(ILAY+1)%X(ICOL,IROW),ILAY,IROW,ICOL
! ENDIF
! T3=0.0D0; IF(T.GT.0.0D0)T3=T/(KHV(ILAY+1)%X(ICOL,IROW)/KVA(ILAY+1)%X(ICOL,IROW))
T3=0.0D0; IF(T.GT.0.0D0.AND. &
KHV(ILAY+1)%X(ICOL,IROW).GT.0.0D0.AND. &
KVA(ILAY+1)%X(ICOL,IROW).GT.0.0D0)T3=T/(KHV(ILAY+1)%X(ICOL,IROW)/KVA(ILAY+1)%X(ICOL,IROW))
!## total resistance
VCW(ILAY)%X(ICOL,IROW)=T1+T2+T3
ELSE
VCW(ILAY)%X(ICOL,IROW)=HNOFLOW
ENDIF
ENDDO; ENDDO; ENDDO
END SUBROUTINE PMANAGER_SAVEMF2005_COMPUTE_KDW_VCW
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_LPF_SAVE(DIR,DIRMNAME,IBATCH,ISS)
!####====================================================================
IMPLICIT NONE
REAL(KIND=DP_KIND),PARAMETER :: WETDRYTHRESS=0.1D0
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME
INTEGER,INTENT(IN) :: IBATCH,ISS
REAL(KIND=DP_KIND) :: WETFCT,T,KD,D
INTEGER :: IU,ILAY,IFBND,IHDWET,IWETIT,IROW,ICOL
PMANAGER_SAVEMF2005_LPF_SAVE=.TRUE.; IF(PBMAN%IFORMAT.EQ.3)RETURN; IF(.NOT.LLPF)RETURN
!## use lpf6
PMANAGER_SAVEMF2005_LPF_SAVE=.FALSE.
IF(IBATCH.EQ.0)CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIRMNAME)//'.LPF7'//'...')
IF(IBATCH.EQ.1)WRITE(*,'(/1X,A)') 'Writing '//TRIM(DIRMNAME)//'.LPF7'//'...'
!## construct lpf7-file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.LPF7',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# LPF7 File Generated by '//TRIM(UTL_IMODVERSION())
!## dry cells negative for restart
LINE=TRIM(ITOS(IBCFCB))//','//TRIM(RTOS(HNOFLOW,'G',7))//',0,STORAGECOEFFICIENT,THICKSTRT,CONSTANTCV,NOCVCORRECTION'
IF(PBMAN%MINKD.NE.0.0D0)LINE=TRIM(LINE)//',MINKD '//TRIM(RTOS(PBMAN%MINKD,'G',5))
IF(PBMAN%MINC .NE.0.0D0)LINE=TRIM(LINE)//',MINC ' //TRIM(RTOS(PBMAN%MINC ,'G',5))
WRITE(IU,'(A)') TRIM(LINE)
!## laycon=1: 0
!## laycon=2: 1
!## laycon=3:-1
!## laycon=4: constant head
!## laytyp code
LINE=''; DO ILAY=1,PRJNLAY
SELECT CASE (LAYCON(ILAY))
CASE (1); LINE=TRIM(LINE)//' 0,' !## confined
CASE (2); LINE=TRIM(LINE)//' 1,' !## convertible head-bot
CASE (3); LINE=TRIM(LINE)//'-1,' !## convertible shd/top-bot
CASE (4); LINE=TRIM(LINE)//' 0,' !## constant head
END SELECT
IF(MOD(ILAY,40).EQ.0)THEN; WRITE(IU,'(A)') LINE(:LEN_TRIM(LINE)-1); LINE=''; ENDIF
ENDDO; IF(LEN_TRIM(LINE).NE.0)WRITE(IU,'(A)') LINE(:LEN_TRIM(LINE)-1)
!## layavg code
LINE=''; DO ILAY=1,PRJNLAY; LINE=TRIM(LINE)//'0,'
IF(MOD(ILAY,40).EQ.0)THEN; WRITE(IU,'(A)') LINE(:LEN_TRIM(LINE)-1); LINE=''; ENDIF
ENDDO; IF(LEN_TRIM(LINE).NE.0)WRITE(IU,'(A)') LINE(:LEN_TRIM(LINE)-1)
!## chani code
LINE=''; DO ILAY=1,PRJNLAY; LINE=TRIM(LINE)//'1.0D0,'
IF(MOD(ILAY,20).EQ.0)THEN; WRITE(IU,'(A)') LINE(:LEN_TRIM(LINE)-1); LINE=''; ENDIF
ENDDO; IF(LEN_TRIM(LINE).NE.0)WRITE(IU,'(A)') LINE(:LEN_TRIM(LINE)-1)
!## lvka code
LINE=''; DO ILAY=1,PRJNLAY; LINE=TRIM(LINE)//'1,'
IF(MOD(ILAY,20).EQ.0)THEN; WRITE(IU,'(A)') LINE(:LEN_TRIM(LINE)-1); LINE=''; ENDIF
ENDDO; IF(LEN_TRIM(LINE).NE.0)WRITE(IU,'(A)') LINE(:LEN_TRIM(LINE)-1)
!## laywet code - if unconfined always use wetdry
LINE=''; IWETIT=0
DO ILAY=1,PRJNLAY
!## not unconfined
IF(LAYCON(ILAY).NE.2)LINE=TRIM(LINE)//'0,'
!## unconfined
IF(LAYCON(ILAY).EQ.2)THEN; LINE=TRIM(LINE)//'1,'; IWETIT=1; ENDIF
IF(MOD(ILAY,20).EQ.0)THEN; WRITE(IU,'(A)') LINE(:LEN_TRIM(LINE)-1); LINE=''; ENDIF
ENDDO; IF(LEN_TRIM(LINE).NE.0)WRITE(IU,'(A)') LINE(:LEN_TRIM(LINE)-1)
!## include wetdry options
IF(IWETIT.EQ.1)THEN
WETFCT=0.1 !## multiplication to determine head in dry cell
IHDWET=0 !## option to compute rewetted model layers; h = BOT + WETFCT (hn - BOT)
LINE=TRIM(RTOS(WETFCT,'F',2))//','//TRIM(ITOS(IWETIT))//','//TRIM(ITOS(IHDWET))
WRITE(IU,'(A)') TRIM(LINE)
ENDIF
!## check all on active cells, except wetdry
IFBND=1
DO ILAY=1,PRJNLAY
IF(PBMAN%MINKD.GT.0.0D0)THEN
DO IROW=1,KHV(ILAY)%NROW; DO ICOL=1,KHV(ILAY)%NCOL
D=TOP(ILAY)%X(ICOL,IROW)-BOT(ILAY)%X(ICOL,IROW)
IF(D.GT.0.0D0)THEN
KD=D*KHV(ILAY)%X(ICOL,IROW)
IF(KD.LT.PBMAN%MINKD)KHV(ILAY)%X(ICOL,IROW)=PBMAN%MINKD/D
ENDIF
ENDDO; ENDDO
ENDIF
!## hk
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\LPF7\HK_L'//TRIM(ITOS(ILAY))//'.ARR', &
KHV(ILAY),0,IU,ILAY,IFBND))RETURN
!## vka
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\LPF7\VKA_L'//TRIM(ITOS(ILAY))//'.ARR', &
KVA(ILAY),0,IU,ILAY,IFBND))RETURN
!## transient simulation
IF(ISS.EQ.1)THEN
!## sf1 - specific storage
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\LPF7\SF1_L'//TRIM(ITOS(ILAY))//'.ARR', &
STO(ILAY),0,IU,ILAY,IFBND))RETURN
!## sf2 - specific yield in case not confined
IF(LAYCON(ILAY).NE.1)THEN
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\LPF7\SF2_L'//TRIM(ITOS(ILAY))//'.ARR', &
SPY(ILAY),0,IU,ILAY,IFBND))RETURN
ENDIF
ENDIF
!## quasi-3d scheme add vertical hydraulic conductivity of interbed
IF(LQBD.AND.ILAY.NE.PRJNLAY)THEN
!## kvv
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\LPF7\VKCB_L'//TRIM(ITOS(ILAY))//'.ARR', &
KVV(ILAY),0,IU,ILAY,IFBND))RETURN
ENDIF
!## add wetdry options - lakes/inactive cells cannot be rewetted)
IF(LAYCON(ILAY).NE.1.AND.IWETIT.EQ.1)THEN
!## fill wetdry thresholds
PRJIDF%X=0.0D0
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
IF(BND(ILAY)%X(ICOL,IROW).GT.0)THEN
T=TOP(ILAY)%X(ICOL,IROW)-BOT(ILAY)%X(ICOL,IROW)
!## only cells below can rewet - more stable
IF(ILAY.LT.PRJNLAY)THEN
PRJIDF%X(ICOL,IROW)=-MIN(WETDRYTHRESS,MAX(0.0,T))
ELSE
PRJIDF%X(ICOL,IROW)= MIN(WETDRYTHRESS,MAX(0.0,T))
ENDIF
ENDIF
ENDDO; ENDDO
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\LPF7\WETDRY_L'//TRIM(ITOS(ILAY))//'.ARR', &
PRJIDF,0,IU,ILAY,0))RETURN
ENDIF
!The two most important variables that affect stability are the wetting
!threshold and which neighboring cells are checked to determine if a cell
!should be wetted. Both of these are controlled through WETDRY. It is
!often useful to look at the output file and identify cells that convert
!repeatedly from wet to dry. Try raising the wetting threshold for those
!cells. It may also be worthwhile looking at the boundary conditions
!associated with dry cells.
ENDDO
CLOSE(IU)
PMANAGER_SAVEMF2005_LPF_SAVE=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_LPF_SAVE
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_NPF_SAVE(DIR,DIRMNAME,IBATCH)
!####====================================================================
IMPLICIT NONE
REAL(KIND=DP_KIND),PARAMETER :: WETDRYTHRESS=0.1D0
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME
INTEGER,INTENT(IN) :: IBATCH
REAL(KIND=DP_KIND) :: WETFCT,T,KDMIN,KD,THICK,ROT
INTEGER :: IU,ILAY,JLAY,IFBND,IHDWET,IWETIT,IROW,ICOL
LOGICAL :: LEX
PMANAGER_SAVEMF2005_NPF_SAVE=.TRUE.; IF(PBMAN%IFORMAT.EQ.2)RETURN; IF(.NOT.LNPF)RETURN
!## use npf6
PMANAGER_SAVEMF2005_NPF_SAVE=.FALSE.
IF(IBATCH.EQ.0)CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIRMNAME)//'.NPF6'//'...')
IF(IBATCH.EQ.1)WRITE(*,'(/1X,A)') 'Writing '//TRIM(DIRMNAME)//'.NPF6'//'...'
!## construct npf6-file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.NPF6',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# NPF6 File Generated by '//TRIM(UTL_IMODVERSION())
WRITE(IU,'(/A/)') '#General Options'
WRITE(IU,'(A)') 'BEGIN OPTIONS'
LEX=.FALSE.
IF(ASSOCIATED(PBMAN%ISAVE(TBND)%ILAY))LEX=.TRUE.
IF(ASSOCIATED(PBMAN%ISAVE(TSTO)%ILAY))LEX=.TRUE.
IF(ASSOCIATED(PBMAN%ISAVE(TSPY)%ILAY))LEX=.TRUE.
IF(ASSOCIATED(PBMAN%ISAVE(TKHV)%ILAY))LEX=.TRUE.
IF(ASSOCIATED(PBMAN%ISAVE(TKVV)%ILAY))LEX=.TRUE.
IF(ASSOCIATED(PBMAN%ISAVE(TKVA)%ILAY))LEX=.TRUE.
IF(LEX)WRITE(IU,'(A)') ' SAVE_FLOWS'
IF(TOPICS(TANI)%IACT_MODEL.EQ.0)THEN
WRITE(IU,'(A)') ' ALTERNATIVE_CELL_AVERAGING AMT-HMK'
WRITE(IU,'(A)') ' THICKSTRT'
ENDIF
!THICKSTRT—indicates that cells having a negative ICELLTYPE are confined, and their cell thickness
! WRITE(IU,'(A)') ' [VARIABLECV [DEWATERED]]'
!If these keywords are not specified, then the default condition is to calculate the
!vertical conductance at the start of the simulation using the initial head and the cell properties. The
!vertical conductance remains constant for the entire simulation. WRITE(IU,'(A)') ' [PERCHED]'
!## see if layer is unconfined and wettable
WETFCT=0.1 !## multiplication to determine head in dry cell
IHDWET=0 !## is a keyword and integer flag that determines which equation is used to define the initial head at cells that become wet.
IWETIT=0 !## is a keyword and iteration interval for attempting to wet cells
DO ILAY=1,PRJNLAY
IF(LAYCON(ILAY).EQ.2)EXIT
ENDDO
IF(ILAY.LE.PRJNLAY)THEN
IWETIT=1
WRITE(IU,'(A)') ' REWET WETFCT '//TRIM(RTOS(WETFCT,'F',3))// &
' IWETIT '//TRIM(ITOS(IWETIT))//' IHDWET '//TRIM(ITOS(IHDWET))
ENDIF
IF(TOPICS(TANI)%IACT_MODEL.NE.0)THEN
WRITE(IU,'(A)') ' XT3D'! [RHS]]'
ENDIF
! WRITE(IU,'(A)') ' [SAVE_SPECIFIC_DISCHARGE]'
WRITE(IU,'(A)') 'END OPTIONS'
WRITE(IU,'(/A/)') '#Geology Options'
WRITE(IU,'(A)') 'BEGIN GRIDDATA'
WRITE(IU,'(A)') ' ICELLTYPE LAYERED'
DO ILAY=1,SIZE(PBMAN%ILAY)
IF(PBMAN%ILAY(ILAY).EQ.0)CYCLE
IF(LAYCON(ILAY).EQ.1)WRITE(IU,'(A)') ' CONSTANT 0' !## confined
IF(LAYCON(ILAY).EQ.2)WRITE(IU,'(A)') ' CONSTANT 1' !## convertible head-bot
IF(LAYCON(ILAY).EQ.3)WRITE(IU,'(A)') ' CONSTANT -1' !## convertible shd/top-bot
ENDDO
!## mf6 needs minimal k for layers with thickness of zero
KDMIN=MAX(0.01D0,PBMAN%MINKD)
DO ILAY=1,SIZE(PBMAN%ILAY)
IF(KDMIN.GT.0.0D0)THEN
DO IROW=1,KHV(ILAY)%NROW; DO ICOL=1,KHV(ILAY)%NCOL
THICK=TOP(ILAY)%X(ICOL,IROW)-BOT(ILAY)%X(ICOL,IROW)
IF(THICK.GT.0.0D0)THEN
KD=THICK*KHV(ILAY)%X(ICOL,IROW)
IF(KD.LT.KDMIN)KHV(ILAY)%X(ICOL,IROW)=KDMIN/THICK
ENDIF
ENDDO; ENDDO
ENDIF
ENDDO
WRITE(IU,'(A)') ' K LAYERED'
JLAY=0; DO ILAY=1,SIZE(PBMAN%ILAY)
IF(PBMAN%ILAY(ILAY).EQ.0)CYCLE
JLAY=JLAY+1
!## hk
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\NPF\K_L'//TRIM(ITOS(JLAY))//'.ARR', &
KHV(ILAY),0,IU,ILAY,IFBND))RETURN
ENDDO
!## vertical k-value
WRITE(IU,'(A)') ' K33 LAYERED'
JLAY=0; DO ILAY=1,SIZE(PBMAN%ILAY)
IF(PBMAN%ILAY(ILAY).EQ.0)CYCLE
JLAY=JLAY+1
PRJIDF%X=0.0D0
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
IF(BND(ILAY)%X(ICOL,IROW).NE.0)THEN
PRJIDF%X(ICOL,IROW)=KHV(ILAY)%X(ICOL,IROW)/KVA(ILAY)%X(ICOL,IROW)
ELSE
PRJIDF%X(ICOL,IROW)=1.0D0
ENDIF
ENDDO; ENDDO
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\NPF\K33_L'//TRIM(ITOS(JLAY))//'.ARR', &
PRJIDF,0,IU,ILAY,IFBND))RETURN
ENDDO
!## use ani - compute k-minor
IF(TOPICS(TANI)%IACT_MODEL.NE.0)THEN
WRITE(IU,'(A)') ' K22 LAYERED'
JLAY=0; DO ILAY=1,SIZE(PBMAN%ILAY)
IF(PBMAN%ILAY(ILAY).EQ.0)CYCLE
JLAY=JLAY+1
PRJIDF%X=0.0D0
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
IF(BND(ILAY)%X(ICOL,IROW).NE.0)THEN
PRJIDF%X(ICOL,IROW)=KHV(ILAY)%X(ICOL,IROW)*ANF(ILAY)%X(ICOL,IROW)
ELSE
PRJIDF%X(ICOL,IROW)=1.0D0
ENDIF
ENDDO; ENDDO
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\NPF\K22_L'//TRIM(ITOS(JLAY))//'.ARR', &
PRJIDF,0,IU,ILAY,IFBND))RETURN
ENDDO
WRITE(IU,'(A)') ' ANGLE1 LAYERED'
JLAY=0; DO ILAY=1,SIZE(PBMAN%ILAY)
IF(PBMAN%ILAY(ILAY).EQ.0)CYCLE
JLAY=JLAY+1
PRJIDF%X=0.0D0
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
IF(BND(ILAY)%X(ICOL,IROW).NE.0)THEN
!## angle
ROT=(360.0D0-ANA(ILAY)%X(ICOL,IROW))+90.0D0
IF(ROT.GT.360.0D0)ROT=ROT-360.0D0
PRJIDF%X(ICOL,IROW)=ROT
ELSE
PRJIDF%X(ICOL,IROW)=0.0D0
ENDIF
ENDDO; ENDDO
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\NPF\ANGLE1_L'//TRIM(ITOS(JLAY))//'.ARR', &
PRJIDF,0,IU,ILAY,IFBND))RETURN
ENDDO
! WRITE(IU,'(A)') ' ANGLE2 LAYERED'
! WRITE(IU,'(A)') ' ANGLE3 LAYERED'
ENDIF
IF(IWETIT.EQ.1)THEN
WRITE(IU,'(A)') ' WETDRY LAYERED'
JLAY=0; DO ILAY=1,SIZE(PBMAN%ILAY)
IF(PBMAN%ILAY(ILAY).EQ.0)CYCLE
JLAY=JLAY+1
!## add wetdry options - lakes/inactive cells cannot be rewetted)
IF(LAYCON(ILAY).NE.1)THEN
!## fill wetdry thresholds
PRJIDF%X=0.0D0
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
IF(BND(ILAY)%X(ICOL,IROW).GT.0)THEN
T=TOP(ILAY)%X(ICOL,IROW)-BOT(ILAY)%X(ICOL,IROW)
!## only cells below can rewet - more stable
IF(ILAY.LT.PRJNLAY)THEN
PRJIDF%X(ICOL,IROW)=-MIN(WETDRYTHRESS,T)
ELSE
PRJIDF%X(ICOL,IROW)= MIN(WETDRYTHRESS,T)
ENDIF
ENDIF
ENDDO; ENDDO
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\NPF\WETDRY_L'//TRIM(ITOS(JLAY))//'.ARR', &
PRJIDF,0,IU,ILAY,0))RETURN
ENDIF
ENDDO
ENDIF
WRITE(IU,'(A)') 'END GRIDDATA'
CLOSE(IU)
PMANAGER_SAVEMF2005_NPF_SAVE=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_NPF_SAVE
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_CON_READ(IPRT)
!####====================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IPRT
INTEGER :: ILAY,SCL_D,SCL_U,IINV,ITOPIC,NCON,IROW,ICOL
PMANAGER_SAVEMF2005_CON_READ=.TRUE.
IF(.NOT.TOPICS(TCON)%DEFINED)RETURN
IF(PBMAN%IFORMAT.EQ.3)RETURN
ALLOCATE(FNAMES(1),PRJILIST(1))
PMANAGER_SAVEMF2005_CON_READ=.FALSE.
NCON=0; DO ILAY=1,PRJNLAY
WRITE(6,'(A)') '+Reading CON-files ('//TRIM(RTOS(REAL(100*ILAY,8)/REAL(PRJNLAY,8),'F',2))//'%) '
!## concentration for vdf-package
ITOPIC=TCON; SCL_D=PBMAN%INT(TCON); SCL_U=2; IINV=0
PRJILIST=ITOPIC; IF(PMANAGER_GETFNAMES(ILAY,ILAY,0,1,0).LE.0)RETURN
IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(CON(ILAY),ITOPIC,1,SCL_D,SCL_U,IINV,IPRT))RETURN
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,CON(ILAY),0,ITOPIC)
DO IROW=1,CON(ILAY)%NROW; DO ICOL=1,CON(ILAY)%NCOL
IF(BND(ILAY)%X(ICOL,IROW).NE.0)THEN
IF(CON(ILAY)%X(ICOL,IROW).LT.0.0D0)THEN
NCON=NCON+1; CON(ILAY)%X(ICOL,IROW)=0.0D0
ENDIF
ENDIF
ENDDO; ENDDO
ENDDO
IF(NCON.GT.0)WRITE(*,'(/A,I10,A/)') 'Set ',NCON,' cells with concentration < 0 to 0.0'
DEALLOCATE(FNAMES,PRJILIST)
PMANAGER_SAVEMF2005_CON_READ=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_CON_READ
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_CON_SAVE(DIR,DIRMNAME,IBATCH)
!####====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME
INTEGER,INTENT(IN) :: IBATCH
INTEGER :: IU,ILAY,JLAY,IFBND
PMANAGER_SAVEMF2005_CON_SAVE=.TRUE.
IF(.NOT.TOPICS(TCON)%DEFINED)RETURN
IF(PBMAN%IFORMAT.EQ.3)RETURN
!## use vdf6
PMANAGER_SAVEMF2005_CON_SAVE=.FALSE.
IF(IBATCH.EQ.0)CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIRMNAME)//'.VDF1'//'...')
IF(IBATCH.EQ.1)WRITE(*,'(/1X,A)') 'Writing '//TRIM(DIRMNAME)//'.VDF1'//'...'
!## construct con1-file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.VDF1',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
JLAY=0; DO ILAY=1,SIZE(PBMAN%ILAY)
IF(PBMAN%ILAY(ILAY).EQ.0)CYCLE
JLAY=JLAY+1
!## con
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\VDF1\VDF_L'//TRIM(ITOS(JLAY))//'.ARR', &
CON(ILAY),0,IU,ILAY,IFBND))RETURN
ENDDO
CLOSE(IU)
PMANAGER_SAVEMF2005_CON_SAVE=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_CON_SAVE
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_STO_SAVE(DIR,DIRMNAME,IBATCH,ISS)
!####====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME
INTEGER,INTENT(IN) :: IBATCH,ISS
INTEGER :: IU,ILAY,ISY,KPER,JLAY
LOGICAL :: LEX
PMANAGER_SAVEMF2005_STO_SAVE=.TRUE.; IF(PBMAN%IFORMAT.EQ.2)RETURN; IF(ISS.EQ.0)RETURN
!## use sto6
PMANAGER_SAVEMF2005_STO_SAVE=.FALSE.
IF(IBATCH.EQ.0)CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIRMNAME)//'.STO6'//'...')
IF(IBATCH.EQ.1)WRITE(*,'(/1X,A)') 'Writing '//TRIM(DIRMNAME)//'.STO6'//'...'
!## construct npf6-file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.STO6',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# STO6 File Generated by '//TRIM(UTL_IMODVERSION())
WRITE(IU,'(/A/)') '#General Options'
WRITE(IU,'(A)') 'BEGIN OPTIONS'
LEX=.FALSE.
IF(ASSOCIATED(PBMAN%ISAVE(TSTO)%ILAY))LEX=.TRUE.
IF(ASSOCIATED(PBMAN%ISAVE(TSPY)%ILAY))LEX=.TRUE.
IF(LEX)WRITE(IU,'(A)') ' SAVE_FLOWS'
WRITE(IU,'(A)') ' STORAGECOEFFICIENT' !## specific coefficient given if NOT mentioned
WRITE(IU,'(A)') 'END OPTIONS'
WRITE(IU,'(/A/)') '#Geology Options'
WRITE(IU,'(A)') 'BEGIN GRIDDATA'
WRITE(IU,'(A)') ' ICONVERT LAYERED'
ISY=0
JLAY=0; DO ILAY=1,SIZE(PBMAN%ILAY)
IF(PBMAN%ILAY(ILAY).EQ.0)CYCLE
JLAY=JLAY+1
IF(LAYCON(ILAY).EQ.1)THEN
WRITE(IU,'(A)') ' CONSTANT 0' !## confined storage
ELSE
WRITE(IU,'(A)') ' CONSTANT 1' !## convertible storage
ISY=1
ENDIF
ENDDO
WRITE(IU,'(A)') ' SS LAYERED'
JLAY=0; DO ILAY=1,SIZE(PBMAN%ILAY)
IF(PBMAN%ILAY(ILAY).EQ.0)CYCLE
JLAY=JLAY+1
!## hk
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\STO\SS_L'//TRIM(ITOS(JLAY))//'.ARR', &
STO(ILAY),0,IU,ILAY,1))RETURN
ENDDO
IF(ISY.EQ.1)THEN
WRITE(IU,'(A)') ' SY LAYERED'
JLAY=0; DO ILAY=1,SIZE(PBMAN%ILAY)
IF(PBMAN%ILAY(ILAY).EQ.0)CYCLE
JLAY=JLAY+1
!## hk
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\STO\SY_L'//TRIM(ITOS(JLAY))//'.ARR', &
SPY(ILAY),0,IU,ILAY,1))RETURN
ENDDO
ENDIF
WRITE(IU,'(A)') 'END GRIDDATA'
WRITE(IU,'(/A/)') '#Time Storage Options'
DO KPER=1,PRJNPER
WRITE(IU,'(A)') 'BEGIN PERIOD '//TRIM(ITOS(KPER))
IF(SIM(KPER)%DELT.EQ.0.0D0)WRITE(IU,'(A)') ' STEADY-STATE'
IF(SIM(KPER)%DELT.NE.0.0D0)WRITE(IU,'(A)') ' TRANSIENT'
WRITE(IU,'(A)') 'END PERIOD'
ENDDO
CLOSE(IU)
PMANAGER_SAVEMF2005_STO_SAVE=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_STO_SAVE
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_ANI_READ(IPRT)
!####====================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IPRT
INTEGER :: ILAY,SCL_D,SCL_U,IINV,ITOPIC,NTOP,NSYS,ISYS,KTOP,ICNST
REAL(KIND=DP_KIND) :: FCT,CNST,IMP
CHARACTER(LEN=256) :: SFNAME
PMANAGER_SAVEMF2005_ANI_READ=.TRUE.
!## use ani1
IF(.NOT.TOPICS(TANI)%DEFINED)RETURN
WRITE(6,'(A)') '+Reading ANI-files ...'
PMANAGER_SAVEMF2005_ANI_READ=.FALSE.
!## ani angle
IINV=0; ITOPIC=TANI
!## allocate memory for packages
NTOP=SIZE(TOPICS(ITOPIC)%STRESS(1)%FILES,1); NSYS=SIZE(TOPICS(ITOPIC)%STRESS(1)%FILES,2)
!## fill with default values
DO ILAY=1,PRJNLAY; ANF(ILAY)%X=1.0D0; ANA(ILAY)%X=0.0D0; ANF(ILAY)%NODATA=HUGE(1.0); ANA(ILAY)%NODATA=HUGE(1.0); ENDDO
!## number of systems
DO ISYS=1,NSYS
WRITE(6,'(A)') '+Reading ANI-files ('//TRIM(RTOS(REAL(100*ISYS,8)/REAL(NSYS,8),'F',2))//'%)'
!## number of subtopics
DO KTOP=1,NTOP
ICNST =TOPICS(ITOPIC)%STRESS(1)%FILES(KTOP,ISYS)%ICNST
CNST =TOPICS(ITOPIC)%STRESS(1)%FILES(KTOP,ISYS)%CNST
FCT =TOPICS(ITOPIC)%STRESS(1)%FILES(KTOP,ISYS)%FCT
IMP =TOPICS(ITOPIC)%STRESS(1)%FILES(KTOP,ISYS)%IMP
ILAY =TOPICS(ITOPIC)%STRESS(1)%FILES(KTOP,ISYS)%ILAY
SFNAME=TOPICS(ITOPIC)%STRESS(1)%FILES(KTOP,ISYS)%FNAME
WRITE(IPRT,'(1X,A,I3,A1,I1,A1,I4.3,3(A1,G15.7),A1,A)') TOPICS(ITOPIC)%TNAME(1:5)//',', &
ISYS,',',ICNST,',',ILAY,',',FCT,',',IMP,',',CNST,',',CHAR(39)//TRIM(SFNAME)//CHAR(39)
!## average factor
IF(KTOP.EQ.1)THEN
!## constant value
IF(ICNST.EQ.1)THEN
ANF(ILAY)%X=CNST
!## read/clip/scale idf file
ELSEIF(TOPICS(ITOPIC)%STRESS(1)%FILES(KTOP,ISYS)%ICNST.EQ.2)THEN
ANF(ILAY)%FNAME=SFNAME
SCL_U=2
SCL_D=PBMAN%INT(TANI) !## factors can be interpolated
IF(.NOT.IDFREADSCALE(ANF(ILAY)%FNAME,ANF(ILAY),SCL_U,SCL_D,1.0D0,0))RETURN
ENDIF
CALL PMANAGER_SAVEMF2005_FCTIMP(0,ICNST,ANF(ILAY),FCT,IMP,SCL_D)
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,ANF(ILAY),0,ITOPIC)
!## most frequent occurence for angles
ELSEIF(KTOP.EQ.2)THEN
!## constant value
IF(ICNST.EQ.1)THEN
ANA(ILAY)%X=CNST
!## read/clip/scale idf file
ELSEIF(TOPICS(ITOPIC)%STRESS(1)%FILES(KTOP,ISYS)%ICNST.EQ.2)THEN
ANA(ILAY)%FNAME=SFNAME
SCL_U=7
SCL_D=0 !## no interpolation of angles
IF(.NOT.IDFREADSCALE(ANA(ILAY)%FNAME,ANA(ILAY),SCL_U,SCL_D,1.0D0,0))RETURN
ENDIF
CALL PMANAGER_SAVEMF2005_FCTIMP(0,ICNST,ANA(ILAY),FCT,IMP,SCL_D)
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,ANA(ILAY),0,ITOPIC)
ENDIF
ENDDO
ENDDO
PMANAGER_SAVEMF2005_ANI_READ=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_ANI_READ
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_ANI_SAVE(DIR,DIRMNAME,IBATCH)
!####====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME
INTEGER,INTENT(IN) :: IBATCH
INTEGER :: IU,ILAY,JLAY,IFBND
!## return if modflow6 export
PMANAGER_SAVEMF2005_ANI_SAVE=.TRUE.; IF(PBMAN%IFORMAT.EQ.3)RETURN
!## use ani
IF(TOPICS(TANI)%IACT_MODEL.EQ.0)RETURN
PMANAGER_SAVEMF2005_ANI_SAVE=.FALSE.
IF(IBATCH.EQ.0)CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIRMNAME)//'.ANI1'//'...')
IF(IBATCH.EQ.1)WRITE(*,'(/1X,A)') 'Writing '//TRIM(DIRMNAME)//'.ANI1'//'...'
!## construct ani1-file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.ANI1',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
JLAY=0; DO ILAY=1,SIZE(PBMAN%ILAY)
IF(PBMAN%ILAY(ILAY).EQ.0)CYCLE
JLAY=JLAY+1
!## anisotropy factors
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\ANI1\ANF_L'//TRIM(ITOS(JLAY))//'.ARR', &
ANF(ILAY),0,IU,ILAY,IFBND))RETURN
!## anisotropy angle
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\ANI1\ANA_L'//TRIM(ITOS(JLAY))//'.ARR', &
ANA(ILAY),0,IU,ILAY,IFBND))RETURN
ENDDO
CLOSE(IU)
PMANAGER_SAVEMF2005_ANI_SAVE=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_ANI_SAVE
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_WEL(DIR,DIRMNAME,IBATCH,IACT,ITOPIC,ICB,CPCK,IPRT)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IBATCH,ICB,ITOPIC,IPRT,IACT
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME,CPCK
REAL(KIND=DP_KIND) :: X,Y,Q,Z1,Z2,FCT,IMP,CNST,NCOUNT
CHARACTER(LEN=256) :: SFNAME,EXFNAME,ID,CDIR
CHARACTER(LEN=5) :: EXT
CHARACTER(LEN=30) :: FRM
CHARACTER(LEN=52),ALLOCATABLE,DIMENSION(:) :: STRING
INTEGER :: IU,JU,KU,ILAY,IROW,ICOL,I,J,NROWIPF,NCOLIPF,IEXT,IOS,N,KPER,IPER,NP,MP,ICNST,ISYS,NSYS,ISS,JLAY
REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: TLP,KH,TP,BT
INTEGER(KIND=8) :: ITIME,JTIME
REAL(KIND=DP_KIND),PARAMETER :: MINKHT=0.0D0
CHARACTER(LEN=1) :: VTXT
IF(IACT.EQ.0)THEN; PMANAGER_SAVEMF2005_WEL=.TRUE.; RETURN; ENDIF
PMANAGER_SAVEMF2005_WEL=.FALSE.
VTXT='7'; IF(PBMAN%IFORMAT.EQ.3)VTXT='6'
IF(IBATCH.EQ.0)CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIRMNAME)//'.'//CPCK//VTXT//'...')
IF(IBATCH.EQ.1)WRITE(*,'(/1X,A)') 'Writing '//TRIM(DIRMNAME)//'.'//CPCK//VTXT//'...'
IU=UTL_GETUNIT()
CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.'//CPCK//VTXT//'_',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED')
IF(IU.EQ.0)RETURN
IF(PBMAN%IFORMAT.EQ.3)THEN
WRITE(IU,'(A)') '# '//CPCK//VTXT//' File Generated by '//TRIM(UTL_IMODVERSION())
WRITE(IU,'(/A/)') '#General Options'
WRITE(IU,'(A)') 'BEGIN OPTIONS'
! WRITE(IU,'(A)') ' AUXILIARY '
! WRITE(IU,'(A)') ' AUXMULTNAME '
! WRITE(IU,'(A)') ' BOUNDNAMES'
! WRITE(IU,'(A)') ' PRINT_INPUT'
! WRITE(IU,'(A)') ' PRINT_FLOWS'
IF(ASSOCIATED(PBMAN%ISAVE(TWEL)%ILAY))WRITE(IU,'(A)') ' SAVE_FLOWS'
! WRITE(IU,'(A)') ' TS6 FILEIN '
! WRITE(IU,'(A)') ' OBS6 FILEIN '
! WRITE(IU,'(A)') ' MOVER'
WRITE(IU,'(A)') 'END OPTIONS'
WRITE(IU,'(/A/)') '#General Dimensions'
WRITE(IU,'(A)') 'BEGIN DIMENSIONS'
WRITE(IU,'(1X,A)') ' MAXBOUND NaN1#'
WRITE(IU,'(A)') 'END DIMENSIONS'
ENDIF
! IF(IBATCH.EQ.0)CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIRMNAME)//'.'//CPCK//'7...')
! IF(IBATCH.EQ.1)WRITE(*,'(/1X,A)') 'Writing '//TRIM(DIRMNAME)//'.'//CPCK//'7...'
! IU=UTL_GETUNIT()
! CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.'//CPCK//'7_',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED')
! IF(IU.EQ.0)RETURN
!## header
LINE='NaN1#,'//TRIM(ITOS(ICB))//' AUX ISUB WSUBSYS ISUB NOPRINT'
IF(PBMAN%IFORMAT.EQ.2)WRITE(IU,'(A)') TRIM(LINE)
!## fill tlp for each modellayer
ALLOCATE(TLP(PRJNLAY),KH(PRJNLAY),TP(PRJNLAY),BT(PRJNLAY))
WRITE(FRM,'(A9,I2.2,A15)') '(3(I5,1X),',1,'(G15.7,1X),I10)'
!## create subfolders
IF(PBMAN%IFORMAT.EQ.2)CALL UTL_CREATEDIR(TRIM(DIR)//'\'//CPCK//'7')
!## maximum number of well in simulation
MP=0
IOS=0
DO IPER=1,PRJNPER
!## number of wells per stressperiod
NP=0
!## get appropriate stress-period to store in runfile
KPER=PMANAGER_GETCURRENTIPER(IPER,ITOPIC,ITIME,JTIME)
!## always export wells per stress-period
IF(PBMAN%DWEL.EQ.1)KPER=ABS(KPER)
!## output
WRITE(IPRT,'(1X,A,2I10,2(1X,I14))') 'Exporting timestep ',IPER,KPER,ITIME,JTIME
IF(IBATCH.EQ.1)WRITE(6,'(A,3I6,2(1X,I14))') '+Exporting timestep ',IPER,PRJNPER,KPER,ITIME,JTIME
!## reuse previous timestep
IF(KPER.LE.0)THEN
IF(PBMAN%IFORMAT.EQ.2)THEN
IF(IPER.EQ.1)THEN; WRITE(IU,'(I10)') 0
ELSE; WRITE(IU,'(I10)') -1; ENDIF
ENDIF
!## goto next timestep
CYCLE
ENDIF
IF(PBMAN%IFORMAT.EQ.3)WRITE(IU,'(/A)') 'BEGIN PERIOD '//TRIM(ITOS(IPER))
JU=0
!## create subfolders
IF(PBMAN%IFORMAT.EQ.2)THEN
CALL UTL_CREATEDIR(TRIM(DIR)//'\'//CPCK//'7')
EXFNAME=TRIM(DIR)//'\'//CPCK//'7'//'\'//CPCK//'_T'//TRIM(ITOS(IPER))//'.ARR'
ELSE
CALL UTL_CREATEDIR(TRIM(DIR)//'\'//CPCK//'6')
EXFNAME=TRIM(DIR)//'\'//CPCK//'6'//'\'//CPCK//'_T'//TRIM(ITOS(IPER))//'.ARR'
ENDIF
JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=EXFNAME,STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IOS=0; IF(JU.EQ.0)THEN; IOS=-1; EXIT; ENDIF
!## number of systems
NSYS=SIZE(TOPICS(ITOPIC)%STRESS(KPER)%FILES,2)
DO ISYS=1,NSYS
ICNST =TOPICS(ITOPIC)%STRESS(KPER)%FILES(1,ISYS)%ICNST
CNST =TOPICS(ITOPIC)%STRESS(KPER)%FILES(1,ISYS)%CNST
FCT =TOPICS(ITOPIC)%STRESS(KPER)%FILES(1,ISYS)%FCT
IMP =TOPICS(ITOPIC)%STRESS(KPER)%FILES(1,ISYS)%IMP
ILAY =TOPICS(ITOPIC)%STRESS(KPER)%FILES(1,ISYS)%ILAY
SFNAME=TOPICS(ITOPIC)%STRESS(KPER)%FILES(1,ISYS)%FNAME
WRITE(IPRT,'(1X,A,I3,A1,I1,A1,I4.3,3(A1,G15.7),A1,A)') TOPICS(ITOPIC)%TNAME(1:5)//',', &
ISYS,',',ICNST,',',ILAY,',',FCT,',',IMP,',',CNST,',',CHAR(39)//TRIM(SFNAME)//CHAR(39)
CDIR=SFNAME(:INDEX(SFNAME,'\',.TRUE.)-1)
KU=UTL_GETUNIT(); CALL OSD_OPEN(KU,SFNAME,STATUS='OLD',ACTION='READ',FORM='FORMATTED'); IF(KU.EQ.0)RETURN
READ(KU,*,IOSTAT=IOS) NROWIPF; IF(IOS.NE.0)EXIT
READ(KU,*,IOSTAT=IOS) NCOLIPF; IF(IOS.NE.0)EXIT
DO I=1,NCOLIPF
READ(KU,*,IOSTAT=IOS); IF(IOS.NE.0)EXIT
ENDDO
READ(KU,*,IOSTAT=IOS) IEXT,EXT; IF(IOS.NE.0)EXIT
N=MAX(3,IEXT); IF(ILAY.EQ.0)N=MAX(5,IEXT)
IF(N.GT.NCOLIPF)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMOD need at least '//TRIM(ITOS(N))//' columns however it reads only '//TRIM(ITOS(NCOLIPF))//' from:'//CHAR(13)// &
TRIM(SFNAME),'Error'); EXIT
ENDIF
ALLOCATE(STRING(N)); STRING=''
!## steady-state/transient timestep
ISS=1; IF(SIM(IPER)%DELT.GT.0.0D0)ISS=2
!## overrule in case of steady-state
IF(ISS.EQ.1)IEXT=0
DO I=1,NROWIPF
!## start with current given layer number
ILAY=TOPICS(ITOPIC)%STRESS(KPER)%FILES(1,ISYS)%ILAY
READ(KU,*,IOSTAT=IOS) (STRING(J),J=1,N); IF(IOS.NE.0)EXIT
READ(STRING(1),*,IOSTAT=IOS) X; IF(IOS.NE.0)EXIT
READ(STRING(2),*,IOSTAT=IOS) Y; IF(IOS.NE.0)EXIT
!## get correct cell-indices
CALL IDFIROWICOL(BND(1),IROW,ICOL,X,Y)
!## outside current model
IF(IROW.EQ.0.OR.ICOL.EQ.0)CYCLE
!## get discharge - always on position 3
IF(IEXT.EQ.0)THEN
READ(STRING(3),*,IOSTAT=IOS) Q; IF(IOS.NE.0)EXIT
ELSE
!## get id number - can be any column
READ(STRING(IEXT),'(A)',IOSTAT=IOS) ID; IF(IOS.NE.0)EXIT
ENDIF
!## assign to several layer
IF(ILAY.EQ.0)THEN
READ(STRING(4),*,IOSTAT=IOS) Z1; IF(IOS.NE.0)EXIT
READ(STRING(5),*,IOSTAT=IOS) Z2; IF(IOS.NE.0)EXIT
!## get filter fractions
CALL PMANAGER_SAVEMF2005_PCK_ULSTRD_PARAM(PRJNLAY,ICOL,IROW,TOP,BOT,KDW,TP,BT,KH,.TRUE.)
CALL UTL_PCK_GETTLP(PRJNLAY,TLP,KH,TP,BT,Z1,Z2,MINKHT)
!## find uppermost layer
ELSE
IF(ILAY.EQ.-1)THEN; DO ILAY=1,PRJNLAY; IF(BND(ILAY)%X(ICOL,IROW).GT.0)EXIT; ENDDO; ENDIF
!## outside current model dimensions, set ilay=0
IF(ILAY.GT.PRJNLAY)ILAY=0; TLP=0.0D0; IF(ILAY.NE.0)TLP(ILAY)=1.0D0
ENDIF
IF(IEXT.GT.0)THEN
IF(.NOT.UTL_PCK_READTXT(2,ITIME,JTIME,Q,TRIM(CDIR)//'\'//TRIM(ID)//'.'//TRIM(EXT),0,'',ISS,NCOUNT))THEN
IOS=-1; EXIT
ENDIF
IF(NCOUNT.LE.0.0D0)Q=0.0D0
ENDIF
!## use factor/impulse
Q=Q*FCT; Q=Q+IMP
IF(Q.NE.0.0D0)THEN
!## only active cells
DO ILAY=1,PRJNLAY
IF(BND(ILAY)%X(ICOL,IROW).LE.0.0D0)TLP(ILAY)=0.0D0
ENDDO
! !## normalize tlp() again
! IF(SUM(TLP).GT.0.0D0)TLP=(1.0D0/SUM(TLP))*TLP
JLAY=0; DO ILAY=1,SIZE(PBMAN%ILAY)
IF(PBMAN%ILAY(ILAY).EQ.0)CYCLE; JLAY=JLAY+1
IF(TLP(ILAY).GT.0.0D0)THEN
WRITE(JU,FRM) JLAY,IROW,ICOL,Q*TLP(ILAY),ISYS
NP=NP+1
ENDIF
ENDDO
ENDIF
ENDDO
DEALLOCATE(STRING)
CLOSE(KU)
IF(IOS.NE.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Error reading IPF file'//CHAR(13)//TRIM(SFNAME)//CHAR(13)// &
'Linenumber '//TRIM(ITOS(I))//CHAR(13)//'iMOD Probably cannot read values for top and bot in combination with ilay=0','Error'); EXIT
ENDIF
ENDDO
IF(NP.GT.0)THEN
IF(PBMAN%IFORMAT.EQ.2)CALL IDFWRITEFREE_HEADER(JU,PRJIDF)
CLOSE(JU)
ELSE
CLOSE(JU,STATUS='DELETE')
ENDIF
IF(IOS.NE.0)EXIT
!## store maximum number of well in simulation
MP=MAX(MP,NP)
IF(PBMAN%IFORMAT.GE.2)THEN
IF(PBMAN%IFORMAT.EQ.2)THEN
LINE=TRIM(ITOS(NP)); WRITE(IU,'(A)') TRIM(LINE)
ENDIF
IF(NP.GT.0)THEN
SFNAME=EXFNAME
N=3; IF(PBMAN%IFORMAT.EQ.3)N=4; DO I=1,N; SFNAME=SFNAME(:INDEX(SFNAME,'\',.TRUE.)-1); ENDDO
I=LEN_TRIM(SFNAME); SFNAME='.'//EXFNAME(I+1:)
WRITE(IU,'(A)') 'OPEN/CLOSE '//TRIM(SFNAME)//' 1.0D0 (FREE) -1'
ENDIF
IF(PBMAN%IFORMAT.EQ.3)WRITE(IU,'(A)') 'END PERIOD '//TRIM(ITOS(IPER))
ENDIF
ENDDO
CLOSE(IU); DEALLOCATE(TLP,TP,BT,KH)
IF(IOS.EQ.0)THEN
!## mf6 does not accept zero boundaries
IF(PBMAN%IFORMAT.EQ.3)MP=MAX(1,MP)
CALL UTL_MF2005_MAXNO(TRIM(DIRMNAME)//'.'//CPCK//VTXT//'_',(/MP/))
PMANAGER_SAVEMF2005_WEL=.TRUE.
ENDIF
END FUNCTION PMANAGER_SAVEMF2005_WEL
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_MNW(DIRMNAME,IBATCH,IACT,ITOPIC,ICB,CPCK,IPRT)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IBATCH,ICB,ITOPIC,IPRT,IACT
CHARACTER(LEN=*),INTENT(IN) :: DIRMNAME,CPCK
REAL(KIND=DP_KIND) :: X,Y,Q,Z1,Z2,FCT,IMP,CNST,RW,RSKIN,KSKIN,NCOUNT
CHARACTER(LEN=256) :: SFNAME,ID,CDIR
CHARACTER(LEN=5) :: EXT
CHARACTER(LEN=30) :: LOSSTYPE
CHARACTER(LEN=52),ALLOCATABLE,DIMENSION(:) :: STRING
INTEGER :: IU,KU,ILAY,IROW,ICOL,I,J,ISYS,NROWIPF,NCOLIPF,IEXT,IOS,N,KPER,IPER,LPER,NSYS,ICNST, &
MNWPRINT,NNODES,ILOSSTYPE,QLIMIT,PPFLAG,PUMPLOC,PUMPCAP,ILOSS,IEQUAL
INTEGER(KIND=8) :: ITIME,JTIME
IF(IACT.EQ.0)THEN; PMANAGER_SAVEMF2005_MNW=.TRUE.; RETURN; ENDIF
PMANAGER_SAVEMF2005_MNW=.FALSE.
IF(IBATCH.EQ.0)CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIRMNAME)//'.'//CPCK//'7...')
IF(IBATCH.EQ.1)WRITE(*,'(/1X,A)') 'Writing '//TRIM(DIRMNAME)//'.'//CPCK//'7...'
IU=UTL_GETUNIT()
CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.'//CPCK//'7_',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED')
IF(IU.EQ.0)RETURN
!## no output information, use 2 for maximal output
MNWPRINT=0 !2
!## header
LINE='NaN1#,'//TRIM(ITOS(ICB))//','//TRIM(ITOS(MNWPRINT))//' NOPRINT'; WRITE(IU,'(A)') TRIM(LINE)
!## search for first mnw definition in time - can be one only !!!
DO IPER=1,PRJNPER
!## get appropriate input file for first stress-period
KPER=PMANAGER_GETCURRENTIPER(IPER,ITOPIC,ITIME,JTIME)
!## found appropriate stress-period
IF(KPER.GT.0)EXIT
ENDDO
!## nothing found
IF(IPER.GT.PRJNPER)KPER=0
!## store maximum number of well in simulation
ALLOCATE(NP_IPER(0:PRJNPER)); NP_IPER=0; LPER=0
!## fill static-time independent information
DO IPER=0,PRJNPER
IF(IPER.GT.0)THEN
!## get appropriate stress-period to store in runfile
KPER=PMANAGER_GETCURRENTIPER(IPER,ITOPIC,ITIME,JTIME)
!## output
WRITE(IPRT,'(1X,A,2I10,2(1X,I14))') 'Exporting timestep ',IPER,KPER,ITIME,JTIME
IF(IBATCH.EQ.1)WRITE(6,'(A,3I6,2(1X,I14))') '+Exporting timestep ',IPER,PRJNPER,KPER,ITIME,JTIME
!## always export wells per stress-period
IF(PBMAN%DWEL.EQ.1)KPER=ABS(KPER)
ENDIF
!## reuse previous timestep
IF(KPER.LE.0)THEN
IF(PBMAN%IFORMAT.EQ.2)THEN
IF(IPER.EQ.1)THEN; WRITE(IU,'(I10)') 0
ELSE; WRITE(IU,'(I10)') -1; ENDIF
ENDIF
!## goto next timestep
CYCLE
ENDIF
IF(IPER.GT.0)THEN; LINE='NaN'//TRIM(ITOS(IPER+1))//'#'; WRITE(IU,'(A)') TRIM(LINE); ENDIF
!## get number of mnw-systems
NSYS=SIZE(TOPICS(ITOPIC)%STRESS(KPER)%FILES,2)
DO ISYS=1,NSYS
ICNST =TOPICS(ITOPIC)%STRESS(KPER)%FILES(1,ISYS)%ICNST
CNST =TOPICS(ITOPIC)%STRESS(KPER)%FILES(1,ISYS)%CNST
FCT =TOPICS(ITOPIC)%STRESS(KPER)%FILES(1,ISYS)%FCT
IMP =TOPICS(ITOPIC)%STRESS(KPER)%FILES(1,ISYS)%IMP
ILAY =TOPICS(ITOPIC)%STRESS(KPER)%FILES(1,ISYS)%ILAY
SFNAME=TOPICS(ITOPIC)%STRESS(KPER)%FILES(1,ISYS)%FNAME
!## check to see whether equal to previous timestep
IEQUAL=1
IF(LPER.GT.0)THEN
IEQUAL=1
IF(ICNST.EQ. TOPICS(ITOPIC)%STRESS(LPER)%FILES(1,ISYS)%ICNST.AND. &
CNST .EQ. TOPICS(ITOPIC)%STRESS(LPER)%FILES(1,ISYS)%CNST.AND. &
! FCT.EQ. TOPICS(ITOPIC)%STRESS(LPER)%FILES(1,ISYS)%FCT.AND. &
! IMP .EQ. TOPICS(ITOPIC)%STRESS(LPER)%FILES(1,ISYS)%IMP.AND. &
ILAY.EQ. TOPICS(ITOPIC)%STRESS(LPER)%FILES(1,ISYS)%ILAY.AND. &
SFNAME.EQ.TOPICS(ITOPIC)%STRESS(LPER)%FILES(1,ISYS)%FNAME)IEQUAL=1
ENDIF
!## for MNW it is essential that the number of files are similar during simulation
IF(IEQUAL.EQ.-1)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'For the MNW package it is NOT allowed to specify different input files'//CHAR(13)// &
'among different stress-periods','Error'); IOS=-1; EXIT
ENDIF
IF(IPER.GT.0)THEN
WRITE(IPRT,'(1X,A,I3,A1,I1,A1,I4.3,3(A1,G15.7),A1,A)') TOPICS(ITOPIC)%TNAME(1:5)//',', &
ISYS,',',ICNST,',',ILAY,',',FCT,',',IMP,',',CNST,',',CHAR(39)//TRIM(SFNAME)//CHAR(39)
ENDIF
CDIR=SFNAME(:INDEX(SFNAME,'\',.TRUE.)-1)
KU=UTL_GETUNIT(); CALL OSD_OPEN(KU,SFNAME,STATUS='OLD',ACTION='READ',FORM='FORMATTED'); IF(KU.EQ.0)THEN; IOS=-1; EXIT; ENDIF
READ(KU,*,IOSTAT=IOS) NROWIPF; IF(IOS.NE.0)EXIT
READ(KU,*,IOSTAT=IOS) NCOLIPF; IF(IOS.NE.0)EXIT
DO I=1,NCOLIPF; READ(KU,*,IOSTAT=IOS); IF(IOS.NE.0)EXIT; ENDDO
READ(KU,*,IOSTAT=IOS) IEXT,EXT; IF(IOS.NE.0)EXIT
N=NCOLIPF; ALLOCATE(STRING(N)); STRING=''
IF(ILAY.GT.0)ILOSS=4; IF(ILAY.EQ.0)ILOSS=6
DO I=1,NROWIPF
!## start with current given layer number
ILAY=TOPICS(ITOPIC)%STRESS(KPER)%FILES(1,ISYS)%ILAY
READ(KU,*,IOSTAT=IOS) (STRING(J),J=1,N); IF(IOS.NE.0)EXIT
READ(STRING(1),*,IOSTAT=IOS) X; IF(IOS.NE.0)EXIT
READ(STRING(2),*,IOSTAT=IOS) Y; IF(IOS.NE.0)EXIT
!## get correct cell-indices
CALL IDFIROWICOL(BND(1),IROW,ICOL,X,Y)
!## outside current model
IF(IROW.EQ.0.OR.ICOL.EQ.0)CYCLE
NP_IPER(IPER)=NP_IPER(IPER)+1
!## write alphanumerical identification of well
IF(IPER.EQ.0)THEN
IF(ILAY.GT.0)NNODES= 1 !## single well screen layer given
IF(ILAY.LE.0)NNODES=-1 !## single well screen layer determined
LINE='WELLID_'//TRIM(ITOS(NP_IPER(IPER)))//','//TRIM(ITOS(NNODES))
!## identification
WRITE(IU,'(A)') TRIM(LINE)
READ(STRING(ILOSS),*,IOSTAT=IOS) LOSSTYPE; IF(IOS.NE.0)EXIT
!## losstype
LOSSTYPE=UTL_CAP(LOSSTYPE,'U')
SELECT CASE (TRIM(LOSSTYPE))
CASE ('NONE'); ILOSSTYPE=0
CASE ('THIEM'); ILOSSTYPE=1
CASE ('SKIN'); ILOSSTYPE=2
! CASE ('GENERAL'); ILOSSTYPE=3
! CASE ('SPECIFYCWC'); ILOSSTYPE=4
CASE DEFAULT
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Specified model ('//TRIM(LOSSTYPE)//') for well loss unknown'//CHAR(13)// &
'Select one of the following:'//CHAR(13)//'NONE, THIEM, SKIN','Error'); IOS=-1; EXIT
! 'Select one of the following:'//CHAR(13)//'NONE, THIEM, SKIN, GENERAL, SPECIFYCWC','Error'); IOS=-1; EXIT
END SELECT
IF(ILOSSTYPE.EQ.0.AND.NNODES.LT.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Specified model ('//TRIM(LOSSTYPE)//') for well cannot be'//CHAR(13)// &
'used in combination with ILAY=0','Error'); IOS=-1; EXIT
ENDIF
PUMPLOC=0 !## no location of pump intake or injection
QLIMIT=0 !## pumpage not by constraints
PPFLAG=0 !## head not adjusted for partial penetration of well - error in case ibound is zero
!IF(NNODES.EQ. 1)PPFLAG=0 !## head not adjusted for partial penetration of well
!IF(NNODES.EQ.-1)PPFLAG=1 !## head adjusted for partial penetration of well
PUMPCAP=0 !## discharge not defined by head-capacity relation
LINE=TRIM(LOSSTYPE)//','//TRIM(ITOS(PUMPLOC))//','//TRIM(ITOS(QLIMIT))//','//TRIM(ITOS(PPFLAG))//','//TRIM(ITOS(PUMPCAP))
WRITE(IU,'(A)') TRIM(LINE)
SELECT CASE (ILOSSTYPE)
!## thiem
CASE(1)
READ(STRING(ILOSS+1),*,IOSTAT=IOS) RW; IF(IOS.NE.0)EXIT
LINE=TRIM(RTOS(RW,'F',2)); WRITE(IU,'(A)') TRIM(LINE)
!## skin
CASE(2)
READ(STRING(ILOSS+1),*,IOSTAT=IOS) RW; IF(IOS.NE.0)EXIT
READ(STRING(ILOSS+2),*,IOSTAT=IOS) RSKIN; IF(IOS.NE.0)EXIT
READ(STRING(ILOSS+3),*,IOSTAT=IOS) KSKIN; IF(IOS.NE.0)EXIT
LINE=TRIM(RTOS(RW,'F',2))//','//TRIM(RTOS(RSKIN,'F',2))//','//TRIM(RTOS(KSKIN,'F',2)); WRITE(IU,'(A)') TRIM(LINE)
END SELECT
IF(NNODES.GT.0)THEN
LINE=TRIM(ITOS(ILAY))//','//TRIM(ITOS(IROW))//','//TRIM(ITOS(ICOL))
WRITE(IU,'(A)') TRIM(LINE)
ELSE
READ(STRING(4),*,IOSTAT=IOS) Z1; IF(IOS.NE.0)EXIT
READ(STRING(5),*,IOSTAT=IOS) Z2; IF(IOS.NE.0)EXIT
Z1=MIN(Z1,TOP(1 )%X(ICOL,IROW)-0.1D0)
Z2=MAX(Z2,BOT(PRJNLAY)%X(ICOL,IROW)+0.1D0)
LINE=TRIM(RTOS(Z1,'F',2))//','//TRIM(RTOS(Z2,'F',2))//','//TRIM(ITOS(IROW))//','//TRIM(ITOS(ICOL))
WRITE(IU,'(A)') TRIM(LINE)
ENDIF
ELSE
!## get discharge - always on position 3
IF(IEXT.EQ.0)THEN
READ(STRING(3),*,IOSTAT=IOS) Q; IF(IOS.NE.0)EXIT
ELSE
!## get id number - can be any column
READ(STRING(IEXT),*,IOSTAT=IOS) ID; IF(IOS.NE.0)EXIT
IF(.NOT.UTL_PCK_READTXT(2,ITIME,JTIME,Q,TRIM(CDIR)//'\'//TRIM(ID)//'.'//TRIM(EXT),0,'',2,NCOUNT))THEN
IOS=-1; EXIT
ENDIF
IF(NCOUNT.LE.0.0D0)Q=0.0D0
ENDIF
!## use factor/impulse
Q=Q*FCT; Q=Q+IMP
LINE='WELLID_'//TRIM(ITOS(NP_IPER(IPER)))//','//TRIM(RTOS(Q,'G',7))
WRITE(IU,'(A)') TRIM(LINE)
ENDIF
ENDDO
DEALLOCATE(STRING); CLOSE(KU)
IF(IOS.NE.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Error reading IPF file'//CHAR(13)//TRIM(SFNAME)//CHAR(13)// &
'Linenumber '//TRIM(ITOS(I)),'Error'); EXIT
ENDIF
ENDDO
IF(IOS.NE.0)EXIT
!## store previous stress-period information for this timestep
IF(IPER.GT.0)LPER=KPER
ENDDO
CLOSE(IU)
!## store maximum number of well in simulation
NP_IPER(0)=MAXVAL(NP_IPER(1:PRJNPER))
IF(IOS.EQ.0)THEN
CALL UTL_MF2005_MAXNO(TRIM(DIRMNAME)//'.'//CPCK//'7_',NP_IPER)
PMANAGER_SAVEMF2005_MNW=.TRUE.
ENDIF
DEALLOCATE(NP_IPER)
END FUNCTION PMANAGER_SAVEMF2005_MNW
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_ISG(DIR,DIRMNAME,IBATCH,IACT,ITOPIC,ICB,CPCK,IPRT)
!###======================================================================
IMPLICIT NONE
REAL(KIND=DP_KIND),PARAMETER :: CONST=86400.0D0 !## conversion to m3/day
REAL(KIND=DP_KIND),PARAMETER :: DLEAK=0.001D0
INTEGER,INTENT(IN) :: IBATCH,ICB,ITOPIC,IPRT,IACT
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME,CPCK
REAL(KIND=DP_KIND) :: FCT,IMP,CNST
CHARACTER(LEN=256) :: SFNAME,EXFNAME
CHARACTER(LEN=30) :: FRM
INTEGER :: IU,JU,ILAY,I,ISYS,KPER,IPER,NTOP,NSYS,ICNST,ICOL,IROW,JSYS
INTEGER,DIMENSION(2) :: NP
INTEGER(KIND=8) :: ITIME,JTIME
TYPE(GRIDISGOBJ) :: GRIDISG
CHARACTER(LEN=1) :: VTXT
IF(IACT.EQ.0)THEN; PMANAGER_SAVEMF2005_ISG=.TRUE.; RETURN; ENDIF
PMANAGER_SAVEMF2005_ISG=.FALSE.
VTXT='7'; IF(PBMAN%IFORMAT.EQ.3)VTXT='6'
IF(IBATCH.EQ.0)CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIRMNAME)//'.'//CPCK//VTXT//'...')
IF(IBATCH.EQ.1)WRITE(*,'(/1X,A)') 'Writing '//TRIM(DIRMNAME)//'.'//CPCK//VTXT//'...'
IU=UTL_GETUNIT()
CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.'//CPCK//VTXT//'_',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED')
!IF(IBATCH.EQ.0)CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIRMNAME)//'.'//CPCK//'7...')
!IF(IBATCH.EQ.1)WRITE(*,'(/1X,A)') 'Writing '//TRIM(DIRMNAME)//'.'//CPCK//'7...'
IF(PBMAN%IFORMAT.EQ.3)THEN
WRITE(IU,'(A)') '# '//CPCK//VTXT//' File Generated by '//TRIM(UTL_IMODVERSION())
WRITE(IU,'(/A/)') '#General Options'
WRITE(IU,'(A)') 'BEGIN OPTIONS'
! WRITE(IU,'(A)') ' AUXILIARY '
! WRITE(IU,'(A)') ' AUXMULTNAME '
! WRITE(IU,'(A)') ' BOUNDNAMES'
! WRITE(IU,'(A)') ' PRINT_INPUT'
! WRITE(IU,'(A)') ' PRINT_FLOWS'
IF(ASSOCIATED(PBMAN%ISAVE(TRIV)%ILAY))WRITE(IU,'(A)') ' SAVE_FLOWS'
! WRITE(IU,'(A)') ' TS6 FILEIN '
! WRITE(IU,'(A)') ' OBS6 FILEIN '
! WRITE(IU,'(A)') ' MOVER'
WRITE(IU,'(A)') 'END OPTIONS'
WRITE(IU,'(/A/)') '#General Dimensions'
WRITE(IU,'(A)') 'BEGIN DIMENSIONS'
WRITE(IU,'(1X,A)') ' MAXBOUND NaN1#'
WRITE(IU,'(A)') 'END DIMENSIONS'
ENDIF
! IU=UTL_GETUNIT()
! CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.'//CPCK//'7_',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED')
! IF(IU.EQ.0)RETURN
IF(PBMAN%IFORMAT.EQ.2)THEN
SELECT CASE (ITOPIC)
!## isg
CASE (TISG)
LINE='NaN1#,'//TRIM(ITOS(ICB))//' AUX RFCT AUX ISUB RFACT RFCT RSUBSYS ISUB NOPRINT'
!## sfr
CASE (TSFR)
LINE='NaN2#,NaN1#,0,0,'//TRIM(RTOS(CONST,'G',7))//','//TRIM(RTOS(DLEAK,'E',4))//','// &
TRIM(ITOS(ICB))//','//TRIM(ITOS(ISFRCB2))//' NOPRINT'
END SELECT
WRITE(IU,'(A)') TRIM(LINE)
ENDIF
WRITE(FRM,'(A9,I2.2,A14)') '(3(I5,1X),',1,'(G15.7,1X),I5)'
!## create subfolders
CALL UTL_CREATEDIR(TRIM(DIR)//'\'//CPCK//VTXT)
CALL PMANAGER_SAVEMF2005_ALLOCATEPCK(PRJNLAY)
NP=0
DO IPER=1,PRJNPER
!## reset only for isg to riv conversion
IF(ITOPIC.EQ.TISG)NP(1)=0
!## get appropriate stress-period to store in runfile
KPER=PMANAGER_GETCURRENTIPER(IPER,ITOPIC,ITIME,JTIME)
!## always export rivers per stress-period
IF(ITOPIC.EQ.TISG)THEN; IF(PBMAN%DISG.EQ.1)KPER=ABS(KPER); ENDIF
!## always export streamflow routing per stress-period
IF(ITOPIC.EQ.TSFR)THEN; IF(PBMAN%DSFR.EQ.1)KPER=ABS(KPER); ENDIF
!## output
WRITE(IPRT,'(1X,A,2I10,2(1X,I14))') 'Exporting timestep ',IPER,KPER,ITIME,JTIME
IF(IBATCH.EQ.1)WRITE(6,'(A,3I6,2(1X,I14))') '+Exporting timestep ',IPER,PRJNPER,KPER,ITIME,JTIME
!## reuse previous timestep
IF(KPER.LE.0)THEN
IF(IPER.EQ.1)THEN
WRITE(IU,'(I10)') 0
ELSE
IF(ITOPIC.EQ.TISG)WRITE(IU,'(A)') '-1'
IF(ITOPIC.EQ.TSFR)WRITE(IU,'(A)') '-1,-1,0,0'
ENDIF
!## process next timestep
CYCLE
ENDIF
IF(PBMAN%IFORMAT.EQ.3)WRITE(IU,'(/A)') 'BEGIN PERIOD '//TRIM(ITOS(IPER))
!## default isg
IF(ITOPIC.EQ.TISG)THEN
EXFNAME=TRIM(DIR)//'\'//CPCK//VTXT//'\'//CPCK//'_T'//TRIM(ITOS(IPER))//'.ARR'
JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=EXFNAME,STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(JU.EQ.0)RETURN
!## sfr isg
ELSE
EXFNAME=TRIM(DIR)//'\'//CPCK//VTXT//'\'//CPCK//'.ARR'
JU=IU
ENDIF
!## ISG not yet supports timescales less than 1 day
GRIDISG%SDATE=SIM(IPER)%IYR*10000+SIM(IPER)%IMH*100+SIM(IPER)%IDY
GRIDISG%SDATE=UTL_IDATETOJDATE(GRIDISG%SDATE)
GRIDISG%EDATE=GRIDISG%SDATE+MAX(1,INT(SIM(IPER)%DELT))
GRIDISG%XMIN=BND(1)%XMIN; GRIDISG%YMIN=BND(1)%YMIN
GRIDISG%XMAX=BND(1)%XMAX; GRIDISG%YMAX=BND(1)%YMAX
!## transient (2) or steady-state (1)
GRIDISG%ISTEADY=2; IF(SIM(IPER)%DELT.EQ.0.0D0)GRIDISG%ISTEADY=1
GRIDISG%IDIM=0
GRIDISG%CS=BND(1)%DX !## cellsize
GRIDISG%MINDEPTH=0.1
GRIDISG%WDEPTH=0.0D0
GRIDISG%ICDIST=1 !## compute influence of structures
GRIDISG%ISIMGRO=0 !## no simgro
GRIDISG%IEXPORT=1 !## modflow river files
IF(BND(1)%IEQ.EQ.1)THEN
GRIDISG%NCOL=BND(1)%NCOL; GRIDISG%NROW=BND(1)%NROW
ALLOCATE(GRIDISG%DELR(0:BND(1)%NCOL))
DO ICOL=0,GRIDISG%NCOL; GRIDISG%DELR(ICOL)=BND(1)%SX(ICOL); ENDDO
ALLOCATE(GRIDISG%DELC(0:BND(1)%NROW))
DO IROW=0,GRIDISG%NROW; GRIDISG%DELC(IROW)=BND(1)%SY(IROW); ENDDO
ELSE
GRIDISG%NCOL=0; GRIDISG%NROW=0
ENDIF
!## output folder
GRIDISG%ROOT=EXFNAME(1:INDEX(EXFNAME,'\',.TRUE.)-1)
GRIDISG%POSTFIX=''
GRIDISG%NODATA=-999.99D0
GRIDISG%ISAVE=1
GRIDISG%MAXWIDTH=1000.0D0
GRIDISG%IAVERAGE=1
!## allocate memory for packages
NTOP=SIZE(TOPICS(ITOPIC)%STRESS(KPER)%FILES,1); NSYS=SIZE(TOPICS(ITOPIC)%STRESS(KPER)%FILES,2)
!## number of systems
DO ISYS=1,NSYS
ICNST =TOPICS(ITOPIC)%STRESS(KPER)%FILES(1,ISYS)%ICNST
CNST =TOPICS(ITOPIC)%STRESS(KPER)%FILES(1,ISYS)%CNST
FCT =TOPICS(ITOPIC)%STRESS(KPER)%FILES(1,ISYS)%FCT
IMP =TOPICS(ITOPIC)%STRESS(KPER)%FILES(1,ISYS)%IMP
ILAY =TOPICS(ITOPIC)%STRESS(KPER)%FILES(1,ISYS)%ILAY
SFNAME=TOPICS(ITOPIC)%STRESS(KPER)%FILES(1,ISYS)%FNAME
IF(PBMAN%SSYSTEM.EQ.0)THEN
JSYS=ISYS
ELSE
JSYS=1
ENDIF
WRITE(IPRT,'(1X,A,I3,A1,I1,A1,I4.3,3(A1,G15.7),A1,A)') TOPICS(ITOPIC)%TNAME(1:5)//',', &
ISYS,',',ICNST,',',ILAY,',',FCT,',',IMP,',',CNST,',',CHAR(39)//TRIM(SFNAME)//CHAR(39)
IF(ISGREAD((/SFNAME/),IBATCH))THEN
!## translate again to idate as it will be convered to jdate in next subroutine
GRIDISG%SDATE=UTL_JDATETOIDATE(GRIDISG%SDATE)
GRIDISG%EDATE=UTL_JDATETOIDATE(GRIDISG%EDATE)-1 !<- edate is equal to sdate if one day is meant
SELECT CASE (ITOPIC)
!## open isg file
CASE (TISG)
IF(.NOT.ISG2GRID(GRIDISG%POSTFIX,BND(1)%NROW,BND(1)%NCOL,PRJNLAY,ILAY,TOP,BOT,KHV,BND,VCW,IBATCH,NP,JU,GRIDISG,SFT,TOPICS(TSFT)%DEFINED,JSYS))EXIT
!## open sfr file
CASE (TSFR)
IF(.NOT.ISG2SFR(BND(1)%NROW,BND(1)%NCOL,PRJNLAY,ILAY,IPER,PRJNPER,NP,JU,GRIDISG,EXFNAME,TOP,BOT))EXIT
END SELECT
CALL ISGDEAL(1); CALL ISGCLOSEFILES()
ELSE
!## stop processing
CLOSE(IU); CALL PMANAGER_SAVEMF2005_DEALLOCATEPCK(); RETURN
ENDIF
ENDDO
!## not for sfr
IF(PBMAN%IFORMAT.EQ.2.AND.ITOPIC.EQ.29)CALL IDFWRITEFREE_HEADER(JU,BND(1))
!## error occured
IF(ISYS.LE.NSYS)EXIT
!## only for river package usage of external filename
IF(ITOPIC.EQ.TISG)THEN
IF(PBMAN%IFORMAT.GE.2)THEN
IF(PBMAN%IFORMAT.EQ.2)THEN
LINE=TRIM(ITOS(NP(1))); WRITE(IU,'(A)') TRIM(LINE)
ENDIF
NP(2)=MAXVAL(NP)
IF(NP(1).GT.0)THEN
SFNAME=EXFNAME
N=3; IF(PBMAN%IFORMAT.EQ.3)N=4; DO I=1,N; SFNAME=SFNAME(:INDEX(SFNAME,'\',.TRUE.)-1); ENDDO
I=LEN_TRIM(SFNAME); SFNAME='.'//EXFNAME(I+1:)
WRITE(IU,'(A)') 'OPEN/CLOSE '//TRIM(SFNAME)//' 1.0 (FREE) -1'
ENDIF
IF(IU.NE.JU)CLOSE(JU)
IF(PBMAN%IFORMAT.EQ.3)WRITE(IU,'(A)') 'END PERIOD '
ENDIF
ENDIF
ENDDO
CLOSE(IU); CALL PMANAGER_SAVEMF2005_DEALLOCATEPCK()
IF(ASSOCIATED(GRIDISG%DELR))DEALLOCATE(GRIDISG%DELR)
IF(ASSOCIATED(GRIDISG%DELC))DEALLOCATE(GRIDISG%DELC)
!## no error occured
IF(IPER.GT.NPER)THEN
IF(ITOPIC.EQ.TISG)THEN
CALL UTL_MF2005_MAXNO(TRIM(DIRMNAME)//'.'//CPCK//VTXT//'_',(/NP(2)/))
ELSE
CALL UTL_MF2005_MAXNO(TRIM(DIRMNAME)//'.'//CPCK//VTXT//'_',NP)
ENDIF
PMANAGER_SAVEMF2005_ISG=.TRUE.
ENDIF
END FUNCTION PMANAGER_SAVEMF2005_ISG
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,IACT,ITOPIC,ICB,CPCKIN,JTOP,IPRT)
!###======================================================================
IMPLICIT NONE
INTEGER,PARAMETER :: IFHBSS=0,NFHBX1=0,NFHBX2=0
INTEGER,INTENT(IN) :: IBATCH,ITOPIC,ICB,IPRT
INTEGER,INTENT(IN),DIMENSION(:) :: JTOP
INTEGER,INTENT(IN) :: IACT
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME,CPCKIN
REAL(KIND=DP_KIND) :: Z1,Z2,FCT,IMP,CNST,OLFCOND
CHARACTER(LEN=256) :: SFNAME,EXFNAME
CHARACTER(LEN=3) :: CPCK
CHARACTER(LEN=40) :: FRM
INTEGER :: IU,JU,ILAY,IROW,ICOL,I,J,KTOP,KPER,IPER,NTOP,SCL_D,SCL_U,ICNST,NSYS,ISYS,JSYS,MP,N,IIPER,KKPER, &
NBDTIM,NHED,NFLW,IFBND,NRCHOP,NEVTOP,NUZTOP,INRECH,INSURF,INEVTR,INEXDP,LPER,NUZF1,NUZF2,NUZF3,NUZF4,JLAY
REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: TLP,KH,TP,BT,XTMP
INTEGER(KIND=8) :: ITIME,JTIME
REAL(KIND=DP_KIND),PARAMETER :: MINKHT=0.0D0
! INTEGER,PARAMETER :: ICLAY=1 !## shift to nearest aquifer
INTEGER :: JD0,JD1,ISEC0,ISEC1,NUZGAG,IRUNFLG,IEQUAL,ICHECK
INTEGER,ALLOCATABLE,DIMENSION(:,:) :: JEQUAL
REAL(KIND=DP_KIND) :: DDAY,DSEC
CHARACTER(LEN=1) :: VTXT
LOGICAL :: LCHKCHD
IF(IACT.EQ.0)THEN; PMANAGER_SAVEMF2005_PCK=.TRUE.; RETURN; ENDIF
PMANAGER_SAVEMF2005_PCK=.FALSE.
CPCK=CPCKIN
VTXT='7'; IF(PBMAN%IFORMAT.EQ.3)VTXT='6'
IF(IBATCH.EQ.0)CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIRMNAME)//'.'//CPCK//VTXT//'...')
IF(IBATCH.EQ.1)WRITE(*,'(/1X,A)') 'Writing '//TRIM(DIRMNAME)//'.'//CPCK//VTXT//'...'
IU=UTL_GETUNIT()
CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.'//CPCK//VTXT//'_',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED')
IF(IU.EQ.0)RETURN
IF(PBMAN%IFORMAT.EQ.3)THEN
WRITE(IU,'(A)') '# '//CPCK//VTXT//' File Generated by '//TRIM(UTL_IMODVERSION())
WRITE(IU,'(/A/)') '#General Options'
WRITE(IU,'(A)') 'BEGIN OPTIONS'
! WRITE(IU,'(A)') ' AUXILIARY '
! WRITE(IU,'(A)') ' AUXMULTNAME '
! WRITE(IU,'(A)') ' BOUNDNAMES'
! WRITE(IU,'(A)') ' PRINT_INPUT'
! WRITE(IU,'(A)') ' PRINT_FLOWS'
IF(ASSOCIATED(PBMAN%ISAVE(ITOPIC)%ILAY))WRITE(IU,'(1X,A)') 'SAVE_FLOWS'
! WRITE(IU,'(A)') ' TS6 FILEIN '
! WRITE(IU,'(A)') ' OBS6 FILEIN '
! WRITE(IU,'(A)') ' MOVER'
WRITE(IU,'(A)') 'END OPTIONS'
WRITE(IU,'(/A/)') '#General Dimensions'
WRITE(IU,'(A)') 'BEGIN DIMENSIONS'
WRITE(IU,'(1X,A)') ' MAXBOUND NaN1#'
WRITE(IU,'(A)') 'END DIMENSIONS'
ENDIF
!## write header of file
SELECT CASE (ITOPIC)
!## uzf
!NUZTOP=1 !## recharge specified to top cell
CASE (TUZF); NUZGAG=0; IRUNFLG=0; NUZTOP=1 !PBMAN%NLOGLOC
!## define initial water content
IF(SIM(1)%DELT.GT.0.0D0)WRITE(IU,'(A)') 'SPECIFYTHTI'
LINE='NaN1#,2,'//TRIM(ITOS(IRUNFLG))//',1,'//TRIM(ITOS(-IUZFCB1))//',0,20,50,'//TRIM(ITOS(NUZGAG))//',0.5'
IF(PBMAN%IFORMAT.EQ.2)WRITE(IU,'(A)') TRIM(LINE)
!IUZFOPT=2 !## permeabiliy specified in lpf
!irunflg=0 !## water discharge from top removed form the model (usage of SFR/LAK needed)
!ietflg=1 !## et simulated
!iuzfcb1=59 !## writing groundwater recharge (see nam-file)
!iuzfcb2=0 !## alternative output format
!NTRAIL2=10 !## trailing waves
!nsets2=20 !## number of wave sets
!nuzgag=1 !## number of cells to gage
!surfdep=0.5 !## average undulation depth (is stabieler om iets meer te pakken)
!WRITE(iu,'(9I3,f5.1)') NUZTOP,IUZFOPT,irunflg,ietflg,iuzfcb1,iuzfcb2,NTRAIL2,nsets2,nuzgag,surfdep
!## drn
CASE (TDRN)
IF(PBMAN%ICONCHK.EQ.0)THEN
LINE='NaN1#,'//TRIM(ITOS(ICB))//' AUX ISUB DSUBSYS ISUB NOPRINT'
ELSE
LINE='NaN1#,'//TRIM(ITOS(ICB))//' AUX ISUB DSUBSYS ISUB ICONCHK NOPRINT'
ENDIF
IF(PBMAN%IFORMAT.EQ.2)WRITE(IU,'(A)') TRIM(LINE)
!## AUX IC ICHONCHK IC
!## riv
CASE (TRIV)
LINE='NaN1#,'//TRIM(ITOS(ICB))//' AUX RFCT'
IF(TOPICS(TCON)%IACT_MODEL.EQ.1)LINE=TRIM(LINE)//' AUX RIVDEN'
LINE=TRIM(LINE)//' AUX ISUB RFACT RFCT RSUBSYS ISUB NOPRINT'
IF(PBMAN%IFORMAT.EQ.2)WRITE(IU,'(A)') TRIM(LINE)
!## IFVDL SFT RCNC
!## evt
CASE (TEVT); NEVTOP=1; LINE='NaN1#,'//TRIM(ITOS(ICB))
IF(PBMAN%IFORMAT.EQ.2)WRITE(IU,'(A)') TRIM(LINE)
!## NEVTOP moet twee worden voor optie laag = -1
!## ghb
CASE (TGHB)
LINE='NaN1#,'//TRIM(ITOS(ICB))
IF(TOPICS(TCON)%IACT_MODEL.EQ.1)LINE=TRIM(LINE)//' AUX GHBDEN'
LINE=TRIM(LINE)//' AUX ISUB GSUBSYS ISUB NOPRINT'
IF(PBMAN%IFORMAT.EQ.2)WRITE(IU,'(A)') TRIM(LINE)
!## rch
CASE (TRCH); NRCHOP=1; LINE='NaN1#,'//TRIM(ITOS(ICB))
IF(PBMAN%IFORMAT.EQ.2)WRITE(IU,'(A)') TRIM(LINE)
!## NaN1 moet 3 worden voor optie laag = -1
!## olf
CASE (TOLF)
CPCK='OLF'; IF(.NOT.TOPICS(TDRN)%DEFINED)CPCK='DRN';
IF(PBMAN%ICONCHK.EQ.0)THEN
LINE='NaN1#,'//TRIM(ITOS(ICB))//' AUX ISUB DSUBSYS ISUB NOPRINT'
ELSE
LINE='NaN1#,'//TRIM(ITOS(ICB))//' AUX ISUB DSUBSYS ISUB ICONCHK NOPRINT'
ENDIF
IF(PBMAN%IFORMAT.EQ.2)WRITE(IU,'(A)') TRIM(LINE)
!## chd
CASE (TCHD)
LINE='NaN1#'
IF(TOPICS(TCON)%IACT_MODEL.EQ.1)LINE=TRIM(LINE)//' AUX CHDDEN'
LINE=TRIM(LINE)//' NOPRINT NEGBND'
IF(PBMAN%IFORMAT.EQ.2)WRITE(IU,'(A)') TRIM(LINE)
!## fhb package
CASE(TFHB)
!## check number of boundary type conditions - for fhb package
NHED=0; NFLW=0
DO ILAY=1,PRJNLAY
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
IF(BND(ILAY)%X(ICOL,IROW).EQ.-2.0)NHED=NHED+1
IF(BND(ILAY)%X(ICOL,IROW).EQ. 2.0)NFLW=NFLW+1
ENDDO; ENDDO
ENDDO
!## look for number of stress-periods for boundary package
ALLOCATE(FHBNBDTIM(PRJNPER)); FHBNBDTIM=0.0D0
!## get first stress-period
NBDTIM=0
DO I=1,PRJNPER; IF(SIM(I)%DELT.NE.0.0D0)EXIT; ENDDO
!## add steady-state
IF(I.NE.1)NBDTIM=1
!## transient periods still available
IF(I.LE.PRJNPER)THEN
!## get first start-date
JD0 =JD(SIM(I)%IYR,SIM(I)%IMH,SIM(I)%IDY)
ISEC0= SIM(I)%IHR*3600+SIM(I)%IMT*60+SIM(I)%ISC
ISEC0= 86400-ISEC0
DO J=1,SIZE(TOPICS(ITOPIC)%STRESS)
IF(.NOT.ASSOCIATED(TOPICS(ITOPIC)%STRESS(J)%FILES))CYCLE
!## not transient definition
IF(TOPICS(ITOPIC)%STRESS(J)%IYR+TOPICS(ITOPIC)%STRESS(J)%IMH+TOPICS(ITOPIC)%STRESS(J)%IDY+ &
TOPICS(ITOPIC)%STRESS(J)%IHR+TOPICS(ITOPIC)%STRESS(J)%IMT+TOPICS(ITOPIC)%STRESS(J)%ISC.LE.0)CYCLE
!## get date for current period
JD1 =JD(TOPICS(ITOPIC)%STRESS(J)%IYR,TOPICS(ITOPIC)%STRESS(J)%IMH,TOPICS(ITOPIC)%STRESS(J)%IDY)
ISEC1 =TOPICS(ITOPIC)%STRESS(J)%IHR*3600+TOPICS(ITOPIC)%STRESS(J)%IMT*60+TOPICS(ITOPIC)%STRESS(J)%ISC
DDAY =JD1-JD0
IF(DDAY.EQ.0.0D0)THEN
DSEC=ISEC1
ELSE
DSEC=ISEC0+ISEC1
ENDIF
NBDTIM=NBDTIM+1
FHBNBDTIM(NBDTIM)=DDAY+REAL(DSEC)/86400.0D0
ENDDO
ENDIF
LINE=TRIM(ITOS(NBDTIM))//','//TRIM(ITOS(NFLW)) //','//TRIM(ITOS(NHED))//','//TRIM(ITOS(IFHBSS))//','// &
TRIM(ITOS(IFHBCB))//','//TRIM(ITOS(NFHBX1))//','//TRIM(ITOS(NFHBX2))
WRITE(IU,'(A)') TRIM(LINE)
LINE=TRIM(ITOS(IFHBUN))//',1.0,1'
WRITE(IU,'(A)') TRIM(LINE)
WRITE(IU,*) (FHBNBDTIM(I),I=1,NBDTIM)
!## allocate for fhb package
IF(NHED.GT.0)ALLOCATE(FHBHED(NHED,NBDTIM))
IF(NFLW.GT.0)ALLOCATE(FHBFLW(NFLW,NBDTIM))
END SELECT
!## fill tlp for each modellayer
ALLOCATE(TLP(PRJNLAY),KH(PRJNLAY),TP(PRJNLAY),BT(PRJNLAY))
!## see whether information is equal to previous timestep - only for rch and evt
LPER=0
ALLOCATE(NP_IPER(0:PRJNPER)); NP_IPER=0
!## maximum number of input per simulation
MP=0; NBDTIM=0
DO IPER=1,PRJNPER
!## number of input per stressperiod
NP_IPER(IPER)=0
!## get appropriate stress-period to store in runfile
KPER=PMANAGER_GETCURRENTIPER(IPER,ITOPIC,ITIME,JTIME)
!## output
WRITE(IPRT,'(1X,A,2I10,2(1X,I14))') 'Exporting timestep ',IPER,KPER,ITIME,JTIME
IF(IBATCH.EQ.1)WRITE(6,'(A,3I6,2(1X,I14))') '+Exporting timestep ',IPER,PRJNPER,KPER,ITIME,JTIME
!## reuse previous timestep
IF(KPER.LE.0)THEN
SELECT CASE (ITOPIC)
!## uzf
CASE (TUZF)
IF(IPER.EQ.1)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You need to start the first stress-period with'//CHAR(13)// &
'a definition for the UZF package','Error'); RETURN
ELSE
DO I=1,4; WRITE(IU,'(A)') '-1'; ENDDO
ENDIF
!## evt
CASE (TEVT)
IF(IPER.EQ.1)THEN
WRITE(IU,'(A)') '0,0,0'
DO I=1,3; WRITE(IU,'(A)') 'CONSTANT 0.000000E+00'; ENDDO
ELSE; WRITE(IU,'(A)') '-1,-1,-1'; ENDIF
!## rch
CASE (TRCH)
IF(PBMAN%IFORMAT.EQ.2)THEN
IF(IPER.EQ.1)THEN; WRITE(IU,'(I10)') 0; WRITE(IU,'(A)') 'CONSTANT 0.000000E+00'
ELSE; WRITE(IU,'(I10)') -1; ENDIF
ENDIF
!## wel,drn,riv,ghb,chd,olf
CASE (TDRN,TRIV,TGHB,TCHD,TOLF,TISG)
IF(PBMAN%IFORMAT.EQ.2)THEN
IF(IPER.EQ.1)THEN; WRITE(IU,'(I10)') 0
ELSE; WRITE(IU,'(I10)') -1; ENDIF
ENDIF
!## fhb- skip
CASE (TFHB)
CASE DEFAULT
WRITE(*,'(/A)') 'CANNOT COME HERE: ERROR PMANAGER_SAVEMF2005_PCK - WRITING HEADER'
WRITE(*,'(A,I10)') 'ITOPIC=',ITOPIC
WRITE(*,'(A)') TRIM(TOPICS(ITOPIC)%TNAME)
PAUSE; STOP
END SELECT
!## goto next timestep
CYCLE
ENDIF
!## allocate memory for packages
NTOP=SIZE(TOPICS(ITOPIC)%STRESS(KPER)%FILES,1); NSYS=SIZE(TOPICS(ITOPIC)%STRESS(KPER)%FILES,2)
IF(NTOP.NE.SIZE(JTOP))THEN
IF(IBATCH.EQ.0)CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'The number of entries '//TRIM(ITOS(NTOP))//' is not equal to the number of entries allowed ('//TRIM(ITOS(SIZE(JTOP)))//').'//CHAR(13)// &
'You might remove these additional entries from the current package '//TRIM(TOPICS(ITOPIC)%TNAME),'Information')
IF(IBATCH.EQ.1)WRITE(*,'(/A/)') 'The number of entries '//TRIM(ITOS(NTOP))//' is not equal to the number of entries allowed ('//TRIM(ITOS(SIZE(JTOP)))//'). '// &
'You might remove these additional entries from the current package '//TRIM(TOPICS(ITOPIC)%TNAME)
RETURN
ENDIF
!## used for writing and including the tlp-vector
IF(ALLOCATED(XTMP))DEALLOCATE(XTMP); ALLOCATE(XTMP(NTOP)); XTMP=0.0D0
SELECT CASE (ITOPIC)
CASE (TEVT,TRCH)
IF(NSYS.GT.1)THEN
IF(IBATCH.EQ.0)CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'You cannot apply more than a single layer to the package '// &
TRIM(TOPICS(ITOPIC)%TNAME)//'.','Information')
IF(IBATCH.EQ.1)WRITE(*,'(/A/)') 'You cannot apply more than a single layer to the package '//TRIM(TOPICS(ITOPIC)%TNAME)//'.'
RETURN
ENDIF
END SELECT
SELECT CASE (ITOPIC)
CASE(TOLF,TCHD); N=NTOP+1
CASE DEFAULT; N=NTOP
END SELECT
WRITE(FRM,'(A10,I2.2,A14)') '(3(I5,1X),',N,'(G15.7,1X),I5)'
CALL PMANAGER_SAVEMF2005_ALLOCATEPCK(NTOP)
NHED=0; NFLW=0; NBDTIM=NBDTIM+1
!## see whether duplicate of definitions happened with current systems, not for wel/isg
SELECT CASE (ITOPIC)
!## drn,riv,ghb,chd,olf
CASE (TDRN,TRIV,TGHB,TCHD,TOLF)
ALLOCATE(JEQUAL(NSYS,NTOP))
!## search previous entries
DO IIPER=1,IPER-1
JEQUAL=0
!## get appropriate stress-period to store in runfile
KKPER=PMANAGER_GETCURRENTIPER(IIPER,ITOPIC,ITIME,JTIME)
IF(KKPER.LE.0)CYCLE
!## number of systems
DO ISYS=1,NSYS
!## number of subtopics
DO KTOP=1,NTOP
ICNST =TOPICS(ITOPIC)%STRESS(KPER)%FILES(KTOP,ISYS)%ICNST
CNST =TOPICS(ITOPIC)%STRESS(KPER)%FILES(KTOP,ISYS)%CNST
FCT =TOPICS(ITOPIC)%STRESS(KPER)%FILES(KTOP,ISYS)%FCT
IMP =TOPICS(ITOPIC)%STRESS(KPER)%FILES(KTOP,ISYS)%IMP
ILAY =TOPICS(ITOPIC)%STRESS(KPER)%FILES(KTOP,ISYS)%ILAY
SFNAME=TOPICS(ITOPIC)%STRESS(KPER)%FILES(KTOP,ISYS)%FNAME
!## only whenever number of systems are equal
IF(NSYS.EQ.SIZE(TOPICS(ITOPIC)%STRESS(KKPER)%FILES,2))THEN
IF(ICNST.EQ. TOPICS(ITOPIC)%STRESS(KKPER)%FILES(KTOP,ISYS)%ICNST.AND. &
CNST .EQ. TOPICS(ITOPIC)%STRESS(KKPER)%FILES(KTOP,ISYS)%CNST.AND. &
FCT.EQ. TOPICS(ITOPIC)%STRESS(KKPER)%FILES(KTOP,ISYS)%FCT.AND. &
IMP .EQ. TOPICS(ITOPIC)%STRESS(KKPER)%FILES(KTOP,ISYS)%IMP.AND. &
ILAY.EQ. TOPICS(ITOPIC)%STRESS(KKPER)%FILES(KTOP,ISYS)%ILAY.AND. &
SFNAME.EQ.TOPICS(ITOPIC)%STRESS(KKPER)%FILES(KTOP,ISYS)%FNAME)THEN
JEQUAL(ISYS,KTOP)=IIPER
ENDIF
ENDIF
ENDDO
ENDDO
!## there is a previous definition of this package exported allready and can be reused
IF(MINVAL(JEQUAL).EQ.MAXVAL(JEQUAL).AND.MINVAL(JEQUAL).NE.0)THEN
IF(NP_IPER(IIPER).GT.0)THEN
EXFNAME=TRIM(DIR)//'\'//CPCK//'7\'//CPCK//'_T'//TRIM(ITOS(IIPER))//'.ARR'
SFNAME=EXFNAME; DO I=1,3; SFNAME=SFNAME(:INDEX(SFNAME,'\',.TRUE.)-1); ENDDO
I=LEN_TRIM(SFNAME); SFNAME='.'//EXFNAME(I+1:)
LINE=TRIM(ITOS(NP_IPER(IIPER))); WRITE(IU,'(A)') TRIM(LINE)
WRITE(IU,'(A)') 'OPEN/CLOSE '//TRIM(SFNAME)//' 1.0D0 (FREE) -1'
NP_IPER(IPER)=NP_IPER(IIPER)
ENDIF
EXIT
ENDIF
ENDDO
IF(ALLOCATED(JEQUAL))DEALLOCATE(JEQUAL)
END SELECT
!## next timestep
IF(NP_IPER(IPER).GT.0)CYCLE
!## open external file (not for rch/evt)
IF(PBMAN%IFORMAT.GE.2)THEN
JU=0
SELECT CASE (ITOPIC)
CASE (TDRN,TRIV,TGHB,TOLF,TCHD,TISG)
!## create subfolders
CALL UTL_CREATEDIR(TRIM(DIR)//'\'//CPCK//VTXT)
EXFNAME=TRIM(DIR)//'\'//CPCK//VTXT//'\'//CPCK//'_T'//TRIM(ITOS(IPER))//'.ARR'
JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=EXFNAME,STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(JU.EQ.0)RETURN
!## rch/evt for mf6
CASE (TEVT,TRCH)
IF(PBMAN%IFORMAT.EQ.3)THEN
!## create subfolders
CALL UTL_CREATEDIR(TRIM(DIR)//'\'//CPCK//VTXT)
EXFNAME=TRIM(DIR)//'\'//CPCK//VTXT//'\'//CPCK//'_T'//TRIM(ITOS(IPER))//'.ARR'
JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=EXFNAME,STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(JU.EQ.0)RETURN
ENDIF
END SELECT
IF(PBMAN%IFORMAT.EQ.3)WRITE(IU,'(/A)') 'BEGIN PERIOD '//TRIM(ITOS(IPER))
ELSE
JU=IU
ENDIF
!## number of systems
DO ISYS=1,NSYS
!## number of subtopics
DO KTOP=1,NTOP
ICNST =TOPICS(ITOPIC)%STRESS(KPER)%FILES(KTOP,ISYS)%ICNST
CNST =TOPICS(ITOPIC)%STRESS(KPER)%FILES(KTOP,ISYS)%CNST
FCT =TOPICS(ITOPIC)%STRESS(KPER)%FILES(KTOP,ISYS)%FCT
IMP =TOPICS(ITOPIC)%STRESS(KPER)%FILES(KTOP,ISYS)%IMP
ILAY =TOPICS(ITOPIC)%STRESS(KPER)%FILES(KTOP,ISYS)%ILAY
SFNAME=TOPICS(ITOPIC)%STRESS(KPER)%FILES(KTOP,ISYS)%FNAME
!## ilay equal zero not possible for rch and evt
IF(ITOPIC.EQ.TEVT.OR.ITOPIC.EQ.TRCH)THEN
IF(ILAY.EQ.0)THEN
IF(IBATCH.EQ.0)CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'You cannot apply a layer code of zero for RCH or EVT','Error')
IF(IBATCH.EQ.1)WRITE(*,'(/A/)') 'You cannot apply a layer code of zero for RCH or EVT'
RETURN
ENDIF
ENDIF
!## check to see whether equal to previous timestep
IEQUAL=1
SELECT CASE (ITOPIC)
!## uzf,evt,rch
CASE (TUZF,TEVT,TRCH)
IF(LPER.GT.0)THEN
!## only whenever number of systems are equal
IF(NSYS.EQ.SIZE(TOPICS(ITOPIC)%STRESS(LPER)%FILES,2))THEN
IF(ICNST.EQ. TOPICS(ITOPIC)%STRESS(LPER)%FILES(KTOP,ISYS)%ICNST.AND. &
CNST .EQ. TOPICS(ITOPIC)%STRESS(LPER)%FILES(KTOP,ISYS)%CNST.AND. &
FCT.EQ. TOPICS(ITOPIC)%STRESS(LPER)%FILES(KTOP,ISYS)%FCT.AND. &
IMP .EQ. TOPICS(ITOPIC)%STRESS(LPER)%FILES(KTOP,ISYS)%IMP.AND. &
ILAY.EQ. TOPICS(ITOPIC)%STRESS(LPER)%FILES(KTOP,ISYS)%ILAY.AND. &
SFNAME.EQ.TOPICS(ITOPIC)%STRESS(LPER)%FILES(KTOP,ISYS)%FNAME)IEQUAL=-1
ENDIF
ENDIF
END SELECT
WRITE(IPRT,'(1X,A,I3,A1,I1,A1,I4.3,3(A1,G15.7),A1,A)') TOPICS(ITOPIC)%TNAME(1:5)//',', &
ISYS,',',ICNST,',',ILAY,',',FCT,',',IMP,',',CNST,',',CHAR(39)//TRIM(SFNAME)//CHAR(39)
SELECT CASE (ITOPIC)
!## uzf
CASE (TUZF)
SELECT CASE (KTOP)
CASE (1); SCL_D=0; SCL_U=7 !## boundary
CASE (2); SCL_D=0; SCL_U=7 !## brook-corey
CASE (3:4); SCL_D=0; SCL_U=2 !## thts/thhi
CASE (5); SCL_D=0; SCL_U=2; NUZF1=IEQUAL
CASE (6); SCL_D=0; SCL_U=2; NUZF2=IEQUAL
CASE (7); SCL_D=0; SCL_U=2; NUZF3=IEQUAL
CASE (8); SCL_D=0; SCL_U=2; NUZF4=IEQUAL
END SELECT
!## skip uzf package info for coming stress-periods
IF(KTOP.LE.4.AND.IPER.GT.1)CYCLE
!## evt
CASE (TEVT)
SCL_D=1
!## check to see whether equal to previous timestep
SELECT CASE (KTOP)
CASE (1); INSURF=IEQUAL; SCL_U=2
CASE (2); INEVTR=IEQUAL; SCL_U=16
CASE (3); INEXDP=IEQUAL; SCL_U=2
END SELECT
!## rch
CASE (TRCH)
SCL_D=1; SCL_U=16 !## average
!## equal from previous timestep
INRECH=IEQUAL
!## drn,riv,ghb
CASE (TDRN,TRIV,TGHB)
IF(KTOP.EQ.1)THEN; SCL_D=0; SCL_U=5; ENDIF
IF(KTOP.NE.1)THEN; SCL_D=0; SCL_U=2; ENDIF
!## chd,olf
CASE (TCHD,TOLF)
SCL_D=1; SCL_U=2
!## fhb
CASE (TFHB)
SCL_D=1
IF(KTOP.EQ.1)SCL_U=5 !## q - sum (divide if cell is smaller)
IF(KTOP.EQ.2)SCL_U=2 !## h - average
CASE DEFAULT
WRITE(*,'(/A)') 'CANNOT COME HERE: ERROR PMANAGER_SAVEMF2005_PCK - SETTING SCALING FACTORS'
WRITE(*,'(A,I10)') 'ITOPIC=',ITOPIC
WRITE(*,'(A)') TRIM(TOPICS(ITOPIC)%TNAME)
PAUSE; STOP
END SELECT
PCK(KTOP)%ILAY=ILAY
!## skip this one - no to be read
IF(IEQUAL.EQ.-1)CYCLE
!## constant value
IF(ICNST.EQ.1)THEN
PCK(KTOP)%X=CNST
!## read/clip/scale idf file
ELSEIF(TOPICS(ITOPIC)%STRESS(KPER)%FILES(KTOP,ISYS)%ICNST.EQ.2)THEN
PCK(KTOP)%FNAME=SFNAME
IF(.NOT.IDFREADSCALE(PCK(KTOP)%FNAME,PCK(KTOP),SCL_U,SCL_D,1.0D0,0))RETURN
ENDIF
!## no checking for inactive cells
ICHECK=1
!## rch/evt mm/day -> m/day
SELECT CASE (ITOPIC)
!## uzf
CASE (TUZF)
IF(KTOP.EQ.5.OR.KTOP.EQ.6)FCT=FCT*0.001D0
IF(ILAY.LE.0)NUZTOP=3
!## not checking for inactive cells
ICHECK=0
!## evt
CASE (TEVT)
IF(KTOP.EQ.1)THEN
FCT=FCT*0.001D0
IMP=IMP*0.001D0
ENDIF
IF(ILAY.LT.0)NEVTOP=3
!## checking for inactive cells
ICHECK=1; IF(ILAY.GT.0)ICHECK=0
!## rch
CASE (TRCH)
IF(KTOP.EQ.1)THEN
FCT=FCT*0.001D0
IMP=IMP*0.001D0
ENDIF
IF(ILAY.LT.0)NRCHOP=3
!## checking for inactive cells
ICHECK=1; IF(ILAY.GT.0)ICHECK=0
END SELECT
CALL PMANAGER_SAVEMF2005_FCTIMP(0,ICNST,PCK(KTOP),FCT,IMP,SCL_D)
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,PCK(KTOP),ICHECK,ITOPIC)
ENDDO
SELECT CASE (ITOPIC)
!## uzf
CASE (TUZF)
IF(IPER.EQ.1)THEN
!## make sure value for uzbnd is zero for constant head and inactive cells - only if NUZTOP.eq.1
IF(NUZTOP.EQ.1)THEN
DO IROW=1,PCK(1)%NROW; DO ICOL=1,PCK(1)%NCOL
IF(BND(1)%X(ICOL,IROW).LE.0)PCK(1)%X(ICOL,IROW)=0.0D0
ENDDO; ENDDO
!## make sure entered uzbnd with top layer is equal to the top elevation - otherwise solve the conflict
ELSEIF(NUZTOP.EQ.3)THEN
DO IROW=1,PCK(1)%NROW; DO ICOL=1,PCK(1)%NCOL
!## assigned layer
I=PCK(1)%X(ICOL,IROW)
!## skip this one as it is an inactive cell
IF(I.LE.0)CYCLE
!## search first active layer
DO ILAY=1,PRJNLAY; IF(BND(ILAY)%X(ICOL,IROW).GT.0)EXIT; ENDDO
!## overrule for the first active layer
IF(ILAY.LE.PRJNLAY)THEN
IF(PCK(1)%X(ICOL,IROW).LT.0)PCK(1)%X(ICOL,IROW)=SIGN(ILAY,I)
IF(ILAY.EQ.1)PCK(1)%X(ICOL,IROW)=1.0D0
ENDIF
ENDDO; ENDDO
ENDIF
!## areal extent of uz flow
IF(.NOT.PMANAGER_SAVEMF2005_PCK_U2DREL(TRIM(DIR)//'\'//CPCK//'7\'//CPCK//'_UZBND_T'//TRIM(ITOS(IPER))//'.ARR',PCK(1),IU, 0,1))RETURN
!## brooks-corey epsilon
IF(.NOT.PMANAGER_SAVEMF2005_PCK_U2DREL(TRIM(DIR)//'\'//CPCK//'7\'//CPCK//'_EPS_T'//TRIM(ITOS(IPER))// '.ARR',PCK(2),IU,IFBND,0))RETURN
!## thts saturated water content
IF(.NOT.PMANAGER_SAVEMF2005_PCK_U2DREL(TRIM(DIR)//'\'//CPCK//'7\'//CPCK//'_THTS_T'//TRIM(ITOS(IPER))// '.ARR',PCK(3),IU,IFBND,0))RETURN
!## skip initial water content if steady-state
IF(SIM(IPER)%DELT.GT.0.0D0)THEN
IF(.NOT.PMANAGER_SAVEMF2005_PCK_U2DREL(TRIM(DIR)//'\'//CPCK//'7\'//CPCK//'_THTI_T'//TRIM(ITOS(IPER))// '.ARR',PCK(4),IU,IFBND,0))RETURN
ENDIF
! !## log uzf locations
! DO I=1,PBMAN%NLOGLOC
! WRITE(IU,'(4(I10,1X))') PBMAN%ILOC(I,1),PBMAN%ILOC(I,2),99+I,1
! ENDDO
ENDIF
LINE=TRIM(ITOS(NUZF1)); WRITE(IU,'(A)') TRIM(LINE)
IF(NUZF1.EQ.1)THEN
IF(.NOT.PMANAGER_SAVEMF2005_PCK_U2DREL(TRIM(DIR)//'\'//CPCK//'7\'//CPCK//'_FINF_T'//TRIM(ITOS(IPER))// '.ARR',PCK(5),IU,IFBND,0))RETURN
ENDIF
LINE=TRIM(ITOS(NUZF2)); WRITE(IU,'(A)') TRIM(LINE)
IF(NUZF2.EQ.1)THEN
IF(.NOT.PMANAGER_SAVEMF2005_PCK_U2DREL(TRIM(DIR)//'\'//CPCK//'7\'//CPCK//'_PET_T'//TRIM(ITOS(IPER))// '.ARR',PCK(6),IU,IFBND,0))RETURN
ENDIF
LINE=TRIM(ITOS(NUZF3)); WRITE(IU,'(A)') TRIM(LINE)
IF(NUZF3.EQ.1)THEN
IF(.NOT.PMANAGER_SAVEMF2005_PCK_U2DREL(TRIM(DIR)//'\'//CPCK//'7\'//CPCK//'_EXDP_T'//TRIM(ITOS(IPER))// '.ARR',PCK(7),IU,IFBND,0))RETURN
ENDIF
LINE=TRIM(ITOS(NUZF4)); WRITE(IU,'(A)') TRIM(LINE)
IF(NUZF4.EQ.1)THEN
!## make sure this is always larger than residual water content
IF(.NOT.PMANAGER_SAVEMF2005_PCK_U2DREL(TRIM(DIR)//'\'//CPCK//'7\'//CPCK//'_EXTWC_T'//TRIM(ITOS(IPER))//'.ARR',PCK(8),IU,IFBND,0))RETURN
ENDIF
!## rch
CASE (TRCH)
IF(PBMAN%IFORMAT.EQ.2)THEN
LINE=TRIM(ITOS(INRECH)); WRITE(IU,'(A)') TRIM(LINE); IFBND=0; IF(ILAY.GT.0)IFBND=1
IF(INRECH.EQ.1)THEN
IF(.NOT.PMANAGER_SAVEMF2005_PCK_U2DREL(TRIM(DIR)//'\'//CPCK//'7\'//CPCK//'_T'//TRIM(ITOS(IPER))//'.ARR',PCK(1),IU,IFBND,0))RETURN
ENDIF
ELSEIF(PBMAN%IFORMAT.EQ.3)THEN
DO IROW=1,PCK(1)%NROW; DO ICOL=1,PCK(1)%NCOL
!## find uppermost layer
TLP=0.0D0
IF(PCK(1)%ILAY.EQ.-1)THEN
DO ILAY=1,SIZE(PBMAN%ILAY); IF(PBMAN%ILAY(ILAY).EQ.1.AND.BND(ILAY)%X(ICOL,IROW).GT.0)EXIT; ENDDO
!## assign to uppermost active layer
IF(ILAY.LE.PRJNLAY)TLP(ILAY)=1.0D0
ELSE
!## assign to predefined layer
TLP(PCK(1)%ILAY)=1.0D0
ENDIF
JLAY=0; DO ILAY=1,SIZE(PBMAN%ILAY)
IF(PBMAN%ILAY(ILAY).EQ.0)CYCLE; JLAY=JLAY+1
!## skip inactive cells
IF(BND(ILAY)%X(ICOL,IROW).EQ.0.0D0)CYCLE
!## not put into this model layer
IF(TLP(ILAY).LE.0.0D0)CYCLE
WRITE(JU,'(3I10,G15.7)') JLAY,IROW,ICOL,PCK(1)%X(ICOL,IROW)
NP_IPER(IPER)=NP_IPER(IPER)+1
ENDDO
ENDDO; ENDDO
ENDIF
!## evt
CASE (TEVT)
LINE=TRIM(ITOS(INSURF))//','//TRIM(ITOS(INEVTR))//','//TRIM(ITOS(INEXDP)); WRITE(IU,'(A)') TRIM(LINE); IFBND=0; IF(ILAY.GT.0)IFBND=1
IF(INSURF.EQ.1)THEN
IF(.NOT.PMANAGER_SAVEMF2005_PCK_U2DREL(TRIM(DIR)//'\'//CPCK//'7\'//CPCK//'_SURF_T'//TRIM(ITOS(IPER))//'.ARR',PCK(2),IU,IFBND,0))RETURN
ENDIF
IF(INEVTR.EQ.1)THEN
IF(.NOT.PMANAGER_SAVEMF2005_PCK_U2DREL(TRIM(DIR)//'\'//CPCK//'7\'//CPCK//'_EVTR_T'//TRIM(ITOS(IPER))//'.ARR',PCK(1),IU,IFBND,0))RETURN
ENDIF
IF(INEXDP.EQ.1)THEN
IF(.NOT.PMANAGER_SAVEMF2005_PCK_U2DREL(TRIM(DIR)//'\'//CPCK//'7\'//CPCK//'_EXDP_T'//TRIM(ITOS(IPER))//'.ARR',PCK(3),IU,IFBND,0))RETURN
ENDIF
CASE DEFAULT
DO IROW=1,PCK(1)%NROW; DO ICOL=1,PCK(1)%NCOL
!## skip inactive/constant head cells
IF(PCK(1)%ILAY.GT.0.AND.ITOPIC.NE.TCHD)THEN
IF(BND(PCK(1)%ILAY)%X(ICOL,IROW).LE.0.0D0)CYCLE
ENDIF
IF(ITOPIC.EQ.TFHB)THEN
!## check whether one of the two is not equal to nodata
DO I=1,NTOP; IF(PCK(JTOP(I))%X(ICOL,IROW).NE.HNOFLOW)EXIT; ENDDO
!## found no data in either dataset - skip data point
IF(I.GT.NTOP)CYCLE
ELSE
!## check nodata in dataset
DO I=1,NTOP; IF(PCK(JTOP(I))%X(ICOL,IROW).EQ.HNOFLOW)EXIT; ENDDO
!## found any nodata in dataset - skip data point
IF(I.LE.NTOP)CYCLE
ENDIF
!## check bottom river if that is higher than river stage
IF(ITOPIC.EQ.TRIV)PCK(3)%X(ICOL,IROW)=MIN(PCK(2)%X(ICOL,IROW),PCK(3)%X(ICOL,IROW))
!## initially not assigned to any model layer
TLP=0.0D0
!## assign to several layer based upon top/bot
IF(PCK(1)%ILAY.EQ.0)THEN
!## get filter fractions
CALL PMANAGER_SAVEMF2005_PCK_ULSTRD_PARAM(PRJNLAY,ICOL,IROW,TOP,BOT,KDW,TP,BT,KH,.FALSE.)
SELECT CASE (ITOPIC)
CASE (TDRN) !## drn - drainagelevel
Z1=PCK(2)%X(ICOL,IROW); Z2=Z1
CASE (TRIV) !## riv - waterlevel and bottom
Z1=PCK(2)%X(ICOL,IROW); Z2=PCK(3)%X(ICOL,IROW)
CASE (TOLF) !## olf drainagelevel
Z1=PCK(1)%X(ICOL,IROW); Z2=Z1
CASE (TGHB) !## ghb drainagelevel
Z1=PCK(2)%X(ICOL,IROW); Z2=Z1
CASE DEFAULT
WRITE(*,'(/A)') 'CANNOT COME HERE: ERROR PMANAGER_SAVEMF2005_PCK - AUTOM. LAYER ASSIGNMENT'
WRITE(*,'(A,I10)') 'ITOPIC=',ITOPIC
WRITE(*,'(A)') TRIM(TOPICS(ITOPIC)%TNAME)
PAUSE; STOP
END SELECT
!## get fraction per model layer
CALL UTL_PCK_GETTLP(PRJNLAY,TLP,KH,TP,BT,Z1,Z2,MINKHT)
!## find uppermost active layer
ELSEIF(PCK(1)%ILAY.EQ.-1)THEN
DO ILAY=1,PRJNLAY; IF(BND(ILAY)%X(ICOL,IROW).NE.0)EXIT; ENDDO
!## assign to uppermost active layer
IF(ILAY.LE.PRJNLAY)THEN; IF(BND(ILAY)%X(ICOL,IROW).GT.0)TLP(ILAY)=1.0D0; ENDIF
ELSE
!## chd package
IF(ITOPIC.EQ.TCHD)THEN
IF(BND(PCK(1)%ILAY)%X(ICOL,IROW).LT.0)TLP(PCK(1)%ILAY)=1.0D0
!## assign to predefined layer - if not constant or inactive
ELSE
IF(BND(PCK(1)%ILAY)%X(ICOL,IROW).GT.0)TLP(PCK(1)%ILAY)=1.0D0
ENDIF
ENDIF
JLAY=0; DO ILAY=1,SIZE(PBMAN%ILAY)
IF(PBMAN%ILAY(ILAY).EQ.0)CYCLE; JLAY=JLAY+1
!## not put into model layer
IF(TLP(ILAY).LE.0.0D0)CYCLE
!## skip inactive cells - this can happen whenever ilay=0 and stage is above top_l1 or ilay>0 and layer is inactive
IF(BND(ILAY)%X(ICOL,IROW).EQ.0)CYCLE
!## write specific packages
SELECT CASE (ITOPIC)
!## chd
CASE (TCHD)
IF(BND(ILAY)%X(ICOL,IROW).LT.0)THEN
!## check whether constant head is in appropriate cell - if not - skip it.
LCHKCHD=.TRUE.
!## head is in within current layer pck(jtop(1))%x(1,1:50)
IF(PBMAN%ICHKCHD.EQ.1)LCHKCHD=PCK(JTOP(1))%X(ICOL,IROW).GT.BOT(ILAY)%X(ICOL,IROW)
IF(LCHKCHD)THEN
IF(PBMAN%SSYSTEM.EQ.0)THEN
WRITE(JU,FRM) JLAY,IROW,ICOL,PCK(JTOP(1))%X(ICOL,IROW),PCK(JTOP(1))%X(ICOL,IROW),ISYS
ELSE
WRITE(JU,FRM) JLAY,IROW,ICOL,PCK(JTOP(1))%X(ICOL,IROW),PCK(JTOP(1))%X(ICOL,IROW),1
ENDIF
NP_IPER(IPER)=NP_IPER(IPER)+1
ENDIF
ENDIF
!## olf
CASE (TOLF)
OLFCOND=(IDFGETAREA(PCK(JTOP(1)),ICOL,IROW)/COLF) !## drainage conductance
IF(PBMAN%SSYSTEM.EQ.0)THEN
WRITE(JU,FRM) JLAY,IROW,ICOL,PCK(JTOP(1))%X(ICOL,IROW),OLFCOND,ISYS
ELSE
WRITE(JU,FRM) JLAY,IROW,ICOL,PCK(JTOP(1))%X(ICOL,IROW),OLFCOND,1
ENDIF
NP_IPER(IPER)=NP_IPER(IPER)+1
!## fhb
CASE (TFHB)
IF(BND(ILAY)%X(ICOL,IROW).EQ. 2.0)THEN; NFLW=NFLW+1; FHBFLW(NFLW,NBDTIM)=PCK(JTOP(1))%X(ICOL,IROW); ENDIF
IF(BND(ILAY)%X(ICOL,IROW).EQ.-2.0)THEN; NHED=NHED+1; FHBHED(NHED,NBDTIM)=PCK(JTOP(2))%X(ICOL,IROW); ENDIF
CASE DEFAULT
IF(PCK(JTOP(2))%X(ICOL,IROW).GT.0.0D0)THEN
DO I=1,NTOP; XTMP(I)=PCK(I)%X(ICOL,IROW); ENDDO
XTMP(1)=XTMP(1)*TLP(ILAY)
!## in current model (layers)
JSYS=1; IF(PBMAN%SSYSTEM.EQ.0)JSYS=ISYS
WRITE(JU,FRM) JLAY,IROW,ICOL,(XTMP(JTOP(I)),I=1,NTOP),JSYS
NP_IPER(IPER)=NP_IPER(IPER)+1
ENDIF
END SELECT
ENDDO
ENDDO; ENDDO
END SELECT
ENDDO
IF(ITOPIC.NE.TFHB.AND. &
ITOPIC.NE.TUZF.AND. &
ITOPIC.NE.TEVT.AND. &
ITOPIC.NE.TRCH)THEN
LINE=TRIM(ITOS(NP_IPER(IPER))); IF(PBMAN%IFORMAT.EQ.2)WRITE(IU,'(A)') TRIM(LINE)
ENDIF
!## maximum input per simulation
MP=MAX(MP,NP_IPER(IPER))
IF(PBMAN%IFORMAT.EQ.2)THEN
SELECT CASE (ITOPIC)
CASE (TDRN,TRIV,TGHB,TOLF,TCHD)
CALL IDFWRITEFREE_HEADER(JU,PRJIDF)
END SELECT
ENDIF
CLOSE(JU)
IF(PBMAN%IFORMAT.GE.2)THEN
IF(NP_IPER(IPER).GT.0)THEN
SFNAME=EXFNAME
N=3; IF(PBMAN%IFORMAT.EQ.3)N=4; DO I=1,N; SFNAME=SFNAME(:INDEX(SFNAME,'\',.TRUE.)-1); ENDDO
I=LEN_TRIM(SFNAME); SFNAME='.'//EXFNAME(I+1:)
WRITE(IU,'(A)') 'OPEN/CLOSE '//TRIM(SFNAME)//' 1.0 (FREE) -1'
ENDIF
ENDIF
IF(PBMAN%IFORMAT.EQ.3)WRITE(IU,'(A)') 'END PERIOD '
!## store previous stress-period information for this timestep
LPER=KPER
ENDDO
!## write fhb package
IF(ITOPIC.EQ.TFHB)THEN
IF(ALLOCATED(FHBFLW))THEN
LINE=TRIM(ITOS(IFHBUN))//',1.0,1'; WRITE(IU,'(A)') TRIM(LINE)
!## store values in fhb package
I=0; DO ILAY=1,PRJNLAY; DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
IF(BND(ILAY)%X(ICOL,IROW).EQ. 2)THEN
I=I+1; WRITE(IU,'(3(I10,1X),F10.1,99(1X,G15.7))') ILAY,IROW,ICOL,1.0,(FHBFLW(I,J),J=1,NBDTIM)
ENDIF
ENDDO; ENDDO; ENDDO
ENDIF
IF(ALLOCATED(FHBHED))THEN
LINE=TRIM(ITOS(IFHBUN))//',1.0,1'; WRITE(IU,'(A)') TRIM(LINE)
!## store values in fhb package
I=0; DO ILAY=1,PRJNLAY; DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
IF(BND(ILAY)%X(ICOL,IROW).EQ.-2)THEN
I=I+1; WRITE(IU,'(3(I10,1X),F10.1,99(1X,G15.7))') ILAY,IROW,ICOL,1.0,(FHBHED(I,J),J=1,NBDTIM)
ENDIF
ENDDO; ENDDO; ENDDO
ENDIF
ENDIF
CLOSE(IU)
IF(ALLOCATED(TLP)) DEALLOCATE(TLP)
IF(ALLOCATED(TP)) DEALLOCATE(TP)
IF(ALLOCATED(BT)) DEALLOCATE(BT)
IF(ALLOCATED(KH)) DEALLOCATE(KH)
IF(ALLOCATED(XTMP)) DEALLOCATE(XTMP)
CALL PMANAGER_SAVEMF2005_DEALLOCATEPCK()
!## apply nevtop/nrchop options
SELECT CASE(ITOPIC)
CASE (TUZF); NP_IPER(0)=NUZTOP
CASE (TEVT); NP_IPER(0)=NEVTOP
CASE (TRCH)
IF(PBMAN%IFORMAT.EQ.2)NP_IPER(0)=NRCHOP
IF(PBMAN%IFORMAT.EQ.3)NP_IPER(0)=NP_IPER(1)
CASE DEFAULT; NP_IPER(0)=MP
END SELECT
IF(ITOPIC.EQ.TEVT.OR.ITOPIC.EQ.TRCH)THEN
IF(TOPICS(TLAK)%DEFINED.AND.NP_IPER(0).EQ.1)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'It is compulsory to apply the '//TRIM(TOPICS(ITOPIC)%TNAME)//' package to the'//CHAR(13)// &
'first active modellayer in combination with the LAK package.'//CHAR(13)// &
'Assign zero (0) as a model layer for the package','Error')
RETURN
ENDIF
ENDIF
!## mf6 does not allow max dimensions to be zero
IF(PBMAN%IFORMAT.EQ.3)NP_IPER(0)=MAX(1,NP_IPER(0))
CALL UTL_MF2005_MAXNO(TRIM(DIRMNAME)//'.'//CPCK//VTXT//'_',(/NP_IPER(0)/))
IF(ALLOCATED(NP_IPER))DEALLOCATE(NP_IPER)
PMANAGER_SAVEMF2005_PCK=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_PCK
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_LAK_READ(IPER,IPRT,KPER)
!####====================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IPER,IPRT
INTEGER,INTENT(INOUT) :: KPER
INTEGER :: I,ITOPIC,SCL_D,SCL_U,IROW,ICOL,JPER
INTEGER(KIND=8) :: ITIME,JTIME
PMANAGER_SAVEMF2005_LAK_READ=.TRUE.
IF(.NOT.TOPICS(TLAK)%DEFINED)RETURN
PMANAGER_SAVEMF2005_LAK_READ=.FALSE.
!## lak settings - use most frequent
ITOPIC=TLAK
!## initialisation of lake package
IF(IPER.EQ.0)THEN
!## search for first lake definition in time
DO JPER=1,PRJNPER
!## get appropriate input file for first stress-period
KPER=PMANAGER_GETCURRENTIPER(JPER,ITOPIC,ITIME,JTIME)
IF(KPER.GT.0)EXIT
ENDDO
!## nothing found
IF(JPER.GT.PRJNPER)KPER=0
! ELSE
! !## get appropriate input file for first stress-period
! KPER=PMANAGER_GETCURRENTIPER(IPER,ITOPIC,ITIME,JTIME)
! !## nothing found
! IF(IPER.EQ.1.AND.KPER.LE.0)KPER=0
ENDIF
! IF(KPER.LT.0)THEN; PMANAGER_SAVEMF2005_LAK_READ=.TRUE.; RETURN; ENDIF
!## get appropriate filename for first system and i-th subsystem for kper-th period
ALLOCATE(FNAMES(TOPICS(ITOPIC)%NSUBTOPICS),PRJILIST(1)); PRJILIST=ITOPIC
IF(PMANAGER_GETFNAMES(1,1,1,0,KPER).LE.0)RETURN
DO I=1,SIZE(LAK)
SELECT CASE (I)
CASE (1); SCL_D=0; SCL_U=7
CASE DEFAULT; SCL_D=1; SCL_U=2
END SELECT
CALL IDFCOPY(PRJIDF,LAK(I))
IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(LAK(I),ITOPIC,I,SCL_D,SCL_U,0,IPRT))RETURN
IF(I.EQ.1)THEN
!## remove negative lake-numbers and nodata cells
DO IROW=1,BND(1)%NROW; DO ICOL=1,BND(1)%NCOL
IF(LAK(1)%X(ICOL,IROW).LT.0.0D0)LAK(1)%X(ICOL,IROW)=0.0D0
IF(LAK(1)%X(ICOL,IROW).EQ.LAK(1)%NODATA)LAK(1)%X(ICOL,IROW)=0.0D0
ENDDO; ENDDO
ELSE
!## clean rest of input
CALL PMANAGER_SAVEMF2005_CORRECT(1,LAK,LAK(I),0,ITOPIC)
ENDIF
ENDDO
DEALLOCATE(FNAMES,PRJILIST)
PMANAGER_SAVEMF2005_LAK_READ=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_LAK_READ
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_LAK_SAVE(IULAK,IINI,IBATCH,DIR,KPER,DIRMNAME)
!####====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIR
CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: DIRMNAME
INTEGER,INTENT(IN),OPTIONAL :: KPER
INTEGER,INTENT(IN) :: IBATCH,IINI
INTEGER,INTENT(INOUT) :: IULAK
INTEGER :: NSSITR,I,J,IOP,ILAY,ITMP1,IFBND
REAL(KIND=DP_KIND) :: THETA,SSCNCR,LVL,FCT,SURFDEPTH
PMANAGER_SAVEMF2005_LAK_SAVE=.TRUE.
IF(.NOT.TOPICS(TLAK)%DEFINED)RETURN
PMANAGER_SAVEMF2005_LAK_SAVE=.FALSE.
!## initial timestep - open file and write header
IF(KPER.EQ.1)THEN
!## a THETA is automatically set to a value of 1.0D0 for all steady-state stress periods
!## a THETA of 0.5 represents the average lake stage during a time step.
!## a THETA of 1.0D0 represents the lake stage at the end of the time step.
!## a negative THETA of applies for a SURFDEPTH decreases the lakebed conductance for vertical flow across a horizontal lakebed
!## caused both by a groundwater head that is between the lakebed and the lakebed plus SURFDEPTH and a lake stage that is also
!## between the lakebed and the lakebed plus SURFDEPTH. This method provides a smooth transition from a condition of no groundwater
!## discharge to a lake, when groundwater head is below the lakebed, to a condition of increasing groundwater discharge to a lake as
!## groundwater head becomes greater than the elevation of the dry lakebed. The method also allows for the transition of seepage from
!## a lake to groundwater when the lake stage decreases to the lakebed elevation. Values of SURFDEPTH ranging from 0.01D0 to 0.5 have
!## been used successfully in test simulations. SURFDEP is read only if THETA is specified as a negative value.
THETA=-1.0D0; SSCNCR=0.01D0; NSSITR=100; SURFDEPTH=0.25D0
!## read lake package (also adjust ibound for lakes)
IULAK=UTL_GETUNIT(); CALL OSD_OPEN(IULAK,FILE=TRIM(DIRMNAME)//'.LAK7',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IULAK.EQ.0)RETURN
!## set number of lakes
LINE=TRIM(ITOS(NLAKES))//','//TRIM(ITOS(ILAKCB))
WRITE(IULAK,'(A)') TRIM(LINE)
!## set global settings
LINE=TRIM(RTOS(THETA,'G',5))//','//TRIM(ITOS(NSSITR))//','//TRIM(RTOS(SSCNCR,'G',5))//','//TRIM(RTOS(SURFDEPTH,'G',5))
WRITE(IULAK,'(A)') TRIM(LINE)
ENDIF
!## initial timestep
IF(IINI.EQ.1)THEN
!## get initial, minimal and maximal stages per lake
DO I=1,NLAKES
DO J=3,5
SELECT CASE (J)
CASE (3); IOP=1 !## initial (take average value)
CASE (4); IOP=2 !## minimal
CASE (5); IOP=3 !## maximal
END SELECT
IF(.NOT.PMANAGER_SAVEMF2005_LAKE_GETMEANVALUE(LAK(1)%X,LAK(J)%X,ULAKES(I),LVL,IBATCH,IOP))RETURN
IF(J.EQ.3)THEN
LINE=TRIM(RTOS(LVL,'G',5))
ELSE
LINE=TRIM(LINE)//','//TRIM(RTOS(LVL,'G',5))
ENDIF
ENDDO
WRITE(IULAK,'(A)') TRIM(LINE)//' ORIGINAL LAKE IDENTIFICATION: '//TRIM(ITOS(ULAKES(I)))
ENDDO
ITMP1=1; LINE='1,'//TRIM(ITOS(ITMP1))//',0'; WRITE(IULAK,'(A)') TRIM(LINE)
!## save lake identification
IFBND=0
DO ILAY=1,PRJNLAY
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\LAK7\LKARR_L'//TRIM(ITOS(ILAY))//'.ARR', &
LBD(ILAY),1,IULAK,ILAY,IFBND))RETURN
ENDDO
!## get lakebed leakance
IFBND=0
DO ILAY=1,PRJNLAY
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\LAK7\BDLKNC_L'//TRIM(ITOS(ILAY))//'.ARR', &
LCD(ILAY),0,IULAK,ILAY,IFBND))RETURN
ENDDO
!## no connected lakes
LINE=TRIM(ITOS(0))
WRITE(IULAK,'(A)') TRIM(LINE)
ELSE
! ITMP1=1; IF(KPER.EQ.0)ITMP1=0; IF(KPER.LT.0)ITMP1=-1
!## iini=-1 to previous usage of lak settings but renewed read in rch/evt
IF(KPER.GT.0)ITMP1= 1 !SIGN(KPER) !IINI !ABS(IINI)
IF(KPER.LT.0)ITMP1=-1 !SIGN(KPER) !IINI !ABS(IINI)
!## HIER MOET IINI OOK DE WAARDE 1 KUNNEN KRIJGEN ALS ER WEL RCH.EVT MOET WORDEN INGELZEN
LINE='-1,'//TRIM(ITOS(ITMP1))//',0'; WRITE(IULAK,'(A)') TRIM(LINE)
ENDIF
!## get average prcplk,evaplk sum of rnf,wthdrw
IF(ITMP1.GT.0)THEN
IOP=1
DO I=1,NLAKES
DO J=7,10
SELECT CASE (J)
CASE (7,8); IOP=1; FCT=0.01D0 !## prcplk,evaplk
CASE (9); IOP=1; FCT=1.00D0 !## rnf
CASE (10); IOP=1; FCT=1.00D0 !## wthdrw
END SELECT
IF(.NOT.PMANAGER_SAVEMF2005_LAKE_GETMEANVALUE(LAK(1)%X,LAK(J)%X,ULAKES(I),LVL,IBATCH,IOP))RETURN
IF(J.EQ.7)THEN
LINE=TRIM(RTOS(LVL*FCT,'G',5))
ELSE
LINE=TRIM(LINE)//','//TRIM(RTOS(LVL*FCT,'G',5))
ENDIF
ENDDO
WRITE(IULAK,'(A)') TRIM(LINE)
ENDDO
ENDIF
PMANAGER_SAVEMF2005_LAK_SAVE=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_LAK_SAVE
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_SFT_READ(IPRT)
!####====================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IPRT
INTEGER :: ITOPIC,SCL_D,SCL_U,I,IINV,NTOP,NSYS,ISYS,KTOP,ICNST,ILAY
REAL(KIND=DP_KIND) :: FCT,CNST,IMP
CHARACTER(LEN=256) :: SFNAME
PMANAGER_SAVEMF2005_SFT_READ=.TRUE.
!## use sft1
IF(.NOT.TOPICS(TSFT)%DEFINED)RETURN
PMANAGER_SAVEMF2005_SFT_READ=.FALSE.
!## sft settings
ITOPIC=TSFT; IINV=0; SCL_D=1
DO I=1,SIZE(SFT); CALL IDFCOPY(PRJIDF,SFT(I)); ENDDO
!## allocate memory for packages
NTOP=SIZE(TOPICS(ITOPIC)%STRESS(1)%FILES,1); NSYS=SIZE(TOPICS(ITOPIC)%STRESS(1)%FILES,2)
!## number of systems
DO ISYS=1,NSYS
!## number of subtopics
DO KTOP=1,NTOP
ICNST =TOPICS(ITOPIC)%STRESS(1)%FILES(KTOP,ISYS)%ICNST
CNST =TOPICS(ITOPIC)%STRESS(1)%FILES(KTOP,ISYS)%CNST
FCT =TOPICS(ITOPIC)%STRESS(1)%FILES(KTOP,ISYS)%FCT
IMP =TOPICS(ITOPIC)%STRESS(1)%FILES(KTOP,ISYS)%IMP
ILAY =TOPICS(ITOPIC)%STRESS(1)%FILES(KTOP,ISYS)%ILAY
!## always layer
ILAY =1
SFNAME=TOPICS(ITOPIC)%STRESS(1)%FILES(KTOP,ISYS)%FNAME
WRITE(IPRT,'(1X,A,I3,A1,I1,A1,I4.3,3(A1,G15.7),A1,A)') TOPICS(ITOPIC)%TNAME(1:5)//',', &
ISYS,',',ICNST,',',ILAY,',',FCT,',',IMP,',',CNST,',',CHAR(39)//TRIM(SFNAME)//CHAR(39)
!## thickness
IF(KTOP.EQ.1)THEN
!## constant value
IF(ICNST.EQ.1)THEN
SFT(1)%X=CNST
!## read/clip/scale idf file
ELSEIF(TOPICS(ITOPIC)%STRESS(1)%FILES(KTOP,ISYS)%ICNST.EQ.2)THEN
SFT(1)%FNAME=SFNAME
SCL_U=2
IF(.NOT.IDFREADSCALE(SFT(1)%FNAME,SFT(1),SCL_U,SCL_D,1.0D0,0))RETURN
ENDIF
CALL PMANAGER_SAVEMF2005_FCTIMP(0,ICNST,SFT(1),FCT,IMP,SCL_D)
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,SFT(1),0,ITOPIC)
!## most frequent occurence for angles
ELSEIF(KTOP.EQ.2)THEN
!## constant value
IF(ICNST.EQ.1)THEN
SFT(2)%X=CNST
!## read/clip/scale idf file
ELSEIF(TOPICS(ITOPIC)%STRESS(1)%FILES(KTOP,ISYS)%ICNST.EQ.2)THEN
SFT(2)%FNAME=SFNAME
SCL_U=3
IF(.NOT.IDFREADSCALE(SFT(ILAY)%FNAME,SFT(2),SCL_U,SCL_D,1.0D0,0))RETURN
ENDIF
CALL PMANAGER_SAVEMF2005_FCTIMP(0,ICNST,SFT(2),FCT,IMP,SCL_D)
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,SFT(2),0,ITOPIC)
ENDIF
ENDDO
ENDDO
PMANAGER_SAVEMF2005_SFT_READ=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_SFT_READ
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_TDIS(DIRMNAME)
!####====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIRMNAME
INTEGER :: IU,KPER
PMANAGER_SAVEMF2005_TDIS=.TRUE.; IF(PBMAN%IFORMAT.EQ.2)RETURN
!## file already written
IF(PBMAN%ISUBMODEL.GT.1)RETURN
PMANAGER_SAVEMF2005_TDIS=.FALSE.
!## construct pcg-file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.TDIS6',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# TDIS6 File Generated by '//TRIM(UTL_IMODVERSION())
WRITE(IU,'(/A/)') '#General Options'
WRITE(IU,'(A)') 'BEGIN OPTIONS'
WRITE(IU,'(A)') ' TIME_UNITS DAYS'
DO KPER=1,PRJNPER; IF(SIM(KPER)%DELT.GT.0.0D0)EXIT; ENDDO
IF(KPER.LE.PRJNPER)THEN
WRITE(IU,'(A)') ' START_DATE_TIME '//TRIM(ITOS(SIM(KPER)%IYR))//'-'//TRIM(ITOS(SIM(KPER)%IMH))//'-'//TRIM(ITOS(SIM(KPER)%IDY))// &
'T00:00:00TZD+01:00'
ENDIF
WRITE(IU,'(A)') 'END OPTIONS'
WRITE(IU,'(/A/)') '#Time Dimensions'
WRITE(IU,'(A)') 'BEGIN DIMENSIONS'
WRITE(IU,'(A)') ' NPER '//TRIM(ITOS(PRJNPER))
WRITE(IU,'(A)') 'END DIMENSIONS'
WRITE(IU,'(/A/)') '#Stress periods'
WRITE(IU,'(A)') 'BEGIN PERIODDATA'
!## time information
DO KPER=1,PRJNPER
!## set delt.eq.1 otherwise crash in UZF package
IF(SIM(KPER)%DELT.EQ.0.0D0)THEN
LINE=TRIM(RTOS(1.0D0,'G',7))//','// &
TRIM(ITOS(SIM(KPER)%NSTP)) //','// &
TRIM(RTOS(SIM(KPER)%TMULT,'G',7))
ELSE
LINE=TRIM(RTOS(SIM(KPER)%DELT,'G',7))//','// &
TRIM(ITOS(SIM(KPER)%NSTP)) //','// &
TRIM(RTOS(SIM(KPER)%TMULT,'G',7))
ENDIF
LINE=TRIM(LINE)//' ['//TRIM(SIM(KPER)%CDATE)//']'
WRITE(IU,'(A)') ' '//TRIM(LINE)
ENDDO
WRITE(IU,'(A)') 'END PERIODDATA'
CLOSE(IU)
PMANAGER_SAVEMF2005_TDIS=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_TDIS
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_MET(DIR,DIRMNAME)
!####====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME
INTEGER :: IU,KPER,I,N1,N2
PMANAGER_SAVEMF2005_MET=.TRUE.; IF(PBMAN%IFORMAT.EQ.3)RETURN
PMANAGER_SAVEMF2005_MET=.FALSE.
!## write *.nam file(s)
N1=1; N2=1
IF(PBMAN%IPESTP.EQ.1)THEN
N1=-PBMAN%NLINESEARCH; N2=SIZE(PEST%PARAM)
ELSEIF(PBMAN%IIES.EQ.1)THEN
N1=1; N2=PEST%NREALS
ENDIF
DO I=N1,N2
!## skip zero
IF(I.EQ.0)CYCLE
IU=UTL_GETUNIT()
IF(PBMAN%IPESTP+PBMAN%IIES.EQ.0)THEN
CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.MET7',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED')
ELSEIF(PBMAN%IPESTP.EQ.1)THEN
IF(I.GT.0)THEN
IF(PEST%PARAM(I)%PACT.EQ.0.OR.PEST%PARAM(I)%PIGROUP.LT.0)CYCLE
CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'_P#'//TRIM(ITOS(I))//'.MET7',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED')
ELSE
CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'_L#'//TRIM(ITOS(ABS(I)))//'.MET7',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED')
ENDIF
ELSEIF(PBMAN%IIES.EQ.1)THEN
CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'_R#'//TRIM(ITOS(I))//'.MET7',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED')
ENDIF
IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# MET7 File Generated by '//TRIM(UTL_IMODVERSION())
LINE='COORD_XLL '//TRIM(RTOS(PRJIDF%XMIN,'F',3)) ; WRITE(IU,'(A)') TRIM(LINE)
LINE='COORD_YLL '//TRIM(RTOS(PRJIDF%YMIN,'F',3)) ; WRITE(IU,'(A)') TRIM(LINE)
LINE='COORD_XLL_NB '//TRIM(RTOS(PRJIDF%XMIN,'F',3)); WRITE(IU,'(A)') TRIM(LINE)
LINE='COORD_YLL_NB '//TRIM(RTOS(PRJIDF%YMIN,'F',3)); WRITE(IU,'(A)') TRIM(LINE)
LINE='COORD_XUR_NB '//TRIM(RTOS(PRJIDF%XMAX,'F',3)); WRITE(IU,'(A)') TRIM(LINE)
LINE='COORD_YUR_NB '//TRIM(RTOS(PRJIDF%YMAX,'F',3)); WRITE(IU,'(A)') TRIM(LINE)
!## look for first
DO KPER=1,PRJNPER; IF(SIM(KPER)%DELT.GT.0.0D0)EXIT; ENDDO
IF(KPER.LE.PRJNPER)THEN
LINE='STARTTIME YEAR '//TRIM(ITOS(SIM(KPER)%IYR))//' MONTH '//TRIM(ITOS(SIM(KPER)%IMH))//' DAY '//TRIM(ITOS(SIM(KPER)%IDY))
WRITE(IU,'(A)') TRIM(LINE)
ENDIF
IF(PBMAN%IPESTP+PBMAN%IIES.EQ.0)THEN
LINE='RESULTDIR "'//TRIM(DIR(:INDEX(DIR,'\',.TRUE.)-1))//'"'; WRITE(IU,'(A)') TRIM(LINE)
ELSEIF(PBMAN%IPESTP.EQ.1)THEN
IF(I.GT.0)THEN
LINE='RESULTDIR "'//TRIM(DIR(:INDEX(DIR,'\',.TRUE.)-1))//'\IPEST_P#'//TRIM(ITOS(I))//'"'; WRITE(IU,'(A)') TRIM(LINE)
ELSE
LINE='RESULTDIR "'//TRIM(DIR(:INDEX(DIR,'\',.TRUE.)-1))//'\IPEST_L#'//TRIM(ITOS(ABS(I)))//'"'; WRITE(IU,'(A)') TRIM(LINE)
ENDIF
ELSEIF(PBMAN%IIES.EQ.1)THEN
IF(I.GT.0)THEN
LINE='RESULTDIR "'//TRIM(DIR(:INDEX(DIR,'\',.TRUE.)-1))//'\IIES_R#'//TRIM(ITOS(I))//'"'; WRITE(IU,'(A)') TRIM(LINE)
ELSE
LINE='RESULTDIR "'//TRIM(DIR(:INDEX(DIR,'\',.TRUE.)-1))//'\IIES_L#'//TRIM(ITOS(ABS(I)))//'"'; WRITE(IU,'(A)') TRIM(LINE)
ENDIF
ENDIF
IF(PBMAN%IPEST+PBMAN%IPESTP.GT.0)THEN
LINE='IPESTPDIR "'//TRIM(DIR(:INDEX(DIR,'\',.TRUE.)-1))//'"'; WRITE(IU,'(A)') TRIM(LINE)
ENDIF
LINE='SAVEDOUBLE '//TRIM(ITOS(PBMAN%IDOUBLE)); WRITE(IU,'(A)') TRIM(LINE)
CLOSE(IU)
ENDDO
PMANAGER_SAVEMF2005_MET=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_MET
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_HFB(IBATCH,DIRMNAME,IPRT,LTB)
!####====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIRMNAME
INTEGER,INTENT(IN) :: IBATCH,IPRT
LOGICAL,INTENT(IN) :: LTB
INTEGER :: IU,JU,ILAY,ITOPIC,NPHFB,MXFB
INTEGER,ALLOCATABLE,DIMENSION(:) :: IUGEN,IUDAT,NHFBNP
CHARACTER(LEN=1) :: VTXT
PMANAGER_SAVEMF2005_HFB=.TRUE.
IF(.NOT.TOPICS(THFB)%DEFINED)RETURN
PMANAGER_SAVEMF2005_HFB=.FALSE.
VTXT='7'; IF(PBMAN%IFORMAT.EQ.3)VTXT='6'
IF(IBATCH.EQ.0)CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIRMNAME)//'.HFB'//VTXT//'...')
IF(IBATCH.EQ.1)WRITE(*,'(/1X,A)') 'Writing '//TRIM(DIRMNAME)//'.HFB'//VTXT//'...'
!## creating and collect all faults
JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=TRIM(DIRMNAME)//'_HFB.TXT',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED')
ITOPIC=THFB; IF(.NOT.PMANAGER_SAVEMF2005_HFB_COMPUTE(PRJIDF,ITOPIC,JU,BND,TOP,BOT,IPRT,IBATCH))RETURN
!## construct hfb-file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.HFB'//VTXT//'_',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# HFB'//VTXT//' File Generated by '//TRIM(UTL_IMODVERSION())
IF(PBMAN%IFORMAT.EQ.3)THEN
WRITE(IU,'(/A/)') '#General Options'
WRITE(IU,'(A)') 'BEGIN OPTIONS'
! WRITE(IU,'(A)') ' PRINT_INPUT'
WRITE(IU,'(A)') 'END OPTIONS'
WRITE(IU,'(/A/)') '#General Dimensions'
WRITE(IU,'(A)') 'BEGIN DIMENSIONS'
WRITE(IU,'(1X,A)') ' MAXHFB NaN1#'
WRITE(IU,'(A)') 'END DIMENSIONS'
WRITE(IU,'(/A)') 'BEGIN PERIOD 1'
ENDIF
!## is the number of horizontal-flow barrier parameters
NPHFB=0
!## is the number of HFB barriers not defined by parameters
MXFB=0
!## number of faults
ALLOCATE(NHFBNP(PRJNLAY)); NHFBNP=0
!## apply resistances
IF(PBMAN%IFORMAT.EQ.2)THEN
IF(LTB)THEN
WRITE(IU,'(2I10,A)') NPHFB,MXFB,',NaN1# NOPRINT HFBRESIS SYSTEM'
ELSE
WRITE(IU,'(2I10,A)') NPHFB,MXFB,',NaN1# NOPRINT HFBFACT SYSTEM'
ENDIF
ENDIF
ALLOCATE(IUGEN(PRJNLAY),IUDAT(PRJNLAY)); IUGEN=0; IUDAT=0
DO ILAY=1,PRJNLAY
IUGEN(ILAY)=UTL_GETUNIT(); CALL OSD_OPEN(IUGEN(ILAY),FILE=TRIM(DIRMNAME)//'_HFB_L'//TRIM(ITOS(ILAY))//'.GEN', &
STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED')
IF(IUGEN(ILAY).EQ.0)RETURN
IUDAT(ILAY)=UTL_GETUNIT(); CALL OSD_OPEN(IUDAT(ILAY),FILE=TRIM(DIRMNAME)//'_HFB_L'//TRIM(ITOS(ILAY))//'.DAT', &
STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED')
IF(IUDAT(ILAY).EQ.0)RETURN
IF(LTB)THEN
WRITE(IUDAT(ILAY),'(A10,3(1X,A15),6A10)') 'NO','CONF_RESIS','UNCONF_RESIS','FRACTION','SYSTEM','ICOL1','IROW1','ICOL2','IROW2','IBND'
ELSE
WRITE(IUDAT(ILAY),'(A10,1X,A15,6A10)') 'NO','FRACTION','SYSTEM','ICOL1','IROW1','ICOL2','IROW2','IBND'
ENDIF
ENDDO
!## collect all faults
JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=TRIM(DIRMNAME)//'_HFB.TXT',STATUS='OLD',ACTION='READ',FORM='FORMATTED')
CALL PMANAGER_SAVEMF2005_HFB_EXPORT(NHFBNP,IU,JU,IUGEN,IUDAT,PRJIDF,LTB)
DO ILAY=1,PRJNLAY
IF(NHFBNP(ILAY).GT.0)THEN
CLOSE(IUGEN(ILAY)); CLOSE(IUDAT(ILAY))
ELSE
CLOSE(IUGEN(ILAY),STATUS='DELETE'); CLOSE(IUDAT(ILAY),STATUS='DELETE')
ENDIF
ENDDO
DEALLOCATE(IUGEN,IUDAT)
IF(PBMAN%IFORMAT.EQ.3)WRITE(IU,'(A)') 'END PERIOD'
!## close hfb file
CLOSE(IU); CLOSE(JU,STATUS='DELETE')
CALL UTL_MF2005_MAXNO(TRIM(DIRMNAME)//'.HFB'//VTXT//'_',(/SUM(NHFBNP)/))
DEALLOCATE(NHFBNP)
PMANAGER_SAVEMF2005_HFB=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_HFB
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_OCD(DIRMNAME,MAINDIR)
!####====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIRMNAME,MAINDIR
INTEGER :: IU,JU,ILAY,IPER,J,IFLX
PMANAGER_SAVEMF2005_OCD=.FALSE.
JU=0
IF(PBMAN%IFORMAT.EQ.2)THEN
IF(PBMAN%IPESTP.EQ.1)THEN
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'_L.OC',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# OC File Generated by '//TRIM(UTL_IMODVERSION())
JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=TRIM(DIRMNAME)//'_P.OC',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(JU.EQ.0)RETURN
WRITE(JU,'(A)') '# OC File Generated by '//TRIM(UTL_IMODVERSION())
ELSE
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.OC',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# OC File Generated by '//TRIM(UTL_IMODVERSION())
ENDIF
ELSE
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.OC6',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# OC6 File Generated by '//TRIM(UTL_IMODVERSION())
ENDIF
IF(PBMAN%IFORMAT.EQ.3)THEN
WRITE(IU,'(/A/)') '#General Options'
WRITE(IU,'(A)') 'BEGIN OPTIONS'
LSHD=.FALSE.; LBDG=.FALSE.
DO I=1,SIZE(MC(3)%T)
J=MC(3)%T(I)
SELECT CASE (J)
CASE (TCHD,TSHD)
IF(ASSOCIATED(PBMAN%ISAVE(J)%ILAY).AND..NOT.LSHD)THEN
WRITE(IU,'(1X,A)') 'HEAD FILEOUT .\GWF_'//TRIM(ITOS(PBMAN%ISUBMODEL))//'\MODELOUTPUT\HEAD\HEAD.HED'; LSHD=.TRUE.
ENDIF
CASE DEFAULT
IF(ASSOCIATED(PBMAN%ISAVE(J)%ILAY).AND..NOT.LBDG)THEN
WRITE(IU,'(1X,A)') 'BUDGET FILEOUT .\GWF_'//TRIM(ITOS(PBMAN%ISUBMODEL))//'\MODELOUTPUT\BUDGET\BUDGET.CBC'; LBDG=.TRUE.
ENDIF
END SELECT
ENDDO
IF(LSHD)CALL UTL_CREATEDIR(TRIM(MAINDIR)//'\GWF_'//TRIM(ITOS(PBMAN%ISUBMODEL))//'\MODELOUTPUT\HEAD')
IF(LBDG)CALL UTL_CREATEDIR(TRIM(MAINDIR)//'\GWF_'//TRIM(ITOS(PBMAN%ISUBMODEL))//'\MODELOUTPUT\BUDGET')
WRITE(IU,'(A)') 'END OPTIONS'
ENDIF
IF(PBMAN%IFORMAT.EQ.2)THEN
LINE='HEAD SAVE UNIT '//TRIM(ITOS(IHEDUN)); WRITE(IU,'(A)') TRIM(LINE)
IF(JU.GT.0)WRITE(JU,'(A)') TRIM(LINE)
DO IFLX=1,SIZE(TFLX)
IF(ASSOCIATED(PBMAN%ISAVE(TFLX(IFLX))%ILAY))EXIT
ENDDO; IF(IFLX.GT.SIZE(TFLX))IFLX=0
ENDIF
DO IPER=1,PRJNPER
IF(PBMAN%IFORMAT.EQ.2)THEN
LINE='PERIOD '//TRIM(ITOS(IPER))//' STEP '//TRIM(ITOS(SIM(IPER)%NSTP)); WRITE(IU,'(A)') TRIM(LINE)
IF(JU.GT.0)WRITE(JU,'(A)') TRIM(LINE)
LINE='PRINT BUDGET'; WRITE(IU,'(A)') TRIM(LINE)
IF(JU.GT.0)WRITE(JU,'(A)') TRIM(LINE)
!## save all head for l-versions (overwrite given settings)
IF(PBMAN%IPESTP.EQ.1)THEN
LINE='SAVE HEAD'; DO ILAY=1,PRJNLAY; LINE=TRIM(LINE)//' '//TRIM(ITOS(ILAY)); ENDDO; WRITE(IU,'(A)') TRIM(LINE)
ENDIF
IF(ASSOCIATED(PBMAN%ISAVE(TSHD)%ILAY))THEN
IF(PBMAN%ISAVE(TSHD)%ILAY(1).EQ.-1)THEN
LINE='SAVE HEAD'; DO ILAY=1,PRJNLAY; LINE=TRIM(LINE)//' '//TRIM(ITOS(ILAY)); ENDDO
IF(JU.EQ.0)WRITE(IU,'(A)') TRIM(LINE); IF(JU.GT.0)WRITE(JU,'(A)') TRIM(LINE)
ELSE
LINE='SAVE HEAD'; DO ILAY=1,SIZE(PBMAN%ISAVE(TSHD)%ILAY); LINE=TRIM(LINE)//' '//TRIM(ITOS(PBMAN%ISAVE(TSHD)%ILAY(ILAY))); ENDDO
IF(JU.EQ.0)WRITE(IU,'(A)') TRIM(LINE); IF(JU.GT.0)WRITE(JU,'(A)') TRIM(LINE)
ENDIF
ENDIF
!## write output fluxes
IF(IFLX.GT.0)THEN
IF(ASSOCIATED(PBMAN%ISAVE(TFLX(IFLX))%ILAY))THEN
CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%ISAVE(TFLX(IFLX))%ILAY,IBCFCB,IU)
ENDIF
ENDIF
IF(TOPICS(TUZF)%DEFINED)CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%ISAVE(TUZF)%ILAY,IUZFCB1,IU)
IF(TOPICS(TSFR)%DEFINED)CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%ISAVE(TSFR)%ILAY,ISFRCB,IU)
IF(TOPICS(TFHB)%DEFINED)CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%ISAVE(TFHB)%ILAY,IFHBCB,IU)
IF(TOPICS(TDRN)%DEFINED.OR.TOPICS(TOLF)%DEFINED)CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%ISAVE(TDRN)%ILAY,IDRNCB,IU)
IF(TOPICS(TRIV)%DEFINED.OR.TOPICS(TISG)%DEFINED)CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%ISAVE(TRIV)%ILAY,IRIVCB,IU)
IF(TOPICS(TGHB)%DEFINED)CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%ISAVE(TGHB)%ILAY,IGHBCB,IU)
IF(TOPICS(TWEL)%DEFINED)CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%ISAVE(TWEL)%ILAY,IWELCB,IU)
IF(TOPICS(TRCH)%DEFINED)CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%ISAVE(TRCH)%ILAY,IRCHCB,IU)
IF(TOPICS(TEVT)%DEFINED)CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%ISAVE(TEVT)%ILAY,IEVTCB,IU)
IF(TOPICS(TMNW)%DEFINED)CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%ISAVE(TMNW)%ILAY,IWL2CB,IU)
IF(TOPICS(TLAK)%DEFINED)CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%ISAVE(TLAK)%ILAY,ILAKCB,IU)
ELSE
WRITE(IU,'(/A/)') '#Stressperiod Save Options'
WRITE(IU,'(A)') 'BEGIN PERIOD '//TRIM(ITOS(IPER))
IF(LSHD)WRITE(IU,'(A)') ' SAVE HEAD ALL'
IF(LBDG)WRITE(IU,'(A)') ' SAVE BUDGET ALL'
WRITE(IU,'(A)') 'END PERIOD'
ENDIF
ENDDO
CLOSE(IU); IF(JU.GT.0)CLOSE(JU)
PMANAGER_SAVEMF2005_OCD=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_OCD
!####====================================================================
SUBROUTINE PMANAGER_SAVEMF2005_OCD_ISAVE(ISAVE,ID,IU)
!####====================================================================
IMPLICIT NONE
INTEGER,INTENT(IN),POINTER,DIMENSION(:) :: ISAVE
INTEGER,INTENT(IN) :: ID,IU
INTEGER :: I
IF(ASSOCIATED(ISAVE))THEN
IF(ISAVE(1).EQ.-1)THEN
LINE='SAVE BUDGET '//TRIM(ITOS(ID)); DO I=1,PRJNLAY; LINE=TRIM(LINE)//' '//TRIM(ITOS(I)); ENDDO
ELSE
LINE='SAVE BUDGET '//TRIM(ITOS(ID)); DO I=1,SIZE(ISAVE); LINE=TRIM(LINE)//' '//TRIM(ITOS(ISAVE(I))); ENDDO
ENDIF
WRITE(IU,'(A)') TRIM(LINE)
ENDIF
END SUBROUTINE PMANAGER_SAVEMF2005_OCD_ISAVE
!####====================================================================
SUBROUTINE PMANAGER_SAVEMF2005_RUN_ISAVE(ISAVE,CID,IU)
!####====================================================================
IMPLICIT NONE
INTEGER,INTENT(IN),POINTER,DIMENSION(:) :: ISAVE
CHARACTER(LEN=*),INTENT(IN) :: CID
INTEGER,INTENT(IN) :: IU
INTEGER :: I,N
IF(ASSOCIATED(ISAVE))THEN
IF(ISAVE(1).EQ.-1)THEN
LINE='1,1,0'
ELSE
N=SIZE(ISAVE)
LINE='1,'//TRIM(ITOS(N)); DO I=1,SIZE(ISAVE); LINE=TRIM(LINE)//','//TRIM(ITOS(ISAVE(I))); ENDDO
ENDIF
ELSE
LINE='1,0'
ENDIF
LINE=TRIM(LINE)//' '//TRIM(CID)
WRITE(IU,'(A)') TRIM(LINE)
END SUBROUTINE PMANAGER_SAVEMF2005_RUN_ISAVE
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_PCG(DIRMNAME)
!####====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIRMNAME
INTEGER :: IU
PMANAGER_SAVEMF2005_PCG=.TRUE.
IF(.NOT.TOPICS(TPCG)%DEFINED)RETURN; IF(PBMAN%IFORMAT.EQ.3)RETURN
PMANAGER_SAVEMF2005_PCG=.FALSE.
!## construct pcg-file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.PCG7',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# PCG7 File Generated by '//TRIM(UTL_IMODVERSION())
CALL PMANAGER_SAVEPCG(IU,2)
CLOSE(IU)
PMANAGER_SAVEMF2005_PCG=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_PCG
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_IMS(DIRMNAME)
!####====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIRMNAME
INTEGER :: IU
PMANAGER_SAVEMF2005_IMS=.TRUE.; IF(PBMAN%IFORMAT.EQ.2)RETURN
PMANAGER_SAVEMF2005_IMS=.FALSE.
!## construct pcg-file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.IMS6',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# IMS6 File Generated by '//TRIM(UTL_IMODVERSION())
WRITE(IU,'(/A/)') '#General options'
WRITE(IU,'(A)') 'BEGIN OPTIONS'
WRITE(IU,'(A)') ' PRINT_OPTION SUMMARY'
! WRITE(IU,'(A)') ' COMPLEXITY '//TRIM(PBMAN%TCOMPLEX) !MODERATE' !## simple complex
IF(TOPICS(TANI)%IACT_MODEL.EQ.1)THEN
WRITE(IU,'(A)') ' COMPLEXITY COMPLEX' !## complex
ELSE
WRITE(IU,'(A)') ' COMPLEXITY MODERATE' !## moderate
ENDIF
WRITE(IU,'(A)') ' CSV_OUTPUT FILEOUT '//TRIM(DIRMNAME(INDEX(DIRMNAME,'\',.TRUE.)+1:))//'.CSV'
WRITE(IU,'(A)') 'END OPTIONS'
!## set by complexity
WRITE(IU,'(/A/)') '#Nonlinear options'
WRITE(IU,'(A)') 'BEGIN NONLINEAR'
! WRITE(IU,'(A,G15.7)') ' OUTER_HCLOSE ',PCG%HCLOSE
! WRITE(IU,'(A,I10)') ' OUTER_MAXIMUM ',PCG%NOUTER
! WRITE(IU,'(A)') ' [UNDER_RELAXATION ]'
! WRITE(IU,'(A)') ' [UNDER_RELAXATION_THETA ]'
! WRITE(IU,'(A)') ' [UNDER_RELAXATION_KAPPA ]'
! WRITE(IU,'(A)') ' [UNDER_RELAXATION_GAMMA ]'
! WRITE(IU,'(A)') ' [UNDER_RELAXATION_MOMENTUM ]'
! WRITE(IU,'(A)') ' [BACKTRACKING_NUMBER ]'
! WRITE(IU,'(A)') ' [BACKTRACKING_TOLERANCE ]'
! WRITE(IU,'(A)') ' [BACKTRACKING_REDUCTION_FACTOR ]'
! WRITE(IU,'(A)') ' [BACKTRACKING_RESIDUAL_LIMIT ]'
WRITE(IU,'(A)') 'END NONLINEAR'
WRITE(IU,'(/A/)') '#Linear options'
WRITE(IU,'(A)') 'BEGIN LINEAR'
! WRITE(IU,'(A,I10)') ' INNER_MAXIMUM ',PCG%NINNER
! WRITE(IU,'(A,G15.7)') ' INNER_HCLOSE ',PCG%HCLOSE
! WRITE(IU,'(A,G15.7)') ' INNER_RCLOSE ',PCG%RCLOSE
! WRITE(IU,'(A)') ' LINEAR_ACCELERATION CG'
! WRITE(IU,'(A,G15.7)') ' RELAXATION_FACTOR ',PCG%RELAX
! WRITE(IU,'(A)') ' [PRECONDITIONER_LEVELS ]'
! WRITE(IU,'(A)') ' [PRECONDITIONER_DROP_TOLERANCE ]'
! WRITE(IU,'(A)') ' [NUMBER_ORTHOGONALIZATIONS ]'
! WRITE(IU,'(A)') ' [SCALING_METHOD ]'
! WRITE(IU,'(A)') ' [REORDERING_METHOD ]'
WRITE(IU,'(A)') 'END LINEAR'
CLOSE(IU)
PMANAGER_SAVEMF2005_IMS=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_IMS
!###======================================================================
SUBROUTINE PMANAGER_SAVEPCG(IU,IOPTION)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IU,IOPTION
!## prj file
IF(IOPTION.EQ.0)THEN
WRITE(IU,'(1X,A)') 'MXITER= '//TRIM(ITOS(PCG%NOUTER))
WRITE(IU,'(1X,A)') 'ITER1= '//TRIM(ITOS(PCG%NINNER))
WRITE(IU,'(1X,A)') 'HCLOSE= '//TRIM(RTOS(PCG%HCLOSE,'G',7))
WRITE(IU,'(1X,A)') 'RCLOSE= '//TRIM(RTOS(PCG%RCLOSE,'G',7))
WRITE(IU,'(1X,A)') 'RELAX= '//TRIM(RTOS(PCG%RELAX,'G',7))
WRITE(IU,'(1X,A)') 'NPCOND= '//TRIM(ITOS(PCG%NPCOND))
WRITE(IU,'(1X,A)') 'IPRPCG= '//TRIM(ITOS(PCG%IPRPCG))
WRITE(IU,'(1X,A)') 'MUTPCG= '//TRIM(ITOS(PCG%MUTPCG))
WRITE(IU,'(1X,A)') 'DAMPPCG= '//TRIM(RTOS(PCG%DAMPPCG,'G',7))
WRITE(IU,'(1X,A)') 'DAMPPCGT='//TRIM(RTOS(PCG%DAMPPCGT,'G',7))
WRITE(IU,'(1X,A)') 'IQERROR= '//TRIM(ITOS(PCG%IQERROR))
WRITE(IU,'(1X,A)') 'QERROR= '//TRIM(RTOS(PCG%QERROR,'G',7))
!## run file
ELSEIF(IOPTION.EQ.1)THEN
!## mf2005 file
ELSEIF(IOPTION.EQ.2)THEN
LINE=TRIM(ITOS(PCG%NOUTER)) //','// &
TRIM(ITOS(PCG%NINNER)) //','// &
TRIM(ITOS(PCG%NPCOND))
WRITE(IU,'(A)') TRIM(LINE)
LINE=TRIM(RTOS(PCG%HCLOSE,'G',5)) //','// &
TRIM(RTOS(PCG%RCLOSE,'G',5)) //','// &
TRIM(RTOS(PCG%RELAX ,'G',5)) //','// &
TRIM(RTOS(1.0D0,'G',5)) //','// &
TRIM(ITOS(PCG%IPRPCG)) //','// &
TRIM(ITOS(PCG%MUTPCG)) //','// &
TRIM(RTOS(PCG%DAMPPCG ,'G',5)) //','// &
TRIM(RTOS(PCG%DAMPPCGT ,'G',5))
WRITE(IU,'(A)') TRIM(LINE)
ENDIF
END SUBROUTINE PMANAGER_SAVEPCG
!###======================================================================
LOGICAL FUNCTION PMANAGER_LOADPCG(IU)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IU
INTEGER :: IOS
PMANAGER_LOADPCG=.FALSE.
!## prj file
READ(IU,'(A256)') LINE
READ(LINE,*,IOSTAT=IOS) PCG%NOUTER,PCG%NINNER,PCG%HCLOSE,PCG%RCLOSE,PCG%RELAX,PCG%NPCOND, &
PCG%IPRPCG,PCG%MUTPCG,PCG%DAMPPCG,PCG%DAMPPCGT,PCG%IQERROR,PCG%QERROR
IF(IOS.NE.0)THEN
PCG%IQERROR=0; PCG%QERROR=0.0D0
READ(LINE,*,IOSTAT=IOS) PCG%NOUTER,PCG%NINNER,PCG%HCLOSE,PCG%RCLOSE,PCG%RELAX,PCG%NPCOND, &
PCG%IPRPCG,PCG%MUTPCG,PCG%DAMPPCG,PCG%DAMPPCGT
ENDIF
!## try new style
IF(IOS.NE.0)THEN
BACKSPACE(IU)
IF(.NOT.UTL_READINITFILE('MXITER',LINE,IU,0))RETURN; READ(LINE,*) PCG%NOUTER
IF(.NOT.UTL_READINITFILE('ITER1',LINE,IU,0))RETURN; READ(LINE,*) PCG%NINNER
IF(.NOT.UTL_READINITFILE('HCLOSE',LINE,IU,0))RETURN; READ(LINE,*) PCG%HCLOSE
IF(.NOT.UTL_READINITFILE('RCLOSE',LINE,IU,0))RETURN; READ(LINE,*) PCG%RCLOSE
IF(.NOT.UTL_READINITFILE('RELAX',LINE,IU,0))RETURN; READ(LINE,*) PCG%RELAX
IF(.NOT.UTL_READINITFILE('NPCOND',LINE,IU,0))RETURN; READ(LINE,*) PCG%NPCOND
IF(.NOT.UTL_READINITFILE('IPRPCG',LINE,IU,0))RETURN; READ(LINE,*) PCG%IPRPCG
IF(.NOT.UTL_READINITFILE('MUTPCG',LINE,IU,0))RETURN; READ(LINE,*) PCG%MUTPCG
IF(.NOT.UTL_READINITFILE('DAMPPCG',LINE,IU,0))RETURN; READ(LINE,*) PCG%DAMPPCG
IF(.NOT.UTL_READINITFILE('DAMPPCGT',LINE,IU,0))RETURN; READ(LINE,*) PCG%DAMPPCGT
IF(.NOT.UTL_READINITFILE('IQERROR',LINE,IU,0))RETURN; READ(LINE,*) PCG%IQERROR
IF(.NOT.UTL_READINITFILE('QERROR',LINE,IU,0))RETURN; READ(LINE,*) PCG%QERROR
ENDIF
PMANAGER_LOADPCG=.TRUE.
END FUNCTION PMANAGER_LOADPCG
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_PKS(DIRMNAME)
!####====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIRMNAME
INTEGER :: IU,NP
PMANAGER_SAVEMF2005_PKS=.TRUE.; IF(PBMAN%IFORMAT.EQ.3)RETURN; IF(.NOT.LPKS)RETURN
PMANAGER_SAVEMF2005_PKS=.FALSE.
!## a single processor used
NP=1
!## construct pcg-file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.PKS',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# PKS File Generated by '//TRIM(UTL_IMODVERSION())
!## number of processors
LINE='ISOLVER '//TRIM(ITOS(NP)); WRITE(IU,'(A)') TRIM(LINE)
!## preconditioner
LINE='NPC '//TRIM(ITOS(2)); WRITE(IU,'(A)') TRIM(LINE)
LINE='HCLOSEPKS '//TRIM(RTOS(PCG%HCLOSE,'E',7)); WRITE(IU,'(A)') TRIM(LINE)
LINE='RCLOSEPKS '//TRIM(RTOS(PCG%RCLOSE,'E',7)); WRITE(IU,'(A)') TRIM(LINE)
LINE='MXITER '//TRIM(ITOS(PCG%NOUTER)); WRITE(IU,'(A)') TRIM(LINE)
LINE='INNERIT '//TRIM(ITOS(PCG%NINNER)); WRITE(IU,'(A)') TRIM(LINE)
LINE='RELAX '//TRIM(RTOS(PCG%RELAX,'E',7)); WRITE(IU,'(A)') TRIM(LINE)
WRITE(IU,'(A)') 'END'
CLOSE(IU)
PMANAGER_SAVEMF2005_PKS=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_PKS
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_MSP(DIR,DIRMNAME,IBATCH,IPRT)
!####====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME
INTEGER,INTENT(IN) :: IBATCH,IPRT
INTEGER :: ISYS,ILAY,ITOPIC,IPER,IINV,SCL_U,SCL_D
INTEGER :: I,J,NIDF
REAL(KIND=DP_KIND),DIMENSION(:),ALLOCATABLE :: NODATA
CHARACTER(LEN=256) :: FFNAME,DIRMSP,FNNAME
PMANAGER_SAVEMF2005_MSP=.TRUE.
IF(.NOT.TOPICS(TCAP)%DEFINED)RETURN
PMANAGER_SAVEMF2005_MSP=.FALSE.
IF(IBATCH.EQ.0)CALL WINDOWOUTSTATUSBAR(4,'Writing MetaSwap files ...')
IF(IBATCH.EQ.1)WRITE(*,'(/1X,A)') 'Writing MetaSwap files ...'
NIDF=22; ALLOCATE(NODATA(NIDF))
!## allocate memory
IF(ALLOCATED(SIMGRO))DEALLOCATE(SIMGRO); ALLOCATE(SIMGRO(PRJIDF%NCOL,PRJIDF%NROW))
!## initialize unit numbers
INDSB=0; IAREA=0; ISELSVAT=0; IGWMP=0; IMODSIM=0; ISCAP=0; IINFI=0; IIDF=0; IDFM_MSWP=0; IMSWP_DFM=0
DIRMSP=DIR(:INDEX(DIR,'\',.TRUE.)-1)//'\MSWAPINPUT'
!## open indsb
FFNAME=TRIM(DIRMSP)//'\SVAT2SWNR_ROFF.INP'; INDSB=UTL_GETUNIT(); CALL OSD_OPEN(INDSB,FILE=FFNAME,STATUS='UNKNOWN',ACTION='WRITE')
!## OPEN IAREA
FFNAME=TRIM(DIRMSP)//'\AREA_SVAT.INP'; IAREA=UTL_GETUNIT(); CALL OSD_OPEN(IAREA,FILE=FFNAME,STATUS='UNKNOWN',ACTION='WRITE')
!## OPEN ISCAP
FFNAME=TRIM(DIRMSP)//'\SCAP_SVAT.INP'; ISCAP=UTL_GETUNIT(); CALL OSD_OPEN(ISCAP,FILE=FFNAME,STATUS='UNKNOWN',ACTION='WRITE')
!## OPEN IGWMP
FFNAME=TRIM(DIRMSP)//'\MOD2SVAT.INP'; IGWMP=UTL_GETUNIT(); CALL OSD_OPEN(IGWMP,FILE=FFNAME,STATUS='UNKNOWN',ACTION='WRITE')
!## open MODFLOW dxc file
FFNAME=TRIM(DIRMNAME)//'.DXC'; IDXC=UTL_GETUNIT(); CALL OSD_OPEN(IDXC,FILE=FFNAME,STATUS='UNKNOWN',ACTION='WRITE')
!## OPEN MOD-SIM.TXT
FFNAME=TRIM(DIRMSP)//'\MOD-SIM.TXT'; IMODSIM=UTL_GETUNIT(); CALL OSD_OPEN(IMODSIM,FILE=FFNAME,STATUS='UNKNOWN',ACTION='WRITE')
!## OPEN ISELSVAT
FFNAME=TRIM(DIRMSP)//'\SEL_SVAT_BDA.INP'; ISELSVAT=UTL_GETUNIT(); CALL OSD_OPEN(ISELSVAT,FILE=FFNAME,STATUS='UNKNOWN',ACTION='WRITE')
!## OPEN INFI_SVAT.INP
FFNAME=TRIM(DIRMSP)//'\INFI_SVAT.INP'; IINFI=UTL_GETUNIT(); OPEN(IINFI,FILE=FFNAME,STATUS='UNKNOWN',CARRIAGECONTROL='LIST',ACTION='WRITE')
!## OPEN IDF_SVAT.INP
FFNAME=TRIM(DIRMSP)//'\IDF_SVAT.INP'; IIDF=UTL_GETUNIT(); CALL OSD_OPEN(IIDF,FILE=FFNAME,STATUS='UNKNOWN',ACTION='WRITE')
!## OPEN USCL_SVAT.INP
FFNAME=TRIM(DIRMSP)//'\USCL_SVAT.INP'; IUSCL=UTL_GETUNIT(); CALL OSD_OPEN(IUSCL,FILE=FFNAME,STATUS='UNKNOWN',ACTION='WRITE')
!## OPEN Dfm2dToMsw_WL.DMM
FFNAME=TRIM(DIRMSP)//'\DFM2DTOMSW_WL.DMM_'; IDFM_MSWP=UTL_GETUNIT(); CALL OSD_OPEN(IDFM_MSWP,FILE=FFNAME,STATUS='UNKNOWN',ACTION='WRITE')
!## OPEN Dfm2dToMsw_WL.DMM
FFNAME=TRIM(DIRMSP)//'\MSWTODFM2D_DPV.DMM_'; IMSWP_DFM=UTL_GETUNIT(); CALL OSD_OPEN(IMSWP_DFM,FILE=FFNAME,STATUS='UNKNOWN',ACTION='WRITE')
!## metaswap
IARMWP=0
IF(TOPICS(TCAP)%IACT_MODEL.EQ.1)THEN
IF(ASSOCIATED(TOPICS(TCAP)%STRESS))THEN
FFNAME=TOPICS(TCAP)%STRESS(1)%FILES(8,1)%FNAME
IF(INDEX(UTL_CAP(FFNAME,'U'),'IPF').GT.0)IARMWP=1
ENDIF
ENDIF
ISYS=0; ILAY=1; ITOPIC=TCAP; IPER=1; IINV=0
ALLOCATE(FNAMES(TOPICS(ITOPIC)%NSUBTOPICS),PRJILIST(1)); PRJILIST=ITOPIC
IF(PMANAGER_GETFNAMES(1,1,1,0,1).LE.0)RETURN
!## open all files
DO ISYS=1,NIDF
!## skip ipf for artificial recharge
IF(IARMWP.EQ.1.AND.ISYS.EQ.8)CYCLE
SELECT CASE (ISYS)
!## bnd
CASE (1); NODATA(ISYS)=-999.99D0; SCL_U=1; SCL_D=0
!## lgn,root,soil,meteo
CASE (2:5,7:9); NODATA(ISYS)=-999.99D0; SCL_U=7; SCL_D=0
!## surf,ponding,ponding,pwtlevel
CASE (6,12,13,20); NODATA(ISYS)=-999.99D0; SCL_U=2; SCL_D=1
!## soilfactor,cond.factor
CASE (21,22); NODATA(ISYS)=-999.99D0; SCL_U=2; SCL_D=0
!## qinfub,qinfru
CASE (18,19); NODATA(ISYS)=-999.99D0; SCL_U=7; SCL_D=0 !6; SCL_D=0
!## runoff,runoff,runon,runon
CASE (14:17); NODATA(ISYS)=-999.99D0; SCL_U=7; SCL_D=0 !6; SCL_D=0
!## wetted area/urban area
CASE (10,11); NODATA(ISYS)=-999.99D0; SCL_U=5; SCL_D=0
END SELECT
!## read in data
IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(PRJIDF,ITOPIC,ISYS,SCL_D,SCL_U,IINV,IPRT))RETURN
SELECT CASE (ISYS)
CASE (1); SIMGRO%IBOUND=INT(PRJIDF%X)
CASE (2); SIMGRO%LGN=INT(PRJIDF%X)
CASE (3); SIMGRO%RZ=PRJIDF%X
CASE (4); SIMGRO%BODEM=INT(PRJIDF%X)
CASE (5); SIMGRO%METEO=INT(PRJIDF%X)
CASE (6); SIMGRO%MV=PRJIDF%X
CASE (7); SIMGRO%BEREGEN=INT(PRJIDF%X)
CASE (8); SIMGRO%BER_LAAG=INT(PRJIDF%X)
CASE (9); SIMGRO%BEREGEN_Q=PRJIDF%X
CASE (10); SIMGRO%NOPP=PRJIDF%X
CASE (11); SIMGRO%SOPP=PRJIDF%X
CASE (12); SIMGRO%VXMU_SOPP=PRJIDF%X
CASE (13); SIMGRO%VXMU_ROPP=PRJIDF%X
CASE (14); SIMGRO%CRUNOFF_SOPP=PRJIDF%X
CASE (15); SIMGRO%CRUNOFF_ROPP=PRJIDF%X
CASE (16); SIMGRO%CRUNON_SOPP=PRJIDF%X
CASE (17); SIMGRO%CRUNON_ROPP=PRJIDF%X
CASE (18); SIMGRO%QINFBASIC_SOPP=PRJIDF%X
CASE (19); SIMGRO%QINFBASIC_ROPP=PRJIDF%X
CASE (20); SIMGRO%PWT_LEVEL=PRJIDF%X
CASE (21); SIMGRO%MOISTURE=PRJIDF%X
CASE (22); SIMGRO%COND=PRJIDF%X
END SELECT
ENDDO
IF(.NOT.TOPICS(TPWT)%DEFINED)SIMGRO%PWT_LEVEL=NODATA(20)
!## check input parameters
CALL PMANAGER_SAVEMF2005_MSP_CHECK(NODATA)
ISYS=8
CALL PMANAGER_SAVEMF2005_MSP_INPFILES(NODATA(20),TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISYS,ILAY)%FNAME,TOPICS(TPWT)%DEFINED,DIRMSP)
!## write extra files
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%INPFILES))THEN
J=SIZE(TOPICS(ITOPIC)%STRESS(1)%INPFILES)
DO I=1,J
FFNAME=UTL_CAP(TOPICS(ITOPIC)%STRESS(1)%INPFILES(I),'U')
IF(INDEX(FFNAME,'METE_GRID.INP').GT.0)THEN
CALL METASWAP_METEGRID1(FFNAME,TRIM(DIRMSP)//'\METE_GRID.INP')
ELSEIF(INDEX(FFNAME,'PARA_SIM.INP').GT.0)THEN
CALL PMANAGER_SAVEMF2005_MSP_PARASIM(FFNAME,DIRMSP)
ELSE
FNNAME=TRIM(DIRMSP)//'\'//TRIM(FFNAME(INDEX(FFNAME,'\',.TRUE.)+1:))
CALL SYSTEM('COPY "'//TRIM(FFNAME)//'" "'//TRIM(FNNAME)//'" /Y ')
ENDIF
ENDDO
ENDIF
!## metaswap 727 computing with recharge (possibility) if mete_grid.inp exists
CALL METASWAP_METEGRID2(TRIM(DIRMSP))
DEALLOCATE(SIMGRO,NODATA)
PMANAGER_SAVEMF2005_MSP=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_MSP
!###====================================================================
SUBROUTINE PMANAGER_SAVEMF2005_MSP_PARASIM(FNAME,DIRMSP)
!###====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: FNAME,DIRMSP
INTEGER :: IU,JU,I,IOS,IC1,IC2,IR1,IR2,SNCOL,SNROW
REAL(KIND=DP_KIND) :: X1,Y1,TINY
CHARACTER(LEN=256) :: S,S1,S2,RUNDIR
I=INDEX(FNAME,'\',.TRUE.)
!## get working director
CALL IOSDIRNAME(RUNDIR)
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=FNAME,STATUS='OLD',ACTION='READ')
JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=TRIM(DIRMSP)//'\PARA_SIM.INP',STATUS='REPLACE',ACTION='WRITE')
DO
READ(IU,'(A256)',IOSTAT=IOS) LINE
IF(IOS.NE.0)EXIT
S=TRIM(ADJUSTL(LINE)); S=UTL_CAP(S,'L')
IF(S(1:14).EQ.'unsa_svat_path')THEN
I=INDEX(LINE,'=')
S1=ADJUSTL(LINE(I+1:LEN_TRIM(LINE)))
READ(S1,*) S2
CALL UTL_REL_TO_ABS(RUNDIR,S2)
LINE=LINE(1:I)//' "'//TRIM(S2)//'"'
END IF
!## do not copy simgro_opt settings if existing
IF(INDEX(TRIM(S),'simgro_opt').EQ.0)WRITE(JU,'(A)') TRIM(LINE)
ENDDO
CLOSE(IU)
TINY=0.001D0
CALL POL1LOCATE(PRJIDF%SX,PRJIDF%NCOL+1,PRJIDF%XMIN+TINY,IC1)
CALL POL1LOCATE(PRJIDF%SX,PRJIDF%NCOL+1,PRJIDF%XMAX-TINY,IC2)
CALL POL1LOCATE(PRJIDF%SY,PRJIDF%NROW+1,PRJIDF%YMAX-TINY,IR1)
CALL POL1LOCATE(PRJIDF%SY,PRJIDF%NROW+1,PRJIDF%YMIN+TINY,IR2)
!## check to make sure dimensions are within bounds!
IC1 = MAX(1,IC1); IC2 = MIN(IC2,PRJIDF%NCOL)
IR1 = MAX(1,IR1); IR2 = MIN(IR2,PRJIDF%NROW)
SNCOL=(IC2-IC1)+1; SNROW=(IR2-IR1)+1
X1=PRJIDF%XMIN
Y1=PRJIDF%YMIN
WRITE(JU,'(A)') '*'
WRITE(JU,'(A)') '* Parameters for IDF output'
WRITE(JU,'(A)') '*'
WRITE(JU,'(A)') ' simgro_opt = -1 ! simgro output file'
WRITE(JU,'(A)') ' idf_per = 1 ! Writing IDF files'
LINE=' idf_xmin = '//TRIM(RTOS(X1,'G',7))
WRITE(JU,'(A)') TRIM(LINE)
LINE=' idf_ymin = '//TRIM(RTOS(Y1,'G',7))
WRITE(JU,'(A)') TRIM(LINE)
LINE=' idf_dx = '//TRIM(RTOS(PRJIDF%DX,'G',7))
WRITE(JU,'(A)') TRIM(LINE)
LINE=' idf_dy = '//TRIM(RTOS(PRJIDF%DY,'G',7))
WRITE(JU,'(A)') TRIM(LINE)
LINE=' idf_ncol = '//TRIM(ITOS(SNCOL))
WRITE(JU,'(A)') TRIM(LINE)
LINE=' idf_nrow = '//TRIM(ITOS(SNROW))
WRITE(JU,'(A)') TRIM(LINE)
LINE=' idf_nodata = '//TRIM(RTOS(-9999.00D0,'F',2))
WRITE(JU,'(A)') TRIM(LINE)
CLOSE(JU)
END SUBROUTINE PMANAGER_SAVEMF2005_MSP_PARASIM
!###====================================================================
SUBROUTINE PMANAGER_SAVEMF2005_MSP_INPFILES(NODATA_PWT,IPFFILE,LPWT,DIRMSP)
!###====================================================================
IMPLICIT NONE
LOGICAL :: LPWT
REAL(KIND=DP_KIND),INTENT(IN) :: NODATA_PWT
CHARACTER(LEN=*),INTENT(IN) :: IPFFILE,DIRMSP
INTEGER,PARAMETER :: AEND=0 !## no surfacewater units
INTEGER :: NUND,MDND,IROW,ICOL,LYBE,TYBE,BEREGENID,JROW,JCOL,N,M,I,J,JU,IC1,IC2,IR1,IR2
REAL(KIND=DP_KIND) :: XC,YC,ARND,QBER,FLBE,TINY
TYPE IPFOBJ
INTEGER :: ILAY
REAL(KIND=DP_KIND) :: X,Y,CAP
END TYPE IPFOBJ
TYPE(IPFOBJ),ALLOCATABLE,DIMENSION(:) :: IPF
LOGICAL :: LURBAN
INTEGER :: NDXC, UNID, IACT
INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: DXCID
! INTEGER, DIMENSION(:,:), ALLOCATABLE :: RURALSVATID
IF (ALLOCATED(DXCID)) DEALLOCATE(DXCID)
ALLOCATE(DXCID(PRJIDF%NCOL,PRJIDF%NROW,PRJNLAY))
! ALLOCATE(RURALSVATID(PRJIDF%NCOL,PRJIDF%NROW))
DXCID = 0
NDXC = 0
! RURALSVATID=0
IF(IARMWP.EQ.1)THEN
JU=UTL_GETUNIT(); MDND=0
DO J=1,2
CALL OSD_OPEN(JU,FILE=IPFFILE,ACTION='READ',STATUS='OLD')
READ(JU,*) N; READ(JU,*) M
IF(M.LT.5)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'IPF for artificial recharge should be at least 5 column, x,y,ilay,id,capacity','Error')
RETURN
ENDIF
DO I=1,M+1; READ(JU,*) ; ENDDO
IF(J.EQ.2)THEN; ALLOCATE(IPF(MDND)); IPF%ILAY=0; IPF%CAP=0.0D0; ENDIF
DO I=1,N
READ(JU,*) XC,YC,LYBE,NUND,QBER
IF(J.EQ.1)MDND=MAX(MDND,NUND)
IF(J.EQ.2)THEN; IPF(NUND)%X=XC; IPF(NUND)%Y=YC; IPF(NUND)%ILAY=LYBE; IPF(NUND)%CAP=QBER; ENDIF
ENDDO
CLOSE(JU)
ENDDO
ENDIF
!## get window of interest
TINY=0.001D0
CALL POL1LOCATE(PRJIDF%SX,PRJIDF%NCOL+1,PRJIDF%XMIN+TINY,IC1)
CALL POL1LOCATE(PRJIDF%SX,PRJIDF%NCOL+1,PRJIDF%XMAX-TINY,IC2)
CALL POL1LOCATE(PRJIDF%SY,PRJIDF%NROW+1,PRJIDF%YMAX-TINY,IR1)
CALL POL1LOCATE(PRJIDF%SY,PRJIDF%NROW+1,PRJIDF%YMIN+TINY,IR2)
!## check to make sure dimensions are within bounds!
IC1=MAX(1,IC1); IC2=MIN(IC2,PRJIDF%NCOL)
IR1=MAX(1,IR1); IR2=MIN(IR2,PRJIDF%NROW)
WRITE(IDFM_MSWP,'(A)') 'NaN1#'
WRITE(IMSWP_DFM,'(A)') 'NaN1#'
DO IACT=1,2
NUND=0; UNID=0
DO IROW=1,PRJIDF%NROW
DO ICOL=1,PRJIDF%NCOL
LURBAN=.FALSE.
IF(SIMGRO(ICOL,IROW)%IBOUND.LE.0)CYCLE
MDND=(IROW-1)*PRJIDF%NCOL+ICOL
ARND=IDFGETAREA(PRJIDF,ICOL,IROW)
ARND= ARND-SIMGRO(ICOL,IROW)%NOPP-SIMGRO(ICOL,IROW)%SOPP
!## rural area > 0
IF(ARND.GT.0.0D0)THEN
LURBAN=.TRUE.
NUND=NUND+1
! IF(IACT.EQ.1)RURALSVATID(ICOL,IROW)=NUND
CALL IDFGETLOC(PRJIDF,IROW,ICOL,XC,YC)
!## write idf_svat.inp - inside area of interest
IF(ICOL.GE.IC1.AND.ICOL.LE.IC2.AND.IROW.GE.IR1.AND.IROW.LE.IR2)THEN
IF(IACT.EQ.2)WRITE(IIDF,'(3I10,2F15.3)') NUND,IROW-IR1+1,ICOL-IC1+1,XC,YC
ENDIF
!## write sel_svat_bda.inp
IF(IACT.EQ.2)THEN
WRITE(ISELSVAT,'(I10)') NUND
WRITE(IDFM_MSWP,'(2(F10.3,1X),I10)') XC,YC,NUND
WRITE(IMSWP_DFM,'(I10,2(1X,F10.3))') NUND,XC,YC
!## write area_svat.inp
WRITE(IAREA,'(I10,F10.1,F8.3,8X,I6,8X,8X,I6,F8.3,I10,2F8.3)') NUND,ARND,SIMGRO(ICOL,IROW)%MV, &
SIMGRO(ICOL,IROW)%BODEM,SIMGRO(ICOL,IROW)%LGN,SIMGRO(ICOL,IROW)%RZ/100.0D0, &
SIMGRO(ICOL,IROW)%METEO,1.0,1.0
!## write svat2swnr_roff.inp ------------------
WRITE(INDSB,'(I10,I10,F8.3,2F8.1)') NUND,AEND,SIMGRO(ICOL,IROW)%VXMU_ROPP,SIMGRO(ICOL,IROW)%CRUNOFF_ROPP, &
SIMGRO(ICOL,IROW)%CRUNON_ROPP
!## write infi_svat.inp, infiltratiecapaciteit per cel, de rest -9999.
WRITE(IINFI,'(I10,F8.3,4F8.1)') NUND,SIMGRO(ICOL,IROW)%QINFBASIC_ROPP,-9999.0,-9999.0,-9999.0,-9999.0
ENDIF
!## add couple location modflow
CALL STOREDXC(DXCID,PRJIDF%NCOL,PRJIDF%NROW,PRJNLAY,1,IROW,ICOL,UNID,IACT)
IF(IACT.EQ.2)THEN
WRITE(IGWMP,'(I10,2X,I10,I5)') UNID,NUND,1
WRITE(IMODSIM,'(I10,2X,I10,I5)') UNID,NUND,1
ENDIF
!## BEGIN scap_svat.inp - grondwater + ow
IF(IARMWP.EQ.0)THEN
LYBE=SIMGRO(ICOL,IROW)%BER_LAAG
TYBE=SIMGRO(ICOL,IROW)%BEREGEN
QBER=SIMGRO(ICOL,IROW)%BEREGEN_Q
JCOL=ICOL; JROW=IROW
ELSE
JCOL=0; JROW=0
BEREGENID=INT(SIMGRO(ICOL,IROW)%BEREGEN)
IF(BEREGENID.GT.0.AND.BEREGENID.LE.SIZE(IPF))THEN
QBER=IPF(BEREGENID)%CAP
LYBE=IPF(BEREGENID)%ILAY
TYBE=1 !## groundwater
CALL IDFIROWICOL(PRJIDF,JROW,JCOL,IPF(BEREGENID)%X,IPF(BEREGENID)%Y)
ENDIF
ENDIF
IF(JROW.NE.0.AND.JCOL.NE.0)THEN
FLBE=0.0D0
IF(TYBE.EQ.1)THEN
!## maximum groundwater abstraction mm/day fmmxabgw
FLBE=QBER
ELSEIF(TYBE.EQ.2)THEN
!## maximum surface water abstraction mm/day fmmxabsw
FLBE=QBER
ENDIF
!## maximum groundwater abstraction mm/day fmmxabgw
IF(FLBE.GT.0.0D0)THEN
IF(TYBE.EQ.1)THEN
IF(IACT.EQ.2)THEN
! MDND2=RURALSVATID(JCOL,JROW)
WRITE(ISCAP,'(I10,F8.2,24X,I10,I6)') NUND,QBER,NUND,LYBE
ENDIF
ELSEIF(TYBE.EQ.2)THEN
IF(IACT.EQ.2)WRITE(ISCAP,'(I10,8X,F8.2,32X,I10)') NUND,QBER,AEND
ENDIF
ENDIF
!## sprinkling from other than modellayer 1 or other location
IF(TYBE.EQ.1.AND.LYBE.GT.1)THEN
!## add couple location modflow
CALL STOREDXC(DXCID,PRJIDF%NCOL,PRJIDF%NROW,PRJNLAY,LYBE,JROW,JCOL,UNID,IACT)
IF(IACT.EQ.2)THEN
WRITE(IGWMP,'(I10,2X,I10,I5)') UNID,NUND,LYBE
WRITE(IMODSIM,'(I10,2X,I10,I5)') UNID,NUND,LYBE
ENDIF
ENDIF
ENDIF
!## END scap_svat.inp - grondwater + ow
!## BEGIN mod2svat.inp; NB: als opp. water of glas dan laag = 0
IF(.NOT.LPWT)THEN
IF(IACT.EQ.2)WRITE(IUSCL,'(I10,3F8.3,8X,2I10)') NUND,SIMGRO(ICOL,IROW)%MOISTURE,SIMGRO(ICOL,IROW)%COND,1.0,ICOL,IROW
ELSE
IF(SIMGRO(ICOL,IROW)%PWT_LEVEL.NE.NODATA_PWT)THEN
IF(IACT.EQ.2)WRITE(IUSCL,'(I10,4F8.3,2I10)') NUND,SIMGRO(ICOL,IROW)%MOISTURE,SIMGRO(ICOL,IROW)%COND,1.0D0, &
SIMGRO(ICOL,IROW)%MV-SIMGRO(ICOL,IROW)%PWT_LEVEL,ICOL,IROW
ELSE
IF(IACT.EQ.2)WRITE(IUSCL,'(I10,3F8.3,8X,2I10)') NUND,SIMGRO(ICOL,IROW)%MOISTURE,SIMGRO(ICOL,IROW)%COND,1.0D0,ICOL,IROW
ENDIF
ENDIF
!## END mod2svat.inp; NB: als opp. water of glas dan laag = 0
!## end rural area
ENDIF
!## urban area (verhard)
ARND =IDFGETAREA(PRJIDF,ICOL,IROW)
ARND =MIN(ARND,SIMGRO(ICOL,IROW)%SOPP) !< dit komt niet meer terug?
IF(ARND.GT.0.0D0)THEN
NUND=NUND+1
!## write idf_svat.inp - inside area of interest
IF(ICOL.GE.IC1.AND.ICOL.LE.IC2.AND.IROW.GE.IR1.AND.IROW.LE.IR2) THEN
IF(IACT.EQ.2)WRITE(IIDF,'(3I10,2F15.3)') NUND,IROW-IR1+1,ICOL-IC1+1,XC,YC
ENDIF
!## write sel_svat_bda.inp
IF(IACT.EQ.2)THEN
WRITE(ISELSVAT,'(I10)') NUND
CALL IDFGETLOC(PRJIDF,IROW,ICOL,XC,YC)
WRITE(IDFM_MSWP,'(2(F10.3,1X),I10)') XC,YC,NUND
WRITE(IMSWP_DFM,'(I10,2(1X,F10.3))') NUND,XC,YC
WRITE(IAREA,'(I10,F10.1,F8.3,8X,I6,16X,I6,F8.3,I10,2F8.2)') &
NUND,ARND,SIMGRO(ICOL,IROW)%MV,SIMGRO(ICOL,IROW)%BODEM,18,0.1,SIMGRO(ICOL,IROW)%METEO,1.0D0,1.0D0
WRITE(INDSB,'(2I10,F8.3,2F8.1)') NUND,0,SIMGRO(ICOL,IROW)%VXMU_SOPP,SIMGRO(ICOL,IROW)%CRUNOFF_SOPP,SIMGRO(ICOL,IROW)%CRUNON_SOPP
ENDIF
!## add couple location modflow
CALL STOREDXC(DXCID,PRJIDF%NCOL,PRJIDF%NROW,PRJNLAY,1,IROW,ICOL,UNID,IACT)
IF(IACT.EQ.2)THEN
WRITE(IGWMP,'(I10,2X,I10,I5)') UNID,NUND,1
WRITE(IMODSIM,'(I10,2X,I10,I5)') UNID,NUND,1
ENDIF
IF(.NOT.LPWT)THEN
IF(IACT.EQ.2)WRITE(IUSCL,'(I10,3F8.3,8X,2I10)') NUND,SIMGRO(ICOL,IROW)%MOISTURE,SIMGRO(ICOL,IROW)%COND,1.0D0,ICOL,IROW
ELSE
IF(SIMGRO(ICOL,IROW)%PWT_LEVEL.NE.NODATA_PWT)THEN
IF(IACT.EQ.2)WRITE(IUSCL,'(I10,4F8.3,2I10)') NUND,SIMGRO(ICOL,IROW)%MOISTURE,SIMGRO(ICOL,IROW)%COND,1.0D0, &
SIMGRO(ICOL,IROW)%MV-SIMGRO(ICOL,IROW)%PWT_LEVEL,ICOL,IROW
ELSE
IF(IACT.EQ.2)WRITE(IUSCL,'(I10,3F8.3,8X,2I10)') NUND,SIMGRO(ICOL,IROW)%MOISTURE,SIMGRO(ICOL,IROW)%COND,1.0D0,ICOL,IROW
ENDIF
ENDIF
!## write infi_svat.inp, infiltratiecapaciteit per cel, de rest -9999.
IF(IACT.EQ.2)WRITE(IINFI,'(I10,F8.3,4F8.1)') NUND,SIMGRO(ICOL,IROW)%QINFBASIC_SOPP,-9999.0,-9999.0,-9999.0,-9999.0
ENDIF
ENDDO
ENDDO
IF(IACT.EQ.1) CALL GENIDDXC(DXCID,PRJIDF%NCOL,PRJIDF%NROW,PRJNLAY,NDXC)
ENDDO
CALL WRITEDXC(IDXC,DXCID,PRJIDF%NCOL,PRJIDF%NROW,PRJNLAY,NDXC)
DEALLOCATE(DXCID) !,RURALSVATID)
IF(IARMWP.EQ.1)DEALLOCATE(IPF)
IF(IAREA.GT.0) CLOSE(IAREA)
IF(ISELSVAT.GT.0) CLOSE(ISELSVAT)
IF(INDSB.GT.0) CLOSE(INDSB)
IF(ISCAP.GT.0) CLOSE(ISCAP)
IF(IGWMP.GT.0) CLOSE(IGWMP)
IF(IMODSIM.GT.0) CLOSE(IMODSIM)
IF(IINFI.GT.0) CLOSE(IINFI)
IF(IIDF.GT.0) CLOSE(IIDF)
IF(IUSCL.GT.0) CLOSE(IUSCL)
IF(IDFM_MSWP.GT.0)CLOSE(IDFM_MSWP)
IF(IMSWP_DFM.GT.0)CLOSE(IMSWP_DFM)
CALL UTL_MF2005_MAXNO(TRIM(DIRMSP)//'\DFM2DTOMSW_WL.DMM_',(/NUND/))
CALL UTL_MF2005_MAXNO(TRIM(DIRMSP)//'\MSWTODFM2D_DPV.DMM_',(/NUND/))
END SUBROUTINE PMANAGER_SAVEMF2005_MSP_INPFILES
!###====================================================================
SUBROUTINE STOREDXC(DXCID,NCOL,NROW,NLAY,ILAY,IROW,ICOL,ID,IACT)
!###====================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: NCOL,NROW,NLAY
INTEGER,INTENT(INOUT) :: ID
INTEGER,INTENT(IN) :: IACT
INTEGER,INTENT(INOUT), DIMENSION(NCOL,NROW,NLAY) :: DXCID
INTEGER,INTENT(IN) :: ILAY, IROW, ICOL
IF(IACT.EQ.2) THEN
ID=DXCID(ICOL,IROW,ILAY)
RETURN
END IF
IF(DXCID(ICOL,IROW,ILAY).EQ.0) THEN
DXCID(ICOL,IROW,ILAY)=1
ENDIF
END SUBROUTINE STOREDXC
!###====================================================================
SUBROUTINE GENIDDXC(DXCID,NCOL,NROW,NLAY,ID)
!###====================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: NCOL,NROW,NLAY
INTEGER,INTENT(OUT) :: ID
INTEGER,INTENT(INOUT), DIMENSION(NCOL,NROW,NLAY) :: DXCID
INTEGER :: ILAY, ICOL, IROW
ID=0
DO ILAY=1,NLAY; DO IROW=1,NROW; DO ICOL=1,NCOL
IF(DXCID(ICOL,IROW,ILAY).NE.0)THEN
ID=ID+1; DXCID(ICOL,IROW,ILAY)=ID
ENDIF
ENDDO; ENDDO; ENDDO
END SUBROUTINE
!###====================================================================
SUBROUTINE WRITEDXC(IDXC,DXCID,NCOL,NROW,NLAY,NDXC)
!###====================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IDXC,NCOL,NROW,NLAY,NDXC
INTEGER,INTENT(IN), DIMENSION(NCOL,NROW,NLAY) :: DXCID
INTEGER :: LUNCB,ICOL,IROW,ILAY,ID
LUNCB=0
WRITE(IDXC,'(2I10)') NDXC,LUNCB
WRITE(IDXC,'(I10)') NDXC
DO ILAY=1,NLAY; DO IROW=1,NROW; DO ICOL=1,NCOL
ID=DXCID(ICOL,IROW,ILAY)
IF(ID.NE.0)THEN
IF(ID.LT.0)THEN
WRITE(IDXC,*) -ILAY,IROW,ICOL,ABS(DXCID(ICOL,IROW,ILAY))
ELSE
WRITE(IDXC,*) ILAY,IROW,ICOL,ABS(DXCID(ICOL,IROW,ILAY))
ENDIF
ENDIF
ENDDO; ENDDO; ENDDO
CLOSE(IDXC)
END SUBROUTINE WRITEDXC
!###====================================================================
SUBROUTINE METASWAP_METEGRID1(FNAME,FNAME2)
!###====================================================================
IMPLICIT NONE
INTEGER,PARAMETER :: NA=11
CHARACTER(LEN=1024) :: S
CHARACTER(LEN=*),INTENT(IN) :: FNAME
CHARACTER(LEN=*),INTENT(IN) :: FNAME2
INTEGER :: IU,JU,I,IOS
CHARACTER(LEN=256), DIMENSION(11) :: SA
CHARACTER(LEN=256) :: RUNDIR
CHARACTER(LEN=8) :: FRM
WRITE(FRM,'(A1,I2.2,A2)') '(',NA,'A)'
CALL IOSDIRNAME(RUNDIR)
IU=UTL_GETUNIT(); OPEN(IU,FILE=FNAME,STATUS='OLD',ACTION='READ')
JU=UTL_GETUNIT(); OPEN(JU,FILE=FNAME2,STATUS='REPLACE',ACTION='WRITE')
DO
READ(IU,'(A1024)',IOSTAT=IOS) S; IF(IOS.NE.0)EXIT
IF(LEN_TRIM(S).EQ.0)CYCLE
!## initial value
SA='NoValue'
READ(S,*,IOSTAT=IOS)(SA(I),I=1,NA)
CALL UTL_REL_TO_ABS(RUNDIR,SA(3))
CALL UTL_REL_TO_ABS(RUNDIR,SA(4))
DO I=3,NA; SA(I)='"'//TRIM(ADJUSTL(SA(I)))//'"'; END DO
DO I=1,NA-1; SA(I)=TRIM(SA(I))//',' ; END DO
WRITE(S,FRM)(TRIM(SA(I)),I=1,NA)
WRITE(JU,'(A)') TRIM(S)
ENDDO
CLOSE(IU)
CLOSE(JU)
END SUBROUTINE
!###====================================================================
SUBROUTINE METASWAP_METEGRID2(DIRMSP)
!###====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIRMSP
LOGICAL :: LEX
REAL(KIND=DP_KIND) :: TD
INTEGER :: IU,IY
CHARACTER(LEN=256) :: PRECFNAME,ETFNAME
!## inquire the existence of mete_grid.inp
INQUIRE(FILE=TRIM(DIRMSP)//'\METE_GRID.INP',EXIST=LEX); IF(.NOT.LEX)RETURN
!## open mete_grid.inp
IU=UTL_GETUNIT()
OPEN(IU,FILE=TRIM(DIRMSP)//'\METE_GRID.INP',STATUS='OLD',ACTION='READ')
READ(IU,*) TD,IY,PRECFNAME,ETFNAME
CLOSE(IU)
!## create coupling tables
CALL METASWAP_METEGRID_INP(PRECFNAME,TRIM(DIRMSP)//'\SVAT2PRECGRID.INP')
CALL METASWAP_METEGRID_INP(ETFNAME, TRIM(DIRMSP)//'\SVAT2ETREFGRID.INP')
END SUBROUTINE METASWAP_METEGRID2
!###====================================================================
SUBROUTINE METASWAP_METEGRID_INP(ASCIIFNAME,INPFNAME)
!###====================================================================
IMPLICIT NONE
INTEGER :: IU,A_NROW,A_NCOL,IROW,ICOL,IR1,IR2,IC1,IC2,NUND
CHARACTER(LEN=*),INTENT(IN) :: ASCIIFNAME,INPFNAME
REAL(KIND=DP_KIND) :: A_XLLC,A_YLLC,A_NODATA,A_CELLSIZE,IX,IY,ARND
CHARACTER(LEN=52) :: TXT
INTEGER,ALLOCATABLE,DIMENSION(:,:) :: PDELR,PDELC
IF(ALLOCATED(PDELR))DEALLOCATE(PDELR)
IF(ALLOCATED(PDELC))DEALLOCATE(PDELC)
ALLOCATE(PDELR(2,PRJIDF%NCOL),PDELC(2,PRJIDF%NROW))
!## read header of ascii file
IU=UTL_GETUNIT(); OPEN(IU,FILE=ASCIIFNAME,ACTION='READ',STATUS='OLD')
READ(IU,*) TXT,A_NCOL
READ(IU,*) TXT,A_NROW
READ(IU,*) TXT,A_XLLC
TXT=UTL_CAP(TXT,'U');IX=0.0D0; IF(TRIM(TXT).EQ.'XLLCENTER')IX=1.0D0
READ(IU,*) TXT,A_YLLC
TXT=UTL_CAP(TXT,'U'); IY=0.0D0; IF(TRIM(TXT).EQ.'YLLCENTER')IY=1.0D0
READ(IU,*) TXT,A_CELLSIZE
READ(IU,*) TXT,A_NODATA
A_XLLC=A_XLLC-(IX*(A_CELLSIZE/2.0D0)); A_YLLC=A_YLLC-(IY*(A_CELLSIZE/2.0D0))
CLOSE(IU)
CALL IMOD_UTL_SCALE1PDELRC(A_XLLC,A_YLLC,A_XLLC+(A_NCOL*A_CELLSIZE),A_YLLC+(A_NROW*A_CELLSIZE), &
PRJIDF%SX,PRJIDF%SY,PDELR,PDELC,PRJIDF%NROW,PRJIDF%NCOL,A_CELLSIZE,A_NROW,A_NCOL,0,0,0)
!## write koppeltabel
IU=UTL_GETUNIT(); OPEN(IU,FILE=INPFNAME,ACTION='WRITE',STATUS='UNKNOWN')
!## fill svat connection to recharge/et based upon svat-units
NUND=0
DO IROW=1,PRJIDF%NROW
DO ICOL=1,PRJIDF%NCOL
!## rural area
ARND=IDFGETAREA(PRJIDF,ICOL,IROW)
ARND=ARND-SIMGRO(ICOL,IROW)%NOPP-SIMGRO(ICOL,IROW)%SOPP
IF(SIMGRO(ICOL,IROW)%IBOUND.GT.0.AND.ARND.GT.0.0)THEN
NUND =NUND+1
IR1=PDELC(1,IROW); IF(IR1.LT.0)IR1=PDELC(1,ABS(IR1))
IR2=PDELC(2,IROW); IF(IR2.LT.0)IR2=PDELC(2,ABS(IR2))
IC1=PDELR(1,ICOL); IF(IC1.LT.0)IC1=PDELR(1,ABS(IC1))
IC2=PDELR(2,ICOL); IF(IC2.LT.0)IC2=PDELR(2,ABS(IC2))
WRITE(IU,'(3I10,10X,2I10)') NUND,IR1,IC1,IR2,IC2
ENDIF
!## urban area
ARND=IDFGETAREA(PRJIDF,ICOL,IROW)
ARND=MIN(ARND,SIMGRO(ICOL,IROW)%SOPP)
IF(SIMGRO(ICOL,IROW)%IBOUND.GT.0.AND.ARND.GT.0.0)THEN
NUND=NUND+1
IR1=PDELC(1,IROW); IF(IR1.LT.0)IR1=PDELC(1,ABS(IR1))
IR2=PDELC(2,IROW); IF(IR2.LT.0)IR2=PDELC(2,ABS(IR2))
IC1=PDELR(1,ICOL); IF(IC1.LT.0)IC1=PDELR(1,ABS(IC1))
IC2=PDELR(2,ICOL); IF(IC2.LT.0)IC2=PDELR(2,ABS(IC2))
WRITE(IU,'(3I10,10X,2I10)') NUND,IR1,IC1,IR2,IC2
ENDIF
ENDDO
ENDDO
CLOSE(IU)
IF(ALLOCATED(PDELR))DEALLOCATE(PDELR)
IF(ALLOCATED(PDELC))DEALLOCATE(PDELC)
END SUBROUTINE METASWAP_METEGRID_INP
!###====================================================================
SUBROUTINE IMOD_UTL_SCALE1PDELRC(XMIN,YMIN,XMAX,YMAX,SXX,SYY,PDELR,PDELC,NROW,NCOL,CS,NROWIDF,NCOLIDF,IU,IEQ,ITB)
!###====================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: NROW,NCOL,NROWIDF,NCOLIDF,IU,IEQ,ITB
REAL(KIND=8),INTENT(IN) :: CS,XMIN,YMIN,XMAX,YMAX
REAL(KIND=8),INTENT(IN),DIMENSION(0:NCOL) :: SXX
REAL(KIND=8),INTENT(IN),DIMENSION(0:NROW) :: SYY
REAL(KIND=8) :: DX,DY
INTEGER,INTENT(OUT),DIMENSION(2,NCOL) :: PDELR
INTEGER,INTENT(OUT),DIMENSION(2,NROW) :: PDELC
INTEGER :: I,J,IREC
CHARACTER(LEN=256) :: IDFNAME
REAL(KIND=8),ALLOCATABLE,DIMENSION(:) :: DELRIDF,DELCIDF
IF(XMIN.GT.SXX(0).OR.XMAX.LT.SXX(NCOL).OR.YMIN.GT.SYY(NROW).OR.YMAX.LT.SYY(0))THEN
INQUIRE(UNIT=IU,NAME=IDFNAME)
WRITE(*,'(A)') '======================================='
WRITE(*,'(A)') 'Warning!'
WRITE(*,'(A)') 'File: '//TRIM(IDFNAME)
WRITE(*,'(A)') 'Undersizes current model dimensions!'
IF(XMIN.GT.SXX(0))THEN
WRITE(*,'(A)') 'XMIN IDF '//TRIM(RTOS(XMIN,'F',2))//' > XMIN MODEL '//TRIM(RTOS(SXX(0),'F',2))
ENDIF
IF(XMAX.LT.SXX(NCOL))THEN
WRITE(*,'(A)') 'XMAX IDF '//TRIM(RTOS(XMAX,'F',2))//' < XMAX MODEL '//TRIM(RTOS(SXX(NCOL),'F',2))
ENDIF
IF(YMIN.GT.SYY(NROW))THEN
WRITE(*,'(A)') 'YMIN IDF '//TRIM(RTOS(YMIN,'F',2))//' > YMIN MODEL '//TRIM(RTOS(SYY(NROW),'F',2))
ENDIF
IF(YMAX.LT.SYY(0))THEN
WRITE(*,'(A)') 'YMAX IDF '//TRIM(RTOS(YMAX,'F',2))//' < YMAX MODEL '//TRIM(RTOS(SYY(0),'F',2))
ENDIF
WRITE(*,'(A)') '======================================='
WRITE(*,'(A)') 'Error'
ENDIF
IF(ALLOCATED(DELRIDF))DEALLOCATE(DELRIDF)
IF(ALLOCATED(DELCIDF))DEALLOCATE(DELCIDF)
ALLOCATE(DELRIDF(0:NCOLIDF),DELCIDF(0:NROWIDF))
DELRIDF(0)=XMIN
DELCIDF(0)=YMAX
IF(IEQ.EQ.0)THEN
DO I=1,NCOLIDF; DELRIDF(I)=XMIN+REAL(I)*CS; ENDDO
DO I=1,NROWIDF; DELCIDF(I)=YMAX-REAL(I)*CS; ENDDO
ELSEIF(IEQ.EQ.1)THEN
IREC =10+ITB*2
DO I=1,NCOLIDF
IREC=IREC+1
READ(IU,REC=IREC+ICF) DELRIDF(I)
DELRIDF(I)=DELRIDF(I-1)+DELRIDF(I)
END DO
DO I=1,NROWIDF
IREC=IREC+1
READ(IU,REC=IREC+ICF) DELCIDF(I)
DELCIDF(I)=DELCIDF(I-1)-DELCIDF(I)
END DO
ENDIF
!## start/end column direction
DO I=1,NCOL
CALL POL1LOCATE(DELRIDF,NCOLIDF+1,SXX(I-1),PDELR(1,I))
!## check whether position is exact equally
J=PDELR(1,I)
IF(J.LE.NCOLIDF)THEN
IF(DELRIDF(J).EQ.SXX(I-1))PDELR(1,I)=PDELR(1,I)+1
ENDIF
CALL POL1LOCATE(DELRIDF,NCOLIDF+1,SXX(I),PDELR(2,I))
PDELR(1,I)=MIN(PDELR(1,I),NCOLIDF)
PDELR(2,I)=MIN(PDELR(2,I),NCOLIDF)
ENDDO
DO I=1,NROW
CALL POL1LOCATE(DELCIDF,NROWIDF+1,SYY(I-1),PDELC(1,I))
CALL POL1LOCATE(DELCIDF,NROWIDF+1,SYY(I),PDELC(2,I))
!## check whether position is exact equally
J=PDELC(2,I)
IF(J.LE.NROWIDF)THEN
IF(DELCIDF(J-1).EQ.SYY(I))PDELC(2,I)=PDELC(2,I)-1
ENDIF
PDELC(1,I)=MIN(PDELC(1,I),NROWIDF)
PDELC(2,I)=MIN(PDELC(2,I),NROWIDF)
ENDDO
IF(ALLOCATED(DELRIDF))DEALLOCATE(DELRIDF)
IF(ALLOCATED(DELCIDF))DEALLOCATE(DELCIDF)
DO I=1,NCOL
IF(PDELR(2,I).LT.PDELR(1,I))then
DX =(SXX(I-1)-XMIN)/CS
PDELR(1,I)=INT(DX)+1
DX =(SXX(I)-XMIN)/CS
PDELR(2,I)=INT(DX)+1
DX=SXX(I)-XMIN
IF(MOD(DX,CS).EQ.0.0)PDELR(2,I)=PDELR(2,I)-1
WRITE(*,'(A)') 'PDELR(2,I).LT.PDELR(1,I)'
ENDIF
ENDDO
DO I=1,NROW
IF(PDELC(2,I).LT.PDELC(1,I))THEN
DY=(YMAX-SYY(I-1))/CS
PDELC(1,I)=INT(DY)+1
DY=(YMAX-SYY(I))
PDELC(2,I)=INT(DY)+1
DY=YMAX-SYY(I)
IF(MOD(DY,CS).EQ.0.0)PDELC(2,I)=PDELC(2,I)-1
WRITE(*,'(A)') 'PDELC(2,I).LT.PDELC(1,I)'
ENDIF
ENDDO
!## adjust pdelr/pdelc in case reading idf is coarser, then you don't need to read it in again, values will be copied in READCOPYVALUES_R()
J=1
DO I=2,NCOL
IF(PDELR(1,I).EQ.PDELR(1,J).AND. &
PDELR(2,I).EQ.PDELR(2,J))THEN
PDELR(1,I)=-J
PDELR(2,I)=-J
ELSE
J=I
ENDIF
END DO
J=1
DO I=2,NROW
IF(PDELC(1,I).EQ.PDELC(1,J).AND. &
PDELC(2,I).EQ.PDELC(2,J))THEN
PDELC(1,I)=-J
PDELC(2,I)=-J
ELSE
J=I
ENDIF
END DO
END SUBROUTINE IMOD_UTL_SCALE1PDELRC
!###====================================================================
SUBROUTINE PMANAGER_SAVEMF2005_MSP_CHECK(NODATA)
!###====================================================================
IMPLICIT NONE
REAL(KIND=DP_KIND),DIMENSION(:),INTENT(IN) :: NODATA
INTEGER,DIMENSION(:),ALLOCATABLE :: IERROR
INTEGER :: IROW,ICOL,STRLEN
REAL(KIND=DP_KIND) :: DXY,ARND
CHARACTER(LEN=:),ALLOCATABLE :: STR
!## inactivate constant head boundaries and inactive nodes
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
IF(BND(1)%X(ICOL,IROW).LE.0.0D0)SIMGRO(ICOL,IROW)%IBOUND=0
ENDDO; ENDDO
!## skip corners irt anisotropy package
SIMGRO(1 ,1 )%IBOUND=0
SIMGRO(1 ,PRJIDF%NROW )%IBOUND=0
SIMGRO(PRJIDF%NCOL,1 )%IBOUND=0
SIMGRO(PRJIDF%NCOL,PRJIDF%NROW)%IBOUND=0
!## make sure that for sopp>0 there is a vxmu value, turn nopp otherwise off
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
IF(SIMGRO(ICOL,IROW)%VXMU_SOPP.EQ.NODATA(12))SIMGRO(ICOL,IROW)%SOPP=0.0D0
IF(SIMGRO(ICOL,IROW)%SOPP.GT.0.0D0)THEN
IF(SIMGRO(ICOL,IROW)%VXMU_SOPP .EQ.NODATA(12))SIMGRO(ICOL,IROW)%SOPP=0.0D0
IF(SIMGRO(ICOL,IROW)%CRUNOFF_SOPP .EQ.NODATA(14))SIMGRO(ICOL,IROW)%SOPP=0.0D0
IF(SIMGRO(ICOL,IROW)%CRUNON_SOPP .EQ.NODATA(16))SIMGRO(ICOL,IROW)%SOPP=0.0D0
IF(SIMGRO(ICOL,IROW)%QINFBASIC_SOPP.EQ.NODATA(18))SIMGRO(ICOL,IROW)%SOPP=0.0D0
ENDIF
DXY=IDFGETAREA(PRJIDF,ICOL,IROW)
IF(SIMGRO(ICOL,IROW)%VXMU_ROPP.EQ.NODATA(13))SIMGRO(ICOL,IROW)%NOPP=DXY !## surface water, no metaswap
ARND=DXY-SIMGRO(ICOL,IROW)%NOPP-SIMGRO(ICOL,IROW)%SOPP
!## rural area
IF(ARND.GT.0.0D0)THEN
IF(SIMGRO(ICOL,IROW)%VXMU_ROPP .EQ.NODATA(13))SIMGRO(ICOL,IROW)%NOPP=ARND !## surface water, no metaswap
IF(SIMGRO(ICOL,IROW)%CRUNOFF_ROPP .EQ.NODATA(15))SIMGRO(ICOL,IROW)%NOPP=ARND !## surface water, no metaswap
IF(SIMGRO(ICOL,IROW)%CRUNON_ROPP .EQ.NODATA(17))SIMGRO(ICOL,IROW)%NOPP=ARND !## surface water, no metaswap
IF(SIMGRO(ICOL,IROW)%QINFBASIC_ROPP.EQ.NODATA(19))SIMGRO(ICOL,IROW)%NOPP=ARND !## surface water, no metaswap
ENDIF
ENDDO; ENDDO
!## check input
ALLOCATE(IERROR(22)); IERROR=0
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
IF(SIMGRO(ICOL,IROW)%IBOUND.GT.0)THEN
IF(SIMGRO(ICOL,IROW)%LGN.EQ.NODATA(2)) IERROR(2) =IERROR(2)+1
IF(SIMGRO(ICOL,IROW)%RZ.EQ.NODATA(3)) IERROR(3) =IERROR(3)+1
IF(SIMGRO(ICOL,IROW)%BODEM.EQ.NODATA(4)) IERROR(4) =IERROR(4)+1
IF(SIMGRO(ICOL,IROW)%METEO.EQ.NODATA(5)) IERROR(5) =IERROR(5)+1
IF(SIMGRO(ICOL,IROW)%MV.EQ.NODATA(6)) IERROR(6) =IERROR(6)+1
IF(SIMGRO(ICOL,IROW)%BEREGEN.EQ.NODATA(7)) IERROR(7) =IERROR(7)+1
IF(IARMWP.EQ.0)THEN
IF(SIMGRO(ICOL,IROW)%BER_LAAG.EQ.NODATA(8)) IERROR(8) =IERROR(8)+1
IF(SIMGRO(ICOL,IROW)%BEREGEN_Q.EQ.NODATA(9)) IERROR(9) =IERROR(9)+1
ENDIF
IF(SIMGRO(ICOL,IROW)%NOPP.EQ.NODATA(10)) IERROR(10)=IERROR(10)+1
IF(SIMGRO(ICOL,IROW)%SOPP.EQ.NODATA(11)) IERROR(11)=IERROR(11)+1
IF(SIMGRO(ICOL,IROW)%VXMU_ROPP.EQ.NODATA(13)) IERROR(13)=IERROR(13)+1
IF(SIMGRO(ICOL,IROW)%CRUNOFF_SOPP.EQ.NODATA(14)) IERROR(14)=IERROR(14)+1
IF(SIMGRO(ICOL,IROW)%SOPP.GT.0)THEN
IF(SIMGRO(ICOL,IROW)%VXMU_SOPP.EQ.NODATA(12)) IERROR(12)=IERROR(12)+1
IF(SIMGRO(ICOL,IROW)%CRUNON_SOPP.EQ.NODATA(16)) IERROR(16)=IERROR(16)+1
IF(SIMGRO(ICOL,IROW)%QINFBASIC_SOPP.EQ.NODATA(18))IERROR(18)=IERROR(18)+1
ENDIF
IF(SIMGRO(ICOL,IROW)%CRUNOFF_ROPP.EQ.NODATA(15)) IERROR(15)=IERROR(15)+1
IF(SIMGRO(ICOL,IROW)%CRUNON_ROPP.EQ.NODATA(17)) IERROR(17)=IERROR(17)+1
IF(SIMGRO(ICOL,IROW)%QINFBASIC_ROPP.EQ.NODATA(19))IERROR(19)=IERROR(19)+1
IF(TOPICS(TPWT)%DEFINED)THEN
! IF(SIMGRO(ICOL,IROW)%PWT_LEVEL.EQ.NODATA(20)) IERROR(20)=IERROR(20)+1 <--- nodata is niet erg, is er geen PWT aanwezig
ENDIF
IF(SIMGRO(ICOL,IROW)%MOISTURE.EQ.NODATA(21)) IERROR(21)=IERROR(21)+1
IF(SIMGRO(ICOL,IROW)%COND.EQ.NODATA(22)) IERROR(22)=IERROR(22)+1
ENDIF
ENDDO; ENDDO
!## error in data
IF(SUM(IERROR).GT.0)THEN
STRLEN=22*30; ALLOCATE(CHARACTER(LEN=STRLEN) :: STR)
STR='NodataValues on active modelcells found in :'//NEWLINE// &
'- Landuse '//TRIM(ITOS(IERROR(2)))//NEWLINE// &
'- Rootzone '//TRIM(ITOS(IERROR(3)))//NEWLINE// &
'- Soil Types '//TRIM(ITOS(IERROR(4)))//NEWLINE// &
'- Meteo Stations '//TRIM(ITOS(IERROR(5)))//NEWLINE// &
'- Surface Level '//TRIM(ITOS(IERROR(6)))//NEWLINE// &
'- Art. Recharge '//TRIM(ITOS(IERROR(7)))//NEWLINE// &
'- Art. Rch. Layer '//TRIM(ITOS(IERROR(8)))//NEWLINE// &
'- Art. Rch. Strength'//TRIM(ITOS(IERROR(9)))//NEWLINE// &
'- Wetted Area '//TRIM(ITOS(IERROR(10)))//NEWLINE// &
'- Surf. Urban Area '//TRIM(ITOS(IERROR(11)))//NEWLINE// &
'- VXMU SOPP '//TRIM(ITOS(IERROR(12)))//NEWLINE// &
'- VXMU ROPP '//TRIM(ITOS(IERROR(13)))//NEWLINE// &
'- CRUNOFF SOPP '//TRIM(ITOS(IERROR(14)))//NEWLINE// &
'- CRUNOFF ROPP '//TRIM(ITOS(IERROR(15)))//NEWLINE// &
'- CRUNON SOPP '//TRIM(ITOS(IERROR(16)))//NEWLINE// &
'- CRUNON ROPP '//TRIM(ITOS(IERROR(17)))//NEWLINE// &
'- QINFBASIS SOPP '//TRIM(ITOS(IERROR(18)))//NEWLINE// &
'- QINFBASIS ROPP '//TRIM(ITOS(IERROR(19)))//NEWLINE// &
! '- Pondingdepth '//TRIM(ITOS(IERROR(12))),1)
!! IF(LPWT)CALL PRINTTEXT('- PWT Level '//TRIM(ITOS(IERROR(20))),1)
'- Moisture Factor '//TRIM(ITOS(IERROR(21)))//NEWLINE// &
'- Conductivity '//TRIM(ITOS(IERROR(22)))//NEWLINE// &
'Process stopped!'
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,TRIM(STR),'Error')
DEALLOCATE(STR,IERROR); RETURN
ENDIF
!## change surface water into gras; change urban into gras
DO IROW=1,PRJIDF%NROW
DO ICOL=1,PRJIDF%NCOL
SELECT CASE (SIMGRO(ICOL,IROW)%LGN)
CASE (8,18:21,23:26)
SIMGRO(ICOL,IROW)%LGN=1
CASE (22)
SIMGRO(ICOL,IROW)%LGN=12
CASE (:0,45:)
SIMGRO(ICOL,IROW)%LGN=1
END SELECT
ENDDO
ENDDO
!## minimale beworteling
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
IF(SIMGRO(ICOL,IROW)%RZ.LT.10.0D0)SIMGRO(ICOL,IROW)%RZ=10.0D0
ENDDO; ENDDO
!## minimal nopp-value
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
SIMGRO(ICOL,IROW)%NOPP=MAX(0.0D0,SIMGRO(ICOL,IROW)%NOPP)
!## minimal sopp-value
SIMGRO(ICOL,IROW)%SOPP=MAX(0.0D0,SIMGRO(ICOL,IROW)%SOPP)
ENDDO; ENDDO
!## bodem 22/23 vertalen naar 9 -> 22 (stedelijk zand?)/23(geen bodem; stad) -> zand
DO IROW=1,PRJIDF%NROW
DO ICOL=1,PRJIDF%NCOL
SELECT CASE (SIMGRO(ICOL,IROW)%BODEM)
CASE (23,22)
SIMGRO(ICOL,IROW)%BODEM=9
END SELECT
!## kies bodem 22 for lgn stedelijk gebied
SELECT CASE (SIMGRO(ICOL,IROW)%LGN)
CASE (18,25)
! SIMGRO(ICOL,IROW)%BODEM=22
END SELECT
ENDDO
ENDDO
IF(IARMWP.EQ.0)THEN
!## turn off beregening whenever layer is zero!
DO IROW=1,PRJIDF%NROW
DO ICOL=1,PRJIDF%NCOL
!## maximal artificial recharge layer is PRJNLAY
SIMGRO(ICOL,IROW)%BER_LAAG=MIN(SIMGRO(ICOL,IROW)%BER_LAAG,PRJNLAY)
IF(SIMGRO(ICOL,IROW)%BEREGEN.NE.0.AND.SIMGRO(ICOL,IROW)%BER_LAAG.EQ.0)SIMGRO(ICOL,IROW)%BEREGEN=0
ENDDO
ENDDO
ENDIF
DEALLOCATE(IERROR)
END SUBROUTINE PMANAGER_SAVEMF2005_MSP_CHECK
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_COMBINE(DIR,DIRNAME,PCK,CB,CAUX)
!###======================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRNAME,CAUX
INTEGER,INTENT(IN) :: CB
CHARACTER(LEN=*),INTENT(IN),DIMENSION(:) :: PCK
INTEGER,DIMENSION(3) :: IU
INTEGER,DIMENSION(3) :: JU,NO,NO_PREV
CHARACTER(LEN=256),DIMENSION(3) :: FNAME,FNAME_PREV
INTEGER :: I,J,IPER
LOGICAL :: LEX
PMANAGER_SAVEMF2005_COMBINE=.FALSE.
!## read from files
IU=0
DO I=1,SIZE(PCK)
LINE=TRIM(DIRNAME)//'.'//TRIM(PCK(I))//'7'
IF(I.LE.2)THEN
IU(I)=UTL_GETUNIT(); CALL OSD_OPEN(IU(I),FILE=LINE,STATUS='OLD',ACTION='READ')
ELSE
!## write to file
IU(I)=UTL_GETUNIT(); CALL OSD_OPEN(IU(I),FILE=LINE,STATUS='UNKNOWN',ACTION='WRITE')
ENDIF
ENDDO
IF(MINVAL(IU).EQ.0)RETURN
NO=0; DO I=1,2; READ(IU(I),*) NO(I); ENDDO
LINE=TRIM(ITOS(SUM(NO)))//','//TRIM(ITOS(CB))//' '//TRIM(CAUX)
WRITE(IU(3),'(A)') TRIM(LINE)
DO IPER=1,PRJNPER
NO=0; DO I=1,2; READ(IU(I),*) NO(I); ENDDO
!## use previous timestep for both
IF(NO(1).EQ.-1.AND.NO(2).EQ.-1)THEN
WRITE(IU(3),'(I2)') -1; CYCLE
ENDIF
FNAME=''
!## reuse previous values
DO I=1,2
IF(NO(I).LT.0)THEN; NO(I)=NO_PREV(I); FNAME(I)=FNAME_PREV(I); ENDIF
ENDDO
LINE=TRIM(ITOS(SUM(NO)))
WRITE(IU(3),'(A)') TRIM(LINE)
JU=0
DO I=1,2
!## refresh external filename
IF(NO(I).GT.0)THEN
IF(LEN_TRIM(FNAME(I)).EQ.0)THEN
READ(IU(I),'(11X,A)') FNAME(I)
FNAME(I)=UTL_CAP(FNAME(I),'U')
J=INDEX(FNAME(I),'.ARR',.TRUE.)-1
FNAME(I)=DIR(:INDEX(DIR,'\',.TRUE.)-1)//TRIM(FNAME(I)(2:J))//'.ARR'
FNAME(I)=UTL_CAP(FNAME(I),'U')
ENDIF
JU(I)=UTL_GETUNIT(); CALL OSD_OPEN(JU(I),FILE=FNAME(I),STATUS='OLD',ACTION='READ')
ENDIF
ENDDO
!## create (new) output file
FNAME(3)=TRIM(DIR)//'\'// TRIM(PCK(2))//'7\'//TRIM(PCK(2))//'_T'//TRIM(ITOS(IPER))//'.ARR'
FNAME(3)=UTL_CAP(FNAME(3),'U')
!## append to existing file, create new file otherwise
JU(3)=UTL_GETUNIT()
IF(FNAME(3).EQ.FNAME(2))THEN; FNAME(3)=TRIM(FNAME(3))//'_'; ENDIF
CALL OSD_OPEN(JU(3),FILE=FNAME(3),STATUS='UNKNOWN',ACTION='WRITE')
IF(JU(1).GT.0)THEN; DO I=1,NO(1); READ(JU(1),'(A256)') LINE; WRITE(JU(3),'(A)') TRIM(LINE); ENDDO; CLOSE(JU(1)); ENDIF
IF(JU(2).GT.0)THEN; DO I=1,NO(2); READ(JU(2),'(A256)') LINE; WRITE(JU(3),'(A)') TRIM(LINE); ENDDO; CLOSE(JU(2)); ENDIF
!## add iMOD header at the bottom
IF(PBMAN%IFORMAT.EQ.2)CALL IDFWRITEFREE_HEADER(JU(3),BND(1))
CLOSE(JU(3))
J=LEN_TRIM(FNAME(3))
IF(FNAME(3)(J:J).EQ.'_')THEN
FNAME(3)(J:J)=' '
INQUIRE(FILE=FNAME(3),EXIST=LEX); IF(LEX)CALL IOSDELETEFILE(FNAME(3))
CALL IOSRENAMEFILE(TRIM(FNAME(3))//'_',FNAME(3))
ENDIF
LINE=FNAME(3); DO J=1,3; LINE=LINE(:INDEX(LINE,'\',.TRUE.)-1); ENDDO
J=LEN_TRIM(LINE); LINE='.'//FNAME(3)(J+1:)
IF(SUM(NO).GT.0)WRITE(IU(3),'(A)') 'OPEN/CLOSE '//TRIM(LINE)//' 1.0D0 (FREE) -1'
DO I=1,2; NO_PREV(I)=NO(I); FNAME_PREV(I)=FNAME(I); ENDDO
ENDDO
CLOSE(IU(1),STATUS='DELETE'); CLOSE(IU(2),STATUS='DELETE'); CLOSE(IU(3))
!## rename file
FNAME(1)=TRIM(DIRNAME)//'.'//TRIM(PCK(3))//'7'
FNAME(2)=TRIM(DIRNAME)//'.'//TRIM(PCK(2))//'7'
CALL IOSRENAMEFILE(FNAME(1),FNAME(2))
PMANAGER_SAVEMF2005_COMBINE=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_COMBINE
!###======================================================================
SUBROUTINE PMANAGER_SAVEMF2005_PCK_ULSTRD_PARAM(PRJNLAY,ICOL,IROW,TOP,BOT,KD,TP,BT,KH,LKHV)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: PRJNLAY,ICOL,IROW
TYPE(IDFOBJ),INTENT(IN),DIMENSION(PRJNLAY) :: TOP,BOT,KD
REAL(KIND=DP_KIND),INTENT(OUT),DIMENSION(PRJNLAY) :: KH,TP,BT
LOGICAL,INTENT(IN) :: LKHV
INTEGER :: ILAY
!## get filter fractions
DO ILAY=1,PRJNLAY
TP(ILAY)=TOP(ILAY)%X(ICOL,IROW)
BT(ILAY)=BOT(ILAY)%X(ICOL,IROW)
KH(ILAY)=KD (ILAY)%X(ICOL,IROW)
ENDDO
DO ILAY=1,PRJNLAY
!## put in cells witrh thickness only, also include inactive cells as they could be formed for mf6
IF(TP(ILAY)-BT(ILAY).GT.0.0D0)THEN
! IF(BND(ILAY)%X(ICOL,IROW).GT.0.AND.TP(ILAY)-BT(ILAY).GT.0.0D0)THEN
KH(ILAY)=KH(ILAY)/(TP(ILAY)-BT(ILAY))
!## uniform disctribution
IF(.NOT.LKHV)KH(ILAY)=1.0D0
ELSE
KH(ILAY)=0.0D0
ENDIF
ENDDO
END SUBROUTINE PMANAGER_SAVEMF2005_PCK_ULSTRD_PARAM
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_PCK_U2DREL(EXFNAME,IDF,IU,IFBND,IINT)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IFBND,IINT
CHARACTER(LEN=*),INTENT(IN) :: EXFNAME
TYPE(IDFOBJ),INTENT(INOUT) :: IDF
CHARACTER(LEN=256) :: SFNAME
INTEGER,INTENT(IN) :: IU
INTEGER :: JU,IROW,ICOL,I
REAL(KIND=DP_KIND) :: MINV,MAXV
PMANAGER_SAVEMF2005_PCK_U2DREL=.FALSE.
IF(.NOT.PMANAGER_SAVEMF2005_PCK_GETMINMAX(IDF%X,IDF%NCOL,IDF%NROW,BND(1)%X,MINV,MAXV,IFBND))RETURN
!## constant value
IF(MAXV.EQ.MINV)THEN
IF(IINT.EQ.0)WRITE(IU,'(A)') 'CONSTANT '//TRIM(RTOS(MAXV,'E',7))
IF(IINT.EQ.1)THEN
LINE='CONSTANT '//TRIM(ITOS(INT(MAXV)))
WRITE(IU,'(A)') TRIM(LINE)
ENDIF
ELSE
CALL UTL_CREATEDIR(EXFNAME(:INDEX(EXFNAME,'\',.TRUE.)-1))
SFNAME=EXFNAME; DO I=1,3; SFNAME=SFNAME(:INDEX(SFNAME,'\',.TRUE.)-1); ENDDO
I=LEN_TRIM(SFNAME); SFNAME='.'//EXFNAME(I+1:)
IF(IINT.EQ.0)WRITE(IU,'(A)') 'OPEN/CLOSE '//TRIM(SFNAME)//' 1.0D0 (FREE) -1'
IF(IINT.EQ.1)WRITE(IU,'(A)') 'OPEN/CLOSE '//TRIM(SFNAME)//' 1 (FREE) -1'
JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=EXFNAME,STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(JU.EQ.0)RETURN
IF(LFREEFORMAT)THEN
CALL IDFWRITEFREE(JU,IDF,IINT,'B','*')
ELSE
IF(IINT.EQ.1)THEN
DO IROW=1,IDF%NROW; WRITE(JU,*) (INT(IDF%X(ICOL,IROW)),ICOL=1,IDF%NCOL); ENDDO
ELSE
DO IROW=1,IDF%NROW; WRITE(JU,*) (IDF%X(ICOL,IROW) ,ICOL=1,IDF%NCOL); ENDDO
ENDIF
ENDIF
CLOSE(JU)
ENDIF
PMANAGER_SAVEMF2005_PCK_U2DREL=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_PCK_U2DREL
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_HFB_COMPUTE(IDF,ITOPIC,IU,BND,TOP,BOT,IPRT,IBATCH)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ITOPIC,IU,IPRT,IBATCH
TYPE(IDFOBJ),INTENT(INOUT) :: IDF
TYPE(IDFOBJ),DIMENSION(PRJNLAY),INTENT(INOUT) :: TOP,BOT,BND
REAL(KIND=DP_KIND) :: FCT,IMP,CNST
INTEGER :: ILAY,ISYS,ICNST
INTEGER(KIND=1),ALLOCATABLE,DIMENSION(:,:,:) :: IPC
TYPE(IDFOBJ) :: TIDF,BIDF
PMANAGER_SAVEMF2005_HFB_COMPUTE=.FALSE.
CALL ASC2IDF_INT_NULLIFY(); ALLOCATE(XP(100),YP(100),ZP(100),FP(100),WP(100))
!## compute block-faces
ALLOCATE(IPC(IDF%NCOL,IDF%NROW,2))
CALL IDFNULLIFY(TIDF); CALL IDFNULLIFY(BIDF)
CALL IDFCOPY(IDF,TIDF); CALL IDFCOPY(IDF,BIDF)
WRITE(IU,'(5A10,2A15,A10,4A15)') 'ILAY','IROW1','ICOL1','IROW2','ICOL2','RESISTANCE','FRACTION','SYSTEM', &
'TOP_LAYER','BOT_LAYER','TOP_FAULT','BOT_FAULT'
!## process per system
DO ISYS=1,SIZE(TOPICS(ITOPIC)%STRESS(1)%FILES,2)
IPC=INT(0,1)
ICNST =TOPICS(ITOPIC)%STRESS(1)%FILES(1,ISYS)%ICNST
CNST =TOPICS(ITOPIC)%STRESS(1)%FILES(1,ISYS)%CNST
ILAY =TOPICS(ITOPIC)%STRESS(1)%FILES(1,ISYS)%ILAY
FCT =TOPICS(ITOPIC)%STRESS(1)%FILES(1,ISYS)%FCT
IMP =TOPICS(ITOPIC)%STRESS(1)%FILES(1,ISYS)%IMP
IDF%FNAME=TOPICS(ITOPIC)%STRESS(1)%FILES(1,ISYS)%FNAME
IF(ICNST.EQ.1)THEN
IF(IBATCH.EQ.0)CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'HFB cannot be parameterized via a constant value.','Error')
WRITE(*,'(A)') 'HFB cannot be parameterized via a constant value.'
EXIT
ENDIF
WRITE(IPRT,'(1X,A,I3,A1,I1,A1,I4.3,3(A1,G15.7),A1,A)') TOPICS(ITOPIC)%TNAME(1:5)//',', &
ISYS,',',ICNST,',',ILAY,',',FCT,',',IMP,',',CNST,',',CHAR(39)//TRIM(IDF%FNAME)//CHAR(39)
IF(LEN_TRIM(PRJIDF%FNAME).GT.0)THEN
!## rasterize genfile
CALL ASC2IDF_HFB(IDF,IDF%NROW,IDF%NCOL,IPC,(/IDF%FNAME/),ILAY,TIDF,BIDF)
!## collect all fault in a single file with resistances and layer fractions
CALL PMANAGER_SAVEMF2005_HFB_COLLECT(IPC,IDF%NROW,IDF%NCOL,FCT*IMP,IU,BND,TOP,BOT,ILAY,TIDF,BIDF,ISYS)
ENDIF
ENDDO
CALL ASC2IDF_INT_DEALLOCATE(); CLOSE(IU)
DEALLOCATE(IPC); CALL IDFDEALLOCATEX(TIDF); CALL IDFDEALLOCATEX(BIDF)
IF(ISYS.GT.SIZE(TOPICS(ITOPIC)%STRESS(1)%FILES,2))PMANAGER_SAVEMF2005_HFB_COMPUTE=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_HFB_COMPUTE
!###====================================================================
SUBROUTINE PMANAGER_SAVEMF2005_HFB_COLLECT(IPC,NROW,NCOL,HFBRESIS, &
IU,BND,TOP,BOT,ITB,TIDF,BIDF,ISYS)
!###====================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: NROW,NCOL,IU,ITB,ISYS
TYPE(IDFOBJ),INTENT(INOUT) :: TIDF,BIDF
TYPE(IDFOBJ),DIMENSION(PRJNLAY),INTENT(INOUT) :: TOP,BOT,BND
REAL(KIND=DP_KIND),INTENT(IN) :: HFBRESIS
INTEGER(KIND=1),INTENT(IN),DIMENSION(NCOL,NROW,2) :: IPC
INTEGER :: IROW,ICOL,IL1,IL2,ILAY
REAL(KIND=DP_KIND) :: NODATA,FDZ,TPV,BTV,TFV,BFV
NODATA=HUGE(1.0D0)
!## determine what layer(s)
IF(ITB.EQ.0)THEN
IL1=1; IL2=PRJNLAY
ELSE
IL1=ITB; IL2=IL1
ENDIF
DO IROW=1,NROW; DO ICOL=1,NCOL; DO ILAY=IL1,IL2
!## place vertical wall
IF(IPC(ICOL,IROW,1).EQ.INT(1,1))THEN
IF(ICOL.LT.NCOL)THEN
!## fraction is minus 1 for given layers
FDZ=-1.0D0
IF(ITB.EQ.0)FDZ=PMANAGER_SAVEMF2005_HFB_GETFDZ(BND,TOP,BOT,TIDF%X,BIDF%X,ICOL,IROW,ICOL+1,IROW,NODATA,ILAY,TFV,BFV)
!## enter fault if occupation > 0.0D0%
IF(ITB.EQ.0.AND.FDZ.LE.0.0D0)CYCLE
IF(ITB.NE.0)THEN
TPV=0.0D0
BTV=0.0D0
TFV=0.0D0
BFV=0.0D0
ELSE
TPV=(TOP(ILAY)%X(ICOL,IROW)+TOP(ILAY)%X(ICOL+1,IROW))/2.0D0
BTV=(BOT(ILAY)%X(ICOL,IROW)+BOT(ILAY)%X(ICOL+1,IROW))/2.0D0
ENDIF
!## write fault always, as it becomes confused
WRITE(IU,'(5I10,2G15.7,I10,4G15.7)') ILAY,IROW,ICOL,IROW,ICOL+1,HFBRESIS,FDZ,ISYS,TPV,BTV,TFV,BFV !## x-direction
ENDIF
ENDIF
!## place horizontal wall
IF(IPC(ICOL,IROW,2).EQ.INT(1,1))THEN
IF(IROW.LT.NROW)THEN
!## fraction is minus 1 for given layers
FDZ=-1.0D0
IF(ITB.EQ.0)FDZ=PMANAGER_SAVEMF2005_HFB_GETFDZ(BND,TOP,BOT,TIDF%X,BIDF%X,ICOL,IROW,ICOL,IROW+1,NODATA,ILAY,TFV,BFV)
!## enter fault if occupation > 0.0D0%
IF(ITB.EQ.0.AND.FDZ.LE.0.0D0)CYCLE
IF(ITB.NE.0)THEN
TPV=0.0D0
BTV=0.0D0
TFV=0.0D0
BFV=0.0D0
ELSE
TPV=(TOP(ILAY)%X(ICOL,IROW)+TOP(ILAY)%X(ICOL,IROW+1))/2.0D0
BTV=(BOT(ILAY)%X(ICOL,IROW)+BOT(ILAY)%X(ICOL,IROW+1))/2.0D0
ENDIF
!## write fault always, as it becomes confused
WRITE(IU,'(5I10,2G15.7,I10,4G15.7)') ILAY,IROW,ICOL,IROW+1,ICOL,HFBRESIS,FDZ,ISYS,TPV,BTV,TFV,BFV !## y-direction
ENDIF
ENDIF
ENDDO; ENDDO; ENDDO
END SUBROUTINE PMANAGER_SAVEMF2005_HFB_COLLECT
!###====================================================================
SUBROUTINE PMANAGER_SAVEMF2005_HFB_EXPORT(NHFBNP,IU,JU,IUGEN,IUDAT,IDF,LTB)
!###====================================================================
IMPLICIT NONE
REAL(KIND=DP_KIND),PARAMETER :: THICKNESS=0.5D0
LOGICAL,INTENT(IN) :: LTB
INTEGER,INTENT(IN) :: IU,JU
INTEGER,INTENT(IN),DIMENSION(:) :: IUGEN,IUDAT
INTEGER,INTENT(INOUT),DIMENSION(:) :: NHFBNP
TYPE(IDFOBJ),INTENT(INOUT) :: IDF
INTEGER :: IROW,ICOL,ILAY,IOS,JLAY,IC1,IC2,IR1,IR2,ISYS,NC,NR,KLAY
REAL(KIND=DP_KIND) :: C,C1,C2,Z,ZZ,TPV,BTV,TFV,BFV,F
INTEGER(KIND=1),ALLOCATABLE,DIMENSION(:,:,:) :: IPC
INTEGER(KIND=1),ALLOCATABLE,DIMENSION(:,:) :: SYS
REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:,:) :: RES,FDZ,TF,BF
LOGICAL :: LINV
!## compute block-faces
ALLOCATE(IPC(IDF%NCOL,IDF%NROW,2))
ALLOCATE(RES(IDF%NCOL,IDF%NROW))
ALLOCATE(FDZ(IDF%NCOL,IDF%NROW))
ALLOCATE(SYS(IDF%NCOL,IDF%NROW))
ALLOCATE(TF(IDF%NCOL,IDF%NROW))
ALLOCATE(BF(IDF%NCOL,IDF%NROW))
!## process each layer
JLAY=0; DO ILAY=1,SIZE(PBMAN%ILAY)
IF(PBMAN%ILAY(ILAY).EQ.0)CYCLE; JLAY=JLAY+1
NC=BND(ILAY)%NCOL
NR=BND(ILAY)%NROW
IPC=INT(0,1)
RES=0.0D0
FDZ=0.0D0
SYS=INT(0,1)
TF=-10.0D10
BF= 10.0D10
LINV=.FALSE.
READ(JU,*)
DO
!## z=fraction (-1=confined system; used as conductance), c=resistance
READ(JU,'(5I10,2G15.7,I10,4G15.7)',IOSTAT=IOS) KLAY,IR1,IC1,IR2,IC2,C,Z,ISYS,TPV,BTV,TFV,BFV
IF(IOS.NE.0)EXIT
IF(KLAY.NE.ILAY)CYCLE
!## skip c.lt.zero
IF(C.LT.0.0D0)CYCLE
IF(IC1.EQ.IC2)THEN
IPC(IC1,IR1,2)=INT(1,1)
ELSE
IPC(IC1,IR1,1)=INT(1,1)
ENDIF
IF(Z.GT.0.0D0)LINV=.TRUE.
!## still some space left in modellayer for an additional fault
IF(Z.LT.0.0D0.OR.FDZ(IC1,IR1).LT.1.0D0)THEN
!## available space
ZZ=1.0D0-FDZ(IC1,IR1)
!## net available space
ZZ=MIN(ZZ,Z)
!## confined system
IF(Z.LT.0.0D0)ZZ=1.0D0
!## take system number of largest contribution to c
IF(RES(IC1,IR1).GT.0.0D0)THEN
IF(Z.GT.0.0D0)THEN
!## currently available resistance
C2=1.0D0/RES(IC1,IR1)*FDZ(IC1,IR1)
IF(C.GT.C2)SYS(IC1,IR1)=INT(ISYS,1)
ELSE
IF(C.GT.RES(IC1,IR1))SYS(IC1,IR1)=INT(ISYS,1)
ENDIF
ELSE
SYS(IC1,IR1)=INT(ISYS,1)
ENDIF
!## resistance, sum conductances - ignore resistance of zero days
IF(Z.GT.0.0D0)THEN
!## add small fault using arithmetic mean
IF(TPV-BTV.LE.THICKNESS)THEN
C1=0.0D0; IF(RES(IC1,IR1).GT.0.0D0)C1=1.0D0/RES(IC1,IR1)*FDZ(IC1,IR2)
C2=C*ZZ
!## set conductance
RES(IC1,IR1)=1.0D0/((C1+C2)/(ZZ+FDZ(IC1,IR2)))
!## add large fault using harmonic mean
ELSE
!## set conductance
RES(IC1,IR1)=RES(IC1,IR1)+(1.0D0/C)*ZZ
ENDIF
ELSE
!## get largest resistance
RES(IC1,IR1)=MAX(RES(IC1,IR1),C)
ENDIF
!## occupation fraction
FDZ(IC1,IR1)=MIN(1.0D0,FDZ(IC1,IR1)+ABS(Z))
!## maximum top fault for display
TF(IC1,IR1)=MAX(TF(IC1,IR1),TF(IC2,IR2),TFV)
!## minimum bot fault for display
BF(IC1,IR1)=MIN(BF(IC1,IR1),BF(IC2,IR2),BFV)
ENDIF
ENDDO
DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL
!## place vertical wall (block in y-direction)
IF(IPC(ICOL,IROW,1).EQ.INT(1,1))THEN
IF(ICOL.LT.IDF%NCOL)THEN
!## skip faults from and to inactive cell
IF(BND(ILAY)%X(ICOL,IROW).EQ.0.0D0.AND. &
BND(ILAY)%X(ICOL+1,IROW).EQ.0.0D0)CYCLE
!## transform conductances to resistance - take into account the occupation fraction
IF(LINV)THEN
C1=1.0D0/RES(ICOL,IROW)*FDZ(ICOL,IROW)
ELSE
C1=RES(ICOL,IROW)
ENDIF
!## get total resistance related to thickness of model layer
IF(FDZ(ICOL,IROW).LT.1.0D0)THEN
!## take harmonic mean in case of unsaturated thickness of fault
C2=1.0D0/((1.0D0/C1*FDZ(ICOL,IROW))+(1.0D0-FDZ(ICOL,IROW)))
ELSE
C2=C1
ENDIF
!## get systemnumber
ISYS=SYS(ICOL,IROW)
!## top fault for display purposes
TFV=TF(ICOL,IROW)
!## bottom fault for display purposes
BFV=BF(ICOL,IROW)
!## modflow2005
IF(PBMAN%IFORMAT.EQ.2)THEN
IF(BND(ILAY)%X(ICOL,IROW).NE.0.0D0.AND. &
BND(ILAY)%X(ICOL+1,IROW).NE.0.0D0)THEN
!## add fault
NHFBNP(ILAY)=NHFBNP(ILAY)+1
WRITE(IU,'(5(I10,1X),G15.7,1X,I10)') JLAY,IROW,ICOL, IROW,ICOL+1, C2,ISYS !## y-direction
ENDIF
!## modflow6
ELSE
IF(BND(ILAY)%X(ICOL ,IROW).NE.0.0D0.AND. &
BND(ILAY)%X(ICOL+1,IROW).NE.0.0D0)THEN
!## add fault
NHFBNP(ILAY)=NHFBNP(ILAY)+1
!## get hydrch as 1/d
IF(C2.NE.0.0D0)C2=1.0D0/C2
F=MAX(0.0D0,C2)
WRITE(IU,'(6(I10,1X),G15.7,1X,I10)') JLAY,IROW,ICOL,JLAY,IROW,ICOL+1,F,ISYS !## y-direction
ENDIF
ENDIF
!## write line in genfile
CALL PMANAGER_SAVEMF2005_HFB_GENFILES(IUGEN(ILAY),IUDAT(ILAY),IPC,IDF,IDF%NROW,IDF%NCOL,IROW,ICOL, &
NHFBNP(ILAY),C1,C2,FDZ(ICOL,IROW),ISYS,1,LTB,TFV,BFV,BND(ILAY))
ENDIF
ENDIF
!## place horizontal wall (block in x-direction)
IF(IPC(ICOL,IROW,2).EQ.INT(1,1))THEN
IF(IROW.LT.IDF%NROW)THEN
!## skip faults from and/or towards inactive cell
IF(BND(ILAY)%X(ICOL,IROW).EQ.0.0D0.AND. &
BND(ILAY)%X(ICOL,IROW+1).EQ.0.0D0)CYCLE
!## transform conductances to resistance
IF(LINV)THEN
C1=1.0D0/RES(ICOL,IROW)*FDZ(ICOL,IROW)
ELSE
C1=RES(ICOL,IROW)
ENDIF
!## get total resistance related to thickness of model layer
IF(FDZ(ICOL,IROW).LT.1.0D0)THEN
!## take harmonic mean in case of unsaturated thickness of fault
C2=1.0D0/((1.0D0/C1*FDZ(ICOL,IROW))+(1.0D0-FDZ(ICOL,IROW)))
ELSE
C2=C1
ENDIF
!## get systemnumber
ISYS=SYS(ICOL,IROW)
!## top fault for display purposes
TFV=TF(ICOL,IROW)
!## bottom fault for display purposes
BFV=BF(ICOL,IROW)
!## modflow2005
IF(PBMAN%IFORMAT.EQ.2)THEN
IF(BND(ILAY)%X(ICOL,IROW).NE.0.0D0.AND. &
BND(ILAY)%X(ICOL,IROW+1).NE.0.0D0)THEN
!## add fault
NHFBNP(ILAY)=NHFBNP(ILAY)+1
WRITE(IU,'(5(I10,1X),G15.7,1X,I10)') JLAY,IROW,ICOL, IROW+1,ICOL, C2,ISYS !## x-direction
ENDIF
!## modflow6
ELSE
IF(BND(ILAY)%X(ICOL,IROW) .NE.0.0D0.AND. &
BND(ILAY)%X(ICOL,IROW+1).NE.0.0D0)THEN
!## add fault
NHFBNP(ILAY)=NHFBNP(ILAY)+1
IF(C2.NE.0.0D0)C2=1.0D0/C2
F=MAX(0.0D0,C2)
WRITE(IU,'(6(I10,1X),G15.7,1X,I10)') JLAY,IROW,ICOL,JLAY,IROW+1,ICOL,F,ISYS !## x-direction
ENDIF
ENDIF
!## write line in genfile
CALL PMANAGER_SAVEMF2005_HFB_GENFILES(IUGEN(ILAY),IUDAT(ILAY),IPC,IDF,IDF%NROW,IDF%NCOL,IROW,ICOL, &
NHFBNP(ILAY),C1,C2,FDZ(ICOL,IROW),ISYS,2,LTB,TFV,BFV,BND(ILAY))
ENDIF
ENDIF
ENDDO; ENDDO
WRITE(IUGEN(ILAY),'(A)') 'END'
REWIND(JU)
ENDDO
DEALLOCATE(IPC,RES,FDZ,SYS,TF,BF)
END SUBROUTINE PMANAGER_SAVEMF2005_HFB_EXPORT
!###====================================================================
REAL(KIND=DP_KIND) FUNCTION PMANAGER_SAVEMF2005_HFB_GETFDZ(BND,TOP,BOT,TF,BF,IC1,IR1,IC2,IR2,NODATA,ILAY,TFV,BFV)
!###====================================================================
IMPLICIT NONE
TYPE(IDFOBJ),DIMENSION(PRJNLAY),INTENT(INOUT) :: TOP,BOT,BND
REAL(KIND=DP_KIND),INTENT(IN) :: NODATA
REAL(KIND=DP_KIND),INTENT(IN),DIMENSION(:,:) :: TF,BF
REAL(KIND=DP_KIND),INTENT(OUT) :: TFV,BFV
INTEGER,INTENT(IN) :: IC1,IR1,IC2,IR2,ILAY
REAL(KIND=DP_KIND) :: TPV,BTV,FDZ
PMANAGER_SAVEMF2005_HFB_GETFDZ=0.0D0
!## determine values
IF(TF(IC1,IR1).NE.NODATA.AND.TF(IC2,IR2).NE.NODATA)THEN
TFV=(TF(IC1,IR1)+TF(IC2,IR2))/2.0D0
ELSEIF(TF(IC1,IR1).NE.NODATA)THEN
TFV=TF(IC1,IR1)
ELSEIF(TF(IC2,IR2).NE.NODATA)THEN
TFV=TF(IC2,IR2)
ELSE
TFV=-999.99D0
ENDIF
IF(BF(IC1,IR1).NE.NODATA.AND.BF(IC2,IR2).NE.NODATA)THEN
BFV=(BF(IC1,IR1)+BF(IC2,IR2))/2.0D0
ELSEIF(BF(IC1,IR1).NE.NODATA)THEN
BFV=BF(IC1,IR1)
ELSEIF(BF(IC2,IR2).NE.NODATA)THEN
BFV=BF(IC2,IR2)
ELSE
BFV=-999.99D0
ENDIF
!## skip this fault as it enteres nodata
IF(BND(ILAY)%X(IC1,IR1).EQ.0.OR.BND(ILAY)%X(IC2,IR2).EQ.0)RETURN
IF(TOP(ILAY)%X(IC1,IR1).NE.TOP(ILAY)%NODATA.AND. &
TOP(ILAY)%X(IC2,IR2).NE.TOP(ILAY)%NODATA)THEN
TPV=(TOP(ILAY)%X(IC1,IR1)+TOP(ILAY)%X(IC2,IR2))/2.0D0
ELSE
TPV=-999.99D0
ENDIF
IF(BOT(ILAY)%X(IC1,IR1).NE.BOT(ILAY)%NODATA.AND. &
BOT(ILAY)%X(IC1,IR1).NE.BOT(ILAY)%NODATA)THEN
BTV=(BOT(ILAY)%X(IC1,IR1)+BOT(ILAY)%X(IC2,IR2))/2.0D0
ELSE
BTV=-999.99D0
ENDIF
!## nett appearance of fault in modellayer
FDZ=MIN(TFV,TPV)-MAX(BFV,BTV)
!## not in current modellayer
IF(FDZ.LT.0.0D0)RETURN
IF(TPV-BTV.GT.0.0D0)THEN
!## fraction of fault in modellayer
FDZ=FDZ/(TPV-BTV)
ELSE
!## completely filled in model layer with thickness of zero
FDZ=1.0D0
ENDIF
!## fraction of layer occupation
PMANAGER_SAVEMF2005_HFB_GETFDZ=FDZ
END FUNCTION PMANAGER_SAVEMF2005_HFB_GETFDZ
!###====================================================================
SUBROUTINE PMANAGER_SAVEMF2005_HFB_GENFILES(IU,JU,IPC,IDF,NROW,NCOL,IROW,ICOL,N, &
C,RES,FDZ,ISYS,IT,LTB,TFV,BFV,BND)
!###====================================================================
IMPLICIT NONE
TYPE(IDFOBJ),INTENT(IN) :: IDF,BND
REAL(KIND=DP_KIND),INTENT(IN) :: C,RES,FDZ,TFV,BFV
LOGICAL,INTENT(IN) :: LTB
INTEGER,INTENT(IN) :: NROW,NCOL,IROW,ICOL,IU,JU,N,ISYS,IT
INTEGER(KIND=1),INTENT(IN),DIMENSION(NCOL,NROW,2) :: IPC
INTEGER :: IBND
REAL(KIND=DP_KIND) :: T1,B1
!## place vertical wall
IF(IT.EQ.1)THEN
IF(IPC(ICOL,IROW,1).EQ.INT(1,1).AND.ICOL.LT.NCOL)THEN
IF(JU.GT.0)THEN
IBND=0; IF(BND%X(ICOL,IROW).EQ.0.OR.BND%X(ICOL+1,IROW).EQ.0)IBND=1
IF(LTB)THEN
!## write location of fault for m6f and submodel
IF(TFV.GE.BFV)WRITE(JU,'(I10,3(1X,E15.7),6I10)') N,C,RES,FDZ,ISYS,ICOL,IROW,ICOL+1,IROW,IBND
ELSE
!## write location of fault for m6f and submodel
WRITE(JU,'(I10,1X ,E15.7 ,6I10)') N,C,ISYS,ICOL,IROW,ICOL+1,IROW,IBND
ENDIF
ENDIF
IF(ICOL.LT.PRJIDF%NCOL)THEN
IF(LTB)THEN
IF(TFV.GE.BFV)THEN
T1=TFV; B1=BFV
WRITE(IU,'(I10)') N
WRITE(IU,'(3(F15.3,A1))') IDF%SX(ICOL),',',IDF%SY(IROW-1),',',T1
WRITE(IU,'(3(F15.3,A1))') IDF%SX(ICOL),',',IDF%SY(IROW) ,',',T1
WRITE(IU,'(3(F15.3,A1))') IDF%SX(ICOL),',',IDF%SY(IROW) ,',',B1
WRITE(IU,'(3(F15.3,A1))') IDF%SX(ICOL),',',IDF%SY(IROW-1),',',B1
WRITE(IU,'(3(F15.3,A1))') IDF%SX(ICOL),',',IDF%SY(IROW-1),',',T1
WRITE(IU,'(A)') 'END'
ENDIF
ELSE
WRITE(IU,'(I10)') N
WRITE(IU,'(2(F15.3,A1))') IDF%SX(ICOL),',',IDF%SY(IROW-1)
WRITE(IU,'(2(F15.3,A1))') IDF%SX(ICOL),',',IDF%SY(IROW)
WRITE(IU,'(A)') 'END'
ENDIF
ENDIF
ENDIF
ENDIF
!## place horizontal wall
IF(IT.EQ.2)THEN
IF(IPC(ICOL,IROW,2).EQ.INT(1,1).AND.IROW.LT.NROW)THEN
IF(JU.GT.0)THEN
IBND=0; IF(BND%X(ICOL,IROW).EQ.0.OR.BND%X(ICOL,IROW+1).EQ.0)IBND=1
IF(LTB)THEN
!## write location of fault for m6f and submodel
IF(TFV.GE.BFV)WRITE(JU,'(I10,3(1X,E15.7),6I10)') N,C,RES,FDZ,ISYS,ICOL,IROW,ICOL,IROW+1,IBND
ELSE
!## write location of fault for m6f and submodel
WRITE(JU,'(I10,1X ,E15.7 ,6I10)') N,C,ISYS,ICOL,IROW,ICOL,IROW+1,IBND
ENDIF
ENDIF
IF(IROW.LT.PRJIDF%NROW)THEN
IF(LTB)THEN
IF(TFV.GE.BFV)THEN
T1=TFV; B1=BFV
WRITE(IU,'(I10)') N
WRITE(IU,'(3(F15.3,A1))') IDF%SX(ICOL-1),',',IDF%SY(IROW),',',T1
WRITE(IU,'(3(F15.3,A1))') IDF%SX(ICOL ),',',IDF%SY(IROW),',',T1
WRITE(IU,'(3(F15.3,A1))') IDF%SX(ICOL ),',',IDF%SY(IROW),',',B1
WRITE(IU,'(3(F15.3,A1))') IDF%SX(ICOL-1),',',IDF%SY(IROW),',',B1
WRITE(IU,'(3(F15.3,A1))') IDF%SX(ICOL-1),',',IDF%SY(IROW),',',T1
WRITE(IU,'(A)') 'END'
ENDIF
ELSE
WRITE(IU,'(I10)') N
WRITE(IU,'(2(F15.3,A1))') IDF%SX(ICOL-1),',',IDF%SY(IROW)
WRITE(IU,'(2(F15.3,A1))') IDF%SX(ICOL ),',',IDF%SY(IROW)
WRITE(IU,'(A)') 'END'
ENDIF
ENDIF
ENDIF
ENDIF
END SUBROUTINE PMANAGER_SAVEMF2005_HFB_GENFILES
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_LAK_CONFIG()
!###======================================================================
IMPLICIT NONE
INTEGER :: IROW,ICOL,ILAY,I,JROW,JCOL
REAL(KIND=DP_KIND) :: C,ZT,ZB,X1,X2,Y1,Y2,L,TIB,F,KD1,KD2,OT1,OT2
INTEGER,DIMENSION(4) :: IR,IC
DATA IR/-1, 0,0,1/
DATA IC/ 0,-1,1,0/
PMANAGER_SAVEMF2005_LAK_CONFIG=.TRUE.
IF(.NOT.TOPICS(TLAK)%DEFINED)RETURN
PMANAGER_SAVEMF2005_LAK_CONFIG=.FALSE.
!## lake numbers are integer values only
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
LAK(1)%X(ICOL,IROW)=INT(LAK(1)%X(ICOL,IROW))
ENDDO; ENDDO
!## get unique number of lakes
ALLOCATE(DULAKES(PRJIDF%NCOL*PRJIDF%NROW))
I=0; DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL; I=I+1; DULAKES(I)=INT(LAK(1)%X(ICOL,IROW)); ENDDO; ENDDO
CALL UTL_GETUNIQUE_INT(DULAKES,PRJIDF%NROW*PRJIDF%NCOL,NLAKES,0)
ALLOCATE(ULAKES(NLAKES)); DO I=1,NLAKES; ULAKES(I)=DULAKES(I); ENDDO; DEALLOCATE(DULAKES)
!## reset array lbd - boundary settings, layer becomes lakes as bathymetry of over half of cell
DO ILAY=1,PRJNLAY; DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL; LBD(ILAY)%X(ICOL,IROW)=0.0D0; ENDDO; ENDDO; ENDDO
!## reset array lcd - sum of conductance vertically/horizontally
DO ILAY=1,PRJNLAY; DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL; LCD(ILAY)%X(ICOL,IROW)=0.0D0; ENDDO; ENDDO; ENDDO
!## get lakebed leakance - combination of resistance and model resistance of depth AROUND lake
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
!## skip non lake cells
IF(LAK(1)%X(ICOL,IROW).LE.0)CYCLE
!## find appropriate modellayer underneath bathymetry of lake
DO ILAY=1,PRJNLAY
!## apply lakes only for active cells (>0)
IF(BND(ILAY)%X(ICOL,IROW).LE.0)CYCLE
ZT=TOP(ILAY)%X(ICOL,IROW)
!## found appropriate modellayer
IF(ZT.GT.LAK(2)%X(ICOL,IROW))THEN
!## cannot have a lake in the lowest model layer
IF(ILAY.EQ.PRJNLAY)THEN
! CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You cannot put a lake in the lowest model layer'//CHAR(13)// &
! 'Make sure the bathymetry is always higher than the top of'//CHAR(13)// &
! 'your lowest model layer in order to avoid this error message.','Error')
! RETURN
ENDIF
!## lake number is equal to internal number in the sort-list
DO I=1,NLAKES
IF(INT(LAK(1)%X(ICOL,IROW)).EQ.ULAKES(I))THEN; LBD(ILAY)%X(ICOL,IROW)=I; EXIT; ENDIF
ENDDO
BND(ILAY)%X(ICOL,IROW)=0.0D0
!## modify existing aquitard due to this displacement - can be removed partly by lake
IF(ILAY.LT.PRJNLAY)THEN
!## bottom of current model layer
ZB=TOP(ILAY+1)%X(ICOL,IROW)
ELSE
ZB=BOT(ILAY)%X(ICOL,IROW)
ENDIF
!## thickness original interbed
TIB=BOT(ILAY)%X(ICOL,IROW)-ZB
!top =10
!lak = 4
!bot = 2
!zb = 0
!tib = 2
!## compute fraction for leakance in case lake bathymetry is higher
IF(ZB.LT.LAK(2)%X(ICOL,IROW))THEN
!## add extra resistance to leakance of part of aquifer
IF(BOT(ILAY)%X(ICOL,IROW).LT.LAK(2)%X(ICOL,IROW))THEN
C=(LAK(2)%X(ICOL,IROW)-BOT(ILAY)%X(ICOL,IROW))/(KHV(ILAY)%X(ICOL,IROW)/KVA(ILAY)%X(ICOL,IROW))
ENDIF
OT1=0.0D0; OT2=0.0D0
IF(ILAY.LT.PRJNLAY)THEN
OT1=BOT(ILAY )%X(ICOL,IROW)-TOP(ILAY+1)%X(ICOL,IROW)
OT2=TOP(ILAY+1)%X(ICOL,IROW)-BOT(ILAY+1)%X(ICOL,IROW)
ENDIF
!## adjust bot as the LAK package uses this to create the table input
BOT(ILAY)%X(ICOL,IROW)=LAK(2)%X(ICOL,IROW)
!## make sure thickness of interbed remains the same
IF(TIB.EQ.0.0D0)THEN
!## increase permeability in ratio in case no interbed and interface is shifted upwards
IF(ILAY.LT.PRJNLAY)THEN
TOP(ILAY+1)%X(ICOL,IROW)=BOT(ILAY)%X(ICOL,IROW)
KD1=KHV(ILAY )%X(ICOL,IROW)*OT1
KD2=KHV(ILAY+1)%X(ICOL,IROW)*OT2
KD1=KD1+KD2; KD2=KD1/OT2
KHV(ILAY+1)%X(ICOL,IROW)=KHV(ILAY+1)%X(ICOL,IROW)*KD2
ENDIF
ELSE
!## top remains the same but thickness can be enlarged of the interbed, correct with permeability
F=(BOT(ILAY)%X(ICOL,IROW)-TOP(ILAY+1)%X(ICOL,IROW))/TIB
KVV(ILAY)%X(ICOL,IROW)=KVV(ILAY)%X(ICOL,IROW)*F
ENDIF
ELSE
C=0.0D0
ENDIF
!## lake leakance for vertical conductances - excl. the effect of vertical shift, this is taken care of by MF2005
LCD(ILAY)%X(ICOL,IROW)=1.0D0/LAK(6)%X(ICOL,IROW)
ENDIF
ENDDO
ENDDO; ENDDO
!## get lakebed lateral leakances
DO ILAY=1,PRJNLAY; DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
!## found lake cell
IF(LBD(ILAY)%X(ICOL,IROW).NE.0)THEN
!## compute lateral leakances
DO I=1,SIZE(IC)
JROW=IR(I)+IROW; JCOL=IC(I)+ICOL
IF(JROW.GT.PRJIDF%NROW.OR.JROW.LT.1)CYCLE
IF(JCOL.GT.PRJIDF%NCOL.OR.JCOL.LT.1)CYCLE
!## not equal a lake, thus next to the lake and not inactive cell
IF(LBD(ILAY)%X(JCOL,JROW).EQ.0.AND. &
BND(ILAY)%X(JCOL,JROW).NE.0)THEN
CALL IDFGETEDGE(PRJIDF,JROW,JCOL,X1,Y1,X2,Y2)
IF(JROW.EQ.IROW)THEN; L=X2-X1 ; ENDIF
IF(JCOL.EQ.ICOL)THEN; L=Y2-Y1 ; ENDIF
!## resistance along lake
C=L/KHV(ILAY)%X(ICOL,IROW)
!## lake leakance for vertical conductances - excl. the effect of vertical shift, this is taken care of by MF2005
LCD(ILAY)%X(JCOL,JROW)=1.0D0/LAK(6)%X(ICOL,IROW)
ENDIF
ENDDO
ENDIF
ENDDO; ENDDO; ENDDO
PMANAGER_SAVEMF2005_LAK_CONFIG=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_LAK_CONFIG
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_LAKE_GETMEANVALUE(X,Y,ULAKE,LVL,IBATCH,IOP)
!###======================================================================
IMPLICIT NONE
REAL(KIND=DP_KIND),DIMENSION(:,:),INTENT(IN) :: X,Y
INTEGER,INTENT(IN) :: ULAKE
INTEGER,INTENT(IN) :: IBATCH,IOP
REAL(KIND=DP_KIND),INTENT(OUT) :: LVL
REAL(KIND=DP_KIND) :: ILVL
INTEGER :: IROW,ICOL
PMANAGER_SAVEMF2005_LAKE_GETMEANVALUE=.FALSE.
LVL=0.0D0; ILVL=0.0D0
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
IF(INT(X(ICOL,IROW)).EQ.ULAKE)THEN
SELECT CASE (IOP)
!## average/sum
CASE (1,4); LVL=LVL+Y(ICOL,IROW); ILVL=ILVL+1.0D0
!## min
CASE (2); IF(ILVL.EQ.0)THEN; LVL=Y(ICOL,IROW); ELSE; LVL=MIN(LVL,Y(ICOL,IROW)); ENDIF; ILVL=ILVL+1.0D0
!## max
CASE (3); IF(ILVL.EQ.0)THEN; LVL=Y(ICOL,IROW); ELSE; LVL=MAX(LVL,Y(ICOL,IROW)); ENDIF; ILVL=ILVL+1.0D0
END SELECT
ENDIF
ENDDO; ENDDO
IF(ILVL.LE.0.0D0)THEN
IF(IBATCH.EQ.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMOD cannot assign a lakelevel for lake '//TRIM(ITOS(ULAKE)),'Error')
RETURN
ELSE
WRITE(*,'(A)') 'iMOD cannot assign a lakelevel for lake '//TRIM(ITOS(ULAKE)); STOP
ENDIF
ENDIF
IF(IOP.EQ.1)LVL=LVL/ILVL
PMANAGER_SAVEMF2005_LAKE_GETMEANVALUE=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_LAKE_GETMEANVALUE
!###======================================================================
SUBROUTINE PMANAGER_SAVEMF2005_BND(ISIZE)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN),DIMENSION(:,:) :: ISIZE
INTEGER :: IROW,ICOL,NN,NE,NS,NW,ILAY,I,J,ISUB
ILAY=0; DO I=1,SIZE(PBMAN%ILAY)
!## turn all boundaries on zero for this layer
IF(PBMAN%ILAY(I).EQ.0)THEN
BND(I)%X=0.0D0; CYCLE
ENDIF
ILAY=ILAY+1
DO IROW=1,BND(ILAY)%NROW
DO ICOL=1,BND(ILAY)%NCOL
IF(BND(ILAY)%X(ICOL,IROW).EQ.HNOFLOW)BND(ILAY)%X(ICOL,IROW)=0.0D0
!## snap to integer
BND(ILAY)%X(ICOL,IROW)=DBLE(INT(BND(ILAY)%X(ICOL,IROW)))
!## correct for boundary values from mf6
IF(PBMAN%IFORMAT.EQ.3)THEN
!## assign mf6 blocking per layer
IF(PBMAN%SMTYPE.EQ.1)THEN
ISUB=PBMAN%ISUBMODEL
IF(PBMAN%SM(ISUB)%IDF(ILAY)%X(ICOL,IROW).EQ.PBMAN%SM(ISUB)%IDF(ILAY)%NODATA)BND(ILAY)%X(ICOL,IROW)=0.0D0
ELSE
IF(PRJIDF%X(ICOL,IROW).EQ.PRJIDF%NODATA)THEN
BND(ILAY)%X(ICOL,IROW)=0.0D0
ELSE
!## set a fixed head around the border of the sub model (only for the first)
IF(PBMAN%ISUBMODEL.EQ.1)THEN
!## submodel is smaller than extent of ibound, change boundary
IF(SUM(ISIZE(:,ILAY)).GT.0)THEN
IF(BND(ILAY)%X(ICOL,IROW).GT.0.0D0.AND.PRJIDF%X(ICOL,IROW).LT.0.0D0)BND(ILAY)%X(ICOL,IROW)=PRJIDF%X(ICOL,IROW)
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
ENDDO
ENDDO
NN=0; NW=0; NS=0; NE=0
!## only apply this to mf2005
IF(PBMAN%IFORMAT.NE.3)THEN
!## replace ibound for boundaries
DO IROW=1,BND(ILAY)%NROW
! IF(ISIZE(1,ILAY).EQ.1)THEN; ICOL=1; IF(BND(ILAY)%X(ICOL,IROW).GT.0)THEN; NW=NW+1; BND(ILAY)%X(ICOL,IROW)=-1; ENDIF; ENDIF
! IF(ISIZE(3,ILAY).EQ.1)THEN; ICOL=BND(ILAY)%NCOL; IF(BND(ILAY)%X(ICOL,IROW).GT.0)THEN; NE=NE+1; BND(ILAY)%X(ICOL,IROW)=-1; ENDIF; ENDIF
IF(IFULL(1).EQ.1)THEN; ICOL=1; IF(BND(ILAY)%X(ICOL,IROW).GT.0)THEN; NW=NW+1; BND(ILAY)%X(ICOL,IROW)=-1; ENDIF; ENDIF
IF(IFULL(3).EQ.1)THEN; ICOL=BND(ILAY)%NCOL; IF(BND(ILAY)%X(ICOL,IROW).GT.0)THEN; NE=NE+1; BND(ILAY)%X(ICOL,IROW)=-1; ENDIF; ENDIF
ENDDO
DO ICOL=1,BND(ILAY)%NCOL
! IF(ISIZE(4,ILAY).EQ.1)THEN; IROW=1; IF(BND(ILAY)%X(ICOL,IROW).GT.0)THEN; NN=NN+1; BND(ILAY)%X(ICOL,IROW)=-1; ENDIF; ENDIF
! IF(ISIZE(2,ILAY).EQ.1)THEN; IROW=BND(ILAY)%NROW; IF(BND(ILAY)%X(ICOL,IROW).GT.0)THEN; NS=NS+1; BND(ILAY)%X(ICOL,IROW)=-1; ENDIF; ENDIF
IF(IFULL(4).EQ.1)THEN; IROW=1; IF(BND(ILAY)%X(ICOL,IROW).GT.0)THEN; NN=NN+1; BND(ILAY)%X(ICOL,IROW)=-1; ENDIF; ENDIF
IF(IFULL(2).EQ.1)THEN; IROW=BND(ILAY)%NROW; IF(BND(ILAY)%X(ICOL,IROW).GT.0)THEN; NS=NS+1; BND(ILAY)%X(ICOL,IROW)=-1; ENDIF; ENDIF
ENDDO
IF(NN+NS+NW+NE.GT.0)THEN
WRITE(*,'(A)') 'Modified boundary layer '//TRIM(ITOS(ILAY))//' due to submodelling N/S/W/E: ' // &
TRIM(ITOS(NN))//'/'//TRIM(ITOS(NS))//'/'//TRIM(ITOS(NW))//'/'//TRIM(ITOS(NE))
ENDIF
ENDIF
ENDDO
!## turn off isolated cells (constant heads)
ILAY=0; DO I=1,SIZE(PBMAN%ILAY)
IF(PBMAN%ILAY(I).EQ.0)CYCLE; ILAY=ILAY+1
DO IROW=1,BND(ILAY)%NROW
DO ICOL=1,BND(ILAY)%NCOL
!## check if constant head connected to active node
IF(BND(ILAY)%X(ICOL,IROW).LT.0)THEN
!## inactive unless proves otherwise
J=0
IF(ILAY.GT.1)THEN; IF(BND(ILAY-1)%X(ICOL ,IROW ).GT.0)J=-1; ENDIF
IF(ILAY.LT.PRJNLAY)THEN; IF(BND(ILAY+1)%X(ICOL ,IROW ).GT.0)J=-1; ENDIF
IF(ICOL.GT.1)THEN; IF(BND(ILAY )%X(ICOL-1,IROW ).GT.0)J=-1; ENDIF
IF(ICOL.LT.BND(ILAY)%NCOL)THEN; IF(BND(ILAY )%X(ICOL+1,IROW ).GT.0)J=-1; ENDIF
IF(IROW.GT.1)THEN; IF(BND(ILAY )%X(ICOL ,IROW-1).GT.0)J=-1; ENDIF
IF(IROW.LT.BND(ILAY)%NROW)THEN; IF(BND(ILAY )%X(ICOL ,IROW+1).GT.0)J=-1; ENDIF
BND(ILAY)%X(ICOL,IROW)=J
ENDIF
ENDDO
ENDDO
ENDDO
END SUBROUTINE PMANAGER_SAVEMF2005_BND
!###======================================================================
SUBROUTINE PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,IDF,ITYPE,ITOPIC)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ITOPIC,ILAY,ITYPE
TYPE(IDFOBJ),INTENT(INOUT) :: IDF
TYPE(IDFOBJ),INTENT(INOUT),DIMENSION(:) :: BND
INTEGER :: IROW,ICOL,JLAY
LOGICAL :: LEX
CHARACTER(LEN=1) :: YESNO
IF(ILAY.GT.0)THEN
DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL
!## blank out inactive cells
IF(BND(ILAY)%X(ICOL,IROW).EQ.0)THEN
! IDF%X(ICOL,IROW)=IDF%NODATA
ELSE
IF(ITYPE.EQ.0)THEN
!## check whether nodata for active location
IF(IDF%X(ICOL,IROW).EQ.IDF%NODATA)THEN
LEX=.TRUE.
!## vcw/kvv might be inactive though boundary underneath is zero
IF(ITOPIC.EQ.TVCW.OR.ITOPIC.EQ.TKVV)THEN
IF(BND(ILAY+1)%X(ICOL,IROW).EQ.0)LEX=.FALSE.
ENDIF
IF(LEX)THEN
IF(.NOT.LYESNO)THEN
WRITE(*,'(/1X,A)') 'Error NodataValue found for active cell'
WRITE(*,'(A3,3A4,3A15 )') 'VAR','COL','ROW','LAY','IBOUND','X','NODATAVALUE'
WRITE(*,'(A3,3I4,F15.1,2E15.7)') TOPICS(ITOPIC)%CMOD,ICOL,IROW,ILAY,BND(ILAY)%X(ICOL,IROW),IDF%X(ICOL,IROW),IDF%NODATA
WRITE(*,'(A$)') 'Continue yes (default value of 1.0D0 is set) / no ?'
READ(*,'(A1)') YESNO
IF(UTL_CAP(YESNO,'U').EQ.'N')STOP
LYESNO=.TRUE.
ELSE
!## set dummy value
IDF%X(ICOL,IROW)=1.0D0
ENDIF
ENDIF
ENDIF
ENDIF
ENDIF
!## blank out layer below in case of vertical conductance
IF(ITOPIC.EQ.TVCW.OR.ITOPIC.EQ.TKVV)THEN
IF(BND(ILAY+1)%X(ICOL,IROW).EQ.0)IDF%X(ICOL,IROW)=IDF%NODATA
ENDIF
ENDDO; ENDDO
!## find uppermost active cell
ELSEIF(ILAY.EQ.0)THEN
DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL
DO JLAY=1,PRJNLAY; IF(BND(JLAY)%X(ICOL,IROW).GT.0)EXIT; ENDDO
!## skip if location is equal to nodata, completely
IF(JLAY.GT.PRJNLAY)CYCLE
IF(ITYPE.EQ.0)THEN
!## check whether nodata for active location
IF(IDF%X(ICOL,IROW).EQ.IDF%NODATA)THEN
WRITE(*,'(/1X,A)') 'Error NodataValue found for active cell'
WRITE(*,'(A3,3A4,3A15 )') 'VAR','COL','ROW','LAY','IBOUND','X','NODATAVALUE'
WRITE(*,'(A3,3I4,F15.1,2E15.7)') TOPICS(ITOPIC)%CMOD,ICOL,IROW,JLAY,BND(JLAY)%X(ICOL,IROW),IDF%X(ICOL,IROW),IDF%NODATA
PAUSE; STOP
ENDIF
ENDIF
ENDDO; ENDDO
ENDIF
!## blank out negative values for 'KDW','KHV','KVA','VCW','KVV','STO','SSC'
SELECT CASE (ITOPIC)
CASE (TKDW,TKHV,TKVA,TVCW,TKVV,TSTO,TSPY)
DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL
IF(IDF%X(ICOL,IROW).EQ.IDF%NODATA)CYCLE
IF(IDF%X(ICOL,IROW).LT.0.0D0)IDF%X(ICOL,IROW)=0.0D0
ENDDO; ENDDO
END SELECT
! !## remove input for inactive cells
! IF(ILAY.GT.0)THEN
! DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL
! IF(BND(ILAY)%X(ICOL,IROW).EQ.0)IDF%X(ICOL,IROW)=IDF%NODATA
! ENDDO; ENDDO
! ENDIF
!## skip fhb(31) / chd(28) package
IF(ITOPIC.NE.TFHB.AND.ITOPIC.NE.TCHD)THEN
!## remove packages on constant head cells
IF(ITYPE.EQ.1.AND.ILAY.GT.0)THEN
DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL
!## blank out constant head cells
IF(BND(ILAY)%X(ICOL,IROW).LT.0)IDF%X(ICOL,IROW)=IDF%NODATA
ENDDO; ENDDO
ENDIF
ENDIF
END SUBROUTINE PMANAGER_SAVEMF2005_CORRECT
END MODULE MOD_PMANAGER_MF2005