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.
733 lines
16 KiB
Fortran
733 lines
16 KiB
Fortran
!IPK LAST UPDATE SEP 23 2015 ADD TESTING FOR CHNAGED ELEMENTS/NODES OR REORDERING
|
|
! Last change: IPK 13 Jan 98 10:01 am
|
|
!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
|
SUBROUTINE RMAGEN(MENUS,N1,N2,N3,N4,N5,N6,N7,N8,N9)
|
|
!
|
|
!
|
|
!
|
|
! RMAGEN Version 4.2
|
|
!
|
|
! Release date Jan 13 1998
|
|
!
|
|
!
|
|
! Changes in this version include:
|
|
! (1) Revisions to operate in a graphical mode, reducing the amount of
|
|
! DOS screen input.
|
|
! (2) Addition of options for both the node move operation and refine
|
|
! options to allow the user to stop preservation or automatic
|
|
! interpolation of bottom elevations from the corner node values.
|
|
! This option is a user setting. The default initial setting
|
|
! retains the value for the move operation and interpolaton during
|
|
! refinement.
|
|
! (3) Input of "geo" has been made more flexible. The model
|
|
! automatically detects binary files with and without headers. Note
|
|
! that this option is only relevant for PC versions.
|
|
! (4) The screen now displays compilation limits on startup.
|
|
!
|
|
!
|
|
! RMAGEN Version 4.1(a)
|
|
!
|
|
! Release date Nov 18 1997
|
|
!
|
|
!
|
|
!
|
|
! Changes in this version include:
|
|
! (1) Revised interpolation scheme for computing bottom elevations from
|
|
! map file data.
|
|
! (2) More consistent backup
|
|
! (3) Addition of option to split triangles when refining
|
|
!
|
|
! RMAGEN Version 4.1
|
|
!
|
|
! Release date Oct 19 1996
|
|
|
|
! Changes in this version include:
|
|
! (1) New options that allow selective drawing of maps in different
|
|
! colours
|
|
! (2) An option that allows construction of continuity lines from the
|
|
! map screen
|
|
|
|
! RMAGEN Version 3.3
|
|
|
|
! Release date April 1 1994
|
|
|
|
! Changes in this version include:
|
|
! (1) Incorporation of the ability to record and play scripts.
|
|
! (2) Correction to correctly operate in the top half inch of the network
|
|
|
|
! RMAGEN Version 3.2
|
|
|
|
! Release date March 1 1994
|
|
|
|
! Changes in this version include:
|
|
! (1) Modification to the save options to enter a menu of save choices.
|
|
! (2) Addition of the capability to save a binary version of the map file.
|
|
! (3) Correction to the "backup file" to make it work consistently.
|
|
! (4) Changes to the algorithm of the bottom elevation generation routine
|
|
! to improve reliability.
|
|
! (5) Removal of an implied limitation of 32000 lines for the map file by
|
|
! deleting some INTEGER*2 variable to INTEGER*4.
|
|
|
|
! RMAGEN Version 3.1(a)
|
|
|
|
! Release date Aug 1 1993
|
|
|
|
! Changes in this version include:
|
|
! (1) Correction to colurs that make them more readable.
|
|
! (2) Additions to the SELECT options that permit more flexible choice
|
|
! of elements.
|
|
|
|
! RMAGEN Version 3.1
|
|
|
|
! Release date March 1 1993
|
|
|
|
! Changes in this version include:
|
|
! (1) Correction in fill operation to ensure correct fill when there are
|
|
! a number of gaps in the nodal sequence.
|
|
! (2) Additions to the NODE-DELETE options that permit more flexible
|
|
! deletion options such as all mid-side nodes, all exact mid-side
|
|
! location nodes or all unused nodes. The fill option has added
|
|
! flexibility.
|
|
|
|
|
|
! Version 3.0(c) August 1 1992
|
|
|
|
! Changes in this version include:
|
|
! (1) Revisions to incorporate REGIS graphics capability
|
|
! (2) Block of routines available to use DEC 340 REGIS graphics
|
|
! terminal with unix system
|
|
|
|
|
|
! Version 3.0(b) May 20 1992
|
|
|
|
! Changes in this version include:
|
|
! (1) Renaming of all colours for compatibility with Silicon Graphics
|
|
! (2) Modification of nodal delete so that when a mid-side node is
|
|
! selected for deletion it is removed and the associated reference
|
|
! in the element is set to zero. The element is no longer deleted.
|
|
! (3) Cleanup of array subscripts in SUBROUTINE HEDRC
|
|
|
|
! Version 3.0(a) April 1992
|
|
|
|
! Changes to a number of routines to correct minor errors
|
|
! and nuisances.
|
|
|
|
! Version 3.0 January 1992
|
|
|
|
! This version revises the naming of input and output files.
|
|
! Output files may be generated in ASCII or BINARY form.
|
|
! The binary file is designed to bypass RMA-1.
|
|
! This file optionally may contain element reordering numbers
|
|
! New capabilities include:
|
|
! (1) Automatic filling of zero's in element connection arrays.
|
|
! (2) Input of reordering sequences and executing the reordering
|
|
! process.
|
|
|
|
|
|
USE BLKMAP
|
|
USE BLK1MOD
|
|
! INCLUDE 'BLK1.COM'
|
|
|
|
INCLUDE 'BFILES.I90'
|
|
|
|
|
|
INCLUDE 'TXFRM.COM'
|
|
!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL
|
|
|
|
!ipk oct96
|
|
character*64 fnams
|
|
character*25 mesg
|
|
CHARACTER*1 ANS,ANSW(0:9),ansx(0:9)
|
|
DATA ANSW/'e','n','o','h','s','l','t','z','r','q'/
|
|
data ansx/'s','b','m','p',2*' ','h','z','r','q'/
|
|
|
|
DATA IFIRST / 1 /
|
|
|
|
IF(N3 .EQ. 1) GO TO 101
|
|
|
|
IGUNIT=0
|
|
ISWTAGN=0
|
|
ISWTINTP=0
|
|
WIDSCL=1.0
|
|
WIDEL=0.0
|
|
IPW1=1
|
|
IMP=N1
|
|
IIN=N2
|
|
IOT=N4
|
|
IOT1=N5
|
|
IGFG=N6
|
|
ITRIAN=N7
|
|
!ipk jul98
|
|
LCROSS=.FALSE.
|
|
ICRS=0
|
|
DFACTOR=50.
|
|
ZREF=5.
|
|
|
|
!iPK JAN98
|
|
IDELV=0
|
|
IRESTT=0
|
|
1 CONTINUE
|
|
IFIRST=1
|
|
IECHG=0
|
|
NELAST=1
|
|
NPLAST=1
|
|
NLST=0
|
|
NENTRY=0
|
|
TXSCAL = 1.
|
|
XS=0.
|
|
YS=0.
|
|
VDX = - 1.0E+10
|
|
VOID = - 1.0E+20
|
|
|
|
IPSW(1)=0
|
|
IPSW(2)=0
|
|
IPSW(3)=0
|
|
IPSW(4)=1
|
|
IPSW(5)=0
|
|
IPSW(6)=0
|
|
IPSW(7)=0
|
|
IPSW(8)=0
|
|
IPSW(9)=0
|
|
IPSW(12)=0
|
|
! IF(N8 .GT. 100000) THEN
|
|
! IPSW(2)=1
|
|
! IPSW(4)=0
|
|
! ENDIF
|
|
MAXPTS=MAXPL
|
|
!ipk jan98
|
|
call file(1)
|
|
|
|
|
|
write(90,*) 'rmagen',iot,iot1
|
|
|
|
! Initialize plot
|
|
|
|
!! CALL GINIT
|
|
|
|
! Startup files
|
|
WRITE(MESG,6010)
|
|
6010 FORMAT(' Going to initialisation ')
|
|
CALL SYMBL(1.1,6.3,0.15,mesg,0.0,25)
|
|
|
|
CALL FILE(2)
|
|
|
|
WRITE(MESG,6011)
|
|
6011 FORMAT(' Back from initialisation')
|
|
CALL SYMBL(1.1,5.3,0.15,mesg,0.0,25)
|
|
|
|
IF(MENUS .EQ. -1) CALL DEMOS
|
|
|
|
IF(IIN .EQ. 0) IPSW(1)=1
|
|
|
|
! Initialize plot
|
|
|
|
!ipk jan98 CALL GINIT
|
|
|
|
IF(IMP .GT. 0) THEN
|
|
|
|
! Read map file
|
|
WRITE(90,*) 'GOING TO READ MAP'
|
|
CALL RDMAP(0,0,0,0)
|
|
IF (IFIRST .EQ. 1) THEN
|
|
|
|
! Find max and min
|
|
|
|
XMIN = 1.E+20
|
|
XMAX = -XMIN
|
|
YMIN = 1.E+20
|
|
YMAX = -YMIN
|
|
|
|
DO 8 J=1,MAXPTS
|
|
IF (CMAP(J,1) .LT. VDX) GOTO 8
|
|
IF (CMAP(J,1) .LT. XMIN) XMIN = CMAP(J,1)
|
|
IF (CMAP(J,1) .GT. XMAX) XMAX = CMAP(J,1)
|
|
IF (CMAP(J,2) .LT. YMIN) YMIN = CMAP(J,2)
|
|
IF (CMAP(J,2) .GT. YMAX) YMAX = CMAP(J,2)
|
|
8 CONTINUE
|
|
9 CONTINUE
|
|
ENDIF
|
|
ENDIF
|
|
|
|
! Read in header lines
|
|
|
|
ISET=1
|
|
WRITE(90,*) 'GOING TO HEADIN'
|
|
CALL HEADIN(IIN,ISET)
|
|
|
|
! Read in existing elements
|
|
WRITE(90,*) 'GOING TO RDELEM'
|
|
call second(timc)
|
|
CALL RDELEM(IIN)
|
|
call second(timd)
|
|
write(90,*) 'time in element read',timd-timc
|
|
! Read in nodal coordinates
|
|
|
|
WRITE(90,*) 'GOING TO RDCORD'
|
|
CALL RDCORD(IIN)
|
|
call second(timee)
|
|
write(90,*) 'time in node read',timee-timd
|
|
|
|
WRITE(90,*) 'RMAGEN-243 NCLM',NCLM
|
|
|
|
|
|
!ipk may03
|
|
ichg=1
|
|
|
|
! Close input file
|
|
|
|
if(iin .ne. 0) then
|
|
CLOSE(IIN)
|
|
endif
|
|
|
|
! Scale for plotting
|
|
|
|
IF (IFIRST .EQ. 1) THEN
|
|
IF (IMP .EQ. 0) THEN
|
|
XMIN = 1.E+20
|
|
XMAX = -XMIN
|
|
YMIN = 1.E+20
|
|
YMAX = -YMIN
|
|
ENDIF
|
|
|
|
! do j=1,ne
|
|
! if(nop(j,1) .eq. 0) cycle
|
|
! do k=1,8,2
|
|
! if(nop(j,k) .eq. 0) cycle
|
|
! if(wd(nop(j,k)) .gt. 27.) go to 7110
|
|
! if(wd(nop(j,k)) .lt. 22.) go to 7111
|
|
|
|
! enddo
|
|
!7110 continue
|
|
! imat(j)=0
|
|
! IESKP(J)=1
|
|
! DO K=1,8
|
|
! NOP(J,K)=0
|
|
! ENDDO
|
|
!7111 continue
|
|
! enddo
|
|
|
|
|
|
IF(NP .GT. 0) THEN
|
|
DO 10 J=1,NP
|
|
IF (CORD(J,1) .LT. VDX) GOTO 10
|
|
IF (CORD(J,1) .LT. XMIN) XMIN = CORD(J,1)
|
|
IF (CORD(J,1) .GT. XMAX) XMAX = CORD(J,1)
|
|
IF (CORD(J,2) .LT. YMIN) YMIN = CORD(J,2)
|
|
IF (CORD(J,2) .GT. YMAX) YMAX = CORD(J,2)
|
|
10 CONTINUE
|
|
ENDIF
|
|
|
|
! Check for background limits
|
|
WRITE(90,*) 'NBKFL',NBKFL
|
|
IF(NBKFL .GT. 0) THEN
|
|
DO I=1,NBKFL
|
|
IF(BFMINMAX(I,1) .LT. XMIN) XMIN=BFMINMAX(I,1)
|
|
IF(BFMINMAX(I,2) .LT. YMIN) YMIN=BFMINMAX(I,2)
|
|
IF(BFMINMAX(I,3) .GT. XMAX) XMAX=BFMINMAX(I,3)
|
|
IF(BFMINMAX(I,4) .GT. YMAX) YMAX=BFMINMAX(I,4)
|
|
WRITE(90,*) 'XX',XMIN,XMAX,YMIN,YMAX
|
|
WRITE(90,*) 'BFMIN',(BFMINMAX(I,K4),K4=1,4)
|
|
ENDDO
|
|
ENDIF
|
|
|
|
!rrr
|
|
WRITE(90,*) 'GOING TO PGRID'
|
|
CALL PGRID
|
|
|
|
AMAP=(XMAX-XMIN)*(YMAX-YMIN)
|
|
XSCALE = (XMAX-XMIN)/(hsize-0.5)
|
|
YSCALE = (YMAX-YMIN)/6.5
|
|
PSCALE = MAX(XSCALE,YSCALE)
|
|
|
|
XAVE = (XMIN + XMAX) /2.0
|
|
YAVE = (YMIN + YMAX) /2.0
|
|
XMIN = XAVE - hsize/2.*PSCALE
|
|
YMIN = YAVE - 3.5*PSCALE
|
|
XMAX = XAVE + (hsize-0.5)/2.*PSCALE
|
|
YMAX = YAVE + 3.25*PSCALE
|
|
! YMIN = YMIN - .01*PSCALE
|
|
! XMIN = XMIN - .01*PSCALE
|
|
|
|
! Reset values if STARTUP.DAT file is used
|
|
|
|
IF(IS11 .GT. 0) THEN
|
|
READ(IS11,5200) XS,YS,PSCALE
|
|
5200 FORMAT(3F15.0)
|
|
XMIN=-XS
|
|
YMIN=-YS
|
|
ENDIF
|
|
|
|
IFIRST = 0
|
|
|
|
ENDIF
|
|
|
|
! Plot all data
|
|
|
|
CALL PLOTSV(0)
|
|
!ipk nov97 add (1)
|
|
CALL PLOTOT(1)
|
|
GO TO 101
|
|
|
|
! Top of loop ********************************
|
|
|
|
100 CONTINUE
|
|
101 CONTINUE
|
|
if(menus .gt. 9) go to 25
|
|
IF(MENUS .GT. 0) THEN
|
|
ANS=ANSW(MENUS-1)
|
|
MENUS=0
|
|
GO TO 130
|
|
ENDIF
|
|
|
|
! List options
|
|
|
|
25 CONTINUE
|
|
|
|
! Draw box around selections
|
|
|
|
IF(MENUS .EQ. -3) THEN
|
|
CALL PLOTOT(0)
|
|
MENUS=-2
|
|
ENDIF
|
|
NHTP=1
|
|
NMESS=0
|
|
NBRR=0
|
|
CALL HEDR
|
|
! Get answer
|
|
|
|
call xyloc(XPT,YPT,ANS,IBOX)
|
|
IF(IRMAIN .EQ. 1) THEN
|
|
!ipk may94 add line
|
|
CALL RESCAL
|
|
IRMAIN=0
|
|
GO TO 100
|
|
ENDIF
|
|
IF(ANS .EQ. 'c') THEN
|
|
I=IBOX-1
|
|
if(i .lt. 0) go to 25
|
|
ANS=ANSW(I)
|
|
ENDIF
|
|
|
|
130 CONTINUE
|
|
|
|
! Add elements
|
|
|
|
IF (ANS .EQ. 'e') THEN
|
|
CALL ELTS
|
|
IF(IRMAIN .EQ. 1) THEN
|
|
!ipk may94 add line
|
|
CALL RESCAL
|
|
IRMAIN=0
|
|
GO TO 100
|
|
ENDIF
|
|
|
|
! Go to help facility
|
|
|
|
ELSEIF (ANS .EQ. 'h') THEN
|
|
CALL HELPS(1)
|
|
IF(IRMAIN .EQ. 1) THEN
|
|
!ipk may94 add line
|
|
CALL RESCAL
|
|
IRMAIN=0
|
|
GO TO 100
|
|
ENDIF
|
|
|
|
! Process nodes
|
|
|
|
ELSEIF (ANS .EQ. 'n') THEN
|
|
CALL ADDNOD
|
|
!ipk feb94 call for backup
|
|
CALL WRTOUT(0)
|
|
IF(IRMAIN .EQ. 1) THEN
|
|
!ipk may94 add line
|
|
CALL RESCAL
|
|
IRMAIN=0
|
|
GO TO 100
|
|
ENDIF
|
|
|
|
! Add element reordering sequence
|
|
|
|
ELSEIF (ANS .EQ. 'o') THEN
|
|
|
|
! Draw box around selections
|
|
|
|
140 CONTINUE
|
|
NHTP=3
|
|
NMESS=0
|
|
NBRR=0
|
|
CALL PLOTORDS
|
|
|
|
CALL HEDR
|
|
|
|
! Get answer
|
|
|
|
call xyloc(XPT,YPT,ANS,IBOX)
|
|
CALL PLOTORDS
|
|
IF(IRMAIN .EQ. 1) THEN
|
|
!ipk may94 add line
|
|
CALL RESCAL
|
|
IRMAIN=0
|
|
GO TO 100
|
|
ENDIF
|
|
IF(ANS .EQ. 'c') THEN
|
|
I=IBOX-1
|
|
ELSE
|
|
IF(ANS .EQ. 'l') THEN
|
|
|
|
! Process current list including baseine order
|
|
|
|
I=0
|
|
ELSEIF(ANS .EQ. 'g') THEN
|
|
|
|
! Add another order to the list
|
|
|
|
I=1
|
|
ELSEIF(ANS .EQ. 'p') THEN
|
|
|
|
! Process the latest addition to the list
|
|
|
|
I=2
|
|
ELSEIF(ANS .EQ. 'o') THEN
|
|
I=3
|
|
ELSEIF(ANS .EQ. 't') THEN
|
|
I=4
|
|
ELSEIF(ANS .EQ. 'h') THEN
|
|
I=5
|
|
ELSEIF(ANS .EQ. 'z') THEN
|
|
I=7
|
|
ELSEIF(ANS .EQ. 'r') THEN
|
|
I=8
|
|
ELSEIF(ANS .EQ. 'q') THEN
|
|
I=9
|
|
ENDIF
|
|
ENDIF
|
|
IF(I .LT. 3) THEN
|
|
|
|
CALL ADDORD(I)
|
|
IF(IRMAIN .EQ. 1) THEN
|
|
!ipk may94 add line
|
|
CALL RESCAL
|
|
IRMAIN=0
|
|
GO TO 100
|
|
ENDIF
|
|
GO TO 140
|
|
ELSEIF(I .gt. 2 .and. I .lt. 5) THEN
|
|
!
|
|
! compact elements and nodes
|
|
!
|
|
call compact(i)
|
|
go to 100
|
|
|
|
ELSEIF(I .EQ. 5) THEN
|
|
|
|
! Get help screen
|
|
|
|
CALL HELPS(5)
|
|
IF(IRMAIN .EQ. 1) THEN
|
|
!ipk may94 add line
|
|
CALL RESCAL
|
|
IRMAIN=0
|
|
GO TO 100
|
|
ENDIF
|
|
|
|
ELSEIF(I .EQ. 9) THEN
|
|
|
|
! Return to main menu
|
|
|
|
GO TO 100
|
|
|
|
ELSE
|
|
|
|
! Return to try for character again
|
|
|
|
GO TO 140
|
|
ENDIF
|
|
GO TO 140
|
|
|
|
! ENDIF
|
|
!ipk oct96 add continuity lines
|
|
|
|
ELSEIF (ANS .EQ. 'l') THEN
|
|
CALL CCLINE(1)
|
|
IF(IRMAIN .EQ. 1) THEN
|
|
!ipk may94 add line
|
|
CALL RESCAL
|
|
IRMAIN=0
|
|
GO TO 100
|
|
ENDIF
|
|
|
|
!ycw mar97 add cross section
|
|
|
|
ELSEIF (ANS .EQ. 't') THEN
|
|
CALL CRSECT
|
|
IF(IRMAIN .EQ. 1) THEN
|
|
CALL RESCAL
|
|
IRMAIN=0
|
|
GO TO 100
|
|
ENDIF
|
|
!ycw
|
|
ELSEIF (ANS .EQ. 'r') THEN
|
|
! Save display parameters
|
|
|
|
n1=nhtp
|
|
n2=nmess
|
|
n3=nbrr
|
|
CALL RDRW(0)
|
|
if(irmain .eq. 1) return
|
|
|
|
! Restore display parameters
|
|
|
|
nhtp=n1
|
|
nmess=n2
|
|
nbrr=n3
|
|
|
|
ELSEIF (ANS .EQ. 's') THEN
|
|
|
|
! Save files
|
|
|
|
|
|
! Draw box around selections
|
|
|
|
210 NHTP=11
|
|
NMESS=0
|
|
NBRR=0
|
|
CALL HEDR
|
|
|
|
! Get answer
|
|
|
|
call xyloc(XPT,YPT,ANS,IBOX)
|
|
IF(IRMAIN .EQ. 1) THEN
|
|
!ipk may94 add line
|
|
CALL RESCAL
|
|
IRMAIN=0
|
|
GO TO 100
|
|
ENDIF
|
|
IF(ANS .EQ. 'c') THEN
|
|
if(ibox .le. 0) go to 210
|
|
I=IBOX-1
|
|
ANS=ANSX(I)
|
|
ENDIF
|
|
|
|
! Save plot file
|
|
|
|
IF (ANS .EQ. 'p') THEN
|
|
|
|
CALL PLOTSV(1)
|
|
!ipk nov97 add(1)
|
|
CALL PLOTOT(1)
|
|
CALL NDPLSV
|
|
|
|
ELSEIF (ANS .EQ. 'b') THEN
|
|
|
|
! Save file in binary form
|
|
|
|
CALL WRTOUT(2)
|
|
|
|
ELSEIF (ANS .EQ. 'm') THEN
|
|
|
|
! Save map file
|
|
|
|
CALL WRTMAP(0)
|
|
|
|
ELSEIF (ANS .EQ. 's') THEN
|
|
|
|
! Save file
|
|
|
|
CALL WRTOUT(1)
|
|
|
|
! Go to help facility
|
|
|
|
ELSEIF (ANS .EQ. 'h') THEN
|
|
CALL HELPS(8)
|
|
IF(IRMAIN .EQ. 1) THEN
|
|
!ipk may94 add line
|
|
CALL RESCAL
|
|
IRMAIN=0
|
|
GO TO 100
|
|
ENDIF
|
|
ELSEIF (ANS .EQ. 'q') THEN
|
|
GO TO 100
|
|
ENDIF
|
|
GO TO 210
|
|
|
|
|
|
ELSEIF (ANS .EQ. 'q') THEN
|
|
|
|
! Quit program after checking
|
|
|
|
|
|
CALL RQUIT(IYES)
|
|
IF(IYES .EQ. 1) THEN
|
|
CALL Quit_Pgm
|
|
STOP
|
|
!!SEP02 CALL CLSCRN
|
|
!!SEP02 CALL SETD(23)
|
|
!ipk oct96 move to screen output
|
|
|
|
!!SEP02 WRITE(FNAMS,*) 'Do you really want to quit? (y) or (n)'
|
|
!!SEP02 CALL SYMBL(1.,7.20,0.20,FNAMS,0.,38)
|
|
!!SEP02 ndig=1
|
|
!!SEP02 call gtcharx(ans,ndig,6.,7.2)
|
|
!ipk oct96 READ(*,'(A)') ANS
|
|
!!SEP02 IF(ANS .EQ. 'y' .OR. ANS .EQ. 'Y') THEN
|
|
!!SEP02 CALL Quit_Pgm
|
|
!!SEP02 STOP
|
|
!!SEP02 ELSE
|
|
!!SEP02 WRITE(FNAMS,*)'Do you want to restart? (y) or (n)'
|
|
!!SEP02 CALL SYMBL(1.,6.20,0.20,FNAMS,0.,34)
|
|
!!SEP02 ndig=1
|
|
!!SEP02 call gtcharx(ans,ndig,6.,7.2)
|
|
!ipk oct96 READ(*,'(A)') ANS
|
|
!!SEP02 IF(ANS .EQ. 'y' .OR. ANS .EQ. 'Y') THEN
|
|
!!SEP02 IRESTT=1
|
|
!!SEP02 GO TO 1
|
|
!!SEP02 ENDIF
|
|
!!SEP02 CALL SETD(2)
|
|
ENDIF
|
|
|
|
ENDIF
|
|
|
|
GOTO 100
|
|
|
|
END
|
|
|
|
|
|
SUBROUTINE RQUIT(IYES)
|
|
|
|
USE WINTERACTER
|
|
|
|
INCLUDE 'BFILES.I90'
|
|
|
|
INCLUDE 'D.INC'
|
|
|
|
IF(IRDONE .NE. 0) THEN
|
|
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you really wish to quit?'//&
|
|
CHAR(13)//' ','Quit option')
|
|
ELSE
|
|
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'You have not reordered'//Char(13)//'Do you really wish to quit?'//&
|
|
CHAR(13)//' ','Quit option')
|
|
ENDIF
|
|
!
|
|
! If answer 'No', return
|
|
!
|
|
iyes=1
|
|
IF (WInfoDialog(4).EQ.2) iyes=0
|
|
return
|
|
end
|
|
|
|
SUBROUTINE SECOND(TA)
|
|
SAVE
|
|
!C This version is for microsoft fortran
|
|
DATA ITIM/0/
|
|
|
|
CALL GETTIM(IHR,IMIN,ISEC,IHUN)
|
|
TA=3600.*IHR+60.*IMIN+ISEC+ FLOAT(IHUN)/100.
|
|
IF(ITIM .EQ. 0) THEN
|
|
TOLD=TA
|
|
ITIM=1
|
|
ENDIF
|
|
TA=TA-TOLD
|
|
RETURN
|
|
END
|
|
|