!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,ISWBAK) ! ! 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 IF(ISWBAK .EQ. 1) THEN WD(INODE) = WDBAK(INODE)+BELEV ELSE WD(INODE) = WD(INODE)+BELEV ENDIF 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