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.F90

959 lines
31 KiB
Fortran
Raw Blame History

!IPK LAST UPDATE JUN 15 2020 FIXUP TO READ OLD FORMAT GEO
!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/ iw,ih,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
!IPK JUN20 ALLOOW FOR OLD FORMAT GEO
IF(HEADR(1:6) .NE. 'RMAGEN') THEN
CLOSE (IIN)
OPEN(IIN ,FILE=FNAME,STATUS='OLD',form='unformatted',ACTION='READ')
ENDIF
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 files -- *.map, *.grd |*.map;*.grd|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