!! Copyright (C) Stichting Deltares, 2005-2017.
!!
!! 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 .
!!
!! Contact: imod.support@deltares.nl
!! Stichting Deltares
!! P.O. Box 177
!! 2600 MH Delft, The Netherlands.
!!
MODULE MOD_PMANAGER
USE WINTERACTER
USE RESOURCE
USE IMODVAR
USE MOD_ISG_PAR, ONLY : GRIDISGOBJ
USE MOD_MDL_PAR, ONLY : REPLACESTRING
USE MOD_UTL, ONLY : UTL_GETUNIT,ITOS,RTOS,UTL_WSELECTFILE,UTL_CAP,UTL_MESSAGEHANDLE,UTL_SUBST,UTL_FILLDATES,NEWLINE,UTL_LISTOFFILES, &
IDATETOGDATE,UTL_IDATETOJDATE,UTL_GDATE,UTL_JDATETOIDATE,JD,UTL_IDFSNAPTOGRID,UTL_CREATEDIR,UTL_GETMED,UTL_CLOSEUNITS,ITIMETOHMS, &
HMSTOITIME,UTL_IDATETOJDATE,UTL_PCK_READTXT,UTL_PCK_GETTLP,ITIMETOGDATE,UTL_IMODVERSION,UTL_DEBUGLEVEL,UTL_GETUNIQUE_INT, &
UTL_DIRINFO_POINTER,UTL_IDFGETLAYERS,UTL_DIRINFO,UTL_FILLDATESDIALOG,UTL_GETCURRENTDATE,UTL_IDFGETDATE,UTL_GETREAL,&
UTL_SYSCOREINFO,UTL_MINTHICKNESS
USE MOD_IDF, ONLY : IDFREAD,IDFDEALLOCATE,IDFNULLIFY,IDFREADSCALE,IDFCOPY,IDFDEALLOCATEX,IDFIROWICOL,IDFALLOCATEX,IDFGETAREA, &
IDFFILLSXSY,IDFWRITE,IDFGETEDGE,IDFGETILAY,UTL_WRITE_FREE,IDFDEALLOCATESX
USE MOD_IDF_PAR, ONLY : IDFOBJ
USE MOD_OSD, ONLY : OSD_OPEN
USE MOD_PMANAGER_PAR
USE MOD_PMANAGER_UTL, ONLY : PMANAGER_SAVEMF2005_ALLOCATEPCK,PMANAGER_SAVEMF2005_DEALLOCATEPCK,PMANAGER_SAVEMF2005_PCK_GETMINMAX,PMANAGER_SAVEMF2005_COARSEGRID
USE MOD_MANAGER, ONLY : MANAGERDELETE
USE MODPLOT, ONLY : MP,MPW
USE IMOD, ONLY : IDFINIT
USE MOD_PREF_PAR, ONLY : PREFVAL
USE DATEVAR
USE MOD_ISG_GRID, ONLY : ISG2GRID,ISG2SFR
USE MOD_ISG_PAR, ONLY : IRDFLG,IPTFLG,ISFR
USE MOD_ISG_UTL, ONLY : ISGDEAL,ISGREAD,ISGCLOSEFILES
USE MOD_POLINT, ONLY : POL1LOCATE
USE MOD_QKSORT
USE MOD_ASC2IDF_HFB, ONLY : ASC2IDF_HFB
USE MOD_ASC2IDF_PAR, ONLY : ASC2IDF_INT_NULLIFY,ASC2IDF_INT_DEALLOCATE,XP,YP,ZP,WP,FP
USE MOD_ABOUT, ONLY : IMOD_AGREEMENT
TYPE SIMGRO_OBJ
INTEGER :: IBOUND !boundary condition
INTEGER :: LGN !landuse
INTEGER :: METEO !meteo-station
INTEGER :: BER_LAAG !artificial recharge layer
INTEGER :: BEREGEN !artificial recharge
INTEGER :: BODEM !soil type
REAL :: BEREGEN_Q !artificial recharge strength
REAL :: NOPP !wetted-surface
REAL :: SOPP !urban-surface
REAL :: RZ !rootzone
REAL :: MV !surface-level
REAL :: PWT_LEVEL !level for PWT (optional)
REAL :: COND !conductivity
REAL :: MOISTURE !moisture
REAL :: VXMU_SOPP !micro-storage capacity, sill of the runoff relationship
REAL :: VXMU_ROPP !micro-storage capacity, sill of the runoff relationship
REAL :: CRUNOFF_SOPP !runoff resistance (days)
REAL :: CRUNOFF_ROPP !runoff resistance (days)
REAL :: CRUNON_SOPP !runon resistance (days)
REAL :: CRUNON_ROPP !runon resistance (days)
REAL :: QINFBASIC_SOPP !infiltratie cap.
REAL :: QINFBASIC_ROPP
END TYPE SIMGRO_OBJ
TYPE(SIMGRO_OBJ),ALLOCATABLE,DIMENSION(:,:) :: SIMGRO
INTEGER,PRIVATE :: INDSB !unit number for svat2swnr_roff.inp
INTEGER,PRIVATE :: IAREA !unit number for area_msw.inp
INTEGER,PRIVATE :: ISELSVAT !unit number for sel_svat_bda.inp
INTEGER,PRIVATE :: ISCAP !unit number for scap_msw.inp
INTEGER,PRIVATE :: IGWMP !unit number for gwmp_msw.inp
INTEGER,PRIVATE :: IMODSIM !unit number for mod-sim.txt
INTEGER,PRIVATE :: IINFI !unit number for infi_svat.inp
INTEGER,PRIVATE :: IIDF !unit number for idf_svat.inp
INTEGER,PRIVATE :: IUSCL
REAL,PARAMETER,PRIVATE :: MSWPMV=10.0 !## add meter to surface level urban area
INTEGER,PRIVATE :: IARMWP
!## usage of true modflow2005
LOGICAL,PRIVATE :: LMODFLOW2005=.FALSE.
LOGICAL,PRIVATE,PARAMETER :: LFREEFORMAT=.TRUE. !## use true free-format
CHARACTER(LEN=1024),PRIVATE :: LINE
CHARACTER(LEN=256),POINTER,DIMENSION(:,:),PRIVATE :: FILES
CHARACTER(LEN=256),DIMENSION(:,:),POINTER,PRIVATE :: FILES_BU
CONTAINS
!###======================================================================
SUBROUTINE PMANAGERMAIN(ITYPE,MESSAGE)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ITYPE
TYPE(WIN_MESSAGE),INTENT(IN) :: MESSAGE
INTEGER :: I
SELECT CASE (ITYPE)
CASE (FIELDCHANGED)
SELECT CASE (MESSAGE%VALUE1)
CASE (ID_TREEVIEW1)
CALL PMANAGERFIELDS()
END SELECT
CASE (PUSHBUTTON)
SELECT CASE (MESSAGE%VALUE1)
CASE (ID_CLEAN)
CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Are you sure to refresh the Project Manager?','Question')
IF(WINFODIALOG(4).EQ.1)THEN
DO I=1,SIZE(TOPICS); CALL PMANAGER_DEALLOCATE(I); ENDDO; CALL PMANAGER_DEALLOCATE_PEST()
CALL PMANAGERUPDATE(0,0,0)
ENDIF
CASE (ID_DRAW)
CALL PMANAGERDRAW()
CASE (ID_DRAW2)
CALL PMANAGERDRAW_PLUS()
CASE (ID_PROPERTIES_AUTO)
CALL PMANAGEROPEN_AUTOMATIC()
CASE (ID_PROPERTIES)
CALL PMANAGEROPEN()
CASE (ID_OPENRUN,ID_SAVERUN)
IF(PMANAGERRUN(MESSAGE%VALUE1,'',0))THEN; ENDIF
CASE (ID_OPEN,ID_SAVE)
IF(PMANAGERPRJ(MESSAGE%VALUE1,'',0))THEN; ENDIF
CASE (ID_DELETE)
CALL PMANAGERDELETE()
CASE (IDCANCEL)
CALL PMANAGERCLOSE()
CASE (IDHELP)
CALL IMODGETHELP('3.3.6','VMO.iMODProjMan')
END SELECT
END SELECT
END SUBROUTINE PMANAGERMAIN
!###======================================================================
SUBROUTINE PMANAGEROPEN()
!###======================================================================
IMPLICIT NONE
INTEGER :: I,J,N,ITYPE,IPER,ITOPIC,IYR,IMH,IDY,IHR,IMT,ISC,ICF,ID,ISYS,ISUBTOPIC,IST,IOPTION
TYPE(WIN_MESSAGE) :: MESSAGE
CHARACTER(LEN=256) :: CNAME
CHARACTER(LEN=3) :: EXT
LOGICAL :: LEX,LNEW
CHARACTER(LEN=MAXLEN) :: CD
CHARACTER(LEN=256),POINTER,DIMENSION(:) :: INPLIST
CALL WDIALOGSELECT(ID_DPMANAGER); CALL WDIALOGGETTREEVIEW(ID_TREEVIEW1,ID,CNAME)
!## get the right topics, attributes from the tree-view
IF(.NOT.PMANAGER_GETSELECTED(ID,ITOPIC,IPER,ISYS,ISUBTOPIC,1))RETURN
!## pst/pcg goes to another dialog
IF(ITOPIC.EQ.20.OR.ITOPIC.EQ.33)THEN
!## pst=settings
IF(ITOPIC.EQ.20)CALL PMANAGEROPEN_PEST()
!## pcg-settings
IF(ITOPIC.EQ.33)CALL PMANAGEROPEN_PCG()
IF(.NOT.ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
!## create/update new period
CALL PMANAGER_STRESSES(ITOPIC,IPER)
!## create new system
CALL PMANAGER_SYSTEMS(ITOPIC,IPER,ISYS)
ELSE
IPER=1; ISYS=1
ENDIF
TOPICS(ITOPIC)%STRESS(IPER)%FILES(1,ISYS)%IACT =1
CALL PMANAGERUPDATE(ITOPIC,IPER,ISYS)
RETURN
ENDIF
N=TOPICS(ITOPIC)%NSUBTOPICS; ALLOCATE(PRJ(N))
IYR=0; IMH=0; IDY=0; IHR=0; IMT=0; ISC=0
CALL WDIALOGLOAD(ID_DPMANAGEROPEN,ID_DPMANAGEROPEN)
!## add a new period
!## add a new system for current period
IF(IPER.EQ.0.OR.ISYS.EQ.0)THEN
PRJ%ILAY =1
PRJ%FCT =1.0
PRJ%IMP =0.0
PRJ%CNST =-999.99
PRJ%ICNST=1
PRJ%FNAME=''
PRJ%IACT =1
CALL IOSDATE(IYR,IMH,IDY); IHR=0; IMT=0; ISC=0
CALL WDIALOGFIELDSTATE(IDOK3,0)
LNEW=.FALSE.; IF(IPER.EQ.0)LNEW=.TRUE.
!## edit an existing system
ELSE
DO ISUBTOPIC=1,TOPICS(ITOPIC)%NSUBTOPICS
PRJ(ISUBTOPIC)%FNAME=TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME
PRJ(ISUBTOPIC)%FCT =TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FCT
PRJ(ISUBTOPIC)%IMP =TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%IMP
PRJ(ISUBTOPIC)%CNST =TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%CNST
PRJ(ISUBTOPIC)%ICNST=TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ICNST
PRJ(ISUBTOPIC)%ILAY =TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ILAY
PRJ(ISUBTOPIC)%IACT =TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%IACT
ENDDO
CALL WDIALOGFIELDSTATE(IDOK,0)
LNEW=.FALSE.
ENDIF
IF(ITOPIC.EQ.1.AND.IPER.GT.0)THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(IPER)%INPFILES))THEN
ALLOCATE(INPLIST(SIZE(TOPICS(ITOPIC)%STRESS(IPER)%INPFILES)))
INPLIST=TOPICS(ITOPIC)%STRESS(IPER)%INPFILES
ENDIF
ENDIF
ENDIF
IOPTION=1
!## cannot change date
IF(.NOT.LNEW)THEN
CALL WDIALOGFIELDSTATE(IDF_RADIO3,0)
CALL WDIALOGFIELDSTATE(IDF_RADIO4,0)
CALL WDIALOGFIELDSTATE(IDF_RADIO5,0)
ENDIF
IF(IPER.GT.0)THEN
IF(TOPICS(ITOPIC)%TIMDEP)THEN
IYR=TOPICS(ITOPIC)%STRESS(IPER)%IYR; IMH=TOPICS(ITOPIC)%STRESS(IPER)%IMH; IDY=TOPICS(ITOPIC)%STRESS(IPER)%IDY
IHR=TOPICS(ITOPIC)%STRESS(IPER)%IHR; IMT=TOPICS(ITOPIC)%STRESS(IPER)%IMT; ISC=TOPICS(ITOPIC)%STRESS(IPER)%ISC
!## true date eentered
IF(IYR+IMH+IDY+IHR+IMT+ISC.GT.0)THEN
CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO4) !## transient
IF(.NOT.LNEW)CALL WDIALOGFIELDSTATE(IDF_RADIO4,1)
ELSE
!## check whether available period selected
DO I=1,NPERIOD; IF(TRIM(UTL_CAP(TOPICS(ITOPIC)%STRESS(IPER)%CDATE,'U')).EQ.TRIM(UTL_CAP(PERIOD(I)%NAME,'U')))EXIT; ENDDO
IF(I.LE.NPERIOD)THEN
IOPTION=I
CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO5) !## specified period
IF(.NOT.LNEW)CALL WDIALOGFIELDSTATE(IDF_RADIO5,1)
ELSE
CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO3) !## steady-state
IF(.NOT.LNEW)CALL WDIALOGFIELDSTATE(IDF_RADIO3,1)
ENDIF
ENDIF
ENDIF
ENDIF
IST=1
CALL WDIALOGTITLE('Define Characteristics for: '//TRIM(TOPICS(ITOPIC)%TNAME))
ALLOCATE(MENUNAMES(TOPICS(ITOPIC)%NSUBTOPICS))
DO J=1,TOPICS(ITOPIC)%NSUBTOPICS; MENUNAMES(J)=TOPICS(ITOPIC)%SNAME(J); ENDDO
CALL WDIALOGPUTMENU(IDF_MENU1,MENUNAMES,TOPICS(ITOPIC)%NSUBTOPICS,IST)
IF(ITOPIC.EQ.1)THEN
CALL WDIALOGFIELDSTATE(IDF_LABEL1,0)
CALL WDIALOGFIELDSTATE(IDF_INTEGER1,0)
CALL WDIALOGFIELDSTATE(ID_ADDFILES,1)
ELSE
CALL WDIALOGFIELDSTATE(ID_ADDFILES,0)
ENDIF
IF(NPERIOD.EQ.0)THEN
CALL WDIALOGFIELDSTATE(IDF_MENU3,0)
CALL WDIALOGCLEARFIELD(IDF_MENU3)
ELSE
CALL WDIALOGPUTMENU(IDF_MENU3,PERIOD%NAME,NPERIOD,IOPTION)
CALL WDIALOGFIELDSTATE(IDF_MENU3,1)
ENDIF
CALL WDIALOGPUTIMAGE(ID_OPEN ,ID_ICONOPENIDF,1)
IF(.NOT.TOPICS(ITOPIC)%TIMDEP)THEN
CALL WDIALOGFIELDSTATE(IDF_RADIO3,0)
CALL WDIALOGFIELDSTATE(IDF_RADIO4,0)
CALL WDIALOGFIELDSTATE(IDF_RADIO5,0)
CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO3)
CALL WDIALOGFIELDSTATE(IDF_INTEGER2,0)
CALL WDIALOGFIELDSTATE(IDF_INTEGER3,0)
CALL WDIALOGFIELDSTATE(IDF_INTEGER4,0)
CALL WDIALOGFIELDSTATE(IDF_INTEGER5,0)
CALL WDIALOGFIELDSTATE(IDF_INTEGER6,0)
CALL WDIALOGFIELDSTATE(IDF_MENU2,0)
CALL WDIALOGFIELDSTATE(IDF_MENU3,0)
CALL WDIALOGFIELDSTATE(ID_PROPERTIES,0)
CALL WDIALOGPUTSTRING(IDF_LABEL1,'Assign parameter to modellayer. Use >0 to enter modellayer number')
ELSE
CALL WDIALOGPUTSTRING(IDF_LABEL1,'Assign parameter to modellayer. Use >0 to enter modellayer number; use -1 to assign to uppermost active '// &
'modellayer and use =0 to assign to modellayers automatically')
ENDIF
CALL WDIALOGPUTMENU(IDF_MENU2,CDATE,12,MAX(1,IMH))
CALL WDIALOGPUTINTEGER(IDF_INTEGER2,IDY)
CALL WDIALOGPUTINTEGER(IDF_INTEGER3,IYR)
CALL WDIALOGPUTINTEGER(IDF_INTEGER4,IHR)
CALL WDIALOGPUTINTEGER(IDF_INTEGER5,IMT)
CALL WDIALOGPUTINTEGER(IDF_INTEGER6,ISC)
CALL WDIALOGPUTINTEGER(IDF_INTEGER1,PRJ(1)%ILAY)
CALL WDIALOGPUTCHECKBOX(IDF_CHECK1 ,PRJ(1)%IACT)
IF(.NOT.TOPICS(ITOPIC)%TIMDEP.OR.SIZE(MENUNAMES).EQ.1)CALL WDIALOGFIELDSTATE(IDF_CHECK2,0)
IF(PRJ(1)%ICNST.EQ.0)CALL WDIALOGPUTCHECKBOX(IDF_CHECK2,1)
IF(TOPICS(ITOPIC)%TIMDEP)THEN
CALL WDIALOGRANGEINTEGER(IDF_INTEGER1,-1,9999)
ELSE
CALL WDIALOGRANGEINTEGER(IDF_INTEGER1, 1,9999)
ENDIF
CALL PMANAGERPUTFIELDS(IST,ICF,EXT)
CALL WDIALOGFIELDSTATE(IDF_RADIO1,ICF)
IF(ICF.EQ.0)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO2)
CALL PMANAGEROPENFIELDS(TOPICS(ITOPIC)%TIMDEP,LNEW,ICF)
CALL UTL_FILLDATES(IDF_INTEGER3,IDF_MENU2,IDF_INTEGER2)
CALL WDIALOGSHOW(-1,-1,0,3)
DO
CALL WMESSAGE(ITYPE,MESSAGE)
SELECT CASE (ITYPE)
CASE(FIELDCHANGED)
SELECT CASE (MESSAGE%VALUE2)
CASE (IDF_MENU1)
CALL PMANAGERGETFIELDS(IST)
CASE (IDF_RADIO1,IDF_RADIO2,IDF_RADIO3,IDF_RADIO4,IDF_RADIO5,IDF_CHECK1,IDF_CHECK2)
CALL PMANAGEROPENFIELDS(TOPICS(ITOPIC)%TIMDEP,LNEW,ICF)
CASE (IDF_INTEGER2,IDF_INTEGER3,IDF_MENU2)
CALL UTL_FILLDATES(IDF_INTEGER3,IDF_MENU2,IDF_INTEGER2)
END SELECT
SELECT CASE (MESSAGE%VALUE1)
CASE (IDF_MENU1)
CALL PMANAGERPUTFIELDS(IST,ICF,EXT)
CALL PMANAGEROPENFIELDS(TOPICS(ITOPIC)%TIMDEP,LNEW,ICF)
END SELECT
CASE(PUSHBUTTON)
SELECT CASE (MESSAGE%VALUE1)
CASE (ID_ADDFILES)
CALL UTL_LISTOFFILES(INPLIST,(/'*.*','','','','','Specify the files to be added to the package'/),I)
CASE (ID_PROPERTIES)
CALL PMANAGERDEFINEPERIODS()
IF(NPERIOD.GT.0)THEN
CALL WDIALOGPUTMENU(IDF_MENU3,PERIOD%NAME,NPERIOD,1)
CALL WDIALOGFIELDSTATE(IDF_MENU3,1)
ELSE
CALL WDIALOGFIELDSTATE(IDF_MENU3,0)
CALL WDIALOGCLEARFIELD(IDF_MENU3)
ENDIF
CASE (ID_OPEN)
IF(UTL_WSELECTFILE('iMOD '//TRIM(EXT)//' File (*.'//TRIM(EXT)//')|*.'//TRIM(EXT)//'|', &
LOADDIALOG+MUSTEXIST+PROMPTON+DIRCHANGE+APPENDEXT,PRJ(IST)%FNAME,&
'Load iMOD '//TRIM(EXT)//' File'))THEN
CALL WDIALOGPUTSTRING(IDF_STRING1,PRJ(IST)%FNAME)
ENDIF
CASE (IDOK,IDOK3)
LEX=.TRUE.
IF(TOPICS(ITOPIC)%TIMDEP)THEN
CALL WDIALOGGETRADIOBUTTON(IDF_RADIO3,I)
CD=''
!## steady-state
IF(I.EQ.1)THEN
CD='STEADY-STATE'; IYR=0; IMH=0; IDY=0; IHR=0; IMT=0; ISC=0
!## date
ELSEIF(I.EQ.2)THEN
CALL WDIALOGGETINTEGER(IDF_INTEGER2,IDY)
CALL WDIALOGGETINTEGER(IDF_INTEGER3,IYR)
CALL WDIALOGGETMENU(IDF_MENU2,IMH)
CALL WDIALOGGETINTEGER(IDF_INTEGER4,IHR)
CALL WDIALOGGETINTEGER(IDF_INTEGER5,IMT)
CALL WDIALOGGETINTEGER(IDF_INTEGER6,ISC)
WRITE(CD,'(I4.4,5(A1,I2.2))') IYR,'-',IMH,'-',IDY,' ',IHR,':',IMT,':',ISC
!## period
ELSEIF(I.EQ.3)THEN
CALL WDIALOGGETMENU(IDF_MENU3,I)
WRITE(CD,'(A)') PERIOD(I)%NAME
IYR=0; IMH=0; IDY=0; IHR=0; IMT=0; ISC=0
ENDIF
IF(LNEW)THEN
!## test whether date has been defined already
N=0; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))N=SIZE(TOPICS(ITOPIC)%STRESS)
DO I=1,N
IF(TRIM(UTL_CAP(TOPICS(ITOPIC)%STRESS(I)%CDATE,'U')).EQ.TRIM(UTL_CAP(CD,'U')))THEN
!## defined already
CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'Entered date ['//TRIM(CD)//'] has been defined already.','Information')
LEX=.FALSE.
ENDIF
ENDDO
ENDIF
ENDIF
IF(LEX)THEN
CALL WDIALOGGETINTEGER(IDF_INTEGER1,PRJ(1)%ILAY)
CALL WDIALOGGETCHECKBOX(IDF_CHECK1 ,PRJ(1)%IACT)
PRJ(1:SIZE(PRJ))%ILAY=PRJ(1)%ILAY
PRJ(1:SIZE(PRJ))%IACT=PRJ(1)%IACT
CALL PMANAGERGETFIELDS(IST)
EXIT
ENDIF
CASE (IDCANCEL)
EXIT
END SELECT
END SELECT
ENDDO
CALL WDIALOGUNLOAD()
IF(MESSAGE%VALUE1.EQ.IDOK.OR.MESSAGE%VALUE1.EQ.IDOK3)THEN
!## create new period
CALL PMANAGER_STRESSES(ITOPIC,IPER)
!## create new system
CALL PMANAGER_SYSTEMS(ITOPIC,IPER,ISYS)
TOPICS(ITOPIC)%STRESS(IPER)%CDATE=CD
TOPICS(ITOPIC)%STRESS(IPER)%IYR=IYR; TOPICS(ITOPIC)%STRESS(IPER)%IMH=IMH
TOPICS(ITOPIC)%STRESS(IPER)%IDY=IDY; TOPICS(ITOPIC)%STRESS(IPER)%IHR=IHR
TOPICS(ITOPIC)%STRESS(IPER)%IMT=IMT; TOPICS(ITOPIC)%STRESS(IPER)%ISC=ISC
IF(ITOPIC.EQ.1)THEN
IF(ASSOCIATED(INPLIST))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(IPER)%INPFILES))DEALLOCATE(TOPICS(ITOPIC)%STRESS(IPER)%INPFILES)
ALLOCATE(TOPICS(ITOPIC)%STRESS(IPER)%INPFILES(SIZE(INPLIST)))
TOPICS(ITOPIC)%STRESS(IPER)%INPFILES=INPLIST
DEALLOCATE(INPLIST)
ENDIF
ENDIF
DO ISUBTOPIC=1,TOPICS(ITOPIC)%NSUBTOPICS
TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%IACT =PRJ(ISUBTOPIC)%IACT
TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME=PRJ(ISUBTOPIC)%FNAME
TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FCT =PRJ(ISUBTOPIC)%FCT
TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%IMP =PRJ(ISUBTOPIC)%IMP
TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ICNST=PRJ(ISUBTOPIC)%ICNST
TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%CNST =PRJ(ISUBTOPIC)%CNST
TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ILAY =PRJ(ISUBTOPIC)%ILAY
IF(PRJ(ISUBTOPIC)%ICNST.EQ.2)THEN
TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ALIAS= &
UTL_CAP(TRIM(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME &
(INDEX(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME,'\',.TRUE.)+1:)),'L')
ENDIF
ENDDO
CALL PMANAGER_SORTTOPIC(ITOPIC,IPER)
CALL PMANAGERUPDATE(ITOPIC,IPER,ISYS)
ENDIF
DEALLOCATE(MENUNAMES,PRJ)
END SUBROUTINE PMANAGEROPEN
!###======================================================================
SUBROUTINE PMANAGER_SORTTOPIC(ITOPIC,IPER)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ITOPIC,IPER
INTEGER :: I,J,II,K,N,M,JJ,IYR,IMH,IDY,IHR,IMT,ISC
INTEGER,ALLOCATABLE,DIMENSION(:) :: ILAY,ISORT
REAL(KIND=8),ALLOCATABLE,DIMENSION(:) :: RTIME
!## sort selected systems in layer
N=SIZE(TOPICS(ITOPIC)%STRESS(IPER)%FILES,2)
IF(N.GT.1)THEN
ALLOCATE(ILAY(N),ISORT(N)); ILAY=0; ISORT=0
DO I=1,N; ILAY(I)=TOPICS(ITOPIC)%STRESS(IPER)%FILES(1,I)%ILAY; ENDDO
CALL WSORT(ILAY,1,N,IORDER=ISORT)
J =SIZE(TOPICS(ITOPIC)%STRESS(IPER)%FILES,1)
K =SIZE(TOPICS(ITOPIC)%STRESS(IPER)%FILES,2)
NULLIFY(TOPICS(ITOPIC)%STRESS(IPER)%FILES_TMP)
ALLOCATE(TOPICS(ITOPIC)%STRESS(IPER)%FILES_TMP(J,K))
DO I=1,N
J=ISORT(I)
DO II=1,SIZE(TOPICS(ITOPIC)%STRESS(IPER)%FILES,1)
TOPICS(ITOPIC)%STRESS(IPER)%FILES_TMP(II,I)=TOPICS(ITOPIC)%STRESS(IPER)%FILES(II,J)
ENDDO
ENDDO
DEALLOCATE(TOPICS(ITOPIC)%STRESS(IPER)%FILES)
TOPICS(ITOPIC)%STRESS(IPER)%FILES=>TOPICS(ITOPIC)%STRESS(IPER)%FILES_TMP
DEALLOCATE(ILAY,ISORT)
ENDIF
!## sort selected systems in time
IF(TOPICS(ITOPIC)%TIMDEP)THEN
N=SIZE(TOPICS(ITOPIC)%STRESS)
IF(N.GT.1)THEN
ALLOCATE(RTIME(N),ISORT(N)); RTIME=0.0D0; ISORT=0
DO I=1,N
IYR=TOPICS(ITOPIC)%STRESS(I)%IYR; IMH=TOPICS(ITOPIC)%STRESS(I)%IMH
IDY=TOPICS(ITOPIC)%STRESS(I)%IDY; IHR=TOPICS(ITOPIC)%STRESS(I)%IHR
IMT=TOPICS(ITOPIC)%STRESS(I)%IMT; ISC=TOPICS(ITOPIC)%STRESS(I)%ISC
RTIME(I)=IYR*10000000000+IMH*100000000+IDY*1000000+IHR*10000+IMT*100+ISC
ENDDO
CALL WSORT(RTIME,1,N,IORDER=ISORT)
N=SIZE(TOPICS(ITOPIC)%STRESS); ALLOCATE(TOPICS(ITOPIC)%STRESS_TMP(N))
DO I=1,N
J=ISORT(I)
!## create items for j
N =SIZE(TOPICS(ITOPIC)%STRESS(J)%FILES,1)
M =SIZE(TOPICS(ITOPIC)%STRESS(J)%FILES,2)
NULLIFY(TOPICS(ITOPIC)%STRESS_TMP(I)%FILES); ALLOCATE(TOPICS(ITOPIC)%STRESS_TMP(I)%FILES(N,M))
TOPICS(ITOPIC)%STRESS_TMP(I)%CDATE=TOPICS(ITOPIC)%STRESS(J)%CDATE
TOPICS(ITOPIC)%STRESS_TMP(I)%IYR =TOPICS(ITOPIC)%STRESS(J)%IYR
TOPICS(ITOPIC)%STRESS_TMP(I)%IMH =TOPICS(ITOPIC)%STRESS(J)%IMH
TOPICS(ITOPIC)%STRESS_TMP(I)%IDY =TOPICS(ITOPIC)%STRESS(J)%IDY
TOPICS(ITOPIC)%STRESS_TMP(I)%IHR =TOPICS(ITOPIC)%STRESS(J)%IHR
TOPICS(ITOPIC)%STRESS_TMP(I)%IMT =TOPICS(ITOPIC)%STRESS(J)%IMT
TOPICS(ITOPIC)%STRESS_TMP(I)%ISC =TOPICS(ITOPIC)%STRESS(J)%ISC
DO II=1,SIZE(TOPICS(ITOPIC)%STRESS_TMP(I)%FILES,1)
DO JJ=1,SIZE(TOPICS(ITOPIC)%STRESS_TMP(I)%FILES,2)
TOPICS(ITOPIC)%STRESS_TMP(I)%FILES(II,JJ)=TOPICS(ITOPIC)%STRESS(J)%FILES(II,JJ)
ENDDO
ENDDO
ENDDO
DEALLOCATE(TOPICS(ITOPIC)%STRESS)
TOPICS(ITOPIC)%STRESS=>TOPICS(ITOPIC)%STRESS_TMP
DEALLOCATE(RTIME,ISORT)
ENDIF
ENDIF
END SUBROUTINE PMANAGER_SORTTOPIC
!###======================================================================
SUBROUTINE PMANAGEROPEN_AUTOMATIC()
!###======================================================================
IMPLICIT NONE
INTEGER :: I,J,N,ITYPE,ITOPIC,IPER,ISYS,ISUBTOPIC,ID,NF,ICNST,ILAY,IOS,IYR,IMH,IDY,IHR,IMT,ISC,ISEL
REAL :: CNST
TYPE(WIN_MESSAGE) :: MESSAGE
CHARACTER(LEN=14) :: CD
CHARACTER(LEN=256) :: CNAME
CHARACTER(LEN=256),ALLOCATABLE,DIMENSION(:) :: PNAME
! CHARACTER(LEN=256),POINTER,DIMENSION(:,:) :: FILES
INTEGER(KIND=8) :: IDATE
CALL WDIALOGSELECT(ID_DPMANAGER); CALL WDIALOGGETTREEVIEW(ID_TREEVIEW1,ID,CNAME)
!## get the right topics, attributes from the tree-view
IF(.NOT.PMANAGER_GETSELECTED(ID,ITOPIC,IPER,ISYS,ISUBTOPIC,1))RETURN
!## pst/pcg goes to another dialog
IF(ITOPIC.EQ.1.OR.ITOPIC.EQ.20.OR.ITOPIC.EQ.33)THEN
RETURN
ENDIF
CALL WDIALOGLOAD(ID_DPMANAGER_AUTOMATIC,ID_DPMANAGER_AUTOMATIC)
CALL WGRIDROWS(IDF_GRID1,TOPICS(ITOPIC)%NSUBTOPICS)
CALL WDIALOGTITLE('Define Characteristics for: '//TRIM(TOPICS(ITOPIC)%TNAME))
DO J=1,TOPICS(ITOPIC)%NSUBTOPICS; CALL WGRIDPUTCELLSTRING(IDF_GRID1,1,J,TOPICS(ITOPIC)%SNAME(J)); ENDDO
IF(ALLOCATED(PNAME))DEALLOCATE(PNAME)
ALLOCATE(PNAME(TOPICS(ITOPIC)%NSUBTOPICS))
IF(TOPICS(ITOPIC)%TIMDEP)THEN
CALL WDIALOGPUTSTRING(IDF_RADIO1,'iMOD will look for unique TIME STEPS (>0) and MODEL LAYERS (>0) at the wildcard and add those files to your Project Manager')
CALL WDIALOGFIELDSTATE(IDF_RADIO2,0)
ELSE
CALL WDIALOGPUTSTRING(IDF_RADIO1,'iMOD will look for unique LAYERS (>0) at the wildcard and add those files to your Project Manager')
CALL WDIALOGFIELDSTATE(IDF_RADIO3,0)
ENDIF
CALL WDIALOGPUTMENU(IDF_MENU1,CDATE,12,1)
CALL WDIALOGPUTMENU(IDF_MENU2,CDATE,12,1)
CALL UTL_FILLDATESDIALOG(ID_DPMANAGER_AUTOMATIC,IDF_INTEGER1,IDF_MENU1,IDF_INTEGER2,UTL_GETCURRENTDATE())
CALL UTL_FILLDATESDIALOG(ID_DPMANAGER_AUTOMATIC,IDF_INTEGER2,IDF_MENU2,IDF_INTEGER4,UTL_GETCURRENTDATE())
CALL PMANAGEROPEN_AUTOMATIC_FIELDS()
CALL WDIALOGRANGEINTEGER(IDF_INTEGER5,1,999)
CALL WDIALOGPUTINTEGER(IDF_INTEGER5,1)
CALL PMANAGER_GETNFILES((/2,3,4,5,6,7,8,9,10,11,12/),NF); NF=MAX(1,NF)
CALL WDIALOGPUTINTEGER(IDF_INTEGER12,NF)
CALL WDIALOGRANGEINTEGER(IDF_INTEGER12,1,999)
CALL WDIALOGSHOW(-1,-1,0,3)
DO
CALL WMESSAGE(ITYPE,MESSAGE)
SELECT CASE (ITYPE)
CASE(FIELDCHANGED)
SELECT CASE (MESSAGE%VALUE2)
CASE (IDF_RADIO1,IDF_RADIO2,IDF_RADIO3)
CALL PMANAGEROPEN_AUTOMATIC_FIELDS()
CASE (IDF_MENU1)
CALL UTL_FILLDATES(IDF_INTEGER3,IDF_MENU1,IDF_INTEGER1)
CASE (IDF_MENU2)
CALL UTL_FILLDATES(IDF_INTEGER4,IDF_MENU2,IDF_INTEGER2)
END SELECT
SELECT CASE (MESSAGE%VALUE1)
END SELECT
CASE(PUSHBUTTON)
SELECT CASE (MESSAGE%VALUE1)
CASE (IDOK)
CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,ISEL); NF=0
DO J=1,TOPICS(ITOPIC)%NSUBTOPICS
CALL WGRIDGETCELLSTRING(IDF_GRID1,2,J,PNAME(J))
IF(TRIM(PNAME(J)).EQ.'')THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Nothing filled in for'//CHAR(13)// &
TRIM(TOPICS(ITOPIC)%SNAME(J)),'Error'); EXIT
ENDIF
IF(INDEX(PNAME(J),'*').GT.0)NF=NF+1
ENDDO
IF(ISEL.NE.2.AND.NF.LE.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You need to add at least one parameter'//CHAR(13)// &
'defined with a wildcard','Error')
ELSE
IF(J.GT.TOPICS(ITOPIC)%NSUBTOPICS)THEN
IF(PMANAGEROPEN_AUTOMATIC_FILES(ITOPIC,PNAME,SIZE(PNAME)))THEN !,FILES))THEN
!## show files found
IF(PMANAGEROPEN_AUTOMATIC_LISTFILES(ITOPIC))EXIT !FILES,ITOPIC))EXIT
CALL WDIALOGSELECT(ID_DPMANAGER_AUTOMATIC)
ENDIF
ENDIF
ENDIF
CASE (IDHELP)
CASE (IDCANCEL)
EXIT
END SELECT
END SELECT
ENDDO
CALL WDIALOGSELECT(ID_DPMANAGER_AUTOMATIC); CALL WDIALOGUNLOAD()
IF(MESSAGE%VALUE1.EQ.IDOK)THEN
!## add files to project manager
DO I=1,SIZE(FILES,1)
IF(TOPICS(ITOPIC)%TIMDEP)THEN
READ(FILES(I,TOPICS(ITOPIC)%NSUBTOPICS+1),*) IDATE
CALL ITIMETOGDATE(IDATE,IYR,IMH,IDY,IHR,IMT,ISC)
WRITE(CD,'(I14)') IDATE
!## test whether date has been defined already
IPER=0; N=0; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))N=SIZE(TOPICS(ITOPIC)%STRESS)
DO J=1,N
IF(TRIM(UTL_CAP(TOPICS(ITOPIC)%STRESS(J)%CDATE,'U')).EQ.TRIM(UTL_CAP(CD,'U')))THEN
IPER=J; EXIT
ENDIF
ENDDO
!## create new period
CALL PMANAGER_STRESSES(ITOPIC,IPER)
!## create new system
ISYS=0; CALL PMANAGER_SYSTEMS(ITOPIC,IPER,ISYS)
TOPICS(ITOPIC)%STRESS(IPER)%CDATE=ADJUSTL(FILES(I,TOPICS(ITOPIC)%NSUBTOPICS+1))
TOPICS(ITOPIC)%STRESS(IPER)%IYR=IYR; TOPICS(ITOPIC)%STRESS(IPER)%IMH=IMH
TOPICS(ITOPIC)%STRESS(IPER)%IDY=IDY; TOPICS(ITOPIC)%STRESS(IPER)%IHR=IHR
TOPICS(ITOPIC)%STRESS(IPER)%IMT=IMT; TOPICS(ITOPIC)%STRESS(IPER)%ISC=ISC
ILAY=-9999
ELSE
!## create new period
CALL PMANAGER_STRESSES(ITOPIC,IPER)
!## create new system
ISYS=0; CALL PMANAGER_SYSTEMS(ITOPIC,IPER,ISYS)
READ(FILES(I,TOPICS(ITOPIC)%NSUBTOPICS+1),*,IOSTAT=IOS) ILAY
IF(IOS.NE.0)ILAY=-9999
ENDIF
DO ISUBTOPIC=1,TOPICS(ITOPIC)%NSUBTOPICS
READ(FILES(I,ISUBTOPIC),*,IOSTAT=IOS) CNST
IF(IOS.EQ.0)THEN
!## constant value
ICNST=1; FILES(I,ISUBTOPIC)=''
ELSE
!## file given
ICNST=2; CNST=-999.99
!## try to read layer
IF(ILAY.EQ.-9999)ILAY=IDFGETILAY(FILES(I,ISUBTOPIC))
ILAY=MAX(1,ILAY)
ENDIF
TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%IACT =1
TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME=FILES(I,ISUBTOPIC)
TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FCT =1.0
TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%IMP =0.0
TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ICNST=ICNST
TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%CNST =CNST
TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ILAY =ILAY
IF(ICNST.EQ.2)THEN
TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ALIAS= &
UTL_CAP(TRIM(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME &
(INDEX(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME,'\',.TRUE.)+1:)),'L')
ELSE
TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ALIAS=''
ENDIF
ENDDO
ENDDO
CALL PMANAGER_SORTTOPIC(ITOPIC,IPER)
CALL PMANAGERUPDATE(ITOPIC,IPER,ISYS)
DEALLOCATE(FILES,PNAME)
ENDIF
END SUBROUTINE PMANAGEROPEN_AUTOMATIC
!###======================================================================
SUBROUTINE PMANAGEROPEN_AUTOMATIC_FIELDS()
!###======================================================================
IMPLICIT NONE
INTEGER :: I,I1,I2
CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,I)
SELECT CASE (I)
CASE (1); I1=0; I2=0
CASE (2); I1=0; I2=1
CASE (3); I1=1; I2=0
END SELECT
CALL WDIALOGFIELDSTATE(IDF_MENU1,I1)
CALL WDIALOGFIELDSTATE(IDF_MENU2,I1)
CALL WDIALOGFIELDSTATE(IDF_INTEGER1,I1)
CALL WDIALOGFIELDSTATE(IDF_INTEGER2,I1)
CALL WDIALOGFIELDSTATE(IDF_INTEGER3,I1)
CALL WDIALOGFIELDSTATE(IDF_INTEGER4,I1)
CALL WDIALOGFIELDSTATE(IDF_INTEGER6,I1)
CALL WDIALOGFIELDSTATE(IDF_INTEGER7,I1)
CALL WDIALOGFIELDSTATE(IDF_INTEGER8,I1)
CALL WDIALOGFIELDSTATE(IDF_INTEGER9,I1)
CALL WDIALOGFIELDSTATE(IDF_INTEGER10,I1)
CALL WDIALOGFIELDSTATE(IDF_INTEGER11,I1)
CALL WDIALOGFIELDSTATE(IDF_LABEL2,I1)
CALL WDIALOGFIELDSTATE(IDF_LABEL3,I1)
CALL WDIALOGFIELDSTATE(IDF_INTEGER5,I2)
CALL WDIALOGFIELDSTATE(IDF_INTEGER12,I2)
END SUBROUTINE PMANAGEROPEN_AUTOMATIC_FIELDS
!###======================================================================
LOGICAL FUNCTION PMANAGEROPEN_AUTOMATIC_LISTFILES(ITOPIC) !FILES,ITOPIC)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ITOPIC
! CHARACTER(LEN=*),INTENT(INOUT),POINTER,DIMENSION(:,:) :: FILES
INTEGER,DIMENSION(:),ALLOCATABLE :: ICOLS
INTEGER :: I,J,N,M,ITYPE
TYPE(WIN_MESSAGE) :: MESSAGE
CALL WDIALOGLOAD(ID_DPMANAGER_AUTO_LIST,ID_DPMANAGER_AUTO_LIST)
N=SIZE(FILES,1); M=SIZE(FILES,2)-1
IF(WINFOGRID(IDF_GRID1,GRIDROWSMAX).LT.N)THEN
CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'iMOD can display '//TRIM(ITOS(WINFOGRID(IDF_GRID1,GRIDROWSMAX)))//' rows only'//CHAR(13)// &
'The current selection of files is '//TRIM(ITOS(N)),'Information')
CALL WDIALOGUNLOAD(); RETURN
ENDIF
CALL WGRIDROWS(IDF_GRID1,N)
ALLOCATE(ICOLS(M)); ICOLS=1; CALL WGRIDCOLUMNS(IDF_GRID1,M,ICOLS); DEALLOCATE(ICOLS)
DO I=1,M; CALL WGRIDLABELCOLUMN(IDF_GRID1,I,TOPICS(ITOPIC)%SNAME(I)(1:5)); ENDDO
DO I=1,N; CALL WGRIDLABELROW(IDF_GRID1,I,FILES(I,M+1)); ENDDO
DO I=1,M; DO J=1,N
CALL WGRIDPUTCELLSTRING(IDF_GRID1,I,J,FILES(J,I))
ENDDO; ENDDO
CALL WDIALOGSHOW(-1,-1,0,3)
DO
CALL WMESSAGE(ITYPE,MESSAGE)
SELECT CASE (ITYPE)
CASE(FIELDCHANGED)
SELECT CASE (MESSAGE%VALUE2)
END SELECT
SELECT CASE (MESSAGE%VALUE1)
END SELECT
CASE(PUSHBUTTON)
SELECT CASE (MESSAGE%VALUE1)
CASE (IDOK)
!## read from dialog any adjustments
DO I=1,M; DO J=1,N
CALL WGRIDGETCELLSTRING(IDF_GRID1,I,J,FILES(J,I))
IF(UTL_CAP(FILES(J,I),'U').EQ.'INHERENT')THEN
IF(J.EQ.1)THEN
CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'You cannot assign key word INHERENT on the first row','Information')
EXIT
ELSE
FILES(J,I)=FILES(J-1,I)
ENDIF
ENDIF
ENDDO; IF(J.LE.N)EXIT; ENDDO
IF(I.GT.M)THEN
PMANAGEROPEN_AUTOMATIC_LISTFILES=.TRUE.; EXIT
ENDIF
CASE (IDHELP)
CASE (IDCANCEL)
PMANAGEROPEN_AUTOMATIC_LISTFILES=.FALSE.; EXIT
END SELECT
END SELECT
ENDDO
CALL WDIALOGUNLOAD()
END FUNCTION PMANAGEROPEN_AUTOMATIC_LISTFILES
!###======================================================================
LOGICAL FUNCTION PMANAGEROPEN_AUTOMATIC_FILES(ITOPIC,PNAME,NPNAME) !,FILES)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ITOPIC,NPNAME
CHARACTER(LEN=*),INTENT(IN),DIMENSION(NPNAME) :: PNAME
! CHARACTER(LEN=*),INTENT(INOUT),DIMENSION(:,:),POINTER :: FILES
! CHARACTER(LEN=256),DIMENSION(:,:),POINTER :: FILES_BU
INTEGER :: I,J,K,L,N,M,IOS,ISEL,IDY,IMH,IYR,IHR,IMT,ISC,IL,IL1,IL2,MLV
CHARACTER(LEN=256),ALLOCATABLE,DIMENSION(:) :: LISTNAME
INTEGER,ALLOCATABLE,DIMENSION(:) :: NF,PF
CHARACTER(LEN=256) :: DIR
CHARACTER(LEN=52) :: WC
REAL :: X
INTEGER(KIND=8) :: IT,IT1,IT2,MTV
LOGICAL :: LEX
PMANAGEROPEN_AUTOMATIC_FILES=.FALSE.
CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,ISEL)
IF(ISEL.EQ.2)THEN
CALL WDIALOGGETINTEGER(IDF_INTEGER5 ,IL1)
CALL WDIALOGGETINTEGER(IDF_INTEGER12,IL2)
ELSEIF(ISEL.EQ.3)THEN
CALL WDIALOGGETINTEGER(IDF_INTEGER1 ,IDY)
CALL WDIALOGGETMENU(IDF_MENU1 ,IMH)
CALL WDIALOGGETINTEGER(IDF_INTEGER3 ,IYR)
CALL WDIALOGGETINTEGER(IDF_INTEGER6 ,IHR)
CALL WDIALOGGETINTEGER(IDF_INTEGER7 ,IMT)
CALL WDIALOGGETINTEGER(IDF_INTEGER8 ,ISC)
IT1=IYR*10000000000+IMH*100000000+IDY*1000000+IHR*10000+IMT*100+ISC
CALL WDIALOGGETINTEGER(IDF_INTEGER2 ,IDY)
CALL WDIALOGGETMENU(IDF_MENU2 ,IMH)
CALL WDIALOGGETINTEGER(IDF_INTEGER4 ,IYR)
CALL WDIALOGGETINTEGER(IDF_INTEGER9 ,IHR)
CALL WDIALOGGETINTEGER(IDF_INTEGER10,IMT)
CALL WDIALOGGETINTEGER(IDF_INTEGER11,ISC)
IT2=IYR*10000000000+IMH*100000000+IDY*1000000+IHR*10000+IMT*100+ISC
ENDIF
N=TOPICS(ITOPIC)%NSUBTOPICS
CALL IOSDIRENTRYTYPE('F')
ALLOCATE(NF(N),PF(N)); NF=0; PF=1
!## okay let's go
DO J=1,2
NF=0
DO I=1,N
!## try to read a number
READ(PNAME(I),*,IOSTAT=IOS) X
!## okay is number, go to next
IF(IOS.EQ.0)THEN
IF(J.EQ.2)WRITE(FILES(1,I),*) X
ELSE
!## try wildcard
IF(INDEX(PNAME(I),'*').GT.0)THEN
DIR=PNAME(I)(1:INDEX(PNAME(I),'\',.TRUE.)-1)
WC =PNAME(I)(INDEX(PNAME(I),'\',.TRUE.)+1:)
CALL IOSDIRCOUNT(DIR,WC,M)
ALLOCATE(LISTNAME(M)); CALL UTL_DIRINFO(DIR,WC,LISTNAME,M,'F')
L=0
DO K=1,M
!## file okay until proven otherwise
LEX=.TRUE.
IF(.NOT.TOPICS(ITOPIC)%TIMDEP)THEN
IL=IDFGETILAY(LISTNAME(K))
!## negative/zero layers always invalid
IF(IL.LE.0)LEX=.FALSE.
IF(ISEL.EQ.2)THEN; IF(IL.LT.IL1.OR.IL.GT.IL2)LEX=.FALSE.; ENDIF
ELSE
IF(UTL_IDFGETDATE(LISTNAME(K),IYR=IYR,IMH=IMH,IDY=IDY,IHR=IHR,IMT=IMT,ISC=ISC).NE.0)THEN
IT=IYR*10000000000+IMH*100000000+IDY*1000000+IHR*10000+IMT*100+ISC
!## negative dates always invalid
IF(IT.LE.0)LEX=.FALSE.
IF(ISEL.EQ.3)THEN; IF(IT.LT.IT1.OR.IT.GT.IT2)LEX=.FALSE.; ENDIF
ELSE
LEX=.FALSE.
ENDIF
ENDIF
IF(LEX)THEN
L=L+1; IF(J.EQ.2)FILES(L,I)=TRIM(DIR)//'\'//TRIM(LISTNAME(K))
ENDIF
ENDDO
NF(I)=L; DEALLOCATE(LISTNAME)
ELSE
IF(J.EQ.2)FILES(1,I)=PNAME(I)
ENDIF
ENDIF
ENDDO
!## layer may be filled in without wildcards
IF(SUM(NF).EQ.0)THEN
!## layer asked
IF(ISEL.EQ.2)EXIT
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'No files found for the parameter(s)'//CHAR(13)// &
'defined with a wildcard','Error'); DEALLOCATE(NF,PF); RETURN
ENDIF
IF(J.EQ.1)ALLOCATE(FILES(SUM(NF),N))
ENDDO
IF(SUM(NF).GT.0)THEN
!## sort files - get them nicely lined up
DO I=1,N
IF(NF(I).GT.1)CALL WSORT(FILES(:,I),1,NF(I))
ENDDO
!## organize them properly
ALLOCATE(FILES_BU(SUM(NF),N+1))
!## initial value
FILES_BU='Inherent'
IF(TOPICS(ITOPIC)%TIMDEP)THEN
DO I=1,SUM(NF)
MTV=HUGE(INT(1,8))
!## find min-value
K=0; DO J=1,N
!## skip time-constant files
IF(NF(J).EQ.0)CYCLE
IF(UTL_IDFGETDATE(FILES(PF(J),J),IYR=IYR,IMH=IMH,IDY=IDY,IHR=IHR,IMT=IMT,ISC=ISC).NE.0)THEN
IT=IYR*10000000000+IMH*100000000+IDY*1000000+IHR*10000+IMT*100+ISC
IF(IT.LE.MTV)THEN; MTV=IT; K=K+1; ENDIF
ENDIF
ENDDO
!## nothing found anymore - quit
IF(K.EQ.0)EXIT
!## copy all equal to minvalue
WRITE(FILES_BU(I,N+1),*) MTV
DO J=1,N
!## skip time-constant files
IF(NF(J).EQ.0)CYCLE
IF(UTL_IDFGETDATE(FILES(PF(J),J),IYR=IYR,IMH=IMH,IDY=IDY,IHR=IHR,IMT=IMT,ISC=ISC).NE.0)THEN
IT=IYR*10000000000+IMH*100000000+IDY*1000000+IHR*10000+IMT*100+ISC
IF(IT.EQ.MTV)THEN
FILES_BU(I,J)=FILES(PF(J),J); PF(J)=PF(J)+1
ENDIF
ENDIF
ENDDO
ENDDO
ELSE
DO I=1,SUM(NF)
MLV=HUGE(1)
!## find min-value
K=0; DO J=1,N
IL=IDFGETILAY(FILES(PF(J),J)); IF(IL.LE.MLV)THEN; MLV=IL; K=K+1; ENDIF
ENDDO
!## nothing found anymore - quit
IF(K.EQ.0)EXIT
!## copy all equal to minvalue
WRITE(FILES_BU(I,N+1),*) MLV
DO J=1,N
IL=IDFGETILAY(FILES(PF(J),J))
IF(IL.EQ.MLV)THEN
FILES_BU(I,J)=FILES(PF(J),J); PF(J)=PF(J)+1
ENDIF
ENDDO
ENDDO
ENDIF
K=I-1
DEALLOCATE(FILES)
ALLOCATE(FILES(K,N+1))
DO I=1,K; DO J=1,N+1; FILES(I,J)=FILES_BU(I,J); ENDDO; ENDDO
DEALLOCATE(FILES_BU)
!## fill in constants at the beginning
DO I=1,N
IF(NF(I).EQ.0)FILES(1,I)=PNAME(I)
ENDDO
ELSE
K=(IL2-IL1)+1
ALLOCATE(FILES(K,N+1))
IL=IL1-1; DO I=1,K; IL=IL+1; DO J=1,N; FILES(I,J)=PNAME(J); ENDDO; FILES(I,N+1)=TRIM(ITOS(IL)); ENDDO
NF=K
ENDIF
IF(SUM(NF).GT.0)PMANAGEROPEN_AUTOMATIC_FILES=.TRUE.
DEALLOCATE(NF,PF)
END FUNCTION PMANAGEROPEN_AUTOMATIC_FILES
!###======================================================================
SUBROUTINE PMANAGEROPEN_PCG()
!###======================================================================
IMPLICIT NONE
TYPE(WIN_MESSAGE) :: MESSAGE
INTEGER :: ITYPE,DID
!CHARACTER,ALLOCATABLE,DIMENSION(:) :: COPTS
DID=WINFODIALOG(CURRENTDIALOG)
CALL WDIALOGLOAD(ID_DPMANAGER_PCG,ID_DPMANAGER_PCG)
CALL WDIALOGPUTSTRING(IDOK,'Apply')
CALL WDIALOGPUTIMAGE(ID_OPEN,ID_ICONOPENIDF)
!## fill in values
CALL WDIALOGPUTINTEGER(IDF_INTEGER1 ,ABS(PCG%NOUTER))
CALL WDIALOGPUTINTEGER(IDF_INTEGER2 ,PCG%NINNER)
CALL WDIALOGPUTREAL(IDF_REAL1,PCG%HCLOSE, '(G10.5)')
CALL WDIALOGPUTREAL(IDF_REAL2,PCG%RCLOSE, '(G10.5)')
CALL WDIALOGPUTREAL(IDF_REAL3,PCG%RELAX , '(G10.5)')
CALL WDIALOGPUTREAL(IDF_REAL4,PCG%QERROR, '(G10.5)')
CALL WDIALOGPUTCHECKBOX(IDF_CHECK1,PCG%IQERROR)
CALL WDIALOGPUTOPTION(IDF_MENU1,PCG%NPCOND)
CALL WDIALOGPUTINTEGER(IDF_INTEGER4 ,PCG%IPRPCG)
CALL WDIALOGPUTOPTION(IDF_MENU2,PCG%MUTPCG)
CALL WDIALOGPUTREAL(IDF_REAL7,PCG%DAMPPCG ,'(G10.5)')
CALL WDIALOGPUTREAL(IDF_REAL8,PCG%DAMPPCGT,'(G10.5)')
!## pks settings
CALL WDIALOGFIELDSTATE(IDF_MENU3,3)
CALL WDIALOGFIELDSTATE(IDF_MENU4,3)
CALL WDIALOGFIELDSTATE(IDF_STRING1,3)
CALL WDIALOGFIELDSTATE(IDF_CHECK2,3)
CALL WDIALOGFIELDSTATE(IDF_LABEL20,3)
CALL WDIALOGFIELDSTATE(IDF_LABEL21,3)
CALL WDIALOGFIELDSTATE(IDF_LABEL22,3)
CALL WDIALOGFIELDSTATE(ID_OPEN,3)
!CALL UTL_SYSCOREINFO(NMAXCORES)
!ALLOCATE(COPTS(NMAXCORES))
!DO I=1,NMAXCORES
! COPTS(I)=ITOS(I)
!ENDDO
!CALL WDIALOGPUTMENU(IDF_MENU3,COPTS,NMAXCORES,PCG%NCORES)
!DEALLOCATE(COPTS)
!PARTOPT=PCG%PARTOPT; IF(PARTOPT.EQ.0)PARTOPT=PCG%PARTOPT+1
!CALL WDIALOGPUTOPTION(IDF_MENU4,PARTOPT)
!CALL WDIALOGPUTSTRING(IDF_STRING1,PCG%MRGFNAME)
!CALL WDIALOGPUTCHECKBOX(IDF_CHECK2,PCG%IMERGE)
CALL WDIALOGGETCHECKBOX(IDF_CHECK1,PCG%IQERROR)
CALL WDIALOGFIELDSTATE(IDF_REAL4,PCG%IQERROR)
!CALL PMANAGEROPEN_PCGFIELDS()
CALL WDIALOGSHOW(-1,-1,0,3)
DO
CALL WMESSAGE(ITYPE,MESSAGE)
SELECT CASE (ITYPE)
CASE(FIELDCHANGED)
SELECT CASE (MESSAGE%VALUE2)
CASE (IDF_CHECK1)
CALL WDIALOGGETCHECKBOX(IDF_CHECK1,PCG%IQERROR)
CALL WDIALOGFIELDSTATE(IDF_REAL4,PCG%IQERROR)
!CASE (IDF_MENU3,IDF_MENU4)
! CALL PMANAGEROPEN_PCGFIELDS()
END SELECT
SELECT CASE (MESSAGE%VALUE1)
END SELECT
CASE(PUSHBUTTON)
SELECT CASE (MESSAGE%VALUE1)
CASE (IDOK,IDCANCEL)
EXIT
!CASE (ID_OPEN)
! FNAME=''
! IF(UTL_WSELECTFILE('iMOD IDF-File (*.idf)|*.idf|',LOADDIALOG+PROMPTON+DIRCHANGE+MUSTEXIST, &
! FNAME,'Select IDF File (*.idf)'))THEN
!CALL WDIALOGSELECT(ID_DPMANAGER_PCG)
!CALL WDIALOGPUTSTRING(IDF_STRING1,FNAME)
!ENDIF
!PCG%MRGFNAME=FNAME
CASE (IDHELP)
CALL IMODGETHELP('7.8','TMO.ModSim.SolverSettings')
END SELECT
END SELECT
ENDDO
!## read values
IF(MESSAGE%VALUE1.EQ.IDOK)THEN
CALL WDIALOGGETINTEGER(IDF_INTEGER1,PCG%NOUTER)
CALL WDIALOGGETINTEGER(IDF_INTEGER2,PCG%NINNER)
CALL WDIALOGGETREAL(IDF_REAL1,PCG%HCLOSE)
CALL WDIALOGGETREAL(IDF_REAL2,PCG%RCLOSE)
CALL WDIALOGGETREAL(IDF_REAL3,PCG%RELAX)
CALL WDIALOGGETREAL(IDF_REAL4,PCG%QERROR)
CALL WDIALOGGETCHECKBOX(IDF_CHECK1,PCG%IQERROR)
CALL WDIALOGGETMENU(IDF_MENU1,PCG%NPCOND)
CALL WDIALOGGETINTEGER(IDF_INTEGER4,PCG%IPRPCG)
CALL WDIALOGGETMENU(IDF_MENU2,PCG%MUTPCG)
CALL WDIALOGGETREAL(IDF_REAL7,PCG%DAMPPCG)
CALL WDIALOGGETREAL(IDF_REAL8,PCG%DAMPPCGT)
!CALL WDIALOGGETMENU(IDF_MENU3,PCG%NCORES)
!CALL WDIALOGGETMENU(IDF_MENU4,PCG%PARTOPT)
!CALL WDIALOGGETCHECKBOX(IDF_CHECK2,PCG%IMERGE)
!CALL WDIALOGGETSTRING(IDF_STRING1,PCG%MRGFNAME)
ENDIF
CALL WDIALOGSELECT(ID_DPMANAGER_PCG)
CALL WDIALOGUNLOAD(); CALL WDIALOGSELECT(DID)
END SUBROUTINE PMANAGEROPEN_PCG
!###======================================================================
SUBROUTINE PMANAGEROPEN_PCGFIELDS()
!###======================================================================
IMPLICIT NONE
CALL WDIALOGSELECT(ID_DPMANAGER_PCG)
!## get amount of cores to be used in modelsimulation, selected by user
!CALL WDIALOGGETMENU(IDF_MENU3,PCG%NCORES)
!J=0; IF(PCG%NCORES.NE.1)J=1
!IF(J.EQ.1)THEN
!!## enable partitioning option + subdomain merge option
! CALL WDIALOGFIELDSTATE(IDF_LABEL21,J)
! CALL WDIALOGFIELDSTATE(IDF_MENU4,J)
! CALL WDIALOGGETMENU(IDF_MENU4,I)
! K=0; IF(I.EQ.3)K=1
! CALL WDIALOGFIELDSTATE(IDF_STRING1,K)
! CALL WDIALOGFIELDSTATE(ID_OPEN,K)
! CALL WDIALOGFIELDSTATE(IDF_LABEL22,K)
! K=0; IF(I.NE.1)K=1
! CALL WDIALOGFIELDSTATE(IDF_CHECK2,K)
! CALL WDIALOGGETSTRING(IDF_STRING1,PCG%MRGFNAME)
!ELSE
!!## amount of selected cores is equal to 1;
!!## parallel simulation is not possible --> all options disabled
! CALL WDIALOGFIELDSTATE(IDF_LABEL21,J)
! CALL WDIALOGFIELDSTATE(IDF_MENU4,J)
! CALL WDIALOGPUTOPTION(IDF_MENU4,J+1)
! CALL WDIALOGFIELDSTATE(IDF_STRING1,J)
! CALL WDIALOGFIELDSTATE(ID_OPEN,J)
! CALL WDIALOGFIELDSTATE(IDF_LABEL22,J)
! CALL WDIALOGFIELDSTATE(IDF_CHECK2,J)
!ENDIF
CALL WDIALOGSELECT(ID_DPMANAGER_PCG)
END SUBROUTINE PMANAGEROPEN_PCGFIELDS
!###======================================================================
SUBROUTINE PMANAGEROPEN_PEST()
!###======================================================================
IMPLICIT NONE
TYPE(WIN_MESSAGE) :: MESSAGE
INTEGER :: ITYPE,DID,N
DID=WINFODIALOG(CURRENTDIALOG)
CALL WDIALOGLOAD(ID_DPMANAGER_PEST,ID_DPMANAGER_PEST)
CALL WDIALOGPUTSTRING(IDOK,'Apply System Settings')
!## fill in values
CALL WDIALOGPUTINTEGER(IDF_INTEGER7 ,PEST%PE_MXITER)
CALL WDIALOGPUTREAL(IDF_REAL4,PEST%PE_STOP,'(F10.2)')
CALL WDIALOGPUTREAL(IDF_REAL8,PEST%PE_PADJ ,'(F10.2)')
CALL WDIALOGPUTREAL(IDF_REAL5,PEST%PE_SENS,'(F10.2)')
CALL WDIALOGPUTREAL(IDF_REAL9,PEST%PE_DRES,'(F10.2)')
CALL WDIALOGPUTREAL(IDF_REAL6,PEST%PE_TARGET(1),'(F10.2)')
CALL WDIALOGPUTREAL(IDF_REAL7,PEST%PE_TARGET(2),'(F10.2)')
CALL WDIALOGPUTOPTION(IDF_MENU4,PEST%PE_SCALING)
CALL WDIALOGPUTOPTION(IDF_MENU5,PEST%PE_KTYPE)
N=0; IF(ASSOCIATED(PEST%S_PERIOD))N=SIZE(PEST%S_PERIOD)
CALL WDIALOGPUTINTEGER(IDF_INTEGER8 ,N)
CALL WDIALOGFIELDSTATE(IDF_INTEGER8,2)
N=0; IF(ASSOCIATED(PEST%B_FRACTION))N=SIZE(PEST%B_FRACTION)
CALL WDIALOGPUTINTEGER(IDF_INTEGER9 ,N)
CALL WDIALOGFIELDSTATE(IDF_INTEGER9,2)
N=0; IF(ASSOCIATED(PEST%PARAM))N=SIZE(PEST%PARAM)
CALL WDIALOGPUTINTEGER(IDF_INTEGER10,N)
CALL WDIALOGFIELDSTATE(IDF_INTEGER10,2)
N=0; IF(ASSOCIATED(PEST%IDFFILES))N=SIZE(PEST%IDFFILES)
CALL WDIALOGPUTINTEGER(IDF_INTEGER11,N)
CALL WDIALOGFIELDSTATE(IDF_INTEGER11,2)
N=0; IF(ASSOCIATED(PEST%MEASURES))N=SIZE(PEST%MEASURES)
CALL WDIALOGPUTINTEGER(IDF_INTEGER12,N)
CALL WDIALOGFIELDSTATE(IDF_INTEGER12,2)
CALL WDIALOGSHOW(-1,-1,0,3)
DO
CALL WMESSAGE(ITYPE,MESSAGE)
SELECT CASE (ITYPE)
CASE(FIELDCHANGED)
SELECT CASE (MESSAGE%VALUE2)
END SELECT
SELECT CASE (MESSAGE%VALUE1)
END SELECT
CASE(PUSHBUTTON)
SELECT CASE (MESSAGE%VALUE1)
CASE (ID_PERIODS)
CALL WDIALOGGETINTEGER(IDF_INTEGER8,N)
CALL PMANAGEROPEN_PESTPARAM(ID_PERIODS,N)
CALL WDIALOGPUTINTEGER(IDF_INTEGER8,N)
CASE (ID_BATCHFILES)
CALL WDIALOGGETINTEGER(IDF_INTEGER9,N)
CALL PMANAGEROPEN_PESTPARAM(ID_BATCHFILES,N)
CALL WDIALOGPUTINTEGER(IDF_INTEGER9,N)
CASE (ID_PARAMETERS)
CALL WDIALOGGETINTEGER(IDF_INTEGER10,N)
CALL PMANAGEROPEN_PESTPARAM(ID_PARAMETERS,N)
CALL WDIALOGPUTINTEGER(IDF_INTEGER10,N)
CASE (ID_ZONES)
CALL WDIALOGGETINTEGER(IDF_INTEGER11,N)
CALL PMANAGEROPEN_PESTPARAM(ID_ZONES,N)
CALL WDIALOGPUTINTEGER(IDF_INTEGER11,N)
CASE (ID_MEASURES)
CALL WDIALOGGETINTEGER(IDF_INTEGER12,N)
CALL PMANAGEROPEN_PESTPARAM(ID_MEASURES,N)
CALL WDIALOGPUTINTEGER(IDF_INTEGER12,N)
CASE (IDOK,IDCANCEL)
EXIT
END SELECT
END SELECT
ENDDO
!## read values
IF(MESSAGE%VALUE1.EQ.IDOK)THEN
CALL WDIALOGGETINTEGER(IDF_INTEGER7 ,PEST%PE_MXITER)
CALL WDIALOGGETREAL(IDF_REAL4,PEST%PE_STOP)
CALL WDIALOGGETREAL(IDF_REAL8,PEST%PE_PADJ)
CALL WDIALOGGETREAL(IDF_REAL5,PEST%PE_SENS)
CALL WDIALOGGETREAL(IDF_REAL9,PEST%PE_DRES)
CALL WDIALOGGETREAL(IDF_REAL6,PEST%PE_TARGET(1))
CALL WDIALOGGETREAL(IDF_REAL7,PEST%PE_TARGET(2))
CALL WDIALOGGETMENU(IDF_MENU4,PEST%PE_SCALING)
CALL WDIALOGGETMENU(IDF_MENU5,PEST%PE_KTYPE)
ENDIF
CALL WDIALOGSELECT(ID_DPMANAGER_PEST)
CALL WDIALOGUNLOAD(); CALL WDIALOGSELECT(DID)
END SUBROUTINE PMANAGEROPEN_PEST
!###======================================================================
SUBROUTINE PMANAGEROPEN_PESTPARAM(ID,N)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ID
INTEGER,INTENT(INOUT) :: N
TYPE(WIN_MESSAGE) :: MESSAGE
INTEGER :: ITYPE,DID,I,M
DID=WINFODIALOG(CURRENTDIALOG)
CALL WDIALOGLOAD(ID_DPMANAGER_PESTFILES,ID_DPMANAGER_PESTFILES)
SELECT CASE (ID)
CASE (ID_PERIODS)
CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES)
CALL WDIALOGSETTAB(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB1)
CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB2,0)
CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB3,0)
CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB4,0)
CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB5,0)
CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES_TAB1)
CALL WDIALOGPUTINTEGER(IDF_INTEGER8,N)
IF(N.GT.0)THEN
CALL WGRIDROWS(IDF_GRID1,N)
CALL WGRIDPUTSTRING(IDF_GRID1,1,PEST%S_PERIOD,N)
CALL WGRIDPUTSTRING(IDF_GRID1,2,PEST%E_PERIOD,N)
ELSE
CALL WDIALOGFIELDSTATE(IDF_GRID1,3)
ENDIF
CASE (ID_BATCHFILES)
CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES)
CALL WDIALOGSETTAB(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB2)
CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB1,0)
CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB3,0)
CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB4,0)
CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB5,0)
CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES_TAB2)
CALL WDIALOGPUTINTEGER(IDF_INTEGER9,N)
IF(N.GT.0)THEN
CALL WGRIDROWS(IDF_GRID1,N)
CALL WGRIDPUTREAL(IDF_GRID1,1,PEST%B_FRACTION,N)
CALL WGRIDPUTSTRING(IDF_GRID1,2,PEST%B_BATCHFILE,N)
CALL WGRIDPUTSTRING(IDF_GRID1,3,PEST%B_OUTFILE,N)
ELSE
CALL WDIALOGFIELDSTATE(IDF_GRID1,3)
ENDIF
CASE (ID_PARAMETERS)
CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES)
CALL WDIALOGSETTAB(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB3)
CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB1,0)
CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB2,0)
CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB4,0)
CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB5,0)
CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES_TAB3)
CALL WDIALOGPUTINTEGER(IDF_INTEGER10,N)
IF(N.GT.0)THEN
CALL WGRIDROWS(IDF_GRID1,N)
CALL WGRIDPUTCHECKBOX(IDF_GRID1,1 ,PEST%PARAM%PACT,N)
CALL WGRIDPUTMENU(IDF_GRID1 ,2 ,PARAM,SIZE(PARAM),PEST%PARAM%IPARAM,N)
CALL WGRIDPUTINTEGER(IDF_GRID1 ,3 ,PEST%PARAM%PILS,N)
CALL WGRIDPUTINTEGER(IDF_GRID1 ,4 ,PEST%PARAM%PIZONE,N)
CALL WGRIDPUTINTEGER(IDF_GRID1 ,5 ,PEST%PARAM%PIGROUP,N)
CALL WGRIDPUTREAL(IDF_GRID1 ,6 ,PEST%PARAM%PINI,N)
CALL WGRIDPUTREAL(IDF_GRID1 ,7 ,PEST%PARAM%PMIN,N)
CALL WGRIDPUTREAL(IDF_GRID1 ,8 ,PEST%PARAM%PMAX,N)
CALL WGRIDPUTREAL(IDF_GRID1 ,9 ,PEST%PARAM%PDELTA,N)
CALL WGRIDPUTREAL(IDF_GRID1 ,10,PEST%PARAM%PINCREASE,N)
CALL WGRIDPUTCHECKBOX(IDF_GRID1,11,PEST%PARAM%PLOG,N)
ELSE
CALL WDIALOGFIELDSTATE(IDF_GRID1,3)
ENDIF
CASE (ID_ZONES)
CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES)
CALL WDIALOGSETTAB(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB4)
CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB1,0)
CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB2,0)
CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB3,0)
CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB5,0)
CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES_TAB4)
CALL WDIALOGPUTINTEGER(IDF_INTEGER11,N)
IF(N.GT.0)THEN
CALL WGRIDROWS(IDF_GRID1,N)
CALL WGRIDPUTSTRING(IDF_GRID1,1,PEST%IDFFILES,N)
ELSE
CALL WDIALOGFIELDSTATE(IDF_GRID1,3)
ENDIF
CASE (ID_MEASURES)
CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES)
CALL WDIALOGSETTAB(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB5)
CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB1,0)
CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB2,0)
CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB3,0)
CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB4,0)
CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES_TAB5)
CALL WDIALOGPUTINTEGER(IDF_INTEGER12,N)
IF(N.GT.0)THEN
CALL WGRIDROWS(IDF_GRID1,N)
CALL WGRIDPUTSTRING (IDF_GRID1,1,PEST%MEASURES%IPFNAME,N)
PEST%MEASURES%IPFTYPE=PEST%MEASURES%IPFTYPE-1
CALL WGRIDPUTCHECKBOX(IDF_GRID1,2,PEST%MEASURES%IPFTYPE,N)
CALL WGRIDPUTINTEGER (IDF_GRID1,3,PEST%MEASURES%IXCOL,N)
CALL WGRIDPUTINTEGER (IDF_GRID1,4,PEST%MEASURES%IYCOL,N)
CALL WGRIDPUTINTEGER (IDF_GRID1,5,PEST%MEASURES%ILCOL,N)
CALL WGRIDPUTINTEGER (IDF_GRID1,6,PEST%MEASURES%IMCOL,N)
CALL WGRIDPUTINTEGER (IDF_GRID1,7,PEST%MEASURES%IVCOL,N)
ELSE
CALL WDIALOGFIELDSTATE(IDF_GRID1,3)
ENDIF
END SELECT
CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES)
CALL WDIALOGSHOW(-1,-1,0,3)
DO
CALL WMESSAGE(ITYPE,MESSAGE)
SELECT CASE (ITYPE)
CASE(FIELDCHANGED)
SELECT CASE (MESSAGE%VALUE2)
END SELECT
SELECT CASE (MESSAGE%VALUE1)
END SELECT
CASE(PUSHBUTTON)
CALL WDIALOGSELECT(MESSAGE%WIN)
SELECT CASE (MESSAGE%VALUE1)
CASE (ID_PERIODS)
CALL WDIALOGGETINTEGER(IDF_INTEGER8,N)
IF(N.EQ.0)THEN
CALL WDIALOGCLEARFIELD(IDF_GRID1)
IF(ASSOCIATED(PEST%S_PERIOD))DEALLOCATE(PEST%S_PERIOD,PEST%E_PERIOD)
CALL WDIALOGFIELDSTATE(IDF_GRID1,3)
ELSE
M=WINFOGRID(IDF_GRID1,GRIDROWSMAX)
IF(N.GT.M)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You can specify a maximum of '//TRIM(ITOS(M))//' Periods','Error'); N=M
ENDIF
!## resize variables
IF(ASSOCIATED(PEST%S_PERIOD))THEN
M=SIZE(PEST%S_PERIOD)
IF(N.NE.M)THEN
ALLOCATE(PEST%S_PERIOD_BU(N),PEST%E_PERIOD_BU(N)); PEST%S_PERIOD_BU='20150101000000'; PEST%E_PERIOD_BU='20151231000000'
DO I=1,MIN(N,M); PEST%S_PERIOD_BU(I)=PEST%S_PERIOD(I); ENDDO
DO I=1,MIN(N,M); PEST%E_PERIOD_BU(I)=PEST%E_PERIOD(I); ENDDO
DEALLOCATE(PEST%S_PERIOD,PEST%E_PERIOD); PEST%S_PERIOD=>PEST%S_PERIOD_BU; PEST%E_PERIOD=>PEST%E_PERIOD_BU
ENDIF
ELSE
ALLOCATE(PEST%S_PERIOD(N),PEST%E_PERIOD(N)); PEST%S_PERIOD='20150101000000'; PEST%E_PERIOD='20151231000000'
ENDIF
CALL WDIALOGFIELDSTATE(IDF_GRID1,1)
CALL WGRIDROWS(IDF_GRID1,N)
CALL WGRIDPUTSTRING(IDF_GRID1,1,PEST%S_PERIOD,N)
CALL WGRIDPUTSTRING(IDF_GRID1,2,PEST%E_PERIOD,N)
ENDIF
CASE (ID_BATCHFILES)
CALL WDIALOGGETINTEGER(IDF_INTEGER9,N)
IF(N.EQ.0)THEN
CALL WDIALOGCLEARFIELD(IDF_GRID1)
IF(ASSOCIATED(PEST%B_FRACTION))DEALLOCATE(PEST%B_FRACTION,PEST%B_BATCHFILE,PEST%B_OUTFILE)
CALL WDIALOGFIELDSTATE(IDF_GRID1,3)
ELSE
M=WINFOGRID(IDF_GRID1,GRIDROWSMAX)
IF(N.GT.M)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You can specify a maximum of '//TRIM(ITOS(M))//' Batchfiles','Error'); N=M
ENDIF
!## resize variables
IF(ASSOCIATED(PEST%B_FRACTION))THEN
M=SIZE(PEST%B_FRACTION)
IF(N.NE.M)THEN
ALLOCATE(PEST%B_FRACTION_BU(N),PEST%B_BATCHFILE_BU(N),PEST%B_OUTFILE_BU(N))
PEST%B_FRACTION_BU=1.0; PEST%B_BATCHFILE_BU=''; PEST%B_OUTFILE_BU=''
DO I=1,MIN(N,M); PEST%B_FRACTION_BU(I) =PEST%B_FRACTION(I); ENDDO
DO I=1,MIN(N,M); PEST%B_BATCHFILE_BU(I)=PEST%B_BATCHFILE(I); ENDDO
DO I=1,MIN(N,M); PEST%B_OUTFILE_BU(I) =PEST%B_OUTFILE(I); ENDDO
DEALLOCATE(PEST%B_FRACTION,PEST%B_BATCHFILE,PEST%B_OUTFILE)
PEST%B_FRACTION=>PEST%B_FRACTION_BU; PEST%B_BATCHFILE=>PEST%B_BATCHFILE_BU; PEST%B_OUTFILE=>PEST%B_OUTFILE_BU
ENDIF
ELSE
ALLOCATE(PEST%B_FRACTION(N),PEST%B_BATCHFILE(N),PEST%B_OUTFILE(N)); PEST%B_FRACTION=1.0; PEST%B_BATCHFILE=''; PEST%B_OUTFILE=''
ENDIF
CALL WDIALOGFIELDSTATE(IDF_GRID1,1)
CALL WGRIDROWS(IDF_GRID1,N)
CALL WGRIDPUTREAL(IDF_GRID1,1,PEST%B_FRACTION,N)
CALL WGRIDPUTSTRING(IDF_GRID1,2,PEST%B_BATCHFILE,N)
CALL WGRIDPUTSTRING(IDF_GRID1,3,PEST%B_OUTFILE,N)
ENDIF
CASE (ID_PARAMETERS)
CALL WDIALOGGETINTEGER(IDF_INTEGER10,N)
IF(N.EQ.0)THEN
CALL WDIALOGCLEARFIELD(IDF_GRID1)
IF(ASSOCIATED(PEST%PARAM))DEALLOCATE(PEST%PARAM)
CALL WDIALOGFIELDSTATE(IDF_GRID1,3)
ELSE
M=WINFOGRID(IDF_GRID1,GRIDROWSMAX)
IF(N.GT.M)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You can specify a maximum of '//TRIM(ITOS(M))//' Parameters','Error'); N=M
ENDIF
!## resize variables
IF(ASSOCIATED(PEST%PARAM))THEN
M=SIZE(PEST%PARAM)
IF(N.NE.M)THEN
ALLOCATE(PEST%PARAM_BU(N)); DO I=1,N; PEST%PARAM_BU(I)%PIGROUP=I; PEST%PARAM_BU(I)%PIZONE=I; ENDDO
DO I=1,MIN(N,M); PEST%PARAM_BU(I) =PEST%PARAM(I); ENDDO
DEALLOCATE(PEST%PARAM)
PEST%PARAM=>PEST%PARAM_BU
ENDIF
ELSE
ALLOCATE(PEST%PARAM(N)); DO I=1,N; PEST%PARAM(I)%PIGROUP=I; PEST%PARAM(I)%PIZONE=I; ENDDO
ENDIF
CALL WDIALOGFIELDSTATE(IDF_GRID1,1)
CALL WGRIDROWS(IDF_GRID1,N)
CALL WGRIDPUTCHECKBOX(IDF_GRID1,1 ,PEST%PARAM%PACT,N)
CALL WGRIDPUTMENU(IDF_GRID1 ,2 ,PARAM,SIZE(PARAM),PEST%PARAM%IPARAM,N)
CALL WGRIDPUTINTEGER(IDF_GRID1 ,3 ,PEST%PARAM%PILS,N)
CALL WGRIDPUTINTEGER(IDF_GRID1 ,4 ,PEST%PARAM%PIZONE,N)
CALL WGRIDPUTINTEGER(IDF_GRID1 ,5 ,PEST%PARAM%PIGROUP,N)
CALL WGRIDPUTREAL(IDF_GRID1 ,6 ,PEST%PARAM%PINI,N)
CALL WGRIDPUTREAL(IDF_GRID1 ,7 ,PEST%PARAM%PMIN,N)
CALL WGRIDPUTREAL(IDF_GRID1 ,8 ,PEST%PARAM%PMAX,N)
CALL WGRIDPUTREAL(IDF_GRID1 ,9 ,PEST%PARAM%PDELTA,N)
CALL WGRIDPUTREAL(IDF_GRID1 ,10,PEST%PARAM%PINCREASE,N)
CALL WGRIDPUTCHECKBOX(IDF_GRID1,11,PEST%PARAM%PLOG,N)
ENDIF
CASE (ID_ZONES)
CALL WDIALOGGETINTEGER(IDF_INTEGER11,N)
IF(N.EQ.0)THEN
CALL WDIALOGCLEARFIELD(IDF_GRID1)
IF(ASSOCIATED(PEST%IDFFILES))DEALLOCATE(PEST%IDFFILES)
CALL WDIALOGFIELDSTATE(IDF_GRID1,3)
ELSE
M=WINFOGRID(IDF_GRID1,GRIDROWSMAX)
IF(N.GT.M)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You can specify a maximum of '//TRIM(ITOS(M))//' Zones','Error'); N=M
ENDIF
!## resize variables
IF(ASSOCIATED(PEST%IDFFILES))THEN
M=SIZE(PEST%IDFFILES)
IF(N.NE.M)THEN
ALLOCATE(PEST%IDFFILES_BU(N))
PEST%IDFFILES_BU=''
DO I=1,MIN(N,M); PEST%IDFFILES_BU(I) =PEST%IDFFILES(I); ENDDO
DEALLOCATE(PEST%IDFFILES)
PEST%IDFFILES=>PEST%IDFFILES_BU
ENDIF
ELSE
ALLOCATE(PEST%IDFFILES(N)); PEST%IDFFILES=''
ENDIF
CALL WDIALOGFIELDSTATE(IDF_GRID1,1)
CALL WGRIDROWS(IDF_GRID1,N)
CALL WGRIDPUTSTRING(IDF_GRID1,1,PEST%IDFFILES,N)
ENDIF
CASE (ID_MEASURES)
CALL WDIALOGGETINTEGER(IDF_INTEGER12,N)
IF(N.EQ.0)THEN
CALL WDIALOGCLEARFIELD(IDF_GRID1)
IF(ASSOCIATED(PEST%MEASURES))DEALLOCATE(PEST%MEASURES)
CALL WDIALOGFIELDSTATE(IDF_GRID1,3)
ELSE
M=WINFOGRID(IDF_GRID1,GRIDROWSMAX)
IF(N.GT.M)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You can specify a maximum of '//TRIM(ITOS(M))//' Measurement','Error'); N=M
ENDIF
!## resize variables
IF(ASSOCIATED(PEST%MEASURES))THEN
M=SIZE(PEST%MEASURES)
IF(N.NE.M)THEN
ALLOCATE(PEST%MEASURES_BU(N)); PEST%MEASURES_BU%IPFNAME=''; PEST%MEASURES_BU%IXCOL=1; PEST%MEASURES_BU%IYCOL=2; PEST%MEASURES_BU%ILCOL=3
PEST%MEASURES_BU%IMCOL=4; PEST%MEASURES_BU%IVCOL=-5; PEST%MEASURES_BU%IPFTYPE=0
DO I=1,MIN(N,M); PEST%MEASURES_BU(I)=PEST%MEASURES(I); ENDDO
DEALLOCATE(PEST%MEASURES); PEST%MEASURES=>PEST%MEASURES_BU
ENDIF
ELSE
ALLOCATE(PEST%MEASURES(N)); PEST%MEASURES%IPFNAME=''; PEST%MEASURES%IXCOL=1; PEST%MEASURES%IYCOL=2; PEST%MEASURES%ILCOL=3
PEST%MEASURES%IMCOL=4; PEST%MEASURES%IVCOL=-5; PEST%MEASURES%IPFTYPE=0
ENDIF
CALL WDIALOGFIELDSTATE(IDF_GRID1,1)
CALL WGRIDROWS(IDF_GRID1,N)
CALL WGRIDPUTSTRING (IDF_GRID1,1,PEST%MEASURES%IPFNAME,N)
! PEST%MEASURES%IPFTYPE=PEST%MEASURES%IPFTYPE-1
CALL WGRIDPUTCHECKBOX(IDF_GRID1,2,PEST%MEASURES%IPFTYPE,N)
CALL WGRIDPUTINTEGER (IDF_GRID1,3,PEST%MEASURES%IXCOL,N)
CALL WGRIDPUTINTEGER (IDF_GRID1,4,PEST%MEASURES%IYCOL,N)
CALL WGRIDPUTINTEGER (IDF_GRID1,5,PEST%MEASURES%ILCOL,N)
CALL WGRIDPUTINTEGER (IDF_GRID1,6,PEST%MEASURES%IMCOL,N)
CALL WGRIDPUTINTEGER (IDF_GRID1,7,PEST%MEASURES%IVCOL,N)
ENDIF
CASE (IDOK,IDCANCEL)
EXIT
END SELECT
END SELECT
ENDDO
SELECT CASE (ID)
CASE (ID_PERIODS)
CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES_TAB1)
IF(ASSOCIATED(PEST%S_PERIOD))THEN
N=SIZE(PEST%S_PERIOD)
CALL WGRIDGETSTRING(IDF_GRID1,1,PEST%S_PERIOD,N)
CALL WGRIDGETSTRING(IDF_GRID1,2,PEST%E_PERIOD,N)
ENDIF
CASE (ID_BATCHFILES)
CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES_TAB2)
IF(ASSOCIATED(PEST%B_FRACTION))THEN
N=SIZE(PEST%B_FRACTION)
CALL WGRIDGETREAL(IDF_GRID1,1,PEST%B_FRACTION,N)
CALL WGRIDGETSTRING(IDF_GRID1,2,PEST%B_BATCHFILE,N)
CALL WGRIDGETSTRING(IDF_GRID1,3,PEST%B_OUTFILE,N)
ENDIF
CASE (ID_PARAMETERS)
CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES_TAB3)
IF(ASSOCIATED(PEST%PARAM))THEN
N=SIZE(PEST%PARAM)
CALL WGRIDGETCHECKBOX(IDF_GRID1,1 ,PEST%PARAM%PACT,N)
CALL WGRIDGETMENU(IDF_GRID1 ,2 ,PEST%PARAM%IPARAM,N)
CALL WGRIDGETINTEGER(IDF_GRID1 ,3 ,PEST%PARAM%PILS,N)
CALL WGRIDGETINTEGER(IDF_GRID1 ,4 ,PEST%PARAM%PIZONE,N)
CALL WGRIDGETINTEGER(IDF_GRID1 ,5 ,PEST%PARAM%PIGROUP,N)
CALL WGRIDGETREAL(IDF_GRID1 ,6 ,PEST%PARAM%PINI,N)
CALL WGRIDGETREAL(IDF_GRID1 ,7 ,PEST%PARAM%PMIN,N)
CALL WGRIDGETREAL(IDF_GRID1 ,8 ,PEST%PARAM%PMAX,N)
CALL WGRIDGETREAL(IDF_GRID1 ,9 ,PEST%PARAM%PDELTA,N)
CALL WGRIDGETREAL(IDF_GRID1 ,10,PEST%PARAM%PINCREASE,N)
CALL WGRIDGETCHECKBOX(IDF_GRID1,11,PEST%PARAM%PLOG,N)
DO I=1,SIZE(PEST%PARAM); PEST%PARAM(I)%PPARAM=PARAM(PEST%PARAM(I)%IPARAM); ENDDO
ENDIF
CASE (ID_ZONES)
CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES_TAB4)
CALL WDIALOGGETINTEGER(IDF_INTEGER11,N)
IF(N.GT.0)CALL WGRIDGETSTRING(IDF_GRID1,1,PEST%IDFFILES,N)
CASE (ID_MEASURES)
CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES_TAB5)
IF(ASSOCIATED(PEST%MEASURES))THEN
N=SIZE(PEST%MEASURES)
CALL WGRIDGETSTRING (IDF_GRID1,1,PEST%MEASURES%IPFNAME,N)
CALL WGRIDGETCHECKBOX(IDF_GRID1,2,PEST%MEASURES%IPFTYPE,N)
PEST%MEASURES%IPFTYPE=PEST%MEASURES%IPFTYPE+1
CALL WGRIDGETINTEGER (IDF_GRID1,3,PEST%MEASURES%IXCOL,N)
CALL WGRIDGETINTEGER (IDF_GRID1,4,PEST%MEASURES%IYCOL,N)
CALL WGRIDGETINTEGER (IDF_GRID1,5,PEST%MEASURES%ILCOL,N)
CALL WGRIDGETINTEGER (IDF_GRID1,6,PEST%MEASURES%IMCOL,N)
CALL WGRIDGETINTEGER (IDF_GRID1,7,PEST%MEASURES%IVCOL,N)
CALL WDIALOGGETCHECKBOX(IDF_CHECK1,PEST%IIPF)
ENDIF
END SELECT
CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES)
CALL WDIALOGUNLOAD(); CALL WDIALOGSELECT(DID)
END SUBROUTINE PMANAGEROPEN_PESTPARAM
!###======================================================================
SUBROUTINE PMANAGERDEFINEPERIODS()
!###======================================================================
IMPLICIT NONE
INTEGER :: ITYPE,I,IOPTION
TYPE(WIN_MESSAGE) :: MESSAGE
CALL WDIALOGLOAD(ID_DPMANAGERDATES,ID_DPMANAGERDATES)
CALL WDIALOGPUTIMAGE(ID_NEW,ID_ICONNEW,1)
CALL WDIALOGPUTIMAGE(ID_DELETE,ID_ICONDELETE,1)
CALL WDIALOGPUTIMAGE(ID_RENAME,ID_ICONRENAME,1)
!## enter artificial year to be able to use generic routine
CALL WDIALOGPUTINTEGER(IDF_INTEGER3,2000)
IF(.NOT.PMANAGERDEFINEPERIODS_INIT())THEN
CALL WDIALOGUNLOAD(); CALL WDIALOGSELECT(ID_DPMANAGEROPEN)
RETURN
ENDIF
!## display dialog
CALL WDIALOGSHOW(-1,-1,0,3)
DO
CALL WMESSAGE(ITYPE,MESSAGE)
SELECT CASE (ITYPE)
CASE(FIELDCHANGED)
!## current field
SELECT CASE (MESSAGE%VALUE2)
CASE (IDF_MENU3)
IF(MESSAGE%VALUE1.EQ.MESSAGE%VALUE2)CALL PMANAGERDEFINEPERIODS_PUT()
CASE (IDF_MENU1)
CALL UTL_FILLDATES(IDF_INTEGER3,IDF_MENU1,IDF_INTEGER1)
END SELECT
CASE(PUSHBUTTON)
SELECT CASE (MESSAGE%VALUE1)
CASE (ID_DELETE)
CALL WDIALOGGETMENU(IDF_MENU3,IOPTION)
CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Are you sure to delete selected'//CHAR(13)// &
'period: ['//TRIM(PERIOD(IOPTION)%NAME)//']','Question')
IF(WINFODIALOG(4).EQ.1)THEN
DO I=IOPTION,SIZE(PERIOD)-1; PERIOD(I)=PERIOD(I+1); ENDDO; NPERIOD=MAX(NPERIOD-1,0)
ENDIF
IF(.NOT.PMANAGERDEFINEPERIODS_INIT())EXIT
CASE (ID_NEW)
CALL WDIALOGSELECT(ID_DPMANAGERDATES); CALL WDIALOGGETMENU(IDF_MENU3,IOPTION)
CALL PMANAGERDEFINEPERIODS_GET(IOPTION)
CALL PMANAGERDEFINEPERIODS_RENAME(0)
CASE (ID_RENAME)
CALL PMANAGERDEFINEPERIODS_RENAME(1)
CASE (IDOK)
CALL WDIALOGSELECT(ID_DPMANAGERDATES); CALL WDIALOGGETMENU(IDF_MENU3,IOPTION)
CALL PMANAGERDEFINEPERIODS_GET(IOPTION); EXIT
CASE (IDCANCEL)
EXIT
CASE (IDHELP)
END SELECT
END SELECT
ENDDO
CALL WDIALOGUNLOAD(); CALL WDIALOGSELECT(ID_DPMANAGEROPEN)
END SUBROUTINE PMANAGERDEFINEPERIODS
!###======================================================================
LOGICAL FUNCTION PMANAGERDEFINEPERIODS_INIT()
!###======================================================================
IMPLICIT NONE
PMANAGERDEFINEPERIODS_INIT=.FALSE.
IF(NPERIOD.EQ.0)THEN
CALL PMANAGERDEFINEPERIODS_RENAME(0)
!## cannot start unless nperiod>0
IF(NPERIOD.EQ.0)THEN
CALL WDIALOGUNLOAD(); CALL WDIALOGSELECT(ID_DPMANAGERDATES); RETURN
ENDIF
ELSE
!## fill in menu
CALL WDIALOGPUTMENU(IDF_MENU3,PERIOD%NAME,NPERIOD,1)
CALL PMANAGERDEFINEPERIODS_PUT()
IF(NPERIOD.GE.SIZE(PERIOD))CALL WDIALOGFIELDSTATE(ID_NEW,0)
ENDIF
PMANAGERDEFINEPERIODS_INIT=.TRUE.
END FUNCTION PMANAGERDEFINEPERIODS_INIT
!###======================================================================
SUBROUTINE PMANAGERDEFINEPERIODS_RENAME(ICODE)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ICODE
INTEGER :: IOPTION,ITYPE,I
TYPE(WIN_MESSAGE) :: MESSAGE
!## define new period
IF(ICODE.EQ.0)THEN
NPERIOD=NPERIOD+1; IOPTION=NPERIOD
PERIOD(IOPTION)%NAME=''
PERIOD(IOPTION)%IMH=4; PERIOD(IOPTION)%IDY=1; PERIOD(IOPTION)%IYR=2014
PERIOD(IOPTION)%IHR=0; PERIOD(IOPTION)%IMT=0; PERIOD(IOPTION)%ISC=0
!## use existing one
ELSE
CALL WDIALOGGETMENU(IDF_MENU3,IOPTION)
ENDIF
CALL WDIALOGLOAD(ID_POLYGONSHAPENAME,ID_POLYGONSHAPENAME)
CALL WDIALOGSHOW(-1,-1,0,3)
CALL WDIALOGPUTSTRING(IDF_LABEL1,'Enter a new name')
IF(IOPTION.EQ.0)CALL WDIALOGPUTSTRING(IDF_STRING1,'...')
IF(IOPTION.GT.0)CALL WDIALOGPUTSTRING(IDF_STRING1,TRIM(PERIOD(IOPTION)%NAME))
DO
CALL WMESSAGE(ITYPE,MESSAGE)
SELECT CASE (ITYPE)
CASE (PUSHBUTTON)
SELECT CASE (MESSAGE%VALUE1)
CASE (IDOK)
CALL WDIALOGGETSTRING(IDF_STRING1,PERIOD(IOPTION)%NAME)
IF(TRIM(PERIOD(IOPTION)%NAME).EQ.'')THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You should specify a name of at least 1 character','Warning')
ELSE
DO I=1,NPERIOD
IF(I.EQ.IOPTION)CYCLE
IF(UTL_CAP(TRIM(PERIOD(I)%NAME),'U').EQ.UTL_CAP(TRIM(PERIOD(IOPTION)%NAME),'U'))THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Given name has defined already.'//CHAR(13)// &
'You should specify an unique name','Warning')
EXIT
ENDIF
ENDDO
IF(I.GT.NPERIOD)EXIT
ENDIF
CASE (IDCANCEL)
EXIT
END SELECT
END SELECT
ENDDO
CALL WDIALOGUNLOAD()
CALL WDIALOGSELECT(ID_DPMANAGERDATES)
IF(MESSAGE%VALUE1.EQ.IDOK)THEN
CALL WDIALOGPUTMENU(IDF_MENU3,PERIOD%NAME,NPERIOD,IOPTION)
CALL PMANAGERDEFINEPERIODS_PUT()
ELSEIF(MESSAGE%VALUE1.EQ.IDCANCEL)THEN
NPERIOD=NPERIOD-1
ENDIF
IF(NPERIOD.GE.SIZE(PERIOD))CALL WDIALOGFIELDSTATE(ID_NEW,0)
END SUBROUTINE PMANAGERDEFINEPERIODS_RENAME
!###======================================================================
SUBROUTINE PMANAGERDEFINEPERIODS_PUT()
!###======================================================================
IMPLICIT NONE
INTEGER :: IOPTION,I
CALL WDIALOGSELECT(ID_DPMANAGERDATES)
CALL WDIALOGGETMENU(IDF_MENU3,IOPTION)
CALL WDIALOGGETINTEGER(IDF_INTEGER4,I)
!## make copy of entered data first, before overwrite it with new one
IF(I.NE.IOPTION)CALL PMANAGERDEFINEPERIODS_GET(I)
CALL WDIALOGPUTINTEGER(IDF_INTEGER4,IOPTION)
CALL WDIALOGPUTMENU(IDF_MENU1,CDATE,12,PERIOD(IOPTION)%IMH)
CALL WDIALOGPUTINTEGER(IDF_INTEGER1 ,PERIOD(IOPTION)%IDY)
CALL WDIALOGPUTINTEGER(IDF_INTEGER3 ,PERIOD(IOPTION)%IYR)
CALL WDIALOGPUTINTEGER(IDF_INTEGER6 ,PERIOD(IOPTION)%IHR)
CALL WDIALOGPUTINTEGER(IDF_INTEGER7 ,PERIOD(IOPTION)%IMT)
CALL WDIALOGPUTINTEGER(IDF_INTEGER8 ,PERIOD(IOPTION)%ISC)
CALL UTL_FILLDATES(IDF_INTEGER3,IDF_MENU1,IDF_INTEGER1)
END SUBROUTINE PMANAGERDEFINEPERIODS_PUT
!###======================================================================
SUBROUTINE PMANAGERDEFINEPERIODS_GET(IOPTION)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IOPTION
IF(IOPTION.GT.0)THEN
CALL WDIALOGGETMENU(IDF_MENU1 ,PERIOD(IOPTION)%IMH)
CALL WDIALOGGETINTEGER(IDF_INTEGER1 ,PERIOD(IOPTION)%IDY)
CALL WDIALOGGETINTEGER(IDF_INTEGER3 ,PERIOD(IOPTION)%IYR)
CALL WDIALOGGETINTEGER(IDF_INTEGER6 ,PERIOD(IOPTION)%IHR)
CALL WDIALOGGETINTEGER(IDF_INTEGER7 ,PERIOD(IOPTION)%IMT)
CALL WDIALOGGETINTEGER(IDF_INTEGER8 ,PERIOD(IOPTION)%ISC)
ENDIF
END SUBROUTINE PMANAGERDEFINEPERIODS_GET
!###======================================================================
LOGICAL FUNCTION PMANAGER_GETSELECTED(ID,ITOPIC,IPER,ISYS,ISUBTOPIC,IERROR)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ID,IERROR
INTEGER,INTENT(OUT) :: ITOPIC,IPER,ISYS,ISUBTOPIC
INTEGER :: NSYS
PMANAGER_GETSELECTED=.FALSE.
!## check what topic has been selected
TOPICLOOP: DO ITOPIC=1,MAXTOPICS
IPER=0; ISYS=0; ISUBTOPIC=0; IF(ID.EQ.TOPICS(ITOPIC)%ID)EXIT TOPICLOOP
NPER=0; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))NPER=SIZE(TOPICS(ITOPIC)%STRESS)
DO IPER=1,NPER
ISYS=0; ISUBTOPIC=0
IF(ID.EQ.TOPICS(ITOPIC)%IDT(IPER))EXIT TOPICLOOP
NSYS=0; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(IPER)%FILES))NSYS=SIZE(TOPICS(ITOPIC)%STRESS(IPER)%FILES,2)
!## read for each subtopic
DO ISUBTOPIC=1,TOPICS(ITOPIC)%NSUBTOPICS
ISYS=0
IF(ID.EQ.TOPICS(ITOPIC)%ISD(IPER,ISUBTOPIC))THEN
IF(IERROR.EQ.1)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You should select a MAIN TOPIC, a DATE or an individual FILENAME.','Warning')
RETURN
ELSE
EXIT TOPICLOOP
ENDIF
ENDIF
!## read for each system
DO ISYS=1,NSYS
IF(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ID.EQ.ID)EXIT TOPICLOOP
ENDDO
ENDDO
ENDDO
ENDDO TOPICLOOP
IF(ITOPIC.GT.MAXTOPICS)THEN
ITOPIC=0
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You should select a MAIN TOPIC at least','Warning')
RETURN
ENDIF
!## ITOPIC =TOPIC NUMBER (E.G. SHD, BND, WEL)
!## IPER =STRESSPERIOD
!## ISYS =SYSTEM NUMBER
PMANAGER_GETSELECTED=.TRUE.
END FUNCTION PMANAGER_GETSELECTED
!###======================================================================
SUBROUTINE PMANAGER_STRESSES(ITOPIC,IPER)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ITOPIC
INTEGER,INTENT(INOUT) :: IPER
INTEGER :: N,I,J,K
IF(IPER.GT.0)RETURN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
!## only increase for timedependent information
IF(TOPICS(ITOPIC)%TIMDEP)THEN
!## make copy of current memory
N=SIZE(TOPICS(ITOPIC)%STRESS)
NULLIFY(TOPICS(ITOPIC)%STRESS_TMP)
ALLOCATE(TOPICS(ITOPIC)%STRESS_TMP(N+1))
DO I=1,N
J=SIZE(TOPICS(ITOPIC)%STRESS(I)%FILES,1)
K=SIZE(TOPICS(ITOPIC)%STRESS(I)%FILES,2)
NULLIFY(TOPICS(ITOPIC)%STRESS_TMP(I)%FILES)
NULLIFY(TOPICS(ITOPIC)%STRESS_TMP(I)%INPFILES)
ALLOCATE(TOPICS(ITOPIC)%STRESS_TMP(I)%FILES(J,K))
TOPICS(ITOPIC)%STRESS_TMP(I)%FILES=TOPICS(ITOPIC)%STRESS(I)%FILES
TOPICS(ITOPIC)%STRESS_TMP(I)%CDATE=TOPICS(ITOPIC)%STRESS(I)%CDATE
TOPICS(ITOPIC)%STRESS_TMP(I)%IYR=TOPICS(ITOPIC)%STRESS(I)%IYR
TOPICS(ITOPIC)%STRESS_TMP(I)%IMH=TOPICS(ITOPIC)%STRESS(I)%IMH
TOPICS(ITOPIC)%STRESS_TMP(I)%IDY=TOPICS(ITOPIC)%STRESS(I)%IDY
TOPICS(ITOPIC)%STRESS_TMP(I)%IHR=TOPICS(ITOPIC)%STRESS(I)%IHR
TOPICS(ITOPIC)%STRESS_TMP(I)%IMT=TOPICS(ITOPIC)%STRESS(I)%IMT
TOPICS(ITOPIC)%STRESS_TMP(I)%ISC=TOPICS(ITOPIC)%STRESS(I)%ISC
DEALLOCATE(TOPICS(ITOPIC)%STRESS(I)%FILES)
ENDDO
TOPICS(ITOPIC)%STRESS=>TOPICS(ITOPIC)%STRESS_TMP
IPER=N+1
ELSE
IPER=1
ENDIF
ELSE
ALLOCATE(TOPICS(ITOPIC)%STRESS(1))
NULLIFY(TOPICS(ITOPIC)%STRESS(1)%FILES)
TOPICS(ITOPIC)%IACT =1
TOPICS(ITOPIC)%IACT_MODEL=1
IPER=1
ENDIF
END SUBROUTINE PMANAGER_STRESSES
!###======================================================================
SUBROUTINE PMANAGER_SYSTEMS(ITOPIC,IPER,ISYS)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ITOPIC,IPER
INTEGER,INTENT(INOUT) :: ISYS
INTEGER :: N,M
!## create new system
IF(ISYS.GT.0)RETURN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(IPER)%FILES))THEN
!## make copy of current memory
M=SIZE(TOPICS(ITOPIC)%STRESS(IPER)%FILES,1)
N=SIZE(TOPICS(ITOPIC)%STRESS(IPER)%FILES,2)
NULLIFY(TOPICS(ITOPIC)%STRESS(IPER)%FILES_TMP)
ALLOCATE(TOPICS(ITOPIC)%STRESS(IPER)%FILES_TMP(M,N+1))
TOPICS(ITOPIC)%STRESS(IPER)%FILES_TMP(1:M,1:N)=TOPICS(ITOPIC)%STRESS(IPER)%FILES(1:M,1:N)
DEALLOCATE(TOPICS(ITOPIC)%STRESS(IPER)%FILES)
TOPICS(ITOPIC)%STRESS(IPER)%FILES=>TOPICS(ITOPIC)%STRESS(IPER)%FILES_TMP
ISYS=N+1
ELSE
N=TOPICS(ITOPIC)%NSUBTOPICS
ALLOCATE(TOPICS(ITOPIC)%STRESS(IPER)%FILES(N,1))
ISYS=1
ENDIF
END SUBROUTINE PMANAGER_SYSTEMS
!###======================================================================
SUBROUTINE PMANAGERPUTFIELDS(IST,ICF,EXT)
!###======================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(OUT) :: EXT
INTEGER,INTENT(OUT) :: IST,ICF
!## get subitem
CALL WDIALOGGETMENU(IDF_MENU1,IST)
ICF=0; IF(INDEX(UTL_CAP(MENUNAMES(IST),'U'),'(IDF)').GT.0)ICF=1
IF(INDEX(UTL_CAP(MENUNAMES(IST),'U'),'(IDF)').GT.0)EXT='IDF'
IF(INDEX(UTL_CAP(MENUNAMES(IST),'U'),'(IPF)').GT.0)EXT='IPF'
IF(INDEX(UTL_CAP(MENUNAMES(IST),'U'),'(ISG)').GT.0)EXT='ISG'
IF(INDEX(UTL_CAP(MENUNAMES(IST),'U'),'(GEN)').GT.0)EXT='GEN'
CALL WDIALOGPUTREAL(IDF_REAL1,PRJ(IST)%FCT,'(G12.5)')
CALL WDIALOGPUTREAL(IDF_REAL2,PRJ(IST)%IMP,'(G12.5)')
CALL WDIALOGPUTREAL(IDF_REAL3,PRJ(IST)%CNST,'(G12.5)')
!## for ipf,isg,gen not constant values allowed
IF(ICF.EQ.0)PRJ(IST)%ICNST=2
IF(PRJ(IST)%ICNST.EQ.1)THEN
CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO1)
CALL WDIALOGPUTSTRING(IDF_STRING1,'')
ELSEIF(PRJ(IST)%ICNST.EQ.2)THEN
CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO2)
CALL WDIALOGPUTSTRING(IDF_STRING1,TRIM(PRJ(IST)%FNAME))
ENDIF
END SUBROUTINE PMANAGERPUTFIELDS
!###======================================================================
SUBROUTINE PMANAGERGETFIELDS(IST)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IST
CALL WDIALOGGETREAL(IDF_REAL1,PRJ(IST)%FCT)
CALL WDIALOGGETREAL(IDF_REAL2,PRJ(IST)%IMP)
CALL WDIALOGGETCHECKBOX(IDF_CHECK2,PRJ(IST)%ICNST)
!## inherent
IF(PRJ(IST)%ICNST.EQ.1)THEN
PRJ(IST)%ICNST=0
ELSE
CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,PRJ(IST)%ICNST)
ENDIF
CALL WDIALOGGETREAL(IDF_REAL3,PRJ(IST)%CNST)
IF(PRJ(IST)%ICNST.EQ.2)CALL WDIALOGGETSTRING(IDF_STRING1,PRJ(IST)%FNAME)
END SUBROUTINE PMANAGERGETFIELDS
!###======================================================================
SUBROUTINE PMANAGEROPENFIELDS(LEX,LNEW,ICF)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ICF
LOGICAL,INTENT(IN) :: LEX,LNEW
INTEGER :: II,I,J,K,L
CALL WDIALOGGETCHECKBOX(IDF_CHECK1,II)
IF(II.EQ.1)THEN
CALL WDIALOGPUTSTRING(IDF_CHECK1,'Package is ACTIVE for coming simulations, deselect to Deactivate Parameter; ')
CALL WDIALOGCOLOUR(IDF_CHECK1,WRGB(0,0,0),WRGB(0,255,0))
ELSE
CALL WDIALOGPUTSTRING(IDF_CHECK1,'Package is INACTIVE for coming simulations, select to Activate Parameter; .')
CALL WDIALOGCOLOUR(IDF_CHECK1,WRGB(255,255,255),WRGB(255,0,0))
ENDIF
CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,I)
SELECT CASE (I)
!## constant
CASE (1); J=0; L=1
!## idf
CASE (2); J=1; L=0
END SELECT
CALL WDIALOGGETCHECKBOX(IDF_CHECK2,II); II=ABS(II-1)
J=J*II; L=L*II
CALL WDIALOGFIELDSTATE(IDF_REAL1,II)
CALL WDIALOGFIELDSTATE(IDF_REAL2,II)
CALL WDIALOGFIELDSTATE(IDF_LABEL2,II)
CALL WDIALOGFIELDSTATE(IDF_LABEL3,II)
CALL WDIALOGFIELDSTATE(IDF_RADIO1,II*ICF)
CALL WDIALOGFIELDSTATE(IDF_RADIO2,II)
CALL WDIALOGFIELDSTATE(IDF_REAL3,L)
CALL WDIALOGFIELDSTATE(IDF_STRING1,J)
CALL WDIALOGFIELDSTATE(ID_OPEN,J)
!## new definition
IF(LEX)THEN
CALL WDIALOGGETRADIOBUTTON(IDF_RADIO3,I)
SELECT CASE (I)
CASE (1)
J=0; K=0; L=0
CASE (2)
J=1; K=0; L=0; IF(.NOT.LNEW)J=2
CASE (3)
J=0; K=1; L=1; IF(.NOT.LNEW)L=2
IF(NPERIOD.EQ.0)L=0
END SELECT
CALL WDIALOGFIELDSTATE(IDF_MENU2,J)
CALL WDIALOGFIELDSTATE(IDF_INTEGER2,J)
CALL WDIALOGFIELDSTATE(IDF_INTEGER3,J)
CALL WDIALOGFIELDSTATE(IDF_INTEGER4,J)
CALL WDIALOGFIELDSTATE(IDF_INTEGER5,J)
CALL WDIALOGFIELDSTATE(IDF_INTEGER6,J)
CALL WDIALOGFIELDSTATE(IDF_MENU3,L)
CALL WDIALOGFIELDSTATE(ID_PROPERTIES,K)
ENDIF
END SUBROUTINE PMANAGEROPENFIELDS
!###======================================================================
SUBROUTINE PMANAGERDRAW_PLUS()
!###======================================================================
IMPLICIT NONE
INTEGER :: ITYPE,IOPTION
TYPE(WIN_MESSAGE) :: MESSAGE
INTEGER :: I,IL1,IL2,IPLOT,NFILES
CALL PMANAGER_GETNFILES((/2,3,4,5,6,7,8,9,10,11,12/),MXNLAY)
IF(MXNLAY.EQ.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'There are no layers available.','Warning')
RETURN
ENDIF
CALL WDIALOGLOAD(ID_DPMANAGER_SPECIALOPEN,ID_DPMANAGER_SPECIALOPEN)
CALL WDIALOGPUTINTEGER(IDF_INTEGER1,1)
CALL WDIALOGRANGEINTEGER(IDF_INTEGER1,1,MXNLAY)
CALL WDIALOGPUTINTEGER(IDF_INTEGER2,MXNLAY)
CALL WDIALOGRANGEINTEGER(IDF_INTEGER2,1,MXNLAY)
CALL WDIALOGSHOW(-1,-1,0,3)
DO
CALL WMESSAGE(ITYPE,MESSAGE)
SELECT CASE (ITYPE)
CASE (PUSHBUTTON)
SELECT CASE (MESSAGE%VALUE1)
CASE (IDCANCEL)
EXIT
CASE (IDHELP)
CASE (IDOK)
CALL WDIALOGGETMENU(IDF_MENU1,IOPTION)
CALL WDIALOGGETINTEGER(IDF_INTEGER1,IL1)
CALL WDIALOGGETINTEGER(IDF_INTEGER2,IL2)
EXIT
END SELECT
END SELECT
ENDDO
CALL WDIALOGUNLOAD
IF(MESSAGE%VALUE1.EQ.IDCANCEL)RETURN
NLAY=IL2-IL1+1
!## create list of filenames
SELECT CASE (IOPTION)
!## TOP1 - BOT1 - TOP2 - ...
CASE (1)
ALLOCATE(FNAMES(NLAY*2),ILIST(2))
ILIST(1)=2; ILIST(2)=3
!## TOP1 - KDW1 - BOT1 - TOP2 - KDW2 - BOT2 ...
CASE (2)
ALLOCATE(FNAMES(NLAY*3),ILIST(3))
ILIST(1)=2; ILIST(2)=6; ILIST(3)=3
!## TOP1 - KDW1 - BOT1 - VCW1 - TOP2 - KDW1- BOT2 - VCW2 - TOP3 ...
CASE (3)
ALLOCATE(FNAMES(NLAY*4-1),ILIST(4))
ILIST(1)=2; ILIST(2)=6; ILIST(3)=3; ILIST(4)=9
!## TOP1 - BOT1 - VCW1 - TOP2 - BOT2 - VCW2 - TOP3 ...
CASE(4)
ALLOCATE(FNAMES(NLAY*3-1),ILIST(3))
ILIST(1)=2; ILIST(2)=3; ILIST(3)=9
!## TOP1 - SHD1 - BOT1 - TOP2 - SHD2 - BOT2 ...
CASE (5)
ALLOCATE(FNAMES(NLAY*3),ILIST(3))
ILIST(1)=2; ILIST(2)=5; ILIST(3)=3
!## TOP1 - KHV1 - BOT1 - TOP2 - KHV2 - BOT2 ...
CASE (6)
ALLOCATE(FNAMES(NLAY*3),ILIST(3))
ILIST(1)=2; ILIST(2)=7; ILIST(3)=3
!## TOP1 - BOT1 - KVV1 - TOP2 - BOT2 - KVV2 - TOP3 ...
CASE(7)
ALLOCATE(FNAMES(NLAY*3-1),ILIST(3))
ILIST(1)=2; ILIST(2)=3; ILIST(3)=10
!## TOP1 - KHV1 - BOT1 - KVV1 - TOP2 - KHV2 - BOT2 - KVV2 - TOP3 ...
CASE (8)
ALLOCATE(FNAMES(NLAY*4-1),ILIST(4))
ILIST(1)=2; ILIST(2)=7; ILIST(3)=3; ILIST(4)=10
END SELECT
!## get appropriate number of files - no matter what system or type, for first "stress-period"
NFILES=PMANAGER_GETFNAMES(IL1,IL2,0,0,1)
!## nothing found
IF(NFILES.GT.0)THEN
!## select files in the imod manager
MP%ISEL=.FALSE.
DO I=1,NFILES
DO IPLOT=1,SIZE(MP)
IF(TRIM(UTL_CAP(MP(IPLOT)%IDFNAME,'U')).EQ.TRIM(UTL_CAP(FNAMES(I)%FNAME,'U')))MP(IPLOT)%ISEL=.TRUE.
ENDDO
END DO
!## delete them all from manager
CALL MANAGERDELETE(IQ=0)
DO I=1,NFILES; CALL IDFINIT(FNAMES(I)%FNAME,LPLOT=.FALSE.,LDEACTIVATE=.FALSE.); ENDDO
ENDIF
DEALLOCATE(FNAMES,ILIST)
END SUBROUTINE PMANAGERDRAW_PLUS
!###======================================================================
INTEGER FUNCTION PMANAGER_GETFNAMES(IL1,IL2,JSYS,JSUB,JPER)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IL1,IL2,JSYS,JSUB,JPER
INTEGER :: KK,I,J,JJ,ISYS,ISUB,IPER,IL
LOGICAL :: LEX
PMANAGER_GETFNAMES=0
KK=0
!## find fnames for model layers
DO IL=IL1,IL2
!## find topics
DO J=1,SIZE(ILIST)
JJ=ILIST(J)
!## skip last - if that is vcw/kvv
IF(IL1.NE.IL2.AND.IL.EQ.IL2)THEN
IF(JJ.EQ.9.OR.JJ.EQ.10)CYCLE
ENDIF
IF(.NOT.ASSOCIATED(TOPICS(JJ)%STRESS))CYCLE
DO IPER=1,SIZE(TOPICS(JJ)%STRESS)
!## not appropriate system
IF(IPER.NE.JPER.AND.JPER.NE.0)CYCLE
IF(.NOT.ASSOCIATED(TOPICS(JJ)%STRESS(IPER)%FILES))CYCLE
!## number of subtopics
DO ISUB=1,SIZE(TOPICS(JJ)%STRESS(IPER)%FILES,1)
!## not appropriate system
IF(ISUB.NE.JSUB.AND.JSUB.NE.0)CYCLE
!## number of systems
DO ISYS=1,SIZE(TOPICS(JJ)%STRESS(IPER)%FILES,2)
!## not appropriate system
IF(ISYS.NE.JSYS.AND.JSYS.NE.0)CYCLE
!## not appropriate layer
IF(IL.NE.0)THEN
IF(TOPICS(JJ)%STRESS(IPER)%FILES(ISUB,ISYS)%ILAY.NE.IL)CYCLE
ENDIF
KK=KK+1; CALL PMAMAGER_INCREASEFNAMES(KK)
FNAMES(KK)%ILAY =TOPICS(JJ)%STRESS(IPER)%FILES(ISUB,ISYS)%ILAY
FNAMES(KK)%ICNST=TOPICS(JJ)%STRESS(IPER)%FILES(ISUB,ISYS)%ICNST
FNAMES(KK)%CNST =TOPICS(JJ)%STRESS(IPER)%FILES(ISUB,ISYS)%CNST
FNAMES(KK)%FCT =TOPICS(JJ)%STRESS(IPER)%FILES(ISUB,ISYS)%FCT
FNAMES(KK)%IMP =TOPICS(JJ)%STRESS(IPER)%FILES(ISUB,ISYS)%IMP
FNAMES(KK)%FNAME=TOPICS(JJ)%STRESS(IPER)%FILES(ISUB,ISYS)%FNAME
!## read only the first appropriate file
EXIT
ENDDO
ENDDO
ENDDO
ENDDO
ENDDO
!## actual found files
PMANAGER_GETFNAMES=KK
LINE=TOPICS(ILIST(1))%TNAME(1:5)
DO J=2,SIZE(ILIST); LINE=TRIM(LINE)//','//TOPICS(ILIST(J))%TNAME(1:5); ENDDO
IF(PMANAGER_GETFNAMES.EQ.0)CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'No files found for package(s):'//CHAR(13)//TRIM(LINE),'Warning')
!## check whether file(s) exist
DO I=1,KK
!## filename read
IF(FNAMES(I)%ICNST.GT.1)THEN
INQUIRE(FILE=FNAMES(I)%FNAME,EXIST=LEX)
IF(.NOT.LEX)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMOD cannot find the following file:'//CHAR(13)// &
TRIM(FNAMES(I)%FNAME),'Warning'); PMANAGER_GETFNAMES=0
ENDIF
ENDIF
ENDDO
END FUNCTION PMANAGER_GETFNAMES
!###======================================================================
SUBROUTINE PMAMAGER_INCREASEFNAMES(K)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: K
INTEGER :: I,N
IF(.NOT.ASSOCIATED(FNAMES))THEN; ALLOCATE(FNAMES(1)); RETURN; ENDIF
N=SIZE(FNAMES); IF(K.LE.N)RETURN
ALLOCATE(FNAMES_BU(N+10)); DO I=1,N; FNAMES_BU(I)=FNAMES(I); ENDDO
DEALLOCATE(FNAMES); FNAMES=>FNAMES_BU
END SUBROUTINE PMAMAGER_INCREASEFNAMES
!###======================================================================
SUBROUTINE PMANAGERDRAW()
!###======================================================================
IMPLICIT NONE
INTEGER :: IPER,ITOPIC,ISYS,ID,ISUBTOPIC
CHARACTER(LEN=256) :: CNAME
CALL WDIALOGSELECT(ID_DPMANAGER); CALL WDIALOGGETTREEVIEW(ID_TREEVIEW1,ID,CNAME)
!## get the right topics, attributes from the tree-view
IF(.NOT.PMANAGER_GETSELECTED(ID,ITOPIC,IPER,ISYS,ISUBTOPIC,0))RETURN
!## major topic selected, draw everything
IF(IPER.EQ.0.AND.ISYS.EQ.0.AND.ISUBTOPIC.EQ.0)THEN
NPER=0; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))NPER=SIZE(TOPICS(ITOPIC)%STRESS)
DO IPER=1,NPER
DO ISYS=1,SIZE(TOPICS(ITOPIC)%STRESS(1)%FILES,2)
DO ISUBTOPIC=1,TOPICS(ITOPIC)%NSUBTOPICS
!## idf file
IF(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ICNST.EQ.2)THEN
CALL IDFINIT(IDFNAMEGIVEN=TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME,LPLOT=.TRUE.)
ENDIF
ENDDO
ENDDO
ENDDO
ELSEIF(IPER.GT.0.AND.ISYS.EQ.0.AND.ISUBTOPIC.EQ.0)THEN
DO ISYS=1,SIZE(TOPICS(ITOPIC)%STRESS(IPER)%FILES,2)
DO ISUBTOPIC=1,TOPICS(ITOPIC)%NSUBTOPICS
!## idf file
IF(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ICNST.EQ.2)THEN
CALL IDFINIT(IDFNAMEGIVEN=TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME,LPLOT=.TRUE.)
ENDIF
ENDDO
ENDDO
ELSEIF(IPER.GT.0.AND.ISYS.GT.0.AND.ISUBTOPIC.EQ.0)THEN
DO ISUBTOPIC=1,TOPICS(ITOPIC)%NSUBTOPICS
!## idf file
IF(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ICNST.EQ.2)THEN
CALL IDFINIT(IDFNAMEGIVEN=TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME,LPLOT=.TRUE.)
ENDIF
ENDDO
ELSEIF(IPER.GT.0.AND.ISYS.EQ.0.AND.ISUBTOPIC.GT.0)THEN
DO ISYS=1,SIZE(TOPICS(ITOPIC)%STRESS(IPER)%FILES,2)
!## idf file
IF(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ICNST.EQ.2)THEN
CALL IDFINIT(IDFNAMEGIVEN=TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME,LPLOT=.TRUE.)
ENDIF
ENDDO
ELSE
CALL IDFINIT(IDFNAMEGIVEN=TOPICS(ITOPIC)%STRESS(1)%FILES(ISUBTOPIC,ISYS)%FNAME,LPLOT=.TRUE.)
ENDIF
END SUBROUTINE PMANAGERDRAW
!###======================================================================
LOGICAL FUNCTION PMANAGERPRJ(ID,RUNFNAME,IBATCH)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ID,IBATCH
CHARACTER(LEN=*),INTENT(IN) :: RUNFNAME
CHARACTER(LEN=256) :: FNAME
PMANAGERPRJ=.FALSE.
IF(ID.EQ.ID_OPEN)THEN
IF(RUNFNAME.EQ.'')THEN
FNAME=''
IF(.NOT.UTL_WSELECTFILE('iMOD Project File (*.prj)|*.prj|', &
LOADDIALOG+MUSTEXIST+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,&
'Load iMOD Project File'))RETURN
ELSE
FNAME=RUNFNAME
ENDIF
IF(.NOT.PMANAGER_LOADPRJ(FNAME))THEN
IF(IBATCH.EQ.0)CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMOD cannot read in the Project File','Error')
ELSE
IF(IBATCH.EQ.0)CALL PMANAGERUPDATE(0,0,0); PMANAGERPRJ=.TRUE.
ENDIF
ELSEIF(ID.EQ.ID_SAVE)THEN
IF(RUNFNAME.EQ.'')THEN
FNAME=''
IF(.NOT.UTL_WSELECTFILE('iMOD Project Files (*.prj)|*.prj|', &
SAVEDIALOG+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,'Save iMOD Project File'))RETURN
ELSE
FNAME=RUNFNAME
ENDIF
IF(PMANAGER_SAVEPRJ(FNAME))THEN
IF(IBATCH.EQ.0)CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'Successfully written project file:'//CHAR(13)//TRIM(FNAME),'Information')
IF(IBATCH.EQ.1)WRITE(*,'(/A/)') 'Successfully written project file:'//TRIM(FNAME)
PMANAGERPRJ=.TRUE.
ENDIF
ENDIF
END FUNCTION PMANAGERPRJ
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEPRJ(FNAME)
!###======================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: FNAME
INTEGER :: IU,I,J,K,L
PMANAGER_SAVEPRJ=.FALSE.
IU=UTL_GETUNIT()
CALL OSD_OPEN(IU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE,DENYREAD',FORM='FORMATTED')
!## write modules
DO I=1,MAXTOPICS
IF(.NOT.ASSOCIATED(TOPICS(I)%STRESS))CYCLE
!## pst module is exception
IF(I.EQ.20)THEN
WRITE(IU,'(/I4.4,A,I1,A)') SIZE(PEST%PARAM),','//TOPICS(I)%TNAME(1:5)//',',TOPICS(I)%IACT_MODEL,','//TRIM(TOPICS(I)%TNAME(6:))//' []'
IF(.NOT.PMANAGER_SAVEPST(IU,0,'',0))RETURN
CYCLE
!## pcg module another exception
ELSEIF(I.EQ.33)THEN
WRITE(IU,'(/I4.4,A,I1,A)') 1,','//TOPICS(I)%TNAME(1:5)//',',TOPICS(I)%IACT_MODEL,','//TRIM(TOPICS(I)%TNAME(6:))//' []'
CALL PMANAGER_SAVEPCG(IU,0)
CYCLE
ENDIF
WRITE(LINE,'(I4.4,A,I1,A)') SIZE(TOPICS(I)%STRESS),','//TOPICS(I)%TNAME(1:5)//',',TOPICS(I)%IACT_MODEL,','//TRIM(TOPICS(I)%TNAME(6:))
LINE=TRIM(LINE)//',['//TOPICS(I)%SNAME(1)(2:4)
DO L=2,(TOPICS(I)%NSUBTOPICS)
LINE=TRIM(LINE)//','//TOPICS(I)%SNAME(L)(2:4)
ENDDO
LINE=TRIM(LINE)//']'
WRITE(IU,'(/A)') TRIM(LINE)
DO L=1,SIZE(TOPICS(I)%STRESS)
IF(.NOT.ASSOCIATED(TOPICS(I)%STRESS(L)%FILES))CYCLE
IF(TOPICS(I)%TIMDEP)THEN
IF(TOPICS(I)%STRESS(L)%IYR+TOPICS(I)%STRESS(L)%IMH+TOPICS(I)%STRESS(L)%IDY+ &
TOPICS(I)%STRESS(L)%IHR+TOPICS(I)%STRESS(L)%IMT+TOPICS(I)%STRESS(L)%ISC.GT.0)THEN
WRITE(IU,'(I4.4,5(A1,I2.2))') TOPICS(I)%STRESS(L)%IYR,'-',TOPICS(I)%STRESS(L)%IMH,'-',TOPICS(I)%STRESS(L)%IDY,' ', &
TOPICS(I)%STRESS(L)%IHR,':',TOPICS(I)%STRESS(L)%IMT,':',TOPICS(I)%STRESS(L)%ISC
ELSE
WRITE(IU,'(A)') TRIM(TOPICS(I)%STRESS(L)%CDATE)
ENDIF
ENDIF
WRITE(IU,'(2(I3.3,A1))') SIZE(TOPICS(I)%STRESS(L)%FILES,1),',',SIZE(TOPICS(I)%STRESS(L)%FILES,2)
DO K=1,SIZE(TOPICS(I)%STRESS(L)%FILES,1) !## systems(.)
DO J=1,SIZE(TOPICS(I)%STRESS(L)%FILES,2) !## subtopics(.)
WRITE(IU,'(1X,2(I1,A1),I4.3,3(A1,G15.7),A1,A)') &
TOPICS(I)%STRESS(L)%FILES(K,J)%IACT ,',', &
TOPICS(I)%STRESS(L)%FILES(K,J)%ICNST,',', &
TOPICS(I)%STRESS(L)%FILES(K,J)%ILAY ,',', &
TOPICS(I)%STRESS(L)%FILES(K,J)%FCT ,',', &
TOPICS(I)%STRESS(L)%FILES(K,J)%IMP ,',', &
TOPICS(I)%STRESS(L)%FILES(K,J)%CNST ,',', &
CHAR(39)//TRIM(TOPICS(I)%STRESS(L)%FILES(K,J)%FNAME)//CHAR(39)
ENDDO
ENDDO
!## write extra files only for MetaSWAP
IF(I.EQ.1)THEN
IF(ASSOCIATED(TOPICS(I)%STRESS(L)%INPFILES))THEN
K=SIZE(TOPICS(I)%STRESS(L)%INPFILES)
WRITE(IU,'(I3.3,A)') K,',EXTRA FILES'
DO J=1,K; WRITE(IU,'(A)') TRIM(TOPICS(I)%STRESS(L)%INPFILES(J)); ENDDO
ENDIF
ENDIF
ENDDO
ENDDO
WRITE(IU,'(/A)') 'Periods'
DO I=1,NPERIOD
WRITE(IU,'(A)') '"'//TRIM(PERIOD(I)%NAME)//'"'
WRITE(IU,'(2(I2.2,A1),I4.4,3(A1,I2.2))') PERIOD(I)%IDY,'-',PERIOD(I)%IMH,'-',PERIOD(I)%IYR,' ', &
PERIOD(I)%IHR,':',PERIOD(I)%IMT,':',PERIOD(I)%ISC
ENDDO
CLOSE(IU)
PMANAGER_SAVEPRJ=.TRUE.
END FUNCTION PMANAGER_SAVEPRJ
!###======================================================================
LOGICAL FUNCTION PMANAGER_LOADPRJ(FNAME)
!###======================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: FNAME
INTEGER :: IU,I,J,K,IOS,NC,L,NSYS,IACT
CHARACTER(LEN=MAXLEN) :: CTOPIC
PMANAGER_LOADPRJ=.FALSE.
DO I=1,SIZE(TOPICS); CALL PMANAGER_DEALLOCATE(I); ENDDO; CALL PMANAGER_DEALLOCATE_PEST()
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=FNAME,STATUS='OLD',ACTION='READ,DENYWRITE',FORM='FORMATTED')
!## read modules
DO
DO
READ(IU,'(A512)',IOSTAT=IOS) LINE; IF(IOS.NE.0)EXIT
!## check keyword
IF(TRIM(LINE).NE.'')THEN
!## periods defined - stop searching for modules/packages
IF(TRIM(UTL_CAP(LINE,'U')).EQ.'PERIODS')EXIT
READ(LINE,*,IOSTAT=IOS) NPER,CTOPIC,IACT
IF(IOS.NE.0)THEN; IACT=1; READ(LINE,*,IOSTAT=IOS) NPER,CTOPIC; ENDIF
IF(IOS.EQ.0)THEN
!## skip empty packages
IF(NPER.LE.0)CYCLE
I=PMANAGER_FIND_KEYWORD(CTOPIC); IF(I.GT.0)EXIT
ENDIF
ENDIF
ENDDO
IF(IOS.NE.0)EXIT
!## periods defined - stop searching for modules/packages
IF(TRIM(UTL_CAP(LINE,'U')).EQ.'PERIODS')EXIT
!## pst module is exception
IF(I.EQ.20)THEN
CALL PMANAGER_LOADPST(IU,NPER,0)
TOPICS(I)%IACT_MODEL=IACT; ALLOCATE(TOPICS(I)%STRESS(1)); ALLOCATE(TOPICS(I)%STRESS(1)%FILES(1,1))
CYCLE
ELSEIF(I.EQ.33)THEN
CALL PMANAGER_LOADPCG(IU,0)
TOPICS(I)%IACT_MODEL=IACT; ALLOCATE(TOPICS(I)%STRESS(1)); ALLOCATE(TOPICS(I)%STRESS(1)%FILES(1,1))
CYCLE
ENDIF
ALLOCATE(TOPICS(I)%STRESS(NPER)); TOPICS(I)%IACT_MODEL=IACT
DO L=1,NPER
IF(TOPICS(I)%TIMDEP)THEN
READ(IU,'(A512)') LINE
READ(LINE,'(I4,5(1X,I2))',IOSTAT=IOS) TOPICS(I)%STRESS(L)%IYR,TOPICS(I)%STRESS(L)%IMH,TOPICS(I)%STRESS(L)%IDY, &
TOPICS(I)%STRESS(L)%IHR,TOPICS(I)%STRESS(L)%IMT,TOPICS(I)%STRESS(L)%ISC
IF(IOS.NE.0)THEN
READ(LINE,*) TOPICS(I)%STRESS(L)%CDATE
TOPICS(I)%STRESS(L)%IYR=0; TOPICS(I)%STRESS(L)%IMH=0; TOPICS(I)%STRESS(L)%IDY=0
TOPICS(I)%STRESS(L)%IHR=0; TOPICS(I)%STRESS(L)%IMT=0; TOPICS(I)%STRESS(L)%ISC=0
ENDIF
ENDIF
READ(IU,*) NC,NSYS
IF(NC.NE.TOPICS(I)%NSUBTOPICS)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Number of parameters is not correct'//CHAR(13)//TRIM(TOPICS(I)%TNAME),'Error')
CLOSE(IU); RETURN
ENDIF
ALLOCATE(TOPICS(I)%STRESS(L)%FILES(NC,NSYS))
DO K=1,TOPICS(I)%NSUBTOPICS
DO J=1,NSYS
READ(IU,'(A512)',IOSTAT=IOS) LINE
IF(IOS.EQ.0)THEN
READ(LINE,*,IOSTAT=IOS) TOPICS(I)%STRESS(L)%FILES(K,J)%IACT , &
TOPICS(I)%STRESS(L)%FILES(K,J)%ICNST
IF(IOS.EQ.0)THEN
IF(TOPICS(I)%STRESS(L)%FILES(K,J)%ICNST.EQ.1)THEN
READ(LINE,*,IOSTAT=IOS) TOPICS(I)%STRESS(L)%FILES(K,J)%IACT , &
TOPICS(I)%STRESS(L)%FILES(K,J)%ICNST, &
TOPICS(I)%STRESS(L)%FILES(K,J)%ILAY , &
TOPICS(I)%STRESS(L)%FILES(K,J)%FCT , &
TOPICS(I)%STRESS(L)%FILES(K,J)%IMP , &
TOPICS(I)%STRESS(L)%FILES(K,J)%CNST
TOPICS(I)%STRESS(L)%FILES(K,J)%FNAME=''
ELSEIF(TOPICS(I)%STRESS(L)%FILES(K,J)%ICNST.EQ.2)THEN
READ(LINE,*,IOSTAT=IOS) TOPICS(I)%STRESS(L)%FILES(K,J)%IACT , &
TOPICS(I)%STRESS(L)%FILES(K,J)%ICNST, &
TOPICS(I)%STRESS(L)%FILES(K,J)%ILAY , &
TOPICS(I)%STRESS(L)%FILES(K,J)%FCT , &
TOPICS(I)%STRESS(L)%FILES(K,J)%IMP , &
TOPICS(I)%STRESS(L)%FILES(K,J)%CNST , &
TOPICS(I)%STRESS(L)%FILES(K,J)%FNAME
IF(TRIM(PREFVAL(5)).NE.'')THEN
TOPICS(I)%STRESS(L)%FILES(K,J)%FNAME=UTL_SUBST(TOPICS(I)%STRESS(L)%FILES(K,J)%FNAME,TRIM(REPLACESTRING),PREFVAL(5))
ENDIF
TOPICS(I)%STRESS(L)%FILES(K,J)%ALIAS= &
UTL_CAP(TRIM(TOPICS(I)%STRESS(L)%FILES(K,J)%FNAME(INDEX(TOPICS(I)%STRESS(L)%FILES(K,J)%FNAME,'\',.TRUE.)+1:)),'L')
ELSE
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Incorrect syntax, the ICNST need to be 1 or 2.'//CHAR(13)// &
'iMOD reads ['//TRIM(ITOS(TOPICS(I)%STRESS(L)%FILES(K,J)%ICNST))//']','Error')
CLOSE(IU); RETURN
ENDIF
ENDIF
ENDIF
IF(IOS.NE.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Incorrect number of input fields for'//CHAR(13)//TRIM(TOPICS(I)%TNAME)//CHAR(13)// &
'or syntax error in line'//CHAR(13)//CHAR(13)//TRIM(LINE)//CHAR(13)//CHAR(13)//'Maybe a quote is missing in the filename','Error')
CLOSE(IU); RETURN
ENDIF
ENDDO
ENDDO
!## extra files only for MetaSWAP
IF(I.EQ.1)THEN
READ(IU,*) K
IF(ASSOCIATED(TOPICS(I)%STRESS(L)%INPFILES))DEALLOCATE(TOPICS(I)%STRESS(L)%INPFILES)
ALLOCATE(TOPICS(I)%STRESS(L)%INPFILES(K))
DO J=1,K; READ(IU,'(A256)') TOPICS(I)%STRESS(L)%INPFILES(J); ENDDO
ENDIF
ENDDO
ENDDO
I=0
DO
DO
READ(IU,'(A512)',IOSTAT=IOS) LINE; IF(IOS.NE.0)EXIT
IF(TRIM(LINE).NE.'')EXIT
ENDDO
IF(IOS.NE.0)EXIT
I=I+1; READ(LINE,*,IOSTAT=IOS) PERIOD(I)%NAME
READ(IU,'(2(I2.2,1X),I4.4,3(1X,I2.2))',IOSTAT=IOS) PERIOD(I)%IDY,PERIOD(I)%IMH,PERIOD(I)%IYR, &
PERIOD(I)%IHR,PERIOD(I)%IMT,PERIOD(I)%ISC
IF(IOS.NE.0)THEN; I=I-1; EXIT; ENDIF
ENDDO; NPERIOD=I
CLOSE(IU)
PMANAGER_LOADPRJ=.TRUE.
END FUNCTION PMANAGER_LOADPRJ
!###======================================================================
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.0,'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
!###======================================================================
SUBROUTINE PMANAGER_LOADPCG(IU,IOPTION)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IU,IOPTION
INTEGER :: IOS
!## prj file
IF(IOPTION.EQ.0)THEN
READ(IU,'(A256)') LINE
READ(LINE,*,IOSTAT=IOS) PCG%NOUTER,PCG%NINNER,PCG%HCLOSE,PCG%RCLOSE,PCG%RELAX,PCG%NPCOND, &
PCG%IPRPCG,PCG%MUTPCG,PCG%DAMPPCG,PCG%DAMPPCGT,PCG%IQERROR,PCG%QERROR
IF(IOS.NE.0)THEN
PCG%IQERROR=0; PCG%QERROR=0.0
READ(LINE,*,IOSTAT=IOS) PCG%NOUTER,PCG%NINNER,PCG%HCLOSE,PCG%RCLOSE,PCG%RELAX,PCG%NPCOND, &
PCG%IPRPCG,PCG%MUTPCG,PCG%DAMPPCG,PCG%DAMPPCGT
ENDIF
!## run file
ELSEIF(IOPTION.EQ.1)THEN
!## mf2005 file
ELSEIF(IOPTION.EQ.2)THEN
ENDIF
END SUBROUTINE PMANAGER_LOADPCG
!###======================================================================
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 :: Z
PMANAGER_SAVEPST=.FALSE.
!## write model dimensions into pst file
IF(IOPTION.EQ.2)THEN
WRITE(IU,*) IDF%NCOL,IDF%NROW,NLAY,NPER,ISS
WRITE(IU,*) IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX,IDF%IEQ
IF(IDF%IEQ.EQ.0)THEN
WRITE(IU,*) IDF%DX
ELSE
WRITE(IU,*) (IDF%SX(ICOL),ICOL=1,IDF%NCOL)
WRITE(IU,*) (IDF%SY(IROW),IROW=1,IDF%NROW)
ENDIF
ENDIF
IF(IOPTION.NE.1)THEN
IF(ASSOCIATED(PEST%MEASURES))THEN
I=SIGN(SIZE(PEST%MEASURES),PEST%IIPF)
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))
WRITE(IU,'(A)') TRIM(LINE)
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))
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
IDF%X=Z
ELSE
!## upscale is using number 15, zones
IDF%FNAME=LINE; SCL_UP=15; SCL_D=0
!## read/clip/scale idf file
IF(.NOT.IDFREADSCALE(IDF%FNAME,IDF,SCL_UP,SCL_D,1.0,0))RETURN
ENDIF
!## 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',IDF,0,IU,1,0))RETURN
ELSE
WRITE(IU,'(A)') TRIM(LINE)
ENDIF
ENDDO
ENDIF
PMANAGER_SAVEPST=.TRUE.
END FUNCTION PMANAGER_SAVEPST
!###======================================================================
SUBROUTINE PMANAGER_LOADPST(IU,NPARAM,IOPTION)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IU,NPARAM,IOPTION
INTEGER :: I,J,IOS,N,M
IF(IOPTION.EQ.0)THEN
READ(IU,*) PEST%IIPF
IF(PEST%IIPF.NE.0)THEN
ALLOCATE(PEST%MEASURES(ABS(PEST%IIPF)))
PEST%IIPF=MIN(PEST%IIPF,0); IF(PEST%IIPF.LT.0)PEST%IIPF=1
DO I=1,SIZE(PEST%MEASURES)
READ(IU,'(A256)') LINE
READ(LINE,*) PEST%MEASURES(I)%IPFNAME,PEST%MEASURES(I)%IPFTYPE,PEST%MEASURES(I)%IXCOL, &
PEST%MEASURES(I)%IYCOL ,PEST%MEASURES(I)%ILCOL ,PEST%MEASURES(I)%IMCOL,PEST%MEASURES(I)%IVCOL
ENDDO
ENDIF
ENDIF
READ(IU,'(A)') LINE
READ(LINE,*,IOSTAT=IOS) PEST%PE_MXITER,PEST%PE_STOP,PEST%PE_SENS,N,M,PEST%PE_TARGET(1),PEST%PE_TARGET(2),PEST%PE_SCALING, &
PEST%PE_PADJ,PEST%PE_DRES,PEST%PE_KTYPE
IF(IOS.NE.0)THEN
PEST%PE_KTYPE=1
READ(LINE,*,IOSTAT=IOS) PEST%PE_MXITER,PEST%PE_STOP,PEST%PE_SENS,N,M,PEST%PE_TARGET(1),PEST%PE_TARGET(2),PEST%PE_SCALING, &
PEST%PE_PADJ,PEST%PE_DRES
IF(IOS.NE.0)THEN
PEST%PE_DRES=0.0
READ(LINE,*,IOSTAT=IOS) PEST%PE_MXITER,PEST%PE_STOP,PEST%PE_SENS,N,M,PEST%PE_TARGET(1),PEST%PE_TARGET(2),PEST%PE_SCALING, &
PEST%PE_PADJ
IF(IOS.NE.0)THEN
PEST%PE_PADJ=0.0
READ(LINE,*,IOSTAT=IOS) PEST%PE_MXITER,PEST%PE_STOP,PEST%PE_SENS,N,M,PEST%PE_TARGET(1),PEST%PE_TARGET(2),PEST%PE_SCALING
IF(IOS.NE.0)THEN
PEST%PE_SCALING=0
READ(LINE,*,IOSTAT=IOS) PEST%PE_MXITER,PEST%PE_STOP,PEST%PE_SENS,N,M,PEST%PE_TARGET(1),PEST%PE_TARGET(2)
ENDIF
ENDIF
ENDIF
ENDIF
PEST%PE_SCALING=PEST%PE_SCALING+1
!## periods defined
IF(N.GT.0)THEN
ALLOCATE(PEST%S_PERIOD(N),PEST%E_PERIOD(N))
PEST%S_PERIOD='0'; PEST%E_PERIOD='0'
DO I=1,SIZE(PEST%S_PERIOD)
READ(IU,'(A256)') LINE
READ(LINE,*) PEST%S_PERIOD(I),PEST%E_PERIOD(I)
ENDDO
ENDIF
!## batchfiles defined
IF(M.GT.0)THEN
ALLOCATE(PEST%B_FRACTION(M),PEST%B_BATCHFILE(M),PEST%B_OUTFILE(M))
PEST%B_FRACTION=1.0; PEST%B_BATCHFILE=''; PEST%B_OUTFILE=''
DO I=1,SIZE(PEST%B_FRACTION)
READ(IU,'(A256)') LINE
READ(LINE,*,IOSTAT=IOS) PEST%B_FRACTION(I),PEST%B_BATCHFILE(I),PEST%B_OUTFILE(I)
ENDDO
ENDIF
IF(NPARAM.GT.0)THEN
ALLOCATE(PEST%PARAM(NPARAM))
DO I=1,SIZE(PEST%PARAM)
READ(IU,'(A256)') LINE
READ(LINE,*,IOSTAT=IOS) PEST%PARAM(I)%PACT,PEST%PARAM(I)%PPARAM,PEST%PARAM(I)%PILS,PEST%PARAM(I)%PIZONE,PEST%PARAM(I)%PINI,PEST%PARAM(I)%PDELTA, &
PEST%PARAM(I)%PMIN,PEST%PARAM(I)%PMAX,PEST%PARAM(I)%PINCREASE,PEST%PARAM(I)%PIGROUP,PEST%PARAM(I)%PLOG
PEST%PARAM(I)%PPARAM=UTL_CAP(PEST%PARAM(I)%PPARAM,'U')
IF(IOS.NE.0)THEN
READ(LINE,*,IOSTAT=IOS) PEST%PARAM(I)%PACT,PEST%PARAM(I)%PPARAM,PEST%PARAM(I)%PILS,PEST%PARAM(I)%PIZONE,PEST%PARAM(I)%PINI,PEST%PARAM(I)%PDELTA, &
PEST%PARAM(I)%PMIN,PEST%PARAM(I)%PMAX,PEST%PARAM(I)%PINCREASE,PEST%PARAM(I)%PIGROUP
IF(IOS.NE.0)THEN
PEST%PARAM(I)%PIGROUP=I
READ(LINE,*,IOSTAT=IOS) PEST%PARAM(I)%PACT,PEST%PARAM(I)%PPARAM,PEST%PARAM(I)%PILS,PEST%PARAM(I)%PIZONE,PEST%PARAM(I)%PINI,PEST%PARAM(I)%PDELTA, &
PEST%PARAM(I)%PMIN,PEST%PARAM(I)%PMAX,PEST%PARAM(I)%PINCREASE
IF(IOS.NE.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Error reading runfile in the PST section with the parameter definitions.','Error')
RETURN
ENDIF
ENDIF
ENDIF
SELECT CASE (PEST%PARAM(I)%PPARAM)
!## recharge/anisotropy angle non log transformed
CASE ('RE','AH')
PEST%PARAM(I)%PLOG=0
CASE DEFAULT
PEST%PARAM(I)%PLOG=1
END SELECT
!## fill in iparam
DO J=1,SIZE(PARAM); IF(PEST%PARAM(I)%PPARAM.EQ.PARAM(J))EXIT; ENDDO
PEST%PARAM(I)%IPARAM=J
ENDDO
ENDIF
READ(IU,*) I
IF(I.GT.0)THEN
ALLOCATE(PEST%IDFFILES(I))
DO I=1,SIZE(PEST%IDFFILES)
READ(IU,'(A256)') LINE
READ(LINE,*) PEST%IDFFILES(I)
ENDDO
ENDIF
END SUBROUTINE PMANAGER_LOADPST
!###======================================================================
LOGICAL FUNCTION PMANAGERRUN(ID,RUNFNAME,IBATCH)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ID,IBATCH
CHARACTER(LEN=*),INTENT(IN) :: RUNFNAME
INTEGER :: IU,ITOPIC,IRUN
CHARACTER(LEN=256) :: FNAME
LOGICAL :: LEX
PMANAGERRUN=.FALSE.
IF(ID.EQ.ID_OPENRUN)THEN
IF(RUNFNAME.EQ.'')THEN
FNAME=''
IF(.NOT.UTL_WSELECTFILE('iMOD Run File (*.run)|*.run|', &
LOADDIALOG+MUSTEXIST+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,&
'Load iMOD Run File'))RETURN
ELSE
FNAME=RUNFNAME
ENDIF
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=FNAME,STATUS='OLD',ACTION='READ,DENYWRITE',FORM='FORMATTED')
IF(IBATCH.EQ.0)CALL UTL_MESSAGEHANDLE(0)
IF(PMANAGER_GETKEYS(IU)) THEN
IF(PMANAGER_GETFILES(IU,ITOPIC))THEN
IF(IBATCH.EQ.0)CALL PMANAGERUPDATE(0,0,0); PMANAGERRUN=.TRUE.
ELSE
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Error reading BODY runfile '//TRIM(CMOD(ITOPIC)),'Error')
ENDIF
ELSE
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Error reading HEADER runfile','Error')
ENDIF
CLOSE(IU)
IF(IBATCH.EQ.0)CALL UTL_MESSAGEHANDLE(1)
ELSEIF(ID.EQ.ID_SAVERUN)THEN
FNAME=RUNFNAME
LEX=PMANAGER_INITSIM(FNAME,IBATCH,IRUN)
CALL WDIALOGSELECT(ID_DPMANAGER_SIM); CALL WDIALOGUNLOAD()
CALL WDIALOGSELECT(ID_DPMANAGERLAYERTYPES); CALL WDIALOGUNLOAD()
IF(.NOT.LEX)THEN; IF(ASSOCIATED(SIM))DEALLOCATE(SIM); RETURN; ENDIF
IF(IBATCH.EQ.0)CALL UTL_MESSAGEHANDLE(0)
IF(IFORMAT.EQ.1)THEN
IF(PMANAGER_SAVERUN(FNAME,IBATCH))THEN
IF(IBATCH.EQ.0)THEN
IF(IRUN.EQ.0)CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'Successfully written runfile:'//CHAR(13)//TRIM(FNAME)//CHAR(13)//CHAR(13)// &
'Start the MODELTOOL to use this runfile for a simulation.','Information')
ELSE
WRITE(*,'(/A/)') 'Successfully written runfile:'//TRIM(FNAME)
ENDIF
PMANAGERRUN=.TRUE.
ENDIF
ELSEIF(IFORMAT.EQ.2)THEN
IF(PMANAGER_SAVEMF2005(FNAME,IBATCH))THEN
IF(IBATCH.EQ.0)THEN
IF(IRUN.EQ.0)CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'Successfully written MF2005 files:'//CHAR(13)//TRIM(FNAME),'Information')
ELSE
WRITE(*,'(/A/)') 'Successfully written MF2005 files:'//TRIM(FNAME)
ENDIF
PMANAGERRUN=.TRUE.
ENDIF
CALL PMANAGER_SAVEMF2005_DEALLOCATE()
ENDIF
CALL UTL_CLOSEUNITS()
DEALLOCATE(SIM)
IF(ABS(IRUN).EQ.1.AND.PMANAGERRUN)CALL PMANAGERSTART(FNAME,IRUN,IBATCH,1,LMODFLOW2005)
IF(IBATCH.EQ.0)CALL UTL_MESSAGEHANDLE(1)
ENDIF
END FUNCTION PMANAGERRUN
!###======================================================================
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
TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: IDF
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(NPER.GT.1)NPER=NPER-1
MXNLAY=NLAY
CALL UTL_CREATEDIR(FNAME(1:INDEX(FNAME,'\',.TRUE.)-1))
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
WRITE(IU,'(A)') CHAR(39)//FNAME(1:INDEX(FNAME,'\',.TRUE.)-1)//CHAR(39)
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.0)NSCL=2
ENDIF
WRITE(IU,'(12(I10,1X))') NLAY,MXNLAY,NPER,0,NSCL,0,PBMAN%ICONCHK,N,PBMAN%UNCONFINED,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,0,0,0,0'
IF(PBMAN%MINKD.NE.0.0.OR.PBMAN%MINC.NE.0.0)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(G15.7,A1))') IDF(1)%XMIN,',',IDF(1)%YMIN,',',IDF(1)%XMAX,',',IDF(1)%YMAX,',',IDF(1)%DX,',',0.0
ELSE
IF(SUBMODEL(6).GT.0.0.AND.SUBMODEL(7).GT.0.0)THEN
WRITE(IU,'(7(G15.7,A1))') SUBMODEL(1),',',SUBMODEL(2),',',SUBMODEL(3),',',SUBMODEL(4),',',SUBMODEL(5),',',SUBMODEL(7),',',SUBMODEL(6)
ELSE
WRITE(IU,'(6(G15.7,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 (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
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
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
!## pwt - skip ilay
IF(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,NPER
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,NPER
!## steady-state
IF(SIM(KPER)%DELT.EQ.0.0)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
!###======================================================================
SUBROUTINE PMANAGERSTART(RUNFNAME,IRUNMODE,IBATCH,NICORES,LMODFLOW2005)
!###======================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: RUNFNAME
INTEGER,INTENT(IN) :: IRUNMODE,IBATCH,NICORES
LOGICAL,INTENT(IN) :: LMODFLOW2005
CHARACTER(LEN=256) :: DIR,DIRNAME
CHARACTER(LEN=52) :: MNAME
INTEGER :: IU,JU,IOS,I,IFLAGS,IEXCOD,IERROR,IMODE
LOGICAL :: LEX
IMODE=0
IF(LEN_TRIM(PREFVAL(8)).GT.0)THEN
INQUIRE(FILE=PREFVAL(8),EXIST=LEX)
ELSE
LEX=.FALSE.
ENDIF
IF(.NOT.LEX)THEN
IF(IBATCH.EQ.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMODFLOW cannot be started, iMOD cannot find the executable:'//CHAR(13)// &
'['//TRIM(PREFVAL(8))//']','Error')
ELSE
WRITE(*,'(A)') 'iMODFLOW cannot be started, iMOD cannot find the exectuable given'
WRITE(*,'(A)') '['//TRIM(PREFVAL(8))//']'
ENDIF
RETURN
ENDIF
IMODE=0
!## runfile or namfile
IF(INDEX(UTL_CAP(RUNFNAME,'U'),'.NAM',.TRUE.).GT.0)THEN
IMODE=1
ELSEIF(INDEX(UTL_CAP(RUNFNAME,'U'),'.RUN',.TRUE.).GT.0)THEN
IMODE=2
ELSE
IF(IBATCH.EQ.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMODFLOW cannot be started with given file:'//CHAR(13)// &
TRIM(RUNFNAME),'Error')
ELSE
WRITE(*,'(A)') 'iMODFLOW cannot be started with given file: '//TRIM(RUNFNAME)
ENDIF
RETURN
ENDIF
!## simulation directory
DIR=RUNFNAME(:INDEX(RUNFNAME,'\',.TRUE.)-1)
CALL UTL_CREATEDIR(DIR)
!## modelname
MNAME=RUNFNAME(INDEX(RUNFNAME,'\',.TRUE.)+1:INDEX(RUNFNAME,'.',.TRUE.)-1)
!## simulate batch-file, inclusive pause statement.
IU=UTL_GETUNIT()
CALL OSD_OPEN(IU,FILE=TRIM(DIR)//'\RUN.BAT',STATUS='REPLACE',ACTION='WRITE,DENYREAD',IOSTAT=IOS)
IF(IOS.NE.0)THEN
IF(IBATCH.EQ.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMODFLOW is already running, you cannot start '//CHAR(13)// &
'new run while previous run is still running'//CHAR(13)//'or'//CHAR(13)//'Run-script cannot be created'//CHAR(13)// &
TRIM(DIR)//'\RUN.BAT','Error')
ELSE
WRITE(*,'(A)') 'iMODFLOW is already running, you cannot start new run while previous run is still running'// &
'or Run-script cannot be created '//TRIM(DIR)//'\RUN.BAT'
ENDIF
RETURN
ENDIF
!## remove previous version of imodflow
I=INDEXNOCASE(PREFVAL(8),'\',.TRUE.)+1
INQUIRE(FILE=TRIM(DIR)//'\'//TRIM(PREFVAL(8)(I:)),EXIST=LEX)
IF(LEX)CALL IOSDELETEFILE(TRIM(DIR)//'\'//TRIM(PREFVAL(8)(I:)))
!## copy imodflow executable
CALL IOSCOPYFILE(TRIM(PREFVAL(8)),TRIM(DIR)//'\'//TRIM(PREFVAL(8)(I:)))
INQUIRE(FILE=TRIM(EXEPATH)//'\'//TRIM(LICFILE),EXIST=LEX)
IF(.NOT.LEX)THEN
IERROR=0; CALL IMOD_AGREEMENT(IERROR)
IF(IERROR.NE.1)THEN
IF(LBETA)THEN
IF(IBATCH.EQ.0)THEN
CALL WMESSAGEBOX(OKONLY,COMMONOK,EXCLAMATIONICON,'Cannot start Beta-iMOD because you are not authorized in writing for Beta-iMOD','Error')
ELSE
WRITE(*,'(A)') 'Cannot start Beta-iMOD because you are not authorized in writing for Beta-iMOD'
ENDIF
ELSE
IF(IBATCH.EQ.0)THEN
CALL WMESSAGEBOX(OKONLY,COMMONOK,EXCLAMATIONICON,'Cannot start iMODFLOW unless you accept the iMOD Software License Agreement','Error')
ELSE
WRITE(*,'(A)') 'Cannot start iMODFLOW unless you accept the iMOD Software License Agreement'
ENDIF
ENDIF
RETURN
ENDIF
ENDIF
!## copy imod license text file
CALL IOSCOPYFILE(TRIM(EXEPATH)//'\'//TRIM(LICFILE),TRIM(DIR)//'\'//TRIM(LICFILE))
!## write start script in batch file
WRITE(IU,'(A)') 'REM =========================='
WRITE(IU,'(A)') 'REM Run Script iMOD '//TRIM(RVERSION)
WRITE(IU,'(A)') 'REM =========================='
!## namfile
IF(IMODE.EQ.1)THEN
WRITE(IU,'(A)') 'TITLE "NAMFILE: '//TRIM(MNAME)//'.nam"'
IF(LMODFLOW2005)THEN
JU=UTL_GETUNIT()
CALL OSD_OPEN(JU,FILE=TRIM(DIR)//'\MF2005.TXT',STATUS='REPLACE',ACTION='WRITE,DENYREAD',IOSTAT=IOS)
WRITE(JU,*) TRIM(RUNFNAME(INDEX(RUNFNAME,'\',.TRUE.)+1:))
CLOSE(JU)
WRITE(IU,'(/A/)') '"'//TRIM(PREFVAL(8))//'" < MF2005.TXT'
ELSE
IF(PBMAN%IPEST.EQ.0)THEN
WRITE(IU,'(/A/)') '"'//TRIM(PREFVAL(8))//'" "'//TRIM(MNAME)//'.nam"'
ELSE
WRITE(IU,'(/A/)') '"'//TRIM(PREFVAL(8))//'" "'//TRIM(MNAME)//'.nam" -ipest ".\modelinput\'//trim(mname)//'.pst1"'
ENDIF
ENDIF
!## include conversion of sfr package into isg-file
IF(LSFR)THEN
WRITE(IU,'(/A)') 'REM ============================================='
WRITE(IU,'( A)') 'REM iMOD Batch Script iMOD '//TRIM(RVERSION)
WRITE(IU,'( A)') 'REM ============================================='
WRITE(IU,'( A)') 'ECHO FUNCTION=SFRTOISG > SFRTOISG.INI'
WRITE(IU,'( A)') 'ECHO ISGFILE_IN= "'//TRIM(DIR)//'\MODELINPUT\SFR7\SFR.ISG" >> SFRTOISG.INI'
WRITE(IU,'( A)') 'ECHO ISGFILE_OUT="'//TRIM(DIR)//'\BDGSFR\ISG\SFR.ISG" >> SFRTOISG.INI'
WRITE(IU,'(A/)') 'ECHO SFRFILE_IN= "'//TRIM(DIR)//'\'//TRIM(MNAME)//'_FSFR.TXT" >> SFRTOISG.INI'
WRITE(IU,'(A)')
WRITE(IU,'(A)') '"'//TRIM(EXENAME)//'" SFRTOISG.INI'
WRITE(IU,'(A)')
ENDIF
!## runfile
ELSEIF(IMODE.EQ.2)THEN
IF(IBATCH.EQ.0)THEN
IF(NICORES.GT.1)THEN
WRITE(IU,'(A)') ':: Set number of MPI processes'
WRITE(IU,'(A)') 'set np='//ITOS(NICORES)
WRITE(IU,'(A)') ''
WRITE(IU,'(A)') ':: Run model'
WRITE(IU,'(A)') '"C:\Program Files\MPICH2\bin\mpiexec.exe" -localonly %np% "'//TRIM(PREFVAL(8))//'" '//TRIM(MNAME)//'.run"'
ELSE
WRITE(IU,'(A)') '"'//TRIM(PREFVAL(8))//'" '//'IMODFLOW.RUN'
ENDIF
ELSE
WRITE(IU,'(A)') '"'//TRIM(PREFVAL(8))//'" '//TRIM(MNAME)//'.run'
ENDIF
ENDIF
CLOSE(IU)
!## move iMOD to the simulation directory
CALL IOSDIRNAME(DIRNAME); CALL IOSDIRCHANGE(TRIM(DIR)//'\')
!## start the batch file - run in the foreground
IF(IRUNMODE.GT.0)THEN
IFLAGS=PROCBLOCKED
!## executes on commandtool such that commands alike 'dir' etc. works
#if (defined(WINTERACTER11))
IFLAGS=IFLAGS+PROCCMDPROC
#endif
CALL IOSCOMMAND('RUN.BAT',IFLAGS,IEXCOD=IEXCOD)
IF(IEXCOD.EQ.0)THEN
IF(IBATCH.EQ.0)THEN
CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'Successful simulation using: '//CHAR(13)// &
'MODFLOW: '//TRIM(PREFVAL(8))//CHAR(13)// &
'RUNFILE/NAMFILE: '//TRIM(RUNFNAME),'Information')
ELSE
WRITE(*,'(A)') 'Successfully STARTED the Modflow simulation using:'
WRITE(*,'(A)') 'MODFLOW: '//TRIM(PREFVAL(8))
WRITE(*,'(A)') 'RUNFILE/NAMFILE: '//TRIM(RUNFNAME)
ENDIF
ELSE
IF(IBATCH.EQ.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'An error occured in starting your simulation','Error')
ELSE
WRITE(*,'(A)') 'An error occured in starting your simulation'
ENDIF
ENDIF
!## start the batch file - run in the background
ELSEIF(IRUNMODE.LT.0)THEN
IFLAGS=0
!## executes on commandtool such that commands alike 'dir' etc. works
#if (defined(WINTERACTER11))
IFLAGS=IFLAGS+PROCCMDPROC
#endif
CALL IOSCOMMAND('RUN.BAT',IFLAGS,IEXCOD=IEXCOD)
IF(IBATCH.EQ.0)THEN
CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'Successfully STARTED the Modflow simulation using:'//CHAR(13)// &
'MODFLOW: '//TRIM(PREFVAL(8))//CHAR(13)// &
'RUNFILE/NAMFILE: '//TRIM(RUNFNAME),'Information')
ELSE
WRITE(*,'(A)') 'Successful simulation using:'
WRITE(*,'(A)') 'MODFLOW: '//TRIM(PREFVAL(8))
WRITE(*,'(A)') 'RUNFILE/NAMFILE: '//TRIM(RUNFNAME)
ENDIF
ENDIF
CALL IOSDIRCHANGE(DIRNAME)
END SUBROUTINE PMANAGERSTART
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005(FNAME,IBATCH)
!###======================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: FNAME
INTEGER,INTENT(IN) :: IBATCH
CHARACTER(LEN=512) :: DIRMNAME,DIR
INTEGER(KIND=8) :: ITIME,JTIME
INTEGER :: ISS,IULAK,ISTEADY,IPER,INIPER,LPER,KPER,IINI,IPRT
LOGICAL :: LTB
PMANAGER_SAVEMF2005=.FALSE.
!## remove final stress as it is the final timestep
IF(NPER.GT.1)NPER=NPER-1
ISTEADY=0; IF(SIM(1)%DELT.EQ.0.0)ISTEADY=1
!## time information
ISS=0; DO KPER=1,NPER; IF(SIM(KPER)%DELT.NE.0.0)ISS=1; ENDDO
!## overwrite nstep/nmult in case imodbatch is used
IF(IBATCH.EQ.1)THEN
DO KPER=1,NPER; 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,DIR,DIRMNAME,IPRT))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
!##================
!## 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(IBATCH))RETURN
!## save bas file
IF(.NOT.PMANAGER_SAVEMF2005_BAS_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 bcf 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_PCG(DIRMNAME))RETURN
!## save pcgn file
IF(.NOT.PMANAGER_SAVEMF2005_PCGN(DIRMNAME))RETURN
!## save sip file
IF(.NOT.PMANAGER_SAVEMF2005_SIP(DIRMNAME))RETURN
!## save oc file
IF(.NOT.PMANAGER_SAVEMF2005_OCD(DIRMNAME))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 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 isg package
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 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,NPER
!## 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
! IF(.NOT.PMANAGER_SAVEMF2005_LAK_SAVE(IULAK,IINI,IBATCH,DIR,KPER=KPER,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,''))RETURN
ELSE
IF(.NOT.PMANAGER_SAVEMF2005_COMBINE(DIR,DIRMNAME,(/'OLF','DRN','DRN_'/),IDRNCB,'ICONCHK IC'))RETURN
ENDIF
ENDIF
IF(LISG.AND.LRIV)THEN
IF(.NOT.PMANAGER_SAVEMF2005_COMBINE(DIR,DIRMNAME,(/'ISG','RIV','RIV_'/),IRIVCB,'AUX RFCT RFACT RFCT'))RETURN
ENDIF
PMANAGER_SAVEMF2005=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005
! !###======================================================================
! SUBROUTINE PMANAGER_SAVEMF2005_GETTIMESTEP(IPER,ITIME,JTIME)
! !###======================================================================
! IMPLICIT NONE
! INTEGER,INTENT(IN) :: IPER
! INTEGER(KIND=8),INTENT(OUT) :: ITIME,JTIME
!
! !## start- and enddate of simulation period
! IF(SIM(IPER)%DELT.EQ.0.0)THEN
! ITIME=INT(0,8); JTIME=INT(0,8)!; GRIDISG%SDATE=0; GRIDISG%EDATE=0 !## mean value
! ELSE
! ITIME=SIM(IPER )%IYR*10000000000+SIM(IPER )%IMH*100000000+SIM(IPER )%IDY*1000000+ &
! SIM(IPER )%IHR*10000 +SIM(IPER )%IMT*100 +SIM(IPER )%ISC
! JTIME=SIM(IPER+1)%IYR*10000000000+SIM(IPER+1)%IMH*100000000+SIM(IPER+1)%IDY*1000000+ &
! SIM(IPER+1)%IHR*10000 +SIM(IPER+1)%IMT*100 +SIM(IPER+1)%ISC
! ENDIF
!
! END SUBROUTINE PMANAGER_SAVEMF2005_GETTIMESTEP
!###======================================================================
SUBROUTINE PMANAGER_SAVEMF2005_CONSISTENCY(LTB)
!###======================================================================
IMPLICIT NONE
LOGICAL,INTENT(IN) :: LTB
INTEGER :: IROW,ICOL,ILAY,JLAY,IC1,IC2,IR1,IR2,IL1,IL2
REAL :: XBOT
REAL,DIMENSION(:),ALLOCATABLE :: TP,BT,HK,VK,VA,TH,TP_BU,BT_BU,HK_BU,VK_BU,VA_BU
INTEGER,DIMENSION(:),ALLOCATABLE :: IB
!## make sure nodata for anisotropy factors is 1.0
IF(LANI)THEN
!## apply consistency check anisotropy factor to be in between 0.0-1.0
DO ILAY=1,NLAY; DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL
ANF(ILAY)%X(ICOL,IROW)=MAX(0.0,MIN(1.0,ANF(ILAY)%X(ICOL,IROW)))
ENDDO; ENDDO; ENDDO
ENDIF
IF(.NOT.LTB)RETURN
!## apply consistency check top/bot
IF(.TRUE.)THEN
DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL; JLAY=0; DO ILAY=1,NLAY
IF(BND(ILAY)%X(ICOL,IROW).EQ.0)CYCLE
IF(JLAY.GT.0)THEN
XBOT=BOT(JLAY)%X(ICOL,IROW)
!## minimal aquifer thickness
TOP(ILAY)%X(ICOL,IROW)=MIN(XBOT,TOP(ILAY)%X(ICOL,IROW))
ENDIF
BOT(ILAY)%X(ICOL,IROW)=MIN(TOP(ILAY)%X(ICOL,IROW)-MINTHICKNESS ,BOT(ILAY)%X(ICOL,IROW))
!## store last active layer
JLAY=ILAY
ENDDO; ENDDO; ENDDO
ELSE
ALLOCATE(TP(NLAY) ,BT(NLAY) ,HK(NLAY) ,VK(NLAY-1) ,VA(NLAY) ,IB(NLAY),TH(NLAY), &
TP_BU(NLAY),BT_BU(NLAY),HK_BU(NLAY),VK_BU(NLAY-1),VA_BU(NLAY))
DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL
DO ILAY=1,NLAY ; IB(ILAY)=BND(ILAY)%X(ICOL,IROW); ENDDO
DO ILAY=1,NLAY ; TP(ILAY)=TOP(ILAY)%X(ICOL,IROW); ENDDO
DO ILAY=1,NLAY ; BT(ILAY)=BOT(ILAY)%X(ICOL,IROW); ENDDO
DO ILAY=1,NLAY ; HK(ILAY)=KHV(ILAY)%X(ICOL,IROW); ENDDO
DO ILAY=1,NLAY ; VA(ILAY)=KVA(ILAY)%X(ICOL,IROW); ENDDO
DO ILAY=1,NLAY-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,MINTHICKNESS)
DO ILAY=1,NLAY ; IB(ILAY)=BND(ILAY)%X(ICOL,IROW); ENDDO
DO ILAY=1,NLAY ; TOP(ILAY)%X(ICOL,IROW)=TP(ILAY); ENDDO
DO ILAY=1,NLAY ; BOT(ILAY)%X(ICOL,IROW)=BT(ILAY); ENDDO
DO ILAY=1,NLAY ; KHV(ILAY)%X(ICOL,IROW)=HK(ILAY); ENDDO
DO ILAY=1,NLAY ; KVA(ILAY)%X(ICOL,IROW)=VA(ILAY); ENDDO
DO ILAY=1,NLAY-1; KVV(ILAY)%X(ICOL,IROW)=VK(ILAY); 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(.NOT.LCHD)THEN
! DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL; DO ILAY=1,NLAY
! 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
!
! !## constant head cell dry - becomes active node - shift to an appropriate model layer where the head is actually in
! DO JLAY=ILAY,NLAY
! IF(SHD(ILAY)%X(ICOL,IROW).LE.BOT(JLAY)%X(ICOL,IROW))THEN
! BND(JLAY)%X(ICOL,IROW)=1
! SHD(JLAY)%X(ICOL,IROW)=SHD(ILAY)%X(ICOL,IROW)
! ELSE
! BND(JLAY)%X(ICOL,IROW)=-99
! SHD(JLAY)%X(ICOL,IROW)=SHD(ILAY)%X(ICOL,IROW)
! !## exit
! EXIT
! ENDIF
! ENDDO
! ENDIF
! ENDDO; ENDDO; ENDDO
! ENDIF
!## if unconfined modify (nodata) head for dry cells, check from bottom to top
DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL; DO ILAY=NLAY-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,IDF%NROW; DO ICOL=1,IDF%NCOL
DO ILAY=NLAY,1,-1
IF(KDW(ILAY)%X(ICOL,IROW).LE.0.0)THEN
IF(ILAY.GT.1)VCW(ILAY-1)%X(ICOL,IROW)=0.0
KDW(ILAY)%X(ICOL,IROW)=0.0
BND(ILAY)%X(ICOL,IROW)=0.0
ELSE
!## stop search for this location
EXIT
ENDIF
ENDDO
ENDDO; ENDDO
!## cleaning for constant head cells that are only connected to other constant head/inactive cells
DO ILAY=1,NLAY; DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL
IC1=MAX(ICOL-1,1); IC2=MIN(ICOL+1,IDF%NCOL)
IR1=MAX(IROW-1,1); IR2=MIN(IROW+1,IDF%NROW)
IL1=MAX(ILAY-1,1); IL2=MIN(ILAY+1,NLAY)
IF(BND(ILAY)%X(ICOL,IROW).LT.0)THEN
IF((BND(ILAY)%X(ICOL,IR1 ).LE.0).AND. & !N
(BND(ILAY)%X(ICOL,IR2 ).LE.0).AND. & !S
(BND(ILAY)%X(IC1,IROW ).LE.0).AND. & !W
(BND(ILAY)%X(IC2,IROW ).LE.0).AND. & !E
(BND(IL1 )%X(ICOL,IROW).LE.0).AND. & !T
(BND(IL2 )%X(ICOL,IROW).LE.0))THEN !B
BND(ILAY)%X(ICOL,IROW)=0
END IF
END IF
ENDDO; ENDDO; ENDDO
END SUBROUTINE PMANAGER_SAVEMF2005_CONSISTENCY
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_NAM(FNAME,DIR,DIRMNAME,IPRT)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(OUT) :: IPRT
CHARACTER(LEN=*),INTENT(IN) :: FNAME
CHARACTER(LEN=*),INTENT(OUT) :: DIR,DIRMNAME
INTEGER :: IU
CHARACTER(LEN=52) :: MNAME
PMANAGER_SAVEMF2005_NAM=.FALSE.
!## result folder
DIR=FNAME(:INDEX(FNAME,'\',.TRUE.)-1); DIR=UTL_CAP(DIR,'U')
!## modelname
MNAME=FNAME(INDEX(FNAME,'\',.TRUE.)+1:INDEX(FNAME,'.',.TRUE.)-1)
MNAME=UTL_CAP(MNAME,'U')
!## result folder including the modelname
DIRMNAME='.\MODELINPUT\'//TRIM(MNAME)
MXNLAY=NLAY
CALL UTL_CREATEDIR(DIR)
IPRT=6 !## write to screen
IPRT=UTL_GETUNIT(); CALL OSD_OPEN(IPRT,FILE=TRIM(DIR)//'\USED_FILES.TXT',STATUS='UNKNOWN',ACTION='WRITE')
CALL UTL_CREATEDIR(TRIM(DIR)//'\MODELINPUT')
!## 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)
IF(.NOT.LMODFLOW2005)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(LPCGN)WRITE(IU,'(A)') 'PCGN 15 '//CHAR(39)//TRIM(DIRMNAME)//'.PCGN'//CHAR(39)
IF(LSIP) WRITE(IU,'(A)') 'SIP 15 '//CHAR(39)//TRIM(DIRMNAME)//'.SIP'//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(LMODFLOW2005)THEN
WRITE(IU,'(A,I3,A)') 'DATA(BINARY) ',IHEDUN,' '//CHAR(39)//TRIM(DIRMNAME)//'_HEAD.DAT'//CHAR(39)
WRITE(IU,'(A,I3,A)') 'DATA(BINARY) ',IBCFCB,' '//CHAR(39)//TRIM(DIRMNAME)//'_FBCF.DAT'//CHAR(39)
IF(LRCH)WRITE(IU,'(A,I3,A)') 'DATA(BINARY) ',IRCHCB,' '//CHAR(39)//TRIM(DIRMNAME)//'_FRCH.DAT'//CHAR(39)
IF(LEVT)WRITE(IU,'(A,I3,A)') 'DATA(BINARY) ',IEVTCB,' '//CHAR(39)//TRIM(DIRMNAME)//'_FEVT.DAT'//CHAR(39)
IF(LDRN.OR.LOLF)WRITE(IU,'(A,I3,A)') 'DATA(BINARY) ',IDRNCB,' '//CHAR(39)//TRIM(DIRMNAME)//'_FDRN.DAT'//CHAR(39)
IF(LRIV.OR.LISG)WRITE(IU,'(A,I3,A)') 'DATA(BINARY) ',IRIVCB,' '//CHAR(39)//TRIM(DIRMNAME)//'_FRIV.DAT'//CHAR(39)
IF(LGHB)WRITE(IU,'(A,I3,A)') 'DATA(BINARY) ',IGHBCB,' '//CHAR(39)//TRIM(DIRMNAME)//'_FGHB.DAT'//CHAR(39)
IF(LCHD)WRITE(IU,'(A,I3,A)') 'DATA(BINARY) ',ICHDCB,' '//CHAR(39)//TRIM(DIRMNAME)//'_FCHD.DAT'//CHAR(39)
IF(LWEL)WRITE(IU,'(A,I3,A)') 'DATA(BINARY) ',IWELCB,' '//CHAR(39)//TRIM(DIRMNAME)//'_FWEL.DAT'//CHAR(39)
IF(LSFR)THEN
WRITE(IU,'(A,I3,A)') 'DATA(BINARY) ',ISFRCB,' '//CHAR(39)//TRIM(DIRMNAME)//'_FSFR.DAT'//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(BINARY) ',IFHBCB ,' '//CHAR(39)//TRIM(DIRMNAME)//'_FFHB.DAT'//CHAR(39)
IF(LLAK)WRITE(IU,'(A,I3,A)') 'DATA(BINARY) ',ILAKCB ,' '//CHAR(39)//TRIM(DIRMNAME)//'_FLAK.DAT'//CHAR(39)
IF(LUZF)WRITE(IU,'(A,I3,A)') 'DATA(BINARY) ',IUZFCB1,' '//CHAR(39)//TRIM(DIRMNAME)//'_FUZF.DAT'//CHAR(39)
IF(LMNW)WRITE(IU,'(A,I3,A)') 'DATA(BINARY) ',IWL2CB ,' '//CHAR(39)//TRIM(DIRMNAME)//'_FMNW.DAT'//CHAR(39)
ELSE
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'//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'
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(IDF); IFULL=0
IF(.NOT.PMANAGER_INIT_SIMAREA(IDF,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)
!## compute dimensions of submodel
CALL UTL_IDFSNAPTOGRID(SUBMODEL(1),SUBMODEL(3),SUBMODEL(2),SUBMODEL(4),SUBMODEL(5),IDF%NCOL,IDF%NROW)
IF(SUBMODEL(1).GT.IDF%XMIN)IFULL(1)=1; IF(SUBMODEL(2).GT.IDF%YMIN)IFULL(2)=1
IF(SUBMODEL(3).LT.IDF%XMAX)IFULL(3)=1; IF(SUBMODEL(4).LT.IDF%YMAX)IFULL(4)=1
IDF%XMIN=SUBMODEL(1); IDF%YMIN=SUBMODEL(2); IDF%XMAX=SUBMODEL(3); IDF%YMAX=SUBMODEL(4)
IDF%DX=SUBMODEL(5); IDF%DY=SUBMODEL(5);
IF(SUBMODEL(7).EQ.0.0)THEN
IDF%IEQ=0
ELSE
!## create non-equidistantial network
IF(.NOT.PMANAGER_SAVEMF2005_COARSEGRID(IDF,SUBMODEL(1)+SUBMODEL(6), &
SUBMODEL(2)+SUBMODEL(6), &
SUBMODEL(3)-SUBMODEL(6), &
SUBMODEL(4)-SUBMODEL(6),SUBMODEL(7)))RETURN
ENDIF
ENDIF
IF(.NOT.IDFALLOCATEX(IDF))RETURN
!## fill sx/sy variable in idf
IF(.NOT.IDFFILLSXSY(IDF))RETURN
ALLOCATE(BND(NLAY)); DO ILAY=1,SIZE(BND); CALL IDFNULLIFY(BND(ILAY)); ENDDO
ALLOCATE(SHD(NLAY)); DO ILAY=1,SIZE(SHD); CALL IDFNULLIFY(SHD(ILAY)); ENDDO
ALLOCATE(TOP(NLAY)); DO ILAY=1,SIZE(TOP); CALL IDFNULLIFY(TOP(ILAY)); ENDDO
ALLOCATE(BOT(NLAY)); DO ILAY=1,SIZE(BOT); CALL IDFNULLIFY(BOT(ILAY)); ENDDO
ALLOCATE(KDW(NLAY)); DO ILAY=1,SIZE(KDW); CALL IDFNULLIFY(KDW(ILAY)); ENDDO
ALLOCATE(VCW(NLAY-1)); DO ILAY=1,SIZE(VCW); CALL IDFNULLIFY(VCW(ILAY)); ENDDO
ALLOCATE(KHV(NLAY)); DO ILAY=1,SIZE(KHV); CALL IDFNULLIFY(KHV(ILAY)); ENDDO
IF(ISS.EQ.1)THEN
ALLOCATE(STO(NLAY)); DO ILAY=1,SIZE(STO); CALL IDFNULLIFY(STO(ILAY)); ENDDO
ALLOCATE(SPY(NLAY)); DO ILAY=1,SIZE(SPY); CALL IDFNULLIFY(SPY(ILAY)); ENDDO
ENDIF
IF(LLPF)THEN
ALLOCATE(KVV(NLAY-1)); DO ILAY=1,SIZE(KVV); CALL IDFNULLIFY(KVV(ILAY)); ENDDO
ALLOCATE(KVA(NLAY)); DO ILAY=1,SIZE(KVA); CALL IDFNULLIFY(KVA(ILAY)); ENDDO
ENDIF
IF(LANI)THEN
ALLOCATE(ANA(NLAY)); DO ILAY=1,SIZE(ANA); CALL IDFNULLIFY(ANA(ILAY)); ENDDO
ALLOCATE(ANF(NLAY)); 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(NLAY)); DO ILAY=1,SIZE(LBD); CALL IDFNULLIFY(LBD(ILAY)); ENDDO
ALLOCATE(LCD(NLAY)); 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(IDF,TOP(ILAY)); ENDDO
DO ILAY=1,SIZE(BOT); CALL IDFCOPY(IDF,BOT(ILAY)); ENDDO
DO ILAY=1,SIZE(KDW); CALL IDFCOPY(IDF,KDW(ILAY)); ENDDO
DO ILAY=1,SIZE(VCW); CALL IDFCOPY(IDF,VCW(ILAY)); ENDDO
DO ILAY=1,SIZE(KHV); CALL IDFCOPY(IDF,KHV(ILAY)); ENDDO
IF(LLPF)THEN
DO ILAY=1,SIZE(KVV); CALL IDFCOPY(IDF,KVV(ILAY)); ENDDO
DO ILAY=1,SIZE(KVA); CALL IDFCOPY(IDF,KVA(ILAY)); ENDDO
ENDIF
IF(ISS.EQ.1)THEN
DO ILAY=1,SIZE(STO); CALL IDFCOPY(IDF,STO(ILAY)); ENDDO
DO ILAY=1,SIZE(SPY); CALL IDFCOPY(IDF,SPY(ILAY)); ENDDO
ENDIF
IF(LANI)THEN
DO ILAY=1,SIZE(ANF); CALL IDFCOPY(IDF,ANF(ILAY)); ENDDO
DO ILAY=1,SIZE(ANA); CALL IDFCOPY(IDF,ANA(ILAY)); ENDDO
ENDIF
IF(LLAK)THEN
DO ILAY=1,SIZE(LBD); CALL IDFCOPY(IDF,LBD(ILAY)); ENDDO
DO ILAY=1,SIZE(LCD); CALL IDFCOPY(IDF,LCD(ILAY)); ENDDO
ENDIF
IF(LSFT)THEN
DO ILAY=1,SIZE(SFT); CALL IDFCOPY(IDF,SFT(ILAY)); ENDDO
ENDIF
PMANAGER_SAVEMF2005_SIM=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_SIM
!###======================================================================
LOGICAL FUNCTION PMANAGER_GETPACKAGES(IBATCH)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IBATCH
INTEGER :: ITOPIC
PMANAGER_GETPACKAGES=.FALSE.
LPCGN=.FALSE. !## option ?
LPWT =.FALSE.
!## cap
LMSP=.FALSE.; ITOPIC=1; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))LMSP=.TRUE.; ENDIF
IF(TOPICS(ITOPIC)%IACT_MODEL.EQ.0)LMSP=.FALSE.
!## ani
LANI=.FALSE.; ITOPIC=14; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))LANI=.TRUE.; ENDIF
IF(TOPICS(ITOPIC)%IACT_MODEL.EQ.0)LANI=.FALSE.
!## hfb
LHFB=.FALSE.; ITOPIC=15; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))LHFB=.TRUE.; ENDIF
IF(TOPICS(ITOPIC)%IACT_MODEL.EQ.0)LHFB=.FALSE.
!## wel
LWEL=.FALSE.; ITOPIC=21; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))LWEL=.TRUE.; ENDIF
IF(TOPICS(ITOPIC)%IACT_MODEL.EQ.0)LWEL=.FALSE.
!## drn
LDRN=.FALSE.; ITOPIC=22; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))LDRN=.TRUE.; ENDIF
IF(TOPICS(ITOPIC)%IACT_MODEL.EQ.0)LDRN=.FALSE.
!## riv
LRIV=.FALSE.; ITOPIC=23; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))LRIV=.TRUE.; ENDIF
IF(TOPICS(ITOPIC)%IACT_MODEL.EQ.0)LRIV=.FALSE.
!## evt
LEVT=.FALSE.; ITOPIC=24; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))LEVT=.TRUE.; ENDIF
IF(TOPICS(ITOPIC)%IACT_MODEL.EQ.0)LEVT=.FALSE.
!## ghb
LGHB=.FALSE.; ITOPIC=25; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))LGHB=.TRUE.; ENDIF
IF(TOPICS(ITOPIC)%IACT_MODEL.EQ.0)LGHB=.FALSE.
!## rch
LRCH=.FALSE.; ITOPIC=26; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))LRCH=.TRUE.; ENDIF
IF(TOPICS(ITOPIC)%IACT_MODEL.EQ.0)LRCH=.FALSE.
!## sof
LOLF=.FALSE.; ITOPIC=27; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))LOLF=.TRUE.; ENDIF
IF(TOPICS(ITOPIC)%IACT_MODEL.EQ.0)LOLF=.FALSE.
!## chd
LCHD=.FALSE.; ITOPIC=28; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))LCHD=.TRUE.; ENDIF
IF(TOPICS(ITOPIC)%IACT_MODEL.EQ.0)LCHD=.FALSE.
!## isg
LISG=.FALSE.; ITOPIC=29; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))LISG=.TRUE.; ENDIF
IF(TOPICS(ITOPIC)%IACT_MODEL.EQ.0)LISG=.FALSE.
!## sfr
LSFR=.FALSE.; ITOPIC=30; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))LSFR=.TRUE.; ENDIF
IF(TOPICS(ITOPIC)%IACT_MODEL.EQ.0)LSFR=.FALSE.
!## fhb
LFHB=.FALSE.; ITOPIC=31; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))LFHB=.TRUE.; ENDIF
IF(TOPICS(ITOPIC)%IACT_MODEL.EQ.0)LFHB=.FALSE.
!## lak
LLAK=.FALSE.; ITOPIC=32; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))LLAK=.TRUE.; ENDIF
IF(TOPICS(ITOPIC)%IACT_MODEL.EQ.0)LLAK=.FALSE.
!## pcg
LPCG=.FALSE.; ITOPIC=33; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))LPCG=.TRUE.; ENDIF
IF(TOPICS(ITOPIC)%IACT_MODEL.EQ.0)LPCG=.FALSE.
!## uzf
LUZF=.FALSE.; ITOPIC=18; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))LUZF=.TRUE.; ENDIF
IF(TOPICS(ITOPIC)%IACT_MODEL.EQ.0)LUZF=.FALSE.
IF(LUZF)THEN
IF(LAYCON(1).NE.2)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'It is compulsory to use an unconfined first model layer for the UZF package','Error')
RETURN
ENDIF
ENDIF
!## mnw
LMNW=.FALSE.; ITOPIC=19; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))LMNW=.TRUE.; ENDIF
IF(TOPICS(ITOPIC)%IACT_MODEL.EQ.0)LMNW=.FALSE.
!## sft
LSFT=.FALSE.; ITOPIC=17; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))LSFT=.TRUE.; ENDIF
IF(TOPICS(ITOPIC)%IACT_MODEL.EQ.0)LSFT=.FALSE.
!## pst
LPST=.FALSE.; ITOPIC=20; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))LPST=.TRUE.; ENDIF
IF(TOPICS(ITOPIC)%IACT_MODEL.EQ.0)LPST=.FALSE.
IF(.NOT.LPCG)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'It is compulsory to add a solver, e.g. PCG','Error')
RETURN
ENDIF
!## save settings for iMOD GUI
IF(IBATCH.EQ.0)THEN
!## save all heads
ALLOCATE(PBMAN%SAVESHD(1)); PBMAN%SAVESHD(1)=-1
!## save all fluxes
ALLOCATE(PBMAN%SAVEFLX(1)); PBMAN%SAVEFLX(1)=-1
IF(LUZF)THEN
ALLOCATE(PBMAN%SAVEUZF(1)); PBMAN%SAVEUZF(1)=1
ENDIF
IF(LSFR)THEN
ALLOCATE(PBMAN%SAVESFR(1)); PBMAN%SAVESFR(1)=1
ENDIF
IF(LWEL)THEN
ALLOCATE(PBMAN%SAVEWEL(1)); PBMAN%SAVEWEL(1)=-1
ENDIF
IF(LDRN.OR.LOLF)THEN
ALLOCATE(PBMAN%SAVEDRN(1)); PBMAN%SAVEDRN(1)=-1
ENDIF
IF(LRIV.OR.LISG)THEN
ALLOCATE(PBMAN%SAVERIV(1)); PBMAN%SAVERIV(1)=-1
ENDIF
IF(LGHB)THEN
ALLOCATE(PBMAN%SAVEGHB(1)); PBMAN%SAVEGHB(1)=-1
ENDIF
IF(LRCH)THEN
ALLOCATE(PBMAN%SAVERCH(1)); PBMAN%SAVERCH(1)=1
ENDIF
IF(LEVT)THEN
ALLOCATE(PBMAN%SAVEEVT(1)); PBMAN%SAVEEVT(1)=1
ENDIF
IF(LMNW)THEN
ALLOCATE(PBMAN%SAVEMNW(1)); PBMAN%SAVEMNW(1)=-1
ENDIF
IF(LLAK)THEN
ALLOCATE(PBMAN%SAVELAK(1)); PBMAN%SAVELAK(1)=-1
ENDIF
IF(LFHB)THEN
ALLOCATE(PBMAN%SAVEFHB(1)); PBMAN%SAVEFHB(1)=-1
ENDIF
PBMAN%MINKD=0.0
PBMAN%MINC =0.0
PBMAN%IFVDL=0
ENDIF
PMANAGER_GETPACKAGES=.TRUE.
END FUNCTION PMANAGER_GETPACKAGES
!####====================================================================
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(NLAY),ILIST(1))
!## bnd settings
ITOPIC=4; SCL_D=0; SCL_U=1; ILIST=ITOPIC; IF(PMANAGER_GETFNAMES(1,NLAY,0,1,0).LE.0)RETURN
DO ILAY=1,NLAY
CALL IDFCOPY(IDF,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(BND(ILAY))
ENDDO
!## shd settings
ITOPIC=5; SCL_D=1; SCL_U=2; ILIST=ITOPIC; IF(PMANAGER_GETFNAMES(1,NLAY,0,1,0).LE.0)RETURN
DO ILAY=1,NLAY
CALL IDFCOPY(IDF,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,ILIST)
PMANAGER_SAVEMF2005_BAS_READ=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_BAS_READ
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_BAS_SAVE(DIR,DIRMNAME,IBATCH)
!####====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME
INTEGER,INTENT(IN) :: IBATCH
INTEGER :: IU,ILAY,IFBND
PMANAGER_SAVEMF2005_BAS_SAVE=.FALSE.
IF(IBATCH.EQ.0)CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIRMNAME)//'.BAS6'//'...')
IF(IBATCH.EQ.1)WRITE(*,'(/1X,A)') 'Writing '//TRIM(DIRMNAME)//'.BAS6'//'...'
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIRMNAME)//'.BAS6',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# BAS6 File Generated by '//TRIM(UTL_IMODVERSION())
IF(PCG%IQERROR.EQ.0)THEN
WRITE(IU,'(A)') 'FREE'
ELSE
WRITE(IU,'(A,G10.5)') 'FREE STOPERROR ',PCG%QERROR
ENDIF
IFBND=0
DO ILAY=1,NLAY
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,'E',7))
IFBND=1
DO ILAY=1,NLAY
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\BAS6\STRT_L'//TRIM(ITOS(ILAY))//'.ARR', &
SHD(ILAY),0,IU,ILAY,IFBND))RETURN
ENDDO
CLOSE(IU)
PMANAGER_SAVEMF2005_BAS_SAVE=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_BAS_SAVE
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_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),ILIST(1))
!## check top/bottom
LTB=.TRUE.; IINV=0
!## top settings
SCL_D=1; SCL_U=2
DO ILAY=1,NLAY
!## top data
ITOPIC=2; LEX=.FALSE.
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))THEN
ILIST=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
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,TOP(ILAY),0,ITOPIC)
LEX=.TRUE.
ENDIF
ENDIF
IF(.NOT.LEX)THEN; TOP(ILAY)%X=0.0; LTB=.FALSE.; ENDIF
!## bot data
ITOPIC=3; LEX=.FALSE.
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))THEN
ILIST=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
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,BOT(ILAY),0,ITOPIC)
LEX=.TRUE.
ENDIF
ENDIF
IF(.NOT.LEX)THEN; BOT(ILAY)%X=0.0; LTB=.FALSE.; ENDIF
ENDDO
DEALLOCATE(FNAMES,ILIST)
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,KPER,ITOPIC,ICOL,IROW
INTEGER,ALLOCATABLE,DIMENSION(:) :: LCBD
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())
LINE=TRIM(ITOS(NLAY))//','//TRIM(ITOS(IDF%NROW))//','//TRIM(ITOS(IDF%NCOL))//','//TRIM(ITOS(NPER))//',4,2'
WRITE(IU,'(A)') TRIM(LINE)
ALLOCATE(LCBD(NLAY))
!## laycbd code
LINE=''
DO ILAY=1,NLAY
IF(ILAY.LT.NLAY)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(IDF%IEQ.EQ.0)THEN
WRITE(IU,'(A)') 'CONSTANT '//TRIM(RTOS(IDF%DX,'E',7)); WRITE(IU,'(A)') 'CONSTANT '//TRIM(RTOS(IDF%DY,'E',7))
ELSE
WRITE(IU,'(A)') 'INTERNAL,1.0,(FREE),-1'
WRITE(IU,*) (IDF%SX(ICOL)-IDF%SX(ICOL-1),ICOL=1,IDF%NCOL)
WRITE(IU,'(A)') 'INTERNAL,1.0,(FREE),-1'
WRITE(IU,*) (IDF%SY(IROW-1)-IDF%SY(IROW),IROW=1,IDF%NROW)
ENDIF
DO ILAY=1,NLAY
ITOPIC=2
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\DIS6\TOP_L'//TRIM(ITOS(ILAY))//'.ARR', &
TOP(ILAY),0,IU,ILAY,ITOPIC))RETURN
!## quasi-3d scheme add bot aquifer modellayer
IF(LQBD.OR.ILAY.EQ.NLAY)THEN
ITOPIC=3
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(TRIM(DIR)//'\DIS6\BOTM_L'//TRIM(ITOS(ILAY))//'.ARR', &
BOT(ILAY),0,IU,ILAY,ITOPIC))RETURN
ENDIF
ENDDO
!## time information
DO KPER=1,NPER
!## set delt.eq.1 otherwise crash in UZF package
IF(SIM(KPER)%DELT.EQ.0.0)THEN
LINE=TRIM(RTOS(1.0,'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.0)LINE=TRIM(LINE)//',SS'
IF(SIM(KPER)%DELT.NE.0.0)LINE=TRIM(LINE)//',TR'
LINE=TRIM(LINE)//' ['//TRIM(SIM(KPER)%CDATE)//']'
WRITE(IU,'(A)') TRIM(LINE)
ENDDO
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),ILIST(1))
DO ILAY=1,NLAY
!## transient simulation
IF(ISS.EQ.1)THEN
!## sf1
ITOPIC=11; SCL_D=1; SCL_U=2; IINV=0
ILIST=ITOPIC; IF(PMANAGER_GETFNAMES(ILAY,ILAY,0,1,0).LE.0)RETURN
IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(IDF,ITOPIC,1,SCL_D,SCL_U,IINV,IPRT))RETURN
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,IDF,0,ITOPIC)
ENDIF
!## kdw
ITOPIC=6; SCL_D=1; SCL_U=3; IINV=0
ILIST=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.NLAY)THEN
!## vcont
ITOPIC=9; SCL_D=1; SCL_U=6; IINV=1
ILIST=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,ILIST)
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
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,'E',7))//',0,1.0,1,0'
IF(PBMAN%MINKD.NE.0.0)LINE=TRIM(LINE)//',MINKD '//TRIM(RTOS(PBMAN%MINKD,'G',5))
IF(PBMAN%MINC .NE.0.0)LINE=TRIM(LINE)//',MINC ' //TRIM(RTOS(PBMAN%MINC ,'G',5))
WRITE(IU,'(A)') TRIM(LINE)
!## ltype code
LINE=''; DO ILAY=1,NLAY; 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.0' !## trpy
IFBND=1
DO ILAY=1,NLAY
!## 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.NLAY)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 :: T,T1,T2,T3
PMANAGER_SAVEMF2005_LPF_READ=.TRUE.
!## use lpf6
IF(.NOT.LLPF)RETURN
ALLOCATE(FNAMES(1),ILIST(1))
PMANAGER_SAVEMF2005_LPF_READ=.FALSE.
DO ILAY=1,NLAY
!## hk
ITOPIC=7; SCL_D=1; SCL_U=3; IINV=0
ILIST=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
ILIST=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
ILIST=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
ILIST=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.NLAY)THEN
!## kvv
ITOPIC=10; SCL_D=1; SCL_U=3; IINV=0
ILIST=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,NLAY; DO IROW=1,IDF%NROW; DO ICOL=1,IDF%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,NLAY-1; DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL
IF(BND(ILAY )%X(ICOL,IROW).NE.0.AND. &
BND(ILAY+1)%X(ICOL,IROW).NE.0)THEN
!## top aquifer
T =0.5*(TOP(ILAY)%X(ICOL,IROW)-BOT(ILAY)%X(ICOL,IROW))
T1=0.0; IF(KHV(ILAY)%X(ICOL,IROW).GT.0.0)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.0
!## zero permeability - make sure resistance is equal to minc
IF(KVV(ILAY)%X(ICOL,IROW).LE.0.0)THEN
IF(T.GT.0.0)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.0
ENDIF
ENDIF
T2=T/KVV(ILAY)%X(ICOL,IROW)
!## bottom aquifer
T =0.5*(TOP(ILAY+1)%X(ICOL,IROW)-BOT(ILAY+1)%X(ICOL,IROW))
T3=0.0; IF(KHV(ILAY+1)%X(ICOL,IROW).GT.0.0)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,ILIST)
PMANAGER_SAVEMF2005_LPF_READ=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_LPF_READ
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_LPF_SAVE(DIR,DIRMNAME,IBATCH,ISS)
!####====================================================================
IMPLICIT NONE
REAL,PARAMETER :: WETDRYTHRESS=0.1 !1.0 <- converges
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME
INTEGER,INTENT(IN) :: IBATCH,ISS
REAL :: WETFCT,T
INTEGER :: IU,ILAY,IFBND,IHDWET,IWETIT,IROW,ICOL
PMANAGER_SAVEMF2005_LPF_SAVE=.TRUE.
!## use lpf6
IF(.NOT.LLPF)RETURN
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,'E',7))//',0,STORAGECOEFFICIENT,THICKSTRT,CONSTANTCV'
IF(PBMAN%MINKD.NE.0.0)LINE=TRIM(LINE)//',MINKD '//TRIM(RTOS(PBMAN%MINKD,'G',5))
IF(PBMAN%MINC .NE.0.0)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,NLAY
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,NLAY; 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,NLAY; LINE=TRIM(LINE)//'1.0,'
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,NLAY; 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,NLAY
!## 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,NLAY
!## 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.NLAY)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
IDF%X=0.0
DO IROW=1,IDF%NROW; DO ICOL=1,IDF%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.NLAY)THEN
IDF%X(ICOL,IROW)=-MIN(WETDRYTHRESS,T)
ELSE
IDF%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', &
IDF,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_ANI_READ(IPRT)
!####====================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IPRT
INTEGER :: ILAY,SCL_D,SCL_U,IINV,ITOPIC,NTOP,NSYS,ISYS,KTOP,ICNST
REAL :: 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,NLAY; ANF(ILAY)%X=1.0; ANA(ILAY)%X=0.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.0,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.0,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,NLAY
!## 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 :: X,Y,Q,Z1,Z2,FCT,IMP,CNST
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,ALLOCATABLE,DIMENSION(:) :: TLP,KH,TP,BT
INTEGER(KIND=8) :: ITIME,JTIME
REAL,PARAMETER :: MINKHT=0.0
INTEGER,PARAMETER :: ICLAY=1 !## shift to nearest aquifer
IF(.NOT.LEX)THEN; PMANAGER_SAVEMF2005_WEL=.TRUE.; RETURN; ENDIF
PMANAGER_SAVEMF2005_WEL=.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
!## header
LINE='NaN1#,'//TRIM(ITOS(ICB))//' NOPRINT'
WRITE(IU,'(A)') TRIM(LINE)
!## fill tlp for each modellayer
ALLOCATE(TLP(NLAY),KH(NLAY),TP(NLAY),BT(NLAY))
WRITE(FRM,'(A9,I2.2,A15)') '(3(I5,1X),',1,'(G15.7,1X),I10)'
!## create subfolders
CALL UTL_CREATEDIR(TRIM(DIR)//'\'//CPCK//'7')
!## maximum number of well in simulation
MP=0
IOS=0
DO IPER=1,NPER
!## 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
KPER=ABS(KPER)
!## output
WRITE(IPRT,'(1X,A,2I10,2(1X,I14))') 'Exporting timestep ',IPER,KPER,ITIME,JTIME
!## reuse previous timestep
IF(KPER.LE.0)THEN
IF(IPER.EQ.1)THEN; WRITE(IU,'(I10)') 0
ELSE; WRITE(IU,'(I10)') -1; ENDIF
!## goto next timestep
CYCLE
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.0)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(NLAY,ICOL,IROW,BND,TOP,BOT,KDW,TP,BT,KH)
CALL UTL_PCK_GETTLP(NLAY,TLP,KH,TP,BT,Z1,Z2,MINKHT,ICLAY)
!## find uppermost layer
ELSE
IF(ILAY.EQ.-1)THEN; DO ILAY=1,NLAY; IF(BND(ILAY)%X(ICOL,IROW).GT.0)EXIT; ENDDO; ENDIF
!## outside current model dimensions, set ilay=0
IF(ILAY.GT.NLAY)ILAY=0; TLP=0.0; IF(ILAY.NE.0)TLP(ILAY)=1.0
ENDIF
IF(IEXT.GT.0)THEN
IF(.NOT.UTL_PCK_READTXT(2,ITIME,JTIME,Q,TRIM(CDIR)//'\'//TRIM(ID)//'.'//TRIM(EXT),0,'',ISS))THEN
IOS=-1; EXIT
ENDIF
ENDIF
!## use factor/impulse
Q=Q*FCT; Q=Q+IMP
IF(Q.NE.0.0)THEN
DO ILAY=1,NLAY
IF(TLP(ILAY).GT.0.0)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(NP.GT.0)THEN; CLOSE(JU)
ELSE; CLOSE(JU,STATUS='DELETE'); ENDIF
IF(IOS.NE.0)EXIT
!## store maximum number of well in simulation
MP=MAX(MP,NP)
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.0 (FREE) -1'
ENDIF
ENDDO
CLOSE(IU); DEALLOCATE(TLP,TP,BT,KH)
IF(IOS.EQ.0)THEN
CALL PMANAGER_SAVEMF2005_MAXNO(TRIM(DIRMNAME)//'.'//CPCK//'7_',(/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 :: X,Y,Q,Z1,Z2,FCT,IMP,CNST,RW,RSKIN,KSKIN
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,NPER
!## 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.NPER)KPER=0
!## store maximum number of well in simulation
ALLOCATE(NP_IPER(0:NPER)); NP_IPER=0; LPER=0
!## fill static-time independent information
DO IPER=0,NPER
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))THEN
IOS=-1; EXIT
ENDIF
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:NPER))
IF(IOS.EQ.0)THEN
CALL PMANAGER_SAVEMF2005_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,PARAMETER :: CONST=86400.0 !## conversion to m3/day
REAL,PARAMETER :: DLEAK=0.0001
INTEGER,INTENT(IN) :: IBATCH,ICB,ITOPIC,IPRT
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME,CPCK
LOGICAL,INTENT(IN) :: LEX
REAL :: FCT,IMP,CNST
CHARACTER(LEN=256) :: SFNAME,EXFNAME
CHARACTER(LEN=30) :: FRM
INTEGER :: IU,JU,ILAY,I,ISYS,KPER,IPER,NTOP,NSYS,ICNST
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(NLAY)
NP=0
DO IPER=1,NPER
!## reset only for isg to riv conversion
IF(ITOPIC.EQ.29)NP=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
!## 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.0)GRIDISG%ISTEADY=1
GRIDISG%IDIM=0
GRIDISG%CS=BND(1)%DX !## cellsize
GRIDISG%MINDEPTH=0.1
GRIDISG%WDEPTH=0.0
GRIDISG%ICDIST=1 !## compute influence of structures
GRIDISG%ISIMGRO=0 !## no simgro
GRIDISG%IEXPORT=1 !## modflow river files
GRIDISG%ROOT=EXFNAME(1:INDEX(EXFNAME,'\',.TRUE.)-1) !## output folder
GRIDISG%POSTFIX=''
GRIDISG%NODATA=-999.99
GRIDISG%ISAVE=1
GRIDISG%MAXWIDTH=1000.0
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
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,NLAY,ILAY,TOP,BOT,KHV,BND,VCW,IBATCH,NP,JU,GRIDISG,SFT,LSFT))EXIT
!## open sfr file
CASE (30)
IF(.NOT.ISG2SFR(BND(1)%NROW,BND(1)%NCOL,NLAY,ILAY,IPER,NPER,NP,JU,GRIDISG,EXFNAME))EXIT
END SELECT
CALL ISGDEAL(1); CALL ISGCLOSEFILES()
ELSE
!## stop processing
CLOSE(IU); CALL PMANAGER_SAVEMF2005_DEALLOCATEPCK(); RETURN
ENDIF
ENDDO
!## only for river package usage of external filename
IF(ITOPIC.EQ.29)THEN
LINE=TRIM(ITOS(NP(1))); WRITE(IU,'(A)') TRIM(LINE)
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()
CALL PMANAGER_SAVEMF2005_MAXNO(TRIM(DIRMNAME)//'.'//CPCK//'7_',(/NP/))
PMANAGER_SAVEMF2005_ISG=.TRUE.
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 :: 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,ALLOCATABLE,DIMENSION(:) :: TLP,KH,TP,BT,XTMP
INTEGER(KIND=8) :: ITIME,JTIME
REAL,PARAMETER :: MINKHT=0.0
INTEGER,PARAMETER :: ICLAY=1 !## shift to nearest aquifer
INTEGER :: JD0,JD1,ISEC0,ISEC1,NUZGAG,IRUNFLG,IEQUAL,ICHECK
INTEGER,ALLOCATABLE,DIMENSION(:,:) :: JEQUAL
REAL :: DDAY,DSEC
IF(.NOT.LEX)THEN; PMANAGER_SAVEMF2005_PCK=.TRUE.; RETURN; ENDIF
PMANAGER_SAVEMF2005_PCK=.FALSE.
CPCK=CPCKIN
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
!## 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,10,30,'//TRIM(ITOS(NUZGAG))//',0.5'; 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
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'
WRITE(IU,'(A)') TRIM(LINE)
!## IFVDL SFT RCNC
!## evt
CASE (24); NEVTOP=1; LINE='NaN1#,'//TRIM(ITOS(ICB)); WRITE(IU,'(A)') TRIM(LINE)
!## NEVTOP moet twee worden voor optie laag = -1
!## ghb
CASE (25)
LINE='NaN1#,'//TRIM(ITOS(ICB))//' NOPRINT'
WRITE(IU,'(A)') TRIM(LINE)
!## rch
CASE (26); NRCHOP=1; LINE='NaN1#,'//TRIM(ITOS(ICB)); 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
WRITE(IU,'(A)') TRIM(LINE)
!## chd
CASE (28)
LINE='NaN1# NOPRINT NEGBND'
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,NLAY
DO IROW=1,IDF%NROW; DO ICOL=1,IDF%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(NPER)); FHBNBDTIM=0.0
!## get first stress-period
NBDTIM=0
DO I=1,NPER; IF(SIM(I)%DELT.NE.0.0)EXIT; ENDDO
!## add steady-state
IF(I.NE.1)NBDTIM=1
!## transient periods still available
IF(I.LE.NPER)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.0)THEN
DSEC=ISEC1
ELSE
DSEC=ISEC0+ISEC1
ENDIF
NBDTIM=NBDTIM+1
FHBNBDTIM(NBDTIM)=DDAY+REAL(DSEC)/86400.0
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(NLAY),KH(NLAY),TP(NLAY),BT(NLAY))
!## see whether information is equal to previous timestep - only for rch and evt
LPER=0
ALLOCATE(NP_IPER(0:NPER)); NP_IPER=0
!## maximum number of input per simulation
MP=0; NBDTIM=0
DO IPER=1,NPER
!## 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
!## 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.0000000E-00'; ENDDO
ELSE; WRITE(IU,'(A)') '-1,-1,-1'; ENDIF
!## rch
CASE (26)
IF(IPER.EQ.1)THEN; WRITE(IU,'(I10)') 0; WRITE(IU,'(A)') 'CONSTANT 0.0000000E-00'
ELSE; WRITE(IU,'(I10)') -1; ENDIF
!## wel,drn,riv,ghb,rch,chd,olf
CASE (21,22,23,25,27,28,29)
IF(IPER.EQ.1)THEN; WRITE(IU,'(I10)') 0
ELSE; WRITE(IU,'(I10)') -1; 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.0
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)//'.'//CHAR(13)//'If you want this, use the RUNFILE option instead','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.0 (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)
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
!## 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,ghg
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.0,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.001
IF(ILAY.LE.0)NUZTOP=3
!## not checking for inactive cells
ICHECK=0
!## evt
CASE (24)
IF(KTOP.EQ.1)FCT=FCT*0.001
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.001
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.0
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,NLAY; IF(BND(ILAY)%X(ICOL,IROW).GT.0)EXIT; ENDDO
!## overrule for the first active layer
IF(ILAY.LE.NLAY)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.0
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.0)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)
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
!## 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.0)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.0
!## assign to several layer based upon top/bot
IF(PCK(1)%ILAY.EQ.0)THEN
!## get filter fractions
CALL PMANAGER_SAVEMF2005_PCK_ULSTRD_PARAM(NLAY,ICOL,IROW,BND,TOP,BOT,KDW,TP,BT,KH)
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(NLAY,TLP,KH,TP,BT,Z1,Z2,MINKHT,ICLAY)
!## find uppermost layer
ELSEIF(PCK(1)%ILAY.EQ.-1)THEN
DO ILAY=1,NLAY; IF(BND(ILAY)%X(ICOL,IROW).GT.0)EXIT; ENDDO
!## assign to uppermost active layer
IF(ILAY.LE.NLAY)TLP(ILAY)=1.0
ELSE
!## assign to predefined layer
TLP(PCK(1)%ILAY)=1.0
ENDIF
DO ILAY=1,NLAY
!## not put into model layer
IF(TLP(ILAY).LE.0.0)CYCLE
!## write specific packages
SELECT CASE (ITOPIC)
!## chd
CASE (28)
IF(BND(ILAY)%X(ICOL,IROW).LT.0)THEN
IF(PBMAN%SSYSTEM.EQ.1)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
!## olf
CASE (27)
OLFCOND=(IDFGETAREA(PCK(JTOP(1)),ICOL,IROW)/COLF) !## drainage conductance
IF(PBMAN%SSYSTEM.EQ.1)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.0)THEN
DO I=1,NTOP; XTMP(I)=PCK(I)%X(ICOL,IROW); ENDDO
XTMP(1)=XTMP(1)*TLP(ILAY)
JSYS=1; IF(PBMAN%SSYSTEM.EQ.1)JSYS=ISYS
WRITE(JU,FRM) ILAY,IROW,ICOL,(XTMP(JTOP(I)),I=1,NTOP),JSYS
NP_IPER(IPER)=NP_IPER(IPER)+1
ENDIF
END SELECT
ENDDO
ENDDO; ENDDO
END SELECT
ENDDO
IF(ITOPIC.NE.31.AND. &
ITOPIC.NE.18.AND. &
ITOPIC.NE.24.AND. &
ITOPIC.NE.26)THEN
LINE=TRIM(ITOS(NP_IPER(IPER))); WRITE(IU,'(A)') TRIM(LINE)
ENDIF
!## maximum input per simulation
MP=MAX(MP,NP_IPER(IPER))
CLOSE(JU)
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
!## 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,NLAY; DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL
IF(BND(ILAY)%X(ICOL,IROW).EQ. 2)THEN
I=I+1; WRITE(IU,*) 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,NLAY; DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL
IF(BND(ILAY)%X(ICOL,IROW).EQ.-2)THEN
I=I+1; WRITE(IU,*) 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); NP_IPER(0)=NRCHOP
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
CALL PMANAGER_SAVEMF2005_MAXNO(TRIM(DIRMNAME)//'.'//CPCK//'7_',(/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,NPER
!## 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.NPER)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),ILIST(1)); ILIST=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(IDF,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.0)LAK(1)%X(ICOL,IROW)=0.0
IF(LAK(1)%X(ICOL,IROW).EQ.LAK(1)%NODATA)LAK(1)%X(ICOL,IROW)=0.0
ENDDO; ENDDO
ELSE
!## clean rest of input
CALL PMANAGER_SAVEMF2005_CORRECT(1,LAK,LAK(I),0,ITOPIC)
ENDIF
ENDDO
DEALLOCATE(FNAMES,ILIST)
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 :: 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.0 for all steady-state stress periods
!## a THETA of 0.5 represents the average lake stage during a time step.
!## a THETA of 1.0 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.01 to 0.5 have
!## been used successfully in test simulations. SURFDEP is read only if THETA is specified as a negative value.
THETA=-1.0; SSCNCR=0.001; NSSITR=100; SURFDEPTH=0.25
!## 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,NLAY
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,NLAY
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.001 !## prcplk,evaplk
CASE (9); IOP=1; FCT=1.0 !## rnf
CASE (10); IOP=1; FCT=1.0 !## 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 :: 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(IDF,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.0,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.0,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_MET(DIR,DIRMNAME)
!####====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIR,DIRMNAME
INTEGER :: IU,KPER
PMANAGER_SAVEMF2005_MET=.TRUE.
IF(LMODFLOW2005)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(IDF%XMIN,'F',2)) ; WRITE(IU,'(A)') TRIM(LINE)
LINE='COORD_YLL '//TRIM(RTOS(IDF%YMIN,'F',2)) ; WRITE(IU,'(A)') TRIM(LINE)
LINE='COORD_XLL_NB '//TRIM(RTOS(IDF%XMIN,'F',2)); WRITE(IU,'(A)') TRIM(LINE)
LINE='COORD_YLL_NB '//TRIM(RTOS(IDF%YMIN,'F',2)); WRITE(IU,'(A)') TRIM(LINE)
LINE='COORD_XUR_NB '//TRIM(RTOS(IDF%XMAX,'F',2)); WRITE(IU,'(A)') TRIM(LINE)
LINE='COORD_YUR_NB '//TRIM(RTOS(IDF%YMAX,'F',2)); WRITE(IU,'(A)') TRIM(LINE)
!## look for first
DO KPER=1,NPER; IF(SIM(KPER)%DELT.GT.0.0)EXIT; ENDDO
IF(KPER.LE.NPER)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)
!save_no_buf
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(IDF,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(NLAY)); 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(NLAY),IUDAT(NLAY)); IUGEN=0; IUDAT=0
DO ILAY=1,NLAY
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,IDF,LTB)
DO ILAY=1,NLAY
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 PMANAGER_SAVEMF2005_MAXNO(TRIM(DIRMNAME)//'.HFB7_',(/SUM(NHFBNP)/))
DEALLOCATE(NHFBNP)
PMANAGER_SAVEMF2005_HFB=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_HFB
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_OCD(DIRMNAME)
!####====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIRMNAME
INTEGER :: IU,ILAY,IPER
PMANAGER_SAVEMF2005_OCD=.FALSE.
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())
LINE='HEAD SAVE UNIT '//TRIM(ITOS(IHEDUN)); WRITE(IU,'(A)') TRIM(LINE)
DO IPER=1,NPER
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,NLAY; 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)
! IF(LCHD)THEN
! LINE='SAVE BUDGET '//TRIM(ITOS(ICHDCB)); DO ILAY=1,NLAY; LINE=TRIM(LINE)//' '//TRIM(ITOS(ILAY)); ENDDO; WRITE(IU,'(A)') TRIM(LINE)
! 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,NLAY; 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
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)
! LINE=TRIM(ITOS(PCG%))//','//TRIM(ITOS(ITER1))//','//TRIM(ITOS(NPCOND))
! WRITE(IU,'(A)') TRIM(LINE)
! LINE=TRIM(RTOS(HCLOSE,'E',7))//','//TRIM(RTOS(RCLOSE,'E',7))//','//TRIM(RTOS(RELAX,'E',7))//',1,1,0,1.0'
! WRITE(IU,'(A)') TRIM(LINE)
CLOSE(IU)
PMANAGER_SAVEMF2005_PCG=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_PCG
!####====================================================================
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.0,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.0,0.0,0.5,1.0'; WRITE(IU,'(A)') TRIM(LINE)
! LINE='0,0.0,0,0.0,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(IDF)
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(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(ILIST)) DEALLOCATE(ILIST)
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)
END SUBROUTINE PMANAGER_SAVEMF2005_DEALLOCATE
!####====================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_MSP(IBATCH)
!####====================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IBATCH
!## dummy variables
INTEGER :: ISYS,ILAY,ITOPIC,IPER,IINV,SCL_U,SCL_D
INTEGER :: I,J,NIDF
REAL,DIMENSION(:),ALLOCATABLE :: NODATA
CHARACTER(LEN=256) :: FFNAME
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(IDF%NCOL,IDF%NROW))
!## initialize unit numbers
INDSB=0; IAREA=0; ISELSVAT=0; IGWMP=0; IMODSIM=0; ISCAP=0; IINFI=0; IIDF =0
!## open indsb
FFNAME='svat2swnr_roff.inp'; INDSB=UTL_GETUNIT(); CALL OSD_OPEN(INDSB,FILE=FFNAME,STATUS='UNKNOWN',ACTION='WRITE')
!## open iarea
FFNAME='area_svat.inp'; IAREA=UTL_GETUNIT(); CALL OSD_OPEN(IAREA,FILE=FFNAME,STATUS='UNKNOWN',ACTION='WRITE')
!## open iscap
FFNAME='scap_svat.inp'; ISCAP=UTL_GETUNIT(); CALL OSD_OPEN(ISCAP,FILE=FFNAME,STATUS='UNKNOWN',ACTION='WRITE')
!## open igwmp
FFNAME='mod2svat.inp'; IGWMP=UTL_GETUNIT(); CALL OSD_OPEN(IGWMP,FILE=FFNAME,STATUS='UNKNOWN',ACTION='WRITE')
!## open MOD-SIM.TXT
FFNAME='MOD-SIM.TXT'; IMODSIM=UTL_GETUNIT(); CALL OSD_OPEN(IMODSIM,FILE=FFNAME,STATUS='UNKNOWN',ACTION='WRITE')
!## open iselsvat
FFNAME='sel_svat_bda.inp'; ISELSVAT=UTL_GETUNIT(); CALL OSD_OPEN(ISELSVAT,FILE=FFNAME,STATUS='UNKNOWN',ACTION='WRITE')
!## open infi_svat.inp
FFNAME='infi_svat.inp'; IINFI=UTL_GETUNIT(); OPEN(IINFI,FILE=FFNAME,STATUS='UNKNOWN',CARRIAGECONTROL='LIST',ACTION='WRITE')
!## open idf_svat.inp
FFNAME='idf_svat.inp'; IIDF=UTL_GETUNIT(); CALL OSD_OPEN(IIDF,FILE=FFNAME,STATUS='UNKNOWN',ACTION='WRITE')
!## open uscl_svat.inp
FFNAME='uscl_svat.inp'; IUSCL=UTL_GETUNIT(); CALL OSD_OPEN(IUSCL,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
!## open all files
DO ISYS=1,NIDF
!## skip ipf for artificial recharge
IF(IARMWP.EQ.1.AND.ISYS.EQ.8)CYCLE
SELECT CASE (ISYS)
CASE (1); NODATA(ISYS)=-999.99; SCL_U=1; SCL_D=0
CASE (2:5,7:9); NODATA(ISYS)=-999.99; SCL_U=7; SCL_D=0
CASE (6,12,13,20); NODATA(ISYS)=-999.99; SCL_U=2; SCL_D=1
CASE (21,22); NODATA(ISYS)=-999.99; SCL_U=2; SCL_D=0
CASE (18,19); NODATA(ISYS)=-999.99; SCL_U=6; SCL_D=0 !## scaling m/d -> reciprook -> m/d
CASE (14:17); NODATA(ISYS)=-999.99; SCL_U=6; SCL_D=0
CASE (10,11); NODATA(ISYS)=-999.99; SCL_U=5; SCL_D=0
END SELECT
!## read in data
! IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(IDF,ITOPIC,IPER,ISYS,ILAY,SCL_D,SCL_U,IINV))RETURN
SELECT CASE (ISYS)
CASE (1); SIMGRO%IBOUND=INT(IDF%X)
CASE (2); SIMGRO%LGN=INT(IDF%X)
CASE (3); SIMGRO%RZ=IDF%X
CASE (4); SIMGRO%BODEM=INT(IDF%X)
CASE (5); SIMGRO%METEO=INT(IDF%X)
CASE (6); SIMGRO%MV=IDF%X
CASE (7); SIMGRO%BEREGEN=INT(IDF%X)
CASE (8); SIMGRO%BER_LAAG=INT(IDF%X)
CASE (9); SIMGRO%BEREGEN_Q=IDF%X
CASE (10); SIMGRO%NOPP=IDF%X
CASE (11); SIMGRO%SOPP=IDF%X
CASE (12); SIMGRO%VXMU_SOPP=IDF%X
CASE (13); SIMGRO%VXMU_ROPP=IDF%X
CASE (14); SIMGRO%CRUNOFF_SOPP=IDF%X
CASE (15); SIMGRO%CRUNOFF_ROPP=IDF%X
CASE (16); SIMGRO%CRUNON_SOPP=IDF%X
CASE (17); SIMGRO%CRUNON_ROPP=IDF%X
CASE (18); SIMGRO%QINFBASIC_SOPP=IDF%X
CASE (19); SIMGRO%QINFBASIC_ROPP=IDF%X
CASE (20); SIMGRO%PWT_LEVEL=IDF%X
CASE (21); SIMGRO%MOISTURE=IDF%X
CASE (22); SIMGRO%COND=IDF%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)
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)
!## 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,'PARA_SIM.INP').GT.0)THEN
CALL PMANAGER_SAVEMF2005_MSP_PARASIM(FFNAME,IDF)
ELSE
CALL SYSTEM('COPY "'//TRIM(FFNAME)//'" /Y ')
ENDIF
ENDDO
ENDIF
!## metaswap 727 computing with recharge (possibility) if mete_grid.inp exists
! CALL PMANAGER_SAVEMF2005_MSP_METEGRID()
DEALLOCATE(SIMGRO,NODATA)
PMANAGER_SAVEMF2005_MSP=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_MSP
!###====================================================================
SUBROUTINE PMANAGER_SAVEMF2005_MSP_PARASIM(FNAME,IDF)
!###====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: FNAME
TYPE(IDFOBJ),INTENT(IN) :: IDF
INTEGER :: IU,JU,I,IOS
I=INDEX(FNAME,'\',.TRUE.)
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=FNAME,STATUS='OLD',ACTION='READ')
JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE='para_sim.inp',STATUS='REPLACE',ACTION='WRITE')
DO
READ(IU,'(A256)',IOSTAT=IOS) LINE
IF(IOS.NE.0)EXIT
WRITE(JU,'(A)') TRIM(LINE)
ENDDO
WRITE(JU,'(A)') '*'
WRITE(JU,'(A)') '* Parameters for IDF output'
WRITE(JU,'(A)') '*'
WRITE(JU,'(A)') ' idf_per = 1 ! Writing IDF files'
LINE=' idf_xmin = '//TRIM(RTOS(IDF%XMIN,'G',7))
WRITE(JU,'(A)') TRIM(LINE)
LINE=' idf_ymin = '//TRIM(RTOS(IDF%YMIN,'G',7))
WRITE(JU,'(A)') TRIM(LINE)
LINE=' idf_dx = '//TRIM(RTOS(IDF%DX,'G',7))
WRITE(JU,'(A)') TRIM(LINE)
LINE=' idf_dy = '//TRIM(RTOS(IDF%DY,'G',7))
WRITE(JU,'(A)') TRIM(LINE)
LINE=' idf_ncol = '//TRIM(ITOS(IDF%NCOL))
WRITE(JU,'(A)') TRIM(LINE)
LINE=' idf_nrow = '//TRIM(ITOS(IDF%NROW))
WRITE(JU,'(A)') TRIM(LINE)
LINE=' idf_nodata = '//TRIM(RTOS(HUGE(1.0),'G',7))
WRITE(JU,'(A)') TRIM(LINE)
CLOSE(JU)
END SUBROUTINE PMANAGER_SAVEMF2005_MSP_PARASIM
!###====================================================================
SUBROUTINE PMANAGER_SAVEMF2005_MSP_INPFILES(NODATA_PWT,IPFFILE,LPWT)
!###====================================================================
IMPLICIT NONE
LOGICAL :: LPWT
REAL,INTENT(IN) :: NODATA_PWT
CHARACTER(LEN=*),INTENT(IN) :: IPFFILE
INTEGER,PARAMETER :: AEND=0 !## no surfacewater units
INTEGER :: NUND,MDND,MDND2,IROW,ICOL,LYBE,TYBE,BEREGENID,JROW,JCOL,N,M,I,J,JU
REAL :: XC,YC,ARND,QBER
TYPE IPFOBJ
INTEGER :: ILAY
REAL :: X,Y,CAP
END TYPE IPFOBJ
TYPE(IPFOBJ),ALLOCATABLE,DIMENSION(:) :: IPF
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)CALL PRINTTEXT('IPF for artificial recharge should be at least 5 column, x,y,ilay,id,capacity',2)
DO I=1,M+1; READ(JU,*) ; ENDDO
IF(J.EQ.2)THEN; ALLOCATE(IPF(MDND)); IPF%ILAY=0; IPF%CAP=0.0; 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
NUND=0
DO IROW=1,IDF%NROW
DO ICOL=1,IDF%NCOL
IF(SIMGRO(ICOL,IROW)%IBOUND.LE.0)CYCLE
MDND=(IROW-1)*IDF%NCOL+ICOL
ARND=IDFGETAREA(IDF,ICOL,IROW)
ARND= ARND-SIMGRO(ICOL,IROW)%NOPP-SIMGRO(ICOL,IROW)%SOPP
!## rural area > 0
IF(ARND.GT.0.0)THEN
NUND=NUND+1
!## write idf_svat.inp - inside area of interest
WRITE(IIDF,'(3I10)') NUND,IROW,ICOL
!## write sel_svat_bda.inp
WRITE(ISELSVAT,'(I10)') NUND
!## 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.0, &
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
!## 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(IDF,JROW,JCOL,IPF(BEREGENID)%X,IPF(BEREGENID)%Y)
ENDIF
ENDIF
MDND2= (JROW-1)*IDF%NCOL+JCOL
MDND2=MDND2+(LYBE-1)*IDF%NCOL*IDF%NROW
IF(JROW.NE.0.AND.JCOL.NE.0)THEN
!## maximum groundwater abstraction mm/day fmmxabgw
IF(QBER.GT.0.0)THEN
IF(TYBE.EQ.1)THEN
WRITE(ISCAP,'(I10,F8.2,24X,I10,I6)') NUND,QBER,NUND,LYBE
ELSEIF(TYBE.EQ.2)THEN
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.MDND.NE.MDND2)THEN !LYBE.GT.1)THEN
WRITE(IGWMP,'(I10,2X,I10,I5)') MDND2,NUND,LYBE
WRITE(IMODSIM,'(I10,2X,I10,I5)') MDND2,NUND,LYBE
ENDIF
ENDIF
!## END scap_svat.inp - grondwater + ow
!## BEGIN mod2svat.inp; NB: als opp. water of glas dan laag = 0
WRITE(IGWMP ,'(I10,2X,I10,I5)') MDND,NUND,1
WRITE(IMODSIM,'(I10,2X,I10,I5)') MDND,NUND,1
IF(.NOT.LPWT)THEN
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
WRITE(IUSCL,'(I10,4F8.3,2I10)') NUND,SIMGRO(ICOL,IROW)%MOISTURE,SIMGRO(ICOL,IROW)%COND,1.0, &
SIMGRO(ICOL,IROW)%MV-SIMGRO(ICOL,IROW)%PWT_LEVEL,ICOL,IROW
ELSE
WRITE(IUSCL,'(I10,3F8.3,8X,2I10)') NUND,SIMGRO(ICOL,IROW)%MOISTURE,SIMGRO(ICOL,IROW)%COND,1.0,ICOL,IROW
ENDIF
ENDIF
!## END mod2svat.inp; NB: als opp. water of glas dan laag = 0
ENDIF
!## urban area (verhard)
ARND =IDFGETAREA(IDF,ICOL,IROW)
ARND =MIN(ARND,SIMGRO(ICOL,IROW)%SOPP) !< dit komt niet meer terug?
IF(ARND.GT.0.0)THEN
NUND=NUND+1
!## write sel_svat_bda.inp
WRITE(ISELSVAT,'(I10)') NUND
WRITE(IAREA,'(I10,F10.1,F8.3,8X,I6,16X,I6,F8.3,I10,2F8.2)') & !
NUND,ARND,SIMGRO(ICOL,IROW)%MV+MSWPMV,SIMGRO(ICOL,IROW)%BODEM,18,0.1,SIMGRO(ICOL,IROW)%METEO,1.0,1.0
WRITE(INDSB,'(2I10,F8.3,2F8.1)') NUND,0,SIMGRO(ICOL,IROW)%VXMU_SOPP,SIMGRO(ICOL,IROW)%CRUNOFF_SOPP,SIMGRO(ICOL,IROW)%CRUNON_SOPP
WRITE(IGWMP,'(I10,2X,I10,I5)') MDND,NUND,1
IF(.NOT.LPWT)THEN
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
WRITE(IUSCL,'(I10,4F8.3,2I10)') NUND,SIMGRO(ICOL,IROW)%MOISTURE,SIMGRO(ICOL,IROW)%COND,1.0, &
SIMGRO(ICOL,IROW)%MV-SIMGRO(ICOL,IROW)%PWT_LEVEL,ICOL,IROW
ELSE
WRITE(IUSCL,'(I10,3F8.3,8X,2I10)') NUND,SIMGRO(ICOL,IROW)%MOISTURE,SIMGRO(ICOL,IROW)%COND,1.0,ICOL,IROW
ENDIF
ENDIF
WRITE(IMODSIM,'(I10,2X,I10,I5)') MDND,NUND,1
!## write infi_svat.inp, infiltratiecapaciteit per cel, de rest -9999.
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(IARMWP.EQ.1)DEALLOCATE(IPF)
RETURN
END SUBROUTINE PMANAGER_SAVEMF2005_MSP_INPFILES
!###====================================================================
SUBROUTINE PMANAGER_SAVEMF2005_MSP_CHECK(NODATA)
!###====================================================================
IMPLICIT NONE
REAL,DIMENSION(:),INTENT(IN) :: NODATA
INTEGER,DIMENSION(:),ALLOCATABLE :: IERROR
INTEGER :: IROW,ICOL,STRLEN
REAL :: DXY,ARND
CHARACTER(LEN=:),ALLOCATABLE :: STR
IERROR=0
SIMGRO(1 ,1 )%IBOUND=0
SIMGRO(1 ,IDF%NROW)%IBOUND=0
SIMGRO(IDF%NCOL,1 )%IBOUND=0
SIMGRO(IDF%NCOL,IDF%NROW)%IBOUND=0
!## make sure that for sopp>0 there is a vxmu value, turn nopp otherwise off
DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL
IF(SIMGRO(ICOL,IROW)%VXMU_SOPP.EQ.NODATA(12))SIMGRO(ICOL,IROW)%SOPP=0.0
IF(SIMGRO(ICOL,IROW)%SOPP.GT.0.0)THEN
IF(SIMGRO(ICOL,IROW)%VXMU_SOPP .EQ.NODATA(12))SIMGRO(ICOL,IROW)%SOPP=0.0
IF(SIMGRO(ICOL,IROW)%CRUNOFF_SOPP .EQ.NODATA(14))SIMGRO(ICOL,IROW)%SOPP=0.0
IF(SIMGRO(ICOL,IROW)%CRUNON_SOPP .EQ.NODATA(16))SIMGRO(ICOL,IROW)%SOPP=0.0
IF(SIMGRO(ICOL,IROW)%QINFBASIC_SOPP.EQ.NODATA(18))SIMGRO(ICOL,IROW)%SOPP=0.0
ENDIF
DXY=IDFGETAREA(IDF,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.0)THEN
IF(SIMGRO(ICOL,IROW)%VXMU_ROPP .EQ.NODATA(13))SIMGRO(ICOL,IROW)%NOPP=DXY !## surface water, no metaswap
IF(SIMGRO(ICOL,IROW)%CRUNOFF_ROPP .EQ.NODATA(15))SIMGRO(ICOL,IROW)%NOPP=DXY !## surface water, no metaswap
IF(SIMGRO(ICOL,IROW)%CRUNON_ROPP .EQ.NODATA(17))SIMGRO(ICOL,IROW)%NOPP=DXY !## surface water, no metaswap
IF(SIMGRO(ICOL,IROW)%QINFBASIC_ROPP.EQ.NODATA(19))SIMGRO(ICOL,IROW)%NOPP=DXY !## surface water, no metaswap
ENDIF
ENDDO; ENDDO
!## check input
ALLOCATE(IERROR(22)); IERROR=0
DO IROW=1,IDF%NROW; DO ICOL=1,IDF%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,IDF%NROW
DO ICOL=1,IDF%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,IDF%NROW; DO ICOL=1,IDF%NCOL
IF(SIMGRO(ICOL,IROW)%RZ.LT.10.0)SIMGRO(ICOL,IROW)%RZ=10.0
ENDDO; ENDDO
!## minimal nopp-value
DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL
SIMGRO(ICOL,IROW)%NOPP=MAX(0.0,SIMGRO(ICOL,IROW)%NOPP)
!## minimal sopp-value
SIMGRO(ICOL,IROW)%SOPP=MAX(0.0,SIMGRO(ICOL,IROW)%SOPP)
ENDDO; ENDDO
!## bodem 22/23 vertalen naar 9 -> 22 (stedelijk zand?)/23(geen bodem; stad) -> zand
DO IROW=1,IDF%NROW
DO ICOL=1,IDF%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,IDF%NROW
DO ICOL=1,IDF%NCOL
!## maximal artificial recharge layer is nlay
SIMGRO(ICOL,IROW)%BER_LAAG=MIN(SIMGRO(ICOL,IROW)%BER_LAAG,NLAY)
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
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)//' AUX ISUB DSUBSYS ISUB NOPRINT'
WRITE(IU(3),'(A)') TRIM(LINE)
DO IPER=1,NPER
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
CLOSE(JU(2)); JU(2)=0
CALL OSD_OPEN(JU(3),FILE=FNAME(3),STATUS='OLD' ,ACTION='WRITE',POSITION='APPEND')
ELSE
CALL OSD_OPEN(JU(3),FILE=FNAME(3),STATUS='UNKNOWN',ACTION='WRITE')
ENDIF
LINE=FNAME(I); DO J=1,3; LINE=LINE(:INDEX(LINE,'\',.TRUE.)-1); ENDDO
J=LEN_TRIM(LINE); LINE='.'//FNAME(I)(J+1:)
IF(SUM(NO).GT.0)WRITE(IU(3),'(A)') 'OPEN/CLOSE '//TRIM(LINE)//' 1.0 (FREE) -1'
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
CLOSE(JU(3))
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_MAXNO(FNAME,NP)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN),DIMENSION(:) :: NP
CHARACTER(LEN=*),INTENT(IN) :: FNAME
INTEGER :: I,IU,JU,IOS
CHARACTER(LEN=12) :: NAN
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=FNAME ,STATUS='OLD' ,ACTION='READ' ,FORM='FORMATTED'); IF(IU.EQ.0)RETURN
JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=FNAME(:LEN_TRIM(FNAME)-1),STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(JU.EQ.0)RETURN
DO
READ(IU,'(A256)',IOSTAT=IOS) LINE; IF(IOS.NE.0)EXIT
IF(INDEX(LINE,'NaN').GT.0)THEN
DO I=1,SIZE(NP)
NAN='NaN'//TRIM(ITOS(I))//'#'
IF(INDEX(LINE,TRIM(NAN)).GT.0)LINE=UTL_SUBST(LINE,TRIM(NAN),ITOS(NP(I)))
ENDDO
ENDIF
WRITE(JU,'(A)') TRIM(ADJUSTL(LINE))
ENDDO
CLOSE(IU,STATUS='DELETE'); CLOSE(JU)
END SUBROUTINE PMANAGER_SAVEMF2005_MAXNO
!###======================================================================
SUBROUTINE PMANAGER_SAVEMF2005_PCK_ULSTRD_PARAM(NLAY,ICOL,IROW,BND,TOP,BOT,KD,TP,BT,KH)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: NLAY,ICOL,IROW
TYPE(IDFOBJ),INTENT(IN),DIMENSION(NLAY) :: BND,TOP,BOT,KD
REAL,INTENT(OUT),DIMENSION(NLAY) :: KH,TP,BT
INTEGER :: ILAY
!## get filter fractions
DO ILAY=1,NLAY
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,NLAY
!## do not put any in constant or inactive cells
IF(BND(ILAY)%X(ICOL,IROW).GT.0.AND.TP(ILAY)-BT(ILAY).GT.0.0)THEN
KH(ILAY)=KH(ILAY)/(TP(ILAY)-BT(ILAY))
ELSE
KH(ILAY)=0.0
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 :: 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,EXFNAME))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.0 (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 UTL_WRITE_FREE(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(NLAY),INTENT(INOUT) :: TOP,BOT,BND
REAL :: 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(IDF%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(NLAY),INTENT(INOUT) :: TOP,BOT,BND
REAL,INTENT(IN) :: HFBRESIS
INTEGER(KIND=1),INTENT(IN),DIMENSION(NCOL,NROW,2) :: IPC
INTEGER :: IROW,ICOL,IL1,IL2,ILAY
REAL :: NODATA,FDZ,TPV,BTV,TFV,BFV
NODATA=HUGE(1.0)
!## determine what layer(s)
IF(ITB.EQ.0)THEN
IL1=1; IL2=NLAY
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.0
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.0%
IF(ITB.EQ.0.AND.FDZ.LE.0.0)CYCLE
IF(ITB.NE.0)THEN
TPV=0.0
BTV=0.0
TFV=0.0
BFV=0.0
ELSE
TPV=(TOP(ILAY)%X(ICOL,IROW)+TOP(ILAY)%X(ICOL+1,IROW))/2.0
BTV=(BOT(ILAY)%X(ICOL,IROW)+BOT(ILAY)%X(ICOL+1,IROW))/2.0
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.0
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.0%
IF(ITB.EQ.0.AND.FDZ.LE.0.0)CYCLE
IF(ITB.NE.0)THEN
TPV=0.0
BTV=0.0
TFV=0.0
BFV=0.0
ELSE
TPV=(TOP(ILAY)%X(ICOL,IROW)+TOP(ILAY)%X(ICOL,IROW+1))/2.0
BTV=(BOT(ILAY)%X(ICOL,IROW)+BOT(ILAY)%X(ICOL,IROW+1))/2.0
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,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 :: C,C1,C2,Z,ZZ,TPV,BTV,TFV,BFV
INTEGER(KIND=1),ALLOCATABLE,DIMENSION(:,:,:) :: IPC
INTEGER(KIND=1),ALLOCATABLE,DIMENSION(:,:) :: SYS
REAL,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,NLAY
IPC=INT(0,1)
RES=0.0
FDZ=0.0
SYS=INT(0,1)
TF=-10.0E10
BF= 10.0E10
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.0)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.0)LINV=.TRUE.
!## still some space left in modellayer for an additional fault
IF(Z.LT.0.0.OR.FDZ(IC1,IR1).LT.1.0)THEN
!## available space
ZZ=1.0-FDZ(IC1,IR1)
!## net available space
ZZ=MIN(ZZ,Z)
!## confined system
IF(Z.LT.0.0)ZZ=1.0
!## take system number of largest contribution to c
IF(RES(IC1,IR1).GT.0.0)THEN
IF(Z.GT.0.0)THEN
!## currently available resistance
C2=1.0/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.0)THEN
!## add small fault using arithmetic mean
IF(TPV-BTV.LE.THICKNESS)THEN
C1=0.0; IF(RES(IC1,IR1).GT.0.0)C1=1.0/RES(IC1,IR1)*FDZ(IC1,IR2)
C2=C*ZZ
!## set conductance
RES(IC1,IR1)=1.0/((C1+C2)/(ZZ+FDZ(IC1,IR2)))
!## add large fault using harmonic mean
ELSE
!## set conductance
RES(IC1,IR1)=RES(IC1,IR1)+(1.0/C)*ZZ
ENDIF
ELSE
!## get largest resistance
RES(IC1,IR1)=MAX(RES(IC1,IR1),C)
ENDIF
!## occupation fraction
FDZ(IC1,IR1)=MIN(1.0,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)
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.0/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.0)THEN
!## take harmonic mean in case of unsaturated thickness of fault
C2=1.0/((1.0/C1*FDZ(ICOL,IROW))+(1.0-FDZ(ICOL,IROW)))
! C2=C1*FDZ(ICOL,IROW)**4.0
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.0/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.0)THEN
!## take harmonic mean in case of unsaturated thickness of fault
C2=1.0/((1.0/C1*FDZ(ICOL,IROW))+(1.0-FDZ(ICOL,IROW)))
! C2=C1*FDZ(ICOL,IROW)**4.0
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 FUNCTION PMANAGER_SAVEMF2005_HFB_GETFDZ(BND,TOP,BOT,TF,BF,IC1,IR1,IC2,IR2,NODATA,ILAY,TFV,BFV)
!###====================================================================
IMPLICIT NONE
TYPE(IDFOBJ),DIMENSION(NLAY),INTENT(INOUT) :: TOP,BOT,BND
REAL,INTENT(IN) :: NODATA
REAL,INTENT(IN),DIMENSION(:,:) :: TF,BF
REAL,INTENT(OUT) :: TFV,BFV
INTEGER,INTENT(IN) :: IC1,IR1,IC2,IR2,ILAY
REAL :: TPV,BTV,FDZ
PMANAGER_SAVEMF2005_HFB_GETFDZ=0.0
!## 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.0
BTV=(BOT(ILAY)%X(IC1,IR1)+BOT(ILAY)%X(IC2,IR2))/2.0
!## nett appearance of fault in modellayer
FDZ=MIN(TFV,TPV)-MAX(BFV,BTV)
!## not in current modellayer
IF(FDZ.LT.0.0)RETURN
IF(TPV-BTV.GT.0.0)THEN
!## fraction of fault in modellayer
FDZ=FDZ/(TPV-BTV)
ELSE
!## completely filled in model layer with thickness of zero
FDZ=1.0
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,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 :: 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.IDF%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.IDF%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 :: 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
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)
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.0,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
REAL :: 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,EXFNAME))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.0 (FREE) -1'
IF(IINT.EQ.1)WRITE(IU,'(A)') 'OPEN/CLOSE '//TRIM(SFNAME)//' 1 (FREE) -1'
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 UTL_WRITE_FREE(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,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.0
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.0.AND.IDF%X(ICOL,IROW).NE.HNOFLOW)IDF%X(ICOL,IROW)=1.0/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 :: C,ZT,ZB,A,X1,X2,Y1,Y2,DX,DY,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,IDF%NROW; DO ICOL=1,IDF%NCOL
LAK(1)%X(ICOL,IROW)=INT(LAK(1)%X(ICOL,IROW))
ENDDO; ENDDO
!## get unique number of lakes
ALLOCATE(DULAKES(IDF%NCOL*IDF%NROW))
I=0; DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL; I=I+1; DULAKES(I)=INT(LAK(1)%X(ICOL,IROW)); ENDDO; ENDDO
CALL UTL_GETUNIQUE_INT(DULAKES,IDF%NROW*IDF%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,NLAY; DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL; LBD(ILAY)%X(ICOL,IROW)=0.0; ENDDO; ENDDO; ENDDO
!## reset array lcd - sum of conductance vertically/horizontally
DO ILAY=1,NLAY; DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL; LCD(ILAY)%X(ICOL,IROW)=0.0; ENDDO; ENDDO; ENDDO
!## get lakebed leakance - combination of resistance and model resistance of depth AROUND lake
DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL
!## skip non lake cells
IF(LAK(1)%X(ICOL,IROW).LE.0)CYCLE
!## find appropriate modellayer underneath bathymetry of lake
DO ILAY=1,NLAY
!## 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.NLAY)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.0
!## modify existing aquitard due to this displacement - can be removed partly by lake
IF(ILAY.LT.NLAY)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.0; OT2=0.0
IF(ILAY.LT.NLAY)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.0)THEN
!## increase permeability in ratio in case no interbed and interface is shifted upwards
IF(ILAY.LT.NLAY)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.0
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.0/LAK(6)%X(ICOL,IROW)
ENDIF
ENDDO
ENDDO; ENDDO
!## get lakebed lateral leakances
DO ILAY=1,NLAY; DO IROW=1,IDF%NROW; DO ICOL=1,IDF%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.IDF%NROW.OR.JROW.LT.1)CYCLE
IF(JCOL.GT.IDF%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(IDF,JROW,JCOL,X1,Y1,X2,Y2)
IF(JROW.EQ.IROW)THEN; A=DY; L=X2-X1 ; ENDIF
IF(JCOL.EQ.ICOL)THEN; A=DX; 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.0/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,DIMENSION(:,:),INTENT(IN) :: X,Y
INTEGER,INTENT(IN) :: ULAKE
INTEGER,INTENT(IN) :: IBATCH,IOP
REAL,INTENT(OUT) :: LVL
REAL :: ILVL
INTEGER :: IROW,ICOL
PMANAGER_SAVEMF2005_LAKE_GETMEANVALUE=.FALSE.
LVL=0.0; ILVL=0.0
DO IROW=1,IDF%NROW; DO ICOL=1,IDF%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.0
!## min
CASE (2); IF(ILVL.EQ.0)THEN; LVL=Y(ICOL,IROW); ELSE; LVL=MIN(LVL,Y(ICOL,IROW)); ENDIF; ILVL=ILVL+1.0
!## max
CASE (3); IF(ILVL.EQ.0)THEN; LVL=Y(ICOL,IROW); ELSE; LVL=MAX(LVL,Y(ICOL,IROW)); ENDIF; ILVL=ILVL+1.0
END SELECT
ENDIF
ENDDO; ENDDO
IF(ILVL.LE.0.0)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(BND)
!###======================================================================
IMPLICIT NONE
TYPE(IDFOBJ),INTENT(INOUT) :: BND
INTEGER :: IROW,ICOL
!## if bound equal to hnoflow, turn inactive, before correcting due to submodel potential
DO IROW=1,BND%NROW
DO ICOL=1,BND%NCOL
IF(BND%X(ICOL,IROW).EQ.HNOFLOW)BND%X(ICOL,IROW)=0
ENDDO
ENDDO
!## replace ibound for boundaries
DO IROW=1,BND%NROW
IF(IFULL(1).EQ.1)THEN; ICOL=1; IF(BND%X(ICOL,IROW).GT.0)BND%X(ICOL,IROW)=-1; ENDIF
IF(IFULL(3).EQ.1)THEN; ICOL=BND%NCOL; IF(BND%X(ICOL,IROW).GT.0)BND%X(ICOL,IROW)=-1; ENDIF
ENDDO
DO ICOL=1,BND%NCOL
IF(IFULL(4).EQ.1)THEN; IROW=1; IF(BND%X(ICOL,IROW).GT.0)BND%X(ICOL,IROW)=-1; ENDIF
IF(IFULL(2).EQ.1)THEN; IROW=BND%NROW; IF(BND%X(ICOL,IROW).GT.0)BND%X(ICOL,IROW)=-1; ENDIF
ENDDO
END SUBROUTINE PMANAGER_SAVEMF2005_BND
!###======================================================================
SUBROUTINE PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,IDF,ITYPE,ITOPIC)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ITOPIC,ILAY,ITYPE
TYPE(IDFOBJ),INTENT(INOUT) :: IDF
TYPE(IDFOBJ),INTENT(INOUT),DIMENSION(:) :: BND
INTEGER :: IROW,ICOL,JLAY
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 !IDF%X(ICOL,IROW).EQ.IDF%NODATA)THEN
WRITE(*,'(/1X,A)') 'Error NodataValue found for active cell'
WRITE(*,'(A3,3A4,3A15 )') 'VAR','COL','ROW','LAY','IBOUND','X','NODATAVALUE'
WRITE(*,'(A3,3I4,F15.1,2E15.7)') CMOD(ITOPIC),ICOL,IROW,ILAY,BND(ILAY)%X(ICOL,IROW),IDF%X(ICOL,IROW),IDF%NODATA
PAUSE; STOP
ENDIF
ENDIF
ENDIF
!## blank out layer below in case of vertical conductance
IF(ITOPIC.EQ.4)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,NLAY; IF(BND(JLAY)%X(ICOL,IROW).GT.0)EXIT; ENDDO
!## skip if location is equal to nodata, completely
IF(JLAY.GT.NLAY)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.0)IDF%X(ICOL,IROW)=0.0
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
!###======================================================================
SUBROUTINE PMANAGER_GETNFILES(ITOPICS,MAXNLAY)
!###======================================================================
IMPLICIT NONE
INTEGER,DIMENSION(:),INTENT(IN) :: ITOPICS
INTEGER,INTENT(OUT) :: MAXNLAY
INTEGER :: II,I,J,IPER,ITOPIC,ILAY
INTEGER,POINTER,DIMENSION(:) :: ALAY
!## get maximal number of layers
MAXNLAY=999; ALLOCATE(ALAY(MAXNLAY)); ALAY=0
DO II=1,SIZE(ITOPICS)
ITOPIC=ITOPICS(II)
IF(.NOT.ASSOCIATED(TOPICS(ITOPIC)%STRESS))CYCLE
IF(.NOT.ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))CYCLE
DO IPER=1,SIZE(TOPICS(ITOPIC)%STRESS)
DO I=1,SIZE(TOPICS(ITOPIC)%STRESS(IPER)%FILES,1)
DO J=1,SIZE(TOPICS(ITOPIC)%STRESS(IPER)%FILES,2)
ILAY=TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,J)%ILAY
IF(ILAY.GT.0)ALAY(ILAY)=1
ENDDO
ENDDO
ENDDO
! SELECT CASE (ITOPIC)
! !## kvv or vcw
! CASE (9,10)
! NLAY=NLAY+1
! END SELECT
! MXNLAY=MIN(MXNLAY,NLAY)
ENDDO
!## how many connected layers are defined
MAXNLAY=0; DO ILAY=1,SIZE(ALAY); IF(ALAY(ILAY).EQ.0)EXIT; MAXNLAY=MAXNLAY+1; ENDDO
IF(ASSOCIATED(ALAY))DEALLOCATE(ALAY)
END SUBROUTINE PMANAGER_GETNFILES
!###======================================================================
SUBROUTINE PMANAGER_GETNPER(JD1,IHMS1,JD2,IHMS2)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: JD1,IHMS1,JD2,IHMS2
INTEGER :: I,J,K,IYR,IMH,IDY,IHR,IMT,ISC,IPER
INTEGER(KIND=8),POINTER,DIMENSION(:) :: ITIME
INTEGER(KIND=8) :: STIME,ETIME
ALLOCATE(ITIME(100)); ITIME=INT(0,8)
CALL UTL_GDATE(JD1,IYR,IMH,IDY); CALL ITIMETOHMS(IHMS1,IHR,IMT,ISC)
ITIME(1)=IYR*10000000000+IMH*100000000+IDY*1000000+IHR*10000+IMT*100+ISC
CALL UTL_GDATE(JD2,IYR,IMH,IDY); CALL ITIMETOHMS(IHMS2,IHR,IMT,ISC)
ITIME(2)=IYR*10000000000+IMH*100000000+IDY*1000000+IHR*10000+IMT*100+ISC
!## fill in list
IPER=2
DO I=1,MAXTOPICS
IF(.NOT.TOPICS(I)%TIMDEP)CYCLE
IF(.NOT.ASSOCIATED(TOPICS(I)%STRESS))CYCLE
IF(.NOT.ASSOCIATED(TOPICS(I)%STRESS(1)%FILES))CYCLE
DO J=1,SIZE(TOPICS(I)%STRESS)
!## skip steady-state
IF(TRIM(UTL_CAP(TOPICS(I)%STRESS(J)%CDATE,'U')).EQ.'STEADY-STATE')CYCLE
IYR=TOPICS(I)%STRESS(J)%IYR; IMH=TOPICS(I)%STRESS(J)%IMH; IDY=TOPICS(I)%STRESS(J)%IDY
IHR=TOPICS(I)%STRESS(J)%IHR; IMT=TOPICS(I)%STRESS(J)%IMT; ISC=TOPICS(I)%STRESS(J)%ISC
!## true date specified
IF(IYR+IMH+IDY+IHR+IMT+ISC.GT.0)THEN
IPER=IPER+1; CALL PMANAGER_GETNPER_ITIME(ITIME,IPER)
ITIME(IPER)=IYR*10000000000+IMH*100000000+IDY*1000000+IHR*10000+IMT*100+ISC
ELSE
!## include used periods
DO K=1,NPERIOD
IF(TRIM(UTL_CAP(TOPICS(I)%STRESS(J)%CDATE,'U')).EQ.TRIM(UTL_CAP(PERIOD(K)%NAME,'U')))EXIT
ENDDO
!## see whether the current stress is within mentioned period
IF(K.LE.NPERIOD)THEN
IYR=PERIOD(K)%IYR; IMH=PERIOD(K)%IMH; IDY=PERIOD(K)%IDY; IHR=PERIOD(K)%IHR; IMT=PERIOD(K)%IMT; ISC=PERIOD(K)%ISC
!## true date specified
IF(IYR+IMH+IDY+IHR+IMT+ISC.GT.0)THEN
IPER=IPER+1; CALL PMANAGER_GETNPER_ITIME(ITIME,IPER)
ITIME(IPER)=IYR*10000000000+IMH*100000000+IDY*1000000+IHR*10000+IMT*100+ISC
ENDIF
ELSE
!## not known period specified
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMOD cannot find the definition for the specified'//CHAR(13)// &
'period called: '//TRIM(TOPICS(I)%STRESS(J)%CDATE),'Error')
NPER=0; RETURN
ENDIF
ENDIF
ENDDO
ENDDO
STIME=ITIME(1); ETIME=ITIME(2)
CALL PMANAGER_SORTTIMES(ITIME,STIME,ETIME)
DEALLOCATE(ITIME)
END SUBROUTINE PMANAGER_GETNPER
!###======================================================================
SUBROUTINE PMANAGER_SORTTIMES(ITIME,STIME,ETIME)
!###======================================================================
IMPLICIT NONE
INTEGER(KIND=8),INTENT(IN) :: STIME,ETIME
INTEGER(KIND=8),DIMENSION(:),POINTER,INTENT(IN) :: ITIME
INTEGER(KIND=8),DIMENSION(:),POINTER :: JTIME
INTEGER :: IPER,I
CALL SHELLSORT_DOUBLEINT(SIZE(ITIME),ITIME)
ALLOCATE(JTIME(SIZE(ITIME)))
NPER=1
!## start time
JTIME(1)=STIME
!## get first date inside time window
DO IPER=1,SIZE(ITIME)
!## too early
IF(ITIME(IPER).LE.STIME)CYCLE; EXIT
ENDDO
!## get number of unique dates
DO I=IPER,SIZE(ITIME)
!## too late - stop
IF(ITIME(I).GT.ETIME)EXIT
IF(I.GT.1)THEN
IF(ITIME(I).NE.ITIME(I-1))THEN
NPER=NPER+1; JTIME(NPER)=ITIME(I)
ENDIF
ENDIF
ENDDO
IF(NPER.EQ.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'No stress-periods found in the packages.','Warning')
ELSE
ALLOCATE(SIM(NPER)); SIM%DELT=HUGE(1.0)
DO I=1,NPER
WRITE(SIM(I)%CDATE,'(I14)') JTIME(I)
READ(SIM(I)%CDATE,'(I4,5I2)') SIM(I)%IYR,SIM(I)%IMH,SIM(I)%IDY,SIM(I)%IHR,SIM(I)%IMT,SIM(I)%ISC
SIM(I)%ISAVE=1; SIM(I)%ISUM=0
ENDDO
ENDIF
DEALLOCATE(JTIME)
END SUBROUTINE PMANAGER_SORTTIMES
!###======================================================================
SUBROUTINE PMANAGER_GETNPER_ITIME(ITIME,IPER)
!###======================================================================
IMPLICIT NONE
INTEGER(KIND=8),INTENT(INOUT),DIMENSION(:),POINTER :: ITIME
INTEGER,INTENT(IN) :: IPER
INTEGER(KIND=8),POINTER,DIMENSION(:) :: ITIME_C
INTEGER :: N,I
!## check size of the SIM vector
IF(SIZE(ITIME).LT.IPER)THEN
N=SIZE(ITIME)+100; ALLOCATE(ITIME_C(N)); ITIME_C=INT(0,8)
DO I=1,SIZE(ITIME); ITIME_C(I)=ITIME(I); ENDDO
DEALLOCATE(ITIME); ITIME=>ITIME_C
ENDIF
END SUBROUTINE PMANAGER_GETNPER_ITIME
!###======================================================================
INTEGER FUNCTION PMANAGER_GETCURRENTIPER(IPER,ITOPIC,ITIME,JTIME)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IPER,ITOPIC
INTEGER(KIND=8),INTENT(OUT) :: ITIME,JTIME
INTEGER(KIND=8) :: KTIME
INTEGER :: KPER
PMANAGER_GETCURRENTIPER=0
KTIME=INT(0,8); JTIME=INT(0,8); ITIME=INT(0,8)
!## get appropriate stress-period to store in runfile
IF(SIM(IPER)%DELT.GT.0.0)THEN !## transient
!## previous timestep
IF(IPER.GT.1)THEN
IF(SIM(IPER-1)%DELT.GT.0.0)THEN
KTIME=SIM(IPER-1)%IYR*10000000000+SIM(IPER-1)%IMH*100000000+SIM(IPER-1)%IDY*1000000+ &
SIM(IPER-1)%IHR*10000 +SIM(IPER-1)%IMT*100 +SIM(IPER-1)%ISC
ENDIF
ENDIF
!## current timestep
ITIME=SIM(IPER )%IYR*10000000000+SIM(IPER )%IMH*100000000+SIM(IPER )%IDY*1000000+ &
SIM(IPER )%IHR*10000 +SIM(IPER )%IMT*100 +SIM(IPER )%ISC
!## next timestep
JTIME=SIM(IPER+1)%IYR*10000000000+SIM(IPER+1)%IMH*100000000+SIM(IPER+1)%IDY*1000000+ &
SIM(IPER+1)%IHR*10000 +SIM(IPER+1)%IMT*100 +SIM(IPER+1)%ISC
ENDIF
KPER=PMANAGER_GETIPER(IPER,KTIME,ITIME,JTIME,TOPICS(ITOPIC)%STRESS)
PMANAGER_GETCURRENTIPER=KPER
END FUNCTION PMANAGER_GETCURRENTIPER
!###======================================================================
INTEGER FUNCTION PMANAGER_GETIPER(IPER,PTIME,STIME,ETIME,STRESS)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IPER
INTEGER(KIND=8),INTENT(IN) :: STIME,ETIME,PTIME
TYPE(STRESSOBJ),INTENT(IN),DIMENSION(:) :: STRESS
INTEGER :: I,J,ID,IYR
INTEGER(KIND=8) :: PCKTIME,MD
!## initially nothing found
PMANAGER_GETIPER=0
!## look for steady-state
IF(STIME.EQ.INT(0,8))THEN
DO I=1,SIZE(STRESS)
IF(TRIM(UTL_CAP(STRESS(I)%CDATE,'U')).EQ.'STEADY-STATE')THEN
PMANAGER_GETIPER=I; RETURN
ENDIF
ENDDO
ID=0 !## nothing found
!## transient
ELSE
!## get time-interval window
!## look for nearest package to current timestep
MD=10E14; ID=0
DO I=1,SIZE(STRESS)
!## skip steady-state
IF(TRIM(UTL_CAP(STRESS(I)%CDATE,'U')).EQ.'STEADY-STATE')CYCLE
!## check whether a period is available
DO J=1,NPERIOD
IF(TRIM(UTL_CAP(STRESS(I)%CDATE,'U')).EQ.TRIM(UTL_CAP(PERIOD(J)%NAME,'U')))EXIT
ENDDO
!## see whether the current stress is within mentioned period
IF(J.LE.NPERIOD)THEN
!## check each subsequent period for years to be closed to current time step
IYR=PERIOD(J)%IYR
DO
!## package time
PCKTIME=IYR*10000000000+ PERIOD(J)%IMH*100000000+PERIOD(J)%IDY*1000000+ &
PERIOD(J)%IHR*10000+PERIOD(J)%IMT*100+ PERIOD(J)%ISC
!## outside (appears to be later) current time-window
IF(PCKTIME.GE.ETIME)EXIT
!## defined at the same period as the current timestep - better than this it will not become, stop search
IF(STIME.EQ.PCKTIME)THEN; ID=I; EXIT; ENDIF
!## get closest defined before current timestep
IF(STIME.GT.PCKTIME)THEN
!## closer than what we had already
IF(STIME-PCKTIME.LE.MD)THEN; MD=STIME-PCKTIME; ID=-I; ENDIF
ENDIF
!## insert period next year
IYR=IYR+1
ENDDO
!## defined at the same period as the current timestep - better than this it will not become, stop search
IF(STIME.EQ.PCKTIME)EXIT
ELSE
!## package time
PCKTIME=STRESS(I)%IYR*10000000000+STRESS(I)%IMH*100000000+STRESS(I)%IDY*1000000+ &
STRESS(I)%IHR*10000 +STRESS(I)%IMT*100 +STRESS(I)%ISC
!## outside (appears to be later) current time-window - try next
IF(PCKTIME.GE.ETIME)CYCLE
!## defined at the same period as the current timestep - better than this it will not become, stop search
IF(STIME.EQ.PCKTIME)THEN; ID=I; EXIT; ENDIF
!## get closest defined before current timestep
IF(STIME.GT.PCKTIME)THEN
!## closer than what we had already
IF(STIME-PCKTIME.LE.MD)THEN; MD=STIME-PCKTIME; ID=-I; ENDIF
ENDIF
ENDIF
ENDDO
ENDIF
!## nothing found
IF(ID.EQ.0)THEN
!## check steady-state period
DO I=1,SIZE(STRESS)
!## skip steady-state
IF(TRIM(UTL_CAP(STRESS(I)%CDATE,'U')).EQ.'STEADY-STATE')ID=I
ENDDO
!## apply minus 1
IF(IPER.GT.1)ID=-1*ID
PMANAGER_GETIPER=ID !0
!## use previous input
ELSEIF(ID.LT.0)THEN
!## no matter what; cannot use -1 for first timestep
IF(IPER.EQ.1)THEN
PMANAGER_GETIPER=ABS(ID)
ELSE
!## no matter what; cannot use -1 for first timestep after steady-state
IF(SIM(IPER-1)%DELT.EQ.0.0)THEN
PMANAGER_GETIPER=ABS(ID)
ELSE
!## check whether date is after last time-step (ktime)
IF(STIME-MD.GT.PTIME)THEN
PMANAGER_GETIPER=ABS(ID)
ELSE
PMANAGER_GETIPER=ID
ENDIF
ENDIF
ENDIF
!## number of systems for current stress period
ELSE
PMANAGER_GETIPER=ID
ENDIF
END FUNCTION PMANAGER_GETIPER
!###======================================================================
LOGICAL FUNCTION PMANAGER_INITSIM(FNAME,IBATCH,IRUN)
!###======================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(OUT) :: FNAME
INTEGER,INTENT(OUT) :: IRUN
INTEGER,INTENT(IN) :: IBATCH
INTEGER :: ITYPE
TYPE(WIN_MESSAGE) :: MESSAGE
INTEGER :: IDY,IYR,IMH,ITOPIC,IPER,I,J,K,MINJD,MAXJD,IDATE,IHR,IMT,ISC,IHMS,MINHMS,MAXHMS,ISTEADY,ISTEP,ITRANSIENT
TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: IDF
LOGICAL :: LEX
PMANAGER_INITSIM=.FALSE.; IRUN=0
!## put maximum number of layer in dialog
CALL WDIALOGLOAD(ID_DPMANAGER_SIM,ID_DPMANAGER_SIM)
CALL WDIALOGLOAD(ID_DPMANAGERLAYERTYPES,ID_DPMANAGERLAYERTYPES)
CALL PMANAGER_GETNFILES((/2,3,4,5,6,7,8,9,10,11,12/),MXNLAY)
IF(MXNLAY.LE.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'No layers found for the current configuration','Error')
RETURN
ENDIF
!## number of active layers equal to maximum allowable layers
CALL WDIALOGRANGEINTEGER(IDF_INTEGER1,1,MXNLAY)
CALL WDIALOGPUTINTEGER(IDF_INTEGER1,MXNLAY); NLAY=MXNLAY
IF(MXNLAY.GT.WINFOGRID(IDF_GRID1,GRIDROWSMAX))THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'For this iMOD version, there is a maximum number of layers is 200.','Error')
RETURN
ENDIF
CALL WGRIDROWS(IDF_GRID1,MXNLAY)
IF(ALLOCATED(LAYCON))THEN
IF(SIZE(LAYCON).LT.MXNLAY)DEALLOCATE(LAYCON)
ENDIF
IF(.NOT.ALLOCATED(LAYCON))THEN
ALLOCATE(LAYCON(MXNLAY))
IF(IBATCH.EQ.0)THEN
LAYCON=1
ELSE
LAYCON=PBMAN%UNCONFINED+1
ENDIF
ENDIF
!## laycon=1: 0
!## laycon=2: 1
!## laycon=3:-1
!## laycon=4: constant head
ISTEADY=0; ITRANSIENT=0; MINJD=10E7; MAXJD=-10E7; MINHMS=246060; MAXHMS=0.0
DO ITOPIC=1,MAXTOPICS
IF(.NOT.ASSOCIATED(TOPICS(ITOPIC)%STRESS))CYCLE
IF(.NOT.TOPICS(ITOPIC)%TIMDEP)CYCLE
DO IPER=1,SIZE(TOPICS(ITOPIC)%STRESS)
IF(TRIM(TOPICS(ITOPIC)%STRESS(IPER)%CDATE).EQ.'STEADY-STATE')THEN
ISTEADY=1
ELSE
IYR=TOPICS(ITOPIC)%STRESS(IPER)%IYR; IMH=TOPICS(ITOPIC)%STRESS(IPER)%IMH; IDY=TOPICS(ITOPIC)%STRESS(IPER)%IDY
IHR=TOPICS(ITOPIC)%STRESS(IPER)%IHR; IMT=TOPICS(ITOPIC)%STRESS(IPER)%IMT; ISC=TOPICS(ITOPIC)%STRESS(IPER)%ISC
!## date entered
IF(IYR+IMH+IDY+IHR+IMT+ISC.GT.0)THEN
ITRANSIENT=1
IDATE=JD(IYR,IMH,IDY); IHMS=HMSTOITIME(IHR,IMT,ISC)
IF(IDATE.LE.MINJD)THEN
MINJD=MIN(MINJD,IDATE); IF(IHMS.LT.MINHMS)MINHMS=IHMS
ENDIF
IF(IDATE.GE.MAXJD)THEN
MAXJD=MAX(MAXJD,IDATE); IF(IHMS.GT.MAXHMS)MAXHMS=IHMS
ENDIF
ELSE
!## probably period definition?
DO J=1,NPERIOD
IF(TRIM(UTL_CAP(TOPICS(ITOPIC)%STRESS(IPER)%CDATE,'U')).EQ.TRIM(UTL_CAP(PERIOD(J)%NAME,'U')))EXIT
ENDDO
!## see whether the current stress is within mentioned period
IF(J.LE.NPERIOD)THEN
ITRANSIENT=1
DO K=1,2
IYR=PERIOD(J)%IYR; IMH=PERIOD(J)%IMH; IDY=PERIOD(J)%IDY
IHR=PERIOD(J)%IHR; IMT=PERIOD(J)%IMT; ISC=PERIOD(J)%ISC
IDATE=JD(IYR,IMH,IDY); IHMS=HMSTOITIME(IHR,IMT,ISC)
IF(IDATE.LE.MINJD)THEN
MINJD=MIN(MINJD,IDATE); IF(IHMS.LT.MINHMS)MINHMS=IHMS
ENDIF
IF(IDATE.GE.MAXJD)THEN
MAXJD=MAX(MAXJD,IDATE); IF(IHMS.GT.MAXHMS)MAXHMS=IHMS
ENDIF
ENDDO
ELSE
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot convert date ['//TRIM(TOPICS(ITOPIC)%STRESS(IPER)%CDATE)//'] for'//CHAR(13)// &
'Topic '//TRIM(TOPICS(ITOPIC)%TNAME),'Warning')
RETURN
ENDIF
ENDIF
ENDIF
ENDDO
ENDDO
!## transient data found - see whether storage has been defined
IF(ITRANSIENT.EQ.1)THEN
I=0
IF(ASSOCIATED(TOPICS(11)%STRESS))THEN
IF(ASSOCIATED(TOPICS(11)%STRESS(1)%FILES))I=1
ENDIF
IF(I.EQ.0)THEN
IF(ISTEADY.EQ.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Missing data to convert to a transient model.'//CHAR(13)// &
'You need to specify the package (STO).','Warning'); RETURN
ELSE
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Missing data to convert to a transient model.'//CHAR(13)// &
'You need to specify the package (STO).'//CHAR(13)//'You can only select the STEADY-STATE model.','Warning'); ITRANSIENT=0
ENDIF
ENDIF
ENDIF
!## default packages
CALL WDIALOGSELECT(ID_DPMANAGER_SIM)
CALL WDIALOGPUTMENU(IDF_MENU4,TMENU1,SIZE(TMENU1),8)
CALL WDIALOGPUTIMAGE(ID_DRAW,ID_ICONDRAW,1)
CALL WDIALOGPUTIMAGE(ID_OPEN,ID_ICONOPENIDF,1)
CALL WDIALOGPUTSTRING(ID_LAYERTYPES,'Define '//TRIM(ITOS(NLAY))//' Layer Types ...')
!## no transient data found
IF(ITRANSIENT.EQ.0)THEN
IMH=3; IYR=1970; IDY=8; IHR=0; IMT=0; ISC=0
CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO1)
CALL WDIALOGFIELDSTATE(IDF_RADIO2,0)
CALL WDIALOGPUTMENU(IDF_MENU2,CDATE,12,IMH)
CALL WDIALOGPUTINTEGER(IDF_INTEGER2,IDY)
CALL WDIALOGPUTINTEGER(IDF_INTEGER3,IYR)
CALL WDIALOGPUTINTEGER(IDF_INTEGER6,IHR)
CALL WDIALOGPUTINTEGER(IDF_INTEGER7,IMT)
CALL WDIALOGPUTINTEGER(IDF_INTEGER8,ISC)
CALL WDIALOGPUTMENU(IDF_MENU3,CDATE,12,IMH)
CALL WDIALOGPUTINTEGER(IDF_INTEGER4,IDY)
CALL WDIALOGPUTINTEGER(IDF_INTEGER5,IYR)
CALL WDIALOGPUTINTEGER(IDF_INTEGER9,IHR)
CALL WDIALOGPUTINTEGER(IDF_INTEGER10,IMT)
CALL WDIALOGPUTINTEGER(IDF_INTEGER11,ISC)
!## transient data found
ELSE
CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO2)
IF(ISTEADY.EQ.0)THEN
CALL WDIALOGFIELDSTATE(IDF_RADIO1,0)
CALL WDIALOGFIELDSTATE(IDF_CHECK2,0)
ELSE
CALL WDIALOGPUTCHECKBOX(IDF_CHECK2,1)
ENDIF
CALL UTL_GDATE(MINJD,IYR,IMH,IDY)
CALL WDIALOGPUTMENU(IDF_MENU2,CDATE,12,IMH)
CALL WDIALOGPUTINTEGER(IDF_INTEGER2,IDY)
CALL WDIALOGPUTINTEGER(IDF_INTEGER3,IYR)
CALL ITIMETOHMS(MINHMS,IHR,IMT,ISC)
CALL WDIALOGPUTINTEGER(IDF_INTEGER6,IHR)
CALL WDIALOGPUTINTEGER(IDF_INTEGER7,IMT)
CALL WDIALOGPUTINTEGER(IDF_INTEGER8,ISC)
CALL UTL_GDATE(MAXJD,IYR,IMH,IDY)
CALL WDIALOGPUTMENU(IDF_MENU3,CDATE,12,IMH)
CALL WDIALOGPUTINTEGER(IDF_INTEGER4,IDY)
CALL WDIALOGPUTINTEGER(IDF_INTEGER5,IYR)
CALL ITIMETOHMS(MAXHMS,IHR,IMT,ISC)
CALL WDIALOGPUTINTEGER(IDF_INTEGER9,IHR)
CALL WDIALOGPUTINTEGER(IDF_INTEGER10,IMT)
CALL WDIALOGPUTINTEGER(IDF_INTEGER11,ISC)
ENDIF
!## confined all, unless determined otherwise
! LAYCON=0
IF(ASSOCIATED(TOPICS(2)%STRESS).AND.ASSOCIATED(TOPICS(3)%STRESS).AND.ASSOCIATED(TOPICS(7)%STRESS))THEN
!## set laycon variable
DO I=1,MXNLAY
IF(ASSOCIATED(TOPICS(2)%STRESS(1)%FILES).AND. & !## top
ASSOCIATED(TOPICS(3)%STRESS(1)%FILES).AND. & !## bot
ASSOCIATED(TOPICS(7)%STRESS(1)%FILES))THEN !## khv
!## convertible/unconfined
! LAYCON(I)=0
ENDIF
ENDDO
ENDIF
I=0
IF(ASSOCIATED(TOPICS(6)%STRESS))THEN
IF(ASSOCIATED(TOPICS(6)%STRESS(1)%FILES))THEN !## kdw
I=1
IF(NLAY.GT.1)THEN
IF(ASSOCIATED(TOPICS(9)%STRESS))THEN
IF(.NOT.ASSOCIATED(TOPICS(9)%STRESS(1)%FILES))I=0 !## vcw
ELSE
I=0
ENDIF
ENDIF
ENDIF
ENDIF
CALL WDIALOGFIELDSTATE(IDF_RADIO5,I) !## bcf
IF(I.EQ.1)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO5)
LBCF=.FALSE.; IF(I.EQ.1)LBCF=.TRUE.
J=0
IF(ASSOCIATED(TOPICS(2)%STRESS).AND. &
ASSOCIATED(TOPICS(3)%STRESS).AND. &
ASSOCIATED(TOPICS(7)%STRESS).AND. &
ASSOCIATED(TOPICS(8)%STRESS))THEN
IF(ASSOCIATED(TOPICS(2)%STRESS(1)%FILES).AND. & !## top
ASSOCIATED(TOPICS(3)%STRESS(1)%FILES).AND. & !## bot
ASSOCIATED(TOPICS(7)%STRESS(1)%FILES).AND. & !## hkv
ASSOCIATED(TOPICS(8)%STRESS(1)%FILES))THEN !## kva
J=1
ENDIF
ENDIF
CALL WDIALOGFIELDSTATE(IDF_RADIO6,J) !## lpf
IF(J.EQ.1)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO6)
LLPF=.FALSE.; IF(J.EQ.1)LLPF=.TRUE.
IF(I.EQ.0.AND.J.EQ.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Missing data to convert to BCF6 or to convert to LPF package'//CHAR(13)// &
'For BCF you need at least KDW and VCW parameters'//CHAR(13)// &
'For LPF you need at least TOP, BOT, KHV and KVA parameters','Warning')
RETURN
ENDIF
!## if lake or uzf package activated, make sure top/bot are active too
IF(ASSOCIATED(TOPICS(32)%STRESS).OR.ASSOCIATED(TOPICS(18)%STRESS))THEN
J=0
IF(ASSOCIATED(TOPICS(2)%STRESS).AND.ASSOCIATED(TOPICS(3)%STRESS))J=1
IF(J.EQ.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'For usage of the LAK or UZF package you need to'//CHAR(13)// &
'specify TOP and BOT packages as well','Warning'); RETURN
ENDIF
ENDIF
! !## if kvv specified use quasi-3d discretisation
! J=0
! IF(NLAY.GT.1)THEN
! IF(ASSOCIATED(TOPICS(10)%STRESS))THEN
! IF(ASSOCIATED(TOPICS(10)%STRESS(1)%FILES))J=1 !## kvv
! ENDIF
! ENDIF
! IF(J.EQ.0)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO7) !## no interbeds
! IF(J.EQ.1)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO8) !## interbeds
!! CALL WDIALOGFIELDSTATE(IDF_RADIO7,J)
! CALL WDIALOGFIELDSTATE(IDF_RADIO8,J)
!## look for any boundary file (first) not equal to constant values
ALLOCATE(IDF(1)); CALL IDFNULLIFY(IDF(1))
IF(.NOT.PMANAGER_INIT_SIMAREA(IDF(1),IBATCH))THEN
CALL IDFDEALLOCATE(IDF,SIZE(IDF)); DEALLOCATE(IDF); RETURN
ENDIF
IF(IBATCH.EQ.0)PBMAN%BNDFILE=''
IF(TRIM(PBMAN%BNDFILE).NE.'')THEN
CALL WDIALOGPUTSTRING(IDF_STRING2,PBMAN%BNDFILE)
CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO16)
ELSE
CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO17)
CALL WDIALOGPUTSTRING(IDF_STRING2,'Enter NETWORKIDF')
ENDIF
!## found any of the given IDF-files that could serve as simulation window
IF(IDF(1)%DX.GT.0.0)THEN
CALL WDIALOGPUTREAL(IDF_REAL5,IDF(1)%DX,'(G12.7)')
ELSE
CALL WDIALOGPUTREAL(IDF_REAL5,25.0,'(G12.7)')
ENDIF
CALL IDFDEALLOCATE(IDF,SIZE(IDF)); DEALLOCATE(IDF)
!## modflow2005 does not allow thickness of zero
CALL WDIALOGPUTREAL(IDF_REAL6,MINTHICKNESS,'(F10.2)')
CALL WDIALOGPUTREAL(IDF_REAL1,MPW%XMIN,'(G15.7)')
CALL WDIALOGPUTREAL(IDF_REAL2,MPW%YMIN,'(G15.7)')
CALL WDIALOGPUTREAL(IDF_REAL3,MPW%XMAX,'(G15.7)')
CALL WDIALOGPUTREAL(IDF_REAL4,MPW%YMAX,'(G15.7)')
CALL WDIALOGPUTSTRING(IDF_STRING1,MODELNAME)
CALL PMANAGER_INITSIM_FIELDS()
CALL WDIALOGGETMENU(IDF_MENU4,I)
CALL PMANAGER_TIMESTEPS_GETISTEP(I,J,ISTEP)
CALL WDIALOGPUTINTEGER(IDF_INTEGER12,ISTEP)
CALL WDIALOGFIELDSTATE(IDF_INTEGER12,J)
!## start dialog
IF(IBATCH.EQ.0)THEN
CALL WDIALOGSHOW(-1,-1,0,3)
DO
CALL WMESSAGE(ITYPE,MESSAGE)
SELECT CASE (ITYPE)
CASE(FIELDCHANGED)
SELECT CASE (MESSAGE%VALUE2)
CASE (IDF_MENU4)
CALL WDIALOGGETMENU(IDF_MENU4,I)
CALL PMANAGER_TIMESTEPS_GETISTEP(I,J,ISTEP)
CALL WDIALOGPUTINTEGER(IDF_INTEGER12,ISTEP)
CALL WDIALOGFIELDSTATE(IDF_INTEGER12,J)
CASE (IDF_RADIO1,IDF_RADIO2,IDF_RADIO3,IDF_RADIO4,IDF_CHECK1,IDF_INTEGER1,IDF_RADIO15,IDF_RADIO16,IDF_RADIO17)
CALL PMANAGER_INITSIM_FIELDS()
CASE (IDF_INTEGER2,IDF_INTEGER3,IDF_MENU2)
CALL UTL_FILLDATES(IDF_INTEGER3,IDF_MENU2,IDF_INTEGER2)
CASE (IDF_INTEGER4,IDF_INTEGER5,IDF_MENU3)
CALL UTL_FILLDATES(IDF_INTEGER5,IDF_MENU3,IDF_INTEGER4)
END SELECT
SELECT CASE (MESSAGE%VALUE1)
END SELECT
CASE(PUSHBUTTON)
SELECT CASE (MESSAGE%VALUE1)
CASE (ID_OPEN)
FNAME=TRIM(PREFVAL(1))//'*.idf'
LEX=UTL_WSELECTFILE('Select (network) IDF File (*.idf)|*.idf|', &
LOADDIALOG+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,'Select (network) IDF File')
IF(LEX)CALL WDIALOGPUTSTRING(IDF_STRING2,FNAME)
CASE (ID_LAYERTYPES)
CALL PMANAGERLAYERTYPES()
CALL PMANAGER_INITSIM_FIELDS()
CASE (ID_SIMCUSTOMIZE)
CALL PMANAGER_TIMESTEPS()
CALL WDIALOGPUTOPTION(IDF_MENU4,9)
CASE (ID_PACKAGE)
CALL PMANAGER_INITSIM_PACKAGES()
CALL PMANAGER_INITSIM_FIELDS()
CASE (IDOK,IDSIMULATE)
!## fill timesteps - if not yet done
LEX=.TRUE.; IF(.NOT.ASSOCIATED(SIM))LEX=PMANAGER_FILLTIMESTEPS()
IF(LEX)THEN
!## get file format
CALL WDIALOGGETRADIOBUTTON(IDF_RADIO3,IFORMAT)
IF(IFORMAT.EQ.1)THEN
FNAME=TRIM(PREFVAL(1))//'\RUNFILES\*.run'
LEX=UTL_WSELECTFILE('iMOD Run Files (*.run)|*.run|', &
SAVEDIALOG+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,'Save iMOD Run File')
ELSEIF(IFORMAT.EQ.2)THEN
CALL UTL_CREATEDIR(TRIM(PREFVAL(1))//'\MODELS')
FNAME=TRIM(PREFVAL(1))//'\MODELS\*.nam'
LEX=UTL_WSELECTFILE('Modflow 2005 Nam Files (*.nam)|*.nam|', &
SAVEDIALOG+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,'Save Modflow 2005 Files')
ENDIF
IF(LEX)EXIT
ENDIF
CASE (IDCANCEL)
EXIT
END SELECT
END SELECT
ENDDO
ELSE
!## take care of setting from imod-batch
IF(PBMAN%ISS.EQ.0)THEN
CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO1) !## steady-state
ELSE
CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO2) !## transient
IF(LEN_TRIM(PBMAN%TIMFNAME).EQ.0)THEN
!## start date
CALL ITIMETOGDATE(PBMAN%SDATE,IYR,IMH,IDY,IHR,IMT,ISC)
CALL WDIALOGPUTINTEGER(IDF_INTEGER2 ,IDY)
CALL WDIALOGPUTOPTION(IDF_MENU2 ,IMH)
CALL WDIALOGPUTINTEGER(IDF_INTEGER3 ,IYR)
CALL WDIALOGPUTINTEGER(IDF_INTEGER6 ,IHR)
CALL WDIALOGPUTINTEGER(IDF_INTEGER7 ,IMT)
CALL WDIALOGPUTINTEGER(IDF_INTEGER8 ,ISC)
!## end date
CALL ITIMETOGDATE(PBMAN%EDATE,IYR,IMH,IDY,IHR,IMT,ISC)
CALL WDIALOGPUTINTEGER(IDF_INTEGER4 ,IDY)
CALL WDIALOGPUTOPTION(IDF_MENU3 ,IMH)
CALL WDIALOGPUTINTEGER(IDF_INTEGER5 ,IYR)
CALL WDIALOGPUTINTEGER(IDF_INTEGER9 ,IHR)
CALL WDIALOGPUTINTEGER(IDF_INTEGER10,IMT)
CALL WDIALOGPUTINTEGER(IDF_INTEGER11,ISC)
CALL WDIALOGPUTINTEGER(IDF_INTEGER12,PBMAN%IDT)
CALL WDIALOGPUTOPTION(IDF_MENU4 ,PBMAN%ITT)
ENDIF
ENDIF
!## first idf
IF(PBMAN%IWINDOW.EQ.0)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO17)
!## window
IF(PBMAN%IWINDOW.EQ.1)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO15)
!## network idf
IF(PBMAN%IWINDOW.EQ.2)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO16)
CALL WDIALOGPUTREAL(IDF_REAL1,PBMAN%XMIN) !## xmin
CALL WDIALOGPUTREAL(IDF_REAL2,PBMAN%YMIN) !## ymin
CALL WDIALOGPUTREAL(IDF_REAL3,PBMAN%XMAX) !## xmax
CALL WDIALOGPUTREAL(IDF_REAL4,PBMAN%YMAX) !## ymax
CALL WDIALOGPUTREAL(IDF_REAL5,PBMAN%CELLSIZE) !## cellsize
CALL WDIALOGPUTREAL(IDF_REAL7,PBMAN%BUFFER) !## buffer
IF(PBMAN%BUFFER.LE.0.0)PBMAN%BUFFERCS=0.0
CALL WDIALOGPUTREAL(IDF_REAL8,PBMAN%BUFFERCS) !## buffer-cellsize
IF(PBMAN%IFORMAT.EQ.1)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO3) !## runfile
IF(PBMAN%IFORMAT.EQ.2)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO4) !## modflow2005
!## initial steady-state stress-period
CALL WDIALOGPUTCHECKBOX(IDF_CHECK2,PBMAN%ISTEADY)
IF(LEN_TRIM(PBMAN%TIMFNAME).NE.0)THEN
CALL PMANAGER_SAVETIMESTEPS(ID_OPEN,1,PBMAN%TIMFNAME)
ELSE
LEX=.TRUE.; IF(.NOT.ASSOCIATED(SIM))LEX=PMANAGER_FILLTIMESTEPS()
ENDIF
!## set modflow executable
PREFVAL(8)=PBMAN%MODFLOW
!## save only, or start model as well
MESSAGE%VALUE1=IDOK; IF(PBMAN%ISOLVE.EQ.1)MESSAGE%VALUE1=IDSIMULATE
ENDIF
IF(ASSOCIATED(SIM))SIM%ISUM=1
!## get file format of export
CALL WDIALOGGETRADIOBUTTON(IDF_RADIO3,IFORMAT)
CALL WDIALOGGETRADIOBUTTON(IDF_RADIO17,I)
PBMAN%IWINDOW=0
IF(I.EQ.3)THEN
CALL WDIALOGGETSTRING(IDF_STRING2,PBMAN%BNDFILE)
ISUBMODEL=0; PBMAN%IWINDOW=2
ELSE
!## apply submodelling
IF(I.EQ.2)THEN; ISUBMODEL=1; PBMAN%IWINDOW=1; ENDIF
SUBMODEL=0.0; IF(ISUBMODEL.EQ.1)THEN
CALL WDIALOGGETREAL(IDF_REAL1,SUBMODEL(1)) !## xmin
CALL WDIALOGGETREAL(IDF_REAL2,SUBMODEL(2)) !## ymin
CALL WDIALOGGETREAL(IDF_REAL3,SUBMODEL(3)) !## xmax
CALL WDIALOGGETREAL(IDF_REAL4,SUBMODEL(4)) !## ymax
CALL WDIALOGGETREAL(IDF_REAL5,SUBMODEL(5)) !## cellsize
CALL WDIALOGGETREAL(IDF_REAL7,SUBMODEL(6)) !## buffer
CALL WDIALOGGETREAL(IDF_REAL8,SUBMODEL(7)) !## buffercs
ENDIF
ENDIF
CALL WDIALOGGETREAL(IDF_REAL6,MINTHICKNESS)
!## get subsoil format
CALL WDIALOGGETRADIOBUTTON(IDF_RADIO5,I)
LBCF=.FALSE.; IF(I.EQ.1)LBCF=.TRUE.
LLPF=.FALSE.; IF(I.EQ.2)LLPF=.TRUE.
CALL WDIALOGGETRADIOBUTTON(IDF_RADIO7,I)
LQBD=.TRUE.; IF(I.EQ.1)LQBD=.FALSE.
!## output folder for a runfile
CALL WDIALOGGETSTRING(IDF_STRING1,MODELNAME)
CALL WDIALOGGETRADIOBUTTON(IDF_RADIO13,I)
IF(MESSAGE%VALUE1.EQ.IDCANCEL)RETURN
!## start the model as well
IF(MESSAGE%VALUE1.EQ.IDSIMULATE)IRUN=1
IF(I.EQ.2)IRUN=-1*IRUN
!## final check
IF((ITRANSIENT.EQ.1.AND.ISTEADY.EQ.0).AND.SIZE(SIM).EQ.1)THEN
IF(SIM(1)%DELT.EQ.0.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMOD cannot start this model as you have defined a timestep length'//CHAR(13)// &
'of zero (steady-state), and all your packages are assigned'//CHAR(13)//'to a transient period.','Warning')
RETURN
ENDIF
ENDIF
PMANAGER_INITSIM=.TRUE.
END FUNCTION PMANAGER_INITSIM
!###======================================================================
LOGICAL FUNCTION PMANAGER_INIT_SIMAREA(IDF,IBATCH)
!###======================================================================
IMPLICIT NONE
TYPE(IDFOBJ),INTENT(INOUT) :: IDF
INTEGER,INTENT(IN) :: IBATCH
INTEGER :: I,J,K,II
PMANAGER_INIT_SIMAREA=.FALSE.
! IF(PBMAN%IWINDOW.EQ.1)THEN; PMANAGER_INIT_SIMAREA=.TRUE.; RETURN; ENDIF
IF(PBMAN%IWINDOW.EQ.2)THEN
IF(IDFREAD(IDF,PBMAN%BNDFILE,0))THEN
PMANAGER_INIT_SIMAREA=.TRUE.; RETURN
ENDIF
ENDIF
! !## window specified
! IF(PBMAN%IWINDOW.EQ.1)THEN; PMANAGER_INIT_SIMAREA=.TRUE.; RETURN; ENDIF
!## get estimated of the current modeldomain
JLOOP: DO K=1,SIZE(TOPICS)
!## skip wel,mnw,hfb,isg,sfr
SELECT CASE (K)
CASE (15,19:21,29,30,33); CYCLE
END SELECT
IF(.NOT.ASSOCIATED(TOPICS(K)%STRESS))CYCLE
DO J=1,SIZE(TOPICS(K)%STRESS)
IF(.NOT.ASSOCIATED(TOPICS(K)%STRESS(J)%FILES))CYCLE
!## number of systems
DO I=1,SIZE(TOPICS(K)%STRESS(J)%FILES,1)
!## number of layers
DO II=1,SIZE(TOPICS(K)%STRESS(J)%FILES,2)
IF(TOPICS(K)%STRESS(J)%FILES(I,II)%ICNST.EQ.2)THEN
IF(.NOT.IDFREAD(IDF,TOPICS(K)%STRESS(J)%FILES(I,II)%FNAME,0))THEN
RETURN
ENDIF
EXIT JLOOP
ENDIF
ENDDO
ENDDO
ENDDO
ENDDO JLOOP
IF(K.GT.SIZE(TOPICS))THEN
IF(IBATCH.EQ.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMOD cannot determine the size of the model.'//CHAR(13)// &
'Please specify at least ONE IDF file in the PRJ file or'//CHAR(13)// &
'specify a simulation window beforehand','Error')
ELSE
WRITE(*,'(/A/)') 'iMOD cannot determine the size of the model. Please specify at least ONE IDF file in the PRJ file or '// &
'specify a simulation window beforehand'
ENDIF
RETURN
ENDIF
!## in case non-equi network is read, et rid of the ieq settings
CALL IDFDEALLOCATESX(IDF); IDF%IEQ=0
PMANAGER_INIT_SIMAREA=.TRUE.
END FUNCTION PMANAGER_INIT_SIMAREA
!###======================================================================
SUBROUTINE PMANAGERLAYERTYPES()
!###======================================================================
IMPLICIT NONE
INTEGER :: ITYPE
TYPE(WIN_MESSAGE) :: MESSAGE
INTEGER,ALLOCATABLE,DIMENSION(:) :: BLAYCON
INTEGER :: BNLAY
CALL WDIALOGSELECT(ID_DPMANAGERLAYERTYPES)
!## backup in case cancel is pressed
CALL WDIALOGPUTINTEGER(IDF_INTEGER1,NLAY)
ALLOCATE(BLAYCON(MXNLAY)); BLAYCON=LAYCON; BNLAY=NLAY
CALL PMANAGERLAYERTYPES_NLAY()
CALL WDIALOGSHOW(-1,-1,0,3)
DO
CALL WMESSAGE(ITYPE,MESSAGE)
SELECT CASE (ITYPE)
CASE (FIELDCHANGED)
SELECT CASE (MESSAGE%VALUE1)
END SELECT
CASE (PUSHBUTTON)
SELECT CASE (MESSAGE%VALUE1)
CASE (ID_APPLY)
CALL PMANAGERLAYERTYPES_NLAY()
CASE (IDOK)
CALL WGRIDGETMENU(IDF_GRID1,2,LAYCON,NLAY)
EXIT
CASE (IDCANCEL)
NLAY=BNLAY; LAYCON=BLAYCON
EXIT
CASE (IDHELP)
! CALL IMODGETHELP('3.3.6','VMO.iMODProjMan')
END SELECT
END SELECT
ENDDO
DEALLOCATE(BLAYCON)
CALL WDIALOGHIDE(); CALL WDIALOGSELECT(ID_DPMANAGER_SIM)
CALL WDIALOGPUTSTRING(ID_LAYERTYPES,'Define '//TRIM(ITOS(NLAY))//' Layer Types ...')
END SUBROUTINE PMANAGERLAYERTYPES
!###======================================================================
SUBROUTINE PMANAGERLAYERTYPES_NLAY()
!###======================================================================
IMPLICIT NONE
INTEGER :: I
CALL WDIALOGGETINTEGER(IDF_INTEGER1,NLAY)
CALL WGRIDROWS(IDF_GRID1,NLAY)
DO I=1,NLAY; CALL WGRIDPUTCELLSTRING(IDF_GRID1,1,I,'Layer '//TRIM(ITOS(I))); ENDDO
!## write boundary string lower layer
CALL WGRIDPUTOPTION(IDF_GRID1,2,LAYCON,NLAY)
IF(NLAY.LT.MXNLAY)CALL WGRIDPUTCELLOPTION(IDF_GRID1,2,NLAY,4)
END SUBROUTINE PMANAGERLAYERTYPES_NLAY
!###======================================================================
SUBROUTINE PMANAGER_TIMESTEPS()
!###======================================================================
IMPLICIT NONE
INTEGER :: ITYPE
TYPE(WIN_MESSAGE) :: MESSAGE
INTEGER :: DID,I,J,ISTEP,IROW,IROW1,IROW2,ION,ITG
!## fill timesteps
IF(.NOT.PMANAGER_FILLTIMESTEPS())RETURN
DID=WINFODIALOG(CURRENTDIALOG)
CALL WDIALOGLOAD(ID_DPMANAGER_TIMES,ID_DPMANAGER_TIMES)
CALL WDIALOGPUTIMAGE(ID_OPEN,ID_ICONOPEN,1)
CALL WDIALOGPUTIMAGE(ID_SAVE,ID_ICONSAVEAS,1)
CALL WDIALOGPUTMENU(IDF_MENU1,TMENU1,SIZE(TMENU1),2)
CALL WDIALOGTITLE('Time Discretization Manager for Simulation')
CALL WDIALOGFIELDOPTIONS(IDF_INTEGER1,EDITFIELDCHANGED,1)
CALL WDIALOGFIELDOPTIONS(IDF_INTEGER2,EDITFIELDCHANGED,1)
CALL PMANAGER_PUTTIMEINGRID()
CALL WDIALOGGETMENU(IDF_MENU1,I)
CALL PMANAGER_TIMESTEPS_GETISTEP(I,J,ISTEP)
CALL WDIALOGPUTINTEGER(IDF_INTEGER3,ISTEP)
CALL WDIALOGFIELDSTATE(IDF_INTEGER3,J)
CALL WGRIDSTATE(IDF_GRID1,1,2)
CALL WGRIDSTATE(IDF_GRID1,2,2)
CALL WDIALOGFIELDSTATE(IDF_RADIO3,0); CALL WDIALOGFIELDSTATE(IDF_RADIO4,0)
CALL WDIALOGSHOW(-1,-1,0,3)
DO
CALL WMESSAGE(ITYPE,MESSAGE)
SELECT CASE (ITYPE)
CASE(FIELDCHANGED)
SELECT CASE (MESSAGE%VALUE2)
CASE (IDF_RADIO1,IDF_RADIO2)
CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,I)
IF(I.EQ.1)THEN
CALL WDIALOGPUTSTRING(ID_APPLY,'Modify Time Steps')
CALL WDIALOGFIELDSTATE(IDF_RADIO3,0); CALL WDIALOGFIELDSTATE(IDF_RADIO4,0); CALL WDIALOGFIELDSTATE(IDF_LABEL6,0)
CALL WDIALOGPUTMENU(IDF_MENU1,TMENU1,SIZE(TMENU1),2)
ENDIF
IF(I.EQ.2)THEN
CALL WDIALOGPUTSTRING(ID_APPLY,'Modify Save Intervals')
CALL WDIALOGFIELDSTATE(IDF_RADIO3,1); CALL WDIALOGFIELDSTATE(IDF_RADIO4,1); CALL WDIALOGFIELDSTATE(IDF_LABEL6,1)
CALL WDIALOGPUTMENU(IDF_MENU1,TMENU2,SIZE(TMENU2),9)
ENDIF
CASE (IDF_MENU1)
CALL WDIALOGGETMENU(IDF_MENU1,I)
CALL PMANAGER_TIMESTEPS_GETISTEP(I,J,ISTEP)
CALL WDIALOGPUTINTEGER(IDF_INTEGER3,ISTEP)
CALL WDIALOGFIELDSTATE(IDF_INTEGER3,J)
CASE (IDF_INTEGER1,IDF_INTEGER2)
CALL WDIALOGGETINTEGER(IDF_INTEGER1,IROW1)
CALL WDIALOGGETINTEGER(IDF_INTEGER2,IROW2)
CALL WGRIDCOLOURCOLUMN(IDF_GRID1,1,-1,-1)
DO IROW=MIN(IROW1,IROW2),MAX(IROW1,IROW2)
CALL WGRIDCOLOURCELL(IDF_GRID1,1,IROW,-1,WRGB(255,0,0))
ENDDO
END SELECT
CASE(PUSHBUTTON)
SELECT CASE (MESSAGE%VALUE1)
CASE (ID_SELECTALL)
I=1; IF(SIM(1)%DELT.LE.0.0)I=2
CALL WDIALOGPUTINTEGER(IDF_INTEGER1,I)
CALL WDIALOGPUTINTEGER(IDF_INTEGER2,NPER)
CALL WGRIDCOLOURCOLUMN(IDF_GRID1,1,-1,-1)
DO IROW=I,NPER; CALL WGRIDCOLOURCELL(IDF_GRID1,1,IROW,-1,WRGB(255,0,0)); ENDDO
CASE (ID_APPLY)
CALL WDIALOGGETMENU(IDF_MENU1,I) !## period
CALL WDIALOGGETINTEGER(IDF_INTEGER1,IROW1)
CALL WDIALOGGETINTEGER(IDF_INTEGER2,IROW2)
CALL WDIALOGGETINTEGER(IDF_INTEGER3,ISTEP) !## number of repetitions
CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,ITG)
CALL WDIALOGGETRADIOBUTTON(IDF_RADIO3,ION)
CALL PMANAGER_INSERTTIMES(IROW1,IROW2,I,ISTEP,ITG,ION)
CASE (ID_SAVE,ID_OPEN)
!## store saving (done manually)
I=SIZE(SIM); CALL WGRIDGETINTEGER(IDF_GRID1,3,SIM%ISAVE,I)
CALL WGRIDGETINTEGER(IDF_GRID1,4,SIM%NSTP,I); CALL WGRIDGETREAL(IDF_GRID1,5,SIM%TMULT,I)
CALL PMANAGER_SAVETIMESTEPS(MESSAGE%VALUE1,0,'')
CASE (IDOK)
!## store saving (done manually)
I=SIZE(SIM); CALL WGRIDGETINTEGER(IDF_GRID1,3,SIM%ISAVE,I)
CALL WGRIDGETINTEGER(IDF_GRID1,4,SIM%NSTP,I); CALL WGRIDGETREAL(IDF_GRID1,5,SIM%TMULT,I)
EXIT
CASE (IDHELP)
CASE (IDCANCEL)
EXIT
END SELECT
END SELECT
ENDDO
CALL WDIALOGFIELDOPTIONS(IDF_INTEGER1,EDITFIELDCHANGED,0)
CALL WDIALOGFIELDOPTIONS(IDF_INTEGER2,EDITFIELDCHANGED,0)
CALL WDIALOGUNLOAD(); CALL WDIALOGSELECT(DID)
END SUBROUTINE PMANAGER_TIMESTEPS
!###======================================================================
SUBROUTINE PMANAGER_TIMESTEPS_GETISTEP(IPERIOD,ISTATE,ISTEP)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IPERIOD
INTEGER,INTENT(OUT) :: ISTATE,ISTEP
SELECT CASE (IPERIOD)
CASE (1,2,6,7) !## hourly,daily,monthly,yearly
ISTATE=1; ISTEP=1
CASE (3) !## weekly
ISTATE=1; ISTEP=1
CASE (4) !## decade
ISTATE=1; ISTEP=1
CASE (5) !## 14/28
ISTATE=0; ISTEP=14
CASE (8,9) !## all
ISTATE=0; ISTEP=0
END SELECT
END SUBROUTINE PMANAGER_TIMESTEPS_GETISTEP
!###======================================================================
SUBROUTINE PMANAGER_PUTTIMEINGRID()
!###======================================================================
IMPLICIT NONE
INTEGER :: I
IF(NPER.GT.WINFOGRID(IDF_GRID1,GRIDROWSMAX))THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'There is a maximum of '// &
TRIM(ITOS(WINFOGRID(IDF_GRID1,GRIDROWSMAX)))//' timesteps in this iMOD version'//CHAR(13)// &
'iMOD displays '//TRIM(ITOS(WINFOGRID(IDF_GRID1,GRIDROWSMAX)))//' records only of '//TRIM(ITOS(NPER)),'Warning')
NPER=WINFOGRID(IDF_GRID1,GRIDROWSMAX)
ALLOCATE(SIM_C(NPER)); DO I=1,NPER; SIM_C(I)=SIM(I); ENDDO; DEALLOCATE(SIM); SIM=>SIM_C
ENDIF
CALL WGRIDROWS(IDF_GRID1,NPER)
DO I=1,NPER; CALL WGRIDLABELROW(IDF_GRID1,I,TRIM(ITOS(I))); ENDDO
CALL WGRIDPUTSTRING (IDF_GRID1,1,SIM%CDATE,NPER)
CALL WGRIDPUTREAL (IDF_GRID1,2,SIM%DELT ,NPER)
CALL WGRIDPUTINTEGER(IDF_GRID1,3,SIM%ISAVE,NPER)
CALL WGRIDPUTINTEGER(IDF_GRID1,4,SIM%NSTP ,NPER)
CALL WGRIDPUTREAL (IDF_GRID1,5,SIM%TMULT,NPER)
CALL WGRIDSTATE(IDF_GRID1,1,2)
CALL WGRIDSTATE(IDF_GRID1,2,2)
I=1; IF(SIM(1)%DELT.LE.0.0)I=2; I=MIN(I,NPER)
CALL WDIALOGRANGEINTEGER(IDF_INTEGER1,I,NPER)
CALL WDIALOGRANGEINTEGER(IDF_INTEGER2,I,NPER)
CALL WDIALOGPUTINTEGER(IDF_INTEGER1,I)
CALL WDIALOGPUTINTEGER(IDF_INTEGER2,I)
CALL WGRIDCOLOURCOLUMN(IDF_GRID1,1,-1,-1)
CALL WGRIDCOLOURCELL(IDF_GRID1,1,I,-1,WRGB(255,0,0))
CALL WDIALOGPUTINTEGER(IDF_INTEGER4,NPER)
END SUBROUTINE PMANAGER_PUTTIMEINGRID
!###======================================================================
SUBROUTINE PMANAGER_INSERTTIMES(IROW1,IROW2,IPERIOD,ISTEP,ITG,ION)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IROW1,IROW2,IPERIOD,ISTEP,ITG,ION
INTEGER :: IR1,IR2,IHMS1,IHMS2,JD1,JD2,I,J
INTEGER(KIND=8),POINTER,DIMENSION(:) :: ITIME
INTEGER(KIND=8) :: STIME,ETIME
!## get the hours,minutes,seconds
IR1=MAX(1,IROW1); IR2=MIN(SIZE(SIM),IROW2+1)
IHMS1=HMSTOITIME(SIM(IR1)%IHR,SIM(IR1)%IMT,SIM(IR1)%ISC)
IHMS2=HMSTOITIME(SIM(IR2)%IHR,SIM(IR2)%IMT,SIM(IR2)%ISC)
JD1=JD(SIM(IR1)%IYR,SIM(IR1)%IMH,SIM(IR1)%IDY)
JD2=JD(SIM(IR2)%IYR,SIM(IR2)%IMH,SIM(IR2)%IDY)
ALLOCATE(SIM_C2(SIZE(SIM))); SIM_C2=SIM; DEALLOCATE(SIM)
!## all selected between irow1 and irow2
IF(ITG.EQ.2.AND.IPERIOD.EQ.9)THEN
NPER=IROW2-IROW1+1; ALLOCATE(SIM(NPER))
DO I=1,NPER; SIM(I)=SIM_C2(I+IROW1-1); ENDDO
ELSE
!## create new timesteps in between
ALLOCATE(SIM(100)); SIM%DELT=HUGE(1.0)
CALL PMANAGER_ASSIGNTIMESTEPS(1,2,JD1,JD2,IHMS1,IHMS2,IPERIOD,ISTEP)
ENDIF
!## adjust time-steps
IF(ITG.EQ.1)THEN
J=NPER+IR1+(SIZE(SIM_C2)-IR2+1)
ALLOCATE(ITIME(J))
!## fill in previous timesteps before ir1 - skip steady-state
J=0; DO I=1,IR1
J=J+1
ITIME(J)=SIM_C2(I)%IYR*10000000000+SIM_C2(I)%IMH*100000000+SIM_C2(I)%IDY*1000000+SIM_C2(I)%IHR*10000+SIM_C2(I)%IMT*100+SIM_C2(I)%ISC
ENDDO
STIME=ITIME(1)
!## fill in previous timesteps after ir2
DO I=IR2,SIZE(SIM_C2)
J=J+1
ITIME(J)=SIM_C2(I)%IYR*10000000000+SIM_C2(I)%IMH*100000000+SIM_C2(I)%IDY*1000000+SIM_C2(I)%IHR*10000+SIM_C2(I)%IMT*100+SIM_C2(I)%ISC
ENDDO
ETIME=ITIME(J)
!## fill in the renewed timsteps
DO I=1,NPER
J=J+1
ITIME(J)=SIM(I)%IYR*10000000000+SIM(I)%IMH*100000000+SIM(I)%IDY*1000000+SIM(I)%IHR*10000+SIM(I)%IMT*100+SIM(I)%ISC
ENDDO
CALL PMANAGER_SORTTIMES(ITIME,STIME,ETIME); DEALLOCATE(ITIME)
!## recompute delt
CALL PMANAGER_COMPUTEDELT()
!## adjust saving interval
ELSE
DO I=1,NPER
DO J=1,SIZE(SIM_C2)
IF(SIM(I)%IYR.EQ.SIM_C2(J)%IYR.AND. &
SIM(I)%IMH.EQ.SIM_C2(J)%IMH.AND. &
SIM(I)%IDY.EQ.SIM_C2(J)%IDY.AND. &
SIM(I)%IHR.EQ.SIM_C2(J)%IHR.AND. &
SIM(I)%IMT.EQ.SIM_C2(J)%IMT.AND. &
SIM(I)%ISC.EQ.SIM_C2(J)%ISC)THEN; SIM_C2(J)%ISAVE=ION-1; EXIT; ENDIF
ENDDO
ENDDO
DEALLOCATE(SIM); SIM=>SIM_C2; NPER=SIZE(SIM)
ENDIF
!## put in the menu
CALL PMANAGER_PUTTIMEINGRID()
END SUBROUTINE PMANAGER_INSERTTIMES
!###======================================================================
SUBROUTINE PMANAGER_ASSIGNTIMESTEPS(I1,I2,JD1,JD2,IHMS1,IHMS2,IPERIOD,JSTEP)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: I1,I2,IPERIOD,JD1,JD2,IHMS1,IHMS2,JSTEP
INTEGER :: I,ISTEP
ISTEP=JSTEP
!## fill in final date on position(1)
CALL UTL_GDATE(JD2,SIM(I1)%IYR,SIM(I1)%IMH,SIM(I1)%IDY)
CALL ITIMETOHMS(IHMS2,SIM(I1)%IHR,SIM(I1)%IMT,SIM(I1)%ISC)
!## fill in start date on position(1)
CALL UTL_GDATE(JD1,SIM(I2)%IYR,SIM(I2)%IMH,SIM(I2)%IDY)
CALL ITIMETOHMS(IHMS1,SIM(I2)%IHR,SIM(I2)%IMT,SIM(I2)%ISC)
!## overrule in case istep=0
IF(ISTEP.EQ.0)THEN
SELECT CASE (IPERIOD)
CASE (1,2,6,7) !## hourly,daily,monthly,yearly
ISTEP=1
CASE (3) !## weekly
ISTEP=7
CASE (4) !## decade
ISTEP=10
CASE (5) !## 14/28
ISTEP=14
END SELECT
ENDIF
SELECT CASE (IPERIOD)
CASE (3) !## weekly
ISTEP=JSTEP*7
CASE (4) !## decade
ISTEP=JSTEP*10
END SELECT
!## fill in intermediate timesteps
SELECT CASE (IPERIOD)
CASE (1) !## hourly
I=I2; DO; I=I+1; IF(.NOT.PMANAGER_ADDTIMESTEP(I,I1, ISTEP,4))EXIT; ENDDO; NPER=I
CASE (2) !## daily
I=I2; DO; I=I+1; IF(.NOT.PMANAGER_ADDTIMESTEP(I,I1, ISTEP,3))EXIT; ENDDO; NPER=I
CASE (3) !## weekly
I=I2; DO; I=I+1; IF(.NOT.PMANAGER_ADDTIMESTEP(I,I1, ISTEP,3))EXIT; ENDDO; NPER=I
CASE (4) !## decade
I=I2; DO; I=I+1; IF(.NOT.PMANAGER_ADDTIMESTEP(I,I1, ISTEP,3))EXIT; ENDDO; NPER=I
CASE (5) !## 14/28
I=I2; DO; I=I+1; IF(.NOT.PMANAGER_ADDTIMESTEP(I,I1,10,7))EXIT; ENDDO; NPER=I
CASE (6) !## monthly
I=I2; DO; I=I+1; IF(.NOT.PMANAGER_ADDTIMESTEP(I,I1, ISTEP,2))EXIT; ENDDO; NPER=I
CASE (7) !## yearly
I=I2; DO; I=I+1; IF(.NOT.PMANAGER_ADDTIMESTEP(I,I1, ISTEP,1))EXIT; ENDDO; NPER=I
CASE (8) !## packages
CALL PMANAGER_GETNPER(JD1,IHMS1,JD2,IHMS2)
END SELECT
!## remove first "temporary" timestep
SELECT CASE (IPERIOD)
CASE (1:7)
!## make sure size(sim) is equal to nper
ALLOCATE(SIM_C(NPER-1)); DO I=1,NPER-1; SIM_C(I)=SIM(I+1); ENDDO; DEALLOCATE(SIM); SIM=>SIM_C; NPER=NPER-1
END SELECT
DO I=1,NPER
WRITE(SIM(I)%CDATE,'(I4.4,5(A1,I2.2))') SIM(I)%IYR,'-',SIM(I)%IMH,'-',SIM(I)%IDY,' ',SIM(I)%IHR,':',SIM(I)%IMT,':',SIM(I)%ISC
SIM(I)%ISAVE=1; SIM(I)%ISUM =0; SIM(I)%TMULT=1.0; SIM(I)%NSTP=1
ENDDO
!## make sure size(sim) is equal to nper
IF(NPER.LT.SIZE(SIM))THEN
ALLOCATE(SIM_C(NPER)); DO I=1,NPER; SIM_C(I)=SIM(I); ENDDO; DEALLOCATE(SIM); SIM=>SIM_C
ENDIF
END SUBROUTINE PMANAGER_ASSIGNTIMESTEPS
!###======================================================================
SUBROUTINE PMANAGER_SAVETIMESTEPS(ID,IBATCH,FNAME_IN)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ID,IBATCH
CHARACTER(LEN=*),INTENT(IN) :: FNAME_IN
INTEGER :: I,N,IOS,IU
CHARACTER(LEN=256) :: FNAME
INTEGER(KIND=8) :: IDATE
IF(ID.EQ.ID_OPEN)THEN
IF(LEN_TRIM(FNAME_IN).EQ.0)THEN
FNAME=TRIM(PREFVAL(1))//'\RUNFILES\*.tim'
IF(.NOT.UTL_WSELECTFILE('iMOD Time Files (*.tim)|*.tim|', &
LOADDIALOG+MUSTEXIST+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,&
'Load iMOD Time File'))RETURN
ELSE
FNAME=FNAME_IN
ENDIF
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=FNAME,STATUS='OLD',ACTION='READ,DENYWRITE',FORM='FORMATTED')
IF(IU.EQ.0)RETURN
N=100; IF(ASSOCIATED(SIM))DEALLOCATE(SIM); ALLOCATE(SIM(N)); SIM%DELT=HUGE(1.0)
NPER=1; DO
READ(IU,'(A256)',IOSTAT=IOS) LINE; IF(IOS.NE.0)EXIT
READ(LINE,*,IOSTAT=IOS) SIM(NPER)%CDATE,SIM(NPER)%ISAVE,SIM(NPER)%NSTP,SIM(NPER)%TMULT
IF(IOS.NE.0)THEN
SIM(NPER)%NSTP=1; SIM(NPER)%TMULT=1.0
READ(LINE,*,IOSTAT=IOS) SIM(NPER)%CDATE,SIM(NPER)%ISAVE
IF(IOS.NE.0)EXIT
ENDIF
NPER=NPER+1
IF(NPER.GE.N)THEN
ALLOCATE(SIM_C(N+100)); DO I=1,N; SIM_C(I)=SIM(I); ENDDO
DEALLOCATE(SIM); SIM=>SIM_C; N=SIZE(SIM)
ENDIF
ENDDO
NPER=NPER-1
!## make sure lenght is equal to nper
IF(NPER.LT.SIZE(SIM))THEN
ALLOCATE(SIM_C(NPER)); SIM_C%DELT=HUGE(1.0); DO I=1,NPER; SIM_C(I)=SIM(I); ENDDO; DEALLOCATE(SIM); SIM=>SIM_C
ENDIF
DO I=1,NPER
READ(SIM(I)%CDATE,'(I14)') IDATE
CALL ITIMETOGDATE(IDATE,SIM(I)%IYR,SIM(I)%IMH,SIM(I)%IDY,SIM(I)%IHR,SIM(I)%IMT,SIM(I)%ISC)
ENDDO
CALL PMANAGER_COMPUTEDELT()
!## put in the menu
IF(IBATCH.EQ.0)CALL PMANAGER_PUTTIMEINGRID()
CLOSE(IU)
ELSEIF(ID.EQ.ID_SAVE)THEN
IF(LEN_TRIM(FNAME_IN).EQ.0)THEN
FNAME=TRIM(PREFVAL(1))//'\RUNFILES\*.tim'
IF(.NOT.UTL_WSELECTFILE('iMOD Time Files (*.tim)|*.tim|', &
SAVEDIALOG+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,'Save iMOD Time File'))RETURN
ELSE
FNAME=FNAME_IN
ENDIF
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE,DENYREAD',FORM='FORMATTED')
IF(IU.EQ.0)RETURN
DO I=1,SIZE(SIM)
WRITE(LINE,'(I4.4,5I2.2,A1,I2,A1,I4.4,A1,G10.5)') SIM(I)%IYR,SIM(I)%IMH,SIM(I)%IDY,SIM(I)%IHR,SIM(I)%IMT,SIM(I)%ISC, &
',',SIM(I)%ISAVE,',',SIM(I)%NSTP,',',SIM(I)%TMULT
WRITE(IU,'(A)') TRIM(LINE)
ENDDO
CLOSE(IU)
CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'Successfully written project tim-file:'//CHAR(13)//TRIM(FNAME),'Information')
ENDIF
END SUBROUTINE PMANAGER_SAVETIMESTEPS
!###======================================================================
SUBROUTINE PMANAGER_INITSIM_PACKAGES()
!###======================================================================
IMPLICIT NONE
INTEGER :: ITYPE
TYPE(WIN_MESSAGE) :: MESSAGE
INTEGER :: DID,I,N
CHARACTER(LEN=MAXLEN),ALLOCATABLE,DIMENSION(:) :: PLIST
INTEGER,ALLOCATABLE,DIMENSION(:) :: IPLIST,JPLIST
DID=WINFODIALOG(CURRENTDIALOG)
CALL WDIALOGLOAD(ID_DPMANAGER_PACKAGES,ID_DPMANAGER_PACKAGES)
ALLOCATE(PLIST(SIZE(TOPICS)),IPLIST(SIZE(TOPICS)),JPLIST(SIZE(TOPICS)))
PLIST=''; IPLIST=0; JPLIST=0
N=0; DO I=1,SIZE(TOPICS)
IF(ASSOCIATED(TOPICS(I)%STRESS))THEN
N=N+1; PLIST(N)=TOPICS(I)%TNAME; IPLIST(N)=TOPICS(I)%IACT_MODEL; JPLIST(N)=I
ENDIF
ENDDO
CALL WDIALOGPUTMENU(IDF_MENU1,PLIST,N,IPLIST)
CALL WDIALOGSHOW(-1,-1,0,3)
DO
CALL WMESSAGE(ITYPE,MESSAGE)
SELECT CASE (ITYPE)
CASE(FIELDCHANGED)
!## previous field
SELECT CASE (MESSAGE%VALUE1)
CASE (IDF_MENU1)
END SELECT
!## next field
SELECT CASE (MESSAGE%VALUE2)
CASE (IDF_MENU1)
END SELECT
CASE(PUSHBUTTON)
SELECT CASE (MESSAGE%VALUE1)
CASE (IDOK)
CALL WDIALOGGETMENU(IDF_MENU1,IPLIST)
DO I=1,N; TOPICS(JPLIST(I))%IACT_MODEL=IPLIST(I); ENDDO
EXIT
CASE (IDHELP)
CASE (IDCANCEL)
EXIT
END SELECT
END SELECT
ENDDO
CALL WDIALOGUNLOAD(); CALL WDIALOGSELECT(DID)
DEALLOCATE(PLIST,IPLIST,JPLIST)
END SUBROUTINE PMANAGER_INITSIM_PACKAGES
!###======================================================================
LOGICAL FUNCTION PMANAGER_FILLTIMESTEPS()
!###======================================================================
IMPLICIT NONE
INTEGER :: JD1,JD2,IPERIOD,I,ISS,IHR,IMT,ISC,IHMS1,IHMS2,ISTEADY,ISTEP
PMANAGER_FILLTIMESTEPS=.FALSE.
!## get timestep configurations
CALL WDIALOGGETMENU(IDF_MENU4,IPERIOD)
CALL WDIALOGGETINTEGER(IDF_INTEGER12,ISTEP)
!## custom settings
IF(IPERIOD.GE.9)THEN
IF(.NOT.ASSOCIATED(SIM))THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'No time step configuration set found','Error')
ELSE
PMANAGER_FILLTIMESTEPS=.TRUE.
ENDIF
RETURN
ENDIF
!## get steady-transient simulation option, ISS=1 steady, ISS=2 transient
CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,ISS)
CALL WDIALOGGETCHECKBOX(IDF_CHECK2,ISTEADY)
IF(ASSOCIATED(SIM))DEALLOCATE(SIM)
!## transient
IF(ISS.EQ.2)THEN
!## get the dates
CALL UTL_FILLDATES(IDF_INTEGER3,IDF_MENU2,IDF_INTEGER2,JD1)
CALL UTL_FILLDATES(IDF_INTEGER5,IDF_MENU3,IDF_INTEGER4,JD2)
!## get the hours,minutes,seconds
CALL WDIALOGGETINTEGER(IDF_INTEGER6,IHR)
CALL WDIALOGGETINTEGER(IDF_INTEGER7,IMT)
CALL WDIALOGGETINTEGER(IDF_INTEGER8,ISC)
IHMS1=HMSTOITIME(IHR,IMT,ISC)
CALL WDIALOGGETINTEGER(IDF_INTEGER9,IHR)
CALL WDIALOGGETINTEGER(IDF_INTEGER10,IMT)
CALL WDIALOGGETINTEGER(IDF_INTEGER11,ISC)
IHMS2=HMSTOITIME(IHR,IMT,ISC)
ALLOCATE(SIM(100)); SIM%DELT=HUGE(1.0)
CALL PMANAGER_ASSIGNTIMESTEPS(1,2,JD1,JD2,IHMS1,IHMS2,IPERIOD,ISTEP)
CALL PMANAGER_COMPUTEDELT()
!## add first steady-state step
IF(ISTEADY.EQ.1)THEN
ALLOCATE(SIM_C(NPER+1)); DO I=2,NPER+1; SIM_C(I)=SIM(I-1); ENDDO; DEALLOCATE(SIM); SIM=>SIM_C
!## first is always a steady-state - potentially
SIM(1)%CDATE='STEADY-STATE'; SIM(1)%DELT=0.0; SIM(1)%ISAVE=1; SIM(1)%ISUM=0
SIM(1)%IYR=0; SIM(1)%IMH=0; SIM(1)%IDY=0; SIM(1)%IHR=0; SIM(1)%IMT=0; SIM(1)%ISC=0
SIM(1)%NSTP=1; SIM(1)%TMULT=1.0
NPER=NPER+1
ENDIF
ELSE
NPER=1; ALLOCATE(SIM(1)); SIM%DELT=HUGE(1.0)
SIM(1)%CDATE='STEADY-STATE'; SIM(1)%DELT=0.0; SIM(1)%ISAVE=1; SIM(1)%ISUM=0
SIM(1)%IYR=0; SIM(1)%IMH=0; SIM(1)%IDY=0; SIM(1)%IHR=0; SIM(1)%IMT=0; SIM(1)%ISC=0
SIM(1)%NSTP=1; SIM(1)%TMULT=1.0
ENDIF
PMANAGER_FILLTIMESTEPS=.TRUE.
END FUNCTION PMANAGER_FILLTIMESTEPS
!###======================================================================
SUBROUTINE PMANAGER_COMPUTEDELT()
!###======================================================================
IMPLICIT NONE
INTEGER,PARAMETER :: SDAY=60*60*24
INTEGER :: JD1,JD2,I,ISC1,ISC2
DO I=1,NPER-1
!## skip steady-state
IF(SIM(I)%DELT.EQ.0.0.OR.SIM(I)%CDATE.EQ.'STEADY-STATE')CYCLE
IF(SIM(I)%IYR+SIM(I)%IMH+SIM(I)%IDY+SIM(I)%IHR+SIM(I)%IMT+SIM(I)%ISC.LE.0)THEN
SIM(I)%DELT=0.0; SIM(I)%CDATE='STEADY-STATE'
CYCLE
ENDIF
!## compute delta-t for previous timestep
JD1=JD(SIM(I )%IYR,SIM(I )%IMH,SIM(I )%IDY)
JD2=JD(SIM(I+1)%IYR,SIM(I+1)%IMH,SIM(I+1)%IDY)
SIM(I)%DDAY=JD2-JD1-1
!## compute net seconds between timesteps
ISC1=SIM(I)%IHR*3600+SIM(I)%IMT*60+SIM(I)%ISC
ISC1=SDAY-ISC1
ISC2=SIM(I+1)%IHR*3600+SIM(I+1)%IMT*60+SIM(I+1)%ISC
SIM(I)%DSEC=ISC1+ISC2
DO
IF(SIM(I)%DSEC.LT.SDAY)EXIT
SIM(I)%DDAY=SIM(I)%DDAY+1
SIM(I)%DSEC=SIM(I)%DSEC-SDAY
ENDDO
SIM(I)%DELT=REAL(SIM(I)%DDAY)+SIM(I)%DSEC/REAL(SDAY)
ENDDO
!## last timestep is zero 0 will not be part of the model
SIM(NPER)%DELT =0.0
SIM(NPER)%ISAVE=0.0
SIM(NPER)%ISUM =0.0
SIM%NSTP =1
SIM%TMULT =1.0
END SUBROUTINE PMANAGER_COMPUTEDELT
!###======================================================================
LOGICAL FUNCTION PMANAGER_ADDTIMESTEP(ISIM,ESIM,ISTEP,TSTEP)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ISIM,ESIM,TSTEP,ISTEP
INTEGER :: IDAY,IHMS1,IHMS2,JD1,JD2,I,N
!## added a step, or otherwise not
PMANAGER_ADDTIMESTEP=.TRUE.
!## check size of the SIM vector
IF(SIZE(SIM).LE.ISIM)THEN
N=SIZE(SIM)+100; ALLOCATE(SIM_C(N))
DO I=1,SIZE(SIM); SIM_C(I)=SIM(I); ENDDO
DEALLOCATE(SIM); SIM=>SIM_C
ENDIF
!## copy previous timestep
SIM(ISIM)=SIM(ISIM-1)
!## add a timestep to it according to the type of the timestep
SELECT CASE (TSTEP)
CASE (1) !## iyear
SIM(ISIM)%IYR=SIM(ISIM-1)%IYR+ISTEP
CASE (2) !## imonth
SIM(ISIM)%IMH=SIM(ISIM-1)%IMH+ISTEP
CASE (3) !## iday
SIM(ISIM)%IDY=SIM(ISIM-1)%IDY+ISTEP
CASE (4) !## ihour
SIM(ISIM)%IHR=SIM(ISIM-1)%IHR+ISTEP
CASE (5) !## iminute
SIM(ISIM)%IMT=SIM(ISIM-1)%IMT+ISTEP
CASE (6) !## isecond
SIM(ISIM)%ISC=SIM(ISIM-1)%ISC+ISTEP
CASE (7) !## 14/28
IF(SIM(ISIM-1)%IDY.EQ.14)THEN
SIM(ISIM)%IDY=28
ELSEIF(SIM(ISIM-1)%IDY.EQ.28)THEN
SIM(ISIM)%IDY=14; SIM(ISIM)%IMH=SIM(ISIM-1)%IMH+1
ELSEIF(SIM(ISIM-1)%IDY.GT.14.AND.SIM(ISIM-1)%IDY.LT.28)THEN
SIM(ISIM)%IDY=28
ELSE
SIM(ISIM)%IDY=14; IF(SIM(ISIM-1)%IDY.GT.28)SIM(ISIM)%IMH=SIM(ISIM-1)%IMH+1
ENDIF
END SELECT
!## correct seconds
DO
IF(SIM(ISIM)%ISC.LT.60)EXIT
SIM(ISIM)%ISC=SIM(ISIM)%ISC-60; SIM(ISIM)%IMT=SIM(ISIM)%IMT+1
ENDDO
!## correct minutes
DO
IF(SIM(ISIM)%IMT.LT.60)EXIT
SIM(ISIM)%IMT=SIM(ISIM)%IMT-60; SIM(ISIM)%IHR=SIM(ISIM)%IHR+1
ENDDO
!## correct hours
DO
IF(SIM(ISIM)%IHR.LT.24)EXIT
SIM(ISIM)%IHR=SIM(ISIM)%IHR-24; SIM(ISIM)%IDY=SIM(ISIM)%IDY+1
ENDDO
!## no minutes available ihms1=0 otherwise ihms1=1
IHMS1=HMSTOITIME(SIM(ISIM)%IHR,SIM(ISIM)%IMT,SIM(ISIM)%ISC)
IHMS1=MIN(IHMS1,1)
!## correct days
DO
IDAY=WDATEDAYSINMONTH(SIM(ISIM)%IYR,SIM(ISIM)%IMH)
IF(SIM(ISIM)%IDY.LE.IDAY)EXIT
SIM(ISIM)%IDY=SIM(ISIM)%IDY-IDAY; SIM(ISIM)%IMH=SIM(ISIM)%IMH+1
ENDDO
!## correct month
DO
IF(SIM(ISIM)%IMH.LE.12)EXIT
SIM(ISIM)%IMH=SIM(ISIM)%IMH-12; SIM(ISIM)%IYR=SIM(ISIM)%IYR+1
ENDDO
!## evaluate whether the new date is greater or equal esim - trim on it alternatively
JD1=JD(SIM(ISIM)%IYR,SIM(ISIM)%IMH,SIM(ISIM)%IDY)
JD2=JD(SIM(ESIM)%IYR,SIM(ESIM)%IMH,SIM(ESIM)%IDY)
IHMS1=HMSTOITIME(SIM(ISIM)%IHR,SIM(ISIM)%IMT,SIM(ISIM)%ISC)
IHMS2=HMSTOITIME(SIM(ESIM)%IHR,SIM(ESIM)%IMT,SIM(ESIM)%ISC)
!## not yet finished - return
IF(JD1.LT.JD2)THEN
RETURN
!## trim and finish
ELSEIF(JD1.GT.JD2)THEN
SIM(ISIM)=SIM(ESIM)
ELSE
!## not yet finished - return
IF(IHMS1.LT.IHMS2)THEN
RETURN
!## trim and finish
ELSE
SIM(ISIM)=SIM(ESIM)
ENDIF
ENDIF
PMANAGER_ADDTIMESTEP=.FALSE.
END FUNCTION PMANAGER_ADDTIMESTEP
!###======================================================================
SUBROUTINE PMANAGER_INITSIM_FIELDS()
!###======================================================================
IMPLICIT NONE
INTEGER :: I,J,K
!## window or bndfile
CALL WDIALOGGETRADIOBUTTON(IDF_RADIO17,K)
IF(K.EQ.1)THEN
I=0; J=0
ELSEIF(K.EQ.2)THEN
I=0; J=1
ELSEIF(K.EQ.3)THEN
I=1; J=0
ENDIF
CALL WDIALOGFIELDSTATE(IDF_STRING2,I)
CALL WDIALOGFIELDSTATE(ID_OPEN,I)
CALL WDIALOGFIELDSTATE(IDF_REAL1,J)
CALL WDIALOGFIELDSTATE(IDF_REAL2,J)
CALL WDIALOGFIELDSTATE(IDF_REAL3,J)
CALL WDIALOGFIELDSTATE(IDF_REAL4,J)
CALL WDIALOGFIELDSTATE(IDF_REAL5,J)
CALL WDIALOGFIELDSTATE(IDF_REAL7,J)
CALL WDIALOGFIELDSTATE(IDF_REAL8,J)
CALL WDIALOGFIELDSTATE(IDF_LABEL9,J)
CALL WDIALOGFIELDSTATE(IDF_LABEL10,J)
CALL WDIALOGFIELDSTATE(IDF_LABEL11,J)
CALL WDIALOGFIELDSTATE(IDF_LABEL12,J)
CALL WDIALOGFIELDSTATE(IDF_LABEL19,J)
CALL WDIALOGFIELDSTATE(ID_DRAW,J)
CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,I)
CALL WDIALOGFIELDSTATE(IDF_LABEL4,I-1)
CALL WDIALOGFIELDSTATE(IDF_LABEL6,I-1)
CALL WDIALOGFIELDSTATE(IDF_LABEL7,I-1)
CALL WDIALOGFIELDSTATE(IDF_INTEGER2,I-1)
CALL WDIALOGFIELDSTATE(IDF_INTEGER3,I-1)
CALL WDIALOGFIELDSTATE(IDF_INTEGER4,I-1)
CALL WDIALOGFIELDSTATE(IDF_INTEGER5,I-1)
CALL WDIALOGFIELDSTATE(IDF_INTEGER6 ,I-1)
CALL WDIALOGFIELDSTATE(IDF_INTEGER7 ,I-1)
CALL WDIALOGFIELDSTATE(IDF_INTEGER8 ,I-1)
CALL WDIALOGFIELDSTATE(IDF_INTEGER9 ,I-1)
CALL WDIALOGFIELDSTATE(IDF_INTEGER10,I-1)
CALL WDIALOGFIELDSTATE(IDF_INTEGER11,I-1)
CALL WDIALOGFIELDSTATE(IDF_MENU2,I-1)
CALL WDIALOGFIELDSTATE(IDF_MENU3,I-1)
CALL WDIALOGFIELDSTATE(IDF_MENU4,I-1)
CALL WDIALOGFIELDSTATE(IDF_CHECK2,I-1)
CALL WDIALOGFIELDSTATE(ID_SIMCUSTOMIZE,I-1)
CALL WDIALOGGETRADIOBUTTON(IDF_RADIO3,J)
CALL WDIALOGFIELDSTATE(IDF_STRING1,J)
J=J-1
!## creating a runfile cannot start that one - will be start the modeltool instead
CALL WDIALOGFIELDSTATE(IDSIMULATE,J)
CALL WDIALOGFIELDSTATE(IDF_RADIO13,J)
CALL WDIALOGFIELDSTATE(IDF_RADIO14,J)
!## minimal thickness
CALL WDIALOGFIELDSTATE(IDF_REAL6,J)
CALL WDIALOGFIELDSTATE(IDF_LABEL14,J)
CALL WDIALOGFIELDSTATE(IDF_RADIO11,J)
CALL WDIALOGFIELDSTATE(IDF_RADIO12,J)
!## single layer model - usage of interbeds
IF(NLAY.LE.1)THEN
CALL WDIALOGFIELDSTATE(IDF_LABEL22,0)
CALL WDIALOGFIELDSTATE(IDF_RADIO7,0)
CALL WDIALOGFIELDSTATE(IDF_RADIO8,0)
ELSE
!## if kvv specified use quasi-3d discretisation
I=0
IF(NLAY.GT.1)THEN
IF(ASSOCIATED(TOPICS(10)%STRESS))THEN
IF(ASSOCIATED(TOPICS(10)%STRESS(1)%FILES))I=1 !## kvv
ENDIF
ENDIF
IF(I.EQ.0)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO7) !## no interbeds
IF(I.EQ.1)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO8) !## interbeds
IF(J.EQ.1)THEN
CALL WDIALOGFIELDSTATE(IDF_RADIO7,ABS(I-1))
CALL WDIALOGFIELDSTATE(IDF_RADIO8,I)
CALL WDIALOGFIELDSTATE(IDF_LABEL22,1)
ELSE
CALL WDIALOGFIELDSTATE(IDF_RADIO7,0)
CALL WDIALOGFIELDSTATE(IDF_RADIO8,0)
CALL WDIALOGFIELDSTATE(IDF_LABEL22,0)
ENDIF
ENDIF
!## subsoil package
IF(J.EQ.1)THEN
CALL WDIALOGFIELDSTATE(IDF_LABEL20,1)
I=0; IF(LBCF)I=1; CALL WDIALOGFIELDSTATE(IDF_RADIO5,I)
I=0; IF(LLPF)I=1; CALL WDIALOGFIELDSTATE(IDF_RADIO6,I)
ELSE
CALL WDIALOGFIELDSTATE(IDF_LABEL20,0)
CALL WDIALOGFIELDSTATE(IDF_RADIO5,0)
CALL WDIALOGFIELDSTATE(IDF_RADIO6,0)
ENDIF
!## steady-state model
CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,I)
IF(I.EQ.1)THEN
CALL WDIALOGFIELDSTATE(IDF_LABEL23,0)
CALL WDIALOGFIELDSTATE(IDF_RADIO9,0)
CALL WDIALOGFIELDSTATE(IDF_RADIO10,0)
ELSE
CALL WDIALOGFIELDSTATE(IDF_LABEL23,I)
CALL WDIALOGFIELDSTATE(IDF_RADIO9,I)
CALL WDIALOGFIELDSTATE(IDF_RADIO10,I)
ENDIF
END SUBROUTINE PMANAGER_INITSIM_FIELDS
!###======================================================================
LOGICAL FUNCTION PMANAGER_GETKEYS(IU)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IU
INTEGER :: I,J,IOS
PMANAGER_GETKEYS=.FALSE.
DO I=1,SIZE(TOPICS); CALL PMANAGER_DEALLOCATE(I); ENDDO; CALL PMANAGER_DEALLOCATE_PEST()
READ(IU,*,IOSTAT=IOS); IF(IOS.NE.0)RETURN
READ(IU,*,IOSTAT=IOS) NLAY,NLAY,NPER,I,I,I,I,PEST%IIPF; IF(IOS.NE.0)RETURN
IF(PEST%IIPF.NE.0)THEN
ALLOCATE(PEST%MEASURES(ABS(PEST%IIPF)))
PEST%IIPF=MIN(PEST%IIPF,0); IF(PEST%IIPF.LT.0)PEST%IIPF=1
DO I=1,SIZE(PEST%MEASURES)
READ(IU,'(A256)') LINE
READ(LINE,*) PEST%MEASURES(I)%IPFNAME,PEST%MEASURES(I)%IPFTYPE,PEST%MEASURES(I)%IXCOL, &
PEST%MEASURES(I)%IYCOL ,PEST%MEASURES(I)%ILCOL ,PEST%MEASURES(I)%IMCOL,PEST%MEASURES(I)%IVCOL
ENDDO
ENDIF
!## skip common settings
READ(IU,*)
!## read pcg solvers settings
READ(IU,*) PCG%NOUTER,PCG%NINNER,PCG%HCLOSE,PCG%RCLOSE,PCG%RELAX
ALLOCATE(TOPICS(33)%STRESS(1)); ALLOCATE(TOPICS(33)%STRESS(1)%FILES(1,1))
TOPICS(33)%IACT=1; TOPICS(33)%IACT_MODEL=1
PCG%NPCOND=1
PCG%IPRPCG=1
PCG%MUTPCG=0
PCG%DAMPPCG=1.0
PCG%DAMPPCGT=1.0
!PCG%IMERGE=0
!PCG%PARTOPT=0
!PCG%NCORES=1
!## find available keys
J=0; DO
READ(IU,'(A256)') LINE; LINE=UTL_CAP(LINE,'U')
I=PMANAGER_FIND_KEYWORD(LINE)
IF(I.GT.0)THEN
TOPICS(I)%IACT=1; TOPICS(I)%IACT_MODEL=1; J=J+1
ELSE
IF(UTL_CAP(LINE,'U').EQ.'MODULES FOR EACH LAYER')EXIT
! IF(J.GT.0)EXIT
ENDIF
ENDDO
PMANAGER_GETKEYS=.TRUE.
END FUNCTION PMANAGER_GETKEYS
!###======================================================================
LOGICAL FUNCTION PMANAGER_GETFILES(IU,ITOPIC)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IU
INTEGER,INTENT(OUT) :: ITOPIC
INTEGER :: I,II,IOS,IPER,KPER,NSYS,ISYS,MSYS
CHARACTER(LEN=52) :: CDATE,C
REAL :: DELT,CNST
PMANAGER_GETFILES=.FALSE.
!## find available files for different keys
CDATE=''; IARMWP=0
DO
READ(IU,'(A256)',IOSTAT=IOS) LINE; IF(IOS.NE.0)EXIT; LINE=UTL_CAP(LINE,'U')
!## try to read timestamp
READ(LINE,*,IOSTAT=IOS) KPER,DELT,C,I; IF(IOS.EQ.0)CDATE=C
ITOPIC=PMANAGER_FIND_KEYWORD(LINE)
IF(ITOPIC.GT.0)THEN
IF(TOPICS(ITOPIC)%IACT.EQ.1)THEN
READ(LINE,*,IOSTAT=IOS) NSYS; IF(IOS.NE.0)RETURN; IF(NSYS.LE.0)CYCLE
!## reduce number of system to 1 for metaswap
IF(ITOPIC.EQ.1)THEN
MSYS=NSYS; NSYS=1
ENDIF
!## pst module
IF(ITOPIC.EQ.20)THEN
!## create new system
IPER=0; CALL PMANAGER_STRESSES(ITOPIC,IPER)
ISYS=0; CALL PMANAGER_SYSTEMS(ITOPIC,IPER,ISYS)
CALL PMANAGER_LOADPST(IU,NSYS,1); TOPICS(ITOPIC)%IACT_MODEL=1; CYCLE
ENDIF
!## create stress-period
IPER=0; CALL PMANAGER_STRESSES(ITOPIC,IPER)
!## create systems
ALLOCATE(TOPICS(ITOPIC)%STRESS(IPER)%FILES(TOPICS(ITOPIC)%NSUBTOPICS,NSYS))
TOPICS(ITOPIC)%STRESS(IPER)%IYR=0; TOPICS(ITOPIC)%STRESS(IPER)%IMH=0; TOPICS(ITOPIC)%STRESS(IPER)%IDY=0
TOPICS(ITOPIC)%STRESS(IPER)%IHR=0; TOPICS(ITOPIC)%STRESS(IPER)%IMT=0; TOPICS(ITOPIC)%STRESS(IPER)%ISC=0
IF(TOPICS(ITOPIC)%TIMDEP)THEN
TOPICS(ITOPIC)%STRESS(IPER)%CDATE=CDATE
READ(CDATE,'(I4,5I2)',IOSTAT=IOS) TOPICS(ITOPIC)%STRESS(IPER)%IYR,TOPICS(ITOPIC)%STRESS(IPER)%IMH,TOPICS(ITOPIC)%STRESS(IPER)%IDY, &
TOPICS(ITOPIC)%STRESS(IPER)%IHR,TOPICS(ITOPIC)%STRESS(IPER)%IMT,TOPICS(ITOPIC)%STRESS(IPER)%ISC
ENDIF
I=0; DO II=1,TOPICS(ITOPIC)%NSUBTOPICS
I=I+1
!## stop reading
IF(I.NE.II.AND.II.EQ.TOPICS(ITOPIC)%NSUBTOPICS)EXIT
DO ISYS=1,NSYS
SELECT CASE (ITOPIC)
CASE (1,13) !## msp,pwt
READ(IU,*,IOSTAT=IOS) TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%FCT, &
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%IMP, &
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%FNAME
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%ILAY=1
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%IACT=1
READ(TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%FNAME,*,IOSTAT=IOS) CNST
IF(IOS.EQ.0)THEN
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%ICNST=1
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%CNST =CNST
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%FNAME=''
ELSE
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%ICNST=2
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%CNST =-999.99
ENDIF
!## found ipf for artificial recharge
IF(ITOPIC.EQ.1.AND.I.EQ.8.AND.TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%ICNST.EQ.2)THEN
IF(INDEX(UTL_CAP(TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%FNAME,'U'),'.IPF').GT.0)THEN
TOPICS(1)%SNAME(7) ='Recharge-ID (IDF)'
TOPICS(1)%SNAME(8) ='Extraction (IPF)'
TOPICS(1)%SNAME(9) =''
I=I+1; IARMWP=1
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%FNAME=''
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%FCT=1.0
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%IMP=0.0
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%ICNST=1
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%CNST=-999.99
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%ILAY=1
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%IACT=1
ELSE
TOPICS(1)%SNAME(7) ='Artificial discharge (IDF)'
TOPICS(1)%SNAME(8) ='Artificial layer (IDF)'
TOPICS(1)%SNAME(9) ='Artificial location (IDF)'
ENDIF
ENDIF
CASE (29) !## isg
READ(IU,*,IOSTAT=IOS) TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%ILAY, &
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%FCT, &
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%IMP, &
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%FNAME
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%ICNST=2
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%CNST =-999.99
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%IACT =1
CASE DEFAULT
READ(IU,*,IOSTAT=IOS) TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%ILAY, &
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%FCT, &
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%IMP, &
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%FNAME
IF(IOS.NE.0)RETURN
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%IACT=1
READ(TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%FNAME,*,IOSTAT=IOS) CNST
IF(IOS.EQ.0)THEN
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%ICNST=1
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%CNST =CNST
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%FNAME=''
ELSE
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%ICNST=2
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%CNST =-999.99
ENDIF
END SELECT
IF(TRIM(PREFVAL(5)).NE.'')THEN
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%FNAME=UTL_SUBST(TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%FNAME,TRIM(REPLACESTRING),PREFVAL(5))
ENDIF
TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%ALIAS= &
UTL_CAP(TRIM(TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%FNAME(INDEX(TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,ISYS)%FNAME,'\',.TRUE.)+1:)),'L')
ENDDO
ENDDO
!## read in the inp files
IF(ITOPIC.EQ.1)THEN
MSYS=MSYS-TOPICS(ITOPIC)%NSUBTOPICS+IARMWP
ALLOCATE(TOPICS(ITOPIC)%STRESS(IPER)%INPFILES(MSYS))
DO ISYS=1,MSYS
READ(IU,'(A)',IOSTAT=IOS) TOPICS(ITOPIC)%STRESS(IPER)%INPFILES(ISYS)
TOPICS(ITOPIC)%STRESS(IPER)%INPFILES(ISYS)=ADJUSTL(TOPICS(ITOPIC)%STRESS(IPER)%INPFILES(ISYS))
ENDDO
ENDIF
ENDIF
ENDIF
ENDDO
PMANAGER_GETFILES=.TRUE.
END FUNCTION PMANAGER_GETFILES
!###======================================================================
SUBROUTINE PMANAGERDELETE()
!###======================================================================
IMPLICIT NONE
INTEGER :: ID,ITOPIC,IPER,ISYS,ISUBTOPIC,I,II,J,K,N,M
CHARACTER(LEN=256) :: CNAME,STRING
CHARACTER(LEN=4) :: EXT
CALL WDIALOGSELECT(ID_DPMANAGER); CALL WDIALOGGETTREEVIEW(ID_TREEVIEW1,ID,CNAME)
!## get the right topics and attribute from the treeview
IF(.NOT.PMANAGER_GETSELECTED(ID,ITOPIC,IPER,ISYS,ISUBTOPIC,1))RETURN
!## remove/clean entire topic
IF(IPER+ISYS+ISUBTOPIC.EQ.0)THEN
CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Are you sure to delete the content'//CHAR(13)// &
'for the topic ['//TRIM(TOPICS(ITOPIC)%TNAME)//']','Question'); IF(WINFODIALOG(4).NE.1)RETURN
CALL PMANAGER_DEALLOCATE(ITOPIC)
!## update the project manager for changes
CALL PMANAGERUPDATE(0,0,0)
ELSEIF(IPER.NE.0.AND.ISYS.NE.0.AND.ISUBTOPIC.NE.0)THEN
STRING='ilay='//TRIM(ITOS(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ILAY))
STRING=TRIM(STRING)//CHAR(13)//'fct='//TRIM(RTOS(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FCT,'*',3))
STRING=TRIM(STRING)//CHAR(13)//'imp='//TRIM(RTOS(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%IMP,'*',3))
!## constant value
IF(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ICNST.EQ.1)THEN
STRING=TRIM(STRING)//CHAR(13)//'cnst='//TRIM(RTOS(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%CNST,'*',3))
!## filename
ELSEIF(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ICNST.EQ.2)THEN
CNAME=TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ALIAS
EXT=CNAME(INDEX(CNAME,'.',.TRUE.)+1:)
STRING=TRIM(STRING)//CHAR(13)//TRIM(EXT)//'='//TRIM(CNAME) !TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ALIAS)
ENDIF
CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Are you sure to remove the selected entry:'//CHAR(13)//TRIM(STRING),'Question')
IF(WINFODIALOG(4).NE.1)RETURN
!## file selected, selected system will be deleted, thus conductance removes stage,bottom and inffactor as well.
!## delete selected file and decrease size of files().
N=SIZE(TOPICS(ITOPIC)%STRESS(IPER)%FILES,1) !## number of subtopics
M=SIZE(TOPICS(ITOPIC)%STRESS(IPER)%FILES,2) !## number of systems
IF(M.GT.1)THEN
ALLOCATE(TOPICS(ITOPIC)%STRESS(IPER)%FILES_TMP(N,M-1)) !## decrease size of the systems
DO I=1,N; K=0; DO J=1,M
IF(J.NE.ISYS)THEN
K=K+1
TOPICS(ITOPIC)%STRESS(IPER)%FILES_TMP(I,K)=TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,J)
ENDIF
ENDDO; ENDDO
DEALLOCATE(TOPICS(ITOPIC)%STRESS(IPER)%FILES)
TOPICS(ITOPIC)%STRESS(IPER)%FILES=>TOPICS(ITOPIC)%STRESS(IPER)%FILES_TMP
ELSE
!## remove current date - nothing left
IF(TOPICS(ITOPIC)%TIMDEP)THEN
!## make copy of current memory
N=SIZE(TOPICS(ITOPIC)%STRESS)
NULLIFY(TOPICS(ITOPIC)%STRESS_TMP)
ALLOCATE(TOPICS(ITOPIC)%STRESS_TMP(N-1))
II=0; DO I=1,N
IF(I.EQ.IPER)CYCLE
II=II+1
J=SIZE(TOPICS(ITOPIC)%STRESS(I)%FILES,1)
K=SIZE(TOPICS(ITOPIC)%STRESS(I)%FILES,2)
NULLIFY(TOPICS(ITOPIC)%STRESS_TMP(II)%FILES)
NULLIFY(TOPICS(ITOPIC)%STRESS_TMP(II)%INPFILES)
ALLOCATE(TOPICS(ITOPIC)%STRESS_TMP(II)%FILES(J,K))
TOPICS(ITOPIC)%STRESS_TMP(II)%FILES=TOPICS(ITOPIC)%STRESS(I)%FILES
TOPICS(ITOPIC)%STRESS_TMP(II)%CDATE=TOPICS(ITOPIC)%STRESS(I)%CDATE
TOPICS(ITOPIC)%STRESS_TMP(II)%IYR=TOPICS(ITOPIC)%STRESS(I)%IYR
TOPICS(ITOPIC)%STRESS_TMP(II)%IMH=TOPICS(ITOPIC)%STRESS(I)%IMH
TOPICS(ITOPIC)%STRESS_TMP(II)%IDY=TOPICS(ITOPIC)%STRESS(I)%IDY
TOPICS(ITOPIC)%STRESS_TMP(II)%IHR=TOPICS(ITOPIC)%STRESS(I)%IHR
TOPICS(ITOPIC)%STRESS_TMP(II)%IMT=TOPICS(ITOPIC)%STRESS(I)%IMT
TOPICS(ITOPIC)%STRESS_TMP(II)%ISC=TOPICS(ITOPIC)%STRESS(I)%ISC
DEALLOCATE(TOPICS(ITOPIC)%STRESS(I)%FILES)
ENDDO
TOPICS(ITOPIC)%STRESS=>TOPICS(ITOPIC)%STRESS_TMP
ELSE
DEALLOCATE(TOPICS(ITOPIC)%STRESS(1)%FILES)
DEALLOCATE(TOPICS(ITOPIC)%STRESS)
TOPICS(ITOPIC)%IACT_MODEL=0
ENDIF
ENDIF
!## if pest associated, remove number of pest parameters
IF(ITOPIC.EQ.20)CALL PMANAGER_DEALLOCATE_PEST()
!## update the project manager for changes - on topic level, other is not possible
CALL PMANAGERUPDATE(ITOPIC,IPER,ISUBTOPIC)
!## remove selected date
ELSEIF(IPER.NE.0.AND.ISYS.EQ.0.AND.ISUBTOPIC.EQ.0)THEN
CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Are you sure to delete the selected date ['//TRIM(TOPICS(ITOPIC)%STRESS(IPER)%CDATE)//']'//CHAR(13)// &
' for the topic ['//TRIM(TOPICS(ITOPIC)%TNAME)//']','Question'); IF(WINFODIALOG(4).NE.1)RETURN
!## make copy of current memory
N=SIZE(TOPICS(ITOPIC)%STRESS)
IF(N.GT.1)THEN
NULLIFY(TOPICS(ITOPIC)%STRESS_TMP)
ALLOCATE(TOPICS(ITOPIC)%STRESS_TMP(N-1))
M=0
DO I=1,N
!## skip selected period (do not copy)
IF(I.EQ.IPER)CYCLE
M=M+1
J =SIZE(TOPICS(ITOPIC)%STRESS(I)%FILES,1)
K =SIZE(TOPICS(ITOPIC)%STRESS(I)%FILES,2)
NULLIFY(TOPICS(ITOPIC)%STRESS_TMP(M)%FILES)
ALLOCATE(TOPICS(ITOPIC)%STRESS_TMP(M)%FILES(J,K))
TOPICS(ITOPIC)%STRESS_TMP(M)%FILES=TOPICS(ITOPIC)%STRESS(I)%FILES
TOPICS(ITOPIC)%STRESS_TMP(M)%CDATE=TOPICS(ITOPIC)%STRESS(I)%CDATE
TOPICS(ITOPIC)%STRESS_TMP(M)%IYR=TOPICS(ITOPIC)%STRESS(I)%IYR
TOPICS(ITOPIC)%STRESS_TMP(M)%IMH=TOPICS(ITOPIC)%STRESS(I)%IMH
TOPICS(ITOPIC)%STRESS_TMP(M)%IDY=TOPICS(ITOPIC)%STRESS(I)%IDY
TOPICS(ITOPIC)%STRESS_TMP(M)%IHR=TOPICS(ITOPIC)%STRESS(I)%IHR
TOPICS(ITOPIC)%STRESS_TMP(M)%IMT=TOPICS(ITOPIC)%STRESS(I)%IMT
TOPICS(ITOPIC)%STRESS_TMP(M)%ISC=TOPICS(ITOPIC)%STRESS(I)%ISC
DEALLOCATE(TOPICS(ITOPIC)%STRESS(I)%FILES)
ENDDO
TOPICS(ITOPIC)%STRESS=>TOPICS(ITOPIC)%STRESS_TMP
ELSE
DEALLOCATE(TOPICS(ITOPIC)%STRESS(IPER)%FILES)
DEALLOCATE(TOPICS(ITOPIC)%STRESS)
ENDIF
CALL PMANAGERUPDATE(ITOPIC,0,0)
ELSE
CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'You should select a topic or a individual filename','Question')
IF(WINFODIALOG(4).NE.1)RETURN
ENDIF
END SUBROUTINE PMANAGERDELETE
!###======================================================================
SUBROUTINE PMANAGERFIELDS()
!###======================================================================
IMPLICIT NONE
INTEGER :: I,ID
CALL WDIALOGSELECT(ID_DPMANAGER)
CALL WDIALOGUNDEFINED(IVALUE=-1); CALL UTL_DEBUGLEVEL(0)
CALL WDIALOGGETTREEVIEW(ID_TREEVIEW1,ID); CALL UTL_DEBUGLEVEL(1)
!## nothing selected
IF(ID.EQ.-1)ID=0; ID=MAX(ID,0); I=1; IF(ID.EQ.0)I=0
CALL WDIALOGFIELDSTATE(ID_DRAW,I)
CALL WDIALOGFIELDSTATE(ID_PROPERTIES,I)
CALL WDIALOGFIELDSTATE(ID_PROPERTIES_AUTO,I)
END SUBROUTINE PMANAGERFIELDS
!###======================================================================
SUBROUTINE PMANAGERUPDATE(IDITOPIC,IDIPER,IDISUBS)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IDITOPIC,IDIPER,IDISUBS
INTEGER :: IPER,I,J,K,N,IDTOPIC,IDSUBTC,IFILES,NF,MF,JD
CHARACTER(LEN=256) :: STRING,CNAME
CHARACTER(LEN=4) :: EXT
I=INFOERROR(1)
JD=0
CALL PMANAGER_ALLOCATE()
CALL WDIALOGSELECT(ID_DPMANAGER); CALL WDIALOGCLEARFIELD(ID_TREEVIEW1)
#if (defined(WINTERACTER11))
CALL WDIALOGTREEVIEWCHECK(0)
#endif
IDTOPIC=1000-1; IDSUBTC=2000-1
IFILES=0; DO I=1,SIZE(TOPICS)
IDTOPIC =IDTOPIC+1
TOPICS(I)%ID=IDTOPIC
!## create main topics
CALL WDIALOGINSERTTREEVIEWITEM(ID_TREEVIEW1,TOPICS(MAX(1,I-1))%ID,INSERTAFTER, &
TOPICS(I)%ID,TRIM(TOPICS(I)%TNAME))
!## stress periods available
N=0; IF(ASSOCIATED(TOPICS(I)%STRESS))N=SIZE(TOPICS(I)%STRESS)
IF(N.GT.0)THEN
!## create timestamps
DO IPER=1,SIZE(TOPICS(I)%STRESS)
NF=0; MF=0
IF(ASSOCIATED(TOPICS(I)%STRESS(IPER)%FILES))THEN
NF=SIZE(TOPICS(I)%STRESS(IPER)%FILES,1); MF=SIZE(TOPICS(I)%STRESS(IPER)%FILES,2)
ENDIF
!## create timestamp - only whenever files are active
IF(TOPICS(I)%TIMDEP.AND.NF.GT.0)THEN
IDSUBTC =IDSUBTC+1
TOPICS(I)%IDT(IPER)=IDSUBTC
IF(TOPICS(I)%STRESS(IPER)%IYR+TOPICS(I)%STRESS(IPER)%IMH+TOPICS(I)%STRESS(IPER)%IDY+ &
TOPICS(I)%STRESS(IPER)%IHR+TOPICS(I)%STRESS(IPER)%IMT+TOPICS(I)%STRESS(IPER)%ISC.GT.0)THEN
WRITE(STRING,'(I4.4,5(A1,I2.2))') TOPICS(I)%STRESS(IPER)%IYR,'-', &
TOPICS(I)%STRESS(IPER)%IMH,'-', &
TOPICS(I)%STRESS(IPER)%IDY,' ', &
TOPICS(I)%STRESS(IPER)%IHR,':', &
TOPICS(I)%STRESS(IPER)%IMT,':', &
TOPICS(I)%STRESS(IPER)%ISC
ELSE
STRING=TRIM(TOPICS(I)%STRESS(IPER)%CDATE)
ENDIF
CALL WDIALOGINSERTTREEVIEWITEM(ID_TREEVIEW1,TOPICS(I)%ID,INSERTCHILD, &
TOPICS(I)%IDT(IPER),TRIM(STRING))
ELSE
TOPICS(I)%IDT(IPER)=TOPICS(I)%ID
ENDIF
!## create subtopics names - only whenever files are active
IF(TOPICS(I)%NSUBTOPICS.GT.1.AND.NF.GT.0)THEN
DO J=1,TOPICS(I)%NSUBTOPICS
IDSUBTC =IDSUBTC+1
TOPICS(I)%ISD(IPER,J)=IDSUBTC
CALL WDIALOGINSERTTREEVIEWITEM(ID_TREEVIEW1,TOPICS(I)%IDT(IPER),INSERTCHILD, &
TOPICS(I)%ISD(IPER,J),TRIM(TOPICS(I)%SNAME(J)))
END DO
ELSE
TOPICS(I)%ISD(IPER,1)=TOPICS(I)%IDT(IPER)
ENDIF
DO J=1,NF !## number of periods (types)
DO K=1,MF !## number of files (systems)
IDSUBTC=IDSUBTC+1
IFILES=IFILES+1
TOPICS(I)%STRESS(IPER)%FILES(J,K)%ID=IDSUBTC
STRING=''
IF(TOPICS(I)%STRESS(IPER)%FILES(J,K)%IACT.EQ.0)THEN
STRING='* inactive *;'
ENDIF
!## pst is a special case
IF(I.EQ.20)THEN
IF(ASSOCIATED(PEST%MEASURES))THEN
STRING=TRIM(STRING)//'nmeasures='//TRIM(ITOS(SIZE(PEST%MEASURES)))
ELSE
STRING=TRIM(STRING)//'nmeasures=0'
ENDIF
IF(ASSOCIATED(PEST%PARAM))THEN
STRING=TRIM(STRING)//';nparam='//TRIM(ITOS(SIZE(PEST%PARAM)))
ELSE
STRING=TRIM(STRING)//';nparam=0'
ENDIF
IF(ASSOCIATED(PEST%S_PERIOD))THEN
STRING=TRIM(STRING)//';nperiods='//TRIM(ITOS(SIZE(PEST%S_PERIOD)))
ELSE
STRING=TRIM(STRING)//';nperiods=0'
ENDIF
IF(ASSOCIATED(PEST%B_FRACTION))THEN
STRING=TRIM(STRING)//';nbatchfiles='//TRIM(ITOS(SIZE(PEST%B_FRACTION)))
ELSE
STRING=TRIM(STRING)//';nbatchfiles=0'
ENDIF
IF(ASSOCIATED(PEST%IDFFILES))THEN
STRING=TRIM(STRING)//';nzones='//TRIM(ITOS(SIZE(PEST%IDFFILES)))
ELSE
STRING=TRIM(STRING)//';nzones=0'
ENDIF
!## pcg-settings
ELSEIF(I.EQ.33)THEN
STRING=TRIM(STRING)//'outer='//TRIM(ITOS(PCG%NOUTER))//';inner='// &
TRIM(ITOS(PCG%NINNER))//';hclose='//TRIM(RTOS(PCG%HCLOSE,'G',5))// &
';rclose='//TRIM(RTOS(PCG%RCLOSE,'G',5))
ELSE
STRING=TRIM(STRING)//'ilay='//TRIM(ITOS(TOPICS(I)%STRESS(IPER)%FILES(J,K)%ILAY))
! IF(TOPICS(I)%STRESS(IPER)%FILES(J,K)%ICNST.EQ.0)THEN
! STRING=TRIM(STRING)//';inherent'
! ELSE
IF(TOPICS(I)%STRESS(IPER)%FILES(J,K)%ICNST.EQ.1)THEN
STRING=TRIM(STRING)//';cnst='//TRIM(RTOS(TOPICS(I)%STRESS(IPER)%FILES(J,K)%CNST,'*',3))
ELSEIF(TOPICS(I)%STRESS(IPER)%FILES(J,K)%ICNST.EQ.2)THEN
CNAME=TOPICS(I)%STRESS(IPER)%FILES(J,K)%ALIAS
EXT=UTL_CAP(CNAME(INDEX(CNAME,'.',.TRUE.)+1:),'L')
STRING=TRIM(STRING)//';'//CHAR(13)//TRIM(EXT)//'='//TRIM(CNAME)
ENDIF
STRING=TRIM(STRING)//';fct='//TRIM(RTOS(TOPICS(I)%STRESS(IPER)%FILES(J,K)%FCT,'*',3))
STRING=TRIM(STRING)//';imp='//TRIM(RTOS(TOPICS(I)%STRESS(IPER)%FILES(J,K)%IMP,'*',3))
! ENDIF
ENDIF
CALL WDIALOGINSERTTREEVIEWITEM(ID_TREEVIEW1,TOPICS(I)%ISD(IPER,J),INSERTCHILD, &
TOPICS(I)%STRESS(IPER)%FILES(J,K)%ID,TRIM(STRING))
!## select file of first type
IF(J.EQ.1.AND.IDITOPIC.EQ.I.AND.IDIPER.EQ.IPER.AND.IDISUBS.EQ.K)THEN
JD=TOPICS(I)%STRESS(IPER)%FILES(J,K)%ID
ENDIF
END DO
END DO
ENDDO
ENDIF
END DO
#if (defined(WINTERACTER11))
CALL WDIALOGTREEVIEWCHECK(1)
#endif
! !## expand the last selected id of filename
! IF(IDITOPIC.NE.0.AND.IDIPER.NE.0.AND.IDISUBS.NE.0)THEN
! CALL WDIALOGSETTREEVIEWSTATE(IDF_TREEVIEW1,TOPICS(I)%ID,BranchCollapsed)
! CALL WDIALOGPUTTREEVIEW(ID_TREEVIEW1,TOPICS(IDITOPIC)%ISD(IDIPER,IDISUBS)) !,BRANCHEXPANDED)
! ELSEIF(IDITOPIC.NE.0.AND.IDIPER.NE.0)THEN
! CALL WDIALOGPUTTREEVIEW(ID_TREEVIEW1,TOPICS(IDITOPIC)%IDT(IDIPER)) !,BRANCHEXPANDED)
! ELSEIF(IDITOPIC.NE.0)THEN
! CALL WDIALOGPUTTREEVIEW(ID_TREEVIEW1,TOPICS(IDITOPIC)%ID) !,BranchCollapsed)
! ENDIF
!## select appropriate id's
IF(JD.NE.0)CALL WDIALOGPUTTREEVIEW(ID_TREEVIEW1,JD)
I=INFOERROR(1)
END SUBROUTINE PMANAGERUPDATE
!###======================================================================
SUBROUTINE PMANAGERSHOW(ICODE)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ICODE
CALL WINDOWSELECT(0)
IF(WMENUGETSTATE(ID_PMANAGER,2).EQ.1)THEN
IF(ICODE.EQ.0)THEN; CALL PMANAGERCLOSE(); RETURN; ENDIF
ENDIF
CALL WMENUSETSTATE(ID_PMANAGER,2,1)
CALL WDIALOGSELECT(ID_DPMANAGER); CALL WDIALOGSHOW(0,65,0,2)
END SUBROUTINE PMANAGERSHOW
!###======================================================================
SUBROUTINE PMANAGERINIT()
!###======================================================================
IMPLICIT NONE
INTEGER :: I
TOPICS(1)%TNAME ='(CAP) MetaSwap'
TOPICS(2)%TNAME ='(TOP) Top Elevation'
TOPICS(3)%TNAME ='(BOT) Bottom Elevation'
TOPICS(4)%TNAME ='(BND) Boundary Condition'
TOPICS(5)%TNAME ='(SHD) Starting Heads'
TOPICS(6)%TNAME ='(KDW) Transmissivity'
TOPICS(7)%TNAME ='(KHV) Horizontal Permeability'
TOPICS(8)%TNAME ='(KVA) Vertical Anisotropy'
TOPICS(9)%TNAME ='(VCW) Vertical Resistance'
TOPICS(10)%TNAME='(KVV) Vertical Permeability'
TOPICS(11)%TNAME='(STO) Confined Storage Coefficient'
TOPICS(12)%TNAME='(SPY) Specific Yield'
TOPICS(13)%TNAME='(PWT) Perched Water Table'
TOPICS(14)%TNAME='(ANI) Anisotropy'
TOPICS(15)%TNAME='(HFB) Horizontal Flow Barrier'
TOPICS(16)%TNAME='(IBS) Interbed Storage'
TOPICS(17)%TNAME='(SFT) StreamFlow Thickness'
TOPICS(18)%TNAME='(UZF) Unsaturated Zone Flow Package'
TOPICS(19)%TNAME='(MNW) Multi Node Well Package'
TOPICS(20)%TNAME='(PST) Parameter Estimation'
TOPICS(21)%TNAME='(WEL) Wells'
TOPICS(22)%TNAME='(DRN) Drainage'
TOPICS(23)%TNAME='(RIV) Rivers'
TOPICS(24)%TNAME='(EVT) Evapotranspiration'
TOPICS(25)%TNAME='(GHB) General Head Boundary'
TOPICS(26)%TNAME='(RCH) Recharge'
TOPICS(27)%TNAME='(OLF) Overland Flow'
TOPICS(28)%TNAME='(CHD) Constant Head Boundary'
TOPICS(29)%TNAME='(ISG) iMOD Segment Rivers'
TOPICS(30)%TNAME='(SFR) Stream Flow Routing'
TOPICS(31)%TNAME='(FHB) Flow and Head Boundary'
TOPICS(32)%TNAME='(LAK) Lake Package'
TOPICS(33)%TNAME='(PCG) Precondition Conjugate-Gradient'
TOPICS(1)%NSUBTOPICS =22 !CAP
TOPICS(2)%NSUBTOPICS =1 !TOP
TOPICS(3)%NSUBTOPICS =1 !BOT
TOPICS(4)%NSUBTOPICS =1 !BND
TOPICS(5)%NSUBTOPICS =1 !SHD
TOPICS(6)%NSUBTOPICS =1 !KDW
TOPICS(7)%NSUBTOPICS =1 !KHV
TOPICS(8)%NSUBTOPICS =1 !KHA
TOPICS(9)%NSUBTOPICS =1 !VCW
TOPICS(10)%NSUBTOPICS=1 !KVV
TOPICS(11)%NSUBTOPICS=1 !STO
TOPICS(12)%NSUBTOPICS=1 !SSC
TOPICS(13)%NSUBTOPICS=6 !PWT
TOPICS(14)%NSUBTOPICS=2 !ANI
TOPICS(15)%NSUBTOPICS=1 !HFB
TOPICS(16)%NSUBTOPICS=4 !IBS
TOPICS(17)%NSUBTOPICS=2 !SFT
TOPICS(18)%NSUBTOPICS=8 !UZF
TOPICS(19)%NSUBTOPICS=1 !MNW
TOPICS(20)%NSUBTOPICS=1 !PST
TOPICS(21)%NSUBTOPICS=1 !WEL
TOPICS(22)%NSUBTOPICS=2 !DRN
TOPICS(23)%NSUBTOPICS=4 !RIV
TOPICS(24)%NSUBTOPICS=3 !EVT
TOPICS(25)%NSUBTOPICS=2 !GHB
TOPICS(26)%NSUBTOPICS=1 !RCH
TOPICS(27)%NSUBTOPICS=1 !OLF
TOPICS(28)%NSUBTOPICS=1 !CHD
TOPICS(29)%NSUBTOPICS=1 !ISG
TOPICS(30)%NSUBTOPICS=1 !SFR
TOPICS(31)%NSUBTOPICS=2 !FHB
TOPICS(32)%NSUBTOPICS=10 !LAK
TOPICS(33)%NSUBTOPICS=1 !PCG
TOPICS(1)%TIMDEP =.FALSE. !CAP
TOPICS(2)%TIMDEP =.FALSE. !TOP
TOPICS(3)%TIMDEP =.FALSE. !BOT
TOPICS(4)%TIMDEP =.FALSE. !BND
TOPICS(5)%TIMDEP =.FALSE. !SHD
TOPICS(6)%TIMDEP =.FALSE. !KDW
TOPICS(7)%TIMDEP =.FALSE. !KHV
TOPICS(8)%TIMDEP =.FALSE. !KVA
TOPICS(9)%TIMDEP =.FALSE. !VCW
TOPICS(10)%TIMDEP=.FALSE. !KVV
TOPICS(11)%TIMDEP=.FALSE. !STO
TOPICS(12)%TIMDEP=.FALSE. !SSC
TOPICS(13)%TIMDEP=.FALSE. !PWT
TOPICS(14)%TIMDEP=.FALSE. !ANI
TOPICS(15)%TIMDEP=.FALSE. !HFB
TOPICS(16)%TIMDEP=.FALSE. !IBS
TOPICS(17)%TIMDEP=.FALSE. !SFT
TOPICS(18)%TIMDEP=.TRUE. !UZF
TOPICS(19)%TIMDEP=.TRUE. !MNW
TOPICS(20)%TIMDEP=.FALSE. !PST
TOPICS(21)%TIMDEP=.TRUE. !WEL
TOPICS(22)%TIMDEP=.TRUE. !DRN
TOPICS(23)%TIMDEP=.TRUE. !RIV
TOPICS(24)%TIMDEP=.TRUE. !EVT
TOPICS(25)%TIMDEP=.TRUE. !GHB
TOPICS(26)%TIMDEP=.TRUE. !RCH
TOPICS(27)%TIMDEP=.TRUE. !OLF
TOPICS(28)%TIMDEP=.TRUE. !CHD
TOPICS(29)%TIMDEP=.TRUE. !ISG
TOPICS(30)%TIMDEP=.TRUE. !SFR
TOPICS(31)%TIMDEP=.TRUE. !FHB
TOPICS(32)%TIMDEP=.TRUE. !LAK
TOPICS(33)%TIMDEP=.FALSE. !PCG
TOPICS(1)%SNAME(1) ='(BND) Boundary (IDF)'
TOPICS(1)%SNAME(2) ='(LUS) Landuse (IDF)'
TOPICS(1)%SNAME(3) ='(RTZ) Rootzone (IDF)'
TOPICS(1)%SNAME(4) ='(SLT) Soiltype (IDF)'
TOPICS(1)%SNAME(5) ='(MST) Meteostation (IDF)'
TOPICS(1)%SNAME(6) ='(SFL) Surfacelevel (IDF)'
TOPICS(1)%SNAME(7) ='(ARQ) Artificial discharge (IDF)'
TOPICS(1)%SNAME(8) ='(ARL) Artificial layer (IDF)'
TOPICS(1)%SNAME(9) ='(ARL) Artificial location (IPF)'
TOPICS(1)%SNAME(10) ='(WRA) Wetted Rural Area (IDF)'
TOPICS(1)%SNAME(11) ='(WUA) Wetted Urban Area (IDF)'
TOPICS(1)%SNAME(12) ='(PUA) Pondingdepth Urban Area (IDF)'
TOPICS(1)%SNAME(13) ='(PRA) Pondingdepth Rural Area (IDF)'
TOPICS(1)%SNAME(14) ='(RUA) Runoff Resistance Urban Area (IDF)'
TOPICS(1)%SNAME(15) ='(RRA) Runoff Resistance Rural Area (IDF)'
TOPICS(1)%SNAME(16) ='(RUA) Runon Resistance Urban Area (IDF)'
TOPICS(1)%SNAME(17) ='(RRA) Runon Resistance Rural Area (IDF)'
TOPICS(1)%SNAME(18) ='(IUA) Infiltration Capacity Urban Area (IDF)'
TOPICS(1)%SNAME(19) ='(IRA) Infiltration Capacity Rural Area (IDF)'
TOPICS(1)%SNAME(20) ='(PWD) Purgewater Depth (IDF)'
TOPICS(1)%SNAME(21) ='(SMF) Soil Moisture Factor (IDF)'
TOPICS(1)%SNAME(22) ='(SPF) Soil Permeability Factor (IDF)'
TOPICS(2)%SNAME(1) ='(TOP) Top of Modellayer (IDF)'
TOPICS(3)%SNAME(1) ='(BOT) Bottom of Modellayer (IDF)'
TOPICS(4)%SNAME(1) ='(BND) Boundary Settings (IDF)'
TOPICS(5)%SNAME(1) ='(SHD) Starting Heads (IDF)'
TOPICS(6)%SNAME(1) ='(KDW) COnductance (IDF)'
TOPICS(7)%SNAME(1) ='(KHV) Horizontal Permeability (IDF)'
TOPICS(8)%SNAME(1) ='(KVA) Vertical Anisotropy (IDF)'
TOPICS(9)%SNAME(1) ='(VCW) Vertical Resistance (IDF)'
TOPICS(10)%SNAME(1) ='(KVV) Vertical Permeability (IDF)'
TOPICS(11)%SNAME(1) ='(STO) Storage Coefficient (IDF)'
TOPICS(12)%SNAME(1) ='(SSY) Specific Yield / Confined Storage Coef. (IDF)'
TOPICS(13)%SNAME(1) ='(LAY) Layer Identification (IDF)'
TOPICS(13)%SNAME(2) ='(STO) Phreatic Storage Coefficient (IDF)'
TOPICS(13)%SNAME(3) ='(TA1) Top of Aquifer above PWT-layer (IDF)'
TOPICS(13)%SNAME(4) ='(TAQ) Top of Aquitard PWT-layer (IDF)'
TOPICS(13)%SNAME(5) ='(TA2) Top of Aquifer beneath PWT-layer (IDF)'
TOPICS(13)%SNAME(6) ='(VCP) Vertical Resistance of PWT-clay (IDF)'
TOPICS(14)%SNAME(1) ='(FCT) Factor (IDF)'
TOPICS(14)%SNAME(2) ='(ANG) Angle (IDF)'
TOPICS(15)%SNAME(1) ='(HFB) Horizontal Barrier Flow (GEN)'
TOPICS(16)%SNAME(1) ='(PCH) Preconsolidation Head (IDF)'
TOPICS(16)%SNAME(2) ='(ESC) Elastic Storage Coefficient (IDF)'
TOPICS(16)%SNAME(3) ='(ISC) Inelastic Storage Coefficient (IDF)'
TOPICS(16)%SNAME(4) ='(SCP) Starting Compaction (IDF)'
TOPICS(17)%SNAME(1) ='(SFT) Stream Flow Thickness (IDF)'
TOPICS(17)%SNAME(2) ='(PER) Permeability (IDF)'
TOPICS(18)%SNAME(1) ='(AEA) Areal Extent of Active Model (IDF)'
! TOPICS(18)%SNAME(2) ='Overland Flow to SFR (>0) / LAK (<0) (IDF)'
! TOPICS(18)%SNAME(2) ='Saturated Vertical Conductivity (IDF)'
TOPICS(18)%SNAME(2) ='(BCE) Brooks-Corey Epsilon (IDF)'
TOPICS(18)%SNAME(3) ='(SWC) Saturated Water Content of Unsat. Zone (IDF)'
! TOPICS(18)%SNAME(4) ='(RWC) Residual Water Content of Unsat. Zone (IDF)'
TOPICS(18)%SNAME(4) ='(IWC) Initial Water Content (IDF)'
TOPICS(18)%SNAME(5) ='(INF) Infiltration Rates at Land Surface (IDF)'
TOPICS(18)%SNAME(6) ='(EVA) Evaporation Demands (IDF)'
TOPICS(18)%SNAME(7) ='(EXD) Extinction Depth (IDF)'
TOPICS(18)%SNAME(8) ='(EWC) Extinction Water Content (IDF)'
TOPICS(19)%SNAME(1) ='(WRL) Well Rate and Well Loss (IPF)'
TOPICS(20)%SNAME(1) ='(PAR) Parameters Estimation (-)'
TOPICS(21)%SNAME(1) ='(WRA) Well Rate (IPF)'
TOPICS(22)%SNAME(1) ='(CON) Conductance (IDF)'
TOPICS(22)%SNAME(2) ='(DEL) Drainage Level (IDF)'
TOPICS(23)%SNAME(1) ='(CON) Conductance (IDF)'
TOPICS(23)%SNAME(2) ='(RST) River Stage (IDF)'
TOPICS(23)%SNAME(3) ='(RBT) River Bottom (IDF)'
TOPICS(23)%SNAME(4) ='(RIF) Infiltration Factor (IDF)'
TOPICS(24)%SNAME(1) ='(EVA) Evapotranspiration Rate (IDF)'
TOPICS(24)%SNAME(2) ='(SUR) Surface Level (IDF)'
TOPICS(24)%SNAME(3) ='(EXD) Extinction Depth (IDF)'
TOPICS(25)%SNAME(1) ='(CON) Conductance (IDF)'
TOPICS(25)%SNAME(2) ='(LVL) Reference Level (IDF)'
TOPICS(26)%SNAME(1) ='(RCH) Recharge Rate (IDF)'
TOPICS(27)%SNAME(1) ='(LVL) Overland Flow Level (IDF)'
TOPICS(28)%SNAME(1) ='(CHD) Constant Head (IDF)'
TOPICS(29)%SNAME(1) ='(ISG) Segment River (ISG)'
TOPICS(30)%SNAME(1) ='(ISG) Stream Flow River (ISG)'
TOPICS(31)%SNAME(1) ='(FHB) Specified Flow (IDF)'
TOPICS(31)%SNAME(2) ='(FHB) Specified Head (IDF)'
TOPICS(32)%SNAME(1) ='(LID) Lake Identifications (IDF)'
TOPICS(32)%SNAME(2) ='(LBA) Lake Bathymetry (IDF)'
TOPICS(32)%SNAME(3) ='(INI) Initial Lake Levels (IDF)'
TOPICS(32)%SNAME(4) ='(MIN) Minimal Lake Levels (IDF)'
TOPICS(32)%SNAME(5) ='(MAX) Maximal Lake Levels (IDF)'
TOPICS(32)%SNAME(6) ='(LRE) Lakebed Resistance (IDF)'
TOPICS(32)%SNAME(7) ='(LPR) Precipitation at surface Lake (IDF)'
TOPICS(32)%SNAME(8) ='(LEV) Evaporation at surface Lake (IDF)'
TOPICS(32)%SNAME(9) ='(LOR) Overland runoff (IDF)'
TOPICS(32)%SNAME(10)='(LWD) Lake Withdrawall (IDF)'
TOPICS(33)%SNAME(1) ='(PCG) Parameters PCG method (-)'
CALL WDIALOGLOAD(ID_DPMANAGER)
CALL WDIALOGPUTIMAGE(ID_OPEN,ID_ICONOPEN,1)
CALL WDIALOGPUTIMAGE(ID_SAVE,ID_ICONSAVEAS,1)
CALL WDIALOGPUTIMAGE(ID_PROPERTIES,ID_ICONPROPERTIES,1)
CALL WDIALOGPUTIMAGE(ID_PROPERTIES_AUTO,ID_ICONPROPERTIES_AUTO,1)
CALL WDIALOGPUTIMAGE(ID_DRAW,ID_ICONDRAW,1)
CALL WDIALOGPUTIMAGE(ID_DRAW2,ID_ICONDRAWPLUS,1)
CALL WDIALOGPUTIMAGE(ID_OPENRUN,ID_ICONOPENRUN,1)
CALL WDIALOGPUTIMAGE(ID_SAVERUN,ID_ICONSAVERUN,1)
CALL WDIALOGPUTIMAGE(ID_CLEAN,ID_ICONNEW,1)
CALL WDIALOGPUTIMAGE(ID_DELETE,ID_ICONDELETE,1)
ALLOCATE(PERIOD(MAXPERIODS)); NPERIOD=0
DO I=1,SIZE(TOPICS)
NULLIFY(TOPICS(I)%STRESS)
NULLIFY(TOPICS(I)%STRESS_TMP)
ENDDO
END SUBROUTINE PMANAGERINIT
!###======================================================================
SUBROUTINE PMANAGER_ALLOCATE()
!###======================================================================
IMPLICIT NONE
INTEGER :: I,N,M
DO I=1,SIZE(TOPICS)
IF(ASSOCIATED(TOPICS(I)%STRESS))THEN
N=SIZE(TOPICS(I)%STRESS)
M=TOPICS(I)%NSUBTOPICS
IF(ASSOCIATED(TOPICS(I)%IDT))DEALLOCATE(TOPICS(I)%IDT)
IF(ASSOCIATED(TOPICS(I)%ISD))DEALLOCATE(TOPICS(I)%ISD)
ALLOCATE(TOPICS(I)%IDT(N))
ALLOCATE(TOPICS(I)%ISD(N,M))
TOPICS(I)%IDT=0; TOPICS(I)%ISD=0
ENDIF
ENDDO
END SUBROUTINE PMANAGER_ALLOCATE
!###======================================================================
SUBROUTINE PMANAGER_DEALLOCATE(I)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: I
INTEGER :: J
IF(ASSOCIATED(TOPICS(I)%STRESS))THEN
DO J=1,SIZE(TOPICS(I)%STRESS)
IF(ASSOCIATED(TOPICS(I)%STRESS(J)%FILES))DEALLOCATE(TOPICS(I)%STRESS(J)%FILES)
IF(ASSOCIATED(TOPICS(I)%STRESS(J)%INPFILES))DEALLOCATE(TOPICS(I)%STRESS(J)%INPFILES)
ENDDO
DEALLOCATE(TOPICS(I)%STRESS)
ENDIF
IF(ASSOCIATED(TOPICS(I)%IDT))DEALLOCATE(TOPICS(I)%IDT)
IF(ASSOCIATED(TOPICS(I)%ISD))DEALLOCATE(TOPICS(I)%ISD)
NULLIFY(TOPICS(I)%STRESS); NULLIFY(TOPICS(I)%IDT); NULLIFY(TOPICS(I)%ISD)
TOPICS(I)%IACT_MODEL=0
END SUBROUTINE PMANAGER_DEALLOCATE
!#####=================================================================
SUBROUTINE PMANAGERCLOSE()
!#####=================================================================
IMPLICIT NONE
CALL WINDOWSELECT(0); CALL WMENUSETSTATE(ID_PMANAGER,2,0)
CALL WDIALOGSELECT(ID_DPMANAGER); CALL WDIALOGHIDE()
IF(ALLOCATED(LAYCON))DEALLOCATE(LAYCON)
END SUBROUTINE PMANAGERCLOSE
!#####=================================================================
SUBROUTINE PMANAGER_DEALLOCATE_PEST()
!#####=================================================================
IMPLICIT NONE
IF(ASSOCIATED(PEST%PARAM)) DEALLOCATE(PEST%PARAM)
IF(ASSOCIATED(PEST%S_PERIOD)) DEALLOCATE(PEST%S_PERIOD)
IF(ASSOCIATED(PEST%E_PERIOD)) DEALLOCATE(PEST%E_PERIOD)
IF(ASSOCIATED(PEST%B_FRACTION)) DEALLOCATE(PEST%B_FRACTION)
IF(ASSOCIATED(PEST%B_BATCHFILE))DEALLOCATE(PEST%B_BATCHFILE)
IF(ASSOCIATED(PEST%B_OUTFILE)) DEALLOCATE(PEST%B_OUTFILE)
END SUBROUTINE PMANAGER_DEALLOCATE_PEST
!#####=================================================================
INTEGER FUNCTION PMANAGER_FIND_KEYWORD(KEYLINE)
!#####=================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: KEYLINE
INTEGER :: I,J
CHARACTER(LEN=3) :: CKEY
PMANAGER_FIND_KEYWORD=0
I=INDEX(KEYLINE,'('); J=INDEX(KEYLINE,')')
IF(I.EQ.0.OR.J.EQ.0)RETURN; IF(J-I.NE.4)RETURN
CKEY=KEYLINE(I+1:J-1); CKEY=UTL_CAP(CKEY,'U')
DO I=1,SIZE(CMOD)
IF(CKEY.EQ.CMOD(I))THEN; PMANAGER_FIND_KEYWORD=I; RETURN; ENDIF
END DO
END FUNCTION PMANAGER_FIND_KEYWORD
END MODULE