!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