iank
/
RMAGEN84
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
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.
master
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from '8f3dbc8e9c'
${ noResults }
RMAGEN84/SRC84/SYMBL.F90

1458 lines
35 KiB
Fortran
Raw Normal View History Unescape Escape

VERSION84 WITH NEW GRID PLOTTING AND 1D EXPANSION
5 years ago
!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