      PROGRAM HSCTM
************************************************************************
*                                                                      *
*     HYDRODYNAMIC/SEDIMENT TRANSPORT/CONTAMINANT TRANSPORT            *
*     MODELING SYSTEM: HSCTM-2D                                        *
*                                                                      *
*     Version 1.00     August 1997                                     *
*                                                                      *
*     TWO-DIMENSIONAL, VERTICALLY INTEGRATED FINITE ELEMENT PROGRAM    *
*                                                                      *
*     CONSISTS OF TWO COUPLED MODULES:                                 *
*                                                                      *
*           HYDRO2D (hydrodynamics & salt transport)                   *
*           CS2D    (sediment & contaminant transport)                 *
*                                                                      *
*     This program uses metric units (SI). Thus, the SI card in the    *
*     input geometry and boundary condition files for HYDRO2D          *
*     should be set equal to 1.                                        *
*                                                                      *
*     LANGUAGE: FORTRAN77                                              *
*                                                                      *
*     SMS software should be used to generate, modify and plot         *
*     the finite element grid used by HSCTM.  Please see User          *
*     Manual for information on SMS.                                   *
*                                                                      *
*     DEVELOPED BY: Earl J. Hayter                                     *
*                   Department of Civil Engineering                    *
*                   Clemson University                                 *
*                   Clemson, South Carolina 29634-0911                 *
*                   864.656.3320                                       *
*                   ejh@ces.clemson.edu                                *
*                                                                      *
************************************************************************
      INCLUDE 'hsctm.inc'
      CHARACTER*73 TITLE1,TITLE2,TITLE3
      CHARACTER*32 FNAM,FNAM2
      IOUT=3
      IVOUT=1
      IN5=5
      IN8=80
      LP=8
      NSTEP=0
      NSTIME=1
      ICYC=0
      ND1=9
      ND2=10
      INT1=50
      INT2=51
      INT3=52
      ISPRT=59
      IGEON=60
      IBUP=61
      IHOTO=62
      IHOTN=63
      IFINO=64
      LPDR2=72
      LPCBP=73
      ISWIT=0
      WRITE (*,6001)
C 6001 FORMAT (' Enter control file name',/)
 6001 FORMAT (' Type control file name then press Enter key. --> ')
      READ (5,5002) FNAM2
C      READ (*,5002) FNAM2
      OPEN (49,FILE=FNAM2,FORM='FORMATTED',STATUS='UNKNOWN')
      LBMAX=1500
      READ (49,5001) NFILES
 5001 FORMAT (I5)
      DO 9305 I=1,NFILES
         READ (49,5002) FNAM
 5002    FORMAT (A32)
         READ (49,*) ICOD,LZP
         IF (ICOD .EQ. 0)
     &   OPEN (LZP,FILE=FNAM,FORM='FORMATTED',STATUS='UNKNOWN')
         IF (ICOD .EQ. 1)
     &   OPEN (LZP,FILE=FNAM,FORM='UNFORMATTED',STATUS='UNKNOWN')
         IF (ICOD .EQ. 2)
     &   OPEN (LZP,FILE=FNAM,ACCESS='TRANSPARENT',FORM='UNFORMATTED',
     &         STATUS='UNKNOWN')
 9305 CONTINUE
      OPEN (ND2,FILE='SCR.FIL',ACCESS='TRANSPARENT',FORM='UNFORMATTED',
     &      STATUS='UNKNOWN')
*-
*     Open the following file for Vineland Model
*-
      IF (FNAM2 .EQ. 'vineland.fil' .OR. FNAM2 .EQ. 'VINELAND.FIL') THEN
         ISWIT = 1
         OPEN (27,FILE='depini.inp',STATUS='unknown')
         READ (27,4) dinibbu,dinigs1,dinimru,dinicon,dinigs2
    4    FORMAT (5(9X,F6.3))
      ENDIF
      READ (IN5,5000) TITLE1
      READ (IN5,5000) TITLE2
      READ (IN5,5000) TITLE3
 5000 FORMAT (7X,A73) 
      WRITE (LP,6000) TITLE1
      WRITE (LP,6010) TITLE2
      WRITE (LP,6010) TITLE3
 6000 FORMAT (1X,A73/)
 6010 FORMAT (1X,A73/)
      READ (IN5,5010) NCON,IDEFAU
 5010 FORMAT (44X,I1,/,44X,I1)
      READ (IN5,'(I4,/,I4)') IOSTEP,NSTIME
      IF (NCON .EQ. 1) THEN
         CALL HYDRO2
      ELSE
         CALL CS2D (FNAM2)
      ENDIF
      CLOSE (ND1,STATUS='DELETE')
      CLOSE (ND2,STATUS='DELETE')
      REWIND (49)
      READ (49,5001) NFILES
      DO 9310 I=1,NFILES
         READ (49,5002) FNAM
         READ (49,*) ICOD,LZP
         CLOSE (LZP)
 9310 CONTINUE
      CLOSE (49)
      CALL BEEP (5)
      STOP ' END OF PROGRAM'
      END                                                               
************************************************************************
      SUBROUTINE CS2D (FNAM2)
************************************************************************
      INCLUDE 'hsctm.inc'
      CHARACTER*80 DUMMY
      CHARACTER*73 TITLE4
      CHARACTER*32 FNAM2
      DIMENSION NPMA(NCYS),CMAX(4)
      DIMENSION WWT(9),EEN(8,9),PNDS(8,9),PNDE(8,9)
      DIMENSION TEMP(5),IT(5)
*-
*     DEFINE SEDIMENT-FLUX ARRAYS
*-
      DIMENSION x(20),y(20),ux(20),uy(20),ddd(20),ci(20),AF(20,2)
************************************************************************
*     GAUSS POINTS FOR NUMERICAL INTEGRATION IN FINITE ELEMENT METHOD
************************************************************************
      NGAUSS=3
      NE=1
      NP=1
      QP(1)=0.0E0
      QP(2)=0.7745966692E0
      QP(3)=-0.7745966692E0
      QW(1)=0.888888889E0
      QW(2)=0.555555556E0
      QW(3)=0.555555556E0
************************************************************************
*
*     READ INPUT AND OUTPUT FILE NUMBERS
*
*     INPUT=IN
*     OUTPUT=LP
*     CONCENTRATIONS=INC
*     DIFFUSION COEFFICIENTS=IND
*     VELOCITIES=INF
*     SETTLING VELOCITIES=ING
*     COMPUTATION MESH=INI
*     BOUNDARY CONDITIONS=INB
*     WATER SALINITIES=INS
*     NEW WATER SALINITIES=INSS
*
************************************************************************
      IF (IDEFAU .EQ. 0) READ (IN5,5000) INC,IND,INF,ING,INSS,INI,
     &                                   INB,INS,NGC,NE,NP
 5000 FORMAT (/,7X,I3,12X,I3,12X,I3,
     &   /,7X,I3,12X,I3,12X,I3,
     &   /,7X,I3,12X,I3,12X,I3,
     &   /,5X,I5,9X,I6)
      IF (INB .EQ. 0) INB=IN5
      IF (INC .EQ. 0) INC=IN5
      IF (IND .EQ. 0) IND=IN5
      IF (INF .EQ. 0) INF=IN5
      IF (ING .EQ. 0) ING=IN5
      IF (INI .EQ. 0) INI=IN5
      IF (INS .EQ. 0) INS=IN5
************************************************************************
*     READ END OF DATA PARAMETER AND THE TITLE OF THE JOB
************************************************************************
   99 READ (IN5,111) NSTOP,TITLE4
      IF (NSTOP .NE. 0) GO TO 115
      WRITE (LP,1195) TITLE4
 1195 FORMAT (/,1X,A73)
      IF (IDEFAU) 1020,1020,1030
 1020 CONTINUE
      WRITE (LP,6010)
 6010 FORMAT (//1X,'ALL DATA MUST BE INPUT BY USER'
     &   ,//1X,'DEFAULT VALUES ARE NOT USED')
      GO TO 1040
 1030 CONTINUE
 1040 CONTINUE
************************************************************************
*     READ JOB CONTROL PARAMETERS, INPUT CODES, AND OPTIONS
************************************************************************
  116 READ (IN5,5003) NOPT,ICODE,NCYC,IVEL,ISOUR,IDIF1,IBED,ISET,
     &                ICONC,INBC,IDRY,ISZ
 5003 FORMAT (7X,I3,12X,I3,11X,I4,12X,I3,
     &   /,7X,I3,3(12X,I3),
     &   /,7X,I3,3(12X,I3),//)
      READ (IN5,5081) JQ1,JQ2,JQ3,JQ4,JQ5
 5081 FORMAT (5(12X,I1),//)
      JQP = 0
      JQZ(1)=JQ1
      IF (JQ1 .GT. 0) JQP = 1
      JQZ(2)=JQ2
      IF (JQ2 .GT. 0) JQP = 2
      JQZ(3)=JQ3
      IF (JQ3 .GT. 0) JQP = 3
      JQZ(4)=JQ4
      IF (JQ4 .GT. 0) JQP = 4
      JQZ(5)=JQ5
      IF (JQ5 .GT. 0) JQP = 5
      WRITE (LP,9045) (JQZ(K),K=1,5),JQP
 9045 FORMAT(/,' JQZ ARRAY =',5I4,' JPQ=',I4)
************************************************************************
*     READ ARRAY JSOUR(K), WHICH SPECIFIES FOR WHICH VARIABLE (I.E.,
*     DEGREE OF FREEDOM) A SOURCE OR SINK IS TO BE SPECIFIED
************************************************************************
      READ (IN5,5001) (JSOUR(K),K=1,4)
 5001 FORMAT (4I16,/)
************************************************************************
*     FOR STEADY STATE SEDIMENT PROBLEM, SPECIFY FOR ALL NODES AND
*     ELEMENTS WHETHER EROSION, DEPOSITION OR NEITHER INITIALLY OCCUR
************************************************************************
      DO 1100 I=1,NP
         BSO(I)=0.0
         ISTP(I)=0
         SLOPE(I)= -0.10E-19
 1100 CONTINUE
      DO 1110 I=1,NE
         ESRO(I)=0.0E0
         ISTE(I)=0
         IMAT(I)=1
         TH(I)=0.0E0
 1110 CONTINUE
      IF (ISZ .EQ. 0) GO TO 1080
      READ (IN5,5030) (ISTP(I),I=1,NP)
      DO 1120 I=1,NP
         IF (ISTP(I) .EQ. 1) GO TO 1130
         BSO(I)=1.0E0
         GO TO 1120
 1130    CONTINUE
         BSO(I)=0.0E0
 1120 CONTINUE
      READ (IN5,5030) (ISTE(I),I=1,NE)
      DO 1140 I=1,NE
         IF (ISTE(I) .EQ. 1) GO TO 1150
         ESRO(I)=1.0E0
         GO TO 1140
 1150    CONTINUE
         ESRO(I)=0.0E0
 1140 CONTINUE
************************************************************************
*     INITIALIZE NECESSARY ARRAYS
************************************************************************
 1080 CONTINUE
      DO 1160 I=1,NP
         BEDLL(I)=0.0E0
         SLOPE(I)=0.0E0
         IV(I)=2
         IVCOP(I)=2
         NRIGHT(I)=0.0E0
         NLEFT(I)=0.0E0
         TDP(I)=0.0E0
         WS(I,1)=0.0E0
         BSHEAR(I)=0.0E0
         VEL(3,I)=0.0E0
         ALPHA1(I,1)=0.0E0
         VEL(1,I)=0.0E0
         VEL(2,I)=0.0E0
         DO 4586 K=1,3
            CBP(I,K)=0.0E0
 4586    CONTINUE
         DO 3586 K=1,JQP
            NFIZ(I,K)=0
            MFIX(I,K)=0
            CNC(I,K)=0.0E0
            SPEC(I,K+3)=0.0E0
            CNT(I,K)=0.0E0
            R9(I,K)=0.0E0
            R2(I,K)=0.0E0
 3586    CONTINUE
 1160 CONTINUE
      DO 1170 I=1,NE
         EDOT(I)=0.0E0
         AT(I)=0.0E0
         ALPHA2(I)=0.0E0
         CHEZ(I)=0.0E0
         ZMANN(I)=0.0E0
         DO 1271 K=1,3
            CBEL(I,K)=0.0E0
 1271    CONTINUE
 1170 CONTINUE
************************************************************************
*     TRANSIENT PROBLEM - READ TRANSIENT INPUT
************************************************************************
      IF (NOPT .EQ. 1) GO TO 776
  790 READ (IN5,1055) TETA,DELT,TIM(NSTIME)
 1055 FORMAT (30X,F10.4,/,16X,F10.2,/,16X,F10.2)
      DLT = DELT*3600.0E0
      DO 875 I = 1,NP
         TETZ(I) = TETA
  875 CONTINUE
************************************************************************
*     CODES FOR SEDIMENT TRANSPORT PROBLEM
************************************************************************
      DO 3000 I = NSTIME,NCYC
         NPMA(I)=0
         IFF(I,1)=1
         IVCOD(I)=4
         IDIF(I)=IDIF1
         ISVS(I)=3
         ISORS(I)=0
         IF (I/IOSTEP .EQ. REAL(I)/REAL(IOSTEP)) THEN
            IFF(I,2)=3
            ELSE
            IFF(I,2)=0
         ENDIF
 3000 CONTINUE
************************************************************************
*     READ INFORMATION FOR FLUX ROUTINE
************************************************************************
*     IFLX   = FLUX ROUTINE SWITCH
*     IFLXNP = # OF NODES IN THE FLUX STRING
*     IFLXNN = NODE # OF NODES IN THE FLUX STRING
*     FLUXT  = TOTAL FLUX OVER ALL TIME
*     DTF    = DT IN SECONDS FOR ALL TIME STEPS
************************************************************************
      READ (IN5,'(I1,I10)') IFLX,IFLXNP
      READ (IN5,2019) (IFLXNN(I),I=1,IFLXNP)
 2019 FORMAT (5I10)
      FLUXT = 0.0E0
      DTF = 300.0E0
************************************************************************
*     READ THE NUMBERS OF SPECIAL ELEMENTS FOR TIME SERIES TO BE SAVED
************************************************************************
      READ (IN5,1093) NELE,(NELH(J),J=1,NELE)                          
 1093 FORMAT (43X,I7,/,20X,5I5)
      READ (IN5,1095) DUMMY
 1095 FORMAT (A80)
      WRITE (LP,256) TETA
************************************************************************
*     READ INITIAL WATER SALINITIES AND TEMPERATURE
************************************************************************
  776 GAC=2650.0
      CALL DENSTY (0,4)
      IF (ISOUR .EQ. 0) GO TO 121
************************************************************************
*     READ SOURCE/SINK TERM AT APPROPRIATE NODES
************************************************************************
  125 CONTINUE
      JQO = JQP-Q
      DO 124 K=1,JQO
         IF (JSOUR(K) .EQ. 0) GO TO 124
 1254    READ (IN5,122) (IT(J),TEMP(J),J=1,4)
  122    FORMAT (4(I10,F10.5))
         DO 123 I=1,4
            IF (IT(I) .LE. 0) GO TO 124
            N=IT(I)
            R2(N,K)=TEMP(I)
            IF (N .GE. NP) GO TO 124
  123    CONTINUE
      GO TO 1254
  124 CONTINUE
************************************************************************
*     IF SEDIMENT PROBLEM INITIALIZE BED PROPERTIES
************************************************************************
  121 IF (NOPT .LT. 3) GO TO 458
      DO 457 I=1,NE
      BEDL(I)=0.0
      IFLAG(I)=0
      IFGZ(I)=0
      NC(I)=1
      IVT(I)=2
      IVCON(I)=2
      NLAYO(I)=0
      NLAYM(I)=0
      TM(I)=0.0
      TH9(I)=0.0
      FLUX(I)=0.0
      DOWN(I)=0.0
      BDM(I)=0.0
      ETIM(I)=0.0
      NOCR(I)=0
      DTIM(I)=0.0
      DO 459 K=1,5
         NLAY(K,I)=0
         TC(I,K)=0.0
  459 CONTINUE
      TDE(I)=0.0
      BEDEL(I)=0.0
      DO 457 J=1,9
         DO 491 K=1,9
            THICK(K,I,J)=0.0
            GADT(K,I,J)=0.0
            GBT(K,I,J)=0.0
            SST(K,I,J)=0.0
  491    CONTINUE
         GBM(J)=0.0
         GB(J)=0.0
         GADM(J)=0.0
         GAD(J)=0.0
         GBTM(I,J)=0.0
         GADTM(I,J)=0.0
         GADO(I,J)=0.0
         GBO(I,J)=0.0
         SSTO(I,J)=0.0
         SSTM(I,J)=0.0
         THICKO(I,J)=0.0
         THICKM(I,J)=0.0
  457 CONTINUE
************************************************************************
*     FOR A SEDIMENT PROBLEM THE SEDIMENT PROPERTIES MUST BE READ
************************************************************************
      CALL SEDPRP
************************************************************************
*
*     THE FIRST TIME STEP
*
************************************************************************
  458 NSTEP = NSTIME
************************************************************************
*     SET INITIAL CONDITIONS AND PARAMETER VALUES
************************************************************************
      IF (NOPT .EQ. 1) GO TO 38
      DO 495 K = 1,JQP
         IF (JQZ(K) .GT. 0 .AND. K .NE. 2) THEN
            CALL CONCIC (ICONC,K)
         ENDIF
  495 CONTINUE
************************************************************************
*     INITIAL CALL TO HYDRODYNAMIC MODULE TO DETERMINE STEADY STATE
*     (OR INITIAL TIME-STEP) FLOW FIELD
************************************************************************
   38 CONTINUE
      CALL VELL (IVEL)
      IF (NCON .GT. 1) THEN
         DO 9395 K = 1,JQP
            IF (JQZ(K) .EQ. 0) GO TO 9395
            DO 9385 J=1,NP
               NFIZ(J,K)=NDRY(J)-1
 9385       CONTINUE
 9395    CONTINUE
      ENDIF
************************************************************************
*     FORM THE SHAPE FUNCTIONS
************************************************************************
      CALL SHPFNS
      CALL TSHAPE
      IF (NCON .EQ. 1) GO TO 3737
      IF (NOPT .LT. 3) GO TO 36
************************************************************************
*     IF AN INITIAL BED PROFILE IS TO BE READ IN IBED MUST BE NON ZERO
************************************************************************
      DO 80 L = 1,NE
      A=0.0E0
      SAA=0.0E0
      DEE=0.0E0
      IF (ABS(NOP(L,7)) .NE. 0) GO TO 84
      NCN=6
      IPZ=NGAUSP
      DO 85 KK=1,IPZ
      DO 86 I=1,NCN
      EEN(I,KK)=SZ(I,KK)
      PNDS(I,KK)=SX(I,KK)
   86 PNDE(I,KK)=SY(I,KK)
   85 WWT(KK)=QWT(KK)
      GO TO 87
   84 NCN=8
      IPZ=NGAUSS*NGAUSS
      DO 88 KK=1,IPZ
      DO 89 I=1,NCN
      EEN(I,KK)=EN(I,KK)
      PNDS(I,KK)=DNDS(I,KK)
   89 PNDE(I,KK)=DNDE(I,KK)
   88 WWT(KK)=WT(KK)
   87 DO 81 N = 1,IPZ
      SA=0.0E0
      DE=0.0E0
      DXDS=0.0E0
      DZDS=0.0E0
      DZDE=0.0E0
      DXDE=0.0E0
      DO 83 I = 1,NCN
         NOP(L,I)=ABS(NOP(L,I))
         K=NOP(L,I)
         E=EEN(I,N)
         SA=E*CNC(K,2)+SA
         DE=E*DEN(K)+DE
         DXDS=PNDS(I,N)*CORD(K,1)+DXDS
         DXDE=PNDE(I,N)*CORD(K,1)+DXDE
         DZDS=PNDS(I,N)*CORD(K,2)+DZDS
         DZDE=PNDE(I,N)*CORD(K,2)+DZDE
   83 CONTINUE
      VJAC=DXDS*DZDE-DXDE*DZDS
      VJAC=VJAC*WWT(N)
      A=A+VJAC 
      SAA=SAA+VJAC*SA
      DEE=DEE+VJAC*DE
   81 CONTINUE
      ESAL(L)=SAA/A
      EDEN(L)=DEE/A
   80 CONTINUE
  792 CALL DENSTY (1,10)
      IF (IBED .NE. 0) CALL ORGBED
      IF (JQ3 .GT. 0) THEN
         CALL INTER2 (1)
         WRITE (LP,2251)
         DO 3917 J=1,NP
            WRITE (LP,2522) J,CBP(J,1)
 3917    CONTINUE
      ENDIF
 2522 FORMAT (1X,I4,1PE15.7)
 2251 FORMAT (//5X,'NODAL CONTAMINANT BED CONCENTRATIONS',/)
   36 CONTINUE
      IF (NOPT .LT. 3) GO TO 71
      CALL BEDSS
   71 CALL DISPER (IDIF1)
      IF (NOPT .LT. 3) GO TO 37
      DO 494 K = 1,JQ1
         CALL SETVEL (ISET,K)
  494 CONTINUE
************************************************************************
*     CONCENTRATION BOUNDARY CONDITIONS ARE SET
************************************************************************
   37 CONTINUE
      DO 52 K=1,JQP
         CALL CONCBC (INBC,K)
************************************************************************
*     CONCENTRATIONS AT THE BOUNDARIES ARE SET IN THE CONC. ARRAY
************************************************************************
         DO 51 I=1,NP
            IF (MFIX(I,K) .EQ. 0) GO TO 51
            CNC(I,K)=SPEC(I,K+3)
   51    CONTINUE
   52 CONTINUE
      IF (JQ3 .GT. 0) CALL ADSORB
      IF (JQ4 .GT. 0) CALL DISOLV
      IF (JQ5 .GT. 0) CALL WQUAL
************************************************************************
*     IF DRY NODE PROBLEM DETERMINE DRY NODES AT START
************************************************************************
*     IF (IDRY .NE. 0) CALL DRYNOD
      CALL LOADX
************************************************************************
*     PRINT OUT THE INITIAL CONDITIONS AND PARAMETRIC VALUES
************************************************************************
      WRITE (LP,250)
      DO 392 K = 1,JQP
         IF (JQZ(K) .EQ. 0) GO TO 392
         WRITE (LP,251)
         WRITE (LP,253)
         DO 391 J=1,NP
            WRITE (LP,252) J,MFIX(J,K),VEL(1,J),VEL(2,J),VEL(3,J),
     &      CNC(J,K),DIF(J,1),DIF(J,2),DIF(J,3)
            SPECO(J,K+3)=SPEC(J,K+3)
            CNCO(J,K)=CNC(J,K)
  391    CONTINUE
  392 CONTINUE
      IF (NOPT .NE. 1) GO TO 276
************************************************************************
*
*                 COMPUTATION FOR THE STEADY STATE PROBLEM
*
************************************************************************
      CALL FRONT (1)
      WRITE (LP,320)
      WRITE (LP,318)
      WRITE (LP,319) (I,AT(I),I=1,NE)
      CALL WRITER (2)
      IF (ICODE .NE. 0) CALL COMPAR
      GO TO 99
************************************************************************
*                    END OF STEADY STATE PROBLEM
************************************************************************
*     THE FOLLOWING COMPUTATIONS ARE MADE AT THE FIRST TIME STEP FOR
*     TRANSIENT PROBLEMS. EROSION AND DEPOSITION RATES ARE COMPUTED FOR 
*     SEDIMENT PROBLEMS. FOR ALL DYNAMIC PROBLEMS THE ELEMENT STIFFNESS
*     MATRICES ARE FORMED.
************************************************************************
  276 CONTINUE
      IF (NOPT .LT. 3) GO TO 316
      DO 329 I=1,NP
      DEPO(I)=VEL(3,I)
  329 BSO(I)=BSHEAR(I)
      DO 330 I=1,NE
  330 ESRO(I)=ESR(I)
************************************************************************
*     SET THE INITIAL BED ELEVATIONS IN ARRAY BEDEL
************************************************************************
      DO 337 I=1,NE
         EELEV(I)=EELEV(I)+BEDEL(I)
         BEDEL(I)=EELEV(I)
  337 CONTINUE
      DO 314 K=1,JQ1
         CALL DEPSN (K)
  314 CONTINUE
      CALL RESUSP
************************************************************************
*     THE ELEMENT STIFFNESS ARRAYS FOR THE FIRST TIME STEP ARE FORMED
************************************************************************
  316 CONTINUE
      DO 465 KT=1,JQP
         DO 465 I=1,NE
            DO 465 J=1,8
               FO(I,J)=0.0E0
               QK(I,J)=0.0E0
               DO 465 K=1,8
                  ESTO(KT,I,J,K)=0.0E0
  465 CONTINUE
      DO 366 KT = 1,JQP
      IF (JQZ(KT) .EQ. 0) GO TO 366
         DO 365 I=1,NE
            CALL ELSTIF (I,KT)
  365    CONTINUE
  366 CONTINUE
      WRITE (LP,318)
      WRITE (LP,319) (I,AT(I),I=1,NE)
  793 CONTINUE
 3737 CONTINUE
************************************************************************
*
*            MAIN TIME LOOP  -  STARTS AT TIME STEP NO. NSTIME+1
*
************************************************************************
      DO 991 N = NSTIME+1,NCYC
************************************************************************
*     CHANGE TIME STEP SIZE DEPENDING ON VALUE OF NPMA(N)
************************************************************************
      IF (NOPT .EQ. 5) GO TO 794
      IF (NPMA(N) .EQ. 1) DELT = DELT+DELT
      IF (NPMA(N) .EQ. 2) DELT = DELT/2.0E0
      DLT = DELT*3600.0E0
************************************************************************
*     SET NEW TIME AND I/O CODES FOR THIS TIME STEP
************************************************************************
      TIM(N) = TIM(N-1)+DELT
      WRITE (LP,9527) N,TIM(N)
 9527 FORMAT (/,' Time Step Number =',I5,'   Time =',F10.3)
      NSTEP=N
      ICON=IFF(N,1)
      IVEL=IVCOD(N)
      ICODE=IFF(N,2)
      ID=IDIF(N)
      ISQ=ISVS(N)
      ISOUR=ISORS(N)
      IF (NCON .EQ. 1) GO TO 3738
************************************************************************
*     SET OLD BOUNDARY CONDITION VALUES EQUAL TO THE NEW VALUES
************************************************************************
      DO 498 K = 1,JQP
      IF (JQZ(K) .EQ. 0) GO TO 498
         DO 499 JI = 1,NP
            SPECO(JI,K+3)=SPEC(JI,K+3)
  499    CONTINUE
  498 CONTINUE
      DO 1740 J = 1,NE
         BEDL(J)=0.0E0
 1740 CONTINUE
************************************************************************
*     DEPENDING ON THE INPUT CODES, READ NEW PARAMETERS FOR THIS TIME
*     STEP
************************************************************************
      IF (JQ2 .NE. 0) CALL DENSTY (0,JQ2)
      DO 490 K=1,JQP
         IF (JQZ(K) .GT. 0) THEN
            IF (ICON .GT. 0) CALL CONCBC (ICON,K)
         ENDIF
  490 CONTINUE
 3738 CONTINUE
      IF (IVEL .GT. 0) CALL VELL (IVEL)
      IF (NCON .EQ. 1) GO TO 3739
      IF (NCON .GT. 1) THEN
      DO 9184 K=1,JQP
         DO 9387 J=1,NP
            NFIZ(J,K)=NDRY(J)-1
 9387    CONTINUE
 9184 CONTINUE
      ENDIF
      IF (NOPT .EQ. 2 .OR. JQ1 .EQ. 0) GO TO 72
      CALL BEDSS
   72 IF (ID .NE. 0) CALL DISPER (ID)
      DO 489 K=1,JQ1
         IF (JQZ(K) .GT. 0) THEN
            IF (ISQ .NE. 0) CALL SETVEL (ISQ,K)
         ENDIF
  489 CONTINUE
      IF (ISOUR .EQ. 0) GO TO 126
      DO 138 M=1,JQP
         IF (JSOUR(M) .EQ. 0) GO TO 138
  127    READ (IN5,122) (IT(J),TEMP(J),J=1,4)
         DO 128 I=1,5
            IF (IT(I) .LE. 0) GO TO 129
            K=IT(I)
            R2(K,M)=TEMP(I)
            IF (K .GE. NP) GO TO 129
  128 CONTINUE
      GO TO 127
  129 CONTINUE
  138 CONTINUE
  126 CONTINUE
      IF (IDRY .NE. 0) CALL LOADX
************************************************************************
*     FOR SEDIMENT PROBLEMS, COMPUTE THE RATES OF EROSION AND
*     DEPOSITION FOR THIS TIME STEP
************************************************************************
      IF (NOPT .EQ. 2) GO TO 317
      IF (JQ2 .NE. 0) CALL DENSTY (1,10)
      IF (JQ1 .EQ. 0) GO TO 556
      DO 851 K=1,JQ1
         CALL DEPSN (K)
  851 CONTINUE
      CALL REDISP
      CALL RESUSP
  556 IF (JQ3 .GT. 0) CALL ADSORB
      IF (JQ4 .GT. 0) CALL DISOLV
      IF (JQ5 .GT. 0) CALL WQUAL
************************************************************************
*     SOLVE FOR THIS TIME STEP'S CONCENTRATIONS
************************************************************************
  317 CONTINUE
*      IF (IDRY .NE. 0) CALL DRYNOD
      DO 853 K=1,JQP
         IF (JQZ(K) .GT. 0) THEN
            CALL FRONT (K)
         ENDIF
  853 CONTINUE
************************************************************************
*     FORM THE NEW BED CAUSED BY DEPOSITION
************************************************************************
      IF (NOPT .LT. 3 .OR. JQ1 .EQ. 0) GO TO 131
      DO 917 M=1,JQ1
         CALL DEPMAS (M)
  917 CONTINUE
  794 CALL BEDMOD
      CALL INTERP
      IF (JQ3 .GT. 0) THEN
         CALL BEDCON
         DO 5629 M=1,3
            CALL INTER2 (M)
 5629    CONTINUE
      ENDIF
************************************************************************
*     SET OLD CONCENTRATIONS, BED SHEARS, AND DEPTHS TO NEW VALUES
************************************************************************
      DO 5 I=1,NP
         BSO(I)=BSHEAR(I)
         DEPO(I)=VEL(3,I)
    5 CONTINUE
      DO 497 K=1,JQP
         IF (JQZ(K) .GT. 0) THEN
            DO 719 I=1,NP
               CNCO(I,K)=CNC(I,K)
  719       CONTINUE
         ENDIF
  497 CONTINUE
************************************************************************
*     FORM CONCENTRATION BOUNDARY CONDITION FILES FOR DOWNSTREAM
*     MODEL - PERFORMED ONLY FOR THE VINELAND, NJ MODEL
************************************************************************
      IF (FNAM2 .EQ. 'vineland.fil' .OR. FNAM2 .EQ. 'VINELAND.FIL') THEN
      ND3=91
      DO 597 K=1,JQP
         IF (JQZ(K) .GT. 0) THEN
            CNCAVE=(CNC(34,K)+CNC(39,K)+CNC(44,K)+CNC(49,K)+CNC(54,K)+
     &             CNC(59,K)+CNC(64,K))/7.0
            WRITE (ND3,9482) NSTEP,CNCAVE
 9482       FORMAT (' Timestep=',I6,/,10X,'1',F20.8)
            ND3=ND3+1
         ENDIF
  597 CONTINUE
      ENDIF
************************************************************************
*     OUTPUT FOR THIS TIME STEP.  SAVE VALUES IF NELE .NE. 0
************************************************************************
  131 IF (NELE .NE. 0) CALL RECORD
      ICODE=3
      CALL WRITER (ICODE)
      IF (ICODE .EQ. 5) CALL COMPAR
************************************************************************
*     SEDIMENT FLUX ROUTINE
************************************************************************
*
*     Routine to compute the sediment flux across a node-string.
*
*     fluxi=flux at a subsection
*     fluxs=flux for the entire flux line for this timestep
*     fluxt=total flux as summed over time.
      IF (iflx .NE. 0) THEN
         fluxs=0.0
*-
*     Establish nodal values for cartesian coordinates, depth, & vel. in
*     indexed notation
*      WRITE(13,*)'node#,x,y,ux,uy,d,ci'
*-
         DO 175 J=1,IFLXNP
	      x(j)=CORD(iflxnn(j),1)
	      y(j)=CORD(iflxnn(j),2)
	      ux(j)=vel(1,iflxnn(j))
	      uy(j)=vel(2,iflxnn(j))
	      ddd(j)=vel(3,iflxnn(j))
            ci(j)=cnc(iflxnn(j),1)
*           WRITE(13,*)j,x(j),y(j),ux(j),uy(j),ddd(j),ci(j)
  175	   CONTINUE
* ... Calculate the area of each subsection
	   DO 200 j=1,iflxnp
	      IF (j .EQ. 1) THEN
               distf=sqrt((x(j)-x(j+1))**2+(y(j)-y(j+1))**2)
	         w=distf/2.0
	         depf=(3*ddd(j)+ddd(j+1))/4.0
	         AF(1,2)=w*depf
*              WRITE(13,*)AF(1,2)
	      ELSEIF (j .EQ. iflxnp) THEN
               distf=sqrt((x(j)-x(j-1))**2+(y(j)-y(j-1))**2)
	         w=distf/2.0
	         depf=(3*ddd(j)+ddd(j-1))/4.0
	         AF(iflxnp,1)=w*depf
*              WRITE(13,*)AF(iflxnp,1)
	      ELSE
	         distf1=sqrt((x(j)-x(j-1))**2+(y(j)-y(j-1))**2)
	         distf2=sqrt((x(j)-x(j+1))**2+(y(j)-y(j+1))**2)
	         w1=distf1/2.0
	         w2=distf2/2.0
	         depf1=(ddd(j-1)+3.0*ddd(j))/4.0
	         depf2=(ddd(j+1)+3.0*ddd(j))/4.0
	         AF(j,1)=depf1*w1
	         AF(j,2)=depf2*w2
*              WRITE(13,*)AF(j,1),AF(j,2)
	      ENDIF
  200	   CONTINUE
*-
* ... Calculate normal velocities for each subsection
* ... Beta=angle CW from x-axis to flux line between two nodes
* ... Gamma=angle CW from x-axis to nodal velocity vector
*-
* ... Calculation of U-normal and Flux
*-
	   DO 300 j=1,iflxnp
	      uf=sqrt(ux(j)**2+uy(j)**2)
	      IF (j .EQ. 1) THEN
               delx=x(j+1)-x(j)
               dely=y(j+1)-y(j)
               omeg=gammaf(ux(j),uy(j))-betaf(delx,dely)
               unorm=uf*sin(omeg)
               fluxi=unorm*ci(j)*AF(1,2)*dtf
               fluxs=fluxs+fluxi
               fluxt=fluxt+fluxi
            ELSEIF (j .EQ. iflxnp) THEN
               delx=x(j-1)-x(j)
               dely=y(j-1)-y(j)
               omeg=betaf(delx,dely)-gammaf(ux(j),uy(j))
               unorm=uf*sin(omeg)
               fluxi=unorm*ci(j)*AF(iflxnp,1)*dtf
               fluxs=fluxs+fluxi
               fluxt=fluxt+fluxi
            ELSE
               DO 350 k=1,2
                  IF (k .EQ. 1) THEN
                     delx=x(j-1)-x(j)
                     dely=y(j-1)-y(j)
                     omeg=betaf(delx,dely)-gammaf(ux(j),uy(j))
                     unorm=uf*sin(omeg)
                     fluxi=unorm*ci(j)*AF(j,1)*dtf
                     fluxs=fluxs+fluxi
                     fluxt=fluxt+fluxi
*                    WRITE (13,*)'sect1: fluxi= ',fluxi
                  ELSE
                     delx=x(j+1)-x(j)
                     dely=y(j+1)-y(j)
                     omeg=gammaf(ux(j),uy(j))-betaf(delx,dely)
                     unorm=uf*sin(omeg)
                     fluxi=unorm*ci(j)*AF(j,2)*dtf
                     fluxs=fluxs+fluxi
                     fluxt=fluxt+fluxi
*                    WRITE (13,*)'sect2: fluxi= ',fluxi
                  ENDIF
*                 WRITE (13,*)'j,uf,omeg,unorm,ci(j),fluxi'
*                 WRITE (13,*) j,uf,omeg,unorm,ci(j),fluxi
  350          CONTINUE
            ENDIF
  300    CONTINUE
         WRITE (13,8113) tim(nstep),fluxs,fluxt
8113     FORMAT (' time=',2x,f9.2,' flux for this step=',f10.2,
     &           ' total flux=',f10.2)
  100 CONTINUE
      ENDIF
************************************************************************
*
*     Output bed elevation change and contaminant bed concentration
*     to SMS files
*
************************************************************************
      IF (N .EQ. NCYC) THEN
      IF (JQ1 .NE. 0) THEN
         IVER=4
         NONE=1
         DO 1313 I=1,NP
            BEDLL(I)=BEDLL(I)*1000.0E0
 1313    CONTINUE
         WRITE (LPDR2) IVER,NP,NE,NONE
         WRITE (LPDR2) TIM(NSTEP),(BEDLL(I),I=1,NP)
      ENDIF
      IF (JQ3 .NE. 0) THEN
      DO 2313 I=1,NP
         IF (CBP(I,3) .GT. 0.0E0) THEN
            CBPART(I)=CBP(I,3)*1000.0E0
         ELSEIF (CBP(I,2) .GT. 0.0E0) THEN
            CBPART(I)=CBP(I,2)*1000.0E0
         ELSE
            CBPART(I)=CBP(I,1)*1000.0E0
         ENDIF
 2313 CONTINUE
      WRITE (LPCBP) IVER,NP,NE,NONE
      WRITE (LPCBP) TIM(NSTEP),(CBPART(I),I=1,NP)
      ENDIF
      WRITE (LP,6308) 
 6308 FORMAT (//,' NODAL BED-ELEVATION CHANGES (mm) AND SURFICIAL BED CO
     &NTAMINANT CONCENTRATIONS (g/kg)',//)
      DO 1314 I=1,NP
         WRITE (LP,1013) I,AOO(I),BEDLL(I),AO(I),CBPART(I),
     &                   (CBP(I,J),J=1,3)
 1314 CONTINUE
 1013 FORMAT (I10,7E14.6)
      ENDIF
************************************************************************
*     SAVE MAXIMUM CONCENTRATIONS AT EACH TIME STEP IF NELE .NE. 0
************************************************************************
      IF (NELE .EQ. 0) GO TO 991
      DO 496 K=1,JQP
         CMAX(K)=0.0E0
         DO 867 J=1,NP
            IF (CNC(J,K) .LT. CMAX(K)) GO TO 867
            CMAX(K)=CNC(J,K)
  867    CONTINUE
  496 CONTINUE
 3739 CONTINUE
  991 CONTINUE
************************************************************************
*
*                        END OF TIME LOOP
*
************************************************************************
*     IF NELE .NE. 0 FOR A SEDIMENT PROBLEM, PRINT TIME HISTORIES
************************************************************************
      IF (NOPT .EQ. 5) GO TO 993
      AVETIM=0.0E0
      IZ=0
      DO 555 K=1,NE
         IF (NOCR(K) .EQ. 0) GO TO 555
         IZ=IZ+1
         BDM(K)=BDM(K)/NCYC
         AVETIM=AVETIM+DTIM(K)/NOCR(K)
  555 CONTINUE
      IF (IZ .EQ. 0) IZ=1
      AVETIM=AVETIM/(IZ*60.0E0)
      WRITE (LP,9009) AVETIM
 9009 FORMAT(///,' AVERAGE AMOUNT OF TIME SEDIMENT PARTICLES ARE IN SUSP
     &ENSION = ',F5.1,'  minutes'//)
      WRITE (LP,9000)
 9000 FORMAT(/1X,'PRINT OUT OF SPECIFIED INFORMATION',
     &       /1X,'----------------------------------',
     &       //1X,'ELEMENT',3X,'NET CHANGE',3X,'NET VERTICAL',3X,
     &            'NET DOWNWARD',3X,'AVE THICK.',
     &       /1X,' NUMBER',3X,'  IN BED  ',3X,'MASS FLUX OF',3X,
     &            ' MASS FLUX ',3X,' OF STAT. ',
     &        /11X,'ELEVATION',5X,' SEDIMENT ',5X,
     &            'OF SEDIMENT',3X,'SUSPENSION'
     &/1X,'-------------------------------------------------------------
     &---'/)
      WRITE (LP,9001) (K,ANET(K),FLUX(K),DOWN(K),BDM(K),K=1,NE)
 9001 FORMAT (I5,4E15.5)
      IF (NOPT .LT. 3 .OR. NELE .EQ. 0) GO TO 993
      WRITE (LP,1000)
      DO 1001 I=1,NELE
         NN=NELH(I)
         WRITE (LP,1002) NN
         WRITE (LP,1003)
         DO 1005 N=NSTIME,NCYC
            THR=TIM(N)
            BECH=TEBOT(I,N)
            WRITE (LP,1006) THR,TEVEL(I,N),TECON(I,N),TEDR(I,N),
     &                      TEMER(I,N),TESER(I,N),TEDMAS(I,N),BECH
 1005    CONTINUE
 1001 CONTINUE
  993 CONTINUE
************************************************************************
*     FORMAT STATEMENTS
************************************************************************
 5030 FORMAT (80I1,/)
    3 FORMAT (//1X,11HTOTAL NODES,4X,I3/1X,15HTOTAL ELEMENTS ,I3/1X,
     &        1X,11HPROB OPTION,4X,I3/1X,14HNO. TIME STEPS,I4//)
  111 FORMAT (/,34X,I1,/,7X,A73,/)
  256 FORMAT (///' TRANSIENT PROBLEM SOLVED WITH THETA =',F7.5)
  500 FORMAT (16I5)
 1000 FORMAT (///,20X,'TIME HISTORY OF FLOW AND SEDIMENTATION')
 1002 FORMAT (/,32X,'ELEMENT NO. ',I3/,32X,15(1H-))
 1003 FORMAT (/5X,'TIME',2X,'VELOCITY',1X,'SED.CONC.',
     &1X,'DEP.RATE',1X,'MA.ER.RATE',1X,'SUR.ER.RATE',
     &1X,'E/D MASS',1X,'BED ELEV'/5X,'HRS.',4X,'M/S',5X,
     &'KG/CU.M',2X,
     &'KG/SQ.M',3X,' KG/SQ.M',3X,' KG/SQ.M',4X,'KG/S',8X,'M')
 1006 FORMAT (1X,F8.2,1P7E10.2)
  250 FORMAT (///1X,'INITIAL CONDITIONS'
     &/1X,          '------------------')
  251 FORMAT(///1X,'NODE POINTS VELOCITES, DEPTHS, CONCENTRATIONS, AND D
     &IFFUSION COEFFICIENTS')
  252 FORMAT (1X,I4,I4,1P7E9.2)
  253 FORMAT (//1X,4HNODE,1X,3HFIX,2X,5HX-VEL,5X,5HY-VEL,4X,5HDEPTH,
     &4X,5HCONC.,4X,5HX-DIF,3X,5HY-DIF,4X,6HXY-DIF)
  318 FORMAT(///6X,14HELEM.     AREA,11X,14HELEM.     AREA,11X,14HELEM.
     &    AREA,11X,14HELEM.     AREA)
  319 FORMAT(I9,3X,1PE11.4,I11,3X,1PE11.4,I11,3X,1PE11.4,I11,3X,1PE11.4)
  320 FORMAT(1H1)
      GO TO 99
  115 WRITE (LP,117)
  117 FORMAT (///,' **** END OF JOB ****')
      RETURN
      END
************************************************************************
*     FUNCTION DEFINITIONS FOR SEDIMENT FLUX ROUTINE.
************************************************************************
      function betaf (dx,dy)
        pi=3.14159265E0
        IF (dx .EQ. 0.0) then
          IF (dy .GT. 0.0) betaf=3./2.0*pi
          IF (dy .LE. 0.0) betaf=pi/2.0
        ELSEIF (dx .GT. 0.0) then
          IF (dy .GT. 0.0) betaf=2.0*pi-atan(dy/dx)
          IF (dy .LT. 0.0) betaf= -atan(dy/dx)
          IF (dy .EQ. 0.0) betaf=0.0
        ELSE
          betaf=pi-atan(dy/dx)
        ENDIF
*        WRITE(13,*)'betaf= ',betaf
        end
      function gammaf (ux,uy)
        pi=3.14159265
        IF (ux .EQ. 0.0) then
          IF (uy .GT. 0.0) gammaf=3./2.0*pi
          IF (uy .LE. 0.0) gammaf=pi/2.0
        ELSEIF (ux .GT. 0.0) then
          IF (uy .GT. 0.0) gammaf=2.0*pi-atan(uy/ux)
          IF (uy .LT. 0.0) gammaf= -atan(uy/ux)
          IF (uy .EQ. 0.0) gammaf=0.0
        ELSE
          IF (uy .NE. 0.0) gammaf=pi-atan(uy/ux)
          IF (uy .EQ. 0.0) gammaf=pi
        ENDIF
*        WRITE(13,*)'gammaf= ',gammaf
        end
************************************************************************
      SUBROUTINE EXACT (EX)
************************************************************************
      INCLUDE 'hsctm.inc'
      DIMENSION EX(MND)
      TQ=TIM(NSTEP)
      D=DIF(1,1)
      DO 1 I=1,NP
         X=CORD(I,1)
         U=VEL(1,I)
         P=U*X/D
         IF (P .GE. 174.67) P=174.67
         DN=2.0*SQRT(D*TQ)
         A=(X-U*TQ)/DN
         B=(X+U*TQ)/DN
         DEX=0.50*(ERFC(A)+EXP(P)*ERFC(B))
         EX(I)=DEX
    1 CONTINUE
      RETURN
      END
************************************************************************
      SUBROUTINE WQUAL
************************************************************************
*
*     WATER QUALITY MODULE- SOLVES THE DEPTH-AVERAGED ADVECTION-
*     DISPERSION EQUATION FOR THE NODAL CONCENTRATIONS OF DISSOLVED
*     OXYGEN (DO) AND BIOCHEMICAL OXYGEN DEMAND (BOD)
*
*     to be added at a later date.
*
************************************************************************
      INCLUDE 'hsctm.inc'
      RETURN
      END
************************************************************************
      SUBROUTINE DISOLV
************************************************************************
*
*     DISSOLVED CONTAMINANT TRANSPORT MODULE.
*
************************************************************************
      INCLUDE 'hsctm.inc' 
      IF (NSTEP .GT. NSTIME) GO TO 1000
      READ (IN8,5000) DCYD
      WRITE (LP,6000) DCYD
 6000 FORMAT (/,5X,'DCYD =',E12.5)
 5000 FORMAT (10X,E10.3)
*     IF (JQ3 .GT. 0) GO TO 1000
      READ (IN8,5010) (ADRATE(J),J=1,JQ3)
      WRITE (LP,5020) ADRATE(1)
 5020 FORMAT (' ADRATE =',E15.7)
 5010 FORMAT (10X,3E15.7)
      READ (IN8,5010) (PART(J),J=1,JQ3)
 1000 CONTINUE 
      RETURN
      END
************************************************************************
      SUBROUTINE ADSORB
************************************************************************
*
*     PARTICULATE CONTAMINANT TRANSPORT MODULE.
*
************************************************************************
      INCLUDE 'hsctm.inc'
      IF (NSTEP .GT. NSTIME) GO TO 1000
      READ (IN8,5000) DCYP
      WRITE (LP,6000) DCYP
 6000 FORMAT (/,5X,'DCYP =',E12.5)
 5000 FORMAT (10X,E10.3)
 1000 CONTINUE 
      RETURN
      END
************************************************************************
      SUBROUTINE BEDCON
************************************************************************
*
*     THIS SUBROUTINE CALCULATES THE CHANGE IN THE AVERAGE 
*     CONCENTRATION OF PARTICULATE CONTAMINANTS SORBED TO BED SEDIMENT 
*     DUE TO DEPOSITIONAL FLUX OF SEDIMENT TO THE BED.
*
************************************************************************
      INCLUDE 'hsctm.inc'
      DO 1000 NN=1,NE
         TMASOLD(NN)=TMAS(NN)
         TMAS(NN)=0.0
         IF (IFLAG(NN) .NE. 1) GO TO 1000
         IF (NLAYM(NN) .NE. 0) THEN
            NLW=NLAYM(NN)
            DO 2000 J=1,NLW
               TMAS(NN)=TMAS(NN)+0.5*THICKM(NN,J)*
     &                  (GADTM(NN,J)+GADTM(NN,J+1))
 2000       CONTINUE
            CMASSOLD=TMASOLD(NN)*CBEL(NN,3)
            CBEL(NN,3)=(TMBC(NN)+CMASSOLD)/TMAS(NN)
            WRITE (LP,3000) NN,NLW,TMBC(NN),CMASSOLD,TMAS(NN)
 3000       FORMAT (2I6,' TMBC =',3E15.7)
         ENDIF
 1000 CONTINUE
      RETURN
      END
************************************************************************
      SUBROUTINE DISPER (IDI)
************************************************************************
*
*     THIS SUBROUTINE DETERMINES THE DISPERSION COEFFICIENTS FOR EACH
*     ELEMENT, AT EACH TIMESTEP THAT THE CODE ARRAY IDIF HAS A
*     NON-ZERO VALUE.
*
*     IF IDIF=0: NO NEW DISPERSION COEFFICIENTS.
*     IF IDIF=1: DISPERSION COEFFICIENTS (DXX, DXY, DYY) ARE COMPUTED
*     USING THE CONSTANTS CDIFL AND CDIFT WHICH ARE READ IN HERE.
*     IF IDIF=2: THE DISPERSION COEFFICIENTS (DL, DT) THAT ARE TO BE
*     CHANGED ARE READ IN AND VALUES OF DXX, DXY AND DYY ARE
*     COMPUTED USING THESE VALUES OF DL AND DT.
*     IF IDIF=3: A DISPERSION MODEL IS USED TO CALCULATE THE VALUES OF 
*     DXX, DXY, AND DYY.
*
************************************************************************
      INCLUDE 'hsctm.inc'
      DIMENSION IT(3),TEMP(2,3),NDNOD(10,1000),K(10)
      REAL MXDIF(10,2),MNDIF(10,2)
      GO TO (1,2,3,4),IDI
    1 READ (IN5,10) CDIFL,CDIFT
   10 FORMAT(/,2(7X,F8.2))
      DO 46 I=1,NP
         DIF(I,1)=CDIFL*COS(THTA(I))**2+CDIFT*SIN(THTA(I))**2
         DIF(I,2)=CDIFL*SIN(THTA(I))**2+CDIFT*COS(THTA(I))**2
         DIF(I,3)=0.5*(CDIFL-CDIFT)*SIN(2.0*THTA(I))
   46 CONTINUE
      RETURN
    2 CONTINUE
  432 READ (IN5,12) (IT(J),TEMP(1,J),TEMP(2,J),J=1,3)
      DO 433 I=1,3
         IF (IT(I) .LE. 0) GO TO 434
         N=IT(I)
         DIF(N,1)=TEMP(1,I)*COS(THTA(N))**2+TEMP(2,I)*SIN(THTA(N))**2
         DIF(N,2)=TEMP(1,I)*SIN(THTA(N))**2+TEMP(2,I)*COS(THTA(N))**2
         DIF(N,3)=0.50*(TEMP(1,I)-TEMP(2,I))*SIN(2.0*THTA(N))
  433 CONTINUE
      GO TO 432
  434 CONTINUE
   12 FORMAT (3(I5,2F10.5))
      RETURN
    3 CONTINUE
      DO 5 I=1,NP
         IF (UST(I) .LE. 0.0) GO TO 6
         DIF(I,1)=0.1*VEL(3,I)*(0.20*VEL(1,I))**2/(0.0670*UST(I))
         DIF(I,2)=0.1*VEL(3,I)*(0.20*VEL(2,I))**2/(0.0670*UST(I))
         DIF(I,3)=0.1*0.2**2*VEL(1,I)*VEL(2,I)*VEL(3,I)/(0.0670*UST(I))
         GO TO 5
    6    DIF(I,1)=0.0
         DIF(I,2)=0.0
         DIF(I,3)=0.0
    5 CONTINUE
      RETURN
    4 CONTINUE
*-
* ... USE MODIFIED ELDER DISPERSION MODEL
*-
      IF (NSTEP .EQ. NSTIME) THEN
        READ (IN5,'(I1)') K(1)
        DO 55 N=1,K(1)
           READ (IN5,'(I4)') NDNOD(1,N)
           MNDIF(N,1)=100.0
           MNDIF(N,2)=100.0
           MXDIF(N,1)=0.0
           MXDIF(N,2)=0.0
   55   CONTINUE
      ENDIF
      MCNT=1
      DO 13 I=1,NP
* CALCULATE LONGITUDINAL AND TRANSVERSE DISPERSION FROM ELDER EQN
         CDIFL=60.0*UST(I)*VEL(3,I)
         CDIFT=0.23*UST(I)*VEL(3,I)
* ASSIGN MAX AND MIN VALUES OF LONG. AND TRANS. DISPER.
         IF (I .EQ. NDNOD(1,MCNT)) THEN
            IF (CDIFL .LT. MNDIF(MCNT,1)) MNDIF(MCNT,1)=CDIFL
            IF (CDIFT .LT. MNDIF(MCNT,2)) MNDIF(MCNT,2)=CDIFT
            IF (CDIFL .GT. MXDIF(MCNT,1)) MXDIF(MCNT,1)=CDIFL
            IF (CDIFT .GT. MXDIF(MCNT,2)) MXDIF(MCNT,2)=CDIFT
            MCNT=MCNT+1
         ENDIF
         IF (CDIFL .LT. 2.0) CDIFL=2.0
         IF (CDIFT .LT. 2.0) CDIFT=2.0
         DIF(I,1)=CDIFL*COS(THTA(I))**2+CDIFT*SIN(THTA(I))**2
         DIF(I,2)=CDIFL*SIN(THTA(I))**2+CDIFT*COS(THTA(I))**2
         DIF(I,3)=0.50*(CDIFL-CDIFT)*SIN(2.0*THTA(I))
   13 CONTINUE
      IF (NSTEP .EQ. NCYC)  THEN
         WRITE (10,59)
   59    FORMAT ('NODE, MNDIFL, MXDIFL, MNDIFT, MXDIFT')
         DO 57 N=1,K(1)
            WRITE (10,'(I4,4F10.2)') NDNOD(1,N),MNDIF(N,1),MXDIF(N,1),
     &                               MNDIF(N,2),MXDIF(N,2)
   57    CONTINUE
      ENDIF
      RETURN
      END
************************************************************************
      SUBROUTINE CONCBC (IN1,K)
************************************************************************
*
*     THIS SUBROUTINE READS CONCENTRATION BOUNDARY CONDITIONS
*     DEPENDING ON THE VALUE OF IN1
*
*     IN1=1:  READ BOUNDARY CONDITIONS FROM FORMATTED FILE NUMBER INB
*     IN1=2:  COMPUTE FROM MODEL OR FORMULA
*
************************************************************************
      INCLUDE 'hsctm.inc'
      CHARACTER DUMMY*50
      DIMENSION ACQ(10),NQA(3)
   20 FORMAT (3(I10,F10.5))
      IF (IN1 .EQ. 2) GO TO 2
************************************************************************
*     READ IN BOUNDARY CONDITIONS FROM FILE NUMBERS 14 - 17
************************************************************************
    1 CONTINUE
      INQZ=K+13
      READ (INQZ,3050) DUMMY
 3050 FORMAT (A50)
      DO 1864 I=1,NGC
         READ (INQZ,2164) NQA(I),ACQ(I)
 1864 CONTINUE
 2164 FORMAT (I11,F20.8)
      DO 1464 N=1,NGC
         NLON=NQA(N)
         AC2=ACQ(N)
         LMK=LMT(NLON)
         DO 1164 I=1,LMK
            NN=LINE(NLON,I)
            MFIX(NN,K)=1
            SPEC(NN,K+3)=AC2
 1164    CONTINUE
 1464 CONTINUE
      GO TO 6
*      DO 3 I=1,3
*      IF (IT(I) .LE. 0) GO TO 4
*      N=IT(I)
*      NFIZ(N)=1
************************************************************************
*     THE FIXES FOR BC ARE PERMANENTLY RECORDED IN MFIX
************************************************************************
*      MFIX(N)=1
*      SPEC(N,JQ+3)=TEMP(I)
*    3 CONTINUE
*      GO TO 1
*    4 RETURN
************************************************************************
*     BOUNDARY CONDITIONS ARE COMPUTED USING USER SPECIFIED ROUTINE
************************************************************************
    2 CONTINUE
      DO 200 J=1,NGC
        IF (J .EQ. 1) THEN
           N=1
           ACQ(N)=0.250+0.050*SIN(1.396E-04*TIM(NSTEP)*3600.0)
        ELSE
           N=2
           ACQ(N)=0.250+0.050*SIN(1.396E-04*TIM(NSTEP)*3600.0)
        ENDIF
*       WRITE (LP,6500) NSTEP,TIM(NSTEP),AC
*6500   FORMAT (//,' NSTEP =',I5,'   TIME =',F10.3,' hrs.    BC =',F8.3)
        LMK=LMT(N)
        DO 10 I=1,LMK
           NN=LINE(N,I)
           MFIX(NN,K)=1
           SPEC(NN,K+3)=ACQ(J)
   10   CONTINUE
  200 CONTINUE
    6 RETURN
      END
************************************************************************
      SUBROUTINE VELL (IN1)
************************************************************************
*
*     THIS SUBROUTINE READS THE INITIAL AND SUBSEQUENT VELOCITY FIELDS
*     BASED ON THE VALUE OF IN1
*
*     IN1=1: THE VALUES OF ALL VELOCITIES ARE SET TO CONSTANTS
*            CONXV AND CONYV
*     IN1=2: THE VELOCITIES AT EACH NODE POINT ARE READ IN
*     IN1=3: THE VELOCITES ARE CALCULATED USING USER SPECIFIED PROCEDURE
*     IN1=4: THE VELOCITIES ARE CALCULATED USING THE HYDRO2
*            HYDRODYNAMIC MODULE
*     IN1=5: THE VELOCITIES AT EACH NODE POINT ARE READ IN UNFORMATTED
*            FROM FILE UNIT INF
*
************************************************************************
      INCLUDE 'hsctm.inc'
      PI=3.14159265359E0
      IF (IN1 .NE. 5) GO TO 5
      READ (INF) XVEL
      RETURN
    5 GO TO (1,2,3,4),IN1
    1 READ (INF,10) CONXV,CONYV
   10 FORMAT (2F10.5)
      DO 40 I=1,NP
         VEL(1,I)=CONXV
         VEL(2,I)=CONYV
         IF (VEL(1,I) .NE. 0.0E0) GO TO 12
         IF (VEL(2,I)) 13,14,15
   13    THTA(I)=3.0*PI/2.0
         GO TO 40
   14    THTA(I)=0.0E0
         GO TO 40
   15    THTA(I)=PI/2.0E0
         GO TO 40
   12    THTA(I)=ATAN(VEL(2,I)/VEL(1,I))
   40 CONTINUE
      RETURN
************************************************************************
*     READ NODAL VELOCITIES FROM FORMATTED FILE NUMBER INF
************************************************************************
*         INT = (NPM-LP)/3+1
*         INTT = INT+LP-1
*         DO 410 I = LP, INTT
*            WRITE (13,400) (J, (XVEL(K,J), K = 1, 2), VEL(3,J), 
*     &                     XVEL(3,J), J = I, NPM, INT)
*  400       FORMAT (3(I6,2F9.3,2F8.3))
*  410    CONTINUE
*
*    2 READ(15,41) CTEST
*      IF (CTEST .NE. '  NODE') GO TO 2
*   41 FORMAT(A6)
*      READ(15,*)
*         INT = (NP -1)/ 3+1
*         INTT = INT+1-1
*         DO 410 I = 1, INTT
*            READ (15,400) ((VEL(K,J), K = 1,3), J = I,NP,INT)
*  400       FORMAT (3(6X,2F9.3,F8.3,8X))
*  410    CONTINUE
************************************************************************
*     READ IN BINARY SPECIAL VELOCITY FILE
************************************************************************
    2 CONTINUE
*      IF (NSTEP .EQ. 1) READ (65) IMAC,NP,NE,NTIMES
      READ (65) TET,((VEL(J,K),J=1,3),WSEL(K),NDRY(K),K=1,NP),
     &           (IMAT(JJ),JJ=1,NE)
      WRITE (90,*) 'TIMESTEP= ',NSTEP
*      DO 400 J=1,NP
*         WRITE (90,9994) J,VEL(1,J),VEL(2,J),VEL(3,J),WSEL(J),NDRY(J)
* 9994    FORMAT (I10,' VEL =',4E15.7,I5)
*  400 CONTINUE
*      DO 500 J=1,NE
*         WRITE (90,9995) J,IMAT(J)
* 9995    FORMAT (I10,' IMAT =',I5)
*  500 CONTINUE
*-
*    2 READ (INF,41) (VEL(1,J),VEL(2,J),VEL(3,J),J=1,NP)
*   41 FORMAT (5X,3E15.4)
*-
*    2 CONTINUE
*      REWIND 99
*      READ (99,9994) (VEL(1,K),VEL(2,K),VEL(3,K),
*     &                WSEL(K),K=1,NP),(IMAT(JJ),JJ=1,NE)
*-
      RETURN
************************************************************************
*     NODAL VELOCITIES COMPUTED USING USER SPECIFIED PROCEDURE
************************************************************************
    3 CONTINUE
      RETURN
************************************************************************
*     NODAL VELOCITIES COMPUTED USING HYDRO2 HYDRODYNAMIC MODULE
************************************************************************
    4 CONTINUE
      CALL HYDRO2
*-
      DO 36 I=1,NP
         IF (VEL(1,I) .NE. 0.0E0) GO TO 32
         IF (VEL(2,I)) 33,34,35
   33    THTA(I)=3.0E0*PI/2.0E0
         GO TO 36
   34    THTA(I)=0.0E0
         GO TO 36
   35    THTA(I)=PI/2.0E0
         GO TO 36
   32    THTA(I)=ATAN(VEL(2,I)/VEL(1,I))
   36 CONTINUE
*-
      RETURN
      END
************************************************************************
      SUBROUTINE SETVEL (ISQ,K)
************************************************************************
*
*     THIS SUBROUTINE SETS THE SETTLING VELOCITIES FOR EACH
*     ELEMENT, AT EACH TIMESTEP THAT THE CODE ARRAY IS HAS A
*     NON-ZERO VALUE.
*
*     ISQ=0:  NO NEW SETTLING VELOCITIES.
*     ISQ=1:  SETTLING VELOCITIES ARE SET TO A CONSTANT CVSX WHICH IS
*             READ IN HERE.
*     ISQ=2:  THE SETTLING VELOCITIES THAT ARE TO BE CHANGED ARE
*             READ IN.
*     ISQ=3:  A SETTLING VELOCITY MODEL IS USED TO GENERATE THE VALUES.
*
************************************************************************
      INCLUDE 'hsctm.inc'
      DIMENSION IT(4),TEMP(4)
      GO TO (1,2,3),ISQ
    1 READ (ING,10) CVSX
   10 FORMAT(8F10.5)
      DO 4 I=1,NP
         WS(I,K)=CVSX
    4 CONTINUE
      RETURN
    2 CONTINUE
  432 READ (ING,23) (IT(J),TEMP(J),J=1,4)
      DO 433 I=1,4
      IF (IT(I) .LE. 0) GO TO 434
      N=IT(I)
  433 WS(N,K)=TEMP(I)
      GO TO 432
  434 CONTINUE
   23 FORMAT (4(I10,F10.5))
      RETURN
************************************************************************
*     SETTLING VELOCITIES ARE COMPUTED USING MODEL
************************************************************************
    3 DO 11 I=1,NP
      AKAY=0.002
      SALIN=CNC(I,2)
      IF (SALIN .LT. 0.10) SALIN=0.10
      WS(I,K)=WS1*(SALIN)**EXPM1*AA
      IF (CNC(I,1) .LT. CRCN1) GO TO 11
      IF (CNC(I,1) .LT. CRCN2) GO TO 7
      IF (CNC(I,1) .GE. CRCN3) GO TO 14
      WS(I,K)=WSK2*CNC(I,1)**EXPN2*(SALIN)**EXPM2*AB
      IF (CNC(I,1) .LT. 0.0) WS(I,1)=0.0
      GO TO 11
   14 WRR=(WSK2*CRCN2**EXPN2*(SALIN)**EXPM2*AB)/(1.0-CRCN2*AKAY)**5
      WS(I,K)=(1.0-CNC(I,1)*AKAY)**5*WRR
      IF (CNC(I,1) .LT. 0.0) WS(I,1)=0.0
      GO TO 11
    7 WS(I,K)=WSK1*CNC(I,1)**EXPN1*(SALIN)**EXPM1*AA
      IF (CNC(I,1) .LT. 0.0) WS(I,1)=0.0
   11 CONTINUE
      RETURN
      END
************************************************************************
      SUBROUTINE BEDSS
************************************************************************
      INCLUDE 'hsctm.inc'
      DIMENSION WWT(9),EEN(8,9),PNDS(8,9),PNDE(8,9)
************************************************************************
*     FIRST COMPUTE THE BED SHEAR AT EACH NODE POINT
************************************************************************
      IF (NSTEP .GT. NSTIME) GO TO 14
      IC=0
   14 DO 1 K1 = 1,NP
      USTA=0.0
      BSHEAR(K1)=0.0
      U=VEL(1,K1)
      V=VEL(2,K1)
      UV=SQRT(U*U+V*V)
      IF (UV .LE. 0.0) GO TO 3
* ... USE NEWTON'S METHOD TO COMPUTE BED SHEAR
      UOLD=.03
      USTA=.03
      IF (VEL(3,K1) .LE. 0.0) THEN
         WRITE (LP,10) NSTEP,K1,VEL(3,K1),UV
         BSHEAR(K1) = 0.0E0
      ELSE
   10    FORMAT (2I10,2E15.7)
         A1=5.75E0*ALOG10(3.32E0*VEL(3,K1)/UN)
  112    UOLD=USTA                                
         USTA=UOLD-(UOLD*A1+5.75*UOLD*ALOG10(UOLD)-UV)/(A1+5.75+
     &   5.75*ALOG10(UOLD))
         IF (ABS((USTA-UOLD)/USTA) .GT. 0.01) GO TO 112
         BSHEAR(K1)=USTA*USTA*DEN(K1)
      ENDIF
    3 IF (USTA .LT. 0.0E0) WRITE (LP,101) K1,USTA,VEL(3,K1),DEN
  101 FORMAT (' USTA .LT. 0',I10,3E15.7)
      UST(K1)=USTA
      IF (ISZ .EQ. 1 .AND. ISTP(K1) .EQ. 0) BSO(K1)=BSHEAR(K1)
      IF (BSHEAR(K1)-BSO(K1)) 8,9,11
    8 IVCOP(K1)=0
      IV(K1)=0
      TDP(K1)=0.0
      GO TO 1
    9 IVCOP(K1) = -1
      TDP(K1) = TDP(K1)+DLT
      IF (NSTEP .EQ. NSTIME) TDP(K1)=0.0E0
      IF (ISZ .EQ. 0) GO TO 1
      IF (ISTP(K1) .EQ. 0) GO TO 15
      IV(K1) = 1
      GO TO 1
   15 IV(K1) = 0
      GO TO 1
   11 IVCOP(K1) = 1
      IV(K1) = 1
      TDP(K1)=0.0E0
    1 CONTINUE
************************************************************************
*     THE AVERAGE DEPTHS, FRICTION VELOCITIES, VELOCITIES AND
*     CONCENTRATIONS FOR EACH ELEMENT ARE COMPUTED USING SHAPE 
*     FUNCTIONS
************************************************************************
      DO 80 L = 1,NE
      IF (JQ2 .EQ. 0) GO TO 12
      IC = IC+1
      IF (IC .LE. 1) GO TO 13
      EDENOO(L)=EDENO(L)
      ESALOO(L)=ESALO(L)
   13 EDENO(L)=EDEN(L)
      ESALO(L)=ESAL(L)
   12 A=0.0
      SAA=0.0
      DEE=0.0
      UI=0.0
      VI=0.0
      SHI=0.0
      CI=0.0
      DI=0.0
      ELI=0.0
      USI=0.0
      IF (NOP(L,7) .NE. 0) GO TO 84
      NCN=6
      IPZ=NGAUSP
      DO 85 KK=1,IPZ
      DO 86 I=1,NCN
      EEN(I,KK)=SZ(I,KK)
      PNDS(I,KK)=SX(I,KK)
   86 PNDE(I,KK)=SY(I,KK)
   85 WWT(KK)=QWT(KK)
      GO TO 87
   84 NCN=8
      IPZ=NGAUSS*NGAUSS
      DO 88 KK=1,IPZ
      DO 89 I=1,NCN
      EEN(I,KK)=EN(I,KK)
      PNDS(I,KK)=DNDS(I,KK)
   89 PNDE(I,KK)=DNDE(I,KK)
   88 WWT(KK)=WT(KK)
   87 DO 81 N=1,IPZ
      U=0.0E0
      V=0.0E0
      D=0.0E0
      CZ=0.0E0
      SH=0.0E0
      US=0.0E0
      SA=0.0E0
      DE=0.0E0
      ELLL=0.0E0
      DXDS=0.0E0
      DZDS=0.0E0
      DZDE=0.0E0
      DXDE=0.0E0
      DO 2 I=1,NCN
         K=NOP(L,I)
         K=IABS(K)
         E=EEN(I,N)
         U=E*VEL(1,K)+U
         V=E*VEL(2,K)+V
         D=E*VEL(3,K)+D
         CZ=E*CNC(K,1)+CZ
         US=E*UST(K)+US
         ELLL=E*AO(K)+ELLL
         SH=E*BSHEAR(K)+SH
         SA=E*CNC(K,2)+SA
         DE=E*DEN(K)+DE
         DXDS=PNDS(I,N)*CORD(K,1)+DXDS
         DXDE=PNDE(I,N)*CORD(K,1)+DXDE
         DZDS=PNDS(I,N)*CORD(K,2)+DZDS
         DZDE=PNDE(I,N)*CORD(K,2)+DZDE
         IF (BSHEAR(K) .LT. 0.0) WRITE(LP,111) L,K,I,N,E,BSHEAR(K)
  111    FORMAT (4I9,2E16.8)
    2 CONTINUE
      VJAC=DXDS*DZDE-DXDE*DZDS
      VJAC=VJAC*WWT(N)
      A=A+VJAC
      UI=UI+VJAC*U
      VI=VI+VJAC*V
      CI=CI+VJAC*CZ
      DI=DI+VJAC*D
      USI=USI+VJAC*US
      ELI=ELI+VJAC*ELLL
      SHI=SHI+VJAC*SH
      SAA=SAA+VJAC*SA
      DEE=DEE+VJAC*DE
   81 CONTINUE
      EXV(L)=UI/A
      EYV(L)=VI/A
      EDEP(L)=DI/A
      ECONC(L)=CI/A
      EUSTAR(L)=USI/A
      ESAL(L)=SAA/A
      EDEN(L)=DEE/A
      IF (NSTEP .EQ. NSTIME) EELEV(L)=ELI/A
      ESR(L)=SHI/A
      IF (ESR(L) .LT. 0.0) THEN
         WRITE (LP,100) L,ESR(L),SHI,A,EUSTAR(L)
  100    FORMAT (/,I10,4E15.7)
         ESR(L)=0.0
      ENDIF
      IF (ISZ .EQ. 1 .AND. ISTE(L) .EQ. 0) ESRO(L)=ESR(L)
      IF (ESR(L)-ESRO(L)) 5,6,7
    5 IVCON(L)=0
      IVT(L)=0
      TDE(L)=0.0E0
      GO TO 4
    6 IVCON(L)= -1
      TDE(L)=TDE(L)+DLT
      IF (NSTEP .EQ. NSTIME) TDE(L)=0.0E0
      IF (ISTE(L) .EQ. 0) GO TO 16
      IVT(L)=1
      GO TO 4
   16 IVT(L)=0
      GO TO 4
    7 IVCON(L)=1
      IVT(L)=1
      TDE(L)=0.0E0
    4 IF (AT(L) .EQ. 0.0E0) AT(L)=A
   80 CONTINUE
      RETURN
      END
************************************************************************
      SUBROUTINE RESUSP
************************************************************************
*
*     THIS SUBROUTINE COMPUTES THE RATE OF SURFACE EROSION AS ALPHA2(NN)
*     FOR EACH ELEMENT. SURFACE EROSION CAN OCCUR FROM THE NLAYT
*     CONSOLIDATING LAYERS OF A NEW DEPOSIT, OR FROM ANY LAYER OF
*     THE ORIGINAL BED IF SUCH EXISTS
*
************************************************************************
      INCLUDE 'hsctm.inc'
      DO 1 NN=1,NE
      KZ=NC(NN)
      IF (KZ .EQ. 0) KZ=1
      TEMAL2=ALPHA2(NN)
      ALPHA2(NN)=0.0
      AVERAT(NN)=0.0
************************************************************************
*     CHECK IF ANY LAYER OF UNCONSOLIDATED NEW DEPOSIT EXISTS
************************************************************************
      IF (THICKM(NN,1) .GT. 0.0) GO TO 9
      J=0
************************************************************************
*     CHECK IF ANY PARTIALLY CONSOLIDATED NEW DEPOSIT LAYERS EXIST
************************************************************************
      LO=NLAY(KZ,NN)
      LT=LO
      N=0
      I=1
      ZZ=0.0
      IF (LO .EQ. 0) GO TO 2
      IF (THICK(KZ,NN,LO) .LE. 0.0) GO TO 2
************************************************************************
*     CHECK IF THIS LAYER WILL UNDERGO SURFACE EROSION
************************************************************************
      IF (ESR(NN) .LT. SST(KZ,NN,LO+1) .OR. IVCON(NN) .EQ. 0
     &    .OR. IVT(NN) .EQ. 0) GO TO 9
************************************************************************
*     CALCULATE RATE OF SURFACE EROSION
************************************************************************
      DTH1=0.0
      EPS=EPSN(NN,LO)
      ALF=ALFN(NN,LO)
      GAD1=0.5*(GADT(KZ,NN,LO)+GADT(KZ,NN,LO+1))
      THCK=THICK(KZ,NN,LO)
      DTH=THCK
      SSS=0.5*(SST(KZ,NN,LO+1)+SST(KZ,NN,LO))
      IF (ESR(NN) .LT. SST(KZ,NN,LO)) SSS=0.5*(SST(KZ,NN,LO+1)+ESR(NN))
      KJ=NLAY(KZ,NN)
   65 IF (ESR(NN) .GT. SST(KZ,NN,KJ)) GO TO 66
      ZZ=ZZ+(ESR(NN)-SST(KZ,NN,KJ+1))/(SST(KZ,NN,KJ)-SST(KZ,NN,KJ+1))*
     &   THICK(KZ,NN,KJ)
      GO TO 7
   66 KJ=KJ-1
      ZZ=ZZ+THICK(KZ,NN,KJ+1)
      IF (KJ .LT. 1) GO TO 7
      GO TO 65
    7 ALPHA2(NN)=EPS*EXP((ESR(NN)/SSS-1.0)*ALF)/EDEP(NN)
      IF (NSTEP .EQ. NSTIME) GO TO 9
************************************************************************
*     DETERMINE TOTAL MASS ERODED IN THIS TIME STEP
************************************************************************
      AVERAT(NN)=(1.0-TETA)*TEMAL2+TETA*ALPHA2(NN)
      TMER=AVERAT(NN)*DLT*EDEP(NN)
      QQQ=GAD1*DTH/TMER
      DTH=TMER/GAD1
************************************************************************
*     CHECK IF ENTIRE TOP LAYER IS SUSPENDED
************************************************************************
      BAL=THCK-DTH
      IF (N .EQ. 0) JJ=J+1
      IF (N .GT. 0) GO TO 3
      IF (BAL) 67,4,3
   67 IF (ESR(NN) .LE. SST(KZ,NN,LO)) GO TO 4
      GO TO 12
************************************************************************
*     ONLY PART OF TOP LAYER IS ERODED
************************************************************************
    3 N=N+1
      IF (N-1) 5,5,6
    5 IF (DTH .GT. ZZ) DTH=ZZ
      DTH1=DTH
      QQ1=QQQ
      GO TO 55
    6 DFF=ABS((DTH-DTH1)/DTH)
      IF (DFF .LT. 0.02) GO TO 8
      DTH2=DTH
      DTH=DTH+(DTH-DTH1)*(QQQ-1.0)/(QQ1-QQQ)
      DTH1=DTH2
      QQ1=QQQ
   55 SSS=0.0
      EPS=0.0
      ALF=0.0
      GAD1=0.0
      THCK=0.0
      GO TO 68
   69 JJ=JJ-1
   68 IF (DTH .LE. THICK(KZ,NN,LO)) JJ=1
      DO 18 K=1,JJ
      IF (K .EQ. JJ) GO TO 19
      A=THICK(KZ,NN,LO+1-K)
      EPS=EPS+EPSN(NN,LO+1-K)*A
      ALF=ALF+ALFN(NN,LO+1-K)*A
      THCK=THCK+A
      IF (DTH .LE. THCK.AND.K .LT. JJ-1) GO TO 69
      SSS=SSS+0.5*(SST(KZ,NN,LO+2-K)+SST(KZ,NN,LO+1-K))*A
      GAD1=GAD1+0.5*(GADT(KZ,NN,LO+2-K)+GADT(KZ,NN,LO+1-K))*A
      GO TO 18
   19 IF (DTH .GT. ZZ) DTH=ZZ
      A=DTH-THCK
      EPS=EPS+EPSN(NN,LO+1-K)*A
      ALF=ALF+ALFN(NN,LO+1-K)*A
      THCK=DTH
      SSS=SSS+0.5*(2.0*SST(KZ,NN,LO+2-K)+(SST(KZ,NN,LO+1-K)
     &-SST(KZ,NN,LO+2-K))*A/THICK(KZ,NN,LO+1-K))*A
      GAD1=GAD1+0.5*(2.0*GADT(KZ,NN,LO+2-K)+(GADT(KZ,NN,LO+1-K)-
     &GADT(KZ,NN,LO+2-K))*A/THICK(KZ,NN,LO+1-K))*A
      EPS=EPS/THCK
      ALF=ALF/THCK
      SSS=SSS/THCK
      GAD1=GAD1/THCK
   18 CONTINUE
      GO TO 7
    8 BEDEL(NN)=BEDEL(NN)-DTH
      BEDL(NN)= -DTH+BEDL(NN)
      IF (DTH .LE. 0.0) WRITE (LP,20)
   20 FORMAT (/'  WARNING: VALUE OF DTH IS LESS THAN ZERO  ')
      X=0.0
      IF (J .EQ. 0) GO TO 21
      NLAY(KZ,NN)=NLAY(KZ,NN)-J
      DO 22 K=1,J
      X=X+THICK(KZ,NN,LO+1-K)
      GADT(KZ,NN,LO+2-K)=0.0
      GBT(KZ,NN,LO+2-K)=0.0
      THICK(KZ,NN,LO+1-K)=0.0
      EPSN(NN,LO+1-K)=0.0
      ALFN(NN,LO+1-K)=0.0
      SST(KZ,NN,LO+2-K)=0.0
   22 CONTINUE
   21 X=DTH-X
*     IF (X .LE. 0.0) WRITE (LP,20)ZZ,X,DTH,J,JJ,NSTEP
      SST(KZ,NN,LO+1-J)=SST(KZ,NN,LO+1-J)+X*(SST(KZ,NN,LO-J)-
     &                  SST(KZ,NN,LO+1-J))/THICK(KZ,NN,LO-J)
      GADT(KZ,NN,LO+1-J)=GADT(KZ,NN,LO+1-J)+X*(GADT(KZ,NN,LO-J)
     &                  -GADT(KZ,NN,LO+1-J))/THICK(KZ,NN,LO-J)
      GBT(KZ,NN,LO+1-J)=GBT(KZ,NN,LO+1-J)+X*(GBT(KZ,NN,LO-J)
     &                 -GBT(KZ,NN,LO+1-J))/THICK(KZ,NN,LO-J)
      THICK(KZ,NN,LO-J)=THICK(KZ,NN,LO-J)-X
      IF (THICK(KZ,NN,LO-J) .GE. 0.0) GO TO 71
      THICK(KZ,NN,LO-J)=0.0
      EPSN(NN,LO-J)=0.0
      ALFN(NN,LO-J)=0.0
      SST(KZ,NN,LO+1-J)=0.0
      GADT(KZ,NN,LO+1-J)=0.0
      GBT(KZ,NN,LO+1-J)=0.0
      NLAY(KZ,NN)=NLAY(KZ,NN)-1
   71 N=0
      GO TO 9
************************************************************************
*     FULL TOP LAYER IS SUSPENDED
************************************************************************
    4 JL=J+1
      NLAY(KZ,NN)=NLAY(KZ,NN)-JL
      DO 17 II=1,JL
      BEDEL(NN)=BEDEL(NN)-THICK(KZ,NN,LO+1-II)
      BEDL(NN)= -THICK(KZ,NN,LO+1-II)+BEDL(NN)
      THICK(KZ,NN,LO+1-II)=0.0
      EPSN(NN,LO+1-II)=0.0
      ALFN(NN,LO+1-II)=0.0
      SST(KZ,NN,LO+2-II)=0.0
      GADT(KZ,NN,LO+2-II)=0.0
      GBT(KZ,NN,LO+2-II)=0.0
   17 CONTINUE
      GO TO 9
************************************************************************
*     MORE THAN TOP LAYER IS SUSPENDED
************************************************************************
   12 J=J+1
      LT=LT-1
      L=LO-J
      IF (L .EQ. 0) GO TO 13
      SSS=0.0
      EPS=0.0
      ALF=0.0
      GAD1=0.0
      THCK=0.0
      JJ=J+2
      DO 14 K=1,JJ
      IF (K .EQ. JJ) GO TO 15
      EPS=EPS+EPSN(NN,LO+1-K)*THICK(KZ,NN,LO+1-K)                       
      ALF=ALF+ALFN(NN,LO+1-K)*THICK(KZ,NN,LO+1-K)                       
      THCK=THCK+THICK(KZ,NN,LO+1-K)                                     
      IF (K .EQ. 1) GO TO 16                                              
      SSS=SSS+SST(KZ,NN,LO+2-K)*(THICK(KZ,NN,LO+1-K)+THICK(KZ,NN,LO+2-K)
     &)/2.0                                                             
      GAD1=GAD1+GADT(KZ,NN,LO+2-K)*(THICK(KZ,NN,LO+1-K)+                
     &THICK(KZ,NN,LO+2-K))/2.0                                          
      GO TO 14                                                          
   15 SSS=SSS+SST(KZ,NN,LO+2-K)*THICK(KZ,NN,LO+2-K)/2.0                 
      GAD1=GAD1+GADT(KZ,NN,LO+2-K)*THICK(KZ,NN,LO+2-K)/2.0              
      EPS=EPS/THCK                                                      
      ALF=ALF/THCK                                                      
      SSS=SSS/THCK                                                      
      GAD1=GAD1/THCK                                                    
      GO TO 14                                                          
   16 SSS=SSS+SST(KZ,NN,LO+2-K)*THICK(KZ,NN,LO+1-K)/2.0                 
      GAD1=GAD1+GADT(KZ,NN,LO+2-K)*THICK(KZ,NN,LO+1-K)/2.0              
   14 CONTINUE                                                          
      GO TO 7                                                           
************************************************************************
*     ENTIRE NEW DEPOSIT IS ENTRAINED
************************************************************************
   13 AVERAT(NN)=GAD1*THCK/(DLT*EDEP(NN))
      ALPHA2(NN)=(AVERAT(NN)-(1.0-TETA)*TEMAL2)/TETA
      DO 23 K=1,LO
      BEDL(NN)= -THICK(KZ,NN,LO+1-K)+BEDL(NN)
      BEDEL(NN)=BEDEL(NN)-THICK(KZ,NN,LO+1-K)
      THICK(KZ,NN,LO+1-K)=0.0
      EPSN(NN,LO+1-K)=0.0
      ALFN(NN,LO+1-K)=0.0
      SST(KZ,NN,LO+2-K)=0.0
      GADT(KZ,NN,LO+2-K)=0.0
      GBT(KZ,NN,LO+2-K)=0.0
   23 CONTINUE
      NLAY(KZ,NN)=0
      NC(NN)=NC(NN)-1
      GO TO 9
************************************************************************
*     CHECK IF ANY ORIGINAL BED LAYERS EXIST.
************************************************************************
    2 LO=NLAYO(NN)
      IF (NLAY(KZ,NN) .NE. 0 .AND. NLAYO(NN) .NE. 0) GO TO 72
      DO 73 K=1,8
         QK(NN,K)=0.0
   73 CONTINUE
   72 IF (LO .EQ. 0) GO TO 9
************************************************************************
*     CHECK IF TOP LAYER WILL UNDERGO SURFACE EROSION
************************************************************************
      IF (ESR(NN) .LE. SSTO(NN,I) .OR. IVCON(NN) .EQ. 0
     &   .OR. IVT(NN) .EQ. 0) GO TO 9
************************************************************************
*     CALCULATE RATE OF SURFACE EROSION
************************************************************************
      N=0
      ZZ=0.0
      ERO=EROCON(NN,I)
      GAD1=0.5*(GADO(NN,I)+GADO(NN,I+1))
      THCK=THICKO(NN,I)
      DTH=THCK
      SSS=0.5*(SSTO(NN,I+1)+SSTO(NN,I))
      IF (ESR(NN) .LT. SSTO(NN,I+1)) SSS=0.5*(SSTO(NN,I)+ESR(NN))
      KJ=1
   62 IF (ESR(NN) .GT. SSTO(NN,KJ+1)) GO TO 59
      ZZ=ZZ+(ESR(NN)-SSTO(NN,KJ))/(SSTO(NN,KJ+1)-SSTO(NN,KJ))*
     &   THICKO(NN,KJ)
      GO TO 24
   59 KJ=KJ+1
      ZZ=ZZ+THICKO(NN,KJ-1)
      IF (KJ .GE. LO+1) GO TO 24
      GO TO 62
   24 ALPHA2(NN)=ERO*(ESR(NN)/SSS-1.0)/EDEP(NN)
      IF (NSTEP .EQ. NSTIME) GO TO 9
************************************************************************
*     DETERMINE TOTAL MASS ERODED IN THIS TIME STEP
************************************************************************
      AVERAT(NN)=(1.0-TETA)*TEMAL2+TETA*ALPHA2(NN)
      TMER=AVERAT(NN)*DLT*EDEP(NN)
      QQQ=GAD1*DTH/TMER
      DTH=TMER/GAD1
************************************************************************
*     CHECK IF ENTIRE TOP LAYER IS SUSPENDED
************************************************************************
      BAL=THCK-DTH
      IF (N .EQ. 0) JJ=J+1
      IF (N .GT. 0) GO TO 25
      IF (BAL)26,27,25
   26 IF (ESR(NN) .LE. SSTO(NN,I+1)) GO TO 27
      GO TO 56
************************************************************************
*     ONLY PART OF TOP LAYER IS SUSPENDED
************************************************************************
   25 N=N+1
      IF (N-1) 31,31,32
   31 IF (DTH .GT. ZZ) DTH=ZZ
      DTH1=DTH
      QQ1=QQQ
      GO TO 54
   32 DFF=ABS((DTH-DTH1)/DTH)
      IF (DFF .LT. 0.03) GO TO 33
      DTH2=DTH
      DTH=DTH+(DTH-DTH1)*(QQQ-1.0)/(QQ1-QQQ)
      DTH1=DTH2
      QQ1=QQQ
   54 SSS=0.0
      ERO=0.0
      GAD1=0.0
      THCK=0.0
      GO TO 64
   63 JJ=JJ-1
   64 IF (DTH .LE. THICKO(NN,1)) JJ=1
      DO 28 K=1,JJ
      IF (K .EQ. JJ) GO TO 29
      A=THICKO(NN,K)
      ERO=ERO+EROCON(NN,K)*A                                            
      THCK=THCK+A                                                       
      IF (DTH .LE. THCK .AND. K .LT. JJ-1) GO TO 63
      SSS=SSS+0.5*(SSTO(NN,K)+SSTO(NN,K+1))*A                           
      GAD1=GAD1+0.5*(GADO(NN,K)+GADO(NN,K+1))*A                         
      GO TO 28                                                          
   29 IF (DTH .GT. ZZ) DTH=ZZ                                              
      A=DTH-THCK                                                        
      ERO=ERO+EROCON(NN,K)*A                                            
      THCK=A+THCK                                                       
      SSS=SSS+0.5*(2.0*SSTO(NN,K)+(SSTO(NN,K+1)-SSTO(NN,K))*A/
     &    THICKO(NN,K))*A
      GAD1=GAD1+0.5*(2.0*GADO(NN,K)+(GADO(NN,K+1)-GADO(NN,K))*A/
     &    THICKO(NN,K))*A
      ERO=ERO/THCK                                                      
      SSS=SSS/THCK                                                      
      GAD1=GAD1/THCK                                                    
   28 CONTINUE                                                          
      GO TO 24                                                          
   33 BEDEL(NN)=BEDEL(NN)-DTH
      BEDL(NN)=BEDL(NN)-DTH                                           
      X=0.0                                                           
      IF (J .EQ. 0) GO TO 35                                              
      KJ=NLAYO(NN)-J+1                                                  
      DO 34 K=1,KJ                                                      
      IF (K .EQ. KJ) GO TO 44                                             
      IF (K .GT. J) GO TO 53                                              
      X=X+THICKO(NN,K)                                                  
   53 THICKO(NN,K)=THICKO(NN,J+K)                                       
      EROCON(NN,K)=EROCON(NN,J+K)                                       
   44 SSTO(NN,K)=SSTO(NN,J+K)                                           
      GADO(NN,K)=GADO(NN,J+K)                                           
      GBO(NN,K)=GBO(NN,J+K)                                             
   34 CONTINUE                                                          
   35 X=DTH-X                                                           
      SSTO(NN,1)=SSTO(NN,1)+X*(SSTO(NN,2)-SSTO(NN,1))/THICKO(NN,1)      
      GADO(NN,1)=GADO(NN,1)+X*(GADO(NN,2)-GADO(NN,1))/THICKO(NN,1)      
      GBO(NN,1)=GBO(NN,1)+X*(GBO(NN,2)-GBO(NN,1))/THICKO(NN,1)          
      THICKO(NN,1)=THICKO(NN,1)-X                                       
      N=0                                                               
      NO=NLAYO(NN)                                                      
      IF (J .EQ. 0) GO TO 9                                               
      DO 43 K=1,J                                                       
      THICKO(NN,NO-J+1)=0.0                                           
      EROCON(NN,NO-J+1)=0.0                                           
      SSTO(NN,NO-J+2)=0.0                                             
      GADO(NN,NO-J+2)=0.0                                             
      GBO(NN,NO-J+2)=0.0                                              
   43 CONTINUE                                                          
      NLAYO(NN)=NLAYO(NN)-J                                             
      GO TO 9                                                           
************************************************************************
*     FULL TOP LAYER IS SUSPENDED
************************************************************************
   27 KJ=NLAYO(NN)                                                      
      JL=J+1                                                            
      YZ=THICKO(NN,1)                                                   
      DO 36 K=1,KJ                                                      
      IF (K .EQ. KJ) GO TO 46                                             
      THICKO(NN,K)=THICKO(NN,K+1)                                       
      EROCON(NN,K)=EROCON(NN,K+1)                                       
   46 SSTO(NN,K)=SSTO(NN,K+1)                                           
      GADO(NN,K)=GADO(NN,K+1)                                           
      GBO(NN,K)=GBO(NN,K+1)                                             
   36 CONTINUE                                                          
      DO 47 K=1,JL                                                      
      BEDEL(NN)=BEDEL(NN)-YZ
      BEDL(NN)=BEDL(NN)-YZ                                            
      THICKO(NN,KJ-JL+1)=0.0                                          
      SSTO(NN,KJ-JL+2)=0.0                                            
      GADO(NN,KJ-JL+2)=0.0                                            
      GBO(NN,KJ-JL+2)=0.0                                             
      EROCON(NN,KJ-JL+1)=0.0                                          
   47 CONTINUE                                                          
      NLAYO(NN)=NLAYO(NN)-JL                                            
      GO TO 9                                                           
************************************************************************
*     MORE THAN TOP LAYER IS SUSPENDED
************************************************************************
   56 J=J+1                                                             
      LT=LT-1                                                           
      L=LO-J                                                            
      IF (L .LE. 0) GO TO 37                                              
      SSS=0.0                                                         
      ERO=0.0                                                         
      GAD1=0.0                                                        
      THCK=0.0                                                        
      JJ=J+2                                                            
      DO 38 K=1,JJ                                                      
      IF (K .EQ. JJ) GO TO 39                                             
      ERO=ERO+EROCON(NN,K)*THICKO(NN,K)                                 
      THCK=THCK+THICKO(NN,K)                                            
      IF (K .EQ. 1) GO TO 41                                              
      SSS=SSS+SSTO(NN,K)*(THICKO(NN,K)+THICKO(NN,K-1))/2.0              
      GAD1=GAD1+GADO(NN,K)*(THICKO(NN,K)+THICKO(NN,K-1))/2.0            
      GO TO 38                                                          
   39 SSS=SSS+SSTO(NN,K)*THICKO(NN,K-1)/2.0                             
      GAD1=GAD1+GADO(NN,K)*THICKO(NN,K-1)/2.0                           
      ERO=ERO/THCK                                                      
      SSS=SSS/THCK                                                      
      GAD1=GAD1/THCK                                                    
      GO TO 38                                                          
   41 SSS=SSS+SSTO(NN,K)*THICKO(NN,K)/2.0                               
      GAD1=GAD1+GADO(NN,K)*THICKO(NN,K)/2.0                             
   38 CONTINUE                                                          
      GO TO 24                                                          
************************************************************************
*     ENTIRE ORIGINAL BED IS ENTRAINED
************************************************************************
   37 AVERAT(NN)=GAD1*THCK/(DLT*EDEP(NN))
      ALPHA2(NN)=(AVERAT(NN)-(1.0-TETA)*TEMAL2)/TETA                    
      DO 42 K=1,LO                                                      
      BEDEL(NN)=BEDEL(NN)-THICKO(NN,K)
      BEDL(NN)=BEDL(NN)-THICKO(NN,K)                                 
      THICKO(NN,K)=0.0                                                
      SSTO(NN,K)=0.0                                                  
      GADO(NN,K)=0.0                                                  
      GBO(NN,K)=0.0                                                   
   42 CONTINUE                                                          
      NLAYO(NN)=0                                                       
************************************************************************
*     SET OLD ELEMENTAL BED SHEAR STRESS TO NEW SHEAR STRESS.
************************************************************************
    9 ESRO(NN)=ESR(NN)
      IF (ALPHA2(NN) .GT. 0.0) IFLAG(NN)=3
    1 CONTINUE
      RETURN
      END
************************************************************************
      SUBROUTINE SEDPRP
************************************************************************
*
*     THIS SUBROUTINE READS THE PROPERTIES OF COHESIVE SEDIMENTS THAT
*     EXIST IN THE SYSTEM. THE INITIAL BED PROFILE AND PROPERTIES ARE
*     READ IN BY SUBROUTINE ORGBED.
*
************************************************************************
      INCLUDE 'hsctm.inc'
************************************************************************
*     SETTLING VELOCITY PARAMETERS
************************************************************************
      GRAV=9.806
      READ (IN5,4999) DUMMY
 4999 FORMAT(A80)
      READ (IN5,5000) CRCN1,CRCN2,CRCN3,GAC
 5000 FORMAT (10X,F10.3,/,10X,F10.3,/,10X,F10.3,/40X,F10.5,/)
      READ (IN5,5001) AA,AB,AC,B,FZ,AL
 5001 FORMAT (6(10X,F10.4,/))
      READ (IN5,5010) WS1,D
      D=D*1.0E+06
 5010 FORMAT (10X,F10.5,/,25X,F10.5,/)
      READ (IN5,5002) EXPN1,EXPN2
 5002 FORMAT (10X,F10.5,/,10X,F10.5,/)
      READ (IN5,5003) EXPM1,EXPM2,EXPM3
 5003 FORMAT (10X,F10.5,/,10X,F10.5,/,10X,F10.5,/)
      READ (IN5,5007) WSK1,WSK2
 5007 FORMAT (10X,E10.5,/,10X,E10.5,/)
      WRITE (LP,6000)
 6000 FORMAT (////1X,75('='),/20X,'SEDIMENT PROPERTIES',/,1X,75('='))
      WRITE (LP,6010)
 6010 FORMAT (//1X,'SETTLING VELOCITIES:',//,
     & 1X,20HCONC. RANGE(KG/M^3) ,11X ,25HSETTLING VELOCITY (M/SEC),/,
     & 78('-'))
      A=0.0E0
      WRITE (LP,6020) A,CRCN1,WS1
 6020 FORMAT (1X,F3.0,5X,2HTO,F10.3,11X,1PE12.3)
      WRITE (LP,6030) CRCN1,CRCN2,AA,WSK1,EXPN1,EXPM1
      IF (CRCN3 .EQ. CRCN2) GO TO 1000
      WRITE (LP,6030) CRCN2,CRCN3,AB,WSK2,EXPN2,EXPM2
 1000 CONTINUE
*      AKK=AC*GRAV*D**2.0*0.25/(18.0*UN*D**1.8)
 6030 FORMAT (1X,F5.2,3X,2HTO,F10.3,3X,3HWS=,F4.2,1H*,D9.3,7H*CONC**
     &        ,F4.2,'*(SAL)**',F4.2)
      WRITE (LP,6040) CRCN3
 6040 FORMAT (2X,5HABOVE,F6.2,11X,'WS=0.003*(1.0-0.001*CONC)**5')
************************************************************************
*     NEW DEPOSIT PROPERTIES
************************************************************************
      READ (IN5,5020) NLAYTM,NLAYT,TAUBMN,TAUMAX
      WRITE (LP,6050) TAUBMN,TAUMAX
 5020 FORMAT (55X,I5,/,55X,I5,/,25X,F10.5,/,25X,F10.5,/)
 6050 FORMAT(//1X,'MINIMUM DEPOSITIONAL SHEAR STRESS =',F7.3,1X,'N/M^2
     &'/1X,'MAXIMUM DEPOSITIONAL SHEAR STRESS =',F7.3,1X,'N/m^2')
      WRITE (LP,6060) TEMPC,GAC,UN
 6060 FORMAT(//1X,'TEMPERATURE OF SUSPENDING WATER =',F7.1,' CELCIUS'/
     &1X,'DENSITY OF SEDIMENT MINERAL     =',F7.1,' kg/m^3'/
     &1X,'KIN. VISCOSITY OF SUSP. WATER   =',E10.3,' M^2/SEC')
      IF (ISZ .EQ. 1) GO TO 1010
      READ (IN5,5008) A1,S1,A2,S2,C1
 5008 FORMAT (5X,F10.2,/,5X,F10.2,/,5X,F10.2,/,5X,F10.2,/,5X,F10.5,/)
      READ (IN5,5008) A3,S3,A4,S4,C2
      GO TO 1020
 1010 CONTINUE
      READ (IN5,5000) T50,SIG2,CEQ
 1020 CONTINUE
      WRITE (LP,6070)
 6070 FORMAT (/////1X,75('='),/20X,'NEW DEPOSIT PROPERTIES:'
     &        /1X,75('='))
      KJ=NLAYTM+1
      READ (IN5,5030) (SSM(I),GADM(I),I=1,KJ)
      READ (IN5,5035) DUMMY
      READ (IN5,5040) (TLAYM(I),I=1,NLAYTM)
      READ (IN5,5035) DUMMY
      WRITE (LP,6080)
 6080 FORMAT (//1X,'PROPERTIES OF UNCONSOLIDATED NEW DEPOSITS:')
      WRITE (LP,6090)
 6090 FORMAT (1X,75('-'),/,14X,'AVERAGE',12X,'AVERAGE',
     & 22X,'AVERAGE',/,1X,'LAYER',4X,' SHEAR STRENGTH',6X,'BULK DENSITY'
     & ,3X,'THICKNESS',6X,'DRY DENSITY'/15X,'N/m^2',13X,'kg/m^3',
     & 9X,'METERS',8X,'KG/M^3',/,1X,75('-'))
      DO 1030 I=1,KJ
         GBM(I)=GADM(I)*(GAC-GAW)/GAC+GAW
 1030 CONTINUE
      DO 1040 I=1,NLAYTM
         AVSSM=0.5*(SSM(I)+SSM(I+1))
         AVGBM=0.5*(GBM(I)+GBM(I+1))
         AVGADM=0.5*(GADM(I)+GADM(I+1))
         WRITE (LP,6100)I,AVSSM,AVGBM,TLAYM(I),AVGADM
 1040 CONTINUE
 6100 FORMAT (I4,F15.3,F21.2,F14.3,F14.2)
      WRITE (LP,6110)
 6110 FORMAT(///1X,'PROPERTIES OF PARTIALLY CONSOLIDATED NEW DEPOSITS:')
      WRITE (LP,6120)
 6120 FORMAT (1X,75('-'),
     &       /12X,'AVERAGE',10X,'AVERAGE',5X,'THICK-',1X,'AVERAGE',
     &       /1X,'LAYER',3X,'SHEAR STRENGTH',3X,'BULK DENSITY',
     &       3X,' NESS ',1X,'DENSITY',2X,'EPSILON',4X,'ALPHA',/,
     &       1X,75('-'))
      JK=NLAYT+1
      READ (IN5,5030) (SS(I),GAD(I),I=1,JK)
      READ (IN5,5035) DUMMY
      READ (IN5,5050) (TLAY(I),EPSLON(I),AFLA(I),I=1,NLAYT)
      READ (IN5,5035) DUMMY
 5030 FORMAT (20X,F10.5,30X,F10.5)
 5035 FORMAT (A80)
 5050 FORMAT (16X,F9.5,15X,F10.5,12X,F9.5)
 5040 FORMAT (50X,2F10.5)
      DO 1050 I=1,JK
         GB(I)=GAD(I)*(GAC-GAW)/GAC+GAW
 1050 CONTINUE
      DO 1060 I=1,NLAYT
         AVSS=0.5*(SS(I)+SS(I+1))
         AVGB=0.5*(GB(I)+GB(I+1))
         AVGAD=0.5*(GAD(I)+GAD(I+1))
         WRITE (LP,6130) I,AVSS,AVGB,TLAY(I),AVGAD,EPSLON(I),AFLA(I)
 6130    FORMAT (I4,F14.3,F19.3,F10.5,F8.4,F9.6,F9.3)
 1060 CONTINUE
      DO 1070 NN = 1,NE
         DO 1080 I = 1,JK
            GD(NN,I)=GAD(I)
 1080    CONTINUE
         DO 1090 I = 1,KJ
            GDM(NN,I)=GADM(I)
 1090    CONTINUE
 1070 CONTINUE
      RETURN
      END
************************************************************************
      SUBROUTINE DEPSN (K)
************************************************************************
*
*     THIS SUBROUTINE COMPUTES THE RATE OF DEPOSITION, IF ANY OCCURS,
*     AT EACH NODE POINT. THE DEPOSITIONAL RATE IS RETURNED IN ARRAY
*     ALPHA1(I,K).
*
************************************************************************
      INCLUDE 'hsctm.inc'
      TWO=2.0E0
      TPI=2.0E0*3.14159E0
      DO 1111 I=1,NP
      SALIN=CNC(I,2)
      IF (SALIN .LT. 0.10) SALIN=0.10E0
      ALPHA1(I,K)=0.0E0
      IF (BSHEAR(I) .GE. TAUMAX .OR. NFIZ(I,K) .EQ. 1) GO TO 1
      TAUBM=BSHEAR(I)/TAUBMN                                            
      TAUBMO=BSO(I)/TAUBMN
      IF (IVCOP(I) .EQ. 1 .OR. IV(I) .EQ. 1) GO TO 1
      IF (TAUBM .LT. 0.25) GO TO 7
      IF (IV(I) .EQ. 0 .AND. IVCOP(I) .EQ. 0) CNT(I,K)=CNC(I,K)
    6 CONCC=CNC(I,K)
      CNT(I,K)=CNC(I,K)
      IF (CONCC .EQ. 0.0E0) GO TO 1
      TD=TDP(I)
      TDD=TD-DLT
      IF (TDD .LE. 0.0E0) TDD=0.01E0
      IF (TD .LE. 0.0E0) TD=DLT                                          
      IF (NSTEP .NE. NSTIME) GO TO 8
      TD=DLT                                                           
    8 IF (ISZ .EQ. 1) GO TO 9
      SIG2=SIGFUN(TAUBM)                                          
      SIG2O=SIGFUN(TAUBMO)                                        
      T50=T50FUN(TAUBM)                                           
      T50O=T50FUN(TAUBMO)
      GO TO 12                                                          
    9 T50O=T50                                                          
      SIG2O=SIG2                                                        
   12 TQW=ALOG10((TD/T50)*B*SALIN**FZ)/SIG2                     
      TO=ALOG10((TDD/T50O)*B*SALIN**FZ)/SIG2O              
      IF (NSTEP .EQ. NSTIME) TQW=ALOG10(TDD/T50)/SIG2
      IF (TQW .LT. -18.0E0) TQW= -18.0E0
      IF (TO .LT. -18.0E0) TO= -18.0E0
      IF (TQW .GT. 18.0E0) TQW=18.0E0
      IF (TO .GT. 18.0E0) TO=18.0E0
      IF (IVCOP(I) .EQ. -1) GO TO 4
      CEQ=0.0E0
      GO TO 5
    4 SIG1=0.49E0
      TAU50=4.0*EXP(-12.7E0*TAUBMN)
      IF (TAUBM .LE. 1.0E0) GO TO 3
      YA=ALOG10((TAUBM-1.0)/TAU50)/SIG1
      IF (ISZ .EQ. 1) GO TO 5
      CEQ=0.5E0*(1.0E0+ERF(YA/SQRT(TWO)))                             
      GO TO 5                                                           
    3 CEQ=0.0E0
    5 IF (TAUBM .GE. 1.0E0 .OR. CNC(I,K) .GE. CRCN1) GO TO 2
      TAUBC=1.0E0+0.434E0*VEL(3,I)*EXP(-TQW**2/2.0E0)*(CEQ-1.0E0)/
     &      (SIG2*TD*SQRT(TPI)*WS(I,K))
      IF (TAUBC .LT. 0.25E0) TAUBC=0.25E0
      IF (CNC(I,K) .LT. CRCN1) GO TO 7
      IF (TAUBM .GE. TAUBC) GO TO 2
    7 PD=1.0E0-TAUBM
*      IF (I. EQ. 1599) WRITE (LP,9864)
* 9864 FORMAT (' AT STATEMENT NO. 7')
      IF (TAUBM .LT. 0.25E0) GO TO 14
      IF (TAUBM .GE. TAUBC) PD=1.0E0-TAUBC
   14 ALPHA1(I,K)= -WS(I,K)*PD/VEL(3,I)
      GO TO 1
    2 THT=TETZ(I)
      CTHT=1.0E0-THT
      BETA=1.0E0/(2.0E0*DLT)*(ERF(TQW/SQRT(TWO))-
     &     ERF(TO/SQRT(TWO)))/
     &     (0.434/(SIG2*SQRT(TPI))*(THT*EXP(-TQW**2/2.0)/TD+CTHT*
     &     EXP(-TO**2/2.0E0)/TDD))
   11 IF (ISZ .EQ. 0) GO TO 13
      ALPHA1(I,K)=(CEQ-1.0E0)*0.434E0*EXP(-TQW**2/2.0E0)/(SIG2*TD*
     &            SQRT(TPI))*BETA*CNT(I,K)/CONCC
      IF (CNT(I,K) .LT. 0.0E0) ALPHA1(I,K)=0.0E0
      GO TO 1
   13 ALPHA1(I,K)=(CEQ-1.0E0)*0.434E0*EXP(-TQW**2/2.0E0)/(SIG2*TD*
     &            SQRT(TPI))*BETA*CNC(I,K)/CONCC
      IF (CNC(I,K) .LT. 0.0E0) ALPHA1(I,K)=0.0E0
    1 CONTINUE
*      IF (I .EQ. 1599) THEN
*         WRITE (LP,9948) K,I,NSTEP,CNC(I,K),WS(I,K),PD,VEL(3,I),
*     &                   ALPHA1(I,K),TAUBC,TAUBM,IV(I),IVCOP(I)
* 9948    FORMAT (3I5,' CNC=',7E14.6,2I5)
*      ENDIF
 1111 CONTINUE
      RETURN
      END
************************************************************************
      SUBROUTINE ORGBED
************************************************************************
*     THIS SUBROUTINE READS THE INITIAL BED PROFILE IF IBED .NE. 0
************************************************************************
      INCLUDE 'hsctm.inc'
      DIMENSION IT(MEL),TEMP(MEL)
      CHARACTER*80 DUMMY
   15 FORMAT(///40X,'INITIAL BED PROFILE'/40X,19(1H-),/9X,'ELEMENT',4X, 
     &'LAYER',4X,'THICKNESS',4X,'AVE.BULK DENSITY   AVE.SHEAR STRENGTH',
     &5X,'ERO. CONST.'/12X,'NO.',7X,'NO.',7X,'METERS',10X,'KG/CU.M',13X,
     &'N/SQ.M',10X,'KG/SQ.M/SEC')
      IL=0
      READ (IN5,1095) DUMMY
 1095 FORMAT (A80)
   10 READ (IN5,1) NN,NLA,NM,GWA
      IF (NN .LT. 0) GO TO 11
      IF (IL .NE. 0) GO TO 7
      WRITE (LP,15)
      IL=IL+1
    7 NLAYO(NN)=NLA
    1 FORMAT (3I5,F10.5)
      NL=NLAYO(NN)
      NNL=NL+1
      READ (IN5,3) (SSTO(NN,I),GADO(NN,I),I=1,NNL)
    3 FORMAT (2F10.5)
      READ (IN5,6) (THICKO(NN,I),EROCON(NN,I),I=1,NL)
    6 FORMAT (2E10.3)
   14 DO 8 I=1,NNL
         GBO(NN,I)=GADO(NN,I)*(GAC-GWA)/GAC+GWA
    8 CONTINUE
      DO 2 I=1,NL
      AVSSTO=0.5*(SSTO(NN,I)+SSTO(NN,I+1))
      AVGBO=0.5*(GBO(NN,I)+GBO(NN,I+1))
      IF (I .GT. 1) GO TO 4
      WRITE (LP,16) NN,I,THICKO(NN,I),AVGBO,AVSSTO,EROCON(NN,I)
   16 FORMAT (/I14,I10,E14.3,F17.1,F19.3,E21.3)
      GO TO 2
    4 WRITE (LP,17) I,THICKO(NN,I),AVGBO,AVSSTO,EROCON(NN,I)
   17 FORMAT (14X,I10,E14.3,F17.1,F19.3,E21.3)
    2 CONTINUE
      IF (NM .EQ. 0) GO TO 10
      NN=NN+1
      IF (NN .GT. NE) GO TO 10
      NLAYO(NN)=NLA
      NL=NLAYO(NN)
      NNL=NL+1
      DO 12 I=1,NNL
         SSTO(NN,I)=SSTO(1,I)
         GBO(NN,I)=GBO(1,I)
         GADO(NN,I)=GADO(1,I)
   12 CONTINUE
      DO 13 I=1,NL
         THICKO(NN,I)=THICKO(1,I)
         EROCON(NN,I)=EROCON(1,I)
   13 CONTINUE
      GO TO 14
************************************************************************
*     READ DRY MASS PER UNIT AREA OF MATERIAL AT BOTTOM
************************************************************************
   11 IF (NN .NE. -10) GO TO 5
      I=0
      NLZ=0
  432 I=I+1
      IF (I .GT. NE) GO TO 434
      IF (NLZ .EQ. 2) GO TO 99
      READ (IN5,23) IT(I),TEMP(I)
      IF (IT(I) .EQ. 5000) NLZ=2
      GO TO 98
   99 IT(I)=I
      TEMP(I)=TEMP(1)
   98 IF (IT(I) .LE. 0) GO TO 434
      N=IT(I)
      IF (N .EQ. 5000) N=1
      TM(N)=TEMP(I)
      JL=0
      CALL BEDFOR (JL,N)
      GO TO 432
  434 CONTINUE
   23 FORMAT (I10,F10.5)
    5 CONTINUE
************************************************************************
*     READ IN ELEMENTAL PARTICULATE CONCENTRATIONS IN INITIAL BED
************************************************************************
      IF (JQ3 .EQ. 0) RETURN
      IL=0
  100 READ (IN5,111) NN,NLA,NM
      IF (NN .LT. 0) GO TO 114
  111 FORMAT (3I5)
      NNL=NLA+1
      IF (NN .GT. NE) THEN
         READ (IN5,30) CBEDP
   30    FORMAT (F10.5)
         DO 300 K=1,NE
            CBEL(K,1)=CBEDP
  300    CONTINUE
      ELSE
      READ (IN5,30) CBEDP
  320 READ (95,40) NELEM,CBEDP
   40 FORMAT (I5,F15.8)
      IF (NELEM .LE. 0) RETURN
      CBEL(NELEM,1)=CBEDP
      GO TO 320
      ENDIF
  114 CONTINUE
      RETURN
      END
************************************************************************
      SUBROUTINE REDISP
************************************************************************
*
*     THIS SUBROUTINE COMPUTES THE EROSION RATE FOR REENTRAINMENT
*     WHICH OCCURS FOR THE NLAYM(NN) UNCONSOLIDATED NEW DEPOSIT LAYERS.
*     ALL COMPUTATIONS ARE MADE ON AN ELEMENT BASIS. THE MASS EROSION
*     RATE IS RETURNED IN ARRAY EDOT(NN).
* 
************************************************************************
      INCLUDE 'hsctm.inc'
************************************************************************
*     LAYERS ARE NUMBERED FROM BOTTOM TO TOP.
************************************************************************
      DO 1 NN=1,NE
         IFLAG(NN)=0
         EDOT(NN)=0.0E0
         ES=TETA*ESR(NN)+(1.0E0-TETA)*ESRO(NN)
************************************************************************
*     CHECK IF ANY UNCONSOLIDATED NEW DEPOSIT LAYERS EXIST
************************************************************************
         LO=NLAYM(NN)
         I=1
         IF (LO .EQ. 0) GO TO 1
    2 CONTINUE
************************************************************************
*     CHECK IF TOP LAYER WILL ERODE
************************************************************************
      IF (ES.LE.SSTM(NN,LO+1).OR.IVCON(NN).EQ.0.OR.IVT(NN).EQ.0) GO TO 1
************************************************************************
*     TOP LAYER WILL UNDERGO MASS EROSION
************************************************************************
      IF (ES .LT. SSTM(NN,LO)) GO TO 3
************************************************************************
*     ENTIRE TOP LAYER WILL BE SUSPENDED
************************************************************************
      EDOT(NN)=THICKM(NN,LO)*0.5*(GADTM(NN,LO)+GADTM(NN,LO+1))+EDOT(NN)
      TH9(NN)=TH9(NN)-THICKM(NN,LO)
      BEDL(NN)=BEDL(NN)-THICKM(NN,LO)
      SSTM(NN,LO+1)=0.0E0
      THICKM(NN,LO)=0.0E0
      GADTM(NN,LO+1)=0.0E0
      GBTM(NN,LO+1)=0.0E0
      IF (LO .NE. 1) GO TO 4
      SSTM(NN,LO)=0.0E0
      GADTM(NN,LO)=0.0E0
      GBTM(NN,LO)=0.0E0
    4 I=I+1
      LO=LO-1
      IF (LO .EQ. 0) GO TO 11
      GO TO 2
************************************************************************
*     ONLY PART OF TOP LAYER IS MASS ERODED
************************************************************************
    3 THK=(ES-SSTM(NN,LO+1))/((SSTM(NN,LO)-SSTM(NN,LO+1))/THICKM(NN,LO))
      EDOT(NN)=0.5*(2.0*GADTM(NN,LO+1)+(GADTM(NN,LO)-GADTM(NN,LO+1))
     &         *THK/THICKM(NN,LO))*THK+EDOT(NN)
      TH9(NN)=TH9(NN)-THK
      BEDL(NN)=BEDL(NN)-THK
      SSTM(NN,LO+1)=ES
      GBTM(NN,LO+1)=GBTM(NN,LO+1)+(GBTM(NN,LO)-GBTM(NN,LO+1))*THK/
     &              THICKM(NN,LO)
      GADTM(NN,LO+1)=GADTM(NN,LO+1)+(GADTM(NN,LO)-GADTM(NN,LO+1))*THK/
     &               THICKM(NN,LO)
      THICKM(NN,LO)=THICKM(NN,LO)-THK
      IF (THICKM(NN,LO) .LT. 0.0) WRITE (LP,10) I,NN
   10 FORMAT(///10X,I2,'TH UNCONSOLIDATED NEW DEPOSIT LAYER IN',I5,'ELEM
     &ENT HAS A THICKNESS .LT. 0.0')
   11 NLAYM(NN)=LO
      IF (NLAYM(NN) .GT. NLAYTM) NLAYM(NN)=NLAYTM 
      EDOT(NN)=EDOT(NN)/(DLT*EDEP(NN))
      IFLAG(NN)=2
*      IF (EDOT(NN) .NE. 0.0E0) THEN
*         WRITE (LP,5837) NSTEP,NN,IVCON(I),IVT(I),EDOT(NN)
* 5837    FORMAT (' TESTING REDISP',4I6,E15.6)
*      ENDIF
    1 CONTINUE
      RETURN
      END
************************************************************************
      SUBROUTINE DEPMAS (M)
************************************************************************
*
*     THIS SUBROUTINE COMPUTES THE DRY SEDIMENT MASS DEPOSITED, IF ANY,
*     DURING THE LAST TIME STEP IN EACH ELEMENT.
*
************************************************************************
      INCLUDE 'hsctm.inc'
      DIMENSION WWT(9),EEN(8,9),PNDS(8,9),PNDE(8,9)
      TWO=2.0E0
      TPI=2.0E0*3.141593E0
      DO 1111 NN=1,NE
      SZZ=ESAL(NN)
      IF (SZZ .LT. 0.10E0) SZZ=0.10E0
      TM(NN)=0.0E0
      TMD(NN)=0.0E0
      TMBC(NN)=0.0E0
      IF (IMAT(NN) .LE. 0) THEN
         IFLAG(NN)=0
         GO TO 11
      ENDIF
      IF (IVCON(NN) .EQ. 1 .OR. IVT(NN) .EQ. 1) GO TO 11
      IF (ESRO(NN) .GE. TAUMAX .OR. ESR(NN) .GE. TAUMAX) GO TO 11
      KZ=NC(NN)
      IF (KZ .EQ. 0) KZ=1
      IF (ESRO(NN) .LE. TAUBMN .AND. ESR(NN) .LE. TAUBMN) GO TO 43
   43 IF (NOP(NN,7) .NE. 0) GO TO 84
      NCN=6
      IPZ=NGAUSP
      DO 85 KK=1,IPZ
         DO 86 I=1,NCN
            EEN(I,KK)=SZ(I,KK)
            PNDS(I,KK)=SX(I,KK)
            PNDE(I,KK)=SY(I,KK)
   86    CONTINUE
      WWT(KK)=QWT(KK)
   85 CONTINUE
      GO TO 87
   84 NCN=8
      IPZ=NGAUSS*NGAUSS
      DO 88 KK=1,IPZ
         DO 89 I=1,NCN
            EEN(I,KK)=EN(I,KK)
            PNDS(I,KK)=DNDS(I,KK)
            PNDE(I,KK)=DNDE(I,KK)
   89    CONTINUE
      WWT(KK)=WT(KK)
   88 CONTINUE
   87 DO 81 N=1,IPZ
      WWS=WWT(N)
      VST=0.0
      TAU=0.0
      TAUO=0.0
      D=0.0
      DO=0.0
      CS=0.0
      CSO=0.0
      CCN=0.0
      CBCP=0.0
      CBCPO=0.0
      DXDS=0.0
      DZDS=0.0
      DZDE=0.0
      DXDE=0.0
      DO 2 I=1,NCN
      K=NOP(NN,I)
      K=IABS(K)
      E=EEN(I,N)
      D=D+E*VEL(3,K)
      DO=DO+E*DEPO(K)
      TAU=TAU+E*BSHEAR(K)
      TAUO=TAUO+E*BSO(K)
      CBCP=CBCP+E*CNC(K,2)
      CBCPO=CBCPO+E*CNCO(K,2)
      IF (CNC(K,M) .LT. 0.0) GO TO 77
      CS=CS+E*CNC(K,M)
   77 IF (CNCO(K,M) .LT. 0.0) GO TO 78
      CSO=CSO+E*CNCO(K,M)
   78 IF (CNT(K,M) .LT. 0.0) GO TO 79
      CCN=CCN+E*CNT(K,M)
   79 VST=VST+E*WS(K,M)
      DXDS=PNDS(I,N)*CORD(K,1)+DXDS
      DXDE=PNDE(I,N)*CORD(K,1)+DXDE
      DZDS=PNDS(I,N)*CORD(K,2)+DZDS
      DZDE=PNDE(I,N)*CORD(K,2)+DZDE
    2 CONTINUE
      VJAC=(DXDS*DZDE-DXDE*DZDS)*WWS
      STA=0.25*TAUBMN
      TAUBM=TAU/TAUBMN
      TAUBMO=TAUO/TAUBMN
      IF (TAUBM .LT. STA .OR. TAUBMO .LT. STA) GO TO 49
      IF (ISZ .EQ. 1) GO TO 53
      SIG2=SIGFUN(TAUBM)
      T50=T50FUN(TAUBM)
   53 TD=TDE(NN)
      TDD=TD
      IF (IVCON(NN) .EQ. -1) TDD=TDD-DLT
      IF (TDD .LE. 0.0) TDD=0.01
      IF (TD .LE. 0.0) TD=DLT
      TQW=ALOG10((TD/T50)*B*SZZ**FZ)/SIG2
      IF (TQW .GT. 18.00) TQW=18.0
      IF (TQW .LT. -18.00) TQW= -18.0
      IF (ISZ .EQ. 1) GO TO 54
      SIG2O=SIGFUN(TAUBMO)
      T50O=T50FUN(TAUBMO)
      GO TO 55
   54 SIG2O=SIG2
      T50O=T50
   55 TO=ALOG10((TDD/T50O)*B*SZZ**FZ)/SIG2O
      IF (TO .GT. 18.00) TO=18.0
      IF (TO .LT. -18.00) TO= -18.0
      IF (IVCON(NN) .EQ. -1) GO TO 41
      CEQ=0.0
      CEQO=0.0
      GO TO 42
   41 SIG1=0.49
      TAU50=4.0*EXP(-12.7*TAUBMN)
      IF (TAUBM .LE. 1.0) GO TO 46
      YA=ALOG10((TAUBM-1.0)/TAU50)/SIG1
      IF (ISZ .EQ. 1) GO TO 47
      CEQ=0.5*(1.0+ERF(YA/SQRT(TWO)))
      GO TO 47
   46 CEQ=0.0
   47 TAU50O=4.0*EXP(-12.7*TAUBMN)
      IF (TAUBMO .LE. 1.0) GO TO 48
      YAO=ALOG10((TAUBMO-1.0)/TAU50O)/SIG1
      IF (ISZ .EQ. 1) GO TO 59
      CEQO=0.5*(1.0+ERF(YAO/SQRT(TWO)))
      GO TO 42
   59 CEQO=CEQ
      GO TO 42
   48 CEQO=0.0
   42 IF (TAU .GE. TAUBMN .OR. TAUO .GE. TAUBMN) GO TO 52
      TAUBC=1.0+0.434*D*EXP(-TQW**2/2.0)*(CEQ-1.0)/
     &      (SIG2*TD*SQRT(TPI)*VST)
      TAUBCO=1.0+0.434*DO*EXP(-TO**2/2.0)*(CEQO-1.0)/
     &       (SIG2O*TDD*SQRT(TPI)*VST)
      IF (TAUBC .LT. 0.25) TAUBC=0.25
      IF (TAUBCO .LT. 0.25) TAUBCO=0.25
      IF (CS .LT. CRCN1 .AND. CSO .LT. CRCN1) GO TO 49
      IF (TAUBM .GE. TAUBC .AND. TAUBMO .GE. TAUBCO) GO TO 52
   49 PD=3.0*TAUBMN-2.0*TAUO-TAU
      PDO=3.0*TAUBMN-TAUO-2.0*TAU
      IF (TAUBM .LT. STA .OR. TAUBMO .LT. STA) GO TO 61
      IF (TAUBM .GE. TAUBC) PD=1.0-TAUBC
      IF (TAUBMO .GE. TAUBCO) PDO=1.0-TAUBCO
   61 TM(NN)=TM(NN)+ABS(VST)*VJAC*DLT*(PD*CSO+
     &       PDO*CS)/(6.0*TAUBMN)
      TMBC(NN)=TMBC(NN)+ABS(VST)*VJAC*DLT*(PD*CBCPO+
     &         PDO*CBCP)/(6.0*TAUBMN)
      GO TO 45
   52 IF (TDE(NN) .EQ. 0.0) GO TO 44
      IF (ISZ .EQ. 0) GO TO 57
      IF (CCN .EQ. 0.0) CCN=CINT
      TM(NN)=TM(NN)+0.50*VJAC*(ERF(TQW/SQRT(TWO))-
     &       ERF(TO/SQRT(TWO)))*ABS(CCN*(CEQ+CEQO-2.0))*0.25*(D+DO)
      GO TO 45
   57 TM(NN)=TM(NN)+0.50*VJAC*(ERF(TQW/SQRT(TWO))-ERF(TO/SQRT(TWO)))*
     &       ABS(CS*(CEQ+CEQO-2.0))*0.25*(D+DO)
      GO TO 45
   44 IF (ISZ .EQ. 0) GO TO 58
      IF (CCN .EQ. 0.0E0) CCN=CINT
      TM(NN)=TM(NN)+0.50*VJAC*(ERF(TQW/SQRT(TWO))+1.0)*0.25*(D+DO)*
     &       ABS(CCN*(CEQ+CEQO-2.0))
      GO TO 45
   58 TM(NN)=TM(NN)+0.50*VJAC*(ERF(TQW/SQRT(TWO))+1.0)*0.25*(D+DO)*
     &       ABS(CS*(CEQ+CEQO-2.0))
   45 CONTINUE
*   45 IF (TM(NN) .LE. 0.0) GO TO 11
   81 CONTINUE
      IF (TM(NN) .LE. 0.0E0) GO TO 11
************************************************************************
*     MASS DEPOSITED PER UNIT AREA
************************************************************************
      TM(NN)=TM(NN)/AT(NN)
      TMD(NN)=TM(NN)
      IFLAG(NN)=1
   11 CONTINUE
      TMBC(NN)=TMBC(NN)/AT(NN)
*      IF (TMD(NN) .NE. 0.0E0) THEN
*         WRITE (LP,5837) NSTEP,NN,IVCON(I),IVT(I),TMD(NN)
* 5837    FORMAT (' TESTING ',4I6,E15.6)
*      ENDIF
 1111 CONTINUE
      RETURN
      END
************************************************************************
      SUBROUTINE BEDMOD
************************************************************************
      INCLUDE 'hsctm.inc'
      DO 10 NN=1,NE
      IF (IFLAG(NN) .EQ. 0) GO TO 4
      IY=IFLAG(NN)
      GO TO (1,2,3),IY
    1 N=NC(NN)
      ND=N
      IF (N .EQ. 0) N=1
      DO 60 I=1,N
         TC(NN,I)=TC(NN,I)+DLT
   60 CONTINUE
      IF (TC(NN,N) .GE. 2592000.0E0 .AND. IFGZ(NN) .NE. 1) GO TO 11
      TC(NN,N)=0.0E0
      GO TO 9
   11 NC(NN)=NC(NN)+1
      IF (NC(NN) .GT. NLAYT) NC(NN)=NLAYT
    9 CALL BEDFOR (0,NN)
      GO TO 5
************************************************************************
*     REDISPERSION OF STATIONARY SUSPENSION OCCURRED. CONSOLIDATION OF
*     LOWER CONSOLIDATING BED STRATA (IF ANY EXISTS) IS ACCOUNTED FOR
*     HERE
************************************************************************
    2 N=NC(NN)
      IF (NLAYM(NN) .EQ. 0) GO TO 3
      ND=N
      NDD=N
      IF (ND .EQ. 0) ND=1
      DO 20 I=1,ND
         TC(NN,I)=TC(NN,I)+DLT
   20 CONTINUE
      IF (TC(NN,ND) .GE. 2592000.0E0) N=N+1
      IF (N .EQ. 0) GO TO 10
      IF (N .EQ. NDD) GO TO 5
************************************************************************
*     TC(NN) IS GREATER THAN 30 DAYS, SO THE NLAYM(NN) STATIONARY
*     SUSPENSION (UNCONSOLIDATED) LAYER(S) BECOME PART OF THE PARTIALLY
*     CONSOLIDATED BED
************************************************************************
      IF (NLAY(NDD,NN) .EQ. 0) NC(NN)=N
   12 AMA=0.0E0
      LO=NLAYM(NN)
      DO 30 I=1,LO
      K=LO+1-I
      A=THICKM(NN,K)
      BB=GDM(NN,I)
      IF (A .GT. TLAYM(I)) GO TO 6
      BB=GDM(NN,I+1)
      A=TLAYM(I)-THICKM(NN,K)
    6 IF (THICKM(NN,K) .EQ. 0.0E0) GO TO 7
      IF (THICKM(NN,K) .LT. TLAYM(I)) GO TO 8
      AMA=AMA+0.5E0*(GDM(NN,I)+GDM(NN,I+1))*TLAYM(I)
      GO TO 7
    8 AMA=AMA+THICKM(NN,K)*(GDM(NN,I)+BB+A*(GDM(NN,I+1)-GDM(NN,I))/
     &    TLAYM(I))*0.5
    7 THICKM(NN,K)=0.0
   30 CONTINUE
      NLAYM(NN)=0
      TM(NN)=AMA
      CALL BEDFOR (1,NN)
      NLAYM(NN)=0
************************************************************************
*     CONSOLIDATION OF LOWER NC(NN)-1 STRATA (IF ANY EXISTS) IS
*     ACCOUNTED FOR.
************************************************************************
      IF (NC(NN) .LE. 1) GO TO 10
      GO TO 5
************************************************************************
*     RESUSPENSION OF PARTIALLY CONSOLIDATED BED OCCURRED. CONSOLIDATION
*     OF NC(NN) CONSOLIDATING STRATA IS ACCOUNTED FOR HERE.
************************************************************************
    3 N=NC(NN)
      IF (N .EQ. 0) N=1
      DO 40 I=1,N
         TC(NN,I)=TC(NN,I)+DLT
   40 CONTINUE
      GO TO 5
************************************************************************
*     CONSOLIDATION OF NC(NN) CONSOLIDATING STRATA IS ACCOUNTED FOR HERE
************************************************************************
    4 N=NC(NN)
      IF (N .EQ. 0) N=1
      DO 50 I=1,N
         TC(NN,I)=TC(NN,I)+DLT
   50 CONTINUE
      IF (NLAYM(NN) .GT. 0 .AND. TC(NN,N) .GE. 2592000.0E0) GO TO 12
    5 IFGZ(NN)=IFLAG(NN)
   10 CONTINUE
      RETURN
      END
************************************************************************
      SUBROUTINE BEDFOR (II,NN)
************************************************************************
*
*     THIS SUBROUTINE FORMS THE NEW BED THAT IS A RESULT OF DEPOSITION
*     DURING THE LAST TIME STEP.
*
************************************************************************
      INCLUDE 'hsctm.inc'
      IF (TM(NN) .LE. 0.0) GO TO 11
      IF (NC(NN) .EQ. 0) NC(NN)=1
      KA=NC(NN)
      LT=0
      IF (II .EQ. 1) GO TO 17
      IF (NSTEP .EQ. NSTIME) TC(NN,1)=0.0
      IFE=0
      IFG=0
      IGF=0
      IGH=0
      LO=NLAYM(NN)
      IF (LO .EQ. 0) LO=1
      LT=LO
      IF (LO .EQ. NLAYTM) IFG=1
      IF (IFG .EQ. 1) GO TO 35
      IFG=0
      IFE=0
************************************************************************
*     IF IFG=1, ALL UNCONSOLIDATED NEW DEPOSIT LAYERS, EXCEPT THE
*     BOTTOM LAYER, ARE FULL. ADD DEPOSITED MASS TM(NN) DIRECTLY INTO
*     BOTTOM LAYER.
************************************************************************
   35 IF (IFG .EQ. 0) GO TO 1
      IF (THICKM(NN,1) .GE. TLAYM(LO)) GO TO 17
      J=1
      CALL ITERM (XT7,NN,IFG,LT,IGF,J)
      IFG=0
      IF (IGF .EQ. -1) GO TO 18
      THICKM(NN,1)=XT7+THICKM(NN,1)
      I=LO
      SSTM(NN,1)=SM(NN,I)+THICKM(NN,1)*(SM(NN,I+1)-SM(NN,I))/TLAYM(I)
      GBTM(NN,1)=GM(NN,I)+THICKM(NN,1)*(GM(NN,I+1)-GM(NN,I))/TLAYM(I)   
      GADTM(NN,1)=GDM(NN,I)+THICKM(NN,1)*(GDM(NN,I+1)-GDM(NN,I))/
     &            TLAYM(I)
      SSTM(NN,2)=SM(NN,I)                                               
      GBTM(NN,2)=GM(NN,I)                                               
      GADTM(NN,2)=GDM(NN,I)                                             
      GO TO 8                                                           
************************************************************************
*     ALL UNCONSOLIDATED NEW DEPOSIT LAYERS ARE FULL - PUT RESIDUAL
*     DEPOSITED MASS IN PARTIALLY CONSOLIDATED NEW DEPOSIT LAYERS.
************************************************************************
   18 I=LO                                                              
      IGF=0                                                             
      SSTM(NN,1)=SM(NN,I+1)                                             
      GBTM(NN,1)=GM(NN,I+1)                                             
      GADTM(NN,1)=GDM(NN,I+1)                                           
      THICKM(NN,1)=TLAYM(I)                                             
************************************************************************
*     CALCULATE THICKNESS OF PART. CONS. NEW DEPOSIT FORMED BY TM(NN)
************************************************************************
   17 AC=TM(NN)
      J=NLAYT
      LS=1
      IFG=0
      IGF=0
      CALL ITERC (XT7,NN,IFG,LS,IGF,J,K)
      JK=K
************************************************************************
*     ADD THE MASS OF ALL EXISTING PART. CONS. NEW DEPOSIT LAYERS
************************************************************************
      TM(NN)=0.0
      IF (NLAY(KA,NN) .EQ. 0) GO TO 32
      LL=NLAY(KA,NN)
      DO 19 I=1,LL
      J=LL+1-I
      IF (THICK(KA,NN,J) .EQ. 0.0) GO TO 19
      IF (THICK(KA,NN,J)-TLAY(I)) 21,36,37
   36 TM(NN)=TM(NN)+0.5*(GD(NN,I)+GD(NN,I+1))*TLAY(I)
      GO TO 19
   21 TM(NN) = TM(NN)+THICK(KA,NN,J)*(2.0*GD(NN,I)+THICK(KA,NN,J)*
     &         (GD(NN,I+1)-GD(NN,I))/TLAY(I))*0.5
      GO TO 19
   37 ZQ=THICK(KA,NN,J)-TLAY(I)
      Y=TLAY(I)/(2.0*THICK(KA,NN,J))
      X=(ZQ+TLAY(I)/2.0)/THICK(KA,NN,J)
      TM(NN)=TM(NN)+THICK(KA,NN,J)*(GADT(KA,NN,J)*X+GADT(KA,NN,J+1)*Y)
   19 CONTINUE
************************************************************************
*     CALCULATE THE NUMBER OF LAYERS THAT ARE FORMED BY TOTAL MASS
************************************************************************
   32 TM(NN)=TM(NN)+AC
      I=0
      SUM=0.0
   22 I=I+1
      IF (I .GT. NLAYT) GO TO 25
      SUM=SUM+TLAY(I)*0.5*(GD(NN,I)+GD(NN,I+1))
      IF (SUM .LT. TM(NN)) GO TO 22
      GO TO 23
   25 I=NLAYT
************************************************************************
*     FILL UP LAYERS FORMED BY NEWLY DEPOSITED MASS
************************************************************************
   23 DO 24 L=1,JK
      J=I+1-L
      IF (L .EQ. JK) GO TO 26
      THICK(KA,NN,J)=TLAY(L)
      EPSN(NN,J)=EPSLON(L)                                              
      ALFN(NN,J)=AFLA(L)                                                
      SST(KA,NN,J+1)=SD(NN,L)                                           
      GADT(KA,NN,J+1)=GD(NN,L)                                          
      GBT(KA,NN,J+1)=GBB(NN,L)                                          
      XT7=XT7-TLAY(L)                                                   
      GO TO 24                                                          
   26 THICK(KA,NN,J)=XT7                                                
      EPSN(NN,J)=EPSLON(L)                                              
      ALFN(NN,J)=AFLA(L)                                                
      SST(KA,NN,J+1)=SD(NN,L)                                           
      GADT(KA,NN,J+1)=GD(NN,L)                                          
      GBT(KA,NN,J+1)=GBB(NN,L)                                          
      BB=TLAY(L)                                                        
      IF (XT7 .GT. BB)BB=XT7                                              
      SST(KA,NN,J)=SD(NN,L)+XT7*(SD(NN,L+1)-SD(NN,L))/BB                
      GADT(KA,NN,J)=GD(NN,L)+XT7*(GD(NN,L+1)-GD(NN,L))/BB               
      GBT(KA,NN,J)=GBB(NN,L)+XT7*(GBB(NN,L+1)-GBB(NN,L))/BB             
   24 CONTINUE                                                          
      NLAY(KA,NN)=I                                                     
      L=JK                                                              
      JJ=J                                                              
      IGH=0                                                             
      TM(NN)=TM(NN)-AC                                                  
      IF (TM(NN) .LE. 0.0) GO TO 8
************************************************************************
*     FILL UP LOWER LAYERS WITH PREVIOUSLY DEPOSITED MASS.
************************************************************************
      IGF=1                                                             
      IFG=I+1-J                                                         
      CALL ITERC (XT7,NN,IFG,I,IGF,J,K)
      J=JJ                                                              
      IF (XT7 .GT. TLAY(L)) GO TO 27                                      
      THICK(KA,NN,J)=XT7                                                
      EPSN(NN,J)=EPSLON(L)                                              
      ALFN(NN,J)=AFLA(L)                                                
   31 SST(KA,NN,J)=SST(KA,NN,J+1)+THICK(KA,NN,J)*(SD(NN,K+1)-SD(NN,K))  
     &/TLAY(K)                                                          
      GADT(KA,NN,J)=GADT(KA,NN,J+1)+THICK(KA,NN,J)*(GD(NN,K+1)-GD(NN,K))
     &/TLAY(K)                                                          
      GBT(KA,NN,J)=GBT(KA,NN,J+1)+THICK(KA,NN,J)*(GBB(NN,K+1)-GBB(NN,K))
     &/TLAY(K)                                                          
      GO TO 8                                                           
   27 IF (J .EQ. 1) GO TO 28                                              
      THICK(KA,NN,J)=TLAY(L)                                            
      EPSN(NN,J)=EPSLON(L)                                              
      ALFN(NN,J)=AFLA(L)                                                
      SST(KA,NN,J)=SD(NN,L+1)                                           
      GADT(KA,NN,J)=GD(NN,L+1)                                          
      GBT(KA,NN,J)=GBB(NN,L+1)                                          
      XT7=XT7-TLAY(L)                                                   
      J=J-1                                                             
      L=L+1                                                             
      IF (XT7 .GE. TLAY(L)) GO TO 27                                      
   28 THICK(KA,NN,J)=XT7                                                
      EPSN(NN,J)=EPSLON(L)                                              
      ALFN(NN,J)=AFLA(L)                                                
      IF (J .EQ. 1.AND.XT7 .GT. TLAY(L)) GO TO 29                           
      K=L                                                               
      GO TO 31                                                          
   29 SST(KA,NN,1)=SD(NN,L+1)                                           
      GADT(KA,NN,1)=GD(NN,L+1)                                          
      GBT(KA,NN,1)=GBB(NN,L+1)                                          
      GO TO 8                                                           
************************************************************************
*     ADD THE MASS OF ALL EXISTING UNCONSOLIDATED NEW DEPOSIT LAYERS TO
*     DEPOSITED MASS
************************************************************************
    1 DO 15 I=1,LO
      J=LO+1-I
      A=THICKM(NN,J)
      BB=GDM(NN,I)
      IF (IFE .EQ. 0) GO TO 34
      BB=GDM(NN,I+1)
      A=TLAYM(I)-THICKM(NN,J)
      IFE=0
   34 IF (THICKM(NN,J) .EQ. 0.0) GO TO 15
      IF (THICKM(NN,J) .LT. TLAYM(I)) GO TO 16
      TM(NN)=TM(NN)+0.5*(GDM(NN,I)+GDM(NN,I+1))*TLAYM(I)                
      GO TO 15                                                          
   16 TM(NN)=TM(NN)+THICKM(NN,J)*(GDM(NN,I)+BB+A*(GDM(NN,I+1)-GDM(NN,I))
     &       /TLAYM(I))*0.5
   15 CONTINUE
************************************************************************
*     CALCULATE THE NUMBER OF LAYERS THAT ARE FORMED BY TOTAL MASS
************************************************************************
      I=0
      SUM=0.0
    3 I=I+1
      IF (I .GT. NLAYTM) GO TO 4
      SUM=SUM+TLAYM(I)*0.5*(GDM(NN,I)+GDM(NN,I+1))
      IF (SUM .LT. TM(NN)) GO TO 3
************************************************************************
*     LT=TOTAL NUMBER OF LAYERS FORMED BY THIS MASS
************************************************************************
      LT=I
      GO TO 7
    4 LT=NLAYTM
      IGH= -1
************************************************************************
*     IF LT IS GREATER THAN ONE, FILL TOP LAYER FIRST
************************************************************************
    7 IF (LT .EQ. 1) GO TO 6
      THICKM(NN,LT)=TLAYM(1)
      SSTM(NN,LT+1)=SM(NN,1)
      SSTM(NN,LT)=SM(NN,2)
      GADTM(NN,LT+1)=GDM(NN,1)
      GADTM(NN,LT)=GDM(NN,2)
      GBTM(NN,LT+1)=GM(NN,1)
      GBTM(NN,LT)=GM(NN,2)
      TM(NN)=TM(NN)-0.5*TLAYM(1)*(GDM(NN,1)+GDM(NN,2))
      GO TO 9
************************************************************************
*     LT IS EQUAL TO ONE, PUT ENTIRE DEPOSITED MASS INTO TOP LAYER
************************************************************************
    6 J=1
      CALL ITERM (XT7,NN,IFG,LT,IGF,J)
      THICKM(NN,LT)=XT7
      SSTM(NN,LT+1)=SM(NN,1)
      SSTM(NN,LT)=SM(NN,1)+XT7*(SM(NN,2)-SM(NN,1))/TLAYM(1)
      GBTM(NN,LT+1)=GM(NN,1)
      GBTM(NN,LT)=GM(NN,1)+XT7*(GM(NN,2)-GM(NN,1))/TLAYM(1)
      GADTM(NN,LT+1)=GDM(NN,1)
      GADTM(NN,LT)=GDM(NN,1)+XT7*(GDM(NN,2)-GDM(NN,1))/TLAYM(1)
      GO TO 8
************************************************************************
*     FILL UP THE OTHER LAYERS
************************************************************************
    9 DO 14 I=2,LT
      NJI=LT+1-I
      AJQ=0.5*TLAYM(I)*(GDM(NN,I)+GDM(NN,I+1))
      IF (TM(NN) .LT. AJQ) GO TO 12
************************************************************************
*     FILL FULL LAYERS, IF ANY EXIST
************************************************************************
      THICKM(NN,NJI)=TLAYM(I)
      SSTM(NN,NJI)=SM(NN,I+1)
      SSTM(NN,NJI+1)=SM(NN,I)
      GBTM(NN,NJI)=GM(NN,I+1)
      GBTM(NN,NJI+1)=GM(NN,I)
      GADTM(NN,NJI)=GDM(NN,I+1)
      GADTM(NN,NJI+1)=GDM(NN,I)
      TM(NN)=TM(NN)-0.5*TLAYM(I)*(GDM(NN,I)+GDM(NN,I+1))
      GO TO 14
************************************************************************
*     FILL PARTIAL LAYER
************************************************************************
   12 IGF=1
      IFG=I
      CALL ITERM (XT7,NN,IFG,LT,IGF,1)
      IFG=0                                                             
      IGF=0                                                             
      THICKM(NN,NJI)=XT7                                                
      SSTM(NN,NJI)=SM(NN,I)+XT7*(SM(NN,I+1)-SM(NN,I))/TLAYM(I)
      GBTM(NN,NJI)=GM(NN,I)+XT7*(GM(NN,I+1)-GM(NN,I))/TLAYM(I)
      GADTM(NN,NJI)=GDM(NN,I)+XT7*(GDM(NN,I+1)-GDM(NN,I))/TLAYM(I)
   14 CONTINUE                                                          
    8 IF (IGH .EQ. -1) GO TO 17
      IF (LT .GT. NLAYTM) LT=NLAYTM
      NLAYM(NN)=LT                                                      
      TH2=0.0                                                         
      TH9O=TH9(NN)
      TH9(NN)=0.0                                                     
      DO 13 I=1,LT                                                      
         J=LT+1-I
         TH9(NN)=TH9(NN)+THICKM(NN,J)
   13 CONTINUE
      BEDL(NN)=BEDL(NN)-TH9O+TH9(NN)
      TH2O=BEDEL(NN)                                      
      BEDEL(NN)=TH2                                                     
      DO 72 I=1,KA                                                      
         IF (NLAY(I,NN) .EQ. 0) GO TO 72
         LL=NLAY(I,NN)
         TH2=0.0
         DO 33 J=1,LL
            JJ=LL+1-J
            TH2=TH2+THICK(I,NN,JJ)
   33    CONTINUE
         BEDEL(NN)=BEDEL(NN)+TH2
         BEDL(NN)=BEDL(NN)+BEDEL(NN)-TH2O
   72 CONTINUE
   11 CONTINUE
      RETURN
      END
************************************************************************
      SUBROUTINE CONSOL (NN)
************************************************************************
      INCLUDE 'hsctm.inc'
      DIMENSION TY(5)
************************************************************************
*
*     FIRST DETERMINE AVERAGE BED DENSITY, THICKNESS OF PARTIALLY
*     CONSOLIDATED BED, INITIAL SUSPENSION CONCENTRATION, CO, AND FINAL
*     MEAN BED DENSITY = F(CO)
*
************************************************************************
      IF (NC(NN) .EQ. 0) NC(NN)=1
      N=NC(NN)
      THZ=0.0
      ADEN=0.0
      ADN=0.0                                                         
      DO 20 I=1,N                                                       
      TY(I)=0.0                                                       
      L=NLAY(I,NN)                                                      
      IF (L .EQ. 0) GO TO 20
      DO 30 J=1,L                                                       
      TY(I)=TY(I)+THICK(I,NN,J)                                         
      ADEN=ADEN+0.5*(GADT(I,NN,J)+GADT(I,NN,J+1))*THICK(I,NN,J)
   30 THZ=THZ+THICK(I,NN,J)
   20 CONTINUE
      IF (THZ .EQ. 0.0) GO TO 2
      ADEN=ADEN/THZ
    6 CO=ADEN*THZ/EDEP(NN)
      FMBD=FMBDN(CO)
      TCIN=FTCIN(CO)
************************************************************************
*
*     DETERMINE VALUE OF MEAN BED DENSITY AT CURRENT CONSOLIDATION
*     TIME FOR NC(NN) BED STRATA.
*
************************************************************************
      ZQ=0.05*TY(1)
      DO 50 I=1,N
      IF (I .LT. N) GO TO 1
      IF (TC(NN,N) .LT. 3.0) GO TO 50
    1 AMBD=FMBD*(1.0-AP*EXP(-ALAMDA*TC(NN,I)/TCIN))
      TCT=TC(NN,I)                                                      
      ZHMIN=FZHMIN(TCT)
      ZITH=ZQ/THZ
      IF (ZITH .EQ. 0.0) ZITH=0.05
      L=NLAY(I,NN)+1                                                    
      DO 60 J=1,L                                                       
      IF (ZITH .LT. ZHMIN .AND. TCT .LT. TCC) GO TO 3
      TCS=TCT                                                           
      GO TO 4                                                           
    3 TCS=TCC                                                           
    4 CONTINUE
      BETA=FBETA(TCS)
      DELTA=FDELTA(TCS)
      GADT(I,NN,J)=AMBD*BETA*(ZITH)**DELTA
      IF (J .EQ. 1 .AND. I .EQ. 1) ZQ=0.0
      IF (J .EQ. L) GO TO 5
      ZQ=ZQ+THICK(I,NN,J)
    5 ZITH=ZQ/THZ
      IF (ZITH .LT. 0.05) ZITH=0.05
   60 CONTINUE
      LL=L-1
      DO 40 J=1,LL
         ADN=ADN+0.5*(GADT(I,NN,J)+GADT(I,NN,J+1))*THICK(I,NN,J)
   40 CONTINUE
      ADN=ADN/THZ                                                       
      CNS=AMBD/ADN                                                      
      DO 80 J=1,L                                                       
         GADT(I,NN,J)=GADT(I,NN,J)*CNS
         GBT(I,NN,J)=GADT(I,NN,J)*(GAC-EDEN(NN))/GAC+EDEN(NN)
         SST(I,NN,J)=TAL*GADT(I,NN,J)**TAB
   80 CONTINUE                                                          
   50 CONTINUE                                                          
************************************************************************
*     THICKNESS OF PARTIALLY CONSOLIDATED BED IS REDUCED TO
*     ACCOUNT FOR CONSOLIDATION DURING THE LAST TIME STEP
************************************************************************
      IF (TC(NN,N) .LT. 3.0) N=N-1
      IF (N .EQ. 0) GO TO 2
      R=THZ                                                             
      THZ=THZ*ADEN/AMBD                                                 
      BEDEL(NN)=BEDEL(NN)+THZ-R                                         
      DO 90 J=1,N
         L=NLAY(J,NN)
         IF (L .EQ. 0) GO TO 2
         DO 10 I=1,L
            THICK(J,NN,I)=THICK(J,NN,I)+(THZ-R)*THICK(J,NN,I)/R
   10    CONTINUE
   90 CONTINUE
    2 RETURN
      END
************************************************************************
      SUBROUTINE ITERC (XT7,NN,IFG,LT,IGF,J,K)
************************************************************************
      INCLUDE 'hsctm.inc'
      IH=0
      AM=0.0
      AMM=0.0
      XT7=0.0
      IF (TLAY(NLAYT) .EQ. 0.0) TLAY(NLAYT)=1.0
      KA=NC(NN)
      TQ=THICK(KA,NN,J)
      THZ=THICK(KA,NN,J)+0.0001
      DH=THZ-TQ
      K=1                                                               
      SUM=0.0                                                         
      B=GADT(KA,NN,J)                                                   
      IF (IFG .NE. 0) K=NLAYT                                             
      IF (IGF .EQ. 0) GO TO 6                                             
      K=IFG                                                             
      C=TLAY(K)                                                         
      IF (TQ .LE. C) GO TO 1                                          
      C=TQ+TLAY(K)                                       
      IH=1                                                              
      GO TO 1                                                           
    6 IF (LT .NE. 1) GO TO 5                                              
      B=GD(NN,K)                                                        
      TQ=0.0                                   
      THZ=0.0001                                                   
    5 C=TLAY(K)                                                         
    1 AB=0.5*(GD(NN,K+1)+B)*(C-TQ)              
      IF (TM(NN) .GT. AB) GO TO 3                                         
    4 A=(GD(NN,K+1)-GD(NN,K))/C                                         
      IF (IH .EQ. 1) A=(GD(NN,K+1)-GD(NN,K))/THZ                          
      AM=(A*THZ+GD(NN,K)+B)*0.5*(THZ-TQ)                  
      IF (TM(NN) .LE. AM) GO TO 2                                         
      DH=0.0005                                                       
      THH=THZ                                                           
      AMM=AM                                                            
      THZ=THZ+DH                                                        
      IF (THH .LT. C) GO TO 4                                             
    3 TM(NN)=TM(NN)-AB                                                  
      SUM=SUM+C                                                         
      THZ=0.0001                                                
      B=GD(NN,K+1)                                                      
      TQ=0.0                                          
      K=K+1                                                             
      J=J-1                                                             
      IF (K .LE. NLAYT) GO TO 5                                           
      K=K-1                                                             
      J=J+1                                                             
      IH=1                                                              
      B=GD(NN,K+1)                                                      
      C=1.0                                                          
      GO TO 1                                                           
    2 XT7=SUM+THZ-DH*(AM-TM(NN))/(AM-AMM)                               
      IF (XT7 .LE. 0.0) WRITE (LP,10)XT7                                
   10 FORMAT ('   XT7 =',F10.5)                                         
      RETURN                                                            
      END                                                               
************************************************************************
      SUBROUTINE ITERM (XT7,NN,IFG,LT,IGF,J)
************************************************************************
      INCLUDE 'hsctm.inc'
      AM=0.0                                                          
      AMM=0.0                                                         
      XT7=0.0                                                         
      TH1=THICKM(NN,J)                                                  
      THZ=THICKM(NN,J)+0.0001                                       
      DH=THZ-TH1                                                        
      B=GADTM(NN,J)                                                     
      TQ=THICKM(NN,J)                                               
      SUM=0.0                                                         
      K=1                                                               
      IF (IFG .NE. 0) K=NLAYTM                                            
      IF (IGF .NE. 0) K=IFG                                               
      IF (IGF .NE. 0) GO TO 6
      IF (LT .NE. 1) GO TO 1
    6 B=GDM(NN,K)                                                       
      TQ=0.0                                                     
      TH1=TQ                                                           
      THZ=0.0001                                                   
    1 AB=0.5*(B+GDM(NN,K+1))*(TLAYM(K)-TQ)              
      IF (TM(NN) .GT. AB) GO TO 3
    4 A=(GDM(NN,K+1)-GDM(NN,K))/TLAYM(K)                                
      AM=(A*THZ+GDM(NN,K)+B)*0.5*(THZ-TH1)                              
      IF (TM(NN) .LE. AM) GO TO 2
      DH=0.0005                                                         
      THZ=THZ+DH                                                        
      THH=THZ-DH                                                        
      AMM=AM                                                            
      IF (THH .LT. TLAYM(K)) GO TO 5
    3 TM(NN)=TM(NN)-AB                                                  
      SUM=SUM+TLAYM(K)                                                  
      THZ=0.0001                                                        
      TH1=0.0                                                         
      B=GDM(NN,K+1)                                                     
      TQ = 0.0
      K = K+1
      J = J-1
    5 IF (K .LE. NLAYTM) GO TO 1
      IGF = -1
************************************************************************
*     ALL UNCONSOLIDATED NEW DEPOSIT LAYERS ARE FULL - PUT RESIDUAL
*     DEPOSITED MASS IN PARTIALLY CONSOLIDATED NEW DEPOSIT LAYERS
************************************************************************
      XT7 = SUM
      RETURN
    2 XT7 = SUM+THZ-DH*(AM-TM(NN))/(AM-AMM)
      RETURN
      END
************************************************************************
      SUBROUTINE DENSTY (INN,IN1)
************************************************************************
*
*     THIS SUBROUTINE COMPUTES THE WATER DENSITY FOR EACH NODE USING
*     THE INPUTTED WATER TEMPERATURE, SALINITY AND SUSPENSION
*     CONCENTRATION AT EACH TIMESTEP THAT IN1 HAS A NON-ZERO VALUE.
*
*     IF IN1=0: NODAL SALINITIES ARE SET EQUAL TO A CONSTANT SW
*               WHICH IS READ IN, AND A CONSTANT VALUE OF DENSITY
*               IS CALCULATED
*
*     IF IN1=1: NODAL SALINITIES ARE CALCULATED AT EACH TIME-STEP
*               BY CONSED2D. NODAL DENSITIES ARE CALCULATED HEREIN.
*
*     IF IN1=2: NEW SALINITY VALUES AT SPECIFIED NODES ARE READ
*               IN AND NEW NODAL DENSITIES ARE CALCULATED
*
*     IF IN1=3: NEW SALINITY VALUES AT ALL NODES ARE READ
*               IN AND NEW NODAL DENSITIES ARE CALCULATED
*
*     IF IN1=4: THE WATER TEMPERATURE IS READ IN, THE KINEMATIC
*               VISCOSITY IS CALCULATED AS A FUNCTION OF THE
*               TEMPERATURE, AND SALINITY VALUES ARE READ IN AND
*               DENSITIES COMPUTED FOR EACH NODE FOR THE FIRST
*               TIME STEP
*
************************************************************************
      INCLUDE 'hsctm.inc'
      DIMENSION IT(3),TEMP(3)
      INZ=INS
      IF (NSTEP .GT. NSTIME) INZ=INSS
      IF (IN1 .EQ. 10) GO TO 9
      IF (IN1 .EQ. 0) GO TO 111
      GO TO (1,2,3,4),IN1
  111 READ (IN5,10) SW
   10 FORMAT (30X,F10.5)
      DNW=DENFUN(SW,TEMPC)
      DO 7 I = 1,NP
         CNC(I,2)=SW
         DEN(I)=DNW+CNC(I,1)*(GAC-DNW)/GAC
         ESAL(1)=SW
         EDEN(1)=DEN(1)
    7 CONTINUE
      IF (INN .NE. 0) GO TO 9
      RETURN
    1 CONTINUE
      DO 77 I = 1,NP
         CNC(I,2)=SW
         DEN(I)=DNW+CNC(I,1)*(GAC-DNW)/GAC
         ESAL(1)=SW
         EDEN(1)=DEN(1)
   77 CONTINUE
      RETURN
    2 READ (INZ,20) (IT(J),TEMP(J),J=1,3)
   20 FORMAT (3(I10,F10.5))
      DO 5 I = 1,3
      IF (IT(I) .LE. 0) GO TO 6
      N=IT(I)
      CNC(N,2)=TEMP(I)
      SALWT=CNC(N,2)
      DNW=DENFUN(SALWT,TEMPC)
    5 DEN(N)=DNW+CNC(N,1)*(GAC-DNW)/GAC
      GO TO 2
    6 IF (INN .NE. 0) GO TO 9
      RETURN
    3 READ (INZ,10) (CNC(J,2),J=1,NP)
      DO 8 J=1,NP
      SALWT=CNC(J,2)
      DNW=DENFUN(SALWT,TEMPC)
    8 DEN(J)=DNW+CNC(J,1)*(GAC-DNW)/GAC
      IF (INN .NE. 0) GO TO 9
      RETURN
    4 READ (IN5,30) TEMPC,IS
   30 FORMAT(11X,F9.3,/,49X,I1,/)
      IC=0
      SQ=0.0
      GAW = DENFUN(SQ,TEMPC)
      UN = 1.701721*EXP(-0.025109*TEMPC)*0.000001
      IF (IS .EQ. 1) GO TO 3
      GO TO 111
    9 IF (INN .EQ. 0) GO TO 12
      IC=IC+1
      DO 11 NN=1,NE
      KA=NC(NN)
      NM=2
      IF (NSTEP .EQ. NSTIME) NM=NLAYTM+1
      Y=EDEN(NN)
      ZQ=ESAL(NN)
      DO 13 I=1,NM
         IF (NSTEP .EQ. NSTIME) GO TO 27
         IF (I .NE. NM) GO TO 27
         Y=EDENO(NN)
         ZQ=ESALO(NN)
   27    GM(NN,I)=GBM(I)+Y-GAW                                             
         GDM(NN,I)=(GM(NN,I)-Y)*GAC/(GAC-Y)                                
         IF (ZQ .GE. 2.0) GO TO 14
         SM(NN,I)=SSM(I)*(0.5*ZQ+1.0)                           
         GO TO 13                                                          
   14    SM(NN,I)=2.0*SSM(I)                                             
   13 CONTINUE                                                          
      IF (NLAYM(NN) .GT. 0.AND.NSTEP .GT. NSTIME) GO TO 28
      NM=2                                                              
      Y=EDEN(NN)                                                        
      ZQ=ESAL(NN)                                                   
      IF (NSTEP .EQ. NSTIME) NM=NLAYT+1
      DO 15 I = 1,NM
         IF (NSTEP .EQ. NSTIME) GO TO 29
         IF (I .NE. NM) GO TO 29
         Y=EDENO(NN)
         ZQ=ESALO(NN)
   29    GBB(NN,I)=GB(I)+Y-GAW
         GD(NN,I)=(GBB(NN,I)-Y)*GAC/(GAC-Y)
         IF (ZQ .GE. 2.0) GO TO 16
         SD(NN,I)=SS(I)*(0.5*ZQ+1.0)
         GO TO 15
   16    SD(NN,I)=2.0*SS(I)
   15 CONTINUE
   28 IF (NLAYM(NN) .EQ. 0 .OR. NSTEP .EQ. NSTIME) GO TO 17
      NM=2
      DO 18 I=1,NM
      Y=EDEN(NN)
      YY=EDENO(NN)
      IF (I .NE. NM) GO TO 24
      Y=EDENO(NN)
      IF (IC .GT. 2) GO TO 25
      YY=Y
      GO TO 24
   25 YY=EDENOO(NN)
   24 GBTM(NN,I)=GBTM(NN,I)+Y-YY
      GADTM(NN,I)=(GBTM(NN,I)-Y)*GAC/(GAC-Y)
      IF (ESALO(NN) .GE. 2.0 .AND. ESAL(NN) .GE. 2.0) GO TO 18
      ES=ESALO(NN)
      IF (ES .GE. 2.0) ES=2.0
      SSO=SSTM(NN,I)/(0.5*ES+1.0)
      ESA=ESAL(NN)
      IF (ESA .GE. 2.0) ESA=2.0
      SSTM(NN,I)=SSO*(0.5*ESA+1.0)
   18 CONTINUE
   17 IF (NLAY(KA,NN) .EQ. 0 .OR. NSTEP .LE. NSTIME) GO TO 11
      NM=2
      IF (NLAYM(NN) .GT. 0) GO TO 11
      DO 21 I=1,NM
      Y=EDEN(NN)
      YY=EDENO(NN)
      IF (I .NE. NM) GO TO 22
      Y=EDENO(NN)
      IF (IC .GT. 2) GO TO 26
      YY=Y
      GO TO 22
   26 YY=EDENOO(NN)
   22 GBT(KA,NN,I)=GBT(KA,NN,I)+Y-YY
      GADT(KA,NN,I)=(GBT(KA,NN,I)-Y)*GAC/(GAC-Y)
      IF (ESALO(NN) .GE. 2.0 .AND. ESALOO(NN) .GE. 2.0) GO TO 11
      ES=ESALOO(NN)
      IF (ES .GE. 2.0) ES=2.0
      SSO=SST(KA,NN,I)/(0.5*ES+1.0)
      ESA=ESALO(NN)
      IF (ESA .GE. 2.0) ESA=2.0
      SST(KA,NN,I)=SSO*(0.5*ESA+1.0)
   21 CONTINUE
   11 CONTINUE
   12 RETURN
      END
************************************************************************
      FUNCTION DENFUN (SQ,TQ)
************************************************************************
      INCLUDE 'hsctm.inc'
      DENFUN=1.0/(0.702+100.0*(17.5273+0.1101*TQ-
     &       0.000639*TQ*TQ-0.039986*SQ-0.000107*TQ*SQ)/
     &       (1.01325+5880.9+37.592*TQ-0.34395*TQ*TQ+2.2524*SQ))*
     &       1000.0E0
      RETURN
      END
************************************************************************
      FUNCTION SIGFUN (TQ)
************************************************************************
      INCLUDE 'hsctm.inc'
      IF (TQ .LE. C1) GO TO 1
      SIGFUN=S2*TQ+A2
      GO TO 2
    1 SIGFUN=S1*TQ+A1
    2 RETURN
      END
************************************************************************
      FUNCTION T50FUN (TQ)
************************************************************************
      INCLUDE 'hsctm.inc'
      IF (TQ .LE. C2) GO TO 1
      T50FUN=10.0**(S4*TQ+A4)*60.0
      GO TO 2
    1 T50FUN=10.0**(S3*TQ+A3)*60.0
    2 RETURN
      END
************************************************************************
      SUBROUTINE CONCIC (ISC,K)
************************************************************************
*
*     THIS SUBROUTINE READS THE INITIAL SUSPENDED SEDIMENT CONCENTRATION
*     AND THE INITIAL PARTICULATE CONCENTRATION FOR BED SEDIMENTS
*     AT EVERY NODE. FOR:
*
*     ISC=1: NODAL CONCENTRATIONS ARE SET EQUAL TO A CONSTANT VALUE
*            WHICH IS READ IN.
*     ISC=2: NODAL CONCENTRATIONS ARE READ IN FROM FILE NUMBER INC.
*     ISC=3: NODAL CONCENTRATIONS ARE COMPUTED USING USER SPECIFIED
*            PROCEDURE.
*
************************************************************************
      INCLUDE 'hsctm.inc'
      DIMENSION IT(4),TEMP(4)
      GO TO (1,2,3),ISC
    1 IF (K .EQ. 1) INV = IN5
      IF (K .EQ. 2) INV = 15
      IF (K .GT. 2) INV = IN5
      READ (INV,10) CINT
   10 FORMAT (41X,F13.7)
      DO 4 I=1,NP
         CNC(I,K)=CINT
    4 CONTINUE
      RETURN
    2 CONTINUE
  432 READ (INC,23) (IT(J),TEMP(J),J=1,4)
      DO 433 I=1,4
      IF (IT(I) .LE. 0) GO TO 434
      N=IT(I)
  433 CNC(N,K)=TEMP(I)
      GO TO 432
  434 CONTINUE
   23 FORMAT (4(I10,F10.5))
      RETURN
************************************************************************
*     INITIAL SUSPENDED SEDIMENT CONCENTRATIONS ARE COMPUTED USING USER 
*     SPECIFIED PROCEDURE
************************************************************************
    3 CONTINUE
      RETURN
      END
************************************************************************
      SUBROUTINE RECORD
************************************************************************
*
*     THIS SUBROUTINE RECORDS THE VALUES OF VARIOUS PARAMETERS
*     FOR THE ELEMENTS SPECIFIED IN ARRAY NELH FOR ALL TIME STEPS
*
************************************************************************
      INCLUDE 'hsctm.inc'
      N=NSTEP
      DO 1 I=1,NELE
         J=NELH(I)
         TECON(I,N)=ECONC(J)
         TEVEL(I,N)=EXV(J)
         TEDR(I,N)=TMD(J)/DLT
         TEMER(I,N)=EDOT(J)*EDEP(J)
         TESER(I,N)=ALPHA2(J)*EDEP(J)
         TEBOT(I,N)=BEDEL(J)
         TEDMAS(I,N)=(EDOT(J)+ALPHA2(J))*DLT*AT(J)*EDEP(J)
     &               -TMD(J)*AT(J)
    1 CONTINUE
      RETURN
      END
************************************************************************
      SUBROUTINE WRITER (NOUT)
************************************************************************
      INCLUDE 'hsctm.inc'
      IF (NOUT .EQ. 0) GO TO 46
      IF (IFF(NSTEP,2) .GT. 0) THEN
         WRITE (LP,11)
   11 FORMAT(/,'********************************************************
     &**************************',/)
         IF (NCYC .GT. NSTIME) WRITE (LP,66) NSTEP,TIM(NSTEP),DELT
   66    FORMAT(//2X,9HTIME STEP,I12/2X,10HTOTAL TIME,F11.3,' hrs.',/2X,
     &         10HDELTA TIME,F11.3,' hrs.',//)
         GO TO (1,2,3),NOUT
    3    CONTINUE
    2    INT=(NP+5)/5
      ENDIF
      IF (IFF(NSTEP,2) .GT. 0) THEN
      DO 41 K=1,JQP
         WRITE (LP,73) K
         DO 75 J=1,INT
            WRITE (LP,76) (N,CNC(N,K),N=J,NP,INT)
   75    CONTINUE
   41 CONTINUE
      ENDIF
      IF (NOUT .EQ. 2) RETURN
    1 IF (IFF(NSTEP,2) .GT. 0) WRITE (LP,77)
***********************************************************************
*     PRINT THE BED SHEAR, ER/DEP RATES AND ELEVATIONS
***********************************************************************
      IF (IFF(NSTEP,2) .GT. 0) THEN
      WRITE (LP,80)
   80 FORMAT(1X,'ELEM.',1X,'BED SHEAR',2X,'BOT.ELEV',1X,'BED CHANGE',1X
     &,'REDIS RATE',1X,'RESUS RATE',2X,'DEP RATE',1X,'ER/DEP MASS'/)
      ENDIF
   46 DO 81 I=1,NE
      BE=BEDEL(I)+EELEV(I)
      BC=BE+ABS(EELEV(I))
      ANET(I)=BC
      DMER=EDOT(I)*EDEP(I)
      SER=AVERAT(I)*EDEP(I)
      DR=TMD(I)/DLT
      IF (EDOT(I) .GT. 0.0 .OR. AVERAT(I) .GT. 0.0) GO TO 250
      GO TO 251
  250 IF (ETIM(I) .EQ. 0.0) NOCR(I)=NOCR(I)+1
      ETIM(I)=ETIM(I)+DLT
      GO TO 252
  251 IF (TMD(I) .GT. 0.0) GO TO 253
      IF (EDOT(I) .EQ. 0.0 .AND. AVERAT(I) .EQ. 0.0
     &   .AND. ETIM(I) .GT. 0.0) ETIM(I)=ETIM(I)+DLT
      GO TO 252
  253 DTIM(I)=DTIM(I)+ETIM(I)+DLT
      ETIM(I)=0.0
  252 CONTINUE
      BDM(I)=BDM(I)+TH9(I)
      DOWN(I)=DOWN(I)+TMD(I)*AT(I)/DLT
      FLUX(I)=FLUX(I)+((EDOT(I)+AVERAT(I))*EDEP(I)-TMD(I)/DLT)*AT(I)
      EDM=(EDOT(I)+AVERAT(I))*DLT*AT(I)*EDEP(I)-TMD(I)*AT(I)
      IF (IFF(NSTEP,2) .GT. 0)
     &   WRITE (LP,82) I,ESR(I),BE,BC,DMER,SER,DR,EDM
   81 CONTINUE
   82 FORMAT (I4,1P7E11.3)
      IF (NOUT .EQ. 0) RETURN
************************************************************************
*     PRINT OUT LAYER PROPERTIES
************************************************************************
      IF (IFF(NSTEP,2) .GT. 0) THEN
      WRITE (LP,83)
   83 FORMAT (///1X,'BED LAYER PROPERTIES'//)
      WRITE (LP,84)
   84 FORMAT(1X,'ELEM.',2X,'LAYER',2X,'THICKNESS',2X,'AVE.SHEAR STRENGTH
     &',2X,'AVE.BULK DENSITY',2X,'AVE.DRY DENSITY')
      T1=0.0
      DO 89 I=1,NE
      IF (NC(I) .EQ. 0) NC(I)=1
      KA=NC(I)
      IF (NLAYM(I) .EQ. 0 .AND. THICKM(I,1) .EQ. 0.0) GO TO 4
      WRITE (LP,90) I
   90 FORMAT (/1X,I4,24X,'UNCONSOLIDATED NEW DEPOSIT'/)
      LL=NLAYM(I)
      DO 91 L=1,LL
         NI=LL-L+1
         T1=T1+THICKM(I,NI)
         AVSSTM=0.5*(SSTM(I,NI)+SSTM(I,NI+1))
         AVGBM=0.5*(GBTM(I,NI)+GBTM(I,NI+1))
         AVGADM=0.5*(GADTM(I,NI)+GADTM(I,NI+1))
         WRITE (LP,88) L,THICKM(I,NI),AVSSTM,AVGBM,AVGADM
   91 CONTINUE
    4 IF (NLAY(KA,I) .EQ. 0) GO TO 5
      WRITE (LP,92) I
   92 FORMAT (/1X,I4,12X,'PARTIALLY CONSOLIDATED NEW DEPOSIT'/)
      LL=NLAY(KA,I)
      DO 93 L=1,LL
         NI=LL-L+1
         IF (NI .NE. 1) GO TO 7
         IF (THICK(KA,I,NI) .LE. TLAY(NLAYT)) GO TO 7
         XT7=THICK(KA,I,NI)-TLAY(NLAYT)
         A=TLAY(NLAYT)/(2.0*THICK(KA,I,NI))
         B=(XT7+TLAY(NLAYT)/2.0)/THICK(KA,I,NI)
         AVSST=SST(KA,I,NI+1)*A+SST(KA,I,NI)*B
         AVGB=GBT(KA,I,NI+1)*A+GBT(KA,I,NI)*B
         AVGAD=GADT(KA,I,NI+1)*A+GADT(KA,I,NI)*B
         GO TO 8
    7    AVSST=0.5*(SST(KA,I,NI)+SST(KA,I,NI+1))
         AVGB=0.5*(GBT(KA,I,NI)+GBT(KA,I,NI+1))
         AVGAD=0.5*(GADT(KA,I,NI)+GADT(KA,I,NI+1))
    8    WRITE (LP,88)L,THICK(KA,I,NI),AVSST,AVGB,AVGAD
   93 CONTINUE
    5 IF (NLAYO(I) .EQ. 0 .AND. THICKO(I,1) .EQ. 0.0) GO TO 89
      WRITE (LP,85) I
   85 FORMAT (/1X,I4,30X,'CONSOLIDATED BED')
      LL=NLAYO(I)
      DO 6 L=1,LL
      AVSSTO=0.5*(SSTO(I,L)+SSTO(I,L+1))
      AVGBO=0.5*(GBO(I,L)+GBO(I,L+1))
      AVGADO=0.5*(GADO(I,L)+GADO(I,L+1))
      WRITE (LP,88) L,THICKO(I,L),AVSSTO,AVGBO,AVGADO
    6 CONTINUE
   88 FORMAT (7X,I4,E13.3,E15.3,E19.3,E18.3)
   89 CONTINUE
      ENDIF
   73 FORMAT (///1X,25HNODE POINT CONCENTRATIONS,'  K=',I2//)
   76 FORMAT (5(I5,1PE11.3))
   77 FORMAT (////1X,26HBED SHEARS AND BED PROFILE//)
   70 FORMAT (//5X,F10.5)
      RETURN
      END
************************************************************************
      SUBROUTINE COMPAR
************************************************************************
      INCLUDE 'hsctm.inc'
      DIMENSION EX(MND)
      WRITE (LP,11)
   11 FORMAT (1H1,78H***************************************************
     &***************************//)
   66 FORMAT (//2X,11HTIME STEP *,I10/2X,10HTOTAL TIME,F11.3/2X,
     &10HDELTA TIME,F11.3//)
      IF (NCYC .GT. 1) WRITE (LP,66) NSTEP,TIM(NSTEP),DELT
      WRITE (LP,73)
      WRITE (LP,74)
      AMAX=0.0
      RMAX=0.0
      CALL EXACT (EX)
      DO 100 K=1,NP
      ABER=ABS(CNC(K,1)-EX(K))
      IF (ABS(EX(K)) .LT. 1.0E-25) EX(K)=1.0E-25
      REL=ABER/ABS(EX(K))
      IF (ABER .GT. AMAX) AMAX=ABER
      IF (REL .GT. RMAX) RMAX=REL
  100 WRITE (LP,101) K,CNC(K,1),EX(K),ABER,REL
      WRITE (LP,105) AMAX,RMAX
  105 FORMAT (//1X,24HMAXIMUM ABSOLUTE ERROR =,1PE15.6/1X,
     &24HMAXIMUM RELATIVE ERROR =,1PE15.6/)
  101 FORMAT (I20,1P4E20.6/)
   73 FORMAT (///9X,25HNODE POINT CONCENTRATIONS//)
   74 FORMAT(17X,4HNODE,7X,12HCONC. (COMP),8X,13HCONC. (EXACT),10X,
     &9HBS. ERROR,7X,10HREL. ERROR)
   15 RETURN
      END
************************************************************************
      SUBROUTINE SHPFNS
************************************************************************
*     THIS SUBROUTINE COMPUTES THE ISOPARAMETRIC QUADRATIC FUNCTIONS
*     AND DERIVATIVES FOR QUADRILATERALS WITH PARABOLIC SIDES
************************************************************************
      INCLUDE 'hsctm.inc'
      DO 12 N=1,NGAUSS
      SC=QP(N)
      A=1.0-SC
      B=1.0+SC
      DO 13 M=1,NGAUSS
      ET=QP(M)
      C=1.0-ET
      D=1.0+ET
************************************************************************
*     ELEMENTAL SHAPE FUNCTIONS
************************************************************************
      K=(N-1)*NGAUSS+M
      WT(K)=QW(N)*QW(M)
      EN(1,K)= -A*C*(B+ET)/4.0
      EN(2,K)=A*B*C/2.0
      EN(3,K)= -B*C*(D-SC)/4.0
      EN(4,K)=B*C*D/2.0
      EN(5,K)=B*D*(-A+ET)/4.0
      EN(6,K)=A*B*D/2.0
      EN(7,K)=A*D*(ET-B)/4.0
      EN(8,K)=A*C*D/2.0
************************************************************************
*     DERIVATIVES OF SHAPE FUNCTIONS W.R.T. SCI
************************************************************************
      DNDS(1,K)=C*(2.0*SC+ET)/4.0
      DNDS(2,K)= -SC*C
      DNDS(3,K)=C*(2.0*SC-ET)/4.0
      DNDS(4,K)=C*D/2.0
      DNDS(5,K)=D*(2.0*SC+ET)/4.0
      DNDS(6,K)= -SC*D
      DNDS(7,K)=D*(2.0*SC-ET)/4.0
      DNDS(8,K)= -DNDS(4,K)
************************************************************************
*     DERIVATIVES OF SHAPE FUNCTIONS W.R.T. ETA
************************************************************************
      DNDE(1,K)=A*(2.0*ET+SC)/4.0
      DNDE(2,K)= -A*B/2.0
      DNDE(3,K)= -B*(SC-2.0*ET)/4.0
      DNDE(4,K)= -B*ET
      DNDE(5,K)=B*(2.0*ET+SC)/4.0
      DNDE(6,K)= -DNDE(2,K)
      DNDE(7,K)=A*(2.0*ET-SC)/4.0
   13 DNDE(8,K)= -ET*A
   12 CONTINUE
      RETURN
      END
************************************************************************
      SUBROUTINE TSHAPE
************************************************************************
*     THIS SUBROUTINE COMPUTES THE SHAPE FUNCTIONS AND DERIVATIVES
*     FOR A QUADRATIC TRIANGLE AT NPGAUS GAUSS POINTS
************************************************************************
      INCLUDE 'hsctm.inc'
************************************************************************
*     GAUSS POINTS AND WEIGHTS
*     THIS IS AN EFFICIENT 7 POINT SCHEME
************************************************************************
      NGAUSP=7
      QX(1)=0.333333333333
      QY(1)=0.333333333333
      QWT(1)=0.225000000*0.5
      QX(2)=0.797426985353
      QY(2)=0.101286507323
      QWT(2)=0.125939181*0.5
      QX(3)=QY(2)
      QY(3)=QX(2)
      QWT(3)=QWT(2)
      QX(4)=QX(3)
      QY(4)=QX(3)
      QWT(4)=QWT(2)
      QX(5)=0.059715871790
      QY(5)=0.470142064105
      QWT(5)=0.132394153*0.5
      QX(6)=QY(5)
      QY(6)=QX(6)
      QWT(6)=QWT(5)
      QX(7)=QX(6)
      QY(7)=QX(5)
      QWT(7)=QWT(6)
************************************************************************
*     ISOPARAMETRIC SHAPE FUNCTIONS
************************************************************************
      DO 1 I=1,NGAUSP
         X=QX(I)
         Y=QY(I)
         A=1.0-X-Y
         SZ(2,I)=4.0*X*A*(1.0-Y)
         SZ(4,I)=4.0*X*Y/(X+Y)
         SZ(6,I)=4.0*Y*A*(1.0-X)
         SZ(1,I)=A-(SZ(2,I)+SZ(6,I))/2.0
         SZ(3,I)=X-(SZ(2,I)+SZ(4,I))/2.0
         SZ(5,I)=Y-(SZ(4,I)+SZ(6,I))/2.0
************************************************************************
*     DERIVATIVES WRT SCI
************************************************************************
         SX(2,I)=4.0*(1.0-Y)*(1.0-2.0*X-Y)
         SX(4,I)=4.0*Y*Y/(X+Y)**2
         SX(6,I)= -4.0*Y*(2.0-2.0*X-Y)
         SX(1,I)= -1.0-(SX(2,I)+SX(6,I))/2.0
         SX(3,I)=1.0-(SX(2,I)+SX(4,I))/2.0
         SX(5,I)= -(SX(4,I)+SX(6,I))/2.0
************************************************************************
*     DERIVATIVES WRT ETA
************************************************************************
         SY(2,I)= -4.0*X*(2.0-X-2.0*Y)
         SY(4,I)=4.0*X*X/(X+Y)**2
         SY(6,I)=4.0*(1.0-X)*(1.0-X-2.0*Y)
         SY(1,I)= -1.0-(SY(2,I)+SY(6,I))/2.0
         SY(3,I)= -(SY(2,I)+SY(4,I))/2.0
         SY(5,I)=1.0-(SY(4,I)+SY(6,I))/2.0
    1 CONTINUE
      RETURN
      END
************************************************************************
      SUBROUTINE ELSTIF (NN,KT)
************************************************************************
      INCLUDE 'hsctm.inc'
      DIMENSION DNDX(8),DNDZ(8),ESAV(8,8,NIU),ELOAD(8),WWT(9),EEN(8,9),
     &          PNDS(8,9),PNDE(8,9),EELOD(8)
      IF (NSTEP .EQ. NSTIME) AT(NN)=0.0
************************************************************************
*     CHECK IF TRIANGLAR OR QUADRILATERAL ELEMENT
************************************************************************
      IF (NOP(NN,7) .NE. 0) GO TO 998
************************************************************************
*     TRIANGULAR ELEMENT
************************************************************************
      NCN=6
      IPZ=NGAUSP
      DO 993 KK=1,IPZ
         DO 980 I=1,NCN
            EEN(I,KK)=SZ(I,KK)
            PNDS(I,KK)=SX(I,KK)
            PNDE(I,KK)=SY(I,KK)
  980    CONTINUE
         WWT(KK)=QWT(KK)
  993 CONTINUE
      GO TO 996
************************************************************************
*     QUADRILATERAL ELEMENT
************************************************************************
  998 CONTINUE
      NCN=8
      IPZ=NGAUSS*NGAUSS
      DO 997 KK=1,IPZ
      DO 981 I=1,NCN
      EEN(I,KK)=EN(I,KK)
      PNDS(I,KK)=DNDS(I,KK)
  981 PNDE(I,KK)=DNDE(I,KK)
  997 WWT(KK)=WT(KK)
  996 CONTINUE
      DO 10 I=1,NCN
         ELOAD(I)=0.0
         EELOD(I)=0.0
         DO 10 J=1,NCN
            T(I,J)=0.0
            ESTIFM(I,J)=0.0
   10 CONTINUE
************************************************************************
*     GLOBAL DERIVATIVES, POINT VALUES, JACOBIAN, ETC.
************************************************************************
      DO 81 N=1,IPZ
      AL1=0.0
      U=0.0
      V=0.0
      D=0.0
      DE=0.0
      DF=0.0
      CC=0.0
      CS=0.0
      CD=0.0
      CP=0.0
      CBDP=0.0
      DIFXY=0.0
      DIFY=0.0
      DIFX=0.0
      DXDS=0.0
      DZDS=0.0
      DZDE=0.0
      DXDE=0.0
      DO 2 I=1,NCN
         K=NOP(NN,I)
         K=IABS(K)
         E=EEN(I,N)
         U=E*VEL(1,K)+U
         V=E*VEL(2,K)+V
         D=E*VEL(3,K)+D
         CD=E*CNC(K,4)+CD
         CS=E*CNC(K,1)+CS
         CC=E*CNC(K,2)+CC
         CP=E*CNC(K,3)+CP
         IF (CBP(K,3) .GT. 0.0) THEN
            CBDP=E*CBP(K,3)+CBDP
         ELSEIF (CBP(K,2) .GT. 0.0) THEN
            CBDP=E*CBP(K,2)+CBDP
         ELSE
            CBDP=E*CBP(K,1)+CBDP
         ENDIF
         AL1=AL1+E*ALPHA1(K,1)
         DIFXY=DIFXY+E*DIF(K,3)
         DIFY=DIFY+E*DIF(K,2)
         DIFX=DIFX+E*DIF(K,1)
         DXDS=PNDS(I,N)*CORD(K,1)+DXDS
         DXDE=PNDE(I,N)*CORD(K,1)+DXDE
         DZDS=PNDS(I,N)*CORD(K,2)+DZDS
         DZDE=PNDE(I,N)*CORD(K,2)+DZDE
    2 CONTINUE
*      WRITE (LP,9842) KT,NN,CS,CP,CD,CBDP
* 9842 FORMAT (' KT =',I5,'  NN =',I7,4E15.7)
      VJAC=DXDS*DZDE-DXDE*DZDS
      IF (NSTEP .EQ. NSTIME) AT(NN)=AT(NN)+VJAC*WWT(N)
      DO 3 I=1,NCN
         K=NOP(NN,I)
         K=IABS(K)
         DNDX(I)=(DZDE*PNDS(I,N)-DZDS*PNDE(I,N))/VJAC
         DNDZ(I)=(DXDS*PNDE(I,N)-DXDE*PNDS(I,N))/VJAC
         DE=DE+DNDX(I)*VEL(3,K)
         DF=DF+DNDZ(I)*VEL(3,K)
    3 CONTINUE
************************************************************************
*     ELEMENT STIFFNESS AND LOAD MATRICES
************************************************************************
      IF (KT .EQ. 1) GO TO 2001
      IF (KT .EQ. 2) GO TO 14
      IF (KT .EQ. 3) GO TO 12
      IF (KT .EQ. 4) GO TO 13
      IF (KT .EQ. 5) GO TO 11
************************************************************************
*     STIFFNESS AND LOAD MATRICES FOR SEDIMENT TRANSPORT MODULE
************************************************************************
 2001 DO 4 I=1,NCN
*      WRITE(LP,6992) NSTEP,KT,I,NN,CS
* 6992 FORMAT (' NSTEP=',4I10,E14.6)
      EELOD(I)=EELOD(I)+WWT(N)*VJAC*EEN(I,N)*ALPHA2(NN)
      ELOAD(I)=ELOAD(I)+WWT(N)*VJAC*EEN(I,N)*(ALPHA2(NN)+EDOT(NN)
     &         /TETA)
      DO 4 J=1,NCN
      ESTIFM(I,J)=VJAC*WWT(N)*(EEN(I,N)*(U*DNDX(J)+
     &            V*DNDZ(J)-AL1*EEN(J,N))+DIFX*DNDX(I)*
     &            DNDX(J)+DIFY*DNDZ(I)*DNDZ(J)+DIFXY*DNDX(I)*DNDZ(J)+
     &            DIFXY*DNDX(J)*DNDZ(I))+ESTIFM(I,J)
      T(I,J)=T(I,J)+WWT(N)*VJAC*EEN(I,N)*EEN(J,N)
    4 CONTINUE
      GO TO 81
************************************************************************
*     STIFFNESS AND LOAD MATRICES FOR WATER QUALITY MODULE
************************************************************************
   11 CONTINUE
      DO 24 I=1,NCN
      EELOD(I)=EELOD(I)+WWT(N)*VJAC*EEN(I,N)*ALPHA2(NN)
      ELOAD(I)=ELOAD(I)+WWT(N)*VJAC*EEN(I,N)*(ALPHA2(NN)+EDOT(NN)
     &         /TETA)
      DO 24 J=1,NCN
      ESTIFM(I,J)=VJAC*WWT(N)*(EEN(I,N)*(U*DNDX(J)+
     &            V*DNDZ(J)-AL1*EEN(J,N))+DIFX*DNDX(I)*
     &            DNDX(J)+DIFY*DNDZ(I)*DNDZ(J)+DIFXY*DNDX(I)*DNDZ(J)+
     &            DIFXY*DNDX(J)*DNDZ(I))+ESTIFM(I,J)
      T(I,J)=T(I,J)+WWT(N)*VJAC*EEN(I,N)*EEN(J,N)
   24 CONTINUE
      GO TO 81
************************************************************************
*     STIFFNESS AND LOAD MATRICES FOR ADSORBED CONTAMINANT MODULE
************************************************************************
   12 CONTINUE
      DO 34 I=1,NCN
*      IF (D .LE. 0.0) WRITE(LP,6992) NSTEP,KT,I,NN,D
      EELOD(I)=EELOD(I)+WWT(N)*VJAC*EEN(I,N)*(ALPHA2(NN)*CBDP+
     &         ADRATE(1)*PART(1)*CS*CD)
      ELOAD(I)=ELOAD(I)+WWT(N)*VJAC*EEN(I,N)*((ALPHA2(NN)+EDOT(NN)/
     &         TETA)*CBDP+ADRATE(1)*PART(1)*CS*CD)
      DO 34 J=1,NCN
         ESTIFM(I,J)=VJAC*WWT(N)*(EEN(I,N)*(U*DNDX(J)+
     &   V*DNDZ(J)-(DCYP+ADRATE(1)+AL1)*EEN(J,N))+DIFX*DNDX(I)*
     &   DNDX(J)+DIFY*DNDZ(I)*DNDZ(J)+DIFXY*DNDX(I)*DNDZ(J)+
     &   DIFXY*DNDX(J)*DNDZ(I))+ESTIFM(I,J)
         T(I,J)=T(I,J)+WWT(N)*VJAC*EEN(I,N)*EEN(J,N)
   34 CONTINUE
      GO TO 81
************************************************************************
*     STIFFNESS AND LOAD MATRICES FOR DISSOLVED CONTAMINANT MODULE
************************************************************************
   13 CONTINUE
      DO 44 I=1,NCN
*      IF (D .LE. 0.0) WRITE(LP,6992) NSTEP,KT,I,NN,D
      EELOD(I)=EELOD(I)+WWT(N)*VJAC*EEN(I,N)*(ADRATE(1)*
     &         (CP+GADM(1)*DIA/D*CBDP))
      ELOAD(I)=ELOAD(I)+WWT(N)*VJAC*EEN(I,N)*(ADRATE(1)*
     &         (CP+GADM(1)*DIA/D*CBDP))
      DO 44 J=1,NCN
         ESTIFM(I,J)=VJAC*WWT(N)*(EEN(I,N)*(U*DNDX(J)+
     &   V*DNDZ(J)-(DCYD+ADRATE(1)*PART(1)*CS+
     &   ADRATE(1)*PART(1)*GADM(1)*DIA/D)*EEN(J,N))+DIFX*DNDX(I)*
     &   DNDX(J)+DIFY*DNDZ(I)*DNDZ(J)+DIFXY*DNDX(I)*DNDZ(J)+
     &   DIFXY*DNDX(J)*DNDZ(I))+ESTIFM(I,J)
         T(I,J)=T(I,J)+WWT(N)*VJAC*EEN(I,N)*EEN(J,N)
   44 CONTINUE
************************************************************************
*     STIFFNESS AND LOAD MATRICES FOR SALINITY TRANSPORT MODULE
************************************************************************
   14 CONTINUE
      DO 54 I=1,NCN
      EELOD(I)=EELOD(I)+WWT(N)*VJAC*EEN(I,N)*0.0
      ELOAD(I)=ELOAD(I)+WWT(N)*VJAC*EEN(I,N)*0.0
      DO 54 J=1,NCN
         ESTIFM(I,J)=VJAC*WWT(N)*(EEN(I,N)*(U*DNDX(J)+
     &   V*DNDZ(J))+DIFX*DNDX(I)*
     &   DNDX(J)+DIFY*DNDZ(I)*DNDZ(J)+DIFXY*DNDX(I)*DNDZ(J)+
     &   DIFXY*DNDX(J)*DNDZ(I))+ESTIFM(I,J)
         T(I,J)=T(I,J)+WWT(N)*VJAC*EEN(I,N)*EEN(J,N)
   54 CONTINUE
   81 CONTINUE
      IF (NSTEP .EQ. NSTIME) GO TO 99
************************************************************************
*     THE TRANSIENT PROBLEM
************************************************************************
      DO 5 I=1,NCN
         F(I)=QK(NN,I)
         FO(NN,I)=ELOAD(I)
         QK(NN,I)=EELOD(I)
         DO 5 J=1,NCN
            ESAV(I,J,KT)=ESTO(KT,NN,I,J)
            ESTO(KT,NN,I,J)=ESTIFM(I,J)
    5 CONTINUE
      IF (NSTEP .EQ. NSTIME .AND. NCYC .GT. NSTIME) RETURN
      IF (NSTEP .EQ. NSTIME) GO TO 99
************************************************************************
*     FORM TRANSIENT LOAD AND STIFFNESS ARRAYS
************************************************************************
      DO 6 I=1,NCN
         KK1=IABS(NOP(NN,I))
         TIP=TETZ(KK1)
         CTET=1.0-TIP
         ELOAD(I)=TIP*FO(NN,I)+CTET*F(I)
         DO 6 J=1,NCN
            NJ1=NOP(NN,J)
            NJ1=IABS(NJ1)
            TIP=TETZ(NJ1)
            CTET=1.0-TIP
            ELOAD(I)=ELOAD(I)+(T(I,J)/DLT-(CTET)*ESAV(I,J,KT))*
     &               CNC(NJ1,KT)
            ESTIFM(I,J)=ESTIFM(I,J)*TIP+T(I,J)/DLT
    6 CONTINUE
   99 CONTINUE
************************************************************************
*     MODIFY FOR SPECIFIED CONCENTRATION
************************************************************************
      DO 7 J=1,NCN
         N=NOP(NN,J)
         N=IABS(N)
         TIP=TETZ(N)
         CTET=1.0-TIP
         IF (MFIX(N,KT) .EQ. 0) GO TO 7
         DO 8 I=1,NCN
            ELOAD(I)=ELOAD(I)-ESTIFM(I,J)*(TIP*SPEC(N,KT+3)+CTET*
     &               SPECO(N,KT+3))
    8    CONTINUE
    7 CONTINUE
************************************************************************
*     SYSTEM LOAD ARRAY IS FORMED HERE
************************************************************************
      DO 9 I=1,NCN
         N=NOP(NN,I)
         N=IABS(N)
         JA=NBD(N,KT)
         IF (JA .EQ. 0) GO TO 9
         R9(JA,KT)=R9(JA,KT)+ELOAD(I)
    9 CONTINUE
      RETURN
      END
************************************************************************
      SUBROUTINE FRONT (MM)
************************************************************************
*     FRONTAL ELIMINATION ROUTINE USING FULL PIVOTING
************************************************************************
      INCLUDE 'hsctm.inc'
      DIMENSION EZ(MFW,MFW)
      NDG=1
      NEC=0
      IRTC=0
      LQ=0
      NRR=0
      MMAX=MFW
************************************************************************
*     SET NFIZH TEMPORARILY
************************************************************************
      DO 998 I=1,NE
         NFIZH(I,MM)=I
  998 CONTINUE
      NELL=0
      NTRA=1
      ND5=ND2
      IF (NTRA .EQ. 1) CALL WRT (ND5,0,NRR)
      NTRA=0
************************************************************************
*     PUT INTO R9 ANY SOURCE TERM AT THE NODES
************************************************************************
      J=0
      DO 4 N=1,NP
         R9(N,MM)=0.0
         IF (NBD(N,MM) .EQ. 0) GO TO 4
         J=J+1
         R9(J,MM)=R2(N,MM)
    4 CONTINUE
************************************************************************
*     FIND LAST APPEARANCE OF EACH NODE
************************************************************************
      K=NE+1
      DO 12 NN=1,NE
         K=K-1
         N=NFIZH(K,MM)
         IF (IMAT(N) .LE. 0) GO TO 12
         NCN=6
         IF (NOP(N,7) .NE. 0) NCN=8
         DO 8 M=1,NCN
            NOP(N,M)=IABS(NOP(N,M))
            L=NOP(N,M)
            IF (L .EQ. 0) GO TO 9
            IF (R9(L,MM) .NE. 0.0) GO TO 8
            NOP(N,M)= -L
            R9(L,MM)=1.0
    8 CONTINUE
    9 CONTINUE
   12 CONTINUE
************************************************************************
*     ASSEMBLY
************************************************************************
   14 CONTINUE
      DO 15 N=1,NSZG
         R9(N,MM)=0.0E0
   15 CONTINUE
      LCOL=0
      DO 16 I=1,MMAX
      DO 16 J=1,MMAX
         EZ(J,I)=0.0E0
   16 CONTINUE
   18 NELL=NELL+1
      IF (NELL .GT. NE) GO TO 380
      N=NFIZH(NELL,MM)
      IF (IMAT(N) .LE. 0) GO TO 18
*      WRITE (LP,9372) MM,N,NELL
 9372 FORMAT (' MM =',I5,' N =',I10,' NELL =',I10)
      CALL ELSTIF (N,MM)
*      WRITE (LP,9373) NCN,NDG
 9373 FORMAT (' NCN =',I5,' NDG =',I10)
      NBN=NCN*NDG
      DO 19 LK=1,NBN
         NJ(LK)=0
   19 CONTINUE
      KC=0
      DO 23 J=1,NCN
      NN=NOP(N,J)
      M=IABS(NN)
      IF (M .EQ. 0) GO TO 23
      DO 22 L=1,NDG
         KC=KC+1
         II=NBD(M,MM)
         IF (NN .LT. 0) II = -II
         NJ(KC) = II
   22 CONTINUE
   23 CONTINUE
************************************************************************
*     SET UP HEADING VECTORS
************************************************************************
      DO 52 LK=1,NBN
      NODE=NJ(LK)
      IF (NODE .EQ. 0) GO TO 52
      IF (LCOL .EQ. 0) GO TO 28
      DO 24 L=1,LCOL
      LL=L
      IF (IABS(NODE) .EQ. IABS(LHEF(L))) GO TO 32
   24 CONTINUE
   28 LCOL=LCOL+1
      LDESS(LK)=LCOL
      LHEF(LCOL)=NODE
      GO TO 36
   32 LDESS(LK)=LL
      LHEF(LL)=NODE
   36 CONTINUE
   52 CONTINUE
      IF (LCOL .LE. MMAX) GO TO 54
      NERROR=2
      WRITE (LP,417) NERROR
      WRITE (LP,6008) NFIZH(NELL,MM)
 6008 FORMAT (//10X,' ... STOP AT ELEMENT',I10)
      STOP
   54 CONTINUE
      DO 57 L=1,NBN
      IF (NJ(L) .EQ. 0) GO TO 57
      LL=LDESS(L)
      DO 56 K=1,NBN
      IF (NJ(K) .EQ. 0) GO TO 56
      KK=LDESS(K)
      EZ(KK,LL)=EZ(KK,LL)+ESTIFM(K,L)
   56 CONTINUE
   57 CONTINUE
************************************************************************
*     FIND OUT WHICH MATRIX ELEMENTS ARE FULLY SUMMED
************************************************************************
   60 LC=0
      PIVOT=0.0
      DO 64 L=1,LCOL
         IF (LHEF(L) .GE. 0) GO TO 64
         LC=LC+1
         LPIW(LC)=L
         PIVA=EZ(L,L)
         IF (ABS(PIVA) .LT. PIVOT) GO TO 64
         PIVOT=PIVA
         LPIVCO=L
   64 CONTINUE
*      WRITE (LP,5937) NSTEP,MM,PIVOT
* 5937 FORMAT (2I7,' PIVOT =',E15.7)
      IF (LC .EQ. 0) GO TO 18
      IF (ABS(PIVOT) .LT. 1.0E-20 .AND. NELL .LE. NE) GO TO 18
************************************************************************
*     NORMALIZE PIVOTAL ROW
************************************************************************
      LCO=IABS(LHEF(LPIVCO))
      IF (ABS(PIVOT) .LT. 1.0E-08) WRITE (LP,576) PIVOT
  576 FORMAT (45H WARNING-> MATRIX SINGULAR OR ILL CONDITIONED,E15.7)
      DO 80 L=1,LCOL
         QPP(L)=EZ(LPIVCO,L)/PIVOT
   80 CONTINUE
      RHS=R9(LCO,MM)/PIVOT
      R9(LCO,MM)=RHS
      PVCOL(LPIVCO)=PIVOT
************************************************************************
*     ELIMINATE THEN DELETE PIVOTAL ROW AND COLUMN
************************************************************************
      IF (LPIVCO .EQ. 1) GO TO 104
      LPIVR = LPIVCO-1
      DO 100 K=1,LPIVR
      KRW=IABS(LHEF(K))
      FAC=EZ(K,LPIVCO)
      PVCOL(K)=FAC
      IF (LPIVCO .EQ. 1 .OR. FAC .EQ. 0.0) GO TO 88
      LPIVC=LPIVCO-1
      DO 84 L=1,LPIVC
         EZ(K,L)=EZ(K,L)-FAC*QPP(L)
   84 CONTINUE
   88 IF (LPIVCO .EQ. LCOL) GO TO 96
      LPIVC=LPIVCO+1
      DO 92 L=LPIVC,LCOL
         EZ(K,L-1)=EZ(K,L)-FAC*QPP(L)
   92 CONTINUE
   96 R9(KRW,MM)=R9(KRW,MM)-FAC*RHS
  100 CONTINUE
  104 IF (LPIVCO .EQ. LCOL) GO TO 128
      LPIVR=LPIVCO+1
      DO 124 K=LPIVR,LCOL
         KRW=IABS(LHEF(K))
         FAC=EZ(K,LPIVCO)
         PVCOL(K)=FAC
         IF (LPIVCO .EQ. 1) GO TO 112
         LPIVC=LPIVCO-1
         DO 108 L=1,LPIVC
            EZ(K-1,L)=EZ(K,L)-FAC*QPP(L)
  108    CONTINUE
  112    IF (LPIVCO .EQ. LCOL) GO TO 120
         LPIVC=LPIVCO+1
         DO 116 L=LPIVC,LCOL
            EZ(K-1,L-1)=EZ(K,L)-FAC*QPP(L)
  116    CONTINUE
  120    R9(KRW,MM)=R9(KRW,MM)-FAC*RHS
  124 CONTINUE
  128 CONTINUE
************************************************************************
*     WRITE PIVOTAL EQUATION ON DISK
************************************************************************
      NEC=NEC+1
      LCZ(NEC)=LCOL
      LPZ(NEC)=LPIVCO
      DO 129 L=1,LCOL
         LQ=LQ+1
         LHZ(LQ)=LHEF(L)
         QZ(LQ)=QPP(L)
  129 CONTINUE
      IF (LQ .LT. LBMAX-MMAX) GO TO 1291
      IRTC=IRTC+1
      ND5=ND2
      IF (IRTC .EQ. 1) CALL WRT (ND5,0,NRR)
      CALL WRT (ND5,-1,NRR)
      LQ=0
 1291 CONTINUE
      DO 130 L=1,LCOL
         EZ(L,LCOL)=0.0
         EZ(LCOL,L)=0.0
  130 CONTINUE
************************************************************************
*     REARRANGE HEADING VECTORS
************************************************************************
      LCOL=LCOL-1
      IF (LPIVCO .EQ. LCOL+1) GO TO 136
      DO 132 L=LPIVCO,LCOL
         LHEF(L)=LHEF(L+1)
  132 CONTINUE
  136 CONTINUE
************************************************************************
*     DETERMINE WHETHER TO ASSEMBLE, ELIMINATE, OR BACK SUBSTITUTE
************************************************************************
  380 CONTINUE
      IF (LCOL .GT. 1) GO TO 60
      LCO=IABS(LHEF(1))
      PIVOT=EZ(1,1)
      IF (ABS(PIVOT) .LT. 1.0E-08) WRITE (LP,476) MM,LCO
  476 FORMAT (' WARNING-MATRIX SINGULAR OR ILL CONDITIONED',' MM=',
     &       I4,' LCO=',I15)
      R9(LCO,MM)=R9(LCO,MM)/PIVOT
      NEC=NEC+1
      LCZ(NEC)=1
      LPZ(NEC)=1
      LQ=LQ+1
      LHZ(LQ)=LHEF(1)
      QZ(LQ)=1.0
************************************************************************
*     BACK SUBSTITUTION
************************************************************************
      WRITE (LP,6020) IRTC
 6020 FORMAT(1X,'***',I5,' BUFFER BLOCK(S) WRITTEN DURING FRONTAL ',
     &'SOLUTION'/)
      NEC=NSZG+1
      DO 600 IVQ=1,NSZG
      NEC=NEC-1
      LCOL=LCZ(NEC)
      LPIVCO=LPZ(NEC)
      LQ=LQ-LCOL
      IF (LQ .GT. -1) GO TO 450
      ND5=ND2
      CALL RED (ND5,IRTC,NRR)
      LQ=LQ-LCOL
  450 DO 460 L=1,LCOL
      LQ=LQ+1
      LHEF(L)=LHZ(LQ)
  460 QPP(L)=QZ(LQ)
      LQ=LQ-LCOL
      LCO=IABS(LHEF(LPIVCO))
      GASH=0.0
      QPP(LPIVCO)=0.0
      DO 580 L=1,LCOL
         ITEMP=IABS(LHEF(L))
         GASH=GASH-QPP(L)*R9(ITEMP,MM)
  580 CONTINUE
      R9(LCO,MM)=R9(LCO,MM)+GASH
  600 CONTINUE
************************************************************************
*     TRANSFER CONCENTRATIONS TO CONCENTRATION ARRAY FROM R9 ARRAY
************************************************************************
         DO 150 J=1,NP
            NJ1=NBD(J,MM)
            IF (NJ1) 33,33,34
   33       CNC(J,MM)=SPEC(J,MM+3)
            GO TO 150
   34       CNC(J,MM)=R9(NJ1,MM)
  150    CONTINUE
  417 FORMAT (/8H NERROR=,I5//
     & ' THE DIFFERENCE MMAX-NCRIT IS NOT SUFFICIENTLY LARGE'
     &/' TO PERMIT THE ASSEMBLY OF THE NEXT ELEMENT---'
     &/' EITHER INCREASE MMAX OR LOWER NCRIT',/)
      RETURN
      END
************************************************************************
      SUBROUTINE LOADX
************************************************************************
      INCLUDE 'hsctm.inc'
      IR1MAX=MR1
      DO 4 MM=1,JQP
         DO 1 N=1,NP
            NBD(N,MM)=1
            IF (NFIZ(N,MM) .EQ. 0 .AND. MFIX(N,MM) .EQ. 0) GO TO 1
            NBD(N,MM)=0
    1    CONTINUE
    4 CONTINUE
*      DO 43 N=1,NP
*            WRITE (LP,6000) N,(NBD(N,MM),MM=1,3)
* 6000 FORMAT (' NBD =',4I10)
*   43 CONTINUE
      DO 3 MM=1,JQP
         NSZG=0
         DO 2 J=1,NP
            IF (NBD(J,MM) .EQ. 0) GO TO 2
            NSZG=NSZG+1
            NBD(J,MM)=NSZG
    2    CONTINUE
         WRITE (LP,11) NSZG
    3 CONTINUE
   11 FORMAT (/,1X,'NUMBER OF EQUATIONS IN SYSTEM ARRAY = ',I6/)
      IF (NSZG .LE. IR1MAX) RETURN
      WRITE (LP,12) IR1MAX
   12 FORMAT (/ ,10X,'SYSTEM ARRAY LONGER THAN ALLOWABLE MAXIMUM OF ',
     & I6,/,10X,'EXECUTION TERMINATED')
      STOP
      END
************************************************************************
      SUBROUTINE DRYNOD
************************************************************************
*     DETERMINES DRY NODES AND ELEMENTS AND SETS NFIZ = 1 FOR DRY NODES
*     AND IMAT NEGATIVE FOR DRY ELEMENTS. FOR ALL ELEMENTS THAT WERE
*     DRY AT PREVIOUS TIME STEP, THETA = 1.0
************************************************************************
      INCLUDE 'hsctm.inc'
************************************************************************
*     SET THETA = 1.0 FOR ALL PREVIOUSLY DRY NODES, RESET NFIZ TO MFIX,
*     AND SET NFIZ = 1 FOR DRY NODES
************************************************************************
      DO 4 MM=1,JQP
         DO 1 I=1,NP
            TETZ(I)=TETA
            IF (NFIZ(I,MM) .EQ. 1) TETZ(I)=1.0
            NFIZ(I,MM)=MFIX(I,MM)
            IF (VEL(3,I) .LT. 0.083) NFIZ(I,MM)=1
    1    CONTINUE
    4 CONTINUE
************************************************************************
*     SET IMAT NEGATIVE FOR DRY ELEMENTS
************************************************************************
      DO 2 I=1,NE
         ITE=0
         NCN=8
         IF (NOP(I,7) .EQ. 0) NCN=6
         DO 3 J=1,NCN
            K=IABS(NOP(I,J))
             IF (VEL(3,K) .LT. 0.083) ITE=ITE+1
    3    CONTINUE
         IMAT(I)=IABS(IMAT(I))
         IF (ITE .EQ. NCN) IMAT(I) = -IMAT(I)
    2 CONTINUE
      RETURN
      END
************************************************************************
      SUBROUTINE RED (ND,IRTC,NRR)
************************************************************************
*     SUBROUTINE TO READ DATA WITH MASS TRANSFER
************************************************************************
      INCLUDE 'hsctm.inc'
      NRDS=IRTC-NRR
      REWIND ND
      DO 100 L=1,NRDS
         READ (ND) LQ,LHZ,QZ
  100 CONTINUE
      REWIND ND
      NRR=NRR+1
      RETURN
      END
************************************************************************
      SUBROUTINE WRT (ND,N,NRR)
************************************************************************
*     SUBROUTINE TO PERFORM MASS TRANSFER OF DATA AND LOCATE
*     STARTING POINT
************************************************************************
      INCLUDE 'hsctm.inc'
************************************************************************
*     NTR IS TOTAL LENGTH OF BLOCK TRANSFER = LBMAX*2+1
************************************************************************
      IF (N) 400,300,400
************************************************************************
*     IF N .EQ. 0 REWIND OR INITIALIZE FILE
************************************************************************
  300 REWIND ND
      RETURN
  400 WRITE (ND) LQ,LHZ,QZ
      NRR=0
      RETURN
      END
************************************************************************
      SUBROUTINE INTERP
************************************************************************
*
*     THIS IS A SUBROUTINE TO PERFORM ELEMENT TO NODE INTERPOLATION.
*
*     BEDEL(NE) IS ARRAY WITH ELEMENTAL AVERAGE BOTTOM ELEVATIONS.
*     WHEN THE PROCEDURE IS COMPLETE, BEDNOD(I) WILL CONTAIN THE
*     NODAL INTERPOLATED BOTTOM ELEVATIONS.
*
*     ARRAY AREAS(I) CONTAINS THE AREAS REPRESENTED BY EACH NODE.
*     ARRAY AREASE(NE,NCN) CONTAINS THE AREA REPRESENTED BY EACH
*     NODE WITHIN INDIVIDUAL ELEMENTS.
*
************************************************************************
      INCLUDE 'hsctm.inc'
      DO 1000 I=1,NP
         BEDNOD(I)=0.0E0
         AREAS(I)=0.0E0
 1000 CONTINUE
      DO 1010 NN=1,NE
         CALL SEDMAT (NN)
 1010 CONTINUE
      CALL DISTBT
      RETURN
      END
************************************************************************
      SUBROUTINE SEDMAT (NN)
************************************************************************
      REAL*8 WAITQ,WAITQQ
      INCLUDE 'hsctm.inc'
      DIMENSION
     &   DA(8,16),DB(8,16),
     &   WAITX(16),GOSSA(9),ANAREA(8),WAITQ(7),WAITQQ(9),XL(8),YL(8)
      DATA WAITQ/
     &   0.11250000000000D0,   0.06619707639425D0,   0.06619707639425D0,
     &   0.06619707639425D0,   0.06296959027241D0,   0.06296959027241D0,
     &   0.06296959027241D0/
      DATA WAITQQ/
     &   0.30864197530863D0,   0.49382716049379D0,   0.30864197530863D0,
     &   0.49382716049379D0,   0.79012345679006D0,   0.49382716049379D0,
     &   0.30864197530863D0,   0.49382716049379D0,   0.30864197530863D0/
      AREA=0.0E0
      NCN=8
      NGP=9
      IF (NOP(NN,7) .EQ. 0) NCN=6
      IF (NOP(NN,7) .EQ. 0) NGP=7
      CX=1.0E0
      SA=0.0E0
      IF (NGP .EQ. 7) GO TO 1000
      DO 90 M=1,NGP
         WAITX(M)=SNGL(WAITQQ(M))
         DO 90 N=1,NCN
            DA(N,M)=DNAR(N,M)
            DB(N,M)=DNBR(N,M)
   90 CONTINUE
      NR=IABS(NOP(NN,1))
      DO 100 K=2,NCN
      N=IABS(NOP(NN,K))
      DX=CORD(N,1)-CORD(NR,1)
      DY=CORD(N,2)-CORD(NR,2)
      XL(K)=DX*CX+DY*SA
      YL(K)= -DX*SA+DY*CX
  100 CONTINUE
      DO 500 I=1,NGP
  125 A11=0.0E0
      A12=0.0E0
      A21=0.0E0
      A22=0.0E0
      DO 130 K= 2,NCN
         A11=A11+DA(K,I)*XL(K)
         A12=A12+DA(K,I)*YL(K)
         A21=A21+DB(K,I)*XL(K)
         A22=A22+DB(K,I)*YL(K)
  130 CONTINUE
      DETJ=A11*A22-A12*A21
      AMW=WAITX(I)*DETJ
      AREA=AREA+AMW
      GOSSA(I)=AMW
      IF (AMW .LE. 0.0) WRITE(LP,6000) AMW,NN,I,NGP,DETJ
 6000 FORMAT(' AMW =',E14.6,', Element',I5,', Gauss No.',I5,', NGP=',
     &       I5,', DETJ =',E14.6)
  500 CONTINUE
*-
*     DISTRIBUTE GAUSS POINT AREAS TO NODES USING AN APPROXIMATE
*     METHOD. THIS METHOD DISTRIBUTES THE CENTRAL GAUSS POINT
*     AREA (GAUSS PT. 5) EQUALLY TO ALL NODES AND ASSIGNS THE
*     AREAS OF OUTER GAUSS POINTS TO CORRESPONDING NODES
*-
      GMIDLE=GOSSA(5)/8.0
      ANAREA(1)=GOSSA(7)+GMIDLE
      ANAREA(2)=GOSSA(8)+GMIDLE
      ANAREA(3)=GOSSA(9)+GMIDLE
      ANAREA(4)=GOSSA(6)+GMIDLE
      ANAREA(5)=GOSSA(3)+GMIDLE
      ANAREA(6)=GOSSA(2)+GMIDLE
      ANAREA(7)=GOSSA(1)+GMIDLE
      ANAREA(8)=GOSSA(4)+GMIDLE
      DO 280 I=1,NCN
         IR=IABS(NOP(NN,I))
         AREAS(IR)=AREAS(IR)+ANAREA(I)
         AREASE(NN,I)=ANAREA(I)
  280 CONTINUE
      RETURN
 1000 DO 80 M=1,NGP
         WAITX(M)=SNGL(WAITQ(M))
         DO 80 N=1,NCN
            DA(N,M)=DNAT(N,M)
            DB(N,M)=DNBT(N,M)
   80 CONTINUE
      NR=IABS(NOP(NN,1))
      DO 200 K=2,NCN
         N=IABS(NOP(NN,K))
         DX=CORD(N,1)-CORD(NR,1)
         DY=CORD(N,2)-CORD(NR,2)
         XL(K)=DX*CX+DY*SA
         YL(K)= -DX*SA+DY*CX
  200 CONTINUE
      DO 600 I=1,NGP
         A11=0.0
         A12=0.0
         A21=0.0
         A22=0.0
         DO 230 K= 2,NCN
            A11=A11+DA(K,I)*XL(K)
            A12=A12+DA(K,I)*YL(K)
            A21=A21+DB(K,I)*XL(K)
            A22=A22+DB(K,I)*YL(K)
  230    CONTINUE
      DETJ=A11*A22-A12*A21
      AMW=WAITX(I)*DETJ
      AREA=AREA+AMW
      GOSSA(I)=AMW
      IF (AMW .LE. 0.0) WRITE (LP,6000) AMW,NN,I,NGP,DETJ
  600 CONTINUE
*-
*     DISTRIBUTE GAUSS POINT AREAS TO NODES USING AN APPROXIMATE
*     METHOD. THIS METHOD DISTRIBUTES THE CENTRAL GAUSS POINT
*     AREA (GAUSS PT. 4) EQUALLY TO ALL NODES AND ASSIGNS THE
*     AREAS OF OUTER GAUSS POINTS TO CORRESPONDING NODES
*-
      GMIDLE=GOSSA(4)/6.0
      ANAREA(1)=GOSSA(2)+GMIDLE
      ANAREA(2)=GOSSA(7)+GMIDLE
      ANAREA(3)=GOSSA(1)+GMIDLE
      ANAREA(4)=GOSSA(5)+GMIDLE
      ANAREA(5)=GOSSA(3)+GMIDLE
      ANAREA(6)=GOSSA(6)+GMIDLE
      DO 290 I=1,NCN
         IR=IABS(NOP(NN,I))
         AREAS(IR)=AREAS(IR)+ANAREA(I)
         AREASE(NN,I)=ANAREA(I)
  290 CONTINUE
      RETURN
      END
************************************************************************
      SUBROUTINE DISTBT
************************************************************************
      INCLUDE 'hsctm.inc'
*      WRITE(LP,*) 'NN                AVERAG     NCN NUM    BEDNOD(NUM)
*     &  AREASE(NN,N)'
      DO 300 NN=1,NE
         AVERAG=BEDL(NN)
         IF (AVERAG .EQ. 0.0E0) GO TO 300
         NCN=8
         IF (NOP(NN,7) .EQ. 0) NCN=6
         DO 100 N=1,NCN
            NUM=IABS(NOP(NN,N))
            BEDNOD(NUM)=BEDNOD(NUM)+AVERAG*AREASE(NN,N)
*            IF (NUM .EQ. 1599) THEN
*            WRITE (LP,9933) NN,AVERAG,NCN,NUM,BEDNOD(NUM),
*     &                      AREASE(NN,N)
* 9933       FORMAT (I5,' BEDL= ',E15.7,2I5,2E15.7)
*            ENDIF
  100    CONTINUE
  300 CONTINUE
*      WRITE (LP,*) 'N,BEDNOD(N),BEDLL(N),VEL(3,N),AREAS(N)'
      DO 200 N=1,NP
         BEDNOD(N)=BEDNOD(N)/AREAS(N)
         BEDLL(N)=BEDLL(N)+BEDNOD(N)
         AOLD=AO(N)
         AO(N)=AO(N)+BEDNOD(N)
*         IF (N .EQ. 1599) WRITE (LP,9935) NSTEP,AO(N),AOLD,AREAS(N),
*     &                                    BEDNOD(N),BEDLL(N)
* 9935    FORMAT (' NSTEP=',I6,5E14.7)
*         IF (BEDLL(N) .NE. 0.0E0) WRITE (LP,9933) N,BEDNOD(N),BEDLL(N),
*     &                                            AOLD,AO(N),AREAS(N)
*9933     FORMAT (' N=',I5,5E14.6)
  200 CONTINUE
      RETURN
      END
************************************************************************
      SUBROUTINE INTER2 (KT)
************************************************************************
*
*     THIS IS A SUBROUTINE TO PERFORM ELEMENT TO NODE INTERPOLATION
*
*     CBEL(NE) IS AN ARRAY WITH ELEMENTAL AVERAGE CONTAMINANT BED
*     CONCENTRATIONS
*
*     WHEN THE PROCEDURE IS COMPLETE, CBP(NP) WILL CONTAIN THE
*     NODAL INTERPOLATED CONTAMINANT BED CONCENTRATIONS (kg/kg)
*
*     ARRAY AREAS(I) CONTAINS THE AREAS REPRESENTED BY EACH NODE
*     ARRAY AREASE(NE,NCN) CONTAINS THE AREA REPRESENTED BY EACH
*     NODE WITHIN INDIVIDUAL ELEMENTS
*
************************************************************************
      INCLUDE 'hsctm.inc'
      DO 1000 I=1,NP
         CBP(I,KT)=0.0E0
         AREAS(I)=0.0E0
 1000 CONTINUE
      DO 1010 NN=1,NE
         CALL SEDMA2 (NN)
 1010 CONTINUE
      CALL DISTB2 (KT)
      RETURN
      END
************************************************************************
      SUBROUTINE SEDMA2 (NN)
************************************************************************
      REAL*8 WAITQ,WAITQQ
      INCLUDE 'hsctm.inc'
      DIMENSION
     &   DA(8,16),DB(8,16),
     &   WAITX(16),GOSSA(9),ANAREA(8),WAITQ(7),WAITQQ(9),XL(8),YL(8)
      DATA WAITQ/
     &   0.11250000000000D0,   0.06619707639425D0,   0.06619707639425D0,
     &   0.06619707639425D0,   0.06296959027241D0,   0.06296959027241D0,
     &   0.06296959027241D0/
      DATA WAITQQ/
     &   0.30864197530863D0,   0.49382716049379D0,   0.30864197530863D0,
     &   0.49382716049379D0,   0.79012345679006D0,   0.49382716049379D0,
     &   0.30864197530863D0,   0.49382716049379D0,   0.30864197530863D0/
      AREA=0.0E0
      NCN=8
      NGP=9
      IF (NOP(NN,7) .EQ. 0) NCN=6
      IF (NOP(NN,7) .EQ. 0) NGP=7
      CX=1.0E0
      SA=0.0E0
      IF (NGP .EQ. 7) GO TO 1000
      DO 90 M=1,NGP
         WAITX(M)=SNGL(WAITQQ(M))
         DO 90 N=1,NCN
*            XNX(N,M)=XNR(N,M)
            DA(N,M)=DNAR(N,M)
            DB(N,M)=DNBR(N,M)
   90 CONTINUE
      NR=IABS(NOP(NN,1))
      DO 100 K=2,NCN
         N=IABS(NOP(NN,K))
         DX=CORD(N,1)-CORD(NR,1)
         DY=CORD(N,2)-CORD(NR,2)
         XL(K)=DX*CX+DY*SA
         YL(K)= -DX*SA+DY*CX
  100 CONTINUE
      DO 500 I=1,NGP
  125 A11=0.0E0
      A12=0.0E0
      A21=0.0E0
      A22=0.0E0
      DO 130 K=2,NCN
         A11=A11+DA(K,I)*XL(K)
         A12=A12+DA(K,I)*YL(K)
         A21=A21+DB(K,I)*XL(K)
         A22=A22+DB(K,I)*YL(K)
  130 CONTINUE
      DETJ=A11*A22-A12*A21
      AMW=WAITX(I)*DETJ
      AREA=AREA+AMW
      GOSSA(I)=AMW
      IF (AMW .LE. 0.0) WRITE(LP,6000) AMW,NN,I,NGP,DETJ
 6000 FORMAT(' AMW =',E14.6,', Element',I5,', Gauss No.',I5,', NGP=',
     &       I5,', DETJ =',E14.6)
  500 CONTINUE
*-
*     DISTRIBUTE GAUSS POINT AREAS TO NODES USING AN APPROXIMATE
*     METHOD. THIS METHOD DISTRIBUTES THE CENTRAL GAUSS POINT
*     AREA (GAUSS PT. 5) EQUALLY TO ALL NODES AND ASSIGNS THE
*     AREAS OF OUTER GAUSS POINTS TO CORRESPONDING NODES.
*-
      GMIDLE=GOSSA(5)/8.0
      ANAREA(1)=GOSSA(7)+GMIDLE
      ANAREA(2)=GOSSA(8)+GMIDLE
      ANAREA(3)=GOSSA(9)+GMIDLE
      ANAREA(4)=GOSSA(6)+GMIDLE
      ANAREA(5)=GOSSA(3)+GMIDLE
      ANAREA(6)=GOSSA(2)+GMIDLE
      ANAREA(7)=GOSSA(1)+GMIDLE
      ANAREA(8)=GOSSA(4)+GMIDLE
      DO 280 I=1,NCN
         IR=IABS(NOP(NN,I))
         AREAS(IR)=AREAS(IR)+ANAREA(I)
         AREASE(NN,I)=ANAREA(I)
  280 CONTINUE
      RETURN
 1000 DO 80 M=1,NGP
         WAITX(M)=SNGL(WAITQ(M))
         DO 80 N=1,NCN
            DA(N,M)=DNAT(N,M)
            DB(N,M)=DNBT(N,M)
   80 CONTINUE
      NR=IABS(NOP(NN,1))
      DO 200 K=2,NCN
      N=IABS(NOP(NN,K))
      DX=CORD(N,1)-CORD(NR,1)
      DY=CORD(N,2)-CORD(NR,2)
      XL(K)=DX*CX+DY*SA
      YL(K)= -DX*SA+DY*CX
  200 CONTINUE
      DO 600 I=1,NGP
      A11=0.0
      A12=0.0
      A21=0.0
      A22=0.0
      DO 230 K= 2,NCN
         A11=A11+DA(K,I)*XL(K)
         A12=A12+DA(K,I)*YL(K)
         A21=A21+DB(K,I)*XL(K)
         A22=A22+DB(K,I)*YL(K)
  230 CONTINUE
      DETJ=A11*A22-A12*A21
      AMW=WAITX(I)*DETJ
      AREA=AREA+AMW
      GOSSA(I)=AMW
      IF (AMW .LE. 0.0) WRITE(LP,6000) AMW,NN,I,NGP,DETJ
  600 CONTINUE
*-
*     DISTRIBUTE GAUSS POINT AREAS TO NODES USING AN APPROXIMATE
*     METHOD. THIS METHOD DISTRIBUTES THE CENTRAL GAUSS POINT
*     AREA (GAUSS PT. 4) EQUALLY TO ALL NODES AND ASSIGNS THE
*     AREAS OF OUTER GAUSS POINTS TO CORRESPONDING NODES
*-
      GMIDLE=GOSSA(4)/6.0
      ANAREA(1)=GOSSA(2)+GMIDLE
      ANAREA(2)=GOSSA(7)+GMIDLE
      ANAREA(3)=GOSSA(1)+GMIDLE
      ANAREA(4)=GOSSA(5)+GMIDLE
      ANAREA(5)=GOSSA(3)+GMIDLE
      ANAREA(6)=GOSSA(6)+GMIDLE
      DO 290 I=1,NCN
         IR=IABS(NOP(NN,I))
         AREAS(IR)=AREAS(IR)+ANAREA(I)
         AREASE(NN,I)=ANAREA(I)
  290 CONTINUE
      RETURN
      END
************************************************************************
      SUBROUTINE DISTB2 (KT)
************************************************************************
      INCLUDE 'hsctm.inc'
*      WRITE(LP,*) 'NN                AVERAG     NCN NUM    BEDNOD(NUM)  
*     &  AREASE(NN,N)'
      DO 300 NN=1,NE
         AVERAG=CBEL(NN,KT)
         IF (AVERAG .EQ. 0.0) GO TO 300
         NCN=8
         IF (NOP(NN,7) .EQ. 0) NCN=6
         DO 100 N=1,NCN
            NUM=IABS(NOP(NN,N))
            CBP(NUM,KT)=CBP(NUM,KT)+AVERAG*AREASE(NN,N)
*            WRITE(LP,9935)NN,AVERAG,NCN,NUM,BEDNOD(NUM),
*     &                                     AREASE(NN,N)
* 9935       FORMAT(I5,' BEDL= ',E15.7,2I5,2E15.7)
  100    CONTINUE
  300 CONTINUE
      DO 200 N=1,NP
         CBP(N,KT)=CBP(N,KT)/AREAS(N)
  200 CONTINUE
      RETURN
      END
************************************************************************
      SUBROUTINE HYDRO2
************************************************************************
*
*     Module HYDRO2 - Two-dimensional Hydrodynamics in the
*                     Horizontal Plane
*
************************************************************************
      INCLUDE 'hsctm.inc'
*-
      LOGICAL ONCE
*-
      VERRM2(1) = 'HYDRO2      1-D AND 2-D CAPABILITY.'
      VERRM2(2) = 'LAST MODIFICATION DATE  07-25-1997 '
*-
      CHKDMS =  ' DMS ='
*-
      DESC(1)(1:40)  = '........................................'
      DESC(1)(41:80) = '........................................'
      DESC(2)(1:40)  = '........................................'
      DESC(2)(41:80) = '........................................'
*-
      IF (NCON .EQ. 2 .AND. NSTEP .GT. NSTIME) GO TO 180
      IF (NCON .EQ. 1) THEN
         NSTEP = NSTIME
         ICYC = NSTEP
      ENDIF
*-
      ITRACE =  0
      IRVIZ  =  0
      IRVOLD =  0
      USERCA =  1.6
*-
* ... PRINT FLOW TRACE ALL SUBROUTINE CALLS (0=OFF 1=TRACE MAIN 2=ALL)
*-
* ... SET STEADY STATE ON (COEF1 FOR NON-REFLECTING BC VIA BRL-CARD)
*-
      ISS = 1
*-
      METRIC = 1
      IBATCH = 0
      DORITE = 0
      INHEC  = 2
*-
* ... Initialize
*-
      CALL BDATA
*-
* ... Read input from interative file assignments if IBATCH = 0
*-
      IF (IBATCH .LE. 0) CALL FILE
*-
      IBCSET = 0
*-
      CALL PREHYD (0)
*-
      IBCSET = 1
*-
* ... Get flow directions for one-dimensional elements
*-
      CALL FLDIR
*-
* ... Perform initial step solution
*-
      CALL CHECK
      IDP = 2
      IF (NITI .EQ. 0) GO TO 170
      ICT = LI
  105 FACT = 0.0
      WRITE (IOUT,106) SSDCRT,NITI,NITSV,MAXN
  106 FORMAT(//,' *** STEADY STATE DEPTH CONVERGENCE CRITERION =',F10.7,
     &    //,' *** NITI REQUESTED=',I5,' NITSV-SOLVED=',I5,' MAXN=',I5)
      STPCRT = SSDCRT
      DO 130 NPRR = 1,NITI
        NITSV = NITSV+1
        NPR   = NITSV
        WRITE (IOUT,9982) LI,ICT,IPLI,IDNOPT
 9982   FORMAT (' LI =',4I7)
        IF (ICT .LT. LI) GO TO 110
*-
* ... Wetting and drying activated
*-
        IF (IPLI .EQ. 0) THEN
          IF (IDNOPT .EQ. 0) THEN
            CALL REWET
            CALL DEL
          ELSE
            CALL REWETM
            CALL DELM
          ENDIF
        ENDIF
        IF (IFLG .EQ. 1 .AND. NPRR .NE. 1) THEN
* ... Test for convergence
            IF (FACT .LT. SSDCRT) GO TO 150
        ENDIF
        IF (NPR .GT. 1) FACT = 0.0
        ICT = 0
  110   CONTINUE
*-
        CALL BLINE (NPR)
        CALL FLDIR
        CALL LOAD
        ICT = ICT+1
*-
* ... Prepare cross sectional areas for stage flow computation
*-
        CALL AGEN
        CALL FRONT2
        IDP = 1
        IF (ITSI .GT. 0) THEN
            IF (MOD(NPR,ITSI) .EQ. 0) IDP = 2
            IF (NPR .EQ. NITI) IDP = 2
        ENDIF
        IF (ISPRT .GT. 0) THEN
            IF (IDP .NE. 2 .AND. NPR .EQ. NITI) IDP = -2
        ENDIF
        CALL OUTPUT (IDP)
        IF (FACT .LT. SSDCRT) ICT = LI
*-
        IF (IHOTO .NE. 0) THEN
* ... WRITE BINARY HYDRO RESTART INFORMATION, WITH BANNERS
          PRINT *,' *** WRITE S.S. HOTSTART AT HR-ITERATION =',TET,NITSV
          IREC(1) = 427
* ... WRITE INTEGER type CHARACTER BANNER .. BINARY HOTSTART HYDRO
          PRINT *,' --> writing the integer banner hotstart'
*-
          CALL CONVRT (BANRM2,15,IPACKB,80,1)
*-
          REWIND IHOTO
          MFLG = 135
          WRITE (IHOTO) MFLG,IREC(1),NP,NE
          IWRT1 = 1200
          WRITE (IHOTO) IWRT1,(IPACKB(I),I=1,IWRT1)
          IWRT2 = 40
          IWRT3 = 40
          WRITE (IHOTO) IWRT2,IWRT3,
     &                  (IREC(I),I =1,IWRT2),(FREC(I),I =1,IWRT3)
*-
          WRITE (IHOTO) TET,NP,NE,NITSV,
     &                ((VEL(J,K),J=1,3),K =1,NP),
     &                ((VDOT(J,K),J=1,3),K = 1,NP),
     &                ((VOLD(J,K),J=1,3),K = 1,NP),
     &                ((VDOTO(J,K),J=1,3),K = 1,NP),
     &                 (NDRY(K),K = 1,NP),
     &                 (HEL(K),HOL(K),HDET(K),HDOT(K),K = 1,NP),
     &                 (IMAT(K),K = 1,NE)
        ENDIF
*-
  120 CALL CHECK
      MAXN  = NPRR
  130 CONTINUE
*-
  150 IF (MAXN .LT. NITI) NITSV = NITSV-1
*-
      IF (IRVIZ .GT. 0) THEN
* ... AN  REV-CARD HAS BEEN DETECTED
          PRINT *,' *** UPDATE STEADY STATE ... REVISION =',IRVIZ
          CALL PREHYD (1)
          GO TO 105
      ENDIF
*-
      DO 165 J = 1,NP
         WSEL(J) = HEL(J)+AO(J)
  165 CONTINUE
*-
  170 IF (IFINO .GT. 0) THEN
*-
* ... WRITE FINAL-RESULTS FILE ... FOR STEADY STATE SOLUTION
*-
         IF (.NOT. ONCE) THEN
*-
* ... WRITE DMS BANNERS ON FINAL HYDRO RESULTS FIRST TIME THRU
*-
            CALL CONVRT (BANRM2,15,IPACKB,80,1)
            CALL CONVRT (TITLE,1,IPACKT,77,1)
            REWIND IFINO
            MFLG = 1
            NTSZ = NCYC-ICYC
*            WRITE (IOUT,1431) ICYC,NSTIME,NITSV,ITRMAX,NTSZ
* 1431 FORMAT (' ICYC=',I6,' NSTIME=',I5,' NITSV=',I5,' ITRMAX=',I5,
*     &        ' NTSZ=',I6)
            WRITE (IFINO) MFLG,NP,NE,NTSZ
            ONCE = .TRUE.
         ENDIF
*-
* ... WRITE STEADY STATE FINAL RESULTS INFORMATION
*-
         IWRITE = 0
         IF (NTBN .GT. 0) THEN
* ... ONLY USER SELECTED HOURS WILL BE WRITTEN
            DO 175 JJ = 1,NTBN
*               WRITE (IOUT,1331) JJ,NTBN,TBINRY(JJ),TET
* 1331          FORMAT (' JJ1=',I5,' NTBN=',I7,' TBINRY(JJ)=',F10.4,
*     &                 ' TET=',F10.4)
               IF (ABS(TBINRY(JJ)-TET) .GT. 0.01) GO TO 175
               IWRITE = 1
  175       CONTINUE
         ELSE
* ... BY DEFAULT THE LAST ITERATION OF ALL HOURS ARE WRITTEN
            IWRITE = 1
         ENDIF
*-
         IF (IWRITE .EQ. 1) THEN
            WRITE (IFINO) TET,((VEL(J,K),J=1,2),WSEL(K),K = 1,NP),
     &                    (IMAT(JJ),JJ = 1,NE)
            DORITE = DORITE+1.0
         ENDIF
      ENDIF
*-
      IF (NCYC .GT. 0 .AND. NCON .NE. 1) THEN
         RETURN
      ELSEIF (NCYC .GT. 0 .AND. NCON .EQ. 1) THEN
         GO TO 180
      ELSEIF (NCYC .EQ. 0 .AND. NCON .EQ. 1) THEN
         GO TO 1801
      ELSEIF (NCYC .EQ. 0 .AND. NCON .NE. 1) THEN
         RETURN
      ENDIF
*-
 1801 CALL ZVRS (1)
      IF (IBATCH .EQ. 0) THEN
          CALL BEEP (5)
          PRINT *,' HYDRO2 has finished initial solution'
      ENDIF
      RETURN
*-
  180 NITSV = 1
      DO 185 J = 1,NP
         DO 184 K = 1,NDF
            VOLD(K,J) = VEL(K,J)
            VDOT(K,J) = 0.0
            VDOTO(K,J) = 0.0
  184    CONTINUE
         HOL(J) = HEL(J)
         HDET(J) = 0.0
         HDOT(J) = 0.0
         WSEL(J) = HEL(J)+AO(J)
         IF (J .EQ. 1599) WRITE (LP,9768) NSTEP,AO(J),HEL(J),WSEL(J)
 9768    FORMAT (' NSTEP=',I6,3E14.6)
  185 CONTINUE
*-
*                  ******* DYNAMIC LOOP *******
*-
* ... Determine if non-reflecting bc housekeeping needs to be done
*-
      DO 190 I = 1,MCC
        ICON = I
        IF (IBR(ICON) .EQ. 0) GO TO 190
* ... YES I HAVE A NRB SPEC ON THIS CONTINUITY LINE, DO IT
        NODE = LINE(ICON,1)
        JJ = IABS(IBR(ICON))
*-
* ... If the IBR switch is negative use steady state solution
* ... otherwise use the value the user put on the BRA-card
*-
        IF (IBR(ICON) .LT. 0) AC3X(JJ) = WSEL(NODE)
        IBR(ICON) = IABS(IBR(ICON))
  190 CONTINUE
      ISS = 0
      IF (TMAX .LE. 0.0) GO TO 330
  800 CONTINUE
        ICYC = ICYC+1
        CALL PREHYD (2)
        THETCN = 1.0/USERCA
        IF (DELT .GT. 0.0) THEN
            ALTM = 1.0/(THETCN*3600.0*DELT)
        ELSE
            ALTM = 0.0
        ENDIF
        IF (MBAND .EQ. 1) GO TO 220
*-
* ... Project forward in time
*-
        DO 210 J = 1,NP
          DO 200 K = 1,2
             VOLD(K,J) = VEL(K,J)
             VDOTO(K,J) = VDOT(K,J)
             VEL(K,J) = VEL(K,J)+3600.0*DELT*VDOT(K,J)
  200     CONTINUE
          VOLD(3,J) = VEL(3,J)
          VDOTO(3,J) = VDOT(3,J)
          HOL(J) = HEL(J)
          HDOT(J) = HDET(J)
          IF (NDRY(J) .NE. 2) THEN
              HEL(J) = HEL(J)+3600.0*DELT*HDET(J)
              CALL AMF (HEL(J),VEL(3,J),AKP(J),ADT(J),ADB(J),D1,D2,1)
              IF (DELT .GT. 0.0) THEN
              VDOT(3,J) = ALTM*(VEL(3,J)-VOLD(3,J))-
     &                    VDOTO(3,J)*(1.0/THETCN-1.0)
          ELSE
              VDOT(3,J) = 0.0
          ENDIF
          ENDIF
  210   CONTINUE
        IF (LI .EQ. 999) THEN
           CALL ZVRS (1)
           PRINT *,' STOP because ... LI is equal to 999'
           PRINT *,' Enter any key to clear the screen'
           PAUSE
           STOP
        ENDIF
        TET = TET+DELT
        NPR = 0
  220   CONTINUE
        NPR = 1
        NITSV = 0
*-
* ... SETUP VALUES FOR TIME SOLUTION
*-
        ICT = LI
  225   FACT = 0.0
        STPCRT = USDCRT
        DO 280 NXX = 1,NITN
           NITSV = NITSV+1
           MAXN = NXX
           IF (ICT .LT. LI) GO TO 240
           IF (IPLI .EQ. 0) THEN
              IF (IDNOPT .EQ. 0) THEN
                 CALL REWET
                 CALL DEL
              ELSE
                 CALL REWETM
                 CALL DELM
              ENDIF
           ENDIF
           IF (IFLG .EQ. 2) GO TO 230
           IF (NXX .EQ. 1) GO TO 230
           IF (FACT .LT. USDCRT) GO TO 290
  230      FACT = 0.0
           ICT = 0
  240      CONTINUE
           CALL BLINE (NXX)
           CALL FLDIR
           CALL LOAD
*-
* ... Prepare cross sectional areas for stage flow computation
*-
          CALL AGEN
          CALL FRONT2
          IDP = 1
          IF (NXX .EQ. NITN) IDP = -2
          IF (ITSI .GT. 0) THEN
* ... FULL NODAL PRINT AT EVERY ITSI-th  ITERATION
              IF (MOD(NXX,ITSI) .EQ. 0) IDP = 2
          ELSEIF (ITSI .LT. 0) THEN
* ... FULL NODAL PRINT AT EVERY ITSI-th TIME STEP (LAST ITERATION)
              IF (MOD(ICYC,-ITSI) .EQ. 0 .AND. NXX .EQ. NITN) IDP = 2
          ENDIF
*-
          ICT = ICT+1
          IF (NXX .EQ. NITN .AND. ITSI .GT. 0) ICT = LI
          CALL OUTPUT (IDP)
          NPR = 0
          MBAND = 0
          DO 260 J = 1,NP
            DO 250 K = 1,NDF
              IF (DELT .GT. 0.0) THEN
                  VDOT(K,J) = ALTM*(VEL(K,J)-VOLD(K,J))-
     &                        VDOTO(K,J)*(ALTM*3600.0*DELT-1.0)
              ELSE
                  VDOT(K,J) = 0.0
              ENDIF
  250       CONTINUE
            WSEL(J) = HEL(J)+AO(J)
            HDET(J) = ALTM*(HEL(J)-HOL(J))-HDOT(J)*(1.0/THETCN-1.0)
  260     CONTINUE
*-
          IF (IHOTO .EQ. 0) GO TO 270
          IF (FACT .GE. 2.0) GO TO 270
          IREC(1) = 427
*-
* ... WRITE INTEGER type CHARACTER BANNER .. BINARY HOTSTART HYDRO
*-
          CALL CONVRT (BANRM2,15,IPACKB,80,1)
*-
          REWIND IHOTO
          MFLG = 135
          WRITE (IHOTO) MFLG,IREC(1),NP,NE
          IWRT1 = 1200
          WRITE (IHOTO) IWRT1,(IPACKB(I),I=1,IWRT1)
          IWRT2 = 40
          IWRT3 = 40
          WRITE (IHOTO) IWRT2,IWRT3,
     &                  (IREC(I),I=1,IWRT2),(FREC(I),I=1,IWRT3)
*-
          WRITE (IHOTO) TET,NP,NE,NITSV,
     &                ((VEL(J,K),J=1,3),K =1,NP),
     &                ((VDOT(J,K),J=1,3),K =1,NP),
     &                ((VOLD(J,K),J=1,3),K =1,NP),
     &                ((VDOTO(J,K),J=1,3),K =1,NP),
     &                 (NDRY(K),K = 1,NP),
     &                 (HEL(K),HOL(K),HDET(K),HDOT(K),K = 1,NP),
     &                 (IMAT(K),K = 1,NE)
  270     CONTINUE
          IF (FACT .LT. USDCRT) GO TO 290
  280   CONTINUE
  290   CONTINUE
*-
        CALL CHECK
*-
        IF (IRVIZ .GT. 0) THEN
* ... A REV-CARD HAS BEEN DETECTED
           CALL PREHYD (3)
           GO TO 225
        ENDIF
*-
        IF (IFINO .EQ. 0) GO TO 310
*-
* ... WRITE BINARY FINAL-RESULTS FILE
*-
        IF (.NOT. ONCE) THEN
* ... WRITE DMS BANNERS ON FINAL HYDRO RESULTS FIRST TIME THRU
           IREC(1) = 427
* ... WRITE INTEGER type CHARACTER BANNER .. BINARY HYDRO
           CALL CONVRT (BANRM2,15,IPACKB,80,1)
*-
           CALL CONVRT (TITLE,1,IPACKT,77,1)
              ONCE = .TRUE.
        ENDIF
*-
* ... WRITE TIME STEP INFORMATION
*-
        IWRITE = 0
        IF (NTBN .GT. 0) THEN
* ... ONLY USER SELECTED HOURS WILL BE WRITTEN
           DO 300 JJ = 1,NTBN
*              WRITE (IOUT,1331) JJ,NTBN,TBINRY(JJ),TET
              IF (ABS(TBINRY(JJ)-TET) .GT. 0.01) GO TO 300
              IWRITE = 1
  300      CONTINUE
        ELSE
* ... BY DEFAULT THE LAST ITERATION OF ALL HOURS ARE WRITTEN
           IWRITE = 1
        ENDIF
*-
*        WRITE (IOUT,1336) NTBN,IWRITE,TET,IFINO
* 1336   FORMAT (I10,' IWRITE=',I5,' TET=',F10.5,' IFINO=',I5)
        IF (IWRITE .EQ. 1) THEN
           WRITE (IFINO) TET,((VEL(J,K),J=1,2),WSEL(K),K = 1,NP),
     &                   (IMAT(JJ),JJ = 1,NE)
           DORITE = DORITE+1.0
        ENDIF
*-
  310 IF (TET .GE. TMAX) GO TO 330
      IF (NCON .GE. 2 .AND. NSTEP .LT. NCYC) RETURN
      IF (NCON .EQ. 1 .AND. ICYC .LT. NCYC) GO TO 800
      GO TO 350
  330 CALL ZVRS (1)
      IF (IOUT .GT. 0) WRITE (IOUT,340) NCYC,TMAX,TET,DORITE
  340 FORMAT (' TMAX CONTROLS PROGRAM STOP ... NCYC=',I5,'  TMAX=',
     &       F12.3,'  TET=',F14.3,//,' BINARY WRITE CONTAINS 4 ',
     &       'BANNER RECORDS AND ',F8.0,' FINAL RESULT RECORDS')
      RETURN
  350 CALL ZVRS (1)
      IF (IOUT .GT. 0) WRITE (IOUT,360) NCYC,TMAX,TET,DORITE
  360 FORMAT (/,' NCYC CONTROLS PROGRAM STOP ... NCYC=',I5,'  TMAX=',
     &       F9.3,'  TET=',F10.3,//,' BINARY WRITE CONTAINS 4 ',
     &       'BANNER RECORDS AND ',F5.0,' FINAL RESULT RECORDS')
      RETURN
      END
*-
      BLOCK DATA
*-
* ... Initialization of variables contained in common blocks
*-
      INCLUDE 'hsctm.inc'
      LOGICAL ONCE
      DATA FCOEF/14.57E0/
      DATA (IREC(I),I=1,40)/40*0/
      DATA (FREC(I),I=1,40)/40*0.0/
      DATA IBR /MCC*0/
      DATA IDMN /MND*-999/
      DATA KBCTS /0/
      DATA TGFGEN(1:20)/'                    '/
      DATA ONCE /.FALSE./
*-
      DATA WAITT/0.11250000000000D0, 0.06619707639425D0,
     &     0.06619707639425D0, 0.06619707639425D0,
     &     0.06296959027241D0, 0.06296959027241D0,
     &     0.06296959027241D0/
*-
      DATA WAITR/0.30864197530863D0, 0.49382716049379D0,
     &     0.30864197530863D0, 0.49382716049379D0,
     &     0.79012345679006D0, 0.49382716049379D0,
     &     0.30864197530863D0, 0.49382716049379D0,
     &     0.30864197530863D0/
*-
      DATA DNAR/
     &-0.0436492,0.1745967,-0.1309475,0.20,-0.3436492,1.374597,
     &-1.030947,-0.20,
     &.0436492,0.00,-0.0436492,0.20,0.3436492,0.0,
     &-0.3436492,-0.20,
     & 0.1309475,-0.1745967,0.0436492,0.20,1.030947,-1.374597,
     & 0.3436492,-0.20,
     &-0.3872983,0.7745967,-0.3872983,0.50,-0.3872983,0.7745967,
     &-0.3872983,-0.50,
     & 0.0,0.0,0.0,0.50,0.0,0.0,
     & 0.0,-0.50,
     & 0.3872983,-0.7745967,0.3872983,0.50,0.3872983,-0.7745967,
     & 0.3872983,-0.50,
     &-1.030947,1.374597,-0.3436492,0.20,-0.1309475,0.1745967,
     &-0.0436492,-0.20,
     &-0.3436492,0.0,0.3436492,0.20,-0.0436492,0.0,
     & 0.0436492,-0.20,
     & 0.3436492,-1.374597,1.030947,0.20,0.0436492,-0.1745967,
     & 0.1309475,-0.20/
*-
      DATA DNBR/
     & 0.3436492,-0.20,0.1309475,-0.1745967,0.0436492,0.20,
     & 1.030947,-1.374597,
     & 0.3872983,-0.50,0.3872983,-0.7745967,0.3872983,0.50,
     & 0.3872983,-0.7745967,
     & 0.1309475,-0.20,0.3436492,-1.374597,1.030947,0.20,
     & 0.0436492,-0.1745967,
     &-0.3436492,-0.20,0.0436492,0.0,-0.0436492,0.20,
     & 0.3436492,0.0,
     & 0.0,-0.50,0.0,0.0,0.0,0.50,
     & 0.0,0.0,
     & 0.0436492,-0.20,-0.3436492,0.0,0.3436492,0.20,
     &-0.0436492,0.0,
     &-1.030947,-0.20,-0.0436492,0.1745967,-0.1309475,0.20,
     &-0.3436492,1.374597,
     &-0.3872983,-0.50,-0.3872983,0.7745967,-0.3872983,0.50,
     &-0.3872983,0.7745967,
     &-0.0436492,-0.20,-1.030947,1.374597,-0.3436492,0.20,
     &-0.1309475,0.1745967/
*-
      DATA XNR/
     &-0.10,0.0450807,-0.032379,0.0450807,-0.10,0.3549193,
     & 0.432379,0.3549193,
     &-0.10,0.1127076,-0.10,0.20,-0.10,0.8872983,
     &-0.10,0.20,
     &-0.032379,0.0450807,-0.10,0.3549193,0.432379,0.3549193,
     &-0.10,0.0450807,
     &-0.10,0.20,-0.10,0.1127017,-0.10,0.20,
     &-0.10,0.8872983,
     &-0.25,0.50,-0.25,0.50,-0.25,0.50,
     &-0.25,0.50,
     &-0.10,0.20,-0.10,0.8872983,-0.10,0.20,
     &-0.10,0.1127017,
     & 0.432379,0.3549193,-0.10,0.0450807,-0.032379,0.0450807,
     &-0.10,0.3549193,
     &-0.10,0.8872983,-0.10,0.20,-0.10,0.1127017,
     &-0.10,0.20,
     &-0.10,0.3549193,0.432379,0.3549193,-0.10,0.0450807,
     &-0.032379,0.0450807/
*-
      DATA XMT/
     & 0.3333333,0.0,0.3333333,0.0,0.3333333,0.0,
     & 0.0597159,0.0,0.4701421,0.0,0.4701421,0.0,
     & 0.4701421,0.0,0.0597159,0.0,0.4701421,0.0,
     & 0.4701421,0.0,0.4701421,0.0,0.0597159,0.0,
     & 0.797427,0.0,0.1012865,0.0,0.1012865,0.0,
     & 0.1012865,0.0,0.797427,0.0,0.1012865,0.0,
     & 0.1012865,0.0,0.1012865,0.0,0.797427,0.0/
*-
      DATA DMAT/1.0,0.0,0.0,0.0,-1.0,0.0,1.0,0.0,0.0,
     &0.0,-1.0,0.0,1.0,0.0,0.0,0.0,-1.0,0.0,1.0,
     &0.0,0.0,0.0,-1.0,0.0,1.0,0.0,0.0,0.0,-1.0,
     &0.0,1.0,0.0,0.0,0.0,-1.0,0.0,1.0,0.0,0.0,
     &0.0,-1.0,0.0/
*-
      DATA DMBT/0.0,0.0,1.0,0.0,-1.0,0.0,0.0,0.0,
     &1.0,0.0,-1.0,0.0,0.0,0.0,1.0,0.0,-1.0,0.0,
     &0.0,0.0,1.0,0.0,-1.0,0.0,0.0,0.0,1.0,0.0,
     &-1.0,0.0,0.0,0.0,1.0,0.0,-1.0,0.0,0.0,0.0,
     &1.0,0.0,-1.0,0.0/
*-
      DATA XMR/
     & 0.1      ,0.0,0.0127017,0.0,0.1      ,0.0,0.7872983,0.0,
     & 0.0563508,0.0,0.0563508,0.0,0.4436492,0.0,0.4436492,0.0,
     & 0.0127017,0.0,0.1      ,0.0,0.7872983,0.0,0.1      ,0.0,
     & 0.4436492,0.0,0.0563508,0.0,0.0563508,0.0,0.4436492,0.0,
     & 0.25     ,0.0,0.25     ,0.0,0.25     ,0.0,0.25     ,0.0,
     & 0.0563508,0.0,0.4436492,0.0,0.4436492,0.0,0.0563508,0.0,
     & 0.7872983,0.0,0.1      ,0.0,0.0127017,0.0,0.1      ,0.0,
     & 0.4436492,0.0,0.4436492,0.0,0.0563508,0.0,0.0563508,0.0,
     & 0.1      ,0.0,0.7872983,0.0,0.1      ,0.0,0.0127017,0.0/
*-
      DATA DMAR/
     & -0.0563508,0.0,0.0563508,0.0,0.4436492,0.0,-0.4436492,0.0,
     & -0.0563508,0.0,0.0563508,0.0,0.4436492,0.0,-0.4436492,0.0,
     & -0.0563508,0.0,0.0563508,0.0,0.4436492,0.0,-0.4436492,0.0,
     & -0.25     ,0.0,0.25     ,0.0,0.25     ,0.0,-0.25     ,0.0,
     & -0.25     ,0.0,0.25     ,0.0,0.25     ,0.0,-0.25     ,0.0,
     & -0.25     ,0.0,0.25     ,0.0,0.25     ,0.0,-0.25     ,0.0,
     & -0.4436492,0.0,0.4436492,0.0,0.0563508,0.0,-0.0563508,0.0,
     & -0.4436492,0.0,0.4436492,0.0,0.0563508,0.0,-0.0563508,0.0,
     & -0.4436492,0.0,0.4436492,0.0,0.0563508,0.0,-0.0563508,0.0/
*-
      DATA DMBR/
     & -0.4436492,0.0,-0.0563508,0.0,0.0563508,0.0,0.4436492,0.0,
     & -0.25     ,0.0,-0.25     ,0.0,0.25     ,0.0,0.25     ,0.0,
     & -0.0563508,0.0,-0.4436492,0.0,0.4436492,0.0,0.0563508,0.0,
     & -0.4436492,0.0,-0.0563508,0.0,0.0563508,0.0,0.4436492,0.0,
     & -0.25     ,0.0,-0.25     ,0.0,0.25     ,0.0,0.25     ,0.0,
     & -0.0563508,0.0,-0.4436492,0.0,0.4436492,0.0,0.0563508,0.0,
     & -0.4436492,0.0,-0.0563508,0.0,0.0563508,0.0,0.4436492,0.0,
     & -0.25     ,0.0,-0.25     ,0.0,0.25     ,0.0,0.25     ,0.0,
     & -0.0563508,0.0,-0.4436492,0.0,0.4436492,0.0,0.0563508,0.0/
*-
      DATA XNT/
     &-0.1111111,0.4444444,-0.1111111,0.4444444,-0.1111111,0.4444444,
     &-0.0525839,0.1122998,-0.028075,0.8841342,-0.028075,0.1122998,
     &-0.028075,0.1122998,-0.0525839,0.1122998,-0.028075,0.8841342,
     &-0.028075,0.8841342,-0.028075,0.1122998,-0.0525839,0.1122998,
     & 0.4743526,0.3230744,-0.0807686,0.0410358,-0.0807686,0.3230744,
     &-0.0807686,0.3230744,0.4743526,0.3230744,-0.0807686,0.0410358,
     &-0.0807686,0.0410358,-0.0807686,0.3230744,0.4743526,0.3230744/
*-
       DATA DNAT/
     &0.3333333,1.333333,0.0,-1.333333,-0.3333333,0.0,
     &-0.7611365,1.880568,0.0,-1.880568,-0.8805682,1.641705,
     &0.8805682,0.2388635,0.0,-0.2388635,-0.8805682,0.0,
     &0.8805682,1.880568,0.0,-1.880568,0.7611365,-1.641705,
     &2.189708,0.4051460,0.0,-0.4051460,0.5948540,-2.784562,
     &-0.5948540,3.189708,0.0,-3.189708,0.5948540,
     &0.0,-0.5948540,0.4051460,0.0,-0.4051460,
     &-2.189708,2.784562/
*-
      DATA DNBT/
     &0.0,1.333333,0.3333333,0.0,-0.3333333,-1.333333,
     &0.0,0.2388635,0.8805682,0.0,-0.8805682,-0.2388635,
     &0.0,1.880568,-0.7611365,1.641705,-0.8805682,-1.880568,
     &0.0,1.880568,0.8805682,-1.641705,0.7611365,
     &-1.880568,0.0,3.189708,-0.5948540,0.0,0.5948540,
     &-3.189708,0.0,0.4051460,2.189708,-2.784562,0.5948540,
     &-0.4051460,0.0,0.4051460,-0.5948540,2.784562,
     &-2.189708,-0.4051460/
*-
      END
*-
      SUBROUTINE AGEN
*-
      SAVE
*-
* ... Generate specified total flow boundary conditions
*-
      INCLUDE 'hsctm.inc'
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED AGEN'
*-
* ... Calculate total projected area for all stage flow lines
*-
      DO 300 J = 1,NCL
        MAX=LMT(J)
* ... Skip if 1-d or line is not stage flow
        IF (MAX .EQ. 0) GO TO 300
*       IF (STQA(J) .EQ. 0.0 .AND.  TAREA(J) .EQ. 0.0) GO TO 300
        ALN(J)=0.0
        THET=STQT(J)
        MAX = LMT(J)-2
        DO 150 K = 1,MAX,2
          NA = LINE(J,K)
          NCQ = LINE(J,K+2)
          DX=CORD(NCQ,1)-CORD(NA,1)
          DY= -(CORD(NCQ,2)-CORD(NA,2))
          XL=SQRT(DX**2+DY**2)
          ALP=ATAN2(DX,DY)
          D1=VEL(3,NA)
          D3=VEL(3,NCQ)
          D2=(D1+D3)/2.0
          ALN(J) = ALN(J)+XL*COS(ALP-THET)*D2
  150   CONTINUE
        ALN(J)=ABS(ALN(J))
       IF (ITRACE .GE. 2) PRINT *,' ALN(',J,') = ',ALN(J)
  300 CONTINUE
*-
      RETURN
      END
*-
      SUBROUTINE AMF (H,HSIG,AKAPM,ATM,ABM,AM,DAMH,ISWT)
*-
      SAVE
*-
      IF (ISWT .EQ. 0) THEN
*-
* ... Convert HSIG to H
*-
        IF (AKAPM .GT. 0.9999) THEN
           H = HSIG
           AM = 0.0
           DAMH = 0.0
        ELSEIF (HSIG .LT. AKAPM*ABM) THEN
           H = HSIG/AKAPM
           AM = H-HSIG
           DAMH = 1.0/AKAPM-1.0
        ELSEIF (HSIG .GT. ATM-(ABM+ATM)/2.0*(1.0-AKAPM)) THEN
           H = HSIG+(1.0-AKAPM)/2.0*(ABM+ATM)
           AM = H-HSIG
           DAMH = 0.0
        ELSE
           SQ = SQRT((ATM-ABM)*(AKAPM*(AKAPM*(ATM+ABM)-2.0*ABM)
     &          +2.0*HSIG*(1.0-AKAPM)))
           H = (ABM-AKAPM*ATM+SQ)/(1.0-AKAPM)
           AM = H-HSIG
           DAMH = -1.0+(ATM-ABM)/SQ
        ENDIF
*-
* ... TEST MODIFICATION OF DERIVATIVES
*-
*       IF (HSIG .LT. 2.0+ATM-(ABM+ATM)/2.0*(1.0-AKAPM)) THEN
*         DAMH=AM/HSIG
*       ENDIF
*-
* ... END CHANGE
*-
      ELSE
*-
* ... Convert H to HSIG
*-
        IF (AKAPM .GT. 0.9999) THEN
          HSIG=H
        ELSEIF (H .LT. ABM) THEN
          HSIG=H*AKAPM
        ELSEIF (H .GT. ATM) THEN
          HSIG=AKAPM*H+(1.0-AKAPM)*((ATM-ABM)/2.0+(H-ATM))
        ELSE
          HSIG=AKAPM*H+(1.0-AKAPM)/2.0*(H-ABM)**2/(ATM-ABM)
        ENDIF
      ENDIF
*      WRITE (*,6000) H,HSIG,AKAPM,ATM,ABM,AM,DAMH
* 6000 FORMAT (7F10.3)
      RETURN
      END
*-
      SUBROUTINE BDATA
*-
      SAVE
      INCLUDE 'hsctm.inc'
*-
      COMMON /BLKC/ AFACT(4),HFACT(4),SLOAD(2),DNAL(3,4),XNAL(3,4)
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED BDATA '
*-
      NDF  = 3
      NCN  = 6
      GRAV = 32.2
      ROAVG = 1.935
      CHI  = 3.8E-06
      FACT = 1.0
      URF  = 1.000
      ALTM = 0.0
      ICYC = NSTIME
      TET  = TIM(1)
      IFLG = 1
      IRVIZ = 0
      TEMPC = 20.0
*-
      AFACT(1)=0.0694319
      AFACT(2)=0.3300095
      AFACT(3)=0.6699905
      AFACT(4)=0.9305682
      HFACT(1)=0.3478548
      HFACT(2)=0.6521451
      HFACT(3)=0.6521451
      HFACT(4)=0.3478548
      SLOAD(1)= -1.0
      SLOAD(2)= 1.0
      DNAL(1,1)= -2.7222728
      DNAL(2,1)= 3.4445456
      DNAL(3,1)= -0.7222728
      DNAL(1,2)= -1.6799620
      DNAL(2,2)= 1.3599240
      DNAL(3,2)= 0.3200380
      DNAL(1,3)= -0.3200380
      DNAL(2,3)= -1.3599240
      DNAL(3,3)= 1.6799620
      DNAL(1,4)= 0.7222728
      DNAL(2,4)= -3.4445456
      DNAL(3,4)= 2.7222728
      XNAL(1,1)= 0.80134615
      XNAL(2,1)= 0.25844410
      XNAL(3,1)= -0.05979025
      XNAL(1,2)= 0.22778404
      XNAL(2,2)= 0.88441292
      XNAL(3,2)= -0.11219696
      XNAL(1,3)= -0.11219696
      XNAL(2,3)= 0.88441292
      XNAL(3,3)= 0.22778404
      XNAL(1,4)= -0.05979025
      XNAL(2,4)= 0.25844410
      XNAL(3,4)= 0.80134615
*-
      RETURN
      END
*-
      SUBROUTINE BEEP (NHONK)
*-
* ... ROUTINE TO CAUSE YOUR TERMINAL TO BEEP - NHONK TIMES
*-
      N = NHONK
      IF (N .GT. 40) N = 40
      PRINT *,(CHAR(7),I = 1,N)
      RETURN
      END
*-
      SUBROUTINE BFORM (KK)
*-
      SAVE
*-
* ... Routine to setup boundary condtions
*-
      INCLUDE 'hsctm.inc'
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED BFORM (KK=',KK,')'
*-
* ... INITIALIZE FOR BOUNDARY CONDITIONS
*-
      IF (KK .EQ. 0) THEN
        NLA=1
        NTA=NP
      ELSE
        NLA=KK
        NTA=KK
      ENDIF
      DO 550 J = NLA,NTA
      IF (NFIX(J) .GE. 13000) GO TO 540
      IF (NFIX(J)/10000 .EQ. 1) THEN
        ALFA(J)=0.0
        VEL(1,J)=SPEC(J,1)
        IF (MOD(NFIX(J),10000)/1000 .EQ. 1) THEN
          VEL(2,J)=SPEC(J,2)
        ENDIF
      ENDIF
      IF (NFIX(J)/1000 .EQ. 0) ALFA(J)=0.0
      IF (MOD(NFIX(J)/100,10) .NE. 0) THEN
        SPCD=SPEC(J,3)-AO(J)
        CALL AMF (SPCD,SPEC(J,3),AKP(J),ADT(J),ADB(J),D1,D2,1)
      ENDIF
      GO TO 549
  540 IF (NFIX(J) .NE. 13000) GO TO 542
      SPEC(J,1)=SPEC(J,2)
      SPEC(J,2)=0.0
      ALFA(J)=0.0
      GO TO 549
  542 CONTINUE
      VT=SQRT(SPEC(J,1)**2+SPEC(J,2)**2)
      ALFA(J)=0.0
      IF (SPEC(J,1) .EQ. 0.0) THEN
        ALFA(J)=1.570796
        SPEC(J,1)=VT
        IF (SPEC(J,2) .LT. 0.0) THEN
          SPEC(J,2)= -1.57095
        ELSE
          SPEC(J,2)=1.57096
        ENDIF
      ELSE
        IF (VT .GT. 0.0) ALFA(J)=ATAN(SPEC(J,2)/SPEC(J,1))
        SPEC(J,2)=ATAN2(SPEC(J,2),SPEC(J,1))
        SPEC(J,1)=VT
      ENDIF
  549 CONTINUE
  550 CONTINUE
      RETURN
      END
*-
      SUBROUTINE BLINE (NTR)
*-
      SAVE
*-
      INCLUDE 'hsctm.inc'
*-
      COMMON /BLKC/ AFACT(4),HFACT(4),SLOAD(2),DNAL(3,4),XNAL(3,4)
*-
      DIMENSION DL(2,2),FMT(2),IFORM(MND),IOD(MND)
*-
      DATA PI2/1.570796/
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED BLINE (NTR=',NTR,')'
      IF (ITRACE .GE. 1)  PRINT *,'            commented out GO TO 240'
      IF (ITRACE .GE. 1)  PRINT 1,IRVIZ,IRVOLD,ICYC,IHGEN,NBX
    1 FORMAT (12X,'IRVIZ=',I2,' IRVOLD=',I2,' ICYC=',I4,/,12X,
     &            'IHGEN=',I2,'  NBX=',I3)
*-
      DO 180 N=1,NP
         IFORM(N)=0
         IOD(N)=0
  180 CONTINUE
*-
* ... INITIALIZE ON FIRST PASS
*-
      DO 230 N=1,NP
         NFIXK(N)=NFIX(N)
  230 CONTINUE
* ... COMPUTE BOUNDARY MID-SIDE NODES
      DO 260 N=1,NP
         IBN(N)=0
         XSLP(N)=0.0
         YSLP(N)=0.0
  260 CONTINUE
      DO 280 N=1,NE
      IF (IMAT(N) .LT. 1) GO TO 280
      NM=IMAT(N)
      IF (NM .GT. 900) GO TO 265                                         
      IF (ORT(NM,1) .EQ. 0.0) GO TO 280                                   
  265 NCN=NCORN(N)                                                      
      IF (NCN .EQ. 5 .AND. NM .LT. 900) NCN=3                          
      IF (NCN .EQ. 3 .OR. NM .GT. 900) THEN                            
        MCL=1                                                           
      ELSE                                                              
        MCL=2                                                           
      ENDIF                                                             
      DO 270 M=MCL,NCN,MCL                                              
      K=IABS(NOP(N,M))                                                  
      IF (NM .GT. 900) THEN                                              
        IBN(K)=3                                                        
      ELSE                                                              
        IF (MCL .EQ. 1) IOD(K)=1                                         
        IBN(K)=IBN(K)+1                                                 
      ENDIF                                                             
  270 CONTINUE
  280 CONTINUE
      DO 600 N=1,NE                                                     
      IF (IMAT(N) .LT. 1) GO TO 600                                      
      NM=IMAT(N)                                                        
      IF (NM .GT. 900) GO TO 600                                         
      IF (ORT(NM,1) .EQ. 0.0) GO TO 600                                   
      NCN=NCORN(N)                                                      
      IF (NCN .EQ. 5) NCN=3                                              
      DO 590 M=2,NCN,2                                                  
      N2=IABS(NOP(N,M))                                                 
*-
* ... Skip slope calculation for sides that have fixed flow or elevation
*-
      IF (IBN(N2) .EQ. 1) THEN
        IF (NFIXK(N2) .LT. 11300 .AND. NFIXK(N2) .NE. 200) THEN
          N1=IABS(NOP(N,M-1))
          N3=IABS(NOP(N,1))
          IF (M .LT. NCN) N3=IABS(NOP(N,M+1))
          H1=VEL(3,N1)
          H3=VEL(3,N3)
          IF (NCN .NE. 3) THEN                                           
            DL(1,2)=CORD(N2,1)-CORD(N1,1)                               
            DL(1,1)=CORD(N2,2)-CORD(N1,2)                               
          ELSE                                                          
            DL(1,2)=(CORD(N3,1)-CORD(N1,1))/2.0                          
            DL(1,1)=(CORD(N3,2)-CORD(N1,2))/2.0                          
          ENDIF                                                         
          DL(2,2)=CORD(N3,1)-CORD(N1,1)                                 
          DL(2,1)=CORD(N3,2)-CORD(N1,2)                                 
          IF (IFORM(N1) .EQ. 1) THEN                                     
            FMT(1)= -1.0                                                 
          ELSE                                                          
            FMT(1)=1.0                                                  
          ENDIF                                                         
          IF (IFORM(N3) .EQ. 3) THEN                                     
            FMT(2)= -1.0                                                 
          ELSE                                                          
            FMT(2)=1.0                                                  
          ENDIF                                                         
          IFORM(N1)=1                                                   
          IFORM(N3)=3                                                   
          DO 580 NG=1,4                                                 
            TEMP1=(DNAL(2,NG)*DL(1,1)+DNAL(3,NG)*DL(2,1))/2.0
            TEMP2=(DNAL(2,NG)*DL(1,2)+DNAL(3,NG)*DL(2,2))/2.0
            H=(H1+AFACT(NG)*(H3-H1))*HFACT(NG)                          
            IF (NCN .EQ. 3) H=1.0                                        
            YSLP(N1)=YSLP(N1)+TEMP1*H*XNAL(1,NG)*FMT(1)                 
            YSLP(N2)=YSLP(N2)+TEMP1*H*XNAL(2,NG)                        
            YSLP(N3)=YSLP(N3)+TEMP1*H*XNAL(3,NG)*FMT(2)                 
            XSLP(N1)=XSLP(N1)+TEMP2*H*XNAL(1,NG)*FMT(1)                 
            XSLP(N2)=XSLP(N2)+TEMP2*H*XNAL(2,NG)                        
            XSLP(N3)=XSLP(N3)+TEMP2*H*XNAL(3,NG)*FMT(2)                 
  580     CONTINUE                                                      
        ENDIF                                                           
      ENDIF                                                             
  590 CONTINUE                                                          
  600 CONTINUE                                                          
      DO 701 N=1,NP
      NFIX(N)=NFIXK(N)
*     ALFA(N)=ALFAK(N)
      IF (NFIXK(N) .EQ. 0) ALFA(N)=0.0
      IF (MOD(NFIX(N),1000) .EQ. 200) THEN
*-
* ... THESE ARE ONE-D ELEMENTS TYPE 102 012 0R 002
* ... GET ALFA AND SET FORM FOR NFIX
*-
        IF (NFIX(N) .EQ. 10200) THEN
*-
* ... SPECIAL CASE OF VERTICAL LINE RESET 102 TO 012 AND CHANGE ALFA
*-
          ALFA(N)=PI2
          NFIX(N)=01200
        ELSE
*-
          IF (XSLP(N) .LT. -0.00001 .OR. XSLP(N) .GT. 0.00001) THEN
* ... OTHERWISE SAID - XSLP IS NOT EQUAL TO 0.0
              ALFA(N)=ATAN(YSLP(N)/XSLP(N))
              NFIX(N)=01200
              IF (IECHO .GT. 1) WRITE (*,1233) N,NFIX(N),XSLP(N),YSLP(N)
 1233         FORMAT (' REVISED SPEC ON NODE=',I6,' TO=',I6,
     &                ' DUE TO XSLP=',F12.4,' YSLP=',F12.4)
          ELSE
            IF (YSLP(N) .LT. -0.00001 .OR. YSLP(N) .GT. 0.00001) THEN
*               OTHERWISE SAID - YSLP IS NOT EQUAL TO 0.0
                ALFA(N)=PI2
                NFIX(N)=01200
                IF (IECHO .GT. 1) WRITE(*,1234)N,NFIX(N),YSLP(N),XSLP(N)
 1234           FORMAT (' REVISED SPEC ON NODE=',I6,' TO=',I6,
     &                  ' DUE TO YSLP=',F12.4,'XSLP=',F12.4)
            ENDIF
          ENDIF
        ENDIF
        IF (IOD(N) .EQ. 1 .AND. NTR .GT. 0) THEN
*-                                                                      
* ... ADJUST VELOCITY COMPONENTS FOR NEW ANGLE                     
*-                                                                      
          IF (VEL(1,N) .EQ. 0.0) ALOLD=PI2                                
          IF (VEL(1,N) .NE. 0.0) ALOLD=ATAN(VEL(2,N)/VEL(1,N))            
          IF (ABS(ALFA(N)-ALOLD) .GT. PI2 .AND.                        
     &       ABS(ALFA(N)-ALOLD) .LT. 3.0*PI2) ALOLD=ALOLD+2.0*PI2         
          CSX=COS(ALOLD)                                                
          SSX=SIN(ALOLD)                                                
          CSN=COS(ALFA(N))                                              
          SSN=SIN(ALFA(N))                                              
          VT=VEL(1,N)*CSX+VEL(2,N)*SSX                                  
          VEL(1,N)=VT*CSN                                               
          VEL(2,N)=VT*SSN                                               
          VT=VOLD(1,N)*CSX+VOLD(2,N)*SSX                                
          VOLD(1,N)=VT*CSN                                              
          VOLD(2,N)=VT*SSN                                              
          VT=VDOT(1,N)*CSX+VDOT(2,N)*SSX
          VDOT(1,N)=VT*CSN
          VDOT(2,N)=VT*SSN                                              
          VT=VDOTO(1,N)*CSX+VDOTO(2,N)*SSX                              
          VDOTO(1,N)=VT*CSN                                             
          VDOTO(2,N)=VT*SSN                                             
        ENDIF                                                           
*-
      ELSE
         IF (NFIX(N) .LE. 10000) GO TO 610
         IF (IOD(N) .EQ. 0) GO TO 700
*-
* ... ONLY ONE-D LEFT  NFIX = 11 OR 31
*-
        IF (NFIX(N) .GT. 11000) THEN
*          ALFA(N)=ALFAK(N)
          GO TO 630
        ELSE
          ALFA(N)=0.0
          GO TO 700
        ENDIF
  610   CONTINUE
        IF (ALFAK(N) .NE. 0.0) THEN
          ALFA(N)=ALFAK(N)
        ELSEIF (XSLP(N) .NE. 0.0) THEN
          ALFA(N)=ATAN(YSLP(N)/XSLP(N))
        ELSE
          IF (YSLP(N) .EQ. 0.0) GO TO 700
          ALFA(N)=PI2
        ENDIF
        NFIX(N)=01000
  630   CONTINUE
        IF (NTR .GT. 0) THEN
          IF (VEL(1,N) .EQ. 0.0) ALOLD=PI2
          IF (VEL(1,N) .NE. 0.0) ALOLD=ATAN(VEL(2,N)/VEL(1,N))
          IF (ABS(ALFA(N)-ALOLD) .GT. PI2 .AND.
     &       ABS(ALFA(N)-ALOLD) .LT. 3.0*PI2) ALOLD=ALOLD+2.0*PI2
          CSX=COS(ALOLD)                                                
          SSX=SIN(ALOLD)                                                
          CSN=COS(ALFA(N))                                              
          SSN=SIN(ALFA(N))                                              
          VT=VEL(1,N)*CSX+VEL(2,N)*SSX                                  
          VEL(1,N)=VT*CSN                                               
          VEL(2,N)=VT*SSN                                               
          VT=VOLD(1,N)*CSX+VOLD(2,N)*SSX                                
          VOLD(1,N)=VT*CSN                                              
          VOLD(2,N)=VT*SSN                                              
          VT=VDOT(1,N)*CSX+VDOT(2,N)*SSX                                
          VDOT(1,N)=VT*CSN                                              
          VDOT(2,N)=VT*SSN                                              
          VT=VDOTO(1,N)*CSX+VDOTO(2,N)*SSX                              
          VDOTO(1,N)=VT*CSN                                             
          VDOTO(2,N)=VT*SSN                                             
        ENDIF
        IF (NFIX(N) .EQ. 10000) ALFA(N)=0.0
  700 CONTINUE
      ENDIF
  701 CONTINUE
  720 CONTINUE
*-
* ... Set forced value of ALFA from ALFAK
*-
      DO 730 N=1,NP
        ADIF(N)=0.0
        IF (ALFAK(N) .NE. 0.0) ALFA(N)=ALFAK(N)
  730 CONTINUE
*-
* ... EXAMINE FOR CASE WHERE 1-D CHANNEL FORMS DEAD END
*-
      DO 750 M=1,NE
        IF (IMAT(M) .GT. 0) THEN
          IF (IMAT(M) .LT. 900 .AND. NCORN(M) .EQ. 3) THEN
            DO 740 L=1,NCORN(M),2
              N=NOP(M,L)
              IF (IBN(N) .EQ. 1) THEN
                IF (NFIX(N) .EQ. 01000) THEN
                  NFIX(N)=11000
                  WRITE (*,6010) N
                  IF (IOUT .GT. 0) WRITE (IOUT,6010) N
 6010             FORMAT ('  NODE',I5,
     &                    ' FORMS DEAD END WITHOUT NFIX = 11000')
                ENDIF
              ENDIF
  740       CONTINUE
          ENDIF
        ENDIF
  750 CONTINUE
*-
* ... Adjust directions when specified flow would reverse
*-
      IF (NTR .GT. 0) THEN
        DO 760 N=1,NP
          IF (NFIX(N)/1000 .EQ. 31) THEN
           IF (ABS(ALFA(N)-SPEC(N,2)) .GT. 1.570796 .AND.             
     &        ABS(ALFA(N)-SPEC(N,2)) .LT. 4.713388) THEN              
              SPEC(N,1)= -SPEC(N,1)                                      
              IF (ALFA(N) .GT. SPEC(N,2)) THEN                           
                 SPEC(N,2)=SPEC(N,2)+3.141592                            
              ELSE                                                      
                 SPEC(N,2)=SPEC(N,2)-3.141592                            
              ENDIF                                                     
           ENDIF                                                        
          ENDIF                                                         
  760   CONTINUE
      ENDIF
*-
* ... Compute angular difference at 1D - 2D junctions
*-
      DO 800 N=1,NE                                                     
        IF (NCORN(N) .EQ. 5 .AND. IMAT(N) .LT. 901) THEN               
          N1=IABS(NOP(N,3))                                             
          N2=IABS(NOP(N,4))                                             
          N3=IABS(NOP(N,5))                                             
          ADIF(N2)=ALFA(N2)-ALFA(N1)                                    
          IF (ADIF(N2) .GT. PI2) THEN                                    
            ALFA(N2)=ALFA(N2)-2.0*PI2                                    
            ADIF(N2)=ALFA(N2)-ALFA(N1)                                  
          ELSEIF (ADIF(N2) .LT. -PI2) THEN                               
            ALFA(N2)=ALFA(N2)+2.0*PI2                                    
            ADIF(N2)=ALFA(N2)-ALFA(N1)                                  
          ENDIF                                                         
          ADIF(N3)=ALFA(N3)-ALFA(N1)                                    
          IF (ADIF(N3) .GT. PI2) THEN                                    
            ALFA(N3)=ALFA(N3)-2.0*PI2                                    
            ADIF(N3)=ALFA(N3)-ALFA(N1)                                  
          ELSEIF (ADIF(N3) .LT. -PI2) THEN                               
            ALFA(N3)=ALFA(N3)+2.0*PI2                                    
            ADIF(N3)=ALFA(N3)-ALFA(N1)                                  
          ENDIF                                                         
          IF (IECHO .GT. 1)                                                
     &    PRINT *,' SETTING ADIF ',N1,N2,N3,ADIF(N2),ADIF(N3)           
        ENDIF                                                           
  800 CONTINUE
      RETURN
      END
*-
      SUBROUTINE CHECK
*-
      SAVE
*-
      INCLUDE 'hsctm.inc'
*-
      DIMENSION ITEMP(MCCN)
      DATA NCALL/0/
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED CHECK. NCL LINES=',NCL
*-
      IF (NCL .LE. 0) RETURN
      IF (NCALL .GT. 0) GO TO 140
      NCALL = 1
*-
*     Augment continuity lists
*-
      DO 125 J = 1,NCL
        M = LMT(J)
        IF (M .GT. 2*MCCN) PRINT *,' ARRAY OVER-RUN IN SUB CHECK'
        DO 113 K = 1,M
           ITEMP(K) = LINE(J,K)
  113   CONTINUE
        LMT(J) = 2*LMT(J)-1
        NN = LMT(J)
        N = 0
        IF (M .EQ. 1) GO TO 125
        DO 124 L = 1,NN,2
           N = N+1
           NA = ITEMP(N)
           NCQ = ITEMP(N+1)
           LINE(J,L) = NA
           LINE(J,L+2) = NCQ
           DO 123 JJ = 1,NE
              IF (IMAT(JJ) .EQ. 0) GO TO 123
              NCN=NCORN(JJ)
              DO 117 KK = 1,NCN,2
                 KKK = MOD(KK+2,NCN)
                 IF (KKK .EQ. 0) KKK=3
                 N1 = IABS(NOP(JJ,KK))
                 N2 = IABS(NOP(JJ,KKK))
                 IF (NA .EQ. N1 .AND. NCQ .EQ. N2) GO TO 115
                 IF (NCQ .EQ. N1 .AND. NA .EQ. N2) GO TO 115
                 GO TO 117
  115            LINE(J,L+1) = IABS(NOP(JJ,KK+1))
                 GO TO 124
  117         CONTINUE
  123      CONTINUE
  124   CONTINUE
  125 CONTINUE
      IF (NB .EQ. 0) RETURN
  140 CONTINUE
      IF (IOUT .GT. 0) WRITE (IOUT,6030) ICYC,NITSV
      ND = NB
      DO 180 J = 1,NCL
        SUMX = 0.0
        SUMY = 0.0
        IF (LMT(J) .EQ. 1) THEN
           NA=LINE(J,1)
           SUMX = SQRT(VEL(1,NA)**2+VEL(2,NA)**2)*VEL(3,NA)*
     &           (2.0*WIDTH(NA)+(SS1(NA)+SS2(NA))*VEL(3,NA))/2.0
        ELSE
          MAX = LMT(J)-2
          DO 150 K = 1,MAX,2
            NA = LINE(J,K)
            NB = LINE(J,K+1)
            NCQ = LINE(J,K+2)
            DX=(CORD(NCQ,1)-CORD(NA,1))/6.0
            DY=(CORD(NCQ,2)-CORD(NA,2))/6.0
            D1=VEL(3,NA)
            D3=VEL(3,NCQ)
            D2=(D1+D3)/2.0
            SUMX = SUMX+DY*(VEL(1,NA)*D1+4.0*VEL(1,NB)*D2+VEL(1,NCQ)*D3)
            SUMY = SUMY+DX*(VEL(2,NA)*D1+4.0*VEL(2,NB)*D2+VEL(2,NCQ)*D3)
  150     CONTINUE
        ENDIF
        TOTAL = SUMX-SUMY
        IF (J .EQ. 1) REF = TOTAL
        IF (ABS(REF) .LT. 0.0001) REF=1.0
        PCT = 100.0*TOTAL/REF
        IF (IOUT .GT. 0) WRITE (IOUT,6035) J,TOTAL,SUMX,SUMY,PCT
  180 CONTINUE
      NB = ND
      RETURN
 6030 FORMAT (// ' **',7X,'CONTINUITY CHECKS    ',
     &         ' TIME STEP =',I5,'    ITER CYCLE =',I4,
     &     // ' **',7X,'LINE',10X,'TOTAL',8X,' X-FLOW',8X,' Y-FLOW',
     &        4X,' PERCENT')
 6035 FORMAT (' ++',7X,I4,1P3E15.3,0PF10.1)
      END
*-
      SUBROUTINE COEF1 (NN,NTX)
      SAVE
*-
      INCLUDE 'hsctm.inc'
*-
      COMMON /BLKC/ AFACT(4),HFACT(4),SLOAD(2),DNAL(3,4),XNAL(3,4)
*-
      COMMON XN(3),DNX(3),DNY(3),XM(2),DMX(2),DMY(2),XL(3),
     &     YL(3),VX(3),VY(3),VDX(3),VDY(3),QFACT(3),
     &     QQFACT(3),AME(4),DAME(4)
*-
      IF (ITRACE .GE. 2)
     &          PRINT *,' =+= CALLED COEF1 (NN,NTX=', NN, NTX, ')'
*-
* ... ASSIGN PROPER COEFFICIENTS
*-
      TEL = XAREA(NN)
      XAREA(NN) = 0.0
      NCN = NCORN(NN)
      IF (NCN .EQ. 5 .AND. IMAT(NN) .LT. 901) NCN = 3
      NCNX = 2
*-
* ... INITIALIZE MATRICES AND VARIABLES
*-
      NEF = NCN*NDF
      DO 100 I = 1,NEF
         Z(I) = 0.0
         DO 100 J = 1,NEF
  100 ESTIFN(I,J) = 0.0
      IF (IMAT(NN) .GT. 900) GO TO 380
      DO 110 M = 1,NCNX
        MC = 2*M-1
        N = NOP(NN,MC)
        HS = VEL(3,N)
        CALL AMF (H,HS,AKP(N),ADT(N),ADB(N),AME(M),DAME(M),0)
  110 CONTINUE
      MR = IMAT(NN)
      CXX = COS(TH(NN))
      SAA = SIN(TH(NN))
      ROAVG = (DEN(NOP(NN,1))+DEN(NOP(NN,3)))/2.0
      IF (NTX .EQ. 0) GO TO 120
      EPSX = ORT(MR,1)/ROAVG
      FFACT = 0.0
      IF (CHEZ(NN) .GT. 0.0) FFACT = GRAV/CHEZ(NN)**2
  120 CONTINUE
      NGP = 4
      NCNX = 2
*-
* ... COMPUTE LOCAL CORDS
*-
      NR = IABS(NOP(NN,1))                                              
      DO 130 K = 1,NCN                                                 
         N = IABS(NOP(NN,K))                                             
         ANGDIF = TH(NN)-ALFA(N)                                       
         IF (ABS(ANGDIF) .GT. 1.570798 .AND. ABS(ANGDIF) .LT.            
     &       4.712394) THEN                                             
            QFACT(K) = -1.0                                             
            QQFACT(K) = -1.0                                            
         ELSE                                                            
            QFACT(K) = 1.0                                                
            QQFACT(K) = 1.0                                               
         ENDIF                                                          
         DX = CORD(N,1)-CORD(NR,1)                                     
         DY = CORD(N,2)-CORD(NR,2)                                     
         XL(K) = DX*CXX+DY*SAA                                     
         YL(K) = -DX*SAA+DY*CXX
  130 CONTINUE
*-
* ... COMPUTE ELEMENT EQUATIONS
*-
      TFR = TEL/ABS(XL(3))
      IF (NTX .NE. 0) XL(2) = XL(3)/2.0
      DO 310 I = 1,NGP
        TEMP = (DNAL(2,I)*XL(2)+DNAL(3,I)*XL(3))
*-
* ... DEFINE SHAPE FUNCTIONS
*-
        XN(1) = (1.0-AFACT(I))*(1.0-2.0*AFACT(I))
        XN(2) = (1.0-AFACT(I))*4.0*AFACT(I)
        XN(3) = (2.0*AFACT(I)-1.0)*AFACT(I)
        DNX(1) = (4.0*AFACT(I)-3.0)/TEMP
        DNX(2) = (4.0-8.0*AFACT(I))/TEMP
        DNX(3) = (4.0*AFACT(I)-1.0)/TEMP
        IF (NTX .EQ. 0) THEN
           DYDX = YL(2)*DNX(2)+YL(3)*DNX(3)
           ALF = ATAN(DYDX)
           CSALF = COS(ALF)
           TEMP = TEMP/CSALF
        ELSE
           TEMP = TEMP*TFR
        ENDIF
        IF (NTX .NE. 0) THEN
           DO 150 J = 1,3
              DNX(J) = DNX(J)/TFR
  150      CONTINUE
        ENDIF
        XM(1) = 1.0-AFACT(I)
        XM(2) = AFACT(I)
        DMX(1) = -1.0/TEMP
        DMX(2) = 1.0/TEMP
        N1 = IABS(NOP(NN,1))
        N2 = IABS(NOP(NN,3))
        WID = WIDTH(N1)*XM(1)+WIDTH(N2)*XM(2)
        WIDSTR = WIDS(N1)*XM(1)+WIDS(N2)*XM(2)
        SSLOP = XM(1)*(SS1(N1)+SS2(N1))+XM(2)*
     &          (SS1(N2)+SS2(N2))
        DWIDX = (WIDTH(N2)-WIDTH(N1))/TEMP
        DSLOX = (SS1(N2)+SS2(N2)-SS1(N1)-SS2(N1))/TEMP
        IF (NTX .NE. 0) THEN
           H = VEL(3,N1)*XM(1)+VEL(3,N2)*XM(2)
        ELSE
           H = 1.0
        ENDIF
        AMW = ABS(TEMP)*HFACT(I)/2.0
        XAREA(NN) = XAREA(NN)+AMW
        IF (NTX .EQ. 0) GO TO 310
*-
* ... COMPUTE R AND H AND THEIR DERIVATIVES
*-
        R = 0.0
        DRDX = 0.0
        BETA1 = 0.0
*-
* ... ESTABLISH VELOCITIES
*-
        DO 160 M = 1,NCN
           MR = IABS(NOP(NN,M))
           VX(M) = VEL(1,MR)
           VY(M) = VEL(2,MR)
           VDX(M) = VDOT(1,MR)
           VDY(M) = VDOT(2,MR)
  160   CONTINUE
        DO 170 M = 1,NCN
           MR = IABS(NOP(NN,M))
           ANGDIF = TH(NN)-ALFA(MR)
           CX = COS(ALFA(MR))
           SA = SIN(ALFA(MR))
           R = R+XN(M)*(VX(M)*CX+VY(M)*SA)*QFACT(M)
           DRDX = DRDX+DNX(M)*(VX(M)*CX+VY(M)*SA)*QFACT(M)
           IF (DELT .GT. 0.0) THEN
              BETA1 = BETA1+XN(M)*(VDX(M)*CX+VDY(M)*SA)*QFACT(M)
           ENDIF
  170   CONTINUE
        DHDX   = 0.0
        DAODX  = 0.0
        DRODX  = 0.0
        DAODXH = 0.0
        SIGMAX = 0.0
        BETA3  = 0.0
        DO 180 M = 1,NCNX
           MC = 2*M-1
           MR = IABS(NOP(NN,MC))
           BETA3 = BETA3+XM(M)*VDOT(3,MR)
           DHDX = DHDX+DMX(M)*VEL(3,MR)
           DAODX = DAODX+DMX(M)*(AME(M)+AO(MR))
           DRODX = DRODX+DMX(M)*DEN(MR)
           DAODXH = DAODXH+DMX(M)*DAME(M)
           SIGMAX = SIGMAX+XM(M)*(SIGMA(MR,1)*CXX+SIGMA(MR,2)*SAA)
  180   CONTINUE
        WSRF = WID+SSLOP*H
        WTOT = WSRF+WIDSTR
        DACR = H*DWIDX+H**2/2.0*DSLOX+DHDX*WSRF
        ACR = H*(WSRF+WID)*0.5
        NTYP = IMAT(NN)
        TVOL(NTYP) = TVOL(NTYP)+ACR*AMW
        SIGMAX = SIGMAX/ROAVG
        VECQ = ABS(R)
        IF (H .LE. 0.0) H = 0.001
        IF (ZMANN(NN) .GT. 0.0) FFACT = ZMANN(NN)**2*FCOEF/(H**0.333)
        TFRIC = 0.0
        IF (VECQ .GT. 1.0E-6) TFRIC = FFACT
        FRN = 0.0
        IF (DELT .GT. 0.0) THEN
           FRN = ACR*BETA1
        ENDIF
*-
* ... EVALUATE THE BASIC EQUATIONS WITH PRESENT VALUES
*-
* ... MOMENTUM TERMS
*-
  190   FRN = FRN+ACR*R*DRDX+SIDF(NN)*R
*-
* ... VISCOUS TERMS
*-
        FRN = FRN+EPSX*DRDX*DACR
        FRNX = EPSX*DRDX*ACR
*-
* ... SURFACE AND BOTTOM SLOPE (PRESSURE) TERMS
*-
        FRN = FRN+GRAV*((DAODX+H*DRODX/ROAVG)*ACR-H**
     &        2/2.0*(DWIDX+DSLOX*H/2.0+SSLOP*0.5*DHDX))
        FRNX = FRNX-GRAV*ACR*H/2.0
*-
* ... BOTTOM FRICTION TERMS
*-
        FRN = FRN+FFACT*VECQ*R*(WID+SSLOP/2.0*H)
*-
* ... WIND TERMS
*-
        FRN = FRN-SIGMAX*(WID+SSLOP/2.0*H)
*-
* ... MOTION EQUATIONS
*-
        IA = 1-NDF
        DO 200 M = 1,NCN
           IA = IA+NDF
           Z(IA) = Z(IA)-AMW*(XN(M)*FRN+DNX(M)*FRNX)*QFACT(M)
  200   CONTINUE
*-
* ... CONTINUITY EQUATION
*-
        FRNC = ACR*DRDX+DACR*R-SIDF(NN)
        IF (DELT .GT. 0.0) THEN
           FRNC = FRNC+BETA3*WTOT
        ENDIF
        DO 210 M = 1,NCNX
           IA = 3+2*NDF*(M-1)
           Z(IA) = Z(IA)-AMW*XM(M)*FRNC
  210   CONTINUE
*-
* ... FORM THE X MOTION EQUATIONS
*-
* ... FLOW TERMS
*-
* ... INERTIAL COMPONENTS
*-
        T1 = AMW*((H*DRDX+TFRIC*2.0*VECQ)*(WID+SSLOP/2.0*H)+
     &       SIDF(NN))
        T2 = AMW*(ACR*R+EPSX*DACR)
        T5 = AMW*EPSX*ACR
        IB = 1-NDF
        DO 240 N = 1,NCN
           IB = IB+NDF
           FEEAN = (XN(N)*T1+DNX(N)*T2)*QQFACT(N)
           FEEBN = T5*DNX(N)*QQFACT(N)
*-
*- ... FORM THE TIME TERMS
*-
           IF (DELT .GT. 0.0) THEN
              FEEAN = FEEAN+AMW*XN(N)*ACR*ALTM*QQFACT(N)
           ENDIF
  220      CONTINUE
           IA = 1-NDF
           DO 230 M = 1,NCN
              IA = IA+NDF
              ESTIFN(IA,IB) = ESTIFN(IA,IB)+(XN(M)*FEEAN+
     &                        DNX(M)*FEEBN)*QFACT(M)
  230      CONTINUE
  240   CONTINUE
*-
* ... FORM THE HEAD TERMS
*-
        T1 = AMW*((R*DRDX+GRAV*DAODX)*WSRF+SSLOP/2.0*
     &       TFRIC*VECQ*R-GRAV*(H*DWIDX+0.75*H**2
     &       *DSLOX+DHDX*0.5*SSLOP*H)+EPSX*DRDX*
     &       (DWIDX+H*DSLOX+SSLOP*DHDX))
        T2 = AMW*(DRDX*EPSX*WSRF-0.25*GRAV*SSLOP*H**2)
        T4 = AMW*(EPSX*DRDX*WSRF-GRAV*(WID*H+0.75*
     &       SSLOP*H**2))
        IB = 3-2*NDF
        DO 270 N = 1,NCNX
           IB = IB+2*NDF
           FEEAN = XM(N)*T1+DMX(N)*(T2+ACR*GRAV*DAME(N))
           FEEBN = XM(N)*T4
*-
* ... FORM THE TIME TERMS
*-
           IF (DELT .GT. 0.0) THEN
              FEEAN = FEEAN+AMW*XM(N)*BETA1*WSRF
           ENDIF
  250      CONTINUE
           IA = 1-NDF
           DO 260 M = 1,NCN
              IA = IA+NDF
              ESTIFN(IA,IB) = ESTIFN(IA,IB)+(XN(M)*FEEAN+
     &                        DNX(M)*FEEBN)*QFACT(M)
  260      CONTINUE
  270   CONTINUE
*-
* ... FORM THE CONTINUITY EQUATIONS
*-
        TA4 = AMW*ACR
        TX = AMW*DACR
        TB = AMW*(DRDX*(WID+SSLOP*H)+R*(DWIDX+H*
     &       DSLOX+SSLOP*DHDX))
        TCQ = AMW*R*(WID+SSLOP*H)
        IF (DELT .GT. 0.0) THEN
          TB = TB+AMW*(ALTM*WSRF+BETA3*SSLOP)+AMW*
     &         ALTM*WIDSTR
        ENDIF
        IA = 3-2*NDF
        DO 300 M = 1,NCNX
          IA = IA+2*NDF
          IB = 1-NDF
          EA = XM(M)*TA4
          EB = XM(M)*TX
          DO 280 N = 1,NCN
            IB = IB+NDF
            ESTIFN(IA,IB) = ESTIFN(IA,IB)+(EA*DNX(N)+EB*
     &           XN(N))*QQFACT(N)
  280     CONTINUE
          EA = XM(M)*TB
          EB = XM(M)*TCQ
          IB = 3-2*NDF
          DO 290 N = 1,NCNX
            IB = IB+2*NDF
            ESTIFN(IA,IB) = ESTIFN(IA,IB)+XM(N)*EA+DMX(N)*EB
  290     CONTINUE
  300   CONTINUE
*-
* ... END GAUSS DO LOOP
*-
  310 CONTINUE
      IF (NTX .EQ. 0) RETURN
*-
* ... Compute boundary forces
*-
      DO 330 L = 1,NCN,2
        N1 = IABS(NOP(NN,L))
        IF (MOD(NFIX(N1)/100,10) .EQ. 2) THEN
          NA = (L-1)*NDF+1
          PPL = QFACT(L)*GRAV*(WIDTH(N1)+(SS1(N1)+
     &         SS2(N1))*SPEC(N1,3)/2.0)
          IF (L .EQ. 1) PPL = -PPL
          Z(NA) = Z(NA)-PPL*(SPEC(N1,3)-VEL(3,N1)/2.0)*
     &         SPEC(N1,3)
          ESTIFN(NA,NA+2) = ESTIFN(NA,NA+2)-PPL*SPEC(N1,3)/2.0
        ELSEIF (IBN(N1) .EQ. 1 .OR. IBN(N1) .GE. 3) THEN
          NA = (L-1)*NDF+1
          DO 320 KK = 1,NEF
             ESTIFN(NA,KK) = 0.0
  320     CONTINUE
          Z(NA) = 0.0
        ENDIF
  330 CONTINUE
*-
* ... Insert boundary flows
*-
      DO 350 N = 1,NCN
        M = IABS(NOP(NN,N))
*-
* ... Test for and then retrieve stage flow constants
*-
        IF (ISTLIN(M) .NE. 0) THEN
          JJ  = ISTLIN(M)
          AC1 = STQ(JJ)
          AC2 = STQA(JJ)
          E0  = STQE(JJ)
          CP  = STQC(JJ)
          ATH = STQT(JJ)
          TAR = TAREA(JJ)
          IF (ITRACE .GE. 2) THEN
              PRINT *,' ==== Debug DO 350 COEF1 ==='
              PRINT *,' LINE JJ= ',JJ,' AC1= ',AC1,' AC2= ',AC2,
     &                 ' E0= ',E0
              PRINT *,' CP=',CP,' ATH= ',ATH,' ALFA(M) = ',ALFA(M)
          ENDIF
        ELSE
          AC2 = 0.0E0
        ENDIF
        IF (NFIX(M)/1000 .LT. 13) GO TO 350
        IRW = (N-1)*NDF+1
        IRH = IRW+2
        CX = COS(ALFA(M))
        SA = SIN(ALFA(M))
        VT = VEL(1,M)*CX+VEL(2,M)*SA
        AWIDT = (WIDTH(M)*2.0+(SS1(M)+SS2(M))*VEL(3,M))/2.0
        DO 340 J = 1,NEF
           ESTIFN(IRW,J) = 0.0E0
  340   CONTINUE
        ESTIFN(IRW,IRW) = XAREA(NN)*VEL(3,M)*AWIDT
        ESTIFN(IRW,IRH) = XAREA(NN)*VT*(WIDTH(M)+(SS1(M)+
     &       SS2(M))*VEL(3,M))
        Z(IRW) = XAREA(NN)*(SPEC(M,1)-AWIDT*VT*VEL(3,M))
        IF (AC2 .NE. 0.0 .OR. TAR .NE. 0.0E0) THEN
          XCHK = HEL(M)+AO(M)-E0
          IF (ABS(XCHK) .LE. 0.01E0) AC2 = 0.0E0
          XSGN = SIGN(1.0,XCHK)*COS(ALFA(M)-ATH)
* ... VARIABLE IGO IS A SWITCH FOR NON-REFLECTING BC VIA BRL CARD
* ... WHERE ISS = 1 STEADY STATE, IBR()=+N IF NRB SPEC, ELSE 0
          ICON = ISTLIN(M)
          IBR2 = 0
          IF (ICON .GT. 0) THEN
             IF (IABS(IBR(ICON)) .GT. 0) IBR2 = 1
          ENDIF
          IGO = (1-ISS*IBR2)
          IF (ITRACE .GE. 2) PRINT *,' DEBUG IN COEF1 - VALUES ',
     &                     'IGO-ISS-ICON-M ',IGO,ISS,ICON,M
          IF (ABS(CP-1.0) .LT. 0.01) THEN
            ESTIFN(IRW,IRH) = ESTIFN(IRW,IRH) - XAREA(NN)*AC2*
     &                        COS(ALFA(M) - ATH)*IGO
            TSGN = SIGN(1.0,COS(ALFA(M)-ATH))
            ESTIFN(IRW,IRH) = ESTIFN(IRW,IRH) - XAREA(NN)*TAR*TSGN
     &                        *ALTM*IGO
            Z(IRW) = Z(IRW)+XAREA(NN)*AC2*XSGN*ABS(XCHK)*IGO
            Z(IRW) = Z(IRW)-XAREA(NN)*TAR*TSGN*(ALTM*
     &               (VEL(3,M)-VOLD(3,M))-(ALTM*3600.0*DELT-1.0)
     &               *VDOTO(3,M))*IGO
          ELSE
            ESTIFN(IRW,IRH) = ESTIFN(IRW,IRH)-XAREA(NN)*
     &               (AC2*CP*(ABS(XCHK))**(CP-1.0))*IGO
            Z(IRW) = Z(IRW)+XAREA(NN)*AC2*XSGN*
     &               (ABS(XCHK))**CP*IGO
          ENDIF
        ENDIF
  350 CONTINUE
  360 CONTINUE
      DO 370 I = 1,NCN
        J = IABS(NOP(NN,I))
        IA = NDF*(I-1)
        DO 370 K = 1,NDF
          IA = IA+1
          JA = NBC(J,K)
          IF (JA .EQ. 0) GO TO 370
          R1(JA) = R1(JA)+Z(IA)
  370 CONTINUE
      RETURN
  380 CONTINUE
*-
* ... Special cases for control structures or junction sources
*-
      IF (IMAT(NN) .GT. 903) THEN
        CALL CSTRC (NN)
        GO TO 360
      ENDIF
*-
* ... Special cases for junction element
*-
      NCN = NCORN(NN)
      Z(1) = 0.0
      DO 390 KK = 1,NCN
        N1 = IABS(NOP(NN,KK))
        IF (N1 .EQ. 0) GO TO 390
        NA = (KK-1)*NDF+1
        ESTIFN(1,NA) = DIR(N1)*(WIDTH(N1)+(SS1(N1)+
     &       SS2(N1))/2.0*VEL(3,N1))*VEL(3,N1)
        CX = COS(ALFA(N1))
        SA = SIN(ALFA(N1))
        R = VEL(1,N1)*CX+VEL(2,N1)*SA
        ESTIFN(1,NA+2) = DIR(N1)*(WIDTH(N1)+(SS1(N1)+
     &       SS2(N1))*VEL(3,N1))*R
        Z(1) = Z(1)-ESTIFN(1,NA)*R
  390 CONTINUE
      IF (IMAT(NN) .EQ. 903) THEN
*-
* ... Develop momentum boundary conditions
*-
        NRX = IABS(NOP(NN,1))
        NRY = IABS(NOP(NN,2))
        WSX = WIDTH(NRX)+VEL(3,NRX)*(SS1(NRX)+SS2(NRX))
        WSY = WIDTH(NRY)+VEL(3,NRY)*(SS1(NRY)+SS2(NRY))
        ACX = (WIDTH(NRX)+WSX)*VEL(3,NRX)/2.0
        ACY = (WIDTH(NRY)+WSY)*VEL(3,NRY)/2.0
        RX = VEL(1,NRX)*COS(ALFA(NRX))+VEL(2,NRX)*
     &       SIN(ALFA(NRX))
        RY = VEL(1,NRY)*COS(ALFA(NRY))+VEL(2,NRY)*
     &       SIN(ALFA(NRY))
        Z(4) = -ACX*RX**2+ACY*RY**2-GRAV*ACX*
     &       VEL(3,NRX)+GRAV*ACY*VEL(3,NRY)
        ESTIFN(4,1) = ACX*RX*2.0
        ESTIFN(4,4) = -ACY*RY*2.0
        ESTIFN(4,3) = WSX*RX**2+GRAV*VEL(3,NRX)*
     &       WIDTH(NRX)*2.0
        ESTIFN(4,6) = -WSY*RY**2-GRAV*VEL(3,NRY)*
     &       WIDTH(NRY)*2.0
        DO 400 KK = 3,NCN
          N1 = IABS(NOP(NN,KK))
          IF (N1 .EQ. 0) GO TO 400
          NA = (KK-1)*NDF+1
          ESTIFN(NA,3) = 0.5
          ESTIFN(NA,6) = 0.5
          ESTIFN(NA,NA+2) = -1.0
          Z(NA) = VEL(3,N1)-(VEL(3,NRX)+VEL(3,NRY))/2.0+
     &            AO(N1)-(AO(NRX)+AO(NRY))/2.0
  400   CONTINUE
      ELSEIF (IMAT(NN) .EQ. 902) THEN
*-
* ... Equal total head condition
*-
        NRX = IABS(NOP(NN,1))
        RX = VEL(1,NRX)*COS(ALFA(NRX))+VEL(2,NRX)*
     &       SIN(ALFA(NRX))
        THN = HEL(NRX)+AO(NRX)+RX**2/(2.0*GRAV)
        DO 410 KK = 2,NCN
          N1 = IABS(NOP(NN,KK))
          IF (N1 .EQ. 0) GO TO 410
          RY = VEL(1,N1)*COS(ALFA(N1))+VEL(2,N1)*
     &         SIN(ALFA(N1))
          TH1 = HEL(N1)+AO(N1)+RY**2/(2.0*GRAV)
          NA = (KK-1)*NDF+1
          ESTIFN(NA,1) = RX/GRAV
          ESTIFN(NA,3) = 1.0
          ESTIFN(NA,NA) = -RY/GRAV
          ESTIFN(NA,NA+2) = -1.0
          Z(NA) = TH1-THN
  410   CONTINUE
      ELSE
*-
* ... Equal elevation condition
*-
        NRX = IABS(NOP(NN,1))
        DO 420 KK = 2,NCN
          N1 = IABS(NOP(NN,KK))
          IF (N1 .EQ. 0) GO TO 420
          NA = (KK-1)*NDF+1
          ESTIFN(NA,3) = 1.0
          ESTIFN(NA,NA+2) = -1.0
          Z(NA) = (HEL(N1)-HEL(NRX))+(AO(N1)-AO(NRX))
  420   CONTINUE
      ENDIF
      GO TO 360
      END
*-
      SUBROUTINE COEFS (NN,NTX)
*-
      SAVE
*-
      INCLUDE 'hsctm.inc'
*-
      COMMON /BLKS/ XNX(8,16),DA(8,16),DB(8,16),XMX(4,16),
     &              CA(4,16),CB(4,16)
*-
      COMMON /BLKC/ AFACT(4),HFACT(4),SLOAD(2),DNAL(3,4),
     &              XNAL(3,4)
*-
* ... FOR SMALL MACHINES REAL*8   NEEDED for WAITx in COEFS (not for CRA
*-
      REAL*8 WAITX,WAITTH,WAITRH
      DIMENSION XN(8),DNX(8),DNY(8),XM(4),DMX(4),DMY(4),
     &     XL(8),YL(8),WAITX(16),DL(2,2),
     &     WAITTH(16),WAITRH(16),AME(4),DAME(4)
      REAL J11,J12,J21,J22
      DATA WAITTH/2*0.05423225910526D-1,2*0.10167259564479D-1,
     &     2*0.22584049282370D-1,2*0.42339724521747D-1,
     &     2*0.35388067898086D-1,2*0.66344216107050D-1,
     &     2*0.23568368193383D-1,2*0.44185088522362D-1/
      DATA WAITRH/0.1210029932856021D0,2*0.2268518518518519D0,
     &     0.1210029932856021D0,0.2268518518518519D0,
     &     2*0.4252933030106941D0,0.2268518518518519D0,
     &     0.2268518518518519D0,2*0.4252933030106941D0,
     &     0.2268518518518519D0,0.1210029932856021D0,
     &     2*0.2268518518518519D0,0.1210029932856021D0/
*-
      IF (ITRACE .GE. 2)
     &        PRINT *,' =+= CALLED COEFS (NN,NTX,=', NN, NTX, ')',
     &                 ' ,OMEGA FOR THIS ELEMENT=', OMEGA
*-
* ... Assign proper coefs
*-
      XAREA(NN) = 0.0
      MR = IMAT(NN)
      CX = COS(TH(NN))
      SA = SIN(TH(NN))
      FFACT = 0.0
      IF (CHEZ(NN) .GT. 0.0) FFACT = GRAV/CHEZ(NN)**2
      NGP = 7
      NCN = NCORN(NN)
      NCNX = NCN/2
*-
* ... Initialize matrices and variables
*-
      DO 100 M = 1,NCNX
         MC = 2*M-1
         N = NOP(NN,MC)
         HS = VEL(3,N)
         CALL AMF (H,HS,AKP(N),ADT(N),ADB(N),AME(M),DAME(M),0)
  100 CONTINUE
      DO 110 I = 1,30
         Z(I) = 0.0
         DO 110 J = 1,30
            ESTIFN(I,J) = 0.0
  110 CONTINUE
*-
* ... Copy proper weighting functions
*-
      IF (IHORD(NN) .LT. 1) THEN
         IF (NCN .LT. 8) THEN
            NGP = 7
            DO 120 M = 1,NGP
               WAITX(M) = WAITT(M)
  120       CONTINUE
         ELSE
            NGP = 9
            DO 130 M = 1,NGP
               WAITX(M) = WAITR(M)
  130       CONTINUE
         ENDIF
      ELSE
         NGP = 16
         IF (NCN .LT. 8) THEN
            DO 140 M = 1,NGP
               WAITX(M) = WAITTH(M)
  140       CONTINUE
         ELSE
            DO 150 M = 1,NGP
               WAITX(M) = WAITRH(M)
  150       CONTINUE
         ENDIF
      ENDIF
*-
* ... Copy shape functions
*-
      CALL SB (NCN,NGP)
*-
* ... Compute local cords
*-
      NR = IABS(NOP(NN,1))
      DO 160 K = 1,NCN
         N = IABS(NOP(NN,K))
         DX = CORD(N,1)-CORD(NR,1)
         DY = CORD(N,2)-CORD(NR,2)
         XL(K) = DX*CX+DY*SA
         YL(K) = -DX*SA+DY*CX
  160 CONTINUE
*-
* ... Compute element equations
*-
      DO 410 I = 1,NGP
*-
* ... Form the Jacobian for quadratic functions
*-
         J11 = 0.0
         J12 = 0.0
         J21 = 0.0
         J22 = 0.0
         DO 170 K = 2,NCN
            J11 = J11+DA(K,I)*XL(K)
            J12 = J12+DA(K,I)*YL(K)
            J21 = J21+DB(K,I)*XL(K)
            J22 = J22+DB(K,I)*YL(K)
  170    CONTINUE
         DETJ = J11*J22-J12*J21
         DO 180 J = 1,NCN
            XN(J) = XNX(J,I)
            DNX(J) = (J22*DA(J,I)-J12*DB(J,I))/DETJ
            DNY(J) = (J11*DB(J,I)-J21*DA(J,I))/DETJ
  180    CONTINUE
         AMW = WAITX(I)*DETJ
         XAREA(NN) = XAREA(NN)+AMW
*        IF (AMW .LE. 0.0) PRINT 190,NN,I
         IF (AMW .LE. 0.0 .AND. IOUT .GT. 0) WRITE (IOUT,190) NN,I
  190    FORMAT (' AMW IS ZERO OR NEGATIVE FOR ELEMENT',I5,
     &          ',GAUSS NO',I5)
         IF (NTX .EQ. 0) GO TO 410
*-
* ... Repeat for linear function
*-
         JJ = 0
         DO 200 J = 1,NCN,2
            JJ = JJ+1
            XM(JJ) = XMX(JJ,I)
            DMX(JJ) = (J22*CA(JJ,I)-J12*CB(JJ,I))/DETJ
            DMY(JJ) = (J11*CB(JJ,I)-J21*CA(JJ,I))/DETJ
  200    CONTINUE
*-
* ... COMPUTE R, S, H AND THEIR DERIVATIVES
*-
         R = 0.0
         SQ = 0.0
         DRDX = 0.0
         DRDZ = 0.0
         DSDX = 0.0
         DSDZ = 0.0
         BETA1 = 0.0
         BETA2 = 0.0
         DO 210 M = 1,NCN
            MR = IABS(NOP(NN,M))
            R = R+XN(M)*(VEL(1,MR)*CX+VEL(2,MR)*SA)
            SQ = SQ+XN(M)*(-VEL(1,MR)*SA+VEL(2,MR)*CX)
            DRDX = DRDX+DNX(M)*(VEL(1,MR)*CX+VEL(2,MR)*SA)
            DRDZ = DRDZ+DNY(M)*(VEL(1,MR)*CX+VEL(2,MR)*SA)
            DSDX = DSDX+DNX(M)*(-VEL(1,MR)*SA+VEL(2,MR)*CX)
            DSDZ = DSDZ+DNY(M)*(-VEL(1,MR)*SA+VEL(2,MR)*CX)
            IF (DELT .GT. 0.0) THEN
               BETA1 = BETA1+XN(M)*(VDOT(1,MR)*CX+
     &             VDOT(2,MR)*SA)
               BETA2 = BETA2+XN(M)*(-VDOT(1,MR)*SA+
     &             VDOT(2,MR)*CX)
            ENDIF
  210    CONTINUE
         ELEV = URF
         H = 0.0
         ROAVG = 0.0
         DHDX  = 0.0
         DHDZ  = 0.0
         DAODX = 0.0
         DAODZ = 0.0
         DRODX = 0.0
         DRODZ = 0.0
         DAODXH = 0.0
         DAODZH = 0.0
         SIGMAX = 0.0
         SIGMAZ = 0.0
         BETA3  = 0.0
         DO 220 M = 1,NCNX
            MC = 2*M-1
            MR = IABS(NOP(NN,MC))
            H = H+XM(M)*VEL(3,MR)
            ROAVG = ROAVG+XM(M)*DEN(MR)
            BETA3 = BETA3+XM(M)*VDOT(3,MR)
            DHDX = DHDX+DMX(M)*VEL(3,MR)
            DHDZ = DHDZ+DMY(M)*VEL(3,MR)
            DAODX = DAODX+DMX(M)*(AME(M)+AO(MR))
            DAODZ = DAODZ+DMY(M)*(AME(M)+AO(MR))
            DRODX = DRODX+DMX(M)*DEN(MR)
            DRODZ = DRODZ+DMY(M)*DEN(MR)
            DAODXH = DAODXH+DMX(M)*DAME(M)
            DAODZH = DAODZH+DMY(M)*DAME(M)
            SIGMAX = SIGMAX+XM(M)*(SIGMA(MR,1)*CX+SIGMA(MR,2)*SA)
            SIGMAZ = SIGMAZ+XM(M)*(-SIGMA(MR,1)*SA+SIGMA(MR,2)*CX)
  220    CONTINUE
         IF (ABS(ROAVG) .LE. 0.001) THEN
            PRINT *,' ==== FEAR OF DIVIDED BY NEAR ZERO in COEFS ===='
            PRINT *,' After 220 continue NN - NTX - NCN - NCNX - ROAVG'
            PRINT *,NN,NTX,NCN,NCNX,ROAVG
            PRINT *,' IMAT(NN)=',IMAT(NN)
            PRINT *,' XM(1) and XM(NCNX)=',XM(1),XM(NCNX)
            PRINT *,' MR=',MR,'   DEN(MR)=',DEN(MR)
            PRINT *,' ==============================================='
         ENDIF
         NTYP = IMAT(NN)
         EPSX = ORT(NTYP,1)/ROAVG
         EPSXZ = ORT(NTYP,2)/ROAVG
         EPSZX = ORT(NTYP,3)/ROAVG
         EPSZ = ORT(NTYP,4)/ROAVG
         SIGMAX = SIGMAX/ROAVG
         SIGMAZ = SIGMAZ/ROAVG
         TVOL(NTYP) = TVOL(NTYP)+AMW*H
         GHC = GRAV*H
         VECQ = SQRT(R**2+SQ**2)
         IF (H .LE. 0.0) H = 0.001
         IF (ZMANN(NN) .GT. 0.0) FFACT = ZMANN(NN)**2*FCOEF/(H**0.333)
         TFRIC = 0.0
         IF (VECQ .GT. 1.0E-6) TFRIC = FFACT/VECQ
         FRN = 0.0
         FSN = 0.0
         IF (DELT .GT. 0.0) THEN
            FRN = H*BETA1
            FSN = H*BETA2
         ENDIF
*-
* ... Evaluate the basic equations with present values
*-
* ... Momentum terms
*-
  230   FRN = FRN+H*(R*DRDX+SQ*DRDZ)+R*SIDF(NN)
        FSN = FSN+H*(SQ*DSDZ+R*DSDX)+SQ*SIDF(NN)
*-
* ... Viscous terms
*-
        FRN = FRN+EPSX*DRDX*DHDX+EPSXZ*DRDZ*DHDZ
        FRNX = EPSX*H*DRDX
        FRNZ = EPSXZ*H*DRDZ
        FSN = FSN+EPSZ*DSDZ*DHDZ+EPSZX*DSDX*DHDX
        FSNX = EPSZX*H*DSDX
        FSNZ = EPSZ*H*DSDZ
*-
* ... Surface and bottom slope (pressure) terms
*-
        FRN = FRN+GHC*(DAODX+H*DRODX/ROAVG)
        FSN = FSN+GHC*(DAODZ+H*DRODZ/ROAVG)
        FRNX = FRNX-H*GHC/2.0
        FSNZ = FSNZ-H*GHC/2.0
*-
* ... Bottom friction terms
*-
        FRN = FRN+FFACT*VECQ*R
        FSN = FSN+FFACT*VECQ*SQ
*-
* ... Coriolis terms
*-
        FRN = FRN-OMEGA*SQ*H
        FSN = FSN+OMEGA*R*H
*-
* ... Wind terms
*-
        FRN = FRN-SIGMAX
        FSN = FSN-SIGMAZ
*-
* ... Motion equations
*-
        DO 240 M = 1,NCN
           IA = 1+NDF*(M-1)
           Z(IA) = Z(IA)-AMW*(XN(M)*FRN+DNX(M)*FRNX+DNY(M)*FRNZ)
           IA = IA+1
           Z(IA) = Z(IA)-AMW*(XN(M)*FSN+DNX(M)*FSNX+DNY(M)*FSNZ)
  240   CONTINUE
*-
* ... Continuity equation
*-
        FRN = H*(DRDX+DSDZ)+R*DHDX+SQ*DHDZ-SIDF(NN)
        IF (DELT .GT. 0.0) THEN
           FRN = FRN+BETA3
        ENDIF
        DO 250 M = 1,NCNX
           IA = 3+2*NDF*(M-1)
           Z(IA) = Z(IA)-AMW*XM(M)*FRN
  250   CONTINUE
*-
* ... Form the x motion equations
*-
* ... Flow terms
*-
* ... Inertial components
*-
        T1 = AMW*(H*DRDX+TFRIC*(2.0*R*R+SQ*SQ)+SIDF(NN))
        T2 = AMW*(H*R+EPSX*DHDX)
        T3 = AMW*(H*SQ+EPSXZ*DHDZ)
        T4 = AMW*(H*(DRDZ-OMEGA)+TFRIC*R*SQ)
        T5 = AMW*EPSX*H
        T6 = AMW*EPSXZ*H
        IB = -2
        DO 280 N = 1,NCN
          IB = IB+NDF
          FEEAN = XN(N)*T1+DNX(N)*T2+DNY(N)*T3
          FEEDN = XN(N)*T4
          FEEBN = T5*DNX(N)
          FEECN = T6*DNY(N)
*-
* ... Form the time terms
*-
          IF (ALTM .LE. 0.0) GO TO 260
          FEEAN = FEEAN+AMW*XN(N)*H*ALTM
  260     CONTINUE
          IA = -2
          DO 270 M = 1,NCN
             IA = IA+NDF
             ESTIFN(IA,IB) = ESTIFN(IA,IB)+XN(M)*FEEAN+
     &                       DNX(M)*FEEBN+DNY(M)*FEECN
             ESTIFN(IA,IB+1) = ESTIFN(IA,IB+1)+XN(M)*FEEDN
  270     CONTINUE
  280   CONTINUE
*-
* ... Form the head terms
*-
        T1 = (R*DRDX+SQ*(DRDZ-OMEGA)+GRAV*DAODX)*AMW
        T2 = AMW*DRDX*EPSX
        T3 = AMW*DRDZ*EPSXZ
        T4 = AMW*(EPSX*DRDX-GHC)
        IB = -3
        DO 310 N = 1,NCNX
          IB = IB+2*NDF
          FEEAN = XM(N)*T1+DMX(N)*(T2+AMW*GRAV*H*
     &            DAME(N))+DMY(N)*T3
          FEEBN = XM(N)*T4
          FEECN = XM(N)*T3
*-
* ... Form the time terms
*-
          IF (DELT .GT. 0.0) THEN
            FEEAN = FEEAN+AMW*XM(N)*BETA1
          ENDIF
  290     CONTINUE
          IA = -2
          DO 300 M = 1,NCN
            IA = IA+NDF
            ESTIFN(IA,IB) = ESTIFN(IA,IB)+XN(M)*FEEAN+
     &                      DNX(M)*FEEBN+DNY(M)*FEECN
  300     CONTINUE
  310   CONTINUE
*-
* ... form the y motion equations
*-
* ... flow terms
*-
        T1 = AMW*(H*DSDZ+TFRIC*(2.0*SQ*SQ+R*R)+SIDF(NN))
        T2 = AMW*(H*R+DHDX*EPSZX)
        T3 = AMW*(H*SQ+DHDZ*EPSZ)
        T4 = AMW*(H*(DSDX+OMEGA)+TFRIC*R*SQ)
        T5 = AMW*EPSZX*H
        T6 = AMW*EPSZ*H
        IB = -2
        DO 340 N = 1,NCN
          IB = IB+NDF
*-
* ... inertial components
*-
          FEEAN = XN(N)*T1+DNX(N)*T2+DNY(N)*T3
          FEEDN = XN(N)*T4
          FEEBN = DNX(N)*T5
          FEECN = DNY(N)*T6
*-
* ... form the time terms
*-
          IF (DELT .GT. 0.0) THEN
             FEEAN = FEEAN+AMW*XN(N)*ALTM*H
          ENDIF
  320     CONTINUE
          IA = -1
          DO 330 M = 1,NCN
            IA = IA+NDF
            ESTIFN(IA,IB) = ESTIFN(IA,IB)+XN(M)*FEEDN
            ESTIFN(IA,IB+1) = ESTIFN(IA,IB+1)+XN(M)*FEEAN+
     &                        DNX(M)*FEEBN+DNY(M)*FEECN
  330     CONTINUE
  340   CONTINUE
*-
* ... head terms
*-
        T1 = AMW*(SQ*DSDZ+R*(OMEGA+DSDX)+GRAV*DAODZ)
        T2 = AMW*EPSZX*DSDX
        T3 = AMW*EPSZ*DSDZ
        T4 = T3-GHC*AMW
        IB = -3
        DO 370 N = 1,NCNX
           IB = IB+2*NDF
*-
* ... Inertial components
*-
           FEEAN = XM(N)*T1+DMX(N)*T2+DMY(N)*(T3+AMW*
     &             GRAV*H*DAME(N))
           FEEBN = XM(N)*T2
           FEECN = XM(N)*T4
*-
* ... Form the time terms
*-
           IF (DELT .GT. 0.0) THEN
              FEEAN = FEEAN+AMW*XM(N)*BETA2
           ENDIF
  350      CONTINUE
           IA = -1
           DO 360 M = 1,NCN
              IA = IA+NDF
              ESTIFN(IA,IB) = ESTIFN(IA,IB)+XN(M)*FEEAN+
     &                        DNX(M)*FEEBN+DNY(M)*FEECN
  360      CONTINUE
  370   CONTINUE
*-
* ... form the continuity equations
*-
        TA4 = AMW*H
        TX = AMW*DHDX
        TZ = AMW*DHDZ
        TB = AMW*(DRDX+DSDZ)
        TCQ = AMW*R
        TD = AMW*SQ
        IF (ALTM .NE. 0.0) TB = TB+ALTM*AMW
        IA = -3
        DO 400 M = 1,NCNX
           IA = IA+6
           IB = -1
           EA = XM(M)*TA4
           EB = XM(M)*TX
           EC = XM(M)*TZ
           DO 380 N = 1,NCN
              IB = IB+2
              ESTIFN(IA,IB) = ESTIFN(IA,IB)+EA*DNX(N)+EB*XN(N)
              IB = IB+1
              ESTIFN(IA,IB) = ESTIFN(IA,IB)+EA*DNY(N)+EC*XN(N)
  380      CONTINUE
           EA = XM(M)*TB
           EB = XM(M)*TCQ
           EC = XM(M)*TD
           IB = -3
           DO 390 N = 1,NCNX
              IB = IB+6
              ESTIFN(IA,IB) = ESTIFN(IA,IB)+XM(N)*EA+DMX(N)*
     &                        EB+DMY(N)*EC
  390      CONTINUE
  400   CONTINUE
  410 CONTINUE
      IF (NTX .EQ. 0) RETURN
*-
* ... Compute boundary forces
*-
      DO 480 L = 1,NCN,2
        N1 = IABS(NOP(NN,L))
        N2 = IABS(NOP(NN,L+1))
        NA = MOD(L+2,NCN)
        NC1 = 3*L
        NC2 = 3*NA
        N3 = IABS(NOP(NN,NA))
        IF (IBN(N2) .NE. 1) GO TO 480
        H1 = VEL(3,N1)
        HT1 = VEL(3,N1)
        H3 = VEL(3,N3)
        HT3 = VEL(3,N3)
        DL(1,2) = (CORD(N2,1)-CORD(N1,1))*CX+(CORD(N2,2)-
     &            CORD(N1,2))*SA
        DL(1,1) = -(CORD(N2,1)-CORD(N1,1))*SA+
     &            (CORD(N2,2)-CORD(N1,2))*CX
        DL(2,2) = (CORD(N3,1)-CORD(N1,1))*CX+(CORD(N3,2)-
     &            CORD(N1,2))*SA
        DL(2,1) = -(CORD(N3,1)-CORD(N1,1))*SA+
     &       (CORD(N3,2)-CORD(N1,2))*CX
        DO 470 M = 1,2
          DO 460 N = 1,4
            TEMP = (DNAL(2,N)*DL(1,M)+DNAL(3,N)*DL(2,M))*
     &             GRAV/2.0
            H = H1+AFACT(N)*(H3-H1)
            HP = TEMP*HFACT(N)*H**2/2.0
            H = HT1+AFACT(N)*(HT3-HT1)
            HP1 = TEMP*H*HFACT(N)
            MA = (L-1)*3+M
            MB = MA+3
            Z(MA) = Z(MA)+HP*XNAL(1,N)*SLOAD(M)
            Z(MA+3) = Z(MA+3)+HP*XNAL(2,N)*SLOAD(M)
            MC = (NA-1)*3+M
            Z(MC) = Z(MC)+HP*XNAL(3,N)*SLOAD(M)
            IF (MOD(NFIX(N2),1000) .EQ. 200) GO TO 420
            ESTIFN(MA,NC1) = ESTIFN(MA,NC1)-SLOAD(M)*(1.0 -
     &                       AFACT(N))*HP1*XNAL(1,N)
            ESTIFN(MB,NC1) = ESTIFN(MB,NC1)-SLOAD(M)*(1.0 -
     &                       AFACT(N))*HP1*XNAL(2,N)
            ESTIFN(MC,NC1) = ESTIFN(MC,NC1)-SLOAD(M)*(1.0 -
     &                       AFACT(N))*HP1*XNAL(3,N)
            GO TO 430
  420       CONTINUE
            Z(MA) = Z(MA)+SLOAD(M)*(1.0-AFACT(N))*HP1*
     &              XNAL(1,N)*(SPEC(N1,3)-VEL(3,N1))
            Z(MB) = Z(MB)+SLOAD(M)*(1.0-AFACT(N))*HP1*
     &              XNAL(2,N)*(SPEC(N1,3)-VEL(3,N1))
            Z(MC) = Z(MC)+SLOAD(M)*(1.0-AFACT(N))*HP1*
     &              XNAL(3,N)*(SPEC(N1,3)-VEL(3,N1))
  430       CONTINUE
            IF (MOD(NFIX(N2),1000) .EQ. 200) GO TO 440
            ESTIFN(MA,NC2) = ESTIFN(MA,NC2)-SLOAD(M)*
     &                       AFACT(N)*HP1*XNAL(1,N)
            ESTIFN(MB,NC2) = ESTIFN(MB,NC2)-SLOAD(M)*
     &                       AFACT(N)*HP1*XNAL(2,N)
            ESTIFN(MC,NC2) = ESTIFN(MC,NC2)-SLOAD(M)*
     &                       AFACT(N)*HP1*XNAL(3,N)
            GO TO 450
  440       CONTINUE
            Z(MA) = Z(MA)+SLOAD(M)*AFACT(N)*HP1*
     &              XNAL(1,N)*(SPEC(N3,3)-VEL(3,N3))
            Z(MB) = Z(MB)+SLOAD(M)*AFACT(N)*HP1*
     &              XNAL(2,N)*(SPEC(N3,3)-VEL(3,N3))
            Z(MC) = Z(MC)+SLOAD(M)*AFACT(N)*HP1*
     &              XNAL(3,N)*(SPEC(N3,3)-VEL(3,N3))
  450       CONTINUE
  460     CONTINUE
  470   CONTINUE
  480 CONTINUE
*-
* ... Apply transformations to stiffness and
* ... Force matrices for sloping boundary conditions
*-
      DO 520 N = 1,NCN
         N1 = IABS(NOP(NN,N))
         AFA = ALFA(N1)-TH(NN)-ADIF(N1)
         IF (AFA .LT. 0.0) GO TO 490
         IF (AFA .LE. 0.0) GO TO 520
  490    CX = COS(AFA)
         SA = SIN(AFA)
         IB = NDF*(N-1)+1
         DO 500 M = 1,NCN
            DO 500 MM = 1,NDF
               IA = NDF*(M-1)+MM
               TEMP = ESTIFN(IA,IB)*CX+ESTIFN(IA,IB+1)*SA
               ESTIFN(IA,IB+1) = -ESTIFN(IA,IB)*SA+
     &                            ESTIFN(IA,IB+1)*CX
               ESTIFN(IA,IB) = TEMP
  500       CONTINUE
         DO 510 M = 1,NCN
            DO 510 MM = 1,NDF
               IA = NDF*(M-1)+MM
               TEMP = ESTIFN(IB,IA)*CX+ESTIFN(IB+1,IA)*SA
               ESTIFN(IB+1,IA) = -ESTIFN(IB,IA)*SA+
     &                            ESTIFN(IB+1,IA)*CX
               ESTIFN(IB,IA) = TEMP
  510    CONTINUE
         TEMP = CX*Z(IB)+SA*Z(IB+1)
         Z(IB+1) = -Z(IB)*SA+Z(IB+1)*CX
         Z(IB) = TEMP
  520 CONTINUE
*-
* ... For 1D - 2D junctions adjust equation for direction
*-
      DO 540 N = 1,NCN,2
         M = IABS(NOP(NN,N))
         IF (ADIF(M) .NE. 0.0) THEN
            NEQ = NDF*NCN
            IA = NDF*(N-1)+1
            DO 530 I = 1,NEQ
               ESTIFN(I,IA) = ESTIFN(I,IA)+ESTIFN(I,IA+1)*
     &                        SIN(ADIF(M))/COS(ADIF(M))
  530       CONTINUE
         ENDIF
  540 CONTINUE
*-
* ... Insert experimental upstream boundary flows
*-
      DO 580 N = 1,NCN
         M = IABS(NOP(NN,N))
*-
* ... Test for and then retrieve stage flow constants
*-
        IF (ISTLIN(M) .NE. 0) THEN
           J = ISTLIN(M)
           AC1 = STQ(J)
           AC2 = STQA(J)
           E0 = STQE(J)
           CP = STQC(J)
           ASC = ALN(J)
           JJ = J
           THET = STQT(J)
           TAR = TAREA(J)
           IF (ITRACE .GE. 2) THEN
              PRINT *,'J= ',J,' AC1= ',AC1,' AC2= ',AC2,' E0= ',
     &                 E0,' ASC= ',ASC
              PRINT *,'ALFA(M) = ',ALFA(M),'  THET = ',THET
           ENDIF
        ELSE
           AC2 = 0.0
        ENDIF
        IF (NFIX(M) .LT. 13000) GO TO 580
        IRW = 3*N-2
        IF (NFIX(M) .EQ. 13000) IRW = IRW+1
        IRH = 3*N
        VX = VEL(1,M)*COS(ALFA(M))+VEL(2,M)*SIN(ALFA(M))
*-
        DO 550 J = 1,30
           ESTIFN(IRW,J) = 0.0
  550   CONTINUE
*-
* ... Check for negative head on brc (boundary rating curve)
*-
        ICON = ISTLIN(M)
        MAX = 0
        IF (ICON .GT. 0) MAX = LMT(ICON)
        XCHK = HEL(M)-AO(M)-E0
        IF (MAX .NE. 0) THEN
           XCHK = 0.0
           DO 560 IC = 1,MAX
              XCHK = XCHK+HEL(LINE(ICON,IC))+AO(LINE(ICON,IC))
  560      CONTINUE
           XCHK = XCHK/FLOAT(MAX)
           XCHK = XCHK-E0
        ENDIF
        IF (ABS(XCHK) .LE. 0.01) AC2 = 0.0
        FROUDE = ABS(VX/SQRT(VEL(3,M)*GRAV))
        IF (FROUDE .GT. 1.0) FROUDE = 1.0
        FROUDE = 0.0
        XSGN = SIGN(1.0,XCHK)*COS(ALFA(M)-THET)*(1.0-FROUDE**0.5)
        IBR2 = 0
        IF (ICON .GT. 0) THEN
           IF (IABS(IBR(ICON)) .GT. 0) IBR2=1
        ENDIF
*-
* ... VARIABLE IGO is a switch for radiation bc bia bra card
* ... WHERE ISS = 1 FOR STEADY STATE, ELSE 0 AND IBR()=+N IF NRB SPEC
*-
        IGO = (1-ISS*IBR2)
        IF (ITRACE .GE. 2) PRINT *,' DEBUG IN COEFS-VALUES IGO-I',
     &                   'SS-ICON-M= ',IGO,ISS,ICON,M
        IF (MOD(N,2) .EQ. 0) GO TO 570
        ESTIFN(IRW,IRW) = XAREA(NN)*VEL(3,M)
        ESTIFN(IRW,IRH) = XAREA(NN)*VX
        Z(IRW) = XAREA(NN)*(SPEC(M,1)-VX*VEL(3,M))
        IF (AC2 .NE. 0.0 .OR. TAR .NE. 0.0) THEN
           ASC = ALN(JJ)
           AF = VEL(3,M)/ASC
           IF (ITRACE .GE. 2) THEN
            PRINT *,' DEBUG in COEFS   M= ',M,'   NODE NUMBER'
            PRINT *,' VEL(3,M)= ',VEL(3,M),'  SPEC(M,1) = ',SPEC(M,1)
            PRINT *,' AC1 = ',AC1,'   AC2 = ',AC2,'   AF = ',AF
            PRINT *,' XCHK = ',XCHK,'  XSGN = ',XSGN
          ENDIF
          IF (SPEC(M,1) .LT. 0.0) THEN
            AC1 = -ABS(AC1)
          ENDIF
          IF (ABS(CP-1.0) .LT. 0.01) THEN
             Z(IRW) = Z(IRW)+XAREA(NN)*AF*(AC2*XSGN*
     &                ABS(XCHK)*IGO)
             ESTIFN(IRW,IRH) = ESTIFN(IRW,IRH)-XAREA(NN)*AF*AC2*CP*IGO
             TSGN = SIGN(1.0,COS(ALFA(M)-THET))*(1.0-FROUDE**0.5)
             Z(IRW) = (Z(IRW)-XAREA(NN)*TAR*AF*TSGN*(ALTM*
     &                (VEL(3,M)-VOLD(3,M))-(ALTM*3600.0*DELT-1.0)*
     &                VDOTO(3,M))*IGO)
             ESTIFN(IRW,IRH)=ESTIFN(IRW,IRH)-XAREA(NN)*AF*TAR*TSGN*
     &                       ALTM*IGO
          ELSE
             Z(IRW) = (Z(IRW)+XAREA(NN)*AF*(AC1+AC2*
     &                XSGN*ABS(XCHK)**CP))*IGO
             ESTIFN(IRW,IRH) = (ESTIFN(IRW,IRH)-XAREA(NN)*
     &                         (AF*AC2*CP*ABS(XCHK)**(CP-1.0)))*IGO
          ENDIF
        ENDIF
        GO TO 580
  570   N1 = IABS(NOP(NN,N-1))
        N2 = MOD(N+1,NCN)
        N3 = IABS(NOP(NN,N2))
        HM = (VEL(3,N1)+VEL(3,N3))/2.0
*-
        ESTIFN(IRW,IRW) = XAREA(NN)*HM
        ESTIFN(IRW,IRH-3) = XAREA(NN)*VX/2.0
        ESTIFN(IRW,3*N2) = XAREA(NN)*VX/2.0
        Z(IRW) = XAREA(NN)*(SPEC(M,1)-VX*HM)
        HM = (HEL(N1)+HEL(N3))/2.0
* ... check for negative head
        IF (HM .LT. 0.0) HM = 0.0
        XCHK = HM+AO(M)-E0
        IF (AC2 .NE. 0.0 .OR.  TAR  .NE. 0.0) THEN
           IF (ABS(ASC) .LT. 0.001) PRINT *,' COEFS ASC >>> near 0'
           AF = HM/ASC
           IF (ABS(CP-1.0) .LT. 0.01) THEN
              Z(IRW) = Z(IRW)+XAREA(NN)* (AF*AC2 *XSGN*ABS(XCHK)*IGO)
              ESTIFN(IRW,IRH-3)=ESTIFN(IRW,IRH-3)-(XAREA(NN)/2.0)*AF*AC2
     &                          *IGO
              TSGN = SIGN(1.0,COS(ALFA(M)-THET))
              Z(IRW)=Z(IRW)-XAREA(NN)*AF*TAR*TSGN*(ALTM*
     &               (VEL(3,M)-VOLD(3,M))-(ALTM*3600.0*DELT-1.0)*
     &               VDOTO(3,M))*IGO
              ESTIFN(IRW,IRH-3)=ESTIFN(IRW,IRH-3)-(XAREA(NN)/2.0)*AF*
     &                          TAR*TSGN*ALTM*IGO
              ESTIFN(IRW,3*N2) = ESTIFN(IRW,IRH-3)
           ELSE
              Z(IRW) = (Z(IRW)+XAREA(NN)*(AF*(AC1+AC2*
     &                 XSGN*ABS(XCHK)**CP)))*IGO
              ESTIFN(IRW,IRH-3) = (ESTIFN(IRW,IRH-3)-(XAREA(NN)/2.0)
     &                            *(AF*AC2*CP*ABS(XCHK)**(CP-1.0)))*IGO
              ESTIFN(IRW,3*N2) = ESTIFN(IRW,IRH-3)
           ENDIF
        ENDIF
  580 CONTINUE
      DO 590 I = 1,NCN
        J = IABS(NOP(NN,I))
        IA = NDF*(I-1)
        DO 590 K = 1,NDF
          IA = IA+1
          JA = NBC(J,K)
          IF (JA .EQ. 0) GO TO 590
          R1(JA) = R1(JA)+Z(IA)
  590 CONTINUE
      RETURN
      END
*-
      SUBROUTINE CONVRT (ISTRING,LENGTH,INTVAL,ISIZE,ISWITCH)
      SAVE
*-
* ... ISWITCH: 1 CONVERT FROM CHARACTER TO ASCII INTEGER VALUE
* ...          2 CONVERT FROM INTEGER VALUE TO CHARACTER EQUIVALENT
* ...          3 CONSOLIDATE BANNERS
* ... PURPOSE: Avoid FORTRAN to C-Language binary file read problems
*-
      PARAMETER (MM8=1200)
      INCLUDE 'hsctm.inc'
      CHARACTER ISTRING(15)*80
      DIMENSION INTVAL(MM8)
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED CONVRT (ISIZE=',ISIZE,
     &                                '...ISWITCH=',ISWITCH,')'
*-
      ISTOP = 0
      IF ((ISIZE*LENGTH) .GT. MM8) THEN
         PRINT *,' Error in CONVRT ... LENGTH & SIZE are inconsistent'
         PRINT *,'          with dimension capabilities'
         ISTOP= 1
      ENDIF
      IF (ISIZE .GT. MM8) THEN
         PRINT *,' Error in CONVRT ... size larger than 1200'
         ISTOP= 1
      ENDIF
      IF (ISTOP .GE. 1) THEN
         STOP'CONVRT'
      ENDIF
*-
      IF (ISWITCH .EQ. 1) THEN
*-
* ... Convert from character to ascii integer value
*-
          II = 0
          DO 300 LL = 1,LENGTH
             DO 200 I = 1,ISIZE
                II = II+1
                INTVAL(II) = ICHAR(ISTRING(LL)(I:I))
  200        CONTINUE
  300     CONTINUE
*-
      ELSEIF (ISWITCH .EQ. 2) THEN
*-
* ... Convert from ascii integer value to character
*-
          IIE = 0
          DO 600 LL = 1,LENGTH
             IIS = 1+IIE
             IIE = IIS+(ISIZE-1)
             J = 0
             DO 500 I = IIS,IIE
                J = J+1
                ISTRING(LL)(J:J) = CHAR(INTVAL(I))
  500        CONTINUE
  600     CONTINUE
*-
      ELSEIF (ISWITCH .EQ. 3) THEN
*-
* ... consolidate BANNER section
*-
        BANRM2(1)(1:80)  = BANGFG(1)(1:80)
        BANRM2(2)(1:80)  = BANGFG(2)(1:80)
        BANRM2(3)(1:80)  = BANGFG(3)(1:80)
        BANRM2(4)(1:80)  = BANGFG(4)(1:80)
        BANRM2(5)(1:80)  = BANGFG(5)(1:80)
*-
        IF (METRIC .GE. 1) BANRM2(6)(41:47) = 'METRIC '
        BANRM2(7)(1:40)  = VERRM2(1)(1:40)
        BANRM2(7)(41:80) = VERRM2(2)(1:40)
        BANRM2(8)(1:80)  = STAMP(1:80)
        BANRM2(9)(1:80)  = DESC(1)(1:80)
        BANRM2(10)(1:80) = DESC(2)(1:80)
*-
        BANRM2(11)(1:80) = BANGFG(11)(1:80)
        BANRM2(12)(1:80) = BANGFG(12)(1:80)
        BANRM2(13)(1:80) = BANGFG(13)(1:80)
        BANRM2(14)(1:80) = BANGFG(14)(1:80)
        BANRM2(15)(1:80) = BANGFG(15)(1:80)
*-
      ELSE
*-
          PRINT *,' --> Value of ISWITCH invalid in CONVRT'
      ENDIF
      RETURN
      END
*-
      SUBROUTINE CSTRC (NN)
*-
      SAVE
*-
      INCLUDE 'hsctm.inc'
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED CSTR* .....NN=',NN
*-
      NCN=NCORN(NN)
*-
* ... DETERMINE TYPE OF CONTROL STRUCTURE
*-
      NM=IMAT(NN)-900
*-
* ... ONE OF THE CONDITIONS IS FLOW BALANCE
*-
      IF (NJT(NM) .GT. 1) THEN
         Z(1)=0.0
      ELSE
         Z(1)=AJ(NM)
      ENDIF
      DO 300 KK=1,NCN
         N1=IABS(NOP(NN,KK))
         IF (N1 .EQ. 0) GO TO 300
         NA=(KK-1)*NDF+1
         ESTIFN(1,NA)=DIR(N1)*(WIDTH(N1)+(SS1(N1)+SS2(N1))/2.0
     &                *VEL(3,N1))*VEL(3,N1)
         CX=COS(ALFA(N1))
         SA=SIN(ALFA(N1))
         R=VEL(1,N1)*CX+VEL(2,N1)*SA
         ESTIFN(1,NA+2)=DIR(N1)*(WIDTH(N1)+(SS1(N1)+SS2(N1))
     &                  *VEL(3,N1))*R
         Z(1)=Z(1)-ESTIFN(1,NA)*R
  300 CONTINUE
*-
* ... THE OTHER IS SOME KIND OF ELEVATION RELATIONSHIP
*-
      IF (NJT(NM) .EQ. 1) THEN
*-
* ... BALANCE TOTAL HEAD
*-
         NRX=IABS(NOP(NN,1))
         RX=VEL(1,NRX)*COS(ALFA(NRX))+VEL(2,NRX)*SIN(ALFA(NRX))
         THN=HEL(NRX)+AO(NRX)+RX**2/(2.0*GRAV)
         DO 350 KK=2,NCN
            N1=IABS(NOP(NN,KK))
            IF (N1 .EQ. 0) GO TO 350
            RY=VEL(1,N1)*COS(ALFA(N1))+VEL(2,N1)*SIN(ALFA(N1))
            TH1=HEL(N1)+AO(N1)+RY**2/(2.0*GRAV)
            NA=(KK-1)*NDF+1
            ESTIFN(NA,1)=RX/GRAV
            ESTIFN(NA,3)=1.0
            ESTIFN(NA,NA)= -RY/GRAV
            ESTIFN(NA,NA+2)= -1.0
            Z(NA)=TH1-THN
  350    CONTINUE
*-
      ELSEIF (NJT(NM) .EQ. 2) THEN
*-
* ... REVERSIBLE Q = FUNCTION OF HEAD LOSS (H1 -H2 -C)
*-
         N1=IABS(NOP(NN,1))
         RX1=VEL(1,N1)*COS(ALFA(N1))+VEL(2,N1)*SIN(ALFA(N1))
         IF (ABS(ALFA(N1)-QD(NM)) .GT. 1.570796 .AND.
     &      ABS(ALFA(N1)-QD(NM)) .LT. 4.713388) THEN
            RSWT1= -1.0
         ELSE
         RSWT1=1.0
         ENDIF
         N2=IABS(NOP(NN,2))
         RX2=VEL(1,N2)*COS(ALFA(N2))+VEL(2,N2)*SIN(ALFA(N2))
         IF (ABS(ALFA(N2)-QD(NM)) .GT. 1.570796 .AND.
     &      ABS(ALFA(N2)-QD(NM)) .LT. 4.713388) THEN
            RSWT2= -1.0
         ELSE
            RSWT2=1.0
         ENDIF
         WRITE (*,*) NN,N1,ALFA(N1),N2,ALFA(N2)
         NA=NDF+1
         AWD1=WIDTH(N1)+(SS1(N1)+SS2(N1))/2.0*VEL(3,N1)
         AWD2=WIDTH(N2)+(SS1(N2)+SS2(N2))/2.0*VEL(3,N2)
         ACR1=AWD1*VEL(3,N1)
         ACR2=AWD2*VEL(3,N2)
         QA=(ACR1*RX1*RSWT1+ACR2*RX2*RSWT2)/2.0
         WS1=HEL(N1)+AO(N1)
         WS2=HEL(N2)+AO(N2)
         HLOS=ABS(WS1-WS2)
         HLOS=HLOS-CJ(NM)
         HLD=SIGN(1.0,WS1-WS2)
* ... SET HLOS FOR VERY FIRST ITERATION
         WRITE (*,*) RSWT1,RSWT2,HLOS
         IF (HLOS .LT. 0.01 .AND. NPR .EQ. 1) THEN
            HLOS=0.01
         ELSEIF (HLOS .LT. 0.0001) THEN
            HLOS = 0.0001
         ENDIF
         Z(NA)=QA-AJ(NM)-BJ(NM)*HLD*HLOS**GAMJ(NM)
         ESTIFN(NA,1)= -(ACR1*RSWT1)/2.0
         ESTIFN(NA,NA)= -(ACR2*RSWT2)/2.0
         ESTIFN(NA,3)=BJ(NM)*GAMJ(NM)*HLOS**(GAMJ(NM)-1.0)
     &                -RX1*RSWT1*AWD1/2.0
         ESTIFN(NA,NA+2)= -BJ(NM)*GAMJ(NM)*HLOS**(GAMJ(NM)-1.0)
     &                    -RX2*RSWT2*AWD2/2.0
*-
      ELSEIF (NJT(NM) .EQ. 3) THEN
*-
* ... NON-REVERSIBLE Q = FUNCTION OF HEAD LOSS (H1 -H2 -C)
*-
         N1=IABS(NOP(NN,1))
         RX1=VEL(1,N1)*COS(ALFA(N1))+VEL(2,N1)*SIN(ALFA(N1))
         IF (ABS(ALFA(N1)-QD(NM)) .GT. 1.570796 .AND.
     &      ABS(ALFA(N1)-QD(NM)) .LT. 4.713388) THEN
            RSWT1= -1.0
         ELSE
            RSWT1=1.0
         ENDIF
         N2=IABS(NOP(NN,2))
         RX2=VEL(1,N2)*COS(ALFA(N2))+VEL(2,N2)*SIN(ALFA(N2))
         IF (ABS(ALFA(N2)-QD(NM)) .GT. 1.570796 .AND.
     &      ABS(ALFA(N2)-QD(NM)) .LT. 4.713388) THEN
            RSWT2= -1.0
         ELSE
            RSWT2=1.0
         ENDIF
         NA=NDF+1
         AWD1=WIDTH(N1)+(SS1(N1)+SS2(N1))/2.0*VEL(3,N1)
         AWD2=WIDTH(N2)+(SS1(N2)+SS2(N2))/2.0*VEL(3,N2)
         ACR1=AWD1*VEL(3,N1)
         ACR2=AWD2*VEL(3,N2)
         QA=(ACR1*RX1*RSWT1+ACR2*RX2*RSWT2)/2.0
         WS1=HEL(N1)+AO(N1)
         WS2=HEL(N2)+AO(N2)
         HLOS=WS1-WS2-CJ(NM)
            WRITE (*,*) NN,N1,ALFA(N1),N2,ALFA(N2)
            WRITE (*,*) RSWT1,RSWT2,HLOS
         IF (HLOS .LT. 0.01 .AND. NPR .EQ. 1) HLOS = 0.01
         IF (HLOS .LT. 0.0001) THEN
            Z(NA)=QA
            ESTIFN(NA,1)= -(ACR1*RSWT1)/2.0
            ESTIFN(NA,NA)= -(ACR2*RSWT2)/2.0
         ELSE
            HLD = 1.0
* ... SET HLOS FOR VERY FIRST ITERATION
            Z(NA)=QA-AJ(NM)-BJ(NM)*HLD*HLOS**GAMJ(NM)
            ESTIFN(NA,1)= -(ACR1*RSWT1)/2.0
            ESTIFN(NA,NA)= -(ACR2*RSWT2)/2.0
            ESTIFN(NA,3)=BJ(NM)*GAMJ(NM)*HLOS**(GAMJ(NM)-1.0)
     &                   -RX1*RSWT1*AWD1/2.0
            ESTIFN(NA,NA+2)= -BJ(NM)*GAMJ(NM)*HLOS**(GAMJ(NM)-1.0)
     &                       -RX2*RSWT2*AWD2/2.0
         ENDIF
*-
      ELSEIF (NJT(NM) .EQ. 4) THEN
*-
* ... Q = FUNCTION OF HEAD (H1)
*-
         N1=IABS(NOP(NN,1))
         RX1=VEL(1,N1)*COS(ALFA(N1))+VEL(2,N1)*SIN(ALFA(N1))
         IF (ABS(ALFA(N1)-QD(NM)) .GT. 1.570796 .AND.
     &      ABS(ALFA(N1)-QD(NM)) .LT. 4.713388) THEN
            RSWT1= -1.0
         ELSE
            RSWT1=1.0
         ENDIF
         N2=IABS(NOP(NN,2))
         RX2=VEL(1,N2)*COS(ALFA(N2))+VEL(2,N2)*SIN(ALFA(N2))
         IF (ABS(ALFA(N2)-QD(NM)) .GT. 1.570796 .AND.
     &      ABS(ALFA(N2)-QD(NM)) .LT. 4.713388) THEN
            RSWT2= -1.0
         ELSE
            RSWT2=1.0
         ENDIF
         NA=NDF+1
         AWD1=WIDTH(N1)+(SS1(N1)+SS2(N1))/2.0*VEL(3,N1)
         AWD2=WIDTH(N2)+(SS1(N2)+SS2(N2))/2.0*VEL(3,N2)
         ACR1=AWD1*VEL(3,N1)
         ACR2=AWD2*VEL(3,N2)
         QA=(ACR1*RX1*RSWT1+ACR2*RX2*RSWT2)/2.0
         WS1=HEL(N1)+AO(N1)-CJ(NM)
* ... WS1 SET TO NEAR ZERO IF NEGATIVE
         IF (WS1 .LT. 0.0) WS1 = 0.0000001
         Z(NA)=QA-AJ(NM)-BJ(NM)*WS1**GAMJ(NM)
         ESTIFN(NA,1)= -(ACR1*RSWT1)/2.0
         ESTIFN(NA,NA)= -(ACR2*RSWT2)/2.0
         ESTIFN(NA,3)=BJ(NM)*GAMJ(NM)*WS1**(GAMJ(NM)-1.0)
     &                -RX1*RSWT1*AWD1/2.0
         ESTIFN(NA,NA+2)= -RX2*RSWT2*AWD2/2.0
*-
      ELSEIF (NJT(NM) .EQ. 5) THEN
*-
* ... REVERSIBLE HEAD LOSS (H1 -H2) = FUNCTION OF Q
*-
        N1=IABS(NOP(NN,1))
        RX1=VEL(1,N1)*COS(ALFA(N1))+VEL(2,N1)*SIN(ALFA(N1))
        IF (ABS(ALFA(N1)-QD(NM)) .GT. 1.570796 .AND.
     &     ABS(ALFA(N1)-QD(NM)) .LT. 4.713388) THEN
          RSWT1= -1.0
        ELSE
          RSWT1=1.0
        ENDIF
        N2=IABS(NOP(NN,2))
        RX2=VEL(1,N2)*COS(ALFA(N2))+VEL(2,N2)*SIN(ALFA(N2))
        IF (ABS(ALFA(N2)-QD(NM)) .GT. 1.570796 .AND.
     &     ABS(ALFA(N2)-QD(NM)) .LT. 4.713388) THEN
          RSWT2= -1.0
        ELSE
          RSWT2=1.0
        ENDIF
        NA=NDF+1
        AWD1=WIDTH(N1)+(SS1(N1)+SS2(N1))/2.0*VEL(3,N1)
        AWD2=WIDTH(N2)+(SS1(N2)+SS2(N2))/2.0*VEL(3,N2)
        ACR1=AWD1*VEL(3,N1)
        ACR2=AWD2*VEL(3,N2)
        QA=(ACR1*RX1*RSWT1+ACR2*RX2*RSWT2)/2.0
        SQ=SIGN(1.0,QA)
        WS1=HEL(N1)+AO(N1)
        WS2=HEL(N2)+AO(N2)
        HLOS=WS1-WS2
        HLD=SIGN(1.0,WS1-WS2)
        Z(NA)=HLOS-AJ(NM)-BJ(NM)*SQ*(ABS(QA))**GAMJ(NM)
        ESTIFN(NA,1)=
     &    BJ(NM)*ACR1*RSWT1/2.0*GAMJ(NM)*(ABS(QA))**(GAMJ(NM)-1.0)
        ESTIFN(NA,NA)=
     &    BJ(NM)*ACR2*RSWT2/2.0*GAMJ(NM)*(ABS(QA))**(GAMJ(NM)-1.0)
        ESTIFN(NA,3)= -1.0
     &   +BJ(NM)*AWD1*RSWT1/2.0*RX1*GAMJ(NM)*(ABS(QA))**(GAMJ(NM)-1.0) 
        ESTIFN(NA,NA+2)=1.0
     &   +BJ(NM)*AWD2*RSWT2/2.0*RX2*GAMJ(NM)*(ABS(QA))**(GAMJ(NM)-1.0)
*-
*  SPECIAL FLOW CONTROLLER EQUATION FOR GRAND AND WHITE LAKES STUDY
*-
*    QA =  BJ*H**GAMJ*(CJ*(WS-AJ1)-H)
*    AJ1 = SILL ELEVATION
*    WS = WATER SURFACE ELEVATION
*-
*    NJT = 6   REVERSIBLE
*    NJT = 7   NON-REVERSIBLE
*-
      ELSEIF (NJT(NM) .EQ. 6 .OR. NJT(NM) .EQ. 7) THEN
*-
        N1=IABS(NOP(NN,1))
        RX1=VEL(1,N1)*COS(ALFA(N1))+VEL(2,N1)*SIN(ALFA(N1))
        IF (ABS(ALFA(N1)-QD(NM)) .GT. 1.570796 .AND.
     &     ABS(ALFA(N1)-QD(NM)) .LT. 4.713388) THEN
           RSWT1= -1.0
        ELSE
           RSWT1=1.0
        ENDIF
        N2=IABS(NOP(NN,2))
        RX2=VEL(1,N2)*COS(ALFA(N2))+VEL(2,N2)*SIN(ALFA(N2))
        IF (ABS(ALFA(N2)-QD(NM)) .GT. 1.570796 .AND.
     &     ABS(ALFA(N2)-QD(NM)) .LT. 4.713388) THEN
           RSWT2= -1.0
        ELSE
           RSWT2=1.0
        ENDIF
        NA=NDF+1
        AWD1=WIDTH(N1)+(SS1(N1)+SS2(N1))/2.0*VEL(3,N1)
        AWD2=WIDTH(N2)+(SS1(N2)+SS2(N2))/2.0*VEL(3,N2)
        ACR1=AWD1*VEL(3,N1)
        ACR2=AWD2*VEL(3,N2)
        QA=(ACR1*RX1*RSWT1+ACR2*RX2*RSWT2)/2.0
        WS1=HEL(N1)+AO(N1)
        WS2=HEL(N2)+AO(N2)
        HLOS=ABS(WS1-WS2)
        IF (HLOS .LT. 0.01) HLOS=0.01
        HLD=SIGN(1.0,WS1-WS2)
        CDEPTH = 0.5*(WS1+WS2)-AJ(NM)
* ... SET HLOS FOR VERY FIRST ITERATION
        IF (HLOS .LT. 0.10 .AND. NPR .EQ. 1) HLOS=0.10
* ... CHECK FOR NON-REVERSIBLE FLOW
        IF ((WS1-WS2) .LT. 0.01 .AND. NJT(NM) .EQ. 7) THEN
           Z(NA) = QA
           ESTIFN(NA,1)= -(ACR1*RSWT1)/2.0
           ESTIFN(NA,NA)= -(ACR2*RSWT2)/2.0
        ELSE
           Z(NA) = QA- BJ(NM)*HLD*HLOS**GAMJ(NM)*
     &             (CJ(NM)*CDEPTH-HLOS)
           ESTIFN(NA,1)= -(ACR1*RSWT1)/2.0
           ESTIFN(NA,NA)= -(ACR2*RSWT2)/2.0
           ESTIFN(NA,3) = BJ(NM)*GAMJ(NM)*HLOS**(GAMJ(NM)-1.0)*
     &                    (CJ(NM)*CDEPTH-HLOS)+
     &                    BJ(NM)*HLOS**GAMJ(NM)*(0.5*CJ(NM)-1.0)
     &                    -RX1*RSWT1*AWD1/2.0
           ESTIFN(NA,NA+2)= -BJ(NM)*GAMJ(NM)*HLOS**(GAMJ(NM)-1.0)*
     &                      (CJ(NM)*CDEPTH-HLOS)+
     &                      BJ(NM)*HLOS**GAMJ(NM)*(0.5*CJ(NM)+1.0)
     &                      -RX2*RSWT2*AWD2/2.0
*-
        ENDIF
*-
      ENDIF
*-
      RETURN
      END
*-
***********************************************************************
      SUBROUTINE CRACK (I1,NWD,REA,INT,CHA,TYPE,IERRC)
***********************************************************************
*-
*     CRACKS DATA CARDS SIMULATING LIST DIRECTED READS
*     CARD IS PASSED THROUGH COMMON BLOCK
*-
      IMPLICIT REAL (A-H,O-Z)
      CHARACTER*1  IBLANK,ICOMMA
      COMMON /CARD/ JREC
      DIMENSION REA(200),INT(200)
      CHARACTER JREC(80)*1,TYPE*9,IBUF*77,IFOR(1)*10
      CHARACTER CHA(200)*20
*-
      DATA IBLANK /' '/
      DATA ICOMMA /','/
*-
      IF (NWD .GT. 200) PRINT *,' ARRAY overrun in CRACK -REA/INT/CHA'
*-
* ... LOOP FOR EACH WORD TO BE READ
      IF (I1 .GT. 77) RETURN
      NWD1=NWD
      DO 900 I=1,NWD1
* ... FIND START OF DATA (FIRST NON-BLANK CHARACTER)
   10 CONTINUE
      IF (JREC(I1) .NE. IBLANK .AND. JREC(I1) .NE. ICOMMA) GO TO 15
      I1=I1+1
      IF (JREC(I1) .EQ. ICOMMA) THEN
         I1=I1+1
         GO TO 900
      ENDIF
      IF (I1 .GT. 77) THEN
         NWD=I-1
         RETURN
      ENDIF
      GO TO 10
   15 CONTINUE
* ... FIND END OF DATA
      I2=I1+1
   20 CONTINUE
      IF (JREC(I1) .EQ. '''') THEN
         IF (JREC(I2) .EQ. '''') GO TO 25
      ELSE
         IF (JREC(I2) .EQ. IBLANK .OR. JREC(I2) .EQ. ICOMMA) GO TO 25
      ENDIF
      I2=I2+1
      IF (I2 .LT. 78) GO TO 20
      I2=77
   25 CONTINUE
      IF (JREC(I1) .EQ. '''') I1=I1+1
      LENGTH=I2-I1
      IF (LENGTH .LT. 1) LENGTH=1
      I2=I2-1
* ... PACK DATA INTO BUFFER
      WRITE (IBUF,30)(JREC(J),J=I1,I2)
   30 FORMAT (77A1)
* ... SET UP CORRECT FORMAT AND READ DATA
      IF (TYPE(1:4) .EQ. 'REAL') THEN
         WRITE (IFOR,35) LENGTH
   35    FORMAT ('(F',I2,'.0)')
         READ (IBUF,IFOR) REA(I)
         ELSEIF (TYPE(1:7) .EQ. 'INTEGER') THEN
         WRITE (IFOR,40) LENGTH
   40    FORMAT ('(I',I2,')')
         READ (IBUF,IFOR) INT(I)
      ELSEIF (TYPE(1:9) .EQ. 'CHARACTER') THEN
         WRITE (IFOR,45) LENGTH
   45    FORMAT ('(A',I2,')')
         READ (IBUF,IFOR) CHA(I)
      ELSE
         PRINT 50,TYPE
   50    FORMAT(' *** ERROR, ',A10,' IS ILLEGAL IN CALL TO CRACK ***')
         IERRC =IERRC+1
         RETURN
      ENDIF
      IF (JREC(I2+1) .EQ. '''') I2=I2+1
      I1=I2+1
  900 CONTINUE
       RETURN
       END
*-
      SUBROUTINE DEL
*-
      SAVE
*-
      INCLUDE 'hsctm.inc'
*-
      DATA IENT /0/
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED DEL'
*-
* ... ROUTINE TO DROP OUT ELEMENTS
*-
      IF (IENT .EQ. 1) GO TO 200
      DO 180 N = 1,NE
         IMATO(N)=IMAT(N)
  180 CONTINUE
      DO 185 N = 1,NP
         NDRYO(N)=NDRY(N)
  185 CONTINUE
  200 IENT = 1
*-
* ... RESET MAT TYPES
*-
      DO 250 N = 1,NE
         IMAT(N)=IABS(IMAT(N))
         IF (IMAT(N) .EQ. 0) GO TO 250
         NCN=NCORN(N)                                                      
         DO 230 M=1,NCN,2                                                  
            L=IABS(NOP(N,M))                                                  
            IF (VEL(3,L) .GT. DSETD) GO TO 230                                 
            IF (NDRY(L) .LT. 1) GO TO 205                                      
            IF (VEL(3,L) .GT. DSET) GO TO 230                                  
  205       IMAT(N)= -IABS(IMAT(N))                                            
  230    CONTINUE                                                          
  250 CONTINUE                                                          
      DO 300 N=1,NP
  300 NDRY(N)=2                                                         
      DO 330 N=1,NE                                                     
         IF (IMAT(N) .LT. 1) GO TO 330                                      
         NCN=NCORN(N)                                                      
         DO 320 M=1,NCN                                                    
         L=IABS(NOP(N,M))                                                  
  320    NDRY(L)=1                                                         
  330 CONTINUE                                                          
      DO 390 L=1,NP                                                     
         IF (NDRY(L) .EQ. 1) GO TO 390                                      
         DO 380 IA=1,2                                                     
            VEL(IA,L)=0.0
  380    CONTINUE                                                          
  390 CONTINUE                                                          
      IF (IOUT .GT. 0) WRITE (IOUT,6005)                                  
 6005 FORMAT (' THE FOLLOWING ELEMENTS HAVE BEEN ELIMINATED')            
      NR=0                                                              
      IFLG=1                                                           
      DO 405 N=1,NE                                                     
         IF (IMAT(N) .GE. 0) GO TO 405                                      
         IF (IMATO(N) .LT. 0) GO TO 405                                     
         NR=NR+1                                                           
         IPT(NR)=N                                                         
  405 CONTINUE                                                          
      IF (NR .GT. 0) IFLG=2                                             
      IF (NR .GT. 0 .AND. IOUT .GT. 0) WRITE (IOUT,6030) (IPT(N),N=1,NR)   
 6030 FORMAT (10I5)                                                      
      IF (IOUT .GT. 0) WRITE (IOUT,6007)                                  
 6007 FORMAT (' THE FOLLOWING ELEMENTS HAVE BEEN ADDED')                 
      NR=0                                                              
      DO 410 N=1,NE                                                     
         IF (IMAT(N) .LE. 0) GO TO 410                                      
         IF (IMATO(N) .GT. 0) GO TO 410                                     
         NR=NR+1                                                           
         IPT(NR)=N                                                         
  410 CONTINUE                                                          
      IF (NR .GT. 0) IFLG=2                                             
      IF (IOUT .GT. 0) THEN                                              
          IF (NR .GT. 0) WRITE (IOUT,6030) (IPT(N),N=1,NR)                
          WRITE (IOUT,6008)                                              
 6008     FORMAT (' THE FOLLOWING NODES HAVE BEEN ELIMINATED')           
      ENDIF                                                             
      NR=0                                                              
      DO 415 N=1,NP                                                     
      IF (NDRY(N) .EQ. 1) GO TO 415                                      
      IF (NDRYO(N) .NE. 1) GO TO 415                                     
      NR=NR+1                                                           
      IPT(NR)=N                                                         
  415 CONTINUE                                                          
      IF (NR .GT. 0) IFLG=2                                             
      IF (IOUT .GT. 0) THEN                                              
          IF (NR .GT. 0) WRITE (IOUT,6030) (IPT(N),N=1,NR)                
          WRITE (IOUT,6009)                                              
 6009     FORMAT (' THE FOLLOWING NODES HAVE BEEN ADDED')                
      ENDIF                                                             
      NR=0                                                              
      DO 420 N=1,NP                                                     
      IF (NDRY(N) .NE. 1) GO TO 420                                      
      IF (NDRYO(N) .EQ. 1) GO TO 420                                     
      NR=NR+1                                                           
      IPT(NR)=N                                                         
  420 CONTINUE                                                          
      IF (NR .GT. 0) IFLG=2                                             
      IF (NR .GT. 0 .AND. IOUT .GT. 0) WRITE (IOUT,6030) (IPT(N),N=1,NR)    
      DO 450 N=1,NE                                                     
         IMATO(N)=IMAT(N)                                                  
  450 CONTINUE                                                          
      DO 500 N=1,NP                                                     
         NDRYO(N)=NDRY(N)                                                  
  500 CONTINUE                                                          
      RETURN                                                            
      END
*-
      SUBROUTINE DELM
*-
      SAVE
*-
      INCLUDE 'hsctm.inc'
*-                                                                      
       DATA IENT /0/
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED DELM '                     
*                                                                       
* ... Routine to drop out elements                                    
*-                                                                      
*-      NDRY = 1  Standard node                                         
*-             2  Dry node                                              
*-            -1  A dry node that has rewet during REWET                
*-                                                                      
* ... Initialize                                                      
*-                                                                      
      IF (IENT .EQ. 0) THEN                                              
*       DO 180 N=1,NE                                                   
*         IMATO(N)=IMAT(N)                                              
* 180   CONTINUE                                                        
        DO 185 N=1,NP
           NDRYO(N)=NDRY(N)                                              
  185   CONTINUE                                                        
        IENT=1                                                          
      ENDIF                                                             
*-                                                                      
* ... Reset mat types                                                 
*-                                                                      
      DO 250 N=1,NE                                                     
         IMAT(N)=IABS(IMAT(N))                                           
         IF (IMAT(N) .EQ. 0) GO TO 250                                    
         NCN=NCORN(N)                                                    
         DO 230 M=1,NCN,2                                                
            L=IABS(NOP(N,M))                                              
            IF (VEL(3,L) .GT. AKP(L)*ADB(L)) GO TO 250                     
  230    CONTINUE                                                        
         IMAT(N)= -IABS(IMAT(N))                                          
  250 CONTINUE                                                          
*-
* ... Establish NDRY
*-
      DO 300 N=1,NP
         NDRY(N)=2
  300 CONTINUE
      DO 330 N=1,NE
         IF (IMAT(N) .LT. 1) GO TO 330
         NCN=NCORN(N)
         DO 320 M=1,NCN
            L=IABS(NOP(N,M))
  320       NDRY(L)=1
  330    CONTINUE
*-
* ... Set velocities = 0.0 for dry nodes
*-
      DO 390 L=1,NP
         IF (NDRY(L) .EQ. 1) GO TO 390
         DO 380 IA=1,3
            VEL(IA,L)=0.0
            VEL(IA,L)=0.0
  380    CONTINUE
  390 CONTINUE
*-
* ... Print list of changed elements and nodes
*-
      IF (IOUT .GT. 0) WRITE (IOUT,6005)
      WRITE (*,6005)
 6005 FORMAT (' THE FOLLOWING ELEMENTS HAVE BEEN ELIMINATED')
      NR=0
      IFLG=1
      DO 405 N=1,NE
         IF (IMAT(N) .GE. 0) GO TO 405
         IF (IMATO(N) .LT. 0) GO TO 405
         NR=NR+1
         IPT(NR)=N
  405 CONTINUE
      IF (NR .GT. 0) IFLG=2
      IF (NR .GT. 0 .AND. IOUT .GT. 0) WRITE (IOUT,6030) (IPT(N),N=1,NR)
      IF (NR .GT. 0) WRITE (*,6030) (IPT(N),N=1,NR)
 6030 FORMAT (10I5)
      IF (IOUT .GT. 0) WRITE (IOUT,6007)
      WRITE (*,6007)
 6007 FORMAT (' THE FOLLOWING ELEMENTS HAVE BEEN ADDED')
      NR=0
      DO 410 N=1,NE
         IF (IMAT(N) .LE. 0) GO TO 410
         IF (IMATO(N) .GT. 0) GO TO 410
         NR=NR+1
         IPT(NR)=N
  410 CONTINUE
      IF (NR .GT. 0) IFLG=2
      IF (NR .GT. 0) WRITE (*,6030) (IPT(N),N=1,NR)
      WRITE (*,6008)
      IF (IOUT .GT. 0) THEN
         IF (NR .GT. 0) WRITE (IOUT,6030) (IPT(N),N=1,NR)
         WRITE (IOUT,6008)
 6008    FORMAT (' THE FOLLOWING NODES HAVE BEEN ELIMINATED')
      ENDIF
      NR=0
      DO 415 N=1,NP
        IF (NDRY(N) .EQ. 1) GO TO 415
        IF (NDRYO(N) .NE. 1) GO TO 415
        NR=NR+1
        IPT(NR)=N
  415 CONTINUE
      IF (NR .GT. 0) IFLG=2
      IF (IOUT .GT. 0) THEN
         IF (NR .GT. 0) WRITE (IOUT,6030) (IPT(N),N=1,NR)
         WRITE (IOUT,6009)
      ENDIF
      IF (NR .GT. 0) WRITE (*,6030) (IPT(N),N=1,NR)
      WRITE (*,6009)
 6009 FORMAT (' THE FOLLOWING NODES HAVE BEEN ADDED')
      NR=0
      DO 420 N=1,NP
         IF (NDRY(N) .NE. 1) GO TO 420
         IF (NDRYO(N) .EQ. 1) GO TO 420
         NR=NR+1
         IPT(NR)=N
  420 CONTINUE
      IF (NR .GT. 0) IFLG=2
      IF (NR .GT. 0 .AND. IOUT .GT. 0) WRITE (IOUT,6030) (IPT(N),N=1,NR)
      IF (NR .GT. 0) WRITE (*,6030) (IPT(N),N=1,NR)
      DO 450 N=1,NE
         IMATO(N)=IMAT(N)
  450 CONTINUE
      DO 500 N=1,NP
         NDRYO(N)=NDRY(N)
  500 CONTINUE
      RETURN
      END
*-
      SUBROUTINE FILE
*-
      SAVE
*-
* ... Open files as requested by input
*-
      INCLUDE 'hsctm.inc'
*-
      DATA VOID /-1.0E20/
*-
* ... NSCR variable is SCRATCH file assignment
*-
      NSCR = 9
*-
* ... Initialize arrays and variables
*-
      MAXFIL = 0
      MAXP = MND
      MAXE = MEL
      DO 400 N = 1,MAXE
         TH(N) = 0.0
         XAREA(N) = 0.0
         IHORD(N) = 0
         CHEZ(N) = 0.0
         ZMANN(N) = 0.0
         SIDF(N) = 0.0
         DO 300 M = 1,8
             NOP(N,M) = 0
  300    CONTINUE
         DO 350 M = 1,5
            ORT(N,M) = 0.0
  350    CONTINUE
  400 CONTINUE
*-
          DO 700 J = 1,MAXP
             IF (NCON .EQ. 1) THEN
                IF (METRIC .EQ. 0) DEN(J) = 1.935
                IF (METRIC .GE. 1) DEN(J) = 1.935*516.0
             ENDIF
             NSPREF(J) = 0.0
             HEL(J)    = 0.0
             HOL(J)    = 0.0
             WSEL(J)   = 0.0
             HDET(J)   = 0.0
             HDOT(J)   = 0.0
             ISTLIN(J) = 0
             WIDTH(J)  = 0.0
             WIDS(J)   = 0.0
             SS1(J)    = 0.0
             SS2(J)    = 0.0
             NDRY(J)   = 1
             CORD(J,1) = VOID
             CORD(J,2) = VOID
             AO(J)     = 0.0
             ALFA(J)   = 0.0
             ALFAK(J)  = 0.0
             SIGMA(J,1) = 0.0
             SIGMA(J,2) = 0.0
             NFIX(J)    = 0
             NLOC(J)    = 0
             NFIXH(J)   = 0
             DO 650 K = 1,NDF
                SPEC(J,K) = 0.0
                NBC(J,K)  = 0
                VDOT(K,J) = 0.0
                VOLD(K,J) = 0.0
                VDOTO(K,J)= 0.0
                VEL(K,J)  = 0.0
  650        CONTINUE
  700        CONTINUE
      RETURN
      END
*-
      SUBROUTINE FLDIR
*-
      SAVE
*-
* ... Routine to establish flow directions for one-dimensional elements
* ... Flow into a nodal junction will generate -1. for DIR
*-
      INCLUDE 'hsctm.inc'
*-
      DIMENSION ITAB(MND)
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED FLDIR'
*-
* ... Analyze the elements for connections
*-
      DO 180 N=1,NP
         ITAB(N)=0
  180 CONTINUE
      DO 220 M=1,NE
         IF (IMAT(M) .EQ. 0 .OR. IABS(IMAT(M)) .GT. 900) GO TO 220
         NM=IABS(IMAT(M))
         IF (ORT(NM,1) .EQ. 0.0) GO TO 220
         IF (NOP(M,6) .EQ. 0) THEN
            DO 200 K=1,3,2
               N1=NOP(M,K)
               ITAB(N1)=M
  200       CONTINUE
         ENDIF
  220 CONTINUE
      DO 500 N=1,NE
         IF (IMAT(N) .GT. 900) THEN
*-
* ... Select a node to establish direction
*-
          DO 400 K=1,8
            NRF=NOP(N,K)
            IF (NRF .EQ. 0) GO TO 450
*-
* ... Search other elements for junction nodes
*-
            M=ITAB(NRF)
            IF (M .EQ. 0 .OR. M .GT. NE) GO TO 700
                DO 250 L=1,3,2
                  IF (NOP(M,L) .EQ. NRF) THEN
*-
* ... When match is found get slope with respect to 's'
*-
                    IF (L .EQ. 1) THEN
                      L3=NOP(M,3)
                    ELSE
                      L3=NOP(M,1)
                    ENDIF
                    DX=(CORD(L3,1)-CORD(NRF,1))/2.0
                    DY=(CORD(L3,2)-CORD(NRF,2))/2.0
                    IF (ABS(DX) .GT. ABS(DY)) THEN
                      IF (DX .LT. 0.0) THEN
                        DIR(NRF)= -1.0
                      ELSE
                        DIR(NRF)=1.0
                      ENDIF
                    ELSE
                      IF (DY .LT. 0.0) THEN
                        DIR(NRF)= -1.0
                      ELSE
                        DIR(NRF)=1.0
                      ENDIF
                      IF (TF(ALFA(NRF)) .LT. 0.0) DIR(NRF)= -DIR(NRF)
                    ENDIF
                  ENDIF
  250           CONTINUE
  400     CONTINUE
  450     CONTINUE
        ENDIF
  500 CONTINUE
      RETURN
  700 WRITE (*,720) NRF,M,(N,ITAB(N),N=1,NP)
  720 FORMAT('  ERROR IN ELEMENT CONNECTIONS DETECTED IN FLDIR'/
     &       '  MATCHING NODE',I6,'  ELEMENT APPARENTLY',I5/
     &       '  TABLE OF ELEMENTS CONNECTED TO NODES AS FOLLOWS'/
     &       5(I8,I6))
      STOP 'ERROR'
      END
*-
      FUNCTION TF (A)
*-
      S=SIN(A)
      C=COS(A)
      IF (C .NE. 0.0) THEN
         TF=S/C
      ELSEIF (S .LT. 0.0) THEN
         TF= -1.0E20
      ELSE
         TF=1.0E20
      ENDIF
      RETURN
      END
*-
      SUBROUTINE FRONT2
*-
      SAVE
*-
* ... FRONTAL ELIMINATION ROUTINE USING FULL PIVOTING
*-
      INCLUDE 'hsctm.inc'
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED FRONT2'
*-
  100 FORMAT (/10X,'FROM CALL SECOND DELTA T =',F10.1,
     &                ' TOTAL T =',F10.1)
      NEC   = 0
      IRTC  = 0
      LQ    = 0
      NRR   = 0
      LCMAX = 0
      NMAX  = MFW
*-
* ... Initialize
*-
      NELL = 0
      DO 110 N = 1,NSZF
         R1(N) = 0.0
  110 CONTINUE
      DO 120 N = 1,NMAT
         TVOL(N) = 0.0
  120 CONTINUE
      LCOL = 0
      DO 130 I = 1,NMAX
        DO 130 J = 1,NMAX
          EQ(J,I) = 0.0
  130 CONTINUE
  140 NELL = NELL+1
      IF (NELL .GT. NE) GO TO 470                      
      N = NFIXH(NELL)
      IF (IMAT(N) .LE. 0) GO TO 140                                     
      NM = IMAT(N)                                                      
      IF (NM .LT. 901) THEN                                             
          IF (ORT(NM,1) .EQ. 0.0) GO TO 140
      ENDIF                                                            
*
      IF (NCORN(N) .LT. 6 .OR. NM .GT. 900) THEN                        
          CALL COEF1 (N,1)                                              
      ELSE                                                              
          OMEGA = OMEGAS(N)                                             
          CALL COEFS (N,1)                                              
      ENDIF                                                            
*
      NBN = NCN*NDF                                                   
      DO 150 LK = 1,NBN                                                
         LDEST(LK) = 0                                                  
         NK(LK) = 0                                                     
  150 CONTINUE                                                          
      KC = 0                                                            
      DO 170 J = 1,NCN                                                 
         I = NOP(N,J)                                                   
         DO 160 L = 1,NDF                                              
            LL = NBC(I,L)                                               
            KC = KC+1                                                 
            NK(KC) = LL                                                 
            IF (LL .EQ. 0) GO TO 160                                    
            IF (NLSTEL(LL) .EQ. N) NK(KC) = -LL                       
  160    CONTINUE                                                       
  170 CONTINUE                                                          
*-
* ... SET UP HEADING VECTORS
*-
      DO 220 LK = 1,NBN                                                
         NODE = NK(LK)                                                  
         IF (NODE .EQ. 0) GO TO 220                                     
         IF (LCOL .EQ. 0) GO TO 190                                     
         DO 180 L = 1,LCOL                                             
            LL = L                                                      
            IF (IABS(NODE) .EQ. IABS(LHED(L))) GO TO 200                
  180    CONTINUE                                                       
  190    LCOL = LCOL+1                                                
         LDEST(LK) = LCOL                                               
         LHED(LCOL) = NODE                                              
         GO TO 210                                                      
  200    LDEST(LK) = LL                                                 
         LHED(LL) = NODE                                                
  210    CONTINUE                                                       
  220 CONTINUE
      IF (LCOL .GT. LCMAX) LCMAX = LCOL
      IF (LCOL .LE. NMAX) GO TO 240
      NERROR = 2
      PRINT 225,NERROR
      PRINT 230,NFIXH(NELL)
      IF (IOUT .GT. 0) WRITE (IOUT,225) NERROR
  225 FORMAT (/'NERROR=',I5//,
     &           ' THE VALUE NMAX IS NOT SUFFICIENTLY LARGE',/,
     &           ' TO PERMIT THE ASSEMBLY OF THE NEXT ELEMENT---',/,
     &           ' INCREASE NMAX OR OR CHECK FOR ORDERING ERROR'/)
      IF (IOUT .GT. 0) WRITE (IOUT,230) NFIXH(NELL)
  230 FORMAT (//10X,'..STOP AT ELEMENT',I10)
      CALL ZVRS (1)
      STOP 'FRONT2'
*-
  240 CONTINUE
      DO 260 K = 1,NBN
         IF (NK(K) .EQ. 0) GO TO 260
         KK = LDEST(K)
         DO 250 L = 1,NBN
            IF (NK(L) .EQ. 0) GO TO 250
            LL = LDEST(L)
            EQ(LL,KK) = EQ(LL,KK)+ESTIFN(K,L)
  250    CONTINUE
  260 CONTINUE
*-
* ... FIND OUT WHICH MATRIX ELEMENTS ARE FULLY SUMMED
*-
  270 LPIVCO = 0
      PIVOT = 0.0
      DO 280 L = 1,LCOL
         IF (LHED(L) .GT.-1) GO TO 280                               
         PIVA = EQ(L,L)                                                 
         IF (ABS(PIVA) .LT. ABS(PIVOT)) GO TO 280                       
         PIVOT = PIVA                                                   
         LPIVCO = L                                                     
  280 CONTINUE                                                          
      IF (LPIVCO .EQ. 0) GO TO 140                                      
      IF (ABS(PIVOT) .LT. 1.0E-10) GO TO 140                           
*-
* ... NORMALIZE PIVOTAL ROW
*-
      LCO = IABS(LHED(LPIVCO))                                          
      IF (ABS(PIVOT) .LT. 1.0E-010) THEN                  
          IF (IOUT .GT. 0) WRITE (IOUT,610)                               
          PRINT 610                                                     
      ENDIF                                                             
      DO 290 L = 1,LCOL                                                
         QQ(L) = EQ(L,LPIVCO)/PIVOT                                   
  290 CONTINUE                                                          
      RHS = R1(LCO)/PIVOT                                             
      R1(LCO) = RHS                                                     
      PVKOL(LPIVCO) = PIVOT                                             
*                                                                       
* ... ELIMATE THEN DELETE PIVOTAL ROW AND COLUMN                        
*                                                                       
      IF (LPIVCO .EQ. 1) GO TO 350                                      
      LPIVR = LPIVCO-1                                                
      DO 340 K = 1,LPIVR                                               
        KRW = IABS(LHED(K))                                             
        FAC = EQ(LPIVCO,K)                                              
        PVKOL(K) = FAC                                                  
        IF (LPIVCO .EQ. 1 .OR. FAC .EQ. 0.0) GO TO 310                   
        LPIVC = LPIVCO-1                                              
        DO 300 L = 1,LPIVC                                             
           EQ(L,K) = EQ(L,K)-FAC*QQ(L)                              
  300   CONTINUE                                                        
  310   IF (LPIVCO .EQ. LCOL) GO TO 330                                 
        LPIVC = LPIVCO+1                                              
        DO 320 L = LPIVC,LCOL                                          
           EQ(L-1,K) = EQ(L,K)-FAC*QQ(L)                            
  320   CONTINUE                                                        
  330   R1(KRW) = R1(KRW)-FAC*RHS                                   
  340 CONTINUE                                                          
  350 IF (LPIVCO .EQ. LCOL) GO TO 410                                   
      LPIVR = LPIVCO+1                                                
      DO 400 K = LPIVR,LCOL                                            
         KRW = IABS(LHED(K))                                            
         FAC = EQ(LPIVCO,K)                                             
         PVKOL(K) = FAC                                                 
         IF (LPIVCO .EQ. 1) GO TO 370                                   
         LPIVC = LPIVCO-1                                             
         DO 360 L = 1,LPIVC                                            
            EQ(L,K-1) = EQ(L,K)-FAC*QQ(L)                           
  360    CONTINUE                                                       
  370    IF (LPIVCO .EQ. LCOL) GO TO 390                                
         LPIVC = LPIVCO+1                                             
         DO 380 L = LPIVC,LCOL                                         
            EQ(L-1,K-1) = EQ(L,K)-FAC*QQ(L)                         
  380    CONTINUE                                                       
  390    R1(KRW) = R1(KRW)-FAC*RHS                                  
  400 CONTINUE                                                          
  410 CONTINUE                                                          
*-
* ... WRITE PIVOTAL EQUATION ON DISK
*-
      NEC = NEC+1                                                     
      LCS(NEC) = LCOL                                                   
      LPS(NEC) = LPIVCO                                                 
      DO 420 L = 1,LCOL                                                
         LQ = LQ+1                                                    
         LHS(LQ) = LHED(L)                                              
         QS(LQ) = QQ(L)                                                 
  420 CONTINUE                                                          
      IF (LQ .LT. LBMAX-NMAX) GO TO 430                               
      IRTC = IRTC+1                                                   
      CALL XWRT (-1,NRR)                                          
      LQ = 0                                                            
  430 CONTINUE                                                   
      DO 440 L = 1,LCOL                                                
         EQ(L,LCOL) = 0.0
         EQ(LCOL,L) = 0.0
  440 CONTINUE
*-
* ... REARRANGE HEADING VECTORS
*-
      LCOL = LCOL-1
      IF (LPIVCO .EQ. LCOL+1) GO TO 460
      DO 450 L = LPIVCO,LCOL
         LHED(L) = LHED(L+1)
  450 CONTINUE
  460 CONTINUE
*-
* ... DETERMINE WHETHER TO ASSEMBLE, ELIMINATE, OR BACKSUBSTITUTE
*-
      IF (LCOL .GT. 0) GO TO 270
      GO TO 140
  470 CONTINUE
      IF (LCOL .GT. 0) THEN                                             
        WRITE (*,480) LCOL                                              
        WRITE (*,479) LPIVCO,PIVOT                                     
  479   FORMAT ('  VARIABLES   LPIVCO=',I8,'  PIVOT=',I8)                
        IF (IOUT .GT. 0) THEN                                             
            WRITE (IOUT,480) LCOL                                       
  480       FORMAT ('  UNSATISFIED ELIMINATION ERROR STOP',/,        
     &              '   LCOL =',I5)                                   
            WRITE (IOUT,490) (LHED(L),L = 1,LCOL)                     
            WRITE (IOUT,510) (EQ(L,L),L = 1,LCOL)                     
        ENDIF
  490   FORMAT ('  CONTENTS OF LHED ARE (EQUATION NUMBERS) ',/,(5I8))
        WRITE (IOUT,500) (N,(NBC(N,M),M = 1,3),N = 1,NP)
  500   FORMAT ('  NODE # ...  NBC ARRAY (EQN NO) IS '/(4I8))
  510   FORMAT ('  EQ IS'/(1P5E12.4))
        CALL ZVRS (1)
        WRITE (*,520)
  520   FORMAT (' INSIDE FRONT2 - UNSATISFIED ELIMINATION ERROR-STOP')
        STOP 'ERROR'
      ENDIF
*     WRITE (*,530) IRTC,LQ
      IF (LCOL .GT. 0) WRITE (*,*) LHED(1),EQ(1,1)
      IF (IOUT .GT. 0) WRITE (IOUT,530) IRTC,LQ
  530 FORMAT (/I10,' BUFFER BLOCKS WRITTEN.  FINAL LQ SIZE =',I10)
      IF (IOUT .GT. 0) WRITE (IOUT,540) LCMAX
  540 FORMAT (/,I10,' IS THE MAXIMUM FRONT WIDTH')
*     IF (IOUT .GT. 0) WRITE (IOUT,550) SELT
  550 FORMAT (/50X,'TIME IN COEFS =',F6.1)
*-
* ... BACK SUBSTITUTION
*-
      NEC = NSZF+1
      DO 590 IVQ = 1,NSZF                                  
         NEC = NEC-1                                                  
         LCOL = LCS(NEC)                                                
         LPIVCO = LPS(NEC)                                              
         LQ = LQ-LCOL                                                 
         IF (LQ .GT.-1) GO TO 560
         CALL XRED (NRR)                                     
         LQ = LQ-LCOL                                                 
  560    DO 570 L = 1,LCOL                                             
            LQ = LQ+1                                                 
            LHED(L) = LHS(LQ)                                           
            QQ(L) = QS(LQ)                                              
  570    CONTINUE                                                       
         LQ = LQ-LCOL                                                 
         LCO = IABS(LHED(LPIVCO))                                       
         GASH = 0.0
         QQ(LPIVCO) = 0.0
         DO 580 L = 1,LCOL
            ITEMP = IABS(LHED(L))
            GASH = GASH-QQ(L)*R1(ITEMP)
  580    CONTINUE
         R1(LCO) = R1(LCO)+GASH
  590 CONTINUE
      RETURN
  610 FORMAT (' WARNING-MATRIX SINGULAR OR ILL CONDITIONED')
      END
*-
      SUBROUTINE HGEN (J,HREQ)
*-
      SAVE
*-
* ... Generate specified head boundary conditions
*-
      INCLUDE 'hsctm.inc'
*-
* ... Insert values into SPEC and NFIX arrays
*-
      IF (ITRACE .GE. 1) THEN
*          WRITE (IOUT,9945) J,HREQ,LMT(J),LINE(J,1),LINE(J,2)
* 9945     FORMAT (' = CALLED HGEN (J,HREQ=',I5,F8.3,')',3I10)
          PRINT *,'              IRVIZ=',IRVIZ,' IRVOLD=',IRVOLD,
     &                           'ICYC=',ICYC,' IHGEN=',IHGEN
      ENDIF
      MAX=LMT(J)
      DO 300 K=1,MAX
         NA=LINE(J,K)
         SPEC(NA,3)=HREQ
         IF (MOD(NFIX(NA),1000) .LT. 200) THEN
            NFIX(NA)=NFIX(NA)+200
         ENDIF
         IF (ICYC .GT. 0 .OR. IRVOLD .GE. 1) CALL BFORM (NA)
  300 CONTINUE
      RETURN
      END
*-
      SUBROUTINE INPUTP (NEX)
*-
      SAVE
*-
*      Modified to avoid duplicate marsh porosity offsets tO
*      bottom elevation:
*          If IDMN(NODE) = 0 then default parameters are used
*          IF IDMN(NODE) = 1 then the override valus will be used
*          These values of IDMN are set in PREHYD for DM* cards
*-
      INCLUDE 'hsctm.inc'
*-
      COMMON /CNTRL/ LE,LPP
      DIMENSION ELVVV(MND),DEPVV(MND)
      DATA VOID /-1.0E20/
      DATA A1A,A2A,A3A/1.939938,5.588599E-5,-1.108539E-5/
*-
*       IDNOPT
* =  0  Do not use marsh elements
* = -1  Use default values for (below AO), RANGE, AKAPM and/or (abs AO)
* = -2  Input default values of (below AO), RANGE, AKAPM and/or (abs AO)
* =  N  input default (optional) and N nodal values
*               of (below AO), RANGE, AKAPM and/or (abs AO)
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED INPUTP (NEX=', NEX, ')'
*-
      MMM1 = MND
      MMM2 = MEL
      MMM3 = MR1
      MMM6 = MFW
      MMM7 = MCC
      MMM8 = NBS
      MMM9 = MPB
*-
* ... NEX = 0 MEANS STEADY STATE INITIALIZATION
* ... NEX = 1 MEANS CONTINUATION OF STEADY STATE VIA REV-CARD
* ... NEX = 2 MEANS DYNAMIC TIME STEP
* ... NEX = 3 MEANS THIS DYNAMIC TIME STEP IS REVISED
*-
      IF (NEX .EQ. 2) GO TO 770
*-
      IF (NEX .EQ. 1 .OR. NEX .EQ. 3) THEN
         IF (IOUT .GT. 0) THEN
*         WRITE (IOUT,990)
*         WRITE (IOUT,1000) NEX,TET
*         WRITE (IOUT,1020) TITLE
         WRITE (IOUT,1030) NE,NMAT,NPX,NBX,NWID,NSID,IPRT,NCL,
     &                     IWIND,IRO,IRSLP,IQGEN,IHGEN,ISTGEN,
     &                     NCFLW,IDNOPT
         WRITE (IOUT,1040) IHOTN,IHOTO,IGEON,IFINO,NTBIN,IBUP,NSCR
         WRITE (IOUT,1050) OMEGA,ELEV,XSCALE,ZSCALE,DSET,
     &                     DSETD,SSDCRT,USDCRT,UNOM,HMIN,TEMPC
         WRITE (IOUT,1060) NITI,NITN,MBAND,NSTART,NCYC,DELT,
     &                     TMAX,LI,ITSI,ISPRT,JSPLPT,IHOE,IDEN
         WRITE (IOUT,1070)
         WRITE (IOUT,1080)
         ENDIF
         DO 100 J = 1,MAXE
            IF (IMAT(J) .LT. 1) GO TO 100
            IF (IMAT(J) .GT. 900) GO TO 100
            IF (ORT(IMAT(J),5) .GT. 3.0) THEN                              
               CHEZ(J) = ORT(IMAT(J),5)                                  
            ELSE                                                          
               ZMANN(J) = ORT(IMAT(J),5)                                 
            ENDIF
            IF (ORT(J,1) .NE. 0.0 .AND. ORT(J,5) .NE. 0.0 .AND. 
     &         IOUT .GT. 0) WRITE (IOUT,1090) J,(ORT(J,K),K=1,5)
  100   CONTINUE
        CALL SBGENP (NEX)
*-
        INITSV = NITSV
        CALL BLINE (INITSV)
*-
        IF (NBX .GT. 0) THEN                                            
          IF (IOUT .GT. 0) WRITE (IOUT,1210) TTT,NITSV                   
          DO 110 K = 1,NBX                                             
             IF (NFIX(K) .GT.-1) GO TO 110                            
             J = KNBX(K)                                                 
             NFIX(J) = -NFIX(J)                                        
* ... Setup for boundary conditions                               
             IF (IOUT .GT. 0)                                              
     &       WRITE (IOUT,1220) J,NFIX(J),(SPEC(J,M),M = 1,3)         
             CALL BFORM (J)                                               
  110        CONTINUE                                                      
        ENDIF
*-
* ... Preserve NFIX
*-
        DO 120 J = 1,NP                                                
           NFIXP(J) = NFIX(J)                                           
  120   CONTINUE                                                        
*-
        RETURN                                                          
      ENDIF                                                            
*-
* ... Initialize arrays not covered by input
*-
      IPLI   = 0
      IBIN   = INOLD
      MAXP   = MND
      MAXE   = MEL
      LE     = MAXE
      LPP    = MAXP
      TET    = 0.0
      KWIND  = 0
      NITSV  = 0
*-
* ... Read and print title and run control
*-
      IF (IOUT .GT. 0) THEN
         WRITE (IOUT,1200) VERRM2(1),VERRM2(2),MMM1,MMM2,MMM3,
     &                     MMM6,MMM7,MMM8,MMM9
*-
         WRITE (IOUT,1030) NE,NMAT,NPX,NBX,NWID,NSID,IPRT,
     &                     NCL,IWIND,IRO,IRSLP,IQGEN,IHGEN,
     &                     ISTGEN,NCFLW,IDNOPT
         WRITE (IOUT,1040) IHOTN,IHOTO,IGEON,IFINO,NTBIN,IBUP,NSCR
      ENDIF
*-
      CALL ZVRS (0)
*-
      IF (IGEON .GT. 0) REWIND IGEON
      IF (IFINO .GT. 0) REWIND IFINO
      IF (XSCALE .EQ. 0.0) XSCALE = 1.0
      IF (ZSCALE .EQ. 0.0) ZSCALE = 1.0
      YSCALE = XSCALE
      IF (IOUT .GT. 0)
     &   WRITE (IOUT,1050) OMEGA,ELEV,XSCALE,ZSCALE,DSET,DSETD,
     &                     SSDCRT,USDCRT,UNOM,HMIN,TEMPC
      IF (UNOM .EQ. 0.0) UNOM = 0.25
      IF (IOUT .GT. 0)
     &   WRITE (IOUT,1060) NITI,NITN,MBAND,NSTART,NCYC,DELT,
     &                     TMAX,LI,ITSI,ISPRT,JSPLPT,IHOE,
     &                     IDEN,METRIC
      IF (METRIC .LE. 0) THEN
* ... ENGLISH UNITS COMING IN AND GOING OUT
           GRAV = 32.2                                                  
           FCOEF = GRAV/2.208                                         
      ELSEIF (METRIC .GE. 1) THEN
* ... METRIC UNITS COMING IN AND GOING OUT
           GRAV = 9.81
           FCOEF = GRAV
      ENDIF
      IF (ISPRT .GT. 0) THEN
        IF (NCYC*JSPLPT .GT. MMM9 .OR. JSPLPT .GT. MMM9) THEN
          IF (IOUT .GT. 0) WRITE (IOUT,130) NCYC,JSPLPT
  130     FORMAT ('  MAXIMUM SIZE OF PRINT BUFFER WILL BE EXCEEDED'
     &         /'  VALUES INPUT ARE:'
     &         /'          TIME STEPS     =',I8
     &         /'          PRINT NODES    =',I8
     &         /,'          ALLOWABLE SIZE =',I8)
          WRITE (*,130)
          STOP 'ERROR'
        ENDIF
        IF (IOUT .GT. 0) WRITE (IOUT,1130) (NSPLPT(J),J = 1,JSPLPT)
        DO 140 J = 1,JSPLPT
           NSPREF(NSPLPT(J)) = J
  140   CONTINUE
      ENDIF
      IF (LI .EQ. 0) IPLI = 1
      ROAVG = A1A+A2A*TEMPC+A3A*TEMPC**2
      IF (METRIC .GE. 1) ROAVG = ROAVG*516.0
      ITIN = IGEON
      IF (NE .GT. 0) ITIN = 0
      IF (NPX .GT. 0) ITIN = 0
*-
* ... ELEMENT CHARACTERISTICS
*-
      IF (IOUT .GT. 0) THEN
          WRITE (IOUT,1070)
          IF (METRIC .LE. 0) WRITE (IOUT,1080)                            
          IF (METRIC .GE. 1) WRITE (IOUT,1085)                            
          DO 150 J = 1,MAXE                                            
             IF (ORT(J,1) .NE. 0.0 .AND. ORT(J,5) .NE. 0.0)               
     &       WRITE (IOUT,1090) J,(ORT(J,K),K = 1,5)                  
  150     CONTINUE                                                      
*-
* ... Input/output lines for continuity checks
*-
         IF (NCL .GT. 0) THEN
*            WRITE (IOUT,990)
*            WRITE (IOUT,1020) TITLE
            WRITE (IOUT,1180)
            DO 180 J = 1,NCL
               NA = LMT(J)
               WRITE (IOUT,1190) J,(LINE(J,K),K = 1,NA)
  180       CONTINUE
         ELSE
            WRITE (IOUT,1170)
         ENDIF
      ENDIF
*-
* ... USE ELEMENT TYPES TO ASSIGN MANNINGS N IF VALUE LESS THAN 3.0
*-
      DO 220 I = 1,MAXE                                                
         IF (IMAT(I) .LT. 1) GO TO 220                                   
         IF (IMAT(I) .GT. 900) GO TO 220                                 
         J = IMAT(I)                                                     
         IF (ORT(J,5) .GT. 3.0) THEN                                     
            CHEZ(I) = ORT(J,5)                                          
        ELSE                                                            
            ZMANN(I) = ORT(J,5)                                         
        ENDIF                                                          
  220 CONTINUE                                                          
*-                                                                      
* ... FIND MAX NODE AND ELEMENT NUMBERS                            
*-                                                                      
      NP = 0                                                            
      DO 260 J = 1,MAXE                                                
        IF (NOP(J,1) .NE. 0) NE = J                                     
        IF (IMAT(J) .LE. 0) GO TO 260                                   
        IF (J .LT. LE) LE = J                                           
        DO 230 K = 8,1,-1                                           
          IF (NOP(J,K) .EQ. 0) GO TO 230                                
          NCORN(J) = K                                                  
          GO TO 240                                                     
  230   CONTINUE                                                        
        NCORN(J) = 0                                                    
  240   CONTINUE                                                        
        IF (NCORN(J) .GT. 5) THEN                                       
           IF (IHOE .GT. 0) IHORD(J) = 1                                 
        ENDIF                                                          
        NCN = NCORN(J)                                                  
        DO 250 K = 1,NCN                                               
          IF (NOP(J,K) .GT. NP) NP = NOP(J,K)                           
          IF (NOP(J,K) .LT. LPP) LPP = NOP(J,K)                   
  250   CONTINUE                                                        
  260 CONTINUE                                                          
      IF (IOUT .GT. 0) WRITE (IOUT,1250) NE,LE,NP,LPP                 
*-
* ... COORDINATE DATA FROM CARDS
*-
      IF (IDNOPT .EQ. 0) THEN                                           
         DO 290 N = 1,NP                                                
            ADB(N) = 0.0
            ADT(N) = 0.0
            AKP(N) = 1.0                                                  
  290   CONTINUE                                                        
        IF (IOUT .GT. 0) WRITE (IOUT,300)                                 
  300   FORMAT (// '  MARSH ELEMENTS INOPERATIVE')                     
      ELSE                                                              
        IF (IDNOPT .EQ. -1) THEN                                      
          AC3=0.02                                                      
          IF (METRIC .LE. 0) THEN                                      
* ... ENGLISH UNITS COMING IN AND GOING OUT                     
              AC1=3.0                                                  
              AC2=2.0                                                  
          ELSEIF (METRIC .GE. 1) THEN                                 
* ... METRIC UNITS COMING IN AND GOING OUT                      
              AC1 = 3.0*0.3048                                        
              AC2 = 2.0*0.3048                                        
          ENDIF                                                         
*-
          IF (IOUT .GT. 0) WRITE (IOUT,310) AC1,AC2,AC3                 
  310     FORMAT (// '  DEFAULT VALUES FOR MARSH ELEMENTS USED',      
     &            /'      DEPTH SHIFT',F8.2                         
     &            /'      RANGE      ',F8.2                         
     &            /'      KAPPA      ',F8.2)                        
* ... change ELSE to ENDIF + IF
        ENDIF                                                          
        IF (IDNOPT .EQ.-2) THEN                                      
* ... end of change                                                 
* ===     READ (INOLD,xxxx) J,AC1,AC2,AC3,AC4                            
          AC1 = WDMC1(1)                                                
          AC2 = WDMC2(1)                                                
          AC3 = WDMC3(1)                                                
          AC4 = WDMC4(1)                                                
          IF (IOUT .GT. 0) WRITE (IOUT,320) AC1,AC2,AC3,AC4            
  320     FORMAT (// '  INPUT VALUES FOR MARSH ELEMENTS USED',        
     &            /'      DEPTH SHIFT',F8.2                         
     &            /'      RANGE      ',F8.2                         
     &            /'      KAPPA      ',F8.2                         
     &            /,'      ABS A0     ',F8.2)                        
        ENDIF                                                          
*-
* ... Alter bottom elevation values for dry node coding
*-
        DO 330 N = 1,NP
           ADB(N) = AO(N)
           ADT(N) = AO(N)                                                
           AKP(N) = 1.0                                                  
           ADO(N) = AO(N)                                                
  330   CONTINUE                                                        
        DO 360 J = 1,NE                                                
           IF (IMAT(J) .NE. 0) THEN                                      
              NCN = NCORN(J)                                              
              IF (IMAT(J) .GT. 900) GO TO 360                             
              IF (NCN .EQ. 5) NCN = 3                                     
              DO 350 K = 1,NCN,2                                        
                 N = NOP(J,K)                                              
              DO 340 L = 1,NCN,2                                      
                 M = NOP(J,L)                                           
                 IF (ADO(N) .GT. AO(M)) ADO(N) = AO(M)                  
  340         CONTINUE                                                  
              ADB(N) = AO(N)-AC2/2.0                                 
              AKP(N) = AC3                                              
  350       CONTINUE                                                    
          ENDIF                                                        
  360   CONTINUE                                                        
        DO 370 N = 1,NP                                                
* ... add cond transfer based on IDMN for each node
          IF (IDMN(N) .GT. 0) GO TO 370                                 
          IF (AC1 .GT. 0.0) THEN                                         
            IF (AKP(N) .LT. 0.95) THEN                                  
              ADB(N) = ADB(N)+(AO(N)-ADO(N)+AC1)*AKP(N)/      
     &             (1.0-AKP(N))                                        
            ENDIF                                                      
            AO(N) = ADO(N)-AC1                                        
          ELSE                                                          
            IF (AKP(N) .LT. 0.95) THEN                                  
              ADB(N) = ADB(N)+(AO(N)-AC4)*AKP(N)/(1.0-AKP(N))    
            ENDIF                                                      
            AO(N) = AC4                                                 
          ENDIF                                                        
          ADB(N) = ADB(N)-AO(N)                                       
          ADT(N) = ADB(N)+AC2                                         
  370   CONTINUE                                                        
        IF (IDNOPT .GT. 0) THEN                                         
          IF (IOUT .GT. 0) WRITE (IOUT,380)                               
  380     FORMAT (// '  OVERRIDING PARAMETERS USED FOR MARSH ELEMENTS' 
     &         // '      NODE   DEPTH-SHIFT',9X,'RANGE',9X,'KAPPA' 
     &       ,8X,'ABS A0'/)
*-
          DO 400 N = 1,NP                                              
            IF (IDMN(N) .LE. 0) GO TO 400                               
* ===       READ (INOLD,xxxx) J,AC1,AC2,AC3,AC4                          
            NODE = N                                                    
            J = NODE                                                    
            AC1 = WDMC1(J)                                              
            AC2 = WDMC2(J)                                              
            AC3 = WDMC3(J)                                              
            AC4 = WDMC4(J)                                              
            IF (IOUT .GT. 0) WRITE (IOUT,390) J,AC1,AC2,AC3,AC4       
  390       FORMAT (I10,4F14.2)                                        
            IF (J .LE. 0) GO TO 410                                     
            IF (AC1 .GT. 0.0) THEN                                       
              ADO(J) = AO(J)-AC1                                      
            ELSE                                                        
              ADO(J) = AC4                                              
            ENDIF                                                      
            ADB(J) = AO(J)-AC2/2.0-ADO(J)                          
            IF (AC3 .LT. 0.95) THEN                                     
              ADB(J) = ADB(J)+(AO(J)-ADO(J))*AC3/(1.0-AC3)     
            ENDIF                                                      
            ADT(J) = ADB(J)+AC2                                       
            AKP(J) = AC3                                                
            AO(J) = ADO(J)                                              
  400     CONTINUE                                                      
  410     CONTINUE                                                      
        ENDIF                                                          
      ENDIF
*-
  420 CONTINUE
*-
* ... REORDER ARRAY
*-
* ... Fill reordering array if empty
*-
      IF (ITIN .GT. 0) GO TO 440
      IF (NFIXH(1) .EQ. 0) NFIXH(1) = 1                                 
      DO 430 N = 2,NE                                                  
         IF (NFIXH(N) .EQ. 0) NFIXH(N) = NFIXH(N-1)+1                 
  430 CONTINUE                                                          
*-
* ... COMPUTE MID-SIDE VALUES
*-
  440 CONTINUE                                                          
*-
* ... Force values of depth width etc equal for IMAT = 903
*-
      DO 450 N = 1,NE                                                  
        NM = IMAT(N)                                                    
        IF (NM .EQ. 903) THEN                                           
          N1 = NOP(N,1)                                                 
          N2 = NOP(N,2)                                                 
          AO(N1) = (AO(N1)+AO(N2))/2.0                               
          AO(N2) = AO(N1)                                               
          WIDTH(N1) = (WIDTH(N1)+WIDTH(N2))/2.0                      
          WIDTH(N2) = WIDTH(N1)                                         
          SS1(N1) = (SS1(N1)+SS1(N2))/2.0                            
          SS1(N2) = SS1(N1)                                             
          SS2(N1) = (SS2(N1)+SS2(N2))/2.0                            
          SS2(N2) = SS2(N1)                                             
          WIDS(N1) = (WIDS(N1)+WIDS(N2))/2.0                         
          WIDS(N2) = WIDS(N1)                                           
        ENDIF                                                          
  450 CONTINUE                                                          
      IERR = 0                                                          
      DO 470 J = 1,NE                                                  
        IF (IMAT(J) .EQ. 0) GO TO 470                                   
        NM = IABS(IMAT(J))                                              
        IF (NM .GT. 900) GO TO 470                                      
        IF (ORT(NM,1) .EQ. 0.0) GO TO 470                                
        NCN = NCORN(J)                                                  
        IF (NCN .EQ. 5) THEN                                            
          N1 = NOP(J,4)                                                 
          N2 = NOP(J,3)                                                 
          N3 = NOP(J,5)                                                 
          AO(N2) = 0.5*(AO(N1)+AO(N3))
          IF (CORD(N2,1) .LE. VOID) THEN
            CORD(N2,1) = 0.5*(CORD(N1,1)+CORD(N3,1))                
            CORD(N2,2) = 0.5*(CORD(N1,2)+CORD(N3,2))                
          ENDIF                                                        
          NCN = 3                                                       
        ENDIF                                                          
        DO 460 K = 2,NCN,2                                            
          N1 = NOP(J,K-1)                                               
          N2 = NOP(J,K)                                                 
          N3 = MOD(K+1,NCN)                                             
          IF (N3 .EQ. 0) N3 = NCN                                       
          N3 = NOP(J,N3)                                                
          AO(N2)  = 0.5*(AO(N1)+AO(N3))                             
          ADB(N2) = 0.5*(ADB(N1)+ADB(N3))                           
          ADT(N2) = 0.5*(ADT(N1)+ADT(N3))                           
          AKP(N2) = 0.5*(AKP(N1)+AKP(N3))                           
          IF (NCN .EQ. 3) THEN                                          
             IF (WIDTH(N1) .EQ. 0.0) THEN                                 
                IF (IOUT .GT. 0) WRITE (IOUT,1230) N1,WIDTH(N1)            
                IERR = 1                                                  
             ENDIF                                                      
             IF (WIDTH(N3) .EQ. 0.0) THEN                                 
                IF (IOUT .GT. 0) WRITE (IOUT,1230) N3,WIDTH(N3)            
                IERR = 1                                                  
             ENDIF                                                      
          ENDIF                                                        
          IF (WIDTH(N1) .GT. 0.0 .AND. WIDTH(N3) .GT. 0.0) THEN           
             WIDTH(N2) = 0.5*(WIDTH(N1)+WIDTH(N3))                   
            WIDS(N2) = 0.5*(WIDS(N1)+WIDS(N3))                     
            SS1(N2) = 0.5*(SS1(N1)+SS2(N3))                       
            SS2(N2) = 0.5*(SS2(N1)+SS2(N3))                       
          ENDIF                                                        
          IF (CORD(N2,1) .LE. VOID) THEN                                
             CORD(N2,1) = 0.5*(CORD(N1,1)+CORD(N3,1))                
             CORD(N2,2) = 0.5*(CORD(N1,2)+CORD(N3,2))                
          ENDIF                                                        
  460   CONTINUE                                                        
  470 CONTINUE                                                          
      IF (IERR .EQ. 1) THEN                                             
        IF (IOUT .GT. 0) WRITE (IOUT,1240)                                
        WRITE (*,1240)                                                  
        STOP 'ERROR'                                                    
      ENDIF                                                            
*-
* ... Compute side slopes
* ... IBN contains counter for number of references to a node
*-
      DO 480 N = 1,NP
        IBN(N) = 0                                                      
  480 CONTINUE                                                          
      DO 500 N = 1,NE                                                  
        IF (IMAT(N) .GT. 0) THEN                                        
          NM = IABS(IMAT(N))                                            
          IF (NM .LT. 900) THEN
            IF (ORT(NM,1) .GT. 0.0) THEN
              NCN = NCORN(N)
              IF (NCN .EQ. 5) NCN = 3
              DO 490 M = 1,NCN
                K = IABS(NOP(N,M))
                IBN(K) = IBN(K)+1
  490         CONTINUE
            ENDIF
          ENDIF
        ENDIF
  500 CONTINUE
*-
* ... Apply scale factors
*-
      DO 510 J = 1,NP
        CORD(J,1) = CORD(J,1)*XSCALE
        CORD(J,2) = CORD(J,2)*YSCALE
        AO(J) = AO(J)*ZSCALE
  510 CONTINUE
*-
* ... Assign higher order to curved elements
*-
      DO 540 J = 1,NE
        IF (IMAT(J) .EQ. 0 .OR. IHORD(J) .GT. 1) GO TO 540              
        NM = IABS(IMAT(J))                                              
        IF (NM .GT. 900) GO TO 540                                      
        IF (ORT(NM,1) .EQ. 0.0) GO TO 540                                
        NCN = NCORN(J)                                                  
        IF (NCN .LT. 6) GO TO 540                                       
        DO 530 K = 1,NCN,2
          N1 = NOP(J,K)
          N2 = NOP(J,K+1)
          N3 = MOD(K+2,NCN)
          N3 = NOP(J,N3)
          XMID = 0.5*(CORD(N1,1)+CORD(N3,1))
          IF (ABS(XMID-CORD(N2,1)) .GT. 0.005) GO TO 520
          YM = 0.5*(CORD(N1,2)+CORD(N3,2))
          IF (ABS(YM-CORD(N2,2)) .LT. 0.005) GO TO 530
  520     IHORD(J) = 1
          GO TO 540
  530   CONTINUE
  540 CONTINUE
*-
      IF (IPRT .EQ. 0) THEN
        DO 550 N = 1,NE
          IF (IMAT(N) .NE. 0) THEN
            NM = IABS(IMAT(N))
            IF (NM .GT. 900) GO TO 550
            IF (ORT(NM,1) .EQ. 0.0) GO TO 550
            IF (NCORN(N) .LT. 6) THEN
              N1 = NOP(N,1)
              N2 = NOP(N,3)
              TH(N) = ATAN2(CORD(N2,2)-CORD(N1,2),CORD(N2,1)-CORD(N1,1))
              CALL COEF1 (N,0)
            ENDIF
          ENDIF
  550   CONTINUE
*-
* ... Get element sizes
*-
      ELSE
        DO 560 N = 1,NE
          IF (IMAT(N) .NE. 0) THEN
            NM = IABS(IMAT(N))
            IF (NM .GT. 900) GO TO 560
            IF (ORT(NM,1) .EQ. 0.0) GO TO 560
            IF (NCORN(N) .LT. 6) THEN
* ... First rotate element to new x-axis
              N1 = NOP(N,1)
              N2 = NOP(N,3)
              TH(N) = ATAN2(CORD(N2,2)-CORD(N1,2),CORD(N2,1)-CORD(N1,1))
              CALL COEF1 (N,0)
            ELSE
              OMEGA = OMEGAS(N)
              CALL COEFS (N,0)
            ENDIF
          ENDIF
  560   CONTINUE
*-
* ... PRINT ELEMENT AND COORDINATE DATA
*-
        IF (IOUT .GT. 0) THEN
*           WRITE (IOUT,990)                                             
*           WRITE (IOUT,1020) TITLE                                      
           WRITE (IOUT,1100)                                            
           IF (METRIC .LE. 0) WRITE (IOUT,1110)                          
           IF (METRIC .GE. 1) WRITE (IOUT,1115)                          
           INT = (NE-LE)+1                                          
           INTT = INT+LE-1                                          
           DO 580 J = LE,INTT                                          
              DO 570 N = J,NE,INT                                     
              WRITE (IOUT,1120) N,(NOP(N,M),M = 1,8),IMAT(N),      
     &           NFIXH(N),XAREA(N),TH(N),OMEGAS(N)                   
                 IF (XAREA(N) .LE. 0.0) WRITE (*,565) N                      
  565            FORMAT (' ---> ZERO OR NEGATIVE AREA FOR ELEMENT=',I8)  
  570         CONTINUE                                                  
  580      CONTINUE                                                     
       ENDIF                                                            
      ENDIF                                                            
      TOTAREA=0.0
      DO 9873 J=1,NE
         TOTAREA=TOTAREA+XAREA(J)
 9873 CONTINUE
*      WRITE (IOUT,9874) TOTAREA
* 9874 FORMAT (' TOTAL LAGOON AND INLET AREA =',F12.2)
      NEM = NE                                                          
      NPM = NP                                                          
*-
* ... INPUT INITIAL CONDITIONS, IF SPECIFIED
*-
      IF (IHOTN .EQ. 0) GO TO 650
      NXX = IHOTN
      IHOTN = IABS(IHOTN)
      IF (IHOTN .GE. 100) GO TO 630
*-
         REWIND IHOTN
*-
         READ (IHOTN) ITEST
         REWIND IHOTN                                                   
*-
         IF (ITEST .GT. 200) THEN                                         
* ... This is a true character variable type read                
             READ (IHOTN) (BANHTN(I),I=1,15)                           
             READ (IHOTN) (IHOT(I),I=1,40),(FHOT(I),I=1,40)            
         ELSE                                                           
* ... This must be an integer style character-- so convert       
             READ (IHOTN) MFLG1,MFLG2,MFLG3,MFLG4                   
             READ (IHOTN) IWRT1,(IPACKB(I),I=1,IWRT1)                
             READ (IHOTN) IWRT2,IWRT3,                               
     &                    (IHOT(I),I=1,IWRT2),(FHOT(I),I=1,IWRT3)      
*-                                                                      
             CALL CONVRT (BANHTN,15,IPACKH,80,2)
         ENDIF                                                          
*-
         READ (IHOTN) TET,NPT,NE,NITSV,                                
     &                ((VEL(J,K),J=1,3),K=1,NPT),                      
     &                ((VDOT(J,K),J=1,3),K=1,NPT),                     
     &                ((VOLD(J,K),J=1,3),K=1,NPT),                     
     &                ((VDOTO(J,K),J=1,3),K=1,NPT),                    
     &                (NDRY(K),K=1,NPT),                               
     &                (HEL(K),HOL(K),HDET(K),HDOT(K),K=1,NPT),         
     &                (IMAT(K),K=1,NE)                                  
*-
         IF (IOUT .GT. 0) WRITE (IOUT,590) TET,(BANHTN(I),I=1,15),
     &                  (IHOT(I),I=1,10),(FHOT(I),I=1,10)
  590    FORMAT (//,30X,'BANNER HEADINGS ON HOTSTART HYDRO2 FILE',/,
     &     ' Time recorded on the hotstart file is =',F15.6,//,
     &     '  1) ',5(A80,/),'  2) ',5(A80,/),'  3) ',5(A80,/),
     &     10I6,/,10F6.1,/)
         PRINT *,' =+=+= Just finished reading binary HOTSTART'
*-
* ... END OF HOTSTART READ
*-
      IRVOLD = 1
*-
      DO 620 N = 1,NE
         NM = IABS(IMAT(N))
         IF (NM .GT. 900) GO TO 620
         IF (NM .EQ. 0) GO TO 620
         IF (ORT(NM,1) .EQ. 0.0) GO TO 620
         NCN = NCORN(N)
         IF (NCN .EQ. 5) THEN
         NCN = 3
         IF (IOUT .GT. 0) WRITE (IOUT,600) N
  600    FORMAT (' *** INITIAL CONDITION CORRECTED FOR ELEM=',I6)
        ENDIF
        DO 610 M = 2,NCN,2
           N1 = IABS(NOP(N,M-1))
           N2 = IABS(NOP(N,M))
           N3 = MOD(M+1,NCN)
           IF (NCN .EQ. 3) N3 = 3
           N3 = IABS(NOP(N,N3))
           VDOT(3,N2) = (VDOT(3,N1)+VDOT(3,N3))/2.0
           HDET(N2) = (HDET(N1)+HDET(N3))/2.0
  610   CONTINUE
  620 CONTINUE
*-
      IF (NXX .GT. 0) GO TO 690
*-
  630 CONTINUE
  650 IF (ISWIT .EQ. 1) THEN
*-
* ... Recalculate ELVV by linear interpolation for Maurice River, NJ
*-
         XSCA = 0.3048
         ZSCA = 0.3048
         ydsmr = 244272.00*XSCA
         yusmr = 245710.00*XSCA
         xleft = 329460.00*XSCA
         xrigh = 330716.00*XSCA
         xconf = 329287.08*XSCA
         yconf = 245026.70*XSCA
         xbbux = 339548.99*XSCA
*        ybbuy = 250409.57*XSCA
         ymruy = 251288.60*XSCA
         ygs2y = 241772.99*XSCA
         xgs1x = 330716.38*XSCA
*        ygs1y = 245446.62*XSCA
         xbb3x = 332025.75*XSCA
*        ybb3y = 247184.78*XSCA
         ymr1y = 248800.54*XSCA
         xbb2x = 334820.16*XSCA
         xbb1x = 336304.62*XSCA
         xbb0x = 337639.11*XSCA
         elvbbu = 69.50*ZSCA
         elvmru = 53.40*ZSCA
         elvcus = 49.00*ZSCA
         elvcds = 46.96*ZSCA
         elvcon = 48.50*ZSCA
         elvgs2 = 46.50*ZSCA
         elvgs1 = 52.90*ZSCA
         elvbb3 = 53.65*ZSCA
         elvbb2 = 58.40*ZSCA
         elvbb1 = 60.60*ZSCA
         elvbb0 = 64.00*ZSCA
         elvmr1 = 50.50*ZSCA
         DO 177 j = 1,NP
            IF (CORD(j,1) .GT. xbb0x) THEN
               ELVVV(j)=elvbb0+(elvbbu-elvbb0)*(CORD(j,1)-xbb0x)/
     &                  (xbbux-xbb0x)
               DEPVV(j)=dinigs1+(dinibbu-dinigs1)*(CORD(j,1)-xgs1x)/
     &                  (xbbux-xgs1x)
            ENDIF
            IF (CORD(j,1) .GT. xbb1x .AND. CORD(j,1) .LE. xbb0x) THEN
               ELVVV(j)=elvbb1+(elvbb0-elvbb1)*(CORD(j,1)-xbb1x)/
     &                  (xbb0x-xbb1x)
               DEPVV(j)=dinigs1+(dinibbu-dinigs1)*(CORD(j,1)-xgs1x)/
     &                  (xbbux-xgs1x)
            ENDIF
            IF (CORD(j,1) .GT. xbb2x .AND. CORD(j,1) .LE. xbb1x) THEN
               ELVVV(j)=elvbb2+(elvbb1-elvbb2)*(CORD(j,1)-xbb2x)/
     &                  (xbb1x-xbb2x)
               DEPVV(j)=dinigs1+(dinibbu-dinigs1)*(CORD(j,1)-xgs1x)/
     &                  (xbbux-xgs1x)
            ENDIF
            IF (CORD(j,1) .GT. xbb3x .AND. CORD(j,1) .LE. xbb2x) THEN
               ELVVV(j)=elvbb3+(elvbb2-elvbb3)*(CORD(j,1)-xbb3x)/
     &                  (xbb2x-xbb3x)
               DEPVV(j)=dinigs1+(dinibbu-dinigs1)*(CORD(j,1)-xgs1x)/
     &                  (xbbux-xgs1x)
            ENDIF
            IF (CORD(j,1) .GT. xrigh .AND. CORD(j,1) .LE. xbb3x) THEN
               ELVVV(j)=elvgs1+(elvbb3-elvgs1)*(CORD(j,1)-xgs1x)/
     &                  (xbb3x-xgs1x)
*              ELVVV(j)=elvgs1+(elvbb3-elvgs1)*(CORD(j,2)-ygs1y)/
*    &                  (ybb3y-ygs1y)
               DEPVV(j)=dinigs1+(dinibbu-dinigs1)*(CORD(j,1)-xgs1x)/
     &                  (xbbux-xgs1x)
            ENDIF
            IF (CORD(j,2) .LE. ydsmr) THEN
               ELVVV(j)=elvgs2+(elvcds-elvgs2)*(CORD(j,2)-ygs2y)/
     &                  (ydsmr-ygs2y)
               DEPVV(j)=dinigs2+(dinicon-dinigs2)*(CORD(j,2)-ygs2y)/
     &                  (ydsmr-ygs2y)
            ENDIF
            IF (CORD(j,2) .GE. ymr1y .AND. CORD(j,1) .LE. xrigh) THEN
               ELVVV(j)=elvmr1+(elvmru-elvmr1)*(CORD(j,2)-ymr1y)/
     &                  (ymruy-ymr1y)
               DEPVV(j)=dinicon+(dinimru-dinicon)*(CORD(j,2)-yconf)/
     &                  (ymruy-yconf)
            ENDIF
            IF (CORD(j,2) .GE. yusmr .AND. CORD(j,2) .LT. ymr1y
     &         .AND. CORD(j,1) .LE. xrigh) THEN
               ELVVV(j)=elvcus+(elvmr1-elvcus)*(CORD(j,2)-yusmr)/
     &                  (ymr1y-yusmr)
               DEPVV(j)=dinicon+(dinimru-dinicon)*(CORD(j,2)-yconf)/
     &                  (ymruy-yconf)
            ENDIF
            IF (CORD(j,2) .LT. yusmr .AND. CORD(j,2) .GT. yconf) THEN
               IF (CORD(j,1) .LE. xleft) THEN
                  ELVVV(j)=elvcon+(elvcus-elvcon)*(CORD(j,2)-
     &                     yconf)/(yusmr-yconf)
                  DEPVV(j)=dinicon+(dinimru-dinicon)*
     &                     (CORD(j,2)-yconf)/(ymruy-yconf)
               ENDIF
               IF (CORD(j,1) .GE. xleft .AND. CORD(j,1) .LE. xrigh) THEN
                  ELVVV(j)=elvcon+(elvgs1-elvcon)*(CORD(j,1)-xconf)/
     &                     (xgs1x-xconf)
                  DEPVV(j)=dinicon+(dinigs1-dinicon)*
     &                     (CORD(j,1)-xconf)/(xgs1x-xconf)
               ENDIF
            ENDIF
         IF (CORD(j,2) .LE. yconf .AND. CORD(j,2) .GE. ydsmr) THEN
            IF (CORD(j,1) .LE. xleft) THEN
               ELVVV(j)=elvcds+(elvcon-elvcds)*(CORD(j,2)-
     &                  ydsmr)/(yconf-ydsmr)
               DEPVV(j)=dinicon+(dinimru-dinicon)*
     &                  (CORD(j,2)-yconf)/(ydsmr-yconf)
            ENDIF
            IF (CORD(j,1) .GE. xleft .AND. CORD(j,1) .LE. xrigh) THEN
               ELVVV(j)=elvcon+(elvgs1-elvcon)*(CORD(j,1)-xconf)/
     &                 (xgs1x-xconf)
               DEPVV(j)=dinicon+(dinigs1-dinicon)*
     &                  (CORD(j,1)-xconf)/(xgs1x-xconf)
            ENDIF
         ENDIF
  177 CONTINUE
      ENDIF
*-
* ... INITIALIZE PRIMARY STATE VARIABLE ARRAY
*-
      WRITE (IOUT,9964)
 9964 FORMAT (/'HMIN=',/)
      DO 660 J = 1,NP
         VEL(1,J) = 0.0
         VEL(2,J) = 0.0
         HEL(J) = ELEV-AO(J)
         IF (ISWIT .EQ. 1) HEL(J)=DEPVV(J)+ELVVV(J)-AO(J)
         CALL AMF (HEL(J),VEL(3,J),AKP(J),ADT(J),ADB(J),D1,D2,1)
         IF (ISWIT .EQ. 1) THEN
         WRITE (IOUT,9962) J,VEL(3,J),HEL(J),DEPVV(J),ELVVV(J),
     &                     AO(J),HMIN
 9962    FORMAT (I6,6F12.4)
         ENDIF
         IF (VEL(3,J) .LT. HMIN) VEL(3,J) = HMIN
         VOLD(3,J) = VEL(3,J)
         HOL(J) = HEL(J)
  660 CONTINUE
*      WRITE (iout,176)
*  176 format(/2x,'Initial water depth'/)
*      WRITE (iout,174) dinibbu,dinigs1,dinimru,dinicon,dinigs2
*  174 format('dinibbu=',f5.2,2x,'dinigs1=',f5.2,2x,'dinimru=',f5.2,
*     +       2x,'dinicon=',f5.2,2x,'dinigs2=',f5.2)
*      WRITE (iout,178) (i,hel(i),i=1,np)
*  178 format(8(i4,1x,f5.2))
*-
* ... Set up 1-D velocities
*-
      DO 680 N = 1,NE
         NM = IABS(IMAT(N))
         IMATO(N) = IMAT(N)
         IF (NM .EQ. 0 .OR. NM .GT. 900) GO TO 680
         IF (ORT(NM,1) .EQ. 0.0) GO TO 680
         IF (NOP(N,6) .GT. 0) GO TO 680
         IF (NCORN(N) .EQ. 5) THEN
            NLM = 2
         ELSE
            NLM = 3
         ENDIF
         DO 670 M = 1,NLM
            NA = NOP(N,M)
            VEL(1,NA) = UNOM
            IF (M .EQ. 2) VEL(1,NA) = UNOM*1.01
  670    CONTINUE
  680 CONTINUE
*-
* ... INPUT BOUNDARY AND WIND DATA
*-
  690 CONTINUE
*-
* ... Initialize CHECK
*-
      CALL CHECK
*-
* ... Process boundary and solution step varying properties
*-
      IF (IHOTN .LT. 0) TET = (NSTART-1)*DELT
      NXX = NSTART
      NSTIME = NSTART
      IF (NXX .LT. 1) NXX = 1
*-
      CALL SBGENP (NEX)
*-
* ... PRESERVE INPUT VALUES OF NFIX
*-
      DO 710 J = 1,NP
         NFIXP(J) = NFIX(J)
  710 CONTINUE
*-
* ... Set direction for 1D - 2D junction node
*-
      DO 720 N = 1,NE
        IF (NCORN(N) .EQ. 5 .AND. IMAT(N) .LT. 901) THEN
          N1 = NOP(N,4)
          N2 = NOP(N,5)
          DX = CORD(N1,1)-CORD(N2,1)
          DY = CORD(N1,2)-CORD(N2,2)
          WIDTT = SQRT(DX**2+DY**2)
          ANG = ATAN2(DX,-DY)
          IF (ANG .GT. 1.5707963) ANG = ANG-3.1415926
          IF (ANG .LT. -1.5707963) ANG = ANG+3.1415926
          N3 = NOP(N,3)
*-
* ... Set midside at halfway point
*-
          CORD(N3,1) = (CORD(N1,1)+CORD(N2,1))/2.0
          CORD(N3,2) = (CORD(N1,2)+CORD(N2,2))/2.0
          IF (SS1(N3) .NE. 0.0 .OR. SS2(N3) .NE. 0.0) THEN
            WRITE (*,*) ' **ERROR**  SIDE SLOPES AT NODE',N3,
     &           ' NON-ZERO ... VALUES FORCED TO ZERO'
            SS1(N3) = 0.0
            SS2(N3) = 0.0
          ENDIF
          WIDTO = WIDTH(N3)
          WIDTH(N3) = WIDTT
          IF (ANG .NE. 0.0) THEN
            ALFAK(N3) = ANG
          ELSE
            ALFAK(N3) = 0.0001
          ENDIF
          IF (IECHO .GT. 1) PRINT *,' SETTING ALFAK, WIDTH, OLD WIDTH '
     &       ,N3,ANG,WIDTH(N3),WIDTO
        ENDIF
  720 CONTINUE
*-
* ... Call BLINE to establish side line boundaries for printing
*-
      CALL BLINE (0)
*-
      IF (IPRT .NE. 1) GO TO 750
      DO 740 J = 1,NP
        IF (MOD(J,45) .NE. 1) GO TO 730
        IF (IOUT .GT. 0) THEN
*            WRITE (IOUT,990)
*            WRITE (IOUT,1020) TITLE
            WRITE (IOUT,1140)
            IF (METRIC .LE. 0) WRITE (IOUT,1150)
            IF (METRIC .GE. 1) WRITE (IOUT,1155)
        ENDIF
  730   IF (WIDTH(J) .NE. VOID) THEN
           WDA = WIDTH(J)
           WDS = WIDS(J)
           SL = SS1(J)
           SR = SS2(J)
        ELSE
          WDA = 0.0
          WDS = 0.0
          SL = 0.0
          SR = 0.0
        ENDIF
        IF (IOUT .GT. 0)
     &     WRITE (IOUT,1160) J,CORD(J,1),CORD(J,2),AO(J),
     &     ALFA(J),NFIX(J),(SPEC(J,K),K = 1,3),WDA,SL,SR,WDS
  740 CONTINUE
  750 IF (IPRT .EQ. 2) CALL OUTPUT (0)
      OMEGA = 1.458E-4*SIN(OMEGA/57.3)
      DO 760 II = 1,NE
*-
* ... Convert local ave lat from deg
*-
         OMEGAS(II) = 1.458E-04*SIN(OMEGAS(II)/57.3)
  760 CONTINUE
*-
* ... INITIALIZE FOR BOUNDARY CONDITIONS
*-
      IF (IHOTN .EQ. 0) CALL BFORM (0)
*-
      IF (IHOTN .GT. 0) NP = NPT
      RETURN
*-
* ... ENTRY FOR TIME DEPENDENT INPUT DATA
*-
* ... RESTORE INPUT VALUES OF -NFIX- AND SET -SPE*- TO ZERO
*-
  770 DO 780 J = 1,NP
        NFIX(J) = NFIXP(J)
  780 CONTINUE
*-
      TTT = TET+DELT
      IF (IOUT .GT. 0) WRITE (IOUT,1210) TTT,ICYC
*-
* ... Enter variable density if requested by input
*-
      IF (NBX .GT. 0) THEN
        DO 810 K = 1,NBX
          J = KNBX(K)
          NFIX(J) = IABS(NFIX(J))
          IF (IOUT .GT. 0)
     &    WRITE (IOUT,1220) J,NFIX(J),(SPEC(J,M),M = 1,3)
*-
* ... Setup for boundary conditions
*-
          CALL BFORM (J)
*-
  810   CONTINUE
      ENDIF
*-
* ... Input element inflows and special boundary conditions
*-
      CALL SBGENP (NEX)
*-
* ... PRESERVE NFIX
*-
      DO 820 J = 1,NP
         NFIXP(J) = NFIX(J)
  820 CONTINUE
*-
      RETURN
*-
* ... INPUT DATA CARD FORMATS
*-
  830 FORMAT ('+',85X,'WARNING, AREA LESS THAN OR EQUAL TO ZERO')
  840 FORMAT (' **** WARNING, SLOPE IS ZERO BUT B-C IS SLIP FLOW ****')
  850 FORMAT (A)
  860 FORMAT (16I5)
  870 FORMAT (16I5)
  880 FORMAT (8F10.0)
  890 FORMAT (5I5,F10.0,6I5)
  900 FORMAT (I10,5F10.0)
  910 FORMAT (2I5,F10.0,6I5)
  920 FORMAT (I10,E10.0)
  930 FORMAT (I5,6E10.0)
  940 FORMAT (I10,7F10.0)
  950 FORMAT (10I5,F10.0)
  960 FORMAT (I10,4F10.0)
  970 FORMAT (2I10,3E10.0)
  980 FORMAT (A32)
  990 FORMAT (/,10X,'HYDRO2D - FINITE ELEMENT MODULE FOR FLUID FLOW',
     & /,10X,'TWO-DIMENSIONAL (VERTICALLY INTEGRATED) HYDRODYNAMICS',
     & /,10X,'VERSION 1.00',/)
 1020 FORMAT (5X,A80)
 1030 FORMAT (//,2X,'RUN CONTROL PARAMETERS',
     &        //,5X,'ELEMENT CARDS',T25,I5,
     &         /,5X,'ELEMENT TYPES',T25,I5,
     &         /,5X,'COORDINATE CARDS',T25,I5,
     &         /,5X,'BOUNDARY SPECS',T25,I5,
     &         /,5X,'WIDTH CARDS',T25,I5,
     &         /,5X,'ELEMENT FLOW CARDS',T25,I5,
     &         /,5X,'PRINT OPTION',T25,I5,
     &         /,5X,'CONT CHECKS',T25,I5,
     &         /,5X,'WIND INPUTS',T25,I5,
     &         /,5X,'REORDER OPTION',T25,I5,
     &         /,5X,'INPUT SLOPE OPTION',T25,I5,
     &         /,5X,'INPUT FLOW OPTION',T25,I5,
     &         /,5X,'INPUT ELEV OPTION',T25,I5,
     &         /,5X,'INPUT STGE-FLOW OPT',T25,I5,
     &         /,5X,'FLOW CONTROLLERS',T25,I5,
     &         /,5X,'MARSH INPUT SWITCH',T25,I5,/)
 1040 FORMAT (/,2X,'LOGICAL UNIT ASSIGNMENTS',
     &        /,5X,'INPUT RESTART BINARY FILE',T40,I5,
     &        /,5X,'OUTPUT RESTART BINARY FILE',T40,I5,
     &        /,5X,'INPUT GEOMETRY BINARY FILE',T40,I5,
     &        /,5X,'FINAL RESULTS BINARY FILE',T40,I5,
     &        /,5X,'FINAL RESULTS BINARY TIME CONTROL',T40,I5,
     &        /,5X,'ALTERN. INPUT B.C. FILE',T40,I5,
     &        /,5X,'SCRATCH FILE FOR BUFFER ',T40,I5,
     &        /,5X,'SUMMARY PRINT BY NODE OPTION',T40,I5,/)
 1050 FORMAT (/,5X,'GLOBAL AVG LAT (DEG) ',F13.3,
     &        /,5X,'AVG WS ELEV (M)      ',F13.3,
     &        /,5X,'X-SCALE FACTOR       ',F13.3,
     &        /,5X,'Z-SCALE FACTOR       ',F13.3,
     &        /,5X,'DSET FACTOR          ',F13.4,
     &        /,5X,'DSETD FACTOR         ',F13.4,
     &        /,5X,'S.S. DEPTH CONV CHECK',F13.6,
     &        /,5X,'U.S. DEPTH CONV CHECK',F13.6,
     &        /,5X,'NOMINAL VELOCITY     ',F13.3,
     &        /,5X,'MIN DEPTH            ',F13.3,
     &        /,5X,'TEMPERATURE (C)      ',F13.3)
 1060 FORMAT (//,2X,'TIME, ITERATION, AND PRINT CONTROL'
     &        //,5X,'ITERATIONS- FIRST TIME       (NITI)  ',I10,
     &         /,5X,'ITERATIONS- DYNAMIC          (NITN)  ',I10,
     &         /,5X,'RESTART MID-ITER CONTROLS    (MBAND  ',I10,
     &         /,5X,'STARTING TIME STEPS          (NSTART)',I10,
     &         /,5X,'TOTAL TIME STEPS             (NCYC)  ',I10,
     &         /,5X,'DELTA TIME INTERVAL in HRS   (DELT)  ',F10.6,
     &         /,5X,'MAX HOUR FOR THIS RUN        (TMAX)  ',F10.4,
     &         /,5X,'ITERATIONS FOR DRY NODES     (LI)    ',I10,
     &         /,5X,'PRINT INCREMENT ITERATIONS   (ITSI)  ',I10,
     &         /,5X,'SPECIAL PRINT FILE SWITCH            ',I10,
     &         /,5X,'NO. OF NODES FOR SPECIAL PRINT       ',I10,
     &         /,5X,'HIGH ORDER INTEGRATION       (IHOE)  ',I10,
     &         /,5X,'INPUT DISTRIBUTED DENSITY    (IDEN)  ',I10,
     &         /,5X,'SYSTEM INTERNATIONAL UNITS   (METRIC)',I10,/)
 1070 FORMAT (// 5X,'ELEMENT CHARACTERISTICS')
 1080 FORMAT (//
     &  5X,'  TYPE   X-X EDDY VIS   X-Y EDDY VIS   Y-X EDDY VIS',
     &      '   Y-Y EDDY VIS   CHEZY-MANNING'
     &  / 11X,4(3X,'LB-SEC/SF',3X))
 1085 FORMAT (//
     &  5X,'  TYPE   X-X EDDY VIS   X-Y EDDY VIS   Y-X EDDY VIS',
     &      '   Y-Y EDDY VIS   CHEZY-MANNING'
     &  / 12X,4(3X,'PASCAL-SEC',2X))
 1090 FORMAT (I10,5(1PE15.3))
 1100 FORMAT (/4X,'NODAL CONNECTIONS AND MATERIAL NUMBERS....',/)
 1110 FORMAT (7X,'ELT',5X,'NODES (COUNTERCLOCKWISE)',
     &       13X,'TYPE  SEQ',3X,'AREA (FT2)     ANGLE    LATITUDE ')
 1115 FORMAT (7X,'ELT',5X,'NODES (COUNTERCLOCKWISE)',
     &       13X,'TYPE  SEQ',3X,'AREA (SQ M)    ANGLE    LATITUDE ')
 1120 FORMAT (I10,10I5,F13.2,F10.3,F10.3)
 1130 FORMAT (/10X,'NODES SELECTED FOR SPECIAL PRINT FILE'/(10I8))
 1140 FORMAT (/10X,'.....NODAL SPECIFICATIONS.....')
 1150 FORMAT (/6X,'NODE     X-LOC     Y-LOC    BOT EL         '
     &    ,'NETWORK B-C    X-FLOW    Y-FLOW  SUR ELEV      NODE '
     &    ,'     LEFT     RIGHT   STORAGE'/4X,'NUMBER      '
     &    ,'(FT)      (FT)      (FT)     SLOPE       FIX  (CFS/FT) '
     &    ,' (CFS/FT)      (FT)     WIDTH     SLOPE     SLOPE   '
     &    ,'  WIDTH')
 1155 FORMAT (/6X,'NODE     X-LOC     Y-LOC    BOT EL   '
     &    ,'NETWORK       B-C    X-FLOW    Y-FLOW    SUR EL      NODE '
     &    ,'    LEFT      RIGHT    STORAGE'/4X,'NUMBER      '
     &    ,'(M)       (M)       (M)      SLOPE       FIX   (CMS/M) '
     &    ,'  (CMS/M)       (M)     WIDTH     SLOPE     SLOPE   '
     &    ,'  WIDTH')
 1160 FORMAT (I10,3F10.2,F10.5,I10,3F10.2,F10.0,2F10.4,F10.1)
 1170 FORMAT (/// 10X,'NO CONTINUITY CHECKS REQUESTED.....')
 1180 FORMAT (////
     &  ' ++',4X,
     &  'CONTINUITY CHECKS TO BE MADE ALONG THE FOLLOWING LINES',//,
     &  ' ++',4X,'LINE      NODES ')
 1190 FORMAT (' ++',I7,4X,16I6,(/,14X,16I6))
 1200 FORMAT (//,2X,A,/,2X,A,//
     &        2X,'THIS PROGRAM IS DIMENSIONED AS FOLLOWS ',//,
     &        5X,'MAX NO. OF NODES                  ',I10,/,
     &        5X,'MAX NO. OF ELEMENTS               ',I10,/,
     &        5X,'MAX NO. OF EQUATIONS              ',I10,/,
     &        5X,'MAX FRONT WIDTH                   ',I10,/,
     &        5X,'MAX NO. OF CONTINUITY CHECK LINES ',I10,/,
     &        5X,'MAX BUFFER SIZE                   ',I10,/,
     &        5X,'MAX PRINT-SUMMARY BUFFER          ',I10)
 1210 FORMAT (/1X,'*** BOUNDARY CONDITION UPDATE AT TIME ='
     &   ,F10.2,' hrs   CYCLE NUMBER',I4/,6X,'NODE      '
     &    ,'FIX   X-FLOW   Y-FLOW    W.S.EL')
 1220 FORMAT (2I10,3F10.2)
 1230 FORMAT (/' NODE ',I7,' AT ZERO WIDTH',1PE14.4)
 1240 FORMAT (/' EXECUTION TERMINATED BY ZERO WIDTH NODE(S)')
 1250 FORMAT (// 10X,'.....NETWORK INPUT COMPLETE.....',
     &        // 15X,'MAX ELEMENT NUM =',I5
     &        /15X,'MIN ELEMENT NUM =',I5
     &        /15X,'MAX NODE NUM =',I8
     &        /15X,'MIN NODE NUM =',I8)
      END
*-
      SUBROUTINE LETTER (IC2,ISTYLE)
*-
      SAVE
*-
      DIMENSION A2Z(26)
      CHARACTER *1  IC2
      CHARACTER *1  A2Z
      DATA A2Z /'A','B','C','D','E','F','G','H','I','J','K','L',
     &              'M','N','O','P','Q','R','S','T','U','V','W','X',
     &              'Y','Z'/
* ... FOR HEC STYLE INPUT, THE VALUE OF ISTYLE WILL BE SET TO 1
      ISTYLE = 0
      DO 100 I = 1,26
         IF (IC2 .EQ. A2Z(I)) GO TO 200
  100 CONTINUE
      RETURN
  200 ISTYLE = 1
      RETURN
      END
*-
      SUBROUTINE LOAD
*-
      SAVE
*-
      INCLUDE 'hsctm.inc'
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED LOAD'
      IF (ITRACE .GE. 1) PRINT *,'       IHGEN=',IHGEN,' NBX=',NBX
*-
* ... COPY HEAD SPECS AND FIX BOUNDARY CONDITIONS
*-
      DO 150 N=1,NE
         DO 150 M=1,8
            NOP(N,M)=IABS(NOP(N,M))
  150 CONTINUE
      IR1MAX = MR1
      NA = 10**(5-NDF)
      DO 195 J = 1,NP
         NLOC(J)=NFIX(J)
         IF (MOD(NLOC(J)/100,10) .EQ. 2) NLOC(J) = NLOC(J)-200
         NLOC(J) = NLOC(J)/NA
  195 CONTINUE
*-
* ... SET UP NBC ARRAY
*-
      DO 197 N=1,NP
      DO 197 M=1,NDF
  197 NBC(N,M)= -1
      DO 199 J=1,NE
         IF (IMAT(J) .GT. 0 .AND. IMAT(J) .LT. 901) THEN
          NCN=NCORN(J)
          IF (NCN .GT. 5) THEN
            L=IMAT(J)
          ELSE
            L=IMAT(J)
          ENDIF
          IF (ORT(L,1) .EQ. 0.0) GO TO 199
          DO 198 K=1,NCN
          N=IABS(NOP(J,K))
          NDS=NDF
          IF (MOD(K,2) .EQ. 0) NDS=2
          DO 198 I=1,NDS
             NBC(N,I)=0
  198     CONTINUE
        ENDIF
  199 CONTINUE
*-
* ... FORM DEGREE OF FREEDOM ARRAY
*-
      DO 220 N=1,NP
        DO 200 M=1,NDF
        NBC(N,M)=NBC(N,M)+1
        IF (NBC(N,M) .EQ. 0) GO TO 200
        IF (NLOC(N)/(10**(NDF-M)) .NE. 1) GO TO 200
        NBC(N,M)=0
  200   NLOC(N)=MOD(NLOC(N),10**(NDF-M))
  220 CONTINUE
*-
* ... Install special values for one-two dimension intersections
*-
      DO 360 NN=1,NE
        IF (IMAT(NN) .EQ. 0) GO TO 360
        IF (NCORN(NN) .EQ. 5 .AND. IMAT(NN) .LT. 901) THEN
          NLN=NOP(NN,3)
          DO 315 K=4,5
             IF (NOP(NN,K) .EQ. 0) GO TO 320
             IF (NLN .GT. NOP(NN,K)) NLN=NOP(NN,K)
  315     CONTINUE
  320     CONTINUE
          DO 330 K=3,5                                                  
            IF (NLN .EQ. NOP(NN,K)) GO TO 330                            
            ND=NOP(NN,K)                                                
            IF (ND .EQ. 0) GO TO 330                                     
            NBC(ND,1)= -NLN                                             
            NBC(ND,2)= -NLN                                             
            NBC(ND,3)= -NLN                                              
  330     CONTINUE                                                      
        ENDIF                                                           
  360 CONTINUE
*-
*     REARRANGE ARRAY
*-
      NSZF=0                                                            
      N = 0                                                             
      DO 380 NN = 1,NP                                                 
        N = N+1                                                       
        DO 370 M = 1,NDF                                               
          IF (NBC(N,M) .GT. 0) THEN                                    
            NSZF=NSZF+1                                                 
            NBC(N,M)=NSZF                                               
          ELSEIF (NBC(N,M) .LT. 0) THEN                                  
            NRF= -NBC(N,M)                                               
            NBC(N,M)=NBC(NRF,M)                                         
          ENDIF                                                         
  370   CONTINUE                                                        
  380 CONTINUE                                                          
      IF (NSZF .GT. IR1MAX) THEN
        IF (IOUT .GT. 0) THEN                                             
           WRITE (IOUT,6007) NSZF                                       
           WRITE (IOUT,6008) IR1MAX                                     
        ENDIF                                                           
        CALL ZVRS (1)                                                    
        WRITE (*,381) NSZF,IR1MAX                                       
  381   FORMAT (' SUB LOAD- TOO MANY EQUATIONS NSZF=',I8,/,             
     &         ' ALLOWABLE LIMIT  IR1MAX=',I8)                          
        STOP 'LOAD'                                                     
      ENDIF                                                             
*-
* ... Find last appearance of each node
*-
      DO 400 J=1,NSZF                                                   
  400 NLSTEL(J)=0                                                       
      K=NE+1                                                            
      DO 480 NN=1,NE                                                    
         K=K-1                                                           
         N=NFIXH(K)                                                      
         IF (IMAT(N) .GT. 0) THEN                                         
            NM=IMAT(N)                                                    
            IF (NM .GT. 900) GO TO 410                                     
            IF (ORT(NM,1) .EQ. 0.0) GO TO 480                               
  410       CONTINUE                                                      
            NCN=NCORN(N)                                                  
            IF (NOP(N,3) .EQ. 0) NCN=2                                     
            DO 450 M=1,NCN                                                
               L=NOP(N,M)                                                  
               DO 420 I=1,NDF                                              
                  J=NBC(L,I)                                                
                  IF (J .NE. 0) THEN                                         
                     IF (NLSTEL(J) .EQ. 0) THEN                               
                        NLSTEL(J)=N                                           
                     ENDIF                                                   
                  ENDIF                                                     
  420          CONTINUE                                                    
  450       CONTINUE                                                      
        ENDIF
  480 CONTINUE
      IF (IOUT .GT. 0) WRITE (IOUT,6007) NSZF
 6007 FORMAT (//9X,'TOTAL NUMBER OF ACTIVE SYSTEM EQUATIONS =',I6)
      RETURN
 6008 FORMAT (20X,'ALLOWABLE LIMIT OF',I7,' EXCEEDED'/,
     &       20X,'EXECUTION TERMINATED')
      END
*-
      SUBROUTINE OUTPUT (IDP)
*-
      SAVE
*-
      INCLUDE 'hsctm.inc'
*-
      COMMON /CNTRL/ LE,LPP                                            
      COMMON /PTOUT/ EMAX(5),EAVG(5),NMAX(5)                          
      COMMON /XVLC/ XVEL(3,MND),IIREC2(100,3)                          
      DIMENSION CNCC(MND)
      CHARACTER *8 IVAR(5)                                              
      DATA IVAR/'X-VEL   ','Y-VEL   ','DEPTH   ','TEMP/SAL','TEMP    '/ 
*-
* ... SETUP FOR SOLUTION CORRECTIONS
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED OUTPUT (IDP=', IDP, ')'
*-
*     VARIABLE IDP CONTROLS PRINTOUT IN THE FOLLOWING LOGIC
*     IF IDP IS ZERO ALL NODAL VALUES FOR INITIAL CONDITIONS PRINTED
*     IF IDP IS +1   AND CONVERGENCE IS GOOD IDP GETS CHANGED TO = 2
*     IF IDP IS -1   AND CONVERGENCE IS BAD IDP GET CHANGED  TO = -2
*     IF IDP IS +2   ALL NODAL VALUES FOR THIS ITERATION IS PRINTED
*     IF IDP IS -2   ONLY MINI-STATS ARE PRINTED IF CONVERGENCE IS GOOD
*     IF IDP IS -2   ALL NODAL VALUES ARE PRINTED IF CONVERGENCE IS BAD
*     *****************************************************************
*-
      DO 110 J = 1,NDF
         DO 100 I = 1,100                                               
            IIREC2(I,J) = 0
  100    CONTINUE                                                        
         EAVG(J) = 0.0                                                   
         EMAX(J) = 0.0                                                   
         NMAX(J) = 0.0                                                   
  110 CONTINUE                                                          
*-
      IF (IDP .EQ. 0) GO TO 230
*-
* ... COMPUTE SOLUTION CORRECTIONS
*-
      DO 210 K = 1,NDF                                                 
        EMAX(K) = 0.0                                                   
        EAVG(K) = 0.0                                                   
        COUNT = 0.0                                                     
        DO 200 J = 1,NP                                                
          IF (NBC(J,K) .LE. 0) GO TO 190                                
  120     I = NBC(J,K)                                                  
          COUNT = COUNT+1.0                                           
          EX = R1(I)                                                    
          AMAG = -34.9                                                
          IF (EX .NE. 0.0) AMAG = ALOG10(ABS(EX))                        
          IMAG = AMAG+35.9999                                         
          IIREC2(IMAG,K) = IIREC2(IMAG,K)+1                           
          AEX = ABS(EX)                                                 
          EAVG(K) = EAVG(K)+AEX                                       
          IF (AEX .LT. ABS(EMAX(K))) GO TO 130                          
          EMAX(K) = EX                                                  
          NMAX(K) = J                                                   
  130     CONTINUE                                                      
          IF (K .GT. 2) GO TO 160                                       
          IF (ADIF(J) .NE. 0.0) EX = EX/COS(ADIF(J))                   
          ZQWIFZ = ALFA(J)                                              
          IF (ZQWIFZ .LT. 0.0) GO TO 140                                 
          IF (ZQWIFZ .LE. 0.0) GO TO 150                                 
  140     VEL(K,J) = VEL(K,J)+EX*COS(ALFA(J))                       
          VEL(K+1,J) = VEL(K+1,J)+EX*SIN(ALFA(J))                   
          GO TO 200                                                     
  150     VEL(K,J) = VEL(K,J)+EX                                      
          GO TO 200                                                     
  160     IT1 = 0                                                       
  170     IF (IT1 .GT. 5) GO TO 180                                     
          VN = VEL(K,J)+EX                                            
          IF (VN .LT. 0.0) THEN                                          
            EX = EX/2.0
            IT1 = IT1+1                                               
            GO TO 170                                                   
          ENDIF                                                        
  180     VEL(K,J) = VN                                                 
  190     CONTINUE                                                      
          IF (NDRY(J) .EQ. 1) THEN                                      
            CALL AMF (HEL(J),VEL(3,J),AKP(J),ADT(J),ADB(J),D1,D2,0)    
          ENDIF                                                        
  200   CONTINUE                                                        
        IF (COUNT .GT. 0.0) THEN
           EAVG(K) = EAVG(K)/COUNT                                     
        ELSE                                                            
           EAVG(K) = 0.0
        ENDIF                                                          
  210 CONTINUE                                                          
*-
* ... Correct angle for merging elements
*-
      DO 220 N = 1,NE                                                  
        IF (IMAT(N) .LT. 900 .AND. NCORN(N) .EQ. 5) THEN                
          N0 = NOP(N,3)                                                 
          VB = VEL(1,N0)*COS(ALFA(N0))+VEL(2,N0)*SIN(ALFA(N0))    
          N1 = NOP(N,4)                                                 
          VEL(1,N1) = VB*COS(ALFA(N1))/COS(ADIF(N1))                
          VEL(2,N1) = VB*SIN(ALFA(N1))/COS(ADIF(N1))                
          N2 = NOP(N,5)                                                 
          VEL(1,N2) = VB*COS(ALFA(N2))/COS(ADIF(N2))                
          VEL(2,N2) = VB*SIN(ALFA(N2))/COS(ADIF(N2))                
        ENDIF                                                          
  220 CONTINUE                                                          
*-
      FACT = ABS(EMAX(3))
      IF (FACT .LT. STPCRT .AND. ABS(EMAX(1)) .LT. DSET .AND.
     &    ABS(EMAX(2)) .LT. DSET) THEN
          IDP = ISIGN(2,IDP)
      ELSE                                                              
          FACT = DSET*2.0                                              
      ENDIF                                                            
      IF (ABS(EMAX(3)) .GT. 10.0) THEN                                   
          IDP = 2                                                       
          GO TO 230                                                     
      ENDIF
*-
* ... OUTPUT RESULTS
*-
  230 IF (IOUT .GT. 0) WRITE (IOUT,250) TITLE
  250 FORMAT (/,5X,A)
      IF (IDP .EQ. 0) THEN
          IF (IOUT .GT. 0) WRITE (IOUT,260)
  260     FORMAT (/5X,'..... INITIAL CONDITIONS .....')
          IDP = 2
      ENDIF
      IF (IOUT .GT. 0) WRITE (IOUT,270) ICYC,TET,NITSV
      WRITE (*,270) ICYC,TET,NITSV
  270 FORMAT (/1X,'RESULTS AT THE END OF',I5,' TIME STEPS...'
     &    ,/,1X,'TOTAL TIME =',F10.3,' hours     ITERATION '
     &    ,'CYCLE =',I4)
      WRITE (*,275)
      IF (IOUT .GT. 0) WRITE (IOUT,275)
  275 FORMAT (//,8X,'CONVERGENCE PARAMETERS',//,8X,                   
     &              'DF        AVG  CHG        MAX CHG     LOCATION')   
      DO 280 J = 1,NDF                                                 
         IF (IOUT .GT. 0)                                                 
     &   WRITE (IOUT,290) J,EAVG(J),EMAX(J),NMAX(J),IVAR(J)
         WRITE (*,290) J,EAVG(J),EMAX(J),NMAX(J),IVAR(J)
  280 CONTINUE
  290 FORMAT (I10,2F15.4,I10,4X,A8)
*-
* ... COMPUTE VALUES FOR SECONDARY OUTPUT
*-
      DO 310 J = 1,NP
        DO 300 K = 1,3
           XVEL(K,J) = 0.0
  300   CONTINUE
  310 CONTINUE
      DO 330 J = 1,NE                                                  
         IF (IMAT(J) .GT. 0) THEN                                        
            NM = IMAT(J)                                                  
            IF (NM .LT. 901) THEN                                         
               IF (ORT(NM,1) .GT. 0.0) THEN                                 
                  NCN = NCORN(J)                                            
                  IF (NCN .EQ. 5) NCN = 3                                   
               DO 320 K = 2,NCN,2                                      
                  N1 = IABS(NOP(J,K-1))                                   
                  N2 = IABS(NOP(J,K))                                     
                  N3 = MOD(K+1,NCN)                                       
                  IF (NCN .EQ. 3) N3 = 3                                  
                  N3 = IABS(NOP(J,N3))                                    
                  VEL(3,N2) = 0.5*(VEL(3,N1)+VEL(3,N3))               
                  XVEL(3,N1) = HEL(N1)                                    
                  XVEL(3,N3) = HEL(N3)                                    
                  HEL(N2) = (HEL(N1)+HEL(N3))/2.0                      
                  XVEL(3,N2) = 0.5*(XVEL(3,N1)+XVEL(3,N3))            
  320          CONTINUE                                                  
            ENDIF                                                      
          ENDIF                                                        
        ENDIF                                                          
  330 CONTINUE                                                          
      IF (ICYC .GT. 0) TT(ICYC) = TET                                   
      DO 340 J = 1,NP                                                  
        XVEL(1,J) = VEL(1,J)                                            
        XVEL(2,J) = VEL(2,J)                                            
        XVEL(3,J) = XVEL(3,J)+AO(J)                                   
        IF (NSPREF(J) .GT. 0) THEN                                      
          IF (ICYC .GT. 0) THEN                                         
              JJ = NSPREF(J)+(ICYC-1)*JSPLPT                      
          ELSE                                                          
              JJ = NSPREF(J)                                            
          ENDIF                                                        
          SPQ(JJ) = 0.0
          SPVELX(JJ) = VEL(1,J)                                         
          SPVELY(JJ) = VEL(2,J)                                         
          SPVELT(JJ) = SQRT(VEL(1,J)**2+VEL(2,J)**2)                    
          SPDEP(JJ)  = VEL(3,J)                                         
          SPELEV(JJ) = XVEL(3,J)                                        
          SPCRDX(JJ) = CORD(J,1)                                        
          SPCRDY(JJ) = CORD(J,2)                                        
        ENDIF                                                          
  340 CONTINUE                                                          
      IF (TET .LE. 0.0) THEN
        ITRMAX = NITI 
      ELSE
        ITRMAX = NITN
      ENDIF
      IF (NSTEP .EQ. 1) THEN
         DO 8111 I = 1,NP
            CNCC(I) = 0.0
 8111    CONTINUE
      ENDIF
*-
* ... CALCULATE MINI STATISTICS FOR THIS ITERATION
*-
      VOID  = 1.0E20                                                     
      XMAX  = -VOID                                                   
      YMAX  = -VOID                                                   
      WMAX  = -VOID                                                   
      XMIN  = VOID                                                      
      YMIN  = VOID                                                      
      WMIN  = VOID                                                      
      NXMAX = 0                                                         
      NXMIN = 0                                                         
      NYMAX = 0                                                         
      NYMIN = 0                                                         
      NWMAX = 0                                                         
      NWMIN = 0                                                         
      SWAVG = 0.0
      NACTV = 0                                                         
      DO 350 JJ = 1,NP                                                 
* ... CHECK IF NODE IS ACTIVE. NDRY=1=WET, =2=DRY, = -1=REWETTING
        IF (NDRY(JJ) .NE. 1) GO TO 350
        NACTV = NACTV+1
        IF (XVEL(1,JJ) .GT. XMAX) THEN                                  
            XMAX = XVEL(1,JJ)                                           
            NXMAX = JJ                                                  
        ENDIF                                                          
        IF (XVEL(1,JJ) .LT. XMIN) THEN                                  
            XMIN = XVEL(1,JJ)                                           
            NXMIN = JJ                                                  
        ENDIF                                                          
        IF (XVEL(2,JJ) .GT. YMAX) THEN                                  
            YMAX = XVEL(2,JJ)                                           
            NYMAX = JJ                                                  
        ENDIF                                                          
        IF (XVEL(2,JJ) .LT. YMIN) THEN                                  
            YMIN = XVEL(2,JJ)                                           
            NYMIN = JJ                                                  
        ENDIF                                                          
        IF (XVEL(3,JJ) .GT. WMAX) THEN                                  
            WMAX = XVEL(3,JJ)                                           
            NWMAX = JJ                                                  
        ENDIF                                                          
        IF (XVEL(3,JJ) .LT. WMIN) THEN                                  
            WMIN = XVEL(3,JJ)                                           
            NWMIN = JJ                                                  
        ENDIF                                                          
        SWAVG = SWAVG+XVEL(3,JJ)                                      
  350 CONTINUE                                                          
      IF (NACTV .GE. 1) THEN                                            
          WAVG = SWAVG/FLOAT(NACTV)                                   
      ELSE                                                              
          WAVG = 0.0
      ENDIF
       IF (IOUT .GT. 0) THEN
       WRITE (IOUT,360) NXMAX,XMAX,NXMIN,XMIN,NYMAX,YMAX,NYMIN,YMIN  
       WRITE (IOUT,370) NWMAX,WMAX,NWMIN,WMIN,WAVG,NACTV            
       ENDIF                                                             
  360 FORMAT (/,10X,'ACTIVE NODAL STATISTICS FOR THIS ITERATION'     
     &    ,//,4X,'NODE',2X,'XVEL-MAX',4X,'NODE',2X,'XVEL-MIN' 
     &   ,4X,'NODE',2X,'YVEL-MAX',4X,'NODE',2X,'YVEL-MIN'      
     &    ,/,4(I8,1X,F9.3))                                          
  370 FORMAT (/,4X,'NODE',2X,'ELEV-MAX',4X,'NODE',2X,'ELEV-MIN'
     &   ,3X,'AVE-ELEV',2X,'NODES ACTIVE',/,
     &     2(I8,1X,F9.3),2X,F9.3,5X,I7,/)
*-
* ... CONTROL FOR PRINTING OF OUTPUT
*-
      IF (IDP .EQ. 2 .AND. IOUT .GT. 0) THEN
         INT = (NPM-LPP)/3+1
         INTT = INT+LPP-1
         IF (METRIC .LE. 0) WRITE (IOUT,390)
         IF (METRIC .GE. 1) WRITE (IOUT,395)
  390    FORMAT (3('  NODE    X-VEL    Y-VEL   DEPTH    ELEV')/
     &           3('          (FPS)    (FPS)    (FT)    (FT)'))
  395    FORMAT (3('  NODE    X-VEL    Y-VEL   DEPTH    ELEV')/
     &           3('          (MPS)    (MPS)    (M)      (M)'))
         IF (IVOUT .GT. 0) THEN
            DO 410 I = LPP,INTT
               WRITE (IOUT,400) (J,(XVEL(K,J),K = 1,2),VEL(3,J),
     &                          XVEL(3,J),J = I,NPM,INT)
  400          FORMAT (3(I6,2F9.3,2F8.3))
  410       CONTINUE
         ENDIF
*-
* ... Define flows for 1-D element node locations
*-
         WRITE (IOUT,420)
  420    FORMAT (/'  FLOWS AT NODES FOR 1-D ELEMENTS'//)            
      ENDIF                                                            
      JJ = 0                                                            
      DO 430 J = 1,NP                                                  
        IF (WIDTH(J) .GT. 0.0) THEN                                      
          JJ = JJ+1                                                   
          XVEL(1,JJ) = J                                                
          XVEL(2,JJ) = (VEL(1,J)*COS(ALFA(J))+VEL(2,J)*
     &            SIN(ALFA(J)))*VEL(3,J)*(2.0*WIDTH(J)+          
     &            (SS1(J)+SS2(J))*VEL(3,J))/2.0
          IF (NSPREF(J) .GT. 0) THEN                                    
              IF (ICYC .GT. 0) THEN                                     
                  JK = NSPREF(J)+(ICYC-1)*JSPLPT                  
               ELSE                                                     
                  JK = NSPREF(J)
               ENDIF
               SPQ(JK) = XVEL(2,JJ)
          ENDIF
        ENDIF
  430 CONTINUE
      IF (ICYC .EQ. 0) THEN
* ... Steady State special print write
        IF (MAXN .EQ. NITI .OR. FACT .LT. STPCRT) THEN
          IF (ISPRT .GT. 0) THEN
            WRITE (ISPRT,270) ICYC,TET,NITSV
            IF (METRIC .LE. 0) WRITE (ISPRT,440)
            IF (METRIC .GE. 1) WRITE (ISPRT,445)
  440       FORMAT (// '  NODE       X-VEL       Y-VEL     TOT-VEL '   
     &          ,'       FLOW     DEPTH      ELEV     CORD(X - Y)'    
     &          ,/,10X,'   (FPS)       (FPS)       (FPS)       '    
     &          ,'(CFS)      (FT)      (FT)          (FT)')           
  445       FORMAT (// '  NODE       X-VEL       Y-VEL     TOT-VEL '   
     &          ,'       FLOW     DEPTH      ELEV     CORD(X - Y)'    
     &          ,/,10X,'   (MPS)       (MPS)       (MPS)       '    
     &          ,'(CMS)       (M)       (M)           (M)')           
            DO 450 I = 1,JSPLPT                                        
               WRITE (ISPRT,530) NSPLPT(I),SPVELX(I),SPVELY(I),
     &                           SPVELT(I),SPQ(I),SPDEP(I),
     &                           SPELEV(I),SPCRDX(I),SPCRDY(I)
  450       CONTINUE
          ENDIF
        ENDIF
      ELSEIF (MOD(ICYC,10) .EQ. 0 .OR. ICYC .EQ. NCYC .OR.
     &        ABS(TET-TMAX) .LT. 0.00001) THEN
* ... Dynamic special print (do every 10th time step last iteration)
        IF (MAXN .EQ. NITN .OR. FACT .LT. STPCRT) THEN
          IF (ISPRT .GT. 0) THEN                                        
            REWIND ISPRT
            WRITE (ISPRT,250) TITLE                                     
            DO 480 JK = 1,JSPLPT                                       
              IF (METRIC .LE. 0) WRITE (ISPRT,462) NSPLPT(JK)             
              IF (METRIC .GE. 1) WRITE (ISPRT,463) NSPLPT(JK)             
  462         FORMAT(//,20X,'HYDROGRAPH FOR NODE',I8,/,                
     &              //,4X,'TIME',7X,'X-VEL',7X,'Y-VEL',6X,'TOT-VEL',  
     &               8X,'FLOW',3X,'DEPTH',6X,'ELEV',/,                 
     &               4X,'(HR)',7X,'(FPS),',7X,'(FPS),',7X,'(FPS)',     
     &               6X,'(CFS)',3X,'(FT)',6X,'(FT)')                    
  463         FORMAT(//,20X,'HYDROGRAPH FOR NODE',I8,/,                
     &              //,4X,'TIME',7X,'X-VEL',7X,'Y-VEL',6X,'TOT-VEL',  
     &               8X,'FLOW',3X,'DEPTH',6X,'ELEV',/,                 
     &               4X,'(HR)',7X,'(MPS),',7X,'(MPS),',7X,'(MPS)',     
     &               6X,'(CMS)',4X,'(M)',7X,'(M)')                      
              DO 470 J = 1,ICYC                                        
                 I = (J-1)*JSPLPT+JK                              
                 WRITE (ISPRT,460) TT(J),SPVELX(I),SPVELY(I),
     &                         SPVELT(I),SPQ(I),SPDEP(I),SPELEV(I)
  460            FORMAT (F8.2,3F12.3,F12.1,2F10.3)
  470         CONTINUE
  480       CONTINUE
          ENDIF
        ENDIF
      ENDIF
*-
* ... Output to SMS solution file - suspended sediment concs. (mg/l)
*-
      DO 9955 I = 1,NP
         CNCC(I) = CNC(I,1)*1000.0
 9955 CONTINUE
      IF (INT2 .EQ. 0 .OR. JQ1 .EQ. 0) GO TO 311
      IF (ICYC .GT. NSTIME) GO TO 312
      IF (NITSV .LT. ITRMAX) GO TO 311
*-
* ... WRITE DMS BANNERS ON FINAL HYDRO RESULTS FIRST TIME THRU
* ... IREC(1) = 427
*-
      CALL CONVRT (BANRM2,15,IPACKB,80,1)
*-
      CALL CONVRT (TITLE,1,IPACKT,77,1)
*-
      REWIND INT2
      MFLG = 1
      NTSZ = NCYC-ICYC
*      WRITE (IOUT,1431) ICYC,NSTIME,NITSV,ITRMAX,NTSZ
* 1431 FORMAT (' ICYC=',I6,' NSTIME=',I5,' NITSV=',I5,' ITRMAX=',I5,
*     &        ' NTSZ=',I6)
      WRITE (INT2) MFLG,NP,NE,NTSZ
*-
  312 IF (NITSV .LT. ITRMAX) GO TO 311
*-
* ... WRITE TIME STEP INFORMATION
*-
      IWRITE = 0
      IF (NTBN .GT. 0) THEN
* ... ONLY USER SELECTED HOURS WILL BE WRITTEN
         DO 341 JJ = 1,NTBN
*            WRITE (IOUT,1331) JJ,NTBN,TBINRY(JJ),TET
* 1331       FORMAT (' JJ1=',I5,' NTBN=',I7,' TBINRY(JJ)=',F10.4,
*     &              ' TET=',F10.4)
            IF (ABS(TBINRY(JJ)-TET) .GT. 0.01) GO TO 341
            IWRITE = 1
  341    CONTINUE
      ELSE
         IWRITE = 1
      ENDIF
*-
*      WRITE (IOUT,1336) NTBN,IWRITE,TET,INT2
* 1336 FORMAT (I10,' IWRITE=',I5,' TET=',F10.5,' INT2=',I5)
      IF (IWRITE .EQ. 1) THEN
         WRITE (INT2) TET,((VEL(J,K),J=1,2),CNCC(K),K = 1,NP),
     &                (IMAT(JJ),JJ = 1,NE)
      ENDIF
  311 CONTINUE
*-
* ... Output to SMS solution file - salinities (ppt)
*-
      IF (INT3 .EQ. 0 .OR. JQ2 .EQ. 0) GO TO 318
      IF (ICYC .GT. NSTIME) GO TO 317
      IF (NITSV .LT. ITRMAX) GO TO 318
*-
* ... WRITE DMS BANNERS ON FINAL HYDRO RESULTS FIRST TIME THRU
* ... IREC(1) = 427
*-
      CALL CONVRT (BANRM2,15,IPACKB,80,1)
*-
      CALL CONVRT (TITLE,1,IPACKT,77,1)
*-
      REWIND INT3
      MFLG = 1
      NTSZ = NCYC-ICYC
*      WRITE (IOUT,1431) ICYC,NSTIME,NITSV,ITRMAX,NTSZ
      WRITE (INT3) MFLG,NP,NE,NTSZ
*-
  317 IF (NITSV .LT. ITRMAX) GO TO 318
*-
* ... WRITE TIME STEP INFORMATION
*-
      IWRITE = 0
      IF (NTBN .GT. 0) THEN
* ... ONLY USER SELECTED HOURS WILL BE WRITTEN
         DO 332 JJ = 1,NTBN
*            WRITE (IOUT,1331) JJ,NTBN,TBINRY(JJ),TET
            IF (ABS(TBINRY(JJ)-TET) .GT. 0.01) GO TO 332
            IWRITE = 1
  332    CONTINUE
      ELSE
         IWRITE = 1
      ENDIF
*-
*      WRITE (IOUT,1339) NTBN,IWRITE,TET,INT3
* 1339 FORMAT (I10,' IWRITE=',I5,' TET=',F10.5,' INT3=',I5)
      IF (IWRITE .EQ. 1) THEN
         WRITE (INT3) TET,((VEL(J,K),J=1,2),CNC(K,2),K = 1,NP),
     &                (IMAT(JJ),JJ = 1,NE)
      ENDIF
  318 CONTINUE
      IF (IDP .EQ. 2 .AND. IOUT .GT. 0) THEN
         INT = (JJ-1)/5+1
         DO 500 I = 1,INT
            WRITE (IOUT,490) (XVEL(1,J),XVEL(2,J),J = I,JJ,INT)
  490       FORMAT (5(F6.0,F9.0))
  500     CONTINUE
          WRITE (IOUT,510) (J,TVOL(J),J = 1,NMAT)
  510     FORMAT (// '   TOTAL VOLUME IN STORAGE BY ELEMENT TYPE'/
     &            /'      TYPE         VOLUME'/(I10,1PE15.4))
      ENDIF
      IF (ABS(EMAX(3)) .GT. 1900.0) THEN
          CALL ZVRS (1)
          STOP
      ENDIF
      RETURN
*-
  520 FORMAT (//(I10,2F12.2,2F12.3))
  530 FORMAT (I6,3F12.3,F12.1,2F10.4,2F12.1)
      END
*-
      SUBROUTINE PREHYD (NCTRL)
*-
      SAVE
*-
* ... HEC STYLE INPUT READER FOR HYDRO2
*-
      INCLUDE 'hsctm.inc'
*-
      COMMON /CARD/ JREC
      DIMENSION REA(200),INT(200)
* === DIMENSION ITIME(4)
      CHARACTER JREC(80)*1,CHAR(200)*20
      CHARACTER IC1*2,IC3*1,ICHECK*10,IC2*1
*-
      INTEGER ENDFLG
*-
      DATA ICHECK /'          '/
*-
      IREAD = 0
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED PREHYD (NCTRL=',NCTRL,')'
*-
* ... NCTRL = 0  FIRST STEADY STATE
* ... NCTRL = 1  STEADY STATE WITH REVISED PARAMETERS
* ... NCTRL = 2  DYNAMIC
* ... NCTRL = 3  DYNAMIC WITH REVISED PARAMETERS
*-
      IF (NCTRL .EQ. 2) GO TO 1970
      IF (NCTRL .EQ. 1) GO TO 250
      IF (NCTRL .EQ. 3) GO TO 250
*-
      NCL = 0
      NODMN = 0
      MAXDMN = MR1
      IBPD = 0
*-
      DO 110 I = 1,MEL
         NFIXH(I) = 0
  110 CONTINUE
*-
* ... READ DMS INFORMATION IF AVAILABLE, CHECKING FOR KEYWORD
*-
      READ (INHEC,120,END = 2040) RECRD
  120 FORMAT (A6)
      IF (RECRD(1:6) .EQ. CHKDMS(1:6)) THEN
        REWIND INHEC
        READ (INHEC,140) STAMP
        READ (INHEC,140) DESC(1)
        READ (INHEC,140) DESC(2)
  140   FORMAT (A80)
  150   FORMAT (' ECHO BANNERS',/,1X,A80,/,1X,A80,/,1X,A80,/)
      ELSE
        REWIND INHEC
        DESC(1)(1:35) = 'NO BANNERS WERE SUPPLIED AS INPUT  '
      ENDIF
*-
* ... READ FIRST "HEC" RECORD, LOOKING FOR A "T" CARD          (T_ CARD)
*-
      READ (INHEC,170) IC1,IC3,TITLE
  170 FORMAT (A2,A1,A77)
  190 CONTINUE
*-
* ... BEGIN HEC STYLE READ FOR T CARDS
*-
  200 CONTINUE
      IF (IC1 .NE. 'T1' .AND. IC1 .NE. 'T2' .AND. IC1 .NE. 'T3') THEN
        PRINT 220
  220   FORMAT (' *** ERROR, "T" CARD EXPECTED, RUN TERMINATED ***')
        STOP 'ERROR'
      ENDIF
      IF (IC1 .EQ. 'T3') GO TO 230
      READ (INHEC,170) IC1,IC3,TITLE
      GO TO 200
*-
* ... DATA INITIALIZATION FOR HEC READS
*-
  230 CONTINUE
      IECHO  = 1
      IERR   = 0
      NCL    = 0
      IDEN   = 0
      INBX   = 0
      IWIND  = 0
      IHGEN  = 0
      IQGEN  = 0
      NCFLW  = 0
      NWID   = 0
      ISTGEN = 0
      IC24   = -9
      IDYN   = 0
      IRO    = 0
      NMAT   = 0
      NPX    = 0
      NWID   = 0
      JSPLPT = 0
      IDNOPT = 0
      NSTORM = 0
      NTBN   = 0
*-
* ... MAIN DATA READ
*-
  250 CONTINUE
      READ (INHEC,260,END = 1840) IC1,IC3,(JREC(I),I = 1,80),ICHECK
  260 FORMAT (A2,A1,80A1,A10)
      IF (ICHECK(1:2) .NE. '  ') THEN
        PRINT 270
  270   FORMAT (' *** ERROR, NEXT INPUT RECORD IS TOO LONG ***')
        IF (IECHO .LT. 1) PRINT 1820,IC1,IC3,(JREC(I),I = 1,80)
        IERR = IERR+1
      ENDIF
      I1 = 1
      IF (IC3 .EQ. ',') IC3 = ' '                                       
      IF (IC1 .EQ. '$F') THEN                                           
* ... FIXED FIELD CARD                                       ($F CARD)
      ELSEIF (IC1 .EQ. '$L') THEN
*     LOGICAL UNIT CONTROL CARD - $L CARD                    ($L CARD)
        IF (IRVIZ .GT. 0) GO TO 1835                                    
        NWD = 7                                                         
        CALL CRACK (I1,NWD,REA,INT,CHAR,'INTEGER  ',IERC)
  280   FORMAT (1X,A2,A1,22I6)
        IF (INT(1) .LT. 0) THEN
             IHOTN = IABS(INT(1))
           ELSEIF (INT(1) .GT. 0) THEN
             IHOTN = 63
           ELSE
             IHOTN = 0
        ENDIF
        IF (INT(2) .LT. 0) THEN
             IHOTO = IABS(INT(2))
           ELSEIF (INT(2) .GT. 0) THEN
             IHOTO = 62
           ELSE                                                         
             IHOTO = 0                                                 
        ENDIF                                                           
        IF (INT(3) .LT. 0) THEN                                        
             IGEON = IABS(INT(3))                                      
           ELSEIF (INT(3) .GT. 0) THEN                                
             IGEON = 60                                                
           ELSE                                                         
             IGEON = 0                                                 
        ENDIF                                                           
        IF (INT(4) .LT. 0) THEN                                        
             IFINO = IABS(INT(4))                                      
           ELSEIF (INT(4) .GT. 0) THEN                                
             IFINO = 64                                                
           ELSE                                                         
             IFINO = 0                                                 
*             PRINT *,' << CAUTION >> Final Binary is turned off via $L' 
        ENDIF                                                           
        IF (INT(5) .LT. 0) THEN                                        
             IBUP = IABS(INT(5))                                       
           ELSEIF (INT(5) .GT. 0) THEN                                
             IBUP = 61
           ELSE
             IBUP = 0
        ENDIF
        IF (INT(6) .LT. 0) THEN
           IOUT = IABS(INT(6))
           ELSEIF (INT(6) .GT. 0) THEN
              IOUT = 3
           ELSE
              IOUT = 0
        ENDIF
        IF (INT(7) .LT. 0) THEN
             ISPRT = IABS(INT(7))
           ELSEIF (INT(7) .GT. 0) THEN
             ISPRT = 59
           ELSE
             ISPRT = 0
        ENDIF
        IF (IGEON .NE. 0) THEN
*-
* ... READ EXTERNAL GFGEN GEOMETRY INFORMATION WITH BANNERS  (GFGEN)
*-
          REWIND IGEON
          READ (IGEON) ITEST
          REWIND IGEON
*-
          IF (ITEST .GT. 200) THEN
* ... This is a true character variable type read
             READ (IGEON) (BANGFG(I),I = 1,15)
             READ (IGEON) (IREC(I),I = 1,40),(FREC(I),I = 1,40)
             IF (IREC(1) .GE. 425) READ (IGEON) TGFGEN
          ELSE
* ... This must be an integer style character-- so convert
             READ (IGEON) MFLG1,MFLG2,MFLG3,MFLG4
             READ (IGEON) IWRT1,(IPACKB(I),I=1,IWRT1)
             READ (IGEON) IWRT2,IWRT3,
     &                    (IREC(I),I =1,IWRT2),(FREC(I),I =1,IWRT3)
             READ (IGEON) IWRT4,(IPACKT(I),I =1,IWRT4)
             CALL CONVRT (BANGFG,15,IPACKB,80,2)
             CALL CONVRT (TGFGEN,1,IPACKT,77,2)
             IF (MFLG3 .GT. MND .OR. MFLG4 .GT. MEL) THEN
                 PRINT *,' ********************************************'
                 PRINT *,' --> GFGEN GEOMETRY EXCEEDS PROGRAM DIMENSION'
                 PRINT *,' --> BINARY GEOM CONTAINS  ',MFLG3,MFLG4
                 PRINT *,' --> HYDRO2 DIMENSIONED TO   ',MND,MEL
                 PRINT *,' ********************************************'
                 STOP'Dim'
             ENDIF
          ENDIF
*-
          READ (IGEON) N,M,((CORD(J,K),K=1,2),ALFA(J),AO(J),J=1,N),
     &                 ((NOP(J,K),K=1,8),IMAT(J),TH(J),NFIXH(J),J=1,M)
*-
          DO 7684 J=1,N
             AOO(J)=AO(J)
 7684     CONTINUE
          IF (IREC(1) .GE. 425)
     &    READ (IGEON) (WIDTH(J),SS1(J),SS2(J),WIDS(J),J=1,N)
*-
* ... Consolidate GFGEN BANGFG/HYDRO2 STAMP../ all into BANRM2
*-
          CALL CONVRT (RECRD,1,IFAKE,1,3)
*-
          NE = M
          NP = N
        ENDIF
*-
      ELSEIF (IC1 .EQ. '$M') THEN
* ... DEFINE THE MACHINE ID                                  ($M CARD)
* ... FOR HANDLING RECORD LENGTHS AND WORD SIZE
        IF (ICYC .GT. NSTIME .OR. IRVIZ .NE. 0) GO TO 1835
        NWD = 1
        DO 300 I = 1,NWD
          INT(I) = 0
  300   CONTINUE
        CALL CRACK (I1,NWD,REA,INT,CHAR,'INTEGER  ',IERC)
        IVRSID = INT(1)
*-
      ELSEIF (IC1 .EQ. 'CA') THEN
*-
* ... READ SPECIAL CALCULATION VARIABLES - CA CARD           (CA CARD)
*-
        REA(1) = 0.0
        NWD = 1
        CALL CRACK (I1,NWD,REA,INT,CHAR,'REAL     ',IERC)
        USERCA = REA(1)
        IF (REA(1) .LT. 0.001) USERCA = 1.6
        PRINT *,' CALCULATION TEMPORAL DERIVATIVE - THETCN = 1/',USERCA
*-
      ELSEIF (IC1 .EQ. 'DE') THEN
* ... READ WETTING AND DRYING BY ELEMENT - DE CARD           (DE CARD)
        DO 310 I = 1,4
           REA(I) = 0.0
           INT(I) = 0
  310   CONTINUE
        NWD = 2
        CALL CRACK (I1,NWD,REA,INT,CHAR,'REAL     ',IERC)
        NWD = 1
        CALL CRACK (I1,NWD,REA,INT,CHAR,'INTEGER  ',IERC)
        DSET = REA(1)*ZSCALE
        IF (ABS(DSET) .LT. 0.00001) DSET = 0.275*ZSCALE
        DSETD = REA(2)*ZSCALE
        IF (ABS(DSETD) .LT. 0.00001) DSETD = 0.60*ZSCALE
        LI = INT(1)
*-
      ELSEIF (IC1 .EQ. 'DM') THEN
* ... MARSH WETTING AND DRYING - DM CARD                     (DM CARD)
        IF (ICYC .GT. NSTIME .OR. IRVIZ .NE. 0) GO TO 1835
        NWD = 5
        DO 330 I = 1,NWD
           INT(I) = 0
           REA(I) = 0.0
  330   CONTINUE
        IF (IC3 .EQ. ' ') THEN
* ... THE ON/OFF SWITCH AND DEFAULT OVERRIDES             (DM_ CARD)
          NWD1 = 1
          CALL CRACK (I1,NWD1,REA,INT,CHAR,'INTEGER  ',IERC)
          NWD2 = 4
          CALL CRACK (I1,NWD2,REA,INT,CHAR,'REAL     ',IERC)
          IDNOPT = INT(1)
          IF (IDNOPT .GT. 0) THEN
            NODE1 = IDNOPT
            NODMAX = MND
            IF (NP .GT. 0) NODMAX = NP
            DO 350 K = NODE1,NODMAX
              NODE = K
  340         FORMAT (' CARD=',A2,A1,' FOR NODE=',I6,' HAS '
     &            ,'BEEN IGNORED',/,' BECAUSE',I10,' MARSH '
     &            ,'ASSIGNMENTS HAVE ALREADY BEEN MADE AND DIMENSION '
     &            ,'LIMIT HIT')
              IF (NODMN .GT. MAXDMN) THEN
                  IERR = IERR+1
                  GO TO 350
              ENDIF
*-
              IDMN(NODE) = 1
              WDMC1(NODE) = REA(1)
              WDMC2(NODE) = REA(2)
              WDMC3(NODE) = REA(3)
              WDMC4(NODE) = REA(4)
  350       CONTINUE
          ENDIF
          IF (IDNOPT .EQ. -2) THEN
* ... USER DEFINES HIS OWN DEFAULT VALUES
            WDMC1(1) = REA(1)
            WDMC2(1) = REA(2)
            WDMC3(1) = REA(3)
            WDMC4(1) = REA(4)
          ENDIF
        ENDIF
        IF (IC3 .EQ. 'E') THEN
*-
* ... MARSH WET & DRY BY ELEMENT NUMBER THEN ASSIGN
* ... CORNER NODE WITH COEFFICIENTS                       (DME CARD)
*-
          NWD1 = 1
          CALL CRACK (I1,NWD1,REA,INT,CHAR,'INTEGER  ',IERC)
          NWD2 = 4
          CALL CRACK (I1,NWD2,REA,INT,CHAR,'REAL     ',IERC)
          IELEM = INT(1)
          IF (NE .LT. 1) THEN
            IERR = IERR+1
            PRINT *,' GEOMETRY WAS NOT DEFINED PRIOR TO DME CARD'
          ENDIF
          DO 360 J = 1,8,2
            NODE = NOP(IELEM,J)
            IF (NODE .EQ. 0) GO TO 360
            IF (NODE .LE. 0 .OR. NODE .GT. MND) THEN
              IERR = IERR+1
            ELSE
              IF (NODMN .GT. MAXDMN) THEN
                IERR = IERR+1
                GO TO 360
              ENDIF
*-
              IDMN(NODE) = 1
              IF (REA(1) .GT. 0.0) WDMC1(NODE) = REA(1)
              IF (REA(2) .GT. 0.0) WDMC2(NODE) = REA(2)
              IF (REA(3) .GT. 0.0) WDMC3(NODE) = REA(3)
              IF (REA(4) .GT. 0.0) WDMC4(NODE) = REA(4)
            ENDIF
  360     CONTINUE
        ENDIF
*-
        IF (IC3 .EQ. 'T') THEN
*-
* ... MARSH WET & DRY BY ELEMENT TYPE THEN ASSIGN
* ... CORNER NODE WITH COEFFICIENTS                      (DMT CARD)
*-
          NWD1 = 1
          CALL CRACK (I1,NWD1,REA,INT,CHAR,'INTEGER  ',IERC)
          NWD2 = 4
          CALL CRACK (I1,NWD2,REA,INT,CHAR,'REAL     ',IERC)
          NMAT = INT(1)
          IF (NE .LT. 1) THEN
            IERR = IERR+1
            PRINT *,' GEOMETRY WAS NOT DEFINED PRIOR TO DMT CARD'
          ENDIF
          DO 390 I = 1,NE                                              
            IF (IMAT(I) .NE. NMAT) GO TO 390                            
            DO 370 J = 1,8,2                                          
              NODE = NOP(I,J)                                           
              IF (NODE .EQ. 0) GO TO 370                                
              IF (NODE .LE. 0 .OR. NODE .GT. MND) THEN                  
                IERR = IERR+1
              ELSE                                                      
*-
                IF (NODMN .GT. MAXDMN) THEN                             
                   PRINT 340,IC1,IC3,NODE,NODMN                     
                   IERR = IERR+1                                      
                   GO TO 370                                            
                ENDIF                                                  
*-
                IDMN(NODE) = 1                                          
                IF (REA(1) .GT. 0.0) WDMC1(NODE) = REA(1)               
                IF (REA(2) .GT. 0.0) WDMC2(NODE) = REA(2)               
                IF (REA(3) .GT. 0.0) WDMC3(NODE) = REA(3)               
                IF (REA(4) .GT. 0.0) WDMC4(NODE) = REA(4)               
              ENDIF                                                    
  370       CONTINUE                                                    
            IELEM = I                                                   
            IF (IECHO .GT. 0) PRINT 380,IELEM,NMAT,(REA(KK),KK = 1,4)                                             
  380       FORMAT (' ELEMENT=',I6,' WITH IMAT=',I6,' ASSIGNED '    
     &          ,'MARSH W&D COEFS=',4F10.4)                          
  390     CONTINUE                                                      
        ENDIF                                                          
        IF (IC3 .EQ. 'N') THEN
*-
* ... MARSH WET & DRY WITH CORNER NODE  OVER-RIDE        (DMN CARD) 
*-
          NWD1 = 1                                                      
          CALL CRACK (I1,NWD1,REA,INT,CHAR,'INTEGER  ',IERC)
          NWD2 = 4                                                      
          CALL CRACK (I1,NWD2,REA,INT,CHAR,'REAL     ',IERC)
          IF (IECHO .GT. 0) PRINT 480,IC1,IC3,INT(1),               
     &                      (REA(K),K = 1,4)                          
          NODE = INT(1)                                                 
          IF (NODE .LT. 1 .OR. NODE .GT. MND) THEN                      
            IERR = IERR+1                                             
            PRINT 400,IC3,IC1,INT(1),(REA(K),K = 1,4)             
  400       FORMAT (' *** OUT OF BOUNDS NODE NO. ON CARD =',/,       
     &            5X,A2,A1,I6,4F10.4)                               
          ELSE                                                          
*- 
            IDMN(NODE) = 1                                              
            IF (NODMN .GT. MAXDMN) THEN                                 
               PRINT 340,IC1,IC3,NODE,NODMN                         
               IERR = IERR+1                                          
               GO TO 410                                                
            ENDIF                                                      
            IF (REA(1) .GT. 0.0) WDMC1(NODE) = REA(1)                   
            IF (REA(2) .GT. 0.0) WDMC2(NODE) = REA(2)                   
            IF (REA(3) .GT. 0.0) WDMC3(NODE) = REA(3)                   
            IF (REA(4) .GT. 0.0) WDMC4(NODE) = REA(4)                   
  410       CONTINUE
*          ISKIP = 1                                                   
          ENDIF                                                        
        ENDIF                                                          
*-                                                                      
      ELSEIF (IC1 .EQ. 'EX' .OR. IC1 .EQ. 'EY') THEN                   
* ... EDDY VISCOSITIES IN X-PLANE                      (EX OR EY CARD) 
        IF (IC1 .EQ. 'EX') THEN                                         
          K1 = 1                                                        
          K2 = 2                                                        
        ELSE                                                            
          K1 = 3                                                        
          K2 = 4                                                        
        ENDIF                                                          
        NWD = 200                                                       
        DO 420 I = 1,NWD                                               
          INT(I) = 0                                                    
          REA(I) = 0.0                                                  
  420   CONTINUE                                                        
        NWD = NWD/2                                                   
        ISTART = 1                                                      
        DO 430 I = 1,NWD                                               
          NWD = 1                                                       
          CALL CRACK (I1,NWD,REA,INT(I),CHAR,'INTEGER  ',IERC)
          IF (NWD .LT. 1) GO TO 440                                     
          NWD = 2                                                       
          CALL CRACK (I1,NWD,REA(ISTART),INT,CHAR,'REAL     ',IERC)
          ISTART = ISTART+2                                           
          ICOUNT = I                                                    
  430   CONTINUE                                                        
  440   CONTINUE                                                        
        NWD = ICOUNT                                                    
        IF (IECHO .GT. 0) PRINT 450,IC1,IC3,(INT(I),                
     &       REA(2*I-1),REA(2*I),I = 1,NWD)                          
  450   FORMAT (1X,A2,A1,20(4(I6,2F12.5),/))                         
        ISTART = 1                                                      
        DO 460 I = 1,NWD                                               
          J = INT(I)                                                    
          IF (J .LT. 1 .OR. J .GT. MEL) THEN                            
            IF (IECHO .LT. 1) PRINT 450,IC1,IC3,(INT(II),           
     &           REA(2*II-1),REA(2*II),II = 1,NWD)                   
            PRINT 770                                                   
            IERR = IERR+1                                             
          ELSE                                                          
            NMAT = MAX0(NMAT,J)                                         
            ORT(J,K1) = REA(ISTART)                                     
            ISTART = ISTART+1                                         
            ORT(J,K2) = REA(ISTART)                                     
            ISTART = ISTART+1                                         
          ENDIF                                                        
  460   CONTINUE                                                        
*-                                                                      
      ELSEIF (IC1 .EQ. 'EV') THEN                                      
* ... FULL EDDY VISCOSITY CARD & N-VALUE                     (EV CARD)
* ... (COMBINATION OF HNE, EX, AND EY)
        INT(1) = 1
        NWD1 = 1
        DO 470 I = 1,NWD
          REA(I) = 0.0
  470   CONTINUE
        CALL CRACK (I1,NWD1,REA,INT,CHAR,'INTEGER  ',IERC)
        NWD = 5
        CALL CRACK (I1,NWD,REA,INT,CHAR,'REAL     ',IERC)
        IF (IECHO .GT. 0) PRINT 480,IC1,IC3,INT(1),(REA(I),I = 1,5)
  480   FORMAT (1X,A2,A1,I6,4G12.5,F12.7)
        J = INT(1)
        IF (J .LT. 1 .OR. J .GT. MEL) THEN
          IF (IECHO .LT. 1) PRINT 480,IC1,IC3,INT(1),(REA(I),I = 1,5)
          PRINT 770
          IERR = IERR+1
        ELSE
          NMAT = MAX0(NMAT,J)
          ORT(J,1) = REA(1)
          ORT(J,2) = REA(2)
          ORT(J,3) = REA(3)
          ORT(J,4) = REA(4)
          IF (NWD .GT. 4) ORT(J,5) = REA(5)
        ENDIF
*-
      ELSEIF (IC1 .EQ. 'FC') THEN
* ... FLOW CONTROL STRUCTURES BY ELEMENT TYPE                (FC CARD)
        IF (ICYC .GT. NSTIME .OR. IRVIZ .NE. 0) GO TO 1835
        NWD = 7
        DO 500 I = 1,NWD                                               
          INT(I) = 0                                                    
          REA(I) = 0.0
  500   CONTINUE                                                        
        NWD1 = 2                                                        
        CALL CRACK (I1,NWD1,REA,INT,CHAR,'INTEGER  ',IERC)
        NWD2 = 5                                                        
        CALL CRACK (I1,NWD2,REA,INT,CHAR,'REAL     ',IERC)
        IF (IECHO .GT. 0) PRINT 510,IC1,IC3,(INT(II),II = 1,2),    
     &                    (REA(II),II = 1,5)                          
  510   FORMAT (1X,A2,A1,2I6,5G12.5)                                
        J = INT(1)                                                      
        K = INT(2)                                                      
        IF (J .GT. 903 .AND. K .LT. 6) THEN                             
* ... LOOK IN SUB SBGEN DO LOOP 400 FOR VARIABLE ASSIGNMENT         
          IF (NCTRL .EQ. 0) NCFLW = NCFLW+1                           
          IFLZ1(NCFLW) = INT(1)                                         
          IFLZ2(NCFLW) = INT(2)                                         
          FLZ3(NCFLW) = REA(1)                                          
          FLZ4(NCFLW) = REA(2)                                          
          FLZ5(NCFLW) = REA(3)                                          
          FLZ6(NCFLW) = REA(4)                                          
          FLZ7(NCFLW) = REA(5)                                          
        ELSE                                                            
          PRINT 520,IC1,IC3,J,K                                     
  520     FORMAT (' ABOVE ',A2,A1,' CARD HAS EITHER AN INVALID '     
     &        ,'FLOW CONTROL ID (IMAT) OR FLOW CONTROLLER TYPE')      
          IERR = IERR+1                                               
        ENDIF                                                          
*-                                                                      
      ELSEIF (IC1 .EQ. 'FD') THEN                                      
* ... FLUID DENSITY BY NODAL VALUE                          (FD CARD) 
        NWD = 200                                                       
        DO 530 I = 1,NWD                                               
          INT(I) = 0                                                    
  530   CONTINUE                                                        
        IF (IC3 .EQ. ' ') NWD = 1                                       
        DO 540 I = 1,NWD                                               
          NWD1 = 1                                                      
          CALL CRACK (I1,NWD1,REA,INT(I),CHAR,'INTEGER  ',IERC)
          IF (NWD1 .LT. 1) GO TO 550                                    
          CALL CRACK (I1,NWD1,REA(I),INT,CHAR,'REAL     ',IERC)
          ICOUNT = I                                                    
  540   CONTINUE                                                        
  550   NWD = ICOUNT
        IF (IECHO .GT. 0) PRINT 560,IC1,IC3,(INT(II),REA(II),II = 1,NWD)
  560   FORMAT (1X,A2,A1,6(I6,F7.3),/,4X,6(I6,F7.3))
        IF (IC3 .EQ. 'N') THEN
* ... INITIALIZE EACH NODE DENSITY INDIVIDUALLY          (FDN CARD)
          DO 580 I = 1,NWD
            NODE = INT(I)
            DENXX = REA(I)
            IF (NODE .GT. MND) THEN
              IF (IECHO .LT. 1) PRINT 560,IC1,IC3,(INT(II),
     &             REA(II),II = 1,NWD)
              IERR = IERR+1
              PRINT 570,IC1,IC3,NODE
  570         FORMAT (' ABOVE ',A2,A1,' CARD HAS AN INVALID NODE #')
            ELSE
              IDEN = IDEN+1                                           
              NODE = INT(I)                                             
              IF (NCON .EQ. 1) DEN(NODE) = REA(I)                                        
            ENDIF                                                      
  580     CONTINUE                                                      
        ELSE                                                            
          IF (IC3 .EQ. ' ') THEN                                        
* ... INITIALIZE THE ENTIRE ARRAY OF NODES GT           (FD_ CARD)
            NODE = INT(1)                                               
            DENXX = REA(1)                                              
            DO 590 JJ = NODE,MND                                       
               IDEN = IDEN+1
               IF (NCON .EQ .1) DEN(JJ) = DENXX
  590       CONTINUE                                                    
          ENDIF                                                        
          IF (IDEN .GT. MND) IDEN = MND                                 
        ENDIF
*-
      ELSEIF (IC1 .EQ. 'FT') THEN                                      
* ... TEMPERATURE CARD (CELCIUS) HAS BEEN READ               (FT CARD)
        NWD = 1                                                         
        REA(1) = 0.0                                                    
        CALL CRACK (I1,NWD,REA,INT,CHAR,'REAL     ',IERC)
        IF (IECHO .GT. 0) PRINT 1310,IC1,IC3,REA(1)                  
        IF (REA(1) .GT. 0.0) TEMPC = REA(1)                              
*-
      ELSEIF (IC1 .EQ. 'G1') THEN                                      
* ... GENERAL GEOMETRY TYPE INFORMATION - G1 CARD            (G1 CARD)
        IF (ICYC .GT. NSTIME .OR. IRVIZ .NE. 0) GO TO 1835
        NWD = 3                                                         
        DO 600 I = 1,NWD
           REA(I) = 0.0
  600   CONTINUE
        CALL CRACK (I1,NWD,REA,INT,CHAR,'REAL     ',IERC)
        NWD = 1                                                         
        INT(1) = 0                                                      
        CALL CRACK (I1,NWD,REA,INT,CHAR,'INTEGER  ',IERC)
        IF (IECHO .GT. 0) PRINT 610,IC1,IC3,(REA(I),I = 1,3),
     &                    INT(1)                                        
  610   FORMAT (1X,A2,A1,3G12.5,I6,G12.5)
        OMEGA  = REA(1)                                                 
        XSCALE = REA(2)                                                 
        ZSCALE = REA(3)                                                 
        NBX = INT(1)                                                    
        IF (NBX .GT. MND) THEN                                          
          IF (IECHO .LT. 1) PRINT 610,IC1,IC3,(REA(I),I = 1,3),    
     &                      INT(1),REA(4)                              
          PRINT 620                                                     
  620     FORMAT (' *** ERROR, NBX IS TOO LARGE ***')                   
          IERR = IERR+1                                               
        ENDIF                                                          
        IF (NBX .LT. 1) INBX = -1                                     
* ... ASSIGN LOCAL AVE LAT DEG- CORIOLIS FORCE BY ELEM
        DO 625 II = 1,NE
           OMEGAS(II) = OMEGA                                           
  625   CONTINUE                                                        
*-
      ELSEIF (IC1 .EQ. 'GC') THEN
* ... READ CONTINUITY CHECK/AUTO BC GENERATION CARD          (GC CARD)
* ... (ONLY USE CORNER NODES)                                         
        IF (ICYC .GT. NSTIME .OR. IRVIZ .NE. 0) GO TO 1835
        NCL = NCL+1                                                   
        IF (NCL .GT. MCC) THEN                                          
          PRINT 1820,IC1,IC3,(JREC(I),I = 1,80)                    
          PRINT 640,MCC                                                
  640     FORMAT (' *** ERROR, TOO MANY CONTINUITY CHECK LINES ***',/, 
     &            '     HYDRO2 IS DIMENSIONED FOR ',I5,' CHECK LINES')    
          IERR = IERR+1                                               
        ELSE                                                            
          NWD = 200                                                     
          DO 650 I = 1,NWD                                             
             INT(I) = 0                                                  
  650     CONTINUE                                                      
          CALL CRACK (I1,NWD,REA,INT,CHAR,'INTEGER  ',IERC)
          LMT(NCL) = INT(1)                                             
          IF (IECHO .GT. 0) PRINT 280,IC1,IC3,(INT(I),I = 1,NWD)    
          IF (LMT(NCL) .GT. MCCN) THEN                                  
            IF (IECHO .LT. 1) PRINT 280,IC1,IC3,(INT(I),I =1,NWD)    
            PRINT 660,MCCN                                             
  660       FORMAT (' *** ERROR, TOO MANY NODES IN THE ABOVE',         
     &              ' CONTINUITY CHECK LINE ***',/,                    
     &              ' *** Program dimension limit for MCCN= ',I6,/)     
            IERR = IERR+1                                             
            GO TO 250                                                   
          ELSE                                                          
            DO 680 I = 1, NWD-1
              LINE(NCL,I) = INT(I+1)
              IF (LINE(NCL,I) .LT. 1 .OR. LINE(NCL,I) .GT. MND) THEN    
                IF (IECHO .LT. 1) PRINT 280,IC1,IC3,(INT(II),       
     &               II = 1,NWD)                                       
                PRINT 670                                               
  670           FORMAT (' *** ERROR, AN OUT OF BOUNDS NODE WAS READ ')  
                IERR = IERR+1                                         
                GO TO 250                                               
              ENDIF                                                    
  680       CONTINUE                                                    
            ISTART = NWD                                                
            NWD = NWD-1                                               
  690       CONTINUE                                                    
            IF (NWD .LT. LMT(NCL)) THEN                                 
* ... READ GC-CARD CONTINUATION CARD INFORMATION                
              READ (INHEC,260,END = 1860) IC1,IC3,(JREC(I),I = 1,80) 
              I1 = 1                                                    
              IF (IC1 .NE. 'GC') THEN                                   
                PRINT 1820,IC1,IC3,(JREC(I),I = 1,80)              
                PRINT 700                                               
  700           FORMAT (' *** ERROR, GC CARD FOR CONTINUATION  OF '     
     &              ,'PREVIOUS GC WAS EXPECTED ***')                  
                IERR = IERR+1                                         
                GO TO 250                                               
              ENDIF                                                    
              NWD = LMT(NCL)                                            
              DO 710 I = 1,NWD                                         
                INT(I) = 0                                              
  710         CONTINUE
              CALL CRACK (I1,NWD,REA,INT,CHAR,'INTEGER  ',IERC)
              IF (IECHO .GT. 0) PRINT 280,IC1,IC3,(INT(I),I = 1,NWD)
              DO 720 I = 1,NWD                                         
                LINE(NCL,ISTART) = INT(I)                               
                IF (LINE(NCL,ISTART) .LT. 1 .OR.                        
     &               LINE(NCL,ISTART) .GT. MND) THEN                    
                  IF (IECHO .LT. 1) PRINT 280,IC1,IC3,               
     &                 (INT(II),II = 1,NWD)                           
                  PRINT 670                                             
                  IERR = IERR+1                                       
                  GO TO 250                                             
                ENDIF                                                  
                ISTART = ISTART+1                                     
  720         CONTINUE                                                  
              NWD = ISTART-1                                          
              GO TO 690                                                 
            ENDIF                                                      
          ENDIF                                                        
        ENDIF                                                          
*-
      ELSEIF (IC1 .EQ. 'GE') THEN
* ... READ ELEMENT CONNECTION TABLE   -GE CARD              (GE CARD)
        IF (ICYC .GT. NSTIME .OR. IRVIZ .NE. 0) GO TO 1835
        NWD = 10                                                        
        DO 730 I = 1,NWD                                               
          INT(I) = 0                                                    
  730   CONTINUE                                                        
        REA(1) = 0.0                                                    
        CALL CRACK (I1,NWD,REA,INT,CHAR,'INTEGER  ',IERC)
        NWD1 = 1                                                        
        CALL CRACK (I1,NWD1,REA,INT,CHAR,'REAL     ',IERC)
        IF (IECHO .GT. 0) PRINT 740,IC1,IC3,(INT(I),I = 1,         
     &       10),REA(1)                                                
  740   FORMAT (1X,A2,A1,10I6,G12.5)                                
        J = INT(1)                                                      
        IF (J .LT. 1 .OR. J .GT. MEL) THEN                              
          IF (IECHO .LT. 1) PRINT 740,IC1,IC3,(INT(I),I = 1,       
     &         10),REA(1)                                              
          PRINT 750                                                     
  750     FORMAT (' *** ERROR, AN OUT OF BOUNDS ELEMENT WAS READ ***')  
          IERR = IERR+1                                               
        ELSE                                                            
          NE = MAX0(NE,J)                                               
          LOW = 0                                                       
          DO 760 I = 8,1,-1                                         
            NODE = INT(I+1)                                             
            NOP(J,I) = NODE                                             
            NP = MAX0(NP,NODE)                                          
            IF (NOP(J,I) .LT. LOW .OR. NOP(J,I) .GT. MND) THEN          
              IF (IECHO .LT. 1) PRINT 740,IC1,IC3,(INT(II),         
     &             II = 1,10),REA(1)                                  
              PRINT 670                                                 
              IERR = IERR+1                                           
            ENDIF                                                      
            IF (NOP(J,I) .GT. 0) LOW = 1                                
  760     CONTINUE                                                      
          IF (NWD .GT. 9) THEN                                          
* ... IMAT WAS READ ON THIS CARD                                  
            IMAT(J) = INT(10)                                           
            IF (IMAT(J) .GT. MEL) THEN                                  
              IF (IECHO .LT. 1) PRINT 740,IC1,IC3,(INT(I),          
     &             I = 1,10),REA(1)                                   
              PRINT 770                                                 
  770         FORMAT (' *** ERROR, AN OUT OF BOUNDS ELEMENT TYPE ',    
     &                'WAS READ ***')                                   
              IERR = IERR+1                                           
            ENDIF                                                      
* ... WAS TH (ANGLE OF ROTATION FOR EDDY VIS) READ ON CARD?       
            IF (NWD1 .GT. 0) TH(J) = REA(1)                             
          ENDIF                                                        
*                          NEED TO MODIFY THE REORDERING LIST           
          IF (NFIXH(INT(1)) .EQ. 0) THEN                                
            NFIXH(INT(1)) = INT(1)                                      
            PRINT 780,INT(1),NFIXH(INT(1))                            
  780       FORMAT (10X,'*** ALERT *** MODIFY REORDERING LIST.  '      
     &          ,'NEW ELEM CREATED BY GE CARD=',I6,' REORDER NO.='  
     &         ,I6)                                                   
          ENDIF                                                        
        ENDIF                                                          
*-                                                                      
      ELSEIF (IC1 .EQ. 'GN' .AND. IC3 .EQ. ' ') THEN                   
* ... NODAL POINT COORDINATE CARD,                         (GN_ CARD)
* ... WITHOUT AO (BOTTOM ELEV) ON CARD                                
        IF (ICYC .GT. NSTIME .OR. IRVIZ .NE. 0) GO TO 1835
        NPX = NPX+1                                                   
        NWD = 200                                                       
        DO 790 I = 1,NWD                                               
          INT(I) = 0                                                    
          REA(I) = 0.0                                                  
  790   CONTINUE                                                        
        NWD = NWD/2                                                   
        ISTART = 1                                                      
        DO 800 I = 1,NWD                                               
          NWD = 1                                                       
          CALL CRACK (I1,NWD,REA,INT(I),CHAR,'INTEGER  ',IERC)
          IF (NWD .LT. 1) GO TO 810                                     
          CALL CRACK (I1,NWD,REA(ISTART),INT,CHAR,'REAL     ',IERC)
          ISTART = ISTART+2                                           
          ICOUNT = I                                                    
  800   CONTINUE                                                        
  810   CONTINUE                                                        
        NWD = ICOUNT                                                    
        IF (IECHO .GT. 0) PRINT 820,IC1,IC3,(INT(I),                
     &       REA(2*I-1),I = 1,NWD)                                    
  820   FORMAT (1X,A2,A1,28(4(I6,2G12.5,/)))                         
        ISTART = 1                                                      
        DO 830 I = 1,NWD                                               
          J = INT(I)                                                    
          IF (J .LT. 1 .OR. J .GT. MND) THEN                            
            IF (IECHO .LT. 1) PRINT 820,IC1,IC3,(INT(II),           
     &           REA(2*II-1),II = 1,NWD)                              
            PRINT 670                                                   
            IERR = IERR+1                                             
          ELSE                                                          
            NP = MAX0(NP,J)                                             
            CORD(J,1) = REA(ISTART)                                     
            ISTART = ISTART+1                                         
            CORD(J,2) = REA(ISTART)                                     
            ISTART = ISTART+1                                         
          ENDIF                                                        
  830   CONTINUE                                                        
*-                                                                      
      ELSEIF (IC1 .EQ. 'GN' .AND. IC3 .EQ. 'N') THEN                   
* ... NODE COORDINATE AND ELEVATION (JUST LIKE GFGEN)       (GNN CARD)
        IF (ICYC .GT. NSTIME .OR. IRVIZ .NE. 0) GO TO 1835
        NPX = NPX+1                                                   
        NWD = 7                                                         
        INT(1) = 0                                                      
        DO 840 I = 1,NWD                                               
          REA(I) = 0.0                                                  
  840   CONTINUE                                                        
        NWD1 = 1                                                        
        CALL CRACK (I1,NWD1,REA,INT,CHAR,'INTEGER  ',IERC)
        NWD = 7                                                         
        CALL CRACK (I1,NWD,REA,INT,CHAR,'REAL     ',IERC)
        IF (IECHO .GT. 0) PRINT 850,IC1,IC3,INT(1),(REA(I),I=1,NWD)
  850   FORMAT (1X,A2,A1,I6,2G12.5,F12.4,4F12.3)
        J = INT(1)
        IF (J .LT. 1 .OR. J .GT. MND) THEN
          IF (IECHO .LT. 1) PRINT 850,IC1,IC3,INT(1),(REA(I),I=1,NWD)
          PRINT 670
          IERR = IERR+1
        ELSE
          NP = MAX0(NP,J)
          CORD(J,1) = REA(1)
          CORD(J,2) = REA(2)                                            
          AO(J)     = REA(3)                                            
          IF (NWD .GE. 4) THEN                                           
             WIDTH(J) = REA(4)                                          
             SS1(J)   = REA(5)                                          
             SS2(J)   = REA(6)                                          
             WIDS(J)  = REA(7)                                          
          ENDIF                                                         
        ENDIF                                                          
*-                                                                      
      ELSEIF (IC1 .EQ. 'GO') THEN                                      
* ... REORDERING CARD HAS BEEN READ                          (GO CARD)
        IF (ICYC .GT. NSTIME .OR. IRVIZ .NE. 0) GO TO 1835
        NWD = 200                                                       
        DO 860 I = 1,NWD                                               
          INT(I) = 0                                                    
  860   CONTINUE                                                        
        CALL CRACK (I1,NWD,REA,INT,CHAR,'INTEGER  ',IERC)
        IF (IECHO .GT. 0) PRINT 870,IC1,IC3,(INT(I),I = 1,NWD)      
  870   FORMAT (1X,A2,A1,20I6)                                       
        DO 900 I = 1,NWD                                               
          IRO = IRO+1                                                 
          IF (IRO .GT. MEL) THEN
            PRINT 880,IC1,IC3,(INT(K),K = 1,NWD)
  880       FORMAT (' IRO COUNTER EXCEEDS MAX ELEM DIMENSION -  '
     &          ,'LAST CARD PROCESSED WAS ...',/,1X,A2,A1,20I6,/)
            IERR = IERR+1                                             
          ELSEIF (INT(I) .GT. MEL) THEN                                
            PRINT 890,IC1,IC3,INT(I)                                 
  890       FORMAT (1X,' CARD=',A2,A1,' CONTAINS ELEMENT NUMBER='   
     &         ,I8,' AND EXCEEDS MAX ELEM DIMENSION.')               
            IERR = IERR+1                                             
          ENDIF                                                        
          NFIXH(IRO) = INT(I)                                           
  900   CONTINUE                                                        
        PRINT *,' BEWARE -REORDERING LIST OVER-RULED IF GFGEN IS READ' 
*-                                                                      
      ELSEIF (IC1 .EQ. 'GT') THEN                                      
* ... ELEMENT TYPE CARD                                      (GT CARD)
        NWD = 200                                                       
        DO 910 I = 1,NWD                                               
          INT(I) = 0                                                    
  910   CONTINUE                                                        
        CALL CRACK (I1,NWD,REA,INT,CHAR,'INTEGER  ',IERC)
        IF (IECHO .GT. 0) PRINT 280,IC1,IC3,(INT(I),I = 1,NWD)      
        DO 920 I = 1,NWD,2
          J = INT(I)
          IF (J .LT. 1 .OR. J .GT. MEL) THEN
            IF (IECHO .LT. 1) PRINT 280,IC1,IC3,(INT(II),II = 1,NWD)
            PRINT 750                                                   
            IERR = IERR+1                                             
          ELSE
            IMAT(J) = INT(I+1)
            IF (IMAT(J) .GT. MEL) THEN
              IF (IECHO .LT. 1) PRINT 280,IC1,IC3,(INT(II),II = 1,NWD)
              PRINT 770                                                 
              IERR = IERR+1                                           
            ENDIF                                                      
          ENDIF                                                        
  920   CONTINUE                                                        
*-
      ELSEIF (IC1 .EQ. 'GV') THEN                                      
*-
* ... EDDY VISCOSITY ANGLE CARD                              (GV CARD)
*-
        NWD = 200
        DO 930 I = 1,NWD
          INT(I) = 0
          REA(I) = 0.0
  930   CONTINUE
        DO 940 I = 1,NWD
          NWD1 = 1
          CALL CRACK (I1,NWD,REA,INT(I),CHAR,'INTEGER  ',IERC)
          IF (NWD1 .LT. 1) GO TO 950
          CALL CRACK (I1,NWD,REA(I),INT,CHAR,'REAL     ',IERC)
          ICOUNT = I
  940   CONTINUE
  950   CONTINUE
        NWD = ICOUNT
        IF (IECHO .GT. 0) PRINT 960,IC1,IC3,(INT(I),REA(I),I=1,NWD)
  960   FORMAT (1X,A2,A1,28(7(I6,G12.5),/))                          
        DO 970 I = ISTART,NWD                                          
          J = INT(I)                                                    
          IF (J .LT. 1 .OR. J .GT. MEL) THEN                            
            IF (IECHO .LT. 1) PRINT 960,IC1,IC3,(INT(II),           
     &           REA(II),II = 1,NWD)                                  
            PRINT 750                                                   
            IERR = IERR+1                                             
          ELSE                                                          
            TH(J) = REA(I+1)                                            
          ENDIF                                                        
  970   CONTINUE                                                        
*-                                                                      
      ELSEIF (IC1 .EQ. 'GW') THEN                                      
* ... NODAL CROSS SECTIONAL WIDTHS                           (GW CARD)
        IF (ICYC .GT. NSTIME .OR. IRVIZ .NE. 0) GO TO 1835
        NWD = 4                                                         
        DO 980 I = 1,NWD                                               
          REA(I) = 0.0                                                  
          INT(I) = 0                                                    
  980   CONTINUE                                                        
        NWD1 = 1
        CALL CRACK (I1,NWD1,REA,INT,CHAR,'INTEGER  ',IERC)
        NWD2 = 4
        CALL CRACK (I1,NWD2,REA,INT,CHAR,'REAL    ',IERC)
        IF (IECHO .GT. 0) PRINT 990,IC1,IC3,INT(1),(REA(II),II = 1,4)
  990   FORMAT (1X,A2,A1,I6,4G12.5)                                 
        NODE = INT(1)                                                   
        IF (NODE .LT. 1 .OR. NODE .GT. MND) THEN                        
          IF (IECHO .LT. 1) PRINT 990,IC1,IC3,INT(1),               
     &         (REA(II),II = 1,NWD2)                                  
          PRINT 670                                                     
          IERR = IERR+1                                               
        ELSE                                                            
          IF (IC3 .NE. ' ') THEN                                        
* ... INITIALIZE BY NODE                                          
            NWID = NWID+1                                             
            WIDTH(NODE) = REA(1)                                        
            SS1(NODE) = REA(2)                                          
            SS2(NODE) = REA(3)                                          
            WIDS(NODE) = REA(4)                                         
          ELSE                                                          
* ... INITIALIZE ENTIRE RANGE OF VALUES                           
            DO 1000 II = NODE,MND                                      
              NWID = NWID+1                                           
              WIDTH(II) = REA(1)                                        
              SS1(II) = REA(2)                                          
              SS2(II) = REA(3)                                          
              WIDS(II) = REA(4)                                         
 1000       CONTINUE                                                    
          ENDIF                                                        
        ENDIF                                                          
*-                                                                      
      ELSEIF (IC1 .EQ. 'GY') THEN                                      
*-
* ... NODE ELEVATION (AO) CARD WAS READ                      (GY CARD)
*-
        IF (ICYC .GT. NSTIME .OR. IRVIZ .NE. 0) GO TO 1835
        NWD = 200
        DO 1010 I = 1,NWD
          INT(I) = 0
          REA(I) = 0.0
 1010   CONTINUE
        DO 1020 I = 1,NWD
          NWD1 = 1
          CALL CRACK (I1,NWD1,REA,INT(I),CHAR,'INTEGER  ',IERC)
          IF (NWD1 .LT. 1) GO TO 1030
          CALL CRACK (I1,NWD1,REA(I),INT,CHAR,'REAL     ',IERC)
          ICOUNT = I
 1020   CONTINUE
 1030   CONTINUE
        NWD = ICOUNT
        IF (IECHO .GT. 0) PRINT 960,IC1,IC3,(INT(I),REA(I),I = 1,NWD)
        DO 1040 I = 1,NWD                                              
          J = INT(I)                                                    
          IF (J .LT. 1 .OR. J .GT. MND) THEN                            
            IF (IECHO .LT. 1) PRINT 960,IC1,IC3,(INT(II),           
     &           REA(II),II = 1,NWD)                                  
            PRINT 670                                                   
            IERR = IERR+1                                             
          ELSE                                                          
            NP = MAX0(NP,J)                                             
            AO(J) = REA(I)
          ENDIF
 1040   CONTINUE
*-
        IF (IC3 .EQ. ' ') THEN
* ... INITIALIZE ENTIRE AO ARRAY                          (GY_ CARD)
          DO 1050 I = 1,NP
            AO(I) = REA(1)
 1050     CONTINUE
        ENDIF
*-
      ELSEIF (IC1 .EQ. 'HN' .AND. (IC3 .EQ. 'T' .OR. IC3 .EQ. 'E')) THEN     
* ... MANNING'S N CARD HAS BEEN READ                        (HN TYPE) 
        NWD = 200                                                       
        DO 1070 I = 1,NWD
          INT(I) = 0
          REA(I) = 0.0                                                  
 1070   CONTINUE                                                        
        DO 1080 I = 1,NWD                                              
          NWD1 = 1                                                      
          CALL CRACK (I1,NWD1,REA,INT(I),CHAR,'INTEGER  ',IERC)
          IF (NWD1 .LT. 1) GO TO 1090
          CALL CRACK (I1,NWD1,REA(I),INT,CHAR,'REAL     ',IERC)
          ICOUNT = I                                                    
 1080   CONTINUE                                                        
 1090   CONTINUE                                                        
        NWD = ICOUNT                                                    
        IF (IECHO .GT. 0) PRINT 960,IC1,IC3,(INT(I),REA(I),I = 1,NWD)                                                
        DO 1100 I = 1,NWD                                              
* ... CHECK FOR IMAT OR ELEM NUMBER EXCEEDING DIMENSION             
          J = INT(I)                                                    
          IF (J .LT. 1 .OR. J .GT. MEL) THEN                            
            IF (IECHO .LT. 1) PRINT 960,IC1,IC3,(INT(II),           
     &           REA(II),II = 1,NWD)                                  
            PRINT 750                                                   
            IERR = IERR+1                                             
          ELSE                                                          
            IF (IC3 .EQ. 'T') THEN
* ... MANNINGS-N VALUE ASSIGNED BY ELEMENT TYPE       (HNT CARD)
              ORT(J,5) = REA(I)
              IF (REA(I) .LE. 3.0) ZMANN(J) = ORT(J,5)
              IF (REA(I) .GT. 3.0) CHEZ(J) = ORT(J,5)
            ENDIF
          ENDIF
 1100   CONTINUE
*-EJH
      ELSEIF (IC1 .EQ. 'HN') THEN
* ... NEED TO INTIALIZE ALL OF MANNING'S N'S                (HN_ CARD)
        NWD = 1
        DO 1110 I = 1,NWD
          REA(I) = 0.0
 1110   CONTINUE
        CALL CRACK (I1,NWD,REA,INT,CHAR,'REAL     ',IERC)
        IF (IECHO .GT. 0) PRINT 1310,IC1,IC3,REA(1)
        DO 1120 I = 1,MEL
           ORT(I,5) = REA(NWD)
 1120   CONTINUE
*-
      ELSEIF (IC1 .EQ. 'IC') THEN
* ... INITIAL WATER SURFACE ELEVATION/VELOCITY               (IC CARD)
        IF (ICYC .GT. NSTIME .OR. IRVIZ .NE. 0) GO TO 1835
        NWD = 3
        DO 1130 I = 1,NWD
          REA(I) = 0.0
 1130   CONTINUE
        CALL CRACK (I1,NWD,REA,INT,CHAR,'REAL     ',IERC)
        IF (IECHO .GT. 0) PRINT 1140,IC1,IC3,(REA(I),I = 1,NWD)
 1140   FORMAT (1X,A2,A1,4G12.5)                                     
        ELEV = REA(1)*ZSCALE
        HMIN = REA(2)                                                   
        UNOM = REA(3)                                                   
      ELSEIF (IC1 .EQ. 'LA' .AND. IC3 .EQ. 'T') THEN
* ... LOCAL AVE LATITUDE DEGREES BY IMAT NUMBER (CORIOLIS)  (LAT CARD)
        NWD = 200                                                       
        DO 1142 I = 1,NWD                                              
          INT(I) = 0                                                    
          REA(I) = 0.0                                                  
 1142   CONTINUE                                                        
        ILAT = 0                                                        
        IWARN = 0                                                       
        DO 1144 I = 1,NWD                                              
          NWD1 = 1                                                      
          CALL CRACK (I1,NWD1,REA,INT(I),CHAR,'INTEGER  ',IERC)
          IF (NWD1 .LT. 1) GO TO 1146                                   
          NWD2 = 1                                                      
          CALL CRACK (I1,NWD2,REA(I),INT,CHAR,'REAL     ',IERC)
          IF (REA(I).GT. OMEGA) IWARN = IWARN+1                      
          ILAT = ILAT+1                                               
 1144   CONTINUE
 1146   IF (IECHO .GT. 0) PRINT 960,IC1,IC3,(INT(II),REA(II),II=1,ILAT)
        IF (IWARN .GT. 0) THEN
           PRINT 1147,IWARN,OMEGA,IC1,IC3,(INT(II),REA(II),II = 1,ILAT)
 1147      FORMAT(' *** WARNING LOCAL LATITUDE HAS EXCEEDED THE',      
     &            '     GLOBAL VALUE',I5,' TIMES.  GLOBAL=',F8.4,/,    
     &            '     CARD=',A2,A,20(I6,F10.4),/)                     
           IF (IOUT .GT. 0) WRITE (IOUT,1147)                              
     &        IWARN,OMEGA,IC1,IC3,(INT(II),REA(II),II= 1,ILAT)    
        ENDIF
        DO 1150 I = 1,ILAT
           MAT = INT(I)
           IF (MAT .LT. 1 .OR. MAT .GT. MEL) THEN
           IF (IECHO .LT. 1) PRINT 960,IC1,IC3,(INT(II),
     &                       REA(II),II = 1,ILAT)
            PRINT 770                                                   
            IERR = IERR+1                                             
          ELSE                                                          
            DO 1148  J = 1,NE                                          
* ... ASSIGNMENT OF CORIOLIS BY ELEMENT NO. VIA IMAT
              IF (IMAT(J) .EQ. MAT) OMEGAS(J) = REA(I)                   
 1148       CONTINUE                                                    
          ENDIF
 1150   CONTINUE
*-
      ELSEIF (IC1 .EQ. 'SI') THEN
* ... SYSTEM INTERNATIONAL UNITS
        NWD = 1
        INT(1) = 0
        CALL CRACK (I1,NWD,REA,INT,CHAR,'INTEGER  ',IERC)
        METRIC = INT(1)
        IF (METRIC .LE. 0) THEN
* ... ENGLISH UNITS COMING IN AND GOING OUT
            GRAV  = 32.2
            FCOEF = GRAV/2.208
            IF (BANGFG(1)(41:46) .EQ. 'METRIC') THEN
                IF (IBATCH .EQ. 0) CALL BEEP (10)
                PRINT *,' --> STOP.. GFGEN BANNER SHOWS METRIC UNITS'
                PRINT *,' -->        BUT SI-CARD INDICATES ENGLISH'
                STOP'units'                                             
            ENDIF                                                       
        ELSEIF (METRIC .GE. 1) THEN                                   
* ... METRIC UNITS COMING IN AND GOING OUT
            GRAV  = 9.81                                                
            FCOEF = GRAV                                                
            IF (BANGFG(1)(41:47) .EQ. 'ENGLISH') THEN                    
                IF (IBATCH .EQ. 0) CALL BEEP (10)                         
                PRINT *,' --> STOP.. GFGEN BANNER SHOWS ENGLISH UNITS'  
                PRINT *,' -->        BUT SI-CARD INDICATES METRIC'
                STOP'units'                                             
            ENDIF                                                       
        ENDIF                                                           
        DO 1160 J = 1,MND                                              
* ... SI CARD ... VARIABLE METRIC WAS JUST SET IN PREHYD           
           IF (IDEN .GT. 0) THEN                                        
               PRINT *,' --> The user must put the SI-Card before'      
               PRINT *,'     specifying the density, FD type cards ...' 
               PRINT *,'     Otherwise the defaults for array RON'      
               PRINT *,'     may not be correctly set.'                 
               IF (IBATCH .EQ. 0) CALL BEEP (10)                          
               IERR = IERR+1                                          
           ENDIF
           IF (NCON .EQ. 1) THEN
              IF (METRIC .EQ. 0) DEN(J) = 1.935
              IF (METRIC .GE. 1) DEN(J) = 1.935*516.0
           ENDIF
 1160   CONTINUE
*-
      ELSEIF (IC1 .EQ. 'TI') THEN
* ... NUMBER OF ITERATION TYPE CARD HAS BEEN READ            (TI CARD)
        NWD = 2
        INT(1) = 0
        INT(2) = 0                                                      
        CALL CRACK (I1,NWD,REA,INT,CHAR,'INTEGER  ',IERC)
        NWD = 2
        REA(1) = 0.0
        REA(2) = 0.0
        CALL CRACK (I1,NWD,REA,INT,CHAR,'REAL     ',IERC)
        IF (IECHO .GT. 0) PRINT 1165,IC1,IC3,INT(1),INT(2),REA(1),REA(2)
 1165   FORMAT (1X,A2,A1,2I6,2F12.8)
        IF (ABS(DSET) .LT. 0.00001) DSET = 0.275
        NITI     = INT(1)
        NITN     = INT(2)
        SSDCRT  = REA(1)
        USDCRT  = REA(2)
        IF (SSDCRT .LE. -0.001) SSDCRT = DSET*0.5
        IF (USDCRT .LE. -0.001) USDCRT = DSET*0.5
*-
      ELSEIF (IC1 .EQ. 'TO') THEN
* ... TIMING CONTROL (HOURS) FOR BINARY OUTPUT WRITE        (TO CARD)
        IF (ICYC .GT. NSTIME .OR. IRVIZ .NE. 0) GO TO 1835
        NWD = 200
        ICOUNT = 0
        DO 1170 I = 1,NWD
           REA(I) = 0.0
 1170   CONTINUE
        DO 1180 II = 1,NWD
          NWD1 = 1
          CALL CRACK (I1,NWD1,REA(II),INT,CHAR,'REAL     ',IERC)
          IF (NWD1 .LT. 1) GO TO 1190
          ICOUNT = II
 1180   CONTINUE
 1190   NWD = ICOUNT
        IF (IECHO .GT. 0) PRINT 1200,IC1,IC3,(REA(I),I = 1,NWD)
 1200   FORMAT (1X,A2,A1,(12F8.4,/,4X))
*-
* ... THE FOLLOWING ROUTINE USES THREE INPUTS FROM THE TO CARD TO
* ... WRITE TO THE SOLUTION FILE ON A REGULAR INTERVAL.
* ... THE INPUTS ARE AS FOLLOWS:
*
*        REA(1) - TIMESTEP
*        REA(2) - START TIME
*        REA(3) - END TIME
*
*-
         TOSTEP = REA(1)
         TOSTART = REA(2)
         TOFIN = REA(3)
         JNUMB = (TOFIN-TOSTART)/TOSTEP+2
         DO 1210 JJ = 1,JNUMB
            TOTIME = TOSTART+TOSTEP*(JJ-1)
            TBINRY(JJ) = TOTIME
            NTBN = NTBN+1
 1210    CONTINUE
*-
      ELSEIF (IC1 .EQ. 'TR') THEN
* ... TRACE PRINT OUT CARD - TR CARD                          (TR TYPE)
        NWD = 200
        DO 1220 I = 1,NWD
          INT(I) = 0
 1220   CONTINUE
        IF (IC3 .EQ. ' ') THEN
* ... ON/OFF SWITCH FOR PRINT CONTROL                         (TR CARD)
          NWD = 5
          CALL CRACK (I1,NWD,REA,INT,CHAR,'INTEGER  ',IERC)
          IPRT = INT(1)
          ITSI = INT(2)
          IECHO = INT(3)
          IF (NWD .EQ. 4 .AND. INT(4) .LT. 1) THEN
            ISPRT = 0                                                   
            IF (IECHO .GT. 0) PRINT 1230                                
 1230       FORMAT (5X,'DISABLE SUMMARY PRINTOUT BY NODE VARIABLE',/, 
     &              5X,'ISPRT=0   BY TR-CARD 4TH FIELD SPECIFICATION') 
          ENDIF                                                        
          IF (NWD .EQ. 5) ITRACE = INT(5)                               
        ENDIF                                                          
        IF (IC3 .EQ. 'N') THEN
* ... TRACE PRINTOUT FOR SPECIAL NODE LIST               (TRN CARD) 
          IF (ICYC .GT. NSTIME .OR. IRVIZ .NE. 0) GO TO 1835
          DO 1240 II = 1,NWD                                           
            NWD1 = 1                                                    
            CALL CRACK (I1,NWD1,REA,INT(II),CHAR,'INTEGER  ',IERC)
            IF (NWD1 .LT. 1) GO TO 1250                                 
            ICOUNT = II                                                 
 1240     CONTINUE                                                      
 1250     NWD = ICOUNT                                                  
          IF (IECHO .GT. 0) PRINT 1260,IC1,IC3,(INT(JJ),JJ=1,NWD)     
 1260     FORMAT (1X,A2,A1,(12I6,/,4X))                           
          DO 1280 JJ = 1,NWD                                           
            NODE = INT(JJ)                                              
            IF (NODE .LT. 1 .OR. NODE .GT. MND) THEN                    
              IERR = IERR+1                                           
              PRINT 1270,IC1,IC3,NODE                                
 1270         FORMAT (' *** THE ABOVE ',A2,A1,' CARD HAS AN OUT ',  
     &                'OF BOUNDS NODE=',I12)                           
            ELSE                                                        
              JSPLPT = JSPLPT+1                                       
              NSPLPT(JSPLPT) = NODE                                     
            ENDIF                                                      
 1280     CONTINUE                                                      
        ENDIF                                                          
*-                                                                      
      ELSEIF (IC1 .EQ. 'TZ') THEN
* ... COMPUTATION TIME CARD HAS BEEN READ                    (TZ CARD)
        IF (ICYC .GT. NSTIME .OR. IRVIZ .NE. 0) GO TO 1835
        NWD = 2                                                         
        NWD1 = 3                                                        
        DO 1300 I = 1,NWD1                                             
          REA(I) = 0.0
          INT(I) = 0                                                    
 1300   CONTINUE                                                        
        CALL CRACK (I1,NWD,REA,INT,CHAR,'REAL     ',IERC)
        CALL CRACK (I1,NWD1,REA,INT,CHAR,'INTEGER  ',IERC)
        IF (IECHO .GT. 0) PRINT 1310,IC1,IC3,REA(1),REA(2),        
     &       (INT(II),II = 1,3)                                       
 1310   FORMAT (1X,A2,A1,2G12.5,3I6)
        DELT   = REA(1)                                                 
        TMAX   = REA(2)                                                 
        NCYC   = INT(1)                                                 
        NSTART = INT(2)                                                 
        MBAND  = INT(3)                                                 
*-
      ELSEIF (IC1 .EQ. 'BC') THEN                                      
* ... BOUNDARY CONDITION TYPE CARD READ -                    (BC TYPE)
        NWD = 200                                                       
        DO 1350 I = 1,NWD                                              
          INT(I) = 0                                                    
          REA(I) = 0.0                                                  
 1350   CONTINUE                                                        
        IF (IC3 .EQ. 'C') THEN                                          
* ... BOUNDARY UPDATE CONTROL PARAMETERS READ             (BCC CARD)
          NWD1 = 1                                                      
          CALL CRACK (I1,NWD1,REA,INT,CHAR,'REAL     ',IERC)
          NWD2 = 2                                                      
          CALL CRACK (I1,NWD2,REA,INT,CHAR,'INTEGER  ',IERC)
          IF (IECHO .GT. 0) THEN                                        
            PRINT 1360,IC1,IC3,REA(1),(INT(I),I = 1,8)            
 1360       FORMAT (/,' BOUNDARY SPECIFICATION UPDATES',/,         
     &           1X,A2,A1,G12.5,8I6)                                
          ENDIF                                                        
          DELTN = REA(1)                                                
          NBX   = INT(1)                                                
          IWIND = INT(2)                                                
          IF (DELTN .GT. 0.0) DELT = DELTN
          IF (NBX .LT. 1) INBX = -1                                   
        ENDIF                                                          
        IF (IC3 .EQ. 'N') THEN                                          
* ... BOUNDARY SPECIFICATION BY NODE                      (BCN CARD)
          NWD1 = 2                                                      
          CALL CRACK (I1,NWD1,REA,INT,CHAR,'INTEGER  ',IERC)
          NWD2 = 3                                                      
          CALL CRACK (I1,NWD2,REA,INT,CHAR,'REAL     ',IERC)
          IF (IECHO .GT. 0) THEN                                        
            PRINT 1370,IC1,IC3,(INT(I),I = 1,2),(REA(I),I=1,3)   
 1370       FORMAT (1X,A2,A1,2I6,3G12.5)                            
          ENDIF                                                        
          J = INT(1)                                                    
          IF (J .LT. 1 .OR. J .GT. MND) THEN
            IF (IECHO .EQ. 0) PRINT 1370,IC1,IC3,(INT(I),I = 1,2),
     &                        (REA(I),I = 1,3)
            PRINT 670                                                   
            IERR = IERR+1                                             
          ELSE                                                          
* ... INCREMENT NBX COUNTER
            NODE = INT(1)                                               
            IF (IBCSET .GT. 0) THEN                                     
* ... LOOK TO SEE IF THIS NODE HAS A PREVIOUS BCN SPEC        
                IFOUND = 0                                              
                DO 1375 II = 1,IBPD                                    
                   IF (NODE .EQ. KNBX(II)) IFOUND = 1                    
 1375           CONTINUE                                                
                IF (IFOUND .EQ. 1) GO TO 1377                             
                IF (IFOUND .EQ. 0) THEN                                   
                    PRINT *,' BCN CARD FOR NODE=',NODE,'ILLEGAL'       
                    GO TO 1835                                          
                ENDIF                                                   
            ENDIF                                                       
            IF (INBX .LT. 0) THEN                                       
                NBX = NBX+1                                           
            ELSE                                                        
                INBX = INBX+1                                         
                IF (INBX .GE. NBX) GO TO 1860                           
            ENDIF                                                      
            IBPD = IBPD+1                                             
            KNBX(IBPD) = NODE                                           
*-                                                                      
 1377       NODE = INT(1)                                               
            NFIX(NODE) = INT(2)                                         
            IF (IDYN .GT. 0) NFIX(J) = -NFIX(J)                       
            SPEC(NODE,1) = REA(1)                                       
            SPEC(NODE,2) = REA(2)                                       
            SPEC(NODE,3) = REA(3)                                       
          ENDIF                                                        
        ENDIF                                                          
*                                                                       
      ELSEIF (IC1 .EQ. 'BA') THEN                                      
* ... BOUNDARY AZIMUTH CARD -                                (BA CARD)
        NWD = 200                                                       
        DO 1380 I = 1,NWD                                              
          INT(I) = 0                                                    
          REA(I) = 0.0                                                  
 1380   CONTINUE                                                        
        DO 1390 I = 1,NWD                                              
          NWD1 = 1                                                      
          CALL CRACK (I1,NWD1,REA,INT(I),CHAR,'INTEGER  ',IERC)
          IF (NWD1 .LT. 1) GO TO 1400                                   
          CALL CRACK(I1,NWD1,REA(I),INT,CHAR,'REAL     ',IERC)
          ICOUNT = I                                                    
          IRSLP = ICOUNT                                                
 1390   CONTINUE
 1400   CONTINUE
        NWD = ICOUNT
        IF (IECHO .GT. 0) PRINT 960,IC1,IC3,(INT(I),REA(I),I = 1,NWD)
        DO 1410 I = 1,NWD                                              
          J = INT(I)                                                    
          IF (J .LT. 1 .OR. J .GT. MND) THEN                            
            IF (IECHO .LT. 1) PRINT 960,IC1,IC3,(INT(II),           
     &           REA(II),II = 1,NWD)                                  
            PRINT 670                                                   
            IERR = IERR+1                                             
          ELSE                                                          
            ALFAK(J) = REA(I)                                           
          ENDIF                                                        
 1410   CONTINUE                                                        
        IF (IC3 .EQ. ' ') THEN                                          
* ... INITIALIZE ENTIRE ALFAK ARRAY                       (BA_ CARD)
          DO 1420 I = J,MND                                            
            ALFAK(I) = REA(1)                                           
 1420     CONTINUE                                                      
        ENDIF                                                          
*-                                                                      
      ELSEIF (IC1 .EQ. 'BH') THEN                                      
* ... BOUNDARY HEAD CARD                                     (BH CARD)
        NWD = 200                                                       
        DO 1430 I = 1,NWD                                              
          INT(I) = 0                                                    
          REA(I) = 0.0                                                  
 1430   CONTINUE                                                        
        DO 1440 I = 1,NWD
          NWD1 = 1
          CALL CRACK (I1,NWD1,REA,INT(I),CHAR,'INTEGER  ',IERC)
          IF (NWD1 .LT. 1) GO TO 1450
          CALL CRACK (I1,NWD1,REA(I),INT,CHAR,'REAL     ',IERC)
          ICOUNT = I
 1440   CONTINUE
 1450   CONTINUE
        NWD = ICOUNT
        IF (IECHO .GT. 0) PRINT 960,IC1,IC3,(INT(I),REA(I),I = 1,NWD)
        DO 1460 I = 1,NWD                                              
           J = INT(I)                                                   
           IF (J .LT. 1 .OR. J .GT. MND) THEN                           
             IF (IECHO .LT. 1) PRINT 960,IC1,IC3,(INT(II),          
     &                         REA(II),II = 1,NWD)                    
             PRINT 670                                                  
             IERR = IERR+1
           ELSE                                                         
             IF (IC3 .EQ. 'N') THEN                                     
* ...                                          (BHN CARD)
                CALL REVHYD (IC1,IC3,J,INDEX,IFOUND)
                IF (IRVIZ .GT. 0 .AND. IFOUND .EQ. 0) GO TO 1835
                NFIX(J) = NFIX(J)/1000*1000+200
                SPEC(J,3) = REA(I)*ZSCALE
             ELSEIF (IC3 .EQ. 'L') THEN
* ...                                          (BHL CARD)
                CALL REVHYD (IC1,IC3,J,INDEX,IFOUND)
                IF (IRVIZ .GT. 0 .AND. IFOUND .EQ. 0) GO TO 1835
* ... IHGEN/INDEX IS DEFINED IN REVHYD
                JCH(INDEX) = J
                HFX(INDEX) = REA(I)*ZSCALE
             ENDIF                                                     
          ENDIF                                                        
 1460   CONTINUE
        IF (IC3 .EQ. ' ') THEN
* ... INITIALIZE ENTIRE SPEC ARRAY                       (BH_ CARD)
          IF (ICYC .GT. NSTIME .OR. IRVIZ .GT. 0) GO TO 1835
          DO 1470 I = J,MND
            NFIX(I) = NFIX(I)/1000*1000+200
            SPEC(I,3) = REA(1)*ZSCALE
 1470     CONTINUE
        ENDIF                                                          
*-
      ELSEIF (IC1 .EQ. 'BQ' .AND. IC3 .EQ. 'L') THEN                   
* ... TOTAL Q ALONG CONTINUITY CHECK LINE                   (BQL CARD)
        NWD = 200                                                       
        DO 1490 I = 1,NWD                                              
          INT(I) = 0                                                    
          REA(I) = 0                                                    
 1490   CONTINUE                                                        
        NWD = NWD/2                                                   
        J1 = 1                                                          
        J2 = 1                                                          
        ICOUNT = 1                                                      
        DO 1500 I = 1,NWD                                              
          NWD1 = 1                                                      
          CALL CRACK (I1,NWD1,REA,INT(J1),CHAR,'INTEGER  ',IERC)
          IF (NWD1 .LT. 1) GO TO 1510
          NWD2 = 2
          CALL CRACK (I1,NWD2,REA(J2),INT,CHAR,'REAL     ',IERC)
          IF (NWD2 .LT. 2) GO TO 1510
          J1 = J1+NWD1
          J2 = J2+NWD2
          ICOUNT = I
 1500   CONTINUE
 1510   CONTINUE
        NWD = ICOUNT
        IF (IECHO .GT. 0) THEN
          PRINT 1520,IC1,IC3,(INT(I),REA(2*I-1),REA(2*I),I = 1,NWD)
 1520     FORMAT (1X,A2,A1,10(4(I6,2G12.5),/))
        ENDIF
        DO 1530 I = 1,NWD
          J = INT(I)
          IF (J .LT. 1 .OR. J .GT. MCC) THEN
            PRINT 1520,IC1,IC3,(INT(II),REA(2*II-1),REA(2*II),
     &            II = 1,NWD)
            PRINT 1570
            IERR = IERR+1
          ELSE
            CALL REVHYD (IC1,IC3,J,INDEX,IFOUND)
            IF (IRVIZ .GT. 0 .AND. IFOUND .EQ. 0) GO TO 1835
* ... IQGEN/INDEX IS DETERMINED IN REVHYD
            JCQ(INDEX)  = J
            QF(INDEX)   = REA(2*I-1)
            QDIR(INDEX) = REA(2*I)
          ENDIF
 1530   CONTINUE
*-
      ELSEIF (IC1 .EQ. 'BR' .AND. IC3 .EQ. 'C') THEN
* ... RATING CURVE DEFINITION                               (BRC CARD)
* ... FOR STAGE-FLOW RELATIONSHIP
        NWD = 200
        DO 1540 I = 1,NWD
          REA(I) = 0.0
          INT(I) = 0
 1540   CONTINUE
        NWD1 = 1
        CALL CRACK (I1,NWD1,REA,INT,CHAR,'INTEGER  ',IERC)
        IF (NWD1 .LT. 1) GO TO 1550
        NWD2 = 5
        CALL CRACK (I1,NWD2,REA,INT,CHAR,'REAL    ',IERC)
 1550   CONTINUE
        IF (IECHO .GT. 0) PRINT 1560,IC1,IC3,INT(1),(REA(JJ),
     &       JJ = 1,5)
 1560   FORMAT (1X,A2,A1,(I6,5G12.5))
        JCON1 = INT(1)
        IF (JCON1 .LT. 1 .OR. JCON1 .GT. MCC) THEN
          PRINT 1560,IC1,IC3,INT(1),(REA(JJ),JJ = 1,5)
          PRINT 1570
 1570     FORMAT (' *** ERROR, OUT OF BOUNDS CONTINUITY CHECK LINE ',
     &            'WAS READ ***')
          IERR = IERR+1
        ELSE
* ...                                                       (BRC)
          CALL REVHYD (IC1,IC3,JCON1,INDEX,IFOUND)
          IF (IRVIZ .GT. 0 .AND. IFOUND .EQ. 0) GO TO 1835
* ... ISTGEN/INDEX IS DETERMINED IN REVHYD
          JCR(INDEX)  = JCON1
          AC1X(INDEX) = REA(1)
          AC2X(INDEX) = REA(2)
          AC3X(INDEX) = REA(3)
          AC4X(INDEX) = REA(4)
          AC5X(INDEX) = REA(5)
        ENDIF
*-
      ELSEIF (IC1 .EQ. 'BR' .AND. IC3 .EQ. 'A') THEN
* ... BOUNDARY REFLECTION-ABSORPTION                        (BRA CARD)
* ... BY CONTINUITY LINE NUMBER
* ... BEST SUITED FOR 1-D BOUNDARY SPEC LOCATIONS
* ... DISCHARGE = A+B(H-SSH)**C (SIMILAR TO RCL)
* ...          B=1 TOTAL REFLECTION, B=0 TOTAL ABSORPTION
* ... TO MAKE THIS WORK ... MUST WAIT UNTIL AFTER STEADY STATE
* ...                       TO FINISH SETTING UP EQUATION
* ...                       'IBR'  FLAG VERY IMPORTANT IN COEF1
        NWD = 200
        DO 1580 I = 1,NWD
          REA(I) = 0.0
          INT(I) = 0
 1580   CONTINUE
        NWD1 = 1
        CALL CRACK (I1,NWD1,REA,INT,CHAR,'INTEGER  ',IERC)
        IF (NWD1 .LT. 1) GO TO 1590
        NWD2 = 5
        CALL CRACK (I1,NWD2,REA,INT,CHAR,'REAL    ',IERC)
 1590   CONTINUE
        IF (IECHO .GT. 0) PRINT 1560,IC1,IC3,INT(1),(REA(JJ),JJ = 1,5)
        ICON = INT(1)
        IF (ICON .LT. 1 .OR. ICON .GT. MCC) THEN
          PRINT 1560,IC1,IC3,INT(1),(REA(JJ),JJ = 1,3)
          PRINT 1570
          IERR = IERR+1
        ELSE
          CALL REVHYD (IC1,IC3,INT(1),INDEX,IFOUND)
          IF (IRVIZ .GT. 0 .AND. IFOUND .EQ. 0) GO TO 1835
* ... ISTGEN/INDEX is determined in REVHYD
          IBR(ICON)   = INDEX
          JCR(INDEX)  = ICON
          AC1X(INDEX) = REA(1)
          BETA        = REA(2)
* ... Variable ELEV is initial water surface elevation read from IC-CARD
          IF (ELEV .GT. 0.0) AC3X(ISTGEN) = ELEV
          IF (REA(3) .GT. 0.0) AC3X(ISTGEN) = REA(3)
          IF (ABS(REA(3)) .LT. 0.001) IBR(ICON) = -IABS(IBR(ICON))
          TAR = REA(5)
* ... Prepare the equation
          IF (LMT(ICON) .GT. 1) THEN
            DXCL = CORD(LINE(ICON,1),1)-CORD(LINE(ICON,LMT(ICON)),1)
            DYCL = CORD(LINE(ICON,1),2)-CORD(LINE(ICON,LMT(ICON)),2)
            W = SQRT(DXCL*DXCL+DYCL*DYCL)
            DO 1595 IC= 1,LMT(ICON)-1
            DXCL = CORD(LINE(ICON,IC),1)-CORD(LINE(ICON,IC+1),1)
            DYCL = CORD(LINE(ICON,IC),2)-CORD(LINE(ICON,IC+1),2)
            WW = SQRT(DXCL*DXCL+DYCL*DYCL)
            WWT = WWT+WW
            BE = BE+WW*(AO(LINE(ICON,IC))+AO(LINE(ICON,IC+1)))/2.0
 1595       CONTINUE
            BE = BE/WWT
            NODE = LINE(ICON,1)
          ELSEIF (LMT(ICON) .EQ. 1) THEN
            NODE = LINE(ICON,1)
            W = WIDTH(NODE)
            BE = AO(NODE)
          ENDIF
          DEEP = AC3X(INDEX)-BE
          IF (W .LE. 0.0 .OR. BE .LE. 0.0 .OR. NODE .LE. 0) THEN
            IERR = IERR+1
            PRINT 1560,IC1,IC3,INT(1),(REA(JJ),JJ = 1,3)
            PRINT 1600,ICON,NODE,W,BE
 1600       FORMAT (' ERROR ON ABOVE CARD: CONTINUITY LINE=',I6,/,
     &              ' HAS AS A 1ST NODE=',I6,' AND THAT NODE ',
     &              ' HAS AN UNDEFINED WIDTH=',F10.2,
     &              ' OR BOTTOM ELEV=',F10.2,/,
     &              ' NEED GC, GNN, AND-OR GWN CARD(S) ',
     &              ' BEFORE BRL CARD')
          ENDIF
*-
* ... variable DEEP is not properly defined unless the user
* ... supplies the true steady state water surface elevation
* ... NOTE:   BETA = 1 all reflected, BETA=0 total absorption
*-
          GRAVTY = 32.2
          CELER = (GRAVTY*DEEP)**0.5
          AC2X(INDEX) = -1.0*((1.0-BETA)/(1.0+BETA))*(CELER*W)
* ... AC3X(INDEX) =  IS OBTAINED 20 LINES UP
          AC4X(INDEX) = 1.0
          AC5X(INDEX) = REA(4)
          TAREA(ICON) = TAR*BETA
        ENDIF
*-
      ELSEIF (IC1 .EQ. 'BS') THEN
* ... BOUNDARY CURRENT SPEED (MAGNITUDE) CARD                (BS CARD)
        NWD = 200
        DO 1610 I = 1,NWD
          INT(I) = 0
          REA(I) = 0.0
 1610   CONTINUE
        DO 1620 I = 1,NWD
          NWD1 = 1
          CALL CRACK (I1,NWD1,REA,INT(I),CHAR,'INTEGER  ',IERC)
          IF (NWD1 .LT. 1) GO TO 1630
          CALL CRACK (I1,NWD1,REA(I),INT,CHAR,'REAL     ',IERC)
          ICOUNT = I
 1620   CONTINUE
 1630   CONTINUE
        NWD = ICOUNT
        IF (IECHO .GT. 0) PRINT 960,IC1,IC3,(INT(I),REA(I),I = 1,NWD)
        DO 1640 I = 1,NWD
          J = INT(I)
          IF (J .LT. 1 .OR. J .GT. MND) THEN
            IF (IECHO .LT. 1) PRINT 960,IC1,IC3,(INT(II),
     &          REA(II),II = 1,NWD)
            PRINT 670
            IERR = IERR+1
          ELSE
            CALL REVHYD (IC1,IC3,J,INDEX,IFOUND)
            IF (IRVIZ .GT. 0 .AND. IFOUND .EQ. 0) GO TO 1835
            NFIX(J) = MOD(NFIX(J),1000)+11000
            SPEC(J,1) = REA(I)*COS(ALFAK(J))
            SPEC(J,2) = REA(I)*SIN(ALFAK(J))
          ENDIF
 1640   CONTINUE
*-
        IF (IC3 .EQ. ' ') THEN
* ... INITIALIZE ENTIRE SPEC  ARRAY                       (BS_ CARD)
          IF (ICYC .GT. NSTIME .OR. IRVIZ .GT. 0) GO TO 1835
          DO 1650 I = J,MND
            NFIX(I) = MOD(NFIX(I),1000)+11000                         
            SPEC(I,1) = REA(1)*COS(ALFAK(I))                          
            SPEC(I,2) = REA(1)*SIN(ALFAK(I))                          
 1650     CONTINUE                                                      
        ENDIF                                                          
*-                                                                      
      ELSEIF (IC1 .EQ. 'BQ' .AND. IC3 .NE. 'L') THEN                   
* ... UNIT DISCHARGE CARD (POINT SOURCE OF FLOW)            (BQ TYPE) 
        NWD = 200                                                       
        DO 1660 I = 1,NWD                                              
          INT(I) = 0                                                    
          REA(I) = 0.0                                                  
 1660   CONTINUE                                                        
        DO 1670 I = 1,NWD
          NWD1 = 1
          CALL CRACK (I1,NWD1,REA,INT(I),CHAR,'INTEGER  ',IERC)
          IF (NWD1 .LT. 1) GO TO 1680
          CALL CRACK (I1,NWD1,REA(I),INT,CHAR,'REAL     ',IERC)
          ICOUNT = I
 1670   CONTINUE
 1680   CONTINUE
        NWD = ICOUNT
        IF (IECHO .GT. 0) PRINT 960,IC1,IC3,(INT(I),REA(I),I = 1,NWD)
        DO 1690 I = 1,NWD                                              
          J = INT(I)                                                    
          IF (J .LT. 1 .OR. J .GT. MND) THEN                            
            IF (IECHO .LT. 1) PRINT 960,IC1,IC3,(INT(II),           
     &           REA(II),II = 1,NWD)                                  
            PRINT 670                                                   
            IERR = IERR+1                                             
          ELSE                                                          
            IF (IC3 .EQ. 'N') THEN                                      
* ...                                            (BQN CARD)
              CALL REVHYD (IC1,IC3,J,INDEX,IFOUND)
              IF (IRVIZ .GT. 0 .AND. IFOUND .EQ. 0) GO TO 1835
              NFIX(J) = MOD(NFIX(J),1000)+31000                       
              SPEC(J,1) = REA(I)*COS(ALFAK(J))                        
              SPEC(J,2) = REA(I)*SIN(ALFAK(J))                        
            ELSEIF (IC3 .EQ. 'E') THEN                                 
* ...                                           (BQE CARD)
              CALL REVHYD (IC1,IC3,ICON,INDEX,IFOUND)
              IF (IRVIZ .GT. 0 .AND. IFOUND .EQ. 0) GO TO 1835
* ... NSID IS DETERMINED IN REVHYD                              
              JBQE(INDEX) = J                                           
              SIDF(J) = REA(I)                                          
            ENDIF                                                      
          ENDIF                                                        
 1690   CONTINUE                                                        
        IF (IC3 .EQ. ' ') THEN                                          
* ... INITIALIZE ENTIRE SPEC  ARRAY                       (BQ_ CARD)
          IF (ICYC .GT. NSTIME .OR. IRVIZ .GT. 0) GO TO 1835
          DO 1700 I = J,MND                                            
            NFIX(I) = MOD(NFIX(I),1000)+11000                         
            SPEC(I,1) = REA(1)*COS(ALFAK(I))                          
            SPEC(I,2) = REA(1)*SIN(ALFAK(I))                          
 1700     CONTINUE                                                      
        ENDIF                                                          
*-
      ELSEIF (IC1 .EQ. 'BW') THEN                                      
* ... WIND CARD                                              (BW TYPE)
        NWD = 4                                                         
        DO 1710 I = 1,NWD                                              
          INT(I) = 0                                                    
          REA(I) = 0                                                    
 1710   CONTINUE                                                        
        IF (IC3 .EQ. 'C') THEN                                          
* ... WIND COEFICIENTS FOR GIVEN FORMULATION TYPE         (BWC CARD)
          NWD1 = 2                                                      
          CALL CRACK (I1,NWD1,REA,INT,CHAR,'INTEGER  ',IERC)
          NWD2 = 4                                                      
          CALL CRACK (I1,NWD2,REA,INT,CHAR,'REAL     ',IERC)
          IF (IECHO .GT. 0.0) PRINT 1720,IC1,IC3,INT(1),             
     &         INT(2),(REA(I),I = 1,4)                               
 1720     FORMAT (1X,A2,A1,2I6,4G12.6)                              
          IF (ABS(INT(1)) .GT. 8) THEN                                  
            PRINT 1730,INT(1)                                          
 1730       FORMAT (' *** VARIABLE IWIND ON ABOVE CARD IS ILLEGAL ***') 
            IERR = IERR+1                                             
          ENDIF                                                        
          IWIND = INT(1)                                                
          IWMX  = INT(2)                                                
          WC1X  = REA(1)                                                
          WC2X  = REA(2)                                                
          WC3X  = REA(3)                                                
          WC4X  = REA(4)                                                
        ENDIF                                                          
*-                                                                      
        IF (IC3 .EQ. 'E') THEN
*-
* ... WIND SPEED/DIR BY ELEMENT NUMBER THEN ASSIGN                  
* ... CORNER NODE WITH COEFFICIENTS                       (BWE CARD)
*-
          NWD1 = 1
          CALL CRACK (I1,NWD1,REA,INT,CHAR,'INTEGER  ',IERC)
          NWD2 = 2
          CALL CRACK (I1,NWD2,REA,INT,CHAR,'REAL     ',IERC)
          IF (IECHO .GT. 0) PRINT 480,IC1,IC3,INT(1),(REA(K),K = 1,2)
          IELEM = INT(1)                                                
          IF (NE .LT. 1) THEN                                           
            IERR = IERR+1                                             
            PRINT *,' GEOMETRY WAS NOT DEFINED PRIOR TO BWE CARD'      
          ENDIF                                                        
          DO 1740 J = 1,8,2                                           
            NODE = NOP(IELEM,J)                                         
            IF (NODE .EQ. 0) GO TO 1740                                 
            IF (NODE .LE. 0 .OR. NODE .GT. MND) THEN                    
              IERR = IERR+1                                           
              PRINT 400,IC3,IC1,INT(1),(REA(K),K = 1,2)           
            ELSE                                                        
              TWX(NODE) = REA(1)                                        
              TAX(NODE) = REA(2)                                        
            ENDIF
 1740     CONTINUE
          NMAT = IMAT(IELEM)
          IF (IECHO .GT. 0) PRINT 1750,IELEM,NMAT,(REA(KK),KK = 1,2)
 1750     FORMAT (' ELEMENT=',I6,' HAS IMAT=',I6,' ASSIGNED '       
     &        ,'-BWE- WIND SPEED/DIR =',2F10.4)                      
        ENDIF                                                          
*-                                                                      
        IF (IC3 .EQ. 'T') THEN                                          
* ... WIND SPEED & DIR BY ELEMENT TYPE THEN ASSIGN                  
* ... CORNER NODE WITH COEFFICIENTS                      (BWT CARD)
          NWD1 = 1
          CALL CRACK (I1,NWD1,REA,INT,CHAR,'INTEGER  ',IERC)
          NWD2 = 2
          CALL CRACK (I1,NWD2,REA,INT,CHAR,'REAL     ',IERC)
          IF (IECHO .GT. 0) PRINT 480,IC1,IC3,INT(1),(REA(K),K = 1,2)
          NMAT = INT(1)                                                 
          IF (NE .LT. 1) THEN                                           
            IERR = IERR+1                                             
            PRINT *,' GEOMETRY WAS NOT DEFINED PRIOR TO BWT CARD'      
          ENDIF                                                        
          DO 1780 I = 1,NE                                             
            IF (IMAT(I) .NE. NMAT) GO TO 1780                           
            DO 1760 J = 1,8,2
              NODE = NOP(I,J)                                           
              IF (NODE .EQ. 0) GO TO 1760                               
              IF (NODE .LE. 0 .OR. NODE .GT. MND) THEN                  
                IERR = IERR+1                                         
                PRINT 400,IC3,IC1,INT(1),(REA(K),K = 1,2)         
              ELSE                                                      
                TWX(NODE) = REA(1)                                      
                TAX(NODE) = REA(2)                                      
              ENDIF                                                    
 1760       CONTINUE
            IELEM = I
            IF (IECHO .GT. 0) PRINT 1770,IELEM,NMAT,(REA(KK),KK = 1,2)
 1770       FORMAT (' ELEMENT=',I6,' WITH IMAT=',I6,' ASSIGNED '    
     &          ,'-BWT- WIND SPEED/DIR =',2F10.4)                    
 1780     CONTINUE                                                      
        ENDIF                                                          
*-                                                                      
        IF (IC3 .EQ. 'N') THEN                                          
* ... WIND SPEED/DIRECTION FOR GIVEN NODE ON CARD         (BWN CARD)
          NWD1 = 1                                                      
          CALL CRACK (I1,NWD1,REA,INT,CHAR,'INTEGER  ',IERC)
          NWD2 = 2                                                      
          CALL CRACK(I1,NWD2,REA,INT,CHAR,'REAL     ',IERC)
          IF (IECHO .GT. 0.0) PRINT 1790,IC1,IC3,INT(1),             
     &         (REA(I),I = 1,2)                                       
          NODE = INT(1)                                                 
          IF (NODE .LT. 1 .OR. NODE .GT. MND) THEN                      
            IF (IECHO .LT. 1) PRINT 1790,IC1,IC3,INT(1),            
     &           (REA(I),I = 1,2)                                     
            PRINT 670                                                   
            IERR = IERR+1                                             
          ELSE                                                          
            TWX(NODE) = REA(1)                                          
            TAX(NODE) = REA(2)                                          
          ENDIF                                                        
        ENDIF                                                          
*-
        IF (IC3 .EQ. ' ') THEN
*-
* ... WIND SPEED/DIRECTION                                          
* ... ALL NODES GREATER THAN NODE ON CARD                 (BW_ CARD)
*-
          NWD1 = 1                                                      
          CALL CRACK (I1,NWD1,REA,INT,CHAR,'INTEGER  ',IERC)
          NWD2 = 2                                                      
          CALL CRACK (I1,NWD2,REA,INT,CHAR,'REAL     ',IERC)
          IF (IECHO .GT. 0.0) PRINT 1790,IC1,IC3,INT(1),             
     &         (REA(I),I = 1,2)                                       
 1790     FORMAT (1X,A2,A1,I6,4G12.6)
          NODE = INT(1)                                                 
          DO 1800 I = NODE,MND                                         
            TWX(I) = REA(1)                                             
            TAX(I) = REA(2)                                             
 1800     CONTINUE                                                      
        ENDIF                                                          
        IF (IC3 .EQ. 'S') THEN                                          
* ... BOUNDARY WIND STORM EVENT CALCULATED                (BWS CARD)
          NWD1 = 2                                                      
          CALL CRACK (I1,NWD1,REA,INT,CHAR,'INTEGER  ',IERC)
          NWD2 = 9                                                      
          CALL CRACK (I1,NWD2,REA,INT,CHAR,'REAL     ',IERC)
          IF (IECHO .GT. 0.0) PRINT 1810,IC1,IC3,INT(1),             
     &         INT(2),(REA(I),I = 1,9)                               
 1810     FORMAT (1X,A2,A1,2I6,9F12.1)                              
          CALL REVHYD (IC1,IC3,INT(1),INDEX,IFOUND)
          IF (IRVIZ .GT. 0 .AND. IFOUND .EQ. 0) GO TO 1835
* ... NSTORM IS DETERMINED IN REVHYD
          IF (NSTORM .GT. MXSTRM) THEN                                  
            PRINT *,' STORM ARRAY OVER-RUN'                            
            IERR = IERR+1                                             
          ELSE                                                          
            ISTYPE(INDEX)   = INT(1)                                    
            NREF(INDEX)     = INT(2)                                    
            TREF(INDEX)     = REA(1)                                    
            SSPD(INDEX)     = REA(2)                                    
            WNDMAX(INDEX)   = REA(3)                                    
            WNDMIN          = REA(4)                                    
            THETAS(INDEX)   = REA(5)                                    
            THETAK(INDEX)   = REA(6)                                    
            BETAL(INDEX)    = REA(7)                                    
            BETAT(INDEX)    = REA(8)                                    
            DECAY(INDEX)    = REA(9)                                
          ENDIF                                                        
        ENDIF                                                          
*-                                                                      
      ELSEIF (IC1 .EQ. 'EN' .AND. IC3 .EQ. 'D') THEN                   
* ... END CARD USED TO SEPERATE TIME STEPS                  (END CARD)
        IF (IECHO .GT. 0) PRINT 1820,IC1,IC3,                       
     &                     (JREC(I),I=1,80)                             
*        PRINT 1815                                                      
 1815   FORMAT (/)
        IRVOLD = IRVIZ                                                  
        IRVIZ = 0                                                       
        IREAD = 1                                                       
        KBCTS = KBCTS+1                                               
*        PRINT *,'=+=  KOUNT # OF END-CARDS MARKING END OF TS = ',KBCTS
        IBCSET = 1                                                      
        IF (KBCTS .LT. NSTART) GO TO 250                              
        GO TO 1860                                                      
*-                                                                      
      ELSEIF (IC1 .EQ. 'RE' .AND. IC3 .EQ. 'V') THEN                   
* ... REVISION OF PARAMETERS IN MID-TIME STEP REQUESTED     (REV CARD)
        IF (IECHO .GT. 0) PRINT 1820,IC1,IC3,                       
     &                     (JREC(I),I=1,80)                             
*        PRINT 1815                                                      
        IBCSET = 1                                                      
        IF (KBCTS .LE. (NSTART-1)) GO TO 250
        IRVOLD = IRVIZ                                                  
        IRVIZ = IRVIZ+1                                               
        PRINT *,' REVISION CARD NUMBER=',IRVIZ,' HAS BEEN READ'         
        IREAD = 1                                                       
        GO TO 1860
*-
      ELSEIF (IC1 .EQ. 'ST' .AND. IC3 .EQ. 'O') THEN                   
* ... END CARD USED TO SEPERATE TIME STEPS                 (STOP CARD)
        IF (IECHO .GT. 0) PRINT 1820,IC1,IC3,                       
     &                     (JREC(I),I=1,80)                             
        IF (IBATCH .EQ. 0) CALL BEEP (5)
        STOP 'CARD'
*-
      ELSEIF (IC1 .EQ. 'CO') THEN
* ... COMMENT CARD                                      (COMMENT CARD)
        IF (IECHO .GT. 0) PRINT 1820,IC1,IC3,(JREC(I),I = 1,80)
      ELSE
* ... BAD CARD                                          (ILLEGAL CARD)
        PRINT 1820,IC1,IC3,(JREC(I),I = 1,80)                      
 1820   FORMAT (1X,A2,A1,80A1)                                       
        PRINT 1830                                                      
 1830   FORMAT (' *** ERROR, ILLEGAL CARD TYPE ***')                    
        IERR = IERR+1
      ENDIF
* ... READ ANOTHER CARD
      GO TO 250
*-
 1835 PRINT 1836,IC1,IC3,(JREC(I),I=1,80)
 1836 FORMAT (' *** PERMISSION DENIED TO REVISE THE FOLLOWING CARD ***',
     &    /,1X,A2,A1,80A1)
      GO TO 250
*-
 1840 CONTINUE
      INHEC = IBUP
      IBIN = IBUP
      PRINT 1850,INHEC                                                 
 1850 FORMAT (' *** PREPARE TO READ FROM UNIT ',I6,' ***')            
      IF (IBUP .EQ. 0) THEN                                             
           PRINT *,' ========> Logical Unit # is zero ===> STOP'        
           PRINT *,' ===> Attempt to read non-defined alt-bc file'      
           IF (IBATCH .EQ. 0) THEN                                        
               CALL BEEP (10)                                           
*              PAUSE                                                
           ENDIF                                                        
           STOP 'BAD-LU'                                                
      ENDIF                                                             
 1860 CONTINUE                                                          
*-                                                                      
*     CHECK FOR DYNAMIC DATA
*-
      IF (IDYN .GT. 0) GO TO 1970                                       
*-
      IF (IDNOPT .GE. 1) THEN
          IF (IDNOPT .GT. NP) IDNOPT = NP
          PRINT *,' PREPARE FOR S.S. PROCESS ... IDNOPT = ',IDNOPT    
      ENDIF
 1870 FORMAT (' *** CARD INPUT COMPLETE WITH ',I6,' ERRORS ***')
      IF (IERR .GT. 0) THEN
          IF (IBATCH .EQ. 0) CALL BEEP (10)                               
          STOP 'ERROR'                                                  
      ENDIF                                                             
*-
* ... DO WE NEED TO GO TO IBUP FOR STEADY STATE EXTRA DATA??
      IF (INBX .GT. -1 .AND. INBX .LT. NBX) THEN
* ... CHECK FOR CODE 24 TYPE FILE                              
        ENDFLG = 0                                                      
 1880   CONTINUE                                                        
        PRINT 1890,INHEC                                               
 1890   FORMAT (' PREHYD IS LOOKING FOR EXTRA S.S. BC DATA ON UNIT=',I5)
        IF (INHEC .LE. 0) THEN                                          
          PRINT 1900,INHEC                                             
 1900     FORMAT (' STOP BECAUSE VARIABLE NBX ON G1-CARD INDICATES ',  
     &            ' THAT MORE BOUNDARY CONDITION DATA IS NEEDED.',/,   
     &            ' TRIED TO READ FROM AN INVALID LOGICAL UNIT NUMBER=',
     &            I3,/)
        STOP
        ENDIF
        IC2 = '?'
        READ (INHEC,1930,END = 1910) IC2
        GO TO 1920
 1910   CONTINUE
        ENDFLG = ENDFLG+1
        INHEC = IBUP
        IBIN = IBUP
        IF (ENDFLG .GE. 3) GO TO 2040
        GO TO 1880
 1920   CONTINUE
 1930   FORMAT (A1)
        BACKSPACE INHEC
*-
        CALL LETTER (IC2,ISTYLE)
*-
* ... WE HAVE A HEC BOUNDARY CARD WHEN ISTYLE IS POSITIVE
        IF (ISTYLE .GE. 1) GO TO 250
*-
* ... CODE-24 TYPE READ (IAN KING'S TRADITIONAL DYNAMIC UPDATE
* ... COME HERE IF STEADY STATE IS LACKING TOTAL
*-
        IC24 = 1
        ILEFT = NBX-INBX
        IF (IDEN .GT. 0) THEN
* ... VARIABLE DENSITY
            READ (INHEC,1940) (L,DEN(L),N = 1,IDEN)                  
 1940       FORMAT (I10,E10.0)                                         
        ENDIF                                                          
        IF (ILEFT .GT. 0) THEN                                          
* ... BOUNDARY SPECS                                                
          DO 1960 I = 1,ILEFT                                          
             READ (INHEC,1950) J,NFIX(J),(SPEC(J,K),K = 1,3)        
 1950        FORMAT (2I10,3F10.0)
 1960     CONTINUE                                                      
          IDYN = 1                                                      
        ENDIF                                                          
      ENDIF                                                            
*-
      IF (KBCTS .LT. NSTART) GO TO 250
      CALL INPUTP (NCTRL)                                               
      RETURN                                                            
*-                                                                      
 1970 CONTINUE                                                          
      IDYN = 1
*-                                                                      
*     DYNAMIC INPUT SECTION (FIRST DETERMINE WHAT FORMAT FOR BC'S ?)    
*-                                                                      
      IF (IC24 .LE. -1) THEN                                            
*       CHECK TO SEE WHAT FORMAT DYNAMIC BC FILE IS IN                  
        ENDFLG = 0
 1980   CONTINUE
        IC1 = '?'
        READ (INHEC,260,ERR=2000,END=2000) IC1,IC3,(JREC(I),I=1,80)    
        GO TO 2010                                                      
 2000   CONTINUE                                                        
        ENDFLG = ENDFLG+1                                             
        INHEC = IBUP                                                    
        IBIN  = IBUP                                                    
        IF (ENDFLG .GE. 3) GO TO 2040
        GO TO 1980                                                      
 2010   CONTINUE                                                        
        BACKSPACE INHEC                                                 
*-
* ... WHAT'S THE FORMAT OF DYNAMIC FILE, ISTYLE POSITIVE MEANS HEC
*-
        IC2 = IC1                                                       
        CALL LETTER (IC2,ISTYLE)
*-                                                                      
        IF (ISTYLE .EQ. 1) THEN
             IC24 = 0
        ELSE
             IC24 = 1
        ENDIF
      ENDIF
*-
      IF (IREAD .EQ. 0) GO TO 250                                   
      CALL INPUTP (NCTRL)
*-
      RETURN
*-
 2040 ENDFLG = ENDFLG+1
      PRINT 2050,INHEC,ENDFLG
 2050 FORMAT (' UNEXPECTED END OF FILE ON MANDATORY HYDRO2 INPUT ',
     &        /,' CONTROL FILE, UNIT= ',I5,/,
     &        ' PROGRAM STOPS AFTER ',I5,' ATTEMPTS')
      IF (IBATCH .EQ. 0) CALL BEEP (10)
      STOP 'E-O-F'
      END
*-
      SUBROUTINE REVHYD (IC1,IC3,ICON,INDEX,IFOUND)
*-
      SAVE
*-
* ... REVISED INPUT CHECKER FOR HYDRO2 BOUNDARY CONDITIONS
*-
* ..  PURPOSE: TO RE-SET ANY BOUNDARY CONDITION COUNTERS
*-
* ... IC1 AND IC3 DEFINE THE TYPE OF CARD
* ... ICON - IS THE CONTINUITY LINE OR NODE ON THE CARD
* ... INDEX - COUNTER FOR THAT TYPE BOUNDARY CONDITION
* ... IFOUND - IF 1 THEN THE NODE WAS PREVIOUSLY ASSIGNED               
*-
      INCLUDE 'hsctm.inc'
*-
      CHARACTER IC1*2,IC3*1
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED REVHYD ... CARD=',IC1,IC3
      IF (ITRACE .GE. 1) PRINT *,'     KBCTS=',KBCTS,'  NSTART=',NSTART
*-
      IFOUND = 0                                                        
      IF (IC1(1:1) .NE. 'B') RETURN
*-
      IF (IC1 .EQ. 'BH' .AND. IC3 .EQ. ' ') THEN                              
* ... CHECK TO SEE IF THIS NODE WAS PREVIOUSLY A HEAD SPEC         
           IF (SPEC(ICON,3) .EQ. 200) IFOUND = 1                         
           IF (SPEC(ICON,3) .EQ. 1200) IFOUND = 1                         
           INDEX = 0                                                    
           RETURN                                                       
      ENDIF                                                             
      IF (IC1 .EQ. 'BH'.AND.IC3 .EQ. 'L') THEN                              
          IF (IBCSET .EQ. 0) THEN                                       
               IHGEN = IHGEN+1                                        
*               PRINT *,' -------> INCREMENT IHGEN=',IHGEN
               INDEX = IHGEN                                            
               RETURN                                                   
          ENDIF                                                         
* ... DETERMINE IF THIS CONTINUITY LINE HAS PREVIOUSLY BEEN BHL     
          IF (IHGEN .EQ. 0) GO TO 110                                    
          DO 100 I= 1,IHGEN                                            
             IAM = I                                                    
             IF (JCH(IAM) .EQ. ICON) GO TO 130                           
  100     CONTINUE                                                      
* ... ILLEGAL REVISION                                              
  110     IFOUND = 0                                                    
          PRINT 120,IC1,IC3                                            
  120     FORMAT(' *** THIS CONTINUITY LINE WAS NOT PREVIOUSLY',       
     &    ' ASSIGNED AS A ',A2,A1,' CARD ... HENCE ILLEGAL')            
          PRINT *,'  HYDRO2 STOPS in Subroutine REVHYD ... Fatal Error'  
          IF (IBATCH .EQ. 0) CALL BEEP (10)                               
          STOP 'BC-ERR'                                                 
* ... VALID REVISION                                                
  130     IFOUND = 1                                                    
          INDEX = IAM                                                   
          RETURN                                                        
       ENDIF                                                            
*-                                                                      
       IF (IC1 .EQ. 'BQ'.AND.IC3 .EQ. 'N') THEN                              
          IF (NFIX(ICON) .EQ. 11000) IFOUND = 1                         
          IF (NFIX(ICON) .EQ. 31000) IFOUND = 1                         
          INDEX = 0                                                     
          RETURN                                                        
       ENDIF                                                            
       IF (IC1 .EQ. 'BQ'.AND.IC3 .EQ. 'L') THEN                             
           IF (IBCSET .EQ. 0) THEN                                       
               IQGEN = IQGEN+1                                        
               PRINT *,' -------> INCREMENT IQGEN=',IQGEN               
               INDEX = IQGEN                                            
               RETURN                                                   
           ENDIF                                                        
* ... DETERMINE IF THIS CONTINUITY LINE HAS PREVIOUSLY BEEN BQL    
           IF (IQGEN .EQ. 0) GO TO 210                                   
           DO 200 I= 1,IQGEN                                           
             IAM = I                                                    
             IF (JCQ(IAM) .EQ. ICON) GO TO 230                           
  200      CONTINUE                                                     
* ... ILLEGAL REVISION                                             
  210      IFOUND = 0                                                   
           PRINT 220,IC1,IC3                                           
  220      FORMAT(' *** THIS CONTINUITY LINE WAS NOT PREVIOUSLY',      
     &     ' ASSIGNED AS A ',A2,A1,' CARD ... HENCE ILLEGAL')           
           PRINT *,'  HYDRO2 STOPS in Routine REVHYD ... Fatal Error'    
           IF (IBATCH .EQ. 0) CALL BEEP (10)                              
           STOP 'BC-ERR'                                                
* ... VALID REVISION                                               
  230      IFOUND = 1                                                   
           INDEX = IAM                                                  
           RETURN                                                       
       ENDIF                                                            
*-                                                                      
       IF (IC1 .EQ. 'BQ'.AND.IC3 .EQ. 'E') THEN                             
           IF (IBCSET .EQ. 0) THEN                                       
               NSID = NSID+1                                          
               PRINT *,' -------> INCREMENT NSID=',NSID                 
               INDEX = NSID                                             
               RETURN                                                   
           ENDIF                                                        
* ... DETERMINE IF THIS ELEMENT SIDE HAS PREVIOUSLY BEEN BQE       
           IF (NSID .EQ. 0) GO TO 310                                    
           DO 300 I= 1,NSID                                            
             IAM = I                                                    
             IF (JBQE(IAM) .EQ. ICON) GO TO 330                          
  300      CONTINUE                                                     
* ... ILLEGAL REVISION                                             
  310      IFOUND = 0                                                   
           PRINT 320,IC1,IC3                                           
  320      FORMAT(' *** THIS ELEMENT SIDE WAS NOT PREVIOUSLY',         
     &     ' ASSIGNED AS A ',A2,A1,' CARD ... HENCE ILLEGAL')           
           PRINT *,' HYDRO2 STOPS in Routine REVHYD ... Fatal Error'
           IF (IBATCH .EQ. 0) CALL BEEP (10)                              
           STOP 'BC-ERR'                                                
* ... VALID REVISION                                               
  330      IFOUND = 1                                                   
           INDEX = IAM                                                  
           RETURN                                                       
       ENDIF                                                            
*-                                                                      
       IF (IC1 .EQ. 'BR') THEN                                            
           IF (IBCSET .EQ. 0) THEN                                       
               ISTGEN = ISTGEN+1                                      
               PRINT *,' -------> INCREMENT ISTGEN=',ISTGEN             
               INDEX = ISTGEN                                           
               RETURN                                                   
           ENDIF                                                        
* ... DETERMINE IF THIS CONTINUITY LINE HAS PREVIOUSLY BEEN BR?    
           IF (ISTGEN .EQ. 0) GO TO 410                                  
           DO 400 I= 1,ISTGEN                                          
             IAM = I                                                    
             IF (JCR(IAM) .EQ. ICON) GO TO 430                           
  400      CONTINUE                                                     
* ... ILLEGAL REVISION                                             
  410      IFOUND = 0                                                   
           PRINT 420,IC1,IC3                                           
  420      FORMAT(' *** THIS CONTINUITY LINE WAS NOT PREVIOUSLY',      
     &     ' ASSIGNED AS A ',A2,A1,' CARD ... HENCE ILLEGAL')           
            PRINT *,' HYDRO2 STOPS in Routine REVHYD ... Fatal Error'
            IF (IBATCH .EQ. 0) CALL BEEP (10)                             
            STOP 'BC-ERR'                                               
* ... VALID REVISION                                               
  430      IFOUND = 1                                                   
           INDEX = IAM                                                  
           RETURN                                                       
       ENDIF                                                            
*-                                                                      
       IF (IC1 .EQ. 'BS') THEN                                             
          IF (NFIX(ICON) .EQ. 11000) IFOUND = 1                         
          IF (NFIX(ICON) .EQ. 31000) IFOUND = 1                         
          INDEX = 0                                                     
          RETURN                                                        
       ENDIF                                                            
*-                                                                      
       IF (IC1 .EQ. 'BW' .AND. IC3 .EQ. 'S') THEN                            
* ... DETERMINE IF THIS STORM HAS BEEN PREVIOUSLY DETERMINED VIA BWS
           IF (NSTORM .EQ. 0) GO TO 510                                  
           DO 500 I= 1,NSTORM                                          
             IAM = I                                                    
             IF (ISTYPE(IAM) .EQ. ICON) GO TO 530                        
  500      CONTINUE                                                     
* ... ILLEGAL REVISION                                             
  510      IFOUND = 0                                                   
           PRINT 520,IC1,IC3                                           
  520      FORMAT(' *** THIS STORM NUMBER WAS NOT PREVIOUSLY',         
     &     ' ASSIGNED AS A ',A2,A1,' CARD ... HENCE ILLEGAL')           
           PRINT *,' HYDRO2 STOPS in Routine REVHYD ... Fatal Error'     
           IF (IBATCH .EQ. 0) CALL BEEP (10)
           STOP 'BC-ERR'                                                
* ... VALID REVISION                                               
  530      IFOUND = 1                                                   
           INDEX = IAM                                                  
           RETURN                                                       
       ENDIF                                                            
       RETURN                                                           
       END
*-
      SUBROUTINE QGEN (J,QREQ,THET)
*-
      SAVE
*-
* ... Generate specified total flow boundary conditions
*-
      INCLUDE 'hsctm.inc'                                              
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED QGEN (J,QREQ,THET=',
     &                                 J,QREQ,THET,')  IRVIZ=',IRVIZ
*-
* ... Calculate total projected area
*-
      MAX=LMT(J)                                                        
      STQT(J)=THET                                                      
      IF (MAX .EQ. 1) THEN                                               
*-                                                                      
* ... This is for 1-D element                                         
*-                                                                      
        K=0                                                             
        DO 120 M=1,NE                                                   
          K=K+1                                                         
          IF (NOP(K,3) .EQ. LINE(J,1)) GO TO 125                         
          IF (NOP(K,1) .EQ. LINE(J,1)) GO TO 126                         
  120   CONTINUE                                                        
  125   NA=NOP(K,3)                                                     
        NCQ=NOP(K,1)                                                   
        GO TO 127                                                       
  126   NA=NOP(K,1)                                                     
        NCQ=NOP(K,3)                                               
  127   NM=NOP(K,2)                                                     
        DX=2.0*(CORD(NM,1)-CORD(NA,1))-0.5*(CORD(NCQ,1)-CORD(NA,1))   
        DY=2.0*(CORD(NM,2)-CORD(NA,2))-0.5*(CORD(NCQ,2)-CORD(NA,2))   
        BEETA=ATAN2(DY,DX)                                              
        IF (ABS(BEETA-THET) .GT. 1.570798 .AND.                        
     &     ABS(BEETA-THET) .LT. 4.712394) BEETA=BEETA+3.141596          
        SPEC(NA,1)=QREQ*COS(BEETA)                                      
        SPEC(NA,2)=QREQ*SIN(BEETA)                                      
        NFIX(NA)=31000
*-
* ... THIS IS FOR 2-D ELEMENTS
*-
      ELSE                                                              
      SUMA=0.0
      MAX = LMT(J)-2                                                    
      DO 150 K = 1,MAX,2                                              
         NA = LINE(J,K)                                                    
         NCQ = LINE(J,K+2)                                               
         DX=CORD(NCQ,1)-CORD(NA,1)                                      
         DY= -(CORD(NCQ,2)-CORD(NA,2))                                  
         XL=SQRT(DX**2+DY**2)                                              
         ALP=ATAN2(DX,DY)                                                  
         D1=VEL(3,NA)                                                      
         D3=VEL(3,NCQ)                                               
         D2=(D1+D3)/2.0
         SUMA = SUMA+XL*COS(ALP-THET)*D2                                   
  150 CONTINUE
*-                                                                      
* ... Compute velocity required                                       
*-                                                                      
      SUMA=ABS(SUMA)                                                    
      VEST=QREQ/SUMA                                                    
*-                                                                      
* ... Insert values into SPEC  and  NFIX arrays                       
*-                                                                      
      MAX=MAX+2                                                         
      DO 300 K=1,MAX                                                    
        NA=LINE(J,K)                                                    
        D1=VEL(3,NA)                                                    
        SPEC(NA,1)=VEST*D1*COS(THET)                                    
        SPEC(NA,2)=VEST*D1*SIN(THET)                                    
        IF (SPEC(NA,1) .NE. 0.0) THEN                                     
          NFIX(NA)=31000                                                
        ELSE                                                            
          NFIX(NA)=13000                                                
        ENDIF                                                           
  300 CONTINUE                                                          
*-                                                                      
* ... Find correct components for boundary nodes                      
*-                                                                      
      DO 400 K=1,MAX,MAX-1                                              
        NA=LINE(J,K)                                                    
*-                                                                      
* ... Locate element with this node                                   
*-                                                                      
        DO 340 N=1,NE                                                   
          IF (IMAT(N) .EQ. 0) GO TO 340                                  
          NCN=NCORN(N)                                                  
          DO 310 MM=1,NCN                                               
            M=MM                                                        
            IF (IABS(NOP(N,M)) .EQ. NA) GO TO 315                        
  310     CONTINUE                                                      
          GO TO 340                                                     
*-
* ... Found a match node. Now determine side for parallel flow
*-
  315     IF (K .EQ. 1) THEN                                             
            KK=2                                                        
          ELSE                                                          
            KK=MAX-1                                                    
          ENDIF                                                         
          MLW=M-1                                                       
          IF (MM .EQ. 1) THEN                                            
            MLW=NCN                                                     
          ELSE                                                          
            MLW=M-1                                                     
          ENDIF                                                         
          MSL=MOD(MLW+2,NCN)                                          
          IF (MSL .EQ. 0) MSL=NCN                                      
          MFR=MOD(MLW+3,NCN)                                          
          MSL=IABS(NOP(N,MSL))                                        
          IF (MSL .EQ. LINE(J,KK)) GO TO 317                           
          IF (IBN(MSL) .EQ. 1) GO TO 330
  317       CONTINUE                                                    
            MLW=MOD(M+1,NCN)                                            
            IF (MLW .EQ. 0) MLW=NCN                                      
            IF (MLW .GT. 2) THEN                                       
               MSL=MLW-2                                               
               MFR=MLW-3                                               
            ELSE                                                      
               MSL=NCN                                                 
               MFR=NCN-1                                               
            ENDIF                                                     
            MSL=IABS(NOP(N,MSL))                                      
            IF (MSL .EQ. LINE(J,KK)) GO TO 340                         
            IF (IBN(MSL) .EQ. 1) GO TO 330                             
          GO TO 340                                                     
  330     CONTINUE                                                      
          MFR=IABS(NOP(N,MFR))                                          
*-                                                                      
* ... Now compute boundary angle                                      
*-                                                                      
          DX=2.0*(CORD(MSL,1)-CORD(NA,1))-0.5*(CORD(MFR,1)-CORD(NA,1))   
          DY=2.0*(CORD(MSL,2)-CORD(NA,2))-0.5*(CORD(MFR,2)-CORD(NA,2))   
          BEETA=ATAN2(DY,DX)                                            
*-                                                                      
* ... Find angle of side that flow crosses                            
*-                                                                      
          IF (K .EQ. 1) THEN                                             
            NAD=LINE(J,3)                                               
          ELSE                                                          
            NAD=LINE(J,MAX-2)                                           
          ENDIF                                                         
          DXA=CORD(NAD,1)-CORD(NA,1)                                    
          DYA= -(CORD(NAD,2)-CORD(NA,2))                                 
          AALFA=ATAN2(DXA,DYA)                                          
          IF (ABS(AALFA-THET) .GT. 1.570796 .AND.                      
     &       ABS(AALFA-THET) .LT. 4.712394) THEN                        
            AALFA=AALFA+3.141596                                        
          ENDIF                                                         
          IF (ABS(AALFA-BEETA) .GT. 1.570796 .AND.                     
     &       ABS(AALFA-BEETA) .LT. 4.712394) THEN                       
            BEETA=BEETA+3.141596
          ENDIF
*-
* ... Finally adjust flows
*-
          IF (COS(THET) .NE. 0.0) THEN
            QMAG=SPEC(NA,1)*COS(AALFA-THET)/(COS(THET)*COS(AALFA-BEETA))
          ELSE
            QMAG=SPEC(NA,2)*COS(AALFA-THET)/(SIN(THET)*COS(AALFA-BEETA))
          ENDIF
          SPEC(NA,1)=QMAG*COS(BEETA)
          SPEC(NA,2)=QMAG*SIN(BEETA)
          GO TO 400
  340   CONTINUE
  400 CONTINUE
      ENDIF
      IF (ICYC .GT. 0 .OR. IRVOLD .GE. 1) THEN
         DO 500 K=1,MAX
            NA=LINE(J,K)
            CALL BFORM (NA)
  500    CONTINUE
      ENDIF
      RETURN
      END
*-
      SUBROUTINE REPLY (ANAM,ISWT)
*-
      SAVE
*-
      CHARACTER*32 ANAM
      ISWT=0
      IF (ANAM .EQ. '?') GO TO 200
      IF (ANAM .EQ. ' ?') GO TO 200
*-
      IF (ANAM .EQ. 'N') GO TO 100
      IF (ANAM .EQ. 'n') GO TO 100
      IF (ANAM .EQ. 'NO') GO TO 100
      IF (ANAM .EQ. 'no') GO TO 100
      IF (ANAM .EQ. 'NONE') GO TO 100
      IF (ANAM .EQ. 'none') GO TO 100
      IF (ANAM .EQ. 'NULL') GO TO 100
      IF (ANAM .EQ. 'null') GO TO 100
*-
      IF (ANAM(1:1) .EQ. 'Q') GO TO 110
      IF (ANAM(1:1) .EQ. 'q') GO TO 110
      IF (ANAM .EQ. 'QUIT') GO TO 110
      IF (ANAM .EQ. 'quit') GO TO 110
      IF (ANAM .EQ. 'STOP') GO TO 110
      IF (ANAM .EQ. 'stop') GO TO 110
      RETURN
*-
* ... User does not want this file saved
*-
  100 ISWT=1
      RETURN
* ... User wants to quit the program
  110 ISWT=2
*      CALL BEEP (5)
      STOP 'REPLY'
* ... Need a menu
  200 ISWT=3
      WRITE (*,210)
  210 FORMAT (/,' How to Respond',/,
     &          ' Enter -->filename   to save as requested',/,
     &          ' Enter -->null       if not saving that file',/,
     &          ' Enter -->quit       to stop the program, now',/)
      RETURN
      END
*-
      SUBROUTINE REWET
*-
      SAVE
*-
      INCLUDE 'hsctm.inc'
*-
      DATA VOID/1.0E20/,VDRY/0.0E0/
      DIST(N1,N2)=(CORD(N2,1)-CORD(N1,1))**2+(CORD(N2,2)-CORD(N1,2))**2
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED REWET '
*-
*      WRITE (*,*) 'STARTING REWET'
      DO 200 N=1,NP
         DREC(N)=VOID
         IF (NDRY(N) .EQ. 1) GO TO 200
         NDRY(N)=2
         VEL(3,N)=VDRY
  200 CONTINUE
      DO 205 M=1,NE
         IMAT(M)=IABS(IMAT(M))
         DO 204 K=1,8
            L=IABS(NOP(M,K))
            IF (L .EQ. 0) GO TO 204
            IF (NDRY(L) .NE. 1) IMAT(M)= -IABS(IMAT(M))
  204    CONTINUE
  205 CONTINUE
*-
* ... SET NUMBER OF PASSES
*-
      NPAS=19
      DO 600 NPA=1,NPAS
      IL=0
      ILO=0
      DO 500 N=1,NE
      IF (IMAT(N) .GE. 0) GO TO 500
      NCN=NCORN(N)
      ELD=VOID
      DO 220 M=1,NCN,2
      K=IABS(NOP(N,M))
      IF (NDRY(K) .NE. 2) GO TO 220
      DO 210 MM=1,NCN,2
      KK=IABS(NOP(N,MM))
      IF (NDRY(KK) .EQ. 2) GO TO 210
      IF (VEL(3,KK) .LT. 0.0) GO TO 210
      ELD=SQRT(DIST(K,KK))
      IF (ELD .GT. ABS(DREC(K))) GO TO 210
      IF (NDRY(KK) .EQ. -1 .AND. DREC(K) .GT. 0
     &                     .AND. DREC(K) .LT. VOID) GO TO 210
      DREC(K)=ELD
      IF (NDRY(KK) .EQ. -1) DREC(K)= -ELD
*-
* ... -HF- IS BEING COMPUTED TO ESTIMATE HEAD LOSS WITH A 0.35 VEL
*-
      IF (ZMANN(N) .EQ. 0.0) GO TO 207
      HF=3.0/(VEL(3,KK)-DSET)*(1.0/DSET**0.333-1.0/VEL(3,KK)**0.333)
      HLOS=HF*(0.35/1.486)**2*ZMANN(N)**2*ELD
      GO TO 208
  207 HF=1.0/(VEL(3,KK)-DSET)*ALOG(VEL(3,KK)/DSET)
      HLOS=HF*0.1225*ELD/CHEZ(N)**2
  208 CONTINUE
      DEP=VEL(3,KK)+AO(KK)-AO(K)-HLOS
      IF (DEP .GT. 0.0) THEN
        VEL(3,K)=DEP
        VDOT(3,K)=ALTM*(VEL(3,K)-VOLD(3,K))
        VDOTO(3,K)=0.0
        IL=IL+1
        LISTEL(IL)=N
        IF (IL .GT. 1 .AND. LISTEL(IL) .EQ. LISTEL(IL-1)) IL=IL-1
      ELSE
        VEL(3,K)=0.0
      ENDIF
  210 CONTINUE
  220 CONTINUE
      IF (ELD .EQ. VOID) GO TO 500
      IF (IL .EQ. ILO) GO TO 500
      ILO=IL
  500 CONTINUE
      IF (IL .EQ. 0) GO TO 700
      DO 550 I=1,IL
         NN=LISTEL(I)
         NCN=NCORN(NN)
         DO 530 M=1,NCN,2
            N=IABS(NOP(NN,M))
            IF (NDRY(N) .NE. 2) GO TO 530
            IF (VEL(3,N) .GT. 0) NDRY(N) = -1
  530    CONTINUE
  550 CONTINUE
  600 CONTINUE
  700 CONTINUE
      RETURN
      END
*-
      SUBROUTINE REWETM
*-
      SAVE
*-
      INCLUDE 'hsctm.inc'
*-
      DATA VOID/1.0E20/,VDRY/0.0E0/
      DIST(N1,N2)=(CORD(N2,1)-CORD(N1,1))**2+(CORD(N2,2)-CORD(N1,2))**2
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED REWETM'
*-
* ... Set all NDRY = 2 for all dry nodes
*-
      DO 200 N=1,NP
        DREC(N)=VOID
        IF (NDRY(N) .EQ. 1) GO TO 200
        NDRY(N)=2
        VEL(3,N)=VDRY
  200 CONTINUE
*-
* ... Reset IMAT
*-
      DO 205 M=1,NE
         IMAT(M)=IABS(IMAT(M))
         DO 204 K=1,8
           L=NOP(M,K)
           IF (L .EQ. 0) GO TO 204
           IF (NDRY(L) .EQ. 1) GO TO 205
  204   CONTINUE
        IMAT(M)= -IABS(IMAT(M))
  205 CONTINUE
*-
* ... Set number of passes to test adjacent node rewetting
*-
      WRITE (*,*) 'IN REWET'
      NPAS=19
      DO 600 NPA=1,NPAS
        IL=0
        ILO=0
*-
* ... Scan elements
*-
        DO 500 N=1,NE
          IF (IMATO(N) .GE. 0) GO TO 500
          NCN=NCORN(N)
          ELD=VOID
*-
* ... Work through corner nodes
*-
          DO 220 M=1,NCN,2
            K=IABS(NOP(N,M))
            IF (NDRY(K) .NE. 2) GO TO 220
*-
* ... Look at nodes in the element
*-
            DO 210 MM=1,NCN,2
              KK=IABS(NOP(N,MM))
              IF (NDRY(KK) .EQ. 2) GO TO 210
              IF (VEL(3,KK) .LT. DSET) GO TO 210
              ELD=SQRT(DIST(K,KK))
              IF (ELD .GT. ABS(DREC(K))) GO TO 210
*-
* ... Skip out if DREC has been defined and kk is recently rewetted
*-
              IF (NDRY(KK) .EQ. -1 .AND. DREC(K) .GT. 0
     &                     .AND. DREC(K) .LT. VOID) GO TO 210
              DREC(K)=ELD
*-
* ... Set ELD negative if rewetted node used
*-
              IF (NDRY(KK) .EQ. -1) DREC(K)= -ELD
*-
* ... -HF- is being computed to estimate head loss with a 0.35 vel
*-
              IF (ZMANN(N) .GT. 0.0) THEN
                 HF=1.0/VEL(3,KK)**1.333
                 HLOS=HF*(0.35/1.486)**2*ZMANN(N)**2*ELD
              ELSE
                 HF=1.0/VEL(3,KK)**2
                 HLOS=HF*0.1225*ELD/CHEZ(N)**2
              ENDIF
              DEP=HEL(KK)+AO(KK)-AO(K)-HLOS
              IF (DEP .GT. 0.0) THEN
                HEL(K)=DEP
                CALL AMF (HEL(K),VEL(3,K),AKP(K),ADT(K),ADB(K),D1,D2,1)
                CALL AMF (HOL(K),VOLD(3,K),AKP(K),ADT(K),ADB(K),D1,D2,1)
                IF (DELT .GT. 0.0) THEN
                  HDET(K)=(HEL(K)-HOL(K))/DELT
                  VDOT(3,K)=(VEL(3,K)-VOLD(3,K))/(DELT*3600.0)
                ELSE
                  HDET(K)=0.0
                  VDOT(3,K)=0.0
                ENDIF
                HDOT(K)=HDET(K)
                VDOTO(3,K)=VDOT(3,K)
                IL=IL+1
                LISTEL(IL)=N
                IF (IL .GT. 1 .AND. LISTEL(IL) .EQ. LISTEL(IL-1))
     &              IL=IL-1
                ELSE
                   VEL(3,K)=0.0
                ENDIF
  210       CONTINUE
  220     CONTINUE
          IF (ELD .EQ. VOID) GO TO 500
          IF (IL .EQ. ILO) GO TO 500
          ILO=IL
  500   CONTINUE
        IF (IL .EQ. 0) GO TO 700
*-
* ... Identify nodes that have rewet
*-
        DO 550 I=1,IL
          NN=LISTEL(I)
          NCN=NCORN(NN)
          DO 530 M=1,NCN,2
            N=IABS(NOP(NN,M))
            IF (NDRY(N) .NE. 2) GO TO 530
            IF (VEL(3,N) .GT. 0) NDRY(N)= -1
  530     CONTINUE
  550   CONTINUE
  600 CONTINUE
  700 CONTINUE
      RETURN
      END
*-
      SUBROUTINE SB (NCN,NGP)
*-
      SAVE
*-
* ... Subroutine to obtain 5th or 7th order gauss point values
*-
*     K is shape function number
*     I is gauss point number
*     L is shape function desired
*                type 1 = function
*                type 2 = x derivative
*                type 3 = y derivative
*     NCN is number of corner nodes, this determines element type.
*                 6 = triangle
*                 8 = rectangle
*-
*     NODE AND GAUSS POINT LOCATIONS DIAGRAMMED BELOW.
*     FOR 5TH ORDER CASE
*     FOR A QUAD, -1. < (ETA,PSI) < 1.
*     FOR A TRIANGLE, 0. < (ETA,PSI) < 1.0, AND ETA+PSI < 1.0
*
*                      PSI                          5
*                     /
*                    /
*            7 - - - 6 - - - 5              PSI /  7
*           /               /                  /
*          /   1   2   3   /                  6  3     2  4     /
*         /               /                  /      1
*        8   4   5   6   4 ---ETA           /
*       /               /                  /   5    4    6
*      /   7   8   9   /                  /
*     /               /                  1 - - - - -2- - - - - 3
*    1 - - - 2 - - - 3
*
*      QUADRILATERAL                            TRIANGLE
*-
* ... FOR SMALL MACHINES REAL*8  NEEDED SUB-SB-3 times  (not for CRAY)
* ...                            valid for next 3 REAL statements
*-
      REAL *8 XN2,DNX,DNY
      REAL *8 ETAGPT,PSIGPT,ETAGPR,PSIGPR,ETGPTH,PSGPTH,ETGPRH,PSGPRH
      REAL *8 SJ,SK,SM,SN,X,Y
*-
      COMMON /BLKS/ XNX(8,16),DA(8,16),DB(8,16),XMX(4,16),CA(4,16),
     &              CB(4,16)
*-
      DIMENSION ETAGPT(7),PSIGPT(7),ETAGPR(9),PSIGPR(9)
      DIMENSION ETGPTH(16),PSGPTH(16),ETGPRH(16),PSGPRH(16)
      DIMENSION SJ(8,9,3),SK(8,16,3)
      DIMENSION SM(6,7,3),SN(6,16,3)
      DATA ICNT7,ICNR9,ICNT16,ICNR16/4*0/
*-
*     ---------------------
*     GAUSS POINT LOCATIONS
*     ---------------------
*-
      DATA ETAGPT /
     &   0.33333333333333D0,  0.05971587178978D0,  0.47014206410510E0,
     &   0.47014206410510E0,  0.79742698535307D0,  0.10128650732346D0,
     &   0.10128650732346D0/
*-
      DATA PSIGPT/
     &   0.33333333333333D0,  0.47014206410510E0,  0.05971587178978D0,
     &   0.47014206410510E0,  0.10128650732346D0,  0.79742698535307D0,
     &   0.10128650732346D0/
*-
      DATA ETAGPR/
     &  -0.77459666924146D0,  0.00000000000000E0,  0.77459666924146D0,
     &  -0.77459666924146D0,  0.00000000000000E0,  0.77459666924146D0,
     &  -0.77459666924146D0,  0.00000000000000E0,  0.77459666924146D0/
*-
      DATA PSIGPR/
     &   0.77459666924146D0,  0.77459666924146D0,  0.77459666924146D0,
     &   0.00000000000000E0,  0.00000000000000E0,  0.00000000000000E0,
     &  -0.77459666924146D0, -0.77459666924146D0, -0.77459666924146D0/
*-
      DATA ETGPTH/
     & 0.00970378512695D0,0.13005607921683D0,0.04612207990645D0,
     & 0.09363778443732D0,0.02891208422438D0,0.38749748340665D0,
     & 0.13741910413455D0,0.27899046349647D0,0.05021012321138D0,
     & 0.67294686315042D0,0.23864865973143D0,0.48450832663038D0,
     & 0.06546699455501D0,0.87742880933037D0,0.31116455224431D0,
     & 0.63173125164105D0/
*-
      DATA PSGPTH/
     & 0.13005607921683D0,0.00970378512695D0,0.09363778443732D0,
     & 0.04612207990645D0,0.38749748340665D0,0.02891208422438D0,
     & 0.27899046349647D0,0.13741910413455D0,0.67294686315042D0,
     & 0.05021012321138D0,0.48450832663038D0,0.23864865973143D0,
     & 0.87742880933037D0,0.06546699455501D0,0.63173125164105D0,
     & 0.31116455224431D0/
*-
      DATA ETGPRH/
     & -0.8611363116D0,-0.3399810436D0,0.3399810436D0,
     &  0.8611363116D0,
     & -0.8611363116D0,-0.3399810436D0,0.3399810436D0,
     &  0.8611363116D0,
     & -0.8611363116D0,-0.3399810436D0,0.3399810436D0,
     &  0.8611363116D0,
     & -0.8611363116D0,-0.3399810436D0,0.3399810436D0,
     &  0.8611363116D0/
*-
      DATA PSGPRH/
     & 4*-0.8611363116D0,4*-0.3399810436D0,
     & 4*0.3399810436D0,4*0.8611363116D0/
*-
      IF (NCN .EQ. 6) GO TO 200
*-
* ... PROCESS RECTANGLE
*-
      IF (NGP .EQ. 16) GO TO 160                                         
      IF (ICNR9 .EQ. 0) THEN                                             
        DO 120 I=1,NGP                                                  
          X=ETAGPR(I)                                                   
          Y=PSIGPR(I)                                                   
          DO 110 K=1,NCN                                                
            SJ(K,I,1)=XN2(1,K,X,Y)                                      
            SJ(K,I,2)=DNX(1,K,X,Y)                                      
            SJ(K,I,3)=DNY(1,K,X,Y)                                      
  110     CONTINUE                                                      
  120   CONTINUE                                                        
        ICNR9=1                                                         
      ENDIF                                                             
      DO 140 I=1,NGP                                                    
        DO 130 K=1,NCN                                                  
          XNX(K,I)=SJ(K,I,1)                                            
          DA(K,I)=SJ(K,I,2)                                             
          DB(K,I)=SJ(K,I,3)                                             
  130   CONTINUE                                                        
  140 CONTINUE                                                          
      GO TO 400                                                         
  160 IF (ICNR16 .EQ. 0) THEN                                            
        DO 170 I=1,NGP                                                  
          X=ETGPRH(I)                                                   
          Y=PSGPRH(I)                                                   
          DO 165 K=1,NCN                                                
            SK(K,I,1)=XN2(1,K,X,Y)                                      
            SK(K,I,2)=DNX(1,K,X,Y)                                      
            SK(K,I,3)=DNY(1,K,X,Y)                                      
  165     CONTINUE                                                      
  170   CONTINUE                                                        
        ICNR16=1                                                        
      ENDIF                                                             
      DO 180 I=1,NGP                                                    
        DO 175 K=1,NCN                                                  
          XNX(K,I)=SK(K,I,1)                                            
          DA(K,I)=SK(K,I,2)                                             
          DB(K,I)=SK(K,I,3)                                             
  175   CONTINUE                                                        
  180 CONTINUE                                                          
      GO TO 400                                                         
*-
* ... PROCESS TRIANGLE                                                 
*-                                                                      
200   CONTINUE                                                          
      IF (NGP .EQ. 16) GO TO 300                                         
      IF (ICNT7 .EQ. 0) THEN                                             
        DO 275 I=1,NGP                                                  
          X=ETAGPT(I)                                                   
          Y=PSIGPT(I)                                                   
          DO 270 K=1,NCN                                                
            SM(K,I,1) = XN2(2,K,X,Y)                                    
            SM(K,I,2) = DNX(2,K,X,Y)                                    
            SM(K,I,3) = DNY(2,K,X,Y)                                    
  270     CONTINUE                                                      
  275   CONTINUE                                                        
        ICNT7=1                                                         
      ENDIF                                                             
      DO 290 I=1,NGP                                                    
        DO 285 K=1,NCN                                                  
          XNX(K,I)=SM(K,I,1)                                            
          DA(K,I)=SM(K,I,2)                                             
          DB(K,I)=SM(K,I,3)                                             
  285   CONTINUE                                                        
  290 CONTINUE                                                          
      GO TO 400                                                         
  300 IF (ICNT16 .EQ. 0) THEN                                            
        DO 325 I=1,NGP                                                  
          X=ETGPTH(I)                                                   
          Y=PSGPTH(I)                                                   
          DO 310 K=1,NCN                                                
            SN(K,I,1) = XN2(2,K,X,Y)                                    
            SN(K,I,2) = DNX(2,K,X,Y)                                    
            SN(K,I,3) = DNY(2,K,X,Y)                                    
  310     CONTINUE                                                      
  325   CONTINUE                                                        
        ICNT16=1                                                        
      ENDIF                                                             
      DO 350 I=1,NGP                                                    
        DO 340 K=1,NCN                                                  
          XNX(K,I)=SN(K,I,1)
          DA(K,I)=SN(K,I,2)
          DB(K,I)=SN(K,I,3)
  340   CONTINUE
  350 CONTINUE
*-
* ... CREATE LINEAR FUNCTIONS
*-
  400 CONTINUE
      DO 500 I=1,NGP
        J=0
        DO 450 K=1,NCN,2
          J=J+1
          NA=K-1
          IF (K .EQ. 1) NA=NCN
          XMX(J,I)=XNX(K,I)+(XNX(NA,I)+XNX(K+1,I))*0.5
          CA(J,I)=DA(K,I)+(DA(NA,I)+DA(K+1,I))*0.5
          CB(J,I)=DB(K,I)+(DB(NA,I)+DB(K+1,I))*0.5
  450   CONTINUE
  500 CONTINUE
      RETURN
      END
*-
      SUBROUTINE SBGEN (NEX)
*-
      SAVE
*-
* ... Input special boundary conditions
*-
      INCLUDE 'hsctm.inc'
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED SBGEN (NEX=',NEX,')'
*-
      IF (IOUT .GT. 0) WRITE (IOUT,888)                                   
     &          IBIN,NSID,IQGEN,IHGEN,ISTGEN,IWIND,NSTORM,NCFLW         
  888 FORMAT (' INSIDE SUBROUTINE SBGEN DEBUG ****',/,                  
     &       '  IBIN  NSID  IQGEN IHGEN ISTGEN IWIND NSTORM NCFLW=',/, 
     &       1X,8I6,/)                                                  
*-                                                                      
* ... Input element inflows                                             
*-                                                                      
      IF (NSID .GT. 0) THEN                                              
        DO 708 L=1,NSID                                                 
           READ (IBIN,5035) N,SIDF(N)                                    
  708   CONTINUE                                                        
      ELSEIF (NSID .LT. 0) THEN                                         
        READ (IBIN,5035) N,SF                                           
        DO 709 L=1,NE                                                   
          SIDF(L)=SF                                                    
  709   CONTINUE                                                        
      ENDIF                                                             
*-                                                                      
* ... Input Q for a continuity line if required                         
*-                                                                      
      IF (IQGEN .GT. 0) THEN                                             
        IF (IOUT .GT. 0) WRITE (IOUT,6033)                                 
        DO 713 N=1,IQGEN                                                
          READ (IBIN,5035) J,QF(1),QDIR(1)                              
          IF (IOUT .GT. 0) WRITE (IOUT,6034) J,QF(1),QDIR(1)               
          CALL QGEN (J,QF(1),QDIR(1))                                    
  713   CONTINUE
      ENDIF
*-
* ... Input head for a continuity line if required
*-
      IF (IHGEN .GT. 0) THEN
        IF (IOUT .GT. 0) WRITE (IOUT,6035)
        DO 714 N=1,IHGEN
          READ (IBIN,5035) J,HF
          IF (IOUT .GT. 0) WRITE (IOUT,6036) J,HF
          CALL HGEN (J,HF)
  714   CONTINUE
      ENDIF
*-
* ... Input stage-flow for a continuity line if required
*-
      IF (ISTGEN .GT. 0) THEN
        IF (IOUT .GT. 0) WRITE (IOUT,6045)
        DO 715 N=1,ISTGEN
          READ (IBIN,5035)  J,AC1,AC2,AC3,AC4,AC5
          IF (IOUT .GT. 0) WRITE (IOUT,6036) J,AC1,AC2,AC3,AC4,AC5
          CALL STGEN (J,AC1,AC2,AC3,AC4,AC5)
  715   CONTINUE
      ENDIF
*-
* ... Test and read wind velocity data, if required
*-
      IF (IWIND .EQ. 0) GO TO 220
      IF (NSTORM .GT. 0) CALL STORM (NEX)
      IF (KWIND .EQ. 99) GO TO 302
*-
      IF (KWIND .EQ. -99) THEN
         WSFCTO = WSFCT
         IF (NSTORM .EQ. 0) READ (IBIN,'(I10,2F10.0)')  N1ST,WSFCT
         DO 205  II = 1,NP
            TW(II) = TW(II)*(WSFCT/WSFCTO)
  205    CONTINUE
         WSFCTO = WSFCT
         N1ST = 1
         IF (IOUT .GT. 0) WRITE (IOUT,209) N1ST,NP,WSFCT
  209    FORMAT (' ALL NODES BETWEEN ',I6,' AND ',I6,' WERE ASSIGNED',
     &   ' A WIND SPEED FACTOR OF ',F10.5,' TO THEIR S.S. VALUE',/)
         GO TO 302
      ENDIF
*-
      IF (IOUT .GT. 0) WRITE (IOUT,6050)
      IF (IWIND .LT. 0) GO TO 215
      IF (IOUT .GT. 0) WRITE (IOUT,6051)
      IMET=0
      DO 210 J=1,NP                                                     
         IF (NSTORM .EQ. 0) READ (IBIN,'(I10,2F10.0,I10)') N,TW(N),TA(N),IM 
*-
* ... Historically, TW has been in miles/hour.  if IM
* ... is set to 1 in the first wind input record, THEN
* ... TW is entered in meters per second
* ... Change meters per second to miles per hour initially,
* ... to conform to original input.  It gets changed back to
* ... metric for some of the formulas
*-
         IF (IM .EQ. 1 .OR. IMET .EQ. 1) IMET=1                               
         IF (IMET .EQ. 1) TW(N)=TW(N)/4470.388                            
  210 CONTINUE                                                          
      GO TO 299                                                         
  215 CONTINUE                                                          
      IF (NSTORM .EQ. 0) THEN                                             
          READ (IBIN,'(I10,2F10.0,I10)') N,TW1,TA1,IM                    
      ELSE
* ... SUB STORM HAS COMPUTED WIND SPEED/DIRECTION IN MPH            
          GO TO 299                                                     
      ENDIF                                                             
      IF (IM .EQ. 1) THEN                                                 
*-
*     Historically, TW has been in miles/hour.  if IM                
*     is set to 1 in the first wind input record, then               
*     TW is entered in meters per second.                            
*     Change meters per second to miles per hour initially,          
*     to conform to original input.  It gets changed back to         
*     metric for some of the formulas.                               
*-
         IMET=1                                                         
         TW1=TW1/4470.388                                               
      ENDIF                                                             
      IF (IOUT .GT. 0) WRITE (IOUT,6052) TW1,TA1                           
      DO 219 N=1,NP                                                     
         TW(N)=TW1                                                      
         TA(N)=TA1                                                      
  219 CONTINUE                                                          
*-
*     NOTE THAT WIND COMPUTATIONS ARE DONE IN METRIC                    
*     UNITS TO CORRESPOND TO COEFFICIENT VALUES REPORTED                
*     IN THE LITERATURE.  CONVERSION TO ENGLISH UNITS                   
*     IS ACCOMPLISHED BEFORE LEAVING THIS SUBROUTINE.                   
*-
  299 JWIND=IABS(IWIND)                                                 
      IF (JWIND .EQ. 2) THEN                                              
         IF (NSTORM .EQ. 0) READ (IBIN,5037) YHT,YALPHA,YBETA,WCRIT         
*-
*        CHANGE FROM M/SEC TO CM/SEC
*-
         WCRIT=WCRIT*100.0
      ELSEIF (JWIND .EQ. 7) THEN                                          
         YHT=10.0                                                       
         YALPHA=1.1E-3                                                  
         YBETA=1.5E-3                                                   
         WCRIT=560.0
      ELSEIF (JWIND .EQ. 3) THEN                                          
         IF (NSTORM .EQ. 0) READ (IBIN,5037) YHT,CWIND,RHOAIR            
         IF (RHOAIR .LE. 0.0) RHOAIR=0.001226                             
      ELSEIF (JWIND .EQ. 8) THEN                                          
         YHT=10.0                                                       
         RHOAIR=0.001226                                                
      ELSEIF (JWIND .EQ. 4) THEN                                          
         IF (NSTORM .EQ. 0) READ (IBIN,5037) AWIND,ETA,AGRAV,RHOAIR      
         IF (RHOAIR .LE. 0.0) RHOAIR=0.001226                             
         IF (AWIND .LE. 0.0) AWIND=0.0332                                
         IF (AGRAV .LE. 0.0) AGRAV=979.965                               
      ELSEIF (JWIND .EQ. 6) THEN                                          
         IF (NSTORM .EQ. 0) READ (IBIN,5037) YHT,CWIND,EXP,RHOAIR        
         IF (RHOAIR .LE. 0.0) RHOAIR=0.001226                             
      ENDIF                                                             
      DO 300 N=1,NP                                                     
*-
*        CONVERT MILES PER HOUR TO CENTIMETERS PER SECOND
*        OR CHANGE METERS PER SECOND TO CENTIMETERS PER SECOND.
*        CONVERT DEGREES TO RADIANS.
*-
         IF (IMET .EQ. 0) THEN
            TWMET=TW(N)*44.70388                                        
         ELSE                                                           
            TWMET=TW(N)*100.                                            
         ENDIF                                                          
         TARAD=TA(N)/57.3                                               
*                                                                       
*        EKMAN FORMULA                                                  
*                                                                       
         IF (JWIND .EQ. 5) THEN                                           
            IF (N .EQ. 1 .AND. IOUT .GT. 0) WRITE (IOUT,6053) 3.2E-6        
 6053       FORMAT ('    EKMAN FORMULA USED:',                          
     &              ' WIND STRESS COEFICIENT (METRIC) = ',E12.2)         
            TSIG=3.2E-6*TWMET*TWMET                                     
*-
*        VAN DORN FORMULA
*-
         ELSEIF (JWIND .EQ. 2 .OR. JWIND .EQ. 7) THEN                         
            IF (N .EQ. 1 .AND. IOUT .GT. 0)                                
     &      WRITE (IOUT,6054) YALPHA,YBETA,WCRIT                        
 6054       FORMAT ('    VAN DORN FORMULA USED:',                       
     &      ' ALPHA WIND STRESS COEFICIENT (METRIC) = ',E14.4,/,26X,   
     &      ' BETA  WIND STRESS COEFICIENT (METRIC) = ',E14.4,/,26X,   
     &      ' CRITICAL WIND SPEED FOR WAVE FORMATION (CM/SEC) = ',E14.4)
            TERM2=TWMET-WCRIT                                           
            A=YALPHA                                                    
            B=YBETA                                                     
            IF (TERM2 .LE. 0.0) B=0.0                                     
            RHOH2O=1.0                                                  
            TSIG=RHOH2O*(A*A*TWMET*TWMET+B*B*TERM2*TERM2)               
*-
*        WU FORMULA
*-
         ELSEIF (JWIND .EQ. 3 .OR. JWIND .EQ. 8) THEN                         
            IF (JWIND .EQ. 3) GO TO 301                                   
            IF (TWMET.LE.100.0) CWIND=(1.25/((TWMET/100.0)**0.2))*0.001  
            IF (TWMET .GT. 100.0 .AND. TWMET .LT. 1500.0)                     
     &         CWIND=((TWMET/100.0)**0.5)*0.001/2.0
            IF (TWMET .GE. 1500.0) CWIND=2.6*0.001                        
            IF (N .EQ. 1 .AND. IOUT .GT. 0) WRITE (IOUT,6055) CWIND,
     &          RHOAIR  
 6055       FORMAT('    WU FORMULA USED:',                             
     &      ' WIND STRESS COEFICIENT (METRIC) = ',E14.4,/,             
     &      20X,' DENSITY OF AIR (GRAMS/CUBIC CM) = ',E14.4)            
  301       TSIG=RHOAIR*CWIND*TWMET*TWMET                               
*-
* ... SAFAIE FORMULA
*-
         ELSEIF (JWIND .EQ. 4) THEN                                       
            IF (N .EQ. 1 .AND. IOUT .GT. 0)                                 
     &      WRITE (IOUT,6056) AWIND,ETA,AGRAV,RHOAIR                    
 6056       FORMAT ('    SAFAIE FORMULA USED:',                         
     &      ' CHARNOCK''S CONSTANT (METRIC) = ',E14.4,/,               
     &      24X,' DYNAMIC ROUGHNESS (CM) = ',E14.4,/,                  
     &      24X,' ACCELERATION DUE TO GRAVTY (CM/SEC**2) = ',E14.4,/,  
     &      24X,' DENSITY OF AIR (GRAMS/CUBIC CM) = ',E14.4)            
            G=AGRAV                                                     
            TSIG=RHOAIR*ETA*G/AWIND                                     
*-
* ... ORIGINAL FORMULA
*-
         ELSEIF (JWIND .EQ. 1) THEN                                       
            CHI=3.8E-06                                                 
            IF (N .EQ. 1 .AND. IOUT .GT. 0) WRITE (IOUT,6057) CHI           
 6057       FORMAT('    ORIGINAL FORMULA USED:',                  
     &      ' WIND STRESS COEFICIENT (ENGLISH UNITS) = ',E14.4)         
            TSIG=CHI*TW(N)*TW(N)                                        
*-
* ... GENERIC FORMULA
*-
         ELSEIF (JWIND .EQ. 6) THEN
            IF (N .EQ. 1 .AND. IOUT .GT. 0)                                 
     &      WRITE (IOUT,6058) CWIND,RHOAIR,EXP                          
 6058       FORMAT('    GENERIC FORMULA USED:',                        
     &      ' WIND STRESS COEFICIENT (METRIC) = ',E14.4,/,             
     &      25X,' DENSITY OF AIR (GRAMS/CUBIC CM) = ',E14.4,/,         
     &      25X,' EXPONENT FOR WIND VELOCITY = ',E14.4)                 
            TSIG=RHOAIR*CWIND*TWMET**EXP                                
         ENDIF                                                          
*-
* ... COMPUTE X AND Z COMPONENTS.  CONVERT FROM GRAMS/(CM*SEC*SEC) TO
* ... POUNDS/(FOOT*SEC*SEC) (EXCEPT WHEN JWIND=1)
*-
         IF (METRIC .GE. 1) THEN                                        
* ... UNITS COMING IN ARE METRIC
              FACT = 0.1                                                
              IF (JWIND .EQ. 1) FACT = 47.918                          
         ELSE                                                           
* ... CHANGE FROM POUNDS MASS TO POUNDS FORCE
* ... DO THIS ....  FACT=.0671976/(GRAV=32.2)  --> 0.002087
              FACT = 1.0/479.18                                         
              IF (JWIND .EQ. 1) FACT = 1.0                            
         ENDIF                                                          
*-
         SIGMA(N,1)=TSIG*COS(TARAD)*FACT
         SIGMA(N,2)=TSIG*SIN(TARAD)*FACT
*-
  300 CONTINUE
*-
  302 WRITE (*,305) IWIND,NSTORM,SIGMA(1,1),SIGMA(1,2),TW(1),TWMET      
  305 FORMAT (2X,'IWIND=',I4,' NSTORM=',I4,' FIRST SIGMA VALUES=',
     &       2F12.4,1X,'TW(1)=',F12.4,' TWMET=',F12.4)                        
  220 CONTINUE                                                          
*-                                                                      
* ... Input properties flow flow control elements                      
*-                                                                      
      IF (NCFLW .GT. 0) THEN                                             
        DO 400 K=1,NCFLW                                                
           READ (IBIN,5040) NJN,NJT1,AJ1,BJ1,CJ1,GAM1,QD1                
           IF (IOUT .GT. 0) WRITE (IOUT,6040) NJN,NJT1,AJ1,BJ1,CJ1,
     &                                        GAM1,QD1 
           NJT(NJN-900)=NJT1                                             
           AJ(NJN-900)=AJ1                                               
           BJ(NJN-900)=BJ1                                               
           CJ(NJN-900)=CJ1                                               
           GAMJ(NJN-900)=GAM1                                            
           QD(NJN-900)=QD1                                               
  400   CONTINUE
      ENDIF
 5035 FORMAT (I10,7F10.0)
 5036 FORMAT (I10)
 5037 FORMAT (5F10.0)
 5040 FORMAT (2I10,5F10.0)
 6033 FORMAT (/'*** BOUNDARY CONDITION DEFINED AS FLOW ACROSS A LINE'//
     &'      LINE           FLOW      DIRECTION')
 6034 FORMAT (I10,F15.3,F15.3)
 6035 FORMAT (/'   BOUNDARY CONDITION DEFINED AS ELEVATION ALONG A LINE'
     &//'      LINE           ELEV')
 6036 FORMAT (I10,4F15.3,F15.3)
 6040 FORMAT (/'   PROPERTIES OF FLOW CONTROL STRUCTURE NUMBER',I6//
     &'  TYPE    AJ        BJ        CJ       GAM  FLOW-DIR.'/
     &   1X,I6,4F10.2,F10.3)
 6045 FORMAT (/'  BOUNDARY CONDITION DEFINED AS STAGE FLOW ALONG A LINE'
     &//'      LINE             A1             A2             E0',
     &            '             C       DIRECTION')
 6050 FORMAT ('0   WIND STRESS INFORMATION:')
 6051 FORMAT ('    WIND VELOCITY SUPPLIED AT EVERY NODE')
 6052 FORMAT ('    WIND VELOCITY CONSTANT OVER ALL NODES',/,
     &  '    WIND VELOCITY (MPH) = ',F10.5,/,
     &  '    ANGLE BETWEEN WIND AND X-AXIS (DEGREES ANTI-CLOCKWISE) = ',
     &  F10.5)
      RETURN
      END
*-
      SUBROUTINE SBGENP (NEX)
*-
      SAVE
*-
* ... Input special boundary conditions
*-
      INCLUDE 'hsctm.inc'
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED SBGENP (NEX=',NEX,')'
*-
* ... Input Q for a continuity line if required
*-
      IF (IQGEN .GT. 0) THEN
         IF (IOUT .GT. 0) WRITE (IOUT,6033)
         DO 713 N=1,IQGEN
            IF (IOUT .GT. 0) WRITE (IOUT,6034) JCQ(N),QF(N),QDIR(N)
            CALL QGEN (JCQ(N),QF(N),QDIR(N))
  713    CONTINUE
      ENDIF
*-
* ... Input head for a continuity line if required
*-
      IF (IHGEN .GT. 0) THEN
         IF (IOUT .GT. 0) WRITE (IOUT,6035)
         DO 714 N=1,IHGEN
*            J=JCH(N)
            IF (IOUT .GT. 0) WRITE (IOUT,6036) JCH(N),HFX(N)
*            WRITE (IOUT,9947) IHGEN,N,JCH(N),HFX(N),J,LMT(J)
* 9947       FORMAT (' IHGEN=',I5,' N=',I5,' JCH=',I15,' HFX=',F10.4,
*      &             2I8)
*            KK=LMT(J)
*            WRITE (IOUT,9948) (LINE(J,K),K=1,KK)
* 9948       FORMAT (15I6)
            CALL HGEN (JCH(N),HFX(N))
*            WRITE (IOUT,9947) IHGEN,N,JCH(N),HFX(N)
  714    CONTINUE
      ENDIF
*-
* ... Input stage-flow for a continuity line if required
*-
      IF (ISTGEN .GT. 0) THEN
        IF (IOUT .GT. 0) WRITE (IOUT,6045)
        DO 715 N=1,ISTGEN
          IF (IOUT .GT. 0)
     &    WRITE (IOUT,6036) JCR(N),AC1X(N),AC2X(N),
     &                      AC3X(N),AC4X(N),AC5X(N)
          CALL STGEN (JCR(N),AC1X(N),AC2X(N),AC3X(N),AC4X(N),AC5X(N))
  715   CONTINUE
      ENDIF
*-
* ... Test and read wind velocity data, if required
*-
      IF (IWIND .EQ. 0) GO TO 220
      IF (NSTORM .GT. 0) CALL STORM (NEX)
      IF (IOUT .GT. 0) WRITE (IOUT,6050)
      IMET=0
      DO 210 J=1,NP                                                     
*-
* ... Historically, TW has been in miles/hour.  if IM
* ... is set to 1 in the first wind input record, then
* ... TW is entered in meters per second.
* ... Change meters per second to miles per hour initially,
* ... to conform to original input.  It gets changed back to
* ... metric for some of the formulas.
*-
         TW(J) = TWX(J)                                                 
         TA(J) = TAX(J)                                                 
         IWMX  = IWMX                                                   
* ... THE VARIABLES TWX,TAX,IWMX WERE DEFINED WITH PREHYD/STORM
         IF (IWMX .EQ. 1 .OR. IMET .EQ. 1) IMET=1                           
         IF (IMET .EQ. 1) TW(N)=TW(N)/4470.388                           
  210 CONTINUE
      PRINT 2111,TW(1),TA(1),NP,TW(NP),TA(NP),IWMX,IMET
      IF (IOUT .GT. 0)                                                    
     &  WRITE (IOUT,2111) TW(1),TA(1),NP,TW(NP),TA(NP),IWMX,IMET          
 2111 FORMAT(2X,'SUB SBGENP * * *  TW(1),TA(1)=',2F12.5,/,             
     &       2X,' NP,TW(NP),TA(NP)=',                                  
     &       I8,2F12.5,2X,'IWMX=',I7,' IMET=',I7,' DEBUG***')           
*                                                                       
*     NOTE THAT WIND COMPUTATIONS ARE DONE IN METRIC                    
*     UNITS TO CORRESPOND TO COEFFICIENT VALUES REPORTED                
*     IN THE LITERATURE.  CONVERSION TO ENGLISH UNITS                   
*     IS ACCOMPLISHED BEFORE LEAVING THIS ROUTINE.                      
*                                                                       
  299 JWIND=IABS(IWIND)                                                 
      IF (JWIND .EQ. 2) THEN                                              
* ... VAN DORN FORMULA                                              
* ===     READ (IBIN,5037) YHT,YALPHA,YBETA,WCRIT                        
          YHT    =  WC1X                                                
          YALPHA =  WC2X                                                
          YBETA  =  WC3X                                                
          WCRIT  =  WC4X                                                
*                                                                       
*        CHANGE FROM M/SEC TO CM/SEC                                    
*                                                                       
         WCRIT=WCRIT*100.                                               
      ELSEIF (JWIND .EQ. 7) THEN                                          
* ... VAN DORN FORMULA                                               
         YHT=10.0                                                       
         YALPHA=1.1E-3                                                  
         YBETA=1.5E-3                                                   
         WCRIT=560.                                                     
      ELSEIF (JWIND .EQ. 3) THEN                                          
* ... WU FORMULA COEFFICIENTS SUPPLIED                               
* ===    READ (IBIN,5037) YHT,CWIND,RHOAIR                               
         YHT    = WC1X                                                  
         CWIND  = WC2X                                                  
         RHOAIR = WC3X                                                  
         IF (RHOAIR.LE.0.0) RHOAIR=0.001226                             
      ELSEIF (JWIND .EQ. 8) THEN                                          
* ... WU FORMULA WITH DEFAULT COEFFICIENTS                           
         YHT=10.0                                                       
         RHOAIR=0.001226                                                
      ELSEIF (JWIND .EQ. 4) THEN                                          
* ... SAFAIE FORMULA WITH SUPPLIED COEFFICIENTS                      
* ===    READ (IBIN,5037) AWIND,ETA,AGRAV,RHOAIR                         
         AWIND    =  WC1X                                               
         ETA      =  WC2X                                               
         AGRAV    =  WC3X                                               
         RHOAIR   =  WC4X                                               
         IF (RHOAIR.LE.0.0) RHOAIR=0.001226
         IF (AWIND.LE.0.0) AWIND=0.0332
         IF (AGRAV.LE.0.0) AGRAV=979.965
      ELSEIF (JWIND .EQ. 6) THEN
* ... GENERIC FORMULA WITH SUPPLIED COEFFICIENTS
         YHT = WC1X
         CWIND = WC2X
         EXP = WC3X
         RHOAIR = WC4X
         IF (RHOAIR .LE. 0.0) RHOAIR=0.001226                             
      ENDIF                                                             
      DO 300 N=1,NP
*-
* ... CONVERT MILES PER HOUR TO CENTIMETERS PER SECOND
* ... OR CHANGE METERS PER SECOND TO CENTIMETERS PER SECOND.
* ... CONVERT DEGREES TO RADIANS
*-
         IF (IMET .EQ. 0) THEN                                            
            TWMET=TW(N)*44.70388                                        
         ELSE                                                           
            TWMET=TW(N)*100.0                                            
         ENDIF                                                          
         TARAD=TA(N)/57.3                                               
*                                                                       
*        EKMAN FORMULA                                                  
*                                                                       
         IF (JWIND .EQ. 5) THEN                                           
            IF (N .EQ. 1 .AND. IOUT .GT. 0) WRITE (IOUT,6053) 3.2E-6        
 6053       FORMAT('    EKMAN FORMULA USED:',                          
     &             ' WIND STRESS COEFICIENT (METRIC) = ',E12.2)         
            TSIG=3.2E-6*TWMET*TWMET                                     
*                                                                       
*        VAN DORN FORMULA                                               
*                                                                       
         ELSEIF (JWIND .EQ. 2 .OR. JWIND .EQ. 7) THEN                         
            IF (N .EQ. 1 .AND. IOUT .GT. 0)                                 
     &      WRITE (IOUT,6054) YALPHA,YBETA,WCRIT                        
 6054       FORMAT('    VAN DORN FORMULA USED:',                       
     &      ' ALPHA WIND STRESS COEFICIENT (METRIC) = ',E14.4,/,26X,   
     &      ' BETA  WIND STRESS COEFICIENT (METRIC) = ',E14.4,/,26X,   
     &      ' CRITICAL WIND SPEED FOR WAVE FORMATION (CM/SEC) = ',E14.4)
            TERM2=TWMET-WCRIT                                           
            A=YALPHA                                                    
            B=YBETA                                                     
            IF (TERM2 .LE. 0.0) B=0.0                                     
            RHOH2O=1.0                                                  
            TSIG=RHOH2O*(A*A*TWMET*TWMET+B*B*TERM2*TERM2)               
*                                                                       
*        WU FORMULA                                                     
*                                                                       
         ELSEIF (JWIND .EQ. 3 .OR. JWIND .EQ. 8) THEN                         
            IF (JWIND .EQ. 3) GO TO 301                                   
            IF (TWMET .LE. 100.0) CWIND=(1.25/((TWMET/100.0)**0.2))*0.001  
            IF (TWMET .GT. 100.0 .AND. TWMET .LT. 1500.0)                     
     &         CWIND=((TWMET/100.0)**0.5)*0.001/2.0                       
            IF (TWMET .GE. 1500.0) CWIND=2.6*0.001                        
            IF (N .EQ. 1 .AND. IOUT .GT. 0) WRITE (IOUT,6055) CWIND,
     &          RHOAIR  
 6055       FORMAT ('    WU FORMULA USED:',                             
     &      ' WIND STRESS COEFICIENT (METRIC) = ',E14.4,/,20X,         
     &      ' DENSITY OF AIR (GRAMS/CUBIC CM) = ',E14.4)                
  301       TSIG=RHOAIR*CWIND*TWMET*TWMET                               
*-
* ... SAFAIE FORMULA
*-
         ELSEIF (JWIND .EQ. 4) THEN                                       
            IF (N .EQ. 1 .AND. IOUT .GT. 0)                                 
     &      WRITE (IOUT,6056) AWIND,ETA,AGRAV,RHOAIR                    
 6056       FORMAT ('    SAFAIE FORMULA USED:',                         
     &      ' CHARNOCK''S CONSTANT (METRIC) = ',E14.4,/,               
     &      24X,' DYNAMIC ROUGHNESS (CM) = ',E14.4,/,                  
     &      24X,' ACCELERATION DUE TO GRAVTY (CM/SEC**2) = ',E14.4,/,  
     &      24X,' DENSITY OF AIR (GRAMS/CUBIC CM) = ',E14.4)            
            G=AGRAV                                                     
            TSIG=RHOAIR*ETA*G/AWIND                                     
*-
* ... ORIGINAL FORMULA
*-
         ELSEIF (JWIND .EQ. 1) THEN
            CHI=3.8E-06
            IF (N .EQ. 1 .AND. IOUT .GT. 0) WRITE (IOUT,6057) CHI
 6057       FORMAT('    ORIGINAL FORMULA USED:',
     &      ' WIND STRESS COEFICIENT (ENGLISH UNITS) = ',E14.4)
            TSIG=CHI*TW(N)*TW(N)
*-
* ... GENERIC FORMULA
*-
         ELSEIF (JWIND .EQ. 6) THEN
            IF (N .EQ. 1 .AND. IOUT .GT. 0)
     &      WRITE (IOUT,6058) CWIND,RHOAIR,EXP
 6058       FORMAT('    GENERIC FORMULA USED:',
     &      ' WIND STRESS COEFICIENT (METRIC) = ',E14.4,/,
     &      25X,' DENSITY OF AIR (GRAMS/CUBIC CM) = ',E14.4,
     &      25X,' EXPONENT FOR WIND VELOCITY = ',E14.4)
            TSIG=RHOAIR*CWIND*TWMET**EXP
         ENDIF
*-
* ... COMPUTE X AND Z COMPONENTS.  CONVERT FROM GRAMS/(CM*SEC*SEC) TO
* ... POUNDS/(FOOT*SEC*SEC) (EXCEPT WHEN JWIND=1)
*-
         IF (METRIC .GE. 1) THEN
* ... UNITS COMING IN ARE METRIC                                
              FACT = 0.1                                                
              IF (JWIND .EQ. 1) FACT = 47.918                          
         ELSE                                                           
* ... CHANGE FROM POUNDS MASS TO POUNDS FORCE                   
* ... DO THIS ....  FACT=.0671976/(GRAV=32.2)  --> 0.002087   
              FACT = 1.0/479.18                                         
              IF (JWIND .EQ. 1) FACT = 1.0                            
         ENDIF                                                          
*-                                                                      
         SIGMA(N,1)=TSIG*COS(TARAD)*FACT                                
         SIGMA(N,2)=TSIG*SIN(TARAD)*FACT                                
*                                                                       
  300 CONTINUE                                                          
*                                                                       
  302 WRITE (*,305) IWIND,NSTORM,SIGMA(1,1),SIGMA(1,2),TW(1),TWMET      
  305 FORMAT(2X,'IWIND=',I4,' NSTORM=',I4,' FIRST SIGMA VALUES=',2F10.4,
     &       1X,'TW(1)=',F10.4,' TWMET=',F10.4)                        
  220 CONTINUE                                                          
*-                                                                      
* ... Input properties flow flow control elements                      
*-                                                                      
      IF (NCFLW .GT. 0) THEN                                             
        DO 400 K=1,NCFLW                                                
* ===     READ (IBIN,5040)   NJN,NJT1,AJ1,BJ1,CJ1,GAM1,QD1               
          IF (IOUT .GT. 0) WRITE (IOUT,6040) IFLZ1(K),IFLZ2(K),          
     &                     FLZ3(K),FLZ4(K),FLZ5(K),FLZ6(K),FLZ7(K)       
          NJN           = IFLZ1(K)
          NJT(NJN-900)  = IFLZ2(K)
          AJ(NJN-900)   =  FLZ3(K)
          BJ(NJN-900)   =  FLZ4(K)
          CJ(NJN-900)   =  FLZ5(K)
          GAMJ(NJN-900) =  FLZ6(K)
          QD(NJN-900)   =  FLZ7(K)
  400   CONTINUE
      ENDIF
 5035 FORMAT (I10,7F10.0)
 5036 FORMAT (I10)
 5037 FORMAT (5F10.0)
 5040 FORMAT (2I10,5F10.0)
 6033 FORMAT (/'   BOUNDARY CONDITION DEFINED AS FLOW ACROSS A LINE'//
     &'       LINE           FLOW      DIRECTION')
 6034 FORMAT (I10,F15.3,F15.3)
 6035 FORMAT (/'   BOUNDARY CONDITION DEFINED AS ELEV ALONG A LINE'//
     &'      LINE           ELEV')
 6036 FORMAT (I10,4F15.3,F15.3)
 6040 FORMAT (/'   PROPERTIES OF FLOW CONTROL STRUCTURE NUMBER',I6//
     &'  TYPE    AJ        BJ        CJ       GAM  FLOW-DIR.'/
     &   1X,I6,4F10.2,F10.3)
 6045 FORMAT(/'   BOUNDARY CONDITION DEFINED AS STAGE FLOW ALONG A LINE'
     &//'      LINE             A1             A2             E0',
     &            '             *       DIRECTION')
 6050 FORMAT ('0   WIND STRESS INFORMATION:')
 6051 FORMAT ('    WIND VELOCITY SUPPLIED AT EVERY NODE')
 6052 FORMAT ('    WIND VELOCITY CONSTANT OVER ALL NODES',/,
     &  '    WIND VELOCITY (MPH) = ',F10.5,/,
     &  '    ANGLE BETWEEN WIND AND X-AXIS (DEGREES ANTI-CLOCKWISE) = ',
     &  F10.5)
      RETURN
      END
*-
      SUBROUTINE SECOND (TA)
*-
      SAVE
*-
* ... Timing routine
*-
*     TA is time in seconds
*-
      TA=0.0
      RETURN
      END
*-
      SUBROUTINE STGEN (J,A11,A22,A33,A44,A55)
*-
      SAVE
*-
* ... Generate specified stage flow boundary conditions
*-
      INCLUDE 'hsctm.inc'
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED STGEN (J etc=',J,')'
*-
* ... Save pointer to define which nodes are stage flow
*-
      MAX=LMT(J)
      DO 300 K=1,MAX
         NA=LINE(J,K)
         ISTLIN(NA)=J
  300 CONTINUE
*-
* ... Save constants for later use
*-
      STQ(J)=A11
      STQA(J)=A22
      STQE(J)=A33
      STQC(J)=A44
      STQT(J)=A55
*-
* ... Define a nominal Q and generate B-C's
*-
      IF (ABS(A11) .LE. 0.0001) A11=0.0001
****   QREQ=A11+A22*XGO*(ABS(XCHK))**A44
      QREQ=A1
      CALL QGEN (J,QREQ,A55)
      RETURN
      END
*-
      SUBROUTINE STORM (NEX)
*-
      SAVE
*-
*      THIS COMPUTES THE TEMPORAL AND SPATIAL
*      DISTRIBUTION OF WIND SPEED AND DIRECTION OF A STORM(S) AS IT
*      MOVES OVER A MODEL MESH
*-
*      THE PRIMARY VARIABLES ARE:
*-
*          BETAL = STANDARD DEVIATION OF SPATIAL DISTRIBUTION
*                  FUNCTION IS DIRECTION OF STORM MOVEMENT
*          BETAT = STANDARD DEVIATION OF SPATIAL DISTRIBUTION
*                  FUNCTION IN DIRECTION TRANSVERSE TO STORM PATH
*
*          SSPD  = STORM SPEED IN MPH
*          X0,Y0 = LOCATION OF STORM CENTER
*    XORIG,YORIG = LOCATION OF STORM AT T=0.0
*         THETAS = DIRECTION OF STORM TRACK, DEGREES
*                  COUNTERCLOCKWISE FROM +X-AXIS TOWARD WHICH
*                  STORM IS MOVING
*         THETAK = ORIENTATION OF FRONT (0,180) RELATIVE TO X-
*                  AXIS IN DEGREES, DEGREES CCW
*          DECAY = STORM DECAY TERM
*
*         WNDMAX = MAXIMUM WIND SPEED
*         WNDMIN = MINIMUM OR BASE WIND LEVEL
*
*           NREF = REFERENCE NODE FOR STORM TRACK
*           TREF = REFERENCE TIME FOR STORM AT NREF
*
*         ISTYPE = STORM REFERENCE POINT (3 = CENTER)
*-
      INCLUDE 'hsctm.inc'
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED STORM (NEX=',NEX,')'
*-
      DO 100 IJ=1,NP
         WX(IJ) = 0.0
         WY(IJ) = 0.0
  100 CONTINUE
*-
      DO 800 M=1,NSTORM
         WSMAX = (WNDMAX(M)-WNDMIN)/(EXP(-0.5)/2.0**0.5)
         IF (ABS(DECAY(M)).GT. 0.000001) THEN
            IF (DECAY(M) .LT. 0.000001) TMAXS = 0.0
            IF (DECAY(M) .GT. 0.000001) TMAXS = TREF(M)
            WSMAX = WSMAX*EXP(-(TET-TMAXS)**2.0/DECAY(M)**2.0)
         ENDIF
         PI = 4.0*ATAN(1.0)
         ARGS = THETAS(M)*PI/180.0
         XORIG = CORD(NREF(M),1)-TREF(M)*SSPD(M)*COS(ARGS)*5280.0
         YORIG = CORD(NREF(M),2)-TREF(M)*SSPD(M)*SIN(ARGS)*5280.0
         X0 = XORIG+TET*SSPD(M)*COS(ARGS)*5280.0
         Y0 = YORIG+TET*SSPD(M)*SIN(ARGS)*5280.0
         DO 500 I=1,NP
            X = CORD(I,1)                                               
            Y = CORD(I,2)                                               
            DX = X-X0                                                   
            DY = Y-Y0                                                   
            ARG = 2.0*THETAK(M)*PI/360.0
            DT = DY*SIN(ARG)+DX*COS(ARG)                          
            DL = DX*SIN(ARG)-DY*COS(ARG)                          
            IF (ISTYPE(M) .EQ. 1) DT=DT+BETAT(M)/2.0**0.5              
            IF (ISTYPE(M) .EQ. 2) DT=DT-BETAT(M)/2.0**0.5              
            IF (ISTYPE(M) .EQ. 4) DL=DL+BETAL(M)/2.0**0.5              
            IF (ISTYPE(M) .EQ. 5) DL=DL-BETAL(M)/2.0**0.5              
            ARGL = -DL**2.0/BETAL(M)**2.0
            ARGT = -DT**2.0/BETAT(M)**2.0
            FL = DL/BETAL(M)                                            
            FT = DT/BETAT(M)                                            
            WL = -FT*EXP(ARGL)*EXP(ARGT)*WSMAX                   
            WTT =   FL*EXP(ARGL)*EXP(ARGT)*WSMAX      
            WSS = SQRT(WL*WL+WTT*WTT)               
            IF (ABS(WL) .LE. 0.0000001 .AND. ABS(WTT) .LE. 
     &          0.0000001) THEN
               WDIRF = 0.0
            ELSE                                                        
               WDIRF = ATAN2(WTT,WL)              
            ENDIF                                                       
            WDIRF = WDIRF*180.0/PI
            WDIRXY = WDIRF-(90.0-THETAK(M))
            ARGXY = WDIRXY*PI/180.                                    
            WX(I) = WX(I)+WSS*COS(ARGXY)                          
            WY(I) = WY(I)+WSS*SIN(ARGXY)                          
  500    CONTINUE
  800 CONTINUE
*-
      TESTIT = 0.0000001
      DO 900 I=1,NP                                                     
         IF (ABS(WX(I)) .LE. TESTIT .AND. ABS(WY(I)) .LE. TESTIT) THEN
            WDIRXY = 0.0
         ELSE                                                           
            WDIRXY = ATAN2(WY(I),WX(I))                                 
         ENDIF                                                          
         WSS = SQRT(WX(I)**2.0+WY(I)**2.0)+WNDMIN
         TAX(I) = WDIRXY*180.0/PI
         TWX(I) = WSS                          
         TA(I)  = TAX(I)                                                
         TW(I)  = TWX(I)                                                
         IF (NEX .LE. 1) THEN
             IF (I .EQ. 1)
     &       PRINT *,' WIND STEADY-STATE SPEED =1.0 MPH FOR ALL NODES'
             TWX(I) = 1.0
         ENDIF
         WX(I) = TWX(I)*COS(WDIRXY)
         WY(I) = TWX(I)*SIN(WDIRXY)
  900 CONTINUE
      IF (IOUT .GT. 0) WRITE (IOUT,910) NSTORM,TWX(1),NP,TWX(NP)
      PRINT 910,NSTORM,TWX(1),NP,TWX(NP)
  910 FORMAT(/,' AFTER SUB STORM * * * NSTORM=',I4,
     &         ' NODE=1 WIND SPEED=',F8.2,' NODE=',I6,' SPEED=',F8.2,/)
*-
      RETURN
      END
*-
      SUBROUTINE XRED (NRR)
*-
      SAVE
*-
* ... Routine to read data from mass storage
*-
      INCLUDE 'hsctm.inc'
*-
      COMMON /CHR1/ FNAM,FNBM,TNAM,FHED,TSUB,TNUM
      CHARACTER*8 FNAM
      CHARACTER*7 FNBM
      CHARACTER*4 TNAM,FHED
      CHARACTER*3 TSUB,TNUM
      DATA IPASS/0/
*-
      IF (ITRACE .GE. 2)
     &    PRINT *,' =+= CALLED XRED (ND1=NSCR etc=',ND1,')'
*-
      IF (IPASS .EQ. 0) THEN
         MAXFIL=0
         IPASS=1
      ENDIF
*-
      IF (IVRSID .EQ. 4 .OR. IVRSID .EQ. 6) THEN
*-
* ... Read sequential file
*-
        WRITE (TSUB,3000) NRR
 3000   FORMAT (I3.3)
        CLOSE (ND1)
        IF (IVRSID .EQ. 4) THEN
          FNAM=FHED//'.'//TSUB(1:3)
          IF (NRR .GT. 1 .OR. IPASS .GT. 0) CLOSE (ND1)
          OPEN (ND1,FILE=FNAM,ACCESS='TRANSPARENT',STATUS='UNKNOWN',
     &    FORM='UNFORMATTED')
        ELSE
          FNBM=FHED//TSUB(1:3)
          IF (NRR .GT. 1 .OR. IPASS .GT. 0) CLOSE (ND1)
          OPEN (ND1,FILE=FNBM,ACCESS='TRANSPARENT',STATUS='UNKNOWN',
     &    FORM='UNFORMATTED')
        ENDIF
*-
        REWIND ND1
        READ (ND1) LQ,LHS,QS
        REWIND ND1
        NRR=NRR-1
      ELSE
        READ (ND1,REC=NRR) LQ,LHS,QS
        NRR = NRR-1
      ENDIF
      RETURN
      END
*-
      SUBROUTINE XWRT (N,NRR)
*-
      SAVE
*-
      INCLUDE 'hsctm.inc'
      COMMON /CHR1/ FNAM,FNBM,TNAM,FHED,TSUB,TNUM
      CHARACTER*8 FNAM
      CHARACTER*7 FNBM
      CHARACTER*4 TNAM,FHED
      CHARACTER*3 TSUB,TNUM
      LOGICAL EX
      DATA IPASS/0/
*-
      IF (ITRACE .GE. 2) PRINT *,' =+= CALLED XWRT (ND1=NSCR=',ND1,')'
*-
      IF (IPASS .EQ. 0) MAXFIL=0
*-
      IF (IVRSID .LT. 4 .OR. IVRSID .EQ. 5) THEN
        IF (IPASS .EQ. 0) THEN
          IF (IVRSID .EQ. 1) THEN
*-
* ... NSIZ in bytes
*-
            NSIZ=8*NBS+4
*-
          ELSEIF (IVRSID .EQ. 2) THEN
*-
* ... NSIZ for short words (2 bytes)
*-
            NSIZ=4*NBS+2
*-
          ELSEIF (IVRSID .EQ. 3) THEN
*-
* ... NSIZ for long words (4 bytes)
*-
            NSIZ=2*NBS+1
*-
          ELSE
*-
* ... NSIZ for 64 bit machines recording record size in bytes
*-
            NSIZ=16*NBS+8
          ENDIF
*-
          OPEN (ND1,STATUS='SCRATCH',ACCESS='TRANSPARENT',
     &    FORM='UNFORMATTED')
          IPASS=1
          NRR=0
        ENDIF
        IF (N .EQ. 0) RETURN
        NRR=NRR+1
        WRITE (ND1,REC=NRR) LQ,LHS,QS
*-
      ELSE
        IF (IPASS .EQ. 0) THEN
*-
* ... Develop a name for the scratch file
*-
        DO 300 NSCT=1,999
          WRITE (TNUM,3001) NSCT
 3001     FORMAT(I3.3)
          FHED='H'//TNUM(1:3)
          IF (IVRSID .EQ. 4) THEN
            FNAM=FHED//'.001'
            INQUIRE(FILE=FNAM,EXIST=EX)
          ELSE
            FNBM=FHED//'001'
            INQUIRE(FILE=FNBM,EXIST=EX)
          ENDIF
          IF (EX) GO TO 300
          GO TO 301
  300   CONTINUE
        IF (IOUT .GT. 0) WRITE (IOUT,3002)                                 
        WRITE (*,3002)                                                   
 3002   FORMAT (' UNABLE TO OPEN SCRATCH FILE WITH SUITABLE NAME'/       
     &  ' EXECUTION TERMINATED')                                        
        IF (IBATCH .EQ. 0) CALL BEEP (10)                                 
        STOP
  301   CONTINUE
        IPASS=1
        WRITE (*,3003) FHED
 3003   FORMAT (' HEADER ON SCRATCH FILE IS',3X,A4)
*-
* ... Open temporary sequential file
*-
        ENDIF
        NRR=NRR+1
        WRITE (TSUB,3000) NRR
 3000   FORMAT(I3.3)
        IF (MAXFIL .LT. NRR) MAXFIL=NRR
        IF (IVRSID .EQ. 4) THEN
          FNAM=FHED//'.'//TSUB(1:3)
          IF (NRR .GT. 1 .OR. IPASS .GT. 0) CLOSE (ND1)
          OPEN(ND1,FILE=FNAM,STATUS='UNKNOWN',
     &    FORM='UNFORMATTED')
        ELSE
          FNBM=FHED//TSUB(1:3)
          IF (NRR .GT. 1 .OR. IPASS .GT. 0) CLOSE (ND1)
          OPEN(ND1,FILE=FNBM,STATUS='UNKNOWN',
     &    FORM='UNFORMATTED')
        ENDIF
*-
        IF (N .EQ. 0) RETURN
*-
        WRITE (ND1) LQ,LHS,QS
*-
      ENDIF
      RETURN
      END
*-
      SUBROUTINE ZVRS (NTIM)
*-
      SAVE
      INCLUDE 'hsctm.inc'
*-
      COMMON /CHR1/ FNAM,FNBM,TNAM,FHED,TSUB,TNUM
      CHARACTER*8 FNAM
      CHARACTER*7 FNBM
      CHARACTER*4 TNAM,FHED
      CHARACTER*3 TSUB,TNUM
*-
*       This routine is used to define the various necessary configuration
*       based on the type of machine used.
*       Users must set IVRSID to the appropriate constant for their machine.
*-
*       IVRSID can take the following values
*       1   F77 standard  Direct access record length unlimited, and
*                         defined in terms of bytes
*           Example systems            Definicon 032 board
*                                      M S FORTRAN for PCs
*-
*       2   F77 standard  Direct access record length unlimited, and
*                         defined in terms of short words (2 bytes)
*           Example systems            Prime mini computers
*-
*       3   F77 standard  Direct access record length limited to 32k bytes
*                         defined in terms of long words (4 bytes)
*           Example systems            DEC Vax
*-
*       4   F77 standard  Direct access defined using multiple sequential
*                         access files that are opened as required. Note
*                         this may generate and leave many files on disk
*           Example sytems             Apple MAC II under Absoft FORTRAN
*                                      Definicon 020 board
*                                      DEC Vax to avoid short record limit
*-
*       5   F77 standard  Direct access defined for systems using 64 bytes
*                         or 8 byte words and where record lengths are
*                         defined in bytes
*           Example systems            Cray or CDC Cyber
*-
*       6   F77 standard  Direct access defined using multiple sequential
*                         access files that are opened as required. Note
*                         this version does not put period in file name.
*                         It may generate and leave many files on disk
*           Example sytems             CDC Cyber
*-
*           USE PARAMETER VALUE FOR INITIAL BUFFER SIZE
*-
      IF (ITRACE .GE. 1) PRINT *,' =+= CALLED ZVRS (NTIM=',NTIM,')'
*-
      IF (NTIM .GT. 0) GO TO 750
      LBMAX=NBS
      RETURN
  750 CONTINUE
*-
* ... Clean up scratch files
*-
      IF (MAXFIL .EQ. 0) RETURN
      IF (IVRSID .EQ. 4 .OR. IVRSID .EQ. 6) THEN
        DO 800 NRC = 1,MAXFIL
           WRITE (TSUB,3000) NRC
 3000      FORMAT(I3.3)
           IF (IVRSID .EQ. 4) THEN
           FNAM=FHED//'.'//TSUB(1:3)
           CLOSE (NSCR)
           OPEN(NSCR,FILE=FNAM,STATUS='UNKNOWN',
     &     FORM='UNFORMATTED')
           CLOSE(NSCR,STATUS='DELETE')
           ELSE
           FNBM=FHED//TSUB(1:3)
           CLOSE (NSCR)
           OPEN(NSCR,FILE=FNBM,STATUS='UNKNOWN',
     &     FORM='UNFORMATTED')
           CLOSE(NSCR,STATUS='DELETE')
           ENDIF
*-
  800   CONTINUE
      ENDIF
      RETURN
      END
*-
      REAL*8 FUNCTION DNX (IT,K,X,Y)
*-
* ... FOR SMALL MACHINES REAL*8 NEEDED IN FUNCTION DNX (not for CRAY)
*-
      SAVE
*-
      REAL*8 X,Y
*-
* ... FOR SMALL MACHINES REAL*8 NEEDED FOR X-Y Var (not for CRAY)
* ... FUNCTION TO DETERMINE X-DERIVATIVE OF SHAPE FUNCTION
*-
      IF (IT .EQ. 1) GO TO 500
*-
* ... TRIANGULAR ELEMENT
*-
      GO TO (110,120,130,140,150,160),K
  110 DNX= -3.0E0+4.0E0*X+4.0E0*Y
      RETURN
  120 DNX=4.0E0-8.0E0*X-4.0E0*Y
      RETURN
  130 DNX=4.0E0*X-1.0E0
      RETURN
  140 DNX=4.0E0*Y
      RETURN
  150 DNX=0.0E0
      RETURN
  160 DNX= -4.0E0*Y
      RETURN
*-
* ... QUADRILATERAL ELEMENT
*-
  500 CONTINUE
      GO TO (510,520,530,540,550,560,570,580),K
  510 DNX= -(1.0E0-Y)*(-2.0E0*X-Y)/4.0E0
      RETURN
  520 DNX= -X*(1.0E0-Y)                                                   
      RETURN                                                            
  530 DNX=(1.0E0-Y)*(2.0E0*X-Y)/4.0E0                                      
      RETURN                                                            
  540 DNX=(1.0E0-Y*Y)/2.0E0                                               
      RETURN                                                            
  550 DNX=(1.0E0+Y)*(2.0E0*X+Y)/4.0E0                                      
      RETURN                                                            
  560 DNX= -X*(1.0E0+Y)                                                   
      RETURN                                                            
  570 DNX= -(1.0E0+Y)*(-2.0E0*X+Y)/4.0E0                                    
      RETURN                                                            
  580 DNX= -(1.0E0-Y*Y)/2.0E0                                              
      RETURN
      END
*-
      REAL*8 FUNCTION DNY (IT,K,X,Y)
*-
* ... FOR SMALL MACHINES REAL*8   NEEDED IN FUNCTION DNY (not for CRAY) 
*-
      SAVE
*-
      REAL*8 X,Y
*-
* ... FOR SMALL MACHINES REAL*8 NEEDED FOR X-Y Var (not for CRAY)
* ... FUNCTION TO DETERMINE Y-DERIVATIVE OF SHAPE FUNCTION
*-
      IF (IT .EQ. 1) GO TO 500
*-
* ... TRIANGULAR ELEMENT
*-
      GO TO (110,120,130,140,150,160),K
  110 DNY= -3.0E0+4.0E0*X+4.0E0*Y
      RETURN
  120 DNY= -4.0E0*X
      RETURN
  130 DNY=0.0E0
      RETURN
  140 DNY=4.0E0*X                                                        
      RETURN                                                            
  150 DNY=4.0E0*Y-1.0E0                                                   
      RETURN                                                            
  160 DNY=4.0E0-4.0E0*X-8.0E0*Y
      RETURN
*-
* ... QUADRILATERAL ELEMENT
*-
  500 CONTINUE
      GO TO (510,520,530,540,550,560,570,580),K
  510 DNY= -(1.0E0-X)*(-2.0E0*Y-X)/4.0E0
      RETURN
  520 DNY= -(1.0E0-X*X)/2.0E0
      RETURN
  530 DNY= -(1.0E0+X)*(X-2.0E0*Y)/4.0E0
      RETURN
  540 DNY= -Y*(1.0E0+X)
      RETURN
  550 DNY=(1.0E0+X)*(2.0E0*Y+X)/4.0E0
      RETURN
  560 DNY=(1.0E0-X*X)/2.0E0
      RETURN
  570 DNY=(1.0E0-X)*(2.0E0*Y-X)/4.0E0
      RETURN
  580 DNY= -Y*(1.0E0-X)
      RETURN
      END
*-
      REAL*8 FUNCTION XN2 (IT,K,X,Y)
*-
* ... FOR SMALL MACHINES REAL*8 NEEDED IN FUNCTION XN2 (not for CRAY)
*-
      SAVE
*-
      REAL*8 X,Y
*-
* ... FOR SMALL MACHINES REAL*8 NEEDED FOR X-Y Var (not for CRAY)
* ... FUNCTION TO DEFINE SHAPE FUNCTION VALUES
*-
      IF (IT .EQ. 1) GO TO 500
*-
* ... TRIANGULAR ELEMENT
*-
      GO TO (110,120,130,140,150,160),K
  110 XN2=(1.0E0-2.0E0*X-2.0E0*Y)*(1.0E0-X-Y)
      GO TO 600
  120 XN2=4.0E0*X*(1.0E0-X-Y)
      GO TO 600
  130 XN2=(2.0E0*X-1.0E0)*X
      GO TO 600
  140 XN2=4.0E0*X*Y
      GO TO 600
  150 XN2=(2.0E0*Y-1.0E0)*Y
      GO TO 600
  160 XN2=4.0E0*Y*(1.0E0-X-Y)
      GO TO 600
*-
*     QUADRILATERAL ELEMENT
*-
  500 CONTINUE
      GO TO (510,520,530,540,550,560,570,580),K
  510 XN2=(1.0E0-X)*(1.0E0-Y)*(-X-Y-1.0E0)/4.0E0
      GO TO 600
  520 XN2=(1.0E0-X*X)*(1.0E0-Y)/2.0E0
      GO TO 600
  530 XN2=(1.0E0+X)*(1.0E0-Y)*(X-Y-1.0E0)/4.0E0
      GO TO 600
  540 XN2=(1.0E0+X)*(1.0E0-Y*Y)/2.0E0
      GO TO 600
  550 XN2=(1.0E0+X)*(1.0E0+Y)*(X+Y-1.0E0)/4.0E0
      GO TO 600
  560 XN2=(1.0E0-X*X)*(1.0E0+Y)/2.0E0
      GO TO 600
  570 XN2=(1.0E0-X)*(1.0E0+Y)*(-X+Y-1.0E0)/4.0E0
      GO TO 600
  580 XN2=(1.0E0-X)*(1.0E0-Y*Y)/2.0E0
  600 RETURN
      END
*-
      FUNCTION FMBDN (CO)
*-
      INCLUDE 'hsctm.inc'
      FMBDN=FMBDO+AI*CO
      RETURN
      END
*-
      FUNCTION FTCIN (CO)
*-
      INCLUDE 'hsctm.inc'
      FTCIN=TCINO*3600.0E0+BI*CO
      RETURN
      END
*-
      FUNCTION FBETA (TCT)
*-
      INCLUDE 'hsctm.inc'
      IF (TCT .GE. TCC) TCT=TCC
      FBETA=AQ*(TCT/3600.0E0)**BQ
      RETURN
      END
*-
      FUNCTION FDELTA (TCT)
*-
      INCLUDE 'hsctm.inc'
      IF (TCT .GE. TCC) TCT=TCC
      FDELTA= -EQW*(TCT/3600.0E0)**FQ
      RETURN
      END
*-
      FUNCTION FZHMIN (TCT)
*-
      INCLUDE 'hsctm.inc'
      IF (TCT .GE. TCC) TCT=TCC
      FZHMIN=PQ*(TCT/3600.0E0)**SQQ
      RETURN
      END
