!! Copyright (C) Stichting Deltares, 2005-2017. !! !! This file is part of iMOD. !! !! This program is free software: you can redistribute it and/or modify !! it under the terms of the GNU General Public License as published by !! the Free Software Foundation, either version 3 of the License, or !! (at your option) any later version. !! !! This program is distributed in the hope that it will be useful, !! but WITHOUT ANY WARRANTY; without even the implied warranty of !! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the !! GNU General Public License for more details. !! !! You should have received a copy of the GNU General Public License !! along with this program. If not, see . !! !! Contact: imod.support@deltares.nl !! Stichting Deltares !! P.O. Box 177 !! 2600 MH Delft, The Netherlands. !! MODULE MOD_BATCH USE WINTERACTER USE RESOURCE USE DATEVAR USE MOD_BATCH_PAR USE MOD_OSD, ONLY : OSD_GETARG,OSD_GETNARG,OSD_OPEN USE MOD_UTL,ONLY : UTL_CAP,UTL_GETUNIT,UTL_READINITFILE,ITOS,RTOS,UTL_IDATETOJDATE,UTL_DIRINFO,UTL_CREATEDIR, & UTL_SUBST,UTL_DIRINFO_POINTER,UTL_IDFGETDATE,UTL_FIT_REGRESSION,UTL_IDFSNAPTOGRID,UTL_READARRAY, & UTL_GETUNIQUE,UTL_GETIDPROC,UTL_WSELECTFILE,PROCOBJ,UTL_GDATE,NV,NL,UTL_GENLABELSREAD,UTL_IMODVERSION, & IDATETOGDATE,VAR,UTL_IDFSNAPTOGRID_LLC USE MODPLOT, ONLY : MPW,MP,MXMPLOT USE IMODVAR, ONLY : IBACKSLASH,ILABELNAME,EXENAME,LBETA USE MOD_PREF, ONLY : PREFCOLOURSINIT USE MOD_PREF_PAR, ONLY : PREFVAL USE MOD_MANAGER, ONLY : MANAGERINIT USE MOD_IDF, ONLY : IDFREAD,IDFNULLIFY,IDFWRITE,IDFDEALLOCATE,IDFREADSCALE,IDFCOPY,IDFGETXYVAL,IDFIROWICOL, & IDFGETLOC,IDFGETVAL,IDFEQUAL,IDFCREATEIVF,IDF_EXTENT,IDFALLOCATEX,IDFDEALLOCATEX,IDFFILLSXSY USE MOD_LEGEND, ONLY : LEG_INIT USE IMOD, ONLY : IDFINIT USE MOD_LEGPLOT, ONLY : LEGPLOT_PLOT USE IMODVAR, ONLY : BVERSION USE MOD_POLYGON_PAR USE MOD_POLYGON_UTL, ONLY : POLYGON1INIT,POLYGON1CLOSE,POLYGON1SAVELOADSHAPE USE MOD_COLOURS USE MOD_SOBEK, ONLY : SOBEK1CALC USE MOD_IPF, ONLY : IPFSAMPLE,IPFDEALLOCATE,IPFREAD2,IPFSPOTIFY,IPFASSIGNWELL USE MOD_PLINES_TRACE, ONLY : TRACEMAIN,TRACEPOSTPROCESSING,TRACECONVERTTOGEN,TRACEDEALLOCATE USE MOD_TSTAT, ONLY : TSTAT1APPLY,TSTATRESIDUAL USE MOD_GENPLOT, ONLY : TOPOGENINIT USE MOD_GXG_CLC, ONLY : GXG1COMPUTEGXG,GXG1ABORT USE MOD_ASC2IDF USE MOD_INFO, ONLY : INFOSTAT USE MOD_AHNFILTER, ONLY : AHNFILTER_MAIN USE MOD_MATH_CALC, ONLY : MATH1CALC ,MATH1CALCCLOSE,MATH1_PWTCOUNT USE MOD_MATH_SCALE, ONLY : MATH1SCALE,MATH1SCALECLOSE USE MOD_MATH_MERGE, ONLY : MATH1MERGE,MATH1MERGECLOSE USE MOD_MEAN_CLC, ONLY : MEAN1COMPUTE,MEAN1ABORT USE MOD_IMPORT_CALC, ONLY : IMPORT_CALC USE MOD_MODEL, ONLY : MODEL1COPYRUNFILE USE MOD_WBAL_CLC, ONLY : WBALCOMPUTE,WBALABORT USE MOD_ISG_ADJ, ONLY : ISGADJUSTAPPLY USE MOD_ISG_GRID, ONLY : ISG_SIMPLIFYMAIN,ISG_ADDCROSSSECTION,ISG2GRIDMAIN,ISG_ADDSTAGES,ISG_EXPORT USE MOD_ISG_STRUCTURES, ONLY : ISG_ADDSTRUCTURES USE MOD_ISG_UTL, ONLY : ISGSAVE,ISGDEAL,ISGREAD USE MOD_ISG_PAR, ONLY : NISG,ISG,ISD,DATISD,ISFR USE MOD_DINO_IPF, ONLY : IMOD_DINO_MAIN,IMOD_DINO_DEALLOCATE USE MOD_CORRKD, ONLY : CORRKD_MAIN,CORRKD_DEALLOCATE,CORRKD_ALLOCATE USE MOD_TS_CLC, ONLY : TS1COMPUTE,TS_END USE MOD_SOLID, ONLY : SOLID_NEWMASKS,SOLID_CALC_KDC,SOLID_CALC_KDC_DEALLOCATE,SOLID_INITSLDPOINTER,SOLID_INITSLD USE MOD_SOLID, ONLY : SOLID_WVP,SOLID_GEOTOP,SOLID_GEOTOP_DEALLOCATE USE MOD_SOLID_PCG, ONLY : SOLID_CALC_HYPO,SOLID_TRACE_3D USE MOD_SOF, ONLY : SOF_MAIN,SOF_TRACE,SOF_CATCHMENTS,SOF_EXPORT USE MOD_CUS, ONLY : CUS_MAIN,CUS_DEALLOCATE USE MOD_CREATEIZONE, ONLY : CREATEIZONE_MAIN USE MOD_GEF2IPF, ONLY : GEF2IPF_MAIN USE MOD_UTM, ONLY : UTM_IDF2LATLONG USE MOD_TB_READCONF, ONLY : TB_MAIN USE MOD_ABOUT, ONLY : IMOD_AGREEMENT USE MOD_PMANAGER, ONLY : PMANAGERPRJ,PMANAGERRUN,PMANAGERINIT,PMANAGER_SAVEMF2005_HFB_GENFILES USE MOD_PMANAGER_PAR, ONLY : PBMAN,TOP,BOT,TOPICS USE MOD_IPFANALYSE, ONLY : IPFANALYSE_INIT_GRAPHVARIABLES INTEGER,PARAMETER,PRIVATE :: MAXFUNC=67 CHARACTER(LEN=50),DIMENSION(MAXFUNC),PRIVATE :: CFUNC CHARACTER(LEN=50),DIMENSION(:),ALLOCATABLE,PRIVATE :: CKEY CHARACTER(LEN=3*256),PRIVATE :: LINE CHARACTER(LEN=256),PRIVATE :: ARGSTRING INTEGER,PRIVATE :: NKEY,IU,IFN DATA CFUNC/'PLOT','GXG','AHNFILTER','IDFSCALE','IDFCALC','IDFMERGE','CREATEIDF','IMPORTMODFLOW',& 'IDFSTAT','IPFSTAT','MODELCOPY','IMODPATH','IPFSAMPLE','XYZTOIDF','IMPORTSOBEK','MKWELLIPF', & 'IDFMEAN','WBALANCE','ISGADJUST','DINO2IPF','CORRKD','IDFTIMESERIE','BMPTILING','IPFRESIDUAL', & 'SOLID','GEN2ISG','IDFINSERT','CREATESOF','ISGSIMPLIFY','ISGADDCROSSSECTION','CREATEASC', & 'CREATEIVF','WVP','CUS','GEOTOP','ISGADDSTRUCTURES','PWTCOUNT','IDFCONSISTENCY','GEN2GEN3D', & 'CREATEIBOUND','CREATESUBMODEL','CREATEEVT','DRNSURF','ISGGRID','IPFSPOTIFY','ASSIGNWELL', & 'CREATEIZONE','GEF2IPF','UTM2LATLONG','ISGADDSTAGES','VOLUME','TESTBANK','ISGEXPORT', & 'CLIPVOXELS','FAULTS3D','RUNFILE','FLUMY','GEOCONNECT','IPFSUM','VOXELVOLUME','PLOTRESIDUAL', & 'IPF2ISG','SFRTOISG','ISGTOSFR','IDFTRACE','UZFTOCSV','GENSNAPTOGRID'/ CHARACTER(LEN=256),PRIVATE,DIMENSION(4) :: FIG TYPE(PROCOBJ),DIMENSION(:),POINTER,PRIVATE :: PROC CONTAINS !###====================================================================== SUBROUTINE CREATEIMODBATCHMAIN(ITYPE,MESSAGE) !###====================================================================== IMPLICIT NONE TYPE(WIN_MESSAGE),INTENT(IN) :: MESSAGE INTEGER,INTENT(IN) :: ITYPE CALL WDIALOGSELECT(MESSAGE%WIN) SELECT CASE(ITYPE) CASE (MENUSELECT) SELECT CASE (MESSAGE%VALUE1) END SELECT CASE(FIELDCHANGED) SELECT CASE (MESSAGE%VALUE2) END SELECT CASE(PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (IDOK) CALL CREATEIMODBATCHCREATE() CASE (ID_KILL) ! CALL CREATEIMODBATCHKILL() CASE (ID_INFO) CALL CREATEIMODBATCHINFO() CASE (ID_REFRESH) CALL CREATEIMODBATCHREFRESH() CASE (ID_EXECUTE) CALL CREATEIMODBATCHEXECUTE() CASE (IDHELP) CALL IMODGETHELP('3.2.6','EMO.iMODBatch') CASE (IDCANCEL) CALL CREATEIMODBATCHCLOSE() END SELECT END SELECT END SUBROUTINE CREATEIMODBATCHMAIN !###====================================================================== SUBROUTINE CREATEIMODBATCHINFO() !###====================================================================== IMPLICIT NONE INTEGER :: IWIN,IU,I CHARACTER(LEN=256) :: FNAME CALL WDIALOGSELECT(ID_DBATCH) CALL WDIALOGGETMENU(IDF_MENU2,I,FNAME) FNAME=TRIM(PREFVAL(1))//'\IMODBATCH\'//TRIM(FNAME) IU=UTL_GETUNIT() CALL OSD_OPEN(IU,FILE=FNAME,STATUS='OLD',IOSTAT=I) IF(I.NE.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMOD cannot view the created file : '//CHAR(13)// & TRIM(FNAME)//'.'//CHAR(13)//'It is probably opened already in another application','Error') ELSE CLOSE(IU) CALL WINDOWOPENCHILD(IWIN,FLAGS=SYSMENUON+MAXWINDOW,WIDTH=1000,HEIGHT=500) CALL WINDOWSELECT(IWIN) CALL WEDITFILE(FNAME,ITYPE=MODAL,IDMENU=0, & IFLAGS=NOTOOLBAR+WORDWRAP+NOFILENEWOPEN,& IFONT=4,ISIZE=10) ENDIF END SUBROUTINE CREATEIMODBATCHINFO !###====================================================================== SUBROUTINE CREATEIMODBATCHREFRESH() !###====================================================================== IMPLICIT NONE INTEGER :: I I=UTL_GETIDPROC(PROC,1) IF(I.EQ.0)THEN CALL WDIALOGFIELDSTATE(ID_KILL,0) CALL WDIALOGCLEARFIELD(IDF_MENU3); CALL WDIALOGPUTMENU(IDF_MENU3,(/''/),1,1) CALL WDIALOGFIELDSTATE(IDF_MENU3,0) CALL WDIALOGPUTSTRING(IDF_LABEL1,'No processes active') ELSE CALL WDIALOGFIELDSTATE(ID_KILL,1) CALL WDIALOGPUTMENU(IDF_MENU3,PROC%CID,SIZE(PROC),I) CALL WDIALOGPUTSTRING(IDF_LABEL1,'Current processes') ENDIF END SUBROUTINE CREATEIMODBATCHREFRESH !###====================================================================== SUBROUTINE CREATEIMODBATCHCREATE() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: FNAME,INIFNAME INTEGER :: IU,I,J,K,II,I1,I2 CHARACTER(LEN=12) :: CN FNAME=TRIM(PREFVAL(1))//'\IMODBATCH\*.bat' IF(.NOT.UTL_WSELECTFILE('Batch Files (*.bat)|',& SAVEDIALOG+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,& 'Save Selected Function to Batchfile (*.bat)'))RETURN IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=FNAME,STATUS='UNKNOWN',ACTION='WRITE',IOSTAT=I) IF(I.NE.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot create the file:'//CHAR(13)//TRIM(FNAME),'Error') RETURN ENDIF CALL WDIALOGSELECT(ID_DBATCH) CALL WDIALOGGETMENU(IDF_MENU1,J,FNAME) INIFNAME=TRIM(UTL_CAP(FNAME,'L'))//'.ini' WRITE(IU,'(A/)') 'rem iMOD Batch generated by '//TRIM(UTL_IMODVERSION()) WRITE(IU,'(A)') 'rem FUNCTION' LINE='echo FUNCTION='//TRIM(BAT(J)%CFUNC); LINE(52:)='> '//TRIM(INIFNAME) WRITE(IU,'(A)') TRIM(LINE) K=0 DO I=1,BAT(J)%N LINE='echo' SELECT CASE (BAT(J)%LVL(I)) CASE ('(COMP)') K=0; II=6 CASE ('(OPT)') II=6 IF(K.EQ.0)WRITE(IU,'(A)') 'rem OPTIONAL ARGUMENTS'; K=1 CASE ('(DEP)') II=8 CASE ('(DEP2)') II=10 END SELECT IF(INDEX(BAT(J)%KEY(I),'{').GT.0)THEN I1=INDEX(BAT(J)%KEY(I),',',.TRUE.)+1 I2=INDEX(BAT(J)%KEY(I),'}',.TRUE.)-1 READ(BAT(J)%KEY(I)(I1:I2),*) CN LINE=''; LINE(II:)='for /l %%a in (1,1,{ value of '//TRIM(CN)//'} ) do (' WRITE(IU,'(A)') TRIM(LINE) I2=INDEX(BAT(J)%KEY(I),'{',.TRUE.)-1 LINE='echo'; LINE(II:)=BAT(J)%KEY(I)(:I2)//'%%a= ...' LINE(52:)='>> '//TRIM(INIFNAME) WRITE(IU,'(A)') TRIM(LINE) LINE=''; LINE(II:)=')'; WRITE(IU,'(A)') TRIM(LINE) ELSE LINE(II:)=TRIM(BAT(J)%KEY(I))//'= ...' LINE(52:)='>> '//TRIM(INIFNAME) WRITE(IU,'(A)') TRIM(LINE) ENDIF ENDDO WRITE(IU,'(A)') WRITE(IU,'(A)') TRIM(EXENAME)//' '//TRIM(INIFNAME) WRITE(IU,'(A)') CLOSE(IU) CALL CREATEIMODBATCH_UPDATE() CALL CREATEIMODBATCHINFO() END SUBROUTINE CREATEIMODBATCHCREATE !###====================================================================== SUBROUTINE CREATEIMODBATCHEXECUTE() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=52) :: FNAME INTEGER :: IFLAGS,I INTEGER,DIMENSION(2) :: PID CALL WDIALOGSELECT(ID_DBATCH) CALL WDIALOGGETMENU(IDF_MENU2,I,FNAME) IFLAGS=0 !## hidden window CALL WDIALOGGETCHECKBOX(IDF_CHECK1,I) IF(I.EQ.1)IFLAGS=IFLAGS+PROCSILENT !## I=0: show execution window !## I=1: hide execution window !## block execution CALL WDIALOGGETCHECKBOX(IDF_CHECK2,I) !## I=0: do not block execution till complete !## I=1: block execution till complete IF(I.EQ.1)IFLAGS=IFLAGS+PROCBLOCKED !## executes on commandtool such that commands alike 'dir' etc. works #if(defined(WINTERACTER9)) IFLAGS=IFLAGS+PROCCMDPROC #endif I=UTL_GETIDPROC(PROC,0) #if(defined(WINTERACTER9)) CALL IOSCOMMAND(TRIM(PREFVAL(1))//'\IMODBATCH\'//TRIM(FNAME),IFLAGS,0,PID) #endif PROC(I)%ID=PID(1) PROC(I)%CID=TRIM(FNAME) CALL WDIALOGGETCHECKBOX(IDF_CHECK1,PROC(I)%IFLAGS(1)) CALL WDIALOGGETCHECKBOX(IDF_CHECK2,PROC(I)%IFLAGS(2)) CALL WDIALOGPUTMENU(IDF_MENU3,PROC%CID,SIZE(PROC),I) END SUBROUTINE CREATEIMODBATCHEXECUTE !###====================================================================== SUBROUTINE CREATEIMODBATCHINIT() !###====================================================================== IMPLICIT NONE CALL WINDOWSELECT(0) IF(WMENUGETSTATE(ID_IMODBATCH,2).EQ.1)THEN CALL CREATEIMODBATCHCLOSE(); RETURN ENDIF CALL UTL_CREATEDIR(TRIM(PREFVAL(1))//'\IMODBATCH') CALL WMENUSETSTATE(ID_IMODBATCH,2,1) CALL WDIALOGLOAD(ID_DBATCH,ID_DBATCH) CALL BATCHINIT() CALL CREATEIMODBATCH_UPDATE() CALL CREATEIMODBATCHREFRESH() CALL WDIALOGSELECT(ID_DBATCH) CALL WDIALOGPUTIMAGE(ID_REFRESH,ID_ICONREDRAW,1) CALL WDIALOGPUTIMAGE(ID_INFO,ID_ICONINFO,1) CALL WDIALOGSHOW(-0,100,0,2) END SUBROUTINE CREATEIMODBATCHINIT !###====================================================================== SUBROUTINE CREATEIMODBATCH_UPDATE() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=52),POINTER,DIMENSION(:) :: INIFNAME !## get available batchfiles (*.ini) IF(.NOT.UTL_DIRINFO_POINTER(TRIM(PREFVAL(1))//'\IMODBATCH','*.bat',INIFNAME,'F'))STOP IF(SIZE(INIFNAME).EQ.0)THEN CALL WDIALOGFIELDSTATE(IDF_MENU2,0); CALL WDIALOGFIELDSTATE(ID_EXECUTE,0); CALL WDIALOGCLEARFIELD(IDF_MENU2) CALL WDIALOGFIELDSTATE(ID_INFO,0) ELSE CALL WDIALOGFIELDSTATE(IDF_MENU2,1); CALL WDIALOGFIELDSTATE(ID_EXECUTE,1); CALL WDIALOGFIELDSTATE(ID_INFO,1) CALL WDIALOGPUTMENU(IDF_MENU2,INIFNAME,SIZE(INIFNAME),1) ENDIF END SUBROUTINE CREATEIMODBATCH_UPDATE !###====================================================================== SUBROUTINE CREATEIMODBATCHCLOSE() !###====================================================================== IMPLICIT NONE CALL WINDOWSELECT(0); CALL WMENUSETSTATE(ID_IMODBATCH,2,0) CALL WDIALOGSELECT(ID_DBATCH); CALL WDIALOGUNLOAD() END SUBROUTINE CREATEIMODBATCHCLOSE !###====================================================================== LOGICAL FUNCTION IMODBATCH() !###====================================================================== IMPLICIT NONE INTEGER :: IERROR IMODBATCH=.FALSE. IF(.NOT.IMODBATCH_FUNC())RETURN !## get username and status and initialise window CALL WINDOWOPEN(FLAGS=SYSMENUON+HIDEWINDOW+STATUSBAR) CALL WINDOWSTATUSBARPARTS(4,(/2000,2000,750,-1/),(/1,1,1,1/)) !## initialize preferences user FOR IMOD Batch only PREFVAL='' !(1)='.\' CALL IOSDIRNAME(PREFVAL(1)) IERROR=0; CALL IMOD_AGREEMENT(IERROR) IF(IERROR.NE.1)THEN IF(LBETA)THEN CALL WMESSAGEBOX(OKONLY,COMMONOK,EXCLAMATIONICON,'Cannot start Beta-iMOD because you are not authorized in writing for Beta-iMOD','Error') ELSE CALL WMESSAGEBOX(OKONLY,COMMONOK,EXCLAMATIONICON,'Cannot start iMOD unless you accept the iMOD Software License Agreement','Error') ENDIF CALL WINDOWCLOSE(); STOP ENDIF CALL WINDOWCLOSE() !## open Unit for Same Line Printing of echo (is equal to screen or '*') OPEN(UNIT=6,CARRIAGECONTROL='fortran') CALL UTL_CREATEDIR(TRIM(PREFVAL(1))//'\tmp') !## initialize polygons MAXSHAPES=500 MAXSHPCRD=1000 CALL POLYGON1INIT() SELECT CASE (IFN) CASE (1) !## plot-function CALL IMODBATCH_PLOT_MAIN() CASE (2) !## gxg-function CALL IMODBATCH_GXG_MAIN() CASE (3) !## ahnfilter CALL IMODBATCH_AHNFILTER_MAIN() CASE (4) !## scale CALL IMODBATCH_SCALE_MAIN() CASE (5) !## math CALL IMODBATCH_CALC_MAIN() CASE (6) !## merge CALL IMODBATCH_MERGE_MAIN() CASE (7) !## createidf CALL IMODBATCH_CREATEIDF_MAIN() CASE (8) !## importmodflow CALL IMODBATCH_IMPORTMODFLOW_MAIN() CASE (9) !## idfstat CALL IMODBATCH_IDFSTAT_MAIN() CASE (10)!## ipfstat CALL IMODBATCH_IPFSTAT_MAIN() CASE (11)!## model copy CALL IMODBATCH_MODELCOPY_MAIN() CASE (12)!## imodpath CALL IMODBATCH_IMODPATH_MAIN() CASE (13)!## idfsample CALL IMODBATCH_IPFSAMPLE_MAIN() CASE (14)!## xyztoidf CALL IMODBATCH_XYZTOIDF_MAIN() CASE (15)!## importsobek CALL IMODBATCH_IMPORTSOBEK_MAIN() CASE (16)!## makewellipf CALL IMODBATCH_MKWELLIPF_MAIN() CASE (17)!## idfmean CALL IMODBATCH_IDFMEAN_MAIN() CASE (18)!## wbalance CALL IMODBATCH_WBALANCE_MAIN() CASE (19)!## wbalance CALL IMODBATCH_ISGADJUST_MAIN() CASE (20)!## csv2ipf CALL IMODBATCH_DINO2IPF_MAIN() CASE (21)!## corrkd CALL IMODBATCH_CORRKD_MAIN() CASE (22)!## idftimeserie CALL IMODBATCH_TSERIES() CASE (23)!## bitmaptiling CALL IMODBATCH_BITMAPTILING() CASE (24)!## ipfresidual CALL IMODBATCH_IPFRESIDUAL() CASE (25)!## solid CALL IMODBATCH_SOLID() CASE (26)!## gen2isg CALL IMODBATCH_GEN2ISG() CASE (27)!## idfinsert CALL IMODBATCH_IDFINSERT() CASE (28)!## createsof CALL IMODBATCH_CREATESOF() CASE (29)!## simplify isg CALL IMODBATCH_ISGSIMPLIFY_MAIN() CASE (30)!## add cross-sections CALL IMODBATCH_ISGADDCROSSSECTION() CASE (31)!## add cross-sections CALL IMODBATCH_CREATEASC_MAIN() CASE (32)!## create ivf0 CALL IMODBATCH_CREATEIVF_MAIN() CASE (33)!## wvp CALL IMODBATCH_WVP() CASE (34)!## cus CALL IMODBATCH_CUS() CASE (35)!## geotop CALL IMODBATCH_GEOTOP() CASE (36) !## add structures CALL IMODBATCH_ISGADDSTRUCTURES() CASE (37) !## pwtcount CALL IMODBATCH_PWTCOUNT() CASE (38) !## consistency CALL IMODBATCH_IDFCONSISTENCY() CASE (39) !## gen2gen3d CALL IMODBATCH_IDFGEN2GEN3D() CASE (40) !## createibound CALL IMODBATCH_CREATEIBOUND() CASE (41) CALL IMODBATCH_CREATESUBMODELS() CASE (42) CALL IMODBATCH_CREATEEVT() CASE (43) CALL IMODBATCH_DRNSURF() CASE (44) CALL IMODBATCH_ISGGRID() CASE (45) CALL IMODBATCH_IPFSPOTIFY() CASE (46) !## adjust filters such that they position filter is proper geological layer CALL IMODBATCH_ASSIGNWELL() CASE (47) !## create izones for iPEST CALL IMODBATCH_CREATEIZONE() CASE (48)!## gef2ipf CALL IMODBATCH_GEF2IPF_MAIN() CASE (49)!## utm2latlong CALL IMODBATCH_UTM2LATLONG_MAIN() ! CASE (49)!## createvoxel ! CALL IMODBATCH_CREATEVOXEL_MAIN() CASE (50)!## add cross-sections CALL IMODBATCH_ISGADDSTAGES() CASE (51)!## volume CALL IMODBATCH_VOLUME() CASE (52)!## testbank CALL IMODBATCH_TESTBANK() CASE (53)!## export isg CALL IMODBATCH_ISGEXPORT() CASE (54)!## clip voxels CALL IMODBATCH_CLIPVOXELS() CASE (55)!## faults to 3d conversion CALL IMODBATCH_FAULTS3D() CASE (56)!## create runfile CALL IMODBATCH_RUNFILE() CASE (57)!## make flumy-files CALL IMODBATCH_FLUMY() CASE (58)!## geoConnect CALL IMODBATCH_GEOCONNECT() CASE (59) !## summarizes ipf extraction per layer CALL IMODBATCH_IPFSUM() CASE (60)!## volume 3d CALL IMODBATCH_VOXELVOLUME() CASE (61) !## plot residual (scatter or histogram) CALL IMODBATCH_PLOTRESIDUAL() CASE (62) !## ipf2isg CALL IMODBATCH_IPF2ISG() CASE (63) !## sfrtoisg CALL IMODBATCH_SFRTOISG_MAIN() CASE (64) !## isgtosfr CALL IMODBATCH_ISGTOSFR_MAIN() CASE (65) !## idftrace CALL IMODBATCH_IDFTRACE_MAIN() CASE (66) !## uzftocsv CALL IMODBATCH_UZFTOCSV() CASE (67) !## gensnaptogrid CALL IMODBATCH_GENSNAPTOGRID() END SELECT CLOSE(IU) CALL POLYGON1CLOSE() IMODBATCH=.TRUE. END FUNCTION IMODBATCH !###====================================================================== LOGICAL FUNCTION IMODBATCH_FUNC() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=50) :: CF INTEGER :: NARG,IOS IMODBATCH_FUNC=.FALSE. CALL OSD_GETNARG(NARG) IF(NARG.LE.0.OR.NARG.GT.1)RETURN CALL OSD_GETARG(1,ARGSTRING) IF(INDEX(UTL_CAP(ARGSTRING,'U'),'INI').EQ.0)RETURN IMODBATCH_FUNC=.TRUE. IU=UTL_GETUNIT() CALL OSD_OPEN(IU,FILE=ARGSTRING,STATUS='OLD',ACTION='READ',IOSTAT=IOS) IF(IOS.NE.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot open file:'//CHAR(13)//TRIM(ARGSTRING),'Error') RETURN ENDIF !## read function IF(.NOT.UTL_READINITFILE('FUNCTION',LINE,IU,0))RETURN READ(LINE,*) CF !## search for recognizable functions DO IFN=1,SIZE(CFUNC) IF(TRIM(UTL_CAP(CFUNC(IFN),'U')).EQ.TRIM(UTL_CAP(CF,'U')))EXIT ENDDO IF(IFN.GT.SIZE(CFUNC))THEN CLOSE(IU) CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot recognize function:'//CHAR(13)//'FUNCTION='//TRIM(CF),'Error') RETURN ENDIF WRITE(*,'(/A/)') 'EXECUTING FUNCTION >>> '//TRIM(CF)//' <<<' END FUNCTION IMODBATCH_FUNC !###====================================================================== SUBROUTINE IMODBATCH_TESTBANK() !###====================================================================== USE MOD_TB_PAR, ONLY : CONFNAME IMPLICIT NONE IF(.NOT.UTL_READINITFILE('CONFNAME',LINE,IU,0))RETURN READ(LINE,'(A)') CONFNAME; WRITE(*,'(A)') 'CONFNAME='//TRIM(CONFNAME) CALL TB_MAIN() END SUBROUTINE IMODBATCH_TESTBANK !###====================================================================== SUBROUTINE IMODBATCH_VOXELVOLUME() !###====================================================================== IMPLICIT NONE TYPE(IDFOBJ) :: IDF CHARACTER(LEN=256),DIMENSION(:),POINTER :: LISTNAME CHARACTER(LEN=256) :: DIRNAME,FNAME CHARACTER(LEN=52) :: WC INTEGER :: I,II,J,JU,MAXTHREAD,MAXN,NPOCKETS,ILAY,IROW,ICOL,IP,NXOFFSET INTEGER(KIND=1),DIMENSION(:,:,:),ALLOCATABLE :: Y INTEGER,DIMENSION(:,:,:),ALLOCATABLE :: IBND REAL,ALLOCATABLE,DIMENSION(:) :: XTOP REAL,ALLOCATABLE,DIMENSION(:) :: XOFFSET INTEGER,ALLOCATABLE,DIMENSION(:) :: ITOP TYPE POCKETOBJ INTEGER :: SIZE INTEGER :: COUNT REAL :: VOLUME END TYPE POCKETOBJ TYPE(POCKETOBJ),ALLOCATABLE,DIMENSION(:,:) :: POCKET !## get number of files to be imported IF(.NOT.UTL_READINITFILE('SOURCEDIR',LINE,IU,0))RETURN READ(LINE,*) DIRNAME; WRITE(*,'(A)') 'SOURCEDIR='//TRIM(DIRNAME) IF(.NOT.UTL_READINITFILE('WILDCARD',LINE,IU,0))RETURN READ(LINE,*) WC; WRITE(*,'(A)') 'WILDCARD='//TRIM(WC) IF(.NOT.UTL_READINITFILE('FNAME',LINE,IU,0))RETURN READ(LINE,*) FNAME; WRITE(*,'(A)') 'FNAME='//TRIM(FNAME) IF(.NOT.UTL_READINITFILE('NXOFFSET',LINE,IU,0))RETURN READ(LINE,*) NXOFFSET; LINE='NXOFFSET='//TRIM(ITOS(NXOFFSET)); WRITE(*,'(A)') TRIM(LINE) ALLOCATE(XOFFSET(NXOFFSET)) DO I=1,NXOFFSET IF(.NOT.UTL_READINITFILE('XOFFSET'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) XOFFSET(I); LINE='XOFFSET'//TRIM(ITOS(I))//'='//TRIM(RTOS(XOFFSET(I),'F',7)); WRITE(*,'(A)') TRIM(LINE) ENDDO IF(.NOT.UTL_READINITFILE('NPOCKETS',LINE,IU,0))RETURN READ(LINE,*) NPOCKETS; LINE='NPOCKETS='//TRIM(ITOS(NPOCKETS)); WRITE(*,'(A)') TRIM(LINE) ALLOCATE(POCKET(NPOCKETS,NXOFFSET)); POCKET%SIZE=0; POCKET%COUNT=0 DO I=1,NPOCKETS IF(.NOT.UTL_READINITFILE('POCKET'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) POCKET(I,1)%SIZE; LINE='POCKET'//TRIM(ITOS(I))//'='//TRIM(ITOS(POCKET(I,1)%SIZE)); WRITE(*,'(A)') TRIM(LINE) ENDDO ! IF(.NOT.UTL_READINITFILE('XOFFSET',LINE,IU,0))RETURN ! READ(LINE,*) XOFFSET; LINE='XOFFSET='//TRIM(RTOS(XOFFSET,'E',7)); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_DIRINFO_POINTER(DIRNAME,WC,LISTNAME,'F'))THEN; STOP 'No files found'; ENDIF JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=FNAME,STATUS='UNKNOWN',ACTION='WRITE') ALLOCATE(XTOP(SIZE(LISTNAME)),ITOP(SIZE(LISTNAME))); XTOP=10.0E10; ITOP=0 DO I=1,SIZE(LISTNAME) LISTNAME(I)=TRIM(DIRNAME)//'\'//TRIM(LISTNAME(I)) IF(.NOT.IDFREAD(IDF,LISTNAME(I),0))THEN; WRITE(*,'(A)') 'Cannot read '//TRIM(LISTNAME(I)); STOP; ENDIF IF(IDF%ITB.EQ.0)THEN; WRITE(*,'(A)') TRIM(LISTNAME(I))//' is not a voxel IDF'; STOP; ENDIF XTOP(I)=IDF%TOP CLOSE(IDF%IU) ENDDO CALL WSORT(XTOP,1,SIZE(LISTNAME),1,IORDER=ITOP) ALLOCATE(IBND(IDF%NCOL,IDF%NROW,SIZE(LISTNAME))) DO II=1,NXOFFSET DO I=1,NPOCKETS POCKET(I,II)%SIZE =POCKET(I,1)%SIZE POCKET(I,II)%COUNT=0 ENDDO IBND=0 DO I=1,SIZE(LISTNAME) J=ITOP(I) WRITE(*,'(2I10,A)') I,J,TRIM(LISTNAME(J)) IF(.NOT.IDFREAD(IDF,LISTNAME(J),1))THEN; WRITE(*,'(A)') 'Cannot read '//TRIM(LISTNAME(I)); STOP; ENDIF DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL IF(IDF%X(ICOL,IROW).GE.XOFFSET(II))IBND(ICOL,IROW,I)=1 ENDDO; ENDDO CALL IDFDEALLOCATEX(IDF) ENDDO !## find active cells not in direct (2d/3d) relation to constant head cell! IF(ALLOCATED(Y))DEALLOCATE(Y); ALLOCATE(Y(IDF%NCOL,IDF%NROW,SIZE(LISTNAME))) IP=0 Y =0 DO ILAY=1,SIZE(LISTNAME) DO IROW=1,IDF%NROW DO ICOL=1,IDF%NCOL IF(Y(ICOL,IROW,ILAY).EQ.0.AND.IBND(ICOL,IROW,ILAY).GT.0)THEN IP=1 MAXTHREAD=1000; MAXN=MAXTHREAD CALL SOLID_TRACE_3D(ILAY,IROW,ICOL,IBND,Y,SIZE(LISTNAME),IDF%NROW,IDF%NCOL,IP,MAXTHREAD,MAXN,POCKET(:,II)%COUNT,POCKET(:,II)%SIZE) ENDIF ENDDO ENDDO WRITE(6,'(A,F10.2)') '+Progress ',REAL(ILAY*100)/REAL(SIZE(LISTNAME)) END DO ENDDO WRITE(JU,'(A15)') 'COUNT' WRITE(JU,'(2A15,99F15.7)') 'ipocket','size',(XOFFSET(I)*86400.0,I=1,NXOFFSET) DO I=1,NPOCKETS WRITE(JU,'(99I15)') I,POCKET(I,1)%SIZE,(POCKET(I,J)%COUNT,J=1,NXOFFSET) ENDDO WRITE(JU,'(A15)') 'VOLUME' WRITE(JU,'(2A15,99F15.7)') 'ipocket','size',(XOFFSET(I)*86400.0,I=1,NXOFFSET) DO I=1,NPOCKETS DO J=1,NXOFFSET POCKET(I,J)%VOLUME=POCKET(I,J)%SIZE*POCKET(I,J)%COUNT POCKET(I,J)%VOLUME=POCKET(I,J)%VOLUME*((IDF%DX*IDF%DY*5.0)/1.0E6) ENDDO WRITE(JU,'(2I15,99F15.7)') I,POCKET(I,1)%SIZE,(POCKET(I,J)%VOLUME,J=1,NXOFFSET) ENDDO DEALLOCATE(Y,IBND,XTOP,ITOP) CLOSE(JU); DEALLOCATE(LISTNAME) END SUBROUTINE IMODBATCH_VOXELVOLUME !###====================================================================== SUBROUTINE IMODBATCH_VOLUME() !###====================================================================== IMPLICIT NONE TYPE(IDFOBJ) :: IDF CHARACTER(LEN=256),DIMENSION(:),POINTER :: LISTNAME CHARACTER(LEN=256) :: DIRNAME,FNAME CHARACTER(LEN=52) :: WC REAL,DIMENSION(2) :: XSUM INTEGER :: I,J,IROW,ICOL,JU !## get number of files to be imported IF(.NOT.UTL_READINITFILE('SOURCEDIR',LINE,IU,0))RETURN READ(LINE,*) DIRNAME; WRITE(*,'(A)') 'SOURCEDIR='//TRIM(DIRNAME) IF(.NOT.UTL_READINITFILE('WILDCARD',LINE,IU,0))RETURN READ(LINE,*) WC; WRITE(*,'(A)') 'WILDCARD='//TRIM(WC) IF(.NOT.UTL_READINITFILE('FNAME',LINE,IU,0))RETURN READ(LINE,*) FNAME; WRITE(*,'(A)') 'FNAME='//TRIM(FNAME) IF(.NOT.UTL_DIRINFO_POINTER(DIRNAME,WC,LISTNAME,'F'))THEN; STOP 'No files found'; ENDIF JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=FNAME,STATUS='UNKNOWN',ACTION='WRITE') DO I=1,SIZE(LISTNAME) LISTNAME(I)=TRIM(DIRNAME)//'\'//TRIM(LISTNAME(I)) IF(.NOT.IDFREAD(IDF,LISTNAME(I),1))THEN; WRITE(*,'(A)') 'Cannot read '//TRIM(LISTNAME(I)); STOP; ENDIF XSUM=0.0; DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL IF(IDF%X(ICOL,IROW).NE.IDF%NODATA)THEN J=1; IF(IDF%X(ICOL,IROW).LT.0.0)J=2 XSUM(J)=XSUM(J)+IDF%X(ICOL,IROW) ENDIF ENDDO; ENDDO WRITE(*,'(2I10,A,3F15.7)') I,SIZE(LISTNAME),TRIM(LISTNAME(I)(INDEX(LISTNAME(I),'\',.TRUE.)+1:)),XSUM(1),XSUM(2),SUM(XSUM) WRITE(JU,'(A,3F15.7)') TRIM(LISTNAME(I)(INDEX(LISTNAME(I),'\',.TRUE.)+1:)),XSUM(1),XSUM(2),SUM(XSUM) ENDDO CLOSE(JU); DEALLOCATE(LISTNAME) END SUBROUTINE IMODBATCH_VOLUME !###====================================================================== SUBROUTINE IMODBATCH_VOLUME_SALT() !###====================================================================== IMPLICIT NONE TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: IDF INTEGER :: I,IROW,ICOL REAL :: T,B,DENSITY_FRESH,DENSITY_SALT,R,DRNLEVEL,POR,TV ALLOCATE(IDF(3)); DO I=1,SIZE(IDF); CALL IDFNULLIFY(IDF(I)); ENDDO DENSITY_FRESH=0.0; DENSITY_SALT=0.0 IF(.NOT.UTL_READINITFILE('TOPIDF',LINE,IU,0))RETURN READ(LINE,'(A)') IDF(1)%FNAME; WRITE(*,'(A)') 'TOPIDF='//TRIM(IDF(1)%FNAME) IF(.NOT.UTL_READINITFILE('BOTIDF',LINE,IU,0))RETURN READ(LINE,'(A)') IDF(2)%FNAME; WRITE(*,'(A)') 'BOTIDF='//TRIM(IDF(2)%FNAME) IF(.NOT.UTL_READINITFILE('VOLIDF',LINE,IU,0))RETURN READ(LINE,'(A)') IDF(3)%FNAME; WRITE(*,'(A)') 'VOLIDF='//TRIM(IDF(3)%FNAME) IF(UTL_READINITFILE('DENSITY_FRESH',LINE,IU,1))READ(LINE,*) DENSITY_FRESH WRITE(*,'(A,F10.2)') 'DENSITY_FRESH=',DENSITY_FRESH IF(UTL_READINITFILE('DENSITY_SALT',LINE,IU,1))READ(LINE,*) DENSITY_SALT WRITE(*,'(A,F10.2)') 'DENSITY_SALT=',DENSITY_SALT !## Ghyben-Herzberg R=DENSITY_FRESH/(DENSITY_SALT-DENSITY_FRESH) DRNLEVEL=0.0 POR=0.35 IF(.NOT.IDFREAD(IDF(1),IDF(1)%FNAME,0))STOP 'Cannot read data for IDF(1)' IF(.NOT.IDFREAD(IDF(2),IDF(2)%FNAME,0))STOP 'Cannot read data for IDF(2)' CLOSE(IDF(1)%IU); CLOSE(IDF(2)%IU) IF(.NOT.IDF_EXTENT(2,IDF,IDF(3),2))STOP 'Cannot determing minimal overlapping size.' IF(.NOT.IDFALLOCATEX(IDF(3)))STOP ' Cannot allocate memory for IDF(3)' CALL IDFCOPY(IDF(3),IDF(1)); CALL IDFCOPY(IDF(3),IDF(2)) IF(.NOT.IDFREADSCALE(IDF(1)%FNAME,IDF(1),2,1,0.0,0))STOP 'Cannot read data for IDF(1)' IF(.NOT.IDFREADSCALE(IDF(2)%FNAME,IDF(2),2,1,0.0,0))STOP 'Cannot read data for IDF(2)' TV=0.0 DO IROW=1,IDF(1)%NROW DO ICOL=1,IDF(1)%NCOL T=IDF(1)%X(ICOL,IROW) B=IDF(2)%X(ICOL,IROW) IF(T.NE.IDF(1)%NODATA.AND.B.NE.IDF(2)%NODATA)THEN IF(T.GT.DRNLEVEL.AND.T.GT.B)THEN !# base if salt-water boundary IF(DENSITY_FRESH.GT.0.0.AND.DENSITY_SALT.GT.0.0)B=MAX(B,DRNLEVEL-T*R) IDF(3)%X(ICOL,IROW)=T-B TV=TV+(IDF(3)%X(ICOL,IROW)*POR*IDF(3)%DX*IDF(3)%DY) ELSE IDF(3)%X(ICOL,IROW)=0.0 ENDIF ELSE IDF(3)%X(ICOL,IROW)=IDF(3)%NODATA ENDIF ENDDO ENDDO IF(.NOT.IDFWRITE(IDF(3),IDF(3)%FNAME,1))STOP 'Cannot write result IDF(3)' CALL IDFDEALLOCATE(IDF,SIZE(IDF)); DEALLOCATE(IDF) WRITE(*,'(A,F17.5)') 'Total volume = ',TV END SUBROUTINE IMODBATCH_VOLUME_SALT !###====================================================================== SUBROUTINE IMODBATCH_CLIPVOXELS() !###====================================================================== IMPLICIT NONE TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: IDF CHARACTER(LEN=256) :: DIRNAME,OUTPUTNAME CHARACTER(LEN=52) :: WC INTEGER :: I,J,IROW,ICOL,ISCALE,NZ REAL :: DZ,MINZ,MAXZ,Z1,Z2 REAL,ALLOCATABLE,DIMENSION(:) :: ZT,ZB INTEGER,ALLOCATABLE,DIMENSION(:) :: IORDER CHARACTER(LEN=256),DIMENSION(:),POINTER :: LISTNAME ISCALE=3; IF(UTL_READINITFILE('ISCALE',LINE,IU,1))READ(LINE,*) ISCALE WRITE(*,'(A,I5)') 'ISCALE=',ISCALE DZ=1.0; IF(UTL_READINITFILE('DZ',LINE,IU,1))READ(LINE,*) DZ WRITE(*,'(A,F15.7)') 'DZ=',DZ ALLOCATE(IDF(5)); DO I=1,SIZE(IDF); CALL IDFNULLIFY(IDF(I)); ENDDO IF(.NOT.UTL_READINITFILE('TOPIDF',LINE,IU,0))RETURN READ(LINE,'(A)') IDF(1)%FNAME; WRITE(*,'(A)') 'TOPIDF='//TRIM(IDF(1)%FNAME) IF(.NOT.UTL_READINITFILE('BOTIDF',LINE,IU,0))RETURN READ(LINE,'(A)') IDF(2)%FNAME; WRITE(*,'(A)') 'BOTIDF='//TRIM(IDF(2)%FNAME) IF(.NOT.UTL_READINITFILE('OUTPUTNAME',LINE,IU,0))RETURN READ(LINE,'(A)') OUTPUTNAME; WRITE(*,'(A)') 'OUTPUTNAME='//TRIM(OUTPUTNAME) !## get number of files to be imported IF(.NOT.UTL_READINITFILE('SOURCEDIR',LINE,IU,0))RETURN READ(LINE,*) DIRNAME; WRITE(*,'(A)') 'SOURCEDIR='//TRIM(DIRNAME) WC=DIRNAME(INDEX(DIRNAME,'\',.TRUE.)+1:); DIRNAME=DIRNAME(:INDEX(DIRNAME,'\',.TRUE.)-1) IF(.NOT.IDFREAD(IDF(1),IDF(1)%FNAME,0))STOP 'Cannot read data for IDF(1)' IF(.NOT.IDFREAD(IDF(2),IDF(2)%FNAME,0))STOP 'Cannot read data for IDF(2)' CLOSE(IDF(1)%IU); CLOSE(IDF(2)%IU) IF(.NOT.IDF_EXTENT(2,IDF,IDF(3),2))STOP 'Cannot determing minimal overlapping size.' IF(.NOT.IDFALLOCATEX(IDF(3)))STOP ' Cannot allocate memory for IDF(3)' CALL IDFCOPY(IDF(3),IDF(1)); CALL IDFCOPY(IDF(3),IDF(2)) IF(.NOT.IDFREADSCALE(IDF(1)%FNAME,IDF(1),2,1,0.0,0))STOP 'Cannot read data for IDF(1)' IF(.NOT.IDFREADSCALE(IDF(2)%FNAME,IDF(2),2,1,0.0,0))STOP 'Cannot read data for IDF(2)' IF(.NOT.UTL_DIRINFO_POINTER(DIRNAME,WC,LISTNAME,'F'))RETURN DO I=1,SIZE(LISTNAME); LISTNAME(I)=TRIM(DIRNAME)//'\'//TRIM(LISTNAME(I)); ENDDO ALLOCATE(ZT(SIZE(LISTNAME)),ZB(SIZE(LISTNAME)),IORDER(SIZE(LISTNAME))) !## determine what we have ... DO I=1,SIZE(LISTNAME) IF(.NOT.IDFREAD(IDF(4),LISTNAME(I),0))THEN; WRITE(*,'(A)') 'Cannot read file '//TRIM(LISTNAME(I)); STOP; ENDIF ZT(I)=IDF(4)%TOP; ZB(I)=IDF(4)%BOT ENDDO CALL WSORT(ZT,1,SIZE(ZT),IFLAGS=SORTDESCEND,IORDER=IORDER) !## get minimal/maximal value MINZ=MINVAL(ZB); MAXZ=MAXVAL(ZT) !# make intervals NZ=(MAXZ-MINZ)/DZ CALL IDFCOPY(IDF(1),IDF(4)); CALL IDFCOPY(IDF(1),IDF(5)) Z1=MAXZ DO I=1,NZ Z2=Z1-DZ; IDF(4)%X=0.0; IDF(5)%X=0.0 WRITE(*,'(A,2F15.7)') 'Interval ',Z1,Z2 DO J=1,SIZE(LISTNAME) !## see whether current IDF fits within bandwidth of thickness (dz) IF(ZT(J).LE.Z1.AND.ZB(IORDER(J)).GE.Z2)THEN WRITE(*,'(1X,A)') TRIM(LISTNAME(IORDER(J))) IF(.NOT.IDFREADSCALE(LISTNAME(IORDER(J)),IDF(3),ISCALE,1,0.0,0))STOP 'Cannot read data for IDF(3)' DO IROW=1,IDF(1)%NROW; DO ICOL=1,IDF(1)%NCOL IF(IDF(3)%X(ICOL,IROW).NE.IDF(3)%NODATA)THEN IDF(4)%X(ICOL,IROW)=IDF(4)%X(ICOL,IROW)+1.0 IDF(5)%X(ICOL,IROW)=IDF(5)%X(ICOL,IROW)+LOG(IDF(3)%X(ICOL,IROW)) ENDIF ENDDO; ENDDO ENDIF ENDDO !## compute upscaled values DO IROW=1,IDF(1)%NROW; DO ICOL=1,IDF(1)%NCOL IF(Z1.LE.IDF(1)%X(ICOL,IROW).AND.Z2.GT.IDF(2)%X(ICOL,IROW))THEN IF(IDF(4)%X(ICOL,IROW).GT.0.0)THEN IDF(5)%X(ICOL,IROW)=EXP(IDF(5)%X(ICOL,IROW)/IDF(4)%X(ICOL,IROW)) ELSE IDF(5)%X(ICOL,IROW)=IDF(5)%NODATA ENDIF ELSE IDF(5)%X(ICOL,IROW)=IDF(5)%NODATA ENDIF ENDDO; ENDDO IDF(5)%FNAME=TRIM(OUTPUTNAME)//TRIM(RTOS(Z1,'F',3))//'_'//TRIM(RTOS(Z2,'F',3))//'.IDF' IDF(5)%ITB=INT(1,1); IDF(5)%TOP=Z1; IDF(5)%BOT=Z2 IF(.NOT.IDFWRITE(IDF(5),IDF(5)%FNAME,1))STOP 'Cannot write result IDF(5)' Z1=Z2 ENDDO DEALLOCATE(IORDER,ZT) CALL IDFDEALLOCATE(IDF,SIZE(IDF)); DEALLOCATE(IDF) END SUBROUTINE IMODBATCH_CLIPVOXELS !###====================================================================== SUBROUTINE IMODBATCH_DRNSURF() !###====================================================================== USE MOD_DRNSURF IMPLICIT NONE ALLOCATE(IDF(4)); DO I=1,SIZE(IDF); CALL IDFNULLIFY(IDF(I)); ENDDO IF(.NOT.UTL_READINITFILE('SURFIDF',LINE,IU,0))RETURN READ(LINE,'(A)') IDF(1)%FNAME; WRITE(*,'(A)') 'SURFIDF='//TRIM(IDF(1)%FNAME) IF(.NOT.UTL_READINITFILE('PNTRIDF',LINE,IU,0))RETURN READ(LINE,'(A)') IDF(2)%FNAME; WRITE(*,'(A)') 'PNTRIDF='//TRIM(IDF(2)%FNAME) IF(.NOT.UTL_READINITFILE('LUSEIDF',LINE,IU,0))RETURN READ(LINE,'(A)') IDF(3)%FNAME; WRITE(*,'(A)') 'LUSEIDF='//TRIM(IDF(3)%FNAME) IF(.NOT.UTL_READINITFILE('NLUSE',LINE,IU,0))RETURN READ(LINE,*) NLGN; WRITE(*,'(A,I10)') 'NLUSE=',NLGN !## landuse code to be drainage potentially ALLOCATE(ILGN(NLGN)) DO I=1,NLGN IF(.NOT.UTL_READINITFILE('ILUSE'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) ILGN(I) LINE='ILUSE'//TRIM(ITOS(I))//'='//TRIM(ITOS(ILGN(I))); WRITE(*,'(A)') TRIM(LINE) ENDDO !## percentage to become drainage (0-100%) IF(.NOT.UTL_READINITFILE('TDRAINAGE',LINE,IU,0))RETURN READ(LINE,*) CLB; WRITE(*,'(A,F10.2)') 'TDRAINAGE=',CLB !## Give Absolute AHN-Threshold for determining zones' IF(.NOT.UTL_READINITFILE('TSURFLEVEL',LINE,IU,0))RETURN READ(LINE,*) CRITAHN; WRITE(*,'(A,F10.2)') 'TSURFLEVEL=',CRITAHN !## Give Percentile for determining drainage level within each zone, Percentile (0-100, 50=median)' IF(.NOT.UTL_READINITFILE('PERCENTILE',LINE,IU,0))RETURN READ(LINE,*) SFCT; WRITE(*,'(A,F10.2)') 'PERCENTILE=',SFCT MPW%XMIN=0.0; MPW%YMIN=0.0; MPW%XMAX=0.0; MPW%YMAX=0.0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) MPW%XMIN,MPW%YMIN,MPW%XMAX,MPW%YMAX WRITE(*,'(A,4F10.2)') 'WINDOW=',MPW%XMIN,MPW%YMIN,MPW%XMAX,MPW%YMAX IF(.NOT.UTL_READINITFILE('CELL_SIZE',LINE,IU,0))RETURN READ(LINE,*) CS; WRITE(*,'(A,F10.2)') 'CELL_SIZE=',CS ENDIF IF(.NOT.UTL_READINITFILE('OUTIDF',LINE,IU,0))RETURN READ(LINE,'(A)') IDF(4)%FNAME; WRITE(*,'(A)') 'OUTIDF='//TRIM(IDF(4)%FNAME) CALL DRNSURF_MAIN() CALL IDFDEALLOCATE(IDF,SIZE(IDF)); DEALLOCATE(IDF) END SUBROUTINE IMODBATCH_DRNSURF !###====================================================================== SUBROUTINE IMODBATCH_CREATEEVT() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: HIDF,FIDF CHARACTER(LEN=52) :: WC CHARACTER(LEN=256),DIMENSION(:),POINTER :: HLISTNAME,FLISTNAME TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: F,H INTEGER :: II,I,J,JD1,JD2,IROW,ICOL,MWT REAL :: FV,HV,A,B,SIGA,SIGB,CHI2,Q INTEGER,ALLOCATABLE,DIMENSION(:) :: IP REAL,ALLOCATABLE,DIMENSION(:) :: HC,FC,SIG IF(.NOT.UTL_READINITFILE('FIDF',LINE,IU,0))RETURN READ(LINE,'(A)') FIDF; WRITE(*,'(A)') 'FIDF='//TRIM(FIDF) IF(.NOT.UTL_READINITFILE('HIDF',LINE,IU,0))RETURN READ(LINE,'(A)') HIDF; WRITE(*,'(A)') 'HIDF='//TRIM(HIDF) IF(.NOT.UTL_READINITFILE('SDATE',LINE,IU,0))RETURN READ(LINE,*) JD1; LINE=TRIM(ITOS(JD1)); WRITE(*,'(A)') 'SDATE='//TRIM(LINE) IF(.NOT.UTL_READINITFILE('EDATE',LINE,IU,0))RETURN READ(LINE,*) JD2; LINE=TRIM(ITOS(JD2)); WRITE(*,'(A)') 'EDATE='//TRIM(LINE) JD1=UTL_IDATETOJDATE(JD1); JD2=UTL_IDATETOJDATE(JD2) WC=TRIM(FIDF(INDEX(FIDF,'\',.TRUE.)+1:)); FIDF=FIDF(:INDEX(FIDF,'\',.TRUE.)-1) IF(.NOT.UTL_DIRINFO_POINTER(FIDF,WC,FLISTNAME,'F'))STOP WC=TRIM(HIDF(INDEX(HIDF,'\',.TRUE.)+1:)); HIDF=HIDF(:INDEX(HIDF,'\',.TRUE.)-1) IF(.NOT.UTL_DIRINFO_POINTER(HIDF,WC,HLISTNAME,'F'))STOP ALLOCATE(F(SIZE(FLISTNAME)),H(SIZE(HLISTNAME))) DO I=1,SIZE(F); CALL IDFNULLIFY(F(I)); ENDDO; DO I=1,SIZE(H); CALL IDFNULLIFY(H(I)); ENDDO DO I=1,SIZE(FLISTNAME); F(I)%JD=UTL_IDFGETDATE(FLISTNAME(I)); IF(F(I)%JD.NE.0)F(I)%JD=UTL_IDATETOJDATE(F(I)%JD); ENDDO DO I=1,SIZE(HLISTNAME); H(I)%JD=UTL_IDFGETDATE(HLISTNAME(I)); IF(H(I)%JD.NE.0)H(I)%JD=UTL_IDATETOJDATE(H(I)%JD); ENDDO DO I=1,SIZE(FLISTNAME) IF(F(I)%JD.LT.JD1.OR.F(I)%JD.GT.JD2)THEN; F(I)%JD=0; CYCLE; ENDIF ENDDO !## search for overlapping files ALLOCATE(IP(SIZE(FLISTNAME))); IP=0 DO I=1,SIZE(FLISTNAME) IF(F(I)%JD.GT.0)THEN DO J=1,SIZE(HLISTNAME); IF(H(J)%JD.EQ.F(I)%JD)IP(I)=J; ENDDO ENDIF ENDDO !## open files - that overlap DO I=1,SIZE(FLISTNAME) J=IP(I); IF(J.GT.0)THEN IF(.NOT.IDFREAD(F(I),TRIM(FIDF)//'\'//TRIM(FLISTNAME(I)),0))STOP IF(.NOT.IDFREAD(H(J),TRIM(HIDF)//'\'//TRIM(HLISTNAME(J)),0))STOP ENDIF ENDDO ALLOCATE(HC(SIZE(FLISTNAME)),FC(SIZE(FLISTNAME)),SIG(SIZE(FLISTNAME))) SIG=0.0; MWT=0 OPEN(10,FILE='D:\DUMP\REGRESSION.TXT',STATUS='UNKNOWN') DO IROW=1,F(1)%NROW; DO ICOL=1,F(1)%NCOL II=0; DO I=1,SIZE(FLISTNAME) J=IP(I); IF(J.GT.0)THEN FV=IDFGETVAL(F(I),IROW,ICOL) HV=IDFGETVAL(H(J),IROW,ICOL) IF(FV.NE.F(I)%NODATA.AND.HV.NE.H(J)%NODATA)THEN II=II+1; HC(II)=HV; FC(II)=MAX(0.0,MIN(1.0,FV)) ENDIF ENDIF ENDDO IF(II.GT.0)THEN CALL UTL_FIT_REGRESSION(HC,FC,II,SIG,MWT,B,A,SIGA,SIGB,CHI2,Q) WRITE(10,'(2I10)') ICOL,IROW DO I=1,II; WRITE(10,'(I10,2F10.2)') I,HC(I),FC(I); ENDDO WRITE(10,'(6F10.2)') A,B,SIGA,SIGB,CHI2,Q !## y=ax+b ENDIF ENDDO; ENDDO CLOSE(10) ! DO I=1,SIZE(HLISTNAME); IF(.NOT.IDFREAD(H(I),TRIM(HIDF)//'\'//TRIM(HLISTNAME(I)),0))STOP; ENDDO ! IF(.NOT.IDFREAD(IDF(1),IDF(1)%FNAME,1))RETURN END SUBROUTINE IMODBATCH_CREATEEVT !###====================================================================== SUBROUTINE IMODBATCH_CREATESUBMODELS() !###====================================================================== IMPLICIT NONE TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: IDF CHARACTER(LEN=256) :: SUBMODELFILE CHARACTER(LEN=256) :: STRING REAL :: DSIZE,X1,Y1,X,Y,F REAL :: CSIZE,DX,DY,MAXS REAL,DIMENSION(4) :: BOXS REAL,ALLOCATABLE,DIMENSION(:) :: IDLIST LOGICAL :: LCLICK LOGICAL,DIMENSION(4) :: LTRB INTEGER :: II,I,JJ,J,IX,IY,JU,KU,LU,MU,IROW,ICOL,IR1,IR2,IC1,IC2,NID INTEGER :: MAXDEELMOD INTEGER,ALLOCATABLE,DIMENSION(:,:) :: DEELMOD TYPE POLOBJ REAL :: X1,X2,Y1,Y2,CS,XMIN,YMIN,XMAX,YMAX INTEGER :: ILOAD INTEGER :: ID ! FR CHARACTER(LEN=52) :: NAME END TYPE POLOBJ TYPE(POLOBJ),ALLOCATABLE,DIMENSION(:,:) :: POL !## FR 20131016: add IDF with "deelmodel" numbers !## FR 20131016: add TXT with list of "deelmodellen" for each unique value in given SOURCEDIR !## smaller than to be possible to be added to another one F=0.25 IF(.NOT.UTL_READINITFILE('DSIZE',LINE,IU,0))RETURN READ(LINE,*) DSIZE; WRITE(*,'(A,F10.2)') 'DSIZE=',DSIZE IF(.NOT.UTL_READINITFILE('CSIZE',LINE,IU,0))RETURN READ(LINE,*) CSIZE; WRITE(*,'(A,F10.2)') 'CSIZE=',CSIZE ALLOCATE(IDF(2)); DO I=1,SIZE(IDF); CALL IDFNULLIFY(IDF(I)); ENDDO ! FR 20131016 IF(.NOT.UTL_READINITFILE('IBOUND',LINE,IU,0))RETURN READ(LINE,'(A)') IDF(1)%FNAME; LINE='IBOUND='; WRITE(*,'(A)') TRIM(LINE)//TRIM(IDF(1)%FNAME) IF(.NOT.IDFREAD(IDF(1),IDF(1)%FNAME,1))RETURN ! FR 20131016 CALL IDFCOPY(IDF(1),IDF(2)); IDF(2)%X=IDF(2)%NODATA ! FR 20131016 IF(.NOT.UTL_READINITFILE('SUBMODELFILE',LINE,IU,0))RETURN READ(LINE,'(A)') SUBMODELFILE; LINE='SUBMODELFILE='; WRITE(*,'(A)') TRIM(LINE)//TRIM(SUBMODELFILE) I=INDEX(SUBMODELFILE,'.',.TRUE.); IF(I.GT.0)SUBMODELFILE=SUBMODELFILE(:I-1) JU=UTL_GETUNIT(); OPEN(JU,FILE=TRIM(SUBMODELFILE)//'.RUN',STATUS='UNKNOWN',ACTION='WRITE') KU=UTL_GETUNIT(); OPEN(KU,FILE=TRIM(SUBMODELFILE)//'.GEN',STATUS='UNKNOWN',ACTION='WRITE') LU=UTL_GETUNIT(); OPEN(LU,FILE=TRIM(SUBMODELFILE)//'.IPF',STATUS='UNKNOWN',ACTION='WRITE') IDF(2)%FNAME=TRIM(SUBMODELFILE)//'.IDF' ! FR 20131016 MU=UTL_GETUNIT(); OPEN(MU,FILE=TRIM(SUBMODELFILE)//'.TXT',STATUS='UNKNOWN',ACTION='WRITE') ! FR 20131016 IX=(IDF(1)%XMAX-IDF(1)%XMIN)/DSIZE; IX=IX+1 IY=(IDF(1)%YMAX-IDF(1)%YMIN)/DSIZE; IY=IY+1 ALLOCATE(POL(IX,IY)) !## fill polygons II=0; Y1=IDF(1)%YMAX+DSIZE DO J=1,IY; Y1=Y1-DSIZE; X1=IDF(1)%XMIN; DO I=1,IX II=II+1 POL(I,J)%NAME='SUBMODEL'//TRIM(ITOS(POL(I,J)%ID)) POL(I,J)%X1=X1; POL(I,J)%Y2=Y1 POL(I,J)%X2=MIN(IDF(1)%XMAX,X1+DSIZE); POL(I,J)%Y1=MAX(IDF(1)%YMIN,Y1-DSIZE) POL(I,J)%CS=CSIZE CALL IDFIROWICOL(IDF(1),IR1,IC1,POL(I,J)%X1,POL(I,J)%Y2) CALL IDFIROWICOL(IDF(1),IR2,IC2,POL(I,J)%X2,POL(I,J)%Y1) IF(IC2.EQ.0)IC2=IDF(1)%NCOL; IF(IR2.EQ.0)IR2=IDF(1)%NROW IC1=MAX(1,IC1); IC2=MIN(IC2,IDF(1)%NCOL) IR1=MAX(1,IR1); IR2=MIN(IR2,IDF(1)%NROW) POL(I,J)%ILOAD=0 DO IROW=IR1,IR2; DO ICOL=IC1,IC2 IF(IDF(1)%X(ICOL,IROW).GT.0)POL(I,J)%ILOAD=POL(I,J)%ILOAD+1 ! IF(IDF(1)%X(ICOL,IROW).NE.0)POL(I,J)%ILOAD=POL(I,J)%ILOAD+1 ENDDO; ENDDO !## adjust boxsize to NODATA value POL(I,J)%XMIN=POL(I,J)%X2; POL(I,J)%YMIN=POL(I,J)%Y2; POL(I,J)%XMAX=POL(I,J)%X1; POL(I,J)%YMAX=POL(I,J)%Y1 DO IROW=IR1,IR2 DO ICOL=IC1,IC2 CALL IDFGETLOC(IDF(1),IROW,ICOL,X,Y); X=X-(IDF(1)%DX/2.0); Y=Y+(IDF(1)%DX/2.0) IF(X.GE.POL(I,J)%X2)EXIT; IF(Y.LE.POL(I,J)%Y1)EXIT ! IF(IDF(1)%X(ICOL,IROW).NE.0)THEN IF(IDF(1)%X(ICOL,IROW).GT.0)THEN POL(I,J)%XMIN=MIN(POL(I,J)%XMIN,X) POL(I,J)%XMAX=MAX(POL(I,J)%XMAX,X+IDF(1)%DX) POL(I,J)%YMIN=MIN(POL(I,J)%YMIN,Y-IDF(1)%DX) POL(I,J)%YMAX=MAX(POL(I,J)%YMAX,Y) ENDIF ENDDO ENDDO X1=POL(I,J)%X2 POL(I,J)%X1=POL(I,J)%XMIN; POL(I,J)%Y1=POL(I,J)%YMIN POL(I,J)%X2=POL(I,J)%XMAX; POL(I,J)%Y2=POL(I,J)%YMAX IF(X1.GE.IDF(1)%XMAX)EXIT ENDDO; ENDDO !GOTO 10 DO I=1,SIZE(POL,1); DO J=1,SIZE(POL,2) IF(POL(I,J)%ILOAD.GT.0)THEN DX=POL(I,J)%X2-POL(I,J)%X1; DY=POL(I,J)%Y2-POL(I,J)%Y1 !## see whether submodel need to be added to another one IF(DX.LT.F*DSIZE.OR.DY.LT.F*DSIZE)THEN LTRB=.FALSE. IF(I.GT.1)THEN IF(POL(I-1,J)%X2.EQ.POL(I,J)%X1)THEN DX=POL(I-1,J)%X2-POL(I-1,J)%X1; DY=POL(I-1,J)%Y2-POL(I-1,J)%Y1 BOXS(1)=DX*DY IF(POL(I-1,J)%ILOAD.GT.0)LTRB(1)=.TRUE. ENDIF ENDIF IF(I.LT.SIZE(POL,1))THEN IF(POL(I+1,J)%X1.EQ.POL(I,J)%X2)THEN DX=POL(I+1,J)%X2-POL(I+1,J)%X1; DY=POL(I+1,J)%Y2-POL(I+1,J)%Y1 BOXS(3)=DX*DY IF(POL(I+1,J)%ILOAD.GT.0)LTRB(3)=.TRUE. ENDIF ENDIF IF(J.GT.1)THEN IF(POL(I,J-1)%Y1.EQ.POL(I,J)%Y2)THEN DX=POL(I,J-1)%X2-POL(I,J-1)%X1; DY=POL(I,J-1)%Y2-POL(I,J-1)%Y1 BOXS(2)=DX*DY IF(POL(I,J-1)%ILOAD.GT.0)LTRB(2)=.TRUE. ENDIF ENDIF IF(J.LT.SIZE(POL,2))THEN IF(POL(I,J+1)%Y2.EQ.POL(I,J)%Y1)THEN DX=POL(I,J+1)%X2-POL(I,J+1)%X1; DY=POL(I,J+1)%Y2-POL(I,J+1)%Y1 BOXS(4)=DX*DY IF(POL(I,J+1)%ILOAD.GT.0)LTRB(4)=.TRUE. ENDIF ENDIF !## find most appropriate submodel JJ=0; MAXS=0; DO II=1,4 IF(LTRB(II))THEN IF(BOXS(II).GT.MAXS)THEN; MAXS=BOXS(II); JJ=II; ENDIF ENDIF ENDDO !## extent submodel jj LCLICK=.FALSE. SELECT CASE (JJ) CASE (0) !WRITE(*,*) CASE (1) !## left IF(POL(I,J)%X2-POL(I-1,J)%X1.LT.DSIZE*(1.0+F))THEN; POL(I-1,J)%X2=POL(I,J)%X2; LCLICK=.TRUE.; ENDIF CASE (2) !## top IF(POL(I,J-1)%Y2-POL(I,J)%Y1.LT.DSIZE*(1.0+F))THEN; POL(I,J-1)%Y1=POL(I,J)%Y1; LCLICK=.TRUE.; ENDIF CASE (3) !## right IF(POL(I+1,J)%X2-POL(I,J)%X1.LT.DSIZE*(1.0+F))THEN; POL(I+1,J)%X1=POL(I,J)%X1; LCLICK=.TRUE.; ENDIF CASE (4) !## bottom IF(POL(I,J)%Y2-POL(I,J+1)%Y1.LT.DSIZE*(1.0+F))THEN; POL(I,J+1)%Y2=POL(I,J)%Y2; LCLICK=.TRUE.; ENDIF END SELECT IF(LCLICK)POL(I,J)%ILOAD=0 ENDIF ENDIF ENDDO; ENDDO !10 CONTINUE !## Update Object POL metadata before writing data MAXDEELMOD=0 II=0 DO I=1,SIZE(POL,1); DO J=1,SIZE(POL,2) ; IF(POL(I,J)%ILOAD.GT.0)THEN POL(I,J)%XMIN=MIN(POL(I,J)%X1,POL(I,J)%X2) POL(I,J)%XMAX=MAX(POL(I,J)%X1,POL(I,J)%X2) POL(I,J)%YMIN=MIN(POL(I,J)%Y1,POL(I,J)%Y2) POL(I,J)%YMAX=MAX(POL(I,J)%Y1,POL(I,J)%Y2) CALL IDFIROWICOL(IDF(2),IR1,IC1,POL(I,J)%XMIN,POL(I,J)%YMAX) CALL IDFIROWICOL(IDF(2),IR2,IC2,POL(I,J)%XMAX,POL(I,J)%YMIN) IF(IC2.EQ.0)IC2=IDF(1)%NCOL ; IF(IR2.EQ.0)IR2=IDF(1)%NROW IC1=MAX(1,IC1); IC2=MIN(IC2,IDF(1)%NCOL) ; IR1=MAX(1,IR1); IR2=MIN(IR2,IDF(1)%NROW) POL(I,J)%ILOAD=0 DO IROW = IR1,IR2-1 ; DO ICOL = IC1,IC2-1 IF(IDF(1)%X(ICOL,IROW).GT.0) POL(I,J)%ILOAD=POL(I,J)%ILOAD+1 ENDDO ; ENDDO POL(I,J)%ID=0 POL(I,J)%NAME='' IF(POL(I,J)%ILOAD.GT.0) THEN II=II+1 POL(I,J)%ID=II POL(I,J)%NAME='SUBMODEL'//TRIM(ITOS(POL(I,J)%ID)) MAXDEELMOD=MAX(MAXDEELMOD,POL(I,J)%ID) ENDIF ENDIF ;ENDDO ; ENDDO !## Write GEN and RUN file ! FR 20131016 DO I=1,SIZE(POL,1); DO J=1,SIZE(POL,2) IF(POL(I,J)%ILOAD.GT.0)THEN WRITE(JU,'(I1,6(1X,F10.2),A)') 1,MIN(POL(I,J)%X1,POL(I,J)%X2),MIN(POL(I,J)%Y1,POL(I,J)%Y2), & MAX(POL(I,J)%X1,POL(I,J)%X2),MAX(POL(I,J)%Y1,POL(I,J)%Y2),POL(I,J)%CS,3000.0,','//TRIM(POL(I,J)%NAME) WRITE(KU,'(2I10)') POL(I,J)%ID,POL(I,J)%ILOAD WRITE(KU,'(2(F10.2,A))') POL(I,J)%X1,',',POL(I,J)%Y2 WRITE(KU,'(2(F10.2,A))') POL(I,J)%X2,',',POL(I,J)%Y2 WRITE(KU,'(2(F10.2,A))') POL(I,J)%X2,',',POL(I,J)%Y1 WRITE(KU,'(2(F10.2,A))') POL(I,J)%X1,',',POL(I,J)%Y1 WRITE(KU,'(2(F10.2,A))') POL(I,J)%X1,',',POL(I,J)%Y2 WRITE(KU,'(A)') 'END' ENDIF ENDDO; ENDDO WRITE(KU,'(A)') 'END' !## write IDF file ! ID of Deelmodel as IDF ! FR 20131016 DO I=1,SIZE(POL,1); DO J=1,SIZE(POL,2) IF(POL(I,J)%ILOAD.GT.0) THEN CALL IDFIROWICOL(IDF(2),IR1,IC1,POL(I,J)%XMIN,POL(I,J)%YMAX) CALL IDFIROWICOL(IDF(2),IR2,IC2,POL(I,J)%XMAX,POL(I,J)%YMIN) IF(IC2.EQ.0)IC2=IDF(1)%NCOL ; IF(IR2.EQ.0)IR2=IDF(1)%NROW IC1=MAX(1,IC1); IC2=MIN(IC2,IDF(1)%NCOL) ; IR1=MAX(1,IR1); IR2=MIN(IR2,IDF(1)%NROW) DO IROW = IR1,IR2-1 ; DO ICOL = IC1,IC2-1 IDF(2)%X(ICOL,IROW)=POL(I,J)%ID ENDDO ; ENDDO ENDIF ENDDO; ENDDO IF(.NOT.IDFWRITE(IDF(2),IDF(2)%FNAME,1))RETURN !## Write IPF file WRITE(LU,*) MAXDEELMOD WRITE(LU,*) 4 WRITE(LU,*) 'X' WRITE(LU,*) 'Y' WRITE(LU,*) 'ID' WRITE(LU,*) 'LOAD' WRITE(LU,*) '0,TXT' DO I=1,SIZE(POL,1); DO J=1,SIZE(POL,2) IF(POL(I,J)%ILOAD.GT.0)THEN WRITE(LU,*) 0.5*(POL(I,J)%X1+POL(I,J)%X2), 0.5*(POL(I,J)%Y1+POL(I,J)%Y2), POL(I,J)%ID, POL(I,J)%ILOAD ENDIF ENDDO; ENDDO !## write TXT file !## Make list of Deelmodellen for each unique value in pointer IDF ! FR 20131016 ALLOCATE(IDLIST(IDF(2)%NCOL*IDF(2)%NROW)) !for 1D sort action IDLIST=0 DO IROW = 1,IDF(2)%NROW ; DO ICOL = 1,IDF(2)%NCOL IDLIST((IROW-1)*IDF(2)%NCOL+ICOL) = IDF(1)%X(ICOL,IROW) ENDDO ; ENDDO CALL UTL_GETUNIQUE(IDLIST,IDF(2)%NCOL*IDF(2)%NROW,NID,IDF(2)%NODATA) ALLOCATE(DEELMOD(NID,MAXDEELMOD)) DEELMOD=0 DO IROW = 1,IDF(2)%NROW ; DO ICOL = 1,IDF(2)%NCOL IF(IDF(2)%X(ICOL,IROW).GT.0)THEN DO I=1,NID IF(IDF(1)%X(ICOL,IROW).EQ.IDLIST(I)) DEELMOD(I,REAL(IDF(2)%X(ICOL,IROW)))= 1 ENDDO ENDIF ENDDO ; ENDDO DO II=1,NID WRITE(MU,*) '-----------------------------' WRITE(MU,*) 'unique pointer ID:,',IDLIST(II) WRITE(MU,*) 'covered by deelmodellen:' STRING=' ' DO JJ=1,MAXDEELMOD IF(DEELMOD(II,JJ).EQ.1) WRITE(STRING,'(A,I4,A)') TRIM(ADJUSTL(STRING)),JJ,',' IF(LEN(TRIM(STRING)).GT.100.OR.JJ.EQ.MAXDEELMOD)THEN ; WRITE(MU,'(A256)') ADJUSTL(STRING) ; STRING=' ' ; ENDIF ENDDO DO JJ=1,MAXDEELMOD IF(DEELMOD(II,JJ).EQ.1)THEN DO I=1,SIZE(POL,1); DO J=1,SIZE(POL,2) IF(POL(I,J)%ID.EQ.JJ) THEN WRITE(MU,'(I1,6(1X,F10.2),A)') 1, & MIN(POL(I,J)%X1,POL(I,J)%X2),MIN(POL(I,J)%Y1,POL(I,J)%Y2), & MAX(POL(I,J)%X1,POL(I,J)%X2),MAX(POL(I,J)%Y1,POL(I,J)%Y2),POL(I,J)%CS,3000.0,','//TRIM(POL(I,J)%NAME) EXIT ENDIF ENDDO ; ENDDO ENDIF ENDDO ENDDO CLOSE(JU); CLOSE(KU); CLOSE(LU) ; CLOSE(MU) END SUBROUTINE IMODBATCH_CREATESUBMODELS !###====================================================================== SUBROUTINE IMODBATCH_CREATEIBOUND() !###====================================================================== IMPLICIT NONE INTEGER :: NLAY,I,J,IROW,ICOL TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:,:) :: IDF CHARACTER(LEN=256) :: RESULTDIR REAL :: T,B IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) NLAY; WRITE(*,'(A,I10)') 'NLAY=',NLAY IF(.NOT.UTL_READINITFILE('RESULTDIR',LINE,IU,0))RETURN READ(LINE,*) RESULTDIR; WRITE(*,'(A)') 'RESULTDIR='//RESULTDIR ALLOCATE(IDF(NLAY,2)); DO I=1,SIZE(IDF,1); DO J=1,SIZE(IDF,2); CALL IDFNULLIFY(IDF(I,J)); ENDDO; ENDDO DO I=1,NLAY IF(.NOT.UTL_READINITFILE('TOP_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) IDF(I,1)%FNAME; LINE='TOP_L'//TRIM(ITOS(I))//'='; WRITE(*,'(A)') TRIM(LINE)//TRIM(IDF(I,1)%FNAME) IF(.NOT.UTL_READINITFILE('BOT_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) IDF(I,2)%FNAME; LINE='BOT_L'//TRIM(ITOS(I))//'='; WRITE(*,'(A)') TRIM(LINE)//TRIM(IDF(I,2)%FNAME) ENDDO DO I=1,NLAY IF(.NOT.IDFREAD(IDF(I,1),IDF(I,1)%FNAME,1))RETURN IF(.NOT.IDFREAD(IDF(I,2),IDF(I,2)%FNAME,1))RETURN ENDDO DO IROW=1,IDF(1,1)%NROW; DO ICOL=1,IDF(1,1)%NCOL DO I=NLAY,1,-1 T=IDF(I,1)%X(ICOL,IROW); B=IDF(I,2)%X(ICOL,IROW) IF(T-B.GT.0.0)EXIT IDF(I,1)%X(ICOL,IROW)=0.0 ENDDO DO J=I,1,-1; IDF(J,1)%X(ICOL,IROW)=1.0; ENDDO ENDDO; ENDDO CALL UTL_CREATEDIR(RESULTDIR) DO I=1,NLAY IDF(I,1)%FNAME=TRIM(RESULTDIR)//'\IBOUND_L'//TRIM(ITOS(I))//'.IDF' IF(.NOT.IDFWRITE(IDF(I,1),IDF(I,1)%FNAME,1))RETURN ENDDO END SUBROUTINE IMODBATCH_CREATEIBOUND !###====================================================================== SUBROUTINE IMODBATCH_IDFGEN2GEN3D() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: GENFILE_IN,GENFILE_OUT TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: IDF INTEGER :: I,IOS,ID REAL :: XSAMPLING INTEGER,DIMENSION(2) :: JU DOUBLE PRECISION,DIMENSION(2) :: X,Y ALLOCATE(IDF(2)); DO I=1,SIZE(IDF); CALL IDFNULLIFY(IDF(I)); ENDDO IF(.NOT.UTL_READINITFILE('GENFILE_IN',LINE,IU,0))RETURN READ(LINE,*) GENFILE_IN; WRITE(*,'(A)') 'GENFILE_IN='//TRIM(GENFILE_IN) IF(.NOT.UTL_READINITFILE('IDF_TOP',LINE,IU,0))RETURN READ(LINE,*) IDF(1)%FNAME; WRITE(*,'(A)') 'IDF_TOP='//TRIM(IDF(1)%FNAME) IF(.NOT.UTL_READINITFILE('IDF_BOT',LINE,IU,0))RETURN READ(LINE,*) IDF(2)%FNAME; WRITE(*,'(A)') 'IDF_BOT='//TRIM(IDF(2)%FNAME) IF(.NOT.UTL_READINITFILE('GENFILE_OUT',LINE,IU,0))RETURN READ(LINE,*) GENFILE_OUT; WRITE(*,'(A)') 'GENFILE_OUT='//TRIM(GENFILE_OUT) XSAMPLING=0.0; IF(UTL_READINITFILE('XSAMPLING',LINE,IU,1))READ(LINE,*) XSAMPLING JU(1)=UTL_GETUNIT(); OPEN(JU(1),FILE=GENFILE_IN ,STATUS='OLD' ,ACTION='READ') CALL UTL_CREATEDIR(GENFILE_OUT(:INDEX(GENFILE_OUT,'\',.TRUE.)-1)) JU(2)=UTL_GETUNIT(); OPEN(JU(2),FILE=GENFILE_OUT,STATUS='UNKNOWN',ACTION='WRITE') DO I=1,SIZE(IDF); IF(.NOT.IDFREAD(IDF(I),IDF(I)%FNAME,0))RETURN; ENDDO IF(XSAMPLING.EQ.0.0)XSAMPLING=IDF(1)%DX WRITE(*,'(A,F10.2)') 'XSAMPLING=',XSAMPLING DO READ(JU(1),*,IOSTAT=IOS) ID IF(IOS.NE.0)EXIT I=0; DO I=I+1; READ(JU(1),*,IOSTAT=IOS) X(2),Y(2) IF(IOS.NE.0)EXIT IF(I.GT.1)CALL IMODBATCH_SAMPLEPOINTS(ID,JU(2),IDF,X,Y,XSAMPLING) X(1)=X(2); Y(1)=Y(2) ENDDO ENDDO WRITE(JU(2),*) 'END' DO I=1,2; CLOSE(JU(I)); ENDDO END SUBROUTINE IMODBATCH_IDFGEN2GEN3D !###====================================================================== SUBROUTINE IMODBATCH_RUNFILE() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: RUNFILE,PRJFILE INTEGER :: IMODE,N IMODE=0; PBMAN%IFORMAT=0; PBMAN%TIMFNAME=''; PBMAN%ISOLVE=0; PBMAN%SSYSTEM=0 PBMAN%NSTEP=1; PBMAN%NMULT=1.0; PBMAN%ISTEADY=0; PBMAN%MINKD=0.0; PBMAN%MINC=0.0 PBMAN%ICONCHK=0; PBMAN%UNCONFINED=0; PBMAN%IPEST=0; PBMAN%IWINDOW=0 IF(UTL_READINITFILE('PRJFILE_IN',LINE,IU,1))THEN IMODE=1 READ(LINE,*) PRJFILE; WRITE(*,'(A12,A)') 'PRJFILE_IN=',TRIM(PRJFILE) IF(UTL_READINITFILE('RUNFILE_OUT',LINE,IU,1))THEN READ(LINE,*) RUNFILE; WRITE(*,'(A12,A)') 'RUNFILE_OUT=',TRIM(RUNFILE) PBMAN%IFORMAT=1 ENDIF IF(UTL_READINITFILE('NAMFILE_OUT',LINE,IU,1))THEN READ(LINE,*) RUNFILE; WRITE(*,'(A12,A)') 'NAMFILE_OUT=',TRIM(RUNFILE) PBMAN%IFORMAT=2 ENDIF !## more specific options to create a runfile IF(.NOT.UTL_READINITFILE('ISS',LINE,IU,0))RETURN READ(LINE,*) PBMAN%ISS; WRITE(*,'(A12,I1)') 'ISS=',PBMAN%ISS !## transient IF(PBMAN%ISS.EQ.1)THEN !## tim-file? IF(UTL_READINITFILE('TIMFNAME',LINE,IU,1))THEN READ(LINE,*) PBMAN%TIMFNAME; WRITE(*,'(A12,A)') 'TIMFNAME=',TRIM(PBMAN%TIMFNAME) ELSE !## sdate IF(.NOT.UTL_READINITFILE('SDATE',LINE,IU,0))RETURN READ(LINE,*) PBMAN%SDATE; WRITE(*,'(A12,I14)') 'SDATE=',PBMAN%SDATE !## edate IF(.NOT.UTL_READINITFILE('EDATE',LINE,IU,0))RETURN READ(LINE,*) PBMAN%EDATE; WRITE(*,'(A12,I14)') 'EDATE=',PBMAN%EDATE !## type of interval IF(.NOT.UTL_READINITFILE('ITT',LINE,IU,0))RETURN READ(LINE,*) PBMAN%ITT; WRITE(*,'(A12,I14)') 'ITT=',PBMAN%ITT SELECT CASE (PBMAN%ITT) CASE (1:5,6,7) !## timesteps IF(.NOT.UTL_READINITFILE('IDT',LINE,IU,0))RETURN READ(LINE,*) PBMAN%IDT; WRITE(*,'(A12,I14)') 'IDT=',PBMAN%IDT END SELECT SELECT CASE (PBMAN%ITT) CASE (1) WRITE(*,'(A,I5,A)') 'Time step: ',PBMAN%IDT,' hours' CASE (2) WRITE(*,'(A,I5,A)') 'Time step: ',PBMAN%IDT,' days' CASE (3) WRITE(*,'(A,I5,A)') 'Time step: ',PBMAN%IDT,' weeks' CASE (4) WRITE(*,'(A,I5,A)') 'Time step: decades',PBMAN%IDT,' days' CASE (5) WRITE(*,'(A)') 'Time step: every 14/28' CASE (6) WRITE(*,'(A,I5,A)') 'Time step: ',PBMAN%IDT,' months' CASE (7) WRITE(*,'(A,I5,A)') 'Time step: ',PBMAN%IDT,' years' CASE (8) WRITE(*,'(A)') 'Time step: depending on packages'; PBMAN%IDT=1 END SELECT IF(UTL_READINITFILE('NSTEP',LINE,IU,1))READ(LINE,*) PBMAN%NSTEP WRITE(*,'(A12,I10)') 'NSTEP=',PBMAN%NSTEP IF(UTL_READINITFILE('NMULT',LINE,IU,1))READ(LINE,*) PBMAN%NMULT WRITE(*,'(A12,F10.2)') 'NMULT=',PBMAN%NMULT IF(UTL_READINITFILE('ISTEADY',LINE,IU,1))READ(LINE,*) PBMAN%ISTEADY WRITE(*,'(A12,I10)') 'ISTEADY=',PBMAN%ISTEADY ENDIF ENDIF IF(UTL_READINITFILE('SSYSTEM',LINE,IU,1))READ(LINE,*) PBMAN%SSYSTEM WRITE(*,'(A12,I1)') 'SSYSTEM=',PBMAN%SSYSTEM IF(.NOT.IMODBATCH_READPOINTER(N,PBMAN%SAVESHD,'SAVESHD',1,EXCLVALUE=0))RETURN IF(.NOT.IMODBATCH_READPOINTER(N,PBMAN%SAVEFLX,'SAVEFLX',1,EXCLVALUE=0))RETURN IF(.NOT.IMODBATCH_READPOINTER(N,PBMAN%SAVEUZF,'SAVEUZF',1,EXCLVALUE=0))RETURN IF(.NOT.IMODBATCH_READPOINTER(N,PBMAN%SAVESFR,'SAVESFR',1,EXCLVALUE=0))RETURN IF(.NOT.IMODBATCH_READPOINTER(N,PBMAN%SAVEWEL,'SAVEWEL',1,EXCLVALUE=0))RETURN IF(.NOT.IMODBATCH_READPOINTER(N,PBMAN%SAVEDRN,'SAVEDRN',1,EXCLVALUE=0))RETURN IF(.NOT.IMODBATCH_READPOINTER(N,PBMAN%SAVERIV,'SAVERIV',1,EXCLVALUE=0))RETURN IF(.NOT.IMODBATCH_READPOINTER(N,PBMAN%SAVEGHB,'SAVEGHB',1,EXCLVALUE=0))RETURN IF(.NOT.IMODBATCH_READPOINTER(N,PBMAN%SAVERCH,'SAVERCH',1,EXCLVALUE=0))RETURN IF(.NOT.IMODBATCH_READPOINTER(N,PBMAN%SAVEEVT,'SAVEEVT',1,EXCLVALUE=0))RETURN IF(.NOT.IMODBATCH_READPOINTER(N,PBMAN%SAVEMNW,'SAVEMNW',1,EXCLVALUE=0))RETURN !## packages SELECT CASE (PBMAN%IFORMAT) CASE (1) WRITE(*,'(/A/)') 'Export to a RUNFILE' CASE (2) WRITE(*,'(/A/)') 'Export to standard MODFLOW2005 files' ! !## define quasi 3d or 3d discretisation ! IF(.NOT.UTL_READINITFILE('IQUASI3D',LINE,IU,0))RETURN ! READ(LINE,*) I ! IF(I.EQ.0)THEN; LQBD=.FALSE.; WRITE(*,'(/A/)') 'IQUASI3D = 3D DISCRETISATION APPLIED (NO INTERBEDS)'; ENDIF ! IF(I.EQ.1)THEN; LQBD=.TRUE.; WRITE(*,'(/A/)') 'IQUASI3D = QUASI 3D DISCRETISATION APPLIED (USING INTERBEDS)'; ENDIF END SELECT IF(UTL_READINITFILE('ICONCHK',LINE,IU,1))READ(LINE,*) PBMAN%ICONCHK WRITE(*,'(A12,I10)') 'ICONCHK=',PBMAN%ICONCHK !## specify unconfined/parameter estimation IF(PBMAN%IFORMAT.EQ.2)THEN IF(UTL_READINITFILE('UNCONFINED',LINE,IU,1))READ(LINE,*) PBMAN%UNCONFINED WRITE(*,'(A12,I10)') 'UNCONFINED=',PBMAN%UNCONFINED IF(UTL_READINITFILE('IPEST',LINE,IU,1))READ(LINE,*) PBMAN%IPEST WRITE(*,'(A12,I10)') 'IPEST=',PBMAN%IPEST ENDIF IF(UTL_READINITFILE('MINKD',LINE,IU,1))READ(LINE,*) PBMAN%MINKD WRITE(*,'(A12,G10.4)') 'MINKD=',PBMAN%MINKD IF(UTL_READINITFILE('MINC',LINE,IU,1))READ(LINE,*) PBMAN%MINC WRITE(*,'(A12,G10.4)') 'MINC=',PBMAN%MINC IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN PBMAN%IWINDOW=1 READ(LINE,*) PBMAN%XMIN,PBMAN%YMIN,PBMAN%XMAX,PBMAN%YMAX WRITE(*,'(A12,4G15.7)') 'WINDOW=',PBMAN%XMIN,PBMAN%YMIN,PBMAN%XMAX,PBMAN%YMAX IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,0))RETURN READ(LINE,*) PBMAN%CELLSIZE; WRITE(*,'(A12,G15.7)') 'CELLSIZE=',PBMAN%CELLSIZE PBMAN%BUFFER=0.0; IF(UTL_READINITFILE('BUFFER',LINE,IU,1))READ(LINE,*) PBMAN%BUFFER WRITE(*,'(A12,G15.7)') 'BUFFER=',PBMAN%BUFFER ELSE IF(UTL_READINITFILE('CELLSIZE',LINE,IU,1))THEN WRITE(*,'(/A/)') 'The usage of CELLSIZE is only valid in combination with the keyword WINDOW'; RETURN ENDIF IF(UTL_READINITFILE('BUFFER',LINE,IU,1))THEN WRITE(*,'(/A/)') 'The usage of BUFFER is only valid in combination with the keyword WINDOW'; RETURN ENDIF ENDIF IF(UTL_READINITFILE('ISOLVE',LINE,IU,1))READ(LINE,*) PBMAN%ISOLVE WRITE(*,'(A,I1)') 'ISOLVE=',PBMAN%ISOLVE IF(PBMAN%ISOLVE.EQ.1)THEN IF(.NOT.UTL_READINITFILE('MODFLOW',LINE,IU,0))RETURN READ(LINE,*) PBMAN%MODFLOW; WRITE(*,'(A)') 'MODFLOW='//TRIM(PBMAN%MODFLOW) ENDIF ENDIF IF(UTL_READINITFILE('RUNFILE_IN',LINE,IU,1))THEN IMODE=2 READ(LINE,*) RUNFILE; WRITE(*,'(A12,A)') 'RUNFILE_IN=',TRIM(RUNFILE) IF(.NOT.UTL_READINITFILE('PRJFILE_OUT',LINE,IU,0))RETURN READ(LINE,*) PRJFILE; WRITE(*,'(A12,A)') 'PRJFILE_OUT=',TRIM(PRJFILE) ENDIF IF(IMODE.EQ.0)THEN; WRITE(*,'(/A/)') 'Stop not appropriate conversion mode found'; STOP; ENDIF CALL PMANAGERINIT() IF(IMODE.EQ.1)THEN IF(.NOT.PMANAGERPRJ(ID_OPEN ,PRJFILE,1))THEN; WRITE(*,'(/A/)') 'Error reading project file '//TRIM(PRJFILE); STOP; ENDIF IF(.NOT.PMANAGERRUN(ID_SAVERUN,RUNFILE,1))THEN; WRITE(*,'(/A/)') 'Error writing runfile '//TRIM(RUNFILE); STOP; ENDIF ELSEIF(IMODE.EQ.2)THEN IF(.NOT.PMANAGERRUN(ID_OPENRUN,RUNFILE,1))THEN; WRITE(*,'(/A/)') 'Error reading runfile '//TRIM(RUNFILE); STOP; ENDIF IF(.NOT.PMANAGERPRJ(ID_SAVE ,PRJFILE,1))THEN; WRITE(*,'(/A/)') 'Error writing project file '//TRIM(PRJFILE); STOP; ENDIF ENDIF END SUBROUTINE IMODBATCH_RUNFILE !###====================================================================== SUBROUTINE IMODBATCH_FAULTS3D() !###====================================================================== IMPLICIT NONE REAL,PARAMETER :: PI=3.1415 REAL,PARAMETER :: RAD=360.0/(2.0*3.1415) CHARACTER(LEN=256) :: CSVFILE,GENFILE INTEGER :: I,ID,IOS REAL :: X1,Y1,X2,Y2,XN1,XN2,YN1,YN2,Z1,Z2,DIPANGLE,DZ,DX,DY,TNG,DIPDIRECTION INTEGER,DIMENSION(2) :: JU IF(.NOT.UTL_READINITFILE('CSVFILE',LINE,IU,0))RETURN READ(LINE,*) CSVFILE; WRITE(*,'(A)') 'CSVFILE='//TRIM(CSVFILE) IF(.NOT.UTL_READINITFILE('GENFILE',LINE,IU,0))RETURN READ(LINE,*) GENFILE; WRITE(*,'(A)') 'GENFILE='//TRIM(GENFILE) JU(1)=UTL_GETUNIT(); OPEN(JU(1),FILE=CSVFILE ,STATUS='OLD' ,ACTION='READ') JU(2)=UTL_GETUNIT(); OPEN(JU(2),FILE=GENFILE,STATUS='UNKNOWN',ACTION='WRITE') READ(JU(1),*) ID=0; DO READ(JU(1),*,IOSTAT=IOS) X1,Y1,X2,Y2,Z1,Z2,DIPDIRECTION,DIPANGLE IF(IOS.NE.0)EXIT ID=ID+1 WRITE(JU(2),*) ID WRITE(JU(2),'(3F15.7)') X1,Y1,Z1 WRITE(JU(2),'(3F15.7)') X2,Y2,Z1 !## get dipangle into radians DIPANGLE=DIPANGLE/RAD DIPDIRECTION=DIPDIRECTION/RAD !## compute angle of line DX=X2-X1; DY=Y2-Y1; IF(DY.EQ.0.0)TNG=0.0; IF(ABS(DY).GT.0.0)TNG=ATAN2(DY,DX) ! TNG=TNG-0.5*PI TNG=DIPDIRECTION !## compute bottom equivalents DZ=Z1-Z2 !## get projected distance of fault DX=COS(DIPANGLE)*DZ !## use this new length to reduced new coordinates perpendicular to line XN1=X1+COS(TNG)*DZ; YN1=Y1+SIN(TNG)*DZ XN2=X2+COS(TNG)*DZ; YN2=Y2+SIN(TNG)*DZ WRITE(JU(2),'(3F15.7)') XN2,YN2,Z2 WRITE(JU(2),'(3F15.7)') XN1,YN1,Z2 WRITE(JU(2),*) 'END' ENDDO WRITE(JU(2),*) 'END' DO I=1,2; CLOSE(JU(I)); ENDDO END SUBROUTINE IMODBATCH_FAULTS3D !###====================================================================== SUBROUTINE IMODBATCH_SAMPLEPOINTS(ID,JU,IDF,X,Y,XSAMPLING) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: JU,ID TYPE(IDFOBJ),DIMENSION(2),INTENT(INOUT) :: IDF DOUBLE PRECISION,DIMENSION(2),INTENT(IN) :: X,Y DOUBLE PRECISION :: TD,D,X1,X2,Y1,Y2,DM REAL,DIMENSION(2) :: Z1,Z2 REAL,INTENT(IN) :: XSAMPLING REAL :: DX,DY,OR INTEGER :: I DX=X(2)-X(1); DY=Y(2)-Y(1); DM=0.0; IF(DX.NE.0.0.OR.DY.NE.0.0)DM=SQRT(DX**2.0+DY**2.0); TD=0.0 X1=X(1); Y1=Y(1); OR=ATAN2(DY,DX) I=0; DO X2=X1+XSAMPLING*COS(OR); Y2=Y1+XSAMPLING*SIN(OR); D=SQRT((X2-X1)**2.0+(Y2-Y1)**2.0); TD=TD+D IF(TD.GT.DM)THEN; X2=X(2); Y2=Y(2); ENDIF Z1(1)=IDFGETXYVAL(IDF(1),REAL(X1),REAL(Y1)); Z2(1)=IDFGETXYVAL(IDF(1),REAL(X2),REAL(Y2)); Z1(2)=IDFGETXYVAL(IDF(2),REAL(X1),REAL(Y1)); Z2(2)=IDFGETXYVAL(IDF(2),REAL(X2),REAL(Y2)); IF(Z1(1).NE.IDF(1)%NODATA.AND.Z2(1).NE.IDF(1)%NODATA.AND. & Z1(2).NE.IDF(2)%NODATA.AND.Z2(2).NE.IDF(2)%NODATA)THEN I=I+1; WRITE(JU,'(I5.5,A1,I5.5)') ID,'-',I WRITE(JU,*) X1,Y1,Z1(1); WRITE(JU,*) X1,Y1,Z2(2) WRITE(JU,*) X2,Y2,Z1(2); WRITE(JU,*) X2,Y2,Z2(1) WRITE(JU,*) X1,Y1,Z1(1) WRITE(JU,*) 'END' ENDIF IF(TD.GT.DM)EXIT X1=X2; Y1=Y2 ENDDO END SUBROUTINE IMODBATCH_SAMPLEPOINTS !###====================================================================== SUBROUTINE IMODBATCH_ISGEXPORT() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: ISGFILE,EXPORTFNAME,LINE INTEGER :: IEXPORT IF(.NOT.UTL_READINITFILE('ISGFILE_IN',LINE,IU,0))RETURN READ(LINE,*) ISGFILE; WRITE(*,'(A)') 'ISGFILE_IN='//TRIM(ISGFILE) IF(.NOT.UTL_READINITFILE('IEXPORT',LINE,IU,0))RETURN READ(LINE,*) IEXPORT SELECT CASE (IEXPORT) CASE (1) LINE='IEXPORT='//TRIM(ITOS(IEXPORT))//' exporting stages' WRITE(*,'(A)') TRIM(LINE) CASE (2) LINE='IEXPORT='//TRIM(ITOS(IEXPORT))//' exporting cross-sections' WRITE(*,'(A)') TRIM(LINE) CASE DEFAULT STOP 'No proper value for IEXPORT given' END SELECT IF(.NOT.UTL_READINITFILE('EXPORTFNAME',LINE,IU,0))RETURN READ(LINE,*) EXPORTFNAME; WRITE(*,'(A)') 'EXPORTFNAME='//TRIM(EXPORTFNAME) CALL ISG_EXPORT(ISGFILE,EXPORTFNAME,IEXPORT,1) END SUBROUTINE IMODBATCH_ISGEXPORT !###====================================================================== SUBROUTINE IMODBATCH_ISGADDSTAGES() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: IPFFILE,ISGFILE INTEGER :: STAGETYPE IF(.NOT.UTL_READINITFILE('IPFFILE',LINE,IU,0))RETURN READ(LINE,*) IPFFILE; WRITE(*,'(A)') 'IPFFILE='//TRIM(IPFFILE) IF(.NOT.UTL_READINITFILE('ISGFILE_IN',LINE,IU,0))RETURN READ(LINE,*) ISGFILE; WRITE(*,'(A)') 'ISGFILE_IN='//TRIM(ISGFILE) STAGETYPE=0; IF(UTL_READINITFILE('STAGETYPE',LINE,IU,1))READ(LINE,*) STAGETYPE LINE='STAGETYPE='//TRIM(ITOS(STAGETYPE)); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('ISGFILE_OUT',LINE,IU,0))RETURN CALL ISG_ADDSTAGES(ISGFILE,IPFFILE,1,STAGETYPE) READ(LINE,*) ISGFILE; WRITE(*,'(A)') 'ISGFILE_OUT='//TRIM(ISGFILE) WRITE(*,'(/A)') 'ISGFILE_OUT='//TRIM(ISGFILE) WRITE(*,'(/A/)') 'Writing updated ISG file ...' CALL ISGSAVE(ISGFILE,2) !- saving ONLY *.ISG, *.isp, *.isd END SUBROUTINE IMODBATCH_ISGADDSTAGES !###====================================================================== SUBROUTINE IMODBATCH_ISGADDCROSSSECTION() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: ISGFILE,FNAME,WIDTHFNAME,CROSS_PNTR,CROSS_BATH,CROSS_ZCHK,CROSS_CVAL REAL :: MAXDIST,CELL_SIZE INTEGER :: ICLEAN ICLEAN=1; IF(UTL_READINITFILE('ICLEAN',LINE,IU,0))READ(LINE,*) ICLEAN WRITE(*,'(A,I1)') 'ICLEAN=',ICLEAN CROSS_PNTR=''; CROSS_BATH=''; WIDTHFNAME='' IF(UTL_READINITFILE('CROSSSECTION_IN',LINE,IU,1))THEN READ(LINE,*) FNAME; WRITE(*,'(A)') 'CROSSSECTION_IN='//TRIM(FNAME) IF(ICLEAN.EQ.1)THEN IF(.NOT.UTL_READINITFILE('WIDTH_IDF',LINE,IU,0))RETURN READ(LINE,*) WIDTHFNAME; WRITE(*,'(A)') 'WIDTH_IDF='//TRIM(WIDTHFNAME) ENDIF IF(.NOT.UTL_READINITFILE('MAXDIST',LINE,IU,0))RETURN READ(LINE,*) MAXDIST; WRITE(*,'(A,F10.2)') 'MAXDIST=',MAXDIST ELSE IF(.NOT.UTL_READINITFILE('CROSS_PNTR',LINE,IU,0))RETURN READ(LINE,*) CROSS_PNTR; WRITE(*,'(A)') 'CROSS_PNTR='//TRIM(CROSS_PNTR) IF(.NOT.UTL_READINITFILE('CROSS_BATH',LINE,IU,0))RETURN READ(LINE,*) CROSS_BATH; WRITE(*,'(A)') 'CROSS_BATH='//TRIM(CROSS_BATH) CROSS_ZCHK=''; IF(UTL_READINITFILE('CROSS_ZCHK',LINE,IU,1))THEN READ(LINE,*) CROSS_ZCHK; WRITE(*,'(A)') 'CROSS_ZCHK='//TRIM(CROSS_ZCHK) ENDIF CROSS_CVAL=''; IF(UTL_READINITFILE('CROSS_CVAL',LINE,IU,1))THEN READ(LINE,*) CROSS_CVAL; WRITE(*,'(A)') 'CROSS_CVAL='//TRIM(CROSS_CVAL) ENDIF CELL_SIZE=0.0; IF(UTL_READINITFILE('CELL_SIZE',LINE,IU,1))THEN READ(LINE,*) CELL_SIZE; WRITE(*,'(A,F10.3)') 'CELL_SIZE=',CELL_SIZE ENDIF ENDIF IF(.NOT.UTL_READINITFILE('ISGFILE_IN',LINE,IU,0))RETURN READ(LINE,*) ISGFILE; WRITE(*,'(A)') 'ISGFILE_IN='//TRIM(ISGFILE) IF(.NOT.UTL_READINITFILE('ISGFILE_OUT',LINE,IU,0))RETURN CALL ISG_ADDCROSSSECTION(ISGFILE,FNAME,WIDTHFNAME,MAXDIST,CROSS_PNTR,CROSS_BATH,CROSS_ZCHK,CROSS_CVAL,CELL_SIZE,1,ICLEAN) READ(LINE,*) ISGFILE; WRITE(*,'(A)') 'ISGFILE_OUT='//TRIM(ISGFILE) WRITE(*,'(/A)') 'ISGFILE_OUT='//TRIM(ISGFILE) WRITE(*,'(/A/)') 'Writing updated ISG file ...' CALL ISGSAVE(ISGFILE,2) !- saving ONLY *.ISG, *.isp, *.isd END SUBROUTINE IMODBATCH_ISGADDCROSSSECTION !###====================================================================== SUBROUTINE IMODBATCH_ISGADDSTRUCTURES() !###====================================================================== USE MOD_ISG_STRUCTURES, ONLY : IPFFNAME,IX,IY,ID,IO,IS,IW,MAXDIST,SY,EY, & CSPS,CEPS,CSPW,CEPW,CMD,LOGFNAME,IBATCH IMPLICIT NONE CHARACTER(LEN=256) :: ISGFILE IF(.NOT.UTL_READINITFILE('ISGFILE_IN',LINE,IU,0))RETURN READ(LINE,*) ISGFILE; WRITE(*,'(A)') 'ISGFILE_IN='//TRIM(ISGFILE) IF(.NOT.UTL_READINITFILE('IPFFILE_IN',LINE,IU,0))RETURN READ(LINE,*) IPFFNAME; WRITE(*,'(A)') 'IPFFILE_IN='//TRIM(IPFFNAME) IX=1; IY=2; ID=3; IO=4; IS=5; IW=6; MAXDIST=1000.0; SY=1980; EY=2012 CSPS='01-04'; CEPS='30-09'; CSPW='01-10'; CEPW='31-03'; CMD='0-0-0'; LOGFNAME='log.ipf' !## x coordinate IF(UTL_READINITFILE('IXCOL',LINE,IU,1))READ(LINE,*) IX; WRITE(*,'(A,I2)') 'IXCOL=',IX !## y coordinate IF(UTL_READINITFILE('IYCOL',LINE,IU,1))READ(LINE,*) IY; WRITE(*,'(A,I2)') 'IYCOL=',IY !## identification IF(UTL_READINITFILE('IDCOL',LINE,IU,1))READ(LINE,*) ID; WRITE(*,'(A,I2)') 'IDCOL=',ID !## orientation IF(UTL_READINITFILE('IOCOL',LINE,IU,1))READ(LINE,*) IO; WRITE(*,'(A,I2)') 'IOCOL=',IO !## summer level IF(UTL_READINITFILE('ISCOL',LINE,IU,1))READ(LINE,*) IS; WRITE(*,'(A,I2)') 'ISCOL=',IS !## winter level IF(UTL_READINITFILE('IWCOL',LINE,IU,1))READ(LINE,*) IW; WRITE(*,'(A,I2)') 'IWCOL=',IW !## Maximum Distance to asign structure to segment (meters) IF(UTL_READINITFILE('MAXDIST',LINE,IU,1))READ(LINE,*) MAXDIST; WRITE(*,'(A,F10.2)') 'MAXDIST=',MAXDIST !## start period IF(UTL_READINITFILE('START_YEAR',LINE,IU,1))READ(LINE,*) SY; WRITE(*,'(A,I4)') 'START_YEAR=',SY !## end period IF(UTL_READINITFILE('END_YEAR',LINE,IU,1))READ(LINE,*) EY; WRITE(*,'(A,I4)') 'END_YEAR=',EY !## start summer period IF(UTL_READINITFILE('START_PERIOD_SUMMER',LINE,IU,1))READ(LINE,*) CSPS; WRITE(*,'(A)') 'START_PERIOD_SUMMER='//TRIM(CSPS) !## end summer period IF(UTL_READINITFILE('END_PERIOD_SUMMER',LINE,IU,1)) READ(LINE,*) CEPS; WRITE(*,'(A)') 'END_PERIOD_SUMMER='//TRIM(CEPS) !## start winter period IF(UTL_READINITFILE('START_PERIOD_WINTER',LINE,IU,1))READ(LINE,*) CSPW; WRITE(*,'(A)') 'START_PERIOD_WINTER='//TRIM(CSPW) !## end winter period IF(UTL_READINITFILE('END_PERIOD_WINTER',LINE,IU,1)) READ(LINE,*) CEPW; WRITE(*,'(A)') 'END_PERIOD_WINTER='//TRIM(CEPW) !## date of measure to be sued to compute undisturbed waterlevel !## give 0-0-0 to compute the mean of all values (e.g. 28-02-1994 or 0-0-0) IF(UTL_READINITFILE('DATE_WLEVEL',LINE,IU,1))READ(LINE,*) CMD; WRITE(*,'(A)') 'DATE_WLEVEL='//TRIM(CMD) !## logfile IF(UTL_READINITFILE('IPFLOGFILE',LINE,IU,1)) READ(LINE,*) LOGFNAME; WRITE(*,'(A)') 'IPFLOGFILE='//TRIM(LOGFNAME) IBATCH=1 IF(ISG_ADDSTRUCTURES(ISGFILE))THEN IF(.NOT.UTL_READINITFILE('ISGFILE_OUT',LINE,IU,0))RETURN READ(LINE,*) ISGFILE; WRITE(*,'(A)') 'ISGFILE_OUT='//TRIM(ISGFILE) WRITE(*,'(/A)') 'ISGFILE_OUT='//TRIM(ISGFILE) WRITE(*,'(/A/)') 'Writing updated ISG file ...' CALL ISGSAVE(ISGFILE,2) !- saving ONLY *.ISG, *.isp, *.isd ENDIF !## deallocate memory CALL ISGDEAL(1) END SUBROUTINE IMODBATCH_ISGADDSTRUCTURES !###====================================================================== SUBROUTINE IMODBATCH_CREATESOF() !###====================================================================== IMPLICIT NONE TYPE(IDFOBJ),DIMENSION(:),ALLOCATABLE :: IDF TYPE(IDFOBJ),DIMENSION(:,:),ALLOCATABLE :: TQP INTEGER :: I,J,IFLOW,IPNTR,IWINDOW,IWRITE,IGRAD,ITQP,NTQP,TTQP,IFORMAT,PITTSIZE,MINFRICTION,NQDW REAL,DIMENSION(:),ALLOCATABLE :: PTQP REAL,DIMENSION(:,:),POINTER :: QDW CHARACTER(LEN=256) :: RESULTIDF,OUTPUTFOLDER,FNAME REAL :: XMIN,YMIN,XMAX,YMAX,CELLSIZE,MINQ,RAIN IPNTR=0; IWINDOW=0; IGRAD=0 IF(.NOT.UTL_READINITFILE('IFLOW',LINE,IU,0))RETURN READ(LINE,*) IFLOW; WRITE(*,'(A,I1)') 'IFLOW=',IFLOW !## compute d-infinity matrix and surface overland flow level IF(IFLOW.EQ.0)THEN I=6; ALLOCATE(IDF(I)); DO I=1,SIZE(IDF); CALL IDFNULLIFY(IDF(I)); ENDDO IF(.NOT.UTL_READINITFILE('LEVELIDF',LINE,IU,0))RETURN READ(LINE,*) IDF(1)%FNAME; WRITE(*,'(A)') 'LEVELIDF='//TRIM(IDF(1)%FNAME) IF(UTL_READINITFILE('OUTLETIDF',LINE,IU,1))THEN IPNTR=1; READ(LINE,*) IDF(5)%FNAME; WRITE(*,'(A)') 'OUTLETIDF='//TRIM(IDF(5)%FNAME) ENDIF IF(.NOT.UTL_READINITFILE('SOFIDF',LINE,IU,0))RETURN READ(LINE,*) IDF(3)%FNAME; WRITE(*,'(A)') 'SOFIDF='//TRIM(IDF(3)%FNAME) IF(UTL_READINITFILE('IGRAD',LINE,IU,1))READ(LINE,*) IGRAD WRITE(*,'(A,I2)') 'IGRAD=',IGRAD IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) XMIN,YMIN,XMAX,YMAX; IWINDOW=1 WRITE(*,'(A,4F15.2)') 'WINDOW=',XMIN,YMIN,XMAX,YMAX IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,0))RETURN READ(LINE,*) CELLSIZE; WRITE(*,'(A,4F10.2)') 'CELLSIZE=',CELLSIZE ENDIF !## size of the pitt to become outlet PITTSIZE=0; IF(UTL_READINITFILE('PITTSIZE',LINE,IU,1))THEN READ(LINE,*) PITTSIZE; WRITE(*,'(A,I4)') 'PITTSIZE=',PITTSIZE ENDIF !## compute sof-area with spill levels CALL SOF_MAIN(IDF,IPNTR,IWINDOW,XMIN,YMIN,XMAX,YMAX,CELLSIZE,IGRAD,PITTSIZE) ELSEIF(IFLOW.EQ.1)THEN I=8; ALLOCATE(IDF(I)); DO I=1,SIZE(IDF); CALL IDFNULLIFY(IDF(I)); ENDDO IF(.NOT.UTL_READINITFILE('ASPECTIDF',LINE,IU,0))RETURN READ(LINE,*) IDF(1)%FNAME; WRITE(*,'(A)') 'ASPECTIDF='//TRIM(IDF(1)%FNAME) IF(.NOT.UTL_READINITFILE('LEVELIDF',LINE,IU,0))RETURN READ(LINE,*) IDF(5)%FNAME; WRITE(*,'(A)') 'LEVELIDF='//TRIM(IDF(5)%FNAME) IF(.NOT.UTL_READINITFILE('SLOPEIDF',LINE,IU,0))RETURN READ(LINE,*) IDF(6)%FNAME; WRITE(*,'(A)') 'SLOPEIDF='//TRIM(IDF(6)%FNAME) IF(.NOT.UTL_READINITFILE('COUNTIDF',LINE,IU,0))RETURN READ(LINE,*) IDF(2)%FNAME; WRITE(*,'(A)') 'COUNTIDF='//TRIM(IDF(2)%FNAME) IF(.NOT.UTL_READINITFILE('SLOPE_OUTIDF',LINE,IU,0))RETURN READ(LINE,*) IDF(7)%FNAME; WRITE(*,'(A)') 'SLOPE_OUTIDF='//TRIM(IDF(7)%FNAME) IF(.NOT.UTL_READINITFILE('LEVEL_OUTIDF',LINE,IU,0))RETURN READ(LINE,*) IDF(8)%FNAME; WRITE(*,'(A)') 'LEVEL_OUTIDF='//TRIM(IDF(8)%FNAME) IWRITE=0; IF(UTL_READINITFILE('IWRITE',LINE,IU,1))READ(LINE,*) IWRITE WRITE(*,'(A,I10)') 'IWRITE=',IWRITE IDF(4)%FNAME=''; IF(UTL_READINITFILE('DISZONEIPF',LINE,IU,1))THEN READ(LINE,*) IDF(4)%FNAME; WRITE(*,'(A)') 'DISZONEIPF='//TRIM(IDF(4)%FNAME) ENDIF CALL SOF_TRACE(IDF,SIZE(IDF),IWRITE) ELSEIF(IFLOW.EQ.2)THEN I=2; ALLOCATE(IDF(I)); DO I=1,SIZE(IDF); CALL IDFNULLIFY(IDF(I)); ENDDO IF(.NOT.UTL_READINITFILE('COUNTIDF',LINE,IU,0))RETURN READ(LINE,*) IDF(1)%FNAME; WRITE(*,'(A)') 'COUNTIDF='//TRIM(IDF(1)%FNAME) !## whenever itqp.eq.1 read the tqpidf files, create them otherwise IF(.NOT.UTL_READINITFILE('ITQP',LINE,IU,0))RETURN READ(LINE,*) ITQP; WRITE(*,'(A,I10)') 'ITQP=',ITQP MINQ=0.0; IF(ITQP.EQ.1)THEN !## whenever itqp.eq.1 read the tqpidf files, create them otherwise IF(.NOT.UTL_READINITFILE('MINQ',LINE,IU,0))RETURN READ(LINE,*) MINQ; WRITE(*,'(A,F10.2)') 'MINQ=',MINQ ENDIF !## decide to have a total p50 or a monthly p50 IF(.NOT.UTL_READINITFILE('TTQP',LINE,IU,0))RETURN READ(LINE,*) TTQP; WRITE(*,'(A,I10)') 'TTQP=',TTQP !## read number of percentiles IF(.NOT.UTL_READINITFILE('NTQP',LINE,IU,0))RETURN READ(LINE,*) NTQP; WRITE(*,'(A,I10)') 'NTQP=',NTQP I=NTQP; J=1+11*TTQP; ALLOCATE(TQP(I,J),PTQP(I)) DO I=1,SIZE(TQP,1); DO J=1,SIZE(TQP,2); CALL IDFNULLIFY(TQP(I,J)); ENDDO; ENDDO !## read percentiles of discharge groups DO I=1,NTQP IF(.NOT.UTL_READINITFILE('PTQP'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) PTQP(I); LINE='PTQP'//TRIM(ITOS(I))//'='//TRIM(RTOS(PTQP(I),'F',2)); WRITE(*,'(A)') TRIM(LINE) ENDDO !## read result folder with data to be traced IF(.NOT.UTL_READINITFILE('RESULTIDF',LINE,IU,0))RETURN READ(LINE,*) RESULTIDF; WRITE(*,'(A)') 'RESULTIDF='//TRIM(RESULTIDF) !## read output folder IF(.NOT.UTL_READINITFILE('OUTPUTFOLDER',LINE,IU,0))RETURN READ(LINE,*) OUTPUTFOLDER; WRITE(*,'(A)') 'OUTPUTFOLDER='//TRIM(OUTPUTFOLDER) !## read in name of the output of the discharge per percentile DO I=1,NTQP TQP(I,1)%FNAME=''; IF(.NOT.UTL_READINITFILE('TQPIDF'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) FNAME IF(TTQP.EQ.1)THEN DO J=1,12 TQP(I,J)%FNAME=FNAME(:INDEX(FNAME,'.',.TRUE.)-1)//'_'//CDATE_SHORT(J)//'.IDF' WRITE(*,'(A)') 'TQPIDF'//TRIM(ITOS(I))//'_'//TRIM(ITOS(J))//'='//TRIM(TQP(I,J)%FNAME) ENDDO ELSE TQP(I,1)%FNAME=FNAME WRITE(*,'(A)') 'TQPIDF'//TRIM(ITOS(I))//'='//TRIM(TQP(I,1)%FNAME) ENDIF ENDDO CALL SOF_CATCHMENTS(RESULTIDF,OUTPUTFOLDER,IDF,TQP,PTQP,ITQP,TTQP,MINQ) !## create river input ELSEIF(IFLOW.EQ.3)THEN IF(.NOT.UTL_READINITFILE('IFORMAT',LINE,IU,0))RETURN READ(LINE,*) IFORMAT; WRITE(*,'(A,I10)') 'IFORMAT=',IFORMAT !# read catchment rainfall (mm/d) RAIN=1.0; IF(UTL_READINITFILE('RAIN',LINE,IU,1))READ(LINE,*) RAIN WRITE(*,'(A,F10.2)') 'RAIN=',RAIN MINFRICTION=0; IF(UTL_READINITFILE('MINFRICTION',LINE,IU,1))READ(LINE,*) MINFRICTION WRITE(*,'(A,I10)') 'MINFRICTION=',MINFRICTION NQDW=0; IF(UTL_READINITFILE('NQDW',LINE,IU,1))READ(LINE,*) NQDW IF(NQDW.GT.0)THEN WRITE(*,'(A,I10)') 'NQDW=',NQDW ALLOCATE(QDW(NQDW,3)) !## q in m3/seconds DO I=1,NQDW IF(UTL_READINITFILE('QDW'//TRIM(ITOS(I)),LINE,IU,1))READ(LINE,*) QDW(I,1),QDW(I,2),QDW(I,3) LINE='QDW'//TRIM(ITOS(I)); WRITE(*,'(A,3(F10.2,A1))') TRIM(LINE)//'=',QDW(I,1),',',QDW(I,2),',',QDW(I,3) ENDDO ENDIF I=9; ALLOCATE(IDF(I)); DO I=1,SIZE(IDF); CALL IDFNULLIFY(IDF(I)); ENDDO IF(.NOT.UTL_READINITFILE('COUNTIDF',LINE,IU,0))RETURN READ(LINE,*) IDF(1)%FNAME; WRITE(*,'(A)') 'COUNTIDF='//TRIM(IDF(1)%FNAME) IF(.NOT.UTL_READINITFILE('SLOPEIDF',LINE,IU,0))RETURN READ(LINE,*) IDF(2)%FNAME; WRITE(*,'(A)') 'SLOPEIDF='//TRIM(IDF(2)%FNAME) IF(.NOT.UTL_READINITFILE('ASPECTIDF',LINE,IU,0))RETURN READ(LINE,*) IDF(3)%FNAME; WRITE(*,'(A)') 'ASPECTIDF='//TRIM(IDF(3)%FNAME) IF(.NOT.UTL_READINITFILE('LEVELIDF',LINE,IU,0))RETURN READ(LINE,*) IDF(4)%FNAME; WRITE(*,'(A)') 'LEVELIDF='//TRIM(IDF(4)%FNAME) IF(.NOT.UTL_READINITFILE('RCND_IDF',LINE,IU,0))RETURN READ(LINE,*) IDF(5)%FNAME; WRITE(*,'(A)') 'RCOND_IDF='//TRIM(IDF(5)%FNAME) IF(.NOT.UTL_READINITFILE('RSTG_IDF',LINE,IU,0))RETURN READ(LINE,*) IDF(6)%FNAME; WRITE(*,'(A)') 'RSTG_IDF='//TRIM(IDF(6)%FNAME) IF(.NOT.UTL_READINITFILE('RBOT_IDF',LINE,IU,0))RETURN READ(LINE,*) IDF(7)%FNAME; WRITE(*,'(A)') 'RBOT_IDF='//TRIM(IDF(7)%FNAME) IF(.NOT.UTL_READINITFILE('RINF_IDF',LINE,IU,0))RETURN READ(LINE,*) IDF(8)%FNAME; WRITE(*,'(A)') 'RINF_IDF='//TRIM(IDF(8)%FNAME) CALL SOF_EXPORT(IDF,SIZE(IDF),IFORMAT,RAIN,MINFRICTION,QDW) ENDIF CALL IDFDEALLOCATE(IDF,SIZE(IDF)) END SUBROUTINE IMODBATCH_CREATESOF !###====================================================================== SUBROUTINE IMODBATCH_IDFTRACE_MAIN() !###====================================================================== USE MOD_IDFEDIT_TRACE IMPLICIT NONE TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: IDF INTEGER :: I,IROW,ICOL,JROW,JCOL,IPZ,JPZ,MINT INTEGER(KIND=1),POINTER,DIMENSION(:) :: ISPEC INTEGER(KIND=2),POINTER,DIMENSION(:,:) :: THREAD,YSEL INTEGER :: MAXTHREAD,NTHREAD,MAXN,DTERM,IMENU ALLOCATE(IDF(2));DO I=1,SIZE(IDF); CALL IDFNULLIFY(IDF(I)); ENDDO IF(.NOT.UTL_READINITFILE('IDF_IN',LINE,IU,0))RETURN READ(LINE,*) IDF(1)%FNAME; WRITE(*,'(A)') 'IDF_IN='//TRIM(IDF(1)%FNAME) IF(.NOT.UTL_READINITFILE('IDF_OUT',LINE,IU,0))RETURN READ(LINE,*) IDF(2)%FNAME; WRITE(*,'(A)') 'IDF_OUT='//TRIM(IDF(2)%FNAME) MINT=0; IF(UTL_READINITFILE('MINT',LINE,IU,1))THEN READ(LINE,*) MINT; WRITE(*,'(A,I10)') 'MINT=',MINT ENDIF WRITE(*,'(A)') 'Reading '//TRIM(IDF(1)%FNAME) IF(.NOT.IDFREAD(IDF(1),IDF(1)%FNAME,1))RETURN CALL IDFCOPY(IDF(1),IDF(2)) IMENU= 4 ! greater than zero6 !## not equal DTERM= 1 !## 9-points IPZ = 0 !## pointer value MAXTHREAD=1000; ALLOCATE(ISPEC(MAXTHREAD),THREAD(3,MAXTHREAD),YSEL(2,MAXTHREAD)); MAXN=MAXTHREAD WRITE(6,'(1X,A)') 'Tracing ' IDF(2)%X=IDF(2)%NODATA !## start tracing DO IROW=1,IDF(1)%NROW; DO ICOL=1,IDF(1)%NCOL !## skip nodata IF(IDF(1)%X(ICOL,IROW).EQ.IDF(1)%NODATA)CYCLE !## set begin values NTHREAD=1; YSEL(1,NTHREAD)=ICOL; YSEL(2,NTHREAD)=IROW; IPZ=IPZ+1 !## trace all not greater than zero, imenu=4, idf(1) will be adjusted CALL IDFEDITTRACE(IDF(1),IDF(2),THREAD,YSEL,ISPEC,DTERM,IMENU,MAXTHREAD,MAXN,0.0,NTHREAD,IPZ) JPZ=IPZ; IF(NTHREAD.LT.MINT)THEN; JPZ=0; IPZ=IPZ-1; ENDIF DO I=1,NTHREAD JCOL=YSEL(1,I); JROW=YSEL(2,I) IDF(2)%X(JCOL,JROW)=JPZ IDF(1)%X(JCOL,JROW)=IDF(1)%NODATA ENDDO ENDDO; WRITE(6,'(A,F7.3,A)') '+Progress ',REAL(IROW*100)/REAL(IDF(1)%NROW),' % finished '; ENDDO WRITE(*,'(A)') 'Writing '//TRIM(IDF(2)%FNAME) IF(.NOT.IDFWRITE(IDF(2),IDF(2)%FNAME,1))THEN; ENDIF DEALLOCATE(ISPEC,THREAD,YSEL) CALL IDFDEALLOCATE(IDF,SIZE(IDF)); DEALLOCATE(IDF) END SUBROUTINE IMODBATCH_IDFTRACE_MAIN !###====================================================================== SUBROUTINE IMODBATCH_IDFINSERT() !###====================================================================== IMPLICIT NONE INTEGER :: I,J,NLAY,NIDF,ILAY,IROW,ICOL TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:,:) :: IDF TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: INIDF CHARACTER(LEN=256) :: OUTPUTFOLDER LOGICAL :: LIDF IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) NLAY; WRITE(*,'(A,I10)') 'NLAY=',NLAY ALLOCATE(IDF(NLAY,2)); DO I=1,SIZE(IDF,1); DO J=1,SIZE(IDF,2); CALL IDFNULLIFY(IDF(I,J)); ENDDO; ENDDO IF(.NOT.UTL_READINITFILE('TOPSYSTEM',LINE,IU,0))RETURN READ(LINE,*) IDF(1,1)%FNAME; WRITE(*,'(A)') 'TOPSYSTEM='//TRIM(IDF(1,1)%FNAME) IF(.NOT.UTL_READINITFILE('BOTSYSTEM',LINE,IU,0))RETURN READ(LINE,*) IDF(NLAY,2)%FNAME; WRITE(*,'(A)') 'BOTSYSTEM='//TRIM(IDF(NLAY,2)%FNAME) IF(.NOT.IDFREAD(IDF(1,1) ,IDF(1 ,1)%FNAME,1))RETURN IF(.NOT.IDFREAD(IDF(NLAY,2),IDF(NLAY,2)%FNAME,1))RETURN !## copy settings and allocate remaining idf files DO I=1,SIZE(IDF,1); DO J=1,SIZE(IDF,2) IF(I.EQ.1.AND.J.EQ.1)CYCLE; IF(I.EQ.NLAY.AND.J.EQ.2)CYCLE; CALL IDFCOPY(IDF(1,1),IDF(I,J)) ENDDO; ENDDO IF(.NOT.UTL_READINITFILE('OUTPUTFOLDER',LINE,IU,0))RETURN READ(LINE,*) OUTPUTFOLDER; WRITE(*,'(A)') 'OUTPUTFOLDER='//TRIM(OUTPUTFOLDER) CALL UTL_CREATEDIR(OUTPUTFOLDER) DO I=1,SIZE(IDF,1) IDF(I,1)%FNAME=TRIM(OUTPUTFOLDER)//'\TOP_MDL'//TRIM(ITOS(I))//'.IDF' IDF(I,2)%FNAME=TRIM(OUTPUTFOLDER)//'\BOT_MDL'//TRIM(ITOS(I))//'.IDF' ENDDO !## initialize data DO I=1,SIZE(IDF,1); DO J=1,SIZE(IDF,2) IF(I.EQ.1.AND.J.EQ.1)CYCLE; IF(I.EQ.NLAY.AND.J.EQ.2)CYCLE; IDF(I,J)%X=IDF(I,J)%NODATA ENDDO; ENDDO IF(.NOT.UTL_READINITFILE('NIDF',LINE,IU,0))RETURN READ(LINE,*) NIDF; LINE='NIDF='//TRIM(ITOS(NIDF)); WRITE(*,'(A)') TRIM(LINE) ALLOCATE(INIDF(3)); DO I=1,SIZE(INIDF); CALL IDFNULLIFY(INIDF(I)); ENDDO !## check input DO I=1,NIDF IF(.NOT.UTL_READINITFILE('INTOP'//TRIM(ITOS(I)),LINE,IU,0))RETURN; READ(LINE,*) INIDF(1)%FNAME IF(.NOT.UTL_READINITFILE('INBOT'//TRIM(ITOS(I)),LINE,IU,0))RETURN; READ(LINE,*) INIDF(2)%FNAME IF(.NOT.IDFREAD(INIDF(1),INIDF(1)%FNAME,0))THEN; RETURN; ENDIF IF(.NOT.IDFREAD(INIDF(2),INIDF(2)%FNAME,0))THEN; RETURN; ENDIF CLOSE(INIDF(1)%IU); CLOSE(INIDF(2)%IU) LIDF=UTL_READINITFILE('INLAY'//TRIM(ITOS(I)),LINE,IU,1) IF(LIDF)THEN READ(LINE,*) INIDF(3)%FNAME IF(.NOT.IDFREAD(INIDF(3),INIDF(3)%FNAME,0))THEN; RETURN; ENDIF CLOSE(INIDF(3)%IU) ELSE IF(.NOT.UTL_READINITFILE('IL'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) ILAY ; IF(ILAY.GT.NLAY)STOP 'ILAY.GT.NLAY' ENDIF ENDDO !## read/scale/cut mean values DO I=1,NIDF IF(.NOT.UTL_READINITFILE('INTOP'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) INIDF(1)%FNAME; LINE='INTOP'//TRIM(ITOS(I))//'='//TRIM(INIDF(1)%FNAME) WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('INBOT'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) INIDF(2)%FNAME; LINE='INBOT'//TRIM(ITOS(I))//'='//TRIM(INIDF(2)%FNAME) WRITE(*,'(A)') TRIM(LINE) CALL IDFCOPY(IDF(1,1),INIDF(1)); IF(.NOT.IDFREADSCALE(INIDF(1)%FNAME,INIDF(1),2,1,0.0,0))THEN; RETURN; ENDIF CALL IDFCOPY(IDF(1,1),INIDF(2)); IF(.NOT.IDFREADSCALE(INIDF(2)%FNAME,INIDF(2),2,1,0.0,0))THEN; RETURN; ENDIF LIDF=UTL_READINITFILE('INLAY'//TRIM(ITOS(I)),LINE,IU,1) IF(LIDF)THEN READ(LINE,*) INIDF(3)%FNAME; LINE='INLAY'//TRIM(ITOS(I))//'='//TRIM(INIDF(3)%FNAME) WRITE(*,'(A)') TRIM(LINE) CALL IDFCOPY(IDF(1,1),INIDF(3)); IF(.NOT.IDFREADSCALE(INIDF(3)%FNAME,INIDF(3),7,1,0.0,0))THEN; RETURN; ENDIF ELSE IF(.NOT.UTL_READINITFILE('IL'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) ILAY; LINE='IL'//TRIM(ITOS(I))//'='//TRIM(ITOS(ILAY)); WRITE(*,'(A)') TRIM(LINE) ENDIF DO IROW=1,IDF(1,1)%NROW; DO ICOL=1,IDF(1,1)%NCOL IF(LIDF)ILAY=INIDF(3)%X(ICOL,IROW) IF(INIDF(1)%X(ICOL,IROW).NE.INIDF(1)%NODATA.AND. & !## top INIDF(2)%X(ICOL,IROW).NE.INIDF(2)%NODATA.AND. & !## bot INIDF(1)%X(ICOL,IROW).GE.INIDF(2)%X(ICOL,IROW))THEN !## top>bot !## skip ilay outside 1-nlay IF(ILAY.LE.0.OR.ILAY+1.GT.NLAY)THEN LINE='ILAY='//TRIM(ITOS(ILAY)); WRITE(*,'(A)') TRIM(LINE) ELSE !## not yet value given for top of resistance layer to be inserted IF(IDF(ILAY,2)%X(ICOL,IROW).EQ.IDF(ILAY,2)%NODATA)THEN IDF(ILAY,2)%X(ICOL,IROW)=INIDF(1)%X(ICOL,IROW) !## adjust bottom of resistance layer ELSE IDF(ILAY,2)%X(ICOL,IROW)=MAX(IDF(ILAY,2)%X(ICOL,IROW),INIDF(1)%X(ICOL,IROW)) ENDIF !## not yet value given for bottom of resistance layer to be inserted IF(IDF(ILAY+1,1)%X(ICOL,IROW).EQ.IDF(ILAY+1,1)%NODATA)THEN IDF(ILAY+1,1)%X(ICOL,IROW)=INIDF(2)%X(ICOL,IROW) !## adjust bottom of resistance layer ELSE IDF(ILAY+1,1)%X(ICOL,IROW)=MIN(IDF(ILAY+1,1)%X(ICOL,IROW),INIDF(2)%X(ICOL,IROW)) ENDIF ENDIF ENDIF ENDDO; ENDDO ENDDO DO I=1,SIZE(IDF,1); DO J=1,SIZE(IDF,2) IF(.NOT.IDFWRITE(IDF(I,J),IDF(I,J)%FNAME,1))RETURN ENDDO; ENDDO DO I=1,SIZE(IDF,1); DO J=1,SIZE(IDF,2); CALL IDFDEALLOCATE(IDF(I,J),1); ENDDO; ENDDO IF(ALLOCATED(INIDF))THEN; CALL IDFDEALLOCATE(INIDF,SIZE(INIDF)); DEALLOCATE(INIDF); ENDIF END SUBROUTINE IMODBATCH_IDFINSERT !###====================================================================== SUBROUTINE IMODBATCH_TSERIES() !###====================================================================== USE MOD_TS_PAR, ONLY : IPFNAME1,IPFNAME2,TSILAY,JD1,JD2,IASSF,TSDIR,IBATCH,LCOL IMPLICIT NONE IF(.NOT.UTL_READINITFILE('IPF1',LINE,IU,0))RETURN READ(LINE,*) IPFNAME1; WRITE(*,'(A)') 'IPF1='//TRIM(IPFNAME1) IF(.NOT.UTL_READINITFILE('IPF2',LINE,IU,0))RETURN READ(LINE,*) IPFNAME2; WRITE(*,'(A)') 'IPF2='//TRIM(IPFNAME2) IF(.NOT.UTL_READINITFILE('SDATE',LINE,IU,0))RETURN READ(LINE,*) JD1; LINE=TRIM(ITOS(JD1)); WRITE(*,'(A)') 'SDATE='//TRIM(LINE) IF(.NOT.UTL_READINITFILE('EDATE',LINE,IU,0))RETURN READ(LINE,*) JD2; LINE=TRIM(ITOS(JD2)); WRITE(*,'(A)') 'EDATE='//TRIM(LINE) LCOL=0; IF(UTL_READINITFILE('LABELCOL',LINE,IU,1))READ(LINE,*) LCOL LINE=TRIM(ITOS(LCOL)); WRITE(*,'(A)') 'LABELCOL='//TRIM(LINE) IF(.NOT.UTL_READINITFILE('ILAY',LINE,IU,0))RETURN READ(LINE,*) TSILAY; LINE=TRIM(ITOS(TSILAY)); WRITE(*,'(A)') 'ILAY='//TRIM(LINE) IF(.NOT.UTL_READINITFILE('SOURCEDIR',LINE,IU,0))RETURN READ(LINE,*) TSDIR; WRITE(*,'(A)') 'SOURCEDIR='//TRIM(TSDIR) IBATCH=1; IF(.NOT.TS1COMPUTE())THEN; ENDIF; CALL TS_END() END SUBROUTINE IMODBATCH_TSERIES !###====================================================================== SUBROUTINE IMODBATCH_PWTCOUNT() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: DIR,SDLFNAME,OUTPUTIDF,ILAYFNAME INTEGER :: SDATE,EDATE IF(.NOT.UTL_READINITFILE('SDLIDF',LINE,IU,0))RETURN READ(LINE,*) SDLFNAME; WRITE(*,'(A)') 'SDLIDF='//TRIM(SDLFNAME) IF(.NOT.UTL_READINITFILE('ILAYIDF',LINE,IU,0))RETURN READ(LINE,*) ILAYFNAME; WRITE(*,'(A)') 'ILAYIDF='//TRIM(ILAYFNAME) IF(.NOT.UTL_READINITFILE('SDATE',LINE,IU,0))RETURN READ(LINE,*) SDATE; LINE=TRIM(ITOS(SDATE)); WRITE(*,'(A)') 'SDATE='//TRIM(LINE) IF(.NOT.UTL_READINITFILE('EDATE',LINE,IU,0))RETURN READ(LINE,*) EDATE; LINE=TRIM(ITOS(EDATE)); WRITE(*,'(A)') 'EDATE='//TRIM(LINE) IF(.NOT.UTL_READINITFILE('SOURCEDIR',LINE,IU,0))RETURN READ(LINE,*) DIR; WRITE(*,'(A)') 'SOURCEDIR='//TRIM(DIR) IF(.NOT.UTL_READINITFILE('OUTPUTIDF',LINE,IU,0))RETURN READ(LINE,*) OUTPUTIDF; WRITE(*,'(A)') 'OUTPUTIDF='//TRIM(OUTPUTIDF) SDATE=UTL_IDATETOJDATE(SDATE); EDATE=UTL_IDATETOJDATE(EDATE) CALL MATH1_PWTCOUNT(DIR,SDLFNAME,ILAYFNAME,SDATE,EDATE,OUTPUTIDF) END SUBROUTINE IMODBATCH_PWTCOUNT !###====================================================================== SUBROUTINE IMODBATCH_BITMAPTILING() !###====================================================================== USE MOD_TOPO, ONLY : TOPO1DRAW_TILING IMPLICIT NONE CHARACTER(LEN=256) :: BMPFILE,OUTPUTFOLDER IF(.NOT.UTL_READINITFILE('BMPFILE',LINE,IU,0))RETURN READ(LINE,*) BMPFILE; WRITE(*,'(A)') 'BMPFILE='//TRIM(BMPFILE) IF(.NOT.UTL_READINITFILE('OUTPUTFOLDER',LINE,IU,0))RETURN READ(LINE,*) OUTPUTFOLDER; WRITE(*,'(A)') 'OUTPUTFOLDER='//TRIM(OUTPUTFOLDER) CALL TOPO1DRAW_TILING(BMPFILE,OUTPUTFOLDER,1,500,5) END SUBROUTINE IMODBATCH_BITMAPTILING !###====================================================================== SUBROUTINE IMODBATCH_GEN2ISG() !###====================================================================== USE MOD_GEN2GEN_PUZZLE, ONLY : GENFNAME,PUZZLEMAIN USE MOD_ISGGEN, ONLY : FNAME,IIDFZ,IIDFW,IIDFB,ICCF,IBOT,ICDY,RBOT,CSUMMER,CWINTER,ISTART,ISTOP,SAMPLE,ISGGEN_GENTOISG, & CDAY,INFFCT,XSEARCH,LDAT,IIDFC,IIDFI,IINF,ISUMMER_BACKUP,IWINTER_BACKUP,IIDFZ_BU,IIDFW_BU,DATCOL IMPLICIT NONE CHARACTER(LEN=256) :: OUTFILE INTEGER :: IPUZZLE,I IPUZZLE=0 CWINTER='0110' CSUMMER='0104' ISTART=2014 ISTOP=2014 SAMPLE=250.0 XSEARCH=250.0 CDAY=1.0 INFFCT=0.33 IBOT=-1 ICDY=-1 IINF=-1 IF(.NOT.UTL_READINITFILE('GENFNAME',LINE,IU,0))RETURN READ(LINE,*) GENFNAME; WRITE(*,'(A)') 'GENFNAME='//TRIM(GENFNAME) !## test to see whether *.dat file exists with genfile information LDAT=.FALSE.; I=0 IF(UTL_READINITFILE('IUSEDAT',LINE,IU,1))READ(LINE,*) I IF(I.EQ.1)LDAT=.TRUE. IF(LDAT)THEN IF(.NOT.UTL_READINITFILE('STAGE1_COLUMN',LINE,IU,0))RETURN READ(LINE,*) DATCOL(1); WRITE(*,'(A,I2)') 'STAGE1_COLUMN=',DATCOL(1) IF(.NOT.UTL_READINITFILE('STAGE2_COLUMN',LINE,IU,0))RETURN READ(LINE,*) DATCOL(2); WRITE(*,'(A,I2)') 'STAGE2_COLUMN=',DATCOL(2) IF(.NOT.UTL_READINITFILE('BOTL1_COLUMN',LINE,IU,0))RETURN READ(LINE,*) DATCOL(3); WRITE(*,'(A,I2)') 'BOTL1_COLUMN=',DATCOL(3) IF(.NOT.UTL_READINITFILE('BOTL2_COLUMN',LINE,IU,0))RETURN READ(LINE,*) DATCOL(4); WRITE(*,'(A,I2)') 'BOTL2_COLUMN=',DATCOL(4) IF(.NOT.UTL_READINITFILE('SLOPE_L_COLUMN',LINE,IU,0))RETURN READ(LINE,*) DATCOL(5); WRITE(*,'(A,I2)') 'SLOPE_L_COLUMN=',DATCOL(5) IF(.NOT.UTL_READINITFILE('SLOPE_R_COLUMN',LINE,IU,0))RETURN READ(LINE,*) DATCOL(6); WRITE(*,'(A,I2)') 'SLOPE_R_COLUMN=',DATCOL(6) IF(.NOT.UTL_READINITFILE('BWIDTH_COLUMN',LINE,IU,0))RETURN READ(LINE,*) DATCOL(7); WRITE(*,'(A,I2)') 'BWIDTH_COLUMN=',DATCOL(7) ELSE !## steady-state stage read in IF(UTL_READINITFILE('IDFSTAGE',LINE,IU,1))THEN READ(LINE,'(A)') FNAME(IIDFZ); WRITE(*,'(A)') 'IDFSTAGE='//TRIM(FNAME(IIDFZ)) FNAME(IIDFW)=FNAME(IIDFZ) ELSE IF(.NOT.UTL_READINITFILE('IDFSUMMER',LINE,IU,0))RETURN READ(LINE,'(A)') FNAME(IIDFZ); WRITE(*,'(A)') 'IDFSUMMER='//TRIM(FNAME(IIDFZ)) ISUMMER_BACKUP=0; IF(UTL_READINITFILE('IDFSUMMER_BACKUP',LINE,IU,1))THEN ISUMMER_BACKUP=1; READ(LINE,'(A)') FNAME(IIDFZ_BU); WRITE(*,'(A)') 'IDFSUMMER_BACKUP='//TRIM(FNAME(IIDFZ_BU)); ENDIF IF(.NOT.UTL_READINITFILE('IDFWINTER',LINE,IU,0))RETURN READ(LINE,'(A)') FNAME(IIDFW); WRITE(*,'(A)') 'IDFWINTER='//TRIM(FNAME(IIDFW)) IWINTER_BACKUP=0; IF(UTL_READINITFILE('IDFWINTER_BACKUP',LINE,IU,1))THEN IWINTER_BACKUP=1; READ(LINE,'(A)') FNAME(IIDFW_BU); WRITE(*,'(A)') 'IDFWINTER_BACKUP='//TRIM(FNAME(IIDFW_BU)); ENDIF IF(UTL_READINITFILE('SUMMERPERIOD',LINE,IU,1))READ(LINE,*) CSUMMER WRITE(*,'(A)') 'SUMMERPERIOD='//TRIM(CSUMMER) IF(UTL_READINITFILE('WINTERPERIOD',LINE,IU,1))READ(LINE,*) CWINTER WRITE(*,'(A)') 'WINTERPERIOD='//TRIM(CWINTER) IF(UTL_READINITFILE('START_YEAR',LINE,IU,1))READ(LINE,*) ISTART WRITE(*,*) 'START_YEAR=',ISTART IF(UTL_READINITFILE('END_YEAR',LINE,IU,1))READ(LINE,*) ISTOP WRITE(*,*) 'END_YEAR=',ISTOP ENDIF IF(UTL_READINITFILE('IDFBOTTOM',LINE,IU,1))THEN IBOT=0; RBOT=0.0 READ(LINE,'(A)') FNAME(IIDFB); WRITE(*,'(A)') 'IDFBOTTOM='//TRIM(FNAME(IIDFB)) ENDIF IF(UTL_READINITFILE('BOTTOMVALUE',LINE,IU,1))THEN IBOT=1; READ(LINE,*) RBOT; WRITE(*,*) 'RBOT=',RBOT ENDIF IF(IBOT.LT.0)STOP 'SPECIFY IDFBOTTOM or BOTTOMVALUE' IF(UTL_READINITFILE('SAMPLE_DISTANCE',LINE,IU,1))READ(LINE,*) SAMPLE WRITE(*,*) 'SAMPLE_DISTANCE=',SAMPLE IF(.NOT.UTL_READINITFILE('CCFFNAME',LINE,IU,0))RETURN READ(LINE,*) FNAME(ICCF); WRITE(*,'(A)') 'CCFFNAME='//TRIM(FNAME(ICCF)) IF(UTL_READINITFILE('SEARCH_DISTANCE',LINE,IU,1))READ(LINE,*) XSEARCH WRITE(*,*) 'SEARCH_DISTANCE=',XSEARCH IF(UTL_READINITFILE('IPUZZLE',LINE,IU,1))READ(LINE,*) IPUZZLE WRITE(*,'(A,I10)') 'IPUZZLE=',IPUZZLE ENDIF IF(UTL_READINITFILE('IDFRESISTANCE',LINE,IU,1))THEN ICDY=0; CDAY=0.0 READ(LINE,'(A)') FNAME(IIDFC); WRITE(*,'(A)') 'IDFRESISTANCE='//TRIM(FNAME(IIDFC)) ENDIF IF(UTL_READINITFILE('RESISTANCE',LINE,IU,1))THEN ICDY=1; READ(LINE,*) CDAY; WRITE(*,*) 'RESISTANCE=',CDAY ENDIF IF(ICDY.LT.0)STOP 'SPECIFY IDFRESISTANCE or RESISTANCE' IF(UTL_READINITFILE('IDFINFILTRATIONFACTOR',LINE,IU,1))THEN IINF=0; INFFCT=0.0 READ(LINE,'(A)') FNAME(IIDFI); WRITE(*,'(A)') 'IDFINFILTRATIONFACTOR='//TRIM(FNAME(IIDFI)) ENDIF IF(UTL_READINITFILE('INFILTRATIONFACTOR',LINE,IU,1))THEN IINF=1; READ(LINE,*) INFFCT; WRITE(*,*) 'INFILTRATIONFACTOR=',INFFCT ENDIF IF(IINF.LT.0)STOP 'SPECIFY IDFINFILTRATIONFACTOR or INFILTRATIONFACTOR' IF(.NOT.UTL_READINITFILE('OUTFILE',LINE,IU,0))RETURN READ(LINE,*) OUTFILE; WRITE(*,'(A)') 'OUTFILE='//TRIM(OUTFILE) IF(IPUZZLE.EQ.1)CALL PUZZLEMAIN() CALL ISGGEN_GENTOISG(GENFNAME,OUTFILE) END SUBROUTINE IMODBATCH_GEN2ISG !###====================================================================== SUBROUTINE IMODBATCH_IPF2ISG() !###====================================================================== USE MOD_ISGGEN, ONLY : ISGGEN_IPFTOISG IMPLICIT NONE CHARACTER(LEN=256) :: ISGFILE,IPFFILE INTEGER,DIMENSION(9) :: DATCOL INTEGER(KIND=8) :: SDATE INTEGER :: I DO I=1,SIZE(DATCOL); DATCOL(I)=I; ENDDO; SDATE=20000101000000 IF(.NOT.UTL_READINITFILE('IPFFILE',LINE,IU,0))RETURN READ(LINE,*) IPFFILE; WRITE(*,'(A)') 'IPFFILE='//TRIM(IPFFILE) IF(UTL_READINITFILE('IXCOL',LINE,IU,1))READ(LINE,*) DATCOL(1) WRITE(*,'(A,I2)') 'IXCOL=',DATCOL(1) IF(UTL_READINITFILE('IYCOL',LINE,IU,1))READ(LINE,*) DATCOL(2) WRITE(*,'(A,I2)') 'IYCOL=',DATCOL(2) IF(UTL_READINITFILE('ILABELCOL',LINE,IU,1))READ(LINE,*) DATCOL(3) WRITE(*,'(A,I2)') 'ILABELCOL=',DATCOL(3) IF(UTL_READINITFILE('ISEGMCOL',LINE,IU,1))READ(LINE,*) DATCOL(4) WRITE(*,'(A,I2)') 'ISEGMCOL=',DATCOL(4) IF(UTL_READINITFILE('IWIDTHCOL',LINE,IU,1))READ(LINE,*) DATCOL(5) WRITE(*,'(A,I2)') 'IWIDTHCOL=',DATCOL(5) IF(UTL_READINITFILE('IBOTTOMCOL',LINE,IU,1))READ(LINE,*) DATCOL(6) WRITE(*,'(A,I2)') 'IBOTTOMCOL=',DATCOL(6) IF(UTL_READINITFILE('ISTAGECOL',LINE,IU,1))READ(LINE,*) DATCOL(7) WRITE(*,'(A,I2)') 'ISTAGECOL=',DATCOL(7) IF(UTL_READINITFILE('IPERMCOL',LINE,IU,1))READ(LINE,*) DATCOL(8) WRITE(*,'(A,I2)') 'IPERMCOL=',DATCOL(8) ! IF(UTL_READINITFILE('ITALUSCOL',LINE,IU,1))READ(LINE,*) DATCOL(9) ! WRITE(*,'(A,I2)') 'ITALUSCOL=',DATCOL(9) IF(UTL_READINITFILE('SDATE',LINE,IU,1))READ(LINE,*) SDATE WRITE(*,'(A,I14)') 'SDATE=',SDATE IF(.NOT.UTL_READINITFILE('ISGFILE',LINE,IU,0))RETURN READ(LINE,*) ISGFILE; WRITE(*,'(A)') 'ISGFILE='//TRIM(ISGFILE) CALL ISGGEN_IPFTOISG(IPFFILE,ISGFILE,DATCOL,SDATE) END SUBROUTINE IMODBATCH_IPF2ISG !###====================================================================== SUBROUTINE IMODBATCH_GENSNAPTOGRID() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: GENFILE TYPE(IDFOBJ) :: IDF INTEGER(KIND=1),DIMENSION(:,:,:),ALLOCATABLE :: IPC INTEGER :: IROW,ICOL,N,JU IDF%XMIN=0.0; IDF%YMIN=0.0; IDF%XMAX=0.0; IDF%YMAX=0.0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX WRITE(*,'(A,4F10.2)') 'WINDOW=',IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX IF(.NOT.UTL_READINITFILE('CELL_SIZE',LINE,IU,0))RETURN READ(LINE,*) IDF%DX; WRITE(*,'(A,F10.2)') 'CELL_SIZE=',IDF%DX; IDF%DY=IDF%DX CALL UTL_IDFSNAPTOGRID_LLC(IDF%XMIN,IDF%XMAX,IDF%YMIN,IDF%YMAX,IDF%DX,IDF%NCOL,IDF%NROW) ELSE IF(.NOT.UTL_READINITFILE('IDFFILE',LINE,IU,0))RETURN READ(LINE,*) IDF%FNAME; WRITE(*,'(A)') 'IDFFILE='//TRIM(IDF%FNAME) IF(.NOT.IDFREAD(IDF,IDF%FNAME,0))RETURN ENDIF !## fill sx/sy variable in idf IF(.NOT.IDFFILLSXSY(IDF))RETURN ALLOCATE(IPC(IDF%NCOL,IDF%NROW,2)); IPC=INT(0,1) IF(.NOT.UTL_READINITFILE('GENFILE',LINE,IU,0))RETURN READ(LINE,*) GENFILE; WRITE(*,'(A)') 'GENFILE='//TRIM(GENFILE) CALL ASC2IDF_INT_NULLIFY(); ALLOCATE(XP(100),YP(100),ZP(100),WP(100),FP(100)) CALL ASC2IDF_HFB(IDF,IDF%NROW,IDF%NCOL,IPC,GENFILE,-1) IF(.NOT.UTL_READINITFILE('GENFILE_OUT',LINE,IU,0))RETURN READ(LINE,*) GENFILE; WRITE(*,'(A)') 'GENFILE_OUT='//TRIM(GENFILE) JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=GENFILE,ACTION='WRITE',STATUS='UNKNOWN',FORM='FORMATTED') IF(JU.EQ.0)THEN; WRITE(*,'(A)') 'Error opening '//TRIM(GENFILE); RETURN; ENDIF N=0; DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL !## place vertical wall IF(IPC(ICOL,IROW,1).EQ.INT(1,1))THEN IF(ICOL.LT.IDF%NCOL)THEN; N=N+1; CALL PMANAGER_SAVEMF2005_HFB_GENFILES(JU,0,IPC,IDF,IDF%NROW,IDF%NCOL,IROW,ICOL,N,0.0,0.0,0.0); ENDIF ENDIF !## place horizontal wall IF(IPC(ICOL,IROW,2).EQ.INT(1,1))THEN !## write line in genfile IF(IROW.LT.IDF%NROW)THEN; N=N+1; CALL PMANAGER_SAVEMF2005_HFB_GENFILES(JU,0,IPC,IDF,IDF%NROW,IDF%NCOL,IROW,ICOL,N,0.0,0.0,0.0); ENDIF ENDIF ENDDO; ENDDO CLOSE(JU); CALL ASC2IDF_INT_DEALLOCATE(); DEALLOCATE(IPC); CALL IDFDEALLOCATEX(IDF) END SUBROUTINE IMODBATCH_GENSNAPTOGRID !###====================================================================== SUBROUTINE IMODBATCH_UZFTOCSV() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: UZFFILE,CSVFILE INTEGER,DIMENSION(2) :: JU INTEGER :: I,J,IOS IF(.NOT.UTL_READINITFILE('UZFFILE',LINE,IU,0))RETURN READ(LINE,*) UZFFILE; WRITE(*,'(A)') 'UZFFILE='//TRIM(UZFFILE) IF(.NOT.UTL_READINITFILE('CSVFILE',LINE,IU,0))RETURN READ(LINE,*) CSVFILE; WRITE(*,'(A)') 'CSVFILE='//TRIM(CSVFILE) JU(1)=UTL_GETUNIT(); OPEN(JU(1),FILE=UZFFILE,STATUS='OLD' ,ACTION='READ') JU(2)=UTL_GETUNIT(); OPEN(JU(2),FILE=CSVFILE,STATUS='UNKNOWN',ACTION='WRITE') ! 1 0.0000000E+00 8.7779391E-01 2.8722062E+00 7.1803361E-02 6.3689098E-02 ! 1.4360672E-01 6.3689098E-02 !## read all first DO I=1,2 DO J=1,3; READ(JU(1),*); ENDDO DO ! READ(JU(1),'(9X,I5,3X,5(1PE14.7,1X)',IOSTAT=IOS) K,T,H,T,D,WC ! 9014 FORMAT (62X, 2(1PE14.7, 1X)) IF(IOS.NE.0)EXIT ENDDO ENDDO CLOSE(JU(1)); CLOSE(JU(2)) END SUBROUTINE IMODBATCH_UZFTOCSV !###====================================================================== SUBROUTINE IMODBATCH_MKWELLIPF_MAIN() !###====================================================================== USE MOD_SCENTOOL_PAR, ONLY : STNLAY,TOPIDF,BOTIDF,KDIDF,CIDF USE MOD_IPF_PAR, ONLY : NIPF,IPF USE MOD_IPF, ONLY : IPFALLOCATE USE MOD_SCENTOOL_WELLS, ONLY : ST1CREATEIPF_STEADY USE MOD_IDF, ONLY : IDFNULLIFY IMPLICIT NONE INTEGER :: I,N,IKD,ICW,SDATE,EDATE,ISS,IMIDF,ICLAY,IFRAC,IQCOL REAL :: HNODATA,FNODATA,MAXC,MINKH,MINKD IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN; READ(LINE,*) STNLAY ALLOCATE(TOPIDF(STNLAY),BOTIDF(STNLAY),KDIDF(STNLAY),CIDF(STNLAY-1)) DO I=1,SIZE(TOPIDF); CALL IDFNULLIFY(TOPIDF(I)); ENDDO DO I=1,SIZE(BOTIDF); CALL IDFNULLIFY(BOTIDF(I)); ENDDO DO I=1,SIZE(KDIDF); CALL IDFNULLIFY(KDIDF(I)); ENDDO DO I=1,SIZE(CIDF); CALL IDFNULLIFY(CIDF(I)); ENDDO IKD=0; ICW=0 DO I=1,STNLAY IF(.NOT.UTL_READINITFILE('TOPIDF'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) TOPIDF(I)%FNAME; LINE='TOPIDF'//TRIM(ITOS(I))//'='//TRIM(TOPIDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('BOTIDF'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) BOTIDF(I)%FNAME; LINE='BOTIDF'//TRIM(ITOS(I))//'='//TRIM(BOTIDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) !## optionele opties IF(UTL_READINITFILE('KDIDF'//TRIM(ITOS(I)),LINE,IU,1))THEN IKD=1 READ(LINE,*) KDIDF(I)%FNAME; LINE='KDIDF'//TRIM(ITOS(I))//'='//TRIM(KDIDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) ENDIF IF(I.LT.STNLAY)THEN IF(UTL_READINITFILE('CIDF'//TRIM(ITOS(I)),LINE,IU,1))THEN ICW=1 READ(LINE,*) CIDF(I)%FNAME; LINE='CIDF'//TRIM(ITOS(I))//'='//TRIM(CIDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) ENDIF ENDIF ENDDO MAXC=1.0 IF(ICW.EQ.1)THEN IF(.NOT.UTL_READINITFILE('MAXC',LINE,IU,0))RETURN; READ(LINE,*) MAXC WRITE(*,'(A,F15.7)') 'MAXC=',MAXC ENDIF MINKH=0.0 IF(IKD.EQ.1)THEN IF(.NOT.UTL_READINITFILE('MINKH',LINE,IU,0))RETURN; READ(LINE,*) MINKH WRITE(*,'(A,F15.7)') 'MINKH=',MINKH ENDIF MINKD=0.0 IF(UTL_READINITFILE('MINKD',LINE,IU,1))THEN READ(LINE,*) MINKD WRITE(*,'(A,F15.7)') 'MINKD=',MINKD ENDIF !## whenever in clay, position above (<0) or beneath (+1) ICLAY=0; IF(UTL_READINITFILE('ICLAY',LINE,IU,1))READ(LINE,*) ICLAY WRITE(*,'(A,I5)') 'ICLAY=',ICLAY !## apply fraction for missing data IFRAC=1.0; IF(UTL_READINITFILE('IFRAC',LINE,IU,1))READ(LINE,*) IFRAC WRITE(*,'(A,I5)') 'IFRAC=',IFRAC !## usage of nodata HNODATA=0.0; IF(UTL_READINITFILE('HNODATA',LINE,IU,1))READ(LINE,*) HNODATA WRITE(*,'(A,F15.7)') 'HNODATA=',HNODATA !## usage of nodata FNODATA=-99999.0; IF(UTL_READINITFILE('FNODATA',LINE,IU,1))READ(LINE,*) FNODATA WRITE(*,'(A,F15.7)') 'FNODATA=',FNODATA NIPF=1; CALL IPFALLOCATE() IPF(1)%XCOL=1; IPF(1)%YCOL=2; IPF(1)%QCOL=3; IPF(1)%ZCOL=4; IPF(1)%Z2COL=5 IF(UTL_READINITFILE('IXCOL',LINE,IU,1))READ(LINE,*) IPF(1)%XCOL; WRITE(*,'(A,I2)') 'IXCOL=',IPF(1)%XCOL IF(UTL_READINITFILE('IYCOL',LINE,IU,1))READ(LINE,*) IPF(1)%YCOL; WRITE(*,'(A,I2)') 'IYCOL=',IPF(1)%YCOL IF(UTL_READINITFILE('IQCOL',LINE,IU,1))READ(LINE,*) IPF(1)%QCOL; WRITE(*,'(A,I2)') 'IQCOL=',IPF(1)%QCOL IF(UTL_READINITFILE('ITCOL',LINE,IU,1))READ(LINE,*) IPF(1)%ZCOL; WRITE(*,'(A,I2)') 'ITCOL=',IPF(1)%ZCOL IF(UTL_READINITFILE('IBCOL',LINE,IU,1))READ(LINE,*) IPF(1)%Z2COL; WRITE(*,'(A,I2)') 'IBCOL=',IPF(1)%Z2COL IQCOL=IPF(1)%QCOL IMIDF=0; IF(UTL_READINITFILE('IMIDF',LINE,IU,1))READ(LINE,*) IMIDF; WRITE(*,'(A,I2)') 'IMIDF=',IMIDF IF(.NOT.UTL_READINITFILE('NIPF',LINE,IU,0))RETURN READ(LINE,*) N; WRITE(*,'(A,I5)') 'NIPF=',N ISS=0; IF(UTL_READINITFILE('ISS',LINE,IU,1))READ(LINE,*) ISS WRITE(*,'(A,I1)') 'ISS=',ISS SDATE=0; EDATE=0; IF(ISS.EQ.1)THEN IF(.NOT.UTL_READINITFILE('SDATE',LINE,IU,0))RETURN READ(LINE,*) SDATE; WRITE(*,'(A,I8)') 'SDATE=',SDATE IF(.NOT.UTL_READINITFILE('EDATE',LINE,IU,0))RETURN READ(LINE,*) EDATE; WRITE(*,'(A,I8)') 'EDATE=',EDATE ENDIF DO I=1,N IF(.NOT.UTL_READINITFILE('IPF'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) IPF(1)%FNAME LINE='IPF'//TRIM(ITOS(I))//'='//TRIM(IPF(1)%FNAME); WRITE(*,'(A)') TRIM(LINE) !## reset qcol as that can be changed IPF(1)%QCOL=IQCOL !## read entire ipf IF(.NOT.IPFREAD2(1,1,1))RETURN IF(.NOT.ST1CREATEIPF_STEADY(IKD,ICW,MAXC,MINKH,IMIDF,SDATE,EDATE,ISS,ICLAY,IFRAC,HNODATA,FNODATA,MINKD))WRITE(*,'(A)') 'Error IPF '//TRIM(IPF(1)%FNAME)//' failed' ENDDO END SUBROUTINE IMODBATCH_MKWELLIPF_MAIN !###====================================================================== SUBROUTINE IMODBATCH_IMPORTSOBEK_MAIN() !###====================================================================== USE MOD_SOBEK_PAR, ONLY : ISGNAME,SOBEKDIR,CALCPNTHISNAME,STRUCHISNAME,IBATCH IMPLICIT NONE IF(.NOT.UTL_READINITFILE('ISGNAME',LINE,IU,0))RETURN READ(LINE,*) ISGNAME; WRITE(*,'(A)') 'ISGNAME='//TRIM(ISGNAME) IF(.NOT.UTL_READINITFILE('SOBEKDIR',LINE,IU,0))RETURN READ(LINE,*) SOBEKDIR; WRITE(*,'(A)') 'SOBEKDIR='//TRIM(SOBEKDIR) IF(.NOT.UTL_READINITFILE('CALCHIS',LINE,IU,0))RETURN READ(LINE,*) CALCPNTHISNAME; WRITE(*,'(A)') 'CALCHIS='//TRIM(CALCPNTHISNAME) STRUCHISNAME='' IF(UTL_READINITFILE('STRUCHIS',LINE,IU,1))THEN READ(LINE,*) STRUCHISNAME; WRITE(*,'(A)') 'STRUCHIS='//TRIM(STRUCHISNAME) ENDIF IBATCH=1 IF(.NOT.SOBEK1CALC())THEN; ENDIF END SUBROUTINE IMODBATCH_IMPORTSOBEK_MAIN !###====================================================================== SUBROUTINE IMODBATCH_CORRKD_MAIN() !###====================================================================== USE MOD_CORRKD_PAR, ONLY : NLAY,MINVC,MAXK,C_IDF,KD_IDF,TOP_IDF,BOT_IDF, & OUTPUTMAP,IBND_IDF,ANIF_IDF !,MAXZ IMPLICIT NONE INTEGER :: I IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) NLAY; LINE='NLAY='//TRIM(ITOS(NLAY)); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('MINVC',LINE,IU,0))RETURN READ(LINE,*) MINVC; LINE='MINVC='//TRIM(RTOS(MINVC,'F',7)); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('MAXK',LINE,IU,0))RETURN READ(LINE,*) MAXK; LINE='MAXK='//TRIM(RTOS(MAXK,'F',7)); WRITE(*,'(A)') TRIM(LINE) CALL CORRKD_ALLOCATE() ! IF(.NOT.UTL_READINITFILE('MAXZ',LINE,IU,0))RETURN ! READ(LINE,*) MAXZ; WRITE(*,'(A,F10.2)') 'MAXZ=',MAXZ DO I=1,NLAY IF(I.LT.NLAY)THEN IF(.NOT.UTL_READINITFILE('C_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) C_IDF(I)%FNAME; LINE='C_L'//TRIM(ITOS(I))//'='//TRIM(C_IDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) ENDIF IF(.NOT.UTL_READINITFILE('KD_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) KD_IDF(I)%FNAME; LINE='KD_L'//TRIM(ITOS(I))//'='//TRIM(KD_IDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('TOP_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) TOP_IDF(I)%FNAME; LINE='TOP_L'//TRIM(ITOS(I))//'='//TRIM(TOP_IDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('BOT_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) BOT_IDF(I)%FNAME; LINE='BOT_L'//TRIM(ITOS(I))//'='//TRIM(BOT_IDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('IBND_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) IBND_IDF(I)%FNAME; LINE='IBND_L'//TRIM(ITOS(I))//'='//TRIM(IBND_IDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) ANIF_IDF(I)%FNAME=''; IF(UTL_READINITFILE('ANIF_L'//TRIM(ITOS(I)),LINE,IU,1))THEN READ(LINE,*) ANIF_IDF(I)%FNAME; LINE='ANIF_L'//TRIM(ITOS(I))//'='//TRIM(ANIF_IDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) ENDIF ENDDO IF(.NOT.UTL_READINITFILE('OUTPUTMAP',LINE,IU,0))RETURN READ(LINE,*) OUTPUTMAP; WRITE(*,'(A)') 'OUTPUTMAP='//TRIM(OUTPUTMAP) CALL CORRKD_MAIN() !CALL CORRKD_DEALLOCATE() END SUBROUTINE IMODBATCH_CORRKD_MAIN !###====================================================================== SUBROUTINE IMODBATCH_GEF2IPF_MAIN() !###====================================================================== USE MOD_GEF2IPF_PAR, ONLY : GEFDIR,IPFFNAME,GENFNAME,GEFNAMES IMPLICIT NONE INTEGER :: GEFTYPE IF(.NOT.UTL_READINITFILE('GEFDIR',LINE,IU,0))RETURN READ(LINE,*) GEFDIR; WRITE(*,'(A)') 'GEFDIR='//TRIM(GEFDIR) IF(.NOT.UTL_READINITFILE('IPFFILE',LINE,IU,0))RETURN READ(LINE,*) IPFFNAME; WRITE(*,'(A)') 'IPFFILE='//TRIM(IPFFNAME) MPW%XMIN=0.0; MPW%YMIN=0.0; MPW%XMAX=0.0; MPW%YMAX=0.0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) MPW%XMIN,MPW%YMIN,MPW%XMAX,MPW%YMAX WRITE(*,'(A,4F10.2)') 'WINDOW=',MPW%XMIN,MPW%YMIN,MPW%XMAX,MPW%YMAX ENDIF GENFNAME='' IF(UTL_READINITFILE('GENFILE',LINE,IU,1))THEN READ(LINE,*) GENFNAME; WRITE(*,'(A)') 'GENFILE='//TRIM(GENFNAME) ENDIF GEFTYPE=0 IF(.NOT.UTL_READINITFILE('GEFTYPE',LINE,IU,0))RETURN READ(LINE,*) GEFTYPE; WRITE(*,*) 'GEFTYPE=',GEFTYPE IF(UTL_DIRINFO_POINTER(GEFDIR(:INDEX(GEFDIR,'\',.TRUE.)-1),GEFDIR(INDEX(GEFDIR,'\',.TRUE.)+1:),GEFNAMES,'F'))THEN CALL GEF2IPF_MAIN(1,GEFTYPE) ELSE WRITE(*,'(/1X,A)') 'No files found that match' WRITE(*,'(1X,A/)') TRIM(GEFDIR) ENDIF END SUBROUTINE IMODBATCH_GEF2IPF_MAIN !###====================================================================== SUBROUTINE IMODBATCH_UTM2LATLONG_MAIN() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: IDFNAME IF(.NOT.UTL_READINITFILE('IDFNAME',LINE,IU,0))RETURN READ(LINE,*) IDFNAME; WRITE(*,'(A)') 'IDFNAME='//TRIM(IDFNAME) CALL UTM_IDF2LATLONG(IDFNAME) END SUBROUTINE IMODBATCH_UTM2LATLONG_MAIN !###====================================================================== SUBROUTINE IMODBATCH_DINO2IPF_MAIN() !###====================================================================== USE MOD_DINO_PAR, ONLY : CSVFNAME,IPFFNAME,GENFNAME IMPLICIT NONE CHARACTER(LEN=256) :: ROOT CHARACTER(LEN=52) :: WC INTEGER :: I,N ALLOCATE(CSVFNAME(1)) IF(.NOT.UTL_READINITFILE('CSVFILE',LINE,IU,0))RETURN READ(LINE,*) CSVFNAME(1) IF(INDEX(CSVFNAME(1),'.').EQ.0)CSVFNAME(1)=TRIM(CSVFNAME(1))//'.csv' WRITE(*,'(A)') 'CSVFILE='//TRIM(CSVFNAME(1)) IF(INDEX(CSVFNAME(1),'*').EQ.0)THEN IPFFNAME=CSVFNAME(1)(:INDEX(CSVFNAME(1),'.',.TRUE.))//'ipf' IF(UTL_READINITFILE('IPFFILE',LINE,IU,0))READ(LINE,*) IPFFNAME ELSE I=INDEX(CSVFNAME(1),'\',.TRUE.); ROOT=CSVFNAME(1)(:I-1); WC=TRIM(CSVFNAME(1)(I+1:)) CALL IOSDIRENTRYTYPE('F'); CALL IOSDIRCOUNT(TRIM(ROOT),TRIM(WC),N) IF(N.EQ.0)THEN; WRITE(*,'(A)') 'No files found in: '//TRIM(CSVFNAME(1)); RETURN; ENDIF DEALLOCATE(CSVFNAME); ALLOCATE(CSVFNAME(N)) CALL UTL_DIRINFO(TRIM(ROOT),TRIM(WC),CSVFNAME,N,'F') DO I=1,SIZE(CSVFNAME); CSVFNAME(I)=TRIM(ROOT)//'\'//TRIM(CSVFNAME(I)); ENDDO IF(.NOT.UTL_READINITFILE('IPFFILE',LINE,IU,0))RETURN READ(LINE,*) IPFFNAME ENDIF WRITE(*,'(A)') 'IPFFILE='//TRIM(IPFFNAME) MPW%XMIN=0.0; MPW%YMIN=0.0; MPW%XMAX=0.0; MPW%YMAX=0.0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) MPW%XMIN,MPW%YMIN,MPW%XMAX,MPW%YMAX WRITE(*,'(A,4F10.2)') 'WINDOW=',MPW%XMIN,MPW%YMIN,MPW%XMAX,MPW%YMAX ENDIF GENFNAME='' IF(UTL_READINITFILE('GENFILE',LINE,IU,1))THEN READ(LINE,*) GENFNAME; WRITE(*,'(A)') 'GENFILE='//TRIM(GENFNAME) ENDIF CALL IMOD_DINO_MAIN() CALL IMOD_DINO_DEALLOCATE() END SUBROUTINE IMODBATCH_DINO2IPF_MAIN !###====================================================================== SUBROUTINE IMODBATCH_XYZTOIDF_MAIN() !###====================================================================== USE MOD_ASC2IDF_PAR, ONLY : IDFFILE,SOURCEDIR,TARGETDIR,IGRIDFUNC,CS,NODATA,LAGDISTANCE, & PERCENTILE,MINP,XYZFNAMES,RANGE,SILL,NUGGET,LAGINTERVAL,KTYPE,IXCOL,IYCOL,IZCOL,STDEVIDF,PNTSEARCH, & ASSF_COLUMN,ASSF_STARTDATE,ASSF_ENDDATE,ASSF_DDATE,ASSF_CDDATE,ILOG,TRIMDEPTH_IDF,ASSF_NTHRESHOLD, & GENFILE,BLNFILE,ASSF_TOP,ASSF_BOT,ASSF_IDEPTH,ASSF_DZ,ASSF_INDICATOR,ASSF_THRESHOLD,ASSF_K_THRESHOLD, & IQUADRANT,IINT_IDF,INT_IDF USE MOD_SOLID, ONLY : MXITER2,HCLOSE,RCLOSE USE MOD_UTL, ONLY : UTL_GETUNIT,UTL_JDATETOIDATE IMPLICIT NONE INTEGER :: I,J,K,N,IN_TYPE,JU,M,IDATE,SDATE,EDATE,DDATE,IOS,ICOL,IROW,JF,ID,KSUM,ILAY,NLAY CHARACTER(LEN=52) :: GRIDFUNC,WC,ROOT CHARACTER(LEN=256) :: FNAME,SNAME REAL :: XMIN,YMIN,XMAX,YMAX,Z1,Z2,MF,KH,VC TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: VOXEL REAL,POINTER,DIMENSION(:) :: DZ=>NULL() BLNFILE='' N=0; IN_TYPE=0 IF(UTL_READINITFILE('SOURCEDIR',LINE,IU,1))THEN READ(LINE,*) SOURCEDIR WRITE(*,'(A)') 'SOURCEDIR='//TRIM(SOURCEDIR) I=INDEX(SOURCEDIR,'\',.TRUE.); ROOT=SOURCEDIR(:I-1); WC=TRIM(SOURCEDIR(I+1:)) CALL IOSDIRENTRYTYPE('F'); CALL IOSDIRCOUNT(TRIM(ROOT),TRIM(WC),N) IF(N.EQ.0)THEN WRITE(*,'(A)') 'No files found in: '//TRIM(SOURCEDIR) RETURN ENDIF ALLOCATE(XYZFNAMES(N)); XYZFNAMES='' CALL UTL_DIRINFO(TRIM(ROOT),TRIM(WC),XYZFNAMES,N,'F') IF(.NOT.UTL_READINITFILE('TARGETDIR',LINE,IU,0))RETURN READ(LINE,*) TARGETDIR WRITE(*,'(A)') 'TARGETDIR='//TRIM(TARGETDIR) ELSE ALLOCATE(XYZFNAMES(2)); XYZFNAMES='' IF(UTL_READINITFILE('XYZFILE',LINE,IU,1))THEN READ(LINE,*) XYZFNAMES(1); WRITE(*,'(A)') 'XYZFILE='//TRIM(XYZFNAMES(1)); IN_TYPE=1 ENDIF IF(UTL_READINITFILE('IPFFILE',LINE,IU,1))THEN READ(LINE,*) XYZFNAMES(1); WRITE(*,'(A)') 'IPFFILE='//TRIM(XYZFNAMES(1)); IN_TYPE=2 ENDIF IF(UTL_READINITFILE('IDFFILE_IN',LINE,IU,1))THEN READ(LINE,*) XYZFNAMES(1); WRITE(*,'(A)') 'IDFFILE_IN='//TRIM(XYZFNAMES(1)); IN_TYPE=3 ENDIF IF(UTL_READINITFILE('GENFILE',LINE,IU,1))THEN READ(LINE,*) XYZFNAMES(1); WRITE(*,'(A)') 'GENFILE='//TRIM(XYZFNAMES(1)); IN_TYPE=4 ENDIF ENDIF IF(UTL_READINITFILE('IDFFILE_POINTER',LINE,IU,1))THEN READ(LINE,*) XYZFNAMES(2); WRITE(*,'(A)') 'IDFFILE_POINTER='//TRIM(XYZFNAMES(2)) ENDIF XMIN=0.0; YMIN=0.0; XMAX=0.0; YMAX=0.0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) XMIN,YMIN,XMAX,YMAX; WRITE(*,'(A,4F10.2)') 'WINDOW=',XMIN,YMIN,XMAX,YMAX ENDIF NODATA=-999.99 IF(UTL_READINITFILE('NODATA',LINE,IU,1))READ(LINE,*) NODATA WRITE(*,'(A,F10.2)') 'NODATA=',NODATA ILOG=0 IF(UTL_READINITFILE('ILOG',LINE,IU,1))READ(LINE,*) ILOG WRITE(*,'(A,I10)') 'ILOG=',ILOG IXCOL=1; IYCOL=2; IZCOL=3; ASSF_COLUMN=0; ASSF_STARTDATE=0; ASSF_ENDDATE=0; ASSF_DDATE=0; ASSF_CDDATE=''; TRIMDEPTH_IDF%FNAME='' ASSF_IDEPTH=0; ASSF_TOP=0.0; ASSF_BOT=0.0; ASSF_DZ=0.0; ASSF_NTHRESHOLD=1; ASSF_INDICATOR=0 IF(IN_TYPE.EQ.2)THEN IF(UTL_READINITFILE('IXCOL',LINE,IU,1))READ(LINE,*) IXCOL IF(UTL_READINITFILE('IYCOL',LINE,IU,1))READ(LINE,*) IYCOL IF(UTL_READINITFILE('IZCOL',LINE,IU,1))READ(LINE,*) IZCOL WRITE(*,'(A,I10)') 'IXCOL=',IXCOL WRITE(*,'(A,I10)') 'IYCOL=',IYCOL WRITE(*,'(A,I10)') 'IZCOL=',IZCOL !## if zcol eq iext then specify period for gridding JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=XYZFNAMES(1),STATUS='OLD',FORM='FORMATTED',ACTION='READ,DENYWRITE') IF(JU.EQ.0)THEN WRITE(*,'(/1X,A/)') 'Error, cannot find '//TRIM(XYZFNAMES(1)); STOP ENDIF READ(JU,*) M; READ(JU,*) M; DO I=1,M; READ(JU,*); ENDDO; READ(JU,*) M; CLOSE(JU) IF(M.GT.0.AND.M.EQ.IZCOL)THEN IF(.NOT.UTL_READINITFILE('ASSF_COLUMN',LINE,IU,0))RETURN READ(LINE,*) ASSF_COLUMN; WRITE(*,'(A,I3)') 'ASSF_COLUMN=',ASSF_COLUMN IF(.NOT.UTL_READINITFILE('ASSF_IDEPTH',LINE,IU,0))RETURN READ(LINE,*) ASSF_IDEPTH; WRITE(*,'(A,I10)') 'ASSF_IDEPTH=',ASSF_IDEPTH IF(ASSF_IDEPTH.EQ.0)THEN WRITE(*,'(/A/)') '>>> Dates are processed <<<' IF(.NOT.UTL_READINITFILE('ASSF_STARTDATE',LINE,IU,0))RETURN READ(LINE,*) ASSF_STARTDATE; WRITE(*,'(A,I10)') 'ASSF_STARTDATE=',ASSF_STARTDATE IF(.NOT.UTL_READINITFILE('ASSF_ENDDATE',LINE,IU,0))RETURN READ(LINE,*) ASSF_ENDDATE; WRITE(*,'(A,I10)') 'ASSF_ENDDATE=',ASSF_ENDDATE IF(.NOT.UTL_READINITFILE('ASSF_DDATE',LINE,IU,0))RETURN READ(LINE,*,IOSTAT=IOS) ASSF_DDATE IF(IOS.EQ.0)THEN WRITE(*,'(A,I10)') 'ASSF_DDATE=',ASSF_DDATE ELSE READ(LINE,*,IOSTAT=IOS) ASSF_CDDATE SELECT CASE (ASSF_CDDATE) CASE('D','W','M','Y') CASE DEFAULT WRITE(*,'(A)') 'SPECIFY ASSF_DDATE TO BE D,W,M,Y' END SELECT WRITE(*,'(A,A1)') 'ASSF_DDATE=',ASSF_CDDATE ENDIF ASSF_STARTDATE=UTL_IDATETOJDATE(ASSF_STARTDATE) ASSF_ENDDATE =UTL_IDATETOJDATE(ASSF_ENDDATE) ELSE WRITE(*,'(/A/)') '>>> Depths are processed <<<' IF(ASSF_IDEPTH.EQ.1)THEN IF(.NOT.UTL_READINITFILE('ASSF_TOP',LINE,IU,0))RETURN READ(LINE,*) ASSF_TOP; WRITE(*,'(A,F10.2)') 'ASSF_TOP=',ASSF_TOP IF(.NOT.UTL_READINITFILE('ASSF_BOT',LINE,IU,0))RETURN READ(LINE,*) ASSF_BOT; WRITE(*,'(A,F10.2)') 'ASSF_BOT=',ASSF_BOT IF(.NOT.IMODBATCH_READPOINTER_REAL(I,DZ,'ASSF_DZ',0,EXCLVALUE=0.0))RETURN IF(UTL_READINITFILE('TRIMTOP_IDF',LINE,IU,1))READ(LINE,'(A)') TRIMDEPTH_IDF(1)%FNAME IF(TRIM(TRIMDEPTH_IDF(1)%FNAME).NE.'')WRITE(*,'(A)') 'TRIMTOP_IDF='//TRIM(TRIMDEPTH_IDF(1)%FNAME) IF(UTL_READINITFILE('TRIMBOT_IDF',LINE,IU,1))READ(LINE,'(A)') TRIMDEPTH_IDF(2)%FNAME IF(TRIM(TRIMDEPTH_IDF(2)%FNAME).NE.'')WRITE(*,'(A)') 'TRIMBOT_IDF='//TRIM(TRIMDEPTH_IDF(2)%FNAME) ELSEIF(ASSF_IDEPTH.EQ.2)THEN IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) NLAY; WRITE(*,'(A,I3)') 'NLAY=',NLAY ALLOCATE(INT_IDF(NLAY)) DO ILAY=1,NLAY IF(.NOT.UTL_READINITFILE('INT_L'//TRIM(ITOS(ILAY)),LINE,IU,0))RETURN READ(LINE,*) INT_IDF(ILAY)%FNAME; LINE='INT_L'//TRIM(ITOS(ILAY)); WRITE(*,'(A,I3)') TRIM(LINE)//'='//TRIM(INT_IDF(ILAY)%FNAME) ENDDO ENDIF !## indicator ASSF_INDICATOR=0; ASSF_NTHRESHOLD=0 IF(UTL_READINITFILE('INDICATOR',LINE,IU,1))THEN READ(LINE,*) ASSF_INDICATOR; WRITE(*,*) 'INDICATOR=',ASSF_INDICATOR IF(.NOT.UTL_READINITFILE('NTHRESHOLD',LINE,IU,0))RETURN READ(LINE,*) ASSF_NTHRESHOLD; WRITE(*,*) 'NTHRESHOLD=',ASSF_NTHRESHOLD ALLOCATE(ASSF_THRESHOLD(ASSF_NTHRESHOLD)); ASSF_THRESHOLD='' ALLOCATE(ASSF_K_THRESHOLD(ASSF_NTHRESHOLD)); ASSF_K_THRESHOLD=0.0 DO I=1,ASSF_NTHRESHOLD IF(.NOT.UTL_READINITFILE('THRESHOLD'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) ASSF_THRESHOLD(I); WRITE(*,*) 'THRESHOLD'//TRIM(ITOS(I))//'=',ASSF_THRESHOLD(I) IF(.NOT.UTL_READINITFILE('K_THRESHOLD'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) ASSF_K_THRESHOLD(I); WRITE(*,*) 'K_THRESHOLD'//TRIM(ITOS(I))//'=',ASSF_K_THRESHOLD(I) ENDDO KSUM=0; IF(UTL_READINITFILE('KSUM',LINE,IU,1))READ(LINE,*) KSUM WRITE(*,*) 'KSUM=',KSUM ENDIF ENDIF ENDIF !## genfile ELSEIF(IN_TYPE.EQ.4)THEN IF(UTL_READINITFILE('IZCOL',LINE,IU,1))READ(LINE,*) IZCOL WRITE(*,'(A,I10)') 'IZCOL=',IZCOL NV=0; NL=0 !## reading labels WRITE(*,'(A)') 'Reading '//XYZFNAMES(1)(:INDEX(XYZFNAMES(1),'.',.TRUE.)-1)//'.dat ...' CALL UTL_GENLABELSREAD(XYZFNAMES(1)(:INDEX(XYZFNAMES(1),'.',.TRUE.)-1)//'.dat',VAR,NL,NV) IF(IZCOL.GT.NV)THEN; WRITE(*,'(A)') 'Error, entered label number exceeds available label'; STOP; ENDIF ENDIF IF(.NOT.UTL_READINITFILE('GRIDFUNC',LINE,IU,0))RETURN READ(LINE,*) GRIDFUNC; GRIDFUNC=UTL_CAP(GRIDFUNC,'U'); WRITE(*,'(A)') 'GRIDFUNC='//TRIM(GRIDFUNC) IGRIDFUNC=0 SELECT CASE (GRIDFUNC) CASE ('MIN'); IGRIDFUNC= 1 CASE ('MAX'); IGRIDFUNC= 2 CASE ('MEAN'); IGRIDFUNC= 3 CASE ('PERC'); IGRIDFUNC= 4 CASE ('BIVAR'); IGRIDFUNC= 5 CASE ('SKRIGING'); IGRIDFUNC= 6 CASE ('OKRIGING'); IGRIDFUNC=-6 CASE ('VARIOGRAM'); IGRIDFUNC= 7 CASE ('PCG') ; IGRIDFUNC= 8 END SELECT IF(IGRIDFUNC.NE.7)THEN IF(.NOT.UTL_READINITFILE('IDFFILE',LINE,IU,0))RETURN READ(LINE,*) IDFFILE; WRITE(*,'(A)') 'IDFFILE='//TRIM(IDFFILE) !## points from idf files IF(IN_TYPE.EQ.3)THEN !## neccessary to read in cell-size IF(XMIN.NE.XMAX)THEN IF(.NOT.UTL_READINITFILE('CS',LINE,IU,0))RETURN READ(LINE,*) CS; WRITE(*,'(A,F10.2)') 'CS=',CS ENDIF ELSE IF(.NOT.UTL_READINITFILE('CS',LINE,IU,0))RETURN READ(LINE,*) CS; WRITE(*,'(A,F10.2)') 'CS=',CS ENDIF ENDIF IF(IN_TYPE.EQ.3.AND.IGRIDFUNC.LT.5)STOP 'IDFFILE_IN in combination with GRIDFUNC=MIN,MAX,MEAN or PERC not sustained' SELECT CASE (IGRIDFUNC) CASE (0) WRITE(*,'(A)') 'ERROR, enter GRIDFUNC=MIN,MAX,MEAN,PERC,BIVAR,PCG,SKRIGING,OKRIGING,VARIOGRAM'; RETURN CASE (4) IF(.NOT.UTL_READINITFILE('PERCENTILE',LINE,IU,0))RETURN READ(LINE,*) PERCENTILE; WRITE(*,'(A,F10.2)') 'PERCENTILE=',PERCENTILE CASE (-6,6) PNTSEARCH=0 !## no search IF(.NOT.UTL_READINITFILE('KTYPE',LINE,IU,0))RETURN READ(LINE,*) KTYPE; WRITE(*,'(A,I10)') 'KTYPE=',KTYPE IF(.NOT.UTL_READINITFILE('RANGE',LINE,IU,0))RETURN READ(LINE,*) RANGE; WRITE(*,*) 'RANGE=',RANGE IF(.NOT.UTL_READINITFILE('SILL',LINE,IU,0))RETURN READ(LINE,*) SILL; WRITE(*,*) 'SILL=',SILL IF(.NOT.UTL_READINITFILE('NUGGET',LINE,IU,0))RETURN READ(LINE,*) NUGGET; WRITE(*,*) 'NUGGET=',NUGGET IF(NUGGET.LT.0.0)THEN WRITE(*,'(/A/)') 'It is not allowed to have a NUGGET value of less than zero'; STOP ENDIF MINP=0; IF(UTL_READINITFILE('MINP',LINE,IU,1))READ(LINE,*) MINP WRITE(*,'(A,I10)') 'MINP=',MINP IQUADRANT=0; IF(UTL_READINITFILE('IQUADRANT',LINE,IU,1))READ(LINE,*) IQUADRANT WRITE(*,'(A,I10)') 'IQUADRANT=',IQUADRANT IF(.NOT.UTL_READINITFILE('STDEVIDF',LINE,IU,0))RETURN READ(LINE,*) STDEVIDF; WRITE(*,'(A)') 'STDEVIDF='//TRIM(STDEVIDF) CASE (7) IF(.NOT.UTL_READINITFILE('LAGINTERVAL',LINE,IU,0))RETURN READ(LINE,*) LAGINTERVAL; WRITE(*,*) 'LAGINTERVAL=',LAGINTERVAL IF(.NOT.UTL_READINITFILE('LAGDISTANCE',LINE,IU,0))RETURN READ(LINE,*) LAGDISTANCE; WRITE(*,*) 'LAGDISTANCE=',LAGDISTANCE CASE (8) MXITER2=50 !## inner (linear system) HCLOSE=0.001 RCLOSE=10000.0 IF(UTL_READINITFILE('NINNER',LINE,IU,1))READ(LINE,*) MXITER2 IF(UTL_READINITFILE('HCLOSE',LINE,IU,1))READ(LINE,*) HCLOSE IF(UTL_READINITFILE('RCLOSE',LINE,IU,1))READ(LINE,*) RCLOSE WRITE(*,*) 'NINNER=',MXITER2 WRITE(*,*) 'HCLOSE=',HCLOSE WRITE(*,*) 'RCLOSE=',RCLOSE END SELECT IF(UTL_READINITFILE('BLNFILE',LINE,IU,1))THEN READ(LINE,*) BLNFILE; WRITE(*,'(A)') 'BLNFILE='//TRIM(BLNFILE) ENDIF DDATE=0 FNAME=IDFFILE(:INDEX(IDFFILE,'.',.TRUE.)-1) SNAME=STDEVIDF(:INDEX(STDEVIDF,'.',.TRUE.)-1) IF(ASSF_COLUMN.EQ.0)THEN SDATE=1; EDATE=1; DDATE=1 ELSE IF(ASSF_IDEPTH.EQ.0)THEN SDATE=ASSF_STARTDATE EDATE=ASSF_ENDDATE IF(ASSF_DDATE.EQ.0)THEN !## duration is equal to difference start- and enddate IF(ASSF_CDDATE.EQ.'')DDATE=(EDATE-SDATE)+1 ELSE DDATE=ASSF_DDATE ENDIF ENDIF ENDIF IF(N.EQ.0)THEN Z1=ASSF_TOP Z2=ASSF_BOT IF(ASSF_INDICATOR.GE.0)THEN DO I=1,ASSF_NTHRESHOLD IF(ASSF_INDICATOR.GT.0)THEN WRITE(*,'(/1X,A/)') 'Busy with indicator: '//TRIM(ASSF_THRESHOLD(ASSF_INDICATOR)) ENDIF ASSF_TOP=Z1; IINT_IDF=0 IF(ASSF_IDEPTH.EQ.0)IDATE=SDATE; ID=0 DO ID=ID+1 IF(ASSF_IDEPTH.EQ.0)THEN CALL IMODBATCH_XYZTOIDF_GETDDATE(IDATE,DDATE,ASSF_CDDATE) ASSF_STARTDATE= IDATE ASSF_ENDDATE = MIN(IDATE+DDATE,EDATE) ELSEIF(ASSF_IDEPTH.EQ.1)THEN IF(ID.LE.SIZE(DZ))THEN ASSF_DZ=DZ(ID) ELSE ASSF_DZ=DZ(SIZE(DZ)) ENDIF ASSF_BOT=MAX(Z2,ASSF_TOP-ASSF_DZ) ELSEIF(ASSF_IDEPTH.EQ.2)THEN IINT_IDF=IINT_IDF+1 ENDIF !## startdate IF(ASSF_COLUMN.NE.0)THEN IF(ASSF_IDEPTH.EQ.0)THEN IDFFILE =TRIM(FNAME)//'_'//TRIM(ITOS(UTL_JDATETOIDATE(IDATE)))//'.IDF' STDEVIDF=TRIM(SNAME)//'_'//TRIM(ITOS(UTL_JDATETOIDATE(IDATE)))//'.IDF' ELSEIF(ASSF_IDEPTH.EQ.1)THEN IDFFILE =TRIM(FNAME)//'_'//TRIM(ASSF_THRESHOLD(I))//'_T'//TRIM(RTOS(ASSF_TOP,'F',2))//'.IDF' STDEVIDF=TRIM(SNAME)//'_'//TRIM(ASSF_THRESHOLD(I))//'_T'//TRIM(RTOS(ASSF_TOP,'F',2))//'.IDF' ELSEIF(ASSF_IDEPTH.EQ.2)THEN IDFFILE =TRIM(FNAME)//'_'//TRIM(ASSF_THRESHOLD(I))//'_INT'//TRIM(ITOS(IINT_IDF))//'.IDF' STDEVIDF=TRIM(SNAME)//'_'//TRIM(ASSF_THRESHOLD(I))//'_INT'//TRIM(ITOS(IINT_IDF))//'.IDF' ENDIF ENDIF IF(.NOT.ASC2IDF_INT_MAIN(1,XMIN,YMIN,XMAX,YMAX))THEN; ENDIF IF(ASSF_IDEPTH.EQ.0)THEN IDATE=IDATE+DDATE IF(IDATE.GT.EDATE)EXIT ELSEIF(ASSF_IDEPTH.EQ.1)THEN IF(ASSF_BOT.LE.Z2)EXIT ASSF_TOP=ASSF_TOP-ASSF_DZ ELSEIF(ASSF_IDEPTH.EQ.2)THEN IF(IINT_IDF.EQ.NLAY-1)EXIT ENDIF ENDDO ASSF_INDICATOR=ASSF_INDICATOR+1 ENDDO ENDIF !## get final voxel-images IF(ABS(ASSF_INDICATOR).GT.0.AND.ASSF_NTHRESHOLD.GT.1)THEN ALLOCATE(VOXEL(ASSF_NTHRESHOLD+4)) ASSF_TOP=Z1; ID=0; IINT_IDF=0 DO ID=ID+1 IF(ASSF_IDEPTH.EQ.1)THEN IF(ID.LE.SIZE(DZ))THEN ASSF_DZ=DZ(ID) ELSE ASSF_DZ=DZ(SIZE(DZ)) ENDIF ASSF_BOT=MAX(Z2,ASSF_TOP-ASSF_DZ) WRITE(*,'(/1X,A/)') 'Busy with voxel layer: '//TRIM(RTOS(ASSF_TOP,'F',2))//'_'//TRIM(RTOS(ASSF_BOT,'F',2)) ELSEIF(ASSF_IDEPTH.EQ.2)THEN IINT_IDF=IINT_IDF+1 WRITE(*,'(/1X,A/)') 'Busy with interface: '//TRIM(ITOS(IINT_IDF)) ENDIF DO I=1,ASSF_NTHRESHOLD IF(ASSF_IDEPTH.EQ.1)THEN IDFFILE =TRIM(FNAME)//'_'//TRIM(ASSF_THRESHOLD(I))//'_T'//TRIM(RTOS(ASSF_TOP,'F',2))//'.IDF' ELSEIF(ASSF_IDEPTH.EQ.2)THEN IDFFILE =TRIM(FNAME)//'_'//TRIM(ASSF_THRESHOLD(I))//'_INT'//TRIM(ITOS(IINT_IDF))//'.IDF' ENDIF IF(.NOT.IDFREAD(VOXEL(I),IDFFILE,1,0))STOP ENDDO CALL IDFCOPY(VOXEL(1),VOXEL(ASSF_NTHRESHOLD+1)) CALL IDFCOPY(VOXEL(1),VOXEL(ASSF_NTHRESHOLD+2)) CALL IDFCOPY(VOXEL(1),VOXEL(ASSF_NTHRESHOLD+3)) CALL IDFCOPY(VOXEL(1),VOXEL(ASSF_NTHRESHOLD+4)) !## fill in final voxel - take majority value per voxel DO IROW=1,VOXEL(ASSF_NTHRESHOLD+1)%NROW; DO ICOL=1,VOXEL(ASSF_NTHRESHOLD+1)%NCOL VOXEL(ASSF_NTHRESHOLD+1)%X(ICOL,IROW)=VOXEL(ASSF_NTHRESHOLD+1)%NODATA VOXEL(ASSF_NTHRESHOLD+2)%X(ICOL,IROW)=0.0 VOXEL(ASSF_NTHRESHOLD+3)%X(ICOL,IROW)=0.0 VOXEL(ASSF_NTHRESHOLD+4)%X(ICOL,IROW)=0.0 !## normalize fraction to be 1.0 MF=0.0 DO I=1,ASSF_NTHRESHOLD IF(VOXEL(I)%X(ICOL,IROW).NE.VOXEL(I)%NODATA)THEN !## total fraction MF=MF+VOXEL(I)%X(ICOL,IROW) VOXEL(ASSF_NTHRESHOLD+4)%X(ICOL,IROW)=VOXEL(ASSF_NTHRESHOLD+4)%X(ICOL,IROW)+MF ENDIF ENDDO MF=1.0/MF DO I=1,ASSF_NTHRESHOLD IF(VOXEL(I)%X(ICOL,IROW).NE.VOXEL(I)%NODATA)THEN VOXEL(I)%X(ICOL,IROW)=VOXEL(I)%X(ICOL,IROW)*MF ENDIF ENDDO MF=0.0; JF=0 DO I=1,ASSF_NTHRESHOLD IF(VOXEL(I)%X(ICOL,IROW).NE.VOXEL(I)%NODATA)THEN IF(VOXEL(I)%X(ICOL,IROW).GT.MF)THEN MF=VOXEL(I)%X(ICOL,IROW); JF=I ENDIF IF(KSUM.EQ.1)THEN !## horizontal permeability KH= VOXEL(I)%X(ICOL,IROW)*ASSF_K_THRESHOLD(I) VOXEL(ASSF_NTHRESHOLD+2)%X(ICOL,IROW)=VOXEL(ASSF_NTHRESHOLD+2)%X(ICOL,IROW)+KH !## vertical resistance per meter VC=VOXEL(I)%X(ICOL,IROW)/ASSF_K_THRESHOLD(I) VOXEL(ASSF_NTHRESHOLD+3)%X(ICOL,IROW)=VOXEL(ASSF_NTHRESHOLD+3)%X(ICOL,IROW)+VC ENDIF ENDIF ENDDO IF(JF.GT.0)THEN VOXEL(ASSF_NTHRESHOLD+1)%X(ICOL,IROW)=JF IF(KSUM.EQ.0)THEN VOXEL(ASSF_NTHRESHOLD+2)%X(ICOL,IROW)=ASSF_K_THRESHOLD(JF) VOXEL(ASSF_NTHRESHOLD+3)%X(ICOL,IROW)=ASSF_K_THRESHOLD(JF) ENDIF !## vertical anisotropy VOXEL(ASSF_NTHRESHOLD+3)%X(ICOL,IROW)=VOXEL(ASSF_NTHRESHOLD+3)%X(ICOL,IROW)/VOXEL(ASSF_NTHRESHOLD+2)%X(ICOL,IROW) ELSE VOXEL(ASSF_NTHRESHOLD+2)%X(ICOL,IROW)=VOXEL(ASSF_NTHRESHOLD+2)%NODATA VOXEL(ASSF_NTHRESHOLD+3)%X(ICOL,IROW)=VOXEL(ASSF_NTHRESHOLD+3)%NODATA ENDIF ENDDO; ENDDO IF(ASSF_IDEPTH.EQ.1)THEN DO I=1,4; VOXEL(ASSF_NTHRESHOLD+I)%ITB=INT(1,1); VOXEL(ASSF_NTHRESHOLD+I)%TOP=ASSF_TOP; VOXEL(ASSF_NTHRESHOLD+I)%BOT=ASSF_BOT; ENDDO ELSEIF(ASSF_IDEPTH.EQ.2)THEN DO I=1,4; VOXEL(ASSF_NTHRESHOLD+I)%ITB=INT(0,1); VOXEL(ASSF_NTHRESHOLD+I)%TOP=0.0; VOXEL(ASSF_NTHRESHOLD+I)%BOT=0.0; ENDDO ENDIF !## main lithology IF(ASSF_IDEPTH.EQ.1)IDFFILE =TRIM(FNAME)//'_T'//TRIM(RTOS(ASSF_TOP,'F',2))//'_L.IDF' IF(ASSF_IDEPTH.EQ.2)IDFFILE =TRIM(FNAME)//'_INT'//TRIM(ITOS(IINT_IDF))//'_L.IDF' IF(.NOT.IDFWRITE(VOXEL(ASSF_NTHRESHOLD+1),IDFFILE,1))STOP !## permeability IF(ASSF_IDEPTH.EQ.1)IDFFILE =TRIM(FNAME)//'_T'//TRIM(RTOS(ASSF_TOP,'F',2))//'_K.IDF' IF(ASSF_IDEPTH.EQ.2)IDFFILE =TRIM(FNAME)//'_INT'//TRIM(ITOS(IINT_IDF))//'_K.IDF' IF(.NOT.IDFWRITE(VOXEL(ASSF_NTHRESHOLD+2),IDFFILE,1))STOP !## vertical anisotropy IF(ASSF_IDEPTH.EQ.1)IDFFILE =TRIM(FNAME)//'_T'//TRIM(RTOS(ASSF_TOP,'F',2))//'_A.IDF' IF(ASSF_IDEPTH.EQ.2)IDFFILE =TRIM(FNAME)//'_INT'//TRIM(ITOS(IINT_IDF))//'_A.IDF' IF(.NOT.IDFWRITE(VOXEL(ASSF_NTHRESHOLD+3),IDFFILE,1))STOP !## sum of fractions IF(ASSF_IDEPTH.EQ.1)IDFFILE =TRIM(FNAME)//'_T'//TRIM(RTOS(ASSF_TOP,'F',2))//'_F.IDF' IF(ASSF_IDEPTH.EQ.2)IDFFILE =TRIM(FNAME)//'_INT'//TRIM(ITOS(IINT_IDF))//'_F.IDF' IF(.NOT.IDFWRITE(VOXEL(ASSF_NTHRESHOLD+4),IDFFILE,1))STOP IF(ASSF_IDEPTH.EQ.1)THEN IF(ASSF_BOT.LE.Z2)EXIT ASSF_TOP=ASSF_TOP-ASSF_DZ ELSEIF(ASSF_IDEPTH.EQ.2)THEN IF(IINT_IDF.EQ.NLAY-1)EXIT ENDIF ENDDO CALL IDFDEALLOCATE(VOXEL,SIZE(VOXEL)); DEALLOCATE(VOXEL) ENDIF ELSE IDATE=SDATE DO ASSF_STARTDATE= IDATE ASSF_ENDDATE = MIN(IDATE+DDATE,EDATE) DO I=1,N WRITE(*,'(A)') 'Busy with '//TRIM(XYZFNAMES(I)) J=INDEX(XYZFNAMES(I),'\',.TRUE.)+1; K=INDEX(XYZFNAMES(I),'.',.TRUE.)-1 IDFFILE=TRIM(TARGETDIR)//'\'//XYZFNAMES(I)(J:K) IF(ASSF_COLUMN.NE.0)IDFFILE=TRIM(IDFFILE)//'_'//TRIM(ITOS(UTL_JDATETOIDATE(IDATE))) IDFFILE=TRIM(IDFFILE)//'.IDF' XYZFNAMES(I)=TRIM(ROOT)//'\'//TRIM(XYZFNAMES(I)) IF(.NOT.ASC2IDF_INT_MAIN(I,XMIN,YMIN,XMAX,YMAX))THEN ENDIF ENDDO IDATE=IDATE+DDATE; IF(IDATE.GT.EDATE)EXIT ENDDO ENDIF IF(ALLOCATED(ASSF_THRESHOLD))DEALLOCATE(ASSF_THRESHOLD) IF(ALLOCATED(ASSF_K_THRESHOLD))DEALLOCATE(ASSF_K_THRESHOLD) IF(ALLOCATED(INT_IDF))THEN; CALL IDFDEALLOCATE(INT_IDF,SIZE(INT_IDF)); DEALLOCATE(INT_IDF); ENDIF END SUBROUTINE IMODBATCH_XYZTOIDF_MAIN !###====================================================================== SUBROUTINE IMODBATCH_XYZTOIDF_GETDDATE(IDATE,DDATE,ASSF_CDDATE) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: IDATE INTEGER,INTENT(INOUT) :: DDATE CHARACTER(LEN=1),INTENT(IN) :: ASSF_CDDATE INTEGER :: IY,IM,ID SELECT CASE (ASSF_CDDATE) CASE ('D') DDATE=1 CASE ('W') DDATE=7 CASE ('M') CALL UTL_GDATE(IDATE,IY,IM,ID) DDATE=WDATEDAYSINMONTH(IY,IM) CASE ('Y') CALL UTL_GDATE(IDATE,IY,IM,ID) DDATE=365; IF(WDATELEAPYEAR(IY))DDATE=DDATE+1 END SELECT END SUBROUTINE IMODBATCH_XYZTOIDF_GETDDATE !###====================================================================== SUBROUTINE IMODBATCH_IPFSAMPLE_MAIN() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256),DIMENSION(3) :: FNAME INTEGER :: IXCOL,IYCOL,IACOL IF(.NOT.UTL_READINITFILE('IPFFILE_IN',LINE,IU,0))RETURN READ(LINE,*) FNAME(1); WRITE(*,'(A)') 'IPFFILE_IN='//TRIM(FNAME(1)) IXCOL=1; IF(UTL_READINITFILE('IXCOL',LINE,IU,1))READ(LINE,*) IXCOL WRITE(*,'(A,I2)') 'IXCOL=',IXCOL IYCOL=2; IF(UTL_READINITFILE('IYCOL',LINE,IU,1))READ(LINE,*) IYCOL WRITE(*,'(A,I2)') 'IYCOL=',IYCOL IACOL=0; IF(UTL_READINITFILE('IACOL',LINE,IU,1))READ(LINE,*) IACOL WRITE(*,'(A,I2)') 'IACOL=',IACOL IF(.NOT.UTL_READINITFILE('IPFFILE_OUT',LINE,IU,0))RETURN READ(LINE,*) FNAME(2); WRITE(*,'(A)') 'IPFFILE_OUT='//TRIM(FNAME(2)) IF(.NOT.UTL_READINITFILE('SOURCEDIR',LINE,IU,0))RETURN READ(LINE,*) FNAME(3); WRITE(*,'(A)') 'SOURCEDIR='//TRIM(FNAME(3)) CALL IPFSAMPLE(FNAME(1),FNAME(2),FNAME(3),IXCOL,IYCOL,IACOL) END SUBROUTINE IMODBATCH_IPFSAMPLE_MAIN !###====================================================================== SUBROUTINE IMODBATCH_IPFRESIDUAL() !###====================================================================== USE MOD_TSTAT_PAR, ONLY : IPFFILE,OUTNAME,IHCOL,IMCOL,IWCOL,ILCOL,W_TYPE, & POINTERIDF,NZONE,IZONE,HNODATA,ICOLLECT,SOBSDATE,EOBSDATE IMPLICIT NONE INTEGER :: I,NIPF POINTERIDF='' IF(UTL_READINITFILE('POINTERIDF',LINE,IU,1))THEN READ(LINE,*) POINTERIDF; WRITE(*,'(A)') 'POINTERIDF='//TRIM(POINTERIDF) IF(.NOT.UTL_READINITFILE('NZONE',LINE,IU,0))RETURN READ(LINE,*) NZONE; WRITE(*,'(A,I10)') 'NZONE=',NZONE ALLOCATE(IZONE(NZONE)) DO I=1,NZONE IF(.NOT.UTL_READINITFILE('IZONE'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) IZONE(I); LINE='IZONE'//TRIM(ITOS(I))//'='//TRIM(ITOS(IZONE(I))) WRITE(*,'(A)') TRIM(LINE) ENDDO ENDIF !## colect all txt files into a single folder and add to the ipf file ICOLLECT=0; IF(UTL_READINITFILE('ICOLLECT',LINE,IU,1))READ(LINE,*) ICOLLECT WRITE(*,'(A,I2)') 'ICOLLECT=',ICOLLECT !HNODATA=-999.99; IF(UTL_READINITFILE('HNODATA',LINE,IU,1))READ(LINE,*) HNODATA !WRITE(*,'(A,F10.3)') 'HNODATA=',HNODATA IF(.NOT.UTL_READINITFILE('NIPF',LINE,IU,0))RETURN READ(LINE,*) NIPF; WRITE(*,'(A,I10)') 'NIPF=',NIPF ALLOCATE(IPFFILE(NIPF),IHCOL(NIPF),IMCOL(NIPF),IWCOL(NIPF),ILCOL(NIPF),W_TYPE(NIPF)) DO I=1,NIPF IF(.NOT.UTL_READINITFILE('IPFFILE'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) IPFFILE(I); LINE='IPFFILE'//TRIM(ITOS(I))//'='//TRIM(IPFFILE(I)) WRITE(*,'(A)') TRIM(LINE) W_TYPE(I)=0 IF(UTL_READINITFILE('W_TYPE'//TRIM(ITOS(I)),LINE,IU,1))THEN READ(LINE,*) W_TYPE(I) LINE='W_TYPE'//TRIM(ITOS(I))//'='//TRIM(ITOS(W_TYPE(I))); WRITE(*,'(A)') TRIM(LINE) ENDIF IWCOL(I)=3 IF(W_TYPE(I).NE.0)THEN IF(UTL_READINITFILE('IWCOL'//TRIM(ITOS(I)),LINE,IU,1))READ(LINE,*) IWCOL(I) LINE='IWCOL'//TRIM(ITOS(I))//'='//TRIM(ITOS(IWCOL(I))); WRITE(*,'(A)') TRIM(LINE) ENDIF IHCOL(I)=3 IF(UTL_READINITFILE('IHCOL'//TRIM(ITOS(I)),LINE,IU,1))THEN READ(LINE,*) IHCOL(I) LINE='IHCOL'//TRIM(ITOS(I))//'='//TRIM(ITOS(IHCOL(I))); WRITE(*,'(A)') TRIM(LINE) ENDIF IMCOL(I)=3 IF(UTL_READINITFILE('IMCOL'//TRIM(ITOS(I)),LINE,IU,1))THEN READ(LINE,*) IMCOL(I) LINE='IMCOL'//TRIM(ITOS(I))//'='//TRIM(ITOS(IMCOL(I))); WRITE(*,'(A)') TRIM(LINE) ENDIF ILCOL(I)=3 IF(UTL_READINITFILE('ILCOL'//TRIM(ITOS(I)),LINE,IU,1))THEN READ(LINE,*) ILCOL(I) LINE='ILCOL'//TRIM(ITOS(I))//'='//TRIM(ITOS(ILCOL(I))); WRITE(*,'(A)') TRIM(LINE) ENDIF ENDDO SOBSDATE=0 IF(UTL_READINITFILE('SDATE',LINE,IU,1))THEN READ(LINE,*) SOBSDATE LINE='SDATE='//TRIM(ITOS(SOBSDATE)); WRITE(*,'(A)') TRIM(LINE) ENDIF EOBSDATE=0 IF(UTL_READINITFILE('EDATE',LINE,IU,1))THEN READ(LINE,*) EOBSDATE LINE='EDATE='//TRIM(ITOS(EOBSDATE)); WRITE(*,'(A)') TRIM(LINE) ENDIF IF(.NOT.UTL_READINITFILE('OUTNAME',LINE,IU,0))RETURN READ(LINE,*) OUTNAME; WRITE(*,'(A)') 'OUTNAME='//TRIM(OUTNAME) CALL TSTATRESIDUAL() END SUBROUTINE IMODBATCH_IPFRESIDUAL !###====================================================================== SUBROUTINE IMODBATCH_ISGGRID() !###====================================================================== USE MOD_ISG_PAR IMPLICIT NONE INTEGER :: I,NLAY TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: TOP,BOT TYPE(GRIDISGOBJ) :: GRIDISG CHARACTER(LEN=256) :: ISGFILE GRIDISG%MINDEPTH=0.10 !'mindepth : minimal waterdepth for computing conductances (m)' GRIDISG%WDEPTH=1.0 ! waterdepth : for simgro trapezia GRIDISG%ICDIST=0 !'icdist : (0) do not compute effect of weirs (1) do compute effect of weirs' GRIDISG%ISIMGRO=0 !'isimgro : usage of simgro' !## if isimgro>0 GRIDISG%THIESSENFNAME='' GRIDISG%AHNFNAME='' GRIDISG%SEGMENTCSVFNAME='' GRIDISG%SYSID=0 GRIDISG%ISTEADY=1 !'iss : (1) mean over all periods, (2) mean over given period' GRIDISG%IDIM=2 !'idim : (1) give area (2) entire domain of isg (3) selected isg' GRIDISG%POSTFIX='' GRIDISG%STIME=INT(0,8); GRIDISG%ETIME=INT(0,8); GRIDISG%DTIME=INT(0,8) GRIDISG%SDATE=0; GRIDISG%EDATE=0; GRIDISG%DDATE=0 GRIDISG%ISAVE=1 GRIDISG%MAXWIDTH=250.0 GRIDISG%IAVERAGE=1 !## (1) take the mean (2) take the median value GRIDISG%IEXPORT=0 !## (0) idf (1) modflow river file NLAY=0 !## number of layer read in GRIDISG%IDIM=2; GRIDISG%XMIN=0.0; GRIDISG%YMIN=0.0; GRIDISG%XMAX=0.0; GRIDISG%YMAX=0.0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) GRIDISG%XMIN,GRIDISG%YMIN,GRIDISG%XMAX,GRIDISG%YMAX WRITE(*,'(A,4F10.2)') 'WINDOW=',GRIDISG%XMIN,GRIDISG%YMIN,GRIDISG%XMAX,GRIDISG%YMAX MPW%XMIN=GRIDISG%XMIN; MPW%YMIN=GRIDISG%YMIN; MPW%XMAX=GRIDISG%XMAX; MPW%YMAX=GRIDISG%YMAX GRIDISG%IDIM=1 ENDIF IF(.NOT.UTL_READINITFILE('CELL_SIZE',LINE,IU,0))RETURN READ(LINE,*) GRIDISG%CS; WRITE(*,'(A,F10.2)') 'CELL_SIZE=',GRIDISG%CS IF(.NOT.UTL_READINITFILE('NODATA',LINE,IU,0))RETURN READ(LINE,*) GRIDISG%NODATA; WRITE(*,'(A,F10.2)') 'NODATA=',GRIDISG%NODATA IF(UTL_READINITFILE('ISIMGRO',LINE,IU,1))READ(LINE,*) GRIDISG%ISIMGRO WRITE(*,'(A,I1)') 'ISIMGRO=',GRIDISG%ISIMGRO IF(GRIDISG%ISIMGRO.EQ.1)THEN IF(.NOT.UTL_READINITFILE('SVAT2SWNR_DRNG',LINE,IU,0))RETURN READ(LINE,*) GRIDISG%SVAT2SWNR_DRNG; WRITE(*,'(A)') 'SVAT2SWNR_DRNG='//TRIM(GRIDISG%SVAT2SWNR_DRNG) IF(.NOT.UTL_READINITFILE('THIESSENFNAME',LINE,IU,0))RETURN READ(LINE,*) GRIDISG%THIESSENFNAME; WRITE(*,'(A)') 'THIESSENFNAME='//TRIM(GRIDISG%THIESSENFNAME) IF(.NOT.UTL_READINITFILE('AHNFNAME',LINE,IU,0))RETURN READ(LINE,*) GRIDISG%AHNFNAME; WRITE(*,'(A)') 'AHNFNAME='//TRIM(GRIDISG%AHNFNAME) IF(.NOT.UTL_READINITFILE('SEGMENTCSVFNAME',LINE,IU,0))RETURN READ(LINE,*) GRIDISG%SEGMENTCSVFNAME; WRITE(*,'(A)') 'SEGMENTCSVFNAME='//TRIM(GRIDISG%SEGMENTCSVFNAME) IF(.NOT.UTL_READINITFILE('SYSID',LINE,IU,0))RETURN READ(LINE,*) GRIDISG%SYSID; WRITE(*,'(A,I10)') 'SYSID=',GRIDISG%SYSID IF(UTL_READINITFILE('WDEPTH',LINE,IU,1))READ(LINE,*) GRIDISG%WDEPTH WRITE(*,'(A,F10.2)') 'WDEPTH=',GRIDISG%WDEPTH GRIDISG%MINDEPTH=GRIDISG%WDEPTH ELSE IF(UTL_READINITFILE('MINDEPTH',LINE,IU,1))READ(LINE,*) GRIDISG%MINDEPTH WRITE(*,'(A,F10.2)') 'MINDEPTH=',GRIDISG%MINDEPTH ENDIF IF(UTL_READINITFILE('MAXWIDTH',LINE,IU,1))READ(LINE,*) GRIDISG%MAXWIDTH WRITE(*,'(A,F10.2)') 'MAXWIDTH=',GRIDISG%MAXWIDTH IF(UTL_READINITFILE('POSTFIX',LINE,IU,1))READ(LINE,*) GRIDISG%POSTFIX WRITE(*,'(A)') 'POSTFIX='//TRIM(GRIDISG%POSTFIX) IF(.NOT.UTL_READINITFILE('OUTPUTFOLDER',LINE,IU,0))RETURN READ(LINE,*) GRIDISG%ROOT; WRITE(*,'(A)') 'OUTPUTFOLDER='//TRIM(GRIDISG%ROOT) CALL UTL_CREATEDIR(GRIDISG%ROOT) IF(.NOT.UTL_READINITFILE('ISAVE',LINE,IU,0))RETURN READ(LINE,*) GRIDISG%ISAVE; WRITE(*,'(A,99I1)') 'ISAVE=',GRIDISG%ISAVE IF(UTL_READINITFILE('IPERIOD',LINE,IU,1))READ(LINE,*) GRIDISG%ISTEADY WRITE(*,'(A,I1)') 'IPERIOD=',GRIDISG%ISTEADY IF(GRIDISG%ISTEADY.EQ.2)THEN IF(.NOT.UTL_READINITFILE('SDATE',LINE,IU,0))RETURN READ(LINE,*) GRIDISG%SDATE; WRITE(*,'(A,I8)') 'SDATE=',GRIDISG%SDATE IF(.NOT.UTL_READINITFILE('EDATE',LINE,IU,0))RETURN READ(LINE,*) GRIDISG%EDATE; WRITE(*,'(A,I8)') 'EDATE=',GRIDISG%EDATE IF(UTL_READINITFILE('DDATE',LINE,IU,1))READ(LINE,*) GRIDISG%DDATE WRITE(*,'(A,I10)') 'DDATE=',GRIDISG%DDATE GRIDISG%STIME=GRIDISG%SDATE*1000000; GRIDISG%ETIME=GRIDISG%EDATE*1000000; GRIDISG%DTIME=GRIDISG%DDATE*1000000 ENDIF IF(UTL_READINITFILE('IAVERAGE',LINE,IU,1))READ(LINE,*) GRIDISG%IAVERAGE WRITE(*,'(A,I1)') 'IAVERAGE=',GRIDISG%IAVERAGE IF(UTL_READINITFILE('IEXPORT',LINE,IU,1))READ(LINE,*) GRIDISG%IEXPORT WRITE(*,'(A,I1)') 'IEXPORT=',GRIDISG%IEXPORT IF(GRIDISG%IEXPORT.EQ.1)THEN IF(UTL_READINITFILE('NLAY',LINE,IU,1))READ(LINE,*) NLAY IF(NLAY.GT.0)THEN WRITE(*,'(A,I8)') 'NLAY=',NLAY ALLOCATE(TOP(NLAY),BOT(NLAY)) DO I=1,NLAY CALL IDFNULLIFY(BOT(I)); CALL IDFNULLIFY(TOP(I)) IF(.NOT.UTL_READINITFILE('TOP_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) TOP(I)%FNAME; LINE='TOP_L'//TRIM(ITOS(I))//'='; WRITE(*,'(A)') TRIM(LINE)//TRIM(TOP(I)%FNAME) IF(.NOT.UTL_READINITFILE('BOT_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) BOT(I)%FNAME; LINE='BOT_L'//TRIM(ITOS(I))//'='; WRITE(*,'(A)') TRIM(LINE)//TRIM(BOT(I)%FNAME) ENDDO ENDIF ELSE NLAY=1; ALLOCATE(TOP(NLAY),BOT(NLAY)) DO I=1,NLAY; CALL IDFNULLIFY(BOT(I)); CALL IDFNULLIFY(TOP(I)); ENDDO ENDIF IF(.NOT.UTL_READINITFILE('ISGFILE_IN',LINE,IU,0))RETURN READ(LINE,*) ISGFILE; WRITE(*,'(A)') 'ISGFILE_IN='//TRIM(ISGFILE) IF(.NOT.ISG2GRIDMAIN(ISGFILE,1,NLAY,TOP,BOT,GRIDISG))THEN; WRITE(*,'(/A/)') 'Error occured in ISG Grid routine'; ENDIF CALL ISGDEAL(1) DO I=1,NLAY CALL IDFDEALLOCATE(TOP,SIZE(TOP)) CALL IDFDEALLOCATE(BOT,SIZE(BOT)) ENDDO DEALLOCATE(TOP,BOT) END SUBROUTINE IMODBATCH_ISGGRID !###====================================================================== SUBROUTINE IMODBATCH_ISGADJUST_MAIN() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: SESFILE,LOGFILE,ISGFILE IF(.NOT.UTL_READINITFILE('SESFILE',LINE,IU,0))RETURN READ(LINE,*) SESFILE WRITE(*,'(A)') 'SESFILE='//TRIM(SESFILE) LOGFILE='.\log_ses.txt' IF(UTL_READINITFILE('LOGFILE',LINE,IU,1))READ(LINE,*) LOGFILE WRITE(*,'(A/)') 'LOGFILE='//TRIM(LOGFILE) IF(ISGADJUSTAPPLY(SESFILE,LOGFILE,1))THEN IF(UTL_READINITFILE('OUTNAME',LINE,IU,1))READ(LINE,*) ISGFILE WRITE(*,'(/A)') 'OUTNAME='//TRIM(ISGFILE) CALL ISGSAVE(ISGFILE,2) !- saving ONLY *.ISG, *.isp, *.isd ENDIF END SUBROUTINE IMODBATCH_ISGADJUST_MAIN !###====================================================================== SUBROUTINE IMODBATCH_ISGSIMPLIFY_MAIN() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: ISGFILE REAL :: ZTOLERANCE,NODATA IF(.NOT.UTL_READINITFILE('ISGFILE_IN',LINE,IU,0))RETURN READ(LINE,*) ISGFILE; WRITE(*,'(A)') 'ISGFILE_IN='//TRIM(ISGFILE) IF(.NOT.UTL_READINITFILE('ZTOLERANCE',LINE,IU,0))RETURN READ(LINE,*) ZTOLERANCE; WRITE(*,'(A,F10.2)') 'ZTOLERANCE=',ZTOLERANCE IF(.NOT.UTL_READINITFILE('NODATA',LINE,IU,0))RETURN READ(LINE,*) NODATA; WRITE(*,'(A,F10.2)') 'NODATA=',NODATA IF(.NOT.UTL_READINITFILE('ISGFILE_OUT',LINE,IU,0))RETURN CALL ISG_SIMPLIFYMAIN(ISGFILE,ZTOLERANCE,NODATA,1) READ(LINE,*) ISGFILE; WRITE(*,'(A)') 'ISGFILE_OUT='//TRIM(ISGFILE) WRITE(*,'(/A)') 'ISGFILE_OUT='//TRIM(ISGFILE) !## saving isg CALL ISGSAVE(ISGFILE,2) END SUBROUTINE IMODBATCH_ISGSIMPLIFY_MAIN !###====================================================================== SUBROUTINE IMODBATCH_SFRTOISG_MAIN() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: ISGFILE,SFRFILE REAL,DIMENSION(11) :: R INTEGER,DIMENSION(5) :: ID REAL :: QSTR,SHED,SDEP,SWID INTEGER :: JU,I,J,IREC,IPER,NPER IF(.NOT.UTL_READINITFILE('ISGFILE_IN',LINE,IU,0))RETURN READ(LINE,*) ISGFILE; WRITE(*,'(A)') 'ISGFILE_IN='//TRIM(ISGFILE) !## read entire ISG file IF(ISGREAD((/ISGFILE/),1))THEN; ENDIF IF(.NOT.UTL_READINITFILE('SFRFILE_IN',LINE,IU,0))RETURN READ(LINE,*) SFRFILE; WRITE(*,'(A)') 'SFRFILE_IN='//TRIM(SFRFILE) JU=UTL_GETUNIT(); OPEN(JU,FILE=SFRFILE,FORM='FORMATTED',STATUS='OLD',ACTION='READ') NPER=ISD(1)%N DO IPER=1,NPER DO J=1,8; READ(JU,*); ENDDO DO I=1,NISG READ(JU,*) (ID(J),J=1,5),(R(J),J=1,11) ! !## extern flow components ! QEXT= -R(2)+R(4)+R(5)-R(6) !## average flow in stream QSTR=(R(1)+R(3))/2.0 ! !## net stream discharge ! QSTR=QSTR+QEXT !## waterlevel SHED=R(7) !## waterdepth SDEP=R(8) !## waterwidth SWID=R(9) ! LAYER ROW COL. STREAM RCH. FLOW INTO FLOW TO FLOW OUT OF OVRLND. DIRECT STREAM STREAM STREAM STREAM STREAMBED STREAMBED ! SEG.NO. NO. STRM. RCH. AQUIFER STRM. RCH. RUNOFF PRECIP ET HEAD DEPTH WIDTH CONDCTNC. GRADIENT ! 1 1 1 1 1 6.3357E+04 7.9484E+03 5.5409E+04 0.000E+00 0.000E+00 0.000E+00 3.37445E+02 3.587E-01 3.931E+00 5.850E+03 1.359E+00 !## put results on each calculation point of isg DO J=1,ISG(I)%NCLC IREC=IPER+(I-1)*NPER*2+(J-1)*NPER DATISD(IREC)%WLVL =SHED DATISD(IREC)%BTML =SDEP DATISD(IREC)%RESIS=SWID DATISD(IREC)%INFF =QSTR/85400.0 !## m3/day - m3/sec ENDDO ENDDO ENDDO CLOSE(JU) IF(.NOT.UTL_READINITFILE('ISGFILE_OUT',LINE,IU,0))RETURN READ(LINE,*) ISGFILE; WRITE(*,'(A)') 'ISGFILE_OUT='//TRIM(ISGFILE) WRITE(*,'(/A)') 'ISGFILE_OUT='//TRIM(ISGFILE) !## saving isg CALL ISGSAVE(ISGFILE,2) END SUBROUTINE IMODBATCH_SFRTOISG_MAIN !###====================================================================== SUBROUTINE IMODBATCH_ISGTOSFR_MAIN() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: ISGFILE REAL :: WL,BL,F,C INTEGER :: I,ID IF(.NOT.UTL_READINITFILE('ISGFILE_IN',LINE,IU,0))RETURN READ(LINE,*) ISGFILE; WRITE(*,'(A)') 'ISGFILE_IN='//TRIM(ISGFILE) !## read entire ISG file IF(ISGREAD((/ISGFILE/),1))THEN; ENDIF !## turn to sfr mode ISFR=1 !## fill in the appropriate data DO I=1,SIZE(DATISD) ID=DATISD(I)%IDATE WL=DATISD(I)%WLVL BL=DATISD(I)%BTML C =DATISD(I)%RESIS F =DATISD(I)%INFF DATISD(I)%IDATE=ID DATISD(I)%CTIME='00:00:00' DATISD(I)%WLVL =WL DATISD(I)%BTML =BL DATISD(I)%WIDTH=1.0 DATISD(I)%THCK =1.0 DATISD(I)%HCND =1.0 DATISD(I)%QFLW =0.0 DATISD(I)%QROF =0.0 DATISD(I)%PPTSW =0.0 DATISD(I)%ETSW =0.0 DATISD(I)%UPSG =0 DATISD(I)%DWNS =0 DATISD(I)%ICLC =1 DATISD(I)%IPRI =1 ENDDO IF(.NOT.UTL_READINITFILE('ISGFILE_OUT',LINE,IU,0))RETURN READ(LINE,*) ISGFILE; WRITE(*,'(A)') 'ISGFILE_OUT='//TRIM(ISGFILE) WRITE(*,'(/A)') 'ISGFILE_OUT='//TRIM(ISGFILE) !## saving isg CALL ISGSAVE(ISGFILE,2) END SUBROUTINE IMODBATCH_ISGTOSFR_MAIN !###====================================================================== SUBROUTINE IMODBATCH_IMODPATH_MAIN() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: RUNFILE,IFFFLOW,IPFFLOW,IDFFLOW,IPFFNAME INTEGER :: IPOSTP,IRUN,ICONVERTGEN INTEGER,DIMENSION(4) :: IPFICOL !## default irun=1 ICONVERTGEN=0; IRUN=1; RUNFILE=''; IF(UTL_READINITFILE('IRUN',LINE,IU,1))READ(LINE,*) IRUN IF(IRUN.EQ.1)THEN WRITE(*,'(A,I10)') 'IRUN=',IRUN IF(.NOT.UTL_READINITFILE('RUNFILE',LINE,IU,0))RETURN READ(LINE,*) RUNFILE; WRITE(*,'(A)') 'RUNFILE='//TRIM(RUNFILE) ENDIF IF(UTL_READINITFILE('ICONVERTGEN',LINE,IU,1))READ(LINE,*) ICONVERTGEN WRITE(*,'(A,I10)') 'ICONVERTGEN=',ICONVERTGEN !## default ipostp=0 IPOSTP=0; IF(UTL_READINITFILE('IPOSTP',LINE,IU,1))READ(LINE,*) IPOSTP WRITE(*,'(A,I10)') 'IPOSTP=',IPOSTP IF(IPOSTP.EQ.1)THEN IFFFLOW=''; IPFFLOW='' IF(UTL_READINITFILE('IFFFLOW',LINE,IU,1))THEN READ(LINE,*) IFFFLOW; WRITE(*,'(A)') 'IFFFLOW='//TRIM(IFFFLOW) ENDIF IF(UTL_READINITFILE('IPFFLOW',LINE,IU,1))THEN READ(LINE,*) IPFFLOW; WRITE(*,'(A)') 'IPFFLOW='//TRIM(IPFFLOW) ENDIF IF(.NOT.UTL_READINITFILE('IDFFLOW',LINE,IU,0))RETURN READ(LINE,*) IDFFLOW; WRITE(*,'(A)') 'IDFFLOW='//TRIM(IDFFLOW) IF(.NOT.UTL_READINITFILE('IPFFNAME',LINE,IU,0))RETURN READ(LINE,*) IPFFNAME; WRITE(*,'(A)') 'IPFFNAME='//TRIM(IPFFNAME) IF(.NOT.UTL_READINITFILE('IXCOL',LINE,IU,0))RETURN READ(LINE,*) IPFICOL(1); WRITE(*,'(A,I10)') 'IXCOL=',IPFICOL(1) IF(.NOT.UTL_READINITFILE('IYCOL',LINE,IU,0))RETURN READ(LINE,*) IPFICOL(2); WRITE(*,'(A,I10)') 'IYCOL=',IPFICOL(2) IF(.NOT.UTL_READINITFILE('ILABELCOL',LINE,IU,0))RETURN READ(LINE,*) IPFICOL(3); WRITE(*,'(A,I10)') 'ILABELCOL=',IPFICOL(3) IF(.NOT.UTL_READINITFILE('ILAYCOL',LINE,IU,0))RETURN READ(LINE,*) IPFICOL(4); WRITE(*,'(A,I10)') 'ILAYCOL=',IPFICOL(4) ENDIF IF(IRUN.EQ.1)THEN IF(TRACEMAIN(RUNFILE,1,ICONVERTGEN))THEN; ENDIF ENDIF IF(IPOSTP.EQ.1)CALL TRACEPOSTPROCESSING(IFFFLOW,IPFFLOW,IDFFLOW,IPFFNAME,IPFICOL,ICONVERTGEN) !## close all memory CALL TRACEDEALLOCATE(1) END SUBROUTINE IMODBATCH_IMODPATH_MAIN !###====================================================================== SUBROUTINE IMODBATCH_IDFCONSISTENCY() !###====================================================================== IMPLICIT NONE TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: IDF INTEGER,ALLOCATABLE,DIMENSION(:) :: CNTL TYPE(IDFOBJ) :: MOTHER CHARACTER(LEN=256) :: OUTPUTFOLDER INTEGER :: NLAY,I,J,K,ICOL,IROW,ICLEAN,IOS REAL :: X ICLEAN=0 !## number of layer to be corrected IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) NLAY; WRITE(*,'(A,I10)') 'NLAY=',NLAY !## result folder IF(.NOT.UTL_READINITFILE('OUTPUTFOLDER',LINE,IU,0))RETURN READ(LINE,*) OUTPUTFOLDER; WRITE(*,'(A)') 'OUTPUTFOLDER='//TRIM(OUTPUTFOLDER) !## iclean is type of "cleaning" IF(UTL_READINITFILE('ICLEAN',LINE,IU,1))READ(LINE,*) ICLEAN WRITE(*,'(A,I10)') 'ICLEAN=',ICLEAN WRITE(*,'(1X,A)') 'Applies consistency only for active cells' SELECT CASE (ICLEAN) CASE (0) CASE (1) WRITE(*,'(1X,A)') 'Removes all data in all files whenever at least a single nodata value is found among them.' CASE (2) WRITE(*,'(1X,A)') 'Removes all data whenever at least a nodata value is found for the first and second idf file.' CASE DEFAULT WRITE(*,'(A)') 'ICLEAN need to be 0,1,2' END SELECT ALLOCATE(IDF(NLAY*2)); DO I=1,SIZE(IDF); CALL IDFNULLIFY(IDF(I)); ENDDO CALL IDFNULLIFY(MOTHER) J=0; DO I=1,NLAY J=J+1 IF(.NOT.UTL_READINITFILE('TOP_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) IDF(J)%FNAME LINE='TOP_L'//TRIM(ITOS(I))//'='//TRIM(IDF(J)%FNAME); WRITE(*,'(A)') TRIM(LINE) J=J+1 IF(.NOT.UTL_READINITFILE('BOT_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) IDF(J)%FNAME; LINE='BOT_L'//TRIM(ITOS(I))//'='//TRIM(IDF(J)%FNAME); WRITE(*,'(A)') TRIM(LINE) ENDDO MOTHER%XMIN=0.0; MOTHER%XMAX=0.0; MOTHER%YMIN=0.0; MOTHER%YMAX=0.0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) MOTHER%XMIN,MOTHER%YMIN,MOTHER%XMAX,MOTHER%YMAX WRITE(*,'(A,4F10.2)') 'WINDOW=',MOTHER%XMIN,MOTHER%YMIN,MOTHER%XMAX,MOTHER%YMAX IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,0))RETURN READ(LINE,*) MOTHER%DX; WRITE(*,'(A,4F10.2)') 'CELLSIZE=',MOTHER%DX CALL UTL_IDFSNAPTOGRID(MOTHER%XMIN,MOTHER%XMAX,MOTHER%YMIN,MOTHER%YMAX,MOTHER%DX,MOTHER%NCOL,MOTHER%NROW) MOTHER%DY=MOTHER%DX ELSE !## construct mother to be the minimal overlapping gridsize IDF%NROW=0; IDF%NCOL=0 DO I=1,SIZE(IDF) READ(IDF(I)%FNAME,*,IOSTAT=IOS) X IF(IOS.NE.0)THEN; IF(.NOT.IDFREAD(IDF(I),IDF(I)%FNAME,0))RETURN; ENDIF ENDDO !## get maximal extent IF(.NOT.IDF_EXTENT(SIZE(IDF),IDF,MOTHER,1))RETURN ENDIF DO J=1,SIZE(IDF) CALL IDFCOPY(MOTHER,IDF(J)) WRITE(*,'(A)') ' Reading '//TRIM(IDF(J)%FNAME) READ(IDF(J)%FNAME,*,IOSTAT=IOS) X IF(IOS.EQ.0)THEN IF(.NOT.IDFALLOCATEX(IDF(J)))RETURN; IDF(J)%X=X; IDF(J)%NODATA=X ELSE IF(.NOT.IDFREADSCALE(IDF(J)%FNAME,IDF(J),2,1,0.0,0))RETURN ENDIF ENDDO ALLOCATE(CNTL(SIZE(IDF))) !## convert top nodata whenever a single layer is nodata DO IROW=1,MOTHER%NROW; DO ICOL=1,MOTHER%NCOL CNTL=0 DO I=1,SIZE(IDF) IF(IDF(I)%X(ICOL,IROW).EQ.IDF(I)%NODATA)CNTL(I)=1 ENDDO J=0 IF(ICLEAN.EQ.1)THEN IF(SUM(CNTL).NE.0)J=1 ELSEIF(ICLEAN.EQ.2)THEN IF(CNTL(1).EQ.1.OR.CNTL(SIZE(IDF)).EQ.1)J=1 ENDIF IF(J.EQ.1)THEN DO I=1,SIZE(IDF); IDF(I)%X(ICOL,IROW)=IDF(I)%NODATA; ENDDO ENDIF ENDDO; ENDDO DEALLOCATE(CNTL) IF(ICLEAN.NE.0)THEN !## correct base to be at least below top elevation DO IROW=1,MOTHER%NROW; DO ICOL=1,MOTHER%NCOL IF(IDF(1)%X(ICOL,IROW) .EQ.IDF(1)%NODATA)CYCLE IF(IDF(SIZE(IDF))%X(ICOL,IROW).EQ.IDF(1)%NODATA)CYCLE IDF(SIZE(IDF))%X(ICOL,IROW)=MIN(IDF(1)%X(ICOL,IROW),IDF(SIZE(IDF))%X(ICOL,IROW)) ENDDO; ENDDO ENDIF IF(ICLEAN.EQ.2)THEN !## correct top->bottom and apply vertical shift DO IROW=1,MOTHER%NROW; DO ICOL=1,MOTHER%NCOL DO J=1,SIZE(IDF) !## value available - if not search for next one in row IF(IDF(J)%X(ICOL,IROW).NE.IDF(J)%NODATA)CYCLE DO K=J+1,SIZE(IDF) IF(IDF(K)%X(ICOL,IROW).NE.IDF(K)%NODATA)THEN IDF(J)%X(ICOL,IROW)=IDF(K)%X(ICOL,IROW); EXIT ENDIF ENDDO ENDDO ENDDO; ENDDO ENDIF !## correct idf->top DO IROW=1,MOTHER%NROW; DO ICOL=1,MOTHER%NCOL DO I=2,SIZE(IDF) !## adjust whenever it crosses higher idf-files IF(IDF(I)%X(ICOL,IROW).EQ.IDF(I)%NODATA)CYCLE DO J=I-1,1,-1 IF(IDF(J)%X(ICOL,IROW).NE.IDF(J)%NODATA)THEN IDF(I)%X(ICOL,IROW)=MIN(IDF(I)%X(ICOL,IROW),IDF(J)%X(ICOL,IROW)) EXIT ENDIF ENDDO ENDDO ENDDO; ENDDO I=1; DO J=1,SIZE(IDF) READ(IDF(J)%FNAME,*,IOSTAT=IOS) X IF(IOS.EQ.0)THEN IF(MOD(J,2).EQ.0)THEN IDF(J)%FNAME=TRIM(OUTPUTFOLDER)//'\BOT_L'//TRIM(ITOS(I))//'.IDF' ELSE IDF(J)%FNAME=TRIM(OUTPUTFOLDER)//'\TOP_L'//TRIM(ITOS(I))//'.IDF' ENDIF ELSE IDF(J)%FNAME=TRIM(OUTPUTFOLDER)//'\'//TRIM(IDF(J)%FNAME(INDEX(IDF(J)%FNAME,'\',.TRUE.)+1:)) ENDIF IF(.NOT.IDFWRITE(IDF(J),IDF(J)%FNAME,1))RETURN IF(MOD(J,2).EQ.0)I=I+1 ENDDO END SUBROUTINE IMODBATCH_IDFCONSISTENCY !!###====================================================================== !SUBROUTINE IMODBATCH_IDFMINTHICKNESS() !!###====================================================================== !IMPLICIT NONE !TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: IDF !INTEGER,ALLOCATABLE,DIMENSION(:) :: CNTL !TYPE(IDFOBJ) :: MOTHER !CHARACTER(LEN=256) :: OUTPUTFOLDER !INTEGER :: NLAY,I,J,K,ICOL,IROW,ICLEAN,IOS !REAL :: X !LOGICAL :: LTB ! !LTB=.TRUE. ! !!## number of layers in the model to be corrected !IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN !READ(LINE,*) NLAY; WRITE(*,'(A,I10)') 'NLAY=',NLAY !!## result folder !IF(.NOT.UTL_READINITFILE('OUTPUTFOLDER',LINE,IU,0))RETURN !READ(LINE,*) OUTPUTFOLDER; WRITE(*,'(A)') 'OUTPUTFOLDER='//TRIM(OUTPUTFOLDER) ! !ALLOCATE(IDF(NLAY*2)); DO I=1,SIZE(IDF); CALL IDFNULLIFY(IDF(I)); ENDDO !CALL IDFNULLIFY(MOTHER) ! !J=0; DO I=1,NLAY ! J=J+1 ! IF(.NOT.UTL_READINITFILE('TOP_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN ! READ(LINE,*) TOP(J)%FNAME ! LINE='TOP_L'//TRIM(ITOS(I))//'='//TRIM(TOP(J)%FNAME); WRITE(*,'(A)') TRIM(LINE) ! J=J+1 ! IF(.NOT.UTL_READINITFILE('BOT_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN ! READ(LINE,*) BOT(J)%FNAME; LINE='BOT_L'//TRIM(ITOS(I))//'='//TRIM(BOT(J)%FNAME); WRITE(*,'(A)') TRIM(LINE) !ENDDO ! !!MOTHER%XMIN=0.0; MOTHER%XMAX=0.0; MOTHER%YMIN=0.0; MOTHER%YMAX=0.0 !!IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN !! READ(LINE,*) MOTHER%XMIN,MOTHER%YMIN,MOTHER%XMAX,MOTHER%YMAX !! WRITE(*,'(A,4F10.2)') 'WINDOW=',MOTHER%XMIN,MOTHER%YMIN,MOTHER%XMAX,MOTHER%YMAX !! IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,0))RETURN !! READ(LINE,*) MOTHER%DX; WRITE(*,'(A,4F10.2)') 'CELLSIZE=',MOTHER%DX !! CALL UTL_IDFSNAPTOGRID(MOTHER%XMIN,MOTHER%XMAX,MOTHER%YMIN,MOTHER%YMAX,MOTHER%DX,MOTHER%NCOL,MOTHER%NROW) !! MOTHER%DY=MOTHER%DX !!ELSE !! !## construct mother to be the minimal overlapping gridsize !! IDF%NROW=0; IDF%NCOL=0 !! DO I=1,SIZE(IDF) !! READ(IDF(I)%FNAME,*,IOSTAT=IOS) X !! IF(IOS.NE.0)THEN; IF(.NOT.IDFREAD(IDF(I),IDF(I)%FNAME,0))RETURN; ENDIF !! ENDDO !! !## get maximal extent !! IF(.NOT.IDF_EXTENT(SIZE(IDF),IDF,MOTHER,1))RETURN !!ENDIF ! !!DO J=1,SIZE(IDF) !! CALL IDFCOPY(MOTHER,IDF(J)) !! WRITE(*,'(A)') ' Reading '//TRIM(IDF(J)%FNAME) !! READ(IDF(J)%FNAME,*,IOSTAT=IOS) X !! IF(IOS.EQ.0)THEN !! IF(.NOT.IDFALLOCATEX(IDF(J)))RETURN; IDF(J)%X=X; IDF(J)%NODATA=X !! ELSE !! IF(.NOT.IDFREADSCALE(IDF(J)%FNAME,IDF(J),2,1,0.0,0))RETURN !! ENDIF !!ENDDO !! !!ALLOCATE(CNTL(SIZE(IDF))) !!!## convert top nodata whenever a single layer is nodata !!DO IROW=1,MOTHER%NROW; DO ICOL=1,MOTHER%NCOL !! !! CNTL=0 !! DO I=1,SIZE(IDF) !! IF(IDF(I)%X(ICOL,IROW).EQ.IDF(I)%NODATA)CNTL(I)=1 !! ENDDO !! !! J=0 !! IF(ICLEAN.EQ.1)THEN !! IF(SUM(CNTL).NE.0)J=1 !! ELSEIF(ICLEAN.EQ.2)THEN !! IF(CNTL(1).EQ.1.OR.CNTL(SIZE(IDF)).EQ.1)J=1 !! ENDIF !! !! IF(J.EQ.1)THEN !! DO I=1,SIZE(IDF); IDF(I)%X(ICOL,IROW)=IDF(I)%NODATA; ENDDO !! ENDIF !! !!ENDDO; ENDDO !!DEALLOCATE(CNTL) !! !!IF(ICLEAN.NE.0)THEN !! !## correct base to be at least below top elevation !! DO IROW=1,MOTHER%NROW; DO ICOL=1,MOTHER%NCOL !! IF(IDF(1)%X(ICOL,IROW) .EQ.IDF(1)%NODATA)CYCLE !! IF(IDF(SIZE(IDF))%X(ICOL,IROW).EQ.IDF(1)%NODATA)CYCLE !! IDF(SIZE(IDF))%X(ICOL,IROW)=MIN(IDF(1)%X(ICOL,IROW),IDF(SIZE(IDF))%X(ICOL,IROW)) !! ENDDO; ENDDO !!ENDIF !! !!IF(ICLEAN.EQ.2)THEN !! !## correct top->bottom and apply vertical shift !! DO IROW=1,MOTHER%NROW; DO ICOL=1,MOTHER%NCOL !! DO J=1,SIZE(IDF) !! !## value available - if not search for next one in row !! IF(IDF(J)%X(ICOL,IROW).NE.IDF(J)%NODATA)CYCLE !! DO K=J+1,SIZE(IDF) !! IF(IDF(K)%X(ICOL,IROW).NE.IDF(K)%NODATA)THEN !! IDF(J)%X(ICOL,IROW)=IDF(K)%X(ICOL,IROW); EXIT !! ENDIF !! ENDDO !! ENDDO !! ENDDO; ENDDO !!ENDIF !! !!!## correct idf->top !!DO IROW=1,MOTHER%NROW; DO ICOL=1,MOTHER%NCOL !! DO I=2,SIZE(IDF) !! !## adjust whenever it crosses higher idf-files !! IF(IDF(I)%X(ICOL,IROW).EQ.IDF(I)%NODATA)CYCLE !! DO J=I-1,1,-1 !! IF(IDF(J)%X(ICOL,IROW).NE.IDF(J)%NODATA)THEN !! IDF(I)%X(ICOL,IROW)=MIN(IDF(I)%X(ICOL,IROW),IDF(J)%X(ICOL,IROW)) !! EXIT !! ENDIF !! ENDDO !! ENDDO !!ENDDO; ENDDO ! !CALL PMANAGER_SAVEMF2005_CONSISTENCY(LTB) ! !I=1; DO J=1,SIZE(TOP) ! READ(IDF(J)%FNAME,*,IOSTAT=IOS) X ! IF(IOS.EQ.0)THEN ! IF(MOD(J,2).EQ.0)THEN ! IDF(J)%FNAME=TRIM(OUTPUTFOLDER)//'\BOT_L'//TRIM(ITOS(I))//'.IDF' ! ELSE ! IDF(J)%FNAME=TRIM(OUTPUTFOLDER)//'\TOP_L'//TRIM(ITOS(I))//'.IDF' ! ENDIF ! ELSE ! IDF(J)%FNAME=TRIM(OUTPUTFOLDER)//'\'//TRIM(IDF(J)%FNAME(INDEX(IDF(J)%FNAME,'\',.TRUE.)+1:)) ! ENDIF ! IF(.NOT.IDFWRITE(IDF(J),IDF(J)%FNAME,1))RETURN ! IF(MOD(J,2).EQ.0)I=I+1 !ENDDO ! !END SUBROUTINE IMODBATCH_IDFMINTHICKNESS !###====================================================================== SUBROUTINE IMODBATCH_CUS() !###====================================================================== USE MOD_CUS_PAR, ONLY : REGISTOP,REGISBOT,OUTPUTFOLDER,MDLIDF,TOPIDF, & BOTIDF,ZIDF,ZCRIT,ZINFO,FDISTANCES,NFORM, & TOPSYSTEM,BOTSYSTEM,PERCENTAGE,CRIT_THICKNESS, & ICPOINTERS,NLAY,CLIPIDF,NCLIP,ICLIP,IEXPZONE, & MIN_THICKNESS IMPLICIT NONE INTEGER :: I,IOS FDISTANCES=''; ICPOINTERS=1; NCLIP=0; IEXPZONE=0; MIN_THICKNESS=0.0 ALLOCATE(MDLIDF(5)); DO I=1,SIZE(MDLIDF); CALL IDFNULLIFY(MDLIDF(I)); ENDDO MDLIDF(1)%XMIN=0.0; MDLIDF(1)%YMIN=0.0; MDLIDF(1)%XMAX=0.0; MDLIDF(1)%YMAX=0.0 IF(UTL_READINITFILE('ICPOINTERS',LINE,IU,1))READ(LINE,*) ICPOINTERS WRITE(*,'(A,I1)') 'ICPOINTERS=',ICPOINTERS !## read predefined number of modellayers IF(ICPOINTERS.EQ.0)THEN IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) NLAY; WRITE(*,'(A,I10)') 'NLAY=',NLAY ELSE IF(UTL_READINITFILE('FDISTANCES',LINE,IU,1))THEN READ(LINE,*) FDISTANCES; WRITE(*,'(A)') 'FDISTANCES='//TRIM(FDISTANCES) ELSE IF(.NOT.UTL_READINITFILE('CRIT_THICKNESS',LINE,IU,0))RETURN READ(LINE,*) CRIT_THICKNESS; WRITE(*,'(A,F10.2)') 'CRIT_THICKNESS=',CRIT_THICKNESS IF(UTL_READINITFILE('MIN_THICKNESS',LINE,IU,1))READ(LINE,*) MIN_THICKNESS WRITE(*,'(A,F10.2)') 'MIN_THICKNESS=',MIN_THICKNESS ENDIF IF(.NOT.UTL_READINITFILE('ZCRIT',LINE,IU,0))RETURN READ(LINE,*) ZCRIT; WRITE(*,'(A,F10.2)') 'ZCRIT=',ZCRIT IF(.NOT.UTL_READINITFILE('PERCENTAGE',LINE,IU,0))RETURN READ(LINE,*) PERCENTAGE; LINE='PERCENTAGE'//'='//TRIM(RTOS(PERCENTAGE,'F',2)); WRITE(*,'(A)') TRIM(LINE) IF(UTL_READINITFILE('ICLIP',LINE,IU,1))THEN CALL IDFNULLIFY(CLIPIDF); NCLIP=1 READ(LINE,*) CLIPIDF%FNAME LINE='ICLIP='//TRIM(CLIPIDF%FNAME); WRITE(*,'(A)') TRIM(LINE) ENDIF IF(UTL_READINITFILE('IEXPZONE',LINE,IU,1))THEN READ(LINE,*) IEXPZONE LINE='IEXPZONE='//TRIM(ITOS(IEXPZONE)); WRITE(*,'(A)') TRIM(LINE) ENDIF ENDIF IF(TRIM(FDISTANCES).EQ.'')THEN IF(UTL_READINITFILE('NFORM',LINE,IU,1))THEN READ(LINE,*) NFORM; WRITE(*,'(A,I10)') 'NFORM=',NFORM ALLOCATE(TOPIDF(NFORM),BOTIDF(NFORM),ZIDF(NFORM),ZINFO(NFORM),ICLIP(NFORM,2)) DO I=1,NFORM CALL IDFNULLIFY(TOPIDF(I)); CALL IDFNULLIFY(BOTIDF(I)); CALL IDFNULLIFY(ZIDF(I)) NULLIFY(ZINFO(I)%NP); ZINFO(I)%NZ=0 IF(ICPOINTERS.EQ.0)THEN IF(.NOT.UTL_READINITFILE('PNT_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) ZIDF(I)%FNAME LINE='PNT_L'//TRIM(ITOS(I))//'='//TRIM(ZIDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) ENDIF IF(.NOT.UTL_READINITFILE('FORMTOP_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*,IOSTAT=IOS) TOPIDF(I)%FNAME,ICLIP(I,1) IF(IOS.NE.0)THEN; READ(LINE,*) TOPIDF(I)%FNAME; ICLIP(I,1)=0; ENDIF LINE='FORMTOP_L'//TRIM(ITOS(I))//'='//TRIM(TOPIDF(I)%FNAME)//'(CLIP='//TRIM(ITOS(ICLIP(I,1)))//')'; WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('FORMBOT_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*,IOSTAT=IOS) BOTIDF(I)%FNAME,ICLIP(I,2) IF(IOS.NE.0)THEN; READ(LINE,*) BOTIDF(I)%FNAME; ICLIP(I,2)=0; ENDIF LINE='FORMBOT_L'//TRIM(ITOS(I))//'='//TRIM(BOTIDF(I)%FNAME)//'(CLIP='//TRIM(ITOS(ICLIP(I,2)))//')'; WRITE(*,'(A)') TRIM(LINE) ENDDO ELSE IF(.NOT.UTL_READINITFILE('FORMTOP',LINE,IU,0))RETURN READ(LINE,*) REGISTOP; WRITE(*,'(A)') 'FORMTOP='//TRIM(REGISTOP) IF(.NOT.UTL_READINITFILE('FORMBOT',LINE,IU,0))RETURN READ(LINE,*) REGISBOT; WRITE(*,'(A)') 'FORMBOT='//TRIM(REGISBOT) ENDIF ENDIF IF(.NOT.UTL_READINITFILE('OUTPUTFOLDER',LINE,IU,0))RETURN READ(LINE,*) OUTPUTFOLDER; WRITE(*,'(A)') 'OUTPUTFOLDER='//TRIM(OUTPUTFOLDER) IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) MDLIDF(1)%XMIN,MDLIDF(1)%YMIN,MDLIDF(1)%XMAX,MDLIDF(1)%YMAX WRITE(*,'(A,4F10.2)') 'WINDOW=',MDLIDF(1)%XMIN,MDLIDF(1)%YMIN,MDLIDF(1)%XMAX,MDLIDF(1)%YMAX IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,0))RETURN READ(LINE,*) MDLIDF(1)%DX; WRITE(*,'(A,F10.2)') 'CELLSIZE=',MDLIDF(1)%DX MDLIDF(1)%DY=MDLIDF(1)%DX CALL UTL_IDFSNAPTOGRID(MDLIDF(1)%XMIN,MDLIDF(1)%XMAX,MDLIDF(1)%YMIN,MDLIDF(1)%YMAX,MDLIDF(1)%DX,MDLIDF(1)%NCOL,MDLIDF(1)%NROW) ENDIF IF(.NOT.UTL_READINITFILE('TOPSYSTEM',LINE,IU,0))RETURN READ(LINE,*) TOPSYSTEM; WRITE(*,'(A)') 'TOPSYSTEM='//TRIM(TOPSYSTEM) IF(.NOT.UTL_READINITFILE('BOTSYSTEM',LINE,IU,0))RETURN READ(LINE,*) BOTSYSTEM; WRITE(*,'(A)') 'BOTSYSTEM='//TRIM(BOTSYSTEM) IF(CUS_MAIN())THEN; ENDIF CALL CUS_DEALLOCATE() END SUBROUTINE IMODBATCH_CUS !###====================================================================== SUBROUTINE IMODBATCH_GEOTOP() !###====================================================================== USE MOD_SOLID_PAR, ONLY : NLAYG,NLAYM,KHG,KVG,MDLIDF,KHM,KAM,KVM,SHM,IBM,TPM, & BTM,RESULTFOLDER IMPLICIT NONE INTEGER :: I !## results folder IF(.NOT.UTL_READINITFILE('RESULTFOLDER',LINE,IU,0))RETURN READ(LINE,*) RESULTFOLDER; WRITE(*,'(A)') 'RESULTFOLDER='//TRIM(RESULTFOLDER) !## number of modellayers IF(.NOT.UTL_READINITFILE('NLAYG',LINE,IU,0))RETURN READ(LINE,*) NLAYG; WRITE(*,'(A,I10)') 'NLAYG=',NLAYG IF(.NOT.UTL_READINITFILE('NLAYM',LINE,IU,0))RETURN READ(LINE,*) NLAYM; WRITE(*,'(A,I10)') 'NLAYM=',NLAYM !## read geotop-files (voxels) ALLOCATE(KHG(NLAYG),KVG(NLAYG)) DO I=1,NLAYG CALL IDFNULLIFY(KHG(I)); CALL IDFNULLIFY(KVG(I)) IF(.NOT.UTL_READINITFILE('KHG_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN; READ(LINE,*) KHG(I)%FNAME LINE='KHG_L'//TRIM(ITOS(I))//'='//TRIM(KHG(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('KVG_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN; READ(LINE,*) KVG(I)%FNAME LINE='KVG_L'//TRIM(ITOS(I))//'='//TRIM(KVG(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) ENDDO !## read model-files ALLOCATE(KHM(NLAYM),TPM(NLAYM),BTM(NLAYM),SHM(NLAYM),IBM(NLAYM),KVM(NLAYM),KAM(NLAYM)) DO I=1,NLAYM CALL IDFNULLIFY(KHM(I)); CALL IDFNULLIFY(TPM(I)); CALL IDFNULLIFY(BTM(I)) CALL IDFNULLIFY(SHM(I)); CALL IDFNULLIFY(IBM(I)); CALL IDFNULLIFY(KVM(I)) CALL IDFNULLIFY(KAM(I)) IF(.NOT.UTL_READINITFILE('IBM_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN; READ(LINE,*) IBM(I)%FNAME LINE='IBM_L'//TRIM(ITOS(I))//'='//TRIM(IBM(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('SHM_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN; READ(LINE,*) SHM(I)%FNAME LINE='SHM_L'//TRIM(ITOS(I))//'='//TRIM(SHM(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('TPM_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN; READ(LINE,*) TPM(I)%FNAME LINE='TPM_L'//TRIM(ITOS(I))//'='//TRIM(TPM(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('BTM_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN; READ(LINE,*) BTM(I)%FNAME LINE='BTM_L'//TRIM(ITOS(I))//'='//TRIM(BTM(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('KHM_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN; READ(LINE,*) KHM(I)%FNAME LINE='KHM_L'//TRIM(ITOS(I))//'='//TRIM(KHM(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('KAM_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN; READ(LINE,*) KAM(I)%FNAME LINE='KAM_L'//TRIM(ITOS(I))//'='//TRIM(KAM(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(I.LT.NLAYM)THEN IF(.NOT.UTL_READINITFILE('KVM_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN; READ(LINE,*) KVM(I)%FNAME LINE='KVM_L'//TRIM(ITOS(I))//'='//TRIM(KVM(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) ENDIF ENDDO MDLIDF%XMIN=0.0; MDLIDF%YMIN=0.0; MDLIDF%XMAX=0.0; MDLIDF%YMAX=0.0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) MDLIDF%XMIN,MDLIDF%YMIN,MDLIDF%XMAX,MDLIDF%YMAX WRITE(*,'(A,4F10.2)') 'WINDOW=',MDLIDF%XMIN,MDLIDF%YMIN,MDLIDF%XMAX,MDLIDF%YMAX IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,0))RETURN READ(LINE,*) MDLIDF%DX; WRITE(*,'(A,F10.2)') 'CELLSIZE=',MDLIDF%DX MDLIDF%DY=MDLIDF%DX ENDIF IF(.NOT.SOLID_GEOTOP())RETURN CALL SOLID_GEOTOP_DEALLOCATE() END SUBROUTINE IMODBATCH_GEOTOP !###====================================================================== SUBROUTINE IMODBATCH_IPFSPOTIFY() !###====================================================================== IMPLICIT NONE INTEGER :: NLAY,I TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: TOPIDF,BOTIDF CHARACTER(LEN=256),DIMENSION(2) :: IPFFNAME,REGIS CHARACTER(LEN=256) :: OUTPUTFOLDER INTEGER,DIMENSION(6) :: IXCOL IPFFNAME=''; OUTPUTFOLDER=''; IXCOL=0 IF(UTL_READINITFILE('IPFFILE_IN',LINE,IU,1))THEN READ(LINE,*) IPFFNAME(1); WRITE(*,'(A)') 'IPFFILE_IN='//TRIM(IPFFNAME(1)) IXCOL(1)=1; IF(UTL_READINITFILE('IXCOL',LINE,IU,1))READ(LINE,*) IXCOL(1) WRITE(*,'(A,I2)') 'IXCOL=',IXCOL(1) IXCOL(2)=2; IF(UTL_READINITFILE('IYCOL',LINE,IU,1))READ(LINE,*) IXCOL(2) WRITE(*,'(A,I2)') 'IYCOL=',IXCOL(2) IXCOL(3)=3; IF(UTL_READINITFILE('IFCOL',LINE,IU,1))READ(LINE,*) IXCOL(3) WRITE(*,'(A,I2)') 'IFCOL=',IXCOL(3) IXCOL(4)=1; IF(UTL_READINITFILE('IZ1COL',LINE,IU,1))READ(LINE,*) IXCOL(4) WRITE(*,'(A,I2)') 'IZ1COL=',IXCOL(4) IXCOL(5)=1; IF(UTL_READINITFILE('IZ2COL',LINE,IU,1))READ(LINE,*) IXCOL(5) WRITE(*,'(A,I2)') 'IZ2COL=',IXCOL(5) IXCOL(6)=6; IF(UTL_READINITFILE('ILCOL',LINE,IU,1))READ(LINE,*) IXCOL(6) WRITE(*,'(A,I2)') 'ILCOL=',IXCOL(6) IF(.NOT.UTL_READINITFILE('IPFFILE_OUT',LINE,IU,0))RETURN READ(LINE,*) IPFFNAME(2); WRITE(*,'(A)') 'IPFFILE_OUT='//TRIM(IPFFNAME(2)) ELSE IF(.NOT.UTL_READINITFILE('OUTPUTFOLDER',LINE,IU,0))RETURN READ(LINE,*) OUTPUTFOLDER; WRITE(*,'(A)') 'OUTPUTFOLDER='//TRIM(OUTPUTFOLDER) ENDIF !## number of modellayers IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) NLAY; WRITE(*,'(A,I10)') 'NLAY=',NLAY ALLOCATE(TOPIDF(NLAY),BOTIDF(NLAY)) DO I=1,SIZE(TOPIDF); CALL IDFNULLIFY(TOPIDF(I)); ENDDO DO I=1,SIZE(BOTIDF); CALL IDFNULLIFY(BOTIDF(I)); ENDDO !## try to read all idf's DO I=1,NLAY IF(.NOT.UTL_READINITFILE('TOP_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) TOPIDF(I)%FNAME LINE='TOP_L'//TRIM(ITOS(I))//'='//TRIM(TOPIDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('BOT_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) BOTIDF(I)%FNAME LINE='BOT_L'//TRIM(ITOS(I))//'='//TRIM(BOTIDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) ENDDO IF(.NOT.UTL_READINITFILE('FORMTOP',LINE,IU,0))RETURN READ(LINE,*) REGIS(1); WRITE(*,'(A)') 'FORMTOP='//TRIM(REGIS(1)) IF(.NOT.UTL_READINITFILE('FORMBOT',LINE,IU,0))RETURN READ(LINE,*) REGIS(2); WRITE(*,'(A)') 'FORMBOT='//TRIM(REGIS(2)) CALL IPFSPOTIFY(IPFFNAME,TOPIDF,BOTIDF,IXCOL,REGIS,OUTPUTFOLDER) END SUBROUTINE IMODBATCH_IPFSPOTIFY !###====================================================================== SUBROUTINE IMODBATCH_IPFSUM() !###====================================================================== IMPLICIT NONE INTEGER :: NFILE TYPE(IDFOBJ) :: ZONEIDF CHARACTER(LEN=256),DIMENSION(:),ALLOCATABLE :: IPFFILE INTEGER,DIMENSION(:),ALLOCATABLE :: ILAYFILE CHARACTER(LEN=256) :: OUTPUTFILE,LAYFILE,FNAME CHARACTER(LEN=5) :: EXT CHARACTER(LEN=52) :: CID INTEGER :: I,J,K,KK,KKK,N,M,NN,JU,KU,IEXT,IDATE,JDATE,JD1,JD2,IY,IM,ID,IY1,IY2,IBAL,IROW,ICOL,IPER,DD,NYR REAL :: Q1,Q2,X,Y TYPE BALOBJ CHARACTER(LEN=52) :: LABEL INTEGER :: NPOL,NLAY REAL,POINTER,DIMENSION(:) :: Q=>NULL() INTEGER,DIMENSION(10) :: ILAY,IPOL END TYPE BALOBJ TYPE(BALOBJ),DIMENSION(:),ALLOCATABLE :: BAL IF(.NOT.UTL_READINITFILE('SYEAR',LINE,IU,0))RETURN READ(LINE,*) IY1; WRITE(*,'(A,I10)') 'SYEAR=',IY1 IF(.NOT.UTL_READINITFILE('EYEAR',LINE,IU,0))RETURN READ(LINE,*) IY2; WRITE(*,'(A,I10)') 'EYEAR=',IY2 ! IY1=1980; IY2=2015; NYR=(IY2-IY1)+1 IF(.NOT.UTL_READINITFILE('NFILE',LINE,IU,0))RETURN READ(LINE,*) NFILE; WRITE(*,'(A,I10)') 'NFILE=',NFILE ALLOCATE(IPFFILE(NFILE),ILAYFILE(NFILE)) DO I=1,NFILE IF(.NOT.UTL_READINITFILE('IPFFILE'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) ILAYFILE(I),IPFFILE(I); LINE='IPFFILE'//TRIM(ITOS(I))//'='//TRIM(ITOS(ILAYFILE(I)))//','//TRIM(IPFFILE(I)) WRITE(*,'(A)') TRIM(LINE) ENDDO IF(.NOT.UTL_READINITFILE('LAYFILE',LINE,IU,0))RETURN READ(LINE,*) LAYFILE; WRITE(*,'(A)') 'LAYFILE='//TRIM(LAYFILE) IF(.NOT.UTL_READINITFILE('ZONEIDF',LINE,IU,0))RETURN READ(LINE,*) ZONEIDF%FNAME; WRITE(*,'(A)') 'ZONEIDF='//TRIM(ZONEIDF%FNAME) !## read zones IF(.NOT.IDFREAD(ZONEIDF,ZONEIDF%FNAME,1))STOP !## get number of zones N=13; ALLOCATE(BAL(N)); BAL%NPOL=0; BAL%NLAY=0 DO I=1,SIZE(BAL); ALLOCATE(BAL(I)%Q(NYR)); BAL(I)%Q=0.0; ENDDO WRITE(*,'(/1X,A,I10,A)') 'Found ',N,' zones' JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=LAYFILE,ACTION='READ',FORM='FORMATTED',STATUS='OLD') READ(JU,*) DO I=1,SIZE(BAL) READ(JU,*) BAL(I)%LABEL,BAL(I)%NPOL,(BAL(I)%IPOL(J),J=1,BAL(I)%NPOL),BAL(I)%NLAY,(BAL(I)%ILAY(J),J=1,BAL(I)%NLAY) ENDDO CLOSE(JU) !## process all ipf files DO I=1,NFILE JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=IPFFILE(I),ACTION='READ',FORM='FORMATTED',STATUS='OLD') WRITE(*,'(A)') 'Reading '//TRIM(IPFFILE(I))//' ...' READ(JU,*) N; READ(JU,*) M; DO J=1,M; READ(JU,*); ENDDO; READ(JU,*) IEXT,EXT DO J=1,N READ(JU,*) X,Y,CID CALL IDFIROWICOL(ZONEIDF,IROW,ICOL,X,Y) !## skip outside zones IF(ZONEIDF%X(ICOL,IROW).LT.0.OR.ZONEIDF%X(ICOL,IROW).GT.SIZE(BAL))CYCLE !## what group has this zone number on the given layer IBAL=0 DO K=1,SIZE(BAL) DO KK=1,BAL(K)%NPOL !## current group has current zone IF(BAL(K)%IPOL(KK).EQ.ZONEIDF%X(ICOL,IROW))THEN !## check whether is has the same layer DO KKK=1,BAL(K)%NLAY !## ihit is group number IF(BAL(K)%ILAY(KKK).EQ.ILAYFILE(I))IBAL=K ENDDO ENDIF ENDDO ENDDO IF(IBAL.EQ.0)THEN WRITE(*,*) 'Cannot allocate current location' PAUSE ENDIF FNAME=IPFFILE(I)(:INDEX(IPFFILE(I),'\',.TRUE.))//TRIM(CID)//'.'//TRIM(EXT) KU=UTL_GETUNIT(); CALL OSD_OPEN(KU,FILE=FNAME,ACTION='READ',FORM='FORMATTED',STATUS='OLD') READ(KU,*) NN; READ(KU,*) M; DO K=1,M; READ(KU,*); ENDDO READ(KU,*) IDATE,Q1 JD1=UTL_IDATETOJDATE(IDATE) DO K=1,NN-1 READ(KU,*) JDATE,Q2 JD2=UTL_IDATETOJDATE(JDATE) CALL IDATETOGDATE(IDATE,IY,IM,ID) IF(IY.GE.IY1.AND.IY.LE.IY2)THEN IPER=(IY-IY1)+1 DD= JD2-JD1 BAL(IBAL)%Q(IPER)=BAL(IBAL)%Q(IPER)+Q1*REAL(DD) ENDIF IDATE=JDATE; Q1=Q2; JD1=JD2 ENDDO !## trick for last - assume that continues a month BAL(IBAL)%Q(IPER)=BAL(IBAL)%Q(IPER)+Q1*31.0 CLOSE(KU) ENDDO CLOSE(JU) ENDDO IF(.NOT.UTL_READINITFILE('OUTPUTFILE',LINE,IU,0))RETURN READ(LINE,*) OUTPUTFILE; WRITE(*,'(A)') 'OUTPUTFILE='//TRIM(OUTPUTFILE) JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=OUTPUTFILE,ACTION='WRITE',FORM='FORMATTED',STATUS='UNKNOWN') WRITE(JU,'(14A)') 'Location Names',(','//TRIM(BAL(J)%LABEL),J=1,SIZE(BAL)) WRITE(JU,'(14A)') 'Location Ids',(',Zone '//TRIM(ITOS(J)),J=1,SIZE(BAL)) WRITE(JU,'(14A)') 'Time',(',Q_m3yr.wel',J=1,SIZE(BAL)) IY=IY1-1 DO IPER=1,NYR DO J=1,SIZE(BAL); BAL(J)%Q(IPER)=-1.0*BAL(J)%Q(IPER)/1.0E6; ENDDO IY=IY+1 WRITE(LINE,'(I4.4,A)') IY,'-01-01 00:00:00' WRITE(JU,'(A,13(A1,E10.4))') TRIM(LINE),(',',BAL(J)%Q(IPER),J=1,SIZE(BAL)) ENDDO CLOSE(JU) DO I=1,SIZE(BAL); DEALLOCATE(BAL(I)%Q); ENDDO DEALLOCATE(IPFFILE,ILAYFILE,BAL) END SUBROUTINE IMODBATCH_IPFSUM !###====================================================================== SUBROUTINE IMODBATCH_CREATEIZONE() !###====================================================================== IMPLICIT NONE INTEGER :: I,NFORMATIONS,NLAY,IZONEOFFSET,IGROUPOFFSET CHARACTER(LEN=256),ALLOCATABLE,DIMENSION(:) :: FIDF CHARACTER(LEN=256) :: PFOLDER,OFOLDER,TPARAMETER REAL :: MINF IF(.NOT.UTL_READINITFILE('OFOLDER',LINE,IU,0))RETURN READ(LINE,*) OFOLDER; WRITE(*,'(A)') 'OFOLDER='//TRIM(OFOLDER) IF(.NOT.UTL_READINITFILE('PFOLDER',LINE,IU,0))RETURN READ(LINE,*) PFOLDER; WRITE(*,'(A)') 'PFOLDER='//TRIM(PFOLDER) IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) NLAY; WRITE(*,'(A,I10)') 'NLAY=',NLAY IF(.NOT.UTL_READINITFILE('MINF',LINE,IU,0))RETURN READ(LINE,*) MINF; WRITE(*,'(A,F10.3)') 'MINF=',MINF IZONEOFFSET=0 IF(UTL_READINITFILE('IZONEOFFSET',LINE,IU,1))THEN READ(LINE,*) IZONEOFFSET; WRITE(*,'(A,I10)') 'IZONEOFFSET=',IZONEOFFSET ENDIF IGROUPOFFSET=0 IF(UTL_READINITFILE('IGROUPOFFSET',LINE,IU,1))THEN READ(LINE,*) IGROUPOFFSET; WRITE(*,'(A,I10)') 'IGROUPOFFSET=',IGROUPOFFSET ENDIF IF(.NOT.UTL_READINITFILE('NFORMATIONS',LINE,IU,0))RETURN READ(LINE,*) NFORMATIONS; WRITE(*,'(A,I10)') 'NFORMATIONS=',NFORMATIONS ALLOCATE(FIDF(NFORMATIONS)) DO I=1,NFORMATIONS IF(.NOT.UTL_READINITFILE('FORMATION'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) FIDF(I) LINE='FORMATION'//TRIM(ITOS(I))//'='//TRIM(FIDF(I)); WRITE(*,'(A)') TRIM(LINE) ENDDO IF(.NOT.UTL_READINITFILE('TPARAMETER',LINE,IU,0))RETURN READ(LINE,*) TPARAMETER; WRITE(*,'(A)') 'TPARAMETER='//TRIM(TPARAMETER) CALL CREATEIZONE_MAIN(FIDF,PFOLDER,OFOLDER,TPARAMETER,NLAY,MINF,IZONEOFFSET,IGROUPOFFSET) DEALLOCATE(FIDF) END SUBROUTINE IMODBATCH_CREATEIZONE !###====================================================================== SUBROUTINE IMODBATCH_ASSIGNWELL() !###====================================================================== IMPLICIT NONE INTEGER :: I,NFORMATIONS TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: TOPIDF,BOTIDF CHARACTER(LEN=256),DIMENSION(2) :: IPFFNAME INTEGER,DIMENSION(6) :: IXCOL INTEGER,ALLOCATABLE,DIMENSION(:) :: IFCOL IPFFNAME='' IF(.NOT.UTL_READINITFILE('IPFFILE_IN',LINE,IU,0))RETURN READ(LINE,'(A256)') IPFFNAME(1); WRITE(*,'(A)') 'IPFFILE_IN='//TRIM(IPFFNAME(1)) IXCOL(1)=1; IF(UTL_READINITFILE('IXCOL',LINE,IU,1))READ(LINE,*) IXCOL(1) WRITE(*,'(A,I2)') 'IXCOL=',IXCOL(1) IXCOL(2)=2; IF(UTL_READINITFILE('IYCOL',LINE,IU,1))READ(LINE,*) IXCOL(2) WRITE(*,'(A,I2)') 'IYCOL=',IXCOL(2) IXCOL(3)=3; IF(UTL_READINITFILE('IDCOL',LINE,IU,1))READ(LINE,*) IXCOL(3) WRITE(*,'(A,I2)') 'IDCOL=',IXCOL(3) IXCOL(4)=1; IF(UTL_READINITFILE('IZ1COL',LINE,IU,1))READ(LINE,*) IXCOL(4) WRITE(*,'(A,I2)') 'IZ1COL=',IXCOL(4) IXCOL(5)=1; IF(UTL_READINITFILE('IZ2COL',LINE,IU,1))READ(LINE,*) IXCOL(5) WRITE(*,'(A,I2)') 'IZ2COL=',IXCOL(5) IF(.NOT.UTL_READINITFILE('NFORMATIONS',LINE,IU,0))RETURN READ(LINE,*) NFORMATIONS; WRITE(*,'(A,I10)') 'NFORMATIONS=',NFORMATIONS ALLOCATE(IFCOL(NFORMATIONS)) DO I=1,NFORMATIONS IF(.NOT.UTL_READINITFILE('FORMATION'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) IFCOL(I) LINE='FORMATION'//TRIM(ITOS(I))//'='//TRIM(ITOS(IFCOL(I))); WRITE(*,'(A)') TRIM(LINE) ENDDO IF(.NOT.UTL_READINITFILE('IPFFILE_OUT',LINE,IU,0))RETURN READ(LINE,'(A256)') IPFFNAME(2); WRITE(*,'(A)') 'IPFFILE_OUT='//TRIM(IPFFNAME(2)) ALLOCATE(TOPIDF(NFORMATIONS),BOTIDF(NFORMATIONS)) DO I=1,SIZE(TOPIDF); CALL IDFNULLIFY(TOPIDF(I)); ENDDO DO I=1,SIZE(BOTIDF); CALL IDFNULLIFY(BOTIDF(I)); ENDDO !## try to read all idf's DO I=1,NFORMATIONS IF(.NOT.UTL_READINITFILE('TOP_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) TOPIDF(I)%FNAME LINE='TOP_L'//TRIM(ITOS(I))//'='//TRIM(TOPIDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('BOT_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) BOTIDF(I)%FNAME LINE='BOT_L'//TRIM(ITOS(I))//'='//TRIM(BOTIDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) ENDDO CALL IPFASSIGNWELL(IPFFNAME,TOPIDF,BOTIDF,IXCOL,IFCOL) END SUBROUTINE IMODBATCH_ASSIGNWELL !###====================================================================== SUBROUTINE IMODBATCH_WVP() !###====================================================================== USE MOD_SOLID_PAR, ONLY : TOPIDF,BOTIDF,CIDF,MINC,OUTPUTFOLDER,MDLIDF IMPLICIT NONE INTEGER :: NLAY,I !## number of modellayers IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) NLAY; WRITE(*,'(A,I10)') 'NLAY=',NLAY IF(.NOT.UTL_READINITFILE('MINC',LINE,IU,0))RETURN READ(LINE,*) MINC; WRITE(*,'(A,F10.2)') 'MINC=',MINC ALLOCATE(TOPIDF(NLAY),BOTIDF(NLAY),CIDF(NLAY-1)) DO I=1,SIZE(TOPIDF); CALL IDFNULLIFY(TOPIDF(I)); ENDDO DO I=1,SIZE(BOTIDF); CALL IDFNULLIFY(BOTIDF(I)); ENDDO DO I=1,SIZE(CIDF ); CALL IDFNULLIFY(CIDF (I)); ENDDO !## try to read all idf's DO I=1,NLAY IF(.NOT.UTL_READINITFILE('TOP_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) TOPIDF(I)%FNAME LINE='TOP_L'//TRIM(ITOS(I))//'='//TRIM(TOPIDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('BOT_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) BOTIDF(I)%FNAME LINE='BOT_L'//TRIM(ITOS(I))//'='//TRIM(BOTIDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(I.LT.NLAY)THEN IF(.NOT.UTL_READINITFILE('C_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) CIDF(I)%FNAME LINE='C_L'//TRIM(ITOS(I))//'='//TRIM(CIDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) ENDIF ENDDO IF(.NOT.UTL_READINITFILE('OUTPUTFOLDER',LINE,IU,0))RETURN READ(LINE,*) OUTPUTFOLDER; WRITE(*,'(A)') 'OUTPUTFOLDER='//TRIM(OUTPUTFOLDER) MDLIDF%XMIN=0.0; MDLIDF%YMIN=0.0; MDLIDF%XMAX=0.0; MDLIDF%YMAX=0.0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) MDLIDF%XMIN,MDLIDF%YMIN,MDLIDF%XMAX,MDLIDF%YMAX WRITE(*,'(A,4F10.2)') 'WINDOW=',MDLIDF%XMIN,MDLIDF%YMIN,MDLIDF%XMAX,MDLIDF%YMAX IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,0))RETURN READ(LINE,*) MDLIDF%DX; WRITE(*,'(A,F10.2)') 'CELLSIZE=',MDLIDF%DX MDLIDF%DY=MDLIDF%DX ENDIF IF(SOLID_WVP())THEN; ENDIF END SUBROUTINE IMODBATCH_WVP !###====================================================================== SUBROUTINE IMODBATCH_SOLID() !###====================================================================== USE MOD_SOLID_PAR, ONLY : IBATCH,IWINDOW,SOLFILE,OUTPUTFOLDER,FMIDELEV, & MDLIDF,REGISTOP,REGISBOT,REGISKHV,REGISKVV,SLD,DZ,HCLOSE,MICNVG,IBNDCHK,IINT_IDF,GENSOL, & REGISFILES_TOP,REGISFILES_BOT,REGISFILES_KHV,REGISFILES_KVV,NGENSOL IMPLICIT NONE INTEGER :: IMASK,IHYPO,ICKDC,I,J,FNLAY REAL :: ZOFFSET IWINDOW=0; HCLOSE=0.001; MICNVG=5; FMIDELEV=1.0; IBNDCHK=0; IINT_IDF=1 CALL SOLID_INITSLD(1) !## number of modellayers IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) SLD(1)%NINT; WRITE(*,'(A,I10)') 'NLAY=',SLD(1)%NINT SLD(1)%NINT=2*SLD(1)%NINT CALL SOLID_INITSLDPOINTER(1,SLD(1)%NINT) ALLOCATE(DZ(SLD(1)%NINT)); DZ=0.0 IF(UTL_READINITFILE('DZ',LINE,IU,0))READ(LINE,*) DZ(1:SLD(1)%NINT/2) WRITE(*,'(99F8.2)') DZ(1:SLD(1)%NINT/2) !## copy dz for each interface DO I=SLD(1)%NINT,1,-2 DZ(I) =DZ(I/2) DZ(I-1)=0.0 ENDDO !## try to read all idf's J=0 DO I=1,SLD(1)%NINT/2 IF(.NOT.UTL_READINITFILE('TOP_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN J=J+1 READ(LINE,*) SLD(1)%INTNAME(J) LINE='TOP_L'//TRIM(ITOS(I))//'='//TRIM(SLD(1)%INTNAME(J)); WRITE(*,'(A)') TRIM(LINE) SLD(1)%ICLC(J)=0; IF(UTL_READINITFILE('ICLC_TL'//TRIM(ITOS(I)),LINE,IU,1))READ(LINE,*) SLD(1)%ICLC(J) LINE='ICLC_TL'//TRIM(ITOS(I))//'='//TRIM(ITOS(SLD(1)%ICLC(J))); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('BOT_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN J=J+1 READ(LINE,*) SLD(1)%INTNAME(J) LINE='BOT_L'//TRIM(ITOS(I))//'='//TRIM(SLD(1)%INTNAME(J)); WRITE(*,'(A)') TRIM(LINE) SLD(1)%ICLC(J)=0; IF(UTL_READINITFILE('ICLC_BL'//TRIM(ITOS(I)),LINE,IU,1))READ(LINE,*) SLD(1)%ICLC(J) LINE='ICLC_BL'//TRIM(ITOS(I))//'='//TRIM(ITOS(SLD(1)%ICLC(J))); WRITE(*,'(A)') TRIM(LINE) ENDDO IF(.NOT.UTL_READINITFILE('OUTPUTFOLDER',LINE,IU,0))RETURN READ(LINE,*) OUTPUTFOLDER; WRITE(*,'(A)') 'OUTPUTFOLDER='//TRIM(OUTPUTFOLDER) CALL UTL_CREATEDIR(TRIM(OUTPUTFOLDER)) MDLIDF%XMIN=0.0; MDLIDF%YMIN=0.0; MDLIDF%XMAX=0.0; MDLIDF%YMAX=0.0; IWINDOW=0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) MDLIDF%XMIN,MDLIDF%YMIN,MDLIDF%XMAX,MDLIDF%YMAX WRITE(*,'(A,4F10.2)') 'WINDOW=',MDLIDF%XMIN,MDLIDF%YMIN,MDLIDF%XMAX,MDLIDF%YMAX IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,0))RETURN READ(LINE,*) MDLIDF%DX; WRITE(*,'(A,F10.2)') 'CELLSIZE=',MDLIDF%DX IWINDOW=1; MDLIDF%DY=MDLIDF%DX ENDIF IF(.NOT.UTL_READINITFILE('IMASK',LINE,IU,0))RETURN; READ(LINE,*) IMASK IF(.NOT.UTL_READINITFILE('IHYPO',LINE,IU,0))RETURN; READ(LINE,*) IHYPO IF(.NOT.UTL_READINITFILE('ICKDC',LINE,IU,0))RETURN; READ(LINE,*) ICKDC WRITE(*,'(A,I10)') 'IMASK=' ,IMASK WRITE(*,'(A,I10)') 'IHYPO=' ,IHYPO WRITE(*,'(A,I10)') 'ICKDC=' ,ICKDC IF(IMASK.EQ.1)THEN IF(.NOT.UTL_READINITFILE('ZOFFSET',LINE,IU,0))RETURN READ(LINE,*) ZOFFSET; WRITE(*,'(A,F10.2)') 'ZOFFSET=',ZOFFSET ENDIF IF(ICKDC.EQ.1)THEN IF(UTL_READINITFILE('FNLAY',LINE,IU,1))THEN READ(LINE,*) FNLAY; WRITE(*,'(A,I10)') 'FNLAY=',FNLAY ALLOCATE(REGISFILES_TOP(FNLAY),REGISFILES_BOT(FNLAY),REGISFILES_KHV(FNLAY),REGISFILES_KVV(FNLAY)) REGISFILES_TOP=''; REGISFILES_BOT=''; REGISFILES_KHV=''; REGISFILES_KVV='' DO I=1,FNLAY !## read top formation IF(.NOT.UTL_READINITFILE('FTOP_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) REGISFILES_TOP(I) LINE='FTOP_L'//TRIM(ITOS(I))//'='//TRIM(REGISFILES_TOP(I)); WRITE(*,'(A)') TRIM(LINE) !## read bot formation IF(.NOT.UTL_READINITFILE('FBOT_L'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) REGISFILES_BOT(I) LINE='FBOT_L'//TRIM(ITOS(I))//'='//TRIM(REGISFILES_BOT(I)); WRITE(*,'(A)') TRIM(LINE) !## read optional khv formation IF(UTL_READINITFILE('FKHV_L'//TRIM(ITOS(I)),LINE,IU,1))READ(LINE,*) REGISFILES_KHV(I) LINE='FKHV_L'//TRIM(ITOS(I))//'='//TRIM(REGISFILES_KHV(I)); WRITE(*,'(A)') TRIM(LINE) !## read optional kvv formation IF(UTL_READINITFILE('FKVV_L'//TRIM(ITOS(I)),LINE,IU,1))READ(LINE,*) REGISFILES_KVV(I) LINE='FKVV_L'//TRIM(ITOS(I))//'='//TRIM(REGISFILES_KVV(I)); WRITE(*,'(A)') TRIM(LINE) ENDDO ELSE !## use wildcards IF(.NOT.UTL_READINITFILE('FOLDERTOP',LINE,IU,0))RETURN READ(LINE,*) REGISTOP; WRITE(*,'(A)') 'FOLDERTOP='//TRIM(REGISTOP) IF(.NOT.UTL_READINITFILE('FOLDERBOT',LINE,IU,0))RETURN READ(LINE,*) REGISBOT; WRITE(*,'(A)') 'FOLDERBOT='//TRIM(REGISBOT) IF(.NOT.UTL_READINITFILE('FOLDERKHV',LINE,IU,0))RETURN READ(LINE,*) REGISKHV; WRITE(*,'(A)') 'FOLDERKHV='//TRIM(REGISKHV) IF(.NOT.UTL_READINITFILE('FOLDERKVV',LINE,IU,0))RETURN READ(LINE,*) REGISKVV; WRITE(*,'(A)') 'FOLDERKVV='//TRIM(REGISKVV) ENDIF ENDIF IF(IHYPO.EQ.1)THEN !## try to go through the mid IF(UTL_READINITFILE('IMIDELEV',LINE,IU,1))READ(LINE,*) FMIDELEV WRITE(*,'(A,F10.2)') 'IMIDELEV=',FMIDELEV !## include top/bottom in interpolation IF(UTL_READINITFILE('IINT_IDF',LINE,IU,1))READ(LINE,*) IINT_IDF WRITE(*,'(A,I1)') 'IINT_IDF=',IINT_IDF !## check isolated boundary cells IF(UTL_READINITFILE('IBNDCHK',LINE,IU,1))READ(LINE,*) IBNDCHK WRITE(*,'(A,I1)') 'IBNDCHK=',IBNDCHK !## hclosure criterium IF(UTL_READINITFILE('HCLOSE',LINE,IU,1))READ(LINE,*) HCLOSE WRITE(*,'(A,F15.7)') 'HCLOSE=',HCLOSE !## max. inner convergences IF(UTL_READINITFILE('MICNVG',LINE,IU,1))READ(LINE,*) MICNVG WRITE(*,'(A,I10)') 'MICNVG=',MICNVG NGENSOL=0; IF(UTL_READINITFILE('NGEN',LINE,IU,1))READ(LINE,*) NGENSOL WRITE(*,'(A,I10)') 'NGEN=',NGENSOL IF(NGENSOL.GT.0)THEN ALLOCATE(GENSOL(NGENSOL)) DO I=1,NGENSOL IF(.NOT.UTL_READINITFILE('GEN_'//TRIM(ITOS(I)),LINE,IU,0))RETURN; READ(LINE,*) GENSOL(I)%ILAY,GENSOL(I)%FNAME LINE='GEN_'//TRIM(ITOS(I))//'='//TRIM(ITOS(GENSOL(I)%ILAY))//','//TRIM(GENSOL(I)%FNAME) WRITE(*,'(A)') TRIM(LINE) ENDDO ENDIF ENDIF IBATCH=1 !## compute masks IF(IMASK.EQ.1)THEN IF(.NOT.SOLID_NEWMASKS(ZOFFSET))RETURN ENDIF !## compute solid IF(IHYPO.EQ.1)CALL SOLID_CALC_HYPO() !## compute kd/c IF(ICKDC.EQ.1)THEN IF(.NOT.SOLID_CALC_KDC())THEN; ENDIF CALL SOLID_CALC_KDC_DEALLOCATE() ENDIF IF(ASSOCIATED(REGISFILES_TOP))DEALLOCATE(REGISFILES_TOP) IF(ASSOCIATED(REGISFILES_BOT))DEALLOCATE(REGISFILES_BOT) IF(ASSOCIATED(REGISFILES_KHV))DEALLOCATE(REGISFILES_KHV) IF(ASSOCIATED(REGISFILES_KVV))DEALLOCATE(REGISFILES_KVV) DEALLOCATE(DZ) END SUBROUTINE IMODBATCH_SOLID !###====================================================================== SUBROUTINE IMODBATCH_MODELCOPY_MAIN() !###====================================================================== USE MOD_MDL_PAR, ONLY : RUNFILE,RESDIR,SIMBOX,CLIPDIR,SIMCSIZE IMPLICIT NONE IF(.NOT.UTL_READINITFILE('RUNFILE',LINE,IU,0))RETURN READ(LINE,*) RUNFILE; WRITE(*,'(A)') 'RUNFILE='//TRIM(RUNFILE) IF(.NOT.UTL_READINITFILE('TARGETDIR',LINE,IU,0))RETURN READ(LINE,*) RESDIR; WRITE(*,'(A)') 'TARGETDIR='//TRIM(RESDIR) SIMBOX=0.0; SIMCSIZE=0.0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) SIMBOX(1),SIMBOX(2),SIMBOX(3),SIMBOX(4) WRITE(*,'(A,4F10.2)') 'WINDOW=',SIMBOX(1),SIMBOX(2),SIMBOX(3),SIMBOX(4) IF(.NOT.UTL_READINITFILE('CELL_SIZE',LINE,IU,0))RETURN READ(LINE,*) SIMCSIZE; WRITE(*,'(A,F10.2)') 'CELL_SIZE=',SIMCSIZE IF(SIMCSIZE.LE.0.0)STOP 'SIMCSIZE NEED TO BE LARGER THAN ZERO !' ENDIF CLIPDIR='' IF(UTL_READINITFILE('CLIPDIR',LINE,IU,1))THEN READ(LINE,*) CLIPDIR; WRITE(*,'(A)') 'CLIPDIR='//TRIM(CLIPDIR) ENDIF CALL MODEL1COPYRUNFILE(1) CALL IPFDEALLOCATE() END SUBROUTINE IMODBATCH_MODELCOPY_MAIN !###====================================================================== SUBROUTINE IMODBATCH_IPFSTAT_MAIN() !###====================================================================== USE MOD_TSTAT_PAR, ONLY : GENNAME,IPFNAME1,IPFNAME2,IGEN,CXPERC,OUTNAME, & RELATECOLIPF1,RELATECOLIPF2,XLAG,DLAG,DMY1,DMY2,NVARS,CVARS,IVARS, & IINVERSE,ICOLDATE,ICOLVARS,SURFACELEVEL IMPLICIT NONE INTEGER :: I NVARS=3 ICOLDATE='1' !## date column in txt files ICOLVARS='2' !## vars column in txt files IF(.NOT.UTL_READINITFILE('IPF1',LINE,IU,0))RETURN READ(LINE,*) IPFNAME1 WRITE(*,'(A)') 'IPF1='//TRIM(IPFNAME1) IF(UTL_READINITFILE('ICOLDATE1',LINE,IU,1))READ(LINE,*) ICOLDATE(1) WRITE(*,'(A)') 'ICOLDATE1='//TRIM(ICOLDATE(1)) IF(UTL_READINITFILE('ICOLVARS1',LINE,IU,1))READ(LINE,*) ICOLVARS(1) WRITE(*,'(A)') 'ICOLVARS1='//TRIM(ICOLVARS(1)) IPFNAME2='' IF(UTL_READINITFILE('IPF2',LINE,IU,1))THEN READ(LINE,*) IPFNAME2 WRITE(*,'(A)') 'IPF2='//TRIM(IPFNAME2) IF(.NOT.UTL_READINITFILE('RELATECOLIPF1',LINE,IU,0))RETURN READ(LINE,*) RELATECOLIPF1 WRITE(*,'(A,I3)') 'RELATECOLIPF1=',RELATECOLIPF1 IF(.NOT.UTL_READINITFILE('RELATECOLIPF2',LINE,IU,0))RETURN READ(LINE,*) RELATECOLIPF2 WRITE(*,'(A,I3)') 'RELATECOLIPF2=',RELATECOLIPF2 NVARS=NVARS+2 IF(UTL_READINITFILE('ICOLDATE2',LINE,IU,1))READ(LINE,*) ICOLDATE(2) WRITE(*,'(A)') 'ICOLDATE2='//TRIM(ICOLDATE(2)) IF(UTL_READINITFILE('ICOLVARS2',LINE,IU,1))READ(LINE,*) ICOLVARS(2) WRITE(*,'(A)') 'ICOLVARS2='//TRIM(ICOLVARS(2)) ENDIF XLAG=0.0; DLAG=7.0 IF(UTL_READINITFILE('XLAG',LINE,IU,1))READ(LINE,*) XLAG; WRITE(*,'(A,F10.2)') 'XLAG=',XLAG IF(UTL_READINITFILE('DLAG',LINE,IU,1))READ(LINE,*) DLAG; WRITE(*,'(A,F10.2)') 'DLAG=',DLAG DMY1=19000101; DMY2=21001231 IF(UTL_READINITFILE('DMY1',LINE,IU,1))READ(LINE,*) DMY1; WRITE(*,'(A,I8)') 'DMY1=',DMY1 IF(UTL_READINITFILE('DMY2',LINE,IU,1))READ(LINE,*) DMY2; WRITE(*,'(A,I8)') 'DMY2=',DMY2 IF(.NOT.UTL_READINITFILE('OUTFILE',LINE,IU,0))RETURN READ(LINE,*) OUTNAME WRITE(*,'(A)') 'OUTFILE='//TRIM(OUTNAME) IGEN=0 IF(UTL_READINITFILE('GENFILE',LINE,IU,1))THEN IGEN=1 READ(LINE,*) GENNAME; WRITE(*,'(A)') 'GENNAME='//TRIM(GENNAME) CXPERC='0.10,0.25,0.50,0.75,0.90' IF(UTL_READINITFILE('PERCENTILES',LINE,IU,1))READ(LINE,'(A50)') CXPERC WRITE(*,'(A)') 'CXPERC='//TRIM(CXPERC) IINVERSE=0 IF(UTL_READINITFILE('INVERSE',LINE,IU,1))READ(LINE,*) IINVERSE WRITE(*,'(A,I1)') 'IINVERSE=',IINVERSE ENDIF ALLOCATE(CVARS(NVARS),IVARS(NVARS)) IF(.NOT.UTL_READINITFILE('VARIABLES',LINE,IU,0))RETURN READ(LINE,*) IVARS; WRITE(*,'(A,5(I1,A1))') 'IVARS=',(IVARS(I),',',I=1,NVARS) IF(IPFNAME2.EQ.'')THEN CVARS(1)='Auto-Correlation (IPF A)' CVARS(2)='P50 (IPF A)' CVARS(3)='(n)GxG (IPF A)' ELSE CVARS(1)='Cross-Correlation' CVARS(2)='P50 (IPF A)' CVARS(3)='P50 (IPF B)' CVARS(4)='(n)GxG (IPF A)' CVARS(5)='(n)GxG (IPF B)' ENDIF SURFACELEVEL='' IF(UTL_READINITFILE('SURFACELEVEL',LINE,IU,1))THEN READ(LINE,*) SURFACELEVEL; WRITE(*,'(A)') 'SURFACELEVEL=',TRIM(SURFACELEVEL) ENDIF CALL TSTAT1APPLY(1) IF(ALLOCATED(CVARS))DEALLOCATE(CVARS) IF(ALLOCATED(IVARS))DEALLOCATE(IVARS) END SUBROUTINE IMODBATCH_IPFSTAT_MAIN !###====================================================================== SUBROUTINE IMODBATCH_IDFMEAN_MAIN() !###====================================================================== USE MOD_MEAN_PAR IMPLICIT NONE INTEGER :: I,J,N,SY,EY IBATCH=1; MEAN_FYR=0; MEAN_TYR=0 !## read mean ilay (optional) IF(.NOT.IMODBATCH_READPOINTER(MEAN_NLAYER,MEAN_ILAYER,'ILAYER',0))RETURN IF(MEAN_NLAYER.GT.0)THEN !## read start date (optional) IF(.NOT.UTL_READINITFILE('SDATE',LINE,IU,0))RETURN READ(LINE,*) MEAN_FYR; WRITE(*,'(A,I8)') 'SDATE=',MEAN_FYR LINE=ADJUSTL(LINE); READ(LINE,'(I4)') SY !## read end date (obliged) IF(.NOT.UTL_READINITFILE('EDATE',LINE,IU,0))RETURN READ(LINE,*) MEAN_TYR; WRITE(*,'(A,I8)') 'EDATE=',MEAN_TYR LINE=ADJUSTL(LINE); READ(LINE,'(I4)') EY IF(.NOT.IMODBATH_READYEAR(MEAN_NYEAR,MEAN_IYEAR,SYEAR=SY,EYEAR=EY))RETURN IF(.NOT.IMODBATH_READPERIOD(MEAN_NPERIOD,MEAN_IPERIOD))RETURN ENDIF IF(.NOT.IMODBATCH_AREAINFO(MEAN_ISEL,MEAN_IDFNAME,MEAN_GENFNAME))RETURN CFUNC='MEAN' IF(UTL_READINITFILE('CFUNC',LINE,IU,1))READ(LINE,*) CFUNC CFUNC=UTL_CAP(CFUNC,'U') SELECT CASE (TRIM(CFUNC)) CASE('MIN','MAX','MEAN','SUM') CASE('PERC') IF(.NOT.UTL_READINITFILE('PERCVALUE',LINE,IU,0))RETURN READ(LINE,*) PERCVALUE; WRITE(*,'(A,I8)') 'PERCVALUE=',PERCVALUE PERCVALUE=PERCVALUE/100.0 CASE DEFAULT WRITE(*,'(A)') 'CFUNC should be equal to MEAN,MIN,MAX,SUM,PERC'; STOP END SELECT WRITE(*,'(A)') 'CFUNC='//TRIM(CFUNC) IF(.NOT.UTL_READINITFILE('NDIR',LINE,IU,0))RETURN READ(LINE,*) N; WRITE(*,'(A,I4)') 'NDIR=',N ALLOCATE(MEAN_FMEAN(MAX(1,MEAN_NLAYER)),MEAN_FTOTAL(MAX(1,MEAN_NLAYER))) DO I=1,N !## read idfname IF(.NOT.UTL_READINITFILE('SOURCEDIR'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) MEAN_RESDIR IF(MEAN_NLAYER.GT.0)THEN !## remove "*" and "." if beyond "\" - in case sdate/edate/ilay will be used J=INDEX(MEAN_RESDIR,'\',.TRUE.) IF(INDEX(MEAN_RESDIR,'*',.TRUE.).GT.J)MEAN_RESDIR=MEAN_RESDIR(:INDEX(MEAN_RESDIR,'*',.TRUE.)-1) IF(INDEX(MEAN_RESDIR,'.',.TRUE.).GT.J)MEAN_RESDIR=MEAN_RESDIR(:INDEX(MEAN_RESDIR,'.',.TRUE.)-1) ENDIF LINE='SOURCEDIR'//TRIM(ITOS(I))//'='; WRITE(*,'(A)') TRIM(LINE)//TRIM(MEAN_RESDIR) IF(.NOT.MEAN1COMPUTE())THEN ENDIF END DO CALL MEAN1ABORT() IF(ALLOCATED(MEAN_FTOTAL))DEALLOCATE(MEAN_FTOTAL) IF(ALLOCATED(MEAN_FMEAN))DEALLOCATE(MEAN_FMEAN) IF(ASSOCIATED(MEAN_IPERIOD))DEALLOCATE(MEAN_IPERIOD) IF(ASSOCIATED(MEAN_IYEAR))DEALLOCATE(MEAN_IYEAR) IF(ASSOCIATED(MEAN_ILAYER))DEALLOCATE(MEAN_ILAYER) END SUBROUTINE IMODBATCH_IDFMEAN_MAIN !###====================================================================== SUBROUTINE IMODBATCH_WBALANCE_MAIN() !###====================================================================== USE MOD_WBAL_PAR USE IMODVAR, ONLY : TP,MXTP,MXSYS IMPLICIT NONE INTEGER :: I,J,K,N,SY,EY,NBAL CHARACTER(LEN=15),ALLOCATABLE,DIMENSION(:) :: CBAL IBATCH=1 !## default no exchange fluxes WBAL_WBEX=0 !## all off TP%IACT=0 DO I=1,SIZE(TP) ALLOCATE(TP(I)%ISYS(MXSYS)) TP(I)%NSYS=1 TP(I)%ISYS=0 ENDDO IF(.NOT.UTL_READINITFILE('NBAL',LINE,IU,0))RETURN READ(LINE,*) NBAL; WRITE(*,'(A,I4)') 'NBAL=',NBAL IF(NBAL.LE.0)STOP 'NBAL SHOULD BE > 0!' ALLOCATE(CBAL(NBAL)) DO I=1,NBAL IF(.NOT.UTL_READINITFILE('BAL'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) CBAL(I) DO J=1,MXTP; IF(TRIM(UTL_CAP(CBAL(I),'U')).EQ.TRIM(UTL_CAP(TP(J)%ACRNM,'U')))EXIT; ENDDO IF(J.GT.MXTP)THEN WRITE(*,'(/A)') 'Cannot identify keyword '//TRIM(CBAL(I)) WRITE(*,'(A/)') 'Choose out of:' DO J=1,MXTP WRITE(*,'(I2,A1,A15,A)') J,'-',TRIM(TP(J)%ACRNM),' = '//TRIM(TP(J)%ALIAS) ENDDO STOP ENDIF TP(J)%IACT=1 LINE='BAL'//TRIM(ITOS(I))//'='//TRIM(TP(J)%ACRNM)//' ('//TRIM(TP(J)%ALIAS)//')' WRITE(*,'(A)') TRIM(LINE) IF(.NOT.IMODBATCH_READPOINTER(TP(J)%NSYS,TP(I)%ISYS,'BAL'//TRIM(ITOS(I))//'ISYS',1))RETURN IF(TP(J)%ISYS(1).EQ.0)THEN TP(J)%NSYS=1 LINE='- all systems'; WRITE(*,'(A)') TRIM(LINE) ELSE LINE='- systems' DO K=1,TP(J)%NSYS; LINE=TRIM(LINE)//', '//TRIM(ITOS(TP(J)%ISYS(K))); ENDDO; WRITE(*,'(A)') TRIM(LINE) ENDIF ENDDO !## correct systems for modules DO I=1,6 TP(I)%NSYS=1 TP(I)%ISYS=0 ENDDO WBAL_ISTEADY=1 !## read start date (optional IF(UTL_READINITFILE('SDATE',LINE,IU,1))THEN READ(LINE,*) WBAL_FYR; WRITE(*,'(A,I8)') 'SDATE=',WBAL_FYR LINE=ADJUSTL(LINE); READ(LINE,'(I4)') SY !## read end date IF(.NOT.UTL_READINITFILE('EDATE',LINE,IU,0))RETURN READ(LINE,*) WBAL_TYR; WRITE(*,'(A,I8)') 'EDATE=',WBAL_TYR LINE=ADJUSTL(LINE); READ(LINE,'(I4)') EY IF(.NOT.IMODBATH_READYEAR(WBAL_NYEAR,WBAL_IYEAR,SYEAR=SY,EYEAR=EY))RETURN IF(.NOT.IMODBATH_READPERIOD(WBAL_NPERIOD,WBAL_IPERIOD))RETURN WBAL_ISTEADY=0 ELSE WRITE(*,'(/1A/)') 'COMPUTING WATERBALANCE FOR STEADY-STATE SIMULATION' ENDIF IF(.NOT.IMODBATCH_READPOINTER(WBAL_NLAYER,WBAL_ILAYER,'ILAYER',0))RETURN IF(.NOT.IMODBATCH_AREAINFO(WBAL_ISEL,WBAL_IDFNAME,WBAL_GENFNAME))RETURN IF(UTL_READINITFILE('WBEX',LINE,IU,1))READ(LINE,*) WBAL_WBEX WRITE(*,'(A,I1)') 'WBEX=',WBAL_WBEX IF(.NOT.UTL_READINITFILE('NDIR',LINE,IU,0))RETURN READ(LINE,*) N; WRITE(*,'(A,I4)') 'NDIR=',N DO I=1,N !## read idfname IF(.NOT.UTL_READINITFILE('SOURCEDIR'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) WBAL_RESDIR LINE='SOURCEDIR'//TRIM(ITOS(I))//'=' WRITE(*,'(A)') TRIM(LINE)//TRIM(WBAL_RESDIR) IF(.NOT.UTL_READINITFILE('OUTPUTNAME'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) WBAL_OUTFNAME LINE='OUTPUTNAME'//TRIM(ITOS(I))//'=' WRITE(*,'(A)') TRIM(LINE)//TRIM(WBAL_OUTFNAME) IF(.NOT.WBALCOMPUTE())THEN; ENDIF END DO !## release waterbalance-related memory again CALL WBALABORT() IF(ALLOCATED(CBAL))DEALLOCATE(CBAL) ! IF(.NOT.WBAL_ANALYSE_MAIN('g:\IMOD-MODELS\ALBERTA\SYLVAN_LAKE\IMOD_USER\MODELS\SLB_V9_250\WBAL.CSV'))THEN ! ENDIF ! IF(.NOT.WBAL_ANALYSE_MAIN('g:\IMOD-MODELS\ALBERTA\SYLVAN_LAKE\IMOD_USER\MODELS\SLB_V15_TRANSIENT\WBAL_WHOLE.CSV'))THEN ! ENDIF END SUBROUTINE IMODBATCH_WBALANCE_MAIN !###====================================================================== SUBROUTINE IMODBATCH_IDFSTAT_MAIN() !###====================================================================== IMPLICIT NONE INTEGER :: IOS,I,N,JU,IFORMAT CHARACTER(LEN=256) :: SOURCEDIR,OUTFILE,ROOT CHARACTER(LEN=1000) :: STRING CHARACTER(LEN=256),ALLOCATABLE,DIMENSION(:) :: IDFNAMES CHARACTER(LEN=50) :: WC IF(.NOT.UTL_READINITFILE('SOURCEDIR',LINE,IU,0))RETURN READ(LINE,*) SOURCEDIR; WRITE(*,'(A)') 'SOURCEDIR='//TRIM(SOURCEDIR) IF(.NOT.UTL_READINITFILE('OUTFILE',LINE,IU,0))RETURN READ(LINE,*) OUTFILE; WRITE(*,'(A)') 'OUTFILE='//TRIM(OUTFILE) IFORMAT=0; IF(UTL_READINITFILE('IFORMAT',LINE,IU,1))READ(LINE,*) IFORMAT WRITE(*,'(A,I1)') 'IFORMAT=',IFORMAT JU=UTL_GETUNIT() CALL OSD_OPEN(JU,FILE=OUTFILE,STATUS='UNKNOWN',IOSTAT=IOS) IF(IOS.NE.0)THEN; WRITE(*,*) 'Error opening file '//TRIM(OUTFILE); RETURN; ENDIF I=INDEX(SOURCEDIR,'\',.TRUE.); ROOT=SOURCEDIR(:I-1); WC=TRIM(SOURCEDIR(I+1:)) CALL IOSDIRENTRYTYPE('F'); CALL IOSDIRCOUNT(TRIM(ROOT),TRIM(WC),N) IF(N.EQ.0)THEN; WRITE(*,'(A)') 'No files found in: '//TRIM(SOURCEDIR); RETURN; ENDIF ALLOCATE(IDFNAMES(N)) CALL UTL_DIRINFO(TRIM(ROOT),TRIM(WC),IDFNAMES,N,'F') SELECT CASE (IFORMAT) CASE (0) DO I=1,SIZE(IDFNAMES); WRITE(JU,'(I5,A)') I,','//TRIM(IDFNAMES(I)); ENDDO WRITE(STRING,'(A6,3(A16))') 'File,','Population,','Mean,','Variance,' DO I=1,21 IF(I.NE.21)WRITE(STRING,'(A,11X,A2,I2,A2)') TRIM(STRING),'P(',(I-1)*5,'),' IF(I.EQ.21)WRITE(STRING,'(A,10X,A2,I3,A1)') TRIM(STRING),'P(',(I-1)*5,')' ENDDO CASE (1) WRITE(STRING,'(A20,6(A16))') 'File,','Population,','Mean,','Variance','Min,','Max,','Median' CASE DEFAULT WRITE(*,'(A)') 'Wrong format chosen' END SELECT WRITE(JU,'(A)') TRIM(STRING) DO I=1,SIZE(IDFNAMES) WRITE(*,'(A)') 'Busy with: '//TRIM(IDFNAMES(I)) IDFNAMES(I)=TRIM(ROOT)//'\'//TRIM(IDFNAMES(I)) CALL INFOSTAT(IDFNAMES(I),JU,IFORMAT) !,XMIN,YMIN,XMAX,YMAX) <--- OPTIONAL ENDDO CLOSE(JU) END SUBROUTINE IMODBATCH_IDFSTAT_MAIN !###====================================================================== SUBROUTINE IMODBATCH_IMPORTMODFLOW_MAIN() !###====================================================================== USE MOD_IMPORT_PAR, ONLY : IVERSION,FNAME_MDL,XMIN,YMIN,SDATE,RUNFILE,DIR_DBS,ISUMPCK,IRIV5,IBATCH IMPLICIT NONE CHARACTER(LEN=4) :: MVERSION IF(.NOT.UTL_READINITFILE('MVERSION',LINE,IU,0))RETURN READ(LINE,*) MVERSION; WRITE(*,'(A)') 'MVERSION='//TRIM(MVERSION) SELECT CASE (MVERSION) CASE ('1988') IF(UTL_READINITFILE('BASFILE',LINE,IU,1))THEN READ(LINE,*) FNAME_MDL; WRITE(*,'(A)') 'BASFILE='//TRIM(FNAME_MDL) ELSE IF(.NOT.UTL_READINITFILE('NAMFILE',LINE,IU,0))RETURN READ(LINE,*) FNAME_MDL; WRITE(*,'(A)') 'NAMFILE='//TRIM(FNAME_MDL) ENDIF IVERSION=1 CASE ('1996') IF(.NOT.UTL_READINITFILE('NAMFILE',LINE,IU,0))RETURN READ(LINE,*) FNAME_MDL; WRITE(*,'(A)') 'NAMFILE='//TRIM(FNAME_MDL) IVERSION=2 CASE ('2000') IF(.NOT.UTL_READINITFILE('NAMFILE',LINE,IU,0))RETURN READ(LINE,*) FNAME_MDL; WRITE(*,'(A)') 'NAMFILE='//TRIM(FNAME_MDL) IVERSION=3 CASE ('2005') IF(.NOT.UTL_READINITFILE('NAMFILE',LINE,IU,0))RETURN READ(LINE,*) FNAME_MDL; WRITE(*,'(A)') 'NAMFILE='//TRIM(FNAME_MDL) IVERSION=4 CASE DEFAULT WRITE(*,'(A)') 'Only 1988,1996,2000 or 2005 are sustained behind MODFLOWVERSION=' STOP END SELECT XMIN=0.0 YMIN=0.0 IF(UTL_READINITFILE('LLCORNER',LINE,IU,1))READ(LINE,*) XMIN,YMIN WRITE(*,'(A,2F10.2)') 'LLCORNER=',XMIN,YMIN SDATE=20110101 IF(UTL_READINITFILE('SDATE',LINE,IU,1))READ(LINE,*) SDATE WRITE(*,'(A,I8)') 'SDATE=',SDATE SDATE=UTL_IDATETOJDATE(SDATE) DIR_DBS='.' IF(UTL_READINITFILE('OUTDIR',LINE,IU,1))READ(LINE,*) DIR_DBS IF(INDEX(DIR_DBS,'\',.TRUE.).EQ.LEN_TRIM(DIR_DBS))DIR_DBS(LEN_TRIM(DIR_DBS):LEN_TRIM(DIR_DBS))=' ' RUNFILE =TRIM(DIR_DBS)//'\model.run' WRITE(*,'(A)') 'OUTDIR='//TRIM(DIR_DBS) ISUMPCK=0 IF(UTL_READINITFILE('PACKAGESUM',LINE,IU,1))READ(LINE,*) ISUMPCK IRIV5=0 IF(UTL_READINITFILE('RIV5TH',LINE,IU,1))READ(LINE,*) IRIV5 WRITE(*,'(A,I8)') 'PACKAGESUM=',ISUMPCK WRITE(*,'(A,I8)') 'RIV5TH=',IRIV5 ISUMPCK=ABS(ISUMPCK-1) IBATCH=1 IF(IMPORT_CALC())THEN; ENDIF END SUBROUTINE IMODBATCH_IMPORTMODFLOW_MAIN !###====================================================================== SUBROUTINE IMODBATCH_CALC_MAIN() !###====================================================================== USE MOD_MATH_PAR IMPLICIT NONE INTEGER :: I,N INTEGER,DIMENSION(3) :: IG CHARACTER(LEN=256) :: SOURCEDIRA,SOURCEDIRB,SOURCEDIRC,ROOT,ROOTA,ROOTB,ROOTC CHARACTER(LEN=52) :: WC,WCA,WCB,WCC,SUBSTR !## get scale type (1=upscaling;2=downscaling) IF(.NOT.UTL_READINITFILE('FUNC',LINE,IU,0))RETURN READ(LINE,*) FUNC FUNC=UTL_CAP(FUNC,'U'); WRITE(*,'(A)') 'FUNC='//TRIM(FUNC) ! !## exclude functions, they are within brackets "(" ! I=INDEX(FUNC,'('); I=MAX(I,1) I=1 IG(1)=INDEX(FUNC(I:),'A') IG(2)=INDEX(FUNC(I:),'B') IG(3)=INDEX(FUNC(I:),'C') DO I=1,3; IG(I)=MIN(1,MAX(IG(I),0)); ENDDO IF(SUM(IG).LE.1)THEN WRITE(*,'(A)') 'ERROR, enter function with at least C and A and/or B' WRITE(*,'(A)') 'FUNC='//TRIM(FUNC) RETURN ENDIF IIEXT=2 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN IIEXT=3 READ(LINE,*) MPW%XMIN,MPW%YMIN,MPW%XMAX,MPW%YMAX WRITE(*,'(A,4F10.2)') 'WINDOW=',MPW%XMIN,MPW%YMIN,MPW%XMAX,MPW%YMAX ENDIF IGEN=0 IF(UTL_READINITFILE('GENFILE',LINE,IU,1))THEN READ(LINE,*) GENNAME WRITE(*,'(A)') 'GENFILE='//TRIM(GENNAME) IGEN=1 ENDIF TRIM_VALUE=0.0; IF(UTL_READINITFILE('TRIM_VALUE',LINE,IU,1))READ(LINE,*) TRIM_VALUE WRITE(*,'(A,F10.3)') 'TRIM_VALUE=',TRIM_VALUE INODATA=0 !## ignore default NODATA_VALUE=0.0 IF(UTL_READINITFILE('USENODATA',LINE,IU,1))THEN READ(LINE,*) INODATA IF(INODATA.EQ.1)THEN IF(.NOT.UTL_READINITFILE('NODATAVALUE',LINE,IU,0))RETURN READ(LINE,*) NODATA_VALUE ENDIF ENDIF IF(INODATA.EQ.0)WRITE(*,'(A,I1)') 'USENODATA=',INODATA,'(cell with nodata values will be LEFT OUT)' IF(INODATA.EQ.1)THEN WRITE(*,'(A,I1)') 'USENODATA=',INODATA,'(cell with nodata values will be translated into NODATA_VALUE)' WRITE(*,'(A,F10.3)') 'NODATAVALUE=',NODATA_VALUE ENDIF IEQUI=0 IF(UTL_READINITFILE('IEQUI',LINE,IU,1))READ(LINE,*) IEQUI WRITE(*,'(A,I1)') 'IEQUI=',IEQUI N=0 IF(UTL_READINITFILE('NREPEAT',LINE,IU,1))READ(LINE,*) N !## given names IF(N.GT.0)THEN WRITE(*,'(A,I10)') 'NREPEAT=',N ALLOCATE(IDFNAMES(N,3)) IDFNAMES='' DO I=1,N !## get idfnames IF(SUM(IG).EQ.3)THEN IF(.NOT.UTL_READINITFILE('ABC'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) IDFNAMES(I,1),IDFNAMES(I,2),IDFNAMES(I,3) LINE='A'//TRIM(ITOS(I))//'='//TRIM(IDFNAMES(I,1)) WRITE(*,'(A)') TRIM(LINE) LINE='B'//TRIM(ITOS(I))//'='//TRIM(IDFNAMES(I,2)) WRITE(*,'(A)') TRIM(LINE) LINE='C'//TRIM(ITOS(I))//'='//TRIM(IDFNAMES(I,3)) WRITE(*,'(A)') TRIM(LINE) ELSE IF(IG(1).EQ.1)THEN IF(.NOT.UTL_READINITFILE('AC'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) IDFNAMES(I,1),IDFNAMES(I,3) LINE='A'//TRIM(ITOS(I))//'='//TRIM(IDFNAMES(I,1)) WRITE(*,'(A)') TRIM(LINE) LINE='C'//TRIM(ITOS(I))//'='//TRIM(IDFNAMES(I,3)) WRITE(*,'(A)') TRIM(LINE) ELSE IF(.NOT.UTL_READINITFILE('BC'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) IDFNAMES(I,2),IDFNAMES(I,3) LINE='B'//TRIM(ITOS(I))//'='//TRIM(IDFNAMES(I,2)) WRITE(*,'(A)') TRIM(LINE) LINE='C'//TRIM(ITOS(I))//'='//TRIM(IDFNAMES(I,3)) WRITE(*,'(A)') TRIM(LINE) ENDIF ENDIF ENDDO !## wildcard mode ELSE IF(IG(1).GT.0)THEN IF(.NOT.UTL_READINITFILE('SOURCEDIRA',LINE,IU,0))RETURN READ(LINE,*) SOURCEDIRA WRITE(*,'(A)') 'SOURCEDIRA='//TRIM(SOURCEDIRA) I=INDEX(SOURCEDIRA,'\',.TRUE.); ROOTA=SOURCEDIRA(:I-1); WCA=TRIM(SOURCEDIRA(I+1:)) CALL IOSDIRENTRYTYPE('F'); CALL IOSDIRCOUNT(TRIM(ROOTA),TRIM(WCA),N) ROOT=ROOTA; WC=WCA ENDIF IF(IG(2).GT.0)THEN IF(.NOT.UTL_READINITFILE('SOURCEDIRB',LINE,IU,0))RETURN READ(LINE,*) SOURCEDIRB WRITE(*,'(A)') 'SOURCEDIRB='//TRIM(SOURCEDIRB) I=INDEX(SOURCEDIRB,'\',.TRUE.); ROOTB=SOURCEDIRB(:I-1); WCB=TRIM(SOURCEDIRB(I+1:)) IF(IG(1).EQ.0)THEN CALL IOSDIRENTRYTYPE('F'); CALL IOSDIRCOUNT(TRIM(ROOTB),TRIM(WCB),N) ROOT=ROOTB; WC=WCB ENDIF ENDIF IF(N.EQ.0)THEN; WRITE(*,*) 'No files found in: '//TRIM(ROOT)//'\'//TRIM(WC); RETURN; ENDIF WRITE(*,'(A,I10)') 'NREPEAT=',N ALLOCATE(IDFNAMES(N,3)) CALL UTL_DIRINFO(TRIM(ROOT),TRIM(WC),IDFNAMES(:,1),N,'F') IF(.NOT.UTL_READINITFILE('SOURCEDIRC',LINE,IU,0))RETURN READ(LINE,*) SOURCEDIRC WRITE(*,'(A)') 'SOURCEDIRC='//TRIM(SOURCEDIRC) I=INDEX(SOURCEDIRC,'\',.TRUE.); ROOTC=SOURCEDIRC(:I-1); WCC=TRIM(SOURCEDIRC(I+1:)) WCA=UTL_CAP(WCA,'U') WCB=UTL_CAP(WCB,'U') WCC=UTL_CAP(WCC,'U') DO I=1,SIZE(IDFNAMES,1) IDFNAMES(I,1)=UTL_CAP(IDFNAMES(I,1),'U') CALL IMODBATCH_CALC_SUBST(IDFNAMES(I,1),WCA,SUBSTR) IDFNAMES(I,1)=TRIM(ROOTA)//'\'//TRIM(IDFNAMES(I,1)) IDFNAMES(I,2)=TRIM(ROOTB)//'\'//TRIM(WCB) IDFNAMES(I,3)=TRIM(ROOTC)//'\'//TRIM(WCC) IDFNAMES(I,2)=UTL_SUBST(IDFNAMES(I,2),'*',SUBSTR) IDFNAMES(I,3)=UTL_SUBST(IDFNAMES(I,3),'*',SUBSTR) IF(IG(1).GT.0)THEN LINE='A'//TRIM(ITOS(I))//'='//TRIM(IDFNAMES(I,1)) WRITE(*,'(A)') TRIM(LINE) ENDIF IF(IG(2).GT.0)THEN LINE='B'//TRIM(ITOS(I))//'='//TRIM(IDFNAMES(I,2)) WRITE(*,'(A)') TRIM(LINE) ENDIF LINE='C'//TRIM(ITOS(I))//'='//TRIM(IDFNAMES(I,3)) WRITE(*,'(A)') TRIM(LINE) ENDDO ENDIF IF(MATH1CALC(1,ROOTC))THEN; ENDIF CALL MATH1CALCCLOSE(1) END SUBROUTINE IMODBATCH_CALC_MAIN !###====================================================================== SUBROUTINE IMODBATCH_CALC_SUBST(FNAME,WC,SUBSTR) !###====================================================================== CHARACTER(LEN=*),INTENT(IN) :: WC,FNAME CHARACTER(LEN=*),INTENT(OUT) :: SUBSTR INTEGER :: I,J !## get in-between-string I=INDEX(FNAME,WC(1:INDEX(WC,'*')-1)) I=I+(INDEX(WC,'*')-1) J=INDEX(FNAME,WC(INDEX(WC,'*')+1:))-1 IF(I.EQ.0.OR.J.EQ.0)THEN SUBSTR=FNAME ELSE SUBSTR=FNAME(I:J) ENDIF END SUBROUTINE IMODBATCH_CALC_SUBST !###====================================================================== SUBROUTINE IMODBATCH_SCALE_MAIN() !###====================================================================== USE MOD_MATH_SCALE_PAR IMPLICIT NONE INTEGER :: I !## initialize optional arguments IINT=4 SFCT=1.0 IBUFFER=0 !## get scale type (1=upscaling;2=downscaling) IF(.NOT.UTL_READINITFILE('SCALESIZE',LINE,IU,0))RETURN READ(LINE,*) SCLSIZE; WRITE(*,'(A,F10.2)') 'SCALESIZE=',SCLSIZE !## default scltype_up=2 (mean) SCLTYPE_UP=2; IF(UTL_READINITFILE('SCLTYPE_UP',LINE,IU,1))THEN READ(LINE,*) SCLTYPE_UP; WRITE(*,'(A,I2)') 'SCLTYPE_UP=',SCLTYPE_UP; ENDIF SCLTYPE_DOWN=0; IF(UTL_READINITFILE('SCLTYPE_DOWN',LINE,IU,1))THEN READ(LINE,*) SCLTYPE_DOWN; WRITE(*,'(A,I2)') 'SCLTYPE_DOWN=',SCLTYPE_DOWN; ENDIF IF(SCLTYPE_UP.EQ.0.AND.SCLTYPE_DOWN.EQ.0)THEN WRITE(*,'(/1X,A/)') 'You should specify SCLTYPE_UP and/or SCLTYPE_DOWN'; STOP ENDIF !## upscaling IF(SCLTYPE_UP.GT.0)THEN SELECT CASE (SCLTYPE_UP) CASE (8) IF(.NOT.UTL_READINITFILE('PERCENTILE',LINE,IU,0))RETURN READ(LINE,*) SFCT !## <>1.0 WRITE(*,'(A,F10.2)') 'SFCT=',SFCT CASE (1,3,4,5,6,9) IF(UTL_READINITFILE('WEIGHFACTOR',LINE,IU,1))READ(LINE,*) SFCT !## <>1.0 WRITE(*,'(A,F10.2)') 'SFCT=',SFCT CASE (14) HOR_FCT=1.0 VER_FCT=1.0 MAXK=250.0 !## grof zand DHX=0.0 DHY=0.0 DHZ=0.0 QRATE=0.0 ISURFWATER=0 AQFR_KD=250.0 !## m/day ILGROUP=1 !## vertical box to average k-value KMIN=1.0 !## k-value to become clay IF(UTL_READINITFILE('ANI_X',LINE,IU,1))READ(LINE,*) HOR_FCT !## <>1.0 WRITE(*,'(A,F10.2)') 'ANI_X=',HOR_FCT IF(UTL_READINITFILE('ANI_Z',LINE,IU,1))READ(LINE,*) VER_FCT !## <>1.0 WRITE(*,'(A,F10.2)') 'ANI_Z=',VER_FCT IF(UTL_READINITFILE('DH_X',LINE,IU,1))READ(LINE,*) DHX !## <>1.0 WRITE(*,'(A,F10.2)') 'DH_X=',DHX IF(UTL_READINITFILE('DH_Y',LINE,IU,1))READ(LINE,*) DHY !## <>1.0 WRITE(*,'(A,F10.2)') 'DH_Y=',DHY IF(UTL_READINITFILE('DH_Z',LINE,IU,1))READ(LINE,*) DHZ !## <>1.0 WRITE(*,'(A,F10.2)') 'DH_Z=',DHZ IF(UTL_READINITFILE('MAX_K',LINE,IU,1))READ(LINE,*) MAXK !## >> WRITE(*,'(A,F10.2)') 'MAX_K=',MAXK IF(UTL_READINITFILE('QRATE',LINE,IU,1))THEN READ(LINE,*) QRATE !## extraction rate m3/day WRITE(*,'(A,F10.2)') 'QRATE=',QRATE IF(UTL_READINITFILE('AQFR_KD',LINE,IU,1))READ(LINE,*) AQFR_KD !## transmissivity of aquifer WRITE(*,'(A,F10.2)') 'AQFR_KD=',AQFR_KD ENDIF IF(UTL_READINITFILE('ISURFWATER',LINE,IU,1))READ(LINE,*) ISURFWATER !## >> apply surface water to nodata column WRITE(*,'(A,I1)') 'ISURFWATER=',ISURFWATER IF(UTL_READINITFILE('KMIN',LINE,IU,1))READ(LINE,*) KMIN !## minimal k-value to become clay WRITE(*,'(A,F10.2)') 'KMIN=',KMIN IF(UTL_READINITFILE('ILGROUP',LINE,IU,1))READ(LINE,*) ILGROUP !## >> vertical number of layers to aggregrate to get k-value average WRITE(*,'(A,I1)') 'ILGROUP=',ILGROUP END SELECT !## downscaling ENDIF IF(SCLTYPE_DOWN.GT.0)THEN SELECT CASE (SCLTYPE_DOWN) CASE (1) IF(UTL_READINITFILE('BLOCK',LINE,IU,1))READ(LINE,*) IINT !## 4,16,32,64,100 SELECT CASE (TRIM(LINE)) CASE ('4','16','32','64','100') STOP 'BLOCK should be in {4,16,32,64,100}' CASE DEFAULT END SELECT WRITE(*,'(A,I1)') 'IINT=',IINT END SELECT ENDIF IIEXT=2 !## given idf IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN IIEXT=3 !## given window READ(LINE,*) MPW%XMIN,MPW%YMIN,MPW%XMAX,MPW%YMAX WRITE(*,'(A,4F10.2)') 'WINDOW=',MPW%XMIN,MPW%YMIN,MPW%XMAX,MPW%YMAX ENDIF ALLOCATE(IDFNAMES(1),OUTNAMES(1)); OUTNAMES='' !## get idfnames SELECT CASE (SCLTYPE_UP) CASE (14) IF(.NOT.UTL_READINITFILE('SOURCEDIR',LINE,IU,0))RETURN READ(LINE,*) IDFNAMES(1) WRITE(*,'(A)') 'SOURCEDIR='//TRIM(IDFNAMES(1)) ALLOCATE(TRIMIDF(2)); DO I=1,2; CALL IDFNULLIFY(TRIMIDF(I)); ENDDO; TRIMIDF%FNAME='' ITRIM=0 IF(UTL_READINITFILE('TOPTRIMIDF',LINE,IU,1))THEN READ(LINE,*) TRIMIDF(1)%FNAME; WRITE(*,'(A)') 'TOPTRIMIDF='//TRIM(TRIMIDF(1)%FNAME) IF(.NOT.IDFREAD(TRIMIDF(1),TRIMIDF(1)%FNAME,0))RETURN ITRIM(1)=1 ENDIF IF(UTL_READINITFILE('BOTTRIMIDF',LINE,IU,1))THEN READ(LINE,*) TRIMIDF(2)%FNAME; WRITE(*,'(A)') 'BOTTRIMIDF='//TRIM(TRIMIDF(2)%FNAME) IF(.NOT.IDFREAD(TRIMIDF(2),TRIMIDF(2)%FNAME,0))RETURN ITRIM(2)=1 ENDIF CASE DEFAULT IF(.NOT.UTL_READINITFILE('SOURCEIDF',LINE,IU,0))RETURN READ(LINE,*) IDFNAMES(1) WRITE(*,'(A)') 'SOURCEIDF='//TRIM(IDFNAMES(1)) END SELECT !## get buffersize SELECT CASE (SCLTYPE_UP) CASE (11,12,13,14) IF(UTL_READINITFILE('BUFFER',LINE,IU,1))READ(LINE,*) IBUFFER WRITE(*,'(A,I3)') 'BUFFER=',IBUFFER END SELECT IF(.NOT.UTL_READINITFILE('OUTFILE',LINE,IU,0))RETURN READ(LINE,*) OUTNAMES(1) WRITE(*,'(A)') 'OUTFILE='//TRIM(OUTNAMES(1)) IF(MATH1SCALE(1))THEN; ENDIF CALL MATH1SCALECLOSE(1) END SUBROUTINE IMODBATCH_SCALE_MAIN !###====================================================================== SUBROUTINE IMODBATCH_MERGE_MAIN() !###====================================================================== USE MOD_MATH_MERGE_PAR IMPLICIT NONE INTEGER :: I,N CHARACTER(LEN=256) :: SOURCEDIR,ROOT CHARACTER(LEN=50) :: WC !## get number of files to be merged IF(UTL_READINITFILE('NMERGE',LINE,IU,1))THEN READ(LINE,*) N; WRITE(*,'(A,I10)') 'NMERGE=',N ALLOCATE(IDFNAMES(N)) DO I=1,N IF(.NOT.UTL_READINITFILE('SOURCEIDF'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) IDFNAMES(I) LINE='SOURCEIDF'//TRIM(ITOS(I))//'='//TRIM(IDFNAMES(I)) WRITE(*,'(A)') TRIM(LINE) ENDDO ELSE IF(.NOT.UTL_READINITFILE('SOURCEDIR',LINE,IU,0))RETURN READ(LINE,*) SOURCEDIR I=INDEX(SOURCEDIR,'\',.TRUE.); ROOT=SOURCEDIR(:I-1); WC=TRIM(SOURCEDIR(I+1:)) CALL IOSDIRENTRYTYPE('F'); CALL IOSDIRCOUNT(TRIM(ROOT),TRIM(WC),N) IF(N.EQ.0)THEN WRITE(*,'(A)') 'No files found in: '//TRIM(SOURCEDIR) RETURN ENDIF ALLOCATE(IDFNAMES(N)) CALL UTL_DIRINFO(TRIM(ROOT),TRIM(WC),IDFNAMES,N,'F') ENDIF IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) MPW%XMIN,MPW%YMIN,MPW%XMAX,MPW%YMAX WRITE(*,'(A,4F10.2)') 'WINDOW=',MPW%XMIN,MPW%YMIN,MPW%XMAX,MPW%YMAX IEXT=1 ELSE WRITE(*,'(A)') 'no window given'; IEXT=2 ENDIF IMASK=0 IF(UTL_READINITFILE('MASKIDF',LINE,IU,1))THEN IMASK=1 READ(LINE,*) MSKNAME; WRITE(*,'(A)') 'MASKIDF='//TRIM(MSKNAME) ELSE WRITE(*,'(A)') 'no mask given' ENDIF IF(.NOT.UTL_READINITFILE('TARGETIDF',LINE,IU,0))RETURN READ(LINE,*) OUTNAME; WRITE(*,'(A)') 'TARGETIDF='//TRIM(OUTNAME) CLOSE(IU) IF(MATH1MERGE(1))THEN ENDIF CALL MATH1MERGECLOSE(1) END SUBROUTINE IMODBATCH_MERGE_MAIN !###====================================================================== SUBROUTINE IMODBATCH_CREATEIDF_MAIN() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: DIRNAME CHARACTER(LEN=52) :: TOPWC REAL :: BOTEL,MULT,ADD !## get number of files to be imported IF(.NOT.UTL_READINITFILE('SOURCEDIR',LINE,IU,0))RETURN READ(LINE,*) DIRNAME; WRITE(*,'(A)') 'SOURCEDIR='//TRIM(DIRNAME) TOPWC=''; BOTEL=0.0; MULT =1.0; ADD=0.0 IF(UTL_READINITFILE('TOPWC',LINE,IU,1))THEN READ(LINE,*) TOPWC; WRITE(*,'(A)') 'TOPWC='//TRIM(TOPWC) IF(.NOT.UTL_READINITFILE('BOTEL',LINE,IU,0))RETURN READ(LINE,*) BOTEL; WRITE(*,'(A,F10.2)') 'BOTEL=',BOTEL IF(UTL_READINITFILE('MULT',LINE,IU,1))THEN READ(LINE,*) MULT; WRITE(*,'(A,F10.2)') 'MULT=',MULT ENDIF IF(UTL_READINITFILE('ADD',LINE,IU,1))THEN READ(LINE,*) ADD; WRITE(*,'(A,F10.2)') 'ADD=',ADD ENDIF ENDIF CLOSE(IU) CALL ASC2IDF_IMPORTASC_MAIN(DIRNAME,TOPWC,BOTEL,MULT,ADD,1) END SUBROUTINE IMODBATCH_CREATEIDF_MAIN !###====================================================================== SUBROUTINE IMODBATCH_CREATEASC_MAIN() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: DIRNAME INTEGER :: IBATCH !## get number of files to be exported IF(.NOT.UTL_READINITFILE('SOURCEDIR',LINE,IU,0))RETURN READ(LINE,*) DIRNAME; WRITE(*,'(A)') 'SOURCEDIR='//TRIM(DIRNAME) CLOSE(IU) CALL ASC2IDF_EXPORTASC_MAIN(DIRNAME,IBATCH) END SUBROUTINE IMODBATCH_CREATEASC_MAIN !###====================================================================== SUBROUTINE IMODBATCH_CREATEIVF_MAIN() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: DIRNAME CHARACTER(LEN=256),ALLOCATABLE,DIMENSION(:,:) :: TBNAME CHARACTER(LEN=52) :: DATE INTEGER :: NLAY,I !## get number of files to be exported IF(.NOT.UTL_READINITFILE('SOURCEDIR',LINE,IU,0))RETURN READ(LINE,*) DIRNAME; WRITE(*,'(A)') 'SOURCEDIR='//TRIM(DIRNAME) IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) NLAY; WRITE(*,'(A,I10)') 'NLAY=',NLAY IF(.NOT.UTL_READINITFILE('DATE',LINE,IU,0))RETURN READ(LINE,*) DATE; WRITE(*,'(A)') 'DATE='//TRIM(DATE) ALLOCATE(TBNAME(NLAY,2)) DO I=1,NLAY IF(.NOT.UTL_READINITFILE('TOP'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) TBNAME(I,1); WRITE(*,'(A)') 'TOP'//TRIM(ITOS(I))//'='//TRIM(TBNAME(I,1)) IF(.NOT.UTL_READINITFILE('BOT'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) TBNAME(I,2); WRITE(*,'(A)') 'BOT'//TRIM(ITOS(I))//'='//TRIM(TBNAME(I,2)) ENDDO IF(.NOT.IDFCREATEIVF(TRIM(DIRNAME),TRIM(DATE),TBNAME,NLAY))THEN; ENDIF DEALLOCATE(TBNAME) CLOSE(IU) END SUBROUTINE IMODBATCH_CREATEIVF_MAIN !###====================================================================== SUBROUTINE IMODBATCH_AHNFILTER_MAIN() !###====================================================================== USE MOD_AHNFILTER_PAR IMPLICIT NONE INTEGER :: I,NWINDOW !## read idfname IF(.NOT.UTL_READINITFILE('NAHN',LINE,IU,0))RETURN READ(LINE,*) NAHN; IF(NAHN.LE.0)STOP 'NAHN.LE.0' WRITE(*,'(A,I10)') 'NAHN=',NAHN ALLOCATE(AHN(NAHN)) DO I=1,NAHN !## read surface name IF(.NOT.UTL_READINITFILE('IDFFILE'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) AHN(I) LINE='IDFFILE'//TRIM(ITOS(I))//'='//TRIM(AHN(I)); WRITE(*,'(A)') TRIM(LINE) ENDDO NSCRIT =1500 !## surface yes/no (cells!) LOCCRIT =2.00 !## no local depression/upconing whenever max-min>loccrit (m) XCRIT =0.50 !## building/strong edge (m) DPW =5 !## size window upconing DP1 =30.0 !## depression percentile DP2 =90.0 !## upconing percentile CORXCRIT =0.10 !## max. change to become surf.level (m) CORCRIT =50 !## max. number of cells corrected during interpolation outer loop (-) INTXCRIT =0.05 !## stop criterion max. change interpolation (m) INTNODATA=1 !## ignore nodata BUFFER =0.0 !## buffer IAGGREGATEY=0 !## aggregrate y IF(UTL_READINITFILE('IAGGREGATEY',LINE,IU,1))READ(LINE,*) IAGGREGATEY IF(UTL_READINITFILE('IGNORENODATA',LINE,IU,1))READ(LINE,*) INTNODATA IF(UTL_READINITFILE('NSCRIT',LINE,IU,1))READ(LINE,*) NSCRIT IF(UTL_READINITFILE('LOCCRIT',LINE,IU,1))READ(LINE,*) LOCCRIT IF(UTL_READINITFILE('XCRIT',LINE,IU,1))READ(LINE,*) XCRIT IF(UTL_READINITFILE('DPW',LINE,IU,1))READ(LINE,*) DPW IF(UTL_READINITFILE('DP1',LINE,IU,1))READ(LINE,*) DP1 IF(UTL_READINITFILE('DP2',LINE,IU,1))READ(LINE,*) DP2 IF(UTL_READINITFILE('CORXCRIT',LINE,IU,1))READ(LINE,*) CORXCRIT IF(UTL_READINITFILE('NCORXCRIT',LINE,IU,1))READ(LINE,*) CORCRIT IF(UTL_READINITFILE('INTXCRIT',LINE,IU,1))READ(LINE,*) INTXCRIT IF(UTL_READINITFILE('BUFFER',LINE,IU,1))READ(LINE,*) BUFFER WRITE(*,'(A,I1)') 'IAGGREGATEY=',IAGGREGATEY WRITE(*,'(A,I1)') 'IGNORENODATA=',INTNODATA WRITE(*,'(A,I10)') 'NSCRIT=',NSCRIT WRITE(*,'(A,F10.2,A)') 'LOCCRIT=',LOCCRIT,' [unit of idf]' WRITE(*,'(A,F10.2,A)') 'XCRIT=',XCRIT,' [unit of idf]' WRITE(*,'(A,I10)') 'DPW=',DPW WRITE(*,'(A,F10.2,A)') 'DP1=',DP1,' [%]' WRITE(*,'(A,F10.2,A)') 'DP2=',DP2,' [%]' WRITE(*,'(A,F10.2,A)') 'CORXCRIT=',CORXCRIT,' [unit of idf]' WRITE(*,'(A,I10)') 'NCORXCRIT=',CORCRIT WRITE(*,'(A,F10.2,A)') 'INTXCRIT=',INTXCRIT,' [unit of idf]' WRITE(*,'(A,F10.2,A)') 'BUFFER=',BUFFER,' [size of idf]' NWINDOW=0; IWINDOW=0 IF(UTL_READINITFILE('NWINDOW',LINE,IU,1))THEN READ(LINE,*) NWINDOW; IWINDOW=1 ENDIF DO I=1,MAX(1,NWINDOW) IF(NWINDOW.GT.0)THEN IF(.NOT.UTL_READINITFILE('WINDOW'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) XMIN,YMIN,XMAX,YMAX LINE='WINDOW'//TRIM(ITOS(I))//'=' WRITE(*,'(A,4F10.2)') TRIM(LINE),XMIN,YMIN,XMAX,YMAX IF(.NOT.UTL_READINITFILE('OUTFILE'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) OUTFILE LINE='OUTFILE'//TRIM(ITOS(I))//'='//TRIM(OUTFILE) WRITE(*,'(A)') TRIM(LINE) ELSE IF(.NOT.UTL_READINITFILE('OUTFILE',LINE,IU,0))RETURN READ(LINE,*) OUTFILE LINE='OUTFILE='//TRIM(OUTFILE) WRITE(*,'(A)') TRIM(LINE) ENDIF IF(.NOT.AHNFILTER_MAIN(I))RETURN ENDDO DEALLOCATE(AHN) END SUBROUTINE IMODBATCH_AHNFILTER_MAIN !###====================================================================== SUBROUTINE IMODBATCH_GXG_MAIN() !###====================================================================== USE MOD_GXG_PAR IMPLICIT NONE INTEGER :: I,J,N IBATCH=1 GXG_RESDIR=''; GXG_MVIDFNAME='' !## read layer (optional) IF(.NOT.IMODBATCH_READPOINTER(GXG_NLAYER,GXG_ILAYER,'ILAYER',0))RETURN !## read surface name IF(UTL_READINITFILE('SURFACEIDF',LINE,IU,1))THEN READ(LINE,*) GXG_MVIDFNAME; WRITE(*,'(A)') 'SURFACEIDF='//TRIM(GXG_MVIDFNAME) ENDIF IF(.NOT.IMODBATH_READYEAR(GXG_NYEAR,GXG_IYEAR))RETURN ALLOCATE(GXG_IPERIOD(12,2)) GXG_IPERIOD=1 IF(UTL_READINITFILE('IPERIOD',LINE,IU,1))THEN READ(LINE,'(24I1)') ((GXG_IPERIOD(I,J),J=1,2),I=1,12) WRITE(*,'(24I1)') ((GXG_IPERIOD(I,J),J=1,2),I=1,12) ENDIF IF(.NOT.IMODBATCH_AREAINFO(ISEL,GXG_IDFNAME,GXG_GENFNAME))RETURN IF(.NOT.UTL_READINITFILE('NDIR',LINE,IU,0))RETURN READ(LINE,*) N; WRITE(*,'(A,I4)') 'NDIR=',N GXG_STARTMONTH=4 !## default starting month april IF(UTL_READINITFILE('STARTMONTH',LINE,IU,1))READ(LINE,*) GXG_STARTMONTH WRITE(*,'(A,I4)') 'STARTMONTH=',GXG_STARTMONTH GXG_HGLG3=0 IF(UTL_READINITFILE('HGLG3',LINE,IU,1))READ(LINE,*) GXG_HGLG3 WRITE(*,'(A,I1)') 'HGLG3=',GXG_HGLG3 DO I=1,N !## read idfname IF(.NOT.UTL_READINITFILE('SOURCEDIR'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) GXG_RESDIR; LINE='SOURCEDIR='//TRIM(ITOS(I))//'='//TRIM(GXG_RESDIR) WRITE(*,'(A)') TRIM(LINE) IF(.NOT.GXG1COMPUTEGXG())WRITE(*,'(/A/)') 'ERROR OCCURED!' END DO IF(ASSOCIATED(GXG_IPERIOD))DEALLOCATE(GXG_IPERIOD) IF(ASSOCIATED(GXG_IYEAR)) DEALLOCATE(GXG_IYEAR) IF(ASSOCIATED(GXG_ILAYER)) DEALLOCATE(GXG_ILAYER) !## clean memory CALL GXG1ABORT() END SUBROUTINE IMODBATCH_GXG_MAIN !###====================================================================== LOGICAL FUNCTION IMODBATCH_READPOINTER(NPOINTER,IPOINTER,TXT,IOPT,EXCLVALUE) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: IOPT !## ioptional INTEGER,INTENT(IN),OPTIONAL :: EXCLVALUE !## wrong value INTEGER,INTENT(OUT) :: NPOINTER INTEGER,POINTER,DIMENSION(:) :: IPOINTER CHARACTER(LEN=*),INTENT(IN) :: TXT INTEGER :: IOS,I NPOINTER=0 IF(IOPT.EQ.0)THEN IMODBATCH_READPOINTER=.FALSE. IF(.NOT.UTL_READINITFILE(TRIM(TXT),LINE,IU,0))RETURN ELSEIF(IOPT.EQ.1)THEN IMODBATCH_READPOINTER=.TRUE. IF(.NOT.UTL_READINITFILE(TRIM(TXT),LINE,IU,1))RETURN ENDIF IF(ASSOCIATED(IPOINTER))THEN NPOINTER=SIZE(IPOINTER) ELSE NPOINTER=80 ALLOCATE(IPOINTER(NPOINTER)) ENDIF DO READ(LINE,*,IOSTAT=IOS) (IPOINTER(I),I=1,NPOINTER) IF(IOS.EQ.0)EXIT NPOINTER=NPOINTER-1 ENDDO DEALLOCATE(IPOINTER) ALLOCATE(IPOINTER(NPOINTER)) READ(LINE,*,IOSTAT=IOS) (IPOINTER(I),I=1,NPOINTER) IF(IOS.NE.0)THEN WRITE(*,'(/1A/)') 'ERROR READING '//TRIM(TXT) STOP ENDIF WRITE(*,'(A,99(I2,A1))') TRIM(TXT)//'=',(IPOINTER(I),',',I=1,NPOINTER) IF(PRESENT(EXCLVALUE))THEN DO,I=1,NPOINTER IF(IPOINTER(I).EQ.EXCLVALUE)THEN DEALLOCATE(IPOINTER); RETURN ENDIF ENDDO ENDIF IMODBATCH_READPOINTER=.TRUE. END FUNCTION IMODBATCH_READPOINTER !###====================================================================== LOGICAL FUNCTION IMODBATCH_READPOINTER_REAL(NPOINTER,XPOINTER,TXT,IOPT,EXCLVALUE) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: IOPT !## ioptional REAL,INTENT(IN),OPTIONAL :: EXCLVALUE !## wrong value INTEGER,INTENT(OUT) :: NPOINTER REAL,POINTER,DIMENSION(:) :: XPOINTER CHARACTER(LEN=*),INTENT(IN) :: TXT INTEGER :: IOS,I NPOINTER=0 IF(IOPT.EQ.0)THEN IMODBATCH_READPOINTER_REAL=.FALSE. IF(.NOT.UTL_READINITFILE(TRIM(TXT),LINE,IU,0))RETURN ELSEIF(IOPT.EQ.1)THEN IMODBATCH_READPOINTER_REAL=.TRUE. IF(.NOT.UTL_READINITFILE(TRIM(TXT),LINE,IU,1))RETURN ENDIF IF(ASSOCIATED(XPOINTER))THEN NPOINTER=SIZE(XPOINTER) ELSE NPOINTER=80; ALLOCATE(XPOINTER(NPOINTER)) ENDIF DO READ(LINE,*,IOSTAT=IOS) (XPOINTER(I),I=1,NPOINTER) IF(IOS.EQ.0)EXIT NPOINTER=NPOINTER-1 ENDDO DEALLOCATE(XPOINTER); ALLOCATE(XPOINTER(NPOINTER)) READ(LINE,*,IOSTAT=IOS) (XPOINTER(I),I=1,NPOINTER) IF(IOS.NE.0)THEN WRITE(*,'(/1A/)') 'ERROR READING '//TRIM(TXT); STOP ENDIF WRITE(*,'(A,99(F10.2,A1))') TRIM(TXT)//'=',(XPOINTER(I),',',I=1,NPOINTER) IF(PRESENT(EXCLVALUE))THEN DO,I=1,NPOINTER IF(XPOINTER(I).EQ.EXCLVALUE)THEN DEALLOCATE(XPOINTER); RETURN ENDIF ENDDO ENDIF IMODBATCH_READPOINTER_REAL=.TRUE. END FUNCTION IMODBATCH_READPOINTER_REAL !###====================================================================== LOGICAL FUNCTION IMODBATH_READYEAR(NYEAR,IYEAR,SYEAR,EYEAR) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN),OPTIONAL :: SYEAR,EYEAR INTEGER,INTENT(OUT) :: NYEAR INTEGER,POINTER,DIMENSION(:) :: IYEAR INTEGER :: IOS,I,EY,SY IMODBATH_READYEAR=.FALSE. IF(.NOT.PRESENT(SYEAR))THEN !## read begin year IF(.NOT.UTL_READINITFILE('SYEAR',LINE,IU,0))RETURN LINE=ADJUSTL(LINE); READ(LINE,'(I4)') SY; WRITE(*,'(A,I4)') 'SYEAR=',SY ELSE SY=SYEAR ENDIF IF(.NOT.PRESENT(EYEAR))THEN !## read end year IF(.NOT.UTL_READINITFILE('EYEAR',LINE,IU,0))RETURN READ(LINE,*) EY; WRITE(*,'(A,I4)') 'EYEAR=',EY ELSE EY=EYEAR ENDIF !## read nyear (optional) NYEAR=EY-SY+1 ALLOCATE(IYEAR(NYEAR)) IF(UTL_READINITFILE('IYEAR',LINE,IU,1))THEN DO IYEAR=0 READ(LINE,*,IOSTAT=IOS) (IYEAR(I),I=1,NYEAR) IF(IOS.EQ.0)EXIT NYEAR=NYEAR-1 ENDDO WRITE(*,'(A,99(I4,A1))') 'IYEAR=',(IYEAR(I),',',I=1,NYEAR) ELSE NYEAR=0; DO I=SY,EY; NYEAR=NYEAR+1; IYEAR(NYEAR)=I; ENDDO ENDIF IMODBATH_READYEAR=.TRUE. END FUNCTION IMODBATH_READYEAR !###====================================================================== LOGICAL FUNCTION IMODBATH_READPERIOD(NPERIOD,IPERIOD) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(OUT) :: NPERIOD INTEGER,DIMENSION(:,:),POINTER :: IPERIOD INTEGER :: I,J,K IMODBATH_READPERIOD=.FALSE. NPERIOD=0 IF(UTL_READINITFILE('NPERIOD',LINE,IU,1))THEN READ(LINE,*) NPERIOD; WRITE(*,'(A,I4)') 'NPERIOD=',NPERIOD IF(NPERIOD.GT.0)THEN ALLOCATE(IPERIOD(NPERIOD*2,2)) K=0 DO J=1,NPERIOD IF(.NOT.UTL_READINITFILE('PERIOD'//TRIM(ITOS(J)),LINE,IU,0))RETURN I=INDEX(LINE,'-') K=K+1 READ(LINE(:I-1),'(2I2)') IPERIOD(K,1),IPERIOD(K,2) K=K+1 READ(LINE(I+1:),'(2I2)') IPERIOD(K,1),IPERIOD(K,2) LINE='PERIOD'//TRIM(ITOS(J))//'='//TRIM(ITOS(IPERIOD(K-1,1)))//'-'//TRIM(ITOS(IPERIOD(K-1,2)))//';'// & TRIM(ITOS(IPERIOD(K,1))) //'-'//TRIM(ITOS(IPERIOD(K ,2))) WRITE(*,'(A)') TRIM(LINE) END DO NPERIOD=NPERIOD*2 ELSE ALLOCATE(IPERIOD(1,2)) ENDIF ENDIF IMODBATH_READPERIOD=.TRUE. END FUNCTION IMODBATH_READPERIOD !###====================================================================== LOGICAL FUNCTION IMODBATCH_AREAINFO(ISEL,IDFNAME,GENFNAME) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(OUT) :: ISEL CHARACTER(LEN=*),INTENT(OUT) :: IDFNAME,GENFNAME IMODBATCH_AREAINFO=.FALSE. IDFNAME='' GENFNAME='' ISEL=1 IF(UTL_READINITFILE('ISEL',LINE,IU,1))THEN READ(LINE,*) ISEL IF(ISEL.EQ.2)THEN IF(.NOT.UTL_READINITFILE('GENFILE',LINE,IU,0))RETURN READ(LINE,*) GENFNAME; WRITE(*,'(A)') 'GENFILE='//TRIM(GENFNAME) ! CALL POLYGON1SAVELOADSHAPE(ID_LOADSHAPE,0,GENFNAME) ELSEIF(ISEL.EQ.3)THEN IF(.NOT.UTL_READINITFILE('IDFNAME',LINE,IU,0))RETURN READ(LINE,*) IDFNAME; WRITE(*,'(A)') 'IDFNAME='//TRIM(IDFNAME) ENDIF ENDIF WRITE(*,'(A,I4)') 'ISEL=',ISEL IMODBATCH_AREAINFO=.TRUE. END FUNCTION IMODBATCH_AREAINFO !###====================================================================== SUBROUTINE IMODBATCH_PLOT_MAIN() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: IDFLEGNAME,IPFLEGNAME,IFFLEGNAME,IDFNAME,IPFNAME,OUTNAME,IFFNAME,BMPOUTNAME CHARACTER(LEN=52) :: IDFLEGTXT,IPFLEGTXT,IFFLEGTXT CHARACTER(LEN=256),ALLOCATABLE,DIMENSION(:) :: GENNAME INTEGER :: JU,IOS,I,NFIG,RESOLUTION,IDFSTYLE,IPFSTYLE,IFFSTYLE,NLABELS,NGEN,IR,IG,IB,N,M,J,II,IEXT,II1,II2 INTEGER,DIMENSION(2) :: IPFASSFILES INTEGER,DIMENSION(4) :: IPFICOL REAL :: XMIN,YMIN,XMAX,YMAX,YFRACLEGEND,RAT,TSIZE INTEGER,DIMENSION(3) :: IP REAL,DIMENSION(:,:),ALLOCATABLE :: XY INTEGER,ALLOCATABLE,DIMENSION(:) :: ILABELS,GENCOLOUR CHARACTER(LEN=52),DIMENSION(:),ALLOCATABLE :: STRING,CLABEL CHARACTER(LEN=3) :: CSTYLE LOGICAL :: LIND IDFNAME=''; IDFLEGNAME=''; IPFNAME=''; IFFNAME='' !## read idfname (optional) IF(UTL_READINITFILE('IDFFILE',LINE,IU,1))THEN READ(LINE,*) IDFNAME; WRITE(*,'(A)') 'IDFNAME='//TRIM(IDFNAME) IP=0; IP(1)=1; IDFSTYLE=100 IF(UTL_READINITFILE('IDFSTYLE',LINE,IU,1))THEN READ(LINE,*) IDFSTYLE; WRITE(*,'(A,I3)') 'IDFSTYLE=',IDFSTYLE ENDIF WRITE(CSTYLE,'(I3.3)') IDFSTYLE READ(CSTYLE,'(3I1)') IP CALL UTL_READARRAY(IP,3,IDFSTYLE) !## read legname (optional) IF(UTL_READINITFILE('IDFLEGFILE',LINE,IU,1))THEN READ(LINE,*) IDFLEGNAME; WRITE(*,'(A)') 'IDFLEGFILE='//TRIM(IDFLEGNAME) ENDIF IDFLEGTXT='' IF(UTL_READINITFILE('IDFLEGTXT',LINE,IU,1))THEN READ(LINE,*) IDFLEGTXT; WRITE(*,'(A)') 'IDFLEGTXT='//TRIM(IDFLEGTXT) ENDIF ENDIF !## read legname (optional) TSIZE=0.05; IF(UTL_READINITFILE('LEGTSIZE',LINE,IU,1))THEN READ(LINE,*) TSIZE; WRITE(*,'(A,F10.3)') 'LEGTSIZE=',TSIZE ENDIF !## read ipfname (optional) IF(UTL_READINITFILE('IPFFILE',LINE,IU,1))THEN READ(LINE,*) IPFNAME WRITE(*,'(A)') 'IPFNAME='//TRIM(IPFNAME) IPFSTYLE=0 IF(UTL_READINITFILE('IPFSTYLE',LINE,IU,1))THEN READ(LINE,*) IPFSTYLE; WRITE(*,'(A,I1)') 'IPFSTYLE=',IPFSTYLE ENDIF IF(IPFSTYLE.LT.0.OR.IPFSTYLE.GT.1)THEN; WRITE(*,*) 'You should specify IPFSTYLE in {0,1}'; STOP; ENDIF IPFASSFILES=0; IPFASSFILES(2)=-1 IF(UTL_READINITFILE('IPFASSFILES',LINE,IU,1))THEN READ(LINE,*) IPFASSFILES(1); WRITE(*,'(A,I1)') 'IPFASSFILES=',IPFASSFILES(1) ENDIF IF(IPFASSFILES(1).LT.0.OR.IPFASSFILES(1).GT.2)THEN; WRITE(*,*) 'You should specify IPFASSFILES in {0,1,2}'; STOP; ENDIF IF(IPFASSFILES(1).GT.0)THEN IF(UTL_READINITFILE('IPFASSFILES_ALL',LINE,IU,1))THEN READ(LINE,*) IPFASSFILES(2); WRITE(*,'(A,I1)') 'IPFASSFILES_ALL=',IPFASSFILES(2) ENDIF IF(IPFASSFILES(2).LT.-1.OR.IPFASSFILES(2).GT.1)THEN; WRITE(*,*) 'You should specify IPFASSFILES_ALL in {-1,0,1}'; STOP; ENDIF ENDIF IPFICOL(1)=1; IPFICOL(2)=2; IPFICOL(3)=3; IPFICOL(4)=0 IF(UTL_READINITFILE('IPFXCOL',LINE,IU,1))READ(LINE,*) IPFICOL(1) WRITE(*,'(A,I1)') 'IPFXCOL=',IPFICOL(1) IF(UTL_READINITFILE('IPFYCOL',LINE,IU,1))READ(LINE,*) IPFICOL(2) WRITE(*,'(A,I1)') 'IPFYCOL=',IPFICOL(2) IF(UTL_READINITFILE('IPFHCOL',LINE,IU,1))READ(LINE,*) IPFICOL(4) WRITE(*,'(A,I1)') 'IPFHCOL=',IPFICOL(4) IPFLEGNAME=''; NLABELS=0 IF(IPFSTYLE.EQ.1)THEN !## read legname (optional) IF(UTL_READINITFILE('IPFLEGFILE',LINE,IU,1))THEN READ(LINE,*) IPFLEGNAME WRITE(*,'(A)') 'IPFLEGFILE='//TRIM(IPFLEGNAME) IF(.NOT.UTL_READINITFILE('IPFLCOL',LINE,IU,0))RETURN READ(LINE,*) IPFICOL(3) WRITE(*,'(A,I1)') 'IPFLCOL=',IPFICOL(3) ENDIF IPFLEGTXT='' IF(UTL_READINITFILE('IPFLEGTXT',LINE,IU,1))THEN READ(LINE,*) IPFLEGTXT; WRITE(*,'(A)') 'IPFLEGTXT='//TRIM(IPFLEGTXT) ENDIF IF(UTL_READINITFILE('NLABELS',LINE,IU,1))THEN READ(LINE,*) NLABELS; WRITE(*,'(A,I10)') 'NLABELS=',NLABELS ALLOCATE(ILABELS(NLABELS)) IF(.NOT.UTL_READINITFILE('ILABELS',LINE,IU,0))RETURN READ(LINE,*) ILABELS; WRITE(*,'(A,99I5)') 'ILABELS=',ILABELS ENDIF ENDIF ENDIF !## read iffname (optional) IF(UTL_READINITFILE('IFFFILE',LINE,IU,1))THEN IFFSTYLE=1 READ(LINE,*) IFFNAME; WRITE(*,'(A)') 'IFFNAME='//TRIM(IFFNAME) !## read legname (optional) IF(UTL_READINITFILE('IFFLEGFILE',LINE,IU,1))THEN READ(LINE,*) IFFLEGNAME; WRITE(*,'(A)') 'IFFLEGFILE='//TRIM(IFFLEGNAME) ENDIF IFFLEGTXT='' IF(UTL_READINITFILE('IFFLEGTXT',LINE,IU,1))THEN READ(LINE,*) IFFLEGTXT; WRITE(*,'(A)') 'IFFLEGTXT='//TRIM(IFFLEGTXT) ENDIF ENDIF !## read genname (optional) NGEN=0; IF(UTL_READINITFILE('NGEN',LINE,IU,1))THEN READ(LINE,*) NGEN; WRITE(*,'(A,I10)') 'NGEN=',NGEN ALLOCATE(GENNAME(NGEN),GENCOLOUR(NGEN)) DO I=1,NGEN IF(.NOT.UTL_READINITFILE('GENFILE'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) GENNAME(I) LINE='GENFILE'//TRIM(ITOS(I))//'='//TRIM(GENNAME(I)) WRITE(*,'(A)') TRIM(LINE) GENCOLOUR(I)=WRGB(0,0,0) IF(UTL_READINITFILE('GENCOLOUR'//TRIM(ITOS(I)),LINE,IU,1))THEN READ(LINE,*) IR,IG,IB; GENCOLOUR(I)=WRGB(IR,IG,IB) LINE='GENCOLOUR'//TRIM(ITOS(I))//'=('//TRIM(ITOS(IR))//','//TRIM(ITOS(IG))//','//TRIM(ITOS(IB))//') '//TRIM(ITOS(GENCOLOUR(I))) WRITE(*,'(A)') TRIM(LINE) ENDIF ENDDO ENDIF !## read top25 reference IF(UTL_READINITFILE('TOP25',LINE,IU,1))THEN READ(LINE,*) PREFVAL(2); WRITE(*,'(A)') 'TOP25'//'='//TRIM(PREFVAL(2)) ENDIF !## read outname IF(.NOT.UTL_READINITFILE('OUTFILE',LINE,IU,0))RETURN READ(LINE,*) OUTNAME WRITE(*,'(A)') 'OUTFILE='//TRIM(OUTNAME) IF(INDEX(UTL_CAP(OUTNAME,'U'),'.BMP').EQ.0.AND. & INDEX(UTL_CAP(OUTNAME,'U'),'.PCX').EQ.0.AND. & INDEX(UTL_CAP(OUTNAME,'U'),'.JPG').EQ.0.AND. & INDEX(UTL_CAP(OUTNAME,'U'),'.PNG').EQ.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot recognize file extent:'//CHAR(13)//'OUT='//TRIM(OUTNAME),'Error') RETURN ENDIF !## read LEGPLOT_PLOT (optional) FIG(1)='TITLE'; FIG(2)='SUBTITLE'; FIG(3)='FIGTXT'; FIG(4)='PRJTXT' NFIG =0 DO I=1,SIZE(FIG) IF(UTL_READINITFILE(FIG(I),LINE,IU,1))THEN READ(LINE,*,IOSTAT=IOS) FIG(I) IF(IOS.NE.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot read figure properties:'//CHAR(13)// & TRIM(FIG(I))//'='//TRIM(LINE),'Error') RETURN ENDIF NFIG=NFIG+1 ENDIF ENDDO IF(NFIG.EQ.4)THEN WRITE(*,'(A)') 'TITLE='//TRIM(FIG(1)) WRITE(*,'(A)') 'SUBTITLE='//TRIM(FIG(2)) WRITE(*,'(A)') 'FIGTXT='//TRIM(FIG(3)) WRITE(*,'(A)') 'PRJTXT='//TRIM(FIG(4)) ENDIF ! NCLEGEND=2 ! IF(UTL_READINITFILE('NCLEGEND',LINE,IU,1))THEN ! READ(LINE,*) NCLEGEND; WRITE(*,'(A,I2)') 'NCLEGEND=',NCLEGEND ! ENDIF YFRACLEGEND=100.0 IF(UTL_READINITFILE('YFRACLEGEND',LINE,IU,1))THEN READ(LINE,*) YFRACLEGEND; WRITE(*,'(A,F10.1)') 'YFRACLEGEND=',YFRACLEGEND ENDIF RESOLUTION=3200 IF(UTL_READINITFILE('RESOLUTION',LINE,IU,1))THEN READ(LINE,*) RESOLUTION; WRITE(*,'(A,I10)') 'RESOLUTION=',RESOLUTION ENDIF !## read extent (optional) XMIN=0.0; XMAX=0; YMIN=0.0; YMAX=0.0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*,IOSTAT=IOS) XMIN,YMIN,XMAX,YMAX IF(IOS.NE.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot read extent properly:'//CHAR(13)//'EXT='//TRIM(LINE),'Error') RETURN ENDIF WRITE(*,'(A,4F10.2)') 'WINDOW=',XMIN,YMIN,XMAX,YMAX ENDIF CALL WINDOWOPEN(FLAGS=SYSMENUON+HIDEWINDOW+STATUSBAR) CALL WINDOWSTATUSBARPARTS(4,(/2000,2000,750,-1/),(/1,1,1,1/)) CALL WMENU(ID_MAINMENU1,0) CALL WMENUTOOLBAR(ID_TOOLBAR1,0,1) LIND=.FALSE. IF(IPFASSFILES(1).GT.0.AND.IPFASSFILES(2).GE.0)THEN JU=UTL_GETUNIT(); CALL OSD_OPEN(JU,FILE=IPFNAME,STATUS='OLD',ACTION='READ,DENYWRITE') READ(JU,*) N; ALLOCATE(XY(N,2)); READ(JU,*) M; DO I=1,M; READ(JU,*); ENDDO; ALLOCATE(STRING(M)) READ(JU,*) IEXT; ALLOCATE(CLABEL(N)) IF(IEXT.EQ.0)THEN; WRITE(*,'(A)') 'Cannot plot associated files whenever IEXT=0'; STOP; ENDIF DO I=1,N READ(JU,*) (STRING(J),J=1,M) READ(STRING(IPFICOL(1)),*) XY(I,1); READ(STRING(IPFICOL(2)),*) XY(I,2); READ(STRING(IEXT),*) CLABEL(I) ENDDO CLOSE(JU) II1=1; II2=N; IF(IPFASSFILES(2).EQ.2)THEN; II1=IPFASSFILES(2); II2=II1; ENDIF LIND=.TRUE. ELSE II1=1; II2=1 ENDIF !## 24-bits colour application CALL IGRCOLOURMODEL(24) !## load datamanager in memory CALL MANAGERINIT() !## initialize colours CALL PREFCOLOURSINIT(.FALSE.) !## initiate lines in graphs CALL IPFANALYSE_INIT_GRAPHVARIABLES() !## remove backslash in labeling on default IBACKSLASH=1; ILABELNAME=0 ICOLOR(1)=WRGB(255,0,0) ICOLOR(2)=WRGB(0,255,0) ICOLOR(3)=WRGB(0,0,255) DO II=II1,II2 !## initialize iMOD CALL IMODINIT() IF(LIND)THEN I=INDEX(CLABEL(II),'\',.TRUE.); IF(I.NE.0)CLABEL(II)=CLABEL(II)(I+1:) BMPOUTNAME=OUTNAME(:INDEX(OUTNAME,'.',.TRUE.)-1)//'_'//TRIM(CLABEL(II)) BMPOUTNAME=TRIM(BMPOUTNAME)//TRIM(OUTNAME(INDEX(OUTNAME,'.',.TRUE.):)) FIG(2)=CLABEL(II) IPFASSFILES(2)=II XMIN=XY(II,1)-1000.0 XMAX=XY(II,1)+1000.0 YMIN=XY(II,2)-1000.0 YMAX=XY(II,2)+1000.0 WRITE(*,'(I5.5,A,I5.5,A)') II,'-',N,'Busy with '//TRIM(CLABEL(II)) WRITE(*,'(5X,A)') 'Saving: '//TRIM(BMPOUTNAME) ELSE BMPOUTNAME=OUTNAME ENDIF IF(LEN_TRIM(IDFNAME).NE.0)CALL IDFINIT(IDFNAMEGIVEN=IDFNAME,LEGNAME=IDFLEGNAME,LPLOT=.FALSE. ,ISTYLE=IDFSTYLE,LDEACTIVATE=.FALSE.) IF(LEN_TRIM(IPFNAME).NE.0)THEN IF(NLABELS.EQ.0)THEN CALL IDFINIT(IDFNAMEGIVEN=IPFNAME,LEGNAME=IPFLEGNAME,LPLOT=.FALSE.,ISTYLE=IPFSTYLE,LDEACTIVATE=.FALSE.,IPFICOL=IPFICOL,IPFASSFILES=IPFASSFILES) ELSE CALL IDFINIT(IDFNAMEGIVEN=IPFNAME,LEGNAME=IPFLEGNAME,LPLOT=.FALSE.,ISTYLE=IPFSTYLE,LDEACTIVATE=.FALSE.,IPFICOL=IPFICOL,ILABELS=ILABELS,IPFASSFILES=IPFASSFILES) ENDIF ENDIF IF(LEN_TRIM(IFFNAME).NE.0)CALL IDFINIT(IDFNAMEGIVEN=IFFNAME,LEGNAME=IFFLEGNAME,LPLOT=.FALSE.,ISTYLE=IFFSTYLE,LDEACTIVATE=.FALSE.) DO I=1,NGEN; CALL TOPOGENINIT(GENNAME=GENNAME(I),LPLOT=.FALSE.,LDEACTIVATE=.FALSE.,GENCOLOUR=GENCOLOUR(I)); ENDDO IF(XMAX-XMIN.EQ.0.0)THEN CALL IDFZOOM(ID_ZOOMFULLMAP,0.0,0.0,0) ELSE !## set zoom level (all) MPW%XMIN=XMIN MPW%YMIN=YMIN MPW%XMAX=XMAX MPW%YMAX=YMAX ENDIF IF(NFIG.EQ.4)THEN !## bitmap size ... screensize --- vierkant MPW%DIX=RESOLUTION !1600 MPW%DIY=RESOLUTION !1600 ELSE RAT=(MPW%XMAX-MPW%XMIN)/(MPW%YMAX-MPW%YMIN) IF(RAT.GE.1)THEN MPW%DIX=RESOLUTION !1600 MPW%DIY=MPW%DIX/RAT ELSE MPW%DIY=3200 !1600 MPW%DIX=MPW%DIY*RAT ENDIF ENDIF CALL WMENUSETSTATE(ID_SHOWSCALEBAR,2,0) CALL WMENUSETSTATE(ID_HIGHACCURACY,2,0) CALL WMENUSETSTATE(ID_EXCELLENTACCURACY,2,1) IF(PREFVAL(2).NE.'')CALL WMENUSETSTATE(ID_TOPOGRAPHY,2,1) CALL IDFPLOT(1) CALL WCLIPBOARDPUTBITMAP(MPW%IBITMAP) !## finished with drawing CALL WINDOWCLOSECHILD(MPW%IWIN) !## create drawing IF(NFIG.EQ.4)CALL IMODBATH_PLOTFIG(TSIZE,YFRACLEGEND,(/IDFLEGTXT,IPFLEGTXT,IFFLEGTXT/)) CALL UTL_CREATEDIR(OUTNAME(1:INDEX(OUTNAME,'\',.TRUE.)-1)) CALL WBITMAPSAVE(MPW%IBITMAP,BMPOUTNAME) CALL WINDOWCLOSECHILD(MPW%IWIN) CALL WBITMAPDESTROY(MPW%IBITMAP) ENDDO IF(ALLOCATED(XY))DEALLOCATE(XY) IF(ALLOCATED(STRING))DEALLOCATE(STRING) IF(ALLOCATED(CLABEL))DEALLOCATE(CLABEL) END SUBROUTINE IMODBATCH_PLOT_MAIN !###====================================================================== SUBROUTINE IMODBATH_PLOTFIG(TSIZE,YFRACLEGEND,LEGTXT) !###====================================================================== IMPLICIT NONE REAL,INTENT(IN) :: TSIZE,YFRACLEGEND CHARACTER(LEN=*),DIMENSION(:),INTENT(IN) :: LEGTXT INTEGER :: IBITMAP,I !,ILOGO !,IH,IW REAL :: XP,YP,ACC,GR,LT,LB,LB1,X1,X2,Y1,Y2,BH,BND,PB,FB,TBND,DB,AB,DL INTEGER :: IHR,IMT,IS,MS,IY,IM,ID,N CHARACTER(LEN=50) :: STRING BND =5.0 !## witte rand XP =420.0 !## paper width YP =297.0 !## paper heigth GR =YP !## graph area right BH =YP-40.0 !## title bot area LT =YP-75.0 !## legend top aera LB =65.0 !## legend bot aera AB =45.0 !## axes bot area PB =19.0 !## project FB =15.0 !## figure number DB =10.0 !## date TBND=BND+BND !MPW%DX ACC=5.0 !## create 'mother' bitmap for current coordinates CALL WBITMAPCREATE(IBITMAP,INT(XP*ACC),INT(YP*ACC)) CALL IGRSELECT(DRAWBITMAP,IBITMAP) CALL IGRPLOTMODE(MODECOPY) CALL IGRAREA(0.0,0.0,1.0,1.0) CALL IGRUNITS(0.0,0.0,XP,YP) CALL IGRCOLOURN(WRGB(235,235,235)) !## legend area CALL IGRFILLPATTERN(SOLID) CALL IGRRECTANGLE(GR,AB,XP-BND,LT) CALL IGRCOLOURN(WRGB(123,152,168)) CALL IGRRECTANGLE(GR,LT,XP-BND,YP-BND) !## top CALL IGRCOLOURN(WRGB(0,102,161)) CALL IGRRECTANGLE(GR,0.0+BND,XP-BND,AB) !## below CALL IGRCOLOURN(WRGB(255,255,255)) CALL IGRRECTANGLE(0.0+BND,0.0+BND,GR-BND,YP-BND) !## main window Y1=0.03333 X1=Y1/(0.03333/0.01333) !## header/title CALL WGRTEXTFONT(FFHELVETICA,WIDTH=X1,HEIGHT=Y1,ISTYLE=FSBOLD) CALL WGRTEXTORIENTATION(IALIGN=ALIGNLEFT) CALL IGRCOLOURN(WRGB(0,0,0)) CALL WGRTEXTBLOCK(GR+BND,BH,XP-TBND,YP-TBND,TRIM(FIG(1)),1.0) !,TBFONTSIZE) !+TBJUSTIFY) !## sub-header CALL WGRTEXTFONT(FFHELVETICA,WIDTH=X1/2.0,HEIGHT=Y1/2.0,ISTYLE=0) !FSBOLD) CALL WGRTEXTBLOCK(GR+BND,LT+0.5*TBND,XP-TBND,BH-TBND,TRIM(FIG(2)),1.0)!,TBFONTSIZE) !+TBJUSTIFY) !## projectlabel CALL WGRTEXTFONT(FFHELVETICA,WIDTH=X1/2.0,HEIGHT=Y1/2.0,ISTYLE=FSITALIC) CALL WGRTEXTBLOCK(GR+BND,PB,XP-TBND,AB-2.5,'Project: '//CHAR(13)//TRIM(FIG(4)),1.0) !,TBFONTSIZE)!+TBJUSTIFY) !## figure CALL WGRTEXTSTRING(GR+BND,FB,'Figure/report: '//TRIM(FIG(3)))!,1.0)!,TBFONTSIZE)!+TBJUSTIFY) !## date CALL IOSTIME(IHR,IMT,IS,MS) CALL IOSDATE(IY,IM,ID) CALL WDATETOSTRING(STRING,IY,IM,ID,DATELONGMONTH+DATENOLEADZERO,'-') STRING=TRIM(STRING)//' '//TRIM(ITOS(IHR))//':'//TRIM(ITOS(IMT))//':'//TRIM(ITOS(IS)) CALL WGRTEXTSTRING(GR+BND,DB,'Creation Date/time: '//TRIM(STRING))!,1.0)!,TBFONTSIZE)!+TBJUSTIFY) CALL WGRTEXTORIENTATION(IALIGN=ALIGNRIGHT,ANGLE=0.0) CALL WGRTEXTFONT(FFHELVETICA,WIDTH=X1/3.0,HEIGHT=Y1/3.0,ISTYLE=0) CALL WGRTEXTSTRING(XP-BND,0.0+0.5*BND,'Powered by '//TRIM(UTL_IMODVERSION())//' Copyright © 2005-2013') CALL IMODBATH_PLOTFIG_DIM(MPW%IBITMAP,X1,X2,Y1,Y2,GR,YP) Y1=Y1+BND Y2=Y2-BND X1=X1+BND X2=X2-BND CALL IGRAREA(X1/XP,Y1/YP,X2/XP,Y2/YP) CALL WBITMAPPUT(MPW%IBITMAP,2,1) CALL IGRFILLPATTERN(OUTLINE) CALL IGRCOLOURN(WRGB(0,0,0)) CALL IGRLINEWIDTH(1) CALL IGRAREA(0.0,0.0,1.0,1.0) CALL IGRRECTANGLE(0.0,0.0,XP,YP) N=0; DO I=1,MXMPLOT; IF(.NOT.MP(I)%IACT)CYCLE; N=N+1; ENDDO DL =(YFRACLEGEND/REAL(N))/100.0*(LT-LB) LB1=LT-DL DO I=1,MXMPLOT IF(.NOT.MP(I)%IACT)CYCLE IF(MP(I)%IPLOT.EQ.1)MP(I)%LEG%HEDTXT=LEGTXT(1) !## idf IF(MP(I)%IPLOT.EQ.2)MP(I)%LEG%HEDTXT=LEGTXT(2) !## ipf IF(MP(I)%IPLOT.EQ.3)MP(I)%LEG%HEDTXT=LEGTXT(3) !## iff ENDDO !## plot legend DO I=1,MXMPLOT IF(.NOT.MP(I)%IACT)CYCLE X1=GR+BND Y1=LB1+BND X2=XP-BND-BND Y2=LT-BND CALL IGRAREA(X1/XP,Y1/YP,X2/XP,Y2/YP) CALL IGRUNITS(0.0,0.0,1.0,1.0) !yfraclegend/100.0) !1.0) CALL LEGPLOT_PLOT(MP(I)%LEG,1,TSIZE=TSIZE) !## plot legend for iplot=1, nc=2 columns LT=LT-DL LB1=LB1-DL ENDDO !!## put deltares logo !CALL WBITMAPGETRESOURCE(ILOGO,ID_ICONTNO) !CALL IMODBATH_PLOTFIG_DIM(ILOGO,X1,X2,Y1,Y2,20.0,20.0) !X1=X1+GR !X2=X2+GR !Y1=Y1+BND !Y2=Y2+BND !CALL IGRAREA(X1/XP,Y1/YP,X2/XP,Y2/YP) !CALL WBITMAPPUT(ILOGO,2,1) CALL IGRAREA(GR/XP,AB/YP,XP/XP,LB/YP) X1=MPW%XMIN+(GR/GR)*(MPW%XMAX-MPW%XMIN) Y1=MPW%YMIN+(AB/YP)*(MPW%YMAX-MPW%YMIN) X2=MPW%XMIN+(XP/GR)*(MPW%XMAX-MPW%XMIN) Y2=MPW%YMIN+(LB/YP)*(MPW%YMAX-MPW%YMIN) CALL IGRUNITS(X1,Y1,X2,Y2) CALL IDFPLOT_FEATURES_SCALE() ! CALL WBITMAPDESTROY(MPW%IBITMAP) MPW%IBITMAP=IBITMAP END SUBROUTINE IMODBATH_PLOTFIG !###====================================================================== SUBROUTINE IMODBATH_PLOTFIG_DIM(IBITMAP,X1,X2,Y1,Y2,XW,XH) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: IBITMAP REAL,INTENT(IN) :: XW,XH REAL,INTENT(OUT) :: X1,X2,Y1,Y2 INTEGER :: IW,IH REAL :: RAT !## put bitmap IW=WINFOBITMAP(IBITMAP,BITMAPWIDTH) IH=WINFOBITMAP(IBITMAP,BITMAPHEIGHT) RAT=REAL(IW)/REAL(IH) IF(RAT.GT.1.0)THEN Y1=(XH-(XH/RAT))/2.0; Y2= Y1+XH/RAT; X1=0.0; X2=XW ELSEIF(RAT.LT.1.0)THEN X1=(XW-(XW*RAT))/2.0; X2= X1+XW*RAT; Y1=0.0; Y2=XH ELSE X1=0.0; Y1=0.0; X2=XW; Y2=XH ENDIF END SUBROUTINE IMODBATH_PLOTFIG_DIM !###====================================================================== SUBROUTINE IMODBATCH_FLUMY() !###====================================================================== USE MOD_BATCH_FLUMY IMPLICIT NONE INTEGER :: I,NPAR CHARACTER(LEN=256) :: IPFFNAME XOFFSET=0.0 YOFFSET=0.0 ZOFFSET=0.0 IF(.NOT.UTL_READINITFILE('IPFFILE',LINE,IU,0))RETURN READ(LINE,*) IPFFNAME; WRITE(*,'(A)') 'IPFFILE='//TRIM(IPFFNAME) IF(.NOT.UTL_READINITFILE('NPARAM',LINE,IU,0))RETURN READ(LINE,*) NPAR; WRITE(*,'(A,I3)') 'NPARAM=',NPAR IF(UTL_READINITFILE('ZOFFSET',LINE,IU,1))THEN READ(LINE,*) ZOFFSET; WRITE(*,'(A,F3.2)') 'ZOFFSET=',ZOFFSET ENDIF IF(UTL_READINITFILE('XOFFSET',LINE,IU,1))THEN READ(LINE,*) XOFFSET; WRITE(*,'(A,F3.2)') 'XOFFSET=',XOFFSET ENDIF IF(UTL_READINITFILE('YOFFSET',LINE,IU,1))THEN READ(LINE,*) YOFFSET; WRITE(*,'(A,F3.2)') 'YOFFSET=',YOFFSET ENDIF !## store flumy codes ALLOCATE(FLM(NPAR)) DO I=1,NPAR IF(.NOT.UTL_READINITFILE('GRAIN'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) FLM(I)%GRAIN; FLM(I)%GRAIN=UTL_CAP(FLM(I)%GRAIN,'U') LINE='GRAIN'//TRIM(ITOS(I))//'='//TRIM(FLM(I)%GRAIN); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('FACIESL'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,'(A)') FLM(I)%FACL; FLM(I)%FACL=UTL_CAP(FLM(I)%FACL,'U') LINE='FACIESL'//TRIM(ITOS(I))//'='//TRIM(FLM(I)%FACL); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('FACIESN'//TRIM(ITOS(I)),LINE,IU,0))RETURN READ(LINE,*) FLM(I)%FACN LINE='FACIESN'//TRIM(ITOS(I))//'='//TRIM(ITOS(FLM(I)%FACN)); WRITE(*,'(A)') TRIM(LINE) ENDDO CALL FLUMY_MAIN(IPFFNAME) DEALLOCATE(FLM) END SUBROUTINE IMODBATCH_FLUMY !###====================================================================== SUBROUTINE IMODBATCH_GEOCONNECT() !###====================================================================== USE MOD_GEOCONNECT USE MOD_GEOCONNECT_PAR IMPLICIT NONE IF(.NOT.UTL_READINITFILE('IFLAG',LINE,IU,0))RETURN READ(LINE,*) GC_IFLAG; WRITE(*,'(A,I1)') 'IFLAG=',GC_IFLAG IF(GC_IFLAG.EQ.1)THEN ! IF(GC_INIT_IDENTIFY(IU)) ELSEIF(GC_IFLAG.EQ.2)THEN IF(.NOT.GC_INIT_PREPROCESSING_READ(IU,1))RETURN ELSEIF(GC_IFLAG.EQ.3)THEN IF(.NOT.GC_INIT_POSTPROCESSING_READ(IU,1))RETURN ENDIF CALL GC_COMPUTE_MAIN(1) !## clean memory CALL GC_DEALLOCATE() END SUBROUTINE IMODBATCH_GEOCONNECT !###====================================================================== SUBROUTINE IMODBATCH_PLOTRESIDUAL() !###====================================================================== USE MOD_RESIDUALPLOT, ONLY : RESIDUAL_MAIN USE MOD_RESIDUALPLOT_PAR IMPLICIT NONE INTEGER,DIMENSION(6) :: ICOL IPLOT=1; ITRANSIENT=0; NLAYER=0; NIPFS=0; NRDATE=0; IWEIGHT=0; ICOL=0 IF(.NOT.UTL_READINITFILE('INPUTFILE',LINE,IU,0))RETURN READ(LINE,*) INPUTFILE; WRITE(*,'(A)') 'INPUTFILE='//TRIM(INPUTFILE) IF(.NOT.UTL_READINITFILE('ITRANSIENT',LINE,IU,0))RETURN READ(LINE,*) ITRANSIENT; WRITE(*,'(A,I1)') 'ITRANSIENT=',ITRANSIENT IF(INDEX(UTL_CAP(INPUTFILE,'U'),'IPF'))THEN ICOL(1)=1; IF(UTL_READINITFILE('IXCOL',LINE,IU,1))READ(LINE,*) ICOL(1) WRITE(*,'(A,I1)') 'IXCOL=',ICOL(1) ICOL(2)=2; IF(UTL_READINITFILE('IYCOL',LINE,IU,1))READ(LINE,*) ICOL(2) WRITE(*,'(A,I1)') 'IYCOL=',ICOL(2) !## read only whenever steady-state ICOL(3)=1; IF(UTL_READINITFILE('IMCOL',LINE,IU,1))READ(LINE,*) ICOL(3) WRITE(*,'(A,I1)') 'IMCOL=',ICOL(3) ICOL(4)=1; IF(UTL_READINITFILE('IHCOL',LINE,IU,1))READ(LINE,*) ICOL(4) WRITE(*,'(A,I1)') 'IHCOL=',ICOL(4) ICOL(5)=1; IF(UTL_READINITFILE('IWCOL',LINE,IU,1))READ(LINE,*) ICOL(5) WRITE(*,'(A,I1)') 'IWCOL=',ICOL(5) ICOL(6)=1; IF(UTL_READINITFILE('ILCOL',LINE,IU,1))READ(LINE,*) ICOL(6) WRITE(*,'(A,I1)') 'ILCOL=',ICOL(6) ENDIF IF(.NOT.UTL_READINITFILE('IPLOT',LINE,IU,0))RETURN READ(LINE,*) IPLOT; WRITE(*,'(A,I1)') 'IPLOT=',IPLOT IF(.NOT.UTL_READINITFILE('BMPNAME',LINE,IU,0))RETURN READ(LINE,*) BMPNAME; WRITE(*,'(A)') 'BMPNAME='//TRIM(BMPNAME) IF(.NOT.IMODBATCH_READPOINTER(NLAYER,ILAYER,'ILAYER',1))RETURN IF(.NOT.IMODBATCH_READPOINTER(NIPFS,IIPFS,'IIPF',1))RETURN IF(.NOT.IMODBATCH_READPOINTER(NRDATE,IRDATE,'IDATE',1))RETURN IF(UTL_READINITFILE('IWEIGHT',LINE,IU,1))READ(LINE,*) IWEIGHT WRITE(*,'(A,I1)') 'IWEIGHT=',IWEIGHT !## call residual-main routine CALL RESIDUAL_MAIN(ICOL) END SUBROUTINE IMODBATCH_PLOTRESIDUAL END MODULE MOD_BATCH