!! Copyright (C) Stichting Deltares, 2005-2018.
!!
!! 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
CONTAINS
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEPST(IU,IOPTION,DIR,ISS)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IU,IOPTION,ISS
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=1,PRJIDF%NCOL)
WRITE(IU,*) (PRJIDF%SY(IROW),IROW=1,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))
WRITE(IU,'(A)') TRIM(LINE)
ENDDO
ELSE
LINE=TRIM(ITOS(0))
WRITE(IU,'(A)') TRIM(LINE)
ENDIF
ENDIF
IF(IOPTION.EQ.2)THEN
LINE=TRIM(ITOS(SIZE(PEST%PARAM))); 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)
LINE=TRIM(ITOS(PEST%PE_MXITER)) //','//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))
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(PEST%PARAM(I)%PIGROUP)) //','// &
TRIM(ITOS(PEST%PARAM(I)%PLOG))
IF(TRIM(PEST%PARAM(I)%ACRONYM).NE.'')LINE=TRIM(LINE)//','//TRIM(PEST%PARAM(I)%ACRONYM)
WRITE(IU,'(A)') TRIM(LINE)
ENDDO
ENDIF
IF(ASSOCIATED(PEST%IDFFILES))THEN
LINE=TRIM(ITOS(SIZE(PEST%IDFFILES)))
WRITE(IU,'(A)') TRIM(LINE)
DO I=1,SIZE(PEST%IDFFILES)
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
!## 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
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.
!## overrule ipst if not as keyword given
IF(IBATCH.EQ.1.AND.PBMAN%IPEST.EQ.0)TOPICS(20)%IACT_MODEL=0
!## get active packages
IF(.NOT.PMANAGER_GETPACKAGES(IBATCH))RETURN
DO I=1,MAXTOPICS
SELECT CASE (I)
CASE (12,18,19,30,31,32)
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
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
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(PREFVAL(1))//'\MODELS\'//TRIM(MODELNAME)//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(1)%IACT_MODEL.EQ.1)THEN
IF(ASSOCIATED(TOPICS(1)%STRESS))THEN
LINE=TOPICS(1)%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.2)NSCL=0
IF(PBMAN%IWINDOW.EQ.1)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
IF(PBMAN%IWINDOW.EQ.2)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)
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
!## non-equistantial network
IF(PBMAN%IWINDOW.EQ.2)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'
DO I=1,MAXTOPICS
IF(TOPICS(I)%IACT_MODEL.EQ.0)CYCLE
!## skip pcg
IF(I.EQ.33)CYCLE
!## pst module is exception
IF(I.EQ.20)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
SELECT CASE (I)
CASE (5)
CALL PMANAGER_SAVEMF2005_RUN_ISAVE(PBMAN%SAVESHD,TOPICS(I)%TNAME(1:5),IU)
CASE (4,6,7,9,10,11)
CALL PMANAGER_SAVEMF2005_RUN_ISAVE(PBMAN%SAVEFLX,TOPICS(I)%TNAME(1:5),IU)
CASE (21) !## wel
CALL PMANAGER_SAVEMF2005_RUN_ISAVE(PBMAN%SAVEWEL,TOPICS(I)%TNAME(1:5),IU)
CASE (22) !## drn
CALL PMANAGER_SAVEMF2005_RUN_ISAVE(PBMAN%SAVEDRN,TOPICS(I)%TNAME(1:5),IU)
CASE (23) !## riv
CALL PMANAGER_SAVEMF2005_RUN_ISAVE(PBMAN%SAVERIV,TOPICS(I)%TNAME(1:5),IU)
CASE (24) !## evt
CALL PMANAGER_SAVEMF2005_RUN_ISAVE(PBMAN%SAVEEVT,TOPICS(I)%TNAME(1:5),IU)
CASE (25) !## ghb
CALL PMANAGER_SAVEMF2005_RUN_ISAVE(PBMAN%SAVEGHB,TOPICS(I)%TNAME(1:5),IU)
CASE (26) !## rch
CALL PMANAGER_SAVEMF2005_RUN_ISAVE(PBMAN%SAVERCH,TOPICS(I)%TNAME(1:5),IU)
CASE (27) !## olf
CALL PMANAGER_SAVEMF2005_RUN_ISAVE(PBMAN%SAVEDRN,TOPICS(I)%TNAME(1:5),IU)
CASE (29) !## isg
CALL PMANAGER_SAVEMF2005_RUN_ISAVE(PBMAN%SAVERIV,TOPICS(I)%TNAME(1:5),IU)
CASE DEFAULT
WRITE(IU,'(A)') '1,0 '//TRIM(TOPICS(I)%TNAME)
END SELECT
ENDDO
!## write bndfile
WRITE(IU,'(A)') CHAR(39)//TRIM(BNDFNAME)//CHAR(39)
WRITE(IU,'(A)') 'MODULES FOR EACH LAYER'
!## write modules
DO I=1,MAXTOPICS
IF(TOPICS(I)%IACT_MODEL.EQ.0)CYCLE
IF(TOPICS(I)%TIMDEP)CYCLE
!## skip pcg
IF(I.EQ.33)CYCLE
!## pst module is exception
IF(I.EQ.20)THEN
LINE=TRIM(ITOS(SIZE(PEST%PARAM)))//',(PST)'; WRITE(IU,'(A)') TRIM(LINE)
IF(.NOT.PMANAGER_SAVEPST(IU,1,'',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.1)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.1.OR.I.EQ.13)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.1)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 (21,29); 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)
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 :: IULAK,ISTEADY,IPER,INIPER,LPER,KPER,IINI,IPRT,I,J
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(IBATCH))RETURN
!## 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(ISS,IBATCH))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 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)
!## 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 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,LUZF,18,IUZFCB1,'UZF',(/1,2,3,4,5,6,7,8/),IPRT))RETURN
!## save mnw package
IF(.NOT.PMANAGER_SAVEMF2005_MNW(DIRMNAME,IBATCH,LMNW,19,IWL2CB,'MNW',IPRT))RETURN
!## save wel package
IF(.NOT.PMANAGER_SAVEMF2005_WEL(DIR,DIRMNAME,IBATCH,LWEL,21,IWELCB,'WEL',IPRT))RETURN
!## save drn package
IF(.NOT.PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,LDRN,22,IDRNCB,'DRN',(/2,1/),IPRT))RETURN
!## save isg package (always before riv in case of dmm-files)
IF(.NOT.LRIV)THEN
IF(.NOT.PMANAGER_SAVEMF2005_ISG(DIR,DIRMNAME,IBATCH,LISG,29,IRIVCB,'RIV',IPRT))RETURN
ELSE
IF(.NOT.PMANAGER_SAVEMF2005_ISG(DIR,DIRMNAME,IBATCH,LISG,29,IRIVCB,'ISG',IPRT))RETURN
ENDIF
!## save riv package
IF(.NOT.PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,LRIV,23,IRIVCB,'RIV',(/2,1,3,4/),IPRT))RETURN
!## save evt package
IF(.NOT.PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,LEVT,24,IEVTCB,'EVT',(/2,1,3/),IPRT))RETURN
!## save ghb package
IF(.NOT.PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,LGHB,25,IGHBCB,'GHB',(/2,1/),IPRT))RETURN
!## save rch package
IF(.NOT.PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,LRCH,26,IRCHCB,'RCH',(/1/),IPRT))RETURN
!## save olf package
IF(.NOT.LDRN)THEN
IF(.NOT.PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,LOLF,27,IDRNCB,'DRN',(/1/),IPRT))RETURN
ELSE
IF(.NOT.PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,LOLF,27,IDRNCB,'OLF',(/1/),IPRT))RETURN
ENDIF
!## save chd package
IF(.NOT.PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,LCHD,28,ICHDCB,'CHD',(/1/),IPRT))RETURN
!## save sfr package
IF(.NOT.PMANAGER_SAVEMF2005_ISG(DIR,DIRMNAME,IBATCH,LSFR,30,ISFRCB,'SFR',IPRT))RETURN
!## save fhb package
IF(.NOT.PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,LFHB,31,IFHBCB,'FHB',(/1,2/),IPRT))RETURN
IF(LLAK)THEN
!## save rest of lak package
LPER=0; DO IPER=1,PRJNPER
!## get appropriate stress-period to store in runfile
KPER=PMANAGER_GETCURRENTIPER(IPER,32,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(LOLF.AND.LDRN)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(LISG.AND.LRIV)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=1,PBMAN%NSUBMODEL
DO J=I+1,PBMAN%NSUBMODEL
CALL PMANAGER_SAVEMF6_EXG(MAINDIR,I,J)
ENDDO
ENDDO
ENDIF
PMANAGER_SAVEMF2005=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005
!###======================================================================
SUBROUTINE PMANAGER_SAVEMF6_EXG(DIR,M1,M2)
!###======================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIR
INTEGER,INTENT(IN) :: M1,M2
REAL(KIND=DP_KIND) :: XP,YP,T,B,Z1,Z2
INTEGER :: IU,JU,I,J,K,IM,N,M,IOS,II,ILAY,MAXNLAY,IROW,ICOL,IMDL1,IMDL2,JROW,JCOL
TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:,:) :: TOP,BOT,BND
INTEGER,DIMENSION(2) :: MNLAY
CHARACTER(LEN=256) :: FNAME,LINE
CHARACTER(LEN=52) :: TXT,MDLNAME
CHARACTER(LEN=1) :: TLAYMODEL
CHARACTER(LEN=5),DIMENSION(3) :: PCK
DATA PCK/'RIV6','RCH6','WEL6'/
LOGICAL :: LSUBMODEL,LEX
MDLNAME=DIR(INDEX(DIR,'\',.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'
WRITE(IU,'(1X,A)') 'PRINT_INPUT'
WRITE(IU,'(1X,A)') 'PRINT_FLOWS'
WRITE(IU,'(1X,A)') 'SAVE_FLOWS'
! 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 + top/bottom = summary file with bnd/top/bot
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(II.EQ.2)THEN
IF(IM.EQ.1)THEN
DO I=1,1; IF(.NOT.IDFREAD(TOP(1,I),TRIM(DIR)//'\GWF_'//TRIM(ITOS(M1))//'\MODELINPUT\DIS6\TOP_L'//TRIM(ITOS(I))//'.IDF',1))RETURN; ENDDO
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
DO I=1,MNLAY(IM); IF(.NOT.IDFREAD(BOT(1,I),TRIM(DIR)//'\GWF_'//TRIM(ITOS(M1))//'\MODELINPUT\DIS6\BOT_L'//TRIM(ITOS(I))//'.IDF',1))RETURN; ENDDO
ELSE
DO I=1,1; IF(.NOT.IDFREAD(TOP(2,I),TRIM(DIR)//'\GWF_'//TRIM(ITOS(M2))//'\MODELINPUT\DIS6\TOP_L'//TRIM(ITOS(I))//'.IDF',1))RETURN; ENDDO
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
DO I=1,MNLAY(IM); IF(.NOT.IDFREAD(BOT(2,I),TRIM(DIR)//'\GWF_'//TRIM(ITOS(M2))//'\MODELINPUT\DIS6\BOT_L'//TRIM(ITOS(I))//'.IDF',1))RETURN; ENDDO
ENDIF
EXIT
ENDIF
ENDIF
ENDDO
CLOSE(JU)
ENDDO
IF(II.EQ.1)THEN
ALLOCATE(TOP(2,1),BOT(2,MAXNLAY),BND(2,MAXNLAY))
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
DO I=1,SIZE(BND,1); DO J=1,SIZE(BND,2); CALL IDFNULLIFY(BND(I,J)); ENDDO; ENDDO
ENDIF
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))
ENDDO; ENDDO; ENDDO; ENDDO
!## who is smallest in cellsize and/or dimension
IMDL1=1; IMDL2=2; LSUBMODEL=.FALSE.; TLAYMODEL=''
!## check size first
IF(BND(2,1)%XMIN.GT.BND(1,1)%XMIN.AND. &
BND(2,1)%XMAX.LT.BND(1,1)%XMAX.AND. &
BND(2,1)%YMIN.GT.BND(1,1)%YMIN.AND. &
BND(2,1)%YMAX.LT.BND(1,1)%YMAX)THEN
!## throw an error in the case a submodel, is coarser - not supported
IF(BND(2,1)%DX.GT.BND(1,1)%DX)THEN
WRITE(*,'(/A/)') 'A submodel need to have at least a cellsize which is equal or smaller than the overlapping model'; STOP
ENDIF
IMDL2=1; IMDL1=2; LSUBMODEL=.TRUE.
!## check size second
ELSEIF(BND(1,1)%XMIN.GT.BND(2,1)%XMIN.AND. &
BND(1,1)%XMAX.LT.BND(2,1)%XMAX.AND. &
BND(1,1)%YMIN.GT.BND(2,1)%YMIN.AND. &
BND(1,1)%YMAX.LT.BND(2,1)%YMAX)THEN
!## throw an error in the case a submodel, is coarser - not supported
IF(BND(1,1)%DX.GT.BND(2,1)%DX)THEN
WRITE(*,'(/A/)') 'A submodel need to have at least a cellsize which is equal or smaller than the overlapping model'; STOP
ENDIF
IMDL2=2; IMDL1=1; LSUBMODEL=.TRUE.
!## if not, equal model size but different layers
ELSEIF(BND(2,1)%XMIN.EQ.BND(1,1)%XMIN.AND. &
BND(2,1)%XMAX.EQ.BND(1,1)%XMAX.AND. &
BND(2,1)%YMIN.EQ.BND(1,1)%YMIN.AND. &
BND(2,1)%YMAX.EQ.BND(1,1)%YMAX)THEN
IF(BND(2,1)%DX.LT.BND(1,1)%DX)THEN
IMDL1=2; IMDL2=1
ENDIF
!## determine whether submodel is on top or bottom
DO IROW=1,BND(IMDL1,1)%NROW; DO ICOL=1,BND(IMDL1,1)%NCOL
IF(BND(IMDL1,1)%X(ICOL,IROW).EQ.1)THEN
T=TOP(IMDL1,1)%X(ICOL,IROW)
B=BOT(IMDL1,1)%X(ICOL,IROW)
Z1=B+0.5D0*(T-B)
!## get z from other model
CALL IDFGETLOC(BND(IMDL1,1),IROW,ICOL,XP,YP)
CALL IDFIROWICOL(BND(IMDL2,1),JROW,JCOL,XP,YP)
!## outside parent model
IF(JROW.LE.0.OR.JCOL.LE.0)RETURN
T=TOP(IMDL2,1)%X(JCOL,JROW)
B=BOT(IMDL2,1)%X(JCOL,JROW)
Z2=B+0.5D0*(T-B)
IF(Z2.GT.Z1)THEN
IF(TLAYMODEL.EQ.'')THEN
TLAYMODEL='T' !## other model is on top
ELSEIF(TLAYMODEL.NE.'T')THEN
WRITE(*,'(/1X,A/)') 'Vertical TOP inconsistency between two submodels'; STOP
ENDIF
ELSEIF(Z2.LT.Z1)THEN
IF(TLAYMODEL.EQ.'')THEN
TLAYMODEL='B' !## other model is at bottom
ELSEIF(TLAYMODEL.NE.'B')THEN
WRITE(*,'(/1X,A/)') 'Vertical BOT inconsistency between two submodels'; STOP
ENDIF
ENDIF
ENDIF
ENDDO; ENDDO
IF(TLAYMODEL.EQ.'')THEN
WRITE(*,'(/1X,A/)') 'Cannot position model vertically'; STOP
ENDIF
ENDIF
DO I=1,2
N=0
DO ILAY=1,MNLAY(IMDL1)
IF(LSUBMODEL)THEN
!## north connection
IF(I.EQ.2)WRITE(IU,'(/A)') '# North Connection'
IROW=1; DO ICOL=1,BND(IMDL1,ILAY)%NCOL
IF(PMANAGER_SAVEMF6_EXG_CONNECTIONS('N',IU,ILAY,IROW,ICOL,IMDL1,IMDL2,MNLAY(IMDL1),MNLAY(IMDL2), &
BND(IMDL1,ILAY),BND(IMDL2,ILAY),TOP(IMDL1,ILAY),BOT(IMDL1,ILAY),TOP(IMDL2,ILAY),BOT(IMDL2,ILAY),I))N=N+1
ENDDO
!## south connection
IF(I.EQ.2)WRITE(IU,'(/A)') '# South Connection'
IROW=BND(IMDL1,ILAY)%NROW; DO ICOL=1,BND(IMDL1,ILAY)%NCOL
IF(PMANAGER_SAVEMF6_EXG_CONNECTIONS('S',IU,ILAY,IROW,ICOL,IMDL1,IMDL2,MNLAY(IMDL1),MNLAY(IMDL2), &
BND(IMDL1,ILAY),BND(IMDL2,ILAY),TOP(IMDL1,ILAY),BOT(IMDL1,ILAY),TOP(IMDL2,ILAY),BOT(IMDL2,ILAY),I))N=N+1
ENDDO
!## west connection
IF(I.EQ.2)WRITE(IU,'(/A)') '# West Connection'
ICOL=1; DO IROW=1,BND(IMDL1,ILAY)%NROW
IF(PMANAGER_SAVEMF6_EXG_CONNECTIONS('W',IU,ILAY,IROW,ICOL,IMDL1,IMDL2,MNLAY(IMDL1),MNLAY(IMDL2), &
BND(IMDL1,ILAY),BND(IMDL2,ILAY),TOP(IMDL1,ILAY),BOT(IMDL1,ILAY),TOP(IMDL2,ILAY),BOT(IMDL2,ILAY),I))N=N+1
ENDDO
!## east connection
IF(I.EQ.2)WRITE(IU,'(/A)') '# East Connection'
ICOL=BND(IMDL1,ILAY)%NCOL; DO IROW=1,BND(IMDL1,ILAY)%NROW
IF(PMANAGER_SAVEMF6_EXG_CONNECTIONS('E',IU,ILAY,IROW,ICOL,IMDL1,IMDL2,MNLAY(IMDL1),MNLAY(IMDL2), &
BND(IMDL1,ILAY),BND(IMDL2,ILAY),TOP(IMDL1,ILAY),BOT(IMDL1,ILAY),TOP(IMDL2,ILAY),BOT(IMDL2,ILAY),I))N=N+1
ENDDO
!## clean cells in course model
DO IROW=1,BND(IMDL1,ILAY)%NROW; DO ICOL=1,BND(IMDL1,ILAY)%NCOL
CALL IDFGETLOC(BND(IMDL1,ILAY),IROW,ICOL,XP,YP)
CALL IDFIROWICOL(BND(IMDL2,ILAY),JROW,JCOL,XP,YP)
BND(IMDL2,ILAY)%X(JCOL,JROW)=0.0D0
ENDDO; ENDDO
ENDIF
ENDDO
!## define connection from top-bottom
IF(TRIM(TLAYMODEL).NE.'')THEN
DO IROW=1,BND(IMDL1,1)%NROW; DO ICOL=1,BND(IMDL1,1)%NCOL
IF(TLAYMODEL.EQ.'T')THEN
IF(PMANAGER_SAVEMF6_EXG_CONNECTIONS(TLAYMODEL,IU,1,IROW,ICOL,IMDL1,IMDL2,MNLAY(IMDL1),MNLAY(IMDL2), &
BND(IMDL1,1),BND(IMDL2,MNLAY(IMDL2)),TOP(IMDL1,1),BOT(IMDL1,1),TOP(IMDL2,MNLAY(IMDL2)),BOT(IMDL2,MNLAY(IMDL2)),I))N=N+1
ELSEIF(TLAYMODEL.EQ.'B')THEN
IF(PMANAGER_SAVEMF6_EXG_CONNECTIONS(TLAYMODEL,IU,MNLAY(IMDL1),IROW,ICOL,IMDL1,IMDL2,MNLAY(IMDL1),MNLAY(IMDL2), &
BND(IMDL1,MNLAY(IMDL1)),BND(IMDL2,1),TOP(IMDL1,MNLAY(IMDL1)),BOT(IMDL1,MNLAY(IMDL1)),TOP(IMDL2,1),BOT(IMDL2,1),I))N=N+1
ENDIF
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))
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)
DO I=1,SIZE(BND,2)
IU=UTL_GETUNIT()
CALL OSD_OPEN(IU,FILE=TRIM(DIR)//'\GWF_'//TRIM(ITOS(IMDL1))//'\MODELINPUT\DIS6\IBOUND_L'//TRIM(ITOS(I))//'.ARR',STATUS='UNKNOWN', &
ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
CALL IDFWRITEFREE(IU,BND(IMDL1,I),1,'B','*')
CLOSE(IU)
ENDDO
DO I=1,SIZE(BND,2)
IU=UTL_GETUNIT()
CALL OSD_OPEN(IU,FILE=TRIM(DIR)//'\GWF_'//TRIM(ITOS(IMDL2))//'\MODELINPUT\DIS6\IBOUND_L'//TRIM(ITOS(I))//'.ARR',STATUS='UNKNOWN', &
ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
CALL IDFWRITEFREE(IU,BND(IMDL2,I),1,'B','*')
CLOSE(IU)
ENDDO
!## clean packages - need to remove them (or put them on an active location and deactivate them)
DO I=1,SIZE(PCK)
INQUIRE(FILE=TRIM(DIR)//'\GWF_'//TRIM(ITOS(IMDL2))//'\MODELINPUT\'//TRIM(MDLNAME)//'.'//TRIM(PCK(I)),EXIST=LEX)
IF(.NOT.LEX)EXIT
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIR)//'\GWF_'//TRIM(ITOS(IMDL2))//'\MODELINPUT\'//TRIM(MDLNAME)//'.'//TRIM(PCK(I)), &
STATUS='OLD',ACTION='READ',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=TRIM(DIR)//'\GWF_'//TRIM(ITOS(IMDL2))//'\MODELINPUT\'//TRIM(MDLNAME)//'.'//TRIM(PCK(I))//'_', &
STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(JU.EQ.0)RETURN
M=0
DO J=1,2
DO
READ(IU,'(A256)',IOSTAT=IOS) LINE
IF(IOS.NE.0)EXIT
IF(INDEX(LINE,'MAXBOUND').GT.0)THEN
IF(J.EQ.2)WRITE(JU,'(A)') 'MAXBOUND '//TRIM(ITOS(MAX(1,M)))
ELSEIF(INDEX(LINE,'BEGIN PERIOD').GT.0)THEN
IF(J.EQ.2)WRITE(JU,'(A)') TRIM(LINE)
N=0
DO
READ(IU,'(A256)',IOSTAT=IOS) LINE
IF(IOS.NE.0)EXIT
IF(INDEX(LINE,'END PERIOD').GT.0)EXIT
READ(LINE,*) ILAY,IROW,ICOL
!## skip inactive cells
IF(BND(IMDL2,ILAY)%X(ICOL,IROW).EQ.0.0D0)CYCLE
N=N+1; IF(J.EQ.2)WRITE(JU,'(A)') TRIM(LINE)
ENDDO
IF(J.EQ.2)WRITE(JU,'(A)') TRIM(LINE)
M=MAX(M,N)
ELSE
IF(J.EQ.2)WRITE(JU,'(A)') TRIM(LINE)
ENDIF
ENDDO
REWIND(IU)
ENDDO
CLOSE(IU,STATUS='DELETE'); CLOSE(JU)
CALL IOSRENAMEFILE(TRIM(DIR)//'\GWF_'//TRIM(ITOS(IMDL2))//'\MODELINPUT\'//TRIM(MDLNAME)//'.'//TRIM(PCK(I))//'_', &
TRIM(DIR)//'\GWF_'//TRIM(ITOS(IMDL2))//'\MODELINPUT\'//TRIM(MDLNAME)//'.'//TRIM(PCK(I)))
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)
END SUBROUTINE PMANAGER_SAVEMF6_EXG
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF6_EXG_CONNECTIONS(CDIR,IU,ILAY,IROW,ICOL,IMDL1,IMDL2,NLAY1,NLAY2,BND1,BND2,TOP1,BOT1,TOP2,BOT2,IIU)
!###======================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: CDIR
TYPE(IDFOBJ),INTENT(IN) :: BND1,BND2,TOP1,BOT1,TOP2,BOT2
INTEGER,INTENT(IN) :: ILAY,IROW,ICOL,IMDL1,IMDL2,IU,IIU,NLAY1,NLAY2
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
REAL(KIND=DP_KIND),DIMENSION(2) :: CL
PMANAGER_SAVEMF6_EXG_CONNECTIONS=.FALSE.
!## current centre location of fine model
CALL IDFGETLOC( BND1,IROW,ICOL,XP1,YP1)
CALL IDFGETEDGE(BND1,IROW,ICOL,X1 ,Y1 ,X2 ,Y2)
!## get vertical position of node
Z2=TOP1%X(ICOL,IROW); Z1=BOT1%X(ICOL,IROW)
DZ1=Z2-Z1; ZP1=Z1+0.5D0*DZ1
!## get cellsize of fine model
CALL IDFGETDXDY(BND1,IROW,ICOL,DX1,DY1)
!## get location of nearest course model
SELECT CASE (CDIR)
CASE ('N'); CALL IDFGETLOC( BND1,IROW-1,ICOL,XP,YP); IHC=1; JLAY=ILAY
CASE ('S'); CALL IDFGETLOC( BND1,IROW+1,ICOL,XP,YP); IHC=1; JLAY=ILAY
CASE ('W'); CALL IDFGETLOC( BND1,IROW,ICOL-1,XP,YP); IHC=1; JLAY=ILAY
CASE ('E'); CALL IDFGETLOC( BND1,IROW,ICOL+1,XP,YP); IHC=1; JLAY=ILAY
CASE ('T'); CALL IDFGETLOC( BND1,IROW,ICOL ,XP,YP); IHC=0; JLAY=NLAY2
CASE ('B'); CALL IDFGETLOC( BND1,IROW,ICOL ,XP,YP); IHC=0; JLAY=1
END SELECT
CALL IDFIROWICOL(BND2,JROW,JCOL,XP,YP)
!## outside parent model
IF(JROW.LE.0.OR.JCOL.LE.0)RETURN
!## get location of cell outside submodel
CALL IDFGETLOC(BND2,JROW,JCOL,XP2,YP2)
!## get vertical position of node
DZ2=TOP2%X(JCOL,JROW)-BOT2%X(JCOL,JROW)
ZP2=BOT2%X(JCOL,JROW)+0.5D0*DZ2
!## get cellsize of course model
CALL IDFGETDXDY(BND2,JROW,JCOL,DX2,DY2)
CELLID(IMDL1,1)=ILAY
CELLID(IMDL1,2)=IROW
CELLID(IMDL1,3)=ICOL
CELLID(IMDL2,1)=JLAY
CELLID(IMDL2,2)=JROW
CELLID(IMDL2,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(IMDL1)=UTL_DIST(XP1,YP1,XINT1,YINT1)
CL(IMDL2)=UTL_DIST(XP2,YP2,XINT2,YINT2)
HWVA=X2-X1
!## area of connection
ELSEIF(IHC.EQ.0)THEN
CL(IMDL1)=UTL_DIST_3D(XP1,YP1,ZP1,XINT1,YINT1,ZINT1)
CL(IMDL2)=UTL_DIST_3D(XP2,YP2,ZP2,XINT2,YINT2,ZINT2)
HWVA=(X2-X1)*(Y2-Y1)
ENDIF
IF(IIU.EQ.2)WRITE(IU,'(7I10,4G15.7)') (CELLID(1,I),I=1,3),(CELLID(2,I),I=1,3),IHC,CL(1),CL(2),HWVA
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) :: XBOT
REAL(KIND=DP_KIND),DIMENSION(:),ALLOCATABLE :: TP,BT,HK,VK,VA,TH,TP_BU,BT_BU,HK_BU,VK_BU,VA_BU
INTEGER,DIMENSION(:),ALLOCATABLE :: IB
REAL(KIND=SP_KIND) :: ST,SB
!## make sure nodata for anisotropy factors is 1.0D0
IF(LANI)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
!## clean from bottom to top inactive layers with zero conductance
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
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=REAL(BOT(ILAY)%X(ICOL,IROW),4)
ST=REAL(TOP(ILAY)%X(ICOL,IROW),4)
SB=MIN(ST,SB)
BOT(ILAY)%X(ICOL,IROW)=DBLE(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)=DBLE(ST)
ENDIF
!## store last active layer
JLAY=ILAY
ENDDO; ENDDO; ENDDO
ELSEIF(PBMAN%ICONSISTENCY.EQ.2)THEN
ALLOCATE(TP(PRJNLAY) ,BT(PRJNLAY) ,HK(PRJNLAY) ,VK(PRJNLAY-1) ,VA(PRJNLAY) ,IB(PRJNLAY),TH(PRJNLAY), &
TP_BU(PRJNLAY),BT_BU(PRJNLAY),HK_BU(PRJNLAY),VK_BU(PRJNLAY-1),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
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)
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
BOT(ILAY)%X(ICOL,IROW)=BOT(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
ENDIF
ENDDO
ENDDO; ENDDO
DEALLOCATE(TP,BT,HK,VK,VA,IB,TH,TP_BU,BT_BU,HK_BU,VK_BU,VA_BU)
ENDIF
!## 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
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
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
CHARACTER(LEN=52) :: MNAME
PMANAGER_SAVEMF2005_NAM=.FALSE.
!## 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=I+1,PBMAN%NSUBMODEL
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(LMSP)CALL UTL_CREATEDIR(TRIM(DIR)//'\MSWAPINPUT')
IF(PBMAN%IFORMAT.EQ.3)THEN
! IF(PBMAN%NSUBMODEL.GT.1)
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(LCHD) WRITE(IU,'(A)') ' CHD6 '//TRIM(DIRMNAME)//'.CHD6'
IF(LWEL) WRITE(IU,'(A)') ' WEL6 '//TRIM(DIRMNAME)//'.WEL6'
IF(LDRN) WRITE(IU,'(A)') ' DRN6 '//TRIM(DIRMNAME)//'.DRN6'
IF(LRCH) WRITE(IU,'(A)') ' RCH6 '//TRIM(DIRMNAME)//'.RCH6'
IF(LRIV) WRITE(IU,'(A)') ' RIV6 '//TRIM(DIRMNAME)//'.RIV6'
WRITE(IU,'(A)') 'END PACKAGES'
CLOSE(IU)
ELSE
DIRMNAME='.\'//TRIM(DIRMNAME)
!## write *.nam file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(FNAME),STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# Nam File Generated by '//TRIM(UTL_IMODVERSION())
WRITE(IU,'(A)') 'LIST 10 '//CHAR(39)//'.\'//TRIM(MNAME)//'.LIST'//CHAR(39)
WRITE(IU,'(A)') 'MET 11 '//CHAR(39)//TRIM(DIRMNAME)//'.MET7'//CHAR(39)
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) WRITE(IU,'(A)') 'LPF 14 '//CHAR(39)//TRIM(DIRMNAME)//'.LPF7'//CHAR(39)
IF(LPCG) 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)
WRITE(IU,'(A)') 'OC 16 '//CHAR(39)//TRIM(DIRMNAME)//'.OC'//CHAR(39)
IF(LRCH) WRITE(IU,'(A)') 'RCH 17 '//CHAR(39)//TRIM(DIRMNAME)//'.RCH7'//CHAR(39)
IF(LEVT) WRITE(IU,'(A)') 'EVT 18 '//CHAR(39)//TRIM(DIRMNAME)//'.EVT7'//CHAR(39)
IF(LDRN.OR.LOLF) WRITE(IU,'(A)') 'DRN 19 '//CHAR(39)//TRIM(DIRMNAME)//'.DRN7'//CHAR(39)
IF(LRIV.OR.LISG) WRITE(IU,'(A)') 'RIV 20 '//CHAR(39)//TRIM(DIRMNAME)//'.RIV7'//CHAR(39)
IF(LGHB) WRITE(IU,'(A)') 'GHB 21 '//CHAR(39)//TRIM(DIRMNAME)//'.GHB7'//CHAR(39)
IF(LCHD) WRITE(IU,'(A)') 'CHD 22 '//CHAR(39)//TRIM(DIRMNAME)//'.CHD7'//CHAR(39)
IF(LWEL) WRITE(IU,'(A)') 'WEL 23 '//CHAR(39)//TRIM(DIRMNAME)//'.WEL7'//CHAR(39)
IF(LHFB) WRITE(IU,'(A)') 'HFB6 24 '//CHAR(39)//TRIM(DIRMNAME)//'.HFB7'//CHAR(39)
IF(LSFR) WRITE(IU,'(A)') 'SFR 25 '//CHAR(39)//TRIM(DIRMNAME)//'.SFR7'//CHAR(39)
IF(LFHB)THEN; WRITE(IU,'(A)') 'FHB 26 '//CHAR(39)//TRIM(DIRMNAME)//'.FHB7'//CHAR(39); IFHBUN=26; ENDIF
IF(LLAK) WRITE(IU,'(A)') 'LAK 27 '//CHAR(39)//TRIM(DIRMNAME)//'.LAK7'//CHAR(39)
IF(LUZF) WRITE(IU,'(A)') 'UZF 28 '//CHAR(39)//TRIM(DIRMNAME)//'.UZF7'//CHAR(39)
IF(LMNW) WRITE(IU,'(A)') 'MNW2 29 '//CHAR(39)//TRIM(DIRMNAME)//'.MNW7'//CHAR(39)
IF(LANI) WRITE(IU,'(A)') 'ANI 30 '//CHAR(39)//TRIM(DIRMNAME)//'.ANI1'//CHAR(39)
IF(LMSP) WRITE(IU,'(A)') 'DXC 31 '//CHAR(39)//TRIM(DIRMNAME)//'.DXC'//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(LRCH)WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',IRCHCB,' '//CHAR(39)//'BDGRCH '//CHAR(39)
IF(LEVT)WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',IEVTCB,' '//CHAR(39)//'BDGEVT '//CHAR(39)
IF(LDRN.OR.LOLF)WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',IDRNCB,' '//CHAR(39)//'BDGDRN '//CHAR(39)
IF(LRIV.OR.LISG)WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',IRIVCB,' '//CHAR(39)//'BDGRIV '//CHAR(39)
IF(LGHB)WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',IGHBCB,' '//CHAR(39)//'BDGGHB'//CHAR(39)
IF(LCHD)WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',ICHDCB,' '//CHAR(39)//'BDGCHD'//CHAR(39)
IF(LWEL)WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',IWELCB,' '//CHAR(39)//'BDGWEL'//CHAR(39)
IF(LSFR)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(LFHB)WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',IFHBCB ,' '//CHAR(39)//'BDGFHB'//CHAR(39)
IF(LLAK)WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',ILAKCB ,' '//CHAR(39)//'BDGLAK'//CHAR(39)
IF(LUZF)WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',IUZFCB1,' '//CHAR(39)//'UZFINF BDGGRC BDGGET UZFRUN UZFET UZFSFR'//CHAR(39)
IF(LMNW)WRITE(IU,'(A,I3,A)') 'DATA(BINARYIDF) ',IWL2CB ,' '//CHAR(39)//'BDGMNW'//CHAR(39)
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(ISS,IBATCH)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ISS,IBATCH
INTEGER :: ILAY
PMANAGER_SAVEMF2005_SIM=.FALSE.
!## read idf for dimensions
CALL IDFNULLIFY(PRJIDF); IFULL=0
IF(.NOT.PMANAGER_INIT_SIMAREA(PRJIDF,IBATCH))RETURN
IF(ISUBMODEL.EQ.1)THEN
!## 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)
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
!## 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)
!## 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,SUBMODEL(1)+SUBMODEL(6), &
SUBMODEL(2)+SUBMODEL(6), &
SUBMODEL(3)-SUBMODEL(6), &
SUBMODEL(4)-SUBMODEL(6),SUBMODEL(7)))RETURN
ENDIF
ENDIF
IF(.NOT.IDFALLOCATEX(PRJIDF))RETURN
!## fill sx/sy variable in idf
IF(.NOT.IDFFILLSXSY(PRJIDF))RETURN
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(LANI)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(LLAK)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(LSFT)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(LANI)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(LLAK)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(LSFT)THEN
DO ILAY=1,SIZE(SFT); CALL IDFCOPY(PRJIDF,SFT(ILAY)); ENDDO
ENDIF
PMANAGER_SAVEMF2005_SIM=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_SIM
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_PST_READWRITE(DIR,DIRMNAME,IBATCH,ISS)
!####====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME
INTEGER,INTENT(IN) :: IBATCH,ISS
INTEGER :: N,IU
PMANAGER_SAVEMF2005_PST_READWRITE=.TRUE.
IF(.NOT.LPST)RETURN
!## overrule is by imod batch
IF(IBATCH.EQ.1.AND.PBMAN%IPEST.EQ.0)RETURN
PMANAGER_SAVEMF2005_PST_READWRITE=.FALSE.
N=0; IF(ASSOCIATED(PEST%MEASURES))THEN
N=SIZE(PEST%MEASURES)
ENDIF
IF(N.EQ.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'//'...'
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.PST1',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); 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))RETURN
CLOSE(IU)
PMANAGER_SAVEMF2005_PST_READWRITE=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_PST_READWRITE
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_BAS_READ(IPRT)
!####====================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IPRT
INTEGER :: ITOPIC,SCL_D,SCL_U,ILAY
PMANAGER_SAVEMF2005_BAS_READ=.FALSE.
ALLOCATE(FNAMES(PRJNLAY),PRJILIST(1))
!## bnd settings
ITOPIC=4; SCL_D=0; SCL_U=1; PRJILIST=ITOPIC; IF(PMANAGER_GETFNAMES(1,PRJNLAY,0,1,0).LE.0)RETURN
DO ILAY=1,PRJNLAY
CALL IDFCOPY(PRJIDF,BND(ILAY))
IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(BND(ILAY),ITOPIC,ILAY,SCL_D,SCL_U,0,IPRT))RETURN
!## adjust boundary for submodel()
CALL PMANAGER_SAVEMF2005_BND(ILAY)
ENDDO
!## shd settings
ITOPIC=5; SCL_D=1; SCL_U=2; PRJILIST=ITOPIC; IF(PMANAGER_GETFNAMES(1,PRJNLAY,0,1,0).LE.0)RETURN
DO ILAY=1,PRJNLAY
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)
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,JLAY,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'//'...'
IF(PBMAN%IFORMAT.EQ.2)THEN
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
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)
ELSE
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.IC',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# IC 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) !PRJNLAY
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)
ENDIF
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) !PRJNLAY
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=1; SCL_U=2
DO ILAY=1,PRJNLAY
!## top data
ITOPIC=2; 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
!## not wise to do that as 3d uses bottom and if layers do not match you get layers of zero thickness
! CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,TOP(ILAY),0,ITOPIC)
LEX=.TRUE.
ENDIF
ENDIF
IF(.NOT.LEX)THEN; TOP(ILAY)%X=0.0D0; LTB=.FALSE.; ENDIF
!## bot data
ITOPIC=3; 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
!## not wise to do that as 3d uses bottom and if layers do not match you get layers of zero thickness
! CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,BOT(ILAY),0,ITOPIC)
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,ITOPIC,ICOL,IROW,N,I
INTEGER,ALLOCATABLE,DIMENSION(:) :: LCBD
REAL(KIND=DP_KIND) :: T
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=2
!## 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,ITOPIC))RETURN
ENDIF
ITOPIC=3
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\DIS6\BOTM_L'//TRIM(ITOS(ILAY))//'.ARR', &
BOT(ILAY),0,IU,ILAY,ITOPIC))RETURN
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'
LINE=TRIM(LINE)//' ['//TRIM(SIM(KPER)%CDATE)//']'
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)) !PRJNLAY))
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
WRITE(IU,'(/A/)') '#Vertical Configuration'
WRITE(IU,'(A)') 'TOP'
ITOPIC=2
!## get first model layer
DO I=1,SIZE(PBMAN%ILAY); IF(PBMAN%ILAY(I).EQ.1)EXIT; ENDDO
!## quasi-3d scheme add top aquifer modellayer
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\DIS6\TOP_L'//TRIM(ITOS(1))//'.ARR', &
TOP(I),0,IU,1,ITOPIC))RETURN
!## write idf for connection-purposes
IF(.NOT.IDFWRITE(TOP(I),TRIM(DIR)//'\DIS6\TOP_L'//TRIM(ITOS(1))//'.IDF',1))RETURN
WRITE(IU,'(A)') 'BOTM LAYERED'
ITOPIC=3
JLAY=0; DO ILAY=1,SIZE(PBMAN%ILAY) !PRJNLAY
IF(PBMAN%ILAY(ILAY).EQ.0)CYCLE
JLAY=JLAY+1
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\DIS6\BOTM_L'//TRIM(ITOS(JLAY))//'.ARR', &
BOT(ILAY),0,IU,ILAY,ITOPIC))RETURN
!## write idf for connection-purposes
IF(.NOT.IDFWRITE(BOT(ILAY),TRIM(DIR)//'\DIS6\BOT_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) !PRJNLAY
IF(PBMAN%ILAY(ILAY).EQ.0)CYCLE
JLAY=JLAY+1
!## modify bnd for idomain parameter
PRJIDF%X=BND(ILAY)%X
!## clean idomain which was the boundary condition
DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL
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)PRJIDF%X(ICOL,IROW)=-1.0D0
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
!## transient simulation
IF(ISS.EQ.1)THEN
!## sf1
ITOPIC=11; SCL_D=1; 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=6; SCL_D=1; 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=9; SCL_D=1; 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,IROW,ICOL
REAL(KIND=DP_KIND) :: T,T1,T2,T3
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
!## hkv
ITOPIC=7; SCL_D=1; 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=8; SCL_D=1; 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=11; SCL_D=1; 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=12; SCL_D=1; 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=10; SCL_D=1; 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
!## 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
IF(BND(ILAY)%X(ICOL,IROW).NE.0)THEN
T=TOP(ILAY)%X(ICOL,IROW)-BOT(ILAY)%X(ICOL,IROW)
KDW(ILAY)%X(ICOL,IROW)=T*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(KHV(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
KVV(ILAY)%X(ICOL,IROW)=T/PBMAN%MINC
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))
T3=0.0D0; IF(KHV(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
DEALLOCATE(FNAMES,PRJILIST)
PMANAGER_SAVEMF2005_LPF_READ=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_LPF_READ
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_LPF_SAVE(DIR,DIRMNAME,IBATCH,ISS)
!####====================================================================
IMPLICIT NONE
REAL(KIND=DP_KIND),PARAMETER :: WETDRYTHRESS=0.1 !1.0D0 <- converges
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME
INTEGER,INTENT(IN) :: IBATCH,ISS
REAL(KIND=DP_KIND) :: WETFCT,T
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'
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
!## 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,T)
ELSE
PRJIDF%X(ICOL,IROW)= MIN(WETDRYTHRESS,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 !1.0D0 <- converges
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME
INTEGER,INTENT(IN) :: IBATCH
REAL(KIND=DP_KIND) :: WETFCT,T
INTEGER :: IU,ILAY,JLAY,IFBND,IHDWET,IWETIT,IROW,ICOL
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'
WRITE(IU,'(A)') ' SAVE_FLOWS'
WRITE(IU,'(A)') ' ALTERNATIVE_CELL_AVERAGING AMT-HMK'
WRITE(IU,'(A)') ' THICKSTRT'
!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
! WRITE(IU,'(A)') ' [XT3D [RHS]]'
! 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) !PRJNLAY
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
WRITE(IU,'(A)') ' K LAYERED'
JLAY=0; DO ILAY=1,SIZE(PBMAN%ILAY) !PRJNLAY
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
! WRITE(IU,'(A)') ' K22 LAYERED'
! -- READARRAY]
!## vertical k-value
WRITE(IU,'(A)') ' K33 LAYERED'
JLAY=0; DO ILAY=1,SIZE(PBMAN%ILAY) !PRJNLAY
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)
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
! WRITE(IU,'(A)') ' ANGLE1 LAYERED'
! WRITE(IU,'(A)') ' ANGLE2 LAYERED'
! WRITE(IU,'(A)') ' ANGLE3 LAYERED'
IF(IWETIT.EQ.1)THEN
WRITE(IU,'(A)') ' WETDRY LAYERED'
JLAY=0; DO ILAY=1,SIZE(PBMAN%ILAY) !PRJNLAY
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_STO_SAVE(DIR,DIRMNAME,IBATCH,ISS)
!####====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME
INTEGER,INTENT(IN) :: IBATCH,ISS
INTEGER :: IU,ILAY,ISY,KPER
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'
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
DO ILAY=1,PRJNLAY
IF(LAYCON(ILAY).EQ.2)THEN
WRITE(IU,'(A)') ' CONSTANT 1' !## confined storage
ELSE
WRITE(IU,'(A)') ' CONSTANT 0' !## convertible storage
ISY=1
ENDIF
ENDDO
WRITE(IU,'(A)') ' SS LAYERED'
DO ILAY=1,PRJNLAY
!## hk
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\STO\SS_L'//TRIM(ITOS(ILAY))//'.ARR', &
STO(ILAY),0,IU,ILAY,1))RETURN
ENDDO
IF(ISY.EQ.1)THEN
WRITE(IU,'(A)') ' SY LAYERED'
DO ILAY=1,PRJNLAY
!## hk
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\STO\SY_L'//TRIM(ITOS(ILAY))//'.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.LANI)RETURN
PMANAGER_SAVEMF2005_ANI_READ=.FALSE.
!## ani angle
IINV=0; ITOPIC=14
!## 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
!## 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=1 !## 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,IFBND
PMANAGER_SAVEMF2005_ANI_SAVE=.TRUE.
!## use ani1
IF(.NOT.LANI)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
DO ILAY=1,PRJNLAY
!## anisotropy factors
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\ANI1\ANF_L'//TRIM(ITOS(ILAY))//'.ARR', &
ANF(ILAY),0,IU,ILAY,IFBND))RETURN
!## anisotropy angle
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\ANI1\ANA_L'//TRIM(ITOS(ILAY))//'.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,LEX,ITOPIC,ICB,CPCK,IPRT)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IBATCH,ICB,ITOPIC,IPRT
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME,CPCK
LOGICAL,INTENT(IN) :: LEX
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
REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: TLP,KH,TP,BT
INTEGER(KIND=8) :: ITIME,JTIME
REAL(KIND=DP_KIND),PARAMETER :: MINKHT=0.0D0
INTEGER,PARAMETER :: ICLAY=1 !## shift to nearest aquifer
CHARACTER(LEN=1) :: VTXT
IF(.NOT.LEX)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'
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
! 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
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))
IF(PBMAN%IFORMAT.EQ.2)THEN
JU=0
!## create subfolders
CALL UTL_CREATEDIR(TRIM(DIR)//'\'//CPCK//'7')
EXFNAME=TRIM(DIR)//'\'//CPCK//'7'//'\'//CPCK//'_T'//TRIM(ITOS(IPER))//'.ARR'
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
ELSE
JU=IU
ENDIF
! !## create subfolders
! CALL UTL_CREATEDIR(TRIM(DIR)//'\'//CPCK//'7')
! EXFNAME=TRIM(DIR)//'\'//CPCK//'7'//'\'//CPCK//'_T'//TRIM(ITOS(IPER))//'.ARR'
! 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); 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),*,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,BND,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
DO ILAY=1,PRJNLAY
IF(TLP(ILAY).GT.0.0D0)THEN
WRITE(JU,FRM) ILAY,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)),'Error'); EXIT
ENDIF
ENDDO
IF(PBMAN%IFORMAT.EQ.3)WRITE(IU,'(A)') 'END PERIOD '//TRIM(ITOS(IPER))
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.EQ.2)THEN
LINE=TRIM(ITOS(NP)); WRITE(IU,'(A)') TRIM(LINE)
IF(NP.GT.0)THEN
SFNAME=EXFNAME; DO I=1,3; 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
ENDIF
ENDDO
CLOSE(IU); DEALLOCATE(TLP,TP,BT,KH)
IF(IOS.EQ.0)THEN
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,LEX,ITOPIC,ICB,CPCK,IPRT)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IBATCH,ICB,ITOPIC,IPRT
CHARACTER(LEN=*),INTENT(IN) :: DIRMNAME,CPCK
LOGICAL,INTENT(IN) :: LEX
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(.NOT.LEX)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
!## maximal output information
MNWPRINT=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
!## output
WRITE(IPRT,'(1X,A,I10)') 'Exporting timestep ',IPER
!## get appropriate stress-period to store in runfile
KPER=PMANAGER_GETCURRENTIPER(IPER,ITOPIC,ITIME,JTIME)
!## always export extraction values
KPER=ABS(KPER)
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
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
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,LEX,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
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME,CPCK
LOGICAL,INTENT(IN) :: LEX
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
IF(.NOT.LEX)THEN; PMANAGER_SAVEMF2005_ISG=.TRUE.; RETURN; ENDIF
PMANAGER_SAVEMF2005_ISG=.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
SELECT CASE (ITOPIC)
!## isg
CASE (29)
LINE='NaN1#,'//TRIM(ITOS(ICB))//' AUX RFCT AUX ISUB RFACT RFCT RSUBSYS ISUB NOPRINT'
!## IFVDL SFT RCNC
!## sfr
CASE (30)
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)
WRITE(FRM,'(A9,I2.2,A14)') '(3(I5,1X),',1,'(G15.7,1X),I5)'
!## create subfolders
CALL UTL_CREATEDIR(TRIM(DIR)//'\'//CPCK//'7')
CALL PMANAGER_SAVEMF2005_ALLOCATEPCK(PRJNLAY)
NP=0
DO IPER=1,PRJNPER
!## reset only for isg to riv conversion
IF(ITOPIC.EQ.29)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.29)THEN; IF(PBMAN%DISG.EQ.1)KPER=ABS(KPER); ENDIF
!## output
WRITE(IPRT,'(1X,A,2I10,2(1X,I14))') 'Exporting timestep ',IPER,KPER,ITIME,JTIME
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.29)WRITE(IU,'(A)') '-1'
IF(ITOPIC.EQ.30)WRITE(IU,'(A)') '-1,-1,0,0'
ENDIF
!## process next timestep
CYCLE
ENDIF
!## default isg
IF(ITOPIC.EQ.29)THEN
EXFNAME=TRIM(DIR)//'\'//CPCK//'7\'//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//'7\'//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 (29)
IF(.NOT.ISG2GRID(GRIDISG%POSTFIX,BND(1)%NROW,BND(1)%NCOL,PRJNLAY,ILAY,TOP,BOT,KHV,BND,VCW,IBATCH,NP,JU,GRIDISG,SFT,LSFT,JSYS))EXIT
!## open sfr file
CASE (30)
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.29)THEN
LINE=TRIM(ITOS(NP(1))); WRITE(IU,'(A)') TRIM(LINE)
NP(2)=MAXVAL(NP)
IF(NP(1).GT.0)THEN
SFNAME=EXFNAME; DO I=1,3; 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)
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.29)THEN
CALL UTL_MF2005_MAXNO(TRIM(DIRMNAME)//'.'//CPCK//'7_',(/NP(2)/))
ELSE
CALL UTL_MF2005_MAXNO(TRIM(DIRMNAME)//'.'//CPCK//'7_',NP)
ENDIF
PMANAGER_SAVEMF2005_ISG=.TRUE.
ENDIF
END FUNCTION PMANAGER_SAVEMF2005_ISG
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_PCK(DIR,DIRMNAME,IBATCH,LEX,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
LOGICAL,INTENT(IN) :: LEX
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
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(.NOT.LEX)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'
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 (18); NUZGAG=0; IRUNFLG=0; NUZTOP=1
! WRITE(IU,'(A)') 'SPECIFYTHTR'
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 (22)
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 (23)
LINE='NaN1#,'//TRIM(ITOS(ICB))//' AUX RFCT AUX ISUB RFACT RFCT RSUBSYS ISUB NOPRINT'
IF(PBMAN%IFORMAT.EQ.2)WRITE(IU,'(A)') TRIM(LINE)
!## IFVDL SFT RCNC
!## evt
CASE (24); 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 (25)
LINE='NaN1#,'//TRIM(ITOS(ICB))//' NOPRINT'
IF(PBMAN%IFORMAT.EQ.2)WRITE(IU,'(A)') TRIM(LINE)
!## rch
CASE (26); 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 (27)
CPCK='OLF'; IF(.NOT.LDRN)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 (28)
LINE='NaN1# NOPRINT NEGBND'
IF(PBMAN%IFORMAT.EQ.2)WRITE(IU,'(A)') TRIM(LINE)
!## fhb package
CASE(31)
!## 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
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 (18)
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 (24)
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 (26)
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,rch,chd,olf
CASE (21,22,23,25,27,28,29)
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 (31)
CASE DEFAULT
WRITE(*,*) 'Cannot come here: ERROR PMANAGER_SAVEMF2005_PCK'; PAUSE
END SELECT
!## goto next timestep
CYCLE
ENDIF
! DATA CMOD/'CAP','TOP','BOT','BND','SHD','KDW','KHV','KVA','VCW','KVV', & ! 1-10
! 'STO','SPY','PWT','ANI','HFB','IBS','SFT','UZF','MNW','PST', & !11-20
! 'WEL','DRN','RIV','EVT','GHB','RCH','OLF','CHD','ISG','SFR', & !21-30
! 'FHB','LAK','PCG'/ !31-40
! !## open external file (not for rch/evt)
! JU=0
! SELECT CASE (ITOPIC)
! CASE (22:23,25,27:29)
! !## create subfolders
! CALL UTL_CREATEDIR(TRIM(DIR)//'\'//CPCK//'7')
! EXFNAME=TRIM(DIR)//'\'//CPCK//'7\'//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
! END SELECT
!## allocate memory for packages
NTOP=SIZE(TOPICS(ITOPIC)%STRESS(KPER)%FILES,1); NSYS=SIZE(TOPICS(ITOPIC)%STRESS(KPER)%FILES,2)
!## used for writing and including the tlp-vector
IF(ALLOCATED(XTMP))DEALLOCATE(XTMP); ALLOCATE(XTMP(NTOP)); XTMP=0.0D0
SELECT CASE (ITOPIC)
CASE (24,26)
IF(NSYS.GT.1)THEN
CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'You cannot apply more than a single layer to the package '// &
TRIM(TOPICS(ITOPIC)%TNAME)//'.','Information')
RETURN
ENDIF
END SELECT
SELECT CASE (ITOPIC)
CASE(27,28); 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 (22,23,25,27,28)
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.EQ.2)THEN
JU=0
SELECT CASE (ITOPIC)
CASE (22:23,25,27:29)
!## create subfolders
CALL UTL_CREATEDIR(TRIM(DIR)//'\'//CPCK//'7')
EXFNAME=TRIM(DIR)//'\'//CPCK//'7\'//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
END SELECT
ELSE
JU=IU
ENDIF
IF(PBMAN%IFORMAT.EQ.3)WRITE(IU,'(/A)') 'BEGIN PERIOD '//TRIM(ITOS(IPER))
!## 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.24.OR.ITOPIC.EQ.26)THEN
IF(ILAY.EQ.0)THEN
CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'You cannot apply a layer code of zero for RCH or EVT','Error')
RETURN
ENDIF
ENDIF
!## check to see whether equal to previous timestep
IEQUAL=1
SELECT CASE (ITOPIC)
!## uzf,rch,evt
CASE (18,24,26)
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 (18)
SELECT CASE (KTOP)
CASE (1); SCL_D=0; SCL_U=7 !## most frequent
CASE (2:4); SCL_D=0; SCL_U=2 !## avg
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 (24)
SCL_D=1; SCL_U=2
!## check to see whether equal to previous timestep
SELECT CASE (KTOP)
CASE (1); INSURF=IEQUAL
CASE (2); INEVTR=IEQUAL
CASE (3); INEXDP=IEQUAL
END SELECT
!## rch
CASE (26)
SCL_D=1; SCL_U=2 !## average
!## equal from previous timestep
INRECH=IEQUAL
!## drn,riv,ghb
CASE (22,23,25) !## drn,riv,ghb
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 (27,28)
SCL_D=1; SCL_U=2
!## fhb
CASE (31)
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
STOP 'Cannot come here: ERROR PMANAGER_SAVEMF2005_PCK'
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 (18)
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 (24)
IF(KTOP.EQ.1)FCT=FCT*0.001D0
IF(ILAY.LT.0)NEVTOP=3
!## checking for inactive cells
ICHECK=1; IF(ILAY.GT.0)ICHECK=0
!## rch
CASE (26)
IF(KTOP.EQ.1)FCT=FCT*0.001D0
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 (18)
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)
!## 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
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 (26)
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
!## skip inactive cells
IF(PCK(1)%ILAY.GT.0.AND.PBMAN%ILAY(PCK(1)%ILAY).EQ.1)THEN
IF(BND(PCK(1)%ILAY)%X(ICOL,IROW).EQ.0.0D0)CYCLE
ENDIF
!## find uppermost layer
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
DO ILAY=1,SIZE(PBMAN%ILAY)
IF(PBMAN%ILAY(ILAY).EQ.0)CYCLE
!## not put into model layer
IF(TLP(ILAY).LE.0.0D0)CYCLE
WRITE(JU,'(3I10,G15.7)') ILAY,IROW,ICOL,PCK(1)%X(ICOL,IROW)
NP_IPER(IPER)=NP_IPER(IPER)+1
ENDDO
ENDDO; ENDDO
ENDIF
!## evt
CASE (24)
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 cells
IF(PCK(1)%ILAY.GT.0)THEN
IF(BND(PCK(1)%ILAY)%X(ICOL,IROW).EQ.0.0D0)CYCLE
ENDIF
IF(ITOPIC.EQ.31)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.23)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,BND,TOP,BOT,KDW,TP,BT,KH,.FALSE.)
SELECT CASE (ITOPIC)
CASE (22) !## drn - drainagelevel
Z1=PCK(2)%X(ICOL,IROW); Z2=Z1
CASE (23) !## riv - waterlevel and bottom
Z1=PCK(2)%X(ICOL,IROW); Z2=PCK(3)%X(ICOL,IROW)
CASE (27) !## olf drainagelevel
Z1=PCK(1)%X(ICOL,IROW); Z2=Z1
CASE (25) !## ghb drainagelevel
Z1=PCK(2)%X(ICOL,IROW); Z2=Z1
CASE DEFAULT
WRITE(*,*) 'Cannot come here: ERROR PMANAGER_SAVEMF2005_PCK'; PAUSE
END SELECT
!## get fraction per model layer
CALL UTL_PCK_GETTLP(PRJNLAY,TLP,KH,TP,BT,Z1,Z2,MINKHT)
!## find uppermost layer
ELSEIF(PCK(1)%ILAY.EQ.-1)THEN
DO ILAY=1,PRJNLAY; IF(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
DO ILAY=1,PRJNLAY
!## not put into model layer
IF(TLP(ILAY).LE.0.0D0)CYCLE
!## write specific packages
SELECT CASE (ITOPIC)
!## chd
CASE (28)
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) ILAY,IROW,ICOL,PCK(JTOP(1))%X(ICOL,IROW),PCK(JTOP(1))%X(ICOL,IROW),ISYS
ELSE
WRITE(JU,FRM) ILAY,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 (27)
OLFCOND=(IDFGETAREA(PCK(JTOP(1)),ICOL,IROW)/COLF) !## drainage conductance
IF(PBMAN%SSYSTEM.EQ.0)THEN
WRITE(JU,FRM) ILAY,IROW,ICOL,PCK(JTOP(1))%X(ICOL,IROW),OLFCOND,ISYS
ELSE
WRITE(JU,FRM) ILAY,IROW,ICOL,PCK(JTOP(1))%X(ICOL,IROW),OLFCOND,1
ENDIF
NP_IPER(IPER)=NP_IPER(IPER)+1
!## fhb
CASE (31)
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)
IF(PBMAN%ILAY(ILAY).EQ.1)THEN
JSYS=1; IF(PBMAN%SSYSTEM.EQ.0)JSYS=ISYS
WRITE(JU,FRM) ILAY,IROW,ICOL,(XTMP(JTOP(I)),I=1,NTOP),JSYS
NP_IPER(IPER)=NP_IPER(IPER)+1
ENDIF
ENDIF
END SELECT
ENDDO
ENDDO; ENDDO
END SELECT
ENDDO
IF(PBMAN%IFORMAT.EQ.3)WRITE(IU,'(A)') 'END PERIOD '
IF(ITOPIC.NE.31.AND. &
ITOPIC.NE.18.AND. &
ITOPIC.NE.24.AND. &
ITOPIC.NE.26)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 (22,23,25,27,28)
CALL IDFWRITEFREE_HEADER(JU,PRJIDF)
END SELECT
ENDIF
CLOSE(JU)
IF(PBMAN%IFORMAT.EQ.2)THEN
IF(NP_IPER(IPER).GT.0)THEN
SFNAME=EXFNAME; DO I=1,3; 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
!## store previous stress-period information for this timestep
LPER=KPER
ENDDO
!## write fhb package
IF(ITOPIC.EQ.31)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 (18); NP_IPER(0)=NUZTOP
CASE (24); NP_IPER(0)=NEVTOP
CASE (26)
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.24.OR.ITOPIC.EQ.26)THEN
IF(LLAK.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.LLAK)RETURN
PMANAGER_SAVEMF2005_LAK_READ=.FALSE.
!## lak settings - use most frequent
ITOPIC=32
!## 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.LLAK)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.LSFT)RETURN
PMANAGER_SAVEMF2005_SFT_READ=.FALSE.
!## sft settings
ITOPIC=17; 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
PMANAGER_SAVEMF2005_MET=.TRUE.; IF(PBMAN%IFORMAT.EQ.3)RETURN
PMANAGER_SAVEMF2005_MET=.FALSE.
!## construct pcg-file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.MET7',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); 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='IDATE_SAVE '//TRIM(ITOS(PBMAN%ISAVEENDDATE))
WRITE(IU,'(A)') TRIM(LINE)
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
LINE='RESULTDIR "'//TRIM(DIR(:INDEX(DIR,'\',.TRUE.)-1))//'"'; WRITE(IU,'(A)') TRIM(LINE)
LINE='SAVEDOUBLE '//TRIM(ITOS(PBMAN%IDOUBLE)); WRITE(IU,'(A)') TRIM(LINE)
CLOSE(IU)
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
PMANAGER_SAVEMF2005_HFB=.TRUE.
IF(.NOT.LHFB)RETURN
PMANAGER_SAVEMF2005_HFB=.FALSE.
IF(IBATCH.EQ.0)CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIRMNAME)//'.HFB7'//'...')
IF(IBATCH.EQ.1)WRITE(*,'(/1X,A)') 'Writing '//TRIM(DIRMNAME)//'.HFB7'//'...'
!## creating and collect all faults
JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=TRIM(DIRMNAME)//'_HFB.TXT',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED')
ITOPIC=15; 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)//'.HFB7_',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# HFB7 File Generated by '//TRIM(UTL_IMODVERSION())
!## 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(LTB)THEN
WRITE(IU,'(2I10,A)') NPHFB,MXFB,',NaN1# NOPRINT HFBRESIS SYSTEM'
ELSE
WRITE(IU,'(2I10,A)') NPHFB,MXFB,',NaN1# NOPRINT HFBFACT SYSTEM'
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),A10)') 'NO','CONF_RESIS','UNCONF_RESIS','FRACTION','SYSTEM'
ELSE
WRITE(IUDAT(ILAY),'(A10,1X,A15,A10)') 'NO','FRACTION','SYSTEM'
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)
!## close hfb file
CLOSE(IU); CLOSE(JU,STATUS='DELETE')
CALL UTL_MF2005_MAXNO(TRIM(DIRMNAME)//'.HFB7_',(/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,ILAY,IPER
PMANAGER_SAVEMF2005_OCD=.FALSE.
IF(PBMAN%IFORMAT.EQ.2)THEN
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())
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'
WRITE(IU,'(1X,A)') 'BUDGET FILEOUT .\GWF_'//TRIM(ITOS(PBMAN%ISUBMODEL))//'\MODELOUTPUT\BUDGET\BUDGET.CBC'
WRITE(IU,'(1X,A)') 'HEAD FILEOUT .\GWF_'//TRIM(ITOS(PBMAN%ISUBMODEL))//'\MODELOUTPUT\HEAD\HEAD.HED'
CALL UTL_CREATEDIR(TRIM(MAINDIR)//'\GWF_'//TRIM(ITOS(PBMAN%ISUBMODEL))//'\MODELOUTPUT\BUDGET')
CALL UTL_CREATEDIR(TRIM(MAINDIR)//'\GWF_'//TRIM(ITOS(PBMAN%ISUBMODEL))//'\MODELOUTPUT\HEAD')
! WRITE(IU,'(A)') ' HEAD PRINT_FORMAT COLUMNS WIDTH DIGITS ]'
WRITE(IU,'(A)') 'END OPTIONS'
ENDIF
LINE='HEAD SAVE UNIT '//TRIM(ITOS(IHEDUN)); WRITE(IU,'(A)') TRIM(LINE)
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)
LINE='PRINT BUDGET'; WRITE(IU,'(A)') TRIM(LINE)
IF(ASSOCIATED(PBMAN%SAVESHD))THEN
IF(PBMAN%SAVESHD(1).EQ.-1)THEN
LINE='SAVE HEAD'; DO ILAY=1,PRJNLAY; LINE=TRIM(LINE)//' '//TRIM(ITOS(ILAY)); ENDDO; WRITE(IU,'(A)') TRIM(LINE)
ELSE
LINE='SAVE HEAD'; DO ILAY=1,SIZE(PBMAN%SAVESHD); LINE=TRIM(LINE)//' '//TRIM(ITOS(PBMAN%SAVESHD(ILAY))); ENDDO; WRITE(IU,'(A)') TRIM(LINE)
ENDIF
ENDIF
CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%SAVEFLX,IBCFCB,IU)
CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%SAVEUZF,IUZFCB1,IU)
CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%SAVESFR,ISFRCB,IU)
CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%SAVEFHB,IFHBCB,IU)
CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%SAVEDRN,IDRNCB,IU)
CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%SAVERIV,IRIVCB,IU)
CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%SAVEGHB,IGHBCB,IU)
CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%SAVEWEL,IWELCB,IU)
CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%SAVERCH,IRCHCB,IU)
CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%SAVEEVT,IEVTCB,IU)
CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%SAVEMNW,IWL2CB,IU)
CALL PMANAGER_SAVEMF2005_OCD_ISAVE(PBMAN%SAVELAK,ILAKCB,IU)
ELSE
WRITE(IU,'(/A/)') '#Stressperiod Save Options'
WRITE(IU,'(A)') 'BEGIN PERIOD '//TRIM(ITOS(IPER))
WRITE(IU,'(A)') ' SAVE HEAD ALL'
WRITE(IU,'(A)') ' SAVE BUDGET ALL'
WRITE(IU,'(A)') 'END PERIOD'
ENDIF
ENDDO
CLOSE(IU)
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.LPCG)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 MODERATE' !## simple complex
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
LINE=TRIM(ITOS(PCG%NOUTER)) //','// &
TRIM(ITOS(PCG%NINNER)) //','// &
TRIM(RTOS(PCG%HCLOSE,'G',5)) //','// &
TRIM(RTOS(PCG%RCLOSE,'G',5)) //','// &
TRIM(RTOS(PCG%RELAX ,'G',5)) //','// &
TRIM(ITOS(PCG%NPCOND)) //','// &
TRIM(ITOS(PCG%IPRPCG)) //','// &
TRIM(ITOS(PCG%MUTPCG)) //','// &
TRIM(RTOS(PCG%DAMPPCG ,'G',5)) //','// &
TRIM(RTOS(PCG%DAMPPCGT ,'G',5))//','// &
TRIM(ITOS(PCG%IQERROR)) //','// &
TRIM(RTOS(PCG%QERROR,'G',5))
WRITE(IU,'(A)') TRIM(LINE)
!## run file
ELSEIF(IOPTION.EQ.1)THEN
! LINE=TRIM(ITOS(PCG%NOUTER)) //','// &
! TRIM(ITOS(PCG%NINNER)) //','// &
! TRIM(ITOS(PCG%NPCOND))
! WRITE(IU,'(A)') TRIM(LINE)
!## 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_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
!## Parallel Krylov Solver Package
!isolver 1
!npc 2
!hclosepks 9.9999997E-05
!rclosepks 100.000
!mxiter 500
!innerit 30
!relax 0.9800000
!end
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_SIP(DIRMNAME)
! !####====================================================================
! IMPLICIT NONE
! CHARACTER(LEN=*),INTENT(IN) :: DIRMNAME
! INTEGER :: IU
!
! PMANAGER_SAVEMF2005_SIP=.TRUE.
!
! IF(.NOT.LSIP)RETURN
!
! PMANAGER_SAVEMF2005_SIP=.FALSE.
!
! !## construct sip-file
! IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.SIP',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
! WRITE(IU,'(A)') '# SIP File Generated by '//TRIM(UTL_IMODVERSION())
! LINE=TRIM(ITOS(SIP%NOUTER))//',5'; WRITE(IU,'(A)') TRIM(LINE)
! LINE=TRIM(RTOS(SIP%RELAX,'E',7))//','//TRIM(RTOS(SIP%HCLOSE,'E',7))//',1,0.0D0,1'; WRITE(IU,'(A)') TRIM(LINE)
!
! CLOSE(IU)
!
! PMANAGER_SAVEMF2005_SIP=.TRUE.
!
! END FUNCTION PMANAGER_SAVEMF2005_SIP
! !####====================================================================
! LOGICAL FUNCTION PMANAGER_SAVEMF2005_PCGN(DIRMNAME)
! !####====================================================================
! IMPLICIT NONE
! CHARACTER(LEN=*),INTENT(IN) :: DIRMNAME
! INTEGER :: IU
!
! PMANAGER_SAVEMF2005_PCGN=.TRUE.
!
! IF(.NOT.LPCGN)RETURN
!
! PMANAGER_SAVEMF2005_PCGN=.FALSE.
!
! !## construct pcgn-file
! IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.PCGN',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
!! LINE=TRIM(ITOS(MXITER))//','//TRIM(ITOS(ITER1))//','//TRIM(RTOS(RCLOSE,'E',7))//','//TRIM(RTOS(HCLOSE,'E',7))
!! WRITE(IU,'(A)') TRIM(LINE)
!! LINE=TRIM(RTOS(RELAX,'E',7))//',1,0,0'; WRITE(IU,'(A)') TRIM(LINE)
!! LINE='0,1.0D0,0.0D0,0.5,1.0D0'; WRITE(IU,'(A)') TRIM(LINE)
!! LINE='0,0.0D0,0,0.0D0,0'; WRITE(IU,'(A)') TRIM(LINE)
!
! CLOSE(IU)
!
! PMANAGER_SAVEMF2005_PCGN=.TRUE.
!
! END FUNCTION PMANAGER_SAVEMF2005_PCGN
!
!####====================================================================
SUBROUTINE PMANAGER_SAVEMF2005_DEALLOCATE()
!####====================================================================
IMPLICIT NONE
IF(ALLOCATED(NP_IPER))DEALLOCATE(NP_IPER)
CALL IDFDEALLOCATEX(PRJIDF)
IF(ALLOCATED(BND))THEN
CALL IDFDEALLOCATE(BND,SIZE(BND)); DEALLOCATE(BND)
ENDIF
IF(ALLOCATED(SHD))THEN
CALL IDFDEALLOCATE(SHD,SIZE(SHD)); DEALLOCATE(SHD)
ENDIF
IF(ALLOCATED(KDW))THEN
CALL IDFDEALLOCATE(KDW,SIZE(KDW)); DEALLOCATE(KDW)
ENDIF
IF(ALLOCATED(VCW))THEN
CALL IDFDEALLOCATE(VCW,SIZE(VCW)); DEALLOCATE(VCW)
ENDIF
IF(ALLOCATED(TOP))THEN
CALL IDFDEALLOCATE(TOP,SIZE(TOP)); DEALLOCATE(TOP)
ENDIF
IF(ALLOCATED(BOT))THEN
CALL IDFDEALLOCATE(BOT,SIZE(BOT)); DEALLOCATE(BOT)
ENDIF
IF(ALLOCATED(ANA))THEN
CALL IDFDEALLOCATE(ANA,SIZE(ANA)); DEALLOCATE(ANA)
ENDIF
IF(ALLOCATED(ANF))THEN
CALL IDFDEALLOCATE(ANF,SIZE(ANF)); DEALLOCATE(ANF)
ENDIF
IF(ALLOCATED(KHV))THEN
CALL IDFDEALLOCATE(KHV,SIZE(KHV)); DEALLOCATE(KHV)
ENDIF
IF(ALLOCATED(KVV))THEN
CALL IDFDEALLOCATE(KVV,SIZE(KVV)); DEALLOCATE(KVV)
ENDIF
IF(ALLOCATED(KVA))THEN
CALL IDFDEALLOCATE(KVA,SIZE(KVA)); DEALLOCATE(KVA)
ENDIF
IF(ALLOCATED(STO))THEN
CALL IDFDEALLOCATE(STO,SIZE(STO)); DEALLOCATE(STO)
ENDIF
IF(ALLOCATED(SPY))THEN
CALL IDFDEALLOCATE(SPY,SIZE(SPY)); DEALLOCATE(SPY)
ENDIF
IF(ALLOCATED(LAK))THEN
CALL IDFDEALLOCATE(LAK,SIZE(LAK)); DEALLOCATE(LAK)
ENDIF
IF(ALLOCATED(LBD))THEN
CALL IDFDEALLOCATE(LBD,SIZE(LBD)); DEALLOCATE(LBD)
ENDIF
IF(ALLOCATED(LCD))THEN
CALL IDFDEALLOCATE(LCD,SIZE(LCD)); DEALLOCATE(LCD)
ENDIF
IF(ALLOCATED(SFT))THEN
CALL IDFDEALLOCATE(SFT,SIZE(SFT)); DEALLOCATE(SFT)
ENDIF
IF(ALLOCATED(ULAKES)) DEALLOCATE(ULAKES)
IF(ALLOCATED(FHBHED)) DEALLOCATE(FHBHED)
IF(ALLOCATED(FHBFLW)) DEALLOCATE(FHBFLW)
IF(ALLOCATED(FHBNBDTIM))DEALLOCATE(FHBNBDTIM)
IF(ASSOCIATED(FNAMES)) DEALLOCATE(FNAMES)
IF(ALLOCATED(PRJILIST)) DEALLOCATE(PRJILIST)
IF(ASSOCIATED(PBMAN%SAVESHD))DEALLOCATE(PBMAN%SAVESHD)
IF(ASSOCIATED(PBMAN%SAVEFLX))DEALLOCATE(PBMAN%SAVEFLX)
IF(ASSOCIATED(PBMAN%SAVEUZF))DEALLOCATE(PBMAN%SAVEUZF)
IF(ASSOCIATED(PBMAN%SAVELAK))DEALLOCATE(PBMAN%SAVELAK)
IF(ASSOCIATED(PBMAN%SAVESFR))DEALLOCATE(PBMAN%SAVESFR)
IF(ASSOCIATED(PBMAN%SAVEWEL))DEALLOCATE(PBMAN%SAVEWEL)
IF(ASSOCIATED(PBMAN%SAVEDRN))DEALLOCATE(PBMAN%SAVEDRN)
IF(ASSOCIATED(PBMAN%SAVERIV))DEALLOCATE(PBMAN%SAVERIV)
IF(ASSOCIATED(PBMAN%SAVEGHB))DEALLOCATE(PBMAN%SAVEGHB)
IF(ASSOCIATED(PBMAN%SAVERCH))DEALLOCATE(PBMAN%SAVERCH)
IF(ASSOCIATED(PBMAN%SAVEEVT))DEALLOCATE(PBMAN%SAVEEVT)
IF(ASSOCIATED(PBMAN%SAVEMNW))DEALLOCATE(PBMAN%SAVEMNW)
IF(ASSOCIATED(PBMAN%SAVEFHB))DEALLOCATE(PBMAN%SAVEFHB)
IF(ASSOCIATED(PBMAN%UNCONFINED))DEALLOCATE(PBMAN%UNCONFINED)
IF(ASSOCIATED(PBMAN%ILAY))DEALLOCATE(PBMAN%ILAY)
END SUBROUTINE PMANAGER_SAVEMF2005_DEALLOCATE
!####====================================================================
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.LMSP)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(1)%IACT_MODEL.EQ.1)THEN
IF(ASSOCIATED(TOPICS(1)%STRESS))THEN
FFNAME=TOPICS(1)%STRESS(1)%FILES(8,1)%FNAME
IF(INDEX(UTL_CAP(FFNAME,'U'),'IPF').GT.0)IARMWP=1
ENDIF
ENDIF
ISYS=0; ILAY=1; ITOPIC=1; 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.LPWT)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,LPWT,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,MDND2,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
IF (ALLOCATED(DXCID)) DEALLOCATE(DXCID)
ALLOCATE(DXCID(PRJIDF%NCOL,PRJIDF%NROW,PRJNLAY))
DXCID = 0
NDXC = 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
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
MDND2= (JROW-1)*PRJIDF%NCOL+JCOL
MDND2=MDND2+(LYBE-1)*PRJIDF%NCOL*PRJIDF%NROW
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)WRITE(ISCAP,'(I10,F8.2,24X,I10,I6)') NUND,QBER,NUND,LYBE
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
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)') NUND,IROW-IR1+1,ICOL-IC1+1
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)
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
END IF
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
CHARACTER(LEN=256) :: STR
CHARACTER(LEN=256), DIMENSION(4) :: STRARR
INTEGER :: J, LUNCB, ICOL, IROW, ILAY, ID
! NAM%DATA(IDXCFLUX)%FNAME = 'BDGCAP'
! NAM%DATA(IDXCFLUX)%CBNLAY = DXC%CBNLAY
! NAM%DATA(IDXCFLUX)%CBLAY = DXC%CBLAY
! IF (DXC%CBNLAY.GT.0) THEN
! NAM%DATA(IDXCFLUX)%ACTIVE = .TRUE.
! LUNCB = NAM%DATA(IDXCFLUX)%NUNIT
! ELSE
LUNCB = 0
! END IF
WRITE(STRARR(1),*) NDXC
WRITE(STRARR(2),*) LUNCB
WRITE(STR,'(2(A,1X))') (TRIM(ADJUSTL(STRARR(J))),J=1,2)
WRITE(IDXC,'(A)') TRIM(STR)
WRITE(IDXC,'(A)') TRIM(ADJUSTL(STRARR(1)))
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(STRARR(1),*) -ILAY
WRITE(IDXC,*) -ILAY,IROW,ICOL,ABS(DXCID(ICOL,IROW,ILAY))
ELSE
! WRITE(STRARR(1),*) ILAY
WRITE(IDXC,*) ILAY,IROW,ICOL,ABS(DXCID(ICOL,IROW,ILAY))
END IF
! WRITE(STRARR(2),*) IROW
! WRITE(STRARR(3),*) ICOL
! WRITE(STRARR(4),*) ABS(DXCID(ICOL,IROW,ILAY))
! WRITE(STR,'(4(A,1X))') (TRIM(ADJUSTL(STRARR(J))),J=1,4)
! WRITE(IDXC,'(A)') TRIM(STR)
END IF
END DO
END DO
END DO
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
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(LPWT)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(3) :: 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,BND,TOP,BOT,KD,TP,BT,KH,LKHV)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: PRJNLAY,ICOL,IROW
TYPE(IDFOBJ),INTENT(IN),DIMENSION(PRJNLAY) :: BND,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
!## do not put any in constant or inactive cells
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.5
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
REAL(KIND=DP_KIND) :: C,C1,C2,Z,ZZ,TPV,BTV,TFV,BFV
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
DO ILAY=1,PRJNLAY
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), c=resistance
READ(JU,'(5I10,2G15.7,I10,4G15.7)',IOSTAT=IOS) JLAY,IR1,IC1,IR2,IC2,C,Z,ISYS,TPV,BTV,TFV,BFV
IF(IOS.NE.0)EXIT
IF(JLAY.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),TFV)
!## minimum bot fault for display
BF(IC1,IR1)=MIN(BF(IC1,IR1),BFV)
!## dit klopt niet ... de vulling van een breuk gaan niet op de cell niveau maar op vlak-niveau :-(
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
!## 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)
!## add fault
NHFBNP(ILAY)=NHFBNP(ILAY)+1
WRITE(IU,'(5(I10,1X),G15.7,1X,I10)') ILAY,IROW,ICOL,IROW,ICOL+1,C2,ISYS !## y-direction
!## 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)
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
!## 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)
!## add fault
NHFBNP(ILAY)=NHFBNP(ILAY)+1
WRITE(IU,'(5(I10,1X),G15.7,1X,I10)') ILAY,IROW,ICOL,IROW+1,ICOL,C2,ISYS !## x-direction
!## 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)
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.0
ELSEIF(TF(IC1,IR1).NE.NODATA)THEN
TFV=TF(IC1,IR1)
ELSE
TFV=TF(IC2,IR2)
ENDIF
IF(BF(IC1,IR1).NE.NODATA.AND.BF(IC2,IR2).NE.NODATA)THEN
BFV=(BF(IC1,IR1)+BF(IC2,IR2))/2.0
ELSEIF(BF(IC1,IR1).NE.NODATA)THEN
BFV=BF(IC1,IR1)
ELSE
BFV=BF(IC2,IR2)
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
TPV=(TOP(ILAY)%X(IC1,IR1)+TOP(ILAY)%X(IC2,IR2))/2.0D0
BTV=(BOT(ILAY)%X(IC1,IR1)+BOT(ILAY)%X(IC2,IR2))/2.0D0
!## 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)
!###====================================================================
IMPLICIT NONE
TYPE(IDFOBJ),INTENT(INOUT) :: IDF
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
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
IF(LTB)THEN
IF(TFV.GE.BFV)WRITE(JU,'(I10,3(1X,E15.7),I10)') N,C,RES,FDZ,ISYS
ELSE
WRITE(JU,'(I10,1X ,E15.7 ,I10)') N,C,ISYS
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(G15.7,A1))') IDF%SX(ICOL),',',IDF%SY(IROW-1),',',T1
WRITE(IU,'(3(G15.7,A1))') IDF%SX(ICOL),',',IDF%SY(IROW) ,',',T1
WRITE(IU,'(3(G15.7,A1))') IDF%SX(ICOL),',',IDF%SY(IROW) ,',',B1
WRITE(IU,'(3(G15.7,A1))') IDF%SX(ICOL),',',IDF%SY(IROW-1),',',B1
WRITE(IU,'(3(G15.7,A1))') IDF%SX(ICOL),',',IDF%SY(IROW-1),',',T1
WRITE(IU,'(A)') 'END'
ENDIF
ELSE
WRITE(IU,'(I10)') N
WRITE(IU,'(2(G15.7,A1))') IDF%SX(ICOL),',',IDF%SY(IROW-1)
WRITE(IU,'(2(G15.7,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
IF(LTB)THEN
IF(TFV.GE.BFV)WRITE(JU,'(I10,3(1X,E15.7),I10)') N,C,RES,FDZ,ISYS
ELSE
WRITE(JU,'(I10,1X ,E15.7 ,I10)') N,C,ISYS
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(G15.7,A1))') IDF%SX(ICOL-1),',',IDF%SY(IROW),',',T1
WRITE(IU,'(3(G15.7,A1))') IDF%SX(ICOL ),',',IDF%SY(IROW),',',T1
WRITE(IU,'(3(G15.7,A1))') IDF%SX(ICOL ),',',IDF%SY(IROW),',',B1
WRITE(IU,'(3(G15.7,A1))') IDF%SX(ICOL-1),',',IDF%SY(IROW),',',B1
WRITE(IU,'(3(G15.7,A1))') IDF%SX(ICOL-1),',',IDF%SY(IROW),',',T1
WRITE(IU,'(A)') 'END'
ENDIF
ELSE
WRITE(IU,'(I10)') N
WRITE(IU,'(2(G15.7,A1))') IDF%SX(ICOL-1),',',IDF%SY(IROW)
WRITE(IU,'(2(G15.7,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_MOD_READ(IDF,ITOPIC,IFILE,SCL_D,SCL_U,IINV,IPRT)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ITOPIC,IFILE,SCL_D,SCL_U,IINV,IPRT
CHARACTER(LEN=256) :: FNAME
TYPE(IDFOBJ),INTENT(INOUT) :: IDF
INTEGER :: ICNST,ILAY
REAL(KIND=DP_KIND) :: FCT,IMP,CNST
PMANAGER_SAVEMF2005_MOD_READ=.TRUE.
FCT =FNAMES(IFILE)%FCT
IMP =FNAMES(IFILE)%IMP
ILAY =FNAMES(IFILE)%ILAY
ICNST=FNAMES(IFILE)%ICNST
CNST =FNAMES(IFILE)%CNST
FNAME=FNAMES(IFILE)%FNAME
IF(IPRT.GT.0)THEN
WRITE(IPRT,'(1X,A,I3,A1,I1,A1,I4.3,3(A1,G15.7),A1,A)') TOPICS(ITOPIC)%TNAME(1:5)//',', &
IFILE,',',ICNST,',',ILAY,',',FCT,',',IMP,',',CNST,',',CHAR(39)//TRIM(FNAME)//CHAR(39)
ENDIF
IF(ICNST.EQ.1)THEN
IDF%X=CNST
ELSEIF(ICNST.EQ.2.OR.ICNST.EQ.3)THEN
IDF%FNAME=FNAME
!## read/clip/scale idf file
PMANAGER_SAVEMF2005_MOD_READ=IDFREADSCALE(IDF%FNAME,IDF,SCL_U,SCL_D,1.0D0,0)
ENDIF
!## apply factors if no errors occured
IF(PMANAGER_SAVEMF2005_MOD_READ)CALL PMANAGER_SAVEMF2005_FCTIMP(IINV,ICNST,IDF,FCT,IMP,SCL_U)
END FUNCTION PMANAGER_SAVEMF2005_MOD_READ
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_MOD_U2DREL(EXFNAME,IDF,IINT,IU,ILAY,IFBND)
!###======================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: EXFNAME
TYPE(IDFOBJ),INTENT(INOUT) :: IDF
CHARACTER(LEN=256) :: SFNAME
INTEGER,INTENT(IN) :: IINT,IU,ILAY,IFBND
INTEGER :: JU,IROW,ICOL,I,N
REAL(KIND=DP_KIND) :: MINV,MAXV
PMANAGER_SAVEMF2005_MOD_U2DREL=.FALSE.
!## correct for boundary conditions
IF(.NOT.PMANAGER_SAVEMF2005_PCK_GETMINMAX(IDF%X,IDF%NCOL,IDF%NROW,BND(ILAY)%X,MINV,MAXV,IFBND))RETURN
!## constant value
IF(MAXV.EQ.MINV)THEN
IF(IINT.EQ.0)THEN
IF(MAXV.EQ.IDF%NODATA)THEN
LINE='CONSTANT '//TRIM(RTOS(HNOFLOW,'E',7))
ELSE
LINE='CONSTANT '//TRIM(RTOS(MAXV,'E',7))
ENDIF
ELSEIF(IINT.EQ.1)THEN
IF(MAXV.EQ.IDF%NODATA)THEN
LINE='CONSTANT '//TRIM(ITOS(0))
ELSE
LINE='CONSTANT '//TRIM(ITOS(INT(MAXV)))
ENDIF
ENDIF
IF(PBMAN%IFORMAT.EQ.2)WRITE(IU,'(A)') TRIM(LINE)
IF(PBMAN%IFORMAT.EQ.3)WRITE(IU,'(A)') ' '//TRIM(LINE)
ELSE
CALL UTL_CREATEDIR(EXFNAME(:INDEX(EXFNAME,'\',.TRUE.)-1))
IF(PBMAN%IFORMAT.EQ.3)THEN; N=4; ELSE; N=3; ENDIF
SFNAME=EXFNAME; DO I=1,N; SFNAME=SFNAME(:INDEX(SFNAME,'\',.TRUE.)-1); ENDDO
I=LEN_TRIM(SFNAME); SFNAME='.'//EXFNAME(I+1:)
IF(PBMAN%IFORMAT.EQ.2)THEN
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'
ELSE
IF(IINT.EQ.0)WRITE(IU,'(A)') ' OPEN/CLOSE '//TRIM(SFNAME)//' FACTOR 1.0D0 IPRN -1'
IF(IINT.EQ.1)WRITE(IU,'(A)') ' OPEN/CLOSE '//TRIM(SFNAME)//' FACTOR 1 IPRN -1'
ENDIF
IF(TRIM(EXFNAME(INDEX(EXFNAME,'.',.TRUE.)+1:)).EQ.'ASC')THEN
JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=EXFNAME,STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(JU.EQ.0)RETURN
WRITE(JU,'(A14,I10)') 'NCOLS' ,IDF%NCOL
WRITE(JU,'(A14,I10)') 'NROWS' ,IDF%NROW
WRITE(JU,'(A14,G15.7)') 'XLLCORNER' ,IDF%XMIN
WRITE(JU,'(A14,G15.7)') 'YLLCORNER' ,IDF%YMIN
WRITE(JU,'(A14,G15.7)') 'CELLSIZE' ,IDF%DX
WRITE(JU,'(A14,G15.7)') 'NODATA_VALUE ',IDF%NODATA
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
CLOSE(JU)
ELSEIF(TRIM(EXFNAME(INDEX(EXFNAME,'.',.TRUE.)+1:)).EQ.'IDF')THEN
IF(.NOT.IDFWRITE(IDF,EXFNAME,1))RETURN
ELSE
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
ENDIF
PMANAGER_SAVEMF2005_MOD_U2DREL=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_MOD_U2DREL
!###======================================================================
SUBROUTINE PMANAGER_SAVEMF2005_FCTIMP(IINV,ICNST,IDF,FCT,IMP,SCL_U)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IINV,ICNST,SCL_U
REAL(KIND=DP_KIND),INTENT(IN) :: FCT,IMP
TYPE(IDFOBJ),INTENT(INOUT) :: IDF
INTEGER :: IROW,ICOL
!## replace nodata for hnoflow-value
DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL
!## not constant value and equal to nodata - skip it
IF(ICNST.EQ.2.AND.IDF%X(ICOL,IROW).EQ.IDF%NODATA)THEN
!## geometric will otherwise ignore zero as entry which is allowed
IF(SCL_U.EQ.3)THEN
IDF%X(ICOL,IROW)=0.0D0
ELSE
IDF%X(ICOL,IROW)=HNOFLOW
ENDIF
ELSE
IDF%X(ICOL,IROW)=IDF%X(ICOL,IROW)*FCT+IMP
ENDIF
!## translate from resistance into reciprocal conductance
!## translate from vka into reciprocal vka
IF(IINV.EQ.1)THEN
IF(IDF%X(ICOL,IROW).NE.0.0D0.AND.IDF%X(ICOL,IROW).NE.HNOFLOW)IDF%X(ICOL,IROW)=1.0D0/IDF%X(ICOL,IROW)
ENDIF
ENDDO; ENDDO
IDF%NODATA=HNOFLOW
END SUBROUTINE PMANAGER_SAVEMF2005_FCTIMP
!###======================================================================
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.LLAK)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(ILAY)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ILAY
INTEGER :: IROW,ICOL,NN,NE,NS,NW
!## if bound equal to hnoflow, turn inactive, before correcting due to submodel potential
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
ENDDO
ENDDO
NN=0; NW=0; NS=0; NE=0
!## no applicable with submodel via mf6
IF(PBMAN%NSUBMODEL.GT.1.AND.PBMAN%IFORMAT.EQ.3)RETURN
!## replace ibound for boundaries
DO IROW=1,BND(ILAY)%NROW
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(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:'
WRITE(*,'(A)') ' - North Boundary '//TRIM(ITOS(NN))
WRITE(*,'(A)') ' - South Boundary '//TRIM(ITOS(NS))
WRITE(*,'(A)') ' - West Boundary '//TRIM(ITOS(NW))
WRITE(*,'(A/)') ' - East Boundary '//TRIM(ITOS(NE))
ENDIF
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.9.OR.ITOPIC.EQ.10)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)') CMOD(ITOPIC),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.9.OR.ITOPIC.EQ.10)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,A4,3A15 )') 'VAR','LAY','IBOUND','X','NODATAVALUE'
WRITE(*,'(A3,I4,A15,2E15.7)') CMOD(ITOPIC),ILAY,' NoActiveLayer',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 (6:12)
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.31.AND.ITOPIC.NE.28)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