!! 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 USE WINTERACTER USE RESOURCE USE IMODVAR, ONLY : IDOWN USE DATEVAR USE MOD_COLOURS USE MOD_ISG_TRAPEZIUM, ONLY : ISGCOMPUTETRAPEZIUM,ISGCOMPUTEEIGHTPOINTS USE MOD_POLYGON_PAR USE MOD_GRAPH, ONLY : GRAPH_PLOTAXES,AXESOBJ,GRAPHUNITS,GRAPHAREA USE MOD_PREF_PAR, ONLY : PREFVAL USE MOD_UTL, ONLY : ITOS,INVERSECOLOUR,UTL_MESSAGEHANDLE,UTL_CAP,EQUALNAMES,UTL_FILLDATES,RTOS,UTL_IDFSNAPTOGRID,UTL_GETUNIT, & UTL_JDATETOIDATE,UTL_WSELECTFILE,IDFPLOT1BITMAP,IDFPLOT2BITMAP,UTL_IDATETOJDATE,UTL_GENLABELSDEALLOCATE,UTL_DATA_CSV,NL, & UTL_IDFGETCLASS,UTL_IDFCRDCOR,UTL_GETCURRENTDATE,UTL_GETCURRENTTIME,UTL_WRITENUMBER,VAR,ICOL_VAR,IACT_VAR,CCNST, & JDATETOFDATE,UTL_DIST,UTL_DEBUGLEVEL,UTL_MEASURE,UTL_INSIDEPOLYGON !,MAXLEN USE MOD_POLYGON_UTL, ONLY : POLYGON1FIELDS,POLYGON1IMAGES,POLYGON1INIT,POLYGON1CLOSE USE MOD_POLYGON_DRAW, ONLY : POLYGON1DRAWSHAPE USE MOD_IDF, ONLY : IDFREAD,IDFREADSCALE,IDFDEALLOCATE,IDFCOPY,IDFNULLIFY,IDFIROWICOL,IDFGETLOC,IDFALLOCATEX,IDFDEALLOCATEX,IDFCOPY USE MODPLOT USE MOD_LEGEND, ONLY : LEG_MAIN USE MOD_ISG_PAR USE MOD_OSD, ONLY : OSD_OPEN USE MOD_ISG_GRID, ONLY : ISG2GRIDGETDIMENSION,ISG2GRIDMAIN USE MOD_ISG_ADJ, ONLY : ISGADJUSTFIELDS,ISGADJUSTFIELDSTAB,ISGADJUSTCOMPUTEXY USE MOD_ISG_PLOT, ONLY : ISGPLOTSHAPE,ISGPLOT_FDIRECTION,ISGPLOT_FCONNECTION,ISGPLOT_LEGENDLINES,ISGPLOT_DRAWSELECTEDSEGMENTS, & ISGPLOT_DRAWREACHES USE MOD_ISG_UTL USE MOD_LEGPLOT, ONLY : LEGPLOT_PLOT USE IMODVAR, ONLY : IDIAGERROR USE IMOD, ONLY : IDFINIT USE MOD_QKSORT USE MOD_CREATEIPF, ONLY : CREATEIPF_DRAWPOLYGON USE MOD_LEGEND, ONLY : LEG_CREATE_COLORS TYPE(AXESOBJ),PRIVATE :: AXES REAL,PARAMETER,PRIVATE :: RNODATA=HUGE(1.0) INTEGER,PARAMETER,PRIVATE :: INODATA=0 REAL,ALLOCATABLE,DIMENSION(:),PRIVATE :: XTOP,XSTW,XBOT,XCRS,XQHR REAL,ALLOCATABLE,DIMENSION(:),PRIVATE :: YTOP,YBOT INTEGER,PRIVATE :: NTOP,NBOT,NCRS,NQHR,NSTW REAL,PRIVATE :: PROFXMIN,PROFXMAX,PROFYMIN,PROFYMAX INTEGER,PRIVATE :: ACLR,BCLR CONTAINS !###==================================================================== SUBROUTINE ISGEDITMAIN(ITYPE,MESSAGE) !###==================================================================== IMPLICIT NONE TYPE(WIN_MESSAGE),INTENT(IN) :: MESSAGE TYPE(WIN_MESSAGE) :: DMESSAGE INTEGER,INTENT(IN) :: ITYPE INTEGER :: I,IRGB,JTYPE CHARACTER(LEN=256) :: ISGFILE CALL WDIALOGSELECT(MESSAGE%WIN) SELECT CASE (ITYPE) CASE(TABCHANGED) !## new tab SELECT CASE (MESSAGE%VALUE2) CASE (ID_DISGEDITTAB1) ISGSHAPES=SHPNO !## remove polygons ... CALL POLYGON1DRAWSHAPE(1,SHPNO) SHPNCRD(1:SHPNO)=-1*SHPNCRD(1:SHPNO) !## draw selected segments CALL ISGCHECKISG(0.0,0.0,1) CASE (ID_DISGEDITTAB2,ID_DISGEDITTAB3,ID_DISGEDITTAB4,ID_DISGEDITTAB5,ID_DISGEDITTAB6,ID_DISGEDITTAB7) IF(MESSAGE%VALUE1.EQ.ID_DISGEDITTAB1)THEN !## remove selected segment IF(SHPNO.GT.0)CALL POLYGON1DRAWSHAPE(SHPNO,SHPNO) SHPNO =ISGSHAPES SHPNCRD(1:SHPNO)=-1*SHPNCRD(1:SHPNO) !## draw polygons CALL POLYGON1DRAWSHAPE(1,SHPNO) CALL POLYGON1FIELDS(ID_DISGEDITTAB2) ENDIF CALL ISGADJUSTFIELDS() IF(MESSAGE%VALUE2.EQ.ID_DISGEDITTAB4)CALL ISGADJUSTFIELDSTAB(ID_DISGEDITTAB4,4) IF(MESSAGE%VALUE2.EQ.ID_DISGEDITTAB5)CALL ISGADJUSTFIELDSTAB(ID_DISGEDITTAB5,2) IF(MESSAGE%VALUE2.EQ.ID_DISGEDITTAB6)CALL ISGADJUSTFIELDSTAB(ID_DISGEDITTAB6,3) IF(MESSAGE%VALUE2.EQ.ID_DISGEDITTAB7)CALL ISGADJUSTFIELDSTAB(ID_DISGEDITTAB7,4) END SELECT CASE(FIELDCHANGED) SELECT CASE (MESSAGE%VALUE2) !## change in field of isg segments CASE (IDF_MENU1) CALL ISGCHECKISG(0.0,0.0,1) !## show selected CASE (IDF_CHECK7) CALL IDFPLOTFAST(1) CASE (IDF_CHECK1,IDF_CHECK2,IDF_CHECK3,IDF_CHECK4,IDF_CHECK5,IDF_CHECK6,IDF_CHECK9,IDF_CHECK10) CALL WDIALOGSELECT(ID_DISGEDIT) CALL WDIALOGGETCHECKBOX(MESSAGE%VALUE2,I) CALL WINDOWSELECT(0) IF(MESSAGE%VALUE2.EQ.IDF_CHECK1) CALL WMENUSETSTATE(ID_ISGNODES,2,I) IF(MESSAGE%VALUE2.EQ.IDF_CHECK2) CALL WMENUSETSTATE(ID_ISGCLCNODES,2,I) IF(MESSAGE%VALUE2.EQ.IDF_CHECK3) CALL WMENUSETSTATE(ID_ISGCRSSCTNS,2,I) IF(MESSAGE%VALUE2.EQ.IDF_CHECK4) CALL WMENUSETSTATE(ID_ISGSEGNODES,2,I) IF(MESSAGE%VALUE2.EQ.IDF_CHECK5) CALL WMENUSETSTATE(ID_ISGSTUWEN,2,I) IF(MESSAGE%VALUE2.EQ.IDF_CHECK6) CALL WMENUSETSTATE(ID_ISGQHR,2,I) IF(MESSAGE%VALUE2.EQ.IDF_CHECK9) CALL WMENUSETSTATE(ID_ISGSFR,2,I) IF(MESSAGE%VALUE2.EQ.IDF_CHECK10)CALL WMENUSETSTATE(ID_ISGSFC,2,I) CASE (IDF_STRING1,IDF_STRING2,IDF_STRING3,IDF_STRING4,IDF_STRING5,IDF_STRING6,IDF_STRING7,IDF_STRING8) CALL WDIALOGSELECT(ID_DISGEDIT) IF(MESSAGE%VALUE2.EQ.IDF_STRING1)IRGB=ICLRND IF(MESSAGE%VALUE2.EQ.IDF_STRING2)IRGB=ICLRSD IF(MESSAGE%VALUE2.EQ.IDF_STRING3)IRGB=ICLRSC IF(MESSAGE%VALUE2.EQ.IDF_STRING4)IRGB=ICLRSP IF(MESSAGE%VALUE2.EQ.IDF_STRING5)IRGB=ICLRST IF(MESSAGE%VALUE2.EQ.IDF_STRING6)IRGB=ICLRQH IF(MESSAGE%VALUE2.EQ.IDF_STRING7)IRGB=ICLRSF IF(MESSAGE%VALUE2.EQ.IDF_STRING8)IRGB=ICLRCO CALL WSELECTCOLOUR(IRGB) IF(WINFODIALOG(4).EQ.1)THEN IF(MESSAGE%VALUE2.EQ.IDF_STRING1)ICLRND=IRGB IF(MESSAGE%VALUE2.EQ.IDF_STRING2)ICLRSD=IRGB IF(MESSAGE%VALUE2.EQ.IDF_STRING3)ICLRSC=IRGB IF(MESSAGE%VALUE2.EQ.IDF_STRING4)ICLRSP=IRGB IF(MESSAGE%VALUE2.EQ.IDF_STRING5)ICLRST=IRGB IF(MESSAGE%VALUE2.EQ.IDF_STRING6)ICLRQH=IRGB IF(MESSAGE%VALUE2.EQ.IDF_STRING7)ICLRSF=IRGB IF(MESSAGE%VALUE2.EQ.IDF_STRING8)ICLRCO=IRGB CALL WDIALOGCOLOUR(MESSAGE%VALUE2,INVERSECOLOUR(IRGB),IRGB) CALL IDFPLOTFAST(1) ENDIF END SELECT CASE(PUSHBUTTON) SELECT CASE (MESSAGE%WIN) CASE (ID_DISGEDIT) SELECT CASE (MESSAGE%VALUE1) CASE (ID_SAVE) ISGFILE=ISGFNAME; CALL ISGSAVE(ISGFILE,0) CASE(ID_SAVEAS) ISGFILE=''; CALL ISGSAVE(ISGFILE,1) !## global isgname IF(ISGFILE.NE.'')THEN CALL IDFINIT(IDFNAMEGIVEN=TRIM(ISGFILE),LPLOT=.TRUE.) DO I=1,MXMPLOT; IF(MP(I)%ISEL.AND.MP(I)%IPLOT.EQ.4)EXIT; END DO IISGPLOT=I; ISGFNAME=ISGFILE CALL WDIALOGSELECT(ID_DISGEDIT) CALL WDIALOGTITLE('ISG Edit: '//TRIM(MP(IISGPLOT)%ALIAS)) ENDIF CASE (ID_UPDATE) CALL IDFPLOTFAST(1) CASE(IDHELP) CALL IMODGETHELP('4.4.3','MMO.IGO.ISGEdit') CASE(IDCANCEL) CALL ISGEDITCLOSE(1) END SELECT CASE (ID_DISGEDITTAB1) SELECT CASE (MESSAGE%VALUE1) CASE (ID_RENAME) CALL ISGRENAMESEGMENT() CASE (ID_GRID) CALL ISGGRIDMAIN() CASE (ID_LEGEND) CALL ISGLEGENDINIT() CASE (ID_PROFILE) CALL ISGPROFILE CASE (ID_DRAW) CALL ISGADD() CASE (ID_CONNECTTO,ID_CONNECTFROM) CALL ISGCONNECT(MESSAGE%VALUE1) CASE (ID_CONNECTTOAUTO) CALL ISGCONNECTTOAUTO() CASE (ID_DRIP) CALL ISGDRIP() CASE (ID_POLYGON) CALL ISGSELECTPOLYGON() CASE(ID_ZOOMTO) CALL ISGZOOMTO() CASE (ID_FIND) CALL ISGFIND() CASE (ID_RECORDS) CALL ISGATTRIBUTES() CASE(ID_DELETE) CALL WDIALOGGETMENU(IDF_MENU1,ISG(1:NISG)%ILIST) CALL WINDOWSELECT(0) IF(SUM(ISG(1:NISG)%ILIST).EQ.1)THEN CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Are you sure to delete segment ['//TRIM(ISG(ISELISG)%SNAME)//'] ?','Question') IF(WINFODIALOG(4).EQ.1)THEN CALL WCURSORSHAPE(CURHOURGLASS) CALL WINDOWOUTSTATUSBAR(4,'Removing '//TRIM(ISG(ISELISG)%SNAME)//' ...') CALL ISGDEL() CALL ISGDELCLOSE() CALL WCURSORSHAPE(CURARROW) ENDIF ELSE CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Are you sure to delete the selected segments ?','Question') IF(WINFODIALOG(4).EQ.1)THEN CALL WCURSORSHAPE(CURHOURGLASS) I=0 DO I=I+1 IF(I.GT.NISG)EXIT IF(ISG(I)%ILIST.EQ.1)THEN ISELISG=I CALL WMESSAGEPEEK(JTYPE,DMESSAGE) CALL WINDOWOUTSTATUSBAR(4,'Removing '//TRIM(ISG(ISELISG)%SNAME)//' ...') CALL ISGDEL() I=I-1 ENDIF END DO CALL ISGDELCLOSE() CALL WCURSORSHAPE(CURARROW) ENDIF ENDIF CALL WINDOWSELECT(0) CALL WINDOWOUTSTATUSBAR(4,'') END SELECT END SELECT END SELECT END SUBROUTINE ISGEDITMAIN !###==================================================================== SUBROUTINE ISGRENAMESEGMENT() !###==================================================================== IMPLICIT NONE TYPE(WIN_MESSAGE) :: MESSAGE INTEGER :: ITYPE,I CHARACTER(LEN=50) :: SNAME IF(SUM(ISG%ILIST).NE.1)THEN CALL WMESSAGEBOX(OKONLY,COMMONOK,EXCLAMATIONICON,'You need to select one segment to rename it.','Information') RETURN ENDIF DO I=1,NISG; IF(ISG(I)%ILIST.EQ.1)EXIT; ENDDO CALL WDIALOGLOAD(ID_DSCENNAME,ID_DSCENNAME) CALL WDIALOGTITLE('Give New Name: ') CALL WDIALOGPUTSTRING(IDF_GROUP1,'Enter a new name for the selected Segment') CALL WDIALOGPUTMENU(IDF_MENU1,ISG%SNAME,NISG,I) CALL WDIALOGPUTSTRING(IDOK,'Save and Close') CALL WDIALOGSHOW(-1,-1,0,3) DO CALL WMESSAGE(ITYPE,MESSAGE) IF(ITYPE.EQ.PUSHBUTTON)THEN SELECT CASE(MESSAGE%VALUE1) CASE (IDOK) CALL WDIALOGGETMENU(IDF_MENU1,ITYPE,SNAME) ISG(I)%SNAME=SNAME CALL WDIALOGSELECT(ID_DISGEDITTAB1) CALL WDIALOGPUTMENU(IDF_MENU1,ISG%SNAME,NISG,ISG%ILIST) EXIT CASE (IDCANCEL) EXIT CASE(IDHELP) CALL IMODGETHELP('4.4.3.2','MMO.IGO.IE.Attr') END SELECT ENDIF ENDDO CALL WDIALOGSELECT(ID_DSCENNAME); CALL WDIALOGUNLOAD() CALL WDIALOGSELECT(ID_DISGEDITTAB1) END SUBROUTINE ISGRENAMESEGMENT !###==================================================================== SUBROUTINE ISGPROFILE() !###==================================================================== IMPLICIT NONE TYPE(WIN_MESSAGE) :: MESSAGE INTEGER :: ITYPE,I,IRGB ACLR=WRGB(119,219,214) BCLR=WRGB(160,136,121) CALL WDIALOGLOAD(ID_DISGPROFILE,ID_DISGPROFILE) CALL WDIALOGPUTMENU(IDF_MENU1,ISG%SNAME,NISG,ISG%ILIST) IF(ISFR.EQ.0)THEN CALL WDIALOGPUTMENU(IDF_MENU3,ISDLABELS(2:),SIZE(ISDLABELS)-1,1) CALL WDIALOGPUTMENU(IDF_MENU4,ISDLABELS(2:),SIZE(ISDLABELS)-1,2) ELSE CALL WDIALOGPUTMENU(IDF_MENU3,ISDLABELS(3:),SIZE(ISDLABELS)-2,1) CALL WDIALOGPUTMENU(IDF_MENU4,ISDLABELS(3:),SIZE(ISDLABELS)-2,2) ENDIF CALL WDIALOGPUTIMAGE(IDF_COLOUR1,ID_ICONLEGEND,1) CALL WDIALOGPUTIMAGE(IDF_COLOUR2,ID_ICONLEGEND,1) CALL WDIALOGPUTIMAGE(ID_ZOOMIN,ID_ICONZOOMIN) CALL WDIALOGPUTIMAGE(ID_ZOOMOUT,ID_ICONZOOMOUT) CALL WDIALOGPUTIMAGE(ID_ZOOMFULL,ID_ICONZOOMFULL) CALL WDIALOGPUTIMAGE(ID_ZOOMBOX,ID_ICONZOOMBOX) CALL WDIALOGPUTIMAGE(ID_MOVE,ID_ICONMOVE) CALL WDIALOGFIELDSTATE(IDF_MENU4,0) CALL WDIALOGFIELDSTATE(IDF_COLOUR2,0) CALL WDIALOGSHOW(-1,-1,0,3) CALL WDIALOGGETMENU(IDF_MENU1,ISG%ILIST) CALL ISGPROFILE_GETDATES(IDF_MENU2) CALL ISGPROFILE_GETDATA() CALL ISGPROFILE_PLOT() DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE (MOUSEMOVE) CALL WDIALOGPUTREAL(IDF_REAL1,MESSAGE%GX) CALL WDIALOGPUTREAL(IDF_REAL2,MESSAGE%GY) ! CALL ISGPROFILENAMES(MESSAGE%GX,MESSAGE%GY,0,(/0,0,0,0/)) CASE (FIELDCHANGED) SELECT CASE (MESSAGE%VALUE2) CASE (IDF_CHECK6) CALL ISGPROFILE_GETDATA() CALL ISGPROFILE_PLOT() CASE (IDF_CHECK5) CALL WDIALOGGETCHECKBOX(IDF_CHECK5,I) CALL WDIALOGFIELDSTATE(IDF_MENU4,I) CALL WDIALOGFIELDSTATE(IDF_COLOUR2,I) CALL ISGPROFILE_GETDATA() CALL ISGPROFILE_PLOT() CASE (IDF_CHECK1,IDF_CHECK2,IDF_CHECK3,IDF_CHECK4) IF(MESSAGE%VALUE1.EQ.MESSAGE%VALUE2)CALL ISGPROFILE_PLOT() CASE (IDF_MENU1) CALL WDIALOGGETMENU(IDF_MENU1,ISG%ILIST) CALL ISGPROFILE_GETDATES(IDF_MENU2) CALL ISGPROFILE_GETDATA() CALL ISGPROFILE_PLOT() CASE (IDF_MENU2,IDF_MENU3,IDF_MENU4) CALL ISGPROFILE_GETDATA() CALL ISGPROFILE_PLOT() END SELECT CASE (PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (IDF_COLOUR1) IRGB=ACLR; CALL WSELECTCOLOUR(IRGB); IF(WINFODIALOG(4).EQ.1)ACLR=IRGB CALL ISGPROFILE_PLOT() CASE (IDF_COLOUR2) IRGB=BCLR; CALL WSELECTCOLOUR(IRGB); IF(WINFODIALOG(4).EQ.1)BCLR=IRGB CALL ISGPROFILE_PLOT() CASE (ID_ZOOMIN,ID_ZOOMOUT,ID_ZOOMFULL,ID_ZOOMBOX,ID_MOVE) CALL ISGPROFILE_ZOOM(MESSAGE%VALUE1,ID_DISGPROFILE) CASE (IDOK,IDCANCEL) EXIT CASE (IDHELP) CALL IMODGETHELP('4.4.3.4','MMO.IGO.IE.Prof') END SELECT CASE (EXPOSE,RESIZE) CALL ISGPROFILE_PLOT() END SELECT ENDDO CALL ISGPROFILE_DEALLOCATE() IF(ALLOCATED(IDATES))DEALLOCATE(IDATES) IF(ALLOCATED(CDATES))DEALLOCATE(CDATES) CALL WDIALOGSELECT(ID_DISGPROFILE); CALL WDIALOGUNLOAD() CALL WDIALOGSELECT(ID_DISGEDITTAB1) CALL WDIALOGPUTMENU(IDF_MENU1,ISG%SNAME,NISG,ISG%ILIST) CALL IGRSELECT(DRAWWIN,MPW%IWIN) END SUBROUTINE ISGPROFILE !###====================================================================== SUBROUTINE ISGPROFILE_ZOOM(IDZ,IWIN_ID) !###====================================================================== IMPLICIT NONE REAL,PARAMETER :: FZIO=0.05 INTEGER,INTENT(IN) :: IDZ,IWIN_ID TYPE(WIN_MESSAGE) :: MESSAGE INTEGER :: ITYPE,IDOWN,IDCURSOR REAL :: FZ,XC1,YC1,XC2,YC2,XC3,YC3,DX,DY LOGICAL :: LEX IF(IDZ.EQ.ID_ZOOMIN)THEN FZ=FZIO*(PROFXMAX-PROFXMIN); PROFXMIN=PROFXMIN+FZ; PROFXMAX=PROFXMAX-FZ FZ=FZIO*(PROFYMAX-PROFYMIN); PROFYMIN=PROFYMIN+FZ; PROFYMAX=PROFYMAX-FZ ELSEIF(IDZ.EQ.ID_ZOOMOUT)THEN FZ=FZIO*(PROFXMAX-PROFXMIN); PROFXMIN=PROFXMIN-FZ; PROFXMAX=PROFXMAX+FZ FZ=FZIO*(PROFYMAX-PROFYMIN); PROFYMIN=PROFYMIN-FZ; PROFYMAX=PROFYMAX+FZ ELSEIF(IDZ.EQ.ID_ZOOMFULL)THEN PROFXMIN=XBOT(1) PROFXMAX=XBOT(NBOT-1) PROFYMAX=-10.0E10 PROFYMIN= 10.0E10 PROFYMIN=MIN(PROFYMIN,MINVAL(YBOT(1:NBOT))) PROFYMAX=MAX(PROFYMAX,MAXVAL(YBOT(1:NBOT))) IF(NTOP.GT.0)THEN PROFYMIN=MIN(PROFYMIN,MINVAL(YTOP(1:NTOP))) PROFYMAX=MAX(PROFYMAX,MAXVAL(YTOP(1:NTOP))) ENDIF ELSEIF(IDZ.EQ.ID_MOVE)THEN IDCURSOR=ID_CURSORHAND; CALL WCURSORSHAPE(IDCURSOR); IDOWN=0 DO CALL WMESSAGE(ITYPE,MESSAGE) IF(IWIN_ID.NE.0.AND.MESSAGE%WIN.NE.IWIN_ID)THEN IF(WINFOMOUSE(MOUSECURSOR).NE.CURHOURGLASS)CALL WCURSORSHAPE(CURHOURGLASS) ELSE IF(WINFOMOUSE(MOUSECURSOR).NE.IDCURSOR)CALL WCURSORSHAPE(IDCURSOR) SELECT CASE(ITYPE) CASE(MOUSEMOVE) CALL WDIALOGPUTREAL(IDF_REAL1,MESSAGE%GX) CALL WDIALOGPUTREAL(IDF_REAL2,MESSAGE%GY) XC2=MESSAGE%GX; YC2=MESSAGE%GY !## first point set! IF(IDOWN.EQ.1)THEN DX=XC1-XC2; DY=YC1-YC2 PROFXMIN=PROFXMIN+DX; PROFXMAX=PROFXMAX+DX PROFYMIN=PROFYMIN+DY; PROFYMAX=PROFYMAX+DY CALL ISGPROFILE_PLOT() ENDIF !## mouse button pressed CASE (MOUSEBUTUP) SELECT CASE (MESSAGE%VALUE1) !## left button CASE (1); IDOWN=0; IDCURSOR=ID_CURSORHAND; CALL WCURSORSHAPE(IDCURSOR) END SELECT !## mouse button pressed CASE (MOUSEBUTDOWN) SELECT CASE (MESSAGE%VALUE1) !## left button CASE (1) IF(IDOWN.EQ.0)THEN IDCURSOR=ID_CURSORHANDGREP; CALL WCURSORSHAPE(IDCURSOR) XC1=XC2; YC1=YC2; IDOWN=1 ENDIF !## right button CASE (3) EXIT END SELECT CASE (EXPOSE,RESIZE) CALL ISGPROFILE_PLOT() END SELECT ENDIF ENDDO ELSEIF(IDZ.EQ.ID_ZOOMBOX)THEN IDCURSOR=ID_CURSORZOOMRECTANGLE !## rectangle zoom CALL IGRPLOTMODE(MODEXOR); CALL IGRCOLOURN(WRGB(255,255,255)) CALL IGRFILLPATTERN(OUTLINE); CALL IGRLINETYPE(DASHED) CALL IGRLINEWIDTH(1); CALL WCURSORSHAPE(IDCURSOR) IDOWN=0 LEX =.FALSE. XC1=0.0; YC1=0.0 DO CALL WMESSAGE(ITYPE,MESSAGE) IF(IWIN_ID.NE.0.AND.MESSAGE%WIN.NE.IWIN_ID)THEN IF(WINFOMOUSE(MOUSECURSOR).NE.CURHOURGLASS)CALL WCURSORSHAPE(CURHOURGLASS) ELSE IF(WINFOMOUSE(MOUSECURSOR).NE.IDCURSOR)CALL WCURSORSHAPE(IDCURSOR) SELECT CASE(ITYPE) CASE(MOUSEMOVE) CALL WDIALOGPUTREAL(IDF_REAL1,MESSAGE%GX) CALL WDIALOGPUTREAL(IDF_REAL2,MESSAGE%GY) XC2=MESSAGE%GX; YC2=MESSAGE%GY !## first point set! IF(IDOWN.EQ.1)THEN IF(LEX)CALL IGRRECTANGLE(XC1,YC1,XC3,YC3) LEX=.FALSE. IF(XC1.NE.XC2.AND.YC1.NE.YC2)LEX=.TRUE. IF(LEX)CALL IGRRECTANGLE(XC1,YC1,XC2,YC2) ENDIF XC3=XC2; YC3=YC2 !## mouse button pressed CASE (MOUSEBUTDOWN) SELECT CASE (MESSAGE%VALUE1) !## left button CASE (1) IF(IDOWN.EQ.0)THEN XC1=XC2; YC1=YC2; IDOWN=1 ELSE PROFXMIN=MIN(XC1,XC2); PROFXMAX=MAX(XC1,XC2) PROFYMIN=MIN(YC1,YC2); PROFYMAX=MAX(YC1,YC2) EXIT ENDIF !## right button CASE (3) IF(IDOWN.EQ.1.AND.LEX)CALL IGRRECTANGLE(XC1,YC1,XC3,YC3) EXIT END SELECT CASE (EXPOSE,RESIZE) CALL ISGPROFILE_PLOT() END SELECT ENDIF ENDDO CALL IGRPLOTMODE(MODECOPY) ENDIF CALL IGRLINETYPE(SOLIDLINE) CALL WCURSORSHAPE(CURARROW) CALL ISGPROFILE_PLOT() ! !## final check, make sure still viewable extent !DX=MPW%XMAX-MPW%XMIN; DY=MPW%YMAX-MPW%YMIN !IF(DX.LE.0.0.OR.DY.LE.0.0)THEN ! IF(DX.LE.0.0.AND.DY.LE.0.0)THEN ! MPW%XMAX=MPW%XMIN+1.0; MPW%YMAX=MPW%YMIN+1.0 ! ELSEIF(DX.LE.0.0.AND.DY.GT.0.0)THEN ! MPW%XMAX=MPW%XMIN+DY ! ELSE ! MPW%YMAX=MPW%YMIN+DX ! ENDIF !ENDIF !CALL WINDOWSELECT(0) !CALL WINDOWOUTSTATUSBAR(2,'') !!## store current zoom-extent !IF(IDZ.NE.ID_ZOOMPREVIOUS.AND.IDZ.NE.ID_ZOOMNEXT)CALL IDFSTOREZOOMEXTENT() END SUBROUTINE ISGPROFILE_ZOOM ! !###==================================================================== ! SUBROUTINE ISGPROFILENAMES(X,Y,IPLOT,ICHECK) ! !###==================================================================== ! IMPLICIT NONE ! INTEGER,PARAMETER :: N=7 ! REAL,INTENT(IN) :: X,Y ! INTEGER,INTENT(IN) :: IPLOT ! INTEGER,DIMENSION(4),INTENT(IN) :: ICHECK ! INTEGER :: I,I1,I2,IISG ! REAL :: MIND,YS,DS,DX ! CHARACTER(LEN=30) :: CNAME ! REAL,DIMENSION(4) :: AREA,GNIT ! ! CALL WDIALOGPUTREAL(IDF_REAL1,X) ! CALL WDIALOGPUTREAL(IDF_REAL2,Y) ! CALL WDIALOGGETMENU(IDF_MENU1,IISG) ! ! DS=1.0/REAL(N) ! ! YS=0.0 ! IF(IPLOT.EQ.1)THEN ! AREA(1)=WINFOGRREAL(GRAPHICSAREAMINX) ! AREA(2)=WINFOGRREAL(GRAPHICSAREAMAXX) ! AREA(3)=WINFOGRREAL(GRAPHICSAREAMINY) ! AREA(4)=WINFOGRREAL(GRAPHICSAREAMAXY) ! GNIT(1)=WINFOGRREAL(GRAPHICSUNITMINX) ! GNIT(2)=WINFOGRREAL(GRAPHICSUNITMAXX) ! GNIT(3)=WINFOGRREAL(GRAPHICSUNITMINY) ! GNIT(4)=WINFOGRREAL(GRAPHICSUNITMAXY) ! CALL IGRAREA(AREA(1),AREA(4),AREA(2),1.0) ! CALL IGRUNITS(GNIT(1),0.0,GNIT(2),1.0) ! CALL IGRCOLOURN(WRGB(50,50,50)) ! YS=1.0 ! DO I=1,N-2 ! YS=YS-DS ! CALL IGRJOIN(GNIT(1),YS+(0.5*DS),GNIT(2),YS+(0.5*DS)) ! END DO ! YS= 1.0 ! DX=(GNIT(2)-GNIT(1))/250.0 ! ENDIF ! ! YS=YS-DS ! CALL IGRCOLOURN(ICLRSD) ! !## calc.points ! I1 =ISG(IISG)%ICLC ! I2 =ISG(IISG)%ICLC+ISG(IISG)%NCLC-1 ! MIND =10.0E10 ! DO I=I1,I2 ! IF(ABS(ISD(I)%DIST-X).LT.MIND)THEN ! CNAME=ISD(I)%CNAME ! MIND=ABS(ISD(I)%DIST-X) ! ENDIF ! IF(IPLOT.EQ.1)CALL IGRRECTANGLE(ISD(I)%DIST-DX,YS,ISD(I)%DIST+DX,YS-DS) ! END DO ! CALL WDIALOGPUTSTRING(IDF_LABEL3,CNAME) ! ! YS=YS-DS ! CALL IGRCOLOURN(ICLRST) ! ! !## structures ! IF(ISG(IISG)%NSTW.LE.0)THEN ! CALL WDIALOGCLEARFIELD(IDF_LABEL5) ! ELSE ! I1 =ISG(IISG)%ISTW ! I2 =ISG(IISG)%ISTW+ISG(IISG)%NSTW-1 ! MIND =10.0E10 ! DO I=I1,I2 ! IF(ABS(IST(I)%DIST-X).LT.MIND)THEN ! CNAME=IST(I)%CNAME ! MIND=ABS(IST(I)%DIST-X) ! ENDIF ! IF(IPLOT.EQ.1)CALL IGRRECTANGLE(IST(I)%DIST-DX,YS,IST(I)%DIST+DX,YS-DS) ! END DO ! CALL WDIALOGPUTSTRING(IDF_LABEL5,CNAME) ! ENDIF ! ! YS=YS-DS ! CALL IGRCOLOURN(ICLRSC) ! ! !## cross-sections ! IF(ISG(IISG)%NCRS.LE.0)THEN ! CALL WDIALOGCLEARFIELD(IDF_LABEL6) ! ELSE ! I1 =ISG(IISG)%ICRS ! I2 =ISG(IISG)%ICRS+ISG(IISG)%NCRS-1 ! MIND =10.0E10 ! DO I=I1,I2 ! IF(ABS(ISC(I)%DIST-X).LT.MIND)THEN ! CNAME=ISC(I)%CNAME ! MIND=ABS(ISC(I)%DIST-X) ! ENDIF ! IF(IPLOT.EQ.1)CALL IGRRECTANGLE(ISC(I)%DIST-DX,YS,ISC(I)%DIST+DX,YS-DS) ! END DO ! CALL WDIALOGPUTSTRING(IDF_LABEL6,CNAME) ! ENDIF ! ! YS=YS-DS ! CALL IGRCOLOURN(ICLRQH) ! ! !## qh-relationships ! IF(ISG(IISG)%NQHR.LE.0)THEN ! CALL WDIALOGCLEARFIELD(IDF_LABEL7) ! ELSE ! I1 =ISG(IISG)%IQHR ! I2 =ISG(IISG)%IQHR+ISG(IISG)%NQHR-1 ! MIND =10.0E10 ! DO I=I1,I2 ! IF(ABS(ISQ(I)%DIST-X).LT.MIND)THEN ! CNAME=ISQ(I)%CNAME ! MIND=ABS(ISQ(I)%DIST-X) ! ENDIF ! IF(IPLOT.EQ.1)CALL IGRRECTANGLE(ISQ(I)%DIST-DX,YS,ISQ(I)%DIST+DX,YS-DS) ! END DO ! CALL WDIALOGPUTSTRING(IDF_LABEL7,CNAME) ! ENDIF ! ! IF(IPLOT.EQ.1)THEN ! CALL IGRAREA(AREA(1),AREA(3),AREA(2),AREA(4)) ! CALL IGRUNITS(GNIT(1),GNIT(3),GNIT(2),GNIT(4)) ! ENDIF ! ! END SUBROUTINE ISGPROFILENAMES !###==================================================================== SUBROUTINE ISGPROFILE_GETDATES(ID) !###==================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ID INTEGER :: I,J,N,IISG CALL UTL_MESSAGEHANDLE(0) !## get max. number of idates() for selected isg segments N=0; DO IISG=1,NISG IF(ISG(IISG)%ILIST.EQ.0)CYCLE !## calc. points DO I=ISG(IISG)%ICLC,ISG(IISG)%ICLC+ISG(IISG)%NCLC-1 N=N+ISD(I)%N END DO !## structures DO I=ISG(IISG)%ISTW,ISG(IISG)%ISTW+ISG(IISG)%NSTW-1 N=N+IST(I)%N END DO ENDDO IF(N.EQ.0)THEN CALL WDIALOGFIELDSTATE(ID,0) CALL WDIALOGPUTMENU(ID,(/'No dates'/),1,1) ELSE CALL WDIALOGFIELDSTATE(ID,1) IF(ALLOCATED(IDATES))DEALLOCATE(IDATES); ALLOCATE(IDATES(N)) !## find them ... N=0; DO IISG=1,NISG IF(ISG(IISG)%ILIST.EQ.0)CYCLE !## calc. points DO I=ISG(IISG)%ICLC,ISG(IISG)%ICLC+ISG(IISG)%NCLC-1 DO J=ISD(I)%IREF,ISD(I)%IREF+ISD(I)%N-1 N =N+1 IDATES(N)=DATISD(J)%IDATE ENDDO ENDDO !## structures DO I=ISG(IISG)%ISTW,ISG(IISG)%ISTW+ISG(IISG)%NSTW-1 DO J=IST(I)%IREF,IST(I)%IREF+IST(I)%N-1 N =N+1 IDATES(N)=DATIST(J)%IDATE ENDDO ENDDO ENDDO !## sort them CALL SHELLSORT_INT(N,IDATES) !## remove doubles I=1 J=1 DO I=I+1 IF(I.EQ.N)EXIT IF(IDATES(I).NE.IDATES(I-1))THEN J =J+1 IDATES(J)=IDATES(I) ENDIF END DO N=J IF(ALLOCATED(CDATES))DEALLOCATE(CDATES); ALLOCATE(CDATES(N)) DO I=1,N; WRITE(CDATES(I),'(I8)') IDATES(I); ENDDO CALL WDIALOGPUTMENU(ID,CDATES,N,1) ENDIF CALL UTL_MESSAGEHANDLE(1) END SUBROUTINE ISGPROFILE_GETDATES !###==================================================================== SUBROUTINE ISGPROFILE_GETDATA() !###==================================================================== IMPLICIT NONE INTEGER :: IISG,JJSG,I,J,K,IDATE,IBOT,ITOP,IORDER,ILAST,IDWNS REAL :: H1,H2,DIST,TDIST CHARACTER(LEN=8) :: TMP_DATE INTEGER,DIMENSION(:,:),ALLOCATABLE :: ICON LOGICAL :: LEX IF(SUM(ISG%ILIST).LE.0)THEN CALL IGRCOLOURN(WRGB(255,255,255)); CALL IGRAREA(0.0,0.0,1.0,1.0); CALL IGRAREACLEAR() RETURN ENDIF CALL UTL_MESSAGEHANDLE(0); CALL WINDOWSELECT(0); CALL WINDOWOUTSTATUSBAR(4,'Getting data ...') CALL WDIALOGGETMENU(IDF_MENU2,IDATE) TMP_DATE=CDATES(IDATE); READ(TMP_DATE,'(I8)') IDATE !## order segments - if possible IORDER=0; IF(ISFR.EQ.1)CALL WDIALOGGETCHECKBOX(IDF_CHECK6,IORDER) CALL WDIALOGFIELDSTATE(IDF_CHECK1,0) CALL WDIALOGFIELDSTATE(IDF_CHECK2,0) CALL WDIALOGFIELDSTATE(IDF_CHECK3,0) CALL WDIALOGFIELDSTATE(IDF_CHECK4,0) !## get column used for cross-section CALL WDIALOGGETMENU(IDF_MENU3,IBOT) CALL WDIALOGGETCHECKBOX(IDF_CHECK5,ITOP) IF(ITOP.EQ.1)CALL WDIALOGGETMENU(IDF_MENU4,ITOP) CALL ISGPROFILE_DEALLOCATE() NTOP=0; NBOT=0; NCRS=0; NQHR=0; NSTW=0 DO IISG=1,NISG IF(ISG(IISG)%ILIST.EQ.0)CYCLE IF(ISG(IISG)%NCLC.GT.0)THEN IF(WINFODIALOGFIELD(IDF_CHECK1,FIELDSTATE).EQ.0)CALL WDIALOGFIELDSTATE(IDF_CHECK1,1) ENDIF IF(ISG(IISG)%NSTW.GT.0)THEN IF(WINFODIALOGFIELD(IDF_CHECK2,FIELDSTATE).EQ.0)CALL WDIALOGFIELDSTATE(IDF_CHECK2,1) ENDIF IF(ISG(IISG)%NCRS.GT.0)THEN IF(WINFODIALOGFIELD(IDF_CHECK3,FIELDSTATE).EQ.0)CALL WDIALOGFIELDSTATE(IDF_CHECK3,1) ENDIF IF(ISG(IISG)%NQHR.GT.0)THEN IF(WINFODIALOGFIELD(IDF_CHECK4,FIELDSTATE).EQ.0)CALL WDIALOGFIELDSTATE(IDF_CHECK4,1) ENDIF NTOP=NTOP+ISG(IISG)%NCLC+2*ISG(IISG)%NSTW+2 NBOT=NBOT+ISG(IISG)%NCLC+2 NCRS=NCRS+ISG(IISG)%NCRS NQHR=NQHR+ISG(IISG)%NQHR NSTW=NSTW+ISG(IISG)%NSTW ENDDO IF(IORDER.EQ.1)THEN ALLOCATE(ICON(NISG,3)); ICON=-999; ILAST=0 DO IISG=1,NISG IF(ISG(IISG)%ILIST.EQ.0)CYCLE !## last calculation point, contains connection I=ISG(IISG)%ICLC+1; J=ISD(I)%IREF !## use only first of date-list I=ISD(J)%IREF; IDWNS=DATISD(I)%DWNS !## connected downstreams IF(IDWNS.GT.0)THEN !## to segment ICON(IISG,2) =IDWNS !## from segment ICON(IDWNS,3)=IISG !## take the last one to trace back ILAST=IISG ENDIF END DO LEX=.FALSE.; IF(ILAST.NE.0)THEN !## trace back IISG=ICON(ILAST,3); IF(IISG.GT.0)LEX=.TRUE. ENDIF IF(LEX)THEN !## search the one that does not redirect to another one DO; JJSG=ICON(IISG,3); IF(JJSG.LE.0)EXIT; IISG=JJSG; ENDDO !## trace forward and fill in list I=0; DO; I=I+1; ICON(I,1)=IISG; JJSG=ICON(IISG,2); IF(JJSG.LE.0)EXIT; IISG=JJSG; ENDDO ELSE !## not possible DEALLOCATE(ICON); CALL UTL_MESSAGEHANDLE(1) CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMOD cannot find any order in the selected segment, are they connected?','Warning') RETURN ENDIF ELSE ALLOCATE(ICON(NISG,1)); DO IISG=1,NISG; ICON(IISG,1)=IISG; ENDDO ENDIF ALLOCATE(XTOP(NTOP),YTOP(NTOP),XBOT(NBOT),YBOT(NBOT)) ALLOCATE(XSTW(NSTW),XCRS(NCRS),XQHR(NQHR)) NTOP=0; NSTW=0; NCRS=0; NQHR=0; NBOT=0; TDIST=0.0; IISG=0 DO JJSG=1,NISG !## segment number IISG=ICON(JJSG,1) !## skip inappropriate isg-element IF(IISG.LE.0)CYCLE !## skip if not selected IF(ISG(IISG)%ILIST.EQ.0)CYCLE !## calc. points DO I=ISG(IISG)%ICLC,ISG(IISG)%ICLC+ISG(IISG)%NCLC-1 DO K=ISD(I)%IREF,ISD(I)%IREF+ISD(I)%N-1 IF(DATISD(K)%IDATE.GE.IDATE)EXIT END DO IF(K.LE.ISD(I)%IREF+ISD(I)%N-1)THEN IF(ITOP.GT.0)THEN NTOP=NTOP+1 XTOP(NTOP)=ISD(I)%DIST+TDIST YTOP(NTOP)=ISGPROFILE_GETVARIABLE(ITOP,K) IF(I.EQ.ISG(IISG)%ICLC) H1=YTOP(NTOP) IF(I.EQ.ISG(IISG)%ICLC+ISG(IISG)%NCLC-1)H2=YTOP(NTOP) ENDIF NBOT=NBOT+1 XBOT(NBOT)=ISD(I)%DIST+TDIST YBOT(NBOT)=ISGPROFILE_GETVARIABLE(IBOT,K) IF(I.EQ.ISG(IISG)%ICLC+ISG(IISG)%NCLC-1)DIST=ISD(I)%DIST ENDIF END DO !## structures DO I=ISG(IISG)%ISTW,ISG(IISG)%ISTW+ISG(IISG)%NSTW-1 DO K=IST(I)%IREF,IST(I)%IREF+IST(I)%N-1 IF(DATIST(K)%IDATE.GE.IDATE)EXIT END DO IF(K.LE.IST(I)%IREF+IST(I)%N-1)THEN NSTW=NSTW+1 XSTW(NSTW)=IST(I)%DIST+TDIST IF(ISFR.EQ.0.AND.ITOP.GT.0)THEN NTOP=NTOP+1 XTOP(NTOP)=IST(I)%DIST+TDIST YTOP(NTOP)=DATIST(K)%WLVL_UP NTOP=NTOP+1 !## depends on flow-direction how to put the weir IF(H1.LT.H2)THEN XTOP(NTOP)=IST(I)%DIST-0.01+TDIST ELSE XTOP(NTOP)=IST(I)%DIST+0.01+TDIST ENDIF YTOP(NTOP)=DATIST(K)%WLVL_DOWN ENDIF ENDIF END DO !## cross-sections DO I=ISG(IISG)%ICRS,ISG(IISG)%ICRS+ISG(IISG)%NCRS-1 NCRS=NCRS+1 XCRS(NCRS)=ISC(I)%DIST+TDIST END DO !## qh-relationships DO I=ISG(IISG)%IQHR,ISG(IISG)%IQHR+ISG(IISG)%NQHR-1 NQHR=NQHR+1 XQHR(NQHR)=ISQ(I)%DIST+TDIST END DO !## increase total distance to add other segments appropriate TDIST=TDIST+DIST ENDDO !## sort on x IF(ITOP.GT.0)CALL UTL_QKSORT2(XTOP,YTOP,SIZE(XTOP),NTOP) CALL UTL_QKSORT2(XBOT,YBOT,SIZE(XBOT),NBOT) PROFXMIN=XBOT(1) PROFXMAX=XBOT(NBOT) PROFYMAX=-10.0E10 PROFYMIN= 10.0E10 PROFYMIN=MIN(PROFYMIN,MINVAL(YBOT(1:NBOT))) PROFYMAX=MAX(PROFYMAX,MAXVAL(YBOT(1:NBOT))) IF(ITOP.GT.0)THEN PROFYMIN=MIN(PROFYMIN,MINVAL(YTOP(1:NTOP))) PROFYMAX=MAX(PROFYMAX,MAXVAL(YTOP(1:NTOP))) ENDIF !## extent polygons for each attribute IF(ITOP.GT.0)THEN NTOP=NTOP+1 XTOP(NTOP)=PROFXMAX YTOP(NTOP)=PROFYMIN NTOP=NTOP+1 XTOP(NTOP)=PROFXMIN YTOP(NTOP)=PROFYMIN ENDIF NBOT=NBOT+1 XBOT(NBOT)=PROFXMAX YBOT(NBOT)=PROFYMIN NBOT=NBOT+1 XBOT(NBOT)=PROFXMIN YBOT(NBOT)=PROFYMIN DEALLOCATE(ICON) CALL UTL_MESSAGEHANDLE(1); CALL WINDOWSELECT(0); CALL WINDOWOUTSTATUSBAR(4,'') END SUBROUTINE ISGPROFILE_GETDATA !###==================================================================== REAL FUNCTION ISGPROFILE_GETVARIABLE(ITB,IIN) !###==================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ITB,IIN IF(ISFR.EQ.0)THEN SELECT CASE (ITB) CASE (1); ISGPROFILE_GETVARIABLE=DATISD(IIN)%WLVL CASE (2); ISGPROFILE_GETVARIABLE=DATISD(IIN)%BTML CASE (3); ISGPROFILE_GETVARIABLE=DATISD(IIN)%RESIS CASE (4); ISGPROFILE_GETVARIABLE=DATISD(IIN)%INFF END SELECT ELSE SELECT CASE (ITB) CASE (1); ISGPROFILE_GETVARIABLE=DATISD(IIN)%WLVL CASE (2); ISGPROFILE_GETVARIABLE=DATISD(IIN)%BTML CASE (3); ISGPROFILE_GETVARIABLE=DATISD(IIN)%WIDTH CASE (4); ISGPROFILE_GETVARIABLE=DATISD(IIN)%THCK CASE (5); ISGPROFILE_GETVARIABLE=DATISD(IIN)%HCND CASE (6); ISGPROFILE_GETVARIABLE=DATISD(IIN)%UPSG CASE (7); ISGPROFILE_GETVARIABLE=DATISD(IIN)%DWNS CASE (8); ISGPROFILE_GETVARIABLE=DATISD(IIN)%ICLC CASE (9); ISGPROFILE_GETVARIABLE=DATISD(IIN)%IPRI CASE (10); ISGPROFILE_GETVARIABLE=DATISD(IIN)%QFLW CASE (11); ISGPROFILE_GETVARIABLE=DATISD(IIN)%QROF CASE (12); ISGPROFILE_GETVARIABLE=DATISD(IIN)%PPTSW CASE (13); ISGPROFILE_GETVARIABLE=DATISD(IIN)%ETSW END SELECT ENDIF END FUNCTION ISGPROFILE_GETVARIABLE !###==================================================================== SUBROUTINE ISGPROFILE_PLOT() !###==================================================================== IMPLICIT NONE INTEGER,DIMENSION(4) :: ICHECK REAL :: DX,DY,YMIN IF(.NOT.ALLOCATED(XTOP))RETURN CALL IGRSELECT(DRAWFIELD,IDF_PICTURE1) CALL IGRFILLPATTERN(SOLID) CALL IGRCOLOURN(WRGB(255,255,255)) CALL IGRAREA(0.0,0.0,1.0,1.0); CALL IGRAREACLEAR() !## create axes CALL ISGATTRIBUTESPLOT_AXES(PROFXMIN,PROFYMIN,PROFXMAX,PROFYMAX,.FALSE.,'Distance (m)','Altitude (m)') ICHECK=0 IF(WINFODIALOGFIELD(IDF_CHECK1,FIELDSTATE).EQ.1)CALL WDIALOGGETCHECKBOX(IDF_CHECK1,ICHECK(1)) IF(WINFODIALOGFIELD(IDF_CHECK2,FIELDSTATE).EQ.1)CALL WDIALOGGETCHECKBOX(IDF_CHECK2,ICHECK(3)) IF(WINFODIALOGFIELD(IDF_CHECK3,FIELDSTATE).EQ.1)CALL WDIALOGGETCHECKBOX(IDF_CHECK3,ICHECK(2)) IF(WINFODIALOGFIELD(IDF_CHECK4,FIELDSTATE).EQ.1)CALL WDIALOGGETCHECKBOX(IDF_CHECK4,ICHECK(4)) CALL IGRFILLPATTERN(SOLID) !## drawing bottom second CALL IGRCOLOURN(ACLR) CALL IGRPOLYGONCOMPLEX(XBOT,YBOT,NBOT) !## drawing second parameter IF(NTOP.GT.0)THEN CALL IGRCOLOURN(BCLR) CALL IGRPOLYGONCOMPLEX(XTOP,YTOP,NTOP) ENDIF !## start plotting waterlevels incl. structures DX=(PROFXMAX-PROFXMIN)/200.0 DY=(PROFYMAX-PROFYMIN)/50.0 YMIN=PROFYMIN+DY CALL ISGPROFILE_PLOTFEATURE(XBOT,1,ICLRSD,ICHECK(1),YMIN,DX,DY) !## waterlevel - filled+vert.lines CALL ISGPROFILE_PLOTFEATURE(XCRS,2,ICLRSC,ICHECK(2),YMIN,DX,DY) !## cross-sections - vert.lines CALL ISGPROFILE_PLOTFEATURE(XSTW,3,ICLRST,ICHECK(3),YMIN,DX,DY) !## structures - vert.lines CALL ISGPROFILE_PLOTFEATURE(XQHR,4,ICLRQH,ICHECK(4),YMIN,DX,DY) !## qh-relations - vert.lines END SUBROUTINE ISGPROFILE_PLOT !###==================================================================== SUBROUTINE ISGPROFILE_PLOTFEATURE(X,ISHAPE,ICLR,ICHK,YMIN,DX,DY) !## waterlevel - filled+vert.lines !###==================================================================== IMPLICIT NONE INTEGER :: ICLR,ICHK,ISHAPE REAL,INTENT(INOUT) :: YMIN REAL,INTENT(IN) :: DX,DY REAL,INTENT(IN),DIMENSION(:) :: X INTEGER :: I IF(ICHK.EQ.0)RETURN CALL IGRCOLOURN(WRGB(0,0,0)) CALL IGRJOIN(PROFXMIN,YMIN,PROFXMAX,YMIN) CALL IGRCOLOURN(ICLR) DO I=1,SIZE(X) CALL ISGPLOTSHAPE(ISHAPE,X(I),YMIN,DX,DY) ENDDO YMIN=YMIN+DY END SUBROUTINE ISGPROFILE_PLOTFEATURE !###==================================================================== SUBROUTINE ISGPROFILE_DEALLOCATE() !###==================================================================== IMPLICIT NONE IF(ALLOCATED(XTOP))DEALLOCATE(XTOP); IF(ALLOCATED(YTOP))DEALLOCATE(YTOP) IF(ALLOCATED(XBOT))DEALLOCATE(XBOT); IF(ALLOCATED(YBOT))DEALLOCATE(YBOT) IF(ALLOCATED(XCRS))DEALLOCATE(XCRS); IF(ALLOCATED(XQHR))DEALLOCATE(XQHR) IF(ALLOCATED(XSTW))DEALLOCATE(XSTW) END SUBROUTINE ISGPROFILE_DEALLOCATE !###==================================================================== SUBROUTINE ISGFIND() !###==================================================================== IMPLICIT NONE TYPE(WIN_MESSAGE) :: MESSAGE INTEGER :: ITYPE,I INTEGER,ALLOCATABLE,DIMENSION(:) :: ILIST,JLIST CHARACTER(LEN=50),ALLOCATABLE,DIMENSION(:) :: SNAME IF(ALLOCATED(ILIST))DEALLOCATE(ILIST) IF(ALLOCATED(JLIST))DEALLOCATE(JLIST) IF(ALLOCATED(SNAME))DEALLOCATE(SNAME) ALLOCATE(ILIST(NISG),SNAME(NISG),JLIST(NISG)); ILIST=0; JLIST=0; SNAME='' CALL WDIALOGLOAD(ID_DISGFIND,ID_DISGFIND) CALL ISGFINDFIELDS(); CALL WDIALOGFIELDSTATE(IDOK,0) CALL WDIALOGSHOW(-1,-1,0,3) DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE (FIELDCHANGED) SELECT CASE (MESSAGE%VALUE1) CASE (IDF_RADIO1,IDF_RADIO2,IDF_CHECK1,IDF_CHECK2,IDF_CHECK3,IDF_CHECK4,IDF_CHECK5) CALL ISGFINDFIELDS() END SELECT CASE (PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (IDCANCEL) EXIT CASE (ID_GETTHEM) CALL ISGFINDIT(ILIST,JLIST,SNAME) CASE (IDOK) CALL WDIALOGGETMENU(IDF_MENU1,JLIST) EXIT CASE (IDHELP) CALL IMODGETHELP('4.4.3.3','MMO.IGO.IE.Search') END SELECT END SELECT ENDDO CALL WDIALOGSELECT(ID_DISGFIND); CALL WDIALOGUNLOAD() IF(MESSAGE%VALUE1.EQ.IDOK)THEN ISG%ILIST=0 DO I=1,NISG; IF(ILIST(I).GT.0.AND.ILIST(I).LE.NISG)ISG(ILIST(I))%ILIST=1; END DO CALL WDIALOGSELECT(ID_DISGEDITTAB1) CALL WDIALOGPUTMENU(IDF_MENU1,ISG%SNAME,NISG,ISG%ILIST) CALL ISGFIELDS(); CALL IDFPLOTFAST(1) ENDIF IF(ALLOCATED(ILIST))DEALLOCATE(ILIST) IF(ALLOCATED(JLIST))DEALLOCATE(JLIST) IF(ALLOCATED(SNAME))DEALLOCATE(SNAME) END SUBROUTINE ISGFIND !###==================================================================== SUBROUTINE ISGFINDFIELDS() !###==================================================================== IMPLICIT NONE INTEGER,DIMENSION(5) :: IOPT INTEGER :: I CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,I) CALL WDIALOGFIELDSTATE(IDF_INTEGER1,I) I=I-1 CALL WDIALOGFIELDSTATE(IDF_GROUP2,I) CALL WDIALOGFIELDSTATE(IDF_CHECK1,I) CALL WDIALOGFIELDSTATE(IDF_CHECK2,I) CALL WDIALOGFIELDSTATE(IDF_CHECK3,I) CALL WDIALOGFIELDSTATE(IDF_CHECK4,I) CALL WDIALOGFIELDSTATE(IDF_CHECK5,I) IF(I.EQ.1)THEN CALL WDIALOGGETCHECKBOX(IDF_CHECK1,IOPT(1)) CALL WDIALOGGETCHECKBOX(IDF_CHECK2,IOPT(2)) CALL WDIALOGGETCHECKBOX(IDF_CHECK3,IOPT(3)) CALL WDIALOGGETCHECKBOX(IDF_CHECK4,IOPT(4)) CALL WDIALOGGETCHECKBOX(IDF_CHECK5,IOPT(5)) ELSE IOPT=1 ENDIF I=0; IF(SUM(IOPT).NE.0)I=1 CALL WDIALOGFIELDSTATE(ID_GETTHEM,I) END SUBROUTINE ISGFINDFIELDS !###==================================================================== SUBROUTINE ISGFINDIT(ILIST,JLIST,SNAME) !###==================================================================== IMPLICIT NONE INTEGER,INTENT(OUT),DIMENSION(NISG) :: ILIST,JLIST CHARACTER(LEN=*),INTENT(OUT),DIMENSION(NISG) :: SNAME INTEGER :: I,J,K,ICASE CHARACTER(LEN=30) :: STRING INTEGER,DIMENSION(5) :: IOPT LOGICAL :: LEX CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,I) IF(I.EQ.1)THEN CALL WDIALOGGETINTEGER(IDF_INTEGER1,J) IF(J.LE.NISG.AND.J.GT.0)THEN K=1; ILIST(K)=J; JLIST(K)=1; SNAME(K)=ISG(J)%SNAME ELSE CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You need to select a segment number between 1 and '//TRIM(ITOS(NISG)),'Warning') ENDIF ELSE CALL WDIALOGGETSTRING(IDF_STRING1,STRING) IF(TRIM(STRING).EQ.'')STRING='*' CALL WDIALOGGETCHECKBOX(IDF_CHECK1,IOPT(1)) CALL WDIALOGGETCHECKBOX(IDF_CHECK2,IOPT(2)) CALL WDIALOGGETCHECKBOX(IDF_CHECK3,IOPT(3)) CALL WDIALOGGETCHECKBOX(IDF_CHECK4,IOPT(4)) CALL WDIALOGGETCHECKBOX(IDF_CHECK5,IOPT(5)) CALL WDIALOGGETCHECKBOX(IDF_CHECK6,ICASE) ILIST=0 K =0 !## number of segments DO I=1,NISG LEX=.FALSE. !## segment names IF(IOPT(1).EQ.1)THEN IF(ICASE.EQ.0)THEN LEX=EQUALNAMES(TRIM(UTL_CAP(STRING,'U')),TRIM(UTL_CAP(ISG(I)%SNAME,'U'))) ELSEIF(ICASE.EQ.1)THEN LEX=EQUALNAMES(TRIM(STRING),TRIM(ISG(I)%SNAME)) ENDIF ENDIF !## calc.pnts IF(.NOT.LEX.AND.IOPT(2).EQ.1)THEN DO J=ISG(I)%ICLC,ISG(I)%ICLC+ISG(I)%NCLC-1 IF(ICASE.EQ.0)THEN LEX=EQUALNAMES(TRIM(UTL_CAP(STRING,'U')),TRIM(UTL_CAP(ISD(J)%CNAME,'U'))) ELSEIF(ICASE.EQ.1)THEN LEX=EQUALNAMES(TRIM(STRING),TRIM(ISD(J)%CNAME)) ENDIF IF(LEX)EXIT END DO ENDIF !## structures IF(.NOT.LEX.AND.IOPT(3).EQ.1)THEN DO J=ISG(I)%ISTW,ISG(I)%ISTW+ISG(I)%NSTW-1 IF(ICASE.EQ.0)THEN LEX=EQUALNAMES(TRIM(UTL_CAP(STRING,'U')),TRIM(UTL_CAP(IST(J)%CNAME,'U'))) ELSEIF(ICASE.EQ.1)THEN LEX=EQUALNAMES(TRIM(STRING),TRIM(IST(J)%CNAME)) ENDIF IF(LEX)EXIT ENDDO ENDIF !## cross-sections IF(.NOT.LEX.AND.IOPT(4).EQ.1)THEN DO J=ISG(I)%ICRS,ISG(I)%ICRS+ISG(I)%NCRS-1 IF(ICASE.EQ.0)THEN LEX=EQUALNAMES(TRIM(UTL_CAP(STRING,'U')),TRIM(UTL_CAP(ISC(J)%CNAME,'U'))) ELSEIF(ICASE.EQ.1)THEN LEX=EQUALNAMES(TRIM(STRING),TRIM(ISC(J)%CNAME)) ENDIF IF(LEX)EXIT END DO ENDIF !## qh-relationships IF(.NOT.LEX.AND.IOPT(5).EQ.1)THEN DO J=ISG(I)%IQHR,ISG(I)%IQHR+ISG(I)%NQHR-1 IF(ICASE.EQ.0)THEN LEX=EQUALNAMES(TRIM(UTL_CAP(STRING,'U')),TRIM(UTL_CAP(ISQ(J)%CNAME,'U'))) ELSEIF(ICASE.EQ.1)THEN LEX=EQUALNAMES(TRIM(STRING),TRIM(ISQ(J)%CNAME)) ENDIF IF(LEX)EXIT END DO ENDIF !## name found within current segment IF(LEX)THEN K =K+1 ILIST(K)=I JLIST(K)=1 SNAME(K)=ISG(I)%SNAME ENDIF END DO ENDIF IF(K.GT.0)THEN CALL WDIALOGFIELDSTATE(IDOK,1) CALL WDIALOGPUTMENU(IDF_MENU1,SNAME,K,JLIST) ELSE CALL WDIALOGFIELDSTATE(IDOK,0) CALL WDIALOGCLEARFIELD(IDF_MENU1) ENDIF CALL WDIALOGPUTSTRING(IDF_LABEL3,TRIM(ITOS(K))//' Segments Found') END SUBROUTINE ISGFINDIT !###==================================================================== SUBROUTINE ISGZOOMTO() !###==================================================================== IMPLICIT NONE INTEGER :: IS,I,J REAL :: MINX,MAXX,MINY,MAXY,X,Y CALL WDIALOGSELECT(ID_DISGEDITTAB1) CALL WDIALOGGETMENU(IDF_MENU1,ISG(1:NISG)%ILIST) IF(SUM(ISG(1:NISG)%ILIST).EQ.0)RETURN J=0 DO IS=1,NISG !#selected, get minx,maxx,miny,maxy IF(ISG(IS)%ILIST.EQ.1)THEN DO I=ISG(IS)%ISEG,ISG(IS)%ISEG+ISG(IS)%NSEG-1 J=J+1 IF(J.EQ.1)THEN MINX=ISP(I)%X MAXX=MINX MINY=ISP(I)%Y MAXY=MINY ELSE MINX=MIN(MINX,ISP(I)%X) MAXX=MAX(MAXX,ISP(I)%X) MINY=MIN(MINY,ISP(I)%Y) MAXY=MAX(MAXY,ISP(I)%Y) ENDIF ENDDO ENDIF END DO MPW%XMIN=MINX MPW%XMAX=MAXX MPW%YMIN=MINY MPW%YMAX=MAXY !#increase window to count for y-size! X =(MPW%XMAX-MPW%XMIN)/4.0 Y =(MPW%YMAX-MPW%YMIN)/4.0 MPW%XMAX=MPW%XMAX+X MPW%XMIN=MPW%XMIN-X MPW%YMAX=MPW%YMAX+Y MPW%YMIN=MPW%YMIN-Y CALL IDFPLOTFAST(1) END SUBROUTINE ISGZOOMTO !###==================================================================== SUBROUTINE ISGLEGENDINIT() !###==================================================================== IMPLICIT NONE INTEGER :: I CALL WDIALOGFIELDSTATE(ID_LEGEND,2) CALL WDIALOGLOAD(ID_DISGEDITLEGEND,ID_DISGEDITLEGEND) CALL WDIALOGPUTIMAGE(ID_LEGEND,ID_ICONLEGEND,1) CALL WDIALOGPUTIMAGE(ID_LEFT,ID_ICONLEFT,1) CALL WDIALOGPUTIMAGE(ID_FASTLEFT,ID_ICONTOTALLEFT,1) CALL WDIALOGPUTIMAGE(ID_RIGHT,ID_ICONRIGHT,1) CALL WDIALOGPUTIMAGE(ID_FASTRIGHT,ID_ICONTOTALRIGHT,1) CALL WDIALOGPUTIMAGE(ID_STOP,ID_ICONSTOP,1) CALL WDIALOGFIELDSTATE(ID_STOP,2) !## as element selected, set selection by default IF(SUM(ISG%ILIST).NE.0)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO5) !## get available dates in the isg file - select at least one segment to fill in the dialog I=0; IF(SUM(ISG%ILIST).EQ.0)THEN; ISG(1)%ILIST=1; I=1; ENDIF CALL ISGPROFILE_GETDATES(IDF_MENU2) IF(I.EQ.1)ISG%ILIST=0 IF(SIZE(CDATES).EQ.1)THEN CALL WDIALOGFIELDSTATE(ID_STOP,2) CALL WDIALOGFIELDSTATE(ID_LEFT,2) CALL WDIALOGFIELDSTATE(ID_FASTLEFT,2) CALL WDIALOGFIELDSTATE(ID_RIGHT,2) CALL WDIALOGFIELDSTATE(ID_FASTRIGHT,2) CALL WDIALOGFIELDSTATE(IDF_TRACKBAR1,2) ELSE I=MAX(1,SIZE(CDATES)/10) CALL WDIALOGRANGETRACKBAR(IDF_TRACKBAR1,1,SIZE(CDATES),I) CALL WDIALOGPUTTRACKBAR(IDF_TRACKBAR1,1) ENDIF IF(ALLOCATED(IDATES))DEALLOCATE(IDATES) IF(ALLOCATED(CDATES))DEALLOCATE(CDATES) IF(ISFR.EQ.0)CALL WDIALOGPUTMENU(IDF_MENU4,ISDLABELS(2:),SIZE(ISDLABELS)-1,1) IF(ISFR.EQ.1)CALL WDIALOGPUTMENU(IDF_MENU4,ISDLABELS(3:),SIZE(ISDLABELS)-2,1) CALL WDIALOGFIELDOPTIONS(IDF_INTEGER1,EDITFIELDCHANGED,ENABLED) CALL ISGLEGENDFILLLEGEND() CALL WDIALOGSHOW(0,0,0,2) CALL ISGLEGENDSHOW(1) CALL IDFPLOT(1) END SUBROUTINE ISGLEGENDINIT !###==================================================================== SUBROUTINE ISGLEGENDFILLLEGEND() !###==================================================================== IMPLICIT NONE INTEGER :: I,J,N REAL :: DR REAL,ALLOCATABLE,DIMENSION(:) :: DMAX,DMIN IF(ISFR.EQ.0)ALLOCATE(DMIN(SIZE(TATTRIB1)),DMAX(SIZE(TATTRIB1))) IF(ISFR.EQ.1)ALLOCATE(DMIN(SIZE(TATTRIB2)),DMAX(SIZE(TATTRIB2))) DMAX=-HUGE(1.0) DMIN= HUGE(1.0) !## fill in legend for each category for all DO I=1,SIZE(DATISD) IF(ISFR.EQ.0)THEN DMAX(1)=MAX(DMAX(1),DATISD(I)%WLVL) DMIN(1)=MIN(DMIN(1),DATISD(I)%WLVL) DMAX(2)=MAX(DMAX(2),DATISD(I)%BTML) DMIN(2)=MIN(DMIN(2),DATISD(I)%BTML) DMAX(3)=MAX(DMAX(3),DATISD(I)%RESIS) DMIN(3)=MIN(DMIN(3),DATISD(I)%RESIS) DMAX(4)=MAX(DMAX(4),DATISD(I)%INFF) DMIN(4)=MIN(DMIN(4),DATISD(I)%INFF) ELSEIF(ISFR.EQ.1)THEN DMAX(1) =MAX(DMAX(1),DATISD(I)%WLVL) DMIN(1) =MIN(DMIN(1),DATISD(I)%WLVL) DMAX(2) =MAX(DMAX(2),DATISD(I)%BTML) DMIN(2) =MIN(DMIN(2),DATISD(I)%BTML) DMAX(3) =MAX(DMAX(3),DATISD(I)%WIDTH) DMIN(3) =MIN(DMIN(3),DATISD(I)%WIDTH) DMAX(4) =MAX(DMAX(4),DATISD(I)%THCK) DMIN(4) =MIN(DMIN(4),DATISD(I)%THCK) DMAX(5) =MAX(DMAX(5),DATISD(I)%HCND) DMIN(5) =MIN(DMIN(5),DATISD(I)%HCND) DMAX(6) =MAX(DMAX(6),REAL(DATISD(I)%UPSG)) DMIN(6) =MIN(DMIN(6),REAL(DATISD(I)%UPSG)) DMAX(7) =MAX(DMAX(7),REAL(DATISD(I)%DWNS)) DMIN(7) =MIN(DMIN(7),REAL(DATISD(I)%DWNS)) DMAX(8) =MAX(DMAX(8),REAL(DATISD(I)%ICLC)) DMIN(8) =MIN(DMIN(8),REAL(DATISD(I)%ICLC)) DMAX(9) =MAX(DMAX(9),REAL(DATISD(I)%IPRI)) DMIN(9) =MIN(DMIN(9),REAL(DATISD(I)%IPRI)) DMAX(10)=MAX(DMAX(10),DATISD(I)%QFLW) DMIN(10)=MIN(DMIN(10),DATISD(I)%QFLW) DMAX(11)=MAX(DMAX(11),DATISD(I)%QROF) DMIN(11)=MIN(DMIN(11),DATISD(I)%QROF) DMAX(12)=MAX(DMAX(12),DATISD(I)%PPTSW) DMIN(12)=MIN(DMIN(12),DATISD(I)%PPTSW) DMAX(13)=MAX(DMAX(13),DATISD(I)%ETSW) DMIN(13)=MIN(DMIN(13),DATISD(I)%ETSW) ENDIF ENDDO !## skip date/time columns IF(ISFR.EQ.0)N=SIZE(DMIN)-1 IF(ISFR.EQ.1)N=SIZE(DMIN)-2 DO I=1,N !SIZE(DMIN) IF(DMIN(I).EQ.DMAX(I))THEN; DMIN(I)=DMIN(I)-1.0; DMAX(I)=DMAX(I)+1.0; ENDIF DR=(DMAX(I)-DMIN(I))/REAL(MXCLR+1) MP(IISGPLOT)%LEG%CLASS(0)=DMAX(I) DO J=1,MXCLR; MP(IISGPLOT)%LEG%CLASS(J)=MP(IISGPLOT)%LEG%CLASS(J-1)-DR; END DO MP(IISGPLOT)%LEG%NCLR=MXCLR !## apply default colours MP(IISGPLOT)%LEG%LEGTXT ='' !## default name of the legend file MP(IISGPLOT)%LEG%CGRAD =1 !## all checkboxes selected DO J=1,MXCGRAD; MP(IISGPLOT)%LEG%ICLRGRAD(J)=WRGB(CLR(J,1),CLR(J,2),CLR(J,3)); ENDDO CALL LEG_CREATE_COLORS(IISGPLOT) ISGLEG(I)=MP(IISGPLOT)%LEG ENDDO DEALLOCATE(DMAX,DMIN) END SUBROUTINE ISGLEGENDFILLLEGEND !###==================================================================== SUBROUTINE ISGLEGENDSHOW(ILEG) !###==================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ILEG INTEGER :: NC CALL WDIALOGSELECT(ID_DISGEDITLEGEND) CALL UTL_DEBUGLEVEL(0) CALL WDIALOGGETINTEGER(IDF_INTEGER1,NC) CALL UTL_DEBUGLEVEL(1) !## skip temporarily misread number of columns IF(NC.LE.0)RETURN CALL IGRSELECT(DRAWFIELD,IDF_PICTURE1) CALL IGRAREA (0.0,0.0,1.0,1.0) CALL IGRUNITS(0.0,0.0,1.0,1.0) CALL LEGPLOT_PLOT(ISGLEG(ILEG),NC) CALL IGRSELECT(DRAWWIN,MPW%IWIN) CALL IGRAREA(0.0,0.0,1.0,1.0) CALL IGRUNITS(MPW%XMIN,MPW%YMIN,MPW%XMAX,MPW%YMAX) END SUBROUTINE ISGLEGENDSHOW !###==================================================================== SUBROUTINE ISGLEGENDMAIN(ITYPE,MESSAGE) !###==================================================================== IMPLICIT NONE INTEGER,INTENT(INOUT) :: ITYPE TYPE(WIN_MESSAGE),INTENT(INOUT) :: MESSAGE INTEGER,DIMENSION(14) :: DID INTEGER :: I,J DATA DID/ID_FASTLEFT,ID_FASTRIGHT,ID_LEFT,ID_RIGHT,IDF_RADIO3,IDF_RADIO5,IDF_MENU2, & IDF_MENU4,IDF_MENU5,IDF_MENU6,IDHELP,IDCANCEL,ID_LEGEND,IDF_TRACKBAR1/ CALL WDIALOGSELECT(ID_DISGEDITLEGEND) SELECT CASE (ITYPE) CASE (EXPOSE,RESIZE) CALL WDIALOGGETMENU(IDF_MENU4,I) CALL ISGLEGENDSHOW(I) CASE (PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (IDHELP) CASE (IDCANCEL) CALL WDIALOGUNLOAD() CALL WDIALOGSELECT(ID_DISGEDITTAB1) CALL WDIALOGFIELDSTATE(ID_LEGEND,1) CALL IDFPLOT(1) CASE (ID_FASTLEFT) CALL WDIALOGPUTOPTION(IDF_MENU2,1) CALL WDIALOGPUTTRACKBAR(IDF_TRACKBAR1,1) CALL IDFPLOT(1) CASE (ID_FASTRIGHT) I=WINFODIALOGFIELD(IDF_TRACKBAR1,FIELDTRACKMAX) CALL WDIALOGPUTTRACKBAR(IDF_TRACKBAR1,I) CALL WDIALOGPUTOPTION(IDF_MENU2,I) CALL IDFPLOT(1) CASE (ID_LEFT,ID_RIGHT) CALL WDIALOGFIELDSTATE(ID_STOP,1) DO I=1,SIZE(DID); CALL WDIALOGFIELDSTATE(DID(I),2); ENDDO J=WINFODIALOGFIELD(IDF_TRACKBAR1,FIELDTRACKMAX) DO CALL WMESSAGEPEEK(ITYPE,MESSAGE) IF(ITYPE.EQ.PUSHBUTTON.AND.MESSAGE%VALUE1.EQ.ID_STOP)EXIT CALL WDIALOGGETMENU(IDF_MENU2,I); I=I+1; IF(I.GT.J)I=1 CALL WDIALOGPUTOPTION(IDF_MENU2,I) CALL WDIALOGPUTTRACKBAR(IDF_TRACKBAR1,I) !## call idfplot to refresh plot CALL ISGPLOT_LEGENDLINES(MPW%XMAX,MPW%YMIN,MPW%XMAX,MPW%YMAX) ENDDO CALL WDIALOGFIELDSTATE(ID_STOP,2) DO I=1,SIZE(DID); CALL WDIALOGFIELDSTATE(DID(I),1); ENDDO !## change legend CASE (ID_LEGEND) CALL WDIALOGGETMENU(IDF_MENU4,I) MP(IISGPLOT)%LEG=ISGLEG(I); CALL LEG_MAIN(IISGPLOT); ISGLEG(I)=MP(IISGPLOT)%LEG; CALL ISGLEGENDSHOW(I) END SELECT CASE (FIELDCHANGED) SELECT CASE (MESSAGE%VALUE2) CASE (IDF_INTEGER1) CALL WDIALOGGETMENU(IDF_MENU4,I) CALL ISGLEGENDSHOW(I) CASE (IDF_MENU2) IF(MESSAGE%VALUE1.EQ.MESSAGE%VALUE2)THEN CALL WDIALOGGETMENU(IDF_MENU2,I) CALL WDIALOGPUTTRACKBAR(IDF_TRACKBAR1,I) CALL IDFPLOT(1) ENDIF CASE (IDF_MENU4,IDF_MENU5,IDF_MENU6,IDF_RADIO3,IDF_RADIO5) IF(MESSAGE%VALUE1.EQ.MESSAGE%VALUE2)THEN IF(MESSAGE%VALUE1.EQ.IDF_MENU4)THEN CALL WDIALOGGETMENU(IDF_MENU4,I); CALL ISGLEGENDSHOW(I) ENDIF CALL IDFPLOT(1) ENDIF CASE (IDF_TRACKBAR1) IF(MESSAGE%VALUE1.EQ.MESSAGE%VALUE2)THEN !## get trackbar position CALL WDIALOGGETTRACKBAR(IDF_TRACKBAR1,I) CALL WDIALOGPUTOPTION(IDF_MENU2,I) CALL IDFPLOT(1) ENDIF END SELECT END SELECT END SUBROUTINE ISGLEGENDMAIN !###==================================================================== SUBROUTINE ISGGRIDMAIN() !###==================================================================== IMPLICIT NONE TYPE(WIN_MESSAGE) :: MESSAGE INTEGER :: ITYPE LOGICAL :: LOKAY CALL WDIALOGLOAD(ID_DISGEDITGRID,ID_DISGEDITGRID) CALL WDIALOGTITLE('ISG Rasterize') ! CALL ISGPROFILE_GETDATES() CALL WDIALOGPUTMENU(IDF_MENU1,CDATE,12,4) CALL WDIALOGPUTMENU(IDF_MENU2,CDATE,12,3) CALL WDIALOGPUTINTEGER(IDF_INTEGER1,14) CALL WDIALOGPUTINTEGER(IDF_INTEGER2,28) CALL WDIALOGPUTINTEGER(IDF_INTEGER3,1996) CALL WDIALOGPUTINTEGER(IDF_INTEGER4,2004) CALL WDIALOGPUTREAL(IDF_REAL1,25.0,'(F10.2)') CALL WDIALOGPUTREAL(IDF_REAL2,0.1,'(F10.2)') CALL WDIALOGSPINNERSTEP(IDF_REAL2,0.1,1.0) CALL WDIALOGPUTSTRING(IDF_LABEL2,'Minimal Waterdepth (m). Only to be used for the computation of the conductance.') CALL UTL_FILLDATES(IDF_INTEGER3,IDF_MENU1,IDF_INTEGER1) CALL UTL_FILLDATES(IDF_INTEGER4,IDF_MENU2,IDF_INTEGER2) IF(SUM(ISG%NSTW).EQ.0)CALL WDIALOGFIELDSTATE(IDF_CHECK1,0) !## not allowed to compute weirs CALL ISGGRIDFIELDS() CALL WDIALOGSELECT(ID_DISGEDITTAB1) CALL WDIALOGGETMENU(IDF_MENU1,ISG(1:NISG)%ILIST) CALL WDIALOGSELECT(ID_DISGEDITGRID) IF(SUM(ISG(1:NISG)%ILIST).EQ.0)THEN CALL WDIALOGFIELDSTATE(IDF_RADIO5,0) ELSE CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO5) ENDIF CALL WDIALOGSHOW(0,0,0,2) DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE(FIELDCHANGED) SELECT CASE (MESSAGE%VALUE2) CASE (IDF_RADIO1,IDF_RADIO2,IDF_CHECK1) CALL ISGGRIDFIELDS() CASE (IDF_INTEGER2,IDF_MENU1,IDF_INTEGER1, & IDF_INTEGER4,IDF_MENU2,IDF_INTEGER3) CALL UTL_FILLDATES(IDF_INTEGER3,IDF_MENU1,IDF_INTEGER1) CALL UTL_FILLDATES(IDF_INTEGER4,IDF_MENU2,IDF_INTEGER2) END SELECT CASE(PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (IDOK) CALL ISGGRIDSTART(LOKAY) IF(LOKAY)EXIT CASE (IDCANCEL) EXIT CASE (IDHELP) CALL IMODGETHELP('4.4.3.5','MMO.IGO.IE.Rast') END SELECT END SELECT ENDDO CALL WDIALOGSELECT(ID_DISGEDITGRID) CALL WDIALOGUNLOAD() END SUBROUTINE ISGGRIDMAIN !###====================================================================== SUBROUTINE ISGGRIDSTART(LOKAY) !###====================================================================== IMPLICIT NONE TYPE(GRIDISGOBJ) :: GRIDISG TYPE(WIN_MESSAGE) :: MESSAGE LOGICAL,INTENT(OUT) :: LOKAY INTEGER :: I,J,K,NROW,NCOL,ITYPE,NLAY INTEGER,DIMENSION(11) :: ID DATA ID/IDF_LABEL1 ,IDF_LABEL3 ,IDF_LABEL5 ,IDF_LABEL7 ,IDF_LABEL9,IDF_LABEL11,IDF_LABEL13, & IDF_LABEL23,IDF_LABEL15,IDF_LABEL17,IDF_LABEL19/ REAL(KIND=8) :: IRECDBL TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: TOP,BOT,KHV,BND LOKAY=.FALSE. CALL WDIALOGUNDEFINED(0) CALL WDIALOGSELECT(ID_DISGEDITGRID) CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,GRIDISG%ISTEADY) CALL WDIALOGGETRADIOBUTTON(IDF_RADIO3,GRIDISG%IDIM) CALL WDIALOGGETREAL(IDF_REAL1,GRIDISG%CS) IF(GRIDISG%CS.LE.0.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You should give a cellsize greater dan 0.0!','Error'); RETURN ENDIF IF(GRIDISG%ISTEADY.EQ.2)THEN CALL WDIALOGGETINTEGER(IDF_INTEGER1,I); CALL WDIALOGGETINTEGER(IDF_INTEGER3,J); CALL WDIALOGGETMENU(IDF_MENU1,K) GRIDISG%SDATE=J*10000+K*100+I CALL WDIALOGGETINTEGER(IDF_INTEGER2,I); CALL WDIALOGGETINTEGER(IDF_INTEGER4,J); CALL WDIALOGGETMENU(IDF_MENU2,K) GRIDISG%EDATE=J*10000+K*100+I IF(GRIDISG%SDATE.GT.GRIDISG%EDATE)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You should specify the startdate to be earlier than/equal to the enddate',& 'Error'); RETURN ENDIF GRIDISG%STIME=INT(GRIDISG%SDATE,8)*1000000; GRIDISG%ETIME=INT(GRIDISG%EDATE,8)*1000000; GRIDISG%DTIME=INT(0,8) ENDIF CALL WDIALOGGETREAL(IDF_REAL2,GRIDISG%MINDEPTH) CALL WDIALOGGETREAL(IDF_REAL3,GRIDISG%NODATA) CALL WDIALOGGETREAL(IDF_REAL4,GRIDISG%MAXWIDTH) CALL WDIALOGGETSTRING(IDF_STRING1,GRIDISG%POSTFIX) CALL WDIALOGGETCHECKBOX(IDF_CHECK1,GRIDISG%ICDIST) CALL WDIALOGGETRADIOBUTTON(IDF_RADIO6,GRIDISG%IAVERAGE) CALL WDIALOGLOAD(ID_DISGEDITGRIDINFO,ID_DISGEDITGRIDINFO) CALL WDIALOGTITLE('ISG Rasterize Info') DO I=1,SIZE(ID); CALL WDIALOGPUTSTRING(ID(I),TRIM(FNAME(I))//TRIM(GRIDISG%POSTFIX)//'.IDF'); END DO IF(GRIDISG%ICDIST.EQ.0)THEN DO I=9,SIZE(ID); CALL WDIALOGFIELDSTATE(ID(I),3); END DO CALL WDIALOGFIELDSTATE(IDF_LABEL16,3) CALL WDIALOGFIELDSTATE(IDF_LABEL18,3) CALL WDIALOGFIELDSTATE(IDF_LABEL21,3) ELSE CALL WDIALOGPUTSTRING(IDF_LABEL2,'Stages based upon linear interpolation of waterlevels within calculation points. '// & 'These will contain the effects of structures as well !') ENDIF IF(GRIDISG%ISTEADY.EQ.1)CALL WDIALOGPUTSTRING(IDF_LABEL22,'Attribute values will be computed as MEAN value over all periods '// & 'that EXIST with data within given date.') IF(GRIDISG%ISTEADY.EQ.2)CALL WDIALOGPUTSTRING(IDF_LABEL22,'Attribute values will be computed as MEDIAN values between the periods '// & TRIM(ITOS(GRIDISG%SDATE))//' and '//TRIM(ITOS(GRIDISG%EDATE))) CALL ISG2GRIDGETDIMENSION(GRIDISG%IDIM,GRIDISG%XMIN,GRIDISG%YMIN,GRIDISG%XMAX,GRIDISG%YMAX,NROW,NCOL,GRIDISG%CS) CALL WDIALOGPUTREAL(IDF_REAL1,GRIDISG%XMIN,'(F10.2)'); CALL WDIALOGPUTREAL(IDF_REAL2,GRIDISG%XMAX,'(F10.2)') CALL WDIALOGPUTREAL(IDF_REAL3,GRIDISG%YMIN,'(F10.2)'); CALL WDIALOGPUTREAL(IDF_REAL4,GRIDISG%YMAX,'(F10.2)') CALL WDIALOGPUTINTEGER(IDF_INTEGER1,NCOL); CALL WDIALOGPUTINTEGER(IDF_INTEGER2,NROW) IRECDBL=1.0E3*((DBLE(NROW)*DBLE(NCOL)*4.0D0)/2.0D0**30) CALL WDIALOGPUTREAL(IDF_INTEGER3,REAL(IRECDBL)) CALL WDIALOGPUTIMAGE(ID_CALC,ID_ICONCALC,1) CALL WDIALOGSHOW(-1,-1,0,3) DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE (PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (ID_CALC) CALL WDIALOGGETREAL(IDF_REAL1,GRIDISG%XMIN); CALL WDIALOGGETREAL(IDF_REAL2,GRIDISG%XMAX) CALL WDIALOGGETREAL(IDF_REAL3,GRIDISG%YMIN); CALL WDIALOGGETREAL(IDF_REAL4,GRIDISG%YMAX) CALL UTL_IDFSNAPTOGRID(GRIDISG%XMIN,GRIDISG%XMAX,GRIDISG%YMIN,GRIDISG%YMAX,GRIDISG%CS,NCOL,NROW) CALL WDIALOGPUTREAL(IDF_REAL1,GRIDISG%XMIN,'(F10.2)'); CALL WDIALOGPUTREAL(IDF_REAL2,GRIDISG%XMAX,'(F10.2)') CALL WDIALOGPUTREAL(IDF_REAL3,GRIDISG%YMIN,'(F10.2)'); CALL WDIALOGPUTREAL(IDF_REAL4,GRIDISG%YMAX,'(F10.2)') CALL WDIALOGPUTINTEGER(IDF_INTEGER1,NCOL); CALL WDIALOGPUTINTEGER(IDF_INTEGER2,NROW) IRECDBL=1.0E3*((DBLE(NROW)*DBLE(NCOL)*4.0D0)/2.0D0**30) CALL WDIALOGPUTREAL(IDF_INTEGER3,REAL(IRECDBL)) CASE (IDCANCEL,IDOK) EXIT END SELECT END SELECT ENDDO CALL WDIALOGGETREAL(IDF_REAL1,GRIDISG%XMIN); CALL WDIALOGGETREAL(IDF_REAL2,GRIDISG%XMAX) CALL WDIALOGGETREAL(IDF_REAL3,GRIDISG%YMIN); CALL WDIALOGGETREAL(IDF_REAL4,GRIDISG%YMAX) CALL UTL_IDFSNAPTOGRID(GRIDISG%XMIN,GRIDISG%XMAX,GRIDISG%YMIN,GRIDISG%YMAX,GRIDISG%CS,NCOL,NROW) CALL WDIALOGUNLOAD() IF(MESSAGE%VALUE1.EQ.IDCANCEL)RETURN CALL UTL_MESSAGEHANDLE(0) CALL WINDOWSELECT(0) GRIDISG%ISIMGRO=0 GRIDISG%DDATE=0 GRIDISG%WDEPTH=0.0 GRIDISG%ROOT=TRIM(PREFVAL(1))//'\TMP' GRIDISG%IDIM=-1*GRIDISG%IDIM MPW%XMIN=GRIDISG%XMIN; MPW%XMAX=GRIDISG%XMAX MPW%YMIN=GRIDISG%YMIN; MPW%YMAX=GRIDISG%YMAX NLAY=1; ALLOCATE(TOP(NLAY),BOT(NLAY),KHV(NLAY),BND(NLAY)) DO I=1,NLAY; CALL IDFNULLIFY(TOP(I)); ENDDO DO I=1,NLAY; CALL IDFNULLIFY(BOT(I)); ENDDO DO I=1,NLAY; CALL IDFNULLIFY(KHV(I)); ENDDO DO I=1,NLAY; CALL IDFNULLIFY(BND(I)); ENDDO GRIDISG%ISAVE=1; LOKAY=ISG2GRIDMAIN('',0,NLAY,TOP,BOT,KHV,BND,GRIDISG) CALL IDFDEALLOCATE(TOP,SIZE(TOP)); DEALLOCATE(TOP) CALL IDFDEALLOCATE(BOT,SIZE(BOT)); DEALLOCATE(BOT) CALL IDFDEALLOCATE(KHV,SIZE(KHV)); DEALLOCATE(KHV) CALL IDFDEALLOCATE(BND,SIZE(BND)); DEALLOCATE(BND) CALL UTL_MESSAGEHANDLE(1) IF(LOKAY)THEN J=SIZE(ID); IF(GRIDISG%ICDIST.EQ.0)J=9 DO I=1,J IF(I.EQ.2)CALL IDFINIT(IDFNAMEGIVEN=TRIM(PREFVAL(1))//'\TMP\'//TRIM(FNAME(I))//TRIM(GRIDISG%POSTFIX)//'.IDF',LPLOT=.TRUE.) IF(I.NE.2)CALL IDFINIT(IDFNAMEGIVEN=TRIM(PREFVAL(1))//'\TMP\'//TRIM(FNAME(I))//TRIM(GRIDISG%POSTFIX)//'.IDF',LPLOT=.FALSE.) END DO ENDIF END SUBROUTINE ISGGRIDSTART !###====================================================================== SUBROUTINE ISGGRIDFIELDS() !###====================================================================== IMPLICIT NONE INTEGER :: I CALL WDIALOGSELECT(ID_DISGEDITGRID) CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,I) I=ABS(I-1) CALL WDIALOGFIELDSTATE(IDF_INTEGER1,I) CALL WDIALOGFIELDSTATE(IDF_INTEGER2,I) CALL WDIALOGFIELDSTATE(IDF_INTEGER3,I) CALL WDIALOGFIELDSTATE(IDF_INTEGER4,I) CALL WDIALOGFIELDSTATE(IDF_MENU1,I) CALL WDIALOGFIELDSTATE(IDF_MENU2,I) CALL WDIALOGGETCHECKBOX(IDF_CHECK1,I) END SUBROUTINE ISGGRIDFIELDS !###==================================================================== SUBROUTINE ISGADD() !###==================================================================== IMPLICIT NONE REAL,DIMENSION(:),POINTER :: XCRD,YCRD INTEGER :: NCRD,I,ISEG,ICLC,ICRS,ISTW,IQHR REAL :: TDIST CALL UTL_MEASURE(XCRD,YCRD,NCRD) IF(NCRD.LE.1)THEN; DEALLOCATE(XCRD,YCRD); RETURN; ENDIF TDIST=0.0 DO I=1,NCRD-1 TDIST=TDIST+SQRT((XCRD(I)-XCRD(I+1))**2.0+(YCRD(I)-YCRD(I+1))**2.0) END DO CALL ISGMEMORYISG(1) ISEG=NISP+1 ICLC=NISD+1 ICRS=NISC+1 ISTW=0 IF(ISFR.EQ.0)IQHR=0 IF(ISFR.EQ.1)IQHR=NISQ+1 ISG(NISG)%SNAME='segment '//TRIM(ITOS(NISG)) ISG(NISG)%ISEG =ISEG ISG(NISG)%ICLC =ICLC ISG(NISG)%ICRS =ICRS ISG(NISG)%ISTW =ISTW ISG(NISG)%IQHR =IQHR ISG(NISG)%NSEG =0 ISG(NISG)%NCLC =0 ISG(NISG)%NCRS =0 ISG(NISG)%NSTW =0 ISG(NISG)%NQHR =0 CALL ISGMEMORYISP(NCRD,NISG,ISEG) !##put them properly within xyISG-array DO I=1,NCRD ISP(ISEG+I-1)%X=XCRD(I) ISP(ISEG+I-1)%Y=YCRD(I) END DO CALL ISGMEMORYISD(2,NISG,ICLC) ISD(ICLC)%N =0 ISD(ICLC)%IREF =0 ISD(ICLC)%DIST =0.0 ISD(ICLC)%CNAME ='CalcPnt FROM' ISD(ICLC+1)%N =0 ISD(ICLC+1)%IREF =0 ISD(ICLC+1)%DIST =TDIST ISD(ICLC+1)%CNAME='CalcPnt TO' DO I=0,1 ISD(ICLC+I)%IREF=NDISD+1 CALL ISGMEMORYDATISD(1,ICLC+I,ISEG) IF(ISFR.EQ.0)THEN DATISD(ISEG)%IDATE=UTL_GETCURRENTDATE() DATISD(ISEG)%WLVL =1.0 DATISD(ISEG)%BTML =0.0 DATISD(ISEG)%RESIS=1.0 DATISD(ISEG)%INFF =0.3 ELSEIF(ISFR.EQ.1)THEN DATISD(ISEG)%IDATE=UTL_GETCURRENTDATE() DATISD(ISEG)%CTIME=UTL_GETCURRENTTIME() DATISD(ISEG)%WLVL =1.0 DATISD(ISEG)%BTML =0.0 DATISD(ISEG)%WIDTH=1.0 DATISD(ISEG)%THCK =1.0 DATISD(ISEG)%HCND =1.0 DATISD(ISEG)%QFLW =0.0 DATISD(ISEG)%QROF =0.0 DATISD(ISEG)%PPTSW =0.0 DATISD(ISEG)%ETSW =0.0 DATISD(ISEG)%UPSG =0 DATISD(ISEG)%DWNS =0 DATISD(ISEG)%ICLC =1 DATISD(ISEG)%IPRI =1 ENDIF ENDDO CALL ISGMEMORYISC(1,NISG,ICRS) ISC(ICRS)%N =0 ISC(ICRS)%IREF =NDISC+1 ISC(ICRS)%DIST =TDIST/2.0 ISC(ICRS)%CNAME='CrossSection' IF(ISFR.EQ.0)THEN CALL ISGMEMORYDATISC(3,ICRS,ISEG) DATISC(ISEG)%DISTANCE =-5.0 DATISC(ISEG)%BOTTOM = 5.0 DATISC(ISEG)%MRC = 0.03 DATISC(ISEG+1)%DISTANCE= 0.0 DATISC(ISEG+1)%BOTTOM = 0.0 DATISC(ISEG+1)%MRC = 0.03 DATISC(ISEG+2)%DISTANCE= 5.0 DATISC(ISEG+2)%BOTTOM = 5.0 DATISC(ISEG+2)%MRC = 0.03 ELSEIF(ISFR.EQ.1)THEN CALL ISGMEMORYDATISC(8,ICRS,ISEG) DATISC(ISEG)%DISTANCE =-5.0 DATISC(ISEG)%BOTTOM = 5.0 DATISC(ISEG)%MRC = 0.15 DATISC(ISEG+1)%DISTANCE=-3.0 DATISC(ISEG+1)%BOTTOM = 3.0 DATISC(ISEG+1)%MRC = 0.15 DATISC(ISEG+2)%DISTANCE=-2.0 DATISC(ISEG+2)%BOTTOM = 2.0 DATISC(ISEG+2)%MRC = 0.03 DATISC(ISEG+3)%DISTANCE=-1.0 DATISC(ISEG+3)%BOTTOM = 1.0 DATISC(ISEG+3)%MRC = 0.03 DATISC(ISEG+4)%DISTANCE= 1.0 DATISC(ISEG+4)%BOTTOM = 0.0 DATISC(ISEG+4)%MRC = 0.03 DATISC(ISEG+5)%DISTANCE= 2.0 DATISC(ISEG+5)%BOTTOM = 2.0 DATISC(ISEG+5)%MRC = 0.03 DATISC(ISEG+6)%DISTANCE= 3.0 DATISC(ISEG+6)%BOTTOM = 3.0 DATISC(ISEG+6)%MRC = 0.15 DATISC(ISEG+7)%DISTANCE= 5.0 DATISC(ISEG+7)%BOTTOM = 5.0 DATISC(ISEG+7)%MRC = 0.15 ENDIF IF(ISFR.EQ.1)THEN CALL ISGMEMORYISQ(1,NISG,IQHR) ISQ(IQHR)%N =0 ISQ(IQHR)%IREF =NDISQ+1 ISQ(IQHR)%DIST =TDIST/2.0 ISQ(IQHR)%CNAME='StreamDepthRelation' CALL ISGMEMORYDATISQ(3,IQHR,ISEG) DATISQ(ISEG)%Q = 10.0 DATISQ(ISEG)%W = 10.0 DATISQ(ISEG)%D = 5.0 DATISQ(ISEG)%F = 1.0 DATISQ(ISEG+1)%Q= 50.0 DATISQ(ISEG+1)%W= 25.0 DATISQ(ISEG+1)%D= 10.0 DATISQ(ISEG+1)%F= 1.0 DATISQ(ISEG+2)%Q=150.0 DATISQ(ISEG+2)%W= 50.0 DATISQ(ISEG+2)%D= 15.0 DATISQ(ISEG+2)%F= 1.0 ENDIF DEALLOCATE(XCRD,YCRD) CALL WDIALOGSELECT(ID_DISGEDITTAB1) !#no selection otherwise line should be selected at once!!! ISG%ILIST=0 CALL WDIALOGPUTMENU(IDF_MENU1,ISG%SNAME,NISG,ISG%ILIST) CALL ISGFIELDS() CALL IDFPLOTFAST(1) END SUBROUTINE ISGADD !###==================================================================== SUBROUTINE ISGCONNECT(ID) !###==================================================================== IMPLICIT NONE REAL,PARAMETER :: SCALEXY=1.0/100.0 INTEGER,INTENT(IN) :: ID INTEGER :: ITYPE TYPE(WIN_MESSAGE) :: MESSAGE INTEGER :: I,J,N,ICLC,NCLC,IISG,JJSG,IREF REAL :: DX,DY,MINDIST LOGICAL :: LEX DX=((MPW%XMAX-MPW%XMIN)*SCALEXY)**2.0 DY=((MPW%YMAX-MPW%YMIN)*SCALEXY)**2.0 MINDIST=SQRT(DX+DY) IF(ISFR.EQ.0)RETURN CALL WDIALOGSELECT(ID_DISGEDITTAB1) CALL WDIALOGGETMENU(IDF_MENU1,ISG(1:NISG)%ILIST) IF(SUM(ISG%ILIST).NE.1)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You need to select only ONE segment to connect it'//CHAR(13)// & 'Use the AutoConnect function for multiply downstream connections','Warning') RETURN ENDIF CALL IGRLINEWIDTH(3) CALL IGRCOLOURN(INVERSECOLOUR(WRGB(255,0,0))) IISG=0 DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE (MOUSEMOVE) !## highlight line LEX=ISGGETSEGMENT(MESSAGE%GX,MESSAGE%GY,0,JJSG,MINDIST,0) IF(LEX)THEN CALL WCURSORSHAPE(ID_CURSORPIPET) ELSE CALL WCURSORSHAPE(CURARROW) ENDIF CALL IDFPLOT1BITMAP() CALL IGRPLOTMODE(MODEXOR) !## remove previous one IF(IISG.NE.0)CALL ISGPLOT_DRAWREACHES(IISG) IISG=0; IF(LEX)THEN; IISG=JJSG; CALL ISGPLOT_DRAWREACHES(IISG); ENDIF CALL IDFPLOT2BITMAP() CALL IGRPLOTMODE(MODECOPY) CASE (MOUSEBUTDOWN) SELECT CASE (MESSAGE%VALUE1) !## upstream / downstream connection CASE(1) !## adjust all connections on segment ICLC=ISG(ISELISG)%ICLC-1; NCLC=ISG(ISELISG)%NCLC DO I=1,NCLC ICLC=ICLC+1; IREF=ISD(ICLC)%IREF-1; N=ISD(ICLC)%N DO J=1,N IREF=IREF+1 !## upstream connection IF(ID.EQ.ID_CONNECTFROM)DATISD(IREF)%UPSG=IISG !## downstream connection IF(ID.EQ.ID_CONNECTTO) DATISD(IREF)%DWNS=IISG ENDDO ENDDO CALL IDFPLOTFAST(1); IISG=0 !## stop by pressing middle/right mouse button CASE (2,3) EXIT END SELECT END SELECT ENDDO CALL IGRCOLOURN(WRGB(0,0,0)) CALL IGRLINEWIDTH(1) CALL WCURSORSHAPE(CURARROW) CALL IDFPLOTFAST(1) END SUBROUTINE ISGCONNECT !###==================================================================== SUBROUTINE ISGSELECTPOLYGON() !###==================================================================== IMPLICIT NONE INTEGER,PARAMETER :: MAXPOL=500 REAL,ALLOCATABLE,DIMENSION(:) :: XPOL,YPOL REAL :: XC1,YC1,X,Y INTEGER :: NPOL,ITYPE,IISG,ISEG TYPE(WIN_MESSAGE) :: MESSAGE LOGICAL :: LEX CALL WCURSORSHAPE(ID_CURSORPOLYGON) ALLOCATE(XPOL(MAXPOL),YPOL(MAXPOL)); NPOL=1 CALL IGRPLOTMODE(MODEXOR); CALL IGRCOLOURN(WRGB(255,255,255)); CALL IGRFILLPATTERN(OUTLINE) LEX=.FALSE. DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) !## mouse-move CASE (MOUSEMOVE) CALL WINDOWSELECT(0) CALL WINDOWOUTSTATUSBAR(1,'X:'//TRIM(ITOS(INT(MESSAGE%GX/1000.0)))//' km, Y:'// & TRIM(ITOS(INT(MESSAGE%GY/1000.0)))//' km') XC1=MESSAGE%GX; YC1=MESSAGE%GY IF(NPOL.GT.1)THEN CALL IDFPLOT1BITMAP() IF(LEX)CALL CREATEIPF_DRAWPOLYGON(SIZE(XPOL),NPOL,XPOL,YPOL) LEX=.TRUE.; XPOL(NPOL)=XC1; YPOL(NPOL)=YC1 CALL CREATEIPF_DRAWPOLYGON(SIZE(XPOL),NPOL,XPOL,YPOL) CALL IDFPLOT2BITMAP() ENDIF CASE (MOUSEBUTDOWN) CALL IDFPLOT1BITMAP() IF(LEX)CALL CREATEIPF_DRAWPOLYGON(SIZE(XPOL),NPOL,XPOL,YPOL) SELECT CASE (MESSAGE%VALUE1) !## left button CASE (1) IF(NPOL+1.GT.MAXPOL)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Maximum of '//TRIM(ITOS(MAXPOL))//' points allowed','Warning') ELSE XPOL(NPOL:NPOL+1)=XC1; YPOL(NPOL:NPOL+1)=YC1; NPOL=NPOL+1 CALL CREATEIPF_DRAWPOLYGON(SIZE(XPOL),NPOL,XPOL,YPOL) CALL IDFPLOT2BITMAP() ENDIF !## right button CASE (3) NPOL=NPOL-1 CALL IDFPLOT2BITMAP() EXIT END SELECT !## bitmap scrolled, renew top-left pixel coordinates CASE (BITMAPSCROLLED) MPW%IX=MESSAGE%VALUE1; MPW%IY=MESSAGE%VALUE2 END SELECT END DO !## right mouse button pushed IF(MESSAGE%VALUE1.EQ.3)THEN !## plot selected segments ISG%ILIST=0; CALL ISGPLOT_DRAWSELECTEDSEGMENTS() DO IISG=1,NISG DO ISEG=ISG(IISG)%ISEG,ISG(IISG)%ISEG+ISG(IISG)%NSEG-1 X=ISP(ISEG)%X; Y=ISP(ISEG)%Y IF(MPW%XMIN.LE.X.AND.MPW%XMAX.GE.X.AND.MPW%YMIN.LE.Y.AND.MPW%YMAX.GE.Y)THEN IF(UTL_INSIDEPOLYGON(X,Y,XPOL,YPOL,NPOL).EQ.1)ISG(IISG)%ILIST=1 ENDIF END DO ENDDO !## plot selected segments CALL ISGPLOT_DRAWSELECTEDSEGMENTS() CALL WDIALOGSELECT(ID_DISGEDITTAB1) CALL WDIALOGPUTOPTION(IDF_MENU1,ISG(1:NISG)%ILIST) CALL ISGFIELDS() CALL ISGADJUSTFIELDS() ENDIF DEALLOCATE(XPOL,YPOL) CALL WCURSORSHAPE(CURARROW); CALL IGRPLOTMODE(MODECOPY); CALL IGRFILLPATTERN(OUTLINE) END SUBROUTINE ISGSELECTPOLYGON !###==================================================================== SUBROUTINE ISGDRIP() !###==================================================================== IMPLICIT NONE INTEGER :: I,N,ICLC,NCLC,IISG,IREF IF(ISFR.EQ.0)RETURN !## remove selected segments ISG%ILIST=0; CALL ISGPLOT_DRAWSELECTEDSEGMENTS() CALL WDIALOGSELECT(ID_DISGEDITTAB1) CALL WDIALOGGETMENU(IDF_MENU1,ISG(1:NISG)%ILIST) DO I=1,NISG !## skip non-selected segments IF(ISG(I)%ILIST.EQ.0)CYCLE !## trace this isg-number IISG=I; ISG(IISG)%JLIST=1 !## do until no connection found anymore DO !## trace selected segment, use only first reference of connection ICLC=ISG(IISG)%ICLC; NCLC=ISG(IISG)%NCLC IREF=ISD(ICLC+1)%IREF; N=ISD(ICLC+1)%N IISG=DATISD(IREF)%DWNS !## not connect to any other segment - exit IF(IISG.LE.0.OR.IISG.GT.NISG)EXIT !## allready visited, might be conflicted - exit IF(ISG(IISG)%JLIST.EQ.1)EXIT ISG(IISG)%JLIST=1 ENDDO ENDDO !## get final selection ISG%ILIST=ISG%JLIST CALL WDIALOGPUTOPTION(IDF_MENU1,ISG(1:NISG)%ILIST) !## plot selected segments ISG%JLIST=0; CALL ISGPLOT_DRAWSELECTEDSEGMENTS() END SUBROUTINE ISGDRIP !###==================================================================== SUBROUTINE ISGCONNECTTOAUTO() !###==================================================================== IMPLICIT NONE INTEGER :: II,J,K,N,ICLC,NCLC,IISG,JJSG,IREF,ISEG,IOS,NPLIST,IPOT INTEGER,POINTER,DIMENSION(:) :: IPLIST=>NULL(),SGLIST=>NULL() REAL,POINTER,DIMENSION(:) :: DPLIST REAL :: MINDIST,X,Y,DPOT CHARACTER(LEN=52) :: LINE LOGICAL :: LEX IF(ISFR.EQ.0)RETURN CALL WDIALOGSELECT(ID_DISGEDITTAB1) CALL WDIALOGGETMENU(IDF_MENU1,ISG(1:NISG)%ILIST) CALL WDIALOGGETSTRING(IDF_SNAPDISTANCE,LINE) READ(LINE,*,IOSTAT=IOS) MINDIST IF(IOS.NE.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You need to enter a number to define the snapping distance for connection.','Error') RETURN ENDIF CALL UTL_MESSAGEHANDLE(0) DO IISG=1,NISG !## skip non-selected segments IF(ISG(IISG)%ILIST.EQ.0)CYCLE !## check what segment in reach of last point on segment ISEG=ISG(IISG)%ISEG+ISG(IISG)%NSEG-1 X=ISP(ISEG)%X; Y=ISP(ISEG)%Y !## get all segments from last point to beginning of segment within given distance LEX=ISGGETSEGMENT(X,Y,IISG,JJSG,MINDIST,1,IPLIST=IPLIST,DPLIST=DPLIST,NPLIST=NPLIST) !## remove existing connection IF(.NOT.LEX)NPLIST=0; JJSG=0 IPOT=0; DPOT=HUGE(1.0) !## find appropriate connection(s) DO II=1,NPLIST !## isg within distance of isg JJSG=IPLIST(II) !## cannot connect to upstream node ... IF(.NOT.ISGCONNECTAUTO_CHECK(IISG,JJSG,SGLIST))CYCLE IF(DPLIST(II).LT.DPOT)THEN; IPOT=IPLIST(II); DPOT=DPLIST(II); ENDIF ENDDO IF(IPOT.EQ.0)THEN JJSG=0 ELSE JJSG=IPOT ENDIF !## adjust all connections on segment ICLC=ISG(IISG)%ICLC-1; NCLC=ISG(IISG)%NCLC DO J=1,NCLC ICLC=ICLC+1; IREF=ISD(ICLC)%IREF-1; N=ISD(ICLC)%N DO K=1,N IREF=IREF+1 DATISD(IREF)%DWNS=JJSG ENDDO ENDDO IF(ASSOCIATED(IPLIST))DEALLOCATE(IPLIST) IF(ASSOCIATED(SGLIST))DEALLOCATE(SGLIST) ENDDO CALL UTL_MESSAGEHANDLE(1) CALL IDFPLOTFAST(1) CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'Finished creating the connections','Information') END SUBROUTINE ISGCONNECTTOAUTO !###==================================================================== LOGICAL FUNCTION ISGCONNECTAUTO_CHECK(IISG,JJSG,SGLIST) !###==================================================================== IMPLICIT NONE INTEGER,INTENT(INOUT),POINTER,DIMENSION(:) :: SGLIST INTEGER,INTENT(IN) :: IISG INTEGER,INTENT(INOUT) :: JJSG INTEGER :: ICLC,IREF ISGCONNECTAUTO_CHECK=.FALSE. IF(.NOT.ASSOCIATED(SGLIST))ALLOCATE(SGLIST(NISG)) SGLIST=0; SGLIST(IISG)=1 !## trace this isg-number jjsg !## do until no connection found anymore DO !## trace selected segment, use only first reference of connection ICLC=ISG(JJSG)%ICLC !; NCLC=ISG(IISG)%NCLC IREF=ISD(ICLC+1)%IREF !; N=ISD(ICLC+1)%N JJSG=DATISD(IREF)%DWNS !## not connect to any other segment - exit IF(JJSG.LE.0.OR.JJSG.GT.NISG)THEN !## correct connection, no circular reference found ISGCONNECTAUTO_CHECK=.TRUE. EXIT ENDIF !## already been here - exit IF(SGLIST(JJSG).EQ.1)EXIT SGLIST(JJSG)=1 ! !## circular reference, cannot connect to this segment ! IF(IISG.EQ.JJSG)EXIT ENDDO END FUNCTION ISGCONNECTAUTO_CHECK !###==================================================================== SUBROUTINE ISGDEL() !###==================================================================== IMPLICIT NONE INTEGER :: ICLC,NCLC,ICRS,NCRS,ISEG,NSEG,I,J,K,ISTW,NSTW,IQHR,NQHR,IREF,N !## remove up- and downstream connections to this stream IF(ISFR.EQ.1)THEN DO I=1,NISG ICLC=ISG(I)%ICLC; NCLC=ISG(I)%NCLC DO J=1,NCLC IREF=ISD(ICLC+J-1)%IREF-1; N=ISD(ICLC+J-1)%N DO K=1,N IREF=IREF+1 !## remove it IF(DATISD(IREF)%UPSG.EQ.ISELISG)DATISD(IREF)%UPSG=0 IF(DATISD(IREF)%DWNS.EQ.ISELISG)DATISD(IREF)%DWNS=0 !## renumber it IF(DATISD(IREF)%UPSG.GT.ISELISG)DATISD(IREF)%UPSG=DATISD(IREF)%UPSG-1 IF(DATISD(IREF)%DWNS.GT.ISELISG)DATISD(IREF)%DWNS=DATISD(IREF)%DWNS-1 ENDDO ENDDO ENDDO ENDIF !## remove all calculation points on segment ICLC=ISG(ISELISG)%ICLC NCLC=ISG(ISELISG)%NCLC DO I=1,NCLC CALL ISGDELISD(ISELISG,ICLC) END DO !## remove all cross-sections on segment ICRS=ISG(ISELISG)%ICRS NCRS=ISG(ISELISG)%NCRS DO I=1,NCRS CALL ISGDELISC(ISELISG,ICRS) END DO !## remove all weirs on segment ISTW=ISG(ISELISG)%ISTW NSTW=ISG(ISELISG)%NSTW DO I=1,NSTW CALL ISGDELIST(ISELISG,ISTW) END DO !## remove all qh relationships on segment IQHR=ISG(ISELISG)%IQHR NQHR=ISG(ISELISG)%NQHR DO I=1,NQHR CALL ISGDELISQ(ISELISG,IQHR) END DO !## remove segment ISEG=ISG(ISELISG)%ISEG NSEG=ISG(ISELISG)%NSEG CALL ISGDELISP(ISELISG) !## remove entire segment in isg() variable ISG(ISELISG:NISG-1)=ISG(ISELISG+1:NISG) NISG =NISG-1 END SUBROUTINE ISGDEL !###==================================================================== SUBROUTINE ISGDELCLOSE() !###==================================================================== IMPLICIT NONE CALL WDIALOGSELECT(ID_DISGEDITTAB1) IF(NISG.GT.0)THEN ISG%ILIST=0 CALL WDIALOGPUTMENU(IDF_MENU1,ISG%SNAME,NISG,ISG%ILIST) ELSE NISG=0 CALL WDIALOGCLEARFIELD(IDF_MENU1) ENDIF CALL ISGFIELDS() !## none selected ISELISG=0 !## remove current line IF(SHPNO.GT.0)CALL POLYGON1DRAWSHAPE(SHPNO,SHPNO) SHPNO=ISGSHAPES CALL IDFPLOTFAST(1) END SUBROUTINE ISGDELCLOSE !###==================================================================== SUBROUTINE ISGATTRIBUTESMATH(ITAB) !###==================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ITAB TYPE(WIN_MESSAGE) :: MESSAGE INTEGER :: ITYPE,I,J,ID1,ID2,IM1,IM2,IY1,IY2,IAT,IOP,IDBG REAL :: X,Y INTEGER,DIMENSION(12) :: ID DATA ID/IDF_INTEGER1 ,IDF_INTEGER2 ,IDF_INTEGER3 ,IDF_INTEGER4, & IDF_INTEGER7 ,IDF_INTEGER8 ,IDF_INTEGER9 , & IDF_INTEGER10,IDF_INTEGER11,IDF_INTEGER12, & IDF_MENU1,IDF_MENU2/ CALL WDIALOGLOAD(ID_DISGCALC) CALL WDIALOGPUTMENU(IDF_MENU1,CDATE,12,4) CALL WDIALOGPUTMENU(IDF_MENU2,CDATE,12,3) CALL WDIALOGPUTINTEGER(IDF_INTEGER1,14) CALL WDIALOGPUTINTEGER(IDF_INTEGER2,1996) CALL WDIALOGPUTINTEGER(IDF_INTEGER3,28) CALL WDIALOGPUTINTEGER(IDF_INTEGER4,2004) CALL UTL_FILLDATES(IDF_INTEGER2,IDF_MENU1,IDF_INTEGER1) CALL UTL_FILLDATES(IDF_INTEGER4,IDF_MENU2,IDF_INTEGER3) !## isd IF(ITAB.EQ.ID_DISGATTRIBUTESTAB1)THEN IF(ISFR.EQ.0)THEN CALL WDIALOGPUTMENU(IDF_MENU4,ISDLABELS(2:),SIZE(ISDLABELS)-1,1) ELSEIF(ISFR.EQ.1)THEN CALL WDIALOGPUTMENU(IDF_MENU4,ISDLABELS(3:),SIZE(ISDLABELS)-2,1) ENDIF !## isc ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB2)THEN ! IF(ISCN(J).EQ.1)THEN ! IF(.NOT.UTL_DATA_CSV((/'Distance ','BottomLevel','MRC '/),VAR,ICOL_VAR,IACT_VAR,CCNST))RETURN; N=3 ! ELSEIF(ISCN(J).EQ.-1)THEN ! IF(.NOT.UTL_DATA_CSV((/'X-crd. ','Y-crd. ','Z-value ','Pointer '/),VAR,ICOL_VAR,IACT_VAR,CCNST))RETURN; N=4 ! ENDIF CALL WDIALOGPUTMENU(IDF_MENU4,(/'Distance ','BottomLevel','MRC '/),3,1) CALL WDIALOGFIELDSTATE(IDF_CHECK1,0) !## isp ! ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB3)THEN ! CALL WDIALOGPUTMENU(IDF_MENU4,(/'Q ','Width ','Depth ','Factor'/),4,1) !## ist ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB5)THEN CALL WDIALOGPUTMENU(IDF_MENU4,(/'Date ','UpWaterLevel ','DownWaterLevel'/),3,1) !## isq ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB5)THEN CALL WDIALOGPUTMENU(IDF_MENU4,(/'Q ','Width ','Depth ','Factor'/),4,1) CALL WDIALOGFIELDSTATE(IDF_CHECK1,0) ENDIF CALL WDIALOGFIELDSTATE(IDF_INTEGER7 ,0) CALL WDIALOGFIELDSTATE(IDF_INTEGER8 ,0) CALL WDIALOGFIELDSTATE(IDF_INTEGER9 ,0) CALL WDIALOGFIELDSTATE(IDF_INTEGER10,0) CALL WDIALOGFIELDSTATE(IDF_INTEGER11,0) CALL WDIALOGFIELDSTATE(IDF_INTEGER12,0) CALL WDIALOGSHOW(-1,-1,0,3) DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE (FIELDCHANGED) SELECT CASE (MESSAGE%VALUE2) CASE (IDF_CHECK1) CALL WDIALOGGETCHECKBOX(IDF_CHECK1,J) DO I=1,SIZE(ID); CALL WDIALOGFIELDSTATE(ID(I),J); ENDDO CASE (IDF_INTEGER1,IDF_INTEGER2,IDF_MENU1) CALL UTL_FILLDATES(IDF_INTEGER2,IDF_MENU1,IDF_INTEGER1) CASE (IDF_INTEGER3,IDF_INTEGER4,IDF_MENU2) CALL UTL_FILLDATES(IDF_INTEGER4,IDF_MENU2,IDF_INTEGER3) END SELECT CASE (PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (IDCANCEL) EXIT CASE (IDOK) CALL WDIALOGGETCHECKBOX(IDF_CHECK1,J) IF(J.EQ.1)THEN CALL WDIALOGGETINTEGER(IDF_INTEGER1,ID1) CALL WDIALOGGETINTEGER(IDF_INTEGER2,IY1) CALL WDIALOGGETINTEGER(IDF_INTEGER3,ID2) CALL WDIALOGGETINTEGER(IDF_INTEGER4,IY2) CALL WDIALOGGETMENU(IDF_MENU1,IM1) CALL WDIALOGGETMENU(IDF_MENU2,IM2) ENDIF CALL WDIALOGGETMENU(IDF_MENU4,IAT) CALL WDIALOGGETMENU(IDF_MENU5,IOP) CALL WDIALOGGETREAL(IDF_REAL1,X) IF(ITAB.EQ.ID_DISGATTRIBUTESTAB1)THEN IAT=IAT+1; IF(ISFR.EQ.1)IAT=IAT+1 ENDIF CALL WDIALOGUNDEFINED(INODATA,RNODATA) IDBG=INFOERROR(DEBUGLEVEL); CALL IDEBUGLEVEL(0) CALL WDIALOGSELECT(ITAB) I=0 DO I=I+1 CALL WGRIDGETCELLREAL(IDF_GRID1,IAT,I,Y) !## nothing read IF(Y.EQ.RNODATA)EXIT SELECT CASE (IOP) CASE (1); Y=Y+X CASE (2); Y=Y-X CASE (3); Y=Y*X CASE (4); Y=Y/X CASE (5); Y=X END SELECT CALL WGRIDPUTCELLREAL(IDF_GRID1,IAT,I,Y) ENDDO CALL IDEBUGLEVEL(IDBG) EXIT CASE (IDHELP) END SELECT END SELECT ENDDO CALL WDIALOGLOAD(ID_DISGCALC) CALL WDIALOGUNLOAD() CALL WDIALOGSELECT(ITAB) END SUBROUTINE ISGATTRIBUTESMATH !###==================================================================== SUBROUTINE ISGATTRIBUTESSAVEOPEN(ID) !###==================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ID INTEGER :: ITAB CALL WDIALOGSELECT(ID_DISGATTRIBUTES) CALL WDIALOGGETTAB(IDF_TAB1,ITAB) !## isd tab IF(ITAB.EQ.ID_DISGATTRIBUTESTAB1)THEN CALL ISGATTRIBUTESGETISDVALUES() CALL ISGATTRIBUTESSAVEOPENISD(ID) !## isc tab ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB2)THEN CALL ISGATTRIBUTESGETISCVALUES() CALL ISGATTRIBUTESSAVEOPENISC(ID) !## isp tab ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB3)THEN CALL ISGATTRIBUTESGETISPVALUES() CALL ISGATTRIBUTESSAVEOPENISP(ID) !## ist tab ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB4)THEN CALL ISGATTRIBUTESGETISTVALUES() CALL ISGATTRIBUTESSAVEOPENIST(ID) !## isq tab ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB5)THEN CALL ISGATTRIBUTESGETISQVALUES() CALL ISGATTRIBUTESSAVEOPENISQ(ID) ENDIF END SUBROUTINE ISGATTRIBUTESSAVEOPEN !###====================================================================== SUBROUTINE ISGATTRIBUTESSAVEOPENISD(ID) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ID INTEGER :: IU,I,J,K,NK,IOS CHARACTER(LEN=256) :: FNAME,LINE CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB1) CALL WDIALOGGETMENU(IDF_MENU1,J) IF(ID.EQ.ID_SAVEAS)THEN IF(.NOT.UTL_WSELECTFILE('Save Comma Separated File (*.csv)|*.csv|',& SAVEDIALOG+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,& 'Save Comma Separated File (*.csv)'))RETURN IU=UTL_GETUNIT(); CALL OSD_OPEN(IU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE') LINE=TRIM(ISDLABELS(1)); DO I=2,SIZE(ISDLABELS); LINE=TRIM(LINE)//','//TRIM(ISDLABELS(I)); ENDDO WRITE(IU,'(A)') TRIM(LINE) DO I=1,TISD(J) IF(ISFR.EQ.0)THEN LINE=TRIM(ITOS(DATISD2(J,I)%IDATE))//','//TRIM(RTOS(DATISD2(J,I)%WLVL,'F',3)) //','//TRIM(RTOS(DATISD2(J,I)%BTML,'F',3))// & ','//TRIM(RTOS(DATISD2(J,I)%RESIS,'G',7))//','//TRIM(RTOS(DATISD2(J,I)%INFF,'G',7)) ELSE LINE=TRIM(ITOS(DATISD2(J,I)%IDATE))//','// DATISD2(J,I)%CTIME //','//TRIM(RTOS(DATISD2(J,I)%WLVL,'F',3))// & ','//TRIM(RTOS(DATISD2(J,I)%BTML,'F',3))//','//TRIM(RTOS(DATISD2(J,I)%WIDTH,'G',7))// & ','//TRIM(RTOS(DATISD2(J,I)%THCK,'G',7))// & ','//TRIM(RTOS(DATISD2(J,I)%HCND,'G',7))//','//TRIM(ITOS(DATISD2(J,I)%UPSG)) // & ','//TRIM(ITOS(DATISD2(J,I)%DWNS))// ','//TRIM(ITOS(DATISD2(J,I)%ICLC)) // & ','//TRIM(ITOS(DATISD2(J,I)%IPRI))// ','//TRIM(RTOS(DATISD2(J,I)%QFLW,'G',7))// & ','//TRIM(RTOS(DATISD2(J,I)%QROF,'G',7))//','//TRIM(RTOS(DATISD2(J,I)%PPTSW,'G',7))// & ','//TRIM(RTOS(DATISD2(J,I)%ETSW,'G',7)) ENDIF WRITE(IU,'(A)') TRIM(LINE) END DO CLOSE(IU) ELSEIF(ID.EQ.ID_OPEN)THEN IF(.NOT.UTL_DATA_CSV(ISDLABELS,VAR,ICOL_VAR,IACT_VAR,CCNST))RETURN TISD(J)=NL IF(ISDMAXROW.LT.TISD(J))THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Maximum number of records to be read is '//TRIM(ITOS(ISDMAXROW))//CHAR(13)// & 'iMOD is reading '//TRIM(ITOS(TISD(J)))//' records only, rest will be left out!','Warning') ENDIF IF(ISFR.EQ.0)NK=5 !## riv package IF(ISFR.EQ.1)NK=15 !## sfr package DO I=1,MIN(ISDMAXROW,TISD(J)) !## number of variables DO K=1,NK IF(IACT_VAR(K).EQ.1)THEN IF(CCNST(K).EQ.'')THEN LINE=VAR(ICOL_VAR(K),I) ELSE LINE=CCNST(K) ENDIF IF(ISFR.EQ.0)THEN IF(K.EQ.1) READ(LINE,*,IOSTAT=IOS) DATISD2(J,I)%IDATE IF(K.EQ.2) READ(LINE,*,IOSTAT=IOS) DATISD2(J,I)%WLVL IF(K.EQ.3) READ(LINE,*,IOSTAT=IOS) DATISD2(J,I)%BTML IF(K.EQ.4) READ(LINE,*,IOSTAT=IOS) DATISD2(J,I)%RESIS IF(K.EQ.5) READ(LINE,*,IOSTAT=IOS) DATISD2(J,I)%INFF ELSEIF(ISFR.EQ.1)THEN IF(K.EQ.1) READ(LINE,*,IOSTAT=IOS) DATISD2(J,I)%IDATE IF(K.EQ.2) READ(LINE,*,IOSTAT=IOS) DATISD2(J,I)%CTIME IF(K.EQ.3) READ(LINE,*,IOSTAT=IOS) DATISD2(J,I)%WLVL IF(K.EQ.4) READ(LINE,*,IOSTAT=IOS) DATISD2(J,I)%BTML IF(K.EQ.5) READ(LINE,*,IOSTAT=IOS) DATISD2(J,I)%WIDTH IF(K.EQ.6) READ(LINE,*,IOSTAT=IOS) DATISD2(J,I)%THCK IF(K.EQ.7) READ(LINE,*,IOSTAT=IOS) DATISD2(J,I)%HCND IF(K.EQ.8) READ(LINE,*,IOSTAT=IOS) DATISD2(J,I)%UPSG IF(K.EQ.9) READ(LINE,*,IOSTAT=IOS) DATISD2(J,I)%DWNS IF(K.EQ.10)THEN READ(LINE,*,IOSTAT=IOS) DATISD2(J,I)%ICLC !## make sure ICLC is within defined limits (1-5) IF(DATISD2(J,I)%ICLC.LE.0.OR.DATISD2(J,I)%ICLC.GT.5)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Calculation option need to be between 1-5'//CHAR(13)// & 'Current value is '//TRIM(ITOS(DATISD2(J,I)%ICLC))//'; iMOD changed it into 1','Warning') DATISD2(J,I)%ICLC=1 ENDIF ENDIF IF(K.EQ.11)THEN READ(LINE,*,IOSTAT=IOS) DATISD2(J,I)%IPRI !## make sure IPRI is within defined limits (1-4) IF(DATISD2(J,I)%IPRI.LE.0.OR.DATISD2(J,I)%IPRI.GT.4)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Diversion option need to be between 1-4'//CHAR(13)// & 'Current value is '//TRIM(ITOS(DATISD2(J,I)%IPRI))//'; iMOD changed it into 1','Warning') DATISD2(J,I)%IPRI=1 ENDIF ENDIF IF(K.EQ.12)READ(LINE,*,IOSTAT=IOS) DATISD2(J,I)%QFLW IF(K.EQ.13)READ(LINE,*,IOSTAT=IOS) DATISD2(J,I)%QROF IF(K.EQ.14)READ(LINE,*,IOSTAT=IOS) DATISD2(J,I)%PPTSW IF(K.EQ.15)READ(LINE,*,IOSTAT=IOS) DATISD2(J,I)%ETSW ENDIF IF(IOS.NE.0)THEN TISD(J)=I-1 CALL WMESSAGEBOX(COMMONOK,EXCLAMATIONICON,COMMONOK,'Error reading column '//TRIM(ITOS(K))//' for row '// & TRIM(ITOS(I)),'Error') EXIT ENDIF ENDIF ENDDO !## something went wrong IF(K.LE.NK)EXIT ENDDO CALL UTL_GENLABELSDEALLOCATE() CALL ISGATTRIBUTESPUTISDVALUES() CALL ISGATTRIBUTESUPDATEPLOTS() ENDIF END SUBROUTINE ISGATTRIBUTESSAVEOPENISD !###====================================================================== SUBROUTINE ISGATTRIBUTESSAVEOPENISC(ID) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ID INTEGER :: I,J,K,IU,IOS,ICHK,N CHARACTER(LEN=256) :: FNAME,LINE CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB2) CALL WDIALOGGETMENU(IDF_MENU1,J) IF(ID.EQ.ID_SAVEAS)THEN IF(.NOT.UTL_WSELECTFILE('Save Comma Separated File (*.csv)|*.csv|',& SAVEDIALOG+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,& 'Save Comma Separated File (*.csv)'))RETURN IU=UTL_GETUNIT() CALL OSD_OPEN(IU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE') IF(ISCN(J).EQ.1)THEN WRITE(IU,'(A)') 'Y,Z,MRC' ELSEIF(ISCN(J).EQ.-1)THEN !## no reference height and pointers used ICHK=0; IF(DATISC2(J,1)%DISTANCE.LT.0.0.AND.DATISC2(J,1)%BOTTOM.LT.0.0)ICHK=1 IF(ICHK.EQ.0)WRITE(IU,'(A)') 'X,Y,Z' IF(ICHK.EQ.1)WRITE(IU,'(A)') 'X,Y,Z,IP' ENDIF DO I=1,TISC(J) IF(I.GE.2.AND.ICHK.EQ.1)THEN LINE=TRIM(RTOS(DATISC2(J,I)%DISTANCE,'F',3)) //','//TRIM(RTOS(DATISC2(J,I)%BOTTOM,'F',3))// & ','//TRIM(RTOS(DATISC2(J,I)%MRC,'G',7))//','//TRIM(RTOS(DATISC2(J,I)%ZP,'F',1)) ELSE LINE=TRIM(RTOS(DATISC2(J,I)%DISTANCE,'F',3)) //','//TRIM(RTOS(DATISC2(J,I)%BOTTOM,'F',3))// & ','//TRIM(RTOS(DATISC2(J,I)%MRC,'G',7)) ENDIF WRITE(IU,'(A)') TRIM(LINE) END DO CLOSE(IU) ELSEIF(ID.EQ.ID_OPEN)THEN IF(ISCN(J).EQ.1)THEN IF(.NOT.UTL_DATA_CSV((/'Distance ','BottomLevel','MRC '/),VAR,ICOL_VAR,IACT_VAR,CCNST))RETURN; N=3 ELSEIF(ISCN(J).EQ.-1)THEN IF(.NOT.UTL_DATA_CSV((/'X-crd. ','Y-crd. ','Z-value ','Pointer '/),VAR,ICOL_VAR,IACT_VAR,CCNST))RETURN; N=4 ENDIF TISC(J)=NL IF(ISCMAXROW.LT.TISC(J))THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Maximum number of records to be read is '//TRIM(ITOS(ISCMAXROW))//CHAR(13)// & 'iMOD is reading '//TRIM(ITOS(TISC(J)))//' records only, rest will be left out!','Warning') ENDIF DO I=1,MIN(ISCMAXROW,TISC(J)) !## number of variables DO K=1,N !4 IF(IACT_VAR(K).EQ.1)THEN IF(CCNST(K).EQ.'')THEN LINE=VAR(ICOL_VAR(K),I) ELSE LINE=CCNST(K) ENDIF IF(K.EQ.1)READ(LINE,*,IOSTAT=IOS) DATISC2(J,I)%DISTANCE IF(K.EQ.2)READ(LINE,*,IOSTAT=IOS) DATISC2(J,I)%BOTTOM IF(K.EQ.3)READ(LINE,*,IOSTAT=IOS) DATISC2(J,I)%MRC IF(K.EQ.4)READ(LINE,*,IOSTAT=IOS) DATISC2(J,I)%ZP IF(IOS.NE.0)THEN TISC(J)=I-1 CALL WMESSAGEBOX(COMMONOK,EXCLAMATIONICON,COMMONOK,'Error reading column '//TRIM(ITOS(K))//' for row '//TRIM(ITOS(I)),'Error') !exit EXIT ENDIF ENDIF ENDDO ENDDO CALL UTL_GENLABELSDEALLOCATE() CALL ISGATTRIBUTESPUTISCVALUES() CALL ISGATTRIBUTESUPDATEPLOTS() ENDIF END SUBROUTINE ISGATTRIBUTESSAVEOPENISC !###====================================================================== SUBROUTINE ISGATTRIBUTESSAVEOPENIST(ID) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ID INTEGER :: IU,I,J,K,IOS CHARACTER(LEN=256) :: FNAME,LINE CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB4) CALL WDIALOGGETMENU(IDF_MENU1,J) IF(ID.EQ.ID_SAVEAS)THEN IF(.NOT.UTL_WSELECTFILE('Save Comma Separated File (*.csv)|*.csv|',& SAVEDIALOG+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,& 'Save Comma Separated File (*.csv)'))RETURN IU=UTL_GETUNIT() CALL OSD_OPEN(IU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE') WRITE(IU,'(A)') 'Date,UpWaterLevel,DownWaterLevel' DO I=1,TIST(J) LINE=TRIM(ITOS(DATIST2(J,I)%IDATE)) //','//TRIM(RTOS(DATIST2(J,I)%WLVL_UP,'F',3))// & ','//TRIM(RTOS(DATIST2(J,I)%WLVL_DOWN,'F',3)) WRITE(IU,'(A)') TRIM(LINE) END DO CLOSE(IU) ELSEIF(ID.EQ.ID_OPEN)THEN IF(.NOT.UTL_DATA_CSV((/'Date ','UpWaterLevel ','DownWaterLevel'/),VAR,ICOL_VAR,IACT_VAR,CCNST))RETURN TIST(J)=NL IF(ISCMAXROW.LT.TIST(J))THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Maximum number of records to be read is '//TRIM(ITOS(ISTMAXROW))//CHAR(13)// & 'iMOD is reading '//TRIM(ITOS(TIST(J)))//' records only, rest will be left out!','Warning') ENDIF DO I=1,MIN(ISTMAXROW,TIST(J)) !## number of variables DO K=1,3 IF(IACT_VAR(K).EQ.1)THEN IF(CCNST(K).EQ.'')THEN LINE=VAR(ICOL_VAR(K),I) ELSE LINE=CCNST(K) ENDIF IF(K.EQ.1)READ(LINE,*,IOSTAT=IOS) DATIST2(J,I)%IDATE IF(K.EQ.2)READ(LINE,*,IOSTAT=IOS) DATIST2(J,I)%WLVL_UP IF(K.EQ.3)READ(LINE,*,IOSTAT=IOS) DATIST2(J,I)%WLVL_DOWN IF(IOS.NE.0)THEN TIST(J)=I-1 CALL WMESSAGEBOX(COMMONOK,EXCLAMATIONICON,COMMONOK,'Error reading column '//TRIM(ITOS(K))//' for row '//TRIM(ITOS(I)),'Error') !EXIT EXIT ENDIF ENDIF ENDDO ENDDO CALL UTL_GENLABELSDEALLOCATE() CALL ISGATTRIBUTESPUTISTVALUES() CALL ISGATTRIBUTESUPDATEPLOTS() ENDIF END SUBROUTINE ISGATTRIBUTESSAVEOPENIST !###====================================================================== SUBROUTINE ISGATTRIBUTESSAVEOPENISQ(ID) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ID INTEGER :: IU,I,J,K,IOS CHARACTER(LEN=256) :: FNAME,LINE CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB5) CALL WDIALOGGETMENU(IDF_MENU1,J) IF(ID.EQ.ID_SAVEAS)THEN IF(.NOT.UTL_WSELECTFILE('Save Comma Separated File |*.csv|',& SAVEDIALOG+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,& 'Save Comma Separated File (*.csv)'))RETURN IU=UTL_GETUNIT() CALL OSD_OPEN(IU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE') WRITE(IU,'(A)') 'Q,Width,Depth,Factor' DO I=1,TISQ(J) LINE=TRIM(RTOS(DATISQ2(J,I)%Q,'F',3))//','//TRIM(RTOS(DATISQ2(J,I)%W,'F',3))//','// & TRIM(RTOS(DATISQ2(J,I)%D,'F',3))//','//TRIM(RTOS(DATISQ2(J,I)%F,'F',3)) WRITE(IU,'(A)') TRIM(LINE) END DO CLOSE(IU) ELSEIF(ID.EQ.ID_OPEN)THEN IF(.NOT.UTL_DATA_CSV((/'Q ','Width ','Depth ','Factor'/),VAR,ICOL_VAR,IACT_VAR,CCNST))RETURN TISQ(J)=NL IF(ISQMAXROW.LT.TISQ(J))THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Maximum number of records to be read is '//TRIM(ITOS(ISQMAXROW))//CHAR(13)// & 'iMOD is reading '//TRIM(ITOS(TISQ(J)))//' records only, rest will be left out!','Warning') ENDIF DO I=1,MIN(ISQMAXROW,TISQ(J)) !## number of variables DO K=1,4 IF(IACT_VAR(K).EQ.1)THEN IF(CCNST(K).EQ.'')THEN LINE=VAR(ICOL_VAR(K),I) ELSE LINE=CCNST(K) ENDIF IF(K.EQ.1)READ(LINE,*,IOSTAT=IOS) DATISQ2(J,I)%Q IF(K.EQ.2)READ(LINE,*,IOSTAT=IOS) DATISQ2(J,I)%W IF(K.EQ.3)READ(LINE,*,IOSTAT=IOS) DATISQ2(J,I)%D IF(K.EQ.4)READ(LINE,*,IOSTAT=IOS) DATISQ2(J,I)%F IF(IOS.NE.0)THEN TISQ(J)=I-1 CALL WMESSAGEBOX(COMMONOK,EXCLAMATIONICON,COMMONOK,'Error reading column '//TRIM(ITOS(K))//' for row '//TRIM(ITOS(I)),'Error') !EXIT EXIT ENDIF ENDIF ENDDO ENDDO CALL UTL_GENLABELSDEALLOCATE() !VAR,IVAR,ICOL_VAR,IACT_VAR,CCNST) CALL ISGATTRIBUTESPUTISQVALUES() CALL ISGATTRIBUTESUPDATEPLOTS() ENDIF END SUBROUTINE ISGATTRIBUTESSAVEOPENISQ !###====================================================================== SUBROUTINE ISGATTRIBUTESSAVEOPENISP(ID) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ID INTEGER :: IU,I,IOS CHARACTER(LEN=256) :: FNAME,LINE IF(ID.EQ.ID_SAVEAS)THEN IF(.NOT.UTL_WSELECTFILE('iMOD Generate File (*.gen)|*.gen|',& SAVEDIALOG+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,& 'Save iMOD Generate File (*.gen)'))RETURN IU=UTL_GETUNIT() CALL OSD_OPEN(IU,FILE=FNAME,STATUS='REPLACE',ACTION='WRITE') WRITE(IU,*) ISELISG,TRIM(ISG(ISELISG)%SNAME) DO I=1,TISP LINE=TRIM(RTOS(ISP2(I)%X,'F',3))//','//TRIM(RTOS(ISP2(I)%Y,'F',3)) WRITE(IU,'(A)') TRIM(LINE) END DO WRITE(IU,'(A)') 'END' WRITE(IU,'(A)') 'END' CLOSE(IU) ELSEIF(ID.EQ.ID_OPEN)THEN IF(.NOT.UTL_WSELECTFILE('iMOD Generate File (*.gen)|*.gen|',& LOADDIALOG+MUSTEXIST+PROMPTON+DIRCHANGE+APPENDEXT,FNAME,& 'Load iMOD Generate File (*.gen)'))RETURN IU=UTL_GETUNIT() CALL OSD_OPEN(IU,FILE=FNAME,STATUS='OLD',ACTION='READ,DENYWRITE') READ(IU,*) TISP=0 I =0 DO I=I+1 IF(SIZE(ISP2).LT.I)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Maximum number of records to be read is '//& TRIM(ITOS(SIZE(ISP2)))//','//CHAR(13)//'rest will be left out!','Warning') EXIT ENDIF READ(IU,*,IOSTAT=IOS) ISP2(I)%X,ISP2(I)%Y IF(IOS.NE.0)EXIT TISP=TISP+1 END DO CLOSE(IU) CALL ISGATTRIBUTESPUTISPVALUES() CALL ISGATTRIBUTESUPDATEPLOTS() ENDIF END SUBROUTINE ISGATTRIBUTESSAVEOPENISP !###==================================================================== SUBROUTINE ISGATTRIBUTESUPDATEPLOTS() !###==================================================================== IMPLICIT NONE INTEGER :: ITAB CALL WDIALOGSELECT(ID_DISGATTRIBUTES) CALL WDIALOGGETTAB(IDF_TAB1,ITAB) !## calculation points IF(ITAB.EQ.ID_DISGATTRIBUTESTAB1)THEN CALL WDIALOGFIELDSTATE(IDF_MENU1,1) CALL ISGATTRIBUTESGETISDVALUES() CALL ISGATTRIBUTESPUTISDVALUES() CALL ISGATTRIBUTESPLOTISD() !## cross-sections ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB2)THEN CALL WDIALOGFIELDSTATE(IDF_MENU1,2) CALL ISGATTRIBUTESGETISCVALUES() CALL ISGATTRIBUTESPUTISCVALUES() CALL ISGATTRIBUTESPLOTISC() !## nodes/points ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB3)THEN CALL WDIALOGFIELDSTATE(IDF_MENU1,2) CALL ISGATTRIBUTESGETISPVALUES() CALL ISGATTRIBUTESPLOTISP() !## weirs/structures ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB4)THEN CALL WDIALOGFIELDSTATE(IDF_MENU1,2) CALL ISGATTRIBUTESGETISTVALUES() CALL ISGATTRIBUTESPUTISTVALUES() CALL ISGATTRIBUTESPLOTIST() !## qh-relationships ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB5)THEN CALL WDIALOGFIELDSTATE(IDF_MENU1,2) CALL ISGATTRIBUTESGETISQVALUES() CALL ISGATTRIBUTESPUTISQVALUES() CALL ISGATTRIBUTESPLOTISQ() ENDIF END SUBROUTINE ISGATTRIBUTESUPDATEPLOTS ! !###==================================================================== ! SUBROUTINE ISGATTRIBUTESSORT(ID) ! !###==================================================================== ! IMPLICIT NONE ! INTEGER,INTENT(IN) :: ID ! CALL WDIALOGSELECT(ID) ! !CALL WGRIDSORT(IDF_GRID1,1) !,1,10) ! END SUBROUTINE ISGATTRIBUTESSORT !###==================================================================== SUBROUTINE ISGATTRIBUTESPLOTISD() !###==================================================================== IMPLICIT NONE INTEGER :: I,J,K,XMIN,XMAX,X1,X2 REAL :: Y1,Y2,YMIN,YMAX CHARACTER(LEN=52) :: YTITLE CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB1) CALL WDIALOGGETMENU(IDF_MENU1,J) I=1; IF(TISD(J).LE.1)I=3 CALL WDIALOGSELECT(ID_DISGATTRIBUTES) CALL WDIALOGFIELDSTATE(IDF_STRING1,I) CALL WDIALOGFIELDSTATE(IDF_STRING2,I) IF(I.EQ.3)THEN CALL IGRAREA(0.0,0.0,1.0,1.0) CALL IGRUNITS(0.0,0.0,1.0,1.0) CALL IGRAREACLEAR() RETURN ENDIF CALL WDIALOGGETMENU(IDF_MENU1,I,YTITLE) CALL ISGATTRIBUTESPLOTISDEXTENT(XMIN,XMAX,YMIN,YMAX,I,J) CALL IGRCOLOURN(WRGB(255,255,255)) CALL IGRAREA(0.0,0.0,1.0,1.0) CALL IGRAREACLEAR() CALL IGRFILLPATTERN(SOLID) CALL ISGATTRIBUTESPLOT_AXES(REAL(XMIN),YMIN,REAL(XMAX),YMAX,.TRUE.,'Date',YTITLE) CALL IGRCOLOURN(WRGB(255,0,0)) IF(ISFR.EQ.0)THEN DO K=1,TISD(J)-1 X1=UTL_IDATETOJDATE(DATISD2(J,K)%IDATE) X2=UTL_IDATETOJDATE(DATISD2(J,K+1)%IDATE) SELECT CASE (I) CASE (1) Y1=DATISD2(J,K)%WLVL Y2=DATISD2(J,K+1)%WLVL CASE(2) Y1=DATISD2(J,K)%BTML Y2=DATISD2(J,K+1)%BTML CASE (3) Y1=DATISD2(J,K)%RESIS Y2=DATISD2(J,K+1)%RESIS CASE (4) Y1=DATISD2(J,K)%INFF Y2=DATISD2(J,K+1)%INFF END SELECT CALL IGRJOIN(REAL(X1),Y1,REAL(X2),Y1) CALL IGRJOIN(REAL(X2),Y1,REAL(X2),Y2) END DO ELSEIF(ISFR.EQ.1)THEN DO K=1,TISD(J)-1 X1=UTL_IDATETOJDATE(DATISD2(J,K)%IDATE) X2=UTL_IDATETOJDATE(DATISD2(J,K+1)%IDATE) SELECT CASE (I) CASE (1) Y1=DATISD2(J,K)%WLVL Y2=DATISD2(J,K+1)%WLVL CASE (2) Y1=DATISD2(J,K)%BTML Y2=DATISD2(J,K+1)%BTML CASE (3) Y1=DATISD2(J,K)%WIDTH Y2=DATISD2(J,K+1)%WIDTH CASE (4) Y1=DATISD2(J,K)%THCK Y2=DATISD2(J,K+1)%THCK CASE (5) Y1=DATISD2(J,K)%HCND Y2=DATISD2(J,K+1)%HCND CASE (6) Y1=DATISD2(J,K)%UPSG Y2=DATISD2(J,K+1)%UPSG CASE (7) Y1=DATISD2(J,K)%DWNS Y2=DATISD2(J,K+1)%DWNS CASE (8) Y1=DATISD2(J,K)%ICLC Y2=DATISD2(J,K+1)%ICLC CASE (9) Y1=DATISD2(J,K)%IPRI Y2=DATISD2(J,K+1)%IPRI CASE (10) Y1=DATISD2(J,K)%QFLW Y2=DATISD2(J,K+1)%QFLW CASE (11) Y1=DATISD2(J,K)%QROF Y2=DATISD2(J,K+1)%QROF CASE (12) Y1=DATISD2(J,K)%PPTSW Y2=DATISD2(J,K+1)%PPTSW CASE (13) Y1=DATISD2(J,K)%ETSW Y2=DATISD2(J,K+1)%ETSW END SELECT CALL IGRJOIN(REAL(X1),Y1,REAL(X2),Y1) CALL IGRJOIN(REAL(X2),Y1,REAL(X2),Y2) END DO ENDIF CALL WDIALOGSELECT(ID_DISGATTRIBUTES) END SUBROUTINE ISGATTRIBUTESPLOTISD !###==================================================================== SUBROUTINE ISGATTRIBUTESPLOT_AXES(XMIN,YMIN,XMAX,YMAX,LDATE,XTITLE,YTITLE) !###==================================================================== IMPLICIT NONE CHARACTER(LEN=*),INTENT(IN) :: XTITLE,YTITLE REAL,INTENT(IN) :: XMIN,YMIN,XMAX,YMAX LOGICAL,INTENT(IN) :: LDATE AXES%XMIN =XMIN AXES%XMAX =XMAX IF(AXES%XMAX.LE.AXES%XMIN)THEN AXES%XMIN=AXES%XMIN-1.0 AXES%XMAX=AXES%XMAX+1.0 ENDIF AXES%YMIN =YMIN AXES%YMAX =YMAX IF(AXES%YMAX.LE.AXES%YMIN)THEN AXES%YMIN=AXES%YMIN-1.0 AXES%YMAX=AXES%YMAX+1.0 ENDIF AXES%IFIXX =0 AXES%IFIXY =0 AXES%IFIXY2=0 AXES%XINT =1.0 AXES%YINT =1.0 AXES%XOFFSET=0 AXES%LDATE =LDATE AXES%XTITLE=TRIM(XTITLE) AXES%YTITLE=TRIM(YTITLE) AXES%IAXES=(/1,0/) !## left/bottom axes only AXES%XFACTOR=1.0 AXES%YFACTOR=1.0 AXES%DXAXESL=40.0 !## 1/40.0 als rand AXES%DYAXESB=20.0 AXES%DYAXEST=75.0 AXES%DXAXESR=150.0 AXES%TFONT=FFHELVETICA !## text-font AXES%ICLRRASTER=WRGB(220,220,220) AXES%ICLRBACKGROUND=WRGB(123,152,168) !## plot axes and set units CALL GRAPH_PLOTAXES(AXES,1) END SUBROUTINE ISGATTRIBUTESPLOT_AXES !###==================================================================== SUBROUTINE ISGATTRIBUTESPLOTISDEXTENT(XMIN,XMAX,YMIN,YMAX,I,J) !###==================================================================== IMPLICIT NONE REAL,INTENT(OUT) :: YMIN,YMAX INTEGER,INTENT(OUT) :: XMIN,XMAX INTEGER,INTENT(IN) :: I,J XMIN=MINVAL(DATISD2(J,1:TISD(J))%IDATE) XMAX=MAXVAL(DATISD2(J,1:TISD(J))%IDATE) XMIN=UTL_IDATETOJDATE(XMIN) XMAX=UTL_IDATETOJDATE(XMAX) IF(ISFR.EQ.0)THEN SELECT CASE (I) CASE (1) YMIN=MINVAL(DATISD2(J,1:TISD(J))%WLVL) YMAX=MAXVAL(DATISD2(J,1:TISD(J))%WLVL) CASE (2) YMIN=MINVAL(DATISD2(J,1:TISD(J))%BTML) YMAX=MAXVAL(DATISD2(J,1:TISD(J))%BTML) CASE (3) YMIN=MINVAL(DATISD2(J,1:TISD(J))%RESIS) YMAX=MAXVAL(DATISD2(J,1:TISD(J))%RESIS) CASE (4) YMIN=MINVAL(DATISD2(J,1:TISD(J))%INFF) YMAX=MAXVAL(DATISD2(J,1:TISD(J))%INFF) END SELECT ELSEIF(ISFR.EQ.1)THEN SELECT CASE (I) CASE (1) YMIN=MINVAL(DATISD2(J,1:TISD(J))%WLVL) YMAX=MAXVAL(DATISD2(J,1:TISD(J))%WLVL) CASE (2) YMIN=MINVAL(DATISD2(J,1:TISD(J))%BTML) YMAX=MAXVAL(DATISD2(J,1:TISD(J))%BTML) CASE (3) YMIN=MINVAL(DATISD2(J,1:TISD(J))%THCK) YMAX=MAXVAL(DATISD2(J,1:TISD(J))%THCK) CASE (4) YMIN=MINVAL(DATISD2(J,1:TISD(J))%WIDTH) YMAX=MAXVAL(DATISD2(J,1:TISD(J))%WIDTH) CASE (5) YMIN=MINVAL(DATISD2(J,1:TISD(J))%HCND) YMAX=MAXVAL(DATISD2(J,1:TISD(J))%HCND) CASE (6) YMIN=MINVAL(DATISD2(J,1:TISD(J))%DWNS) YMAX=MAXVAL(DATISD2(J,1:TISD(J))%DWNS) CASE (7) YMIN=MINVAL(DATISD2(J,1:TISD(J))%UPSG) YMAX=MAXVAL(DATISD2(J,1:TISD(J))%UPSG) CASE (8) YMIN=MINVAL(DATISD2(J,1:TISD(J))%ICLC) YMAX=MAXVAL(DATISD2(J,1:TISD(J))%ICLC) CASE (9) YMIN=MINVAL(DATISD2(J,1:TISD(J))%IPRI) YMAX=MAXVAL(DATISD2(J,1:TISD(J))%IPRI) CASE (10) YMIN=MINVAL(DATISD2(J,1:TISD(J))%QFLW) YMAX=MAXVAL(DATISD2(J,1:TISD(J))%QFLW) CASE (11) YMIN=MINVAL(DATISD2(J,1:TISD(J))%QROF) YMAX=MAXVAL(DATISD2(J,1:TISD(J))%QROF) CASE (12) YMIN=MINVAL(DATISD2(J,1:TISD(J))%PPTSW) YMAX=MAXVAL(DATISD2(J,1:TISD(J))%PPTSW) CASE (13) YMIN=MINVAL(DATISD2(J,1:TISD(J))%ETSW) YMAX=MAXVAL(DATISD2(J,1:TISD(J))%ETSW) END SELECT ENDIF IF(YMAX.EQ.YMIN)THEN YMIN=YMIN-0.5 YMAX=YMAX+0.5 ENDIF END SUBROUTINE ISGATTRIBUTESPLOTISDEXTENT !###==================================================================== SUBROUTINE ISGATTRIBUTESPLOTISC() !###==================================================================== IMPLICIT NONE INTEGER :: I,J,K,ITRAP,ISYM,ISIM,NDIM,NSYM,NSIM,NTRAP REAL :: XMIN,YMIN,XMAX,YMAX,DX,DY,AORG,ATRAP,ASIM,X1,X2,Y1,Y2 REAL,ALLOCATABLE,DIMENSION(:) :: XIN,YIN,XSYM,YSYM,XSIM,YSIM REAL,ALLOCATABLE,DIMENSION(:,:) :: XTRAP,YTRAP AORG=0.0; ATRAP=0.0; ASIM=0.0 !## double X-Y pairs plot with max.maxrow points CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB2) CALL WDIALOGGETMENU(IDF_MENU1,J) I=1; IF(ISCN(J).LT.0)I=3 CALL WDIALOGFIELDSTATE(IDF_CHECK1,I) CALL WDIALOGFIELDSTATE(IDF_CHECK2,I) CALL WDIALOGFIELDSTATE(IDF_CHECK3,I) CALL WDIALOGFIELDSTATE(IDF_REAL1,I) CALL WDIALOGFIELDSTATE(IDF_REAL2,I) CALL WDIALOGFIELDSTATE(IDF_REAL4,I) CALL WDIALOGFIELDSTATE(ID_PICK,ABS(3-I)+1) CALL WDIALOGFIELDSTATE(ID_TABLE,ABS(3-I)+1) ISYM=0; ITRAP=0; ISIM=0 IF(ISCN(J).GT.0)THEN CALL WDIALOGGETCHECKBOX(IDF_CHECK1,ISYM) CALL WDIALOGGETCHECKBOX(IDF_CHECK2,ITRAP) CALL WDIALOGGETCHECKBOX(IDF_CHECK3,ISIM) ENDIF I=1; IF(TISC(J).LE.1)I=3 CALL WDIALOGSELECT(ID_DISGATTRIBUTES) CALL WDIALOGFIELDSTATE(IDF_STRING1,I) CALL WDIALOGFIELDSTATE(IDF_STRING2,I) CALL WDIALOGFIELDSTATE(IDF_MENU1,3) IF(I.EQ.3)THEN CALL IGRAREA(0.0,0.0,1.0,1.0); CALL IGRAREACLEAR(); RETURN ENDIF !## distance/x XMIN=MINVAL(DATISC2(J,1:TISC(J))%DISTANCE) XMAX=MAXVAL(DATISC2(J,1:TISC(J))%DISTANCE) !## bottom/y YMIN=MINVAL(DATISC2(J,1:TISC(J))%BOTTOM) YMAX=MAXVAL(DATISC2(J,1:TISC(J))%BOTTOM) IF(ITRAP.EQ.1.OR.ISYM.EQ.1.OR.ISIM.EQ.1)THEN NDIM=TISC(J)*2 ALLOCATE(XIN(NDIM),YIN(NDIM),XSYM(NDIM),YSYM(NDIM),XSIM(NDIM),YSIM(NDIM)) ALLOCATE(XTRAP(4,NDIM),YTRAP(4,NDIM)) XIN(1:TISC(J))=DATISC2(J,1:TISC(J))%DISTANCE YIN(1:TISC(J))=DATISC2(J,1:TISC(J))%BOTTOM NSYM=TISC(J) !## create a simplified cross-section IF(ISIM.EQ.1)THEN !## try to get 8 NSIM=8; CALL ISGCOMPUTEEIGHTPOINTS(XIN,YIN,TISC(J),XSIM,YSIM,NSIM,AORG=AORG,ASIMPLE=ASIM) ENDIF IF(ISYM.EQ.1.OR.ITRAP.EQ.1)THEN CALL ISGCOMPUTETRAPEZIUM(XIN,YIN,XSYM,YSYM,XTRAP,YTRAP,NTRAP,NDIM,NSYM,AORG,ATRAP) ENDIF IF(ISYM.EQ.1)THEN IF(NSYM.GT.0)THEN XMAX=MAX(MAXVAL(XSYM(1:NSYM)),XMAX) XMIN=MIN(MINVAL(XSYM(1:NSYM)),XMIN) YMAX=MAX(MAXVAL(YSYM(1:NSYM)),YMAX) YMIN=MIN(MINVAL(YSYM(1:NSYM)),YMIN) ENDIF ENDIF IF(ITRAP.EQ.1)THEN IF(NTRAP.GT.0)THEN XMAX=MAX(MAXVAL(XTRAP(2,1:NTRAP)),XMAX) XMIN=MIN(MINVAL(XTRAP(1,1:NTRAP)),XMIN) YMAX=MAX(MAXVAL(YTRAP(2,1:NTRAP)),YMAX) YMIN=MIN(MINVAL(YTRAP(3,1:NTRAP)),YMIN) ENDIF ENDIF IF(ISIM.EQ.1)THEN IF(NSIM.GT.0)THEN XMAX=MAX(MAXVAL(XSIM(1:NSIM)),XMAX) XMIN=MIN(MINVAL(XSIM(1:NSIM)),XMIN) YMAX=MAX(MAXVAL(YSIM(1:NSIM)),YMAX) YMIN=MIN(MINVAL(YSIM(1:NSIM)),YMIN) ENDIF ENDIF ENDIF DX=(XMAX-XMIN)/50.0; DY=(YMAX-YMIN)/50.0 XMAX=XMAX+DX; XMIN=XMIN-DX; YMAX=YMAX+DY; YMIN=YMIN-DY IF(ISCN(J).EQ.1)THEN CALL IGRCOLOURN(WRGB(255,255,255)) CALL IGRAREA(0.0,0.0,1.0,1.0) CALL IGRAREACLEAR() CALL ISGATTRIBUTESPLOT_AXES(REAL(XMIN),YMIN,REAL(XMAX),YMAX,.FALSE.,'Relative Distance (m)','Heigth (m)') CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB2) CALL IGRFILLPATTERN(SOLID) DY=MAXVAL(DATISC2(J,1:TISC(J))%BOTTOM); CALL IGRCOLOURN(WRGB(128,255,255)) DO I=2,TISC(J) ! IF(ISFR.EQ.1)THEN ! SELECT CASE (I) ! CASE (4:6); CALL IGRCOLOURN(WRGB(128,255,255)) !## blueisch ! CASE DEFAULT; CALL IGRCOLOURN(WRGB(128,255,128)) !## grenisch ! END SELECT ! ENDIF X1=DATISC2(J,I-1)%DISTANCE; X2=DATISC2(J,I )%DISTANCE Y1=DATISC2(J,I-1)%BOTTOM; Y2=DATISC2(J,I )%BOTTOM CALL IGRPOLYGONCOMPLEX((/X1,X2,X2,X1/),(/Y1,Y2,DY,DY/),4) ENDDO !## plot 1d cross-section CALL IGRCOLOURN(WRGB(0,255,0)) CALL IGRLINEWIDTH(2) DO I=2,TISC(J) CALL IGRJOIN(DATISC2(J,I-1)%DISTANCE,DATISC2(J,I-1)%BOTTOM,DATISC2(J,I)%DISTANCE,DATISC2(J,I)%BOTTOM) END DO CALL IGRLINEWIDTH(1); CALL IGRFILLPATTERN(SOLID); CALL IGRCOLOURN(WRGB(50,50,50)) DO I=1,TISC(J) CALL IGRCIRCLE(DATISC2(J,I)%DISTANCE,DATISC2(J,I)%BOTTOM,DX/2.0) END DO IF(ITRAP.EQ.1)THEN CALL IGRPLOTMODE(MODEAND) CALL IGRFILLPATTERN(SOLID) K=0; DO I=1,NTRAP K=K+1; IF(J.GT.SIZE(ICOLOR))K=1 CALL IGRCOLOURN(ICOLOR(K)) CALL IGRPOLYGONCOMPLEX(XTRAP(:,I),YTRAP(:,I),4) END DO CALL IGRPLOTMODE(MODECOPY) CALL IGRFILLPATTERN(OUTLINE) CALL WDIALOGFIELDSTATE(IDF_REAL2,1) CALL WDIALOGPUTREAL(IDF_REAL2,ATRAP) ELSE CALL WDIALOGFIELDSTATE(IDF_REAL2,2) CALL WDIALOGCLEARFIELD(IDF_REAL2) ENDIF IF(ISYM.EQ.1)THEN CALL IGRCOLOURN(WRGB(255,0,0)) CALL IGRLINEWIDTH(3) DO I=2,NSYM CALL IGRJOIN(XSYM(I-1),YSYM(I-1),XSYM(I),YSYM(I)) END DO CALL IGRLINEWIDTH(1) CALL WDIALOGFIELDSTATE(IDF_REAL1,1) CALL WDIALOGPUTREAL(IDF_REAL1,AORG) ELSE CALL WDIALOGFIELDSTATE(IDF_REAL1,2) CALL WDIALOGCLEARFIELD(IDF_REAL1) ENDIF IF(ISIM.EQ.1)THEN CALL IGRCOLOURN(WRGB(0,0,255)) CALL IGRLINEWIDTH(3) DO I=2,NSIM CALL IGRJOIN(XSIM(I-1),YSIM(I-1),XSIM(I),YSIM(I)) END DO CALL IGRLINEWIDTH(1) DO I=1,NSIM CALL IGRCIRCLE(XSIM(I),YSIM(I),DX/2.0) END DO CALL IGRLINEWIDTH(1) CALL WDIALOGFIELDSTATE(IDF_REAL4,1) CALL WDIALOGPUTREAL(IDF_REAL4,ASIM) CALL WDIALOGFIELDSTATE(IDF_REAL5,1) CALL WDIALOGPUTREAL(IDF_REAL5,AORG) ELSE CALL WDIALOGFIELDSTATE(IDF_REAL4,2) CALL WDIALOGCLEARFIELD(IDF_REAL4) CALL WDIALOGFIELDSTATE(IDF_REAL5,2) CALL WDIALOGCLEARFIELD(IDF_REAL5) ENDIF IF(ALLOCATED(XIN)) DEALLOCATE(XIN) IF(ALLOCATED(YIN)) DEALLOCATE(YIN) IF(ALLOCATED(XSYM)) DEALLOCATE(XSYM) IF(ALLOCATED(YSYM)) DEALLOCATE(YSYM) IF(ALLOCATED(XTRAP))DEALLOCATE(XTRAP) IF(ALLOCATED(YTRAP))DEALLOCATE(YTRAP) IF(ALLOCATED(XSIM)) DEALLOCATE(XSIM) IF(ALLOCATED(YSIM)) DEALLOCATE(YSIM) !## plot 2d cross-section ELSEIF(ISCN(J).EQ.-1)THEN CALL ISGATTRIBUTES_2DCROSS_PLOT(J) ENDIF CALL WDIALOGSELECT(ID_DISGATTRIBUTES) END SUBROUTINE ISGATTRIBUTESPLOTISC !###==================================================================== SUBROUTINE ISGATTRIBUTES_2DCROSS_PLOT(J) !###==================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: J TYPE(IDFOBJ) :: IDF,PIDF REAL :: X1,X2,Y1,Y2,WIDTH,HEIGHT,ZCHK INTEGER :: IROW,ICOL,ICLR,I !## read IDF with bathemetry IF(.NOT.ISGATTRIBUTES_2DCROSS_READ(J,IDF,PIDF,ZCHK))RETURN X1=IDF%XMIN-0.5*IDF%DX; X2=IDF%XMAX+0.5*IDF%DX; Y1=IDF%YMIN-0.5*IDF%DY; Y2=IDF%YMAX+0.5*IDF%DY WIDTH =REAL(WINFODRAWABLE(DRAWABLEWIDTH)) HEIGHT=REAL(WINFODRAWABLE(DRAWABLEHEIGHT)) CALL UTL_IDFCRDCOR(X1,X2,Y1,Y2,WIDTH,HEIGHT) CALL IGRCOLOURN(WRGB(255,255,255)) CALL IGRAREA(0.0,0.0,1.0,1.0) CALL IGRAREACLEAR() CALL ISGATTRIBUTESPLOT_AXES(X1,Y1,X2,Y2,.FALSE.,'x coordinate','y coordinate') CALL IGRFILLPATTERN(SOLID) DO IROW=1,IDF%NROW; Y2=IDF%YMAX-(IROW-1)*IDF%DY; Y1=Y2-IDF%DY; DO ICOL=1,IDF%NCOL IF(IDF%X(ICOL,IROW).EQ.IDF%NODATA)CYCLE X1=IDF%XMIN+(ICOL-1)*IDF%DX; X2=X1+IDF%DX IF(ICROSS_ZVAL.NE.0)THEN ICLR=UTL_IDFGETCLASS(MP(ICROSS_ZVAL)%LEG,IDF%X(ICOL,IROW)) CALL IGRCOLOURN(ICLR) CALL IGRFILLPATTERN(SOLID) CALL IGRRECTANGLE(X1,Y1,X2,Y2) ENDIF CALL IGRCOLOURN(WRGB(0,0,0)) CALL IGRFILLPATTERN(OUTLINE) CALL IGRRECTANGLE(X1,Y1,X2,Y2) ENDDO; ENDDO !## plot conditional inundated areas CALL IGRPLOTMODE(MODEAND) CALL IGRCOLOURN(WRGB(100,100,100)) CALL IGRFILLPATTERN(SOLID) DO IROW=1,IDF%NROW; Y2=IDF%YMAX-(IROW-1)*IDF%DY; Y1=Y2-IDF%DY; DO ICOL=1,IDF%NCOL IF(IDF%X(ICOL,IROW).EQ.IDF%NODATA)CYCLE X1=IDF%XMIN+(ICOL-1)*IDF%DX; X2=X1+IDF%DX IF(PIDF%X(ICOL,IROW).LT.0.0)CALL IGRRECTANGLE(X1,Y1,X2,Y2) ENDDO; ENDDO CALL IGRPLOTMODE(MODECOPY) CALL IDFDEALLOCATEX(IDF); CALL IDFDEALLOCATEX(PIDF) CALL IGRCOLOURN(WRGB(0,0,0)) DO I=2,TISP CALL IGRJOIN(ISP2(I-1)%X,ISP2(I-1)%Y,ISP2(I)%X,ISP2(I)%Y) END DO END SUBROUTINE ISGATTRIBUTES_2DCROSS_PLOT !###==================================================================== SUBROUTINE ISGATTRIBUTESPLOTIST() !###==================================================================== IMPLICIT NONE INTEGER :: I,J,K,XMIN,XMAX,X1,X2 REAL :: Y1,Y2,YMIN,YMAX CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB4) CALL WDIALOGGETMENU(IDF_MENU1,J) I=1; IF(TIST(J).LE.1)I=3 CALL WDIALOGSELECT(ID_DISGATTRIBUTES) CALL WDIALOGFIELDSTATE(IDF_STRING1,I) CALL WDIALOGFIELDSTATE(IDF_STRING2,I) IF(I.EQ.3)THEN CALL IGRAREA(0.0,0.0,1.0,1.0) CALL IGRUNITS(0.0,0.0,1.0,1.0) CALL IGRAREACLEAR() RETURN ENDIF CALL WDIALOGGETMENU(IDF_MENU1,I) !## distance XMIN=MINVAL(DATIST2(J,1:TIST(J))%IDATE) XMAX=MAXVAL(DATIST2(J,1:TIST(J))%IDATE) XMIN=UTL_IDATETOJDATE(XMIN) XMAX=UTL_IDATETOJDATE(XMAX) !## wl_up IF(I.EQ.1)THEN YMIN=MINVAL(DATIST2(J,1:TIST(J))%WLVL_UP) YMAX=MAXVAL(DATIST2(J,1:TIST(J))%WLVL_UP) ELSEIF(I.EQ.2)THEN !## wl_down YMIN=MINVAL(DATIST2(J,1:TIST(J))%WLVL_DOWN) YMAX=MAXVAL(DATIST2(J,1:TIST(J))%WLVL_DOWN) ENDIF CALL IGRCOLOURN(WRGB(255,255,255)) CALL IGRAREA(0.0,0.0,1.0,1.0) CALL IGRAREACLEAR() CALL IGRFILLPATTERN(SOLID) IF(I.EQ.1)THEN CALL ISGATTRIBUTESPLOT_AXES(REAL(XMIN),YMIN,REAL(XMAX),YMAX,.TRUE.,'Date','Water level Upstream (m+MSL)') ELSE CALL ISGATTRIBUTESPLOT_AXES(REAL(XMIN),YMIN,REAL(XMAX),YMAX,.TRUE.,'Date','Water level Downstream (m+MSL)') ENDIF DO I=1,2 IF(I.EQ.1)THEN CALL IGRCOLOURN(WRGB(0,0,255)) DO K=1,TIST(J)-1 X1=UTL_IDATETOJDATE(DATIST2(J,K)%IDATE) X2=UTL_IDATETOJDATE(DATIST2(J,K+1)%IDATE) Y1=DATIST2(J,K)%WLVL_UP Y2=DATIST2(J,K+1)%WLVL_UP CALL IGRJOIN(REAL(X1),Y1,REAL(X2),Y1) CALL IGRJOIN(REAL(X2),Y1,REAL(X2),Y2) ENDDO ELSEIF(I.EQ.2)THEN CALL IGRCOLOURN(WRGB(0,255,0)) DO K=1,TIST(J)-1 X1=UTL_IDATETOJDATE(DATIST2(J,K)%IDATE) X2=UTL_IDATETOJDATE(DATIST2(J,K+1)%IDATE) Y1=DATIST2(J,K)%WLVL_DOWN Y2=DATIST2(J,K+1)%WLVL_DOWN CALL IGRJOIN(REAL(X1),Y1,REAL(X2),Y1) CALL IGRJOIN(REAL(X2),Y1,REAL(X2),Y2) ENDDO ENDIF END DO END SUBROUTINE ISGATTRIBUTESPLOTIST !###==================================================================== SUBROUTINE ISGATTRIBUTESPLOTISQ() !###==================================================================== IMPLICIT NONE INTEGER :: I,J,K REAL :: Y1,Y2,YMIN,YMAX,XMIN,XMAX,X1,X2,DX,DY CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB5) CALL WDIALOGGETMENU(IDF_MENU1,J) I=1; IF(TISQ(J).LE.1)I=3 CALL WDIALOGSELECT(ID_DISGATTRIBUTES) CALL WDIALOGFIELDSTATE(IDF_STRING1,I) CALL WDIALOGFIELDSTATE(IDF_STRING2,I) IF(I.EQ.3)THEN CALL IGRAREA(0.0,0.0,1.0,1.0) CALL IGRUNITS(0.0,0.0,1.0,1.0) CALL IGRAREACLEAR() RETURN ENDIF CALL WDIALOGGETMENU(IDF_MENU1,I) !## q XMIN=MINVAL(DATISQ2(J,1:TISQ(J))%Q) XMAX=MAXVAL(DATISQ2(J,1:TISQ(J))%Q) !## h YMIN=MINVAL(DATISQ2(J,1:TISQ(J))%W) YMAX=MAXVAL(DATISQ2(J,1:TISQ(J))%W) YMIN=MIN(YMIN,MINVAL(DATISQ2(J,1:TISQ(J))%D)) YMAX=MAX(YMAX,MAXVAL(DATISQ2(J,1:TISQ(J))%D)) ! YMIN=MIN(YMIN,MINVAL(DATISQ2(J,1:TISQ(J))%F)) ! YMAX=MAX(YMAX,MAXVAL(DATISQ2(J,1:TISQ(J))%F)) DX=(XMAX-XMIN)/50.0; DY=(YMAX-YMIN)/50.0 XMAX=XMAX+DX; XMIN=XMIN-DX; YMAX=YMAX+DY; YMIN=YMIN-DY CALL IGRCOLOURN(WRGB(255,255,255)) CALL IGRAREA(0.0,0.0,1.0,1.0) CALL IGRAREACLEAR() CALL IGRFILLPATTERN(SOLID) CALL ISGATTRIBUTESPLOT_AXES(REAL(XMIN),YMIN,REAL(XMAX),YMAX,.FALSE.,'Q (m3/s)','Width (m) and Depth (m)') CALL IGRLINEWIDTH(1); CALL IGRFILLPATTERN(SOLID); CALL IGRCOLOURN(WRGB(0,0,255)) DO K=1,TISQ(J) X1=DATISQ2(J,K)%Q Y1=DATISQ2(J,K)%D IF(K.LT.TISQ(J))THEN X2=DATISQ2(J,K+1)%Q Y2=DATISQ2(J,K+1)%D CALL IGRJOIN(X1,Y1,X2,Y2) ENDIF CALL IGRCIRCLE(X1,Y1,DX/2.0) ENDDO CALL IGRCOLOURN(WRGB(255,0,0)) DO K=1,TISQ(J) X1=DATISQ2(J,K)%Q Y1=DATISQ2(J,K)%W IF(K.LT.TISQ(J))THEN X2=DATISQ2(J,K+1)%Q Y2=DATISQ2(J,K+1)%W CALL IGRJOIN(X1,Y1,X2,Y2) ENDIF CALL IGRCIRCLE(X1,Y1,DX/2.0) ENDDO END SUBROUTINE ISGATTRIBUTESPLOTISQ !###==================================================================== SUBROUTINE ISGATTRIBUTESPLOTISP() !###==================================================================== IMPLICIT NONE INTEGER :: I,J,IREF,IUPSEG,JREC,MSEG,NSEG,DWNSEG REAL :: XMIN,YMIN,XMAX,YMAX,DX,DY,XMID,YMID,WIDTH,HEIGHT,X1,Y1,X,Y INTEGER :: IREC I=1; IF(TISP.LE.1)I=3 CALL WDIALOGSELECT(ID_DISGATTRIBUTES) !## hide date string CALL WDIALOGFIELDSTATE(IDF_STRING1,I) CALL WDIALOGFIELDSTATE(IDF_STRING2,I) !## always hide dropdown menu CALL WDIALOGFIELDSTATE(IDF_MENU1,3) CALL IGRCOLOURN(WRGB(255,255,255)); CALL IGRAREA(0.0,0.0,1.0,1.0); CALL IGRAREACLEAR() !## nothing to plot IF(I.EQ.3)RETURN !## distance XMIN=MINVAL(ISP2(1:TISP)%X) XMAX=MAXVAL(ISP2(1:TISP)%X) !## bottom YMIN=MINVAL(ISP2(1:TISP)%Y) YMAX=MAXVAL(ISP2(1:TISP)%Y) DX =XMAX-XMIN DY =YMAX-YMIN XMID=XMIN+DX/2.0 YMID=YMIN+DY/2.0 DX =MAX(DX,DY)*1.0 XMAX=XMID+DX; XMIN=XMID-DX YMAX=YMID+DX; YMIN=YMID-DX WIDTH =REAL(WINFODRAWABLE(DRAWABLEWIDTH)) HEIGHT=REAL(WINFODRAWABLE(DRAWABLEHEIGHT)) CALL UTL_IDFCRDCOR(XMIN,XMAX,YMIN,YMAX,WIDTH,HEIGHT) CALL ISGATTRIBUTESPLOT_AXES(REAL(XMIN),YMIN,REAL(XMAX),YMAX,.FALSE.,'x coordinate (m)','y coordinate (m)') !## draw all segments in grey CALL IGRCOLOURN(WRGB(150,150,150)); CALL IGRLINETYPE(SOLIDLINE); CALL IGRLINEWIDTH(1) DO I=1,NISG !## get correct record-number for coordinates IREC=ISG(I)%ISEG-1 !## read segments DO J=1,ISG(I)%NSEG X=ISP(IREC+J)%X; Y=ISP(IREC+J)%Y IF(J.GT.1)THEN IF(MIN(X1,X).LT.XMAX.AND.MAX(X1,X).GT.XMIN.AND. & MIN(Y1,Y).LT.YMAX.AND.MAX(Y1,Y).GT.YMIN)THEN CALL IGRJOIN(X1,Y1,X,Y) ENDIF ENDIF X1=X; Y1=Y ENDDO ENDDO !## draw current segment in red CALL IGRCOLOURN(WRGB(255,0,0)); CALL IGRLINEWIDTH(3) DO I=2,TISP; CALL IGRJOIN(ISP2(I-1)%X,ISP2(I-1)%Y,ISP2(I)%X,ISP2(I)%Y); END DO CALL IGRLINEWIDTH(1); CALL IGRCOLOURN(ICLRSF); CALL IGRFILLPATTERN(SOLID) CALL ISGPLOT_FDIRECTION(ISP2%X,ISP2%Y,TISP,XMIN,XMAX,YMIN,YMAX,1) IF(ISFR.EQ.1)THEN !## get upstream connection (first entry) IREC=ISG(ISELISG)%ICLC; IREF=ISD(IREC)%IREF !## use first defined entry for connection IUPSEG=DATISD(IREF)%UPSG IF(IUPSEG.GT.0)THEN IREC=ISG(ISELISG)%ISEG; NSEG=ISG(ISELISG)%NSEG JREC=ISG(IUPSEG)%ISEG; MSEG=ISG(IUPSEG)%NSEG CALL ISGPLOT_FCONNECTION(ISP(IREC:IREC+NSEG-1)%X,ISP(IREC:IREC+NSEG-1)%Y,NSEG, & ISP(JREC:JREC+MSEG-1)%X,ISP(JREC:JREC+MSEG-1)%Y,MSEG, & XMIN,XMAX,YMIN,YMAX,-1,1) ENDIF !## get downstream connection (second entry) IREC=ISG(ISELISG)%ICLC; IREF=ISD(IREC)%IREF+1 !## use first defined entry for connection DWNSEG=DATISD(IREF)%DWNS IF(DWNSEG.GT.0)THEN IREC=ISG(ISELISG)%ISEG; NSEG=ISG(ISELISG)%NSEG JREC=ISG(DWNSEG)%ISEG; MSEG=ISG(DWNSEG)%NSEG CALL ISGPLOT_FCONNECTION(ISP(IREC:IREC+NSEG-1)%X,ISP(IREC:IREC+NSEG-1)%Y,NSEG, & ISP(JREC:JREC+MSEG-1)%X,ISP(JREC:JREC+MSEG-1)%Y,MSEG, & XMIN,XMAX,YMIN,YMAX,1,1) ENDIF ENDIF END SUBROUTINE ISGATTRIBUTESPLOTISP !###====================================================================== SUBROUTINE ISGATTRIBUTESCOPY() !###====================================================================== IMPLICIT NONE TYPE(WIN_MESSAGE) :: MESSAGE INTEGER :: ISEL,JSEL,ITYPE,I,II,J,JJ,ITAB CALL WDIALOGSELECT(ID_DISGATTRIBUTES) CALL WDIALOGGETTAB(IDF_TAB1,ITAB) !## selected calculation point/crosssection CALL WDIALOGSELECT(ITAB) CALL WDIALOGGETMENU(IDF_MENU1,ISEL) CALL WDIALOGLOAD(ID_DCOPYLEGEND) CALL WDIALOGTITLE('Copy data from : ') IF(ITAB.EQ.ID_DISGATTRIBUTESTAB1)THEN CALL WDIALOGPUTMENU(IDF_MENU1,ISD%CNAME,NISD,1) ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB4)THEN CALL WDIALOGPUTMENU(IDF_MENU1,IST%CNAME,NIST,1) ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB5)THEN CALL WDIALOGPUTMENU(IDF_MENU1,ISQ%CNAME,NISQ,1) ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB2)THEN CALL WDIALOGPUTMENU(IDF_MENU1,ISC%CNAME,NISC,1) ENDIF CALL WDIALOGSHOW(-1,-1,0,3) JSEL=0 DO WHILE(.TRUE.) CALL WMESSAGE(ITYPE,MESSAGE) IF(ITYPE.EQ.PUSHBUTTON.AND.MESSAGE%VALUE1.EQ.IDCANCEL)EXIT IF(ITYPE.EQ.PUSHBUTTON.AND.MESSAGE%VALUE1.EQ.IDOK)THEN CALL WDIALOGGETMENU(IDF_MENU1,JSEL) EXIT ENDIF END DO CALL WDIALOGUNLOAD() IF(JSEL.EQ.0)RETURN IF(ITAB.EQ.ID_DISGATTRIBUTESTAB1)THEN I=ISD(JSEL)%IREF; J=I+ISD(JSEL)%N-1 JJ=0; DO II=I,J JJ=JJ+1; DATISD2(ISEL,JJ)=DATISD(II) ENDDO ! DATISD2(ISEL,1:J-I+1)=DATISD(I:J) TISD(ISEL)=ISD(JSEL)%N CALL ISGATTRIBUTESPUTISDVALUES() ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB2)THEN I=ISC(JSEL)%IREF; J=I+ISC(JSEL)%N-1 JJ=0; DO II=I,J JJ=JJ+1; DATISC2(ISEL,JJ)=DATISC(II) ENDDO ! DATISC2(ISEL,1:J-I+1)=DATISC(I:J) TISC(ISEL)=ISC(JSEL)%N CALL ISGATTRIBUTESPUTISCVALUES() ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB4)THEN I=IST(JSEL)%IREF; J=I+IST(JSEL)%N-1 JJ=0; DO II=I,J JJ=JJ+1; DATIST2(ISEL,JJ)=DATIST(II) ENDDO ! DATIST2(ISEL,1:J-I+1)=DATIST(I:J) TIST(ISEL)=IST(JSEL)%N CALL ISGATTRIBUTESPUTISTVALUES() ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB5)THEN I=ISQ(JSEL)%IREF; J=I+ISQ(JSEL)%N-1 JJ=0; DO II=I,J JJ=JJ+1; DATISQ2(ISEL,JJ)=DATISQ(II) ENDDO ! DATISQ2(ISEL,1:J-I+1)=DATISQ(I:J) TISQ(ISEL)=ISQ(JSEL)%N CALL ISGATTRIBUTESPUTISQVALUES() ENDIF CALL ISGATTRIBUTESUPDATEPLOTS() END SUBROUTINE ISGATTRIBUTESCOPY !###====================================================================== SUBROUTINE ISGATTRIBUTESRENAME() !###====================================================================== IMPLICIT NONE TYPE(WIN_MESSAGE) :: MESSAGE INTEGER :: ITYPE,ISEL,I,J,ITAB CHARACTER(LEN=30) :: CVALUE CALL WDIALOGSELECT(ID_DISGATTRIBUTES) CALL WDIALOGGETTAB(IDF_TAB1,ITAB) CALL WDIALOGLOAD(ID_DSCENNAME,ID_DSCENNAME) CALL WDIALOGTITLE('Give New Name : ') CALL WDIALOGPUTSTRING(IDOK,'Save and Close') IF(ITAB.EQ.ID_DISGATTRIBUTESTAB1)THEN CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB1) CALL WDIALOGGETMENU(IDF_MENU1,ISEL) CALL WDIALOGSELECT(ID_DSCENNAME) CALL WDIALOGPUTSTRING(IDF_GROUP1,'Rename Calculation Point') I=ISG(ISELISG)%ICLC J=I+ISG(ISELISG)%NCLC-1 CALL WDIALOGPUTMENU(IDF_MENU1,ISD(I:J)%CNAME,ISG(ISELISG)%NCLC,ISEL) ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB2)THEN CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB2) CALL WDIALOGGETMENU(IDF_MENU1,ISEL) CALL WDIALOGSELECT(ID_DSCENNAME) CALL WDIALOGPUTSTRING(IDF_GROUP1,'Rename Cross-Section') I=ISG(ISELISG)%ICRS J=I+ISG(ISELISG)%NCRS-1 CALL WDIALOGPUTMENU(IDF_MENU1,ISC(I:J)%CNAME,ISG(ISELISG)%NCRS,ISEL) ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB4)THEN CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB4) CALL WDIALOGGETMENU(IDF_MENU1,ISEL) CALL WDIALOGSELECT(ID_DSCENNAME) CALL WDIALOGPUTSTRING(IDF_GROUP1,'Rename Structure') I=ISG(ISELISG)%ISTW J=I+ISG(ISELISG)%NSTW-1 CALL WDIALOGPUTMENU(IDF_MENU1,IST(I:J)%CNAME,ISG(ISELISG)%NSTW,ISEL) ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB5)THEN CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB5) CALL WDIALOGGETMENU(IDF_MENU1,ISEL) CALL WDIALOGSELECT(ID_DSCENNAME) CALL WDIALOGPUTSTRING(IDF_GROUP1,'Rename Qh-relationship') I=ISG(ISELISG)%IQHR J=I+ISG(ISELISG)%NQHR-1 CALL WDIALOGPUTMENU(IDF_MENU1,ISQ(I:J)%CNAME,ISG(ISELISG)%NQHR,ISEL) ENDIF CALL WDIALOGSHOW(0,0,-1,3) DO CALL WMESSAGE(ITYPE,MESSAGE) IF(ITYPE.EQ.PUSHBUTTON)THEN SELECT CASE(MESSAGE%VALUE1) CASE(IDOK,IDCANCEL) EXIT CASE(IDHELP) CALL IMODGETHELP('4.4.3.2','MMO.IGO.IE.Attr') END SELECT ENDIF ENDDO CALL WDIALOGGETMENU(IDF_MENU1,ITYPE,CVALUE) CALL WDIALOGUNLOAD() IF(MESSAGE%VALUE1.EQ.IDCANCEL)RETURN IF(ITAB.EQ.ID_DISGATTRIBUTESTAB1)THEN CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB1) ISD(I+ISEL-1)%CNAME=CVALUE CALL WDIALOGPUTMENU(IDF_MENU1,ISD(I:J)%CNAME,ISG(ISELISG)%NCLC,ISEL) ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB2)THEN CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB2) ISC(I+ISEL-1)%CNAME=CVALUE CALL WDIALOGPUTMENU(IDF_MENU1,ISC(I:J)%CNAME,ISG(ISELISG)%NCRS,ISEL) ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB4)THEN CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB4) IST(I+ISEL-1)%CNAME=CVALUE CALL WDIALOGPUTMENU(IDF_MENU1,IST(I:J)%CNAME,ISG(ISELISG)%NSTW,ISEL) ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB5)THEN CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB5) ISQ(I+ISEL-1)%CNAME=CVALUE CALL WDIALOGPUTMENU(IDF_MENU1,ISQ(I:J)%CNAME,ISG(ISELISG)%NQHR,ISEL) ENDIF CALL WDIALOGSELECT(ID_DISGATTRIBUTES) CALL ISGATTRIBUTESUPDATEPLOTS() END SUBROUTINE ISGATTRIBUTESRENAME !###==================================================================== SUBROUTINE ISGPOSITIONCRSCLC(ID) !###==================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ID INTEGER :: IDIST REAL :: XINTER,YINTER ! DO ISELISG=NISG,1,-1 ! J=ISG(ISELISG)%ISEG ! XINTER=(ISP(J)%X+ISP(J+1)%X)/2.0 ! YINTER=(ISP(J)%Y+ISP(J+1)%Y)/2.0 ! CALL ISGQHADD(J,XINTER,YINTER) ! ENDDO ! RETURN IF(ISFR.EQ.1)THEN IF(ID.NE.ID_DELETEQH.AND.ID.NE.ID_ADDQH)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You may not modify any of the attributes on a segment'//CHAR(13)// & 'whenever your ISG file is used for an SFR-package','Information') RETURN ENDIF ENDIF IF(ID.EQ.ID_DELETECROSSSECTION)THEN IF(ISG(ISELISG)%NCRS.LE.1)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You may not remove the last cross-section!'//CHAR(13)// & 'Each segment needs at least 1 cross-section','Information') RETURN ENDIF ELSEIF(ID.EQ.ID_DELETECALCPOINT)THEN IF(ISG(ISELISG)%NCLC.LE.2)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You may not remove the last TWO Calculation Points!'//CHAR(13)// & 'Each segment needs at least 2 Calculation Points','Information') RETURN ENDIF ENDIF !## get position in x/y coordinates and first coming node after x/y coordinates IF(ID.EQ.ID_ADDCALCPOINT.OR. & ID.EQ.ID_DELETECALCPOINT.OR. & ID.EQ.ID_MOVECALCPOINT)CALL ISGGETPOS(1,IDIST,XINTER,YINTER) IF(ID.EQ.ID_ADDCROSSSECTION.OR. & ID.EQ.ID_DELETECROSSSECTION.OR. & ID.EQ.ID_MOVECROSSSECTION)CALL ISGGETPOS(2,IDIST,XINTER,YINTER) IF(ID.EQ.ID_ADDWEIR.OR. & ID.EQ.ID_DELETEWEIR.OR. & ID.EQ.ID_MOVEWEIR)CALL ISGGETPOS(3,IDIST,XINTER,YINTER) IF(ID.EQ.ID_ADDQH.OR. & ID.EQ.ID_DELETEQH.OR. & ID.EQ.ID_MOVEQH)CALL ISGGETPOS(4,IDIST,XINTER,YINTER) IF(IDIST.LE.0)RETURN IF(ID.EQ.ID_ADDCROSSSECTION) CALL ISGCROSSSECTIONADD(IDIST,XINTER,YINTER) IF(ID.EQ.ID_DELETECROSSSECTION)CALL ISGCROSSSECTIONDELETE(IDIST,XINTER,YINTER) IF(ID.EQ.ID_MOVECROSSSECTION) CALL ISGCROSSSECTIONMOVE(IDIST,XINTER,YINTER) IF(ID.EQ.ID_ADDCALCPOINT) CALL ISGCALCPOINTADD(IDIST,XINTER,YINTER) IF(ID.EQ.ID_DELETECALCPOINT) CALL ISGCALCPOINTDELETE(IDIST,XINTER,YINTER) IF(ID.EQ.ID_MOVECALCPOINT) CALL ISGCALCPOINTMOVE(IDIST,XINTER,YINTER) IF(ID.EQ.ID_ADDWEIR) CALL ISGWEIRADD(IDIST,XINTER,YINTER) IF(ID.EQ.ID_DELETEWEIR) CALL ISGWEIRDELETE(IDIST,XINTER,YINTER) IF(ID.EQ.ID_MOVEWEIR) CALL ISGWEIRMOVE(IDIST,XINTER,YINTER) IF(ID.EQ.ID_ADDQH) CALL ISGQHADD(IDIST,XINTER,YINTER) IF(ID.EQ.ID_DELETEQH) CALL ISGQHDELETE(IDIST,XINTER,YINTER) IF(ID.EQ.ID_MOVEQH) CALL ISGQHMOVE(IDIST,XINTER,YINTER) END SUBROUTINE ISGPOSITIONCRSCLC !###==================================================================== SUBROUTINE ISGCROSSSECTIONADD(IDIST,XINTER,YINTER) !###==================================================================== IMPLICIT NONE REAL,INTENT(IN) :: XINTER,YINTER INTEGER,INTENT(IN) :: IDIST INTEGER :: N,IPOS,ISEG REAL :: TDIST CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Do you want to SAVE Added Cross-Section?','Question') IF(WINFODIALOG(4).NE.1)RETURN !## get distance on segment CALL ISGGETPOSDISTANCE(XINTER,YINTER,TDIST,IDIST) !## get nearest id and record-position CALL ISGGETPOSID(TDIST,IPOS,2) N=3 !## increase memory CALL ISGMEMORYISC(1,ISELISG,IPOS) ISC(IPOS)%N =0 ISC(IPOS)%IREF =NDISC+1 ISC(IPOS)%DIST =TDIST ISC(IPOS)%CNAME='C.Section '//TRIM(ITOS(ISG(ISELISG)%NCRS)) CALL ISGMEMORYDATISC(N,IPOS,ISEG) DATISC(ISEG)%DISTANCE =-5.0 DATISC(ISEG)%BOTTOM = 5.0 DATISC(ISEG)%MRC =0.03 DATISC(ISEG+1)%DISTANCE= 0.0 DATISC(ISEG+1)%BOTTOM = 0.0 DATISC(ISEG+1)%MRC =0.03 DATISC(ISEG+2)%DISTANCE= 5.0 DATISC(ISEG+2)%BOTTOM = 5.0 DATISC(ISEG+2)%MRC =0.03 CALL IDFPLOTFAST(1) END SUBROUTINE ISGCROSSSECTIONADD !###==================================================================== SUBROUTINE ISGCROSSSECTIONDELETE(IDIST,XINTER,YINTER) !###==================================================================== IMPLICIT NONE REAL,INTENT(IN) :: XINTER,YINTER INTEGER,INTENT(IN) :: IDIST REAL :: TDIST INTEGER :: IPOS !#get distance on segment CALL ISGGETPOSDISTANCE(XINTER,YINTER,TDIST,IDIST) !#get nearest id and record-position CALL ISGGETPOSID(TDIST,IPOS,2) CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Are you sure to delete the selected cross-section: [ '// & TRIM(ISC(IPOS)%CNAME)//' ]','Question') IF(WINFODIALOG(4).NE.1)RETURN CALL ISGDELISC(ISELISG,IPOS) CALL IDFPLOTFAST(1) END SUBROUTINE ISGCROSSSECTIONDELETE !###==================================================================== SUBROUTINE ISGCROSSSECTIONMOVE(IDIST,XINTER,YINTER) !###==================================================================== IMPLICIT NONE REAL,INTENT(IN) :: XINTER,YINTER INTEGER,INTENT(IN) :: IDIST REAL :: TDIST,X,Y INTEGER :: JDIST,IPOS !## get distance on segment CALL ISGGETPOSDISTANCE(XINTER,YINTER,TDIST,IDIST) IF(IDIST.LE.0)RETURN !## get nearest id and record-position CALL ISGGETPOSID(TDIST,IPOS,2) CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Are you sure to move the selected cross-section: [ '// & TRIM(ISC(IPOS)%CNAME)//' ]','Question') IF(WINFODIALOG(4).NE.1)RETURN !## get new position !## get position in x/y coordinates and first coming node after x/y coordinates CALL ISGGETPOS(2,JDIST,X,Y) IF(JDIST.LE.0)RETURN !## get distance on segment CALL ISGGETPOSDISTANCE(X,Y,TDIST,JDIST) ISC(IPOS)%DIST=TDIST CALL IDFPLOTFAST(1) END SUBROUTINE ISGCROSSSECTIONMOVE !###==================================================================== SUBROUTINE ISGCALCPOINTADD(IDIST,XINTER,YINTER) !###==================================================================== IMPLICIT NONE REAL,INTENT(IN) :: XINTER,YINTER INTEGER,INTENT(IN) :: IDIST INTEGER :: IPOS,N,ISEG REAL :: TDIST CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Do you want to SAVE Added Calculation Point ? ','Question') IF(WINFODIALOG(4).NE.1)RETURN !## get distance on segment CALL ISGGETPOSDISTANCE(XINTER,YINTER,TDIST,IDIST) !## get nearest id and record-position CALL ISGGETPOSID(TDIST,IPOS,1) N=1 !## increase memory CALL ISGMEMORYISD(1,ISELISG,IPOS) ISD(IPOS)%N =0 ISD(IPOS)%IREF =NDISD+1 ISD(IPOS)%DIST =TDIST ISD(IPOS)%CNAME='Calc.Pnt '//TRIM(ITOS(ISG(ISELISG)%NCLC)) CALL ISGMEMORYDATISD(N,IPOS,ISEG) IF(ISFR.EQ.0)THEN DATISD(ISEG)%IDATE=UTL_GETCURRENTDATE() DATISD(ISEG)%WLVL =1.0 DATISD(ISEG)%BTML =0.0 DATISD(ISEG)%RESIS=1.0 DATISD(ISEG)%INFF =0.3 ELSEIF(ISFR.EQ.1)THEN DATISD(ISEG)%IDATE=UTL_GETCURRENTDATE() DATISD(ISEG)%CTIME=UTL_GETCURRENTTIME() DATISD(ISEG)%WLVL =1.0 DATISD(ISEG)%BTML =0.0 DATISD(ISEG)%WIDTH=1.0 DATISD(ISEG)%THCK =1.0 DATISD(ISEG)%HCND =1.0 DATISD(ISEG)%QFLW =0.0 DATISD(ISEG)%QROF =0.0 DATISD(ISEG)%PPTSW =0.0 DATISD(ISEG)%ETSW =0.0 DATISD(ISEG)%UPSG =0 DATISD(ISEG)%DWNS =0 DATISD(ISEG)%ICLC =1 DATISD(ISEG)%IPRI =1 ENDIF CALL IDFPLOTFAST(1) END SUBROUTINE ISGCALCPOINTADD !###==================================================================== SUBROUTINE ISGCALCPOINTDELETE(IDIST,XINTER,YINTER) !###==================================================================== IMPLICIT NONE REAL,INTENT(IN) :: XINTER,YINTER INTEGER,INTENT(IN) :: IDIST REAL :: TDIST INTEGER :: IPOS !#get distance on segment CALL ISGGETPOSDISTANCE(XINTER,YINTER,TDIST,IDIST) !#get nearest id and record-position CALL ISGGETPOSID(TDIST,IPOS,1) CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Are you sure to delete the selected Calculation Point : [ '// & TRIM(ISD(IPOS)%CNAME)//' ]','Question') IF(WINFODIALOG(4).NE.1)RETURN CALL ISGDELISD(ISELISG,IPOS) CALL IDFPLOTFAST(1) END SUBROUTINE ISGCALCPOINTDELETE !###==================================================================== SUBROUTINE ISGCALCPOINTMOVE(IDIST,XINTER,YINTER) !###==================================================================== IMPLICIT NONE REAL,INTENT(IN) :: XINTER,YINTER INTEGER,INTENT(IN) :: IDIST REAL :: TDIST,X,Y INTEGER :: JDIST,IPOS !#get distance on segment CALL ISGGETPOSDISTANCE(XINTER,YINTER,TDIST,IDIST) IF(IDIST.LE.0)RETURN !#get nearest id and record-position CALL ISGGETPOSID(TDIST,IPOS,1) CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Are you sure to move the selected Calculation Point : [ '// & TRIM(ISD(IPOS)%CNAME)//' ]','Question') IF(WINFODIALOG(4).NE.1)RETURN !##get new position !##get position in x/y coordinates and first coming node after x/y coordinates CALL ISGGETPOS(2,JDIST,X,Y) IF(JDIST.LE.0)RETURN !#get distance on segment CALL ISGGETPOSDISTANCE(X,Y,TDIST,JDIST) ISD(IPOS)%DIST=TDIST CALL IDFPLOTFAST(1) END SUBROUTINE ISGCALCPOINTMOVE !###==================================================================== SUBROUTINE ISGWEIRADD(IDIST,XINTER,YINTER) !###==================================================================== IMPLICIT NONE REAL,INTENT(IN) :: XINTER,YINTER INTEGER,INTENT(IN) :: IDIST INTEGER :: IPOS,N,ISEG REAL :: TDIST CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Do you want to SAVE Added Structure ? ','Question') IF(WINFODIALOG(4).NE.1)RETURN !#get distance on segment CALL ISGGETPOSDISTANCE(XINTER,YINTER,TDIST,IDIST) !#get nearest id and record-position CALL ISGGETPOSID(TDIST,IPOS,3) N=1 !##increase memory CALL ISGMEMORYIST(1,ISELISG,IPOS) IST(IPOS)%N =0 IST(IPOS)%IREF =NDIST+1 IST(IPOS)%DIST =TDIST IST(IPOS)%CNAME='Weir '//TRIM(ITOS(ISG(ISELISG)%NSTW)) CALL ISGMEMORYDATIST(N,IPOS,ISEG) DATIST(ISEG)%IDATE =UTL_GETCURRENTDATE() !20081104 DATIST(ISEG)%WLVL_UP =1.0 DATIST(ISEG)%WLVL_DOWN=0.0 CALL IDFPLOTFAST(1) END SUBROUTINE ISGWEIRADD !###==================================================================== SUBROUTINE ISGWEIRDELETE(IDIST,XINTER,YINTER) !###==================================================================== IMPLICIT NONE REAL,INTENT(IN) :: XINTER,YINTER INTEGER,INTENT(IN) :: IDIST REAL :: TDIST INTEGER :: IPOS !#get distance on segment CALL ISGGETPOSDISTANCE(XINTER,YINTER,TDIST,IDIST) !#get nearest id and record-position CALL ISGGETPOSID(TDIST,IPOS,3) CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Are you sure to delete the selected Structure : [ '// & TRIM(IST(IPOS)%CNAME)//' ]','Question') IF(WINFODIALOG(4).NE.1)RETURN CALL ISGDELIST(ISELISG,IPOS) CALL IDFPLOTFAST(1) END SUBROUTINE ISGWEIRDELETE !###==================================================================== SUBROUTINE ISGWEIRMOVE(IDIST,XINTER,YINTER) !###==================================================================== IMPLICIT NONE REAL,INTENT(IN) :: XINTER,YINTER INTEGER,INTENT(IN) :: IDIST REAL :: TDIST,X,Y INTEGER :: JDIST,IPOS !#get distance on segment CALL ISGGETPOSDISTANCE(XINTER,YINTER,TDIST,IDIST) IF(IDIST.LE.0)RETURN !#get nearest id and record-position CALL ISGGETPOSID(TDIST,IPOS,3) CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Are you sure to move the selected Structure : [ '// & TRIM(IST(IPOS)%CNAME)//' ]','Question') IF(WINFODIALOG(4).NE.1)RETURN !##get new position !##get position in x/y coordinates and first coming node after x/y coordinates CALL ISGGETPOS(3,JDIST,X,Y) IF(JDIST.LE.0)RETURN !#get distance on segment CALL ISGGETPOSDISTANCE(X,Y,TDIST,JDIST) IST(IPOS)%DIST=TDIST CALL IDFPLOTFAST(1) END SUBROUTINE ISGWEIRMOVE !###==================================================================== SUBROUTINE ISGQHADD(IDIST,XINTER,YINTER) !###==================================================================== IMPLICIT NONE REAL,INTENT(IN) :: XINTER,YINTER INTEGER,INTENT(IN) :: IDIST INTEGER :: IPOS,N,ISEG REAL :: TDIST ! CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Do you want to SAVE Added Qh-relationship ?','Question') ! IF(WINFODIALOG(4).NE.1)RETURN !## get distance on segment CALL ISGGETPOSDISTANCE(XINTER,YINTER,TDIST,IDIST) !## get nearest id and record-position CALL ISGGETPOSID(TDIST,IPOS,4) N=3 !## increase memory CALL ISGMEMORYISQ(1,ISELISG,IPOS) ISQ(IPOS)%N =0 ISQ(IPOS)%IREF =NDISQ+1 ISQ(IPOS)%DIST =TDIST ISQ(IPOS)%CNAME='QH '//TRIM(ITOS(ISG(ISELISG)%NQHR)) CALL ISGMEMORYDATISQ(N,IPOS,ISEG) DATISQ(ISEG)%Q = 10.0 DATISQ(ISEG)%W = 10.0 DATISQ(ISEG)%D = 5.0 DATISQ(ISEG)%F = 1.0 DATISQ(ISEG+1)%Q= 50.0 DATISQ(ISEG+1)%W= 25.0 DATISQ(ISEG+1)%D= 10.0 DATISQ(ISEG+1)%F= 1.0 DATISQ(ISEG+2)%Q=150.0 DATISQ(ISEG+2)%W= 50.0 DATISQ(ISEG+2)%D= 15.0 DATISQ(ISEG+2)%F= 1.0 ! CALL IDFPLOTFAST(1) END SUBROUTINE ISGQHADD !###==================================================================== SUBROUTINE ISGQHDELETE(IDIST,XINTER,YINTER) !###==================================================================== IMPLICIT NONE REAL,INTENT(IN) :: XINTER,YINTER INTEGER,INTENT(IN) :: IDIST REAL :: TDIST INTEGER :: IPOS !#get distance on segment CALL ISGGETPOSDISTANCE(XINTER,YINTER,TDIST,IDIST) !#get nearest id and record-position CALL ISGGETPOSID(TDIST,IPOS,4) CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Are you sure to delete the selected Qh-relationship : [ '// & TRIM(ISQ(IPOS)%CNAME)//' ]','Question') IF(WINFODIALOG(4).NE.1)RETURN CALL ISGDELISQ(ISELISG,IPOS) CALL IDFPLOTFAST(1) END SUBROUTINE ISGQHDELETE !###==================================================================== SUBROUTINE ISGQHMOVE(IDIST,XINTER,YINTER) !###==================================================================== IMPLICIT NONE REAL,INTENT(IN) :: XINTER,YINTER INTEGER,INTENT(IN) :: IDIST REAL :: TDIST,X,Y INTEGER :: JDIST,IPOS !#get distance on segment CALL ISGGETPOSDISTANCE(XINTER,YINTER,TDIST,IDIST) IF(IDIST.LE.0)RETURN !#get nearest id and record-position CALL ISGGETPOSID(TDIST,IPOS,4) CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Are you sure to move the selected Qh-relationship : [ '// & TRIM(ISQ(IPOS)%CNAME)//' ]','Question') IF(WINFODIALOG(4).NE.1)RETURN !##get new position !##get position in x/y coordinates and first coming node after x/y coordinates CALL ISGGETPOS(4,JDIST,X,Y) IF(JDIST.LE.0)RETURN !#get distance on segment CALL ISGGETPOSDISTANCE(X,Y,TDIST,JDIST) ISQ(IPOS)%DIST=TDIST CALL IDFPLOTFAST(1) END SUBROUTINE ISGQHMOVE !###==================================================================== SUBROUTINE ISGGETPOS(ISHAPE,IDIST,XINTER,YINTER) !###==================================================================== ! idist=first coming node in xyISG()-vector after xinter,yinter IMPLICIT NONE INTEGER,INTENT(OUT) :: IDIST INTEGER,INTENT(IN) :: ISHAPE REAL,INTENT(OUT) :: XINTER,YINTER TYPE(WIN_MESSAGE) :: MESSAGE INTEGER :: ITYPE,ISTATUS,ISEG,I REAL :: DX,DY,X1,X2,X3,X4,X5,Y1,Y2,Y3,Y4,Y5,DIST,TDIST,D D=(MPW%XMAX-MPW%XMIN)/200.0 CALL IDFPLOT1BITMAP() CALL IGRPLOTMODE(MODEXOR) ICLRSD=INVERSECOLOUR(ICLRSD) ICLRSC=INVERSECOLOUR(ICLRSC) X5 =0.0 Y5 =0.0 IDIST=0 DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE (MOUSEBUTDOWN) SELECT CASE (MESSAGE%VALUE1) CASE (1) EXIT CASE (3) IDIST=0 EXIT END SELECT CASE (MOUSEMOVE) CALL IDFPLOT1BITMAP() CALL ISGPLOTSHAPE(ISHAPE,X5,Y5,D,D) I =0 DO ISEG=ISG(ISELISG)%ISEG+1,ISG(ISELISG)%ISEG+ISG(ISELISG)%NSEG-1 DX=ISP(ISEG)%X-ISP(ISEG-1)%X DY=ISP(ISEG)%Y-ISP(ISEG-1)%Y X1=ISP(ISEG-1)%X Y1=ISP(ISEG-1)%Y X2=ISP(ISEG)%X Y2=ISP(ISEG)%Y X3=MESSAGE%GX Y3=MESSAGE%GY X4=X3-DY Y4=Y3+DX CALL IGRINTERSECTLINE(X1,Y1,X2,Y2,X3,Y3,X4,Y4,XINTER,YINTER,ISTATUS) IF(ISTATUS.EQ.3.OR.ISTATUS.EQ.5)THEN DIST=SQRT((XINTER-X3)**2.0+(YINTER-Y3)**2.0) IF(I.EQ.0)THEN I =1 TDIST=DIST IDIST=ISEG X5 =XINTER Y5 =YINTER ELSE IF(DIST.LT.TDIST)THEN TDIST=DIST IDIST=ISEG X5 =XINTER Y5 =YINTER ENDIF ENDIF ENDIF ENDDO CALL ISGPLOTSHAPE(ISHAPE,X5,Y5,D,D) CALL IDFPLOT2BITMAP() END SELECT ENDDO !## remove cross-section from CALL IDFPLOT1BITMAP() CALL ISGPLOTSHAPE(ISHAPE,X5,Y5,D,D) CALL IDFPLOT2BITMAP() CALL IGRPLOTMODE(MODECOPY) ICLRSD=INVERSECOLOUR(ICLRSD) ICLRSC=INVERSECOLOUR(ICLRSC) XINTER=X5 YINTER=Y5 END SUBROUTINE ISGGETPOS !###====================================================================== SUBROUTINE ISGISP_MENUFIELDS(ICODE) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ICODE INTEGER :: I,J CALL WINDOWSELECT(0) !## stop editing IF(ICODE.EQ.0)THEN I=1; J=0 !## start editing ELSE I=0; J=1 ENDIF !## deactivate start editing option CALL WMENUSETSTATE(ID_ISGISPSTART,1,I) !## activate options CALL WMENUSETSTATE(ID_ISGISPRESET,1,J) CALL WMENUSETSTATE(ID_ISGISPSAVE,1,J) CALL WMENUSETSTATE(ID_ISGISPSTOP,1,J) END SUBROUTINE ISGISP_MENUFIELDS !###====================================================================== SUBROUTINE ISGISPSTART() !###====================================================================== IMPLICIT NONE INTEGER :: NSEG,IOS,I,J,N,M CALL ISGISP_MENUFIELDS(1) NSEG=ISG(ISELISG)%NSEG !## copy coordinates - to shape definition SHPNO =MAXSHAPES+1 SHPI =MAXSHAPES+1 SHPIACT(SHPI) =1 SHPNAME(SHPI) =ISG(ISELISG)%SNAME SHPCOLOR(SHPI)=WRGB(0,255,0) SHPNCRD(SHPI) =NSEG SHPTYPE(SHPI) =ID_LINE SHPWIDTH(SHPI)=3 !## maximum is for UTL_INSIDEPOLYGON etc. IF(ASSOCIATED(SHPXC))THEN IF(SIZE(SHPXC,1).LT.NSEG.OR.SIZE(SHPXC,2).LT.SHPNO)THEN ALLOCATE(CSHPXC(NSEG,MAXSHAPES+1),STAT=IOS) N=SIZE(SHPXC,1); M=SIZE(SHPXC,2) DO I=1,N; DO J=1,M; CSHPXC(I,J)=SHPXC(I,J); ENDDO; ENDDO DEALLOCATE(SHPXC); SHPXC=>CSHPXC ENDIF ENDIF IF(ASSOCIATED(SHPYC))THEN IF(SIZE(SHPYC,1).LT.NSEG.OR.SIZE(SHPYC,2).LT.SHPNO)THEN ALLOCATE(CSHPYC(NSEG,MAXSHAPES+1)) N=SIZE(SHPYC,1); M=SIZE(SHPYC,2) DO I=1,N; DO J=1,M; CSHPYC(I,J)=SHPYC(I,J); ENDDO; ENDDO DEALLOCATE(SHPYC); SHPYC=>CSHPYC ENDIF ENDIF I=ISG(ISELISG)%ISEG; J=I+NSEG-1 SHPXC(1:NSEG,SHPI)=ISP(I:J)%X SHPYC(1:NSEG,SHPI)=ISP(I:J)%Y CALL POLYGON1DRAWSHAPE(SHPNO,SHPNO) END SUBROUTINE ISGISPSTART !###====================================================================== SUBROUTINE ISGISPRESET() !###====================================================================== IMPLICIT NONE INTEGER :: I,J,NSEG !## remove current line CALL POLYGON1DRAWSHAPE(SHPNO,SHPNO) SHPI =MAXSHAPES+1 SHPNO=SHPI I =ISG(ISELISG)%ISEG NSEG=ISG(ISELISG)%NSEG J =I+NSEG-1 SHPNCRD(SHPI)=NSEG SHPXC(1:NSEG,SHPI)=ISP(I:J)%X SHPYC(1:NSEG,SHPI)=ISP(I:J)%Y !## draw new line CALL POLYGON1DRAWSHAPE(1,SHPNO) END SUBROUTINE ISGISPRESET !###====================================================================== SUBROUTINE ISGISPSAVE() !###====================================================================== IMPLICIT NONE INTEGER :: I,J,DN REAL :: TD SHPI=MAXSHAPES+1 DN =SHPNCRD(SHPI)-ISG(ISELISG)%NSEG !## increase memory CALL ISGMEMORYISP(DN,ISELISG,J) TD=0.0 DO I=1,SHPNCRD(SHPI) ISP(J+I-1)%X=SHPXC(I,SHPI) ISP(J+I-1)%Y=SHPYC(I,SHPI) IF(I.GE.2)TD=TD+SQRT((SHPXC(I,SHPI)-SHPXC(I-1,SHPI))**2.0+(SHPYC(I,SHPI)-SHPYC(I-1,SHPI))**2.0) ENDDO CALL ISGISPADJUST(TD) CALL IDFPLOTFAST(1) END SUBROUTINE ISGISPSAVE !###====================================================================== SUBROUTINE ISGISPADJUST(TD) !###====================================================================== IMPLICIT NONE REAL,INTENT(IN) :: TD REAL :: D INTEGER :: I,J !## make sure calculation points do not exceed new segment length DO I=ISG(ISELISG)%ICLC,ISG(ISELISG)%ICLC+ISG(ISELISG)%NCLC-1 IF(ISD(I)%DIST.GT.TD)ISD(I)%DIST=TD END DO !## find max. to be maximum now again D=0.0 DO I=ISG(ISELISG)%ICLC,ISG(ISELISG)%ICLC+ISG(ISELISG)%NCLC-1 IF(ISD(I)%DIST.GT.D)THEN D=ISD(I)%DIST J=I ENDIF END DO ISD(J)%DIST=TD !## make sure cross-section do not exceed new segment length DO I=ISG(ISELISG)%ICRS,ISG(ISELISG)%ICRS+ISG(ISELISG)%NCRS-1 IF(ISC(I)%DIST.GT.TD)ISC(I)%DIST=TD END DO END SUBROUTINE ISGISPADJUST !###====================================================================== SUBROUTINE ISGISPSTOP(CODE) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: CODE CHARACTER(LEN=256) :: ISGFILE !## stop isg-segment editing CALL ISGISP_MENUFIELDS(0) IF(CODE.EQ.0)THEN IDIAGERROR=0; IF(ISELISG.EQ.0)RETURN ENDIF IDIAGERROR=1 IF(CODE.EQ.1)THEN CALL WMESSAGEBOX(YESNOCANCEL,QUESTIONICON,COMMONCANCEL,'Would you like to SAVE to file before leaving choose [Yes]'//CHAR(13)// & 'Leave without saving choose [No]','Question') !## cancel IF(WINFODIALOG(4).EQ.0)RETURN !## save first before leaving IF(WINFODIALOG(4).EQ.1)THEN ISGFILE=ISGFNAME; CALL ISGSAVE(ISGFILE,2) ENDIF ENDIF ! !## none selected ! ISELISG=0 !## remove current line CALL POLYGON1DRAWSHAPE(SHPNO,SHPNO) SHPNO=ISGSHAPES ! CALL WCURSORSHAPE(CURARROW) IDIAGERROR=0 END SUBROUTINE ISGISPSTOP !###====================================================================== SUBROUTINE ISGCHECKISG(X,Y,CODE) !###====================================================================== IMPLICIT NONE REAL,PARAMETER :: SCALEXY=1.0/100.0 INTEGER,INTENT(IN) :: CODE REAL,INTENT(IN) :: X,Y REAL :: DX,DY,MINDIST INTEGER :: ITAB LOGICAL :: LEX DX=((MPW%XMAX-MPW%XMIN)*SCALEXY)**2.0 DY=((MPW%YMAX-MPW%YMIN)*SCALEXY)**2.0 MINDIST=SQRT(DX+DY) CALL WDIALOGSELECT(ID_DISGEDIT) CALL WDIALOGGETTAB(IDF_TAB,ITAB) LEX=.FALSE. !## mouse used IF(CODE.EQ.0)THEN !## wrong tab-selected - do not do anything IF(ITAB.NE.ID_DISGEDITTAB1)RETURN !---- OLD ! ! IF(ISELISG.NE.0)RETURN ! !## select new one ! LEX=ISGGETSEGMENT(X,Y,ISELISG) ! !---- !## check if shift/ctrl button is pressed as well - than add to selection !## already selected something, remove it ! IF(ISELISG.NE.0)THEN ! !## no key pressed, unselect automatically ! IF(GKEYPRESSED.EQ.0)ISELISG=0 !CALL ISGISPSTOP(0) ! ENDIF !## select new one LEX=ISGGETSEGMENT(X,Y,0,ISELISG,MINDIST,0) !## if ctrl pressed, add line to selection IF(IDOWN.EQ.5)THEN !MODCTRL)THEN IF(LEX)ISG(ISELISG)%ILIST=1 ELSE !## single line selected, remove previous one and draw this new one ISG%ILIST=0; IF(LEX)ISG(ISELISG)%ILIST=1 ENDIF CALL WDIALOGSELECT(ID_DISGEDITTAB1) CALL WDIALOGPUTOPTION(IDF_MENU1,ISG(1:NISG)%ILIST) !## tab changed/menu selection done ELSEIF(CODE.EQ.1)THEN CALL ISGISPSTOP(0) CALL WDIALOGSELECT(ID_DISGEDITTAB1) ! !## already selected and in EDIT mode ! IF(ISELISG.NE.0)THEN ! !## question whether to stop modifying isg-line ! CALL ISGISPSTOP(0) ! !## do not change selected isg segment - reselect current one ! IF(IDIAGERROR.EQ.1)THEN ! ISG%ILIST=0; ISG(ISELISG)%ILIST=1 ! CALL WDIALOGSELECT(ID_DISGEDITTAB1) ! CALL WDIALOGPUTOPTION(IDF_MENU1,ISG(1:NISG)%ILIST) ! RETURN ! ENDIF ! ENDIF !## get current selected segments CALL WDIALOGGETMENU(IDF_MENU1,ISG(1:NISG)%ILIST) !## check what isg segment is selected and if it is a single selection ISELISG=0 IF(SUM(ISG(1:NISG)%ILIST).EQ.1)THEN DO ISELISG=1,NISG; IF(ISG(ISELISG)%ILIST.EQ.1)EXIT; END DO ENDIF ! IF(ISELISG.GT.0.AND.ISELISG.LE.NISG)LEX=.TRUE. ENDIF IF(SUM(ISG(1:NISG)%ILIST).EQ.1)THEN CALL WMENUSETSTATE(ID_ISGISPSTART,1,1) ELSE CALL WMENUSETSTATE(ID_ISGISPSTART,1,0) ENDIF CALL ISGPLOT_DRAWSELECTEDSEGMENTS() CALL ISGFIELDS() CALL ISGADJUSTFIELDS() END SUBROUTINE ISGCHECKISG !###====================================================================== LOGICAL FUNCTION ISGGETSEGMENT(X,Y,IISG,JJSG,MINDIST,IPOS,IPLIST,DPLIST,NPLIST) !###====================================================================== IMPLICIT NONE REAL,INTENT(IN) :: MINDIST,X,Y INTEGER,INTENT(IN) :: IPOS !## 0=all;1=begin;2=end INTEGER,INTENT(IN) :: IISG !## current segment INTEGER,INTENT(OUT) :: JJSG !## nearest segment INTEGER,POINTER,DIMENSION(:),OPTIONAL :: IPLIST REAL,POINTER,DIMENSION(:),OPTIONAL :: DPLIST INTEGER,OPTIONAL :: NPLIST REAL :: DX,DIST INTEGER :: I,ISEG,I1,I2,ILIST ISGGETSEGMENT=.FALSE. !## no list needed, just get the nearest ILIST=0 !## create a list IF(PRESENT(IPLIST).AND.PRESENT(NPLIST))THEN ALLOCATE(IPLIST(NISG),DPLIST(NISG)); IPLIST=0; DPLIST=0.0; ILIST=1; NPLIST=0 ENDIF !## search nearest point IF(ILIST.EQ.0)THEN DIST=HUGE(1.0) !## get all points within "mindist" distance ELSE DIST=MINDIST ENDIF JJSG=0 DO I=1,NISG !## skip entered isg if applied IF(I.EQ.IISG)CYCLE SELECT CASE (IPOS) CASE (0) I1=ISG(I)%ISEG I2=ISG(I)%ISEG+ISG(I)%NSEG-1 CASE (1) I1=ISG(I)%ISEG; I2=I1 CASE (2) I2=ISG(I)%ISEG+ISG(I)%NSEG-1; I1=I2 END SELECT DO ISEG=I1,I2 !## try point iseg DX=UTL_DIST(X,Y,ISP(ISEG)%X,ISP(ISEG)%Y) IF(DX.LT.DIST)THEN IF(ILIST.EQ.0)THEN DIST=MIN(DIST,DX); JJSG=I ELSE NPLIST=NPLIST+1; IPLIST(NPLIST)=I; DPLIST(NPLIST)=DX ENDIF ENDIF !## additional point, try point in between, only in combination with "all"-segments ipos=0 IF(ISEG.LT.I2)THEN DX=UTL_DIST(X,Y,(ISP(ISEG)%X+ISP(ISEG+1)%X)/2.0,(ISP(ISEG)%Y+ISP(ISEG+1)%Y)/2.0) IF(DX.LT.DIST)THEN IF(ILIST.EQ.0)THEN DIST=MIN(DIST,DX); JJSG=I ELSE NPLIST=NPLIST+1; IPLIST(NPLIST)=I; DPLIST(NPLIST)=DX ENDIF ENDIF ENDIF ENDDO END DO IF(ILIST.EQ.0)THEN !## check whether inside given range IF(DIST.LE.MINDIST.AND.JJSG.GT.0)ISGGETSEGMENT=.TRUE. ELSE IF(NPLIST.GT.0)ISGGETSEGMENT=.TRUE. ENDIF END FUNCTION ISGGETSEGMENT !###====================================================================== SUBROUTINE ISGEDITINIT() !###====================================================================== IMPLICIT NONE INTEGER :: IPLOT,I,NISGFILES,N CHARACTER(LEN=256),DIMENSION(:),ALLOCATABLE :: ISGFILE CALL WINDOWSELECT(0) IF(WMENUGETSTATE(ID_ISGEDIT,2).EQ.1)THEN CALL ISGEDITCLOSE(1); RETURN ENDIF CALL MAIN1INACTMODULE(ID_ISGEDIT) !## other module no closed, no approvement given IF(IDIAGERROR.EQ.1)RETURN CALL WMENUSETSTATE(ID_ISGEDIT,2,1) !## how many isg files selected NISGFILES=0 DO IPLOT=1,MXMPLOT IF(MP(IPLOT)%ISEL.AND.MP(IPLOT)%IPLOT.EQ.4)THEN NISGFILES=NISGFILES+1 IISGPLOT =IPLOT ENDIF END DO CALL WDIALOGLOAD(ID_DISGEDIT,ID_DISGEDIT) IF(NISGFILES.GT.1)THEN CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'You have selected more than one ISG file.'//CHAR(13)// & 'Do you want iMOD to merge them ? ','Question') IF(WINFODIALOG(4).NE.1)THEN CALL ISGEDITCLOSE(0); RETURN ENDIF ENDIF ALLOCATE(ISGFILE(NISGFILES)) !## open all isg files IF(NISGFILES.GT.1)THEN I=0 DO IPLOT=1,MXMPLOT IF(MP(IPLOT)%ISEL.AND.MP(IPLOT)%IPLOT.EQ.4)THEN I=I+1; ISGFILE(I)=TRIM(MP(IPLOT)%IDFNAME); IISGPLOT=IPLOT ENDIF END DO ELSE ISGFILE(1)=TRIM(MP(IISGPLOT)%IDFNAME); ISGFNAME=ISGFILE(1) ENDIF !## read isg's CALL UTL_MESSAGEHANDLE(0); CALL WINDOWSELECT(0) IF(NISGFILES.EQ.1)CALL WINDOWOUTSTATUSBAR(4,'Reading '//TRIM(ISGFILE(1))//' ...') IF(NISGFILES.GT.1)CALL WINDOWOUTSTATUSBAR(4,'Reading and Merging '//TRIM(ITOS(NISGFILES))//' ISG-file(s) ...') !## to be consistent with multi-isg files to be read! IF(.NOT.ISGREAD(ISGFILE,0))THEN; CALL ISGEDITCLOSE(0); RETURN; ENDIF !## copy legend for ISG-plotting - number of legend is equal to number of variables in isd2-file IF(ISFR.EQ.0)N=SIZE(TATTRIB1) IF(ISFR.EQ.1)N=SIZE(TATTRIB2) ALLOCATE(ISGLEG(N)); DO I=1,SIZE(ISGLEG); ISGLEG(I)=MP(IISGPLOT)%LEG; ENDDO CALL UTL_MESSAGEHANDLE(1) !## close files CALL ISGCLOSEFILES() !## error occured in reading isg-file IF(NISG.LT.0)THEN; CALL ISGEDITCLOSE(0); RETURN; ENDIF !## save in case of merging IF(NISGFILES.GT.1)THEN CALL ISGSAVE(ISGFILE(1),1) !## error writing merged isg file IF(TRIM(ISGFILE(1)).EQ.'')THEN; DEALLOCATE(ISGFILE); CALL ISGEDITCLOSE(1); RETURN; ENDIF CALL IDFINIT(IDFNAMEGIVEN=ISGFILE(1),LPLOT=.TRUE.) ENDIF DEALLOCATE(ISGFILE) CALL WDIALOGSELECT(ID_DISGEDITTAB1) CALL WDIALOGPUTIMAGE(ID_RENAME,ID_ICONRENAME,1) CALL WDIALOGPUTIMAGE(ID_ZOOMTO,ID_ICONZOOMTO,1) CALL WDIALOGPUTIMAGE(ID_FIND,ID_ICONFIND,1) CALL WDIALOGPUTIMAGE(ID_RECORDS,ID_ICONEDITATTRIB,1) CALL WDIALOGPUTIMAGE(ID_PROFILE,ID_ICONPROFILE,1) CALL WDIALOGPUTIMAGE(ID_DELETE,ID_ICONDELETE,1) CALL WDIALOGPUTIMAGE(ID_GRID,ID_ICONGRID,1) CALL WDIALOGPUTIMAGE(ID_LEGEND,ID_ICONLEGEND,1) CALL WDIALOGPUTIMAGE(ID_DRAW,ID_ICONDRAW,1) CALL WDIALOGPUTIMAGE(ID_CONNECTFROM,ID_ICONEDITNODESFROM,1) CALL WDIALOGPUTIMAGE(ID_CONNECTTO,ID_ICONEDITNODESTO,1) CALL WDIALOGPUTIMAGE(ID_CONNECTTOAUTO,ID_ICONEDITNODESTOAUTO,1) CALL WDIALOGPUTIMAGE(ID_DRIP,ID_ICONDRIP,1) CALL WDIALOGPUTIMAGE(ID_POLYGON,ID_ICONPOLYGON,1) CALL POLYGON1IMAGES(ID_DISGEDITTAB2) CALL WDIALOGSELECT(ID_DISGEDITTAB3) CALL WDIALOGPUTIMAGE(ID_LOAD,ID_ICONOPEN,1) CALL WDIALOGPUTIMAGE(ID_SAVEAS,ID_ICONSAVEAS,1) CALL WDIALOGSELECT(ID_DISGEDITTAB4) CALL WDIALOGPUTIMAGE(ID_LOAD,ID_ICONOPEN,1) CALL WDIALOGPUTIMAGE(IDF_LOAD1,ID_ICONOPEN,1) CALL WDIALOGPUTIMAGE(IDF_LOAD2,ID_ICONOPEN,1) CALL WDIALOGPUTIMAGE(IDF_LOAD3,ID_ICONOPEN,1) CALL WDIALOGPUTIMAGE(IDF_LOAD4,ID_ICONOPEN,1) CALL WDIALOGPUTIMAGE(ID_LOAD2,ID_ICONOPEN,1) IF(ISFR.EQ.0)THEN CALL WDIALOGPUTMENU(IDF_MENU5,ISDLABELS(2:),SIZE(ISDLABELS)-1,1) CALL WDIALOGPUTMENU(IDF_MENU6,ISDLABELS(2:),SIZE(ISDLABELS)-1,2) CALL WDIALOGPUTMENU(IDF_MENU7,ISDLABELS(2:),SIZE(ISDLABELS)-1,3) CALL WDIALOGPUTMENU(IDF_MENU8,ISDLABELS(2:),SIZE(ISDLABELS)-1,4) ELSE CALL WDIALOGPUTMENU(IDF_MENU5,ISDLABELS(3:),SIZE(ISDLABELS)-2,1) CALL WDIALOGPUTMENU(IDF_MENU6,ISDLABELS(3:),SIZE(ISDLABELS)-2,2) CALL WDIALOGPUTMENU(IDF_MENU7,ISDLABELS(3:),SIZE(ISDLABELS)-2,3) CALL WDIALOGPUTMENU(IDF_MENU8,ISDLABELS(3:),SIZE(ISDLABELS)-2,4) ENDIF CALL WDIALOGSELECT(ID_DISGEDITTAB5) CALL WDIALOGPUTIMAGE(ID_LOAD,ID_ICONOPEN,1) CALL WDIALOGPUTIMAGE(IDF_LOAD1,ID_ICONOPEN,1) CALL WDIALOGPUTIMAGE(IDF_LOAD2,ID_ICONOPEN,1) CALL WDIALOGSELECT(ID_DISGEDITTAB6) CALL WDIALOGPUTIMAGE(ID_LOAD,ID_ICONOPEN,1) CALL WDIALOGPUTIMAGE(IDF_LOAD1,ID_ICONOPEN,1) CALL WDIALOGPUTIMAGE(IDF_LOAD2,ID_ICONOPEN,1) CALL WDIALOGPUTIMAGE(IDF_LOAD3,ID_ICONOPEN,1) CALL WDIALOGSELECT(ID_DISGEDITTAB7) CALL WDIALOGPUTIMAGE(ID_LOAD,ID_ICONOPEN,1) CALL WDIALOGPUTIMAGE(IDF_LOAD1,ID_ICONOPEN,1) CALL WDIALOGPUTIMAGE(IDF_LOAD2,ID_ICONOPEN,1) CALL WDIALOGPUTIMAGE(IDF_LOAD3,ID_ICONOPEN,1) CALL WDIALOGPUTIMAGE(IDF_LOAD4,ID_ICONOPEN,1) DO IPLOT=1,MXMPLOT IF(MP(IPLOT)%ISEL.AND.MP(IPLOT)%IPLOT.EQ.4)EXIT END DO IISGPLOT=IPLOT ISGFNAME=TRIM(MP(IISGPLOT)%IDFNAME) CALL WDIALOGSELECT(ID_DISGEDIT) CALL WDIALOGTITLE('ISG Edit: '//TRIM(MP(IISGPLOT)%ALIAS)) ISG%ILIST=0; ISG%JLIST=0 CALL WDIALOGSELECT(ID_DISGEDITTAB1) CALL WDIALOGPUTMENU(IDF_MENU1,ISG%SNAME,NISG,ISG%ILIST) CALL ISGFIELDS() CALL WDIALOGSELECT(ID_DISGEDIT) CALL WDIALOGCOLOUR(IDF_STRING1,INVERSECOLOUR(ICLRND),ICLRND) CALL WDIALOGCOLOUR(IDF_STRING2,INVERSECOLOUR(ICLRSD),ICLRSD) CALL WDIALOGCOLOUR(IDF_STRING3,INVERSECOLOUR(ICLRSC),ICLRSC) CALL WDIALOGCOLOUR(IDF_STRING4,INVERSECOLOUR(ICLRSP),ICLRSP) CALL WDIALOGCOLOUR(IDF_STRING5,INVERSECOLOUR(ICLRST),ICLRST) CALL WDIALOGCOLOUR(IDF_STRING6,INVERSECOLOUR(ICLRQH),ICLRQH) CALL WDIALOGCOLOUR(IDF_STRING7,INVERSECOLOUR(ICLRSF),ICLRSF) CALL WDIALOGCOLOUR(IDF_STRING8,INVERSECOLOUR(ICLRCO),ICLRCO) CALL WINDOWSELECT(0) I=WMENUGETSTATE(ID_ISGNODES,2) CALL WDIALOGPUTCHECKBOX(IDF_CHECK1,I) I=WMENUGETSTATE(ID_ISGCLCNODES,2) CALL WDIALOGPUTCHECKBOX(IDF_CHECK2,I) I=WMENUGETSTATE(ID_ISGCRSSCTNS,2) CALL WDIALOGPUTCHECKBOX(IDF_CHECK3,I) I=WMENUGETSTATE(ID_ISGSEGNODES,2) CALL WDIALOGPUTCHECKBOX(IDF_CHECK4,I) I=WMENUGETSTATE(ID_ISGSTUWEN,2) CALL WDIALOGPUTCHECKBOX(IDF_CHECK5,I) I=WMENUGETSTATE(ID_ISGQHR,2) CALL WDIALOGPUTCHECKBOX(IDF_CHECK6,I) I=WMENUGETSTATE(ID_ISGSFR,2) CALL WDIALOGPUTCHECKBOX(IDF_CHECK9,I) I=WMENUGETSTATE(ID_ISGSFC,2) CALL WDIALOGPUTCHECKBOX(IDF_CHECK10,I) CALL ISGISP_MENUFIELDS(0) CALL POLYGON1INIT() CALL ISGADJUSTFIELDS() IF(ALLOCATED(GRAPHUNITS))DEALLOCATE(GRAPHUNITS) IF(ALLOCATED(GRAPHAREA))DEALLOCATE(GRAPHAREA) ALLOCATE(GRAPHUNITS(6,1),GRAPHAREA(4,1)) GRAPHUNITS(1,1)=0.0 GRAPHUNITS(2,1)=0.0 GRAPHUNITS(3,1)=1.0 GRAPHUNITS(4,1)=1.0 GRAPHUNITS(5,1)=0.0 GRAPHUNITS(6,1)=1.0 GRAPHAREA(1,1) =0.0 GRAPHAREA(2,1) =0.0 GRAPHAREA(3,1) =1.0 GRAPHAREA(4,1) =1.0 CALL WDIALOGSELECT(ID_DISGEDIT) CALL WDIALOGSHOW(-0,65,0,2) ISGSHAPES=0; ICROSS_PNTR=0; ICROSS_ZVAL=0 END SUBROUTINE ISGEDITINIT !###====================================================================== SUBROUTINE ISGFIELDS() !###====================================================================== IMPLICIT NONE INTEGER :: I,J CALL WDIALOGSELECT(ID_DISGEDITTAB1) IF(NISG.GT.0)THEN CALL WDIALOGGETMENU(IDF_MENU1,ISG(1:NISG)%ILIST) I=1 ELSE I=0 ENDIF CALL WDIALOGFIELDSTATE(ID_PROFILE,I) IF(SUM(ISG(1:NISG)%ILIST).LE.0)I=0 CALL WDIALOGFIELDSTATE(ID_ZOOMTO,I) CALL WDIALOGFIELDSTATE(ID_DELETE,I) J=I; IF(ISFR.EQ.0)J=0 CALL WDIALOGFIELDSTATE(ID_CONNECTFROM,J) CALL WDIALOGFIELDSTATE(ID_CONNECTTO,J) CALL WDIALOGFIELDSTATE(ID_CONNECTTOAUTO,J) CALL WDIALOGFIELDSTATE(ID_DRIP,J) CALL WDIALOGFIELDSTATE(IDF_SNAPDISTANCE,J) I=3; IF(SUM(ISG(1:NISG)%ILIST).EQ.1)THEN I=1 !## find selected segment DO J=1,NISG; IF(ISG(J)%ILIST.EQ.1)EXIT; ENDDO CALL WDIALOGPUTINTEGER(IDF_INTEGER1,J) ENDIF CALL WDIALOGFIELDSTATE(IDF_LABEL1,I) CALL WDIALOGFIELDSTATE(IDF_INTEGER1,I) CALL WDIALOGSELECT(ID_DISGEDIT) CALL WDIALOGFIELDSTATE(IDF_CHECK7,I) ! CALL WDIALOGFIELDSTATE(IDF_CHECK8,I) IF(I.EQ.0)CALL WDIALOGPUTCHECKBOX(IDF_CHECK7,I) !## only of not selected anything yet! !IF(ISELISG.NE.0)I=0 END SUBROUTINE ISGFIELDS !###====================================================================== SUBROUTINE ISGEDITCLOSE(ICODE) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ICODE IDIAGERROR=1 CALL ISGISPSTOP(ICODE) IF(IDIAGERROR.EQ.1)RETURN IDIAGERROR=1 CALL POLYGON1DRAWSHAPE(1,SHPNO) CALL POLYGON1CLOSE() !## deallocate memory CALL ISGDEAL(1); IF(ALLOCATED(ISGIU))DEALLOCATE(ISGIU) CALL WINDOWSELECT(0) IF(WMENUGETSTATE(ID_ISGEDIT,2).EQ.1)THEN !## legend plotting active, remove it from memory CALL WDIALOGSELECT(ID_DISGEDITTAB1) IF(WINFODIALOGFIELD(ID_LEGEND,FIELDSTATE).EQ.0)THEN CALL WDIALOGSELECT(ID_DISGEDITLEGEND); CALL WDIALOGUNLOAD() ENDIF CALL WDIALOGSELECT(ID_DISGEDIT); CALL WDIALOGUNLOAD() ENDIF CALL WMENUSETSTATE(ID_ISGEDIT,2,0) IDIAGERROR=0 IF(ALLOCATED(GRAPHUNITS))DEALLOCATE(GRAPHUNITS) IF(ALLOCATED(GRAPHAREA))DEALLOCATE(GRAPHAREA) CALL IDFPLOTFAST(1) END SUBROUTINE ISGEDITCLOSE !###==================================================================== SUBROUTINE ISGATTRIBUTESSAVE() !###==================================================================== IMPLICIT NONE CALL UTL_MESSAGEHANDLE(0) CALL WINDOWSELECT(0) CALL WINDOWOUTSTATUSBAR(4,'Storing data ...') CALL ISGATTRIBUTESSAVEISPVALUES() CALL ISGATTRIBUTESSAVEISDVALUES() CALL ISGATTRIBUTESSAVEISCVALUES() CALL ISGATTRIBUTESSAVEISTVALUES() CALL ISGATTRIBUTESSAVEISQVALUES() CALL UTL_MESSAGEHANDLE(1) END SUBROUTINE ISGATTRIBUTESSAVE !###==================================================================== SUBROUTINE ISGATTRIBUTESSAVEISDVALUES() !###==================================================================== IMPLICIT NONE INTEGER :: I,J,K,L,DN K=ISG(ISELISG)%ICLC-1 DO I=1,ISG(ISELISG)%NCLC K =K+1 DN =TISD(I)-ISD(K)%N !## increase memory CALL ISGMEMORYDATISD(DN,K,J) DO L=1,TISD(I) DATISD(J+L-1)=DATISD2(I,L) ENDDO ENDDO END SUBROUTINE ISGATTRIBUTESSAVEISDVALUES !###==================================================================== SUBROUTINE ISGATTRIBUTESSAVEISCVALUES() !###==================================================================== IMPLICIT NONE INTEGER :: I,J,K,L,DN K=ISG(ISELISG)%ICRS-1 DO I=1,ISG(ISELISG)%NCRS K =K+1 DN =TISC(I)-ABS(ISC(K)%N) !## increase memory CALL ISGMEMORYDATISC(DN,K,J) DO L=1,TISC(I) DATISC(J+L-1)=DATISC2(I,L) ENDDO ISC(K)%N=ISCN(I)*ABS(ISC(K)%N) ENDDO END SUBROUTINE ISGATTRIBUTESSAVEISCVALUES !###==================================================================== SUBROUTINE ISGATTRIBUTESSAVEISTVALUES() !###==================================================================== IMPLICIT NONE INTEGER :: I,J,K,L,DN K=ISG(ISELISG)%ISTW-1 DO I=1,ISG(ISELISG)%NSTW K =K+1 DN =TIST(I)-IST(K)%N !## increase memory CALL ISGMEMORYDATIST(DN,K,J) DO L=1,TIST(I) DATIST(J+L-1)=DATIST2(I,L) ENDDO ENDDO END SUBROUTINE ISGATTRIBUTESSAVEISTVALUES !###==================================================================== SUBROUTINE ISGATTRIBUTESSAVEISQVALUES() !###==================================================================== IMPLICIT NONE INTEGER :: I,J,K,L,DN K=ISG(ISELISG)%IQHR-1 DO I=1,ISG(ISELISG)%NQHR K =K+1 DN =TISQ(I)-ISQ(K)%N !## increase memory CALL ISGMEMORYDATISQ(DN,K,J) DO L=1,TISQ(I) DATISQ(J+L-1)=DATISQ2(I,L) ENDDO ENDDO END SUBROUTINE ISGATTRIBUTESSAVEISQVALUES !###==================================================================== SUBROUTINE ISGATTRIBUTESSAVEISPVALUES() !###==================================================================== IMPLICIT NONE INTEGER :: I,J,DN REAL :: TD DN=TISP-ISG(ISELISG)%NSEG !## increase memory CALL ISGMEMORYISP(DN,ISELISG,J) TD=0.0 DO I=1,TISP ISP(J+I-1)=ISP2(I) IF(I.GE.2)TD=TD+SQRT((ISP2(I-1)%X-ISP2(I)%X)**2.0+(ISP2(I-1)%Y-ISP2(I)%Y)**2.0) ENDDO CALL ISGISPADJUST(TD) END SUBROUTINE ISGATTRIBUTESSAVEISPVALUES !###==================================================================== SUBROUTINE ISGATTRIBUTESPUTISDVALUES() !###==================================================================== IMPLICIT NONE INTEGER :: I,J,ISTATE CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB1) CALL WDIALOGGETMENU(IDF_MENU1,J) CALL WDIALOGCLEARFIELD(IDF_GRID1) IF(ISFR.EQ.0)THEN CALL WGRIDPUTINTEGER(IDF_GRID1,1,DATISD2(J,:)%IDATE,TISD(J)) CALL WGRIDPUTREAL(IDF_GRID1,2,DATISD2(J,:)%WLVL,TISD(J),'(F10.2)') CALL WGRIDPUTREAL(IDF_GRID1,3,DATISD2(J,:)%BTML,TISD(J),'(F10.2)') CALL WGRIDPUTREAL(IDF_GRID1,4,DATISD2(J,:)%RESIS,TISD(J),'(F10.2)') CALL WGRIDPUTREAL(IDF_GRID1,5,DATISD2(J,:)%INFF,TISD(J),'(F10.2)') ELSEIF(ISFR.EQ.1)THEN CALL WGRIDPUTINTEGER(IDF_GRID1,1,DATISD2(J,:)%IDATE,TISD(J)) CALL WGRIDPUTSTRING(IDF_GRID1,2,DATISD2(J,:)%CTIME,TISD(J)) CALL WGRIDPUTREAL(IDF_GRID1,3,DATISD2(J,:)%WLVL ,TISD(J),'(F10.2)') CALL WGRIDPUTREAL(IDF_GRID1,4,DATISD2(J,:)%BTML ,TISD(J),'(F10.2)') CALL WGRIDPUTREAL(IDF_GRID1,5,DATISD2(J,:)%WIDTH,TISD(J),'(F10.2)') CALL WGRIDPUTREAL(IDF_GRID1,6,DATISD2(J,:)%THCK ,TISD(J),'(F10.2)') CALL WGRIDPUTREAL(IDF_GRID1,7,DATISD2(J,:)%HCND ,TISD(J),'(F10.2)') CALL WGRIDPUTINTEGER(IDF_GRID1,8,DATISD2(J,:)%UPSG,TISD(J)) CALL WGRIDPUTINTEGER(IDF_GRID1,9,DATISD2(J,:)%DWNS,TISD(J)) CALL WGRIDPUTOPTION(IDF_GRID1,10,DATISD2(J,:)%ICLC,TISD(J)) CALL WGRIDPUTOPTION(IDF_GRID1,11,DATISD2(J,:)%IPRI,TISD(J)) CALL WGRIDPUTREAL(IDF_GRID1,12,DATISD2(J,:)%QFLW,TISD(J),'(F10.2)') CALL WGRIDPUTREAL(IDF_GRID1,13,DATISD2(J,:)%QROF,TISD(J),'(F10.2)') CALL WGRIDPUTREAL(IDF_GRID1,14,DATISD2(J,:)%PPTSW,TISD(J),'(F10.2)') CALL WGRIDPUTREAL(IDF_GRID1,15,DATISD2(J,:)%ETSW,TISD(J),'(F10.2)') !## block downstream items ISTATE=ENABLED; IF(J.EQ.1)ISTATE=DIALOGREADONLY CALL WGRIDSTATE(IDF_GRID1,9 ,ISTATE) ! CALL WGRIDSTATE(IDF_GRID1,11,ISTATE) !## block upstream items ISTATE=ENABLED; IF(J.EQ.2)ISTATE=DIALOGREADONLY CALL WGRIDSTATE(IDF_GRID1,8 ,ISTATE) CALL WGRIDSTATE(IDF_GRID1,10,ISTATE) CALL WGRIDSTATE(IDF_GRID1,11,ISTATE) CALL WGRIDSTATE(IDF_GRID1,12,ISTATE) CALL WGRIDSTATE(IDF_GRID1,13,ISTATE) ENDIF I=ISG(ISELISG)%ICLC-1+J CALL WDIALOGPUTREAL(IDF_REAL1,ISD(I)%DIST) END SUBROUTINE ISGATTRIBUTESPUTISDVALUES !###==================================================================== SUBROUTINE ISGATTRIBUTESPUTISCVALUES() !###==================================================================== IMPLICIT NONE INTEGER :: I,J CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB2) CALL WDIALOGGETMENU(IDF_MENU1,J) CALL WDIALOGCLEARFIELD(IDF_GRID1) !## 1d cross-section IF(ISCN(J).EQ.1)THEN CALL WGRIDCOLUMNS(IDF_GRID1,3,(/1,1,1/),(/30,30,30/)) CALL WGRIDLABELCOLUMN(IDF_GRID1,1,'Distance') CALL WGRIDLABELCOLUMN(IDF_GRID1,2,'Z') CALL WGRIDLABELCOLUMN(IDF_GRID1,3,'MRC') CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO1) CALL WGRIDPUTREAL(IDF_GRID1,1,DATISC2(J,:)%DISTANCE,TISC(J),'(F10.2)') CALL WGRIDPUTREAL(IDF_GRID1,2,DATISC2(J,:)%BOTTOM,TISC(J),'(F10.2)') CALL WGRIDPUTREAL(IDF_GRID1,3,DATISC2(J,:)%MRC,TISC(J),'(F10.2)') !## 2d cross-section ELSEIF(ISCN(J).EQ.-1)THEN CALL WGRIDCOLUMNS(IDF_GRID1,4,(/1,1,1,1/),(/30,30,30,30/)) CALL WGRIDLABELCOLUMN(IDF_GRID1,1,'X-crd.') CALL WGRIDLABELCOLUMN(IDF_GRID1,2,'Y-crd.') CALL WGRIDLABELCOLUMN(IDF_GRID1,3,'Z-val.') CALL WGRIDLABELCOLUMN(IDF_GRID1,4,'Pntr.') CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO2) !## no reference height and pointers used IF(DATISC2(J,1)%DISTANCE.GT.0.0.AND.DATISC2(J,1)%BOTTOM.GT.0.0)THEN CALL WGRIDSTATE(IDF_GRID1,4,2) CALL WGRIDPUTREAL(IDF_GRID1,1,DATISC2(J,:)%DISTANCE,TISC(J),'(F10.2)') CALL WGRIDPUTREAL(IDF_GRID1,2,DATISC2(J,:)%BOTTOM,TISC(J),'(F10.2)') CALL WGRIDPUTREAL(IDF_GRID1,3,DATISC2(J,:)%MRC,TISC(J),'(F10.2)') !## reference height and pointers used ELSE CALL WGRIDLABELCOLUMN(IDF_GRID1,4,'Pnt') CALL WGRIDSTATE(IDF_GRID1,4,1) CALL WGRIDPUTREAL(IDF_GRID1,1,DATISC2(J,:)%DISTANCE,TISC(J),'(F10.2)') CALL WGRIDPUTREAL(IDF_GRID1,2,DATISC2(J,:)%BOTTOM,TISC(J),'(F10.2)') CALL WGRIDPUTREAL(IDF_GRID1,3,DATISC2(J,:)%MRC,TISC(J),'(F10.2)') CALL WGRIDPUTREAL(IDF_GRID1,4,DATISC2(J,:)%ZP,TISC(J),'(F5.1)') ENDIF ENDIF I=ISG(ISELISG)%ICRS-1+J CALL WDIALOGPUTREAL(IDF_REAL3,ISC(I)%DIST) END SUBROUTINE ISGATTRIBUTESPUTISCVALUES !###==================================================================== SUBROUTINE ISGATTRIBUTESPUTISTVALUES() !###==================================================================== IMPLICIT NONE INTEGER :: I,J IF(ISG(ISELISG)%NSTW.EQ.0)RETURN ! Select currently displayed sub CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB4) CALL WDIALOGGETMENU(IDF_MENU1,J) CALL WDIALOGCLEARFIELD(IDF_GRID1) CALL WGRIDPUTINTEGER(IDF_GRID1,1,DATIST2(J,:)%IDATE,TIST(J)) CALL WGRIDPUTREAL(IDF_GRID1,2,DATIST2(J,:)%WLVL_UP,TIST(J),'(F10.2)') CALL WGRIDPUTREAL(IDF_GRID1,3,DATIST2(J,:)%WLVL_DOWN,TIST(J),'(F10.2)') I=ISG(ISELISG)%ISTW-1+J CALL WDIALOGPUTREAL(IDF_REAL1,IST(I)%DIST) END SUBROUTINE ISGATTRIBUTESPUTISTVALUES !###==================================================================== SUBROUTINE ISGATTRIBUTESPUTISQVALUES() !###==================================================================== IMPLICIT NONE INTEGER :: I,J IF(ISG(ISELISG)%NQHR.EQ.0)RETURN ! Select currently displayed sub CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB5) CALL WDIALOGGETMENU(IDF_MENU1,J) CALL WDIALOGCLEARFIELD(IDF_GRID1) CALL WGRIDPUTREAL(IDF_GRID1,1,DATISQ2(J,:)%Q,TISQ(J),'(G10.5)') CALL WGRIDPUTREAL(IDF_GRID1,2,DATISQ2(J,:)%W,TISQ(J),'(G10.5)') CALL WGRIDPUTREAL(IDF_GRID1,3,DATISQ2(J,:)%D,TISQ(J),'(G10.5)') CALL WGRIDPUTREAL(IDF_GRID1,4,DATISQ2(J,:)%F,TISQ(J),'(G10.5)') I=ISG(ISELISG)%IQHR-1+J CALL WDIALOGPUTREAL(IDF_REAL1,ISQ(I)%DIST) END SUBROUTINE ISGATTRIBUTESPUTISQVALUES !###==================================================================== SUBROUTINE ISGATTRIBUTESROTATEISP() !###==================================================================== IMPLICIT NONE INTEGER :: I,J REAL :: X,Y,TDIST,DIST !## get ips values from dialog CALL ISGATTRIBUTESGETISPVALUES() !## rotate J=TISP DO I=1,TISP/2 X=ISP2(I)%X; Y=ISP2(I)%Y ISP2(I)%X=ISP2(J)%X; ISP2(I)%Y=ISP2(J)%Y ISP2(J)%X=X; ISP2(J)%Y=Y J=J-1 ENDDO !## get total distance of current line TDIST=0.0; DO I=2,TISP DIST=(ISP2(I)%X-ISP2(I-1)%X)**2.0+(ISP2(I)%Y-ISP2(I-1)%Y)**2.0 IF(DIST.GT.0.0)DIST=SQRT(DIST); TDIST=TDIST+DIST END DO !## adjust distance for calculation points I=ISG(ISELISG)%ICLC DO J=1,ISG(ISELISG)%NCLC ISD(J)%DIST=TDIST-ISD(J)%DIST ENDDO !## adjust distance for weirs I=ISG(ISELISG)%ISTW DO J=1,ISG(ISELISG)%NSTW IST(J)%DIST=TDIST-IST(J)%DIST ENDDO !## adjust distance for cross-sections I=ISG(ISELISG)%ICRS DO J=1,ISG(ISELISG)%NCRS ISC(J)%DIST=TDIST-ISC(J)%DIST ENDDO !## adjust distance for qh-relationships I=ISG(ISELISG)%IQHR DO J=1,ISG(ISELISG)%NQHR ISQ(J)%DIST=TDIST-ISQ(J)%DIST ENDDO !## adjust distance settings for ALL other such that every thing remains op the same location ! ISD(I)%DIST ! ISC(I)%DIST ! IST(I)%DIST ! ISQ(I)%DIST !## put selected values for current segment CALL ISGATTRIBUTESPUTISPVALUES() END SUBROUTINE ISGATTRIBUTESROTATEISP !###==================================================================== SUBROUTINE ISGATTRIBUTESPUTISPVALUES() !###==================================================================== IMPLICIT NONE CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB3) CALL WDIALOGCLEARFIELD(IDF_GRID1) CALL WGRIDPUTREAL(IDF_GRID1,1,ISP2%X,TISP,'(F10.2)') CALL WGRIDPUTREAL(IDF_GRID1,2,ISP2%Y,TISP,'(F10.2)') END SUBROUTINE ISGATTRIBUTESPUTISPVALUES !###==================================================================== SUBROUTINE ISGATTRIBUTESGETISDVALUES() !###==================================================================== IMPLICIT NONE INTEGER :: I,J,IDBG,IROW CHARACTER(LEN=14),ALLOCATABLE,DIMENSION(:) :: CLIST INTEGER(KIND=4),ALLOCATABLE,DIMENSION(:) :: IORDER CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB1) CALL WDIALOGGETMENU(IDF_MENU1,J) !## use previous one ... IF(SELISD.GT.0)J=SELISD J=MIN(J,ISG(ISELISG)%NCLC) CALL WDIALOGUNDEFINED(INODATA,RNODATA) IDBG=INFOERROR(DEBUGLEVEL) CALL IDEBUGLEVEL(0) IF(ISFR.EQ.0)THEN CALL WGRIDGETINTEGER(IDF_GRID1,1,DATISD2(J,:)%IDATE,ISDMAXROW) CALL WGRIDGETREAL(IDF_GRID1,2,DATISD2(J,:)%WLVL,ISDMAXROW) CALL WGRIDGETREAL(IDF_GRID1,3,DATISD2(J,:)%BTML,ISDMAXROW) CALL WGRIDGETREAL(IDF_GRID1,4,DATISD2(J,:)%RESIS,ISDMAXROW) CALL WGRIDGETREAL(IDF_GRID1,5,DATISD2(J,:)%INFF,ISDMAXROW) ELSEIF(ISFR.EQ.1)THEN CALL WGRIDGETINTEGER(IDF_GRID1,1,DATISD2(J,:)%IDATE,ISDMAXROW) CALL WGRIDGETSTRING(IDF_GRID1,2,DATISD2(J,:)%CTIME,ISDMAXROW) CALL WGRIDGETREAL(IDF_GRID1,3,DATISD2(J,:)%WLVL,ISDMAXROW) CALL WGRIDGETREAL(IDF_GRID1,4,DATISD2(J,:)%BTML,ISDMAXROW) CALL WGRIDGETREAL(IDF_GRID1,5,DATISD2(J,:)%WIDTH,ISDMAXROW) CALL WGRIDGETREAL(IDF_GRID1,6,DATISD2(J,:)%THCK,ISDMAXROW) CALL WGRIDGETREAL(IDF_GRID1,7,DATISD2(J,:)%HCND,ISDMAXROW) CALL WGRIDGETINTEGER(IDF_GRID1,8,DATISD2(J,:)%UPSG,ISDMAXROW) CALL WGRIDGETINTEGER(IDF_GRID1,9,DATISD2(J,:)%DWNS,ISDMAXROW) CALL WGRIDGETMENU(IDF_GRID1,10,DATISD2(J,:)%ICLC,ISDMAXROW) CALL WGRIDGETMENU(IDF_GRID1,11,DATISD2(J,:)%IPRI,ISDMAXROW) CALL WGRIDGETREAL(IDF_GRID1,12,DATISD2(J,:)%QFLW,ISDMAXROW) CALL WGRIDGETREAL(IDF_GRID1,13,DATISD2(J,:)%QROF,ISDMAXROW) CALL WGRIDGETREAL(IDF_GRID1,14,DATISD2(J,:)%PPTSW,ISDMAXROW) CALL WGRIDGETREAL(IDF_GRID1,15,DATISD2(J,:)%ETSW ,ISDMAXROW) ENDIF CALL IDEBUGLEVEL(IDBG) TISD(J)=0 DO I=1,ISDMAXROW !## determine fullfillness of current row i IF(ISFR.EQ.0)THEN IF(DATISD2(J,I)%IDATE.EQ.INODATA)EXIT IF(DATISD2(J,I)%WLVL .EQ.RNODATA)EXIT IF(DATISD2(J,I)%BTML .EQ.RNODATA)EXIT IF(DATISD2(J,I)%RESIS.EQ.RNODATA)EXIT IF(DATISD2(J,I)%INFF .EQ.RNODATA)EXIT ELSEIF(ISFR.EQ.1)THEN IF(DATISD2(J,I)%IDATE.EQ.INODATA)EXIT IF(DATISD2(J,I)%CTIME.EQ.'')EXIT !## skip this at is optional IF(DATISD2(J,I)%BTML .EQ.RNODATA)EXIT IF(DATISD2(J,I)%THCK .EQ.RNODATA)EXIT IF(DATISD2(J,I)%HCND .EQ.RNODATA)EXIT !## allowed to enter all values - skip in check IF(DATISD2(J,I)%ICLC .EQ.INODATA)EXIT IF(DATISD2(J,I)%IPRI .EQ.INODATA)EXIT IF(DATISD2(J,I)%QFLW .EQ.RNODATA)EXIT IF(DATISD2(J,I)%QROF .EQ.RNODATA)EXIT IF(DATISD2(J,I)%PPTSW .EQ.RNODATA)EXIT IF(DATISD2(J,I)%ETSW .EQ.RNODATA)EXIT ENDIF TISD(J)=TISD(J)+1 END DO IF(ISFR.EQ.0)THEN CALL SORTEMI(1,TISD(J),DATISD2(J,:)%IDATE,4,DATISD2(J,:)%WLVL,DATISD2(J,:)%BTML,DATISD2(J,:)%RESIS,DATISD2(J,:)%INFF & ,(/0.0/),(/0.0/),(/0.0/)) ELSEIF(ISFR.EQ.1)THEN ALLOCATE(CLIST(TISD(J)),IORDER(TISD(J))) DO I=1,TISD(J) WRITE(CLIST(I),'(I8.8,3A2)') DATISD2(J,I)%IDATE,DATISD2(J,I)%CTIME(1:2),DATISD2(J,I)%CTIME(4:5),DATISD2(J,I)%CTIME(7:8) ENDDO CALL WSORT(CLIST,1,TISD(J),0,IORDER) DO I=1,TISD(J) IROW=IORDER(I) CALL WGRIDGETCELLINTEGER(IDF_GRID1,1,IROW,DATISD2(J,I)%IDATE) CALL WGRIDGETCELLSTRING(IDF_GRID1,2,IROW,DATISD2(J,I)%CTIME) CALL WGRIDGETCELLREAL(IDF_GRID1,3,IROW,DATISD2(J,I)%WLVL) CALL WGRIDGETCELLREAL(IDF_GRID1,4,IROW,DATISD2(J,I)%BTML) CALL WGRIDGETCELLREAL(IDF_GRID1,5,IROW,DATISD2(J,I)%WIDTH) CALL WGRIDGETCELLREAL(IDF_GRID1,6,IROW,DATISD2(J,I)%THCK) CALL WGRIDGETCELLREAL(IDF_GRID1,7,IROW,DATISD2(J,I)%HCND) CALL WGRIDGETCELLINTEGER(IDF_GRID1,8,IROW,DATISD2(J,I)%UPSG) CALL WGRIDGETCELLINTEGER(IDF_GRID1,9,IROW,DATISD2(J,I)%DWNS) CALL WGRIDGETCELLMENU(IDF_GRID1,10,IROW,DATISD2(J,I)%ICLC) CALL WGRIDGETCELLMENU(IDF_GRID1,11,IROW,DATISD2(J,I)%IPRI) CALL WGRIDGETCELLREAL(IDF_GRID1,12,IROW,DATISD2(J,I)%QFLW) CALL WGRIDGETCELLREAL(IDF_GRID1,13,IROW,DATISD2(J,I)%QROF) CALL WGRIDGETCELLREAL(IDF_GRID1,14,IROW,DATISD2(J,I)%PPTSW) CALL WGRIDGETCELLREAL(IDF_GRID1,15,IROW,DATISD2(J,I)%ETSW) ENDDO ! !## make sure the following attributes are synchronized ! I1=1; I2=2; IF(J.EQ.1)THEN; I1=2; I2=1; ENDIF ! DO I=1,TISD(J) ! DATISD2()%DWNS=DATISD2()%DWNS ! ENDDO DEALLOCATE(CLIST,IORDER) ENDIF !## use new one next time ... CALL WDIALOGGETMENU(IDF_MENU1,J) SELISD=J END SUBROUTINE ISGATTRIBUTESGETISDVALUES !###==================================================================== SUBROUTINE ISGATTRIBUTESGETISCVALUES() !###==================================================================== IMPLICIT NONE INTEGER :: I,J,IDBG CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB2) CALL WDIALOGGETMENU(IDF_MENU1,J) !## use previous one ... IF(SELISC.GT.0)J=SELISC J=MIN(J,ISG(ISELISG)%NCRS) CALL WDIALOGUNDEFINED(RVALUE=RNODATA) IDBG=INFOERROR(DEBUGLEVEL) CALL IDEBUGLEVEL(0) CALL WGRIDGETREAL(IDF_GRID1,1,DATISC2(J,:)%DISTANCE,ISCMAXROW) CALL WGRIDGETREAL(IDF_GRID1,2,DATISC2(J,:)%BOTTOM,ISCMAXROW) CALL WGRIDGETREAL(IDF_GRID1,3,DATISC2(J,:)%MRC,ISCMAXROW) !## read pointer values IF(DATISC2(J,1)%DISTANCE.LT.0.0.AND.DATISC2(J,1)%BOTTOM.LT.0.0)THEN CALL WGRIDGETREAL(IDF_GRID1,4,DATISC2(J,:)%ZP,ISCMAXROW) ENDIF CALL IDEBUGLEVEL(IDBG) TISC(J)=0 DO I=1,ISCMAXROW !## determine fullfillness of current row i IF(DATISC2(J,I)%DISTANCE.EQ.RNODATA)EXIT IF(DATISC2(J,I)%BOTTOM.EQ.RNODATA) EXIT IF(DATISC2(J,I)%MRC.EQ.RNODATA) EXIT TISC(J)=TISC(J)+1 END DO !## sort whenever 1d cross-sections are concerned IF(ISCN(J).EQ.1)THEN CALL SORTEM(1,TISC(J),DATISC2(J,:)%DISTANCE,2,DATISC2(J,:)%BOTTOM,DATISC2(J,:)%MRC,DATISC2(J,:)%ZP,(/0.0/),(/0.0/),(/0.0/),(/0.0/)) ENDIF !## use new one next time ... CALL WDIALOGGETMENU(IDF_MENU1,J) SELISC=J END SUBROUTINE ISGATTRIBUTESGETISCVALUES !###==================================================================== SUBROUTINE ISGATTRIBUTESGETISTVALUES() !###==================================================================== IMPLICIT NONE INTEGER :: I,J,IDBG CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB4) CALL WDIALOGGETMENU(IDF_MENU1,J) !## use previous one ... IF(SELIST.GT.0)J=SELIST J=MIN(J,ISG(ISELISG)%NSTW) CALL WDIALOGUNDEFINED(INODATA,RNODATA) IDBG=INFOERROR(DEBUGLEVEL) CALL IDEBUGLEVEL(0) CALL WGRIDGETINTEGER(IDF_GRID1,1,DATIST2(J,:)%IDATE,ISTMAXROW) CALL WGRIDGETREAL(IDF_GRID1,2,DATIST2(J,:)%WLVL_UP,ISTMAXROW) CALL WGRIDGETREAL(IDF_GRID1,3,DATIST2(J,:)%WLVL_DOWN,ISTMAXROW) CALL IDEBUGLEVEL(IDBG) TIST(J)=0 DO I=1,ISTMAXROW !## determine fullfillness of current row i IF(DATIST2(J,I)%IDATE.EQ.INODATA) EXIT IF(DATIST2(J,I)%WLVL_UP.EQ.RNODATA) EXIT IF(DATIST2(J,I)%WLVL_DOWN.EQ.RNODATA)EXIT TIST(J)=TIST(J)+1 END DO CALL SORTEMI(1,TIST(J),DATIST2(J,:)%IDATE,2,DATIST2(J,:)%WLVL_UP,DATIST2(J,:)%WLVL_DOWN,DATIST2(J,:)%WLVL_UP,DATIST2(J,:)%WLVL_UP & ,(/0.0/),(/0.0/),(/0.0/)) !DATIST2(J,:)%WLVL_UP,DATIST2(J,:)%WLVL_UP ,DATIST2(J,:)%WLVL_UP) !## use new one next time ... CALL WDIALOGGETMENU(IDF_MENU1,J) SELIST=J END SUBROUTINE ISGATTRIBUTESGETISTVALUES !###==================================================================== SUBROUTINE ISGATTRIBUTESGETISQVALUES() !###==================================================================== IMPLICIT NONE INTEGER :: I,J,IDBG CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB5) CALL WDIALOGGETMENU(IDF_MENU1,J) !## use previous one ... IF(SELISQ.GT.0)J=SELISQ J=MIN(J,ISG(ISELISG)%NQHR) CALL WDIALOGUNDEFINED(INODATA,RNODATA) IDBG=INFOERROR(DEBUGLEVEL) CALL IDEBUGLEVEL(0) CALL WGRIDGETREAL(IDF_GRID1,1,DATISQ2(J,:)%Q,ISQMAXROW) CALL WGRIDGETREAL(IDF_GRID1,2,DATISQ2(J,:)%W,ISQMAXROW) CALL WGRIDGETREAL(IDF_GRID1,3,DATISQ2(J,:)%D,ISQMAXROW) CALL WGRIDGETREAL(IDF_GRID1,4,DATISQ2(J,:)%F,ISQMAXROW) CALL IDEBUGLEVEL(IDBG) TISQ(J)=0 DO I=1,ISQMAXROW !## determine fullfillness of current row i IF(DATISQ2(J,I)%Q.EQ.RNODATA)EXIT IF(DATISQ2(J,I)%W.EQ.RNODATA)EXIT IF(DATISQ2(J,I)%D.EQ.RNODATA)EXIT IF(DATISQ2(J,I)%F.EQ.RNODATA)EXIT TISQ(J)=TISQ(J)+1 END DO CALL SORTEM(1,TISQ(J),DATISQ2(J,:)%Q,3,DATISQ2(J,:)%W,DATISQ2(J,:)%D,DATISQ2(J,:)%F,(/0.0/) & ,(/0.0/),(/0.0/),(/0.0/)) !## use new one next time ... CALL WDIALOGGETMENU(IDF_MENU1,J) SELISQ=J END SUBROUTINE ISGATTRIBUTESGETISQVALUES !###==================================================================== SUBROUTINE ISGATTRIBUTESGETISPVALUES() !###==================================================================== IMPLICIT NONE INTEGER :: I,IDBG CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB3) CALL WDIALOGUNDEFINED(RVALUE=RNODATA) IDBG=INFOERROR(DEBUGLEVEL) CALL IDEBUGLEVEL(0) CALL WGRIDGETREAL(IDF_GRID1,1,ISP2%X,ISPMAXROW) CALL WGRIDGETREAL(IDF_GRID1,2,ISP2%Y,ISPMAXROW) CALL IDEBUGLEVEL(IDBG) TISP=0 DO I=1,ISPMAXROW !## determine fullfillness of current row i IF(ISP2(I)%X.EQ.RNODATA)EXIT IF(ISP2(I)%Y.EQ.RNODATA)EXIT TISP=TISP+1 ENDDO END SUBROUTINE ISGATTRIBUTESGETISPVALUES !###====================================================================== SUBROUTINE ISGATTRIBUTES() !###====================================================================== IMPLICIT NONE INTEGER :: ITYPE,I,J,ITAB,IX INTEGER,ALLOCATABLE,DIMENSION(:) :: IOPTIONS TYPE(WIN_MESSAGE) :: MESSAGE REAL :: Y LOGICAL :: LEX CALL WDIALOGSELECT(ID_DISGEDITTAB1) CALL WDIALOGGETMENU(IDF_MENU1,ISG(1:NISG)%ILIST) IF(SUM(ISG(1:NISG)%ILIST).NE.1)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You need to select just 1 Segment before entering the attributes-dialog','Information') RETURN ENDIF DO ISELISG=1,NISG; IF(ISG(ISELISG)%ILIST.EQ.1)EXIT; END DO CALL WDIALOGLOAD(ID_DISGATTRIBUTES,ID_DISGATTRIBUTES) CALL WDIALOGPUTSTRING(IDF_GROUP1,'Attributes for segment: '//TRIM(ISG(ISELISG)%SNAME)) CALL WDIALOGPUTSTRING(IDOK,'Save') CALL WDIALOGPUTSTRING(IDCANCEL,'Cancel') !## isp-tab CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB3) CALL WDIALOGPUTIMAGE(ID_OPEN, ID_ICONOPEN,1) CALL WDIALOGPUTIMAGE(ID_SAVEAS,ID_ICONSAVEAS,1) CALL WDIALOGPUTIMAGE(ID_ROTATE,ID_ICONFLIP,1) ISPMAXROW=WINFOGRID(IDF_GRID1,GRIDROWSMAX) !## isc-tab CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB2) CALL WDIALOGPUTIMAGE(ID_RENAME,ID_ICONRENAME,1) CALL WDIALOGPUTIMAGE(ID_OPEN,ID_ICONOPEN,1) CALL WDIALOGPUTIMAGE(ID_SAVEAS,ID_ICONSAVEAS,1) CALL WDIALOGPUTIMAGE(ID_COPY,ID_ICONCOPY,1) CALL WDIALOGPUTIMAGE(ID_UPDATE,ID_ICONREDRAW,1) CALL WDIALOGPUTIMAGE(ID_MATH,ID_ICONCALC,1) CALL WDIALOGPUTIMAGE(ID_PICK,ID_ICONSELECTPOINT,1) CALL WDIALOGPUTIMAGE(ID_TABLE,ID_ICONEDITATTRIB,1) ISCMAXROW=WINFOGRID(IDF_GRID1,GRIDROWSMAX) !## isd tab CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB1) CALL WDIALOGPUTIMAGE(ID_RENAME,ID_ICONRENAME,1) CALL WDIALOGPUTIMAGE(ID_OPEN,ID_ICONOPEN,1) CALL WDIALOGPUTIMAGE(ID_SAVEAS,ID_ICONSAVEAS,1) CALL WDIALOGPUTIMAGE(ID_COPY,ID_ICONCOPY,1) CALL WDIALOGPUTIMAGE(ID_UPDATE,ID_ICONREDRAW,1) CALL WDIALOGPUTIMAGE(ID_MATH,ID_ICONCALC,1) ISDMAXROW=WINFOGRID(IDF_GRID1,GRIDROWSMAX) !## riv-approach isg IF(ISFR.EQ.0)THEN CALL WGRIDCOLUMNS(IDF_GRID1,SIZE(ISDLABELS),CTATTRIB1) DO I=1,SIZE(ISDLABELS); CALL WGRIDLABELCOLUMN(IDF_GRID1,I,ISDLABELS(I)); ENDDO !## sfr-approach isg ELSEIF(ISFR.EQ.1)THEN CALL WGRIDCOLUMNS(IDF_GRID1,SIZE(ISDLABELS),CTATTRIB2) DO I=1,SIZE(ISDLABELS); CALL WGRIDLABELCOLUMN(IDF_GRID1,I,ISDLABELS(I)); ENDDO ALLOCATE(IOPTIONS(ISDMAXROW)); IOPTIONS=1 CALL WGRIDPUTMENU(IDF_GRID1,10,(/'Static', 'Rectangular', 'Eight Point', 'Power (not supported)', 'Relationship'/),5,IOPTIONS,ISDMAXROW) CALL WGRIDPUTMENU(IDF_GRID1,11,(/'Maximal','Minimal','Fraction','Flooding'/),4,IOPTIONS,ISDMAXROW) DEALLOCATE(IOPTIONS) !## fill menu fields ENDIF !## ist-tab CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB4) CALL WDIALOGPUTIMAGE(ID_RENAME,ID_ICONRENAME,1) CALL WDIALOGPUTIMAGE(ID_OPEN,ID_ICONOPEN,1) CALL WDIALOGPUTIMAGE(ID_SAVEAS,ID_ICONSAVEAS,1) CALL WDIALOGPUTIMAGE(ID_COPY,ID_ICONCOPY,1) CALL WDIALOGPUTIMAGE(ID_UPDATE,ID_ICONREDRAW,1) CALL WDIALOGPUTIMAGE(ID_MATH,ID_ICONCALC,1) ISTMAXROW=WINFOGRID(IDF_GRID1,GRIDROWSMAX) !## isq-tab CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB5) CALL WDIALOGPUTIMAGE(ID_RENAME,ID_ICONRENAME,1) CALL WDIALOGPUTIMAGE(ID_OPEN,ID_ICONOPEN,1) CALL WDIALOGPUTIMAGE(ID_SAVEAS,ID_ICONSAVEAS,1) CALL WDIALOGPUTIMAGE(ID_COPY,ID_ICONCOPY,1) CALL WDIALOGPUTIMAGE(ID_UPDATE,ID_ICONREDRAW,1) CALL WDIALOGPUTIMAGE(ID_MATH,ID_ICONCALC,1) ISQMAXROW=WINFOGRID(IDF_GRID1,GRIDROWSMAX) SELISD=0; SELISC=0; SELIST=0; SELISQ=0 LEX=.FALSE. !## record position - waterlevels IF(ISGATTRIBUTESREADISDVALUE())THEN !## record position - cross-section IF(ISGATTRIBUTESREADISCVALUE(ID_DISGATTRIBUTESTAB2))THEN !## record position - structures IF(ISGATTRIBUTESREADISTVALUE())THEN !## record position - qh-relationships IF(ISGATTRIBUTESREADISQVALUE())THEN !## put coordinates for selected segment IF(ISGATTRIBUTESREADISPVALUE())LEX=.TRUE. ENDIF ENDIF ENDIF ENDIF !## read everything IF(LEX)THEN !## put selected values for current cross-section CALL ISGATTRIBUTESPUTISCVALUES() !## put selected values for current calculation point CALL ISGATTRIBUTESPUTISDVALUES() !## put selected values for current weir point CALL ISGATTRIBUTESPUTISTVALUES() !## put selected values for current qh relationship CALL ISGATTRIBUTESPUTISQVALUES() !## put selected values for current segment CALL ISGATTRIBUTESPUTISPVALUES() CALL WDIALOGSELECT(ID_DISGATTRIBUTES) CALL IGRSELECT(3,IDF_PICTURE1) CALL WCURSORSHAPE(CURARROW) CALL WDIALOGSELECT(ID_DMANAGER) CALL WDIALOGHIDE() CALL WDIALOGSELECT(ID_DISGATTRIBUTES) IF(ISFR.EQ.0)THEN CALL WDIALOGPUTMENU(IDF_MENU1,ISDLABELS(2:),SIZE(ISDLABELS)-1,1) ELSEIF(ISFR.EQ.1)THEN CALL WDIALOGPUTMENU(IDF_MENU1,ISDLABELS(3:),SIZE(ISDLABELS)-2,1) ENDIF CALL WDIALOGSHOW(-1,-1,0,3) !## read values from dialog CALL ISGATTRIBUTESUPDATEPLOTS() DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE (MOUSEMOVE) IF(MESSAGE%WIN.EQ.ID_DISGATTRIBUTES)THEN CALL WDIALOGSELECT(ID_DISGATTRIBUTES) CALL WDIALOGGETTAB(IDF_TAB1,ITAB) !## waterlevels, etc. IF(ITAB.EQ.ID_DISGATTRIBUTESTAB1.OR. & ITAB.EQ.ID_DISGATTRIBUTESTAB4)THEN IX=INT(MESSAGE%GX) Y =MESSAGE%GY CALL WDIALOGSELECT(ID_DISGATTRIBUTES) CALL WDIALOGPUTSTRING(IDF_STRING2,UTL_WRITENUMBER(Y)) CALL WDIALOGPUTSTRING(IDF_STRING1,TRIM(JDATETOFDATE(MESSAGE%GX,0))) !## cross-section/qh relationships/coordinates ELSEIF(ITAB.EQ.ID_DISGATTRIBUTESTAB2.OR. & ITAB.EQ.ID_DISGATTRIBUTESTAB3.OR. & ITAB.EQ.ID_DISGATTRIBUTESTAB5)THEN CALL WDIALOGPUTSTRING(IDF_STRING1,UTL_WRITENUMBER(MESSAGE%GX)) CALL WDIALOGPUTSTRING(IDF_STRING2,UTL_WRITENUMBER(MESSAGE%GY)) ENDIF ENDIF CASE (FIELDCHANGED) SELECT CASE (MESSAGE%VALUE1) CASE (IDF_CHECK1,IDF_CHECK2,IDF_CHECK3) IF(MESSAGE%WIN.EQ.ID_DISGATTRIBUTESTAB2)CALL ISGATTRIBUTESUPDATEPLOTS() CASE (IDF_RADIO1,IDF_RADIO2) IF(MESSAGE%WIN.EQ.ID_DISGATTRIBUTESTAB2)THEN IF(MESSAGE%VALUE1.EQ.MESSAGE%VALUE2)THEN CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONNO,'Are you sure to switch between 1D and 2D cross-section type?','Question') IF(WINFODIALOG(4).EQ.1)THEN CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB2) CALL WDIALOGGETMENU(IDF_MENU1,J) CALL WDIALOGGETRADIOBUTTON(IDF_RADIO1,I) ISCN(J)=1; IF(I.EQ.2)ISCN(J)=-1 CALL ISGATTRIBUTESUPDATEPLOTS() CALL ISGATTRIBUTESPUTISCVALUES() ELSE IF(MESSAGE%VALUE1.EQ.IDF_RADIO1)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO2) IF(MESSAGE%VALUE1.EQ.IDF_RADIO2)CALL WDIALOGPUTRADIOBUTTON(IDF_RADIO1) ENDIF ENDIF ENDIF END SELECT SELECT CASE (MESSAGE%VALUE2) CASE (IDF_MENU1) !## read adjustments first before putting new ones! CALL ISGATTRIBUTESUPDATEPLOTS() IF(MESSAGE%WIN.EQ.ID_DISGATTRIBUTESTAB1)THEN !## put selected values for current calculation point CALL ISGATTRIBUTESPUTISDVALUES() !## read/plot new puttings CALL ISGATTRIBUTESUPDATEPLOTS() ELSEIF(MESSAGE%WIN.EQ.ID_DISGATTRIBUTESTAB2)THEN !## put selected values for current cross-section CALL ISGATTRIBUTESPUTISCVALUES() !## read/plot new puttings CALL ISGATTRIBUTESUPDATEPLOTS() ELSEIF(MESSAGE%WIN.EQ.ID_DISGATTRIBUTESTAB4)THEN !## put selected values for current weir point CALL ISGATTRIBUTESPUTISTVALUES() !## read/plot new puttings CALL ISGATTRIBUTESUPDATEPLOTS() ELSEIF(MESSAGE%WIN.EQ.ID_DISGATTRIBUTESTAB5)THEN !## put selected values for current qh relationship CALL ISGATTRIBUTESPUTISQVALUES() !## read/plot new puttings CALL ISGATTRIBUTESUPDATEPLOTS() ENDIF END SELECT CASE (PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (ID_PICK) CALL ISGATTRIBUTES_2DCROSS() CALL ISGATTRIBUTESUPDATEPLOTS() CASE (ID_TABLE) CALL ISGATTRIBUTESUPDATEPLOTS() CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB2) CALL WDIALOGGETMENU(IDF_MENU1,J) IF(ISGATTRIBUTES_2DCROSS_TABLE(J))CALL ISGATTRIBUTESPUTISCVALUES() !## compute something CASE (ID_MATH) CALL ISGATTRIBUTESMATH(MESSAGE%WIN) !## rename name cross-section CASE (ID_RENAME) CALL ISGATTRIBUTESRENAME() !## copy cross-section definition from other cross-section CASE (ID_COPY) CALL ISGATTRIBUTESCOPY() !## plot cross-section/heads CASE (ID_UPDATE) CALL ISGATTRIBUTESUPDATEPLOTS() !## open/save data CASE (ID_OPEN,ID_SAVEAS) CALL ISGATTRIBUTESSAVEOPEN(MESSAGE%VALUE1) CASE (ID_ROTATE) CALL ISGATTRIBUTESROTATEISP() CALL ISGATTRIBUTESUPDATEPLOTS() CASE (IDOK) CALL ISGATTRIBUTESUPDATEPLOTS() CALL ISGATTRIBUTESSAVE() EXIT CASE (IDHELP) CALL IMODGETHELP('4.4.3.2','MMO.IGO.IE.Attr') CASE (IDCANCEL) ! CALL ISGATTRIBUTESUPDATEPLOTS() ! CALL WMESSAGEBOX(YESNOCANCEL,QUESTIONICON,COMMONNO,'Do you want to take any adjustments made ?', & ! 'Question') ! IF(WINFODIALOG(4).GT.0)THEN ! IF(WINFODIALOG(4).EQ.1)CALL ISGATTRIBUTESSAVE() EXIT ! ENDIF END SELECT CASE (EXPOSE,RESIZE,TABCHANGED) CALL ISGATTRIBUTESUPDATEPLOTS() END SELECT ENDDO ENDIF CALL WDIALOGSELECT(ID_DISGATTRIBUTES); CALL WDIALOGUNLOAD() IF(ALLOCATED(DATISD2))DEALLOCATE(DATISD2); IF(ALLOCATED(DATISC2))DEALLOCATE(DATISC2) IF(ALLOCATED(DATIST2))DEALLOCATE(DATIST2); IF(ALLOCATED(DATISQ2))DEALLOCATE(DATISQ2) IF(ALLOCATED(TISD))DEALLOCATE(TISD); IF(ALLOCATED(TISC))DEALLOCATE(TISC) IF(ALLOCATED(TIST))DEALLOCATE(TIST); IF(ALLOCATED(TISQ))DEALLOCATE(TISQ) IF(ALLOCATED(ISCN))DEALLOCATE(ISCN) CALL IGRSELECT(DRAWWIN,MPW%IWIN); CALL IGRAREA(0.0,0.0,1.0,1.0) CALL IGRUNITS(MPW%XMIN,MPW%YMIN,MPW%XMAX,MPW%YMAX) CALL IDFPLOTFAST(1) END SUBROUTINE ISGATTRIBUTES !###==================================================================== SUBROUTINE ISGATTRIBUTES_2DCROSS() !###==================================================================== IMPLICIT NONE INTEGER :: ITYPE,I,J,ICHK,ICAL TYPE(WIN_MESSAGE) :: MESSAGE CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB2) CALL WDIALOGGETMENU(IDF_MENU1,J) CALL WDIALOGLOAD(ID_DISGCROSS2D,ID_DISGCROSS2D) J=ISG(ISELISG)%ICRS-1+J CALL WDIALOGPUTSTRING(IDF_LABEL3,'Cross-Section:'//TRIM(ISC(J)%CNAME)) ICROSS_PNTR=MAX(1,ICROSS_PNTR); ICROSS_ZVAL=MAX(1,ICROSS_ZVAL) ICROSS_HPNT=MAX(1,ICROSS_HPNT); ICROSS_CPNT=MAX(1,ICROSS_CPNT) CALL WDIALOGPUTMENU(IDF_MENU1,MP%ALIAS,MPW%NACT,ICROSS_PNTR) CALL WDIALOGPUTMENU(IDF_MENU2,MP%ALIAS,MPW%NACT,ICROSS_ZVAL) CALL WDIALOGPUTMENU(IDF_MENU3,MP%ALIAS,MPW%NACT,ICROSS_HPNT) CALL WDIALOGPUTMENU(IDF_MENU4,MP%ALIAS,MPW%NACT,ICROSS_CPNT) CALL WDIALOGSHOW(-1,-1,0,2) DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE (FIELDCHANGED) SELECT CASE (MESSAGE%VALUE2) CASE (IDF_CHECK1) CALL WDIALOGGETCHECKBOX(IDF_CHECK1,I) CALL WDIALOGFIELDSTATE(IDF_MENU3,I); CALL WDIALOGFIELDSTATE(IDF_LABEL4,I) CALL WDIALOGFIELDSTATE(IDF_CHECK2,I) IF(I.EQ.1)CALL WDIALOGGETCHECKBOX(IDF_CHECK2,I) CALL WDIALOGFIELDSTATE(IDF_MENU4,I); CALL WDIALOGFIELDSTATE(IDF_LABEL5,I) CASE (IDF_CHECK2) CALL WDIALOGGETCHECKBOX(IDF_CHECK2,I) CALL WDIALOGFIELDSTATE(IDF_MENU4,I); CALL WDIALOGFIELDSTATE(IDF_LABEL5,I) END SELECT CASE (PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (IDOK) CALL WDIALOGGETMENU(IDF_MENU1,ICROSS_PNTR) CALL WDIALOGGETMENU(IDF_MENU2,ICROSS_ZVAL) CALL WDIALOGGETCHECKBOX(IDF_CHECK1,ICHK); ICROSS_HPNT=0 IF(ICHK.EQ.1)CALL WDIALOGGETMENU(IDF_MENU3,ICROSS_HPNT) CALL WDIALOGGETCHECKBOX(IDF_CHECK2,ICAL); ICROSS_CPNT=0 IF(ICAL.EQ.1)CALL WDIALOGGETMENU(IDF_MENU4,ICROSS_CPNT) IF(ISGATTRIBUTES_2DCROSS_ADD(J,ICHK,ICAL))EXIT CASE (IDCANCEL) EXIT END SELECT END SELECT ENDDO CALL WDIALOGSELECT(ID_DISGCROSS2D); CALL WDIALOGUNLOAD() CALL WDIALOGSELECT(ID_DISGATTRIBUTES) END SUBROUTINE ISGATTRIBUTES_2DCROSS !###==================================================================== LOGICAL FUNCTION ISGATTRIBUTES_2DCROSS_ADD(J,ICHK,ICAL) !###==================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: J,ICHK,ICAL TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:) :: ICROSS INTEGER :: I,IROW,ICOL,IPNT,NPNT INTEGER(KIND=1) :: CF REAL :: IP,TD,ZVAL,XC,YC ISGATTRIBUTES_2DCROSS_ADD=.FALSE. IF(MP(ICROSS_PNTR)%IPLOT.NE.1.OR.MP(ICROSS_ZVAL)%IPLOT.NE.1)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You need to select IDF files for the Bathemetry Pointer and Z-values.','Error') RETURN ENDIF IF(ICHK.EQ.1)THEN IF(MP(ICROSS_HPNT)%IPLOT.NE.1)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You need to select an IDF file for the Reference Height.','Error') RETURN ENDIF ENDIF IF(ICAL.EQ.1)THEN IF(MP(ICROSS_CPNT)%IPLOT.NE.1)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'You need to select an IDF file for the Resistance Values.','Error') RETURN ENDIF ENDIF ALLOCATE(ICROSS(2+ICHK+ICAL)); DO I=1,SIZE(ICROSS); CALL IDFNULLIFY(ICROSS(I)); ENDDO !## pointer is determining for the size and resolution IF(.NOT.IDFREAD(ICROSS(1),MP(ICROSS_PNTR)%IDFNAME,1))RETURN CALL IDFCOPY(ICROSS(1),ICROSS(2)) IF(.NOT.IDFREADSCALE(MP(ICROSS_ZVAL)%IDFNAME,ICROSS(2),2,1,0.0,0))RETURN !## read reference heigth as well is ichk.eq.1 IF(ICHK.EQ.1)THEN CALL IDFCOPY(ICROSS(1),ICROSS(3)) IF(.NOT.IDFREADSCALE(MP(ICROSS_HPNT)%IDFNAME,ICROSS(3),2,1,0.0,0))RETURN ENDIF !## read reference heigth as well is ichk.eq.1 IF(ICAL.EQ.1)THEN CALL IDFCOPY(ICROSS(1),ICROSS(4)) IF(.NOT.IDFREADSCALE(MP(ICROSS_CPNT)%IDFNAME,ICROSS(4),2,1,0.0,0))RETURN ENDIF !## number of nodes on segment NPNT=ISG(ISELISG)%NSEG; IPNT=ISG(ISELISG)%ISEG !## compute correct x/y coordinate of current cross-section CALL ISGADJUSTCOMPUTEXY(IPNT,NPNT,ISC(J)%DIST,TD) CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB2) CALL WDIALOGCLEARFIELD(IDF_GRID1) CALL IDFIROWICOL(ICROSS(1),IROW,ICOL,ISGX,ISGY) IF(IROW.NE.0.AND.ICOL.NE.0)THEN IP=ICROSS(1)%X(ICOL,IROW) IF(IP.NE.ICROSS(1)%NODATA)THEN I=1 !## write 0.0 for reference level IF(ICHK.EQ.0)THEN CALL WGRIDPUTCELLREAL(IDF_GRID1,1,I,ICROSS(1)%DX,'(F10.2)') CALL WGRIDPUTCELLREAL(IDF_GRID1,2,I,ICROSS(1)%DY,'(F10.2)') CALL WGRIDPUTCELLREAL(IDF_GRID1,3,I,0.0,'(F10.2)') ELSE CALL WGRIDPUTCELLREAL(IDF_GRID1,1,I,-ICROSS(1)%DX,'(F10.2)') CALL WGRIDPUTCELLREAL(IDF_GRID1,2,I,-ICROSS(1)%DY,'(F10.2)') !## write reference height CALL WGRIDPUTCELLREAL(IDF_GRID1,3,I,ICROSS(3)%X(ICOL,IROW),'(F10.2)') CALL WGRIDPUTCELLREAL(IDF_GRID1,4,I,0.0,'(F5.1)') ENDIF DO IROW=1,ICROSS(1)%NROW; DO ICOL=1,ICROSS(1)%NCOL !## location of gridcell equal to pointer value at location of cross-section IF(ABS(ICROSS(1)%X(ICOL,IROW)).EQ.ABS(IP))THEN ZVAL=ICROSS(2)%X(ICOL,IROW) IF(ZVAL.NE.ICROSS(2)%NODATA)THEN I=I+1 IF(I.GT.ISCMAXROW)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Maximum number of records is '//TRIM(ITOS(ISCMAXROW))//CHAR(13)// & 'Current bathemetry exceeds these number of records, rest will be left out!','Error') RETURN ENDIF CALL IDFGETLOC(ICROSS(1),IROW,ICOL,XC,YC) CALL WGRIDPUTCELLREAL(IDF_GRID1,1,I,XC,'(F10.2)') CALL WGRIDPUTCELLREAL(IDF_GRID1,2,I,YC,'(F10.2)') CALL WGRIDPUTCELLREAL(IDF_GRID1,3,I,ZVAL,'(F10.2)') IF(ICHK.EQ.1)THEN CF=INT(1,1) IF(ICAL.EQ.1)THEN IF(INT(ICROSS(4)%X(ICOL,IROW)).LE.HUGE(CF))CF=INT(ICROSS(4)%X(ICOL,IROW)) ENDIF IF(ICROSS(1)%X(ICOL,IROW).LT.0.0)CALL WGRIDPUTCELLINTEGER(IDF_GRID1,4,I,-INT(CF)) !## inundated if thresshold exceeded IF(ICROSS(1)%X(ICOL,IROW).GT.0.0)CALL WGRIDPUTCELLINTEGER(IDF_GRID1,4,I, INT(CF)) !## inundated no matter what ENDIF ENDIF ENDIF ENDDO; ENDDO ELSE CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Pointer value is equal to nodata value','Error') ENDIF ELSE CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Position of cross-section is outside Pointer IDF','Error') ENDIF CALL IDFDEALLOCATE(ICROSS,SIZE(ICROSS)); DEALLOCATE(ICROSS) IF(I.EQ.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'No Bathemetry found with values not equal to its NodataValue','Error') ELSE ISGATTRIBUTES_2DCROSS_ADD=.TRUE. ENDIF END FUNCTION ISGATTRIBUTES_2DCROSS_ADD !###====================================================================== LOGICAL FUNCTION ISGATTRIBUTES_2DCROSS_TABLE(J) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: J INTEGER :: ITYPE,IROW,ICOL,IPLTCLR,ICLR REAL :: ZCHK TYPE(WIN_MESSAGE) :: MESSAGE TYPE(IDFOBJ) :: IDF,PIDF ISGATTRIBUTES_2DCROSS_TABLE=.FALSE. IF(.NOT.ISGATTRIBUTES_2DCROSS_READ(J,IDF,PIDF,ZCHK))RETURN CALL WDIALOGLOAD(ID_DIDFEDITTABLE,ID_DIDFEDITTABLE) IF(IDF%NROW.GT.WINFOGRID(IDF_GRID1,GRIDROWSMAX))THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMOD cannot present results in table'//CHAR(13)// & 'with more than '//TRIM(ITOS(WINFOGRID(IDF_GRID1,GRIDROWSMAX)))//' rows','Warning') CALL WDIALOGUNLOAD(); CALL IDFDEALLOCATEX(IDF) RETURN ENDIF CALL WDIALOGSELECT(ID_DIDFEDITTABLE); CALL WDIALOGPUTINTEGER(IDF_INTEGER1,30) CALL WDIALOGSELECT(ID_DIDFEDITTABLE); CALL WDIALOGSHOW(0,0,0,3) CALL WDIALOGFIELDOPTIONS(IDF_GRID1,EDITFIELDCHANGED,1) CALL WDIALOGUNDEFINED(RVALUE=IDF%NODATA) IF(ICROSS_ZVAL.EQ.0)THEN CALL WDIALOGFIELDSTATE(IDF_CHECK1,0) CALL WDIALOGPUTCHECKBOX(IDF_CHECK1,0) ENDIF CALL WDIALOGGETCHECKBOX(IDF_CHECK1,IPLTCLR) CALL ISGATTRIBUTES_2DCROSS_TABLEVALUES(IDF%NCOL,IDF%NROW,IDF%X,IDF%NODATA,IPLTCLR) DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE (FIELDCHANGED) SELECT CASE (MESSAGE%VALUE1) CASE (IDF_CHECK1) CALL WDIALOGGETCHECKBOX(IDF_CHECK1,IPLTCLR) CALL ISGATTRIBUTES_2DCROSS_TABLEVALUES(IDF%NCOL,IDF%NROW,IDF%X,IDF%NODATA,IPLTCLR) CASE (IDF_GRID1) CALL WGRIDPOS(MESSAGE%X,ICOL,IROW) CALL WGRIDGETCELLREAL(IDF_GRID1,ICOL,IROW,IDF%X(ICOL,IROW)) IF(IDF%X(ICOL,IROW).NE.IDF%NODATA)THEN IF(IPLTCLR.EQ.1)THEN ICLR=UTL_IDFGETCLASS(MP(ICROSS_ZVAL)%LEG,IDF%X(ICOL,IROW)) CALL WGRIDCOLOURCELL(IDF_GRID1,ICOL,IROW,-1,ICLR) ELSE CALL WGRIDCOLOURCELL(IDF_GRID1,ICOL,IROW,-1,-1) ENDIF ENDIF END SELECT CASE (PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (ID_WIDTH) CALL ISGATTRIBUTES_2DCROSS_TABLEVALUES(IDF%NCOL,IDF%NROW,IDF%X,IDF%NODATA,IPLTCLR) CASE (IDOK) TISC(J)=0; DO IROW=1,IDF%NROW; DO ICOL=1,IDF%NCOL CALL WGRIDGETCELLREAL(IDF_GRID1,ICOL,IROW,IDF%X(ICOL,IROW)) IF(IDF%X(ICOL,IROW).NE.IDF%NODATA)THEN TISC(J)=TISC(J)+1 CALL IDFGETLOC(IDF,IROW,ICOL,DATISC2(J,TISC(J))%DISTANCE,DATISC2(J,TISC(J))%BOTTOM) DATISC2(J,TISC(J))%MRC=IDF%X(ICOL,IROW) ENDIF ENDDO; ENDDO ISGATTRIBUTES_2DCROSS_TABLE=.TRUE.; EXIT CASE (IDCANCEL) EXIT CASE (IDHELP) CALL IMODGETHELP('4.1.4.3','MMO.IDO.IE.Calc') END SELECT END SELECT ENDDO CALL WDIALOGUNLOAD(); CALL WDIALOGSELECT(ID_DISGATTRIBUTESTAB2); CALL IDFDEALLOCATEX(IDF); CALL IDFDEALLOCATEX(PIDF) END FUNCTION ISGATTRIBUTES_2DCROSS_TABLE !###====================================================================== SUBROUTINE ISGATTRIBUTES_2DCROSS_TABLEVALUES(NC,NR,X,NODATA,IPLTCLR) !###====================================================================== IMPLICIT NONE REAL,INTENT(IN) :: NODATA INTEGER,INTENT(IN) :: NR,NC,IPLTCLR REAL,INTENT(IN),DIMENSION(NC,NR) :: X INTEGER,ALLOCATABLE,DIMENSION(:) :: IC,WC INTEGER :: ICOL,IROW,ICLR,I CALL WDIALOGSELECT(ID_DIDFEDITTABLE); CALL WDIALOGGETINTEGER(IDF_INTEGER1,I); CALL WGRIDROWS(IDF_GRID1,NR) ALLOCATE(IC(NC),WC(NC)); IC=1; WC=I; CALL WGRIDCOLUMNS(IDF_GRID1,NC,IC); DEALLOCATE(IC,WC) DO ICOL=1,NC; CALL WGRIDLABELCOLUMN(IDF_GRID1,ICOL,TRIM(ITOS(ICOL))); ENDDO DO IROW=1,NR; CALL WGRIDLABELROW (IDF_GRID1,IROW,TRIM(ITOS(IROW))); ENDDO CALL WDIALOGSELECT(ID_DIDFEDITTABLE) DO IROW=1,NR; DO ICOL=1,NC IF(X(ICOL,IROW).NE.NODATA)THEN CALL WGRIDPUTCELLREAL(IDF_GRID1,ICOL,IROW,X(ICOL,IROW)) IF(IPLTCLR.EQ.1)THEN ICLR=UTL_IDFGETCLASS(MP(ICROSS_ZVAL)%LEG,X(ICOL,IROW)) CALL WGRIDCOLOURCELL(IDF_GRID1,ICOL,IROW,-1,ICLR) ENDIF ENDIF ENDDO; ENDDO END SUBROUTINE ISGATTRIBUTES_2DCROSS_TABLEVALUES END MODULE MOD_ISG