!IPK LAST UPDATE SEP 23 2015 ADD MORE INFO ON FRAME ! PROGRAM NEWRMAGEN ! ! Use of the module is compulsory ! USE WINTERACTER USE DFLIB ! IMPLICIT NONE ! ! Define some parameters to match those in the resource file ! include 'd.inc' INCLUDE 'TXFRM.COM' REAL HSIZE,scratio COMMON /SSIZE/ HSIZE ! INTEGER :: IBASEV =40042 INTEGER :: I,IRES,N2,M2,ID1,ID2 INTEGER :: ITYPE, IX, IY, IWIDTH, IHEIGHT, KEY,IYES INTEGER :: MOUSEX, MOUSEY, MBUTTON, ITIME, IWINDOW INTEGER :: IDFIELDOLD, IDFIELDNEW, IDBUTN, IDFIELD,TOOLID(4) INTEGER :: LNNAM,K,LMPNAM,IMP,IIN,MENUS,IOT,IOT1,impf,IGFG,ITRIAN,INFO(3) INTEGER , DIMENSION(5) :: WIDSTAT INTEGER*2 :: N1,STATUS,lnnnam,iswtfl,n CHARACTER(LEN=255) :: FNAME,FNAMD,FILTER CHARACTER(LEN=3) :: SUB,SUB1 CHARACTER(LEN=4) :: SUB2 CHARACTER(LEN=1000) :: HEADR INTEGER ,EXTERNAL :: LENSTR LOGICAL :: OPENED,exists LOGICAL(4) :: statud REAL :: XX1,XX2,XX3,XX4,XX5,XX6 INTEGER :: iw,ih,ihandle,ient,IHAND1,IHAND2,IXPM,IYPX,IXPX,IYPM common /hands/ ihandle,IHAND1,IHAND2,IXPM,IYPX,IXPX,IYPM INTEGER ISCRWID,ISCRHGT TYPE(WIN_STYLE) :: WINDOW TYPE(WIN_MESSAGE) :: MESSAGE TYPE (WIN_FONT) :: FONT ! Define a common block with background file names INCLUDE 'BFILES.I90' ! ! Get initial directory and add help name fname = FILE$CURDRIVE IRES=GETDRIVEDIRQQ (fname) ! lnnnam=windowstringlength(fname) lnnnam=lenstr(fname) direct=fname(1:lnnnam)//'\doc\rmagen83d.htm' ! write(128,*) fname,lnnnam,direct ! ! ! Initialise WiSK ! CALL WInitialise() ! ! Create a root window with : ! - System menu ! - Minimise button ! - Maximise button ! ! WINDOW%FLAGS = SysMenuOn + MinButton + MaxButton + StatusBar ISCRWID = WInfoScreen(1) ! Get screen width ISCRHGT = WInfoScreen(2) ! Get screen height scratio=float(iscrwid)/float(iscrhgt) HSIZE=scratio*8. ! ! Centre the window on the screen at 80% of screen size ! WINDOW%X = -1 WINDOW%Y = -1 WINDOW%WIDTH = 0 WINDOW%HEIGHT = 0 ! ! Identify the menu to be attached to the window ! and specify the initial window title ! ! WINDOW%MENUID = IDR_MENU1 ! WINDOW%TITLE = 'RMAGEN' ! ! Now open the root window ! CALL WindowOpen(FLAGS =SysMenuOn+MinButton+MaxButton+StatusBar, & MENUID=IDR_MENU1, & TOOLID=(/0,ID_TOOLBAR1,0,0/), & TITLE ='RMAGEN') ! CALL WindowOpen(WINDOW,TITLE ='RMAGEN') ! Open root window ! ! Add a toolbar ! ! CALL WMenuToolbar(ID_TOOLBAR1) ! ! Main message loop ! ! initialise palette ! CALL IGrPaletteInit ! ! set fill style to solid ! CALL IGrFillPattern(Solid) FONT%IBCOL = TextWhite CALL WindowFont(FONT) ! CALL WindowClear(RGB=RGB_yellow) ! clear window to yellow ! IRGB = WRGB(220,220,220) ! IRGB = WRGB(191,191,191) IRGB = WRGB(227,227,227) CALL WindowClear(rgb=irgb) ! clear to yellow WIDSTAT(1) = 1000 WIDSTAT(2) = 2000 WIDSTAT(3) = 1500 WIDSTAT(4) = 1000 WIDSTAT(5) = 2500 CALL WindowStatusBarParts(5, WIDSTAT) CALL WindowOutStatusBar(1, ' X and Y location') CALL WindowOutStatusBar(4, ' Active File Name') CALL IgrUnits(0.,0.,HSIZE,8.0) ! IF(ISW .EQ. 1) THEN ! CALL WMessageEnable(MouseMove , Enabled) ! MENUS=-3 ! CALL RMAGEN(MENUS,IMP,IIN,1,IOT,IOT1,IGFG) ! ENDIF ! CALL WMenuSetState(ID_NETWD,ItemChecked,1) ! DO I=1,12 ! CALL WMenuSetState(IBASEV+I,ItemChecked,1) ! ENDDO IDDSW=-1 IHANDLE=0 IHAND1=0 IHAND2=0 N2=0 M2=0 TXSCAL = 1. XS=0. YS=0. NBKFL=0 IRDONE=-1 DO I=1,10 ISWBKFL(I)=0 ENDDO IACTVFIL=0 ITOTFIL=0 IOT=0 IOT1=0 IMP=0 CALL INITSIZ(IIN,N2,M2,0) CALL WMenuSetState(ID_loadrm1,ItemEnabled,0) CALL WMenuSetState(ID_sbin,ItemEnabled,0) CALL WMenuSetState(ID_crsf,ItemEnabled,0) CALL WMenuSetState(ID_savcrs,ItemEnabled,0) CALL WMenuSetState(ID_LAYFL,ItemEnabled,0) CALL WMenuSetState(ID_ITEM13,ItemEnabled,0) CALL WMenuSetState(ID_ITEM14,ItemEnabled,0) CALL WMenuSetState(ID_ITEM18,ItemEnabled,0) CALL WMenuSetState(ID_ITEM15,ItemEnabled,0) CALL WMenuSetState(ID_ITEM16,ItemEnabled,0) CALL WMenuSetState(ID_ICOPY,ItemEnabled,0) CALL WMenuSetState(ID_Clip,ItemEnabled,0) CALL WMenuSetState(ID_ITEM24,ItemEnabled,0) CALL WMenuSetState(ID_MMAP,ItemEnabled,0) CALL WMenuSetState(ID_MAPM,ItemEnabled,0) CALL WMenuSetState(ID_NETWORK,ItemEnabled,0) CALL WMenuSetState(ID_NODE,ItemEnabled,0) CALL WMenuSetState(ID_ELTS,ItemEnabled,0) CALL WMenuSetState(ID_ORDR,ItemEnabled,0) CALL WMenuSetState(ID_CCLN,ItemEnabled,0) CALL WMenuSetState(ID_CONTR,ItemEnabled,0) CALL WMenuSetState(ID_CSEC,ItemEnabled,0) CALL WMenuSetState(ID_CSEC1,ItemEnabled,0) CALL WMenuSetState(ID_ITEM20,ItemEnabled,0) CALL WMenuSetState(ID_ITEM26,ItemEnabled,0) CALL WMenuSetState(ID_ZOOM,ItemEnabled,0) CALL WMenuSetState(ID_DRAW,ItemEnabled,0) CALL WMenuSetState(ID_UNDOM,ItemEnabled,0) CALL WMenuSetState(ID_NMAP,ItemEnabled,0) CALL WMenuSetState(ID_CDATA,ItemEnabled,0) CALL WMenuSetState(ID_ITEM56,ItemEnabled,0) CALL WMenuSetState(ID_SECGRP,ItemEnabled,0) iswtfl=0 N1=1 CALL GETARG(N1,FNAME,STATUS) if(status .ne. -1 ) then CALL SHORTNAME(FNAME,FNAMEDISP) do n=status,1,-1 if(fname(n:n) .eq. '\') then lnnnam=n-1 go to 99 endif enddo 99 continue if(lnnnam .gt. 0) then fnamd=fname(1:lnnnam) statud = CHANGEDIRQQ(fnamd) endif iswtfl=1 CALL IlowerCase(FNAME) CALL GETSUB(FNAME,SUB) ITRIAN=0 IF(SUB .EQ. 'geo') then IIN=12 OPEN(IIN ,FILE=FNAME,STATUS='OLD',form='binary',ACTION='READ') FNAMKEP=FNAME READ(IIN) HEADR READ(IIN) N2,M2 REWIND (IIN) ELSEIF(SUB .EQ. 'gfg') then IIN = 10 IGFG=1 CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2) OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ') ELSEIF(SUB .EQ. '2dm') then IIN = 10 IGFG=3 CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2) OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ') ELSEIF(SUB .EQ. 'rst') then IIN=11 OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED') ! OPEN(IIN,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read') IGFG=0 CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2) ELSEIF(SUB .EQ. 'bin') then IIN=12 OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED') IGFG=2 CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2) ELSEIF(SUB .EQ. 'ele') then IIN=10 OPEN(IIN ,FILE=FNAME,STATUS='OLD',ACTION='READ') ITRIAN=1 IGFG=0 FNAMKEP=FNAME CALL SETGFGTRIAN(IGFG,ITRIAN,N2,M2) ELSEIF(SUB .EQ. 'map') then IMP=9 OPEN(9,FILE=FNAME,STATUS='OLD',action='read') ELSEIF(SUB .EQ. 'asc' .or. SUB .EQ. 'grd') then IMP=94 OPEN(94,FILE=FNAME,STATUS='OLD',action='read') 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') ELSE IIN = 10 IGFG=0 CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2) OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ') ENDIF IF(IMP .EQ. 0) THEN IACTVFIL=1 ITOTFIL=1 FNAMEOUT(1)=FNAME ENDIF CALL WMenuSetState(ID_loadrm1,ItemEnabled,1) ! CALL WMenuSetState(ID_sbin,ItemEnabled,1) CALL WMenuSetState(ID_crsf,ItemEnabled,1) ! CALL WMenuSetState(ID_savcrs,ItemEnabled,1) CALL WMenuSetState(ID_LAYFL,ItemEnabled,1) !CALL WMenuSetState(ID_ITEM13,ItemEnabled,1) !CALL WMenuSetState(ID_ITEM14,ItemEnabled,1) !CALL WMenuSetState(ID_ITEM18,ItemEnabled,1) !CALL WMenuSetState(ID_ITEM15,ItemEnabled,1) !CALL WMenuSetState(ID_ITEM16,ItemEnabled,1) CALL WMenuSetState(ID_ICOPY,ItemEnabled,1) CALL WMenuSetState(ID_Clip,ItemEnabled,1) CALL WMenuSetState(ID_ITEM24,ItemEnabled,1) CALL WMenuSetState(ID_MMAP,ItemEnabled,1) CALL WMenuSetState(ID_MAPM,ItemEnabled,1) CALL WMenuSetState(ID_NETWORK,ItemEnabled,1) CALL WMenuSetState(ID_NODE,ItemEnabled,1) CALL WMenuSetState(ID_ELTS,ItemEnabled,1) CALL WMenuSetState(ID_ORDR,ItemEnabled,1) CALL WMenuSetState(ID_CCLN,ItemEnabled,1) CALL WMenuSetState(ID_CONTR,ItemEnabled,1) ! CALL WMenuSetState(ID_CSEC,ItemEnabled,0) CALL WMenuSetState(ID_CSEC1,ItemEnabled,1) CALL WMenuSetState(ID_ITEM20,ItemEnabled,1) CALL WMenuSetState(ID_ITEM26,ItemEnabled,1) CALL WMenuSetState(ID_ZOOM,ItemEnabled,1) CALL WMenuSetState(ID_DRAW,ItemEnabled,1) CALL WMenuSetState(ID_UNDOM,ItemEnabled,1) CALL WMenuSetState(ID_NMAP,ItemEnabled,1) CALL WMenuSetState(ID_CDATA,ItemEnabled,1) CALL WMenuSetState(ID_ITEM56,ItemEnabled,1) CALL WMenuSetState(ID_RESETLIM,ItemEnabled,0) CALL WMessageEnable(MouseMove , Enabled) IF(IMP .GT. 0) THEN MENUS=-2 CALL INITSIZ(IIN,N2,M2,1) go to 500 ENDIF CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to load '//& CHAR(13)//'a map file?' ,& 'Map File Input?') ! ! If answer 'No' skip out ! IMP=0 IF (WInfoDialog(4) .NE. 2) then fname=' ' 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',action='read') ELSEIF(SUB .EQ. 'asc' .or. SUB .EQ. 'grd') then IMP=94 OPEN(94,FILE=FNAME,STATUS='OLD',action='read') 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') ELSEIF(SUB .EQ. 'rm1') then imp=13 OPEN(IMP ,FILE=FNAME,STATUS='OLD',action='read') 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') ENDIF ENDIF END IF MENUS=-2 CALL INITSIZ(IIN,N2,M2,1) go to 500 endif DO WHILE (.TRUE.) ! Loop until user terminates 100 continue CALL WMessage(ITYPE, MESSAGE) SELECT CASE (ITYPE) CASE (KeyDown) ! Key pressed KEY = MESSAGE%VALUE1 MOUSEX = MESSAGE%X MOUSEY = MESSAGE%Y CASE (MenuSelect) ! Menu item selected SELECT CASE (MESSAGE%VALUE1) ! CASE (ID_FILE) ! File option selected CASE (ID_RESETLIM) CALL RESETSIZ CASE (ID_ITEM11) ! New option IMP=0 IIN=0 CALL INITSIZ(IIN,N2,M2,1) CALL WMenuSetState(ID_loadrm1,ItemEnabled,1) ! CALL WMenuSetState(ID_sbin,ItemEnabled,1) CALL WMenuSetState(ID_crsf,ItemEnabled,1) ! CALL WMenuSetState(ID_savcrs,ItemEnabled,1) CALL WMenuSetState(ID_LAYFL,ItemEnabled,1) !CALL WMenuSetState(ID_ITEM13,ItemEnabled,1) !CALL WMenuSetState(ID_ITEM14,ItemEnabled,1) !CALL WMenuSetState(ID_ITEM18,ItemEnabled,1) !CALL WMenuSetState(ID_ITEM15,ItemEnabled,1) !CALL WMenuSetState(ID_ITEM16,ItemEnabled,1) CALL WMenuSetState(ID_ICOPY,ItemEnabled,1) CALL WMenuSetState(ID_Clip,ItemEnabled,1) CALL WMenuSetState(ID_ITEM24,ItemEnabled,1) CALL WMenuSetState(ID_MMAP,ItemEnabled,1) CALL WMenuSetState(ID_MAPM,ItemEnabled,1) CALL WMenuSetState(ID_NETWORK,ItemEnabled,1) CALL WMenuSetState(ID_NODE,ItemEnabled,1) CALL WMenuSetState(ID_ELTS,ItemEnabled,1) CALL WMenuSetState(ID_ORDR,ItemEnabled,1) CALL WMenuSetState(ID_CCLN,ItemEnabled,1) CALL WMenuSetState(ID_CONTR,ItemEnabled,1) ! CALL WMenuSetState(ID_CSEC,ItemEnabled,0) CALL WMenuSetState(ID_CSEC1,ItemEnabled,1) CALL WMenuSetState(ID_ITEM20,ItemEnabled,1) CALL WMenuSetState(ID_ITEM26,ItemEnabled,1) CALL WMenuSetState(ID_ZOOM,ItemEnabled,1) CALL WMenuSetState(ID_DRAW,ItemEnabled,1) CALL WMenuSetState(ID_UNDOM,ItemEnabled,1) CALL WMenuSetState(ID_NMAP,ItemEnabled,1) CALL WMenuSetState(ID_CDATA,ItemEnabled,1) CALL WMenuSetState(ID_ITEM56,ItemEnabled,1) CALL WMenuSetState(ID_RESETLIM,ItemEnabled,0) CALL WMessageEnable(MouseMove , Enabled) MENUS=-2 EXIT CASE (ID_ITEM12) ! Open option IMP=0 IIN=0 if(iswtfl .eq. 1) go to 200 fname=' ' FILTER ="Network Files|*.rm1;*.geo;*.gfg;*.bin;*.ele;*.2dm|Rm1 file -- *.rm1|*.rm1|Geo file -- *.geo|*.geo|GFGEN file -- *.gfg|*.gfg|GFGEN bin file -- *.bin|*.bin|Rst file -- *.rst|*.rst|ele file -- *.ele|*.ele|MESH2D file -- *.2dm|*.2dm|All files|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) IF(SUB .EQ. 'geo') then IIN=12 OPEN(IIN ,FILE=FNAME,STATUS='OLD',form='binary',ACTION='READ') FNAMKEP=FNAME READ(IIN) HEADR READ(IIN) N2,M2 REWIND (IIN) ITRIAN=0 ELSEIF(SUB .EQ. 'gfg') then IIN = 10 IGFG=1 OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ') ITRIAN=0 CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2) ELSEIF(SUB .EQ. '2dm') then IIN = 10 IGFG=3 OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ') ITRIAN=0 CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2) ELSEIF(SUB .EQ. '2dm') then IIN = 10 IGFG=3 OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ') ITRIAN=0 CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2) ELSEIF(SUB .EQ. 'bin') then IIN=12 OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED') IGFG=2 ITRIAN=0 CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2) ELSEIF(SUB .EQ. 'rst') then IIN=11 OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED') ! OPEN(IIN,FILE=FNAME,STATUS='OLD',FORM ='BINARY') IGFG=0 ITRIAN=0 CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2) ELSEIF(SUB .EQ. 'ele') then IIN=10 OPEN(IIN ,FILE=FNAME,STATUS='OLD',ACTION='READ') ITRIAN=1 IGFG=0 FNAMKEP=FNAME CALL SETGFGTRIAN(IGFG,ITRIAN,N2,M2) ELSE IIN = 10 IGFG=0 OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ') ITRIAN=0 CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2) ENDIF IACTVFIL=1 ITOTFIL=1 FNAMEOUT(1)=FNAME CALL SHORTNAME(FNAME,FNAMEDISP) 250 CONTINUE fname=' ' filter="Map file -- *.map |*.map|Bin Map file -- *.mpb|*.mpb|Bin Map file (no head) -- *.mbb|*.mbb|RM1 file (as map) -- *.rm1|*.rm1|ESRI ASC file -- *.asc|*.asc|SURFER GRD file -- *.grd|*.grd|ESRI SHP file -- *.shp|*.shp|" CALL WSelectFile(filter,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',action='read') ELSEIF(SUB .EQ. 'asc' .or. SUB .EQ. 'grd') then IMP=94 OPEN(94,FILE=FNAME,STATUS='OLD',action='read') 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. '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') ELSEIF(SUB .EQ. 'rm1') then imp=13 OPEN(IMP ,FILE=FNAME,STATUS='OLD',action='read') ENDIF ENDIF CALL WMenuSetState(ID_loadrm1,ItemEnabled,1) ! CALL WMenuSetState(ID_sbin,ItemEnabled,1) CALL WMenuSetState(ID_crsf,ItemEnabled,1) ! CALL WMenuSetState(ID_savcrs,ItemEnabled,1) CALL WMenuSetState(ID_LAYFL,ItemEnabled,1) !CALL WMenuSetState(ID_ITEM13,ItemEnabled,1) !CALL WMenuSetState(ID_ITEM14,ItemEnabled,1) !CALL WMenuSetState(ID_ITEM18,ItemEnabled,1) !CALL WMenuSetState(ID_ITEM15,ItemEnabled,1) !CALL WMenuSetState(ID_ITEM16,ItemEnabled,1) CALL WMenuSetState(ID_ICOPY,ItemEnabled,1) CALL WMenuSetState(ID_Clip,ItemEnabled,1) CALL WMenuSetState(ID_ITEM24,ItemEnabled,1) CALL WMenuSetState(ID_MMAP,ItemEnabled,1) CALL WMenuSetState(ID_MAPM,ItemEnabled,1) CALL WMenuSetState(ID_NETWORK,ItemEnabled,1) CALL WMenuSetState(ID_NODE,ItemEnabled,1) CALL WMenuSetState(ID_ELTS,ItemEnabled,1) CALL WMenuSetState(ID_ORDR,ItemEnabled,1) CALL WMenuSetState(ID_CCLN,ItemEnabled,1) CALL WMenuSetState(ID_CONTR,ItemEnabled,1) CALL WMenuSetState(ID_CSEC1,ItemEnabled,1) ! CALL WMenuSetState(ID_CSEC,ItemEnabled,0) CALL WMenuSetState(ID_ITEM20,ItemEnabled,1) CALL WMenuSetState(ID_ITEM26,ItemEnabled,1) CALL WMenuSetState(ID_ZOOM,ItemEnabled,1) CALL WMenuSetState(ID_DRAW,ItemEnabled,1) CALL WMenuSetState(ID_UNDOM,ItemEnabled,1) CALL WMenuSetState(ID_NMAP,ItemEnabled,1) CALL WMenuSetState(ID_CDATA,ItemEnabled,1) CALL WMenuSetState(ID_ITEM56,ItemEnabled,1) CALL WMenuSetState(ID_RESETLIM,ItemEnabled,0) CALL WMessageEnable(MouseMove , Enabled) MENUS=-2 CALL INITSIZ(IIN,N2,M2,1) EXIT CASE (ID_ITEM13) ! Save option WRITE(90,*) 'NWRM ITEM13' INQUIRE(20, OPENED=OPENED) if(.not. opened) then FILTER ="Network Files|*.rm1;*.gfg;*.ele|Rm1 file -- *.rm1|*.rm1|GFGEN file -- *.gfg|*.gfg|ele file -- *.ele|*.ele|All files|*.*|" CALL WSelectFile(FILTER,SaveDialog+PromptOn,FNAME,'Save Network File') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN SUB='rm1' CALL ADDSUB(FNAME,SUB) WRITE(90,*) 'IN ITEM13-NEW',IOT WRITE(90,'(A)') FNAME,SUB IOT = 20 OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN',ACTION='READWRITE') call wrtout(1) ENDIF else call wrtout(1) endif CASE (ID_ITEM14) ! Save option WRITE(90,*) 'NWRM ITEM14' INQUIRE(22, OPENED=OPENED) if(.not. opened) then CALL WSelectFile(ID_STRING4,SaveDialog+PromptOn,FNAME,'Save Network File') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN SUB='geo' CALL ADDSUB(FNAME,SUB) WRITE(90,*) 'IN ITEM14-NEW',IOT1 WRITE(90,'(A)') FNAME,SUB IOT1=22 OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='binary',ACTION='READWRITE') call wrtout(2) ENDIF else call wrtout(2) endif CASE (ID_ITEM18) ! Save As option CALL WSelectFile(ID_STRING5,SaveDialog+PromptOn,FNAME,'Save Bin Map File') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN SUB='mpb' CALL ADDSUB(FNAME,SUB) impf=93 OPEN(IMPF ,FILE=fname,STATUS='unknown',form='unformatted',ACTION='READWRITE') call wrtmap(1) ENDIF CASE (ID_ITEM15) ! Save As option CALL WSelectFile(ID_STRING3,SaveDialog+PromptOn,FNAME,'Save Network File') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN SUB='rm1' CALL ADDSUB(FNAME,SUB) IOT = 20 OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN',ACTION='READWRITE') call wrtout(1) ENDIF CASE (ID_ITEM16) ! Save As option CALL WSelectFile(ID_STRING4,SaveDialog+PromptOn,FNAME,'Save Network File') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN SUB='geo' CALL ADDSUB(FNAME,SUB) IOT1 = 22 OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='binary',ACTION='READWRITE') call wrtout(2) ENDIF CASE (ID_BKF) ! Read background option fname=' ' FILTER ="Background File|*.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,FNAME,'Load Background file') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN CALL IlowerCase(FNAME) CALL GETSUB(FNAME,SUB) NBKFL=NBKFL+1 BFNAME(NBKFL)=FNAME SUB1=SUB 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 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') 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) EXIT ELSE NBKFL=NBKFL-1 EXIT ENDIF ENDIF ! yes 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 CLOSE(104) 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 125 ENDIF OPEN(104,FILE=FNAME,STATUS ='OLD', FORM ='FORMATTED') READ(104,'(4G16.8)') (BFMINMAX(NBKFL,I),I=1,4) CLOSE(104) 125 CONTINUE ENDIF CASE (ID_ITEM24) ! Print option is selected CALL WHardcopyOptions(3) ! ! If the user clicked OK on page setup dialog then output the contents ! of the subroutine DOPLOT 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 call clscrn CALL PLOTOT(0) ! plot graph call rblack 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) CALL PLOTOT(0) CALL HEDR call rblack CALL IGrRectangle(0.,0.,HSIZE,7.5) END IF CASE (ID_ITEM19) ! Demo option MENUS=-1 IMP=0 IIN=0 EXIT CASE (ID_ITEM17) ! Exit option call rquit(iyes) if(iyes .ne. 1) go to 100 MENUS=0 EXIT CASE (ID_EXIT) ! Exit program (menu option) call rquit(iyes) if(iyes .ne. 1) go to 100 MENUS=0 EXIT CASE (ID_NODE) MENUS=2 EXIT CASE (ID_ELTS) MENUS=1 EXIT CASE (ID_ORDR) MENUS=3 EXIT CASE (ID_CCLN) MENUS=6 EXIT CASE (ID_CSEC) MENUS=7 EXIT CASE (ID_ZOOM) MENUS=8 EXIT CASE (ID_DRAW) MENUS=9 EXIT CASE (ID_HELP1) call helps(0) go to 100 CASE (ID_HELP2) call RMINFO go to 100 CASE (ID_ITEM20) CALL GDIST CYCLE CASE (ID_ITEM22) CALL SELNODE(0) CYCLE CASE (ID_ALLNODES) CALL SELNODE(1) CYCLE CASE (ID_UNUSNODES) CALL SELNODE(2) CYCLE CASE (ID_ITEM23) CALL SELELT(0) CYCLE END SELECT CASE (PushButton) ! Dialog button pressed IDBUTN = MESSAGE%VALUE1 IDFIELD = MESSAGE%VALUE2 CASE (MouseButDown,MouseButUp) ! Mouse button down/up MBUTTON = MESSAGE%VALUE1 ITIME = MESSAGE%VALUE2 MOUSEX = MESSAGE%X MOUSEY = MESSAGE%Y CASE (MouseMove) ! Mouse moved ITIME = MESSAGE%VALUE2 MOUSEX = MESSAGE%X MOUSEY = MESSAGE%Y CASE (Expose) ! Window partly/wholly exposed IX = MESSAGE%X IY = MESSAGE%Y IWIDTH = MESSAGE%VALUE1 IHEIGHT = MESSAGE%VALUE2 CASE (Resize) ! Window resized IWIDTH = MESSAGE%VALUE1 IHEIGHT = MESSAGE%VALUE2 CASE (CloseRequest) ! Close window (e.g. Alt/F4) IWINDOW = MESSAGE%WIN call rquit(iyes) if(iyes .ne. 1) go to 100 menus=0 exit ! IF (IWINDOW.EQ.0) EXIT ! Root window : exit program ! CALL WindowCloseChild(IWINDOW) CASE (FieldChanged) ! Field change in modeless dialog IDFIELDOLD = MESSAGE%VALUE1 IDFIELDNEW = MESSAGE%VALUE2 END SELECT END DO 500 continue IF(MENUS .NE. 0) THEN CALL RMAGEN(MENUS,IMP,IIN,0,IOT,IOT1,IGFG,ITRIAN,N2,M2) ENDIF close(90) CALL WindowClose ! Remove program window stop !! CALL WindowClose ! Remove program window END PROGRAM NEWRMAGEN SUBROUTINE GETSUB(FNAME,SUB) CHARACTER(LEN=255) :: FNAME CHARACTER(LEN=3) :: SUB INTEGER ,EXTERNAL :: LENSTR INTEGER :: LNNAM,K LNNAM=LENSTR(FNAME) SUB=' ' DO K=LNNAM,1,-1 IF(FNAME(K:K) .EQ. '.') THEN IF(LNNAM .GT. K+2) THEN SUB=FNAME(K+1:K+3) ELSE SUB=' ' ENDIF GO TO 110 ENDIF ENDDO 110 CONTINUE RETURN END SUBROUTINE ADDSUB(FNAME,SUB) CHARACTER(LEN=255) :: FNAME CHARACTER(LEN=*) :: SUB INTEGER ,EXTERNAL :: LENSTR INTEGER :: LNNAM,K,LMPNAM LNNAM=LENSTR(FNAME) DO K=LNNAM,1,-1 IF(FNAME(K:K) .EQ. '.') THEN lmpnam=k FNAME=FNAME(1:LMPNAM)//SUB GO TO 110 ENDIF ENDDO FNAME=FNAME(1:LNNAM)//'.'//SUB 110 CONTINUE RETURN END SUBROUTINE SHORTNAME(FNAMELL,FNAMES) CHARACTER(LEN=255) :: FNAMELL CHARACTER(LEN=48) :: FNAMES INTEGER ,EXTERNAL :: LENSTR INTEGER :: LNNAM,K,KSTART,KEND LNNAM=LENSTR(FNAMELL) DO K=1,48 FNAMES(K:K)=' ' ENDDO KSTART=1 DO K=LNNAM,1,-1 IF(FNAMELL(K:K) .EQ. '\') THEN KSTART=K+1 GO TO 200 ENDIF ENDDO 200 KEND=LNNAM-KSTART+1 IF(KEND .GT. 48) KEND=48 FNAMES(1:KEND)=FNAMELL(KSTART:KSTART+KEND-1) RETURN END