!IPK LAST UPDATE SEP 23 2015 REVISE TESTING FOR RIVER SECTIONS subroutine tekgin(x,y,iflag) save !iPK APR94 COMMON /RECOD/ IRECD,TSPC character*1 iflag,iiflag,iflags data rsclx,rscly/100.0,100./ data itime/0/ if(itime .eq. 0) then itime=1 iky=0 endif !iPK APR94 IF(IRECD .EQ. 2) THEN if(iky .eq. 0) then READ(91,'(2F7.2,A1)') X,Y,IFLAG iflags=iflag xs=x ys=y else iflag=iflags x=xs y=ys endif ! write(*,'(2f7.2,a1,i4)') x,y,iflag,iky call flush_screen CALL INTRVL(TA,0) 90 CALL INTRVL(TA,1) IF(TA .LT. TSPC) GO TO 90 if(tspc .eq. 0.) then call gim_an_event(ix,iy,iiflag) if(iiflag .eq. '~') then iflag='P' iky=1 return endif endif iky=0 ENDIF 100 continue ! write(*,'(2i15,a1,i3)') ix,iy,iflag,iky if(irecd .eq. 2) return call flush_screen CALL gim_an_event(ix, iy, iiflag) ! write(*,'(2i5,a1)') ix,iy,iiflag IF (iiflag.eq.'~') then ! call hedr ! CALL plotot ! call hedr iflag='P' iky=1 ! go to 100 return endif iky=0 ! if(irecd .eq. 2) return x= float(ix)/rsclx ! y= 8.0-float(iy)/rscly y= float(iy)/rscly iflag=iiflag ! write(90,666) x,y,iflag,ix,iy,iiflag,iky ! 666 format('tekgin',2f8.2,a1,2i5,a1,i2) if(iflag .eq. 'u') then go to 100 endif !ipk apr94 if(irecd .eq. 1) then write(91,'(2f7.2,a1)') x,y,iflag endif return end subroutine draw(x,y) save common /pltc/ipsav,iflg,xll,yll data rsclx,rscly/100.,100./ ix=x*rsclx iy=y*rscly CALL gim_a_line(ix, iy) ! save data on file if requested if(ipsav .gt. 0) then ! don't write out point unless > .005" from previous point if (abs(xll-x) .ge. .005 .or. abs(yll-y) .ge. .005 ) then write(ipsav,99) 'pa',x,y xll = x yll = y iflg = 0 else iflg = 1 endif endif 99 format (a2,2f8.3) return end subroutine move(x,y) save common /pltc/ipsav,iflg,xll,yll data rsclx,rscly/100.,100./ ix=x*rsclx iy=y*rscly CALL move_da_pointer(ix, iy) ! save data on file if requested if(ipsav .gt. 0) then ! don't write out point unless > .005" from previous point write(ipsav,99) 'ma',x,y xll = x yll = y iflg = 0 endif 99 format (a2,2f8.3) return end !************************************************************* ! ! SYMBOL SUBROUTINE ! ! ROUTINE TO OUTPUT !HARACTER STRINGS. ! !***************************************************************** SUBROUTINE SYMBL (X,Y,HEIGHT,STRING,ANGLE,NCHAR) save COMMON /PLTC/IPSAV,IFLG,XLL,YLL CHARACTER*(*) STRING CHARACTER*32 FMT1 CHARACTER*2 PS CHARACTER*2 IHT DATA PS/'PS'/,HT/0.8/ integer*4 nchar IHT(1:1)=CHAR(27) IHT(2:2)=':' HT=height*5. ! if(height .gt. 0.7) then ! ht=height ! else ! ipk mar01 ! ht=0.6 ! endif ! ! Centered symbols ! ICHR = -1 IF (NCHAR .LT. 0) THEN ICHR = ICHAR(STRING(1:1)) IF (ICHR .EQ. 0) STRING(1:1) = CHAR(35) IF (ICHR .EQ. 1) STRING(1:1) = CHAR(33) IF (ICHR .EQ. 2) STRING(1:1) = CHAR(39) IF (ICHR .EQ. 3) STRING(1:1) = CHAR(41) !cc WRITE(2,'(A)') 'SS "CENTERED.SYM"' ENDIF ! ZANGLE = ANGLE LSTR = LENSTR(STRING) LSTR = MIN(LSTR,IABS(NCHAR)) ! ! ixx = x*scrnx ! iyy = (7.50-y-0.2)*scrny ! ! CALL QUAD(X,Y,ITS) IF(ITS .EQ. 22) THEN yy=y ! CALL move( x, yy) CALL LABL(X,YY,LSTR,HT,STRING) ANGL = ZANGLE/3.14159 XLAS = X + COS(ANGL)*(HEIGHT*LSTR) YLAS = Y + SIN(ANGL)*(HEIGHT*LSTR) ! IF(IPSAV .GT. 0) THEN HTG=HT*0.75 WRITE(FMT1,198) NCHAR 198 FORMAT(18h(A2,4F8.3,1X,1H",A,i2,5h,1H")) WRITE(ipsav,FMT1) PS,X,Y,HTG,ANGLE,STRING ENDIF ENDIF ! RETURN END SUBROUTINE QUAD(X,Y,IST) !- !...... Subroutine to establish location of X and Y relative to bounds !- COMMON /PAGE/ XL,XH,YL,YH !- !...... Test side of X !- IST=22 IF(X .LT. XL) IST=12 IF(X .GT. XH) IST=32 !- !...... Test side of Y !- IF(Y .LT. YL) IST=IST-1 IF(Y .GT. YH) IST=IST+1 !- !...... Final pattern for IST is !- ! 13 23 33 ! ------ ! 12 | 22 | 32 ! ------ ! 11 21 31 ! RETURN END SUBROUTINE TRIM(XO,YO,XI,YI,XB,YB,IST,ISTN) !...... Subroutine to compute coordinates for XB and YB on the boundary COMMON /PAGE/ XL,XH,YL,YH IF(IST .LT. 20) THEN !...... XO is to the left IF(ISTN .LT. 20) THEN !...... XI is also left skip out ! by setting IST negative IST=-IST RETURN ELSE XB = XL YB = YO+(YI-YO)/(XI-XO)*(XL-XO) !...... Check location of YB. If its within limits we are done ! or have found a totally crossing line IF(YB .LT. YL) THEN !...... Below IF (YI .EQ. YB) THEN XB = 999. ELSE XB = XB+(XI-XB)/(YI-YB)*(YL-YB) ENDIF YB = YL IF(XB .GT. XH .OR. XB .LT. XL) THEN !...... Signify that final point is still out by negative IST IST=-IST ELSEIF(ISTN .NE. 22) THEN !...... Part of a crossing line set ISTN negative ISTN=-ISTN ENDIF ELSEIF(YB .GT. YH) THEN !...... Above IF (YI .EQ. YB) THEN XB = 999. ELSE XB = XB+(XI-XB)/(YI-YB)*(YH-YB) ENDIF YB = YH IF(XB .GT. XH .OR. XB .LT. XL) THEN IST=-IST ELSEIF(ISTN .NE. 22) THEN ISTN=-ISTN ENDIF ELSEIF(ISTN .NE. 22) THEN ISTN=-ISTN ENDIF ENDIF ELSEIF(IST .GT. 30) THEN !...... XO is to the right IF(ISTN .GT. 30) THEN !...... XI is also right skip out IST=-IST ELSE XB = XH YB = YO+(YI-YO)/(XI-XO)*(XH-XO) !...... Check location of YB. If its within limits we are done IF(YB .LT. YL) THEN !...... Below IF (YI .EQ. YB) THEN XB = 999. ELSE XB = XB+(XI-XB)/(YI-YB)*(YL-YB) ENDIF YB = YL IF(XB .GT. XH .OR. XB .LT. XL) THEN IST=-IST ELSEIF(ISTN .NE. 22) THEN ISTN=-ISTN ENDIF ELSEIF(YB .GT. YH) THEN !...... Above IF (YI .EQ. YB) THEN XB = 999. ELSE XB = XB+(XI-XB)/(YI-YB)*(YH-YB) ENDIF YB = YH IF(XB .GT. XH .OR. XB .LT. XL) THEN IST=-IST ELSEIF(ISTN .NE. 22) THEN ISTN=-ISTN ENDIF ELSEIF(ISTN .NE. 22) THEN ISTN=-ISTN ENDIF ENDIF ELSE !...... XO is in the middle section !...... Check location of YB. If its within limits we are done IF(YO .LT. YL) THEN !...... Below IF(MOD(ISTN,10) .EQ. 1) THEN !...... still out IST=-IST ELSE YB = YL IF (YI .EQ. YO) THEN XB = 999. ELSE XB = XO+(XI-XO)/(YI-YO)*(YL-YO) ENDIF IF(XB .GT. XH .OR. XB .LT. XL) THEN IST=-IST ELSEIF(ISTN .NE. 22) THEN ISTN=-ISTN ENDIF ENDIF ELSEIF(YO .GT. YH) THEN !...... Above IF(MOD(ISTN,10) .EQ. 3) THEN !...... still out IST=-IST ELSE YB = YH IF (YI .EQ. YO) THEN XB = 999. ELSE XB = XO+(XI-XO)/(YI-YO)*(YH-YO) ENDIF IF(XB .GT. XH .OR. XB .LT. XL) THEN IST=-IST ELSEIF(ISTN .NE. 22) THEN ISTN=-ISTN ENDIF ENDIF ENDIF ENDIF RETURN END SUBROUTINE NUMBR(X,Y,HITE,RNUM,THETA,NDEC) ! This routine has been extensively rewritten AUG 94 SAVE COMMON /PLTC/IPSAV,IFLG,XLL,YLL integer*4 ndec CHARACTER*36 FMT,FMT1,NARRAY CHARACTER*1 QOT ! WHERE: X,Y DEFINE THE COORDINATES OF THE LOWER-LEFT CORNER OF THE ! FIRST DIGIT TO BE PLOTTED ! HITE CHARACTER HEIGHT (INCHES) ! RNUM THE REAL NUMBER TO BE PLOTTED ! THETA THE ANGLE (IN DEGREES) THE CHARACTER STRING MAKES WITH THE ! X-AXIS ! NDEC THE OF DECIMAL PLACES TO WHICH THE IS PLOTTED DATA QOT/'"'/ CALL CVF(RNUM,NDEC,NARRAY,NUMC) CALL SYMBL(X,Y,HITE,NARRAY,THETA,NUMC) IF(IPSAV .GT. 0) THEN XLAS=X+NUMC*HITE*0.75 YLAS=Y ZANGLE = THETA HTG=HITE*0.75 WRITE(IPSAV,199) 'PS',X,Y,HTG,ZANGLE,(NARRAY(I:I),I=1,NUMC),QOT 199 FORMAT (A2,2F8.3,2F8.3,1X,1H",11A1) ENDIF RETURN END subroutine polyfl(x,y,npts,icol) ! polygon fill routine npts close it , colour code is icol save dimension x(*),y(*) dimension itran(0:16) data itran/0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/ IF(icol .EQ. -11) then icll=8 else icll=itran(icol) endif if (npts .lt. 4) return CALL nwpen(icll) CALL fill_a_polygon(x,y,npts) call Rblue return end ! --------------------------------------------------------------------------- subroutine nwpen(icl) CALL change_color(icl) return end subroutine RGrey icl=15 ! 240 call nwpen(icl) return end ! ----------------------------------------------------------------------------- subroutine RDGrey icv=216 ! 216 CALL IGrcolourN(ICV) return end ! ----------------------------------------------------------------------------- subroutine RBlack icl=14 ! 223 call nwpen(icl) return end ! ----------------------------------------------------------------------------- subroutine Rwhite icl=0 ! 224 call nwpen(icl) return end ! ----------------------------------------------------------------------------- subroutine Rwhiteb icl=1 ! 224 call nwpen(icl) return end ! ----------------------------------------------------------------------------- subroutine RRed icl=12 ! 16 call nwpen(icl) return end ! ----------------------------------------------------------------------------- subroutine RBlue icl=3 ! 175 call nwpen(icl) return end ! ----------------------------------------------------------------------------- subroutine Rcyan icl=5 ! 112 call nwpen(icl) return end ! ----------------------------------------------------------------------------- subroutine RYellow icl=10 ! 63 call nwpen(icl) return end ! ----------------------------------------------------------------------------- subroutine RGreen icl=7 ! 96 call nwpen(icl) return end ! ----------------------------------------------------------------------------- ! Routine to obtain keyboard entry in ascii code SUBROUTINE KEYBRD(K) character*1 cha call gim_a_charac(K,cha,x,y) RETURN END subroutine clscrn CALL clear_screen return end SUBROUTINE PLOTT(XX,YY,II) SAVE COMMON /PLTC/IPSAV,IFLG,XLL,YLL COMMON /PAGE/ XL,XH,YL,YH COMMON /PLXZ/ XLAS,YLAS,NPLT,NCHRS,XORG,YORG ! Save data on file if requested IF(IPSAV .GT. 0 .AND. II .LT. 0) THEN WRITE(IPSAV,99) 'tr',XX,YY WRITE(IPSAV,99) 'pi',0.0,0.0 WRITE(IPSAV,99) 'ma',0.0,0.0 xold=xx yold=yy ENDIF 99 FORMAT (a2,2F8.3) IF(II .EQ. 3) THEN CALL QUAD(XX,YY,ITS) XOLD=XX YOLD=YY IF(ITS .EQ. 22) call move(xx,yy) ENDIF IF(II .EQ. 2) THEN IF(ITS .EQ. 22) THEN ! was in CALL QUAD(XX,YY,ITS) IF(ITS .EQ. 22) THEN ! still in CALL DRAW(XX,YY) XOLD=XX YOLD=YY ELSE ! now out ITSN=22 CALL TRIM(XX,YY,XOLD,YOLD,XB,YB,ITS,ITSN) CALL DRAW(XB, YB) XOLD=XX YOLD=YY ITS=IABS(ITS) ENDIF ELSE ! was out CALL QUAD(XX,YY,ITSN) IF(ITSN .EQ. 22) THEN ! now in CALL TRIM(XOLD,YOLD,XX,YY,XB,YB,ITS,ITSN) CALL MOVE(XB, YB) CALL DRAW(XX, YY) XOLD=XX YOLD=YY ITS=22 ELSE ! still out but could have been in for a time so test CALL TRIM(XOLD,YOLD,XX,YY,XB,YB,ITS,ITSN) IF(ITS .LT. 0) THEN ! yes XOLD=XX YOLD=YY ITS=IABS(ITSN) ELSEIF(ITSN .LT. 0) THEN CALL MOVE(XB,YB) ITSN=-ITSN ITS=22 XOLD=XB YOLD=YB CALL TRIM(XX,YY,XOLD,YOLD,XB,YB,ITSN,ITS) CALL DRAW(XB, YB) XOLD=XX YOLD=YY ITS=IABS(ITSN) ENDIF ENDIF ENDIF ENDIF XLAS=XOLD YLAS=YOLD RETURN END subroutine quit_pgm call setd(24) close (90) CALL get_rid_window stop end ! ----------------------------------------------------------------------------- subroutine clrbox CALL clear_box return end SUBROUTINE INTRVL(TA,IS) !...... Timing routine ! TA is interval time in seconds !IPK APR94 COMMON /RECOD/ IRECD,TSPC INTEGER*4 ITA,ITN IF(IS .EQ. 0) THEN ! CALL TIMER(ITA) CALL GETTIM(IHR,IMIN,ISEC,IHUN) TB=3600.*IHR+60.*IMIN+ISEC+ FLOAT(IHUN)/100. RETURN ELSE CALL GETTIM(IHR,IMIN,ISEC,IHUN) TA=3600.*IHR+60.*IMIN+ISEC+ FLOAT(IHUN)/100. ! CALL TIMER(ITN) ENDIF ! ITIC=ITN-ITA ! IF(ITIC .LT. 0) THEN ! ITA=ITN ! ITIC=0 ! ENDIF ! TA=FLOAT(ITIC)/100. TA=TA-TB IF(TSPC .EQ. 0.) THEN TA=TA-0.5 ENDIF RETURN END SUBROUTINE DASHLN(XLIN,YLIN,NLINP,ICD) ! Routine to draw a line with dashes DIMENSION XLIN(*),YLIN(*) ! Work through points DO 200 K=1,NLINP IF(K .EQ. 1) THEN CALL PLOTT(XLIN(K),YLIN(K),3) ELSEIF(ICD .EQ. 0) THEN CALL PLOTT(XLIN(K),YLIN(K),2) ELSE ! Draw dashed line DASHNT=0.2/2.**ICD SC1=(XLIN(K)-XLIN(K-1))**2 SC2=(YLIN(K)-YLIN(K-1))**2 SLEN=SQRT(SC1+SC2) NDASH=IFIX(SLEN/DASHNT)+1 XINC=(XLIN(K)-XLIN(K-1))/SLEN*DASHNT YINC=(YLIN(K)-YLIN(K-1))/SLEN*DASHNT XP=XLIN(K-1) YP=YLIN(K-1) DO 180 ND=1,NDASH IF(ND .LT. NDASH) THEN XP=XP+XINC YP=YP+YINC ELSE XP=XLIN(K) YP=YLIN(K) ENDIF IF(MOD(ND,2) .EQ. 1) THEN CALL PLOTT(XP,YP,2) ELSE CALL PLOTT(XP,YP,3) ENDIF 180 CONTINUE ENDIF 200 CONTINUE RETURN END subroutine chint(iflag) character*1 iflag iflag='c' return end SUBROUTINE GETINTAA(INUM) COMMON /RECOD/ IRECD,TSPC character*50 cha CHARACTER*11 DATA CHARACTER*30 MES DATA MES/'Error reading integer, Reenter'/ if(irecd .eq. 2) then read(91,'(i7)') inum CALL INTRVL(TA,0) 70 CALL INTRVL(TA,1) IF(TA .LT. TSPC) GO TO 70 return endif 80 CONTINUE DO 90 I=1,11 DATA(I:I)=' ' 90 CONTINUE I = 1 10 CONTINUE I = I+1 call gim_a_charac(key,cha,x,y) ! write(90,*) 'key',key IF (KEY .EQ. 8) THEN I = I-2 GO TO 10 ENDIF IF(KEY .EQ. 13) GO TO 200 DATA(I:I)=CHAR(KEY) CALL GTEXT(4,I+20,DATA(I:I)) 100 CONTINUE GO TO 10 200 CONTINUE READ(DATA,5000,ERR=300) INUM 5000 FORMAT(1X,I10) if(irecd .eq. 1) then write(91,'(i7)') inum endif RETURN 300 CONTINUE CALL SYMBL(3.0,7.6,0.2,MES,0.0,30) GO TO 80 END SUBROUTINE GETFPNA(FPN) !IPK APR94 COMMON /RECOD/ IRECD,TSPC CHARACTER*11 DATA character*50 cha CHARACTER*30 MES DATA MES/'Error reading number, Reenter.'/ if(irecd .eq. 2) then read(91,'(f7.2)') fpn CALL INTRVL(TA,0) 70 CALL INTRVL(TA,1) IF(TA .LT. TSPC) GO TO 70 return endif 80 CONTINUE DO 90 I=1,11 DATA(I:I)=' ' 90 CONTINUE I = 1 10 CONTINUE I = I+1 call gim_a_charac(key,cha,x,y) ! write(90,*) 'key',key IF (KEY .EQ. 8) THEN I = I-2 GO TO 10 ENDIF IF(KEY .EQ. 13) GO TO 200 DATA(I:I)=CHAR(KEY) CALL GTEXT(4,I+20,DATA(I:I)) 100 CONTINUE GO TO 10 200 CONTINUE READ(DATA,5000,ERR=300) FPN 5000 FORMAT(1X,F10.0) if(irecd .eq. 1) then write(91,'(f7.2)') fpn endif RETURN 300 CONTINUE CALL SYMBL(3.0,7.6,0.2,MES,0.0,30) GO TO 80 END SUBROUTINE FLUSHWN CALL FLUSH_SCREEN RETURN END subroutine gtext(j,i,cha) character*1 cha y=8.0-0.1*j x=i*0.15 call symbl(x,y,0.15,cha,0.0,1) return end subroutine fillem(ielem) USE BLK1MOD INCLUDE 'TXFRM.COM' dimension xvs(9),yvs(9) ! include 'BLK1.COM' ncn=ncorn(ielem) if(ncn .gt. 5) go to 200 N1=NOP(IELEM,1) N2=NOP(IELEM,3) IF(IPW1 .EQ. 1) THEN wd11=width(n1)/txscal wd2=width(n2)/txscal ELSE BT1= & CRSDAT(NRIVCR1(N1),1,1)*WTRIVCR1(N1)+ & CRSDAT(NRIVCR2(N1),1,1)*WTRIVCR2(N1) BT2= & CRSDAT(NRIVCR1(N2),1,1)*WTRIVCR1(N2)+ & CRSDAT(NRIVCR2(N2),1,1)*WTRIVCR2(N2) H1=WIDEL-BT1 H2=WIDEL-BT2 CALL INTERPWLV(N1,H1,AR1,WR1,DWR1) CALL INTERPWLV(N2,H2,AR2,WR2,DWR2) WIDTH(N1)=WR1 WIDTH(N2)=WR2 IF(IPW1 .EQ. 2) THEN WD11=WR1*WIDSCL/TXSCAL WD2=WR2*WIDSCL/TXSCAL ELSE WD11=AR1*WIDSCL/TXSCAL WD2=AR2*WIDSCL/TXSCAL ENDIF ENDIF IF(WD11 .GT. 0. .AND. WD2 .GT. 0.) THEN X1= CORD(N1,1) X2= CORD(N2,1) Y1= CORD(N1,2) Y2= CORD(N2,2) ELDIR=ATAN2(Y2-Y1,X2-X1) ELNORM=ELDIR-1.5708 XVS(1)=X1+COS(ELNORM)*WD11/2. XVS(4)=X1-COS(ELNORM)*WD11/2. XVS(2)=X2+COS(ELNORM)*WD2/2. XVS(3)=X2-COS(ELNORM)*WD2/2. YVS(1)=Y1+SIN(ELNORM)*WD11/2. YVS(4)=Y1-SIN(ELNORM)*WD11/2. YVS(2)=Y2+SIN(ELNORM)*WD2/2. YVS(3)=Y2-SIN(ELNORM)*WD2/2. NPTS=4 call polyfl(xvs,yvs,npts,14) ENDIF RETURN 200 xvs(1)=cord(nop(ielem,1),1) yvs(1)=cord(nop(ielem,1),2) npts=1 do 100 n=1,ncn if(n .ge. 9) go to 100 if(nop(ielem,n) .eq. 0) go to 100 npts=npts+1 xvs(npts)=cord(nop(ielem,n),1) yvs(npts)=cord(nop(ielem,n),2) 100 continue call polyfl(xvs,yvs,npts,14) return end SUBROUTINE CLRSTP(y1,y2) REAL HSIZE COMMON /SSIZE/ HSIZE dimension x(4),y(4) x(1)=0. x(2)=HSIZE x(3)=HSIZE x(4)=0. y(1)=y1 y(2)=y1 y(3)=y2 y(4)=y2 call Rwhite CALL fill_a_polygon(x,y,4) call RBlue return end SUBROUTINE FILLEMC(IELEM,ICCT) USE BLK1MOD INCLUDE 'BFILES.I90' INCLUDE 'TXFRM.COM' ! INCLUDE 'BLK1.COM' DIMENSION X(4),Y(4) DO 300 N=1,NCORN(IELEM),2 M=NOP(IELEM,N) IF(M .EQ. 0) THEN GO TO 310 ELSE X((N+1)/2)=CORD(M,1) Y((N+1)/2)=CORD(M,2) if(i3dview .eq. 1) then Y((N+1)/2)=Y((N+1)/2)+(WD(M)-VRTORIG)*COS(VANG/57.29578)/VRTSCAL endif NPOL=(N+1)/2 ENDIF 300 CONTINUE 310 CONTINUE IF(NCORN(IELEM) .GT. 5) THEN CALL NWPEN(ICCT) CALL fill_a_polygon(x,y,npol) ELSE N1=NOP(IELEM,1) N2=NOP(IELEM,3) !ipk dec17 if(ncorn(ielem) .eq. 2) n2=nop(ielem,2) IF(IPW1 .EQ. 1) THEN wd11=width(n1)/txscal wd2=width(n2)/txscal ELSE IF(NRIVCR1(N1) .EQ. 0 .AND. NRIVCR2(N1) .EQ. 0) RETURN IF(NRIVCR1(N2) .EQ. 0 .AND. NRIVCR2(N2) .EQ. 0) RETURN BT1= & CRSDAT(NRIVCR1(N1),1,1)*WTRIVCR1(N1)+ & CRSDAT(NRIVCR2(N1),1,1)*WTRIVCR2(N1) BT2= & CRSDAT(NRIVCR1(N2),1,1)*WTRIVCR1(N2)+ & CRSDAT(NRIVCR2(N2),1,1)*WTRIVCR2(N2) H1=WIDEL-BT1 H2=WIDEL-BT2 CALL INTERPWLV(N1,H1,AR1,WR1,DWR1) CALL INTERPWLV(N2,H2,AR2,WR2,DWR2) WIDTH(N1)=WR1 WIDTH(N2)=WR2 IF(IPW1 .EQ. 2) THEN WD11=WR1*WIDSCL/TXSCAL WD2=WR2*WIDSCL/TXSCAL ELSE WD11=AR1*WIDSCL/TXSCAL WD2=AR2*WIDSCL/TXSCAL ENDIF ENDIF IF(WD11 .GT. 0. .AND. WD2 .GT. 0.) THEN X1= CORD(N1,1) X2= CORD(N2,1) Y1= CORD(N1,2) Y2= CORD(N2,2) ELDIR=ATAN2(Y2-Y1,X2-X1) ELNORM=ELDIR-1.5708 X(1)=X1+COS(ELNORM)*WD11/2. X(4)=X1-COS(ELNORM)*WD11/2. X(2)=X2+COS(ELNORM)*WD2/2. X(3)=X2-COS(ELNORM)*WD2/2. Y(1)=Y1+SIN(ELNORM)*WD11/2. Y(4)=Y1-SIN(ELNORM)*WD11/2. Y(2)=Y2+SIN(ELNORM)*WD2/2. Y(3)=Y2-SIN(ELNORM)*WD2/2. NPOL=4 CALL NWPEN(ICCT) CALL fill_a_polygon(x,y,npol) ENDIF ENDIF CALL RBlue RETURN END SUBROUTINE POLYG(AX,AY,NPT,N) SAVE DIMENSION AX(10),AY(10),BX(15),BY(15) ! Duplicate numbers around AX to form long list ! DO 200 I=1,NPT AX(I+NPT)=AX(I) AY(I+NPT)=AY(I) 200 CONTINUE ! Find a starting point that is on the page DO 250 I=1,NPT CALL QUAD(AX(I),AY(I),ITS) IF(ITS .EQ. 22) THEN ! We have a starting point II=I GO TO 350 ENDIF ! Keep looking 250 CONTINUE ! No point on page then skip out RETURN ! Loop to check each point and trim as required 350 CONTINUE JJ=1 BX(1)=AX(II) BY(1)=AY(II) XOLD=AX(II) YOLD=AY(II) DO 500 J=2,NPT+1 II=II+1 IF(ITS .EQ. 22) THEN CALL QUAD(AX(II),AY(II),ITS) IF(ITS .EQ. 22) THEN ! still in copy over from A to B JJ=JJ+1 BX(JJ)=AX(II) BY(JJ)=AY(II) XOLD=AX(II) YOLD=AY(II) ELSE ! now out copy over boundary ITSN=22 CALL TRIM(AX(II),AY(II),XOLD,YOLD,XB,YB,ITS,ITSN) JJ=JJ+1 BX(JJ)=XB BY(JJ)=YB XOLD=AX(II) YOLD=AY(II) ITS=IABS(ITS) ENDIF ELSE ! WAS OUT CALL QUAD(AX(II),AY(II),ITSN) IF(ITSN .EQ. 22) THEN ! now in copy over point of return CALL TRIM(XOLD,YOLD,AX(II),AY(II),XB,YB,ITS,ITSN) JJ=JJ+1 BX(JJ)=XB BY(JJ)=YB ! Copy destination point JJ=JJ+1 BX(JJ)=AX(II) BY(JJ)=AY(II) XOLD=AX(II) YOLD=AY(II) ITS=22 ELSE ! still out but could have been in for a time so test CALL TRIM(XOLD,YOLD,AX(II),AY(II),XB,YB,ITS,ITSN) IF(ITS .LT. 0) THEN ! no XOLD=AX(II) YOLD=AY(II) ITS=IABS(ITSN) ELSEIF(ITSN .LT. 0) THEN ! Temporarily in. Copy point of return JJ=JJ+1 BX(JJ)=XB BY(JJ)=YB ITSN=-ITSN ITS=22 XOLD=XB YOLD=YB CALL TRIM(AX(II),AY(II),XOLD,YOLD,XB,YB,ITSN,ITS) ! Now copy over point of exit JJ=JJ+1 BX(JJ)=XB BY(JJ)=YB XOLD=AX(II) YOLD=AY(II) ITS=IABS(ITSN) ENDIF ENDIF ENDIF 500 CONTINUE ! Record final number of points NPTS=JJ !ipk sep 94 icl=mod(n,16)+1 icl=mod(n-1,14) call polyfl(bx,by,npts,icl) RETURN END SUBROUTINE DBDASHLN(XLIN,YLIN,NLINP,ICD) ! Routine to draw a line with dashes REAL*8 XLIN(*),YLIN(*) ! Work through points DO 200 K=1,NLINP IF(K .EQ. 1) THEN XCT=XLIN(K) YCT=YLIN(K) CALL PLOTT(XCT,YCT,3) ELSEIF(ICD .EQ. 0) THEN XCT=XLIN(K) YCT=YLIN(K) CALL PLOTT(XCT,YCT,2) ELSE ! Draw dashed line DASHNT=0.2/2.**ICD SC1=(XLIN(K)-XLIN(K-1))**2 SC2=(YLIN(K)-YLIN(K-1))**2 SLEN=SQRT(SC1+SC2) if(slen .lt. 0.1) then XP=XLIN(K-1) YP=YLIN(K-1) CALL PLOTT(XP,YP,3) XP=XLIN(K) YP=YLIN(K) CALL PLOTT(XP,YP,2) cycle endif NDASH=IFIX(SLEN/DASHNT)+1 XINC=(XLIN(K)-XLIN(K-1))/SLEN*DASHNT YINC=(YLIN(K)-YLIN(K-1))/SLEN*DASHNT XP=XLIN(K-1) YP=YLIN(K-1) DO 180 ND=1,NDASH IF(ND .LT. NDASH) THEN XP=XP+XINC YP=YP+YINC ELSE XP=XLIN(K) YP=YLIN(K) ENDIF IF(MOD(ND,2) .EQ. 1) THEN CALL PLOTT(XP,YP,2) ELSE CALL PLOTT(XP,YP,3) ENDIF 180 CONTINUE ENDIF 200 CONTINUE RETURN END SUBROUTINE GETINT(ISW) USE WINTERACTER ! ! include 'd.inc' ! ! Declare window-type and message variables ! TYPE(WIN_STYLE) :: WINDOW TYPE(WIN_MESSAGE) :: MESSAGE COMMON /RECOD/ IRECD,TSPC 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*47 MESOUT,MESS(47) DATA MESS /'Enter node to search for',' Enter material type',& 'Enter element to search for ',& 'Enter number of layers ',& 'Enter width ',& 'Click mouse at end of line ',& 'Enter number of nodes in line ',& 'Click at corners of block ',& 'Enter number of elements in x-dir ',& 'Enter number of elements in y-dir ',& 'Click to move boundaries or (q)uit to terminate',& 'Click on elements','Enter starting list number ',& 'Enter bed elevation','Click on node ',& 'Click location of new node','Click at node to move ',& 'Click at node to delete ',& 'Type 1 to use all nodes else type 0 ',& 'Enter element to select','Click location of node',& 'Enter SS1','Enter SS2','Enter STRWID','Enter STORAGE ELEVATION',& 'Click mouse on node','click mouse on next node',& 'ERROR - Midside node selected - Select node again',& 'Plotting a selected cross section',& 'Click two locations to form a cross section',& 'Click to adjust the cross section',& 'Compute cross section parameters',& 'Click a node for the cross section',& 'Click two locations to form the width','Click to adjust the line','Click two locations to form left slope',& 'Click two locations to form right slope','Click a location'& ,'Enter storage elevation','Enter storage slope',& 'Click at two locations to determine distance'& ,'Enter continuity line number. Use 0 to end','Click at location to define register point'& ,'Enter 1-D cross-section bed slope','Enter element frequency for search'& ,'Enter no. of elements to reverse '& ,'Enter no. of elements across section'/ if(irecd .eq. 2) then read(91,'(i7)') isw CALL INTRVL(TA,0) 70 CALL INTRVL(TA,1) IF(TA .LT. TSPC) GO TO 70 return endif if(isw .eq. 0) isw=1 call wdialogload(IDD_GETINT) ierr=infoerror(1) CALL WDialogSelect(IDD_GETINT) ierr=infoerror(1) CALL WDialogPutString(IDF_STRING1,MESS(NMESS)) CALL WDialogPutInteger(IDF_INTEGER1,ISW) CALL WDialogShow(-1,-1,0,Modal) ierr=infoerror(1) ! Branch depending on type of message. ! DO IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN CALL WDialogGetInteger(IDF_INTEGER1,ISW) RETURN ELSE RETURN ENDIF ENDDO RETURN END SUBROUTINE GETFPN(FPN) USE WINTERACTER ! ! include 'd.inc' ! ! Declare window-type and message variables ! TYPE(WIN_STYLE) :: WINDOW TYPE(WIN_MESSAGE) :: MESSAGE COMMON /RECOD/ IRECD,TSPC 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*47 MESOUT,MESS(46) DATA MESS /'Enter node to search for',' Enter material type',& 'Enter element to search for ',& 'Enter number of layers ',& 'Enter width ',& 'Click mouse at end of line ',& 'Enter number of nodes in line ',& 'Click at corners of block ',& 'Enter number of elements in x-dir ',& 'Enter number of elements in y-dir ',& 'Click to move boundaries or (q)uit to terminate',& 'Click on elements','Enter starting list number ',& 'Enter bed elevation','Click on node ',& 'Click location of new node','Click at node to move ',& 'Click at node to delete ',& 'Type 1 to use all nodes else type 0 ',& 'Enter element to select','Click location of node',& 'Enter SS1','Enter SS2','Enter STRWID','Enter STORAGE ELEVATION',& 'Click mouse on node','click mouse on next node',& 'ERROR - Midside node selected - Select node again',& 'Plotting a selected cross section',& 'Click two locations to form a cross section',& 'Click to adjust the cross section',& 'Compute cross section parameters',& 'Click a node for the cross section',& 'Click two locations to form the width','Click to adjust the line','Click two locations to form left slope',& 'Click two locations to form right slope','Click a location'& ,'Enter storage elevation','Enter storage slope',& 'Click at two locations to determine distance'& ,'Enter continuity line number. Use 0 to end','Click at location to define register point'& ,'Enter 1-D cross-section bed slope','Enter time interval for display of steps'& ,'Enter tolerance for overlapping points'/ if(irecd .eq. 2) then read(91,'(f7.2)') fpn CALL INTRVL(TA,0) 70 CALL INTRVL(TA,1) IF(TA .LT. TSPC) GO TO 70 return endif call wdialogload(IDD_GETFPN) ierr=infoerror(1) CALL WDialogSelect(IDD_GETFPN) ierr=infoerror(1) CALL WDialogPutString(IDF_STRING1,MESS(NMESS)) CALL WDialogPutReal(IDF_REAL1,FPN) CALL WDialogShow(-1,-1,0,Modal) ierr=infoerror(1) ! Branch depending on type of message. ! DO IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN CALL WDialogGetReal(IDF_REAL1,FPN) RETURN ELSE RETURN ENDIF ENDDO RETURN END subroutine drawcr(x,y,siz) ! routine to draw x mark siz1=0.707/2.*siz x1=x-siz1 y1=y-siz1 call plott(x1,y1,3) x1=x+siz1 y1=y+siz1 call plott(x1,y1,2) x1=x-siz1 y1=y+siz1 call plott(x1,y1,3) x1=x+siz1 y1=y-siz1 call plott(x1,y1,2) return end SUBROUTINE GETREV(ISW,ILMIT) USE WINTERACTER ! ! include 'd.inc' ! ! Declare window-type and message variables ! TYPE(WIN_STYLE) :: WINDOW TYPE(WIN_MESSAGE) :: MESSAGE INTEGER ISW,ILMIT call wdialogload(IDD_GETINTR) ierr=infoerror(1) CALL WDialogSelect(IDD_GETINTR) ierr=infoerror(1) CALL WDialogPutCheckBox(IDF_check1,ILMIT) CALL WDialogPutInteger(IDF_INTEGER1,ISW) CALL WDialogShow(-1,-1,0,Modal) ierr=infoerror(1) ! Branch depending on type of message. ! DO IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN CALL WDialogGetCheckBox(IDF_check1,ILMIT) CALL WDialogGetInteger(IDF_INTEGER1,ISW) RETURN ELSE ISW=-1 RETURN ENDIF ENDDO RETURN END