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.
1458 lines
35 KiB
Fortran
1458 lines
35 KiB
Fortran
!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
|
|
|