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.
335 lines
11 KiB
Fortran
335 lines
11 KiB
Fortran
5 years ago
|
!IPk last updated July 15 1998
|
||
|
|
!IPk last updated Nov 18 1997
|
||
|
|
!IPk last updated Oct 31 1996 fix bug in map option
|
||
|
|
!IPK LAST UPDATED OCT 16 1996
|
||
|
|
!IPk last updated Oct 14 1996
|
||
|
|
!IPk last updated Oct 25 1995
|
||
|
|
SUBROUTINE HEDR
|
||
|
|
SAVE
|
||
|
|
|
||
|
|
! Routine to draw NSIZ header boxes at top of page with the HEAD label
|
||
|
|
|
||
|
|
CHARACTER*80 TITLE
|
||
|
|
CHARACTER*24 HLABL
|
||
|
|
CHARACTER*1 ALABL(10)
|
||
|
|
CHARACTER*40 MPDUM
|
||
|
|
|
||
|
|
COMMON /SSIZE/ HSIZE
|
||
|
|
|
||
|
|
COMMON /BLKA1/ TITLE,HLABL,ALABL,MPDUM
|
||
|
|
|
||
|
|
!IPk oct 95 lines defining MPDUM added
|
||
|
|
!ipk jan01 Expand IPSW to 10
|
||
|
|
COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout
|
||
|
|
!IPk feb94 HEAD array and NHEDL enlarged
|
||
|
|
!IPk oct96 HEAD AND NHEDL MESS, ENLARGED
|
||
|
|
|
||
|
|
common /cols/ ibakk,icolr,iblkk
|
||
|
|
|
||
|
|
CHARACTER*8 HED(10),HEAD(10,16)
|
||
|
|
CHARACTER*47 MESOUT,MESS(48)
|
||
|
|
!ipk lan01 add to MESS
|
||
|
|
!ipk jan99 add to MESS
|
||
|
|
!ycw mar97 change HEADR(5,5) to HEADR(6,7)
|
||
|
|
!ipk add extra headr
|
||
|
|
CHARACTER*8 HEADR(6,10)
|
||
|
|
DIMENSION NHEDL(16)
|
||
|
|
DIMENSION X(5),Y(5),IRV(10)
|
||
|
|
!IPk feb 94 this statement reconstructed
|
||
|
|
!IPK OCT 96 THIS STATMENT DONE AGAIN
|
||
|
|
DATA HEAD/ ' (e)lts ','(n)odes ','(o)rder ',' (h)elp ',' ',&
|
||
|
|
'cc(l)ine',' csec(t)',' (z)oom ',' (r)draw',' (q)uit ','(n)od bk',& !1/2
|
||
|
|
' (e)l bk',&
|
||
|
|
're(f)ine','spli(t) ','c(l)ean ',5*' ','pr(l)st ','get(g)rp'& ! 2/3
|
||
|
|
,'(p)rgrp ','c(o)ptnd','cop(t)el',' (h)elp ',' ',' (z)oom ',' (r)draw',' (q)uit'& !3
|
||
|
|
,' (a)dd ',' (m)ove ',' (d)el ',' (f)ind ',' (g)line',' (e)lev '& !4
|
||
|
|
,' (h)elp ',' (z)oom ',' (r)draw',' (q)uit ',' (m)ap ',' (o)utln'& !4/5
|
||
|
|
,' (e)lts ','(n)odes ',' ne(t)w ',' t(y)pe ','cc(l)ine',' (d)ata '& !5
|
||
|
|
,'(b)elev ',' d(r)aw ',' (s)el ',' (j)oin ',' (f)ind ',' (g)blok'& !5/6
|
||
|
|
,' (t)ype ',' f(i)ll ',' (h)elp ',' (z)oom ',' (r)draw',' (q)uit '& !6
|
||
|
|
,' (d)el ','r(e)fin ',' (n)umb ',' (a)ll ','rectn(g)','(t)riang'& !7
|
||
|
|
,' (h)elp ',' (z)oom ',' (r)draw',' (q)uit ',' (f)our ','two(l)g '& !7/8
|
||
|
|
,'two(s)h ','spli(t) ','re(v)rs ','clea(n) ',' ','s(m)plfy',' ',' (q)uit '& !8
|
||
|
|
,'(m)an/el','(a)ll/el','(f)il/el','(s)in/el',' loc(k) ','(u)nlock'& !9
|
||
|
|
,'(t)hree ','man/(w)d',' (h)elp ','(q)uit ','al(l)mid','cen(m)id'& !9/10
|
||
|
|
,'sin(g)le','un(u)sed',' (f)ill ',' (j)oin ',' (h)elp ',' (z)oom '& !0
|
||
|
|
,' (r)draw',' (q)uit ','a(s)ave ','(b)save ','(m)save ',' (p)save'& !10/11
|
||
|
|
,2*' ',' (h)elp ',' (z)oom ',' (r)draw',' (q)uit ',' z(e)ro '& !11/12
|
||
|
|
,' (o)ne ',' (t)wo ','t(h)ree ',' (f)our ',' f(i)ve ',' (s)ix '& !12
|
||
|
|
,' se(v)en',' ei(g)ht',' (q)uit ',' (w)idth',' ss(1) ',' ss(2) '& !12/13
|
||
|
|
,'strw(d) ','str(e)lv','str(s)lp',' (b)s1 ',' (z)oom ',' (r)draw'& !13
|
||
|
|
,' (q)uit ','(d)elete','s(e)t999','se(t)elv','set(l)ay',' loc(k) ','(u)nlock','(f)orm-t',' (z)oom ',' (r)draw'& !13/14
|
||
|
|
,' (q)uit ','(d)elete','r(e)fin ','se(t)yp ','s(m)plfy','form(g)p','elev und',' ',' (z)oom ',' (r)draw'& !14/15
|
||
|
|
,' (q)uit ','(m)an/el','(a)ll/el','(f)il/el',' ',' ',' '& !15/16
|
||
|
|
,' ',' ',' (h)elp ','(q)uit '/
|
||
|
|
|
||
|
|
|
||
|
|
!IPk apr95 changed structure of messages added 3 more entries
|
||
|
|
|
||
|
|
|
||
|
|
DATA MESS /'Enter node to search for',' Enter material type',& ! 1,2
|
||
|
|
'Enter element to search for ',& ! 3
|
||
|
|
'Enter numbr of layers ',& ! 4
|
||
|
|
'Enter width ',& ! 5
|
||
|
|
'Click mouse at end of line ',& ! 6
|
||
|
|
'Enter nmbr of nodes in line ',& ! 7
|
||
|
|
'Click at corners of block ',& ! 8
|
||
|
|
'Enter nmbr of elts in x-dir ',& ! 9
|
||
|
|
'Enter nmbr of elts in y-dir ',& ! 10
|
||
|
|
'Click to move boundaries or (q)uit to save ',& ! 11
|
||
|
|
'Click on elements', 'Enter starting list number ',& ! 12,13
|
||
|
|
'Enter bottom elevation', 'Click on node ',& ! 14,15
|
||
|
|
'Click location of new node', 'Click at node to move ',&! 16,17
|
||
|
|
'Click at node to delete ',& ! 18
|
||
|
|
'Type 1 to use all nodes else type 0 ',& ! 19
|
||
|
|
'Enter element to select','Click location of node',& ! 20,21
|
||
|
|
'Enter ss1','Enter ss2','Enter strwid','Enter storage elevation',& ! 22,23,24,25
|
||
|
|
'Click mouse on node','click mouse on next node',& ! 26,27
|
||
|
|
'ERROR - Midside node selected - Select node again',& ! 28
|
||
|
|
'Plotting a selected cross section',& ! 29
|
||
|
|
'Click two locations to form a cross section',&! 30
|
||
|
|
'Click to adjust the cross section',& ! 31
|
||
|
|
'Compute cross section parameters',& ! 32
|
||
|
|
'Click a node for the cross section',& ! 33
|
||
|
|
|
||
|
|
'Click two locations to form the width','Click to adjust the line','Click two locations to form left slope',& ! 34 35 36
|
||
|
|
'Click two locations to form right slope','Click a location'& ! 37 38
|
||
|
|
,'Enter storage elevation','Enter storage slope',& ! 39 40
|
||
|
|
'Click at two locations to determine distance'& ! 41
|
||
|
|
,'Enter continuity line number use 0 to end','Click at location on image to define register point'& ! 42 43
|
||
|
|
,'Enter 1-d cross-section bed slope','Click at location to define outline point'& ! 44 45
|
||
|
|
,' ','Click two locations to define move'& ! 46 47
|
||
|
|
,'Click locations to form outline'/ ! 48
|
||
|
|
! last line Jan 2001
|
||
|
|
! line above added Jan 1999
|
||
|
|
DATA HEADR /&
|
||
|
|
' (q)uit ',5*' ',&
|
||
|
|
' (r)draw',' (q)uit ',4*' ',&
|
||
|
|
' (z)oom ',' (r)draw', ' (q)uit ',3*' ',&
|
||
|
|
' (n)ext ',' (z)oom ', ' (r)draw',' (q)uit ',2*' ',&
|
||
|
|
' (b)ack ',' cn(n)ect', ' (z)oom ',' (r)draw',' (q)uit ',' ',&
|
||
|
|
' (l)ine ',' (d)rawcs', ' (z)oom ',' (r)draw',' (q)uit ',' ',&
|
||
|
|
' (d)ist ',' (w)idth', ' (1)slop',' (2)slop',' b(e)lev',' (q)uit',&
|
||
|
|
' (d)el ',' (z)oom ', ' (r)draw',' (q)uit ',2*' ',&
|
||
|
|
' s(a)ve ',' (z)oom ', ' (r)draw',' (q)uit ',2*' ',&
|
||
|
|
' u(n)do ',' (c)ancl', ' (z)oom ',' (r)draw',' (q)uit ',1*' '/
|
||
|
|
DATA IRV/1 , 2 , 5 , 3 , 4 , 7 , 10 , 6 , 9, 5/
|
||
|
|
DATA NHEDL/10,5,10,10,10,10,10,10,10,10,10,10,10,10,10,10/
|
||
|
|
! DATA IBAKK/12/,ICOLR/11/
|
||
|
|
IF(NHTP .NE. 0) THEN
|
||
|
|
|
||
|
|
! Clear upper box area
|
||
|
|
|
||
|
|
CALL CLRBOX
|
||
|
|
|
||
|
|
! Copy appropriate heading for output
|
||
|
|
|
||
|
|
NSIZ=NHEDL(NHTP)
|
||
|
|
DO 120 N=1,NSIZ
|
||
|
|
HED(N)=HEAD(N,NHTP)
|
||
|
|
120 CONTINUE
|
||
|
|
|
||
|
|
! Draw box around selections with colour
|
||
|
|
!
|
||
|
|
Y(1)=7.5
|
||
|
|
Y(2)=7.5
|
||
|
|
Y(3)=7.995
|
||
|
|
Y(4)=7.995
|
||
|
|
Y(5)=7.5
|
||
|
|
XPT=0.
|
||
|
|
DO 150 I=1,NSIZ
|
||
|
|
X(1)=XPT
|
||
|
|
X(4)=XPT
|
||
|
|
X(5)=XPT
|
||
|
|
! XPT=XPT+1.0
|
||
|
|
XPT=XPT+HSIZE/10.
|
||
|
|
X(2)=XPT
|
||
|
|
X(3)=XPT
|
||
|
|
IF(I .EQ. 10) THEN
|
||
|
|
IBLK=IBAKK
|
||
|
|
!IPK OCT96 ADD COLOR OPTIONS
|
||
|
|
ELSEIF((NHTP .EQ. 5 .AND. IPSW(IRV(I)) .EQ. 1) .OR. &
|
||
|
|
(NHTP .EQ. 12 .AND. ICOLON(I) .EQ. 1)) THEN
|
||
|
|
IBLK=iblkk
|
||
|
|
ELSE
|
||
|
|
IBLK=IBAKK
|
||
|
|
ENDIF
|
||
|
|
CALL POLYFL(X,Y,5,IBLK)
|
||
|
|
CALL RBLACK
|
||
|
|
CALL PLOTT(X(1),Y(1),3)
|
||
|
|
CALL PLOTT(X(2),Y(2),2)
|
||
|
|
CALL PLOTT(X(3),Y(3),2)
|
||
|
|
CALL PLOTT(X(4),Y(4),2)
|
||
|
|
CALL PLOTT(X(1),Y(1),2)
|
||
|
|
150 CONTINUE
|
||
|
|
XSY=0.
|
||
|
|
YSY=7.65
|
||
|
|
DO 200 N=1,NSIZ
|
||
|
|
!ipk mar01
|
||
|
|
CALL SYMBL(XSY,YSY,0.20,HED(N),0.0, 8)
|
||
|
|
! XSY=XSY+1.0
|
||
|
|
XSY=XSY+HSIZE/10.
|
||
|
|
200 CONTINUE
|
||
|
|
ENDIF
|
||
|
|
IF(NMESS .GT. 0) THEN
|
||
|
|
|
||
|
|
! Clear upper box area
|
||
|
|
|
||
|
|
CALL CLRBOX
|
||
|
|
|
||
|
|
! Write out message
|
||
|
|
|
||
|
|
MESOUT=MESS(NMESS)
|
||
|
|
!ipk mar01
|
||
|
|
CALL SYMBL(0.,7.65,0.20,MESOUT,0.,47)
|
||
|
|
|
||
|
|
ENDIF
|
||
|
|
IF(NBRR .NE. 0) THEN
|
||
|
|
|
||
|
|
! Put box on right
|
||
|
|
|
||
|
|
! Draw box around selections
|
||
|
|
|
||
|
|
NBX=NBRR
|
||
|
|
if(NBX.gt.5) NBX=NBRR-1 !ycw mar97
|
||
|
|
IF(NBX .GT. 6) NBX=4
|
||
|
|
if(nbrr .eq. 10) NBX=5
|
||
|
|
! XLEFT=10-NBX
|
||
|
|
XLEFT=(10-NBX)*HSIZE/10.
|
||
|
|
DO 250 K=1,NBX
|
||
|
|
X(1)=XLEFT
|
||
|
|
X(4)=XLEFT
|
||
|
|
X(5)=XLEFT
|
||
|
|
! XLEFT=XLEFT+1.0
|
||
|
|
XLEFT=XLEFT+HSIZE/10.
|
||
|
|
X(2)=XLEFT
|
||
|
|
X(3)=XLEFT
|
||
|
|
IBLK=IBAKK
|
||
|
|
CALL POLYFL(X,Y,5,IBLK)
|
||
|
|
CALL RBLACK
|
||
|
|
CALL PLOTT(X(1),Y(1),3)
|
||
|
|
CALL PLOTT(X(2),Y(2),2)
|
||
|
|
CALL PLOTT(X(3),Y(3),2)
|
||
|
|
CALL PLOTT(X(4),Y(4),2)
|
||
|
|
CALL PLOTT(X(1),Y(1),2)
|
||
|
|
!ipk mar01
|
||
|
|
CALL SYMBL(XLEFT-1.,7.65,0.20,HEADR(K,NBRR),0.0,8)
|
||
|
|
250 CONTINUE
|
||
|
|
! ENDIF
|
||
|
|
ENDIF
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
! Get xy location of cursor in screen coordinates (inches)
|
||
|
|
|
||
|
|
|
||
|
|
subroutine xyloc(xscrn,yscrn,iflag,ibox)
|
||
|
|
save
|
||
|
|
|
||
|
|
INCLUDE 'TXFRM.COM'
|
||
|
|
!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL
|
||
|
|
|
||
|
|
CHARACTER*80 TITLE
|
||
|
|
CHARACTER*24 HLABL
|
||
|
|
CHARACTER*1 ALABL(10)
|
||
|
|
CHARACTER*40 MPDUM
|
||
|
|
|
||
|
|
COMMON /SSIZE/ HSIZE
|
||
|
|
|
||
|
|
COMMON /BLKA1/ TITLE,HLABL,ALABL,MPDUM
|
||
|
|
!IPk oct 95 lines defining MPDUM added
|
||
|
|
|
||
|
|
!ipk jan01 Expand IPSW to 10
|
||
|
|
COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout
|
||
|
|
|
||
|
|
character*1 iflag
|
||
|
|
common /blktek/ xmin, xmax, ymin, ymax,&
|
||
|
|
xpiv, ypiv, cthet, sthet,&
|
||
|
|
xscal, yscal, theta, thetdg,&
|
||
|
|
pgscl,scrnx,scrny,ix,iy
|
||
|
|
|
||
|
|
! IRDISP= 0 means no redisplay
|
||
|
|
|
||
|
|
irdisp=0
|
||
|
|
100 continue
|
||
|
|
! iy=ymax
|
||
|
|
! write(90,*) 'to tekgin nhtp',nhtp
|
||
|
|
call tekgin(xscrn,yscrn,iflag)
|
||
|
|
! write(90,*) 'back tekgin nhtp',nhtp,xscrn,yscrn,IRDISP
|
||
|
|
! write(90,'(a)') 'iflag',iflag
|
||
|
|
|
||
|
|
if(iflag .eq. 'P') then
|
||
|
|
call hedr
|
||
|
|
!IPk nov97 add (0)
|
||
|
|
call plotot(0)
|
||
|
|
call hedr
|
||
|
|
!ipk may01
|
||
|
|
irdisp=1
|
||
|
|
go to 100
|
||
|
|
endif
|
||
|
|
|
||
|
|
|
||
|
|
!IPk mar94 if(yscrn .gt. 7.0 .and. iflag .eq. 'c') then
|
||
|
|
if(yscrn .gt. 7.5 .and. iflag .eq. 'c') then
|
||
|
|
! ibox=ifix(xscrn+0.9999)
|
||
|
|
ibox=ifix(xscrn*10./HSIZE+0.9999)
|
||
|
|
iflag='c'
|
||
|
|
elseif(iflag .eq. 'M') then
|
||
|
|
irmain = 1
|
||
|
|
elseif(iflag .ne. 'c') then
|
||
|
|
ibox=1
|
||
|
|
else
|
||
|
|
ibox=0
|
||
|
|
endif
|
||
|
|
if(irmain .eq. 1) return
|
||
|
|
|
||
|
|
! Check for zoom command
|
||
|
|
|
||
|
|
if(nhtp .eq. 2 .or. nhtp .eq. 5 .or. nhtp .eq. 12 .or.&
|
||
|
|
nhtp .eq. 8 .or. nhtp .eq. 9) then
|
||
|
|
return
|
||
|
|
elseif(nhtp .eq. 0 .and. (nbrr .eq. 0 .or. nbrr .eq. 2&
|
||
|
|
.or. nbrr .eq. 7)) then
|
||
|
|
return
|
||
|
|
elseif(ibox .eq. 8 .or. iflag .eq. 'z') then
|
||
|
|
n1=nhtp
|
||
|
|
n2=nbrr
|
||
|
|
nhtp=0
|
||
|
|
nbrr=0
|
||
|
|
CALL ZOOM
|
||
|
|
nhtp=n1
|
||
|
|
nbrr=n2
|
||
|
|
!ipk may01
|
||
|
|
irdisp=1
|
||
|
|
if(irmain .eq. 1) return
|
||
|
|
call hedr
|
||
|
|
IF(N2 .EQ. 10) CALL PLTPT
|
||
|
|
go to 100
|
||
|
|
elseif(ibox .eq. 9 .or. iflag .eq. 'r') then
|
||
|
|
|
||
|
|
! Save display parameters
|
||
|
|
|
||
|
|
n1=nhtp
|
||
|
|
n2=nmess
|
||
|
|
n3=nbrr
|
||
|
|
CALL RDRW(0)
|
||
|
|
if(n2 .eq. 11) call pltpt
|
||
|
|
!ipk may01
|
||
|
|
irdisp=1
|
||
|
|
if(irmain .eq. 1) return
|
||
|
|
|
||
|
|
! Restore display parameters
|
||
|
|
|
||
|
|
nhtp=n1
|
||
|
|
nmess=n2
|
||
|
|
nbrr=n3
|
||
|
|
call hedr
|
||
|
|
go to 100
|
||
|
|
endif
|
||
|
|
|
||
|
|
return
|
||
|
|
|
||
|
|
end
|