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.
2114 lines
63 KiB
Fortran
2114 lines
63 KiB
Fortran
5 years ago
|
!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
|