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.
465 lines
15 KiB
Fortran
465 lines
15 KiB
Fortran
5 years ago
|
!IPK LAST UPDATE JULY 18 1998 MAJOR CHANGES
|
||
|
|
! Last change: IPK 12 Jan 98 11:22 am
|
||
|
|
!ipk jan98 delete old call to char(7)
|
||
|
|
!****************************************************************
|
||
|
|
!
|
||
|
|
SUBROUTINE ADDWID
|
||
|
|
!
|
||
|
|
! Add nodal width data
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
!
|
||
|
|
CHARACTER*1 IFLAG,ANSW(10),ANSW1(10)
|
||
|
|
DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/
|
||
|
|
DATA ANSW1/ 'w','1','2','d','e','s','b','z','r','q'/
|
||
|
|
!
|
||
|
|
4 CONTINUE
|
||
|
|
NHTP=13
|
||
|
|
NMESS=0
|
||
|
|
NBRR=0
|
||
|
|
!ipk apr95 add call to flushwn
|
||
|
|
call flushwn
|
||
|
|
CALL HEDR
|
||
|
|
102 IBOX=1
|
||
|
|
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
!
|
||
|
|
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||
|
|
IFLAG=ANSW1(IBOX)
|
||
|
|
ENDIF
|
||
|
|
IF(IFLAG .EQ. 'w') THEN
|
||
|
|
!
|
||
|
|
! get width
|
||
|
|
!
|
||
|
|
104 continue
|
||
|
|
call plotot(1)
|
||
|
|
CALL RCYAN
|
||
|
|
DO K=1,NE
|
||
|
|
IF(IMAT(K) .GT. 0) THEN
|
||
|
|
IF(NCORN(K) .LT. 6) THEN
|
||
|
|
IF(NCORN(K) .GT. 2 .AND. IMAT(K) .LT. 900) THEN
|
||
|
|
DO N=1,3,2
|
||
|
|
J=NOP(K,N)
|
||
|
|
FPN = WIDTH(J)
|
||
|
|
X = CORD(J,1)
|
||
|
|
Y = CORD(J,2) - .11
|
||
|
|
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||
|
|
enddo
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
enddo
|
||
|
|
CALL RBLUE
|
||
|
|
nmess=45
|
||
|
|
nhtp=0
|
||
|
|
nbrr=4
|
||
|
|
call flushwn
|
||
|
|
CALL HEDR
|
||
|
|
nmess=5
|
||
|
|
xprt=3.2
|
||
|
|
call getfpn(cwid)
|
||
|
|
!
|
||
|
|
! Input new widths
|
||
|
|
!
|
||
|
|
105 IBOX=1
|
||
|
|
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
!
|
||
|
|
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||
|
|
IFLAG=ANSW(IBOX)
|
||
|
|
ENDIF
|
||
|
|
IF(IFLAG .EQ. 'n') THEN
|
||
|
|
GO TO 104
|
||
|
|
ELSEIF(IFLAG .EQ. 'q') THEN
|
||
|
|
CALL WRTOUT(0)
|
||
|
|
go to 4
|
||
|
|
ENDIF
|
||
|
|
XPRT=XPRT+0.5
|
||
|
|
IF(XPRT .GT. HSIZE) XPRT=0.
|
||
|
|
FPN= INODE
|
||
|
|
CALL NUMBR(XPRT,7.20,0.20,FPN,0.0,-1)
|
||
|
|
IF (IFLAG .EQ. 'c') THEN
|
||
|
|
WIDTH(INODE) = CWID
|
||
|
|
FPN = WIDTH(INODE)
|
||
|
|
X = CORD(INODE,1)
|
||
|
|
Y = CORD(INODE,2) + .11
|
||
|
|
CALL RRED
|
||
|
|
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||
|
|
CALL RBLUE
|
||
|
|
endif
|
||
|
|
go to 105
|
||
|
|
elseif(iflag .eq. '1') then
|
||
|
|
!
|
||
|
|
! get ss1
|
||
|
|
!
|
||
|
|
204 continue
|
||
|
|
call plotot(1)
|
||
|
|
CALL RCYAN
|
||
|
|
DO K=1,NE
|
||
|
|
IF(IMAT(K) .GT. 0) THEN
|
||
|
|
IF(NCORN(K) .LT. 6) THEN
|
||
|
|
IF(NCORN(K) .GT. 2 .AND. IMAT(K) .LT. 900) THEN
|
||
|
|
DO N=1,3,2
|
||
|
|
J=NOP(K,N)
|
||
|
|
FPN = ss1(J)
|
||
|
|
X = CORD(J,1)
|
||
|
|
Y = CORD(J,2) - .11
|
||
|
|
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||
|
|
enddo
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
enddo
|
||
|
|
CALL RBLUE
|
||
|
|
nmess=45
|
||
|
|
nhtp=0
|
||
|
|
nbrr=4
|
||
|
|
call flushwn
|
||
|
|
CALL HEDR
|
||
|
|
nmess=22
|
||
|
|
xprt=3.2
|
||
|
|
call getfpn(ss1tp)
|
||
|
|
!
|
||
|
|
! Input new ss1
|
||
|
|
!
|
||
|
|
205 IBOX=1
|
||
|
|
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
!
|
||
|
|
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||
|
|
IFLAG=ANSW(IBOX)
|
||
|
|
ENDIF
|
||
|
|
IF(IFLAG .EQ. 'n') THEN
|
||
|
|
GO TO 204
|
||
|
|
ELSEIF(IFLAG .EQ. 'q') THEN
|
||
|
|
CALL WRTOUT(0)
|
||
|
|
go to 4
|
||
|
|
ENDIF
|
||
|
|
XPRT=XPRT+0.5
|
||
|
|
IF(XPRT .GT. HSIZE) XPRT=0.
|
||
|
|
FPN= INODE
|
||
|
|
CALL NUMBR(XPRT,7.20,0.20,FPN,0.0,-1)
|
||
|
|
IF (IFLAG .EQ. 'c') THEN
|
||
|
|
SS1(INODE) = SS1TP
|
||
|
|
FPN = SS1TP
|
||
|
|
X = CORD(INODE,1)
|
||
|
|
Y = CORD(INODE,2) + .11
|
||
|
|
CALL RRED
|
||
|
|
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||
|
|
CALL RBLUE
|
||
|
|
endif
|
||
|
|
go to 205
|
||
|
|
elseif(iflag .eq. '2') then
|
||
|
|
!
|
||
|
|
! get ss2
|
||
|
|
!
|
||
|
|
304 continue
|
||
|
|
call plotot(1)
|
||
|
|
CALL RCYAN
|
||
|
|
DO K=1,NE
|
||
|
|
IF(IMAT(K) .GT. 0) THEN
|
||
|
|
IF(NCORN(K) .LT. 6) THEN
|
||
|
|
IF(NCORN(K) .GT. 2 .AND. IMAT(K) .LT. 900) THEN
|
||
|
|
DO N=1,3,2
|
||
|
|
J=NOP(K,N)
|
||
|
|
FPN = ss2(J)
|
||
|
|
X = CORD(J,1)
|
||
|
|
Y = CORD(J,2) - .11
|
||
|
|
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||
|
|
enddo
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
enddo
|
||
|
|
CALL RBLUE
|
||
|
|
nmess=45
|
||
|
|
nhtp=0
|
||
|
|
nbrr=4
|
||
|
|
call flushwn
|
||
|
|
CALL HEDR
|
||
|
|
nmess=23
|
||
|
|
xprt=3.2
|
||
|
|
call getfpn(ss2tp)
|
||
|
|
!
|
||
|
|
! Input new ss2
|
||
|
|
!
|
||
|
|
305 IBOX=1
|
||
|
|
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
!
|
||
|
|
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||
|
|
IFLAG=ANSW(IBOX)
|
||
|
|
ENDIF
|
||
|
|
IF(IFLAG .EQ. 'n') THEN
|
||
|
|
GO TO 304
|
||
|
|
ELSEIF(IFLAG .EQ. 'q') THEN
|
||
|
|
CALL WRTOUT(0)
|
||
|
|
go to 4
|
||
|
|
ENDIF
|
||
|
|
XPRT=XPRT+0.5
|
||
|
|
IF(XPRT .GT. HSIZE) XPRT=0.
|
||
|
|
FPN= INODE
|
||
|
|
CALL NUMBR(XPRT,7.20,0.20,FPN,0.0,-1)
|
||
|
|
IF (IFLAG .EQ. 'c') THEN
|
||
|
|
SS2(INODE) = SS2TP
|
||
|
|
FPN = SS2TP
|
||
|
|
X = CORD(INODE,1)
|
||
|
|
Y = CORD(INODE,2) + .11
|
||
|
|
CALL RRED
|
||
|
|
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||
|
|
CALL RBLUE
|
||
|
|
endif
|
||
|
|
go to 305
|
||
|
|
elseif(iflag .eq. 'd') then
|
||
|
|
!
|
||
|
|
! get storage width
|
||
|
|
!
|
||
|
|
404 continue
|
||
|
|
call plotot(1)
|
||
|
|
CALL RCYAN
|
||
|
|
DO K=1,NE
|
||
|
|
IF(IMAT(K) .GT. 0) THEN
|
||
|
|
IF(NCORN(K) .LT. 6) THEN
|
||
|
|
IF(NCORN(K) .GT. 2 .AND. IMAT(K) .LT. 900) THEN
|
||
|
|
DO N=1,3,2
|
||
|
|
J=NOP(K,N)
|
||
|
|
FPN = wids(J)
|
||
|
|
X = CORD(J,1)
|
||
|
|
Y = CORD(J,2) - .11
|
||
|
|
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||
|
|
enddo
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
enddo
|
||
|
|
CALL RBLUE
|
||
|
|
nmess=45
|
||
|
|
nhtp=0
|
||
|
|
nbrr=4
|
||
|
|
call flushwn
|
||
|
|
CALL HEDR
|
||
|
|
nmess=24
|
||
|
|
xprt=3.2
|
||
|
|
call getfpn(wids1tp)
|
||
|
|
!
|
||
|
|
! Input new storgae width
|
||
|
|
!
|
||
|
|
405 IBOX=1
|
||
|
|
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
!
|
||
|
|
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||
|
|
IFLAG=ANSW(IBOX)
|
||
|
|
ENDIF
|
||
|
|
IF(IFLAG .EQ. 'n') THEN
|
||
|
|
GO TO 404
|
||
|
|
ELSEIF(IFLAG .EQ. 'q') THEN
|
||
|
|
CALL WRTOUT(0)
|
||
|
|
go to 4
|
||
|
|
ENDIF
|
||
|
|
XPRT=XPRT+0.5
|
||
|
|
IF(XPRT .GT. HSIZE) XPRT=0.
|
||
|
|
FPN= INODE
|
||
|
|
CALL NUMBR(XPRT,7.20,0.20,FPN,0.0,-1)
|
||
|
|
IF (IFLAG .EQ. 'c') THEN
|
||
|
|
WIDS(INODE) = wids1TP
|
||
|
|
FPN = wids1TP
|
||
|
|
X = CORD(INODE,1)
|
||
|
|
Y = CORD(INODE,2) + .11
|
||
|
|
CALL RRED
|
||
|
|
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||
|
|
CALL RBLUE
|
||
|
|
endif
|
||
|
|
go to 405
|
||
|
|
elseif(iflag .eq. 'e') then
|
||
|
|
!
|
||
|
|
! get storage elevation
|
||
|
|
!
|
||
|
|
504 continue
|
||
|
|
call plotot(1)
|
||
|
|
CALL RCYAN
|
||
|
|
DO K=1,NE
|
||
|
|
IF(IMAT(K) .GT. 0) THEN
|
||
|
|
IF(NCORN(K) .LT. 6) THEN
|
||
|
|
IF(NCORN(K) .GT. 2 .AND. IMAT(K) .LT. 900) THEN
|
||
|
|
DO N=1,3,2
|
||
|
|
J=NOP(K,N)
|
||
|
|
FPN = widbs(J)
|
||
|
|
X = CORD(J,1)
|
||
|
|
Y = CORD(J,2) - .11
|
||
|
|
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||
|
|
enddo
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
enddo
|
||
|
|
CALL RBLUE
|
||
|
|
nmess=45
|
||
|
|
nhtp=0
|
||
|
|
nbrr=4
|
||
|
|
call flushwn
|
||
|
|
CALL HEDR
|
||
|
|
nmess=39
|
||
|
|
xprt=3.2
|
||
|
|
call getfpn(widbs1tp)
|
||
|
|
!
|
||
|
|
! Input new storage elevations
|
||
|
|
!
|
||
|
|
505 IBOX=1
|
||
|
|
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
!
|
||
|
|
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||
|
|
IFLAG=ANSW(IBOX)
|
||
|
|
ENDIF
|
||
|
|
IF(IFLAG .EQ. 'n') THEN
|
||
|
|
GO TO 504
|
||
|
|
ELSEIF(IFLAG .EQ. 'q') THEN
|
||
|
|
CALL WRTOUT(0)
|
||
|
|
go to 4
|
||
|
|
ENDIF
|
||
|
|
XPRT=XPRT+0.5
|
||
|
|
IF(XPRT .GT. HSIZE) XPRT=0.
|
||
|
|
FPN= INODE
|
||
|
|
CALL NUMBR(XPRT,7.20,0.20,FPN,0.0,-1)
|
||
|
|
IF (IFLAG .EQ. 'c') THEN
|
||
|
|
WIDBS(INODE) = widbs1TP
|
||
|
|
FPN = widbs1tp
|
||
|
|
X = CORD(INODE,1)
|
||
|
|
Y = CORD(INODE,2) + .11
|
||
|
|
CALL RRED
|
||
|
|
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||
|
|
CALL RBLUE
|
||
|
|
endif
|
||
|
|
go to 505
|
||
|
|
elseif(iflag .eq. 's') then
|
||
|
|
!
|
||
|
|
! get storage slopes
|
||
|
|
!
|
||
|
|
604 continue
|
||
|
|
call plotot(1)
|
||
|
|
CALL RCYAN
|
||
|
|
DO K=1,NE
|
||
|
|
IF(IMAT(K) .GT. 0) THEN
|
||
|
|
IF(NCORN(K) .LT. 6) THEN
|
||
|
|
IF(NCORN(K) .GT. 2 .AND. IMAT(K) .LT. 900) THEN
|
||
|
|
DO N=1,3,2
|
||
|
|
J=NOP(K,N)
|
||
|
|
FPN = sso(J)
|
||
|
|
X = CORD(J,1)
|
||
|
|
Y = CORD(J,2) - .11
|
||
|
|
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||
|
|
enddo
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
enddo
|
||
|
|
CALL RBLUE
|
||
|
|
nmess=45
|
||
|
|
nhtp=0
|
||
|
|
nbrr=4
|
||
|
|
call flushwn
|
||
|
|
CALL HEDR
|
||
|
|
nmess=40
|
||
|
|
xprt=3.2
|
||
|
|
call getfpn(widslp)
|
||
|
|
!
|
||
|
|
! Input new storage slopes
|
||
|
|
!
|
||
|
|
605 IBOX=1
|
||
|
|
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
!
|
||
|
|
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||
|
|
IFLAG=ANSW(IBOX)
|
||
|
|
ENDIF
|
||
|
|
IF(IFLAG .EQ. 'n') THEN
|
||
|
|
GO TO 604
|
||
|
|
ELSEIF(IFLAG .EQ. 'q') THEN
|
||
|
|
CALL WRTOUT(0)
|
||
|
|
go to 4
|
||
|
|
ENDIF
|
||
|
|
XPRT=XPRT+0.5
|
||
|
|
IF(XPRT .GT. HSIZE) XPRT=0.
|
||
|
|
FPN= INODE
|
||
|
|
CALL NUMBR(XPRT,7.20,0.20,FPN,0.0,-1)
|
||
|
|
IF (IFLAG .EQ. 'c') THEN
|
||
|
|
SSO(INODE) = widslp
|
||
|
|
FPN = widslp
|
||
|
|
X = CORD(INODE,1)
|
||
|
|
Y = CORD(INODE,2) + .11
|
||
|
|
CALL RRED
|
||
|
|
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||
|
|
CALL RBLUE
|
||
|
|
endif
|
||
|
|
go to 605
|
||
|
|
!ipk mar02
|
||
|
|
!
|
||
|
|
! get bed slopes
|
||
|
|
!
|
||
|
|
elseif(iflag .eq. 'b') then
|
||
|
|
704 continue
|
||
|
|
call plotot(1)
|
||
|
|
CALL RCYAN
|
||
|
|
DO K=1,NE
|
||
|
|
IF(IMAT(K) .GT. 0) THEN
|
||
|
|
IF(NCORN(K) .LT. 6) THEN
|
||
|
|
IF(NCORN(K) .GT. 2 .AND. IMAT(K) .LT. 900) THEN
|
||
|
|
DO N=1,3,2
|
||
|
|
J=NOP(K,N)
|
||
|
|
FPN = BS1(J)
|
||
|
|
X = CORD(J,1)
|
||
|
|
Y = CORD(J,2) - .11
|
||
|
|
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||
|
|
enddo
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
enddo
|
||
|
|
CALL RBLUE
|
||
|
|
nmess=45
|
||
|
|
nhtp=0
|
||
|
|
nbrr=4
|
||
|
|
call flushwn
|
||
|
|
CALL HEDR
|
||
|
|
nmess=44
|
||
|
|
xprt=3.2
|
||
|
|
call getfpn(bedslp)
|
||
|
|
!
|
||
|
|
! Input new bed slopes
|
||
|
|
!
|
||
|
|
705 IBOX=1
|
||
|
|
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
!
|
||
|
|
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||
|
|
IFLAG=ANSW(IBOX)
|
||
|
|
ENDIF
|
||
|
|
IF(IFLAG .EQ. 'n') THEN
|
||
|
|
GO TO 704
|
||
|
|
ELSEIF(IFLAG .EQ. 'q') THEN
|
||
|
|
CALL WRTOUT(0)
|
||
|
|
go to 4
|
||
|
|
ENDIF
|
||
|
|
XPRT=XPRT+0.5
|
||
|
|
IF(XPRT .GT. HSIZE) XPRT=0.
|
||
|
|
FPN= INODE
|
||
|
|
CALL NUMBR(XPRT,7.20,0.20,FPN,0.0,-1)
|
||
|
|
IF (IFLAG .EQ. 'c') THEN
|
||
|
|
BS1(INODE) = bedslp
|
||
|
|
FPN = bedslp
|
||
|
|
X = CORD(INODE,1)
|
||
|
|
Y = CORD(INODE,2) + .11
|
||
|
|
CALL RRED
|
||
|
|
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||
|
|
CALL RBLUE
|
||
|
|
endif
|
||
|
|
go to 705
|
||
|
|
|
||
|
|
elseif(iflag .eq. 'q') then
|
||
|
|
return
|
||
|
|
endif
|
||
|
|
go to 4
|
||
|
|
END
|