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.
911 lines
33 KiB
Fortran
911 lines
33 KiB
Fortran
5 years ago
|
!IPK LAST UPDATE SEP 23 2015 ADD TESTING FOR CHNAGED ELEMENTS/NODES
|
||
|
|
! Last change: IPK 13 Jan 98 10:01 am
|
||
|
|
!ipk last update to add deletion opton when moving nodes
|
||
|
|
!ipk last update Jan 12 1998
|
||
|
|
!ipk last update Nov18 1997
|
||
|
|
!
|
||
|
|
!****************************************************************
|
||
|
|
!
|
||
|
|
SUBROUTINE ADDNOD
|
||
|
|
!
|
||
|
|
! Input additional node locations from screen
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
|
||
|
|
!IPK MAY02
|
||
|
|
INCLUDE 'TXFRM.COM'
|
||
|
|
!
|
||
|
|
CHARACTER*1 IFLAG,ANS,ANSW(0:9)
|
||
|
|
CHARACTER*32 JUNK
|
||
|
|
CHARACTER*20 NODH
|
||
|
|
!ipk jan98
|
||
|
|
CHARACTER*80 LIND
|
||
|
|
DATA ANSW/'a','m','d','f','g','e','h','z','r','q'/
|
||
|
|
data itime/0/
|
||
|
|
|
||
|
|
if(itime .eq. 0) then
|
||
|
|
nodsh=1
|
||
|
|
itime=1
|
||
|
|
endif
|
||
|
|
ISWT=3
|
||
|
|
!
|
||
|
|
! Draw box around selections
|
||
|
|
!
|
||
|
|
2 CONTINUE
|
||
|
|
NHTP=4
|
||
|
|
NMESS=0
|
||
|
|
NBRR=0
|
||
|
|
CALL HEDR
|
||
|
|
!
|
||
|
|
! Get answer
|
||
|
|
!
|
||
|
|
3 call xyloc(XPT,YPT,ANS,IBOX)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
!
|
||
|
|
|
||
|
|
IF(ANS .EQ. 'c') THEN
|
||
|
|
if(ibox .eq. 0) go to 3
|
||
|
|
I=IBOX-1
|
||
|
|
ANS=ANSW(I)
|
||
|
|
ENDIF
|
||
|
|
!
|
||
|
|
IF(ANS .EQ. 'a') THEN
|
||
|
|
ISWT=1
|
||
|
|
NHTP=0
|
||
|
|
NBRR=0
|
||
|
|
NMESS=16
|
||
|
|
ELSEIF(ANS .EQ. 'm') THEN
|
||
|
|
ISWT=0
|
||
|
|
NHTP=0
|
||
|
|
NBRR=0
|
||
|
|
NMESS=17
|
||
|
|
ELSEIF(ANS .EQ. 'd') THEN
|
||
|
|
!
|
||
|
|
! Call deleting operations
|
||
|
|
!
|
||
|
|
CALL DELOP
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
GO TO 2
|
||
|
|
ELSEIF(ANS .EQ. 'e') THEN
|
||
|
|
CALL GRIDSB(0)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
GO TO 2
|
||
|
|
ELSEIF(ANS .EQ. 'q') THEN
|
||
|
|
RETURN
|
||
|
|
ELSEIF(ANS .EQ. 'f') THEN
|
||
|
|
!
|
||
|
|
! Search for a plot a grid centered around a node
|
||
|
|
!
|
||
|
|
NHTP=0
|
||
|
|
NBRR=0
|
||
|
|
NMESS=1
|
||
|
|
CALL HEDR
|
||
|
|
NMESS=1
|
||
|
|
CALL GETINT(NODSH)
|
||
|
|
IF(INEW(NODSH) .LE. 0) GO TO 2
|
||
|
|
DO 4 I=1,NP
|
||
|
|
IF(CORD(I,1) .GT. VOID) THEN
|
||
|
|
INSKP(I)=0
|
||
|
|
ENDIF
|
||
|
|
4 CONTINUE
|
||
|
|
DO 5 I=1,NE
|
||
|
|
IF(IMAT(I) .GT. 0) THEN
|
||
|
|
IESKP(I)=0
|
||
|
|
ENDIF
|
||
|
|
5 CONTINUE
|
||
|
|
XP=CORD(NODSH,1)
|
||
|
|
YP=CORD(NODSH,2)
|
||
|
|
XMIN=XP-5.0*PSCALE
|
||
|
|
YMIN=YP-3.5*PSCALE
|
||
|
|
!ipk nov97 add (1)
|
||
|
|
CALL PLOTOT(1)
|
||
|
|
FPN=NODSH
|
||
|
|
HT=0.15
|
||
|
|
XP=CORD(NODSH,1)
|
||
|
|
YP=CORD(NODSH,2)
|
||
|
|
CALL RCYAN
|
||
|
|
CALL NUMBR(XP,YP+0.07,HT,FPN,0.0,-1)
|
||
|
|
CALL RBLUE
|
||
|
|
!
|
||
|
|
GO TO 2
|
||
|
|
ELSEIF(ANS .EQ. 'g') THEN
|
||
|
|
!
|
||
|
|
! This option generates nodes on a line
|
||
|
|
!
|
||
|
|
CALL GNODE(1)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
GO TO 2
|
||
|
|
ELSEIF(ANS .EQ. 'h') THEN
|
||
|
|
CALL HELPS(3)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
GO TO 2
|
||
|
|
ELSE
|
||
|
|
GO TO 3
|
||
|
|
ENDIF
|
||
|
|
6 CONTINUE
|
||
|
|
!
|
||
|
|
! Test for adding operation
|
||
|
|
!
|
||
|
|
IF(ISWT .EQ. 1) THEN
|
||
|
|
!
|
||
|
|
CALL GETNOD(J)
|
||
|
|
CALL GETNOD(J)
|
||
|
|
CALL GETNOD(J)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
!
|
||
|
|
! Get number of node nearest cursor (if ISWT = 0)
|
||
|
|
!
|
||
|
|
ELSE
|
||
|
|
61 IBOX=1
|
||
|
|
! CALL CLRBOX
|
||
|
|
CALL HEDR
|
||
|
|
!ipk jan98
|
||
|
|
call wrtbox(idelv)
|
||
|
|
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
!ipk jan98 add option for deleting elevation on move
|
||
|
|
IF(IBOX .EQ. 7 .or. iflag .eq. 'e') THEN
|
||
|
|
IDELV=MOD(IDELV+1,2)
|
||
|
|
GO TO 61
|
||
|
|
ENDIF
|
||
|
|
J=INODE
|
||
|
|
!ipk jan98
|
||
|
|
if(idelv .eq. 1) then
|
||
|
|
WD(J)=-9999.
|
||
|
|
WIDTH(J)=0.
|
||
|
|
SS1(J)=0.
|
||
|
|
SS2(J)=0.
|
||
|
|
WIDS(J)=0.
|
||
|
|
WIDBS(J)=0.
|
||
|
|
SSO(J)=0.
|
||
|
|
endif
|
||
|
|
!ipk jan98
|
||
|
|
!
|
||
|
|
IF(IFLAG .EQ. 'q') THEN
|
||
|
|
!ipk feb94 CALL WRTOUT(0)
|
||
|
|
GO TO 2
|
||
|
|
ENDIF
|
||
|
|
CALL PLTNOD(J,1)
|
||
|
|
!
|
||
|
|
ENDIF
|
||
|
|
!
|
||
|
|
! Deleting operation
|
||
|
|
!
|
||
|
|
IF(ISWT .EQ. 2) THEN
|
||
|
|
WRITE(NODH,5000) j
|
||
|
|
! CALL CLRBOX
|
||
|
|
CALL HEDR
|
||
|
|
CALL SYMBL(0.,7.70,0.20,NODH,0.,20)
|
||
|
|
CALL DELETN(J)
|
||
|
|
GO TO 6
|
||
|
|
ENDIF
|
||
|
|
WRITE(NODH,5000) j
|
||
|
|
5000 FORMAT('Processing node',i5)
|
||
|
|
7 CALL CLRBOX
|
||
|
|
CALL SYMBL(0.,7.70,0.20,NODH,0.,20)
|
||
|
|
NHTP=0
|
||
|
|
! NMESS=0
|
||
|
|
NBRR=3
|
||
|
|
IF(ISWT .EQ. 0) then
|
||
|
|
NMESS=16
|
||
|
|
endif
|
||
|
|
CALL HEDR
|
||
|
|
!
|
||
|
|
IF (J .GE. MAXP) THEN
|
||
|
|
CALL SETD(23)
|
||
|
|
!IPK JAN98 WRITE(*,*) ' Node number exceeds MAXP '
|
||
|
|
!IPK JAN98 WRITE(*,*) ' Enter -save- to save the file as is'
|
||
|
|
!IPK JAN98 WRITE(*,*) ' Enter -quit- to terminate'
|
||
|
|
!IPK JAN98 READ(*,'(A)') JUNK
|
||
|
|
CALL CLSCRN()
|
||
|
|
WRITE(LIND,*) ' Node number exceeds MAXP '
|
||
|
|
call symbl &
|
||
|
|
& (1.1,4.6,0.25,LIND,0.0,80)
|
||
|
|
WRITE(LIND,*) ' Enter -save- to save the file as is'
|
||
|
|
call symbl &
|
||
|
|
& (1.1,4.1,0.25,LIND,0.0,80)
|
||
|
|
WRITE(LIND,*) ' Enter -quit- to terminate'
|
||
|
|
call symbl &
|
||
|
|
& (1.1,3.8,0.25,LIND,0.0,80)
|
||
|
|
ndig=4
|
||
|
|
CALL GTCHARX(JUNK,NDIG,5.0,4.0)
|
||
|
|
IF(JUNK .NE. 'save') THEN
|
||
|
|
CALL WRTOUT(0)
|
||
|
|
CALL Quit_Pgm()
|
||
|
|
stop
|
||
|
|
else
|
||
|
|
call wrtout(1)
|
||
|
|
CALL Quit_Pgm()
|
||
|
|
stop
|
||
|
|
ENDIF
|
||
|
|
!ipk an97 RETURN
|
||
|
|
ENDIF
|
||
|
|
!
|
||
|
|
! Get screen coordinate of node
|
||
|
|
!
|
||
|
|
CALL XYLOC(XX,YY,IFLAG,IBOX)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
IF(IFLAG .EQ. 'q' .OR. (IFLAG .EQ. 'c' .AND. IBOX .EQ. 10))THEN
|
||
|
|
!ipk feb94 CALL WRTOUT(0)
|
||
|
|
! IF(ISWT .EQ. 2) NP=NP-1
|
||
|
|
if(inew(j) .eq. 0 .and. j .eq. np) np=np-1
|
||
|
|
GO TO 2
|
||
|
|
ENDIF
|
||
|
|
!
|
||
|
|
IF (IFLAG .EQ. 'c') THEN
|
||
|
|
!
|
||
|
|
IF(YY .GT. 7.5) THEN
|
||
|
|
CALL DELETN(J)
|
||
|
|
GO TO 6
|
||
|
|
ENDIF
|
||
|
|
INSKP(J)=0
|
||
|
|
CORD(J,1) = XX
|
||
|
|
CORD(J,2) = YY
|
||
|
|
INEW(J) = 1
|
||
|
|
!
|
||
|
|
XUSR(J) = XX*TXSCAL - XS
|
||
|
|
YUSR(J) = YY*TXSCAL - YS
|
||
|
|
IF (J .GT. NP) NP = J
|
||
|
|
! WRITE(IOT,'(I10,2F10.3)') J, XUSR(J),YUSR(J)
|
||
|
|
CALL PLTNOD(J,0)
|
||
|
|
ICHG=0
|
||
|
|
!
|
||
|
|
IF(ISWT .EQ. 0) NMESS=17
|
||
|
|
GOTO 6
|
||
|
|
ENDIF
|
||
|
|
RETURN
|
||
|
|
!
|
||
|
|
END
|
||
|
|
!
|
||
|
|
!****************************************************************
|
||
|
|
!
|
||
|
|
SUBROUTINE ADDPTH
|
||
|
|
!
|
||
|
|
! Add nodal bottom elevations
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
!
|
||
|
|
CHARACTER*1 IFLAG,ANSW(10)
|
||
|
|
DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/
|
||
|
|
DATA NTYPP,NLOCC,BELEV/1,0,0./
|
||
|
|
!
|
||
|
|
4 CONTINUE
|
||
|
|
NHTP = 0
|
||
|
|
NMESS = 45
|
||
|
|
NBRR = 0
|
||
|
|
CALL HEDR
|
||
|
|
xprt=3.2
|
||
|
|
NMESS = 14
|
||
|
|
!
|
||
|
|
CALL ADJUSTOPT(NTYPP,NLOCC)
|
||
|
|
|
||
|
|
CALL GETFPN(BELEV)
|
||
|
|
!
|
||
|
|
! Write out current depths
|
||
|
|
!
|
||
|
|
7 HT = .15
|
||
|
|
DO 10 J=1,NP
|
||
|
|
IF(INSKP(J) .EQ. 0) THEN
|
||
|
|
IF (CORD(J,1) .GT. VDX) THEN
|
||
|
|
!!SEP02 FPN = WD(J)*10.
|
||
|
|
FPN = WD(J)
|
||
|
|
X = CORD(J,1)
|
||
|
|
Y = CORD(J,2) + .07
|
||
|
|
IF(X .GT. 0. .AND. X .LT. 10.0 .AND. &
|
||
|
|
& Y .GT. 0. .AND. Y .LT. 7.5) THEN
|
||
|
|
!!SEP02 CALL NUMBR(X,Y,HT,FPN,0.0,-1)
|
||
|
|
call numbr(x,y,0.12,fpn,0.0,1)
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
10 END DO
|
||
|
|
!
|
||
|
|
! Input new depths
|
||
|
|
!
|
||
|
|
NMESS = 15
|
||
|
|
NBRR = 4
|
||
|
|
CALL HEDR
|
||
|
|
5 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. 'q') THEN
|
||
|
|
!ipk feb94 CALL WRTOUT(0)
|
||
|
|
RETURN
|
||
|
|
ELSEIF(IFLAG .EQ. 'e' .OR. IFLAG .EQ. 'n') THEN
|
||
|
|
!ipk nov97 add (1)
|
||
|
|
CALL PLOTOT(1)
|
||
|
|
GO TO 4
|
||
|
|
ENDIF
|
||
|
|
XPRT=XPRT+0.5
|
||
|
|
IF(XPRT .GT. 10.) XPRT=0.
|
||
|
|
FPN= INODE
|
||
|
|
CALL RRED
|
||
|
|
CALL NUMBR(XPRT,7.70,HT,FPN,0.0,-1)
|
||
|
|
IF (IFLAG .EQ. 'c') THEN
|
||
|
|
IF(NTYPP .EQ. 1) THEN
|
||
|
|
WD(INODE) = BELEV
|
||
|
|
ELSE
|
||
|
|
WD(INODE) = WD(INODE)+BELEV
|
||
|
|
ENDIF
|
||
|
|
IF(NLOCC .EQ. 1) THEN
|
||
|
|
LOCK(INODE)=1
|
||
|
|
ENDIF
|
||
|
|
ichg=0
|
||
|
|
FPN = WD(INODE)
|
||
|
|
X = CORD(INODE,1)
|
||
|
|
Y = CORD(INODE,2) -0.10
|
||
|
|
call numbr(x,y,0.12,fpn,0.0,1)
|
||
|
|
!!SEP02 CALL NUMBR(X,Y,HT,FPN,0.0,-1)
|
||
|
|
CALL RBLUE
|
||
|
|
!
|
||
|
|
ELSEIF(IFLAG .EQ. 'a') THEN
|
||
|
|
CALL RRED
|
||
|
|
ichg=0
|
||
|
|
DO 100 J=1,NP
|
||
|
|
IF (CORD(J,1) .GE. VDX) THEN
|
||
|
|
WD(J)=BELEV
|
||
|
|
FPN=BELEV
|
||
|
|
X = CORD(J,1)
|
||
|
|
Y = CORD(J,2) + .11
|
||
|
|
CALL NUMBR(X,Y,HT,FPN,0.0,-1)
|
||
|
|
ENDIF
|
||
|
|
100 CONTINUE
|
||
|
|
CALL RBLUE
|
||
|
|
CALL WRTOUT(0)
|
||
|
|
ELSEIF(IFLAG .EQ. 'f') THEN
|
||
|
|
CALL RRED
|
||
|
|
DO 110 J=1,NP
|
||
|
|
IF (CORD(J,1) .GE. VDX .AND. WD(J) .LT. -9000.) THEN
|
||
|
|
WD(J)=BELEV
|
||
|
|
ichg=0
|
||
|
|
FPN=BELEV
|
||
|
|
X = CORD(J,1)
|
||
|
|
Y = CORD(J,2) + .11
|
||
|
|
CALL NUMBR(X,Y,HT,FPN,0.0,-1)
|
||
|
|
ENDIF
|
||
|
|
110 CONTINUE
|
||
|
|
CALL RBLUE
|
||
|
|
CALL WRTOUT(0)
|
||
|
|
!
|
||
|
|
ELSE
|
||
|
|
!ipk jan98 WRITE(*,*) CHAR(7),CHAR(7)
|
||
|
|
ENDIF
|
||
|
|
!
|
||
|
|
GOTO 5
|
||
|
|
!
|
||
|
|
END
|
||
|
|
!
|
||
|
|
SUBROUTINE JUNGEN(J,I,IERR)
|
||
|
|
!
|
||
|
|
! Find elements coming into node J, change all but first node
|
||
|
|
! Form a new junction element
|
||
|
|
!
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
|
||
|
|
!IPK MAY02
|
||
|
|
INCLUDE 'TXFRM.COM'
|
||
|
|
|
||
|
|
!
|
||
|
|
KOUNT=1
|
||
|
|
DO 200 N=1,NE
|
||
|
|
!IPKOCT93 IF(IMAT(N) .GT. 0 .AND. IMAT(N) .LT. 901) THEN
|
||
|
|
IF(IMAT(N) .GT. 0 .AND. (IMAT(N) .LT. 901 .OR. &
|
||
|
|
& IMAT(N) .GT. 903) ) THEN
|
||
|
|
DO 180 K=1,8
|
||
|
|
IF(NOP(N,K) .EQ. I) THEN
|
||
|
|
IF(K .GT. 3) THEN
|
||
|
|
IERR=1
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
IF(KOUNT .EQ. 1) THEN
|
||
|
|
NOP(J,1)=I
|
||
|
|
IJUN(J)=1
|
||
|
|
KOUNT=2
|
||
|
|
ELSE
|
||
|
|
CALL GETNOD(N2)
|
||
|
|
NOP(J,KOUNT)=N2
|
||
|
|
IJUN(N2)=KOUNT
|
||
|
|
KOUNT=KOUNT+1
|
||
|
|
CORD(N2,1) = CORD(I,1)
|
||
|
|
CORD(N2,2) = CORD(I,2)
|
||
|
|
WD(N2)=WD(I)
|
||
|
|
WIDTH(N2) = WIDTH(I)
|
||
|
|
SS1(N2)=SS1(I)
|
||
|
|
SS2(N2)=SS2(I)
|
||
|
|
WIDS(N2)=WIDS(I)
|
||
|
|
INSKP(N2)=0
|
||
|
|
INEW(N2) = 1
|
||
|
|
NOP(N,K) = N2
|
||
|
|
!
|
||
|
|
XUSR(N2) = CORD(N2,1)*TXSCAL - XS
|
||
|
|
YUSR(N2) = CORD(N2,2)*TXSCAL - YS
|
||
|
|
CALL PLTNOD(N2,1)
|
||
|
|
GO TO 200
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
180 CONTINUE
|
||
|
|
ENDIF
|
||
|
|
200 END DO
|
||
|
|
IF(KOUNT .LT. 9) THEN
|
||
|
|
DO 300 K=KOUNT,8
|
||
|
|
NOP(J,K)=0
|
||
|
|
300 CONTINUE
|
||
|
|
ENDIF
|
||
|
|
IMAT(J)=901
|
||
|
|
IESKP(J)=1
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
!
|
||
|
|
!****************************************************************
|
||
|
|
!
|
||
|
|
SUBROUTINE ELDAT
|
||
|
|
!
|
||
|
|
! Add bottom elevations to message file and display
|
||
|
|
!
|
||
|
|
USE BLKMAP
|
||
|
|
USE BLK1MOD
|
||
|
|
USE WINTERACTER
|
||
|
|
|
||
|
|
include 'd.inc'
|
||
|
|
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
|
||
|
|
!IPK MAY02
|
||
|
|
INCLUDE 'TXFRM.COM'
|
||
|
|
!
|
||
|
|
CHARACTER*1 IFLAG,ANSW(10)
|
||
|
|
CHARACTER(LEN=256) :: FILTER
|
||
|
|
CHARACTER(LEN=255) :: FNAME
|
||
|
|
CHARACTER(LEN=3) :: SUB
|
||
|
|
LOGICAL :: OPENED
|
||
|
|
DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/
|
||
|
|
!
|
||
|
|
!ipk mar00
|
||
|
|
jp=2
|
||
|
|
DO 200 N=1,MAXLIN
|
||
|
|
IF(LINTYP(N) .EQ. -999) THEN
|
||
|
|
NLIN=N
|
||
|
|
GO TO 205
|
||
|
|
ENDIF
|
||
|
|
200 END DO
|
||
|
|
205 CONTINUE
|
||
|
|
IF(NLIN .GT. 1) THEN
|
||
|
|
IF(LINTYP(NLIN-1) .NE. 2) THEN
|
||
|
|
LINTYP(NLIN)=2
|
||
|
|
ELSE
|
||
|
|
NLIN=NLIN-1
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
DO 250 J=MAXPL,1,-1
|
||
|
|
IF(CMAP(J,1) .GE. VDX) THEN
|
||
|
|
JP=J+1
|
||
|
|
GO TO 255
|
||
|
|
ENDIF
|
||
|
|
250 END DO
|
||
|
|
255 JP=JP-1
|
||
|
|
IPSW(6)=1
|
||
|
|
!ipk nov97 add (1)
|
||
|
|
CALL PLOTOT(1)
|
||
|
|
write(90,6010)
|
||
|
|
6010 format(' The lines that follow are locations and new bottom ' &
|
||
|
|
& ,'elevations.'/' Note that a zoom operation may insert'&
|
||
|
|
& ,' other information')
|
||
|
|
!
|
||
|
|
4 CONTINUE
|
||
|
|
NHTP = 0
|
||
|
|
NMESS = 45
|
||
|
|
NBRR = 0
|
||
|
|
CALL HEDR
|
||
|
|
!
|
||
|
|
NMESS = 14
|
||
|
|
CALL GETFPN(BELEV)
|
||
|
|
!
|
||
|
|
! Input new depths
|
||
|
|
!
|
||
|
|
7 CONTINUE
|
||
|
|
NMESS = 15
|
||
|
|
NBRR = 4
|
||
|
|
CALL HEDR
|
||
|
|
!
|
||
|
|
! Get screen coordinates
|
||
|
|
!
|
||
|
|
IBOX = 0
|
||
|
|
CALL XYLOC(XX,YY,IFLAG,IBOX)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||
|
|
IFLAG=ANSW(IBOX)
|
||
|
|
ENDIF
|
||
|
|
IF(IFLAG .EQ. 'q')THEN
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
IF(IFLAG .EQ. 'e') THEN
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
IF(IFLAG .EQ. 'n')THEN
|
||
|
|
GO TO 4
|
||
|
|
ENDIF
|
||
|
|
!
|
||
|
|
IF (IFLAG .EQ. 'c') THEN
|
||
|
|
!
|
||
|
|
JP=JP+1
|
||
|
|
CMAP(JP,1) = XX
|
||
|
|
CMAP(JP,2) = YY
|
||
|
|
VAL(JP)=BELEV
|
||
|
|
!
|
||
|
|
XMAP(JP) = XX*TXSCAL - XS
|
||
|
|
YMAP(JP) = YY*TXSCAL - YS
|
||
|
|
IMAPOUT=27
|
||
|
|
INQUIRE(27, OPENED=OPENED)
|
||
|
|
if(.not. opened) then
|
||
|
|
Filter='MAP file -- *.map|*.map|'
|
||
|
|
|
||
|
|
CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Map Data File')
|
||
|
|
|
||
|
|
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||
|
|
|
||
|
|
CALL IlowerCase(FNAME)
|
||
|
|
CALL GETSUB(FNAME,SUB)
|
||
|
|
OPEN(IMAPOUT,FILE=FNAME,STATUS='UNKNOWN',ACTION='WRITE')
|
||
|
|
WRITE(IMAPOUT,*) '2,0'
|
||
|
|
ELSE
|
||
|
|
GO TO 260
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
WRITE(IMAPOUT,6000) XMAP(JP),YMAP(JP),VAL(JP)
|
||
|
|
260 CONTINUE
|
||
|
|
WRITE(90,6000) XMAP(JP),YMAP(JP),VAL(JP)
|
||
|
|
6000 FORMAT(3F16.4)
|
||
|
|
FPN = BELEV
|
||
|
|
HT=0.15
|
||
|
|
CALL RRED
|
||
|
|
CALL NUMBR(XX,YY,HT,FPN,0.0,-1)
|
||
|
|
!
|
||
|
|
GOTO 7
|
||
|
|
!
|
||
|
|
ELSE
|
||
|
|
!ipk jan98 WRITE(*,*) CHAR(7),CHAR(7)
|
||
|
|
ENDIF
|
||
|
|
!
|
||
|
|
GOTO 7
|
||
|
|
!
|
||
|
|
END
|
||
|
|
!
|
||
|
|
SUBROUTINE DELOP
|
||
|
|
!
|
||
|
|
! Input additional delete options from screen
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
|
||
|
|
!IPK MAY02
|
||
|
|
INCLUDE 'TXFRM.COM'
|
||
|
|
|
||
|
|
INCLUDE 'BFILES.I90'
|
||
|
|
|
||
|
|
!
|
||
|
|
CHARACTER*1 IFLAG,ANS,ANSW(0:9)
|
||
|
|
CHARACTER*20 NODH
|
||
|
|
DATA ANSW/'l','m','g','u','f','j','h','z','r','q'/
|
||
|
|
!
|
||
|
|
! Draw box around selections
|
||
|
|
!
|
||
|
|
2 CONTINUE
|
||
|
|
NHTP=10
|
||
|
|
NMESS=0
|
||
|
|
NBRR=0
|
||
|
|
CALL HEDR
|
||
|
|
!
|
||
|
|
! Get answer
|
||
|
|
!
|
||
|
|
3 call xyloc(XPT,YPT,ANS,IBOX)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
!
|
||
|
|
IF(ANS .EQ. 'c') THEN
|
||
|
|
if(ibox .eq. 0) go to 3
|
||
|
|
I=IBOX-1
|
||
|
|
ANS=ANSW(I)
|
||
|
|
ENDIF
|
||
|
|
IF(ANS .EQ. 'l') THEN
|
||
|
|
!
|
||
|
|
! Delete all midside nodes
|
||
|
|
!
|
||
|
|
CALL DELETM(0)
|
||
|
|
ELSEIF(ANS .EQ. 'm') THEN
|
||
|
|
!
|
||
|
|
! Delete all center located midsides
|
||
|
|
!
|
||
|
|
CALL DELETM(1)
|
||
|
|
ELSEIF(ANS .EQ. 'g') THEN
|
||
|
|
!
|
||
|
|
! Deleting operation for nodes
|
||
|
|
!
|
||
|
|
NHTP=0
|
||
|
|
NBRR=3
|
||
|
|
NMESS=18
|
||
|
|
|
||
|
|
6 CONTINUE
|
||
|
|
!
|
||
|
|
IBOX=1
|
||
|
|
CALL HEDR
|
||
|
|
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
J=INODE
|
||
|
|
!
|
||
|
|
IF(IFLAG .EQ. 'q') THEN
|
||
|
|
!ipk feb94 CALL WRTOUT(0)
|
||
|
|
GO TO 2
|
||
|
|
ENDIF
|
||
|
|
CALL PLTNOD(J,1)
|
||
|
|
!
|
||
|
|
WRITE(NODH,5000) j
|
||
|
|
5000 FORMAT('Processing node',i5)
|
||
|
|
CALL HEDR
|
||
|
|
CALL SYMBL(0.,7.70,0.20,NODH,0.,20)
|
||
|
|
CALL DELETN(J)
|
||
|
|
IRDONE=0
|
||
|
|
GO TO 6
|
||
|
|
ELSEIF(ANS .EQ. 'u') THEN
|
||
|
|
!
|
||
|
|
! Delete all unused nodes
|
||
|
|
!
|
||
|
|
CALL DELETM(2)
|
||
|
|
ELSEIF(ANS .EQ. 'j') THEN
|
||
|
|
!
|
||
|
|
! Join two nodes together in the element lists
|
||
|
|
!
|
||
|
|
CALL JOIN(1)
|
||
|
|
ELSEIF(ANS .EQ. 'f') THEN
|
||
|
|
!
|
||
|
|
! Fill midside nodes
|
||
|
|
!
|
||
|
|
!ipk aug02
|
||
|
|
CALL FILM(0)
|
||
|
|
ELSEIF(ANS .EQ. 'h') THEN
|
||
|
|
CALL HELPS(7)
|
||
|
|
ELSEIF(ANS .EQ. 'q') THEN
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
GO TO 2
|
||
|
|
END
|
||
|
|
!
|
||
|
|
SUBROUTINE JOIN(ISWTJ)
|
||
|
|
!
|
||
|
|
! Routine to join references to two nodes
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
CHARACTER*1 IFLAG
|
||
|
|
!
|
||
|
|
61 IBOX=1
|
||
|
|
NHTP=0
|
||
|
|
NBRR=3
|
||
|
|
NMESS=15
|
||
|
|
CALL HEDR
|
||
|
|
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||
|
|
IF(IFLAG .EQ. 'q') THEN
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
FPN= INODE
|
||
|
|
CALL NUMBR(2.0,7.70,0.2,FPN,0.0,-1)
|
||
|
|
! CALL PROX(CORD(1,1),CORD(1,2),NP,XX2,YY2,INODE2,IFLAG,INSKP,IBOX)
|
||
|
|
! IF(IFLAG .EQ. 'q') THEN
|
||
|
|
! RETURN
|
||
|
|
! ELSEIF(INODE2 .EQ. INODE) THEN
|
||
|
|
!
|
||
|
|
! Get second node
|
||
|
|
!
|
||
|
|
CALL PROX2(CORD(1,1),CORD(1,2),NP,XX,YY,INODE, &
|
||
|
|
& XX2,YY2,INODE2,IFLAG,INSKP,IBOX)
|
||
|
|
IF(IFLAG .EQ. 'q') THEN
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
! ENDIF
|
||
|
|
! FPN= INODE2
|
||
|
|
! CALL NUMBR(2.5,7.70,0.2,FPN,0.0,-1)
|
||
|
|
|
||
|
|
INODE1=INODE
|
||
|
|
CALL JOINDEL(INODE1,INODE2)
|
||
|
|
|
||
|
|
CALL PLOTOT(1)
|
||
|
|
GO TO 61
|
||
|
|
! ENDIF
|
||
|
|
END
|
||
|
|
|
||
|
|
SUBROUTINE JOINDEL(INODE1,INODE2)
|
||
|
|
! Routine to join references to two nodes
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
!
|
||
|
|
! Search for references to INODE2
|
||
|
|
!
|
||
|
|
DO N=1,NE
|
||
|
|
NCN=NCORN(N)
|
||
|
|
IF(NCN .GT. 0) THEN
|
||
|
|
DO M=1,NCN
|
||
|
|
IF(NOP(N,M) .EQ. INODE2) THEN
|
||
|
|
!
|
||
|
|
! Change them to INODE
|
||
|
|
!
|
||
|
|
NOP(N,M)=INODE1
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
!
|
||
|
|
! Remove node now
|
||
|
|
!
|
||
|
|
CORD(INODE2,1)=VOID
|
||
|
|
CORD(INODE2,2)=VOID
|
||
|
|
XUSR(INODE2) = VOID
|
||
|
|
YUSR(INODE2) = VOID
|
||
|
|
INSKP(INODE2)=1
|
||
|
|
INEW(INODE2) = 0
|
||
|
|
WD(INODE2)=-9999.
|
||
|
|
WIDTH(INODE2)=0.
|
||
|
|
SS1(INODE2)=0.
|
||
|
|
SS2(INODE2)=0.
|
||
|
|
WIDS(INODE2)=0.
|
||
|
|
!IPK MAY03
|
||
|
|
ICHG=0
|
||
|
|
!ipk nov97 add (1)
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
SUBROUTINE JOINALL
|
||
|
|
USE BLK1MOD
|
||
|
|
|
||
|
|
NMESS = 46
|
||
|
|
TOLER=0.1
|
||
|
|
CALL GETFPN(TOLER)
|
||
|
|
|
||
|
|
DO N=1,NP-1
|
||
|
|
IF(CORD(N,1) .EQ. VOID) CYCLE
|
||
|
|
DO M=N+1,NP
|
||
|
|
IF(CORD(M,1) .EQ. VOID) CYCLE
|
||
|
|
DIST=SQRT((YUSR(M)-YUSR(N))**2+(XUSR(M)-XUSR(N))**2)
|
||
|
|
IF(DIST .LT. TOLER) THEN
|
||
|
|
CALL JOINDEL(N,M)
|
||
|
|
GO TO 100
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
100 CONTINUE
|
||
|
|
ENDDO
|
||
|
|
|
||
|
|
CALL PLOTOT(1)
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
!****************************************************************
|
||
|
|
!
|
||
|
|
SUBROUTINE ADDPTH2(nodlist,ndlist)
|
||
|
|
!
|
||
|
|
! Add nodal bottom elevations
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
!
|
||
|
|
CHARACTER*1 IFLAG,ANSW(10)
|
||
|
|
|
||
|
|
dimension nodlist(*)
|
||
|
|
|
||
|
|
DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/
|
||
|
|
DATA NTYPP,NLOCC/1,0/
|
||
|
|
!
|
||
|
|
4 CONTINUE
|
||
|
|
NHTP = 0
|
||
|
|
NMESS = 45
|
||
|
|
NBRR = 0
|
||
|
|
CALL HEDR
|
||
|
|
xprt=3.2
|
||
|
|
NMESS = 14
|
||
|
|
!
|
||
|
|
CALL ADJUSTOPT(NTYPP,NLOCC)
|
||
|
|
|
||
|
|
CALL GETFPN(BELEV)
|
||
|
|
!
|
||
|
|
! Write out current depths
|
||
|
|
!
|
||
|
|
7 HT = .15
|
||
|
|
DO 10 J=1,NP
|
||
|
|
IF(INSKP(J) .EQ. 0) THEN
|
||
|
|
IF (CORD(J,1) .GT. VDX) THEN
|
||
|
|
!!SEP02 FPN = WD(J)*10.
|
||
|
|
FPN = WD(J)
|
||
|
|
X = CORD(J,1)
|
||
|
|
Y = CORD(J,2) + .07
|
||
|
|
IF(X .GT. 0. .AND. X .LT. HSIZE .AND. &
|
||
|
|
& Y .GT. 0. .AND. Y .LT. 7.5) THEN
|
||
|
|
!!SEP02 CALL NUMBR(X,Y,HT,FPN,0.0,-1)
|
||
|
|
call numbr(x,y,0.12,fpn,0.0,1)
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
10 END DO
|
||
|
|
!
|
||
|
|
! Input new depths
|
||
|
|
!
|
||
|
|
DO J=1,NDLIST
|
||
|
|
INODE=NODLIST(J)
|
||
|
|
FPN= INODE
|
||
|
|
CALL RRED
|
||
|
|
|
||
|
|
IF(NTYPP .EQ. 1) THEN
|
||
|
|
WD(INODE) = BELEV
|
||
|
|
ELSE
|
||
|
|
WD(INODE) = WD(INODE)+BELEV
|
||
|
|
ENDIF
|
||
|
|
IF(NLOCC .EQ. 1) THEN
|
||
|
|
LOCK(INODE)=1
|
||
|
|
ENDIF
|
||
|
|
ichg=0
|
||
|
|
FPN = WD(INODE)
|
||
|
|
X = CORD(INODE,1)
|
||
|
|
Y = CORD(INODE,2) -0.10
|
||
|
|
call numbr(x,y,0.12,fpn,0.0,1)
|
||
|
|
!!SEP02 CALL NUMBR(X,Y,HT,FPN,0.0,-1)
|
||
|
|
CALL RBLUE
|
||
|
|
ENDDO
|
||
|
|
!
|
||
|
|
!
|
||
|
|
RETURN
|
||
|
|
!
|
||
|
|
END
|
||
|
|
!
|
||
|
|
SUBROUTINE FINDNOD
|
||
|
|
!
|
||
|
|
! Search for a plot a grid centered around a node
|
||
|
|
!
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
|
||
|
|
!IPK MAY02
|
||
|
|
INCLUDE 'TXFRM.COM'
|
||
|
|
!
|
||
|
|
NHTPSAV=NHTP
|
||
|
|
NMESSAV=NMESS
|
||
|
|
NBRRSAV=NBRR
|
||
|
|
NHTP=0
|
||
|
|
NBRR=0
|
||
|
|
NMESS=1
|
||
|
|
CALL HEDR
|
||
|
|
NMESS=1
|
||
|
|
CALL GETINT(NODSH)
|
||
|
|
IF(INEW(NODSH) .LE. 0) RETURN
|
||
|
|
DO 4 I=1,NP
|
||
|
|
IF(CORD(I,1) .GT. VOID) THEN
|
||
|
|
INSKP(I)=0
|
||
|
|
ENDIF
|
||
|
|
4 CONTINUE
|
||
|
|
DO 5 I=1,NE
|
||
|
|
IF(IMAT(I) .GT. 0) THEN
|
||
|
|
IESKP(I)=0
|
||
|
|
ENDIF
|
||
|
|
5 CONTINUE
|
||
|
|
XP=CORD(NODSH,1)
|
||
|
|
YP=CORD(NODSH,2)
|
||
|
|
XMIN=XP-5.0*PSCALE
|
||
|
|
YMIN=YP-3.5*PSCALE
|
||
|
|
!ipk nov97 add (1)
|
||
|
|
CALL PLOTOT(1)
|
||
|
|
FPN=NODSH
|
||
|
|
HT=0.15
|
||
|
|
XP=CORD(NODSH,1)
|
||
|
|
YP=CORD(NODSH,2)
|
||
|
|
CALL RCYAN
|
||
|
|
CALL NUMBR(XP,YP+0.07,HT,FPN,0.0,-1)
|
||
|
|
CALL RBLUE
|
||
|
|
NHTP=NHTPSAV
|
||
|
|
NMESS=NMESSAV
|
||
|
|
NBRR=NBRRSAV
|
||
|
|
CALL HEDR
|
||
|
|
!
|
||
|
|
RETURN
|
||
|
|
END
|