!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 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 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)
        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(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 element frequency for search'&
      ,'Enter no. of elements to reverse '/


      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
    