!! Copyright (C) Stichting Deltares, 2005-2014.
!!
!! 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 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
USE MOD_IDF, ONLY : IDFREAD,IDFDEALLOCATE,IDFNULLIFY,IDFREADSCALE,IDFCOPY,IDFDEALLOCATEX,IDFIROWICOL,IDFALLOCATEX,IDFGETAREA
USE MOD_IDF_PAR, ONLY : IDFOBJ
USE MOD_OSD, ONLY : OSD_OPEN
USE IMODVAR, ONLY : RVERSION
USE MOD_PMANAGER_PAR
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
USE MOD_ISG_UTL, ONLY : ISGDEAL,UTL_GETUNITSISG,ISGREAD
USE MOD_POLINT, ONLY : POL1LOCATE
USE MOD_QKSORT
USE MOD_ASC2IDF, ONLY : ASC2IDF_INT_GETFACES
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
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 PMANAGERUPDATE(0,0,0)
ENDIF
CASE (ID_DRAW)
CALL PMANAGERDRAW()
CASE (ID_DRAW2)
CALL PMANAGERDRAW_PLUS()
CASE (ID_PROPERTIES)
CALL PMANAGEROPEN()
CASE (ID_OPENRUN,ID_SAVERUN)
IF(PMANAGERRUN(MESSAGE%VALUE1,''))THEN; ENDIF
CASE (ID_OPEN,ID_SAVE)
IF(PMANAGERPRJ(MESSAGE%VALUE1,''))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,II,J,K,N,ITYPE,ID,IPER,ITOPIC,IST,IYR,IMH,IDY,ISUBTOPIC,ISYS,IOPTION,IHR,IMT,ISC,ICF
TYPE(WIN_MESSAGE) :: MESSAGE
CHARACTER(LEN=256) :: CNAME
CHARACTER(LEN=3) :: EXT
LOGICAL :: LEX,LNEW
CHARACTER(LEN=MAXLEN) :: CD
INTEGER,ALLOCATABLE,DIMENSION(:) :: ILAY,ISORT
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
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 WDIALOGPUTSTRING(IDOK,'Add New System')
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 WDIALOGPUTSTRING(IDOK,'Adjust Parameters for System')
LNEW=.FALSE.
ENDIF
IOPTION=1
!## can not 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
SELECT CASE (ITOPIC)
CASE (21)
EXT='IPF'; ICF=0
CASE (29)
EXT='ISG'; ICF=0
CASE (15)
EXT='GEN'; ICF=0
CASE DEFAULT
EXT='IDF'; ICF=1
END SELECT
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(TOPICS(ITOPIC)%NSUBTOPICS.EQ.1)CALL WDIALOGFIELDSTATE(IDF_MENU1,2)
DEALLOCATE(MENUNAMES)
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)
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(TOPICS(ITOPIC)%TIMDEP)THEN
CALL WDIALOGRANGEINTEGER(IDF_INTEGER1,-1,9999)
ELSE
CALL WDIALOGRANGEINTEGER(IDF_INTEGER1, 1,9999)
ENDIF
CALL WDIALOGFIELDSTATE(IDF_RADIO1,ICF)
IF(ICF.EQ.0)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO2)
CALL PMANAGERPUTFIELDS(IST)
CALL PMANAGEROPENFIELDS(TOPICS(ITOPIC)%TIMDEP,LNEW)
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)
CALL PMANAGEROPENFIELDS(TOPICS(ITOPIC)%TIMDEP,LNEW)
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)
CALL PMANAGEROPENFIELDS(TOPICS(ITOPIC)%TIMDEP,LNEW)
END SELECT
CASE(PUSHBUTTON)
SELECT CASE (MESSAGE%VALUE1)
CASE (ID_ADDFILES)
CALL UTL_LISTOFFILES(TOPICS(1)%STRESS(1)%INPFILES,(/'*.*','','','','','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)
LEX=.TRUE.
IF(TOPICS(ITOPIC)%TIMDEP)THEN
CALL WDIALOGGETRADIOBUTTON(IDF_RADIO3,I)
CD=''
IF(I.EQ.1)THEN !## steady-state
CD='STEADY-STATE'; IYR=0; IMH=0; IDY=0; IHR=0; IMT=0; ISC=0
ELSEIF(I.EQ.2)THEN !## date
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
ELSEIF(I.EQ.3)THEN !## period
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)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
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
!## 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
CALL PMANAGERUPDATE(ITOPIC,IPER,ISYS)
ENDIF
DEALLOCATE(PRJ)
END SUBROUTINE PMANAGEROPEN
!###======================================================================
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)
CASE (IDF_MENU2)
CALL UTL_FILLDATES(IDF_INTEGER5,IDF_MENU2,IDF_INTEGER2)
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(1)=4; PERIOD(IOPTION)%IDY(1)=1; PERIOD(IOPTION)%IYR(1)=2014
PERIOD(IOPTION)%IMH(2)=9; PERIOD(IOPTION)%IDY(2)=31; PERIOD(IOPTION)%IYR(2)=2014
PERIOD(IOPTION)%IHR(1)=0; PERIOD(IOPTION)%IMT(1)=0; PERIOD(IOPTION)%ISC(1)=0
PERIOD(IOPTION)%IHR(2)=0; PERIOD(IOPTION)%IMT(2)=0; PERIOD(IOPTION)%ISC(2)=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(1))
CALL WDIALOGPUTINTEGER(IDF_INTEGER1 ,PERIOD(IOPTION)%IDY(1))
CALL WDIALOGPUTINTEGER(IDF_INTEGER3 ,PERIOD(IOPTION)%IYR(1))
CALL WDIALOGPUTINTEGER(IDF_INTEGER6 ,PERIOD(IOPTION)%IHR(1))
CALL WDIALOGPUTINTEGER(IDF_INTEGER7 ,PERIOD(IOPTION)%IMT(1))
CALL WDIALOGPUTINTEGER(IDF_INTEGER8 ,PERIOD(IOPTION)%ISC(1))
CALL WDIALOGPUTMENU(IDF_MENU2,CDATE,12,PERIOD(IOPTION)%IMH(2))
CALL WDIALOGPUTINTEGER(IDF_INTEGER2 ,PERIOD(IOPTION)%IDY(2))
CALL WDIALOGPUTINTEGER(IDF_INTEGER5 ,PERIOD(IOPTION)%IYR(2))
CALL WDIALOGPUTINTEGER(IDF_INTEGER9 ,PERIOD(IOPTION)%IHR(2))
CALL WDIALOGPUTINTEGER(IDF_INTEGER10 ,PERIOD(IOPTION)%IMT(2))
CALL WDIALOGPUTINTEGER(IDF_INTEGER11 ,PERIOD(IOPTION)%ISC(2))
CALL UTL_FILLDATES(IDF_INTEGER3,IDF_MENU1,IDF_INTEGER1)
CALL UTL_FILLDATES(IDF_INTEGER5,IDF_MENU2,IDF_INTEGER2)
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(1))
CALL WDIALOGGETINTEGER(IDF_INTEGER1 ,PERIOD(IOPTION)%IDY(1))
CALL WDIALOGGETINTEGER(IDF_INTEGER3 ,PERIOD(IOPTION)%IYR(1))
CALL WDIALOGGETINTEGER(IDF_INTEGER6 ,PERIOD(IOPTION)%IHR(1))
CALL WDIALOGGETINTEGER(IDF_INTEGER7 ,PERIOD(IOPTION)%IMT(1))
CALL WDIALOGGETINTEGER(IDF_INTEGER8 ,PERIOD(IOPTION)%ISC(1))
CALL WDIALOGGETMENU(IDF_MENU2 ,PERIOD(IOPTION)%IMH(2))
CALL WDIALOGGETINTEGER(IDF_INTEGER2 ,PERIOD(IOPTION)%IDY(2))
CALL WDIALOGGETINTEGER(IDF_INTEGER5 ,PERIOD(IOPTION)%IYR(2))
CALL WDIALOGGETINTEGER(IDF_INTEGER9 ,PERIOD(IOPTION)%IHR(1))
CALL WDIALOGGETINTEGER(IDF_INTEGER10,PERIOD(IOPTION)%IMT(1))
CALL WDIALOGGETINTEGER(IDF_INTEGER11,PERIOD(IOPTION)%ISC(1))
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,INFORMATIONICON,COMMONOK,'You should select a MAIN TOPIC, a DATE or an individual FILENAME.','Information')
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,INFORMATIONICON,COMMONOK,'You should select a MAIN TOPIC at least','Information')
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(OUT) :: 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)
IPER=1
ENDIF
END SUBROUTINE PMANAGER_STRESSES
!###======================================================================
SUBROUTINE PMANAGER_SYSTEMS(ITOPIC,IPER,ISYS)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ITOPIC,IPER
INTEGER,INTENT(OUT) :: 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)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(OUT) :: IST
CALL WDIALOGGETMENU(IDF_MENU1,IST)
CALL WDIALOGPUTREAL(IDF_REAL1,PRJ(IST)%FCT,'(F10.2)')
CALL WDIALOGPUTREAL(IDF_REAL2,PRJ(IST)%IMP,'(F10.2)')
CALL WDIALOGPUTREAL(IDF_REAL3,PRJ(IST)%CNST,'(F10.2)')
IF(PRJ(IST)%ICNST.EQ.1)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO1)
IF(PRJ(IST)%ICNST.EQ.2)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO2)
CALL WDIALOGPUTSTRING(IDF_STRING1,TRIM(PRJ(IST)%FNAME))
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 WDIALOGGETRADIOBUTTON(IDF_RADIO1,PRJ(IST)%ICNST)
CALL WDIALOGGETREAL(IDF_REAL3,PRJ(IST)%CNST)
CALL WDIALOGGETSTRING(IDF_STRING1,PRJ(IST)%FNAME)
END SUBROUTINE PMANAGERGETFIELDS
!###======================================================================
SUBROUTINE PMANAGEROPENFIELDS(LEX,LNEW)
!###======================================================================
IMPLICIT NONE
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)
CALL WDIALOGFIELDSTATE(IDF_REAL3,ABS(I-2))
CALL WDIALOGFIELDSTATE(IDF_STRING1,ABS(I-1))
CALL WDIALOGFIELDSTATE(ID_OPEN,ABS(I-1))
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,ALLOCATABLE,DIMENSION(:) :: ILIST
CHARACTER(LEN=256),ALLOCATABLE,DIMENSION(:) :: FNAMES
INTEGER :: I,J,K,JJ,KK,ISYS,IL1,IL2,IPLOT,NFILES
CALL PMANAGER_GETNLAY()
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 - 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
END SELECT
KK=0
DO I=IL1,IL2
DO J=1,SIZE(ILIST)
JJ=ILIST(J)
IF(TOPICS(JJ)%TIMDEP)CYCLE
IF(.NOT.ASSOCIATED(TOPICS(JJ)%STRESS))CYCLE
IF(.NOT.ASSOCIATED(TOPICS(JJ)%STRESS(1)%FILES))CYCLE
!## number of subtopics
KLOOP: DO K=1,SIZE(TOPICS(JJ)%STRESS(1)%FILES,1)
!## number of systems
DO ISYS=1,SIZE(TOPICS(JJ)%STRESS(1)%FILES,2)
IF(TOPICS(JJ)%STRESS(1)%FILES(K,ISYS)%ICNST.EQ.2)THEN
IF(TOPICS(JJ)%STRESS(1)%FILES(K,ISYS)%ILAY.EQ.I)THEN
KK=KK+1
FNAMES(KK)=TOPICS(JJ)%STRESS(1)%FILES(K,ISYS)%FNAME
EXIT KLOOP
ENDIF
ENDIF
ENDDO
ENDDO KLOOP
ENDDO
ENDDO
!## actual found files
NFILES=KK
IF(NFILES.EQ.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'No files found.','Warning')
RETURN
ELSE
!## 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),'U')))MP(IPLOT)%ISEL=.TRUE.
ENDDO
END DO
!## delete them all from manager
DO I=1,NFILES; CALL MANAGERDELETE(IQ=0); ENDDO
DO I=1,NFILES
CALL IDFINIT(FNAMES(I),LPLOT=.FALSE.,LDEACTIVATE=.FALSE.)
ENDDO
ENDIF
DEALLOCATE(FNAMES,ILIST)
END SUBROUTINE PMANAGERDRAW_PLUS
!###======================================================================
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)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ID
CHARACTER(LEN=*),INTENT(IN) :: RUNFNAME
CHARACTER(LEN=256) :: FNAME
PMANAGERPRJ=.FALSE.
IF(ID.EQ.ID_OPEN)THEN
IF(RUNFNAME.EQ.'')THEN
FNAME=TRIM(PREFVAL(1))//'\RUNFILES\*.prj'
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
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMOD can not read in the Project File','Error')
ELSE
CALL PMANAGERUPDATE(0,0,0); PMANAGERPRJ=.TRUE.
ENDIF
ELSEIF(ID.EQ.ID_SAVE)THEN
IF(RUNFNAME.EQ.'')THEN
FNAME=TRIM(PREFVAL(1))//'\RUNFILES\*.prj'
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
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Successfully written project file:'//CHAR(13)//TRIM(FNAME),'Information')
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
WRITE(IU,'(I4.4,3A,I1)') SIZE(TOPICS(I)%STRESS),',',TRIM(TOPICS(I)%TNAME),',',TOPICS(I)%IACT_MODEL
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.4,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(1),'-',PERIOD(I)%IMH(1),'-',PERIOD(I)%IYR(1),' ', &
PERIOD(I)%IHR(1),':',PERIOD(I)%IMT(1),':',PERIOD(I)%ISC(1)
WRITE(IU,'(2(I2.2,A1),I4.4,3(A1,I2.2))') PERIOD(I)%IDY(2),'-',PERIOD(I)%IMH(2),'-',PERIOD(I)%IYR(2),' ', &
PERIOD(I)%IHR(2),':',PERIOD(I)%IMT(2),':',PERIOD(I)%ISC(2)
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
CHARACTER(LEN=512) :: LINE
PMANAGER_LOADPRJ=.FALSE.
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=FNAME,STATUS='OLD',ACTION='READ,DENYWRITE',FORM='FORMATTED')
!## read modules
DO
READ(IU,'(A512)',IOSTAT=IOS) LINE; IF(IOS.NE.0)EXIT
READ(LINE,*,IOSTAT=IOS) NPER,CTOPIC,IACT
IF(IOS.NE.0)THEN; IACT=1; READ(LINE,*,IOSTAT=IOS) NPER,CTOPIC; IF(IOS.NE.0)EXIT; ENDIF
IF(NPER.LE.0)CYCLE
I=PMANAGER_FIND_KEYWORD(CTOPIC); IF(I.LE.0)CYCLE
ALLOCATE(TOPICS(I)%STRESS(NPER)); TOPICS(I)%IACT_MODEL=IACT
DO L=1,NPER
IF(TOPICS(I)%TIMDEP)THEN
READ(IU,'(A)') 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
TOPICS(I)%STRESS(L)%CDATE=LINE
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 J=1,NSYS
DO K=1,TOPICS(I)%NSUBTOPICS
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')
ENDIF
ENDIF
ENDIF
IF(IOS.NE.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Incorrect number of input field for'//CHAR(13)//TRIM(TOPICS(I)%TNAME),'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
READ(IU,'(A512)',IOSTAT=IOS) LINE; 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(1),PERIOD(I)%IMH(1),PERIOD(I)%IYR(1), &
PERIOD(I)%IHR(1),PERIOD(I)%IMT(1),PERIOD(I)%ISC(1)
IF(IOS.NE.0)THEN; I=I-1; EXIT; ENDIF
READ(IU,'(2(I2.2,1X),I4.4,3(1X,I2.2))',IOSTAT=IOS) PERIOD(I)%IDY(2),PERIOD(I)%IMH(2),PERIOD(I)%IYR(2), &
PERIOD(I)%IHR(2),PERIOD(I)%IMT(2),PERIOD(I)%ISC(2)
IF(IOS.NE.0)THEN; I=I-1; EXIT; ENDIF
ENDDO; NPERIOD=I
CLOSE(IU)
PMANAGER_LOADPRJ=.TRUE.
END FUNCTION PMANAGER_LOADPRJ
!###======================================================================
LOGICAL FUNCTION PMANAGERRUN(ID,RUNFNAME)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ID
CHARACTER(LEN=*),INTENT(IN) :: RUNFNAME
INTEGER :: IU,ITOPIC
CHARACTER(LEN=256) :: FNAME
PMANAGERRUN=.FALSE.
IF(ID.EQ.ID_OPENRUN)THEN
IF(RUNFNAME.EQ.'')THEN
FNAME=TRIM(PREFVAL(1))//'\RUNFILES\*.run'
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')
CALL UTL_MESSAGEHANDLE(0)
IF(PMANAGER_GETKEYS(IU)) THEN
IF(PMANAGER_GETFILES(IU,ITOPIC))THEN
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)
CALL UTL_MESSAGEHANDLE(1)
ELSEIF(ID.EQ.ID_SAVERUN)THEN
IF(.NOT.PMANAGER_INITSIM(FNAME))THEN; IF(ASSOCIATED(SIM))DEALLOCATE(SIM); RETURN; ENDIF
CALL UTL_MESSAGEHANDLE(0)
IF(IFORMAT.EQ.1)THEN
IF(PMANAGER_SAVERUN(FNAME))THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Successfully written runfile:'//CHAR(13)//TRIM(FNAME),'Error')
PMANAGERRUN=.TRUE.
ENDIF
ELSEIF(IFORMAT.EQ.2)THEN
IF(PMANAGER_SAVEMF2005(FNAME))THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Successfully written MF2005 files:'//CHAR(13)//TRIM(FNAME),'Error')
PMANAGERRUN=.TRUE.
ENDIF
ENDIF
CALL UTL_CLOSEUNITS()
DEALLOCATE(SIM)
CALL UTL_MESSAGEHANDLE(1)
ENDIF
END FUNCTION PMANAGERRUN
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVERUN(FNAME)
!###======================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: FNAME
CHARACTER(LEN=512) :: LINE
CHARACTER(LEN=52) :: CDATE1,CDATE2
INTEGER :: IU,I,J,K,IPER,KPER,N
TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: IDF
PMANAGER_SAVERUN=.FALSE.
!## remove last timestep sinces it is the final date
IF(NPER.GT.1)NPER=NPER-1
MXNLAY=NLAY
IU=UTL_GETUNIT()
CALL OSD_OPEN(IU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE,DENYREAD',FORM='FORMATTED')
IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') TRIM(PREFVAL(1))//'\MODELS\'//TRIM(MODELNAME)
WRITE(IU,'(10(I10,A1))') NLAY,',',MXNLAY,',',NPER,',',0,',',1,',',0,',',0,',',0,',',IUNCONF,',0'
WRITE(IU,'(6(I10,A1))') 1,',',0,',',0,',',0,',',0,',',0
LINE=TRIM(ITOS(MXITER))//','//TRIM(ITOS(ITER1))//','// &
TRIM(RTOS(HCLOSE,'E',7))//','//TRIM(RTOS(RCLOSE,'E',7))//','// &
TRIM(RTOS(RELAX,'E',7))//','//TRIM(ITOS(NPCOND))
WRITE(IU,'(A)') TRIM(LINE)
IF(ISUBMODEL.EQ.0)THEN
ALLOCATE(IDF(1)); CALL IDFNULLIFY(IDF(1))
IF(.NOT.IDFREAD(IDF(1),TOPICS(4)%STRESS(1)%FILES(1,1)%FNAME,0))THEN
CALL IDFDEALLOCATE(IDF,SIZE(IDF)); DEALLOCATE(IDF); CLOSE(IU); RETURN
ENDIF
WRITE(IU,'(6(F10.2,A1))') IDF(1)%XMIN,',',IDF(1)%YMIN,',',IDF(1)%XMAX,',',IDF(1)%YMAX,',',IDF(1)%DX,',',0.0
CALL IDFDEALLOCATE(IDF,SIZE(IDF)); DEALLOCATE(IDF)
ELSE
WRITE(IU,'(6(F10.2,A1))') SUBMODEL(1),',',SUBMODEL(2),',',SUBMODEL(3),',',SUBMODEL(4),',',SUBMODEL(5),',',0.0
ENDIF
WRITE(IU,'(A)') 'ACTIVE MODULES'
DO I=1,MAXTOPICS
IF(TOPICS(I)%IACT_MODEL.EQ.0)CYCLE
IF(.NOT.ASSOCIATED(TOPICS(I)%STRESS))CYCLE
IF(.NOT.ASSOCIATED(TOPICS(I)%STRESS(1)%FILES))CYCLE
WRITE(IU,'(A)') '1,1,0 '//TRIM(TOPICS(I)%TNAME)
ENDDO
!## write bndfile
WRITE(IU,'(A)')TRIM(TOPICS(4)%STRESS(1)%FILES(1,1)%FNAME)
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
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
IF(TOPICS(I)%STRESS(1)%FILES(K,J)%ICNST.EQ.1)THEN
WRITE(IU,'(1X,I4.4,3(A1,G15.7))') &
TOPICS(I)%STRESS(1)%FILES(K,J)%ILAY,',', &
TOPICS(I)%STRESS(1)%FILES(K,J)%FCT ,',', &
TOPICS(I)%STRESS(1)%FILES(K,J)%IMP ,',', &
TOPICS(I)%STRESS(1)%FILES(K,J)%CNST
ELSEIF(TOPICS(I)%STRESS(1)%FILES(K,J)%ICNST.EQ.2)THEN
WRITE(IU,'(1X,I4.4,2(A1,G15.7),A1,A)') &
TOPICS(I)%STRESS(1)%FILES(K,J)%ILAY,',', &
TOPICS(I)%STRESS(1)%FILES(K,J)%FCT ,',', &
TOPICS(I)%STRESS(1)%FILES(K,J)%IMP ,',', &
CHAR(39)//TRIM(TOPICS(I)%STRESS(1)%FILES(K,J)%FNAME)//CHAR(39)
ENDIF
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 '
!## 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
WRITE(CDATE1,'(I4.4,5I2.2)') SIM(KPER)%IYR ,SIM(KPER)%IMH ,SIM(KPER)%IDY ,SIM(KPER)%IHR ,SIM(KPER)%IMT ,SIM(KPER)%ISC
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
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)
!## reuse previous timestep
IF(IPER.LE.0)THEN
WRITE(IU,'(I3,A)') IPER,','//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,I4.4,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,I4.4,2(A1,G15.7),A1,A)') &
TOPICS(I)%STRESS(IPER)%FILES(K,J)%ILAY,',', &
TOPICS(I)%STRESS(IPER)%FILES(K,J)%FCT ,',', &
TOPICS(I)%STRESS(IPER)%FILES(K,J)%IMP ,',', &
CHAR(39)//TRIM(TOPICS(I)%STRESS(IPER)%FILES(K,J)%FNAME)//CHAR(39)
ENDIF
ENDDO
ENDDO
ENDIF
ENDIF
ENDDO
ENDDO
CLOSE(IU)
PMANAGER_SAVERUN=.TRUE.
END FUNCTION PMANAGER_SAVERUN
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005(FNAME)
!###======================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: FNAME
CHARACTER(LEN=512) :: DIR,LINE
INTEGER :: IU,IUBAS,IPER,KPER,IERROR,SCL_D,SCL_U,IINT,ITOPIC,ILAY,ISS,IINV,NRCHOP,NEVTOP,NP
INTEGER :: IHEDUN,IBCFCB,IRCHCB,IEVTCB,IDRNCB,IRIVCB,IGHBCB,ICHDCB,IWELCB,ICB,IROW,ICOL,ISTEADY
REAL :: HNOFLOW,STOPER
TYPE(IDFOBJ) :: IDF
TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: BND,TOP,BOT,KD,SHD
CHARACTER(LEN=52) :: TEXT,CAUX,CMAXNO,CPCK
CHARACTER(LEN=256) :: EXFNAME
LOGICAL :: LEX,LTB
PMANAGER_SAVEMF2005=.FALSE.
!## remove final stress as it is the final timestep
IF(NPER.GT.1)NPER=NPER-1
IIDEBUG=0 !## if 1 write asc files instead of arr
STOPER=0.1 !## stop error of total waterbalance
HNOFLOW=HUGE(1.0) !## noflow value
ISTEADY=0; IF(SIM(1)%DELT.EQ.0.0)ISTEADY=1
IHEDUN=51; IBCFCB=52; IRCHCB=53; IEVTCB=54; IDRNCB=55; IRIVCB=56; IGHBCB=57; ICHDCB=58; IWELCB=59
NRCHOP=1 !## applied to top of gridcells
NEVTOP=1 !## applied to top of gridcells
LPCG =.TRUE.
LPCGN=.FALSE. !## option?
LPWT =.FALSE.
!## msp
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.
!## 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.
DIR=FNAME(:INDEX(FNAME,'.',.TRUE.)-1)
MXNLAY=NLAY
!## write *.nam file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIR)//'.NAM',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
LINE=FNAME(INDEX(FNAME,'\',.TRUE.)+1:INDEX(FNAME,'.',.TRUE.)-1)
WRITE(IU,'(A)') '# Nam File Generated by iMOD '//TRIM(RVERSION)
WRITE(IU,'(A)') 'LIST 10 '//CHAR(39)//TRIM(LINE)//'.LIST'//CHAR(39)
WRITE(IU,'(A)') 'BAS6 11 '//CHAR(39)//TRIM(LINE)//'.BAS6'//CHAR(39)
WRITE(IU,'(A)') 'DIS 12 '//CHAR(39)//TRIM(LINE)//'.DIS6'//CHAR(39)
IF(LBCF) WRITE(IU,'(A)') 'BCF6 13 '//CHAR(39)//TRIM(LINE)//'.BCF6'//CHAR(39)
IF(LLPF) WRITE(IU,'(A)') 'LPF 13 '//CHAR(39)//TRIM(LINE)//'.LPF7'//CHAR(39)
IF(LPCG) WRITE(IU,'(A)') 'PCG 14 '//CHAR(39)//TRIM(LINE)//'.PCG7'//CHAR(39)
IF(LPCGN)WRITE(IU,'(A)') 'PCGN 14 '//CHAR(39)//TRIM(LINE)//'.PCGN'//CHAR(39)
IF(LSIP) WRITE(IU,'(A)') 'SIP 14 '//CHAR(39)//TRIM(LINE)//'.SIP'//CHAR(39)
WRITE(IU,'(A)') 'OC 15 '//CHAR(39)//TRIM(LINE)//'.OC'//CHAR(39)
IF(LRCH) WRITE(IU,'(A)') 'RCH 16 '//CHAR(39)//TRIM(LINE)//'.RCH7'//CHAR(39)
IF(LEVT) WRITE(IU,'(A)') 'EVT 17 '//CHAR(39)//TRIM(LINE)//'.EVT7'//CHAR(39)
IF(LDRN.OR.LOLF) WRITE(IU,'(A)') 'DRN 18 '//CHAR(39)//TRIM(LINE)//'.DRN7'//CHAR(39)
IF(LRIV.OR.LISG) WRITE(IU,'(A)') 'RIV 19 '//CHAR(39)//TRIM(LINE)//'.RIV7'//CHAR(39)
IF(LGHB) WRITE(IU,'(A)') 'GHB 20 '//CHAR(39)//TRIM(LINE)//'.GHB7'//CHAR(39)
IF(LCHD) WRITE(IU,'(A)') 'CHD 21 '//CHAR(39)//TRIM(LINE)//'.CHD7'//CHAR(39)
IF(LWEL) WRITE(IU,'(A)') 'WEL 22 '//CHAR(39)//TRIM(LINE)//'.WEL7'//CHAR(39)
IF(LHFB) WRITE(IU,'(A)') 'HFB 23 '//CHAR(39)//TRIM(LINE)//'.HFB7'//CHAR(39)
WRITE(IU,'(A,I3,A)') 'DATA(BINARY) ',IHEDUN,' '//CHAR(39)//TRIM(LINE)//'_HEAD.DAT'//CHAR(39)
WRITE(IU,'(A,I3,A)') 'DATA(BINARY) ',IBCFCB,' '//CHAR(39)//TRIM(LINE)//'_FBCF.DAT'//CHAR(39)
IF(LRCH)WRITE(IU,'(A,I3,A)') 'DATA(BINARY) ',IRCHCB,' '//CHAR(39)//TRIM(LINE)//'_FRCH.DAT'//CHAR(39)
IF(LEVT)WRITE(IU,'(A,I3,A)') 'DATA(BINARY) ',IEVTCB,' '//CHAR(39)//TRIM(LINE)//'_FEVT.DAT'//CHAR(39)
IF(LDRN.OR.LOLF)WRITE(IU,'(A,I3,A)') 'DATA(BINARY) ',IDRNCB,' '//CHAR(39)//TRIM(LINE)//'_FDRN.DAT'//CHAR(39)
IF(LRIV.OR.LISG)WRITE(IU,'(A,I3,A)') 'DATA(BINARY) ',IRIVCB,' '//CHAR(39)//TRIM(LINE)//'_FRIV.DAT'//CHAR(39)
IF(LGHB)WRITE(IU,'(A,I3,A)') 'DATA(BINARY) ',IGHBCB,' '//CHAR(39)//TRIM(LINE)//'_FGHB.DAT'//CHAR(39)
IF(LCHD)WRITE(IU,'(A,I3,A)') 'DATA(BINARY) ',ICHDCB,' '//CHAR(39)//TRIM(LINE)//'_FCHD.DAT'//CHAR(39)
IF(LWEL)WRITE(IU,'(A,I3,A)') 'DATA(BINARY) ',IWELCB,' '//CHAR(39)//TRIM(LINE)//'_FWEL.DAT'//CHAR(39)
CLOSE(IU)
ALLOCATE(BND(NLAY)); DO ILAY=1,NLAY; CALL IDFNULLIFY(BND(ILAY)); ENDDO
ALLOCATE(SHD(NLAY)); DO ILAY=1,NLAY; CALL IDFNULLIFY(SHD(ILAY)); ENDDO
ALLOCATE(TOP(NLAY)); DO ILAY=1,NLAY; CALL IDFNULLIFY(TOP(ILAY)); ENDDO
ALLOCATE(BOT(NLAY)); DO ILAY=1,NLAY; CALL IDFNULLIFY(BOT(ILAY)); ENDDO
ALLOCATE(KD (NLAY)); DO ILAY=1,NLAY; CALL IDFNULLIFY(KD (ILAY)); ENDDO
!## read idf for dimensions
CALL IDFNULLIFY(IDF); IFULL=0
!## try to read at least a single BND file specified as IDF
DO ILAY=1,NLAY
!## skip constant entries
IF(TOPICS(4)%STRESS(1)%FILES(ILAY,1)%ICNST.EQ.1)CYCLE
IF(.NOT.IDFREAD(IDF,TOPICS(4)%STRESS(1)%FILES(ILAY,1)%FNAME,0,IQ=1))THEN
IF(IDF%IU.GT.0)THEN
INQUIRE(UNIT=IDF%IU,OPENED=LEX)
IF(LEX)CLOSE(IDF%IU); IDF%IU=0
ENDIF
CLOSE(IU); RETURN
ELSE
!## read in correct, close it again
CLOSE(IDF%IU); IDF%IU=0; EXIT
ENDIF
ENDDO
IF(ISUBMODEL.EQ.1)THEN
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)
ENDIF
IF(.NOT.IDFALLOCATEX(IDF))RETURN
IERROR=0
CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIR)//'.BAS6'//'...')
!## construct bas6-file
IUBAS=UTL_GETUNIT(); CALL OSD_OPEN(IUBAS,FILE=TRIM(DIR)//'.BAS6',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IUBAS.EQ.0)RETURN
WRITE(IUBAS,'(A)') '# BAS6 File Generated by iMOD '//TRIM(RVERSION)
WRITE(IUBAS,'(A,F15.7)') 'FREE STOPERROR ',STOPER
!## bnd settings
ITOPIC=4; SCL_D=0; SCL_U=1; IINV=0
DO ILAY=1,NLAY
CALL IDFCOPY(IDF,BND(ILAY))
IF(.NOT.PMANAGER_SAVEMF2005_MOD(BND(ILAY),ITOPIC,1,1,ILAY,SCL_D,SCL_U,HNOFLOW,IINV))RETURN
!## adjust boundary for submodel()
CALL PMANAGER_SAVEMF2005_BND(BND(ILAY),HNOFLOW)
ENDDO
!## shd settings
ITOPIC=5; SCL_D=1; SCL_U=2; IINV=0
DO ILAY=1,NLAY
CALL IDFCOPY(IDF,SHD(ILAY))
IF(.NOT.PMANAGER_SAVEMF2005_MOD(SHD(ILAY),ITOPIC,1,1,ILAY,SCL_D,SCL_U,HNOFLOW,IINV))RETURN
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,SHD(ILAY),0,ITOPIC)
ENDDO
DO ILAY=1,NLAY; CALL IDFCOPY(BND(ILAY),TOP(ILAY)); ENDDO
DO ILAY=1,NLAY; CALL IDFCOPY(BND(ILAY),BOT(ILAY)); ENDDO
DO ILAY=1,NLAY; CALL IDFCOPY(BND(ILAY),KD(ILAY) ); ENDDO
CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIR)//'.DIS6'//'...')
!## construct dis-file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIR)//'.DIS6',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# DIS6 File Generated by iMOD '//TRIM(RVERSION)
LINE=TRIM(ITOS(NLAY))//','//TRIM(ITOS(IDF%NROW))//','//TRIM(ITOS(IDF%NCOL))//','//TRIM(ITOS(NPER))//',4,2'
WRITE(IU,'(A)') TRIM(LINE)
!## laycbd code
LINE=''
DO ILAY=1,NLAY
IF(ILAY.LT.NLAY)THEN
!## quasi-3d scheme
IF(LQBD)THEN
LINE=TRIM(LINE)//' 1'
!## 3d no quasi confining bed
ELSE
LINE=TRIM(LINE)//' 0'
ENDIF
ELSE
!## lowest layer has never a quasi-confining bed
LINE=TRIM(LINE)//' 0'
ENDIF
ENDDO
WRITE(IU,'(A)') TRIM(LINE)
WRITE(IU,'(A)') 'CONSTANT '//TRIM(RTOS(IDF%DX,'E',7)); WRITE(IU,'(A)') 'CONSTANT '//TRIM(RTOS(IDF%DY,'E',7))
!## check top/bottom
LTB=.TRUE.
!## top settings
SCL_D=1; SCL_U=2; IINT=0
DO ILAY=1,NLAY
ITOPIC=2; LEX=.FALSE.
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))THEN
IF(.NOT.PMANAGER_SAVEMF2005_MOD(TOP(ILAY),ITOPIC,1,1,ILAY,SCL_D,SCL_U,HNOFLOW,IINV))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
ITOPIC=3; LEX=.FALSE.
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN
IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))THEN
IF(.NOT.PMANAGER_SAVEMF2005_MOD(BOT(ILAY),ITOPIC,1,1,ILAY,SCL_D,SCL_U,HNOFLOW,IINV))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
!## apply consistency checks
IF(LTB)THEN
!## apply consistency check top/bot
DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL; DO ILAY=1,NLAY
IF(ILAY.GT.1 )TOP(ILAY)%X(ICOL,IROW)=MIN(BOT(ILAY-1)%X(ICOL,IROW)-MINTHICKNESS,TOP(ILAY)%X(ICOL,IROW))
BOT(ILAY)%X(ICOL,IROW)=MIN(TOP(ILAY)%X(ICOL,IROW)-MINTHICKNESS ,BOT(ILAY)%X(ICOL,IROW))
ENDDO; ENDDO; ENDDO
!## apply consistency check constant head and top/bot
DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL; DO ILAY=1,NLAY
IF(BND(ILAY)%X(ICOL,IROW).LT.0)THEN
!## constant head cell dry - becomes active node
IF(SHD(ILAY)%X(ICOL,IROW).LE.BOT(ILAY)%X(ICOL,IROW))BND(ILAY)%X(ICOL,IROW)=1
ENDIF
ENDDO; ENDDO; ENDDO
ENDIF
!## write bas and dis - after consistency checks
IINT=1
DO ILAY=1,NLAY
EXFNAME=TRIM(DIR)//'\BAS6\IBOUND_L'//TRIM(ITOS(ILAY))//FEXT(IIDEBUG)
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(EXFNAME,BND(ILAY),IINT,IUBAS,HNOFLOW))RETURN
ENDDO
WRITE(IUBAS,'(A)') TRIM(RTOS(HNOFLOW,'E',7))
IINT=0
DO ILAY=1,NLAY
EXFNAME=TRIM(DIR)//'\BAS6\STRT_L'//TRIM(ITOS(ILAY))//FEXT(IIDEBUG)
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(EXFNAME,SHD(ILAY),IINT,IUBAS,HNOFLOW))RETURN
ENDDO
CLOSE(IUBAS)
DO ILAY=1,NLAY
EXFNAME=TRIM(DIR)//'\DIS6\TOP_L'//TRIM(ITOS(ILAY))//FEXT(IIDEBUG)
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(EXFNAME,TOP(ILAY),IINT,IU,HNOFLOW))RETURN
!## quasi-3d scheme add bot aquifer modellayer
IF(LQBD.OR.ILAY.EQ.NLAY)THEN
EXFNAME=TRIM(DIR)//'\DIS6\BOTM_L'//TRIM(ITOS(ILAY))//FEXT(IIDEBUG)
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(EXFNAME,BOT(ILAY),IINT,IU,HNOFLOW))RETURN
ENDIF
ENDDO
ISS=0
!## time information
DO KPER=1,NPER
LINE=TRIM(RTOS(SIM(KPER)%DELT,'E',7))//',1,1.0'
IF(SIM(KPER)%DELT.EQ.0.0)LINE=TRIM(LINE)//',SS'
IF(SIM(KPER)%DELT.NE.0.0)THEN; LINE=TRIM(LINE)//',TR'; ISS=1; ENDIF
LINE=TRIM(LINE)//' ['//TRIM(SIM(KPER)%CDATE)//']'
WRITE(IU,'(A)') TRIM(LINE)
ENDDO
CLOSE(IU)
!## write metaswap
IF(LMSP)CALL PMANAGER_SAMEMF2005_METASWAP(IDF%NCOL,IDF%NROW,NLAY,HNOFLOW,BND,IDF)
!## use bcf6
IF(LBCF)THEN
CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIR)//'.BCF6'//'...')
!## construct bcf6-file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIR)//'.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'
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
DO ILAY=1,NLAY
!## sf1
IF(ISS.EQ.1)THEN
ITOPIC=11; SCL_D=1; SCL_U=2; IINV=0; IINT=0
IF(.NOT.PMANAGER_SAVEMF2005_MOD(IDF,ITOPIC,1,1,ILAY,SCL_D,SCL_U,HNOFLOW,IINV))RETURN
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,IDF,0,ITOPIC)
EXFNAME=TRIM(DIR)//'\BCF6\SF1_L'//TRIM(ITOS(ILAY))//FEXT(IIDEBUG)
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(EXFNAME,IDF,IINT,IU,HNOFLOW))RETURN
ENDIF
!## kdw
ITOPIC=6; SCL_D=1; SCL_U=3; IINV=0; IINT=0
IF(.NOT.PMANAGER_SAVEMF2005_MOD(KD(ILAY),ITOPIC,1,1,ILAY,SCL_D,SCL_U,HNOFLOW,IINV))RETURN
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,KD(ILAY),0,ITOPIC)
EXFNAME=TRIM(DIR)//'\BCF6\TRAN_L'//TRIM(ITOS(ILAY))//FEXT(IIDEBUG)
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(EXFNAME,KD(ILAY),IINT,IU,HNOFLOW))RETURN
IF(ILAY.NE.NLAY)THEN
!## vcont
ITOPIC=9; SCL_D=1; SCL_U=6; IINV=1; IINT=0
IF(.NOT.PMANAGER_SAVEMF2005_MOD(IDF,ITOPIC,1,1,ILAY,SCL_D,SCL_U,HNOFLOW,IINV))RETURN
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,IDF,0,ITOPIC)
EXFNAME=TRIM(DIR)//'\BCF6\VCONT_L'//TRIM(ITOS(ILAY))//FEXT(IIDEBUG)
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(EXFNAME,IDF,IINT,IU,HNOFLOW))RETURN
ENDIF
ENDDO
CLOSE(IU)
ENDIF
!## use lpf7
IF(LLPF)THEN
CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIR)//'.LPF7'//'...')
!## construct lpf7-file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIR)//'.LPF7',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# LPF7 File Generated by iMOD '//TRIM(RVERSION)
LINE=TRIM(ITOS(IBCFCB))//','//TRIM(RTOS(HNOFLOW,'E',7))//',0,STORAGECOEFFICIENT'
WRITE(IU,'(A)') TRIM(LINE)
!## laytyp code
LINE=''; DO ILAY=1,NLAY; LINE=TRIM(LINE)//'0,'
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)
!## layavg code
LINE=''; DO ILAY=1,NLAY; LINE=TRIM(LINE)//'0,'
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)
!## chani code
LINE=''; DO ILAY=1,NLAY; LINE=TRIM(LINE)//'1.0,'
IF(MOD(ILAY,20).EQ.0)THEN; WRITE(IU,'(A)') TRIM(LINE); LINE=''; ENDIF
ENDDO; IF(LEN_TRIM(LINE).NE.0)WRITE(IU,'(A)') TRIM(LINE)
!## lvka code
LINE=''; DO ILAY=1,NLAY; LINE=TRIM(LINE)//'1,'
IF(MOD(ILAY,20).EQ.0)THEN; WRITE(IU,'(A)') TRIM(LINE); LINE=''; ENDIF
ENDDO; IF(LEN_TRIM(LINE).NE.0)WRITE(IU,'(A)') TRIM(LINE)
!## laywet code
LINE=''; DO ILAY=1,NLAY; LINE=TRIM(LINE)//'0,'
IF(MOD(ILAY,20).EQ.0)THEN; WRITE(IU,'(A)') TRIM(LINE); LINE=''; ENDIF
ENDDO; IF(LEN_TRIM(LINE).NE.0)WRITE(IU,'(A)') TRIM(LINE)
DO ILAY=1,NLAY
!## hk
ITOPIC=7; SCL_D=1; SCL_U=3; IINT=0; IINV=0
IF(.NOT.PMANAGER_SAVEMF2005_MOD(KD(ILAY),ITOPIC,1,1,ILAY,SCL_D,SCL_U,HNOFLOW,IINV))RETURN
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,KD(ILAY),0,ITOPIC)
EXFNAME=TRIM(DIR)//'\LPF7\HK_L'//TRIM(ITOS(ILAY))//FEXT(IIDEBUG)
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(EXFNAME,KD(ILAY),IINT,IU,HNOFLOW))RETURN
!## vka
ITOPIC=8; SCL_D=1; SCL_U=2; IINT=0; IINV=1
IF(.NOT.PMANAGER_SAVEMF2005_MOD(IDF,ITOPIC,1,1,ILAY,SCL_D,SCL_U,HNOFLOW,IINV))RETURN
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,IDF,0,ITOPIC)
EXFNAME=TRIM(DIR)//'\LPF7\VKA_L'//TRIM(ITOS(ILAY))//FEXT(IIDEBUG)
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(EXFNAME,IDF,IINT,IU,HNOFLOW))RETURN
!## sf1
IF(ISS.EQ.1)THEN
ITOPIC=11; SCL_D=1; SCL_U=2; IINT=0; IINV=0
IF(.NOT.PMANAGER_SAVEMF2005_MOD(IDF,ITOPIC,1,1,ILAY,SCL_D,SCL_U,HNOFLOW,IINV))RETURN
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,IDF,0,ITOPIC)
EXFNAME=TRIM(DIR)//'\LPF7\SF1_L'//TRIM(ITOS(ILAY))//FEXT(IIDEBUG)
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(EXFNAME,IDF,IINT,IU,HNOFLOW))RETURN
ENDIF
!## quasi-3d scheme add bot aquifer modellayer
IF(LQBD.AND.ILAY.NE.NLAY)THEN
!## kvv
ITOPIC=10; SCL_D=1; SCL_U=3; IINT=0; IINV=1
IF(.NOT.PMANAGER_SAVEMF2005_MOD(IDF,ITOPIC,1,1,ILAY,SCL_D,SCL_U,HNOFLOW,IINV))RETURN
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,IDF,0,ITOPIC)
EXFNAME=TRIM(DIR)//'\LPF7\VKCB_L'//TRIM(ITOS(ILAY))//FEXT(IIDEBUG)
IF(.NOT.PMANAGER_SAVEMF2005_MOD_U2DREL(EXFNAME,IDF,IINT,IU,HNOFLOW))RETURN
ENDIF
ENDDO
CLOSE(IU)
ENDIF
!## use hfb
IF(LHFB)THEN
!## construct hfb-file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIR)//'.HFB7',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# HFB7 File Generated by iMOD '//TRIM(RVERSION)
ITOPIC=15; IF(.NOT.PMANAGER_SAVEMF2005_HFB(IDF,ITOPIC,IU))RETURN
ENDIF
!## use pcg
IF(LPCG)THEN
!## construct pcg-file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIR)//'.PCG7',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# PCG7 File Generated by iMOD '//TRIM(RVERSION)
LINE=TRIM(ITOS(MXITER))//','//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)
ENDIF
!## use pcgn
IF(LPCGN)THEN
!## construct pcgn-file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIR)//'.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)
ENDIF
!## use pcg
IF(LSIP)THEN
!## construct sip-file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIR)//'.SIP',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# SIP File Generated by iMOD '//TRIM(RVERSION)
LINE=TRIM(ITOS(MXITER))//',5'; WRITE(IU,'(A)') TRIM(LINE)
LINE=TRIM(RTOS(RELAX,'E',7))//','//TRIM(RTOS(HCLOSE,'E',7))//',1,0.0,1'; WRITE(IU,'(A)') TRIM(LINE)
CLOSE(IU)
ENDIF
!## construct oc-file
IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=TRIM(DIR)//'.OC',STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# OC File Generated by iMOD '//TRIM(RVERSION)
LINE='HEAD SAVE UNIT '//TRIM(ITOS(IHEDUN)); WRITE(IU,'(A)') TRIM(LINE)
DO IPER=1,NPER
LINE='PERIOD '//TRIM(ITOS(IPER))//' STEP 1'; WRITE(IU,'(A)') TRIM(LINE)
LINE='SAVE HEAD'; DO ILAY=1,NLAY; LINE=TRIM(LINE)//' '//TRIM(ITOS(ILAY)); ENDDO; WRITE(IU,'(A)') TRIM(LINE)
LINE='SAVE BUDGET'; DO ILAY=1,NLAY; LINE=TRIM(LINE)//' '//TRIM(ITOS(ILAY)); ENDDO; WRITE(IU,'(A)') TRIM(LINE)
ENDDO
CLOSE(IU)
DO ITOPIC=21,29
SELECT CASE (ITOPIC)
CASE (21); LEX=LWEL; CPCK='WEL'; ICB=IWELCB; CMAXNO='NaN'; CAUX=', AUXILIARY SYSTEM NOPRINT'; TEXT='_'
CASE (22); LEX=LDRN; CPCK='DRN'; ICB=IDRNCB; CMAXNO='NaN'; CAUX=', AUXILIARY SYSTEM NOPRINT'; TEXT='_'
CASE (23); LEX=LRIV; CPCK='RIV'; ICB=IRIVCB; CMAXNO='NaN'; CAUX=', AUXILIARY INFFCT AUXILIARY SYSTEM NOPRINT'; TEXT='_'
CASE (24); LEX=LEVT; CPCK='EVT'; ICB=IEVTCB; CMAXNO=TRIM(ITOS(NEVTOP)); CAUX=''; TEXT=''
CASE (25); LEX=LGHB; CPCK='GHB'; ICB=IGHBCB; CMAXNO='NaN'; CAUX=', AUXILIARY SYSTEM NOPRINT'; TEXT='_'
CASE (26); LEX=LRCH; CPCK='RCH'; ICB=IRCHCB; CMAXNO=TRIM(ITOS(NRCHOP)); CAUX=''; TEXT=''
CASE (27); LEX=LOLF
CPCK='OLF'; IF(.NOT.LDRN)CPCK='DRN'
ICB=IDRNCB; CMAXNO='NaN'; CAUX=', AUXILIARY SYSTEM NOPRINT'; TEXT='_'
CASE (28); LEX=LCHD; CPCK='CHD'; ICB=ICHDCB; CMAXNO='NaN'; CAUX=', AUXILIARY SYSTEM NOPRINT'; TEXT='_'
CASE (29); LEX=LISG
CPCK='ISG'; IF(.NOT.LRIV)CPCK='RIV'
ICB=IRIVCB; CMAXNO='NaN'; CAUX=', AUXILIARY SYSTEM NOPRINT'; TEXT='_'
END SELECT
!## not available
IF(.NOT.LEX)CYCLE
CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(DIR)//'.'//TRIM(CPCK)//'7...')
IU=UTL_GETUNIT()
CALL OSD_OPEN(IU,FILE=TRIM(DIR)//'.'//TRIM(CPCK)//'7'//TRIM(TEXT),STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED')
IF(IU.EQ.0)RETURN
WRITE(IU,'(A)') '# '//TRIM(CPCK)//'7 File Generated by iMOD '//TRIM(RVERSION)
LINE=TRIM(CMAXNO)//','//TRIM(ITOS(ICB))//TRIM(CAUX); WRITE(IU,'(A)') TRIM(LINE)
IF(.NOT.PMANAGER_SAVEMF2005_PCK(IU,ITOPIC,BND,HNOFLOW,DIR,TRIM(CPCK)//'7\'//TRIM(CPCK),NP,LTB,TOP,BOT,KD))RETURN
CLOSE(IU); IF(TEXT.NE.'')CALL PMANAGER_SAVEMF2005_MAXNO(TRIM(DIR)//'.'//TRIM(CPCK)//'7'//TRIM(TEXT),NP)
ENDDO
!## combine olf/drn and isg/riv
IF(LOLF.AND.LDRN)CALL PMANAGER_SAMEMF2005_COMBINE(DIR,(/'OLF','DRN','DRN_'/),IDRNCB,'')
IF(LISG.AND.LRIV)CALL PMANAGER_SAMEMF2005_COMBINE(DIR,(/'ISG','RIV','RIV_'/),IRIVCB,'AUXILIARY INFFCT')
CALL IDFDEALLOCATEX(IDF)
CALL IDFDEALLOCATE(BND,SIZE(BND)); DEALLOCATE(BND)
CALL IDFDEALLOCATE(SHD,SIZE(SHD)); DEALLOCATE(SHD)
CALL IDFDEALLOCATE(TOP,SIZE(TOP)); DEALLOCATE(TOP)
CALL IDFDEALLOCATE(BOT,SIZE(BOT)); DEALLOCATE(BOT)
CALL IDFDEALLOCATE(KD ,SIZE(KD)); DEALLOCATE(KD)
PMANAGER_SAVEMF2005=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005
!####====================================================================
SUBROUTINE PMANAGER_SAMEMF2005_METASWAP(NCOL,NROW,NLAY,HNOFLOW,BND,IDF)
!####====================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: NCOL,NROW,NLAY
REAL,INTENT(IN) :: HNOFLOW
TYPE(IDFOBJ),INTENT(INOUT) :: IDF
TYPE(IDFOBJ),DIMENSION(NLAY),INTENT(INOUT) :: BND
!## dummy variables
INTEGER :: ISYS,ILAY,ITOPIC,IPER,IINV,SCL_U,SCL_D
INTEGER :: I,J,NIDF
REAL,DIMENSION(:),ALLOCATABLE :: NODATA
INTEGER,DIMENSION(:),ALLOCATABLE :: IERROR
CHARACTER(LEN=256) :: FFNAME
NIDF=22; ALLOCATE(NODATA(NIDF))
!## allocate memory
IF(ALLOCATED(SIMGRO))DEALLOCATE(SIMGRO); ALLOCATE(SIMGRO(NCOL,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')
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(IDF,ITOPIC,IPER,ISYS,ILAY,SCL_D,SCL_U,HNOFLOW,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_SAMEMF2005_METASWAP_CHECK(IDF,NCOL,NROW,NLAY,NODATA,IERROR)
ISYS=8
CALL PMANAGER_SAMEMF2005_METASWAP_INPFILES(NROW,NCOL,NLAY,NODATA(20),TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISYS,ILAY)%FNAME,IDF,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_SAMEMF2005_METASWAP_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_SAMEMF2005_METASWAP_METEGRID()
DEALLOCATE(SIMGRO,NODATA,IERROR)
END SUBROUTINE PMANAGER_SAMEMF2005_METASWAP
!###====================================================================
SUBROUTINE PMANAGER_SAMEMF2005_METASWAP_PARASIM(FNAME,IDF)
!###====================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: FNAME
TYPE(IDFOBJ),INTENT(IN) :: IDF
INTEGER :: IU,JU,I,IOS
CHARACTER(LEN=256) :: LINE
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,'F',2))
WRITE(JU,'(A)') TRIM(LINE)
LINE=' idf_ymin = '//TRIM(RTOS(IDF%YMIN,'F',2))
WRITE(JU,'(A)') TRIM(LINE)
LINE=' idf_dx = '//TRIM(RTOS(IDF%DX,'F',2))
WRITE(JU,'(A)') TRIM(LINE)
LINE=' idf_dy = '//TRIM(RTOS(IDF%DY,'F',2))
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(-9999.99,'F',2))
WRITE(JU,'(A)') TRIM(LINE)
CLOSE(JU)
END SUBROUTINE PMANAGER_SAMEMF2005_METASWAP_PARASIM
!###====================================================================
SUBROUTINE PMANAGER_SAMEMF2005_METASWAP_INPFILES(NROW,NCOL,NLAY,NODATA_PWT,IPFFILE,IDF,LPWT)
!###====================================================================
IMPLICIT NONE
LOGICAL :: LPWT
REAL,INTENT(IN) :: NODATA_PWT
INTEGER,INTENT(IN) :: NROW,NCOL,NLAY
CHARACTER(LEN=*),INTENT(IN) :: IPFFILE
TYPE(IDFOBJ),INTENT(IN) :: IDF
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,NROW
DO ICOL=1,NCOL
IF(SIMGRO(ICOL,IROW)%IBOUND.LE.0)CYCLE
MDND=(IROW-1)*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)*NCOL+JCOL
MDND2=MDND2+(LYBE-1)*NCOL*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_SAMEMF2005_METASWAP_INPFILES
!###====================================================================
SUBROUTINE PMANAGER_SAMEMF2005_METASWAP_CHECK(IDF,NCOL,NROW,NLAY,NODATA,IERROR)
!###====================================================================
IMPLICIT NONE
TYPE(IDFOBJ),INTENT(IN) :: IDF
INTEGER,INTENT(IN) :: NCOL,NROW,NLAY
REAL,DIMENSION(:),INTENT(IN) :: NODATA
INTEGER,DIMENSION(:),INTENT(OUT) :: IERROR
INTEGER :: IROW,ICOL,STRLEN
REAL :: DXY,ARND
CHARACTER(LEN=:),ALLOCATABLE :: STR
!## make sure that for sopp>0 there is a vxmu value, turn nopp otherwise off
DO IROW=1,NROW; DO ICOL=1,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
IERROR=0
DO IROW=1,NROW; DO ICOL=1,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); RETURN
ENDIF
!## change surface water into gras; change urban into gras
DO IROW=1,NROW
DO ICOL=1,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,NROW; DO ICOL=1,NCOL
IF(SIMGRO(ICOL,IROW)%RZ.LT.10.0)SIMGRO(ICOL,IROW)%RZ=10.0
ENDDO; ENDDO
!## minimal nopp-value
DO IROW=1,NROW; DO ICOL=1,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,NROW
DO ICOL=1,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 nul!
DO IROW=1,NROW
DO ICOL=1,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
END SUBROUTINE PMANAGER_SAMEMF2005_METASWAP_CHECK
!###======================================================================
SUBROUTINE PMANAGER_SAMEMF2005_COMBINE(DIR,PCK,CB,CAUX)
!###======================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: DIR,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) :: LINE
CHARACTER(LEN=256),DIMENSION(3) :: FNAME,FNAME_PREV
INTEGER :: I,J,IPER
!## read from files
IU=0
DO I=1,SIZE(PCK)
LINE=TRIM(DIR)//'.'//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
DO I=1,2; READ(IU(I),'(A256)') LINE; ENDDO; WRITE(IU(3),'(A)') TRIM(LINE)
NO=0; DO I=1,2; READ(IU(I),*) NO(I); ENDDO
LINE=TRIM(ITOS(SUM(NO)))//','//TRIM(ITOS(CB))//','//TRIM(CAUX)//' AUXILIARY SYSTEM 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=''
!## resuse 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(DIR)//'.'//TRIM(PCK(3))//'7'
FNAME(2)=TRIM(DIR)//'.'//TRIM(PCK(2))//'7'
CALL IOSRENAMEFILE(FNAME(1),FNAME(2))
END SUBROUTINE PMANAGER_SAMEMF2005_COMBINE
!###======================================================================
SUBROUTINE PMANAGER_SAVEMF2005_MAXNO(FNAME,NP)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: NP
CHARACTER(LEN=*),INTENT(IN) :: FNAME
INTEGER :: IU,JU,IOS
CHARACTER(LEN=256) :: LINE
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)LINE=UTL_SUBST(LINE,'NaN',ITOS(NP))
WRITE(JU,'(A)') TRIM(ADJUSTL(LINE))
ENDDO
CLOSE(IU,STATUS='DELETE'); CLOSE(JU)
END SUBROUTINE PMANAGER_SAVEMF2005_MAXNO
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_PCK(IU,ITOPIC,BND,HNOFLOW,DIR,EXT,NP,LTB,TOP,BOT,KD)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IU,ITOPIC
INTEGER,INTENT(OUT) :: NP
REAL,INTENT(IN) :: HNOFLOW
CHARACTER(LEN=*),INTENT(IN) :: EXT,DIR
TYPE(IDFOBJ),INTENT(INOUT),DIMENSION(:) :: BND,TOP,BOT,KD
LOGICAL,INTENT(IN) :: LTB
INTEGER,DIMENSION(:),ALLOCATABLE :: IEQUAL
INTEGER :: IPER,KPER,ISYS,K,NTOP,NSYS,SCL_D,SCL_U
CHARACTER(LEN=512) :: LINE
CHARACTER(LEN=256) :: EXFNAME
REAL :: FCT,IMP,CNST
INTEGER :: ILAY,IS1,ICNST,INEW
TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:,:) :: PCK
PMANAGER_SAVEMF2005_PCK=.FALSE.
NP=0
DO IPER=1,NPER
!## get appropriate stress-period to store in runfile
KPER=PMANAGER_GETCURRENTIPER(IPER,ITOPIC)
!## reuse previous timestep
IF(KPER.LE.0)THEN
SELECT CASE (ITOPIC)
CASE (24) !## evt
WRITE(IU,'(A)') '-1,-1,-1'
CASE (21,22,23,25,26,27,28,29) !## wel,drn,riv,ghb,rch,chd,olf,isg
WRITE(IU,'(A)') '-1'
END SELECT
ELSE
!## allocate memory for packages
NTOP=SIZE(TOPICS(ITOPIC)%STRESS(KPER)%FILES,1); NSYS=SIZE(TOPICS(ITOPIC)%STRESS(KPER)%FILES,2)
INEW=0
SELECT CASE (ITOPIC)
CASE (24,26) !## evt,rch
!## try to reuse pck() for data-efficiency
IF(ALLOCATED(PCK))THEN
IF(SIZE(PCK,1).NE.NTOP.OR.SIZE(PCK,2).NE.NSYS+1)THEN
DO K=1,SIZE(PCK,1); DO ISYS=1,SIZE(PCK,2); CALL IDFDEALLOCATEX(PCK(K,ISYS)); ENDDO; ENDDO; DEALLOCATE(PCK)
ENDIF
ENDIF
IF(.NOT.ALLOCATED(PCK))THEN; ALLOCATE(PCK(NTOP,0:NSYS)); INEW=1; ENDIF
IS1=0
CASE (21,22,23,25,27,28,29) !## wel,drn,riv,ghb,chd,olf,isg
ALLOCATE(PCK(NTOP,NSYS)); IS1=1; INEW=1
END SELECT
IF(INEW.EQ.1)THEN
DO K=1,NTOP; DO ISYS=IS1,NSYS
CALL IDFNULLIFY(PCK(K,ISYS))
SELECT CASE (ITOPIC)
CASE (22:28); CALL IDFCOPY(BND(1),PCK(K,ISYS)) !; PCK(K,ISYS)%X=0.0
END SELECT
ENDDO; ENDDO
ENDIF
!## number of subtopics
DO K=1,NTOP
SELECT CASE (ITOPIC)
CASE (21) !## wel - nothing to do here
CASE (24) !## evt
SCL_D=1
IF(K.EQ.1)SCL_U=4
IF(K.NE.1)SCL_U=2
CASE (26) !## rch
SCL_D=1; SCL_U=4
CASE (22,23,25,27,28) !## drn,riv,ghb,chd,olf
IF(K.EQ.1)THEN; SCL_D=0; SCL_U=5; ENDIF
IF(K.NE.1)THEN; SCL_D=0; SCL_U=2; ENDIF
CASE (29) !## isg - nothing to do here
CASE DEFAULT
STOP 'ERROR PMANAGER_SAVEMF2005_PCK'
END SELECT
!## number of systems
DO ISYS=1,NSYS
ICNST=TOPICS(ITOPIC)%STRESS(KPER)%FILES(K,ISYS)%ICNST
FCT =TOPICS(ITOPIC)%STRESS(KPER)%FILES(K,ISYS)%FCT
IMP =TOPICS(ITOPIC)%STRESS(KPER)%FILES(K,ISYS)%IMP
ILAY =TOPICS(ITOPIC)%STRESS(KPER)%FILES(K,ISYS)%ILAY
PCK(K,ISYS)%ILAY=ILAY
IF(ILAY.EQ.-1.AND..NOT.LTB)THEN
!## cannot be here
ENDIF
IF(ICNST.EQ.1)THEN
CNST=TOPICS(ITOPIC)%STRESS(KPER)%FILES(K,ISYS)%CNST
PCK(K,ISYS)%X=CNST
ELSEIF(TOPICS(ITOPIC)%STRESS(KPER)%FILES(K,ISYS)%ICNST.EQ.2)THEN
PCK(K,ISYS)%FNAME=TOPICS(ITOPIC)%STRESS(KPER)%FILES(K,ISYS)%FNAME
!## read/clip/scale idf file
SELECT CASE (ITOPIC)
CASE (22:28)
IF(.NOT.IDFREADSCALE(PCK(K,ISYS)%FNAME,PCK(K,ISYS),SCL_U,SCL_D,1.0,0))RETURN
END SELECT
ENDIF
!## rch/evt mm/day -> m/day
IF(K.EQ.1)THEN
SELECT CASE (ITOPIC)
CASE (24,26); FCT=FCT*0.001
END SELECT
ENDIF
!## correct for boundary etc.
SELECT CASE (ITOPIC)
CASE (22:28)
CALL PMANAGER_SAVEMF2005_FCTIMP(0,ICNST,PCK(K,ISYS),HNOFLOW,FCT,IMP)
CALL PMANAGER_SAVEMF2005_CORRECT(ILAY,BND,PCK(K,ISYS),1,ITOPIC)
END SELECT
ENDDO
ENDDO
ALLOCATE(IEQUAL(NTOP))
!## prepare for export into modflow 2005
SELECT CASE (ITOPIC)
CASE (21) !## wel
EXFNAME=TRIM(DIR)//'\'//TRIM(EXT)//'_t'//TRIM(ITOS(IPER))//FEXT(IIDEBUG)
IF(.NOT.PMANAGER_SAVEMF2005_PCK_ULSTRD(EXFNAME,PCK,NSYS,NTOP,IU,HNOFLOW,(/1/),NP,BND,TOP,BOT,KD,IPER,KPER,ITOPIC))RETURN
CASE (22) !## drn
EXFNAME=TRIM(DIR)//'\'//TRIM(EXT)//'_t'//TRIM(ITOS(IPER))//FEXT(IIDEBUG)
IF(.NOT.PMANAGER_SAVEMF2005_PCK_ULSTRD(EXFNAME,PCK,NSYS,NTOP,IU,HNOFLOW,(/2,1/),NP,BND,TOP,BOT,KD,IPER,KPER,ITOPIC))RETURN
CASE (23) !## riv
EXFNAME=TRIM(DIR)//'\'//TRIM(EXT)//'_t'//TRIM(ITOS(IPER))//FEXT(IIDEBUG)
IF(.NOT.PMANAGER_SAVEMF2005_PCK_ULSTRD(EXFNAME,PCK,NSYS,NTOP,IU,HNOFLOW,(/2,1,3,4/),NP,BND,TOP,BOT,KD,IPER,KPER,ITOPIC))RETURN
CASE (24) !## evt
CALL PMANAGER_SAVEMF2005_PCK_COLLECT(PCK,NSYS,NTOP,(/1,2,2/),HNOFLOW,IEQUAL,IPER)
LINE=TRIM(ITOS(IEQUAL(2)))//','//TRIM(ITOS(IEQUAL(1)))//','//TRIM(ITOS(IEQUAL(3)))
WRITE(IU,'(A)') TRIM(LINE)
IF(IEQUAL(2).EQ.1)THEN
EXFNAME=TRIM(DIR)//'\'//TRIM(EXT)//'_surf_t'//TRIM(ITOS(IPER))//FEXT(IIDEBUG)
IF(.NOT.PMANAGER_SAVEMF2005_PCK_U2DREL(EXFNAME,PCK(2,0),IU,HNOFLOW))RETURN
ENDIF
IF(IEQUAL(1).EQ.1)THEN
EXFNAME=TRIM(DIR)//'\'//TRIM(EXT)//'_evtr_t'//TRIM(ITOS(IPER))//FEXT(IIDEBUG)
IF(.NOT.PMANAGER_SAVEMF2005_PCK_U2DREL(EXFNAME,PCK(1,0),IU,HNOFLOW))RETURN
ENDIF
IF(IEQUAL(3).EQ.1)THEN
EXFNAME=TRIM(DIR)//'\'//TRIM(EXT)//'_exdp_t'//TRIM(ITOS(IPER))//FEXT(IIDEBUG)
IF(.NOT.PMANAGER_SAVEMF2005_PCK_U2DREL(EXFNAME,PCK(3,0),IU,HNOFLOW))RETURN
ENDIF
CASE (25) !## ghb
EXFNAME=TRIM(DIR)//'\'//TRIM(EXT)//'_t'//TRIM(ITOS(IPER))//FEXT(IIDEBUG)
IF(.NOT.PMANAGER_SAVEMF2005_PCK_ULSTRD(EXFNAME,PCK,NSYS,NTOP,IU,HNOFLOW,(/2,1/),NP,BND,TOP,BOT,KD,IPER,KPER,ITOPIC))RETURN
CASE (26) !## rch
CALL PMANAGER_SAVEMF2005_PCK_COLLECT(PCK,NSYS,NTOP,(/1/),HNOFLOW,IEQUAL,IPER)
LINE=TRIM(ITOS(IEQUAL(1))); WRITE(IU,'(A)') TRIM(LINE)
IF(IEQUAL(1).EQ.1)THEN
EXFNAME=TRIM(DIR)//'\'//TRIM(EXT)//'_rech_t'//TRIM(ITOS(IPER))//FEXT(IIDEBUG)
IF(.NOT.PMANAGER_SAVEMF2005_PCK_U2DREL(EXFNAME,PCK(1,0),IU,HNOFLOW))RETURN
ENDIF
CASE (27) !## olf
EXFNAME=TRIM(DIR)//'\'//TRIM(EXT)//'_t'//TRIM(ITOS(IPER))//FEXT(IIDEBUG)
IF(.NOT.PMANAGER_SAVEMF2005_PCK_ULSTRD(EXFNAME,PCK,NSYS,NTOP,IU,HNOFLOW,(/1/),NP,BND,TOP,BOT,KD,IPER,KPER,ITOPIC))RETURN
CASE (28) !## chd
EXFNAME=TRIM(DIR)//'\'//TRIM(EXT)//'_t'//TRIM(ITOS(IPER))//FEXT(IIDEBUG)
IF(.NOT.PMANAGER_SAVEMF2005_PCK_ULSTRD(EXFNAME,PCK,NSYS,NTOP,IU,HNOFLOW,(/1/),NP,BND,TOP,BOT,KD,IPER,KPER,ITOPIC))RETURN
CASE (29) !## isg
EXFNAME=TRIM(DIR)//'\'//TRIM(EXT)//'_t'//TRIM(ITOS(IPER))//FEXT(IIDEBUG)
IF(.NOT.PMANAGER_SAVEMF2005_PCK_ULSTRD(EXFNAME,PCK,NSYS,NTOP,IU,HNOFLOW,(/1/),NP,BND,TOP,BOT,KD,IPER,KPER,ITOPIC))RETURN
END SELECT
SELECT CASE (ITOPIC)
CASE (21,22,23,25,27,28,29) !## wel,drn,riv,ghb,chd,olf,isg
!## clean up
DO K=1,NTOP; DO ISYS=1,NSYS; CALL IDFDEALLOCATEX(PCK(K,ISYS)); ENDDO; ENDDO; DEALLOCATE(PCK)
END SELECT
DEALLOCATE(IEQUAL)
ENDIF
ENDDO
PMANAGER_SAVEMF2005_PCK=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_PCK
!###======================================================================
SUBROUTINE PMANAGER_SAVEMF2005_PCK_COLLECT(PCK,NSYS,NTOP,ISUM,HNOFLOW,IEQUAL,IPER)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: NSYS,NTOP,IPER
INTEGER,DIMENSION(NTOP) :: ISUM,IEQUAL
REAL,INTENT(IN) :: HNOFLOW
TYPE(IDFOBJ),INTENT(INOUT),DIMENSION(NTOP,0:NSYS) :: PCK
INTEGER :: IROW,ICOL,ISYS,ITOP
REAL :: MTOP
REAL,DIMENSION(:,:,:),ALLOCATABLE :: X
!## copy previous results ...
IF(IPER.GT.1)THEN
ALLOCATE(X(PCK(1,0)%NCOL,PCK(1,0)%NROW,NTOP))
DO ITOP=1,NTOP; DO IROW=1,PCK(1,0)%NROW; DO ICOL=1,PCK(1,0)%NCOL
X(ICOL,IROW,ITOP)=PCK(ITOP,0)%X(ICOL,IROW)
ENDDO; ENDDO; ENDDO
ENDIF
DO IROW=1,PCK(1,0)%NROW; DO ICOL=1,PCK(1,0)%NCOL
DO ITOP=1,NTOP
MTOP=0.0; PCK(ITOP,0)%X(ICOL,IROW)=0.0
DO ISYS=1,NSYS
IF(PCK(ITOP,0)%X(ICOL,IROW).NE.HNOFLOW)THEN
PCK(ITOP,0)%X(ICOL,IROW)=PCK(ITOP,0)%X(ICOL,IROW)+PCK(ITOP,ISYS)%X(ICOL,IROW)
MTOP=MTOP+1.0
ENDIF
ENDDO
IF(ISUM(ITOP).EQ.2)PCK(ITOP,0)%X(ICOL,IROW)=PCK(ITOP,0)%X(ICOL,IROW)/MTOP
ENDDO
ENDDO; ENDDO
!## non equal unless proven otherwise
IEQUAL=1
IF(IPER.GT.1)THEN
!## equal proven otherwise
IEQUAL=-1
DO ITOP=1,NTOP; IROWLOOP: DO IROW=1,PCK(1,0)%NROW; DO ICOL=1,PCK(1,0)%NCOL
IF(X(ICOL,IROW,ITOP).NE.PCK(ITOP,0)%X(ICOL,IROW))THEN; IEQUAL(ITOP)=1; EXIT IROWLOOP; ENDIF
ENDDO; ENDDO IROWLOOP; ENDDO
DEALLOCATE(X)
ENDIF
END SUBROUTINE PMANAGER_SAVEMF2005_PCK_COLLECT
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_PCK_ULSTRD(EXFNAME,PCK,NSYS,NTOP,IU, &
HNOFLOW,JTOP,NP,BND,TOP,BOT,KD,IPER,KPER,ITOPIC)
!###======================================================================
USE MOD_ISG_PAR, ONLY : XMIN,YMIN,XMAX,YMAX, & !## area to be gridded (x1,y1,x2,y2)'
ISS, & !## (1) mean over all periods, (2) mean over given period'
SDATE,EDATE, & !## startdate,enddate,ddate (yyyymmdd,yyyymmdd,dd)'
STIME,ETIME, & !## starttime,endtime,ddate (yyyymmddmmhhss,yyyymmddmmhhss,dd)'
IDIM, & !## (0) give area (2) entire domain of isg (3) selected isg'
CS, & !## cellsize'
MINDEPTH, & !## minimal waterdepth for computing conductances (m)'
WDEPTH, & !## waterdepth only used in combination with isimgro>0'
ICDIST, & !## (0) do not compute effect of weirs (1) do compute effect of weirs'
ISIMGRO, & !## ISIMGRO'
IEXPORT, & !## (0) idf (1) modflow river file
ROOT, & !## resultmap'
POSTFIX, & !## POSTFIX {POSTFIX}_stage.idf etc.'
NODATA, & !## nodatavalue in ISG
ISAVE, &
MAXWIDTH, & !#3 maximum widht for computing rivier-width (in case cross-sections are rubbish)
IAVERAGE, & !## (1) mean (2) median value
NISGFILES, &
ISGIU, &
MAXFILES
IMPLICIT NONE
INTEGER,INTENT(IN) :: IU,NSYS,NTOP,IPER,KPER,ITOPIC
INTEGER,INTENT(INOUT) :: NP
INTEGER,INTENT(IN),DIMENSION(NTOP) :: JTOP
CHARACTER(LEN=*),INTENT(IN) :: EXFNAME
TYPE(IDFOBJ),INTENT(INOUT),DIMENSION(NTOP,NSYS) :: PCK
TYPE(IDFOBJ),INTENT(INOUT),DIMENSION(:) :: BND,TOP,BOT,KD
REAL,INTENT(IN) :: HNOFLOW
REAL :: X,Y,Q,Z1,Z2,FCT,IMP
CHARACTER(LEN=256) :: SFNAME,LINE,ID,CDIR
CHARACTER(LEN=5) :: EXT
CHARACTER(LEN=25) :: FRM
INTEGER :: JU,KU,ILAY,IROW,ICOL,I,ITOP,ISYS,NROWIPF,NCOLIPF,IEXT,MP,IOS,MTYPE,IBATCH
LOGICAL :: LIPF,LISG,LEX
REAL,ALLOCATABLE,DIMENSION(:) :: TLP,KH,TP,BT
INTEGER(KIND=8) :: ITIME,JTIME
PMANAGER_SAVEMF2005_PCK_ULSTRD=.FALSE.
CALL UTL_CREATEDIR(EXFNAME(:INDEX(EXFNAME,'\',.TRUE.)-1))
LIPF=INDEX(EXFNAME,'\WEL7\').GT.0; LISG=INDEX(EXFNAME,'\ISG7\').GT.0
!## fill tlp for each modellayer
ALLOCATE(TLP(NLAY),KH(NLAY),TP(NLAY),BT(NLAY))
!## start- and enddate of simulation period
IF(SIM(IPER)%DELT.EQ.0.0)THEN
MTYPE=1; ITIME=INT(0,8); JTIME=INT(0,8) !## 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
!## ISG not yet supports timescales less than 1 day
SDATE=SIM(IPER)%IYR*10000+SIM(IPER)%IMH*100+SIM(IPER)%IDY
SDATE=UTL_IDATETOJDATE(SDATE)
EDATE=SDATE+MAX(1,INT(SIM(IPER)%DELT))
MTYPE=2 !## median value
ENDIF
IF(LISG)THEN
XMIN=BND(1)%XMIN; YMIN=BND(1)%YMIN
XMAX=BND(1)%XMAX; YMAX=BND(1)%YMAX
ISS=2; IF(SDATE.EQ.0.AND.EDATE.EQ.0)ISS=1
IDIM=0
CS=BND(1)%DX !## cellsize
MINDEPTH=0.1
WDEPTH=0.0
ICDIST=1 !## compute influence of structures
ISIMGRO=0 !## no simgro
IEXPORT=1 !## modflow river files
ROOT=EXFNAME(1:INDEX(EXFNAME,'\',.TRUE.)-1) !## output folder
POSTFIX=''
NODATA=-999.99
ISAVE=1
MAXWIDTH=1000.0
IAVERAGE=1
IBATCH=0
ENDIF
IF(TRIM(EXFNAME(INDEX(EXFNAME,'.',.TRUE.)+1:)).EQ.'ASC')THEN
DO ISYS=1,NSYS
DO ITOP=1,NTOP
SFNAME=UTL_SUBST(EXFNAME,'.ASC',TRIM(ITOS(ISYS))//'_'//TRIM(ITOS(ITOP))//'.ASC')
JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=SFNAME,STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(JU.EQ.0)RETURN
WRITE(JU,'(A14,I10)') 'NCOLS' ,PCK(ITOP,ISYS)%NCOL
WRITE(JU,'(A14,I10)') 'NROWS' ,PCK(ITOP,ISYS)%NROW
WRITE(JU,'(A14,F15.7)') 'XLLCORNER' ,PCK(ITOP,ISYS)%XMIN
WRITE(JU,'(A14,F15.7)') 'YLLCORNER' ,PCK(ITOP,ISYS)%YMIN
WRITE(JU,'(A14,F15.7)') 'CELLSIZE' ,PCK(ITOP,ISYS)%DX
WRITE(JU,'(A14,F15.7)') 'NODATA_VALUE',PCK(ITOP,ISYS)%NODATA
DO IROW=1,PCK(ITOP,ISYS)%NROW; WRITE(JU,*) (PCK(ITOP,ISYS)%X(ICOL,IROW),ICOL=1,PCK(ITOP,ISYS)%NCOL); ENDDO
CLOSE(JU)
ENDDO
ENDDO
ELSE
JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=EXFNAME,STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(JU.EQ.0)RETURN
MP=0
DO ISYS=1,NSYS
FCT =TOPICS(ITOPIC)%STRESS(KPER)%FILES(1,ISYS)%FCT
IMP =TOPICS(ITOPIC)%STRESS(KPER)%FILES(1,ISYS)%IMP
SFNAME=TOPICS(ITOPIC)%STRESS(KPER)%FILES(1,ISYS)%FNAME
!## open isg file
IF(LISG)THEN
!## deallocate memory
CALL ISGDEAL()
NISGFILES=1; IF(ALLOCATED(ISGIU))DEALLOCATE(ISGIU); ALLOCATE(ISGIU(MAXFILES,NISGFILES))
CALL UTL_GETUNITSISG(ISGIU(:,1),SFNAME,'OLD')
IF(MINVAL(ISGIU(:,1)).LE.0)EXIT
!## read complete ISG file
CALL ISGREAD()
!## export isg to riv package
ILAY=PCK(1,ISYS)%ILAY
!## translate again to idate as it will be convered to jdate in next subroutine
SDATE=UTL_JDATETOIDATE(SDATE); EDATE=UTL_JDATETOIDATE(EDATE)-1 !<- edate is equal to sdate if one day is meant
IF(.NOT.ISG2GRID(POSTFIX,BND(1)%NROW,BND(1)%NCOL,NLAY,ILAY,TOP,BOT,IBATCH,MP,JU))EXIT
!## open ipf file
ELSEIF(LIPF)THEN
WRITE(FRM,'(A9,I2.2,A14)') '(3(I5,1X),',1,'(F15.7,1X),I5)'
CDIR=PCK(1,ISYS)%FNAME(:INDEX(PCK(1,ISYS)%FNAME,'\',.TRUE.)-1)
KU=UTL_GETUNIT(); CALL OSD_OPEN(KU,PCK(1,ISYS)%FNAME,STATUS='OLD',ACTION='READ',FORM='FORMATTED'); IF(KU.EQ.0)RETURN
READ(KU,*) NROWIPF; READ(KU,*) NCOLIPF
DO I=1,NCOLIPF; READ(KU,*); ENDDO; READ(KU,*) IEXT,EXT
DO I=1,NROWIPF
ILAY=PCK(1,ISYS)%ILAY
!## assign to several layer
IF(ILAY.EQ.0)THEN
IF(IEXT.EQ.0)THEN
READ(KU,*,IOSTAT=IOS) X,Y,Q,Z1,Z2
ELSE
READ(KU,*,IOSTAT=IOS) X,Y,ID,Z1,Z2
ENDIF
!## get filter fractions
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; KH(ILAY)=KD (ILAY)%X(ICOL,IROW); ENDDO
DO ILAY=1,NLAY; KH(ILAY)=KH(ILAY)/(TP(ILAY)-BT(ILAY)); ENDDO
CALL UTL_PCK_GETTLP(NLAY,TLP,KH,TP,BT,Z1,Z2)
!## find uppermost layer
ELSE
IF(IEXT.EQ.0)THEN
READ(KU,*,IOSTAT=IOS) X,Y,Q
ELSE
READ(KU,*,IOSTAT=IOS) X,Y,ID
ENDIF
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(IOS.NE.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Error reading IPF file'//CHAR(13)//TRIM(PCK(1,ISYS)%FNAME)//CHAR(13)// &
'Linenumber '//TRIM(ITOS(I)),'Error')
CLOSE(JU); CLOSE(KU); RETURN
ENDIF
!## get correct cell-indices
CALL IDFIROWICOL(BND(1),IROW,ICOL,X,Y)
!## outside current model
IF(IROW.EQ.0.OR.ICOL.EQ.0)CYCLE
IF(IEXT.GT.0)THEN
IF(.NOT.UTL_PCK_READTXT(2,ITIME,JTIME,MTYPE,Q,TRIM(CDIR)//'\'//TRIM(ID)//'.'//TRIM(EXT)))THEN
CLOSE(JU); CLOSE(KU); RETURN
ENDIF
ENDIF
!## use factor/impulse
Q=Q*FCT !## use factor
Q=Q+IMP !## use impulse
DO ILAY=1,NLAY
IF(TLP(ILAY).GT.0.0)THEN
WRITE(JU,FRM) ILAY,IROW,ICOL,Q*TLP(ILAY),ISYS
MP=MP+1
ENDIF
ENDDO
ENDDO
CLOSE(KU)
ELSE
WRITE(FRM,'(A9,I2.2,A14)') '(3(I5,1X),',NTOP,'(F15.7,1X),I5)'
DO IROW=1,PCK(1,1)%NROW; DO ICOL=1,PCK(1,1)%NCOL
DO ITOP=1,NTOP; IF(PCK(JTOP(ITOP),ISYS)%X(ICOL,IROW).EQ.HNOFLOW)EXIT; ENDDO
IF(ITOP.LE.NTOP)CYCLE
ILAY=PCK(1,ISYS)%ILAY
!## assign to several layer
IF(ILAY.EQ.0)THEN
!## get filter fractions
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; KH(ILAY)=KD (ILAY)%X(ICOL,IROW); ENDDO
DO ILAY=1,NLAY; KH(ILAY)=KH(ILAY)/(TP(ILAY)-BT(ILAY)); ENDDO
SELECT CASE (ITOPIC)
CASE (22) !## drn
Z1=PCK(2,ISYS)%X(ICOL,IROW); Z2=Z1
CASE (23) !## riv
Z1=PCK(2,ISYS)%X(ICOL,IROW); Z2=PCK(3,ISYS)%X(ICOL,IROW)
CASE (27) !## olf
Z1=PCK(2,ISYS)%X(ICOL,IROW); Z2=Z1
CASE DEFAULT
STOP 'not yet defined!'
END SELECT
CALL UTL_PCK_GETTLP(NLAY,TLP,KH,TP,BT,Z1,Z2)
!## 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
DO ILAY=1,NLAY
!## not put into model layer
IF(TLP(ILAY).LE.0.0)CYCLE
!## single entry eq nodata, skip it
LEX=.TRUE.; DO ITOP=1,NTOP
IF(PCK(ITOP,ISYS)%X(ICOL,IROW).EQ.PCK(ITOP,ISYS)%NODATA)THEN; LEX=.FALSE.; EXIT; ENDIF
ENDDO
IF(.NOT.LEX)CYCLE
!## correct rivers whenever bottom is higher than stage
IF(ITOPIC.EQ.23)PCK(3,ISYS)%X(ICOL,IROW)=MIN(PCK(2,ISYS)%X(ICOL,IROW),PCK(3,ISYS)%X(ICOL,IROW))
WRITE(JU,FRM) ILAY,IROW,ICOL,(PCK(JTOP(ITOP),ISYS)%X(ICOL,IROW),ITOP=1,NTOP),ISYS
MP=MP+1
ENDDO
ENDDO; ENDDO
ENDIF
ENDDO
ENDIF
CLOSE(JU)
DEALLOCATE(TLP,TP,BT,KH)
LINE=TRIM(ITOS(MP)); WRITE(IU,*) TRIM(LINE)
!## storage of maximum number of package elements
NP=MAX(NP,MP)
IF(MP.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
PMANAGER_SAVEMF2005_PCK_ULSTRD=.TRUE.
!## something went wrong
IF(ISYS.LE.NSYS)PMANAGER_SAVEMF2005_PCK_ULSTRD=.FALSE.
END FUNCTION PMANAGER_SAVEMF2005_PCK_ULSTRD
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_PCK_U2DREL(EXFNAME,IDF,IU,HNOFLOW)
!###======================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: EXFNAME
TYPE(IDFOBJ),INTENT(INOUT) :: IDF
REAL,INTENT(IN) :: HNOFLOW
CHARACTER(LEN=256) :: SFNAME
INTEGER,INTENT(IN) :: IU
INTEGER :: JU,IROW,ICOL,I
REAL :: MINV,MAXV
PMANAGER_SAVEMF2005_PCK_U2DREL=.FALSE.
MINV=10.0E10; MAXV=-10.0E10
DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL
IF(IDF%X(ICOL,IROW).NE.HNOFLOW)THEN
MINV=MIN(MINV,IDF%X(ICOL,IROW))
MAXV=MAX(MAXV,IDF%X(ICOL,IROW))
ENDIF
ENDDO; ENDDO
!## constant value
IF(MAXV.EQ.MINV)THEN
WRITE(IU,'(A)') 'CONSTANT '//TRIM(RTOS(MAXV,'E',7))
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:)
WRITE(IU,'(A)') 'OPEN/CLOSE '//TRIM(SFNAME)//' 1.0 (FREE) -1'
JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=EXFNAME,STATUS='UNKNOWN',ACTION='WRITE',FORM='FORMATTED'); IF(JU.EQ.0)RETURN
IF(TRIM(EXFNAME(INDEX(EXFNAME,'.',.TRUE.)+1:)).EQ.'ASC')THEN
WRITE(JU,'(A14,I10)') 'NCOLS' ,IDF%NCOL
WRITE(JU,'(A14,I10)') 'NROWS' ,IDF%NROW
WRITE(JU,'(A14,F15.7)') 'XLLCORNER' ,IDF%XMIN
WRITE(JU,'(A14,F15.7)') 'YLLCORNER' ,IDF%YMIN
WRITE(JU,'(A14,F15.7)') 'CELLSIZE' ,IDF%DX
WRITE(JU,'(A14,F15.7)') 'NODATA_VALUE',IDF%NODATA
ENDIF
DO IROW=1,IDF%NROW; WRITE(JU,*) (IDF%X(ICOL,IROW),ICOL=1,IDF%NCOL); ENDDO
CLOSE(JU)
ENDIF
PMANAGER_SAVEMF2005_PCK_U2DREL=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_PCK_U2DREL
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_HFB(IDF,ITOPIC,IU)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ITOPIC,IU
TYPE(IDFOBJ),INTENT(INOUT) :: IDF
REAL :: FCT,IMP
INTEGER :: ILAY,JLAY,ISYS
INTEGER(KIND=1),ALLOCATABLE,DIMENSION(:,:,:) :: IPC
PMANAGER_SAVEMF2005_HFB=.TRUE.
!## compute block-faces
ALLOCATE(IPC(IDF%NCOL,IDF%NROW,2))
!## process per modellayer
DO ILAY=1,NLAY
IPC=INT(0,1)
DO ISYS=1,SIZE(TOPICS(ITOPIC)%STRESS(1)%FILES,1)
JLAY=TOPICS(ITOPIC)%STRESS(1)%FILES(ISYS,ILAY)%ILAY
IF(JLAY.NE.ILAY)CYCLE
FCT=TOPICS(ITOPIC)%STRESS(1)%FILES(ISYS,ILAY)%FCT
IMP=TOPICS(ITOPIC)%STRESS(1)%FILES(ISYS,ILAY)%IMP
IDF%FNAME=TOPICS(ITOPIC)%STRESS(1)%FILES(ISYS,ILAY)%FNAME
CALL ASC2IDF_INT_GETFACES(IDF,IDF%NROW,IDF%NCOL,IPC,IDF%FNAME)
ENDDO
ENDDO
! !## read/clip/scale idf file
! PMANAGER_SAVEMF2005_HFB=IDFREADSCALE(IDF%FNAME,IDF,SCL_U,SCL_D,1.0,0)
! IF(PMANAGER_SAVEMF2005_HFB)CALL PMANAGER_SAVEMF2005_FCTIMP(IINV,ICNST,IDF,HNOFLOW,FCT,IMP)
DEALLOCATE(IPC)
END FUNCTION PMANAGER_SAVEMF2005_HFB
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_MOD(IDF,ITOPIC,IPER,ISYS,ILAY,SCL_D,SCL_U,HNOFLOW,IINV)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ITOPIC,IPER,ISYS,ILAY,SCL_D,SCL_U,IINV
TYPE(IDFOBJ),INTENT(INOUT) :: IDF
REAL,INTENT(IN) :: HNOFLOW
INTEGER :: ICNST
REAL :: FCT,IMP
PMANAGER_SAVEMF2005_MOD=.TRUE.
FCT =TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISYS,ILAY)%FCT
IMP =TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISYS,ILAY)%IMP
ICNST=TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISYS,ILAY)%ICNST
IF(ICNST.EQ.1)THEN
IDF%X=TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISYS,ILAY)%CNST
ELSEIF(ICNST.EQ.2)THEN
IDF%FNAME=TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISYS,ILAY)%FNAME
!## read/clip/scale idf file
PMANAGER_SAVEMF2005_MOD=IDFREADSCALE(IDF%FNAME,IDF,SCL_U,SCL_D,1.0,0)
ENDIF
IF(PMANAGER_SAVEMF2005_MOD)CALL PMANAGER_SAVEMF2005_FCTIMP(IINV,ICNST,IDF,HNOFLOW,FCT,IMP)
END FUNCTION PMANAGER_SAVEMF2005_MOD
!###======================================================================
LOGICAL FUNCTION PMANAGER_SAVEMF2005_MOD_U2DREL(EXFNAME,IDF,IINT,IU,HNOFLOW)
!###======================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: EXFNAME
TYPE(IDFOBJ),INTENT(INOUT) :: IDF
REAL,INTENT(IN) :: HNOFLOW
CHARACTER(LEN=256) :: SFNAME
INTEGER,INTENT(IN) :: IINT,IU
INTEGER :: JU,IROW,ICOL,I
REAL :: MINV,MAXV
PMANAGER_SAVEMF2005_MOD_U2DREL=.FALSE.
MINV=10.0E10; MAXV=-10.0E10
DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL
IF(IDF%X(ICOL,IROW).NE.HNOFLOW)THEN
MINV=MIN(MINV,IDF%X(ICOL,IROW))
MAXV=MAX(MAXV,IDF%X(ICOL,IROW))
ENDIF
ENDDO; ENDDO
!## constant value
IF(MAXV.EQ.MINV)THEN
IF(IINT.EQ.0)WRITE(IU,'(A)') 'CONSTANT '//TRIM(RTOS(MAXV,'E',7))
IF(IINT.EQ.1)WRITE(IU,'(A)') 'CONSTANT '//TRIM(ITOS(INT(MAXV)))
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(TRIM(EXFNAME(INDEX(EXFNAME,'.',.TRUE.)+1:)).EQ.'ASC')THEN
WRITE(JU,'(A14,I10)') 'NCOLS' ,IDF%NCOL
WRITE(JU,'(A14,I10)') 'NROWS' ,IDF%NROW
WRITE(JU,'(A14,F15.7)') 'XLLCORNER' ,IDF%XMIN
WRITE(JU,'(A14,F15.7)') 'YLLCORNER' ,IDF%YMIN
WRITE(JU,'(A14,F15.7)') 'CELLSIZE' ,IDF%DX
WRITE(JU,'(A14,F15.7)') 'NODATA_VALUE',IDF%NODATA
ENDIF
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)
ENDIF
PMANAGER_SAVEMF2005_MOD_U2DREL=.TRUE.
END FUNCTION PMANAGER_SAVEMF2005_MOD_U2DREL
!###======================================================================
SUBROUTINE PMANAGER_SAVEMF2005_FCTIMP(IINV,ICNST,IDF,HNOFLOW,FCT,IMP)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IINV,ICNST
REAL,INTENT(IN) :: HNOFLOW,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
IF(ICNST.EQ.2.AND.IDF%X(ICOL,IROW).EQ.IDF%NODATA)THEN
IDF%X(ICOL,IROW)=HNOFLOW
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
!###======================================================================
SUBROUTINE PMANAGER_SAVEMF2005_BND(BND,HNOFLOW)
!###======================================================================
IMPLICIT NONE
TYPE(IDFOBJ),INTENT(INOUT) :: BND
REAL,INTENT(IN) :: HNOFLOW
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
DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL
!## blank out inactive cells
IF(BND(ILAY)%X(ICOL,IROW).EQ.0)IDF%X(ICOL,IROW)=IDF%NODATA
!## 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
!## 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 packages on constant head cells
IF(ITYPE.EQ.1)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
END SUBROUTINE PMANAGER_SAVEMF2005_CORRECT
!###======================================================================
SUBROUTINE PMANAGER_GETNLAY()
!###======================================================================
IMPLICIT NONE
INTEGER :: I,J,IPER,ITOPIC
!## get maximal number of layers
MXNLAY=9999
DO ITOPIC=2,12
IF(.NOT.ASSOCIATED(TOPICS(ITOPIC)%STRESS))CYCLE
IF(.NOT.ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))CYCLE
NLAY=-999
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)
NLAY=MAX(NLAY,TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,J)%ILAY)
ENDDO
ENDDO
ENDDO
SELECT CASE (ITOPIC)
!## kvv or vcw
CASE (9,10)
NLAY=NLAY+1
END SELECT
MXNLAY=MIN(MXNLAY,NLAY)
ENDDO
IF(MXNLAY.EQ.9999)MXNLAY=0
END SUBROUTINE PMANAGER_GETNLAY
!###======================================================================
SUBROUTINE PMANAGER_GETNPER(JD1,IHMS1,JD2,IHMS2)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: JD1,IHMS1,JD2,IHMS2
INTEGER :: I,II,J,K,IYR,IMH,IDY,IHR,IMT,ISC,JDP1,JDP2,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
!## check whether a period is available
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(J)%IYR(1)-1
DO II=PERIOD(J)%IYR(1),PERIOD(J)%IYR(2)
IYR=IYR+1
!## construct julian day for start of period
JDP1=JD(IYR,PERIOD(J)%IDY(1),PERIOD(J)%IMH(1))
IF(PERIOD(J)%IMH(2).LT.PERIOD(J)%IMH(1))THEN
IYR=IYR+1
ELSEIF(PERIOD(J)%IMH(1).EQ.PERIOD(J)%IMH(2).AND.PERIOD(J)%IDY(2).LT.PERIOD(J)%IDY(1))THEN
IYR=IYR+1
ENDIF
!## construct julian day for end of period
JDP2=JD(IYR,PERIOD(J)%IDY(2),PERIOD(J)%IMH(2))
ENDDO
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
! !## starttime
! STIME=ITIME(IS)
! !## end time
! ETIME=ITIME(IE)
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(ITIME(I).NE.ITIME(I-1))THEN
NPER=NPER+1; JTIME(NPER)=ITIME(I)
ENDIF
ENDDO
IF(NPER.EQ.0)THEN
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'No stress-periods found in the packages.','Warning')
ELSE
ALLOCATE(SIM(NPER))
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)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IPER,ITOPIC
INTEGER(KIND=8) :: ITIME,JTIME
INTEGER :: KPER
PMANAGER_GETCURRENTIPER=0
!## get appropriate stress-period to store in runfile
IF(SIM(IPER)%DELT.EQ.0.0)THEN !## steady-state
KPER=PMANAGER_GETIPER(IPER,INT(0,8),INT(0,8),TOPICS(ITOPIC)%STRESS)
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
!## previous timestep steady-state
! IF(SIM(IPER+1)%DELT.NE.0.0)THEN
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
! ELSE
! ITIME=JTIME
! ENDIF
KPER=PMANAGER_GETIPER(IPER,ITIME,JTIME,TOPICS(ITOPIC)%STRESS)
ENDIF
PMANAGER_GETCURRENTIPER=KPER
END FUNCTION PMANAGER_GETCURRENTIPER
!###======================================================================
INTEGER FUNCTION PMANAGER_GETIPER(IPER,STIME,ETIME,STRESS)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IPER
INTEGER(KIND=8),INTENT(IN) :: STIME,ETIME
TYPE(STRESSOBJ),INTENT(IN),DIMENSION(:) :: STRESS
INTEGER :: I,J,ID
INTEGER(KIND=8) :: PTIME,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=10E10; 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
! IYR=PERIOD(J)%IYR(1); IMH=PERIOD(J)%IMH(1); IDY=PERIOD(J)%IDY(1)
! IHR=PERIOD(J)%IHR(1); IMT=PERIOD(J)%IMT(1); ISC=PERIOD(J)%ISC(1)
! ITIME=IYR*10000000000+IMT*100000000+IDY*1000000+IHR*10000+IMT*100+ISC
! IYR=PERIOD(J)%IYR(2); IMH=PERIOD(J)%IMH(2); IDY=PERIOD(J)%IDY(2)
! IHR=PERIOD(J)%IHR(2); IMT=PERIOD(J)%IMT(2); ISC=PERIOD(J)%ISC(2)
! JTIME=IYR*10000000000+IMT*100000000+IDY*1000000+IHR*10000+IMT*100+ISC
! !## loop over years
! IYR=PERIOD(J)%IYR(1)-1
! DO K=PERIOD(J)%IYR(1),PERIOD(J)%IYR(2)
! IYR=IYR+1
! !## construct julian day for start of period
! JDP1=JD(IYR,PERIOD(J)%IDY(1),PERIOD(J)%IMH(1))
! IF(PERIOD(J)%IMH(2).LT.PERIOD(J)%IMH(1))THEN
! IYR=IYR+1
! ELSEIF(PERIOD(J)%IMH(1).EQ.PERIOD(J)%IMH(2).AND.PERIOD(J)%IDY(2).LT.PERIOD(J)%IDY(1))THEN
! IYR=IYR+1
! ENDIF
! !## construct julian day for end of period
! JDP2=JD(IYR,PERIOD(J)%IDY(2),PERIOD(J)%IMH(2))
! IF(JD2.GE.JDP1.AND.JD2.LE.JDP2)THEN
! !## if inside period, set equal to start of period
! JDI=JDP1; EXIT
! ELSE
! !## if outside, set equal to stressperiod+1
! JDI=JD2+1
! ENDIF
! ENDDO
ELSE
!## package time
PTIME=STRESS(I)%IYR*10000000000+STRESS(I)%IMH*100000000+STRESS(I)%IDY*1000000+STRESS(I)%IHR*10000+STRESS(I)%IMT*100+STRESS(I)%ISC
ENDIF
!## outside (appears to be later) current time-window
IF(PTIME.GE.ETIME)CYCLE
!## defined at the same period as the current timestep
IF(STIME.EQ.PTIME)THEN; ID=I; EXIT; ENDIF
!## get closest defined before current timestep
IF(STIME.GT.PTIME)THEN
!## closer than what we had already
IF(STIME-PTIME.LE.MD)THEN; MD=STIME-PTIME; ID=-I; ENDIF
ENDIF
ENDDO
ENDIF
!## nothing found
IF(ID.EQ.0)THEN
PMANAGER_GETIPER=0
!## use previous input
ELSEIF(ID.LT.0)THEN
!## cannot use -1 for first timestep
IF(IPER.EQ.1)THEN
PMANAGER_GETIPER=ABS(ID)
ELSE
PMANAGER_GETIPER=-1
ENDIF
!## number of systems for current stress period
ELSE
PMANAGER_GETIPER=ID
ENDIF
END FUNCTION PMANAGER_GETIPER
!###======================================================================
LOGICAL FUNCTION PMANAGER_INITSIM(FNAME)
!###======================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(OUT) :: FNAME
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
TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: IDF
LOGICAL :: LEX
PMANAGER_INITSIM=.FALSE.
CALL WDIALOGLOAD(ID_DPMANAGER_SIM,ID_DPMANAGER_SIM)
!## default packages
CALL WDIALOGPUTMENU(IDF_MENU4,TMENU1,SIZE(TMENU1),8)
!## inherit
CALL WDIALOGPUTMENU(IDF_MENU5,TMENU2,SIZE(TMENU2),9)
CALL PMANAGER_GETNLAY()
CALL WDIALOGPUTINTEGER(IDF_INTEGER1,MXNLAY)
CALL WDIALOGRANGEINTEGER(IDF_INTEGER1,1,MXNLAY)
ISTEADY=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
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
ELSEIF(IDATE.GT.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
DO K=1,2
IYR=PERIOD(J)%IYR(K); IMH=PERIOD(J)%IMH(K); IDY=PERIOD(J)%IDY(K)
IHR=PERIOD(J)%IHR(K); IMT=PERIOD(J)%IMT(K); ISC=PERIOD(J)%ISC(K)
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
ELSEIF(IDATE.GT.MAXJD)THEN
MAXJD=MAX(MAXJD,IDATE); IF(IHMS.GT.MAXHMS)MAXHMS=IHMS
ENDIF
ENDDO
ELSE
CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Can not convert date ['//TRIM(TOPICS(ITOPIC)%STRESS(IPER)%CDATE)//'] for'//CHAR(13)// &
'Topic '//TRIM(TOPICS(ITOPIC)%TNAME),'Warning')
ENDIF
ENDIF
ENDIF
ENDDO
ENDDO
!## no transient data found
IF(MINJD.GT.MAXJD.AND.MINHMS.GT.MAXHMS)THEN
IF(ISTEADY.EQ.0)CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'No steady-state or transient data found','Warning')
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
I=0
IF(ASSOCIATED(TOPICS(2)%STRESS).AND.ASSOCIATED(TOPICS(3)%STRESS).AND.ASSOCIATED(TOPICS(7)%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))I=1 !## khv
ENDIF
CALL WDIALOGFIELDSTATE(IDF_CHECK1,I) !## iunconf
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))THEN
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
J=1
IF(NLAY.GT.1)THEN
IF(ASSOCIATED(TOPICS(10)%STRESS))THEN
IF(.NOT.ASSOCIATED(TOPICS(10)%STRESS(1)%FILES))J=0 !## kvv
ELSE
J=0
ENDIF
ENDIF
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 (a) convert to BCF6 or (b) convert to LPF package','Warning')
CALL WDIALOGUNLOAD(); RETURN
ENDIF
ALLOCATE(IDF(1)); CALL IDFNULLIFY(IDF(1))
IF(.NOT.IDFREAD(IDF(1),TOPICS(4)%STRESS(1)%FILES(1,1)%FNAME,0))THEN
CALL IDFDEALLOCATE(IDF,SIZE(IDF)); DEALLOCATE(IDF); RETURN
ENDIF
CALL WDIALOGPUTREAL(IDF_REAL5,IDF(1)%DX,'(G15.7)')
CALL IDFDEALLOCATE(IDF,SIZE(IDF)); DEALLOCATE(IDF)
!## modflow2005 does not allow thickness of zero
CALL WDIALOGPUTREAL(IDF_REAL6,MINTHICKNESS,'(G15.7)')
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 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,IDF_RADIO4,IDF_CHECK3,IDF_CHECK1,IDF_INTEGER1)
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_SIMCUSTOMIZE,ID_SAVECUSTOMIZE)
CALL PMANAGER_TIMESTEPS(MESSAGE%VALUE1)
CASE (ID_PACKAGE)
CALL PMANAGER_INITSIM_PACKAGES()
CALL PMANAGER_INITSIM_FIELDS()
CASE (IDOK)
!## 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))//'\RUNFILES\MF2005')
FNAME=TRIM(PREFVAL(1))//'\RUNFILES\MF2005\*.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
!## apply submodelling
CALL WDIALOGGETCHECKBOX(IDF_CHECK3,ISUBMODEL)
SUBMODEL=0.0; IF(ISUBMODEL.EQ.1)THEN
CALL WDIALOGGETREAL(IDF_REAL1,SUBMODEL(1))
CALL WDIALOGGETREAL(IDF_REAL2,SUBMODEL(2))
CALL WDIALOGGETREAL(IDF_REAL3,SUBMODEL(3))
CALL WDIALOGGETREAL(IDF_REAL4,SUBMODEL(4))
CALL WDIALOGGETREAL(IDF_REAL5,SUBMODEL(5))
ENDIF
CALL WDIALOGGETREAL(IDF_REAL6,MINTHICKNESS)
!## number of modellayers
CALL WDIALOGGETINTEGER(IDF_INTEGER1,NLAY)
!## apply unconfinedness
CALL WDIALOGGETCHECKBOX(IDF_CHECK1,IUNCONF)
!## 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.
!## number of modellayers
CALL WDIALOGGETSTRING(IDF_STRING1,MODELNAME)
CALL WDIALOGUNLOAD(); IF(MESSAGE%VALUE1.EQ.IDCANCEL)RETURN
PMANAGER_INITSIM=.TRUE.
END FUNCTION PMANAGER_INITSIM
!###======================================================================
SUBROUTINE PMANAGER_TIMESTEPS(ID)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ID
INTEGER :: ITYPE
TYPE(WIN_MESSAGE) :: MESSAGE
INTEGER :: DID,I,IROW,IROW1,IROW2
!## 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)
IF(ID.EQ.ID_SIMCUSTOMIZE)THEN
CALL WDIALOGTITLE('Time Discretization Manager for Simulation')
ELSEIF(ID.EQ.ID_SAVECUSTOMIZE)THEN
CALL WDIALOGTITLE('Time Discretization Manager for Saving')
ENDIF
CALL PMANAGER_PUTTIMEINGRID()
CALL WDIALOGFIELDOPTIONS(IDF_INTEGER1,EDITFIELDCHANGED,1)
CALL WDIALOGFIELDOPTIONS(IDF_INTEGER2,EDITFIELDCHANGED,1)
CALL WGRIDCOLOURCELL(IDF_GRID1,1,1,-1,WRGB(255,0,0))
CALL WDIALOGSHOW(-1,-1,0,3)
DO
CALL WMESSAGE(ITYPE,MESSAGE)
SELECT CASE (ITYPE)
CASE(FIELDCHANGED)
SELECT CASE (MESSAGE%VALUE2)
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_APPLY)
CALL WDIALOGGETMENU(IDF_MENU1,I)
CALL PMANAGER_INSERTTIMES(IROW1,IROW2,I)
CASE (ID_SAVE,ID_OPEN)
CALL PMANAGER_SAVETIMESTEPS(MESSAGE%VALUE1)
CASE (IDOK)
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_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 WDIALOGRANGEINTEGER(IDF_INTEGER1,1,NPER)
CALL WDIALOGRANGEINTEGER(IDF_INTEGER2,1,NPER)
CALL WDIALOGPUTINTEGER(IDF_INTEGER1,1)
CALL WDIALOGPUTINTEGER(IDF_INTEGER2,1)
CALL WGRIDCOLOURCOLUMN(IDF_GRID1,1,-1,-1)
CALL WGRIDCOLOURCELL(IDF_GRID1,1,1,-1,WRGB(255,0,0))
END SUBROUTINE PMANAGER_PUTTIMEINGRID
!###======================================================================
SUBROUTINE PMANAGER_INSERTTIMES(IROW1,IROW2,IPERIOD)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IROW1,IROW2,IPERIOD
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)
!## create new timesteps in between
ALLOCATE(SIM(100))
CALL PMANAGER_ASSIGNTIMESTEPS(1,2,JD1,JD2,IHMS1,IHMS2,IPERIOD)
J=NPER+SIZE(SIM_C2)-((IR2-IR1)+1); ALLOCATE(ITIME(J))
!## fill in previous timesteps before ir1
J=0; DO I=1,IR1-1
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
IF(I.EQ.1)STIME=ITIME(J)
ENDDO
!## fill in previous timesteps after ir2
DO I=IR2+1,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
IF(I.EQ.SIZE(SIM_C2))ETIME=ITIME(J)
ENDDO
!## 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()
!## put in the menu
CALL PMANAGER_PUTTIMEINGRID()
END SUBROUTINE PMANAGER_INSERTTIMES
!###======================================================================
SUBROUTINE PMANAGER_ASSIGNTIMESTEPS(I1,I2,JD1,JD2,IHMS1,IHMS2,IPERIOD)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: I1,I2,IPERIOD,JD1,JD2,IHMS1,IHMS2
INTEGER :: I
!## 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)
!## fill in intermediate timesteps
SELECT CASE (IPERIOD)
CASE (1) !## hourly
I=I2; DO; I=I+1; IF(.NOT.PMANAGER_ADDTIMESTEP(I,I1, 1,4))EXIT; ENDDO; NPER=I
CASE (2) !## daily
I=I2; DO; I=I+1; IF(.NOT.PMANAGER_ADDTIMESTEP(I,I1, 1,3))EXIT; ENDDO; NPER=I
CASE (3) !## weekly
I=I2; DO; I=I+1; IF(.NOT.PMANAGER_ADDTIMESTEP(I,I1, 7,3))EXIT; ENDDO; NPER=I
CASE (4) !## decade
I=I2; DO; I=I+1; IF(.NOT.PMANAGER_ADDTIMESTEP(I,I1,10,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, 1,2))EXIT; ENDDO; NPER=I
CASE (7) !## yearly
I=I2; DO; I=I+1; IF(.NOT.PMANAGER_ADDTIMESTEP(I,I1, 1,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
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)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: ID
INTEGER :: I,N,IOS,IU
CHARACTER(LEN=256) :: FNAME,LINE
IF(ID.EQ.ID_OPEN)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
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))
NPER=1; DO
READ(IU,*,IOSTAT=IOS) SIM(NPER)%CDATE,SIM(NPER)%DELT,SIM(NPER)%ISAVE
IF(IOS.NE.0)EXIT
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
!## make sure lenght 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
CALL PMANAGER_COMPUTEDELT()
!## put in the menu
CALL PMANAGER_PUTTIMEINGRID()
CLOSE(IU)
ELSEIF(ID.EQ.ID_SAVE)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
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)
LINE=TRIM(SIM(I)%CDATE)//','//TRIM(RTOS(SIM(I)%DELT,'F',7))//','//TRIM(ITOS(SIM(I)%ISAVE))
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
PMANAGER_FILLTIMESTEPS=.FALSE.
!## get timestep configurations
CALL WDIALOGGETMENU(IDF_MENU4,IPERIOD)
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))
CALL PMANAGER_ASSIGNTIMESTEPS(1,2,JD1,JD2,IHMS1,IHMS2,IPERIOD)
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
NPER=NPER+1
ENDIF
ELSE
NPER=1; ALLOCATE(SIM(1))
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
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)CYCLE
!## 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
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
CHARACTER(LEN=256) :: STRING
CALL WDIALOGGETCHECKBOX(IDF_CHECK1,I)
IF(I.EQ.1)THEN; CALL WDIALOGPUTSTRING(IDF_LABEL12,'Model will simulate transmissivity as a function of head.')
ELSE; CALL WDIALOGPUTSTRING(IDF_LABEL12,''); ENDIF
CALL WDIALOGGETINTEGER(IDF_INTEGER1,I)
IF(I.LT.MXNLAY)THEN; CALL WDIALOGPUTSTRING(IDF_LABEL13,'Model layer '//TRIM(ITOS(I))//' is simulated by a constant head boundary.')
ELSE; CALL WDIALOGPUTSTRING(IDF_LABEL13,'')
ENDIF
STRING='Active: '
DO I=1,SIZE(TOPICS); IF(TOPICS(I)%IACT_MODEL.EQ.1)STRING=TRIM(STRING)//'; '//TOPICS(I)%TNAME(2:4); ENDDO
CALL WDIALOGPUTSTRING(IDF_LABEL21,TRIM(STRING))
CALL WDIALOGGETCHECKBOX(IDF_CHECK3,I)
CALL WDIALOGFIELDSTATE(IDF_REAL1,I)
CALL WDIALOGFIELDSTATE(IDF_REAL2,I)
CALL WDIALOGFIELDSTATE(IDF_REAL3,I)
CALL WDIALOGFIELDSTATE(IDF_REAL4,I)
CALL WDIALOGFIELDSTATE(IDF_REAL5,I)
CALL WDIALOGFIELDSTATE(IDF_LABEL9,I)
CALL WDIALOGFIELDSTATE(IDF_LABEL10,I)
CALL WDIALOGFIELDSTATE(IDF_LABEL11,I)
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_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,I); I=I-1
CALL WDIALOGFIELDSTATE(IDF_REAL6,I)
CALL WDIALOGFIELDSTATE(IDF_LABEL14,I)
CALL WDIALOGFIELDSTATE(IDF_LABEL22,I)
CALL WDIALOGFIELDSTATE(IDF_RADIO7,I)
CALL WDIALOGFIELDSTATE(IDF_RADIO8,I)
CALL WDIALOGFIELDSTATE(IDF_STRING1,ABS(I-1))
CALL WDIALOGFIELDSTATE(IDF_LABEL8,I)
IF(LBCF)CALL WDIALOGFIELDSTATE(IDF_RADIO5,I)
IF(LLPF)CALL WDIALOGFIELDSTATE(IDF_RADIO6,I)
END SUBROUTINE PMANAGER_INITSIM_FIELDS
!###======================================================================
LOGICAL FUNCTION PMANAGER_GETKEYS(IU)
!###======================================================================
IMPLICIT NONE
INTEGER,INTENT(IN) :: IU
INTEGER :: I,J,IOS
CHARACTER(LEN=256) :: LINE
PMANAGER_GETKEYS=.FALSE.
DO I=1,SIZE(TOPICS); CALL PMANAGER_DEALLOCATE(I); ENDDO
READ(IU,*,IOSTAT=IOS); IF(IOS.NE.0)RETURN
READ(IU,*,IOSTAT=IOS) NLAY,NLAY,NPER; IF(IOS.NE.0)RETURN
!## 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(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=256) :: LINE
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
!## 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,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
DEALLOCATE(TOPICS(ITOPIC)%STRESS(IPER)%FILES)
DEALLOCATE(TOPICS(ITOPIC)%STRESS)
ENDIF
!## 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
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
CHARACTER(LEN=52) :: CNAME
CALL WDIALOGSELECT(ID_DPMANAGER)
CALL WDIALOGGETTREEVIEW(ID_TREEVIEW1,ID,CNAME)
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_OPEN,I)
! !#not able to remove main-topics
! DO J=1,MAXTOPICS
! IF(ID.EQ.TOPICS(J)%ID)I=0
! END DO
! CALL WDIALOGFIELDSTATE(ID_DELETE,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(WINTERACTER9))
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
STRING=TRIM(STRING)//'ilay='//TRIM(ITOS(TOPICS(I)%STRESS(IPER)%FILES(J,K)%ILAY))
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) !TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ALIAS)
! STRING=TRIM(STRING)//';idf='//TRIM(TOPICS(I)%STRESS(IPER)%FILES(J,K)%ALIAS)
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))
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(WINTERACTER9))
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 ='(MSP) MetaSwap [UZF]'
TOPICS(2)%TNAME ='(TOP) Top Elevation [DIS]'
TOPICS(3)%TNAME ='(BOT) Bottom Elevation [DIS]'
TOPICS(4)%TNAME ='(BND) Boundary Condition [BAS]'
TOPICS(5)%TNAME ='(SHD) Starting Heads [BAS]'
TOPICS(6)%TNAME ='(KDW) Transmissivity [BCF/LPF]'
TOPICS(7)%TNAME ='(KHV) Horizontal Permeability [BCF/LPF]'
TOPICS(8)%TNAME ='(KVA) Vertical Anisotropy [LPF]'
TOPICS(9)%TNAME ='(VCW) Vertical Resistance [LPF]'
TOPICS(10)%TNAME='(KVV) Vertical Permeability [BCF/LPF]'
TOPICS(11)%TNAME='(STO) Storage Coefficient [BCF/LPF]'
TOPICS(12)%TNAME='(SSC) Secundary Storage Coefficient [BCF/LPF]'
TOPICS(13)%TNAME='(PWT) Perched Water Table [-]'
TOPICS(14)%TNAME='(ANI) Anisotropy [LPF]'
TOPICS(15)%TNAME='(HFB) Horizontal Flow Boundary [HFB]'
TOPICS(16)%TNAME='(IBS) Interbed Storage [IBS]'
TOPICS(17)%TNAME='(CON) Concentration [-]'
TOPICS(18)%TNAME='(SFT) StreamFlow Thickness [-]'
TOPICS(19)%TNAME='(CPP) Common Pointer Package [-]'
TOPICS(20)%TNAME='(PST) Parameter Estimation [-]'
TOPICS(21)%TNAME='(WEL) Wells [WEL]'
TOPICS(22)%TNAME='(DRN) Drainage [DRN]'
TOPICS(23)%TNAME='(RIV) Rivers [RIV]'
TOPICS(24)%TNAME='(EVT) Evapotranspiration [EVT]'
TOPICS(25)%TNAME='(GHB) General Head Boundary [GHB]'
TOPICS(26)%TNAME='(RCH) Recharge [RCH]'
TOPICS(27)%TNAME='(OLF) Overland Flow [DRN]'
TOPICS(28)%TNAME='(CHD) Constant Head Boundary [CHD]'
TOPICS(29)%TNAME='(ISG) iMOD SeGment Rivers [-]'
!TOPICS(30)%TNAME='(SCR) Subsidence [SWT]'
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=2 !SSC
TOPICS(13)%NSUBTOPICS=6 !PWT
TOPICS(14)%NSUBTOPICS=2 !ANI
TOPICS(15)%NSUBTOPICS=1 !HFB
TOPICS(16)%NSUBTOPICS=4 !IBS
TOPICS(17)%NSUBTOPICS=1 !CON
TOPICS(18)%NSUBTOPICS=2 !SFT
TOPICS(19)%NSUBTOPICS=1 !CPP
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 !SUB
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. !CON
TOPICS(18)%TIMDEP=.FALSE. !SFT
TOPICS(19)%TIMDEP=.FALSE. !CPP
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(1)%SNAME(1) ='Boundary (IDF)'
TOPICS(1)%SNAME(2) ='Landuse (IDF)'
TOPICS(1)%SNAME(3) ='Rootzone (IDF)'
TOPICS(1)%SNAME(4) ='Soiltype (IDF)'
TOPICS(1)%SNAME(5) ='Meteostation (IDF)'
TOPICS(1)%SNAME(6) ='Surfacelevel (IDF)'
TOPICS(1)%SNAME(7) ='Artificial discharge (IDF)'
TOPICS(1)%SNAME(8) ='Artificial layer (IDF)'
TOPICS(1)%SNAME(9) ='Artificial location'
TOPICS(1)%SNAME(10)='Wetted Rural Area (IDF)'
TOPICS(1)%SNAME(11)='Wetted Urban Area (IDF)'
TOPICS(1)%SNAME(12)='Pondingdepth Urban Area (IDF)'
TOPICS(1)%SNAME(13)='Pondingdepth Rural Area (IDF)'
TOPICS(1)%SNAME(14)='Runoff Resistance Urban Area (IDF)'
TOPICS(1)%SNAME(15)='Runoff Resistance Rural Area (IDF)'
TOPICS(1)%SNAME(16)='Runon Resistance Urban Area (IDF)'
TOPICS(1)%SNAME(17)='Runon Resistance Rural Area (IDF)'
TOPICS(1)%SNAME(18)='Infiltration Capacity Urban Area (IDF)'
TOPICS(1)%SNAME(19)='Infiltration Capacity Rural Area (IDF)'
TOPICS(1)%SNAME(20)='Purgewater Depth (IDF)'
TOPICS(1)%SNAME(21)='Soil Moisture Factor (IDF)'
TOPICS(1)%SNAME(22)='Soild Permeability Factor (IDF)'
TOPICS(2)%SNAME(1) ='Top of Modellayer (IDF)'
TOPICS(3)%SNAME(1) ='Bottom of Modellayer (IDF)'
TOPICS(4)%SNAME(1) ='Boundary Settings (IDF)'
TOPICS(5)%SNAME(1) ='Starting Heads (IDF)'
TOPICS(6)%SNAME(1) ='Transmissivity (IDF)'
TOPICS(7)%SNAME(1) ='Horizontal Permeability (IDF)'
TOPICS(8)%SNAME(1) ='Vertical Anisotropy (IDF)'
TOPICS(9)%SNAME(1) ='Vertical Resistance (IDF)'
TOPICS(10)%SNAME(1)='Vertical Permeability (IDF)'
TOPICS(11)%SNAME(1)='Storage Coefficient (IDF)'
TOPICS(12)%SNAME(1)='Unconfined Storage Coefficient (IDF)'
TOPICS(12)%SNAME(2)='Confined Storage Coefficient (IDF)'
TOPICS(13)%SNAME(1)='Layer Identification (IDF)'
TOPICS(13)%SNAME(2)='Phreatic Storage Coefficient (IDF)'
TOPICS(13)%SNAME(3)='Top of Aquifer above PWT-layer (IDF)'
TOPICS(13)%SNAME(4)='Top of Aquitard PWT-layer (IDF)'
TOPICS(13)%SNAME(5)='Top of Aquifer beneath PWT-layer (IDF)'
TOPICS(13)%SNAME(6)='Vertical Resistance of PWT-clay (IDF)'
TOPICS(14)%SNAME(1)='Factor (IDF)'
TOPICS(14)%SNAME(2)='Angle (IDF)'
TOPICS(15)%SNAME(1)='Horizontal Barrier Flow (GEN)'
TOPICS(16)%SNAME(1)='Preconsolidation Head (IDF)'
TOPICS(16)%SNAME(2)='Elastic Storage Coefficient (IDF)'
TOPICS(16)%SNAME(3)='Inelastic Storage Coefficient (IDF)'
TOPICS(16)%SNAME(4)='Starting Compaction (IDF)'
TOPICS(17)%SNAME(1)='Concentration (IDF)'
TOPICS(18)%SNAME(1)='Stream Flow Thickness (IDF)'
TOPICS(18)%SNAME(2)='Permeability (IDF)'
TOPICS(19)%SNAME(1)='Common Pointer (IDF)'
TOPICS(20)%SNAME(1)='Parameters Estimation Parameters'
TOPICS(21)%SNAME(1)='Well Rate (IPF)'
TOPICS(22)%SNAME(1)='Conductance (IDF)'
TOPICS(22)%SNAME(2)='Drainage Level (IDF)'
TOPICS(23)%SNAME(1)='Conductance (IDF)'
TOPICS(23)%SNAME(2)='River Level (IDF)'
TOPICS(23)%SNAME(3)='Riverbottom Level (IDF)'
TOPICS(23)%SNAME(4)='Infiltration Factor (IDF)'
TOPICS(24)%SNAME(1)='Evapotranspiration Rate (IDF)'
TOPICS(24)%SNAME(2)='Surface Level (IDF)'
TOPICS(24)%SNAME(3)='Extinction Depth (IDF)'
TOPICS(25)%SNAME(1)='Conductance (IDF)'
TOPICS(25)%SNAME(2)='Reference Level (IDF)'
TOPICS(26)%SNAME(1)='Recharge Rate (IDF)'
TOPICS(27)%SNAME(1)='Overland Flow Level (IDF)'
TOPICS(28)%SNAME(1)='Constant Head (IDF)'
TOPICS(29)%SNAME(1)='Segment River (ISG)'
CALL WDIALOGLOAD(ID_DPMANAGER)
CALL WDIALOGPUTIMAGE(ID_OPEN,ID_ICONOPEN,1)
CALL WDIALOGPUTIMAGE(ID_SAVE,ID_ICONSAVE,1)
CALL WDIALOGPUTIMAGE(ID_PROPERTIES,ID_ICONPROPERTIES,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
CALL PMANAGERUPDATE(0,0,0)
CALL PMANAGERFIELDS()
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)
END SUBROUTINE PMANAGER_DEALLOCATE
!#####=================================================================
INTEGER FUNCTION PMANAGER_FIND_KEYWORD(LINE)
!#####=================================================================
IMPLICIT NONE
CHARACTER(LEN=*),INTENT(IN) :: LINE
INTEGER :: I,J
CHARACTER(LEN=3) :: CKEY
PMANAGER_FIND_KEYWORD=0
I=INDEX(LINE,'('); J=INDEX(LINE,')')
IF(I.EQ.0.OR.J.EQ.0)RETURN; IF(J-I.NE.4)RETURN
CKEY=LINE(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
!#####=================================================================
SUBROUTINE PMANAGERCLOSE()
!#####=================================================================
IMPLICIT NONE
CALL WINDOWSELECT(0); CALL WMENUSETSTATE(ID_PMANAGER,2,0)
CALL WDIALOGSELECT(ID_DPMANAGER); CALL WDIALOGHIDE()
END SUBROUTINE PMANAGERCLOSE
END MODULE