!IPK LAST UPDATE SEP 23 2015 ADD TESTING FOR status SUBROUTINE gim_an_event(ix,iy,iflag) USE WINTERACTER include 'd.inc' COMMON /TMPLIST/ ilisttmp(100),INREORD ! THIS BLOCK IS IN BLK1.F90 COMMON /VIEWS/ HANG,VANG,VRTSCAL,HANGOLD,VANGOLD,VRTORIG,IASPCT INTEGER :: NP,NE,NHTP,NMESS,NBRR,IPSW,IRMAIN,ISCRN,icolon,nhtpsv,nmessv,nbrrsv,ntempin,IPW2 !ipk jan01 Expand IPSW to 10 CHARACTER*6 DESCR COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout COMMON /HEDS1/ NWINDWS,IWNDWS(10),ISCRNS(10),DESCR(10),ICRSR(10) REAL HSIZE COMMON /SSIZE/ HSIZE REAL :: RSCLX,RSCLY,HRAD,VRAD real*8 xms,yms INTEGER :: MOUSEX, MOUSEY, MBUTTON, ITIME, IWINDOW,MENUS INTEGER :: IMP,IIN,IOT,IOT1,impf,IBAKON,N,NDM,IDRAG,IYES,ITRIAN,INFO(3) LOGICAL :: OPENED,EXISTS CHARACTER(LEN=255) :: FNAME,FNAMGE,FNAMRM,FNAMEB CHARACTER(LEN=3) :: SUB,SUB1 CHARACTER(LEN=4) :: SUB2 character(len=43) :: zoomh CHARACTER(LEN=50) :: STBAR character(len=1000) :: header CHARACTER(len=10) :: DATEC,TIMEC,ZONEC INTEGER :: DTI(8) CHARACTER(LEN=256) :: FILTER CHARACTER(LEN=72) :: CRSTIT REAL :: XX1,XX2,XX3,XX4,XX5,XX6 COMMON /UNITS/IOT,IOT1 INCLUDE 'TXFRM.COM' !IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL ! ! Declare window-type and message variables ! TYPE(WIN_STYLE) :: WINDOW TYPE(WIN_MESSAGE) :: MESSAGE TYPE (WIN_FONT) :: FONT ! Define a common block with background file names INCLUDE 'BFILES.I90' DATA IBAKON/1/ DATA rsclx,rscly/100.0,100./,IDOWN/0/ ! ! Interacter graphics input routine ! Shows the mouse, collects mouse location and character ! on the mouse-click or on a keystroke character*1 iflag CALL WMenuSetState(ID_ITEM11,ItemEnabled,0) CALL WMenuSetState(ID_ITEM12,ItemEnabled,0) nhtpsv=nhtp nmessv=nmess nbrrsv=nbrr 100 continue DO I=1,255 FNAME(I:I)=' ' ENDDO MENUS=0 idrag=0 101 continue CALL WMessage(ITYPE, MESSAGE) SELECT CASE (ITYPE) CASE (KeyDown) ! Key pressed KEY = MESSAGE%VALUE1 MOUSEX = MESSAGE%X MOUSEY = MESSAGE%Y XM=MESSAGE%GX YM=MESSAGE%GY IFLAG=CHAR(KEY) ! WRITE(90,*) 'KEY PRESSED',KEY ! WRITE(90,'(A)') 'KEY PRESSED',IFLAG,menus CASE (MenuSelect) ! Menu item selected INREORD=0 DO J=1,100 ilisttmp (j)=0 ENDDO SELECT CASE (MESSAGE%VALUE1) CASE (ID_ITEM11) ! New option IMP=0 IIN=0 CASE (ID_ITEM12) ! Open option IMP=0 IIN=0 CALL IgrUnits(0.,0.,HSIZE,8.0) CALL WSelectFile(ID_STRING1,PromptOn+DirChange,FNAME,'Load Map File') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN CALL IlowerCase(FNAME) CALL GETSUB(FNAME,SUB) IF(SUB .EQ. 'map') then IMP=9 OPEN(9,FILE=FNAME,STATUS='OLD') ELSEIF(SUB .EQ. 'asc' .or. SUB .EQ. 'grd') then IMP=94 OPEN(94,FILE=FNAME,STATUS='OLD') ELSEIF(SUB .EQ. 'mpb') then imp=92 OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='unformatted',action='read') ELSEIF(SUB .EQ. 'mbb') then imp=92 OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='binary',action='read') ENDIF ENDIF FILTER ="Network Files|*.rm1;*.geo;*.gfg;*.bin;*.ele|Rm1 file -- *.rm1|*.rm1|Geo file -- *.geo|*.geo|GFGEN file -- *.gfg|*.gfg|GFGEN bin file -- *.bin|*.bin|Rst file -- *.rst|*.rst|TRIANG file -- *.ele|*.ele|MESH2D file -- *.2dm|*.2dm|All files|*.*|" CALL WSelectFile(FILTER,PromptOn+DirChange,FNAME,'Load Network File') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN CALL IlowerCase(FNAME) CALL GETSUB(FNAME,SUB) CALL SHORTNAME(FNAME,FNAMEDISP) ITRIAN=0 IF(SUB .EQ. 'rm1') then IIN = 10 OPEN(10,FILE=FNAME,STATUS='OLD') ELSEIF(SUB .EQ. 'ele') then IIN=10 OPEN(IIN ,FILE=FNAME,STATUS='OLD',ACTION='READ') ITRIAN=1 IGFG=0 FNAMKEP=FNAME ELSEIF(SUB .EQ. 'rst') then IIN=11 ! OPEN(IIN ,FILE=FNAME,STATUS='OLD',access='transparent') OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED') ! OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='BINARY') ELSE IIN=12 OPEN(IIN ,FILE=FNAME,STATUS='OLD',form='binary') ENDIF ENDIF CASE (ID_NMAP) CALL WSelectFile(ID_STRING1,PromptOn,FNAME,'Load Map File') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN CALL IlowerCase(FNAME) CALL GETSUB(FNAME,SUB) IF(SUB .EQ. 'map') then IMP=9 OPEN(9,FILE=FNAME,STATUS='OLD') ELSEIF(SUB .EQ. 'shp') then IMP=113 OPEN(113,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read') SUB='DBF' CALL ADDSUB(FNAME,SUB) OPEN(114,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read') ELSEIF(SUB .EQ. 'asc' .or. SUB .EQ. 'grd') then IMP=94 OPEN(94,FILE=FNAME,STATUS='OLD') ELSEIF(SUB .EQ. 'mpb') then imp=92 OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='unformatted',action='read') ELSEIF(SUB .EQ. 'mbb') then imp=92 OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='binary',action='read') ENDIF ENDIF CALL RDMAP(2,IMP,0,0) CALL PLOTOT(0) nhtp=nhtpsv nmess=nmessv nbrr=nbrrsv call hedr GO TO 100 !IPK MAY03 LOAD ADDITIONAL FILES CASE (ID_LOADRM1) ! Load additional RM1 files FILTER ="Network Files|*.rm1;*.geo;*.gfg;*.bin;*.ele|Rm1 file -- *.rm1|*.rm1|Geo file -- *.geo|*.geo|Gfgen file -- *.gfg|*.gfg|GFGEN bin file -- *.bin|*.bin|Rst file -- *.rst|*.rst|TRIANG file -- *.ele|*.ele|All files|*.*|" CALL WSelectFile(FILTER,PromptOn+DirChange,FNAME,'Load Network File') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN GO TO 200 ELSE GO TO 250 ENDIF 200 CONTINUE CALL IlowerCase(FNAME) CALL GETSUB(FNAME,SUB) CALL SHORTNAME(FNAME,FNAMEDISP) ITRIAN=0 IF(SUB .EQ. 'geo') then IIN=12 OPEN(IIN ,FILE=FNAME,STATUS='OLD',form='binary',ACTION='READ') FNAMKEP=FNAME IGFG=0 ELSEIF(SUB .EQ. 'gfg') then IIN = 10 IGFG=1 OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ') ELSEIF(SUB .EQ. '2dm') then IIN = 10 IGFG=3 OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ') ELSEIF(SUB .EQ. 'bin') then IIN=12 OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED') IGFG=2 ELSEIF(SUB .EQ. 'rst') then IIN=11 OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED') IGFG=0 ELSEIF(SUB .EQ. 'ele') then IIN=10 OPEN(IIN ,FILE=FNAME,STATUS='OLD',ACTION='READ') ITRIAN=1 IGFG=0 FNAMKEP=FNAME ELSE IIN = 10 IGFG=0 OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ') ENDIF ITOTFIL=ITOTFIL+1 FNAMEOUT(ITOTFIL)=FNAME CALL GETNEWFIL(IIN,IGFG,ITRIAN,0) fname=' ' GO TO 100 CASE (ID_CRSF) ! Load cross-section files ICRIN=0 FILTER ="Cross-Section files -- *.crs|*.crs|All files -- |*.*|" CALL WSelectFile(FILTER,PromptOn+DirChange,FNAME,'Load Cross-Section File') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN GO TO 210 ELSE GO TO 250 ENDIF 210 CONTINUE CALL IlowerCase(FNAME) CALL GETSUB(FNAME,SUB) ICRIN = 23 OPEN(ICRIN,FILE=FNAME,STATUS='OLD',ACTION='READ') CALL GETCRS(CRSTIT) fname=' ' GO TO 100 ! Load group number files IGRPIN=0 FILTER ="Group number files -- *.txt|*.txt|All files -- |*.*|" CALL WSelectFile(FILTER,PromptOn+DirChange,FNAME,'Load Group Number File') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN GO TO 215 ELSE GO TO 250 ENDIF 215 CONTINUE CALL IlowerCase(FNAME) CALL GETSUB(FNAME,SUB) IGRP = 28 OPEN(IGRP,FILE=FNAME,STATUS='OLD',ACTION='READ') CALL GETGRP fname=' ' GO TO 100 CASE (ID_SAVCRS) ICROUT=24 INQUIRE(24, OPENED=OPENED) if(.not. opened) then Filter='CRS file -- *.crs|*.crs|' CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Cross Section File') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN CALL IlowerCase(FNAME) CALL GETSUB(FNAME,SUB) OPEN(ICROUT,FILE=FNAME,STATUS='UNKNOWN',ACTION='WRITE') ELSE GO TO 250 ENDIF ENDIF REWIND ICROUT CALL WRTCRS(ICROUT,CRSTIT) fname=' ' GO TO 100 CASE (ID_SAVGP) IGRPOUT=29 INQUIRE(29, OPENED=OPENED) if(.not. opened) then Filter='TXT file -- *.txt|*.txt|' CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Group Number File') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN CALL IlowerCase(FNAME) CALL GETSUB(FNAME,SUB) OPEN(IGRPOUT,FILE=FNAME,STATUS='UNKNOWN',ACTION='WRITE') ELSE GO TO 250 ENDIF ENDIF REWIND IGRP CALL WRTGP fname=' ' GO TO 100 CASE (ID_ITEM13) ! Save option ! WRITE(90,*) 'WINTER AT ITEM13' INQUIRE(20, OPENED=OPENED) if(.not. opened) then Filter='Network Files|*.rm1;*.gfg;*.ele;*.2dm|Rm1 file -- *.rm1|*.rm1|gfg file -- *.gfg|*.gfg|TRIANG file -- *.ele|*.ele|2dm file -- *.2dm|*.2dm|' CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Network File') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN CALL IlowerCase(FNAME) CALL GETSUB(FNAME,SUB) CALL SHORTNAME(FNAME,FNAMEDISP) ! SUB='rm1' ! CALL ADDSUB(FNAME,SUB) ! WRITE(90,*) 'IN ITEM13',IOT ! WRITE(90,'(A)') FNAME,SUB IOT = 20 FNAMRM=FNAME ITRIANOUT=0 if(sub .eq. 'rm1') then igfgsw=0 OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN') ! ! Check if file cords format to be short or long ! ! CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to save'//& CHAR(13)//'coordinates in long format?' ,& 'Coordinate save format') ! ! If answer 'No', use short format ! IF (WInfoDialog(4) .EQ. 2) then ntempin=0 else ntempin=2 END IF ! call wrtout(1) CLOSE (IOT) OPEN(IOT,FILE=FNAMRM,STATUS='UNKNOWN') elseif(sub .eq. 'ele') then igfgsw=0 OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN') itrianout=1 call wrtout(1) DO L=255,1,-1 IF(FNAME(L:L) .EQ. '.') THEN FNAME(L+1:L+1)='n' FNAME(L+2:L+2)='o' FNAME(L+3:L+3)='d' FNAME(L+4:L+4)='e' OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN') itrianout=2 call wrtout(1) GO TO 220 ENDIF ENDDO 220 continue CLOSE (IOT) OPEN(IOT,FILE=FNAMRM,STATUS='UNKNOWN') elseif(sub .eq. '2dm') then igfgsw=0 OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN') itrianout=0 call wrtout(3) CLOSE (IOT) OPEN(IOT,FILE=FNAMRM,STATUS='UNKNOWN') else igfgsw=1 OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN') call wrtout(1) CLOSE (IOT) OPEN(IOT,FILE=FNAMRM,STATUS='UNKNOWN') endif ENDIF if(iactvfil .le. 0) iactvfil=1 FNAMEOUT(IACTVFIL)=FNAMRM else CALL GETSUB(FNAMRM,SUB) if(sub .eq. 'ele') then FNAME=FNAMRM igfgsw=0 itrianout=1 call wrtout(1) DO L=255,1,-1 IF(FNAME(L:L) .EQ. '.') THEN FNAME(L+1:L+1)='n' FNAME(L+2:L+2)='o' FNAME(L+3:L+3)='d' FNAME(L+4:L+4)='e' OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN') itrianout=2 call wrtout(1) GO TO 221 ENDIF ENDDO 221 continue ELSE call wrtout(1) ENDIF CLOSE (IOT) fnamrm=FNAMEOUT(IACTVFIL) OPEN(IOT,FILE=FNAMRM,STATUS='UNKNOWN') endif GO TO 100 CASE (ID_ITEM14) ! Save option for binary ! WRITE(90,*) 'WINTER AT ITEM14' INQUIRE(22, OPENED=OPENED) ! WRITE(90,'(L2)') OPENED if(.not. opened) then Filter='Geo file -- *.geo|*.geo|GFGEN file -- *.bin|*.bin|' CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Network File') ! WRITE(90,'(A)') FNAME IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN CALL IlowerCase(FNAME) CALL GETSUB(FNAME,SUB) CALL SHORTNAME(FNAME,FNAMEDISP) ! SUB='geo' ! CALL ADDSUB(FNAME,SUB) ! WRITE(90,*) 'IN ITEM14',IOT1 ! WRITE(90,'(A)') FNAME,SUB IOT1=22 FNAMGE=FNAME if(sub .eq. 'geo') then OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='binary') igfgswb=0 ! add header to binary file DO J=11,1000 HEADER(J:J)=' ' ENDDO HEADER(1:10)='RMAGEN ' CALL DATE_AND_TIME(DATEC,TIMEC,ZONEC,DTI) HEADER(11:20)=DATEC HEADER(21:30)=TIMEC HEADER(31:40)=ZONEC WRITE(IOT1) HEADER call wrtout(2) CLOSE (IOT1) OPEN(IOT1 ,FILE=FNAMGE,STATUS='UNKNOWN',form='binary') else OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='unformatted') igfgswb=1 call wrtout(2) CLOSE (IOT1) OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='unformatted') endif ENDIF else ! add header to binary file DO J=11,1000 HEADER(J:J)=' ' ENDDO HEADER(1:10)='RMAGEN ' CALL DATE_AND_TIME(DATEC,TIMEC,ZONEC,DTI) HEADER(11:20)=DATEC HEADER(21:30)=TIMEC HEADER(31:40)=ZONEC WRITE(IOT1) HEADER call wrtout(2) CLOSE (IOT1) OPEN(IOT1 ,FILE=FNAMGE,STATUS='UNKNOWN',form='binary') endif FNAMEOUT(IACTVFIL)=FNAMRM GO TO 100 CASE (ID_ITEM18) ! Save As option FILTER ="Bin Map file -- *.mpb|*.mpb|Bin Map file (no head) -- *.mbb|*.mbb|" CALL WSelectFile(filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Map File') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN CALL IlowerCase(FNAME) CALL GETSUB(FNAME,SUB) if(SUB .eq. 'mpb') then CALL ADDSUB(FNAME,SUB) impf=93 OPEN(IMPF ,FILE=fname,STATUS='unknown',form='unformatted') call wrtmap(1) elseif(Sub .eq. 'map') then impf=94 OPEN(IMPF ,FILE=fname,STATUS='unknown',form='formatted') call wrtmap(2) endif ENDIF go to 100 CASE (ID_LAYFL) ! input layer data CALL WSelectFile(ID_STRING9,PromptOn+DirChange,FNAME,'Load Layer File') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN SUB='lay' CALL ADDSUB(FNAME,SUB) impf=103 OPEN(103,FILE=FNAME,STATUS='OLD') call rdlayer ENDIF go to 100 CASE (ID_OUTLAY) ! Save layer data call wrtlayer GO TO 100 CASE (ID_ITEM15) ! Save As option Filter='Network Files|*.rm1;*.gfg;*.ele;*.2dm|Rm1 file -- *.rm1|*.rm1|GFGEN file -- *.gfg|*.gfg|TRIANG file -- *.ele|*.ele|2dm file -- *.2dm|*.2dm|' CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Network File') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN CALL IlowerCase(FNAME) CALL GETSUB(FNAME,SUB) CALL SHORTNAME(FNAME,FNAMEDISP) ! SUB='rm1' ! CALL ADDSUB(FNAME,SUB) FNAMRM=FNAME IOT = 20 if(sub .eq. 'rm1') then igfgsw=0 itrianout=0 OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN') ! ! Check if file cords format to be short or long ! CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to save'//& CHAR(13)//'coordinates in long format?' ,& 'Coordinate save format') ! If answer 'No', use short format IF (WInfoDialog(4).EQ.2) then ntempin=0 else ntempin=2 END IF ! call wrtout(1) CLOSE (IOT) OPEN(IOT,FILE=FNAMRM,STATUS='UNKNOWN') elseif(sub .eq. 'ele') then igfgsw=0 OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN') itrianout=1 call wrtout(1) DO L=255,1,-1 IF(FNAME(L:L) .EQ. '.') THEN FNAME(L+1:L+1)='n' FNAME(L+2:L+2)='o' FNAME(L+3:L+3)='d' FNAME(L+4:L+4)='e' OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN') itrianout=2 call wrtout(1) GO TO 225 ENDIF ENDDO 225 continue CLOSE (IOT) OPEN(IOT,FILE=FNAMRM,STATUS='UNKNOWN') elseif(sub .eq. '2dm') then igfgsw=0 OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN') itrianout=0 call wrtout(3) CLOSE (IOT) OPEN(IOT,FILE=FNAMRM,STATUS='UNKNOWN') elseif(sub .eq. 'gfg') then igfgsw=1 OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN') call wrtout(1) CLOSE (IOT) OPEN(IOT,FILE=FNAMRM,STATUS='UNKNOWN') endif IF(IACTVFIL .LE. 0) IACTVFIL=1 FNAMEOUT(IACTVFIL)=FNAMRM ENDIF go to 100 CASE (ID_ITEM16) ! Save As option Filter='Geo file -- *.geo|*.geo|GFGEN file -- *.bin|*.bin|' CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Network File') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN CALL IlowerCase(FNAME) CALL GETSUB(FNAME,SUB) CALL SHORTNAME(FNAME,FNAMEDISP) ! SUB='geo' ! CALL ADDSUB(FNAME,SUB) FNAMGE=FNAME IOT1 = 22 if(SUB .EQ. 'geo') then OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='binary') igfgswb=0 ! add header to binary file DO J=11,1000 HEADER(J:J)=' ' ENDDO HEADER(1:10)='RMAGEN ' CALL DATE_AND_TIME(DATEC,TIMEC,ZONEC,DTI) HEADER(11:20)=DATEC HEADER(21:30)=TIMEC HEADER(31:40)=ZONEC WRITE(IOT1) HEADER call wrtout(2) CLOSE (IOT1) OPEN(IOT1 ,FILE=FNAMGE,STATUS='UNKNOWN',form='binary') else OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='unformatted') igfgswb=1 call wrtout(2) CLOSE (IOT1) OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='unformatted') endif FNAMEOUT(IACTVFIL)=FNAMRM ENDIF go to 100 CASE (ID_SBIN) ! Save As special binary format CALL GETHDRTYP(IHDSWT) Filter='Geo file -- *.geo|*.geo|' CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Network File') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN CALL IlowerCase(FNAME) CALL GETSUB(FNAME,SUB) CALL SHORTNAME(FNAME,FNAMEDISP) ! SUB='geo' ! CALL ADDSUB(FNAME,SUB) FNAMGE=FNAME IOT1 = 22 if(SUB .EQ. 'geo') then if(ihdswt .eq. 1) then OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='UNFORMATTED', CONVERT='LITTLE_ENDIAN') else OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='UNFORMATTED', CONVERT='BIG_ENDIAN') endif igfgswb=0 ! add header to binary file DO J=11,1000 HEADER(J:J)=' ' ENDDO HEADER(1:10)='RMAGEN ' CALL DATE_AND_TIME(DATEC,TIMEC,ZONEC,DTI) HEADER(11:20)=DATEC HEADER(21:30)=TIMEC HEADER(31:40)=ZONEC WRITE(IOT1) HEADER call wrtout(2) CLOSE (IOT1) if(ihdswt .eq. 1) then OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='UNFORMATTED', CONVERT='LITTLE_ENDIAN') else OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='UNFORMATTED', CONVERT='BIG_ENDIAN') endif endif ENDIF go to 100 CASE (ID_BKF) ! Read background option fname=' ' !!! CALL WSelectFile(FILTER,PromptOn+DirChange,FNAME,'Load Background file') FILTER ="Background Files|*.wmf;*.bmp;*.pcx;*.png;*.cgm;*.pic;*.jpg|wmf file -- *.wmf|*.wmf|bmp file -- *.bmp|*.bmp|pcx file -- *.pcx|*.pcx|png file -- *.png|*.png|jpeg file -- *.jpg|*.jpg|cgm file -- *.cgm|*.cgm|pic file -- *.pic|*.pic|" CALL WSelectFile(FILTER,PromptOn+DirChange+Appendext,FNAME,'Load Background file') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN CALL IlowerCase(FNAME) CALL GETSUB(FNAME,SUB) NBKFL=NBKFL+1 BFNAME(NBKFL)=FNAME IF(SUB .EQ. 'bmp') then ISWBKFL(NBKFL) = 2 ELSEIF(SUB .EQ. 'pcx') then ISWBKFL(NBKFL) = 2 ELSEIF(SUB .EQ. 'png' .or. sub .eq. 'jpg') then ISWBKFL(NBKFL) = 2 ELSE ISWBKFL(NBKFL)=1 ENDIF write(90,*) 'nbkfl in winnew',nbkfl write(90,*) ' iswbkfl',iswbkfl(nbkfl) SUB1=SUB SUB='ORG' CALL ADDSUB(FNAME,SUB) BFNAMR(NBKFL)=FNAME INQUIRE (FILE = fname, EXIST = exists) IF (.NOT. exists) THEN IF(SUB1 .EQ. 'PNG' .or. SUB1 .EQ. 'png') SUB2='PNGW' IF(SUB1 .EQ. 'JPG' .or. SUB1 .EQ. 'jpg') SUB2='JPGW' CALL ADDSUB(FNAME,SUB2) BFNAMR(NBKFL)=FNAME INQUIRE (FILE = fname, EXIST = exists) IF (.NOT. exists) THEN IF(SUB2 .EQ. 'JPGW') THEN SUB1='JGW' CALL ADDSUB(FNAME,SUB1) BFNAMR(NBKFL)=FNAME ENDIF ENDIF INQUIRE (FILE = fname, EXIST = exists) IF (.NOT. exists) THEN CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Location file does not exist!!'//CHAR(13)// & 'Do you wish to create file and view image','Looking for location file') ! If answer 'Yes' set ifrmel to 0 ! IF (WInfoDialog(4) .ne. 2) then OPEN(104,FILE=FNAME,STATUS ='NEW', FORM ='FORMATTED') BFNAMR(NBKFL)=FNAME BFMINMAX(NBKFL,1) = - XS BFMINMAX(NBKFL,2) = - YS BFMINMAX(NBKFL,3) = HSIZE*TXSCAL - XS BFMINMAX(NBKFL,4) = 7.50*TXSCAL - YS WRITE(104,'(4G16.8)') (BFMINMAX(NBKFL,I),I=1,4) CLOSE(104) GO TO 100 ELSE NBKFL=NBKFL-1 GO TO 100 ENDIF ENDIF OPEN(104,FILE=FNAME,STATUS ='OLD', FORM ='FORMATTED') READ(104,'(G16.8)') XX1 READ(104,'(G16.8)') XX2 READ(104,'(G16.8)') XX3 READ(104,'(G16.8)') XX4 READ(104,'(G16.8)') XX5 READ(104,'(G16.8)') XX6 call IGrFileInfo(BFNAME(NBKFL),INFO,3) BFMINMAX(NBKFL,1) = XX5 BFMINMAX(NBKFL,2) = XX6+INFO(3)*XX4 BFMINMAX(NBKFL,3) = XX5+INFO(2)*XX1 BFMINMAX(NBKFL,4) = XX6 CLOSE(104) GO TO 100 ! yes ENDIF OPEN(104,FILE=FNAME,STATUS ='OLD', FORM ='FORMATTED') READ(104,'(4G16.8)') (BFMINMAX(NBKFL,J),J=1,4) CLOSE(104) ENDIF ! ipk jan10 go to 100 CASE (ID_ICOPY) CALL WSelectFile(ID_STRING6,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Copy File Name') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN CALL IlowerCase(FNAME) CALL GETSUB(FNAME,SUB) FNAMEB=FNAME SUB1='ORG' CALL ADDSUB(FNAMEB,SUB1) CALL OUTORG(FNAMEB) if(sub .eq. 'jpg' .or. sub .eq. 'png' .or. sub .eq. 'pcx' .or. sub .eq. 'bmp') then ! call doplot(0) CALL WGrSaveImageOptions(31,100) CALL WGrSaveImageOptions(32,150) call igrsaveimage(fname) call doplot(0) call IGrFileInfo(FNAME,INFO,3) IF(SUB .EQ. 'jpg') THEN SUB2='jpgw' CALL ADDSUB(FNAMEB,SUB2) CALL OUTJPGW(FNAMEB,INFO) ENDIF CALL HEDR go to 100 endif CALL IGrInit('HP') ! hardcopy only output !ipk may10 IYPIX=HSIZE/7.5*540 IXPIX=540 IF(SUB .EQ. 'wmf') then CALL IGrHardCopySelect(1,11) CALL IGrHardCopyOptions(27,1) !ipk may10 CALL IGrHardCopyOptions(1,IYPIX) ELSEIF(SUB .EQ. 'emf') then CALL IGrHardCopySelect(1,11) CALL IGrHardCopyOptions(27,2) !ipk may10 CALL IGrHardCopyOptions(1,IYPIX) ELSEIF(SUB .EQ. 'dxf') then CALL IGrHardCopySelect(1,8) ELSEIF(SUB .EQ. 'pcx') then CALL IGrHardCopySelect(1,6) CALL IGrHardCopyOptions(26,0) !ipk may10 CALL IGrHardCopyOptions(1,IYPIX) CALL IGrHardCopyOptions(2,540) ELSEIF(SUB .EQ. 'bmp') then CALL IGrHardCopySelect(1,6) CALL IGrHardCopyOptions(26,1) !ipk may10 IYPIX=IYPIX*1.5 IXPIX=810 CALL IGrHardCopyOptions(1,IYPIX) !IPK MAY10 CALL IGrHardCopyOptions(2,540) CALL IGrHardCopyOptions(2,IXPIX) ELSEIF(SUB .EQ. 'png') then CALL IGrHardCopySelect(1,6) CALL IGrHardCopyOptions(26,3) CALL IGrHardCopyOptions(23,24) !ipk may10 CALL IGrHardCopyOptions(1,IYPIX) CALL IGrHardCopyOptions(2,540) ELSEIF(SUB .EQ. 'jpg') then CALL IGrHardCopySelect(1,6) CALL IGrHardCopyOptions(23,24) CALL IGrHardCopyOptions(26,4) !ipk may10 CALL IGrHardCopyOptions(1,IYPIX) CALL IGrHardCopyOptions(2,540) ELSEIF(SUB .EQ. 'cgm') then CALL IGrHardCopySelect(1,9) !ipk may10 CALL IGrHardCopyOptions(1,IYPIX) ELSEIF(SUB .EQ. 'pic') then CALL IGrHardCopySelect(1,7) !ipk may10 CALL IGrHardCopyOptions(1,IYPIX) CALL IGrHardCopyOptions(2,540) ENDIF CALL IGrHardcopy(fname) ! Start print manager CALL IGrFillPattern(Solid) CALL IgrUnits(0.,0.,HSIZE,7.5) if(menus .eq. 12 .or. menus .eq. 13) then call conout(menus) else CALL CLSCRN CALL PLOTOT(-1) ! plot graph endif call rblack call frame(0.,0.,HSIZE,7.5) CALL IGrHardcopy('S') ! Send data to the printer CALL IGrInit('P') ! Turn graphics back on CALL IGrFillPattern(Solid) CALL IgrUnits(0.,0.,HSIZE,8.0) if(menus .eq. 12 .or. menus .eq. 13) then call conout(menus) else CALL CLSCRN CALL PLOTOT(0) ! plot graph endif CALL HEDR call rblack CALL IGrHardCopySelect(1,10) GO TO 100 ENDIF ! ipk jan10 go to 100 CASE (ID_CLIP) call igrsaveimage( ) call doplot(0) CALL HEDR go to 100 ! Clipboard save !ipk may10 ! IYPIX=HSIZE/7.5*540 ! IXPIX=540 ! CALL IGrHardCopySelect(1,11) ! CALL IGrHardCopyOptions(27,2) !ipk may10 ! CALL IGrHardCopyOptions(1,IYPIX) ! CALL IGrHardcopy() ! Start print manager ! CALL IGrFillPattern(Solid) ! CALL IgrUnits(0.,0.,HSIZE,7.5) ! if(menus .eq. 12 .or. menus .eq. 13) then ! call conout(menus) ! else ! CALL CLSCRN ! CALL PLOTOT(-1) ! plot graph ! endif ! call rblack ! CALL IGrHardcopy('S') ! Send data to the printer ! CALL IGrInit('P') ! Turn graphics back on ! CALL IGrFillPattern(Solid) ! ! CALL IgrUnits(0.,0.,HSIZE,8.0) ! if(menus .eq. 12 .or. menus .eq. 13) then ! call conout(menus) ! else ! CALL CLSCRN ! CALL PLOTOT(0) ! plot graph ! endif ! CALL HEDR ! call rblack ! CALL IGrHardCopySelect(1,10) ! GO TO 100 CASE (ID_SAVSHP) ! Copy to shape file selected is selected call saveshp go to 100 CASE (ID_ITEM24) ! Print option is selected CALL WHardcopyOptions(3) ! ! If the user clicked OK on page setup dialog then output the contents ! to the selected printer ! IF (WinfoDialog(ExitButtonCommon).EQ.CommonOK) THEN CALL IGrInit('HP') ! hardcopy only output CALL IGrFillPattern(Solid) CALL IgrUnits(0.,0.,HSIZE,7.5) CALL IGrHardcopy(' ') ! Start print manager if(menus .eq. 12 .or. menus .eq. 13) then call conout(menus) else CALL CLSCRN CALL PLOTOT(-1) ! plot graph endif call rblack CALL IGrFillPattern(0,0,0) CALL IGrRectangle(0.,0.,HSIZE,7.5) CALL IGrHardcopy('S') ! Send data to the printer CALL IGrInit('P') ! Turn graphics back on CALL IGrFillPattern(Solid) CALL IgrUnits(0.,0.,HSIZE,8.0) if(menus .eq. 12 .or. menus .eq. 13) then call conout(menus) else CALL CLSCRN CALL PLOTOT(0) ! plot graph endif CALL HEDR call rblack CALL IGrFillPattern(0,0,0) CALL IGrRectangle(0.,0.,HSIZE,7.5) GO TO 100 END IF ! ipk jan10 go to 100 CASE (ID_ITEM19) ! Demo option SUB='DEM' CALL RBLUE CALL SYMBL(1.,5.,0.25,SUB,0.0,3) CALL DEMOS ! ipk jan10 go to 100 CASE (ID_MMAP) call mmap go to 100 !IPK MAY03 CASE (ID_SELRM1) ! Select different mesh file IOLDACT=IACTVFIL CALL PANELFIL IF (IOLDACT .NE. IACTVFIL) THEN ! Resave current file IFILOUT=IOLDACT+50 CALL WRTFIL(IFILOUT) CALL LOADFIL ENDIF GO TO 100 !IPK MAY03 CASE (ID_ADDMESH) ! Select file FOR MESH ADDITION IOLDACT=IACTVFIL CALL PANELFIL IF( IOLDACT .EQ. IACTVFIL) THEN CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Same file selected for addition'//& CHAR(13)//'Process ended','SAME FILE') GO TO 100 ENDIF IFILADD=IACTVFIL IACTVFIL=IOLDACT CALL ADDTOMESH(IFILADD,0) GO TO 100 !IPK MAY03 CASE (ID_MRGMESH) ! Select file FOR MESH MERGING IOLDACT=IACTVFIL CALL PANELFIL IF( IOLDACT .EQ. IACTVFIL) THEN CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Same file selected for merging'//& CHAR(13)//'Process ended','SAME FILE') GO TO 100 ENDIF IFILADD=IACTVFIL IACTVFIL=IOLDACT CALL ADDTOMESH(IFILADD,1) GO TO 100 !ipk sep16 ADD MESH FROM POINTS CASE (ID_ADDMESHTR) CALL ADDMESHT GO TO 100 !ipk sep16 ADD MESH FROM POINTS CASE (ID_ADDBEDLEV) CALL ADDBEDLV GO TO 100 !ipk may03 CASE (ID_TRIANG) ! add a triangle of elements CALL ADDTRIANG GO TO 100 CASE (ID_ADDMAP) ! add a triangle of elements CALL ADDMAP GO TO 100 CASE (ID_3DVIEW) CALL SETANGLE I3DVIEW=1 if(menus .eq. 12 .or. menus .eq. 13) then CALL CLSCRN call conout(menus) else call plotot(0) endif call hedr GO TO 100 CASE (ID_VIEWANGLE) I3DVIEW=1 CALL SETANGLE CALL PLOTOT(0) call hedr GO TO 100 !ipk may03 CASE (ID_QUAD) ! add a quad of elements CALL ADDQUAD GO TO 100 !ipk may03 CASE (ID_SETUPLEV) ! setup levees CALL RESETWHGT GO TO 100 CASE (ID_SETTYPLEV) ! setup levees CALL LEVSETTYP GO TO 100 CASE (ID_G1D) CALL FORM1DEL GO TO 100 !ipk apr04 CASE (ID_CREATM) ! create mesh from contours CALL CREATM GO TO 100 CASE (ID_OUTLINFL) ! read outline file CALL RDOUTLIN GO TO 100 CASE (ID_TESTOUT) ! read outline file CALL CHECKPOLY GO TO 100 CASE (ID_CGEN) ! generate contours CALL CGEN GO TO 100 CASE (ID_SPLITN) CALL SPLITN GO TO 100 CASE (ID_FORM999) CALL FORM999(0,0,1) GO TO 100 CASE (ID_FORM2D) CALL FORM999(1,0,1) GO TO 100 !IPK FEB03 CASE (ID_TRIAN) CALL TRIANG GO TO 100 CASE (ID_SWMAP) CALL SWMAP GO TO 100 CASE (ID_SWRM1) CALL SWRM1 GO TO 100 CASE (ID_MAP) CALL GRELV GO TO 100 CASE (ID_SELPR) CALL GETALLANGS GO TO 100 CASE (ID_RVSDIAG) CALL RVSDIAG GO TO 100 CASE (ID_LOADELTLD) CALL GETEQ GO TO 100 CASE (ID_SHOWELTLD) CALL SHOWEQ(0) GO TO 100 CASE (ID_RESHOWELTLD) CALL SHOWEQ(1) GO TO 100 CASE (ID_ASSIGNELTLD) CALL ASSIGNEQ GO TO 100 CASE (ID_SAVELTLD) CALL SAVEEQ GO TO 100 CASE (ID_ADDSLOT) CALL ADDSLOT GO TO 100 CASE (ID_ITEM17) ! Exit option !IPK SEP02 call rquit(iyes) if(iyes .ne. 1) go to 100 MENUS=0 CALL QUIT_PGM CASE (ID_EXIT) ! Exit program (menu option) call rquit(iyes) if(iyes .ne. 1) go to 100 MENUS=0 CALL QUIT_PGM CASE (ID_NODEDATA) CALL NODEDISP(0) GO TO 101 CASE (ID_ELTDATA) CALL ELTDISP(0) GO TO 101 CASE (ID_EDLAY) CALL LAYDISP GO TO 101 CASE (ID_RESETRG) CALL RESETREG GO TO 101 CASE (ID_MOVMESH) CALL MOVMESH GO TO 101 CASE (ID_TRANSFORM) CALL TRANSMESH GO TO 101 !IPK SEP02 CASE (ID_GETELM) CALL GETELMNO GO TO 101 CASE (ID_ATTACH) CALL REATTACH GO TO 101 CASE (ID_DDRAW) IDDSW=MOD(IDDSW+1,2) IF(IDDSW .EQ. 1) CALL WMenuSetState(ID_DDRAW,ItemChecked,1) GO TO 101 CASE (ID_COMPLEX) CALL GNODE(2) GO TO 101 CASE (ID_fillagap) CALL JOINEL GO TO 101 CASE (ID_GETSTRESSFIL) CALL GETSTRESSFIL GO TO 101 CASE (ID_NODE) MENUS=2 CASE (ID_DELM) CALL DELETM(0) go to 100 CASE (ID_DELETELM) CALL DELETEM go to 100 CASE (ID_ELTS) MENUS=1 CASE (ID_FILL) CALL FILM(1) call hedr go to 100 CASE (ID_FILLTR) CALL FILLTR call hedr go to 100 CASE (ID_JOIN) CALL JOIN(1) nhtp=nhtpsv nmess=nmessv nbrr=nbrrsv call hedr go to 100 CASE (ID_JOINALL) CALL JOINALL nhtp=nhtpsv nmess=nmessv nbrr=nbrrsv call hedr go to 100 CASE (ID_CRGRID) CALL CRGRID GO TO 100 CASE (ID_CRSECT) CALL CRSECT GO TO 101 CASE (ID_CRSCAL) CALL COMPWGT GO TO 101 CASE (ID_CSLOC) CALL GETCSLOC GO TO 101 CASE (ID_ORDR) MENUS=3 CASE (ID_ORDR1) CALL ORDALL GO TO 101 CASE (ID_DCONTR) MENUS=12 CALL CONOUT(MENUS) GO TO 101 CASE (ID_CONTOPT) MENUS=13 CALL CONOUT(MENUS) GO TO 101 !ipk feb02 CASE (ID_cdata) ! ! Create data for message file and display ! CALL ELDAT go to 101 CASE (ID_CCLN) MENUS=6 CASE (ID_CHKCCLN) CALL CHKLIN GO TO 101 CASE (ID_CSEC) MENUS=7 CASE (ID_ZIN) MENUS=8 iflag='z' zoomh=' Zooming, click and drag to form rectangle' CALL CLRBOX CALL SYMBL(0.,7.70,0.20,zoomh,0.,43) go to 101 CASE (ID_OUT2) MENUS=8 iflag='y' CASE (ID_OUT4) MENUS=8 iflag='x' CASE (ID_CHCK) CALL CHKAREA GO TO 101 CASE (ID_FINDNODE) CALL FINDNOD GO TO 101 CASE (ID_FINDELEM) CALL FINDEL GO TO 101 CASE (ID_MCHCK) CALL CHKAREA GO TO 101 CASE (ID_SMOOTHMAP) !! CALL SMOOTHMP GO TO 101 CASE (ID_DRAG) MENUS=8 iflag='d' idrag=1 zoomh=' drag/pan , click right to end' CALL CLRBOX CALL SYMBL(0.,7.70,0.20,zoomh,0.,30) call WCursorShape(CurCrossHair) go to 101 CASE (ID_ROTATE) MENUS=8 iflag='d' idrag=2 zoomh=' rotate view , click right to end' CALL CLRBOX CALL SYMBL(0.,7.70,0.20,zoomh,0.,30) call WCursorShape(CurCrossHair) go to 101 CASE (ID_VROTATE) MENUS=8 iflag='d' idrag=2 zoomh=' rotate view , click right to end' CALL CLRBOX CALL SYMBL(0.,7.70,0.20,zoomh,0.,30) call WCursorShape(CurCrossHair) go to 101 CASE (ID_RSET) MENUS=8 iflag='w' CASE (ID_PLEFT) MENUS=8 iflag='v' CASE (ID_PRIGHT) MENUS=8 iflag='u' CASE (ID_PUP) MENUS=8 iflag='t' CASE (ID_PDOWN) MENUS=8 iflag='s' CASE (ID_IDRWT) DO call wdialogload(IDD_DIALOG06) call wdialogputcheckbox(IDF_RADIO1,IPSW(1)) call wdialogputcheckbox(IDF_RADIO2,IPSW(2)) call wdialogputcheckbox(IDF_RADIO3,IPSW(4)) ! call wdialogputcheckbox(IDF_RADIO4,IPSW(3)) ! call wdialogputcheckbox(IDF_RADIO5,IPSW(9)) call wdialogputcheckbox(IDF_RADIO6,IPSW(5)) call wdialogputcheckbox(IDF_RADIO7,IPSW(7)) call wdialogputcheckbox(IDF_RADIO8,IPSW(6)) call wdialogputcheckbox(IDF_RADIO19,IPSW(15)) call wdialogputcheckbox(IDF_RADIO9,IPSW(8)) !ipk jan01 call wdialogputcheckbox(IDF_RADIO10,IPSW(10)) !ipk oct02 call wdialogputcheckbox(IDF_RADIO11,IPSW(11)) call wdialogputcheckbox(IDF_RADIO12,IPSW(12)) call wdialogputcheckbox(IDF_RADIO13,IPSW(13)) ! call wdialogputcheckbox(IDF_RADIO17,IPSW(14)) IF(IPSW(3) .EQ. 1) THEN call wdialogputradiobutton(IDF_RADIO4) ELSEIF(IPSW(9) .EQ. 1) THEN call wdialogputradiobutton(IDF_RADIO5) ELSEIF(IPSW(14).EQ. 1) THEN call wdialogputradiobutton(IDF_RADIO17) ELSE call wdialogputradiobutton(IDF_RADIO18) ENDIF IF(IPW1 .EQ. 1) THEN call wdialogputradiobutton(IDF_RADIO14) ELSEIF(IPW1 .EQ. 2) THEN call wdialogputradiobutton(IDF_RADIO15) ELSEIF(IPW1 .EQ. 3) THEN call wdialogputradiobutton(IDF_RADIO16) ENDIF call wdialogputreal(IDF_REAL1,WIDEL) call wdialogputreal(IDF_REAL2,WIDSCL) CALL WDialogSelect(IDD_DIALOG06) CALL WDialogShow(-1,-1,0,Modal) IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN call wdialoggetcheckbox(IDF_RADIO1,IPSW(1)) call wdialoggetcheckbox(IDF_RADIO2,IPSW(2)) call wdialoggetcheckbox(IDF_RADIO3,IPSW(4)) call wdialoggetcheckbox(IDF_RADIO4,IPSW(3)) call wdialoggetcheckbox(IDF_RADIO5,IPSW(9)) call wdialoggetcheckbox(IDF_RADIO6,IPSW(5)) call wdialoggetcheckbox(IDF_RADIO7,IPSW(7)) call wdialoggetcheckbox(IDF_RADIO8,IPSW(6)) call wdialoggetcheckbox(IDF_RADIO8,IPSW(15)) call wdialoggetcheckbox(IDF_RADIO9,IPSW(8)) !ipk jan01 call wdialoggetcheckbox(IDF_RADIO10,IPSW(10)) !ipk oct02 call wdialoggetcheckbox(IDF_RADIO11,IPSW(11)) call wdialogGetcheckbox(IDF_RADIO12,IPSW(12)) call wdialogGetcheckbox(IDF_RADIO13,IPSW(13)) ! call wdialoggetcheckbox(IDF_RADIO4,IPSW(3)) ! call wdialoggetcheckbox(IDF_RADIO5,IPSW(9)) ! call wdialogGetcheckbox(IDF_RADIO17,IPSW(14)) call wdialoggetradiobutton(IDF_RADIO4,ipw2) IPSW(3)=0 IPSW(9)=0 IPSW(14)=0 IF(IPW2 .EQ. 1) THEN IPSW(3)=1 ELSEIF(IPW2 .EQ. 2) THEN IPSW(9)=1 ELSEIF(IPW2 .EQ. 3) THEN IPSW(14)=1 ENDIF ! IF(IPSW(3) .EQ. 1) THEN ! IPSW(9)=0 ! call wdialogputcheckbox(IDF_RADIO5,0) ! IPSW(14)=0 ! call wdialogputcheckbox(IDF_RADIO17,0) ! ENDIF ! IF(IPSW(9) .EQ. 1) THEN ! IPSW(3)=0 ! call wdialogputcheckbox(IDF_RADIO4,0) ! IPSW(14)=0 ! call wdialogputcheckbox(IDF_RADIO17,0) ! ENDIF ! IF(IPSW(14) .EQ. 1) THEN ! IPSW(9)=0 ! call wdialogputcheckbox(IDF_RADIO5,0) ! IPSW(3)=0 ! call wdialogputcheckbox(IDF_RADIO4,0) ! ENDIF IF(IPSW(5) .EQ. 1) THEN IPSW(7)=0 call wdialogputcheckbox(IDF_RADIO7,0) ENDIF call wdialoggetradiobutton(IDF_RADIO14,ipw1) call wdialoggetreal(IDF_REAL1,WIDEL) call wdialoggetreal(IDF_REAL2,WIDSCL) MENUS=9 endif CALL PLOTOT(0) nhtp=nhtpsv nmess=nmessv nbrr=nbrrsv call hedr GO TO 100 ENDDO GO TO 100 CASE (ID_ITYPN) MENUS=9 ! IQSW(1)=1-IQSW(1) ! IF(IQSW(1) .EQ. 1) THEN ! IQSW(2)=0 ! ENDIF IQSW(1)=1 IQSW(2)=0 CALL WMenuSetState(ID_ITYPN,ItemChecked,1) CALL WMenuSetState(ID_ITYPC,ItemChecked,0) CALL WMenuSetState(ID_IGPC,ItemChecked,0) CALL WMenuSetState(ID_IGPN,ItemChecked,0) go to 100 CASE (ID_ITYPC) MENUS=9 ! IQSW(2)=1-IQSW(2) ! IF(IQSW(2) .EQ. 1) THEN ! IQSW(1)=0 ! ENDIF IQSW(2)=1 IQSW(1)=0 CALL WMenuSetState(ID_ITYPC,ItemChecked,1) CALL WMenuSetState(ID_ITYPN,ItemChecked,0) CALL WMenuSetState(ID_IGPC,ItemChecked,0) CALL WMenuSetState(ID_IGPN,ItemChecked,0) go to 100 CASE (ID_IGPN) MENUS=9 IQSW(1)=2 IQSW(2)=0 CALL WMenuSetState(ID_ITYPN,ItemChecked,0) CALL WMenuSetState(ID_ITYPC,ItemChecked,0) CALL WMenuSetState(ID_IGPN,ItemChecked,1) CALL WMenuSetState(ID_IGPC,ItemChecked,0) go to 100 CASE (ID_IGPC) MENUS=9 IQSW(1)=0 IQSW(2)=2 CALL WMenuSetState(ID_ITYPC,ItemChecked,0) CALL WMenuSetState(ID_ITYPN,ItemChecked,0) CALL WMenuSetState(ID_IGPN,ItemChecked,0) CALL WMenuSetState(ID_IGPC,ItemChecked,1) go to 100 CASE (ID_MAPOPD) DO call wdialogload(IDD_DIALOG05) call wdialogputcheckbox(IDF_CMAP0,ICOLON(1)) call wdialogputcheckbox(IDF_CMAP1,ICOLON(2)) call wdialogputcheckbox(IDF_CMAP2,ICOLON(3)) call wdialogputcheckbox(IDF_CMAP3,ICOLON(4)) call wdialogputcheckbox(IDF_CMAP4,ICOLON(5)) call wdialogputcheckbox(IDF_CMAP5,ICOLON(6)) call wdialogputcheckbox(IDF_CMAP6,ICOLON(7)) call wdialogputcheckbox(IDF_CMAP7,ICOLON(8)) call wdialogputcheckbox(IDF_CMAP8,ICOLON(9)) call wdialogputcheckbox(IDF_CMAP9,ICOLON(10)) call wdialogputcheckbox(IDF_CMAP10,ICOLON(11)) call wdialogputcheckbox(IDF_CMAP11,ICOLON(12)) CALL WDialogSelect(IDD_DIALOG05) CALL WDialogShow(-1,-1,0,Modal) IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN call wdialoggetcheckbox(IDF_CMAP0,ICOLON(1)) call wdialoggetcheckbox(IDF_CMAP1,ICOLON(2)) call wdialoggetcheckbox(IDF_CMAP2,ICOLON(3)) call wdialoggetcheckbox(IDF_CMAP3,ICOLON(4)) call wdialoggetcheckbox(IDF_CMAP4,ICOLON(5)) call wdialoggetcheckbox(IDF_CMAP5,ICOLON(6)) call wdialoggetcheckbox(IDF_CMAP6,ICOLON(7)) call wdialoggetcheckbox(IDF_CMAP7,ICOLON(8)) call wdialoggetcheckbox(IDF_CMAP8,ICOLON(9)) call wdialoggetcheckbox(IDF_CMAP9,ICOLON(10)) call wdialoggetcheckbox(IDF_CMAP10,ICOLON(11)) call wdialoggetcheckbox(IDF_CMAP11,ICOLON(12)) ENDIF CALL PLOTOT(0) nhtp=nhtpsv nmess=nmessv nbrr=nbrrsv call hedr GO TO 100 ENDDO GO TO 100 CASE (ID_DRAWD) CALL PLOTOT(0) nhtp=nhtpsv nmess=nmessv nbrr=nbrrsv call hedr GO TO 100 CASE (ID_BSEL) CALL PANEL012(IBAKON) IF(IBAKON .EQ. 1) THEN ! FONT%IBCOL = TextWhite ! call WindowFontColour(0,7) IRGB = WRGB(220,220,220) ELSE ! FONT%IBCOL = TextWhiteBold ! call WindowFontColour(0,15) IRGB = WRGB(255,255,255) ENDIF ! CALL WindowFont(FONT) call clear_screen call plotot(0) nhtp=nhtpsv nmess=nmessv nbrr=nbrrsv call hedr GO TO 100 CASE (ID_REGST) DO N=1,NBKFL IF(ISWBKFL(N) .NE. 0) THEN CALL REGISTR(N) ENDIF ENDDO GO TO 100 ! CASE (ID_BACGDG) ! call clear_screen ! call plotot(0) ! nhtp=nhtpsv ! nmess=nmessv ! nbrr=nbrrsv ! call hedr ! GO TO 100 CASE (ID_HELP1) call helps(0) ! call WHelpfile('rmagenv5.htm') go to 100 ! MENUS=4 CASE (ID_HELP2) call RMINFO go to 100 CASE (ID_ITEM20) CALL GDIST GO TO 100 CASE (ID_ITEM22) CALL SELNODE(0) menus=2 GO TO 100 CASE (ID_ALLNODES) CALL SELNODE(1) menus=2 GO TO 100 CASE (ID_UNUSNODES) CALL SELNODE(2) menus=2 GO TO 100 CASE (ID_SELELTYP) CALL SELNODE(3) menus=2 GO TO 100 CASE (ID_MOVGRP) CALL SELNODE(4) menus=2 GO TO 100 CASE (ID_ITEM23) CALL SELELT(0) menus=0 GO TO 100 CASE (ID_SECGRP) CALL SELELT(2) menus=0 GO TO 100 ! CALL HEDR CASE (ID_SELAREA) CALL SELELT(1) menus=2 GO TO 100 CASE (ID_DISPTYP) CALL FINDTYP menus=2 GO TO 100 CASE (ID_UNDO) CALL UNDOACT GO TO 100 CASE (ID_UNDOS) IFLAG='U' CASE (ID_UNDOGEN) ! IF(ITOTFIL .EQ. 1) THEN ! CALL ZEROOUT ! IACTVFIL=0 ! CALL PLOTOT(0) ! ELSE CALL UNDOGEN ! ENDIF GO TO 100 CASE (ID_GOUTLIN) CALL GOUTLIN GO TO 100 CASE (ID_XOUTLIN) CALL OUTLINES(0) GO TO 100 CASE (ID_3DMODEL) CALL BuildModel(np,ne) GO TO 100 END SELECT ! ! Mouse button down - only process mouse button 1 events ! CASE (MouseButDown) if(menus .eq. 8) then call rred IF (MESSAGE%VALUE1.EQ.1) THEN ! ! Enable button up and mouse movement events ! CALL WMessageEnable(MouseButUp, Enabled) ! CALL WMessageEnable(MouseMove , Enabled) IDOWN = 1 ! ! Save the current cursor position ! XPOS = MESSAGE%GX YPOS = MESSAGE%GY ! For box plotting we must initialise Exclusive-OR plotting, ! set the fill type, draw the initial box and save the corner ! co-ordinates ! CALL IGrPlotMode('E') !DEC09 CALL IGrPlotMode(0) if(idrag .eq. 0) then CALL IGrFillPattern(0,0,0) CALL IGrRectangle(XPOS, YPOS, MESSAGE%GX, MESSAGE%GY) else call Rgreen CALL IGrJoin(XPOS, YPOS, MESSAGE%GX, MESSAGE%GY) iflag='d' endif XOLD = MESSAGE%GX YOLD = MESSAGE%GY ELSE call WCursorShape(CurArrow) idrag=0 nhtp=nhtpsv nmess=nmessv nbrr=nbrrsv call hedr menus=0 ENDIF GO TO 101 ELSE MBUTTON = MESSAGE%VALUE1 ITIME = MESSAGE%VALUE2 MOUSEX = MESSAGE%X MOUSEY = MESSAGE%Y XM=MESSAGE%GX YM=MESSAGE%GY IF(MBUTTON .EQ. 1) THEN IFLAG='c' ELSE if(idrag .eq. 0) then IFLAG='r' else idrag=0 menus=0 go to 101 endif ENDIF ENDIF ! ! Mouse Movement ! CASE (MouseMove) IF (IDOWN.EQ.1) THEN ! ! For rectangle plotting we must redraw the last box to erase it from the ! screen. We then update the co-ordinates and draw the new rectangle ! IF(IDRAG .EQ. 0) THEN CALL IGrRectangle(XPOS, YPOS, XOLD, YOLD) XOLD = MESSAGE%GX YOLD = MESSAGE%GY XSCRN= XOLD YSCRN= YOLD XMS = XSCRN*TXSCAL - XS YMS = YSCRN*TXSCAL - YS WRITE(STBAR,'(2g19.10)') XMS,YMS CALL WindowOutStatusBar(2,STBAR) WRITE(STBAR,'('' NP = ''i6,'' NE = ''i6)') NP,NE CALL WindowOutStatusBar(3,STBAR) WRITE(STBAR,'(2x,A48)') FNAMEDISP CALL WindowOutStatusBar(5,STBAR) xsiz=abs(xold-xpos) ysiz=abs(yold-ypos) slen=sqrt(xsiz**2+ysiz**2) shapef=hsize/8. !jan09 if(xsiz .lt. 1.25*ysiz) then !jan09 xsiz=1.25*ysiz if(xsiz .lt. shapef*ysiz) then xsiz=shapef*ysiz ! xsiz=16./25.*slen if(xold .lt. xpos) then xold=xpos-xsiz else xold=xpos+xsiz endif !jan09 elseif(ysiz .lt. 0.80*xsiz) then !jan09 ysiz=0.80*xsiz elseif(ysiz .lt. xsiz/shapef) then ysiz=xsiz/shapef ! ysiz=9./25.*slen if(yold .lt. ypos) then yold=ypos-ysiz else yold=ypos+ysiz endif endif CALL IGrRectangle(XPOS, YPOS, xold,yold) go to 101 ELSE CALL IGrJoin(XPOS, YPOS, XOLD, YOLD) XOLD = MESSAGE%GX YOLD = MESSAGE%GY XSCRN= XOLD YSCRN= YOLD XMS = XSCRN*TXSCAL - XS YMS = YSCRN*TXSCAL - YS WRITE(STBAR,'(2g19.10)') XMS,YMS CALL WindowOutStatusBar(2,STBAR) WRITE(STBAR,'('' NP = ''i6,'' NE = ''i6)') NP,NE CALL WindowOutStatusBar(3,STBAR) WRITE(STBAR,'(2x,A48)') FNAMEDISP CALL WindowOutStatusBar(5,STBAR) CALL IGrJoin(XPOS, YPOS, XOLD, YOLD) go to 101 ENDIF ELSE XOLD = MESSAGE%GX YOLD = MESSAGE%GY XSCRN= XOLD YSCRN= YOLD XMS = XSCRN*TXSCAL - XS YMS = YSCRN*TXSCAL - YS WRITE(STBAR,'(2g19.10)') XMS,YMS CALL WindowOutStatusBar(2,STBAR) WRITE(STBAR,'('' NP = ''i6,'' NE = ''i6)') NP,NE CALL WindowOutStatusBar(3,STBAR) WRITE(STBAR,'(2x,A48)') FNAMEDISP CALL WindowOutStatusBar(5,STBAR) GO TO 101 ENDIF ! CASE (PushButton) ! Dialog button pressed ! IDBUTN = MESSAGE%VALUE1 ! IDFIELD = MESSAGE%VALUE2 CASE (MouseButUp) ! Mouse button up IF(MENUS .NE. 8) THEN MBUTTON = MESSAGE%VALUE1 ITIME = MESSAGE%VALUE2 MOUSEX = MESSAGE%X MOUSEY = MESSAGE%Y XM=MESSAGE%GX YM=MESSAGE%GY IF(MBUTTON .EQ. 1) THEN IFLAG='c' ELSE IFLAG='r' ENDIF ELSE ! ! We disable movement and button up events ! IDOWN = 0 CALL WMessageEnable(MouseButUp, Disabled) ! CALL WMessageEnable(MouseMove , Disabled) IF(IDRAG .EQ. 0) THEN CALL IGrRectangle(XPOS, YPOS, XOLD, YOLD) CALL IGrPlotMode('N') CALL IGrRectangle(XPOS, YPOS, xold,yold) XPOS1=MESSAGE%GX YPOS1=MESSAGE%GY menus=-8 zoomh=' Click right if size OK' ! CALL CLRBOX CALL SYMBL(0.,7.70,0.20,zoomh,0.,23) GO TO 101 ELSEIF(IDRAG .EQ. 1) THEN menus=8 CALL IGrJoin(XPOS, YPOS, XOLD, YOLD) CALL IGrPlotMode('N') CALL IGrJoin(XPOS, YPOS, xold,yold) XPOS1=MESSAGE%GX YPOS1=MESSAGE%GY xpos=xpos1-xpos ypos=ypos1-ypos xpos1=xpos+HSIZE ypos1=ypos+8. iflag='d' call zoomnew(xpos,ypos,xpos1,ypos1,iflag) zoomh=' Click right to end ' ! CALL CLRBOX CALL SYMBL(0.,7.70,0.20,zoomh,0.,20) iflag='r' GO TO 101 ELSE menus=8 CALL IGrJoin(XPOS, YPOS, XOLD, YOLD) CALL IGrPlotMode('N') CALL IGrJoin(XPOS, YPOS, xold,yold) XPOS1=MESSAGE%GX YPOS1=MESSAGE%GY xpos=xpos1-xpos ypos=ypos1-ypos zoomh=' Click right to end ' IF(ABS(XPOS) .GT. ABS(YPOS)) THEN hrad=xpos/(YPOS1-4) VRAD=0. ELSE vrad=-ypos/10. HRAD=0. ENDIF call adjustang(hrad,vrad) ! CALL CLRBOX CALL SYMBL(0.,7.70,0.20,zoomh,0.,20) iflag='r' GO TO 101 ENDIF ENDIF ! WRITE(90,*) 'MOUSE BUT',MOUSEX,MOUSEY,XM,YM ! WRITE(90,'(A)') 'MOUSE BUT',IFLAG CASE (Expose) ! Window partly/wholly exposed iflag='P' IX = MESSAGE%X IY = MESSAGE%Y IWIDTH = MESSAGE%VALUE1 IHEIGHT = MESSAGE%VALUE2 call hedr if(menus .eq. 12 .or. menus .eq. 13) then call conout(menus) else call plotot(0) endif call hedr !IPK MAY01 IRDISP=1 if(nmess .eq. 11) CALL PLTPT if(menus .eq. 13) CALL CONOUT(MENUS) go to 100 CASE (Resize) ! Window resized CALL IGrUnits(0.,0.,HSIZE,8.0) iflag='P' IWIDTH = MESSAGE%VALUE1 IHEIGHT = MESSAGE%VALUE2 call hedr if(menus .eq. 12 .or. menus .eq. 13) then call conout(menus) else call plotot(0) endif call hedr !IPK MAY01 IRDISP=1 if(nmess .eq. 11) CALL PLTPT if(menus .eq. 13) CALL CONOUT(MENUS) go to 100 CASE (CloseRequest) ! Close window (e.g. Alt/F4) IWINDOW = MESSAGE%WIN if(iwindow .eq. 0) then !IPK SEP02 call rquit(iyes) if(iyes .ne. 1) go to 100 CALL QUIT_PGM ! Root window : exit program else CALL WindowCloseChild(iwindow) DO I=1,NWINDWS IF(IWINDOW .EQ. IWNDWS(I)) THEN IWNDWS(i)=0 ISCRNS(i)=0 ! This call removes the bitmap CALL BACKP(3,I) ENDIF ENDDO go to 100 endif ! CASE (FieldChanged) ! Field change in modeless dialog ! IDFIELDOLD = MESSAGE%VALUE1 ! IDFIELDNEW = MESSAGE%VALUE2 END SELECT ! WRITE(90,'(A)') 'endselect',IFLAG ! write(90,*) 'endselect',menus menus =abs(menus) IF(MENUS .GT. 0 .and. menus .lt. 8) THEN CALL RMAGEN(MENUS,IMP,IIN,1,IOT,IOT1,NDM,ITRIAN,N2,M2) ENDIF if(menus .eq. 8) then IF(IFLAG .EQ. 'w') THEN HANG=0. VANG=90 VRTSCAL=100. VRTORIG=0. i3dview=0 endif if( IFLAG .EQ. 'r' .or.& iflag .eq. 'y' .or.& iflag .eq. 'x' .or.& iflag .eq. 'w' .or.& iflag .eq. 'v' .or.& iflag .eq. 'u' .or.& iflag .eq. 't' .or.& iflag .eq. 's' ) then call zoomnew(xpos,ypos,xpos1,ypos1,iflag) nhtp=nhtpsv nmess=nmessv nbrr=nbrrsv call hedr endif !IPK MAY01 IRDISP=1 if(nmess .eq. 11) CALL PLTPT go to 100 endif IF(MENUS .EQ. 9) GO TO 101 ix=xm*100. iy=ym*100. ! call IMouseCursorHide() 250 continue nhtp=nhtpsv nmess=nmessv nbrr=nbrrsv ! WRITE(90,'(A)') 'end',IFLAG ! write(90,*) 'end',menus,nhtp,nhtpsv ! call clscrn ! call hedr END SUBROUTINE