!! Copyright (C) Stichting Deltares, 2005-2017. !! !! This file is part of iMOD. !! !! This program is free software: you can redistribute it and/or modify !! it under the terms of the GNU General Public License as published by !! the Free Software Foundation, either version 3 of the License, or !! (at your option) any later version. !! !! This program is distributed in the hope that it will be useful, !! but WITHOUT ANY WARRANTY; without even the implied warranty of !! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the !! GNU General Public License for more details. !! !! You should have received a copy of the GNU General Public License !! along with this program. If not, see . !! !! Contact: imod.support@deltares.nl !! Stichting Deltares !! P.O. Box 177 !! 2600 MH Delft, The Netherlands. !! MODULE MOD_ISG_ADJ USE WINTERACTER USE RESOURCE USE MOD_POLYGON_PAR USE MOD_POLYGON, ONLY : POLYGON1MAIN USE MOD_ISG_PAR USE MOD_PREF_PAR, ONLY : PREFVAL USE MOD_UTL, ONLY : ITOS,RTOS,UTL_WSELECTFILE,UTL_GETUNIT,UTL_CAP,EQUALNAMES,UTL_INSIDEPOLYGON USE MOD_POLYGON_UTL, ONLY : POLYGON1FIELDS,POLYGON1SAVELOADSHAPE USE MOD_OSD, ONLY : OSD_OPEN USE MOD_IDF, ONLY : IDFREAD USE MOD_ISG_UTL CONTAINS !###====================================================================== SUBROUTINE ISGADJUSTMAIN(ITYPE,MESSAGE) !###====================================================================== IMPLICIT NONE TYPE(WIN_MESSAGE),INTENT(IN) :: MESSAGE INTEGER,INTENT(IN) :: ITYPE CHARACTER(LEN=256) :: FNAME LOGICAL :: LEX CALL WDIALOGSELECT(MESSAGE%WIN) SELECT CASE (ITYPE) CASE(FIELDCHANGED) SELECT CASE (MESSAGE%WIN) CASE (ID_DISGEDITTAB2) SELECT CASE (MESSAGE%VALUE2) CASE (IDF_MENU1) CALL POLYGON1FIELDS(ID_DISGEDITTAB2) CALL ISGADJUSTFIELDS() END SELECT CASE (ID_DISGEDITTAB3) SELECT CASE (MESSAGE%VALUE2) CASE (IDF_CHECK1,IDF_CHECK2,IDF_CHECK3,IDF_CHECK4,IDF_RADIO1,IDF_RADIO2) CALL ISGADJUSTFIELDS() END SELECT CASE (ID_DISGEDITTAB4) SELECT CASE (MESSAGE%VALUE2) CASE(IDF_RADIO1,IDF_RADIO2,IDF_CHECK1,IDF_CHECK2,IDF_CHECK3,IDF_CHECK4, & IDF_MENU1, IDF_MENU2, IDF_MENU3, IDF_MENU4) CALL ISGADJUSTFIELDSTAB(ID_DISGEDITTAB4,4) END SELECT CASE (ID_DISGEDITTAB5) SELECT CASE (MESSAGE%VALUE2) CASE(IDF_RADIO1,IDF_RADIO2,IDF_CHECK1,IDF_CHECK2, & IDF_MENU1, IDF_MENU2) CALL ISGADJUSTFIELDSTAB(ID_DISGEDITTAB5,2) END SELECT CASE (ID_DISGEDITTAB6) SELECT CASE (MESSAGE%VALUE2) CASE(IDF_RADIO1,IDF_RADIO2,IDF_CHECK1,IDF_CHECK2,IDF_CHECK3, & IDF_MENU1, IDF_MENU2, IDF_MENU3) CALL ISGADJUSTFIELDSTAB(ID_DISGEDITTAB6,3) END SELECT CASE (ID_DISGEDITTAB7) SELECT CASE (MESSAGE%VALUE2) CASE(IDF_RADIO1,IDF_RADIO2,IDF_CHECK1,IDF_CHECK2,IDF_CHECK3,IDF_CHECK4, & IDF_MENU1, IDF_MENU2, IDF_MENU3, IDF_MENU4) CALL ISGADJUSTFIELDSTAB(ID_DISGEDITTAB7,4) END SELECT END SELECT CASE(PUSHBUTTON) SELECT CASE (MESSAGE%WIN) CASE (ID_DISGEDITTAB2) IACTSHAPES=(/3,3,1,3,3,3/) CALL POLYGON1MAIN(ITYPE,MESSAGE) ISGSHAPES=SHPNO CALL ISGADJUSTFIELDS() CASE (ID_DISGEDITTAB3) SELECT CASE (MESSAGE%VALUE1) CASE (IDOK) CALL ISGADJUST(IDOK,TRIM(PREFVAL(1))//'\TMP\runadjustisg.ses') CASE (ID_LOAD,ID_SAVEAS) CALL ISGADJUST(MESSAGE%VALUE1,'') END SELECT CASE (ID_DISGEDITTAB4,ID_DISGEDITTAB5,ID_DISGEDITTAB6,ID_DISGEDITTAB7) SELECT CASE (MESSAGE%VALUE1) CASE (ID_LOAD) IF(MESSAGE%WIN.EQ.ID_DISGEDITTAB4)LEX=UTL_WSELECTFILE('Comma Seperated File (*.csv)|*.csv|',& LOADDIALOG+MUSTEXIST+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,& 'Load Comma Seperated File (*.csv)') IF(MESSAGE%WIN.EQ.ID_DISGEDITTAB5)LEX=UTL_WSELECTFILE('Comma Seperated File (*.csv)|*.csv|',& LOADDIALOG+MUSTEXIST+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,& 'Load Comma Seperated File (*.csv)') IF(MESSAGE%WIN.EQ.ID_DISGEDITTAB6)LEX=UTL_WSELECTFILE('iMOD Cross-Section File (*.ccf)|*.ccf|',& LOADDIALOG+MUSTEXIST+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,& 'Load iMOD Cross-Section (*.ccf)') IF(MESSAGE%WIN.EQ.ID_DISGEDITTAB7)LEX=UTL_WSELECTFILE('Comma Seperated File (*.csv)|*.csv|',& LOADDIALOG+MUSTEXIST+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,& 'Load Comma Seperated Qh (*.csv)') IF(LEX)CALL WDIALOGPUTSTRING(IDF_STRING,TRIM(ADJUSTL(FNAME))) CASE (IDF_LOAD1,IDF_LOAD2,IDF_LOAD3,IDF_LOAD4) IF(UTL_WSELECTFILE('iMOD IDF (*.idf)|*.idf|',& LOADDIALOG+MUSTEXIST+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,& 'Load iMOD IDF (*.idf)'))THEN IF(MESSAGE%VALUE1.EQ.IDF_LOAD1)CALL WDIALOGPUTSTRING(IDF_STRING1,TRIM(ADJUSTL(FNAME))) IF(MESSAGE%VALUE1.EQ.IDF_LOAD2)CALL WDIALOGPUTSTRING(IDF_STRING2,TRIM(ADJUSTL(FNAME))) IF(MESSAGE%VALUE1.EQ.IDF_LOAD3)CALL WDIALOGPUTSTRING(IDF_STRING3,TRIM(ADJUSTL(FNAME))) IF(MESSAGE%VALUE1.EQ.IDF_LOAD4)CALL WDIALOGPUTSTRING(IDF_STRING4,TRIM(ADJUSTL(FNAME))) ENDIF END SELECT END SELECT END SELECT END SUBROUTINE ISGADJUSTMAIN !###====================================================================== SUBROUTINE ISGADJUSTFIELDS() !###====================================================================== IMPLICIT NONE INTEGER :: I,K INTEGER,DIMENSION(4) :: IOPT CALL WDIALOGSELECT(ID_DISGEDITTAB3) K=ISGADJUSTGETK() I=MIN(1,K) CALL WDIALOGSELECT(ID_DISGEDIT) CALL WDIALOGTABSTATE(IDF_TAB,ID_DISGEDITTAB3,I) IF(I.EQ.0)THEN CALL WDIALOGTABSTATE(IDF_TAB,ID_DISGEDITTAB4,I) CALL WDIALOGTABSTATE(IDF_TAB,ID_DISGEDITTAB5,I) CALL WDIALOGTABSTATE(IDF_TAB,ID_DISGEDITTAB6,I) CALL WDIALOGTABSTATE(IDF_TAB,ID_DISGEDITTAB7,I) IOPT=0 ELSEIF(I.EQ.1)THEN CALL WDIALOGSELECT(ID_DISGEDITTAB3) !## selected option [delete]/[adjust] CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,I) IF(I.EQ.1)THEN IOPT=0 ELSE CALL WDIALOGGETCHECKBOX(IDF_CHECK1,IOPT(1)) CALL WDIALOGGETCHECKBOX(IDF_CHECK2,IOPT(2)) CALL WDIALOGGETCHECKBOX(IDF_CHECK3,IOPT(3)) CALL WDIALOGGETCHECKBOX(IDF_CHECK4,IOPT(4)) ENDIF CALL WDIALOGSELECT(ID_DISGEDIT) CALL WDIALOGTABSTATE(IDF_TAB,ID_DISGEDITTAB4,IOPT(1)) CALL WDIALOGTABSTATE(IDF_TAB,ID_DISGEDITTAB5,IOPT(2)) CALL WDIALOGTABSTATE(IDF_TAB,ID_DISGEDITTAB6,IOPT(3)) CALL WDIALOGTABSTATE(IDF_TAB,ID_DISGEDITTAB7,IOPT(4)) IF(I.EQ.1)IOPT=1 ENDIF CALL WDIALOGSELECT(ID_DISGEDITTAB3) CALL WDIALOGFIELDSTATE(IDOK,MIN(1,SUM(IOPT))) END SUBROUTINE ISGADJUSTFIELDS !###====================================================================== INTEGER FUNCTION ISGADJUSTGETK() !###====================================================================== IMPLICIT NONE INTEGER :: J,K K=0 !k:1=segments;2=polygons !## selected segment DO J=1,NISG IF(ISG(J)%ILIST.EQ.1)EXIT END DO IF(J.LE.NISG)K=1 !## added polygon IF(ISGSHAPES.GT.0)THEN !## how many polygons selected??? CALL WDIALOGSELECT(ID_DISGEDITTAB2) CALL WDIALOGGETMENU(IDF_MENU1,SHPIACT) IF(SUM(SHPIACT(1:ISGSHAPES)).GT.0)THEN K=2 CALL WDIALOGSELECT(ID_DISGEDITTAB3) CALL WDIALOGPUTSTRING(IDOK,'Apply inside selected Polygon') ENDIF ENDIF CALL WDIALOGSELECT(ID_DISGEDITTAB3) IF(K.EQ.1)CALL WDIALOGPUTSTRING(IDOK,'Apply for selected Segments') ISGADJUSTGETK=K END FUNCTION ISGADJUSTGETK !###====================================================================== SUBROUTINE ISGADJUSTFIELDSTAB(ID,N) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: N INTEGER,INTENT(IN) :: ID INTEGER :: I,J,K INTEGER,DIMENSION(24) :: IDS DATA IDS/IDF_CHECK1,IDF_CHECK2,IDF_CHECK3,IDF_CHECK4,& IDF_LOAD1,IDF_LOAD2,IDF_LOAD3,IDF_LOAD4, & IDF_STRING1,IDF_STRING2,IDF_STRING3,IDF_STRING4,& IDF_MENU1,IDF_MENU2,IDF_MENU3,IDF_MENU4, & IDF_REAL1,IDF_REAL2,IDF_REAL3,IDF_REAL4, & IDF_MENU5,IDF_MENU6,IDF_MENU7,IDF_MENU8/ CALL WDIALOGSELECT(ID) CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,I) I=ABS(I-2) CALL WDIALOGFIELDSTATE(ID_LOAD,I) CALL WDIALOGFIELDSTATE(IDF_STRING,I) J=ABS(I-1) DO I=1,N K=J IF(J.EQ.1)CALL WDIALOGGETCHECKBOX(IDS(I),K) !check CALL WDIALOGFIELDSTATE(IDS(I),J) CALL WDIALOGFIELDSTATE(IDS(12+I),K) !menu CALL WDIALOGFIELDSTATE(IDS(16+I),K) !real CALL WDIALOGFIELDSTATE(IDS(20+I),K) !menu IF(K.EQ.1)THEN CALL WDIALOGGETMENU(IDS(12+I),K) IF(K.NE.6)K=0 K=MIN(1,K) ENDIF CALL WDIALOGFIELDSTATE(IDS(4+I),K) !load CALL WDIALOGFIELDSTATE(IDS(8+I),K) !string IF(K.EQ.1)THEN K=ABS(K-1) CALL WDIALOGFIELDSTATE(IDS(16+I),K) !real ENDIF ENDDO END SUBROUTINE ISGADJUSTFIELDSTAB !###====================================================================== SUBROUTINE ISGADJUSTREADFIELDS(ID,N,IU,IACT,ITYPE,TEXT,WC) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: N,IU,IACT,ITYPE INTEGER,INTENT(IN) :: ID INTEGER :: I,J,K CHARACTER(LEN=*),INTENT(IN) :: TEXT,WC INTEGER,DIMENSION(24) :: IDS CHARACTER(LEN=52) :: ATTRIB CHARACTER(LEN=3),DIMENSION(6) :: COPERATOR CHARACTER(LEN=256) :: FNAME REAL :: X DATA COPERATOR/'= ','+ ','- ','/ ','* ','IDF'/ DATA IDS/IDF_CHECK1,IDF_CHECK2,IDF_CHECK3,IDF_CHECK4,& IDF_LOAD1,IDF_LOAD2,IDF_LOAD3,IDF_LOAD4, & IDF_STRING1,IDF_STRING2,IDF_STRING3,IDF_STRING4,& IDF_MENU1,IDF_MENU2,IDF_MENU3,IDF_MENU4, & IDF_REAL1,IDF_REAL2,IDF_REAL3,IDF_REAL4, & IDF_MENU5,IDF_MENU6,IDF_MENU7,IDF_MENU8/ FNAME=TRIM(ITOS(IACT))//',"'//TRIM(WC)//'" '//TRIM(TEXT) WRITE(IU,'(A)') TRIM(FNAME) IF(ITYPE.EQ.1)RETURN IF(IACT.EQ.0) RETURN CALL WDIALOGSELECT(ID) CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,I) IF(I.EQ.1)THEN FNAME=' '//TRIM(ITOS(I))//' Add from file' WRITE(IU,'(A)') TRIM(FNAME) CALL WDIALOGGETSTRING(IDF_STRING,FNAME) WRITE(IU,'(A)') ' "'//TRIM(FNAME)//'" Filename' ELSE FNAME=TRIM(ITOS(I))//' Specify each attributes' WRITE(IU,'(A)') ' '//TRIM(FNAME) DO I=1,N CALL WDIALOGGETCHECKBOX(IDS(I),J) !check CALL WDIALOGGETMENU(IDS(I+20),K,ATTRIB) FNAME=TRIM(ITOS(J))//','//TRIM(ITOS(K))//' "'//TRIM(ATTRIB)//'"' WRITE(IU,'(A)') ' '//TRIM(FNAME) IF(J.EQ.1)THEN CALL WDIALOGGETMENU(IDS(12+I),K) IF(K.EQ.6)THEN CALL WDIALOGGETSTRING(IDS(8+I),FNAME) !string FNAME=TRIM(ITOS(K))//',"'//TRIM(COPERATOR(K))//'","'//TRIM(FNAME)//'"' WRITE(IU,'(A)') ' '//TRIM(FNAME) ELSE CALL WDIALOGGETREAL(IDS(16+I),X) !real FNAME=TRIM(ITOS(K))//',"'//TRIM(COPERATOR(K))//'",'//TRIM(RTOS(X,'F',2)) WRITE(IU,'(A)') ' '//TRIM(FNAME) ENDIF ENDIF ENDDO ENDIF END SUBROUTINE ISGADJUSTREADFIELDS !###====================================================================== SUBROUTINE ISGADJUSTPUTFIELDS(ID,N,IU) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: N,IU INTEGER,INTENT(IN) :: ID INTEGER :: I,J,K INTEGER,DIMENSION(24) :: IDS CHARACTER(LEN=3) :: COPERATOR CHARACTER(LEN=256) :: FNAME REAL :: X DATA IDS/IDF_CHECK1,IDF_CHECK2,IDF_CHECK3,IDF_CHECK4,& IDF_LOAD1,IDF_LOAD2,IDF_LOAD3,IDF_LOAD4, & IDF_STRING1,IDF_STRING2,IDF_STRING3,IDF_STRING4,& IDF_MENU1,IDF_MENU2,IDF_MENU3,IDF_MENU4, & IDF_REAL1,IDF_REAL2,IDF_REAL3,IDF_REAL4, & IDF_MENU5,IDF_MENU6,IDF_MENU7,IDF_MENU8/ CALL WDIALOGSELECT(ID) READ(IU,*) I IF(I.EQ.1)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO1) IF(I.EQ.2)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO2) IF(I.EQ.1)THEN READ(IU,*) FNAME CALL WDIALOGPUTSTRING(IDF_STRING,FNAME) ELSE DO I=1,N READ(IU,*) J,K CALL WDIALOGPUTCHECKBOX(IDS(I),J) !check CALL WDIALOGPUTOPTION(IDS(20+I),K) IF(J.EQ.1)THEN READ(IU,*) K CALL WDIALOGPUTOPTION(IDS(12+I),K) BACKSPACE(IU) IF(K.EQ.6)THEN READ(IU,*) K,COPERATOR,FNAME CALL WDIALOGPUTSTRING(IDS(8+I),FNAME) !string ELSE READ(IU,*) K,COPERATOR,X CALL WDIALOGPUTREAL(IDS(16+I),X) !real ENDIF ENDIF ENDDO ENDIF END SUBROUTINE ISGADJUSTPUTFIELDS !###====================================================================== SUBROUTINE ISGADJUST(ID,FNAME) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ID CHARACTER(LEN=*),INTENT(IN) :: FNAME CHARACTER(LEN=256) :: SESFNAME,GENFNAME INTEGER :: IU,IOS,K,I,J,N,ITYPE,IACT CHARACTER(LEN=256) :: LINE,ISGFILE CHARACTER(LEN=50) :: WC IF(ID.EQ.ID_SAVEAS.OR.ID.EQ.IDOK)THEN IF(FNAME.EQ.'')THEN IF(.NOT.UTL_WSELECTFILE('iMOD Segment Edit Settings (*.ses)|*.ses|',& SAVEDIALOG+PROMPTON+DIRCHANGE+APPENDEXT,SESFNAME,& 'Save iMOD Segment Edit Settings (*.ses)'))RETURN ELSE SESFNAME=FNAME ENDIF IU=UTL_GETUNIT() CALL OSD_OPEN(IU,FILE=SESFNAME,STATUS='UNKNOWN',IOSTAT=IOS) IF(IOS.NE.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMOD cannot create file: '//CHAR(13)//TRIM(SESFNAME),'Error') RETURN ENDIF WRITE(IU,'(A)') '"'//TRIM(ISGFNAME)//'" ISG File' CALL WDIALOGSELECT(ID_DISGEDITTAB3) CALL WDIALOGGETCHECKBOX(IDF_CHECK5,K) LINE=TRIM(ITOS(K)) IF(K.EQ.0)WRITE(IU,'(A)') TRIM(LINE)//' Wild card is case-insensitive!' IF(K.EQ.1)WRITE(IU,'(A)') TRIM(LINE)//' Wild card is case-sensitive!' K=ISGADJUSTGETK() SELECT CASE (K) CASE (1) !## write selected segments CALL WDIALOGSELECT(ID_DISGEDITTAB1) CALL WDIALOGGETMENU(IDF_MENU1,ISG(1:NISG)%ILIST) LINE=TRIM(ITOS(K))//','//TRIM(ITOS(SUM(ISG(1:NISG)%ILIST)))//' Apply to selected segments' WRITE(IU,'(A)') TRIM(LINE) DO I=1,NISG IF(ISG(I)%ILIST.EQ.1)THEN LINE=TRIM(ITOS(I))//',"'//TRIM(ISG(I)%SNAME)//'"' WRITE(IU,'(A)') ' '//TRIM(LINE) ENDIF END DO CASE (2) LINE=TRIM(ITOS(K))//' Apply within selected polygons' WRITE(IU,'(A)') TRIM(LINE) !## write temporary gen-file GENFNAME=TRIM(PREFVAL(1))//'\TMP\isgadjust.gen' CALL POLYGON1SAVELOADSHAPE(ID_SAVESHAPE,ID_DISGEDITTAB2,GENFNAME) WRITE(IU,'(A)') ' "'//TRIM(GENFNAME)//'"' END SELECT CALL WDIALOGSELECT(ID_DISGEDITTAB3) CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,J) IF(J.EQ.1)THEN LINE=TRIM(ITOS(J))//' Removal' WRITE(IU,'(A)') TRIM(LINE) ELSEIF(J.EQ.2)THEN LINE=TRIM(ITOS(J))//' Adjustment' WRITE(IU,'(A)') TRIM(LINE) ENDIF CALL WDIALOGGETCHECKBOX(IDF_CHECK1,I) CALL WDIALOGGETSTRING(IDF_STRING1,WC) CALL ISGADJUSTREADFIELDS(ID_DISGEDITTAB4,4,IU,I,J,'Calculation Points',WC) CALL WDIALOGSELECT(ID_DISGEDITTAB3) CALL WDIALOGGETCHECKBOX(IDF_CHECK2,I) CALL WDIALOGGETSTRING(IDF_STRING2,WC) CALL ISGADJUSTREADFIELDS(ID_DISGEDITTAB5,2,IU,I,J,'Structures',WC) CALL WDIALOGSELECT(ID_DISGEDITTAB3) CALL WDIALOGGETCHECKBOX(IDF_CHECK3,I) CALL WDIALOGGETSTRING(IDF_STRING3,WC) CALL ISGADJUSTREADFIELDS(ID_DISGEDITTAB6,3,IU,I,J,'Cross-Sections',WC) CALL WDIALOGSELECT(ID_DISGEDITTAB3) CALL WDIALOGGETCHECKBOX(IDF_CHECK4,I) CALL WDIALOGGETSTRING(IDF_STRING4,WC) CALL ISGADJUSTREADFIELDS(ID_DISGEDITTAB7,4,IU,I,J,'Q-DW-relationships',WC) ELSEIF(ID.EQ.ID_LOAD)THEN IF(FNAME.EQ.'')THEN IF(.NOT.UTL_WSELECTFILE('iMOD Segment Edit Settings (*.ses)|*.ses|',& LOADDIALOG+MUSTEXIST+PROMPTON+DIRCHANGE+APPENDEXT,SESFNAME,& 'Load iMOD Segment Edit Settings (*.ses)'))RETURN ELSE SESFNAME=FNAME ENDIF IU=UTL_GETUNIT() CALL OSD_OPEN(IU,FILE=SESFNAME,STATUS='OLD',IOSTAT=IOS) IF(IOS.NE.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMOD cannot open file:'//CHAR(13)//TRIM(SESFNAME),'Error') RETURN ENDIF READ(IU,*) LINE IF(TRIM(LINE).NE.TRIM(ISGFNAME))THEN; CLOSE(IU); RETURN; ENDIF READ(IU,*) K CALL WDIALOGSELECT(ID_DISGEDITTAB3) CALL WDIALOGPUTCHECKBOX(IDF_CHECK5,K) READ(IU,*) K SELECT CASE (K) CASE (1) !## write selected segments CALL WDIALOGSELECT(ID_DISGEDITTAB1) BACKSPACE(IU) READ(IU,*) K,N ISG%ILIST=0 DO I=1,N READ(IU,*) J ISG(J)%ILIST=1 END DO CALL WDIALOGPUTOPTION(IDF_MENU1,ISG(1:NISG)%ILIST) CASE (2) READ(IU,*) GENFNAME !## write temporary gen-file CALL POLYGON1SAVELOADSHAPE(ID_LOADSHAPE,ID_DISGEDITTAB2,GENFNAME) ISGSHAPES=SHPNO END SELECT READ(IU,*) ITYPE CALL WDIALOGSELECT(ID_DISGEDITTAB3) IF(ITYPE.EQ.1)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO1) IF(ITYPE.EQ.1)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO2) READ(IU,*) IACT,WC CALL WDIALOGSELECT(ID_DISGEDITTAB3) CALL WDIALOGPUTCHECKBOX(IDF_CHECK1,IACT) CALL WDIALOGPUTSTRING(IDF_STRING1,WC) IF(IACT.EQ.1.AND.ITYPE.EQ.2)CALL ISGADJUSTPUTFIELDS(ID_DISGEDITTAB4,4,IU) READ(IU,*) IACT,WC CALL WDIALOGSELECT(ID_DISGEDITTAB3) CALL WDIALOGPUTCHECKBOX(IDF_CHECK2,IACT) CALL WDIALOGPUTSTRING(IDF_STRING2,WC) IF(IACT.EQ.1.AND.ITYPE.EQ.2)CALL ISGADJUSTPUTFIELDS(ID_DISGEDITTAB5,2,IU) READ(IU,*) IACT,WC CALL WDIALOGSELECT(ID_DISGEDITTAB3) CALL WDIALOGPUTCHECKBOX(IDF_CHECK3,IACT) CALL WDIALOGPUTSTRING(IDF_STRING3,WC) IF(IACT.EQ.1.AND.ITYPE.EQ.2)CALL ISGADJUSTPUTFIELDS(ID_DISGEDITTAB6,3,IU) READ(IU,*) IACT,WC CALL WDIALOGSELECT(ID_DISGEDITTAB3) CALL WDIALOGPUTCHECKBOX(IDF_CHECK4,IACT) CALL WDIALOGPUTSTRING(IDF_STRING4,WC) IF(IACT.EQ.1.AND.ITYPE.EQ.2)CALL ISGADJUSTPUTFIELDS(ID_DISGEDITTAB7,4,IU) CALL ISGADJUSTFIELDS() ENDIF CLOSE(IU) IF(ID.EQ.IDOK)THEN CALL WMESSAGEBOX(YESNO,COMMONNO,QUESTIONICON,'Do you want to continue ? Action that will follow can NOT be undone!','Question') IF(WINFODIALOG(4).EQ.1)THEN IF(ISGADJUSTAPPLY(SESFNAME,TRIM(PREFVAL(1))//'\TMP\log_ses.txt',0))THEN ! ISGFILE=ISGFNAME ! CALL ISGSAVE(ISGFILE,1) !- saving ONLY *.ISG, *.isp, *.isd ENDIF CALL IDFPLOTFAST(1) ENDIF ENDIF END SUBROUTINE ISGADJUST !###=============================================================================== LOGICAL FUNCTION ISGADJUSTAPPLY(SESFNAME,LOGFNAME,IBATCH) !###=============================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: IBATCH CHARACTER(LEN=*),INTENT(IN) :: SESFNAME,LOGFNAME CHARACTER(LEN=256) :: GENFNAME,ISGFILE CHARACTER(LEN=10) :: TEXT INTEGER :: NSEG,IPOLSEG,I,J,ISELADJ,JU,IOS,ICASE,NPOL,IPNT,NPNT,ISEG,MXXY,IWIN,IPOL INTEGER,DIMENSION(4) :: NATTRIB REAL,DIMENSION(2) :: XMIN,XMAX,YMIN,YMAX REAL :: XC,YC LOGICAL :: LEX DATA NATTRIB/4,2,3,4/ ISGADJUSTAPPLY=.FALSE. CALL ISGADJUSTABORT() JU=UTL_GETUNIT() CALL OSD_OPEN(JU,FILE=SESFNAME,STATUS='OLD') !## skip isgname IF(IBATCH.EQ.0)THEN READ(JU,*) !TEXT!,ISGFNAME !## read isgname ELSEIF(IBATCH.EQ.1)THEN READ(JU,*) ISGFILE IF(ISGREAD((/ISGFILE/),IBATCH))THEN; ENDIF ENDIF READ(JU,*) ICASE READ(JU,*) IPOLSEG,GENFNAME IF(IPOLSEG.EQ.1)THEN READ(GENFNAME,*) NSEG ALLOCATE(ISEGMENTS(NSEG)) DO I=1,NSEG; READ(JU,*) ISEGMENTS(I); END DO ELSEIF(IPOLSEG.EQ.2)THEN READ(JU,*) GENFNAME ENDIF !## 1=remove/2=adjust READ(JU,*) ISELADJ ALLOCATE(ISGADJ(4)) DO I=1,4 READ(JU,*) ISGADJ(I)%IACT,ISGADJ(I)%WC IF(ISGADJ(I)%IACT.EQ.1.AND.ISELADJ.EQ.2)THEN READ(JU,*) ISGADJ(I)%ISOURCE !## read from file IF(ISGADJ(I)%ISOURCE.EQ.1)THEN READ(JU,*) ISGADJ(I)%FNAME INQUIRE(FILE=ISGADJ(I)%FNAME,EXIST=LEX) IF(.NOT.LEX)THEN IF(IBATCH.EQ.0)CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot open File: '//TRIM(ISGADJ(I)%FNAME),'Error') IF(IBATCH.EQ.1)WRITE(*,*) 'Cannot open File: '//TRIM(ISGADJ(I)%FNAME) CLOSE(JU) CALL ISGADJUSTABORT() RETURN ENDIF !## read from menu fields ELSEIF(ISGADJ(I)%ISOURCE.EQ.2)THEN DO J=1,NATTRIB(I) READ(JU,*) ISGADJ(I)%IACTATTRIB(J),ISGADJ(I)%IATTRIB(J),ISGADJ(I)%ATTRIB(J) !## activated IF(ISGADJ(I)%IACTATTRIB(J).EQ.1)THEN READ(JU,*) ISGADJ(I)%IOP(J),TEXT,ISGADJ(I)%IDFNAME(J) IF(ISGADJ(I)%IOP(J).NE.6)THEN READ(ISGADJ(I)%IDFNAME(J),*) ISGADJ(I)%VALUE(J) ELSE !## open idf file IF(.NOT.IDFREAD(ISGADJ(I)%IDF(J),ISGADJ(I)%IDFNAME(J),0))THEN IF(IBATCH.EQ.0)CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot open IDF '//TRIM(ISGADJ(I)%IDFNAME(J)),'Error') IF(IBATCH.EQ.1)WRITE(*,*) 'Cannot open IDF '//TRIM(ISGADJ(I)%IDFNAME(J)) CLOSE(JU) CALL ISGADJUSTABORT() RETURN ENDIF ENDIF ENDIF END DO ENDIF ENDIF END DO CLOSE(JU) IULOG=UTL_GETUNIT() CALL OSD_OPEN(IULOG,FILE=LOGFNAME,STATUS='UNKNOWN') WRITE(IULOG,'(A)') 'Information about ISG-EDIT' WRITE(IULOG,'(A)') !## read external files to be asigned to selections DO J=1,4 IF(ISGADJ(J)%IACT.EQ.1.AND.ISGADJ(J)%ISOURCE.EQ.1)CALL ISGADJUSTREADFROMFILE(J) END DO !## proces segments IF(IPOLSEG.EQ.1)THEN DO I=1,NSEG IF(IBATCH.EQ.0)CALL WINDOWOUTSTATUSBAR(4,'Busy with segment '//TRIM(ISG(ISEGMENTS(I))%SNAME)//'...') IF(IBATCH.EQ.1)WRITE(*,*) 'Busy with segment '//TRIM(ISG(ISEGMENTS(I))%SNAME)//'...' DO J=1,4 IF(ISGADJ(J)%IACT.EQ.1)CALL ISGADJUSTAPPLYSELECTION(ISEGMENTS(I),J,ISELADJ,ICASE,NATTRIB(J),IPOLSEG,IBATCH,0) END DO END DO !## proces polygons ELSEIF(IPOLSEG.EQ.2)THEN JU=UTL_GETUNIT() CALL OSD_OPEN(JU,FILE=GENFNAME,STATUS='OLD',ACTION='READ,DENYWRITE') !## test file to determine array-dimensions NPOL=0 MXXY=0 DO READ(JU,*,IOSTAT=IOS) I IF(IOS.NE.0)EXIT NPOL=NPOL+1 NXY =0 DO NXY=NXY+1 READ(JU,*,IOSTAT=IOS) XC,YC IF(IOS.NE.0)EXIT END DO MXXY=MAX(NXY-1,MXXY) ENDDO REWIND(JU) ALLOCATE(XPOL(MXXY),YPOL(MXXY)) DO IPOL=1,NPOL READ(JU,*) NXY=0 DO READ(JU,*,IOSTAT=IOS) XC,YC IF(IOS.NE.0)EXIT NXY =NXY+1 XPOL(NXY)=XC YPOL(NXY)=YC ENDDO !## extension of polygon XMIN(1)=MINVAL(XPOL(1:NXY)) XMAX(1)=MAXVAL(XPOL(1:NXY)) YMIN(1)=MINVAL(YPOL(1:NXY)) YMAX(1)=MAXVAL(YPOL(1:NXY)) !## determine for each segment whether one-or-more points are within extension of polygon DO ISEG=1,NISG IPNT=ISG(ISEG)%ISEG NPNT=IPNT+ISG(ISEG)%NSEG-1 !## extension of current segment XMIN(2)=MINVAL(ISP(IPNT:NPNT)%X) XMAX(2)=MAXVAL(ISP(IPNT:NPNT)%X) YMIN(2)=MINVAL(ISP(IPNT:NPNT)%Y) YMAX(2)=MAXVAL(ISP(IPNT:NPNT)%Y) IF(XMAX(1).GT.XMIN(2).AND. &!OR. & XMIN(1).LT.XMAX(2).AND. &!OR. & YMAX(1).GT.YMIN(2).AND. &!OR. & YMIN(1).LT.YMAX(2))THEN !## apply operations within each polygon DO J=1,4 IF(ISGADJ(J)%IACT.EQ.1)CALL ISGADJUSTAPPLYSELECTION(ISEG,J,ISELADJ,ICASE,NATTRIB(J),IPOLSEG,IBATCH,IPOL) END DO ENDIF END DO ENDDO CLOSE(JU) ENDIF CALL ISGADJUSTABORT() ISGADJUSTAPPLY=.TRUE. CLOSE(IULOG) IF(IBATCH.EQ.0)THEN CALL WINDOWOPENCHILD(IWIN,FLAGS=SYSMENUON,WIDTH=1000,HEIGHT=500) CALL WINDOWSELECT(IWIN) IULOG=UTL_GETUNIT() CALL OSD_OPEN(IULOG,FILE=LOGFNAME,STATUS='OLD',IOSTAT=I) IF(I.NE.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMOD cannot view the created file : '//CHAR(13)// & TRIM(LOGFNAME)//'.'//CHAR(13)//'It is probably opened already in another application','Error') ELSE CLOSE(IULOG) CALL WEDITFILE(LOGFNAME,ITYPE=MODAL,IDMENU=0, & IFLAGS=NOTOOLBAR+VIEWONLY+WORDWRAP+NOFILENEWOPEN+NOFILESAVEAS,& IFONT=4,ISIZE=10) ENDIF ELSE WRITE(*,*) WRITE(*,*) 'Successfully completed ISG editing, results written in:' WRITE(*,*) TRIM(LOGFNAME) ENDIF END FUNCTION ISGADJUSTAPPLY !###=============================================================================== SUBROUTINE ISGADJUSTABORT() !###=============================================================================== IMPLICIT NONE IF(ALLOCATED(ISEGMENTS))DEALLOCATE(ISEGMENTS) IF(ALLOCATED(DUMDATISD))DEALLOCATE(DUMDATISD) IF(ALLOCATED(DUMDATIST))DEALLOCATE(DUMDATIST) IF(ALLOCATED(DUMDATISC))DEALLOCATE(DUMDATISC) IF(ALLOCATED(DUMDATISQ))DEALLOCATE(DUMDATISQ) IF(ALLOCATED(ISGEDITISD))DEALLOCATE(ISGEDITISD) IF(ALLOCATED(ISGEDITIST))DEALLOCATE(ISGEDITIST) IF(ALLOCATED(ISGEDITISC))DEALLOCATE(ISGEDITISC) IF(ALLOCATED(ISGEDITISQ))DEALLOCATE(ISGEDITISQ) IF(ALLOCATED(ISGADJ))DEALLOCATE(ISGADJ) IF(ALLOCATED(XPOL))DEALLOCATE(XPOL) IF(ALLOCATED(YPOL))DEALLOCATE(YPOL) END SUBROUTINE ISGADJUSTABORT !###=============================================================================== SUBROUTINE ISGADJUSTAPPLYSELECTION(ISEG,ITYPE,ISELADJ,ICASE,NATTRIB,IPOLSEG,IBATCH,IPOL) !###=============================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ISEG,ITYPE,ISELADJ,ICASE,NATTRIB,IPOLSEG,IBATCH,IPOL INTEGER :: IPOS,I,J,K,NPOS,IREF,N,NPNT,IPNT REAL :: DIST,TD CHARACTER(LEN=30) :: CNAME LOGICAL :: LEX NPNT=ISG(ISEG)%NSEG IPNT=ISG(ISEG)%ISEG SELECT CASE (ITYPE) !## calc.points CASE (1) NPOS=ISG(ISEG)%NCLC IPOS=ISG(ISEG)%ICLC !## structures CASE (2) NPOS=ISG(ISEG)%NSTW IPOS=ISG(ISEG)%ISTW !## cross-sections CASE (3) NPOS=ISG(ISEG)%NCRS IPOS=ISG(ISEG)%ICRS !## qh-relationships CASE (4) NPOS=ISG(ISEG)%NQHR IPOS=ISG(ISEG)%IQHR END SELECT K=0 DO I=1,NPOS K=K+1 !## get name SELECT CASE (ITYPE) CASE (1) CNAME=ISD(IPOS+K-1)%CNAME IREF =ISD(IPOS+K-1)%IREF N =ISD(IPOS+K-1)%N DIST =ISD(IPOS+K-1)%DIST CASE (2) CNAME=IST(IPOS+K-1)%CNAME IREF= IST(IPOS+K-1)%IREF N =IST(IPOS+K-1)%N DIST =IST(IPOS+K-1)%DIST CASE (3) CNAME=ISC(IPOS+K-1)%CNAME IREF= ISC(IPOS+K-1)%IREF N =ISC(IPOS+K-1)%N DIST =ISC(IPOS+K-1)%DIST CASE (4) CNAME=ISQ(IPOS+K-1)%CNAME IREF= ISQ(IPOS+K-1)%IREF N =ISQ(IPOS+K-1)%N DIST =ISQ(IPOS+K-1)%DIST END SELECT !## compute correct x/y coordinate of current feature CALL ISGADJUSTCOMPUTEXY(IPNT,NPNT,DIST,TD) LEX=.FALSE. IF(ICASE.EQ.0)THEN LEX=EQUALNAMES(TRIM(UTL_CAP(ISGADJ(ITYPE)%WC,'U')),TRIM(UTL_CAP(CNAME,'U'))) ELSEIF(ICASE.EQ.1)THEN LEX=EQUALNAMES(TRIM(ISGADJ(ITYPE)%WC),TRIM(CNAME)) ENDIF !## determine whether point is within polygon ... IF(IPOLSEG.EQ.2)THEN IF(UTL_INSIDEPOLYGON(ISGX,ISGY,XPOL,YPOL,NXY).NE.1)LEX=.FALSE. ENDIF !## adjust/remove IF(LEX)THEN IF(IPOL.NE.0)THEN IF(IBATCH.EQ.0)CALL WINDOWOUTSTATUSBAR(4,'Busy with segment '//TRIM(ISG(ISEG)%SNAME)//' within polygon '//TRIM(ITOS(IPOL))) IF(IBATCH.EQ.1)WRITE(*,*) 'Busy with segment '//TRIM(ISG(ISEG)%SNAME)//' within polygon ',IPOL WRITE(IULOG,'(A,I10)') 'Applied segment '//TRIM(ISG(ISEG)%SNAME)//' within polygon ',IPOL ELSE WRITE(IULOG,'(A,I10)') 'Applied segment '//TRIM(ISG(ISEG)%SNAME) ENDIF !## remove IF(ISELADJ.EQ.1)THEN SELECT CASE (ITYPE) !## remove current calculation points on segment, exception!: do not remove first/last CASE (1) IF(DIST.GT.0.0.AND.DIST.LT.TD)THEN WRITE(IULOG,'(A)') 'Deleted CALCULATION POINT: "'//TRIM(CNAME)//'"' CALL ISGDELISD(ISEG,IPOS+K-1) !## reset pointer one backwards K=K-1 ENDIF !## remove current structures on segment, no exceptions! CASE (2) WRITE(IULOG,'(A)') 'Deleted STRUCTURE: "'//TRIM(CNAME)//'"' CALL ISGDELIST(ISEG,IPOS+K-1) !## reset pointer one backwards K=K-1 !## remove current cross-sections on segment, exception!: do not remove last one!!! CASE (3) IF(ISG(ISEG)%NCRS.GT.1)THEN WRITE(IULOG,'(A)') 'Deleted CROSS-SECTION: "'//TRIM(CNAME)//'"' CALL ISGDELISC(ISEG,IPOS+K-1) !## reset pointer one backwards K=K-1 ENDIF !## remove current qh relationships on segment, no exceptions! CASE (4) WRITE(IULOG,'(A)') 'Deleted QH-RELATIONSHIP: "'//TRIM(CNAME)//'"' CALL ISGDELISQ(ISEG,IPOS+K-1) !## reset pointer one backwards K=K-1 END SELECT !## adjust ELSEIF(ISELADJ.EQ.2)THEN SELECT CASE (ITYPE) CASE (1) WRITE(IULOG,'(A)') 'Adjusted CALCULATION POINT: "'//TRIM(CNAME)//'"' CASE (2) WRITE(IULOG,'(A)') 'Adjusted STRUCTURE: "'//TRIM(CNAME)//'"' CASE (3) WRITE(IULOG,'(A)') 'Adjusted CROSS-SECTION: "'//TRIM(CNAME)//'"' CASE (4) WRITE(IULOG,'(A)') 'Adjusted QH-RELATIONSHIP: "'//TRIM(CNAME)//'"' END SELECT !## read from file IF(ISGADJ(ITYPE)%ISOURCE.EQ.1)THEN CALL ISGADJUSTFROMFILE(ITYPE,IPOS+K-1) !## read for each attribute individual ELSEIF(ISGADJ(ITYPE)%ISOURCE.EQ.2)THEN DO J=1,NATTRIB !## activated IF(ISGADJ(ITYPE)%IACTATTRIB(J).EQ.1)CALL ISGADJUSTATTRIBUTES(J,ITYPE,IREF,N) END DO ENDIF ENDIF ENDIF END DO END SUBROUTINE ISGADJUSTAPPLYSELECTION !###=============================================================================== SUBROUTINE ISGADJUSTREADFROMFILE(ITYPE) !###=============================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ITYPE INTEGER :: IU,I,IOS IU=UTL_GETUNIT() CALL OSD_OPEN(IU,FILE=TRIM(ISGADJ(ITYPE)%FNAME),STATUS='OLD',ACTION='READ,DENYWRITE') READ(IU,*) NRECORDS(ITYPE)=0 DO READ(IU,*,IOSTAT=IOS) IF(IOS.NE.0)EXIT NRECORDS(ITYPE)=NRECORDS(ITYPE)+1 END DO REWIND(IU) READ(IU,*) SELECT CASE (ITYPE) !## adjust current calculation points on segment CASE (1) WRITE(IULOG,'(A)') 'Read Calculation Point Data from: '//TRIM(ISGADJ(ITYPE)%FNAME) WRITE(IULOG,'(A)') WRITE(IULOG,'(5A10)') 'DATE','WATERLEVEL','BOTTOMLEVEL','RESISTANCE','INF.FACTOR' ALLOCATE(ISGEDITISD(NRECORDS(ITYPE))) DO I=1,NRECORDS(ITYPE) READ(IU,*) ISGEDITISD(I)%IDATE,ISGEDITISD(I)%WLVL,ISGEDITISD(I)%BTML,ISGEDITISD(I)%RESIS,ISGEDITISD(I)%INFF WRITE(IU,'(I10,4F10.3)') ISGEDITISD(I)%IDATE,ISGEDITISD(I)%WLVL,ISGEDITISD(I)%BTML,ISGEDITISD(I)%RESIS,ISGEDITISD(I)%INFF END DO WRITE(IULOG,'(A)') !## adjust current structures on segment CASE (2) WRITE(IULOG,'(A)') 'Read Structure Data from: '//TRIM(ISGADJ(ITYPE)%FNAME) WRITE(IULOG,'(A)') WRITE(IULOG,'(3A10)') 'DATE','WATERLEVEL','BOTTOMLEVEL' ALLOCATE(ISGEDITIST(NRECORDS(ITYPE))) DO I=1,NRECORDS(ITYPE) READ(IU,*) ISGEDITIST(I)%IDATE,ISGEDITIST(I)%WLVL_UP,ISGEDITIST(I)%WLVL_DOWN WRITE(IULOG,'(I10,2F10.3)') ISGEDITIST(I)%IDATE,ISGEDITIST(I)%WLVL_UP,ISGEDITIST(I)%WLVL_DOWN END DO WRITE(IULOG,'(A)') !## adjust current cross-sections on segment CASE (3) WRITE(IULOG,'(A)') 'Read Cross-Section Data from: '//TRIM(ISGADJ(ITYPE)%FNAME) WRITE(IULOG,'(A)') WRITE(IULOG,'(3A10)') 'Y','Z','KM' ALLOCATE(ISGEDITISC(NRECORDS(ITYPE))) DO I=1,NRECORDS(ITYPE) READ(IU,*) ISGEDITISC(I)%DISTANCE,ISGEDITISC(I)%BOTTOM,ISGEDITISC(I)%MRC WRITE(IULOG,'(3F10.3)') ISGEDITISC(I)%DISTANCE,ISGEDITISC(I)%BOTTOM,ISGEDITISC(I)%MRC END DO WRITE(IULOG,'(A)') !## adjust current qh relationships on segment CASE (4) WRITE(IULOG,'(A)') 'Read Q-WIDTH/DEPTH relationship Data from: '//TRIM(ISGADJ(ITYPE)%FNAME) WRITE(IULOG,'(A)') WRITE(IULOG,'(4A10)') 'Q','WIDTH','DEPTH','FACTOR' ALLOCATE(ISGEDITISQ(NRECORDS(ITYPE))) DO I=1,NRECORDS(ITYPE) READ(IU,*) ISGEDITISQ(I)%Q,ISGEDITISQ(I)%W,ISGEDITISQ(I)%D,ISGEDITISQ(I)%F WRITE(IULOG,'(4F10.3)') ISGEDITISQ(I)%Q,ISGEDITISQ(I)%W,ISGEDITISQ(I)%D,ISGEDITISQ(I)%F END DO WRITE(IULOG,'(A)') END SELECT CLOSE(IU) END SUBROUTINE ISGADJUSTREADFROMFILE !###=============================================================================== SUBROUTINE ISGADJUSTFROMFILE(ITYPE,IREF) !,N) !###=============================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ITYPE,IREF INTEGER :: I,IPOS,DN SELECT CASE (ITYPE) !## adjust current calculation points on segment CASE (1) DN=NRECORDS(ITYPE)-ISD(IREF)%N CALL ISGMEMORYDATISD(DN,IREF,IPOS) DO I=1,NRECORDS(ITYPE) DATISD(IPOS+I-1)%IDATE=ISGEDITISD(I)%IDATE DATISD(IPOS+I-1)%WLVL =ISGEDITISD(I)%WLVL DATISD(IPOS+I-1)%BTML =ISGEDITISD(I)%BTML DATISD(IPOS+I-1)%RESIS=ISGEDITISD(I)%RESIS DATISD(IPOS+I-1)%INFF =ISGEDITISD(I)%INFF END DO !## adjust current structures on segment CASE (2) DN=NRECORDS(ITYPE)-IST(IREF)%N CALL ISGMEMORYDATIST(DN,IREF,IPOS) DO I=1,NRECORDS(ITYPE) DATIST(IPOS+I-1)%IDATE =ISGEDITIST(I)%IDATE DATIST(IPOS+I-1)%WLVL_UP =ISGEDITIST(I)%WLVL_UP DATIST(IPOS+I-1)%WLVL_DOWN=ISGEDITIST(I)%WLVL_DOWN END DO !## adjust current cross-sections on segment CASE (3) !## check whether information fits into current occupied space ! ISG(ISELISG)%ICRS DN=NRECORDS(ITYPE)-ISC(IREF)%N CALL ISGMEMORYDATISC(DN,IREF,IPOS) DO I=1,NRECORDS(ITYPE) DATISC(IPOS+I-1)%DISTANCE=ISGEDITISC(I)%DISTANCE DATISC(IPOS+I-1)%BOTTOM =ISGEDITISC(I)%BOTTOM DATISC(IPOS+I-1)%MRC =ISGEDITISC(I)%MRC END DO !## adjust current qh relationships on segment CASE (4) DN=NRECORDS(ITYPE)-ISQ(IREF)%N CALL ISGMEMORYDATISQ(DN,IREF,IPOS) DO I=1,NRECORDS(ITYPE) DATISQ(IPOS+I-1)%Q=ISGEDITISQ(I)%Q DATISQ(IPOS+I-1)%W=ISGEDITISQ(I)%W DATISQ(IPOS+I-1)%D=ISGEDITISQ(I)%D DATISQ(IPOS+I-1)%F=ISGEDITISQ(I)%F END DO END SELECT END SUBROUTINE ISGADJUSTFROMFILE !###=============================================================================== SUBROUTINE ISGADJUSTATTRIBUTES(J,ITYPE,IREF,N) !###=============================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ITYPE,IREF,N,J INTEGER :: K REAL :: X1,X2 SELECT CASE (ITYPE) !## adjust current calculation points on segment CASE (1) WRITE(IULOG,'(A)') TRIM(ISGADJ(ITYPE)%ATTRIB(J)) IF(ISFR.EQ.0)THEN DO K=1,N SELECT CASE (ISGADJ(ITYPE)%IATTRIB(J)) CASE (1); X1=DATISD(IREF+K-1)%WLVL CASE (2); X1=DATISD(IREF+K-1)%BTML CASE (3); X1=DATISD(IREF+K-1)%RESIS CASE (4); X1=DATISD(IREF+K-1)%INFF END SELECT X2=X1; CALL ISGADJUSTCURRENTATTRIBUTES(X2,ITYPE,J) SELECT CASE (ISGADJ(ITYPE)%IATTRIB(J)) CASE (1); DATISD(IREF+K-1)%WLVL =X2 CASE (2); DATISD(IREF+K-1)%BTML =X2 CASE (3); DATISD(IREF+K-1)%RESIS=X2 CASE (4); DATISD(IREF+K-1)%INFF =X2 END SELECT WRITE(IULOG,'(A,2(G15.7,A))') ' old/new value:',X1,',',X2 ENDDO ELSEIF(ISFR.EQ.1)THEN DO K=1,N SELECT CASE (ISGADJ(ITYPE)%IATTRIB(J)) CASE (1); X1=DATISD(IREF+K-1)%WLVL CASE (2); X1=DATISD(IREF+K-1)%BTML CASE (3); X1=DATISD(IREF+K-1)%WIDTH CASE (4); X1=DATISD(IREF+K-1)%THCK CASE (5); X1=DATISD(IREF+K-1)%HCND CASE (6); X1=DATISD(IREF+K-1)%UPSG CASE (7); X1=DATISD(IREF+K-1)%DWNS CASE (8); X1=DATISD(IREF+K-1)%ICLC CASE (9); X1=DATISD(IREF+K-1)%IPRI CASE (10); X1=DATISD(IREF+K-1)%QFLW CASE (11); X1=DATISD(IREF+K-1)%QROF CASE (12); X1=DATISD(IREF+K-1)%PPTSW CASE (13); X1=DATISD(IREF+K-1)%ETSW END SELECT X2=X1; CALL ISGADJUSTCURRENTATTRIBUTES(X2,ITYPE,J) SELECT CASE (ISGADJ(ITYPE)%IATTRIB(J)) CASE (1); DATISD(IREF+K-1)%WLVL =X2 CASE (2); DATISD(IREF+K-1)%BTML =X2 CASE (3); DATISD(IREF+K-1)%WIDTH=X2 CASE (4); DATISD(IREF+K-1)%THCK =X2 CASE (5); DATISD(IREF+K-1)%HCND =X2 CASE (6); DATISD(IREF+K-1)%UPSG =X2 CASE (7); DATISD(IREF+K-1)%DWNS =X2 CASE (8); DATISD(IREF+K-1)%ICLC =X2 CASE (9); DATISD(IREF+K-1)%IPRI =X2 CASE (10); DATISD(IREF+K-1)%QFLW =X2 CASE (11); DATISD(IREF+K-1)%QROF =X2 CASE (12); DATISD(IREF+K-1)%PPTSW =X2 CASE (13); DATISD(IREF+K-1)%ETSW =X2 END SELECT WRITE(IULOG,'(A,2(G15.7,A))') ' old/new value:',X1,',',X2 ENDDO ENDIF !## adjust current structures on segment CASE (2) DO K=1,N SELECT CASE (ISGADJ(ITYPE)%IATTRIB(J)) CASE (1); X1=DATIST(IREF+K-1)%WLVL_UP CASE (2); X1=DATIST(IREF+K-1)%WLVL_DOWN END SELECT X2=X1; CALL ISGADJUSTCURRENTATTRIBUTES(X2,ITYPE,J) SELECT CASE (ISGADJ(ITYPE)%IATTRIB(J)) CASE (1); DATIST(IREF+K-1)%WLVL_UP=X2 CASE (2); DATIST(IREF+K-1)%WLVL_DOWN=X2 END SELECT WRITE(IULOG,'(A,2(G15.7,A))') ' old/new value:',X1,',',X2 ENDDO !## adjust current cross-sections on segment CASE (3) DO K=1,N SELECT CASE (ISGADJ(ITYPE)%IATTRIB(J)) CASE (1); X1=DATISC(IREF+K-1)%DISTANCE CASE (2); X1=DATISC(IREF+K-1)%BOTTOM CASE (3); X1=DATISC(IREF+K-1)%MRC END SELECT X2=X1; CALL ISGADJUSTCURRENTATTRIBUTES(X2,ITYPE,J) SELECT CASE (ISGADJ(ITYPE)%IATTRIB(J)) CASE (1); DATISC(IREF+K-1)%DISTANCE=X2 CASE (2); DATISC(IREF+K-1)%BOTTOM=X2 CASE (3); DATISC(IREF+K-1)%MRC=X2 END SELECT WRITE(IULOG,'(A,2(G15.7,A))') ' old/new value:',X1,',',X2 ENDDO !## adjust current qh relationships on segment CASE (4) DO K=1,N SELECT CASE (ISGADJ(ITYPE)%IATTRIB(J)) CASE (1); X1=DATISQ(IREF+K-1)%Q CASE (2); X1=DATISQ(IREF+K-1)%W CASE (3); X1=DATISQ(IREF+K-1)%D CASE (4); X1=DATISQ(IREF+K-1)%F END SELECT X2=X1; CALL ISGADJUSTCURRENTATTRIBUTES(X2,ITYPE,J) SELECT CASE (ISGADJ(ITYPE)%IATTRIB(J)) CASE (1); DATISQ(IREF+K-1)%Q=X2 CASE (2); DATISQ(IREF+K-1)%W=X2 CASE (3); DATISQ(IREF+K-1)%D=X2 CASE (4); DATISQ(IREF+K-1)%F=X2 END SELECT ENDDO END SELECT END SUBROUTINE ISGADJUSTATTRIBUTES !###=============================================================================== SUBROUTINE ISGADJUSTCOMPUTEXY(IPNT,NPNT,DIST,TD) !###=============================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: NPNT,IPNT REAL,INTENT(IN) :: DIST REAL,INTENT(OUT) :: TD INTEGER :: I,J,K REAL :: DXY,F TD=0.0 J =IPNT DO I=2,NPNT J = J+1 DXY=((ISP(J)%X-ISP(J-1)%X)**2.0)+((ISP(J)%Y-ISP(J-1)%Y)**2.0) IF(DXY.GT.0.0)DXY=SQRT(DXY) TD=TD+DXY IF(TD.GE.DIST)EXIT END DO !## distance current segment F =(DIST-(TD-DXY))/DXY ISGX= ISP(J-1)%X+(ISP(J)%X-ISP(J-1)%X)*F ISGY= ISP(J-1)%Y+(ISP(J)%Y-ISP(J-1)%Y)*F !## compute rest of segment length to yield total length K=I+1 DO I=K,NPNT J = J+1 DXY=((ISP(J)%X-ISP(J-1)%X)**2.0)+((ISP(J)%Y-ISP(J-1)%Y)**2.0) IF(DXY.GT.0.0)DXY=SQRT(DXY) TD=TD+DXY END DO END SUBROUTINE ISGADJUSTCOMPUTEXY !###=============================================================================== SUBROUTINE ISGADJUSTCURRENTATTRIBUTES(X2,ITYPE,J) !###=============================================================================== IMPLICIT NONE REAL,INTENT(INOUT) :: X2 INTEGER,INTENT(IN) :: ITYPE,J INTEGER :: IROW,ICOL,IREC,IR,IC,ISTEP SELECT CASE (ISGADJ(ITYPE)%IOP(J)) !## = CASE (1) X2=ISGADJ(ITYPE)%VALUE(J) !## + CASE (2) X2=X2+ISGADJ(ITYPE)%VALUE(J) !## - CASE (3) X2=X2-ISGADJ(ITYPE)%VALUE(J) !## / CASE (4) X2=X2/ISGADJ(ITYPE)%VALUE(J) !## * CASE (5) X2=X2*ISGADJ(ITYPE)%VALUE(J) !## IDF CASE (6) ICOL=INT((ISGX-ISGADJ(ITYPE)%IDF(J)%XMIN)/ISGADJ(ITYPE)%IDF(J)%DX)+1 IROW=INT((ISGADJ(ITYPE)%IDF(J)%YMAX-ISGY)/ISGADJ(ITYPE)%IDF(J)%DY)+1 IF(ICOL.GT.0.AND.ICOL.LE.ISGADJ(ITYPE)%IDF(J)%NCOL.AND. & IROW.GT.0.AND.IROW.LE.ISGADJ(ITYPE)%IDF(J)%NROW)THEN IREC=12+(IROW-1)*ISGADJ(ITYPE)%IDF(J)%NCOL+ICOL READ(ISGADJ(ITYPE)%IDF(J)%IU,REC=IREC) X2 ELSE ISTEP=0 ISTEPLOOP: DO! ISTEP=1,MAXNSTEP ISTEP=ISTEP+1 DO IR=MAX(IROW-ISTEP,1),MIN(IROW+ISTEP,ISGADJ(ITYPE)%IDF(J)%NROW) DO IC=MAX(ICOL-ISTEP,1),MIN(ICOL+ISTEP,ISGADJ(ITYPE)%IDF(J)%NCOL) IREC=12+(IR-1)*ISGADJ(ITYPE)%IDF(J)%NCOL+IC READ(ISGADJ(ITYPE)%IDF(J)%IU,REC=IREC) X2 IF(X2.NE.ISGADJ(ITYPE)%IDF(J)%NODATA)EXIT ISTEPLOOP END DO ENDDO ENDDO ISTEPLOOP WRITE(IULOG,'(A)') '*** Nearest value found within ',ISTEP*ISGADJ(ITYPE)%IDF(J)%DX,' meter ***' ENDIF END SELECT END SUBROUTINE ISGADJUSTCURRENTATTRIBUTES END MODULE MOD_ISG_ADJ