!! Copyright (C) Stichting Deltares, 2005-2022. !! !! 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 ! !$OMP PARALLEL PRIVATE(J,H1,H2,W,TS) SHARED (S,MSR,DF1) ! !$OMP DO ! !$OMP END DO ! !$OMP CRITICAL ! !$OMP END CRITICAL ! !$OMP END PARALLEL #if(defined(DEFPARALLEL)) USE OMP_LIB #endif USE WINTERACTER USE RESOURCE USE IMODVAR USE MOD_UTL USE MOD_IDF USE MOD_OSD USE MOD_PMANAGER_PAR USE MOD_PMANAGER_UTL USE MOD_PMANAGER_MF2005 USE MOD_MANAGER_UTL USE MOD_PMANAGER_WQ USE MOD_PMANAGER_MF6NETWORK USE MOD_IPEST_GLM_PAR, ONLY : MSR,IUPESTOUT,IUPESTPROGRESS,IUPESTEFFICIENCY,IUPESTSENSITIVITY,IUPESTRUNFILE,IUPESTJACOBIAN,LAMBDAS USE MOD_MATH_MERGE USE MOD_MATH_MERGE_PAR USE MOD_IDFPLOT USE MODPLOT USE DATEVAR USE MOD_PKS, ONLY : PKS7MPIPARTDEF,PKS7MPISETGNODES USE MOD_IPEST_GLM, ONLY : IPEST_GLM_MAIN,IPEST_GLM_RESET_PARAMETER,IPEST_GLM_CREATE_RESIDUALSFILES,IPEST_GLM_SETGROUPS, & IPEST_LUBACKSUB_DBL,IPEST_LUDECOMP_DBL,IPEST_GLM_EIGDECOM,IPEST_GLM_DEALLOCATEMSR,IPEST_GLM_ALLOCATEMSR, & IPEST_GLM_GRADIENT,IPEST_GLM_CHK,IPEST_GLM_WRITEHEADER,IPEST_GLM_ECHO_PARAMETERS,IPEST_GLM_CLOSE_FILES,PEST_GLM_ADD_BATCHFILES USE MOD_IPEST_IES, ONLY : IPEST_IES_MAIN USE MOD_POLYGON_PAR, ONLY : SHP CHARACTER(LEN=256),POINTER,DIMENSION(:,:),PRIVATE :: FILES CHARACTER(LEN=256),DIMENSION(:,:),POINTER,PRIVATE :: FILES_BU INTEGER,PARAMETER :: NWAIT=5 INTEGER,ALLOCATABLE,DIMENSION(:),PRIVATE :: IMODEL,IWORKER CONTAINS !###====================================================================== SUBROUTINE PMANAGERMAIN(ITYPE,MESSAGE) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ITYPE TYPE(WIN_MESSAGE),INTENT(IN) :: MESSAGE INTEGER :: I,J SELECT CASE (MESSAGE%WIN) CASE (ID_DPMANAGER) SELECT CASE (ITYPE) CASE (TABCHANGED) !## new tabview selected IF(MESSAGE%VALUE2.EQ.ID_DPMANAGER_TAB1)THEN CALL PMANAGER_UTL_UPDATE_TREEVIEW(0,0,0) CALL WDIALOGSELECT(ID_DPMANAGER) CALL WDIALOGFIELDSTATE(ID_DRAW,1) CALL WDIALOGFIELDSTATE(ID_DRAW2,1) CALL WDIALOGFIELDSTATE(ID_PROPERTIES,1) CALL WDIALOGFIELDSTATE(ID_PROPERTIES_AUTO,1) CALL WDIALOGFIELDSTATE(ID_CALC,0) ENDIF IF(MESSAGE%VALUE2.EQ.ID_DPMANAGER_TAB2)THEN CALL WDIALOGSELECT(ID_DPMANAGER) CALL WDIALOGFIELDSTATE(ID_DRAW,0) CALL WDIALOGFIELDSTATE(ID_DRAW2,0) CALL WDIALOGFIELDSTATE(ID_PROPERTIES,0) CALL WDIALOGFIELDSTATE(ID_PROPERTIES_AUTO,0) CALL WDIALOGFIELDSTATE(ID_CALC,0) ENDIF CASE (PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (ID_CLEAN) IF(UTL_PMANAGER_REFRESH(1))CALL PMANAGER_UTL_UPDATE_TREEVIEW(0,0,0) CASE (ID_DELETE) CALL PMANAGER_DELETE() !## open PRJ file CASE (ID_OPEN) IF(UTL_PMANAGER_REFRESH(1))THEN !## not loaded in correctly, clean it IF(.NOT.PMANAGERPRJ(MESSAGE%VALUE1,'',0,1))THEN IF(UTL_PMANAGER_REFRESH(1))THEN; ENDIF ENDIF CALL PMANAGER_UTL_UPDATE_TREEVIEW(0,0,0); ENDIF !## save PRJ file CASE (ID_SAVE) IF(PMANAGERPRJ(MESSAGE%VALUE1,'',0,1))THEN; ENDIF !## open RUN file CASE (ID_OPENRUN) IF(UTL_PMANAGER_REFRESH(1))THEN IF(PMANAGERRUN(MESSAGE%VALUE1,'',0))THEN !IF(UTL_PMANAGER_REFRESH(1))THEN; ENDIF ENDIF CALL PMANAGER_UTL_UPDATE_TREEVIEW(0,0,0) ENDIF !## SAVE RUN file. Actually start Simulation Manager CASE (ID_SAVERUN) IF(PMANAGERRUN(MESSAGE%VALUE1,'',0))THEN; ENDIF !## copy PRJ data file(s) to iMOD Manager CASE (ID_DRAW) CALL PMANAGERDRAW() !## special Open option CASE (ID_DRAW2) CALL PMANAGERDRAW_PLUS() CASE (ID_PROPERTIES) CALL PMANAGEROPEN() CASE (ID_PROPERTIES_AUTO) CALL PMANAGEROPEN_AUTOMATIC() CASE (ID_CALC) CALL PMANAGER_CALC() CASE (IDCANCEL) CALL PMANAGER_UTL_CLOSE() CASE (IDHELP) CALL UTL_GETHELP('*','VMO.iMODProjMan') END SELECT END SELECT !## treeview CASE (ID_DPMANAGER_TAB1) SELECT CASE (ITYPE) CASE (FIELDCHANGED) SELECT CASE (MESSAGE%VALUE1) CASE (ID_TREEVIEW1) CALL PMANAGERFIELDS() END SELECT END SELECT !## dropdown view CASE (ID_DPMANAGER_TAB2) SELECT CASE (ITYPE) CASE (FIELDCHANGED) SELECT CASE (MESSAGE%VALUE1) CASE (IDF_GRID1) CALL WDIALOGSELECT(ID_DPMANAGER_TAB2); CALL WDIALOGGETMENU(IDF_MENU1,I) J=SIZE(MC(I)%IACT); CALL WGRIDGETCHECKBOX(IDF_GRID1,2,MC(I)%IACT,J) ! CASE (IDF_MENU1) END SELECT SELECT CASE (MESSAGE%VALUE2) CASE (IDF_MENU1) !## model configuration Menu CALL PMANAGEROPEN_LISTITEMS() END SELECT END SELECT END SELECT END SUBROUTINE PMANAGERMAIN !###====================================================================== SUBROUTINE PMANAGEROPEN_LISTITEMS() !###====================================================================== IMPLICIT NONE INTEGER :: IMF,I CALL WDIALOGSELECT(ID_DPMANAGER_TAB2) CALL WDIALOGGETMENU(IDF_MENU1,IMF) CALL WGRIDROWS(IDF_GRID1,SIZE(MC(IMF)%T)) DO I=1,SIZE(MC(IMF)%T) CALL WGRIDPUTCELLSTRING(IDF_GRID1,1,I,TOPICS(MC(IMF)%T(I))%TNAME) CALL WGRIDPUTCELLCHECKBOX(IDF_GRID1,2,I,MC(IMF)%IACT(I)) ENDDO CALL WDIALOGGETMENU(IDF_MENU1,IMF) CALL WDIALOGSELECT(ID_DPMANAGER_TAB1) CALL WDIALOGTITLE('TreeView '//TRIM(MC(IMF)%MCNAME)) CALL WDIALOGSELECT(ID_DPMANAGER_TAB2) END SUBROUTINE PMANAGEROPEN_LISTITEMS !###====================================================================== SUBROUTINE PMANAGEROPEN() !###====================================================================== IMPLICIT NONE INTEGER :: I,J,N,M,ITYPE,IPER,ITOPIC,IYR,IMH,IDY,IHR,IMT,ISC,ICF,ID,ISYS,ISUBTOPIC,IST,IOPTION TYPE(WIN_MESSAGE) :: MESSAGE CHARACTER(LEN=256) :: CNAME CHARACTER(LEN=3) :: EXT LOGICAL :: LEX,LNEW,LADD CHARACTER(LEN=MAXLENPRJ) :: CD CHARACTER(LEN=256),POINTER,DIMENSION(:) :: INPLIST CALL WDIALOGSELECT(ID_DPMANAGER_TAB1); CALL WDIALOGGETTREEVIEW(ID_TREEVIEW1,ID,CNAME) !## get the right topics, attributes from the tree-view IF(.NOT.PMANAGER_GETSELECTED(ID,ITOPIC,IPER,ISYS,ISUBTOPIC,1))RETURN !## pst/pcg and iMOW-WQ packages go to another dialog SELECT CASE (ITOPIC) CASE (TPST,TPCG,TGCG,TVDF,TRCT,TIES) !## pst=settings IF(ITOPIC.EQ.TPST)CALL PMANAGEROPEN_PEST() ! !## ies=settings ! IF(ITOPIC.EQ.TIES)CALL PMANAGEROPEN_IES() !## pcg-settings IF(ITOPIC.EQ.TPCG)CALL PMANAGEROPEN_PCG() !## gcg-settings IF(ITOPIC.EQ.TGCG)CALL PMANAGEROPEN_GCG() !## rct-settings IF(ITOPIC.EQ.TRCT)CALL PMANAGEROPEN_RCT() !## vdf-settings IF(ITOPIC.EQ.TVDF)CALL PMANAGEROPEN_VDF() IF(.NOT.ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN !## create/update new period CALL PMANAGER_STRESSES(ITOPIC,IPER) !## create new system CALL PMANAGER_SYSTEMS(ITOPIC,IPER,ISYS) ELSE IPER=1; ISYS=1 ENDIF TOPICS(ITOPIC)%STRESS(IPER)%FILES(1,ISYS)%IACT =1 CALL PMANAGER_UTL_UPDATE_TREEVIEW(ITOPIC,IPER,ISYS) RETURN END SELECT N=TOPICS(ITOPIC)%NSUBTOPICS; IF(N.GT.0)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 IF(ASSOCIATED(PRJ))THEN PRJ%ILAY =1 PRJ%FCT =1.0D0 PRJ%IMP =0.0D0 PRJ%CNST =-999.99D0 PRJ%ICNST=1 PRJ%FNAME='' PRJ%IACT =1 ENDIF CALL IOSDATE(IYR,IMH,IDY); IHR=0; IMT=0; ISC=0 CALL WDIALOGFIELDSTATE(IDOK3,0); LADD=.TRUE. LNEW=.FALSE.; IF(IPER.EQ.0)LNEW=.TRUE. !## edit an existing system ELSE DO ISUBTOPIC=1,TOPICS(ITOPIC)%NSUBTOPICS PRJ(ISUBTOPIC)%FNAME=TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME PRJ(ISUBTOPIC)%FCT =TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FCT PRJ(ISUBTOPIC)%IMP =TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%IMP PRJ(ISUBTOPIC)%CNST =TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%CNST PRJ(ISUBTOPIC)%ICNST=TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ICNST PRJ(ISUBTOPIC)%ILAY =TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ILAY PRJ(ISUBTOPIC)%IACT =TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%IACT ENDDO CALL WDIALOGFIELDSTATE(IDOK,0); LADD=.FALSE. LNEW=.FALSE. ENDIF IF(ITOPIC.EQ.TCAP.AND.IPER.GT.0)THEN IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(IPER)%INPFILES))THEN ALLOCATE(INPLIST(SIZE(TOPICS(ITOPIC)%STRESS(IPER)%INPFILES))) INPLIST=TOPICS(ITOPIC)%STRESS(IPER)%INPFILES ENDIF ENDIF ENDIF IOPTION=1 !## cannot change date IF(.NOT.LNEW)THEN CALL WDIALOGFIELDSTATE(IDF_RADIO3,0) CALL WDIALOGFIELDSTATE(IDF_RADIO4,0) CALL WDIALOGFIELDSTATE(IDF_RADIO5,0) ENDIF IF(IPER.GT.0)THEN IF(TOPICS(ITOPIC)%TIMDEP)THEN IYR=TOPICS(ITOPIC)%STRESS(IPER)%IYR; IMH=TOPICS(ITOPIC)%STRESS(IPER)%IMH; IDY=TOPICS(ITOPIC)%STRESS(IPER)%IDY IHR=TOPICS(ITOPIC)%STRESS(IPER)%IHR; IMT=TOPICS(ITOPIC)%STRESS(IPER)%IMT; ISC=TOPICS(ITOPIC)%STRESS(IPER)%ISC !## true date eentered IF(IYR+IMH+IDY+IHR+IMT+ISC.GT.0)THEN CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO4) !## transient IF(.NOT.LNEW)CALL WDIALOGFIELDSTATE(IDF_RADIO4,1) ELSE !## check whether available period selected DO I=1,NPERIOD; IF(TRIM(UTL_CAP(TOPICS(ITOPIC)%STRESS(IPER)%CDATE,'U')).EQ.TRIM(UTL_CAP(PERIOD(I)%NAME,'U')))EXIT; ENDDO IF(I.LE.NPERIOD)THEN IOPTION=I CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO5) !## specified period IF(.NOT.LNEW)CALL WDIALOGFIELDSTATE(IDF_RADIO5,1) ELSE CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO3) !## steady-state IF(.NOT.LNEW)CALL WDIALOGFIELDSTATE(IDF_RADIO3,1) ENDIF ENDIF ENDIF ENDIF IST=1; CALL WDIALOGTITLE('Define Characteristics for: '//TRIM(TOPICS(ITOPIC)%TNAME)) IF(TOPICS(ITOPIC)%NSUBTOPICS.GT.0)THEN 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) ENDIF CALL PMANAGEROPEN_NOENTRIES(TOPICS(ITOPIC)%NSUBTOPICS,LADD) !## include species once defined IF(.NOT.TOPICS(ITOPIC)%LSPECIES)THEN CALL WDIALOGFIELDSTATE(IDF_LABEL8,0) CALL WDIALOGFIELDSTATE(IDF_LABEL9,0) CALL WDIALOGPUTSTRING(IDF_LABEL9,'No species available for this package') CALL WDIALOGFIELDSTATE(ID_SPECIES,0) CALL WDIALOGFIELDSTATE(IDF_GROUP3,0) ENDIF IF(ITOPIC.EQ.TCAP)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 IF(NSPECIES.EQ.0)THEN CALL WDIALOGPUTSTRING(IDF_LABEL9,'No species defined') ELSE WRITE(CNAME,'(99A)') (TRIM(SPECIES(I)%NAME)//',',I=1,NSPECIES-1),TRIM(SPECIES(NSPECIES)%NAME) CALL WDIALOGPUTSTRING(IDF_LABEL9,'Species: '//TRIM(CNAME)) ENDIF CALL WDIALOGPUTIMAGE(ID_OPEN ,ID_ICONOPENIDF,1) IF(.NOT.TOPICS(ITOPIC)%LSPECIES)THEN !## species section CALL WDIALOGFIELDSTATE(IDF_GROUP3,0) CALL WDIALOGFIELDSTATE(IDF_LABEL8,0) CALL WDIALOGFIELDSTATE(IDF_LABEL9,0) CALL WDIALOGFIELDSTATE(ID_SPECIES,0) ENDIF IF(.NOT.TOPICS(ITOPIC)%TIMDEP)THEN CALL WDIALOGFIELDSTATE(IDF_RADIO3,0) CALL WDIALOGFIELDSTATE(IDF_RADIO4,0) CALL WDIALOGFIELDSTATE(IDF_RADIO5,0) CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO3) CALL WDIALOGFIELDSTATE(IDF_INTEGER2,0) CALL WDIALOGFIELDSTATE(IDF_INTEGER3,0) CALL WDIALOGFIELDSTATE(IDF_INTEGER4,0) CALL WDIALOGFIELDSTATE(IDF_INTEGER5,0) CALL WDIALOGFIELDSTATE(IDF_INTEGER6,0) CALL WDIALOGFIELDSTATE(IDF_MENU2,0) CALL WDIALOGFIELDSTATE(IDF_MENU3,0) CALL WDIALOGFIELDSTATE(ID_PROPERTIES,0) CALL WDIALOGPUTSTRING(IDF_LABEL1,'Assign parameter to modellayer. Use >0 to enter modellayer number:') CALL WDIALOGRANGEINTEGER(IDF_INTEGER1,1,999) ELSE CALL WDIALOGRANGEINTEGER(IDF_INTEGER1,-1,999) SELECT CASE (ITOPIC) CASE (TEVT,TRCH,TSFR,TFHB) CALL WDIALOGPUTSTRING(IDF_LABEL1,'Assign parameter to modellayer. Use >0 to enter modellayer number; use -1 to assign to uppermost active modellayer:') CASE DEFAULT CALL WDIALOGPUTSTRING(IDF_LABEL1,'Assign parameter to modellayer. Use >0 to enter modellayer number; use -1 to assign to uppermost active '// & 'modellayer and use 0 to assign to modellayers automatically based on elevations:') END SELECT 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) IF(ASSOCIATED(PRJ))THEN CALL WDIALOGPUTINTEGER(IDF_INTEGER1,PRJ(1)%ILAY) CALL WDIALOGPUTCHECKBOX(IDF_CHECK1 ,PRJ(1)%IACT) ELSE CALL WDIALOGPUTINTEGER(IDF_INTEGER1,1) CALL WDIALOGPUTCHECKBOX(IDF_CHECK1 ,1) ENDIF ! IF(.NOT.TOPICS(ITOPIC)%TIMDEP.OR.SIZE(MENUNAMES).EQ.1)CALL WDIALOGFIELDSTATE(IDF_CHECK2,0) ! IF(PRJ(1)%ICNST.EQ.0)CALL WDIALOGPUTCHECKBOX(IDF_CHECK2,1) IF(TOPICS(ITOPIC)%TIMDEP)THEN CALL WDIALOGRANGEINTEGER(IDF_INTEGER1,-1,9999) ELSE CALL WDIALOGRANGEINTEGER(IDF_INTEGER1, 1,9999) ENDIF CALL PMANAGERPUTFIELDS(IST,ICF,EXT) CALL WDIALOGFIELDSTATE(IDF_RADIO1,ICF) IF(ICF.EQ.0)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO2) CALL PMANAGEROPENFIELDS(TOPICS(ITOPIC)%TIMDEP,LNEW,ICF) CALL UTL_FILLDATES(IDF_INTEGER3,IDF_MENU2,IDF_INTEGER2) CALL UTL_DIALOGSHOW(-1,-1,0,3) DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE(FIELDCHANGED) SELECT CASE (MESSAGE%VALUE2) CASE (IDF_MENU1) CALL PMANAGERGETFIELDS(IST) CASE (IDF_RADIO1,IDF_RADIO2,IDF_RADIO3,IDF_RADIO4,IDF_RADIO5,IDF_CHECK1) !,IDF_CHECK2) CALL PMANAGEROPENFIELDS(TOPICS(ITOPIC)%TIMDEP,LNEW,ICF) CASE (IDF_INTEGER2,IDF_INTEGER3,IDF_MENU2) CALL UTL_FILLDATES(IDF_INTEGER3,IDF_MENU2,IDF_INTEGER2) END SELECT SELECT CASE (MESSAGE%VALUE1) CASE (IDF_MENU1) CALL PMANAGERPUTFIELDS(IST,ICF,EXT) CALL PMANAGEROPENFIELDS(TOPICS(ITOPIC)%TIMDEP,LNEW,ICF) END SELECT CASE(PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (ID_ADDFILES) CALL UTL_LISTOFFILES(INPLIST,(/'*.*','','','','','Specify the files to be added to the package'/),I) CASE (ID_PROPERTIES) CALL PMANAGERDEFINEPERIODS() IF(NPERIOD.GT.0)THEN CALL WDIALOGPUTMENU(IDF_MENU3,PERIOD%NAME,NPERIOD,1) CALL WDIALOGFIELDSTATE(IDF_MENU3,1) ELSE CALL WDIALOGFIELDSTATE(IDF_MENU3,0) CALL WDIALOGCLEARFIELD(IDF_MENU3) ENDIF CASE (ID_SPECIES) CALL PMANAGERDEFINESPECIES() !## new number of species N=TOPICS(ITOPIC)%NSUBTOPICS; ALLOCATE(PRJ_TMP(N)) !## old number of species M=0; IF(ASSOCIATED(PRJ))M=SIZE(PRJ) !## copy new species DO ISUBTOPIC=1,MIN(SIZE(PRJ_TMP),M) PRJ_TMP(ISUBTOPIC)%FNAME=PRJ(ISUBTOPIC)%FNAME PRJ_TMP(ISUBTOPIC)%FCT =PRJ(ISUBTOPIC)%FCT PRJ_TMP(ISUBTOPIC)%IMP =PRJ(ISUBTOPIC)%IMP PRJ_TMP(ISUBTOPIC)%CNST =PRJ(ISUBTOPIC)%CNST PRJ_TMP(ISUBTOPIC)%ICNST=PRJ(ISUBTOPIC)%ICNST PRJ_TMP(ISUBTOPIC)%ILAY =PRJ(ISUBTOPIC)%ILAY PRJ_TMP(ISUBTOPIC)%IACT =PRJ(ISUBTOPIC)%IACT ENDDO DO ISUBTOPIC=M+1,N PRJ_TMP(ISUBTOPIC)%FNAME='' PRJ_TMP(ISUBTOPIC)%FCT =1.0D0 PRJ_TMP(ISUBTOPIC)%IMP =0.0D0 PRJ_TMP(ISUBTOPIC)%CNST =0.0D0 PRJ_TMP(ISUBTOPIC)%ICNST=1 IF(M.GT.0)THEN PRJ_TMP(ISUBTOPIC)%ILAY=PRJ(1)%ILAY ELSE PRJ_TMP(ISUBTOPIC)%ILAY=1 ENDIF PRJ_TMP(ISUBTOPIC)%IACT=1 ENDDO IF(ASSOCIATED(PRJ))DEALLOCATE(PRJ); PRJ=>PRJ_TMP IF(ALLOCATED(MENUNAMES))DEALLOCATE(MENUNAMES); IF(TOPICS(ITOPIC)%NSUBTOPICS.GT.0)THEN 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) ELSE CALL WDIALOGCLEARFIELD(IDF_MENU1); CALL WDIALOGFIELDSTATE(IDF_MENU1,2) ENDIF IF(NSPECIES.EQ.0)THEN CALL WDIALOGPUTSTRING(IDF_LABEL9,'No species defined') ELSE WRITE(CNAME,'(99A)') (TRIM(SPECIES(I)%NAME)//',',I=1,NSPECIES-1),TRIM(SPECIES(NSPECIES)%NAME) CALL WDIALOGPUTSTRING(IDF_LABEL9,'Species: '//TRIM(CNAME)) ENDIF CALL PMANAGEROPEN_NOENTRIES(TOPICS(ITOPIC)%NSUBTOPICS,LADD) CASE (ID_OPEN) IF(UTL_WSELECTFILE('iMOD '//TRIM(EXT)//' File (*.'//TRIM(EXT)//')|*.'//TRIM(EXT)//'|', & LOADDIALOG+MUSTEXIST+PROMPTON+DIRCHANGE+APPENDEXT,PRJ(IST)%FNAME,& 'Load iMOD '//TRIM(EXT)//' File'))THEN CALL WDIALOGPUTSTRING(IDF_STRING1,PRJ(IST)%FNAME) ENDIF CASE (IDOK,IDOK3) LEX=.TRUE. IF(TOPICS(ITOPIC)%TIMDEP)THEN CALL WDIALOGGETRADIOBUTTON(IDF_RADIO3,I) CD='' !## steady-state IF(I.EQ.1)THEN CD='STEADY-STATE'; IYR=0; IMH=0; IDY=0; IHR=0; IMT=0; ISC=0 !## date ELSEIF(I.EQ.2)THEN CALL WDIALOGGETINTEGER(IDF_INTEGER2,IDY) CALL WDIALOGGETMENU(IDF_MENU2,IMH) CALL WDIALOGGETINTEGER(IDF_INTEGER3,IYR) CALL WDIALOGGETINTEGER(IDF_INTEGER4,IHR) CALL WDIALOGGETINTEGER(IDF_INTEGER5,IMT) CALL WDIALOGGETINTEGER(IDF_INTEGER6,ISC) WRITE(CD,'(I4.4,5(A1,I2.2))') IYR,'-',IMH,'-',IDY,' ',IHR,':',IMT,':',ISC !## period ELSEIF(I.EQ.3)THEN CALL WDIALOGGETMENU(IDF_MENU3,I) WRITE(CD,'(A)') PERIOD(I)%NAME IYR=0; IMH=0; IDY=0; IHR=0; IMT=0; ISC=0 ENDIF IF(LNEW)THEN !## test whether date has been defined already N=0; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))N=SIZE(TOPICS(ITOPIC)%STRESS) DO I=1,N IF(TRIM(UTL_CAP(TOPICS(ITOPIC)%STRESS(I)%CDATE,'U')).EQ.TRIM(UTL_CAP(CD,'U')))THEN !## defined already CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'Entered date ['//TRIM(CD)//'] has been defined already.','Information') LEX=.FALSE. ENDIF ENDDO ENDIF ENDIF IF(LEX)THEN CALL WDIALOGGETINTEGER(IDF_INTEGER1,PRJ(1)%ILAY) SELECT CASE (ITOPIC) CASE (TEVT,TRCH,TSFR,TFHB) IF(PRJ(1)%ILAY.EQ.0)THEN CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'You can not specify a layer number of zero for this package','Error') LEX=.FALSE. ENDIF END SELECT ENDIF IF(LEX)THEN CALL WDIALOGGETCHECKBOX(IDF_CHECK1 ,PRJ(1)%IACT) PRJ(1:SIZE(PRJ))%ILAY=PRJ(1)%ILAY PRJ(1:SIZE(PRJ))%IACT=PRJ(1)%IACT CALL PMANAGERGETFIELDS(IST) EXIT ENDIF CASE (IDCANCEL) EXIT END SELECT END SELECT ENDDO CALL WDIALOGUNLOAD() IF(MESSAGE%VALUE1.EQ.IDOK.OR.MESSAGE%VALUE1.EQ.IDOK3)THEN !## create new period CALL PMANAGER_STRESSES(ITOPIC,IPER) !## create new system CALL PMANAGER_SYSTEMS(ITOPIC,IPER,ISYS) TOPICS(ITOPIC)%STRESS(IPER)%CDATE=CD TOPICS(ITOPIC)%STRESS(IPER)%IYR=IYR; TOPICS(ITOPIC)%STRESS(IPER)%IMH=IMH TOPICS(ITOPIC)%STRESS(IPER)%IDY=IDY; TOPICS(ITOPIC)%STRESS(IPER)%IHR=IHR TOPICS(ITOPIC)%STRESS(IPER)%IMT=IMT; TOPICS(ITOPIC)%STRESS(IPER)%ISC=ISC IF(ITOPIC.EQ.TCAP)THEN IF(ASSOCIATED(INPLIST))THEN IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(IPER)%INPFILES))DEALLOCATE(TOPICS(ITOPIC)%STRESS(IPER)%INPFILES) ALLOCATE(TOPICS(ITOPIC)%STRESS(IPER)%INPFILES(SIZE(INPLIST))) TOPICS(ITOPIC)%STRESS(IPER)%INPFILES=INPLIST DEALLOCATE(INPLIST) ENDIF ENDIF DO ISUBTOPIC=1,TOPICS(ITOPIC)%NSUBTOPICS TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%IACT =PRJ(ISUBTOPIC)%IACT TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME=PRJ(ISUBTOPIC)%FNAME TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FCT =PRJ(ISUBTOPIC)%FCT TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%IMP =PRJ(ISUBTOPIC)%IMP TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ICNST=PRJ(ISUBTOPIC)%ICNST TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%CNST =PRJ(ISUBTOPIC)%CNST TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ILAY =PRJ(ISUBTOPIC)%ILAY IF(PRJ(ISUBTOPIC)%ICNST.EQ.2)THEN TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ALIAS= & UTL_CAP(TRIM(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME & (INDEX(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME,'\',.TRUE.)+1:)),'L') ENDIF ENDDO CALL PMANAGER_SORTTOPIC(ITOPIC,IPER) CALL PMANAGER_UTL_UPDATE_TREEVIEW(ITOPIC,IPER,ISYS) ENDIF IF(ALLOCATED(MENUNAMES))DEALLOCATE(MENUNAMES); IF(ASSOCIATED(PRJ))DEALLOCATE(PRJ) END SUBROUTINE PMANAGEROPEN !###====================================================================== SUBROUTINE PMANAGEROPEN_NOENTRIES(ITOPIC,LADD) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ITOPIC LOGICAL,INTENT(IN) :: LADD INTEGER :: IACT IACT=1; IF(ITOPIC.LE.0)IACT=0 CALL WDIALOGFIELDSTATE(IDF_MENU1,IACT) IF(IACT.EQ.0)CALL WDIALOGCLEARFIELD(IDF_MENU1) !## turn off all relevant fields CALL WDIALOGFIELDSTATE(IDF_INTEGER1,IACT) CALL WDIALOGFIELDSTATE(IDF_REAL1,IACT) CALL WDIALOGFIELDSTATE(IDF_REAL2,IACT) IF(IACT.EQ.0)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO1) CALL WDIALOGFIELDSTATE(IDF_STRING1,IACT) CALL WDIALOGFIELDSTATE(IDF_RADIO1,IACT) CALL WDIALOGFIELDSTATE(IDF_RADIO2,IACT) CALL WDIALOGFIELDSTATE(ID_OPEN,IACT) IF(LADD)THEN CALL WDIALOGFIELDSTATE(IDOK,IACT) ELSE CALL WDIALOGFIELDSTATE(IDOK3,IACT) ENDIF END SUBROUTINE PMANAGEROPEN_NOENTRIES !###====================================================================== SUBROUTINE PMANAGEROPEN_AUTOMATIC() !###====================================================================== IMPLICIT NONE INTEGER :: I,J,N,ITYPE,ITOPIC,IPER,ISYS,ISUBTOPIC,ID,NF,ICNST,ILAY,IOS,IYR,IMH,IDY,IHR,IMT,ISC,ISEL REAL(KIND=DP_KIND) :: CNST TYPE(WIN_MESSAGE) :: MESSAGE CHARACTER(LEN=14) :: CD CHARACTER(LEN=256) :: CNAME CHARACTER(LEN=256),ALLOCATABLE,DIMENSION(:) :: PNAME INTEGER(KIND=8) :: IDATE CALL WDIALOGSELECT(ID_DPMANAGER_TAB1); CALL WDIALOGGETTREEVIEW(ID_TREEVIEW1,ID,CNAME) !## get the right topics, attributes from the tree-view IF(.NOT.PMANAGER_GETSELECTED(ID,ITOPIC,IPER,ISYS,ISUBTOPIC,1))RETURN !## pst/pcg goes to another dialog SELECT CASE (ITOPIC) CASE (TCAP,TPST,TPCG,TIES); RETURN END SELECT CALL WDIALOGLOAD(ID_DPMANAGER_AUTOMATIC,ID_DPMANAGER_AUTOMATIC) CALL WGRIDROWS(IDF_GRID1,TOPICS(ITOPIC)%NSUBTOPICS) CALL WDIALOGTITLE('Define Characteristics for: '//TRIM(TOPICS(ITOPIC)%TNAME)) DO J=1,TOPICS(ITOPIC)%NSUBTOPICS; CALL WGRIDPUTCELLSTRING(IDF_GRID1,1,J,TOPICS(ITOPIC)%SNAME(J)); ENDDO IF(ALLOCATED(PNAME))DEALLOCATE(PNAME) ALLOCATE(PNAME(TOPICS(ITOPIC)%NSUBTOPICS)) IF(TOPICS(ITOPIC)%TIMDEP)THEN CALL WDIALOGPUTSTRING(IDF_RADIO1,'iMOD will look for unique TIME STEPS (>0) and MODEL LAYERS (>0) at the wildcard and add those files to your Project Manager') CALL WDIALOGFIELDSTATE(IDF_RADIO2,0) ELSE CALL WDIALOGPUTSTRING(IDF_RADIO1,'iMOD will look for unique LAYERS (>0) at the wildcard and add those files to your Project Manager') CALL WDIALOGFIELDSTATE(IDF_RADIO3,0) ENDIF CALL WDIALOGPUTMENU(IDF_MENU1,CDATE,12,1) CALL WDIALOGPUTMENU(IDF_MENU2,CDATE,12,1) CALL UTL_FILLDATESDIALOG(ID_DPMANAGER_AUTOMATIC,IDF_INTEGER1,IDF_MENU1,IDF_INTEGER2,UTL_GETCURRENTDATE()) CALL UTL_FILLDATESDIALOG(ID_DPMANAGER_AUTOMATIC,IDF_INTEGER2,IDF_MENU2,IDF_INTEGER4,UTL_GETCURRENTDATE()) CALL PMANAGEROPEN_AUTOMATIC_FIELDS() CALL WDIALOGRANGEINTEGER(IDF_INTEGER5,1,999) CALL WDIALOGPUTINTEGER(IDF_INTEGER5,1) CALL PMANAGER_GETNFILES((/TTOP,TBOT,TBND,TSHD,TKDW,TKHV,TKVA,TVCW,TKVV,TSTO,TSPY/),NF); NF=MAX(1,NF) CALL WDIALOGPUTINTEGER(IDF_INTEGER12,NF) CALL WDIALOGRANGEINTEGER(IDF_INTEGER12,1,999) CALL UTL_DIALOGSHOW(-1,-1,0,3) DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE(FIELDCHANGED) SELECT CASE (MESSAGE%VALUE2) CASE (IDF_RADIO1,IDF_RADIO2,IDF_RADIO3) CALL PMANAGEROPEN_AUTOMATIC_FIELDS() CASE (IDF_MENU1) CALL UTL_FILLDATES(IDF_INTEGER3,IDF_MENU1,IDF_INTEGER1) CASE (IDF_MENU2) CALL UTL_FILLDATES(IDF_INTEGER4,IDF_MENU2,IDF_INTEGER2) END SELECT SELECT CASE (MESSAGE%VALUE1) END SELECT CASE(PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (IDOK) CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,ISEL); NF=0 DO J=1,TOPICS(ITOPIC)%NSUBTOPICS CALL WGRIDGETCELLSTRING(IDF_GRID1,2,J,PNAME(J)) IF(TRIM(PNAME(J)).EQ.'')THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Nothing filled in for'//CHAR(13)// & TRIM(TOPICS(ITOPIC)%SNAME(J)),'Error'); EXIT ENDIF IF(INDEX(PNAME(J),'*').GT.0)NF=NF+1 ENDDO IF(ISEL.NE.2.AND.NF.LE.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You need to add at least one parameter'//CHAR(13)// & 'defined with a wildcard','Error') ELSE IF(J.GT.TOPICS(ITOPIC)%NSUBTOPICS)THEN IF(PMANAGEROPEN_AUTOMATIC_FILES(ITOPIC,PNAME,SIZE(PNAME)))THEN !,FILES))THEN !## show files found IF(PMANAGEROPEN_AUTOMATIC_LISTFILES(ITOPIC))EXIT !FILES,ITOPIC))EXIT CALL WDIALOGSELECT(ID_DPMANAGER_AUTOMATIC) ENDIF ENDIF ENDIF CASE (IDHELP) CASE (IDCANCEL) EXIT END SELECT END SELECT ENDDO CALL WDIALOGSELECT(ID_DPMANAGER_AUTOMATIC); CALL WDIALOGUNLOAD() IF(MESSAGE%VALUE1.EQ.IDOK)THEN !## add files to project manager DO I=1,SIZE(FILES,1) IF(TOPICS(ITOPIC)%TIMDEP)THEN READ(FILES(I,TOPICS(ITOPIC)%NSUBTOPICS+1),*,IOSTAT=IOS) IDATE IDATE=UTL_COMPLETEDATE(IDATE) IF(IOS.EQ.0)THEN CALL UTL_IDATETOGDATE(IDATE,IYR,IMH,IDY,IHR,IMT,ISC) WRITE(CD,'(I14)') IDATE ELSE READ(FILES(I,TOPICS(ITOPIC)%NSUBTOPICS+1),*,IOSTAT=IOS) CD IYR=0; IMH=0; IDY=0; IHR=0; IMT=0; ISC=0 ENDIF !## test whether date has been defined already IPER=0; N=0; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))N=SIZE(TOPICS(ITOPIC)%STRESS) DO J=1,N IF(TRIM(UTL_CAP(TOPICS(ITOPIC)%STRESS(J)%CDATE,'U')).EQ.TRIM(UTL_CAP(CD,'U')))THEN IPER=J; EXIT ENDIF ENDDO !## create new period CALL PMANAGER_STRESSES(ITOPIC,IPER) !## create new system ISYS=0; CALL PMANAGER_SYSTEMS(ITOPIC,IPER,ISYS) TOPICS(ITOPIC)%STRESS(IPER)%CDATE=ADJUSTL(FILES(I,TOPICS(ITOPIC)%NSUBTOPICS+1)) TOPICS(ITOPIC)%STRESS(IPER)%IYR=IYR; TOPICS(ITOPIC)%STRESS(IPER)%IMH=IMH TOPICS(ITOPIC)%STRESS(IPER)%IDY=IDY; TOPICS(ITOPIC)%STRESS(IPER)%IHR=IHR TOPICS(ITOPIC)%STRESS(IPER)%IMT=IMT; TOPICS(ITOPIC)%STRESS(IPER)%ISC=ISC ILAY=-9999 ELSE !## create new period CALL PMANAGER_STRESSES(ITOPIC,IPER) !## create new system ISYS=0; CALL PMANAGER_SYSTEMS(ITOPIC,IPER,ISYS) READ(FILES(I,TOPICS(ITOPIC)%NSUBTOPICS+1),*,IOSTAT=IOS) ILAY IF(IOS.NE.0)ILAY=-9999 ENDIF DO ISUBTOPIC=1,TOPICS(ITOPIC)%NSUBTOPICS READ(FILES(I,ISUBTOPIC),*,IOSTAT=IOS) CNST IF(IOS.EQ.0)THEN !## constant value ICNST=1; FILES(I,ISUBTOPIC)='' ELSE !## file given ICNST=2; CNST=-999.99 !## try to read layer IF(ILAY.EQ.-9999)ILAY=IDFGETILAY(FILES(I,ISUBTOPIC)) ILAY=MAX(1,ILAY) ENDIF TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%IACT =1 TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME=FILES(I,ISUBTOPIC) TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FCT =1.0D0 TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%IMP =0.0D0 TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ICNST=ICNST TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%CNST =CNST TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ILAY =ILAY IF(ICNST.EQ.2)THEN TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ALIAS= & UTL_CAP(TRIM(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME & (INDEX(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME,'\',.TRUE.)+1:)),'L') ELSE TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ALIAS='' ENDIF ENDDO ENDDO CALL PMANAGER_SORTTOPIC(ITOPIC,IPER) CALL PMANAGER_UTL_UPDATE_TREEVIEW(ITOPIC,IPER,ISYS) DEALLOCATE(FILES,PNAME) ENDIF END SUBROUTINE PMANAGEROPEN_AUTOMATIC !###====================================================================== SUBROUTINE PMANAGEROPEN_AUTOMATIC_FIELDS() !###====================================================================== IMPLICIT NONE INTEGER :: I,I1,I2 CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,I) SELECT CASE (I) CASE (1); I1=0; I2=0 CASE (2); I1=0; I2=1 CASE (3); I1=1; I2=0 END SELECT CALL WDIALOGFIELDSTATE(IDF_MENU1,I1) CALL WDIALOGFIELDSTATE(IDF_MENU2,I1) CALL WDIALOGFIELDSTATE(IDF_INTEGER1,I1) CALL WDIALOGFIELDSTATE(IDF_INTEGER2,I1) CALL WDIALOGFIELDSTATE(IDF_INTEGER3,I1) CALL WDIALOGFIELDSTATE(IDF_INTEGER4,I1) CALL WDIALOGFIELDSTATE(IDF_INTEGER6,I1) CALL WDIALOGFIELDSTATE(IDF_INTEGER7,I1) CALL WDIALOGFIELDSTATE(IDF_INTEGER8,I1) CALL WDIALOGFIELDSTATE(IDF_INTEGER9,I1) CALL WDIALOGFIELDSTATE(IDF_INTEGER10,I1) CALL WDIALOGFIELDSTATE(IDF_INTEGER11,I1) CALL WDIALOGFIELDSTATE(IDF_LABEL2,I1) CALL WDIALOGFIELDSTATE(IDF_LABEL3,I1) CALL WDIALOGFIELDSTATE(IDF_INTEGER5,I2) CALL WDIALOGFIELDSTATE(IDF_INTEGER12,I2) END SUBROUTINE PMANAGEROPEN_AUTOMATIC_FIELDS !###====================================================================== LOGICAL FUNCTION PMANAGEROPEN_AUTOMATIC_LISTFILES(ITOPIC) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ITOPIC INTEGER,DIMENSION(:),ALLOCATABLE :: ICOLS INTEGER :: I,J,N,M,ITYPE TYPE(WIN_MESSAGE) :: MESSAGE PMANAGEROPEN_AUTOMATIC_LISTFILES=.FALSE. CALL WDIALOGLOAD(ID_DPMANAGER_AUTO_LIST,ID_DPMANAGER_AUTO_LIST) N=SIZE(FILES,1); M=SIZE(FILES,2)-1 IF(WINFOGRID(IDF_GRID1,GRIDROWSMAX).LT.N)THEN CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'iMOD can display '//TRIM(VTOS(WINFOGRID(IDF_GRID1,GRIDROWSMAX)))//' rows only'//CHAR(13)// & 'The current selection of files is '//TRIM(VTOS(N)),'Information') CALL WDIALOGUNLOAD(); RETURN ENDIF CALL WGRIDROWS(IDF_GRID1,N) ALLOCATE(ICOLS(M)); ICOLS=1; CALL WGRIDCOLUMNS(IDF_GRID1,M,ICOLS); DEALLOCATE(ICOLS) CALL WGRIDLABELCOLUMN(IDF_GRID1,0,'number of files: '//TRIM(VTOS(N))) DO I=1,M; CALL WGRIDLABELCOLUMN(IDF_GRID1,I,TOPICS(ITOPIC)%SNAME(I)(1:5)); ENDDO DO I=1,N; CALL WGRIDLABELROW(IDF_GRID1,I,FILES(I,M+1)); ENDDO DO I=1,M; DO J=1,N CALL WGRIDPUTCELLSTRING(IDF_GRID1,I,J,FILES(J,I)) ENDDO; ENDDO CALL UTL_DIALOGSHOW(-1,-1,0,3) DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE(FIELDCHANGED) SELECT CASE (MESSAGE%VALUE2) END SELECT SELECT CASE (MESSAGE%VALUE1) END SELECT CASE(PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (IDOK) !## read from dialog any adjustments DO I=1,M; DO J=1,N CALL WGRIDGETCELLSTRING(IDF_GRID1,I,J,FILES(J,I)) IF(UTL_CAP(FILES(J,I),'U').EQ.'INHERENT')THEN IF(J.EQ.1)THEN CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'You cannot assign key word INHERENT on the first row','Information') EXIT ELSE FILES(J,I)=FILES(J-1,I) ENDIF ENDIF ENDDO; IF(J.LE.N)EXIT; ENDDO IF(I.GT.M)THEN PMANAGEROPEN_AUTOMATIC_LISTFILES=.TRUE.; EXIT ENDIF CASE (IDHELP) CASE (IDCANCEL) PMANAGEROPEN_AUTOMATIC_LISTFILES=.FALSE.; EXIT END SELECT END SELECT ENDDO CALL WDIALOGUNLOAD() END FUNCTION PMANAGEROPEN_AUTOMATIC_LISTFILES !###====================================================================== LOGICAL FUNCTION PMANAGEROPEN_AUTOMATIC_FILES(ITOPIC,PNAME,NPNAME) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ITOPIC,NPNAME CHARACTER(LEN=*),INTENT(IN),DIMENSION(NPNAME) :: PNAME INTEGER :: I,J,K,L,N,M,IOS,ISEL,IDY,IMH,IYR,IHR,IMT,ISC,IL,IL1,IL2,MLV CHARACTER(LEN=256),ALLOCATABLE,DIMENSION(:) :: LISTNAME INTEGER,ALLOCATABLE,DIMENSION(:) :: NF,PF CHARACTER(LEN=256) :: DIR CHARACTER(LEN=52) :: WC REAL(KIND=DP_KIND) :: X INTEGER(KIND=8) :: IT,IT1,IT2,MTV LOGICAL :: LEX PMANAGEROPEN_AUTOMATIC_FILES=.FALSE. CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,ISEL) IF(ISEL.EQ.2)THEN CALL WDIALOGGETINTEGER(IDF_INTEGER5 ,IL1) CALL WDIALOGGETINTEGER(IDF_INTEGER12,IL2) ELSEIF(ISEL.EQ.3)THEN CALL WDIALOGGETINTEGER(IDF_INTEGER1 ,IDY) CALL WDIALOGGETMENU(IDF_MENU1 ,IMH) CALL WDIALOGGETINTEGER(IDF_INTEGER3 ,IYR) CALL WDIALOGGETINTEGER(IDF_INTEGER6 ,IHR) CALL WDIALOGGETINTEGER(IDF_INTEGER7 ,IMT) CALL WDIALOGGETINTEGER(IDF_INTEGER8 ,ISC) IT1=IYR*10000000000+IMH*100000000+IDY*1000000+IHR*10000+IMT*100+ISC CALL WDIALOGGETINTEGER(IDF_INTEGER2 ,IDY) CALL WDIALOGGETMENU(IDF_MENU2 ,IMH) CALL WDIALOGGETINTEGER(IDF_INTEGER4 ,IYR) CALL WDIALOGGETINTEGER(IDF_INTEGER9 ,IHR) CALL WDIALOGGETINTEGER(IDF_INTEGER10,IMT) CALL WDIALOGGETINTEGER(IDF_INTEGER11,ISC) IT2=IYR*10000000000+IMH*100000000+IDY*1000000+IHR*10000+IMT*100+ISC ENDIF N=TOPICS(ITOPIC)%NSUBTOPICS CALL IOSDIRENTRYTYPE('F') ALLOCATE(NF(N),PF(N)); NF=0; PF=1 !## okay let's go DO J=1,2 NF=0 DO I=1,N !## try to read a number READ(PNAME(I),*,IOSTAT=IOS) X !## okay is number, go to next IF(IOS.EQ.0)THEN IF(J.EQ.2)WRITE(FILES(1,I),*) X ELSE !## try wildcard IF(INDEX(PNAME(I),'*').GT.0)THEN DIR=PNAME(I)(1:INDEX(PNAME(I),'\',.TRUE.)-1) WC =PNAME(I)(INDEX(PNAME(I),'\',.TRUE.)+1:) CALL IOSDIRCOUNT(DIR,WC,M) ALLOCATE(LISTNAME(M)); CALL UTL_DIRINFO(DIR,WC,LISTNAME,M,'F',CORDER='N') L=0 DO K=1,M !## file okay until proven otherwise LEX=.TRUE. IF(.NOT.TOPICS(ITOPIC)%TIMDEP)THEN IL=IDFGETILAY(LISTNAME(K)) !## negative/zero layers always invalid IF(IL.LE.0)LEX=.FALSE. IF(ISEL.EQ.2)THEN; IF(IL.LT.IL1.OR.IL.GT.IL2)LEX=.FALSE.; ENDIF ELSE IT=0 IF(UTL_IDFGETDATE(LISTNAME(K),IYR=IYR,IMH=IMH,IDY=IDY,IHR=IHR,IMT=IMT,ISC=ISC).NE.0D0)THEN IT=IYR*10000000000+IMH*100000000+IDY*1000000+IHR*10000+IMT*100+ISC ENDIF IL=IDFGETILAY(LISTNAME(K)) !## negative dates/layers always invalid IF(IT.LE.0.AND.IL.LE.0)LEX=.FALSE. IF(ISEL.EQ.3)THEN; IF(IT.LT.IT1.OR.IT.GT.IT2)LEX=.FALSE.; ENDIF ENDIF IF(LEX)THEN L=L+1; IF(J.EQ.2)FILES(L,I)=TRIM(DIR)//'\'//TRIM(LISTNAME(K)) ENDIF ENDDO NF(I)=L; DEALLOCATE(LISTNAME) ELSE IF(J.EQ.2)FILES(1,I)=PNAME(I) ENDIF ENDIF ENDDO !## layer may be filled in without wildcards IF(SUM(NF).EQ.0)THEN !## layer asked IF(ISEL.EQ.2)EXIT CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'No files found for the parameter(s)'//CHAR(13)// & 'defined with a wildcard','Error'); DEALLOCATE(NF,PF); RETURN ENDIF IF(J.EQ.1)ALLOCATE(FILES(SUM(NF),N)) ENDDO IF(SUM(NF).GT.0)THEN !## organize them properly ALLOCATE(FILES_BU(SUM(NF),N+1)) !## initial value FILES_BU='Inherent' IF(TOPICS(ITOPIC)%TIMDEP)THEN DO I=1,SUM(NF) MTV=HUGE(INT(1,8)) !## find min-value K=0; DO J=1,N !## skip time-constant files IF(NF(J).EQ.0)CYCLE IL=IDFGETILAY(FILES(PF(J),J)) IT=INT(0,8) IF(UTL_IDFGETDATE(FILES(PF(J),J),IYR=IYR,IMH=IMH,IDY=IDY,IHR=IHR,IMT=IMT,ISC=ISC).NE.0D0)THEN IT=IYR*10000000000+IMH*100000000+IDY*1000000+IHR*10000+IMT*100+ISC IF(IT.LE.MTV)MTV=IT ENDIF IF(IT.NE.0.OR.IL.NE.0)K=K+1 ENDDO !## nothing found anymore - quit IF(K.EQ.0)EXIT !## copy all equal to minvalue IF(MTV.EQ.HUGE(INT(0,8)))MTV=INT(0,8) !THEN IF(MTV.EQ.INT(0,8))THEN WRITE(FILES_BU(I,N+1),*) 'STEADY-STATE' ELSE WRITE(FILES_BU(I,N+1),*) MTV ENDIF DO J=1,N !## skip time-constant files IF(NF(J).EQ.0)CYCLE IT=INT(0,8) IF(UTL_IDFGETDATE(FILES(PF(J),J),IYR=IYR,IMH=IMH,IDY=IDY,IHR=IHR,IMT=IMT,ISC=ISC).NE.0D0)THEN IT=IYR*10000000000+IMH*100000000+IDY*1000000+IHR*10000+IMT*100+ISC ENDIF IF(IT.EQ.MTV)THEN FILES_BU(I,J)=FILES(PF(J),J); PF(J)=PF(J)+1 ENDIF ENDDO ENDDO ELSE DO I=1,SUM(NF) MLV=HUGE(1) !## find min-value K=0; DO J=1,N IL=IDFGETILAY(FILES(PF(J),J)); IF(IL.LE.MLV)THEN; MLV=IL; K=K+1; ENDIF ENDDO !## nothing found anymore - quit IF(K.EQ.0)EXIT !## copy all equal to minvalue WRITE(FILES_BU(I,N+1),*) MLV DO J=1,N IL=IDFGETILAY(FILES(PF(J),J)) IF(IL.EQ.MLV)THEN FILES_BU(I,J)=FILES(PF(J),J); PF(J)=PF(J)+1 ENDIF ENDDO ENDDO ENDIF K=I-1 DEALLOCATE(FILES) ALLOCATE(FILES(K,N+1)) DO I=1,K; DO J=1,N+1; FILES(I,J)=FILES_BU(I,J); ENDDO; ENDDO DEALLOCATE(FILES_BU) !## fill in constants at the beginning DO I=1,N IF(NF(I).EQ.0)FILES(1,I)=PNAME(I) ENDDO ELSE K=(IL2-IL1)+1 ALLOCATE(FILES(K,N+1)) IL=IL1-1; DO I=1,K; IL=IL+1; DO J=1,N; FILES(I,J)=PNAME(J); ENDDO; FILES(I,N+1)=TRIM(VTOS(IL)); ENDDO NF=K ENDIF IF(SUM(NF).GT.0)PMANAGEROPEN_AUTOMATIC_FILES=.TRUE. DEALLOCATE(NF,PF) END FUNCTION PMANAGEROPEN_AUTOMATIC_FILES !###====================================================================== LOGICAL FUNCTION PMANAGER_SEP_RUNS(ID,RUNFNAME,IBATCH) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ID,IBATCH CHARACTER(LEN=*),INTENT(IN) :: RUNFNAME TYPE(IDFOBJ) :: IDF,LOADPTR,BUFFPTR INTEGER :: NJ,I,J,JU,KU,ICYCLE,IC,IC1,IC2,IR,IR1,IR2,IROW,ICOL,N,M,NUID,PE_MXITER_BU,NCOL,NROW,NODES,IOS,IRUN,NPOP CHARACTER(LEN=256) :: NAMFILE,PRJFILE,FNAME,OUTMAPSEPM,OUTMAP,MNAME,IPESTPOUTPUT INTEGER,ALLOCATABLE,DIMENSION(:) :: PROC_ICOLMIN,PROC_ICOLMAX,PROC_IROWMIN,PROC_IROWMAX,UID,RMID,JMODEL TYPE PSUMOBJ INTEGER :: NITER REAL(KIND=DP_KIND),POINTER,DIMENSION(:) :: ALPHA=>NULL() REAL(KIND=DP_KIND) :: TOBJ,IOBJ,LAMBDA END TYPE PSUMOBJ TYPE(PSUMOBJ),ALLOCATABLE,DIMENSION(:,:) :: PSUM REAL(KIND=DP_KIND) :: X1,Y1,X2,Y2,LAMBDA,X1M,Y1M,X2M,Y2M,TTIME,TIME,STDEV,XT,F REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: FCT LOGICAL :: LEX INTEGER,POINTER,DIMENSION(:) :: SAVESHD,SAVEFLX IF(ASSOCIATED(PBMAN%ISAVE(TSHD)%ILAY))THEN M=SIZE(PBMAN%ISAVE(TSHD)%ILAY); ALLOCATE(SAVESHD(M)); SAVESHD=PBMAN%ISAVE(TSHD)%ILAY ENDIF IF(ASSOCIATED(PBMAN%ISAVE(TKHV)%ILAY))THEN M=SIZE(PBMAN%ISAVE(TKHV)%ILAY); ALLOCATE(SAVEFLX(M)); SAVEFLX=PBMAN%ISAVE(TKHV)%ILAY ENDIF PMANAGER_SEP_RUNS=.FALSE. IF(PEST%PE_MXITER.GT.1.AND.PBMAN%OUTERUPDATE.EQ.1)THEN WRITE(*,'(/A/)') '>>> Are you sure to continue as maximum iteration is '//TRIM(VTOS(PEST%PE_MXITER))//' and outer cycle is active <<<' PAUSE ENDIF !## copy as it shared memory with pbman%runfname NAMFILE=RUNFNAME PRJFILE=PBMAN%PRJFILE IF(LEN_TRIM(PBMAN%OUTPUT).EQ.0)THEN OUTMAP=NAMFILE(:INDEX(NAMFILE,'\',.TRUE.)-1) ELSE OUTMAP=PBMAN%OUTPUT ENDIF IF(LEN_TRIM(PBMAN%SEPM_FOLDER).EQ.0)THEN OUTMAPSEPM=OUTMAP ELSE OUTMAPSEPM=PBMAN%SEPM_FOLDER ENDIF MNAME=NAMFILE(INDEX(NAMFILE,'\',.TRUE.)+1:INDEX(NAMFILE,'.',.TRUE.)-1) CALL PMANAGER_GETNFILES((/TTOP,TBOT,TBND,TSHD,TKDW,TKHV,TKVA,TVCW,TKVV,TSTO,TSPY/),PRJMXNLAY) PRJNLAY=PRJMXNLAY CALL UTL_CREATEDIR(NAMFILE(:INDEX(NAMFILE,'\',.TRUE.)-1)); CALL UTL_CREATEDIR(OUTMAPSEPM) !## get model dimensions IF(.NOT.PMANAGER_SAVEMF2005_SIM(IBATCH))RETURN; CALL IDFDEALLOCATEX(PRJIDF); CALL IDFDEALLOCATESX(PRJIDF) CALL UTL_IDFSNAPTOGRID_LLC(PRJIDF%XMIN,PRJIDF%XMAX,PRJIDF%YMIN,PRJIDF%YMAX,PRJIDF%DX,PRJIDF%DY,PRJIDF%NCOL,PRJIDF%NROW,LLC=.TRUE.) CALL IDFCOPY(PRJIDF,LOADPTR) !## need to be model-dimension IF(PBMAN%NMODELS.EQ.0)THEN IF(TRIM(PBMAN%SEPMODELS).NE.'')THEN IF(.NOT.IDFREAD(IDF,PBMAN%SEPMODELS,0))STOP 'CANNOT LOAD SEPMODELS IDF' IF (.NOT.IDFREADSCALE(PBMAN%SEPMODELS,LOADPTR,7,0,0.0D0,0))THEN WRITE(*,'(/1X,A/)') 'ERROR READING '//TRIM(PBMAN%SEPMODELS); RETURN ENDIF N=PRJIDF%NROW*PRJIDF%NCOL; ALLOCATE(UID(N)); N=0 DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL IF(LOADPTR%X(ICOL,IROW).EQ.LOADPTR%NODATA)CYCLE N=N+1; UID(N)=INT(LOADPTR%X(ICOL,IROW)) ENDDO; ENDDO CALL UTL_GETUNIQUE_INT(UID,N,NUID,0) ALLOCATE(RMID(NUID)); RMID=0 DO I=1,NUID; RMID(I)=UID(I); ENDDO; DEALLOCATE(UID) PBMAN%NMODELS=NUID !## usage of lambdamodels ELSEIF(TRIM(PBMAN%LAMBDAMODELS).NE.'')THEN IF(.NOT.IDFREAD(IDF,PBMAN%LAMBDAMODELS,1))STOP 'CANNOT LOAD LAMBDAMODELS IDF' IF(.NOT.IDFALLOCATEX(LOADPTR))STOP 'CANNOT ALLOCATE LOADPTR' CALL IDFNULLIFY(BUFFPTR); CALL IDFCOPY(LOADPTR,BUFFPTR); BUFFPTR%X=BUFFPTR%NODATA; LOADPTR%X=LOADPTR%NODATA !## create gen-files JU=UTL_GETUNIT(); OPEN(JU,FILE=TRIM(OUTMAPSEPM)//'\LOADPTR.GEN',STATUS='UNKNOWN',ACTION='WRITE') KU=UTL_GETUNIT(); OPEN(KU,FILE=TRIM(OUTMAPSEPM)//'\BUFFPTR.GEN',STATUS='UNKNOWN',ACTION='WRITE') !## fill in loadptr from cellsize lambdamodels TTIME=0.0D0; I=0; DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL CALL IDFGETEDGE(IDF,IROW,ICOL,X1,Y1,X2,Y2) !## see if it is current model IF(X1.LT.PRJIDF%XMAX.AND.X2.GT.PRJIDF%XMIN.AND. & Y1.LT.PRJIDF%YMAX.AND.Y2.GT.PRJIDF%YMIN)THEN CALL IDFIROWICOL(PRJIDF,IR2,IC1,X1,Y1) !## lower left corner CALL IDFIROWICOL(PRJIDF,IR1,IC2,X2,Y2) !## upper right corner IC1=MAX(IC1+1,1); IR1=MAX(IR1+1,1) IC2=MIN(IC2,PRJIDF%NCOL); IR2=MIN(IR2,PRJIDF%NROW) !## see if it is current model LAMBDA=IDF%X(ICOL,IROW) !## skip this one IF(LAMBDA.EQ.0.0D0.OR.LAMBDA.EQ.IDF%NODATA)CYCLE I=I+1; DO IR=IR1,IR2; DO IC=IC1,IC2 LOADPTR%X(IC,IR)=REAL(I,8); BUFFPTR%X(IC,IR)=LAMBDA ENDDO; ENDDO WRITE(JU,'(I10)') I CALL IDFGETEDGE(PRJIDF,IR2,IC1,X1,Y1,X2,Y2); WRITE(JU,'(2F15.3)') X1,Y1 !## lowerleftcorner CALL IDFGETEDGE(PRJIDF,IR2,IC2,X1,Y1,X2,Y2); WRITE(JU,'(2F15.3)') X2,Y1 !## lowerrightcorner CALL IDFGETEDGE(PRJIDF,IR1,IC2,X1,Y1,X2,Y2); WRITE(JU,'(2F15.3)') X2,Y2 !## lowerleftcorner CALL IDFGETEDGE(PRJIDF,IR1,IC1,X1,Y1,X2,Y2); WRITE(JU,'(2F15.3)') X1,Y2 !## lowerrightcorner CALL IDFGETEDGE(PRJIDF,IR2,IC1,X1,Y1,X2,Y2); WRITE(JU,'(2F15.3)') X1,Y1 !## lowerleftcorner WRITE(JU,'(A)') 'END' !## write buffer WRITE(KU,'(I10)') I CALL IDFGETEDGE(PRJIDF,IR2,IC1,X1,Y1,X2,Y2) X1M=MAX(X1-LAMBDA,PRJIDF%XMIN); Y1M=MAX(Y1-LAMBDA,PRJIDF%YMIN) CALL IDFGETEDGE(PRJIDF,IR1,IC2,X1,Y1,X2,Y2) X2M=MIN(X2+LAMBDA,PRJIDF%XMAX); Y2M=MIN(Y2+LAMBDA,PRJIDF%YMAX) WRITE(KU,'(2F15.3)') X1M,Y1M WRITE(KU,'(2F15.3)') X2M,Y1M WRITE(KU,'(2F15.3)') X2M,Y2M WRITE(KU,'(2F15.3)') X1M,Y2M WRITE(KU,'(2F15.3)') X1M,Y1M WRITE(KU,'(A)') 'END' !## estimate model PRJMXNLAY CALL UTL_IDFSNAPTOGRID(X1M,X2M,Y1M,Y2M,PRJIDF%DX,NCOL,NROW); NODES=NCOL*NROW*PRJNLAY !## equation for 171 stress-periods TIME=3.0D-13*NODES**2.0D0+4.0D-06*NODES !## for sensitivity TIME=TIME*(1+43) !## parrallel TIME=TIME/10 !## 10 cycles TIME=TIME*10 !## in hours TIME=TIME/60.0D0 TTIME=TTIME+TIME ENDIF ENDDO; ENDDO WRITE(JU,'(A)') 'END' WRITE(KU,'(A)') 'END' CLOSE(JU); CLOSE(KU) PBMAN%NMODELS=I ENDIF ELSE IF(.NOT.IDFALLOCATEX(LOADPTR))RETURN; LOADPTR%X=1.0D0 ALLOCATE(PROC_ICOLMIN(PBMAN%NMODELS),PROC_ICOLMAX(PBMAN%NMODELS),PROC_IROWMIN(PBMAN%NMODELS),PROC_IROWMAX(PBMAN%NMODELS)) !## subdivide submodels CALL PKS7MPISETGNODES(PRJIDF%NCOL,PRJIDF%NROW) CALL PKS7MPIPARTDEF(PBMAN%NMODELS,PROC_ICOLMIN,PROC_ICOLMAX,PROC_IROWMIN,PROC_IROWMAX) DO I=1,PBMAN%NMODELS IC1=PROC_ICOLMIN(I); IC2=PROC_ICOLMAX(I) IR1=PROC_IROWMIN(I); IR2=PROC_IROWMAX(I) DO IR=IR1,IR2; DO IC=IC1,IC2 LOADPTR%X(IC,IR)=REAL(I,8) ENDDO; ENDDO ENDDO ENDIF !## saved submodel pointers - only boss does that IF(PBMAN%BOSS.EQ.1)THEN LOADPTR%FNAME=TRIM(OUTMAPSEPM)//'\LOADPTR.IDF'; IF(.NOT.IDFWRITE(LOADPTR,LOADPTR%FNAME,1))RETURN IF(TRIM(PBMAN%LAMBDAMODELS).NE.'')THEN BUFFPTR%FNAME=TRIM(OUTMAPSEPM)//'\BUFFPTR.IDF'; IF(.NOT.IDFWRITE(BUFFPTR,BUFFPTR%FNAME,1))RETURN ENDIF ENDIF !## store results IF(PBMAN%NWORKERS.EQ.0)THEN IF(PBMAN%WORKER.GT.0)THEN ALLOCATE(IMODEL(SIZE(PBMAN%IMODEL)),IWORKER(SIZE(PBMAN%IMODEL))); IMODEL=0; IWORKER=0 DO I=1,SIZE(IMODEL) IMODEL(I)=PBMAN%IMODEL(I); IWORKER(I)=PBMAN%WORKER ENDDO PBMAN%NMODELS=SIZE(IMODEL) !## write number of model in imodels_worker{i}.txt CALL PMANAGER_SEP_RUNS_WRITE_IMODELS(OUTMAPSEPM,'IMODELS_WORKER'//TRIM(VTOS(PBMAN%WORKER))) ELSE IF(ASSOCIATED(PBMAN%IMODEL))THEN ALLOCATE(IMODEL(SIZE(PBMAN%IMODEL)),IWORKER(SIZE(PBMAN%IMODEL))); IMODEL=0; IWORKER=0 DO I=1,SIZE(IMODEL) IMODEL(I)=PBMAN%IMODEL(I); IWORKER(I)=PBMAN%WORKER ENDDO PBMAN%NMODELS=SIZE(IMODEL) ELSE ALLOCATE(IMODEL(PBMAN%NMODELS),IWORKER(PBMAN%NMODELS)); IMODEL=0; IWORKER=0 !## all are active for this process DO I=1,SIZE(IMODEL); IMODEL(I)=RMID(I); IWORKER(I)=1; ENDDO ENDIF ENDIF ELSE !## getnumber of submodels from workers DO I=1,PBMAN%NWORKERS CALL PMANAGER_SEP_RUNS_READ_IMODELS(OUTMAPSEPM,'IMODELS_WORKER'//TRIM(VTOS(I)),I) ENDDO PBMAN%NMODELS=SIZE(IMODEL) ENDIF ALLOCATE(PSUM(0:PBMAN%NMODELS,0:PBMAN%NCYCLE)); PSUM%TOBJ=0.0D0; PSUM%LAMBDA=0.0D0 ALLOCATE(SUBMDL(0:PBMAN%NMODELS)) !## check whether submodels are present in loadptr.idf WRITE(*,'(/4A10)') 'NO','WORKER','SUBMODEL','ACTIVE' NJ=0; DO I=1,SIZE(IMODEL) J=0; DO IROW=1,LOADPTR%NROW; DO ICOL=1,LOADPTR%NCOL IF(LOADPTR%X(ICOL,IROW).EQ.REAL(IMODEL(I),8))J=J+1 ENDDO; ENDDO WRITE(*,'(4I10)') I,IWORKER(I),IMODEL(I),J; NJ=NJ+J; IF(J.EQ.0)IMODEL(I)=0 ENDDO IF(NJ.EQ.0)THEN WRITE(*,'(/A/)') '>>> Nothing to do, process stopped <<<'; STOP ELSE NJ=0; DO I=1,SIZE(IMODEL); IF(IMODEL(I).NE.0)NJ=NJ+1; ENDDO WRITE(*,'(/A/)') '>>> Found '//TRIM(VTOS(NJ))//' active models <<<' ENDIF SUBMDL(0)%X1 =PRJIDF%XMIN; SUBMDL(0)%X2 =PRJIDF%XMAX SUBMDL(0)%Y1 =PRJIDF%YMIN; SUBMDL(0)%Y2 =PRJIDF%YMAX SUBMDL(0)%DX =PRJIDF%DX; SUBMDL(0)%BUF=0.0D0; SUBMDL(0)%BDX=0.0D0 !## use specified window PBMAN%IWINDOW=2 !GOTO 10 !## clean all files to be finished for icycle+1,pbman%ncycle IF(PBMAN%BOSS.EQ.1)CALL PMANAGER_SEP_RUNS_CLEAN(OUTMAPSEPM) ICYCLE=0; PBMAN%ICYCLE=ICYCLE DO IF(PBMAN%BOSS.EQ.1)THEN !## run done already? LEX=PMANAGER_SEP_RUNS_READ_DONE(OUTMAPSEPM,'RUNFINISHED',PBMAN%ICYCLE) !## carry out model run if not yet available IF(.NOT.LEX)THEN WRITE(*,'(/A)') '>>> Start running initial global model <<<' !## delete IF(PBMAN%IEXPORTMF2005.EQ.1)THEN INQUIRE(FILE=NAMFILE(:INDEX(NAMFILE,'\',.TRUE.)-1)//'\PARAM_DUMP_IPEST_IMOD.DAT',EXIST=LEX) IF(LEX)CALL IOSDELETEFILE(NAMFILE(:INDEX(NAMFILE,'\',.TRUE.)-1)//'\PARAM_DUMP_IPEST_IMOD.DAT') ENDIF PBMAN%XMIN =SUBMDL(0)%X1; PBMAN%YMIN =SUBMDL(0)%Y1 PBMAN%XMAX =SUBMDL(0)%X2; PBMAN%YMAX =SUBMDL(0)%Y2 PBMAN%CELLSIZE =SUBMDL(0)%DX; PBMAN%BUFFER =SUBMDL(0)%BUF; PBMAN%BUFFERCS =SUBMDL(0)%BDX !## run base model turn off optimization, turn on head and flux-saving set # ipestp iteration to be -1 to get residuals IF(ASSOCIATED(PBMAN%ISAVE(TSHD)%ILAY))DEALLOCATE(PBMAN%ISAVE(TSHD)%ILAY); ALLOCATE(PBMAN%ISAVE(TSHD)%ILAY(1)); PBMAN%ISAVE(TSHD)%ILAY(1)=-1 IF(ASSOCIATED(PBMAN%ISAVE(TKHV)%ILAY))DEALLOCATE(PBMAN%ISAVE(TKHV)%ILAY); ALLOCATE(PBMAN%ISAVE(TKHV)%ILAY(1)); PBMAN%ISAVE(TKHV)%ILAY(1)=-1 PBMAN%RUNFILE=NAMFILE; PBMAN%OUTPUT=OUTMAP !## use window from speficied window PBMAN%IWINDOW=2 !## run the original model PE_MXITER_BU=PEST%PE_MXITER; PEST%PE_MXITER=-1 IF(.NOT.PMANAGERRUN(ID,NAMFILE,IBATCH))THEN; WRITE(*,'(/A/)') 'Error running runfile '//TRIM(NAMFILE); STOP; ENDIF CALL PMANAGER_SEP_RUNS_WRITE_DONE(OUTMAPSEPM,'RUNFINISHED',PBMAN%ICYCLE) PEST%PE_MXITER=PE_MXITER_BU !## deallocate measurements CALL IPEST_GLM_DEALLOCATEMSR() ELSE WRITE(*,'(/A)') '>>> Skipping computing global model <<<' !## set up timestepping, neccessary for prj file to be saved with fhb LEX=PMANAGER_INITSIM(PBMAN%RUNFILE,IBATCH,IRUN); PBMAN%RUNFILE=NAMFILE ENDIF CALL PMANAGER_SEP_RUNS_WRITE_DONE(OUTMAPSEPM,'MDLPRESENT',PBMAN%ICYCLE) ELSE !## wait until the boss is finished CALL PMANAGER_SEP_RUNS_WAIT_FOR_ALL_DONE(OUTMAPSEPM,'RUNFINISHED',ICYCLE)!,IMODEL) !## set up timestepping, neccessary for prj file to be saved with fhb LEX=PMANAGER_INITSIM(PBMAN%RUNFILE,IBATCH,IRUN); PBMAN%RUNFILE=NAMFILE ENDIF !## construct boundary - not for the boss IF(ICYCLE.EQ.0.AND.PBMAN%NWORKERS.EQ.0)THEN CALL PMANAGER_SEPMODEL_BND(OUTMAPSEPM,LOADPTR,BUFFPTR) ENDIF !## construct fhb package CALL PMANAGER_SEPMODEL_FHB(OUTMAPSEPM) CALL PMANAGER_INITSIM_DEAL(0) !## turn on optimization IF(PBMAN%IPESTP.EQ.1)TOPICS(TPST)%IACT_MODEL=1 IF(PBMAN%IIES.EQ.1) TOPICS(TIES)%IACT_MODEL=1 !## save prj files per sepmodel IF(ICYCLE.EQ.0.AND.PBMAN%NWORKERS.EQ.0)THEN DO I=1,PBMAN%NMODELS IF(IMODEL(I).EQ.0)CYCLE !## add appropriate bnd files to the prj file CALL PMANAGER_SEPMODEL_ADDBND(OUTMAPSEPM,IMODEL(I)) !## save project file PBMAN%PRJFILE=TRIM(OUTMAPSEPM)//'\SEPMODEL'//TRIM(VTOS(IMODEL(I)))//'\'//TRIM(MNAME)//'_CYCLE'//TRIM(VTOS(ICYCLE))//'.PRJ' CALL UTL_CREATEDIR(TRIM(OUTMAPSEPM)//'\SEPMODEL'//TRIM(VTOS(IMODEL(I)))) IF(.NOT.PMANAGERPRJ(ID_SAVE,PBMAN%PRJFILE,1,0))THEN; WRITE(*,'(/A/)') 'Error writing project file '//TRIM(PBMAN%PRJFILE); STOP; ENDIF ENDDO ENDIF !## update cycle ICYCLE=ICYCLE+1; IF(ICYCLE.GT.PBMAN%NCYCLE)EXIT; PBMAN%ICYCLE=ICYCLE !## restore output settings IF(ASSOCIATED(PBMAN%ISAVE(TSHD)%ILAY))DEALLOCATE(PBMAN%ISAVE(TSHD)%ILAY) M=SIZE(SAVESHD); ALLOCATE(PBMAN%ISAVE(TSHD)%ILAY(M)); PBMAN%ISAVE(TSHD)%ILAY=SAVESHD IF(ASSOCIATED(PBMAN%ISAVE(TKHV)%ILAY))DEALLOCATE(PBMAN%ISAVE(TKHV)%ILAY) M=SIZE(SAVEFLX); ALLOCATE(PBMAN%ISAVE(TKHV)%ILAY(M)); PBMAN%ISAVE(TKHV)%ILAY=SAVEFLX !## start optimizing separate models DO I=1,PBMAN%NMODELS !## skip sensitivities simulations for the boss IF(PBMAN%NWORKERS.GT.0)CYCLE !## skip this model for this process- not existing IF(IMODEL(I).EQ.0)CYCLE PBMAN%XMIN =SUBMDL(I)%X1; PBMAN%YMIN =SUBMDL(I)%Y1 PBMAN%XMAX =SUBMDL(I)%X2; PBMAN%YMAX =SUBMDL(I)%Y2 PBMAN%CELLSIZE =SUBMDL(I)%DX; PBMAN%BUFFER =SUBMDL(I)%BUF; PBMAN%BUFFERCS =SUBMDL(I)%BDX !## load this prj-file PBMAN%PRJFILE=TRIM(OUTMAPSEPM)//'\SEPMODEL'//TRIM(VTOS(IMODEL(I)))//'\'//TRIM(MNAME)//'_CYCLE'//TRIM(VTOS(ICYCLE-1))//'.PRJ' IF(.NOT.PMANAGERPRJ(ID_OPEN ,PBMAN%PRJFILE,1,0))THEN; WRITE(*,'(/A/)') 'Error reading project file '//TRIM(PBMAN%PRJFILE); STOP; ENDIF !## set output names PBMAN%RUNFILE=NAMFILE(:INDEX(NAMFILE,'\',.TRUE.)-1)//'\SEPMODEL'//TRIM(VTOS(IMODEL(I)))//'\SEPMODEL'//TRIM(VTOS(IMODEL(I)))//'.NAM' PBMAN%OUTPUT=TRIM(OUTMAP)//'\SEPMODEL'//TRIM(VTOS(IMODEL(I))) IPESTPOUTPUT=PBMAN%IPESTPOUTPUT IF(INDEX(PBMAN%IPESTPOUTPUT,'$MODEL$').GT.0)THEN CALL UTL_SUBST(PBMAN%IPESTPOUTPUT,'$MODEL$','SEPMODEL'//TRIM(VTOS((IMODEL(I))))) ENDIF !## skip in restart mode LEX=PMANAGER_SEP_RUNS_READ_DONE(TRIM(OUTMAPSEPM)//'\SEPMODEL'//TRIM(VTOS(IMODEL(I))),'RUNFINISHED',PBMAN%ICYCLE) !## carry out optimization IF(.NOT.LEX)THEN WRITE(*,'(/A)') '>>> Start running sepmodel '//TRIM(VTOS(IMODEL(I)))//' <<<' !## delete INQUIRE(FILE=NAMFILE(:INDEX(NAMFILE,'\',.TRUE.)-1)//'\SEPMODEL'//TRIM(VTOS(IMODEL(I)))//'\PARAM_DUMP_IPEST.DAT',EXIST=LEX) IF(LEX)CALL IOSDELETEFILE(NAMFILE(:INDEX(NAMFILE,'\',.TRUE.)-1)//'\SEPMODEL'//TRIM(VTOS(IMODEL(I)))//'\PARAM_DUMP_IPEST.DAT') ! IF(ASSOCIATED(PBMAN%ISAVE(TSHD)%ILAY))DEALLOCATE(PBMAN%ISAVE(TSHD)%ILAY) !; ALLOCATE(PBMAN%ISAVE(TSHD)%ILAY(1)); PBMAN%ISAVE(TSHD)%ILAY(1)=-1 ! IF(ASSOCIATED(PBMAN%ISAVE(TKHV)%ILAY))DEALLOCATE(PBMAN%ISAVE(TKHV)%ILAY) !; ALLOCATE(PBMAN%ISAVE(TKHV)%ILAY(1)); PBMAN%ISAVE(TKHV)%ILAY(1)=-1 !## optimize separate model IF(.NOT.PMANAGERRUN(ID,PBMAN%RUNFILE,IBATCH))THEN; WRITE(*,'(/A/)') 'Error running '//TRIM(PBMAN%PRJFILE); STOP; ENDIF CALL PMANAGER_SEP_RUNS_WRITE_DONE(TRIM(OUTMAPSEPM)//'\SEPMODEL'//TRIM(VTOS(IMODEL(I))),'RUNFINISHED',PBMAN%ICYCLE) CALL PMANAGER_SEP_RUNS_WRITE_DONE(TRIM(OUTMAPSEPM)//'\SEPMODEL'//TRIM(VTOS(IMODEL(I))),'MDLPRESENT' ,PBMAN%ICYCLE) !## deallocate measurements CALL IPEST_GLM_DEALLOCATEMSR() !## read log_pest_runfile.txt as those does not contain possible adjustments ELSE WRITE(*,'(/A)') '>>> Skipping existing sepmodel '//TRIM(VTOS(IMODEL(I)))//' for icycle '//TRIM(VTOS(ICYCLE))//' <<<' ENDIF CALL PMANAGER_SEP_RUNS_WRITE_DONE(TRIM(OUTMAPSEPM)//'\SEPMODEL'//TRIM(VTOS(IMODEL(I))),'MDLPRESENT',PBMAN%ICYCLE) CALL PMANAGER_INITSIM_DEAL(0) PBMAN%IPESTPOUTPUT=IPESTPOUTPUT ENDDO IF(TOPICS(TPST)%IACT_MODEL.EQ.0)RETURN !## stop if only needed to compute sensitivities !## update parameters from aggregating global results IF(PBMAN%OUTERUPDATE.EQ.1.AND.PBMAN%BOSS.EQ.1)THEN !## check whether all models are finished, if not ... wait CALL PMANAGER_SEP_RUNS_WAIT_FOR_ALL_DONE(OUTMAPSEPM,'RUNFINISHED',PBMAN%ICYCLE) !## check whether all models are present, if not ... wait CALL PMANAGER_SEP_RUNS_WAIT_FOR_ALL_DONE(OUTMAPSEPM,'MDLPRESENT',PBMAN%ICYCLE) WRITE(*,'(/A)') '>>> Start aggregating sepmodel results and computing global gradient' !## reload original prj-file PBMAN%PRJFILE=PRJFILE IF(.NOT.PMANAGERPRJ(ID_OPEN ,PBMAN%PRJFILE,1,0))THEN; WRITE(*,'(/A/)') 'Error reading project file '//TRIM(PBMAN%PRJFILE); STOP; ENDIF !## compute lambda's CALL PMANAGER_SEP_ESTIMATE_LAMBDA(OUTMAPSEPM,PSUM(1:PBMAN%NMODELS,ICYCLE)%LAMBDA,ICYCLE) !## combine jacobians from all submodels IF(.NOT.PMANAGER_SEP_JACOBIAN_UPDATE(IBATCH,ICYCLE,PSUM(1:PBMAN%NMODELS,ICYCLE)%LAMBDA,TRIM(OUTMAPSEPM),LOADPTR))EXIT WRITE(*,'(A/)') ' Finished computing global gradient <<<' !## save new major prj-file PBMAN%PRJFILE=TRIM(OUTMAPSEPM)//'\'//TRIM(MNAME)//'_CYCLE'//TRIM(VTOS(ICYCLE))//'.PRJ' IF(.NOT.PMANAGERPRJ(ID_SAVE,PBMAN%PRJFILE,1,0))THEN; WRITE(*,'(/A/)') 'Error writing project file '//TRIM(PBMAN%PRJFILE); STOP; ENDIF !## set up timestepping, neccessary for prj file to be saved with fhb LEX=PMANAGER_INITSIM(PBMAN%RUNFILE,IBATCH,IRUN); PBMAN%RUNFILE=NAMFILE !## add fhb package CALL PMANAGER_SEPMODEL_FHB(OUTMAPSEPM) !NAMFILE) !# save to all prj files per sep model DO I=1,PBMAN%NMODELS IF(IMODEL(I).EQ.0)CYCLE !## add appropriate bnd files to the prj file CALL PMANAGER_SEPMODEL_ADDBND(OUTMAPSEPM,IMODEL(I)) !## save project file PBMAN%PRJFILE=TRIM(OUTMAPSEPM)//'\SEPMODEL'//TRIM(VTOS(IMODEL(I)))//'\'//TRIM(MNAME)//'_CYCLE'//TRIM(VTOS(ICYCLE))//'.PRJ' IF(.NOT.PMANAGERPRJ(ID_SAVE,PBMAN%PRJFILE,1,0))THEN; WRITE(*,'(/A/)') 'Error writing project file '//TRIM(PBMAN%PRJFILE); STOP; ENDIF ENDDO CALL PMANAGER_INITSIM_DEAL(0) CALL PMANAGER_SEP_RUNS_WRITE_DONE(OUTMAPSEPM,'GRADFINISHED',PBMAN%ICYCLE) ELSE IF(PBMAN%BOSS.EQ.0)THEN !## wait for gradient computation to finish CALL PMANAGER_SEP_RUNS_WAIT_FOR_ALL_DONE(OUTMAPSEPM,'GRADFINISHED',ICYCLE) ENDIF ENDIF IF(PBMAN%BOSS.EQ.1)THEN !## set new prj-file PBMAN%PRJFILE=TRIM(OUTMAPSEPM)//'\'//TRIM(MNAME)//'_CYCLE'//TRIM(VTOS(ICYCLE))//'.PRJ' ! PBMAN%PRJFILE=NAMFILE(:INDEX(NAMFILE,'.',.TRUE.)-1)//'_CYCLE'//TRIM(VTOS(ICYCLE))//'.PRJ' !## use this as base for next cycle PRJFILE=PBMAN%PRJFILE IF(.NOT.PMANAGERPRJ(ID_OPEN ,PBMAN%PRJFILE,1,0))THEN; WRITE(*,'(/A/)') 'Error reading project file '//TRIM(PBMAN%PRJFILE); STOP; ENDIF ENDIF PBMAN%SKIPMODEL=-1*PBMAN%SKIPMODEL ! exit !## next outer cycle ENDDO !## finished if not the boss IF(PBMAN%BOSS.EQ.0)THEN; PMANAGER_SEP_RUNS=.TRUE.; RETURN; ENDIF !10 CONTINUE DO ICYCLE=0,PBMAN%NCYCLE WRITE(*,'(/A)') '>>> Reading results from global and local models icycle '//TRIM(VTOS(ICYCLE))//' <<<' KU=UTL_GETUNIT(); OPEN(KU,FILE=TRIM(OUTMAPSEPM)//'\IPEST\LOG_PEST_EFFICIENCY_ICYCLE'//TRIM(VTOS(ICYCLE))//'.TXT',STATUS='OLD',FORM='FORMATTED',ACTION='READ',IOSTAT=IOS) IF(IOS.EQ.0)THEN READ(KU,*); READ(KU,*); READ(KU,*) PSUM(0,ICYCLE)%TOBJ; DO; READ(KU,*,IOSTAT=IOS) PSUM(0,ICYCLE)%TOBJ; IF(IOS.NE.0)EXIT; ENDDO; CLOSE(KU) ENDIF IF(ICYCLE.GT.0)THEN DO I=1,PBMAN%NMODELS IF(IMODEL(I).EQ.0)CYCLE KU=UTL_GETUNIT(); OPEN(KU,FILE=TRIM(OUTMAPSEPM)//'\SEPMODEL'//TRIM(VTOS(IMODEL(I)))//'\IPEST\LOG_PEST_EFFICIENCY_ICYCLE'//TRIM(VTOS(ICYCLE))//'.TXT', & STATUS='OLD',FORM='FORMATTED',ACTION='READ',IOSTAT=IOS) IF(IOS.EQ.0)THEN READ(KU,*); READ(KU,*) IF(ICYCLE.EQ.1)THEN READ(KU,*) PSUM(I,ICYCLE-1)%TOBJ ELSE READ(KU,*) PSUM(I,ICYCLE)%TOBJ ENDIF DO; READ(KU,*,IOSTAT=IOS) PSUM(I,ICYCLE)%TOBJ; IF(IOS.NE.0)EXIT; ENDDO; CLOSE(KU) ELSE IF(ICYCLE.EQ.1)PSUM(I,ICYCLE-1)%TOBJ=-999.99D0 IF(ICYCLE.NE.1)PSUM(I,ICYCLE )%TOBJ=-999.99D0 ENDIF ENDDO ENDIF ENDDO JU=UTL_GETUNIT(); OPEN(JU,FILE=TRIM(OUTMAPSEPM)//'\IPESTP_SEPMODELLING.TXT',STATUS='UNKNOWN',FORM='FORMATTED',ACTION='WRITE') WRITE(JU,'(A/)') 'SUMMARY OF SEP-MODELLING' WRITE(JU,'(99A15)') 'MODEL','OBJ.F.',('ICYCLE'//TRIM(VTOS(ICYCLE)),ICYCLE=1,PBMAN%NCYCLE) DO I=0,PBMAN%NMODELS IF(I.EQ.0)THEN WRITE(JU,'(15X,99F15.3)') (PSUM(I,ICYCLE)%TOBJ,ICYCLE=0,PBMAN%NCYCLE) ELSE IF(IMODEL(I).EQ.0)CYCLE WRITE(JU,'(I15,99F15.3)') IMODEL(I),(PSUM(I,ICYCLE)%TOBJ,ICYCLE=0,PBMAN%NCYCLE) ENDIF ENDDO !## save performance per cycle for all submodels in idf CALL IDFDEALLOCATEX(IDF); CALL IDFCOPY(LOADPTR,IDF) DO ICYCLE=1,PBMAN%NCYCLE IF(.NOT.IDFALLOCATEX(IDF))STOP IDF%X=0.0D0 DO I=1,PBMAN%NMODELS IF(IMODEL(I).EQ.0)CYCLE IF(PSUM(I,0)%TOBJ.NE.0.0D0)THEN F=100.0D0*(1.0D0-PSUM(I,ICYCLE)%TOBJ/PSUM(I,0)%TOBJ) ELSE F=IDF%NODATA ENDIF DO IROW=1,LOADPTR%NROW; DO ICOL=1,LOADPTR%NCOL IF(LOADPTR%X(ICOL,IROW).EQ.REAL(IMODEL(I),8))IDF%X(ICOL,IROW)=F ENDDO; ENDDO ENDDO IDF%FNAME=TRIM(OUTMAPSEPM)//'\IPESTP_SEPMODELLING\EFFICIENCY'//TRIM(VTOS(ICYCLE))//'.IDF' IF(.NOT.IDFWRITE(IDF,IDF%FNAME,1))STOP ENDDO !## get all factors DO I=0,PBMAN%NMODELS DO ICYCLE=1,PBMAN%NCYCLE IF(I.EQ.0)THEN FNAME=TRIM(OUTMAPSEPM)//'\IPEST\LOG_PEST_RUNFILE_ICYCLE'//TRIM(VTOS(ICYCLE))//'.TXT' ELSE IF(IMODEL(I).EQ.0)CYCLE FNAME=TRIM(OUTMAPSEPM)//'\SEPMODEL'//TRIM(VTOS(IMODEL(I)))//'\IPEST\LOG_PEST_RUNFILE_ICYCLE'//TRIM(VTOS(ICYCLE))//'.TXT' ENDIF INQUIRE(FILE=FNAME,EXIST=LEX) WRITE(*,'(L1,A)') LEX,' '//TRIM(FNAME) IF(LEX)THEN KU=UTL_GETUNIT(); OPEN(KU,FILE=FNAME,STATUS='OLD',FORM='FORMATTED',ACTION='READ') DO READ(KU,'(A256)',IOSTAT=IOS) LINE; IF(IOS.NE.0)EXIT IF(INDEX(LINE,'Copy in the runfile').GT.0)THEN READ(KU,*) IF(.NOT.ASSOCIATED(PSUM(I,ICYCLE)%ALPHA))ALLOCATE(PSUM(I,ICYCLE)%ALPHA(SIZE(PEST%PARAM))) DO J=1,SIZE(PEST%PARAM) READ(KU,*) PEST%PARAM(J)%PACT,PEST%PARAM(J)%PPARAM,PEST%PARAM(J)%PILS,PEST%PARAM(J)%PIZONE,PSUM(I,ICYCLE)%ALPHA(J) ENDDO ENDIF ENDDO CLOSE(KU) ENDIF IF(.NOT.ASSOCIATED(PSUM(I,ICYCLE)%ALPHA))THEN ALLOCATE(PSUM(I,ICYCLE)%ALPHA(SIZE(PEST%PARAM))); PSUM(I,ICYCLE)%ALPHA=-999.99D0 !1.0D0 ENDIF ENDDO ENDDO N=0; DO I=1,PBMAN%NMODELS; IF(IMODEL(I).GT.0)N=N+1; ENDDO; ALLOCATE(JMODEL(N)) N=0; DO I=1,PBMAN%NMODELS; IF(IMODEL(I).LE.0)CYCLE; N=N+1; JMODEL(N)=I; ENDDO ALLOCATE(FCT(N)) DO ICYCLE=1,PBMAN%NCYCLE WRITE(JU,'(/A10,I10)') 'ICYCLE=',ICYCLE WRITE(JU,'(A5,1X,A2,1X,A15,999(1X,A10))') 'IPRM','PT','PARAM','F_FINAL','MEAN','STDEV',('F_MDL'//TRIM(VTOS(JMODEL(I))),I=1,N) !PBMAN%NMODELS) DO J=1,SIZE(PEST%PARAM) N=0; DO I=1,PBMAN%NMODELS; IF(IMODEL(I).GT.0)THEN; N=N+1; FCT(N)=PSUM(I,ICYCLE)%ALPHA(J); ENDIF; ENDDO CALL UTL_STDEF(FCT,N,-999.99D0,STDEV,XT,NPOP) WRITE(JU,'(I5,1X,A2,1X,A15,999(1X,F10.3))') J,PEST%PARAM(J)%PPARAM,PEST%PARAM(J)%ACRONYM,PSUM(0,ICYCLE)%ALPHA(J),XT,STDEV,(PSUM(JMODEL(I),ICYCLE)%ALPHA(J),I=1,N) !PBMAN%NMODELS) ENDDO ENDDO DEALLOCATE(FCT,JMODEL) CLOSE(JU) !## clean up memory CALL PMANAGER_INITSIM_DEAL(1) PMANAGER_SEP_RUNS=.TRUE. END FUNCTION PMANAGER_SEP_RUNS !###====================================================================== SUBROUTINE PMANAGER_SEP_RUNS_CLEAN(FOLDER) !###====================================================================== IMPLICIT NONE CHARACTER(LEN=*),INTENT(IN) :: FOLDER CHARACTER(LEN=256) :: FNAME INTEGER :: I,J,J1 LOGICAL :: LEX !## reset workers IF(PBMAN%RESETWORKERS.EQ.1)THEN DO I=1,PBMAN%NMODELS WRITE(*,'(A)') 'Cleaning MODEL '//TRIM(VTOS(IMODEL(I)))//' ...' DO J=1,PBMAN%NCYCLE FNAME=TRIM(FOLDER)//'\SEPMODEL'//TRIM(VTOS(IMODEL(I)))//'\RUNFINISHED_CYCLE'//TRIM(VTOS(J))//'.TXT' INQUIRE(FILE=FNAME,EXIST=LEX); IF(LEX)CALL IOSDELETEFILE(FNAME) ENDDO DO J=1,PBMAN%NCYCLE FNAME=TRIM(FOLDER)//'\SEPMODEL'//TRIM(VTOS(IMODEL(I)))//'\MDLPRESENT_CYCLE'//TRIM(VTOS(J))//'.TXT' INQUIRE(FILE=FNAME,EXIST=LEX); IF(LEX)CALL IOSDELETEFILE(FNAME) ENDDO ENDDO ENDIF J1=0; IF(PBMAN%SKIPMODEL.EQ.1)J1=1 DO J=J1,PBMAN%NCYCLE FNAME=TRIM(FOLDER)//'\MDLPRESENT_CYCLE'//TRIM(VTOS(J))//'.TXT' INQUIRE(FILE=FNAME,EXIST=LEX); IF(LEX)CALL IOSDELETEFILE(FNAME) FNAME=TRIM(FOLDER)//'\RUNFINISHED_CYCLE'//TRIM(VTOS(J))//'.TXT' INQUIRE(FILE=FNAME,EXIST=LEX); IF(LEX)CALL IOSDELETEFILE(FNAME) FNAME=TRIM(FOLDER)//'\GRADFINISHED_CYCLE'//TRIM(VTOS(J))//'.TXT' INQUIRE(FILE=FNAME,EXIST=LEX); IF(LEX)CALL IOSDELETEFILE(FNAME) ENDDO END SUBROUTINE PMANAGER_SEP_RUNS_CLEAN !###====================================================================== SUBROUTINE PMANAGER_SEP_RUNS_WAIT_FOR_ALL_DONE(FOLDER,FNAME,ICYCLE) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ICYCLE CHARACTER(LEN=*),INTENT(IN) :: FOLDER,FNAME INTEGER :: I,N,M,NM INTEGER,ALLOCATABLE,DIMENSION(:) :: MPRES !## no boss existing IF(PBMAN%OUTERUPDATE.EQ.0.AND.PBMAN%BOSS.EQ.0)RETURN NM=0; DO I=1,PBMAN%NMODELS; IF(IMODEL(I).NE.0)NM=NM+1; ENDDO SELECT CASE (FNAME) CASE('RUNFINISHED') IF(PBMAN%BOSS.EQ.0)THEN WRITE(*,'(/A)') '>>> Waiting for initial global model to be finished' WRITE(*,'( A)') ' Searching for: '//TRIM(FOLDER)//'\'//TRIM(FNAME)//'_CYCLE'//TRIM(VTOS(ICYCLE))//'.TXT' N=0; DO IF(PMANAGER_SEP_RUNS_READ_DONE(TRIM(FOLDER),FNAME,ICYCLE))EXIT N=N+1; WRITE(6,'(A)') '+Waiting for initial global model to be finished for '//TRIM(VTOS(NWAIT*N))//' seconds ' CALL IOSWAIT(NWAIT*100) ENDDO WRITE(*,'(A/)') ' Found results for the initial global model<<<' ELSE WRITE(*,'(/A)') '>>> Getting finished models' ALLOCATE(MPRES(PBMAN%NMODELS)) M=0; DO MPRES=0; N=0; DO I=1,PBMAN%NMODELS IF(IMODEL(I).EQ.0)THEN; MPRES(I)=-1; CYCLE; ENDIF IF(PMANAGER_SEP_RUNS_READ_DONE(TRIM(FOLDER)//'\SEPMODEL'//TRIM(VTOS(IMODEL(I))),FNAME,ICYCLE))THEN; N=N+1; MPRES(I)=1; ENDIF ENDDO IF(N.EQ.NM)EXIT; M=M+1 IF(SUM(MPRES).NE.PBMAN%NMODELS)THEN WRITE(*,'(2A10)') 'MODEL','SEPMODEL' DO I=1,PBMAN%NMODELS IF(MPRES(I).EQ.0)WRITE(*,'(2I10)') I,IMODEL(I) ENDDO ENDIF WRITE(6,'(A)') '+Found '//TRIM(VTOS(N))//' sepmodels finished, waiting for '//TRIM(VTOS(NM-N))//' to finish for '//TRIM(VTOS(NWAIT*M))//' seconds ' CALL IOSWAIT(NWAIT*100) ENDDO DEALLOCATE(MPRES); WRITE(*,'(/A)') ' All finished models found <<<' ENDIF CASE('MDLPRESENT') IF(PBMAN%BOSS.EQ.1)THEN WRITE(*,'(/A)') '>>> Getting presency of models' ALLOCATE(MPRES(PBMAN%NMODELS)) M=0; MPRES=0; DO N=0; DO I=1,PBMAN%NMODELS IF(IMODEL(I).EQ.0)THEN; MPRES(I)=-1; CYCLE; ENDIF IF(PMANAGER_SEP_RUNS_READ_DONE(TRIM(FOLDER)//'\SEPMODEL'//TRIM(VTOS(IMODEL(I))),FNAME,ICYCLE))THEN; N=N+1; MPRES(I)=1; ENDIF ENDDO IF(N.EQ.NM)EXIT; M=M+1 IF(SUM(MPRES).NE.PBMAN%NMODELS)THEN WRITE(*,'(2A10)') 'MODEL','SEPMODEL' DO I=1,PBMAN%NMODELS IF(MPRES(I).EQ.0)WRITE(*,'(2I10)') I,IMODEL(I) ENDDO ENDIF WRITE(6,'(A)') '+Found '//TRIM(VTOS(N))//' sepmodels present, waiting for '//TRIM(VTOS(NM-N))//' to present for '//TRIM(VTOS(NWAIT*M))//' seconds ' CALL IOSWAIT(NWAIT*100) ENDDO DEALLOCATE(MPRES); WRITE(*,'(/A)') ' All models present <<<' ENDIF CASE ('GRADFINISHED') WRITE(*,'(/A)') '>>> Waiting for gradient-computaton to be finished' N=0; DO IF(PMANAGER_SEP_RUNS_READ_DONE(TRIM(FOLDER),FNAME,ICYCLE))EXIT N=N+1; WRITE(6,'(A)') '+Waiting for gradient-computation to be finished for '//TRIM(VTOS(NWAIT*N))//' seconds ' CALL IOSWAIT(NWAIT*100) ENDDO WRITE(*,'(A/)') ' Found <<<' END SELECT END SUBROUTINE PMANAGER_SEP_RUNS_WAIT_FOR_ALL_DONE !###====================================================================== LOGICAL FUNCTION PMANAGER_SEP_RUNS_READ_DONE(FOLDER,FNAME,ICYCLE) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ICYCLE CHARACTER(LEN=*),INTENT(IN) :: FOLDER,FNAME INTEGER :: IU,IOS CHARACTER(LEN=2) :: STATUS LOGICAL :: LEX PMANAGER_SEP_RUNS_READ_DONE=.FALSE. !## skip in restart mode INQUIRE(FILE=TRIM(FOLDER)//'\'//TRIM(FNAME)//'_CYCLE'//TRIM(VTOS(ICYCLE))//'.TXT',EXIST=LEX) IF(LEX)THEN IU=UTL_GETUNIT() OPEN(IU,FILE=TRIM(FOLDER)//'\'//TRIM(FNAME)//'_CYCLE'//TRIM(VTOS(ICYCLE))//'.TXT',STATUS='OLD',ACTION='READ',IOSTAT=IOS) IF(IOS.EQ.0)THEN READ(IU,'(A2)') STATUS IF(STATUS.EQ.'OK')PMANAGER_SEP_RUNS_READ_DONE=.TRUE. CLOSE(IU) ENDIF ENDIF END FUNCTION PMANAGER_SEP_RUNS_READ_DONE !###====================================================================== SUBROUTINE PMANAGER_SEP_RUNS_WRITE_DONE(FOLDER,FNAME,ICYCLE) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ICYCLE CHARACTER(LEN=*),INTENT(IN) :: FOLDER,FNAME INTEGER :: IU,IOS WRITE(*,*) 'FILENAME='//TRIM(FOLDER)//'\'//TRIM(FNAME)//'_CYCLE'//TRIM(VTOS(ICYCLE))//'.TXT' !## skip in restart mode IU=UTL_GETUNIT() OPEN(IU,FILE=TRIM(FOLDER)//'\'//TRIM(FNAME)//'_CYCLE'//TRIM(VTOS(ICYCLE))//'.TXT',STATUS='UNKNOWN',ACTION='WRITE',IOSTAT=IOS) IF(IOS.EQ.0)THEN WRITE(IU,'(A2)') 'OK' CLOSE(IU) ENDIF END SUBROUTINE PMANAGER_SEP_RUNS_WRITE_DONE !###====================================================================== SUBROUTINE PMANAGER_SEP_RUNS_WRITE_IMODELS(FOLDER,FNAME) !###====================================================================== IMPLICIT NONE CHARACTER(LEN=*),INTENT(IN) :: FOLDER,FNAME INTEGER :: IU,IOS !## skip in restart mode IU=UTL_GETUNIT(); OPEN(IU,FILE=TRIM(FOLDER)//'\'//TRIM(FNAME)//'.TXT',STATUS='UNKNOWN',ACTION='WRITE',IOSTAT=IOS) IF(IOS.EQ.0)THEN WRITE(IU,'(I10)') SIZE(IMODEL) DO I=1,SIZE(IMODEL); WRITE(IU,'(I10)') IMODEL(I); ENDDO CLOSE(IU) ENDIF END SUBROUTINE PMANAGER_SEP_RUNS_WRITE_IMODELS !###====================================================================== SUBROUTINE PMANAGER_SEP_RUNS_READ_IMODELS(FOLDER,FNAME,IW) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: IW CHARACTER(LEN=*),INTENT(IN) :: FOLDER,FNAME INTEGER,DIMENSION(:),ALLOCATABLE :: JMODELS,JWORKER INTEGER :: I,IU,IOS,N,M,NN WRITE(*,'(/A)') '>>> Waiting for submodels '//TRIM(FNAME)// '...' IU=UTL_GETUNIT(); N=0; DO OPEN(IU,FILE=TRIM(FOLDER)//'\'//TRIM(FNAME)//'.TXT',STATUS='OLD',ACTION='READ',IOSTAT=IOS) IF(IOS.EQ.0)THEN READ(IU,'(I10)',IOSTAT=IOS) M IF(ALLOCATED(IMODEL))THEN NN=SIZE(IMODEL); ALLOCATE(JMODELS(NN)); JMODELS=IMODEL DEALLOCATE(IMODEL); ALLOCATE(IMODEL(NN+M)) DO I=1,NN; IMODEL(I)=JMODELS(I); ENDDO DEALLOCATE(JMODELS) ELSE ALLOCATE(IMODEL(M)); NN=0 ENDIF IF(ALLOCATED(IWORKER))THEN NN=SIZE(IWORKER); ALLOCATE(JWORKER(NN)); JWORKER=IWORKER DEALLOCATE(IWORKER); ALLOCATE(IWORKER(NN+M)); IWORKER=0 DO I=1,NN; IWORKER(I)=JWORKER(I); ENDDO DEALLOCATE(JWORKER) ELSE ALLOCATE(IWORKER(M)); NN=0 ENDIF IF(IOS.EQ.0)THEN DO I=1,M; READ(IU,'(I10)',IOSTAT=IOS) IMODEL(NN+I); IWORKER(NN+I)=IW; IF(IOS.NE.0)EXIT; ENDDO ENDIF CLOSE(IU); IF(IOS.EQ.0)EXIT ENDIF N=N+1; WRITE(6,'(A)') '+Waiting for submodels for '//TRIM(VTOS(NWAIT*N))//' seconds ' CALL IOSWAIT(NWAIT*100) ENDDO WRITE(*,'(A)') ' Found '//TRIM(VTOS(M))//' submodels <<<' END SUBROUTINE PMANAGER_SEP_RUNS_READ_IMODELS !###====================================================================== SUBROUTINE PMANAGER_SEP_ESTIMATE_LAMBDA(FOLDER,LAMBDAS,ICYCLE) !###====================================================================== IMPLICIT NONE CHARACTER(LEN=*),INTENT(IN) :: FOLDER INTEGER,INTENT(IN) :: ICYCLE REAL(KIND=DP_KIND),INTENT(OUT),DIMENSION(:) :: LAMBDAS INTEGER :: KU,I,ILS,IOS REAL(KIND=DP_KIND) :: MAXREDJ,REDJ,LAMBDA CHARACTER(LEN=256) :: LINE DO I=1,PBMAN%NMODELS IF(IMODEL(I).EQ.0)CYCLE KU=UTL_GETUNIT(); OPEN(KU,FILE=TRIM(FOLDER)//'\SEPMODEL'//TRIM(VTOS(IMODEL(I)))//'\IPEST\LOG_PEST_PROGRESS_ICYCLE'//TRIM(VTOS(ICYCLE))//'.TXT',STATUS='OLD',FORM='FORMATTED',ACTION='READ') MAXREDJ=HUGE(1.0) DO READ(KU,'(A256)',IOSTAT=IOS) LINE; IF(IOS.NE.0)EXIT IF(INDEX(LINE,'LS PARAMETER').GT.0)THEN DO READ(KU,'(I5,20X,F10.0,15X,F15.0)',IOSTAT=IOS) ILS,LAMBDA,REDJ IF(IOS.NE.0)EXIT; IF(ILS.EQ.0)EXIT IF(LAMBDA.GT.0.0D0)THEN IF(REDJ.LT.MAXREDJ)THEN MAXREDJ=REDJ; LAMBDAS(I)=LAMBDA ENDIF ENDIF ENDDO ENDIF ENDDO CLOSE(KU) ENDDO END SUBROUTINE PMANAGER_SEP_ESTIMATE_LAMBDA !###====================================================================== LOGICAL FUNCTION PMANAGER_SEP_JACOBIAN_UPDATE(IBATCH,ICYCLE,LAMBDAS,DIR,LOADPTR) !###====================================================================== IMPLICIT NONE TYPE(IDFOBJ),INTENT(IN) :: LOADPTR CHARACTER(LEN=*),INTENT(IN) :: DIR INTEGER,INTENT(IN) :: IBATCH,ICYCLE REAL(KIND=DP_KIND),INTENT(IN),DIMENSION(:) :: LAMBDAS CHARACTER(LEN=15),ALLOCATABLE,DIMENSION(:) :: GRPNAMES CHARACTER(LEN=256) :: FNAME INTEGER :: II,IU,I,J,K,L,KK,N,M,IOS,NPARAM,IACT,ILAMBDA,IROW,ICOL,NTOT,NTHREAD TYPE JOBJ INTEGER :: NPAR,NOBS INTEGER(KIND=DP_KIND),POINTER,DIMENSION(:) :: IDATE=>NULL() REAL(KIND=SP_KIND),POINTER,DIMENSION(:,:) :: HP=>NULL() REAL(KIND=SP_KIND),POINTER,DIMENSION(:) :: W=>NULL(),D=>NULL() REAL(KIND=SP_KIND),POINTER,DIMENSION(:) :: H0=>NULL() REAL(KIND=SP_KIND),POINTER,DIMENSION(:) :: OBS=>NULL() CHARACTER(LEN=15),POINTER,DIMENSION(:) :: CPARAM=>NULL() CHARACTER(LEN=32),POINTER,DIMENSION(:) :: CLABEL=>NULL() END TYPE JOBJ TYPE(JOBJ),ALLOCATABLE,DIMENSION(:) :: JAC REAL(KIND=SP_KIND),ALLOCATABLE,DIMENSION(:) :: THL,MDL REAL(KIND=SP_KIND),ALLOCATABLE,DIMENSION(:,:) :: THP ! REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: THL,MDL ! REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:,:) :: THP REAL(KIND=DP_KIND) :: LAMBDA,GAMMA,DHH,DRES,PROC REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:,:) :: ALPHAS INTEGER,DIMENSION(:),ALLOCATABLE :: IPOSMSR,IPROJECTIE,JMODEL TYPE OBSMDLOBJ INTEGER,POINTER,DIMENSION(:) :: IOBS=>NULL() END TYPE OBSMDLOBJ TYPE(OBSMDLOBJ),ALLOCATABLE,DIMENSION(:) :: OBSMDL INTEGER,DIMENSION(:,:),ALLOCATABLE :: IUP PMANAGER_SEP_JACOBIAN_UPDATE=.FALSE. !## set initial values for alpha() and perform log-transforms DO I=1,SIZE(PEST%PARAM); IF(.NOT.IPEST_GLM_CHK(I,IBATCH))RETURN; ENDDO !## organise groups IF(.NOT.IPEST_GLM_SETGROUPS(IBATCH))RETURN N=SIZE(PEST%PARAM); M=PBMAN%NMODELS; ALLOCATE(ALPHAS(N,M)); ALPHAS=0.0D0 !## maximal number of parameters DO I=1,2 NPARAM=0; DO J=1,SIZE(PEST%PARAM) !## skip inactive/grouped parameters IF(PEST%PARAM(J)%PACT.NE.1)CYCLE; NPARAM=NPARAM+1 IF(I.EQ.2)THEN GRPNAMES(NPARAM)=ADJUSTL(PEST%PARAM(J)%ACRONYM) ENDIF ENDDO IF(I.EQ.1)THEN; ALLOCATE(GRPNAMES(NPARAM)); GRPNAMES=''; ENDIF ENDDO IF(.NOT.ASSOCIATED(PEST%MEASURES))ALLOCATE(PEST%MEASURES(0)) !## read all measurements available from previous global model FNAME=TRIM(DIR)//'\IPEST\LOG_PESTP_RESIDUAL_ICYCLE'//TRIM(VTOS(ICYCLE-1))//'.TXT' IU=UTL_GETUNIT(); OPEN(IU,FILE=FNAME,STATUS='OLD',ACTION='READ') N=1; IF(.NOT.IPEST_GLM_ALLOCATEMSR(-N,N,N,PEST%MEASURES))RETURN DO I=1,2 !## skip header READ(IU,*) !## read data (only label) N=0; IF(I.EQ.1)M=0 DO; N=N+1; IF(I.EQ.2.AND.N.GT.M)EXIT READ(IU,'(2(F15.2,1X),I10,1X,4(F15.3,1X),2(I10,1X),A32,1X,I14)',IOSTAT=IOS) MSR%X(N),MSR%Y(N),MSR%L(N),MSR%O(N),MSR%C(N),MSR%W(N),MSR%D(N),MSR%IPF(N),MSR%LOC(N),MSR%CLABEL(N),MSR%IDATE(N) MSR%CLABEL(N)=ADJUSTL(MSR%CLABEL(N)) ! write(*,*) i,n,'['//MSR%CLABEL(N)//']' IF(IOS.NE.0)EXIT; IF(I.EQ.1)THEN; N=0; M=M+1; ENDIF ENDDO REWIND(IU) IF(I.EQ.1)THEN IF(.NOT.IPEST_GLM_ALLOCATEMSR(-M,1,NPARAM,PEST%MEASURES))RETURN; MSR%D=0.0D0; MSR%NOBS=M DEALLOCATE(MSR%NS,MSR%COR,MSR%E) ENDIF ENDDO CLOSE(IU) ! DEALLOCATE(MSR%L,MSR%IPF) !## determine submodels measurements need to be assigned to ALLOCATE(IPROJECTIE(MAXVAL(IMODEL))); IPROJECTIE=0; DO I=1,PBMAN%NMODELS; IF(IMODEL(I).GT.0)IPROJECTIE(IMODEL(I))=I; ENDDO ALLOCATE(IPOSMSR(MSR%NOBS)); IPOSMSR=0 DO I=1,MSR%NOBS CALL IDFIROWICOL(LOADPTR,IROW,ICOL,MSR%X(I),MSR%Y(I)) IF(IROW.NE.0.AND.ICOL.NE.0)THEN !## skip nodata IF(LOADPTR%X(ICOL,IROW).EQ.LOADPTR%NODATA)CYCLE J=LOADPTR%X(ICOL,IROW) IF(J.GT.0.AND.J.LE.SIZE(IPROJECTIE))THEN !## inside model IF(IPROJECTIE(J).NE.0)THEN IPOSMSR(I)=IPROJECTIE(J) ENDIF ENDIF ENDIF ENDDO DEALLOCATE(IPROJECTIE) ALLOCATE(JAC(PBMAN%NMODELS)); DO I=1,PBMAN%NMODELS; NULLIFY(JAC(I)%HP,JAC(I)%CPARAM,JAC(I)%CLABEL,JAC(I)%IDATE,JAC(I)%OBS,JAC(I)%H0,JAC(I)%W); ENDDO ALLOCATE(IUP(PBMAN%NMODELS,2)) DO I=1,PBMAN%NMODELS IF(IMODEL(I).EQ.0)CYCLE FNAME=TRIM(DIR)//'\SEPMODEL'//TRIM(VTOS(IMODEL(I)))//'\IPEST\LOG_PEST_JACOBIAN_ICYCLE'//TRIM(VTOS(PBMAN%ICYCLE))//'.TXT' IUP(I,1)=UTL_GETUNIT(); OPEN(IUP(I,1),FILE=FNAME,STATUS='OLD',ACTION='READ') FNAME=TRIM(DIR)//'\SEPMODEL'//TRIM(VTOS(IMODEL(I)))//'\IPEST\LOG_PEST_RUNFILE_ICYCLE'//TRIM(VTOS(ICYCLE))//'.TXT' IUP(I,2)=UTL_GETUNIT(); OPEN(IUP(I,2),FILE=FNAME,STATUS='OLD',ACTION='READ') WRITE(*,*) IUP(I,1),IUP(I,2) ENDDO WRITE(*,'(A)') 'Reading results on '//TRIM(VTOS(UTL_OMP_GET_MAX_THREADS()))//' threads <<<' !## read all jacobian information, overwrite with most recent ones !$OMP PARALLEL PRIVATE(I,J,K,FNAME,IU,IOS) SHARED (IUP,JAC,ALPHAS,IMODEL) !$OMP DO DO I=1,PBMAN%NMODELS IF(IMODEL(I).EQ.0)CYCLE IU=IUP(I,1) INQUIRE(UNIT=IU,NAME=FNAME) WRITE(*,'(1X,A)') 'Reading Unit '//TRIM(VTOS(IU))//' '//TRIM(FNAME)//' ...' JAC(I)%NOBS=0 DO !## header READ(IU,*,IOSTAT=IOS); IF(IOS.NE.0)EXIT !## dimensions READ(IU,*,IOSTAT=IOS) JAC(I)%NOBS,JAC(I)%NPAR; IF(IOS.NE.0)STOP IF(.NOT.ASSOCIATED(JAC(I)%HP ))ALLOCATE(JAC(I)%HP(JAC(I)%NOBS,JAC(I)%NPAR)) IF(.NOT.ASSOCIATED(JAC(I)%CPARAM))ALLOCATE(JAC(I)%CPARAM(JAC(I)%NPAR)) IF(.NOT.ASSOCIATED(JAC(I)%CLABEL))ALLOCATE(JAC(I)%CLABEL(JAC(I)%NOBS)) IF(.NOT.ASSOCIATED(JAC(I)%IDATE ))ALLOCATE(JAC(I)%IDATE(JAC(I)%NOBS)) IF(.NOT.ASSOCIATED(JAC(I)%H0 ))ALLOCATE(JAC(I)%H0(JAC(I)%NOBS)) IF(.NOT.ASSOCIATED(JAC(I)%OBS ))ALLOCATE(JAC(I)%OBS(JAC(I)%NOBS)) IF(.NOT.ASSOCIATED(JAC(I)%W ))ALLOCATE(JAC(I)%W(JAC(I)%NOBS)) IF(.NOT.ASSOCIATED(JAC(I)%D ))ALLOCATE(JAC(I)%D(JAC(I)%NOBS)) !## header READ(IU,'(110X,999A15)',IOSTAT=IOS) (JAC(I)%CPARAM(J),J=1,JAC(I)%NPAR) DO J=1,JAC(I)%NPAR; JAC(I)%CPARAM(J)=ADJUSTL(JAC(I)%CPARAM(J)); ENDDO !## read jacobian info DO K=1,JAC(I)%NOBS READ(IU,'(3X,A32,I15,999F15.0)',IOSTAT=IOS) JAC(I)%CLABEL(K),JAC(I)%IDATE(K),JAC(I)%D(K), & JAC(I)%OBS(K),JAC(I)%W(K),JAC(I)%H0(K),(JAC(I)%HP(K,J),J=1,JAC(I)%NPAR) ENDDO IF(IOS.NE.0)EXIT ENDDO CLOSE(IU) IU=IUP(I,2) INQUIRE(UNIT=IU,NAME=FNAME) WRITE(*,'(1X,A)') 'Reading Unit '//TRIM(VTOS(IU))//' '//TRIM(FNAME)//' ...' DO DO J=1,3; READ(IU,*,IOSTAT=IOS) ; ENDDO IF(IOS.NE.0)EXIT DO J=1,SIZE(PEST%PARAM) READ(IU,'(20X,F10.0)',IOSTAT=IOS) ALPHAS(J,I) IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') '>>> ERROR READING '//TRIM(FNAME)//' <<<'; STOP; ENDIF ENDDO ENDDO CLOSE(IU) ENDDO !$OMP END DO !$OMP END PARALLEL DEALLOCATE(IUP) WRITE(*,'(/A/)') 'Finished reading logfiles' CALL UTL_CREATEDIR(TRIM(DIR)//'\IPESTP_SEPMODELLING') IU=UTL_GETUNIT(); OPEN(IU,FILE=TRIM(DIR)//'\IPESTP_SEPMODELLING\IPESTP_SEPMODEL_LOG_ICYCLE'//TRIM(VTOS(PBMAN%ICYCLE))//'.TXT',STATUS='UNKNOWN',ACTION='WRITE') DO I=1,PBMAN%NMODELS IF(IMODEL(I).EQ.0)CYCLE WRITE(IU,'(/A/)') 'SEPMODEL '//TRIM(VTOS(I)) WRITE(IU,'(A32,999A15)') 'MSR_LABEL','ACCEPT','OBS','W','H0',(ADJUSTR(JAC(I)%CPARAM(J)),J=1,JAC(I)%NPAR) DO J=1,MIN(100,JAC(I)%NOBS) WRITE(IU,'(A32,999F15.3)') JAC(I)%CLABEL(J),JAC(I)%D(J),JAC(I)%OBS(J),JAC(I)%W(J),JAC(I)%H0(J),(JAC(I)%HP(J,K),K=1,JAC(I)%NPAR) ENDDO IF(JAC(I)%NOBS.GT.100)THEN WRITE(IU,'(/A/)') 'skipping export as more than 50 observations in this model' ENDIF ENDDO DO L=1,MSR%NOBS; MSR%CLABEL(L)=ADJUSTL(MSR%CLABEL(L)); ENDDO DO I=1,PBMAN%NMODELS; DO J=1,JAC(I)%NOBS; JAC(I)%CLABEL(J)=ADJUSTL(JAC(I)%CLABEL(J)); ENDDO; ENDDO DO K=1,NPARAM; GRPNAMES(K)=ADJUSTL(GRPNAMES(K)); ENDDO DO I=1,PBMAN%NMODELS; DO J=1,JAC(I)%NPAR; JAC(I)%CPARAM(J)=ADJUSTL(JAC(I)%CPARAM(J)); ENDDO; ENDDO !## create summary of all information in msr arrays WRITE(IU,'(/A/)') 'TOTAL OBSERVATIONS FOR ALL SEPMODELS' WRITE(IU,'(A32,1X,A14,A5,999(1X,A10))') 'OBSLABEL','IDATE','NO','OBS.',('MODEL_'//TRIM(VTOS(I)),I=1,PBMAN%NMODELS) ALLOCATE(MDL(PBMAN%NMODELS)) WRITE(6,'(A)') 'Progressing '//TRIM(VTOS(MSR%NOBS))//' observations ('//TRIM(VTOS(0.0D0,'F',2))//'%) ' NTHREAD=UTL_OMP_GET_MAX_THREADS() WRITE(*,'(A)') 'Aggregating results on '//TRIM(VTOS(UTL_OMP_GET_MAX_THREADS()))//' threads <<<' !$OMP PARALLEL PRIVATE(L,I,J,N,MDL,PROC) SHARED (JAC,MSR,NTOT) NTOT=0 !$OMP DO DO L=1,MSR%NOBS !## all nodata MDL=-999.99D0 N=0 !## in existing sepmodel IF(IPOSMSR(L).GT.0)THEN I=IPOSMSR(L) !## look for correct observation DO J=1,JAC(I)%NOBS IF(JAC(I)%CLABEL(J).EQ.MSR%CLABEL(L))THEN IF(JAC(I)%IDATE(J).EQ.MSR%IDATE(L))EXIT ENDIF ENDDO !## this measurement available; get residual IF(J.LE.JAC(I)%NOBS)THEN; MDL(I)=JAC(I)%H0(J); N=1; ENDIF ENDIF IF(L.LE.500)THEN WRITE(IU,'(A32,1X,I14,I5,999(1X,F10.3))') ADJUSTR(MSR%CLABEL(L)),MSR%IDATE(L),N,MSR%O(L),(MDL(I),I=1,PBMAN%NMODELS) ENDIF !## set measurement to zero as no sensitivity is computed for this measurement IF(N.EQ.0)MSR%O(L)=0.0D0 NTOT=NTOT+1 PROC=REAL(NTOT,8)/REAL(MSR%NOBS,8)*100.0D0 WRITE(6,'(A,I10,A,I5,A,F10.2,A)') '+Progressing ',MSR%NOBS,' observations on ',NTHREAD,' threads (',PROC,'%) ' ENDDO !$OMP END DO !$OMP END PARALLEL DEALLOCATE(MDL) ALLOCATE(THL(MSR%NOBS),THP(NPARAM,MSR%NOBS)) THL=0.0D0; THP=0.0D0; MSR%HL=0.0D0; MSR%HG=0.0D0 WRITE(*,'(A)') 'Aggregating results on '//TRIM(VTOS(UTL_OMP_GET_MAX_THREADS()))//' threads <<<' ALLOCATE(OBSMDL(PBMAN%NMODELS)) !$OMP PARALLEL PRIVATE(I,II,L,N) SHARED (MSR,OBSMDL,IPOSMSR) !$OMP DO DO I=1,PBMAN%NMODELS DO II=1,2 N=0 DO L=1,MSR%NOBS IF(IPOSMSR(L).EQ.I)THEN N=N+1 !## save measurement per submodel IF(II.EQ.2)OBSMDL(I)%IOBS(N)=L ENDIF ENDDO IF(N.EQ.0)EXIT IF(II.EQ.1)ALLOCATE(OBSMDL(I)%IOBS(N)) ENDDO ENDDO !$OMP END DO !$OMP END PARALLEL !## create summary of all information in msr arrays WRITE(*,'(A)') 'Aggregating results on '//TRIM(VTOS(UTL_OMP_GET_MAX_THREADS()))//' threads <<<' WRITE(6,'(A,I10,A,F10.2,A)') 'Progressing ',PBMAN%NMODELS,' models (',0.0D0,'%) ' !$OMP PARALLEL PRIVATE(I,J,II,KK,K,L,PROC) SHARED (JAC,MSR,OBSMDL,THL,THP) N=0 !$OMP DO DO I=1,PBMAN%NMODELS DO J=1,JAC(I)%NOBS !## look for correct observation DO II=1,SIZE(OBSMDL(I)%IOBS) L=OBSMDL(I)%IOBS(II) IF(JAC(I)%CLABEL(J).EQ.MSR%CLABEL(L))THEN IF(JAC(I)%IDATE(J).EQ.MSR%IDATE(L))EXIT ENDIF ENDDO !## this measurement not available IF(II.GT.SIZE(OBSMDL(I)%IOBS))THEN DO II=1,SIZE(OBSMDL(I)%IOBS) L=OBSMDL(I)%IOBS(II) WRITE(*,'(2(I10,1X),A32,1X,I14)') II,L,MSR%CLABEL(L),MSR%IDATE(L) ENDDO WRITE(*,*) 'Cannot overlap submodels (model'//TRIM(VTOS(IMODEL(I)))//'): missing measurement '//TRIM(JAC(I)%CLABEL(J))//' and date '//TRIM(VTOS(JAC(I)%IDATE(J))) PAUSE; CYCLE ENDIF !## get residual MSR%HL(0,L)=JAC(I)%H0(J) MSR%D(L) =JAC(I)%D(J) THL (L) =THL (L)+1.0D0 !## save heads per parameter DO KK=1,JAC(I)%NPAR !## look for correct parameter DO K=1,NPARAM; IF(JAC(I)%CPARAM(KK).EQ.GRPNAMES(K))EXIT; ENDDO !## this measurement not available IF(K.GT.NPARAM)THEN WRITE(*,*) 'Missing Parameter '//TRIM(JAC(I)%CPARAM(KK)); PAUSE; STOP ENDIF !## average parameter heads MSR%HG(K,L)=JAC(I)%HP(J,KK) THP (K,L)=THP (K,L)+1.0D0 ENDDO ENDDO N=N+1; PROC=REAL(N,8)/REAL(PBMAN%NMODELS,8)*100.0D0 WRITE(6,'(A,I10,A,F10.2,A)') '+Progressing ',PBMAN%NMODELS,' models (',PROC,'%) ' ENDDO !$OMP END DO !$OMP END PARALLEL !## get average value per observation and objective function value MSR%TJ=0.0D0; DO L=1,MSR%NOBS IF(THL(L).EQ.0.0D0)MSR%HL(0,L)=0.0D0 MSR%TJ=MSR%TJ+MSR%HL(0,L)**2.0D0 ENDDO DO L=1,MSR%NOBS IF(THL(L).GT.0.0D0)THEN !## calculated - measured DHH=MSR%HL(0,L)-MSR%O(L) DRES=PEST%PE_DRES; IF(DRES.EQ.0.0D0)DRES=MSR%D(L) !## exclude big residuals IF(DRES.LT.0.0D0)THEN IF(ABS(DHH).GT.ABS(DRES))DHH=0.0D0 ELSE IF(ABS(DHH).LT.DRES)THEN DHH=0.0D0 ELSE IF(DHH.GT. DRES)DHH=DHH-DRES IF(DHH.LT.-DRES)DHH=DHH+DRES ENDIF ENDIF ELSE DHH=0.0D0 ENDIF MSR%DHL(0,L)=DHH ENDDO !## get average lambda of all sepmodels WRITE(*,'(/2A10,A15)') 'MODEL','MODELNO','LAMBDA' LAMBDA=0.0D0; L=0; DO I=1,PBMAN%NMODELS !## ignore lambda=0.0 (none computed models) IF(LAMBDAS(I).LE.0.0D0)CYCLE LAMBDA=LAMBDA+LAMBDAS(I) WRITE(*,'(2I10,F15.7)') I,IMODEL(I),LAMBDAS(I) L=L+1 ENDDO LAMBDA=LAMBDA/REAL(L,8) WRITE(*,'(/A/)') 'Average Lambda = '//TRIM(VTOS(LAMBDA,'F',3)) LAMBDA=MSR%TJ/DBLE(2.0D0*MSR%NOBS) LAMBDA=LOG(LAMBDA); I=FLOOR(LAMBDA); LAMBDA=EXP(REAL(I,8)) WRITE(*,'(/A/)') 'Using Residual Lambda = '//TRIM(VTOS(LAMBDA,'F',3)) !$OMP PARALLEL PRIVATE(L,K) SHARED (NPARAM,MSR,THP) !$OMP DO !## get average value per observation per parameter DO L=1,MSR%NOBS; DO K=1,NPARAM !## fill all parameter head with the initial heads IF(THP(K,L).EQ.0.0D0)MSR%HG(K,L)=MSR%HL(0,L) ENDDO; ENDDO !$OMP END DO !$OMP END PARALLEL WRITE(IU,'(/A/)') 'FINAL SET OF OBSERVATION AND SENSITIVITIES' WRITE(IU,'(A32,A15,999(1X,A10))') 'MSR_LABEL','MSR_DATE','OBS','H0',(TRIM(GRPNAMES(J)),J=1,NPARAM) IF(MSR%NOBS.LE.500)THEN DO L=1,MSR%NOBS WRITE(IU,'(A32,I15,999(1X,F10.3))') ADJUSTR(MSR%CLABEL(L)),MSR%IDATE(L),MSR%O(L),MSR%HL(0,L),(MSR%HG(K,L),K=1,NPARAM) ENDDO ELSE WRITE(IU,'(/A/)') 'skipping export as more than 500 observations in entire model' ENDIF CALL UTL_CREATEDIR(TRIM(DIR)//'\IPESTP_SEPMODELLING') IUPESTOUT=UTL_GETUNIT(); OPEN(IUPESTOUT, FILE=TRIM(DIR)//'\IPESTP_SEPMODELLING\LOG_PEST_ICYCLE'//TRIM(VTOS(PBMAN%ICYCLE))//'.TXT' ,STATUS='UNKNOWN',ACTION='WRITE') IUPESTSENSITIVITY=UTL_GETUNIT(); OPEN(IUPESTSENSITIVITY,FILE=TRIM(DIR)//'\IPESTP_SEPMODELLING\LOG_PEST_SENSITIVITY_ICYCLE'//TRIM(VTOS(PBMAN%ICYCLE))//'.TXT',STATUS='UNKNOWN',ACTION='WRITE') IUPESTJACOBIAN=UTL_GETUNIT(); OPEN(IUPESTJACOBIAN, FILE=TRIM(DIR)//'\IPESTP_SEPMODELLING\LOG_PEST_JACOBIAN_ICYCLE'//TRIM(VTOS(PBMAN%ICYCLE))//'.TXT' ,STATUS='UNKNOWN',ACTION='WRITE') WRITE(IUPESTSENSITIVITY,'(A)') 'Sensitivity (%):' CALL IPEST_GLM_WRITEHEADER('ITERATION ',NPARAM,IUPESTSENSITIVITY) !## make sure only lambda is computed ALLOCATE(PBMAN%LAMBDA_TEST_COPY(PBMAN%NLAMBDASEARCH)); PBMAN%LAMBDA_TEST_COPY=PBMAN%LAMBDA_TEST PBMAN%NLAMBDASEARCH=1; PBMAN%LAMBDA_TEST(1)=1.0D0 !## initialize gamma GAMMA=4.0D0 I=IPEST_GLM_GRADIENT(IBATCH,ICYCLE,LAMBDA,GAMMA) PBMAN%LAMBDA_TEST=PBMAN%LAMBDA_TEST_COPY; PBMAN%NLAMBDASEARCH=SIZE(PBMAN%LAMBDA_TEST) !## transform all to normal space CALL IPEST_GLM_RESET_PARAMETER('') ILAMBDA=1 !NINT(REAL(PBMAN%NLAMBDASEARCH,8)/2.0D0) !## set update in pini DO I=1,SIZE(PEST%PARAM) IF(PEST%PARAM(I)%PLOG.EQ.1)THEN PEST%PARAM(I)%PINI=EXP(PEST%PARAM(I)%LALPHA(ILAMBDA)) ELSEIF(PEST%PARAM(J)%PLOG.EQ.2)THEN PEST%PARAM(I)%PINI=10.0D0**PEST%PARAM(I)%LALPHA(ILAMBDA) ELSE PEST%PARAM(I)%PINI=PEST%PARAM(I)%LALPHA(ILAMBDA) ENDIF ENDDO WRITE(IUPESTOUT,'(/A)') 'Parameters' WRITE(IUPESTOUT,'(A2,1X,A2,1X,A5,1X,A7,5(1X,A10),1X,A7,1X,A2,1X,A15,2(1X,A10),2(1X,A14))') 'AC','PT','ILS','ZONE','INITIAL','DELTA','MINIMUM','MAXIMUM','FADJ','IGROUP','TR', & 'ACRONYM','PPRIOR','STDEV','SDATE','EDATE' DO I=1,SIZE(PEST%PARAM) IACT=ABS(PEST%PARAM(I)%PACT); IF(IACT.EQ.2)IACT=1 WRITE(IUPESTOUT,'(I2,1X,A,1X,I5,1X,I7,1X,5(F10.3,1X),I7,1X,I2,1X,A15,2(1X,F10.3),2(1X,A14))') IACT,PEST%PARAM(I)%PPARAM,PEST%PARAM(I)%PILS, & PEST%PARAM(I)%PIZONE,PEST%PARAM(I)%PINI,PEST%PARAM(I)%PDELTA,PEST%PARAM(I)%PMIN,PEST%PARAM(I)%PMAX,PEST%PARAM(I)%PINCREASE, & ABS(PEST%PARAM(I)%PIGROUP),PEST%PARAM(I)%PLOG,PEST%PARAM(I)%ACRONYM,PEST%PARAM(I)%PPRIOR,PEST%PARAM(I)%PARSTD, & PEST%PARAM(I)%SDATE,PEST%PARAM(I)%EDATE ENDDO CALL IPEST_GLM_CLOSE_FILES() N=0; DO I=1,PBMAN%NMODELS; IF(IMODEL(I).GT.0)N=N+1; ENDDO; ALLOCATE(JMODEL(N)) N=0; DO I=1,PBMAN%NMODELS; IF(IMODEL(I).LE.0)CYCLE; N=N+1; JMODEL(N)=I; ENDDO WRITE(IU,'(/A/)') 'ACTIVE PARAMETERS' WRITE(IU,'(A2,1X,A2,1X,A5,1X,A7,1X,A15,999(1X,A10))') 'AC','PT','ILS','ZONE','ACRONYM','PINI',('MODEL_'//TRIM(VTOS(JMODEL(I))),I=1,N) !PBMAN%NMODELS) DO I=1,SIZE(PEST%PARAM) IF((PEST%PARAM(I)%PACT).NE.1)CYCLE WRITE(IU,'(I2,1X,A2,1X,I5,1X,I7,1X,A15,999(1X,F10.3))') PEST%PARAM(I)%PACT,PEST%PARAM(I)%PPARAM,PEST%PARAM(I)%PILS,PEST%PARAM(I)%PIZONE, & PEST%PARAM(I)%ACRONYM,PEST%PARAM(I)%PINI,(ALPHAS(I,JMODEL(J)),J=1,N) !PBMAN%NMODELS) ENDDO CLOSE(IU); DEALLOCATE(ALPHAS,JMODEL) DO I=1,SIZE(JAC) IF(JAC(I)%NOBS.EQ.0)CYCLE DEALLOCATE(JAC(I)%IDATE) DEALLOCATE(JAC(I)%HP) DEALLOCATE(JAC(I)%W) DEALLOCATE(JAC(I)%D) DEALLOCATE(JAC(I)%H0) DEALLOCATE(JAC(I)%OBS) DEALLOCATE(JAC(I)%CPARAM) DEALLOCATE(JAC(I)%CLABEL) ENDDO DEALLOCATE(JAC,IPOSMSR,THL,THP,GRPNAMES) DO I=1,PBMAN%NMODELS; IF(ASSOCIATED(OBSMDL(I)%IOBS))DEALLOCATE(OBSMDL(I)%IOBS); ENDDO CALL IPEST_GLM_DEALLOCATEMSR() PMANAGER_SEP_JACOBIAN_UPDATE=.TRUE. END FUNCTION PMANAGER_SEP_JACOBIAN_UPDATE !###====================================================================== SUBROUTINE PMANAGER_SEPMODEL_FHB(OUTMAP) !###====================================================================== IMPLICIT NONE CHARACTER(LEN=*),INTENT(IN) :: OUTMAP CHARACTER(LEN=256) :: FNAME CHARACTER(LEN=52) :: CDATE,CD INTEGER :: ILAY,IPER,JPER !## deallocate existing fhb CALL PMANAGER_DEALLOCATE(TFHB); ALLOCATE(TOPICS(TFHB)%STRESS(PRJNPER-1)); TOPICS(TFHB)%IACT_MODEL=1 DO IPER=1,PRJNPER-1 IF(SIM(IPER)%DELT.GT.0.0D0)THEN TOPICS(TFHB)%STRESS(IPER)%IDY=SIM(IPER)%IDY; TOPICS(TFHB)%STRESS(IPER)%IMH=SIM(IPER)%IMH; TOPICS(TFHB)%STRESS(IPER)%IYR=SIM(IPER)%IYR TOPICS(TFHB)%STRESS(IPER)%IHR=SIM(IPER)%IHR; TOPICS(TFHB)%STRESS(IPER)%IMT=SIM(IPER)%IMT; TOPICS(TFHB)%STRESS(IPER)%ISC=SIM(IPER)%ISC !## date for current timestep WRITE(CDATE,'(I4.4,5(A1,I2.2))') SIM(IPER)%IYR ,'-',SIM(IPER)%IMH,'-',SIM(IPER)%IDY,' ',SIM(IPER)%IHR,':',SIM(IPER)%IMT,':',SIM(IPER)%ISC !## date for timestamp in idf-file JPER=IPER; IF(PBMAN%ISAVEENDDATE.EQ.1)JPER=JPER+1 IF(SIM(JPER)%IHR+SIM(JPER)%IMT+SIM(JPER)%ISC.EQ.0)THEN WRITE(CD,'(I4.4,2I2.2)') SIM(JPER)%IYR,SIM(JPER)%IMH,SIM(JPER)%IDY ELSE WRITE(CD,'(I4.4,5I2.2)') SIM(JPER)%IYR,SIM(JPER)%IMH,SIM(JPER)%IDY,SIM(JPER)%IHR,SIM(JPER)%IMT,SIM(JPER)%ISC ENDIF ELSE CDATE='STEADY-STATE'; CD=CDATE ENDIF TOPICS(TFHB)%STRESS(IPER)%CDATE=TRIM(CDATE) ALLOCATE(TOPICS(TFHB)%STRESS(IPER)%FILES(3,PRJNLAY)) DO ILAY=1,PRJNLAY DO I=1,3 TOPICS(TFHB)%STRESS(IPER)%FILES(I,ILAY)%IACT =1 TOPICS(TFHB)%STRESS(IPER)%FILES(I,ILAY)%ICNST=2 TOPICS(TFHB)%STRESS(IPER)%FILES(I,ILAY)%ILAY =ILAY TOPICS(TFHB)%STRESS(IPER)%FILES(I,ILAY)%FCT =1.0D0 TOPICS(TFHB)%STRESS(IPER)%FILES(I,ILAY)%IMP =0.0D0 TOPICS(TFHB)%STRESS(IPER)%FILES(I,ILAY)%CNST =-999.99D0 ENDDO IF(PBMAN%IPESTP.EQ.1)THEN FNAME=TRIM(OUTMAP)//'\IPEST_L#1\BDGFRF\BDGFRF_'//TRIM(CD)//'_L'//TRIM(VTOS(ILAY))//'.IDF' ELSE FNAME=TRIM(OUTMAP)//'\BDGFRF\BDGFRF_'//TRIM(CD)//'_L'//TRIM(VTOS(ILAY))//'.IDF' ENDIF TOPICS(TFHB)%STRESS(IPER)%FILES(1,ILAY)%FNAME=FNAME IF(PBMAN%IPESTP.EQ.1)THEN FNAME=TRIM(OUTMAP)//'\IPEST_L#1\BDGFFF\BDGFFF_'//TRIM(CD)//'_L'//TRIM(VTOS(ILAY))//'.IDF' ELSE FNAME=TRIM(OUTMAP)//'\BDGFFF\BDGFFF_'//TRIM(CD)//'_L'//TRIM(VTOS(ILAY))//'.IDF' ENDIF TOPICS(TFHB)%STRESS(IPER)%FILES(2,ILAY)%FNAME=FNAME IF(PBMAN%IPESTP.EQ.1)THEN FNAME=TRIM(OUTMAP)//'\IPEST_L#1\HEAD\HEAD_'//TRIM(CD)//'_L'//TRIM(VTOS(ILAY))//'.IDF' ELSE FNAME=TRIM(OUTMAP)//'\HEAD\HEAD_'//TRIM(CD)//'_L'//TRIM(VTOS(ILAY))//'.IDF' ENDIF TOPICS(TFHB)%STRESS(IPER)%FILES(3,ILAY)%FNAME=FNAME ENDDO ENDDO END SUBROUTINE PMANAGER_SEPMODEL_FHB !###====================================================================== SUBROUTINE PMANAGER_SEPMODEL_BND(OUTMAP,LOADPTR,BUFFPTR)!,IMODEL) !###====================================================================== IMPLICIT NONE CHARACTER(LEN=*),INTENT(IN) :: OUTMAP TYPE(IDFOBJ),INTENT(IN) :: LOADPTR,BUFFPTR CHARACTER(LEN=256) :: FNAME TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: BND TYPE(IDFOBJ) :: TMPIDF INTEGER :: I,J,ISEP,IROW,ICOL,IC,IR,IC1,IC2,IR1,IR2,IFIX,IHDFIX LOGICAL :: LW,LE,LN,LS REAL(KIND=DP_KIND) :: BUFFERDX,BUFFERDY,XMIN,XMAX,YMIN,YMAX,X1,Y1,X2,Y2,XXMIN,XXMAX,YYMIN,YYMAX INTEGER,DIMENSION(:,:),ALLOCATABLE :: ISIZE INTEGER,DIMENSION(4) :: JC=[-1,0,1,0],JR=[0,1,0,-1] WRITE(*,'(/1X,A)') 'Constructing BND-files ...' ALLOCATE(BND(PRJNLAY)); DO I=1,PRJNLAY; CALL IDFNULLIFY(BND(I)); ENDDO ALLOCATE(ISIZE(4,PRJNLAY)) !## apply buffer IF(TRIM(PBMAN%LAMBDAMODELS).NE.'')THEN BUFFERDX=0.0D0; BUFFERDY=BUFFERDX ELSE BUFFERDX=PBMAN%BUFMODELS BUFFERDY=PBMAN%BUFMODELS ENDIF PRJIDF%DX=SUBMDL(0)%DX; PRJIDF%DY=SUBMDL(0)%DX DO ISEP=1,PBMAN%NMODELS IF(IMODEL(ISEP).EQ.0)CYCLE WRITE(6,'(A)') '+Constructing boundary files for model: '//TRIM(VTOS(IMODEL(ISEP)))//' ('//TRIM(VTOS(ISEP))//' out of '//TRIM(VTOS(PBMAN%NMODELS))//')' !## get min/max value for this current submodel IC2=1; IR2=1; IC1=PRJIDF%NCOL; IR1=PRJIDF%NROW DO IROW=1,PRJIDF%NROW; DO ICOL=1,PRJIDF%NCOL IF(LOADPTR%X(ICOL,IROW).EQ.LOADPTR%NODATA)CYCLE I=INT(LOADPTR%X(ICOL,IROW)) IF(IMODEL(ISEP).EQ.I)THEN IC1=MIN(IC1,ICOL); IC2=MAX(IC2,ICOL) IR1=MIN(IR1,IROW); IR2=MAX(IR2,IROW) IF(TRIM(PBMAN%LAMBDAMODELS).NE.'')THEN BUFFERDX=MAX(BUFFERDX,BUFFPTR%X(ICOL,IROW)); BUFFERDY=BUFFERDX ENDIF ENDIF ENDDO; ENDDO CALL IDFGETEDGE(PRJIDF,IR1,IC1,X1,Y1,X2,Y2); XXMIN=X1; XXMIN=MAX(XXMIN,PRJIDF%XMIN) CALL IDFGETEDGE(PRJIDF,IR1,IC2,X1,Y1,X2,Y2); XXMAX=X2; XXMAX=MIN(XXMAX,PRJIDF%XMAX) CALL IDFGETEDGE(PRJIDF,IR2,IC1,X1,Y1,X2,Y2); YYMIN=Y1; YYMIN=MAX(YYMIN,PRJIDF%YMIN) CALL IDFGETEDGE(PRJIDF,IR1,IC2,X1,Y1,X2,Y2); YYMAX=Y2; YYMAX=MIN(YYMAX,PRJIDF%YMAX) SUBMDL(ISEP)%X1 =XXMIN SUBMDL(ISEP)%X2 =XXMAX SUBMDL(ISEP)%Y1 =YYMIN SUBMDL(ISEP)%Y2 =YYMAX SUBMDL(ISEP)%DX =PRJIDF%DX SUBMDL(ISEP)%BUF=BUFFERDX SUBMDL(ISEP)%BDX=PRJIDF%DX CALL IDFGETEDGE(PRJIDF,IR1,IC1,X1,Y1,X2,Y2); XMIN=X1-BUFFERDX; XMIN=MAX(XMIN,PRJIDF%XMIN) CALL IDFGETEDGE(PRJIDF,IR1,IC2,X1,Y1,X2,Y2); XMAX=X2+BUFFERDX; XMAX=MIN(XMAX,PRJIDF%XMAX) CALL IDFGETEDGE(PRJIDF,IR2,IC1,X1,Y1,X2,Y2); YMIN=Y1-BUFFERDY; YMIN=MAX(YMIN,PRJIDF%YMIN) CALL IDFGETEDGE(PRJIDF,IR1,IC2,X1,Y1,X2,Y2); YMAX=Y2+BUFFERDY; YMAX=MIN(YMAX,PRJIDF%YMAX) LW= .FALSE.; IF(XMIN.GT.PRJIDF%XMIN)LW=.TRUE. LE= .FALSE.; IF(XMAX.LT.PRJIDF%XMAX)LE=.TRUE. LN= .FALSE.; IF(YMAX.LT.PRJIDF%YMAX)LN=.TRUE. LS= .FALSE.; IF(YMIN.GT.PRJIDF%YMIN)LS=.TRUE. IFIX=0; ISIZE=0; DO I=1,PRJNLAY BND(I)%XMIN=XMIN; BND(I)%XMAX=XMAX BND(I)%YMIN=YMIN; BND(I)%YMAX=YMAX BND(I)%DX=PRJIDF%DX; BND(I)%DY=BND(I)%DX BND(I)%NCOL=(BND(I)%XMAX-BND(I)%XMIN)/BND(I)%DX BND(I)%NROW=(BND(I)%YMAX-BND(I)%YMIN)/BND(I)%DY IF(TOPICS(TBND)%STRESS(1)%FILES(1,I)%ICNST.EQ.1)THEN IF(.NOT.IDFALLOCATEX(BND(I)))RETURN; BND(I)%NODATA=-999.0D0 BND(I)%X=TOPICS(TBND)%STRESS(1)%FILES(1,I)%CNST ELSE FNAME=TOPICS(TBND)%STRESS(1)%FILES(1,I)%FNAME IF(.NOT.IDFREADSCALE(FNAME,BND(I),1,0,0.0D0,1))STOP !## boundary of set of submodels IF(BND(I)%XMIN.EQ.PRJIDF%XMIN)ISIZE(1,I)= 1 IF(BND(I)%XMAX.EQ.PRJIDF%XMAX)ISIZE(3,I)= 1 IF(BND(I)%YMIN.EQ.PRJIDF%YMIN)ISIZE(2,I)= 1 IF(BND(I)%YMAX.EQ.PRJIDF%YMAX)ISIZE(4,I)= 1 !## check whether it is a global boundary as well IF(IDFREAD(TMPIDF,FNAME,0))THEN IF(TMPIDF%XMIN.EQ.PRJIDF%XMIN)ISIZE(1,I)= 0 IF(TMPIDF%XMAX.EQ.PRJIDF%XMAX)ISIZE(3,I)= 0 IF(TMPIDF%YMIN.EQ.PRJIDF%YMIN)ISIZE(2,I)= 0 IF(TMPIDF%YMAX.EQ.PRJIDF%YMAX)ISIZE(4,I)= 0 ENDIF IF(SUM(ISIZE).NE.0)IFIX=1 ENDIF ENDDO !## adjust boundary for submodel() CALL PMANAGER_SAVEMF2005_BND(ISIZE,BND,-2) IHDFIX=0; DO I=1,PRJNLAY !## fill in (in)active areas for this sep-model DO IROW=1,BND(I)%NROW; DO ICOL=1,BND(I)%NCOL CALL IDFGETLOC(BND(I),IROW,ICOL,X1,Y1) CALL IDFIROWICOL(LOADPTR,IR1,IC1,X1,Y1) !## if predefined shapes are defined, check whether location is in same zone IF(PBMAN%EXCLUDE.EQ.1)THEN IF(INT(LOADPTR%X(IC1,IR1)).NE.IMODEL(ISEP))BND(I)%X(ICOL,IROW)=0.0D0 ENDIF ENDDO; ENDDO !## check outer edge (reduce size model with single row/column if needed) DO IROW=1,BND(I)%NROW !## turn west border inactive IF(LW)THEN !## turn west/east border flux boundary ICOL=1; IF(BND(I)%X(ICOL,IROW).EQ.1.0D0)BND(I)%X(ICOL,IROW)=2.0D0 ENDIF IF(LE)THEN ICOL=BND(I)%NCOL; IF(BND(I)%X(ICOL,IROW).EQ.1.0D0)BND(I)%X(ICOL,IROW)=2.0D0 ENDIF ENDDO DO ICOL=1,BND(I)%NCOL !## turn north border inactive IF(LN)THEN !## turn north/south border flux boundary IROW=1; IF(BND(I)%X(ICOL,IROW).EQ.1.0D0)BND(I)%X(ICOL,IROW)=2.0D0 ENDIF IF(LS)THEN IROW=BND(I)%NROW; IF(BND(I)%X(ICOL,IROW).EQ.1.0D0)BND(I)%X(ICOL,IROW)=2.0D0 ENDIF ENDDO !## check in case of irregular boundaries DO IROW=1,BND(I)%NROW DO ICOL=1,BND(I)%NCOL !## skip constant heads, inactive cells IF(BND(I)%X(ICOL,IROW).LE.0.0D0)CYCLE !## check whether this is a open flow boundary IC=MAX(ICOL-1,1); IR=IROW IF(BND(I)%X(IC,IR).EQ.0.0D0)BND(I)%X(ICOL,IROW)=2.0D0 IC=MIN(ICOL+1,BND(I)%NCOL); IR=IROW IF(BND(I)%X(IC,IR).EQ.0.0D0)BND(I)%X(ICOL,IROW)=2.0D0 IC=ICOL; IR=MAX(IROW-1,1) IF(BND(I)%X(IC,IR).EQ.0.0D0)BND(I)%X(ICOL,IROW)=2.0D0 IC=ICOL; IR=MIN(IROW+1,BND(I)%NROW) IF(BND(I)%X(IC,IR).EQ.0.0D0)BND(I)%X(ICOL,IROW)=2.0D0 ENDDO ENDDO !## add at least a single constant head cell otherwise there is a risk that the model won't converge - take the toplayer IF(IHDFIX.EQ.0)THEN IRLOOP: DO IROW=1,BND(I)%NROW; DO ICOL=1,BND(I)%NCOL !## skip constant heads, inactive cells IF(BND(I)%X(ICOL,IROW).EQ.2.0D0)THEN !## make sure at least 1 single cell is active DO J=1,4 IC=ICOL+JC(J); IR=IROW+JR(J) IF(IC.GT.0.AND.IC.LE.BND(I)%NCOL.AND. & IR.GT.0.AND.IR.LE.BND(I)%NROW)THEN IF(BND(I)%X(IC,IR).GT.0.0D0)IHDFIX=1 ENDIF ENDDO IF(IHDFIX.EQ.1)THEN; BND(I)%X(ICOL,IROW)=-2.0D0; EXIT IRLOOP; ENDIF ENDIF ENDDO; ENDDO IRLOOP ENDIF ENDDO !## save bnd only if this is the boss ! IF(PBMAN%BOSS.EQ.1)THEN DO I=PRJNLAY,1,-1 ! !## set at least a single location with a fixed head (why) ! IF(IFIX.EQ.0)THEN !IROWLOOP: DO IROW=1,BND(I)%NROW; DO ICOL=1,BND(I)%NCOL ! IF(BND(I)%X(ICOL,IROW).EQ.2.0D0)THEN; BND(I)%X(ICOL,IROW)=-2.0D0; IFIX=1; EXIT IROWLOOP; ENDIF ! ENDDO; ENDDO IROWLOOP ! ENDIF FNAME=TRIM(OUTMAP)//'\BND\SEPMODEL'//TRIM(VTOS(IMODEL(ISEP)))//'\BND_L'//TRIM(VTOS(I))//'.IDF' IF(.NOT.IDFWRITE(BND(I),FNAME,1))STOP ENDDO ! ENDIF !## process zone files if needed IF(PBMAN%INTPARAM.EQ.1)THEN CALL IDFIROWICOL(BND(1),IR2,IC1,XXMIN,YYMIN) CALL IDFIROWICOL(BND(1),IR1,IC2,XXMAX,YYMAX) DO I=1,SIZE(PEST%IDFFILES) IF(.NOT.IDFREADSCALE(PEST%IDFFILES(I),BND(1),15,1,0.0D0,0))RETURN !## correct for buffer area DO IROW=1,IR1; DO ICOL=1,BND(1)%NCOL; BND(1)%X(ICOL,IROW)=0.0D0; ENDDO; ENDDO DO IROW=IR2+1,BND(1)%NROW; DO ICOL=1,BND(1)%NCOL; BND(1)%X(ICOL,IROW)=0.0D0; ENDDO; ENDDO DO IROW=1,BND(1)%NROW; DO ICOL=1,IC1; BND(1)%X(ICOL,IROW)=0.0D0; ENDDO; ENDDO DO IROW=1,BND(1)%NROW; DO ICOL=IC2+1,BND(1)%NCOL; BND(1)%X(ICOL,IROW)=0.0D0; ENDDO; ENDDO FNAME=TRIM(OUTMAP)//'\ZONE\SEPMODEL'//TRIM(VTOS(IMODEL(ISEP)))//'\ZONE_'//TRIM(VTOS(I))//'.IDF' IF(.NOT.IDFWRITE(BND(1),FNAME,1))STOP ENDDO ENDIF ENDDO CALL IDFDEALLOCATE(BND,SIZE(BND)); DEALLOCATE(ISIZE) END SUBROUTINE PMANAGER_SEPMODEL_BND !###====================================================================== SUBROUTINE PMANAGER_SEPMODEL_ADDBND(OUTMAP,IPOL) !###====================================================================== IMPLICIT NONE CHARACTER(LEN=*),INTENT(IN) :: OUTMAP INTEGER,INTENT(IN) :: IPOL CHARACTER(LEN=256) :: FNAME INTEGER :: I DO I=1,PRJNLAY FNAME=TRIM(OUTMAP)//'\BND\SEPMODEL'//TRIM(VTOS(IPOL))//'\BND_L'//TRIM(VTOS(I))//'.IDF' TOPICS(TBND)%STRESS(1)%FILES(1,I)%ICNST=2 TOPICS(TBND)%STRESS(1)%FILES(1,I)%CNST=-999.99D0 TOPICS(TBND)%STRESS(1)%FILES(1,I)%FNAME=FNAME ENDDO IF(PBMAN%INTPARAM.EQ.1)THEN DO I=1,SIZE(PEST%IDFFILES) PEST%IDFFILES(I)=TRIM(OUTMAP)//'\ZONE\SEPMODEL'//TRIM(VTOS(IPOL))//'\ZONE_'//TRIM(VTOS(I))//'.IDF' ENDDO ENDIF END SUBROUTINE PMANAGER_SEPMODEL_ADDBND !###====================================================================== LOGICAL FUNCTION PMANAGERRUN(ID,RUNFNAME,IBATCH) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ID,IBATCH CHARACTER(LEN=*),INTENT(IN) :: RUNFNAME INTEGER :: IU,ITOPIC,IRUN,ILOGFILE,ISUB,I,N CHARACTER(LEN=256) :: FNAME,DIR LOGICAL :: LEX !## 2 applications of the function based on IDF input: !## - ID_OPENRUN: opens an existing Runfile to read all modelfiles !## - ID_SAVERUN: starts the Simulation Manager Window. PMANAGERRUN=.FALSE. ILOGFILE=0 !## open existing runfile IF(ID.EQ.ID_OPENRUN)THEN IF(RUNFNAME.EQ.'')THEN FNAME='' IF(.NOT.UTL_WSELECTFILE('iMOD Run File (*.run)|*.run|', & LOADDIALOG+MUSTEXIST+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,& 'Load iMOD Run File'))RETURN ELSE FNAME=RUNFNAME ENDIF IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=FNAME,STATUS='OLD',ACTION='READ,DENYWRITE',FORM='FORMATTED') IF(IBATCH.EQ.0)CALL UTL_MESSAGEHANDLE(0) !## read existing RUN file and fill treeview IF(PMANAGER_GETKEYS(IU)) THEN IF(PMANAGER_GETFILES(IU,ITOPIC))THEN IF(IBATCH.EQ.0)CALL PMANAGER_UTL_UPDATE_TREEVIEW(0,0,0); PMANAGERRUN=.TRUE. ELSE CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Error reading BODY runfile '//TRIM(TOPICS(ITOPIC)%CMOD),'Error') ENDIF ELSE CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Error reading HEADER runfile','Error') ENDIF CLOSE(IU) IF(IBATCH.EQ.0)CALL UTL_MESSAGEHANDLE(1) !## Start Simulation Manager ELSEIF(ID.EQ.ID_SAVERUN)THEN PBMAN%RUNFILE=RUNFNAME !## Open simulation manager window and get info from it, e.g. fname and pbman%** LEX=PMANAGER_INITSIM(PBMAN%RUNFILE,IBATCH,IRUN) IF(.NOT.LEX)THEN; CALL PMANAGER_INITSIM_DEAL(1); RETURN; ENDIF !## swith from ipest to ipestp for simulations with modflow6 at all times IF(PBMAN%IFORMAT.EQ.3)THEN IF(PBMAN%IPEST.EQ.1)THEN; PBMAN%IPESTP=1; PBMAN%IPEST=0; ENDIF ENDIF !## Simulation Manager window closed, continue writing model files. IF(IBATCH.EQ.0)CALL UTL_MESSAGEHANDLE(0) SELECT CASE (PBMAN%IFORMAT) !## runfile CASE (1) IF(PMANAGER_SAVERUN(PBMAN%RUNFILE,IBATCH))THEN IF(IBATCH.EQ.0)THEN IF(IRUN.EQ.0)CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'Successfully written runfile:'//CHAR(13)//TRIM(PBMAN%RUNFILE)//CHAR(13)//CHAR(13)// & 'Start the MODELTOOL to use this runfile for a simulation.','Information') ELSE WRITE(*,'(/A/)') 'Successfully written runfile:'//TRIM(PBMAN%RUNFILE) ENDIF PMANAGERRUN=.TRUE. ENDIF !## mf2005/seawat standard CASE (2,6) IF(ABS(PBMAN%IEXPORTMF2005).EQ.1)THEN IF(PMANAGER_SAVEMF2005(PBMAN%RUNFILE,IBATCH))THEN IF(IBATCH.EQ.0)THEN IF(IRUN.EQ.0)CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'Successfully written MF2005 files:'//CHAR(13)//TRIM(PBMAN%RUNFILE),'Information') ELSE WRITE(*,'(/A/)') 'Successfully written MF2005 files:'//TRIM(PBMAN%RUNFILE) ENDIF PMANAGERRUN=.TRUE. ELSE PMANAGERRUN=.FALSE. ENDIF ELSE !## define prjidf IF(.NOT.PMANAGER_SAVEMF2005_SIM(IBATCH))RETURN IF(.NOT.IPEST_GLM_SETGROUPS(IBATCH))RETURN WRITE(*,'(/A/)') 'Reusing existing exported-files for MF2005 files:'//TRIM(PBMAN%RUNFILE) PMANAGERRUN=.TRUE. ENDIF CALL PMANAGER_SAVEMF2005_DEALLOCATE() !## mf6 CASE (3) IF(ABS(PBMAN%IEXPORTMF2005).EQ.1)THEN !## generate IDF files for submodelling IF(PBMAN%IGENMF6.EQ.1)THEN IF(LEN_TRIM(PBMAN%OUTPUT).EQ.0)THEN; DIR=PBMAN%RUNFILE(:INDEX(PBMAN%RUNFILE,'\',.TRUE.)-1) ELSE; DIR=TRIM(PBMAN%OUTPUT); ENDIF; DIR=TRIM(DIR)//'\GEN' !## generate them per submodel and per layer IF(PBMAN%SMTYPE.EQ.1)THEN DO I=1,PRJNLAY; IF(.NOT.PMANAGER_GENERATEMFNETWORKS(PBMAN%GENFNAME,DIR,N,IBATCH,I,PBMAN%FORCECRD))THEN; RETURN; ENDIF; ENDDO !## generate them for all layers ELSE IF(.NOT.PMANAGER_GENERATEMFNETWORKS(PBMAN%GENFNAME,DIR,PBMAN%NSUBMODEL,IBATCH,0,PBMAN%FORCECRD))THEN; RETURN; ENDIF ENDIF PBMAN%IWINDOW=3; CALL POLYGON1CLOSE() !## mf6 model for the entire region ELSE PBMAN%NSUBMODEL=1 ENDIF !## generate all submodels DO ISUB=1,PBMAN%NSUBMODEL PBMAN%ISUBMODEL=ISUB !## set fname IF(PBMAN%IWINDOW.EQ.3)THEN IF(PBMAN%IGENMF6.EQ.1)PBMAN%BNDFILE=TRIM(DIR)//'\'//'SUBMODEL'//TRIM(VTOS(ISUB))//'.IDF' ENDIF !## set active layers for current submodel IF(PBMAN%SMTYPE.EQ.1)THEN IF(ASSOCIATED(PBMAN%ILAY))DEALLOCATE(PBMAN%ILAY) ALLOCATE(PBMAN%ILAY(PRJNLAY)); PBMAN%ILAY=0 N=SIZE(PBMAN%SM(ISUB)%ILAY); DO I=1,N; PBMAN%ILAY(PBMAN%SM(ISUB)%ILAY(I))=1; ENDDO ENDIF IF(PMANAGER_SAVEMF2005(PBMAN%RUNFILE,IBATCH))THEN IF(IBATCH.EQ.0)THEN CALL WINDOWOUTSTATUSBAR(4,'Successfully written MF6 files:'//CHAR(13)//TRIM(PBMAN%RUNFILE)) IF(ISUB.EQ.PBMAN%NSUBMODEL.AND.IRUN.EQ.0)CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK, & 'Successfully written MODFLOW6 Namfile:'//CHAR(13)//TRIM(PBMAN%RUNFILE)//CHAR(13)//CHAR(13),'Information') ELSE WRITE(*,'(/A/)') 'Successfully written MF6 files:'//TRIM(PBMAN%RUNFILE) ENDIF PMANAGERRUN=.TRUE. ENDIF CALL PMANAGER_SAVEMF2005_DEALLOCATE() ENDDO IF(ASSOCIATED(PBMAN%SM))DEALLOCATE(PBMAN%SM) ELSE IF(.NOT.IPEST_GLM_SETGROUPS(IBATCH))RETURN; PMANAGERRUN=.TRUE.; CALL PMANAGER_SAVEMF2005_DEALLOCATE() !## define prjidf IF(.NOT.PMANAGER_SAVEMF2005_SIM(IBATCH))RETURN WRITE(*,'(/A/)') 'Reusing existing exported-files for MF2005 files:'//TRIM(PBMAN%RUNFILE) ENDIF !## SeaWAT/MT3D CASE (4,5) IF(PMANAGER_SAVERUNWQ(PBMAN%RUNFILE,IBATCH))THEN IF(IBATCH.EQ.0)THEN IF(IRUN.EQ.0)CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'Successfully written SEAWAT runfile:'//CHAR(13)//TRIM(PBMAN%RUNFILE),'Information') ELSE WRITE(*,'(/A/)') 'Successfully written SEAWAT runfile:'//TRIM(PBMAN%RUNFILE) ENDIF PMANAGERRUN=.TRUE. ENDIF END SELECT CALL UTL_CLOSEUNITS() ! IF(ASSOCIATED(PBMAN%UNCONFINED))DEALLOCATE(PBMAN%UNCONFINED) ! IF(ASSOCIATED(PBMAN%ILAY))DEALLOCATE(PBMAN%ILAY) !## start the model ! IF(PBMAN%ISOLVE.EQ.0)IRUN=0 ! IF(ABS(IRUN).EQ.1.AND.PMANAGERRUN)CALL PMANAGERSTART(PBMAN%RUNFILE,IRUN,IBATCH,1,ILOGFILE) IF(PMANAGERRUN)CALL PMANAGERSTART(PBMAN%RUNFILE,IRUN,IBATCH,1,ILOGFILE) IF(IBATCH.EQ.0)CALL UTL_MESSAGEHANDLE(1) IF(PBMAN%NMODELS.EQ.0)THEN CALL PMANAGER_INITSIM_DEAL(1) IF(ASSOCIATED(PBMAN%UNCONFINED))DEALLOCATE(PBMAN%UNCONFINED) IF(ASSOCIATED(PBMAN%ILAY))DEALLOCATE(PBMAN%ILAY) ENDIF ENDIF END FUNCTION PMANAGERRUN !###====================================================================== SUBROUTINE PMANAGERSTART(RUNFNAME,IRUNMODE,IBATCH,NICORES,ILOGFILE) !###====================================================================== IMPLICIT NONE CHARACTER(LEN=*),INTENT(IN) :: RUNFNAME INTEGER,INTENT(IN) :: IRUNMODE,IBATCH,NICORES,ILOGFILE CHARACTER(LEN=256) :: DIR,DIRO,DIRNAME,SEXENAME,FNAME CHARACTER(LEN=128) :: MNAME INTEGER :: IU,IOS,I,II,J,JJ,K,N1,N2,IFLAGS,IEXCOD,IERROR,IMODE,I1,KPER INTEGER :: IPREVAL,ISHORT,III,NII ! location of executable LOGICAL :: LEX,LTOMLOLD LTOMLOLD=.FALSE. IMODE=0 SELECT CASE (PBMAN%IFORMAT) !## mf2005-run,mf2005-nam CASE (1,2); IPREVAL=8; FNAME=PREFVAL(IPREVAL) !## seawat,mt3d CASE (4:6); IPREVAL=9; FNAME=PREFVAL(IPREVAL) !## modflow6 CASE (3) !## modflow6 exe IPREVAL=12; FNAME=PREFVAL(IPREVAL) !## use coupler in case metaswap is active IF(TOPICS(TCAP)%IACT_MODEL.EQ.1)THEN FNAME=''; IF(TRIM(PBMAN%COUPLER).NE.'')FNAME=TRIM(PBMAN%COUPLER)//'\imodc.exe' ENDIF END SELECT IF(LEN_TRIM(FNAME).GT.0)THEN INQUIRE(FILE=FNAME,EXIST=LEX) ELSE LEX=.FALSE. ENDIF IF(.NOT.LEX)THEN IF(PBMAN%ISOLVE.EQ.1)THEN IF(IBATCH.EQ.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,TRIM(FNAME)//' cannot be started, iMOD cannot find the solver executable:'//CHAR(13)// & '['//TRIM(FNAME)//']','Error') ELSE SELECT CASE (PBMAN%IFORMAT) CASE (1,2); WRITE(*,'(A)') TRIM(FNAME)//' cannot be started, iMOD cannot find the MODFLOW executable given, check input for keyword MODFLOW' CASE (4:6); WRITE(*,'(A)') TRIM(FNAME)//' cannot be started, iMOD cannot find the IMOD-WQ executable given, check input for keyword IMOD-WQ' CASE (3) IF(TOPICS(TCAP)%IACT_MODEL.EQ.0)WRITE(*,'(A)') TRIM(FNAME)//' cannot be started, iMOD cannot find the MODFLOW6 executable given, check input for keyword MODFLOW6' IF(TOPICS(TCAP)%IACT_MODEL.EQ.1)WRITE(*,'(A)') TRIM(FNAME)//' cannot be started, iMOD cannot find the COUPLER executable given, check input for keyword COUPLER' END SELECT WRITE(*,'(A)') '['//TRIM(FNAME)//']' ENDIF ENDIF RETURN ENDIF IMODE=0 !## runfile or namfile IF(INDEX(UTL_CAP(RUNFNAME,'U'),'.NAM',.TRUE.).GT.0)THEN IMODE=1 ELSEIF(INDEX(UTL_CAP(RUNFNAME,'U'),'.RUN',.TRUE.).GT.0)THEN IMODE=2 ELSE IF(IBATCH.EQ.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMODFLOW cannot be started with given file:'//CHAR(13)// & TRIM(RUNFNAME),'Error') ELSE WRITE(*,'(A)') 'iMODFLOW cannot be started with given file: '//TRIM(RUNFNAME) ENDIF RETURN ENDIF !## simulation directory DIR=RUNFNAME(:INDEX(RUNFNAME,'\',.TRUE.)-1) DIRO=DIR; IF(TRIM(PBMAN%OUTPUT).NE.'')DIRO=PBMAN%OUTPUT CALL IOSDIRNAME(DIRNAME) !## make sure diro and pbman%output are all absolute pathnames FNAME=DIR; CALL UTL_RELPATHNAME(DIRNAME,FNAME,DIR) FNAME=DIRO; CALL UTL_RELPATHNAME(DIRNAME,FNAME,DIRO) CALL UTL_CREATEDIR(DIR); CALL UTL_CREATEDIR(DIRO) !## modelname MNAME=RUNFNAME(INDEX(RUNFNAME,'\',.TRUE.)+1:INDEX(RUNFNAME,'.',.TRUE.)-1) !## time information I=0; DO KPER=1,PRJNPER IF(ASSOCIATED(SIM))THEN IF(KPER.LE.SIZE(SIM))THEN IF(SIM(KPER)%DELT.NE.0.0D0)I=1 ENDIF ENDIF ENDDO !## turn off metaswap whenever a steady-state model is concerned IF(I.EQ.0)TOPICS(TCAP)%IACT_MODEL=0 !## create component file(s) - not for modflow6/seawat/mt3d/imod-wq IF(TOPICS(TCAP)%IACT_MODEL.EQ.1.AND.PBMAN%IFORMAT.LE.2)THEN N1=1; N2=1; IF(PBMAN%IPESTP.EQ.1)THEN; N1=-PBMAN%NLAMBDASEARCH; N2=SIZE(PEST%PARAM); ENDIF DO I=N1,N2 !## skip zero IF(I.EQ.0)CYCLE !## simulate batch-file IU=UTL_GETUNIT() IF(PBMAN%IPESTP.EQ.0)THEN CALL OSD_OPEN(IU,FILE=TRIM(DIR)//'\COMPONENTS.INP',STATUS='REPLACE',ACTION='WRITE,DENYREAD',IOSTAT=IOS) ELSE IF(I.GT.0)THEN IF(PEST%PARAM(I)%PACT.EQ.0.OR.PEST%PARAM(I)%PIGROUP.LT.0)CYCLE CALL OSD_OPEN(IU,FILE=TRIM(DIR)//'\COMPONENTS_P#'//TRIM(VTOS(I))//'.INP',STATUS='REPLACE',ACTION='WRITE,DENYREAD',IOSTAT=IOS) ELSE CALL OSD_OPEN(IU,FILE=TRIM(DIR)//'\COMPONENTS_L#'//TRIM(VTOS(ABS(I)))//'.INP',STATUS='REPLACE',ACTION='WRITE,DENYREAD',IOSTAT=IOS) ENDIF ENDIF IF(IOS.NE.0)THEN IF(IBATCH.EQ.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMODFLOW is already running, you cannot start '//CHAR(13)// & 'new run while previous run is still running'//CHAR(13)//'or'//CHAR(13)//'Run-script cannot be created'//CHAR(13)// & TRIM(DIR)//'\COMPONENTS.INP','Error') ELSE WRITE(*,'(A)') 'iMODFLOW is already running, you cannot start new run while previous run is still running'// & 'or Run-script cannot be created '//TRIM(DIR)//'\COMPONENTS.INP' ENDIF RETURN ENDIF IF(PBMAN%IPESTP.EQ.0)THEN WRITE(IU,'(A)') 'MODFLOW -wd \MODELINPUT -namfile "'//TRIM(DIR)//'\'//TRIM(MNAME)//'.NAM" -DXC .\MODELINPUT\'//TRIM(MNAME)//'.DXC' ELSE IF(I.GT.0)THEN IF(PEST%PARAM(I)%PACT.EQ.0.OR.PEST%PARAM(I)%PIGROUP.LT.0)CYCLE WRITE(IU,'(A)') 'MODFLOW -wd \MODELINPUT -namfile "'//TRIM(DIR)//'\'//TRIM(MNAME)//'_P#'//TRIM(VTOS(I))//'.NAM" -DXC .\MODELINPUT\'//TRIM(MNAME)//'.DXC' ELSE WRITE(IU,'(A)') 'MODFLOW -wd \MODELINPUT -namfile "'//TRIM(DIR)//'\'//TRIM(MNAME)//'_L#'//TRIM(VTOS(ABS(I)))//'.NAM" -DXC .\MODELINPUT\'//TRIM(MNAME)//'.DXC' ENDIF ENDIF WRITE(IU,'(A)') 'METASWAP -wd \MSWAPINPUT' CLOSE(IU) ENDDO ENDIF INQUIRE(FILE=TRIM(EXEPATH)//'\'//TRIM(LICFILE),EXIST=LEX) IF(.NOT.LEX)THEN IERROR=0; CALL IMOD_AGREEMENT(IERROR) IF(IERROR.NE.1)THEN IF(LBETA)THEN IF(IBATCH.EQ.0)THEN CALL WMESSAGEBOX(OKONLY,COMMONOK,EXCLAMATIONICON,'Cannot start Beta-iMOD because you are not authorized in writing for Beta-iMOD','Error') ELSE WRITE(*,'(A)') 'Cannot start Beta-iMOD because you are not authorized in writing for Beta-iMOD' ENDIF ELSE IF(IBATCH.EQ.0)THEN CALL WMESSAGEBOX(OKONLY,COMMONOK,EXCLAMATIONICON,'Cannot start iMODFLOW unless you accept the iMOD Software License Agreement','Error') ELSE WRITE(*,'(A)') 'Cannot start iMODFLOW unless you accept the iMOD Software License Agreement' ENDIF ENDIF RETURN ENDIF ENDIF ! !## Save Keywords from Model Simulation window to INI file. For reuse in window or run iMODBATCH Function= RUNFILE ! IF(PMANAGERINI(1,"")) THEN; ENDIF !## create toml file for metaswap coupler and modflow6 IF(TOPICS(TCAP)%IACT_MODEL.EQ.1.AND.PBMAN%IFORMAT.EQ.3)THEN IU=UTL_GETUNIT() CALL OSD_OPEN(IU,FILE=TRIM(DIR)//'\'//TRIM(MNAME)//'.TOML',STATUS='REPLACE',ACTION='WRITE,DENYREAD',IOSTAT=IOS) WRITE(IU,'(A/)') '# File created by iMOD version'//TRIM(RVERSION) WRITE(IU,'(A)') 'timing = false' WRITE(IU,'(A)') 'log_level = "INFO"' IF(LTOMLOLD)THEN WRITE(IU,'(/A)') '[kernels]' WRITE(IU,'( A)') ' [kernels.modflow6]' WRITE(IU,'( A)') ' dll = '//CHAR(39)//TRIM(PBMAN%COUPLER)//'\libmf6.dll'//CHAR(39) WRITE(IU,'( A)') ' model = '//CHAR(39)//TRIM(DIR)//CHAR(39) WRITE(IU,'(/A)') ' [kernels.metaswap]' WRITE(IU,'( A)') ' dll = '//CHAR(39)//TRIM(PBMAN%COUPLER)//'\metaswap.dll'//CHAR(39) IF(PBMAN%TOPMODEL.EQ.1)THEN WRITE(IU,'( A)') ' model = '//CHAR(39)//TRIM(DIR)//'\GWF_0\MSWAPINPUT'//CHAR(39) ELSE WRITE(IU,'( A)') ' model = '//CHAR(39)//TRIM(DIR)//'\GWF_1\MSWAPINPUT'//CHAR(39) ENDIF WRITE(IU,'( A)') ' dll_dependency = '//CHAR(39)//TRIM(PBMAN%COUPLER)//CHAR(39) WRITE(IU,'(/A)') '[[exchanges]]' WRITE(IU,'( A)') '# Two kernels per exchange' WRITE(IU,'( A)') 'kernels = ['//CHAR(39)//'modflow6'//CHAR(39)//','//CHAR(39)//'metaswap'//CHAR(39)//']' ELSE WRITE(IU,'(/A)') 'driver_type = '//CHAR(39)//'metamod'//CHAR(39) WRITE(IU,'(/A)') '# MODFLOW6' WRITE(IU,'( A)') '[driver.kernels.modflow6]' WRITE(IU,'( A)') 'dll = '//CHAR(39)//TRIM(PBMAN%COUPLER)//'\libmf6.dll'//CHAR(39) WRITE(IU,'( A)') 'work_dir = '//CHAR(39)//TRIM(DIR)//CHAR(39) WRITE(IU,'(/A)') '# MetaSWAP' WRITE(IU,'( A)') '[driver.kernels.metaswap]' WRITE(IU,'( A)') 'dll = '//CHAR(39)//TRIM(PBMAN%COUPLER)//'\metaswap.dll'//CHAR(39) WRITE(IU,'( A)') 'dll_dep_dir = '//CHAR(39)//TRIM(PBMAN%COUPLER)//CHAR(39) IF(PBMAN%TOPMODEL.EQ.1)THEN WRITE(IU,'( A)') 'work_dir = '//CHAR(39)//TRIM(DIR)//'\GWF_0\MSWAPINPUT'//CHAR(39) ELSE WRITE(IU,'( A)') 'work_dir = '//CHAR(39)//TRIM(DIR)//'\GWF_1\MSWAPINPUT'//CHAR(39) ENDIF WRITE(IU,'(/A)') '# Inner model with sprinkling' WRITE(IU,'( A)') '[[driver.coupling]]' WRITE(IU,'( A)') 'enable_sprinkling = true' IF(PBMAN%TOPMODEL.EQ.1)THEN WRITE(IU,'( A)') 'mf6_model = '//CHAR(39)//'GWF_0'//CHAR(39) ELSE WRITE(IU,'( A)') 'mf6_model = '//CHAR(39)//'GWF_1'//CHAR(39) ENDIF WRITE(IU,'( A)') 'mf6_msw_recharge_pkg = '//CHAR(39)//'RCH_MSW'//CHAR(39) WRITE(IU,'( A)') 'mf6_msw_well_pkg = '//CHAR(39)//'WELLS_MSW'//CHAR(39) WRITE(IU,'( A)') 'mf6_msw_node_map = '//CHAR(39)//TRIM(DIR)//'\nodenr2svat.dxc'//CHAR(39) WRITE(IU,'( A)') 'mf6_msw_recharge_map = '//CHAR(39)//TRIM(DIR)//'\rchindex2svat.dxc'//CHAR(39) WRITE(IU,'( A)') 'mf6_msw_sprinkling_map = '//CHAR(39)//TRIM(DIR)//'\wellindex2svat.dxc'//CHAR(39) ! WRITE(IU,'(/A)') '# Outer model without sprinkling' ! WRITE(IU,'( A)') '[[driver.coupling]]' ! WRITE(IU,'( A)') 'enable_sprinkling = false' ! WRITE(IU,'( A)') 'mf6_model = '//CHAR(39)//'outer_model'//CHAR(39) ! WRITE(IU,'( A)') 'mf6_msw_recharge_pkg = '//CHAR(39)//'RCH_MSW'//CHAR(39) ! WRITE(IU,'( A)') 'mf6_msw_node_map = '//CHAR(39)//TRIM(DIR)//'\nodenr2svat.dxc'//CHAR(39) ! WRITE(IU,'( A)') 'mf6_msw_recharge_map = '//CHAR(39)//TRIM(DIR)//'\rchindex2svat.dxc'//CHAR(39) ENDIF CLOSE(IU) ENDIF !## copy imod license text file CALL IOSCOPYFILE(TRIM(EXEPATH)//'\'//TRIM(LICFILE),TRIM(DIR)//'\'//TRIM(LICFILE)) N1=1; N2=1 IF(PBMAN%IPESTP.EQ.1)THEN IF(PEST%PE_MXITER.LT.0)THEN N1=-1; N2=N1 ELSE N1=-PBMAN%NLAMBDASEARCH; N2=SIZE(PEST%PARAM) ENDIF ELSEIF(PBMAN%IIES.EQ.1)THEN N1=1; N2=PEST%NREALS ENDIF DO I=N1,N2 !## skip zero IF(I.EQ.0)CYCLE !## simulate batch-file IU=UTL_GETUNIT() IF(PBMAN%IPESTP+PBMAN%IIES.EQ.0)THEN FNAME=TRIM(DIR)//'\RUN.BAT' ELSEIF(PBMAN%IPESTP.EQ.1)THEN IF(I.GT.0)THEN IF(PEST%PARAM(I)%PACT.EQ.0.OR.PEST%PARAM(I)%PIGROUP.LT.0)then !## remove nam-file if exists IF(PBMAN%IFORMAT.EQ.3.OR.PBMAN%IFORMAT.EQ.6)THEN FNAME=TRIM(DIR)//'\'//TRIM(MNAME)//'_P#'//TRIM(VTOS(I))//'.NAM' INQUIRE(FILE=FNAME,EXIST=LEX); IF(LEX)CALL IOSDELETEFILE(FNAME) CYCLE ENDIF ENDIF !## mf6 IF(PBMAN%IFORMAT.EQ.3)THEN FNAME=TRIM(DIR)//'\IPEST_P#'//TRIM(VTOS(I))//'\RUN_P#'//TRIM(VTOS(I))//'.BAT' ELSE FNAME=TRIM(DIR)//'\RUN_P#'//TRIM(VTOS(I))//'.BAT' ENDIF ELSE IF(PBMAN%IFORMAT.EQ.3)THEN FNAME=TRIM(DIR)//'\IPEST_L#'//TRIM(VTOS(ABS(I)))//'\RUN_L#'//TRIM(VTOS(ABS(I)))//'.BAT' ELSE FNAME=TRIM(DIR)//'\RUN_L#'//TRIM(VTOS(ABS(I)))//'.BAT' ENDIF ENDIF ELSEIF(PBMAN%IIES.EQ.1)THEN IF(PBMAN%IFORMAT.EQ.3)THEN FNAME=TRIM(DIR)//'\IPEST_R#'//TRIM(VTOS(I))//'\RUN_R#'//TRIM(VTOS(I))//'.BAT' ELSE FNAME=TRIM(DIR)//'\RUN_R#'//TRIM(VTOS(I))//'.BAT' ENDIF ENDIF !## open batchfile to be created CALL OSD_OPEN(IU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE,DENYREAD',IOSTAT=IOS) IF(IOS.NE.0)THEN IF(IBATCH.EQ.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMODFLOW is already running, you cannot start '//CHAR(13)// & 'new run while previous run is still running'//CHAR(13)//'or'//CHAR(13)//'Run-script cannot be created','Error') ELSE WRITE(*,'(A)') 'iMODFLOW is already running, you cannot start new run while previous run is still running'// & 'or Run-script cannot be created' ENDIF RETURN ENDIF SEXENAME='"'//TRIM(PREFVAL(IPREVAL))//'"' !## write start script in batch file WRITE(IU,'(A)') 'REM ==========================' WRITE(IU,'(A)') 'REM Run Script iMOD '//TRIM(RVERSION) WRITE(IU,'(A)') 'REM ==========================' !## namfile IF(IMODE.EQ.1)THEN IF(PBMAN%IFORMAT.EQ.2.OR.PBMAN%IFORMAT.EQ.6)WRITE(IU,'(A)') 'TITLE "NAMFILE: '//TRIM(MNAME)//'.nam"' IF(PBMAN%IPKS.EQ.1.AND.PBMAN%NRPROC.GT.1)THEN WRITE(IU,'(A)') 'set np='//VTOS(PBMAN%NRPROC) WRITE(IU,'(A)') '' SEXENAME='"C:\Program Files\MPICH2\bin\mpiexec.exe" -localonly %np% '//TRIM(SEXENAME) ENDIF IF(TOPICS(TCAP)%IACT_MODEL.EQ.1)THEN IF(PBMAN%IFORMAT.EQ.3)THEN WRITE(IU,'(/A)') 'REM run iMOD-coupler with MODFLOW6-METASWAP model' WRITE(SEXENAME,'(A)') TRIM(PBMAN%COUPLER)//'\imodc.exe '//TRIM(MNAME)//'.toml' ELSE WRITE(IU,'(/A)') 'REM run iMODFLOW-METASWAP model' IF(PBMAN%IPESTP.EQ.0)THEN IF(PBMAN%IFORMAT.EQ.3)THEN WRITE(SEXENAME,'(A)') TRIM(SEXENAME) ELSE WRITE(SEXENAME,'(A)') TRIM(SEXENAME)//' -components components.inp' ENDIF ELSE IF(I.GT.0)THEN WRITE(SEXENAME,'(A)') TRIM(SEXENAME)//' -components components_p#'//TRIM(VTOS(I))//'.inp' ELSE WRITE(SEXENAME,'(A)') TRIM(SEXENAME)//' -components components_l#'//TRIM(VTOS(ABS(I)))//'.inp' ENDIF ENDIF IF(PBMAN%IPEST+PBMAN%IPESTP.GT.0.AND.PBMAN%IFORMAT.EQ.2)THEN IF(I.GT.0)THEN IF(PBMAN%IFORMAT.EQ.2)THEN WRITE(SEXENAME,'(A)') TRIM(SEXENAME)//' -ipest ".\modelinput\'//TRIM(MNAME)//'_p#'//TRIM(VTOS(I))//'.pst1"' ENDIF ELSE IF(PBMAN%IFORMAT.EQ.2)THEN WRITE(SEXENAME,'(A)') TRIM(SEXENAME)//' -ipest ".\modelinput\'//TRIM(MNAME)//'_l#'//TRIM(VTOS(ABS(I)))//'.pst1"' ENDIF ENDIF ENDIF IF(PBMAN%IPKS.EQ.1.AND.ABS(PBMAN%PKSMERGE).EQ.1)THEN IF(PBMAN%PKSMERGE.EQ. 1)WRITE(SEXENAME,'(A)') TRIM(SEXENAME)//' -pksmergeidf' IF(PBMAN%PKSMERGE.EQ.-1)WRITE(SEXENAME,'(A)') TRIM(SEXENAME)//' -pksmergeidfdelete' ENDIF ENDIF WRITE(IU,'(/A/)') TRIM(SEXENAME) ELSE IF(PBMAN%IPEST+PBMAN%IPESTP+PBMAN%IIES.EQ.0)THEN SELECT CASE (PBMAN%IFORMAT) CASE (2,6) IF(PBMAN%IPKS.EQ.1.AND.PBMAN%NRPROC.GT.1.AND.ABS(PBMAN%PKSMERGE).EQ.1)THEN IF(PBMAN%PKSMERGE.EQ.1) WRITE(IU,'(/A/)') TRIM(SEXENAME)//' "'//TRIM(MNAME)//'.nam" -pksmergeidf' IF(PBMAN%PKSMERGE.EQ.-1)WRITE(IU,'(/A/)') TRIM(SEXENAME)//' "'//TRIM(MNAME)//'.nam" -pksmergeidfdelete' ELSE WRITE(IU,'(/A/)') TRIM(SEXENAME)//' "'//TRIM(MNAME)//'.nam"' ENDIF CASE (4,5) WRITE(IU,'(/A/)') TRIM(SEXENAME)//' "'//TRIM(MNAME)//'.run"' CASE (3) !## modflow6 WRITE(IU,'(/A/)') TRIM(SEXENAME) END SELECT !## ipest ELSEIF(PBMAN%IPEST.EQ.1)THEN WRITE(IU,'(/A/)') TRIM(SEXENAME)//' "'//TRIM(MNAME)//'.nam" -ipest ".\modelinput\'//TRIM(MNAME)//'.pst1"' !## parrallel ipest ELSEIF(PBMAN%IPESTP.EQ.1)THEN IF(PBMAN%IFORMAT.EQ.3)THEN WRITE(IU,'(A)') 'CD "'//FNAME(:INDEX(FNAME,'\',.TRUE.)-1)//'"' WRITE(IU,'(/A/)') TRIM(SEXENAME) ELSE IF(I.GT.0)THEN IF(PBMAN%IFORMAT.EQ.2)THEN WRITE(IU,'(/A/)') TRIM(SEXENAME)//' "'//TRIM(MNAME)//'_p#'//TRIM(VTOS(I))//'.nam" -ipest ".\modelinput\'// & TRIM(MNAME)//'_p#'//TRIM(VTOS(I))//'.pst1"' ELSE WRITE(IU,'(/A/)') TRIM(SEXENAME)//' "'//TRIM(MNAME)//'_p#'//TRIM(VTOS(I))//'.nam"' ENDIF ELSE IF(PBMAN%IFORMAT.EQ.2)THEN WRITE(IU,'(/A/)') TRIM(SEXENAME)//' "'//TRIM(MNAME)//'_l#'//TRIM(VTOS(ABS(I)))//'.nam" -ipest ".\modelinput\'// & TRIM(MNAME)//'_l#'//TRIM(VTOS(ABS(I)))//'.pst1"' ELSE WRITE(IU,'(/A/)') TRIM(SEXENAME)//' "'//TRIM(MNAME)//'_l#'//TRIM(VTOS(ABS(I)))//'.nam"' ENDIF ENDIF ENDIF !## ies ELSEIF(PBMAN%IIES.EQ.1)THEN IF(PBMAN%IFORMAT.EQ.3)THEN WRITE(IU,'(A)') 'CD "'//FNAME(:INDEX(FNAME,'\',.TRUE.)-1)//'"' WRITE(IU,'(/A/)') TRIM(SEXENAME) ELSE WRITE(IU,'(/A/)') TRIM(SEXENAME)//' "'//TRIM(MNAME)//'_r#'//TRIM(VTOS(I))//'.nam" -ipest ".\modelinput\'//TRIM(MNAME)//'.pst1"' ENDIF ENDIF ENDIF WRITE(IU,'(A)') 'IF %ERRORLEVEL% NEQ 0 (ECHO AN ERROR WAS FOUND %EXIT /B %ERRORLEVEL%)' IF(I.GT.0)THEN CALL PEST_GLM_ADD_BATCHFILES(IU,'IPEST_P',I) ELSE CALL PEST_GLM_ADD_BATCHFILES(IU,'IPEST_L',ABS(I)) ENDIF ! !## include postprocessing only in case not parameter optimization is carried out ! IF(PBMAN%IPEST+PBMAN%IPESTP.EQ.0.OR.PEST%PE_MXITER.LT.0)THEN !## in case no output is desired, skip grb saving DO II=1,SIZE(PBMAN%ISAVE); IF(ASSOCIATED(PBMAN%ISAVE(II)%ILAY))EXIT; ENDDO IF(II.LT.SIZE(PBMAN%ISAVE))THEN !## include conversion from mf6 to idf files IF(PBMAN%IFORMAT.EQ.3)THEN WRITE(IU,'(/A)') 'ECHO OFF' WRITE(IU,'(/A)') 'ECHO MODFLOW finished, postprocessing started ' WRITE(IU,'(/A)') 'ECHO =============================================' WRITE(IU,'( A)') 'ECHO iMOD Batch Script iMOD '//TRIM(RVERSION) WRITE(IU,'( A)') 'ECHO =============================================' NII=1; IF(PBMAN%TOPMODEL.EQ.1)NII=0 DO III=NII,1 DO JJ=1,PBMAN%NSUBMODEL J=JJ; IF(III.EQ.0)J=0 WRITE(IU,'(/A)') 'ECHO FUNCTION=MF6TOIDF' WRITE(IU,'(/A)') 'ECHO FUNCTION=MF6TOIDF > MF6TOIDF.INI' IF(PBMAN%IPEST+PBMAN%IPESTP.GT.0)THEN WRITE(IU,'( A)') 'ECHO GRB="..\GWF_'//TRIM(VTOS(J))//'\MODELINPUT\'//TRIM(MNAME)//'.DIS6.GRB" >> MF6TOIDF.INI' IF(I.GT.0)THEN IF(LSHD) WRITE(IU,'( A)') 'ECHO HED="..\GWF_'//TRIM(VTOS(J))//'\MODELOUTPUT\IPEST_P#'//TRIM(VTOS(I))//'\HEAD\HEAD.HED" >> MF6TOIDF.INI' IF(LBDG) WRITE(IU,'( A)') 'ECHO BDG="..\GWF_'//TRIM(VTOS(J))//'\MODELOUTPUT\IPEST_P#'//TRIM(VTOS(I))//'\BUDGET\BUDGET.CBC" >> MF6TOIDF.INI' IF(LBDGUZF)WRITE(IU,'( A)') 'ECHO BDGUZF="..\GWF_'//TRIM(VTOS(J))//'\MODELOUTPUT\IPEST_P#'//TRIM(VTOS(I))//'\BUDGET_UZF\BUDGET_UZF.CBC" >> MF6TOIDF.INI' ELSE IF(LSHD) WRITE(IU,'( A)') 'ECHO HED="..\GWF_'//TRIM(VTOS(J))//'\MODELOUTPUT\IPEST_L#'//TRIM(VTOS(ABS(I)))//'\HEAD\HEAD.HED" >> MF6TOIDF.INI' IF(LBDG) WRITE(IU,'( A)') 'ECHO BDG="..\GWF_'//TRIM(VTOS(J))//'\MODELOUTPUT\IPEST_L#'//TRIM(VTOS(ABS(I)))//'\BUDGET\BUDGET.CBC" >> MF6TOIDF.INI' IF(LBDGUZF)WRITE(IU,'( A)') 'ECHO BDGUZF="..\GWF_'//TRIM(VTOS(J))//'\MODELOUTPUT\IPEST_L#'//TRIM(VTOS(ABS(I)))//'\BUDGET_UZF\BUDGET_UZF.CBC" >> MF6TOIDF.INI' ENDIF ELSE WRITE(IU,'( A)') 'ECHO GRB=".\GWF_'//TRIM(VTOS(J))//'\MODELINPUT\'//TRIM(MNAME)//'.DIS6.GRB" >> MF6TOIDF.INI' IF(LSHD) WRITE(IU,'( A)') 'ECHO HED=".\GWF_'//TRIM(VTOS(J))//'\MODELOUTPUT\HEAD\HEAD.HED" >> MF6TOIDF.INI' IF(LBDG) WRITE(IU,'( A)') 'ECHO BDG=".\GWF_'//TRIM(VTOS(J))//'\MODELOUTPUT\BUDGET\BUDGET.CBC" >> MF6TOIDF.INI' IF(LBDGUZF)THEN WRITE(IU,'( A)') 'ECHO BDGUZF=".\GWF_'//TRIM(VTOS(J))//'\MODELOUTPUT\BUDGET_UZF\BUDGET_UZF.CBC" >> MF6TOIDF.INI' WRITE(IU,'( A)') 'ECHO WC_UZF=".\GWF_'//TRIM(VTOS(J))//'\MODELOUTPUT\BUDGET_UZF\WC_UZF.WC" >> MF6TOIDF.INI' ENDIF ENDIF IF(PRJNPER.GT.1)THEN ISHORT=1; DO K=1,PRJNPER; IF(SIM(K)%IHR+SIM(K)%IMT+SIM(K)%ISC.NE.0)ISHORT=0; ENDDO DO K=1,PRJNPER IF(SIM(K)%DELT.EQ.0.0D0)THEN WRITE(IU,'(A)') 'ECHO ISTEADY=1 >> MF6TOIDF.INI' ELSEIF(SIM(K)%DELT.GT.0.0)THEN ! !## results will get timestamp at the end of the simulation ! IF(PBMAN%ISAVEENDDATE.EQ.1)THEN IF(ISHORT.EQ.0)THEN WRITE(IU,'(A,I4.4,5I2.2,A)') 'ECHO SDATE=',SIM(K)%IYR,SIM(K)%IMH,SIM(K)%IDY,SIM(K)%IHR,SIM(K)%IMT,SIM(K)%ISC,' >> MF6TOIDF.INI' ELSE WRITE(IU,'(A,I4.4,2I2.2,A)') 'ECHO SDATE=',SIM(K)%IYR,SIM(K)%IMH,SIM(K)%IDY,' >> MF6TOIDF.INI' ENDIF WRITE(IU,'(A)') 'ECHO ISAVEENDDATE='//TRIM(VTOS(PBMAN%ISAVEENDDATE))//' >> MF6TOIDF.INI' ! ELSE ! WRITE(CDATE,*) ADD_DT_TO_IDATE(SIM(K)%IYR,SIM(K)%IMH,SIM(K)%IDY,SIM(K)%IHR,SIM(K)%IMT,SIM(K)%ISC,-SIM(K)%DELT,ISHORT) ! WRITE(IU,'(A)') 'ECHO SDATE='//TRIM(CDATE)//' >> MF6TOIDF.INI' ! ENDIF EXIT ENDIF ENDDO ELSE WRITE(IU,'(A)') 'ECHO ISTEADY=1 >> MF6TOIDF.INI' ENDIF !## write layers to be saved IF(TOPICS(TSHD)%IACT_MODEL.EQ.1)CALL PMANAGER_SAVEMF2005_MF6TOIDF_ISAVE(PBMAN%ISAVE(TSHD)%ILAY,'SAVESHD',IU) IF(TOPICS(TWEL)%IACT_MODEL.EQ.1)CALL PMANAGER_SAVEMF2005_MF6TOIDF_ISAVE(PBMAN%ISAVE(TWEL)%ILAY,'SAVEWEL',IU) IF(TOPICS(TDRN)%IACT_MODEL.EQ.1)CALL PMANAGER_SAVEMF2005_MF6TOIDF_ISAVE(PBMAN%ISAVE(TDRN)%ILAY,'SAVEDRN',IU) IF(TOPICS(TRIV)%IACT_MODEL.EQ.1)CALL PMANAGER_SAVEMF2005_MF6TOIDF_ISAVE(PBMAN%ISAVE(TRIV)%ILAY,'SAVERIV',IU) IF(TOPICS(TISG)%IACT_MODEL.EQ.1)CALL PMANAGER_SAVEMF2005_MF6TOIDF_ISAVE(PBMAN%ISAVE(TISG)%ILAY,'SAVEISG',IU) IF(TOPICS(TRCH)%IACT_MODEL.EQ.1)CALL PMANAGER_SAVEMF2005_MF6TOIDF_ISAVE(PBMAN%ISAVE(TRCH)%ILAY,'SAVERCH',IU) IF(TOPICS(TEVT)%IACT_MODEL.EQ.1)CALL PMANAGER_SAVEMF2005_MF6TOIDF_ISAVE(PBMAN%ISAVE(TEVT)%ILAY,'SAVEEVT',IU) IF(TOPICS(TGHB)%IACT_MODEL.EQ.1)CALL PMANAGER_SAVEMF2005_MF6TOIDF_ISAVE(PBMAN%ISAVE(TGHB)%ILAY,'SAVEGHB',IU) IF(TOPICS(TCHD)%IACT_MODEL.EQ.1)CALL PMANAGER_SAVEMF2005_MF6TOIDF_ISAVE(PBMAN%ISAVE(TCHD)%ILAY,'SAVECHD',IU) IF(TOPICS(TUZF)%IACT_MODEL.EQ.1)CALL PMANAGER_SAVEMF2005_MF6TOIDF_ISAVE(PBMAN%ISAVE(TUZF)%ILAY,'SAVEUZF',IU) I1=0; DO II=1,SIZE(TFLX) IF(ASSOCIATED(PBMAN%ISAVE(TFLX(II))%ILAY))THEN SELECT CASE (TFLX(II)) CASE (TSTO) CALL PMANAGER_SAVEMF2005_MF6TOIDF_ISAVE(PBMAN%ISAVE(TFLX(II))%ILAY,'SAVESTO',IU) CASE (TSPY) CALL PMANAGER_SAVEMF2005_MF6TOIDF_ISAVE(PBMAN%ISAVE(TFLX(II))%ILAY,'SAVESPY',IU) CASE DEFAULT IF(I1.EQ.0)THEN CALL PMANAGER_SAVEMF2005_MF6TOIDF_ISAVE(PBMAN%ISAVE(TFLX(II))%ILAY,'SAVEFLX',IU); I1=1 ENDIF END SELECT ENDIF ENDDO !## unconfined save saturation DO II=1,PRJNLAY; IF(LAYCON(II).EQ.2)THEN; WRITE(IU,'(A)') 'ECHO SAVESAT=-1 >> MF6TOIDF.INI'; EXIT; ENDIF; ENDDO WRITE(IU,'(/A/)') '"'//TRIM(EXENAME)//'" MF6TOIDF.INI' WRITE(IU,'(/A/)') 'IF %ERRORLEVEL% NEQ 0 (ECHO AN ERROR WAS FOUND %EXIT /B %ERRORLEVEL%)' ENDDO ENDDO ENDIF !## include conversion of sfr package into isg-file IF(TOPICS(TSFR)%IACT_MODEL.EQ.1.AND.PBMAN%IPEST+PBMAN%IPESTP+PBMAN%IIES.EQ.0)THEN !## check whenever output flag is specified as well IF(ASSOCIATED(PBMAN%ISAVE(TSFR)%ILAY))THEN WRITE(IU,'(/A)') 'ECHO =============================================' WRITE(IU,'( A)') 'ECHO iMOD Batch Script iMOD '//TRIM(RVERSION) WRITE(IU,'( A)') 'ECHO =============================================' WRITE(IU,'(/A)') 'ECHO RUNNING FUNCTION=SFRTOISG ...' WRITE(IU,'(/A)') 'ECHO FUNCTION=SFRTOISG > SFRTOISG.INI' WRITE(IU,'( A)') 'ECHO ISGFILE_IN= "'//TRIM(DIR)//'\MODELINPUT\SFR7\SFR.ISG" >> SFRTOISG.INI' WRITE(IU,'( A)') 'ECHO ISGFILE_OUT="'//TRIM(DIR)//'\BDGSFR\ISG\SFR.ISG" >> SFRTOISG.INI' WRITE(IU,'( A)') 'ECHO SFRFILE_IN= "'//TRIM(DIR)//'\'//TRIM(MNAME)//'_FSFR.TXT" >> SFRTOISG.INI' WRITE(IU,'( A)') WRITE(IU,'( A)') '"'//TRIM(EXENAME)//'" SFRTOISG.INI' WRITE(IU,'( A)') WRITE(IU,'(/A/)') 'IF %ERRORLEVEL% NEQ 0 (ECHO AN ERROR WAS FOUND %EXIT /B %ERRORLEVEL%)' ENDIF ENDIF ENDIF !## runfile ELSEIF(IMODE.EQ.2)THEN IF(IBATCH.EQ.0)THEN IF(NICORES.GT.1)THEN WRITE(IU,'(A)') ':: Set number of MPI processes' WRITE(IU,'(A)') 'set np='//VTOS(NICORES) WRITE(IU,'(A)') '' WRITE(IU,'(A)') ':: Run model' WRITE(IU,'(A)') '"C:\Program Files\MPICH2\bin\mpiexec.exe" -localonly %np% "'//TRIM(PREFVAL(IPREVAL))//'" '//TRIM(MNAME)//'.run"' ELSE WRITE(IU,'(A)') TRIM(SEXENAME)//' "'//TRIM(MNAME)//'.RUN"' ENDIF ELSE WRITE(IU,'(A)') TRIM(SEXENAME)//' "'//TRIM(MNAME)//'.RUN"' ENDIF WRITE(IU,'(/A/)') 'IF %ERRORLEVEL% NEQ 0 (ECHO AN ERROR WAS FOUND %EXIT /B %ERRORLEVEL%)' ENDIF ! !## include echo if an error occurs ! WRITE(IU,'(A)') 'REM ERROR HANDLING' ! FNAME=FNAME(INDEX(FNAME,'\',.TRUE.)+1:INDEX(FNAME,'.',.TRUE.)-1) ! WRITE(IU,'(A)') 'IF %ERRORLEVEL% EQU 0 ECHO NO ERROR OCCURED, NORMAL TERMINATION > ERROR_'//TRIM(FNAME)//'.TXT' ! WRITE(IU,'(A)') 'IF %ERRORLEVEL% NEQ 0 ECHO ERROR %ERRORLEVEL% OCCURED > ERROR_'//TRIM(FNAME)//'.TXT' IF(PBMAN%CMDHIDE.EQ.-1)WRITE(IU,*) 'PAUSE' CLOSE(IU) ENDDO !## parralel pest IF(PBMAN%IPESTP.EQ.1)THEN CALL IPEST_GLM_MAIN(TRIM(DIR),MNAME,IBATCH,PBMAN%ACTITER); PBMAN%ACTITER=MAX(1,PBMAN%ACTITER) CALL IPEST_GLM_CLOSE_FILES() CALL IPEST_GLM_RESET_PARAMETER(TRIM(DIRO)) IF(IBATCH.EQ.0)THEN CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'Successful Parameter Optimization using '//TRIM(CSOLVER(PBMAN%IFORMAT))//CHAR(13)// & '- Executable: '//CHAR(13)//TRIM(PREFVAL(IPREVAL))//CHAR(13)// & '- Outputfile: '//CHAR(13)//TRIM(RUNFNAME),'Information') ELSE WRITE(*,'(A)') 'Successfully STARTED the Modflow Parameter Optimization simulation using:' WRITE(*,'(A)') TRIM(CSOLVER(PBMAN%IFORMAT))//': '//TRIM(PREFVAL(IPREVAL)) WRITE(*,'(A)') 'OUTPUTFILE: '//TRIM(RUNFNAME) ENDIF !## iterative ensemble smoother ELSEIF(PBMAN%IIES.EQ.1)THEN CALL IPEST_IES_MAIN(TRIM(DIR),MNAME,IBATCH) ELSE !## get and remember actual iMOD run location + switch to temporal simulation directory CALL IOSDIRNAME(DIRNAME); CALL IOSDIRCHANGE(TRIM(DIR)//'\') !## start the batch file - run in the foreground IF(IRUNMODE.GT.0)THEN IFLAGS=PROCBLOCKED !## executes on commandtool such that commands alike 'dir' etc. works IFLAGS=IFLAGS+PROCCMDPROC IF(ILOGFILE.EQ.0)THEN CALL IOSCOMMAND('RUN.BAT',IFLAGS,IEXCOD=IEXCOD) ELSE CALL IOSCOMMAND('RUN.BAT > RUN_LOG.TXT',IFLAGS,IEXCOD=IEXCOD) ENDIF !## create output files in case modflow6 is used (aggregate results from different modflow6- models) IF(PBMAN%IFORMAT.EQ.3.AND.PBMAN%IPESTP.EQ.0.AND.TOPICS(TOBS)%IACT_MODEL.EQ.1)THEN IF(.NOT.IPEST_GLM_CREATE_RESIDUALSFILES(DIR,0,'',MNAME))RETURN ENDIF IF(IEXCOD.EQ.0)THEN IF(IBATCH.EQ.0)THEN CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'Successful simulation using '//TRIM(CSOLVER(PBMAN%IFORMAT))//CHAR(13)// & '- Executable: '//CHAR(13)//TRIM(PREFVAL(IPREVAL))//CHAR(13)// & '- Outputfile: '//CHAR(13)//TRIM(RUNFNAME),'Information') ELSE WRITE(*,'(A)') 'Successfully STARTED the Modflow simulation using:' WRITE(*,'(A)') TRIM(CSOLVER(PBMAN%IFORMAT))//': '//TRIM(PREFVAL(IPREVAL)) WRITE(*,'(A)') 'OUTPUTFILE: '//TRIM(RUNFNAME) ENDIF ELSE IF(IBATCH.EQ.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'An error occured in starting your simulation','Error') ELSE WRITE(*,'(A)') 'An error occured in starting your simulation' ENDIF ENDIF !## start the batch file - run in the background ELSEIF(IRUNMODE.LT.0)THEN IFLAGS=0 !## executes on commandtool such that commands alike 'dir' etc. works IFLAGS=IFLAGS+PROCCMDPROC IF(ILOGFILE.EQ.0)THEN CALL IOSCOMMAND('RUN.BAT',IFLAGS,IEXCOD=IEXCOD) ELSE CALL IOSCOMMAND('RUN.BAT > RUN_LOG.TXT',IFLAGS,IEXCOD=IEXCOD) ENDIF IF(IBATCH.EQ.0)THEN CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'Successfully STARTED the Modflow simulation using:'//CHAR(13)// & 'MODFLOW: '//TRIM(PREFVAL(IPREVAL))//CHAR(13)// & 'RUNFILE/NAMFILE: '//TRIM(RUNFNAME),'Information') ELSE WRITE(*,'(A)') 'Successful simulation using:' WRITE(*,'(A)') 'MODFLOW: '//TRIM(PREFVAL(IPREVAL)) WRITE(*,'(A)') 'RUNFILE/NAMFILE: '//TRIM(RUNFNAME) ENDIF ENDIF !## bring the iMOD run location back to he origional directory CALL IOSDIRCHANGE(DIRNAME) ENDIF END SUBROUTINE PMANAGERSTART !###====================================================================== LOGICAL FUNCTION PMANAGERINI(ICODE,INIFNAME) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ICODE ! Read INI file: ICODE=0, Save INI file: ICODE=1 CHARACTER(LEN=*),INTENT(IN) :: INIFNAME CHARACTER(LEN=256) :: FNAME PMANAGERINI=.FALSE. IF(ICODE.EQ.0)THEN IF(INIFNAME.EQ.'')THEN FNAME='' IF(.NOT.UTL_WSELECTFILE('iMOD INI File (*.ini)|*.ini|', & LOADDIALOG+MUSTEXIST+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,& 'Load iMOD INI File'))RETURN ELSE FNAME=INIFNAME ENDIF !## reading content INI file IF(.NOT.PMANAGER_LOADINI(FNAME))CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMOD cannot read in the Project File','Error') ELSEIF(ICODE.EQ.1)THEN FNAME=TRIM(PBMAN%OUTPUT)//'\'//TRIM(PBMAN%MODELNAME)//'.INI' CALL PMANAGER_SAVEINI(FNAME) ENDIF END FUNCTION PMANAGERINI !###====================================================================== SUBROUTINE PMANAGER_SAVEINI(INIFNAME) !###====================================================================== IMPLICIT NONE CHARACTER(LEN=*),INTENT(IN) :: INIFNAME INTEGER :: IU,ILAY IU=UTL_GETUNIT() CALL OSD_OPEN(IU,FILE=INIFNAME,STATUS='REPLACE',ACTION='WRITE,DENYREAD',FORM='FORMATTED') WRITE(IU,*) '# INI file writen by iMOD version ...' WRITE(IU,*) 'FUNCTION= RUNFILE' WRITE(IU,*) 'PRJFILE_IN='//TRIM(PBMAN%OUTPUT)//'\'//TRIM(PBMAN%MODELNAME)//'.PRJ' !## get values from tab1 !CALL WDIALOGSELECT(ID_DSIMMANAGER_TAB1) WRITE(IU,*) 'SIM_TYPE= ',PBMAN%IFORMAT WRITE(IU,*) 'OUTPUT_FOLDER= ',TRIM(PBMAN%MODELNAME) WRITE(IU,*) 'FLOW_RESULT_DIR= ',TRIM(PBMAN%FLOW_RESULT_DIR) !## get values from tab2 !CALL WDIALOGSELECT(ID_DSIMMANAGER_TAB2) WRITE(IU,*) 'UNCONFINED= ',(LAYCON(ILAY),ILAY=1,PRJNLAY) !## get values from tab3 !CALL WDIALOGSELECT(ID_DSIMMANAGER_TAB3) !WRITE(IU,*) 'UNCONFINED= ',(LAYCON(ILAY),ILAY=1,PRJNLAY) CLOSE(IU) END SUBROUTINE PMANAGER_SAVEINI !###====================================================================== LOGICAL FUNCTION PMANAGER_LOADINI(INIFNAME) !###====================================================================== IMPLICIT NONE CHARACTER(LEN=*),INTENT(IN) :: INIFNAME INTEGER :: IU PMANAGER_LOADINI=.FALSE. IU=UTL_GETUNIT() CALL OSD_OPEN(IU,FILE=INIFNAME,STATUS='OLD',ACTION='READ,DENYWRITE',FORM='FORMATTED') CLOSE(IU) PMANAGER_LOADINI=.TRUE. END FUNCTION PMANAGER_LOADINI !###====================================================================== SUBROUTINE PMANAGEROPEN_PCG() !###====================================================================== IMPLICIT NONE TYPE(WIN_MESSAGE) :: MESSAGE INTEGER :: ITYPE,DID,NMAXCORES,I CHARACTER(LEN=3),DIMENSION(:),ALLOCATABLE :: COPTS CHARACTER(LEN=256) :: FNAME DID=WINFODIALOG(CURRENTDIALOG); CALL WDIALOGLOAD(ID_DPMANAGER_PCG,ID_DPMANAGER_PCG) CALL WDIALOGPUTSTRING(IDOK,'Apply') CALL WDIALOGPUTIMAGE(ID_OPEN,ID_ICONOPENIDF) !## fill in values CALL WDIALOGPUTINTEGER(IDF_INTEGER1 ,ABS(PCG%NOUTER)) CALL WDIALOGPUTINTEGER(IDF_INTEGER2 ,PCG%NINNER) CALL WDIALOGPUTDOUBLE(IDF_REAL1,PCG%HCLOSE, '(G10.5)') CALL WDIALOGPUTDOUBLE(IDF_REAL2,PCG%RCLOSE, '(G10.5)') CALL WDIALOGPUTDOUBLE(IDF_REAL3,PCG%RELAX , '(G10.5)') CALL WDIALOGPUTDOUBLE(IDF_REAL4,PCG%QERROR, '(G10.5)') CALL WDIALOGPUTCHECKBOX(IDF_CHECK1,PCG%IQERROR) CALL WDIALOGPUTOPTION(IDF_MENU1,PCG%NPCOND) CALL WDIALOGPUTINTEGER(IDF_INTEGER4 ,PCG%IPRPCG) CALL WDIALOGPUTOPTION(IDF_MENU2,PCG%MUTPCG) CALL WDIALOGPUTDOUBLE(IDF_REAL7,PCG%DAMPPCG ,'(G10.5)') CALL WDIALOGPUTDOUBLE(IDF_REAL8,PCG%DAMPPCGT,'(G10.5)') !## pks settings ! CALL WDIALOGFIELDSTATE(IDF_MENU3,3) ! CALL WDIALOGFIELDSTATE(IDF_MENU4,3) ! CALL WDIALOGFIELDSTATE(IDF_STRING1,3) ! CALL WDIALOGFIELDSTATE(IDF_CHECK2,3) ! CALL WDIALOGFIELDSTATE(IDF_LABEL20,3) ! CALL WDIALOGFIELDSTATE(IDF_LABEL21,3) ! CALL WDIALOGFIELDSTATE(IDF_LABEL22,3) ! CALL WDIALOGFIELDSTATE(ID_OPEN,3) CALL UTL_SYSCOREINFO(NMAXCORES,1) ALLOCATE(COPTS(NMAXCORES)) DO I=1,NMAXCORES COPTS(I)=VTOS(I) ENDDO CALL WDIALOGPUTMENU(IDF_MENU3,COPTS,NMAXCORES,PBMAN%NRPROC) !PCG%NCORES) DEALLOCATE(COPTS) PARTOPT=PBMAN%PARTOPT; IF(PARTOPT.EQ.0)PARTOPT=PBMAN%PARTOPT+1 CALL WDIALOGPUTOPTION(IDF_MENU4,PARTOPT) ! CALL WDIALOGPUTSTRING(IDF_STRING1,PCG%MRGFNAME) ! CALL WDIALOGPUTCHECKBOX(IDF_CHECK2,PCG%IMERGE) CALL WDIALOGGETCHECKBOX(IDF_CHECK1,PCG%IQERROR) CALL WDIALOGFIELDSTATE(IDF_REAL4,PCG%IQERROR) !CALL PMANAGEROPEN_PCGFIELDS() CALL UTL_DIALOGSHOW(-1,-1,0,3) DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE(FIELDCHANGED) SELECT CASE (MESSAGE%VALUE2) CASE (IDF_CHECK1) CALL WDIALOGGETCHECKBOX(IDF_CHECK1,PCG%IQERROR) CALL WDIALOGFIELDSTATE(IDF_REAL4,PCG%IQERROR) !CASE (IDF_MENU3,IDF_MENU4) ! CALL PMANAGEROPEN_PCGFIELDS() END SELECT SELECT CASE (MESSAGE%VALUE1) END SELECT CASE(PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (IDOK,IDCANCEL) EXIT CASE (ID_OPEN) FNAME='' IF(UTL_WSELECTFILE('iMOD IDF-File (*.idf)|*.idf|',LOADDIALOG+PROMPTON+DIRCHANGE+MUSTEXIST, & FNAME,'Select IDF File (*.idf)'))THEN CALL WDIALOGSELECT(ID_DPMANAGER_PCG) CALL WDIALOGPUTSTRING(IDF_STRING1,FNAME) ENDIF PCG%MRGFNAME=FNAME CASE (IDHELP) CALL UTL_GETHELP('7.8','TMO.ModSim.SolverSettings') END SELECT END SELECT ENDDO !## read values IF(MESSAGE%VALUE1.EQ.IDOK)THEN CALL WDIALOGGETINTEGER(IDF_INTEGER1,PCG%NOUTER) CALL WDIALOGGETINTEGER(IDF_INTEGER2,PCG%NINNER) CALL WDIALOGGETDOUBLE(IDF_REAL1,PCG%HCLOSE) CALL WDIALOGGETDOUBLE(IDF_REAL2,PCG%RCLOSE) CALL WDIALOGGETDOUBLE(IDF_REAL3,PCG%RELAX) CALL WDIALOGGETDOUBLE(IDF_REAL4,PCG%QERROR) CALL WDIALOGGETCHECKBOX(IDF_CHECK1,PCG%IQERROR) CALL WDIALOGGETMENU(IDF_MENU1,PCG%NPCOND) CALL WDIALOGGETINTEGER(IDF_INTEGER4,PCG%IPRPCG) CALL WDIALOGGETMENU(IDF_MENU2,PCG%MUTPCG) CALL WDIALOGGETDOUBLE(IDF_REAL7,PCG%DAMPPCG) CALL WDIALOGGETDOUBLE(IDF_REAL8,PCG%DAMPPCGT) CALL WDIALOGGETMENU(IDF_MENU3,PBMAN%NRPROC) CALL WDIALOGGETMENU(IDF_MENU4,PBMAN%PARTOPT) ! CALL WDIALOGGETCHECKBOX(IDF_CHECK2,PCG%IMERGE) ! CALL WDIALOGGETSTRING(IDF_STRING1,PCG%MRGFNAME) ENDIF CALL WDIALOGSELECT(ID_DPMANAGER_PCG) CALL WDIALOGUNLOAD(); CALL WDIALOGSELECT(DID) END SUBROUTINE PMANAGEROPEN_PCG !###====================================================================== SUBROUTINE PMANAGEROPEN_GCG() !###====================================================================== IMPLICIT NONE TYPE(WIN_MESSAGE) :: MESSAGE INTEGER :: ITYPE,DID,TMP DID=WINFODIALOG(CURRENTDIALOG); CALL WDIALOGLOAD(ID_DPMANAGER_MT3D_GCG,ID_DPMANAGER_MT3D_GCG) CALL WDIALOGSELECT(ID_DPMANAGER_MT3D_GCG) !## fill in gcg settings window CALL WDIALOGPUTINTEGER(IDF_INTEGER1,WQ%GCG%MXITER) CALL WDIALOGPUTINTEGER(IDF_INTEGER2,WQ%GCG%ITER1) CALL WDIALOGPUTDOUBLE(IDF_REAL1,WQ%GCG%CCLOSE,'(E15.3)') CALL WDIALOGPUTOPTION(IDF_MENU1,WQ%GCG%ISOLVE) CALL WDIALOGPUTDOUBLE(IDF_REAL2,WQ%GCG%ACCL,'(E15.3)') CALL WDIALOGPUTINTEGER(IDF_INTEGER3,WQ%GCG%IPRGCG) TMP=WQ%GCG%NCRS+1 ; CALL WDIALOGPUTOPTION(IDF_MENU2,TMP) CALL UTL_DIALOGSHOW(-1,-1,0,3) DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE(FIELDCHANGED) SELECT CASE (MESSAGE%VALUE2) END SELECT SELECT CASE (MESSAGE%VALUE1) END SELECT CASE(PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (IDOK,IDCANCEL) EXIT CASE (IDHELP) ! CALL UTL_GETHELP('7.8','TMO.ModSim.SolverSettings') END SELECT END SELECT ENDDO !## get gcg settings screeninput IF(MESSAGE%VALUE1.EQ.IDOK)THEN CALL WDIALOGGETINTEGER(IDF_INTEGER1,WQ%GCG%MXITER) CALL WDIALOGGETINTEGER(IDF_INTEGER2,WQ%GCG%ITER1) CALL WDIALOGGETDOUBLE(IDF_REAL1,WQ%GCG%CCLOSE) CALL WDIALOGGETMENU(IDF_MENU1,WQ%GCG%ISOLVE) CALL WDIALOGGETDOUBLE(IDF_REAL2,WQ%GCG%ACCL) CALL WDIALOGGETINTEGER(IDF_INTEGER3,WQ%GCG%IPRGCG) CALL WDIALOGGETMENU(IDF_MENU2,TMP) ; WQ%GCG%NCRS = TMP-1 ENDIF CALL WDIALOGSELECT(ID_DPMANAGER_MT3D_GCG) CALL WDIALOGUNLOAD(); CALL WDIALOGSELECT(DID) END SUBROUTINE PMANAGEROPEN_GCG !###====================================================================== SUBROUTINE PMANAGEROPEN_RCT() !###====================================================================== IMPLICIT NONE TYPE(WIN_MESSAGE) :: MESSAGE INTEGER :: ITYPE,DID,TMP DID=WINFODIALOG(CURRENTDIALOG); CALL WDIALOGLOAD(ID_DPMANAGER_MT3D_RCT,ID_DPMANAGER_MT3D_RCT) !## FILLEN RCT settings window TMP = WQ%RCT%ISOTHM+1 ; CALL WDIALOGPUTOPTION(IDF_MENU1,TMP) TMP = WQ%RCT%IREACT+1 ; CALL WDIALOGPUTOPTION(IDF_MENU2,TMP) CALL WDIALOGPUTINTEGER(IDF_INTEGER1,WQ%RCT%IGETSC) CALL UTL_DIALOGSHOW(-1,-1,0,3) DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE(FIELDCHANGED) SELECT CASE (MESSAGE%VALUE2) END SELECT SELECT CASE (MESSAGE%VALUE1) END SELECT CASE(PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (IDOK,IDCANCEL) EXIT CASE (IDHELP) ! CALL UTL_GETHELP('7.8','TMO.ModSim.SolverSettings') END SELECT END SELECT ENDDO !## read RCT values IF(MESSAGE%VALUE1.EQ.IDOK)THEN CALL WDIALOGGETMENU(IDF_MENU1,TMP) ; WQ%RCT%ISOTHM=TMP-1 CALL WDIALOGGETMENU(IDF_MENU2,TMP) ; WQ%RCT%IREACT=TMP-1 CALL WDIALOGGETINTEGER(IDF_INTEGER1,WQ%RCT%IGETSC) ENDIF CALL WDIALOGSELECT(ID_DPMANAGER_MT3D_RCT) CALL WDIALOGUNLOAD(); CALL WDIALOGSELECT(DID) END SUBROUTINE PMANAGEROPEN_RCT !###====================================================================== SUBROUTINE PMANAGEROPEN_ADV() !###====================================================================== IMPLICIT NONE TYPE(WIN_MESSAGE) :: MESSAGE INTEGER :: ITYPE,DID DID=WINFODIALOG(CURRENTDIALOG) CALL WDIALOGLOAD(ID_DPMANAGER_MT3D_ADV,ID_DPMANAGER_MT3D_ADV) CALL UTL_DIALOGSHOW(-1,-1,0,3) DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE(FIELDCHANGED) SELECT CASE (MESSAGE%VALUE2) END SELECT SELECT CASE (MESSAGE%VALUE1) END SELECT CASE(PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (IDOK,IDCANCEL) EXIT CASE (IDHELP) ! CALL UTL_GETHELP('7.8','TMO.ModSim.SolverSettings') END SELECT END SELECT ENDDO !## read values IF(MESSAGE%VALUE1.EQ.IDOK)THEN ENDIF CALL WDIALOGSELECT(ID_DPMANAGER_MT3D_ADV) CALL WDIALOGUNLOAD(); CALL WDIALOGSELECT(DID) END SUBROUTINE PMANAGEROPEN_ADV !###====================================================================== SUBROUTINE PMANAGEROPEN_VDF() !###====================================================================== IMPLICIT NONE TYPE(WIN_MESSAGE) :: MESSAGE INTEGER :: ITYPE,DID DID=WINFODIALOG(CURRENTDIALOG) CALL WDIALOGLOAD(ID_DPMANAGER_MT3D_VDF,ID_DPMANAGER_MT3D_VDF) !## FILLEN VDF settings window CALL WDIALOGPUTDOUBLE(IDF_REAL1,WQ%VDF%DENSEMIN) CALL WDIALOGPUTDOUBLE(IDF_REAL2,WQ%VDF%DENSEMAX) CALL WDIALOGPUTDOUBLE(IDF_REAL3,WQ%VDF%DENSEREF) CALL WDIALOGPUTDOUBLE(IDF_REAL4,WQ%VDF%DENSESLP) CALL WDIALOGPUTOPTION(IDF_MENU1,WQ%VDF%MTDNCONC+1) CALL WDIALOGPUTOPTION(IDF_MENU2,WQ%VDF%MFNADVFD) CALL WDIALOGPUTINTEGER(IDF_INTEGER1,WQ%VDF%NSWTCPL) CALL WDIALOGPUTOPTION(IDF_MENU3,WQ%VDF%IWTABLE+1) CALL WDIALOGPUTDOUBLE(IDF_REAL5,WQ%VDF%DNSCRIT) CALL WDIALOGPUTDOUBLE(IDF_REAL6,WQ%VDF%FIRSTDT) CALL UTL_DIALOGSHOW(-1,-1,0,3) DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE(FIELDCHANGED) SELECT CASE (MESSAGE%VALUE2) END SELECT SELECT CASE (MESSAGE%VALUE1) END SELECT CASE(PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (IDOK,IDCANCEL) EXIT CASE (IDHELP) ! CALL UTL_GETHELP('7.8','TMO.ModSim.SolverSettings') END SELECT END SELECT ENDDO !## read values IF(MESSAGE%VALUE1.EQ.IDOK)THEN CALL WDIALOGGETDOUBLE(IDF_REAL1,WQ%VDF%DENSEMIN) CALL WDIALOGGETDOUBLE(IDF_REAL2,WQ%VDF%DENSEMAX) CALL WDIALOGGETDOUBLE(IDF_REAL3,WQ%VDF%DENSEREF) CALL WDIALOGGETDOUBLE(IDF_REAL4,WQ%VDF%DENSESLP) CALL WDIALOGGETMENU(IDF_MENU1,WQ%VDF%MTDNCONC) WQ%VDF%MTDNCONC=WQ%VDF%MTDNCONC-1 CALL WDIALOGGETMENU(IDF_MENU2,WQ%VDF%MFNADVFD) CALL WDIALOGGETINTEGER(IDF_INTEGER1,WQ%VDF%NSWTCPL) CALL WDIALOGGETMENU(IDF_MENU3,WQ%VDF%IWTABLE) WQ%VDF%IWTABLE=WQ%VDF%IWTABLE-1 CALL WDIALOGGETDOUBLE(IDF_REAL5,WQ%VDF%DNSCRIT) CALL WDIALOGGETDOUBLE(IDF_REAL6,WQ%VDF%FIRSTDT) ENDIF CALL WDIALOGSELECT(ID_DPMANAGER_MT3D_VDF) CALL WDIALOGUNLOAD(); CALL WDIALOGSELECT(DID) END SUBROUTINE PMANAGEROPEN_VDF !###====================================================================== SUBROUTINE PMANAGEROPEN_PCGFIELDS() !###====================================================================== IMPLICIT NONE CALL WDIALOGSELECT(ID_DPMANAGER_PCG) !## get amount of cores to be used in modelsimulation, selected by user !CALL WDIALOGGETMENU(IDF_MENU3,PCG%NCORES) !J=0; IF(PCG%NCORES.NE.1)J=1 !IF(J.EQ.1)THEN !!## enable partitioning option + subdomain merge option ! CALL WDIALOGFIELDSTATE(IDF_LABEL21,J) ! CALL WDIALOGFIELDSTATE(IDF_MENU4,J) ! CALL WDIALOGGETMENU(IDF_MENU4,I) ! K=0; IF(I.EQ.3)K=1 ! CALL WDIALOGFIELDSTATE(IDF_STRING1,K) ! CALL WDIALOGFIELDSTATE(ID_OPEN,K) ! CALL WDIALOGFIELDSTATE(IDF_LABEL22,K) ! K=0; IF(I.NE.1)K=1 ! CALL WDIALOGFIELDSTATE(IDF_CHECK2,K) ! CALL WDIALOGGETSTRING(IDF_STRING1,PCG%MRGFNAME) !ELSE !!## amount of selected cores is equal to 1; !!## parallel simulation is not possible --> all options disabled ! CALL WDIALOGFIELDSTATE(IDF_LABEL21,J) ! CALL WDIALOGFIELDSTATE(IDF_MENU4,J) ! CALL WDIALOGPUTOPTION(IDF_MENU4,J+1) ! CALL WDIALOGFIELDSTATE(IDF_STRING1,J) ! CALL WDIALOGFIELDSTATE(ID_OPEN,J) ! CALL WDIALOGFIELDSTATE(IDF_LABEL22,J) ! CALL WDIALOGFIELDSTATE(IDF_CHECK2,J) !ENDIF CALL WDIALOGSELECT(ID_DPMANAGER_PCG) END SUBROUTINE PMANAGEROPEN_PCGFIELDS !###====================================================================== SUBROUTINE PMANAGEROPEN_PEST() !###====================================================================== IMPLICIT NONE TYPE(WIN_MESSAGE) :: MESSAGE INTEGER :: ITYPE,DID,N CHARACTER(LEN=52) :: STRING DID=WINFODIALOG(CURRENTDIALOG) CALL WDIALOGLOAD(ID_DPMANAGER_PEST,ID_DPMANAGER_PEST) CALL WDIALOGPUTSTRING(IDOK,'Apply System Settings') !## fill in values CALL WDIALOGPUTCHECKBOX(IDF_CHECK2,PEST%IPESTP) CALL WDIALOGPUTCHECKBOX(IDF_CHECK3,PEST%CMDHIDE) PEST%NCPU=MAX(1,PEST%NCPU); CALL WDIALOGPUTINTEGER(IDF_INTEGER13,PEST%NCPU) IF(ASSOCIATED(PEST%LAMBDA_TEST))THEN DO I=1,SIZE(PEST%LAMBDA_TEST) IF(I.EQ.1)THEN STRING=TRIM(VTOS(PEST%LAMBDA_TEST(I),'F',3)) ELSE STRING=TRIM(STRING)//','//TRIM(VTOS(PEST%LAMBDA_TEST(I),'F',3)) ENDIF ENDDO ELSE STRING='1.0' ENDIF CALL WDIALOGPUTSTRING(IDF_STRING1,STRING) IF(ASSOCIATED(PEST%LINE_SEARCH))THEN DO I=1,SIZE(PEST%LINE_SEARCH) IF(I.EQ.1)THEN STRING=TRIM(VTOS(PEST%LINE_SEARCH(I),'F',3)) ELSE STRING=TRIM(STRING)//','//TRIM(VTOS(PEST%LINE_SEARCH(I),'F',3)) ENDIF ENDDO ELSE STRING='1.0' ENDIF CALL WDIALOGPUTSTRING(IDF_STRING2,STRING) CALL PMANAGEROPEN_PEST_FIELDS() CALL WDIALOGPUTINTEGER(IDF_INTEGER7,PEST%PE_MXITER) CALL WDIALOGPUTDOUBLE(IDF_REAL4,PEST%PE_STOP,'(F15.3)') CALL WDIALOGPUTDOUBLE(IDF_REAL8,PEST%PE_PADJ ,'(F15.3)') CALL WDIALOGPUTDOUBLE(IDF_REAL5,PEST%PE_SENS,'(F15.3)') CALL WDIALOGPUTDOUBLE(IDF_REAL9,PEST%PE_DRES,'(F15.3)') CALL WDIALOGPUTDOUBLE(IDF_REAL6,PEST%PE_TARGET(1),'(F15.3)') CALL WDIALOGPUTDOUBLE(IDF_REAL7,PEST%PE_TARGET(2),'(F15.3)') CALL WDIALOGPUTCHECKBOX(IDF_CHECK1,PEST%PE_REGULARISATION) CALL WDIALOGPUTOPTION(IDF_MENU4,PEST%PE_SCALING+1) CALL WDIALOGPUTOPTION(IDF_MENU5,PEST%PE_KTYPE) N=0; IF(ASSOCIATED(PEST%S_PERIOD))N=SIZE(PEST%S_PERIOD) CALL WDIALOGPUTINTEGER(IDF_INTEGER8 ,N) CALL WDIALOGFIELDSTATE(IDF_INTEGER8,2) N=0; IF(ASSOCIATED(PEST%B_FRACTION))N=SIZE(PEST%B_FRACTION) CALL WDIALOGPUTINTEGER(IDF_INTEGER9 ,N) CALL WDIALOGFIELDSTATE(IDF_INTEGER9,2) N=0; IF(ASSOCIATED(PEST%PARAM))N=SIZE(PEST%PARAM) CALL WDIALOGPUTINTEGER(IDF_INTEGER10,N) CALL WDIALOGFIELDSTATE(IDF_INTEGER10,2) N=0; IF(ASSOCIATED(PEST%IDFFILES))N=SIZE(PEST%IDFFILES) CALL WDIALOGPUTINTEGER(IDF_INTEGER11,N) CALL WDIALOGFIELDSTATE(IDF_INTEGER11,2) N=0; IF(ASSOCIATED(PEST%MEASURES))N=SIZE(PEST%MEASURES) CALL WDIALOGPUTINTEGER(IDF_INTEGER12,N) CALL WDIALOGFIELDSTATE(IDF_INTEGER12,2) CALL UTL_DIALOGSHOW(-1,-1,0,3) DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE(FIELDCHANGED) SELECT CASE (MESSAGE%VALUE2) CASE (IDF_CHECK2) CALL PMANAGEROPEN_PEST_FIELDS() END SELECT SELECT CASE (MESSAGE%VALUE1) END SELECT CASE(PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (ID_PERIODS) CALL WDIALOGGETINTEGER(IDF_INTEGER8,N) CALL PMANAGEROPEN_PESTPARAM(ID_PERIODS,N) CALL WDIALOGPUTINTEGER(IDF_INTEGER8,N) CASE (ID_BATCHFILES) CALL WDIALOGGETINTEGER(IDF_INTEGER9,N) CALL PMANAGEROPEN_PESTPARAM(ID_BATCHFILES,N) CALL WDIALOGPUTINTEGER(IDF_INTEGER9,N) CASE (ID_PARAMETERS) CALL WDIALOGGETINTEGER(IDF_INTEGER10,N) CALL PMANAGEROPEN_PESTPARAM(ID_PARAMETERS,N) CALL WDIALOGPUTINTEGER(IDF_INTEGER10,N) CASE (ID_ZONES) CALL WDIALOGGETINTEGER(IDF_INTEGER11,N) CALL PMANAGEROPEN_PESTPARAM(ID_ZONES,N) CALL WDIALOGPUTINTEGER(IDF_INTEGER11,N) CASE (ID_MEASURES) CALL WDIALOGGETINTEGER(IDF_INTEGER12,N) CALL PMANAGEROPEN_PESTPARAM(ID_MEASURES,N) CALL WDIALOGPUTINTEGER(IDF_INTEGER12,N) CASE (IDOK,IDCANCEL) EXIT END SELECT END SELECT ENDDO !## read values IF(MESSAGE%VALUE1.EQ.IDOK)THEN CALL WDIALOGGETCHECKBOX(IDF_CHECK2,PEST%IPESTP) CALL WDIALOGGETCHECKBOX(IDF_CHECK3,PEST%CMDHIDE) CALL WDIALOGGETINTEGER(IDF_INTEGER13,PEST%NCPU) CALL WDIALOGGETSTRING(IDF_STRING1,STRING) PEST%NLAMBDASEARCH=UTL_COUNT_COLUMNS(STRING,',') IF(ASSOCIATED(PEST%LAMBDA_TEST))DEALLOCATE(PEST%LAMBDA_TEST); ALLOCATE(PEST%LAMBDA_TEST(PEST%NLAMBDASEARCH)) READ(STRING,*) (PEST%LAMBDA_TEST(I),I=1,PEST%NLAMBDASEARCH) CALL WDIALOGGETSTRING(IDF_STRING2,STRING) PEST%NLINESEARCH=UTL_COUNT_COLUMNS(STRING,',') IF(ASSOCIATED(PEST%LINE_SEARCH))DEALLOCATE(PEST%LINE_SEARCH); ALLOCATE(PEST%LINE_SEARCH(PEST%NLINESEARCH)) READ(STRING,*) (PEST%LINE_SEARCH(I),I=1,PEST%NLINESEARCH) CALL WDIALOGGETINTEGER(IDF_INTEGER7 ,PEST%PE_MXITER) CALL WDIALOGGETDOUBLE(IDF_REAL4,PEST%PE_STOP) CALL WDIALOGGETDOUBLE(IDF_REAL8,PEST%PE_PADJ) CALL WDIALOGGETDOUBLE(IDF_REAL5,PEST%PE_SENS) CALL WDIALOGGETDOUBLE(IDF_REAL9,PEST%PE_DRES) CALL WDIALOGGETDOUBLE(IDF_REAL6,PEST%PE_TARGET(1)) CALL WDIALOGGETDOUBLE(IDF_REAL7,PEST%PE_TARGET(2)) CALL WDIALOGGETMENU(IDF_MENU4,PEST%PE_SCALING) PEST%PE_SCALING=PEST%PE_SCALING-1 CALL WDIALOGGETMENU(IDF_MENU5,PEST%PE_KTYPE) CALL WDIALOGGETCHECKBOX(IDF_CHECK1,PEST%PE_REGULARISATION) ENDIF CALL WDIALOGSELECT(ID_DPMANAGER_PEST) CALL WDIALOGUNLOAD(); CALL WDIALOGSELECT(DID) END SUBROUTINE PMANAGEROPEN_PEST !###====================================================================== SUBROUTINE PMANAGEROPEN_PEST_FIELDS() !###====================================================================== IMPLICIT NONE INTEGER :: I CALL WDIALOGGETCHECKBOX(IDF_CHECK2,I) CALL WDIALOGFIELDSTATE(IDF_CHECK3,I) CALL WDIALOGFIELDSTATE(IDF_INTEGER13,I) CALL WDIALOGFIELDSTATE(IDF_LABEL21,I) CALL WDIALOGFIELDSTATE(IDF_LABEL22,I) CALL WDIALOGFIELDSTATE(IDF_LABEL23,I) CALL WDIALOGFIELDSTATE(IDF_STRING1,I) CALL WDIALOGFIELDSTATE(IDF_STRING2,I) END SUBROUTINE PMANAGEROPEN_PEST_FIELDS !###====================================================================== SUBROUTINE PMANAGEROPEN_PESTPARAM(ID,N) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ID INTEGER,INTENT(INOUT) :: N TYPE(WIN_MESSAGE) :: MESSAGE INTEGER :: ITYPE,DID,I,M DID=WINFODIALOG(CURRENTDIALOG) CALL WDIALOGLOAD(ID_DPMANAGER_PESTFILES,ID_DPMANAGER_PESTFILES) SELECT CASE (ID) CASE (ID_PERIODS) CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES) CALL WDIALOGSETTAB(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB1) CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB2,0) CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB3,0) CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB4,0) CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB5,0) CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES_TAB1) CALL WDIALOGPUTINTEGER(IDF_INTEGER8,N) IF(N.GT.0)THEN CALL WGRIDROWS(IDF_GRID1,N) CALL WGRIDPUTSTRING(IDF_GRID1,1,PEST%S_PERIOD,N) CALL WGRIDPUTSTRING(IDF_GRID1,2,PEST%E_PERIOD,N) ELSE CALL WDIALOGFIELDSTATE(IDF_GRID1,3) ENDIF CASE (ID_BATCHFILES) CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES) CALL WDIALOGSETTAB(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB2) CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB1,0) CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB3,0) CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB4,0) CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB5,0) CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES_TAB2) CALL WDIALOGPUTINTEGER(IDF_INTEGER9,N) IF(N.GT.0)THEN CALL WGRIDROWS(IDF_GRID1,N) CALL WGRIDPUTDOUBLE(IDF_GRID1,1,PEST%B_FRACTION,N) CALL WGRIDPUTSTRING(IDF_GRID1,2,PEST%B_BATCHFILE,N) CALL WGRIDPUTSTRING(IDF_GRID1,3,PEST%B_OUTFILE,N) ELSE CALL WDIALOGFIELDSTATE(IDF_GRID1,3) ENDIF CASE (ID_PARAMETERS) CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES) CALL WDIALOGSETTAB(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB3) CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB1,0) CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB2,0) CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB4,0) CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB5,0) CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES_TAB3) CALL WDIALOGPUTINTEGER(IDF_INTEGER10,N) IF(N.GT.0)THEN CALL WGRIDROWS(IDF_GRID1,N) CALL WGRIDPUTCHECKBOX(IDF_GRID1,1 ,PEST%PARAM%PACT,N) CALL WGRIDPUTMENU(IDF_GRID1 ,2 ,PARAM,SIZE(PARAM),PEST%PARAM%IPARAM,N) CALL WGRIDPUTINTEGER(IDF_GRID1 ,3 ,PEST%PARAM%PILS,N) CALL WGRIDPUTINTEGER(IDF_GRID1 ,4 ,PEST%PARAM%PIZONE,N) CALL WGRIDPUTINTEGER(IDF_GRID1 ,5 ,PEST%PARAM%PIGROUP,N) CALL WGRIDPUTDOUBLE(IDF_GRID1 ,6 ,PEST%PARAM%PINI,N) CALL WGRIDPUTDOUBLE(IDF_GRID1 ,7 ,PEST%PARAM%PMIN,N) CALL WGRIDPUTDOUBLE(IDF_GRID1 ,8 ,PEST%PARAM%PMAX,N) CALL WGRIDPUTDOUBLE(IDF_GRID1 ,9 ,PEST%PARAM%PDELTA,N) CALL WGRIDPUTDOUBLE(IDF_GRID1 ,10,PEST%PARAM%PINCREASE,N) CALL WGRIDPUTCHECKBOX(IDF_GRID1,11,PEST%PARAM%PLOG,N) CALL WGRIDPUTSTRING(IDF_GRID1 ,12,PEST%PARAM%ACRONYM,N) CALL WGRIDPUTDOUBLE(IDF_GRID1 ,13,PEST%PARAM%PPRIOR,N) ELSE CALL WDIALOGFIELDSTATE(IDF_GRID1,3) ENDIF CASE (ID_ZONES) CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES) CALL WDIALOGSETTAB(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB4) CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB1,0) CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB2,0) CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB3,0) CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB5,0) CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES_TAB4) CALL WDIALOGPUTINTEGER(IDF_INTEGER11,N) IF(N.GT.0)THEN CALL WGRIDROWS(IDF_GRID1,N) CALL WGRIDPUTSTRING(IDF_GRID1,1,PEST%IDFFILES,N) ELSE CALL WDIALOGFIELDSTATE(IDF_GRID1,3) ENDIF CASE (ID_MEASURES) CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES) CALL WDIALOGSETTAB(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB5) CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB1,0) CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB2,0) CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB3,0) CALL WDIALOGTABSTATE(IDF_TAB1,ID_DPMANAGER_PESTFILES_TAB4,0) CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES_TAB5) CALL WDIALOGPUTINTEGER(IDF_INTEGER12,N) IF(N.GT.0)THEN CALL WGRIDROWS(IDF_GRID1,N) CALL WGRIDPUTSTRING (IDF_GRID1,1 ,PEST%MEASURES%IPFNAME,N) PEST%MEASURES%IPFTYPE=PEST%MEASURES%IPFTYPE-1 CALL WGRIDPUTCHECKBOX(IDF_GRID1,2 ,PEST%MEASURES%IPFTYPE,N) CALL WGRIDPUTINTEGER (IDF_GRID1,3 ,PEST%MEASURES%IXCOL,N) CALL WGRIDPUTINTEGER (IDF_GRID1,4 ,PEST%MEASURES%IYCOL,N) CALL WGRIDPUTINTEGER (IDF_GRID1,5 ,PEST%MEASURES%ILCOL,N) CALL WGRIDPUTINTEGER (IDF_GRID1,6 ,PEST%MEASURES%IMCOL,N) CALL WGRIDPUTINTEGER (IDF_GRID1,7 ,PEST%MEASURES%IVCOL,N) CALL WGRIDPUTINTEGER (IDF_GRID1,8 ,PEST%MEASURES%IDCOL,N) CALL WGRIDPUTINTEGER (IDF_GRID1,9 ,PEST%MEASURES%IZ1CL,N) CALL WGRIDPUTINTEGER (IDF_GRID1,10,PEST%MEASURES%IZ2CL,N) CALL WGRIDPUTINTEGER (IDF_GRID1,11,PEST%MEASURES%IGHCL,N) CALL WGRIDPUTINTEGER (IDF_GRID1,12,PEST%MEASURES%IGLCL,N) ELSE CALL WDIALOGFIELDSTATE(IDF_GRID1,3) ENDIF END SELECT CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES) CALL UTL_DIALOGSHOW(-1,-1,0,3) DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE(FIELDCHANGED) SELECT CASE (MESSAGE%VALUE2) END SELECT SELECT CASE (MESSAGE%VALUE1) END SELECT CASE(PUSHBUTTON) CALL WDIALOGSELECT(MESSAGE%WIN) SELECT CASE (MESSAGE%VALUE1) CASE (ID_PERIODS) CALL WDIALOGGETINTEGER(IDF_INTEGER8,N) IF(N.EQ.0)THEN CALL WDIALOGCLEARFIELD(IDF_GRID1) IF(ASSOCIATED(PEST%S_PERIOD))DEALLOCATE(PEST%S_PERIOD,PEST%E_PERIOD) CALL WDIALOGFIELDSTATE(IDF_GRID1,3) ELSE M=WINFOGRID(IDF_GRID1,GRIDROWSMAX) IF(N.GT.M)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You can specify a maximum of '//TRIM(VTOS(M))//' Periods','Error'); N=M ENDIF !## resize variables IF(ASSOCIATED(PEST%S_PERIOD))THEN M=SIZE(PEST%S_PERIOD) IF(N.NE.M)THEN ALLOCATE(PEST%S_PERIOD_BU(N),PEST%E_PERIOD_BU(N)); PEST%S_PERIOD_BU='20150101000000'; PEST%E_PERIOD_BU='20151231000000' DO I=1,MIN(N,M); PEST%S_PERIOD_BU(I)=PEST%S_PERIOD(I); ENDDO DO I=1,MIN(N,M); PEST%E_PERIOD_BU(I)=PEST%E_PERIOD(I); ENDDO DEALLOCATE(PEST%S_PERIOD,PEST%E_PERIOD); PEST%S_PERIOD=>PEST%S_PERIOD_BU; PEST%E_PERIOD=>PEST%E_PERIOD_BU ENDIF ELSE ALLOCATE(PEST%S_PERIOD(N),PEST%E_PERIOD(N)); PEST%S_PERIOD='20150101000000'; PEST%E_PERIOD='20151231000000' ENDIF CALL WDIALOGFIELDSTATE(IDF_GRID1,1) CALL WGRIDROWS(IDF_GRID1,N) CALL WGRIDPUTSTRING(IDF_GRID1,1,PEST%S_PERIOD,N) CALL WGRIDPUTSTRING(IDF_GRID1,2,PEST%E_PERIOD,N) ENDIF CASE (ID_BATCHFILES) CALL WDIALOGGETINTEGER(IDF_INTEGER9,N) IF(N.EQ.0)THEN CALL WDIALOGCLEARFIELD(IDF_GRID1) IF(ASSOCIATED(PEST%B_FRACTION))DEALLOCATE(PEST%B_FRACTION,PEST%B_BATCHFILE,PEST%B_OUTFILE) CALL WDIALOGFIELDSTATE(IDF_GRID1,3) ELSE M=WINFOGRID(IDF_GRID1,GRIDROWSMAX) IF(N.GT.M)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You can specify a maximum of '//TRIM(VTOS(M))//' Batchfiles','Error'); N=M ENDIF !## resize variables IF(ASSOCIATED(PEST%B_FRACTION))THEN M=SIZE(PEST%B_FRACTION) IF(N.NE.M)THEN ALLOCATE(PEST%B_FRACTION_BU(N),PEST%B_BATCHFILE_BU(N),PEST%B_OUTFILE_BU(N)) PEST%B_FRACTION_BU=1.0D0; PEST%B_BATCHFILE_BU=''; PEST%B_OUTFILE_BU='' DO I=1,MIN(N,M); PEST%B_FRACTION_BU(I) =PEST%B_FRACTION(I); ENDDO DO I=1,MIN(N,M); PEST%B_BATCHFILE_BU(I)=PEST%B_BATCHFILE(I); ENDDO DO I=1,MIN(N,M); PEST%B_OUTFILE_BU(I) =PEST%B_OUTFILE(I); ENDDO DEALLOCATE(PEST%B_FRACTION,PEST%B_BATCHFILE,PEST%B_OUTFILE) PEST%B_FRACTION=>PEST%B_FRACTION_BU; PEST%B_BATCHFILE=>PEST%B_BATCHFILE_BU; PEST%B_OUTFILE=>PEST%B_OUTFILE_BU ENDIF ELSE ALLOCATE(PEST%B_FRACTION(N),PEST%B_BATCHFILE(N),PEST%B_OUTFILE(N)); PEST%B_FRACTION=1.0D0; PEST%B_BATCHFILE=''; PEST%B_OUTFILE='' ENDIF CALL WDIALOGFIELDSTATE(IDF_GRID1,1) CALL WGRIDROWS(IDF_GRID1,N) CALL WGRIDPUTDOUBLE(IDF_GRID1,1,PEST%B_FRACTION,N) CALL WGRIDPUTSTRING(IDF_GRID1,2,PEST%B_BATCHFILE,N) CALL WGRIDPUTSTRING(IDF_GRID1,3,PEST%B_OUTFILE,N) ENDIF CASE (ID_PARAMETERS) CALL WDIALOGGETINTEGER(IDF_INTEGER10,N) IF(N.EQ.0)THEN CALL WDIALOGCLEARFIELD(IDF_GRID1) IF(ASSOCIATED(PEST%PARAM))DEALLOCATE(PEST%PARAM) CALL WDIALOGFIELDSTATE(IDF_GRID1,3) ELSE M=WINFOGRID(IDF_GRID1,GRIDROWSMAX) IF(N.GT.M)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You can specify a maximum of '//TRIM(VTOS(M))//' Parameters','Error'); N=M ENDIF !## resize variables IF(ASSOCIATED(PEST%PARAM))THEN M=SIZE(PEST%PARAM) IF(N.NE.M)THEN ALLOCATE(PEST%PARAM_BU(N)); DO I=1,N; PEST%PARAM_BU(I)%PIGROUP=I; PEST%PARAM_BU(I)%PIZONE=I; ENDDO DO I=1,MIN(N,M); PEST%PARAM_BU(I) =PEST%PARAM(I); ENDDO DEALLOCATE(PEST%PARAM) PEST%PARAM=>PEST%PARAM_BU ENDIF ELSE ALLOCATE(PEST%PARAM(N)); DO I=1,N; PEST%PARAM(I)%PIGROUP=I; PEST%PARAM(I)%PIZONE=I; PEST%PARAM(I)%ACRONYM=''; ENDDO ENDIF CALL WDIALOGFIELDSTATE(IDF_GRID1,1) CALL WGRIDROWS(IDF_GRID1,N) CALL WGRIDPUTCHECKBOX(IDF_GRID1,1 ,PEST%PARAM%PACT,N) CALL WGRIDPUTMENU(IDF_GRID1 ,2 ,PARAM,SIZE(PARAM),PEST%PARAM%IPARAM,N) CALL WGRIDPUTINTEGER(IDF_GRID1 ,3 ,PEST%PARAM%PILS,N) CALL WGRIDPUTINTEGER(IDF_GRID1 ,4 ,PEST%PARAM%PIZONE,N) CALL WGRIDPUTINTEGER(IDF_GRID1 ,5 ,PEST%PARAM%PIGROUP,N) CALL WGRIDPUTDOUBLE(IDF_GRID1 ,6 ,PEST%PARAM%PINI,N) CALL WGRIDPUTDOUBLE(IDF_GRID1 ,7 ,PEST%PARAM%PMIN,N) CALL WGRIDPUTDOUBLE(IDF_GRID1 ,8 ,PEST%PARAM%PMAX,N) CALL WGRIDPUTDOUBLE(IDF_GRID1 ,9 ,PEST%PARAM%PDELTA,N) CALL WGRIDPUTDOUBLE(IDF_GRID1 ,10,PEST%PARAM%PINCREASE,N) CALL WGRIDPUTCHECKBOX(IDF_GRID1,11,PEST%PARAM%PLOG,N) CALL WGRIDPUTSTRING(IDF_GRID1 ,12,PEST%PARAM%ACRONYM,N) CALL WGRIDPUTDOUBLE(IDF_GRID1 ,13,PEST%PARAM%PPRIOR,N) ENDIF CASE (ID_ZONES) CALL WDIALOGGETINTEGER(IDF_INTEGER11,N) IF(N.EQ.0)THEN CALL WDIALOGCLEARFIELD(IDF_GRID1) IF(ASSOCIATED(PEST%IDFFILES))DEALLOCATE(PEST%IDFFILES) CALL WDIALOGFIELDSTATE(IDF_GRID1,3) ELSE M=WINFOGRID(IDF_GRID1,GRIDROWSMAX) IF(N.GT.M)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You can specify a maximum of '//TRIM(VTOS(M))//' Zones','Error'); N=M ENDIF !## resize variables IF(ASSOCIATED(PEST%IDFFILES))THEN M=SIZE(PEST%IDFFILES) IF(N.NE.M)THEN ALLOCATE(PEST%IDFFILES_BU(N)) PEST%IDFFILES_BU='' DO I=1,MIN(N,M); PEST%IDFFILES_BU(I) =PEST%IDFFILES(I); ENDDO DEALLOCATE(PEST%IDFFILES) PEST%IDFFILES=>PEST%IDFFILES_BU ENDIF ELSE ALLOCATE(PEST%IDFFILES(N)); PEST%IDFFILES='' ENDIF CALL WDIALOGFIELDSTATE(IDF_GRID1,1) CALL WGRIDROWS(IDF_GRID1,N) CALL WGRIDPUTSTRING(IDF_GRID1,1,PEST%IDFFILES,N) ENDIF CASE (ID_MEASURES) CALL WDIALOGGETINTEGER(IDF_INTEGER12,N) IF(N.EQ.0)THEN CALL WDIALOGCLEARFIELD(IDF_GRID1) IF(ASSOCIATED(PEST%MEASURES))DEALLOCATE(PEST%MEASURES) CALL WDIALOGFIELDSTATE(IDF_GRID1,3) ELSE M=WINFOGRID(IDF_GRID1,GRIDROWSMAX) IF(N.GT.M)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You can specify a maximum of '//TRIM(VTOS(M))//' Measurement','Error'); N=M ENDIF !## resize variables IF(ASSOCIATED(PEST%MEASURES))THEN M=SIZE(PEST%MEASURES) IF(N.NE.M)THEN ALLOCATE(PEST%MEASURES_BU(N)); PEST%MEASURES_BU%IPFNAME=''; PEST%MEASURES_BU%IXCOL=1; PEST%MEASURES_BU%IYCOL=2; PEST%MEASURES_BU%ILCOL=3 PEST%MEASURES_BU%IMCOL=4; PEST%MEASURES_BU%IVCOL=-5; PEST%MEASURES_BU%IDCOL=0; PEST%MEASURES_BU%IPFTYPE=0; PEST%MEASURES_BU%IZ1CL=0; PEST%MEASURES_BU%IZ2CL=0; PEST%MEASURES_BU%IGHCL=0; PEST%MEASURES_BU%IGLCL=0 DO I=1,MIN(N,M); PEST%MEASURES_BU(I)=PEST%MEASURES(I); ENDDO DEALLOCATE(PEST%MEASURES); PEST%MEASURES=>PEST%MEASURES_BU ENDIF ELSE ALLOCATE(PEST%MEASURES(N)); PEST%MEASURES%IPFNAME=''; PEST%MEASURES%IXCOL=1; PEST%MEASURES%IYCOL=2; PEST%MEASURES%ILCOL=3 PEST%MEASURES%IMCOL=4; PEST%MEASURES%IVCOL=-5; PEST%MEASURES%IDCOL=0; PEST%MEASURES%IPFTYPE=0; PEST%MEASURES%IZ1CL=0; PEST%MEASURES%IZ2CL=0; PEST%MEASURES%IGHCL=0; PEST%MEASURES%IGLCL=0 ENDIF CALL WDIALOGFIELDSTATE(IDF_GRID1,1) CALL WGRIDROWS(IDF_GRID1,N) CALL WGRIDPUTSTRING (IDF_GRID1,1 ,PEST%MEASURES%IPFNAME,N) CALL WGRIDPUTCHECKBOX(IDF_GRID1,2 ,PEST%MEASURES%IPFTYPE,N) CALL WGRIDPUTINTEGER (IDF_GRID1,3 ,PEST%MEASURES%IXCOL,N) CALL WGRIDPUTINTEGER (IDF_GRID1,4 ,PEST%MEASURES%IYCOL,N) CALL WGRIDPUTINTEGER (IDF_GRID1,5 ,PEST%MEASURES%ILCOL,N) CALL WGRIDPUTINTEGER (IDF_GRID1,6 ,PEST%MEASURES%IMCOL,N) CALL WGRIDPUTINTEGER (IDF_GRID1,7 ,PEST%MEASURES%IVCOL,N) CALL WGRIDPUTINTEGER (IDF_GRID1,8 ,PEST%MEASURES%IDCOL,N) CALL WGRIDPUTINTEGER (IDF_GRID1,9 ,PEST%MEASURES%IZ1CL,N) CALL WGRIDPUTINTEGER (IDF_GRID1,10,PEST%MEASURES%IZ2CL,N) CALL WGRIDPUTINTEGER (IDF_GRID1,11,PEST%MEASURES%IGHCL,N) CALL WGRIDPUTINTEGER (IDF_GRID1,12,PEST%MEASURES%IGLCL,N) ENDIF CASE (IDOK,IDCANCEL) IF(PMANAGEROPEN_PESTPARAM_GETVALUES(ID))THEN EXIT ELSE CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Empty fields are not allowed or invalid entries.','Error') ENDIF END SELECT END SELECT ENDDO CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES) CALL WDIALOGUNLOAD(); CALL WDIALOGSELECT(DID) END SUBROUTINE PMANAGEROPEN_PESTPARAM !###====================================================================== LOGICAL FUNCTION PMANAGEROPEN_PESTPARAM_GETVALUES(ID) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ID INTEGER :: N,I PMANAGEROPEN_PESTPARAM_GETVALUES=.FALSE. SELECT CASE (ID) CASE (ID_PERIODS) CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES_TAB1) IF(ASSOCIATED(PEST%S_PERIOD))THEN N=SIZE(PEST%S_PERIOD) CALL WGRIDGETSTRING(IDF_GRID1,1,PEST%S_PERIOD,N) CALL WGRIDGETSTRING(IDF_GRID1,2,PEST%E_PERIOD,N) DO I=1,N IF(LEN_TRIM(PEST%S_PERIOD(I)).EQ.'')RETURN IF(LEN_TRIM(PEST%E_PERIOD(I)).EQ.'')RETURN ENDDO ENDIF CASE (ID_BATCHFILES) CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES_TAB2) IF(ASSOCIATED(PEST%B_FRACTION))THEN N=SIZE(PEST%B_FRACTION) CALL WGRIDGETDOUBLE(IDF_GRID1,1,PEST%B_FRACTION,N) CALL WGRIDGETSTRING(IDF_GRID1,2,PEST%B_BATCHFILE,N) CALL WGRIDGETSTRING(IDF_GRID1,3,PEST%B_OUTFILE,N) DO I=1,N IF(PEST%B_FRACTION(I).LT.0.0D0)RETURN IF(LEN_TRIM(PEST%B_BATCHFILE(I)).EQ.'')RETURN IF(LEN_TRIM(PEST%B_OUTFILE(I)).EQ.'')RETURN ENDDO ENDIF CASE (ID_PARAMETERS) CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES_TAB3) IF(ASSOCIATED(PEST%PARAM))THEN N=SIZE(PEST%PARAM) CALL WGRIDGETCHECKBOX(IDF_GRID1,1 ,PEST%PARAM%PACT,N) CALL WGRIDGETMENU(IDF_GRID1 ,2 ,PEST%PARAM%IPARAM,N) CALL WGRIDGETINTEGER(IDF_GRID1 ,3 ,PEST%PARAM%PILS,N) CALL WGRIDGETINTEGER(IDF_GRID1 ,4 ,PEST%PARAM%PIZONE,N) CALL WGRIDGETINTEGER(IDF_GRID1 ,5 ,PEST%PARAM%PIGROUP,N) CALL WGRIDGETDOUBLE(IDF_GRID1 ,6 ,PEST%PARAM%PINI,N) CALL WGRIDGETDOUBLE(IDF_GRID1 ,7 ,PEST%PARAM%PMIN,N) CALL WGRIDGETDOUBLE(IDF_GRID1 ,8 ,PEST%PARAM%PMAX,N) CALL WGRIDGETDOUBLE(IDF_GRID1 ,9 ,PEST%PARAM%PDELTA,N) CALL WGRIDGETDOUBLE(IDF_GRID1 ,10,PEST%PARAM%PINCREASE,N) CALL WGRIDGETCHECKBOX(IDF_GRID1,11,PEST%PARAM%PLOG,N) CALL WGRIDGETSTRING(IDF_GRID1 ,12,PEST%PARAM%ACRONYM,N) CALL WGRIDGETDOUBLE(IDF_GRID1 ,13,PEST%PARAM%PPRIOR,N) DO I=1,SIZE(PEST%PARAM); PEST%PARAM(I)%PPARAM=PARAM(PEST%PARAM(I)%IPARAM); ENDDO DO I=1,N IF(PEST%PARAM(I)%PINI.LT.0.0D0)RETURN IF(PEST%PARAM(I)%PMIN.LT.0.0D0)RETURN IF(PEST%PARAM(I)%PMAX.LT.0.0D0)RETURN IF(PEST%PARAM(I)%PDELTA.LT.0.0D0)RETURN IF(PEST%PARAM(I)%PINCREASE.LT.0.0D0)RETURN ENDDO ENDIF CASE (ID_ZONES) CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES_TAB4) CALL WDIALOGGETINTEGER(IDF_INTEGER11,N) IF(N.GT.0)CALL WGRIDGETSTRING(IDF_GRID1,1,PEST%IDFFILES,N) DO I=1,N IF(LEN_TRIM(PEST%IDFFILES(I)).EQ.'')RETURN ENDDO CASE (ID_MEASURES) CALL WDIALOGSELECT(ID_DPMANAGER_PESTFILES_TAB5) IF(ASSOCIATED(PEST%MEASURES))THEN N=SIZE(PEST%MEASURES) CALL WGRIDGETSTRING (IDF_GRID1,1 ,PEST%MEASURES%IPFNAME,N) CALL WGRIDGETCHECKBOX(IDF_GRID1,2 ,PEST%MEASURES%IPFTYPE,N) PEST%MEASURES%IPFTYPE=PEST%MEASURES%IPFTYPE+1 CALL WGRIDGETINTEGER (IDF_GRID1,3 ,PEST%MEASURES%IXCOL,N) CALL WGRIDGETINTEGER (IDF_GRID1,4 ,PEST%MEASURES%IYCOL,N) CALL WGRIDGETINTEGER (IDF_GRID1,5 ,PEST%MEASURES%ILCOL,N) CALL WGRIDGETINTEGER (IDF_GRID1,6 ,PEST%MEASURES%IMCOL,N) CALL WGRIDGETINTEGER (IDF_GRID1,7 ,PEST%MEASURES%IVCOL,N) CALL WGRIDGETINTEGER (IDF_GRID1,8 ,PEST%MEASURES%IDCOL,N) CALL WGRIDGETINTEGER (IDF_GRID1,9 ,PEST%MEASURES%IZ1CL,N) CALL WGRIDGETINTEGER (IDF_GRID1,10,PEST%MEASURES%IZ2CL,N) CALL WGRIDGETINTEGER (IDF_GRID1,11,PEST%MEASURES%IGHCL,N) CALL WGRIDGETINTEGER (IDF_GRID1,12,PEST%MEASURES%IGLCL,N) CALL WDIALOGGETCHECKBOX(IDF_CHECK1,PEST%IIPF) DO I=1,N IF(LEN_TRIM(PEST%MEASURES(I)%IPFNAME).EQ.'')RETURN ENDDO ENDIF END SELECT PMANAGEROPEN_PESTPARAM_GETVALUES=.TRUE. END FUNCTION PMANAGEROPEN_PESTPARAM_GETVALUES !###====================================================================== 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 UTL_DIALOGSHOW(-1,-1,0,3) DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE(FIELDCHANGED) !## current field SELECT CASE (MESSAGE%VALUE2) CASE (IDF_MENU3) IF(MESSAGE%VALUE1.EQ.MESSAGE%VALUE2)CALL PMANAGERDEFINEPERIODS_PUT() CASE (IDF_MENU1) CALL UTL_FILLDATES(IDF_INTEGER3,IDF_MENU1,IDF_INTEGER1) END SELECT CASE(PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (ID_DELETE) CALL WDIALOGGETMENU(IDF_MENU3,IOPTION) CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Are you sure to delete selected'//CHAR(13)// & 'period: ['//TRIM(PERIOD(IOPTION)%NAME)//']','Question') IF(WINFODIALOG(4).EQ.1)THEN DO I=IOPTION,SIZE(PERIOD)-1; PERIOD(I)=PERIOD(I+1); ENDDO; NPERIOD=MAX(NPERIOD-1,0) ENDIF IF(.NOT.PMANAGERDEFINEPERIODS_INIT())EXIT CASE (ID_NEW) CALL WDIALOGSELECT(ID_DPMANAGERDATES); CALL WDIALOGGETMENU(IDF_MENU3,IOPTION) CALL PMANAGERDEFINEPERIODS_GET(IOPTION) CALL PMANAGERDEFINEPERIODS_RENAME(0) CASE (ID_RENAME) CALL PMANAGERDEFINEPERIODS_RENAME(1) CASE (IDOK) CALL WDIALOGSELECT(ID_DPMANAGERDATES); CALL WDIALOGGETMENU(IDF_MENU3,IOPTION) CALL PMANAGERDEFINEPERIODS_GET(IOPTION); EXIT CASE (IDCANCEL) EXIT CASE (IDHELP) END SELECT END SELECT ENDDO CALL WDIALOGUNLOAD(); CALL WDIALOGSELECT(ID_DPMANAGEROPEN) END SUBROUTINE PMANAGERDEFINEPERIODS !###====================================================================== LOGICAL FUNCTION PMANAGERDEFINEPERIODS_INIT() !###====================================================================== IMPLICIT NONE PMANAGERDEFINEPERIODS_INIT=.FALSE. IF(NPERIOD.EQ.0)THEN CALL PMANAGERDEFINEPERIODS_RENAME(0) !## cannot start unless nperiod>0 IF(NPERIOD.EQ.0)THEN CALL WDIALOGUNLOAD(); CALL WDIALOGSELECT(ID_DPMANAGERDATES); RETURN ENDIF ELSE !## fill in menu CALL WDIALOGPUTMENU(IDF_MENU3,PERIOD%NAME,NPERIOD,1) CALL PMANAGERDEFINEPERIODS_PUT() IF(NPERIOD.GE.SIZE(PERIOD))CALL WDIALOGFIELDSTATE(ID_NEW,0) ENDIF PMANAGERDEFINEPERIODS_INIT=.TRUE. END FUNCTION PMANAGERDEFINEPERIODS_INIT !###====================================================================== SUBROUTINE PMANAGERDEFINEPERIODS_RENAME(ICODE) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ICODE INTEGER :: IOPTION,ITYPE,I TYPE(WIN_MESSAGE) :: MESSAGE !## define new period IF(ICODE.EQ.0)THEN NPERIOD=NPERIOD+1; IOPTION=NPERIOD PERIOD(IOPTION)%NAME='' PERIOD(IOPTION)%IMH=4; PERIOD(IOPTION)%IDY=1; PERIOD(IOPTION)%IYR=2014 PERIOD(IOPTION)%IHR=0; PERIOD(IOPTION)%IMT=0; PERIOD(IOPTION)%ISC=0 !## use existing one ELSE CALL WDIALOGGETMENU(IDF_MENU3,IOPTION) ENDIF CALL WDIALOGLOAD(ID_POLYGONSHAPENAME,ID_POLYGONSHAPENAME) CALL WDIALOGFIELDSTATE(IDF_INTEGER1,3) CALL WDIALOGFIELDSTATE(IDF_LABEL2,3) CALL UTL_DIALOGSHOW(-1,-1,0,3) CALL WDIALOGPUTSTRING(IDF_LABEL1,'Enter a new name') IF(IOPTION.EQ.0)CALL WDIALOGPUTSTRING(IDF_STRING1,'...') IF(IOPTION.GT.0)CALL WDIALOGPUTSTRING(IDF_STRING1,TRIM(PERIOD(IOPTION)%NAME)) DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE (PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (IDOK) CALL WDIALOGGETSTRING(IDF_STRING1,PERIOD(IOPTION)%NAME) IF(TRIM(PERIOD(IOPTION)%NAME).EQ.'')THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You should specify a name of at least 1 character','Warning') ELSE DO I=1,NPERIOD IF(I.EQ.IOPTION)CYCLE IF(UTL_CAP(TRIM(PERIOD(I)%NAME),'U').EQ.UTL_CAP(TRIM(PERIOD(IOPTION)%NAME),'U'))THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Given name has defined already.'//CHAR(13)// & 'You should specify an unique name','Warning') EXIT ENDIF ENDDO IF(I.GT.NPERIOD)EXIT ENDIF CASE (IDCANCEL) EXIT END SELECT END SELECT ENDDO CALL WDIALOGUNLOAD() CALL WDIALOGSELECT(ID_DPMANAGERDATES) IF(MESSAGE%VALUE1.EQ.IDOK)THEN CALL WDIALOGPUTMENU(IDF_MENU3,PERIOD%NAME,NPERIOD,IOPTION) CALL PMANAGERDEFINEPERIODS_PUT() ELSEIF(MESSAGE%VALUE1.EQ.IDCANCEL)THEN NPERIOD=NPERIOD-1 ENDIF IF(NPERIOD.GE.SIZE(PERIOD))CALL WDIALOGFIELDSTATE(ID_NEW,0) END SUBROUTINE PMANAGERDEFINEPERIODS_RENAME !###====================================================================== SUBROUTINE PMANAGERDEFINEPERIODS_PUT() !###====================================================================== IMPLICIT NONE INTEGER :: IOPTION,I CALL WDIALOGSELECT(ID_DPMANAGERDATES) CALL WDIALOGGETMENU(IDF_MENU3,IOPTION) CALL WDIALOGGETINTEGER(IDF_INTEGER4,I) !## make copy of entered data first, before overwrite it with new one IF(I.NE.IOPTION)CALL PMANAGERDEFINEPERIODS_GET(I) CALL WDIALOGPUTINTEGER(IDF_INTEGER4,IOPTION) CALL WDIALOGPUTMENU(IDF_MENU1,CDATE,12,PERIOD(IOPTION)%IMH) CALL WDIALOGPUTINTEGER(IDF_INTEGER1 ,PERIOD(IOPTION)%IDY) CALL WDIALOGPUTINTEGER(IDF_INTEGER3 ,PERIOD(IOPTION)%IYR) CALL WDIALOGPUTINTEGER(IDF_INTEGER6 ,PERIOD(IOPTION)%IHR) CALL WDIALOGPUTINTEGER(IDF_INTEGER7 ,PERIOD(IOPTION)%IMT) CALL WDIALOGPUTINTEGER(IDF_INTEGER8 ,PERIOD(IOPTION)%ISC) CALL UTL_FILLDATES(IDF_INTEGER3,IDF_MENU1,IDF_INTEGER1) END SUBROUTINE PMANAGERDEFINEPERIODS_PUT !###====================================================================== SUBROUTINE PMANAGERDEFINEPERIODS_GET(IOPTION) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: IOPTION IF(IOPTION.GT.0)THEN CALL WDIALOGGETMENU(IDF_MENU1 ,PERIOD(IOPTION)%IMH) CALL WDIALOGGETINTEGER(IDF_INTEGER1 ,PERIOD(IOPTION)%IDY) CALL WDIALOGGETINTEGER(IDF_INTEGER3 ,PERIOD(IOPTION)%IYR) CALL WDIALOGGETINTEGER(IDF_INTEGER6 ,PERIOD(IOPTION)%IHR) CALL WDIALOGGETINTEGER(IDF_INTEGER7 ,PERIOD(IOPTION)%IMT) CALL WDIALOGGETINTEGER(IDF_INTEGER8 ,PERIOD(IOPTION)%ISC) ENDIF END SUBROUTINE PMANAGERDEFINEPERIODS_GET !###====================================================================== SUBROUTINE PMANAGERDEFINESPECIES() !###====================================================================== IMPLICIT NONE INTEGER :: ITYPE,DID,NSPEC TYPE(WIN_MESSAGE) :: MESSAGE LOGICAL :: LEX DID=WINFODIALOG(CURRENTDIALOG) CALL WDIALOGLOAD(ID_DPMANAGER_MT3D_SPECIES,ID_DPMANAGER_MT3D_SPECIES) !## save previous number of species NSPEC=NSPECIES !## display dialog CALL WGRIDSTATE(IDF_GRID1,1,2); CALL WGRIDSTATE(IDF_GRID1,2,1); CALL WGRIDSTATE(IDF_GRID1,3,1) CALL WDIALOGRANGEINTEGER(IDF_INTEGER1,0,SIZE(SPECIES)) CALL WDIALOGPUTINTEGER(IDF_INTEGER1,NSPECIES) CALL PMANAGERDEFINESPECIES_ADJUST(0) CALL UTL_DIALOGSHOW(-1,-1,0,3) DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE(FIELDCHANGED) !## current field SELECT CASE (MESSAGE%VALUE2) END SELECT CASE(PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (ID_APPLY) CALL PMANAGERDEFINESPECIES_ADJUST(1) CASE (IDCANCEL) !## restore to original number of species NSPECIES=NSPEC; EXIT CASE (IDOK) CALL WGRIDGETSTRING(IDF_GRID1,2,SPECIES%NAME ,NSPECIES) CALL WGRIDGETMENU( IDF_GRID1,3,SPECIES%IMOBILE,NSPECIES) EXIT CASE (IDHELP) CALL UTL_GETHELP('*','VMO.iPM.DefSpec') END SELECT END SELECT ENDDO CALL WDIALOGUNLOAD(); CALL WDIALOGSELECT(DID) !## old number of species not equal to new set of species IF(NSPEC.NE.NSPECIES)THEN !## all will be removed LEX=.TRUE.; IF(NSPEC.GT.0.AND.NSPECIES.EQ.0)THEN CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Are you sure to remove all species','Question') IF(WINFODIALOG(4).NE.1)LEX=.FALSE. ENDIF IF(LEX)CALL PMANAGERDEFINESPECIES_UPDATE() ENDIF END SUBROUTINE PMANAGERDEFINESPECIES !###====================================================================== SUBROUTINE PMANAGERDEFINESPECIES_UPDATE() !###====================================================================== IMPLICIT NONE INTEGER :: I,J,NORG,NTOP,IPER,NSYS,ISYS,ISUB !## modify ALL to include the species DO I=1,MAXTOPICS !## skip time invarient topics IF(.NOT.TOPICS(I)%LSPECIES)CYCLE !## drainage does not have species SELECT CASE (I) CASE (TDRN,TOLF); CYCLE END SELECT !## original number of topics NORG=TOPICS(I)%NSUBTOPICS-TOPICS(I)%NSPECIES !## new number of topics NTOP=NORG+NSPECIES !## set original number of topics NORG=TOPICS(I)%NSUBTOPICS ! IF(I.EQ.TSCO.OR.I.EQ.TTVC)THEN ! NORG=NORG+1 !; NTOP=NTOP-1 ! ENDIF !## process none empty ones IF(ASSOCIATED(TOPICS(I)%STRESS))THEN !## number of defined stresses NPER=SIZE(TOPICS(I)%STRESS) DO IPER=1,NPER NSYS=SIZE(TOPICS(I)%STRESS(IPER)%FILES,2) ALLOCATE(TOPICS(I)%STRESS(IPER)%FILES_TMP(NTOP,NSYS)) DO ISYS=1,NSYS DO ISUB=1,NORG TOPICS(I)%STRESS(IPER)%FILES_TMP(ISUB,ISYS)=TOPICS(I)%STRESS(IPER)%FILES(ISUB,ISYS) ENDDO !## add new ones DO ISUB=NORG+1,NTOP TOPICS(I)%STRESS(IPER)%FILES_TMP(ISUB,ISYS)%IACT =1 TOPICS(I)%STRESS(IPER)%FILES_TMP(ISUB,ISYS)%FNAME='' TOPICS(I)%STRESS(IPER)%FILES_TMP(ISUB,ISYS)%FCT =1.0D0 TOPICS(I)%STRESS(IPER)%FILES_TMP(ISUB,ISYS)%IMP =0.0D0 TOPICS(I)%STRESS(IPER)%FILES_TMP(ISUB,ISYS)%ICNST=1 TOPICS(I)%STRESS(IPER)%FILES_TMP(ISUB,ISYS)%CNST =1.0D0 TOPICS(I)%STRESS(IPER)%FILES_TMP(ISUB,ISYS)%ILAY =TOPICS(I)%STRESS(IPER)%FILES(1,ISYS)%ILAY ENDDO ENDDO DEALLOCATE(TOPICS(I)%STRESS(IPER)%FILES) TOPICS(I)%STRESS(IPER)%FILES=>TOPICS(I)%STRESS(IPER)%FILES_TMP ENDDO ENDIF TOPICS(I)%NSUBTOPICS=NTOP DO J=1,NSPECIES; TOPICS(I)%SNAME(J+NORG)='Concentration '//TRIM(SPECIES(J)%NAME); ENDDO TOPICS(I)%NSPECIES=NSPECIES ENDDO END SUBROUTINE PMANAGERDEFINESPECIES_UPDATE !###====================================================================== SUBROUTINE PMANAGERDEFINESPECIES_ADJUST(IUPDATE) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: IUPDATE INTEGER :: I,N CALL WDIALOGGETINTEGER(IDF_INTEGER1,N) IF(N.EQ.0)THEN CALL WGRIDCLEAR(IDF_GRID1); CALL WDIALOGFIELDSTATE(IDF_GRID1,3) ELSE !## get data from current grid so far IF(IUPDATE.EQ.1)THEN CALL WGRIDGETSTRING(IDF_GRID1,2,SPECIES%NAME,NSPECIES) CALL WGRIDGETMENU(IDF_GRID1,3,SPECIES%IMOBILE,NSPECIES) ENDIF !## renew grid CALL WDIALOGFIELDSTATE(IDF_GRID1,1); CALL WGRIDROWS(IDF_GRID1,N) !## fill in species number, name and mobility DO I=1,N; CALL WGRIDPUTCELLINTEGER(IDF_GRID1,1,I,I); ENDDO !## initialize new species DO I=NSPECIES+1,N; SPECIES(I)%NAME='SPECIES '//TRIM(VTOS(I)); SPECIES(I)%IMOBILE=1; ENDDO !## put them on the dialog CALL WGRIDPUTSTRING(IDF_GRID1,2,SPECIES%NAME,N) CALL WGRIDPUTOPTION(IDF_GRID1,3,SPECIES%IMOBILE,N) ENDIF !## update number of species NSPECIES=N END SUBROUTINE PMANAGERDEFINESPECIES_ADJUST !###====================================================================== LOGICAL FUNCTION PMANAGER_GETSELECTED(ID,ITOPIC,IPER,ISYS,ISUBTOPIC,IERROR) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ID,IERROR INTEGER,INTENT(OUT) :: ITOPIC,IPER,ISYS,ISUBTOPIC INTEGER :: NSYS PMANAGER_GETSELECTED=.FALSE. !## check what topic has been selected TOPICLOOP: DO ITOPIC=1,MAXTOPICS IPER=0; ISYS=0; ISUBTOPIC=0; IF(ID.EQ.TOPICS(ITOPIC)%ID)EXIT TOPICLOOP NPER=0; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))NPER=SIZE(TOPICS(ITOPIC)%STRESS) DO IPER=1,NPER ISYS=0; ISUBTOPIC=0 IF(ID.EQ.TOPICS(ITOPIC)%IDT(IPER))EXIT TOPICLOOP NSYS=0; IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(IPER)%FILES))NSYS=SIZE(TOPICS(ITOPIC)%STRESS(IPER)%FILES,2) !## read for each subtopic DO ISUBTOPIC=1,TOPICS(ITOPIC)%NSUBTOPICS ISYS=0 IF(ID.EQ.TOPICS(ITOPIC)%ISD(IPER,ISUBTOPIC))THEN IF(IERROR.EQ.1)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You should select a MAIN TOPIC, a DATE or an individual FILENAME.','Warning') RETURN ELSE EXIT TOPICLOOP ENDIF ENDIF !## read for each system DO ISYS=1,NSYS IF(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ID.EQ.ID)EXIT TOPICLOOP ENDDO ENDDO ENDDO ENDDO TOPICLOOP IF(ITOPIC.GT.MAXTOPICS)THEN ITOPIC=0; CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You should select a MAIN TOPIC at least','Warning'); RETURN ENDIF !## ITOPIC =TOPIC NUMBER (E.G. SHD, BND, WEL) !## IPER =STRESSPERIOD !## ISYS =SYSTEM NUMBER PMANAGER_GETSELECTED=.TRUE. END FUNCTION PMANAGER_GETSELECTED !###====================================================================== SUBROUTINE PMANAGERPUTFIELDS(IST,ICF,EXT) !###====================================================================== IMPLICIT NONE CHARACTER(LEN=*),INTENT(OUT) :: EXT INTEGER,INTENT(OUT) :: IST,ICF IF(.NOT.ALLOCATED(MENUNAMES))RETURN !## get subitem CALL WDIALOGGETMENU(IDF_MENU1,IST) !## usage of constant values ICF=1 IF(INDEX(UTL_CAP(MENUNAMES(IST),'U'),'(IDF)').GT.0)EXT='IDF' IF(INDEX(UTL_CAP(MENUNAMES(IST),'U'),'(IPF)').GT.0)EXT='IPF' IF(INDEX(UTL_CAP(MENUNAMES(IST),'U'),'(ISG)').GT.0)EXT='ISG' IF(INDEX(UTL_CAP(MENUNAMES(IST),'U'),'(GEN)').GT.0)EXT='GEN' SELECT CASE (EXT); CASE('IPF','ISG','GEN'); ICF=0; END SELECT CALL WDIALOGPUTDOUBLE(IDF_REAL1,PRJ(IST)%FCT,'(G12.5)') CALL WDIALOGPUTDOUBLE(IDF_REAL2,PRJ(IST)%IMP,'(G12.5)') CALL WDIALOGPUTDOUBLE(IDF_REAL3,PRJ(IST)%CNST,'(G12.5)') !## for ipf,isg,gen not constant values allowed IF(ICF.EQ.0)PRJ(IST)%ICNST=2 IF(PRJ(IST)%ICNST.EQ.1)THEN CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO1) CALL WDIALOGPUTSTRING(IDF_STRING1,'') ELSEIF(PRJ(IST)%ICNST.EQ.2)THEN CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO2) CALL WDIALOGPUTSTRING(IDF_STRING1,TRIM(PRJ(IST)%FNAME)) ENDIF END SUBROUTINE PMANAGERPUTFIELDS !###====================================================================== SUBROUTINE PMANAGERGETFIELDS(IST) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: IST CALL WDIALOGGETDOUBLE(IDF_REAL1,PRJ(IST)%FCT) CALL WDIALOGGETDOUBLE(IDF_REAL2,PRJ(IST)%IMP) ! CALL WDIALOGGETCHECKBOX(IDF_CHECK2,PRJ(IST)%ICNST) ! !## inherent ! IF(PRJ(IST)%ICNST.EQ.1)THEN ! PRJ(IST)%ICNST=0 ! ELSE CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,PRJ(IST)%ICNST) ! ENDIF CALL WDIALOGGETDOUBLE(IDF_REAL3,PRJ(IST)%CNST) IF(PRJ(IST)%ICNST.EQ.2)CALL WDIALOGGETSTRING(IDF_STRING1,PRJ(IST)%FNAME) END SUBROUTINE PMANAGERGETFIELDS !###====================================================================== SUBROUTINE PMANAGEROPENFIELDS(LEX,LNEW,ICF) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ICF LOGICAL,INTENT(IN) :: LEX,LNEW INTEGER :: II,I,J,K,L CALL WDIALOGGETCHECKBOX(IDF_CHECK1,II) IF(II.EQ.1)THEN CALL WDIALOGPUTSTRING(IDF_CHECK1,'Current Particular System for the selected Package is ACTIVE, deselect to Deactivate it.') CALL WDIALOGCOLOUR(IDF_CHECK1,WRGB(0,0,0),WRGB(0,255,0)) ELSE CALL WDIALOGPUTSTRING(IDF_CHECK1,'Current Particular System for the selected Package is INACTIVE, select to Activate it.') CALL WDIALOGCOLOUR(IDF_CHECK1,WRGB(255,255,255),WRGB(255,0,0)) ENDIF CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,I) SELECT CASE (I) !## constant CASE (1); J=0; L=1 !## idf CASE (2); J=1; L=0 END SELECT II=1 CALL WDIALOGFIELDSTATE(IDF_REAL1,II) CALL WDIALOGFIELDSTATE(IDF_REAL2,II) CALL WDIALOGFIELDSTATE(IDF_LABEL2,II) CALL WDIALOGFIELDSTATE(IDF_LABEL3,II) CALL WDIALOGFIELDSTATE(IDF_RADIO1,II*ICF) CALL WDIALOGFIELDSTATE(IDF_RADIO2,II) CALL WDIALOGFIELDSTATE(IDF_REAL3,L) CALL WDIALOGFIELDSTATE(IDF_STRING1,J) CALL WDIALOGFIELDSTATE(ID_OPEN,J) !## new definition IF(LEX)THEN CALL WDIALOGGETRADIOBUTTON(IDF_RADIO3,I) SELECT CASE (I) CASE (1) J=0; K=0; L=0 CASE (2) J=1; K=0; L=0; IF(.NOT.LNEW)J=2 CASE (3) J=0; K=1; L=1; IF(.NOT.LNEW)L=2 IF(NPERIOD.EQ.0)L=0 END SELECT CALL WDIALOGFIELDSTATE(IDF_MENU2,J) CALL WDIALOGFIELDSTATE(IDF_INTEGER2,J) CALL WDIALOGFIELDSTATE(IDF_INTEGER3,J) CALL WDIALOGFIELDSTATE(IDF_INTEGER4,J) CALL WDIALOGFIELDSTATE(IDF_INTEGER5,J) CALL WDIALOGFIELDSTATE(IDF_INTEGER6,J) CALL WDIALOGFIELDSTATE(IDF_MENU3,L) CALL WDIALOGFIELDSTATE(ID_PROPERTIES,K) ENDIF END SUBROUTINE PMANAGEROPENFIELDS !###====================================================================== SUBROUTINE PMANAGERDRAW_PLUS() !###====================================================================== IMPLICIT NONE INTEGER :: ITYPE,IOPTION TYPE(WIN_MESSAGE) :: MESSAGE INTEGER :: I,IL1,IL2,IPLOT,NFILES CALL PMANAGER_GETNFILES((/TTOP,TBOT,TBND,TSHD,TKDW,TKHV,TKVA,TVCW,TKVV,TSTO,TSPY/),PRJMXNLAY) IF(PRJMXNLAY.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,PRJMXNLAY) CALL WDIALOGPUTINTEGER(IDF_INTEGER2,PRJMXNLAY) CALL WDIALOGRANGEINTEGER(IDF_INTEGER2,1,PRJMXNLAY) CALL UTL_DIALOGSHOW(-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),PRJILIST(2)) PRJILIST(1)=TTOP; PRJILIST(2)=TBOT !## TOP1 - KDW1 - BOT1 - TOP2 - KDW2 - BOT2 ... CASE (2) ALLOCATE(FNAMES(NLAY*3),PRJILIST(3)) PRJILIST(1)=TTOP; PRJILIST(2)=TKDW; PRJILIST(3)=TBOT !## TOP1 - KDW1 - BOT1 - VCW1 - TOP2 - KDW1- BOT2 - VCW2 - TOP3 ... CASE (3) ALLOCATE(FNAMES(NLAY*4-1),PRJILIST(4)) PRJILIST(1)=TTOP; PRJILIST(2)=TKDW; PRJILIST(3)=TBOT; PRJILIST(4)=TVCW !## TOP1 - BOT1 - VCW1 - TOP2 - BOT2 - VCW2 - TOP3 ... CASE(4) ALLOCATE(FNAMES(NLAY*3-1),PRJILIST(3)) PRJILIST(1)=TTOP; PRJILIST(2)=TBOT; PRJILIST(3)=TVCW !## TOP1 - SHD1 - BOT1 - TOP2 - SHD2 - BOT2 ... CASE (5) ALLOCATE(FNAMES(NLAY*3),PRJILIST(3)) PRJILIST(1)=TTOP; PRJILIST(2)=TSHD; PRJILIST(3)=TBOT !## TOP1 - KHV1 - BOT1 - TOP2 - KHV2 - BOT2 ... CASE (6) ALLOCATE(FNAMES(NLAY*3),PRJILIST(3)) PRJILIST(1)=TTOP; PRJILIST(2)=TKHV; PRJILIST(3)=TBOT !## TOP1 - BOT1 - KVV1 - TOP2 - BOT2 - KVV2 - TOP3 ... CASE(7) ALLOCATE(FNAMES(NLAY*3-1),PRJILIST(3)) PRJILIST(1)=TTOP; PRJILIST(2)=TBOT; PRJILIST(3)=TKVV !## TOP1 - KHV1 - BOT1 - KVV1 - TOP2 - KHV2 - BOT2 - KVV2 - TOP3 ... CASE (8) ALLOCATE(FNAMES(NLAY*4-1),PRJILIST(4)) PRJILIST(1)=TTOP; PRJILIST(2)=TKHV; PRJILIST(3)=TBOT; PRJILIST(4)=TKVV END SELECT !## get appropriate number of files - no matter what system or type, for first "stress-period" NFILES=PMANAGER_GETFNAMES(IL1,IL2,0,0,1) !## nothing found IF(NFILES.GT.0)THEN !## select files in the imod manager MP%ISEL=.FALSE. DO I=1,NFILES DO IPLOT=1,SIZE(MP) IF(TRIM(UTL_CAP(MP(IPLOT)%IDFNAME,'U')).EQ.TRIM(UTL_CAP(FNAMES(I)%FNAME,'U')))MP(IPLOT)%ISEL=.TRUE. ENDDO END DO !## delete them all from manager CALL MANAGER_UTL_DELETE(IQ=0) DO I=1,NFILES; CALL MANAGER_UTL_ADDFILE(FNAMES(I)%FNAME,LDEACTIVATE=.FALSE.); ENDDO ENDIF DEALLOCATE(FNAMES,PRJILIST) END SUBROUTINE PMANAGERDRAW_PLUS !###====================================================================== SUBROUTINE PMANAGERDRAW() !###====================================================================== IMPLICIT NONE INTEGER :: IPER,ITOPIC,ISYS,ID,ISUBTOPIC CHARACTER(LEN=256) :: CNAME CALL WDIALOGSELECT(ID_DPMANAGER_TAB1); 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(IPER)%FILES,2) DO ISUBTOPIC=1,TOPICS(ITOPIC)%NSUBTOPICS !## idf file IF(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ICNST.EQ.2)THEN CALL MANAGER_UTL_ADDFILE(IDFNAMEGIVEN=TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME) 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 MANAGER_UTL_ADDFILE(IDFNAMEGIVEN=TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME) 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 MANAGER_UTL_ADDFILE(IDFNAMEGIVEN=TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME) 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 MANAGER_UTL_ADDFILE(IDFNAMEGIVEN=TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME) ENDIF ENDDO ELSE CALL MANAGER_UTL_ADDFILE(IDFNAMEGIVEN=TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FNAME) ENDIF CALL IDFPLOTFAST(0) END SUBROUTINE PMANAGERDRAW !###====================================================================== LOGICAL FUNCTION PMANAGERPRJ(ID,RUNFNAME,IBATCH,IDIALOG) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ID,IBATCH,IDIALOG CHARACTER(LEN=*),INTENT(IN) :: RUNFNAME CHARACTER(LEN=256) :: FNAME PMANAGERPRJ=.FALSE. IF(ID.EQ.ID_OPEN)THEN IF(RUNFNAME.EQ.'')THEN FNAME='' IF(.NOT.UTL_WSELECTFILE('iMOD Project File (*.prj)|*.prj|', & LOADDIALOG+MUSTEXIST+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,& 'Load iMOD Project File'))RETURN ELSE FNAME=RUNFNAME ENDIF !## reading content PRJ file IF(.NOT.PMANAGER_LOADPRJ(FNAME,IBATCH))THEN IF(IBATCH.EQ.0)CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMOD cannot read in the Project File','Error') ELSE IF(IBATCH.EQ.0.AND.IDIALOG.EQ.1)CALL PMANAGER_UTL_UPDATE_TREEVIEW(0,0,0); PMANAGERPRJ=.TRUE. ENDIF ELSEIF(ID.EQ.ID_SAVE)THEN IF(RUNFNAME.EQ.'')THEN FNAME='' IF(.NOT.UTL_WSELECTFILE('iMOD Project Files (*.prj)|*.prj|', & SAVEDIALOG+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,'Save iMOD Project File'))RETURN ELSE FNAME=RUNFNAME ENDIF IF(PMANAGER_SAVEPRJ(FNAME))THEN IF(IBATCH.EQ.0)CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'Successfully written project file:'//CHAR(13)//TRIM(FNAME),'Information') IF(IBATCH.EQ.1)WRITE(*,'(/A/)') 'Successfully written project file:'//TRIM(FNAME) PMANAGERPRJ=.TRUE. ENDIF ENDIF END FUNCTION PMANAGERPRJ !###====================================================================== LOGICAL FUNCTION PMANAGER_SAVEPRJ(FNAME) !###====================================================================== IMPLICIT NONE CHARACTER(LEN=*),INTENT(IN) :: FNAME INTEGER :: IU,I,J,K,L,N CHARACTER(LEN=52) :: FRM 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 !## get maximal file length for file names N=0; DO J=1,SIZE(TOPICS(I)%STRESS) IF(.NOT.ASSOCIATED(TOPICS(I)%STRESS(J)%FILES))CYCLE DO K=1,SIZE(TOPICS(I)%STRESS(J)%FILES,1) !## systems(.) DO L=1,SIZE(TOPICS(I)%STRESS(J)%FILES,2) !## subtopics(.) N=MAX(LEN_TRIM(TOPICS(I)%STRESS(J)%FILES(K,L)%FNAME),N) ENDDO ENDDO ENDDO N=N+2; WRITE(FRM,'(A34,I3.3,A3)') '(1X,2(I1,A1),I4.3,3(A1,G15.7),A1,A',N,',A)' !## pst module is exception SELECT CASE (I) CASE (TPST) WRITE(IU,'(/I6.6,A,I1,A)') SIZE(PEST%PARAM),','//TOPICS(I)%TNAME(1:5)//',',TOPICS(I)%IACT_MODEL,','//TRIM(TOPICS(I)%TNAME(6:))//' []' IF(.NOT.PMANAGER_SAVEPST(IU,0,'',0,0))RETURN CYCLE CASE (TIES) WRITE(IU,'(/I6.6,A,I1,A)') SIZE(PEST%PARAM),','//TOPICS(I)%TNAME(1:5)//',',TOPICS(I)%IACT_MODEL,','//TRIM(TOPICS(I)%TNAME(6:))//' []' CALL PMANAGER_SAVEIES(IU) CYCLE !## pcg module another exception CASE (TPCG) WRITE(IU,'(/I6.6,A,I1,A)') 1,','//TOPICS(I)%TNAME(1:5)//',',TOPICS(I)%IACT_MODEL,','//TRIM(TOPICS(I)%TNAME(6:)) !//' []' CALL PMANAGER_SAVEPCG(IU,0) CYCLE !## gcg module another exception CASE (TGCG) WRITE(IU,'(/I6.6,A,I1,A)') 1,','//TOPICS(I)%TNAME(1:5)//',',TOPICS(I)%IACT_MODEL,','//TRIM(TOPICS(I)%TNAME(6:)) !//' []' CALL PMANAGER_SAVEGCG(IU) CYCLE !## rct module another exception CASE (TRCT) WRITE(IU,'(/I6.6,A,I1,A)') 1,','//TOPICS(I)%TNAME(1:5)//',',TOPICS(I)%IACT_MODEL,','//TRIM(TOPICS(I)%TNAME(6:)) !//' []' CALL PMANAGER_SAVERCT(IU) CYCLE !## vdf module another exception CASE (TVDF) WRITE(IU,'(/I6.6,A,I1,A)') 1,','//TOPICS(I)%TNAME(1:5)//',',TOPICS(I)%IACT_MODEL,','//TRIM(TOPICS(I)%TNAME(6:)) !//' []' CALL PMANAGER_SAVEVDF(IU) CYCLE END SELECT WRITE(LINE,'(I6.6,A,I1,A)') SIZE(TOPICS(I)%STRESS),','//TOPICS(I)%TNAME(1:5)//',',TOPICS(I)%IACT_MODEL,','//TRIM(TOPICS(I)%TNAME(6:)) WRITE(IU,'(/A)') TRIM(LINE) DO L=1,SIZE(TOPICS(I)%STRESS) IF(.NOT.ASSOCIATED(TOPICS(I)%STRESS(L)%FILES))CYCLE IF(TOPICS(I)%TIMDEP)THEN IF(TOPICS(I)%STRESS(L)%IYR+TOPICS(I)%STRESS(L)%IMH+TOPICS(I)%STRESS(L)%IDY+ & TOPICS(I)%STRESS(L)%IHR+TOPICS(I)%STRESS(L)%IMT+TOPICS(I)%STRESS(L)%ISC.GT.0)THEN WRITE(IU,'(I4.4,5(A1,I2.2))') TOPICS(I)%STRESS(L)%IYR,'-',TOPICS(I)%STRESS(L)%IMH,'-',TOPICS(I)%STRESS(L)%IDY,' ', & TOPICS(I)%STRESS(L)%IHR,':',TOPICS(I)%STRESS(L)%IMT,':',TOPICS(I)%STRESS(L)%ISC ELSE WRITE(IU,'(A)') TRIM(TOPICS(I)%STRESS(L)%CDATE) ENDIF ENDIF WRITE(IU,'(2(I3.3,A1))') SIZE(TOPICS(I)%STRESS(L)%FILES,1),',',SIZE(TOPICS(I)%STRESS(L)%FILES,2) DO K=1,SIZE(TOPICS(I)%STRESS(L)%FILES,1) !## subtopics(.) DO J=1,SIZE(TOPICS(I)%STRESS(L)%FILES,2) !## systems(.) WRITE(IU,FRM) 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),' >>> '//TRIM(TOPICS(I)%SNAME(K))//' <<<' ENDDO ENDDO !## write extra files only for MetaSWAP IF(I.EQ.TCAP)THEN IF(ASSOCIATED(TOPICS(I)%STRESS(L)%INPFILES))THEN K=SIZE(TOPICS(I)%STRESS(L)%INPFILES) WRITE(IU,'(I3.3,A)') K,',EXTRA FILES' DO J=1,K; WRITE(IU,'(A)') TRIM(TOPICS(I)%STRESS(L)%INPFILES(J)); ENDDO ENDIF ENDIF ENDDO ENDDO WRITE(IU,'(/A)') 'Periods' DO I=1,NPERIOD WRITE(IU,'(A)') '"'//TRIM(PERIOD(I)%NAME)//'"' WRITE(IU,'(2(I2.2,A1),I4.4,3(A1,I2.2))') PERIOD(I)%IDY,'-',PERIOD(I)%IMH,'-',PERIOD(I)%IYR,' ', & PERIOD(I)%IHR,':',PERIOD(I)%IMT,':',PERIOD(I)%ISC ENDDO WRITE(IU,'(/A)') 'Species' DO I=1,NSPECIES WRITE(IU,'(A)') '"'//TRIM(SPECIES(I)%NAME)//'",'//TRIM(VTOS(SPECIES(I)%IMOBILE)) ENDDO CLOSE(IU) PMANAGER_SAVEPRJ=.TRUE. END FUNCTION PMANAGER_SAVEPRJ !###====================================================================== LOGICAL FUNCTION PMANAGER_LOADPRJ(FNAME,IBATCH) !###====================================================================== IMPLICIT NONE CHARACTER(LEN=*),INTENT(IN) :: FNAME INTEGER,INTENT(IN) :: IBATCH INTEGER :: IU,I,J,K,IOS,NC,L,NSYS,IACT CHARACTER(LEN=MAXLENPRJ) :: CTOPIC PMANAGER_LOADPRJ=.FALSE. NPERIOD=0; NSPECIES=0 !## clean existing project file information DO I=1,SIZE(TOPICS); CALL PMANAGER_DEALLOCATE(I); ENDDO; CALL PMANAGER_DEALLOCATE_PEST(); CALL PMANAGER_UTL_INIT() IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=FNAME,STATUS='OLD',ACTION='READ,DENYWRITE',FORM='FORMATTED') DO READ(IU,'(A512)',IOSTAT=IOS) LINE; IF(IOS.NE.0)EXIT !## reading species list first IF(TRIM(UTL_CAP(LINE,'U')).EQ.'SPECIES')THEN I=0; DO READ(IU,'(A512)',IOSTAT=IOS) LINE; IF(IOS.NE.0)EXIT IF(TRIM(LINE).EQ.'')EXIT I=I+1; READ(LINE,*,IOSTAT=IOS) SPECIES(I)%NAME,SPECIES(I)%IMOBILE IF(IOS.NE.0)THEN; I=I-1; EXIT; ENDIF ENDDO; NSPECIES=I ENDIF !## periods defined - stop searching for modules/packages IF(TRIM(UTL_CAP(LINE,'U')).EQ.'PERIODS')THEN !## reading period list I=0; DO READ(IU,'(A512)',IOSTAT=IOS) LINE; IF(IOS.NE.0)EXIT IF(TRIM(LINE).EQ.'')EXIT I=I+1 IF(I.GT.SIZE(PERIOD))THEN IF(IBATCH.EQ.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'There is a maximum of '//TRIM(VTOS(MAXPERIODS))//' periods','Error') ELSE WRITE(*,'(/A/)') 'There is a maximum of '//TRIM(VTOS(MAXPERIODS))//' periods'; STOP ENDIF RETURN ENDIF READ(LINE,*,IOSTAT=IOS) PERIOD(I)%NAME READ(IU,'(2(I2.2,1X),I4.4,3(1X,I2.2))',IOSTAT=IOS) PERIOD(I)%IDY,PERIOD(I)%IMH,PERIOD(I)%IYR, & PERIOD(I)%IHR,PERIOD(I)%IMT,PERIOD(I)%ISC IF(IOS.NE.0)THEN; I=I-1; EXIT; ENDIF ENDDO; NPERIOD=I ENDIF ENDDO REWIND(IU) !## read modules DO DO READ(IU,'(A512)',IOSTAT=IOS) LINE; IF(IOS.NE.0)EXIT !## check keyword IF(TRIM(LINE).NE.'')THEN !## periods defined - stop searching for modules/packages IF(TRIM(UTL_CAP(LINE,'U')).EQ.'PERIODS')CYCLE !EXIT !## periods defined - stop searching for modules/packages IF(TRIM(UTL_CAP(LINE,'U')).EQ.'SPECIES')CYCLE !EXIT READ(LINE,*,IOSTAT=IOS) NPER,CTOPIC,IACT IF(IOS.NE.0)THEN; IACT=1; READ(LINE,*,IOSTAT=IOS) NPER,CTOPIC; ENDIF IF(IOS.EQ.0)THEN !## skip empty packages IF(NPER.LE.0)CYCLE I=PMANAGER_FIND_KEYWORD(CTOPIC); IF(I.GT.0)EXIT ENDIF ENDIF ENDDO IF(IOS.NE.0)EXIT !## module with tailor made settings window SELECT CASE (I) CASE (TPST) CALL PMANAGER_LOADPST(IU,NPER,0) TOPICS(I)%IACT_MODEL=IACT; ALLOCATE(TOPICS(I)%STRESS(1)); ALLOCATE(TOPICS(I)%STRESS(1)%FILES(1,1)); TOPICS(I)%STRESS(1)%FILES%FNAME='' CYCLE CASE (TIES) IF(PMANAGER_LOADIES(IU,NPER))THEN TOPICS(I)%IACT_MODEL=IACT; ALLOCATE(TOPICS(I)%STRESS(1)); ALLOCATE(TOPICS(I)%STRESS(1)%FILES(1,1)); TOPICS(I)%STRESS(1)%FILES%FNAME='' CYCLE ELSE CLOSE(IU); RETURN ENDIF CASE (TPCG) TOPICS(I)%IACT_MODEL=IACT; ALLOCATE(TOPICS(I)%STRESS(1)); ALLOCATE(TOPICS(I)%STRESS(1)%FILES(1,1)); TOPICS(I)%STRESS(1)%FILES%FNAME='' IF(.NOT.PMANAGER_LOADPCG(IU))THEN; CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Error reading PCG Section - skipping this part.','Error'); ENDIF CYCLE CASE (TRCT) TOPICS(I)%IACT_MODEL=IACT; ALLOCATE(TOPICS(I)%STRESS(1)); ALLOCATE(TOPICS(I)%STRESS(1)%FILES(1,1)); TOPICS(I)%STRESS(1)%FILES%FNAME='' IF(.NOT.PMANAGER_LOADRCT(IU))THEN; CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Error reading RCT Section - skipping this part.','Error'); ENDIF CYCLE CASE (TGCG) TOPICS(I)%IACT_MODEL=IACT; ALLOCATE(TOPICS(I)%STRESS(1)); ALLOCATE(TOPICS(I)%STRESS(1)%FILES(1,1)); TOPICS(I)%STRESS(1)%FILES%FNAME='' IF(.NOT.PMANAGER_LOADGCG(IU))THEN; CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Error reading GCG Section - skipping this part.','Error'); ENDIF CYCLE CASE (TVDF) TOPICS(I)%IACT_MODEL=IACT; ALLOCATE(TOPICS(I)%STRESS(1)); ALLOCATE(TOPICS(I)%STRESS(1)%FILES(1,1)); TOPICS(I)%STRESS(1)%FILES%FNAME='' IF(.NOT.PMANAGER_LOADVDF(IU))THEN; CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Error reading VDF Section - skipping this part.','Error'); ENDIF CYCLE ! CASE (TFHB) ! WRITE(*,*) END SELECT !## read all other packages ALLOCATE(TOPICS(I)%STRESS(NPER)); TOPICS(I)%IACT_MODEL=IACT !## initiate number of read species per parameter TOPICS(I)%NSPECIES=-1 DO L=1,NPER IF(TOPICS(I)%TIMDEP)THEN READ(IU,'(A512)') LINE READ(LINE,'(I4,5(1X,I2))',IOSTAT=IOS) TOPICS(I)%STRESS(L)%IYR,TOPICS(I)%STRESS(L)%IMH,TOPICS(I)%STRESS(L)%IDY, & TOPICS(I)%STRESS(L)%IHR,TOPICS(I)%STRESS(L)%IMT,TOPICS(I)%STRESS(L)%ISC IF(IOS.NE.0)THEN READ(LINE,*) TOPICS(I)%STRESS(L)%CDATE TOPICS(I)%STRESS(L)%IYR=0; TOPICS(I)%STRESS(L)%IMH=0; TOPICS(I)%STRESS(L)%IDY=0 TOPICS(I)%STRESS(L)%IHR=0; TOPICS(I)%STRESS(L)%IMT=0; TOPICS(I)%STRESS(L)%ISC=0 ENDIF ENDIF READ(IU,*,IOSTAT=IOS) NC,NSYS IF(IOS.NE.0)THEN IF(IBATCH.EQ.0)CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Error reading of parameters for'//CHAR(13)//TRIM(TOPICS(I)%TNAME),'Error') IF(IBATCH.EQ.1)WRITE(*,'(/A/)') 'Error reading parameters for '//TRIM(TOPICS(I)%TNAME)//' stress '//TRIM(VTOS(L))//' "'//TRIM(LINE)//'"' CLOSE(IU); RETURN ENDIF !## check whether number of attributes is similar to the number defined before IF(L.GT.1.AND.NC.NE.TOPICS(I)%NSUBTOPICS)THEN IF(IBATCH.EQ.0)CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Number of attributes is not correct'//CHAR(13)//TRIM(TOPICS(I)%TNAME),'Error') IF(IBATCH.EQ.1)WRITE(*,'(/A/)') 'Number of attributes is not correct '//TRIM(TOPICS(I)%TNAME)//' stress '//TRIM(VTOS(L))//' "'//TRIM(LINE)//'"' CLOSE(IU); RETURN ENDIF ALLOCATE(TOPICS(I)%STRESS(L)%FILES(NC,NSYS)) !## store number of species already present IF(TOPICS(I)%LSPECIES.AND.TOPICS(I)%NSPECIES.EQ.-1)THEN TOPICS(I)%NSPECIES=NC-TOPICS(I)%NSUBTOPICS !## fill in names DO J=1,NSPECIES; TOPICS(I)%SNAME(J+TOPICS(I)%NSUBTOPICS)='Concentration '//TRIM(SPECIES(J)%NAME); ENDDO !## set new number of topics TOPICS(I)%NSUBTOPICS=NC ELSE !## set new number of topics TOPICS(I)%NSUBTOPICS=NC ENDIF DO K=1,TOPICS(I)%NSUBTOPICS DO J=1,NSYS READ(IU,'(A512)',IOSTAT=IOS) LINE IF(IOS.EQ.0)THEN READ(LINE,*,IOSTAT=IOS) TOPICS(I)%STRESS(L)%FILES(K,J)%IACT , & TOPICS(I)%STRESS(L)%FILES(K,J)%ICNST IF(IOS.EQ.0)THEN IF(TOPICS(I)%STRESS(L)%FILES(K,J)%ICNST.EQ.1)THEN READ(LINE,*,IOSTAT=IOS) TOPICS(I)%STRESS(L)%FILES(K,J)%IACT , & TOPICS(I)%STRESS(L)%FILES(K,J)%ICNST, & TOPICS(I)%STRESS(L)%FILES(K,J)%ILAY , & TOPICS(I)%STRESS(L)%FILES(K,J)%FCT , & TOPICS(I)%STRESS(L)%FILES(K,J)%IMP , & TOPICS(I)%STRESS(L)%FILES(K,J)%CNST TOPICS(I)%STRESS(L)%FILES(K,J)%FNAME='' ELSEIF(TOPICS(I)%STRESS(L)%FILES(K,J)%ICNST.EQ.2)THEN READ(LINE,*,IOSTAT=IOS) TOPICS(I)%STRESS(L)%FILES(K,J)%IACT , & TOPICS(I)%STRESS(L)%FILES(K,J)%ICNST, & TOPICS(I)%STRESS(L)%FILES(K,J)%ILAY , & TOPICS(I)%STRESS(L)%FILES(K,J)%FCT , & TOPICS(I)%STRESS(L)%FILES(K,J)%IMP , & TOPICS(I)%STRESS(L)%FILES(K,J)%CNST , & TOPICS(I)%STRESS(L)%FILES(K,J)%FNAME IF(TRIM(PREFVAL(5)).NE.'')THEN CALL UTL_SUBST(TOPICS(I)%STRESS(L)%FILES(K,J)%FNAME,TRIM(REPLACESTRING),PREFVAL(5)) ENDIF TOPICS(I)%STRESS(L)%FILES(K,J)%ALIAS= & UTL_CAP(TRIM(TOPICS(I)%STRESS(L)%FILES(K,J)%FNAME(INDEX(TOPICS(I)%STRESS(L)%FILES(K,J)%FNAME,'\',.TRUE.)+1:)),'L') ELSE CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Incorrect syntax, the CFLAG needs to be 1 or 2.'//CHAR(13)// & 'iMOD reads ['//TRIM(VTOS(TOPICS(I)%STRESS(L)%FILES(K,J)%ICNST))//']','Error') CLOSE(IU); RETURN ENDIF ENDIF ENDIF IF(IOS.NE.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Incorrect number of input fields for'//CHAR(13)//TRIM(TOPICS(I)%TNAME)//CHAR(13)// & 'or syntax error in line'//CHAR(13)//CHAR(13)//TRIM(LINE)//CHAR(13)//CHAR(13)//'Maybe a quote is missing in the filename','Error') CLOSE(IU); RETURN ENDIF ENDDO ENDDO !## extra files (INP) only for MetaSWAP IF(I.EQ.TCAP)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 CLOSE(IU) !## if species defined update relevant packages IF(NSPECIES.GT.0)THEN CALL PMANAGERDEFINESPECIES_UPDATE() ENDIF !## deactivate inactivated packages DO I=1,SIZE(MC) DO J=1,SIZE(MC(I)%IACT) IF(TOPICS(MC(I)%T(J))%IACT_MODEL.EQ.0)MC(I)%IACT(J)=0 ENDDO ENDDO !## make sure the entries are sorted in time DO I=1,MAXTOPICS; CALL PMANAGER_SORTTOPIC(I,1); ENDDO PMANAGER_LOADPRJ=.TRUE. END FUNCTION PMANAGER_LOADPRJ !###====================================================================== SUBROUTINE PMANAGER_DELETE() !###====================================================================== IMPLICIT NONE INTEGER :: ID,ITOPIC,IPER,ISYS,ISUBTOPIC,I,II,J,K,N,M CHARACTER(LEN=256) :: CNAME,STRING CHARACTER(LEN=4) :: EXT CALL WDIALOGSELECT(ID_DPMANAGER_TAB1); 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 PMANAGER_UTL_UPDATE_TREEVIEW(0,0,0) ELSEIF(IPER.NE.0.AND.ISYS.NE.0.AND.ISUBTOPIC.NE.0)THEN STRING='ilay='//TRIM(VTOS(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ILAY)) STRING=TRIM(STRING)//CHAR(13)//'fct='//TRIM(VTOS(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%FCT,'*',3)) STRING=TRIM(STRING)//CHAR(13)//'imp='//TRIM(VTOS(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(VTOS(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%CNST,'*',3)) !## filename ELSEIF(TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ICNST.EQ.2)THEN CNAME=TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ALIAS EXT=CNAME(INDEX(CNAME,'.',.TRUE.)+1:) STRING=TRIM(STRING)//CHAR(13)//TRIM(EXT)//'='//TRIM(CNAME) !TOPICS(ITOPIC)%STRESS(IPER)%FILES(ISUBTOPIC,ISYS)%ALIAS) ENDIF CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Are you sure to remove the selected entry:'//CHAR(13)//TRIM(STRING),'Question') IF(WINFODIALOG(4).NE.1)RETURN !## file selected, selected system will be deleted, thus conductance removes stage,bottom and inffactor as well. !## delete selected file and decrease size of files(). N=SIZE(TOPICS(ITOPIC)%STRESS(IPER)%FILES,1) !## number of subtopics M=SIZE(TOPICS(ITOPIC)%STRESS(IPER)%FILES,2) !## number of systems IF(M.GT.1)THEN ALLOCATE(TOPICS(ITOPIC)%STRESS(IPER)%FILES_TMP(N,M-1)) !## decrease size of the systems DO I=1,N; K=0; DO J=1,M IF(J.NE.ISYS)THEN K=K+1 TOPICS(ITOPIC)%STRESS(IPER)%FILES_TMP(I,K)=TOPICS(ITOPIC)%STRESS(IPER)%FILES(I,J) ENDIF ENDDO; ENDDO DEALLOCATE(TOPICS(ITOPIC)%STRESS(IPER)%FILES) TOPICS(ITOPIC)%STRESS(IPER)%FILES=>TOPICS(ITOPIC)%STRESS(IPER)%FILES_TMP ELSE !## remove current date - nothing left IF(TOPICS(ITOPIC)%TIMDEP)THEN !## make copy of current memory N=SIZE(TOPICS(ITOPIC)%STRESS) NULLIFY(TOPICS(ITOPIC)%STRESS_TMP) ALLOCATE(TOPICS(ITOPIC)%STRESS_TMP(N-1)) II=0; DO I=1,N IF(I.EQ.IPER)CYCLE II=II+1 J=SIZE(TOPICS(ITOPIC)%STRESS(I)%FILES,1) K=SIZE(TOPICS(ITOPIC)%STRESS(I)%FILES,2) NULLIFY(TOPICS(ITOPIC)%STRESS_TMP(II)%FILES) NULLIFY(TOPICS(ITOPIC)%STRESS_TMP(II)%INPFILES) ALLOCATE(TOPICS(ITOPIC)%STRESS_TMP(II)%FILES(J,K)); TOPICS(ITOPIC)%STRESS_TMP(II)%FILES%FNAME='' TOPICS(ITOPIC)%STRESS_TMP(II)%FILES=TOPICS(ITOPIC)%STRESS(I)%FILES TOPICS(ITOPIC)%STRESS_TMP(II)%CDATE=TOPICS(ITOPIC)%STRESS(I)%CDATE TOPICS(ITOPIC)%STRESS_TMP(II)%IYR=TOPICS(ITOPIC)%STRESS(I)%IYR TOPICS(ITOPIC)%STRESS_TMP(II)%IMH=TOPICS(ITOPIC)%STRESS(I)%IMH TOPICS(ITOPIC)%STRESS_TMP(II)%IDY=TOPICS(ITOPIC)%STRESS(I)%IDY TOPICS(ITOPIC)%STRESS_TMP(II)%IHR=TOPICS(ITOPIC)%STRESS(I)%IHR TOPICS(ITOPIC)%STRESS_TMP(II)%IMT=TOPICS(ITOPIC)%STRESS(I)%IMT TOPICS(ITOPIC)%STRESS_TMP(II)%ISC=TOPICS(ITOPIC)%STRESS(I)%ISC DEALLOCATE(TOPICS(ITOPIC)%STRESS(I)%FILES) ENDDO TOPICS(ITOPIC)%STRESS=>TOPICS(ITOPIC)%STRESS_TMP ELSE DEALLOCATE(TOPICS(ITOPIC)%STRESS(1)%FILES) DEALLOCATE(TOPICS(ITOPIC)%STRESS) TOPICS(ITOPIC)%IACT_MODEL=0 ENDIF ENDIF !## if pest associated, remove number of pest parameters IF(ITOPIC.EQ.TPST)CALL PMANAGER_DEALLOCATE_PEST() ! !## if pest associated, remove number of pest parameters ! IF(ITOPIC.EQ.TIES)CALL PMANAGER_DEALLOCATE_IES() !## update the project manager for changes - on topic level, other is not possible CALL PMANAGER_UTL_UPDATE_TREEVIEW(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%FNAME='' TOPICS(ITOPIC)%STRESS_TMP(M)%FILES=TOPICS(ITOPIC)%STRESS(I)%FILES TOPICS(ITOPIC)%STRESS_TMP(M)%CDATE=TOPICS(ITOPIC)%STRESS(I)%CDATE TOPICS(ITOPIC)%STRESS_TMP(M)%IYR=TOPICS(ITOPIC)%STRESS(I)%IYR TOPICS(ITOPIC)%STRESS_TMP(M)%IMH=TOPICS(ITOPIC)%STRESS(I)%IMH TOPICS(ITOPIC)%STRESS_TMP(M)%IDY=TOPICS(ITOPIC)%STRESS(I)%IDY TOPICS(ITOPIC)%STRESS_TMP(M)%IHR=TOPICS(ITOPIC)%STRESS(I)%IHR TOPICS(ITOPIC)%STRESS_TMP(M)%IMT=TOPICS(ITOPIC)%STRESS(I)%IMT TOPICS(ITOPIC)%STRESS_TMP(M)%ISC=TOPICS(ITOPIC)%STRESS(I)%ISC DEALLOCATE(TOPICS(ITOPIC)%STRESS(I)%FILES) ENDDO TOPICS(ITOPIC)%STRESS=>TOPICS(ITOPIC)%STRESS_TMP ELSE DEALLOCATE(TOPICS(ITOPIC)%STRESS(IPER)%FILES) DEALLOCATE(TOPICS(ITOPIC)%STRESS) ENDIF CALL PMANAGER_UTL_UPDATE_TREEVIEW(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 PMANAGER_DELETE !###====================================================================== SUBROUTINE PMANAGER_CALC() !###====================================================================== IMPLICIT NONE TYPE(WIN_MESSAGE) :: MESSAGE INTEGER :: ITYPE,IWINDOW,IL1,IL2 CALL WDIALOGLOAD(ID_DPMANAGER_CALC,ID_DPMANAGER_CALC) !## define number of modellayers CALL PMANAGER_GETNFILES((/TTOP,TBOT,TBND,TSHD,TKDW,TKHV,TKVA,TVCW,TKVV,TSTO,TSPY/),PRJMXNLAY) CALL WDIALOGPUTINTEGER(IDF_INTEGER1,1) CALL WDIALOGPUTINTEGER(IDF_INTEGER2,PRJMXNLAY) CALL UTL_DIALOGSHOW(-1,-1,0,3) DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE(FIELDCHANGED) SELECT CASE (MESSAGE%VALUE2) END SELECT SELECT CASE (MESSAGE%VALUE1) END SELECT CASE(PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (IDOK,IDCANCEL); EXIT END SELECT END SELECT ENDDO CALL WDIALOGGETMENU(IDF_MENU1,ITYPE) CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,IWINDOW) CALL WDIALOGGETINTEGER(IDF_INTEGER1,IL1) CALL WDIALOGGETINTEGER(IDF_INTEGER2,IL2) CALL WDIALOGUNLOAD() IF(MESSAGE%VALUE1.EQ.IDOK)THEN CALL UTL_MESSAGEHANDLE(0) IF(PMANAGER_CALC_INIT(IWINDOW,ITYPE,IL1,IL2))THEN CALL PMANAGER_CALC_READ(ITYPE,IL1,IL2) CALL PMANAGER_CALC_PROCESS(ITYPE,IL1,IL2) CALL PMANAGER_CALC_SAVE(ITYPE,IL1,IL2) ENDIF CALL PMANAGER_SAVEMF2005_DEALLOCATE() CALL UTL_MESSAGEHANDLE(1) ENDIF CALL WDIALOGSELECT(ID_DPMANAGER) END SUBROUTINE PMANAGER_CALC !###====================================================================== LOGICAL FUNCTION PMANAGER_CALC_INIT(IWINDOW,ITYPE,IL1,IL2) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: IWINDOW,ITYPE,IL1,IL2 INTEGER :: ILAY PMANAGER_CALC_INIT=.FALSE. !## read idf for dimensions CALL IDFNULLIFY(PRJIDF) IF(.NOT.PMANAGER_INIT_SIMAREA(PRJIDF,0))RETURN IF(IWINDOW.EQ.2)THEN !## make sure size of model (including buffer) does not exceed total model domain SUBMODEL(1)=MAX(MPW%XMIN,PRJIDF%XMIN); SUBMODEL(2)=MAX(MPW%YMIN,PRJIDF%YMIN) SUBMODEL(3)=MIN(MPW%XMAX,PRJIDF%XMAX); SUBMODEL(4)=MIN(MPW%YMAX,PRJIDF%YMAX) !## compute dimensions of submodel CALL UTL_IDFSNAPTOGRID(SUBMODEL(1),SUBMODEL(3),SUBMODEL(2),SUBMODEL(4),SUBMODEL(5),PRJIDF%NCOL,PRJIDF%NROW) PRJIDF%XMIN=SUBMODEL(1); PRJIDF%YMIN=SUBMODEL(2); PRJIDF%XMAX=SUBMODEL(3); PRJIDF%YMAX=SUBMODEL(4) PRJIDF%DX=SUBMODEL(5); PRJIDF%DY=SUBMODEL(5); PRJIDF%IEQ=0 ENDIF IF(.NOT.IDFALLOCATEX(PRJIDF))RETURN; PRJIDF%X=0.0D0 !## fill sx/sy variable in idf IF(.NOT.IDFFILLSXSY(PRJIDF))RETURN SELECT CASE (ITYPE) !## transmissivities CASE (1,7) ALLOCATE(TOP(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(TOP(ILAY)); ENDDO ALLOCATE(BOT(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(BOT(ILAY)); ENDDO ALLOCATE(KHV(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(KHV(ILAY)); ENDDO ALLOCATE(KDW(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(KDW(ILAY)); ENDDO !## vertical resistance aquifer CASE (2) ALLOCATE(TOP(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(TOP(ILAY)); ENDDO ALLOCATE(BOT(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(BOT(ILAY)); ENDDO ALLOCATE(KHV(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(KHV(ILAY)); ENDDO ALLOCATE(KVA(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(KVA(ILAY)); ENDDO ALLOCATE(VCW(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(VCW(ILAY)); ENDDO !## vertical resistance aquitard CASE (3,8) ALLOCATE(TOP(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(TOP(ILAY)); ENDDO ALLOCATE(BOT(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(BOT(ILAY)); ENDDO ALLOCATE(KVV(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(KVV(ILAY)); ENDDO ALLOCATE(VCW(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(VCW(ILAY)); ENDDO !## total vertical resistance CASE (4) ALLOCATE(TOP(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(TOP(ILAY)); ENDDO ALLOCATE(BOT(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(BOT(ILAY)); ENDDO ALLOCATE(KHV(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(KHV(ILAY)); ENDDO ALLOCATE(KVA(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(KVA(ILAY)); ENDDO ALLOCATE(KVV(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(KVV(ILAY)); ENDDO ALLOCATE(VCW(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(VCW(ILAY)); ENDDO !## thickness aquifer CASE (5) ALLOCATE(TOP(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(TOP(ILAY)); ENDDO ALLOCATE(BOT(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(BOT(ILAY)); ENDDO ALLOCATE(KDW(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(KDW(ILAY)); ENDDO !## thickness aquitard CASE (6) ALLOCATE(TOP(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(TOP(ILAY)); ENDDO ALLOCATE(BOT(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(BOT(ILAY)); ENDDO ALLOCATE(VCW(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(VCW(ILAY)); ENDDO !## characteristic length CASE (9) ALLOCATE(TOP(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(TOP(ILAY)); ENDDO ALLOCATE(BOT(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(BOT(ILAY)); ENDDO ALLOCATE(KHV(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(KHV(ILAY)); ENDDO ALLOCATE(KVA(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(KVA(ILAY)); ENDDO ALLOCATE(KDW(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(KDW(ILAY)); ENDDO ALLOCATE(KVV(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(KVV(ILAY)); ENDDO ALLOCATE(VCW(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(VCW(ILAY)); ENDDO !## characteristic length CASE (10) ALLOCATE(KDW(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(KDW(ILAY)); ENDDO ALLOCATE(VCW(IL1:IL2)); DO ILAY=IL1,IL2; CALL IDFNULLIFY(VCW(ILAY)); ENDDO END SELECT ! IF(ISS.EQ.1)THEN ! ALLOCATE(STO(NLAY)); DO ILAY=1,SIZE(STO); CALL IDFNULLIFY(STO(ILAY)); ENDDO ! ALLOCATE(SPY(NLAY)); DO ILAY=1,SIZE(SPY); CALL IDFNULLIFY(SPY(ILAY)); ENDDO ! ENDIF ! IF(LLPF)THEN ! ALLOCATE(KVV(NLAY-1)); DO ILAY=1,SIZE(KVV); CALL IDFNULLIFY(KVV(ILAY)); ENDDO ! ALLOCATE(KVA(NLAY)); DO ILAY=1,SIZE(KVA); CALL IDFNULLIFY(KVA(ILAY)); ENDDO ! ENDIF IF(ALLOCATED(TOP))THEN; DO ILAY=IL1,IL2; CALL IDFCOPY(PRJIDF,TOP(ILAY)); ENDDO; ENDIF IF(ALLOCATED(BOT))THEN; DO ILAY=IL1,IL2; CALL IDFCOPY(PRJIDF,BOT(ILAY)); ENDDO; ENDIF IF(ALLOCATED(KDW))THEN; DO ILAY=IL1,IL2; CALL IDFCOPY(PRJIDF,KDW(ILAY)); ENDDO; ENDIF IF(ALLOCATED(VCW))THEN; DO ILAY=IL1,IL2; CALL IDFCOPY(PRJIDF,VCW(ILAY)); ENDDO; ENDIF IF(ALLOCATED(KHV))THEN; DO ILAY=IL1,IL2; CALL IDFCOPY(PRJIDF,KHV(ILAY)); ENDDO; ENDIF IF(ALLOCATED(KVV))THEN; DO ILAY=IL1,IL2; CALL IDFCOPY(PRJIDF,KVV(ILAY)); ENDDO; ENDIF IF(ALLOCATED(KVA))THEN; DO ILAY=IL1,IL2; CALL IDFCOPY(PRJIDF,KVA(ILAY)); ENDDO; ENDIF PMANAGER_CALC_INIT=.TRUE. END FUNCTION PMANAGER_CALC_INIT !###====================================================================== SUBROUTINE PMANAGER_CALC_READ(ITYPE,IL1,IL2) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: IL1,IL2,ITYPE INTEGER :: SCL_D,SCL_U,ILAY,ITOPIC,IINV,IPRT LOGICAL :: LEX ALLOCATE(FNAMES(1),PRJILIST(1)) IPRT=0 !## read files DO ILAY=IL1,IL2 !## top/bot data SELECT CASE (ITYPE) CASE (1,2,3,4,5,6,7,8,9) SCL_D=1; SCL_U=2; ITOPIC=TTOP; LEX=.FALSE.; IINV=0 IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))THEN PRJILIST=ITOPIC; IF(PMANAGER_GETFNAMES(ILAY,ILAY,0,1,0).LE.0)RETURN CALL WINDOWOUTSTATUSBAR(4,'Reading '//TRIM(FNAMES(1)%FNAME)//' ...') IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(TOP(ILAY),ITOPIC,1,SCL_D,SCL_U,IINV,IPRT))RETURN LEX=.TRUE. ENDIF ENDIF IF(.NOT.LEX)THEN ENDIF SCL_D=1; SCL_U=2; ITOPIC=TBOT; LEX=.FALSE.; IINV=0 IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))THEN PRJILIST=ITOPIC; IF(PMANAGER_GETFNAMES(ILAY,ILAY,0,1,0).LE.0)RETURN CALL WINDOWOUTSTATUSBAR(4,'Reading '//TRIM(FNAMES(1)%FNAME)//' ...') IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(BOT(ILAY),ITOPIC,1,SCL_D,SCL_U,IINV,IPRT))RETURN LEX=.TRUE. ENDIF ENDIF IF(.NOT.LEX)THEN ENDIF END SELECT !## khv/kdw data SELECT CASE (ITYPE) CASE (1,2,4,9) ITOPIC=TKHV; SCL_D=1; SCL_U=3; LEX=.FALSE.; IINV=0 IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))THEN PRJILIST=ITOPIC; IF(PMANAGER_GETFNAMES(ILAY,ILAY,0,1,0).LE.0)RETURN CALL WINDOWOUTSTATUSBAR(4,'Reading '//TRIM(FNAMES(1)%FNAME)//' ...') IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(KHV(ILAY),ITOPIC,1,SCL_D,SCL_U,IINV,IPRT))RETURN LEX=.TRUE. ENDIF ENDIF IF(.NOT.LEX)THEN ENDIF CASE (7,10) ITOPIC=TKDW; SCL_D=1; SCL_U=3; LEX=.FALSE.; IINV=0 IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))THEN PRJILIST=ITOPIC; IF(PMANAGER_GETFNAMES(ILAY,ILAY,0,1,0).LE.0)RETURN CALL WINDOWOUTSTATUSBAR(4,'Reading '//TRIM(FNAMES(1)%FNAME)//' ...') IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(KDW(ILAY),ITOPIC,1,SCL_D,SCL_U,IINV,IPRT))RETURN LEX=.TRUE. ENDIF ENDIF IF(.NOT.LEX)THEN ENDIF END SELECT !## kva data SELECT CASE (ITYPE) CASE (2,4,9) ITOPIC=TKVA; SCL_D=1; SCL_U=2; LEX=.FALSE.; IINV=1 IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))THEN PRJILIST=ITOPIC; IF(PMANAGER_GETFNAMES(ILAY,ILAY,0,1,0).LE.0)RETURN CALL WINDOWOUTSTATUSBAR(4,'Reading '//TRIM(FNAMES(1)%FNAME)//' ...') IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(KVA(ILAY),ITOPIC,1,SCL_D,SCL_U,IINV,IPRT))RETURN LEX=.TRUE. ENDIF ENDIF IF(.NOT.LEX)THEN ENDIF END SELECT !## kvv data SELECT CASE (ITYPE) CASE (3,4,9) IF(ILAY.LT.PRJMXNLAY)THEN ITOPIC=TKVV; SCL_D=1; SCL_U=3; LEX=.FALSE.; IINV=0 IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))THEN PRJILIST=ITOPIC; IF(PMANAGER_GETFNAMES(ILAY,ILAY,0,1,0).LE.0)RETURN CALL WINDOWOUTSTATUSBAR(4,'Reading '//TRIM(FNAMES(1)%FNAME)//' ...') IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(KVV(ILAY),ITOPIC,1,SCL_D,SCL_U,IINV,IPRT))RETURN LEX=.TRUE. ENDIF ENDIF IF(.NOT.LEX)THEN ENDIF ENDIF CASE (8,10) IF(ILAY.LT.PRJMXNLAY)THEN ITOPIC=TVCW; SCL_D=1; SCL_U=6; LEX=.FALSE.; IINV=0 IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS))THEN IF(ASSOCIATED(TOPICS(ITOPIC)%STRESS(1)%FILES))THEN PRJILIST=ITOPIC; IF(PMANAGER_GETFNAMES(ILAY,ILAY,0,1,0).LE.0)RETURN CALL WINDOWOUTSTATUSBAR(4,'Reading '//TRIM(FNAMES(1)%FNAME)//' ...') IF(.NOT.PMANAGER_SAVEMF2005_MOD_READ(VCW(ILAY),ITOPIC,1,SCL_D,SCL_U,IINV,IPRT))RETURN LEX=.TRUE. ENDIF ENDIF IF(.NOT.LEX)THEN ENDIF ENDIF END SELECT ENDDO DEALLOCATE(FNAMES,PRJILIST) END SUBROUTINE PMANAGER_CALC_READ !###====================================================================== SUBROUTINE PMANAGER_CALC_PROCESS(ITYPE,IL1,IL2) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: IL1,IL2,ITYPE INTEGER :: IROW,ICOL,ILAY REAL(KIND=DP_KIND) :: T1,T2,K1,K2,C1,C2,C3 !## read files DO ILAY=IL1,IL2 SELECT CASE (ITYPE) !## transmissivity CASE (1,9) DO IROW=1,TOP(IL1)%NROW; DO ICOL=1,TOP(IL1)%NCOL IF(TOP(ILAY)%X(ICOL,IROW).NE.TOP(ILAY)%NODATA.AND. & BOT(ILAY)%X(ICOL,IROW).NE.BOT(ILAY)%NODATA.AND. & KHV(ILAY)%X(ICOL,IROW).NE.KHV(ILAY)%NODATA)THEN KDW(ILAY)%X(ICOL,IROW)=KHV(ILAY)%X(ICOL,IROW)*(TOP(ILAY)%X(ICOL,IROW)-BOT(ILAY)%X(ICOL,IROW)) ELSE KDW(ILAY)%X(ICOL,IROW)=KDW(ILAY)%NODATA ENDIF ENDDO; ENDDO !## vertical resistance aquifer CASE (2) DO IROW=1,TOP(IL1)%NROW; DO ICOL=1,TOP(IL1)%NCOL IF(TOP(ILAY )%X(ICOL,IROW).NE.TOP(ILAY )%NODATA.AND. & BOT(ILAY )%X(ICOL,IROW).NE.BOT(ILAY )%NODATA.AND. & KVA(ILAY )%X(ICOL,IROW).NE.KVA(ILAY )%NODATA.AND. & KHV(ILAY )%X(ICOL,IROW).NE.KHV(ILAY )%NODATA)THEN T1=TOP(ILAY )%X(ICOL,IROW)-BOT(ILAY )%X(ICOL,IROW) K1=KHV(ILAY )%X(ICOL,IROW)/KVA(ILAY )%X(ICOL,IROW) C1=0.0D0; IF(K1.GT.0.0D0)C1=T1/K1 VCW(ILAY)%X(ICOL,IROW)=C1 ELSE VCW(ILAY)%X(ICOL,IROW)=VCW(ILAY)%NODATA ENDIF ENDDO; ENDDO !## vertical resistance aquitard CASE (3) IF(ILAY.LT.IL2)THEN DO IROW=1,TOP(IL1)%NROW; DO ICOL=1,TOP(IL1)%NCOL IF(BOT(ILAY )%X(ICOL,IROW).NE.BOT(ILAY )%NODATA.AND. & TOP(ILAY+1)%X(ICOL,IROW).NE.TOP(ILAY+1)%NODATA.AND. & KVV(ILAY )%X(ICOL,IROW).NE.KVV(ILAY )%NODATA)THEN IF(KVV(ILAY)%X(ICOL,IROW).GT.0.0D0)THEN VCW(ILAY)%X(ICOL,IROW)=(BOT(ILAY)%X(ICOL,IROW)-TOP(ILAY+1)%X(ICOL,IROW))/KVV(ILAY)%X(ICOL,IROW) ELSE VCW(ILAY)%X(ICOL,IROW)=0.0D0 ENDIF ELSE VCW(ILAY)%X(ICOL,IROW)=VCW(ILAY)%NODATA ENDIF ENDDO; ENDDO ENDIF END SELECT SELECT CASE (ITYPE) !## total vertical resistance CASE (4,9) IF(ILAY.LT.IL2)THEN DO IROW=1,TOP(IL1)%NROW; DO ICOL=1,TOP(IL1)%NCOL IF(TOP(ILAY )%X(ICOL,IROW).NE.TOP(ILAY )%NODATA.AND. & BOT(ILAY )%X(ICOL,IROW).NE.BOT(ILAY )%NODATA.AND. & TOP(ILAY+1)%X(ICOL,IROW).NE.TOP(ILAY+1)%NODATA.AND. & BOT(ILAY+1)%X(ICOL,IROW).NE.BOT(ILAY+1)%NODATA.AND. & KHV(ILAY )%X(ICOL,IROW).NE.KHV(ILAY )%NODATA.AND. & KHV(ILAY+1)%X(ICOL,IROW).NE.KHV(ILAY+1)%NODATA.AND. & KVA(ILAY )%X(ICOL,IROW).NE.KVA(ILAY )%NODATA.AND. & KVA(ILAY+1)%X(ICOL,IROW).NE.KVA(ILAY+1)%NODATA.AND. & KVV(ILAY )%X(ICOL,IROW).NE.KVV(ILAY )%NODATA)THEN T1=TOP(ILAY )%X(ICOL,IROW)-BOT(ILAY )%X(ICOL,IROW) T2=TOP(ILAY+1)%X(ICOL,IROW)-BOT(ILAY+1)%X(ICOL,IROW) K1=KHV(ILAY )%X(ICOL,IROW)/KVA(ILAY )%X(ICOL,IROW) K2=KHV(ILAY+1)%X(ICOL,IROW)/KVA(ILAY+1)%X(ICOL,IROW) C1=0.0D0; IF(K1.GT.0.0D0)C1=0.5D0*T1/K1 C2=0.0D0; IF(K2.GT.0.0D0)C2=0.5D0*T2/K2 C3=0.0D0; IF(KVV(ILAY)%X(ICOL,IROW).GT.0.0D0)C3=(BOT(ILAY)%X(ICOL,IROW)-TOP(ILAY+1)%X(ICOL,IROW))/KVV(ILAY)%X(ICOL,IROW) VCW(ILAY)%X(ICOL,IROW)=C1+C2+C3 ELSE VCW(ILAY)%X(ICOL,IROW)=VCW(ILAY)%NODATA ENDIF ENDDO; ENDDO ENDIF !## thickness of aquifer CASE (5) DO IROW=1,TOP(IL1)%NROW; DO ICOL=1,TOP(IL1)%NCOL IF(TOP(ILAY)%X(ICOL,IROW).NE.TOP(ILAY)%NODATA.AND. & BOT(ILAY)%X(ICOL,IROW).NE.BOT(ILAY)%NODATA)THEN KDW(ILAY)%X(ICOL,IROW)=TOP(ILAY)%X(ICOL,IROW)-BOT(ILAY)%X(ICOL,IROW) ELSE KDW(ILAY)%X(ICOL,IROW)=KDW(ILAY)%NODATA ENDIF ENDDO; ENDDO !## thickness of aquitard CASE (6) IF(ILAY.LT.IL2)THEN DO IROW=1,TOP(IL1)%NROW; DO ICOL=1,TOP(IL1)%NCOL IF(BOT(ILAY )%X(ICOL,IROW).NE.BOT(ILAY )%NODATA.AND. & TOP(ILAY+1)%X(ICOL,IROW).NE.TOP(ILAY+1)%NODATA)THEN VCW(ILAY)%X(ICOL,IROW)=BOT(ILAY)%X(ICOL,IROW)-TOP(ILAY+1)%X(ICOL,IROW) ELSE VCW(ILAY)%X(ICOL,IROW)=VCW(ILAY)%NODATA ENDIF ENDDO; ENDDO ENDIF !## permeability CASE (7) DO IROW=1,TOP(IL1)%NROW; DO ICOL=1,TOP(IL1)%NCOL IF(TOP(ILAY)%X(ICOL,IROW).NE.TOP(ILAY)%NODATA.AND. & BOT(ILAY)%X(ICOL,IROW).NE.BOT(ILAY)%NODATA.AND. & KDW(ILAY)%X(ICOL,IROW).NE.KDW(ILAY)%NODATA)THEN IF(TOP(ILAY)%X(ICOL,IROW)-BOT(ILAY)%X(ICOL,IROW).GT.0.0D0)THEN KHV(ILAY)%X(ICOL,IROW)=KDW(ILAY)%X(ICOL,IROW)/(TOP(ILAY)%X(ICOL,IROW)-BOT(ILAY)%X(ICOL,IROW)) ELSE KHV(ILAY)%X(ICOL,IROW)=0.0D0 ENDIF ELSE KHV(ILAY)%X(ICOL,IROW)=KHV(ILAY)%NODATA ENDIF ENDDO; ENDDO !## vertical permeability CASE (8) IF(ILAY.LT.IL2)THEN DO IROW=1,TOP(IL1)%NROW; DO ICOL=1,TOP(IL1)%NCOL IF(BOT(ILAY )%X(ICOL,IROW).NE.BOT(ILAY )%NODATA.AND. & TOP(ILAY+1)%X(ICOL,IROW).NE.TOP(ILAY+1)%NODATA.AND. & VCW(ILAY )%X(ICOL,IROW).NE.VCW(ILAY )%NODATA)THEN IF(VCW(ILAY)%X(ICOL,IROW).GT.0.0D0)THEN KVV(ILAY)%X(ICOL,IROW)=(BOT(ILAY)%X(ICOL,IROW)-TOP(ILAY+1)%X(ICOL,IROW))/VCW(ILAY)%X(ICOL,IROW) ELSE KVV(ILAY)%X(ICOL,IROW)=0.0D0 ENDIF ELSE KVV(ILAY)%X(ICOL,IROW)=KVV(ILAY)%NODATA ENDIF ENDDO; ENDDO ENDIF END SELECT ENDDO SELECT CASE (ITYPE) CASE (9,10) DO IROW=1,KDW(IL1)%NROW; DO ICOL=1,KDW(IL1)%NCOL C1=0.0D0; C2=0.0D0 DO ILAY=IL1,IL2 IF(KDW(ILAY)%X(ICOL,IROW).NE.KDW(ILAY)%NODATA)THEN C1=C1+KDW(ILAY)%X(ICOL,IROW) IF(ILAY.LT.IL2)THEN IF(VCW(ILAY)%X(ICOL,IROW).NE.VCW(ILAY)%NODATA)C2=C2+VCW(ILAY)%X(ICOL,IROW) ENDIF ENDIF ENDDO KDW(IL1)%X(ICOL,IROW)=SQRT(C1*C2) ENDDO; ENDDO END SELECT END SUBROUTINE PMANAGER_CALC_PROCESS !###====================================================================== SUBROUTINE PMANAGER_CALC_SAVE(ITYPE,IL1,IL2) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: IL1,IL2,ITYPE INTEGER :: ILAY !## read files DO ILAY=IL1,IL2 SELECT CASE (ITYPE) CASE (1) KDW(ILAY)%FNAME=TRIM(PREFVAL(1))//'\TMP\KDW_L'//TRIM(VTOS(ILAY))//'.IDF' CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(KDW(ILAY)%FNAME)//' ...') IF(.NOT.IDFWRITE(KDW(ILAY),KDW(ILAY)%FNAME,1))RETURN CASE (2) VCW(ILAY)%FNAME=TRIM(PREFVAL(1))//'\TMP\VCW_AQF_L'//TRIM(VTOS(ILAY))//'.IDF' CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(VCW(ILAY)%FNAME)//' ...') IF(.NOT.IDFWRITE(VCW(ILAY),VCW(ILAY)%FNAME,1))RETURN CASE (3) IF(ILAY.LT.IL2)THEN VCW(ILAY)%FNAME=TRIM(PREFVAL(1))//'\TMP\VCW_AQT_L'//TRIM(VTOS(ILAY))//'.IDF' CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(VCW(ILAY)%FNAME)//' ...') IF(.NOT.IDFWRITE(VCW(ILAY),VCW(ILAY)%FNAME,1))RETURN ENDIF CASE (4) IF(ILAY.LT.IL2)THEN VCW(ILAY)%FNAME=TRIM(PREFVAL(1))//'\TMP\VCW_MDL_L'//TRIM(VTOS(ILAY))//'.IDF' CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(VCW(ILAY)%FNAME)//' ...') IF(.NOT.IDFWRITE(VCW(ILAY),VCW(ILAY)%FNAME,1))RETURN ENDIF CASE (5) KDW(ILAY)%FNAME=TRIM(PREFVAL(1))//'\TMP\THK_AQF_L'//TRIM(VTOS(ILAY))//'.IDF' CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(KDW(ILAY)%FNAME)//' ...') IF(.NOT.IDFWRITE(KDW(ILAY),KDW(ILAY)%FNAME,1))RETURN CASE (6) IF(ILAY.LT.IL2)THEN VCW(ILAY)%FNAME=TRIM(PREFVAL(1))//'\TMP\THK_AQT_L'//TRIM(VTOS(ILAY))//'.IDF' CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(VCW(ILAY)%FNAME)//' ...') IF(.NOT.IDFWRITE(VCW(ILAY),VCW(ILAY)%FNAME,1))RETURN ENDIF CASE (7) KHV(ILAY)%FNAME=TRIM(PREFVAL(1))//'\TMP\KHV_L'//TRIM(VTOS(ILAY))//'.IDF' CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(KHV(ILAY)%FNAME)//' ...') IF(.NOT.IDFWRITE(KHV(ILAY),KHV(ILAY)%FNAME,1))RETURN CASE (8) IF(ILAY.LT.PRJMXNLAY)THEN KVV(ILAY)%FNAME=TRIM(PREFVAL(1))//'\TMP\KVV_L'//TRIM(VTOS(ILAY))//'.IDF' CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(KVV(ILAY)%FNAME)//' ...') IF(.NOT.IDFWRITE(KVV(ILAY),KVV(ILAY)%FNAME,1))RETURN ENDIF CASE (9,10) KDW(ILAY)%FNAME=TRIM(PREFVAL(1))//'\TMP\LAMBDA_L'//TRIM(VTOS(IL1))//'_L'//TRIM(VTOS(IL2))//'.IDF' CALL WINDOWOUTSTATUSBAR(4,'Writing '//TRIM(KDW(ILAY)%FNAME)//' ...') IF(.NOT.IDFWRITE(KDW(ILAY),KDW(ILAY)%FNAME,1))RETURN EXIT END SELECT ENDDO !## read files DO ILAY=IL1,IL2 SELECT CASE (ITYPE) CASE (1,5) CALL MANAGER_UTL_ADDFILE(KDW(ILAY)%FNAME) CASE (2) CALL MANAGER_UTL_ADDFILE(VCW(ILAY)%FNAME) CASE (3,4,6) IF(ILAY.LT.IL2)CALL MANAGER_UTL_ADDFILE(VCW(ILAY)%FNAME) CASE (7) CALL MANAGER_UTL_ADDFILE(KHV(ILAY)%FNAME) CASE (8) IF(ILAY.LT.IL2)CALL MANAGER_UTL_ADDFILE(KVV(ILAY)%FNAME) CASE (9,10) CALL MANAGER_UTL_ADDFILE(KDW(ILAY)%FNAME); EXIT END SELECT ENDDO CALL WINDOWOUTSTATUSBAR(4,'') END SUBROUTINE PMANAGER_CALC_SAVE !###====================================================================== SUBROUTINE PMANAGERFIELDS() !###====================================================================== IMPLICIT NONE INTEGER :: I,ID CALL WDIALOGSELECT(ID_DPMANAGER_TAB1) CALL WDIALOGUNDEFINED(IVALUE=-1); CALL UTL_DEBUGLEVEL(0) CALL WDIALOGGETTREEVIEW(ID_TREEVIEW1,ID); CALL UTL_DEBUGLEVEL(1) !## nothing selected IF(ID.EQ.-1)ID=0; ID=MAX(ID,0); I=1; IF(ID.EQ.0)I=0 CALL WDIALOGFIELDSTATE(ID_DRAW,I) CALL WDIALOGFIELDSTATE(ID_PROPERTIES,I) CALL WDIALOGFIELDSTATE(ID_PROPERTIES_AUTO,I) END SUBROUTINE PMANAGERFIELDS !###====================================================================== SUBROUTINE PMANAGER_UTL_UPDATE_TREEVIEW(IDITOPIC,IDIPER,IDISUBS) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: IDITOPIC,IDIPER,IDISUBS INTEGER :: IPER,I,II,J,K,N,IDTOPIC,IDSUBTC,IFILES,NF,MF,JD,IMF CHARACTER(LEN=256) :: STRING,CNAME,XSTRING CHARACTER(LEN=4) :: EXT I=INFOERROR(1) JD=0 CALL PMANAGER_ALLOCATE() !## get model configuration CALL WDIALOGSELECT(ID_DPMANAGER_TAB2); CALL WDIALOGGETMENU(IDF_MENU1,IMF) I=SIZE(MC(IMF)%IACT); CALL WGRIDGETCHECKBOX(IDF_GRID1,2,MC(IMF)%IACT,I) CALL WDIALOGGETMENUSTRING(IDF_MENU1,IMF,STRING) CALL WDIALOGSELECT(ID_DPMANAGER_TAB1); CALL WDIALOGCLEARFIELD(ID_TREEVIEW1) CALL WDIALOGTREEVIEWCHECK(0) CALL WDIALOGTITLE('TreeView '//TRIM(MC(IMF)%MCNAME)) IDTOPIC=1000-1; IDSUBTC=2000-1; TOPICS%ID=0 II=0; IFILES=0; DO I=1,SIZE(TOPICS) IF(IMF.GT.0)THEN DO J=1,SIZE(MC(IMF)%T); IF(MC(IMF)%T(J).EQ.I.AND.MC(IMF)%IACT(J).EQ.1)EXIT; ENDDO IF(J.GT.SIZE(MC(IMF)%T))CYCLE ENDIF IDTOPIC =IDTOPIC+1 TOPICS(I)%ID=IDTOPIC !## create main topics CALL WDIALOGINSERTTREEVIEWITEM(ID_TREEVIEW1,TOPICS(MAX(1,II))%ID,INSERTAFTER, & TOPICS(I)%ID,TRIM(TOPICS(I)%TNAME)) !## save previous inserted treeview item II=I !## 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) !## add tooltips IDSUBTC=IDSUBTC+1 IFILES=IFILES+1 TOPICS(I)%STRESS(IPER)%FILES(J,K)%ID=IDSUBTC STRING=';' IF(TOPICS(I)%STRESS(IPER)%FILES(J,K)%IACT.EQ.0)THEN STRING='* inactive *;' ENDIF !## pst, gcg, rct and VDF are special cases SELECT CASE (I) !## pst-settings CASE (TPST) IF(ASSOCIATED(PEST%MEASURES))THEN; STRING=';nmeasures='//TRIM(VTOS(SIZE(PEST%MEASURES))) ELSE; STRING=TRIM(STRING)//';nmeasures=0'; ENDIF IF(ASSOCIATED(PEST%PARAM))THEN; STRING=TRIM(STRING)//';nparam='//TRIM(VTOS(SIZE(PEST%PARAM))) ELSE; STRING=TRIM(STRING)//';nparam=0'; ENDIF IF(ASSOCIATED(PEST%S_PERIOD))THEN; STRING=TRIM(STRING)//';nperiods='//TRIM(VTOS(SIZE(PEST%S_PERIOD))) ELSE; STRING=TRIM(STRING)//';nperiods=0'; ENDIF IF(ASSOCIATED(PEST%B_FRACTION))THEN; STRING=TRIM(STRING)//';nbatchfiles='//TRIM(VTOS(SIZE(PEST%B_FRACTION))) ELSE; STRING=TRIM(STRING)//';nbatchfiles=0'; ENDIF IF(ASSOCIATED(PEST%IDFFILES))THEN; STRING=TRIM(STRING)//';nzones='//TRIM(VTOS(SIZE(PEST%IDFFILES))) ELSE; STRING=TRIM(STRING)//';nzones=0'; ENDIF CASE (TIES) ! IF(ASSOCIATED(PEST%MEASURES))THEN; STRING=TRIM(STRING)//'nmeasures='//TRIM(VTOS(SIZE(PEST%MEASURES))) ! ELSE; STRING=TRIM(STRING)//'nmeasures=0'; ENDIF ! IF(ASSOCIATED(PEST%PARAM))THEN; STRING=TRIM(STRING)//';nparam='//TRIM(VTOS(SIZE(PEST%PARAM))) ! ELSE; STRING=TRIM(STRING)//';nparam=0'; ENDIF ! IF(ASSOCIATED(PEST%S_PERIOD))THEN; STRING=TRIM(STRING)//';nperiods='//TRIM(VTOS(SIZE(PEST%S_PERIOD))) ! ELSE; STRING=TRIM(STRING)//';nperiods=0'; ENDIF ! IF(ASSOCIATED(PEST%B_FRACTION))THEN; STRING=TRIM(STRING)//';nbatchfiles='//TRIM(VTOS(SIZE(PEST%B_FRACTION))) ! ELSE; STRING=TRIM(STRING)//';nbatchfiles=0'; ENDIF ! IF(ASSOCIATED(PEST%IDFFILES))THEN; STRING=TRIM(STRING)//';nzones='//TRIM(VTOS(SIZE(PEST%IDFFILES))) ! ELSE; STRING=TRIM(STRING)//';nzones=0'; ENDIF !## pcg-settings CASE (TPCG) STRING=TRIM(STRING)//';outer='//TRIM(VTOS(PCG%NOUTER))//';inner='// & TRIM(VTOS(PCG%NINNER))//';hclose='//TRIM(VTOS(PCG%HCLOSE,'G',5))// & ';rclose='//TRIM(VTOS(PCG%RCLOSE,'G',5)) !## gcg-settings CASE (TGCG) STRING=TRIM(STRING)//';mxiter='//TRIM(VTOS(WQ%GCG%MXITER))//';iter1='//TRIM(VTOS(WQ%GCG%ITER1))// & ';cclose='//TRIM(VTOS(WQ%GCG%CCLOSE,'G',5))//';isolve='//TRIM(VTOS(WQ%GCG%ISOLVE)) !## rct-settings CASE (TRCT) STRING=TRIM(STRING)//';isothm='//TRIM(ISOTHM_STR(WQ%RCT%ISOTHM))//';igetsc='//TRIM(VTOS(WQ%RCT%IGETSC)) IF(WQ%RCT%IREACT.EQ.1)THEN ; STRING=TRIM(STRING)//';ireact= no kinetic rate reaction is simulated' ; ELSE STRING=TRIM(STRING)//';ireact= first-order irreversible reaction' ; ENDIF !## vdf-settings CASE (TVDF) STRING=TRIM(STRING)//';densemin='//TRIM(VTOS(WQ%VDF%DENSEMIN,'G',5)) STRING=TRIM(STRING)//';densemax='//TRIM(VTOS(WQ%VDF%DENSEMAX,'G',5)) STRING=TRIM(STRING)//';denseref='//TRIM(VTOS(WQ%VDF%DENSEREF,'G',5)) STRING=TRIM(STRING)//';denseslp='//TRIM(VTOS(WQ%VDF%DENSESLP,'G',5)) CASE DEFAULT STRING=TRIM(STRING)//';ilay='//TRIM(VTOS(TOPICS(I)%STRESS(IPER)%FILES(J,K)%ILAY)) IF(TOPICS(I)%STRESS(IPER)%FILES(J,K)%ICNST.EQ.1)THEN WRITE(XSTRING,UTL_GETFORMAT(TOPICS(I)%STRESS(IPER)%FILES(J,K)%CNST)) TOPICS(I)%STRESS(IPER)%FILES(J,K)%CNST STRING=TRIM(STRING)//';cnst='//TRIM(XSTRING) ELSEIF(TOPICS(I)%STRESS(IPER)%FILES(J,K)%ICNST.EQ.2)THEN CNAME=TOPICS(I)%STRESS(IPER)%FILES(J,K)%ALIAS EXT=UTL_CAP(CNAME(INDEX(CNAME,'.',.TRUE.)+1:),'L') STRING=TRIM(STRING)//';'//CHAR(13)//TRIM(EXT)//'='//TRIM(CNAME) ENDIF WRITE(XSTRING,UTL_GETFORMAT(TOPICS(I)%STRESS(IPER)%FILES(J,K)%FCT)) TOPICS(I)%STRESS(IPER)%FILES(J,K)%FCT STRING=TRIM(STRING)//';fct='//TRIM(XSTRING) WRITE(XSTRING,UTL_GETFORMAT(TOPICS(I)%STRESS(IPER)%FILES(J,K)%IMP)) TOPICS(I)%STRESS(IPER)%FILES(J,K)%IMP STRING=TRIM(STRING)//';imp='//TRIM(XSTRING) END SELECT 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 CALL WDIALOGTREEVIEWCHECK(1) ! !## 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 PMANAGER_UTL_UPDATE_TREEVIEW !###====================================================================== SUBROUTINE PMANAGER_UTL_IPESTTOPARAM_CALC(PRJFNAME,OUTPUTFOLDER,ZIDF) !###====================================================================== IMPLICIT NONE CHARACTER(LEN=*),INTENT(IN) :: PRJFNAME,OUTPUTFOLDER CHARACTER(LEN=256) :: FNAME TYPE(IDFOBJ),INTENT(INOUT) :: ZIDF INTEGER :: I,J,K,N,M,NU,IROW,ICOL,IZ,IP,JZ REAL(KIND=DP_KIND) :: F,P CHARACTER(LEN=2),DIMENSION(:),ALLOCATABLE :: UP INTEGER,DIMENSION(:,:),ALLOCATABLE :: ILS INTEGER,DIMENSION(:),ALLOCATABLE :: NLS TYPE(IDFOBJ),DIMENSION(:,:),ALLOCATABLE :: IDF CALL PMANAGER_UTL_INIT() IF(.NOT.PMANAGER_LOADPRJ(PRJFNAME,1))STOP 'ERROR READING PRJFILE' !## find unique stuff N=SIZE(PEST%PARAM); ALLOCATE(UP(N)); DO I=1,SIZE(PEST%PARAM); UP(I)=PEST%PARAM(I)%PPARAM; ENDDO CALL UTL_GETUNIQUE_CHAR(UP,N,NU) ALLOCATE(NLS(NU)) DO J=1,NU; NLS(J)=0; DO I=1,N; IF(UP(J).EQ.PEST%PARAM(I)%PPARAM)NLS(J)=NLS(J)+1; ENDDO; ENDDO ALLOCATE(ILS(NU,MAXVAL(NLS))) DO J=1,NU; NLS(J)=0; DO I=1,N; IF(UP(J).EQ.PEST%PARAM(I)%PPARAM)THEN; NLS(J)=NLS(J)+1; ILS(J,NLS(J))=PEST%PARAM(I)%PILS; ENDIF; ENDDO; ENDDO DO J=1,NU; CALL UTL_GETUNIQUE_INT(ILS(J,:),NLS(J),M); NLS(J)=M; ENDDO WRITE(*,'(/1X,A)') 'Unique parameters found that can be processed:' DO I=1,NU; WRITE(*,'(1X,99A)') UP(I),(','//TRIM(VTOS(ILS(I,J))),J=1,NLS(I)); ENDDO !## find unique layers/systems per parameter ALLOCATE(IDF(NU,MAXVAL(NLS))); DO I=1,SIZE(IDF,1); DO J=1,SIZE(IDF,2); CALL IDFNULLIFY(IDF(I,J)); ENDDO; ENDDO IF(.NOT.ASSOCIATED(ZIDF%X))THEN !## use first zone to dimension idf DO I=1,SIZE(PEST%IDFFILES); IF(INDEX(UTL_CAP(PEST%IDFFILES(I),'U'),'.IDF').GT.0)EXIT; ENDDO IF(I.GT.SIZE(PEST%IDFFILES))STOP 'NEED TO FIND IDFFILES IN ZONES' IF(.NOT.IDFREAD(ZIDF,PEST%IDFFILES(I),0))THEN; WRITE(*,'(/1X,A/)') 'CANNOT READ '//TRIM(PEST%IDFFILES(I)); STOP; ENDIF ENDIF IF(.NOT.IDFALLOCATEX(ZIDF))STOP DO I=1,SIZE(IDF,1); DO J=1,NLS(I); CALL IDFCOPY(ZIDF,IDF(I,J)); ENDDO; ENDDO DO I=1,SIZE(IDF,1); DO J=1,NLS(I); IF(.NOT.IDFALLOCATEX(IDF(I,J)))STOP 'CANNOT ALLOCATE MEMORY'; IDF(I,J)%X=0.0D0; ENDDO; ENDDO !## process each zone DO I=1,SIZE(PEST%IDFFILES) !## scale up as zones IF(.NOT.IDFREADSCALE(PEST%IDFFILES(I),ZIDF,15,0,1.0D0,0))THEN; WRITE(*,'(/1X,A/)') 'CANNOT READ '//TRIM(PEST%IDFFILES(I)); STOP; ENDIF JZ=0; DO IROW=1,ZIDF%NROW; DO ICOL=1,ZIDF%NCOL IF(ZIDF%X(ICOL,IROW).EQ.ZIDF%NODATA)CYCLE IZ=INT(ZIDF%X(ICOL,IROW)); F=MOD(ZIDF%X(ICOL,IROW),1.0D0); IF(F.EQ.0.0D0)F=1.0D0 !## find new zone DO IP=1,SIZE(PEST%PARAM) IF(PEST%PARAM(IP)%PIZONE.NE.IZ)CYCLE !## find idf to be add values DO J=1,NU; IF(UP(J).EQ.PEST%PARAM(IP)%PPARAM)EXIT; ENDDO !## find ils DO K=1,NLS(J); IF(ILS(J,K).EQ.PEST%PARAM(IP)%PILS)EXIT; ENDDO P=F*PEST%PARAM(IP)%PINI IDF(J,K)%X(ICOL,IROW)=IDF(J,K)%X(ICOL,IROW)+P ENDDO ENDDO; ENDDO F=DBLE(I)/SIZE(PEST%IDFFILES)*100.0D0; WRITE(6,'(A,F10.2,A)') '+Progress ',F,' % ' ENDDO DO I=1,NU; DO J=1,NLS(I) DO IROW=1,IDF(I,J)%NROW; DO ICOL=1,IDF(I,J)%NCOL IF(IDF(I,J)%X(ICOL,IROW).EQ.0.0D0)IDF(I,J)%X(ICOL,IROW)=1.0D0 !IDF(I,J)%NODATA !1.0D0 ENDDO; ENDDO WRITE(FNAME,'(3A,I2.2,A)') TRIM(OUTPUTFOLDER)//'\',UP(I),'_F_LS',ILS(I,J),'.IDF' IF(.NOT.IDFWRITE(IDF(I,J),FNAME,1))THEN; WRITE(*,'(/A/)') 'ERROR WRITING '//TRIM(FNAME); CYCLE; ENDIF WRITE(*,'(A)') 'WRITING '//TRIM(FNAME) ENDDO; ENDDO END SUBROUTINE PMANAGER_UTL_IPESTTOPARAM_CALC END MODULE