!! Copyright (C) Stichting Deltares, 2005-2023. !! !! 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 #if(defined(DEFPARALLEL)) USE OMP_LIB #endif USE WINTERACTER USE INTERPRETER USE RESOURCE USE MOD_DBL USE DATEVAR USE MOD_BATCH_PAR USE MOD_IDFPLOT USE MOD_OSD, ONLY : OSD_GETARG,OSD_GETNARG,OSD_OPEN USE MOD_UTL,ONLY : UTL_CAP,UTL_GETUNIT,UTL_READINITFILE,VTOS,UTL_IDATETOJDATE,UTL_DIRINFO,UTL_CREATEDIR, & UTL_SUBST,UTL_DIRINFO_POINTER,UTL_IDFGETDATE,UTL_FIT_REGRESSION,UTL_IDFSNAPTOGRID,UTL_READARRAY,UTL_DIST_3D, & UTL_GETUNIQUE,UTL_GETIDPROC,UTL_WSELECTFILE,PROCOBJ,UTL_JDATETOGDATE,NV,NL,UTL_GENLABELSREAD,UTL_IMODVERSION, & UTL_IDATETOGDATE,VAR,UTL_IDFSNAPTOGRID_LLC,UTL_EQUALS_REAL,UTL_IMODFILLMENU,UTL_READPOINTER,UTL_READPOINTER, & UTL_MINTHICKNESS,UTL_GETHELP,UTL_STDEF,UTL_GETGAMMA USE MODPLOT, ONLY : MPW,MP,MXMPLOT USE IMODVAR, ONLY : DP_KIND,SP_KIND,IBACKSLASH,ILABELNAME,EXENAME,LBETA USE MOD_PREF, ONLY : PREFCOLOURSINIT USE MOD_PREF_PAR, ONLY : PREFVAL USE MOD_IDF, ONLY : IDFREAD,IDFNULLIFY,IDFWRITE,IDFDEALLOCATE,IDFREADSCALE,IDFCOPY,IDFGETXYVAL,IDFIROWICOL, & IDFGETLOC,IDFGETVAL,IDFEQUAL,IDF_EXTENT,IDFALLOCATEX,IDFDEALLOCATEX,IDFFILLSXSY USE MOD_LEGEND, ONLY : LEG_INIT USE MOD_MANAGER_UTL USE MOD_LEGPLOT, ONLY : LEGPLOT_PLOT USE IMODVAR, ONLY : DP_KIND,SP_KIND,BVERSION USE MOD_POLYGON_PAR USE MOD_POLYGON_UTL, ONLY : POLYGON1INIT,POLYGON1CLOSE USE MOD_COLOURS USE MOD_SOBEK, ONLY : SOBEK1CALC,DFLOWFM1CALC USE MOD_IPF, ONLY : IPFSAMPLE,IPFDEALLOCATE,IPFREAD2,IPFSPOTIFY,IPFASSIGNWELL,IPFEVALUATE,IPFCOPY USE MOD_PLINES_TRACE, ONLY : TRACEMAIN,TRACEPOSTPROCESSING,TRACECONVERTTOGEN,TRACEDEALLOCATE,TRACE_INIT_SP,TRACE_AL_SP,TRACE_BRING_IN_DATA USE MOD_PLINES_PAR, ONLY : SPFNAME,NSPFNAME,SP,ISPFNAME USE MOD_PLINES_SP, ONLY : TRACEPREPARESP,TRACEREADSP USE MOD_TSTAT, ONLY : TSTATRESIDUAL USE MOD_GENPLOT, ONLY : GEN_INIT USE MOD_GXG_CLC, ONLY : GXG1_COMPUTEGXG,GXG1_ABORT,GXG_COMPUTE_SERIE USE MOD_ASC2IDF USE MOD_INFO, ONLY : INFOSTAT USE MOD_AHNFILTER, ONLY : AHNFILTER_MAIN USE MOD_MATH_CALC, ONLY : MATH1CALC ,MATH1CALCCLOSE,MATH1_PWTCOUNT,MATH1GETFUNC 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,IMPORT_MF2005_MAIN USE MOD_MODEL, ONLY : MODEL1COPYRUNFILE USE MOD_WBAL_CLC, ONLY : WBALCOMPUTE,WBALABORT USE MOD_WBAL_ANALYSE, ONLY : WBAL_ANALYSE_INIT,WBAL_ANALYSE_PLOT USE MOD_WBAL_UTL, ONLY : WBAL_ANALYSE_READCONFIG USE MOD_ISG_ADJ, ONLY : ISGADJUSTAPPLY USE MOD_ISG_GRID, ONLY : ISG_SIMPLIFYMAIN,ISG_ADDCROSSSECTION,ISG2GRIDMAIN,ISG_ADDSTAGES,ISG_EXPORT,ISG_IMPORT 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_TS_CLC, ONLY : TS1COMPUTE,TS_END USE MOD_SOLID, ONLY : SOLID_NEWMASKS,SOLID_CALC_KDC,SOLID_CALC_KDC_DEALLOCATE,SOLID_INITSLDPOINTER,SOLID_INITSLD, & 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,CREATEIZONE_LITHOS 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,PMANAGER_UTL_INIT,PMANAGER_SAVEMF2005_HFB_GENFILES,PMANAGER_LOADPRJ, & PMANAGER_GETFNAMES,PMANAGER_SEP_RUNS,PMANAGER_UTL_IPESTTOPARAM_CALC,PMANAGER_SAVEPRJ,PMANAGER_STRESSES,PMANAGER_SYSTEMS USE MOD_PMANAGER_UTL, ONLY : PMANAGER_SAVEMF2005_MOD_READ,PMANAGER_GETNFILES,PMANAGER_INIT_SIMAREA,PMANAGER_DEALLOCATE USE MOD_PMANAGER_PAR, ONLY : TOPICS,PBMAN,PEST,PRJILIST,FNAMES,TBND,TSHD,TTOP,TBOT,TKHV,TKVA,TKDW,TKVV,TVCW,TWEL,TRIV,TDRN,TRCH,TGHB,TEVT,TISG,TOLF,TCHD,TANI,TSTO,TSPY, & FILESOBJ,STRESSOBJ,THFB USE MOD_BATCH_UTL, ONLY : IMODBATCH_RUNFILE_READ,IMODBATCH_CREATEENSEMBLES_CHOLESKY USE MOD_PMANAGER_MF6NETWORK, ONLY : PMANAGER_GENERATEMFNETWORKS,PMANAGER_GENERATEMFNETWORKS_WRITEXY USE MOD_IPFANALYSE, ONLY : IPFANALYSE_INIT_GRAPHVARIABLES USE MOD_DEVWEL, ONLY : DEVWELL_IMPORT USE MOD_STOMP_PAR USE MOD_STOMP, ONLY : STOMP_INIT,STOMP_READ,STOMP_CLOSE,STOMP_SAVEINPUT USE MOD_MAIN USE MOD_IPFASSFILE, ONLY : IPFOPENASSFILE,IPFREADASSFILELABEL,IPFREADASSFILE,IPFDRAWITOPIC2_ICLR, & IPFINITASSFILE USE MOD_IPFASSFILE_UTL USE MOD_IPF_PAR, ONLY : ASSF,IPF,NIPF USE MOD_IPF, ONLY : IPFINIT,IPFREAD,IPFDEALLOCATE,IPFALLOCATE,IPFWRITE USE MOD_IFF_PAR USE MOD_MSPNETRCH, ONLY : MSPNETRCHCOMPUTE USE MOD_AGGREGATE USE MOD_LUDCMP, ONLY : LUDCMP_GETLU,UTL_FIT_POLYNOMIAL,NORMAL_CDF USE MOD_PKS, ONLY : PKS_INIT USE MOD_TOPO, ONLY : TOPO1LOADBMP USE MOD_GEN2GEN_PUZZLE, ONLY : PUZZLE_SIMPLEMAIN USE MOD_IPEST_GLM, ONLY : IPEST_LUBACKSUB_DBL,IPEST_LUDECOMP_DBL,IPEST_GLM_READ_LSTFILE USE MOD_AI, ONLY : MOD_NN_MAIN INTEGER,PARAMETER,PRIVATE :: MAXFUNC=111 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 CHARACTER(LEN=256),PRIVATE,DIMENSION(4) :: FIG TYPE PARAMOBJ INTEGER :: ILS,IZONE,IGROUP,IPARAM,IACT REAL(KIND=DP_KIND) :: PMIN,PINI,PMAX CHARACTER(LEN=15) :: ACRONYM CHARACTER(LEN=2) :: PTYPE END TYPE PARAMOBJ DATA CFUNC/'PLOT','GXG','AHNFILTER','IDFSCALE','IDFCALC','IDFMERGE','CREATEIDF','IMPORTMODFLOW',& 'IDFSTAT','IPFSTAT','MODELCOPY','IMODPATH','IPFSAMPLE','XYZTOIDF','IMPORTSOBEK','MKWELLIPF', & 'IDFMEAN','WBALANCE','ISGADJUST','DINO2IPF','CREATELAYERS','IDFTIMESERIE','BMPTILING','IPFRESIDUAL', & 'SOLID','GEN2ISG','IDFINSERT','CREATESOF','ISGSIMPLIFY','ISGADDCROSSSECTION','CREATEASC', & 'RESAMPLELAYERS','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','DEVWELLTOIPF', & 'CREATEVOXELIDF','MFTOIMOD','KDC','IMODTOSTOMP','XYZTOVOXEL','REGRESSION','MF6TOIDF','ISGIMPORT', & 'FOSM','IPFEDIT','MSPNETRCH','MF6NETWORKS','CREATEPILOTPOINTS','IPFEDITWEIGHT','AGGREGATE', & 'CREATEWELBORELOG','CREATEENSEMBLES','IPFEVALUATE','LAYERFROMTHICKNESS','MODPATH7','IPESTTOPARAM', & 'IFFCROSSSECTION','COMPUTEKDC','IDFMATH','CURVEFITTING','RELATE_OBS_AND_C','MERGEPLOT','ASSIGNLAYER', & 'GENPUZZLE','ICNVTOIDF','CLUSTER','IPFLUMP','TOTBDGVOLUME','AI','IDFTOIPF','WORKFLOW','PRJTOMF6', & 'RESIDUAL_TO_TEX','RES_RESISTANCE','ADJOINT_ZONES','SCALE_ELEVATION','FLUXCHECK','SALT_INTERFACE'/ !,'IPESTSUBM'/ CHARACTER(LEN=2),DIMENSION(6) :: OPER=['<>','<=','>=','=','<','>'] TYPE OPOBJ INTEGER,POINTER,DIMENSION(:) :: COPERATIONS REAL(KIND=DP_KIND),POINTER,DIMENSION(:) :: CNUMBER,CPDATA INTEGER :: N END TYPE OPOBJ TYPE(OPOBJ),ALLOCATABLE,DIMENSION(:,:) :: OP CONTAINS !###====================================================================== LOGICAL FUNCTION IMODBATCH() !###====================================================================== IMPLICIT NONE INTEGER :: IERROR,I,IOS,JU INTEGER,DIMENSION(:),ALLOCATABLE :: ITMP1,ITMP2 CHARACTER(LEN=256) :: FNAME LOGICAL :: LEX IMODBATCH=.FALSE. IF(.NOT.IMODBATCH_FUNC())RETURN !## get username and status and initialise window CALL WINDOWOPEN(FLAGS=SYSMENUON+HIDEWINDOW+STATUSBAR) ALLOCATE(ITMP1(4),ITMP2(4)); ITMP1=[2000,2000,750,-1]; ITMP2=[1,1,1,1] CALL WINDOWSTATUSBARPARTS(4,ITMP1,ITMP2) !(/2000,2000,750,-1/),(/1,1,1,1/)) DEALLOCATE(ITMP1,ITMP2) 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') !## initialize preferences user FOR IMOD Batch only PREFVAL=''; CALL IOSDIRNAME(PREFVAL(1)); PREFVAL(1)=TRIM(PREFVAL(1))//'\IMOD_TMP' !## create user folder I=0; DO I=I+1; INQUIRE(DIRECTORY=TRIM(PREFVAL(1))//'\BATCH'//TRIM(VTOS(I)),EXIST=LEX) IF(LEX)THEN !## try to open file - in that case folder can be re-used FNAME=TRIM(PREFVAL(1))//'\BATCH'//TRIM(VTOS(I))//'\TMP.TMP' JU=UTL_GETUNIT(); OPEN(JU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE',IOSTAT=IOS) IF(IOS.EQ.0)THEN !## try to open tmp.tmp file next CLOSE(JU); LEX=.FALSE. ELSE IF(I.GT.100)THEN WRITE(*,'(/A)') 'iMOD found > 100 iMOD Batch functions folder, please clean up:' WRITE(*,'(2X,A/)') TRIM(PREFVAL(1)) ENDIF ENDIF ENDIF IF(.NOT.LEX)THEN CALL UTL_CREATEDIR(TRIM(PREFVAL(1))//'\BATCH'//TRIM(VTOS(I))) !## try to open file FNAME=TRIM(PREFVAL(1))//'\BATCH'//TRIM(VTOS(I))//'\TMP.TMP' JU=UTL_GETUNIT(); OPEN(JU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE',IOSTAT=IOS) IF(IOS.EQ.0)THEN CALL UTL_CREATEDIR(TRIM(PREFVAL(1))//'\BATCH'//TRIM(VTOS(I))//'\tmp') EXIT ENDIF ENDIF ENDDO PREFVAL(1)=TRIM(PREFVAL(1))//'\BATCH'//TRIM(VTOS(I)) WRITE(*,'(/A)') 'iMODBATCH using tmp-folder:'; WRITE(*,'(2X,A/)') TRIM(PREFVAL(1)) CALL UTL_SETTHREADS() !## initialize polygons MAXSHAPES=500 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 IF(IMODBATCH_IPFSAMPLE_MAIN())THEN; ENDIF 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)!## createlayers CALL IMODBATCH_CREATELAYERS_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)!## create ASC file from IDF CALL IMODBATCH_CREATEASC_MAIN() CASE (32)!## resample layers CALL IMODBATCH_RESAMPLELAYERS() 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) !## gridding isg-files 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() CASE (68) !## convert csv to ipf for deviated wells CALL IMODBATCH_DEVWELLTOIPF() CASE (69) CALL IMODBATCH_ADJUSTVOXELIDF() CASE (70) CALL IMODBATCH_MFTOIMOD() CASE (71) CALL IMODBATCH_KDC() CASE (72) CALL IMODTOSTOMP() CASE (73) CALL IMODBATCH_XYZTOVOXEL() CASE (74) CALL IMODBATCH_REGRESSIONTXT() CASE (75) CALL IMODBATCH_MF6TOIDF() CASE (76) CALL IMODBATCH_ISGIMPORT() CASE (77) CALL IMODBATCH_FOSM() CASE (78) CALL IMODBATCH_IPFEDIT() CASE (79) !## Calculate net recharge based on MetaSwap modelresults CALL IMODBATCH_MSPNETRCH() CASE (80) !## generate networks for MF6 CALL IMODBATCH_MF6NETWORKS() CASE (81) !## create a set of pilot points CALL IMODBATH_CREATEPILOTPOINTS() CASE (82) !## adjust weight value in ipf-file based on pointer grid and given factor CALL IMODBATCH_IPFEDITWEIGHT() CASE (83) !## aggregate CALL IMODBATCH_AGGREGATE() CASE (84) !## createwelborelog CALL IMODBATCH_CREATEWELBORELOG() CASE (85) !## ensembles CALL IMODBATCH_CREATEENSEMBLES() CASE (86) !## evaluate timeseries if measurements are placed in correct modellayer CALL IMODBATCH_IPFEVALUATE() CASE (87) !## construct layers from thicknesses CALL IMODBATCH_LAYERFROMTHICKNESS() CASE (88)!## imodpath7 CALL IMODBATCH_IMODPATH7_MAIN() CASE (89)!## ipesttoparam CALL IMODBATCH_IPESTTOPARAM() CASE (90)!## iffcrosssection CALL IMODBATCH_IFFCROSSSECTION() CASE (91) CALL IMODBATCH_COMPUTEKDC() CASE (92) CALL IMODBATCH_MATH_MAIN() CASE (93) CALL IMODBATCH_CURVEFITTING() CASE (94) CALL IMODBATCH_RELATE_OBS_AND_C() CASE (95) CALL IMODBATCH_MERGEPLOT() CASE (96) CALL IMODBATCH_ASSIGNLAYER() CASE (97) CALL IMODBATCH_GENPUZZLE() CASE (98) CALL IMODBATCH_ICNVTOIDF() CASE (99) CALL IMODBATCH_CLUSTER() ! CALL IMODBATCH_IPESTSUBM() CASE (100) CALL IMODBATCH_IPFLUMP() CASE (101) CALL IMODBATCH_TOTBDGVOLUME() CASE (102) CALL IMODBATCH_AI() CASE (103) CALL IMODBATCH_IDFTOIPF() CASE (104) CALL IMODBATCH_WORKFLOW() CASE (105) CALL IMODBATCH_PRJTOMF6() CASE (106) CALL IMODBATCH_RESIDUAL_TO_TEX() CASE (107) CALL IMODBATCH_RES_RESISTANCE() CASE (108) CALL IMODBATCH_ADJOINT_ZONES() CASE (109) CALL IMODBATCH_SCALE_ELEVATION() CASE (110) CALL IMODBATCH_FLUX_CHECK() CASE (111) CALL IMODBATCH_SALT_INTERFACE() END SELECT IF(IU.GT.0)CLOSE(IU); IF(JU.GT.0)CLOSE(JU) CALL POLYGON1CLOSE() !## remove tmp-folder IF(.NOT.UTL_DEL1TREE(TRIM(PREFVAL(1)),IQUESTION=0))THEN WRITE(*,'(/A)') 'iMOD cannot remove tmp-folder:'; WRITE(*,'(2X,A/)') TRIM(PREFVAL(1)) ELSE WRITE(*,'(/A)') 'iMOD removed tmp-folder:'; WRITE(*,'(2X,A/)') TRIM(PREFVAL(1)) ENDIF 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_RESIDUAL_TO_TEX() !###=========================== IMPLICIT NONE CHARACTER(LEN=256) :: OUTFILE,DIR,FNAME,OUTIPF CHARACTER(LEN=52) :: COLOR CHARACTER(LEN=52),DIMENSION(:,:),ALLOCATABLE :: STRING INTEGER :: I,J,JJ,K,N,NCOL,IEXT,JU,MU,NIPF,NCYCLE,IOS,JLAY,IL,NLAYER,ILAY INTEGER,DIMENSION(:),ALLOCATABLE :: KU,NROW,ICYCLE,ILABEL INTEGER,DIMENSION(:),POINTER :: LAYER=>NULL() REAL(KIND=DP_KIND) :: X1,X2,Y1,Y2,WEIGHT,EFF,DHH,ERROR REAL(KIND=DP_KIND),DIMENSION(:),ALLOCATABLE :: MEASURE,COMPUTED REAL(KIND=DP_KIND),DIMENSION(:,:),ALLOCATABLE :: TDIFF LOGICAL :: LEX,LFOUND CHARACTER(LEN=256),ALLOCATABLE,DIMENSION(:,:) :: LABELS,XLABELS,YLABELS CHARACTER(LEN=256),ALLOCATABLE,DIMENSION(:) :: IPF IF(.NOT.UTL_READINITFILE('NIPF',LINE,IU,0))RETURN READ(LINE,*) NIPF; WRITE(*,'(A)') 'NIPF='//TRIM(VTOS(NIPF)) IF(.NOT.UTL_READINITFILE('NCYCLE',LINE,IU,0))RETURN READ(LINE,*) NCYCLE; WRITE(*,'(A)') 'NCYCLE='//TRIM(VTOS(NCYCLE)) ALLOCATE(IPF(NIPF),KU(NIPF),NROW(NIPF),ILABEL(NIPF),STRING(NCYCLE,11),MEASURE(NCYCLE),COMPUTED(NCYCLE)) DO I=1,NIPF IF(.NOT.UTL_READINITFILE('IPF'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,'(A)') IPF(I); WRITE(*,'(A)') 'IPF'//TRIM(VTOS(I))//'='//TRIM(IPF(I)) ENDDO IF(.NOT.UTL_READINITFILE('ERROR',LINE,IU,0))RETURN READ(LINE,*) ERROR; WRITE(*,'(A)') 'ERROR='//TRIM(VTOS(ERROR,'F',3)) IF(.NOT.UTL_READPOINTER(IU,NLAYER,LAYER,'LAYER',0))RETURN ALLOCATE(ICYCLE(NCYCLE),TDIFF(NCYCLE,3)); ICYCLE=0 DO I=1,NCYCLE IF(.NOT.UTL_READINITFILE('CYCLE'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) ICYCLE(I); WRITE(*,'(A)') 'CYCLE'//TRIM(VTOS(I))//'='//TRIM(VTOS(ICYCLE(I))) ENDDO IF(.NOT.UTL_READINITFILE('RESULTDIR',LINE,IU,0))RETURN READ(LINE,'(A)') DIR; WRITE(*,'(A)') 'RESULTDIR='//TRIM(DIR) IF(.NOT.UTL_READINITFILE('OUTFILE',LINE,IU,0))RETURN READ(LINE,'(A)') OUTFILE; WRITE(*,'(A)') 'OUTFILE='//TRIM(OUTFILE) CALL UTL_CREATEDIR(OUTFILE(1:INDEX(OUTFILE,'\',.TRUE.)-1)) IF(.NOT.UTL_READINITFILE('OUTIPF',LINE,IU,0))RETURN READ(LINE,'(A)') OUTIPF; WRITE(*,'(A)') 'OUTIPF='//TRIM(OUTIPF) JU=UTL_GETUNIT(); OPEN(JU,FILE=OUTFILE,STATUS='REPLACE',ACTION='WRITE') MU=UTL_GETUNIT(); OPEN(MU,FILE=TRIM(OUTIPF)//'_',STATUS='REPLACE',ACTION='WRITE') WRITE(MU,'(A)') 'NaN1#' WRITE(MU,'(A)') TRIM(VTOS(6+NCYCLE*2)) WRITE(MU,'(A)') 'X' WRITE(MU,'(A)') 'Y' WRITE(MU,'(A)') 'LAAG' WRITE(MU,'(A)') 'ID' WRITE(MU,'(A)') 'WEGING' WRITE(MU,'(A)') 'METING' DO I=1,NCYCLE WRITE(MU,'(A)') 'BEREKEND_CYCLE'//TRIM(VTOS(ICYCLE(I))) WRITE(MU,'(A)') 'VERSCHIL_CYCLE'//TRIM(VTOS(ICYCLE(I))) ENDDO WRITE(MU,'(A)') 'VERBETERING(%)' WRITE(MU,'(A)') '0,TXT' WRITE(JU,'(A)') '\documentclass[biblatex]{deltares_memo}' WRITE(JU,'(A)') '\usepackage{pdflscape}' WRITE(JU,'(A)') '\usepackage{xcolor}' WRITE(JU,'(A)') '\begin{document}' WRITE(JU,'(A)') '\memoTo{to whom it may concern}' WRITE(JU,'(A)') '\memoConfidentialUntil{}' WRITE(JU,'(A)') '\memoDate{\today~\currenttime}' WRITE(JU,'(A)') '\memoVersion{001}' WRITE(JU,'(A)') '\memoFrom{Peter Vermeulen}' WRITE(JU,'(A)') '\memoTelephone{+31\,(0)6\,3054\,8234}' WRITE(JU,'(A)') '\memoEmail{peter.vermeulen@deltares.nl}' WRITE(JU,'(A)') '\memoSubject{Kalibratie Resultaten}' WRITE(JU,'(A)') '\memoCopy{}' WRITE(JU,'(A)') '\deltarestitle' WRITE(JU,'(A)') '%------------------------------------------------------------------------------' WRITE(JU,'(A)') '% Text body' WRITE(JU,'(A)') '\begin{landscape}' WRITE(JU,'(A)') '\section{Kalibratie Resultaten}' !## open observations DO I=1,NIPF FNAME=IPF(I); KU(I)=UTL_GETUNIT(); OPEN(KU(I),FILE=FNAME,STATUS='OLD',ACTION='READ') ENDDO NROW=0; DO I=1,NIPF; READ(KU(I),*) NROW(I); ENDDO IF(ALLOCATED(LABELS))DEALLOCATE(LABELS,XLABELS,YLABELS) ALLOCATE(LABELS(NIPF,MAXVAL(NROW)),XLABELS(NIPF,MAXVAL(NROW)),YLABELS(NIPF,MAXVAL(NROW))); LABELS='NaN'; XLABELS='NaN'; YLABELS='NaN' DO I=1,NIPF READ(KU(I),*) NCOL DO J=1,NCOL; READ(KU(I),*); ENDDO READ(KU(I),*) IEXT DO J=1,NROW(I) READ(KU(I),*) (STRING(1,K),K=1,NCOL) IF(IEXT.EQ.0)THEN LABELS(I,J) =STRING(1,3) ELSE LABELS(I,J) =STRING(1,IEXT) ENDIF XLABELS(I,J)=STRING(1,1) YLABELS(I,J)=STRING(1,2) ENDDO CLOSE(KU(I)) ENDDO DEALLOCATE(KU); ALLOCATE(KU(NCYCLE)); KU=0 DO ILAY=1,NLAYER DO I=1,NCYCLE FNAME=TRIM(DIR)//'\LOG_PEST_RESIDUAL_'//TRIM(VTOS(ICYCLE(I)))//'.TXT' INQUIRE(FILE=FNAME,EXIST=LEX) IF(.NOT.LEX)WRITE(*,'(A)') '>>> cannot find '//TRIM(FNAME)//' <<<' KU(I)=UTL_GETUNIT(); OPEN(KU(I),FILE=FNAME,STATUS='OLD',ACTION='READ') ENDDO WRITE(JU,'(A)') '\subsection{Residuen Laag'//TRIM(VTOS(LAYER(ILAY)))//'}' WRITE(JU,'(99A)') ' \begin{longtable}{| r r r l r | r ',('r r ',I=1,NCYCLE),' | r |}' WRITE(JU,'(99A)') ' \caption{Berekende Stijghoogte verschillen voor laag '//TRIM(VTOS(LAYER(ILAY)))//'; cycle ',(TRIM(VTOS(ICYCLE(I)))//',',I=1,NCYCLE),'\textbf{acceptable fout is '//TRIM(VTOS(ERROR,'F',3))//'} meter.}\label{tbl:optimization} \\ \hline' WRITE(JU,'(A)') ' & & & & & \multicolumn{'//TRIM(VTOS(1+NCYCLE*2))//'}{c}{meters} & \% \\ ' !%\cline{2-'//TRIM(VTOS())//' }' WRITE(JU,'(99A)') ' X &Y &Laag &ID &Weging &Gemeten ',('&Berekend &Verschil ',I=1,NCYCLE),' & Verbetering \\ \hline\hline' WRITE(JU,'(A)') '\endfirsthead' WRITE(JU,'(A)') '\multicolumn{'//TRIM(VTOS(6+NCYCLE*2))//'}{c}{-- continued from previous page} \\' WRITE(JU,'(A)') ' & & & & & \multicolumn{'//TRIM(VTOS(1+NCYCLE*2))//'}{c}{meters} & \% \\ '!%\cline{2-6}' WRITE(JU,'(99A)') ' X &Y &Laag &ID &Weging &Gemeten ',('&Berekend &Verschil ',I=1,NCYCLE),' & Verbetering \\ \hline\hline' WRITE(JU,'(A)') '\endhead' !## read files DO I=1,NCYCLE DO J=1,NIPF+1 READ(KU(I),'(A)',IOSTAT=IOS) LINE ENDDO ENDDO N=0; ILABEL=0; TDIFF=0.0D0 DO DO I=1,NCYCLE READ(KU(I),*,IOSTAT=IOS) (STRING(I,JJ),JJ=1,11); IF(IOS.NE.0)EXIT READ(STRING(I,3),*) JLAY READ(STRING(I,4),*) MEASURE(I) READ(STRING(I,5),*) COMPUTED(I) READ(STRING(I,9),*) WEIGHT READ(STRING(I,1),*) X1 READ(STRING(I,2),*) Y1 ENDDO IF(IOS.NE.0)EXIT IF(JLAY.NE.LAYER(ILAY))CYCLE DO I=1,NCYCLE IF(.NOT.MEASURE(I).EQ.MEASURE(1))THEN WRITE(*,'(A)') '>>> SOMETHING GOES WRONG AS MEASURE(I).NE.MEASURE(1) <<<'; PAUSE; STOP ENDIF ENDDO N=N+1 !## search for correct label - restart if needed LFOUND=.FALSE. DO IL=1,2 DO I=1,NIPF DO ILABEL(I)=ILABEL(I)+1 IF(ILABEL(I).GT.NROW(I))EXIT READ(XLABELS(I,ILABEL(I)),*) X2 READ(YLABELS(I,ILABEL(I)),*) Y2 IF(X1.EQ.X2.AND.Y1.EQ.Y2)THEN LFOUND=.TRUE.; EXIT ENDIF ENDDO !## replace with id number of filter IF(LFOUND)EXIT ENDDO !## found, exit IF(LFOUND)EXIT !## reset all ILABEL=0 ENDDO !## not in this model IF(.NOT.LFOUND)CYCLE STRING(1,11)=LABELS(I,ILABEL(I)) DO IF(INDEX(STRING(1,11),'_').EQ.0)EXIT CALL UTL_SUBST(STRING(1,11),'_','-') ENDDO DO I=1,NCYCLE DHH=(COMPUTED(I)-MEASURE(1)) DHH=DHH-ERROR TDIFF(I,1)=TDIFF(I,1)+WEIGHT*DHH**2.0D0 TDIFF(I,2)=TDIFF(I,2)+DHH TDIFF(I,3)=TDIFF(I,3)+ABS(DHH) ENDDO EFF=1.0D0-((COMPUTED(2)-MEASURE(1))/(COMPUTED(1)-MEASURE(1))) EFF=EFF*100.D0 IF(EFF.GT.0.0)THEN COLOR='green' ELSE COLOR='red' ENDIF WRITE(MU,'(99A)') TRIM(STRING(1,1)),','//TRIM(STRING(1,2)),','//TRIM(STRING(1,3)),','//TRIM(STRING(1,11)),','//TRIM(VTOS(WEIGHT,'F',3))//','//TRIM(VTOS(MEASURE(1),'F',3)), & (','//TRIM(VTOS(COMPUTED(I),'F',3)),','//TRIM(VTOS(COMPUTED(I)-MEASURE(1),'F',3)),I=1,NCYCLE),',',TRIM(VTOS(EFF,'F',3)) WRITE(JU,'(99A)') TRIM(STRING(1,1)),' & '//TRIM(STRING(1,2)),'& '//TRIM(STRING(1,3)),' & '//TRIM(STRING(1,11)),'& '//TRIM(VTOS(WEIGHT,'F',3))//' & '//TRIM(VTOS(MEASURE(1),'F',3)), & (' & '//TRIM(VTOS(COMPUTED(I),'F',3)),' & '//TRIM(VTOS(COMPUTED(I)-MEASURE(1),'F',3)),I=1,NCYCLE),' & \colorbox{'//TRIM(COLOR)//'}{'//TRIM(VTOS(EFF,'F',3))//'} \\' ENDDO DO I=1,NCYCLE; CLOSE(KU(I)); ENDDO WRITE(JU,'(A)') ' \hline' DO I=1,NCYCLE TDIFF(I,2)=TDIFF(I,2)/REAL(N,8) TDIFF(I,3)=TDIFF(I,3)/REAL(N,8) ENDDO WRITE(JU,'(99A)') '\multicolumn{5}{l}{Gemiddelde (m)} & ',(' & & '//TRIM(VTOS(TDIFF(I,2),'F',3)),I=1,NCYCLE),' & \\ \hline' WRITE(JU,'(99A)') '\multicolumn{5}{l}{Abs.Gemiddelde (m)} & ',(' & & '//TRIM(VTOS(TDIFF(I,3),'F',3)),I=1,NCYCLE),' & \\ \hline' WRITE(JU,'(99A)') '\multicolumn{5}{l}{Doelfunctie (m2)} & ',(' & & '//TRIM(VTOS(TDIFF(I,1),'F',3)),I=1,NCYCLE),' & \\ \hline' ! WRITE(JU,'(A)') '\end{tabular}' WRITE(JU,'(A)') ' \end{longtable}' ENDDO WRITE(JU,'(A)') '\end{landscape}' WRITE(JU,'(A)') '%------------------------------------------------------------------------------' WRITE(JU,'(A)') '\end{document}' CLOSE(JU) CLOSE(MU) CALL UTL_MF2005_MAXNO(TRIM(OUTIPF)//'_',(/N/)) END SUBROUTINE IMODBATCH_RESIDUAL_TO_TEX !###====================================================================== 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(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: XTOP REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: XOFFSET INTEGER,ALLOCATABLE,DIMENSION(:) :: ITOP TYPE POCKETOBJ INTEGER :: SIZE INTEGER :: COUNT REAL(KIND=DP_KIND) :: 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(VTOS(NXOFFSET)); WRITE(*,'(A)') TRIM(LINE) ALLOCATE(XOFFSET(NXOFFSET)) DO I=1,NXOFFSET IF(.NOT.UTL_READINITFILE('XOFFSET'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) XOFFSET(I); LINE='XOFFSET'//TRIM(VTOS(I))//'='//TRIM(VTOS(XOFFSET(I),'F',7)); WRITE(*,'(A)') TRIM(LINE) ENDDO IF(.NOT.UTL_READINITFILE('NPOCKETS',LINE,IU,0))RETURN READ(LINE,*) NPOCKETS; LINE='NPOCKETS='//TRIM(VTOS(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(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) POCKET(I,1)%SIZE; LINE='POCKET'//TRIM(VTOS(I))//'='//TRIM(VTOS(POCKET(I,1)%SIZE)); WRITE(*,'(A)') TRIM(LINE) ENDDO ! IF(.NOT.UTL_READINITFILE('XOFFSET',LINE,IU,0))RETURN ! READ(LINE,*) XOFFSET; LINE='XOFFSET='//TRIM(VTOS(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='REPLACE',ACTION='WRITE') ALLOCATE(XTOP(SIZE(LISTNAME)),ITOP(SIZE(LISTNAME))); XTOP=10.0D10; 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 ITOP(I)=I ! initialize CLOSE(IDF%IU) ENDDO CALL UTL_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.3)') 'ipocket','size',(XOFFSET(I)*86400.0D0,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.3)') 'ipocket','size',(XOFFSET(I)*86400.0D0,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.3)') 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(KIND=DP_KIND),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='REPLACE',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.0D0; 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.0D0)J=2 XSUM(J)=XSUM(J)+IDF%X(ICOL,IROW) ENDIF ENDDO; ENDDO WRITE(*,'(2I10,A,3F15.3)') I,SIZE(LISTNAME),TRIM(LISTNAME(I)(INDEX(LISTNAME(I),'\',.TRUE.)+1:)),XSUM(1),XSUM(2),SUM(XSUM) WRITE(JU,'(A,3F15.3)') 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_SALT_INTERFACE() !###====================================================================== IMPLICIT NONE TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: SALT TYPE(IDFOBJ) :: IDF INTEGER :: IROW,ICOL,NLAY,ILAY REAL(KIND=DP_KIND) :: T,B,C1,C2,DC,Z1,Z2,DZ,CONC,F REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: Z,C IF(UTL_READINITFILE('NLAY',LINE,IU,1))READ(LINE,*) NLAY WRITE(*,'(A)') 'NLAY='//TRIM(VTOS(NLAY)) ALLOCATE(SALT(NLAY)); DO I=1,SIZE(SALT); CALL IDFNULLIFY(SALT(I)); ENDDO DO ILAY=1,NLAY IF(.NOT.UTL_READINITFILE('CONC_L'//TRIM(VTOS(ILAY)),LINE,IU,0))RETURN READ(LINE,'(A)') SALT(ILAY)%FNAME; WRITE(*,'(A)') 'CONC_L'//TRIM(VTOS(ILAY))//'='//TRIM(SALT(ILAY)%FNAME) IF(.NOT.IDFREAD(SALT(ILAY),SALT(ILAY)%FNAME,1))THEN WRITE(*,'(/A/)') '>>> CANNOT READ '//TRIM(SALT(ILAY)%FNAME)//' <<<' ENDIF ENDDO IF(.NOT.UTL_READINITFILE('INTERFACE',LINE,IU,0))RETURN READ(LINE,'(A)') IDF%FNAME; WRITE(*,'(A)') 'INTERFACE='//TRIM(IDF%FNAME) CALL IDFNULLIFY(IDF); CALL IDFCOPY(SALT(1),IDF) IF(.NOT.UTL_READINITFILE('CONCENTRATION',LINE,IU,0))RETURN READ(LINE,*) CONC; WRITE(*,'(A)') 'CONCENTRATION='//TRIM(VTOS(CONC,'F',2)) ! !## Ghyben-Herzberg ! R=DENSITY_FRESH/(DENSITY_SALT-DENSITY_FRESH) ALLOCATE(Z(NLAY),C(NLAY)); Z=0.0D0 DO ILAY=1,NLAY T=SALT(ILAY)%TOP; B=SALT(ILAY)%BOT; Z(ILAY)=(T+B)/2.0D0 ENDDO IDF%X=IDF%NODATA DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL C=0.0D0; DO ILAY=1,NLAY IF(SALT(ILAY)%X(ICOL,IROW).NE.SALT(ILAY)%NODATA)C(ILAY)=SALT(ILAY)%X(ICOL,IROW) ENDDO DO ILAY=1,NLAY-1 IF(CONC.GE.C(ILAY).AND.CONC.LE.C(ILAY+1))THEN Z1=Z(ILAY); Z2=Z(ILAY+1) C1=C(ILAY); C2=C(ILAY+1) DC=C2-C1 ; DZ=Z2-Z1 F=(CONC-C1)/DC IDF%X(ICOL,IROW)=Z1+F*DZ EXIT ENDIF ENDDO ENDDO; ENDDO IF(.NOT.IDFWRITE(IDF,IDF%FNAME,1))THEN WRITE(*,'(/A/)') '>>> CANNOT WRITE '//TRIM(IDF%FNAME)//' <<<' ENDIF END SUBROUTINE IMODBATCH_SALT_INTERFACE !###====================================================================== SUBROUTINE IMODBATCH_TOTBDGVOLUME() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: CDATE,DIRNAME,OUTPUTIDF INTEGER :: I,J,K,ILAY,IROW,ICOL,IOS TYPE BALOBJ CHARACTER(LEN=256) :: BDGNAME INTEGER,POINTER,DIMENSION(:) :: ISYS=>NULL() LOGICAL,POINTER,DIMENSION(:) :: LEX=>NULL() INTEGER :: NSYS TYPE(IDFOBJ),POINTER,DIMENSION(:) :: BDG END TYPE BALOBJ INTEGER,POINTER,DIMENSION(:) :: ILAYER=>NULL() TYPE(BALOBJ),DIMENSION(:),ALLOCATABLE :: BAL INTEGER :: NBAL,NLAYER REAL(KIND=DP_KIND),DIMENSION(2) :: Q REAL(KIND=DP_KIND) :: XM,XP INTEGER(KIND=DP_KIND) :: IDATE CHARACTER(LEN=1),DIMENSION(2) :: MINPLUS=['-','+'] TYPE(IDFOBJ) :: IDF TYPE(IDFOBJ),DIMENSION(2) :: VOL !## get number of files to be imported IF(.NOT.UTL_READINITFILE('SOURCEDIR',LINE,IU,0))RETURN READ(LINE,*) DIRNAME; WRITE(*,'(A)') 'SOURCEDIR='//TRIM(DIRNAME) DO I=1,SIZE(VOL); CALL IDFNULLIFY(VOL(I)); ENDDO CALL IDFNULLIFY(IDF); IDF%XMIN=0.0D0; IDF%YMIN=0.0D0; IDF%XMAX=0.0D0; IDF%YMAX=0.0D0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX WRITE(*,'(A,4F15.3)') 'WINDOW=',IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,0))RETURN READ(LINE,*) IDF%DX; WRITE(*,'(A,F10.3)') 'CELLSIZE=',IDF%DX; IDF%DY=IDF%DX CALL UTL_IDFSNAPTOGRID_LLC(IDF%XMIN,IDF%XMAX,IDF%YMIN,IDF%YMAX,IDF%DX,IDF%DY,IDF%NCOL,IDF%NROW,LLC=.TRUE.) ENDIF 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(BAL(NBAL)) DO I=1,NBAL IF(.NOT.UTL_READINITFILE('BAL'//TRIM(VTOS(I)),LINE,IU,0))RETURN !## make them capitals READ(LINE,*) BAL(I)%BDGNAME; BAL(I)%BDGNAME=UTL_CAP(BAL(I)%BDGNAME,'U') LINE='BAL'//TRIM(VTOS(I))//'='//TRIM(BAL(I)%BDGNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READPOINTER(IU,BAL(I)%NSYS,BAL(I)%ISYS,'BAL'//TRIM(VTOS(I))//'ISYS',1))RETURN IF(BAL(I)%NSYS.GT.0)THEN LINE='- systems' DO K=1,BAL(I)%NSYS; LINE=TRIM(LINE)//', '//TRIM(VTOS(BAL(I)%ISYS(K))); ENDDO; WRITE(*,'(A)') TRIM(LINE) ENDIF IF(TRIM(BAL(I)%BDGNAME).EQ.'BDGFLF')BAL(I)%NSYS=2 ALLOCATE(BAL(I)%BDG(MAX(1,BAL(I)%NSYS))) ALLOCATE(BAL(I)%LEX(MAX(1,BAL(I)%NSYS))) DO K=1,MAX(1,BAL(I)%NSYS) CALL IDFNULLIFY(BAL(I)%BDG(K)) ENDDO ENDDO !## read start date (optional) CDATE='STEADY-STATE' IF(UTL_READINITFILE('CDATE',LINE,IU,1))THEN READ(LINE,*,IOSTAT=IOS) IDATE IF(IOS.EQ.0)THEN WRITE(CDATE,*) IDATE; CDATE=ADJUSTL(CDATE) ELSE CDATE=TRIM(LINE) ENDIF WRITE(*,'(A)') '>>> COMPUTING VOLUMES FOR '//TRIM(CDATE)//' <<<' ENDIF IF(.NOT.UTL_READPOINTER(IU,NLAYER,ILAYER,'LAYER',0))RETURN !## make sure layers are not defined multiple times DO I=1,NLAYER N=0; J=ILAYER(I) DO K=1,NLAYER IF(ILAYER(K).EQ.J)N=N+1 ENDDO IF(N.GT.1)THEN WRITE(*,'(/1X,A,I3,A)') 'Layer ',J,' defined more than once'; STOP ENDIF ENDDO IF(.NOT.UTL_READINITFILE('OUTPUTIDF',LINE,IU,0))RETURN READ(LINE,*) OUTPUTIDF; WRITE(*,'(A)') 'OUTPUTIDF'//'='//TRIM(OUTPUTIDF) DO ILAY=1,NLAYER DO J=1,NBAL DO K=1,MAX(1,BAL(J)%NSYS) IF(TRIM(BAL(J)%BDGNAME).EQ.'BDGFLF')THEN IF(K.EQ.1)IDF%FNAME=TRIM(DIRNAME)//'\'//TRIM(BAL(J)%BDGNAME)//'\'//TRIM(BAL(J)%BDGNAME)//'_'//TRIM(CDATE)//'_L'//TRIM(VTOS(ILAYER(ILAY )))//'.IDF' IF(K.EQ.2)IDF%FNAME=TRIM(DIRNAME)//'\'//TRIM(BAL(J)%BDGNAME)//'\'//TRIM(BAL(J)%BDGNAME)//'_'//TRIM(CDATE)//'_L'//TRIM(VTOS(ILAYER(ILAY)-1))//'.IDF' ELSE !## read first idf IF(BAL(J)%NSYS.EQ.0)THEN IDF%FNAME=TRIM(DIRNAME)//'\'//TRIM(BAL(J)%BDGNAME)//'\'//TRIM(BAL(J)%BDGNAME)//'_'//TRIM(CDATE)//'_L'//TRIM(VTOS(ILAYER(ILAY)))//'.IDF' ELSE IDF%FNAME=TRIM(DIRNAME)//'\'//TRIM(BAL(J)%BDGNAME)//'\'//TRIM(BAL(J)%BDGNAME)//'_SYS'//TRIM(VTOS(K))//'_'//TRIM(CDATE)//'_L'//TRIM(VTOS(ILAYER(ILAY)))//'.IDF' ENDIF ENDIF !## skip if not exists (often for first and last) INQUIRE(FILE=IDF%FNAME,EXIST=BAL(J)%LEX(K)); IF(.NOT.BAL(J)%LEX(K))CYCLE IF(ILAY.EQ.1.AND.J.EQ.1)THEN IF(.NOT.IDFREAD(IDF,IDF%FNAME,1))THEN; WRITE(*,'(A)') 'Cannot read '//TRIM(IDF%FNAME); STOP; ENDIF CALL IDFCOPY(IDF,BAL(J)%BDG(K)); CALL IDFCOPY(IDF,VOL(1)); CALL IDFCOPY(IDF,VOL(2)) ELSE CALL IDFCOPY(IDF,BAL(J)%BDG(K)) !## sampling IF(.NOT.IDFREADSCALE(IDF%FNAME,BAL(J)%BDG(K),10,1,0.0D0,0))THEN; WRITE(*,'(/A/)') 'CANNOT READ DATA FOR '//TRIM(IDF%FNAME); STOP; ENDIF ENDIF ENDDO ENDDO DO K=1,SIZE(VOL); VOL(K)%X=0.0D0; ENDDO DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL XM=0.0D0; XP=0.0D0 DO J=1,NBAL DO I=1,MAX(1,BAL(J)%NSYS) !## does not exists IF(.NOT.BAL(J)%LEX(I))CYCLE Q=0.0D0 SELECT CASE (TRIM(BAL(J)%BDGNAME)) CASE ('BDGFRF') IF(BAL(J)%BDG(I)%X(ICOL,IROW).NE.BAL(J)%BDG(I)%NODATA) Q(1)= BAL(J)%BDG(I)%X(ICOL ,IROW) IF(ICOL.GT.1)THEN IF(BAL(J)%BDG(I)%X(ICOL-1,IROW).NE.BAL(J)%BDG(I)%NODATA)Q(2)=-1.0D0*BAL(J)%BDG(I)%X(ICOL-1,IROW) ENDIF CASE ('BDGFFF') IF(BAL(J)%BDG(I)%X(ICOL,IROW).NE.BAL(J)%BDG(I)%NODATA) Q(1)= BAL(J)%BDG(I)%X(ICOL,IROW ) IF(IROW.GT.1)THEN IF(BAL(J)%BDG(I)%X(ICOL,IROW-1).NE.BAL(J)%BDG(I)%NODATA)Q(2)=-1.0D0*BAL(J)%BDG(I)%X(ICOL,IROW-1) ENDIF CASE ('BDGFLF') IF(I.EQ.1)THEN IF(BAL(J)%BDG(I)%X(ICOL,IROW).NE.BAL(J)%BDG(I)%NODATA) Q(1)= BAL(J)%BDG(I)%X(ICOL,IROW) ELSEIF(I.EQ.2)THEN IF(ILAYER(ILAY).GT.1)THEN IF(BAL(J)%BDG(I)%X(ICOL,IROW).NE.BAL(J)%BDG(I)%NODATA)Q(2)=-1.0D0*BAL(J)%BDG(I)%X(ICOL,IROW) ENDIF ENDIF CASE DEFAULT IF(BAL(J)%BDG(I)%X(ICOL,IROW).NE.BAL(J)%BDG(I)%NODATA)Q(1)=BAL(J)%BDG(I)%X(ICOL,IROW) END SELECT DO K=1,SIZE(Q) IF(Q(K).LT.0.0D0)XM=XM+Q(K) IF(Q(K).GT.0.0D0)XP=XP+Q(K) ENDDO ENDDO ENDDO VOL(1)%X(ICOL,IROW)=XM VOL(2)%X(ICOL,IROW)=XP ENDDO; ENDDO DO K=1,2 IF(INDEX(OUTPUTIDF,'.IDF').EQ.0)THEN VOL(K)%FNAME=TRIM(OUTPUTIDF)//'_'//TRIM(CDATE)//'_L'//TRIM(VTOS(ILAYER(ILAY)))//MINPLUS(K)//'.IDF' ELSE VOL(K)%FNAME=OUTPUTIDF(:INDEX(OUTPUTIDF,'.',.TRUE.)-1)//MINPLUS(K)//'.IDF' ENDIF IF(.NOT.IDFWRITE(VOL(K),VOL(K)%FNAME,1))THEN; WRITE(*,'(/A/)') '>>> Cannot write '//TRIM(VOL(K)%FNAME)//' <<<'; STOP; ENDIF ENDDO DO J=1,NBAL; DO K=1,MAX(1,BAL(J)%NSYS); CALL IDFDEALLOCATEX(BAL(J)%BDG(K)); ENDDO; ENDDO ENDDO END SUBROUTINE IMODBATCH_TOTBDGVOLUME !###====================================================================== SUBROUTINE IMODBATCH_AI() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: OUTPUTCSV INTEGER :: NINPUT,NOUTPUT,I,IROW,ICOL,JU,INODE,NODES,NSAMPLE INTEGER,ALLOCATABLE,DIMENSION(:) :: N,M REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: X,Y TYPE IOOBJ TYPE(IDFOBJ) :: IDF CHARACTER(LEN=52) :: ALIAS END TYPE IOOBJ TYPE(IOOBJ),ALLOCATABLE,DIMENSION(:) :: INPUT,OUTPUT TYPE(IDFOBJ) :: IDF IF(.NOT.UTL_READINITFILE('OUTPUTCSV',LINE,IU,0))RETURN READ(LINE,*) OUTPUTCSV; WRITE(*,'(A)') 'OUTPUTCSV='//TRIM(OUTPUTCSV) CALL UTL_CREATEDIR(OUTPUTCSV(:INDEX(OUTPUTCSV,'\',.TRUE.)-1)) JU=UTL_GETUNIT(); OPEN(JU,FILE=OUTPUTCSV,STATUS='REPLACE',ACTION='WRITE') !## get number of files to be imported IF(.NOT.UTL_READINITFILE('NINPUT',LINE,IU,0))RETURN READ(LINE,*) NINPUT; WRITE(*,'(A)') 'NINPUT='//TRIM(VTOS(NINPUT)) ALLOCATE(INPUT(NINPUT)); DO I=1,NINPUT; CALL IDFNULLIFY(INPUT(I)%IDF); ENDDO DO I=1,NINPUT IF(.NOT.UTL_READINITFILE('INPUT'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) INPUT(I)%IDF%FNAME; WRITE(*,'(A)') 'INPUT'//TRIM(VTOS(I))//'='//TRIM(INPUT(I)%IDF%FNAME) IF(UTL_READINITFILE('INLABEL'//TRIM(VTOS(I)),LINE,IU,1))THEN READ(LINE,*) INPUT(I)%ALIAS ELSE INPUT(I)%ALIAS=TRIM(INPUT(I)%IDF%FNAME(INDEX(INPUT(I)%IDF%FNAME,'\',.TRUE.)+1:)) ENDIF WRITE(*,'(A)') 'INLABEL'//TRIM(VTOS(I))//'='//TRIM(INPUT(I)%ALIAS) ENDDO IF(.NOT.UTL_READINITFILE('NOUTPUT',LINE,IU,0))RETURN READ(LINE,*) NOUTPUT; WRITE(*,'(A)') 'NOUTPUT='//TRIM(VTOS(NOUTPUT)) ALLOCATE(OUTPUT(NOUTPUT)); DO I=1,NOUTPUT; CALL IDFNULLIFY(OUTPUT(I)%IDF); ENDDO DO I=1,NOUTPUT IF(.NOT.UTL_READINITFILE('OUTPUT'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) OUTPUT(I)%IDF%FNAME; WRITE(*,'(A)') 'OUTPUT'//TRIM(VTOS(I))//'='//TRIM(OUTPUT(I)%IDF%FNAME) IF(UTL_READINITFILE('OUTLABEL'//TRIM(VTOS(I)),LINE,IU,1))THEN READ(LINE,*) OUTPUT(I)%ALIAS ELSE OUTPUT(I)%ALIAS=TRIM(OUTPUT(I)%IDF%FNAME(INDEX(OUTPUT(I)%IDF%FNAME,'\',.TRUE.)+1:)) ENDIF WRITE(*,'(A)') 'OUTLABEL'//TRIM(VTOS(I))//'='//TRIM(OUTPUT(I)%ALIAS) ENDDO CALL IDFNULLIFY(IDF); IDF%XMIN=0.0D0; IDF%YMIN=0.0D0; IDF%XMAX=0.0D0; IDF%YMAX=0.0D0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX WRITE(*,'(A,4F15.3)') 'WINDOW=',IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,0))RETURN READ(LINE,*) IDF%DX; WRITE(*,'(A,F10.3)') 'CELLSIZE=',IDF%DX; IDF%DY=IDF%DX CALL UTL_IDFSNAPTOGRID_LLC(IDF%XMIN,IDF%XMAX,IDF%YMIN,IDF%YMAX,IDF%DX,IDF%DY,IDF%NCOL,IDF%NROW,LLC=.TRUE.) ENDIF DO I=1,NINPUT CALL IDFCOPY(IDF,INPUT(I)%IDF) IF(.NOT.IDFREADSCALE(INPUT(I)%IDF%FNAME,INPUT(I)%IDF,10,1,0.0D0,0))THEN; WRITE(*,'(/A/)') 'CANNOT READ DATA FOR '//TRIM(INPUT(I)%IDF%FNAME); STOP; ENDIF ENDDO DO I=1,NOUTPUT CALL IDFCOPY(IDF,OUTPUT(I)%IDF) IF(.NOT.IDFREADSCALE(OUTPUT(I)%IDF%FNAME,OUTPUT(I)%IDF,10,1,0.0D0,0))THEN; WRITE(*,'(/A/)') 'CANNOT READ DATA FOR '//TRIM(OUTPUT(I)%IDF%FNAME); STOP; ENDIF ENDDO NODES=IDF%NROW*IDF%NCOL ALLOCATE(N(NODES),X(NINPUT),M(NODES),Y(NOUTPUT)); N=0; M=0 INODE=0 DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL INODE=INODE+1 DO I=1,NINPUT; IF(INPUT(I)%IDF%X(ICOL,IROW).NE.INPUT(I)%IDF%NODATA)N(INODE)=N(INODE)+1; ENDDO DO I=1,NOUTPUT; IF(OUTPUT(I)%IDF%X(ICOL,IROW).NE.OUTPUT(I)%IDF%NODATA)M(INODE)=M(INODE)+1; ENDDO ENDDO; ENDDO NSAMPLE=0; DO INODE=1,NODES IF(N(INODE).EQ.NINPUT.AND.M(INODE).EQ.NOUTPUT)THEN NSAMPLE=NSAMPLE+1 ELSE N(INODE)=0; M(INODE)=0 ENDIF ENDDO WRITE(JU,'(2I10,A)') NINPUT,NOUTPUT,' !## INPUT,OUTPUT' WRITE(JU,'(2I10,A)') NSAMPLE,0, ' !## SAMPLE,VALIDATION' WRITE(JU,'(99(A,1X))') (TRIM(INPUT(I)%ALIAS)//',',I=1,NINPUT),(TRIM(OUTPUT(I)%ALIAS)//',',I=1,NOUTPUT-1),TRIM(OUTPUT(NOUTPUT)%ALIAS) INODE=0 DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL INODE=INODE+1; IF(N(INODE)+M(INODE).EQ.0)CYCLE DO I=1,NINPUT; X(I)=INPUT(I)%IDF%X(ICOL,IROW); ENDDO DO I=1,NOUTPUT; Y(I)=OUTPUT(I)%IDF%X(ICOL,IROW); ENDDO WRITE(JU,'(99(F15.7,1X))') (X(I),I=1,NINPUT),(Y(I),I=1,NOUTPUT) ENDDO; ENDDO CLOSE(JU) DEALLOCATE(N,X); DO I=1,NINPUT; CALL IDFDEALLOCATEX(INPUT(I)%IDF); ENDDO JU=UTL_GETUNIT(); OPEN(JU,FILE=OUTPUTCSV(:INDEX(OUTPUTCSV,'.',.TRUE.)-1)//'.INI',STATUS='REPLACE',ACTION='WRITE') WRITE(JU,'(A)') TRIM(OUTPUTCSV(INDEX(OUTPUTCSV,'\',.TRUE.)+1:INDEX(OUTPUTCSV,'.',.TRUE.)-1))//'.OUT' WRITE(JU,'(A)') '1 !## IDEBUG' WRITE(JU,'(A)') '0.9 !## LEARNING RATE' WRITE(JU,'(A)') '0.0 !## MOMENTUM' WRITE(JU,'(A)') '0 !## CONVOLUTION LAYERS' WRITE(JU,'(A)') '2 !## HIDDENLAYERS' WRITE(JU,'(A)') '1 1 !## NEURONS' WRITE(JU,'(A)') 'SIGMOID SIGMOID SIGMOID !## ACTIVATION FUNCTION' WRITE(JU,'(A)') '1000 !## NUMBER OF TRAINING' WRITE(JU,'(A)') '1 !## NUMBER OF BATCHES' WRITE(JU,'(A)') TRIM(OUTPUTCSV(INDEX(OUTPUTCSV,'\',.TRUE.)+1:)) CLOSE(JU) CALL MOD_NN_MAIN(OUTPUTCSV(:INDEX(OUTPUTCSV,'.',.TRUE.)-1)//'.INI') END SUBROUTINE IMODBATCH_AI !###====================================================================== SUBROUTINE IMODBATCH_IDFTOIPF() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: IPFNAME INTEGER :: IROW,ICOL,NSAMPLE,ISAMPLE TYPE(IDFOBJ) :: IDF REAL(KIND=DP_KIND) :: X,Y,XF,YF CALL IDFNULLIFY(IDF); IDF%XMIN=0.0D0; IDF%YMIN=0.0D0; IDF%XMAX=0.0D0; IDF%YMAX=0.0D0 IF(.NOT.UTL_READINITFILE('IDFNAME',LINE,IU,0))RETURN READ(LINE,'(A)') IDF%FNAME; WRITE(*,'(A)') 'IDFNAME='//TRIM(IDF%FNAME) IF(.NOT.IDFREAD(IDF,IDF%FNAME,0))THEN; WRITE(*,'(A)') 'Cannot read '//TRIM(IDF%FNAME); STOP; ENDIF IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX WRITE(*,'(A,4F15.3)') 'WINDOW=',IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX IDF%IEQ=0; CALL UTL_IDFSNAPTOGRID_LLC(IDF%XMIN,IDF%XMAX,IDF%YMIN,IDF%YMAX,IDF%DX,IDF%DY,IDF%NCOL,IDF%NROW,LLC=.TRUE.) IF(.NOT.IDFREADSCALE(IDF%FNAME,IDF,10,1,0.0D0,0))THEN; WRITE(*,'(A)') 'Cannot clip data from '//TRIM(IDF%FNAME); STOP; ENDIF ! IF(.NOT.IDFWRITE(IDF,'D:\TEST.IDF',1))STOP ELSE CLOSE(IDF%IU) IF(.NOT.IDFREAD(IDF,IDF%FNAME,1))THEN; WRITE(*,'(A)') 'Cannot read '//TRIM(IDF%FNAME); STOP; ENDIF ENDIF IF(.NOT.UTL_READINITFILE('IPFNAME',LINE,IU,0))RETURN READ(LINE,'(A)') IPFNAME; WRITE(*,'(A)') 'IPFNAME='//TRIM(IPFNAME) NSAMPLE=0 IF(UTL_READINITFILE('NSAMPLE',LINE,IU,1))THEN READ(LINE,*) NSAMPLE; WRITE(*,'(A)') 'NSAMPLE='//TRIM(VTOS(NSAMPLE)) ENDIF IU=UTL_GETUNIT(); OPEN(IU,FILE=IPFNAME,STATUS='REPLACE',ACTION='WRITE') IF(NSAMPLE.EQ.0)THEN WRITE(IU,'(A)') TRIM(VTOS(IDF%NROW*IDF%NCOL)) ELSE WRITE(IU,'(A)') TRIM(VTOS(NSAMPLE)) ENDIF WRITE(IU,'(A)') '3' WRITE(IU,'(A)') 'X' WRITE(IU,'(A)') 'Y' WRITE(IU,'(A)') 'VALUE' WRITE(IU,'(A)') '0,TXT' IF(NSAMPLE.EQ.0)THEN DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL CALL IDFGETLOC(IDF,IROW,ICOL,X,Y) WRITE(IU,'(2(F15.3,1X),F15.7)') X,Y,IDF%X(ICOL,IROW) ENDDO; ENDDO ELSE ISAMPLE=0; DO CALL RANDOM_NUMBER(XF); CALL RANDOM_NUMBER(YF) X=IDF%XMIN+XF*(IDF%XMAX-IDF%XMIN) Y=IDF%YMIN+YF*(IDF%YMAX-IDF%YMIN) CALL IDFIROWICOL(IDF,IROW,ICOL,X,Y) IF(IDF%X(ICOL,IROW).NE.IDF%NODATA)THEN ISAMPLE=ISAMPLE+1 WRITE(IU,'(2(F15.3,1X),F15.7)') X,Y,IDF%X(ICOL,IROW) IF(ISAMPLE.EQ.NSAMPLE)EXIT ENDIF ENDDO ENDIF CLOSE(IU) END SUBROUTINE IMODBATCH_IDFTOIPF !###====================================================================== SUBROUTINE IMODBATCH_RES_RESISTANCE() !###====================================================================== IMPLICIT NONE INTEGER :: IROW,ICOL,IFLX TYPE(IDFOBJ) :: HED,FLX,HED2,RES,TOP,BOT REAL(KIND=DP_KIND) :: DH,Q,COND,H1,H2,DX1,DX2,DY1,DY2,D,W,T,B,T1,T2,B1,B2,C CALL IDFNULLIFY(HED); CALL IDFNULLIFY(FLX); CALL IDFNULLIFY(HED2); CALL IDFNULLIFY(RES); IFLX=0 IF(.NOT.UTL_READINITFILE('HEAD',LINE,IU,0))RETURN READ(LINE,'(A)') HED%FNAME; WRITE(*,'(A)') 'HEAD='//TRIM(HED%FNAME) IF(.NOT.IDFREAD(HED,HED%FNAME,1))THEN; WRITE(*,'(A)') 'Cannot read '//TRIM(HED%FNAME); STOP; ENDIF IF(UTL_READINITFILE('BDGFRF',LINE,IU,1))THEN READ(LINE,'(A)') FLX%FNAME; WRITE(*,'(A)') 'BDGFRF='//TRIM(FLX%FNAME) IF(.NOT.IDFREAD(FLX,FLX%FNAME,1))THEN; WRITE(*,'(A)') 'Cannot read '//TRIM(FLX%FNAME); STOP; ENDIF IFLX=1 ELSEIF(UTL_READINITFILE('BDGFFF',LINE,IU,1))THEN READ(LINE,'(A)') FLX%FNAME; WRITE(*,'(A)') 'BDGFFF='//TRIM(FLX%FNAME) IF(.NOT.IDFREAD(FLX,FLX%FNAME,1))THEN; WRITE(*,'(A)') 'Cannot read '//TRIM(FLX%FNAME); STOP; ENDIF IFLX=2 ELSEIF(UTL_READINITFILE('BDGFLF',LINE,IU,1))THEN READ(LINE,'(A)') FLX%FNAME; WRITE(*,'(A)') 'BDGFLF='//TRIM(FLX%FNAME) IF(.NOT.IDFREAD(FLX,FLX%FNAME,1))THEN; WRITE(*,'(A)') 'Cannot read '//TRIM(FLX%FNAME); STOP; ENDIF IFLX=3 IF(.NOT.UTL_READINITFILE('HEAD2',LINE,IU,0))RETURN READ(LINE,'(A)') HED2%FNAME; WRITE(*,'(A)') 'HEAD2='//TRIM(HED2%FNAME) IF(.NOT.IDFREAD(HED,HED2%FNAME,1))THEN; WRITE(*,'(A)') 'Cannot read '//TRIM(HED2%FNAME); STOP; ENDIF ENDIF IF(.NOT.UTL_READINITFILE('TOP',LINE,IU,0))RETURN READ(LINE,'(A)') TOP%FNAME; WRITE(*,'(A)') 'TOP='//TRIM(TOP%FNAME) CALL IDFCOPY(HED,TOP); IF(.NOT.IDFREADSCALE(TOP%FNAME,TOP,2,1,0.D0,0))THEN; WRITE(*,'(A)') 'Cannot read '//TRIM(TOP%FNAME); STOP; ENDIF IF(.NOT.UTL_READINITFILE('BOT',LINE,IU,0))RETURN READ(LINE,'(A)') BOT%FNAME; WRITE(*,'(A)') 'BOT='//TRIM(BOT%FNAME) CALL IDFCOPY(HED,BOT); IF(.NOT.IDFREADSCALE(BOT%FNAME,BOT,2,1,0.0D0,0))THEN; WRITE(*,'(A)') 'Cannot read '//TRIM(BOT%FNAME); STOP; ENDIF IF(.NOT.UTL_READINITFILE('RES_IDF',LINE,IU,0))RETURN READ(LINE,'(A)') RES%FNAME; WRITE(*,'(A)') 'RES_IDF='//TRIM(RES%FNAME) CALL IDFCOPY(HED,RES); RES%X=RES%NODATA DO IROW=1,HED%NROW; DO ICOL=1,HED%NCOL IF(HED%X(ICOL,IROW).EQ.HED%NODATA)CYCLE ! IF(IROW.EQ.213.AND.ICOL.EQ.275)THEN ! WRITE(*,*) ! ENDIF H1=HED%X(ICOL,IROW) T1=TOP%X(ICOL,IROW) B1=BOT%X(ICOL,IROW) SELECT CASE (IFLX) !## bdgfrf CASE (1) IF(ICOL.EQ.HED%NCOL)CYCLE H2=HED%X(ICOL+1,IROW) T2=TOP%X(ICOL+1,IROW) B2=BOT%X(ICOL+1,IROW) CALL IDFGETDXDY(HED,ICOL,IROW,DX1,DY1); CALL IDFGETDXDY(HED,ICOL+1,IROW,DX2,DY2) D=0.50*(DX1+DX2) ! W=DY1 !## bdgfff CASE (2) IF(IROW.EQ.HED%NROW)CYCLE H2=HED%X(ICOL,IROW+1) T2=TOP%X(ICOL,IROW+1) B2=BOT%X(ICOL,IROW+1) CALL IDFGETDXDY(HED,ICOL,IROW,DX1,DY1); CALL IDFGETDXDY(HED,ICOL,IROW+1,DX2,DY2) D=0.50*(DY1+DY2) ! W=DX1 !## bdgflf CASE (3) H2=HED2%X(ICOL,IROW) END SELECT C=RES%NODATA T=(T1+T2)/2.0D0 B=(B1+B2)/2.0D0 Q=FLX%X(ICOL,IROW) !## no part of constant head IF(Q.NE.0.0D0)THEN DH=(H2-H1) !/D IF(DH.NE.0.0D0)THEN COND=ABS(Q/DH) C=(T-B)*D/COND ENDIF ENDIF RES%X(ICOL,IROW)=C ENDDO; ENDDO IF(.NOT.IDFWRITE(RES,RES%FNAME,1))STOP END SUBROUTINE IMODBATCH_RES_RESISTANCE !###====================================================================== SUBROUTINE IMODBATCH_ADJOINT_ZONES() !###====================================================================== IMPLICIT NONE INTEGER :: IROW,ICOL,NLAY,NZX,IX,IY,IZ TYPE(IDFOBJ) :: BND REAL(KIND=DP_KIND) :: RESOLUTION,X,Y CALL IDFNULLIFY(BND) IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) NLAY; WRITE(*,'(A)') 'NLAY='//TRIM(VTOS(NLAY)) IF(.NOT.UTL_READINITFILE('RESOLUTION',LINE,IU,0))RETURN READ(LINE,*) RESOLUTION; WRITE(*,'(A)') 'RESOLUTION='//TRIM(VTOS(RESOLUTION,'F',2)) DO I=1,NLAY IF(.NOT.UTL_READINITFILE('IBOUND_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,'(A)') BND%FNAME; WRITE(*,'(A)') 'IBOUND_L'//TRIM(VTOS(I))//'='//TRIM(BND%FNAME) IF(.NOT.IDFREAD(BND,BND%FNAME,1))STOP NZX=(BND%XMAX-BND%XMIN)/RESOLUTION Y=0.0D0 DO IROW=1,BND%NROW Y=Y+RESOLUTION; IY=MOD(Y,RESOLUTION) X=BND%XMIN DO ICOL=1,BND%NCOL X=X+RESOLUTION; IX=MOD(X,RESOLUTION) IF(BND%X(ICOL,IROW).EQ.BND%NODATA)CYCLE IZ=IX+IY BND%X(ICOL,IROW)=REAL(IZ,8) ENDDO ENDDO IF(.NOT.UTL_READINITFILE('ZONES_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,'(A)') BND%FNAME; WRITE(*,'(A)') 'ZONES_L'//TRIM(VTOS(I))//'='//TRIM(BND%FNAME) IF(.NOT.IDFWRITE(BND,BND%FNAME,0))STOP ENDDO ! IF(.NOT.IDFWRITE(RES,RES%FNAME,1))STOP END SUBROUTINE IMODBATCH_ADJOINT_ZONES !###====================================================================== SUBROUTINE IMODBATCH_FLUX_CHECK() !###====================================================================== IMPLICIT NONE TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: FLX,TOP,BOT TYPE(IDFOBJ) :: RES INTEGER :: ILAY,IROW,ICOL,NLAY REAL :: Q1,Q2,T,F IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) NLAY; WRITE(*,'(A)') 'NLAY='//TRIM(VTOS(NLAY)) ALLOCATE(FLX(NLAY)); DO ILAY=1,NLAY; CALL IDFNULLIFY(FLX(ILAY)); ENDDO; CALL IDFNULLIFY(RES) ALLOCATE(TOP(NLAY)); DO ILAY=1,NLAY; CALL IDFNULLIFY(TOP(ILAY)); ENDDO ALLOCATE(BOT(NLAY)); DO ILAY=1,NLAY; CALL IDFNULLIFY(BOT(ILAY)); ENDDO DO ILAY=1,NLAY IF(.NOT.UTL_READINITFILE('FLX_L'//TRIM(VTOS(ILAY)),LINE,IU,0))RETURN READ(LINE,'(A)') FLX(ILAY)%FNAME; WRITE(*,'(A)') 'FLX_L'//TRIM(VTOS(ILAY))//'='//TRIM(FLX(ILAY)%FNAME) IF(.NOT.IDFREAD(FLX(ILAY),FLX(ILAY)%FNAME,1))THEN WRITE(*,'(A)') '>>> CANNOT READ '//TRIM(FLX(ILAY)%FNAME)//' <<<'; STOP ENDIF CALL IDFCOPY(FLX(ILAY),TOP(ILAY)) IF(.NOT.UTL_READINITFILE('TOP_L'//TRIM(VTOS(ILAY)),LINE,IU,0))RETURN READ(LINE,'(A)') TOP(ILAY)%FNAME; WRITE(*,'(A)') 'TOP_L'//TRIM(VTOS(ILAY))//'='//TRIM(TOP(ILAY)%FNAME) IF(.NOT.IDFREAD(TOP(ILAY),TOP(ILAY)%FNAME,1))THEN WRITE(*,'(A)') '>>> CANNOT READ '//TRIM(TOP(ILAY)%FNAME)//' <<<'; STOP ENDIF CALL IDFCOPY(FLX(ILAY),BOT(ILAY)) IF(.NOT.UTL_READINITFILE('BOT_L'//TRIM(VTOS(ILAY)),LINE,IU,0))RETURN READ(LINE,'(A)') BOT(ILAY)%FNAME; WRITE(*,'(A)') 'BOT_L'//TRIM(VTOS(ILAY))//'='//TRIM(BOT(ILAY)%FNAME) IF(.NOT.IDFREAD(BOT(ILAY),BOT(ILAY)%FNAME,1))THEN WRITE(*,'(A)') '>>> CANNOT READ '//TRIM(BOT(ILAY)%FNAME)//' <<<'; STOP ENDIF ENDDO IF(.NOT.UTL_READINITFILE('RESULT',LINE,IU,0))RETURN READ(LINE,'(A)') RES%FNAME; WRITE(*,'(A)') 'RESULT='//TRIM(RES%FNAME) CALL IDFCOPY(FLX(1),RES); RES%X=RES%NODATA DO IROW=1,RES%NROW; DO ICOL=1,RES%NCOL DO ILAY=1,NLAY IF(FLX(ILAY)%X(ICOL,IROW).EQ.FLX(ILAY)%NODATA)CYCLE IF(FLX(ILAY)%X(ICOL,IROW).GT.0.0D0)THEN Q1=0.0D0 IF(ILAY.GT.1)THEN IF(FLX(ILAY-1)%X(ICOL,IROW).NE.FLX(ILAY-1)%NODATA)Q1=ABS(FLX(ILAY-1)%X(ICOL,IROW)) ENDIF Q2=ABS(FLX(ILAY )%X(ICOL,IROW)) F =Q2/(Q1+Q2) T =(TOP(ILAY)%X(ICOL,IROW)-BOT(ILAY)%X(ICOL,IROW))*F RES%X(ICOL,IROW)=TOP(ILAY)%X(ICOL,IROW)-T EXIT ENDIF ENDDO IF(ILAY.GT.NLAY)RES%X(ICOL,IROW)=(TOP(NLAY)%X(ICOL,IROW)+BOT(NLAY)%X(ICOL,IROW))/2.0D0 ENDDO; ENDDO IF(.NOT.IDFWRITE(RES,RES%FNAME,1))THEN WRITE(*,'(A)') '>>> CANNOT SAVE '//TRIM(RES%FNAME)//' <<<'; STOP ENDIF END SUBROUTINE IMODBATCH_FLUX_CHECK !###====================================================================== SUBROUTINE IMODBATCH_SCALE_ELEVATION() !###====================================================================== IMPLICIT NONE TYPE(IDFOBJ),DIMENSION(:),ALLOCATABLE :: HEAD,HED,FRF,FFF,FLF TYPE(IDFOBJ) :: SCLHEAD,QRIV,TR,TF,TL,TOP,BOT TYPE(IDFOBJ),DIMENSION(4) :: SCLRIV TYPE(IDFOBJ),DIMENSION(3) :: RIV REAL(KIND=DP_KIND) :: WP,BH,CN,HD,Q,SCALESIZE,C,DH,QL,QF,QR,DL,DF,DR,HC,KDR,KDF,KDL INTEGER :: IROW,ICOL,JROW,JCOL,ILAY,NLAY,IL1,IL2,I,J,ISCALE,IR1,IR2,IC1,IC2,DCOL,DROW CHARACTER(LEN=256) :: OUTPUTFOLDER,HEADFOLDER,RIVARRFNAME,RESFOLDER REAL(KIND=DP_KIND),POINTER,DIMENSION(:,:) :: X INTEGER,POINTER,DIMENSION(:,:) :: IDX !## compute kh/kv from model to resolution IF(.NOT.UTL_READINITFILE('ISCALE',LINE,IU,0))RETURN READ(LINE,*) ISCALE; WRITE(*,'(A)') 'ISCALE='//TRIM(VTOS(ISCALE)) SELECT CASE (ISCALE) CASE (1); WRITE(*,'(/A/)') 'SCALE RIVERS' CASE (2); WRITE(*,'(/A/)') 'SCALE PERMEABILITY' CASE DEFAULT; WRITE(*,'(/A/)') 'SELECT ISCALE=1 (RIVERS) OF ISCALE=2 (PERMEABILITY)'; STOP END SELECT IF(.NOT.UTL_READINITFILE('OUTPUTFOLDER',LINE,IU,0))RETURN READ(LINE,'(A)') OUTPUTFOLDER; WRITE(*,'(A)') 'OUTPUTFOLDER='//TRIM(OUTPUTFOLDER) IF(.NOT.UTL_READINITFILE('SCALESIZE',LINE,IU,0))RETURN READ(LINE,*) SCALESIZE; WRITE(*,'(A)') 'SCALESIZE='//TRIM(VTOS(SCALESIZE,'F',2)) IF(ISCALE.EQ.1)THEN IF(.NOT.UTL_READINITFILE('HEADFOLDER',LINE,IU,0))RETURN READ(LINE,'(A)') HEADFOLDER; WRITE(*,'(A)') 'HEADFOLDER='//TRIM(HEADFOLDER) IF(.NOT.UTL_READINITFILE('RIVARR',LINE,IU,0))RETURN READ(LINE,'(A)') RIVARRFNAME; WRITE(*,'(A)') 'RIVARR='//TRIM(RIVARRFNAME) IF(.NOT.IPEST_GLM_READ_LSTFILE(RIVARRFNAME,3,X,3,IDX))THEN; WRITE(*,*) 'CANNOT READ '//TRIM(RIVARRFNAME); PAUSE; STOP; ENDIF IL1=MINVAL(IDX(1,:)); IL2=MAXVAL(IDX(1,:)); ALLOCATE(HEAD(IL2)) DO ILAY=IL1,IL2 CALL IDFNULLIFY(HEAD(ILAY)) WRITE(*,*) 'READING '//TRIM(HEADFOLDER)//'\HEAD_STEADY-STATE_L'//TRIM(VTOS(ILAY))//'.IDF ...' IF(.NOT.IDFREAD(HEAD(ILAY),TRIM(HEADFOLDER)//'\HEAD_STEADY-STATE_L'//TRIM(VTOS(ILAY))//'.IDF',1))THEN WRITE(*,*) 'CANNOT READ '//TRIM(HEADFOLDER)//'\HEAD_STEADY-STATE_L'//TRIM(VTOS(ILAY))//'.IDF'; PAUSE; STOP ENDIF ENDDO DO I=1,SIZE(RIV); CALL IDFNULLIFY(RIV(I)); CALL IDFCOPY(HEAD(IL1),RIV(I)); ENDDO CALL IDFNULLIFY(QRIV); CALL IDFCOPY(HEAD(IL1),QRIV) CALL IDFNULLIFY(SCLHEAD); CALL IDFCOPY(HEAD(IL1),SCLHEAD); CALL IDFDEALLOCATEX(SCLHEAD); SCLHEAD%DX=SCALESIZE; SCLHEAD%DY=SCLHEAD%DX CALL UTL_IDFSNAPTOGRID_LLC(SCLHEAD%XMIN,SCLHEAD%XMAX,SCLHEAD%YMIN,SCLHEAD%YMAX,SCLHEAD%DX,SCLHEAD%DY,SCLHEAD%NCOL,SCLHEAD%NROW,LLC=.TRUE.) DO I=1,SIZE(SCLRIV); CALL IDFNULLIFY(SCLRIV(I)); CALL IDFCOPY(SCLHEAD,SCLRIV(I)); ENDDO !## process all available layers DO ILAY=IL1,IL2 QRIV%X=QRIV%NODATA DO I=1,SIZE(RIV); RIV(I)%X =RIV(I)%NODATA; ENDDO DO I=1,SIZE(IDX,2) IF(IDX(1,I).EQ.ILAY)THEN IROW=IDX(2,I) ICOL=IDX(3,I) DO J=1,SIZE(RIV); RIV(J)%X(ICOL,IROW)=X(J,I); ENDDO WP=X(1,I) CN=X(2,I) BH=X(3,I) HD=HEAD(ILAY)%X(ICOL,IROW) !## compute q IF(HD.GT.BH)THEN Q=(WP-HD)*CN ELSEIF(HD.LT.BH)THEN Q=(WP-BH)*CN ENDIF QRIV%X(ICOL,IROW)=Q ENDIF ENDDO !!## save original scaled level !RIV(1)%FNAME=TRIM(OUTPUTFOLDER)//'\ORG_RIVLEVEL_L'//TRIM(VTOS(ILAY))//'.IDF' !IF(.NOT.IDFWRITE(RIV(1),RIV(1)%FNAME,1))THEN ! WRITE(*,*) 'CANNOT SAVE '//TRIM(RIV(1)%FNAME); PAUSE; STOP !ENDIF !RIV(2)%FNAME=TRIM(OUTPUTFOLDER)//'\ORG_RIVCOND_L'//TRIM(VTOS(ILAY))//'.IDF' !IF(.NOT.IDFWRITE(RIV(2),RIV(2)%FNAME,1))THEN ! WRITE(*,*) 'CANNOT SAVE '//TRIM(RIV(2)%FNAME); PAUSE; STOP !ENDIF !RIV(3)%FNAME=TRIM(OUTPUTFOLDER)//'\ORG_RIVBOTTOM_L'//TRIM(VTOS(ILAY))//'.IDF' !IF(.NOT.IDFWRITE(RIV(3),RIV(3)%FNAME,1))THEN ! WRITE(*,*) 'CANNOT SAVE '//TRIM(RIV(3)%FNAME); PAUSE; STOP !ENDIF !QRIV%FNAME=TRIM(OUTPUTFOLDER)//'\ORG_RIVQ_L'//TRIM(VTOS(ILAY))//'.IDF' !IF(.NOT.IDFWRITE(QRIV,QRIV%FNAME,1))THEN ! WRITE(*,*) 'CANNOT SAVE '//TRIM(QRIV%FNAME); PAUSE; STOP !ENDIF !HEAD(ILAY)%FNAME=TRIM(OUTPUTFOLDER)//'\ORG_HEAD_L'//TRIM(VTOS(ILAY))//'.IDF' !IF(.NOT.IDFWRITE(HEAD(ILAY),HEAD(ILAY)%FNAME,1))THEN ! WRITE(*,*) 'CANNOT SAVE '//TRIM(HEAD(ILAY)%FNAME); PAUSE; STOP !ENDIF !## scale all IF(.NOT.IDFREADSCALE_GETX(HEAD(ILAY),SCLHEAD,2,0,0.0D0))THEN; WRITE(*,*) 'CANNOT SCALE HEAD '//TRIM(HEAD(ILAY)%FNAME); PAUSE; STOP; ENDIF IF(.NOT.IDFREADSCALE_GETX(RIV(1),SCLRIV(1),2,0,0.0D0))THEN; WRITE(*,*) 'CANNOT SCALE RIV-LEVEL '; PAUSE; STOP; ENDIF IF(.NOT.IDFREADSCALE_GETX(RIV(2),SCLRIV(2),4,0,0.0D0))THEN; WRITE(*,*) 'CANNOT SCALE RIV-COND '; PAUSE; STOP; ENDIF IF(.NOT.IDFREADSCALE_GETX(RIV(3),SCLRIV(3),2,0,0.0D0))THEN; WRITE(*,*) 'CANNOT SCALE RIV-BOTTOM'; PAUSE; STOP; ENDIF IF(.NOT.IDFREADSCALE_GETX(QRIV ,SCLRIV(4),4,0,0.0D0))THEN; WRITE(*,*) 'CANNOT SCALE QRIV' ; PAUSE; STOP; ENDIF SCLRIV(2)%FNAME=TRIM(OUTPUTFOLDER)//'\SCALED_RIVCOND_ORG_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(SCLRIV(2),SCLRIV(2)%FNAME,1))THEN WRITE(*,*) 'CANNOT SAVE '//TRIM(SCLRIV(2)%FNAME); PAUSE; STOP ENDIF DO IROW=1,SCLHEAD%NROW; DO ICOL=1,SCLHEAD%NCOL !## keep original conductance C=SCLRIV(2)%X(ICOL,IROW) IF(SCLRIV(4)%X(ICOL,IROW).NE.0.0D0)THEN IF(SCLHEAD%X(ICOL,IROW).LT.SCLRIV(3)%X(ICOL,IROW))THEN DH=SCLRIV(1)%X(ICOL,IROW)-SCLRIV(3)%X(ICOL,IROW) ELSE DH=SCLRIV(1)%X(ICOL,IROW)-SCLHEAD%X(ICOL,IROW) ENDIF C=SCLRIV(3)%NODATA IF(DH.NE.0.0D0)C=SCLRIV(4)%X(ICOL,IROW)/DH ENDIF SCLRIV(2)%X(ICOL,IROW)=C ENDDO; ENDDO !## save original scaled level SCLRIV(1)%FNAME=TRIM(OUTPUTFOLDER)//'\SCALED_RIVLEVEL_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(SCLRIV(1),SCLRIV(1)%FNAME,1))THEN WRITE(*,*) 'CANNOT SAVE '//TRIM(SCLRIV(1)%FNAME); PAUSE; STOP ENDIF SCLRIV(2)%FNAME=TRIM(OUTPUTFOLDER)//'\SCALED_RIVCOND_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(SCLRIV(2),SCLRIV(2)%FNAME,1))THEN WRITE(*,*) 'CANNOT SAVE '//TRIM(SCLRIV(2)%FNAME); PAUSE; STOP ENDIF SCLRIV(3)%FNAME=TRIM(OUTPUTFOLDER)//'\SCALED_RIVBOTTOM_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(SCLRIV(3),SCLRIV(3)%FNAME,1))THEN WRITE(*,*) 'CANNOT SAVE '//TRIM(SCLRIV(3)%FNAME); PAUSE; STOP ENDIF SCLRIV(4)%FNAME=TRIM(OUTPUTFOLDER)//'\SCALED_RIVQ_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(SCLRIV(4),SCLRIV(4)%FNAME,1))THEN WRITE(*,*) 'CANNOT SAVE '//TRIM(SCLRIV(4)%FNAME); PAUSE; STOP ENDIF SCLHEAD%FNAME=TRIM(OUTPUTFOLDER)//'\SCALED_HEAD_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(SCLHEAD,SCLHEAD%FNAME,1))THEN WRITE(*,*) 'CANNOT SAVE '//TRIM(SCLHEAD%FNAME); PAUSE; STOP ENDIF ENDDO ELSE IF(.NOT.UTL_READINITFILE('RESFOLDER',LINE,IU,0))RETURN READ(LINE,'(A)') RESFOLDER; WRITE(*,'(A)') 'RESFOLDER='//TRIM(RESFOLDER) IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) NLAY; WRITE(*,'(A)') 'NLAY='//TRIM(VTOS(NLAY)) ALLOCATE(HED(NLAY),FRF(NLAY),FFF(NLAY),FLF(NLAY)) DO ILAY=1,NLAY CALL IDFNULLIFY(HED(ILAY)); CALL IDFNULLIFY(FRF(ILAY)); CALL IDFNULLIFY(FFF(ILAY)); CALL IDFNULLIFY(FLF(ILAY)) WRITE(*,*) 'READING '//TRIM(RESFOLDER)//'\HEAD\HEAD_STEADY-STATE_L'//TRIM(VTOS(ILAY))//'.IDF ...' IF(.NOT.IDFREAD(HED(ILAY),TRIM(RESFOLDER)//'\HEAD\HEAD_STEADY-STATE_L'//TRIM(VTOS(ILAY))//'.IDF',1))THEN WRITE(*,*) 'CANNOT READ '//TRIM(RESFOLDER)//'\HEAD\HEAD_STEADY-STATE_L'//TRIM(VTOS(ILAY))//'.IDF'; PAUSE; STOP ENDIF WRITE(*,*) 'READING '//TRIM(RESFOLDER)//'\BDGFRF\BDGFRF_STEADY-STATE_L'//TRIM(VTOS(ILAY))//'.IDF ...' IF(.NOT.IDFREAD(FRF(ILAY),TRIM(RESFOLDER)//'\BDGFRF\BDGFRF_STEADY-STATE_L'//TRIM(VTOS(ILAY))//'.IDF',1))THEN WRITE(*,*) 'CANNOT READ '//TRIM(RESFOLDER)//'\BDGFRF\BDGFRF_STEADY-STATE_L'//TRIM(VTOS(ILAY))//'.IDF'; PAUSE; STOP ENDIF WRITE(*,*) 'READING '//TRIM(RESFOLDER)//'\BDGFFF\BDGFFF_STEADY-STATE_L'//TRIM(VTOS(ILAY))//'.IDF ...' IF(.NOT.IDFREAD(FFF(ILAY),TRIM(RESFOLDER)//'\BDGFFF\BDGFFF_STEADY-STATE_L'//TRIM(VTOS(ILAY))//'.IDF',1))THEN WRITE(*,*) 'CANNOT READ '//TRIM(RESFOLDER)//'\BDGFFF\BDGFFF_STEADY-STATE_L'//TRIM(VTOS(ILAY))//'.IDF'; PAUSE; STOP ENDIF IF(ILAY.LT.NLAY)THEN WRITE(*,*) 'READING '//TRIM(RESFOLDER)//'\BDGFLF\BDGFLF_STEADY-STATE_L'//TRIM(VTOS(ILAY))//'.IDF ...' IF(.NOT.IDFREAD(FLF(ILAY),TRIM(RESFOLDER)//'\BDGFLF\BDGFLF_STEADY-STATE_L'//TRIM(VTOS(ILAY))//'.IDF',1))THEN WRITE(*,*) 'CANNOT READ '//TRIM(RESFOLDER)//'\BDGFLF\BDGFLF_STEADY-STATE_L'//TRIM(VTOS(ILAY))//'.IDF'; PAUSE; STOP ENDIF ENDIF ENDDO CALL IDFNULLIFY(SCLHEAD); CALL IDFCOPY(HED(1),SCLHEAD); CALL IDFDEALLOCATEX(SCLHEAD); SCLHEAD%DX=SCALESIZE; SCLHEAD%DY=SCLHEAD%DX CALL UTL_IDFSNAPTOGRID_LLC(SCLHEAD%XMIN,SCLHEAD%XMAX,SCLHEAD%YMIN,SCLHEAD%YMAX,SCLHEAD%DX,SCLHEAD%DY,SCLHEAD%NCOL,SCLHEAD%NROW,LLC=.TRUE.) CALL IDFNULLIFY(TL); CALL IDFNULLIFY(TR); CALL IDFNULLIFY(TF) CALL IDFCOPY(SCLHEAD,TL); CALL IDFCOPY(SCLHEAD,TR); CALL IDFCOPY(SCLHEAD,TF) DCOL=SCALESIZE/HED(1)%DX; DROW=SCALESIZE/HED(1)%DX DO ILAY=1,NLAY !## scale all IF(.NOT.IDFREADSCALE_GETX(HED(ILAY),SCLHEAD,2,0,0.0D0))THEN; WRITE(*,*) 'CANNOT SCALE HEAD '//TRIM(HED(ILAY)%FNAME); PAUSE; STOP; ENDIF IF(.NOT.UTL_READINITFILE('TOP_L'//TRIM(VTOS(ILAY)),LINE,IU,0))RETURN READ(LINE,'(A)') TOP%FNAME; WRITE(*,'(A)') 'TOP_L'//TRIM(VTOS(ILAY))//'='//TRIM(TOP%FNAME) IF(.NOT.IDFREADSCALE(TOP%FNAME,TOP,2,0,0.0D0,0))THEN WRITE(*,*) 'CANNOT READ '//TRIM(TOP%FNAME); PAUSE; STOP ENDIF IF(.NOT.UTL_READINITFILE('BOT_L'//TRIM(VTOS(ILAY)),LINE,IU,0))RETURN READ(LINE,'(A)') BOT%FNAME; WRITE(*,'(A)') 'BOT_L'//TRIM(VTOS(ILAY))//'='//TRIM(BOT%FNAME) IF(.NOT.IDFREADSCALE(BOT%FNAME,BOT,2,0,0.0D0,0))THEN WRITE(*,*) 'CANNOT READ '//TRIM(BOT%FNAME); PAUSE; STOP ENDIF IR2=HED(1)%NROW+DROW DO IROW=SCLHEAD%NROW,1,-1 IR2=MAX(1,IR2-DROW); IR1=MAX(1,IR2-DROW-1) IC1=-DCOL+1 DO ICOL=1,SCLHEAD%NCOL IC1=MIN(HED(1)%NCOL,IC1+DCOL); IC2=MIN(HED(1)%NCOL,IC1+DCOL-1) IF(SCLHEAD%X(ICOL,IROW).EQ.SCLHEAD%NODATA)CYCLE QR=0.0D0; QF=0.0D0; QL=0.0D0 DR=0.0D0; DF=0.0D0; DL=0.0D0 DO JROW=IR1,IR2; DO JCOL=IC1,IC2 !## current head HC=HED(ILAY)%X(JCOL,JROW) !## add east IF(HED(ILAY)%X(JCOL+1,JROW).NE.HED(ILAY)%NODATA)THEN QR=QR+ FRF(ILAY)%X(JCOL,JROW) DR=DR+(HED(ILAY)%X(JCOL+1,JROW)-HC) ENDIF !## add west IF(JCOL-1.GT.0)THEN IF(HED(ILAY)%X(JCOL-1,JROW).NE.HED(ILAY)%NODATA)THEN QR=QR+ FRF(ILAY)%X(JCOL-1,JROW) DR=DR+(HC-HED(ILAY)%X(JCOL-1,JROW)) ENDIF ENDIF !## add north IF(HED(ILAY)%X(JCOL,JROW-1).NE.HED(ILAY)%NODATA)THEN QF=QF+ FFF(ILAY)%X(JCOL,JROW) DF=DF+(HC-HED(ILAY)%X(JCOL,JROW-1)) ENDIF !## add south IF(JROW-1.GT.0)then IF(HED(ILAY)%X(JCOL,JROW).NE.HED(ILAY)%NODATA)THEN QF=QF+ FFF(ILAY)%X(JCOL,JROW-1) DF=DF+(HED(ILAY)%X(ICOL,JROW-1)-HC) ENDIF ENDIF !## add bottom IF(ILAY.LT.NLAY)THEN QL=QL+ FLF(ILAY)%X(JCOL,JROW) IF(HED(ILAY+1)%X(JCOL,JROW).NE.HED(ILAY+1)%NODATA)DL=DL+(HED(ILAY+1)%X(JCOL,JROW+1)-HC) ENDIF !## add top IF(ILAY-1.GT.0)THEN QL=QL+ FLF(ILAY-1)%X(JCOL,JROW) IF(HED(ILAY-1)%X(JCOL,JROW).NE.HED(ILAY-1)%NODATA)DL=DL+(HC-HED(ILAY-1)%X(JCOL,JROW)) ENDIF ENDDO; ENDDO !## transmissivity/permeability west/east KDR=TR%NODATA IF(QR.NE.0.0D0)THEN KDR=QR/DR; KDR=KDR/(TOP%X(ICOL,IROW)-BOT%X(ICOL,IROW)) ENDIF KDF=TF%NODATA IF(QF.NE.0.0D0)THEN !## transmissivity/permeability north/south KDF=QF/DF; KDF=KDF/(TOP%X(ICOL,IROW)-BOT%X(ICOL,IROW)) ENDIF KDL=TL%NODATA IF(QL.NE.0.0D0)THEN !## transmissivity/permeability top/bottom KDL=QL/DL; KDL=KDL/(TOP%X(ICOL,IROW)-BOT%X(ICOL,IROW)) ENDIF !## permeability TR%X(ICOL,IROW)=KDR !## horizontal anisotropy TF%X(ICOL,IROW)=KDF/KDR !## vertical anisotropy TL%X(ICOL,IROW)=KDL/KDR ENDDO ENDDO TR%FNAME=TRIM(OUTPUTFOLDER)//'\KHV\KHV_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(TR,TR%FNAME,1))THEN WRITE(*,*) 'CANNOT SAVE '//TRIM(TR%FNAME); PAUSE; STOP ENDIF TF%FNAME=TRIM(OUTPUTFOLDER)//'\ANI\ANF_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(TF,TF%FNAME,1))THEN WRITE(*,*) 'CANNOT SAVE '//TRIM(TF%FNAME); PAUSE; STOP ENDIF TL%FNAME=TRIM(OUTPUTFOLDER)//'\KVA\KVA_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(TL,TL%FNAME,1))THEN WRITE(*,*) 'CANNOT SAVE '//TRIM(TL%FNAME); PAUSE; STOP ENDIF ENDDO ENDIF END SUBROUTINE IMODBATCH_SCALE_ELEVATION !###====================================================================== SUBROUTINE IMODBATCH_SCALE_ELEVATION_OLD() !###====================================================================== IMPLICIT NONE TYPE(IDFOBJ) :: ORGHEAD,ORGLEVL,ORGBOTM,ORGCOND,SCLHEAD,SCLLEVL,SCLBOTM,SCLCOND REAL(KIND=DP_KIND) :: SCALESIZE,TQ,H,DH INTEGER :: IROW,JROW,ICOL,JCOL,IR1,IR2,IC1,IC2,DR,DC,ILEVEL CHARACTER(LEN=256) :: OUTPUTFOLDER IF(.NOT.UTL_READINITFILE('ORGHEAD',LINE,IU,0))RETURN READ(LINE,'(A)') ORGHEAD%FNAME; WRITE(*,'(A)') 'ORGHEAD='//TRIM(ORGHEAD%FNAME) IF(.NOT.UTL_READINITFILE('ORGLEVEL',LINE,IU,0))RETURN READ(LINE,'(A)') ORGLEVL%FNAME; WRITE(*,'(A)') 'ORGLEVEL='//TRIM(ORGLEVL%FNAME) IF(.NOT.UTL_READINITFILE('ORGBOTTOM',LINE,IU,0))RETURN READ(LINE,'(A)') ORGBOTM%FNAME; WRITE(*,'(A)') 'ORGBOTTOM='//TRIM(ORGBOTM%FNAME) IF(.NOT.UTL_READINITFILE('ORGCONDUCT',LINE,IU,0))RETURN READ(LINE,'(A)') ORGCOND%FNAME; WRITE(*,'(A)') 'ORGCONDUCT='//TRIM(ORGCOND%FNAME) IF(.NOT.UTL_READINITFILE('OUTPUTFOLDER',LINE,IU,0))RETURN READ(LINE,'(A)') OUTPUTFOLDER; WRITE(*,'(A)') 'OUTPUTFOLDER='//TRIM(OUTPUTFOLDER) IF(.NOT.UTL_READINITFILE('SCALESIZE',LINE,IU,0))RETURN READ(LINE,*) SCALESIZE; WRITE(*,'(A)') 'SCALESIZE='//TRIM(VTOS(SCALESIZE,'F',2)) IF(.NOT.UTL_READINITFILE('ILEVEL',LINE,IU,0))RETURN READ(LINE,*) ILEVEL; WRITE(*,'(A)') 'ILEVEL='//TRIM(VTOS(ILEVEL)) IF(.NOT.IDFREAD(ORGCOND,ORGCOND%FNAME,0))STOP 'CANNOT READ ORGCOND'; CLOSE(ORGCOND%IU) CALL IDFCOPY(ORGCOND,SCLHEAD); CALL IDFCOPY(ORGCOND,ORGLEVL); CALL IDFCOPY(ORGCOND,ORGHEAD); CALL IDFCOPY(ORGCOND,ORGBOTM) IF(.NOT.IDFREAD(ORGCOND,ORGCOND%FNAME,1))STOP 'CANNOT READ ORGHEAD' !## original stage,bottom,conductance - all resampled to head IF(.NOT.IDFREADSCALE(ORGLEVL%FNAME,ORGLEVL,2,1,0.0D0,0))STOP 'CANNOT READ ORGLEVEL' IF(.NOT.IDFREADSCALE(ORGBOTM%FNAME,ORGBOTM,2,1,0.0D0,0))STOP 'CANNOT READ ORGBOTTOM' IF(.NOT.IDFREADSCALE(ORGHEAD%FNAME,ORGHEAD,2,1,0.0D0,0))STOP 'CANNOT READ ORGHEAD' IF(.NOT.IDFWRITE(ORGHEAD,TRIM(OUTPUTFOLDER)//'\ORGHEAD.IDF',1))STOP IF(.NOT.IDFWRITE(ORGLEVL,TRIM(OUTPUTFOLDER)//'\ORGLEVL.IDF',1))STOP IF(.NOT.IDFWRITE(ORGCOND,TRIM(OUTPUTFOLDER)//'\ORGCOND.IDF',1))STOP IF(.NOT.IDFWRITE(ORGBOTM,TRIM(OUTPUTFOLDER)//'\ORGBOTM.IDF',1))STOP DC=SCALESIZE/ORGHEAD%DX; DR=SCALESIZE/ORGHEAD%DX SCLHEAD%DX=SCALESIZE; SCLHEAD%DY=SCLHEAD%DX CALL UTL_IDFSNAPTOGRID_LLC(SCLHEAD%XMIN,SCLHEAD%XMAX,SCLHEAD%YMIN,SCLHEAD%YMAX,SCLHEAD%DX,SCLHEAD%DY,SCLHEAD%NCOL,SCLHEAD%NROW,LLC=.TRUE.) CALL IDFDEALLOCATEX(SCLHEAD); CALL IDFDEALLOCATESX(SCLHEAD); IF(IDFALLOCATESXY(SCLHEAD))THEN; ENDIF; SCLHEAD%IEQ=0 !; IF(.NOT.IDFFILLSXSY(SCLHEAD))RETURN CALL IDFCOPY(SCLHEAD,SCLLEVL); CALL IDFCOPY(SCLHEAD,SCLCOND); CALL IDFCOPY(SCLHEAD,SCLBOTM) !## upscaled stage,bottom,conductance IF(.NOT.IDFREADSCALE(ORGHEAD%FNAME,SCLHEAD,2,1,0.0D0,0))STOP 'CANNOT READ ORGHEAD' IF(.NOT.IDFREADSCALE(ORGLEVL%FNAME,SCLLEVL,2,1,0.0D0,0))STOP 'CANNOT READ ORGLEVEL' IF(.NOT.IDFREADSCALE(ORGCOND%FNAME,SCLCOND,5,1,0.0D0,0))STOP 'CANNOT READ ORGCONDUCT' IF(.NOT.IDFREADSCALE(ORGBOTM%FNAME,SCLBOTM,2,1,0.0D0,0))STOP 'CANNOT READ ORGBOTTOM' !## save original scaled level SCLHEAD%FNAME=TRIM(OUTPUTFOLDER)//'\SCALED_SCLHEAD.IDF' IF(.NOT.IDFWRITE(SCLHEAD,SCLHEAD%FNAME,1))STOP 'CANNOT SAVE SCLHEAD' SCLCOND%FNAME=TRIM(OUTPUTFOLDER)//'\SCALED_SCLCOND.IDF' IF(.NOT.IDFWRITE(SCLCOND,SCLCOND%FNAME,1))STOP 'CANNOT SAVE SCLCOND' SCLLEVL%FNAME=TRIM(OUTPUTFOLDER)//'\SCALED_SCLLEVL.IDF' IF(.NOT.IDFWRITE(SCLLEVL,SCLLEVL%FNAME,1))STOP 'CANNOT SAVE SCLLEVL' SCLBOTM%FNAME=TRIM(OUTPUTFOLDER)//'\SCALED_SCLBOTM.IDF' IF(.NOT.IDFWRITE(SCLBOTM,SCLBOTM%FNAME,1))STOP 'CANNOT SAVE SCLBOTM' IR2=ORGHEAD%NROW+DR DO IROW=SCLHEAD%NROW,1,-1 IR2=MAX(1,IR2-DR); IR1=MAX(1,IR2-DR-1) IC1=-DC+1 DO ICOL=1,SCLHEAD%NCOL IC1=MIN(ORGHEAD%NCOL,IC1+DC); IC2=MIN(ORGHEAD%NCOL,IC1+DC-1) ! IF(ICOL.EQ.287.AND.IROW.EQ.126)THEN ! WRITE(*,*) ! ENDIF if(irow.eq.453.and.icol.eq.612)then write(*,*) endif !## get total q in fine model TQ=0.0D0 DO JROW=IR1,IR2 DO JCOL=IC1,IC2 IF(ORGHEAD%X(JCOL,JROW).NE.ORGHEAD%NODATA.AND.ORGLEVL%X(JCOL,JROW).NE.ORGLEVL%NODATA)THEN IF(ORGHEAD%X(JCOL,JROW).LT.ORGBOTM%X(JCOL,JROW))THEN DH=ORGLEVL%X(JCOL,JROW)-ORGBOTM%X(JCOL,JROW) ELSE DH=ORGLEVL%X(JCOL,JROW)-ORGHEAD%X(JCOL,JROW) ENDIF ! IF(DH.NE.0.0D0)THEN ! WRITE(*,*) DH ! ENDIF TQ=TQ+DH*ORGCOND%X(JCOL,JROW) ENDIF ENDDO ENDDO !## set level such that average generates same flux !## nett infiltration IF(ILEVEL.EQ.1)THEN IF(TQ.GT.0.0D0)THEN H=-TQ/SCLCOND%X(ICOL,IROW)+SCLHEAD%X(ICOL,IROW) !## nett drainage ELSEIF(TQ.LT.0.0D0)THEN H=-TQ/SCLCOND%X(ICOL,IROW)+SCLHEAD%X(ICOL,IROW) ELSE H=SCLLEVL%NODATA ENDIF !## compute new conductance ELSE IF(TQ.NE.0.0D0)THEN IF(SCLHEAD%X(ICOL,IROW).LT.SCLBOTM%X(ICOL,IROW))THEN DH=SCLLEVL%X(ICOL,IROW)-SCLBOTM%X(ICOL,IROW) ELSE DH=SCLLEVL%X(ICOL,IROW)-SCLHEAD%X(ICOL,IROW) ENDIF IF(DH.NE.0.0D0)THEN H=TQ/DH !## inaccuracy yields conflict IF(H.LT.0.0D0)H=SCLLEVL%NODATA ELSE H=SCLLEVL%NODATA ENDIF ELSE H=SCLLEVL%NODATA ENDIF ENDIF SCLLEVL%X(ICOL,IROW)=H ENDDO ENDDO !## save original scaled level IF(ILEVEL.EQ.1)THEN SCLLEVL%FNAME=TRIM(OUTPUTFOLDER)//'\SCALED_LEVEL_CORRECT.IDF' IF(.NOT.IDFWRITE(SCLLEVL,SCLLEVL%FNAME,1))STOP 'CANNOT SAVE SCALED_LEVEL_CORRECT.IDF' ELSE SCLLEVL%FNAME=TRIM(OUTPUTFOLDER)//'\SCALED_CONDUCTANCE_CORRECT.IDF' IF(.NOT.IDFWRITE(SCLLEVL,SCLLEVL%FNAME,1))STOP 'CANNOT SAVE SCALED_CONDUCTANCE_CORRECT.IDF' ENDIF END SUBROUTINE IMODBATCH_SCALE_ELEVATION_OLD !###====================================================================== SUBROUTINE IMODBATCH_WORKFLOW() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: WORKFLOWFILE TYPE WORKFLOWOBJ INTEGER :: N END TYPE WORKFLOWOBJ TYPE(WORKFLOWOBJ) :: WF IF(.NOT.UTL_READINITFILE('WORKFLOWFILE',LINE,IU,0))RETURN READ(LINE,'(A)') WORKFLOWFILE; WRITE(*,'(A)') 'WORKFLOWFILE='//TRIM(WORKFLOWFILE) CALL IMODBATCH_WORKFLOW_READ(WORKFLOWFILE) END SUBROUTINE IMODBATCH_WORKFLOW !###====================================================================== SUBROUTINE IMODBATCH_WORKFLOW_READ(FNAME) !###====================================================================== IMPLICIT NONE CHARACTER(LEN=*),INTENT(IN) :: FNAME ! JU=UTL_GETUNIT(); OPEN(JU,FILE=FNAME,STATUS=' END SUBROUTINE IMODBATCH_WORKFLOW_READ !###====================================================================== 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(KIND=DP_KIND) :: DZ,MINZ,MAXZ,Z1,Z2 REAL(KIND=DP_KIND),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.0D0; IF(UTL_READINITFILE('DZ',LINE,IU,1))READ(LINE,*) DZ WRITE(*,'(A,F15.3)') '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.0D0,0))STOP 'Cannot read data for IDF(1)' IF(.NOT.IDFREADSCALE(IDF(2)%FNAME,IDF(2),2,1,0.0D0,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) IORDER(I)=I ! initialize 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 UTL_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.0D0; IDF(5)%X=0.0D0 WRITE(*,'(A,2F15.3)') '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.0D0,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.0D0 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.0D0)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(VTOS(Z1,'F',3))//'_'//TRIM(VTOS(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(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) ILGN(I) LINE='ILUSE'//TRIM(VTOS(I))//'='//TRIM(VTOS(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.0D0; MPW%YMIN=0.0D0; MPW%XMAX=0.0D0; MPW%YMAX=0.0D0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) MPW%XMIN,MPW%YMIN,MPW%XMAX,MPW%YMAX WRITE(*,'(A,4F15.3)') '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(KIND=DP_KIND) :: FV,HV,A,B,SIGA,SIGB,CHI2,Q INTEGER,ALLOCATABLE,DIMENSION(:) :: IP REAL(KIND=DP_KIND),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(VTOS(JD1)); WRITE(*,'(A)') 'SDATE='//TRIM(LINE) IF(.NOT.UTL_READINITFILE('EDATE',LINE,IU,0))RETURN READ(LINE,*) JD2; LINE=TRIM(VTOS(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=INT(UTL_IDFGETDATE(FLISTNAME(I)),4); IF(F(I)%JD.NE.0)F(I)%JD=UTL_IDATETOJDATE(F(I)%JD); ENDDO DO I=1,SIZE(HLISTNAME); H(I)%JD=INT(UTL_IDFGETDATE(HLISTNAME(I)),4); 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.0D0; MWT=0 OPEN(10,FILE='D:\DUMP\REGRESSION.TXT',STATUS='REPLACE') 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.0D0,MIN(1.0D0,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(KIND=DP_KIND) :: DSIZE,X1,Y1,X,Y,F,MINSIZE,CSIZE,DX,DY,MAXS REAL(KIND=DP_KIND),DIMENSION(4) :: BOXS REAL(KIND=DP_KIND),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,IRCB INTEGER :: MAXDEELMOD INTEGER,ALLOCATABLE,DIMENSION(:,:) :: DEELMOD TYPE POLOBJ REAL(KIND=DP_KIND) :: X1,X2,Y1,Y2,CS,XMIN,YMIN,XMAX,YMAX INTEGER :: ILOAD INTEGER :: ID CHARACTER(LEN=52) :: NAME END TYPE POLOBJ TYPE(POLOBJ),ALLOCATABLE,DIMENSION(:,:) :: POL ALLOCATE(IDF(2)); DO I=1,SIZE(IDF); CALL IDFNULLIFY(IDF(I)); ENDDO IRCB=0; IF(UTL_READINITFILE('IRCB',LINE,IU,1))READ(LINE,*) IRCB IF(IRCB.EQ.1)THEN !## uniform PBMAN%PARTOPT=1 IF(UTL_READINITFILE('PARTOPT',LINE,IU,1))READ(LINE,*) PBMAN%PARTOPT LINE='PARTOPT='; WRITE(*,'(A)') TRIM(LINE)//TRIM(VTOS(PBMAN%PARTOPT)) PBMAN%PARTOPT=PBMAN%PARTOPT-1 SELECT CASE (PBMAN%PARTOPT) CASE (0); WRITE(*,'(/A)') 'UNIFORM SUBMODELLING SELECTED' CASE (1); WRITE(*,'(/A)') 'RCB SUBMODELLING SELECTED' CASE (2); WRITE(*,'(/A)') 'RCB WEIGHTED SUBMODELLING SELECTED' CASE DEFAULT; STOP 'WRONG PARTOPT SELECTED, PICK 1,2 OR 3' END SELECT IF(.NOT.UTL_READINITFILE('NRPROC',LINE,IU,0))STOP READ(LINE,*) PBMAN%NRPROC; LINE='NRPROC='; WRITE(*,'(A)') TRIM(LINE)//TRIM(VTOS(PBMAN%NRPROC)) IF(PBMAN%PARTOPT.GT.0)THEN IF(.NOT.UTL_READINITFILE('LOADFILE',LINE,IU,0))RETURN READ(LINE,'(A)') PBMAN%LOADFILE; LINE='LOADFILE='; WRITE(*,'(A)') TRIM(LINE)//TRIM(PBMAN%LOADFILE) IF(.NOT.IDFREAD(IDF(1),PBMAN%LOADFILE,0))STOP 'CANNOT LOAD LOADFILE' ENDIF IF(.NOT.UTL_READINITFILE('GENFILE',LINE,IU,0))RETURN READ(LINE,'(A)') SUBMODELFILE; LINE='GENFILE='; WRITE(*,'(A)') TRIM(LINE)//TRIM(SUBMODELFILE) JU=UTL_GETUNIT(); OPEN(JU,FILE=SUBMODELFILE,STATUS='REPLACE',ACTION='WRITE') CALL PKS_INIT(-JU,IDF(1)) CLOSE(JU) STOP ENDIF !## smaller than to be possible to be added to another one F=0.25D0 MINSIZE=0.0D0 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 IF(UTL_READINITFILE('MINSIZE',LINE,IU,1))THEN READ(LINE,*) MINSIZE; WRITE(*,'(A,F10.2)') 'MINSIZE=',MINSIZE ENDIF 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 CALL IDFCOPY(IDF(1),IDF(2)); IDF(2)%X=IDF(2)%NODATA 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) CALL UTL_CREATEDIR(SUBMODELFILE(:INDEX(SUBMODELFILE,'\',.TRUE.)-1)) JU=UTL_GETUNIT(); OPEN(JU,FILE=TRIM(SUBMODELFILE)//'.RUN',STATUS='REPLACE',ACTION='WRITE') KU=UTL_GETUNIT(); OPEN(KU,FILE=TRIM(SUBMODELFILE)//'.GEN',STATUS='REPLACE',ACTION='WRITE') LU=UTL_GETUNIT(); OPEN(LU,FILE=TRIM(SUBMODELFILE)//'.IPF',STATUS='REPLACE',ACTION='WRITE') IDF(2)%FNAME=TRIM(SUBMODELFILE)//'.IDF' MU=UTL_GETUNIT(); OPEN(MU,FILE=TRIM(SUBMODELFILE)//'.TXT',STATUS='REPLACE',ACTION='WRITE') 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)); POL%ILOAD=0 !## 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(VTOS(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 ENDDO; ENDDO ! WRITE(*,*) POL(I,J)%ILOAD !## 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).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 !## set load = zero for load < minsize DO I=1,SIZE(POL,1); DO J=1,SIZE(POL,2) IF(POL(I,J)%ILOAD.LT.MINSIZE)POL(I,J)%ILOAD=0 ENDDO; ENDDO 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) CASE (1) !## left IF(POL(I,J)%X2-POL(I-1,J)%X1.LT.DSIZE*(1.0D0+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.0D0+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.0D0+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.0D0+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 !## 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.0D0) 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(VTOS(POL(I,J)%ID)) MAXDEELMOD=MAX(MAXDEELMOD,POL(I,J)%ID) ENDIF ENDIF ;ENDDO ; ENDDO !## Write GEN and RUN file 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.0D0,','//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 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 ! IF(IDF(1)%X(ICOL,IROW).GT.0.0D0) 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.5D0*(POL(I,J)%X1+POL(I,J)%X2), 0.5D0*(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.AND.IDF(2)%X(ICOL,IROW).NE.IDF(2)%NODATA)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.0D0,','//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(KIND=DP_KIND) :: 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(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) IDF(I,1)%FNAME; LINE='TOP_L'//TRIM(VTOS(I))//'='; WRITE(*,'(A)') TRIM(LINE)//TRIM(IDF(I,1)%FNAME) IF(.NOT.UTL_READINITFILE('BOT_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) IDF(I,2)%FNAME; LINE='BOT_L'//TRIM(VTOS(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.0D0)EXIT IDF(I,1)%X(ICOL,IROW)=0.0D0 ENDDO DO J=I,1,-1; IDF(J,1)%X(ICOL,IROW)=1.0D0; ENDDO ENDDO; ENDDO CALL UTL_CREATEDIR(RESULTDIR) DO I=1,NLAY IDF(I,1)%FNAME=TRIM(RESULTDIR)//'\IBOUND_L'//TRIM(VTOS(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 CHARACTER(LEN=52) :: CID INTEGER :: I,IOS,ID REAL(KIND=DP_KIND) :: XSAMPLING INTEGER,DIMENSION(2) :: JU REAL(KIND=DP_KIND),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.0D0; 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='REPLACE',ACTION='WRITE') DO I=1,SIZE(IDF); IF(.NOT.IDFREAD(IDF(I),IDF(I)%FNAME,0))RETURN; ENDDO IF(XSAMPLING.EQ.0.0D0)XSAMPLING=IDF(1)%DX WRITE(*,'(A,F10.2)') 'XSAMPLING=',XSAMPLING DO READ(JU(1),*,IOSTAT=IOS) CID IF(TRIM(UTL_CAP(CID,'U')).EQ.'END')EXIT IF(IOS.NE.0)THEN WRITE(*,'(/A/)') '>>> THIS FUNCTIONS WORKS WITH THE OLD-FASHIONED ASCII-GENFILES ONLY <<<'; PAUSE; STOP ENDIF 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(CID,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_IPESTSUBM() ! !###====================================================================== ! IMPLICIT NONE ! CHARACTER(LEN=256) :: PRJFILE ! CALL PMANAGER_UTL_INIT() ! IF(.NOT.UTL_READINITFILE('PRJFILE',LINE,IU,0))RETURN ! READ(LINE,*) PRJFILE; WRITE(*,'(2A)') 'PRJFILE='//TRIM(PRJFILE) ! END SUBROUTINE IMODBATCH_IPESTSUBM !###====================================================================== SUBROUTINE IMODBATCH_RUNFILE() !###====================================================================== IMPLICIT NONE INTEGER,DIMENSION(4) :: TMPINT1,TMPINT2 CALL PMANAGER_UTL_INIT() IF(UTL_READINITFILE('RUNFILE_IN',LINE,IU,1))THEN !## option 1: convert RUN file to PRJ file READ(LINE,*) PBMAN%RUNFILE; WRITE(*,'(A,A)') 'RUNFILE_IN=',TRIM(PBMAN%RUNFILE) IF(.NOT.UTL_READINITFILE('PRJFILE_OUT',LINE,IU,0))RETURN READ(LINE,*) PBMAN%PRJFILE WRITE(*,'(A,A)') 'PRJFILE_OUT=',TRIM(PBMAN%PRJFILE) IF(.NOT.PMANAGERRUN(ID_OPENRUN,PBMAN%RUNFILE,1) )THEN; WRITE(*,'(/A/)') 'Error reading runfile '//TRIM(PBMAN%RUNFILE); STOP; ENDIF IF(.NOT.PMANAGERPRJ(ID_SAVE ,PBMAN%PRJFILE,1,0))THEN; WRITE(*,'(/A/)') 'Error writing project file '//TRIM(PBMAN%PRJFILE); STOP; ENDIF ELSEIF(UTL_READINITFILE('PRJFILE_IN',LINE,IU,1))THEN !## option 2: read PRJ file and create model READ(LINE,*) PBMAN%PRJFILE; WRITE(*,'(2A)') 'PRJFILE_IN='//TRIM(PBMAN%PRJFILE) !## read parameters IF(.NOT.IMODBATCH_RUNFILE_READ(IU,1))STOP CALL WINDOWOPEN(FLAGS=SYSMENUON+HIDEWINDOW+STATUSBAR) TMPINT1=[2000,2000,750,-1]; TMPINT2=[1,1,1,1] CALL WINDOWSTATUSBARPARTS(4,TMPINT1,TMPINT2) IF(.NOT.PMANAGERPRJ(ID_OPEN ,PBMAN%PRJFILE,1,0))THEN; WRITE(*,'(/A/)') 'Error reading project file '//TRIM(PBMAN%PRJFILE); STOP; ENDIF IF(PBMAN%NCYCLE.EQ.0)THEN IF(.NOT.PMANAGERRUN(ID_SAVERUN,PBMAN%RUNFILE,1) )THEN; WRITE(*,'(/A/)') 'Error writing project file '//TRIM(PBMAN%RUNFILE); STOP; ENDIF ELSE !## output map IF(.NOT.PMANAGER_SEP_RUNS(ID_SAVERUN,PBMAN%RUNFILE,1) )THEN; WRITE(*,'(/A/)') 'Error starting seperate runs from '//TRIM(PBMAN%RUNFILE); STOP; ENDIF ENDIF ELSE WRITE(*,'(/A/)') 'Stop not appropriate conversion mode found'; STOP ENDIF CALL WINDOWCLOSE() END SUBROUTINE IMODBATCH_RUNFILE !###====================================================================== SUBROUTINE IMODBATCH_FAULTS3D() !###====================================================================== IMPLICIT NONE REAL(KIND=DP_KIND),PARAMETER :: PI=3.1415 REAL(KIND=DP_KIND),PARAMETER :: RAD=360.0D0/(2.0D0*3.1415D0) CHARACTER(LEN=256) :: CSVFILE,GENFILE INTEGER :: I,ID,IOS REAL(KIND=DP_KIND) :: 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='REPLACE',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.3)') X1,Y1,Z1 WRITE(JU(2),'(3F15.3)') 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.0D0)TNG=0.0D0; IF(ABS(DY).GT.0.0D0)TNG=ATAN2(DY,DX) 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.3)') XN2,YN2,Z2 WRITE(JU(2),'(3F15.3)') 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(CID,JU,IDF,X,Y,XSAMPLING) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: JU CHARACTER(LEN=*),INTENT(IN) :: CID TYPE(IDFOBJ),DIMENSION(2),INTENT(INOUT) :: IDF REAL(KIND=DP_KIND),DIMENSION(2),INTENT(IN) :: X,Y REAL(KIND=DP_KIND) :: TD,D,X1,X2,Y1,Y2,DM REAL(KIND=DP_KIND),DIMENSION(2) :: Z1,Z2 REAL(KIND=DP_KIND),INTENT(IN) :: XSAMPLING REAL(KIND=DP_KIND) :: DX,DY,OR INTEGER :: I DX=X(2)-X(1); DY=Y(2)-Y(1); DM=0.0D0; IF(DX.NE.0.0D0.OR.DY.NE.0.0D0)DM=SQRT(DX**2.0D0+DY**2.0D0); TD=0.0D0 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.0D0+(Y2-Y1)**2.0D0); TD=TD+D IF(TD.GT.DM)THEN; X2=X(2); Y2=Y(2); ENDIF Z1(1)=IDFGETXYVAL(IDF(1),X1,Y1); Z2(1)=IDFGETXYVAL(IDF(1),X2,Y2); Z1(2)=IDFGETXYVAL(IDF(2),X1,Y1); Z2(2)=IDFGETXYVAL(IDF(2),X2,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,'(A,I5.5)') TRIM(CID)//'-',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 EXPORTFNAME='' IF(.NOT.UTL_READINITFILE('ISGFILE',LINE,IU,0))RETURN READ(LINE,*) ISGFILE; WRITE(*,'(A)') 'ISGFILE='//TRIM(ISGFILE) IF(.NOT.UTL_READINITFILE('IEXPORT',LINE,IU,0))RETURN READ(LINE,*) IEXPORT SELECT CASE (IEXPORT) CASE (1) LINE='IEXPORT='//TRIM(VTOS(IEXPORT))//' exporting stages' WRITE(*,'(A)') TRIM(LINE) CASE (2) LINE='IEXPORT='//TRIM(VTOS(IEXPORT))//' exporting cross-sections' WRITE(*,'(A)') TRIM(LINE) CASE (0) LINE='IEXPORT='//TRIM(VTOS(IEXPORT))//' exporting all' WRITE(*,'(A)') TRIM(LINE) CASE DEFAULT STOP 'No proper value for IEXPORT given' END SELECT IF(IEXPORT.NE.0)THEN IF(.NOT.UTL_READINITFILE('EXPORTFNAME',LINE,IU,0))RETURN READ(LINE,*) EXPORTFNAME; WRITE(*,'(A)') 'EXPORTFNAME='//TRIM(EXPORTFNAME) ELSE IF(.NOT.UTL_READINITFILE('EXPORTMAP',LINE,IU,0))RETURN READ(LINE,*) EXPORTFNAME; WRITE(*,'(A)') 'EXPORTMAP='//TRIM(EXPORTFNAME) CALL UTL_CREATEDIR(EXPORTFNAME) ENDIF CALL ISG_EXPORT(ISGFILE,EXPORTFNAME,IEXPORT,1) END SUBROUTINE IMODBATCH_ISGEXPORT !###====================================================================== SUBROUTINE IMODBATCH_ISGIMPORT() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: ISGFILE,EXPORTFNAME,LINE ISGDOUBLE=0 IF(.NOT.UTL_READINITFILE('ISGEXPORT',LINE,IU,0))RETURN READ(LINE,*) EXPORTFNAME; WRITE(*,'(A)') 'ISGEXPORT='//TRIM(EXPORTFNAME) IF(.NOT.UTL_READINITFILE('ISGFILE',LINE,IU,0))RETURN READ(LINE,*) ISGFILE; WRITE(*,'(A)') 'ISGFILE='//TRIM(ISGFILE) IF(UTL_READINITFILE('ISGDOUBLE',LINE,IU,1))READ(LINE,*) ISGDOUBLE WRITE(*,'(A)') 'ISGDOUBLE='//TRIM(VTOS(ISGDOUBLE)) ISGDOUBLE=(ISGDOUBLE+1)*4 CALL ISG_IMPORT(ISGFILE,EXPORTFNAME) !,1) END SUBROUTINE IMODBATCH_ISGIMPORT !###====================================================================== SUBROUTINE IMODBATCH_ISGADDSTAGES() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: IPFFILE,ISGFILE INTEGER :: STAGETYPE,ICLEAN 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(VTOS(STAGETYPE)); WRITE(*,'(A)') TRIM(LINE) ICLEAN=0; IF(UTL_READINITFILE('ICLEAN',LINE,IU,1))READ(LINE,*) ICLEAN LINE='ICLEAN='//TRIM(VTOS(ICLEAN)); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('ISGFILE_OUT',LINE,IU,0))RETURN CALL ISG_ADDSTAGES(ISGFILE,IPFFILE,1,STAGETYPE,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_ISGADDSTAGES !###====================================================================== SUBROUTINE IMODBATCH_ISGADDCROSSSECTION() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: ISGFILE,FNAME,WIDTHFNAME,CROSS_PNTR,CROSS_BATH,CROSS_ZCHK,CROSS_CVAL REAL(KIND=DP_KIND) :: MAXDIST INTEGER :: ICLEAN MAXDIST=0.0D0; ICLEAN=1; CROSS_PNTR=''; CROSS_BATH=''; WIDTHFNAME='' IF(UTL_READINITFILE('CROSSSECTION_IN',LINE,IU,1))THEN READ(LINE,*) FNAME; WRITE(*,'(A)') 'CROSSSECTION_IN='//TRIM(FNAME) IF(UTL_READINITFILE('ICLEAN',LINE,IU,0))READ(LINE,*) ICLEAN WRITE(*,'(A,I1)') 'ICLEAN=',ICLEAN IF(ICLEAN.LT.1.OR.ICLEAN.GT.2)STOP 'ICLEAN NEED TO BE 1 OR 2' 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(UTL_READINITFILE('MAXDIST',LINE,IU,1))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) !## optional arguments 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 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,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 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,*) STRUCIPFFNAME; WRITE(*,'(A)') 'IPFFILE_IN='//TRIM(STRUCIPFFNAME) IX=1; IY=2; ID=3; IO=4; IS=5; IW=6; MAXDIST=1000.0D0; SY=1980; EY=2012 CSPS='01-04'; CEPS='30-09'; CSPW='01-10'; CEPW='31-03'; CMD='0-0-0'; LOGFNAME='log.ipf'; ICORDIR=0 !## 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,*) IWISG; WRITE(*,'(A,I2)') 'IWCOL=',IWISG !## 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) IF(UTL_READINITFILE('ICORDIR',LINE,IU,1))READ(LINE,*) ICORDIR; WRITE(*,'(A,I2)') 'ICORDIR=',ICORDIR 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_FOSM() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: COVFILE,SENSDIR,FAILURE INTEGER :: JU,I,II,J,JJ,N,M,NLAYERS,NDATES,IOS,SUMSENS,KU INTEGER,POINTER,DIMENSION(:) :: ILAYERS CHARACTER(LEN=32),POINTER,DIMENSION(:) :: CDATES TYPE(PARAMOBJ),ALLOCATABLE,DIMENSION(:) :: PARAM ! CHARACTER(LEN=16) :: ACRONYM REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:,:) :: COV,OCOV !## get covariance file IF(UTL_READINITFILE('COVFILE',LINE,IU,1))READ(LINE,*) COVFILE WRITE(*,'(A)') 'COVFILE='//TRIM(COVFILE) JU=UTL_GETUNIT(); OPEN(JU,FILE=COVFILE,STATUS='OLD',ACTION='READ') ! KU=UTL_GETUNIT(); OPEN(KU,FILE='d:\IMOD-MODELS\A27_2023\RESULTS\CALIBRATION_V1_STEADY_V16_POSTERIOR\SENS\param.txt',STATUS='OLD',ACTION='READ') !## number of parameters READ(JU,*) N ALLOCATE(PARAM(N)) !## read headers READ(JU,*) !## read parameters DO I=1,N READ(JU,*) PARAM(I)%IPARAM,PARAM(I)%IACT,PARAM(I)%PTYPE,PARAM(I)%ILS,PARAM(I)%IZONE,PARAM(I)%IGROUP,PARAM(I)%ACRONYM ! READ(KU,*) ACRONYM,PARAM(I)%PMIN,PARAM(I)%PINI,PARAM(I)%PMAX ! IF(.NOT.TRIM(ACRONYM).EQ.TRIM(PARAM(I)%ACRONYM))THEN ! WRITE(*,*) TRIM(ACRONYM),TRIM(PARAM(I)%ACRONYM) ! ENDIF ENDDO !## read empty lines DO I=1,7; READ(JU,*); ENDDO !## read covariance matrix ALLOCATE(OCOV(N,N)); OCOV=0.0D0 DO I=1,N READ(JU,'(A15,9999(1X,F15.0))',IOSTAT=IOS) PARAM(I)%ACRONYM,(OCOV(I,J),J=1,N) IF(IOS.NE.0)THEN WRITE(*,'(/A/)') '>>> ERROR READING LINE '//TRIM(VTOS(I))//' <<<' ENDIF ENDDO CLOSE(JU) !; CLOSE(KU) !## see what parameters are off M=0; DO I=1,N; IF(PARAM(I)%IACT.EQ.1)M=M+1; ENDDO IF(M.NE.N)THEN ALLOCATE(COV(M,M)) II=0; DO I=1,N JJ=0; IF(PARAM(I)%IACT.NE.1)CYCLE II=II+1 DO J=1,N IF(PARAM(J)%IACT.NE.1)CYCLE JJ=JJ+1 COV(II,JJ)=OCOV(I,J) ENDDO ENDDO N=M ELSE ALLOCATE(COV(N,N)); COV=OCOV ENDIF DEALLOCATE(OCOV) IF(.NOT.UTL_READPOINTER(IU,NLAYERS,ILAYERS,'ILAYERS',0))RETURN DO I=1,NLAYERS; WRITE(*,'(1X,I3,A)') I,','//TRIM(VTOS(ILAYERS(I))); ENDDO IF(.NOT.UTL_READPOINTER(IU,NDATES,CDATES,'CDATES',0))RETURN DO I=1,NDATES; WRITE(*,'(1X,I3,A)') I,','//TRIM(CDATES(I)); ENDDO !## get sensitivities IF(.NOT.UTL_READINITFILE('SENSDIR',LINE,IU,0))RETURN READ(LINE,*) SENSDIR; WRITE(*,'(A)') 'SENSDIR='//TRIM(SENSDIR) IF(.NOT.UTL_READINITFILE('FAILURE',LINE,IU,0))RETURN READ(LINE,*) FAILURE; WRITE(*,'(A)') 'FAILURE='//TRIM(FAILURE) SUMSENS=0 IF(UTL_READINITFILE('SUMSENS',LINE,IU,1))THEN READ(LINE,*) SUMSENS; WRITE(*,'(A)') 'SUMSENS='//TRIM(VTOS(SUMSENS)) ENDIF DO I=1,NDATES DO J=1,NLAYERS CALL IMODBATCH_COMPUTE_FOSM(N,COV,ILAYERS(J),CDATES(I),SENSDIR,FAILURE,PARAM,SUMSENS) ENDDO ENDDO END SUBROUTINE IMODBATCH_FOSM !#####================================================================= SUBROUTINE IMODBATCH_COMPUTE_FOSM(N,COV,ILAY,CDATE,SENSDIR,FAILURE,PARAM,SUMSENS) !#####================================================================= IMPLICIT NONE INTEGER,INTENT(IN) :: N,ILAY,SUMSENS REAL(KIND=DP_KIND),INTENT(IN),DIMENSION(N,N) :: COV CHARACTER(LEN=*),INTENT(IN) :: CDATE,SENSDIR,FAILURE TYPE(PARAMOBJ),DIMENSION(:),INTENT(IN) :: PARAM INTEGER :: I,J,JJ,II,IROW,ICOL,IOS,THREAD_ID,TN,NODES TYPE(IDFOBJ) :: H,A,BETA,ISUMS CHARACTER(LEN=256) :: FNAME REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:,:) :: JCBN !,FOSM REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: PROW REAL(KIND=DP_KIND) :: MU,SIGMA,X,CDF,F,DF CALL UTL_CREATEDIR(TRIM(SENSDIR)//CHAR(92)//'UNCERTAINTY') CALL UTL_CREATEDIR(TRIM(SENSDIR)//CHAR(92)//'RELIABILITY_INDEX') CALL UTL_CREATEDIR(TRIM(SENSDIR)//CHAR(92)//'PROB_OF_FAILURE') JJ=0; DO J=1,SIZE(PARAM) IF(PARAM(J)%IACT.NE.1)CYCLE JJ=JJ+1 FNAME=TRIM(SENSDIR)//CHAR(92)//'P#'//TRIM(VTOS(PARAM(J)%IPARAM))//'\SENS_'//TRIM(CDATE)//'_L'//TRIM(VTOS(ILAY))//'.IDF' WRITE(*,'(A)') 'Reading '//TRIM(FNAME)//' ...' IF(.NOT.IDFREAD(H,FNAME,1))RETURN IF(SUMSENS.EQ.1)THEN IF(.NOT.ASSOCIATED(ISUMS%X))THEN; CALL IDFCOPY(H,ISUMS); ISUMS%X=0.0D0; ENDIF ENDIF IF(.NOT.ALLOCATED(JCBN))ALLOCATE(JCBN(H%NCOL*H%NROW,N),PROW(N)) II=0; DO IROW=1,H%NROW; DO ICOL=1,H%NCOL II=II+1 IF(H%X(ICOL,IROW).EQ.H%NODATA.OR.H%X(ICOL,IROW).EQ.0.0D0)THEN JCBN(II,JJ)=0.0D0 ELSE ! !## correct sensitivity ! DF=1.1D0 ! if(icol.eq.271.and.irow.eq.388)then ! write(*,*) H%X(ICOL,IROW) ! endif ! H%X(ICOL,IROW)=H%X(ICOL,IROW)*LOG(DF) ! !## correct sensitivity ! DF=LOG(PARAM(J)%PINI)+LOG(DF) ! DF=EXP(DF) ! DF=DF-PARAM(J)%PINI ! H%X(ICOL,IROW)=H%X(ICOL,IROW)/DF JCBN(II,JJ)=H%X(ICOL,IROW) IF(SUMSENS.EQ.1)ISUMS%X(ICOL,IROW)=ISUMS%X(ICOL,IROW)+H%X(ICOL,IROW) ! if(icol.eq.271.and.irow.eq.388)then ! write(*,*) ISUMS%X(ICOL,IROW),H%X(ICOL,IROW) !,df ! endif ENDIF ENDDO; ENDDO ! CALL IDFDEALLOCATEX(H) ENDDO ! IF(.NOT.IDFALLOCATEX(H))THEN; ENDIF IF(SUMSENS.EQ.1)THEN FNAME=TRIM(SENSDIR)//CHAR(92)//'SUMSENS'//CHAR(92)//'SUMSENS_'//TRIM(CDATE)//'_L'//TRIM(VTOS(ILAY))//'.IDF' WRITE(*,'(A)') 'Writing '//TRIM(FNAME)//' ...' IF(.NOT.IDFWRITE(ISUMS,FNAME,1))RETURN CALL IDFDEALLOCATEX(ISUMS) ENDIF ! ALLOCATE(FOSM(H%NCOL*H%NROW,H%NCOL*H%NROW)) ! FOSM=MATMUL(MATMUL(JCBN,COV),TRANSPOSE(JCBN)) ! ICOL=0; IROW=1; DO II=1,H%NROW*H%NCOL ! ICOL=ICOL+1; IF(ICOL.GT.H%NCOL)THEN; ICOL=1; IROW=IROW+1; ENDIF ! H%X(ICOL,IROW)=SQRT(FOSM(II,II)) ! ENDDO ! CALL UTL_SETTHREADS() ! !$OMP PARALLEL PRIVATE(J,H1,H2,W,TS) SHARED (S,MSR,DF1) ! !$OMP DO ! !$OMP END DO ! !$OMP CRITICAL ! !$OMP END CRITICAL ! !$OMP END PARALLEL !## received the variance per location H%X=0.0D0 ! !$OMP PARALLEL PRIVATE(I,F,PROW) SHARED (II,ICOL,IROW,JCBN,COV,N,H) !## compute jcbn*cov*jcbn, process per row !$OMP PARALLEL PRIVATE(IROW,ICOL,II,PROW) SHARED (JCBN,COV,H,N,TN) ! PN=0 TN=0 NODES=H%NROW*H%NCOL !$OMP DO DO IROW=1,H%NROW DO ICOL=1,H%NCOL II=(IROW-1)*H%NCOL+ICOL ! PN=PN+1 PROW=0.0D0 DO I=1,N; DO J=1,N PROW(I)=PROW(I)+JCBN(II,J)*COV(I,J) ENDDO; ENDDO H%X(ICOL,IROW)=0.0D0 DO I=1,N H%X(ICOL,IROW)=H%X(ICOL,IROW)+PROW(I)*JCBN(II,I) ENDDO IF(H%X(ICOL,IROW).GT.0.0D0)THEN H%X(ICOL,IROW)=SQRT(H%X(ICOL,IROW)) ELSE H%X(ICOL,IROW)=H%NODATA ENDIF TN=TN+1 !## only echo for first process #if(defined(DEFPARALLEL)) THREAD_ID=OMP_GET_THREAD_NUM() ! WRITE(*,*) THREAD_ID,IROW,ICOL,II #else THREAD_ID=0 #endif IF(THREAD_ID.EQ.0)THEN F=REAL(TN*100,8)/REAL(NODES,8) WRITE(6,'(A)') '+Progress '//TRIM(VTOS(F,'F',3))//' %' ENDIF ENDDO ENDDO !$OMP END DO !!$OMP BARRIER !!$OMP CRITICAL !!$OMP END CRITICAL !$OMP END PARALLEL !## write results FNAME=TRIM(SENSDIR)//CHAR(92)//'UNCERTAINTY'//CHAR(92)//'UNCERTAINTY_'//TRIM(CDATE)//'_L'//TRIM(VTOS(ILAY))//'.IDF' WRITE(*,'(A)') 'Writing '//TRIM(FNAME)//' ...' IF(.NOT.IDFWRITE(H,FNAME,1))RETURN CALL IDFCOPY(H,A); CALL IDFCOPY(H,BETA) IF(.NOT.IDFREADSCALE(FAILURE,A,2,1,0.0D0,0))RETURN DO IROW=1,H%NROW; DO ICOL=1,H%NCOL !## set nodata for deviation<=0 IF(H%X(ICOL,IROW).LE.0.0D0)THEN BETA%X(ICOL,IROW)=BETA%NODATA !## compute reliability index ELSE BETA%X(ICOL,IROW)=A%X(ICOL,IROW)/H%X(ICOL,IROW) ENDIF ENDDO; ENDDO !## write results READ(FAILURE,*,IOSTAT=IOS) X IF(IOS.EQ.0)THEN FNAME=TRIM(SENSDIR)//CHAR(92)//'RELIABILITY_INDEX'//CHAR(92)//'RELIABILITY_INDEX'//TRIM(FAILURE)//'_'//TRIM(CDATE)//'_L'//TRIM(VTOS(ILAY))//'.IDF' ELSE FNAME=TRIM(SENSDIR)//CHAR(92)//'RELIABILITY_INDEX'//CHAR(92)//'RELIABILITY_INDEX'//TRIM(CDATE)//'_L'//TRIM(VTOS(ILAY))//'.IDF' ENDIF WRITE(*,'(A)') 'Writing '//TRIM(FNAME)//' ...' IF(.NOT.IDFWRITE(BETA,FNAME,1))RETURN DO IROW=1,H%NROW; DO ICOL=1,H%NCOL !## compute probability of failure IF(H%X(ICOL,IROW).LE.0.0D0)THEN A%X(ICOL,IROW)=A%NODATA ELSE SIGMA=H%X(ICOL,IROW) MU=0.0D0 X=A%X(ICOL,IROW) CALL NORMAL_CDF(X,MU,SIGMA,CDF) A%X(ICOL,IROW)=1.0D0-CDF ENDIF ENDDO; ENDDO !## write results READ(FAILURE,*,IOSTAT=IOS) X IF(IOS.EQ.0)THEN FNAME=TRIM(SENSDIR)//CHAR(92)//'PROB_OF_FAILURE'//CHAR(92)//'PROB_OF_FAILURE_'//TRIM(FAILURE)//'_'//TRIM(CDATE)//'_L'//TRIM(VTOS(ILAY))//'.IDF' ELSE FNAME=TRIM(SENSDIR)//CHAR(92)//'PROB_OF_FAILURE'//CHAR(92)//'PROB_OF_FAILURE_'//TRIM(CDATE)//'_L'//TRIM(VTOS(ILAY))//'.IDF' ENDIF WRITE(*,'(A)') 'Writing '//TRIM(FNAME)//' ...' IF(.NOT.IDFWRITE(A,FNAME,1))RETURN CALL IDFDEALLOCATEX(H); DEALLOCATE(JCBN,PROW); CALL IDFDEALLOCATEX(A) END SUBROUTINE IMODBATCH_COMPUTE_FOSM !###====================================================================== SUBROUTINE IMODBATCH_CREATELAYERS_MAIN() !###====================================================================== IMPLICIT NONE TYPE(IDFOBJ),DIMENSION(:),ALLOCATABLE :: IDF CHARACTER(LEN=256) :: OUTPUTFOLDER INTEGER :: I,ILAY,NLAY,IROW,ICOL REAL(KIND=DP_KIND) :: ZTOP,ZBOT,F REAL(KIND=DP_KIND),POINTER,DIMENSION(:) :: DZVAL I=3; ALLOCATE(IDF(I)); DO I=1,SIZE(IDF); CALL IDFNULLIFY(IDF(I)); ENDDO IDF(1)%FNAME='' IDF(3)%FNAME='' IF(.NOT.UTL_READINITFILE('TOPLEVELIDF',LINE,IU,0))RETURN READ(LINE,*) IDF(1)%FNAME; WRITE(*,'(A)') 'TOPLEVELIDF='//TRIM(IDF(1)%FNAME) IF(UTL_READINITFILE('BOTLEVELIDF',LINE,IU,1))THEN READ(LINE,*) IDF(3)%FNAME; WRITE(*,'(A)') 'BOTLEVELIDF='//TRIM(IDF(3)%FNAME) ENDIF IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) IDF(1)%XMIN,IDF(1)%YMIN,IDF(1)%XMAX,IDF(1)%YMAX WRITE(*,'(A,4F15.2)') 'WINDOW=',IDF(1)%XMIN,IDF(1)%YMIN,IDF(1)%XMAX,IDF(1)%YMAX IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,0))RETURN READ(LINE,*) IDF(1)%DX; WRITE(*,'(A,4F15.3)') 'CELLSIZE=',IDF(1)%DX; IDF(1)%DY=IDF(1)%DX CALL UTL_IDFSNAPTOGRID_LLC(IDF(1)%XMIN,IDF(1)%XMAX,IDF(1)%YMIN,IDF(1)%YMAX,IDF(1)%DX,IDF(1)%DY,IDF(1)%NCOL,IDF(1)%NROW,LLC=.TRUE.) IF(.NOT.IDFREADSCALE(IDF(1)%FNAME,IDF(1),2,1,0.0D0,0))THEN; RETURN; ENDIF ELSE IF(.NOT.IDFREAD(IDF(1),IDF(1)%FNAME,1))THEN; ENDIF ENDIF IF(TRIM(IDF(3)%FNAME).NE.'')THEN CALL IDFCOPY(IDF(1),IDF(3)) IF(.NOT.IDFREADSCALE(IDF(3)%FNAME,IDF(3),2,1,0.0D0,0))THEN; RETURN; ENDIF ENDIF IF(.NOT.UTL_READPOINTER(IU,I,DZVAL,'DZVAL',0,EXCLVALUE=0.0D0))RETURN DO I=1,SIZE(DZVAL) IF(DZVAL(I).LE.0.0D0)THEN LINE='DZ('//TRIM(VTOS(I))//')='//TRIM(VTOS(DZVAL(I),'F',3)) WRITE(*,'(A)') TRIM(LINE)//' which is not allowed' ENDIF ENDDO NLAY=SIZE(DZVAL) IF(.NOT.UTL_READINITFILE('OUTPUTFOLDER',LINE,IU,0))RETURN READ(LINE,*) OUTPUTFOLDER; WRITE(*,'(A)') 'OUTPUTFOLDER='//TRIM(OUTPUTFOLDER) IF(TRIM(IDF(3)%FNAME).NE.'')THEN DO IROW=1,IDF(1)%NROW; DO ICOL=1,IDF(1)%NCOL ZTOP=IDF(1)%X(ICOL,IROW) ZBOT=IDF(3)%X(ICOL,IROW) !## compute F to fit the layers F=(ZTOP-ZBOT)/SUM(DZVAL) IDF(3)%X(ICOL,IROW)=F ENDDO; ENDDO ! IDF(3)%FNAME='D:\TMP.IDF' ! IF(.NOT.IDFWRITE(IDF(3),IDF(3)%FNAME,0))STOP ENDIF CALL IDFCOPY(IDF(1),IDF(2)) !## write top layer IDF(1)%FNAME=TRIM(OUTPUTFOLDER)//'\INT_L1.IDF' IF(.NOT.IDFWRITE(IDF(1),IDF(1)%FNAME,1))STOP DO ILAY=2,NLAY+1 DO IROW=1,IDF(1)%NROW; DO ICOL=1,IDF(1)%NCOL IF(TRIM(IDF(3)%FNAME).NE.'')THEN F=IDF(3)%X(ICOL,IROW) ELSE F=1.0D0 ENDIF IF(IDF(1)%X(ICOL,IROW).EQ.IDF(1)%NODATA)CYCLE IDF(2)%X(ICOL,IROW)=IDF(1)%X(ICOL,IROW)-DZVAL(ILAY-1)*F IDF(1)%X(ICOL,IROW)=IDF(2)%X(ICOL,IROW) ENDDO; ENDDO IDF(2)%FNAME=TRIM(OUTPUTFOLDER)//'\INT_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(IDF(2),IDF(2)%FNAME,1))EXIT WRITE(*,'(A)') TRIM(VTOS(ILAY))//' of '//TRIM(VTOS(NLAY))//': INT_L'//TRIM(VTOS(ILAY))//'.IDF' ENDDO CALL IDFDEALLOCATE(IDF,SIZE(IDF)); DEALLOCATE(IDF) END SUBROUTINE IMODBATCH_CREATELAYERS_MAIN !###====================================================================== SUBROUTINE IMODBATCH_CREATESOF() !###====================================================================== IMPLICIT NONE TYPE(IDFOBJ),DIMENSION(:),ALLOCATABLE :: IDF TYPE(IDFOBJ) :: RAIN TYPE(IDFOBJ),DIMENSION(:,:),ALLOCATABLE :: TQP INTEGER :: I,J,IFLOW,IPNTR,IWINDOW,IWRITE,IGRAD,ITQP,NTQP,TTQP,IFORMAT,NQDW,FORCE_DWNHILL REAL(KIND=DP_KIND),DIMENSION(:),ALLOCATABLE :: PTQP REAL(KIND=DP_KIND),DIMENSION(:,:),POINTER :: QDW CHARACTER(LEN=256) :: RESULTIDF,OUTPUTFOLDER,FNAME,ISGFNAME REAL(KIND=DP_KIND) :: XMIN,YMIN,XMAX,YMAX,CELLSIZE,MINQ,MINFLOW 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=7; 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(7)%FNAME; WRITE(*,'(A)') 'OUTLETIDF='//TRIM(IDF(7)%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,4F15.3)') 'CELLSIZE=',CELLSIZE ENDIF !## compute sof-area with spill levels CALL SOF_MAIN(IDF,IPNTR,IWINDOW,XMIN,YMIN,XMAX,YMAX,CELLSIZE,IGRAD) 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) !## read catchment rainfall (mm/d) RAIN%FNAME='1.0'; IF(UTL_READINITFILE('RAIN',LINE,IU,1))READ(LINE,*) RAIN%FNAME WRITE(*,'(A)') 'RAIN='//TRIM(RAIN%FNAME) IF(.NOT.UTL_READINITFILE('FLOWIDF',LINE,IU,0))RETURN READ(LINE,*) IDF(2)%FNAME; WRITE(*,'(A)') 'FLOWIDF='//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,RAIN) ELSEIF(IFLOW.EQ.2)THEN I=2; ALLOCATE(IDF(I)); DO I=1,SIZE(IDF); CALL IDFNULLIFY(IDF(I)); ENDDO IF(.NOT.UTL_READINITFILE('FLOWIDF',LINE,IU,0))RETURN READ(LINE,*) IDF(1)%FNAME; WRITE(*,'(A)') 'FLOWIDF='//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.0D0; 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(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) PTQP(I); LINE='PTQP'//TRIM(VTOS(I))//'='//TRIM(VTOS(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(VTOS(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(VTOS(I))//'_'//TRIM(VTOS(J))//'='//TRIM(TQP(I,J)%FNAME) ENDDO ELSE TQP(I,1)%FNAME=FNAME WRITE(*,'(A)') 'TQPIDF'//TRIM(VTOS(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 MINFLOW=0; IF(UTL_READINITFILE('MINFLOW',LINE,IU,1))READ(LINE,*) MINFLOW WRITE(*,'(A,F10.2)') 'MINFLOW=',MINFLOW 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(VTOS(I)),LINE,IU,1))READ(LINE,*) QDW(I,1),QDW(I,2),QDW(I,3) LINE='QDW'//TRIM(VTOS(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)); IDF(I)%FNAME=''; ENDDO IF(.NOT.UTL_READINITFILE('FLOWIDF',LINE,IU,0))RETURN READ(LINE,*) IDF(1)%FNAME; WRITE(*,'(A)') 'FLOWIDF='//TRIM(IDF(1)%FNAME) IF(UTL_READINITFILE('SLOPEIDF',LINE,IU,1))THEN READ(LINE,*) IDF(2)%FNAME; WRITE(*,'(A)') 'SLOPEIDF='//TRIM(IDF(2)%FNAME) ENDIF 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) FORCE_DWNHILL=0 IF(UTL_READINITFILE('FORCE_DWNHILL',LINE,IU,1))THEN READ(LINE,*) FORCE_DWNHILL; WRITE(*,'(A,I10)') 'FORCE_DWNHILL=',FORCE_DWNHILL ENDIF IF(IFORMAT.EQ.1)THEN 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) ELSE IF(.NOT.UTL_READINITFILE('ISGFILE',LINE,IU,0))RETURN READ(LINE,*) ISGFNAME; WRITE(*,'(A)') 'ISGFILE='//TRIM(ISGFNAME) ENDIF CALL SOF_EXPORT(IDF,SIZE(IDF),IFORMAT,MINFLOW,QDW,ISGFNAME,FORCE_DWNHILL) 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.0D0,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(VTOS(I))//'.IDF' IDF(I,2)%FNAME=TRIM(OUTPUTFOLDER)//'\BOT_MDL'//TRIM(VTOS(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(VTOS(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(VTOS(I)),LINE,IU,0))RETURN; READ(LINE,*) INIDF(1)%FNAME IF(.NOT.UTL_READINITFILE('INBOT'//TRIM(VTOS(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(VTOS(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(VTOS(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(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) INIDF(1)%FNAME; LINE='INTOP'//TRIM(VTOS(I))//'='//TRIM(INIDF(1)%FNAME) WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('INBOT'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) INIDF(2)%FNAME; LINE='INBOT'//TRIM(VTOS(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.0D0,0))THEN; RETURN; ENDIF CALL IDFCOPY(IDF(1,1),INIDF(2)); IF(.NOT.IDFREADSCALE(INIDF(2)%FNAME,INIDF(2),2,1,0.0D0,0))THEN; RETURN; ENDIF LIDF=UTL_READINITFILE('INLAY'//TRIM(VTOS(I)),LINE,IU,1) IF(LIDF)THEN READ(LINE,*) INIDF(3)%FNAME; LINE='INLAY'//TRIM(VTOS(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.0D0,0))THEN; RETURN; ENDIF ELSE IF(.NOT.UTL_READINITFILE('IL'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) ILAY; LINE='IL'//TRIM(VTOS(I))//'='//TRIM(VTOS(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(VTOS(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,SDATE,EDATE,TSDIR,LCOL,TXTCOL,IASSF,INTVAL,NGXG,ICOLGXG,ICLEAN IMPLICIT NONE !## read keywords 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) SDATE=INT(0,8) IF(UTL_READINITFILE('SDATE',LINE,IU,1))THEN READ(LINE,*) SDATE; SDATE=UTL_COMPLETEDATE(SDATE) LINE=TRIM(VTOS(SDATE)); WRITE(*,'(A)') 'SDATE='//TRIM(LINE) ENDIF EDATE=HUGE(EDATE) IF(UTL_READINITFILE('EDATE',LINE,IU,1))THEN READ(LINE,*) EDATE; EDATE=UTL_COMPLETEDATE(EDATE) LINE=TRIM(VTOS(EDATE)); WRITE(*,'(A)') 'EDATE='//TRIM(LINE) ENDIF LCOL=0; IF(UTL_READINITFILE('LABELCOL',LINE,IU,1))READ(LINE,*) LCOL LINE=TRIM(VTOS(LCOL)); WRITE(*,'(A)') 'LABELCOL='//TRIM(LINE) TXTCOL=2; IF(UTL_READINITFILE('TXTCOL',LINE,IU,1))READ(LINE,*) TXTCOL LINE=TRIM(VTOS(TXTCOL)); WRITE(*,'(A)') 'TXTCOL='//TRIM(LINE) IASSF=1; IF(UTL_READINITFILE('IASSF',LINE,IU,1))READ(LINE,*) IASSF LINE=TRIM(VTOS(IASSF)); WRITE(*,'(A)') 'IASSF='//TRIM(LINE) IF(.NOT.UTL_READINITFILE('ILAY',LINE,IU,0))RETURN READ(LINE,*) TSILAY; LINE=TRIM(VTOS(TSILAY)); WRITE(*,'(A)') 'ILAY='//TRIM(LINE) IF(.NOT.UTL_READINITFILE('SOURCEDIR',LINE,IU,0))RETURN READ(LINE,*) TSDIR; WRITE(*,'(A)') 'SOURCEDIR='//TRIM(TSDIR) INTVAL=0; IF(UTL_READINITFILE('INT',LINE,IU,1))READ(LINE,*) INTVAL LINE=TRIM(VTOS(INTVAL)); WRITE(*,'(A)') 'INT='//TRIM(LINE) ICLEAN=0; IF(UTL_READINITFILE('ICLEAN',LINE,IU,1))READ(LINE,*) ICLEAN LINE=TRIM(VTOS(ICLEAN)); WRITE(*,'(A)') 'ICLEAN='//TRIM(LINE) NGXG=0; IF(UTL_READINITFILE('NGXG',LINE,IU,1))THEN READ(LINE,*) NGXG; WRITE(*,'(A)') 'NGXG='//TRIM(VTOS(NGXG)) IF(NGXG.GT.0)THEN ALLOCATE(ICOLGXG(NGXG)); ICOLGXG=0 DO I=1,NGXG IF(.NOT.UTL_READINITFILE('YRGXG'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) ICOLGXG(I); WRITE(*,'(A)') 'YRGXG'//TRIM(VTOS(I))//'='//TRIM(VTOS(ICOLGXG(I))) ENDDO ENDIF ENDIF WRITE(*,'(/A)') 'Function searches for files: '//ACHAR(10)//' - '//TRIM(TSDIR)//'_{yyyymmdd}[hhmmss]_L{ilay}.IDF' !## start function IF(.NOT.TS1COMPUTE(1))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(VTOS(SDATE)); WRITE(*,'(A)') 'SDATE='//TRIM(LINE) IF(.NOT.UTL_READINITFILE('EDATE',LINE,IU,0))RETURN READ(LINE,*) EDATE; LINE=TRIM(VTOS(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,ICORDIR IMPLICIT NONE CHARACTER(LEN=256) :: OUTFILE INTEGER :: IPUZZLE,I IPUZZLE=0 CWINTER='0110' CSUMMER='0104' ISTART=2014 ISTOP=2014 SAMPLE=250.0D0 XSEARCH=250.0D0 CDAY=1.0D0 INFFCT=0.33D0 IBOT=-1 ICDY=-1 IINF=-1 ICORDIR=0 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.0D0 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.0D0 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.0D0 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('ICORDIR',LINE,IU,0))RETURN READ(LINE,*) ICORDIR; WRITE(*,'(A)') 'ICORDIR='//TRIM(VTOS(ICORDIR)) 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_ICNVTOIDF() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: CSVFILE INTEGER :: JU,TOTAL_INNER_ITERATIONS,TOTIM,KPER,KSTP,NOUTER,NINNER,SOLUTION_INNER_DVMAX_MODEL,SOLUTION_INNER_DVMAX_NODE, & SOLUTION_INNER_DRMAX_MODEL,SOLUTION_INNER_DRMAX_NODE,IOS,LENTXT,NTXT,NCELLS,NLAY,NJA,ILAY,IROW,ICOL REAL(KIND=DP_KIND) :: SOLUTION_INNER_DVMAX,SOLUTION_INNER_DRMAX,SOLUTION_INNER_ALPHA,SOLUTION_INNER_OMEGA,ANGROT CHARACTER(LEN=:),ALLOCATABLE :: STRING TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: IDF LOGICAL :: LEX CHARACTER(LEN=50) :: HDR CHARACTER(LEN=256) :: GRBNAME IF(.NOT.UTL_READINITFILE('GRB',LINE,IU,0))RETURN READ(LINE,*) GRBNAME; WRITE(*,'(A)') 'GRB='//TRIM(GRBNAME) INQUIRE(FILE=GRBNAME,EXIST=LEX); IF(.NOT.LEX)THEN; WRITE(*,'(/A/)') 'Cannot read '//TRIM(GRBNAME); STOP; ENDIF JU=UTL_GETUNIT(); OPEN(JU,FILE=GRBNAME,ACTION='READ',ACCESS='STREAM',FORM='UNFORMATTED') READ(JU) HDR READ(JU) HDR READ(JU) HDR; READ(HDR(5:),*) NTXT READ(JU) HDR; READ(HDR(7:),*) LENTXT ALLOCATE(CHARACTER(LEN=LENTXT) :: STRING) DO I=1,NTXT; READ(JU) STRING; ENDDO READ(JU) NCELLS READ(JU) NLAY ALLOCATE(IDF(NLAY)); DO I=1,NLAY; CALL IDFNULLIFY(IDF(I)); ENDDO READ(JU) IDF(1)%NROW READ(JU) IDF(1)%NCOL READ(JU) NJA READ(JU) IDF(1)%XMIN READ(JU) IDF(1)%YMIN READ(JU) ANGROT ALLOCATE(IDF(1)%SX(0:IDF(1)%NCOL)); READ(JU) (IDF(1)%SX(I),I=1,IDF(1)%NCOL) ALLOCATE(IDF(1)%SY(0:IDF(1)%NROW)); READ(JU) (IDF(1)%SY(I),I=1,IDF(1)%NROW) DEALLOCATE(STRING) !## see whether it is a non-equidistantial model IDF(1)%IEQ=0 IF(MINVAL(IDF(1)%SX(1:IDF(1)%NCOL)).NE.MAXVAL(IDF(1)%SX(1:IDF(1)%NCOL)))IDF(1)%IEQ=1 IF(MINVAL(IDF(1)%SY(1:IDF(1)%NROW)).NE.MAXVAL(IDF(1)%SY(1:IDF(1)%NROW)))IDF(1)%IEQ=1 !## fill sx/sy IDF(1)%SX(0)=IDF(1)%XMIN; DO I=1,IDF(1)%NCOL; IDF(1)%SX(I)=IDF(1)%SX(I-1)+IDF(1)%SX(I); ENDDO IDF(1)%YMAX=IDF(1)%YMIN; DO I=1,IDF(1)%NROW; IDF(1)%YMAX =IDF(1)%YMAX+IDF(1)%SY(I); ENDDO IDF(1)%SY(0)=IDF(1)%YMAX; DO I=1,IDF(1)%NROW; IDF(1)%SY(I)=IDF(1)%SY(I-1)-IDF(1)%SY(I); ENDDO IF(IDF(1)%IEQ.EQ.0)THEN IDF(1)%DX=IDF(1)%SX(1)-IDF(1)%SX(0); IDF(1)%DY=IDF(1)%SY(0)-IDF(1)%SY(1) IDF(1)%XMAX=IDF(1)%XMIN+(IDF(1)%NCOL*IDF(1)%DX) IDF(1)%YMAX=IDF(1)%YMIN+(IDF(1)%NROW*IDF(1)%DY) ELSE IDF(1)%DX=MINVAL(IDF(1)%SX); IDF(1)%DY=MINVAL(IDF(1)%SY) IDF(1)%XMAX=IDF(1)%SX(IDF(1)%NCOL) IDF(1)%YMAX=IDF(1)%SY(0) ENDIF IDF(1)%NODATA=0.0D0 IF(.NOT.IDFALLOCATEX(IDF(1)))STOP 'CANNOT ALLOCATE MEMORY X IN IDF OBJECT' CLOSE(JU) IDF(1)%X=0.0D0; DO I=2,NLAY; CALL IDFCOPY(IDF(1),IDF(I)); ENDDO IF(.NOT.UTL_READINITFILE('CSVFILE',LINE,IU,0))RETURN READ(LINE,*) CSVFILE; WRITE(*,'(A)') 'CSVFILE='//TRIM(CSVFILE) JU=UTL_GETUNIT(); OPEN(JU,FILE=CSVFILE,STATUS='OLD',ACTION='READ') READ(JU,*) DO READ(JU,*,IOSTAT=IOS) TOTAL_INNER_ITERATIONS,TOTIM,KPER,KSTP,NOUTER,NINNER,SOLUTION_INNER_DVMAX,SOLUTION_INNER_DVMAX_MODEL,SOLUTION_INNER_DVMAX_NODE,& SOLUTION_INNER_DRMAX,SOLUTION_INNER_DRMAX_MODEL,SOLUTION_INNER_DRMAX_NODE,SOLUTION_INNER_ALPHA,SOLUTION_INNER_OMEGA CALL UTL_GETIROWICOL(SOLUTION_INNER_DVMAX_NODE,IDF(1)%NROW,IDF(1)%NCOL,ILAY,IROW,ICOL) IDF(ILAY)%X(ICOL,IROW)=IDF(ILAY)%X(ICOL,IROW)+1.0D0 IF(IOS.NE.0)EXIT ENDDO CLOSE(JU) DO ILAY=1,NLAY IDF(ILAY)%FNAME=CSVFILE(:INDEX(CSVFILE,'.',.TRUE.)-1)//'_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(IDF(ILAY),IDF(ILAY)%FNAME,1))STOP ENDDO END SUBROUTINE IMODBATCH_ICNVTOIDF !###====================================================================== SUBROUTINE IMODBATCH_GENPUZZLE() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: GENFILE_IN,GENFILE_OUT INTEGER :: IBINARY 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('GENFILE_OUT',LINE,IU,0))RETURN READ(LINE,*) GENFILE_OUT; WRITE(*,'(A)') 'GENFILE_OUT='//TRIM(GENFILE_OUT) IBINARY=0 IF(UTL_READINITFILE('IBINARY',LINE,IU,1))THEN READ(LINE,*) IBINARY; WRITE(*,'(A)') 'IBINARY='//TRIM(VTOS(IBINARY)) ENDIF CALL PUZZLE_SIMPLEMAIN(GENFILE_IN,GENFILE_OUT,IBINARY) END SUBROUTINE IMODBATCH_GENPUZZLE !###====================================================================== 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=20000101000000D00 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) END SUBROUTINE IMODBATCH_IPF2ISG !###====================================================================== SUBROUTINE IMODBATCH_GENSNAPTOGRID() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: GENFILE INTEGER(KIND=1),DIMENSION(:,:,:),ALLOCATABLE :: IPC INTEGER :: IROW,ICOL,N,JU,I3D REAL(KIND=DP_KIND) :: T1,T2,B1,B2,T,B LOGICAL :: LEX TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: IDF ALLOCATE(IDF(3)); DO I=1,SIZE(IDF); CALL IDFNULLIFY(IDF(I)); ENDDO IF(.NOT.UTL_READINITFILE('GENFILE_IN',LINE,IU,0))RETURN READ(LINE,*) GENFILE; WRITE(*,'(A)') 'GENFILE_IN='//TRIM(GENFILE) I3D=0; IF(UTL_READINITFILE('I3D',LINE,IU,1))READ(LINE,*) I3D LINE='I3D='//TRIM(VTOS(I3D)); WRITE(*,'(A)') TRIM(LINE) IDF(3)%XMIN=0.0D0; IDF(3)%YMIN=0.0D0; IDF(3)%XMAX=0.0D0; IDF(3)%YMAX=0.0D0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) IDF(3)%XMIN,IDF(3)%YMIN,IDF(3)%XMAX,IDF(3)%YMAX WRITE(*,'(A,4F15.3)') 'WINDOW=',IDF(3)%XMIN,IDF(3)%YMIN,IDF(3)%XMAX,IDF(3)%YMAX IF(.NOT.UTL_READINITFILE('CELL_SIZE',LINE,IU,0))RETURN READ(LINE,*) IDF(3)%DX; WRITE(*,'(A,F10.2)') 'CELL_SIZE=',IDF(3)%DX; IDF(3)%DY=IDF(3)%DX CALL UTL_IDFSNAPTOGRID_LLC(IDF(3)%XMIN,IDF(3)%XMAX,IDF(3)%YMIN,IDF(3)%YMAX,IDF(3)%DX,IDF(3)%DY,IDF(3)%NCOL,IDF(3)%NROW,LLC=.TRUE.) ELSE IF(.NOT.UTL_READINITFILE('IDFFILE',LINE,IU,0))RETURN READ(LINE,*) IDF(3)%FNAME; WRITE(*,'(A)') 'IDFFILE='//TRIM(IDF(3)%FNAME) IF(.NOT.IDFREAD(IDF(3),IDF(3)%FNAME,0))RETURN ENDIF !## read/scale top/bot files IF(I3D.EQ.1)THEN 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) CALL IDFCOPY(IDF(3),IDF(1)); CALL IDFCOPY(IDF(3),IDF(2)) IF(.NOT.IDFREADSCALE(IDF(1)%FNAME,IDF(1),2,1,0.0D0,0))STOP 'Cannot read data for IDF(1)' IF(.NOT.IDFREADSCALE(IDF(2)%FNAME,IDF(2),2,1,0.0D0,0))STOP 'Cannot read data for IDF(2)' ENDIF !## fill sx/sy variable in idf IF(.NOT.IDFFILLSXSY(IDF(3)))RETURN ALLOCATE(IPC(IDF(3)%NCOL,IDF(3)%NROW,2)); IPC=INT(0,1) CALL ASC2IDF_INT_NULLIFY(); ALLOCATE(XP(100),YP(100),ZP(100),WP(100),PP(100),FP(100)) IF(.NOT.ASC2IDF_HFB(IDF(3),IDF(3)%NROW,IDF(3)%NCOL,IPC,(/GENFILE/),-1,IPUZZLE=0))THEN WRITE(*,'(/A/)') '>>> Error reading '//TRIM(GENFILE)//' <<<'; STOP ENDIF 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='REPLACE',FORM='FORMATTED') IF(JU.EQ.0)THEN; WRITE(*,'(A)') 'Error opening '//TRIM(GENFILE); RETURN; ENDIF N=0; DO IROW=1,IDF(3)%NROW; DO ICOL=1,IDF(3)%NCOL !## place vertical wall IF(IPC(ICOL,IROW,1).EQ.INT(1,1))THEN IF(ICOL.LT.IDF(3)%NCOL)THEN T1=0.0D0; B1=T1; LEX=.FALSE. IF(I3D.EQ.1)THEN T1=IDF(1)%X(ICOL,IROW); T2=IDF(1)%X(ICOL+1,IROW) B1=IDF(2)%X(ICOL,IROW); B2=IDF(2)%X(ICOL+1,IROW) IF(T1.NE.IDF(1)%NODATA.AND.T2.NE.IDF(1)%NODATA.AND. & B1.NE.IDF(2)%NODATA.AND.B2.NE.IDF(2)%NODATA)THEN T=MAX(T1,T2); B=MIN(B1,B2); LEX=.TRUE. ENDIF ELSE LEX=.TRUE.; T=0.0D0; B=0.0D0 ENDIF IF(LEX)THEN N=N+1; CALL PMANAGER_GENERATEMFNETWORKS_WRITEXY(1,JU,0,IPC,IDF(3),IROW,ICOL,N,I3D,T,B) ENDIF ENDIF ENDIF !## place horizontal wall IF(IPC(ICOL,IROW,2).EQ.INT(1,1))THEN !## write line in genfile IF(IROW.LT.IDF(3)%NROW)THEN T1=0.0D0; B1=T1; LEX=.FALSE. IF(I3D.EQ.1)THEN !## find appropriate top/bot T1=IDF(1)%X(ICOL,IROW); T2=IDF(1)%X(ICOL,IROW+1) B1=IDF(2)%X(ICOL,IROW); B2=IDF(2)%X(ICOL,IROW+1) IF(T1.NE.IDF(1)%NODATA.AND.T2.NE.IDF(1)%NODATA.AND. & B1.NE.IDF(2)%NODATA.AND.B2.NE.IDF(2)%NODATA)THEN T=MAX(T1,T2); B=MIN(B1,B2); LEX=.TRUE. ENDIF ELSE LEX=.TRUE.; T=0.0D0; B=0.0D0 ENDIF IF(LEX)THEN N=N+1; CALL PMANAGER_GENERATEMFNETWORKS_WRITEXY(2,JU,0,IPC,IDF(3),IROW,ICOL,N,I3D,T,B) ENDIF ENDIF ENDIF ENDDO; ENDDO ! if(.not.idfallocatex(idf(3)))stop ! idf(3)%x=ipc(:,:,1) ! if(.not.idfwrite(idf(3),'d:\ipc1.idf',0))stop ! idf(3)%x=ipc(:,:,2) ! if(.not.idfwrite(idf(3),'d:\ipc2.idf',0))stop WRITE(JU,'(A)') 'END'; CLOSE(JU) CALL ASC2IDF_INT_DEALLOCATE(); DEALLOCATE(IPC); CALL IDFDEALLOCATE(IDF,SIZE(IDF)); DEALLOCATE(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='REPLACE',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_CLUSTER() !###====================================================================== IMPLICIT NONE REAL(KIND=DP_KIND),POINTER,DIMENSION(:) :: XC,YC REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: X,Y REAL(KIND=DP_KIND) :: CD INTEGER :: I,ISHAPE,JU,IROW,ICOL,IR,IC,DRC TYPE(IDFOBJ) :: IDF NIPF=1; CALL IPFALLOCATE(); CALL IDFNULLIFY(IDF) IF(.NOT.UTL_READINITFILE('IPFNAME',LINE,IU,0))RETURN READ(LINE,*) IPF(1)%FNAME; WRITE(*,'(A)') 'IPFNAME='//TRIM(IPF(1)%FNAME) IF(.NOT.UTL_READINITFILE('DISTANCE',LINE,IU,0))RETURN READ(LINE,*) CD; WRITE(*,'(A,F15.3)') 'DISTANCE=',CD ISHAPE=1; IF(UTL_READINITFILE('SHAPE',LINE,IU,1))READ(LINE,*) ISHAPE SELECT CASE (ISHAPE) CASE (1); WRITE(*,'(A,I2,A)') 'SHAPE=',ISHAPE,' (circle)' CASE (2); WRITE(*,'(A,I2,A)') 'SHAPE=',ISHAPE,' (rectangle)' END SELECT IPF(1)%XCOL =1 IPF(1)%YCOL =2 IPF(1)%ZCOL =1 IPF(1)%Z2COL=1 IPF(1)%QCOL =1 !## read entire ipf IF(.NOT.IPFREAD2(1,1,0))RETURN; ALLOCATE(X(IPF(1)%NROW),Y(IPF(1)%NROW)) DO I=1,IPF(1)%NROW; X(I)=IPF(1)%XYZ(1,I); Y(I)=IPF(1)%XYZ(2,I); ENDDO IF(.NOT.UTL_CLUSTER(CD,X,Y,XC,YC,ISHAPE))RETURN IF(.NOT.UTL_READINITFILE('IPFNAME_OUT',LINE,IU,0))RETURN READ(LINE,*) IPF(1)%FNAME; WRITE(*,'(A)') 'IPFNAME_OUT='//TRIM(IPF(1)%FNAME) JU=UTL_GETUNIT(); OPEN(JU,FILE=IPF(1)%FNAME,STATUS='REPLACE',ACTION='WRITE') WRITE(JU,'(A)') TRIM(VTOS(SIZE(XC))) WRITE(JU,'(A1)') '3' WRITE(JU,'(A1)') 'X' WRITE(JU,'(A1)') 'Y' WRITE(JU,'(A2)') 'ID' WRITE(JU,'(A5)') '0,TXT' DO I=1,SIZE(XC); WRITE(JU,'(2(F10.3,1X),I10)') XC(I),YC(I),I; ENDDO CLOSE(JU) IF(.NOT.UTL_READINITFILE('IDF_OUT',LINE,IU,0))RETURN READ(LINE,*) IDF%FNAME; WRITE(*,'(A)') 'IDF_OUT='//TRIM(IDF%FNAME) IWINDOW=0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN IWINDOW=1 READ(LINE,*) IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX WRITE(*,'(A,4F15.3)') 'WINDOW=',IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX ELSE IDF%XMIN=MINVAL(XC); IDF%XMAX=MAXVAL(XC) IDF%YMIN=MINVAL(YC); IDF%YMAX=MAXVAL(YC) ENDIF IDF%DX=CD/10.0D0; IDF%DY=CD/10.0D0 CALL UTL_IDFSNAPTOGRID_LLC(IDF%XMIN,IDF%XMAX,IDF%YMIN,IDF%YMAX,IDF%DX,IDF%DY,IDF%NCOL,IDF%NROW,.TRUE.) IF(.NOT.IDFALLOCATEX(IDF))STOP; IDF%NODATA=0.0D0; IDF%X=IDF%NODATA DRC=9 DO I=1,SIZE(XC) CALL IDFIROWICOL(IDF,IROW,ICOL,XC(I),YC(I)) DO IR=MAX(IROW-DRC,1),MIN(IROW+DRC,IDF%NROW) DO IC=MAX(ICOL-DRC,1),MIN(ICOL+DRC,IDF%NCOL) IDF%X(IC,IR)=REAL(I,8) ENDDO ENDDO ENDDO IF(IDFWRITE(IDF,IDF%FNAME,1))STOP END SUBROUTINE IMODBATCH_CLUSTER !###====================================================================== SUBROUTINE IMODBATCH_MKWELLIPF_MAIN() !###====================================================================== USE MOD_SCENTOOL_PAR, ONLY : TOPIDF,BOTIDF,KHVIDF 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,ISS,IMIDF,IQCOL,STNLAY INTEGER(KIND=DP_KIND) :: SDATE,EDATE INTEGER,ALLOCATABLE,DIMENSION(:) :: IKD REAL(KIND=DP_KIND) :: HNODATA,FNODATA,MINKHT,MINKD STNLAY=-1; IMIDF=0; MINKHT=0.0D0; SDATE=0; EDATE=0; ISS=0 HNODATA=0.0D0; FNODATA=-99999.0D0; MINKD=0.0D0 IF(UTL_READINITFILE('NLAY',LINE,IU,1))THEN READ(LINE,*) STNLAY ALLOCATE(TOPIDF(STNLAY),BOTIDF(STNLAY),KHVIDF(STNLAY),IKD(STNLAY)) DO I=1,SIZE(TOPIDF); CALL IDFNULLIFY(TOPIDF(I)); ENDDO DO I=1,SIZE(BOTIDF); CALL IDFNULLIFY(BOTIDF(I)); ENDDO DO I=1,SIZE(KHVIDF); CALL IDFNULLIFY(KHVIDF(I)); ENDDO IKD=0 DO I=1,STNLAY IF(.NOT.UTL_READINITFILE('TOPIDF'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) TOPIDF(I)%FNAME; LINE='TOPIDF'//TRIM(VTOS(I))//'='//TRIM(TOPIDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('BOTIDF'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) BOTIDF(I)%FNAME; LINE='BOTIDF'//TRIM(VTOS(I))//'='//TRIM(BOTIDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) !## optionele opties KHVIDF(I)%FNAME='' IF(UTL_READINITFILE('KHVIDF'//TRIM(VTOS(I)),LINE,IU,1))THEN IKD(I)=1 READ(LINE,*) KHVIDF(I)%FNAME; LINE='KHVIDF'//TRIM(VTOS(I))//'='//TRIM(KHVIDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) ENDIF IF(IKD(I).EQ.0)THEN IF(UTL_READINITFILE('KDVIDF'//TRIM(VTOS(I)),LINE,IU,1))THEN IKD(I)=2 READ(LINE,*) KHVIDF(I)%FNAME; LINE='KDVIDF'//TRIM(VTOS(I))//'='//TRIM(KHVIDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) ENDIF ENDIF ENDDO DO I=1,STNLAY IF(IKD(I).EQ.1)THEN IF(UTL_READINITFILE('MINKHT',LINE,IU,1))READ(LINE,*) MINKHT WRITE(*,'(A,F15.3)') 'MINKHT=',MINKHT EXIT ENDIF ENDDO DO I=1,STNLAY IF(IKD(I).EQ.2)THEN IF(UTL_READINITFILE('MINKD',LINE,IU,1))READ(LINE,*) MINKD WRITE(*,'(A,F15.3)') 'MINKD=',MINKD EXIT ENDIF ENDDO !## usage of nodata IF(UTL_READINITFILE('FNODATA',LINE,IU,1))READ(LINE,*) FNODATA WRITE(*,'(A,F15.3)') 'FNODATA=',FNODATA ELSE ALLOCATE(IKD(1)); IKD=0 ENDIF !## usage of nodata IF(UTL_READINITFILE('HNODATA',LINE,IU,1))READ(LINE,*) HNODATA WRITE(*,'(A,F15.3)') 'HNODATA=',HNODATA NIPF=1; CALL IPFALLOCATE() IF(UTL_READINITFILE('ISS',LINE,IU,1))READ(LINE,*) ISS WRITE(*,'(A,I1)') 'ISS=',ISS SDATE=0D0; EDATE=0D0; IF(ISS.EQ.1)THEN IF(.NOT.UTL_READINITFILE('SDATE',LINE,IU,0))RETURN READ(LINE,*) SDATE; SDATE=UTL_COMPLETEDATE(SDATE); WRITE(*,'(A,I14)') 'SDATE=',SDATE IF(.NOT.UTL_READINITFILE('EDATE',LINE,IU,0))RETURN READ(LINE,*) EDATE; EDATE=UTL_COMPLETEDATE(EDATE); WRITE(*,'(A,I14)') 'EDATE=',EDATE ENDIF IPF(1)%XCOL=1; IPF(1)%YCOL=2; IPF(1)%QCOL=1 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(ISS.EQ.0)THEN IF(UTL_READINITFILE('IQCOL',LINE,IU,1))READ(LINE,*) IPF(1)%QCOL; WRITE(*,'(A,I2)') 'IQCOL=',IPF(1)%QCOL ELSE IPF(1)%QCOL=IPF(1)%XCOL ENDIF IF(STNLAY.GT.0)THEN IPF(1)%ZCOL=4; IPF(1)%Z2COL=5 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 IF(UTL_READINITFILE('IMIDF',LINE,IU,1))READ(LINE,*) IMIDF; WRITE(*,'(A,I2)') 'IMIDF=',IMIDF ELSE IPF(1)%ZCOL=1; IPF(1)%Z2COL=1 ENDIF IQCOL=IPF(1)%QCOL IF(.NOT.UTL_READINITFILE('NIPF',LINE,IU,0))RETURN READ(LINE,*) N; WRITE(*,'(A,I5)') 'NIPF=',N DO I=1,N IF(.NOT.UTL_READINITFILE('IPF'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) IPF(1)%FNAME LINE='IPF'//TRIM(VTOS(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,0))RETURN IF(.NOT.ST1CREATEIPF_STEADY(IKD,MINKHT,IMIDF,SDATE,EDATE,ISS,HNODATA,FNODATA,MINKD,STNLAY)) & WRITE(*,'(A)') 'Error IPF '//TRIM(IPF(1)%FNAME)//' failed' ENDDO END SUBROUTINE IMODBATCH_MKWELLIPF_MAIN !###====================================================================== SUBROUTINE IMODBATCH_ASSIGNLAYER() !###====================================================================== USE MOD_IPF_PAR, ONLY : NIPF,IPF USE MOD_IPF, ONLY : IPFALLOCATE IMPLICIT NONE INTEGER :: NLAY,IMIDF,I,J,ILAY,IROW,ICOL,JU REAL(KIND=DP_KIND) :: FNODATA,FMID REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: TOP,BOT,KHV,TLP TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: TOPIDF,BOTIDF IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) 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 DO I=1,NLAY IF(.NOT.UTL_READINITFILE('TOPIDF'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) TOPIDF(I)%FNAME; LINE='TOPIDF'//TRIM(VTOS(I))//'='//TRIM(TOPIDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.IDFREAD(TOPIDF(I),TOPIDF(I)%FNAME,0))RETURN IF(.NOT.UTL_READINITFILE('BOTIDF'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) BOTIDF(I)%FNAME; LINE='BOTIDF'//TRIM(VTOS(I))//'='//TRIM(BOTIDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.IDFREAD(BOTIDF(I),BOTIDF(I)%FNAME,0))RETURN ENDDO NIPF=1; CALL IPFALLOCATE() IPF(1)%XCOL=1; IPF(1)%YCOL=2; IPF(1)%QCOL=3 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 IPF(1)%QCOL=IPF(1)%XCOL IPF(1)%ZCOL=4; IPF(1)%Z2COL=5 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 IMIDF=0; IF(UTL_READINITFILE('IMIDF',LINE,IU,1))READ(LINE,*) IMIDF; WRITE(*,'(A,I2)') 'IMIDF=',IMIDF IF(UTL_READINITFILE('FNODATA',LINE,IU,1))THEN READ(LINE,*) FNODATA WRITE(*,'(A,F15.3)') 'FNODATA=',FNODATA ENDIF IF(.NOT.UTL_READINITFILE('NIPF',LINE,IU,0))RETURN READ(LINE,*) N; WRITE(*,'(A,I5)') 'NIPF=',N ALLOCATE(TOP(NLAY),BOT(NLAY),KHV(NLAY),TLP(NLAY)) DO J=1,N IF(.NOT.UTL_READINITFILE('IPF'//TRIM(VTOS(J)),LINE,IU,0))RETURN READ(LINE,*) IPF(1)%FNAME LINE='IPF'//TRIM(VTOS(J))//'='//TRIM(IPF(1)%FNAME); WRITE(*,'(A)') TRIM(LINE) !## read entire ipf IF(.NOT.IPFREAD2(1,1,0))RETURN JU=UTL_GETUNIT() OPEN(JU,FILE=IPF(1)%FNAME(:INDEX(IPF(1)%FNAME,'.',.TRUE.)-1)//'_LAYER.IPF',STATUS='REPLACE',ACTION='WRITE') WRITE(JU,'(I10)') IPF(1)%NROW WRITE(JU,'(I10)') IPF(1)%NCOL+1 DO I=1,IPF(1)%NCOL; WRITE(JU,'(A)') TRIM(IPF(1)%ATTRIB(I)); ENDDO WRITE(JU,'(A)') 'ASSIGNED_LAYER' WRITE(JU,'(A)') TRIM(VTOS(IPF(1)%ACOL))//','//TRIM(IPF(1)%FEXT) DO I=1,IPF(1)%NROW !## get top/bottoms DO ILAY=1,NLAY !## read current top value TOP(ILAY)=TOPIDF(ILAY)%NODATA CALL IDFIROWICOL(TOPIDF(ILAY),IROW,ICOL,IPF(1)%XYZ(1,I),IPF(1)%XYZ(2,I)) IF(IROW.NE.0.AND.ICOL.NE.0)TOP(ILAY)=IDFGETVAL(TOPIDF(ILAY),IROW,ICOL) !## read current bot value BOT(ILAY)=BOTIDF(ILAY)%NODATA CALL IDFIROWICOL(BOTIDF(ILAY),IROW,ICOL,IPF(1)%XYZ(1,I),IPF(1)%XYZ(2,I)) IF(IROW.NE.0.AND.ICOL.NE.0)BOT(ILAY)=IDFGETVAL(BOTIDF(ILAY),IROW,ICOL) ENDDO KHV=1.0D0 IF(IMIDF.EQ.1)THEN FMID=FNODATA IF(IPF(1)%XYZ(3,I).NE.FNODATA.AND.IPF(1)%XYZ(4,I).NE.FNODATA)THEN FMID=(IPF(1)%XYZ(3,I)+IPF(1)%XYZ(4,I))/2.0D0 ELSEIF(IPF(1)%XYZ(3,I).NE.FNODATA)THEN FMID=IPF(1)%XYZ(3,I) ELSEIF(IPF(1)%XYZ(4,I).NE.FNODATA)THEN FMID=IPF(1)%XYZ(4,I) ELSE WRITE(*,'(/1X,A,I10)') 'Cannot define proper top- and bottom elevation filter for line ',I; STOP ENDIF ELSE FMID=(IPF(1)%XYZ(3,I)+IPF(1)%XYZ(4,I))/2.0D0 ENDIF IPF(1)%XYZ(3,I)=FMID; IPF(1)%XYZ(4,I)=FMID CALL UTL_PCK_GETTLP(NLAY,TLP,KHV,TOP,BOT,IPF(1)%XYZ(3,I),IPF(1)%XYZ(4,I),0.0D0,-1) DO ILAY=1,NLAY; IF(TLP(ILAY).GT.0.0D0)EXIT; ENDDO IF(ILAY.GT.NLAY)THEN WRITE(JU,'(999A)') (TRIM(IPF(1)%INFO(ICOL,I))//',',ICOL=1,IPF(1)%NCOL),'#' ELSE WRITE(JU,'(999A)') (TRIM(IPF(1)%INFO(ICOL,I))//',',ICOL=1,IPF(1)%NCOL),TRIM(VTOS(ILAY)) ENDIF ENDDO ENDDO CLOSE(JU) END SUBROUTINE IMODBATCH_ASSIGNLAYER !###====================================================================== SUBROUTINE IMODBATCH_IMPORTSOBEK_MAIN() !###====================================================================== USE MOD_SOBEK_PAR, ONLY : ISGNAME,SOBEKDIR,CALCPNTHISNAME,STRUCHISNAME,IBATCH,DFLOWFMDIR,ISFINAL IMPLICIT NONE IBATCH=1; ISFINAL=0 IF(.NOT.UTL_READINITFILE('ISGNAME',LINE,IU,0))RETURN READ(LINE,'(A)') ISGNAME; WRITE(*,'(A)') 'ISGNAME='//TRIM(ISGNAME) IF(UTL_READINITFILE('SOBEKDIR',LINE,IU,1))THEN 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 IF(.NOT.SOBEK1CALC())THEN; ENDIF ELSE IF(.NOT.UTL_READINITFILE('DFLOWFMDIR',LINE,IU,0))RETURN READ(LINE,'(A)') DFLOWFMDIR; WRITE(*,'(A)') 'DFLOWFMDIR='//TRIM(DFLOWFMDIR) IF(UTL_READINITFILE('ISFINAL',LINE,IU,1))THEN READ(LINE,*) ISFINAL; WRITE(*,'(A)') 'ISFINAL='//TRIM(VTOS(ISFINAL)) ENDIF IF(.NOT.DFLOWFM1CALC())THEN; ENDIF 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 ! IMPLICIT NONE ! INTEGER :: I ! ! IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN ! READ(LINE,*) NLAY; LINE='NLAY='//TRIM(VTOS(NLAY)); WRITE(*,'(A)') TRIM(LINE) ! IF(.NOT.UTL_READINITFILE('MINVC',LINE,IU,0))RETURN ! READ(LINE,*) MINVC; LINE='MINVC='//TRIM(VTOS(MINVC,'F',7)); WRITE(*,'(A)') TRIM(LINE) ! IF(.NOT.UTL_READINITFILE('MAXK',LINE,IU,0))RETURN ! READ(LINE,*) MAXK; LINE='MAXK='//TRIM(VTOS(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(VTOS(I)),LINE,IU,0))RETURN ! READ(LINE,*) C_IDF(I)%FNAME; LINE='C_L'//TRIM(VTOS(I))//'='//TRIM(C_IDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) ! ENDIF ! IF(.NOT.UTL_READINITFILE('KD_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN ! READ(LINE,*) KD_IDF(I)%FNAME; LINE='KD_L'//TRIM(VTOS(I))//'='//TRIM(KD_IDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) ! IF(.NOT.UTL_READINITFILE('TOP_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN ! READ(LINE,*) TOP_IDF(I)%FNAME; LINE='TOP_L'//TRIM(VTOS(I))//'='//TRIM(TOP_IDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) ! IF(.NOT.UTL_READINITFILE('BOT_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN ! READ(LINE,*) BOT_IDF(I)%FNAME; LINE='BOT_L'//TRIM(VTOS(I))//'='//TRIM(BOT_IDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) ! IF(.NOT.UTL_READINITFILE('IBND_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN ! READ(LINE,*) IBND_IDF(I)%FNAME; LINE='IBND_L'//TRIM(VTOS(I))//'='//TRIM(IBND_IDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) ! ANIF_IDF(I)%FNAME=''; IF(UTL_READINITFILE('ANIF_L'//TRIM(VTOS(I)),LINE,IU,1))THEN ! READ(LINE,*) ANIF_IDF(I)%FNAME; LINE='ANIF_L'//TRIM(VTOS(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 IMODTOSTOMP() !###====================================================================== IMPLICIT NONE INTEGER :: IWINDOW,NLAY,ICROSS,ITYPE REAL(KIND=DP_KIND) :: SEAL TYPE(IDFOBJ) :: IDF IWINDOW=0; ICROSS=0 IF(UTL_READINITFILE('ICROSS',LINE,IU,1))THEN READ(LINE,*) ICROSS IF(.NOT.UTL_READINITFILE('XLINE',LINE,IU,0))RETURN READ(LINE,*) IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX WRITE(*,'(A,4F10.2)') 'XLINE=',IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX ELSE IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN IWINDOW=1 READ(LINE,*) IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX WRITE(*,'(A,4F15.3)') 'WINDOW=',IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX ENDIF ENDIF IF(IWINDOW.NE.0.OR.ICROSS.NE.0)THEN 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 ENDIF IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) NLAY; LINE='NLAY='//TRIM(VTOS(NLAY)); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('ITYPE',LINE,IU,0))RETURN READ(LINE,*) ITYPE; LINE='ITYPE='//TRIM(VTOS(ITYPE)); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('SEAL',LINE,IU,0))RETURN READ(LINE,*) SEAL; LINE='SEAL='//TRIM(VTOS(SEAL,'G',7)); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READPOINTER(IU,NAGGR,IAGGR,'IAGGR',0))RETURN IF(SUM(IAGGR).NE.NLAY)THEN WRITE(*,'(A,I3.3,A)') 'SUM IAGGR (',SUM(IAGGR),') need to be as many entries as NLAY' STOP ENDIF !## initialise variables CALL STOMP_INIT(NLAY) IF(STOMP_READ(IU,IDF,IWINDOW,ICROSS,SEAL))THEN IF(STOMP_SAVEINPUT(ITYPE))THEN; ENDIF ENDIF CALL STOMP_CLOSE() END SUBROUTINE IMODTOSTOMP !###====================================================================== SUBROUTINE IMODBATCH_COMPUTEKDC() !###====================================================================== IMPLICIT NONE INTEGER :: ILAY,IROW,ICOL,NLAY TYPE(IDFOBJ) :: IDF CHARACTER(LEN=256) :: OUTPUTMAP INTEGER :: IWINDOW REAL(KIND=DP_KIND) :: DH,Q,DX1,DX2,DY1,DY2,F TYPE(IDFOBJ),DIMENSION(:),ALLOCATABLE :: HEAD,FLF,FRF,FFF,KDW,VCW,CC,CR,CV IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) NLAY; LINE='NLAY='//TRIM(VTOS(NLAY)); WRITE(*,'(A)') TRIM(LINE) ALLOCATE(HEAD(NLAY),FRF(NLAY),FFF(NLAY),FLF(NLAY-1),KDW(NLAY),VCW(NLAY-1),CC(NLAY),CR(NLAY),CV(NLAY)) DO ILAY=1,NLAY CALL IDFNULLIFY(HEAD(ILAY)); CALL IDFNULLIFY(FFF(ILAY)); CALL IDFNULLIFY(FRF(ILAY)); CALL IDFNULLIFY(KDW(ILAY)) ENDDO DO ILAY=1,NLAY-1; CALL IDFNULLIFY(VCW(ILAY)); CALL IDFNULLIFY(FLF(ILAY)); ENDDO IWINDOW=0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN IWINDOW=1 READ(LINE,*) IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX WRITE(*,'(A,4F15.3)') '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%DY,IDF%NCOL,IDF%NROW,LLC=.TRUE.) ENDIF DO ILAY=1,NLAY IF(.NOT.UTL_READINITFILE('HEAD_L'//TRIM(VTOS(ILAY)),LINE,IU,0))RETURN READ(LINE,*) HEAD(ILAY)%FNAME; LINE='HEAD_L'//TRIM(VTOS(ILAY))//'='//TRIM(HEAD(ILAY)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('FRF_L'//TRIM(VTOS(ILAY)),LINE,IU,0))RETURN READ(LINE,*) FRF(ILAY)%FNAME; LINE='FRF_L'//TRIM(VTOS(ILAY))//'='//TRIM(FRF(ILAY)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('FFF_L'//TRIM(VTOS(ILAY)),LINE,IU,0))RETURN READ(LINE,*) FFF(ILAY)%FNAME; LINE='FFF_L'//TRIM(VTOS(ILAY))//'='//TRIM(FFF(ILAY)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(ILAY.LT.NLAY)THEN IF(.NOT.UTL_READINITFILE('FLF_L'//TRIM(VTOS(ILAY)),LINE,IU,0))RETURN READ(LINE,*) FLF(ILAY)%FNAME; LINE='FLF_L'//TRIM(VTOS(ILAY))//'='//TRIM(FLF(ILAY)%FNAME); WRITE(*,'(A)') TRIM(LINE) ENDIF ENDDO IF(.NOT.UTL_READINITFILE('OUTPUTMAP',LINE,IU,0))RETURN READ(LINE,*) OUTPUTMAP; WRITE(*,'(A)') 'OUTPUTMAP='//TRIM(OUTPUTMAP) DO ILAY=1,NLAY WRITE(*,'(A,I10)') 'Reading files for layer ',ILAY IF(ILAY.EQ.1.AND.IWINDOW.EQ.0)THEN IF(.NOT.IDFREAD(HEAD(ILAY),HEAD(ILAY)%FNAME,1))RETURN CALL IDFCOPY(HEAD(ILAY),IDF) ELSE CALL IDFCOPY(IDF,HEAD(ILAY)); IF(.NOT.IDFREADSCALE(HEAD(ILAY)%FNAME,HEAD(ILAY),2,1,0.0D0,0))RETURN ENDIF CALL IDFCOPY(IDF,FRF(ILAY)); IF(.NOT.IDFREADSCALE(FRF(ILAY)%FNAME,FRF(ILAY),17,1,0.0D0,0))RETURN CALL IDFCOPY(IDF,FFF(ILAY)); IF(.NOT.IDFREADSCALE(FFF(ILAY)%FNAME,FFF(ILAY),18,1,0.0D0,0))RETURN IF(ILAY.LT.NLAY)THEN CALL IDFCOPY(IDF,FLF(ILAY)); IF(.NOT.IDFREADSCALE(FLF(ILAY)%FNAME,FLF(ILAY),4,1,0.0D0,0))RETURN ENDIF ENDDO DO ILAY=1,NLAY CALL IDFCOPY(HEAD(ILAY),CC(ILAY)) CALL IDFCOPY(HEAD(ILAY),CR(ILAY)) IF(ILAY.LT.NLAY)CALL IDFCOPY(HEAD(ILAY),CV(ILAY)) ENDDO !## compute kd and c values DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL DO ILAY=1,NLAY CR(ILAY)%X(ICOL,IROW)=0.0 CC(ILAY)%X(ICOL,IROW)=0.0 IF(ILAY.LT.NLAY)CV(ILAY)%X(ICOL,IROW)=0.0 IF(HEAD(ILAY)%X(ICOL,IROW).EQ.HEAD(ILAY)%NODATA)CYCLE IF(ICOL.LT.HEAD(ILAY)%NCOL)THEN CALL IDFGETDXDY(IDF,ICOL ,IROW,DX1,DY1) CALL IDFGETDXDY(IDF,ICOL+1,IROW,DX2,DY1) DH=HEAD(ILAY)%X(ICOL,IROW)-HEAD(ILAY)%X(ICOL+1,IROW) Q =FRF(ILAY)%X(ICOL,IROW) IF(DH.NE.0.0)CR(ILAY)%X(ICOL,IROW)=ABS(Q/DH) F=DY1/(0.5D0*(DX1+DX2)) CR(ILAY)%X(ICOL,IROW)=CR(ILAY)%X(ICOL,IROW)*F ENDIF IF(IROW.LT.HEAD(ILAY)%NROW)THEN CALL IDFGETDXDY(IDF,ICOL,IROW ,DX1,DY1) CALL IDFGETDXDY(IDF,ICOL,IROW+1,DX1,DY2) DH=HEAD(ILAY)%X(ICOL,IROW)-HEAD(ILAY)%X(ICOL,IROW+1) Q =FFF(ILAY)%X(ICOL,IROW) IF(DH.NE.0.0)CC(ILAY)%X(ICOL,IROW)=ABS(Q/DH) F=DY1/(0.5D0*(DX1+DX2)) CC(ILAY)%X(ICOL,IROW)=CC(ILAY)%X(ICOL,IROW)*F ENDIF IF(ILAY.LT.NLAY)THEN DH=HEAD(ILAY)%X(ICOL,IROW)-HEAD(ILAY+1)%X(ICOL,IROW) Q =FLF(ILAY)%X(ICOL,IROW) IF(DH.NE.0.0)CV(ILAY)%X(ICOL,IROW)=ABS(Q/DH) ENDIF ENDDO ENDDO; ENDDO DO ILAY=1,NLAY HEAD(ILAY)%FNAME=TRIM(OUTPUTMAP)//'\HEAD_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(HEAD(ILAY),HEAD(ILAY)%FNAME,1))RETURN FFF(ILAY)%FNAME=TRIM(OUTPUTMAP)//'\FFF_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(FFF(ILAY),FFF(ILAY)%FNAME,1))RETURN FRF(ILAY)%FNAME=TRIM(OUTPUTMAP)//'\FRF_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(FRF(ILAY),FRF(ILAY)%FNAME,1))RETURN CC(ILAY)%FNAME=TRIM(OUTPUTMAP)//'\CC_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(CC(ILAY),CC(ILAY)%FNAME,1))RETURN CR(ILAY)%FNAME=TRIM(OUTPUTMAP)//'\CR_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(CR(ILAY),CR(ILAY)%FNAME,1))RETURN IF(ILAY.LT.NLAY)THEN CV(ILAY)%FNAME=TRIM(OUTPUTMAP)//'\CV_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(CV(ILAY),CV(ILAY)%FNAME,1))RETURN FLF(ILAY)%FNAME=TRIM(OUTPUTMAP)//'\FLF_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(FLF(ILAY),FLF(ILAY)%FNAME,1))RETURN ENDIF ENDDO END SUBROUTINE IMODBATCH_COMPUTEKDC !###====================================================================== SUBROUTINE IMODBATCH_PRJTOMF6() !###====================================================================== IMPLICIT NONE REAL(KIND=DP_KIND),PARAMETER :: VAH=1.0D0 !## vertical anisotropy aquifer REAL(KIND=DP_KIND),PARAMETER :: VAV=1.0D0 !## vertical anisotropy aquitard REAL(KIND=DP_KIND),PARAMETER :: STV=0.00001 !## storage aquitard INTEGER :: I,J,K,ILAY,IROW,ICOL,NLAY,MLAY,IPER,ISYS,JLAY,IL1,IL2,IL3,JL1,JL2,JL3,II TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: TOP,BOT,KHV,KVV,KVA,BND,SHD,STO,SPY,JDF TYPE(IDFOBJ) :: IDF CHARACTER(LEN=256) :: PRJFILE,OUTPUTMAP,FNAME INTEGER,DIMENSION(:),ALLOCATABLE :: ILY,CLY,IB REAL(KIND=DP_KIND) :: T,B,C,C1,C2,MINKD,MINC,MINC_AQUITARD,F,MINTHICKNESS,NT,AT,CT,SKD,SVC,MINT LOGICAL,DIMENSION(11) :: LPCK INTEGER,DIMENSION(11) :: TPCS1=[TBND,TTOP,TBOT,TKDW,TVCW,TKHV,TKVV,TKVA,TSHD,TSTO,TSPY] INTEGER,DIMENSION(8) :: TPCS2=[TBND,TTOP,TBOT, TKHV ,TKVA,TSHD,TSTO,TSPY] INTEGER,DIMENSION(11) :: TPCS3=[TWEL,TDRN,TRIV,TGHB,TRCH,TEVT,TISG,TOLF,TCHD,TANI,THFB] REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: TH,TP,BT,HK,VK,VA,KD,VC LOGICAL :: LERROR,LEX LERROR=.FALSE. IWINDOW=0; IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN IWINDOW=1 READ(LINE,*) IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX WRITE(*,'(A,4F15.3)') 'WINDOW=',IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,0))RETURN READ(LINE,*) IDF%DX; WRITE(*,'(A,F10.2)') 'CELLSIZE=',IDF%DX IDF%DY=IDF%DX CALL UTL_IDFSNAPTOGRID_LLC(IDF%XMIN,IDF%XMAX,IDF%YMIN,IDF%YMAX,IDF%DX,IDF%DY,IDF%NCOL,IDF%NROW,LLC=.TRUE.) ENDIF IF(.NOT.UTL_READINITFILE('PRJFILE_IN',LINE,IU,0))RETURN READ(LINE,*) PRJFILE; WRITE(*,'(A)') 'PRJFILE_IN='//TRIM(PRJFILE) MINKD=0.0D0; IF(UTL_READINITFILE('MINKD',LINE,IU,1))THEN READ(LINE,*) MINKD; WRITE(*,'(A)') 'MINKD='//TRIM(VTOS(MINKD,'F',7)) ENDIF MINC=0.0D0; IF(UTL_READINITFILE('MINC',LINE,IU,1))THEN READ(LINE,*) MINC; WRITE(*,'(A)') 'MINC='//TRIM(VTOS(MINC,'F',7)) ENDIF CALL PMANAGER_UTL_INIT() IF(.NOT.PMANAGER_LOADPRJ(PRJFILE,1))STOP !## get maximum number of layers CALL PMANAGER_GETNFILES((/TBND/),NLAY) IF(NLAY.LE.0)STOP 'NUMBER OF LAYERS FOUND <= 0' ALLOCATE(ILY(NLAY*2-1),CLY(NLAY)); ILY=0; CLY=0 MLAY=NLAY*2-1; ALLOCATE(BND(MLAY),SHD(MLAY),TOP(MLAY),BOT(MLAY),KHV(MLAY),KVA(MLAY),KVV(MLAY-1),STO(MLAY),SPY(MLAY)) K=MLAY*8; ALLOCATE(JDF(K)); DO I=1,K; CALL IDFNULLIFY(JDF(I)); ENDDO; CALL IDFNULLIFY(IDF) !## allocate chd for each aquifer (if not existing yet) IF(.NOT.ASSOCIATED(TOPICS(TCHD)%STRESS))THEN IPER=0; CALL PMANAGER_STRESSES(TCHD,IPER); J=TOPICS(TCHD)%NSUBTOPICS ALLOCATE(TOPICS(TCHD)%STRESS(IPER)%FILES(J,NLAY)); TOPICS(TCHD)%STRESS(IPER)%FILES%FNAME='' TOPICS(TCHD)%STRESS(1)%CDATE='STEADY-STATE' !## copy shd into chd DO I=1,NLAY TOPICS(TCHD)%STRESS(IPER)%FILES(1,I)%FNAME=TOPICS(TSHD)%STRESS(IPER)%FILES(1,I)%FNAME TOPICS(TCHD)%STRESS(IPER)%FILES(1,I)%IACT =TOPICS(TSHD)%STRESS(IPER)%FILES(1,I)%IACT TOPICS(TCHD)%STRESS(IPER)%FILES(1,I)%ILAY =TOPICS(TSHD)%STRESS(IPER)%FILES(1,I)%ILAY TOPICS(TCHD)%STRESS(IPER)%FILES(1,I)%ICNST=TOPICS(TSHD)%STRESS(IPER)%FILES(1,I)%ICNST TOPICS(TCHD)%STRESS(IPER)%FILES(1,I)%CNST =TOPICS(TSHD)%STRESS(IPER)%FILES(1,I)%CNST ENDDO ENDIF !## fill in names with constant values if needed DO J=1,SIZE(TPCS1) IF(ASSOCIATED(TOPICS(TPCS1(J))%STRESS))THEN LPCK(J)=.TRUE. DO I=1,SIZE(TOPICS(TPCS1(J))%STRESS(1)%FILES,2) IF(TOPICS(TPCS1(J))%STRESS(1)%FILES(1,I)%ICNST.EQ.1)THEN WRITE(TOPICS(TPCS1(J))%STRESS(1)%FILES(1,I)%FNAME,*) TOPICS(TPCS1(J))%STRESS(1)%FILES(1,I)%CNST ENDIF WRITE(*,*) '['//TRIM(TOPICS(TPCS1(J))%CMOD)//'='//TRIM(TOPICS(TPCS1(J))%STRESS(1)%FILES(1,I)%FNAME)//']' TOPICS(TPCS1(J))%STRESS(1)%FILES(1,I)%ICNST=2 TOPICS(TPCS1(J))%STRESS(1)%FILES(1,I)%CNST=0.0D0 ENDDO ENDIF ENDDO !## fill in files I=0; K=0; DO ILAY=1,NLAY I=I+1 CALL IDFNULLIFY(BND(I)); IF(.NOT.IDFREAD(BND(I),TOPICS(TBND)%STRESS(1)%FILES(1,ILAY)%FNAME ,0))RETURN; K=K+1; CALL IDFCOPY(BND(I),JDF(K)) CALL IDFNULLIFY(SHD(I)); IF(.NOT.IDFREAD(SHD(I),TOPICS(TSHD)%STRESS(1)%FILES(1,ILAY)%FNAME ,0))RETURN; K=K+1; CALL IDFCOPY(SHD(I),JDF(K)) CALL IDFNULLIFY(TOP(I)); IF(.NOT.IDFREAD(TOP(I),TOPICS(TTOP)%STRESS(1)%FILES(1,ILAY)%FNAME ,0))RETURN; K=K+1; CALL IDFCOPY(TOP(I),JDF(K)) CALL IDFNULLIFY(BOT(I)); IF(.NOT.IDFREAD(BOT(I),TOPICS(TBOT)%STRESS(1)%FILES(1,ILAY)%FNAME ,0))RETURN; K=K+1; CALL IDFCOPY(BOT(I),JDF(K)) IF(LPCK(10))THEN CALL IDFNULLIFY(STO(I)); IF(.NOT.IDFREAD(STO(I),TOPICS(TSTO)%STRESS(1)%FILES(1,ILAY)%FNAME ,0))RETURN; K=K+1; CALL IDFCOPY(STO(I),JDF(K)) ENDIF IF(LPCK(11))THEN CALL IDFNULLIFY(SPY(I)); IF(.NOT.IDFREAD(SPY(I),TOPICS(TSPY)%STRESS(1)%FILES(1,ILAY)%FNAME ,0))RETURN; K=K+1; CALL IDFCOPY(SPY(I),JDF(K)) ENDIF IF(LPCK(4))THEN CALL IDFNULLIFY(KHV(I)); IF(.NOT.IDFREAD(KHV(I),TOPICS(TKDW)%STRESS(1)%FILES(1,ILAY)%FNAME,0))RETURN; K=K+1; CALL IDFCOPY(KHV(I),JDF(K)) CALL IDFCOPY(BND(I),KVA(I)) ELSE CALL IDFNULLIFY(KHV(I)); IF(.NOT.IDFREAD(KHV(I),TOPICS(TKHV)%STRESS(1)%FILES(1,ILAY)%FNAME,0))RETURN; K=K+1; CALL IDFCOPY(KHV(I),JDF(K)) CALL IDFNULLIFY(KVA(I)); IF(.NOT.IDFREAD(KVA(I),TOPICS(TKVA)%STRESS(1)%FILES(1,ILAY)%FNAME,0))RETURN; K=K+1; CALL IDFCOPY(KVA(I),JDF(K)) ENDIF IF(ILAY.LT.NLAY)THEN I=I+1 CALL IDFNULLIFY(BND(I)); IF(.NOT.IDFREAD(BND(I),TOPICS(TBND)%STRESS(1)%FILES(1,ILAY)%FNAME ,0))RETURN; K=K+1; CALL IDFCOPY(BND(I),JDF(K)) CALL IDFNULLIFY(SHD(I)); IF(.NOT.IDFREAD(SHD(I),TOPICS(TSHD)%STRESS(1)%FILES(1,ILAY)%FNAME ,0))RETURN; K=K+1; CALL IDFCOPY(SHD(I),JDF(K)) CALL IDFNULLIFY(TOP(I)); IF(.NOT.IDFREAD(TOP(I),TOPICS(TBOT)%STRESS(1)%FILES(1,ILAY)%FNAME ,0))RETURN; K=K+1; CALL IDFCOPY(TOP(I),JDF(K)) CALL IDFNULLIFY(BOT(I)); IF(.NOT.IDFREAD(BOT(I),TOPICS(TTOP)%STRESS(1)%FILES(1,ILAY+1)%FNAME,0))RETURN; K=K+1; CALL IDFCOPY(BOT(I),JDF(K)) CALL IDFCOPY(BND(I),KVA(I)) IF(LPCK(5))THEN CALL IDFNULLIFY(KHV(I)); IF(.NOT.IDFREAD(KHV(I),TOPICS(TVCW)%STRESS(1)%FILES(1,ILAY)%FNAME,0))RETURN; K=K+1; CALL IDFCOPY(KHV(I),JDF(K)) ELSE CALL IDFNULLIFY(KHV(I)); IF(.NOT.IDFREAD(KHV(I),TOPICS(TKVV)%STRESS(1)%FILES(1,ILAY)%FNAME,0))RETURN; K=K+1; CALL IDFCOPY(KHV(I),JDF(K)) ENDIF ENDIF ENDDO MINTHICKNESS=0.0D0; MINC_AQUITARD=0.0D0 IF(UTL_READINITFILE('MINTHICKNESS',LINE,IU,1))THEN READ(LINE,*) MINTHICKNESS; WRITE(*,'(A)') 'MINTHICKNESS='//TRIM(VTOS(MINTHICKNESS,'F',7)) ENDIF IF(LPCK(4))THEN MINC_AQUITARD=0.0D0; IF(UTL_READINITFILE('MINC_AQUITARD',LINE,IU,1))THEN READ(LINE,*) MINC_AQUITARD; WRITE(*,'(A)') 'MINC_AQUITARD='//TRIM(VTOS(MINC_AQUITARD,'F',7)) ENDIF ENDIF !## find overlapping minimal cellsizes IF(IWINDOW.EQ.0)THEN IF(.NOT.IDF_EXTENT(K,JDF,IDF,2))STOP 'CANNOT FIND OVERLAPPING EXTENT'; CALL IDFDEALLOCATE(JDF,SIZE(JDF)); DEALLOCATE(JDF) ENDIF WRITE(*,'(/1X,A)') 'MINIMAL OVERLAPPING AREA FOR PROCESSING BND,TOP,BOT,KHV,KVA,KVV IS:' WRITE(*,'( 1X,2(A,F15.3))') 'XMIN=',IDF%XMIN,' ; XMAX=',IDF%XMAX WRITE(*,'( 1X,2(A,F15.3))') 'YMIN=',IDF%YMIN,' ; YMAX=',IDF%YMAX WRITE(*,'(A)') 'Errors' WRITE(*,'(A10,3A5,4A15)') 'LAYERTYPE','ICOL','IROW','ILAY','KHV','TOP','BOT','THICK' !## read top/bot I=0; DO ILAY=1,NLAY WRITE(*,'(A,I10)') 'READING FILES FOR LAYER ',ILAY I=I+1 CALL IDFCOPY(IDF,BND(I)); IF(.NOT.IDFREADSCALE(TOPICS(TBND)%STRESS(1)%FILES(1,ILAY)%FNAME ,BND(I),1,1,0.0D0,0))RETURN CALL IDFCOPY(IDF,SHD(I)); IF(.NOT.IDFREADSCALE(TOPICS(TSHD)%STRESS(1)%FILES(1,ILAY)%FNAME ,SHD(I),2,1,0.0D0,0))RETURN CALL IDFCOPY(IDF,TOP(I)); IF(.NOT.IDFREADSCALE(TOPICS(TTOP)%STRESS(1)%FILES(1,ILAY)%FNAME ,TOP(I),2,1,0.0D0,0))RETURN CALL IDFCOPY(IDF,BOT(I)); IF(.NOT.IDFREADSCALE(TOPICS(TBOT)%STRESS(1)%FILES(1,ILAY)%FNAME ,BOT(I),2,1,0.0D0,0))RETURN IF(LPCK(10))THEN CALL IDFCOPY(IDF,STO(I)); IF(.NOT.IDFREADSCALE(TOPICS(TSTO)%STRESS(1)%FILES(1,ILAY)%FNAME,STO(I),2,1,0.0D0,0))RETURN ENDIF IF(LPCK(11))THEN CALL IDFCOPY(IDF,SPY(I)); IF(.NOT.IDFREADSCALE(TOPICS(TSPY)%STRESS(1)%FILES(1,ILAY)%FNAME,SPY(I),2,1,0.0D0,0))RETURN ENDIF IF(LPCK(4))THEN CALL IDFCOPY(IDF,KHV(I)); IF(.NOT.IDFREADSCALE(TOPICS(TKDW)%STRESS(1)%FILES(1,ILAY)%FNAME,KHV(I),3,1,0.0D0,0))RETURN CALL IDFCOPY(BND(I),KVA(I)); KVA(I)%X=VAH !## make k-values DO IROW=1,BND(1)%NROW; DO ICOL=1,BND(1)%NCOL IF(BND(I)%X(ICOL,IROW).EQ.0.0D0)CYCLE !## resistance higher than zero T=TOP(I)%X(ICOL,IROW); B=BOT(I)%X(ICOL,IROW) !## use a minimal kdw-value KHV(I)%X(ICOL,IROW)=MAX(MINKD,KHV(I)%X(ICOL,IROW)) IF(T-B.GT.0.0D0)THEN IF(KHV(I)%X(ICOL,IROW).LE.0.0D0)THEN WRITE(*,'(A10,3I5,F15.7,3F15.7)') 'AQUIFER',ICOL,IROW,ILAY,KHV(I)%X(ICOL,IROW),T,B,T-B ENDIF KHV(I)%X(ICOL,IROW)=KHV(I)%X(ICOL,IROW)/(T-B) !## 1 day resistance as in this type of model resistance is given by vcw KVA(I)%X(ICOL,IROW)=T-B ENDIF ENDDO; ENDDO ELSE CALL IDFCOPY(IDF,KHV(I)); IF(.NOT.IDFREADSCALE(TOPICS(TKHV)%STRESS(1)%FILES(1,ILAY)%FNAME,KHV(I),3,1,0.0D0,0))RETURN CALL IDFCOPY(IDF,KVA(I)); IF(.NOT.IDFREADSCALE(TOPICS(TKVA)%STRESS(1)%FILES(1,ILAY)%FNAME,KVA(I),2,1,0.0D0,0))RETURN ENDIF IF(ILAY.LT.NLAY)THEN I=I+1 CALL IDFCOPY(IDF,BND(I)); IF(.NOT.IDFREADSCALE(TOPICS(TBND)%STRESS(1)%FILES(1,ILAY)%FNAME ,BND(I),1,1,0.0D0,0))RETURN CALL IDFCOPY(IDF,SHD(I)); IF(.NOT.IDFREADSCALE(TOPICS(TSHD)%STRESS(1)%FILES(1,ILAY)%FNAME ,SHD(I),2,1,0.0D0,0))RETURN CALL IDFCOPY(IDF,TOP(I)); IF(.NOT.IDFREADSCALE(TOPICS(TBOT)%STRESS(1)%FILES(1,ILAY)%FNAME ,TOP(I),2,1,0.0D0,0))RETURN CALL IDFCOPY(IDF,BOT(I)); IF(.NOT.IDFREADSCALE(TOPICS(TTOP)%STRESS(1)%FILES(1,ILAY+1)%FNAME,BOT(I),2,1,0.0D0,0))RETURN CALL IDFCOPY(BND(I),KVA(I)); KVA(I)%X=VAV IF(LPCK(10))THEN; CALL IDFCOPY(BND(I),STO(I)); STO(I)%X=STO(I-1)%X; ENDIF IF(LPCK(11))THEN; CALL IDFCOPY(BND(I),SPY(I)); SPY(I)%X=SPY(I-1)%X; ENDIF IF(LPCK(5))THEN CALL IDFCOPY(IDF,KHV(I)); IF(.NOT.IDFREADSCALE(TOPICS(TVCW)%STRESS(1)%FILES(1,ILAY)%FNAME,KHV(I),6,1,0.0D0,0))RETURN !## make k-values from c-values DO IROW=1,BND(1)%NROW; DO ICOL=1,BND(1)%NCOL IF(BND(I)%X(ICOL,IROW).EQ.0.0D0)CYCLE !## use a minimal vertical resistance KHV(I)%X(ICOL,IROW)=MAX(MINC,KHV(I)%X(ICOL,IROW)) !## resistance higher than zero IF(KHV(I)%X(ICOL,IROW).GT.0.0D0)THEN T=TOP(I)%X(ICOL,IROW); B=BOT(I)%X(ICOL,IROW) IF(T-B.GT.0.0D0)THEN IF(KHV(I)%X(ICOL,IROW).LE.0.0D0)THEN WRITE(*,'(A10,3I5,F15.7,3F15.7)') 'AQUITARD',ICOL,IROW,ILAY,KHV(I)%X(ICOL,IROW),T,B,T-B ENDIF KHV(I)%X(ICOL,IROW)=(T-B)/(KHV(I)%X(ICOL,IROW)*KVA(I)%X(ICOL,IROW)) ELSE !## it remains a resistance becomes a layer if resistance is higher than minc_aquitard ENDIF ELSE KHV(I)%X(ICOL,IROW)=0.0D0 ENDIF ENDDO; ENDDO ELSE CALL IDFCOPY(IDF,KHV(I)); IF(.NOT.IDFREADSCALE(TOPICS(TKVV)%STRESS(1)%FILES(1,ILAY)%FNAME,KHV(I),3,1,0.0D0,0))RETURN ENDIF ENDIF ENDDO !## one modification, sto for aquitard1 need to be equal to sto IF(LPCK(10))THEN DO IROW=1,BND(1)%NROW; DO ICOL=1,BND(1)%NCOL DO I=2,MLAY,2 T=TOP(I)%X(ICOL,IROW); B=BOT(I)%X(ICOL,IROW) STO(I)%X(ICOL,IROW)=STV*(T-B) ENDDO ENDDO; ENDDO ENDIF ALLOCATE(TP(MLAY),BT(MLAY),HK(MLAY),VA(MLAY),IB(MLAY),TH(MLAY),KD(MLAY),VC(MLAY),VK(MLAY)) !## kdw/vcw-model and minthickness>0 IF(LPCK(4).AND.MINTHICKNESS.GT.0.0D0)THEN !## remove tiny layer thicknesses DO IROW=1,BND(1)%NROW; DO ICOL=1,BND(1)%NCOL ! IF(IROW.EQ.17.AND.ICOL.EQ.25)THEN ! WRITE(*,*) ! ENDIF DO ILAY=1,MLAY IB(ILAY)=BND(ILAY)%X(ICOL,IROW) TP(ILAY)=TOP(ILAY)%X(ICOL,IROW) BT(ILAY)=BOT(ILAY)%X(ICOL,IROW) HK(ILAY)=KHV(ILAY)%X(ICOL,IROW) VA(ILAY)=KVA(ILAY)%X(ICOL,IROW) ENDDO TH=0.0D0; KD=0.0D0; VC=0.0D0 IF(LERROR)WRITE(*,'(/A5,A5,7A10)') 'ILAY','IB','TP','BT','TH','HK','VA','KD','VC' DO ILAY=1,MLAY !## make sure thickness is at least zero (no negative thicknesses allowed) IF(IB(ILAY).NE.0)TH(ILAY)=MAX(0.0D0,TP(ILAY)- BT(ILAY)) ENDDO MINT=0.0D0; DO ILAY=1,MLAY,2; IF(IB(ILAY).NE.0)MINT=MINT+TH(ILAY); ENDDO MINT=MIN(MINTHICKNESS,MINT/(REAL(MLAY+1,8)/2.0D0)) !## probably only aquitards found - strange IF(MINT.EQ.0.0D0)MINT=MINTHICKNESS DO ILAY=1,MLAY IF(IB(ILAY).NE.0)THEN !## add thickness in case kh>0 and thickness is zero - due to this profile might become thicker with mint LEX=.FALSE. IF(TH(ILAY).EQ.0.0D0)THEN IF(MOD(ILAY,2).NE.0)THEN !## aquifer IF(HK(ILAY).NE.0.0D0)LEX=.TRUE. ELSE !## aquitard IF(HK(ILAY).GT.MINC_AQUITARD)LEX=.TRUE. ENDIF !,KHV(I)%X(ICOL,IROW)=0.0D0 ENDIF IF(LEX)THEN TH(ILAY)=MINT !## convert vertical resistance to permeability IF(MOD(ILAY,2).EQ.0)THEN HK(ILAY)=MINT/HK(ILAY) !## convert transmissivity to permeability ELSE HK(ILAY)=HK(ILAY)/MINT VA(ILAY)=MINT ENDIF !## see from what layer mint can be removed DO JLAY=ILAY+1,MLAY IF(TH(JLAY).GT.2.0D0*MINT)THEN F=TH(JLAY)/(TH(JLAY)-MINT) TH(JLAY)=TH(JLAY)-MINT !## increase permeability HK(JLAY)=HK(JLAY)*F EXIT ENDIF ENDDO ENDIF KD(ILAY)=HK(ILAY)* TH(ILAY) IF(HK(ILAY)*VA(ILAY).GT.0.0D0)VC(ILAY)=TH(ILAY)/(HK(ILAY)*VA(ILAY)) ENDIF IF(LERROR)WRITE(*,'(2I5,7F10.3)') ILAY,IB(ILAY),TP(ILAY),BT(ILAY),TH(ILAY),HK(ILAY),VA(ILAY),KD(ILAY),VC(ILAY) ENDDO IF(LERROR)WRITE(*,'(30X,5F10.3)') SUM(TH),SUM(HK),SUM(VA),SUM(KD),SUM(VC) SKD=SUM(KD) SVC=SUM(VC) !## only looking downwards DO ILAY=1,MLAY !## skip inactive cells IF(IB(ILAY).EQ.0)CYCLE !## skip aquitards IF(MOD(ILAY,2).EQ.0)CYCLE !## nothing to do, no permeability found IF(HK(ILAY).EQ.0.0D0)CYCLE !## thickness zero, increase thickness IF(TH(ILAY).LT.MINT)THEN DO JLAY=ILAY+1,MLAY !## needed thickness NT=MINT-TH(ILAY) !## achievable thickness from current layer to get AT=MIN(TH(JLAY),NT) IF(AT.GT.0.0D0)THEN !## add to current layer KD(ILAY)=KD(ILAY)+AT* HK(JLAY) VC(ILAY)=VC(ILAY)+AT/(HK(JLAY)*VA(JLAY)) TH(ILAY)=TH(ILAY)+AT !## remove from target layer KD(JLAY)=KD(JLAY)-AT* HK(JLAY) VC(JLAY)=VC(JLAY)-AT/(HK(JLAY)*VA(JLAY)) TH(JLAY)=TH(JLAY)-AT IF(TH(ILAY).GE.MINT)EXIT ENDIF ENDDO ENDIF ENDDO !## remove from below zero thickness layers DO ILAY=MLAY,1,-1; IF(TH(ILAY).GT.0.0D0)EXIT; IB(ILAY)=0; ENDDO !## set new top/bot/kh values IF(LERROR)WRITE(*,'(/A5,A5,7A10)') 'ILAY','IB','TP','BT','TH','HK','VA','KD','VC' DO ILAY=1,MLAY BT(ILAY) =TP(ILAY)-TH(ILAY) IF(ILAY.LT.MLAY)TP(ILAY+1)=BT(ILAY) !## skip inactive cells IF(IB(ILAY).NE.0)THEN IF(MOD(ILAY,2).NE.0.AND.TH(ILAY).LE.0.0D0)THEN WRITE(*,*) 'CANNOT BE'; PAUSE ELSE IF(TH(ILAY).GT.0.0D0)THEN HK(ILAY) = KD(ILAY)/(TH(ILAY)) IF(VC(ILAY).GE.0.0D0)VK(ILAY) =(TH(ILAY))/VC(ILAY) IF(HK(ILAY).GT.0.0D0)VA(ILAY) = VK(ILAY)/HK(ILAY) ELSE HK(ILAY)=1.0D0 VK(ILAY)=1.0D0 VA(ILAY)=1.0D0 KD(ILAY)=0.0D0 VC(ILAY)=0.0D0 ENDIF ENDIF ELSE HK(ILAY)=1.0D0 VK(ILAY)=1.0D0 VA(ILAY)=1.0D0 KD(ILAY)=0.0D0 VC(ILAY)=0.0D0 ENDIF IF(LERROR)WRITE(*,'(2I5,7F10.3)') ILAY,IB(ILAY),TP(ILAY),BT(ILAY),TH(ILAY),HK(ILAY),VA(ILAY),KD(ILAY),VC(ILAY) ENDDO IF(LERROR)WRITE(*,'(30X,5F10.3)') SUM(TH),SUM(HK),SUM(VA),SUM(KD),SUM(VC) IF(ABS(SKD-SUM(KD)).GT.1.0D0.OR.ABS(SVC-SUM(VC)).GT.1.0D0.OR.MINVAL(HK).LT.0.0D0.OR.MINVAL(KD).LT.0.0D0.OR.MINVAL(VA).LT.0.0D0.OR.MINVAL(VC).LT.0.0D0)THEN WRITE(*,'(/2A5,7A10)') 'ILAY','IB','TP','BT','TH','HK','VA','KD','VC' DO ILAY=1,MLAY WRITE(*,'(2I5,7F10.3)') ILAY,IB(ILAY),TP(ILAY),BT(ILAY),TH(ILAY),HK(ILAY),VA(ILAY),KD(ILAY),VC(ILAY) ENDDO WRITE(*,'(30X,5F10.3)') SUM(TH),SUM(HK),SUM(VA),SUM(KD),SUM(VC) PAUSE ENDIF DO ILAY=1,MLAY !## skip inactive cells BND(ILAY)%X(ICOL,IROW)=IB(ILAY) TOP(ILAY)%X(ICOL,IROW)=TP(ILAY) BOT(ILAY)%X(ICOL,IROW)=BT(ILAY) IF(IB(ILAY).EQ.0)THEN KHV(ILAY)%X(ICOL,IROW)=1.0D0 KVA(ILAY)%X(ICOL,IROW)=1.0D0 ELSE KHV(ILAY)%X(ICOL,IROW)=HK(ILAY) KVA(ILAY)%X(ICOL,IROW)=VA(ILAY) ENDIF ENDDO ENDDO; ENDDO ELSE !## remove tiny layer thicknesses DO IROW=1,BND(1)%NROW; DO ICOL=1,BND(1)%NCOL IF(LERROR)WRITE(*,'(/A5,A5,7A10)') 'ILAY','IB','TP','BT','TH','HK','VA','KD','VC' DO ILAY=1,MLAY IB(ILAY)=BND(ILAY)%X(ICOL,IROW) TP(ILAY)=TOP(ILAY)%X(ICOL,IROW) BT(ILAY)=BOT(ILAY)%X(ICOL,IROW) HK(ILAY)=KHV(ILAY)%X(ICOL,IROW) IF(HK(ILAY).LT.0.0D0)THEN WRITE(*,'(2I5,7F10.3)') ILAY,IB(ILAY),TP(ILAY),BT(ILAY),TH(ILAY),HK(ILAY),VA(ILAY),KD(ILAY),VC(ILAY) PAUSE ENDIF VA(ILAY)=KVA(ILAY)%X(ICOL,IROW) IF(LERROR)WRITE(*,'(2I5,7F10.3)') ILAY,IB(ILAY),TP(ILAY),BT(ILAY),TH(ILAY),HK(ILAY),VA(ILAY),KD(ILAY),VC(ILAY) ENDDO IF(LERROR)WRITE(*,'(30X,5F10.3)') SUM(TH),SUM(HK),SUM(VA),SUM(KD),SUM(VC) TH=0.0D0; KD=0.0D0; VC=0.0D0 DO ILAY=1,MLAY IF(IB(ILAY).NE.0)TH(ILAY)=TP(ILAY)- BT(ILAY) IF(TH(ILAY).LE.MINTHICKNESS)TH(ILAY)=0.0D0 ENDDO IF(LERROR)WRITE(*,'(/A5,A5,7A10)') 'ILAY','IB','TP','BT','TH','HK','VA','KD','VC' DO ILAY=1,MLAY BT(ILAY) =TP(ILAY)-TH(ILAY) IF(ILAY.LT.MLAY)TP(ILAY+1)=BT(ILAY) IF(LERROR)WRITE(*,'(2I5,7F10.3)') ILAY,IB(ILAY),TP(ILAY),BT(ILAY),TH(ILAY),HK(ILAY),VA(ILAY),KD(ILAY),VC(ILAY) ENDDO IF(LERROR)WRITE(*,'(30X,5F10.3)') SUM(TH),SUM(HK),SUM(VA),SUM(KD),SUM(VC) ENDDO; ENDDO ENDIF DEALLOCATE(TP,BT,HK,VK,VA,IB,TH,KD,VC) !## correct bnd if top/bot nodata turn into inactive DO IROW=1,BND(1)%NROW; DO ICOL=1,BND(1)%NCOL DO I=1,MLAY !## see whether layer has a thickness T=TOP(I)%X(ICOL,IROW); B=BOT(I)%X(ICOL,IROW); IF(T.LE.B)CYCLE !## monitor number of active cells ILY(I)=ILY(I)+1 ENDDO ENDDO; ENDDO WRITE(*,'(A10,A10,A10)') 'Layer','L.Type','Act.Nodes' J=0; DO I=1,NLAY J=J+1; WRITE(*,'(I10,I10,A10,I10)') I,J,'Aquifer ',ILY(J) IF(I.LT.NLAY)THEN J=J+1; WRITE(*,'(10X,I10,A10,I10)') J,'Aquitard',ILY(J) ENDIF ENDDO !## process vertical permeability previous aquitards DO I=2,MLAY,2 DO IROW=1,BND(1)%NROW; DO ICOL=1,BND(1)%NCOL IF(BND(I)%X(ICOL,IROW).EQ.0.0D0)CYCLE !## k-aquitard for resistance in aquifers T=TOP(I-1)%X(ICOL,IROW); B=BOT(I-1)%X(ICOL,IROW) C1=0.0D0; IF(T-B.GT.0.0D0)C1=(T-B)/(KHV(I-1)%X(ICOL,IROW)*KVA(I-1)%X(ICOL,IROW)) T=TOP(I+1)%X(ICOL,IROW); B=BOT(I+1)%X(ICOL,IROW) C2=0.0D0; IF(T-B.GT.0.0D0)C2=(T-B)/(KHV(I+1)%X(ICOL,IROW)*KVA(I+1)%X(ICOL,IROW)) !## see whether aquitard has a thickness T=TOP(I)%X(ICOL,IROW); B=BOT(I)%X(ICOL,IROW) !## existing physical aquitard IF(T-B.GT.0.0D0)THEN C =(T-B)/(KHV(I )%X(ICOL,IROW)*KVA(I )%X(ICOL,IROW)) C=C-0.5D0*(C1+C2) C=MAX(MINC,C) IF(C.LE.0.0D0)THEN !## resistance need to be negative, set minimal 1.0d0 C=MAX(1.0D0,C) ENDIF T=TOP(I)%X(ICOL,IROW); B=BOT(I)%X(ICOL,IROW) !## resistance aquitard set in kva if(c.le.0.0d0.or.khv(i)%x(icol,irow).le.0.0d0)then write(*,*) 'c,khv(i) ',c,khv(i)%x(icol,irow) endif KVA(I)%X(ICOL,IROW)=((T-B)/C)/KHV(I)%X(ICOL,IROW) if(KVA(I)%X(ICOL,IROW).ne.KVA(I)%X(ICOL,IROW))then write(*,*) 'kva(i) ',KVA(I)%X(ICOL,IROW) endif !## if there is not an aquitard, distribute resistance among layers ELSE ! IF(IROW.EQ.17.AND.ICOL.EQ.25)THEN ! WRITE(*,*) ! ENDIF !## khv is still resistance C =KHV(I)%X(ICOL,IROW) IF(C.GT.0.0D0)THEN ! !## add half of the resistance to both modellayers, divided by their resistance ratio ! IF(C1.EQ.0.0D0)C1=1.0D0; IF(C2.EQ.0.0D0)C2=1.0D0 F=(0.5D0*C)/(0.5D0*C1) !## new c-value to be assigned C1=C1*F !## change kva of part of upper aquifer T=TOP(I-1)%X(ICOL,IROW); B=BOT(I-1)%X(ICOL,IROW) IF(T-B.GT.0.0D0)THEN if(c1.le.0.0d0.or.khv(i-1)%x(icol,irow).le.0.0d0)then write(*,*) 'c1,khv(i-1) ',c1,khv(i-1)%x(icol,irow) endif KVA(I-1)%X(ICOL,IROW)=((T-B)/C1)/KHV(I-1)%X(ICOL,IROW) if(KVA(I-1)%X(ICOL,IROW).ne.KVA(I-1)%X(ICOL,IROW))then write(*,*) 'kva(i-1) ',KVA(I-1)%X(ICOL,IROW) endif ENDIF F=(0.5D0*C)/(0.5D0*C2) C2=C2*F !## change kva of part of lower aquifer T=TOP(I+1)%X(ICOL,IROW); B=BOT(I+1)%X(ICOL,IROW) IF(T-B.GT.0.0D0)THEN if(c2.le.0.0d0.or.khv(i+1)%x(icol,irow).le.0.0d0)then write(*,*) 'c2,khv(i+1) ',c2,khv(i+1)%x(icol,irow) endif KVA(I+1)%X(ICOL,IROW)=((T-B)/C2)/KHV(I+1)%X(ICOL,IROW) if(KVA(I+1)%X(ICOL,IROW).ne.KVA(I+1)%X(ICOL,IROW))then write(*,*) 'kva(i+1) ',KVA(I+1)%X(ICOL,IROW) endif ENDIF ENDIF ENDIF ENDDO ENDDO; ENDDO !## correct bnd from the bottom to the top DO IROW=1,BND(1)%NROW; DO ICOL=1,BND(1)%NCOL DO I=MLAY,1,-1 IF(BND(I)%X(ICOL,IROW).NE.0.0D0)THEN !## see whether layer has a thickness T=TOP(I)%X(ICOL,IROW); B=BOT(I)%X(ICOL,IROW) IF(T.LE.B)BND(I)%X(ICOL,IROW)=0.0D0 IF(BND(I)%X(ICOL,IROW).EQ.0.0D0)THEN SHD(I)%X(ICOL,IROW)=1.0D0 ! TOP(I)%X(ICOL,IROW)=TOP(I)%NODATA ! BOT(I)%X(ICOL,IROW)=BOT(I)%NODATA KHV(I)%X(ICOL,IROW)=1.0D0 KVA(I)%X(ICOL,IROW)=1.0D0 IF(LPCK(10))STO(I)%X(ICOL,IROW)=1.0D0 IF(LPCK(11))SPY(I)%X(ICOL,IROW)=1.0D0 ELSE EXIT ENDIF ENDIF ENDDO ENDDO; ENDDO !## correct bnd if top/bot nodata turns into inactive DO IROW=1,BND(1)%NROW; DO ICOL=1,BND(1)%NCOL DO I=1,MLAY IF(BND(I)%X(ICOL,IROW).EQ.0.0D0)CYCLE !## check constant head if head is below bottom IF(BND(I)%X(ICOL,IROW).LT.0.0D0)THEN IF(SHD(I)%X(ICOL,IROW).LT.BOT(I)%X(ICOL,IROW))THEN BND(I)%X(ICOL,IROW)=1.0D0 !## look for appropriate layer DO J=I+1,MLAY IF(BND(J)%X(ICOL,IROW).EQ.0.0D0)CYCLE IF(SHD(I)%X(ICOL,IROW).LT.TOP(J)%X(ICOL,IROW))THEN BND(J)%X(ICOL,IROW)=-1.0D0 ENDIF ENDDO ENDIF ENDIF ENDDO ENDDO; ENDDO !## create coupling table old layers to new layers J=0; K=0; DO I=1,SIZE(ILY) IF(ILY(I).GT.0)K=K+1 IF(MOD(I,2).NE.0)THEN; J=J+1; CLY(J)=K; ENDIF ENDDO !## number of modellayers is NLAY=0; DO I=1,SIZE(ILY) IF(ILY(I).GT.0)NLAY=NLAY+1 ENDDO !## deallocate packages DO I=1,SIZE(TPCS1); CALL PMANAGER_DEALLOCATE(TPCS1(I)); ENDDO !## allocate them DO I=1,SIZE(TPCS2); IPER=0; CALL PMANAGER_STRESSES(TPCS2(I),IPER); J=TOPICS(TPCS2(I))%NSUBTOPICS ALLOCATE(TOPICS(TPCS2(I))%STRESS(IPER)%FILES(J,NLAY)); TOPICS(TPCS2(I))%STRESS(IPER)%FILES%FNAME='' ENDDO IF(.NOT.LPCK(10))CALL PMANAGER_DEALLOCATE(TSTO) IF(.NOT.LPCK(11))CALL PMANAGER_DEALLOCATE(TSPY) IF(.NOT.UTL_READINITFILE('OUTPUTMAP',LINE,IU,0))RETURN READ(LINE,*) OUTPUTMAP; WRITE(*,'(A)') 'OUTPUTMAP='//TRIM(OUTPUTMAP) CALL UTL_CREATEDIR(OUTPUTMAP) ILAY=0; DO I=1,SIZE(ILY) IF(ILY(I).LE.0)CYCLE ILAY=ILAY+1 WRITE(*,'(A,I10)') 'Writing resulting files for layer ',ILAY BND(I)%FNAME=TRIM(OUTPUTMAP)//'\BND\BND_L'//TRIM(VTOS(ILAY))//'.IDF' CALL IMODBATCH_PRJTOMF6_FILLFILES(TOPICS(TBND)%STRESS(1)%FILES(1,ILAY),BND(I)%FNAME,ILAY) IF(.NOT.IDFWRITE(BND(I),BND(I)%FNAME,1))RETURN TOP(I)%FNAME=TRIM(OUTPUTMAP)//'\TOP\TOP_L'//TRIM(VTOS(ILAY))//'.IDF' CALL IMODBATCH_PRJTOMF6_FILLFILES(TOPICS(TTOP)%STRESS(1)%FILES(1,ILAY),TOP(I)%FNAME,ILAY) IF(.NOT.IDFWRITE(TOP(I),TOP(I)%FNAME,1))RETURN BOT(I)%FNAME=TRIM(OUTPUTMAP)//'\BOT\BOT_L'//TRIM(VTOS(ILAY))//'.IDF' CALL IMODBATCH_PRJTOMF6_FILLFILES(TOPICS(TBOT)%STRESS(1)%FILES(1,ILAY),BOT(I)%FNAME,ILAY) IF(.NOT.IDFWRITE(BOT(I),BOT(I)%FNAME,1))RETURN SHD(I)%FNAME=TRIM(OUTPUTMAP)//'\SHD\SHD_L'//TRIM(VTOS(ILAY))//'.IDF' CALL IMODBATCH_PRJTOMF6_FILLFILES(TOPICS(TSHD)%STRESS(1)%FILES(1,ILAY),SHD(I)%FNAME,ILAY) IF(.NOT.IDFWRITE(SHD(I),SHD(I)%FNAME,1))RETURN KHV(I)%FNAME=TRIM(OUTPUTMAP)//'\KHV\KHV_L'//TRIM(VTOS(ILAY))//'.IDF' CALL IMODBATCH_PRJTOMF6_FILLFILES(TOPICS(TKHV)%STRESS(1)%FILES(1,ILAY),KHV(I)%FNAME,ILAY) IF(.NOT.IDFWRITE(KHV(I),KHV(I)%FNAME,1))RETURN KVA(I)%FNAME=TRIM(OUTPUTMAP)//'\KVA\KVA_L'//TRIM(VTOS(ILAY))//'.IDF' CALL IMODBATCH_PRJTOMF6_FILLFILES(TOPICS(TKVA)%STRESS(1)%FILES(1,ILAY),KVA(I)%FNAME,ILAY) IF(.NOT.IDFWRITE(KVA(I),KVA(I)%FNAME,1))RETURN IF(LPCK(10))THEN STO(I)%FNAME=TRIM(OUTPUTMAP)//'\STO\STO_L'//TRIM(VTOS(ILAY))//'.IDF' CALL IMODBATCH_PRJTOMF6_FILLFILES(TOPICS(TSTO)%STRESS(1)%FILES(1,ILAY),STO(I)%FNAME,ILAY) IF(.NOT.IDFWRITE(STO(I),STO(I)%FNAME,1))RETURN ENDIF IF(LPCK(11))THEN SPY(I)%FNAME=TRIM(OUTPUTMAP)//'\SPY\SPY_L'//TRIM(VTOS(ILAY))//'.IDF' CALL IMODBATCH_PRJTOMF6_FILLFILES(TOPICS(TSPY)%STRESS(1)%FILES(1,ILAY),SPY(I)%FNAME,ILAY) IF(.NOT.IDFWRITE(SPY(I),SPY(I)%FNAME,1))RETURN ENDIF ENDDO !## deallocate olf if existing, and add them to each drn-input IF(TOPICS(TOLF)%IACT_MODEL.EQ.1)THEN IF(SIZE(TOPICS(TOLF)%STRESS).GT.1)THEN WRITE(*,'(/1X,A)') '>>> Cannot convert multilayered/multiperiod OLF package <<<'; PAUSE; STOP ENDIF IF(ASSOCIATED(TOPICS(TDRN)%STRESS))THEN DO I=1,SIZE(TOPICS(TDRN)%STRESS) !## create new system ISYS=0; CALL PMANAGER_SYSTEMS(TDRN,I,ISYS) KHV(I)%FNAME=TRIM(OUTPUTMAP)//'\OLF\OLF_COND.IDF' CALL IMODBATCH_PRJTOMF6_FILLFILES(TOPICS(TDRN)%STRESS(I)%FILES(1,ISYS),KHV(I)%FNAME,1) IF(I.EQ.1)THEN KHV(1)%X=KHV(1)%DX**2.0D0; IF(.NOT.IDFWRITE(KHV(I),KHV(I)%FNAME,1))RETURN ENDIF CALL IMODBATCH_PRJTOMF6_FILLFILES(TOPICS(TDRN)%STRESS(I)%FILES(2,ISYS),TOPICS(TOLF)%STRESS(1)%FILES(1,1)%FNAME,1) ENDDO ENDIF CALL PMANAGER_DEALLOCATE(TOLF) ENDIF !## check packages for layering info DO I=1,SIZE(TPCS3) IF(ASSOCIATED(TOPICS(TPCS3(I))%STRESS))THEN CALL IMODBATCH_PRJTOMF6_CORRECTLAYERS(TOPICS(TPCS3(I))%STRESS,CLY,TPCS3(I)) ENDIF ENDDO !## duplicate hfb IF(ASSOCIATED(TOPICS(THFB)%STRESS))THEN J=SIZE(TOPICS(THFB)%STRESS(1)%FILES,2) DO I=1,J !## create new system ISYS=0; CALL PMANAGER_SYSTEMS(THFB,1,ISYS) CALL IMODBATCH_PRJTOMF6_COPYFILES(TOPICS(THFB)%STRESS(1)%FILES(1,I),TOPICS(THFB)%STRESS(1)%FILES(1,ISYS)) TOPICS(THFB)%STRESS(1)%FILES(1,ISYS)%ILAY=TOPICS(THFB)%STRESS(1)%FILES(1,ISYS)%ILAY-1 ENDDO ENDIF IF(.NOT.UTL_READINITFILE('PRJFILE_OUT',LINE,IU,0))RETURN READ(LINE,*) PRJFILE; WRITE(*,'(A)') 'PRJFILE_OUT='//TRIM(PRJFILE) IF(.NOT.PMANAGER_SAVEPRJ(PRJFILE))STOP END SUBROUTINE IMODBATCH_PRJTOMF6 !###====================================================================== SUBROUTINE IMODBATCH_PRJTOMF6_CORRECTLAYERS(STRESS,CLY,ITOPIC) !###====================================================================== IMPLICIT NONE TYPE(STRESSOBJ),INTENT(IN),DIMENSION(:) :: STRESS INTEGER,INTENT(IN) :: ITOPIC INTEGER,DIMENSION(:),INTENT(IN) :: CLY INTEGER :: I,J,K,ILAY DO I=1,SIZE(STRESS) DO J=1,SIZE(STRESS(I)%FILES,1) DO K=1,SIZE(STRESS(I)%FILES,2) ILAY=STRESS(I)%FILES(J,K)%ILAY SELECT CASE (ITOPIC) CASE (TANI,THFB,TWEL,TCHD) IF(ILAY.GT.0)ILAY=CLY(ILAY) CASE DEFAULT SELECT CASE (ILAY) !## 1 becomes most upper active layer CASE (1) ; ILAY=-1 CASE (2:); ILAY=CLY(ILAY) END SELECT END SELECT STRESS(I)%FILES(J,K)%ILAY=ILAY ENDDO ENDDO ENDDO END SUBROUTINE IMODBATCH_PRJTOMF6_CORRECTLAYERS !###====================================================================== SUBROUTINE IMODBATCH_PRJTOMF6_FILLFILES(FILES,FNAME,ILAY) !###====================================================================== IMPLICIT NONE TYPE(FILESOBJ),INTENT(INOUT) :: FILES INTEGER,INTENT(IN) :: ILAY CHARACTER(LEN=*),INTENT(IN) :: FNAME FILES%FNAME=FNAME FILES%ICNST=2 FILES%CNST =-999.99D0 FILES%ILAY =ILAY FILES%FCT =1.0D0 FILES%IMP =0.0D0 FILES%IACT =1 END SUBROUTINE IMODBATCH_PRJTOMF6_FILLFILES !###====================================================================== SUBROUTINE IMODBATCH_PRJTOMF6_COPYFILES(FILES1,FILES2) !###====================================================================== IMPLICIT NONE TYPE(FILESOBJ),INTENT(INOUT) :: FILES1,FILES2 FILES2%FNAME=FILES1%FNAME FILES2%ICNST=FILES1%ICNST FILES2%CNST =FILES1%CNST FILES2%ILAY =FILES1%ILAY FILES2%FCT =FILES1%FCT FILES2%IMP =FILES1%IMP FILES2%IACT =FILES1%IACT END SUBROUTINE IMODBATCH_PRJTOMF6_COPYFILES !###====================================================================== SUBROUTINE IMODBATCH_KDC() !###====================================================================== IMPLICIT NONE INTEGER :: I,ILAY,IROW,ICOL,NLAY TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: TOP,BOT,KHV,KVV,KVA,BND,KDV,VCV,ERH,ERV,TAF,TAT,HED TYPE(IDFOBJ) :: IDF CHARACTER(LEN=256) :: OUTPUTMAP INTEGER :: IWINDOW,UNCONFINED REAL(KIND=DP_KIND) :: D,T,B,C1,C2,C3 UNCONFINED=0; IF(UTL_READINITFILE('UNCONFINED',LINE,IU,1))THEN READ(LINE,*) UNCONFINED; LINE='UNCONFINED='//TRIM(VTOS(UNCONFINED)); WRITE(*,'(A)') TRIM(LINE) ENDIF IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) NLAY; LINE='NLAY='//TRIM(VTOS(NLAY)); WRITE(*,'(A)') TRIM(LINE) ALLOCATE(TOP(NLAY),BOT(NLAY),KHV(NLAY),KVA(NLAY),KVV(NLAY-1),VCV(NLAY-1),ERV(NLAY-1),BND(NLAY),KDV(NLAY), & ERH(NLAY),HED(NLAY),TAF(NLAY),TAT(NLAY-1)) DO I=1,NLAY CALL IDFNULLIFY(TOP(I)); CALL IDFNULLIFY(BOT(I)); CALL IDFNULLIFY(KHV(I)); CALL IDFNULLIFY(TAF(I)) CALL IDFNULLIFY(KDV(NLAY)); CALL IDFNULLIFY(KVA(I)); CALL IDFNULLIFY(BND(I)); CALL IDFNULLIFY(ERH(NLAY)) ENDDO DO I=1,NLAY-1 CALL IDFNULLIFY(KVV(I)); CALL IDFNULLIFY(VCV(I)); CALL IDFNULLIFY(ERV(I)); CALL IDFNULLIFY(TAT(I)) ENDDO IWINDOW=0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN IWINDOW=1 READ(LINE,*) IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX WRITE(*,'(A,4F15.3)') 'WINDOW=',IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,0))RETURN READ(LINE,*) IDF%DX; WRITE(*,'(A,F10.2)') 'CELLSIZE=',IDF%DX IDF%DY=IDF%DX CALL UTL_IDFSNAPTOGRID_LLC(IDF%XMIN,IDF%XMAX,IDF%YMIN,IDF%YMAX,IDF%DX,IDF%DY,IDF%NCOL,IDF%NROW,LLC=.TRUE.) ENDIF DO I=1,NLAY IF(.NOT.UTL_READINITFILE('BND_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) BND(I)%FNAME; LINE='BND_L'//TRIM(VTOS(I))//'='//TRIM(BND(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(I.LT.NLAY)THEN IF(.NOT.UTL_READINITFILE('KVV_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) KVV(I)%FNAME; LINE='KVV_L'//TRIM(VTOS(I))//'='//TRIM(KVV(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) ENDIF IF(.NOT.UTL_READINITFILE('KHV_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) KHV(I)%FNAME; LINE='KHV_L'//TRIM(VTOS(I))//'='//TRIM(KHV(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('KVA_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) KVA(I)%FNAME; LINE='KVA_L'//TRIM(VTOS(I))//'='//TRIM(KVA(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('TOP_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) TOP(I)%FNAME; LINE='TOP_L'//TRIM(VTOS(I))//'='//TRIM(TOP(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('BOT_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) BOT(I)%FNAME; LINE='BOT_L'//TRIM(VTOS(I))//'='//TRIM(BOT(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(UNCONFINED.EQ.1)THEN IF(.NOT.UTL_READINITFILE('HED_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) HED(I)%FNAME; LINE='HED_L'//TRIM(VTOS(I))//'='//TRIM(HED(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) DO I=1,NLAY WRITE(*,'(A,I10)') 'Reading files for layer ',I IF(I.EQ.1.AND.IWINDOW.EQ.0)THEN IF(.NOT.IDFREAD(BND(I),BND(I)%FNAME,1))RETURN CALL IDFCOPY(BND(1),IDF) ELSE CALL IDFCOPY(IDF,BND(I)); IF(.NOT.IDFREADSCALE(BND(I)%FNAME,BND(I),1,1,0.0D0,0))RETURN ENDIF CALL IDFCOPY(BND(I),TOP(I)); IF(.NOT.IDFREADSCALE(TOP(I)%FNAME,TOP(I),2,1,0.0D0,0))RETURN CALL IDFCOPY(BND(I),BOT(I)); IF(.NOT.IDFREADSCALE(BOT(I)%FNAME,BOT(I),2,1,0.0D0,0))RETURN CALL IDFCOPY(BND(I),KHV(I)); IF(.NOT.IDFREADSCALE(KHV(I)%FNAME,KHV(I),3,1,0.0D0,0))RETURN CALL IDFCOPY(BND(I),KVA(I)); IF(.NOT.IDFREADSCALE(KVA(I)%FNAME,KVA(I),2,1,0.0D0,0))RETURN IF(UNCONFINED.EQ.1)THEN CALL IDFCOPY(BND(I),HED(I)); IF(.NOT.IDFREADSCALE(HED(I)%FNAME,HED(I),2,1,0.0D0,0))RETURN ENDIF CALL IDFCOPY(BND(I),KDV(I)); CALL IDFCOPY(BND(I),ERH(I)); ERH(I)%X=0.0D0; ERH%NODATA=0.0D0 CALL IDFCOPY(BND(I),TAF(I)); CALL IDFCOPY(BND(I),TAF(I)); TAF(I)%X=0.0D0; TAF%NODATA=0.0D0 IF(I.LT.NLAY)THEN CALL IDFCOPY(BND(I),KVV(I)); IF(.NOT.IDFREADSCALE(KVV(I)%FNAME,KVV(I),3,1,0.0D0,0))RETURN CALL IDFCOPY(BND(I),VCV(I)); CALL IDFCOPY(BND(I),ERV(I)); ERV(I)%X=0.0D0; ERV%NODATA=0.0D0 CALL IDFCOPY(BND(I),TAT(I)); CALL IDFCOPY(BND(I),TAT(I)); TAT(I)%X=0.0D0; TAT%NODATA=0.0D0 ENDIF ENDDO !## correct bnd if top/bot nodata turn into inactive DO IROW=1,BND(1)%NROW; DO ICOL=1,BND(1)%NCOL !## make nodata equal zero for boundary conditions DO ILAY=1,NLAY IF(UNCONFINED.EQ.1)THEN IF(HED(ILAY)%X(ICOL,IROW).EQ.HED(ILAY)%NODATA)BND(ILAY)%X(ICOL,IROW)=0.0D0 ENDIF IF(BND(ILAY)%X(ICOL,IROW).EQ.BND(ILAY)%NODATA)BND(ILAY)%X(ICOL,IROW)=0.0D0 IF(ILAY.GT.1)TOP(ILAY)%X(ICOL,IROW)=MIN(TOP(ILAY)%X(ICOL,IROW),BOT(ILAY-1)%X(ICOL,IROW)) BOT(ILAY)%X(ICOL,IROW)=MIN(TOP(ILAY)%X(ICOL,IROW),BOT(ILAY)%X(ICOL,IROW)) T=TOP(ILAY)%X(ICOL,IROW); B=BOT(ILAY)%X(ICOL,IROW); D=T-B IF(D.GT.0.0D0)THEN IF(KHV(ILAY)%X(ICOL,IROW).EQ.KHV(ILAY)%NODATA)THEN ERH(ILAY)%X(ICOL,IROW)=1.0D0 BND(ILAY)%X(ICOL,IROW)=0.0D0 ENDIF IF(KVA(ILAY)%X(ICOL,IROW).EQ.KVA(ILAY)%NODATA)THEN ERH(ILAY)%X(ICOL,IROW)=2.0D0 BND(ILAY)%X(ICOL,IROW)=0.0D0 ENDIF ENDIF IF(ILAY.LT.NLAY)THEN T=BOT(ILAY)%X(ICOL,IROW); B=TOP(ILAY+1)%X(ICOL,IROW); D=T-B IF(D.GT.0.0D0)THEN IF(KVV(ILAY)%X(ICOL,IROW).EQ.KVV(ILAY)%NODATA)THEN ERV(ILAY)%X(ICOL,IROW)=1.0D0 BND(ILAY)%X(ICOL,IROW)=0.0D0 ENDIF ENDIF ENDIF IF(BND(ILAY)%X(ICOL,IROW).EQ.0)THEN TOP(ILAY)%X(ICOL,IROW)=TOP(ILAY)%NODATA BOT(ILAY)%X(ICOL,IROW)=BOT(ILAY)%NODATA KHV(ILAY)%X(ICOL,IROW)=KHV(ILAY)%NODATA KVA(ILAY)%X(ICOL,IROW)=KVA(ILAY)%NODATA KVV(ILAY)%X(ICOL,IROW)=KVV(ILAY)%NODATA TAF(ILAY)%X(ICOL,IROW)=TAF(ILAY)%NODATA TAT(ILAY)%X(ICOL,IROW)=TAT(ILAY)%NODATA KDV(ILAY)%X(ICOL,IROW)=KDV(ILAY)%NODATA VCV(ILAY)%X(ICOL,IROW)=VCV(ILAY)%NODATA IF(UNCONFINED.EQ.1)HED(ILAY)%X(ICOL,IROW)=HED(ILAY)%NODATA ENDIF ENDDO DO ILAY=1,NLAY IF(BND(ILAY)%X(ICOL,IROW).EQ.0)CYCLE !## compute transmissivity IF(UNCONFINED.EQ.1)THEN D=MIN(TOP(ILAY)%X(ICOL,IROW),HED(ILAY)%X(ICOL,IROW))-BOT(ILAY)%X(ICOL,IROW) ELSE D=TOP(ILAY)%X(ICOL,IROW)-BOT(ILAY)%X(ICOL,IROW) ENDIF KDV(ILAY)%X(ICOL,IROW)=KHV(ILAY)%X(ICOL,IROW)*D TAF(ILAY)%X(ICOL,IROW)=D !## compute vertical resistance IF(ILAY.LT.NLAY)THEN C1=0.0D0; IF(D.GT.0.0D0)C1=0.5D0*D/(KHV(ILAY)%X(ICOL,IROW)*KVA(ILAY)%X(ICOL,IROW)) IF(BND(ILAY+1)%X(ICOL,IROW).NE.0)THEN D=BOT(ILAY)%X(ICOL,IROW)-TOP(ILAY+1)%X(ICOL,IROW) TAT(ILAY)%X(ICOL,IROW)=D C2=0.0D0; IF(D.GT.0.0D0)C2=D/KVV(ILAY)%X(ICOL,IROW) IF(UNCONFINED.EQ.1)THEN D=MIN(TOP(ILAY+1)%X(ICOL,IROW),HED(ILAY+1)%X(ICOL,IROW))-BOT(ILAY+1)%X(ICOL,IROW) ELSE D=TOP(ILAY+1)%X(ICOL,IROW)-BOT(ILAY+1)%X(ICOL,IROW) ENDIF C3=0.0D0; IF(D.GT.0.0D0)C3=0.5D0*D/(KHV(ILAY+1)%X(ICOL,IROW)*KVA(ILAY+1)%X(ICOL,IROW)) ENDIF VCV(ILAY)%X(ICOL,IROW)=C1+C2+C3 ENDIF ENDDO ENDDO; ENDDO CALL UTL_CREATEDIR(OUTPUTMAP) DO ILAY=1,NLAY WRITE(*,'(A,I10)') 'Writing KDV/VCV/ERH/ERV resulting files for layer ',ILAY KDV(ILAY)%FNAME=TRIM(OUTPUTMAP)//'\KDV_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(KDV(ILAY),KDV(ILAY)%FNAME,1))RETURN ERH(ILAY)%FNAME=TRIM(OUTPUTMAP)//'\ERH_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(ERH(ILAY),ERH(ILAY)%FNAME,1))RETURN TAF(ILAY)%FNAME=TRIM(OUTPUTMAP)//'\TAF_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(TAF(ILAY),TAF(ILAY)%FNAME,1))RETURN IF(ILAY.LT.NLAY)THEN VCV(ILAY)%FNAME=TRIM(OUTPUTMAP)//'\VCV_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(VCV(ILAY),VCV(ILAY)%FNAME,1))RETURN ERV(ILAY)%FNAME=TRIM(OUTPUTMAP)//'\ERV_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(ERV(ILAY),ERV(ILAY)%FNAME,1))RETURN TAT(ILAY)%FNAME=TRIM(OUTPUTMAP)//'\TAT_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(TAT(ILAY),TAT(ILAY)%FNAME,1))RETURN ENDIF ENDDO END SUBROUTINE IMODBATCH_KDC !###====================================================================== SUBROUTINE IMODBATCH_KDC_INT(IDF,BND,KV,TOP,BOT) !###====================================================================== IMPLICIT NONE TYPE(IDFOBJ),INTENT(INOUT) :: IDF,BND,KV,TOP,BOT REAL(KIND=DP_KIND),POINTER,DIMENSION(:) :: XD,YD,ZD INTEGER :: IROW,IR1,ICOL,IC1,ND,IOS REAL(KIND=DP_KIND) :: D IDF%X=0.0D0 DO IROW=1,BND%NROW; DO ICOL=1,BND%NCOL IF(BND%X(ICOL,IROW).EQ.0)CYCLE D=TOP%X(ICOL,IROW)-BOT%X(ICOL,IROW) IF(D.GT.0.AND.(KV%X(ICOL,IROW).LE.0.0D0.OR.KV%X(ICOL,IROW).EQ.KV%NODATA))THEN IDF%X(ICOL,IROW)=1.0D0 ENDIF ENDDO; ENDDO !## get fixed points - direct next to the selected zone(s) (only if not equal to nodata value) DO IROW=1,BND%NROW; DO ICOL=1,BND%NCOL IF(IDF%X(ICOL,IROW).EQ.1.0D0)THEN DO IR1=MAX(1,IROW-1),MIN(IROW+1,BND%NROW); DO IC1=MAX(1,ICOL-1),MIN(ICOL+1,BND%NCOL) IF(IDF%X(IC1,IR1).EQ.0.0D0)IDF%X(IC1,IR1)=2.0 ENDDO; ENDDO ENDIF ENDDO; ENDDO ND=0; DO IROW=1,BND%NROW; DO ICOL=1,BND%NCOL; IF(IDF%X(ICOL,IROW).EQ.2.0)ND=ND+1; ENDDO; ENDDO !## number data points ALLOCATE(XD(ND),YD(ND),ZD(ND)) ND=0; DO IROW=1,BND%NROW; DO ICOL=1,BND%NCOL IF(IDF%X(ICOL,IROW).EQ.2.0)THEN ND=ND+1; XD(ND)=REAL(ICOL); YD(ND)=REAL(IROW) ZD(ND)=KV%X(ICOL,IROW) ENDIF ENDDO; ENDDO !## start filling in missing values for permeability CALL SOLID_PCGINT(XD,YD,ZD,ND,IOS,IDF,1) ND=0; DO IROW=1,BND%NROW; DO ICOL=1,BND%NCOL IF(IDF%X(ICOL,IROW).EQ.2.0)THEN ND=ND+1; XD(ND)=REAL(ICOL); YD(ND)=REAL(IROW) KV%X(ICOL,IROW)=ZD(ND) ENDIF ENDDO; ENDDO END SUBROUTINE IMODBATCH_KDC_INT !###====================================================================== SUBROUTINE IMODBATCH_DEVWELLTOIPF() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: CSVFNAME,IPFFNAME INTEGER,DIMENSION(:),POINTER :: ICOLS INTEGER :: NLC,I IF(.NOT.UTL_READINITFILE('CSVFNAME',LINE,IU,0))RETURN READ(LINE,*) CSVFNAME; WRITE(*,'(A)') 'CSVFNAME='//TRIM(CSVFNAME) IF(.NOT.UTL_READINITFILE('IPFFNAME',LINE,IU,0))RETURN READ(LINE,*) IPFFNAME; WRITE(*,'(A)') 'IPFFNAME='//TRIM(IPFFNAME) NLC=0; IF(UTL_READINITFILE('NLCOL',LINE,IU,1))READ(LINE,*) NLC; WRITE(*,'(A,I2)') 'NLC=',NLC ALLOCATE(ICOLS(7+NLC)) ICOLS=0; DO I=1,7; ICOLS(I)=I; ENDDO; ICOLS(4)=0 IF(UTL_READINITFILE('NCOL',LINE,IU,1))READ(LINE,*) ICOLS(1); WRITE(*,'(A,I2)') 'NCOL=',ICOLS(1) IF(UTL_READINITFILE('XCOL',LINE,IU,1))READ(LINE,*) ICOLS(2); WRITE(*,'(A,I2)') 'XCOL=',ICOLS(2) IF(UTL_READINITFILE('YCOL',LINE,IU,1))READ(LINE,*) ICOLS(3); WRITE(*,'(A,I2)') 'YCOL=',ICOLS(3) IF(UTL_READINITFILE('ZCOL',LINE,IU,1))READ(LINE,*) ICOLS(4); WRITE(*,'(A,I2)') 'ZCOL=',ICOLS(4) IF(UTL_READINITFILE('DCOL',LINE,IU,1))READ(LINE,*) ICOLS(5); WRITE(*,'(A,I2)') 'DCOL=',ICOLS(5) IF(UTL_READINITFILE('ICOL',LINE,IU,1))READ(LINE,*) ICOLS(6); WRITE(*,'(A,I2)') 'ICOL=',ICOLS(6) IF(UTL_READINITFILE('ACOL',LINE,IU,1))READ(LINE,*) ICOLS(7); WRITE(*,'(A,I2)') 'ACOL=',ICOLS(7) DO I=1,NLC IF(UTL_READINITFILE('LCOL'//TRIM(VTOS(I)),LINE,IU,1))READ(LINE,*) ICOLS(7+I); LINE='LCOL'//TRIM(VTOS(I))//'='//TRIM(VTOS(ICOLS(I+7))) WRITE(*,'(A)') TRIM(LINE) ENDDO ! MPW%XMIN=0.0D0; MPW%YMIN=0.0D0; MPW%XMAX=0.0D0; MPW%YMAX=0.0D0 ! IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN ! READ(LINE,*) MPW%XMIN,MPW%YMIN,MPW%XMAX,MPW%YMAX ! WRITE(*,'(A,4F15.3)') '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 DEVWELL_IMPORT(CSVFNAME,IPFFNAME,ICOLS,1) END SUBROUTINE IMODBATCH_DEVWELLTOIPF !###====================================================================== SUBROUTINE IMODBATCH_GEF2IPF_MAIN() !###====================================================================== USE MOD_GEF2IPF_PAR, ONLY : GEFDIR,IPFFNAME,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.0D0; MPW%YMIN=0.0D0; MPW%XMAX=0.0D0; MPW%YMAX=0.0D0 ! IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN ! READ(LINE,*) MPW%XMIN,MPW%YMIN,MPW%XMAX,MPW%YMAX ! WRITE(*,'(A,4F15.3)') '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.0D0; MPW%YMIN=0.0D0; MPW%XMAX=0.0D0; MPW%YMAX=0.0D0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) MPW%XMIN,MPW%YMIN,MPW%XMAX,MPW%YMAX WRITE(*,'(A,4F15.3)') '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_REGRESSIONTXT() !###====================================================================== USE LSQ IMPLICIT NONE CHARACTER(LEN=52) :: FILTER1,FILTER2,FILTER3 CHARACTER(LEN=256) :: IPFFILE,FNAME,DIR INTEGER :: I,N,M,IALL,JU,KU,II,JJ,JJJ,NN,IDATE,NPOINTS REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: X,Y REAL(KIND=DP_KIND) :: A,B,R2,EZ,CORRELATION FILTER1=''; FILTER2='' IF(.NOT.UTL_READINITFILE('IPFFILE',LINE,IU,0))RETURN READ(LINE,*) IPFFILE; WRITE(*,'(A)') 'IPFFILE='//TRIM(IPFFILE) DIR=IPFFILE(:INDEX(IPFFILE,'\',.TRUE.)-1) IF(.NOT.UTL_READINITFILE('FILTER1',LINE,IU,0))RETURN READ(LINE,*) FILTER1; WRITE(*,'(A)') 'FILTER1='//TRIM(FILTER1) IALL=0; IF(UTL_READINITFILE('IALL',LINE,IU,1))READ(LINE,*) IALL IF(IALL.EQ.0)THEN IF(.NOT.UTL_READINITFILE('FILTER2',LINE,IU,0))RETURN READ(LINE,*) FILTER2; WRITE(*,'(A)') 'FILTER2='//TRIM(FILTER2) ENDIF CORRELATION=0.0D0 IF(.NOT.UTL_READINITFILE('CORRELATION',LINE,IU,0))RETURN READ(LINE,*) CORRELATION; WRITE(*,'(A)') 'CORRELATION='//TRIM(VTOS(CORRELATION,'F',3)) NPOINTS=0.0 IF(.NOT.UTL_READINITFILE('NPOINTS',LINE,IU,0))RETURN READ(LINE,*) NPOINTS; WRITE(*,'(A)') 'NPOINTS='//TRIM(VTOS(NPOINTS)) NIPF=1; CALL IPFALLOCATE(); IPF(1)%FNAME=IPFFILE IPF(1)%XCOL =1; IPF(1)%YCOL=2; IPF(1)%ZCOL=2 IPF(1)%Z2COL=2; IPF(1)%QCOL=2; IF(.NOT.IPFREAD2(1,1,0))RETURN !## open new file FNAME=IPFFILE(:INDEX(IPFFILE,'.',.TRUE.)-1)//'_REGRESSION.IPF_' KU=UTL_GETUNIT(); OPEN(KU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE') WRITE(KU,*) 'NaN1#' WRITE(KU,*) IPF(1)%NCOL+2 DO I=1,IPF(1)%NCOL; WRITE(KU,'(A)') TRIM(IPF(1)%ATTRIB(I)); ENDDO; WRITE(KU,'(A)') 'Regression_coefficient'; WRITE(KU,'(A)') 'Sample_Size' WRITE(KU,*) IPF(1)%ACOL,','//TRIM(IPF(1)%FEXT) !## store each drill in memory for picking purposes CALL IPFASSFILEALLOCATE(2) FILTER1=UTL_CAP(FILTER1,'U') !## get filter1 N=1 DO I=1,IPF(1)%NROW FILTER3=UTL_CAP(IPF(1)%INFO(IPF(1)%ACOL,I),'U') IF(TRIM(FILTER1).NE.TRIM(FILTER3))CYCLE !## read dimensions of associated file FNAME=TRIM(DIR)//'\'//TRIM(IPF(1)%INFO(IPF(1)%ACOL,I))//'.'//TRIM(ADJUSTL(IPF(1)%FEXT)) IF(IPFOPENASSFILE(JU,N,FNAME))THEN !## measurements found IF(ASSF(N)%ITOPIC.EQ.1)THEN IF(.NOT.IPFREADASSFILELABEL(JU,N,FNAME).AND.IPFREADASSFILE(JU,N,FNAME))THEN WRITE(*,'(A)') 'Cannot properly read in file '//TRIM(FNAME); PAUSE; STOP ENDIF ENDIF CLOSE(JU) ENDIF ENDDO !## proces rest of filters N=2; M=0 DO I=1,IPF(1)%NROW IF(IALL.EQ.1)FILTER2=UTL_CAP(IPF(1)%INFO(IPF(1)%ACOL,I),'U') FILTER3=UTL_CAP(IPF(1)%INFO(IPF(1)%ACOL,I),'U') IF(TRIM(FILTER2).NE.TRIM(FILTER3))CYCLE !## read dimensions of associated file FNAME=TRIM(DIR)//'\'//TRIM(IPF(1)%INFO(IPF(1)%ACOL,I))//'.'//TRIM(ADJUSTL(IPF(1)%FEXT)) IF(IPFOPENASSFILE(JU,N,FNAME))THEN !## measurements found IF(ASSF(N)%ITOPIC.EQ.1)THEN IF(IPFREADASSFILELABEL(JU,N,FNAME).AND.IPFREADASSFILE(JU,N,FNAME))THEN CLOSE(JU) !## fill in x use 2 loops DO II=1,2 NN=0 !## look for overlapping dates DO JJ=1,ASSF(1)%NRASS DO JJJ=1,ASSF(2)%NRASS IF(ASSF(1)%IDATE(JJ).EQ.ASSF(2)%IDATE(JJJ))THEN IF(ASSF(1)%MEASURE(1,JJ) .NE.ASSF(1)%NODATA(2).AND. & ASSF(2)%MEASURE(1,JJJ).NE.ASSF(2)%NODATA(2))THEN NN=NN+1 IF(II.EQ.2)THEN X(NN)=ASSF(1)%MEASURE(1,JJ) Y(NN)=ASSF(2)%MEASURE(1,JJJ) ENDIF ENDIF ENDIF ENDDO ENDDO IF(II.EQ.1)THEN IF(NN.GT.0)THEN ALLOCATE(X(NN),Y(NN)); X=0.0D0; Y=0.0D0 ELSE EXIT ENDIF ELSE CALL LINREGRESSION(NN,X,Y,A,B,R2) IF(R2.GT.CORRELATION.AND.NN.GT.NPOINTS)THEN M=M+1 IPF(1)%INFO(IPF(1)%ACOL,I)=TRIM(IPF(1)%INFO(IPF(1)%ACOL,I))//'_regression' WRITE(KU,'(99A)') (TRIM(IPF(1)%INFO(JJ,I))//',',JJ=1,IPF(1)%NCOL),TRIM(VTOS(R2,'G',5)),','//TRIM(VTOS(NN)) !## fill in remaining data points for first series FNAME=TRIM(DIR)//'\'//TRIM(IPF(1)%INFO(IPF(1)%ACOL,I))//'.'//TRIM(ADJUSTL(IPF(1)%FEXT)) JU=UTL_GETUNIT(); OPEN(JU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE') WRITE(JU,'(I9)') ASSF(1)%NRASS WRITE(JU,'(A)') '3,1' WRITE(JU,'(A)') 'DATE,-9999.0' WRITE(JU,'(A)') 'ESTIMATED,-9999.0' WRITE(JU,'(A)') 'MEASURE,-9999.0' !## fill in if needed DO JJ=1,ASSF(1)%NRASS IDATE=UTL_JDATETOIDATE(INT(ASSF(1)%IDATE(JJ))) DO JJJ=1,ASSF(2)%NRASS IF(ASSF(1)%IDATE(JJ).EQ.ASSF(2)%IDATE(JJJ))THEN WRITE(JU,'(I10,2(A1,F10.2))') IDATE,',',ASSF(2)%MEASURE(1,JJJ),',',ASSF(2)%MEASURE(1,JJJ) EXIT ENDIF ENDDO IF(JJJ.GT.ASSF(2)%NRASS)THEN IF(ASSF(1)%MEASURE(1,JJ).NE.ASSF(1)%NODATA(2))THEN IF(A.EQ.0.0)THEN EZ=-9999.0 ELSE !## predict second serie EZ=ASSF(1)%MEASURE(1,JJ)*A+B ENDIF ELSE EZ=-9999.0 ENDIF WRITE(JU,'(I10,2(A1,F10.2))') IDATE,',',EZ,',',-9999.0 ENDIF ENDDO CLOSE(JU) ENDIF ENDIF ENDDO IF(ALLOCATED(X))DEALLOCATE(X); IF(ALLOCATED(Y))DEALLOCATE(Y) ENDIF ELSE WRITE(*,'(A)') 'NTOPIC NE 1'; PAUSE ENDIF ELSE WRITE(*,'(A)') 'Cannot open '//TRIM(FNAME); PAUSE ENDIF ENDDO CLOSE(KU) FNAME=IPFFILE(:INDEX(IPFFILE,'.',.TRUE.)-1)//'_REGRESSION.IPF_' CALL UTL_MF2005_MAXNO(FNAME,(/M/)) END SUBROUTINE IMODBATCH_REGRESSIONTXT !###====================================================================== SUBROUTINE IMODBATCH_RELATE_OBS_AND_C() !###====================================================================== USE LSQ IMPLICIT NONE TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: C CHARACTER(LEN=256) :: IPFFILE,FNAME INTEGER :: I,J,KU,IROW,ICOL,JROW,JCOL,IL1,IL2,ILAY,N,NLAY,IWINDOW REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: VC,X,Y REAL(KIND=DP_KIND) :: TC,DH,A,B,R2 IF(.NOT.UTL_READINITFILE('IPFFILE',LINE,IU,0))RETURN READ(LINE,*) IPFFILE; WRITE(*,'(A)') 'IPFFILE='//TRIM(IPFFILE) IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) NLAY; WRITE(*,'(A)') 'NLAY='//TRIM(VTOS(NLAY)) ALLOCATE(C(NLAY)); DO I=1,NLAY; CALL IDFNULLIFY(C(I)); ENDDO C(1)%XMIN=0.0D0; C(1)%YMIN=0.0D0; C(1)%XMAX=0.0D0; C(1)%YMAX=0.0D0; IWINDOW=0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN IWINDOW=1 READ(LINE,*) C(1)%XMIN,C(1)%YMIN,C(1)%XMAX,C(1)%YMAX WRITE(*,'(A,4F15.3)') 'WINDOW=',C(1)%XMIN,C(1)%YMIN,C(1)%XMAX,C(1)%YMAX IF(.NOT.UTL_READINITFILE('CELL_SIZE',LINE,IU,0))RETURN READ(LINE,*) C(1)%DX; WRITE(*,'(A,F10.2)') 'CELL_SIZE=',C(1)%DX; C(1)%DY=C(1)%DX CALL UTL_IDFSNAPTOGRID_LLC(C(1)%XMIN,C(1)%XMAX,C(1)%YMIN,C(1)%YMAX,C(1)%DX,C(1)%DY,C(1)%NCOL,C(1)%NROW,LLC=.TRUE.) ENDIF NIPF=1; CALL IPFALLOCATE(); IPF(1)%FNAME=IPFFILE IPF(1)%XCOL =1; IPF(1)%YCOL=2; IPF(1)%ZCOL=3 IPF(1)%Z2COL=4; IPF(1)%QCOL=2 IF(UTL_READINITFILE('IXCOL',LINE,IU,1))READ(LINE,*) IPF(1)%XCOL; WRITE(*,'(A)') 'IXCOL='//TRIM(VTOS(IPF(1)%XCOL)) IF(UTL_READINITFILE('IYCOL',LINE,IU,1))READ(LINE,*) IPF(1)%YCOL; WRITE(*,'(A)') 'IYCOL='//TRIM(VTOS(IPF(1)%YCOL)) IF(UTL_READINITFILE('ILCOL',LINE,IU,1))READ(LINE,*) IPF(1)%ZCOL; WRITE(*,'(A)') 'ILCOL='//TRIM(VTOS(IPF(1)%ZCOL)) IF(UTL_READINITFILE('IZCOL',LINE,IU,1))READ(LINE,*) IPF(1)%Z2COL; WRITE(*,'(A)') 'IZCOL='//TRIM(VTOS(IPF(1)%Z2COL)) IF(.NOT.IPFREAD2(1,1,0))RETURN !## open new file FNAME=IPFFILE(:INDEX(IPFFILE,'.',.TRUE.)-1)//'_REGRESSION.IPF' KU=UTL_GETUNIT(); OPEN(KU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE') WRITE(KU,*) IPF(1)%NROW WRITE(KU,*) IPF(1)%NCOL+2 DO I=1,IPF(1)%NCOL; WRITE(KU,'(A)') TRIM(IPF(1)%ATTRIB(I)); ENDDO; WRITE(KU,'(A)') 'Regression_coefficient'; WRITE(KU,'(A)') 'Sample_Size' WRITE(KU,*) IPF(1)%ACOL,','//TRIM(IPF(1)%FEXT) DO I=1,NLAY IF(.NOT.UTL_READINITFILE('C_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) C(I)%FNAME; WRITE(*,'(A)') 'C_L'//TRIM(VTOS(I))//'='//TRIM(C(I)%FNAME) IF(IWINDOW.EQ.0)THEN IF(.NOT.IDFREAD(C(I),C(I)%FNAME,1))STOP ELSE IF(I.NE.1)CALL IDFCOPY(C(1),C(I)) !## upscale inverse for c values IF(.NOT.IDFREADSCALE(C(I)%FNAME,C(I),6,1,0.0D0,0))STOP ENDIF ENDDO ALLOCATE(VC(NLAY)) N=10E6; ALLOCATE(X(N),Y(N)) !## collect inside same model cell N=0; DO I=1,IPF(1)%NROW VC=0.0D0 DO J=1,NLAY CALL IDFIROWICOL(C(J),IROW,ICOL,IPF(1)%XYZ(1,I),IPF(1)%XYZ(2,I)) VC(J)=C(J)%X(ICOL,IROW) ENDDO CALL IDFIROWICOL(C(1),IROW,ICOL,IPF(1)%XYZ(1,I),IPF(1)%XYZ(2,I)) !## skip current point itself DO J=I+1,IPF(1)%NROW CALL IDFIROWICOL(C(1),JROW,JCOL,IPF(1)%XYZ(1,J),IPF(1)%XYZ(2,J)) IF(IROW.EQ.JROW.AND.ICOL.EQ.JCOL)THEN !## difference in head DH=ABS(IPF(1)%XYZ(4,I)-IPF(1)%XYZ(4,J)) !## difference in resistance IL1=MIN(IPF(1)%XYZ(3,I),IPF(1)%XYZ(3,J)) IL2=MAX(IPF(1)%XYZ(3,I),IPF(1)%XYZ(3,J))-1 IF(IL2.GE.IL1)THEN TC=0.0D0; DO ILAY=IL1,IL2 TC=TC+VC(ILAY) ENDDO N=N+1 X(N)=DH Y(N)=TC ! WRITE(KU,'(2F15.3,2I10,4F15.3)') IPF(1)%XYZ(1,I),IPF(1)%XYZ(2,I),IL1,IL2+1,IPF(1)%XYZ(4,I),IPF(1)%XYZ(4,J),DH,TC ENDIF ENDIF ENDDO ENDDO CALL LINREGRESSION(N,X,Y,A,B,R2) DO I=1,N WRITE(KU,'(99A)') TRIM(VTOS(X(I),'F',3)),',',TRIM(VTOS(Y(I),'F',3)) ENDDO ! DO I=1,IPF(1)%NROW ! WRITE(KU,'(99A)') (TRIM(IPF(1)%INFO(J,I))//',',J=1,IPF(1)%NCOL),TRIM(VTOS(X(I),'F',3)),TRIM(VTOS(Y(I),'F',3)) ! ENDDO ! 'Regression Coefficient'//CHAR(32)//TRIM(VTOS(R2,'G',7))//CHAR(13)//CHAR(10)// & ! 'y='//TRIM(VTOS(A,'G',7))//'x '//TRIM(VTOS(B,'G',7)) DEALLOCATE(X,Y) ! ENDDO ! IF(ALLOCATED(X))DEALLOCATE(X); IF(ALLOCATED(Y))DEALLOCATE(Y) CLOSE(KU) END SUBROUTINE IMODBATCH_RELATE_OBS_AND_C !###====================================================================== SUBROUTINE IMODBATCH_CURVEFITTING() !###====================================================================== USE LSQ IMPLICIT NONE CHARACTER(LEN=256) :: IPFFILE,DIR,FNAME CHARACTER(LEN=14) :: TXT INTEGER :: NDEGREES,JU,KU,I,II,J,JJ,K,KK,TYPE_FIT,IUOUT REAL(KIND=DP_KIND) :: MINRDATE,POWER,FTIME,X,Y,OMEGA,PROGNOSE,DX REAL(KIND=DP_KIND),DIMENSION(:),ALLOCATABLE :: COEF IF(.NOT.UTL_READINITFILE('IPFFILE',LINE,IU,0))RETURN READ(LINE,*) IPFFILE; WRITE(*,'(A)') 'IPFFILE='//TRIM(IPFFILE) DIR=IPFFILE(:INDEX(IPFFILE,'\',.TRUE.)-1) TYPE_FIT=1; IF(UTL_READINITFILE('TYPE_FIT',LINE,IU,1))THEN READ(LINE,*) TYPE_FIT; WRITE(*,'(A)') 'TYPE_FIT='//TRIM(VTOS(TYPE_FIT)) ENDIF IF(.NOT.UTL_READINITFILE('NDEGREES',LINE,IU,0))RETURN READ(LINE,*) NDEGREES; WRITE(*,'(A)') 'NDEGREES='//TRIM(VTOS(NDEGREES)) SELECT CASE (TYPE_FIT) CASE (1,2) IF(UTL_READINITFILE('PROGNOSE',LINE,IU,1))THEN READ(LINE,*) PROGNOSE; WRITE(*,'(A)') 'PROGNOSE='//TRIM(VTOS(PROGNOSE,'F',2)) ENDIF CASE (3) PROGNOSE=1.0D0 END SELECT SELECT CASE (TYPE_FIT) CASE (1) WRITE(*,'(1X,A)') 'TYPE_FIT '//TRIM(VTOS(NDEGREES))//' POLYNOOM' CASE (2) WRITE(*,'(1X,A)') 'TYPE_FIT '//TRIM(VTOS(NDEGREES))//' CONT. FOURIER' CASE (3) WRITE(*,'(1X,A)') 'TYPE_FIT LEVENBERG-MARQUARDT' IUOUT=UTL_GETUNIT(); OPEN(IUOUT,FILE=TRIM(DIR)//'\LM_OUT.TXT',STATUS='REPLACE',ACTION='WRITE') END SELECT NIPF=1; CALL IPFALLOCATE(); IPF(1)%FNAME=IPFFILE; IPF(1)%XCOL=1; IPF(1)%YCOL=2; IPF(1)%ZCOL=2; IPF(1)%Z2COL=2; IPF(1)%QCOL=2 IF(.NOT.IPFREAD2(1,1,0))RETURN !## open new file FNAME=IPFFILE(:INDEX(IPFFILE,'.',.TRUE.)-1)//'_CURVEFITTING.IPF' KU=UTL_GETUNIT(); OPEN(KU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE') WRITE(KU,*) IPF(1)%NROW WRITE(KU,*) IPF(1)%NCOL+NDEGREES+1 DO I=1,IPF(1)%NCOL; WRITE(KU,'(A)') TRIM(IPF(1)%ATTRIB(I)); ENDDO DO I=1,NDEGREES; WRITE(KU,'(A)') 'Fit_Coefficients_'//CHAR(96+I); ENDDO; WRITE(KU,'(A)') 'Average_Error_m' WRITE(KU,*) IPF(1)%ACOL,','//TRIM(IPF(1)%FEXT) !## store each drill in memory for picking purposes CALL IPFASSFILEALLOCATE(1) SELECT CASE (TYPE_FIT) CASE (1,3); ALLOCATE(COEF(NDEGREES)) CASE (2); ALLOCATE(COEF(1+NDEGREES*2)) END SELECT !## process data DO I=1,IPF(1)%NROW !## read dimensions of associated file FNAME=TRIM(DIR)//'\'//TRIM(IPF(1)%INFO(IPF(1)%ACOL,I))//'.'//TRIM(ADJUSTL(IPF(1)%FEXT)) IF(IPFOPENASSFILE(JU,1,FNAME))THEN !## measurements found IF(ASSF(1)%ITOPIC.EQ.1)THEN IF(.NOT.IPFREADASSFILELABEL(JU,1,FNAME).AND.IPFREADASSFILE(JU,1,FNAME))THEN WRITE(*,'(/A/)') '>>> Cannot properly read in file '//TRIM(FNAME)//' <<<'; PAUSE; STOP ENDIF !## correct date MINRDATE=ASSF(1)%IDATE(1) DO J=1,ASSF(1)%NRASS; ASSF(1)%IDATE(J)=ASSF(1)%IDATE(J)-MINRDATE; ENDDO SELECT CASE (TYPE_FIT) CASE(1,2) !## omega is year as prior estimate OMEGA=2.0D0*PI/365.0D0 OMEGA=1.0D0 ! !## make function ! DO J=1,ASSF(1)%NRASS ! X=ASSF(1)%IDATE(J) ! ASSF(1)%MEASURE(1,J)=SIN(X*OMEGA) ! ENDDO CALL UTL_FIT_POLYNOMIAL(NDEGREES,COEF,ASSF(1)%IDATE,ASSF(1)%MEASURE(1,:),TYPE_FIT,OMEGA) ! !## unit test ! https://services.math.duke.edu/education/ccp/materials/linalg/curvefit/curvfit2.html ! omega=1.0d0 ! CALL UTL_FIT_POLYNOMIAL(2,COEF,(/-2.0D0 ,-1.50D0,-1.0D0, 0.50D0,0.00D0, 0.5D0 , 1.00D0,1.50D0,2.00D0,2.50D0,3.00D0/), & ! (/-6.32D0,-3.23D0, 1.62D0,3.13D0,1.74D0,-0.75D0,-1.41D0,1.78D0,8.88D0,9.98D0,7.10D0/),TYPE_FIT,OMEGA) !## levenberg-marquardt CASE (3) !## set nodata DO J=1,ASSF(1)%NRASS IF(ASSF(1)%MEASURE(1,J).EQ.ASSF(1)%NODATA(2))ASSF(1)%MEASURE(1,J)=-99999.0D0 IF(ASSF(1)%MEASURE(2,J).EQ.ASSF(1)%NODATA(3))ASSF(1)%MEASURE(2,J)=-99999.0D0 ENDDO CALL UTL_GLM(IPF(1)%INFO(IPF(1)%ACOL,I),COEF,ASSF(1)%MEASURE(1,:),ASSF(1)%MEASURE(2,:),OMEGA,IUOUT,-99999.0D0) END SELECT !## create and save values with the coefficients FNAME=TRIM(DIR)//'\'//TRIM(IPF(1)%INFO(IPF(1)%ACOL,I))//'_CURVEFIT.'//TRIM(ADJUSTL(IPF(1)%FEXT)) JU=UTL_GETUNIT(); OPEN(JU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE') IF(PROGNOSE.GT.1.0D0)THEN DX=ASSF(1)%IDATE(ASSF(1)%NRASS)-ASSF(1)%IDATE(ASSF(1)%NRASS-1) ASSF(1)%NRASS=ASSF(1)%NRASS*PROGNOSE ENDIF WRITE(JU,'(A)') TRIM(VTOS(ASSF(1)%NRASS)) WRITE(JU,'(A)') '3,1' WRITE(JU,'(A)') 'IDATE,-9999' WRITE(JU,'(A)') 'MEASURE,-9999' WRITE(JU,'(A)') 'COMPUTED,-9999' K=0; DO J=1,ASSF(1)%NRASS IF(J.GT.SIZE(ASSF(1)%IDATE))THEN X=X+DX ELSE X=ASSF(1)%IDATE(J); K=K+1 ENDIF SELECT CASE (TYPE_FIT) CASE (1) Y=0.0D0; POWER=-1.0D0 DO II=1,NDEGREES POWER=POWER+1.0D0 Y=Y+COEF(II)*X**POWER ENDDO CASE (2) KK=1; Y=COEF(KK) DO II=1,NDEGREES DO JJ=1,2 KK=KK+1 IF(JJ.EQ.1)Y=Y+COEF(KK)*COS(REAL(II,8)*OMEGA*X) IF(JJ.EQ.2)Y=Y+COEF(KK)*SIN(REAL(II,8)*OMEGA*X) ENDDO ENDDO CASE (3) Y=ASSF(1)%MEASURE(2,J) END SELECT IF(J.GT.SIZE(ASSF(1)%IDATE))THEN ASSF(1)%IDATE(K)=MINRDATE+X ELSE ASSF(1)%IDATE(K)=MINRDATE+ASSF(1)%IDATE(K) ENDIF WRITE(TXT,'(I8)') UTL_JDATETOIDATE(INT(ASSF(1)%IDATE(K))) FTIME=ASSF(1)%IDATE(K)-FLOOR(ASSF(1)%IDATE(K)) IF(FTIME.NE.0.0D0)THEN CALL FTIMETOCTIME(FTIME,CTIME); TXT=TRIM(TXT)//' '//TRIM(CTIME) ENDIF IF(J.GT.SIZE(ASSF(1)%IDATE))THEN WRITE(JU,'(A)') TRIM(TXT)//',-9999,'//TRIM(VTOS(Y,'F',7)) ELSE WRITE(JU,'(A)') TRIM(TXT)//','//TRIM(VTOS(ASSF(1)%MEASURE(1,J),'F',7))//','//TRIM(VTOS(Y,'F',7)) ENDIF ENDDO IPF(1)%INFO(IPF(1)%ACOL,I)=TRIM(IPF(1)%INFO(IPF(1)%ACOL,I))//'_curvefit' WRITE(KU,'(99A)') (TRIM(IPF(1)%INFO(J,I))//',',J=1,IPF(1)%NCOL),(TRIM(VTOS(COEF(J),'E',7))//',',J=1,NDEGREES),TRIM(VTOS(OMEGA,'F',3)) ENDIF CLOSE(JU) ENDIF ENDDO CLOSE(KU) DEALLOCATE(COEF) ! ! !## look for overlapping dates ! DO JJ=1,ASSF(1)%NRASS ! DO JJJ=1,ASSF(2)%NRASS ! IF(ASSF(1)%IDATE(JJ).EQ.ASSF(2)%IDATE(JJJ))THEN ! IF(ASSF(1)%MEASURE(1,JJ) .NE.ASSF(1)%NODATA(2).AND. & ! ASSF(2)%MEASURE(1,JJJ).NE.ASSF(2)%NODATA(2))THEN ! NN=NN+1 ! IF(II.EQ.2)THEN ! X(NN)=ASSF(1)%MEASURE(1,JJ) ! Y(NN)=ASSF(2)%MEASURE(1,JJJ) ! ENDIF ! ENDIF ! ENDIF ! ENDDO ! ENDDO ! IF(II.EQ.1)THEN ! ! CALL LINREGRESSION(NN,X,Y,A,B,R2) ! ! IF(R2.GT.CORRELATION.AND.NN.GT.NPOINTS)THEN ! ! M=M+1 ! IPF(1)%INFO(IPF(1)%ACOL,I)=TRIM(IPF(1)%INFO(IPF(1)%ACOL,I))//'_regression' ! WRITE(KU,'(99A)') (TRIM(IPF(1)%INFO(JJ,I))//',',JJ=1,IPF(1)%NCOL),TRIM(VTOS(R2,'G',5)),','//TRIM(VTOS(NN)) ! ! !## fill in remaining data points for first series ! FNAME=TRIM(DIR)//'\'//TRIM(IPF(1)%INFO(IPF(1)%ACOL,I))//'.'//TRIM(ADJUSTL(IPF(1)%FEXT)) ! JU=UTL_GETUNIT(); OPEN(JU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE') ! WRITE(JU,'(I9)') ASSF(1)%NRASS ! WRITE(JU,'(A)') '3,1' ! WRITE(JU,'(A)') 'DATE,-9999.0' ! WRITE(JU,'(A)') 'ESTIMATED,-9999.0' ! WRITE(JU,'(A)') 'MEASURE,-9999.0' ! ! !## fill in if needed ! DO JJ=1,ASSF(1)%NRASS ! IDATE=UTL_JDATETOIDATE(INT(ASSF(1)%IDATE(JJ))) ! DO JJJ=1,ASSF(2)%NRASS ! IF(ASSF(1)%IDATE(JJ).EQ.ASSF(2)%IDATE(JJJ))THEN ! WRITE(JU,'(I10,2(A1,F10.2))') IDATE,',',ASSF(2)%MEASURE(1,JJJ),',',ASSF(2)%MEASURE(1,JJJ) ! EXIT ! ENDIF ! ENDDO ! IF(JJJ.GT.ASSF(2)%NRASS)THEN ! IF(ASSF(1)%MEASURE(1,JJ).NE.ASSF(1)%NODATA(2))THEN ! IF(A.EQ.0.0)THEN ! EZ=-9999.0 ! ELSE ! !## predict second serie ! EZ=ASSF(1)%MEASURE(1,JJ)*A+B ! ENDIF ! ELSE ! EZ=-9999.0 ! ENDIF ! WRITE(JU,'(I10,2(A1,F10.2))') IDATE,',',EZ,',',-9999.0 ! ENDIF ! ENDDO ! ! CLOSE(JU) ! ENDIF ! ENDIF ! ENDDO ! IF(ALLOCATED(X))DEALLOCATE(X); IF(ALLOCATED(Y))DEALLOCATE(Y) ! ! ENDIF ! ELSE ! WRITE(*,'(A)') 'NTOPIC NE 1'; PAUSE ! ENDIF ! ELSE ! WRITE(*,'(A)') 'Cannot open '//TRIM(FNAME); PAUSE ! ENDIF !ENDDO !CLOSE(KU) ! FNAME=IPFFILE(:INDEX(IPFFILE,'.',.TRUE.)-1)//'_REGRESSION.IPF_' ! CALL UTL_MF2005_MAXNO(FNAME,(/M/)) END SUBROUTINE IMODBATCH_CURVEFITTING !###====================================================================== SUBROUTINE UTL_GLM(FNAME,COEF,X1,X2,OMEGA,IUOUT,NODATA) !###====================================================================== IMPLICIT NONE REAL(KIND=DP_KIND),PARAMETER :: GAMMA=4.0D0 INTEGER,PARAMETER :: MAXTRY=10 REAL(KIND=DP_KIND),PARAMETER :: MINOBJF=1.0D-04 REAL(KIND=DP_KIND),INTENT(OUT):: OMEGA REAL(KIND=DP_KIND),INTENT(IN):: NODATA REAL(KIND=DP_KIND),INTENT(INOUT),DIMENSION(:) :: COEF REAL(KIND=DP_KIND),INTENT(IN),DIMENSION(:) :: X1 REAL(KIND=DP_KIND),INTENT(INOUT),DIMENSION(:) :: X2 CHARACTER(LEN=*),INTENT(IN) :: FNAME CHARACTER(LEN=32) :: FRM INTEGER,INTENT(IN) :: IUOUT INTEGER,PARAMETER :: MAXITER=50,NLAMBDA=3 REAL(KIND=DP_KIND) :: DELTA,MARQUARDT,LAMBDA,MINL INTEGER :: N,M,I,J,ILAMBDA,ITRY REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: X3,JQR,JL INTEGER,ALLOCATABLE,DIMENSION(:) :: TCOEF !## transformation coefficient 0=lineair, 1=ln, 2=log10 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:,:) :: S,JQJ,U,OBJF,R REAL(KIND=DP_KIND),DIMENSION(NLAMBDA) :: LAMBDATEST=[0.1D0,1.0D0,10.0D0] IF(SIZE(X1).NE.SIZE(X2))RETURN; N=SIZE(COEF); M=SIZE(X1); ALLOCATE(OBJF(MAXITER,0:NLAMBDA)); OBJF=0.0D0; ALLOCATE(S(M,N),R(M,NLAMBDA)); S=0.0D0 ALLOCATE(JQJ(N,N),JQR(N),U(N,NLAMBDA),JL(NLAMBDA)); JQJ=0.0D0; JQR=0.0D0; U=0.0D0; JL=0.0D0 ALLOCATE(TCOEF(N)); TCOEF=0 ALLOCATE(X3(M)); X3=X2 !## set finite-difference step (normal space) DELTA=0.01D0 !## set number of coefficient N=SIZE(COEF) !## set desired transformation per coefficient !## set initial values IF(N.GE.1)THEN; COEF(1)=0.0D0; TCOEF(1)=1; ENDIF !## offset lineair IF(N.GE.2)THEN; COEF(2)=1.0D0; TCOEF(2)=2; ENDIF !## dynamics - ln() transformation IF(N.GE.3)THEN; COEF(3)=1.0D0; TCOEF(3)=2; ENDIF !## drainage - ??? DO J=1,SIZE(COEF) SELECT CASE (TCOEF(J)) CASE (1); COEF(J)=COEF(J)+1.0D0 END SELECT ENDDO ! u(:,1)=log(0.1); minl=UTL_GLM_OBJ(X1,R(:,1)) ! write(*,'(2f15.7)') exp(u(:,1)),UTL_GLM_OBJ(X1,R(:,1)) ! do ! u(:,1)=u(:,1)+delta ! CALL UTL_GLM_REAL(U(:,1),X2,R(:,1)); ! write(*,'(2f15.7)') exp(u(:,1)),UTL_GLM_OBJ(X1,R(:,1)) ! if(UTL_GLM_OBJ(X1,R(:,1)).gt.minl)exit ! minl=UTL_GLM_OBJ(X1,R(:,1)) ! enddo DO I=1,MAXITER !## determine objective function OBJF(I,0)=UTL_GLM_OBJ(X1,X3,NODATA,LAMBDA=LAMBDA) IF(OBJF(I,0).LE.MINOBJF)EXIT !## compute realisations/sensitivities CALL UTL_GLM_SENSITIVITY(COEF,TCOEF,X2,S,DELTA,NODATA) !## compute jqr CALL UTL_GLM_JQR(TCOEF,JQR,S,X1,X3,DELTA,NODATA) !## compute jacobian CALL UTL_GLM_JAC(TCOEF,S,X3,DELTA,NODATA) !## do until improvement found DO ITRY=1,MAXTRY ILAMBDA=0; CALL UTL_GLM_JQJ(COEF,JQJ,S,OBJF(I,0),MARQUARDT,0,ILAMBDA,NODATA) DO ILAMBDA=ILAMBDA+1; IF(ILAMBDA.GT.SIZE(LAMBDATEST))EXIT !## set marquardt-lambda (cannot become negative) MARQUARDT=MAX(LAMBDA*LAMBDATEST(ILAMBDA),0.0D0) !## compute jqj CALL UTL_GLM_JQJ(COEF,JQJ,S,OBJF(I,0),MARQUARDT,0,ILAMBDA,NODATA) !## compute gradients CALL UTL_GLM_GRAD(TCOEF,JQJ,JQR,U(:,ILAMBDA)) ENDDO !## add gradient to current coefficients DO ILAMBDA=1,NLAMBDA; U(:,ILAMBDA)=COEF(:)+U(:,ILAMBDA); ENDDO !## compute realisations DO ILAMBDA=1,NLAMBDA CALL UTL_GLM_REAL(U(:,ILAMBDA),X2,R(:,ILAMBDA),NODATA); OBJF(I,ILAMBDA)=UTL_GLM_OBJ(X1,R(:,ILAMBDA),NODATA) ENDDO !## pick best MINL=OBJF(I,0); J=0; DO ILAMBDA=1,NLAMBDA IF(OBJF(I,ILAMBDA).LT.MINL)THEN; MINL=OBJF(I,ILAMBDA); J=ILAMBDA; ENDIF ENDDO IF(J.EQ.0)THEN LAMBDA=LAMBDA*GAMMA ELSE !## set coefficients ! CASE (1); ! FCOEF=FCOEF*U(:,J) ! WRITE(*,'(2I10,2F15.7)') I,J,FCOEF(1),U(:,J) ! DO I=1,N ! SELECT CASE (TCOEF(I)) ! CASE (1); FCOEF=FCOEF*U(:,J) ! CASE (2); FCOEF=FCOEF*U(:,J) ! END SELECT !## update parameter values COEF=U(:,J) WRITE(*,'(2I10,2F15.7)') I,J,COEF(1),U(:,J) X3=R(:,J) WRITE(*,'(20X,2F15.7)') X1(1),X2(1),X3(1) EXIT ENDIF ENDDO IF(ITRY.GT.MAXTRY)EXIT ENDDO DO J=1,SIZE(COEF) SELECT CASE (TCOEF(J)) CASE (1); COEF(J)=COEF(J)-1.0D0 END SELECT ENDDO X2=X3 IF(I.LE.MAXITER)THEN WRITE(FRM,'(A7,I5.5,A11)') '(1X,I5,',2+N,'F15.7,1X,A)' WRITE(IUOUT,FRM) I,OBJF(I,0),(1.0D0-OBJF(I,0)/OBJF(1,0))*100.0D0,(COEF(J),J=1,N),TRIM(ADJUSTL(FNAME)) ELSE I=MAXITER WRITE(FRM,'(A7,I5.5,A11)') '(A1,I5,',2+N,'F15.7,1X,A)' WRITE(IUOUT,FRM) '*',I,OBJF(I,0),(1.0D0-OBJF(I,0)/OBJF(1,0))*100.0D0,(COEF(J),J=1,N),TRIM(ADJUSTL(FNAME)) ENDIF N=0; DO J=1,SIZE(X2) IF(X2(J).NE.NODATA)N=N+1 ENDDO OMEGA=SQRT(OBJF(I,0)/REAL(N,8)) DEALLOCATE(OBJF,S,R,JQJ,JQR,JL,TCOEF,X3) END SUBROUTINE UTL_GLM !###====================================================================== SUBROUTINE UTL_GLM_JAC(TCOEF,R,X2,DELTA,NODATA) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN),DIMENSION(:) :: TCOEF REAL(KIND=DP_KIND),INTENT(IN) :: NODATA REAL(KIND=DP_KIND),INTENT(INOUT),DIMENSION(:,:) :: R REAL(KIND=DP_KIND),INTENT(IN),DIMENSION(:) :: X2 REAL(KIND=DP_KIND),INTENT(IN) :: DELTA INTEGER :: I,J,NR,NX REAL(KIND=DP_KIND) :: R1,R2,D NR=SIZE(R,2) NX=SIZE(X2) DO I=1,NX DO J=1,NR SELECT CASE (TCOEF(J)) CASE (1); D=DELTA CASE (2); D=LOG(DELTA) CASE (3); D=LOG10(DELTA) END SELECT IF(R(I,J).NE.NODATA.AND.X2(I).NE.NODATA)THEN R1=R(I,J); R2=X2(I) R(I,J)=(R1-R2)/D ELSE R(I,J)=NODATA ENDIF ENDDO ENDDO END SUBROUTINE UTL_GLM_JAC !###====================================================================== SUBROUTINE UTL_GLM_GRAD(TCOEF,JQJ,JQR,U) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN),DIMENSION(:) :: TCOEF REAL(KIND=DP_KIND),INTENT(IN),DIMENSION(:,:) :: JQJ REAL(KIND=DP_KIND),INTENT(IN),DIMENSION(:) :: JQR REAL(KIND=DP_KIND),INTENT(OUT),DIMENSION(:) :: U INTEGER :: I,J,NP NP=SIZE(U) !## compute (JQJ)-1*JQR U=0.0D0 DO I=1,NP; DO J=1,NP U(I)=U(I)+(JQJ(J,I)*JQR(J)) ENDDO; ENDDO !## pointing downhill U=-1.0D0*U !## convert to correct gradient DO I=1,NP SELECT CASE (TCOEF(I)) CASE (1); CASE (2); U(I)=EXP(U(I)) CASE (3); U(I)=10.0D0**U(I) END SELECT ENDDO END SUBROUTINE UTL_GLM_GRAD !###====================================================================== REAL(KIND=DP_KIND) FUNCTION UTL_GLM_OBJ(X1,X2,NODATA,LAMBDA) !###====================================================================== IMPLICIT NONE REAL(KIND=DP_KIND),INTENT(IN) :: NODATA REAL(KIND=DP_KIND),INTENT(IN),DIMENSION(:) :: X1,X2 REAL(KIND=DP_KIND),INTENT(OUT),OPTIONAL :: LAMBDA UTL_GLM_OBJ=0.0D0 DO I=1,SIZE(X1) IF(X1(I).NE.NODATA)UTL_GLM_OBJ=UTL_GLM_OBJ+(X1(I)-X2(I))**2.0D0 ENDDO IF(UTL_GLM_OBJ.LE.0.0D0)RETURN IF(PRESENT(LAMBDA))THEN LAMBDA=UTL_GLM_OBJ/DBLE(2.0D0*SIZE(X1)) LAMBDA=LOG(LAMBDA); I=FLOOR(LAMBDA); LAMBDA=EXP(REAL(I,8)) ENDIF END FUNCTION UTL_GLM_OBJ !###====================================================================== SUBROUTINE UTL_GLM_SENSITIVITY(COEF,TCOEF,X2,R,DELTA,NODATA) !###====================================================================== IMPLICIT NONE REAL(KIND=DP_KIND),INTENT(IN) :: NODATA INTEGER,INTENT(IN),DIMENSION(:) :: TCOEF REAL(KIND=DP_KIND),INTENT(IN),DIMENSION(:) :: X2,COEF REAL(KIND=DP_KIND),INTENT(OUT),DIMENSION(:,:) :: R REAL(KIND=DP_KIND),INTENT(IN) :: DELTA INTEGER :: I,J,K REAL(KIND=DP_KIND),DIMENSION(:),ALLOCATABLE :: PCOEF REAL(KIND=DP_KIND) :: AVG,C,MAX N=SIZE(COEF); ALLOCATE(PCOEF(N)) AVG=UTL_GLM_AVERAGE(X2,NODATA) MAX=UTL_GLM_MAXIMAL(X2,NODATA) DO K=1,SIZE(COEF) PCOEF=COEF SELECT CASE (TCOEF(K)) CASE (1); PCOEF(K)= COEF(K) + DELTA CASE (2); PCOEF(K)=LOG(COEF(K)) +LOG( DELTA) CASE (3); PCOEF(K)=LOG10(COEF(K))+LOG10(DELTA) END SELECT DO J=1,SIZE(COEF) !## transform to real factor SELECT CASE (TCOEF(K)) CASE (1); C=PCOEF(J) CASE (2); C=EXP(PCOEF(J)) CASE (3); C=10.0D0**PCOEF(J) END SELECT DO I=1,SIZE(X2) IF(X2(I).NE.NODATA)THEN IF(J.EQ.1)R(I,K)=0.0D0 R(I,K)=R(I,K)+UTL_GLM_VALUE(C,J,X2(I),AVG,MAX) ELSE R(I,K)=NODATA ENDIF ENDDO ENDDO ENDDO DEALLOCATE(PCOEF) END SUBROUTINE UTL_GLM_SENSITIVITY !###====================================================================== REAL(KIND=DP_KIND) FUNCTION UTL_GLM_AVERAGE(X,NODATA) !###====================================================================== IMPLICIT NONE REAL(KIND=DP_KIND),INTENT(IN),DIMENSION(:) :: X REAL(KIND=DP_KIND),INTENT(IN) :: NODATA INTEGER :: I,J UTL_GLM_AVERAGE=0.0D0; J=0 DO I=1,SIZE(X) IF(X(I).EQ.NODATA)CYCLE J=J+1; UTL_GLM_AVERAGE=UTL_GLM_AVERAGE+X(I) ENDDO UTL_GLM_AVERAGE=UTL_GLM_AVERAGE/REAL(J,8) END FUNCTION UTL_GLM_AVERAGE !###====================================================================== REAL(KIND=DP_KIND) FUNCTION UTL_GLM_MAXIMAL(X,NODATA) !###====================================================================== IMPLICIT NONE REAL(KIND=DP_KIND),INTENT(IN),DIMENSION(:) :: X REAL(KIND=DP_KIND),INTENT(IN) :: NODATA INTEGER :: I,J UTL_GLM_MAXIMAL=NODATA; J=0 DO I=1,SIZE(X) IF(X(I).EQ.NODATA)CYCLE J=J+1; UTL_GLM_MAXIMAL=MAX(UTL_GLM_MAXIMAL,X(I)) ENDDO END FUNCTION UTL_GLM_MAXIMAL !###====================================================================== SUBROUTINE UTL_GLM_REAL(COEF,X2,R,NODATA) !###====================================================================== IMPLICIT NONE REAL(KIND=DP_KIND),INTENT(IN) :: NODATA REAL(KIND=DP_KIND),INTENT(IN),DIMENSION(:) :: X2,COEF REAL(KIND=DP_KIND),INTENT(OUT),DIMENSION(:) :: R INTEGER :: I,J REAL(KIND=DP_KIND) :: AVG,MAX AVG=UTL_GLM_AVERAGE(X2,NODATA) MAX=UTL_GLM_MAXIMAL(X2,NODATA) DO J=1,SIZE(COEF) DO I=1,SIZE(X2) IF(X2(I).NE.NODATA)THEN IF(J.EQ.1)R(I)=0.0D0 R(I)=R(I)+UTL_GLM_VALUE(COEF(J),J,X2(I),AVG,MAX) ELSE R(I)=NODATA ENDIF ENDDO ENDDO END SUBROUTINE UTL_GLM_REAL !###====================================================================== REAL(KIND=DP_KIND) FUNCTION UTL_GLM_VALUE(C,J,X,AVG,MAX) !###====================================================================== IMPLICIT NONE REAL(KIND=DP_KIND),INTENT(IN) :: X,AVG,MAX REAL(KIND=DP_KIND),INTENT(IN) :: C INTEGER,INTENT(IN) :: J REAL(KIND=DP_KIND) :: A,A1,A2 UTL_GLM_VALUE=X SELECT CASE (J) !## offset (transmissivity) ! CASE (1); UTL_GLM_VALUE=UTL_GLM_VALUE*C CASE (1); UTL_GLM_VALUE=UTL_GLM_VALUE+((C*1.0D0)-1.0D0) !## dynamics (storage) CASE (2) A1= X-AVG A2= A1*C A = A2-A1 UTL_GLM_VALUE=A !## drainage CASE (3) !## apply threshold IF(UTL_GLM_VALUE.GT.MAX)UTL_GLM_VALUE=C END SELECT END FUNCTION UTL_GLM_VALUE !###====================================================================== SUBROUTINE UTL_GLM_JQR(TCOEF,JQR,R,X1,X2,DELTA,NODATA) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN),DIMENSION(:) :: TCOEF REAL(KIND=DP_KIND),INTENT(IN) :: NODATA REAL(KIND=DP_KIND),INTENT(IN) :: DELTA REAL(KIND=DP_KIND),INTENT(IN),DIMENSION(:,:) :: R REAL(KIND=DP_KIND),INTENT(IN),DIMENSION(:) :: X1,X2 REAL(KIND=DP_KIND),INTENT(OUT),DIMENSION(:) :: JQR INTEGER :: I,J REAL(KIND=DP_KIND) :: SS,TS,R1,R2,W,DJ1,DJ2,D !## construct jTqr (<--- r is residual for current parameter set) JQR=0.0 DO I=1,SIZE(JQR) TS=0.0D0; SS=0.0D0 SELECT CASE (TCOEF(I)) CASE (1); D=DELTA CASE (2); D=LOG(DELTA) CASE (3); D=LOG10(DELTA) END SELECT DO J=1,SIZE(R,1) IF(X2(J).NE.NODATA)THEN R1=R(J,I); R2=X2(J) DJ1=(R1-R2)/D; DJ2=X2(J)-X1(J) W =1.0D0 TS=TS+(DJ1*W*DJ2) ELSE TS=0.0D0 ENDIF ENDDO SS=SS+TS JQR(I)=JQR(I)+SS ENDDO END SUBROUTINE UTL_GLM_JQR !###====================================================================== SUBROUTINE UTL_GLM_JQJ(COEF,JQJ,R,JOBJ,MARQUARDT,IUOUT,ILAMBDA,NODATA) !###====================================================================== IMPLICIT NONE REAL(KIND=DP_KIND),INTENT(IN) :: NODATA REAL(KIND=DP_KIND),INTENT(IN) :: MARQUARDT,JOBJ REAL(KIND=DP_KIND),INTENT(IN),DIMENSION(:,:) :: R REAL(KIND=DP_KIND),INTENT(IN),DIMENSION(:) :: COEF REAL(KIND=DP_KIND),INTENT(OUT),DIMENSION(:,:) :: JQJ INTEGER,INTENT(IN) :: IUOUT,ILAMBDA INTEGER :: I,II,J,NP,N,ISING,IOS,NR REAL(KIND=DP_KIND) :: DJ1,DJ2,W,CB,B1,ZW,Z,Z1,Z2 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:,:) :: COR,COV,B REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: STDEV INTEGER,ALLOCATABLE,DIMENSION(:) :: INDX CHARACTER(LEN=16),DIMENSION(3) :: TXT=['OFFSET','DYNAMICS','THRESHOLD'] NP=SIZE(JQJ,1) NR=SIZE(R,1) JQJ=0.0D0 DO I=1,NP DO II=1,NP DO J=1,NR IF(R(J,I).NE.NODATA.AND.R(J,II).NE.NODATA)THEN DJ1=R(J,I); DJ2=R(J,II); W=1.0D0 JQJ(II,I)=JQJ(II,I)+(DJ1*W*DJ2) ENDIF ENDDO ENDDO ENDDO IF(ILAMBDA.NE.0)THEN DO I=1,NP JQJ(I,I)=JQJ(I,I)+MARQUARDT ENDDO ENDIF IF(ALLOCATED(INDX)) DEALLOCATE(INDX); ALLOCATE(INDX(NP )) IF(ALLOCATED(B )) DEALLOCATE(B); ALLOCATE(B(NP,NP )) CALL IPEST_LUDECOMP_DBL(JQJ,INDX,NP,ISING) !## matrix not singular - compute inverse IF(ISING.NE.0)THEN WRITE(*,'(/A/)') '>>> Singular matrix, cannot compute covariance matrix. <<<' ENDIF B=0.0D0; DO I=1,NP; B(I,I)=1.0D0; ENDDO DO I=1,NP; CALL IPEST_LUBACKSUB_DBL(JQJ,INDX,B(1,I),NP); ENDDO IF(ILAMBDA.NE.0)THEN !## copy inverse of jqj JQJ=B IF(ALLOCATED(INDX)) DEALLOCATE(INDX) IF(ALLOCATED(B)) DEALLOCATE(B) RETURN ENDIF IF(IUOUT.EQ.0)RETURN IF(ALLOCATED(COR )) DEALLOCATE(COR); ALLOCATE(COR(NP,NP)) IF(ALLOCATED(COV )) DEALLOCATE(COV); ALLOCATE(COV(NP,NP)) IF(ALLOCATED(STDEV))DEALLOCATE(STDEV); ALLOCATE(STDEV(NP )) !## b1 is variance of each of model response N=MAX(1,NR-NP); B1=JOBJ/REAL(N,8) !## parameter covariance matrix scaled to this variance DO I=1,NP; DO J=1,NP; B(I,J)=B1*B(I,J); ENDDO; ENDDO WRITE(IUOUT,'(/A/)') 'Parameter Covariance Matrix (m2):' WRITE(IUOUT,'(15X,3A15)') (TXT(I),I=1,NP) DO I=1,NP WRITE(IUOUT,'(A15,3G15.7)') TXT(I),(B(I,J),J=1,NP) DO J=1,NP; COV(I,J)=B(I,J); ENDDO ENDDO WRITE(IUOUT,'(/A/)') 'Parameter Correlation Matrix (-)' WRITE(IUOUT,'(15X,3A15)') (TXT(I),I=1,NP) COR=0.0D0; I=0 DO I=1,NP DO J=1,NP CB=B(I,I)*B(J,J) IF(CB.GT.0.0D0)THEN COR(I,J)=B(I,J)/SQRT(CB) ELSE COR(I,J)=0.0D0 ENDIF ENDDO WRITE(IUOUT,'(A15,3F15.7)',IOSTAT=IOS) TXT(I),(COR(I,J),J=1,NP) ENDDO WRITE(IUOUT,'(/A/)') 'Parameter Variance - Standard Parameter Error (Confidence Limits ~96%)' DO I=1,NP IF(COV(I,I).GT.0.0D0)THEN !## stdev STDEV(I)=SQRT(COV(I,I)) ELSE !## error value - should not happen STDEV(I)=-999.99D0 ENDIF ENDDO WRITE(IUOUT,'(15X,3A15)') 'Lower_Limit','Average','Upper Limit' WRITE(IUOUT,'(60A1)') ('-',I=1,60) DO I=1,NP ZW=STDEV(I)*1.96D0 !## maximize uncertainty ZW=MIN(10.0D0,ZW) ! SELECT CASE (TCOEF(I)) ! CASE (0) Z =COEF(I) Z1=COEF(I)-ZW Z2=COEF(I)+ZW ! CASE (1) ! Z =EXP(COEF(I)) ! Z1=EXP(COEF(I)-ZW) ! Z2=EXP(COEF(I)+ZW) ! CASE (2) ! Z =10.0D0** COEF(I) ! Z1=10.0D0**(COEF(I)-ZW) ! Z2=10.0D0**(COEF(I)+ZW) ! END SELECT WRITE(IUOUT,'(A15,3G15.7)') TXT(I),Z1,Z,Z2 ENDDO IF(ALLOCATED(INDX)) DEALLOCATE(INDX) IF(ALLOCATED(B)) DEALLOCATE(B) IF(ALLOCATED(COV )) DEALLOCATE(COV) IF(ALLOCATED(COR )) DEALLOCATE(COR) IF(ALLOCATED(STDEV))DEALLOCATE(STDEV) END SUBROUTINE UTL_GLM_JQJ !###====================================================================== SUBROUTINE IMODBATCH_MF6TOIDF() !###====================================================================== IMPLICIT NONE TYPE(IDFOBJ) :: IDF,SUM,PHR,HED TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: FFF,FRF,FLF CHARACTER(LEN=256) :: HEDFNAME,BDGFNAME INTEGER :: JU,NCOL,NROW,NLAY,ILAY,KSTP,KPER,ICOL,IROW,IOS,I1,I2,I3,NDIM1,NDIM2,NDIM3, & IMETH,NDAT,NLIST,I,J,LENTXT,NCELLS,NTXT,NJA,N,M,IPOS,NCON,NODE,JLAY,JROW,JCOL,IUUZFCPL, & NLAYERS,IYR,IMH,IDY,IHR,IMT,ISC,ISHORT,ISAT,IPHRLVL,IDATEFORMAT,IFORM,IBDGTYPE,IUZF,UZFNLAY, & ISTEADY,ISAVEENDDATE,IDOUBLE,IFILLHEAD INTEGER,DIMENSION(:),ALLOCATABLE :: ID1,ID2 CHARACTER(LEN=16) :: TEXT,TXT1ID1,TXT1ID2,TXT2ID1,TXT2ID2,CDATE CHARACTER(LEN=50) :: HDR CHARACTER(LEN=16),ALLOCATABLE,DIMENSION(:) :: AUXTXT CHARACTER(LEN=256) :: ROOT REAL(KIND=DP_KIND) :: PERTIM,TOTIM,TTM,DELT,ANGROT,Q REAL(KIND=DP_KIND),DIMENSION(:,:,:),ALLOCATABLE :: X,Y CHARACTER(LEN=:),ALLOCATABLE :: STRING INTEGER(KIND=DP_KIND) :: SDATE,IDATE INTEGER,DIMENSION(:),ALLOCATABLE :: IA,JA INTEGER,DIMENSION(:),POINTER :: SAVESHD,SAVEWEL,SAVEDRN,SAVERIV,SAVEGHB,SAVERCH,SAVEEVT,SAVEFLX,SAVECHD,SAVESTO,SAVESPY,SAVEISG, & SAVESAT,SAVEUZF,SAVEFHB LOGICAL :: LEX TYPE UZFOBJ INTEGER :: ILAY,IROW,ICOL END TYPE UZFOBJ TYPE(UZFOBJ),ALLOCATABLE,DIMENSION(:) :: UZF ISTEADY=0; IF(UTL_READINITFILE('ISTEADY',LINE,IU,1))THEN READ(LINE,*) ISTEADY; WRITE(*,'(A)') 'ISTEADY='//TRIM(VTOS(ISTEADY)) ENDIF IDOUBLE=0; IF(UTL_READINITFILE('IDOUBLE',LINE,IU,1))THEN READ(LINE,*) IDOUBLE; WRITE(*,'(A)') 'IDOUBLE='//TRIM(VTOS(IDOUBLE)) ENDIF ISHORT=0; SDATE=0 IF(UTL_READINITFILE('SDATE',LINE,IU,1))THEN READ(LINE,*) SDATE; SDATE=UTL_COMPLETEDATE(SDATE,ISHORT); WRITE(*,'(A)') 'SDATE='//TRIM(VTOS(SDATE)) CALL UTL_IDATETOGDATE(SDATE,IYR,IMH,IDY,IHR,IMT,ISC) ENDIF IF(ISTEADY.EQ.0.AND.SDATE.EQ.0)THEN WRITE(*,'(/A/)') '>>> In case ISTEADY=0 (or absent) you need to specify SDATE <<<' STOP ENDIF ISAVEENDDATE=1; IF(UTL_READINITFILE('ISAVEENDDATE',LINE,IU,1))THEN READ(LINE,*) ISAVEENDDATE; WRITE(*,'(A)') 'ISAVEENDDATE='//TRIM(VTOS(ISAVEENDDATE)) ENDIF IDATEFORMAT=-1; IF(UTL_READINITFILE('DATEFORMAT',LINE,IU,1))THEN READ(LINE,*) IDATEFORMAT; WRITE(*,'(A)') 'DATEFORMAT='//TRIM(VTOS(IDATEFORMAT)) ENDIF IPHRLVL=0 IF(UTL_READINITFILE('IPHRLVL',LINE,IU,1))THEN READ(LINE,*) IPHRLVL; WRITE(*,'(A)') 'IPHRLVL='//TRIM(VTOS(IPHRLVL)) ENDIF IFILLHEAD=0 IF(UTL_READINITFILE('IFILLHEAD',LINE,IU,1))THEN READ(LINE,*) IFILLHEAD; WRITE(*,'(A)') 'IFILLHEAD='//TRIM(VTOS(IFILLHEAD)) ENDIF IF(.NOT.UTL_READPOINTER(IU,NLAYERS,SAVESHD,'SAVESHD',1))RETURN IF(.NOT.UTL_READPOINTER(IU,NLAYERS,SAVEWEL,'SAVEWEL',1))RETURN IF(.NOT.UTL_READPOINTER(IU,NLAYERS,SAVEDRN,'SAVEDRN',1))RETURN IF(.NOT.UTL_READPOINTER(IU,NLAYERS,SAVERIV,'SAVERIV',1))RETURN IF(.NOT.UTL_READPOINTER(IU,NLAYERS,SAVEISG,'SAVEISG',1))RETURN IF(.NOT.UTL_READPOINTER(IU,NLAYERS,SAVEGHB,'SAVEGHB',1))RETURN IF(.NOT.UTL_READPOINTER(IU,NLAYERS,SAVERCH,'SAVERCH',1))RETURN IF(.NOT.UTL_READPOINTER(IU,NLAYERS,SAVEEVT,'SAVEEVT',1))RETURN IF(.NOT.UTL_READPOINTER(IU,NLAYERS,SAVECHD,'SAVECHD',1))RETURN IF(.NOT.UTL_READPOINTER(IU,NLAYERS,SAVEFLX,'SAVEFLX',1))RETURN IF(.NOT.UTL_READPOINTER(IU,NLAYERS,SAVESTO,'SAVESTO',1))RETURN IF(.NOT.UTL_READPOINTER(IU,NLAYERS,SAVESPY,'SAVESPY',1))RETURN IF(.NOT.UTL_READPOINTER(IU,NLAYERS,SAVESAT,'SAVESAT',1))RETURN IF(.NOT.UTL_READPOINTER(IU,NLAYERS,SAVEUZF,'SAVEUZF',1))RETURN IF(.NOT.UTL_READPOINTER(IU,NLAYERS,SAVEFHB,'SAVEFHB',1))RETURN CALL IDFNULLIFY(IDF); CALL IDFNULLIFY(PHR); CALL IDFNULLIFY(SUM) !## single precision IF(IDOUBLE.EQ.0)THEN IDF%ITYPE=4 !## double precision ELSE IDF%ITYPE=8 ENDIF IF(UTL_READINITFILE('IDF',LINE,IU,1))THEN READ(LINE,*) IDF%FNAME; WRITE(*,'(A)') 'IDF='//TRIM(IDF%FNAME) INQUIRE(FILE=IDF%FNAME,EXIST=LEX); IF(.NOT.LEX)THEN; WRITE(*,'(/A/)') 'Cannot read '//TRIM(IDF%FNAME); STOP; ENDIF IF(.NOT.IDFREAD(IDF,IDF%FNAME,1))STOP ELSEIF(UTL_READINITFILE('GRB',LINE,IU,1))THEN READ(LINE,*) IDF%FNAME; WRITE(*,'(A)') 'GRB='//TRIM(IDF%FNAME) INQUIRE(FILE=IDF%FNAME,EXIST=LEX); IF(.NOT.LEX)THEN; WRITE(*,'(/A/)') 'Cannot read '//TRIM(IDF%FNAME); STOP; ENDIF JU=UTL_GETUNIT(); OPEN(JU,FILE=IDF%FNAME,ACTION='READ',ACCESS='STREAM',FORM='UNFORMATTED') READ(JU) HDR READ(JU) HDR READ(JU) HDR; READ(HDR(5:),*) NTXT READ(JU) HDR; READ(HDR(7:),*) LENTXT ALLOCATE(CHARACTER(LEN=LENTXT) :: STRING) DO I=1,NTXT; READ(JU) STRING; ENDDO READ(JU) NCELLS READ(JU) NLAY READ(JU) IDF%NROW READ(JU) IDF%NCOL READ(JU) NJA READ(JU) IDF%XMIN READ(JU) IDF%YMIN READ(JU) ANGROT ALLOCATE(IDF%SX(0:IDF%NCOL)); READ(JU) (IDF%SX(I),I=1,IDF%NCOL) ALLOCATE(IDF%SY(0:IDF%NROW)); READ(JU) (IDF%SY(I),I=1,IDF%NROW) ALLOCATE(X(IDF%NCOL*IDF%NROW,1,1)); READ(JU) (X(I,1,1),I=1,IDF%NCOL*IDF%NROW); DEALLOCATE(X) ALLOCATE(X(NCELLS,1,1)); READ(JU) (X(I,1,1),I=1,NCELLS); DEALLOCATE(X) ALLOCATE(IA(NCELLS+1)); READ(JU) (IA(I),I=1,NCELLS+1) ALLOCATE(JA(NJA)); READ(JU) (JA(I),I=1,NJA) DEALLOCATE(STRING) !## see whether it is a non-equidistantial model IDF%IEQ=0 IF(MINVAL(IDF%SX(1:IDF%NCOL)).NE.MAXVAL(IDF%SX(1:IDF%NCOL)))IDF%IEQ=1 IF(MINVAL(IDF%SY(1:IDF%NROW)).NE.MAXVAL(IDF%SY(1:IDF%NROW)))IDF%IEQ=1 !## fill sx/sy IDF%SX(0)=IDF%XMIN; DO I=1,IDF%NCOL; IDF%SX(I)=IDF%SX(I-1)+IDF%SX(I); ENDDO IDF%YMAX=IDF%YMIN; DO I=1,IDF%NROW; IDF%YMAX =IDF%YMAX+IDF%SY(I); ENDDO IDF%SY(0)=IDF%YMAX; DO I=1,IDF%NROW; IDF%SY(I)=IDF%SY(I-1)-IDF%SY(I); ENDDO IF(IDF%IEQ.EQ.0)THEN IDF%DX=IDF%SX(1)-IDF%SX(0); IDF%DY=IDF%SY(0)-IDF%SY(1) IDF%XMAX=IDF%XMIN+(IDF%NCOL*IDF%DX) IDF%YMAX=IDF%YMIN+(IDF%NROW*IDF%DY) ELSE IDF%DX=MINVAL(IDF%SX); IDF%DY=MINVAL(IDF%SY) IDF%XMAX=IDF%SX(IDF%NCOL) IDF%YMAX=IDF%SY(0) ENDIF IDF%NODATA=1.0D10 !HUGE(1.0) IF(.NOT.IDFALLOCATEX(IDF))STOP 'CANNOT ALLOCATE MEMORY X IN IDF OBJECT' CLOSE(JU) ELSE STOP 'IDF OR GRB NEEDED' ENDIF IFORM=IDATEFORMAT !## convert heads IF(UTL_READINITFILE('HED',LINE,IU,1))THEN CALL IDFCOPY(IDF,PHR); CALL IDFCOPY(IDF,SUM); ; CALL IDFCOPY(IDF,HED); SUM%NODATA=0.0D0 READ(LINE,*) HEDFNAME; WRITE(*,'(A)') 'HED='//TRIM(HEDFNAME) ROOT=HEDFNAME(:INDEX(HEDFNAME,'\',.TRUE.)-1) INQUIRE(FILE=HEDFNAME,EXIST=LEX); IF(.NOT.LEX)THEN; WRITE(*,'(/A/)') 'Cannot read '//TRIM(HEDFNAME); STOP; ENDIF JU=UTL_GETUNIT(); OPEN(JU,FILE=HEDFNAME,STATUS='OLD',ACTION='READ',ACCESS='STREAM',FORM='UNFORMATTED') HED%X=HED%NODATA; TOTIM=0.0D0 DO READ(JU,IOSTAT=IOS) KSTP,KPER,PERTIM,TTM,TEXT,NCOL,NROW,ILAY; IF(IOS.NE.0)EXIT TEXT=ADJUSTL(TEXT) IF(ILAY.EQ.1)THEN; SUM%X=0.0; PHR%X=PHR%NODATA; ENDIF IF(ISTEADY.EQ.1.AND.KPER.EQ.1) THEN CDATE='STEADY-STATE' ELSE CALL UTL_IDATETOGDATE(SDATE,IYR,IMH,IDY,IHR,IMT,ISC) IF(ILAY.EQ.1)TOTIM=TOTIM+PERTIM IF(ISAVEENDDATE.EQ.0)THEN CDATE=TRIM(VTOS(ADD_DT_TO_IDATE(IYR,IMH,IDY,IHR,IMT,ISC,TOTIM-PERTIM,ISHORT))) ELSE CDATE=TRIM(VTOS(ADD_DT_TO_IDATE(IYR,IMH,IDY,IHR,IMT,ISC,TOTIM,ISHORT))) ENDIF READ(CDATE,*) IDATE; CALL UTL_IDATETOGDATE(IDATE,IYR,IMH,IDY,IHR,IMT,ISC) !## set automatic date IF(IDATEFORMAT.EQ.-1)THEN IFORM=0; IF(ISC+IMT+IHR.GT.0)IFORM=1 ENDIF IF(IFORM.EQ.0)WRITE(CDATE,'(I4.4,2I2.2)') IYR,IMH,IDY IF(IFORM.EQ.1)WRITE(CDATE,'(I4.4,5I2.2)') IYR,IMH,IDY,IHR,IMT,ISC ENDIF WRITE(*,'(1X,A)') 'Processing '//TRIM(TEXT)//'_'//TRIM(CDATE)//'_L'//TRIM(VTOS(ILAY))//' ...' READ(JU) ((IDF%X(ICOL,IROW),ICOL=1,NCOL),IROW=1,NROW) LEX=.FALSE.; IF(ASSOCIATED(SAVESHD))THEN; DO I=1,SIZE(SAVESHD); IF(SAVESHD(I).EQ.ILAY.OR.SAVESHD(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL IF(ABS(IDF%X(ICOL,IROW)).GT.IDF%NODATA)IDF%X(ICOL,IROW)=IDF%NODATA IF(IFILLHEAD.EQ.1)THEN IF(IDF%X(ICOL,IROW).EQ.IDF%NODATA)THEN IDF%X(ICOL,IROW)=HED%X(ICOL,IROW) ENDIF ENDIF ENDDO; ENDDO HED%X=IDF%X IF(LEX)THEN IDF%FNAME=TRIM(ROOT)//'\'//TRIM(TEXT)//'\'//TRIM(TEXT)//'_'//TRIM(CDATE)//'_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(IDF,IDF%FNAME,1))STOP ENDIF DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL IF(IDF%X(ICOL,IROW).NE.IDF%NODATA)THEN IF(SUM%X(ICOL,IROW).EQ.0.0D0)PHR%X(ICOL,IROW)=IDF%X(ICOL,IROW) SUM%X(ICOL,IROW)=SUM%X(ICOL,IROW)+1.0D0 ENDIF ENDDO; ENDDO IF(ILAY.EQ.NLAY)THEN IF(IPHRLVL.EQ.1)THEN SUM%FNAME=TRIM(ROOT)//'\SUMACT_'//TRIM(CDATE)//'.IDF'; IF(.NOT.IDFWRITE(SUM,SUM%FNAME,1))STOP PHR%FNAME=TRIM(ROOT)//'\PHRLEVEL_'//TRIM(CDATE)//'.IDF'; IF(.NOT.IDFWRITE(PHR,PHR%FNAME,1))STOP ENDIF ENDIF ENDDO CLOSE(JU) ENDIF !## convert budgets DO IBDGTYPE=1,3 SELECT CASE(IBDGTYPE) !## regular CASE (1) LEX=UTL_READINITFILE('BDG',LINE,IU,1); IF(.NOT.LEX)CYCLE READ(LINE,*) BDGFNAME; WRITE(*,'(A)') 'BDG='//TRIM(BDGFNAME) !## uzf CASE (2,3) IF(IBDGTYPE.EQ.2)THEN LEX=UTL_READINITFILE('BDGUZF',LINE,IU,1); IF(.NOT.LEX)CYCLE READ(LINE,*) BDGFNAME; WRITE(*,'(A)') 'BDGUZF='//TRIM(BDGFNAME) ELSEIF(IBDGTYPE.EQ.3)THEN LEX=UTL_READINITFILE('WC_UZF',LINE,IU,1); IF(.NOT.LEX)CYCLE READ(LINE,*) BDGFNAME; WRITE(*,'(A)') 'WC_UZF='//TRIM(BDGFNAME) ENDIF !## read uzf coupling table ROOT=BDGFNAME(:INDEX(BDGFNAME,'\MODELOUTPUT\',.TRUE.)-1)//'\MODELINPUT\CPL_UZF.TXT' INQUIRE(FILE=ROOT,EXIST=LEX); IF(.NOT.LEX)THEN; WRITE(*,'(/A/)') 'Cannot read '//TRIM(ROOT); STOP; ENDIF IUUZFCPL=UTL_GETUNIT(); OPEN(IUUZFCPL,FILE=ROOT,STATUS='OLD',ACTION='READ') DO I=1,2 N=0; DO READ(IUUZFCPL,*,IOSTAT=IOS) IUZF,ILAY,IROW,ICOL IF(IOS.NE.0)EXIT; N=MAX(N,IUZF) IF(I.EQ.2)THEN UZF(IUZF)%ILAY=ILAY UZF(IUZF)%IROW=IROW UZF(IUZF)%ICOL=ICOL ENDIF ENDDO IF(I.EQ.1)THEN; ALLOCATE(UZF(N)); REWIND(IUUZFCPL); ENDIF ENDDO UZFNLAY=MAXVAL(UZF%ILAY); CLOSE(IUUZFCPL) END SELECT ROOT=BDGFNAME(:INDEX(BDGFNAME,'\',.TRUE.)-1) INQUIRE(FILE=BDGFNAME,EXIST=LEX); IF(.NOT.LEX)THEN; WRITE(*,'(/A/)') 'Cannot read '//TRIM(BDGFNAME); STOP; ENDIF JU=UTL_GETUNIT() IF(IBDGTYPE.EQ.3)THEN OPEN(JU,FILE=BDGFNAME,STATUS='OLD',ACTION='READ',ACCESS='STREAM',FORM='UNFORMATTED') ELSE OPEN(JU,FILE=BDGFNAME,STATUS='OLD',ACTION='READ',ACCESS='STREAM',FORM='UNFORMATTED') ENDIF DO SELECT CASE (IBDGTYPE) CASE (1,2) READ(JU,IOSTAT=IOS) KSTP,KPER,TEXT,NDIM1,NDIM2,NDIM3; IF(IOS.NE.0)EXIT !## saturation savings TEXT=ADJUSTL(TEXT); ISAT=0; IF(TEXT.EQ.'DATA-SAT')ISAT=1 READ(JU,IOSTAT=IOS) IMETH,DELT,PERTIM,TOTIM; IF(IOS.NE.0)EXIT !## ulasav CASE (3) READ(JU,IOSTAT=IOS) KSTP,KPER,PERTIM,TOTIM,TEXT,NDIM1,NDIM2,NDIM3; IF(IOS.NE.0)EXIT TEXT=ADJUSTL(TEXT) !## ulasav method IMETH=-1 END SELECT IF(ISTEADY.EQ.1.AND.KPER.EQ.1) THEN CDATE='STEADY-STATE' ELSE CALL UTL_IDATETOGDATE(SDATE,IYR,IMH,IDY,IHR,IMT,ISC) IF(ISAVEENDDATE.EQ.0)THEN CDATE=TRIM(VTOS(ADD_DT_TO_IDATE(IYR,IMH,IDY,IHR,IMT,ISC,TOTIM-PERTIM,ISHORT))) ELSE CDATE=TRIM(VTOS(ADD_DT_TO_IDATE(IYR,IMH,IDY,IHR,IMT,ISC,TOTIM,ISHORT))) ENDIF READ(CDATE,*) IDATE; CALL UTL_IDATETOGDATE(IDATE,IYR,IMH,IDY,IHR,IMT,ISC) !## set automatic date IF(IDATEFORMAT.EQ.-1)THEN IFORM=0; IF(ISC+IMT+IHR.GT.0)IFORM=1 ENDIF IF(IFORM.EQ.0)WRITE(CDATE,'(I4.4,2I2.2)') IYR,IMH,IDY IF(IFORM.EQ.1)WRITE(CDATE,'(I4.4,5I2.2)') IYR,IMH,IDY,IHR,IMT,ISC ENDIF WRITE(*,'(1X,A)') 'Processing '//TRIM(TEXT)//'_'//TRIM(CDATE)//'_L* ...' SELECT CASE (IMETH) !## ulasav CASE (-1) ALLOCATE(X(NDIM1,1,1)); READ(JU) (X(J,1,1),J=1,NDIM1) ALLOCATE(Y(IDF%NCOL,IDF%NROW,UZFNLAY)); Y=0.0D0 DO J=1,NLIST !## take only flow from->to and not to->from ILAY=UZF(J)%ILAY; IROW=UZF(J)%IROW; ICOL=UZF(J)%ICOL; Y(ICOL,IROW,ILAY)=X(J,1,1) ENDDO DO ILAY=1,UZFNLAY LEX=.FALSE. IF(ASSOCIATED(SAVEUZF))THEN; DO I=1,SIZE(SAVEUZF); IF(SAVEUZF(I).EQ.ILAY.OR.SAVEUZF(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF IF(ILAY.EQ.1)TEXT='BDG'//ADJUSTL(TEXT) !TXT2ID2) IF(LEX)THEN IDF%X=IDF%NODATA DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL IF(Y(ICOL,IROW,ILAY).NE.0.0D0)THEN IDF%X(ICOL,IROW)=Y(ICOL,IROW,ILAY) ENDIF ENDDO; ENDDO IDF%FNAME=TRIM(ROOT)//'\'//TRIM(TEXT)//'\'//TRIM(TEXT)//'_'//TRIM(CDATE)//'_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(IDF,IDF%FNAME,1))STOP ENDIF ENDDO DEALLOCATE(X,Y) !## intercell flow + storage CASE (1) IF(IBDGTYPE.NE.1)THEN WRITE(*,'(/1X,A/)') '>>> NOT SUPPORTED IMETH=1 FOR IBDGTYPE=',IBDGTYPE; STOP ENDIF ALLOCATE(X(NDIM1,NDIM2,ABS(NDIM3))) READ(JU) (((X(I1,I2,I3),I1=1,NDIM1),I2=1,NDIM2),I3=1,ABS(NDIM3)) IF(TRIM(ADJUSTL(TEXT)).EQ.'FLOW-JA-FACE')THEN ALLOCATE(FFF(NLAY),FRF(NLAY),FLF(NLAY)) DO ILAY=1,NLAY CALL IDFNULLIFY(FFF(ILAY)); CALL IDFNULLIFY(FRF(ILAY)); CALL IDFNULLIFY(FLF(ILAY)) CALL IDFCOPY(IDF,FFF(ILAY)); CALL IDFCOPY(IDF,FRF(ILAY)); CALL IDFCOPY(IDF,FLF(ILAY)) FLF(ILAY)%NODATA=1.0D30; FLF(ILAY)%X=0.0D0 FFF(ILAY)%NODATA=1.0D30; FFF(ILAY)%X=0.0D0 FRF(ILAY)%NODATA=1.0D30; FRF(ILAY)%X=0.0D0 ENDDO DO N=1,NCELLS ! WRITE(*,'(A,I10)') 'THIS IS CELL: ', N NODE=N; CALL UTL_GETIROWICOL(NODE,IDF%NROW,IDF%NCOL,ILAY,IROW,ICOL) NCON=IA(N+1)-IA(N)-1 IF(NCON.LE.0) NCON=0 ! WRITE(*,'(A,4I10)') 'NUMBER OF CONNECTED CELLS IS CELL,ILAY,IROW,ICOL', NCON,ILAY,IROW,ICOL DO IPOS=IA(N)+1,IA(N+1)-1 M=JA(IPOS) Q=X(IPOS,1,1) NODE=M; CALL UTL_GETIROWICOL(NODE,IDF%NROW,IDF%NCOL,JLAY,JROW,JCOL) !## determine what face it is IF(JLAY.GT.ILAY)THEN FLF(ILAY)%X(ICOL,IROW)=Q ELSEIF(JROW.GT.IROW)THEN FFF(ILAY)%X(ICOL,IROW)=Q ELSEIF(JCOL.GT.ICOL)THEN FRF(ILAY)%X(ICOL,IROW)=Q ENDIF ! WRITE(*,'(A,2I10,F10.3)') ' N M Q: ', N,M,Q ENDDO ENDDO !## fill in missing bdgflf DO IROW=1,NROW; DO ICOL=1,NCOL Q=0.0D0 DO ILAY=1,NLAY IF(FLF(ILAY)%X(ICOL,IROW).NE.0.0D0)THEN Q=FLF(ILAY)%X(ICOL,IROW) ELSE FLF(ILAY)%X(ICOL,IROW)=Q ENDIF ENDDO ENDDO; ENDDO DO ILAY=1,NLAY LEX=.FALSE.; IF(ASSOCIATED(SAVEFLX))THEN; DO I=1,SIZE(SAVEFLX); IF(SAVEFLX(I).EQ.ILAY.OR.SAVEFLX(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF IF(LEX)THEN IDF%NODATA=1.0D30 IF(ILAY.LT.NLAY)THEN TEXT='BDGFLF'; IDF%FNAME=TRIM(ROOT)//'\'//TRIM(TEXT)//'\'//TRIM(TEXT)//'_'//TRIM(CDATE)//'_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(FLF(ILAY),IDF%FNAME,1))STOP ENDIF TEXT='BDGFRF'; IDF%FNAME=TRIM(ROOT)//'\'//TRIM(TEXT)//'\'//TRIM(TEXT)//'_'//TRIM(CDATE)//'_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(FRF(ILAY),IDF%FNAME,1))STOP TEXT='BDGFFF'; IDF%FNAME=TRIM(ROOT)//'\'//TRIM(TEXT)//'\'//TRIM(TEXT)//'_'//TRIM(CDATE)//'_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(FFF(ILAY),IDF%FNAME,1))STOP ENDIF ENDDO CALL IDFDEALLOCATE(FFF,SIZE(FFF)); CALL IDFDEALLOCATE(FRF,SIZE(FRF)); CALL IDFDEALLOCATE(FLF,SIZE(FLF)) DEALLOCATE(FFF,FRF,FLF) ELSE IF(TRIM(TEXT).EQ.'STO-SS')TEXT='STO'; IF(TRIM(TEXT).EQ.'STO-SY')TEXT='SPY' DO ILAY=1,ABS(NDIM3) LEX=.FALSE. SELECT CASE (TEXT(1:3)) CASE ('WEL'); IF(ASSOCIATED(SAVEWEL))THEN; DO I=1,SIZE(SAVEWEL); IF(SAVEWEL(I).EQ.ILAY.OR.SAVEWEL(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF CASE ('DRN'); IF(ASSOCIATED(SAVEDRN))THEN; DO I=1,SIZE(SAVEDRN); IF(SAVEDRN(I).EQ.ILAY.OR.SAVEDRN(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF CASE ('RIV'); IF(ASSOCIATED(SAVERIV))THEN; DO I=1,SIZE(SAVERIV); IF(SAVERIV(I).EQ.ILAY.OR.SAVERIV(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF CASE ('ISG'); IF(ASSOCIATED(SAVEISG))THEN; DO I=1,SIZE(SAVEISG); IF(SAVEISG(I).EQ.ILAY.OR.SAVEISG(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF CASE ('GHB'); IF(ASSOCIATED(SAVEGHB))THEN; DO I=1,SIZE(SAVEGHB); IF(SAVEGHB(I).EQ.ILAY.OR.SAVEGHB(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF CASE ('RCH'); IF(ASSOCIATED(SAVERCH))THEN; DO I=1,SIZE(SAVERCH); IF(SAVERCH(I).EQ.ILAY.OR.SAVERCH(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF CASE ('EVT'); IF(ASSOCIATED(SAVEEVT))THEN; DO I=1,SIZE(SAVEEVT); IF(SAVEEVT(I).EQ.ILAY.OR.SAVEEVT(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF CASE ('CHD'); IF(ASSOCIATED(SAVECHD))THEN; DO I=1,SIZE(SAVECHD); IF(SAVECHD(I).EQ.ILAY.OR.SAVECHD(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF CASE ('STO'); IF(ASSOCIATED(SAVESTO))THEN; DO I=1,SIZE(SAVESTO); IF(SAVESTO(I).EQ.ILAY.OR.SAVESTO(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF CASE ('SPY'); IF(ASSOCIATED(SAVESPY))THEN; DO I=1,SIZE(SAVESPY); IF(SAVESPY(I).EQ.ILAY.OR.SAVESPY(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF CASE ('GWF'); IF(ASSOCIATED(SAVEFLX))THEN; DO I=1,SIZE(SAVEFLX); IF(SAVEFLX(I).EQ.ILAY.OR.SAVEFLX(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF CASE ('UZF'); IF(ASSOCIATED(SAVEUZF))THEN; DO I=1,SIZE(SAVEUZF); IF(SAVEUZF(I).EQ.ILAY.OR.SAVEUZF(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF CASE ('FHB'); IF(ASSOCIATED(SAVEFHB))THEN; DO I=1,SIZE(SAVEFHB); IF(SAVEFHB(I).EQ.ILAY.OR.SAVEFHB(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF END SELECT IF(LEX)THEN DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL; IDF%X(ICOL,IROW)=X(ICOL,IROW,ILAY); ENDDO; ENDDO IDF%FNAME=TRIM(ROOT)//'\BDG'//TRIM(TEXT)//'\BDG'//TRIM(TEXT)//'_'//TRIM(CDATE)//'_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(IDF,IDF%FNAME,1))STOP ENDIF ENDDO ENDIF DEALLOCATE(X) !## packages + connected flow to submodels CASE (6) IF(IBDGTYPE.GT.2)THEN WRITE(*,'(/1X,A/)') '>>> NOT SUPPORTED IMETH=1 FOR IBDGTYPE=',IBDGTYPE; STOP ENDIF READ(JU) TXT1ID1; READ(JU) TXT2ID1; READ(JU) TXT1ID2; READ(JU) TXT2ID2 READ(JU) NDAT IF(NDAT.GT.1)THEN; ALLOCATE(AUXTXT(NDAT-1)); READ(JU) (AUXTXT(I),I=1,NDAT-1); ENDIF READ(JU) NLIST IF(NLIST.GT.0)THEN ALLOCATE(ID1(NLIST),ID2(NLIST),X(NDAT,NLIST,1)) READ(JU) ((ID1(J),ID2(J),(X(I,J,1),I=1,NDAT)),J=1,NLIST) IDF%NODATA=1.0D30 IF(IBDGTYPE.EQ.1)THEN IF(TRIM(UTL_CAP(TEXT,'U')).EQ.'FLOW-JA-FACE')THEN TEXT='BDG'//ADJUSTL(TXT1ID2) ELSE IF(ISAT.EQ.0)THEN TEXT='BDG'//ADJUSTL(TXT2ID2) ELSE TEXT='BDGSAT' ENDIF ENDIF IF(NDAT.NE.1.AND.TEXT.NE.'BDGSAT')THEN WRITE(*,'(/99A)') 'READ (but not saving) ADDITIONAL ITEM(S) [',(TRIM(AUXTXT(J)),J=1,NDAT-1),'] FOR '//TRIM(TEXT) NDAT=1 ENDIF ALLOCATE(Y(NDIM1,NDIM2,ABS(NDIM3))); Y=0.0D0 CALL IMODBATCH_MF6TOIDF_FILLY(Y,SIZE(Y),ID1,NLIST,X(:,:,1),NDAT) !## process uzf ELSEIF(IBDGTYPE.EQ.2)THEN ALLOCATE(Y(IDF%NCOL,IDF%NROW,UZFNLAY)); Y=0.0D0; NDIM3=UZFNLAY DO J=1,NLIST !## take only flow from->to and not to->from IF(ID1(J).GT.ID2(J))CYCLE I=ID1(J); ILAY=UZF(I)%ILAY; IROW=UZF(I)%IROW; ICOL=UZF(I)%ICOL; Y(ICOL,IROW,ILAY)=X(1,J,1) ENDDO ENDIF DO ILAY=1,ABS(NDIM3) LEX=.FALSE. IF(IBDGTYPE.EQ.1)THEN SELECT CASE (TEXT(4:6)) CASE ('WEL'); IF(ASSOCIATED(SAVEWEL))THEN; DO I=1,SIZE(SAVEWEL); IF(SAVEWEL(I).EQ.ILAY.OR.SAVEWEL(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF CASE ('DRN'); IF(ASSOCIATED(SAVEDRN))THEN; DO I=1,SIZE(SAVEDRN); IF(SAVEDRN(I).EQ.ILAY.OR.SAVEDRN(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF CASE ('RIV'); IF(ASSOCIATED(SAVERIV))THEN; DO I=1,SIZE(SAVERIV); IF(SAVERIV(I).EQ.ILAY.OR.SAVERIV(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF CASE ('ISG'); IF(ASSOCIATED(SAVEISG))THEN; DO I=1,SIZE(SAVEISG); IF(SAVEISG(I).EQ.ILAY.OR.SAVEISG(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF CASE ('GHB'); IF(ASSOCIATED(SAVEGHB))THEN; DO I=1,SIZE(SAVEGHB); IF(SAVEGHB(I).EQ.ILAY.OR.SAVEGHB(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF CASE ('RCH'); IF(ASSOCIATED(SAVERCH))THEN; DO I=1,SIZE(SAVERCH); IF(SAVERCH(I).EQ.ILAY.OR.SAVERCH(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF CASE ('EVT'); IF(ASSOCIATED(SAVEEVT))THEN; DO I=1,SIZE(SAVEEVT); IF(SAVEEVT(I).EQ.ILAY.OR.SAVEEVT(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF CASE ('CHD'); IF(ASSOCIATED(SAVECHD))THEN; DO I=1,SIZE(SAVECHD); IF(SAVECHD(I).EQ.ILAY.OR.SAVECHD(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF !## node-property output, probably saturation CASE ('SAT'); IF(ASSOCIATED(SAVESAT))THEN; DO I=1,SIZE(SAVESAT); IF(SAVESAT(I).EQ.ILAY.OR.SAVESAT(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF CASE ('GWF'); IF(ASSOCIATED(SAVEFLX))THEN; DO I=1,SIZE(SAVEFLX); IF(SAVEFLX(I).EQ.ILAY.OR.SAVEFLX(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF CASE ('UZF'); IF(ASSOCIATED(SAVEUZF))THEN; DO I=1,SIZE(SAVEUZF); IF(SAVEUZF(I).EQ.ILAY.OR.SAVEUZF(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF END SELECT ELSEIF(IBDGTYPE.EQ.2)THEN IF(ASSOCIATED(SAVEUZF))THEN; DO I=1,SIZE(SAVEUZF); IF(SAVEUZF(I).EQ.ILAY.OR.SAVEUZF(I).EQ.-1)LEX=.TRUE.; ENDDO; ENDIF IF(ILAY.EQ.1)TEXT='BDG'//ADJUSTL(TEXT) ENDIF IF(LEX)THEN IDF%X=IDF%NODATA DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL IF(Y(ICOL,IROW,ILAY).NE.0.0D0)THEN IDF%X(ICOL,IROW)=Y(ICOL,IROW,ILAY) ENDIF ENDDO; ENDDO IDF%FNAME=TRIM(ROOT)//'\'//TRIM(TEXT)//'\'//TRIM(TEXT)//'_'//TRIM(CDATE)//'_L'//TRIM(VTOS(ILAY))//'.IDF' IF(.NOT.IDFWRITE(IDF,IDF%FNAME,1))STOP ENDIF ENDDO DEALLOCATE(ID1,ID2,X,Y) ENDIF IF(ALLOCATED(AUXTXT))DEALLOCATE(AUXTXT) CASE DEFAULT WRITE(*,'(/A,I10/)') 'Cannot distinguish IMETH type ',IMETH; STOP END SELECT ENDDO CLOSE(JU); IF(ALLOCATED(UZF))DEALLOCATE(UZF) ENDDO END SUBROUTINE IMODBATCH_MF6TOIDF !###====================================================================== SUBROUTINE IMODBATCH_MF6TOIDF_FILLY(Y,NY,ID1,NLIST,X,NDAT) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: NY,NLIST,NDAT REAL(KIND=DP_KIND),INTENT(OUT),DIMENSION(NY) :: Y REAL(KIND=DP_KIND),INTENT(IN),DIMENSION(:,:) :: X INTEGER,INTENT(IN),DIMENSION(NLIST) :: ID1 INTEGER :: I,J,IPOS Y=0.0D0 DO J=1,NDAT DO I=1,NLIST IPOS=ID1(I); Y(IPOS)=Y(IPOS)+X(J,I) ENDDO ENDDO END SUBROUTINE IMODBATCH_MF6TOIDF_FILLY !###====================================================================== SUBROUTINE IMODBATCH_XYZTOVOXEL() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: XYZFILE,OUTPUTDIR INTEGER :: IWINDOW REAL(KIND=DP_KIND) :: CELLSIZE,X1,Y1,X2,Y2,DZV,MULT TYPE(IDFOBJ) :: TOP,BOT IF(.NOT.UTL_READINITFILE('XYZFILE',LINE,IU,0))RETURN READ(LINE,*) XYZFILE; WRITE(*,'(A)') 'XYZFILE='//TRIM(XYZFILE) IF(.NOT.UTL_READINITFILE('OUTPUTDIR',LINE,IU,0))RETURN READ(LINE,*) OUTPUTDIR; WRITE(*,'(A)') 'OUTPUTDIR='//TRIM(OUTPUTDIR) IWINDOW=0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN IWINDOW=1; READ(LINE,*) X1,Y1,X2,Y2; WRITE(*,'(A,4F15.3)') 'WINDOW=',X1,Y1,X2,Y2 IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,0))RETURN READ(LINE,*) CELLSIZE; WRITE(*,'(A,F15.3)') 'CELLSIZE=',CELLSIZE ELSE CELLSIZE=0.0D0; IF(UTL_READINITFILE('CELLSIZE',LINE,IU,1))THEN READ(LINE,*) CELLSIZE; WRITE(*,'(A,F15.3)') 'CELLSIZE=',CELLSIZE ENDIF ENDIF DZV=0.0D0; IF(UTL_READINITFILE('DZV',LINE,IU,1))THEN READ(LINE,*) DZV; WRITE(*,'(A,F10.2)') 'DZV=',DZV ENDIF IF(.NOT.UTL_READINITFILE('TOPIDF',LINE,IU,0))RETURN READ(LINE,*) TOP%FNAME; WRITE(*,'(A)') 'TOPIDF='//TRIM(TOP%FNAME) IF(.NOT.UTL_READINITFILE('BOTIDF',LINE,IU,0))RETURN READ(LINE,*) BOT%FNAME; WRITE(*,'(A)') 'BOTIDF='//TRIM(BOT%FNAME) IF(.NOT.UTL_READINITFILE('MULT',LINE,IU,0))RETURN READ(LINE,*) MULT; WRITE(*,'(A)') 'MULT='//TRIM(VTOS(MULT,'G',7)) IF(.NOT.ASC2IDF_IMPORTXYZ_VOXEL(XYZFILE,OUTPUTDIR,IWINDOW,X1,Y1,X2,Y2, & CELLSIZE,DZV,TOP,BOT,MULT))RETURN END SUBROUTINE IMODBATCH_XYZTOVOXEL !###====================================================================== SUBROUTINE IMODBATCH_CREATEENSEMBLES() !###====================================================================== IMPLICIT NONE REAL(KIND=DP_KIND) :: XMIN,YMIN,XMAX,YMAX,MINVALUE,MAXVALUE,STDV,AVERAGE INTEGER :: IN_TYPE,NSIM,ILOGTRANSFORM,I TYPE(IDFOBJ) :: MEAN,STDEV CHARACTER(LEN=256) :: DIR 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.0D0; ASSF_BOT=0.0D0; ASSF_DZ=0.0D0; ASSF_NTHRESHOLD=1; ASSF_INDICATOR=0; ELLIPS_IDF%FNAME=''; ASSF_ZPLUS=0.0D0; ZONE_IDF%FNAME='' ELLIPS_IDF%IU=0; ZONE_IDF%IU=0; IWFACTOR=0; ILOGTRANSFORM=0; ELLIPS_IDF%FNAME='' XMIN=0.0D0; YMIN=0.0D0; XMAX=0.0D0; YMAX=0.0D0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) XMIN,YMIN,XMAX,YMAX; WRITE(*,'(A,4F15.3)') 'WINDOW=',XMIN,YMIN,XMAX,YMAX IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,0))RETURN READ(LINE,*) CS; WRITE(*,'(A,F10.3)') 'CELLSIZE=',CS ENDIF ALLOCATE(XYZFNAMES(2)); XYZFNAMES='' IF(.NOT.UTL_READINITFILE('NSIM',LINE,IU,0))RETURN READ(LINE,*) NSIM; WRITE(*,'(A,I10)') 'NSIM=',NSIM IF(UTL_READINITFILE('RANGE',LINE,IU,1))READ(LINE,*) RANGE WRITE(*,'(A,F10.2)') 'RANGE=',RANGE IF(UTL_READINITFILE('LOGTRANSFORM',LINE,IU,1))THEN READ(LINE,*) ILOGTRANSFORM WRITE(*,'(A,I10)') 'LOGTRANSFORM=',ILOGTRANSFORM ENDIF !## read prior mean/stdev IF(UTL_READINITFILE('MEANFILE',LINE,IU,1))THEN READ(LINE,*) IDFFILE; WRITE(*,'(A)') 'MEANFILE='//TRIM(IDFFILE) !## points from idf files IF(.NOT.UTL_READINITFILE('STDEVIDF',LINE,IU,0))RETURN READ(LINE,*) STDEVIDF; WRITE(*,'(A)') 'STDEVIDF='//TRIM(STDEVIDF) !## read the mean/stdev again IF(.NOT.IDFREAD(MEAN,IDFFILE,1))STOP !## error standard-deviation (s=sqrt(variance)) - used as parameter variance=s^2 CALL IDFCOPY(MEAN,STDEV) IF(.NOT.IDFREADSCALE(STDEVIDF,STDEV,2,1,0.0D0,0))STOP ELSE IF(UTL_READINITFILE('IPFFILE',LINE,IU,1))THEN READ(LINE,*) XYZFNAMES(1); WRITE(*,'(A)') 'IPFFILE='//TRIM(XYZFNAMES(1)); IN_TYPE=2 IF(.NOT.UTL_READINITFILE('IDFFILE',LINE,IU,0))RETURN READ(LINE,*) IDFFILE; WRITE(*,'(A)') 'IDFFILE='//TRIM(IDFFILE) !## points from idf files IF(.NOT.UTL_READINITFILE('STDEVIDF',LINE,IU,0))RETURN READ(LINE,*) STDEVIDF; WRITE(*,'(A)') 'STDEVIDF='//TRIM(STDEVIDF) IF(.NOT.UTL_READINITFILE('KTYPE',LINE,IU,0))RETURN READ(LINE,*) KTYPE; WRITE(*,'(A,I10)') 'KTYPE=',KTYPE 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.0D0)THEN WRITE(*,'(/A/)') 'It is not allowed to have a NUGGET value of less than zero'; STOP ENDIF IF(UTL_READINITFILE('NODATA',LINE,IU,1))READ(LINE,*) NODATA WRITE(*,'(A,F10.2)') 'NODATA=',NODATA IF(.NOT.UTL_READINITFILE('IGRIDFUNC',LINE,IU,0))RETURN READ(LINE,*) IGRIDFUNC; WRITE(*,'(A,I2)') 'GRIDFUNC=',IGRIDFUNC IF(ABS(IGRIDFUNC).NE.6)STOP 'IGRIDFUNC NEED TO BE -6 (SK) OR 6 (OK)' IF(UTL_READINITFILE('COINCIDENT',LINE,IU,1))THEN READ(LINE,*) COINCIDENTDIST; WRITE(*,*) 'COINCIDENT=',COINCIDENTDIST COINCIDENT=1 ENDIF PNTSEARCH=0; IF(UTL_READINITFILE('PNTSEARCH',LINE,IU,1))READ(LINE,*) PNTSEARCH WRITE(*,'(A,I10)') 'PNTSEARCH=',PNTSEARCH MAXPNT=0 IF(PNTSEARCH.EQ.1)THEN IF(UTL_READINITFILE('MAXPNT',LINE,IU,1))READ(LINE,*) MAXPNT WRITE(*,'(A,I10)') 'MAXPNT=',MAXPNT IQUADRANT=0; IF(UTL_READINITFILE('IQUADRANT',LINE,IU,1))READ(LINE,*) IQUADRANT WRITE(*,'(A,I10)') 'IQUADRANT=',IQUADRANT IF(IQUADRANT.EQ.0)THEN IF(UTL_READINITFILE('ZONE_IDF',LINE,IU,1))READ(LINE,'(A)') ZONE_IDF%FNAME IF(TRIM(ZONE_IDF%FNAME).NE.'')WRITE(*,'(A)') 'ZONE_IDF='//TRIM(ZONE_IDF%FNAME) DO I=1,3 IF(UTL_READINITFILE('ELLIPS_ANGLE'//TRIM(VTOS(I)),LINE,IU,1))READ(LINE,'(A)') ELLIPS_IDF(I,1)%FNAME IF(TRIM(ELLIPS_IDF(I,1)%FNAME).NE.'')WRITE(*,'(A)') 'ELLIPS_ANGLE'//TRIM(VTOS(I))//'='//TRIM(ELLIPS_IDF(I,1)%FNAME) IF(UTL_READINITFILE('ELLIPS_RANGE'//TRIM(VTOS(I)),LINE,IU,1))READ(LINE,'(A)') ELLIPS_IDF(I,2)%FNAME IF(TRIM(ELLIPS_IDF(I,2)%FNAME).NE.'')WRITE(*,'(A)') 'ELLIPS_RANGE'//TRIM(VTOS(I))//'='//TRIM(ELLIPS_IDF(I,2)%FNAME) ENDDO ENDIF ENDIF !## perform kriging to get stdev spatially IF(.NOT.ASC2IDF_INT_MAIN(1,1,XMIN,YMIN,XMAX,YMAX,IN_TYPE,0))STOP !## read the mean/stdev again IF(.NOT.IDFREAD(MEAN,IDFFILE,1))STOP !## error standard-deviation (s=sqrt(variance)) - used as parameter variance=s^2 IF(.NOT.IDFREAD(STDEV,STDEVIDF,1))STOP !## create mean/stdev from min- and max values ELSE IF(.NOT.UTL_READINITFILE('MINVALUE',LINE,IU,0))RETURN; READ(LINE,*) MINVALUE WRITE(*,'(A,F10.2)') 'MINVALUE=',MINVALUE IF(.NOT.UTL_READINITFILE('MAXVALUE',LINE,IU,0))RETURN; READ(LINE,*) MAXVALUE WRITE(*,'(A,F10.2)') 'MAXVALUE=',MAXVALUE MEAN%XMIN=XMIN; MEAN%XMAX=XMAX; MEAN%YMIN=YMIN; MEAN%YMAX=YMAX; MEAN%DX=CS; MEAN%DY=MEAN%DX; MEAN%ITYPE=4 CALL UTL_IDFSNAPTOGRID_LLC(MEAN%XMIN,MEAN%XMAX,MEAN%YMIN,MEAN%YMAX,MEAN%DX,MEAN%DX,MEAN%NCOL,MEAN%NROW,LLC=.TRUE.) IF(.NOT.IDFALLOCATEX(MEAN))STOP CALL IDFCOPY(MEAN,STDEV) IF(.NOT.IDFALLOCATEX(STDEV))STOP IF(ILOGTRANSFORM.EQ.0)THEN AVERAGE=(MAXVALUE+MINVALUE)/2.0D0 STDV =(MAXVALUE-MINVALUE)/4.0D0 ELSEIF(ILOGTRANSFORM.EQ.1)THEN AVERAGE=(LOG(ABS(MAXVALUE))+LOG(ABS(MINVALUE)))/2.0D0 STDV =(LOG(ABS(MAXVALUE))-LOG(ABS(MINVALUE)))/4.0D0 ELSEIF(ILOGTRANSFORM.EQ.2)THEN AVERAGE=(LOG10(ABS(MAXVALUE))+LOG10(ABS(MINVALUE)))/2.0D0 STDV =(LOG10(ABS(MAXVALUE))-LOG10(ABS(MINVALUE)))/4.0D0 ENDIF MEAN%X=AVERAGE; MEAN%NODATA =-999.99D0 STDEV%X=STDV; STDEV%NODATA=-999.99D0 WRITE(*,*) 'AVERAGE,STDEV',AVERAGE,STDV ENDIF ENDIF !IF()THEN ! DO IROW=1,STDEV%NROW; DO ICOL=1,STDEV%NCOL ! IF(STDEV%X(ICOL,IROW).NE.STDEV%NODATA)STDEV%X(ICOL,IROW)=LOG10(STDEV%X(ICOL,IROW)) ! IF(MEAN%X(ICOL,IROW) .NE.MEAN%NODATA) MEAN%X(ICOL,IROW) =LOG10(MEAN%X(ICOL,IROW)) ! ENDDO; ENDDO !ENDIF PEST%PE_CHOLESKY=0 IF(.NOT.UTL_READINITFILE('OUTPUTFOLDER',LINE,IU,0))RETURN READ(LINE,*) DIR; WRITE(*,'(A)') 'OUTPUTFOLDER='//TRIM(DIR) CALL IMODBATCH_CREATEENSEMBLES_CHOLESKY(STDEV,MEAN,DIR,RANGE,NSIM,'ENSEMBLE',ILOGTRANSFORM) CALL IDFDEALLOCATEX(STDEV); CALL IDFDEALLOCATEX(MEAN) END SUBROUTINE IMODBATCH_CREATEENSEMBLES !###====================================================================== SUBROUTINE IMODBATCH_XYZTOIDF_MAIN() !###====================================================================== IMPLICIT NONE INTEGER :: I,J,K,N,IN_TYPE,JU,M,IDATE,DDATE,IOS,ICOL,IROW,JF,ID,KSUM,ILAY,NLAYVAL,NBLNFILE,MAXPOINT,IPUZZLE INTEGER(KIND=DP_KIND) :: SDATE,EDATE CHARACTER(LEN=3) :: EXT CHARACTER(LEN=52) :: GRIDFUNC,WC,ROOT CHARACTER(LEN=256) :: FNAMEVAL,SNAME REAL(KIND=DP_KIND) :: XMIN,YMIN,XMAX,YMAX,Z1,Z2,MF,KHVAL,VCVAL TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: VOXEL REAL(KIND=DP_KIND),POINTER,DIMENSION(:) :: DZVAL=>NULL() REAL(KIND=DP_KIND),POINTER,DIMENSION(:) :: XYZRANGE=>NULL() IBLNTYPE=0; NBLNFILE=0; COINCIDENT=0; TRIMCONF_IDF=1; MAXPOINT=0; IPUZZLE=0 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 IF(UTL_READINITFILE('MASKIDF',LINE,IU,1))THEN READ(LINE,*) XYZFNAMES(2); WRITE(*,'(A)') 'MASKIDF='//TRIM(XYZFNAMES(2)) ENDIF ENDIF IF(UTL_READINITFILE('GENFILE',LINE,IU,1))THEN READ(LINE,*) XYZFNAMES(1); WRITE(*,'(A)') 'GENFILE='//TRIM(XYZFNAMES(1)); IN_TYPE=4 ENDIF ENDIF XMIN=0.0D0; YMIN=0.0D0; XMAX=0.0D0; YMAX=0.0D0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) XMIN,YMIN,XMAX,YMAX; WRITE(*,'(A,4F15.3)') 'WINDOW=',XMIN,YMIN,XMAX,YMAX ENDIF NODATA=-999.99D0 IF(UTL_READINITFILE('NODATA',LINE,IU,1))READ(LINE,*) NODATA WRITE(*,'(A,F10.2)') 'NODATA=',NODATA 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.0D0; ASSF_BOT=0.0D0; ASSF_DZ=0.0D0; ASSF_NTHRESHOLD=1; ASSF_INDICATOR=0; ELLIPS_IDF%FNAME=''; ASSF_ZPLUS=0.0D0; ZONE_IDF%FNAME='' ELLIPS_IDF%IU=0; ZONE_IDF%IU=0; IWFACTOR=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 IF(UTL_READINITFILE('IWCOL',LINE,IU,1)) READ(LINE,*) IWCOL WRITE(*,'(A,I10)') 'IXCOL=',IXCOL WRITE(*,'(A,I10)') 'IYCOL=',IYCOL WRITE(*,'(A,I10)') 'IZCOL=',IZCOL WRITE(*,'(A,I10)') 'IWCOL=',IWCOL !## apply weight-column - how IF(IWCOL.GT.0)THEN IF(UTL_READINITFILE('IWFACTOR',LINE,IU,1)) READ(LINE,*) IWFACTOR SELECT CASE (IWFACTOR) CASE (1); WRITE(*,'(A,I1,A)') 'IWFACTOR=',IWFACTOR,' 1-(3-MIN(3,LOG(W))' CASE DEFAULT; WRITE(*,'(/A/)') 'UNKNOWN WEIGHT PROCEDURE'; STOP END SELECT ENDIF !## 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_IDEPTH',LINE,IU,0))RETURN READ(LINE,*) ASSF_IDEPTH; WRITE(*,'(A,I10)') 'ASSF_IDEPTH=',ASSF_IDEPTH SELECT CASE (ASSF_IDEPTH) CASE (0,1,2,3) IF(.NOT.UTL_READINITFILE('ASSF_COLUMN',LINE,IU,0))RETURN READ(LINE,*) ASSF_COLUMN; WRITE(*,'(A,I3)') 'ASSF_COLUMN=',ASSF_COLUMN !## always use column=1 for these types CASE DEFAULT ASSF_COLUMN=1 END SELECT 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','T') CASE DEFAULT WRITE(*,'(A)') 'SPECIFY ASSF_DDATE TO BE D,W,M,Y,T' END SELECT WRITE(*,'(A,A1)') 'ASSF_DDATE=',ASSF_CDDATE ENDIF ASSF_STARTDATE=UTL_IDATETOJDATE(ASSF_STARTDATE) ASSF_ENDDATE =UTL_IDATETOJDATE(ASSF_ENDDATE) ALLOCATE(ASSF_THRESHOLD(1)); ASSF_THRESHOLD='' ALLOCATE(ASSF_KH_THRESHOLD(1)); ASSF_KH_THRESHOLD=0.0D0 ALLOCATE(ASSF_KV_THRESHOLD(1)); ASSF_KV_THRESHOLD=0.0D0 ELSE WRITE(*,'(/A/)') '>>> Depths are processed <<<' IF(ASSF_IDEPTH.EQ.1)THEN WRITE(*,'(/A/)') '>>> VOXEL model is created with constant elevations <<<' 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.UTL_READPOINTER(IU,I,DZVAL,'ASSF_DZ',0,EXCLVALUE=0.0D0))RETURN DO I=1,SIZE(DZVAL) IF(DZVAL(I).LE.0.0D0)THEN LINE='DZ('//TRIM(VTOS(I))//')='//TRIM(VTOS(DZVAL(I),'F',3)) WRITE(*,'(A)') TRIM(LINE)//' which is not allowed' ENDIF ENDDO IF(UTL_READINITFILE('ASSF_ZPLUS',LINE,IU,1))READ(LINE,*) ASSF_ZPLUS WRITE(*,'(A,F10.2)') 'ASSF_ZPLUS=',ASSF_ZPLUS 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) IF(UTL_READINITFILE('TRIMCONF_IDF',LINE,IU,1))READ(LINE,*) TRIMCONF_IDF WRITE(*,'(A,I1)') 'TRIMCONF_IDF',TRIMCONF_IDF ALLOCATE(ASSF_THRESHOLD(1)); ASSF_THRESHOLD='' ALLOCATE(ASSF_KH_THRESHOLD(1)); ASSF_KH_THRESHOLD=0.0D0 ALLOCATE(ASSF_KV_THRESHOLD(1)); ASSF_KV_THRESHOLD=0.0D0 ELSEIF(ASSF_IDEPTH.EQ.2)THEN WRITE(*,'(/A/)') '>>> VOXEL model is created with spatial elevations <<<' IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) NLAYVAL; WRITE(*,'(A,I3)') 'NLAY=',NLAYVAL ALLOCATE(INT_IDF(NLAYVAL)) DO ILAY=1,NLAYVAL IF(.NOT.UTL_READINITFILE('INT_L'//TRIM(VTOS(ILAY)),LINE,IU,0))RETURN READ(LINE,*) INT_IDF(ILAY)%FNAME; LINE='INT_L'//TRIM(VTOS(ILAY)); WRITE(*,'(A,I3)') TRIM(LINE)//'='//TRIM(INT_IDF(ILAY)%FNAME) ENDDO ALLOCATE(ASSF_THRESHOLD(1)); ASSF_THRESHOLD='' ALLOCATE(ASSF_KH_THRESHOLD(1)); ASSF_KH_THRESHOLD=0.0D0 ALLOCATE(ASSF_KV_THRESHOLD(1)); ASSF_KV_THRESHOLD=0.0D0 !## interface(3)/thickness(4) from boreholes interpolated ELSEIF(ASSF_IDEPTH.EQ.3.OR.ASSF_IDEPTH.EQ.4)THEN IF(ASSF_IDEPTH.EQ.3)WRITE(*,'(/A/)') '>>> 3D model is created per interface ELEVATION <<<' IF(ASSF_IDEPTH.EQ.4)WRITE(*,'(/A/)') '>>> 3D model is created per interface THICKNESS <<<' IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) NLAYVAL IF(NLAYVAL.GT.0)THEN WRITE(*,'(A,I3)') 'NLAY IS 1 UP TO ',NLAYVAL ELSEIF(NLAYVAL.LT.0)THEN WRITE(*,'(A,I3)') 'NLAY IS ',ABS(NLAYVAL) ELSE STOP 'NLAY NEED TO BE <>0' ENDIF ENDIF !## indicator ASSF_INDICATOR=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 ASSF_NTHRESHOLD=0; READ(LINE,*) ASSF_NTHRESHOLD; WRITE(*,*) 'NTHRESHOLD=',ASSF_NTHRESHOLD IF(ALLOCATED(ASSF_THRESHOLD ))DEALLOCATE(ASSF_THRESHOLD ) IF(ALLOCATED(ASSF_KH_THRESHOLD))DEALLOCATE(ASSF_KH_THRESHOLD) IF(ALLOCATED(ASSF_KV_THRESHOLD))DEALLOCATE(ASSF_KV_THRESHOLD) ALLOCATE(ASSF_THRESHOLD(ASSF_NTHRESHOLD)); ASSF_THRESHOLD='' ALLOCATE(ASSF_KH_THRESHOLD(ASSF_NTHRESHOLD)); ASSF_KH_THRESHOLD=0.0D0 ALLOCATE(ASSF_KV_THRESHOLD(ASSF_NTHRESHOLD)); ASSF_KV_THRESHOLD=0.0D0 DO I=1,ASSF_NTHRESHOLD IF(.NOT.UTL_READINITFILE('THRESHOLD'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) ASSF_THRESHOLD(I); WRITE(*,*) 'THRESHOLD'//TRIM(VTOS(I))//'=',ASSF_THRESHOLD(I) IF(.NOT.UTL_READINITFILE('KH_THRESHOLD'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) ASSF_KH_THRESHOLD(I); WRITE(*,*) 'KH_THRESHOLD'//TRIM(VTOS(I))//'=',ASSF_KH_THRESHOLD(I) IF(.NOT.UTL_READINITFILE('KV_THRESHOLD'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) ASSF_KV_THRESHOLD(I); WRITE(*,*) 'KV_THRESHOLD'//TRIM(VTOS(I))//'=',ASSF_KV_THRESHOLD(I) ENDDO KSUM=0; IF(UTL_READINITFILE('KSUM',LINE,IU,1))READ(LINE,*) KSUM WRITE(*,*) 'KSUM=',KSUM ELSE IF(.NOT.ALLOCATED(ASSF_THRESHOLD))THEN ALLOCATE(ASSF_THRESHOLD(ASSF_NTHRESHOLD)); ASSF_THRESHOLD='' ENDIF ENDIF ENDIF ENDIF !## genfile ELSEIF(IN_TYPE.EQ.4)THEN IF(UTL_READINITFILE('IPUZZLE',LINE,IU,1))THEN READ(LINE,*) PBMAN%IPUZZLE; WRITE(*,'(A)') 'IPUZZLE='//TRIM(VTOS(PBMAN%IPUZZLE)) ENDIF IF(UTL_READINITFILE('IZCOL',LINE,IU,1))THEN READ(LINE,*) IZCOL; WRITE(*,'(A,I10)') 'IZCOL=',IZCOL ENDIF 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 ILOG=0; IF(UTL_READINITFILE('ILOG',LINE,IU,1))THEN READ(LINE,*) ILOG; WRITE(*,'(A,I10)') 'ILOG=',ILOG 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 CASE ('SUM') ; IGRIDFUNC= 9 CASE DEFAULT WRITE(*,'(/A/)') '>>> Incorrect GRIDFUNC given <<<' END SELECT IF(IGRIDFUNC.NE.7)THEN IF(IN_TYPE.NE.0)THEN IF(.NOT.UTL_READINITFILE('IDFFILE',LINE,IU,0))RETURN READ(LINE,*) IDFFILE; WRITE(*,'(A)') 'IDFFILE='//TRIM(IDFFILE) !## POINTS FROM IDF FILES ENDIF 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.OR.IGRIDFUNC.EQ.9))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,SUM,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) IF(.NOT.UTL_READINITFILE('KTYPE',LINE,IU,0))RETURN READ(LINE,*) KTYPE; WRITE(*,'(A,I10)') 'KTYPE=',KTYPE IF(UTL_READINITFILE('COINCIDENT',LINE,IU,1))THEN READ(LINE,*) COINCIDENTDIST; WRITE(*,*) 'COINCIDENT=',COINCIDENTDIST COINCIDENT=1 ENDIF 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.0D0)THEN WRITE(*,'(/A/)') 'It is not allowed to have a NUGGET value of less than zero'; STOP ENDIF PNTSEARCH=0; IF(UTL_READINITFILE('PNTSEARCH',LINE,IU,1))READ(LINE,*) PNTSEARCH WRITE(*,'(A,I10)') 'PNTSEARCH=',PNTSEARCH MAXPNT=0 IF(PNTSEARCH.EQ.1)THEN IF(UTL_READINITFILE('MAXPNT',LINE,IU,1))READ(LINE,*) MAXPNT WRITE(*,'(A,I10)') 'MAXPNT=',MAXPNT IQUADRANT=0; IF(UTL_READINITFILE('IQUADRANT',LINE,IU,1))READ(LINE,*) IQUADRANT WRITE(*,'(A,I10)') 'IQUADRANT=',IQUADRANT IF(IQUADRANT.EQ.0)THEN IF(UTL_READINITFILE('ZONE_IDF',LINE,IU,1))READ(LINE,'(A)') ZONE_IDF%FNAME IF(TRIM(ZONE_IDF%FNAME).NE.'')WRITE(*,'(A)') 'ZONE_IDF='//TRIM(ZONE_IDF%FNAME) DO I=1,3 IF(UTL_READINITFILE('ELLIPS_ANGLE'//TRIM(VTOS(I)),LINE,IU,1))READ(LINE,'(A)') ELLIPS_IDF(I,1)%FNAME IF(TRIM(ELLIPS_IDF(I,1)%FNAME).NE.'')WRITE(*,'(A)') 'ELLIPS_ANGLE'//TRIM(VTOS(I))//'='//TRIM(ELLIPS_IDF(I,1)%FNAME) IF(UTL_READINITFILE('ELLIPS_RANGE'//TRIM(VTOS(I)),LINE,IU,1))READ(LINE,'(A)') ELLIPS_IDF(I,2)%FNAME IF(TRIM(ELLIPS_IDF(I,2)%FNAME).NE.'')WRITE(*,'(A)') 'ELLIPS_RANGE'//TRIM(VTOS(I))//'='//TRIM(ELLIPS_IDF(I,2)%FNAME) ENDDO ENDIF ENDIF !## used to reset maxpnt each cycle if needed MAXPOINT=MAXPNT !## no usage of ellipses, so specify range IF(TRIM(ELLIPS_IDF(1,1)%FNAME).EQ.'')THEN IF(.NOT.UTL_READPOINTER(IU,I,XYZRANGE,'RANGE',0))RETURN !,EXCLVALUE=0.0D0))RETURN DO I=1,SIZE(XYZRANGE) IF(XYZRANGE(I).LT.0.0D0)THEN LINE='RANGE('//TRIM(VTOS(I))//')='//TRIM(VTOS(XYZRANGE(I),'F',3)) WRITE(*,'(A)') TRIM(LINE)//' which is not allowed' ELSEIF(XYZRANGE(I).EQ.0.0D0)THEN LINE='RANGE('//TRIM(VTOS(I))//')='//TRIM(VTOS(XYZRANGE(I),'F',3)) WRITE(*,'(A)') TRIM(LINE)//' yield automatic determination of range' ENDIF ENDDO ELSE ALLOCATE(XYZRANGE(1)); XYZRANGE=0.0D0 ENDIF IF(.NOT.UTL_READINITFILE('STDEVIDF',LINE,IU,0))RETURN READ(LINE,*) STDEVIDF; WRITE(*,'(A)') 'STDEVIDF='//TRIM(STDEVIDF) CASE (7) IF(UTL_READINITFILE('LAGINTERVAL',LINE,IU,1))THEN READ(LINE,*) LAGINTERVAL; WRITE(*,*) 'LAGINTERVAL=',LAGINTERVAL ELSE WRITE(*,*) 'LAGINTERVAL IS COMPUTED AUTOMATICALLY BASED ON THE DATA' ENDIF IF(UTL_READINITFILE('LAGDISTANCE',LINE,IU,1))THEN READ(LINE,*) LAGDISTANCE; WRITE(*,*) 'LAGDISTANCE=',LAGDISTANCE ELSE WRITE(*,*) 'LAGDISTANCE IS COMPUTED AUTOMATICALLY BASED ON THE DATA' ENDIF CASE (8) MXITER2=50 !## inner (linear system) HCLOSE=0.01D0 RCLOSE=10000.0D0 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('NBLNFILE',LINE,IU,1))THEN READ(LINE,*) NBLNFILE; WRITE(*,'(A)') 'NBLNFILE='//TRIM(VTOS(NBLNFILE)) ALLOCATE(BLNFILE(NBLNFILE),FCTBLNFILE(NBLNFILE)); FCTBLNFILE=0.0 DO I=1,NBLNFILE IF(.NOT.UTL_READINITFILE('BLNFILE'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) BLNFILE(I); WRITE(*,'(A)') 'BLNFILE'//TRIM(VTOS(I))//'='//TRIM(BLNFILE(I)) IF(UTL_READINITFILE('FCTBLNFILE'//TRIM(VTOS(I)),LINE,IU,1))THEN READ(LINE,*) FCTBLNFILE(I); WRITE(*,'(A)') 'FCTBLNFILE'//TRIM(VTOS(I))//'='//TRIM(VTOS(FCTBLNFILE(I),'G',5)) ENDIF ENDDO IF(UTL_READINITFILE('IBLNTYPE',LINE,IU,1))READ(LINE,*) IBLNTYPE WRITE(*,'(A)') 'IBLNTYPE='//TRIM(VTOS(IBLNTYPE)) ENDIF DDATE=0 FNAMEVAL=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.3.OR.ASSF_IDEPTH.EQ.4)THEN IF(NLAYVAL.LT.0)IINT_IDF=ABS(NLAYVAL)-1 ENDIF 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(DZVAL))THEN ASSF_DZ=DZVAL(ID) ELSE ASSF_DZ=DZVAL(SIZE(DZVAL)) ENDIF ASSF_BOT=MAX(Z2,ASSF_TOP-ASSF_DZ) ELSE !IF(ASSF_IDEPTH.EQ.2)THEN IINT_IDF=IINT_IDF+1 ENDIF !## kriging IF(ABS(IGRIDFUNC).EQ.6)THEN IF(ID.LE.SIZE(XYZRANGE))THEN RANGE=XYZRANGE(ID) ELSE RANGE=XYZRANGE(SIZE(XYZRANGE)) ENDIF ENDIF !## startdate IF(ASSF_COLUMN.NE.0)THEN SELECT CASE (ASSF_IDEPTH) CASE (0) IDFFILE =TRIM(FNAMEVAL)//'_'//TRIM(VTOS(UTL_JDATETOIDATE(IDATE)))//'.IDF' STDEVIDF=TRIM(SNAME)//'_'//TRIM(VTOS(UTL_JDATETOIDATE(IDATE)))//'.IDF' CASE (1) IF(ASSF_INDICATOR.GT.0)THEN IDFFILE =TRIM(FNAMEVAL)//'_'//TRIM(ASSF_THRESHOLD(I))//'_T'//TRIM(VTOS(ASSF_TOP,'F',2))//'.IDF' STDEVIDF=TRIM(SNAME)//'_'//TRIM(ASSF_THRESHOLD(I))//'_T'//TRIM(VTOS(ASSF_TOP,'F',2))//'.IDF' ELSE IDFFILE =TRIM(FNAMEVAL)//'_T'//TRIM(VTOS(ASSF_TOP,'F',2))//'.IDF' STDEVIDF=TRIM(SNAME)//'_T'//TRIM(VTOS(ASSF_TOP,'F',2))//'.IDF' ENDIF CASE (2) IF(ASSF_INDICATOR.GT.0)THEN IDFFILE =TRIM(FNAMEVAL)//'_'//TRIM(ASSF_THRESHOLD(I))//'_INT'//TRIM(VTOS(IINT_IDF))//'.IDF' STDEVIDF=TRIM(SNAME)//'_'//TRIM(ASSF_THRESHOLD(I))//'_INT'//TRIM(VTOS(IINT_IDF))//'.IDF' ELSE IDFFILE =TRIM(FNAMEVAL)//'_INT'//TRIM(VTOS(IINT_IDF))//'.IDF' STDEVIDF=TRIM(SNAME)//'_INT'//TRIM(VTOS(IINT_IDF))//'.IDF' ENDIF CASE (3) IDFFILE =TRIM(FNAMEVAL)//'_INT'//TRIM(VTOS(IINT_IDF))//'.IDF' STDEVIDF=TRIM(SNAME)//'_INT'//TRIM(VTOS(IINT_IDF))//'.IDF' CASE (4) IDFFILE =TRIM(FNAMEVAL)//'_THK'//TRIM(VTOS(IINT_IDF))//'.IDF' STDEVIDF=TRIM(SNAME)//'_THK'//TRIM(VTOS(IINT_IDF))//'.IDF' END SELECT ENDIF !## reset max.point per cycle MAXPNT=MAXPOINT IF(.NOT.ASC2IDF_INT_MAIN(1,1,XMIN,YMIN,XMAX,YMAX,IN_TYPE,IPUZZLE))THEN; ENDIF SELECT CASE (ASSF_IDEPTH) CASE (0) IDATE=IDATE+DDATE IF(IDATE.GT.EDATE)EXIT CASE (1) IF(ASSF_BOT.LE.Z2)EXIT ASSF_TOP=ASSF_TOP-ASSF_DZ CASE (2) IF(IINT_IDF.EQ.NLAYVAL-1)EXIT CASE (3,4) IF(IINT_IDF.EQ.ABS(NLAYVAL))EXIT END SELECT 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(DZVAL))THEN ASSF_DZ=DZVAL(ID) ELSE ASSF_DZ=DZVAL(SIZE(DZVAL)) ENDIF ASSF_BOT=MAX(Z2,ASSF_TOP-ASSF_DZ) WRITE(*,'(/1X,A/)') 'Busy with voxel layer: '//TRIM(VTOS(ASSF_TOP,'F',2))//'_'//TRIM(VTOS(ASSF_BOT,'F',2)) ELSEIF(ASSF_IDEPTH.EQ.2)THEN IINT_IDF=IINT_IDF+1 WRITE(*,'(/1X,A/)') 'Busy with interface: '//TRIM(VTOS(IINT_IDF)) ENDIF DO I=1,ASSF_NTHRESHOLD IF(ASSF_IDEPTH.EQ.1)THEN IDFFILE =TRIM(FNAMEVAL)//'_'//TRIM(ASSF_THRESHOLD(I))//'_T'//TRIM(VTOS(ASSF_TOP,'F',2))//'.IDF' ELSEIF(ASSF_IDEPTH.EQ.2)THEN IDFFILE =TRIM(FNAMEVAL)//'_'//TRIM(ASSF_THRESHOLD(I))//'_INT'//TRIM(VTOS(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 !## main lithology VOXEL(ASSF_NTHRESHOLD+1)%X(ICOL,IROW)=VOXEL(ASSF_NTHRESHOLD+1)%NODATA !## permeability VOXEL(ASSF_NTHRESHOLD+2)%X(ICOL,IROW)=0.0D0 !## vertical anisotropy VOXEL(ASSF_NTHRESHOLD+3)%X(ICOL,IROW)=0.0D0 !## fraction VOXEL(ASSF_NTHRESHOLD+4)%X(ICOL,IROW)=0.0D0 !## normalize fraction to be 1.0D0 MF=0.0D0 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)=MF ENDIF ENDDO IF(MF.NE.0.0D0)MF=1.0D0/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.0D0; 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 KHVAL= VOXEL(I)%X(ICOL,IROW)*ASSF_KH_THRESHOLD(I) VOXEL(ASSF_NTHRESHOLD+2)%X(ICOL,IROW)=VOXEL(ASSF_NTHRESHOLD+2)%X(ICOL,IROW)+KHVAL !## vertical resistance per meter VCVAL=VOXEL(I)%X(ICOL,IROW)/ASSF_KV_THRESHOLD(I) VOXEL(ASSF_NTHRESHOLD+3)%X(ICOL,IROW)=VOXEL(ASSF_NTHRESHOLD+3)%X(ICOL,IROW)+VCVAL 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_KH_THRESHOLD(JF) VOXEL(ASSF_NTHRESHOLD+3)%X(ICOL,IROW)=ASSF_KV_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.0D0; VOXEL(ASSF_NTHRESHOLD+I)%BOT=0.0D0; ENDDO ENDIF !## main lithology IF(ASSF_IDEPTH.EQ.1)IDFFILE =TRIM(FNAMEVAL)//'_T'//TRIM(VTOS(ASSF_TOP,'F',2))//'_L.IDF' IF(ASSF_IDEPTH.EQ.2)IDFFILE =TRIM(FNAMEVAL)//'_INT'//TRIM(VTOS(IINT_IDF))//'_L.IDF' IF(.NOT.IDFWRITE(VOXEL(ASSF_NTHRESHOLD+1),IDFFILE,1))STOP !## permeability IF(ASSF_IDEPTH.EQ.1)IDFFILE =TRIM(FNAMEVAL)//'_T'//TRIM(VTOS(ASSF_TOP,'F',2))//'_K.IDF' IF(ASSF_IDEPTH.EQ.2)IDFFILE =TRIM(FNAMEVAL)//'_INT'//TRIM(VTOS(IINT_IDF))//'_K.IDF' IF(.NOT.IDFWRITE(VOXEL(ASSF_NTHRESHOLD+2),IDFFILE,1))STOP !## vertical anisotropy IF(ASSF_IDEPTH.EQ.1)IDFFILE =TRIM(FNAMEVAL)//'_T'//TRIM(VTOS(ASSF_TOP,'F',2))//'_A.IDF' IF(ASSF_IDEPTH.EQ.2)IDFFILE =TRIM(FNAMEVAL)//'_INT'//TRIM(VTOS(IINT_IDF))//'_A.IDF' IF(.NOT.IDFWRITE(VOXEL(ASSF_NTHRESHOLD+3),IDFFILE,1))STOP !## sum of fractions IF(ASSF_IDEPTH.EQ.1)IDFFILE =TRIM(FNAMEVAL)//'_T'//TRIM(VTOS(ASSF_TOP,'F',2))//'_F.IDF' IF(ASSF_IDEPTH.EQ.2)IDFFILE =TRIM(FNAMEVAL)//'_INT'//TRIM(VTOS(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.NLAYVAL-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(VTOS(UTL_JDATETOIDATE(IDATE))) IDFFILE=TRIM(IDFFILE)//'.IDF' XYZFNAMES(I)=TRIM(ROOT)//'\'//TRIM(XYZFNAMES(I)) EXT=XYZFNAMES(I)(INDEX(XYZFNAMES(I),'.',.TRUE.)+1:) SELECT CASE (UTL_CAP(EXT,'U')) CASE ('XYZ'); IN_TYPE=1 CASE ('IPF'); IN_TYPE=2 CASE ('IDF'); IN_TYPE=3 CASE ('GEN'); IN_TYPE=4 END SELECT IF(.NOT.ASC2IDF_INT_MAIN(1,I,XMIN,YMIN,XMAX,YMAX,IN_TYPE,IPUZZLE))THEN ENDIF ENDDO IDATE=IDATE+DDATE; IF(IDATE.GT.EDATE)EXIT ENDDO ENDIF IF(ASSOCIATED(DZVAL))DEALLOCATE(DZVAL) IF(ASSOCIATED(XYZRANGE))DEALLOCATE(XYZRANGE) IF(ALLOCATED(ASSF_THRESHOLD))DEALLOCATE(ASSF_THRESHOLD) IF(ALLOCATED(ASSF_KH_THRESHOLD))DEALLOCATE(ASSF_KH_THRESHOLD) IF(ALLOCATED(ASSF_KV_THRESHOLD))DEALLOCATE(ASSF_KV_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,DD SELECT CASE (ASSF_CDDATE) !## daily CASE ('D') DDATE=1 !## weekly CASE ('W') DDATE=7 !## monthly CASE ('M') CALL UTL_JDTOGDATE(IDATE,IY,IM,ID) DDATE=WDATEDAYSINMONTH(IY,IM) !## yearly CASE ('Y') CALL UTL_JDTOGDATE(IDATE,IY,IM,ID) DDATE=365; IF(WDATELEAPYEAR(IY))DDATE=DDATE+1 !## twice a month CASE ('T') CALL UTL_JDTOGDATE(IDATE,IY,IM,ID) IF(ID.GE.28)THEN DD=WDATEDAYSINMONTH(IY,IM); DDATE=(DD-ID)+14 ELSEIF(ID.LT.14)THEN DDATE=14-ID ELSE DDATE=28-ID ENDIF END SELECT END SUBROUTINE IMODBATCH_XYZTOIDF_GETDDATE !###====================================================================== LOGICAL FUNCTION IMODBATCH_IPFSAMPLE_MAIN(OUTIPF,ICOLS,NLAY) !###====================================================================== IMPLICIT NONE CHARACTER(LEN=*),INTENT(OUT),OPTIONAL :: OUTIPF INTEGER,INTENT(OUT),DIMENSION(:),OPTIONAL :: ICOLS INTEGER,INTENT(OUT),OPTIONAL :: NLAY CHARACTER(LEN=256),DIMENSION(3) :: FNAME INTEGER :: IXCOL,IYCOL,IACOL,ILCOL,IMCOL,NFILES,IEXCLUDE REAL(KIND=DP_KIND) :: NODATA IMODBATCH_IPFSAMPLE_MAIN=.FALSE. 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; IF(PRESENT(ICOLS))ICOLS(1)=IXCOL IYCOL=2; IF(UTL_READINITFILE('IYCOL',LINE,IU,1))READ(LINE,*) IYCOL WRITE(*,'(A,I2)') 'IYCOL=',IYCOL; IF(PRESENT(ICOLS))ICOLS(2)=IYCOL !## column for the insertion IACOL=0; IF(UTL_READINITFILE('IACOL',LINE,IU,1))READ(LINE,*) IACOL WRITE(*,'(A,I2)') 'IACOL=',IACOL; IF(PRESENT(ICOLS))ICOLS(3)=IACOL IF(PRESENT(ICOLS))THEN !## measurement column IMCOL=0; IF(UTL_READINITFILE('IMCOL',LINE,IU,1))READ(LINE,*) IMCOL WRITE(*,'(A,I2)') 'IMCOL=',IMCOL; ICOLS(4)=IMCOL !## layer column ILCOL=0; IF(UTL_READINITFILE('ILCOL',LINE,IU,1))READ(LINE,*) ILCOL WRITE(*,'(A,I2)') 'ILCOL=',ILCOL; ICOLS(5)=ILCOL ENDIF 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)) NODATA=-999.99D0 IF(UTL_READINITFILE('NODATA',LINE,IU,1))READ(LINE,*) NODATA WRITE(*,'(A)') 'NODATA='//TRIM(VTOS(NODATA,'F',7)) IEXCLUDE=0 IF(UTL_READINITFILE('IEXCLUDE',LINE,IU,1))READ(LINE,*) IEXCLUDE WRITE(*,'(A)') 'IEXCLUDE='//TRIM(VTOS(IEXCLUDE)) CALL IPFSAMPLE(FNAME(1),FNAME(2),FNAME(3),IXCOL,IYCOL,IACOL,NODATA,NFILES,IEXCLUDE) IF(PRESENT(NLAY))NLAY=NFILES IF(PRESENT(OUTIPF))OUTIPF=FNAME(2) IMODBATCH_IPFSAMPLE_MAIN=.TRUE. END FUNCTION IMODBATCH_IPFSAMPLE_MAIN !###====================================================================== SUBROUTINE IMODBATCH_IPFRESIDUAL() !###====================================================================== USE MOD_TSTAT_PAR, ONLY : IPFFILE,OUTNAME,IHCOL,IMCOL,IWCOL,ILCOL,W_TYPE, & POINTERIDF,NZONE,IZONE,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(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) IZONE(I); LINE='IZONE'//TRIM(VTOS(I))//'='//TRIM(VTOS(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(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) IPFFILE(I); LINE='IPFFILE'//TRIM(VTOS(I))//'='//TRIM(IPFFILE(I)) WRITE(*,'(A)') TRIM(LINE) W_TYPE(I)=0 IF(UTL_READINITFILE('W_TYPE'//TRIM(VTOS(I)),LINE,IU,1))THEN READ(LINE,*) W_TYPE(I) LINE='W_TYPE'//TRIM(VTOS(I))//'='//TRIM(VTOS(W_TYPE(I))); WRITE(*,'(A)') TRIM(LINE) ENDIF IWCOL(I)=3 IF(W_TYPE(I).NE.0)THEN IF(UTL_READINITFILE('IWCOL'//TRIM(VTOS(I)),LINE,IU,1))READ(LINE,*) IWCOL(I) LINE='IWCOL'//TRIM(VTOS(I))//'='//TRIM(VTOS(IWCOL(I))); WRITE(*,'(A)') TRIM(LINE) ENDIF IHCOL(I)=3 IF(UTL_READINITFILE('IHCOL'//TRIM(VTOS(I)),LINE,IU,1))THEN READ(LINE,*) IHCOL(I) LINE='IHCOL'//TRIM(VTOS(I))//'='//TRIM(VTOS(IHCOL(I))); WRITE(*,'(A)') TRIM(LINE) ENDIF IMCOL(I)=3 IF(UTL_READINITFILE('IMCOL'//TRIM(VTOS(I)),LINE,IU,1))THEN READ(LINE,*) IMCOL(I) LINE='IMCOL'//TRIM(VTOS(I))//'='//TRIM(VTOS(IMCOL(I))); WRITE(*,'(A)') TRIM(LINE) ENDIF ILCOL(I)=3 IF(UTL_READINITFILE('ILCOL'//TRIM(VTOS(I)),LINE,IU,1))THEN READ(LINE,*) ILCOL(I) LINE='ILCOL'//TRIM(VTOS(I))//'='//TRIM(VTOS(ILCOL(I))); WRITE(*,'(A)') TRIM(LINE) ENDIF ENDDO SOBSDATE=0 IF(UTL_READINITFILE('SDATE',LINE,IU,1))THEN READ(LINE,*) SOBSDATE LINE='SDATE='//TRIM(VTOS(SOBSDATE)); WRITE(*,'(A)') TRIM(LINE) ENDIF EOBSDATE=0 IF(UTL_READINITFILE('EDATE',LINE,IU,1))THEN READ(LINE,*) EOBSDATE LINE='EDATE='//TRIM(VTOS(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 USE MOD_PMANAGER_PAR, ONLY : PBMAN IMPLICIT NONE INTEGER :: I,NLAY,MLAY TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: TOP,BOT,KHV,BND TYPE(GRIDISGOBJ) :: GRIDISG CHARACTER(LEN=256) :: ISGFILE PBMAN%IFVDL=0 PBMAN%DMMFILE=0 GRIDISG%MINDEPTH=0.10D0 !'mindepth : minimal waterdepth for computing conductances (m)' GRIDISG%WDEPTH=1.0D0 ! 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=0D0; GRIDISG%EDATE=0D0; GRIDISG%DDATE=0D0 GRIDISG%ISAVE=1 GRIDISG%MAXWIDTH=250.0D0 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 MLAY=1 GRIDISG%IDIM=2; GRIDISG%XMIN=0.0D0; GRIDISG%YMIN=0.0D0; GRIDISG%XMAX=0.0D0; GRIDISG%YMAX=0.0D0 ! REQUIRED KEYWORDS IF(.NOT.UTL_READINITFILE('ISGFILE_IN',LINE,IU,0))RETURN READ(LINE,*) ISGFILE; WRITE(*,'(A)') 'ISGFILE_IN='//TRIM(ISGFILE) IF(.NOT.UTL_READINITFILE('CELL_SIZE',LINE,IU,0))RETURN READ(LINE,*) GRIDISG%CS; WRITE(*,'(A,F15.3)') 'CELL_SIZE=',GRIDISG%CS IF(.NOT.UTL_READINITFILE('NODATA',LINE,IU,0))RETURN READ(LINE,*) GRIDISG%NODATA; WRITE(*,'(A,G15.7)') 'NODATA=',GRIDISG%NODATA IF(.NOT.UTL_READINITFILE('ISAVE',LINE,IU,0))RETURN READ(LINE,*) GRIDISG%ISAVE; WRITE(*,'(A,99I1)') 'ISAVE=',GRIDISG%ISAVE IF(.NOT.UTL_READINITFILE('OUTPUTFOLDER',LINE,IU,0))RETURN READ(LINE,*) GRIDISG%ROOT; WRITE(*,'(A)') 'OUTPUTFOLDER='//TRIM(GRIDISG%ROOT) CALL UTL_CREATEDIR(GRIDISG%ROOT) ! OPTIONAL KEYWORDS IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) GRIDISG%XMIN,GRIDISG%YMIN,GRIDISG%XMAX,GRIDISG%YMAX WRITE(*,'(A,4F15.3)') '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(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 IF(GRIDISG%WDEPTH.LE.0.0D0)THEN WRITE(*,'(/1X,A/)') '>>> WDEPTH needs to be > 0.0 <<<'; STOP ENDIF WRITE(*,'(A,F15.3)') 'WDEPTH=',GRIDISG%WDEPTH GRIDISG%MINDEPTH=GRIDISG%WDEPTH ELSE IF(UTL_READINITFILE('MINDEPTH',LINE,IU,1))READ(LINE,*) GRIDISG%MINDEPTH IF(GRIDISG%MINDEPTH.LE.0.0D0)THEN WRITE(*,'(/1X,A/)') '>>> MINDEPTH needs to be > 0.0 <<<'; STOP ENDIF WRITE(*,'(A,F15.3)') 'MINDEPTH=',GRIDISG%MINDEPTH ENDIF IF(UTL_READINITFILE('MAXWIDTH',LINE,IU,1))READ(LINE,*) GRIDISG%MAXWIDTH WRITE(*,'(A,F15.3)') 'MAXWIDTH=',GRIDISG%MAXWIDTH IF(UTL_READINITFILE('POSTFIX',LINE,IU,1))READ(LINE,*) GRIDISG%POSTFIX WRITE(*,'(A)') 'POSTFIX='//TRIM(GRIDISG%POSTFIX) IF(UTL_READINITFILE('ICDIST',LINE,IU,1))READ(LINE,*) GRIDISG%ICDIST WRITE(*,'(A,99I1)') 'ICDIST=',GRIDISG%ICDIST 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; GRIDISG%SDATE=UTL_COMPLETEDATE(GRIDISG%SDATE); WRITE(*,'(A,I14)') 'SDATE=',GRIDISG%SDATE IF(.NOT.UTL_READINITFILE('EDATE',LINE,IU,0))RETURN READ(LINE,*) GRIDISG%EDATE; GRIDISG%EDATE=UTL_COMPLETEDATE(GRIDISG%EDATE); WRITE(*,'(A,I14)') '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('DMMFILE',LINE,IU,1))READ(LINE,*) PBMAN%DMMFILE WRITE(*,'(A,I1)') 'DMMFILE=',PBMAN%DMMFILE IF(PBMAN%DMMFILE.EQ.0)THEN 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 WRITE(*,'(A,I8)') 'NLAY=',NLAY IF(NLAY.GT.0)THEN MLAY=0 ALLOCATE(TOP(NLAY),BOT(NLAY),KHV(NLAY),BND(NLAY)) DO I=1,NLAY CALL IDFNULLIFY(BOT(I)); CALL IDFNULLIFY(TOP(I)); CALL IDFNULLIFY(KHV(I)); CALL IDFNULLIFY(BND(I)) IF(.NOT.UTL_READINITFILE('TOP_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) TOP(I)%FNAME; LINE='TOP_L'//TRIM(VTOS(I))//'='; WRITE(*,'(A)') TRIM(LINE)//TRIM(TOP(I)%FNAME) IF(.NOT.UTL_READINITFILE('BOT_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) BOT(I)%FNAME; LINE='BOT_L'//TRIM(VTOS(I))//'='; WRITE(*,'(A)') TRIM(LINE)//TRIM(BOT(I)%FNAME) IF(.NOT.UTL_READINITFILE('KHV_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) KHV(I)%FNAME; LINE='KHV_L'//TRIM(VTOS(I))//'='; WRITE(*,'(A)') TRIM(LINE)//TRIM(KHV(I)%FNAME) IF(.NOT.UTL_READINITFILE('BND_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) BND(I)%FNAME; LINE='BND_L'//TRIM(VTOS(I))//'='; WRITE(*,'(A)') TRIM(LINE)//TRIM(KHV(I)%FNAME) ENDDO ENDIF ENDIF ELSE GRIDISG%IEXPORT=-1 ENDIF IF(.NOT.ALLOCATED(TOP))THEN NLAY=1; ALLOCATE(TOP(NLAY),BOT(NLAY),KHV(NLAY),BND(NLAY)) DO I=1,NLAY; CALL IDFNULLIFY(BOT(I)); CALL IDFNULLIFY(TOP(I)); CALL IDFNULLIFY(KHV(I)); CALL IDFNULLIFY(BND(I)); ENDDO ENDIF IF(.NOT.ISG2GRIDMAIN(ISGFILE,1,NLAY,MLAY,TOP,BOT,KHV,BND,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)) CALL IDFDEALLOCATE(KHV,SIZE(KHV)); CALL IDFDEALLOCATE(BND,SIZE(BND)) ENDDO DEALLOCATE(TOP,BOT,KHV,BND) 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(KIND=DP_KIND) :: 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(KIND=DP_KIND),DIMENSION(11) :: R INTEGER,DIMENSION(5) :: ID REAL(KIND=DP_KIND) :: 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) !## average flow in stream QSTR=(R(1)+R(3))/2.0 !## waterlevel SHED=R(7) !## waterdepth SDEP=R(8) !## waterwidth SWID=R(9) !## 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/86400.0D0 !## 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(KIND=DP_KIND) :: 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.0D0 DATISD(I)%THCK =1.0D0 DATISD(I)%HCND =1.0D0 DATISD(I)%QFLW =0.0D0 DATISD(I)%QROF =0.0D0 DATISD(I)%PPTSW =0.0D0 DATISD(I)%ETSW =0.0D0 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_IPESTTOPARAM() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: PRJFNAME,OUTPUTFOLDER,RUNFNAME INTEGER :: ICYCLE TYPE(IDFOBJ) :: ZIDF PRJFNAME=''; IF(.NOT.UTL_READINITFILE('PRJFNAME',LINE,IU,0))RETURN READ(LINE,*) PRJFNAME; WRITE(*,'(A)') 'PRJFNAME='//TRIM(PRJFNAME) ICYCLE=-1; RUNFNAME='' IF(UTL_READINITFILE('RUNFNAME',LINE,IU,1))THEN READ(LINE,*) RUNFNAME; WRITE(*,'(A)') 'RUNFNAME='//TRIM(RUNFNAME) IF(UTL_READINITFILE('CYCLE',LINE,IU,1))THEN READ(LINE,*) ICYCLE; WRITE(*,'(A)') 'CYCLE='//TRIM(VTOS(ICYCLE)) ENDIF ENDIF OUTPUTFOLDER=''; IF(.NOT.UTL_READINITFILE('OUTPUTFOLDER',LINE,IU,0))RETURN READ(LINE,*) OUTPUTFOLDER; WRITE(*,'(A)') 'OUTPUTFOLDER='//TRIM(OUTPUTFOLDER) CALL IDFNULLIFY(ZIDF); ZIDF%XMIN=0.0D0; ZIDF%XMAX=0.0D0; ZIDF%YMIN=0.0D0; ZIDF%YMAX=0.0D0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) ZIDF%XMIN,ZIDF%YMIN,ZIDF%XMAX,ZIDF%YMAX WRITE(*,'(A,4F15.3)') 'WINDOW=',ZIDF%XMIN,ZIDF%YMIN,ZIDF%XMAX,ZIDF%YMAX IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,0))RETURN READ(LINE,*) ZIDF%DX; WRITE(*,'(A,4F15.3)') 'CELLSIZE=',ZIDF%DX; ZIDF%DY=ZIDF%DX CALL UTL_IDFSNAPTOGRID_LLC(ZIDF%XMIN,ZIDF%XMAX,ZIDF%YMIN,ZIDF%YMAX,ZIDF%DX,ZIDF%DY,ZIDF%NCOL,ZIDF%NROW,LLC=.TRUE.) IF(.NOT.IDFALLOCATEX(ZIDF))STOP ELSEIF(UTL_READINITFILE('ZONEIDF',LINE,IU,1))THEN ZIDF%FNAME=''; IF(.NOT.UTL_READINITFILE('ZONEIDF',LINE,IU,0))RETURN READ(LINE,*) ZIDF%FNAME; WRITE(*,'(A)') 'ZONEIDF='//TRIM(ZIDF%FNAME) IF(.NOT.IDFREAD(ZIDF,ZIDF%FNAME,1))THEN; ENDIF; IF(ZIDF%IU.GT.0)CLOSE(ZIDF%IU) ENDIF CALL PMANAGER_UTL_IPESTTOPARAM_CALC(PRJFNAME,OUTPUTFOLDER,ZIDF,RUNFNAME,ICYCLE) END SUBROUTINE IMODBATCH_IPESTTOPARAM !###====================================================================== SUBROUTINE IMODBATCH_IFFCROSSSECTION() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: IFFNAME,GENNAME,IPFNAME CHARACTER(LEN=256) :: LINE INTEGER :: IOS,NC,I,J,K,N,IPOL,ISEG,ISTATUS,JU,NCPOINTS REAL(KIND=DP_KIND) :: XINTER,YINTER,ZINTER !## read function keywords IF(.NOT.UTL_READINITFILE('IFFNAME',LINE,IU,0))RETURN READ(LINE,*) IFFNAME; WRITE(*,'(A)') 'IFFNAME='//TRIM(IFFNAME) IF(.NOT.UTL_READINITFILE('GENNAME',LINE,IU,0))RETURN READ(LINE,*) GENNAME; WRITE(*,'(A)') 'GENNAME='//TRIM(GENNAME) IF(.NOT.UTL_READINITFILE('IPFNAME',LINE,IU,0))RETURN READ(LINE,*) IPFNAME; WRITE(*,'(A)') 'IPFNAME='//TRIM(IPFNAME) !## allocate and open IFF IU=UTL_GETUNIT() CALL OSD_OPEN(IU,FILE=IFFNAME,STATUS='OLD',FORM='FORMATTED',ACTION='READ,DENYWRITE',IOSTAT=IOS) IF(IOS.NE.0) RETURN READ(IU,*) NC ; N=NC-5 ALLOCATE(IFF(2)) DO I=1,SIZE(IFF); NULLIFY(IFF(I)%XVAL); ALLOCATE(IFF(I)%XVAL(N)); ENDDO !## read IFF attributes DO I=1,NC; READ(IU,*); END DO !## allocate and open GEN CALL POLYGON1INIT() CALL POLYGON1SAVELOADSHAPE(ID_LOADSHAPE,GENNAME,'GEN') JU=UTL_GETUNIT() CALL OSD_OPEN(JU,FILE=IPFNAME,STATUS='REPLACE',FORM='FORMATTED',ACTION='WRITE',IOSTAT=IOS,IQUESTION=1) IF(IOS.NE.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot write file:'//CHAR(13)//TRIM(IPFNAME),'Error') RETURN ENDIF DO I=1,2 !## two loops: 1) get NCPOINTS and 2) write IPF !## read IFF header REWIND(IU) ; READ(IU,*) ; DO J=1,NC; READ(IU,*); END DO IF(I.EQ.2)THEN WRITE(JU,*) NCPOINTS WRITE(JU,*) '8' WRITE(JU,*) 'XINTER' WRITE(JU,*) 'YINTER' WRITE(JU,*) 'ZINTER' WRITE(JU,*) 'PARTICLE_NUMBER' WRITE(JU,*) 'ILAY-FROM' WRITE(JU,*) 'ILAY-TO' WRITE(JU,*) 'TIME-FROM(YEARS)' WRITE(JU,*) 'TIME-TO(YEARS)' WRITE(JU,*) '0,TXT' ENDIF !## loop over all IFF points/segments IFF(2)%IPART=0; NCPOINTS=0 ; K=0 DO !## read IFF line READ(IU,*,IOSTAT=IOS) IFF(1)%IPART,IFF(1)%IL,IFF(1)%X,IFF(1)%Y,IFF(1)%Z,(IFF(1)%XVAL(J),J=1,N) IF(IOS.NE.0)EXIT K=K+1 IF(K.EQ.25)THEN WRITE(6,'(A,I)') '+Progress. Reading Particle Number: ',IFF(1)%IPART K=0 ENDIF !## same particle IF(IFF(1)%IPART.EQ.IFF(2)%IPART)THEN !## loop over all GEN segments DO IPOL=1,SHP%NPOL DO ISEG=1,SHP%POL(IPOL)%N-1 !## calculate intersection CALL DBL_IGRINTERSECTLINE(SHP%POL(IPOL)%X(ISEG) ,SHP%POL(IPOL)%Y(ISEG) , & SHP%POL(IPOL)%X(ISEG+1),SHP%POL(IPOL)%Y(ISEG+1), & IFF(1)%X,IFF(1)%Y, & IFF(2)%X,IFF(2)%Y, & XINTER,YINTER,ISTATUS) IF(ISTATUS.EQ.5)THEN NCPOINTS=NCPOINTS+1 ZINTER=IFF(1)%Z IF(IFF(2)%X-IFF(1)%X.GT.0) ZINTER=IFF(1)%Z+(IFF(2)%Z-IFF(1)%Z)*(XINTER-IFF(1)%X)/(IFF(2)%X-IFF(1)%X) !## write IPF content ! IF(I.EQ.2) WRITE(JU,'(3F12.2,I10,2I5,2F13.3)') XINTER,YINTER,ZINTER,IFF(1)%IPART, & ! IFF(2)%IL,IFF(1)%IL,IFF(2)%XVAL(1),IFF(1)%XVAL(1) !## TO=IFF(1), FROM=IFF(2) IF(I.EQ.2) WRITE(JU,'(A)') TRIM(VTOS(XINTER,'F',3))//','//TRIM(VTOS(YINTER,'F',3))//','//TRIM(VTOS(ZINTER,'F',3))//','// & TRIM(VTOS(IFF(1)%IPART))//','// & TRIM(VTOS(IFF(2)%IL))//','//TRIM(VTOS(IFF(1)%IL))//','// & !## TO=IFF(1), FROM=IFF(2) TRIM(VTOS(IFF(2)%XVAL(1),'F',3))//','//TRIM(VTOS(IFF(1)%XVAL(1),'F',3)) ENDIF ENDDO ENDDO ENDIF IFF(2)%IPART=IFF(1)%IPART IFF(2)%IL =IFF(1)%IL IFF(2)%X =IFF(1)%X IFF(2)%Y =IFF(1)%Y IFF(2)%Z =IFF(1)%Z DO J=1,N; IFF(2)%XVAL(J)=IFF(1)%XVAL(J); ENDDO ENDDO !## loop over IFF ENDDO WRITE(*,'(A)') 'Number of intersections found: '//TRIM(VTOS(NCPOINTS)) !## deallocate DO I=1,SIZE(IFF); DEALLOCATE(IFF(I)%XVAL); ENDDO; DEALLOCATE(IFF) CALL POLYGON1CLOSE() CLOSE(IU); CLOSE(JU) END SUBROUTINE IMODBATCH_IFFCROSSSECTION !###====================================================================== SUBROUTINE IMODBATCH_IMODPATH7_MAIN() !###====================================================================== IMPLICIT NONE INTEGER :: JU,KU,NLAY,I,II,J,IOS,ILAY,ID,ICONVERT,IDIRECTION,ISNK,ISRC,ITRACK,ISTOP, & IWEAK,N,NT,SROW,SCOL,EROW,ECOL,MXID,NODE,IGWF CHARACTER(LEN=256) :: MF6DIR,MODPATH7,LINE,OUTDIR,CURDIR REAL(KIND=DP_KIND) :: XLL,YLL,X1,Y1,X2,Y2,X,Y,Z,Z2,T,XD,TSTOP,V,CD,T2 REAL(KIND=DP_KIND),DIMENSION(26) :: XVAR TYPE(IDFOBJ) :: MODELIDF TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: TOP,BOT CHARACTER(LEN=256),DIMENSION(:),POINTER :: LISTNAME INTEGER,ALLOCATABLE,DIMENSION(:) :: MAXLAY REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: D CALL IDFNULLIFY(MODELIDF) CALL IOSDIRNAME(CURDIR) MF6DIR=''; IF(.NOT.UTL_READINITFILE('MF6DIR',LINE,IU,0))RETURN READ(LINE,*) MF6DIR !## change local dir to global dir IF(MF6DIR(2:2).NE.':')MF6DIR=TRIM(CURDIR)//'\'//TRIM(MF6DIR) WRITE(*,'(A)') 'MF6DIR='//TRIM(MF6DIR) OUTDIR=''; IF(UTL_READINITFILE('OUTDIR',LINE,IU,1))READ(LINE,*) OUTDIR IF(TRIM(OUTDIR).EQ.'')OUTDIR=TRIM(MF6DIR)//'\MF7' IF(OUTDIR(2:2).NE.':')OUTDIR=TRIM(CURDIR)//'\'//TRIM(OUTDIR) WRITE(*,'(A)') 'OUTDIR='//TRIM(OUTDIR) MODPATH7=''; IF(.NOT.UTL_READINITFILE('MODPATH7',LINE,IU,0))RETURN READ(LINE,*) MODPATH7; WRITE(*,'(A)') 'MODPATH7='//TRIM(MODPATH7) NSPFNAME=1; ALLOCATE(SPFNAME(NSPFNAME)); SPFNAME(1)='' IF(.NOT.UTL_READINITFILE('ISDNAME',LINE,IU,0))RETURN READ(LINE,*) SPFNAME(1); WRITE(*,'(A)') 'ISDNAME='//TRIM(SPFNAME(1)) IGWF=1; IF(UTL_READINITFILE('GWF',LINE,IU,1))THEN READ(LINE,*) IGWF; WRITE(*,'(A)') 'GWF='//TRIM(VTOS(IGWF)) ENDIF IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) NLAY; WRITE(*,'(A,I10)') 'NLAY=',NLAY ITRACK=2; IF(UTL_READINITFILE('ITRACK',LINE,IU,1))THEN READ(LINE,*) ITRACK; WRITE(*,'(A,I10)') 'ITRACK=',ITRACK ENDIF IF(ITRACK.GT.3.OR.ITRACK.LT.1)THEN WRITE(*,'(/1X,A/)') 'ITRACK NEEDS TO BE 1,2 OR 3'; STOP ENDIF IDIRECTION=1; IF(UTL_READINITFILE('IDIRECTION',LINE,IU,1))THEN READ(LINE,*) IDIRECTION; WRITE(*,'(A,I10)') 'IDIRECTION=',IDIRECTION ENDIF SELECT CASE (IDIRECTION) CASE (1); WRITE(*,'(A)') 'TRACE FORWARD' CASE (2); WRITE(*,'(A)') 'TRACE BACKWARD' CASE DEFAULT; STOP 'WRONG IDIRECTION SPECIFIED, PICK FROM 1 OR 2' END SELECT ISNK=1; ISRC=1; IWEAK=1 IF(UTL_READINITFILE('IWEAK',LINE,IU,1))THEN READ(LINE,*) IWEAK; WRITE(*,'(A10,I2)') 'IWEAK: ',IWEAK ENDIF SELECT CASE (IWEAK) CASE (1); WRITE(*,'(A)') 'PASS THROUGH WEAK SINKS' CASE (2); WRITE(*,'(A)') 'STOP AT WEAK SINKS' CASE DEFAULT; STOP 'WRONG IWEAK SPECIFIED, PICK FROM 1 OR 2' END SELECT IF(IDIRECTION.EQ.1)ISNK=IWEAK IF(IDIRECTION.EQ.2)ISRC=IWEAK ISTOP=1; IF(UTL_READINITFILE('ISTOP',LINE,IU,1))THEN READ(LINE,*) ISTOP; WRITE(*,'(A10,I2)') 'ISTOP: ',ISTOP ENDIF SELECT CASE (ISTOP) CASE (1) IF(IDIRECTION.EQ.1)WRITE(*,'(A)') 'STOP AT THE END' IF(IDIRECTION.EQ.2)WRITE(*,'(A)') 'STOP AT THE BEGINING' CASE (2) IF(IDIRECTION.EQ.1)WRITE(*,'(A)') 'EXTEND FINAL TIME STEP UNTIL ALL REACH TERMINATION' IF(IDIRECTION.EQ.2)WRITE(*,'(A)') 'EXTEND INITIAL TIME STEP UNTIL ALL REACH TERMINATION' CASE (3) WRITE(*,'(A)') 'SPECIFY SPECIFIC VALUE OF TRACKING TIME' TSTOP=0.0D0; IF(.NOT.UTL_READINITFILE('TSTOP',LINE,IU,0))RETURN READ(LINE,*) TSTOP; WRITE(*,'(A10,F15.3)') 'TSTOP: ',TSTOP CASE DEFAULT; STOP 'WRONG ISTOP SPECIFIED, PICK FROM 1,2 OR 3' END SELECT ICONVERT=0; IF(UTL_READINITFILE('ICONVERT',LINE,IU,1))THEN READ(LINE,*) ICONVERT; WRITE(*,'(A,I10)') 'ICONVERT=',ICONVERT ENDIF !## generate mf6 namfile CALL UTL_CREATEDIR(TRIM(OUTDIR)) !## search for dis6.grb IF(.NOT.UTL_DIRINFO_POINTER(TRIM(MF6DIR)//'\GWF_'//TRIM(VTOS(IGWF))//'\MODELINPUT','*.DIS6.GRB',LISTNAME,'F'))THEN WRITE(*,'(/A/)') 'CANNOT FIND '//TRIM(MF6DIR)//'\GWF_'//TRIM(VTOS(IGWF))//'\MODELINPUT\*.DIS6.GRB'; STOP ENDIF JU=UTL_GETUNIT(); OPEN(JU,FILE=TRIM(OUTDIR)//'\MP7.MPNAM',STATUS='REPLACE',ACTION='WRITE') WRITE(JU,'(A)') 'MPBAS '//'MP7.MPBAS' WRITE(JU,'(A)') 'GRBDIS '//TRIM(MF6DIR)//'\GWF_'//TRIM(VTOS(IGWF))//'\MODELINPUT\'//TRIM(LISTNAME(1)) DEALLOCATE(LISTNAME) WRITE(JU,'(A)') 'TDIS '//TRIM(MF6DIR)//'\MFSIM.TDIS6' WRITE(JU,'(A)') 'HEAD '//TRIM(MF6DIR)//'\GWF_'//TRIM(VTOS(IGWF))//'\MODELOUTPUT\HEAD\HEAD.HED' WRITE(JU,'(A)') 'BUDGET '//TRIM(MF6DIR)//'\GWF_'//TRIM(VTOS(IGWF))//'\MODELOUTPUT\BUDGET\BUDGET.CBC' CLOSE(JU) JU=UTL_GETUNIT(); OPEN(JU,FILE=TRIM(OUTDIR)//'\MP7.MPSIM',STATUS='REPLACE',ACTION='WRITE') WRITE(JU,'(A)') 'MP7.MPNAM' WRITE(JU,'(A)') 'MP7.MPLIST' !## pathlines(2),backward(2),pass weaksinks(1),pass weaksources(1),no checks(0),no detailed info(0) SELECT CASE (ITRACK) CASE (2,3) WRITE(JU,'(A)') '2 '//TRIM(VTOS(IDIRECTION))//' '//TRIM(VTOS(ISNK))//' '//TRIM(VTOS(ISRC))//' 0 0' CASE DEFAULT WRITE(JU,'(A)') '1 '//TRIM(VTOS(IDIRECTION))//' '//TRIM(VTOS(ISNK))//' '//TRIM(VTOS(ISRC))//' 0 0' END SELECT WRITE(JU,'(A)') 'MP7.ENDPOINT7' IF(ITRACK.GE.2)WRITE(JU,'(A)') 'MP7.PATHLINE7' ! WRITE(JU,'(A)') 'MP7.TIMESERIES7' WRITE(JU,'(A)') '0' !## no balance checking WRITE(JU,'(A)') '1' !## reference time option WRITE(JU,'(A)') '0.0' !## initial time WRITE(JU,'(A)') TRIM(VTOS(ISTOP)) !## stopping criterion IF(ISTOP.EQ.3)THEN WRITE(JU,'(A)') TRIM(VTOS(TSTOP,'F',7)) !## stopping time (days) ENDIF WRITE(JU,'(A)') '1' !## no stoppping zone WRITE(JU,'(A)') '1' !## no retardation WRITE(JU,'(A)') '1' !## particle group count WRITE(JU,'(A)') 'PG1' !## particle group WRITE(JU,'(A)') '1' !## single value of particle release time' WRITE(JU,'(A)') '0.0' !## release time' WRITE(JU,'(A)') 'EXTERNAL MP7.SLOC' CLOSE(JU) !## read the master of idf MODELIDF%FNAME=TRIM(MF6DIR)//'\GWF_'//TRIM(VTOS(IGWF))//'\MODELINPUT\DIS6\IDOMAIN_L1.IDF' IF(.NOT.IDFREAD(MODELIDF,MODELIDF%FNAME,0))STOP JU=UTL_GETUNIT(); OPEN(JU,FILE=TRIM(OUTDIR)//'\MP7.MPBAS',STATUS='REPLACE',ACTION='WRITE') WRITE(JU,'(A)') '0' !## facecount IF(.NOT.IDFALLOCATEX(MODELIDF))STOP !## read and save porosity DO I=1,NLAY IF(.NOT.UTL_READINITFILE('POR_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) MODELIDF%FNAME; WRITE(*,'(A)') 'POR_L'//TRIM(VTOS(I))//'='//TRIM(MODELIDF%FNAME) READ(MODELIDF%FNAME,*,IOSTAT=IOS) X IF(IOS.EQ.0)THEN MODELIDF%X=X ELSE IF(.NOT.IDFREADSCALE(MODELIDF%FNAME,MODELIDF,2,1,0.0D0,0))RETURN !## scale mean ENDIF KU=UTL_GETUNIT(); OPEN(KU,FILE=TRIM(OUTDIR)//'\POR_L'//TRIM(VTOS(I))//'.ARR',STATUS='REPLACE',ACTION='WRITE') CALL IDFWRITEFREE(KU,MODELIDF,0,'B','F10.3') CLOSE(KU) WRITE(JU,'(A)') 'OPEN/CLOSE POR_L'//TRIM(VTOS(I))//'.ARR 1.0D0 (FREE) -1' ENDDO CLOSE(JU) ALLOCATE(TOP(NLAY),BOT(NLAY)) !## read all top/bot DO I=1,NLAY TOP(I)%FNAME=TRIM(MF6DIR)//'\GWF_'//TRIM(VTOS(IGWF))//'\MODELINPUT\DIS6\TOPM_L'//TRIM(VTOS(I))//'.IDF' IF(.NOT.IDFREAD(TOP(I),TOP(I)%FNAME,1))STOP BOT(I)%FNAME=TRIM(MF6DIR)//'\GWF_'//TRIM(VTOS(IGWF))//'\MODELINPUT\DIS6\BOTM_L'//TRIM(VTOS(I))//'.IDF' IF(.NOT.IDFREAD(BOT(I),BOT(I)%FNAME,1))STOP ENDDO !## copy this into the idf of trace CALL TRACE_BRING_IN_DATA(MODELIDF,NLAY,TOP,BOT) !## initialize startpoints memory CALL TRACE_INIT_SP(1); ISPFNAME=1 !## read/process particles towards readable format IF(.NOT.TRACEPREPARESP(SP(ISPFNAME)%NPART,1,1))RETURN !## read all particle in memory CALL TRACE_AL_SP(SP(ISPFNAME)%NPART,1) !## set initial time for each particle to zero CALL TRACEREADSP(1,SP(ISPFNAME)%NPART) JU=UTL_GETUNIT(); OPEN(JU,FILE=TRIM(OUTDIR)//'\MP7.SLOC',STATUS='REPLACE',ACTION='WRITE') WRITE(JU,'(A)') '1' !## inputstyle WRITE(JU,'(A)') '1' !## locationstyle WRITE(JU,'(A)') TRIM(VTOS((SP(1)%NPART)))//' 1' !## particlecount,particleidoption !## write startpoints DO I=1,SP(1)%NPART !## compute local coordinates CALL IDFGETEDGE(MODELIDF,SP(1)%ILC(I),SP(1)%JLC(I),X1,Y1,X2,Y2) XLL=((MODELIDF%XMIN+SP(1)%XLC(I))-X1)/(X2-X1) YLL=((MODELIDF%YMIN+SP(1)%YLC(I))-Y1)/(Y2-Y1) WRITE(JU,'(A)') TRIM(VTOS(I))//','// & TRIM(VTOS(SP(1)%KLC(I)))//','//TRIM(VTOS(SP(1)%ILC(I)))//','//TRIM(VTOS(SP(1)%JLC(I))) //','// & TRIM(VTOS(XLL,'F',2)) //','//TRIM(VTOS(YLL,'F',2)) //','//TRIM(VTOS(SP(1)%ZLL(I),'F',2)) //','// & TRIM(VTOS(0.0D0,'F',2)) //','//TRIM(VTOS(0)) ENDDO CLOSE(JU) JU=UTL_GETUNIT(); OPEN(JU,FILE=TRIM(OUTDIR)//'\MP7.BAT',STATUS='REPLACE',ACTION='WRITE') WRITE(JU,'(A)') TRIM(MODPATH7)//' < MP7_ARGUMENT.TXT' CLOSE(JU) JU=UTL_GETUNIT(); OPEN(JU,FILE=TRIM(OUTDIR)//'\MP7_ARGUMENT.TXT',STATUS='REPLACE',ACTION='WRITE') WRITE(JU,'(A)') 'MP7.MPSIM' CLOSE(JU) CALL IDFDEALLOCATE(TOP,SIZE(TOP)); CALL IDFDEALLOCATE(BOT,SIZE(BOT)) CALL IOSDIRCHANGE(TRIM(OUTDIR)) CALL IOSCOMMAND('MP7.BAT',IFLAGS=PROCBLOCKED) CALL IOSDIRCHANGE(TRIM(CURDIR)) IF(ICONVERT.NE.0)THEN IF(ITRACK.EQ.2.OR.ITRACK.EQ.3)THEN IU=UTL_GETUNIT(); OPEN(IU,FILE=TRIM(OUTDIR)//'\MP7.PATHLINE7',STATUS='OLD' ,ACTION='READ' ,FORM='FORMATTED') JU=UTL_GETUNIT(); OPEN(JU,FILE=TRIM(OUTDIR)//'\PATHLINE7.IFF',STATUS='REPLACE',ACTION='WRITE',FORM='FORMATTED') WRITE(JU,'(A)') '9' WRITE(JU,'(A)') 'PARTICLE_NUMBER' WRITE(JU,'(A)') 'ILAY' WRITE(JU,'(A)') 'XCRD.' WRITE(JU,'(A)') 'YCRD.' WRITE(JU,'(A)') 'ZCRD.' WRITE(JU,'(A)') 'TIME(YEARS)' WRITE(JU,'(A)') 'VELOCITY(M/DAY)' WRITE(JU,'(A)') 'IROW' WRITE(JU,'(A)') 'ICOL' IF(ITRACK.EQ.3)THEN DO I=1,3; READ(IU,*); ENDDO; MXID=0 DO READ(IU,'(A256)',IOSTAT=IOS) LINE IF(IOS.NE.0)EXIT !## sequencenumber,group,particleID,pathlineCount READ(LINE,*) I,J,ID,N MXID=MAX(MXID,ID) DO I=1,N; READ(IU,*); ENDDO ENDDO ALLOCATE(MAXLAY(MXID),D(MXID)); MAXLAY=0; D=0.0D0; REWIND(IU) ENDIF DO I=1,3; READ(IU,*); ENDDO; MXID=0 DO READ(IU,'(A256)',IOSTAT=IOS) LINE IF(IOS.NE.0)EXIT !## sequencenumber,group,particleID,pathlineCount READ(LINE,*) I,J,ID,N IF(ITRACK.EQ.3)THEN; MAXLAY(ID)=0; D(ID)=0.0D0; ENDIF CD=0.0D0; V=0.0D0; DO I=1,N READ(IU,*) J,X,Y,Z,T,XD,XD,XD,ILAY X=X+TOP(1)%XMIN; Y=Y+TOP(1)%YMIN; T=T/365.25D0 !## current distance IF(I.GT.1)THEN CD=UTL_DIST_3D(X,Y,Z,X2,Y2,Z2) V=0.0D0; IF(T-T2.GT.0.0D0)V=CD/(T-T2)/365.25D0 ENDIF IF(ITRACK.EQ.3)THEN MAXLAY(ID)=MAX(ILAY,MAXLAY(ID)); D(ID)=D(ID)+CD ENDIF CALL IDFIROWICOL(TOP(1),SROW,SCOL,X,Y) ! WRITE(JU(IPF(I)%INQ,1),'(2(I10,1X),5(E15.7,1X),2(I10,1X))') IFF(J)%ID,IFF(J)%ILAY,IFF(J)%X,IFF(J)%Y,IFF(J)%Z,IFF(J)%T,IFF(J)%V,IFF(J)%IROW,IFF(J)%ICOL WRITE(JU,'(2(I10,1X),5(F15.3,1X),2(I10,1X))') ID,ILAY,X,Y,Z,T,V,SROW,SCOL X2=X Y2=Y Z2=Z T2=T ENDDO ENDDO CLOSE(IU); CLOSE(JU) ENDIF IF(ITRACK.EQ.1.OR.ITRACK.EQ.3)THEN IU=UTL_GETUNIT(); OPEN(IU,FILE=TRIM(OUTDIR)//'\MP7.ENDPOINT7',STATUS='OLD' ,ACTION='READ' ,FORM='FORMATTED') JU=UTL_GETUNIT(); OPEN(JU,FILE=TRIM(OUTDIR)//'\ENDPOINT7.IPF',STATUS='REPLACE',ACTION='WRITE',FORM='FORMATTED') READ(IU,*) READ(IU,*) IDIRECTION,N,NT READ(IU,*) READ(IU,*) N DO I=1,N; READ(IU,*); ENDDO READ(IU,*) WRITE(JU,'(A)') TRIM(VTOS(NT)) WRITE(JU,'(A)') '17' WRITE(JU,'(A)') 'SP_XCRD.' WRITE(JU,'(A)') 'SP_YCRD.' WRITE(JU,'(A)') 'SP_ZCRD.' WRITE(JU,'(A)') 'SP_ILAY' WRITE(JU,'(A)') 'SP_IROW' WRITE(JU,'(A)') 'SP_ICOL' WRITE(JU,'(A)') 'EP_XCRD.' WRITE(JU,'(A)') 'EP_YCRD.' WRITE(JU,'(A)') 'EP_ZCRD.' WRITE(JU,'(A)') 'EP_ILAY' WRITE(JU,'(A)') 'EP_IROW' WRITE(JU,'(A)') 'EP_ICOL' WRITE(JU,'(A)') 'TIME' WRITE(JU,'(A)') 'MAXLAYER' WRITE(JU,'(A)') 'DISTANCE' WRITE(JU,'(A)') 'IDENT.NO.' WRITE(JU,'(A)') 'CAPTURED_BY' WRITE(JU,'(A)') '0,TXT' DO I=1,NT READ(IU,*) (XVAR(J),J=1,26) XVAR(12)=XVAR(12)+TOP(1)%XMIN XVAR(13)=XVAR(13)+TOP(1)%YMIN !## use final cell id (xvar(7)) NODE=INT(XVAR(7)); CALL UTL_GETIROWICOL(NODE,TOP(1)%NROW,TOP(1)%NCOL,ILAY,SROW,SCOL) IF(ILAY.NE.INT(XVAR(8)))THEN WRITE(*,'(2(A,I10))') 'Initial layer ',INT(XVAR(8)),' from the endpoint file does not match the derived value ',ILAY ENDIF ! CALL IDFIROWICOL(TOP(1),SROW,SCOL,XVAR(12),XVAR(13)) XVAR(22)=XVAR(22)+TOP(1)%XMIN XVAR(23)=XVAR(23)+TOP(1)%YMIN !## use initial cell id (xvar(17)) NODE=INT(XVAR(17)); CALL UTL_GETIROWICOL(NODE,TOP(1)%NROW,TOP(1)%NCOL,ILAY,EROW,ECOL) IF(ILAY.NE.INT(XVAR(18)))THEN WRITE(*,'(2(A,I10))') 'Final layer ',INT(XVAR(8)),' from the endpoint file does not match the derived value ',ILAY ENDIF ! CALL IDFIROWICOL(TOP(1),EROW,ECOL,XVAR(22),XVAR(23)) II=-1 X =-1.0D0 IF(ITRACK.EQ.3)THEN !## ParticleID ID=INT(XVAR(3)) IF(ID.LE.SIZE(MAXLAY))THEN II=MAXLAY(ID) X =D(ID) ENDIF ENDIF WRITE(JU,'(3(F15.3,1X),3(I10,1X),3(F15.3,1X),3(I10,1X),F15.3,1X,I10,1X,F15.3,2(1X,I10))') XVAR(12),XVAR(13),XVAR(14),INT(XVAR(8)) ,SROW,SCOL, & XVAR(22),XVAR(23),XVAR(24),INT(XVAR(18)),EROW,ECOL, & XVAR(6)/365.25D0,II,X,INT(XVAR(1)),INT(XVAR(4)) ENDDO ENDIF ENDIF IF(ITRACK.EQ.3)DEALLOCATE(MAXLAY,D) END SUBROUTINE IMODBATCH_IMODPATH7_MAIN !###====================================================================== SUBROUTINE IMODBATCH_IMODPATH_MAIN() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: RUNFILE,IFFFLOW,IPFFLOW,IDFFLOW,IPFFNAME INTEGER :: IPOSTP,IRUN,ICONVERTGEN,IEXTRACT INTEGER,DIMENSION(4) :: IPFICOL CHARACTER(LEN=256) :: TOPFNAME,BOTFNAME LOGICAL :: LEX TYPE(IDFOBJ) :: ZOOMIDF TOPFNAME=''; BOTFNAME=''; IEXTRACT=4; IPFFNAME=''; IFFFLOW=''; IPFFLOW='' !## 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) ZOOMIDF%XMIN=0.0D0; ZOOMIDF%YMIN=0.0D0; ZOOMIDF%XMAX=0.0D0; ZOOMIDF%YMAX=0.0D0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) ZOOMIDF%XMIN,ZOOMIDF%YMIN,ZOOMIDF%XMAX,ZOOMIDF%YMAX WRITE(*,'(A,4F15.3)') 'WINDOW=',ZOOMIDF%XMIN,ZOOMIDF%YMIN,ZOOMIDF%XMAX,ZOOMIDF%YMAX ENDIF 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(TRIM(IFFFLOW).EQ.''.AND.TRIM(IPFFLOW).EQ.'')THEN WRITE(*,*) 'You need to specify IPFFLOW and/or IFFFLOW'; STOP ENDIF !## read ipf for postprocessing IF(UTL_READINITFILE('IPFFNAME',LINE,IU,1))THEN READ(LINE,*) IPFFNAME; WRITE(*,'(A)') 'IPFFNAME='//TRIM(IPFFNAME) IF(.NOT.UTL_READINITFILE('IDFFLOW',LINE,IU,0))RETURN READ(LINE,*) IDFFLOW; WRITE(*,'(A)') 'IDFFLOW='//TRIM(IDFFLOW) 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) ELSE IF(UTL_READINITFILE('TOPFNAME',LINE,IU,1))THEN READ(LINE,*) TOPFNAME; WRITE(*,'(A)') 'TOPFNAME='//TRIM(TOPFNAME) ENDIF IF(UTL_READINITFILE('BOTFNAME',LINE,IU,1))THEN READ(LINE,*) BOTFNAME; WRITE(*,'(A)') 'BOTFNAME='//TRIM(BOTFNAME) ENDIF IF(UTL_READINITFILE('IEXTRACT',LINE,IU,1))READ(LINE,*) IEXTRACT WRITE(*,'(A,I1)') 'IEXTRACT=',IEXTRACT IF(IEXTRACT.LT.1.OR.IEXTRACT.GT.4)THEN WRITE(*,'(A)') 'IEXTRACT needs to be 1,2,3 or 4'; STOP ENDIF ENDIF ENDIF LEX=.TRUE.; IF(IRUN.EQ.1)LEX=TRACEMAIN(RUNFILE,1,ICONVERTGEN,ZOOMIDF) IF(LEX.AND.IPOSTP.EQ.1)CALL TRACEPOSTPROCESSING(IFFFLOW,IPFFLOW,IDFFLOW,IPFFNAME,IPFICOL,ICONVERTGEN,TOPFNAME,BOTFNAME,IEXTRACT) !## close all memory CALL TRACEDEALLOCATE(1) END SUBROUTINE IMODBATCH_IMODPATH_MAIN !###====================================================================== SUBROUTINE IMODBATCH_LAYERFROMTHICKNESS() !###====================================================================== IMPLICIT NONE TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: THK TYPE(IDFOBJ) :: MOTHER,TOP,BOT,SUM CHARACTER(LEN=256) :: OUTPUTFOLDER INTEGER :: NLAY,IOS,I,J,IROW,ICOL REAL(KIND=DP_KIND) :: X,MINTHICKNESS,ADDTOPLAYER !## number of layer to be corrected IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) NLAY; WRITE(*,'(A,I10)') 'NLAY=',NLAY !## minimal thickness MINTHICKNESS=0.0D0; IF(UTL_READINITFILE('MINTHICKNESS',LINE,IU,1))READ(LINE,*) MINTHICKNESS WRITE(*,'(A,F10.2)') 'MINTHICKNESS=',MINTHICKNESS ADDTOPLAYER=0.0D0; IF(UTL_READINITFILE('ADDTOPLAYER',LINE,IU,1))READ(LINE,*) ADDTOPLAYER WRITE(*,'(A,F10.2)') 'ADDTOPLAYER=',ADDTOPLAYER !## result folder IF(.NOT.UTL_READINITFILE('OUTPUTFOLDER',LINE,IU,0))RETURN READ(LINE,*) OUTPUTFOLDER; WRITE(*,'(A)') 'OUTPUTFOLDER='//TRIM(OUTPUTFOLDER) CALL IDFNULLIFY(MOTHER); CALL IDFNULLIFY(SUM) ALLOCATE(THK(NLAY)); DO I=1,SIZE(THK); CALL IDFNULLIFY(THK(I)); ENDDO IF(.NOT.UTL_READINITFILE('TOP',LINE,IU,0))RETURN READ(LINE,*) TOP%FNAME; LINE='TOP='//TRIM(TOP%FNAME); WRITE(*,'(A)') TRIM(LINE) DO I=1,NLAY IF(.NOT.UTL_READINITFILE('THK_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) THK(I)%FNAME LINE='THK_L'//TRIM(VTOS(I))//'='//TRIM(THK(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) ENDDO MOTHER%XMIN=0.0D0; MOTHER%XMAX=0.0D0; MOTHER%YMIN=0.0D0; MOTHER%YMAX=0.0D0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) MOTHER%XMIN,MOTHER%YMIN,MOTHER%XMAX,MOTHER%YMAX WRITE(*,'(A,4F15.3)') 'WINDOW=',MOTHER%XMIN,MOTHER%YMIN,MOTHER%XMAX,MOTHER%YMAX IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,0))RETURN READ(LINE,*) MOTHER%DX; WRITE(*,'(A,4F15.3)') 'CELLSIZE=',MOTHER%DX MOTHER%DY=MOTHER%DX CALL UTL_IDFSNAPTOGRID_LLC(MOTHER%XMIN,MOTHER%XMAX,MOTHER%YMIN,MOTHER%YMAX,MOTHER%DX,MOTHER%DY,MOTHER%NCOL,MOTHER%NROW,LLC=.TRUE.) ELSE !## construct mother to be the minimal overlapping gridsize THK%NROW=0; THK%NCOL=0 DO I=1,SIZE(THK) READ(THK(I)%FNAME,*,IOSTAT=IOS) X IF(IOS.NE.0)THEN; IF(.NOT.IDFREAD(THK(I),THK(I)%FNAME,0))RETURN; ENDIF ENDDO !## get maximal extent IF(.NOT.IDF_EXTENT(SIZE(THK),THK,MOTHER,1))RETURN ENDIF CALL IDFCOPY(MOTHER,TOP) WRITE(*,'(A)') ' Reading '//TRIM(TOP%FNAME) READ(TOP%FNAME,*,IOSTAT=IOS) X IF(IOS.EQ.0)THEN IF(.NOT.IDFALLOCATEX(TOP))RETURN; TOP%X=X; TOP%NODATA=X ELSE IF(.NOT.IDFREADSCALE(TOP%FNAME,TOP,2,1,0.0D0,0))RETURN ENDIF CALL IDFCOPY(TOP,BOT); CALL IDFCOPY(TOP,SUM) IF(ADDTOPLAYER.GT.0.0D0)BOT%X=BOT%X-ADDTOPLAYER IF(ADDTOPLAYER.GT.0.0D0)THEN TOP%FNAME=TRIM(OUTPUTFOLDER)//'\TOP_L1.IDF' IF(.NOT.IDFWRITE(TOP,TOP%FNAME,1))RETURN BOT%FNAME=TRIM(OUTPUTFOLDER)//'\BOT_L1.IDF' IF(.NOT.IDFWRITE(BOT,BOT%FNAME,1))RETURN TOP%X=BOT%X ENDIF SUM%X=0.0D0 DO I=1,SIZE(THK) CALL IDFCOPY(MOTHER,THK(I)) WRITE(*,'(A)') ' Reading '//TRIM(THK(I)%FNAME) READ(THK(I)%FNAME,*,IOSTAT=IOS) X IF(IOS.EQ.0)THEN IF(.NOT.IDFALLOCATEX(THK(I)))RETURN; THK(I)%X=X; THK(I)%NODATA=X ELSE IF(.NOT.IDFREADSCALE(THK(I)%FNAME,THK(I),2,1,0.0D0,0))RETURN ENDIF !## compute top and bottom DO IROW=1,MOTHER%NROW; DO ICOL=1,MOTHER%NCOL IF(TOP%X(ICOL,IROW).NE.TOP%NODATA)THEN TOP%X(ICOL,IROW)=BOT%X(ICOL,IROW) IF(THK(I)%X(ICOL,IROW).LT.MINTHICKNESS)THK(I)%X(ICOL,IROW)=0.0D0 !## added enough thickness to start filling in a layer IF(SUM%X(ICOL,IROW).LT.ADDTOPLAYER)THEN SUM%X( ICOL,IROW)=SUM%X( ICOL,IROW)+THK(I)%X(ICOL,IROW) ! MAJ%X( ICOL,IROW)=REAL(I,8) THK(I)%X(ICOL,IROW)=THK(I)%X(ICOL,IROW)-ADDTOPLAYER THK(I)%X(ICOL,IROW)=MAX(0.0D0,THK(I)%X(ICOL,IROW)) ENDIF BOT%X(ICOL,IROW)=TOP%X(ICOL,IROW)-THK(I)%X(ICOL,IROW) ENDIF ENDDO; ENDDO J=0; IF(ADDTOPLAYER.GT.0.0D0)J=1 TOP%FNAME=TRIM(OUTPUTFOLDER)//'\TOP_L'//TRIM(VTOS(I+J))//'.IDF' IF(.NOT.IDFWRITE(TOP,TOP%FNAME,1))RETURN BOT%FNAME=TRIM(OUTPUTFOLDER)//'\BOT_L'//TRIM(VTOS(I+J))//'.IDF' IF(.NOT.IDFWRITE(BOT,BOT%FNAME,1))RETURN ENDDO END SUBROUTINE IMODBATCH_LAYERFROMTHICKNESS !###====================================================================== 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 INTEGER :: IL1,IL2,IL,MINTHICK_OPT REAL(KIND=DP_KIND) :: X,MINTHICK,TD,CD,MT,TT1,TT2 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: THICK1,THICK2 ICLEAN=0; MINTHICK=0.0D0; MINTHICK_OPT=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 (3) WRITE(*,'(1X,A)') 'Fill nodata values from first active layer below inactive location.' CASE DEFAULT WRITE(*,'(A)') 'ICLEAN need to be 0-3' 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(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) IDF(J)%FNAME LINE='TOP_L'//TRIM(VTOS(I))//'='//TRIM(IDF(J)%FNAME); WRITE(*,'(A)') TRIM(LINE) J=J+1 IF(.NOT.UTL_READINITFILE('BOT_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) IDF(J)%FNAME; LINE='BOT_L'//TRIM(VTOS(I))//'='//TRIM(IDF(J)%FNAME); WRITE(*,'(A)') TRIM(LINE) ENDDO MOTHER%XMIN=0.0D0; MOTHER%XMAX=0.0D0; MOTHER%YMIN=0.0D0; MOTHER%YMAX=0.0D0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) MOTHER%XMIN,MOTHER%YMIN,MOTHER%XMAX,MOTHER%YMAX WRITE(*,'(A,4F15.3)') 'WINDOW=',MOTHER%XMIN,MOTHER%YMIN,MOTHER%XMAX,MOTHER%YMAX IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,0))RETURN READ(LINE,*) MOTHER%DX; WRITE(*,'(A,4F15.3)') 'CELLSIZE=',MOTHER%DX MOTHER%DY=MOTHER%DX CALL UTL_IDFSNAPTOGRID_LLC(MOTHER%XMIN,MOTHER%XMAX,MOTHER%YMIN,MOTHER%YMAX,MOTHER%DX,MOTHER%DY,MOTHER%NCOL,MOTHER%NROW,LLC=.TRUE.) 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 !## get minimal layer thickness to be applied IF(UTL_READINITFILE('MINLAY_THICKNESS',LINE,IU,1))THEN READ(LINE,*) MINTHICK IF(UTL_READINITFILE('MINLTZERO_OPT',LINE,IU,1))THEN READ(LINE,*) MINTHICK_OPT ENDIF 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.0D0,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 IF(ICLEAN.EQ.3)THEN !## correct top->bottom and apply vertical shift DO IROW=1,MOTHER%NROW; DO ICOL=1,MOTHER%NCOL DO I=1,SIZE(IDF) IF(IDF(I)%X(ICOL,IROW).NE.IDF(I)%NODATA)CYCLE DO J=I+1,SIZE(IDF) !## value available - if not search for next one in row IF(IDF(J)%X(ICOL,IROW).EQ.IDF(J)%NODATA)CYCLE IDF(I)%X(ICOL,IROW)=IDF(J)%X(ICOL,IROW); EXIT 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 !## correct, based on given minimal thickness ALLOCATE(THICK1(NLAY)); THICK1=0.0D0 ALLOCATE(THICK2(NLAY-1)); THICK2=0.0D0 DO IROW=1,MOTHER%NROW; DO ICOL=1,MOTHER%NCOL THICK1=0.0D0; THICK2=0.0D0 !## compute thicknesses aquifers I=1 DO IL=1,NLAY*2,2 THICK1(I)=IDF(IL)%X(ICOL,IROW)-IDF(IL+1)%X(ICOL,IROW) I=I+1 ENDDO !## compute thicknesses aquitards I=1 DO IL=2,(NLAY-1)*2,2 THICK2(I)=IDF(IL)%X(ICOL,IROW)-IDF(IL+1)%X(ICOL,IROW) I=I+1 ENDDO TT1=SUM(THICK1) TT2=SUM(THICK2) IL1=1 DO DO IL=IL1,NLAY-1 !## found aquitard IF(THICK2(IL).GT.0.0D0)EXIT ENDDO IL2=IL TD=SUM(THICK1(IL1:IL2)) N=((IL2-IL1)+1) MT=MIN(MINTHICK,TD/REAL(N)) !## correct also layers with tickness == 0.0D0 IF(MINTHICK_OPT.EQ.1.AND.MT.EQ.0.0D0)MT=MINTHICK CD=0.0D0 !## total correction term DO IL=IL1,IL2 IF(THICK1(IL).LT.MT)THEN CD=CD+MT-THICK1(IL); THICK1(IL)=MT ENDIF ENDDO !## correction needed IF(CD.GT.0.0D0)THEN N=0 DO IL=IL1,IL2 IF(THICK1(IL).GT.MT)N=N+1 ENDDO IF(N.GT.0)CD=CD/REAL(N) DO IL=IL1,IL2 IF(THICK1(IL).GT.MT)THEN THICK1(IL)=THICK1(IL)-CD ENDIF ENDDO ENDIF IL1=IL2+1 IF(IL1.GE.NLAY)EXIT ENDDO !## adjust all top/bottom according to thick I=1; J=1 DO IL=1,NLAY*2 IF(MOD(IL,2))THEN IDF(IL+1)%X(ICOL,IROW)=IDF(IL)%X(ICOL,IROW)-THICK1(I) I=I+1 ELSE IF(J.LE.NLAY-1)THEN IDF(IL+1)%X(ICOL,IROW)=IDF(IL)%X(ICOL,IROW)-THICK2(J) J=J+1 ENDIF ENDIF 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(VTOS(I))//'.IDF' ELSE IDF(J)%FNAME=TRIM(OUTPUTFOLDER)//'\TOP_L'//TRIM(VTOS(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_RESAMPLELAYERS() !###====================================================================== IMPLICIT NONE TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:,:) :: MDL1,MDL2 TYPE(IDFOBJ) :: IDF CHARACTER(LEN=256) :: OUTPUTFOLDER INTEGER :: NLY1,NLY2,I,J,NROW,NCOL,IROW,ICOL,IWINDOW,N REAL(KIND=DP_KIND) :: TOP1,TOP2,BOT1,BOT2,T,B,CT INTEGER :: ITOP=1,IBOT=2,IKHV=3,IKVA=4,IKVV=5,ITOP2=6 INTEGER :: IKDW=3,IVCW=5,ITKH=6,ITKC=7 IWINDOW=0; IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN IWINDOW=1 READ(LINE,*) IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX WRITE(*,'(A,4F15.3)') '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,F15.3)') 'CELL_SIZE=',IDF%DX IDF%DY=IDF%DX CALL UTL_IDFSNAPTOGRID_LLC(IDF%XMIN,IDF%XMAX,IDF%YMIN,IDF%YMAX,IDF%DX,IDF%DY,IDF%NCOL,IDF%NROW,LLC=.TRUE.) IF(.NOT.IDFALLOCATEX(IDF))RETURN IDF%ITYPE=4 ENDIF !## number of layer to be used for the fill in IF(.NOT.UTL_READINITFILE('NLAY1',LINE,IU,0))RETURN; READ(LINE,*) NLY1; WRITE(*,'(A,I10)') 'NLAY1=',NLY1 !## number of layers of model to be filled in IF(.NOT.UTL_READINITFILE('NLAY2',LINE,IU,0))RETURN; READ(LINE,*) NLY2; WRITE(*,'(A,I10)') 'NLAY2=',NLY2 !## aquifers only ALLOCATE(MDL1(1,ITOP2),MDL2(NLY2,7)) DO I=1,SIZE(MDL1,1); DO J=1,SIZE(MDL1,2); CALL IDFNULLIFY(MDL1(I,J)); ENDDO; ENDDO DO I=1,SIZE(MDL2,1); DO J=1,SIZE(MDL2,2); CALL IDFNULLIFY(MDL2(I,J)); ENDDO; ENDDO !## result folder IF(.NOT.UTL_READINITFILE('OUTPUTFOLDER',LINE,IU,0))RETURN READ(LINE,*) OUTPUTFOLDER; WRITE(*,'(A)') 'OUTPUTFOLDER='//TRIM(OUTPUTFOLDER) DO I=1,NLY2 IF(.NOT.UTL_READINITFILE('TOP2_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) MDL2(I,ITOP)%FNAME; LINE='TOP2_L'//TRIM(VTOS(I))//'='//TRIM(MDL2(I,ITOP)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(IWINDOW.EQ.0)THEN IF(.NOT.IDFREAD(MDL2(I,ITOP),MDL2(I,ITOP)%FNAME,1))RETURN CALL IDFCOPY(MDL2(I,ITOP),IDF) ELSE CALL IDFCOPY(IDF,MDL2(I,ITOP)); IF(.NOT.IDFREADSCALE(MDL2(I,ITOP)%FNAME,MDL2(I,ITOP),2,0,0.0D0,0))STOP 'Cannot read data for TOP2(1)' ENDIF IF(.NOT.UTL_READINITFILE('BOT2_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) MDL2(I,IBOT)%FNAME; LINE='BOT2_L'//TRIM(VTOS(I))//'='//TRIM(MDL2(I,IBOT)%FNAME); WRITE(*,'(A)') TRIM(LINE) CALL IDFCOPY(IDF,MDL2(I,IBOT)); IF(.NOT.IDFREADSCALE(MDL2(I,IBOT)%FNAME,MDL2(I,IBOT),2,0,0.0D0,0))STOP 'Cannot read data for BOT2(1)' CALL IDFCOPY(IDF,MDL2(I,IKDW)); CALL IDFCOPY(IDF,MDL2(I,IKVA)); CALL IDFCOPY(IDF,MDL2(I,IVCW)); CALL IDFCOPY(IDF,MDL2(I,ITKH)); CALL IDFCOPY(IDF,MDL2(I,ITKC)) ENDDO NROW=MDL2(1,ITOP)%NROW; NCOL=MDL2(1,ITOP)%NCOL DO I=1,NLY2; MDL2(I,IKDW)%X=0.0; MDL2(I,IKVA)%X=0.0; MDL2(I,IVCW)%X=0.0; MDL2(I,ITKH)%X=0.0; MDL2(I,ITKC)%X=0.0; ENDDO !## loop on "background"-model DO I=1,NLY1 DO J=1,SIZE(MDL1,2); CALL IDFDEALLOCATEX(MDL1(1,J)); ENDDO IF(.NOT.UTL_READINITFILE('TOP1_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) MDL1(1,1)%FNAME; LINE='TOP1_L'//TRIM(VTOS(I))//'='//TRIM(MDL1(1,ITOP)%FNAME); WRITE(*,'(A)') TRIM(LINE) CALL IDFCOPY(IDF,MDL1(1,ITOP)); IF(.NOT.IDFREADSCALE(MDL1(1,ITOP)%FNAME,MDL1(1,ITOP),1,0,0.0D0,0))STOP 'Cannot read data for TOP1(1)' IF(.NOT.UTL_READINITFILE('BOT1_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) MDL1(1,IBOT)%FNAME; LINE='BOT1_L'//TRIM(VTOS(I))//'='//TRIM(MDL1(1,IBOT)%FNAME); WRITE(*,'(A)') TRIM(LINE) CALL IDFCOPY(IDF,MDL1(1,IBOT)); IF(.NOT.IDFREADSCALE(MDL1(1,IBOT)%FNAME,MDL1(1,IBOT),2,0,0.0D0,0))STOP 'Cannot read data for BOT1(1)' IF(.NOT.UTL_READINITFILE('KHV1_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) MDL1(1,IKHV)%FNAME; LINE='KHV1_L'//TRIM(VTOS(I))//'='//TRIM(MDL1(1,IKHV)%FNAME); WRITE(*,'(A)') TRIM(LINE) CALL IDFCOPY(IDF,MDL1(1,IKHV)); IF(.NOT.IDFREADSCALE(MDL1(1,IKHV)%FNAME,MDL1(1,IKHV),3,0,0.0D0,0))STOP 'Cannot read data for KHV1(1)' IF(.NOT.UTL_READINITFILE('KVA1_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) MDL1(1,IKVA)%FNAME; LINE='KVA1_L'//TRIM(VTOS(I))//'='//TRIM(MDL1(1,IKVA)%FNAME); WRITE(*,'(A)') TRIM(LINE) CALL IDFCOPY(IDF,MDL1(1,IKVA)); IF(.NOT.IDFREADSCALE(MDL1(1,IKVA)%FNAME,MDL1(1,IKVA),2,0,0.0D0,0))STOP 'Cannot read data for KVA1(1)' IF(.NOT.UTL_READINITFILE('KVV1_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) MDL1(1,IKVV)%FNAME; LINE='KVV1_L'//TRIM(VTOS(I))//'='//TRIM(MDL1(1,IKVV)%FNAME); WRITE(*,'(A)') TRIM(LINE) CALL IDFCOPY(IDF,MDL1(1,IKVV)); IF(.NOT.IDFREADSCALE(MDL1(1,IKVV)%FNAME,MDL1(1,IKVV),3,0,0.0D0,0))STOP 'Cannot read data for KVV1(1)' IF(I.LT.NLY1)THEN IF(.NOT.UTL_READINITFILE('TOP1_L'//TRIM(VTOS(I+1)),LINE,IU,0))RETURN READ(LINE,*) MDL1(1,ITOP2)%FNAME; LINE='TOP1_L'//TRIM(VTOS(I+1))//'='//TRIM(MDL1(1,ITOP2)%FNAME); WRITE(*,'(A)') TRIM(LINE) CALL IDFCOPY(IDF,MDL1(1,ITOP2)); IF(.NOT.IDFREADSCALE(MDL1(1,ITOP2)%FNAME,MDL1(1,ITOP2),2,0,0.0D0,0))STOP 'Cannot read data for TOP1(1)' ENDIF DO IROW=1,NROW; DO ICOL=1,NCOL if(icol.eq.179.and.irow.eq.210)then write(*,*) endif !## skip nodata N=5; IF(I.LT.NLY1)N=6; DO J=1,N; IF(MDL1(1,J)%X(ICOL,IROW).EQ.MDL1(1,J)%NODATA)EXIT; ENDDO; IF(J.LE.N)CYCLE !## skip layer thickness of zero TOP1=MDL1(1,ITOP)%X(ICOL,IROW); BOT1=MDL1(1,IBOT)%X(ICOL,IROW); IF(TOP1-BOT1.LE.0.0)CYCLE !## fill model DO J=1,NLY2 TOP2=MDL2(J,ITOP)%X(ICOL,IROW); BOT2=MDL2(J,IBOT)%X(ICOL,IROW) !## fill in horizontal/vertical transmissivity T=MIN(TOP1,TOP2); B=MAX(BOT1,BOT2) IF(T-B.GT.0.0D0)THEN !## sum of thickness aquifer MDL2(J,ITKH)%X(ICOL,IROW)=MDL2(J,ITKH)%X(ICOL,IROW)+(T-B) !## sum of kd MDL2(J,IKDW)%X(ICOL,IROW)=MDL2(J,IKDW)%X(ICOL,IROW)+(T-B)* MDL1(1,IKHV)%X(ICOL,IROW) !## sum of c MDL2(J,IKVA)%X(ICOL,IROW)=MDL2(J,IKVA)%X(ICOL,IROW)+(T-B)/(MDL1(1,IKHV)%X(ICOL,IROW)*MDL1(1,IKVA)%X(ICOL,IROW)) ENDIF ENDDO !## fill in aquitards IF(I.LT.NLY1)THEN TOP1=MDL1(1,IBOT)%X(ICOL,IROW); BOT1=MDL1(1,ITOP2)%X(ICOL,IROW); IF(TOP1-BOT1.LE.0.0)CYCLE DO J=1,NLY2-1 TOP2=MDL2(J,IBOT)%X(ICOL,IROW); BOT2=MDL2(J+1,ITOP)%X(ICOL,IROW) T=MIN(TOP1,TOP2); B=MAX(BOT1,BOT2) IF(T-B.GT.0.0D0)THEN !## sum of thickness aquitard MDL2(J,ITKC)%X(ICOL,IROW)=MDL2(J,ITKC)%X(ICOL,IROW)+(T-B) !## sum of c MDL2(I,IVCW)%X(ICOL,IROW)=MDL2(I,IVCW)%X(ICOL,IROW)+(T-B)/MDL1(1,IKVV)%X(ICOL,IROW) ENDIF ENDDO ENDIF ENDDO; ENDDO ENDDO !## convert to k-values and anisotropy DO J=1,NLY2 DO IROW=1,NROW; DO ICOL=1,NCOL IF(MDL2(J,ITKH)%X(ICOL,IROW).GT.0.0D0)THEN MDL2(J,IKDW)%X(ICOL,IROW)=MDL2(J,IKDW)%X(ICOL,IROW)/MDL2(J,ITKH)%X(ICOL,IROW) MDL2(J,IKVA)%X(ICOL,IROW)=MDL2(J,ITKH)%X(ICOL,IROW)/MDL2(J,IKVA)%X(ICOL,IROW) MDL2(J,IKVA)%X(ICOL,IROW)=MDL2(J,IKVA)%X(ICOL,IROW)/MDL2(J,IKDW)%X(ICOL,IROW) ENDIF IF(J.LT.NLY2)THEN IF(MDL2(J,ITKC)%X(ICOL,IROW).GT.0.0D0)THEN MDL2(J,5)%X(ICOL,IROW)=MDL2(J,ITKC)%X(ICOL,IROW)/MDL2(J,5)%X(ICOL,IROW) ELSE MDL2(J,5)%X(ICOL,IROW)=MDL2(J,5)%NODATA ENDIF ENDIF ENDDO; ENDDO ENDDO DO I=1,NLY2 MDL2(I,ITOP)%FNAME=TRIM(OUTPUTFOLDER)//'\TOP\TOP_L'//TRIM(VTOS(I))//'.IDF' IF(.NOT.IDFWRITE(MDL2(I,ITOP),MDL2(I,ITOP)%FNAME,1))RETURN MDL2(I,IBOT)%FNAME=TRIM(OUTPUTFOLDER)//'\BOT\BOT_L'//TRIM(VTOS(I))//'.IDF' IF(.NOT.IDFWRITE(MDL2(I,IBOT),MDL2(I,IBOT)%FNAME,1))RETURN MDL2(I,IKDW)%FNAME=TRIM(OUTPUTFOLDER)//'\KHV\KHV_L'//TRIM(VTOS(I))//'.IDF' IF(.NOT.IDFWRITE(MDL2(I,3),MDL2(I,3)%FNAME,1))RETURN MDL2(I,IKVA)%FNAME=TRIM(OUTPUTFOLDER)//'\KVA\KVA_L'//TRIM(VTOS(I))//'.IDF' IF(.NOT.IDFWRITE(MDL2(I,4),MDL2(I,4)%FNAME,1))RETURN MDL2(I,IVCW)%FNAME=TRIM(OUTPUTFOLDER)//'\KVV\KVV_L'//TRIM(VTOS(I))//'.IDF' IF(.NOT.IDFWRITE(MDL2(I,5),MDL2(I,5)%FNAME,1))RETURN ENDDO END SUBROUTINE IMODBATCH_RESAMPLELAYERS !###====================================================================== 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,MINEXTENT IMPLICIT NONE INTEGER :: I,IOS FDISTANCES=''; ICPOINTERS=1; NCLIP=0; IEXPZONE=0; MIN_THICKNESS=0.0D0; CRIT_THICKNESS=0.0D0 ALLOCATE(MDLIDF(5)); DO I=1,SIZE(MDLIDF); CALL IDFNULLIFY(MDLIDF(I)); ENDDO MDLIDF(1)%XMIN=0.0D0; MDLIDF(1)%YMIN=0.0D0; MDLIDF(1)%XMAX=0.0D0; MDLIDF(1)%YMAX=0.0D0 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(UTL_READINITFILE('CRIT_THICKNESS',LINE,IU,1))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 MINEXTENT=0; IF(UTL_READINITFILE('MINEXTENT',LINE,IU,1))READ(LINE,*) MINEXTENT WRITE(*,'(A,I10)') 'MINEXTENT=',MINEXTENT 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))READ(LINE,*) IEXPZONE LINE='IEXPZONE='//TRIM(VTOS(IEXPZONE)); WRITE(*,'(A)') TRIM(LINE) ENDIF ZCRIT=0.0D0; IF(UTL_READINITFILE('ZCRIT',LINE,IU,1))READ(LINE,*) ZCRIT WRITE(*,'(A,F10.2)') 'ZCRIT=',ZCRIT PERCENTAGE=95; IF(UTL_READINITFILE('PERCENTAGE',LINE,IU,1))READ(LINE,*) PERCENTAGE LINE='PERCENTAGE'//'='//TRIM(VTOS(PERCENTAGE,'F',2)); WRITE(*,'(A)') TRIM(LINE) 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(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) ZIDF(I)%FNAME LINE='PNT_L'//TRIM(VTOS(I))//'='//TRIM(ZIDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) ENDIF IF(.NOT.UTL_READINITFILE('FORMTOP_L'//TRIM(VTOS(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(VTOS(I))//'='//TRIM(TOPIDF(I)%FNAME)//'(CLIP='//TRIM(VTOS(ICLIP(I,1)))//')'; WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('FORMBOT_L'//TRIM(VTOS(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(VTOS(I))//'='//TRIM(BOTIDF(I)%FNAME)//'(CLIP='//TRIM(VTOS(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,4F15.3)') '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,F15.3)') 'CELLSIZE=',MDLIDF(1)%DX MDLIDF(1)%DY=MDLIDF(1)%DX CALL UTL_IDFSNAPTOGRID_LLC(MDLIDF(1)%XMIN,MDLIDF(1)%XMAX,MDLIDF(1)%YMIN,MDLIDF(1)%YMAX,MDLIDF(1)%DX,MDLIDF(1)%DY,MDLIDF(1)%NCOL,MDLIDF(1)%NROW,LLC=.TRUE.) 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(VTOS(I)),LINE,IU,0))RETURN; READ(LINE,*) KHG(I)%FNAME LINE='KHG_L'//TRIM(VTOS(I))//'='//TRIM(KHG(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('KVG_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN; READ(LINE,*) KVG(I)%FNAME LINE='KVG_L'//TRIM(VTOS(I))//'='//TRIM(KVG(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) ENDDO !## read model-files ALLOCATE(KHM(NLAYM),TPM(NLAYM),BTM(NLAYM),KVM(NLAYM),KAM(NLAYM)) DO I=1,NLAYM CALL IDFNULLIFY(KHM(I)); CALL IDFNULLIFY(TPM(I)); CALL IDFNULLIFY(BTM(I)) CALL IDFNULLIFY(KVM(I)); CALL IDFNULLIFY(KAM(I)) IF(.NOT.UTL_READINITFILE('TPM_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN; READ(LINE,*) TPM(I)%FNAME LINE='TPM_L'//TRIM(VTOS(I))//'='//TRIM(TPM(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('BTM_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN; READ(LINE,*) BTM(I)%FNAME LINE='BTM_L'//TRIM(VTOS(I))//'='//TRIM(BTM(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('KHM_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN; READ(LINE,*) KHM(I)%FNAME LINE='KHM_L'//TRIM(VTOS(I))//'='//TRIM(KHM(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('KAM_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN; READ(LINE,*) KAM(I)%FNAME LINE='KAM_L'//TRIM(VTOS(I))//'='//TRIM(KAM(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(I.LT.NLAYM)THEN IF(.NOT.UTL_READINITFILE('KVM_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN; READ(LINE,*) KVM(I)%FNAME LINE='KVM_L'//TRIM(VTOS(I))//'='//TRIM(KVM(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) ENDIF ENDDO MDLIDF%XMIN=0.0D0; MDLIDF%YMIN=0.0D0; MDLIDF%XMAX=0.0D0; MDLIDF%YMAX=0.0D0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) MDLIDF%XMIN,MDLIDF%YMIN,MDLIDF%XMAX,MDLIDF%YMAX WRITE(*,'(A,4F15.3)') 'WINDOW=',MDLIDF%XMIN,MDLIDF%YMIN,MDLIDF%XMAX,MDLIDF%YMAX IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,0))RETURN READ(LINE,*) MDLIDF%DX; WRITE(*,'(A,F15.3)') '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 TYPE(IDFOBJ) :: IDF CHARACTER(LEN=256),DIMENSION(2) :: IPFFNAME,REGIS CHARACTER(LEN=256) :: OUTPUTFOLDER INTEGER,DIMENSION(6) :: IXCOL IPFFNAME=''; OUTPUTFOLDER=''; IXCOL=0; CALL IDFNULLIFY(IDF) 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) IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX WRITE(*,'(A,4F15.3)') 'WINDOW=',IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,0))RETURN READ(LINE,*) IDF%DX; WRITE(*,'(A,F15.3)') 'CELLSIZE=',IDF%DX; IDF%DY=IDF%DX CALL UTL_IDFSNAPTOGRID_LLC(IDF%XMIN,IDF%XMAX,IDF%YMIN,IDF%YMAX,IDF%DX,IDF%DY,IDF%NCOL,IDF%NROW,LLC=.TRUE.) IF(.NOT.IDFALLOCATEX(IDF))THEN ENDIF ENDIF 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(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) TOPIDF(I)%FNAME LINE='TOP_L'//TRIM(VTOS(I))//'='//TRIM(TOPIDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('BOT_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) BOTIDF(I)%FNAME LINE='BOT_L'//TRIM(VTOS(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,IDF,TOPIDF,BOTIDF,IXCOL,REGIS,OUTPUTFOLDER) END SUBROUTINE IMODBATCH_IPFSPOTIFY !###====================================================================== SUBROUTINE IMODBATCH_IPFLUMP() !###====================================================================== IMPLICIT NONE INTEGER :: I,II,J,K,N IF(.NOT.UTL_READINITFILE('NIPF',LINE,IU,0))RETURN READ(LINE,*) NIPF; WRITE(*,'(A,I2)') 'NIPF=',NIPF CALL IPFALLOCATE() DO I=1,NIPF IF(.NOT.UTL_READINITFILE('IPFFILE'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) IPF(I)%FNAME; WRITE(*,'(A)') 'IPFFILE'//TRIM(VTOS(I))//'='//TRIM(IPF(I)%FNAME) !## read entire ipf IPF(I)%XCOL =1 !## x IPF(I)%YCOL =1 !## y IPF(I)%ZCOL =1 !## z not used IPF(I)%Z2COL=1 !## z2 not used IPF(I)%QCOL =1 !## q not used IF(IPFREAD2(I,1,0))THEN ENDIF ENDDO !## check number of columns DO I=2,NIPF IF(IPF(I)%NCOL.NE.IPF(1)%NCOL)EXIT ENDDO IF(I.LE.NIPF)THEN WRITE(*,*) 'Number of columns are not equal' DO I=1,NIPF WRITE(*,'(2I10,A)') I,IPF(I)%NCOL,TRIM(IPF(I)%FNAME) ENDDO ENDIF IF(.NOT.UTL_READINITFILE('IPFFILE_OUT',LINE,IU,0))RETURN READ(LINE,*) IPF(1)%FNAME; WRITE(*,'(A)') 'IPFFILE_OUT='//TRIM(IPF(1)%FNAME) N=SUM(IPF%NROW) !## create extra record to store reading of idf-file ALLOCATE(IPF(1)%DUMMY_INFO(IPF(1)%NCOL,N)) II=0; DO I=1,NIPF DO J=1,IPF(I)%NROW II=II+1 DO K=1,IPF(I)%NCOL IPF(1)%DUMMY_INFO(K,II)=IPF(I)%INFO(K,J) ENDDO ENDDO ENDDO DEALLOCATE(IPF(1)%INFO); IPF(1)%INFO=>IPF(1)%DUMMY_INFO IPF(1)%NROW=N !## create folder CALL UTL_CREATEDIR(IPF(1)%FNAME(:INDEX(IPF(1)%FNAME,'\',.TRUE.)-1)) IF(.NOT.IPFWRITE(1))THEN; ENDIF END SUBROUTINE IMODBATCH_IPFLUMP !###====================================================================== SUBROUTINE IMODBATCH_IPFSUM() !###====================================================================== IMPLICIT NONE INTEGER :: NFILE TYPE(IDFOBJ) :: ZONEIDF CHARACTER(LEN=256),DIMENSION(:),ALLOCATABLE :: IPFFILE CHARACTER(LEN=256) :: OUTPUTFILE,FNAME CHARACTER(LEN=5) :: EXT CHARACTER(LEN=52) :: CID CHARACTER(LEN=52),DIMENSION(3) :: STRING INTEGER :: I,J,K,N,M,NN,JU,KU,IEXT,IDATE,IY,IM,ID,IBAL,IROW,ICOL,IPER,DD,NYR,IZONE,DDATE,IYR,IMH,IDY,IHR,IMT,ISC,SDATE,EDATE,D1,D2 INTEGER, ALLOCATABLE,DIMENSION(:) :: IP,JDATES,JDATE INTEGER(KIND=DP_KIND) :: IDATED REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: Q REAL(KIND=DP_KIND) :: X,Y TYPE BALOBJ CHARACTER(LEN=52) :: LABEL REAL(KIND=DP_KIND),POINTER,DIMENSION(:) :: Q=>NULL() END TYPE BALOBJ TYPE(BALOBJ),DIMENSION(:),ALLOCATABLE :: BAL IZONE=0 IF(.NOT.UTL_READINITFILE('SDATE',LINE,IU,0))RETURN READ(LINE,*) SDATE; WRITE(*,'(A,I10)') 'SDATE=',SDATE IF(.NOT.UTL_READINITFILE('EDATE',LINE,IU,0))RETURN READ(LINE,*) EDATE; WRITE(*,'(A,I10)') 'EDATE=',EDATE IF(.NOT.UTL_READINITFILE('DDATE',LINE,IU,0))RETURN READ(LINE,*) DDATE SELECT CASE (DDATE) CASE(1); WRITE(*,'(A,I1,A)') 'DDATE=',DDATE,' (daily)' CASE(2); WRITE(*,'(A,I1,A)') 'DDATE=',DDATE,' (weekly)' CASE(3); WRITE(*,'(A,I1,A)') 'DDATE=',DDATE,' (monthly)' CASE(4); WRITE(*,'(A,I1,A)') 'DDATE=',DDATE,' (yearly)' CASE DEFAULT; WRITE(*,'(A)') 'Wrong DDATA value, need to be 1 <= DDATE <= 4' END SELECT NYR=UTL_DIFFDATE(SDATE,EDATE,DDATE) WRITE(*,'(A,I10,A)') 'Defined ',NYR,' periods' ALLOCATE(JDATES(0:NYR)); JDATES(0)=UTL_IDATETOJDATE(SDATE) DO I=1,NYR SELECT CASE (DDATE) !## day CASE (1); JDATES(I)=JDATES(I-1)+1 !## week CASE (2); JDATES(I)=JDATES(I-1)+7 !## month CASE (3); IDATE=UTL_JDATETOIDATE(JDATES(I-1)); CALL UTL_IDATETOGDATE(IDATE,IY,IM,ID); IM=IM+1; IF(IM.GT.12)THEN; IM=1; IY=IY+1; ENDIF; JDATES(I)=JD(IY,IM,ID) !## year CASE (4); IDATE=UTL_JDATETOIDATE(JDATES(I-1)); CALL UTL_IDATETOGDATE(IDATE,IY,IM,ID); IY=IY+1; JDATES(I)=JD(IY,IM,ID) END SELECT ENDDO DO I=0,NYR IDATE=UTL_JDATETOIDATE(JDATES(I)); CALL UTL_IDATETOGDATE(IDATE,IY,IM,ID) WRITE(*,'(I10,A1,I2.2,A1,I2.2,A1,I4)') JDATES(I),' ',ID,'-',IM,'-',IY ENDDO IF(.NOT.UTL_READINITFILE('NFILE',LINE,IU,0))RETURN READ(LINE,*) NFILE; WRITE(*,'(A,I10)') 'NFILE=',NFILE ALLOCATE(IPFFILE(NFILE)) DO I=1,NFILE IF(.NOT.UTL_READINITFILE('IPFFILE'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) IPFFILE(I); LINE='IPFFILE'//TRIM(VTOS(I))//'='//TRIM(IPFFILE(I)) WRITE(*,'(A)') TRIM(LINE) ENDDO IF(UTL_READINITFILE('ZONEIDF',LINE,IU,1))THEN IZONE=1 READ(LINE,*) ZONEIDF%FNAME; WRITE(*,'(A)') 'ZONEIDF='//TRIM(ZONEIDF%FNAME) !## read zones IF(.NOT.IDFREAD(ZONEIDF,ZONEIDF%FNAME,1))STOP !## get number of zones ALLOCATE(IP(ZONEIDF%NCOL*ZONEIDF%NROW)); IBAL=0; DO IROW=1,ZONEIDF%NROW; DO ICOL=1,ZONEIDF%NCOL; IBAL=IBAL+1; IP(IBAL)=INT(ZONEIDF%X(ICOL,IROW)); ENDDO; ENDDO CALL UTL_GETUNIQUE_INT(IP,ZONEIDF%NCOL*ZONEIDF%NROW,N,INT(ZONEIDF%NODATA)) WRITE(*,'(/1X,A,I10,A)') 'Found ',N,' unique zones' ELSE N=1 ENDIF ALLOCATE(BAL(N)) DO IBAL=1,SIZE(BAL); ALLOCATE(BAL(IBAL)%Q(NYR)); BAL(IBAL)%Q=0.0D0; ENDDO DO IBAL=1,SIZE(BAL) IF(IZONE.EQ.0)THEN WRITE(BAL(IBAL)%LABEL,'(A)') 'ZONE1' ELSE !## try to read label for balance IF(UTL_READINITFILE('LABEL'//TRIM(VTOS(IBAL)),LINE,IU,1))THEN READ(LINE,*) BAL(IBAL)%LABEL ELSE WRITE(BAL(IBAL)%LABEL,'(A)') 'ZONE'//TRIM(VTOS(IP(IBAL))) ENDIF WRITE(*,'(A)') 'LABEL'//TRIM(VTOS(IBAL))//'='//TRIM(BAL(IBAL)%LABEL) ENDIF ENDDO !## 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,*) (STRING(K),K=1,3) READ(STRING(1),*) X READ(STRING(2),*) Y CID=STRING(3) IF(IZONE.EQ.1)THEN CALL IDFIROWICOL(ZONEIDF,IROW,ICOL,X,Y) !## outside zone idf IF(IROW.LE.0.OR.ICOL.LE.0)CYCLE !## skip nodata IF(ZONEIDF%X(ICOL,IROW).EQ.ZONEIDF%NODATA)CYCLE !## skip outside zones DO IBAL=1,SIZE(BAL) IF(INT(ZONEIDF%X(ICOL,IROW)).EQ.IP(IBAL))EXIT ENDDO IF(IBAL.GT.SIZE(BAL))CYCLE ELSE IBAL=1 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 ALLOCATE(JDATE(0:NN+1),Q(0:NN+1)); JDATE=0; Q=0.0D0 JDATE(0)=UTL_IDATETOJDATE(SDATE) DO K=1,NN READ(KU,*) IDATED,Q(K); IDATED=UTL_COMPLETEDATE(IDATED) CALL UTL_IDATETOGDATE(IDATED,IYR,IMH,IDY,IHR,IMT,ISC) JDATE(K)=IYR*10000+IMH*100+IDY; JDATE(K)=UTL_IDATETOJDATE(JDATE(K)) ENDDO JDATE(NN+1)=UTL_IDATETOJDATE(EDATE)+1 DO K=0,NN !## fill in all periods DO IPER=1,NYR IF(JDATES(IPER-1).LT.JDATE(K+1).AND.JDATES(IPER).GT.JDATE(K))THEN D1=MAX(JDATES(IPER-1),JDATE(K)) D2=MIN(JDATES(IPER) ,JDATE(K+1)) DD=D2-D1 BAL(IBAL)%Q(IPER)=BAL(IBAL)%Q(IPER)+Q(K)*DD ENDIF ENDDO ENDDO DEALLOCATE(JDATE,Q); 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='REPLACE') WRITE(JU,'(99A)') 'Location Names',(','//TRIM(BAL(J)%LABEL),J=1,SIZE(BAL)) WRITE(JU,'(99A)') 'Date,Duration',(',Q_m3/d',J=1,SIZE(BAL)) DO IPER=1,NYR IDATE=UTL_JDATETOIDATE(JDATES(IPER-1)); CALL UTL_IDATETOGDATE(IDATE,IY,IM,ID) DD= (JDATES(IPER)-JDATES(IPER-1)) !+1 WRITE(JU,'(I4.4,2I2.2,1X,I4.4,1X,(99F10.2,1X))') IY,IM,ID,DD,(BAL(J)%Q(IPER)/REAL(DD,8),J=1,SIZE(BAL)) ENDDO CLOSE(JU) DO I=1,SIZE(BAL); DEALLOCATE(BAL(I)%Q); ENDDO END SUBROUTINE IMODBATCH_IPFSUM !###====================================================================== SUBROUTINE IMODBATCH_CREATEWELBORELOG() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: IPFNAME,DIR CHARACTER(LEN=52) :: ID TYPE(IDFOBJ) :: SURFLEVEL INTEGER :: I,JU,KU REAL(KIND=DP_KIND) :: XC,YC,TP,BT,SL IF(.NOT.UTL_READINITFILE('IPFFILE_IN',LINE,IU,0))RETURN READ(LINE,*) IPFNAME; WRITE(*,'(A)') 'IPFFILE_IN='//TRIM(IPFNAME) IF(.NOT.UTL_READINITFILE('SURFLEVEL',LINE,IU,0))RETURN READ(LINE,*) SURFLEVEL%FNAME; WRITE(*,'(A)') 'SURFLEVEL='//TRIM(SURFLEVEL%FNAME) IF(.NOT.IDFREAD(SURFLEVEL,SURFLEVEL%FNAME,0))STOP NIPF=1; CALL IPFALLOCATE() !## read twice DO I=1,NIPF IPF(I)%FNAME=IPFNAME; IPF(I)%XCOL=1; IPF(I)%YCOL=2; IPF(I)%ZCOL=4; IPF(I)%Z2COL=5; IPF(I)%QCOL=1; IF(.NOT.IPFREAD2(I,1,0))RETURN ENDDO IF(.NOT.UTL_READINITFILE('IPFFILE_OUT',LINE,IU,0))RETURN READ(LINE,*) IPFNAME; WRITE(*,'(A)') 'IPFFILE_OUT='//TRIM(IPFNAME) DIR=IPFNAME(:INDEX(IPFNAME,'\',.TRUE.)-1) JU=UTL_GETUNIT(); OPEN(JU,FILE=IPFNAME,STATUS='REPLACE',ACTION='WRITE') WRITE(JU,'(A)') TRIM(VTOS(IPF(1)%NROW)) WRITE(JU,'(A)') '6' WRITE(JU,'(A)') 'XC' WRITE(JU,'(A)') 'YC' WRITE(JU,'(A)') 'ID' WRITE(JU,'(A)') 'TP' WRITE(JU,'(A)') 'BT' WRITE(JU,'(A)') 'SL' WRITE(JU,'(A)') '3,TXT' DO I=1,IPF(1)%NROW XC=IPF(1)%XYZ(1,I) YC=IPF(1)%XYZ(2,I) TP=IPF(1)%XYZ(3,I) BT=IPF(1)%XYZ(4,I) SL=IDFGETXYVAL(SURFLEVEL,XC,YC) IF(SL.NE.SURFLEVEL%NODATA)THEN ID='WELLOC_'//TRIM(VTOS(I)) KU=UTL_GETUNIT(); OPEN(KU,FILE=TRIM(DIR)//'\'//TRIM(ID)//'.TXT',STATUS='REPLACE',ACTION='WRITE') WRITE(KU,'(A)') '3' WRITE(KU,'(A)') '2,2' WRITE(KU,'(A)') 'Z,-999.0' WRITE(KU,'(A)') 'L,-999.0' WRITE(KU,'(A)') TRIM(VTOS(SL,'F',2))//',P' WRITE(KU,'(A)') TRIM(VTOS(TP,'F',2))//',F' WRITE(KU,'(A)') TRIM(VTOS(BT,'F',2))//',-' CLOSE(KU) WRITE(JU,'(A)') TRIM(VTOS(XC,'F',2))//','//TRIM(VTOS(YC,'F',2))//','//TRIM(ID)//','//TRIM(VTOS(TP,'F',2))//','//TRIM(VTOS(BT,'F',2))//','//TRIM(VTOS(SL,'F',2)) ELSE WRITE(JU,'(A)') TRIM(VTOS(XC,'F',2))//','//TRIM(VTOS(YC,'F',2))//',NONE,'//TRIM(VTOS(TP,'F',2))//','//TRIM(VTOS(BT,'F',2))//','//TRIM(VTOS(SL,'F',2)) ENDIF ENDDO CLOSE(JU) END SUBROUTINE IMODBATCH_CREATEWELBORELOG !###====================================================================== SUBROUTINE IMODBATCH_IPFEDIT() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: IPFNAME CHARACTER(LEN=256),DIMENSION(:,:),POINTER :: EQUATION INTEGER :: NIF CHARACTER(LEN=10),ALLOCATABLE,DIMENSION(:) :: VARIABLES REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: VAL REAL(KIND=DP_KIND),POINTER,DIMENSION(:,:) :: LVAL LOGICAL,POINTER,DIMENSION(:,:) :: LEXX INTEGER :: NCOL,NQ,I,J,K,K1,K2,IOS,II,NVAR INTEGER,ALLOCATABLE,DIMENSION(:) :: IC,ECOL CHARACTER(LEN=52),DIMENSION(:),ALLOCATABLE :: CQ REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: RQ CHARACTER(LEN=52),DIMENSION(:),ALLOCATABLE :: ACHR LOGICAL :: LEX REAL(KIND=DP_KIND) :: X IF(.NOT.UTL_READINITFILE('IPFFILE_IN',LINE,IU,0))RETURN READ(LINE,*) IPFNAME; WRITE(*,'(A)') 'IPFFILE_IN='//TRIM(IPFNAME) NIPF=2; CALL IPFALLOCATE() !## read twice DO I=1,NIPF IPF(I)%FNAME=IPFNAME; IPF(I)%XCOL =1; IPF(I)%YCOL=2; IPF(I)%ZCOL=2; IPF(I)%Z2COL=2; IPF(I)%QCOL=2; IF(.NOT.IPFREAD2(I,1,0))RETURN ENDDO NQ=0; IF(UTL_READINITFILE('NQUERY',LINE,IU,1))THEN READ(LINE,*) NQ; WRITE(*,'(A,I10)') 'NQUERY=',NQ ALLOCATE(CQ(NQ),IC(NQ),RQ(NQ)); CQ='' DO I=1,NQ IF(.NOT.UTL_READINITFILE('IQUERY'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) CQ(I); WRITE(*,'(A)') 'IQUERY'//TRIM(VTOS(I))//'='//TRIM(CQ(I)) DO J=1,SIZE(OPER) K=INDEX(CQ(I),TRIM(OPER(J))) IF(K.EQ.0)CYCLE K1=K-1 K2=K+LEN_TRIM(OPER(J)) !## read column READ(CQ(I)(:K1),*) IC(I) !## get statement value READ(CQ(I)(K2:),*) RQ(I) CQ(I)=OPER(J) EXIT ENDDO IF(IC(I).LE.0.OR.IC(I).GT.IPF(1)%NCOL)THEN WRITE(*,'(/A/)') 'ERROR COLUMN NUMBER NEED TO BE >0 AND <='//TRIM(VTOS(IPF(1)%NCOL)); STOP ENDIF WRITE(*,'(A)') '>>> iMOD found: '//TRIM(VTOS(IC(I)))//' '//TRIM(CQ(I))//' '//TRIM(VTOS(RQ(I),'F',3)) ENDDO ENDIF !## process query IF(NQ.GT.0)THEN K=0; DO J=1,IPF(1)%NROW LEX=.FALSE. DO I=1,NQ READ(IPF(1)%INFO(IC(I),J),*,IOSTAT=IOS) X IF(IOS.NE.0)THEN WRITE(*,'(/A/)') '>>> Cannot evaluate value '//TRIM(IPF(1)%INFO(IC(I),J))//' <<<'; STOP ENDIF SELECT CASE (CQ(I)) CASE ('<>'); LEX=X.NE.RQ(I) CASE ('<='); LEX=X.LE.RQ(I) CASE ('>='); LEX=X.GE.RQ(I) CASE ('=') ; LEX=X.EQ.RQ(I) CASE ('<') ; LEX=X.LT.RQ(I) CASE ('>') ; LEX=X.GT.RQ(I) END SELECT !## not valid expression IF(.NOT.LEX)EXIT ENDDO IF(LEX)THEN K=K+1; IF(K.NE.J)THEN DO I=1,IPF(1)%NCOL; IPF(1)%INFO(I,K)=IPF(1)%INFO(I,J); ENDDO ENDIF ENDIF ENDDO IPF(1)%NROW=K DEALLOCATE(CQ,IC,RQ) ENDIF IF(UTL_READINITFILE('NVAR',LINE,IU,1))THEN READ(LINE,*) NVAR; WRITE(*,'(A)') 'NVAR='//TRIM(VTOS(NVAR)) ALLOCATE(VARIABLES(NVAR),ECOL(NVAR),VAL(NVAR)); ECOL=0; VARIABLES=''; J=64 DO I=1,SIZE(ECOL) J=J+1; IF(.NOT.UTL_READINITFILE('ICOL'//CHAR(J),LINE,IU,0))RETURN READ(LINE,*) ECOL(I); WRITE(*,'(A)') 'ICOL'//CHAR(J)//'='//TRIM(VTOS(ECOL(I))) VARIABLES(I)=CHAR(J); VARIABLES(I)=UTL_CAP(VARIABLES(I),'L') ENDDO !## read equation if needed CALL UTL_GET_EQUATIONS_DEFINE(EQUATION,VARIABLES,NIF,LEXX,LVAL) !## add additional column to save results CALL IPFCOPY(1,2,1,0) IPF(2)%ATTRIB(IPF(2)%NCOL)='RESULT' DO K=1,IPF(1)%NROW DO I=1,NVAR READ(IPF(1)%INFO(ECOL(I),K),*,IOSTAT=IOS) VAL(I) IF(IOS.NE.0)THEN WRITE(*,'(/A/)') '>>> Cannot evaluate value '//TRIM(IPF(1)%INFO(ECOL(I),K))//' <<<'; STOP ENDIF ENDDO !## conditional computation IF(NIF.GT.0)THEN !## evaluate table of functions I=1 DO DO J=1,3,2 IF(LEXX(I,J))THEN !## get function values LVAL(I,J)=EVALUATE(VAL,OP(I,J)%N,OP(I,J)%CNUMBER,OP(I,J)%CPDATA,OP(I,J)%COPERATIONS) ENDIF ENDDO !## evaluate logical condition (['<>','<=','>=','=','<','>']) SELECT CASE (EQUATION(I,2)) CASE ('1'); LEX=LVAL(I,1).NE.LVAL(I,3) CASE ('2'); LEX=LVAL(I,1).LE.LVAL(I,3) CASE ('3'); LEX=LVAL(I,1).GE.LVAL(I,3) CASE ('4'); LEX=LVAL(I,1).EQ.LVAL(I,3) CASE ('5'); LEX=LVAL(I,1).LT.LVAL(I,3) CASE ('6'); LEX=LVAL(I,1).GT.LVAL(I,3) END SELECT !## how to continue? IF(LEX)THEN !## first valid II=4 ELSE !## second valid II=5 ENDIF !## evaluate appropriate function IF(LEXX(I,II))THEN !## check whether there is an if-function IF(INDEX(EQUATION(I,II),'IF').GT.0)THEN !## go to the appropriate equation line READ(EQUATION(I,II)(3:),*) I ELSE !## get function values LVAL(I,II)=EVALUATE(VAL,OP(I,II)%N,OP(I,II)%CNUMBER,OP(I,II)%CPDATA,OP(I,II)%COPERATIONS) !## finished EXIT ENDIF ELSE !## finished EXIT ENDIF ENDDO X=LVAL(I,II) ELSE X=EVALUATE(VAL,OP(1,1)%N,OP(1,1)%CNUMBER,OP(1,1)%CPDATA,OP(1,1)%COPERATIONS) ENDIF !## save results WRITE(IPF(2)%INFO(IPF(2)%NCOL,K),*) X; IPF(2)%INFO(IPF(2)%NCOL,K)=ADJUSTL(IPF(2)%INFO(IPF(2)%NCOL,K)) ENDDO CALL IPFCOPY(2,1,0,0) DEALLOCATE(VARIABLES,ECOL) ENDIF NCOL=0; IF(UTL_READINITFILE('NCOLUMNS',LINE,IU,1))THEN READ(LINE,*) NCOL; WRITE(*,'(A,I10)') 'NCOLUMNS=',NCOL ALLOCATE(IC(NCOL)); IC=0 !## nothing to add ALLOCATE(ACHR(NCOL)); ACHR='' DO I=1,NCOL IF(.NOT.UTL_READINITFILE('ICOL'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) IC(I); WRITE(*,'(A)') 'ICOL'//TRIM(VTOS(I))//'='//TRIM(VTOS(IC(I))) IF(IC(I).LE.0.OR.IC(I).GT.IPF(1)%NCOL)THEN WRITE(*,'(/A/)') 'ERROR COLUMN NUMBER NEED TO BE >0 AND <='//TRIM(VTOS(IPF(1)%NCOL)); STOP ENDIF IF(UTL_READINITFILE('ACHR'//TRIM(VTOS(I)),LINE,IU,1))THEN READ(LINE,*) ACHR(I); WRITE(*,'(A)') 'ACHR'//TRIM(VTOS(I))//'='//TRIM(ACHR(I)) ENDIF ENDDO ENDIF !## shuffle columns IF(NCOL.NE.0)THEN DO I=1,NCOL; IPF(2)%ATTRIB(I)=IPF(1)%ATTRIB(IC(I)); ENDDO; IPF(2)%NCOL=NCOL; IPF(2)%NROW=IPF(1)%NROW DO J=1,IPF(1)%NROW DO I=1,NCOL IPF(2)%INFO(I,J)=TRIM(IPF(1)%INFO(IC(I),J))//TRIM(ACHR(I)) ENDDO ENDDO IPF(2)%ACOL=0; DO I=1,NCOL; IF(IPF(1)%ACOL.EQ.IC(I))THEN; IPF(2)%ACOL=I; EXIT; ENDIF; ENDDO ENDIF IF(.NOT.UTL_READINITFILE('IPFFILE_OUT',LINE,IU,0))RETURN READ(LINE,*) IPFNAME; WRITE(*,'(A)') 'IPFFILE_OUT='//TRIM(IPFNAME) CALL UTL_CREATEDIR(IPFNAME(:INDEX(IPFNAME,'\',.TRUE.)-1)) IF(NCOL.NE.0)THEN IPF(2)%FNAME=IPFNAME; IF(.NOT.IPFWRITE(2))THEN; ENDIF; ELSE IPF(1)%FNAME=IPFNAME; IF(.NOT.IPFWRITE(1))THEN; ENDIF; ENDIF CALL IPFDEALLOCATE() IF(ALLOCATED(OP))THEN DO I=1,SIZE(OP,1); DO J=1,SIZE(OP,2) IF(J.EQ.2)CYCLE IF(.NOT.LEXX(I,J))CYCLE !## skip if-statements IF(INDEX(EQUATION(I,J),'IF').GT.0)CYCLE DEALLOCATE(OP(I,J)%CNUMBER) DEALLOCATE(OP(I,J)%CPDATA) DEALLOCATE(OP(I,J)%COPERATIONS) ENDDO; ENDDO DEALLOCATE(OP) ENDIF END SUBROUTINE IMODBATCH_IPFEDIT !###====================================================================== SUBROUTINE IMODBATCH_AGGREGATE() !###====================================================================== USE MOD_AGGREGATE_PAR IMPLICIT NONE INTEGER :: OBSIROW,OBSICOL IPRJ=0; IWINDOW=0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN IWINDOW=1; READ(LINE,*) XMIN,YMIN,XMAX,YMAX WRITE(*,'(A,4F15.3)') 'WINDOW=',XMIN,YMIN,XMAX,YMAX IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,0))RETURN READ(LINE,*) CELLSIZE; WRITE(*,'(A,F15.3)') 'CELLSIZE=',CELLSIZE ENDIF !## read ini-file IF(.NOT.UTL_READINITFILE('SORTFILE',LINE,IU,0))RETURN READ(LINE,*) SORTFILE; WRITE(*,'(A)') 'SORTFILE='//TRIM(SORTFILE) IF(.NOT.UTL_READINITFILE('INDIR',LINE,IU,0))RETURN READ(LINE,*) INDIR; WRITE(*,'(A)') 'INDIR='//TRIM(INDIR) IF(.NOT.UTL_READINITFILE('IMODE',LINE,IU,0))RETURN READ(LINE,*) IMODE; WRITE(*,'(A)') 'IMODE='//TRIM(VTOS(IMODE)) SELECT CASE (IMODE) CASE (1) !## make consistent model CASE (2) !## include iwhb maps IF(.NOT.UTL_READINITFILE('IWHBFILE',LINE,IU,0))RETURN READ(LINE,*) IWHBFILE; WRITE(*,'(A)') 'IWHBFILE='//TRIM(IWHBFILE) IF(.NOT.UTL_READINITFILE('IWHBDIR',LINE,IU,0))RETURN READ(LINE,*) IWHBDIR; WRITE(*,'(A)') 'IWHBDIR='//TRIM(IWHBDIR) OBSIROW=0; IF(UTL_READINITFILE('OBSIROW',LINE,IU,1))THEN READ(LINE,*) OBSIROW; WRITE(*,'(A)') 'OBSIROW='//TRIM(VTOS(OBSIROW)) ENDIF OBSICOL=0; IF(UTL_READINITFILE('OBSICOL',LINE,IU,1))THEN READ(LINE,*) OBSICOL; WRITE(*,'(A)') 'OBSICOL='//TRIM(VTOS(OBSICOL)) ENDIF CASE (3) !## aggregate IF(UTL_READINITFILE('IPRJ',LINE,IU,1))READ(LINE,*) IPRJ WRITE(*,'(A)') 'IPRJ='//TRIM(VTOS(IPRJ)) IF(.NOT.UTL_READINITFILE('CMIN',LINE,IU,0))RETURN READ(LINE,*) CMIN; WRITE(*,'(A)') 'CMIN='//TRIM(VTOS(CMIN,'F',3)) END SELECT !## output folder IF(.NOT.UTL_READINITFILE('OUTDIR',LINE,IU,0))RETURN READ(LINE,*) OUTDIR; WRITE(*,'(A)') 'OUTDIR='//TRIM(OUTDIR) CALL LHM_CONVERTREGIS_MAIN(OBSICOL,OBSIROW) END SUBROUTINE IMODBATCH_AGGREGATE !###====================================================================== SUBROUTINE IMODBATCH_IPFEDITWEIGHT() !###====================================================================== IMPLICIT NONE TYPE(IDFOBJ) :: IDF CHARACTER(LEN=256) :: IPFNAME,POINTERIDF INTEGER :: WCOL,IOS,I REAL(KIND=DP_KIND) :: PVAL,FACTOR_IN,FACTOR_OUT,X,WEIGHT !## read ini-file IF(.NOT.UTL_READINITFILE('IPFFILE_IN',LINE,IU,0))RETURN READ(LINE,*) IPFNAME; WRITE(*,'(A)') 'IPFFILE_IN='//TRIM(IPFNAME) NIPF=2; CALL IPFALLOCATE() !## read in ipf-file !## read twice to be able to write new ipf-file DO I=1,NIPF IPF(I)%FNAME=IPFNAME; IPF(I)%XCOL =1; IPF(I)%YCOL=2; IPF(I)%ZCOL=2; IPF(I)%Z2COL=2; IPF(I)%QCOL=2; IF(.NOT.IPFREAD2(I,1,0))RETURN ENDDO !## get column with weight factor from ipf file IF(.NOT.UTL_READINITFILE('WCOL',LINE,IU,0))RETURN READ(LINE,*) WCOL; WRITE(*,'(A,I10)') 'WCOL=',WCOL !## read in pointer-file and pointer value to be used !## default=1.0 for pointer value IF(.NOT.UTL_READINITFILE('PVAL',LINE,IU,0))RETURN PVAL=1.0; READ(LINE,*) PVAL; WRITE(*,'(A,F10.3)') 'PVAL=',PVAL IF(.NOT.UTL_READINITFILE('POINTERIDF',LINE,IU,0))RETURN READ(LINE,*) POINTERIDF; WRITE(*,'(A)') 'POINTERIDF='//TRIM(POINTERIDF) IF(.NOT.IDFREAD(IDF,POINTERIDF,0))THEN; WRITE(*,'(A)') 'Cannot read '//TRIM(POINTERIDF); STOP; ENDIF !## read factor to be applied to locations outside of pointer grid !## default=1.0 IF(.NOT.UTL_READINITFILE('FACTOR_IN',LINE,IU,0))RETURN FACTOR_IN=1.0; READ(LINE,*) FACTOR_IN; WRITE(*,'(A,F10.3)') 'FACTOR_IN=',FACTOR_IN !## read factor to be applied to locations inside of pointer grid !## default=1.0 IF(.NOT.UTL_READINITFILE('FACTOR_OUT',LINE,IU,0))RETURN FACTOR_OUT=1.0; READ(LINE,*) FACTOR_OUT; WRITE(*,'(A,F10.3)') 'FACTOR_OUT=',FACTOR_OUT !## main routine !## loop over cells in pointer idf (if not equal to nodata and equal to pval) DO I=1,IPF(1)%NROW X=IDFGETXYVAL(IDF,IPF(1)%XYZ(1,I),IPF(1)%XYZ(2,I)) READ(IPF(2)%INFO(WCOL,I),*,IOSTAT=IOS) WEIGHT IF(IOS.EQ.0)THEN IF(X.NE.IDF%NODATA.AND.X.EQ.PVAL)THEN !## location lays inside pointer area IPF(2)%INFO(WCOL,I)=VTOS(FACTOR_IN*WEIGHT,'F',3) ELSE !## location lays outside pointer area IPF(2)%INFO(WCOL,I)=VTOS(FACTOR_OUT*WEIGHT,'F',3) ENDIF ELSE WRITE(*,*) 'Column '//TRIM(VTOS(WCOL))//' does not contain a weight value. Please check your input ipf-file!'; STOP ENDIF ENDDO !## write new ipf file IF(.NOT.UTL_READINITFILE('IPFFILE_OUT',LINE,IU,0))RETURN READ(LINE,*) IPFNAME; WRITE(*,'(A)') 'IPFFILE_OUT='//TRIM(IPFNAME) CALL UTL_CREATEDIR(IPFNAME(:INDEX(IPFNAME,'\',.TRUE.)-1)) IPF(2)%FNAME=IPFNAME; IF(.NOT.IPFWRITE(2))THEN; ENDIF; CALL IPFDEALLOCATE() END SUBROUTINE IMODBATCH_IPFEDITWEIGHT !###====================================================================== SUBROUTINE IMODBATCH_CREATEIZONE() !###====================================================================== IMPLICIT NONE INTEGER :: I,NFORMATIONS,NLAY,IZONEOFFSET,IGROUPOFFSET,OUTPUTTYPE CHARACTER(LEN=256),ALLOCATABLE,DIMENSION(:) :: FIDF CHARACTER(LEN=12) :: ACRONYM INTEGER,ALLOCATABLE,DIMENSION(:) :: LIDF CHARACTER(LEN=15),ALLOCATABLE,DIMENSION(:) :: GRPN CHARACTER(LEN=256) :: PFOLDER,OFOLDER,TPARAMETER INTEGER,POINTER,DIMENSION(:) :: LAYER REAL(KIND=DP_KIND) :: MINF TYPE(IDFOBJ) :: SUBDIVIDE CALL IDFNULLIFY(SUBDIVIDE) IF(.NOT.UTL_READINITFILE('OFOLDER',LINE,IU,0))RETURN READ(LINE,*) OFOLDER; WRITE(*,'(A)') 'OFOLDER='//TRIM(OFOLDER) IF(UTL_READINITFILE('NLAY',LINE,IU,1))THEN READ(LINE,*) NLAY; WRITE(*,'(A,I10)') 'NLAY=',NLAY ALLOCATE(LAYER(NLAY)); DO I=1,NLAY; LAYER(I)=I; ENDDO ELSE IF(.NOT.UTL_READPOINTER(IU,NLAY,LAYER,'LAYER',0))RETURN ENDIF 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('TPARAMETER',LINE,IU,0))RETURN READ(LINE,*) TPARAMETER; WRITE(*,'(A)') 'TPARAMETER='//TRIM(TPARAMETER) OUTPUTTYPE=0 IF(.NOT.UTL_READINITFILE('OUTPUTTYPE',LINE,IU,0))RETURN READ(LINE,*) OUTPUTTYPE; WRITE(*,'(A)') 'OUTPUTTYPE='//TRIM(VTOS(OUTPUTTYPE)) IF(UTL_READINITFILE('PFOLDER',LINE,IU,1))THEN READ(LINE,*) PFOLDER; WRITE(*,'(A)') 'PFOLDER='//TRIM(PFOLDER) IF(.NOT.UTL_READINITFILE('MINF',LINE,IU,0))RETURN READ(LINE,*) MINF; WRITE(*,'(A,F10.3)') 'MINF=',MINF SUBDIVIDE%FNAME=''; IF(UTL_READINITFILE('SUBDIVIDE',LINE,IU,1))THEN READ(LINE,*) SUBDIVIDE%FNAME; LINE='SUBDIVIDE='//TRIM(SUBDIVIDE%FNAME); WRITE(*,'(A)') TRIM(LINE) ENDIF IF(.NOT.UTL_READINITFILE('NFORMATIONS',LINE,IU,0))RETURN READ(LINE,*) NFORMATIONS; WRITE(*,'(A,I10)') 'NFORMATIONS=',NFORMATIONS ALLOCATE(FIDF(NFORMATIONS),GRPN(NFORMATIONS)) DO I=1,NFORMATIONS IF(.NOT.UTL_READINITFILE('FORMATION'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) FIDF(I); LINE='FORMATION'//TRIM(VTOS(I))//'='//TRIM(FIDF(I)); WRITE(*,'(A)') TRIM(LINE) GRPN(I)=FIDF(I)(:INDEX(FIDF(I),'.',.TRUE.)-1) IF(UTL_READINITFILE('GRPNAME'//TRIM(VTOS(I)),LINE,IU,1))READ(LINE,*) GRPN(I) LINE='GRPNAME'//TRIM(VTOS(I))//'='//TRIM(GRPN(I)); WRITE(*,'(A)') TRIM(LINE) ENDDO CALL CREATEIZONE_MAIN(FIDF,PFOLDER,OFOLDER,TPARAMETER,NLAY,MINF,IZONEOFFSET,IGROUPOFFSET,SUBDIVIDE,LAYER,GRPN,OUTPUTTYPE) ELSE ALLOCATE(FIDF(NLAY),LIDF(NLAY)) ACRONYM=''; IF(UTL_READINITFILE('ACRONYM',LINE,IU,1))THEN READ(LINE,*) ACRONYM; WRITE(*,'(A)') 'ACRONYM='//TRIM(ACRONYM) ENDIF DO I=1,NLAY IF(.NOT.UTL_READINITFILE('LITHO_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) FIDF(I) LINE='LITHO_L'//TRIM(VTOS(I))//'='//TRIM(FIDF(I)); WRITE(*,'(A)') TRIM(LINE) IF(UTL_READINITFILE('ILS_L'//TRIM(VTOS(I)),LINE,IU,1))THEN READ(LINE,*) LIDF(I); WRITE(*,'(A,I10)') 'ILS_L'//TRIM(VTOS(I)),LIDF(I) ELSE LIDF(I)=I ENDIF ENDDO CALL CREATEIZONE_LITHOS(FIDF,LIDF,ACRONYM,OFOLDER,TPARAMETER,NLAY,IZONEOFFSET,IGROUPOFFSET,OUTPUTTYPE) ENDIF DEALLOCATE(FIDF,LAYER) 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(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) IFCOL(I) LINE='FORMATION'//TRIM(VTOS(I))//'='//TRIM(VTOS(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(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) TOPIDF(I)%FNAME LINE='TOP_L'//TRIM(VTOS(I))//'='//TRIM(TOPIDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('BOT_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) BOTIDF(I)%FNAME LINE='BOT_L'//TRIM(VTOS(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(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) TOPIDF(I)%FNAME LINE='TOP_L'//TRIM(VTOS(I))//'='//TRIM(TOPIDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('BOT_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) BOTIDF(I)%FNAME LINE='BOT_L'//TRIM(VTOS(I))//'='//TRIM(BOTIDF(I)%FNAME); WRITE(*,'(A)') TRIM(LINE) IF(I.LT.NLAY)THEN IF(.NOT.UTL_READINITFILE('C_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) CIDF(I)%FNAME LINE='C_L'//TRIM(VTOS(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.0D0; MDLIDF%YMIN=0.0D0; MDLIDF%XMAX=0.0D0; MDLIDF%YMAX=0.0D0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) MDLIDF%XMIN,MDLIDF%YMIN,MDLIDF%XMAX,MDLIDF%YMAX WRITE(*,'(A,4F15.3)') 'WINDOW=',MDLIDF%XMIN,MDLIDF%YMIN,MDLIDF%XMAX,MDLIDF%YMAX IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,0))RETURN READ(LINE,*) MDLIDF%DX; WRITE(*,'(A,F15.3)') 'CELLSIZE=',MDLIDF%DX MDLIDF%DY=MDLIDF%DX ENDIF IF(SOLID_WVP())THEN; ENDIF END SUBROUTINE IMODBATCH_WVP !###====================================================================== SUBROUTINE IMODBATCH_SOLID() !###====================================================================== USE MOD_SOLID_PAR IMPLICIT NONE INTEGER :: IHYPO,ICKDC,I,J,FNLAY REAL(KIND=DP_KIND) :: ZOFFSET IWINDOW=0; HCLOSE=0.01D0; MICNVG=5; FMIDELEV=1.0D0; IBNDCHK=0; SOL_IINT_IDF=1 !## usage of top/bottom aquitards 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) !## try to read all idf's J=0 DO I=1,SLD(1)%NINT/2 IF(.NOT.UTL_READINITFILE('TOP_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN J=J+1 READ(LINE,*) SLD(1)%INTNAME(J) LINE='TOP_L'//TRIM(VTOS(I))//'='//TRIM(SLD(1)%INTNAME(J)); WRITE(*,'(A)') TRIM(LINE) SLD(1)%ICLC(J)=0; IF(UTL_READINITFILE('ICLC_TL'//TRIM(VTOS(I)),LINE,IU,1))READ(LINE,*) SLD(1)%ICLC(J) LINE='ICLC_TL'//TRIM(VTOS(I))//'='//TRIM(VTOS(SLD(1)%ICLC(J))); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('BOT_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN J=J+1 READ(LINE,*) SLD(1)%INTNAME(J) LINE='BOT_L'//TRIM(VTOS(I))//'='//TRIM(SLD(1)%INTNAME(J)); WRITE(*,'(A)') TRIM(LINE) SLD(1)%ICLC(J)=0; IF(UTL_READINITFILE('ICLC_BL'//TRIM(VTOS(I)),LINE,IU,1))READ(LINE,*) SLD(1)%ICLC(J) LINE='ICLC_BL'//TRIM(VTOS(I))//'='//TRIM(VTOS(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.0D0; MDLIDF%YMIN=0.0D0; MDLIDF%XMAX=0.0D0; MDLIDF%YMAX=0.0D0; IWINDOW=0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) MDLIDF%XMIN,MDLIDF%YMIN,MDLIDF%XMAX,MDLIDF%YMAX WRITE(*,'(A,4F15.3)') 'WINDOW=',MDLIDF%XMIN,MDLIDF%YMIN,MDLIDF%XMAX,MDLIDF%YMAX IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,0))RETURN READ(LINE,*) MDLIDF%DX; WRITE(*,'(A,F15.3)') '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(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) REGISFILES_TOP(I) LINE='FTOP_L'//TRIM(VTOS(I))//'='//TRIM(REGISFILES_TOP(I)); WRITE(*,'(A)') TRIM(LINE) !## read bot formation IF(.NOT.UTL_READINITFILE('FBOT_L'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) REGISFILES_BOT(I) LINE='FBOT_L'//TRIM(VTOS(I))//'='//TRIM(REGISFILES_BOT(I)); WRITE(*,'(A)') TRIM(LINE) !## read optional khv formation IF(UTL_READINITFILE('FKHV_L'//TRIM(VTOS(I)),LINE,IU,1))READ(LINE,*) REGISFILES_KHV(I) LINE='FKHV_L'//TRIM(VTOS(I))//'='//TRIM(REGISFILES_KHV(I)); WRITE(*,'(A)') TRIM(LINE) !## read optional kvv formation IF(UTL_READINITFILE('FKVV_L'//TRIM(VTOS(I)),LINE,IU,1))READ(LINE,*) REGISFILES_KVV(I) LINE='FKVV_L'//TRIM(VTOS(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 ALLOCATE(DZ(SLD(1)%NINT)); DZ=0.0D0 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.0D0 ENDDO !## 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,*) SOL_IINT_IDF WRITE(*,'(A,I1)') 'IINT_IDF=',SOL_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_FNAME_'//TRIM(VTOS(I)),LINE,IU,0))RETURN; READ(LINE,*) GENSOL(I)%FNAME LINE='GEN_FNAME_'//TRIM(VTOS(I))//'='//TRIM(GENSOL(I)%FNAME) WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('GEN_LAYER_'//TRIM(VTOS(I)),LINE,IU,0))RETURN; READ(LINE,*) GENSOL(I)%ILAY LINE='GEN_LAYER_'//TRIM(VTOS(I))//'='//TRIM(VTOS(GENSOL(I)%ILAY)) 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(IHYPO))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) IF(ALLOCATED(DZ))DEALLOCATE(DZ) END SUBROUTINE IMODBATCH_SOLID !###====================================================================== SUBROUTINE IMODBATCH_MODELCOPY_MAIN() !###====================================================================== USE MOD_MODEL_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.0D0; SIMCSIZE=0.0D0 IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) SIMBOX(1),SIMBOX(2),SIMBOX(3),SIMBOX(4) WRITE(*,'(A,4F15.3)') 'WINDOW=',SIMBOX(1),SIMBOX(2),SIMBOX(3),SIMBOX(4) IF(UTL_READINITFILE('CELL_SIZE',LINE,IU,1))THEN READ(LINE,*) SIMCSIZE; WRITE(*,'(A,F10.2)') 'CELL_SIZE=',SIMCSIZE IF(SIMCSIZE.LE.0.0D0)STOP 'SIMCSIZE NEED TO BE LARGER THAN ZERO !' ENDIF 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() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: IPFNAME_IN,IPFNAME_OUT,FNAME,DIR INTEGER :: I,J,JJ,KU,JU,LU,NVARS,MINMEASURE,M,N,NPERC,ITXTFILE,IC INTEGER(KIND=SP_KIND) :: SDATE,EDATE,NGXG,DIFFDAY,ICLUSTER,WCOLUMN,NW,IACOL INTEGER,POINTER,DIMENSION(:) :: IVARS REAL(KIND=DP_KIND) :: X,GHG,GLG,NODATA,W,TW REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: MSR REAL(KIND=DP_KIND),POINTER,DIMENSION(:) :: PERC INTEGER,ALLOCATABLE,DIMENSION(:) :: JDT,JDP,ILIST CHARACTER(LEN=3),DIMENSION(5) :: CVARS DATA CVARS/'MIN','MAX','AVG','GXG','PER'/ TYPE(IDFOBJ) :: SURFACELEVEL REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: XPERC MINMEASURE=24; DIFFDAY=5; NODATA=-999.99D0; ICLUSTER=0; ITXTFILE=0; RANGE=0.0D0; WCOLUMN=0;IACOL=2 IF(.NOT.UTL_READINITFILE('IPFFILE_IN',LINE,IU,0))RETURN READ(LINE,*) IPFNAME_IN; WRITE(*,'(A)') 'IPFFILE_IN='//TRIM(IPFNAME_IN) DIR=IPFNAME_IN(:INDEX(IPFNAME_IN,'\',.TRUE.)-1) IF(.NOT.UTL_READINITFILE('IPFFILE_OUT',LINE,IU,0))RETURN READ(LINE,*) IPFNAME_OUT; WRITE(*,'(A)') 'IPFFILE_OUT='//TRIM(IPFNAME_OUT) IF(.NOT.UTL_READINITFILE('SDATE',LINE,IU,0))RETURN READ(LINE,*) SDATE; WRITE(*,'(A)') 'SDATE='//TRIM(VTOS(SDATE)) IF(.NOT.UTL_READINITFILE('EDATE',LINE,IU,0))RETURN READ(LINE,*) EDATE; WRITE(*,'(A)') 'EDATE='//TRIM(VTOS(EDATE)) SDATE=UTL_IDATETOJDATE(SDATE); EDATE=UTL_IDATETOJDATE(EDATE) IF(UTL_READINITFILE('ICLUSTER',LINE,IU,1))READ(LINE,*) ICLUSTER WRITE(*,'(A)') 'ICLUSTER='//TRIM(VTOS(ICLUSTER)) IF(ICLUSTER.EQ.1)THEN IF(UTL_READINITFILE('RANGE',LINE,IU,1))READ(LINE,*) RANGE WRITE(*,'(A)') 'RANGE='//TRIM(VTOS(RANGE,'F',3)) IF(UTL_READINITFILE('IWCOL',LINE,IU,1))READ(LINE,*) WCOLUMN WRITE(*,'(A)') 'IWCOL='//TRIM(VTOS(WCOLUMN)) ENDIF IF(UTL_READINITFILE('IACOL',LINE,IU,1))READ(LINE,*) IACOL WRITE(*,'(A)') 'IACOL='//TRIM(VTOS(IACOL)) IF(IACOL.LE.1)THEN; WRITE(*,'(A)')'It is not allowed to use IACOL=1 for processing'; STOP; ENDIF IF(.NOT.UTL_READPOINTER(IU,NVARS,IVARS,'IVARS',0))RETURN DO I=1,NVARS; WRITE(*,'(1X,I3,A4)') I,','//CVARS(IVARS(I)); ENDDO !## check for duplicates for ivars DO I=1,NVARS J=IVARS(I) DO JJ=I+1,NVARS IF(IVARS(I).EQ.IVARS(JJ))THEN; WRITE(*,'(A)') 'Duplicate IVARS='//TRIM(VTOS(IVARS(I)))//' given'; STOP; ENDIF ENDDO ENDDO NGXG=0; NPERC=0 DO I=1,NVARS IF(IVARS(I).EQ.5)THEN IF(.NOT.UTL_READPOINTER(IU,NPERC,PERC,'PERC',0,EXCLVALUE=-999.99D0))RETURN DO J=1,SIZE(PERC) IF(PERC(J).LT.0.0D0.OR.PERC(J).GT.100.0D0)THEN LINE='PERC('//TRIM(VTOS(J))//')='//TRIM(VTOS(PERC(J),'F',3)); WRITE(*,'(A)') TRIM(LINE)//' which is not allowed'; STOP ENDIF ENDDO ALLOCATE(XPERC(NPERC),JDP(0:NPERC)); XPERC=0.0D0; JDP=0 IF(UTL_READINITFILE('ITXTFILE',LINE,IU,1))THEN READ(LINE,*) ITXTFILE; WRITE(*,'(A)') 'ITXTFILE='//TRIM(VTOS(ITXTFILE)) ENDIF JDP(0)=JD(2000,12,31); DO J=1,NPERC; JDP(J)=JDP(J-1)+INT(PERC(J)); ENDDO ELSEIF(IVARS(I).EQ.4)THEN NGXG=NGXG+1 IF(UTL_READINITFILE('SURFACELEVEL',LINE,IU,1))THEN READ(LINE,*) SURFACELEVEL%FNAME; WRITE(*,'(A)') 'SURFACELEVEL=',TRIM(SURFACELEVEL%FNAME) ENDIF IF(UTL_READINITFILE('MINMEASURE',LINE,IU,1))READ(LINE,*) MINMEASURE WRITE(*,'(A)') 'MINMEASURE='//TRIM(VTOS(MINMEASURE)) IF(UTL_READINITFILE('DIFFDAY',LINE,IU,1))READ(LINE,*) DIFFDAY WRITE(*,'(A)') 'DIFFDAY='//TRIM(VTOS(DIFFDAY)) ENDIF ENDDO NIPF=1; CALL IPFALLOCATE(); IPF(1)%FNAME=IPFNAME_IN IPF(1)%XCOL =1; IPF(1)%YCOL=2; IPF(1)%ZCOL=2; IPF(1)%Z2COL=2; IPF(1)%QCOL=2 IF(.NOT.IPFREAD2(1,1,0))RETURN !## open new file JU=UTL_GETUNIT(); OPEN(JU,FILE=IPFNAME_OUT,STATUS='REPLACE',ACTION='WRITE') WRITE(JU,*) IPF(1)%NROW N=IPF(1)%NCOL+NVARS+1+NGXG; IF(NPERC.GT.1)N=N+(NPERC-1) WRITE(JU,*) N DO I=1,IPF(1)%NCOL; WRITE(JU,'(A)') TRIM(IPF(1)%ATTRIB(I)); ENDDO DO I=1,NVARS SELECT CASE (IVARS(I)) CASE(4) WRITE(JU,'(A)') 'GHG'; WRITE(JU,'(A)') 'GLG' CASE(5) DO JJ=1,NPERC; WRITE(JU,'(A)') 'P'//TRIM(VTOS(PERC(JJ),'F',3)); ENDDO CASE DEFAULT WRITE(JU,'(A)') TRIM(CVARS(IVARS(I))) END SELECT ENDDO IF(ICLUSTER.EQ.0)WRITE(JU,'(A)') 'N' IF(ICLUSTER.GE.1)WRITE(JU,'(A)') 'WEIGHT' WRITE(JU,*) IPF(1)%ACOL,','//TRIM(IPF(1)%FEXT) !## store each drill in memory for picking purposes CALL IPFASSFILEALLOCATE(1) !## proces locations DO I=1,IPF(1)%NROW !## read dimensions of associated file FNAME=TRIM(DIR)//'\'//TRIM(IPF(1)%INFO(IPF(1)%ACOL,I))//'.'//TRIM(ADJUSTL(IPF(1)%FEXT)) IF(IPFOPENASSFILE(KU,1,FNAME))THEN !## raise error if iacol > then amount of columns available in associated text-file and stop loop IF(IACOL.GT.ASSF(1)%NCASS)THEN; WRITE(*,*) 'Error: IACOL ('//TRIM(VTOS(IACOL))//') > the amount of available columns ('//TRIM(VTOS(ASSF(1)%NCASS))//') in associated text files'; RETURN; ENDIF !## not measurements found IF(ASSF(1)%ITOPIC.NE.1)CYCLE IF(IPFREADASSFILELABEL(KU,1,FNAME).AND.IPFREADASSFILE(KU,1,FNAME))THEN !## look for overlapping dates ALLOCATE(JDT(ASSF(1)%NRASS),MSR(ASSF(1)%NRASS)) N=0 DO JJ=1,ASSF(1)%NRASS IF(ASSF(1)%IDATE(JJ).GE.SDATE.AND.ASSF(1)%IDATE(JJ).LE.EDATE)THEN IF(ASSF(1)%MEASURE(IACOL-1,JJ) .NE.ASSF(1)%NODATA(2))THEN N=N+1 JDT(N)=ASSF(1)%IDATE(JJ) MSR(N)=ASSF(1)%MEASURE(IACOL-1,JJ) ENDIF ENDIF ENDDO !## process statistics LINE='' DO J=1,NVARS IF(N.EQ.0)THEN X=NODATA SELECT CASE (IVARS(J)) !## gxg CASE (4) LINE=TRIM(LINE)//','//TRIM(VTOS(X,'F',3)) LINE=TRIM(LINE)//','//TRIM(VTOS(X,'F',3)) !## perc CASE (5) DO JJ=1,NPERC; LINE=TRIM(LINE)//','//TRIM(VTOS(X,'F',3)); ENDDO !## write txt file IF(ITXTFILE.EQ.1)THEN FNAME=TRIM(DIR)//'\'//TRIM(IPF(1)%INFO(IPF(1)%ACOL,I))//'_PERCENTILES.'//TRIM(ADJUSTL(IPF(1)%FEXT)) LU=UTL_GETUNIT(); OPEN(LU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE') WRITE(LU,'(A)') '0' WRITE(LU,'(A)') '2,1' WRITE(LU,'(A)') 'DATE,-999.99' WRITE(LU,'(A)') 'OBS,-999.99' CLOSE(LU) ENDIF CASE DEFAULT LINE=TRIM(LINE)//','//TRIM(VTOS(X,'F',3)) END SELECT ELSE SELECT CASE (IVARS(J)) !## min CASE (1) X=HUGE(1.0D0); DO JJ=1,N; X=MIN(X,MSR(JJ)); ENDDO; LINE=TRIM(LINE)//','//TRIM(VTOS(X,'F',3)) !## max CASE (2) X=-1.0D0*HUGE(1.0D0); DO JJ=1,N; X=MAX(X,MSR(JJ)); ENDDO; LINE=TRIM(LINE)//','//TRIM(VTOS(X,'F',3)) !## avg CASE (3) X=0.0D0; DO JJ=1,N; X=X+MSR(JJ); ENDDO; X=X/REAL(N,8) LINE=TRIM(LINE)//','//TRIM(VTOS(X,'F',3)) !## gxg CASE (4) CALL GXG_COMPUTE_SERIE(JDT(:N),MSR(:N),GHG,GLG,MINMEASURE,DIFFDAY,NODATA) LINE=TRIM(LINE)//','//TRIM(VTOS(GHG,'F',3)) LINE=TRIM(LINE)//','//TRIM(VTOS(GLG,'F',3)) !## per CASE (5) CALL UTL_GETMED(MSR,N,-999.99D0,PERC,NPERC,M,XPERC) DO JJ=1,NPERC; LINE=TRIM(LINE)//','//TRIM(VTOS(XPERC(JJ),'F',3)); ENDDO !## write txt file IF(ITXTFILE.EQ.1)THEN FNAME=TRIM(DIR)//'\'//TRIM(IPF(1)%INFO(IPF(1)%ACOL,I))//'_PERCENTILES.'//TRIM(ADJUSTL(IPF(1)%FEXT)) LU=UTL_GETUNIT(); OPEN(LU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE') WRITE(LU,'(I10)') NPERC WRITE(LU,'(A)') '2,1' WRITE(LU,'(A)') 'DATE,-999.99' WRITE(LU,'(A)') 'OBS,-999.99' DO JJ=1,NPERC WRITE(LU,'(A,F15.3)') UTL_JDATETOGDATE(JDP(JJ),2),XPERC(JJ) ENDDO CLOSE(LU) ENDIF END SELECT ENDIF ENDDO IF(ICLUSTER.EQ.0)THEN LINE=TRIM(LINE)//','//TRIM(VTOS(N)) ELSE W=SQRT(REAL(N,8)) LINE=TRIM(LINE)//','//TRIM(VTOS(W,'G',7)) ENDIF IF(ITXTFILE.EQ.1)IPF(1)%INFO(IPF(1)%ACOL,I)=TRIM(IPF(1)%INFO(IPF(1)%ACOL,I))//'_PERCENTILES' WRITE(JU,'(99A)') ('"'//TRIM(IPF(1)%INFO(J,I))//'",',J=1,IPF(1)%NCOL-1),'"'//TRIM(IPF(1)%INFO(IPF(1)%NCOL,I))//'"',TRIM(LINE) DEALLOCATE(JDT,MSR) ENDIF CLOSE(KU) ELSE WRITE(*,'(A)') 'Cannot open '//TRIM(FNAME); PAUSE ENDIF WRITE(6,'(A)') '+Progress '//TRIM(VTOS(REAL(I,8)/REAL(IPF(1)%NROW,8)*100.D0,'F',3))//' % ' ENDDO IF(ALLOCATED(JDP))DEALLOCATE(JDP); IF(ALLOCATED(XPERC))DEALLOCATE(XPERC); IF(ASSOCIATED(PERC))DEALLOCATE(PERC) CLOSE(JU) IF(ICLUSTER.EQ.1)THEN !## reread file NIPF=1; CALL IPFALLOCATE(); IPF(1)%FNAME=IPFNAME_OUT IPF(1)%XCOL =1; IPF(1)%YCOL=2; IPF(1)%ZCOL=2; IPF(1)%Z2COL=2; IPF(1)%QCOL=2; IF(.NOT.IPFREAD2(1,1,0))RETURN ALLOCATE(ILIST(IPF(1)%NROW)); ILIST=0 IF(WCOLUMN.EQ.0)WCOLUMN=IPF(1)%NCOL DO M=0; IC=0; DO I=1,IPF(1)%NROW IF(ILIST(I).EQ.1)CYCLE N=0; DO J=1,IPF(1)%NROW IF(ILIST(J).EQ.1)CYCLE IF(UTL_DIST(IPF(1)%XYZ(1,I),IPF(1)%XYZ(2,I),IPF(1)%XYZ(1,J),IPF(1)%XYZ(2,J)).LE.RANGE)THEN N=N+1 ENDIF ENDDO IF(N.GT.M)THEN; M=N; IC=I; ENDIF ENDDO !## finished IF(IC.EQ.0)EXIT !## set clusters for ic TW=0.0D0; NW=0 DO J=1,IPF(1)%NROW IF(ILIST(J).EQ.1)CYCLE IF(UTL_DIST(IPF(1)%XYZ(1,IC),IPF(1)%XYZ(2,IC),IPF(1)%XYZ(1,J),IPF(1)%XYZ(2,J)).LE.RANGE)THEN ILIST(J)=2 READ(IPF(1)%INFO(WCOLUMN,J),*) W TW=TW+W NW=NW+1 ENDIF ENDDO NW=MAX(NW,1) DO J=1,IPF(1)%NROW !## incurrent cycle IF(ILIST(J).EQ.2)THEN READ(IPF(1)%INFO(WCOLUMN,J),*) W W=W/REAL(NW,8) WRITE(IPF(1)%INFO(WCOLUMN,J),*) W ILIST(J)=1 ENDIF ENDDO ENDDO DEALLOCATE(ILIST) IPF(1)%FNAME=IPFNAME_OUT(:INDEX(IPFNAME_OUT,'.',.TRUE.)-1)//'_CLUSTER.IPF' IF(.NOT.IPFWRITE(1))RETURN ENDIF 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; IABS=0 !## read mean ilay (optional) IF(.NOT.UTL_READPOINTER(IU,MEAN_NLAYER,MEAN_ILAYER,'ILAYER',1))THEN; ENDIF !## if layer specified, SDATE and EDATE are obliged 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 !## read ISEL parameter IF(.NOT.IMODBATCH_AREAINFO(MEAN_ISEL,MEAN_IDFNAME,MEAN_GENFNAME))RETURN CFUNC='MEAN' ! default function 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,F8.4)') 'PERCVALUE=',PERCVALUE CASE('PROB') IF(.NOT.UTL_READINITFILE('PROBVALUE',LINE,IU,0))RETURN READ(LINE,*) PROBVALUE%FNAME; WRITE(*,'(A)') 'PROBVALUE='//TRIM(PROBVALUE%FNAME) CASE DEFAULT WRITE(*,'(A)') 'CFUNC should be equal to MEAN,MIN,MAX,SUM,PERC'; STOP END SELECT WRITE(*,'(A)') 'CFUNC='//TRIM(CFUNC) IF(UTL_READINITFILE('IABS',LINE,IU,1))THEN READ(LINE,*) IABS; WRITE(*,'(A,I1)') 'IABS=',IABS ENDIF IF(.NOT.UTL_READINITFILE('NDIR',LINE,IU,0))RETURN READ(LINE,*) N; WRITE(*,'(A,I4)') 'NDIR=',N !## read output file name to overrule default names (optional) MEAN_OUTFILE='' IF(UTL_READINITFILE('OUTFILE',LINE,IU,1))READ(LINE,*) MEAN_OUTFILE WRITE(*,'(A)') 'OUTFILE='//TRIM(MEAN_OUTFILE) IF(LEN_TRIM(MEAN_OUTFILE).GT.0)MEAN_OUTFILE=MEAN_OUTFILE(:INDEX(MEAN_OUTFILE,'.',.TRUE.)-1) 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(VTOS(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(VTOS(I))//'='; WRITE(*,'(A)') TRIM(LINE)//TRIM(MEAN_RESDIR) !## start computing 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 : DP_KIND,SP_KIND IMPLICIT NONE INTEGER :: I,J,K,N,SY,EY,NBAL,IOPT CHARACTER(LEN=256) :: FNAME,DIR,OUTPUTFNAME IBATCH=1 !## default no exchange fluxes WBAL_WBEX=0 !## all off TP%IACT=0 DO I=1,SIZE(TP) TP(I)%NSYS=1 ALLOCATE(TP(I)%ISYS(1)); TP(I)%ISYS=0 ENDDO !## check whether the function need to be used for plotting purposes IF(UTL_READINITFILE('CSVFNAME',LINE,IU,1))THEN READ(LINE,*) FNAME; WRITE(*,'(A)') 'CSVFNAME='//TRIM(FNAME) !## imod need to read the csv first to continue WRITE(*,'(A)') 'Reading the CSV file ...' 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) CALL IGRCOLOURMODEL(24) CALL PREFCOLOURSINIT(.FALSE.) !## read the file - stop if there is a problem - fill in the dialog (in the back) CALL WBAL_ANALYSE_INIT(FNAME,1) IF(WBAL_ANALYSE_READCONFIG(IU,1,IOPT))THEN CALL UTL_CREATEDIR(DIR) IF(IOPT.EQ.4)THEN IF(.NOT.UTL_READINITFILE('OUTPUTFNAME',LINE,IU,0))RETURN READ(LINE,*) OUTPUTFNAME; WRITE(*,'(A)') 'OUTPUTFNAME='//TRIM(OUTPUTFNAME) !## imod need to read the csv first to continue WRITE(*,'(A)') 'Reading the CSV file ...' ENDIF CALL WBAL_ANALYSE_PLOT(ID_GRAPHICS,1,OUTPUTFNAME) ENDIF RETURN ENDIF 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(WCTP(NBAL)); WCTP%NSYS=0 DO I=1,NBAL IF(.NOT.UTL_READINITFILE('BAL'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) WCTP(I)%BDGNAME; !## make them capitals WCTP(I)%BDGNAME=UTL_CAP(WCTP(I)%BDGNAME,'U') LINE='BAL'//TRIM(VTOS(I))//'='//TRIM(WCTP(I)%BDGNAME) WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READPOINTER(IU,WCTP(I)%NSYS,WCTP(I)%ISYS,'BAL'//TRIM(VTOS(I))//'ISYS',1))RETURN IF(WCTP(I)%NSYS.EQ.0)THEN WCTP(I)%NSYS=1 LINE='- no system notation applied'; WRITE(*,'(A)') TRIM(LINE) ELSE LINE='- systems' DO K=1,WCTP(I)%NSYS; LINE=TRIM(LINE)//', '//TRIM(VTOS(WCTP(I)%ISYS(K))); ENDDO; WRITE(*,'(A)') TRIM(LINE) ENDIF ENDDO WBAL_ISTEADY=1 !## read start date (optional IF(UTL_READINITFILE('SDATE',LINE,IU,1))THEN READ(LINE,*) WBAL_FYR; WBAL_FYR=UTL_COMPLETEDATE(WBAL_FYR) WRITE(*,'(A,I16)') '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; WBAL_TYR=UTL_COMPLETEDATE(WBAL_TYR) WRITE(*,'(A,I16)') '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.UTL_READPOINTER(IU,WBAL_NLAYER,WBAL_ILAYER,'ILAYER',0))RETURN !## make sure layers are not defined multiple times DO I=1,WBAL_NLAYER N=0; J=WBAL_ILAYER(I) DO K=1,WBAL_NLAYER IF(WBAL_ILAYER(K).EQ.J)N=N+1 ENDDO IF(N.GT.1)THEN WRITE(*,'(/1X,A,I3,A)') 'Layer ',J,' defined more than once'; STOP ENDIF ENDDO 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(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) WBAL_RESDIR LINE='SOURCEDIR'//TRIM(VTOS(I))//'=' WRITE(*,'(A)') TRIM(LINE)//TRIM(WBAL_RESDIR) IF(.NOT.UTL_READINITFILE('OUTPUTNAME'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) WBAL_OUTFNAME LINE='OUTPUTNAME'//TRIM(VTOS(I))//'=' WRITE(*,'(A)') TRIM(LINE)//TRIM(WBAL_OUTFNAME) IF(.NOT.WBALCOMPUTE())THEN; ENDIF WRITE(*,'(/A)') 'Successfully completed waterbalance, results written in:' WRITE(*,'(A/)') TRIM(WBAL_OUTFNAME) END DO !## release waterbalance-related memory again CALL WBALABORT() 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='REPLACE',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,','St.Dev.,' 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,','St.Dev.,','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: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 INTEGER :: IITYPE 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.0D0; YMIN=0.0D0 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) IITYPE=1; IF(UTL_READINITFILE('IITYPE',LINE,IU,1))READ(LINE,*) IITYPE WRITE(*,'(A,I8)') 'IITYPE=',IITYPE SELECT CASE (IITYPE) CASE (1); WRITE(*,'(/A/)') 'Import type as a RUN-file' CASE (2); WRITE(*,'(/A/)') 'Import type as a PRJ-file' END SELECT 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))=' ' WRITE(*,'(A)') 'OUTDIR='//TRIM(DIR_DBS) SELECT CASE (IITYPE) CASE (1); RUNFILE =TRIM(DIR_DBS)//'\MODEL.RUN' CASE (2); RUNFILE =TRIM(DIR_DBS)//'\MODEL.PRJ' END SELECT 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(1,IITYPE))THEN; ENDIF END SUBROUTINE IMODBATCH_IMPORTMODFLOW_MAIN !###====================================================================== SUBROUTINE IMODBATCH_MATH_MAIN() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256),DIMENSION(:,:),POINTER :: EQUATION INTEGER :: I,II,J,NVAR,IROW,ICOL,USENODATA,NIF REAL(KIND=DP_KIND) :: NODATAVALUE CHARACTER(LEN=10),ALLOCATABLE,DIMENSION(:) :: VARIABLES TYPE(IDFOBJ) :: IDF TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: SRC REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: VAL REAL(KIND=DP_KIND),POINTER,DIMENSION(:,:) :: LVAL LOGICAL,POINTER,DIMENSION(:,:) :: LEXX INTEGER,ALLOCATABLE,DIMENSION(:) :: SCLUP,SCLDN LOGICAL :: LEX CALL IDFNULLIFY(IDF) IF(.NOT.UTL_READINITFILE('NVAR',LINE,IU,0))RETURN READ(LINE,*) NVAR; WRITE(*,'(A)') 'NVAR='//TRIM(VTOS(NVAR)) ALLOCATE(SRC(NVAR),VAL(NVAR),VARIABLES(NVAR),SCLUP(NVAR),SCLDN(NVAR)) DO I=1,SIZE(SRC); CALL IDFNULLIFY(SRC(I)); ENDDO VARIABLES=''; J=64; DO I=1,SIZE(SRC) J=J+1; IF(.NOT.UTL_READINITFILE(CHAR(J),LINE,IU,0))RETURN READ(LINE,*) SRC(I)%FNAME; WRITE(*,'(A)') CHAR(J)//'='//TRIM(SRC(I)%FNAME) VARIABLES(I)=CHAR(J); VARIABLES(I)=UTL_CAP(VARIABLES(I),'L') ENDDO SCLUP=10; J=64; DO I=1,SIZE(SRC) J=J+1; IF(UTL_READINITFILE('SCLUP_'//CHAR(J),LINE,IU,1))THEN READ(LINE,*) SCLUP(I); WRITE(*,'(A)') 'SCLUP_'//CHAR(J)//'='//TRIM(VTOS(SCLUP(I))) ENDIF IF(SCLUP(I).LT.1.OR.SCLUP(I).GT.10)THEN WRITE(*,'(/A/)') 'ERROR SCLUP_'//CHAR(J)//' need to be in between 1 and 10'; RETURN ENDIF ENDDO SCLDN=1; J=64; DO I=1,SIZE(SRC) J=J+1; IF(UTL_READINITFILE('SCLDN_'//CHAR(J),LINE,IU,1))THEN READ(LINE,*) SCLDN(I); WRITE(*,'(A)') 'SCLDN_'//CHAR(J)//'='//TRIM(VTOS(SCLDN(I))) ENDIF IF(SCLDN(I).LT.1.OR.SCLDN(I).GT.2)THEN WRITE(*,'(/A/)') 'ERROR SCLDN_'//CHAR(J)//' need to be 1 or 2'; RETURN ENDIF ENDDO CALL UTL_GET_EQUATIONS_DEFINE(EQUATION,VARIABLES,NIF,LEXX,LVAL) USENODATA=0; IF(UTL_READINITFILE('USENODATA',LINE,IU,1))THEN READ(LINE,*) USENODATA; WRITE(*,'(A)') 'USENODATA='//TRIM(VTOS(USENODATA)) IF(USENODATA.EQ.1)THEN IF(.NOT.UTL_READINITFILE('NODATAVALUE',LINE,IU,0))RETURN READ(LINE,*) NODATAVALUE; WRITE(*,'(A)') 'NODATAVALUE='//TRIM(VTOS(NODATAVALUE,'*',7)) ENDIF ENDIF IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX WRITE(*,'(A,4F15.3)') 'WINDOW=',IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,1))RETURN READ(LINE,*) IDF%DX; IDF%DY=IDF%DX; WRITE(*,'(A,F15.3)') 'CELLSIZE=',IDF%DX IDF%NODATA=HUGE(1.0); IDF%ITYPE=4 CALL UTL_IDFSNAPTOGRID_LLC(IDF%XMIN,IDF%XMAX,IDF%YMIN,IDF%YMAX,IDF%DX,IDF%DY,IDF%NCOL,IDF%NROW,LLC=.TRUE.) ELSE IF(.NOT.IDFREAD(SRC(1),SRC(1)%FNAME,0))THEN WRITE(*,'(A)') 'Cannot read data for '//TRIM(SRC(1)%FNAME); RETURN ENDIF CALL IDFCOPY(SRC(1),IDF) ENDIF IF(.NOT.UTL_READINITFILE('OUTPUTIDF',LINE,IU,0))RETURN READ(LINE,*) IDF%FNAME; WRITE(*,'(A)') 'OUTPUTIDF='//TRIM(IDF%FNAME) !## read and scale all input DO I=1,SIZE(SRC) CALL IDFCOPY(IDF,SRC(I)) WRITE(*,'(1X,A)') 'Reading/(scaling)/(clipping): '//TRIM(SRC(I)%FNAME)//' ...' IF(.NOT.IDFREADSCALE(SRC(I)%FNAME,SRC(I),SCLUP(I),SCLDN(I),0.0D0,0))THEN WRITE(*,'(A)') 'Cannot read data for '//TRIM(SRC(I)%FNAME); RETURN ENDIF ENDDO IF(.NOT.IDFALLOCATEX(IDF))THEN; WRITE(*,'(A)') 'Cannot allocate memory for results idf'; RETURN; ENDIF !## process equation DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL if(irow.eq.165.and.icol.eq.511)then write(*,*) endif IDF%X(ICOL,IROW)=IDF%NODATA VAL=0.0; DO I=1,SIZE(SRC) IF(SRC(I)%X(ICOL,IROW).EQ.SRC(I)%NODATA)THEN IF(USENODATA.EQ.0)EXIT; SRC(I)%X(ICOL,IROW)=NODATAVALUE ENDIF VAL(I)=SRC(I)%X(ICOL,IROW) ENDDO !## skip this location as it contains nodata IF(I.LE.SIZE(SRC))CYCLE !## conditional computation IF(NIF.GT.0)THEN !## evaluate table of functions I=1 DO DO J=1,3,2 IF(LEXX(I,J))THEN !## get function values LVAL(I,J)=EVALUATE(VAL,OP(I,J)%N,OP(I,J)%CNUMBER,OP(I,J)%CPDATA,OP(I,J)%COPERATIONS) ENDIF ENDDO !## evaluate logical condition ['<>','<=','>=','=','<','>'] SELECT CASE (EQUATION(I,2)) CASE ('1'); LEX=LVAL(I,1).NE.LVAL(I,3) CASE ('2'); LEX=LVAL(I,1).LE.LVAL(I,3) CASE ('3'); LEX=LVAL(I,1).GE.LVAL(I,3) CASE ('4'); LEX=LVAL(I,1).EQ.LVAL(I,3) CASE ('5'); LEX=LVAL(I,1).LT.LVAL(I,3) CASE ('6'); LEX=LVAL(I,1).GT.LVAL(I,3) END SELECT !## how to continue? IF(LEX)THEN !## first valid II=4 ELSE !## second valid II=5 ENDIF !## evaluate appropriate function IF(LEXX(I,II))THEN !## check whether there is an if-function IF(INDEX(EQUATION(I,II),'IF').GT.0)THEN !## go to the appropriate equation line READ(EQUATION(I,II)(3:),*) I ELSE !## get function values LVAL(I,II)=EVALUATE(VAL,OP(I,II)%N,OP(I,II)%CNUMBER,OP(I,II)%CPDATA,OP(I,II)%COPERATIONS) !## finished EXIT ENDIF ELSE !## finished EXIT ENDIF ENDDO IDF%X(ICOL,IROW)=LVAL(I,II) ELSE IDF%X(ICOL,IROW)=EVALUATE(VAL,OP(1,1)%N,OP(1,1)%CNUMBER,OP(1,1)%CPDATA,OP(1,1)%COPERATIONS) ENDIF WRITE(6,'(A)') '+Progress '//TRIM(VTOS(REAL(IROW,8)/REAL(IDF%NROW)*100.0D0,'F',2))//'% ' ENDDO; ENDDO IF(USENODATA.EQ.1)IDF%NODATA=NODATAVALUE IF(.NOT.IDFWRITE(IDF,IDF%FNAME,1))THEN; WRITE(*,'(A)') 'Cannot save data for '//TRIM(IDF%FNAME); RETURN; ENDIF DO I=1,SIZE(OP,1); DO J=1,SIZE(OP,2) IF(J.EQ.2)CYCLE IF(.NOT.LEXX(I,J))CYCLE !## skip if-statements IF(INDEX(EQUATION(I,J),'IF').GT.0)CYCLE DEALLOCATE(OP(I,J)%CNUMBER) DEALLOCATE(OP(I,J)%CPDATA) DEALLOCATE(OP(I,J)%COPERATIONS) ENDDO; ENDDO DEALLOCATE(OP) CALL IDFDEALLOCATE(SRC,SIZE(SRC)); DEALLOCATE(SRC,VAL,VARIABLES,SCLUP,SCLDN,EQUATION,LVAL,LEXX) CALL IDFDEALLOCATEX(IDF) END SUBROUTINE IMODBATCH_MATH_MAIN !###====================================================================== SUBROUTINE UTL_GET_EQUATIONS_DEFINE(EQUATION,VARIABLES,NIF,LEXX,LVAL) !###====================================================================== IMPLICIT NONE CHARACTER(LEN=*),DIMENSION(:),INTENT(IN) :: VARIABLES CHARACTER(LEN=256),DIMENSION(:,:),POINTER,INTENT(OUT) :: EQUATION REAL(KIND=DP_KIND),POINTER,DIMENSION(:,:),INTENT(OUT) :: LVAL LOGICAL,POINTER,DIMENSION(:,:),INTENT(OUT) :: LEXX INTEGER,INTENT(OUT) :: NIF CHARACTER(LEN=256) :: FULLEQUATION INTEGER :: I,J,IOS CHARACTER(LEN=5) :: STATUSFLAG !## get equation IF(.NOT.UTL_READINITFILE('EQUATION',LINE,IU,0))RETURN READ(LINE,*) FULLEQUATION; FULLEQUATION=UTL_CAP(FULLEQUATION,'U'); WRITE(*,'(A)') 'EQUATION='//TRIM(FULLEQUATION) !## determine whether there is an if-statement NIF=UTL_COUNT_STRINGS(FULLEQUATION,'IF') IF(NIF.GT.0)THEN ALLOCATE(EQUATION(NIF,5),LVAL(NIF,5),LEXX(NIF,5),OP(NIF,5)) !## get equations CALL UTL_GET_EQUATIONS(EQUATION,FULLEQUATION) DO I=1,NIF DO J=1,5 READ(EQUATION(I,J),*,IOSTAT=IOS) LVAL(I,J) LEXX(I,J)=.TRUE.; IF(IOS.EQ.0)LEXX(I,J)=.FALSE. ENDDO ENDDO ELSE ALLOCATE(EQUATION(1,1),LVAL(1,1),LEXX(1,1),OP(1,1)); EQUATION(1,1)=FULLEQUATION; LEXX(1,1)=.TRUE. ENDIF !## initialisation of interpreter DO I=1,SIZE(EQUATION,1); DO J=1,SIZE(EQUATION,2) !## skip logical operator IF(J.EQ.2)CYCLE !## skip constant values IF(.NOT.LEXX(I,J))CYCLE !## skip if-statements IF(INDEX(EQUATION(I,J),'IF').GT.0)CYCLE CALL INIT(EQUATION(I,J),VARIABLES,STATUSFLAG) IF(UTL_CAP(STATUSFLAG,'L').NE.'ok') THEN WRITE(*,*) 'Something wrong in your equation'; WRITE(*,'(A)') TRIM(EQUATION(I,J)); RETURN ENDIF CALL COPYFUNC(OP(I,J)%CNUMBER,OP(I,J)%CPDATA,OP(I,J)%COPERATIONS,OP(I,J)%N) CALL DESTROYFUNC() ENDDO; ENDDO END SUBROUTINE UTL_GET_EQUATIONS_DEFINE !###====================================================================== SUBROUTINE UTL_GET_EQUATIONS(EQUATION,FEQUATION) !###====================================================================== IMPLICIT NONE CHARACTER(LEN=*),INTENT(IN) :: FEQUATION CHARACTER(LEN=*),INTENT(INOUT),DIMENSION(:,:) :: EQUATION INTEGER :: N,M,I,J,IIF,NIF,IOS N=SIZE(EQUATION,1); M=SIZE(EQUATION,2); EQUATION='' !## recursive subroutine IIF=1; NIF=1; CALL UTL_GET_IFEQUATION(N,M,FEQUATION,EQUATION,IIF,NIF) WRITE(*,'(/A/)') 'Equations found:' DO I=1,SIZE(EQUATION,1) LINE=TRIM(EQUATION(I,1)) READ(EQUATION(I,2),*,IOSTAT=IOS) J IF(IOS.EQ.0)THEN LINE=TRIM(LINE)//TRIM(OPER(J))//TRIM(EQUATION(I,3))//','//TRIM(EQUATION(I,4))//','//TRIM(EQUATION(I,5)) ENDIF WRITE(*,'(A)') 'EQUATION'//TRIM(VTOS(I))//':'//TRIM(LINE) ! WRITE(*,'(6A10)') 'EQUATION'//TRIM(VTOS(I)),(TRIM(EQUATION(I,J)),J=1,SIZE(EQUATION,2)) ENDDO !IF( A >0, (B+2)/2, IF(C-A>0,A,B)) ! ( A >0, (B+2)/2, IF(C-A>0,A,B)) ! (A>0,(B+2)/2,(C-A>0,A,B)) !A !(B+2)/2 !IF !C-A !A !B END SUBROUTINE UTL_GET_EQUATIONS !###====================================================================== RECURSIVE SUBROUTINE UTL_GET_IFEQUATION(N,M,FEQUATION,EQUATION,IIF,NIF) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(INOUT) :: IIF,NIF INTEGER,INTENT(IN) :: N,M CHARACTER(LEN=*),INTENT(IN) :: FEQUATION CHARACTER(LEN=*),INTENT(INOUT),DIMENSION(N,M) :: EQUATION CHARACTER(LEN=256) :: LINE INTEGER :: I,II,J,JJ,K,IL,JJF,ILL,NB INTEGER,DIMENSION(2) :: IP I=INDEX(FEQUATION,'IF(')+3 !## find end of current if J=I; NB=0; DO IF(FEQUATION(J:J).EQ.')')THEN IF(NB.EQ.0)THEN; J=J-1; EXIT; ENDIF; NB=NB-1 ENDIF IF(FEQUATION(J:J).EQ.'(')NB=NB+1 J=J+1 ENDDO LINE=FEQUATION(I:J) !## find appropriate delimiters I=0; II=0; ILL=0; IP=0; DO; II=II+1 IF(II.GT.LEN_TRIM(LINE))EXIT IF(LINE(II:II).EQ.'(')ILL=ILL+1 IF(LINE(II:II).EQ.')')ILL=ILL-1 IF(LINE(II:II).EQ.','.AND.ILL.EQ.0)THEN; I=I+1; IP(I)=II; ENDIF ENDDO !## see what is there DO I=1,3 SELECT CASE (I) !## first, try logical operators in first part of equation CASE (1) JJ=IP(1)-1 DO IL=1,SIZE(OPER) II=INDEX(LINE(:JJ),TRIM(OPER(IL)),.FALSE.) IF(II.GT.0)EXIT ENDDO IF(IL.GT.SIZE(OPER))THEN WRITE(*,'(99A)') 'No logical operator (',(TRIM(OPER(IL)),IL=1,SIZE(OPER)),') found in '//TRIM(LINE); STOP ENDIF EQUATION(IIF,1)=LINE(:II-1) EQUATION(IIF,2)=TRIM(VTOS(IL)) JJ=INDEX(LINE,',',.FALSE.) IF(JJ.EQ.0)THEN WRITE(*,'(99A)') 'Error in first argument after locical operator in '//TRIM(LINE); STOP ENDIF K=LEN_TRIM(OPER(IL)) EQUATION(IIF,3)=LINE(II+K:JJ-1) CASE (2) II=IP(1)+1 JJ=IP(2)-1 IF(II.EQ.0.OR.II.GT.JJ)THEN WRITE(*,'(99A)') 'Error in second argument if-statement found in '//TRIM(LINE); STOP ENDIF !## call this subroutine again if this contains an if-statement IF(INDEX(LINE(II:JJ),'IF').GT.0)THEN EQUATION(IIF,4)='IF'//TRIM(VTOS(IIF+1)); JJF=IIF; IIF=IIF+1 CALL UTL_GET_IFEQUATION(N,M,LINE(II:JJ),EQUATION,IIF,NIF) IIF=JJF; NIF=NIF+1 ELSE EQUATION(IIF,4)=LINE(II:JJ) ENDIF CASE (3) II=IP(2)+1 IF(II.EQ.0)THEN WRITE(*,'(99A)') 'Error in third argument if-statement found in '//TRIM(LINE); STOP ENDIF !## call this subroutine again if this contains an if-statement IF(INDEX(LINE(II:),'IF').GT.0)THEN EQUATION(IIF,5)='IF'//TRIM(VTOS(IIF+1)); JJF=IIF; IIF=IIF+1 CALL UTL_GET_IFEQUATION(N,M,LINE(II:),EQUATION,IIF,NIF) IIF=JJF; NIF=NIF+1 ELSE EQUATION(IIF,5)=LINE(II:) ENDIF END SELECT ENDDO ! write(*,*) fequation(I:J) !IF()CALL UTL_GET_IFEQUATION(N,M,FEQUATION(I:J),EQUATION,IIF) END SUBROUTINE UTL_GET_IFEQUATION !!###====================================================================== !RECURSIVE SUBROUTINE UTL_GET_IFEQUATION_BRACKET(FEQUATION,J) !!###====================================================================== !IMPLICIT NONE !CHARACTER(LEN=*),INTENT(IN) :: FEQUATION !INTEGER,INTENT(INOUT) :: J ! !DO ! IF(FEQUATION(J:J).EQ.'(')THEN ! CALL UTL_GET_IFEQUATION_BRACKET(FEQUATION,J) ! ELSE ! J=J+1; IF(FEQUATION(J:J).EQ.')')EXIT ! ENDIF !ENDDO ! !END SUBROUTINE UTL_GET_IFEQUATION_BRACKET !###====================================================================== 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 CHARACTER(LEN=80) :: PARSEDFUNC,DUMMYFUNC INTEGER :: IEFUNC INTEGER,DIMENSION(3) :: IOP REAL(KIND=DP_KIND),DIMENSION(3) :: CLC !## 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) !## interrupt when parsing fails or parsed function doesn't match DUMMYFUNC=FUNC IF(.NOT.MATH1GETFUNC(DUMMYFUNC,1,IG,IOP,CLC,IEFUNC,PARSEDFUNC)) RETURN IF(PARSEDFUNC.NE.FUNC) THEN WRITE(*,'(A)') 'Input formula could not be parsed.& & Did you use the correct order of operands, e.g. 0.5*A instead of A/2?' RETURN ENDIF !## reduce indices to 0 or 1 for absent or present, resp. 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,4F15.3)') 'WINDOW=',MPW%XMIN,MPW%YMIN,MPW%XMAX,MPW%YMAX ENDIF IGEN=0; IBLANKOUT=0 IF(UTL_READINITFILE('GENFILE',LINE,IU,1))THEN READ(LINE,*) GENNAME WRITE(*,'(A)') 'GENFILE='//TRIM(GENNAME) IGEN=1 IF(UTL_READINITFILE('IBLANKOUT',LINE,IU,1))THEN READ(LINE,*) IBLANKOUT; WRITE(*,'(A)') 'IBLANKOUT='//TRIM(VTOS(IBLANKOUT)) ENDIF ENDIF TRIM_VALUE=0.0D0; 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.0D0 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(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) IDFNAMES(I,1),IDFNAMES(I,2),IDFNAMES(I,3) LINE='A'//TRIM(VTOS(I))//'='//TRIM(IDFNAMES(I,1)) WRITE(*,'(A)') TRIM(LINE) LINE='B'//TRIM(VTOS(I))//'='//TRIM(IDFNAMES(I,2)) WRITE(*,'(A)') TRIM(LINE) LINE='C'//TRIM(VTOS(I))//'='//TRIM(IDFNAMES(I,3)) WRITE(*,'(A)') TRIM(LINE) ELSE IF(IG(1).EQ.1)THEN IF(.NOT.UTL_READINITFILE('AC'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) IDFNAMES(I,1),IDFNAMES(I,3) LINE='A'//TRIM(VTOS(I))//'='//TRIM(IDFNAMES(I,1)) WRITE(*,'(A)') TRIM(LINE) LINE='C'//TRIM(VTOS(I))//'='//TRIM(IDFNAMES(I,3)) WRITE(*,'(A)') TRIM(LINE) ELSE IF(.NOT.UTL_READINITFILE('BC'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) IDFNAMES(I,2),IDFNAMES(I,3) LINE='B'//TRIM(VTOS(I))//'='//TRIM(IDFNAMES(I,2)) WRITE(*,'(A)') TRIM(LINE) LINE='C'//TRIM(VTOS(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) CALL UTL_SUBST(IDFNAMES(I,2),'*',SUBSTR) CALL UTL_SUBST(IDFNAMES(I,3),'*',SUBSTR) IF(IG(1).GT.0)THEN LINE='A'//TRIM(VTOS(I))//'='//TRIM(IDFNAMES(I,1)) WRITE(*,'(A)') TRIM(LINE) ENDIF IF(IG(2).GT.0)THEN LINE='B'//TRIM(VTOS(I))//'='//TRIM(IDFNAMES(I,2)) WRITE(*,'(A)') TRIM(LINE) ENDIF LINE='C'//TRIM(VTOS(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.0D0 IBUFFER=0 !## intial values if not specified, overuled by iMOD HCLOSE=-999.99D0 RCLOSE=-999.99D0 !## 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 (9) IF(.NOT.UTL_READINITFILE('PERCENTILE',LINE,IU,0))RETURN READ(LINE,*) SFCT !## <>1.0D0 WRITE(*,'(A,F10.2)') 'SFCT=',SFCT CASE (1,3,4,5,6,8) IF(UTL_READINITFILE('WEIGHFACTOR',LINE,IU,1))READ(LINE,*) SFCT !## <>1.0D0 WRITE(*,'(A,F10.2)') 'SFCT=',SFCT CASE (14) HOR_FCT=1.0D0 VER_FCT=1.0D0 MAXK=250.0D0 !## grof zand DHX=0.0D0 DHY=0.0D0 DHZ=0.0D0 QRATE=0.0D0 FILLNODATA=0 AQFR_KD=250.0D0 !## m/day ILGROUP=1 !## vertical box to average k-value KMIN=1.0D0 !## k-value to become clay IF(UTL_READINITFILE('ANI_X',LINE,IU,1))READ(LINE,*) HOR_FCT !## <>1.0D0 WRITE(*,'(A,F10.2)') 'ANI_X=',HOR_FCT IF(UTL_READINITFILE('ANI_Z',LINE,IU,1))READ(LINE,*) VER_FCT !## <>1.0D0 WRITE(*,'(A,F10.2)') 'ANI_Z=',VER_FCT IF(UTL_READINITFILE('DH_X',LINE,IU,1))READ(LINE,*) DHX !## <>1.0D0 WRITE(*,'(A,F10.2)') 'DH_X=',DHX IF(UTL_READINITFILE('DH_Y',LINE,IU,1))READ(LINE,*) DHY !## <>1.0D0 WRITE(*,'(A,F10.2)') 'DH_Y=',DHY IF(UTL_READINITFILE('DH_Z',LINE,IU,1))READ(LINE,*) DHZ !## <>1.0D0 WRITE(*,'(A,F10.2)') 'DH_Z=',DHZ 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('FILLNODATA',LINE,IU,1))THEN READ(LINE,*) FILLNODATA !## >> apply surface water to nodata column WRITE(*,'(A,I1)') 'FILLNODATA=',FILLNODATA IF(UTL_READINITFILE('MAX_K',LINE,IU,1))READ(LINE,*) MAXK !## >> WRITE(*,'(A,F10.2)') 'MAX_K=',MAXK ENDIF 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 IF(UTL_READINITFILE('HCLOSE',LINE,IU,1))READ(LINE,*) HCLOSE IF(UTL_READINITFILE('RCLOSE',LINE,IU,1))READ(LINE,*) RCLOSE 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,4F15.3)') '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(HCLOSE.LT.0.0D0)HCLOSE=MAX(DHX,DHY,DHZ)/1000.0D0 IF(MATH1SCALE(1,HCLOSE,RCLOSE))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=256),POINTER,DIMENSION(:) :: LISTNAME 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(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) IDFNAMES(I) LINE='SOURCEIDF'//TRIM(VTOS(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:)) IF(UTL_DIRINFO_POINTER(TRIM(ROOT),TRIM(WC),LISTNAME,'F'))THEN IF(SIZE(LISTNAME).EQ.0)THEN; WRITE(*,'(A)') 'No files found in: '//TRIM(SOURCEDIR); RETURN; ENDIF ALLOCATE(IDFNAMES(SIZE(LISTNAME))); DO I=1,SIZE(LISTNAME); IDFNAMES(I)=TRIM(ROOT)//'\'//TRIM(LISTNAME(I)); ENDDO ELSE WRITE(*,'(A)') 'No files found in: '//TRIM(SOURCEDIR); RETURN ENDIF DEALLOCATE(LISTNAME) ENDIF IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) MPW%XMIN,MPW%YMIN,MPW%XMAX,MPW%YMAX WRITE(*,'(A,4F15.3)') 'WINDOW=',MPW%XMIN,MPW%YMIN,MPW%XMAX,MPW%YMAX IEXT=1 ELSE WRITE(*,'(A)') 'no window given'; IEXT=2 ENDIF IMSK=0 IF(UTL_READINITFILE('MASKIDF',LINE,IU,1))THEN IMSK=1 READ(LINE,*) MSKNAME; WRITE(*,'(A)') 'MASKIDF='//TRIM(MSKNAME) ELSE WRITE(*,'(A)') 'no mask given' ENDIF IINT=1; IF(UTL_READINITFILE('IINT',LINE,IU,1))THEN READ(LINE,*) IINT; WRITE(*,'(A)') 'IINT='//TRIM(VTOS(IINT)) 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(KIND=DP_KIND) :: 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.0D0; MULT =1.0D0; ADD=0.0D0 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 !## 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) 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(VTOS(I)),LINE,IU,0))RETURN ! READ(LINE,*) TBNAME(I,1); WRITE(*,'(A)') 'TOP'//TRIM(VTOS(I))//'='//TRIM(TBNAME(I,1)) ! IF(.NOT.UTL_READINITFILE('BOT'//TRIM(VTOS(I)),LINE,IU,0))RETURN ! READ(LINE,*) TBNAME(I,2); WRITE(*,'(A)') 'BOT'//TRIM(VTOS(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(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) AHN(I) LINE='IDFFILE'//TRIM(VTOS(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.0D0 !## depression percentile DP2 =90.0D0 !## 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.05D0 !## stop criterion max. change interpolation (m) INTNODATA=1 !## ignore nodata BUFFER =0.0D0 !## 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; AHN_IWINDOW=0 IF(UTL_READINITFILE('NWINDOW',LINE,IU,1))THEN READ(LINE,*) NWINDOW; AHN_IWINDOW=1 ENDIF DO I=1,MAX(1,NWINDOW) IF(NWINDOW.GT.0)THEN IF(.NOT.UTL_READINITFILE('WINDOW'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) AHN_XMIN,AHN_YMIN,AHN_XMAX,AHN_YMAX LINE='WINDOW'//TRIM(VTOS(I))//'=' WRITE(*,'(A,4F10.2)') TRIM(LINE),AHN_XMIN,AHN_YMIN,AHN_XMAX,AHN_YMAX IF(.NOT.UTL_READINITFILE('OUTFILE'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) OUTFILE LINE='OUTFILE'//TRIM(VTOS(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_SOURCEDIR=''; GXG_MVIDFNAME=''; GXG_OUTFOLDER='' !## read layer IF(.NOT.UTL_READPOINTER(IU,GXG_NLAYER,GXG_ILAYER,'ILAYER',0))RETURN !## read surface name (optional) 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_FIRSTDAY=14 !## default firstday is 14 IF(UTL_READINITFILE('FIRSTDAY',LINE,IU,1))THEN READ(LINE,*) GXG_FIRSTDAY WRITE(*,'(A,I4)') 'FIRSTDAY=',GXG_FIRSTDAY ENDIF GXG_SECONDDAY=28 !## default secondday is 28 IF(UTL_READINITFILE('SECONDDAY',LINE,IU,1))THEN READ(LINE,*) GXG_SECONDDAY WRITE(*,'(A,I4)') 'SECONDDAY=',GXG_SECONDDAY ENDIF 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(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) GXG_SOURCEDIR; LINE='SOURCEDIR='//TRIM(VTOS(I))//'='//TRIM(GXG_SOURCEDIR) WRITE(*,'(A)') TRIM(LINE) !## read output folder name IF(UTL_READINITFILE('OUTPUTFOLDER'//TRIM(VTOS(I)),LINE,IU,1))READ(LINE,*) GXG_OUTFOLDER IF(LEN(TRIM(GXG_OUTFOLDER)).GT.0)WRITE(*,'(A)') 'OUTPUTFOLDER=',GXG_OUTFOLDER !## calc GXG IF(.NOT.GXG1_COMPUTEGXG())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 GXG1_ABORT() END SUBROUTINE IMODBATCH_GXG_MAIN !###====================================================================== 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(VTOS(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(VTOS(J))//'='//TRIM(VTOS(IPERIOD(K-1,1)))//'-'//TRIM(VTOS(IPERIOD(K-1,2)))//';'// & TRIM(VTOS(IPERIOD(K,1))) //'-'//TRIM(VTOS(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) 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_MERGEPLOT() !###====================================================================== IMPLICIT NONE INTEGER :: NPICTURE,IBITMAP,MBITMAP,NROW,NCOL,I,IROW,ICOL,TCOL,TROW,IX1,IY1,IX2,IY2 CHARACTER(LEN=256),DIMENSION(:),ALLOCATABLE :: PICTURE,TITLE CHARACTER(LEN=256) :: OUTPUTNAME INTEGER,ALLOCATABLE,DIMENSION(:) :: INFO,PROW,PCOL REAL(KIND=DP_KIND) :: W,H,XPOS,YPOS IF(.NOT.UTL_READINITFILE('NPICTURE',LINE,IU,0))RETURN READ(LINE,*) NPICTURE; WRITE(*,'(A)') 'NPICTURE='//TRIM(VTOS(NPICTURE)) ALLOCATE(PICTURE(NPICTURE),TITLE(NPICTURE)) CALL WBITMAPALLOC(NPICTURE+1) CALL WINDOWOPEN(FLAGS=SYSMENUON+HIDEWINDOW+STATUSBAR) CALL WINDOWSTATUSBARPARTS(4,(/2000,2000,750,-1/),(/1,1,1,1/)) !## 24-bits colour application CALL IGRCOLOURMODEL(24) NCOL=0; IF(UTL_READINITFILE('NCOL',LINE,IU,1))THEN READ(LINE,*) NCOL; WRITE(*,'(A)') 'NCOL='//TRIM(VTOS(NCOL)) ENDIF NROW=0; IF(UTL_READINITFILE('NROW',LINE,IU,1))THEN READ(LINE,*) NROW; WRITE(*,'(A)') 'NROW='//TRIM(VTOS(NROW)) ENDIF !## compute ncol/nrow IF(NCOL.EQ.0.OR.NROW.EQ.0)THEN ! NCOL=SQRT(REAL(NPICTURE))) ENDIF ALLOCATE(PROW(NROW),PCOL(NCOL)); PROW=0; PCOL=0 IF(.NOT.UTL_READINITFILE('OUTPUTNAME',LINE,IU,0))RETURN READ(LINE,*) OUTPUTNAME; WRITE(*,'(A)') 'OUTPUTNAME='//TRIM(OUTPUTNAME) DO I=1,NPICTURE PICTURE(I)='' IF(UTL_READINITFILE('PICTURE'//TRIM(VTOS(I)),LINE,IU,1))THEN READ(LINE,*) PICTURE(I); WRITE(*,'(A)') 'PICTURE'//TRIM(VTOS(I))//'='//TRIM(PICTURE(I)) TITLE(I)='' IF(UTL_READINITFILE('TITLE'//TRIM(VTOS(I)),LINE,IU,1))THEN READ(LINE,*) TITLE(I); WRITE(*,'(A)') 'TITLE'//TRIM(VTOS(I))//'='//TRIM(TITLE(I)) ENDIF ENDIF ENDDO IF(ALLOCATED(INFO))DEALLOCATE(INFO); ALLOCATE(INFO(6)) I=0; DO IROW=1,NROW DO ICOL=1,NCOL I=I+1; IF(I.GT.NPICTURE)EXIT !## skip this one IF(LEN_TRIM(PICTURE(I)).EQ.0)CYCLE CALL IGRFILEINFO(PICTURE(I),INFO,6) PCOL(ICOL)=MAX(PCOL(ICOL),INFO(2)) PROW(IROW)=MAX(PROW(IROW),INFO(3)) ENDDO ENDDO TCOL=SUM(PCOL); TROW=SUM(PROW) I=INFOERROR(1); CALL WBITMAPCREATE(MBITMAP,TCOL,TROW); I=INFOERROR(1) IF(MBITMAP.EQ.0)THEN; WRITE(*,'(/1X,A,2I10)') 'Cannot create bitmap with dimension ',TCOL,TROW; STOP; ENDIF CALL IGRSELECT(DRAWBITMAP,MBITMAP) I=0; DO IROW=1,NROW DO ICOL=1,NCOL I=I+1; IF(I.GT.NPICTURE)EXIT !## skip this one IF(LEN_TRIM(PICTURE(I)).EQ.0)CYCLE CALL IGRFILEINFO(PICTURE(I),INFO,6) TCOL=INFO(2); TROW=INFO(3) CALL TOPO1LOADBMP(IBITMAP,PICTURE(I),TCOL,TROW) !## add text IF(TRIM(TITLE(I)).NE.'')THEN CALL IGRSELECT(IBITMAP,IBITMAP) XPOS=REAL(TCOL,8); YPOS=REAL(TROW,8) W=0.013333D0; H=W*3.0D0 CALL DBL_WGRTEXTFONT(IFAMILY=FFHELVETICA,TWIDTH=W,THEIGHT=H) !,NAME,ISPACE,IENCODE) ! CALL WGRTEXTOPTIONS(GRTEXTRATIO,3) CALL WGRTEXTORIENTATION(IALIGN=ALIGNLEFT) !CENTRE) !,ANGLE,IDIR,NALIGN) CALL DBL_IGRAREA( 0.0D0,1.0D0,0.0D0,1.0D0) CALL DBL_IGRUNITS(0.0D0,0.0D0,XPOS,YPOS) ! CALL DBL_IGRJOIN( 0.0D0,0.0D0,XPOS,YPOS) XPOS=0.1D0*REAL(TCOL,8); YPOS=0.1D0*REAL(TROW,8) CALL DBL_WGRTEXTSTRING(XPOS,YPOS,TITLE(I)) ! CALL DBL_IGRJOIN(0.0D0,0.0D0,XPOS,YPOS) CALL IGRSELECT(DRAWBITMAP,MBITMAP) ENDIF IX1=1; IF(ICOL.GT.1)IX1=SUM(PCOL(1:ICOL-1))+1 IY1=1; IF(IROW.GT.1)IY1=SUM(PROW(1:IROW-1))+1 IX2=SUM(PCOL(1:ICOL)) IY2=SUM(PROW(1:IROW)) CALL WBITMAPPUT(IBITMAP,METHOD=1,ISTRETCH=0,IX1=IX1,IY1=IY1,IX2=IX2,IY2=IY2) CALL WBITMAPDESTROY(IBITMAP) ENDDO ENDDO IF(ALLOCATED(INFO))DEALLOCATE(INFO) DEALLOCATE(PICTURE,TITLE) CALL UTL_CREATEDIR(OUTPUTNAME(:INDEX(OUTPUTNAME,'\',.TRUE.)-1)) CALL WBITMAPSAVE(MBITMAP,OUTPUTNAME) CALL WBITMAPDESTROY(MBITMAP) END SUBROUTINE IMODBATCH_MERGEPLOT !###====================================================================== SUBROUTINE IMODBATCH_PLOT_MAIN() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: IDFLEGNAME,IPFLEGNAME,IFFLEGNAME,ISGNAME,IDFNAME,IPFNAME,OUTNAME,IFFNAME,BMPOUTNAME CHARACTER(LEN=52) :: IDFLEGTXT,IPFLEGTXT,IFFLEGTXT CHARACTER(LEN=256),ALLOCATABLE,DIMENSION(:) :: GENNAME INTEGER :: IDFLEGCOL,IPFLEGCOL,IFFLEGCOL,IDFLINETHICKNESS,IDFTRANSTOPO,IDFTRANSTOPOPER INTEGER :: JU,IOS,I,NFIG,RESOLUTION,IDFSTYLE,IPFSTYLE,IFFSTYLE,NLABELS,NGEN,IR,IG,IB,N,M,J,II,IEXT,II1,II2,IBITMAP INTEGER,DIMENSION(2) :: IPFASSFILES INTEGER,DIMENSION(5) :: IPFICOL REAL(KIND=DP_KIND) :: XMIN,YMIN,XMAX,YMAX,YFRACLEGEND,RAT INTEGER,DIMENSION(3) :: IP INTEGER,DIMENSION(6) :: ITPER REAL(KIND=DP_KIND),DIMENSION(:,:),ALLOCATABLE :: XY INTEGER,ALLOCATABLE,DIMENSION(:) :: ILABELS,GENCOLOUR,GENTHICKNESS CHARACTER(LEN=52),DIMENSION(:),ALLOCATABLE :: STRING,CLABEL CHARACTER(LEN=3) :: CSTYLE CHARACTER(LEN=6) :: TRANSPER LOGICAL :: LIND IDFNAME=''; IDFLEGNAME=''; IPFNAME=''; IFFNAME=''; ISGNAME='' IDFLEGCOL=0; IPFLEGCOL=0; IFFLEGCOL=0 IDFTRANSTOPOPER=0 ; IDFTRANSTOPO=0; IPFASSFILES=0 !## 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 IDFLEGCOL=1 IF(UTL_READINITFILE('IDFLEGCOL',LINE,IU,1))THEN READ(LINE,*) IDFLEGCOL; WRITE(*,'(A)') 'IDFLEGCOL='//TRIM(VTOS(IDFLEGCOL)) ENDIF IF(UTL_READINITFILE('IDFLINETHICKNESS',LINE,IU,1))THEN READ(LINE,*) IDFLINETHICKNESS; WRITE(*,'(A)') 'IDFLINETHICKNESS='//TRIM(VTOS(IDFLINETHICKNESS)) ENDIF ENDIF ! !## read legname (optional) ! TSIZE=0.05D0; 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(ABS(IPFASSFILES(2)).NE.1)THEN; WRITE(*,*) 'You should specify IPFASSFILES_ALL in {-1,1}'; STOP; ENDIF ENDIF IPFICOL(1)=1; IPFICOL(2)=2; IPFICOL(3)=3; IPFICOL(4)=0; IPFICOL(5)=1 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) IF(UTL_READINITFILE('IPFHCOL_M',LINE,IU,1))READ(LINE,*) IPFICOL(5) WRITE(*,'(A,I1)') 'IPFHCOL_M=',IPFICOL(5) 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) IPFLEGTXT='' IF(UTL_READINITFILE('IPFLEGTXT',LINE,IU,1))THEN READ(LINE,*) IPFLEGTXT; WRITE(*,'(A)') 'IPFLEGTXT='//TRIM(IPFLEGTXT) ENDIF IPFLEGCOL=1 IF(UTL_READINITFILE('IPFLEGCOL',LINE,IU,1))THEN READ(LINE,*) IPFLEGCOL; WRITE(*,'(A)') 'IPFLEGCOL='//TRIM(VTOS(IPFLEGCOL)) ENDIF ELSE IF(IPFICOL(5).EQ.2)THEN WRITE(*,'(/A/)') 'You need to specify a legend in case IPFHCOL_M is specified as 2'; STOP ENDIF 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 IFFLEGCOL=1 IF(UTL_READINITFILE('IFFLEGCOL',LINE,IU,1))THEN READ(LINE,*) IFFLEGCOL; WRITE(*,'(A)') 'IFFLEGCOL=',IFFLEGCOL ENDIF ENDIF !## read iffname (optional) IF(UTL_READINITFILE('ISGFILE',LINE,IU,1))THEN READ(LINE,*) ISGNAME; WRITE(*,'(A)') 'ISGFILE='//TRIM(ISGNAME) 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),GENTHICKNESS(NGEN)) DO I=1,NGEN IF(.NOT.UTL_READINITFILE('GENFILE'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) GENNAME(I) LINE='GENFILE'//TRIM(VTOS(I))//'='//TRIM(GENNAME(I)) WRITE(*,'(A)') TRIM(LINE) GENCOLOUR(I)=WRGB(0,0,0) IF(UTL_READINITFILE('GENCOLOUR'//TRIM(VTOS(I)),LINE,IU,1))THEN READ(LINE,*) IR,IG,IB; GENCOLOUR(I)=WRGB(IR,IG,IB) LINE='GENCOLOUR'//TRIM(VTOS(I))//'=('//TRIM(VTOS(IR))//','//TRIM(VTOS(IG))//','//TRIM(VTOS(IB))//') '//TRIM(VTOS(GENCOLOUR(I))) WRITE(*,'(A)') TRIM(LINE) ENDIF GENTHICKNESS(I)=1 IF(UTL_READINITFILE('GENTHICKNESS'//TRIM(VTOS(I)),LINE,IU,1))THEN READ(LINE,*) GENTHICKNESS(I) LINE='GENTHICKNESS'//TRIM(VTOS(I))//'='//TRIM(VTOS(GENTHICKNESS(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)) IF(UTL_READINITFILE('IDFTRANSTOPO',LINE,IU,1))THEN READ(LINE,*) IDFTRANSTOPO; WRITE(*,'(A)') 'IDFTRANSTOPO='//TRIM(VTOS(IDFTRANSTOPO)) ENDIF IF(UTL_READINITFILE('IDFTRANSTOPOPER',LINE,IU,1))THEN READ(LINE,*) IDFTRANSTOPOPER; WRITE(*,'(A)') 'IDFTRANSTOPOPER='//TRIM(VTOS(IDFTRANSTOPOPER)) WRITE(TRANSPER,'(I6.6)') IDFTRANSTOPOPER READ(TRANSPER,'(6I1)') ITPER CALL UTL_READARRAY(ITPER,6,IDFTRANSTOPOPER) ENDIF 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 YFRACLEGEND=100.0D0 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.0D0; XMAX=0; YMIN=0.0D0; YMAX=0.0D0 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)//'WINDOW='//TRIM(LINE),'Error') RETURN ENDIF WRITE(*,'(A,4F15.3)') 'WINDOW=',XMIN,YMIN,XMAX,YMAX ENDIF CALL WBITMAPALLOC(40) 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 MANAGER_UTL_INIT() !## 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) !## initialize iMOD CALL IMODINIT() IF(NFIG.NE.4)THEN IF(UTL_READINITFILE('LEGPOS',LINE,IU,1))THEN READ(LINE,*,IOSTAT=IOS) LG_XP1,LG_YP1,LG_XP2,LG_YP2 IF(IOS.NE.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot read extent properly:'//CHAR(13)//'LEGPOS='//TRIM(LINE),'Error') RETURN ENDIF WRITE(*,'(A,4F15.3)') 'LEGPOS=',LG_XP1,LG_YP1,LG_XP2,LG_YP2 ENDIF ENDIF DO II=II1,II2 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.0D0 XMAX=XY(II,1)+1000.0D0 YMIN=XY(II,2)-1000.0D0 YMAX=XY(II,2)+1000.0D0 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 MANAGER_UTL_ADDFILE(IDFNAMEGIVEN=IDFNAME,LEGNAME=IDFLEGNAME,ISTYLE=IDFSTYLE,LDEACTIVATE=.FALSE.,LEGTXT=IDFLEGTXT) IF(LEN_TRIM(IPFNAME).NE.0)THEN IF(NLABELS.EQ.0)THEN CALL MANAGER_UTL_ADDFILE(IDFNAMEGIVEN=IPFNAME,LEGNAME=IPFLEGNAME,ISTYLE=IPFSTYLE,LDEACTIVATE=.FALSE., & IPFICOL=IPFICOL,IPFASSFILES=IPFASSFILES,LEGTXT=IPFLEGTXT) ELSE CALL MANAGER_UTL_ADDFILE(IDFNAMEGIVEN=IPFNAME,LEGNAME=IPFLEGNAME,ISTYLE=IPFSTYLE,LDEACTIVATE=.FALSE., & IPFICOL=IPFICOL,ILABELS=ILABELS,IPFASSFILES=IPFASSFILES,LEGTXT=IPFLEGTXT) ENDIF ENDIF IF(LEN_TRIM(IFFNAME).NE.0)CALL MANAGER_UTL_ADDFILE(IDFNAMEGIVEN=IFFNAME,LEGNAME=IFFLEGNAME,ISTYLE=IFFSTYLE,LDEACTIVATE=.FALSE.,LEGTXT=IFFLEGTXT) IF(LEN_TRIM(ISGNAME).NE.0)CALL MANAGER_UTL_ADDFILE(IDFNAMEGIVEN=ISGNAME,LDEACTIVATE=.FALSE.) DO I=1,NGEN; CALL GEN_INIT(GENNAME=GENNAME(I),LDEACTIVATE=.FALSE.,GENCOLOUR=GENCOLOUR(I),GENTHICKNESS=GENTHICKNESS(I)); ENDDO IF(NFIG.EQ.4)THEN !## bitmap size ... screensize --- vierkant MPW%DIX=RESOLUTION MPW%DIY=RESOLUTION ELSE RAT=1.0D0; IF(YMAX-YMIN.NE.0.0D0)RAT=(XMAX-XMIN)/(YMAX-YMIN) IF(RAT.GE.1.0D0)THEN MPW%DIX=RESOLUTION MPW%DIY=MPW%DIX/RAT ELSE MPW%DIY=RESOLUTION MPW%DIX=MPW%DIY*RAT ENDIF ENDIF IF(XMAX-XMIN.EQ.0.0D0)THEN !## draw in case no window is specified CALL IDFPLOT(1) !## if no idf/ipf plotted, use gen for zoom-extent IF(LEN_TRIM(IDFNAME).EQ.0.AND.LEN_TRIM(IPFNAME).EQ.0)THEN CALL WDIALOGSELECT(ID_DMANAGER) CALL WDIALOGSETTAB(ID_DMTAB,ID_DMANAGERTAB2) ENDIF CALL IDFZOOM(ID_ZOOMFULLMAP,0.0D0,0.0D0,0) ELSE !## set zoom level (all) MPW%XMIN=XMIN MPW%YMIN=YMIN MPW%XMAX=XMAX MPW%YMAX=YMAX CALL IDFZOOM(ID_DGOTOXY,0.0D0,0.0D0,0) 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) !## set transparancy values IF(IDFTRANSTOPO.EQ.1)THEN ! CALL WMENUSETSTATE(ID_TOPOTRANSPARANCY,2,1) IF(ITPER(1).EQ.1)CALL WMENUSETSTATE(ID_TOPOTRANSPARANCY0,2,1) IF(ITPER(2).EQ.1)CALL WMENUSETSTATE(ID_TOPOTRANSPARANCY10,2,1) IF(ITPER(3).EQ.1)CALL WMENUSETSTATE(ID_TOPOTRANSPARANCY25,2,1) IF(ITPER(4).EQ.1)CALL WMENUSETSTATE(ID_TOPOTRANSPARANCY50,2,1) IF(ITPER(5).EQ.1)CALL WMENUSETSTATE(ID_TOPOTRANSPARANCY75,2,1) IF(ITPER(6).EQ.1)CALL WMENUSETSTATE(ID_TOPOTRANSPARANCY90,2,1) ENDIF IF(NFIG.NE.4)THEN IF(IDFLEGCOL+IPFLEGCOL+IFFLEGCOL.GT.0)THEN CALL WINDOWSELECT(0); CALL WMENUSETSTATE(ID_PLOTLEGEND,2,1) SELECT CASE (IDFLEGCOL) CASE (1); CALL WMENUSETSTATE(ID_LEGENDCOLUMNS1,2,1) CASE (2); CALL WMENUSETSTATE(ID_LEGENDCOLUMNS2,2,1) CASE (3); CALL WMENUSETSTATE(ID_LEGENDCOLUMNS3,2,1) CASE (4); CALL WMENUSETSTATE(ID_LEGENDCOLUMNS4,2,1) CASE (5); CALL WMENUSETSTATE(ID_LEGENDCOLUMNS5,2,1) END SELECT ENDIF ENDIF CALL IDFPLOT(1) !## create drawing IBITMAP=0 IF(NFIG.EQ.4)THEN CALL IMODBATH_PLOTFIG((/IDFLEGCOL,IPFLEGCOL,IFFLEGCOL,0/),YFRACLEGEND,(/IDFLEGTXT,IPFLEGTXT,IFFLEGTXT,''/),IBITMAP) ELSE IBITMAP=MPW%IBITMAP ENDIF CALL UTL_CREATEDIR(OUTNAME(1:INDEX(OUTNAME,'\',.TRUE.)-1)) I=INFOERROR(1) CALL WBITMAPSAVE(IBITMAP,BMPOUTNAME) I=INFOERROR(1) CALL WBITMAPDESTROY(MPW%IBITMAP) IF(IBITMAP.NE.0)CALL WBITMAPDESTROY(IBITMAP) ENDDO CALL WINDOWCLOSECHILD(MPW%IWIN) IF(ALLOCATED(XY))DEALLOCATE(XY) IF(ALLOCATED(STRING))DEALLOCATE(STRING) IF(ALLOCATED(CLABEL))DEALLOCATE(CLABEL) END SUBROUTINE IMODBATCH_PLOT_MAIN !###====================================================================== SUBROUTINE IMODBATH_PLOTFIG(LEGCOL,YFRACLEGEND,LEGTXT,IBITMAP) !###====================================================================== IMPLICIT NONE REAL(KIND=DP_KIND),INTENT(IN) :: YFRACLEGEND INTEGER,INTENT(IN),DIMENSION(:) :: LEGCOL INTEGER,INTENT(OUT) :: IBITMAP CHARACTER(LEN=*),DIMENSION(:),INTENT(IN) :: LEGTXT INTEGER :: I,J REAL(KIND=DP_KIND) :: 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.0D0 !## witte rand XP =420.0D0 !## paper width YP =297.0D0 !## paper heigth GR =YP !## graph area right BH =YP-40.0D0 !## title bot area LT =YP-75.0D0 !## legend top area LB =65.0D0 !## legend bot area AB =45.0D0 !## axes bot area PB =19.0D0 !## project FB =15.0D0 !## figure number DB =10.0D0 !## date TBND=BND+BND ACC=5.0D0 !## create 'mother' bitmap for current coordinates CALL WBITMAPCREATE(IBITMAP,INT(XP*ACC),INT(YP*ACC)) CALL IGRSELECT(DRAWBITMAP,IBITMAP) CALL IGRPLOTMODE(MODECOPY) CALL DBL_IGRAREA(0.0D0,0.0D0,1.0D0,1.0D0) CALL DBL_IGRUNITS(0.0D0,0.0D0,XP,YP) !## legend area CALL IGRCOLOURN(WRGB(255,255,255)) CALL IGRFILLPATTERN(SOLID) CALL DBL_IGRRECTANGLE(GR,AB,XP-BND,LT) !## top text CALL IGRCOLOURN(WRGB(123,152,168)) CALL DBL_IGRRECTANGLE(GR,LT,XP-BND,YP-BND) !## bottom text CALL IGRCOLOURN(WRGB(123,152,168)) !0,102,161)) CALL DBL_IGRRECTANGLE(GR,0.0D0+BND,XP-BND,AB) !## main window CALL IGRCOLOURN(WRGB(255,255,255)) CALL DBL_IGRRECTANGLE(0.0D0+BND,0.0D0+BND,GR-BND,YP-BND) Y1=0.03333D0 X1=Y1/(0.03333D0/0.01333D0) !## header/title CALL DBL_WGRTEXTFONT(IFAMILY=FFHELVETICA,TWIDTH=X1,THEIGHT=Y1,ISTYLE=FSBOLD) CALL DBL_WGRTEXTORIENTATION(IALIGN=ALIGNLEFT) CALL IGRCOLOURN(WRGB(0,0,0)) CALL DBL_WGRTEXTBLOCK(GR+BND,BH,XP-TBND,YP-TBND,TRIM(FIG(1)),1.0D0) !## sub-header CALL DBL_WGRTEXTFONT(IFAMILY=FFHELVETICA,TWIDTH=X1/2.0D0,THEIGHT=Y1/2.0D0,ISTYLE=0) CALL DBL_WGRTEXTBLOCK(GR+BND,LT+0.5D0*TBND,XP-TBND,BH-TBND,TRIM(FIG(2)),1.0D0) !## projectlabel CALL DBL_WGRTEXTFONT(IFAMILY=FFHELVETICA,TWIDTH=X1/2.0D0,THEIGHT=Y1/2.0D0,ISTYLE=FSITALIC) CALL DBL_WGRTEXTBLOCK(GR+BND,PB,XP-TBND,AB-2.5D0,'Project: '//CHAR(13)//TRIM(FIG(4)),1.0D0) !## figure CALL DBL_WGRTEXTSTRING(GR+BND,FB,'Figure/report: '//TRIM(FIG(3))) !## date CALL IOSTIME(IHR,IMT,IS,MS) CALL IOSDATE(IY,IM,ID) CALL WDATETOSTRING(STRING,IY,IM,ID,DATELONGMONTH+DATENOLEADZERO,'-') STRING=TRIM(STRING)//' '//TRIM(VTOS(IHR))//':'//TRIM(VTOS(IMT))//':'//TRIM(VTOS(IS)) CALL DBL_WGRTEXTSTRING(GR+BND,DB,'Creation Date/time: '//TRIM(STRING)) CALL DBL_WGRTEXTORIENTATION(IALIGN=ALIGNRIGHT,ANGLE=0.0D0) CALL DBL_WGRTEXTFONT(IFAMILY=FFHELVETICA,TWIDTH=X1/3.0D0,THEIGHT=Y1/3.0D0,ISTYLE=0) CALL DBL_WGRTEXTSTRING(XP-BND,0.0D0+0.5D0*BND,'Powered by '//TRIM(UTL_IMODVERSION())//' Copyright © 2005-2023') 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 DBL_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 DBL_IGRAREA(0.0D0,0.0D0,1.0D0,1.0D0) CALL DBL_IGRRECTANGLE(0.0D0,0.0D0,XP,YP) N=0; DO I=1,MXMPLOT; IF(.NOT.MP(I)%IACT)CYCLE; N=N+1; ENDDO DL=0.0D0; IF(N.GT.0)DL =(YFRACLEGEND/DBLE(N))/100.0D0*(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 DBL_IGRAREA(X1/XP,Y1/YP,X2/XP,Y2/YP) CALL DBL_IGRUNITS(0.0D0,0.0D0,1.0D0,1.0D0) !yfraclegend/100.0D0) !1.0D0) J=MP(I)%IPLOT IF(LEGCOL(J).GT.0)CALL LEGPLOT_PLOT(MP(I)%LEG,LEGCOL(J),J,ISYMBOL=MP(I)%SYMBOL) !## 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.0D0,20.0D0) !X1=X1+GR !X2=X2+GR !Y1=Y1+BND !Y2=Y2+BND !CALL DBL_IGRAREA(X1/XP,Y1/YP,X2/XP,Y2/YP) !CALL WBITMAPPUT(ILOGO,2,1) CALL DBL_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 DBL_IGRUNITS(X1,Y1,X2,Y2) SB_XP1=GR/XP SB_YP1=AB/YP SB_XP2=(XP-BND)/XP SB_YP2=LB/YP CALL IDFPLOT_FEATURES_SCALE() ! END SUBROUTINE IMODBATH_PLOTFIG !###====================================================================== SUBROUTINE IMODBATH_PLOTFIG_DIM(IBITMAP,X1,X2,Y1,Y2,XW,XH) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: IBITMAP REAL(KIND=DP_KIND),INTENT(IN) :: XW,XH REAL(KIND=DP_KIND),INTENT(OUT) :: X1,X2,Y1,Y2 INTEGER :: IW,IH REAL(KIND=DP_KIND) :: RAT !## put bitmap IW=WINFOBITMAP(IBITMAP,BITMAPWIDTH) IH=WINFOBITMAP(IBITMAP,BITMAPHEIGHT) RAT=REAL(IW)/REAL(IH) IF(RAT.GT.1.0D0)THEN Y1=(XH-(XH/RAT))/2.0; Y2= Y1+XH/RAT; X1=0.0D0; X2=XW ELSEIF(RAT.LT.1.0D0)THEN X1=(XW-(XW*RAT))/2.0; X2= X1+XW*RAT; Y1=0.0D0; Y2=XH ELSE X1=0.0D0; Y1=0.0D0; 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.0D0 YOFFSET=0.0D0 ZOFFSET=0.0D0 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(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) FLM(I)%GRAIN; FLM(I)%GRAIN=UTL_CAP(FLM(I)%GRAIN,'U') LINE='GRAIN'//TRIM(VTOS(I))//'='//TRIM(FLM(I)%GRAIN); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('FACIESL'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,'(A)') FLM(I)%FACL; FLM(I)%FACL=UTL_CAP(FLM(I)%FACL,'U') LINE='FACIESL'//TRIM(VTOS(I))//'='//TRIM(FLM(I)%FACL); WRITE(*,'(A)') TRIM(LINE) IF(.NOT.UTL_READINITFILE('FACIESN'//TRIM(VTOS(I)),LINE,IU,0))RETURN READ(LINE,*) FLM(I)%FACN LINE='FACIESN'//TRIM(VTOS(I))//'='//TRIM(VTOS(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 WRITE(*,'(/A/)')' IFLAG need to be 2 or 3'; STOP ! 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 CHARACTER(LEN=256) :: POLYGON INTEGER :: I IPLOT=1; ITRANSIENT=0; NLAYER=0; NIPFS=0; NRDATE=0; IWEIGHT=0; ICOL=0; IAVERAGE=0; IXY=0 IF(.NOT.UTL_READINITFILE('INPUTFILE',LINE,IU,0))RETURN READ(LINE,*) INPUTFILE; WRITE(*,'(A)') 'INPUTFILE='//TRIM(INPUTFILE) IF(UTL_READINITFILE('POLYGON',LINE,IU,1))THEN READ(LINE,*) POLYGON; WRITE(*,'(A)') 'POLYGON='//TRIM(POLYGON) CALL POLYGON1SAVELOADSHAPE(ID_LOADSHAPE,POLYGON,'GEN') ENDIF IF(.NOT.UTL_READINITFILE('ITRANSIENT',LINE,IU,0))RETURN READ(LINE,*) ITRANSIENT; WRITE(*,'(A,I1)') 'ITRANSIENT=',ITRANSIENT !## decide whether average/all IF(ITRANSIENT.EQ.1)THEN IF(UTL_READINITFILE('IAVERAGE',LINE,IU,1))READ(LINE,*) IAVERAGE IF(IAVERAGE.LT.0.OR.IAVERAGE.GT.2)THEN WRITE(*,'(/A/)') '>>> Error, IAVERAGE needs to be 0,1 or 2 <<<'; STOP ENDIF WRITE(*,'(A,I1)') 'IAVERAGE=',IAVERAGE ENDIF IF(UTL_READINITFILE('IXY',LINE,IU,1))THEN READ(LINE,*) IXY; WRITE(*,'(A,I1)') 'IXY=',IXY IF(IXY.EQ.1)THEN IF(.NOT.UTL_READINITFILE('XMAX',LINE,IU,0))RETURN READ(LINE,*) XMAX; WRITE(*,'(A,F15.3)') 'XMAX=',XMAX IF(.NOT.UTL_READINITFILE('XMIN',LINE,IU,0))RETURN READ(LINE,*) XMIN; WRITE(*,'(A,F15.3)') 'XMIN=',XMIN IF(.NOT.UTL_READINITFILE('YMAX',LINE,IU,0))RETURN READ(LINE,*) YMAX; WRITE(*,'(A,F15.3)') 'YMAX=',YMAX IF(.NOT.UTL_READINITFILE('YMIN',LINE,IU,0))RETURN READ(LINE,*) YMIN; WRITE(*,'(A,F15.3)') 'YMIN=',YMIN ENDIF ENDIF IF(INDEX(UTL_CAP(INPUTFILE,'U'),'IPF').GT.0)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)=2; IF(UTL_READINITFILE('IMCOL',LINE,IU,1))READ(LINE,*) ICOL(3) WRITE(*,'(A,I1)') 'IMCOL=',ICOL(3) ICOL(4)=3; IF(UTL_READINITFILE('IHCOL',LINE,IU,1))READ(LINE,*) ICOL(4) WRITE(*,'(A,I1)') 'IHCOL=',ICOL(4) ICOL(5)=0; IF(UTL_READINITFILE('IWCOL',LINE,IU,1))READ(LINE,*) ICOL(5) WRITE(*,'(A,I1)') 'IWCOL=',ICOL(5) ICOL(6)=0; 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 SELECT CASE (IPLOT) CASE (1:2) IF(.NOT.UTL_READINITFILE('BMPNAME',LINE,IU,0))RETURN READ(LINE,*) BMPNAME; WRITE(*,'(A)') 'BMPNAME='//TRIM(BMPNAME) CASE (3) IF(.NOT.UTL_READINITFILE('IPFNAME',LINE,IU,0))RETURN READ(LINE,*) IPFNAME; WRITE(*,'(A)') 'IPFNAME='//TRIM(IPFNAME) CASE DEFAULT WRITE(*,'(/A/)') 'IPLOT NEED TO BE 1,2 OR 3'; STOP END SELECT IF(.NOT.UTL_READPOINTER(IU,NLAYER,ILAYER,'ILAYER',1))RETURN IF(.NOT.UTL_READPOINTER(IU,NIPFS,IIPFS,'IIPF',1))RETURN IF(IAVERAGE.EQ.0)THEN IF(.NOT.UTL_READPOINTER(IU,NRDATE,IRDATE,'IRDATE',1))RETURN DO I=1,NRDATE; IRDATE(I)=UTL_COMPLETEDATE(IRDATE(I)); ENDDO ENDIF IF(UTL_READINITFILE('IWEIGHT',LINE,IU,1))READ(LINE,*) IWEIGHT WRITE(*,'(A,I1)') 'IWEIGHT=',IWEIGHT !## read weight-class WC1=0.0D0; IF(UTL_READINITFILE('WC1',LINE,IU,1))THEN READ(LINE,*) WC1; WRITE(*,'(A,F10.2)') 'WC1=',WC1 ENDIF WC2=0.0D0; IF(UTL_READINITFILE('WC2',LINE,IU,1))THEN READ(LINE,*) WC2; WRITE(*,'(A,F10.2)') 'WC2=',WC2 ENDIF IF(.NOT.UTL_READPOINTER(IU,I,HCLASSES,'HCLASSES',1))RETURN IF(ASSOCIATED(HCLASSES))THEN DO I=2,SIZE(HCLASSES) LINE='CLASS('//TRIM(VTOS(I-1))//')='//TRIM(VTOS(HCLASSES(I-1),'F',3))//' - '//TRIM(VTOS(HCLASSES(I),'F',3)) WRITE(*,'(A)') TRIM(LINE) IF(HCLASSES(I).LE.HCLASSES(I-1))THEN WRITE(*,'(A)') 'Current class is not correct'; STOP ENDIF ENDDO ELSE ALLOCATE(HCLASSES(23)); HCLASSES=0.0D0 ENDIF ALLOCATE(XCLASSES(SIZE(HCLASSES)-1)) !## call residual-main routine CALL RESIDUAL_MAIN(ICOL) END SUBROUTINE IMODBATCH_PLOTRESIDUAL !###====================================================================== SUBROUTINE IMODBATCH_ADJUSTVOXELIDF() !###====================================================================== IMPLICIT NONE TYPE(IDFOBJ) :: IDF CHARACTER(LEN=528) :: NEWNAME,DIRNAME CHARACTER(LEN=52) :: WC REAL(KIND=DP_KIND) :: Z_TOP,DZ,Z CHARACTER(LEN=256),DIMENSION(:),POINTER :: LISTNAME INTEGER :: I,ILAY IF(.NOT.UTL_READINITFILE('SOURCEDIR',LINE,IU,0))RETURN READ(LINE,*) DIRNAME; WRITE(*,'(A)') 'SOURCEDIR='//TRIM(SOURCEDIR) NEWNAME='' IF(UTL_READINITFILE('NEWNAME',LINE,IU,1))THEN READ(LINE,*) NEWNAME; WRITE(*,'(A)') 'NEWNAME='//TRIM(NEWNAME) ENDIF IF(.NOT.UTL_READINITFILE('Z_TOP',LINE,IU,0))RETURN READ(LINE,*) Z_TOP; WRITE(*,'(A,F10.3)') 'Z_TOP=',Z_TOP IF(.NOT.UTL_READINITFILE('DZ',LINE,IU,0))RETURN READ(LINE,*) DZ ; WRITE(*,'(A,F10.3)') 'DZ=',DZ IDFFILE =DIRNAME(INDEX(DIRNAME,'\',.TRUE.)+1:) WC =IDFFILE DIRNAME=DIRNAME(:INDEX(DIRNAME,'\',.TRUE.)-1) IF(.NOT.UTL_DIRINFO_POINTER(DIRNAME,WC,LISTNAME,'F'))THEN; STOP 'No files found'; ENDIF 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 IDF%FNAME=LISTNAME(I) !## convert to voxel IDF%ITB=1 !## compute top Z=Z_TOP-(IDF%ILAY-1)*DZ IDF%TOP=Z !## compute bot IDF%BOT=Z-DZ CLOSE(IDF%IU) IF(LEN_TRIM(NEWNAME).NE.0)THEN IDF%FNAME=TRIM(DIRNAME)//'\'//TRIM(NEWNAME)//'_L'//TRIM(VTOS(ILAY))//'. IDF' ENDIF IF(.NOT.IDFWRITE(IDF,IDF%FNAME,1))THEN;WRITE(*,'(A)') 'Cannot write '//TRIM(IDF%FNAME); STOP; ENDIF WRITE(*,*) 'Writing IDF: '//TRIM(LISTNAME(I)) ENDDO END SUBROUTINE IMODBATCH_ADJUSTVOXELIDF !###====================================================================== SUBROUTINE IMODBATCH_MFTOIMOD() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: MFFNAME,OUTNAME,IDFNAME IDFNAME='' IF(.NOT.UTL_READINITFILE('MFFNAME',LINE,IU,0))RETURN READ(LINE,*) MFFNAME; WRITE(*,'(A)') 'MFFNAME='//TRIM(MFFNAME) IF(.NOT.UTL_READINITFILE('OUTNAME',LINE,IU,0))RETURN READ(LINE,*) OUTNAME; WRITE(*,'(A)') 'OUTNAME='//TRIM(OUTNAME) IF(UTL_READINITFILE('IDFNAME',LINE,IU,1))THEN READ(LINE,*) IDFNAME; WRITE(*,'(A)') 'IDFNAME='//TRIM(IDFNAME) ENDIF CALL IMPORT_MF2005_MAIN(MFFNAME,OUTNAME,IDFNAME) END SUBROUTINE IMODBATCH_MFTOIMOD !###====================================================================== SUBROUTINE IMODBATCH_CREATEPILOTPOINTS_IPF(IMASK,MASK) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: IMASK TYPE(IDFOBJ),INTENT(INOUT) :: MASK CHARACTER(LEN=256) :: IPFOBS,IPFMES,IPFPPS CHARACTER(LEN=2) :: PTYPE REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: XP,YP !## list of points REAL(KIND=DP_KIND) :: DCLUSTER,DX,DY INTEGER :: I,J,NBORDER,PPTYPE,IG,IL,ISVALOBS,ISVALMES NIPF=2; CALL IPFALLOCATE() IF(.NOT.UTL_READINITFILE('IPFOBS',LINE,IU,0))RETURN READ(LINE,*) IPFOBS; WRITE(*,'(A)') 'IPFOBS='//TRIM(IPFOBS) IPF(2)%NROW=0; IPFMES=''; IF(UTL_READINITFILE('IPFMES',LINE,IU,1))THEN READ(LINE,*) IPFMES; WRITE(*,'(A)') 'IPFMES='//TRIM(IPFMES) ENDIF DO I=1,2; IPF(I)%XCOL=1; IPF(I)%YCOL=2; IPF(I)%QCOL=1; IPF(I)%ZCOL=1; IPF(I)%Z2COL=1; ENDDO IF(UTL_READINITFILE('IXCOLOBS',LINE,IU,1))READ(LINE,*) IPF(1)%XCOL; WRITE(*,'(A)') 'IXCOLOBS='//TRIM(VTOS(IPF(1)%XCOL)) IF(UTL_READINITFILE('IYCOLOBS',LINE,IU,1))READ(LINE,*) IPF(1)%YCOL; WRITE(*,'(A)') 'IYCOLOBS='//TRIM(VTOS(IPF(1)%YCOL)) IF(UTL_READINITFILE('ISCOLOBS',LINE,IU,1))THEN READ(LINE,*) IPF(1)%QCOL; WRITE(*,'(A)') 'ISCOLOBS='//TRIM(VTOS(IPF(1)%QCOL)) IF(.NOT.UTL_READINITFILE('ISVALOBS',LINE,IU,0))RETURN READ(LINE,*) ISVALOBS; WRITE(*,'(A)') 'ISVALOBS='//TRIM(VTOS(ISVALOBS)) ENDIF IPF(1)%FNAME=IPFOBS; IF(.NOT.IPFREAD2(1,1,0))RETURN IF(IPFMES.NE.'')THEN IPF(2)%FNAME=IPFMES IF(UTL_READINITFILE('IXCOLMES',LINE,IU,1))READ(LINE,*) IPF(2)%XCOL; WRITE(*,'(A)') 'IXCOLMES='//TRIM(VTOS(IPF(2)%XCOL)) IF(UTL_READINITFILE('IYCOLMES',LINE,IU,1))READ(LINE,*) IPF(2)%YCOL; WRITE(*,'(A)') 'IYCOLMES='//TRIM(VTOS(IPF(2)%YCOL)) IF(UTL_READINITFILE('ISCOLMES',LINE,IU,1))THEN READ(LINE,*) IPF(2)%YCOL; WRITE(*,'(A)') 'ISCOLMES='//TRIM(VTOS(IPF(2)%QCOL)) IF(.NOT.UTL_READINITFILE('ISVALMES',LINE,IU,0))RETURN READ(LINE,*) ISVALMES; WRITE(*,'(A)') 'ISVALMES='//TRIM(VTOS(ISVALMES)) ENDIF IF(.NOT.IPFREAD2(2,1,0))RETURN ENDIF IF(.NOT.UTL_READINITFILE('IPFPPS',LINE,IU,0))RETURN READ(LINE,*) IPFPPS; WRITE(*,'(A)') 'IPFPPS='//TRIM(IPFPPS) ! IF(UTL_READINITFILE('IDF',LINE,IU,1))THEN ! READ(LINE,*) IDF%FNAME; WRITE(*,'(A)') 'IDF='//TRIM(IDF%FNAME) ! IF(.NOT.IDFREAD(IDF,IDF%FNAME,1))STOP ! ENDIF !## cluster points DCLUSTER=0.0D0 IF(UTL_READINITFILE('DCLUSTER',LINE,IU,1))READ(LINE,*) DCLUSTER WRITE(*,'(A)') 'DCLUSTER='//TRIM(VTOS(DCLUSTER,'F',3)) !## number of points along the border NBORDER=1 IF(UTL_READINITFILE('NBORDER',LINE,IU,1))READ(LINE,*) NBORDER WRITE(*,'(A)') 'NBORDER='//TRIM(VTOS(NBORDER)) !## layer number IL=1 IF(UTL_READINITFILE('ILAYER',LINE,IU,1))READ(LINE,*) IL WRITE(*,'(A)') 'ILAYER='//TRIM(VTOS(IL)) !## group number IG=1 IF(UTL_READINITFILE('IGROUP',LINE,IU,1))READ(LINE,*) IG WRITE(*,'(A)') 'IGROUP='//TRIM(VTOS(IG)) PPTYPE=1 IF(UTL_READINITFILE('PPTYPE',LINE,IU,1))READ(LINE,*) PPTYPE WRITE(*,'(A)') 'PPTYPE='//TRIM(VTOS(PPTYPE)) SELECT CASE (PPTYPE) CASE (0); WRITE(*,'(A)') 'ORIGINAL (CLUSTERED) POINTS USED FOR PILOTPOINTS' CASE (1); WRITE(*,'(A)') 'DELAUNEY (CIRCUMCENTER) POINTS USED FOR PILOTPOINTS' CASE (2); WRITE(*,'(A)') 'INCENTER POINTS USED FOR PILOTPOINTS' CASE (3); WRITE(*,'(A)') 'MIDPOINTS POINTS USED FOR PILOTPOINTS' END SELECT PTYPE='KH' IF(UTL_READINITFILE('PTYPE',LINE,IU,1))READ(LINE,*) PTYPE WRITE(*,'(A)') 'PTYPE='//TRIM(PTYPE) N=IPF(2)%NROW+IPF(1)%NROW+(4*NBORDER) ALLOCATE(XP(N),YP(N)) N=4*NBORDER DO I=1,IPF(2)%NROW !## remove points for layer if needed IF(IPF(2)%QCOL.NE.IPF(2)%XCOL)THEN !## skip this location if not similar IF(IPF(1)%XYZ(5,I).NE.ISVALMES)CYCLE ENDIF N=N+1; XP(N)=IPF(2)%XYZ(1,I); YP(N)=IPF(2)%XYZ(2,I) ENDDO DO I=1,IPF(1)%NROW !## remove points for layer if needed IF(IPF(1)%QCOL.NE.IPF(1)%XCOL)THEN !## skip this location if not similar IF(IPF(1)%XYZ(5,I).NE.ISVALOBS)CYCLE ENDIF N=N+1; XP(N)=IPF(1)%XYZ(1,I); YP(N)=IPF(1)%XYZ(2,I) ENDDO IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) XP(1),YP(1),XP(3),YP(3) WRITE(*,'(A,4F15.3)') 'WINDOW=',XP(1),YP(1),XP(3),YP(3) XP(2)=XP(1); XP(4)=XP(3) YP(2)=YP(3); YP(4)=YP(1) ELSE J=4*NBORDER+1 XP(1)=MINVAL(XP(J:N)); YP(1)=MINVAL(YP(J:N)) XP(2)=MINVAL(XP(J:N)); YP(2)=MAXVAL(YP(J:N)) XP(3)=MAXVAL(XP(J:N)); YP(3)=MAXVAL(YP(J:N)) XP(4)=MAXVAL(XP(J:N)); YP(4)=MINVAL(YP(J:N)) ENDIF DX=(XP(3)-XP(1))/REAL(NBORDER,8) DY=(YP(2)-YP(1))/REAL(NBORDER,8) J=4; DO I=1,NBORDER-1 J=J+1; XP(J)=XP(1)+DX*I; YP(J)=YP(2) J=J+1; XP(J)=XP(1)+DX*I; YP(J)=YP(1) J=J+1; XP(J)=XP(1); YP(J)=YP(1)+DY*I J=J+1; XP(J)=XP(3); YP(J)=YP(1)+DY*I ENDDO !## read mask file IF(IMASK.EQ.1)THEN WRITE(*,'(A)') 'Reading '//TRIM(MASK%FNAME)//'...' MASK%XMIN=XP(1); MASK%YMIN=YP(1) MASK%XMAX=XP(3); MASK%YMAX=YP(3) MASK%DX=DCLUSTER; MASK%DY=MASK%DX CALL UTL_IDFSNAPTOGRID_LLC(MASK%XMIN,MASK%XMAX,MASK%YMIN,MASK%YMAX,MASK%DX,MASK%DY,MASK%NCOL,MASK%NROW,LLC=.TRUE.) IF(.NOT.IDFREADSCALE(MASK%FNAME,MASK,7,1,0.0D0,0))STOP 'Cannot read data for MASK' ENDIF IG=IG-1 CALL UTL_TRIANGULATION(XP,YP,IPFPPS,DCLUSTER,NBORDER,PTYPE,PPTYPE,IL,IG,MASK) END SUBROUTINE IMODBATCH_CREATEPILOTPOINTS_IPF !###====================================================================== SUBROUTINE UTL_TRIANGULATION(XP,YP,IPFPPS,DCLUSTER,NINT,PTYPE,PPTYPE,IL,IG,IDF) !###====================================================================== IMPLICIT NONE CHARACTER(LEN=*),INTENT(IN) :: IPFPPS,PTYPE INTEGER,INTENT(IN) :: NINT,PPTYPE,IL INTEGER,INTENT(INOUT) :: IG TYPE(IDFOBJ),INTENT(INOUT) :: IDF REAL(KIND=DP_KIND),INTENT(IN) :: DCLUSTER REAL(KIND=DP_KIND),INTENT(INOUT),DIMENSION(:) :: XP,YP TYPE TRIOBJ INTEGER,DIMENSION(3) :: IP=0 !## reference to point for triangles END TYPE TRIOBJ TYPE(TRIOBJ),DIMENSION(:),ALLOCATABLE :: TRI INTEGER :: I,J,JJ,K,NP,IP,JP,IT,JT,P1,P2,P3,ID,IPT,JU,NT,JD,ND,KU,NPF REAL(KIND=DP_KIND) :: D,X,Y,A,A1,A2,A3,A4,XD,YD,F REAL(KIND=DP_KIND),DIMENSION(3,4) :: ANGLE INTEGER,DIMENSION(2) :: SP !## points of triangles of segment to be adjusted INTEGER,DIMENSION(2,3) :: BP !## backup point prior to lawson flip INTEGER,ALLOCATABLE,DIMENSION(:) :: DD LOGICAL :: LEX REAL(KIND=DP_KIND),DIMENSION(2,3) :: T NP =SIZE(XP) NT =SIZE(TRI) NPF=IPF(2)%NROW ALLOCATE(TRI(2*NP)); ALLOCATE(DD(NP)) !## apply clusters DD=0; DO IP=1,NP !## aready done IF(DD(IP).EQ.1)CYCLE XD=XP(IP); YD=YP(IP); ND=1 DO JP=1,NP IF(IP.EQ.JP)CYCLE !## discard point that are too near D=UTL_DIST(XP(IP),YP(IP),XP(JP),YP(JP)) IF(D.LE.DCLUSTER)THEN !## mark double to be removed XD=XD+XP(JP); YD=YD+YP(JP); DD(JP)=1; ND=ND+1 ENDIF ENDDO !## set new point exclude corner points and fixed-points IF(IP.GT.NPF+4*NINT)THEN XD=XD/REAL(ND,8) YD=YD/REAL(ND,8) !## set new point XP(IP)=XD YP(IP)=YD ENDIF ENDDO !## remove all nodata JP=0 DO IP=1,NP IF(DD(IP).EQ.0)THEN JP=JP+1 IF(JP.NE.IP)THEN XP(JP)=XP(IP); YP(JP)=YP(IP) ENDIF ENDIF END DO NP=JP !## construct first four triangles, with first point not equal to all sides DO IP=NPF+(4*NINT)+1,NP IF(XP(IP).NE.XP(1).AND.XP(IP).NE.XP(3).AND. & YP(IP).NE.YP(1).AND.YP(IP).NE.YP(3))EXIT ENDDO IF(IP.GT.NP)STOP 'CANNOT FIND A GOOD STARTING POINT NOT ON THE BOUNDARY' TRI(1)%IP(1)=1; TRI(1)%IP(2)=2; TRI(1)%IP(3)=IP !5 TRI(2)%IP(1)=2; TRI(2)%IP(2)=3; TRI(2)%IP(3)=IP !5 TRI(3)%IP(1)=3; TRI(3)%IP(2)=4; TRI(3)%IP(3)=IP !5 TRI(4)%IP(1)=4; TRI(4)%IP(2)=1; TRI(4)%IP(3)=IP !5 !## start with these four triangles NT=4 !## add all remaining points DO IP=5,NP WRITE(6,'(A)') '+Progress '//TRIM(VTOS(IP))//' '//TRIM(VTOS(NP)) !## skip fixed points IF(NPF.GT.0)THEN IF(IP.GT.4*NINT.AND.IP.LE.NPF+(4*NINT))CYCLE ENDIF ! IF(IP.EQ.NP)THEN ! WRITE(*,*) ! DO IT=1,NT ! WRITE(*,'(4I10)') IT,(TRI(IT)%IP(J),J=1,3) ! ENDDO ! endif !## find out in what triangle current point is DO IT=1,NT P1=TRI(IT)%IP(1); P2=TRI(IT)%IP(2); P3=TRI(IT)%IP(3) IPT=UTL_POINT_IN_TRIANGLE((/XP(P1),YP(P1)/),(/XP(P2),YP(P2)/),(/XP(P3),YP(P3)/),(/XP(IP),YP(IP)/)) IF(IPT.NE.0)EXIT ENDDO !## skip this point as it is on a point of an existing triangle IF(IPT.EQ.-1)CYCLE !## not in any triangle - error IF(IT.GT.NT)THEN; WRITE(*,'(/A/)') 'CURRENT POINT NOT IN ANY TRIANGLE, WILL BE SKIPPED'; PAUSE; CYCLE; ENDIF !## splits current triangle in three TRI(IT)%IP(1)=P1 TRI(IT)%IP(2)=P2 TRI(IT)%IP(3)=IP NT=NT+1 TRI(NT)%IP(1)=P2 TRI(NT)%IP(2)=P3 TRI(NT)%IP(3)=IP NT=NT+1 TRI(NT)%IP(1)=P3 TRI(NT)%IP(2)=IP TRI(NT)%IP(3)=P1 !## clean all triangle that are zero area IT=0; DO IT=IT+1 IF(IT.GT.NT)EXIT DO J=1,3 T(1,J)=XP(TRI(IT)%IP(J)) T(2,J)=YP(TRI(IT)%IP(J)) ENDDO A=TRIANGLE_AREA(T) !## move another triangle if this triangle has a volume IF(A.EQ.0.0D0)THEN DO I=IT,NT-1 DO J=1,3; TRI(I)%IP(J)=TRI(I+1)%IP(J); ENDDO ENDDO NT=NT-1 IT=IT-1 ENDIF ENDDO !## apply a lawson flip to all triangles DO IT=1,NT ! if(it.eq.24)then ! write(*,*) ! endif !## determine angles DO J=1,3 T(1,J)=XP(TRI(IT)%IP(J)) T(2,J)=YP(TRI(IT)%IP(J)) ENDDO CALL TRIANGLE_ANGLES(T,ANGLE(:,1)) ! write(*,'(I10,3F10.3)') it,angle(:,1) !## try to apply for a lawson flip DO K=1,3 !## get maximum angle IF(ANGLE(K,1).GT.90.0D0)THEN ID=TRI(IT)%IP(K) !## select the two others points to look for another triangle I=0; DO JP=1,3; IF(ID.NE.TRI(IT)%IP(JP))THEN; I=I+1; SP(I)=TRI(IT)%IP(JP); ENDIF; ENDDO IF(I.NE.2)THEN; WRITE(*,'(/A/)') 'CANNOT FIND TWO POINTS OF SELECTED TRIANGLE'; PAUSE; STOP; ENDIF !## find triangle thas shares these coordinates !## found triangle to be splitted DO JT=1,NT; IF(JT.EQ.IT)CYCLE; I=0; DO J=1,3 IF(TRI(JT)%IP(J).EQ.SP(1).OR.TRI(JT)%IP(J).EQ.SP(2))I=I+1 ENDDO; IF(I.EQ.2)EXIT; ENDDO !## find triangle that shares coordinates IF(I.EQ.2)THEN ! write(*,*) IT,JT !## backup DO JJ=1,3; BP(1,JJ)=TRI(IT)%IP(JJ); ENDDO DO JJ=1,3; BP(2,JJ)=TRI(JT)%IP(JJ); ENDDO !## find third point that remains in both triangles JD=0; DO J=1,3 IF(TRI(JT)%IP(J).NE.SP(1).AND.TRI(JT)%IP(J).NE.SP(2))THEN; JD=TRI(JT)%IP(J); EXIT; ENDIF ENDDO !## not in any triangle - error IF(JD.EQ.0)THEN; WRITE(*,'(/A/)') 'NO FAR POINT FOUND FOR SELECTED TRIANGLE FOR LAWSON FLIP'; PAUSE; STOP; ENDIF TRI(IT)%IP(1)=ID TRI(IT)%IP(2)=SP(1) TRI(IT)%IP(3)=SP(2) TRI(JT)%IP(1)=JD TRI(JT)%IP(2)=SP(1) TRI(JT)%IP(3)=SP(2) DO J=1,3 T(1,J)=XP(TRI(IT)%IP(J)) T(2,J)=YP(TRI(IT)%IP(J)) ENDDO CALL TRIANGLE_ANGLES(T,ANGLE(:,1)) A1=ANGLE(1,1)*ANGLE(2,1)*ANGLE(3,1) ! WRITE(*,'(A15,5F10.2)') 'OLD TRIANGLE_1',ANGLE(:,1),SUM(ANGLE(:,1)),A1 DO J=1,3 T(1,J)=XP(TRI(JT)%IP(J)) T(2,J)=YP(TRI(JT)%IP(J)) ENDDO CALL TRIANGLE_ANGLES(T,ANGLE(:,2)) A2=ANGLE(1,2)*ANGLE(2,2)*ANGLE(3,2) ! WRITE(*,'(A15,5F10.2)') 'OLD TRIANGLE_2',ANGLE(:,2),SUM(ANGLE(:,2)),A2 ! WRITE(*,'(55X,F10.2)') A1+A2 !## only apply if new polygon is still convex LEX=.FALSE. IF(ANGLE(1,1).GE.180.0D0.OR. & ANGLE(1,2).GE.180.0D0.OR. & ANGLE(2,1)+ANGLE(2,2).GE.180.0D0.OR. & ANGLE(3,1)+ANGLE(3,2).GE.180.0D0)THEN LEX=.TRUE. ENDIF TRI(IT)%IP(1)=SP(1) TRI(IT)%IP(2)=ID TRI(IT)%IP(3)=JD TRI(JT)%IP(1)=SP(2) TRI(JT)%IP(2)=ID TRI(JT)%IP(3)=JD DO J=1,3 T(1,J)=XP(TRI(IT)%IP(J)) T(2,J)=YP(TRI(IT)%IP(J)) ENDDO CALL TRIANGLE_ANGLES(T,ANGLE(:,3)) A3=ANGLE(1,3)*ANGLE(2,3)*ANGLE(3,3) ! WRITE(*,'(A15,5F10.2)') 'NEW TRIANGLE_1',ANGLE(:,3),SUM(ANGLE(:,3)),A3 DO J=1,3 T(1,J)=XP(TRI(JT)%IP(J)) T(2,J)=YP(TRI(JT)%IP(J)) ENDDO CALL TRIANGLE_ANGLES(T,ANGLE(:,4)) A4=ANGLE(1,4)*ANGLE(2,4)*ANGLE(3,4) ! WRITE(*,'(A15,5F10.2)') 'NEW TRIANGLE_2',ANGLE(:,4),SUM(ANGLE(:,4)),A4 ! WRITE(*,'(55X,F10.2)') A3+A4 !## reset as it is no improvement and new polygon is not convex IF(A3+A4.LE.A1+A2.OR.LEX)THEN DO JJ=1,3; TRI(IT)%IP(JJ)=BP(1,JJ); ENDDO DO JJ=1,3; TRI(JT)%IP(JJ)=BP(2,JJ); ENDDO ENDIF ENDIF EXIT ENDIF ENDDO ENDDO ! WRITE(*,*) 'NEW CYCLE' DO IT=1,NT DO J=1,3 T(1,J)=XP(TRI(IT)%IP(J)) T(2,J)=YP(TRI(IT)%IP(J)) ENDDO !## determine angles CALL TRIANGLE_ANGLES(T,ANGLE(:,1)) A=TRIANGLE_AREA(T) ! WRITE(*,'(I10,G10.1,3F10.3)') IT,ABS(A),ANGLE(:,1) ENDDO ENDDO DO IT=1,NT DO J=1,3 T(1,J)=XP(TRI(IT)%IP(J)) T(2,J)=YP(TRI(IT)%IP(J)) ENDDO !## determine angles CALL TRIANGLE_ANGLES(T,ANGLE(:,1)) A=TRIANGLE_AREA(T) WRITE(*,'(I10,G10.1,3F10.3)') IT,ABS(A),ANGLE(:,1) ENDDO !## plot triangles CALL UTL_CREATEDIR(IPFPPS(:INDEX(IPFPPS,'\',.TRUE.)-1)) JU=UTL_GETUNIT(); OPEN(JU,FILE=IPFPPS(:INDEX(IPFPPS,'.',.TRUE.)-1)//'.GEN',STATUS='REPLACE',ACTION='WRITE') DO I=1,NT WRITE(JU,'(I10)') I WRITE(JU,'(2F15.3)') XP(TRI(I)%IP(1)),YP(TRI(I)%IP(1)) WRITE(JU,'(2F15.3)') XP(TRI(I)%IP(2)),YP(TRI(I)%IP(2)) WRITE(JU,'(2F15.3)') XP(TRI(I)%IP(3)),YP(TRI(I)%IP(3)) WRITE(JU,'(2F15.3)') XP(TRI(I)%IP(1)),YP(TRI(I)%IP(1)) WRITE(JU,'(A)') 'END' ENDDO WRITE(JU,'(A)') 'END' CLOSE(JU) KU=UTL_GETUNIT(); OPEN(JU,FILE=IPFPPS(:INDEX(IPFPPS,'.',.TRUE.)-1)//'.PRJ',STATUS='REPLACE',ACTION='WRITE') SELECT CASE (PPTYPE) !## use points CASE (0) !## plot used points of triangles JU=UTL_GETUNIT(); OPEN(JU,FILE=IPFPPS(:INDEX(IPFPPS,'.',.TRUE.)-1)//'_POINTS.IPF',STATUS='REPLACE',ACTION='WRITE') WRITE(JU,*) NP; WRITE(JU,'(A)') '4'; WRITE(JU,'(A)') 'X'; WRITE(JU,'(A)') 'Y'; WRITE(JU,'(A)') 'NO_PPOINT'; WRITE(JU,'(A)') 'IACT'; WRITE(JU,'(A)') '0,TXT' DO I=1+(4+NINT),NP X=XP(I); Y=YP(I) CALL UTL_TRIANGULATION_OUTPUT(JU,KU,XP,YP,NINT,DCLUSTER,X,Y,IL,IG,PTYPE,NPF,IDF) ENDDO CLOSE(JU) !## plot delauney points (circumcenter) CASE (1) JU=UTL_GETUNIT(); OPEN(JU,FILE=IPFPPS(:INDEX(IPFPPS,'.',.TRUE.)-1)//'_DELAUNEY.IPF',STATUS='REPLACE',ACTION='WRITE') WRITE(JU,*) NT; WRITE(JU,'(A)') '4'; WRITE(JU,'(A)') 'X'; WRITE(JU,'(A)') 'Y'; WRITE(JU,'(A)') 'NO_PPOINT'; WRITE(JU,'(A)') 'IACT'; WRITE(JU,'(A)') '0,TXT' DO I=1,NT DO J=1,3 T(1,J)=XP(TRI(I)%IP(J)) T(2,J)=YP(TRI(I)%IP(J)) ENDDO CALL TRIANGLE_CIRCUMCIRCLE(T,X,Y) CALL UTL_TRIANGULATION_OUTPUT(JU,KU,XP,YP,NINT,DCLUSTER,X,Y,IL,IG,PTYPE,NPF,IDF) ENDDO CLOSE(JU) !## plot incenter points CASE (2) JU=UTL_GETUNIT(); OPEN(JU,FILE=IPFPPS(:INDEX(IPFPPS,'.',.TRUE.)-1)//'_INCENTER.IPF',STATUS='REPLACE',ACTION='WRITE') WRITE(JU,*) NT; WRITE(JU,'(A)') '4'; WRITE(JU,'(A)') 'X'; WRITE(JU,'(A)') 'Y'; WRITE(JU,'(A)') 'NO_PPOINT'; WRITE(JU,'(A)') 'IACT'; WRITE(JU,'(A)') '0,TXT' DO I=1,NT DO J=1,3 T(1,J)=XP(TRI(I)%IP(J)) T(2,J)=YP(TRI(I)%IP(J)) ENDDO CALL TRIANGLE_INCIRCLE(T,X,Y) CALL UTL_TRIANGULATION_OUTPUT(JU,KU,XP,YP,NINT,DCLUSTER,X,Y,IL,IG,PTYPE,NPF,IDF) ENDDO CLOSE(JU) !## plot points of mid of triangles CASE (3) JU=UTL_GETUNIT(); OPEN(JU,FILE=IPFPPS(:INDEX(IPFPPS,'.',.TRUE.)-1)//'_CENTROID.IPF',STATUS='REPLACE',ACTION='WRITE') WRITE(JU,*) NT+NPF; WRITE(JU,'(A)') '4'; WRITE(JU,'(A)') 'X'; WRITE(JU,'(A)') 'Y'; WRITE(JU,'(A)') 'NO_PPOINT'; WRITE(JU,'(A)') 'IACT'; WRITE(JU,'(A)') '0,TXT' J=0; DO I=1,NT !## save known measures IF(I.GT.4*NINT.AND.I.LT.4*NINT+NPF)THEN IG=IG+1; J=J+1 WRITE(JU,'(2F15.3,2I10)') X,Y,IG,1 !## apply factor from ipf(2) READ(IPF(2)%INFO(3,J),*) F !F=1.0D0 !IP WRITE(KU,'(A)') TRIM(VTOS(1))//','//TRIM(PTYPE)//','// TRIM(VTOS(IL))//','// TRIM(VTOS(IG))//','//TRIM(VTOS(F,'F',1))//',1.1,0.01,100.0,10.0,'// TRIM(VTOS(IG))//',1,'// & TRIM(PTYPE)//'_G'//TRIM(VTOS(IG))//'_L'//TRIM(VTOS(IL))//'1.0' ENDIF X=XP(TRI(I)%IP(1))+XP(TRI(I)%IP(2))+XP(TRI(I)%IP(3)); X=X/3.0D0 Y=YP(TRI(I)%IP(1))+YP(TRI(I)%IP(2))+YP(TRI(I)%IP(3)); Y=Y/3.0D0 CALL UTL_TRIANGULATION_OUTPUT(JU,KU,XP,YP,NINT,DCLUSTER,X,Y,IL,IG,PTYPE,NPF,IDF) ENDDO CLOSE(JU) END SELECT DEALLOCATE(TRI) END SUBROUTINE UTL_TRIANGULATION !###====================================================================== SUBROUTINE UTL_TRIANGULATION_OUTPUT(JU,KU,XP,YP,NINT,DCLUSTER,X,Y,IL,IG,PTYPE,NPF,IDF) !###====================================================================== IMPLICIT NONE REAL(KIND=DP_KIND),INTENT(IN),DIMENSION(:) :: XP,YP INTEGER,INTENT(IN) :: NINT,JU,IL,NPF,KU TYPE(IDFOBJ),INTENT(INOUT) :: IDF INTEGER,INTENT(INOUT) :: IG CHARACTER(LEN=*),INTENT(IN) :: PTYPE ! CHARACTER(LEN=52) :: CDATE1,CDATE2 REAL(KIND=DP_KIND),INTENT(IN) :: DCLUSTER,X,Y INTEGER :: IACT,J,IROW,ICOL IACT=1 DO J=1+(4*NINT),NPF+4*NINT-1 IF(UTL_DIST(XP(J),YP(J),X,Y).LE.DCLUSTER)IACT=0 ENDDO !## check idf if available IF(ASSOCIATED(IDF%X))THEN CALL IDFIROWICOL(IDF,IROW,ICOL,X,Y) IF(ICOL.EQ.0.OR.IROW.EQ.0)THEN IACT=0 ELSE IF(IDF%X(ICOL,IROW).EQ.IDF%NODATA)IACT=0 ENDIF ENDIF IG=IG+1 WRITE(JU,'(2F15.3,2I10)') X,Y,IG,IACT ! DO ! IF()THEN WRITE(KU,'(A)') TRIM(VTOS(IACT))//','//TRIM(PTYPE)//','// TRIM(VTOS(IL))//','// TRIM(VTOS(IG))//',1.0,1.1,0.01,100.0,10.0,'// TRIM(VTOS(IG))//',1,'// & TRIM(PTYPE)//'_G'//TRIM(VTOS(IG))//'_L'//TRIM(VTOS(IL))//',1.0,1.0' ! ELSE ! WRITE(KU,'(A)') TRIM(VTOS(IACT))//','//TRIM(PTYPE)//','// TRIM(VTOS(IL))//','// TRIM(VTOS(IG))//',1.0,1.1,0.01,100.0,10.0,'// TRIM(VTOS(IG))//',1,'// & ! TRIM(PTYPE)//'_G'//TRIM(VTOS(IG))//'_L'//TRIM(VTOS(IL))//',1.0,1.0,'//TRIM(CDATE1)//','//TRIM(CDATE2) ! ENDIF ! ENDDO END SUBROUTINE UTL_TRIANGULATION_OUTPUT !###====================================================================== SUBROUTINE TRIANGLE_ANGLES(T,ANGLE) !###====================================================================== IMPLICIT NONE REAL(KIND=DP_KIND) :: A,B,C REAL(KIND=DP_KIND),DIMENSION(3),INTENT(OUT) :: ANGLE(:) REAL(KIND=DP_KIND),DIMENSION(2,3),INTENT(IN) :: T !## compute the length of each side. A=SQRT((T(1,2)-T(1,1))**2.0D0+(T(2,2)-T(2,1))**2.0D0) B=SQRT((T(1,3)-T(1,2))**2.0D0+(T(2,3)-T(2,2))**2.0D0) C=SQRT((T(1,1)-T(1,3))**2.0D0+(T(2,1)-T(2,3))**2.0D0) !## take care of ridiculous special cases IF(A.EQ.0.0D+00.AND.B.EQ.0.0D0.AND.C.EQ.0.0D0)THEN ANGLE(1:3)=2.0D0*PI/3.0D0; RETURN END IF IF(C.EQ.0.0D0.OR.A.EQ.0.0D0)THEN ANGLE(1)=PI ELSE ANGLE(1)=ARC_COSINE((C*C+A*A-B*B)/(2.0D0*C*A)) END IF IF(A.EQ.0.0D0.OR.B.EQ.0.0D0)THEN ANGLE(2)=PI ELSE ANGLE(2)=ARC_COSINE((A*A+B*B-C*C)/(2.0D0*A*B)) END IF IF(B.EQ.0.0D0.OR.C.EQ.0.0D0)THEN ANGLE(3)=PI ELSE ANGLE(3)=ARC_COSINE((B*B+C*C-A*A)/(2.0D0*B*C)) END IF ANGLE=ANGLE*360.0D0/(2.0D0*PI) END SUBROUTINE TRIANGLE_ANGLES !###====================================================================== REAL(KIND=DP_KIND) FUNCTION ARC_COSINE(C) !###====================================================================== IMPLICIT NONE REAL(KIND=DP_KIND), INTENT(IN) :: C REAL(KIND=DP_KIND) :: C2 C2=C; C2=MAX(C2,-1.0D0); C2=MIN(C2,1.0D0) ARC_COSINE=ACOS(C2) END FUNCTION ARC_COSINE !###====================================================================== REAL(KIND=DP_KIND) FUNCTION TRIANGLE_AREA(T) !###====================================================================== IMPLICIT NONE REAL(KIND=DP_KIND),DIMENSION(2,3) :: T TRIANGLE_AREA=0.5D0*(T(1,1)*(T(2,2)-T(2,3))+ & T(1,2)*(T(2,3)-T(2,1))+ & T(1,3)*(T(2,1)-T(2,2))) END FUNCTION TRIANGLE_AREA !###====================================================================== SUBROUTINE TRIANGLE_CIRCUMCIRCLE(T,XC,YC) !###====================================================================== IMPLICIT NONE REAL(KIND=DP_KIND),INTENT(IN),DIMENSION(2,3) :: T REAL(KIND=DP_KIND),INTENT(OUT) :: XC,YC REAL(KIND=DP_KIND) :: A,B,BOT,C,DET,R REAL(KIND=DP_KIND),DIMENSION(2) :: F,TOP !## circumradius A=SQRT((T(1,2)-T(1,1))**2.0D0+(T(2,2)-T(2,1))**2.0D0) B=SQRT((T(1,3)-T(1,2))**2.0D0+(T(2,3)-T(2,2))**2.0D0) C=SQRT((T(1,1)-T(1,3))**2.0D0+(T(2,1)-T(2,3))**2.0D0) BOT=(A+B+C)*(-A+B+C)*(A-B+C)*(A+B-C) IF(BOT.LE.0.0D0)THEN R=-1.0D0 XC=0.0D0 YC=0.0D0 RETURN ENDIF R=A*B*C/SQRT(BOT) !## circumcenter. F(1)=(T(1,2)-T(1,1))**2+(T(2,2)-T(2,1))**2.0D0 F(2)=(T(1,3)-T(1,1))**2+(T(2,3)-T(2,1))**2.0D0 TOP(1)= (T(2,3)-T(2,1))*F(1)-(T(2,2)-T(2,1))*F(2) TOP(2)=-(T(1,3)-T(1,1))*F(1)+(T(1,2)-T(1,1))*F(2) DET=(T(2,3)-T(2,1))*(T(1,2)-T(1,1)) & -(T(2,2)-T(2,1))*(T(1,3)-T(1,1)) XC=T(1,1)+0.5D+00*TOP(1)/DET YC=T(2,1)+0.5D+00*TOP(2)/DET END SUBROUTINE TRIANGLE_CIRCUMCIRCLE !###====================================================================== SUBROUTINE TRIANGLE_INCIRCLE(T,X,Y) !###====================================================================== IMPLICIT NONE REAL(KIND=DP_KIND),DIMENSION(2,3),INTENT(IN) :: T REAL(KIND=DP_KIND) :: A,B,C,PERIMETER,R REAL(KIND=DP_KIND),INTENT(OUT) :: X,Y !## compute the length of each side. A=SQRT((T(1,2)-T(1,1))**2.0D0+(T(2,2)-T(2,1))**2.0D0) B=SQRT((T(1,3)-T(1,2))**2.0D0+(T(2,3)-T(2,2))**2.0D0) C=SQRT((T(1,1)-T(1,3))**2.0D0+(T(2,1)-T(2,3))**2.0D0) PERIMETER=A+B+C IF(PERIMETER.EQ.0.0D0)THEN X=T(1,1); Y=T(2,1); R=0.0D0; RETURN ENDIF X=(B*T(1,1)+C*T(1,2)+A*T(1,3))/PERIMETER Y=(B*T(2,1)+C*T(2,2)+A*T(2,3))/PERIMETER R=0.5D0*SQRT((-A+B+C)*(+A-B+C)*(+A+B-C)/PERIMETER) END SUBROUTINE TRIANGLE_INCIRCLE !###====================================================================== INTEGER FUNCTION UTL_POINT_IN_TRIANGLE(A,B,C,P) !###====================================================================== IMPLICIT NONE REAL(KIND=DP_KIND),DIMENSION(:) :: A,B,C,P REAL(KIND=DP_KIND) :: X,Y,Z UTL_POINT_IN_TRIANGLE=-1 !## check whether points of triangle equal to point p ! WRITE(*,*) SUM(P-A) ! WRITE(*,*) SUM(P-B) ! WRITE(*,*) SUM(P-C) IF(P(1)-A(1).EQ.0.0D0.AND.P(2)-A(2).EQ.0.0D0)RETURN IF(P(1)-B(1).EQ.0.0D0.AND.P(2)-B(2).EQ.0.0D0)RETURN IF(P(1)-C(1).EQ.0.0D0.AND.P(2)-C(2).EQ.0.0D0)RETURN !IF(SUM(P-B).EQ.0.0D0)RETURN !IF(SUM(P-C).EQ.0.0D0)RETURN UTL_POINT_IN_TRIANGLE=0 Z= UTL_DETERMINANT(A,B)+UTL_DETERMINANT(B,C)+UTL_DETERMINANT(C,A) IF(Z.EQ.0.0D0)THEN WRITE(*,'(A)') '>>> THIS IS NOT A TRIANGLE <<<'; RETURN ENDIF X=(UTL_DETERMINANT(A,B)+UTL_DETERMINANT(B,P)+UTL_DETERMINANT(P,A))/Z Y=(UTL_DETERMINANT(C,A)+UTL_DETERMINANT(A,P)+UTL_DETERMINANT(P,C))/Z IF(X+Y.LE.1.0D0)THEN IF(X.GE.0.0D0.AND.X.LE.1.0D0.AND. & Y.GE.0.0D0.AND.Y.LE.1.0D0)UTL_POINT_IN_TRIANGLE=1 ENDIF END FUNCTION UTL_POINT_IN_TRIANGLE !###====================================================================== REAL(KIND=DP_KIND) FUNCTION UTL_DETERMINANT(A,B) !###====================================================================== IMPLICIT NONE REAL(KIND=DP_KIND),INTENT(IN),DIMENSION(2) :: A,B UTL_DETERMINANT=A(1)*B(2)-A(2)*B(1) END FUNCTION UTL_DETERMINANT !###====================================================================== SUBROUTINE IMODBATH_CREATEPILOTPOINTS() !###====================================================================== USE MOD_UTL, ONLY : UTL_MINTHICKNESS IMPLICIT NONE TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: BND,VCW,TOP,BOT,KVV,PPT1,PPT2,KHV,KVA TYPE(IDFOBJ) :: MASK INTEGER :: I,II,JJ,NLAY,ILAY,IVCW,DI,IROW,ICOL,NG,N,JU,KU,NP,IAQUIFER,IAQUITARD,IQ3D,IFM,IMASK,IACT,IMETHOD,IG, & MAXCOL,IOS,IGEN,IPOL,IC1,IR1 REAL(KIND=DP_KIND) :: MINC,T,K,C,X,Y,C1,C2 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: DX CHARACTER(LEN=256) :: OUTPUTFOLDER CHARACTER(LEN=2) :: CPARAM1,CPARAM2 REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:) :: TP,BT,HK,VK,VA,TP_BU,BT_BU,HK_BU,VK_BU,VA_BU REAL(KIND=DP_KIND),ALLOCATABLE,DIMENSION(:,:) :: TH INTEGER,ALLOCATABLE,DIMENSION(:) :: IB LOGICAL :: LEX TYPE STROBJ CHARACTER(LEN=52) :: STRING END TYPE TYPE(STROBJ),ALLOCATABLE,DIMENSION(:) :: STR !## method IMETHOD=1; IF(UTL_READINITFILE('IMETHOD',LINE,IU,1))READ(LINE,*) IMETHOD WRITE(*,'(A)') 'IMETHOD='//TRIM(VTOS(IMETHOD)) IMASK=0; IF(UTL_READINITFILE('MASK',LINE,IU,1))THEN IMASK=1; READ(LINE,*) MASK%FNAME; WRITE(*,'(A)') 'MASK='//TRIM(MASK%FNAME) ENDIF IF(IMETHOD.EQ.2)THEN; CALL IMODBATCH_CREATEPILOTPOINTS_IPF(IMASK,MASK); STOP; ENDIF IGEN=0; IF(UTL_READINITFILE('GENFNAME',LINE,IU,1))THEN IGEN=1; READ(LINE,*) GENFNAME; WRITE(*,'(A)') 'GENFNAME='//TRIM(GENFNAME) !## origin file CALL POLYGON1SAVELOADSHAPE(ID_LOADSHAPE,TRIM(GENFNAME),'GEN') IF(SHP%NPOL.LE.0)THEN; WRITE(*,'(/A/)') 'No polygons found in GEN file'; STOP; ENDIF !## make sure at least a column with cell_size is active IF(SIZE(SHP%COLNAMES).LE.1)THEN; WRITE(*,'(/A/)') 'Need to have at least 2 columns in GEN file'; STOP; ENDIF MAXCOL=0; IF(ASSOCIATED(SHP%COLNAMES))MAXCOL=SIZE(SHP%COLNAMES); ALLOCATE(STR(MAXCOL)); ALLOCATE(DX(SHP%NPOL)) DO I=1,SHP%NPOL DO II=1,MAXCOL STR(II)%STRING=''; DO JJ=1,SHP%LWIDTH(II); STR(II)%STRING(JJ:JJ)=SHP%POL(I)%LBL(II)%STRING(JJ); ENDDO ENDDO !## read cellsize in polygon READ(STR(2)%STRING,*,IOSTAT=IOS) DX(I) IF(IOS.NE.0)THEN; WRITE(*,'(/A/)') 'Cannot read cellsize for polygon #',I; STOP; ENDIF ENDDO ELSE !## read in dx, cannot specify different per layer due to aggregation IF(.NOT.UTL_READINITFILE('DX',LINE,IU,0))RETURN ALLOCATE(DX(1)); READ(LINE,*) DX(1); WRITE(*,'(A)') 'DX='//TRIM(VTOS(DX(1),'F',2)) ENDIF IF(.NOT.UTL_READINITFILE('NLAY',LINE,IU,0))RETURN READ(LINE,*) NLAY; WRITE(*,'(A)') 'NLAY='//TRIM(VTOS(NLAY)) IF(.NOT.UTL_READINITFILE('OUTPUTFOLDER',LINE,IU,0))RETURN READ(LINE,*) OUTPUTFOLDER; WRITE(*,'(A)') 'OUTPUTFOLDER='//TRIM(OUTPUTFOLDER) CALL UTL_CREATEDIR(OUTPUTFOLDER) IF(IMETHOD.EQ.1)THEN !## group number IG=1; IF(UTL_READINITFILE('IGROUP',LINE,IU,1))READ(LINE,*) IG WRITE(*,'(A)') 'IGROUP='//TRIM(VTOS(IG)) CPARAM1='KH'; IF(UTL_READINITFILE('PTYPE',LINE,IU,1))READ(LINE,*) CPARAM1 WRITE(*,'(A)') 'PTYPE='//TRIM(CPARAM1) ALLOCATE(BND(NLAY)) DO ILAY=1,NLAY CALL IDFNULLIFY(BND(ILAY)); IF(.NOT.UTL_READINITFILE('BND_L'//TRIM(VTOS(ILAY)),LINE,IU,0))RETURN READ(LINE,*) BND(ILAY)%FNAME; WRITE(*,'(A)') 'BND_L'//TRIM(VTOS(ILAY))//'='//TRIM(BND(ILAY)%FNAME) WRITE(*,'(A)') 'Reading BND_L'//TRIM(VTOS(ILAY))//' '//TRIM(BND(ILAY)%FNAME)//'...' IF(.NOT.IDFREAD(BND(ILAY),BND(ILAY)%FNAME,1))STOP 'Cannot read data for BND' DO IROW=1,BND(ILAY)%NROW; DO ICOL=1,BND(ILAY)%NCOL IF(BND(ILAY)%X(ICOL,IROW).EQ.0.0D0) BND(ILAY)%X(ICOL,IROW)=HUGE(1.0) IF(BND(ILAY)%X(ICOL,IROW).EQ.BND(ILAY)%NODATA)BND(ILAY)%X(ICOL,IROW)=HUGE(1.0) ENDDO; ENDDO; BND(ILAY)%NODATA=HUGE(1.0) DO IROW=1,BND(ILAY)%NROW; DO ICOL=1,BND(ILAY)%NCOL IF(BND(ILAY)%X(ICOL,IROW).NE.BND(ILAY)%NODATA)BND(ILAY)%X(ICOL,IROW)=0.0D0 ENDDO; ENDDO ENDDO !## read msk in same resolution as bnd CALL IDFCOPY(BND(1),MASK) IF(IMASK.EQ.1)THEN IF(.NOT.IDFREADSCALE(MASK%FNAME,MASK,7,1,0.0D0,0))STOP 'Cannot read data for MASK' ELSE MASK%X=1.0D0 ENDIF IF(IGEN.EQ.0)SHP%NPOL=1 NG=IG-1; NP=0 DO IPOL=1,SHP%NPOL DO ILAY=1,NLAY DI=MAX(1,INT(DX(IPOL)/BND(ILAY)%DX)); IC1=MAX(1,INT(0.5D0*DI)); IR1=MAX(INT(0.5D0*DI),1) DO IROW=IR1,BND(ILAY)%NROW,DI; DO ICOL=IC1,BND(ILAY)%NCOL,DI !## skip inactive cells IF(BND(ILAY)%X(ICOL,IROW).EQ.BND(ILAY)%NODATA)CYCLE !## allready occupied IF(BND(ILAY)%X(ICOL,IROW).NE.0.0D0)CYCLE IF(MASK%X(ICOL,IROW).EQ.MASK%NODATA.OR.MASK%X(ICOL,IROW).EQ.0.0D0)CYCLE LEX=.TRUE. IF(IGEN.EQ.1)THEN LEX=.FALSE.; CALL IDFGETLOC(BND(ILAY),IROW,ICOL,X,Y) IF(DBL_IGRINSIDESHAPE(X,Y,SHP%POL(IPOL)).EQ.1)LEX=.TRUE. ENDIF IF(LEX)THEN NG=NG+1; NP=NP+1; BND(ILAY)%X(ICOL,IROW)=NG ENDIF ENDDO; ENDDO ENDDO ENDDO KU=UTL_GETUNIT(); OPEN(KU,FILE=TRIM(OUTPUTFOLDER)//'\PILOTPOINT_AQUIFER.PRJ',ACTION='WRITE',FORM='FORMATTED') WRITE(KU,'(I10,A)') NP,',(PST) PARAMETER ESTIMATION,1' WRITE(KU,*) '1' WRITE(KU,*) 'FILE.IPF,2,1,2,4,3,-5' WRITE(KU,*) '99,0.0,0.0,0,0,1.0,0.0,3,0.0,0.0,2,0.0,0,1.0' !## write IPF and PRJ NP=0 DO ILAY=1,NLAY; DO I=1,2; N=0 DO IROW=1,BND(ILAY)%NROW; DO ICOL=1,BND(ILAY)%NCOL IF(BND(ILAY)%X(ICOL,IROW).EQ.BND(ILAY)%NODATA.OR.BND(ILAY)%X(ICOL,IROW).EQ.0.0D0)CYCLE; N=N+1 IF(I.EQ.2)THEN NG=BND(ILAY)%X(ICOL,IROW) NP=NP+1 CALL IDFGETLOC(BND(ILAY),IROW,ICOL,X,Y) WRITE(JU,'(2(F10.2,1X),2(I10,1X),2(F10.2,1X),I5)') X,Y,NP,INT(BND(ILAY)%X(ICOL,IROW)),-DBLE(ILAY)+0.5D0,-DBLE(ILAY)-0.5D0,1 WRITE(KU,'(A)') TRIM(VTOS(1))//','//TRIM(CPARAM1)//','//TRIM(VTOS(ILAY))//','//TRIM(VTOS(NP))//',1.0,1.1,0.01,100.0,10.0,'// & TRIM(VTOS(NG))//',1,'//TRIM(CPARAM1)//'_GRP'//TRIM(VTOS(NG))//',1.0' ENDIF ENDDO; ENDDO IF(I.EQ.1)THEN JU=UTL_GETUNIT(); OPEN(JU,FILE=TRIM(OUTPUTFOLDER)//'\PILOTPOINT_'//TRIM(CPARAM1)//'_L'//TRIM(VTOS(ILAY))//'.IPF',ACTION='WRITE',FORM='FORMATTED') WRITE(JU,*) N; WRITE(JU,*) 7; WRITE(JU,*) 'X'; WRITE(JU,*) 'Y'; WRITE(JU,*) 'PARAMETER' WRITE(JU,*) 'ZONE'; WRITE(JU,*) 'T'; WRITE(JU,*) 'B'; WRITE(JU,*) 'IACT'; WRITE(JU,*) '0,TXT' ELSE CLOSE(JU) ENDIF ENDDO; ENDDO WRITE(KU,'(I10)') NLAY DO ILAY=1,NLAY; WRITE(KU,'(A)') TRIM(OUTPUTFOLDER)//'\PILOTPOINT_'//TRIM(CPARAM1)//'_L'//TRIM(VTOS(ILAY))//'.IPF'; ENDDO STOP ENDIF !## per layer or per kh IFM=0; IF(UTL_READINITFILE('IFM',LINE,IU,1))READ(LINE,*) IFM WRITE(*,'(A)') 'IFM='//TRIM(VTOS(IFM)) IF(IFM.EQ.0)THEN !## define quasi/3d simulations IQ3D=1; IF(UTL_READINITFILE('IQ3D',LINE,IU,1))READ(LINE,*) IQ3D WRITE(*,'(A)') 'IQ3D='//TRIM(VTOS(IQ3D)) IF(IQ3D.EQ.1)THEN IAQUIFER=0; IF(UTL_READINITFILE('IAQUIFER',LINE,IU,1))READ(LINE,*) IAQUIFER WRITE(*,'(A)') 'IAQUIFER='//TRIM(VTOS(IAQUIFER)) IAQUITARD=0; IF(UTL_READINITFILE('IAQUITARD',LINE,IU,1))READ(LINE,*) IAQUITARD WRITE(*,'(A)') 'IAQUITARD='//TRIM(VTOS(IAQUITARD)) ELSE IAQUIFER=1; IAQUITARD=0 ENDIF IVCW=0 IF(IQ3D.EQ.1)THEN IF(UTL_READINITFILE('IVCW',LINE,IU,1))READ(LINE,*) IVCW WRITE(*,'(A)') 'IVCW='//TRIM(VTOS(IVCW)) ENDIF IF(.NOT.UTL_READINITFILE('MINC',LINE,IU,0))RETURN READ(LINE,*) MINC; WRITE(*,'(A)') 'MINC='//TRIM(VTOS(MINC,'F',2)) ELSE IQ3D=0; IVCW=0; IAQUIFER=1; IAQUITARD=0; MINC=0.0D0 ENDIF CPARAM1='KH'; IF(IVCW.EQ.1)CPARAM1='KD'; CPARAM2='KV'; IF(IVCW.EQ.1)CPARAM2='VC' ALLOCATE(BND(NLAY),PPT1(NLAY),PPT2(NLAY-1)) IF(IVCW.EQ.1)THEN ALLOCATE(VCW(NLAY)) ELSE ALLOCATE(TOP(NLAY),BOT(NLAY)) IF(IQ3D.EQ.1)THEN ALLOCATE(KVV(NLAY)) ELSE ALLOCATE(KHV(NLAY),KVA(NLAY)) ENDIF ENDIF DO ILAY=1,NLAY CALL IDFNULLIFY(PPT1(ILAY)); CALL IDFNULLIFY(BND(ILAY)) IF(.NOT.UTL_READINITFILE('BND_L'//TRIM(VTOS(ILAY)),LINE,IU,0))RETURN READ(LINE,*) BND(ILAY)%FNAME; WRITE(*,'(A)') 'BND_L'//TRIM(VTOS(ILAY))//'='//TRIM(BND(ILAY)%FNAME) IF(IVCW.EQ.1)THEN IF(ILAY.LT.NLAY)THEN CALL IDFNULLIFY(VCW(ILAY)); CALL IDFNULLIFY(PPT2(ILAY)) IF(.NOT.UTL_READINITFILE('VCW_L'//TRIM(VTOS(ILAY)),LINE,IU,0))RETURN READ(LINE,*) VCW(ILAY)%FNAME; WRITE(*,'(A)') 'VCW_L'//TRIM(VTOS(ILAY))//'='//TRIM(VCW(ILAY)%FNAME) ENDIF ELSE CALL IDFNULLIFY(TOP(ILAY)) IF(.NOT.UTL_READINITFILE('TOP_L'//TRIM(VTOS(ILAY)),LINE,IU,0))RETURN READ(LINE,*) TOP(ILAY)%FNAME; WRITE(*,'(A)') 'TOP_L'//TRIM(VTOS(ILAY))//'='//TRIM(TOP(ILAY)%FNAME) CALL IDFNULLIFY(BOT(ILAY)) IF(.NOT.UTL_READINITFILE('BOT_L'//TRIM(VTOS(ILAY)),LINE,IU,0))RETURN READ(LINE,*) BOT(ILAY)%FNAME; WRITE(*,'(A)') 'BOT_L'//TRIM(VTOS(ILAY))//'='//TRIM(BOT(ILAY)%FNAME) IF(IQ3D.EQ.1)THEN IF(ILAY.LT.NLAY)THEN CALL IDFNULLIFY(KVV(ILAY)) IF(.NOT.UTL_READINITFILE('KVV_L'//TRIM(VTOS(ILAY)),LINE,IU,0))RETURN READ(LINE,*) KVV(ILAY)%FNAME; WRITE(*,'(A)') 'KVV_L'//TRIM(VTOS(ILAY))//'='//TRIM(KVV(ILAY)%FNAME) ENDIF ELSE CALL IDFNULLIFY(KHV(ILAY)) IF(IFM.EQ.0)THEN IF(.NOT.UTL_READINITFILE('KHV_L'//TRIM(VTOS(ILAY)),LINE,IU,0))RETURN READ(LINE,*) KHV(ILAY)%FNAME; WRITE(*,'(A)') 'KHV_L'//TRIM(VTOS(ILAY))//'='//TRIM(KHV(ILAY)%FNAME) ENDIF CALL IDFNULLIFY(KVA(ILAY)) IF(IFM.EQ.0)THEN IF(.NOT.UTL_READINITFILE('KVA_L'//TRIM(VTOS(ILAY)),LINE,IU,0))RETURN READ(LINE,*) KVA(ILAY)%FNAME; WRITE(*,'(A)') 'KVA_L'//TRIM(VTOS(ILAY))//'='//TRIM(KVA(ILAY)%FNAME) ENDIF ENDIF ENDIF ENDDO !## read bnd files DO ILAY=1,NLAY WRITE(*,'(A)') 'Reading BND_L'//TRIM(VTOS(ILAY))//' '//TRIM(BND(ILAY)%FNAME)//'...' IF(.NOT.IDFREAD(BND(ILAY),BND(ILAY)%FNAME,1))STOP 'Cannot read data for BND' IF(IAQUIFER.EQ.1)CALL IDFCOPY(BND(ILAY),PPT1(ILAY)) IF(IAQUITARD.EQ.1.AND.ILAY.LT.NLAY)CALL IDFCOPY(BND(ILAY),PPT2(ILAY)) ENDDO DO ILAY=1,NLAY IF(IVCW.EQ.1)THEN IF(ILAY.LT.NLAY)THEN WRITE(*,'(A)') 'Reading VCW_L'//TRIM(VTOS(ILAY))//' '//TRIM(VCW(ILAY)%FNAME)//'...' CALL IDFCOPY(BND(ILAY),VCW(ILAY)); IF(.NOT.IDFREADSCALE(VCW(ILAY)%FNAME,VCW(ILAY),3,1,0.0D0,0))STOP 'Cannot read data for VCW' ENDIF ELSE IF(IQ3D.EQ.1)THEN IF(ILAY.LT.NLAY)THEN WRITE(*,'(A)') 'Reading KVV_L'//TRIM(VTOS(ILAY))//' '//TRIM(KVV(ILAY)%FNAME)//'...' CALL IDFCOPY(BND(ILAY),KVV(ILAY)); IF(.NOT.IDFREADSCALE(KVV(ILAY)%FNAME,KVV(ILAY),3,1,0.0D0,0))STOP 'Cannot read data for KVV' ENDIF ELSE CALL IDFCOPY(BND(ILAY),KHV(ILAY)); CALL IDFCOPY(BND(ILAY),KVA(ILAY)) IF(IFM.EQ.0)THEN WRITE(*,'(A)') 'Reading KHV_L'//TRIM(VTOS(ILAY))//' '//TRIM(KHV(ILAY)%FNAME)//'...' IF(.NOT.IDFREADSCALE(KHV(ILAY)%FNAME,KHV(ILAY),3,1,0.0D0,0))STOP 'Cannot read data for KHV' WRITE(*,'(A)') 'Reading KVA_L'//TRIM(VTOS(ILAY))//' '//TRIM(KVA(ILAY)%FNAME)//'...' IF(.NOT.IDFREADSCALE(KVA(ILAY)%FNAME,KVA(ILAY),2,1,0.0D0,0))STOP 'Cannot read data for KVA' ELSE KHV(ILAY)%X=KHV(ILAY)%NODATA; KVA(ILAY)%X=KVA(ILAY)%NODATA DO IROW=1,BND(ILAY)%NROW; DO ICOL=1,BND(ILAY)%NCOL IF(BND(ILAY)%X(ICOL,IROW).GT.0)THEN KHV(ILAY)%X(ICOL,IROW)=ILAY KVA(ILAY)%X(ICOL,IROW)=1.0D0 ENDIF ENDDO; ENDDO ENDIF ENDIF WRITE(*,'(A)') 'Reading TOP_L'//TRIM(VTOS(ILAY))//' '//TRIM(TOP(ILAY)%FNAME)//'...' CALL IDFCOPY(BND(ILAY),TOP(ILAY)); IF(.NOT.IDFREADSCALE(TOP(ILAY)%FNAME,TOP(ILAY),2,1,0.0D0,0))STOP 'Cannot read data for TOP' WRITE(*,'(A)') 'Reading BOT_L'//TRIM(VTOS(ILAY))//' '//TRIM(BOT(ILAY)%FNAME)//'...' CALL IDFCOPY(BND(ILAY),BOT(ILAY)); IF(.NOT.IDFREADSCALE(BOT(ILAY)%FNAME,BOT(ILAY),2,1,0.0D0,0))STOP 'Cannot read data for BOT' ENDIF ENDDO !## read mask file IF(IMASK.EQ.1)THEN WRITE(*,'(A)') 'Reading '//TRIM(MASK%FNAME)//'...' CALL IDFCOPY(BND(1),MASK); IF(.NOT.IDFREADSCALE(MASK%FNAME,MASK,7,1,0.0D0,0))STOP 'Cannot read data for MASK' DO IROW=1,MASK%NROW; DO ICOL=1,MASK%NCOL IF(MASK%X(ICOL,IROW).EQ.0.0D0)MASK%X(ICOL,IROW)=MASK%NODATA ENDDO; ENDDO ENDIF IF(IFM.EQ.1)THEN ALLOCATE(TP(NLAY) ,BT(NLAY), HK(NLAY), VK(NLAY), VA(NLAY), IB(NLAY)) ALLOCATE(TP_BU(NLAY),BT_BU(NLAY),HK_BU(NLAY),VK_BU(NLAY),VA_BU(NLAY),TH(NLAY,2)) !## is het niet de eerste laag wordt het? DO IROW=1,BND(1)%NROW; DO ICOL=1,BND(1)%NCOL; DO ILAY=1,NLAY IB(ILAY)=BND(ILAY)%X(ICOL,IROW) TP(ILAY)=TOP(ILAY)%X(ICOL,IROW) BT(ILAY)=BOT(ILAY)%X(ICOL,IROW) HK(ILAY)=ILAY VK(ILAY)=1.0D0; IF(IQ3D.EQ.1)VK(ILAY)=KVV(ILAY)%X(ICOL,IROW) VA(ILAY)=KVA(ILAY)%X(ICOL,IROW) ENDDO CALL UTL_MINTHICKNESS(TP,BT,HK,VK,VA,TP_BU,BT_BU,HK_BU,VK_BU,VA_BU,IB,TH,1.0D0,NLAY,ICOL,IROW) DO ILAY=1,NLAY KHV(ILAY)%X(ICOL,IROW)=HK(ILAY) ENDDO ENDDO; ENDDO DEALLOCATE(TP,BT,HK,VK,VA,IB,TP_BU,BT_BU,HK_BU,VK_BU,VA_BU,TH) ! DO ILAY=1,NLAY ! KHV%FNAME='D:\TMP_'//TRIM(VTOS(ILAY))//'.IDF' ! IF(.NOT.IDFWRITE(KHV(ILAY),KHV(ILAY)%FNAME,1))THEN; ENDIF ! ENDDO ENDIF NG=0; NP=0 DI=INT(DX(1)/BND(1)%DX) !## put pilotpoints in aquifers IF(IAQUIFER.EQ.1)THEN PPT1%NODATA=-999.99D0 DO ILAY=1,NLAY; PPT1(ILAY)%X=PPT1(ILAY)%NODATA; ENDDO IF(IFM.EQ.0)THEN DO ILAY=1,NLAY PPT1(ILAY)%X=PPT1(ILAY)%NODATA DO IROW=0.5D0*DI,BND(ILAY)%NROW,DI; DO ICOL=0.5D0*DI,BND(ILAY)%NCOL,DI !## skip inactive cells IF(BND(ILAY)%X(ICOL,IROW).EQ.0.0D0)CYCLE !## skip mask cells eq. 0.0 or nodata IF(IMASK.EQ.1)THEN IF(MASK%X(ICOL,IROW).EQ.MASK%NODATA)CYCLE ENDIF IF(ILAY.EQ.1)THEN NG=NG+1; NP=NP+1; PPT1(ILAY)%X(ICOL,IROW)=NG ELSE IF(IVCW.EQ.1)THEN C=VCW(ILAY-1)%X(ICOL,IROW) ELSE IF(IQ3D.EQ.1)THEN T=BOT(ILAY-1)%X(ICOL,IROW)-TOP(ILAY)%X(ICOL,IROW) K=KVV(ILAY-1)%X(ICOL,IROW) C=T/K ELSE T=TOP(ILAY-1)%X(ICOL,IROW)-BOT(ILAY-1)%X(ICOL,IROW) K=KHV(ILAY-1)%X(ICOL,IROW)*KVA(ILAY-1)%X(ICOL,IROW) C1=0.0D0; IF(T.GT.0.0D0.AND.K.GT.0.0D0)C1=(0.5D0*T)/K T=TOP(ILAY )%X(ICOL,IROW)-BOT(ILAY )%X(ICOL,IROW) K=KHV(ILAY )%X(ICOL,IROW)*KVA(ILAY )%X(ICOL,IROW) C2=0.0D0; IF(T.GT.0.0D0.AND.K.GT.0.0D0)C2=(0.5D0*T)/K C=C1+C2 ENDIF ENDIF !## check c to see if similar point can to be used - only if active layer on top of it IF(PPT1(ILAY-1)%X(ICOL,IROW).NE.PPT1(ILAY-1)%NODATA)THEN IF(C.GT.MINC)THEN NG=NG+1 N =NG ELSE N =PPT1(ILAY-1)%X(ICOL,IROW) ENDIF ELSE NG=NG+1 N =NG ENDIF IF(N.LT.0)THEN WRITE(*,*) 'Something went wrong'; STOP ENDIF NP=NP+1 PPT1(ILAY)%X(ICOL,IROW)=N ENDIF ENDDO; ENDDO ENDDO ELSE DO ILAY=1,NLAY PPT1(ILAY)%X=PPT1(ILAY)%NODATA DO IROW=0.5D0*DI,BND(ILAY)%NROW,DI; DO ICOL=0.5D0*DI,BND(ILAY)%NCOL,DI !## skip inactive cells IF(BND(ILAY)%X(ICOL,IROW).EQ.0.0D0)CYCLE IF(ILAY.EQ.1)THEN NG=NG+1; NP=NP+1; PPT1(ILAY)%X(ICOL,IROW)=NG ELSE !## check c to see if similar point need to be used IF(KHV(ILAY)%X(ICOL,IROW).NE.KHV(ILAY-1)%X(ICOL,IROW))THEN NG=NG+1 N =NG ELSE N =PPT1(ILAY-1)%X(ICOL,IROW) ENDIF IF(N.LT.0)THEN WRITE(*,*) 'Something went wrong'; STOP ENDIF NP=NP+1 PPT1(ILAY)%X(ICOL,IROW)=N ENDIF ENDDO; ENDDO ENDDO ENDIF ENDIF ! DO ILAY=1,NLAY ! PPT1%FNAME='D:\TMP_'//TRIM(VTOS(ILAY))//'.IDF' ! IF(.NOT.IDFWRITE(PPT1(ILAY),PPT1(ILAY)%FNAME,1))THEN; ENDIF ! ENDDO !## put pilotpoints in aquitards IF(IAQUITARD.EQ.1)THEN PPT2%NODATA=-999.99D0 DO ILAY=1,NLAY-1 PPT2(ILAY)%X=PPT2(ILAY)%NODATA DO IROW=0.5*DI,BND(ILAY)%NROW,DI; DO ICOL=0.5*DI,BND(ILAY)%NCOL,DI !## skip inactive cells above and below aquitard IF(BND(ILAY)%X(ICOL,IROW).EQ.0.0D0.OR.BND(ILAY+1)%X(ICOL,IROW).EQ.0.0D0)CYCLE !## skip mask cells eq. 0.0 or nodata IF(IMASK.EQ.1)THEN IF(MASK%X(ICOL,IROW).EQ.MASK%NODATA)CYCLE ENDIF IF(IVCW.EQ.1)THEN C=VCW(ILAY-1)%X(ICOL,IROW) ELSE T=MAX(0.0D0,BOT(ILAY)%X(ICOL,IROW)-TOP(ILAY+1)%X(ICOL,IROW)) K=KVV(ILAY)%X(ICOL,IROW) C=T/K ENDIF NG=NG+1 N =NG NP=NP+1 !## check c to see if similar point need to be used IF(C.GT.MINC)THEN PPT2(ILAY)%X(ICOL,IROW)= N ELSE PPT2(ILAY)%X(ICOL,IROW)=-N ENDIF ENDDO; ENDDO ENDDO ENDIF CALL UTL_CREATEDIR(OUTPUTFOLDER) KU=UTL_GETUNIT() IF(IAQUIFER.EQ.1)THEN OPEN(KU,FILE=TRIM(OUTPUTFOLDER)//'\PILOTPOINT_AQUIFER.PRJ',ACTION='WRITE',FORM='FORMATTED') ELSE OPEN(KU,FILE=TRIM(OUTPUTFOLDER)//'\PILOTPOINT_AQUITARD.PRJ',ACTION='WRITE',FORM='FORMATTED') ENDIF WRITE(KU,'(I10,A)') NP,',(PST) PARAMETER ESTIMATION,1' WRITE(KU,*) '1' WRITE(KU,*) 'FILE.IPF,2,1,2,4,3,-5' WRITE(KU,*) '99,0.0,0.0,0,0,1.0,0.0,3,0.0,0.0,2,'//TRIM(VTOS(DX(1)*4.0D0,'F',2))//',0,1.0' !## write IPF and PRJ NP=0 IF(IAQUIFER.EQ.1)THEN DO ILAY=1,NLAY; DO I=1,2; N=0 DO IROW=0.5D0*DI,BND(ILAY)%NROW,DI; DO ICOL=0.5D0*DI,BND(ILAY)%NCOL,DI IF(PPT1(ILAY)%X(ICOL,IROW).EQ.PPT1(ILAY)%NODATA)CYCLE; N=N+1 CALL IDFGETLOC(PPT1(ILAY),IROW,ICOL,X,Y) IF(I.EQ.2)THEN NG=PPT1(ILAY)%X(ICOL,IROW) NP=NP+1 !## skip mask cells eq. 0.0 or nodata IACT=1 ! IF(IMASK.EQ.1)THEN ! IF(MASK%X(ICOL,IROW).EQ.MASK%NODATA)IACT=0 ! ENDIF IF(IVCW.EQ.1)THEN WRITE(JU,'(2(F10.2,1X),2(I10,1X),2(F10.2,1X),I5)') X,Y,NP,INT(PPT1(ILAY)%X(ICOL,IROW)),-DBLE(ILAY)+0.5D0,-DBLE(ILAY)-0.5D0,IACT ELSE WRITE(JU,'(2(F10.2,1X),2(I10,1X),2(F10.2,1X),I5)') X,Y,NP,INT(PPT1(ILAY)%X(ICOL,IROW)),TOP(ILAY)%X(ICOL,IROW),BOT(ILAY)%X(ICOL,IROW),IACT ENDIF WRITE(KU,'(A)') TRIM(VTOS(IACT))//','//TRIM(CPARAM1)//','//TRIM(VTOS(ILAY))//','//TRIM(VTOS(NP))//',1.0,1.1,0.01,100.0,10.0,'// & TRIM(VTOS(NG))//',1,'//TRIM(CPARAM1)//'_GRP'//TRIM(VTOS(NG))//',1.0' ENDIF ENDDO; ENDDO IF(I.EQ.1)THEN JU=UTL_GETUNIT(); OPEN(JU,FILE=TRIM(OUTPUTFOLDER)//'\PILOTPOINT_'//TRIM(CPARAM1)//'_L'//TRIM(VTOS(ILAY))//'.IPF',ACTION='WRITE',FORM='FORMATTED') WRITE(JU,*) N; WRITE(JU,*) 7; WRITE(JU,*) 'X'; WRITE(JU,*) 'Y'; WRITE(JU,*) 'PARAMETER' WRITE(JU,*) 'ZONE'; WRITE(JU,*) 'T'; WRITE(JU,*) 'B'; WRITE(JU,*) 'IACT'; WRITE(JU,*) '0,TXT' ELSE CLOSE(JU) ENDIF ENDDO; ENDDO ENDIF IF(IAQUITARD.EQ.1)THEN DO ILAY=1,NLAY-1; DO I=1,2; N=0 DO IROW=0.5D0*DI,BND(ILAY)%NROW,DI; DO ICOL=0.5D0*DI,BND(ILAY)%NCOL,DI !## skip mask cells eq. 0.0 or nodata IACT=1 ! IF(IMASK.EQ.1)THEN ! IF(MASK%X(ICOL,IROW).EQ.MASK%NODATA)IACT=0 ! ENDIF IF(PPT2(ILAY)%X(ICOL,IROW).EQ.PPT2(ILAY)%NODATA)CYCLE; N=N+1 CALL IDFGETLOC(PPT2(ILAY),IROW,ICOL,X,Y) IF(I.EQ.2)THEN NP=NP+1 IF(IVCW.EQ.1)THEN WRITE(JU,'(2(F10.2,1X),2(I10,1X),2(F10.2,1X),I5)') X,Y,NP,INT(PPT2(ILAY)%X(ICOL,IROW)),-REAL(ILAY,8)+0.5D0,-REAL(ILAY,8)-0.5D0,IACT ELSE WRITE(JU,'(2(F10.2,1X),2(I10,1X),2(F10.2,1X),I5)') X,Y,NP,INT(PPT2(ILAY)%X(ICOL,IROW)),BOT(ILAY)%X(ICOL,IROW),TOP(ILAY+1)%X(ICOL,IROW),IACT ENDIF NG=PPT2(ILAY)%X(ICOL,IROW) IF(NG.GT.0)THEN !## skip mask cells eq. 0.0 or nodata IACT=1 ! IF(IMASK.EQ.1)THEN ! IF(MASK%X(ICOL,IROW).EQ.MASK%NODATA)IACT=0 ! ENDIF WRITE(KU,'(A)') TRIM(VTOS(IACT))//','//TRIM(CPARAM2)//','//TRIM(VTOS(ILAY))//','//TRIM(VTOS(NP))//',1.0,1.1,0.01,100.0,10.0,'// & TRIM(VTOS(NG))//',1,'//TRIM(CPARAM2)//'_GRP'//TRIM(VTOS(NG))//',1.0' ELSE IACT=0 WRITE(KU,'(A)') TRIM(VTOS(IACT))//','//TRIM(CPARAM2)//','//TRIM(VTOS(ILAY))//','//TRIM(VTOS(NP))//',1.0,1.1,0.01,100.0,10.0,'// & TRIM(VTOS(ABS(NG)))//',1,'//TRIM(CPARAM2)//'_GRP'//TRIM(VTOS(ABS(NG)))//',1.0' ENDIF ENDIF ENDDO; ENDDO IF(I.EQ.1)THEN JU=UTL_GETUNIT(); OPEN(JU,FILE=TRIM(OUTPUTFOLDER)//'\PILOTPOINT_'//TRIM(CPARAM2)//'_L'//TRIM(VTOS(ILAY))//'.IPF',ACTION='WRITE',FORM='FORMATTED') WRITE(JU,*) N; WRITE(JU,*) 7; WRITE(JU,*) 'X'; WRITE(JU,*) 'Y'; WRITE(JU,*) 'PARAMETER' WRITE(JU,*) 'ZONE'; WRITE(JU,*) 'T'; WRITE(JU,*) 'B'; WRITE(JU,*) 'IACT'; WRITE(JU,*) '0,TXT' ELSE CLOSE(JU) ENDIF ENDDO; ENDDO ENDIF !## add ipf files IF(IAQUIFER.EQ.1)N=NLAY; IF(IAQUITARD.EQ.1)N=N+NLAY-1 WRITE(KU,'(I10)') N IF(IAQUIFER.EQ.1)THEN DO ILAY=1,NLAY; WRITE(KU,'(A)') TRIM(OUTPUTFOLDER)//'\PILOTPOINT_'//TRIM(CPARAM1)//'_L'//TRIM(VTOS(ILAY))//'.IPF'; ENDDO ENDIF IF(IAQUITARD.EQ.1)THEN DO ILAY=1,NLAY-1; WRITE(KU,'(A)') TRIM(OUTPUTFOLDER)//'\PILOTPOINT_'//TRIM(CPARAM2)//'_L'//TRIM(VTOS(ILAY))//'.IPF'; ENDDO ENDIF CLOSE(KU) END SUBROUTINE IMODBATH_CREATEPILOTPOINTS !###====================================================================== SUBROUTINE IMODBATCH_MF6NETWORKS() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: GENFNAME,OUTFOLDER INTEGER :: N,FORCECRD IF(.NOT.UTL_READINITFILE('GENFNAME',LINE,IU,0))RETURN READ(LINE,*) GENFNAME; WRITE(*,'(A)') 'GENFNAME='//TRIM(GENFNAME) IF(.NOT.UTL_READINITFILE('OUTFOLDER',LINE,IU,0))RETURN READ(LINE,*) OUTFOLDER; WRITE(*,'(A)') 'OUTFOLDER='//TRIM(OUTFOLDER) FORCECRD=0; IF(UTL_READINITFILE('FORCECRD',LINE,IU,1))THEN READ(LINE,*) FORCECRD; WRITE(*,'(A)') 'FORCECRD='//TRIM(VTOS(FORCECRD)) ENDIF IF(PMANAGER_GENERATEMFNETWORKS(GENFNAME,OUTFOLDER,N,1,0,FORCECRD))THEN WRITE(*,'(1X,A,I10)') 'Number of submodels is ',N ENDIF END SUBROUTINE IMODBATCH_MF6NETWORKS !###====================================================================== SUBROUTINE IMODBATCH_MSPNETRCH() !###====================================================================== USE MOD_MSPINSPECTOR_PAR, ONLY : SOURCEDIR,RESDIR,MSPRCH_FYR,MSPRCH_TYR,STOAVG,HEDDIR,MSPDIR,CONVMM USE IMODVAR, ONLY : DP_KIND,SP_KIND IMPLICIT NONE INTEGER :: SY,EY,SCOPT TYPE(IDFOBJ) :: IDF !## read location info SOURCEDIR=''; HEDDIR=''; MSPDIR='' IF(UTL_READINITFILE('SOURCEDIR',LINE,IU,1))THEN READ(LINE,*) SOURCEDIR; WRITE(*,'(A)') 'SOURCEDIR='//TRIM(SOURCEDIR) ELSE IF(.NOT.UTL_READINITFILE('HEDDIR',LINE,IU,0))RETURN READ(LINE,*) HEDDIR; WRITE(*,'(A)') 'HEDDIR='//TRIM(HEDDIR) IF(.NOT.UTL_READINITFILE('MSPDIR',LINE,IU,0))RETURN READ(LINE,*) MSPDIR; WRITE(*,'(A)') 'MSPDIR='//TRIM(MSPDIR) ENDIF !## - reading Optional input - RESDIR='' IF(UTL_READINITFILE('RESULTDIR',LINE,IU,1))THEN READ(LINE,*) RESDIR; WRITE(*,'(A)') 'RESULTDIR='//TRIM(RESDIR) ELSE RESDIR=TRIM(SOURCEDIR)//'\METASWAP\MSPNETRCH' ENDIF CALL IDFNULLIFY(IDF) IF(UTL_READINITFILE('WINDOW',LINE,IU,1))THEN READ(LINE,*) IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX WRITE(*,'(A,4F15.3)') 'WINDOW=',IDF%XMIN,IDF%YMIN,IDF%XMAX,IDF%YMAX IF(.NOT.UTL_READINITFILE('CELLSIZE',LINE,IU,1))RETURN READ(LINE,*) IDF%DX; IDF%DY=IDF%DX; WRITE(*,'(A,F15.3)') 'CELLSIZE=',IDF%DX IDF%NODATA=HUGE(1.0); IDF%ITYPE=4 CALL UTL_IDFSNAPTOGRID_LLC(IDF%XMIN,IDF%XMAX,IDF%YMIN,IDF%YMAX,IDF%DX,IDF%DY,IDF%NCOL,IDF%NROW,LLC=.TRUE.) IF(.NOT.IDFALLOCATEX(IDF))STOP; IDF%X=1.0D0; IDF%FNAME=TRIM(RESDIR)//'\OUTPUT_TEMPLATE.IDF' IF(.NOT.IDFWRITE(IDF,IDF%FNAME,1))STOP ENDIF SCOPT=0 ! Option to choose methode of calculating STORAGE COEFICIENT is disabled !## read start date MSPRCH_FYR=00000000 ; MSPRCH_TYR=99991231 IF(UTL_READINITFILE('SDATE',LINE,IU,1))THEN READ(LINE,*) MSPRCH_FYR !; MSPRCH_FYR=UTL_COMPLETEDATE(MSPRCH_FYR) WRITE(*,'(A,I16)') 'SDATE=',MSPRCH_FYR LINE=ADJUSTL(LINE); READ(LINE,'(I4)') SY !## read end date IF(.NOT.UTL_READINITFILE('EDATE',LINE,IU,0))RETURN READ(LINE,*) MSPRCH_TYR !; MSPRCH_TYR=UTL_COMPLETEDATE(MSPRCH_TYR) WRITE(*,'(A,I16)') 'EDATE=',MSPRCH_TYR SCOPT=1 LINE=ADJUSTL(LINE); READ(LINE,'(I4)') EY ELSE WRITE(*,'(/1A/)') 'COMPUTING NET RECHARGE FOR ALL TIMESTEPS' ENDIF !## read Storage coefficient STOAVG='' IF(UTL_READINITFILE('STOAVG',LINE,IU,1))THEN READ(LINE,*) STOAVG; WRITE(*,'(A)') 'STOAVG='//TRIM(STOAVG) ELSE IF(SCOPT.EQ.0) WRITE(*,'(A)') 'COMPUTING AVERAGE STORAGE COEFFICIENT FOR THE MODELED PERIODE' IF(SCOPT.EQ.1) WRITE(*,'(A)') 'COMPUTING AVERAGE STORAGE COEFFICIENT FOR THE PERIODE SDATE-EDATE' ENDIF CONVMM=0 IF(UTL_READINITFILE('CONVMM',LINE,IU,1))THEN READ(LINE,*) CONVMM; WRITE(*,'(A)') 'CONVMM='//TRIM(VTOS(CONVMM)) ENDIF IF(.NOT.MSPNETRCHCOMPUTE(IDF))THEN; WRITE(*,'(/A/)') 'NOT Successfully completed MSPNETRCH. Check the echo. ' ELSE WRITE(*,'(/A)') 'Successfully completed MSPNETRCH, results written in:' WRITE(*,'(A/)') TRIM(RESDIR) ENDIF END SUBROUTINE IMODBATCH_MSPNETRCH !###====================================================================== SUBROUTINE IMODBATCH_IPFEVALUATE() !###====================================================================== IMPLICIT NONE CHARACTER(LEN=256) :: INIPF,OUTIPF INTEGER :: NLAY INTEGER,DIMENSION(5) :: ICOLS !## perform ipf sample, return number of IF(.NOT.IMODBATCH_IPFSAMPLE_MAIN(INIPF,ICOLS,NLAY))RETURN IF(.NOT.UTL_READINITFILE('IPFLAYERS',LINE,IU,0))RETURN READ(LINE,*) OUTIPF; WRITE(*,'(A)') 'IPFLAYERS='//TRIM(OUTIPF) CALL IPFEVALUATE(INIPF,OUTIPF,NLAY,ICOLS) END SUBROUTINE IMODBATCH_IPFEVALUATE END MODULE MOD_BATCH