iank
/
RMAGEN84
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
master
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from '601f33fc45'
${ noResults }
RMAGEN84/SRC84/NEWRMGN-demo.F90

949 lines
31 KiB
Fortran
Raw Blame History

!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
Reference in New Issue View Git Blame Copy Permalink