         BLOCK DATA
C        JELESNIANSKI/CHEN     JULY 1988    TDL   FORTRAN 77 VERSION
C
C        PURPOSE
C        DATA INITIALIZATION
C           NONE
C
C        VARIABLES
C       IP(4) JP(4) = SHIFT SUBSCRIPTS T 4 ADJACENT MOMENTUM POINTS
C       IH(4) JH(4) = SHIFT SUBSCRIPTS TO 4 ADJACENT SURGE POINTS ABOUT
C                     A MOMUMTUM POINT
C     IIH(4) JJH(4) = SHIFT SUBSCRIPTS TO 4 ADJACENT SURGE POINTS ABOUT
C                     A SURGE POINT
C            IOPERL = 2  AS DEFAULT IN OPERATIONAL MODE
C         MAPIN(HR) = SPECIFIES THE PRINT HOUR, BEFORE AND AFTER THE
C                     NEAREST APPROACH OF STORM, FOR SNAPSHOT OUTPUT
C                 G = GRAVITY
C                C7 = SLIP COEFFICIENT
C               C17 = AIR DENSITY
C               C19 = FRICTIONAL COEFFICIENT
C               C25 = EDDY VISCOSITY
C         MONTH(12) = ACCUMULATED DAYS AT MONTHLY INCREMENTS
C          AMON(12) = FIRST 3 CHARACTERS FOR EACH MONTH
C
C        GENERAL COMMENTS
C           THIS MEMBER  RESIDES IN THE ROOT OVERLAY
C
      COMMON /DUMB8/  IP(4),JP(4),IH(4),JH(4)
      COMMON /DUM88/  IIH(4),JJH(4),IHH(4),JHH(4)
      COMMON /SWTCH/  IOPERL(5)
      COMMON /DELH11/ MAPIN(10),NUMBER
      COMMON /EGTH/   DELS,DELT,G,COR
      COMMON /THRD/   C7,C17,C19,C25
      COMMON /MTH/    MONTH(12),AMON(12)
      CHARACTER*4     AMON
C
      DATA IP/0,1,1,0/,JP/0,0,1,1/,IH/-1,0,-1,0/,JH/-1,-1,0,0/
      DATA IIH/0,1,0,-1/,JJH/-1,0,1,0/,IHH/-1,1,0,0/,JHH/0,0,-1,1/
      DATA IOPERL/2,2,2,2,2/
      DATA MAPIN/-3,0,2,7*100/
      DATA DELS,G/5280.,32.2/
      DATA C7,C17,C19,C25 / .006 , .00115 , 3.E-6,.25 /
      DATA MONTH /-1,30,58,89,119,150,180,211,242,272,303,333/
      DATA AMON/'JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP',
     1     'OCT','NOV','DEC' /
C       SET DEFAULTS TO NONARCHIVING MODE ( NOARCH='X'). NO TIME HISTRY
C       KHSPT=0.
      COMMON /ARCH/   NOARCH
      COMMON /NFILE/  KNPT,NDATA(3)
      COMMON /CESAV/  IPN(120),IPL(120),KHSPT
      CHARACTER*1     NOARCH
      DATA KNPT/0/,KHSPT/0/,NDATA/13,14,15/,NOARCH/'X'/
C       THIS BLOCK DATA IS TO BE USED FOR LAKE PONTCHARTRAIN
C       BASIN ONLY.
c
      INCLUDE 'parm.for'
C      INCLUDE 'parmmsy.for'
C
      DATA ZSUBCE/-1./,JSUB,JSUB1/38,50/
      DATA LDTMG/5*33,8*35,5*34,
     1 30,29,29,28,27,26,26,24,22,20,21,22,22,21,
     2 68*1,500*1/
      DATA NODRY/74/
      DATA IDRY/21,22,22,23,23,23,23,24,24,24,24,25,25,25,25,26,26,26,
     1          27,27,27,28,28,28,29,29,29,29,30,30,30,30,30,30,31,31,
     2          31,31,28,28,28,28,28,29,29,29,29,30,30,30,30,30,31,31,
     3          31,32,32,32,32,32,32,32,33,33,33,33,33,34,34,34,34,34,
     4          34,34,926*1/
      DATA JDRY/28,28,29,27,28,29,30,27,28,29,30,26,27,28,29,26,27,28,
     1          24,25,26,23,24,25,22,23,24,25,20,21,22,23,24,25,19,20,
     2          25,21,26,27,28,29,30,27,28,29,30,26,27,28,29,30,26,27,
     3          28,23,24,25,26,27,28,29,23,26,27,28,29,20,21,22,23,27,
     4          28,29,926*1/
C
       END
C********************************************************************       
      SUBROUTINE MAINE()
C        JELESNIANSKI/CHEN   AUG 1982  TDL   IBM 360/195
C
C        PURPOSE
C           THIS IS THE MAIN PROGRAM OR ROOT OVERLAY
C           IT CALLs in 4 overlays. the member name is 'main'.
C
C                                 ************
C                                 * ROOT     *
C                                 * OVERLAY  *
C                                 ************
C                                  1  2  3  4
C                   I--------------I  I  I  I---------------I
C                   I             I---I  I-----I            I
C                   I             I            I            I
C              ***********  ***********   ***********  ***********
C              * OVERLAY *  * OVERLAY *   * OVERLAY *  * OVERLAY *
C              * STRMPR  *  * INITLZ  *   * CMPUTE  *  * PLOTS   *
C              ***********  ***********   ***********  ***********
C
C
C        DATA SET USE
C           NONE
C
C        GENERAL COMMENTS
C       THIS CODES ARE USED TOGETHER WITH VSGL0T21.FOR TO GENERATE
C       LOAD MODULE FOR EVACUATION STUDY. VS FORTRAN COMPITBLE.
C       LET (MAIN, PLOTS, CMPUTE) SUPERSEEDS  THOSE IN VSGL0T21.FOR 
C        MAJOR CHANGES-- SURGE HISTRIES AT 10N GRID POINTS
C                        INPUT FORMAT FOR HOURLY PRESS. AND RADIUS
C                        ARCHIVE MAX OF SURGES, MAX WINDS
C --- NOTE ----
C       IF NO ARCHIVE POINTS ARE GIVEN (KHSPT=0), NOARCH TAKES THE 
C       DEFAULT VALUE,'X'. IT IS A NON-ARCHIVE RUN; USING DEFAULT 10
C       POINTS AND TIME HISTRIES IN 10 (15) MIN INTERVALS.
C       IF AS ABOVE, BUT ARCHIVE ENVELOP IS DESIRED, USE ONE BLANK
C       DATA FOR 'ARCHIVE POINTS'. IT WILL OVERWRITE THE DEFAULT VALUE 
C       (X) NOARCH TO ' ', IT MEANS ARCHIEV IS ACTIVE.
C********************************************************************
      INCLUDE 'parm.for'
      COMMON /GEO/  NOGEO
      COMMON /ARCH/   NOARCH
      CHARACTER*1     NOARCH
      COMMON /OPT/  NOPT
      COMMON /KEYS/ KEY1
      COMMON /FLES/ FLE5,FLE9,FLE8,FLE91,FLE99,FLE10,FLE20,FLE30,FLE1
      COMMON /FLE/  FLE92
      INTEGER*2     MYR,MMON,MDAY,MHR,MMIN,MSEC,MI100
      CHARACTER*256 FLE5,FLE9,FLE8,FLE91,FLE99,FLE10,FLE20,FLE30,FLE1
      CHARACTER*30  FLE92
      CHARACTER*40  FLE40
      CHARACTER*1   AA
C
CC      write (*,*) '   This program is compiled with the maximum'
CC      write (*,*) '   dimensions ',M_,N_,L_
c  
CC      WRITE(*,*)'   SLOSH STORM INPUT FILE'
      READ (*,'(A)') FLE5 
CC      WRITE(*,*)'   BASIN FILE *DTA'
      READ (*,'(A)') FLE9 
      KEY1=1
C        ARCHIVE SURGE ENVELOP TO A FILE
CC      WRITE(*,'(A)')' FINAL MAX SURGE WILL BE SAVED IN THE FORM READY '
CC      WRITE(*,'(A)')' TO USE SLOSH FOR GRAPHICAL DISPLAY (IN FT).'
CC      WRITE(*,'(A)')'   SPECIFY THE FILE NAME = '
      READ (*,'(A)') FLE91
C
c      CALL STRMPR
C
      FLE40 = 'FT40'
      CALL INITLZ
      CALL EXTRPT (FLE40)
      CALL CMPUTE
      IF (KEY1.EQ.0) GOTO 1000
C
CC       WRITE(*,*)'   FINISHED SAVING SURGE ENVELOP (FT*10) TO DISK.'
CC       WRITE(*,'(A)') '  FILE NAME = '
CC       WRITE(*,'(A)')  FLE91
CC       WRITE(*,*)'   TIME-HISTRIES data ARE SAVED ON'
CC       WRITE(*,'(A)') FLE10
CC       WRITE(*,'(A)') FLE20
CC       WRITE(*,'(A)')  FLE30
CC       WRITE(*,*) ' RESPECTIVELY FOR SURGE, WIND SPEED, AND WIND DIR.'
CC       WRITE(*,*) '  IN FEET, MPH, METEOR. DIRECTION (DEG.)'
C
 1000 CONTINUE 
c
c       CALL PLOTS1
C
C      CALL GETDAT(MYR,MMON,MDAY)
C      CALL GETTIM(MHR,MMIN,MSEC,MI100)
C
C      WRITE(*,100) MMON,MDAY,MYR,MHR,MMIN,MSEC,MI100
C 100  FORMAT(1H0,'         CALCULATIONS ENDED AT DAY - TIME ',
C    1   2(I2.2,':'),I4.4,'--',2(I2.2,':'),I2.2,'.',I2.2//)
      STOP
      END
       SUBROUTINE EXTRPT (FLE40)
      COMMON /CESAV/  IPN(120),IPL(120),KHSPT
      COMMON /NFILE/  KNPT,NDATA(3)
      COMMON /CESAV1/ STATS(120)
      COMMON /ARCH/   NOARCH
      CHARACTER*16 STATS
      CHARACTER*1  NOARCH
      CHARACTER*40 FLE40
C
CC      write (*,*)'  name of file 40'
C      READ (*,'(A)') FLE40
      OPEN (40,FILE=FLE40)
      READ (40,20,END=55) KNPT,NOARCH
 20   FORMAT(I3,A1)
C
      IF (KNPT.NE.0) THEN
      KHSPT=1+(KNPT-1)/10
      KHSPT1=KHSPT*10
      READ (40,10)(STATS(I),I=1,KHSPT1)
  10  FORMAT(8A10)
      READ (40,15) (IPN(I),IPL(I),I=1,KHSPT1)
  15  FORMAT(10(I3,I3,2X))
      ENDIF
C
  55  CONTINUE
      CLOSE (40)
       RETURN
      END
      SUBROUTINE INTDLT
C        JELESNIANSKI      AUGUST 1980 TDL   IBM 360/195
C
C        PURPOSE
C           THIS SUBROUTINE (INTDLT) ASCERTAINS TIME STEP 'DELT' FOR
C           COMPUTATIONS, INITIALIZES STORM AT SUBSCRIPT 'IBGNT' AND
C           SETS 'ITEND' FOR ENDING COMPUTATIONS AFTER NEAREST STORM
C           APPROACH.
C
C        DATA SET USE
C           NONE
C
C        VARIABLES
C              DELT = TIME INTERVAL FOR EXPLICIT FINITE DIFFERENCING
C              DLTB = THE SMALLEST REDUCTION OF DELT IN THE RUN
C            RLNGTH = DISTANCE OF STORM FROM NEAREST APPROACH
C               JHR = SUBSCRIPT FOR NEAREST APPROACH TO BASIN CENTER
C            P(100) = HOURLY PRESSURE DROPS
C     X(100) Y(100) = HOURLY COMPONENTS FOR STORM POSITIONS
C            R(100) = HOURLY STORM SIZES
C            XMOUTH = X-DISTANCE FROM POLE TO BASIN CENTER
C            YMOUTH = Y-DISTANCE (USUALLY EQUAL TO 0)
C             IBGNT = TABULATED SUBSCRIPT FOR STORM INITIALIZATION
C             ITEND = TABULATED SUBSCRIPT FOR STORM TERMINATION
C              IBGS = NUMBER OF HOURS FOR COMPUTATIONS BEFORE
C                     NEAREST STORM APPROACH
C              ITMS = NUMBER OF REMAINING HOURS, AFTER NEAREST APPROACH,
C          DLTIN(3) = TIME STEPS FOR 3 CATAGORIES OF STORMS FROM DATA
C
C        GENERAL COMMENTS
C           THIS SUBROUTINE LIES IN OVERLAY 'STRMPR'. IT IS CALLED IN
C           BY SUBROUTINE 'STRMPR'.
C
      COMMON /EGTH/   DELS,DELT,G,COR
      COMMON /DLTDTA/ DLTIN(3),DLTB
      COMMON /BSN/    PHI,ALTO,ALNO,PHI1,ALT1,ALN1,ALT1C
      COMMON /SPLN/   ALT(15),ALN(15),AX(15),AY(15),RL(15),ANGD(15),
     1                PT(15),RT(15),XLAT(100),YLONG(100),RLNGTH
      COMMON /STRMPS/ X(100),Y(100),P(100),R(100),DIR(100),SP(100)
C STIME interferes with C code, so switched to STIME2
      COMMON /STIME2/  ISTM,JHR,ITMADV,NHRAD,IBGNT,ITEND
      COMMON /ORIGN/  XMOUTH,YMOUTH
      COMMON /INZSTM/ IBGS,ITMS
      COMMON /OPT/ NOPT
      COMMON /FLES/ FLE5,FLE9,FLE8,FLE91,FLE99,FLE10,FLE20,FLE30,FLE1
      CHARACTER*256 FLE5,FLE9,FLE8,FLE91,FLE99,FLE10,FLE20,FLE30,FLE1
C
C        SET DLTB FOR REDUCTION OF DELT.
      DLTB=DLTIN(2)
C
C        RESET A SMALLER DLTB IF STORM IS STRONG OR STORM IS CLOSE.
      IF(RLNGTH.GT.90.) GO TO 100
      MAXP=AMAX1(P(JHR),P(JHR-3))
      IF (MAXP.GT.60) DLTB=DLTIN(3)
C
  100 CONTINUE
C        SET INITIAL DELT.
      DELT=DLTIN(1)
C
      IF (DELT.GT.500..OR.DELT.LT.5.) GO TO 130
      GO TO 150
 130  CONTINUE
CC      WRITE(*,140) DELT,(DLTIN(I),I=1,3)
 140  FORMAT('  TIME STEP=',F10.3,' IS IMPROPERLY CHOSEN FROM BASIN',
     1' DATA ',3F15.6)
c      STOP
 150  CONTINUE
C
C        SET HOUR FOR STORM INITIALIZATION
C      DO 110 II=1,JHR
C      I=JHR-II+1
C      XZ=X(I)-XMOUTH
C      YZ=Y(I)-YMOUTH
C      DIS=SQRT(XZ*XZ+YZ*YZ)
C      DISCRT=6.*AMAX1(RLNGTH,R(I))
C      IF(DIS.GT.DISCRT) GO TO 120
C  110 CONTINUE
C
C        COMPUTE HOURS OF COMPUTATION BEFORE NEAREST STORM APPROACH
C  120 IBGS=MIN0(MAX0(JHR-I,18),60)
C         SET 12 HOURS OF COMPUTATION, AFTER NEAREST APPROACH
C      ITMS=12
C      IF (NOPT.EQ.1) THEN
C      OPEN (1,FILE=FLE1)
C      READ(1,210,END=200) IBGS,ITMS,JHR1
C      CLOSE (1) 
C 210  FORMAT(2I3,4X,I2)
C      IF(JHR1.NE.0) GO TO 220
C      GO TO 200
C 220  JHR=JHR1
C 200  CONTINUE
C      ENDIF
C        THE ABOVE COMPUTES INITIALIZATION BASED ON TRACK
C        AND SIZE OF THE STORM. 18<=HOURS<=60 BEFORE NEAREST
C        APPROACH ARE ASSUMED.
C        COMPUTE TABULATED SUBSCRIPT FOR STORM INITIALIZATION
C      IBGNT=MAX0(JHR-IBGS,1)
C      ITEND=MIN0(99,JHR+ITMS)
      RETURN
      END
C********************************************************************      
      SUBROUTINE INTVAL
C        JELESNIANSKI    AUGUST 1980   TDL   IBM 360/195
C        PURPOSE
C           THIS SUBROUTINE (INTVAL) SETS INITIAL STORM PARAMETERS,
C           SOME FIXED CONSTANTS FOR INITIALIZATION, AND OUTPUT TIMES.
C********************************************************************
C        DATA SET USE
C           NONE
C
C        VARIABLES
C              DELT = TIME INTERVAL FOR EXPLICIT FINITE DIFFERENCING
C     NDLTHR NDLTH2 = NUMBER OF TIME STEPS IN ONE AND 1/2 HOUR
C            IPRTSV = AT THIS TIME PRINT HISTORICAL SURGES (10 POINTS)
C            IPRTAD = ADVANCE 'IPRTSV' BY 'IPRTAD'
C             IBGNT = SUBSCRIPT FOR STORM INITIALIZATION
C     X(100) Y(100) = HOURLY COMPONENTS FOR STORM POSITIONS
C           SP(100) = HOURLY FORWARD STORM SPEEDS
C          DIR(100) = HOURLY STORM AZIMUTHS
C            R(100) = HOURLY STORM SIZES
C              IBGS = NO OF HRS FOR COMPUTATIONS BEFORE NEAREST APPROACH
C              ITMS = NO OF HRS FOR COMPUTATIONS AFTER NEAREST APPROACH
C             MHALT = number of time steps for total compuations
C             ITEND = TABULATED SUBSCRIPT FOR STORM TERMINATION
C              IC19 = GROWTH TIME TO MATURE STORM
C              ALTO = LATITUDE OF BASIN CENTER
C         MAPIN(10) = PRINT OUT TIME FOR ENVELOPE SNAPSHOT
C            IOPERL = 2 IF IN OPERATIONAL MODE
C            ISTMAP = AT THIS TIME, PRINT A SNAPSHOT OF SURGES
C            NUMBER = NEAREST HOUR TO NEAREST APPROACH
C
C        GENERAL COMMENTS
C           USE ONLY TIME STEPS DIVISIBLE BY 600 S(10 MIN),OR 900 S(
C           15 MIN).
C           THIS SUBROUTINE LIES IN OVERLAY STRMPR. IT IS CALLED IN BY
C           SUBROUTINE STRMPR.
C
      COMMON /EGTH/   DELS,DELT,G,COR
      COMMON /DELTH/  NDLTHR,NDLTH2,DLTHR,DLTH2
      COMMON /FRTH/   IC12,IC19,BT
      COMMON /PRTSV/  IPRTSV,IPRTAD
C STIME interferes with C code, so switched to STIME2
      COMMON /STIME2/  ISTM,JHR,ITMADV,NHRAD,IBGNT,ITEND
      COMMON /STRMPS/ X(100),Y(100),P(100),R(100),DIR(100),SP(100)
      COMMON /INZSTM/ IBGS,ITMS
      COMMON /FFTH/   ITIME,MHALT
      COMMON /BSN/    PHI,ALTO,ALNO,PHI1,ALT1,ALN1,ALT1C
      COMMON /DELH11/ MAPIN(10),NUMBER
      COMMON /SWTCH/  IOPERL(5)
      COMMON /MAPTME/ ISTMAP,IADMAP
C
C        NUMBER OF TIME STEPS IN AN HOUR/HALF-HOUR
      NDLTHR=3600./(DELT-.001)
      NDLTH2=NDLTHR/2
      DLTHR =NDLTHR
      DLTH2 =NDLTH2
C
C        NUMBER OF TIME STEPS BETWEEN TIME-HISTORY PRINT-OUT.
      IPRTAD=NDLTHR/4
      IF(MOD(NDLTHR,6).EQ.0) IPRTAD=NDLTHR/6
      IPRTSV=IPRTAD
C
C
C
C        TOTAL RUN TIME
      T=ITEND-IBGNT
      MHALT=(T*3600.+1.)/DELT
CC      write (*,*)' total hours and time steps',t,mhalt
C
C        PRE-SET STORM GROWTH TO 2 HOURS
      IC19=2*NDLTHR
C
C        COMPUTE STORM GROWTH TIME TO MATURITY
      IF (SP(IBGNT).LT.1.E-5) GO TO 100
C
C        NO OF TIME STEPS FOR STORM TO MOVE 1 DIAMETER IN LENGTH
      IGRWTH=(2.*R(IBGNT)/SP(IBGNT))*DLTHR
      GO TO 110
  100 IGRWTH=4*NDLTHR+4
  110 CONTINUE
      IC19=MAX0(IC19,MIN0(4*NDLTHR+4,IGRWTH))
C
      DO 120 I=1,5
      J=IBGNT+I-1
      IF(ABS(X(J)-1.).LT.(.25*R(IBGNT))) IC19=4*NDLTHR
  120 CONTINUE
C
CC      write (*,*) ' spin-up hours = ',(ic19+1)/ndlthr
C        SET MAPIN(10)  AS SELECTED HOURS, FOR SNAPSHOT OUTPUTS
C      IF(IOPERL(1).NE.2) GO TO 125
C      MAPIN(1)=0
C      DO 122 I=2,10
C 122  MAPIN(I)=200
C 125  CONTINUE
      DO 130 I=1,10
  130 MAPIN(I)=JHR+MAPIN(I)
C
      DO 140 I=1,10
      IF(MAPIN(I).GT.IBGNT+1) GO TO 150
  140 CONTINUE
C
  150 NUMBER=I
C        SET PRINT OUT TIME OF STORM AT NEAREST APPROACH
C        INITIALIZE OUTPUT TIME FOR SNAPSHOT ENVELOPE OF SURGES
      ISTMAP=MAPIN(I)
      RETURN
      END
C********************************************************************      
       SUBROUTINE CNSTNT
C        JELESNIANSKI    SEPTEMBER 1980 TDL   IBM 360/195
C
C        PURPOSE
C           THIS SUBROUTINE (CNSTNT) FIXES SOME PROGRAM CONSTANTS.
C********************************************************************
C        DATA SET USE
C           NONE
C
C        VARIABLES
C            X1(50) = STORED ARRAY OF CONSTANTS
C              DELT = TIME INCRMNT FOR FINITE DIFFRNCNG, SET IN 'INTDLT'
C               COR = CORIOLIS (1/SEC), (SET IN 'INTVAL')
C         IMXB JMXB = NO. OF GRID PTS ALONG A RAY/CIRCLE, IN 'CRDRD1'
C       IMXB1 JMXB1 = IMXB LESS 1, JMXB LESS 1
C       IMXB2 JMXB2 = IMXB LESS 2, JMXB LESS 2
C            DEGREE = ANGLE BETWEEN TWO RAYS, READ IN 'CRDRRD1'
C              DELA = VALUE OF 'DEGREE' IN RADIANS
C               RAD = RADIAN MEASURE
C           X1B(10) = STORED ARRAY OF CONSTANTS
C                 G = GRAVITY = 32.2 FT/SEC-2
C       AMAN->AGB13 = FIXED CONSTANT FOR SUBROUTINE 'CHANNL'
C
C        GENERAL COMMENTS
C           THIS SUBROUTINE IS CALLED BY SUBROUTINES INITLZ AND STMVAL.
C
C      COMMON /SLAT/   FSOUTH
      COMMON /FRST/   X1(50),X12(50)
      COMMON /EGTH/   DELS,DELT,G,COR
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      COMMON /POLAR/  DEGREE,RMOUTH,AZMTH,DELA
      COMMON /GAMAF/  GAMA,GAMA1,GAMFP(4)
      COMMON /DUMB4/  X1B(10)
      COMMON /DUMB4I/ CORL(90)
      COMMON /CHNLNO/ AMAN,BMAN,GB,AGB,AGB13
      X1B(1)=G*DELT/DELA
      X1B(2)=DELT/DELA
C
      X1B(4)=DELT*COR 
      DO 10 L=1,90
      CORL(L)=2.*(7.292116E-5)*SIN((L-1)*1.74532925E-2)/COR
 10   CONTINUE
C     
C        FSOHTH=-1. FOR SOUTHERN HEMISPHERE, NEGATIVE CORIOLIS PARAMETER
C              = 1. FOR NORTHERN HEMISPHERE,
C      X1B(4)=DELT*COR*FSOUTH
C
      X1B(5)=.5*X1B(2)
      X1B(6)=.5*X1B(1)
C        WEIR COEFFICIENT
      X1B(7)=.6*DELT*SQRT(2.*G/3.)/3.
C        SET SMOOTHING CONSTSNTS FOR POLAR COORDINATES
      EXPDLA=EXP(DELA)
      COSHLA=.5*(EXPDLA+1./EXPDLA)
      GAMA =EXPDLA/COSHLA-1.
      GAMA1=-GAMA
      GAMFP(1)=0.
      GAMFP(3)=0.
      GAMFP(2)=GAMA
      GAMFP(4)=GAMA1
C         COMPUTING FIXED CONSTANTS FOR SUBROUTINE 'CHANNL'
      CMAN =1.5/.03
      AMAN =3.*(CMAN**2)/13.
      BMAN =3.*(CMAN**2)/(4.*G)
      GB   =G*BMAN
      AGB  =AMAN-G*BMAN
      AGB13=13.*AGB/3.
      RETURN
       END
C********************************************************************       
      SUBROUTINE BTMSTR(ZLATO)
C        JELESNIANSKI    SEPTEMBER 1980 TDL   IBM 360/195
C
C        PURPOSE
C           THIS SUBROUTINE (BTMSTR) COMPUTES BOTTOM STRESS COEFFCNTS
C           AT 1 FOOT INTERVALS, FROM 1 TO 300 FEET.
C           THE EQUATIONS ARE IN REFERENCE: JELESNIANSKI,
C           "NUMERICAL COMPUTATIONS OF STORM SURGES WITH BOTTOM
C           STRESS", MONTHLY WEATHER REVIEW, VOL 95, NO. 11,
C           NOV 1967, PP 740-756.
C********************************************************************
C        DATA SET USE
C           NONE
C
C        VARIABLES
C             ZLATO = LATITUDE IN DEGREES 
C               COR = CORIOLIS PARAMTER
C                 E = EKMAN PARAMETER, DEPTH*SQRT(COR/2*C25)
C               C25 = EDDY VISCOSITY COEFFICIENT, .25 FT**2/SEC
C                C7 = SLIP COEFFICIENT, .006 FT/SEC
C   AR(300) AI(300) = BOTTOM FRICTION COEFFS FOR CORIOLIS TERMS
C   BR(300) BI(300) = BOTTOM FRICTION COEFFS FOR SFC GRAD TERMS
C   CR(300) CI(300) = BOTTOM FRICTION COEFFS FOR SURFACE STRESS TERMS
C
C        GENERAL COMMENTS
C           THIS MEMBER 'BTMSTR' RESIDES IN OVERLAY 'INITLZ'. IT IS
C           CALLED IN BY SUBROUTINE 'INITLZ'.
C           PROGRAM REWRITTEN (1980), REPLACING SINH BY SIN AND COSH
C           BY COS.
C
C
      COMMON /SCND/ AR(600),AI(600),BR(600),BI(600),CR(600),CI(600)
      COMPLEX*16 SIGMAI,CO1,CO2,CO3,CO4,CO5,CO7,CO17
      COMPLEX*16 CO16,CO10,CP
      REAL*8 E
         DATA C25,C7/.25,.006/
C           CORIOLIS PARAMETER
C      FSOUTH=1.
C      IF (ZLATO.LT.0.) FSOUTH=-1.
      COR=2.*(7.292116E-5)*SIN(ABS(ZLATO)*1.74532925E-2)
CC      PRINT   5
   5  FORMAT(//'  CONSTANTS FOR SLIP CONDITION AT BOTTOM'//
     1'     E       AR       AI       BR         BI       CR       CI
     2        DEPTH')
      NN=1
      NND=1
C
      DO 100 N=1,600
      A=N
      E=A*SQRT(COR/(2.*C25))
      COR1=COR*A/C7
C         
C        FSOHTH=-1. FOR SOUTHERN HEMIS, SIGMA=E*(1-I), I*SIGMA=E+I*E
C              = 1. FOR NORTHERN HEMIS, SIGMA=E*(1+I), I*SIGMA=-E+I*E
C                   
C      SIGMAI=DCMPLX(-E*FSOUTH,E)
      SIGMAI=DCMPLX(-E,E)

C      CO1=CDCOS(SIGMAI)
      CO1=ZCOS(SIGMAI)
C      CO2=SIGMAI/CDSIN(SIGMAI)
      CO2=SIGMAI/ZSIN(SIGMAI)

      CO1=CO1*CO2
C        CO1=SIGMA/TANH(SIGMA) , CO2=SIGMA/SINH(SIGMA)
C        CO1=SIGMAI/TAN(SIGMAI), CO2=SIGMAI/SIN(SIGMAI), SIGMAI=I*SIGMA
      CO3=1./(CO1+CMPLX(-1.,COR1))
C
C      CO3=1./(CO1+CMPLX(-1.,COR1*FSOUTH))
C
      CO4=CO3*CO3
      CO5=CO2*CO2+CO1
      CP=1.-CO2
      CO7=(.5*CO5-1.)*CO4
      CO17=1./(1.+CO7)
      CO16=(1.+CO3)*CO17
      AR(N)=DREAL(CO16)
      AI(N)=DIMAG(CO16)
      BR(N)=DREAL(CO17)
      BI(N)=DIMAG(CO17)
      CO10=(1.+CP*CO3)*CO17
      CR(N)=DREAL(CO10)
      CI(N)=DIMAG(CO10)
C
C  NO WIND STRESS
C
C	CR(N)=0.
C	CI(N)=0.
      IF (N.NE.NN) GOTO 100
      IF (N.GT.10) NND=15
      NN=NN+NND
C      PRINT 120,E,AR(N),AI(N),BR(N),BI(N),CR(N),CI(N),N
 120  FORMAT(F6.2,6F10.5,I10)
  100 CONTINUE
      RETURN
       END
C********************************************************************       
      SUBROUTINE SETCMP
C        JELESNIANSKI    SEPTEMBER 1980 TDL   IBM 360/195
C
C        PURPOSE
C           THIS SUBROUTINE (SETCMP) SETS UP THE FIRST HOURLY
C           METEOROLOGICAL AND TRACK DATA FOR COMPUTTATIONS. IT ALSO
C           SETS CHANGES IN DATA FOR THE FIRST INCREMENTAL TIME STEP.
C********************************************************************
C        DATA SET USE
C
C        VARIABLES
C             ITIME = NUMBER OF TIME STEPS; INITIALIZED TO ZERO
C            NDLTHR = NUMBER OF TIME STEPS IN ONE HOUR
C             HHRAD = ACCUMULATIVE TIME STEPS ON THE HOUR
C             IBGNT = TABULATED SUBSCRIPT FOR STORM INITIALIZATION
C           PT(100) = HOURLY PRESSURE HROPS
C             PDROP = DUMMY VALUE FOR 1ST HOUR PRESSURE DROP
C       YDELP ZDELP = PRESSURE DROP AT PRESENT  TIME STEP
C                PN = PRESS DROP AT PRESENTS TIME
C               PNN = PRESS DROP AT PREVIOUS TIME
C            R(100) = HOURLY STORM SIZES
C              YC24 = STORM SIZE AT PRESENT  TIME STEP
C              ZC24 = STORM SIZE AT PREVIOUS TIME STEP
C               C21 = DUMMY VALUE FOR SPEED OF STORM IN MPH, 1ST HOUR
C                     C21 INITIALLY SET IN 'INTVAL'
C            X12(7) = SPEED OF STORM IN FT/SEC, 1ST HOUR
C   X12(20) X12(21) = DIRCTNS OF STRM MOTION FOR 1ST HR, SET IN 'INTVAL'
C    X12(9) X12(10) = COMPONENTS OF FORWARD SPEED, 1ST HOUR
C              DELT = UNIT TIME STEP
C   X12(11) X12(12) = COMPONENTS OF STRM MOTION UNIT TIME STEP, 1ST HOUR
C               C22 = DRCTN OF STORM MOTION, 1ST HR, SET IN 'INTVAL'
C           X12(17) = FRIC CFFCNT (3X10-6) TIMES SQUARE OF STRM SIZE
C   X12(23) X12(24) = COMPONENTS OF WIND DISTORTN (LAKE WINDS), 1ST HR
C            PTENCY = CHNG IN PRESSURE DROP FOR 1ST HOUR
C            RTENCY = CHNG IN STORM SIZE    FOR 1ST HOUR
C            ITMADV = COUNTER FOR HOURLY TIME, 1ST HOUR
C             AX AY = COMPONENTS OF TOTAL STORM TRAVERSE WITH TIME
C           WMAX(2) = MAX WIND SPEED OVER INLAND WATER BODIES OR OCEAN
C          W1218(2) = TWICE THE MAXIMUM WINDS (LAKE OR OCEAN)
C     C(800) S(800) = COS/SIN OF INFLOW ANGLE, MILE INTERVALS FROM
C                     STORM CENTER (SEA WINDS), COMPUTED IN 'FORCE1'
C   CW(800) SW(800) = COS/SIN INFLOW ANGLE (LAKE WINDS), FROM 'FORCE1'
C
C        GENERAL COMMENTS
C           THIS SUBROUTINE RESIDES IN OVERLAY 'CMPUTE'. IT IS CALLED
C            IN ONLY ONCE BY SUBROUTINE 'CMPUTE'. IT CALLS IN 2
C            SUBROUTINES, 'FORCE1' AND 'INTLHT'.
C
C      COMMON /SLAT/   FSOUTH
      COMMON /FFTH/   ITIME,MHALT
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      COMMON /DELTH/  NDLTHR,NDLTH2,DLTHR,DLTH2
C STIME interferes with C code, so switched to STIME2
      COMMON /STIME2/  ISTM,JHR,ITMADV,NHRAD,IBGNT,ITEND
      COMMON /STRMPS/ X(100),Y(100),PT(100),R(100),DIR(100),SP(100)
      COMMON /SPLN/   ALT(15),ALN(15),DUMX(15),DUMY(15),RL(15),ANGD(15),
     1                PDUM(15),RDUM(15),XLAT(100),YLONG(100),RLNGTH
      COMMON /FRST/   X1(50),X12(50)
      COMMON /EGTH/   DELS,DELT,G,COR
      COMMON /TMEREL/ TREAL
      COMMON /BSN/    PHI,ALTO,ALNO,PHI1,ALT1,ALN1,ALT1C
      COMMON /ZLATO/  ZLATO
      COMMON /THRD/   C7,C17,C19,C25
      COMMON /STRMSB/ C1,C2,C21,C22,AX,AY,PTENCY,RTENCY
      COMMON /WTEMP/  YDELP,ZDELP,PNN,YC24,ZC24
      COMMON /DUMY44/ SW(800),CW(800),W1218(2),WMAX(2)
      COMMON /DUMMY4/ S(800),C(800),P(800),DELP(800)
C
C     CHARACTER*40    FILNAM
      CHARACTER*80    DUM
C
C         SET START TIME TO 0
C         NUMBER OF UNIT TIME STEPS FOR THE 1ST HOUR
      ITIME=0
C        REAL TIME IN SECCONDS                     
      TREAL=0.
      NHRAD=NDLTHR
C
C        PREPARATORY VALUES TO UPDATE STORM FOR EACH MB CHANGE
C        IN PRESSURE DROP, AND FOR EACH MILE CHANGE IN STORM SIZE
C        INITIALIZE (X,Y) STORM POSITION, STORM SPEED AND DIRECTION,
C        STORM SIZE, PRESSURE DROP
      AX=0.
      AY=0.
      C1=X(IBGNT)*5280.
      C2=Y(IBGNT)*5280.
      X12(49)=C1
      X12(50)=C2
      ZLATO=XLAT(IBGNT)
      C21=SP(IBGNT)
      C22=DIR(IBGNT)
C
      PDROP=PT(IBGNT)
      YDELP=PT(IBGNT)
      ZDELP=PT(IBGNT)
      YC24=R(IBGNT)
      ZC24=R(IBGNT)
      X12(20)=COS(C22)
      X12(21)=SIN(C22)
C
C        1ST HR SPEED OF STORM IN FT/SEC
      X12(7)=C21*44./30.
C
C        IST HR COMPONENT SPEED OF STORM IN FT/SEC
      X12(9) =X12(7)*X12(20)
      X12(10)=X12(7)*X12(21)
C
C        1ST HR COMPONENT MOVEMENT OF STORM FOR 1 TIME INTERVAL
      X12(11)=DELT*X12(9)
      X12(12)=DELT*X12(10)
C
      X12(23)=X12(7)*COS(C22+2.*3.14159265358979/3.)
      X12(24)=X12(7)*SIN(C22+2.*3.14159265358979/3.)
C        COMPUTE WIND DISTORTION COEFFICIENT FOR LAKE WINDS, 1ST HR
C        DISTORTION IS A FUNCTION OF STORM'S FORWARD SPEED
C
C        FSOHTH=-1. FOR SOUTHERN HEMISPHERE, CLOCKWISE CIRCLULATION;
C              = 1. FOR NORTHERN HEMISPHERE, COUNTER-CLOCKWISE CIRCULATION.
C      X12(23)=X12(7)*COS(C22+FSOUTH*2.*3.14159265358979/3.)
C      X12(24)=X12(7)*SIN(C22+FSOUTH*2.*3.14159265358979/3.)
C
C         INCREMENTAL CHANGE, PER TIME STEP, FOR PRESSURE DROP
C         AND STORM SIZE
      PTENCY=(PT(IBGNT+1)-PT(IBGNT))/NDLTHR
      RTENCY=(R(IBGNT+1)-R(IBGNT))/NDLTHR
C
C        ADVANCE 1ST HOUR SUBSCRIPT
      ITMADV=IBGNT+1
C
C         X/Y-COMP OF STORM TRAVERSE FOR FIRST UNIT OF TIME
C         RECORD STORM POSITIONS AT ANY TIME IN (X,Y) PLANE (FT)
      AX=AX+X12(11)
      AY=AY+X12(12)
      X12(49)=C1+AX
      X12(50)=C2+AY
C
C         UPDATED PRESS DROP, AND STORM SIZE, FOR UNIT TIME INTERVAL
C         UPDATED PRESS DROP, AND STORM SIZE, FOR UNIT TIME INTERVAL
      YDELP=YDELP+PTENCY
      YC24 =YC24 +RTENCY
      PN=YDELP
      PNN=PN
C
C         1ST HR OR FIRST UNIT OF TIME FOR APPROX OF MAX WINDS
C         HYDROSTATIC PRESSURE P(I) WILL BE USED FOR OPEN OCEAN.
      IPRT=0
C         OBTAIN INITIAL GUESS OF MAX WIND FROM PRESSURE
C         NCATG=1  FOR LAKE WINDS, =2 FOR OCEAN.
      CALL INTWND(YDELP,YC24,ZLATO,VMAX)
CC      write (*,*) ' ydelp yc24 alto vmax',YDELP,YC24,ALTO,VMAX
      WMAX(2)=VMAX
      WMAX(1)=VMAX*.85
      DO 120 NCATG=1,2
      VMAX=WMAX(NCATG)
      CALL FORCE1(YDELP,YC24,VMAX,ZLATO,NCATG,IPRT)
C         SAVE VMAX'S FOR LAKE/OCEAN FOR NEXT INITIAL GUESSES
      WMAX(NCATG)=VMAX
C      TWICE MAX WINDS IN FT/SEC
      W1218(NCATG)=2.*VMAX*44./30.
      IF (NCATG.EQ.1) THEN
      DO 110 I=1,800
      SW(I)=S(I)
 110  CW(I)=C(I)
      ENDIF
 120  CONTINUE
C      R IN FEET
      X12(4) =YC24*5280.
      X12(15)=X12(4)*X12(4)
      X12(17)=C19*X12(15)
      RETURN
       END
C********************************************************************       
      SUBROUTINE STMVAL
C        JELESNIANSKI   SEPTEMBER 1980 TDL   IBM 360/195
C
C        PURPOSE
C           THIS SUBROUTINE (STMVAL) TESTS FOR INCREMENTAL HOURS AND
C           SETS HOURLY TRACK AND METEOROLOGY VALUES. IT TESTS FOR 1-MB
C           CHANGE IN PRESSURE DROP, OR 1 MILE CHANGE IN STORM SIZE,
C           FOR EACH ADVANCE IN TIME. PREPARATORY VALUES ARE SET FOR
C           LATER ADVANCING IN TIME.
C********************************************************************
C        DATA SET USE
C           NONE
C
C        VARIABLES
C             ITIME = CUMULATIVE TIME COUNTER
C                N1 =  TIME STEPS AT HRLY INTERVALS, SET IN 'SETCMP'
C            NDLTHR = NUMBER OF TIME STEPS IN ONE HOUR
C            ITMADV = COUNTER FOR HOURLY TIME, SET IN 'SETCMP'
C               C22 = DUMMY VALUE FOR HOURLY DIRECTION OF STORM MOTION
C          DIR(100) = HOURLY DIRECTION OF STORM MOVEMENT
C   X12(20) X12(21) = DIRECTIONS OF STRM MOTION , HOURLY VALUE
C           SP(100) = HOURLY FORWARD SPEED OF STORM
C               C21 = DUMMY VALUE FOR STORM'S HOURLY FORWARD SPEED
C            X12(7) = SPEED OF STORM IN FT/SEC, HOURLY VALUES
C    X12(9) X12(10) = COMPONENTS OF FORWARD STORM SPEED
C              DELT = UNIT TIME STEP
C   X12(11) X12(12) = STORM MOVEMENT IN X/Y-DIR FOR UNIT TIME STEP
C           X12(17) = FRIC CFFCNT (3X10-6) TIMES SQUARE OF STRM SIZE
C           PT(100) = HOURLY PRESSURE HROPS
C            R(100) = HOURLY STORM SIZES
C            PTENCY = CHANGE IN PRESSURE DROP FOR ONE HOUR
C            RTENCY = CHANGE IN STORM SIZE    FOR ONE HOUR
C              YC24 = STORM SIZE FOR PRESENT TIME
C             YDELP = PRESSURE DROP FOR PRESENT TIME
C             AX AY = COMPONENTS OF TOTAL STORM TRAVERSE WITH TIME
C             ZDELP = PRESSURE DROP AT PREVIOUS MB. STEP
C                PN = INTEGER VALUE OF PRESS DROP AT PRESENT TIME
C               PNN = INTEGER VALUE OF PRESS DROP AT PREVIOUS TIME
C           WMAX(2) = MAX WIND SPEED OVER INLAND WATER BODIES OR OCEAN
C             IGBNT = SUBSCRIPT FOR STORM INITIALIZATION
C               JHR = SUBSCRIPT FOR NEAREST STORM APPROACH
C              ZC24 = STORM SIZE AT PREVIOUS MILE STEP
C              VMAX = DUMMY VALUE FOR MAXIMUM WINDS
C          W1218(2) = TWICE THE MAXIMUM WINDS (LAKE OR OCEAN)
C     C(800) S(800) = COSINE-SINE OF INFLOW ANGLE, MILE INTERVALS FROM
C                     STORM CENTER (SEA WINDS)
C   CW(800) SW(800) = COSINE-SINE OF INFLOW ANGLE (LAKE WINDS)
C  ISTMAP MAPIN(10) = PRINT OUT TIME FOR SNAPSHOTS, SET IN 'BLCKDT'
C                     AND RECONDITIONED IN 'INTVAL'
C            NUMBER = SUBSCRIPT FOR PRINT-OUT OF ABOVE, SET IN 'INTVAL'
C             IPRHR = 1,WHEN ON THE HOUR; 2, WHEN HALF HOUR IN BETWEEN;
C                     3, OTHERWISE
C            IPRTSV = TIME TO SAVE HISTRCL SURGES, 10 PTS, SET 'INTVAL'
C            IPRTAD = UPDATE TIME OF IPRTSV, SET IN 'INTVAL'
C            IOPERL = 2 IF IN OPERATIONAL MODE
C
C        GENERAL COMMENTS
C           THIS SUBROUTINE RESIDES IN OVERLAY 'CMPUTE'. IT IS CALLED
C           IN BY SUBROUTINE 'CMPUTE'.
C
C      COMMON /SLAT/   FSOUTH
      COMMON /KEYS/   KEY1
      COMMON /FFTH/   ITIME,MHALT
      COMMON /WTEMP/  YDELP,ZDELP,PNN,YC24,ZC24
      COMMON /BSN/    PHI,ALTO,ALNO,PHI1,ALT1,ALN1,ALT1C
      COMMON /ZLATO/  ZLATO
      COMMON /DELTH/  NDLTHR,NDLTH2,DLTHR,DLTH2
      COMMON /FRST/   X1(50),X12(50)
      COMMON /EGTH/   DELS,DELT,G,COR
      COMMON /THRD/   C7,C17,C19,C25
      COMMON /STRMSB/ C1,C2,C21,C22,AX,AY,PTENCY,RTENCY
      COMMON /STRMPS/ X(100),Y(100),PT(100),R(100),DIR(100),SP(100)
      COMMON /SPLN/   ALT(15),ALN(15),DUMX(15),DUMY(15),RL(15),ANGD(15),
     1                PDUM(15),RDUM(15),XLAT(100),YLONG(100),RLNGTH
C STIME interferes with C code, so switched to STIME2
      COMMON /STIME2/  ISTM,JHR,ITMADV,NHRAD,IBGNT,ITEND
      COMMON /TMEREL/ TREAL
      COMMON /PRHSY/  IPRHR,JUMPR,IPRT
      COMMON /DUMY44/ SW(800),CW(800),W1218(2),WMAX(2)
      COMMON /DUMMY4/ S(800),C(800),P(800),DELP(800)
      COMMON /MAPTME/ ISTMAP,IADMAP
      COMMON /DELH11/ MAPIN(10),NUMBER
      COMMON /PRTSV/  IPRTSV,IPRTAD
      COMMON /DLTDTA/ DLTIN(3),DLTB
      COMMON /SWTCH/  IOPERL(5)
C
C
C        TEST FOR INCREMENTAL HOURLY CHANGES IN STORM TRACK
      IF(ITIME.NE.NHRAD) GO TO 100
C        PRINTOUT SELECTED HOURS FOR SNAPSHOT SURGES
      IF (ITMADV.NE.MAPIN(NUMBER)) GO TO 20
      CALL SNAPSH
      NUMBER=NUMBER+1
  20  CONTINUE
C
C        TEST TO REDUCE DELT BEFORE NEREST APPROACH
C        FOR WEAK STORM,THERE IS NO CHANGE OF DELT.
C        FOR MEDIUM AND STRONG STORMS, REDDUCE DELT ONE STEP 3 HR BEFORE
C        THE NEAREST APPROACH.
C        FOR STRONG STORMS,REDUCE DELT FURTHER AT NEAREST APPROACH.
C        RETURN TO INTERMEDIATE TIME STEP 3 HR AFTER NEAREST APPROACH.
      IF (DLTB.EQ.DLTIN(1)) GO TO 300
      IF(ITMADV.NE.JHR-6) GO TO 143
      DELT1 =DLTIN(2)
      GO TO 144
 143  IF(ITMADV.NE.JHR) GO TO 300
      IF (DLTB.EQ.DLTIN(2)) GO TO 300
      DELT1=DLTIN(3)
 144  CONTINUE
C
C        RECOMPUTE THE PARAMETERS DEPENDING ON TIME STEP AS DELT CHANGED
      MHALT=ITIME+(MHALT-ITIME)*DELT/DELT1 + .01
      DELT=DELT1
      NDLTHR=3600./(DELT-.001)
      IPRTSV=IPRTSV-IPRTAD
      IPRTAD=NDLTHR/4
      IF(MOD(NDLTHR,6).EQ.0) IPRTAD=NDLTHR/6
      IPRTSV=IPRTSV+IPRTAD
CC      WRITE(*,55)DELT,ITIME
 55   FORMAT('  DELT NOW CHANGED TO ',F10.1,' AT TIME STEP',I8)
      CALL CNSDLT
 300  CONTINUE
C
      NHRAD=NHRAD+NDLTHR
      ZLATO=XLAT(ITMADV)
      C22=DIR(ITMADV)
      X12(20)=COS(C22)
      X12(21)=SIN(C22)
C
C        SPEED OF STORM IN FT/SEC
      C21=SP(ITMADV)
      X12(7) =C21*44./30.
C
C        COMPONENT SPEED OF STORM IN FT/SEC
      X12(9) =X12(7)*X12(20)
      X12(10)=X12(7)*X12(21)
C
C        COMP MOVEMENT OF STORM, FOR 1 TIME INTERVAL, DURING 1 HR INTERV
      X12(11)=DELT*X12(9)
      X12(12)=DELT*X12(10)
C
C        COMPUTE WIND DISTORTION COEFFICIENT FOR LAKE WINDS
C        DISTORTION IS A FUNCTION OF STORM'S FORWARD SPEED
      X12(23)=X12(7)*COS(C22+2.*3.14159265358979/3.)
      X12(24)=X12(7)*SIN(C22+2.*3.14159265358979/3.)
C
C        FSOHTH=-1. FOR SOUTHERN HEMISPHERE, CLOCKWISE CIRCLULATION;
C              = 1. FOR NORTHERN HEMISPHERE, COUNTER-CLOCKWISE CIRCULATION.
C      X12(23)=X12(7)*COS(C22+FSOUTH*2.*3.14159265358979/3.)
C      X12(24)=X12(7)*SIN(C22+FSOUTH*2.*3.14159265358979/3.)
      RTENCY=(R(ITMADV+1)-R(ITMADV))/NDLTHR
      PTENCY=(PT(ITMADV+1)-PT(ITMADV))/NDLTHR
      YC24 =R(ITMADV)
      YDELP=PT(ITMADV)
C
C     ADVANCE HOUR COUNT BY ONE FOR NEXT HOUR
      ITMADV=ITMADV+1
C
C        TEST FOR INCREMENTAL UNIT TIME CHANGES IN TRACK AND METEOROLOGY
C        X/Y-COMPONENT OF TOTAL STORM TRAVERSE WITH ADVANCING TIME
 100  AX=AX+X12(11)
      AY=AY+X12(12)
C
      TREAL=TREAL+DELT
C         UPDATED PRESSURE DROP, AND STORM SIZE, FOR UNIT TIME INTERVAL
      YDELP=YDELP+PTENCY
      YC24=YC24+RTENCY
C
C        JUMPR=2, CALCULATE A STORM FOR PRINTING OUT PROFILES.
C        NO STORM PRINTOUT UNLESS AT NEAREST APPROACH OR LANDFALL.
      IF(JUMPR.GE.2) GO TO 250
      IF (ITMADV.EQ.JHR+1) GO TO 200
      GO TO 250
 200  JUMPR=2
      IPRT=1
C       REDUCE PRINTOUT IF IN OPERATIONAL MODE.
      IF(IOPERL(1).EQ.2) JUMPR=3
      GO TO 110
 250  CONTINUE
C
C          CHECK IF STORM HAS CHANGED BY 1-MB, OR SIZE BY 1 MILE,
C          AS TIME ADVANCES; IF SO, APPROXIMATE MAX WIND
C          FOR INPUT TO CREATE A NEW STORM
      if (key1.eq.0) goto 170
      IF(ABS(YDELP-ZDELP).GE.1.) GO TO 110
 120  IF(ABS(YC24-ZC24) .LT.1.) GO TO 170
 110  NP=YDELP*10.+.5
      PN=NP/10.
      CZ=SQRT(PN/PNN)
C
C        ENTERING WINDS FOR SUBROUTINE FORCE1
C        NCATG=1 FOR LAKE WINDS,   =2 FOR OCEAN WINDS
 130  DO 160 NCATG=1,2
      VMAX=WMAX(NCATG)*CZ
      IF (KEY1.NE.0) CALL FORCE1(PN,YC24,VMAX,ZLATO,NCATG,IPRT)
      WMAX(NCATG)=VMAX
      W1218(NCATG)=2.*VMAX*44./30.
C
      IF (NCATG.EQ.1) THEN
      DO 150 I=1,800
      SW(I)=S(I)
 150  CW(I)=C(I)
      ENDIF
 160  CONTINUE
C
      PNN=PN
      ZDELP=YDELP
      ZC24=YC24
C       PRINT OUT STORM PROFILES ONCE AT NEAREST APPROACH TIME
c      IF(IPRT.EQ.1) IPRT=0
C      R IN FEET
      X12(4) =YC24*5280.
      X12(15)=X12(4)*X12(4)
      X12(17)=C19*X12(15)
C
C      NO UPDATING STORM
 170  CONTINUE
      RETURN
       END
C********************************************************************       
      SUBROUTINE CNSDLT
C        J   CHEN  AUG 1982   IBM  360/195
C
C        PURPOSE
C           THIS SUBROUTINE (CNSDLT) FIXES COEFFICIENTS DEPENDING ON
C           TIME STEP FOR VARIATIONS IN THE COURSE OF COMPUTATION..
C********************************************************************
C        DATA SET USE
C           NONE
C
C        VARIABLES
C            X1(50) = STORED ARRAY OF CONSTANTS
C              DELT = TIME INCRMNT FOR FINITE DIFFRNCNG, SET IN 'INTDLT'
C               COR = CORIOLIS (1/SEC), (SET IN 'INTVAL')
C            DEGREE = ANGLE BETWEEN TWO RAYS, READ IN 'CRDRD1'
C              DELA = VALUE OF 'DEGREE' IN RADIANS
C               RAD = RADIAN MEASURE
C           X1B(10) = STORED ARRAY OF CONSTANTS
C                 G = GRAVITY = 32.2 FT/SEC-2
C
C        GENERAL COMMENTS
C           THIS SUBROUTINE IS CALLED BY SUBROUTINES INITLZ AND STMVAL.
C
C      COMMON /SLAT/   FSOUTH
      COMMON /EGTH/   DELS,DELT,G,COR
      COMMON /FRST/   X1(50),X12(50)
      COMMON /POLAR/  DEGREE,RMOUTH,AZMTH,DELA
      COMMON /DUMB4/  X1B(10)
C
      X1B(1)=G*DELT/DELA
      X1B(2)=DELT/DELA
c
      X1B(4)=DELT*COR
C     
C        FSOHTH=-1. FOR SOUTHERN HEMISPHERE, NEGATIVE CORIOLIS PARAMETER
C              = 1. FOR NORTHERN HEMISPHERE,
c
C      X1B(4)=DELT*COR*FSOUTH
C
      X1B(5)=.5*X1B(2)
      X1B(6)=.5*X1B(1)
C        WEIR COEFFICIENT
      X1B(7)=.6*DELT*SQRT(2.*G/3.)/3.
      RETURN
       END
        SUBROUTINE FORCE1(PDROP,RMAX,VMAX,ALTO,NCATG,IPRT)
C        JELESNIANSKI    SEPTEMBER 1980TDL   IBM 360/195
C
C        PURPOSE
C           THIS SUBROUTINE (FORCE1) COMPUTES, AT MILE INTERVALS FROM
C           THE STORM CENTER, FOR 800 MILES,
C                (1) SINE   OF THE INFLOW ANGLE
C                (2) COSINE OF THE INFLOW ANGLE
C                (3) SURFACE PRESSURE
C                (4) STATIC HEIGHT
C           REFERENCE FOR THE ALGORITHM AND THEORY IS:
C           JELESNIANSKI  AND TAYLOR, 1973, A PRELIMINARY
C           VIEW OF STORM SURGES BEFORE AND AFTER STORM
C           MODIFICATIONS, NOAA TECHNICAL MEMORANDUM
C           ERL WMPO-3, WEATHER MODIFICATION PROGRAM OFFICE,
C           ERL, NOAA, U.S. DEPARTMNET OF COMMERCE, WASHINGTON,
C           D.C., MAY, 33 PP.
C
C        DATA SET USE
C           NONE
C
C        VARIABLES
C             PDROP = INPUT PRESSURE DROP
C              RMAX = DUMMY VALUE FOR STORM SIZE
C              VMAX = DUMMY VALUE FOR MAXIMUM WINDS
C              ALTO = LATITUDE OF BASIN MOUTH POINT
C              IPRT = 1 TO PRINT OUT STORM PROFILE,OTERWISE =0.
C           XKS XKN = WIND FRICTION VALUES
C             CFRIC = FRCTN FACT, =1. IN OCEAN, =4*SQRT(22/RMAX)
C              JSET = DISTANCE BEYOND WHICH APPROX. BY
C                     CONSTANT INFLOW ANGLES
C               COR = CORIOLIS (1/SEC)
C     C(800) S(800) = COS/SIN OF INFLOW ANGLE, MILE INTERVALS
C         DELP(800) = STATIC HEIGHTS, MILE INTERVALS
C            P(800) = PRESSURE GRADIENT, MILE INTERVALS
C              RHOA = AIR DENSITY (MB HR**2 MILE**-2)
C              RHOW = WATER DENSITY (MB SEC**2 FT**-1 MILE**-1)
C             RHOWG = WATER DENSITY*GRAVITY (MB FT**-1)
C              PADD = PRESSURE FROM A RADIUS TO INFINITY
C             PINFT = PRESSURE DROP FROM ITERATION
C
C        GENERAL COMMENTS
C           THIS SUBROUTINE RESIDE IN OVERLAY 'CMPUTE'. IT IS CALLED IN
C           BY TWO SUBROUTINES, 'SETCMP' AND 'STMVAL'. SUBROUTINE
C           'FORCE1' CALLS IN SUBROUTINE 'PRTSTM'.
C
      COMMON /DUMMY4/ S(800),C(800),P(800),DELP(800)
C
      DATA RHOA/2.298E-3/,RHOW/4905./,RHOWG/29.89/
      DATA EPSLN /1.E-5/,IC12/795/
C
C         5 FUNCTIONAL FORMS FOLLOW
      VEE(R)     =2.*VMAX*RMAX*R/(RMAX**2+R**2)
      DERLNV(R)  =1./R-2.*R/(RMAX**2+R**2)
      PRGRAD(R,V)=RHOA*V*V*(XKS/SINPHI-DERLNV(R))
      PYTHAG(X)  =SQRT(1.-X*X)
      JSET       =MIN0(IC12-51,MAX0(150,INT(12.*RMAX)))
C
      COR=2.*(7.292116E-5)*SIN(ABS(ALTO)*1.74532925E-2)
      CORHR=3600.*COR
      CFRIC=1.
C        LAKE WINDS FRICTION WAS CALIBRATED BY MEASUREMENTS OF
C        STORM 1949, OVER LAKE OKEECHOBEE. RMAX=22.
      IF (NCATG.EQ.1) CFRIC=4.*SQRT(22./RMAX)
C
C         BEGIN ITERATION ALGORITHM
  100 CONTINUE
C
C         FORM 2 FRICTION VALUES FOR A STORM: COMPUTE FOR 2 STORMS
      XKS=.01*SQRT(RMAX/(.3*VMAX+60.))
      XKN=.01*SQRT(RMAX/(.4*VMAX+80.))
      XKS=XKS*CFRIC
      XKN=XKN*CFRIC
C         SET RANGES RELATIVE TO STORM CENTER, SCALED TO STORM SIZE
      J2=MIN1(3.*RMAX,50.)
      R0=JSET+50
      MMAX=JSET+9*J2+49
      DELR=1.
      VEER0=VEE(R0)*R0
      COTPHI=(CORHR*R0/VEER0+XKN)/XKS
      SINPHI=1./SQRT(1.+COTPHI*COTPHI)
      COSPHI=PYTHAG(SINPHI)
      OSINFI=1./SINPHI
      W0=VEER0*COSPHI
C        DWDR=0. WITH THIS INITIAL CONDITION
      PRESS=0.
      DPDR0=PRGRAD(R0,VEER0/R0)
C
C        RUNGE-KUTTA-HEUN-TAYLOR METHOD TO SOLVE THE EQUATION
C        DWDR=W*XKS/SIN(PHI)-CORHR*R-XKN*V*R=G(W,R) WHERE W=V*R*COS(PHI)
      DO 160 I=1,MMAX
      FACT=2./DELR
      SLP0=W0*XKS/SINPHI-CORHR*R0-XKN*VEER0
      R1=R0-DELR
      VEER1=VEE(R1)*R1
      W1=VEER1*COSPHI
C
C        NEWTON-RAPHSON METHOD TO FIND W1 SO THAT
C        .5*(G(W1,R1)+G(W0,R0))=(W0-W1)/(R0-R1)
      DO 120 KK=1,75
      SLP1=W1*XKS/SINPHI-CORHR*R1-XKN*VEER1
      PADD=FACT*(W0-W1)-SLP0
      DGDW=XKS/(SINPHI*SINPHI*SINPHI)
      DELW=(SLP1-PADD)/(DGDW+FACT)
      DOSINF=-DELW*COSPHI/VEER1/SINPHI/SINPHI/SINPHI
      OSINFI=OSINFI+DOSINF
      SINPHI=1./OSINFI
         COS1=COSPHI
      COSPHI=PYTHAG(SINPHI)
      W1=VEER1*COSPHI
      IF(W1) 180,180,110
  110 IF(ABS((COS1-COSPHI)/COS1)-EPSLN) 140,140,120
  120 CONTINUE
C
CC      WRITE(*,130)
  130 FORMAT('0INSUFFICIENT STEPS IN NEWTON-RAPHSON LOOP')
      STOP 999
  140 R0=R1
      K=R1+1.01
      VEER0=VEER1
      W0=W1
      S(K)=SINPHI
      C(K)=COSPHI
      DPDR1=PRGRAD(R1,VEER1/R1)
      P(K)=DPDR1
      PRESS=PRESS-(DPDR0+DPDR1)/FACT
      DELP(K)=PRESS
      DPDR0=DPDR1
       IF(K-J2-1) 150,150,160
  150 DELR=.1
  160 CONTINUE
C
      DELP(1)=PRESS-DPDR0/FACT
      P(1)=0.
      S(1)=0.
      C(1)=1.
      R0=JSET-1
      TERM=R0/(RMAX*RMAX+R0*R0)
      PADD=2.*RHOA*((VMAX*RMAX)**2)*(XKS*(ATAN(RMAX/R0)/RMAX+TERM)/
     1 S(JSET)+TERM*TERM)
C
C        PADD = PRESSURE IN MB FROM R0=JSET-1 TO R0=INFINITY, ASSUMING
C   SINPHI=S(JSET)=CONST. FROM R=JSET-1 TO INFINITY
      PINFT=PADD+DELP(JSET)-DELP(1)
C   PINFT= PRESSURE DROP IN MB FROM R=0 TO INFINITY,
C   THEN ON THIS ASSUMPTION
      PRS=PDROP
      IF (ABS(PINFT-PRS)-.2) 200,200,170
  170 VMAX=VMAX*SQRT(PRS/PINFT)
      GO TO 100
C
  180 CONTINUE
CC      WRITE(*,190)
  190 FORMAT('0COS(PHI).LT.0.')
      STOP
C
  200 SINPHI=S(JSET-1)
      COSPHI=C(JSET-1)
      JSTP1=JSET+1
C
      DO 210 K=JSTP1,IC12
      R0=K+1
      S(K)=SINPHI
      C(K)=COSPHI
      P(K)=PRGRAD(R0,VEE(R0))
      DELP(K)=DELP(K-1)+.5*(P(K)+P(K-1))
  210 CONTINUE
C
      PRESS=PADD+DELP(JSET)
      DO 220 I=1,IC12
      DELP(I)=(PRESS-DELP(I))/RHOWG
      P(I)=P(I)/RHOW
  220 CONTINUE
C
      IF(IPRT.EQ.1) CALL PRTSTM(PADD,PINFT,VMAX,RMAX,ALTO,NCATG)
C
C      USE P( ) TO STORE P(I)/R.
      DO 290 I=2,IC12
      P(I)=P(I)/((I-1.)*5280.)
  290 CONTINUE
      RETURN
      END
C********************************************************************      
      SUBROUTINE INTWND(PDROP,RMAX,ALTO,VMAX)
C        JELESNIANSKI       AUGUST 1980TDL   IBM 360/195
C
C        PURPOSE
C           THIS SUBROUTINE (INTWND) SETS UP AN INITIAL GUESS FOR THE
C           MAX WIND OF A STATIONARY STORM USING INITIAL INPUT STORM
C           PARAMETERS. THE INITIAL GUESS IS AN ENTRY VALUE TO
C           SUBROUTINE 'FORCE1' FOR ITERATION TO EXACT MAXIMUM WINDS.
C
C        DATA SET USE
C           NONE
C
C        VARIABLES
C             PDROP = PRESSURE DROP FOR 1ST HOUR
C              ALTO = LATITUDE OF BASIN CENTER
C             KPRES = DOCTORED PRESSURE DROP FOR LAT OTHER THAN 30 DEG
C           WM(150) = ARRAY FOR SLOPE OF LINEAR SLOPE FORMULA
C           WB(150) = ARRAY FOR INTERCEPT OF LINEAR SLOPE FORMULA
C              RMAX = RADIUS OF MAXIMUM WIND
C              VMAX = MAXIMUM WIND
C
C        GENERAL COMMENTS
C           THIS SUBROUTINE LIES IN OVERLAY STRMPR. IT IS CALLED IN BY
C           SUBROUTINE 'STRMPR'
C           FOR A GIVEN PRESSURE DROP 'P(100)', THE MAX WIND
C           VARIES ALMOST LINEARLY WITH STORM SIZE 'R(100)'.
C           SEE BELOW;
C
C                              -       E
C                              -      R
C                              -     U
C                              W    S
C                              I   S  WM(KPRES)=SLOPE OF
C                              N  E             PRESSURE
C                              D R              LINE
C                              -P
C           WB(KPRES)=INTERCEPT-
C                              0---R=STORM SIZE----
C
C           THE SLOPE AND INTERCEPT OF THE PRESSURE LINE VARIES
C           WEAKLY WITH LATITUDE OR CORIOLIS. THE GIVEN WM,WB ARE
C           FOR LATITUDE 30 DEG; THE ENTRY PRESSURE AT TIME 'IBGNT'
C           IS DOCTORED TO CORRECT FOR LATITUDE OTHER THAN 30 DEG.
C
C********************************************************************
      DIMENSION       WM(150),WB(150)
      DATA WM/.10,.14,.17,.20,.23,.25,.28,.30,.32,.33,.35,.37,.38,.39,
     1.41,.42,.43,.44,.45,.46,.46,.47,.48,.49,.49,.50,.51,.52,.52,.53,
     2.53,.54,.54,.55,.56,.56,.57,.57,.58,.58,.59,.59,.60,.60,.61,.62,
     3.62,.63,.63,.64,.65,.65,.66,.66,.67,.68,.69,.69,.70,.71,.71,.72,
     4.72,.73,.73,.74,.74,.75,.75,.76,.76,.76,.77,.77,.77,.77,.78,.78,
     5.78,.78,.79,.79,.79,.79,.80,.80,.80,.80,.80,.81,.81,.81,.81,.81,
     6.82,.82,.82,.82,.82,.82,.83,.83,.83,.83,.84,.84,.84,.84,.84,.84,
     7.84,.85,.85,.85,.85,.85,.85,.85,.86,.86,.86,.86,.86,.86,.86,.86,
     8.86,.86,.87,.87,.87,.87,.87,.87,.87,.87,.87,.87,.87,.87,.87,.87,
     9.87,.87,.87,.87,.87,.87,.87,.87/
      DATA WB/12.,23.,29.,33.,37.,39.,41.,43.,45.,47.,49.,51.,53.,55.,
     157.,58.,60.,62.,63.,65.,67.,68.,70.,71.,73.,74.,76.,77.,78.,80.,
     281.,82.,84.,85.,86.,88.,89.,90.,92.,93.,94.,95.,96.,98.,99.,100.,
     3101.,102.,104.,105.,106.,107.,108.,109.,110.,112.,113.,114.,115.,
     4116.,117.,118.,119.,120.,121.,122.,123.,123.,124.,125.,126.,127.,
     5128.,129.,130.,131.,132.,132.,133.,134.,135.,136.,137.,137.,138.,
     6139.,140.,141.,141.,142.,143.,144.,145.,145.,146.,147.,148.,148.,
     7149.,150.,151.,151.,152.,153.,154.,154.,155.,156.,157.,157.,158.,
     8158.,159.,160.,160.,161.,162.,162.,163.,164.,164.,165.,166.,166.,
     9167.,167.,168.,169.,169.,170.,171.,171.,172.,172.,173.,174.,174.,
     A175.,175.,176.,176.,177.,177.,178.,179.,179.,180.,180.,181.,182./
C       DOCTOR ENTRY PRESSURE FOR LATITUDE OTHER THAN 30 DEG
      PF=.3*(30.-ALTO)*(PDROP/67.7)**2
      KPRES=PDROP+PF+0.5

C       ADDED CHECKS TO MAKE SURE WINDS WERE WITHIN BOUNDS -ARTHUR
      IF (KPRES >= 151) THEN
      KPRES=150
      ENDIF
      IF (KPRES < 1) THEN
      KPRES=1
      ENDIF
C       FINISHED ADDED CHECKS TO MAKE SURE WINDS WERE WITHIN BOUNDS

C       LINEAR SLOPE FORMULA FOR APPROXIMATE MAXIMUM WIND
      VMAX=-WM(KPRES)*RMAX+WB(KPRES)
      VMAX=MAX(VMAX,10.)
      RETURN
      END
      SUBROUTINE PRTSTM(PADD,PINFT,VMAX,RMAX,ALTO,NCATG)
C        THIS SUBROUTINE (STMPRT) PRINTTDL   IBM 360/195
C
C        PURPOSE
C           THIS SUBROUTINE (STRMPRT) PRINTS OUT, AT TIME OF NEAREST
C           APPROACH, THE TWO STORM SYSTEMS FOR LAKE AND OCEAN. THE
C           STORM VALUES ARE INCREMENTED AT REGULAR INTERVALS FROM
C           THE STORM CENTER.
C
C        DATA SET USE
C           NONE
C
C        VARIABLES
C            P(800) = PRESSURE GRADIENT
C            S(800) = SINE OF INFLOW ANGLE
C         DELP(800) = STATIC HEIGHTS FROM STORM CENTER
C             NCATG = 1 FOR LAKE WINDS, =2 FOR OCAENC
C              PADD = PRESSURE DROP FROM A RADIUS TO INFINITY
C             PINFT = PRESSURE DROP FROM ITERATION
C             RHOWG = WATER DENSITY*GRAVITY (MB SEC**2 FT**-1 MILE**-1)
C               PHI = INFLOW ANGLE
C              VMAX = DUMMY VALUE FOR MAXIMUM WINDS
C              ALTO = LATITUDE
C   IBEG(3) IEND(3) = BEGIN/END LOOP
C             IN(3) = INCREMENT OF DO LOOP
C
C        GENERAL COMMENTS
C           THIS SUBROUTINE RESIDES IN OVERLAY 'CMPUTE'. IT IS CALLED
C           IN BY SUBROUTINE 'FORCE1'. 'FORCE1' IS CALLED IN BY
C           SUBROUTINE 'STMVAL'.
C
      COMMON /DUMMY4/ S(800),C(800),P(800),DELP(800)
      DIMENSION       IBEG(3),IEND(3),IN(3)
C
      DATA IBEG/1,111,251/,IEND/101,231,751/,IN/2,10,50/
      DATA RHOA/2.298E-3/,RHOW/4905./,RHOWG/29.89/
C
      VEE(R)     =2.*VMAX*RMAX*R/(RMAX**2+R**2)
C
      COR=2.*(7.292116E-5)*SIN(ALTO*1.74532925E-2)
      CORHR=3600.*COR
C
c      IF(NCATG.EQ.2) THEN
c      WRITE(*,*)'  ***  SLOSH SYMMETRIC WIND PROFILES OVER OCEAN  ***'
c      ELSE
c      WRITE(*,*)'  ***  SLOSH SYMMETRIC WIND PROFILES OVER LAKES ***'
c      ENDIF
C
c      WRITE(*,240) PINFT,VMAX,RMAX,PADD,ALTO
c  240 FORMAT('  PRES DROP  MAX WIND   RADIUS     PADD   LATITUDE',
c     1 /4F10.3,F7.2)
C
c      WRITE(*,250)
c  250 FORMAT (/'    RADIUS     SPEED PRES DROP INFLW ANG  STC HGHT',
c     1   ' GRAD WIND')
C
      DO 260 K=1,3
      J1=IBEG(K)
      J2=IEND(K)
      J3=IN(K)
      DO 260 I=J1,J2,J3
      J=I-1
      PHI=ASIN(S(I))/1.74532925E-2
      PRESS=PINFT-RHOWG*DELP(I)
      R0=J
      XX=VEE(R0)
      VG=R0*P(I)*RHOW/RHOA
      CORR=.5*CORHR*R0
      VGRD=SQRT(VG+CORR*CORR)-CORR
c      WRITE(*,270)J,XX,PRESS,PHI,DELP(I),VGRD
  260 CONTINUE
C
  270 FORMAT (I10,5F10.2)
      RETURN
       END
C********************************************************************       
      SUBROUTINE CRDRD1
C        JYE CHEN            MAY  1990 TDL   IBM 360/195
C        PURPOSE
C           THIS SUBROUTINE (CRDRD1) READS IN BASIN PROJECTION DATA,
C           AS INPUT DATA TO THE SLOSH PROGRAM. EACH BASIN DATA IS ON
C           A SEPARATE FILE, AND CALLED IN BY NAME.
C********************************************************************
C        DATA SET USE
C           FT09F001
C
C        VARIABLES
C               STA = ALPHAMERIC NAME OF A BASIN (10 LETTERS)
C              EBSN =  '$' INDICATES TYPE I ELLIPTIC COORDINATES,
C                      '+' INDICATES TYPE II ELLIPTIC COORDINATES,
C                          OTHERWISE, POLAR COORDINATES
C            DOLLAR = '$' USED FOR ISLAND, OTHERWISE FOR REGULAR BASIN
C             AZMTH = SLANT OF X-AXIS FROM NORTH
C         ALTO ALNO = LATITUDE/LONGITUDE OF BASIN CENTER OR ORIGIN
C            DEGREE = ANGLE BETWEEN TWO RAYS OF A POLAR GRID
C              DELA = RADIAN MEASURE OF DEGREE
C           IRB IRE = TOTAL GRID POINTS IN -+P DIRECTION FROM TANGENT PT
C           NDB NDE = TOTAL GRID POINTS IN -+Q DIRECTION FROM TANGENT PT
C            XMOUTH = X-COORDINATE FROM TANGENT POINT TO (X,Y)=(P,Q)=(0,
C            YMOUTH = Y-COORDINATE FROM TANGENT POINT TO (X,Y)=(P,Q)=(0,
C               PHI = SLANT FROM X-AXIS TO N/S-AXIS
C         IMXB JMXB = TOTAL GRID SPACINGS IN P/Q DIRECTIONS
C       IMXB1 JMXB1 = IMXB LESS 1, JMXB LESS 1
C
C        GENERAL COMMENTS
C
      common /opts/   nofld,nof1d
      character*1     nofld,nof1d
      COMMON /SLAT/   FSOUTH
      CHARACTER*1     ISOUTH 
      COMMON /XOKE/   XOKE 
      CHARACTER*1     XOKE
      COMMON /GPRT/   STA
      COMMON /GPRT1/  DOLLAR,EBSN
      COMMON /GPRT2/  EBSN1,EBSN2
      COMMON /POLAR/  DEGREE,RMOUTH,AZMTH,DELA
      COMMON /INDX/   IRB,IRE,NDB,NDE
      COMMON /BSN/    PHI,ALTO,ALNO,PHI1,ALT1,ALN1,ALT1C
      COMMON /DLTDTA/ DLTIN(3),DLTB
      COMMON /ORIGN/  XMOUTH,YMOUTH
      COMMON /ELLIP/  AAXIS,BAXIS,ABQAB
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      COMMON /EGTH/   DELS,DELT,G,COR
C
      COMMON /FLES/ FLE5,FLE9,FLE8,FLE91,FLE99,FLE10,FLE20,FLE30,FLE1
      CHARACTER*256 FLE5,FLE9,FLE8,FLE91,FLE99,FLE10,FLE20,FLE30,FLE1
      CHARACTER*16  STA
      CHARACTER*2   DOLLAR
      CHARACTER*1   EBSN,EBSN1,EBSN2
C ----------------------------------------------------------------------
C      WRITE(*,*)'  ENTER BASIN PROJECTION FILE '
C      READ (*,'(A)') FLE9
      OPEN(9,FILE=FLE9)
C---------------------------------------------------------------------------
C        AT COLUMN 12, '$' INDICATES TYPE I ELLIPTIC COORDINATES,
C                      '+' INDICATES TYPE II ELLIPTIC COORDINATES,
C                          OTHERWISE, POLAR COORDINATES  
C        AT COLUMN 13, '$ ' INDICATES FOR CLOSED ISLAND (PERIODIC B.C.)
C                      '2$' INDICATES FOR MSY BASIN
C        AT COLUMN 15, '&' INDICATES NO CORNER SMOOTHING
C                      '+' INDICATES GLOBAL SMOOTHING EVERY DELT
C        AT COLUMN 16, '+' INDICATES OUTPUT OPTION (J-I). DEFAULT (I-J)
c                  17, '&' SOUTHERN HEMISPHERE
c                  18, '+' noflooding and overtopping of barriers
c                  19, '+' no 1d flow allowed                           
C---------------------------------------------------------------------------
      READ (9,'(A10,1X,A1,A2,8A1)') STA,EBSN,DOLLAR,EBSN1,EBSN2,ISOUTH,
     1         nofld,nof1d
CC      write (*,'(1x,A10)') STA
CC      write (*,'(1x,A1,A2,A1)') EBSN,DOLLAR,EBSN1
CC      write (*,'(1x,A1)') EBSN2
c
      IF (ISOUTH.EQ.'$') XOKE='X' 
      FSOUTH=1.
      IF (ISOUTH.EQ.'&') FSOUTH=-1.
c
C
      READ (9,580) AZMTH
C       TLAT,TLONG NOT BEING USED. USE XMOUTH,YMOUTH, INSTEAD. 
      IF (EBSN.EQ.'$'.OR.EBSN.EQ.'+') READ (9,580) TLAT,TLONG
C        LAT/LONG OF BASIN CENTER AND TANGENT POINT ON EARTH
      READ (9,580) ALTO,ALNO
C
C ------    FOR POLAR GRID SYSTEM, READ IN DEGREE OF SPREAD OF RAYS ---
      IF (EBSN.NE.'$'.AND.EBSN.NE.'+') THEN
         READ (9,580) DEGREE
         DELA=DEGREE*1.74532925E-2
       ENDIF
C ------   READ IN DISTANCE FROM BASIN CENTER TO 1ST HYPERBOLA, 
C        ANGLE OF 1ST ASYMPTOTE FOR ELLIPTIC GRIDS I  ------ 
      IF (EBSN.EQ.'$') READ (9,580) DSTNT,ASMPT
C ------   READ IN AAXIS,BAXIS FOR ELLIPTIC GRIDS II  ---     
      IF (EBSN.EQ.'+') READ (9,580) AAXIS,BAXIS,GSIZE
C
      READ (9,'(5I5)') IRB,IRE,NDB,NDE,NDB1
C        DEFINE DELTA THETA FOR ELLIPTIC GRIDS I AND II.
      IF (EBSN.EQ.'$') THEN
        IF (NDB.NE.0) THEN
         NDBZ=NDB
         ELSE 
         NDBZ=NDE
         ENDIF
C     SPECIAL USE OF ELLIPTIC BASIN I (CARTESIAN APPROX.)
         IF (EBSN1.EQ.'$') NDBZ=NDB1
        DEGREE=(90.-ASMPT)/NDBZ
        DELA=DEGREE*1.74532925E-2
        ASMPT=ASMPT*1.74532925E-2
        AAXIS=0.
        BAXIS=DSTNT/COS(ASMPT)
        ENDIF
      IF (EBSN.EQ.'+') THEN
C        DEGREE=360./(NDB+NDE)
C        DELA=DEGREE*1.74532925E-2
        DELA=2.*GSIZE/(AAXIS+BAXIS)
        DEGREE=DELA/1.74532925E-2
        XMOUTH=AAXIS
        YMOUTH=0
        ENDIF
C
      PHI   =270.+AZMTH
      PHI1=1.74532925E-2*PHI
      ALT1=1.74532925E-2*ALTO
C
C        FORMULATE CORIOLIS, SEC-1
      COR=2.*(7.292116E-5)*SIN(ALT1)
      ALT1C=1.74532925E-2*(90.-ALTO)
      ALN1=1.74532925E-2*ALNO
C
C        READ IN DELTS FOR 3 CATAGORIES OF STORM
      READ (9,100) (DLTIN(I),I=1,3)
 100  FORMAT(3F10.6)
C
      IF (EBSN.NE.'+') READ (9,580) XMOUTH,YMOUTH
C         DEFINE AAXIS=BAXIS= DISATANCE FROM POLE TO TANGENT POINT
C         FOR POLAR GRIDS
      IF (EBSN.NE.'$'.AND.EBSN.NE.'+') THEN
         AAXIS=XMOUTH
         BAXIS=AAXIS
         ENDIF
C
C         DEFINE CONSTANTS FOR GENERAL CODES.
      RMOUTH=.5*(AAXIS+BAXIS)
      ABQAB=(AAXIS-BAXIS)/(AAXIS+BAXIS)
C
      IMXB  =IRB+IRE+1
      JMXB  =NDB+NDE+1
C
CC      WRITE (*,*) '     ---- GRID TRANSFORMATION DATA ----'
CC      WRITE (*,'(A)') '   AAXIS      BAXIS   DELA(DEG)  IMXB  JMXB  (A-B
CC     1)/(A+B)'
CC      WRITE (*,111) AAXIS,BAXIS,DELA/1.74532925E-2,IMXB,JMXB,ABQAB
 111  FORMAT(2F10.4,F10.6,2I6,F10.5)
C
      IMXB1 =IMXB-1
      JMXB1 =JMXB-1
      IMXB2=IMXB1-1
      JMXB2=JMXB1-1
C
 580  FORMAT (3F10.6)
      RETURN
       END
C********************************************************************       
      SUBROUTINE TTIMER
C        JELESNIANSKI/CHEN    JULY 1989     TDL   IBM 360/195
C
C        PURPOSE
C           IT KEEPS TRACK OF TIME AND ACCUMULATES TIME STEPS.
C           IT UPDATES THE STORM POSITION AT EACH TIME STEP ON A
C           CARTESIAN GRID. IT COMPUTES A GROWTH FACTOR TO UPDATE
C           A STORM TO MATURITY.
C********************************************************************
C        DATA SET USE
C           NONE
C
C        VARIABLES
C              IC19 = STORM GROWTH TIME TO MATURITY, SET IN 'INTVAL'
C
C                           Y        (
C                           Y         *(X,Y)
C                           Y          )
C                           Y
C                     PXXXXX0XXXXXXXXXXXXXXXXXXXXXXXX
C                     0   ORIGIN=TANGENT POINT
C                     L     Y    ON EARTH
C                     E     Y
C                           Y
C
C             ITIME = INCREASES BY ONE FOR EACH TIME STEP
C                BT = STORM GROWTH COEFFICIENT, 0<BT<=1
C
C        GENERAL COMMENTS
C           THIS SUBROUTINE RESIDES IN THE ROOT OVERLAY
C
      COMMON /FFTH/   ITIME,MHALT
      COMMON /FRTH/   IC12,IC19,BT
      ITIME=ITIME+1
C      GROWTH FACTOR OF THE STORM FROM ZERO STRENGTH TO MATURITY
      BT=1.
      IF(ITIME.LT.IC19) THEN
      TIME=ITIME
      ANG=TIME/IC19
      BT=.5*(1.-COS(ANG*3.14159265358979))
         ENDIF
      RETURN
         END
      SUBROUTINE CMPUTE
c
c	Sung Kim, January, 1992
c
c	To save data, press "P"
c	To pause run, press "S"
c	saved data:
c		integer*2 of 1/10th of surge height
c                            10000th power of transport normalized by depth
c
C        JELESNIANSKI   SEPTEMBER 1980 TDL   IBM 360/195
C
C        PURPOSE
C           THIS 2ND OVERLAY 'CMPUTE' USES SUBROUTINE 'CMPUTE' AS
C           A DIRECT CALLING SEQUENCE FOR 12 SUBROUTINES.
C           THE PURPOSE OF THE OVERLAY IS TO COMPUTE SURGE HEIGHTS
C           USING ALGORITHMS FOR PARTIAL DIFFERENTIAL EQUATIONS OF
C           MOTION. SURGES ARE STORED FOR LATER PRINT OUT.
C
C        DATA SET USE
C           NONE
C
C        VARIABLES
C             ITIME = CUMULATIVE TIME COUNTER
C             MHALT = HALT COMPUTATIONS AT THIS TIME STEP
C              NPSS = NUMBER OF CHANNELS
C              NCUT = NUMBER OF CUTS ALONG BARRIORS
C            NSQRWC = NUMBER OF SQUARES FOR 1D FOLW PLUS FLOW CUTS
C            NDLTHR = NUMBER OF TIME STEPS IN ONE HOUR
C            IPRTSV = TIME TO SAVE HISTRCL SURGES, 10 PTS, SET 'INTVAL'
C            IPRTAD = UPDATE TIME OF IPRTSV, SET IN 'INTVAL'
C
C        GENERAL COMMENTS
C           THIS SUBROUTNE RESIDES IN OVERLAY 'CMPUTE'. IT IS NOT
C           CALLED IN BY ANY OTHER SUBROUTINE.
C
      INCLUDE 'parm.for'
      COMMON /DATUM/  SEADTM,DTMLAK
      character*120 pfile
      CHARACTER*120 wfile
      CHARACTER*4 TMBAR
      CHARACTER*3 HRBAR
      COMMON /CESAV/  IPN(120),IPL(120),KHSPT
      common /opts/   nofld,nof1d
      character*1     nofld,nof1d
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      COMMON /DELTH/  NDLTHR,NDLTH2,DLTHR,DLTH2
      COMMON /FFTH/   ITIME,MHALT
      COMMON /FRTH/   IC12,IC19,BT
C STIME interferes with C code, so switched to STIME2
      COMMON /STIME2/  ISTM,JHR,ITMADV,NHRAD,IBGNT,ITEND
      COMMON /PRTSV/  IPRTSV,IPRTAD
      COMMON /FLWCPT/ NSQRS,NSQRW,NSQRWC,NPSS,NCUT
      COMMON /PRHSY/  IPRHR,JUMPR,IPRT
      COMMON /GPRT1/  DOLLAR,EBSN
      COMMON /GPRT2/  EBSN1,EBSN2
      COMMON /KEYS/   KEY1
      COMMON /SWTCH/  IOPERL(5)
      COMMON /POLAR/  DEGREE,RMOUTH,AZMTH,DELA
      COMMON /ELLIP/  AAXIS,BAXIS,ABQAB
      COMMON /INDX/   IRB,IRE,NDB,NDE
      COMMON /STRMSB/ C1,C2,C21,C22,AX,AY,PTENCY,RTENCY
      COMMON /FLES/ FLE5,FLE9,FLE8,FLE91,FLE99,FLE10,FLE20,FLE30,FLE1
      COMMON /FLE/  FLE92
      COMMON /IDENT/  AIDENT(40),DACLOK(7)
      COMMON /EGTH/   DELS,DELT,G,COR
      INTEGER*2     MYR,MMON,MDAY,MHR,MMIN,MSEC,MI100
      CHARACTER*256 FLE5,FLE9,FLE8,FLE91,FLE99,FLE10,FLE20,FLE30,FLE1
      CHARACTER*30  FLE92
      CHARACTER*2  DOLLAR
      CHARACTER*1  EBSN,EBSN1,EBSN2
      integer*2 pdat(M_,N_)
C
C    SELECTION OF SNAPSH FROM 'C' OPTION.
C      OPEN (77,FILE='SN001',FORM='UNFORMATTED')
c
C      INCLUDE 'CMPGR1.FOR'
C
      JUMPR=1
      INCSM=20
      IF (EBSN1.EQ.'+') INCSM=1
c
c
        CALL SETCMP
        CALL INTLHT
        CALL RDLTLG
C
      IF (KHSPT.EQ.0) THEN
      OPEN (10,FILE='$$fle10',FORM='UNFORMATTED')
      OPEN (20,FILE='$$fle20',FORM='UNFORMATTED')
      OPEN (30,FILE='$$fle30',FORM='UNFORMATTED')
      WRITE(10) AIDENT
      WRITE(20) AIDENT
      WRITE(30) AIDENT
      ELSE
      OPEN (13,FILE='$$fle13',FORM='UNFORMATTED')
      OPEN (14,FILE='$$fle14',FORM='UNFORMATTED')
      OPEN (15,FILE='$$fle15',FORM='UNFORMATTED')
      WRITE(13) AIDENT
      WRITE(14) AIDENT
      WRITE(15) AIDENT
      ENDIF
C        SUBROUTINE 'TTIMER' RESIDES IN THE ROOT OVERLAY
C  
  100 CALL TTIMER
      xtime=itime
c
c  continuity
c
      CALL CONTTY
c
C       NO CORNER SMOOTHING for PNB BASIN
c
      IF (EBSN1.EQ.'&'.or.EBSN1.EQ.'+') GOTO 113
C      IF (ITIME.GT.5.AND.INCSM.NE.1)  CALL SMPT2G
 113  CONTINUE
c
c
c
      CALL BDRYHT
      IF (NPSS.NE.0) CALL CHANNL
      IF (NSQRWC.NE.0.and.nof1d.ne.'+') CALL FLW1DM
      CALL HMXSV
C
      IPRHR=3
      IF (ITIME.NE.IPRTSV) GO TO 180
      IF(ITIME.EQ.NHRAD) IPRHR=1
      IF(ITIME.EQ.NHRAD-NDLTHR/2) IPRHR=2
      IPRTSV=IPRTSV+IPRTAD
      IF (KHSPT.EQ.0) THEN
       CALL HISTRY
       ELSE
       IF (IPRHR.NE.3) CALL HSTRY2
       ENDIF
c
c
C      INCLUDE 'CMPGR3.FOR'
c
  180 CONTINUE
C
C       IF (KEY1.EQ.0) GOTO 1112
C
c      IF(ITIME+1.EQ.NHRAD.or.EBSN1.EQ.'+') THEN
      IF(mod(ITIME+1,INCSM).EQ.0.or.EBSN1.EQ.'+') THEN
       IF (DOLLAR.EQ.'$') THEN
      CALL FLTER2
      ELSE
      CALL FILTER
      ENDIF
      ENDIF
c
c  momentum equation
c
      CALL MOMNTM
C
      CALL STMVAL
c
C GRAPHICS
C
C      INCLUDE 'CMPGR2.FOR'
C
C END OF COMPUTE FOR ONE TIME STEP
c
      IF (ITIME.LT.MHALT.AND.MHALT.GT.0) GO TO 100
C
C CLOSE GRAPHICS
C
 999	CONTINUE
CC      write (*,*)'   finished at time step=',itime
CC      write (*,*)'   mhalt=' ,mhalt
      CALL FILTRP
      CALL FHMXSV    
      CALL ARCHIV
C
 1112 CONTINUE  
c
C      INCLUDE 'CMPGR4.FOR'
C
        RETURN
       END
C********************************************************************       
       SUBROUTINE INITLZ
C        JELESNIANSKI    SEPTEMBER 1980TDL   IBM 360/195
C
C        PURPOSE
C           THIS SECOND OVERLAY 'INITLZ' USES SUBROUTINE 'INITLZ' AS A
C           CALLING SEQUENCE FOR 5 SUBROUTINES.
C           THE PURPOSE OF THE OVERLAY IS TO FIX SOME PROGRAM CONSTANTS,
C           SOME POLAR GRID CONSTANTS; TO SET BATHY/TOPO AND
C           BARRIER HEIGHTS, AND TO INITIALIZE A TIMING SEQUENCE.
C********************************************************************
C        DATA SET USE
C           NONE
C
C        VARIABLES
C         ALTO (DEG)= LATITUDE OF BASIN CENTER OR ORIGIN
C
C        GENERAL COMMENTS
C     THIS SUBROUTINE RESIDES IN OVERLAY 'INITLZ'. IT IS CALLED
C           BY THE ROOT OVERLAY AND NOT BY ANY OTHER SUBROUTINE.
C
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
C      COMMON /SLAT/   FSOUTH
      COMMON /BSN/    PHI,ALTO,ALNO,PHI1,ALT1,ALN1,ALT1C
      COMMON /SWTCH/  IOPERL(5)
      COMMON /GPRT1/  DOLLAR,EBSN
      CHARACTER*2     DOLLAR
      CHARACTER*1     EBSN
C      CHARACTER*40    FILNAM
      CHARACTER*80    DUM
C
      CALL INPUTN
C          READ BASIN PROJECTION DATA    
      CALL CRDRD1
      CALL STERON

C           READ IN SLOSH GEOGRAPHY DATA 
      CALL CRDRD2
C           CHANNEL COORDINATES REQUIRED FOR SETDST TO DEFINE AREAS.
      IF (DOLLAR.EQ.'2$') CALL DEPMSY
       CALL DEPSFC
c       IF(IOPERL(1).NE.2) CALL BSNPRT
C
       ZLATO=ALTO
C       IF (FSOUTH.LT.0.) ZLATO=-ALTO
       CALL BTMSTR(ZLATO)
       CALL SETDST
       CALL INTDLT
       CALL INTVAL
       CALL CNSTNT
      RETURN
       END
C********************************************************************       
      SUBROUTINE INPUTN
C********************************************************************      
      COMMON /STRMPS/ X(100),Y(100),P(100),R(100),DIR(100),SP(100)
      COMMON /SPLN/   ALT(15),ALN(15),AX(15),AY(15),RL(15),ANGD(15),
     1                PT(15),RT(15),XLAT(100),YLONG(100),RLNGTH
      COMMON /IDENT/  AIDENT(40),DACLOK(7)
C STIME interferes with C code, so switched to STIME2
      COMMON /STIME2/  ISTM,JHR,ITMADV,NHRAD,IBGNT,ITEND
      COMMON /DATUM/  SEADTM,DTMLAK
      COMMON /DATUM1/ DTMCHN
      COMMON /XOKE/   XOKE 
      CHARACTER*1     XOKE
      COMMON /FLES/ FLE5,FLE9,FLE8,FLE91,FLE99,FLE10,FLE20,FLE30,FLE1
      CHARACTER*256 FLE5,FLE9,FLE8,FLE91,FLE99,FLE10,FLE20,FLE30,FLE1
C      CHARACTER*80   dummy
      COMMON /LANDFL/ LFTIME
      CHARACTER*80   LFTIME
C
      OPEN(5,FILE=FLE5)
C         READ IN 2 TITLE CARDS
      READ (5,'(20a4)') AIDENT
C
C
C        READ 100 STRM PSTNS IN LAT AND LONG, MM PRESSURE DROPS,
C        RADII OF MAX WINDS IN ST MILES, ALL 1 HOURS APART
      DO 110 I=1,100
      READ (5,300) ITM,XLAT(I),YLONG(I),SPeed,DIRr,P(I),R(I)
 300  FORMAT(15X,I5,8F8.2)
 110  CONTINUE
      READ (5,'(3I3)') IBGNT,ITEND,JHR
      READ (5,'(A80)') LFTIME
      READ (5,'(2f5.1,A1,F5.1)') SEADTM,DTMLAK,XOKE,DTMCHN
      CLOSE (5)
C
C ht1 < 99.9 implies init water was for tide + anomaly (so tide)
C ht1 = 99.9 implies init water was missing (so surge)
C 150 < ht1 < 250 implies init water was for anomaly (so surge) (with anomaly = ht1 - 200)
C 350 < ht1 < 450 implies we added a tide field (SLOSH + tide) (so tide) (with anomaly = ht1 - 400)
C
      IF ((SEADTM.GE.150).AND.(SEADTM.LE.250)) THEN
      SEADTM = INT((SEADTM - 200)*10 + .5)/10.
      ELSE IF ((SEADTM.GE.350).AND.(SEADTM.LE.450)) THEN
      SEADTM = INT((SEADTM - 400)*10 + .5)/10.
      ENDIF
c      write (*,*) '  sea datum, and lake datum =', seadtm, dtmlak
c      read (*,*) seadtm,dtmlak
      RETURN
      END
C********************************************************************
      SUBROUTINE STERON
C        JELESNIANSKI/CHEN   OCT 1989    TDL   IBM 360/195
C
C        PURPOSE
C           THIS SUBROUTINE  CHANGES HR'LY  STORM TRACK
C           POSITIONS (LATITUDE AND LONGITUDE) TO  POSITIONS ON (X,Y)
C           PLANE. RECORDS HOURLY SPEEDS AND DIRECTIONS IN (X,Y) PLANE.
C
C        DATA SET USE
C           NONE
C
C        VARIABLES
C  XLAT( ) YLONG( ) = LAT/LONG OF HOURLY STORM POSITIONS
C       X(  ) Y(  ) = COMPONENTS OF HOURLY STORM POSITIONS
C         ALTO ALNO = LAT/LONG OF BASIN ORIGIN
C              PHI  = SLANT FROM N/S AXIS TO Y-AXIS;E.G., 'AZMTH+270'
C              ERAD = RADIUS OF EARTH (SPERICAL)
C             FTPNM = NO OF FEET IN A NAUTICAL MILE
C     XMOUTH YMOUTH = MOUTH COORDINATES IN X-Y PLANE
C
C        GENERAL COMMENTS
C********************************************************************
      COMMON /STRMPS/ X(100),Y(100),P(100),R(100),DIR(100),SP(100)
      COMMON /SPLN/   ALT(15),ALN(15),AX(15),AY(15),RL(15),ANGD(15),
     1                PT(15),RT(15),XLAT(100),YLONG(100),RLNGTH
      COMMON /BSN/    PHI,ALTO,ALNO,PHI1,ALT1,ALN1,ALT1C
      COMMON /EGTH/   DELS,DELT,G,COR
      COMMON /ORIGN/  XMOUTH,YMOUTH
C STIME interferes with C code, so switched to STIME2
      COMMON /STIME2/  ISTM,JHR,ITMADV,NHRAD,IBGNT,ITEND
      DATA ERAD/3437.87/,FTPNM/6080.21/
C
C        SET LAT/LONG AND SLANT IN RADIANS; COMPLEMENT LAT BY 90 DEG
      SO=SIN(ALT1C)
      CO=COS(ALT1C)
      ERAD2=2.*ERAD
      CO2=2.*CO
C        TRANSFORM LAT/LONG TO CARTESIAN (X,Y)
      DO 120 I=1,100
      ALTII=1.74532925E-2*(90.-XLAT(I))
      ALNII=1.74532925E-2*YLONG(I)
      DLAT=ALT1C-ALTII
      DLAT2=.5*DLAT
      DLON=ALN1-ALNII
      DLON2=.5*DLON
      S2=SIN(DLON2)**2
      S=SIN(DLAT2)**2+SO*SIN(ALTII)*S2
      RLZ=ERAD2*SQRT(S/(1.-S))
  110 AN=SIN(ALTII)*SIN(DLON)
      AD=SIN(DLAT)+CO2*SIN(ALTII)*S2
      IF (AN**2+AD**2.LT.1.E-10) THEN
      ANG=3.14159265358979-PHI1
         ELSE
      ANG=3.14159265358979+ATAN2(-AN,-AD)-PHI1
         ENDIF
      X(I)=(RLZ*SIN(ANG))*FTPNM/5280.+XMOUTH
      Y(I)=(RLZ*COS(ANG))*FTPNM/5280.+YMOUTH
C
      IF (I.EQ.1) GOTO 120
         SP(I-1)=SQRT((X(I-1)-X(I))**2+(Y(I-1)-Y(I))**2)
         IF (SP(I-1).LT.1.E-5) THEN
         DIR(I-1)=3.14159265358979
         ELSE
         DIR(I-1)=3.14159265358979+ATAN2(Y(I-1)-Y(I),X(I-1)-X(I))
         ENDIF
c      WRITE(*,*) X(I),Y(I),SP(I-1),DIR(I-1)/1.74532925E-2
  120 CONTINUE
      SP(100)=SP(99)
      DIR(100)=DIR(99)   
C
C      CALCULATE THE MINIMUM DISTANCE TO MOUTH POINT
       RLNGTH=SQRT((X(JHR)-XMOUTH)**2+(Y(JHR)-YMOUTH)**2)
C
      RETURN
       END
C********************************************************************
      SUBROUTINE SETDST
C        JELESNIANSKI    SEPTEMBER 1980 TDL   IBM 360/195
C
C        PURPOSE
C           THIS SUBROUTINE (SETDST) COMPUTES SIZE SPECIFICS OF THE
C           POLAR GRID, AS WELL AS THE ORIENTATION OF THE (P,Q) POLAR
C           SYSTEM VERSUS THE (X,Y) SYSTEM.  THE END RESULTS ARE USED
C           FOR DRIVING FORCES TRANSFORMED FROM THE (X,Y) TO (P,Q)
C           SYSTEMS.  PRINT OUT OF POLAR SPECIFICS ARE EFFECTED.
C********************************************************************
C        DATA SET USE
C           NONE
C
C        VARIABLES
C              DELA = RADIAN MEASURE BETWEEN CONTIGUOUS RAYS
C         IMXB JMXB = TOTAL GRID SPACINGS, SET IN 'CRDRD1'
C       IMXB1 JMXB1 = IMXB LESS 1, JMXB LESS 1
C           IRB JRB = TOTAL GRID POINTS IN +-DIRCTN FROM ORIGIN
C           NDB NDE = TOTAL GRID POINTS IN +-Q DIRECTION FROM ORIGIN
C            RMOUTH = DISTANCE FROM POLE TO BASIN ORIGIN IN MILES
C        SIDEHZ(  ) = ARC LENGTH BETWEEN CONTIGUOUS GRID POINTS IN FT
C        ARESQ(  ) = AREA OF SQUARES, BETWEN CONCENTRIC CIRCLES IN FT-2
C        SIDEVT(  ) = DISTANCE BETWEEN CONCENTRIC CIRCLES IN MILES IN FEET
C            DEGREE = ANGLE BETWEEN 2 CONTIGUOUS RAYS
C          ANGD(  ) = ANGLE BETWEEN P-AXIS AND ANY RAY, IN DEGREES
C               RAD = RADIAN MEASURE
C COST(  ) SINT(  ) = RAY PRJCTNS THRU MOMENTUM POINTS, ON (X,Y) AXIS
C COSL(  ) SINL(  ) = RAY PRJCTNS THRU SURGE POINTS, ON (X,Y) AXIS
C
C        GENERAL COMMENTS
C           THIS SUBROUTINE RESIDES IN OVERLAY 'INITLZ'. IT IS
C           CALLED IN BY SUBROUTINE 'INITLZ'.
C
      INCLUDE 'parm.for'
C
      COMMON /POLAR/  DEGREE,RMOUTH,AZMTH,DELA
      COMMON /ELLIP/  AAXIS,BAXIS,ABQAB
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      COMMON /INDX/   IRB,IRE,NDB,NDE
      COMMON /EGTH/   DELS,DELT,G,COR
      COMMON /FLWCPT/ NSQRS,NSQRW,NSQRWC,NPSS,NCUT
      COMMON /CHNL/   IPT0(2,5),JPT0(2,5),IPTL(2,5),JPTL(2,5),ENTEXT(5)
      COMMON /CHNARA/ ARESQ0(5),ARESQL(5)
C      DIMENSION DUMMY(800)
C        COMPUTING RADII OF CONCENTRIC CIRCLES IN ST MILES
      DO 100 I=1,IMXB
      X=I-1-IRB
      RFEET1=EXP(X*DELA)
      GRID=RMOUTH*RFEET1*5280.
      Z1=1./(RFEET1*RFEET1)
      ELPCT(I)=(1.+ABQAB*Z1)*GRID
      ELPDT(I)=(1.-ABQAB*Z1)*GRID
 100  CONTINUE
C
C        COMPUTING AZIMUTHS FOR EACH RAY FROM STORM CENTER
      DO 130 J=1,JMXB
      X=J-1-NDB
      ANGL=X*DELA
C        AZIMUTHS ON MOMENTUM POINTS
      COST(J)=COS(ANGL)
      SINT(J)=SIN(ANGL)
      SINT2(J)=SINT(J)*SINT(J)
C        AZIMUTHS ON HEIGHT POINTS
      ANGH=ANGL+.5*DELA
      COSL(J)=COS(ANGH)
      SINL(J)=SIN(ANGH)
      SINL2(J)=SINL(J)*SINL(J)
 130  CONTINUE
C
C        COMPUTING RADIAL DISTANCES TO HT PTS, IN FEET
C        DETERMINING HEIGHT POINT JACOBIANS FOR CONTTY EQUATION IN FEET
      DO 150 I=1,IMXB
      X=I-1-IRB
      X=X+0.5
      RFEET1=EXP(X*DELA)
      GRID=RMOUTH*RFEET1*5280.
C      GRID2=1./(RMOUTH*RFEET1*5280.)**2
      Z1=1./(RFEET1*RFEET1)
      ELPCL(I)=(1.+ABQAB*Z1)*GRID
      ELPDL(I)=(1.-ABQAB*Z1)*GRID 
      ELPCL2(I)=ELPCL(I)*ELPCL(I)
      ELPDL2(I)=ELPDL(I)*ELPDL(I)
 150  CONTINUE
C        APPROX. THE AREAS OF THE ENTRANCE AND EXIT SQUARES OF CHANNELS.
      IF (NPSS.NE.0) THEN
      DO 310 NPASS=1,NPSS
      Z1=0.
      Z2=0.
      DO 300 K=1,2
      I=IPT0(K,NPASS)
      J=JPT0(K,NPASS)
      II=IPTL(K,NPASS)
      JJ=JPTL(K,NPASS)
      Z1=Z1+ELPDL2(I)+(ELPCL2(I)-ELPDL2(I))*SINL2(J)
      Z2=Z2+ELPDL2(II)+(ELPCL2(II)-ELPDL2(II))*SINL2(JJ)
 300  CONTINUE
      ARESQ0(NPASS)=.5*Z1*DELA*DELA      
      ARESQL(NPASS)=.5*Z2*DELA*DELA      
 310  CONTINUE  
        ENDIF
C 
C        PRINT OUT X-DISTANCES ALONG Q=0, IN MILES
C      WRITE(*,190)
C      DO 140 I=1,IMXB
C      DUMMY(I)=ELPCT(I)/5280.
C 140  CONTINUE
C      WRITE(*,170)(DUMMY(I),I=1,IMXB)
C        PRINT OUT Y-DISTANCES ALONG P=0, IN MILES
C      WRITE(*,210)
C      DO 135 J=1,JMXB1
C      X=J-1-NDB
C      ANGL=ELPDT(1)*SIN(X*DELA)/5280.
C 135  DUMMY(J)=ANGL
C      WRITE(*,170)(DUMMY(J),J=1,JMXB1)
 160  FORMAT (10X,' RADIUS OF CIRCLES FROM ORIGIN, IN MILES')
 170  FORMAT(F7.1,19F6.1)
 180  FORMAT(3X,20I6)
 190  FORMAT(10X,' GRID DISTANCES ALONG X-AXIS (ALONG Q=0)')
 200  FORMAT(20F6.2)
 210  FORMAT(10X,' GRID DISTANCES ALONG Y-AXIS (ALONG P=0)')
      RETURN
      END
      SUBROUTINE DEPMSY
C
      INCLUDE 'parm.for'
C	
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      COMMON /DATUM/  SEADTM,DTMLAK
      COMMON /GPRT1/  DOLLAR,EBSN
      CHARACTER*2     DOLLAR
      CHARACTER*1     EBSN
C
      DO 5 J=1,JMXB
  5   ZSUB(J)=0.
      DO 11 J=1,JSUB
  11  ZSUB(J)=ZSUBCE
      J11=JSUB+1
      DO 12 J=J11,JSUB1
      Z=JSUB1-J
      Z=Z/(JSUB1-JSUB)
      IZS=-ZSUBCE*Z*10.
  12  ZSUB(J)=-IZS*.1
      DO 13 J=1,JSUB1
      DO 13 I=1,IMXB1
  13  ZB(I,J)=ZB(I,J)-ZSUB(J)
      DTMLAK=DTMLAK+ZSUBCE
C      write (*,*) '  dtmlak= ',dtmlak
C      write (*,*) ' exit from depmsy'
      RETURN
      END
C********************************************************************      
      SUBROUTINE INTLHT
C        JELESNIANSKI   SEPTEMBER 1980 TDL   IBM 360/195
C
C        PURPOSE
C           THIS SUBROUTINE (INTLHT) INITIALIZES THE SEA WITH QUIESCENT
C           WATER LEVELS PLUS STATIC HEIGHTS WITH THE STORM IN DEEP
C           WATER. STATIC HEIGHTS ARE NOT ADDED TO INLAND WATER BODIES.
C           INLAND WATER HEIGHTS ARE INITIALIZED IN SUBROUTINE 'DEPTHB'.
C********************************************************************
C        DATA SET USE
C           NONE
C
C        VARIABLES
C       IMXB1 JMXB1 = MAX SUBSCRIPTS FOR HT POINTS
C            MF(  ) = MOMENTUM P SUBSCRIPT, FOR END OF LAKE WINDS,
C             AX AY = COMPONENTS OF STORM TRAVERSE FOR 1ST UNIT OF TIME
C             C1 C2 = COMPONENTS OF STORM PSTN, TIME=0, SET IN 'INTVAL'
C COSL(  ) SINL(  ) = COMPONENTS OF AZIMUTH ON HEIGHT POINTS
C        GRIDRH(  ) = RADII OF CONCENTRIC CIRCLES THRU HT POINTS
C            SEADTM = INITTIAL, QUIESCENT, SEA SURFACE HEIGHT
C            DTMLAK = INITIAL WATER HEIGHT (INTERIOR WATER BODIES)
C         DELP(800) = STATIC HEIGTHS AT MILE INTERVALS FROM STRM CENTER
C        HB(  ,   ) = SURGE HEIGHTS
C      UB VB(  ,  ) = TRANSPORT COMPONENTS
C        HMX(  ,  ) = MAX SURGE HEIGHTS
C         ZB(  ,  ) = DEPTH VALUES ON TW0-DIMENSIONAL STAIR STEPS
C
C        GENERAL COMMENTS
C           THIS SUBROUTINE RESIDES IN OVERLAY 'CMPUTE'. IT IS
C           CALLED IN ONLY ONCE BY SUBROUTINE 'SETCMP'.
C
      INCLUDE 'parm.for'
C
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      COMMON /STRMSB/ C1,C2,C21,C22,AX,AY,PTENCY,RTENCY
C STIME interferes with C code, so switched to STIME2
      COMMON /STIME2/  ISTM,JHR,ITMADV,NHRAD,IBGNT,ITEND
      COMMON /FLWCPT/ NSQRS,NSQRW,NSQRWC,NPSS,NCUT
      COMMON /DATUM/  SEADTM,DTMLAK
      COMMON /FRST/   X1(50),X12(50)
      COMMON /DUM88/  IIH(4),JJH(4),IHH(4),JHH(4)
      COMMON /DUMMY4/ S(800),C(800),P(800),DELP(800)
      COMMON /SWTCH/  IOPERL(5)
      COMMON /DATUM1/ DTMCHN
      COMMON /XOKE/   XOKE
      CHARACTER*1     XOKE
C      CHARACTER*40     FILNAM
C
      COMMON /GPRT1/  DOLLAR,EBSN
      CHARACTER*2     DOLLAR
      CHARACTER*1     EBSN
C
      IF (XOKE.EQ.'X') GOTO 1111
      IF (DOLLAR.EQ.'2$') GOTO 1211

C        INITIALIZE WATER HEIGHTS ACCORDING TO LAKE DATUM
      DO 90 J=1,JMXB1
      DO 90 I=1,IMXB1
      IF (ITREE(I,J).EQ.'2'.OR.ITREE(I,J).EQ.'5') GOTO 95
      IF (ITREE(I+1,J).EQ.'2'.OR.ITREE(I+1,J).EQ.'5') GOTO 95
      IF (ITREE(I,J+1).EQ.'2'.OR.ITREE(I,J+1).EQ.'5') GOTO 95
      IF (ITREE(I+1,J+1).EQ.'2'.OR.ITREE(I+1,J+1).EQ.'5') GOTO 95
      HB(I,J)=AMAX1(-ZB(I,J),AMAX1(DTMLAK,-ZB(I,J)))
      GOTO 90
C        STATIC HEIGHTS ON OCEAN,SEA OR GULF; NOT ON INLAND WATER BODIES
 95   XR=ELPCL(I)*COSL(J)
      YR=ELPDL(I)*SINL(J)
      X=XR-C1-AX
      Y=YR-C2-AY
      RSQ=X*X+Y*Y
      R1=SQRT(RSQ)/5280.+1.
      K=R1
      R2=K
      DR=R1-R2
      K=MIN0(K,790)
      HB(I,J)=DELP(K)+DR*(DELP(K+1)-DELP(K))+SEADTM
      HB(I,J)=AMAX1(HB(I,J),-ZB(I,J))
 90   CONTINUE
 100  CONTINUE
 110  CONTINUE
C
C--------------- FOR OCEAN SPRING BASIN ONLY ---------
      IF (DOLLAR.EQ.'1$') THEN
C
C        DRY OUT LAND SQUARES BELOW SEA LEVEL.
      DO  L=1,NODRY
      I=IDRY(L)
      J=JDRY(L)
      HB(I,J)=-ZB(I,J)
      ENDDO
      ENDIF
C-----------------------------------------------------
      GOTO 1112
C---------------------- FOR OKEECHOBEE BASIN ONLY ----
 1111 CONTINUE
      DO 10 J=1,JMXB1
      DO 10 I=1,IMXB1
      IF (ITREE(I,J).EQ.'7'.OR.ITREE(I+1,J).EQ.'7'.OR.
     1   ITREE(I,J+1).EQ.'7'.OR.ITREE(I+1,J+1).EQ.'7') THEN
        HB(I,J)=AMAX1(-ZB(I,J),AMAX1(DTMLAK,-ZB(I,J)))
        ELSE IF (ZB(I,J).GT.-10.) THEN
          HB(I,J)=AMAX1(DTMCHN,-zb(i,j))
          ELSE
          HB(I,J)=-ZB(I,J)
          ENDIF
 10   CONTINUE
C       RESET CANNEL WATER LEVEL AS LAKE LEVEL
C       SUPPRESS WIND FOR ALL CANALS WITH 'TREE' OPTION IN 1D FLOW.
      DO 12 L=1,NSQRWC
      IF (KTREE(L).EQ.'T') THEN
       I=ISQR(L)
       J=JSQR(L)
CC       write (*,*) l,i,j
       HB(I,J)=AMAX1(DTMLAK,-ZB(I,J))
       K=ISIDE(L)
       II=I+IHH(K)
       JJ=J+JHH(K)
       HB(II,JJ)=AMAX1(DTMLAK,-ZB(II,JJ))
      ENDIF
 12   CONTINUE
C
      GOTO 1112
C
C ------------------------ FOR MSY ONLY -----------------
C
 1211 CONTINUE
C        INITIALIZE WATER HEIGHTS ACCORDING TO LAKE DATUM
      DO 190 J=1,JMXB1
      IFN=LDTMG(J)
      DO 190 I=1,IMXB1
        IF (I.LE.IFN) THEN
        HB(I,J)=AMAX1(-ZB(I,J),AMAX1(DTMLAK,-ZB(I,J)))
        ELSE IF (ITREE(I,J).EQ.'2'.OR.ITREE(I,J+1).EQ.'2'.OR.
     1  ITREE(I+1,J).EQ.'2'.OR.ITREE(I+1,J+1).EQ.'2') THEN
        XR=ELPCL(I)*COSL(J)
        YR=ELPDL(I)*SINL(J)
        X=XR-C1-AX
        Y=YR-C2-AY
        RSQ=X*X+Y*Y
        R1=SQRT(RSQ)/5280.+1.
        K=R1
        R2=K
        DR=R1-R2
        K=MIN0(K,790)
        HB(I,J)=DELP(K)+DR*(DELP(K+1)-DELP(K))+SEADTM
        HB(I,J)=AMAX1(HB(I,J),-ZB(I,J))
        ELSE
        HB(I,J)=AMAX1(-ZB(I,J),AMAX1(SEADTM,-ZB(I,J)))
        ENDIF
 190   CONTINUE
C
C        DRY OUT LAND SQUARES BELOW SEA LEVEL.
      DO 195  L=1,NODRY
      I=IDRY(L)
      J=JDRY(L)
      HB(I,J)=-ZB(I,J)
 195  CONTINUE
C
C
 1112 CONTINUE
C        INITIALIZE U/V/HMX
C
      DO 320 I=1,IMXB1
 320  HB(I,JMXB)=HB(I,1)
      DO 200 J=1,JMXB
      DO 200 I=1,IMXB
      UB(I,J)=0.
  200 VB(I,J)=0.
      DO 210 J=1,JMXB1
      DO 210 I=1,IMXB1
      HMX(I,J)=HB(I,J)
 210  CONTINUE
C
C
C        INITLIZE FLWSQR TO BE ZERO.
C
      DO 220 L=1,NSQRWC
 220  FLWSQR(L)=0.
C        REDUCE PRINTOUT IF IN OPERATIONAL MODE.
      IF(IOPERL(1).EQ.2) GO TO 300
CC      WRITE(*,140)
C        PRINT OUT INITIAL HEIGHT VALUES
CC      WRITE(*,150)
      NGRP=(JMXB1-1)/25+1
C
      DO 130 NN=1,NGRP
      J1=1+(NN-1)*25
      J2=J1+MIN0(24,JMXB1-J1  )
CC      WRITE(*,180)(J,J=J1,J2)
C
      DO 120 I=1,IMXB1
CC      WRITE(*,170) I,(HB(I,J),J=J1,J2)
 120  CONTINUE
 130  CONTINUE
      DO 1130 NN=1,NGRP
      J1=1+(NN-1)*25
      J2=J1+MIN0(24,JMXB1-J1  )
CC      WRITE(*,180)(J,J=J1,J2)
C
      DO 1120 I=1,IMXB1
CC      WRITE(*,171) I,(HMX(I,J),J=J1,J2)
 171  FORMAT(1H ,I2,26I5)
 1120  CONTINUE
 1130  CONTINUE
C
 140  FORMAT(1H1)
 150  FORMAT(/'   INITIAL HEIGHT VALUES')
 160  FORMAT(1H ,I2,26F5.0)
 170  FORMAT(1H ,I2,26F5.1)
 180  FORMAT(/I6,26I5)
 300  CONTINUE
      RETURN
       END
C********************************************************************
      SUBROUTINE RDLTLG
C********************************************************************      
      INCLUDE 'parm.for'
C
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      COMMON /FLES/ FLE5,FLE9,FLE8,FLE91,FLE99,FLE10,FLE20,FLE30,FLE1
      CHARACTER*256 FLE5,FLE9,FLE8,FLE91,FLE99,FLE10,FLE20,FLE30,FLE1
      CHARACTER*256   FILNAM
      CHARACTER*80    DUM
      integer         strlen
C
CC      WRITE (*,*)' READ IN LAT/LONG OF THE GRIDS'
C      READ (*,'(A)') FILNAM
      FILNAM = FLE99
      CALL TOPEN(25,FILNAM,0,2)
      CALL TREAD(25,IDUM,1)
      CALL TREAD(25,JDUM,1)
      CALL TREADC(25,DUM,80)
      CALL TREADC(25,DUM,80)
      IF (IDUM.NE.IMXB.OR.JDUM.NE.JMXB) THEN
        WRITE (*,*) "LLX ERROR:", IDUM, JDUM, IMXB, JMXB
      ENDIF
      DO L=1,JMXB
        DO K=1,IMXB
          CALL TREADF(25,YLT(K,L),1)
        END DO
      END DO
      DO L=1,JMXB
        DO K=1,IMXB
          CALL TREADF(25,YLG(K,L),1)
        END DO
      END DO
      CALL TCLOSE(25)
C      OPEN (25,FILE=FILNAM,ACCESS='TRANSPARENT')
C      READ (25,end=26) IDUM,JDUM
C      READ (25) DUM,DUM
C      READ (25) ((YLT(K,L),K=1,IMXB),L=1,JMXB)
C      READ (25) ((YLG(K,L),K=1,IMXB),L=1,JMXB)
C       CLOSE (25)
 26   continue
C
C UND
      L = ichar(NCFILE(1:1))
      IF ((L.NE.0).AND.(L.NE.32)) THEN
        CALL gridWrite(IMXB,JMXB)
      ENDIF
      
      RETURN
      END
C********************************************************************      
      SUBROUTINE CRDRD2
C********************************************************************      
      INCLUDE 'parm.for'
C      INCLUDE 'parmmsy.for'
C
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      COMMON /BSN/    PHI,ALTO,ALNO,PHI1,ALT1,ALN1,ALT1C
      COMMON /SPLN/   ALT(15),ALN(15),AX(15),AY(15),RL(15),ANGD(15),
     1                PT(15),RT(15),XLAT(100),YLONG(100),RLNGTH
      COMMON /DUMBSV/ SAVEH(10),IPN(10),JPN(10),STATS(10)
      COMMON /PRTOVL/ NSHEET,JPGS(10),JPGF(10),IPGS(10),IPGF(10)
      COMMON /FLWCPT/ NSQRS,NSQRW,NSQRWC,NPSS,NCUT
      COMMON /DLTDTA/ DLTIN(3),DLTB
      COMMON /CHNLD/  CHLNH(5),CHWTH(5),CHDPH(5)
      COMMON /CHNL/   IPT0(2,5),JPT0(2,5),IPTL(2,5),JPTL(2,5),ENTEXT(5)
      COMMON /IPRX/   IX60
      COMMON /GPRT1/  DOLLAR,EBSN
      CHARACTER*1  EBSN
C
      CHARACTER*16 STATS
      DIMENSION   IANG(L_)
      CHARACTER*16 AAA
      DIMENSION   INW(7),JNW(7),HW(7)
      DIMENSION   IBNK(NBK_),JBNK(NBK_),ISBNK(NBK_),BKI(NBK_),
     1            BKE(NBK_),WCHN(NBK_)
      CHARACTER*2   AC,BC,IX60,XA1,YA1,ZA1,DOLLAR,SIG_
      DATA XA1/'X'/,YA1/'Y'/,ZA1/'Z'/,SIG_/'$'/
C
C       READ BOUNDARY TYPES ALONG LEFT,RIGHT,TOP AND BOTTOM BOUNDARIES
C        ALONG MOMENTUM POINTS.
C             .****.****.****.****.****.****.****.****.  TOP BNDRY
C             *                                       *
C             *                                       *
C             .    .    .    .    .    .    .    .    .
C LEFT BNDY   *                                       *   RIGHT BNDY
C             * +         +         +         +       *
C             *                                       *
C             .****.****.****.****.****.****.****.****.  BOTTOM BNDRY
C             2    8    8    8    9    9    9    1    1
C DEEP WATER-) (-INTERMEDIATE----) (-SHALLOW----) (--LAND----
C
      IF (IMXB.GT.M_.OR.JMXB.GT.N_) THEN
CC      WRITE (*,*) ' BASIN DIMENSIONS ',IMXB,JMXB
CC      WRITE (*,*) ' HAS EXCEEDS THE COMPILE DIMENSIONS',M_,N_
      STOP
      endif
C        INITIALIZE ZBM(I,J) FOR ENTIRE GRIDS
      DO 120 J=1,JMXB
      DO 120 I=1,IMXB
 120  ZBM(I,J)=-300.
C
C         READING IN BARRIER HEIGHTS AT SELECTED GRID POINTS
      READ (9,520) INWP,AC
       IF(AC.EQ.'X') INWP=INWP+1000
       IF(AC.EQ.'Y') INWP=INWP+2000
       IF(AC.EQ.'Z') INWP=INWP+3000
       IF(AC.EQ.'W') INWP=INWP+4000
       IF(AC.EQ.'V') INWP=INWP+5000
C     WRITE (*,520) INWP
      IF (INWP.EQ.0) GO TO 220
      INWX=(INWP-1)/7+1
      I7X=INWP-(INWX-1)*7
      I7=7
      DO 210 IP=1,INWX
      IF(IP.EQ.INWX) I7=I7X
      READ (9,550) (INW(I),JNW(I),HW(I),I=1,I7)
      DO 200 N=1,I7
      I=INW(N)
      J=JNW(N)
 200  ZBM(I,J)=HW(N)
 210  CONTINUE
C
C        COMPLETE DEFINING ZBM( , ) IN SUBROUTINE 'DEPSFC'
C
C         READ IN DATA FOR 1-DIM FLOW, (I,J) POINTS, SIDES 1-4
 220  CONTINUE
C
C       INITIALIZE DATA FOR REGULAR 1D FLOW
      DO 230 I=1,L_
      BANK(I,1)=0.
      BANK(I,2)=0.
      HWEIR(I)=0.
      DELCUT(I)=1.
 230  CONTINUE
C       AC='X' IF 1D-FLOW POINTS EXCEED 1000 .
      READ (9,520) NSQRS,AC,BC
C     WRITE (*,520) NSQRS,AC,BC
      IF (AC.EQ.'X') NSQRS=1000+NSQRS
      IF (AC.EQ.'Y') NSQRS=2000+NSQRS
      IF (AC.EQ.'Z') NSQRS=3000+NSQRS
      IF (AC.EQ.'W') NSQRS=4000+NSQRS
      IF (AC.EQ.'V') NSQRS=5000+NSQRS
      IF (AC.EQ.'U') NSQRS=6000+NSQRS
      IF (AC.EQ.'T') NSQRS=7000+NSQRS
      IF (AC.EQ.'S') NSQRS=8000+NSQRS
      IF (AC.EQ.'R') NSQRS=9000+NSQRS
      IF (AC.EQ.'Q') NSQRS=10000+NSQRS
      IF (AC.EQ.'P') NSQRS=11000+NSQRS
C
      IF (NSQRS.GT.L_) THEN
      WRITE(*,*)' NO. OF 1D FLOW POINTS ',NSQRS
      WRITE(*,*)' EXCEEDS THE MAXIMUM ALLOWED. MAX= ',L_
      STOP
      ENDIF
      IF (NSQRS.EQ.0) GO TO 300
      READ (9,540) (ISQR(I),JSQR(I),KTREE(I),ISIDE(I),IANG(I),I=1,NSQRS)
C
C        FOR BC='X' ENTER SPECIAL 1D FLOW SQUARES,BE SURE OF THE SAME
C        ORDER AS IN 1D FLOW
      IF (BC.NE.'X') GO TO 300
C
C       READ IN BANK DATA
      READ(9,520) NBNKS,AC
      IF (AC.EQ.'X') NBNKS=1000+NBNKS
      IF (AC.EQ.'Y') NBNKS=2000+NBNKS
      IF (AC.EQ.'Z') NBNKS=3000+NBNKS
      IF (AC.EQ.'W') NBNKS=4000+NBNKS
C    WRITE(*,520) NBNKS
      READ(9,250)(IBNK(I),JBNK(I),AC,ISBNK(I),BKI(I),BKE(I),
     1 WCHN(I),I=1,NBNKS)
 250  FORMAT (4(2I3,A1,I1,2F3.0,F4.2))
C
C       REPOSITION BANKS WITH RESPECT TO 1D FLOW SQUARES
C       LIST OF BANK POINTS MUST BE IN THE SAME ORDER AS 1D FLOW PT.
      LLL=1
      DO 290 I=1,NBNKS
      II=IBNK(I)
      JJ=JBNK(I)
      K=ISBNK(I)
      LL=LLL
      DO 280 L=LL,NSQRS
      ISET=ISQR(L)
      IF (ISET.NE.II) GO TO 260
      JSET=JSQR(L)
      IF (JSET.NE.JJ) GO TO 260
      KSET=ISIDE(L)
      IF (KSET.NE.K) GO TO 260
      LLL=L+1
      BANK(L,1)=BKI(I)
      BANK(L,2)=BKE(I)
      DELCUT(L)=WCHN(I)
      GO TO 290
 260  IF (L.NE.NSQRS) GO TO 280
C     WRITE(*,270) IBNK(I),JBNK(I),ISBNK(I)
 270  FORMAT('   THE SPECIAL FLOW POINT FOR BANKS AT I=',I3,' J=',
     1I3,' SIDE=',I3,' DOES NOT EXIST IN THE 1D FLOW REGION')
 280  CONTINUE
 290  CONTINUE
C
C         READ IN DATA FOR RAISED WEIRS FOR 1-DIM FLOW
 300  READ (9,520) NWEIRS,AC
      IF (AC.EQ.'X') NWEIRS=NWEIRS+1000
      IF (AC.EQ.'Y') NWEIRS=NWEIRS+2000
      IF (AC.EQ.'Z') NWEIRS=NWEIRS+3000
      IF (NWEIRS.EQ.0) GO TO 320
      READ (9,530)(ISQR(NSQRS+I),JSQR(NSQRS+I),KTREE(NSQRS+I),
     1 ISIDE(NSQRS+I),HWEIR(NSQRS+I),I=1,NWEIRS)
      DO 310 I=1,NWEIRS
 310  IANG(I+NSQRS)=0
 320  NSQRW=NSQRS+NWEIRS
C
C
C         READ IN DATA FOR 10 SELECTED POINTS (SURGE HISTORY)
      READ (9,630) (STATS(I),I=1,10)
C     WRITE(*,630) (STATS(I),I=1,10)
      READ (9,610) (IPN(I) ,I=1,10)
      READ (9,610) (JPN(I) ,I=1,10)
C
C         READ IN DATA FOR CHANNELS
      READ (9,520) NPSS
      IF (NPSS.EQ.0) GO TO 340
      READ (9,650) (CHLNH(I),I=1,NPSS)
      READ (9,680) (CHWTH(I),I=1,NPSS)
      READ (9,690) (CHDPH(I),I=1,NPSS)
      READ (9,700) ((IPT0(I,J),I=1,2),J=1,NPSS)
      READ (9,700) ((JPT0(I,J),I=1,2),J=1,NPSS)
      READ (9,700) ((IPTL(I,J),I=1,2),J=1,NPSS)
      READ (9,700) ((JPTL(I,J),I=1,2),J=1,NPSS)
 340  CONTINUE
C
C         READ IN DATA FOR FLOW ACROSS CUTS
      READ (9,520) NCUT,AC
      IF (AC.EQ.'X') NCUT=1000+NCUT
      IF (AC.EQ.'Y') NCUT=2000+NCUT
      NSQRWC=NSQRW+NCUT
      IF (NSQRWC.GT.L_) THEN
      WRITE(*,*)' NO. OF 1D FLOW POINTS + CUTS',NSQRWC
      WRITE(*,*)' EXCEEDS THE MAXIMUM ALLOWED. MAX= ',L_
      STOP
        ENDIF
C
      IF (NCUT.EQ.0) GO TO 390
C
      DO 380 I=1,NCUT
      M=I+NSQRW
      READ (9,370)ISQR(M),JSQR(M),KTREE(M),ISIDE(M),BANK(M,1),BANK(M,2),
     1 CUTL(I),CUTLI(I),CUTLE(I),IANG(M),HWEIR(M)
 370  FORMAT(2I3,A1,I1,2F4.0,3F5.2,I3,F5.1)
      IF (CUTL(I).EQ.0.) CUTL(I)=1.
      IF (CUTLI(I).EQ.0.) CUTLI(I)=1.
      IF (CUTLE(I).EQ.0.) CUTLE(I)=1.
 380  CONTINUE
 390  CONTINUE
C
C        COMPUTE SINE AND COSINE OF THE ANGLE THAT IS USED TO
C        ROTATE WIND STRESS DIRECTION FROM ACTUAL TO MODEL'S 1D FLOW
C        DIRECTIONS.
      DO 410 N=1,NSQRWC
      IF (IANG(N).EQ.0) GO TO 400
      ANG=IANG(N)*1.74532925E-2
      COS1D(N)=COS(ANG)
      SIN1D(N)=SIN(ANG)
      GO TO 410
 400  COS1D(N)=1.
      SIN1D(N)=0.
 410  CONTINUE
 420  CONTINUE
C        READ IN DATA FOR MANGROVE POINTS OR TREE LOCATIONS (MGPT=-1)
      READ (9,520) MGPT
      IF (MGPT.EQ.0) GOTO 470
C        READ IN LOCATIONS OF TREE POINTS (0 OR 1)
      DO 460 J=1,JMXB
      READ (9,450) (ITREE(I,J),I=1,IMXB)
 450  FORMAT(60A1)
 460  CONTINUE
C        SET UP BOUNDARY VALUES TO ZBM( , ) TO BE CHECKED FOR OPEN
C        BOUNDARY CALCULATIONS.
       IF (DOLLAR.NE.SIG_) THEN
      DO 160 J=1,JMXB,JMXB1
      DO 160 I=1,IMXB
      ZBM(I,J)=100.
 160  CONTINUE
          ENDIF
      DO 180 I=1,IMXB,IMXB1
      DO 180 J=1,JMXB
      ZBM(I,J)=100.
 180  CONTINUE
C
C         READ IN DATA FOR PRINT OUT OF SHEETS OF MAX SURGES
C        OPTIONAL FORMATS TO ACCOMMODATE DIFFERENT BASINS DATA
C        FORMAT-- I3,A1
C        IX60--' ' FOR DISPLAYING I=1,IXB,WHERE IXB < 60
C              'X' FOR DISPLAYING I=1,IXB,WHERE IXB >=60
C              'Y' FOR I=1,IPGF(I)
C              'Z' FOR I=IPGS(I),IPGF(I)  MOST GENERAL
 470  READ (9,520) NSHEET,IX60
      NSHEET=MIN(NSHEET,6)
C     WRITE(*,520) NSHEET,IX60
      READ (9,610) (JPGS(I),I=1,NSHEET)
C     WRITE(*,610) (JPGS(I),I=1,NSHEET)
      READ (9,610) (JPGF(I),I=1,NSHEET)
C     WRITE(*,610) (JPGF(I),I=1,NSHEET)
      DO 480 N=1,NSHEET
      IPGS(N)=1
      IPGF(N)=MIN0(59,IMXB1)
      IF (IX60.EQ.'X') IPGF(N)=IMXB1
 480  CONTINUE
      IF (IX60.EQ.'Z') THEN
      READ (9,610) (IPGS(I),I=1,NSHEET)
C      WRITE (*,610) (IPGS(I),I=1,NSHEET)
      ENDIF
      IF (IX60.EQ.YA1.OR.IX60.EQ.ZA1) THEN
      READ (9,610) (IPGF(I),I=1,NSHEET)
C       WRITE (*,610) (IPGF(I),I=1,NSHEET)
      ENDIF
C
C         READING IN DEPTH VALUES
      IMX=(IMXB-1)/15+1
      DO 500 K=1,IMX
      IST=(K-1)*15+1
      IFN=MIN0(IST+14,IMXB)
      DO 490 J=1,JMXB
      READ (9,710) (ZB(I,J),I=IST,IFN)
CC      IF (J.EQ.JMXB) WRITE(*,710) (ZB(I,J),I=IST,IFN)
      DO 405 I=IST,IFN
 405  ZB(I,J)=MIN(600.,ZB(I,J))
 490  CONTINUE
 500  CONTINUE
c------------ FOR BIX BASIN ONLY
      IF (DOLLAR.EQ.'1$') THEN
      READ (9,'(i4)') NODRY
      IF(NODRY.GT.ND_) THEN
        WRITE(*,*) "Too many Dry cells"
      ENDIF
      IF(NODRY.GT.1)THEN
      READ (9,'(9(I3,1X,I3,1X))')(IDRY(K),JDRY(K),K=1,NODRY)
      ENDIF
      ENDIF
C
      IF (DOLLAR.EQ.'$') THEN
      DO 510 I=1,IMXB
 510  ZB(I,JMXB)=ZB(I,1)
      ELSE
      DO 512 I=1,IMXB
 512  ZB(I,JMXB)=ZB(I,JMXB1)
      ENDIF
C
      CLOSE (9)
 520  FORMAT (I3,2A1)
 530  FORMAT (5(2I3,A1,I1,F5.1))
 540  FORMAT (6(2I3,A1,I1,I3))
 550  FORMAT (7(I3,I3,F3.0))
 560  FORMAT (A10,2X,A1)
 570  FORMAT (F10.6)
 580  FORMAT (2F10.6)
 590  FORMAT (4I5)
 600  FORMAT (22I3)
 610  FORMAT (15I3)
 620  FORMAT (45I1)
 630  FORMAT (6A10)
 640  FORMAT (15F3.0)
 650  FORMAT (5F5.1)
 660  FORMAT (13F5.0)
 670  FORMAT (A4,3I3,1X,3I3)
 680  FORMAT (5F6.0)
 690  FORMAT (5F5.0)
 700  FORMAT (10I3)
 710  FORMAT (15F4.0,A16)
      RETURN
       END
C********************************************************************       
      SUBROUTINE DEPSFC
C        JELESNIANSKI    SEPTEMBER 1980 TDL   IBM 360/195
C
C        PURPOSE
C           THIS SUBROUTINE (DEPSFC) INITIALIZES INLAND SURFACE WATERS
C           TO LAKE DATUM (SEA WATER TO SEA DATUM IS DONE IN SUBROU-
C           TINE 'INILHT'). BARRIERS AND THEIR HEIGHTS ARE PLACED AT
C           SELECTED MOMENTUM GRID POINTS. FOR 1-DIM FLOW, DEPTHS AND
C           LATERAL BOUNDARIES ARE SET. BOUNDARIES ARE TEMPORARILY
C           SET AS A 100 FOOT WALL. PRINT OUTS ARE MADE OF THE DEPTH
C           FIELD, AND HIGHEST LAND VALUE AT MOMENTUM GRID POINTS
C           ARE SET.
C********************************************************************
C        DATA SET USE
C           NONE
C
C        VARIABLES
C         IMXB JMXB = TOTAL GRID SPACINGS, SET IN 'CRDRD1'
C       IMXB1 JMXB1 = IMXB LESS 1, JMXB LESS 1
C            DOLLAR = '$' FOR ISLAND, OTHERWISE FOR REGULAR BASIN
C         ZB(  ,  ) = BATHY/TOPO HEIGHTS,    RELATIVE TO NGVD
C        ZBM(  ,  ) = HIGHEST ELEVATION AT A MOMENTUM POINT
C                     OR, VALUES INDICATING BOUNDARY TYPES
C             NSQRW = NUMBER OF SQUARES WITH 1-DIM FLOW
C    ISQR JSQR(   ) = SUBSCRIPTS FOR SQUARES WITH 1-DIM FLOW
C        ISIDE(   ) = THE SIDE OF A SQUARE TO PASS 1-DIM FLOW
C     IIH(4) JJH(4) = SHIFT SUBSCRIPTS TO 4 MOMENTUM POINTS ON A SQUARE
C        HWEIR(   ) = LOWESTT BARRIER ELEVATION AT ISIDE(   )
C     IZ1(4) IZ2(4) = SET P SUBSCRIPTS ON 4 SIDES OF ISIDE(   )
C     JZ1(4) JZ2(4) = SET Q SUBSCRIPTS ON 4 SIDES OF ISIDE(   )
C        ZBMIN(   ) = LOWEST DEPTH OF TWO SQUARES BOUNDING ISIDE(30
C              MGPT = TOTAL NUMBER OF MANGROVE PTS
C     IMG( ) JMG( ) = I/J COORDINATES OF MANGROVE PTS
C      ITREE(  ,  ) = 0 FOR NO TREE, 1 FOR TREE ON A GRID POINT
C
C        GENERAL COMMENTS
C           THIS SUBROUTINE RESIDES IN OVERLAY 'INITLZ'. IT IS
C           CALLED IN SUBROUTINE 'INITLZ'.
C
       INCLUDE 'parm.for'
C
      common /opts/   nofld,nof1d
      character*1     nofld,nof1d
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      COMMON /DUMB8/  IP(4),JP(4),IH(4),JH(4)
      COMMON /DUM88/  IIH(4),JJH(4),IHH(4),JHH(4)
      COMMON /BSN/    PHI,ALTO,ALNO,PHI1,ALT1,ALN1,ALT1C
      COMMON /SPLN/   ALT(15),ALN(15),AX(15),AY(15),RL(15),ANGD(15),
     1                PT(15),RT(15),XLAT(100),YLONG(100),RLNGTH
      COMMON /BCPTS/  NBCPT,ISH(1600),JSH(1600)
      COMMON /FLWCPT/ NSQRS,NSQRW,NSQRWC,NPSS,NCUT
      COMMON /SWTCH/  IOPERL(5)
      COMMON /GPRT1/  DOLLAR,EBSN
      CHARACTER*2     DOLLAR
      CHARACTER*1     EBSN
      DIMENSION IZ1(4),IZ2(4),JZ1(4),JZ2(4)
      DATA IZ1/0,1,0,0/,  IZ2/0,1,1,1/, JZ1/1,1,0,1/, JZ2/0,0,0,1/
C
      DO 401 J=2,JMXB
      DO 401 I=2,IMXB
      ZMX=AMAX1(-ZB(I-1,J-1),-ZB(I,J-1),-ZB(I-1,J),-ZB(I,J))
      IF (ZMX.LT.-1499.) ITREE(I,J)='6'
c       IF (ZMX.LE.-799.) ITREE(I,J)='6'
 401  CONTINUE
C      IF (DOLLAR.EQ.'$') THEN
C      DO  I=2,IMXB
C      ZMX=AMAX1(-ZB(I-1,JMXB),-ZB(I,JMXB),-ZB(I-1,1),-ZB(I,1))
C      IF (ZMX.LE.-289.) ITREE(I,1)='6'
C      ENDDO
C      ENDIF
C      
C      DETERMINE THE ACTIVE/NONACTIVE SQUARES FOR HEIGHT COMPUTATIONS    
       DO 400 J=1,JMXB1
       DO 400 I=1,IMXB1
       IF (ZB(I,J).LE.-35.) GOTO 1417
       KSKP(I,J)='1'
       KCT=1
C       SPECIAL TRUNCATED SQUARES IN DEEP OCEAN 
       IF (ITREE(I,J).EQ.'6') KCT=KCT+1
       IF (ITREE(I+1,J).EQ.'6') KCT=KCT+1
       IF (ITREE(I,J+1).EQ.'6') KCT=KCT+1
       IF (ITREE(I+1,J+1).EQ.'6') KCT=KCT+1
       GOTO (400,415,415,415,417),KCT
c 415   KCT=0
c       IF (ITREE(I,J).EQ.'4') KCT=KCT+1
c       IF (ITREE(I+1,J).EQ.'4') KCT=KCT+1
c       IF (ITREE(I,J+1).EQ.'4') KCT=KCT+1
c       IF (ITREE(I+1,J+1).EQ.'4') KCT=KCT+1
c       IF (KCT.GE.3) GOTO 417
  415  KSKP(I,J)='2'
       GOTO 400
 417   ZB(I,J)=-67.
 1417  KSKP(I,J)='0'
 400   CONTINUE
       DO 421 J=1,JMXB
 421   KSKP(IMXB,J)='0'
       DO 420 I=1,IMXB
 420   KSKP(I,JMXB)=KSKP(I,1)
C
C      WRITE(*,3334)
C      DO 3333 JJ=2,JMXB
C      J=JMXB-JJ+1
C      WRITE (*,3332) J,(KSKP(I,J),I=1,IMXB1)
C3332  FORMAT(1X,I3,1X,126A1)
C3333  CONTINUE
C      WRITE(*,3334)
C 3334  FORMAT(/5X,12('1234567890')/)
C
C        ISOLATE HIGHEST LAND SQUARE ABOUT A TRANSPORT POINT
C        FOR ISLAND ZB( ,JMXB)=ZB( ,1)
      J2=JMXB1
      IF (DOLLAR.EQ.'$')  J2=JMXB
      DO 130 I=2,IMXB
      DO 130 J=2,J2
      ZMX=AMAX1(-ZB(I-1,J-1),-ZB(I,J-1),-ZB(I-1,J),-ZB(I,J))
      IF (ZBM(I,J).GE.ZMX) GO TO 130
      IF (ZBM(I,J).NE.-300.) GO TO 110
      ZBM(I,J)=ZMX
      GO TO 130
 110  WRITE(*,120)I,J,ZBM(I,J)
 120  FORMAT ('   ERROR IN BARRIER HEIGHT AT POSITION I=',I5,' J=',I5,
     1 '  HW=',F5.0)
      ZBM(I,J)=ZMX
 130  CONTINUE
      IF (DOLLAR.EQ.'$') THEN
        DO 132 I=1,IMXB
        ZBM(I,1)=ZBM(I,JMXB)
 132    CONTINUE
        ENDIF
C
      DO 1401 J=2,JMXB
      DO 1401 I=2,IMXB
      IF (ITREE(I,J).EQ.'5'.AND.ZBM(I,J).GE.-15.) ITREE(I,J)='3'
 1401  CONTINUE
C
C        IF ZBM GREATER THAN 35 FT IN INTERIOR POINTS, MOMENTURM PTS
C        ARE NONACTIVE.
       DO 40 J=2,J2
       DO 40 I=2,IMXB1
       IF (ZBM(I,J).GE.35.) ITREE(I,J)='4'
       IF (ITREE(I,J).EQ.'5') ITREE(I,J)='2'
 40    CONTINUE
C
C       REDEFINE MS(J). FOR EACH J, FIRST I THE COMPUTATION
C       STARTS IN MOMNTM (ZBM LESS THAN 35 FT).
      DO 50 J=2,JMXB
      MS(J)=1
      DO 60 I=1,IMXB
      IF (ZBM(I,J).LT.35.) GOTO 55
 60   CONTINUE
      I=I-1
 55   MS(J)=I
 50   CONTINUE
      IF (DOLLAR.EQ.'$') THEN
         MS(1)=MS(JMXB)
         ELSE
         MS(1)=MS(2)
         ENDIF
c
      nxx=(jmxb-1)/15+1
      do n=1,nxx
      j1=(n-1)*15+1
      j2=MIN(JMXB,j1+14)
CC      write (*,'(15i3)') (ms(j),j=j1,j2)
      enddo
c

C       DEFINE IS(J). FOR EACH J, FIRST I THE COMPUTATION
C       STARTS IN CONTINUITY.
      DO 10 J=1,JMXB1
      IS(J)=1
      DO 20 I=1,IMXB1
      IF (KSKP(I,J).EQ.'1') GOTO 15
 20   CONTINUE
      I=I-1
 15   IS(J)=I
 10   CONTINUE
      IF (DOLLAR.EQ.'$')THEN
         IS(JMXB)=IS(1)
         ELSE
         IS(JMXB)=IS(JMXB1)
         ENDIF
C
C        DEFINE LOWER LIMIT OF I FOR MOMN. POINTS
      DO 450 J=2,JMXB1
      ME(J)=IMXB
      DO 460 II=2,IMXB1
      I=IMXB-II+1
      IF (ZBM(I,J).GE.35.) GOTO 460
      IF (ITREE(I,J).NE.'6') GOTO 455
 460  CONTINUE
      I=I+1
 455  ME(J)=I
 450  CONTINUE
      ME(1)=IMXB1
      ME(JMXB)=IMXB1
C        DEFINE LOWER LIMIT OF I FOR CONTTY POINTS
C
      DO 610 J=1,JMXB1
      IE(J)=IMXB1
      DO 620 II=1,IMXB1
      I=IMXB1-II+1
      IF (KSKP(I,J).EQ.'1') GOTO 615
 620  CONTINUE
      I=I+1
 615  IE(J)=I
 610  CONTINUE
      IE(JMXB)=IE(1)
C     PRINT 1111,(IS(J),J=1,JMXB)
C     PRINT 1111,(MS(J),J=1,JMXB)
C 1111 FORMAT(1X,15I3)
C     PRINT 1111,(IE(J),J=1,JMXB)
C     PRINT 1111,(ME(J),J=1,JMXB)
C
C
      DO 42 J=2,JMXB
      MF(J)=IMXB
      DO 45 II=1,IMXB1
      I=IMXB-II
      IF (ITREE(I,J).EQ.'1'.OR.ITREE(I,J).EQ.'3') GOTO 48
 45   CONTINUE
 48   MF(J)=I
 42   CONTINUE
      IF (DOLLAR.EQ.'$') THEN
        MF(1)=MF(JMXB)
        ELSE
        MF(1)=MF(2)
        ENDIF
C     IF NO BANKS, THEN SET BANK HEIGHTS TO BARRIER HEIGHT
      IF (NSQRWC.EQ.0) GO TO 250
      DO 200 L=1,NSQRWC
      IF (BANK(L,1).NE.0.) GO TO 190
      I=ISQR(L)
      J=JSQR(L)
      ISS=1
 180  BANK(L,ISS)=AMIN1(ZBM(I,J),ZBM(I,J+1),ZBM(I+1,J),ZBM(I+1,J+1))
       GO TO (190,200),ISS
 190  IF (BANK(L,2).NE.0.) GO TO 200
      K=ISIDE(L)
      I=ISQR(L)+IHH(K)
      J=JSQR(L)+JHH(K)
      ISS=2
      GO TO 180
 200  CONTINUE
C
C        SET UP DEPTHS AND SIDE HEIGHTS FOR 1-DIM FLOW AND RIVER BANKS
C        SET UP SPECIAL RAISED WEIRS OR SILLS FOR 1-DIM FLOW
C        AND ZBMIN FOR FLOW CUTS IN SUBROUTINE CRDRD2.
      IF (NSQRW.EQ.NSQRS) GOTO 2333
      N1=NSQRS+1
      DO 232 L=N1,NSQRW
      I=ISQR(L)
      J=JSQR(L)
      K=ISIDE(L)
      I1=I+IZ1(K)
      I2=I+IZ2(K)
      J1=J+JZ1(K)
      J2=J+JZ2(K)
      IF (HWEIR(L).EQ.0.) HWEIR(L)=AMIN1(ZBM(I1,J1),ZBM(I2,J2))
 232  CONTINUE
      DO 1232 N=N1,NSQRW
      I=ISQR(N)
      J=JSQR(N)
      K=ISIDE(N)
      I1=I+IZ1(K)
      I2=I+IZ2(K)
      J1=J+JZ1(K)
      J2=J+JZ2(K)
      ITREE(I1,J1)='Q'
      ITREE(I2,J2)='Q'
 1232 CONTINUE
 2333 CONTINUE
      DO 3222 J=2,JMXB1
      DO 3222 I=2,IMXB1
      IF (ITREE(I,J).EQ.'Q') THEN
      ZBM(I,J)=36.
      ITREE(I,J)='4'
      ENDIF
 3222 CONTINUE
      DO 240 L=1,NSQRWC
      I=ISQR(L)
      J=JSQR(L)
      ZINT=-ZB(I,J)
      K=ISIDE(L)
      II=I+IHH(K)
      JJ=J+JHH(K)
      ZEXT=-ZB(II,JJ)
C      FOR WEIR HEIGHTS NOT A SILL
      IF (HWEIR(L).NE.0.) GO TO 230
 220  HWEIR(L)=AMAX1(ZINT,ZEXT)
 230  I1=I+IZ1(K)
      I2=I+IZ2(K)
      J1=J+JZ1(K)
      J2=J+JZ2(K)
      IZBX=AMIN1(ZBM(I1,J1),ZBM(I2,J2))
      ZBMIN(L)=IZBX
 240  CONTINUE
C
      IF (NSQRW.EQ.NSQRS) GOTO 250
      DO 2221 N=N1,NSQRW
      I=ISQR(N)
      J=JSQR(N)
      K=ISIDE(N)
      I1=I+IZ1(K)
      I2=I+IZ2(K)
      J1=J+JZ1(K)
      J2=J+JZ2(K)
C     WRITE(*,2222) I,J,K,HWEIR(N),ZBMIN(N),ZBM(I1,J1),ZBM(I2,J2)
C 2222 FORMAT(3I5,4F6.1)
 2221 CONTINUE
C
 250  CONTINUE
C      DEFINE GRID COORDINATES FORSTATIC BOUNDARY CONDITION.
      N=0
      DO 1200 I=1,IMXB1
      DO 1200 J=1,JMXB1
      IF (KSKP(I,J).NE.'2') GOTO 1200
      N=N+1
      ISH(N)=I
      JSH(N)=J
      KSKP(I,J)='0'
 1200 CONTINUE
      NBCPT=N
C     WRITE(*,225) NBCPT
C 225  FORMAT(I5,'     TOTAL POINTS FOR STATIC BOUNDARY CONDITION')
C        NNN=(NBCPT-1)/15+1
C        DO 223 K=1,NNN
C        N1=1+(K-1)*15
C        N2=MIN(N1+14,NBCPT)
C      WRITE(*,222) K,(ISH(N),N=N1,N2)
C      WRITE(*,224) K,(JSH(N),N=N1,N2)
C 222   FORMAT(T62,'I-B.C.',I2,T1,15I4)
C 224   FORMAT(T62,'J-B.C.',I2,T1,15I4)
C 223   CONTINUE
c          noflooding option
        if (nofld.eq.'+') then
        do 1234 j=2,jmxb1
        do 1234 i=2,imxb1
        if (zbm(i,j).gt.0.) then
           itree(i,j)='4'
           zbm(i,j)=36.
           endif
 1234  continue
	endif
C
C        REDUCED PRINTOUT FOR OPERATIONAL MODE.
C      IF(IOPERL(1).EQ.2) GO TO 350
C     WRITE(6,290)
C      WRITE(6,300)
C      NGRP=(JMXB1-1)/25+1
C
C      DO 270 NN=1,NGRP
C      J1=1+(NN-1)*25
C      J2=J1+MIN0(24,JMXB1-J1)
C      WRITE(6,340)(J,J=J1,J2)
C      DO 260 I=1,IMXB1
C       WRITE(6,320)I,(ZB(I,J),J=J1,J2)
C 260  CONTINUE
C 270  CONTINUE
C
C        PRINT OUT HIGHEST LAND VALUE AT MOMENTUM GRID POINTS
C      WRITE(6,290)
C      WRITE(6,310)
C
C      DO  280 NN=1,NGRP
C      J1=2+(NN-1)*25
C      J2=J1+MIN0(24,JMXB1-J1)
C      WRITE(6,340)(J,J=J1,J2)
C      DO 280 I=2,IMXB1
C      WRITE(6,320)I,(ZBM(I,J),J=J1,J2)
C 280  CONTINUE
C
C 290  FORMAT(1H1)
C 300  FORMAT(/5X,'DEPTH FIELD.')
C 310  FORMAT(/5X,'HIGHEST ELEVATION (INCLUDING RIDGES, ROADS, ETC) AT M
C     1OMENTUM GRID POINTS.')
C 320  FORMAT(1H ,I2,26F5.0)
C 330  FORMAT(1H ,I2,26F5.1)
C 340  FORMAT(/I6,26I5)
C 350  CONTINUE
      RETURN
       END
C********************************************************************       
       SUBROUTINE CONTTY
C        JELESNIANSKI     SEPTEMBER 198TDL   IBM 360/195
C
C        PURPOSE
C           THIS SUBROUTINE (CONTTY) IS AN ALGORITHM FOR THE CONTINUITY
C           EQUATION, FOR AN IMAGE PLANE; POLAR COORDINATES ARE
C           TRANSFORMED ONTO THE IMAGE PLANE. THE SYSTEM AXIS ARE
C           (P,Q), BUT THE SUBROUTINE USES (I,J) FOR INTEGER SBSCRPTNG
C           TWO LEVELS IN TIME (FORWARD IN CONTTY PLUS BACKWARD IN MOMN)
C           ARE USED. THE GRID (SEE DIAGRAM BELOW) IS STAGGERED IN SPACE
C           A 5-POINT SCHEME (4 CORNERS OF A SQUARE) ARE USED FOR
C           THE MOMENTUM SPACE GRADIENT.
C
C              .****.****.         WHEN WATER DESCENDS BELOW SQUARE
C              *I-1 * I  *         (I,J), THE MOMENTUM ON 4-SURROUNDNG
C              * +  * +  *         CORNERS ARE REDUCED TO ALLOW THE
C              * J  * J  *         SQUARE TO BECOME DRY.  THE
C              .****.****.****.    PREVIOUSLY COMPUTED SURGES ON THE
C              *I-1 * I  *I+1 *    4-SURROUNDING SQUARES ARE UPDATED
C              * +  * +  * +  *    ACCORDING TO THE REVISED MOMENTUMS
C              *J-1 *J-1 *J-1 *    ON THE 4-CORNER POINTS OF (I,J).
C              .****.****.****.    SEE DIAGRAM BELOW FOR SUBSCRIPTING.
C
C********************************************************************
C        DATA SET USE
C
C        VARIABLES
C       IMXB1 JMXB1 = MAX SUBSCRIPTS FOR SURGE SQUARES
C        HB(  ,   ) = SURGE HEIGHTS
C       HSUB(  ,  ) = STORAGE FOR A SECOND COPY OF HB
C            IS(  ) = START LOOP, EXCLUDE HI TERRAIN, SET IN 'CRDRD2'
C            IB IFN = BEGINNING/ENDING A 'DO LOOP' IN I-DIRECTION
C             ISKIP = 1,FOR J=1,CHECK ZBM AT 2 BNDRY CORNERS FOR SKIPPIN
C                       STAATIC CONDITION.
C                     2,AND I=IMXB1 FOR BOTTOM BOUNDARY
C                     3,FOR J=JMXB1 FOR RIGHT BOUNDARY
C              JUMP = CONDITIONAL INTEGER FOR STANDARD LOOP,
C                     OR RETRIEVAL OF PREVIOUSLY COMPUTED SURGES,
C                     SEE DIAGRAM ABOVE FOR AFFECTED SQUARES
C              LEAP = CONDITIONAL 'GO TO' TO DRY AN (I,J) SQUARE,
C                     SEE DIAGRAM ABOVE FOR AN (I,J) SQUARE
C         IFST ISND = BEGIN/END I SUBSCRIPT ON UPDATED (J-1) SQUARES
C             IPASS = CONDITIONAL INTEGER, TO SET A SQUARE DRY
C         ZB(  ,  ) = DEPTHS AT CENTER OF SURGE SQUARES
C       IP(4) JP(4) = SHIFT SUBSCRIPTS TO 4 MOMENTUM POINTS
C     UB VB(  ,   ) = COMPONENTS OF MOMENTUM FIELDS
C              HPST = DUMMY VALUE FOR SUEGE VALUEC        
C           DUX DVY = COMPONENTS OF MOMENTUM GRADIENT
C               FCT = FACTOR TO MULTIPLY MOMENTUM GRADIENT
C              CHNG = SURGE PLUS DEPTHS (TO TEST FOR DRY SQUARE)
C              DENM = CHANGE IN SURGE, ONE TIME ITERATION
C              ANUM = CHANGE IN SURGE HT, TO TO DRY A SQUARE
C              RFCT = RATIO, <1, OF ANUM TO DENM, REDUCTION FACTOR
C              ISET = I-SUBSCRIPT FOR DRIED SQUARE
C
C        GENERAL COMMENTS
C           THIS SUBROUTINE RESIDES IN OVERLAY 'CMPUTE'. IT IS CALLED
C           IN BY SUBROUTINE 'CMPUTE'
C           THE SYSTEM ROUTINE 'ERRSET' IS USED TO ISOLATE VARIABLES
C           IF AN UNDER/OVERFLOW OCCURS; VARIABLE PRINT OUT IS
C           AIDED VIA 'HELP' AND THE 'COMMON/CHELP/'.
C
C           THE SUBSCRIPT FOR COMPUTATIONS OF SURGES ARE OFFSET (.5,.5)
C           FROM THE MOMENTUM POINTS. SEE BELOW:
C
C             (I,J)       (I,J+1)
C              .         .
C                                  .=MOMENTUM POINTS (UB,VB)
C                                  +=SURGE    POINTS (HB)
C                 (I,J)
C                   +
C                                  .=BARRIER  POINTS (ZBM)
C                                  +=DEPTH    POINTS (ZB)
C
C              .         .            IP(4)=0,1,1,0 JP(4)=0,0,1,1
C             (I+1,J)   (I+1,J+1)
C
      INCLUDE 'parm.for'
C
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      COMMON /DUMB8/  IP(4),JP(4),IH(4),JH(4)
      COMMON /DUM88/  IIH(4),JJH(4),IHH(4),JHH(4)
      COMMON /DUMB4/  X1B(10)
      COMMON /CHELP/  ANUM,DENM,RFCT,I,J,HBJ,HPST,UP(4),VP(4)
C
C        PRODUCE A DUPLICATE COPY OF HB(,) IN CASE WATER DECEND BELOW
C        GROUND.
      DO 100 J=1,JMXB
      DO 100 I=1,IMXB1
 100  HSUB(I,J)=HB(I,J)
C        SET UB,VB TO LOWER BOUNDS OR ZEROS TO AVOID UNDERFLOW.
      DO 110 J=2,JMXB1
      DO 110 I=2,IMXB1
      IF(ABS(UB(I,J)).GT.1.E-10) GO TO 110
      UB(I,J)=0.
      VB(I,J)=0.
 110  CONTINUE
C
C         SET PARAMETERS FOR J=1
C
      J=1
      IB=IS(J)
      IFN=IE(J)
      JUMP=4
      LEAP=1
      GO TO 130
C
C        BEGINING LOOP WHEN J DECENDS BY ONE FOR DRYING OF A SQUARE
C
 120  IB=IFST
      IFN=ISND
C
C        BEGINING OF REGULAR J LOOP FROM 1 THRU JMXB1
C
 130  CONTINUE
      IF (IFN.LT.IB) GOTO 330
      DO 320 I=IB,IFN
C
      IF (KSKP(I,J).EQ.'0') GOTO 320 
C       LEAP=1, REGILAR CASE. LEAP=2, RETURN TO THE SQUARE BEING DRIED.
C
      GO TO (170,160),LEAP
 160  IF(I.NE.IPASS) GO TO 170
      HB(I,J)=-ZB(I,J)
      LEAP=1
      GO TO 320
C
 170  CONTINUE
C
C        BYPASS CHECKINGS FOR DEPTH >30 FT, OR TERRAIN >  35 FT.
C
      DUX=-UB(I,J)+UB(I+1,J)+UB(I+1,J+1)-UB(I,J+1)
C
C        TEST FOR DEPTH > 30 FT
      IF(ZB(I,J).GT.30.) GO TO 210
C
C        TEST FOR DRY SQUARES, IF U'S AT 4 CORNERS ARE 0., OR DUX=0.
C        IN EQUIVALENCE.
      IF (DUX.EQ.0.) GO TO 320
C
C        CONTINUITY EQUATION.
 210  HPST=HSUB(I,J)
      Z=ELPDL2(I)+(ELPCL2(I)-ELPDL2(I))*SINL2(J)
      FCT=X1B(5)/Z
      DVY=-VB(I,J)-VB(I+1,J)+VB(I+1,J+1)+VB(I,J+1)
      HBJ=HPST-FCT*(DUX+DVY)
C
C        TEST IF SURGE IS BELOW DRY LAND, IF SO, SET SURGE TO LAND HGT.
C        REVISE SURROUNDING TRANSPORTS TO GIVE ZERO TOTAL DEPTH.
C
      CHNG=HBJ+ZB(I,J)
      IF (CHNG.GE.0.) GO TO 220
CCCCCC     MODIFICATION 10/27/99  RE-TESTED by Pro Fortran 09/20/01 
      IF (-CHNG.LT.1E-3) THEN
      HB(I,J)=-ZB(I,J)
      GOTO 320
      ENDIF
CCCCCC
      GO TO 230
 220  HB(I,J)=HBJ
      GO TO 320
C**********END OF LOOP FOR REGULAR RETURN*******************************
C
C***********************************************************************
C
C        READJUST TRANSPORTS TO ACCOUNT SUQARES DECENDING BELOW TERRAIN.
C
 230  CONTINUE
      IF (HSUB(I,J).EQ.-ZB(I,J)) GO TO 320
      DENM=HBJ-HPST
      DENM=SIGN(AMAX1(1.E-5,ABS(DENM)),DENM)
 240  ANUM=-ZB(I,J)-HPST
      RFCT=ANUM/DENM
 250  IF (RFCT.LT.0.) GO TO 260
C        RFCT SHOULD NORMALLY BE POSITIVE.
      IF (ABS(RFCT).LT.1.) GO TO 290
 260  CONTINUE
CC      WRITE(*,270)I,J,ZB(I,J),HPST,HBJ
CC      WRITE(*,280)RFCT,ANUM,DENM
 270  FORMAT (2I5,3F15.10)
 280  FORMAT (3F20.10)
 290  IF(ABS(RFCT).LT.1.E-5) RFCT=0.
      DO 300 K=1,4
      IA=I+IP(K)
      JA=J+JP(K)
      UB(IA,JA)=RFCT*UB(IA,JA)
      VB(IA,JA)=RFCT*VB(IA,JA)
 300  CONTINUE
C        RECOMPUTE 3 SQUARES ON J-1 LINE
      J=J-1
      JUMP=1
      ISET=I
      LEAP=1
      IF (J.EQ.0) GO TO 330
      IF (KSKP(I,J).EQ.'0') GOTO 330 
 310  IF (IS(J).GT.I) GO TO 330
      IFST=MAX0(I-1,IS(J))
      ISND=MIN0(I+1,IE(J))
      GO TO 120
 320  CONTINUE
 330  CONTINUE
C        INCREMENT J, OR CONTINUE ON OLD J LINE
      JUMP=JUMP+1
      LEAP=1
C        TEST FOR INCREMENTED OR OLD J
      IF (JUMP.NE.2) GO TO 340
C        OLD J LINE, WITH 2 OLD SQUARES TO BE UPDATED
      J=J+1
      LEAP=2
      IB=MAX0(ISET-1,IS(J))
      IFN=IE(J)
      IPASS=ISET
      GO TO 130
C        INCREMENT J FOR NEW COMPUTATION LINE
 340  J=J+1
      IF (J.GT.JMXB1) GO TO 350
      IB=IS(J)
      IFN=IE(J)
      GO TO 130
C
C***********  RETURN WITH A NEW J-LINE  **********************
C
 350  CONTINUE
      DO 360 I=1,IMXB1
 360  HB(I,JMXB)=HB(I,1)
C
      RETURN
       END
C********************************************************************       
      SUBROUTINE BDRYHT
C        JELESNIANSKI   SEPTEMBER 1980 TDL   IBM 360/195
C
C        PURPOSE
C           THIS SUBROUTINE (BDRYHT) COMPUTES STATIC HEIGHTS ON DEEP
C           WATER BOUNDARIES ONLY, SEE DIAGRAM BELOW:
C
C                             ITREE( , )
C                              =
C                           B.9   .
C                           O
C                           U  +
C                           N                  .*********.
C                           D.8   .            *         *
C                         | A*                 *         *
C                         / R* +               *         *
C                         / Y*                 *    +    * COSL,SINL
C                         /  .6    .            *         *
C                      DEEP  /    /            *         *
C                     WATERS /    /            *         *
C                         /  /    /            .*********.
C                         /  /    /                 |
C                         /  .6    .----.    .     
C                         /  *
C                         /  * +         +
C                         /  *
C                         V  .****.----.****.BOUNDARY---->
C                            6    6    8    9     4= ITREE(I,J)
C                                 DEEP
C                            <----WATERS---->
C
C
C           DEEP WATER CAN BE ON ONE, TWO OR NEITHER OF THE TWO SIDE
C           BOUNDARIES, BUT IT WILL EXIST AT LEAST ON A SEGMENT OF
C           THE CIRCLE WITH LARGEST RADIUS OF THE POLAR GRID.
C********************************************************************
C        DATA SET USE
C           NONE
C
C        VARIABLES
C             AX AY = COMPS OF TOTAL STRM MOTION, ADVANCED IN 'STMVAL'
C             C1 C2 = INITIAL COMPS OF STORM, SET IN 'INTVAL'
C COSL(  ) SINL(  ) = CO-SINE OF ANGLE, RAYS TO X-AXIS, (HEIGHT POINTS
C             IMXB1 = MAX I-SUBSCRIPT FOR HEIGHT POINTS
C            SEADTM = INITIAL HEIGHT OF THE SEA (NO STATIC HEIGHTS)
C         DELP(800) = STATIC HEIGHTS AT MILE INTERVALS FROM STORM CENTER
C        HB(  ,   ) = SURGE HEIGHTS
C        ITREE( , ) = A,   ON AT LEAST ONE BOUNDARY CORNER AS STATIC
C                     HEIGHT IS USED
C
C        GENERAL COMMENTS
C           THIS SUBROUTINE RESIDES IN OVERLAY 'CMPUTE'. IT IS CALLED
C           IN BY SUBROUTINE 'CMPUTE'.
C      THIS SUBROUTINE IS CALLED IN BY SUBROUTINE 'CONTTY'
C      WHICH RESIDES IN OVERLAY 'CMPUTE'
C
      INCLUDE 'parm.for'
C
      COMMON /BCPTS/  NBCPT,ISH(1600),JSH(1600)
      COMMON /DUMMY4/ S(800),C(800),P(800),DELP(800)
      COMMON /STRMSB/ C1,C2,C21,C22,AX,AY,PTENCY,RTENCY
C STIME interferes with C code, so switched to STIME2
      COMMON /STIME2/  ISTM,JHR,ITMADV,NHRAD,IBGNT,ITEND
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      COMMON /FRST/   X1(50),X12(50)
      COMMON /DATUM/  SEADTM,DTMLAK
C
C
C       BOUNDARY SQUARES DETERMINED IN SUBROUTINE DEPSFC
C
      DO 100 N=1,NBCPT
      I=ISH(N)
      J=JSH(N)
      XR=ELPCL(I)*COSL(J)
      YR=ELPDL(I)*SINL(J)
      X=XR-C1-AX
      Y=YR-C2-AY
      RSQ=X*X+Y*Y
      R1=SQRT(RSQ)/5280.+1.
      K=R1
      R2=K
      DR=R1-R2
      K=MIN0(K,790)
      HB(I,J)=DELP(K)+DR*(DELP(K+1)-DELP(K))+SEADTM
  100 CONTINUE
C
C      STATIC HEIGHTS ON SIDE BOUNDARIES
C
      RETURN
       END
      SUBROUTINE CHANNL
C        JELESNIANSKI   SEPTEMBER 1980 TDL   IBM 360/195
C
C        PURPOSE
C           THIS SUBROUTINE (CHANNL) COMPUTES TOTAL FLOW THROUGH A
C           PRISM, INVARIANT IN SPACE. THE PRISM BED IS HORIZONTAL.
C           THE HEAD BETWEEN THE TWO ENDS IS THE DRIVING FORCE TO PASS
C           WATER THRU THE CHANNEL. SEE GEOMETRY BELOW:
C
C                     XXXXXXXXXXXXXXXXXXXX
C                    X'                 XX
C                   X '                X X                      YL,Y0
C                  X  '               X  X                        ^
C                 X   '              X   X   Y0,YL                *
C              - XXXXXXXXXXXXXXXXXXXX    X     ^                  *
C              . X    '             X    X     *                  *
C              . X    '             X    X     *                  *
C              C X    '             X    X     *                  *
C              H X    '             X    X     *                  *
C              D X    ''''''''''''''X''''X    XXXXXXXXXXXXXXXXXXXXX
C              P X   '              X   X     <-----CHLNH--------->
C              H X  '               X  X H
C              . X '                X X T
C              . X'                 XX W
C              - XXXXXXXXXXXXXXXXXXXX H
C                                    C
C                <.....CHLNH........>
C
C           THE EQUATION USED FOR THE CHANNEL FLOW IS;
C
C           Q**2=(C1(YL**13/3-Y0**13/3))/(C2(YL**4/3-Y0**4/3)+CHLNH)
C
C        DATA SET USE
C           NONE
C
C        VARIABLES
C              NPSS = NUMBER OF PASSES
C          CHLNH(5) = LENGTH OF CHANNELS
C                 G = GRAVITY
C             Y0 YL = SURGE AT ENDS OF THE CHANNEL
C    IPTO JPTO(2,5) = POSITIONS FOR 2-SQUARES AT ONE CHANNEL END
C        HB(  ,   ) = SURGE HEIGHT
C          CHDPH(5) = CHANNEL DEPTHS
C    IPTL JPTL(2,5) = POSITIONS OF 2-SQUARES AT OTHER CHANNEL END
C         JPTL(2,5) = J-SUBSCRIPT FOR 2-SQUARES AT OTHER CHANNEL END
C               SIG = SIGN , + OR -
C             CDELY = CUT-OFF HEIGHT OF .1 FOOT FOR THE HEAD
C        AMAN-AGB13 = FIXED CONSTANTS
C              Q(5) = FLOW
C              DELT = UNIT TIME STEP
C          CHWTH(5) = WIDTH OF CHANNELS
C         EXTEXT(5) = TOTAL FLOW THROUGH CHANNEL
C
C        GENERAL COMMENTS
C           THIS SUBROUTINE RESIDES IN OVERLAY 'CMPUTE'. IT IS CALLED
C           IN BY SUBROUTINE 'CMPUTE'.
C
      INCLUDE 'parm.for'
C
      COMMON /FLWCPT/ NSQRS,NSQRW,NSQRWC,NPSS,NCUT
      COMMON /CHNLD/  CHLNH(5),CHWTH(5),CHDPH(5)
      COMMON /EGTH/   DELS,DELT,G,COR
      COMMON /CHNL/   IPT0(2,5),JPT0(2,5),IPTL(2,5),JPTL(2,5),ENTEXT(5)
      COMMON /CHNARA/ ARESQ0(5),ARESQL(5)
      COMMON /CHNLNO/ AMAN,BMAN,GB,AGB,AGB13
      DIMENSION Q(5)
      DATA Q/5*0./
      DATA CDELY/.1/
C
C        UPDATE HEIGHTS ON BOTH ENDS OF CHANNELS.(CONTINUITY)
C
      DO 110 NPASS=1,NPSS
      QWDT=Q(NPASS)*DELT
      DO 100 K=1,2
      I=IPT0(K,NPASS)
      J=JPT0(K,NPASS)
      II=IPTL(K,NPASS)
      JJ=JPTL(K,NPASS)
      HB(I,J)=HB(I,J)-.5*QWDT/ARESQ0(NPASS)
      HB(II,JJ)=HB(II,JJ)+.5*QWDT/ARESQL(NPASS)
      HB(I,J)=AMAX1(HB(I,J),-ZB(I,J))
      HB(II,JJ)=AMAX1(HB(II,JJ),-ZB(II,JJ))
 100  CONTINUE
 110  CONTINUE
C
C        COMPUTE FLOW FROM HEAD BETWEEN THE CHANNEL ENDS.
C
      DO 210  NPASS=1,NPSS
      CLNGTH=CHLNH(NPASS)*5280.
      GL=G*CLNGTH
      Y0=0.
      DO 120 K=1,2
      I=IPT0(K,NPASS)
      J=JPT0(K,NPASS)
 120  Y0=Y0+.5*HB(I,J)
      Y0=Y0+CHDPH(NPASS)
      YL=0.
      DO 130 K=1,2
      II=IPTL(K,NPASS)
      JJ=JPTL(K,NPASS)
 130  YL=YL+.5*HB(II,JJ)
      YL=YL+CHDPH(NPASS)
      SIG=1.
      IF(Y0.GT.YL) GO TO 140
      Z=Y0
      Y0=YL
      YL=Z
      SIG =-1.
 140  CONTINUE
      DELY=Y0-YL
C
C        DO NOT CONSIDER HEAD LESS THAN .1 FT,
      IF(DELY.LT.CDELY) YL=Y0-CDELY
C         INITIAL GUESS FOR NEWTON'METHOD. TEST FOR SUPER-CRITICAL FLOW.
      HIT=YL
      Y=Y0
      J=0
      AF=GL+GB*(Y**(4./3.))
      AF3=3.*AF
      AE=AMAN*(Y**(13./3.))
 150  HITO3=HIT**(1./3.)
      HIT2=HIT*HIT
      HIT3=HIT*HIT2
      HIT10=HIT3*HITO3
      HIT13=HIT*HIT10
      CNUM=AF*HIT3+AGB*HIT13-AE
      CDNM=AF3*HIT2+AGB13*HIT10
      HCRIT=HIT-CNUM/CDNM
      IF (ABS(HCRIT-HIT).LT.(.001)) GO TO 180
      J=J+1
      IF (J.GT.10) GO TO 160
      HIT=HCRIT
      GO TO 150
 160  CONTINUE
CC      WRITE(*,170)HCRIT,HIT
 170  FORMAT (10X,'TOO MAY ITERATIONS. HCRIT=',F10.3,' HIT=',F10.3)
 180  HIT=HCRIT
C
C        DO NOT PERMIT SUPER-CRITICAL FLOW.
      IF(YL.GT.HCRIT) GO TO 190
      QFLW= SQRT(G*HCRIT)*HCRIT
      GO TO 200
 190  Y0TRD=Y0**(1./3.)
      YLTRD=YL**(1./3.)
      Y04=Y0*Y0TRD
      YL4=YL*YLTRD
      Z=Y0*Y0
      Y013=Z*Z*Y0TRD
      Z=YL*YL
      YL13=Z*Z*YLTRD
      QFLWSQ=AMAN*(Y013-YL13)/(CLNGTH+BMAN*(Y04-YL4))
      QFLW=SQRT(ABS(QFLWSQ))
 200  CONTINUE
      Q(NPASS)=QFLW*SIG
      Q(NPASS)=Q(NPASS)*CHWTH(NPASS)
C        FOR HEAD < .1 FT,INTERPOLATE LINEARLY BETWEEN .1 AND 0.
      IF(DELY.LT.CDELY) Q(NPASS)=Q(NPASS)*DELY/CDELY
 210  CONTINUE
      RETURN
       END
C********************************************************************       
      SUBROUTINE FLW1DM
C        JELESNIANSKI   SEPTEMBER 1980 TDL   IBM 360/195
C
C        PURPOSE
C           THIS SUBROUTINE (FLW1DM) COMPUTES 1-DIM FLOW ACROSS CHANNEL
C           SIDES OF INTERLOCKING SQUARES. WATER PASSES ONLY THRU 'OPEN'
C           SIDES OF A 1-DIM FLOW CHANNEL, SEE DIAGRAM BELOW:
C
C                .****.****.****.****.        -FLOW     *NO FLOW
C                -    -    -    -    *        -THRU     *THRU
C                - +  - +  - +  - +  *        -CHANNEL  *CHANNEL
C                -    -    -    -    *        -SIDE     *SIDE
C                -****.****.****.----.
C                               *    *        (OPEN)    (CLOSED)
C                               * +  *
C                               *    *
C                               .----.
C           THE 'LOOP' OF THE CONTINUITY EQUATION FILLS/DEPLETES
C           TWO ADJOINING SQUARES WITH FLOW THRU AN 'OPEN' SIDE,
C           ONE SIDE AT A TIME. IF WATER DROPS BELOW A SQUARE
C           FROM THE ACTION OF AN 'OPEN' SIDE, THEN THE FLOW THRU
C           THE SIDE IS REDUCED TO EXHAUST WATER ONLY TO A DRY
C           SQUARE.
C
C           EACH 'OPEN' SIDE HAS AN INTERIOR AND AN EXTERIOR SQUARE.
C           SUBROUTINE 'CRDRD2' READS THE SUBSCRIPTS FOR INTERIOR
C           SQUARES AND SETS UP PROCEDURES TO ISOLATE THE
C           ADJOINING EXTERIOR SQUARES AND 'OPEN' SIDES VIA
C           'COMMON/DUMB18/'. THE PRESENT SUBROUTINE ISOLATES THE TWO
C           INTERIOR/EXTERIOR SQUARES AND THE ADJOINING SIDE FOR
C           1-DIM FLOW. A 1-DIM FLOW SQUARE CAN BE EITHER AN INT/EXT
C           SQUARE, OR BOTH, 1-4 TIMES, DEPENDING ON THE AMOUNT OF
C           'OPEN' SIDES BOUNDING A SQUARE.
C
C           I,J SHIFTS ABOUT AN (I,J) INTERIOR SQUARE FOR 4 POSSIBLE
C              EXTERIOR SQUARES ARE:
C
C                            .////.
C                            IHH=0/
C                            / 4+ /
C                            JHH=1/
C                       .////.////.////.
C                      IHH=-1/ I  /IHH=1
C                       / 1+ / +  / 2+ /
C                      JHH=0 / J  /JHH=0
C                       .////.////.////.
C                            IHH=0/
C                            / 3+ /
C                            JHH=-1
C                            .////.
C
C********************************************************************
C        DATA SET USE
C           NONE
C
C        VARIABLES
C           AI(800) = BOTTOM FRICTION, AT ONE FOOT INTERVALS
C             NSQRW = NO OF SQUARES WITH 1-DIM FLOW POSSIBLE
C  ISQR(L) JSQRL(L) = I/J-SUBSCRIPT FOR SQUARE WITH 1-DIM FLOW
C        HB(  ,   ) = SURGE FIELD
C        ISIDE(300) = SIDE OF FLOW RELATIVE TO INTERIOR 1-DIM FLOW SQRE
C     IHH(4) JHH(4) = SHIFT I/J-SUBSCRIPT FOR CONTIGUOUS SQUARE
C         HINT HEXT = INTERIOR/EXTERIOR SURGE FOR SFC GRADIENT
C       HINT1 HEXT1 = INTERIOR/EXTERIOR SURGE HEIGHTS ON SQUARES
C        ZBMIN(300) = LOWEST BARRIER VALUE AT END OF AN 'OPEN' SIDE
C                ZL = DUMMY VALUE FOR ZBMIN(300)
C         ZB(  ,  ) = DEPTH FIELD
C        HWEIR(300) = HIGHEST DEPTH  OF INT/EXT SQUARES, OR WEIR HEIGHT
C              HOVT = DUMMY VALUE FOR HWEIR(300)
C     FLWSQR(300  ) = TRANSPORT ACROSS AN 'OPEN' SIDE, TWO TIME LEVELS
C        GRIDR2(  ) = JACOBEAN FOR POLAR COORDINATES
C           SIGA(4) = SIGN FOR FLOW ACROSS SIDES OF SQUARES
C          DPH1D(2) = DEPTH+SURGE AT INT/EXT SQUARES, PRESENT TIME
C     CHNGHI CHNGHE = SURGE INCREASE ON INT/EXT SQRES, FROM 'OPEN' SIDE
C       DEPLI DEPLE = TOTAL DEPTH OF INT/EXT SQRES, FUTURE TIME
C               CII = ACCUMULATED WATER FROM 'OPEN' SIDES, INTERIOR SQR
C              SUBE = SURGE FROM EXT SQR TO PREVENT WATER BLW INT SQR
C         )    CEE = ACCUMULATED WATER FROM 'OPEN' SIDES, EXTERIOR SQR
C              SUBI = SURGE FROM INT SQR TO PREVENT WATER BLW EXT SQR
C            ID DPH = MEAN TOTAL DEPTH OF INT/EXT SQUARES, PRESENT TIME
C               DZL = HEIGHT OF HWEIR ABOVE MEAN DEPTHS
C           FXB FYB = COMPONENTS OF SURFACE STRESS
C            X1B(N) = FIXED COEFFICIENTS FOR FINITE DIFFERENCING
C   BR(300) BI(300) = FRICTION COEFFICIENTS AT 1-FOOT INTERVALS
C              JUMP = 2 FOR STRESS COMPUTATIONS, 1 FOR NO STRESS
C
C        GENERAL COMMENTS
C           THIS IS A VERSION FOR 2-STEP SCHEME (JULY 1981).
C           THIS SUBROUTINE RESIDES IN OVERLAY 'CMPUTE'. IT IS CALLED
C           IN BY SUBROUTINE 'CMPUTE'. SUBROUTINE 'FLW1DM' CALLS IN
C
C           SOME (NOT ALL) ELEVTNS ON INT/EXT SQRES AT PRESENT TIME ARE:
C
C                              T=ZL=ZBMIN(300)
C                              I
C                              I
C                              I
C                              I
C                              I***********>HINT=HB(I,JC)
C              HEXT<***********I      /
C                        /     I      /DPH1D(1)=HINT+ZB
C                        /     I      /
C                DPH1D(2)/     I----------->-ZB(I,J)
C                        /     I   /
C                        /     I   /
C                -ZB<----------I   /
C                          /   I   /
C                          /   I   /
C                          /   I   /
C                          /   I   /
C                 DEPTH=ZB=V   I   V=ZB=DEPTH
C             <----------------I----------------->NGVD DATUM
C                (EXTERIOR)        (INTERIOR)
C
      INCLUDE 'parm.for'
C
      COMMON /EGTH/   DELS,DELT,G,COR
      COMMON /SCND/   AR(600),AI(600),BR(600),BI(600),CR(600),CI(600)
      COMMON /DUMB4/  X1B(10)
      COMMON /DUMB8/  IP(4),JP(4),IH(4),JH(4)
      COMMON /DUM88/  IIH(4),JJH(4),IHH(4),JHH(4)
      COMMON /MF/     DPH,HPD(4),ID
      COMMON /FLWCPT/ NSQRS,NSQRW,NSQRWC,NPSS,NCUT
C
      DIMENSION       SIGA(4),DPH1D(2)
C
      DATA SIGA/-1.,1.,-1.,1./
C
      DO 100 L=1,NSQRWC
      I=ISQR(L)
      J=JSQR(L)
      K=ISIDE(L)
      II=I+IHH(K)
      JJ=J+JHH(K)
      HSUB(I,J)=0.
      HSUB(II,JJ)=0.
 100  F1DACT(L)='F'
C
CXXXXXXXXX BEGIN 1ST 'LOOP'. TREAT 2-DIM FLOW (FROM 'CONTTY') ONTO
CXXXXXXXXX A 1-DIM SQUARE AS A SOURCE.
C
      DO 510 L=1,NSQRWC
C
      IF (FLWSQR(L).EQ.0.) GO TO 510
C        ISOLATE A PARTICULAR SQUARE AND ITS SURFACE HEIGHT
      I=ISQR(L)
      J=JSQR(L)
C
C        DETERMINE WHICH OF 4 SIDES HAS FLOW AND ISOLATE ADJACENT SQUARE
C        AND ITS SURFACE HEIGHT
      K=ISIDE(L)
      II=I+IHH(K)
      JJ=J+JHH(K)
C
C        START CONTINUITY EQUATION FOR ONE SIDE OF A SQUARE
C        COMPUTE TOTAL FLOW IN/OUT OF INTERIOR SQUARE
 110  Z=ELPDL2(I)+(ELPCL2(I)-ELPDL2(I))*SINL2(J)
      Z1=ELPDL2(II)+(ELPCL2(II)-ELPDL2(II))*SINL2(JJ)
      CHNGHI=-SIGA(K)*X1B(5)*FLWSQR(L)/Z
      CHNGHE=-CHNGHI*Z/Z1
C
C     DETERMINE 1-DIM, OR EXPANSION, FLOW
      KCUT=1
      IF (L.GT.NSQRW) KCUT=2
      GO TO (120,130), KCUT
C
C     CHECK FOR EXISTENCE OF BANKS
 120  IF (DELCUT(L).GE.1.) GO TO 470
      GO TO 140
 130  LL=L-NSQRW
      IF (CUTLI(LL).GE.1..AND.CUTLE(LL).GE.1.) GO TO 420
C
C      TWO CASES EXIST: OUTFLOW VERSUS INFLOW
C      CASE 1: CHNGHI NEG (OUTFLOW), CHNGHE POS (INFLOW),  LEAP=1
C      CASE 2: CHNBHI POS (INFLOW),  CHNGHE NEG (OUTFLOW), LEAP=2
 140   LEAP=1
       IF (CHNGHI.GT.0.) LEAP=2
       GO TO (192,194),LEAP
 192   CHNG=CHNGHI
       CSTRT=CHNGHI
        HT=HB(I,J)
        BK=BANK(L,1)
        IF(KCUT.EQ.2) CUTW=CUTLI(LL)
        GO TO (200,300),LEAP
 194   CHNG=CHNGHE
       CSTRT=CHNGHE
       HT=HB(II,JJ)
       BK=BANK(L,2)
       IF(KCUT.EQ.2) CUTW=CUTLE(LL)
       GO TO (300,200),LEAP
C******LOGIC FOR NEGATIVE WATER CHANGES (OUTFLOW)
 200   IF (HT.GT.BK) GO TO 230
        GO TO (210,220),KCUT
C       INITIAL WATER BELOW BANK AND DESCENDING
 210   CHNG=CHNG
       GO TO 280
 220   CHNG=CHNG*CUTL(LL)/CUTW
       GO TO 272
C      INITIAL WATER ABOVE BANK AND DESCENDING
 230   DELB=HT-BK
       GO TO (240,260),KCUT
C      WATER DOES NOT DESCEND BELOW BANK, PURE 1-D FLOW
 240   IF(-CHNG*DELCUT(L).GT.DELB) GO TO 250
       CHNG=CHNG*DELCUT(L)
       GO TO 272
C      WATER DESCENDS BELOW BANK, PURE 1-D FLOW
 250   CHNG=CHNG-DELB+DELB/DELCUT(L)
       GO TO 272
C      WATER DOES NOT DESCEND BELOW BANK, CUT-TYPE FLOW
 260   IF (-CHNG*CUTL(LL).GT.DELB) GO TO 270
       CHNG=CHNG*CUTL(LL)
       GO TO 272
C      WATER DESCENDS BELOW BANK, CUT-TYPE FLOW
 270   CHNG=(CHNG*CUTL(LL)+DELB)/CUTW-DELB
 272   CONTINUE
 280   GO TO (290,295),LEAP
 290   CHNGHI=CHNG
       HSUB(I,J)=HSUB(I,J)+ABS(CSTRT-CHNG)
       GO TO 194
 295   CHNGHE=CHNG
       HSUB(II,JJ)=HSUB(II,JJ)+ABS(CSTRT-CHNG)
       GO TO 192
C$$$$$$LOGIC FOR POSITIVE WATER CHANGES (INFLOW)
 300   IF (HT.LT.BK) GO TO 330
       GO TO (310,320),KCUT
C      INITIAL WATER ABOVE BANK AND ASCENDING
 310   CHNG=CHNG*DELCUT(L)
       GO TO 372
 320   CHNG=CHNG*CUTL(LL)
       GO TO 372
C      INITIAL WATER BELOW BANK AND ASCENDING
 330   DELB=BK-HT
       GO TO (340,360),KCUT
C      WATER DOES NOT ASCEND ABOVE BANK, PURE 1-D FLOW
 340   IF (CHNG.GT.DELB) GO TO 350
       CHNG=CHNG
       GO TO 380
C      WATER ASCENDS ABOVE BANK, PURE 1-D FLOW
 350   CHNG=DELB+(CHNG-DELB)*DELCUT(L)
       GO TO 372
C      WATER DOES NOT ASCEND ABOVE BANK, CUT-TYPE FLOW
 360   IF (CHNG*CUTL(LL).GT.DELB*CUTW) GO TO 370
       CHNG=CHNG*CUTL(LL)/CUTW
       GO TO 372
C      WATER ASCENDS ABOVE BANK, CUT-TYPE FLOW
 370   CHNG=CHNG*CUTL(LL)-DELB*CUTW+DELB
 372   CONTINUE
 380   GO TO (390,395),LEAP
 390   CHNGHE=CHNG
       HSUB(II,JJ)=HSUB(II,JJ)+ABS(CSTRT-CHNG)
       GO TO 470
 395   CHNGHI=CHNG
       HSUB(I,J)=HSUB(I,J)+ABS(CSTRT-CHNG)
       GO TO 470
 420   CHNGHI=CHNGHI*CUTL(LL)/CUTLI(LL)
       CHNGHE=CHNGHE*CUTL(LL)/CUTLE(LL)
 470   HBJ=HB(I,J)+CHNGHI
      HBJJ=HB(II,JJ)+CHNGHE
C        FINISH CONTINUITY EQUATION FOR ONE SIDE OF A SQUARE BY
C        TESTING IF WATER LIES BELOW SQUARES
 480  DEPLI=HBJ+ZB(I,J)
      DEPLE=HBJJ+ZB(II,JJ)
      IF (DEPLI.GE.0.) GO TO 490
C        WATER LIES BELOW INTERIOR SQUARE (DEPLI IS NEGATIVE)
      CII=CHNGHI-DEPLI
      SUBE=-CII*Z/Z1
      HB(I,J)=-ZB(I,J)
      HB(II,JJ)=AMAX1(HB(II,JJ)-CHNGHE+SUBE,-ZB(II,JJ))
      FLWSQR(L)=FLWSQR(L)*CII/CHNGHI
      GO TO 510
C        WATER LIES BELOW EXTERIOR SQUARE (DEPLE IS NEGATIVE)
 490  IF(DEPLE.GE.0.) GO TO 500
      CEE=CHNGHE-DEPLE
      SUBI=-CEE*Z1/Z
      HB(I,J)=AMAX1(HB(I,J)-CHNGHI+SUBI,-ZB(I,J))
      HB(II,JJ)=-ZB(II,JJ)
      FLWSQR(L)=FLWSQR(L)*CEE/CHNGHE
      GO TO 510
C
C        BOTH INTERIOR AND EXTERIOR SQUARES HAVE WATER ABOVE TERRAIN
C        AFTER UPDATES.
 500  HB(I,J)=HBJ
      HB(II,JJ)=HBJJ
C
      F1DACT(L)='T'
 510  CONTINUE
C***********************************************************************
C        END OF HEIGHT UPDATES BY COMPUTED FLOW ACCROSS SIDES
C***********************************************************************
C
C        USE UPDATED HEIGHTS COMPUTE FLOW ACCROSS SIDES.
C
C        FRICTION CHANGE BETWEEN 1-2 FEET OF TOTAL DEPTH, USED
C        FOR EXTRAPOLATION FROM 1 TO 0 FT.
C        SET PARAMETERS FOR FRCPNT ARGUMENTS, LAKE WINDS, WITH STATIC
C        PRESSURE FORCE.
      SLPA=AI(2)-AI(1)
      NCATG=1
      NPLS=1
C
      DO 630 L=1,NSQRWC
C        ISOLATE A PARTICULAR SQUARE AND ITS SURFACE HEIGHT
      I=ISQR(L)
      J=JSQR(L)
      HINT=HB(I,J)
C        DETERMINE WHICH OF 4 SIDES HAS FLOW AND ISOLATE ADJACENT SQUARE
C        AND ITS SURFACE HEIGHT
      K=ISIDE(L)
      II=I+IHH(K)
      JJ=J+JHH(K)
      HEXT=HB(II,JJ)
C        ISOLATE MINIMUM ZBM ON SIDE CONNECTING TWO SQUARES
      ZL=ZBMIN(L)
C        TEST IF SFC LIES ABOVE ZL, E.G., 2-DIM FLOW IN BOTH SQUARES
      IF (AMIN1(HINT,HEXT).GE.ZL) GO TO 520
C        TEST IF BOTH SQUARES ARE DRY
      IF (HINT.EQ.-ZB(I,J).AND.HEXT.EQ.-ZB(II,JJ)) GO TO 520
C        DETERMINE HT OF WEIR OR HIGHEST DEPTH OF TWO SQUARES
      HOVT=HWEIR(L)
C        TEST IF ANY SQUARE(S) OVERTOP THE WEIR AT PRESENT TIME
      IF(AMAX1(HINT,HEXT).GT.HOVT) GO TO 530
 520  FLWSQR(L)=0.
      HSUB(I,J)=0.
      HSUB(II,JJ)=0.
      GO TO 630
 530  CONTINUE
C        COMPUTE MOMENTUM ON ONE SIDE OF A SQUARE
      HINT1=HB(I,J)
      HEXT1=HB(II,JJ)
      HINT=AMIN1(AMAX1(HINT1,HOVT),ZL)
      HEXT=AMIN1(AMAX1(HEXT1,HOVT),ZL)
      JUMP=2
      IF (AMAX1(HINT,HEXT).GE.ZL) JUMP=1
      HEAD=HEXT-HINT
      HEAD=SIGA(K)*HEAD
      DPH1D(1)=HINT+ZB(I,J)
      DPH1D(2)=HEXT+ZB(II,JJ)
      DPH=.5*(DPH1D(1)+DPH1D(2))
CCCCCCCCCCC Arthur fix of dph close to 0.
      if (dph.lt.0.00000001) then
        FLWSQR(L)=0.
        HSUB(I,J)=0.
        HSUB(II,JJ)=0.
        GO TO 630
      end if
CCCCCCCCCCC Arthur end fix of dph close to 0.
      ID=DPH
      ID=AMIN1(599.,DPH)
      ID=MAX0(ID,1)
      BIOBR=BI(ID)/BR(ID)
      IF (NSQRW.EQ.NSQRS) GOTO 1492
          IF (L.GT.NSQRS.AND.L.LE.NSQRW) BIOBR=0.
 1492 CONTINUE
      HCOFF=BR(ID)+BI(ID)*BIOBR
      FLWT=-X1B(1)*HCOFF*DPH*HEAD
         IF (JUMP.EQ.1)  GOTO 589
C
C        AVERAGE SHELTERING COEFF IF WATER BECOME LESS THAN 1 FT ABOVE
C        BED,OR 1 FT BELOW CHANNEL BANK,OR BARRIER HEIGHT.
      IF (KTREE(L).EQ.'T') THEN
         CSHLTR=(DPH/50.)**2
       ELSE
         CSHINT=1.-DIM(1.,DIM(HINT1,HOVT))
         CSHEXT=1.-DIM(1.,DIM(HEXT1,HOVT))
         CSH2I=1.-DIM(1.,DIM(ZL,HINT1))
         CSH2E=1.-DIM(1.,DIM(ZL,HEXT1))
         CSHLTR=.5*AMIN1(CSHINT+CSHEXT,CSH2I+CSH2E)
       ENDIF
C
      III=I
      JJJ=J
      GO TO (116,112,113,114),K
C        COMPUTE (X,Y) POSITION OF FORCE POINTS ON POLAR GRID
 112  III=I+1
 116  XR0=COSL(JJJ)
      YR0=SINL(JJJ)
      ELPCZ=ELPCT(III)
      ELPDZ=ELPDT(III)
      GO TO 115
 114  JJJ=J+1
 113  XR0=COST(JJJ)
      YR0=SINT(JJJ)
      ELPCZ=ELPCL(III)
      ELPDZ=ELPDL(III)
 115  CONTINUE
      XR=XR0*ELPCZ
      YR=YR0*ELPDZ
C RA Dominguez 4/27/12
      CALL FRCPNT(XR,YR,FXB,FYB,NCATG,CSHLTR,NPLS,FXX,FYY,I,J)
C        CHANGE FORCING FROM (X,Y) SYSTEM TO IMAGE PLANE
      XR=XR0*ELPDZ
      YR=YR0*ELPCZ
      FXBP=XR*FXB+YR*FYB
      FYBP=XR*FYB-YR*FXB
C        CORRECT STRESS DIRECTION ACCORDING TO ACTURAL FLOW
      IF(COS1D(L).NE.1.) THEN
      FXB=COS1D(L)*FXBP-SIN1D(L)*FYBP
      FYB=SIN1D(L)*FXBP+COS1D(L)*FYBP
      ELSE
      FXB=FXBP
      FYB=FYBP
      ENDIF
C
      FRC1=.75*FXB
      FRC2=.75*FYB
      IF (K.EQ.3.OR.K.EQ.4) THEN
      Z=FRC2
      FRC2=-FRC1
      FRC1=Z
      ENDIF
C
      FRC12T= DELT*(FRC1+BIOBR*FRC2)
C           ENDED STRESS COMPUTATIONS.
      GOTO 590
C
C        INITIALIZE FLOW WITH GRAVITY AND WITHOUT SURFACE STRESS
 589  FRC12T=0.
C
 590   CONTINUE
C        TAKE AVERAGE OF 'AI' ON TWO SQUARES
      AINTRP=0.
      DO 620 KK=1,2
      IDD=AMIN1(299.,DPH1D(KK))
      IF (IDD.GT.1) GO TO 600
      AITR=AI(1)+SLPA*(DPH1D(KK)-1.)
      GO TO 610
 600  SLPAI=AI(IDD+1)-AI(IDD)
      DPHI=IDD
      AITR=AI(IDD)+SLPAI*(DPH1D(KK)-DPHI)
 610  AINTRP=AINTRP+AITR
 620  CONTINUE
      AINTRP=.5*AINTRP
      FLWCOF=X1B(4)*(AINTRP-AR(ID)*BIOBR)+1.
      FLW=FLWT+FLWCOF*FLWSQR(L)+FRC12T
      FWD=HSUB(II,JJ)-HSUB(I,J)
      IF (FWD.EQ.0.) GO TO 628
      FD2=-SIGA(K)*FWD*X1B(2)/(DPH*DPH)
      FD2=ABS(FD2)
      Z=ELPDL2(I)+(ELPCL2(I)-ELPDL2(I))*SINL2(J)
      Z1=ELPDL2(II)+(ELPCL2(II)-ELPDL2(II))*SINL2(JJ)
      XY=.5*(1./Z+1./Z1)
      FD2=FD2*XY
      FLW1=FLW
      DO 627 ITR=1,20
      FLW1=FLW/(1.+FD2*ABS(FLW1))
 627  CONTINUE
      FLWSQR(L)=FLW1
      GO TO 630
 628  FLWSQR(L)=FLW
 630  CONTINUE
C++++++++END MOMENTUM COMPUTATIONS FOR 1-DIM FLOW+++++++++++++++++++++++
C
C--------END MAIN 'LOOP'------------------------------------------------
      RETURN
       END
C********************************************************************       
      SUBROUTINE FRCPNT(X,Y,FXB,FYB,NCATG,CSHLTR,NPLS,FXX,FYY,I,J)
C        JELESNIANSKI   SEPTEMBER 1980 TDL   IBM 360/195
C
C        PURPOSE
C           THIS SUBROUTINE (FRCPNT) COMPUTES COMPONENTS OF SURFACE
C           DRIVING FORCES AT A MOMENTUM GRID POINT. ENTRY VALUES FOR
C           COMPUTATIONS ARE THRU 'COMMON/MF/'. THE LAKE WINDS ARE
C           DISTORTED ACCORDING TO FORWARD SPEED ALONG TRACK; OCEAN
C           WINDS ARE NOT DISTORTED.
C********************************************************************
C        DATA SET USE
C           NONE
C
C        VARIABLES
C            CSHLTR = EXTINCTION COEF OF STRESS FOR WATER LESS THAN 1 FT
C             AX AY = COMPONENTS OF TOTAL STORM TRAVERSE
C             C1 C2 = INITIAL (X,Y) STORM POSITION, SET IN 'INTVAL'
C            X12(4) = RADIUS OR MAX WIND IN FEET
C           X12(15) = SQUARE OF X12(4)
C    X12(9) X12(10) = COMPONENTS OF FORWARD SPEED, 1ST HOUR
C               C19 = FRIC CFFCNT (3X10-6)
C          W1218(2) = TWICE THE MAXIMUM WINDS, SET IN 'CMPUTE'
C            CSHLTR = STRESS SHELTERING COEFFICIENT, FOR DEPTHS<1 FT
C   CW(800) SW(800) = INFLOW ANGLE, MILE INCRMNT, LAKE WINDS
C     C(800) S(800) = INFLOW ANGLE, MILE INCRMNT, OCEAN WINDS
C  BI BR CI CR(800) = FRICTION FACTORS
C            P(800) = PRESSURE GRADIENT, MILE INTERVALS
C           FXX FYY = COMPONENTS OF STRESS
C           PXX PYY = COMPONENTS OF SURFACE PRESSURE GRADIENT FORCE
C         FXBP FYBP = COMPONENTS OF SURFACE DRIVING FORCES IN (X,Y)
C           FXB FYB = COMPONENTS OF SURFACE FORCES ON IMAGE PLANE
C
C        GENERAL COMMENTS
C           THIS SUBROUTINE LIES IN OVERLAY 'CMPUTE'. IT IS CALLED IN
C           BY SUBROUTINE 'MOMNTM'. SUBROUTINE 'MOMNTM' LIES IN
C           SUBROUTINE 'CMPUTE'.
C
C      COMMON /SLAT/   FSOUTH
      include 'parm.for'
      COMMON /FRST/   X1(50),X12(50)
      COMMON /FRTH/   IC12,IC19,BT
      COMMON /THRD/   C7,C17,C19,C25
      COMMON /STRMSB/ C1,C2,C21,C22,AX,AY,PTENCY,RTENCY
      COMMON /DUMY44/ SW(800),CW(800),W1218(2),WMAX(2)
      COMMON /DUMMY4/ S(800),C(800),P(800),DELP(800)
      COMMON /SCND/   AR(600),AI(600),BR(600),BI(600),CR(600),CI(600)
      COMMON /MF/     DPH,HPD(4),ID
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      INTEGER ::   KK
      REAL :: pi
      REAL :: AYLG1, AYLG2, AYLT1, AYLT2

C        COMPUTING FORCE AT A GRID POINT
      XP=X-C1-AX
      YP=Y-C2-AY
      RSQ=XP*XP+YP*YP
      RS=SQRT(RSQ)
      R1=RS/5280.+1.
      K=R1
      R2=K
      DR=R1-R2
C UND
      pi = 2*ACOS(0.0)            
      AYLT1 = (YLT(1,1)+YLT(1,JMXB))/2
      AYLT2 = (YLT(IMXB,1)+YLT(IMXB,JMXB))/2
      AYLG1 = (YLG(1,1)+YLG(1,JMXB))/2
      AYLG2 = (YLG(IMXB,1)+YLG(IMXB,JMXB))/2      
      DLAT = (AYLT2-AYLT1)*111200.0d0
      DLON = (AYLG2-AYLG1)*ABS(111200.0d0*COS(AYLT1*pi/180.0d0))
      ADJANG = -ATAN(DLON/DLAT)
C
C        VECTOR WIND IS CONSTANT FOR DISTANCE >790 MLS FRM STM CENTER
      K=MIN0(K,790)
      CCN=X12(15)+RSQ
      X1218=W1218(NCATG)
         IF (NCATG.EQ.1) THEN
C        COMPUTE LAKE WINDS
      CK1=CW(K)+DR*(CW(K+1)-CW(K))
      SK1=SW(K)+DR*(SW(K+1)-SW(K))
      ELSE
C        COMPUTE OCEAN WINDS
      CSHLTR=1.
      CK1=C(K)+DR*(C(K+1)-C(K))
      SK1=S(K)+DR*(S(K+1)-S(K))
         ENDIF
C
      A=RS*X12(9) -X1218*(YP*CK1+XP*SK1)
      B=RS*X12(10)+X1218*(XP*CK1-YP*SK1)
C
C        FSOHTH=-1. FOR SOUTHERN HEMISPHERE, CLOCKWISE CIRCLULATION;
C              = 1. FOR NORTHERN HEMISPHERE, COUNTER-CLOCKWISE CIRCULATION.
C
c      A=RS*X12(9) +X1218*(-FSOUTH*YP*CK1-XP*SK1)
c      B=RS*X12(10)+X1218*( FSOUTH*XP*CK1-YP*SK1)

C             COMPUTE WIND DISTORTION, FROM LAND EFFECTS, FOR LAKE WINDS
      IF (NCATG.EQ.1) THEN
      RHOL=ABS(XP*X12(20)+YP*X12(21))
      CCC=CCN*RHOL/(X12(15)+RHOL*RHOL)
      A=A+CCC*X12(23)
      B=B+CCC*X12(24)
       ENDIF
C       WIND COMPONENTS (A,B), FT/SEC, IN X,Y DIRECTIONS
         A=A*X12(4)/CCN
         B=B*X12(4)/CCN
C UND      
      KK = ichar(WNFILE(1:1))
      if ((KK.NE.0).AND.(KK.NE.32)) then
        B = (GWXX(I,J)*COS(-ADJANG)-GWYY(I,J)*SIN(-ADJANG))*3.28084
        A = -(GWXX(I,J)*SIN(-ADJANG)+GWYY(I,J)*COS(-ADJANG))*3.28084
      else
        GWYY(I,J) = -(A*COS(ADJANG)-B*SIN(ADJANG))/3.28084
        GWXX(I,J) = (A*SIN(ADJANG)+B*COS(ADJANG))/3.28084
      end if               
C       STRESS =DRAG COEFF* SPEED * WIND VECTOR
C       STRESS REDUCTION FOR WATER LESS THAN 1 FT, AND SPIN-UP PERIOD   
      FCTT=C19*SQRT(A*A+B*B)
      FCTT=FCTT*CSHLTR*BT
      FXX=FCTT*A
      FYY=FCTT*B
C UND  (Applying Spin-Up)
      KK= ichar(STFILE(1:1))
      if ((KK.NE.0).AND.(KK.NE.32)) then
        FYY = (GFXX(I,J)*COS(-ADJANG)-GFYY(I,J)*SIN(-ADJANG))*3.28084*3.28084
     &        *BT
        FXX = -(GFXX(I,J)*SIN(-ADJANG)+GFYY(I,J)*COS(-ADJANG))*3.28084*3.28084
     &        *BT        
      else
        GFYY(I,J) = -(FXX*COS(ADJANG)-FYY*SIN(ADJANG))/3.28084/3.28084
        GFXX(I,J) = (FXX*SIN(ADJANG)+FYY*COS(ADJANG))/3.28084/3.28084
      end if      
      FXB=CR(ID)*FXX-CI(ID)*FYY
      FYB=CR(ID)*FYY+CI(ID)*FXX
C        PRESSURE TERM IN THE FORCING FUNCTIONS
C        SKIPS IF INTERMEDIATE WATER B. C IS USED.
      IF (NPLS.NE.0) THEN
        AA = -DPH * ( P(K) + DR*(P(K+1)-P(K)) )
        PXX=AA*XP
        PYY=AA*YP
C UND        
        KK = ichar(PRFILE(1:1))
        if ((KK.NE.0).AND.(KK.NE.32)) then
          PYY = -(GPXX(I,J)*COS(-ADJANG)-GPYY(I,J)*SIN(-ADJANG))*DPH*32.174
          PXX = (GPXX(I,J)*SIN(-ADJANG)+GPYY(I,J)*COS(-ADJANG))*DPH*32.174
        else
          GPYY(I,J) = (PXX*COS(ADJANG)-PYY*SIN(ADJANG))/DPH/32.174
          GPXX(I,J) = -(PXX*SIN(ADJANG)+PYY*COS(ADJANG))/DPH/32.174
        end if
C METRIC FORCING      
      GFWY(I,J) = -(FXB*COS(ADJANG)-FYB*SIN(ADJANG))/3.28084/3.28084
      GFWX(I,J) = (FXB*SIN(ADJANG)+FYB*COS(ADJANG))/3.28084/3.28084
      GFPY(I,J) = -((BR(ID)*PXX-BI(ID)*PYY)*COS(ADJANG)-
     & (BR(ID)*PYY+BI(ID)*PXX)*SIN(ADJANG))/3.28084/3.28084
      GFPX(I,J) =  ((BR(ID)*PXX-BI(ID)*PYY)*SIN(ADJANG)+
     & (BR(ID)*PYY+BI(ID)*PXX)*COS(ADJANG))/3.28084/3.28084
C      
        FXB = FXB + BR(ID)*PXX - BI(ID)*PYY
        FYB = FYB + BR(ID)*PYY + BI(ID)*PXX
      ENDIF
C      
      RETURN
       END
C********************************************************************       
       SUBROUTINE MOMNTM
C        JELESNIANSKI,CHEN   SEPTEMBER 1980 TDL   IBM 360/195
C
C        PURPOSE
C           THIS SUBROUTINE (MOMNTM) COMPUTES FUTURE MOMENTUM COMPONENTS
C           ON ALL INTERIOR GRID POINTS, AFTER FIRST COMPUTING FUTURE
C           SURGE BY SUBROUTINE 'CONTTY'. IT CHECKS IF MOMNTM CAN EXIST
C           AT A GRID POINT; E.G.,  OVERTOPPING THE GRID POINT .
C           FUTURE SURGES UPDATED FROM SUB. 'CONTTY' ARE USED TO COMPUTE
C           HEIGHT GRADIENTS AND TO CHECK FOR ELIGIBLE MOMENTUM POINTS--
C           BACKWARD SCHEME---. CHECKS ARE MADE IF MOMENTUM IS TO BE
C           COMPUTED AT OPEN BOUNDARY POINTS.
C********************************************************************
C        DATA SET USE
C           NONE
C
C        VARIABLES
C             NCATG = 1 FOR LAKE WINDS, 2 FOR OCEAN WINDS
C              NPLS = 0 REMOVE STATIC PRESSURE TERM IN FORCING(INT.B.C.)
C                   = 1  OTHERWISE
C             JMXB1 = MAX NO. OF J-POINTS, LESS A BOUNDARY POINT
C              JUMP = 1, FULLY FLOODED; 2,PARTIALLY FLOODED (NO STRESS)
C            MS(  ) = BEGIN I-SUBSCRIPT ON A J-LINE
C       ITREE( ,  ) = INDICATOR ARRAY FOR LAKE/OCEAN, TREE/NO TREE
C                     A,B,C,D FOR BNOUDARY TYPES
C        ZBM(  ,  ) = MAXIMUM BARRIER HT AT A SURGE POINT
C       IH(4) JH(4) = SHIFT I/J-SUBSCRIPTS TO 4 SURRNDNG SRGE PTS
C       IP(4) JP(4) = SHIFTS I/J-SUBPTS FROM SURGE PTS TO 4 MOM. CORNERS
C        HB(  ,   ) = SURGE HEIGHTS
C         ZB(  ,  ) = DEPTHS
C             HF(4) = STORAGE FOR 4 SURRNDNG SURGE PTS,
C            HPD(4) = STORAGE FOR 4 SURRNDNG TOTAL DEPTH POINTS
C     UB VB(  ,   ) = COMPONENTS OF TRANSPORT
C           DHX DHY = COMPONENTS OF SURFACE GRADIENT
C            ID DPH = MEAN TOTAL DEPTH
C   AI(300) AR(300) = FRICTION COEFFICIENTS ON TRANSPORTS
C           FXB FYB = COMPONENTS OF DRIVING FORCES
C           X1B(4)  = DEL*CORIOLIS PARM
C            CSHLTR = EXTINCTION COEF OF STRESS FOR WATER LESS THAN 1 FT
C             ISKIP = 1, COMPUTE MOMENTUM ON J=1    BOUNDARY
C                     2, COMPUTE MOMENTUM ON I=2 BOUNDARY
C                     3, COMPUTE MOMENTUM ON J=JMXB BOUNDARY
C                     4, COMPUTE MOMENTUM ON I=IMXB BOUNDARY
C             IJUMP = 1, SHALLOW WATER BOUNDARY COMPUTATIONS
C                     2, INTER DEPTH   BOUNDARY COMPUTATIONS
C    ISBS JSBS(4) = SHIFT SUBSCRIPTS FROM INTERIOR TO BOUNDARY PT
C         ISHF(3,4) = SUBSCIPTS SHIFTS FROM INTERIOR TO 3 CORNER
C                     MOM-POINTS FOR ALL 4 CORNERS
C
C        GENERAL COMMENTS
C           THIS SUBROUTINE RESIDES IN OVERLAY 'CMPUTE'. IT IS CALLED
C           IN BY SUBROUTINE 'CMPUTE'. THE PRESENT SUBROUTINE CALLS
C           IN 2 SUBROUTINES, 'FRCPNT' AND 'MNTMBD'.
C
C
      INCLUDE 'parm.for'
C
      COMMON /FRTH/   IC12,IC19,BT
      COMMON /MF/     DPH,HPD(4),ID
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      COMMON /EGTH/   DELS,DELT,G,COR
      COMMON /SCND/   AR(600),AI(600),BR(600),BI(600),CR(600),CI(600)
      COMMON /DUMB8/  IP(4),JP(4),IH(4),JH(4)
      COMMON /DUM88/  IIH(4),JJH(4),IHH(4),JHH(4)
      COMMON /DUMB4/  X1B(10)
      COMMON /DUMB4I/ CORL(90)
      COMMON /GPRT1/  DOLLAR,EBSN
      DIMENSION     SLPAI(600),HFX(4),ISBS(4),JSBS(4),ISHF(3,4)
      CHARACTER*2   DOLLAR,SIG_
      CHARACTER*1   EBSN
      DATA ISBS/0,-1,0,1/,  JSBS/-1,0,1,0/
      DATA SIG_/'$'/,SHGT/50./
      DATA ISHF/1,2,4, 1,2,3, 1,3,4, 2,3,4/
C       PRECALCULATED SLOPES OF AI(ID). MAY BE PERMANENTLY STORED.
      DO 10 I=1,599
 10   SLPAI(I)=AI(I+1)-AI(I)
      SLPAI(600)=SLPAI(599)
C
      JEND=JMXB1
      IF (DOLLAR.EQ.SIG_) JEND=JMXB
C
      DO 570 J=2,JEND
C
C         ISKIP SET 3 RANGES FOR J
C
      ISKIP=2
C        FOR CILCULAR ISLAND, NO SIDE-BOUNDARIES (1 OR 3) TO BE TESTED.
C        FOR J=1, U/V  REPEAT THOSE AT J=JMXB (JEND).
      IF (DOLLAR.NE.SIG_) THEN
        IF(J.EQ.2) ISKIP=1
        IF(J.EQ.JEND) ISKIP=3
        ENDIF
C
      IST=MS(J)
      IFN=ME(J)
C        SKIP A J-COLUMN IF MS(J) IS SET TO IMXB OR GREATER.
      IF ((IFN-IST).LT.0) GO TO 570
C
      DO 560 I=IST,IFN
      JUMP=1
C        NO TERRAIN HIGHER THAN 35 FT CAN BE FLOODED.
c
      IF (ITREE(I,J).EQ.'4'.OR.ITREE(I,J).EQ.'6') GO TO 560
C        ITREE IS SET TO 1 OR 3 FOR LAKE WINDS, 2 OR 5 FOR OCEAN WINDS
        IF (ITREE(I,J).EQ.'2'.OR.ITREE(I,J).EQ.'5') THEN
         NCATG=2
         ELSE
         NCATG=1
         ENDIF
      IF (NCATG.EQ.1) GOTO 140
      IF (ITREE(I,J).EQ.'2'.AND.ZBM(I,J).LT.-50.) GOTO 160
C
C      TEST IF SURRNDNG SQRS ARE DRY, PART/FULL FLOOD .
C
 140  CONTINUE
c
      HMN=AMIN1(HB(I,J),HB(I-1,J),HB(I,J-1),HB(I-1,J-1))
      IF (HMN.GT.ZBM(I,J)) GO TO 200
      HMXX=AMAX1(HB(I,J),HB(I-1,J),HB(I,J-1),HB(I-1,J-1))
      IF (HMXX.GT.ZBM(I,J)) GO TO 300
C       NO TRANSPORTS ARE ALLOWED, GO TO CHECK IF NEXT TO BOUNDARY.
      GO TO 220
C        ALL SURROUNDING SQUARES ARE FLOODED, CALCULATE GRADIENT TREM
C        WITH CENTER DIFFERENCES
 200  JUMP=1
      DHX=-HB(I-1,J-1)+HB(I,J-1)-HB(I-1,J)+HB(I,J)
      DHY=-HB(I-1,J-1)-HB(I,J-1)+HB(I-1,J)+HB(I,J)
      GO TO 340
C
C        AT LEAST ONE SQUARE IS NOT OVERTOPPED. USE HYDRULIC HEAD FOR
C        SLOPE ON THAT SQUARE (1/4 EFFECT) AS APPROXMATION
 300  JUMP=2
C      DEFINE A MODIFIED SURFACE GRADIENT FOR A PARTIALLY FLOODED POINT
      HF1=AMAX1(HB(I-1,J-1),ZBM(I,J))
      HF2=AMAX1(HB(I  ,J-1),ZBM(I,J))
      HF3=AMAX1(HB(I-1,J  ),ZBM(I,J))
      HF4=AMAX1(HB(I  ,J  ),ZBM(I,J))
      DHX=-HF1+HF2-HF3+HF4
      DHY=-HF1-HF2+HF3+HF4
C
C        TAKE AVERAGE (D+H), OR TOTAL DEPTH, OF 4 SURROUNDING SQUARES
C        USED TO DEFINE BOTTOM STRESS COEFFICIENTS
 340  CONTINUE
      HPD(1)=HB(I-1,J-1)+ZB(I-1,J-1)
      HPD(2)=HB(I  ,J-1)+ZB(I  ,J-1)
      HPD(3)=HB(I-1,J  )+ZB(I-1,J  )
      HPD(4)=HB(I  ,J  )+ZB(I  ,J  )
      DPH=.25*(HPD(1)+HPD(2)+HPD(3)+HPD(4))
      DPHZ=DPH
      ID=AMIN1(599.,DPHZ)
C
C        FOR VERY THIN SHEET OF WATER ON BARE TERRAIN, BOTTOM FRICTIONS
C        ARE ARTIFICIALLY INCREASED WITH A CUBIC FORMULA
      IF (DPH.GT.5.) GO TO 405
C        IT IS UNNECESSARY IF PARTIALLY FLOODED.
      IF (JUMP.EQ.2) GO TO 400
C
C        REVISE DPH AND ID
      DO 380 K=1,4
      IF(HPD(K).GE.5.) GO TO 370
C        USE ALTERNATIVE X-1+(1-X/5)**3 = X*(.4+.12*X-.008*X**2)
      HPD(K)=HPD(K)*(.4+.12*HPD(K)-.008*HPD(K)*HPD(K))
      GO TO 380
 370  HPD(K)=HPD(K)-1.
 380  CONTINUE
C
      DPH=.25*(HPD(1)+HPD(2)+HPD(3)+HPD(4))
      DPHZ=DPH
      ID=AMIN1(599.,DPHZ)
 400  ID=MAX0(1,ID)
C
C+++++++ TAKE AVERAGE 'AI(TOTAL DEPTH)' ON 4 SQUARES++++++++++++++++++++
C        EXTRAPOLATION IF DPH IS LESS THAN 1 FT
 405  AINTRP=0.
      DO 430 K=1,4
      DPHZ=HPD(K)
      IDD=MIN(599.,DPHZ)
      IDD=MAX0(IDD,1)
C        EXTRAPOLATION RESULTS IF DEPTH IS LESS THAN 1 FT.
      DPHI=IDD
      AITR=AI(IDD)+SLPAI(IDD)*(DPHZ-DPHI)
 420  AINTRP=AINTRP+AITR
 430  CONTINUE
      AINTRP=.25*AINTRP
      GOTO 450
C
C        ALL SURROUNDING SQUARES ARE FLOODED
 160  CONTINUE
      JUMP=1
      DHX=-HB(I-1,J-1)+HB(I,J-1)-HB(I-1,J)+HB(I,J)
      DHY=-HB(I-1,J-1)-HB(I,J-1)+HB(I-1,J)+HB(I,J)
      DPH=.25*(HB(I-1,J-1)+HB(I,J-1)+HB(I-1,J)+HB(I,J)+
     1         ZB(I-1,J-1)+ZB(I,J-1)+ZB(I-1,J)+ZB(I,J))
      DPHZ=MIN(599.,DPH)
      ID=MIN(599.,DPHZ)
      DPHI=ID
      AINTRP=AI(ID)+SLPAI(ID)*(DPHZ-DPHI)
C
 450  AII=1.+X1B(4)*AINTRP
C
C      CORIOLIS PARAMETER DEPENDS ON THE THE LATITUDE OF THE GRID.
      LLAT=YLT(I,J)
      ZCOR=CORL(LLAT+1)+(YLT(I,J)-LLAT)*(CORL(LLAT+2)-CORL(LLAT+1))
      ARJ=AR(ID)*X1B(4)*ZCOR
C
C
      AIU=AII*UB(I,J)
      AIV=AII*VB(I,J)
      FCT=X1B(6)*DPH
C
C        IF PARTIALLY FOODED, NO STRESS IS APPLIED FOR CURRENT TIME.
      IF (JUMP.EQ.2) GOTO 490
C -----------------------------------------------------------------------
      IF (NCATG.EQ.2) THEN
       CSHLTR=1.
       ELSE
         HFX(1)=HB(I-1,J-1)-ZBM(I,J)
         HFX(2)=HB(I  ,J-1)-ZBM(I,J)
         HFX(3)=HB(I-1,J  )-ZBM(I,J)
         HFX(4)=HB(I  ,J  )-ZBM(I,J)
C
C        SHELTERING WIND STRESS LINEARLY IF WATER IS LESS THAN 1 FT
C        ABOVE TERRAIN OR BARRIER.
           IF (ITREE(I,J).NE.'1') THEN
           CSH1=AMIN1(HFX(1),1.)
           CSH2=AMIN1(HFX(2),1.)
           CSH3=AMIN1(HFX(3),1.)
           CSH4=AMIN1(HFX(4),1.)
           CSHLTR=.25*(CSH1+CSH2+CSH3+CSH4)
             ELSE
C
C        STRONGER CSHLTERING FOR MANGROVES OR TREES. SHGT = HEIGHT OF
C        TREE TOP.
             CSHLTR=0.
             DO 484 KX=1,4
             HFXX=1.
             IF(HFX(KX).LE.0.) THEN
               HFXX=0.
               ELSE IF(HFX(KX).LT.SHGT) THEN
               HFXX=(HFX(KX)/SHGT)**2
               ENDIF
             CSHLTR=CSHLTR+HFXX
 484       CONTINUE
             CSHLTR=.25*CSHLTR
             ENDIF
      ENDIF
C
C        LOCATE GRID (I,J) ON PHYSICAT PLANE  Z=(XR,YR)=ZETA
      XR=ELPCT(I)*COST(J)
      YR=ELPDT(I)*SINT(J)
      NPLS=1
c
      CALL FRCPNT(XR,YR,FXBP,FYBP,NCATG,CSHLTR,NPLS,FXX,FYY,I,J)
C
C        CHANGE FORCING FROM (X,Y) SYSTEM BACK TO IMAGE PLANE, 
C        CONJ(DZ/DZETA)*(FXBP,FYBP), WHERE DZ/DZETA=(XR,YR)
      XR=ELPDT(I)*COST(J)
      YR=ELPCT(I)*SINT(J)
      FXB=(XR*FXBP+YR*FYBP)
      FYB=(XR*FYBP-YR*FXBP)
C
      XTTX=DELT*FXB
      XTTY=DELT*FYB
      GO TO 480
C -----------------------------------------------------------------------
C        NO FORCINGS
 490  XTTX=0.
      XTTY=0.
C
 480  CONTINUE
C
C       TEMPORARILY STORE PRESENT U/V TO BE USED FOR BOUNDARY POINTS
      UBJ=UB(I,J)
      VBJ=VB(I,J)
C        COMPUTE MOMENTUM ON INTERIOR POINT, SIELECKI'S SCHEME FOR
C        CORIOLIS TERM IS USED.
      UB(I,J)=AIU-FCT*(BR(ID)*DHX-BI(ID)*DHY)+ARJ*VB(I,J)+XTTX
      VB(I,J)=AIV-FCT*(BR(ID)*DHY+BI(ID)*DHX)-ARJ*UB(I,J)+XTTY
C
      GO TO 500
C
C        TRANSPORT POINT NOT OVERTOPPED IN FUTURE
 220  UB(I,J)=0.
      VB(I,J)=0.
C ------------------------------------------------------------------
C        CHECK IF MOMENTUM COMPUTATIONS REQUIRED ON BOUNDARY
C        ISKIP=1, LEFT BOUNDARY(J=1)
C             =2, AND I=2, NEXT TO TOP BOUNDARY
C             =3, RIGHT BOUNDARY
C             =4, AND I=IMXB1,NEXT TO BOTTOM BOUNDARY
C        IJUMP=1, INTERMEDIATE WATER; =2, SHALLOW WATER
C
 500  IJUMP=1
      GO TO (530,520,540),ISKIP
C
C        CHECK FOR 4 CORNER POINTS AND SET ICOR.
C        ICOR=1,LEFT-TOP; 2,LEFT-BOTTOM;3,RIGHT-TOP;4,RIGHT-BOTTOM
 530  IF(I.NE.ME(J)) GO TO 512
      ICOR=2
 512  IF(I.NE.MS(J)) GO TO 510
      ICOR=1
      GO TO 600
 540  IF(I.NE.ME(J)) GO TO 514
      ICOR=4
 514  IF(I.NE.MS(J)) GO TO 510
      ICOR=3
      GO TO 600
C
C        TEST FOR BOTTOM BOUNDARY
 520  IF(I.EQ.MS(J)) GO TO 510
      IF(I.EQ.ME(J)) GO TO 516
      GO TO 560
 516  ISKIP=4
 510  CONTINUE
      IA=ISBS(ISKIP)
      JA=JSBS(ISKIP)
      ISB=I+IA
      JSB=J+JA
C        IF AT (I,J),TRANSPORTS ARE ZERO,SET TRANSPORTS AT BOUNDY ZEROS.
      IF(UB(I,J).EQ.0.) THEN
      UB(ISB,JSB)=0.
      VB(ISB,JSB)=0.
        GOTO 560
        ENDIF
C        PRE-SET ITREEALONG BOUNDARIES; =4  FOR LAND (SKIP COMP.)
C                                       =9  FOR SHALLOW WATER
C                                       =8  FOR INTERMEDIATE DEPTHS
C                                       =6  FOR DEEP WATER (SKIP COMP.)
      IF(ITREE(ISB,JSB).EQ.'6'.OR.ITREE(ISB,JSB).EQ.'4') GO TO 560
      IF(ITREE(ISB,JSB).EQ.'8' ) IJUMP=2
C      WRITE(*,*) '  MNTMBD ISB,JSB',ISB,JSB,IJUMP
      CALL MNTMBD(JUMP,IJUMP,ISB,JSB,ARJ,AII,I,J,UBJ,VBJ,
     1   FXB,FYB,NCATG,CSHLTR,NPLS)
      GO TO 560
C        THREE MOMENTUM POINTS MUST BE CHECKED FOR COMPUTATIONS FOR
C          CORNER POINTS.
C        B   *                              *    B
C      L O   *                              *    O
C      E U   *                              *  R U
C      F N  1.     .(I,J)         (I,J).    .4 I N
C      T D   *                              *  G D
C        A   *  +(I,J-1)            (I,J) + *  H A
C        R   *                              *  T R
C        Y  2.*****.****  BOUNDARY ****.****.3   Y
C                  3                    2
C
 600  DO 610 KK=1,3
      K=ISHF(KK,ICOR)
      ISB=I+IH(ICOR)+IP(K)
      JSB=J+JH(ICOR)+JP(K)
C        IF AT (I,J),TRANSPORTS ARE ZERO,SET TRANSPORTS AT BOUNDY ZEROS.
      IF(UB(I,J).EQ.0.) GOTO 630
C
      IF(ITREE(ISB,JSB).EQ.'6'.OR.ITREE(ISB,JSB).EQ.'4') GO TO 560
      IF(ITREE(ISB,JSB).EQ.'8' ) IJUMP=2
      CALL MNTMBD(JUMP,IJUMP,ISB,JSB,ARJ,AII,I,J,UBJ,VBJ,
     1   FXB,FYB,NCATG,CSHLTR,NPLS)
      GOTO 610
 630  UB(ISB,JSB)=0.
      VB(ISB,JSB)=0.
 610  CONTINUE
C -------------------------------------------------------------------
 560  CONTINUE
 570  CONTINUE
 580  CONTINUE
C       FOR CIRCULAR ISLAND, PERIODIC BOUNDARY CONDITIONS ARE USED.
      IF (DOLLAR.EQ.'$') THEN
        DO 700 I=1,IMXB
        UB(I,1)=UB(I,JMXB)
 700    VB(I,1)=VB(I,JMXB)
       ENDIF
      RETURN
       END
C********************************************************************       
      SUBROUTINE MNTMBD(JUMP,IJUMP,ISB,JSB,ARJ,AII,I,J,UBJ,VBJ,
     1   FXB,FYB,NCATG,CSHLTR,NPLS)
C        JELESNIANSKI   OCTOBER 1980   TDL   IBM 360/195
C
C        PURPOSE
C           THIS SUBROUTINE (MNTMBD) COMPUTES TRANSPORTS ON MOMENTUM
C           BOUNDARY POINTS, BETWEEN LAND AND DEEP WATERS. IN SHALLOW
C           WATERS THE BOUNDARY CONDITION EQUATES SURFACE GRADIENT AT
C           BOUNDARY AND NEAREST INTERIOR POINT.  IN INTERMEDIATE
C           WATERS THE BOUNDARY CONDITION IGNORES TIME VARIATIONS AND
C           EQUATES SURGE GRADIENT AS STATIC HEIGHT GRADIENT AT A
C           BOUNDARY POINT.
C           BELOW IS ARRANGEMENT OF MOMENTUM BOUNDARY LINE
C           AND NEAREST INTERIOR LINE.
C
C          .    .(I,J)          .    .(I,J)      .    . INTERIOR LINE
C                                                *    *
C            +                    +              * +  *
C                                                *    *
C          .    .<---IJUMP=2--->.    .< IJUMP=1 >.****. BOUNDARY LINE
C               (ISB,JSB)          (ISB,JSB)
C  DEEP--->      <INTERMEDIATE >      <SHALLOW  >     <---LAND-----
C
C********************************************************************
C        DATA SET USE
C           NONE
C
C        VARIABLES
C             ISKIP = 1 TO COMPUTE MOMENTUM ON J=1    BOUNDARY
C                     2 TO COMPUTE MOMENTUM ON I=IMXB BOUNDARY
C                     3 TO COMPUTE MOMENTUM ON J=JMXB BOUNDARY
C         ISB JSB = REVISED SUBSCRIPTS FOR A BOUNDARY POINT
C     UB VB(  ,   ) = TRANSPORTS
C              JUMP = 1 FOR SURFACE FORCING,2 FOR NO SURFACE FORCING
C             IJUMP = 1 FOR SHALLOW WATER BOUNDARY COMPUTATIONS
C                     2 FOR INTER DEPTH   BOUNDARY COMPUTATIONS
C           FXB FYB = COMPONENTS OF DRIVING FORCES
C       AIT AII AIU = PRE-COMPUTED VALUES IN 'MOMNTM'
C       AIV ARJ XTT = DITTO
C            AINTRP = DITTO
C           X1B(10) = FIXED CONSTANTS
C           UBJ VBJ = TRANSPORTS AT (I,J) AT PRESENT TIME,SAVED BEFORE
C                     UPDATED
C
C        GENERAL COMMENTS
C           THIS SUBROUTINE RESIDES IN OVERLAY 'CMPUTE'. IT IS CALLED
C           IN BY SUBROUTINE 'MOMNTM'. SUBROUTINE 'MOMNTM' IS CALLED
C          IN BY SUBROUTINE 'CMPUTE'. THIS SUBROUTINE ALSO CALLS IN
C           SUBROUTINE 'STRESS'.
C
      INCLUDE 'parm.for'
C
      COMMON /EGTH/   DELS,DELT,G,COR
      COMMON /DUMB4/  X1B(10)
      COMMON /SCND/   AR(600),AI(600),BR(600),BI(600),CR(600),CI(600)
C
      AIUL=AII*(UB(ISB,JSB)-UBJ)
      AIVB=AII*(VB(ISB,JSB)-VBJ)
C       TEST FOR PARTIAL FLOODING (NO FORCING).
         IF (JUMP.EQ.2) THEN
      XTTX=0.
      XTTY=0.
      GO TO 140
         ENDIF
C           TEST FOR SHALLOW WATER BOUNDARY AND INTERMEDIATE WATER BRY.
      IF (IJUMP.EQ.2) GOTO 160
C
C        SHALLOW WATER COMPUTATIONS, FORCING COMPUTED ON BOUNDRY PTS
C
      FXD=FXB
      FYD=FYB
C        GRID TRANSFORMATION FROM (I,J) TO (X,Y)
      XR=ELPCT(ISB)*COST(JSB)
      YR=ELPDT(ISB)*SINT(JSB)
      NPLS=1
      CALL FRCPNT(XR,YR,FXBP,FYBP,NCATG,CSHLTR,NPLS,FXX,FYY,I,J)
C        CHANGE FORCING FROM (X,Y) SYSTEM BACK TO IMAGE PLANE
      XR=ELPDT(ISB)*COST(JSB)
      YR=ELPCT(ISB)*SINT(JSB)
      FXB=XR*FXBP+YR*FYBP
      FYB=XR*FYBP-YR*FXBP
C        STRESS DIFFERENCE BETWEEN BOUNDARY POINT AND INTERIOR POINT
      XTTX=DELT*(FXB-FXD)
      XTTY=DELT*(FYB-FYD)
C
C        COMPUTE MOMENTUM ON SHALLOW DEPTH BOUNDARIES. SURFACE GRADIENT
C        TERMS CANCELED BY ASSUMED B.C.
C        NOTE: USE SIELECKI'S SCHEME FOR CORIOLIS TERM.
C              VBJ = V-COMPONENT AT PRESENT TIME AT I,J
C              UB(I,J),VB(I,J) = U,V IN FUTURE TIME
  140 UB(ISB,JSB)=UB(I,J)+AIUL+ARJ*(VB(ISB,JSB)-VBJ)    +XTTX
      VB(ISB,JSB)=VB(I,J)+AIVB-ARJ*(UB(ISB,JSB)-UB(I,J))+XTTY
      GO TO 170
C
C        NO FORCIING WHEN JUMP=2
C
C        COMPUTE MOMENTUM ON INTERMEDIATE DEPTH BOUNDARIES
C        ELIMINATE STATIC PRESSURE TERM IN FRCPNT(NPLS=0).
  160 NPLS=0
      CSHLTR=1.
C        GRID TRANSFORMATION FROM (I,J) TO (X,Y)
      XR=ELPCT(ISB)*COST(JSB)
      YR=ELPDT(ISB)*SINT(JSB)
C
      CALL FRCPNT(XR,YR,FXBP,FYBP,NCATG,CSHLTR,NPLS,FXX,FYY,I,J)
C        CHANGE FROM (X,Y) SYSTEM TO IMAGE PLANE
      XR=ELPDT(ISB)*COST(JSB)
      YR=ELPCT(ISB)*SINT(JSB)
      FXB=XR*FXBP+YR*FYBP
      FYB=XR*FYBP-YR*FXBP
C
  166 UB(ISB,JSB)=AII*UB(ISB,JSB)+ARJ*VB(ISB,JSB)+ DELT*FXB
      VB(ISB,JSB)=AII*VB(ISB,JSB)-ARJ*UB(ISB,JSB)+ DELT*FYB
  170 RETURN
       END
      SUBROUTINE FHMXSV
C       CONVERT SURGE ENVELOP DATA WITH 999 FOR DRY SQUARES SO THAT ZB()
C       CAN BE FREE FROM THE MEMORY.
      INCLUDE 'parm.for'
C
      COMMON /GPRT1/  DOLLAR,EBSN
      COMMON /SWTCH/  IOPERL(5)
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      CHARACTER*2     DOLLAR
      CHARACTER*1     EBSN
C        REPLACE HMX BY 999 IF THE SQUARE IS DRY.
       DO 1 J=1,JMXB
       DO 1 I=1,IMXB
        IF (HMX(I,J)+ZB(I,J).EQ.0) THEN
         IHMX(I,J)=999
         ELSE
         IHMX(I,J)=HMX(I,J)*10.+.5
         ENDIF
  1    CONTINUE
      DO 20 J=1,JMXB
      DO 20 I=1,IMXB
      IF (IHMX(I,J).EQ.999) GOTO 20
      IF (DOLLAR.EQ.'2$') IHMX(I,J)=(HMX(I,J)-ZSUB(J))*10.+.5
 20   CONTINUE
      IF(IOPERL(1).NE.2) THEN
      NGRP=(JMXB1-1)/25+1
      DO 1130 NN=1,NGRP
      J1=1+(NN-1)*25
      J2=J1+MIN0(24,JMXB1-J1  )
CC      WRITE(*,180)(J,J=J1,J2)
 180  FORMAT(/I6,26I5)
C
      DO 1120 I=1,IMXB1
CC      WRITE(*,'(1H ,I2,26I5)') I,(IHMX(I,J),J=J1,J2)
 1120  CONTINUE
 1130  CONTINUE
       ENDIF
C
       RETURN
       END
      SUBROUTINE ARCHIV
C       ARCHIV SURGE ENVELOP DATA FOR DISPLAY
      INCLUDE 'parm.for'
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      COMMON /IDENT/  AIDENT(40),DACLOK(7)
      COMMON /FLES/ FLE5,FLE9,FLE8,FLE91,FLE99,FLE10,FLE20,FLE30,FLE1
      CHARACTER*256 FLE5,FLE9,FLE8,FLE91,FLE99,FLE10,FLE20,FLE30,FLE1
C        ARCHIVE SURGE ENVELOP TO A FILE
C      OPEN (91,FILE=FLE91,FORM='UNFORMATTED',STATUS='UNKNOWN')
       CALL TOPEN (91,FLE91,1,2)
C       WRITE(91) IMXB,JMXB
C       WRITE(91) AIDENT
       CALL TWRITE (91,IMXB,1)
       CALL TWRITE (91,JMXB,1)
       CALL TWRITEC (91,AIDENT,160)
C          SAVE HMX*10 (10TH A FT ACCURACY) IN INTEGER FORMAT
C       WRITE(91) ((IHMX(I,J),I=1,IMXB),J=1,JMXB)
       DO J=1,JMXB
         DO I=1,IMXB
           CALL TWRITES (91,IHMX(I,J),1)
         END DO
       END DO
C       CLOSE (91)
       CALL TCLOSE (91)
C
       RETURN
       END
C********************************************************************       
      SUBROUTINE HISTRY
C        JELESNIANSKI   OCTOBER        TDL   IBM 360/195
C
C        PURPOSE
C           THIS SUBROUTINE (HISTRY) SMOOTHS THE SURGE AT 10
C           PRE-SELECTED GRID POINTS AND SAVES THEM ON TAPE FOR FUTURE
C           PRINT OUT. ALSO, WIND SPEED AND DIRECTION ARE ALSO SAVED AT
C           THE SAME 10 POINTS.
C********************************************************************
C        DATA SET USE
C           FT 10, TEMPORARY SCRATCH TAPE FOR SURGE STORAGE
C           FT 20, TEMPORARY SCRATCH TAPE FOR WIND SPEED STORAGE
C           FT 30, TEMPORARY SCRATCH TAPE FOR STORAGE OF WIND DIRECTION
C
C        VARIABLES
C   IPN(10) IPL(10) = SUBSCRIPTS FOR 10 SELECTED POINTS
C        HB(  ,  ) = SURGE FIELD
C        ZB(  ,   ) = DEPTH FIELD
C       IP(4) JP(4) = SHIFT SUBSCRIPTS TO 4 ADJACENT MOMENTUM POINTS
C       ZBM(  ,   ) = MAXIMUM BARRIER HEIGHT AT A MOMENTUM POINT
C COST(  ) SINT(  ) = RAY PROJECTIONS THRU MOMNTM POINTS, ON (X,Y) AXIS
C        GRIDRF(  ) = RADIAL DISTANCES TOMOMENTUM POINTS
C             AX AY = CMPNENTS OF TOTAL STRM TRVRSE, ADVNCD IN 'STMVAL'
C             C1 C2 = COMPONENTS OF INITIAL STORM POSITION
C             NCATG = 1 FOR LAKE WINDS, 2 FOR OCEAN WINDS
C          W1218(2) = TWICE THE MAXIMUM WINDS, LAKE/OCEAN WINDS
C   CW(800) SW(800) = INFLOW ANGLE FOR LAKE WINDS
C     C(800) S(800) = INFLOW ANGLE FOR OCEAN WINDS
C           X12(50) = FIXED COEFFICIENTS
C    X12(9) X12(10) = COMPONENTS OF FORWARD SPEED, 1ST HOUR
C          WIND(10) = WIND SPEED AT 10 SELECTED POINTS
C          TDIR(10) = WIND DIRECTION AT 10 SELECTED POINTS
C               PHI = SLANT, Y-AXIS TO N/S DIRECTION, AZMTH+270
C               RAD = RADIAN MEASURE
C             IPRHR = 1,WHEN ON THE HOUR; 2, WHEN HALF HOUR IN BETWEEN;
C                     3, OTHERWISE
C
C        GENERAL COMMENTS
C           THIS SUBROUTINE RESIDES IN OVERLAY 'CMPUTE'. IT IS CALLED
C           IN BY SUBROUTINE 'CMPUTE' AT SELECTED TIME INTERVALS.
C
      INCLUDE 'parm.for'
C
C      COMMON /SLAT/   FSOUTH
      COMMON /FFTH/   ITIME,MHALT
      COMMON /PRHSY/  IPRHR,JUMPR,IPRT
      COMMON /DUMBSV/ SAVEH(10),IPN(10),IPL(10),STATS(10)
      COMMON /STRMSB/ C1,C2,C21,C22,AX,AY,PTENCY,RTENCY
C STIME interferes with C code, so switched to STIME2
      COMMON /STIME2/  ISTM,JHR,ITMADV,NHRAD,IBGNT,ITEND
      COMMON /FRST/   X1(50),X12(50)
      COMMON /DUMY44/ SW(800),CW(800),W1218(2),WMAX(2)
      COMMON /DUMMY4/ S(800),C(800),P(800),DELP(800)
      COMMON /BSN/    PHI,ALTO,ALNO,PHI1,ALT1,ALN1,ALT1C
C---------------------------------------------------------
      COMMON /GPRT1/  DOLLAR,EBSN
      CHARACTER*2     DOLLAR
      CHARACTER*1     EBSN
C---------------------------------------------------------
      DIMENSION       WIND(10),TDIR(10)
      CHARACTER*16 STATS
      DATA KHR/1/
C
C
C       KEEP TRACK TIME, ON THE HOUR,HALF HOUR BETWEEN, OR ELSE
C       FROM MOD(IME,100)=1,OR 2,OR 3
C
       IF (ITIME.EQ.0) THEN
       IME=0
       ELSE
       GO TO (10,20,30),IPRHR
   10  KHR=KHR+1
       IME=KHR*100+1
       GO TO 40
   20  IME=KHR*100+2
       GO TO 40
   30  IME=KHR*100+3
   40  CONTINUE
       ENDIF
C********SMOOTHING HISTORICAL SURGES AT 10 SELECTED GRID POINTS*********
      DO 1190 L=1,10
      I=IPN(L)
      J=IPL(L)
C
      SAVEH(L)=HB(I,J)
      IF (DOLLAR.EQ.'2$') SAVEH(L)=HB(I,J)-ZSUB(J)
 1190 CONTINUE
C**************END SMOOTHING********************************************
C
C        WRITING HISTORICAL SURGES AT SELECTED GRID PTS ONTO TAPE
CCCC      WRITE(10)   IME,SAVEH
C      WRITE(*,2222)   IME,SAVEH
C 2222  FORMAT(I5,10F7.2)
C
C++++++++COMPUTING VECTOR WIND AT 10 SELECTED POINTS++++++++++++++++++++
C
C                     +*********+
C                     *         *
C                     *         *
C                     *    I    *
C                     *    .    * COST,SINT
C                     *    J    *
C                     *         *
C                     *         *
C                     +*********+
C                          ^
C                        GRIDRF
C
      DO 230 L=1,10
      I=IPN(L)
      J=IPL(L)
      X=ELPCL(I)*COSL(J)
      Y=ELPDL(I)*SINL(J)
      XP=X-C1-AX
      YP=Y-C2-AY
      RSQ=XP*XP+YP*YP
      RS=SQRT(RSQ)
      R1=RS/5280.+1.
      K=R1
      R2=K
      DR=R1-R2
      K=MIN0(K,790)
      ITEST=0
      if (itree(i,j).eq.'2') ITEST=ITEST+1
      if (itree(i+1,j).eq.'2') ITEST=ITEST+1
      if (itree(i,j+1).eq.'2') ITEST=ITEST+1
      if (itree(i+1,j+1).eq.'2') ITEST=ITEST+1
      IF (ITEST.GE.1) THEN
      ncatg=2
      else
      NCATG=1
      endif
      X1218=W1218(NCATG)
      CK1=CW(K)+DR*(CW(K+1)-CW(K))
      SK1=SW(K)+DR*(SW(K+1)-SW(K))
      CCN=X12(15)+RSQ
      CC=1./CCN
      RHOL=ABS(XP*X12(20)+YP*X12(21))
      CCC=CCN*RHOL/(X12(15)+RHOL*RHOL)
      A=RS*X12(9) -X1218*(YP*CK1+XP*SK1)+CCC*X12(23)
      B=RS*X12(10)+X1218*(XP*CK1-YP*SK1)+CCC*X12(24)
C
C        FSOHTH=-1. FOR SOUTHERN HEMISPHERE; =1. FOR NORTHERN HEMIS.
C     
C      A=RS*X12(9) -FSOUTH*X1218*(YP*CK1+FSOUTH*XP*SK1)+CCC*X12(23)
C      B=RS*X12(10)+FSOUTH*X1218*(XP*CK1-FSOUTH*YP*SK1)+CCC*X12(24)
c
      SS=SQRT(A*A+B*B)
      WIND(L)=X12(4)*SS*CC*3600./5280.
        IF (SS.LT.1.E-5) THEN
        Z=180.
        ELSE
       Z      =ATAN2(A,B)/1.74532925E-2+180.
         ENDIF
       TDIR(L)=AMOD(Z+PHI,360.)
 230   CONTINUE
C++++++++END COMPUTATION OF VECTOR WINDS++++++++++++++++++++++++++++++++
C
C        WRITING HISTORICAL VECTOR WINDS AT SELECTED POINTS ONTO TAPE
CCCCC      WRITE(20)   IME,WIND
CCCCC      WRITE(30)   IME,TDIR
      RETURN
      END
      SUBROUTINE HSTRY2
C        MODIFIED SLOSH USED FOR EVACUATION STUDY.
      INCLUDE 'parm.for'
C
      COMMON /DUMB8/  IP(4),JP(4),IH(4),JH(4)
      COMMON /NFILE/  KNPT,NDATA(3)
      COMMON /STRMSB/ C1,C2,C21,C22,AX,AY,PTENCY,RTENCY
C STIME interferes with C code, so switched to STIME2
      COMMON /STIME2/  ISTM,JHR,ITMADV,NHRAD,IBGNT,ITEND
      COMMON /FRST/   X1(50),X12(50)
      COMMON /DUMY44/ SW(800),CW(800),W1218(2),WMAX(2)
      COMMON /DUMMY4/ S(800),C(800),P(800),DELP(800)
      COMMON /BSN/    PHI,ALTO,ALNO,PHI1,ALT1,ALN1,ALT1C
      COMMON /PIRAD/  PI,RAD
      COMMON /CESAV/  IPN(120),IPL(120),KHSPT
      COMMON /CESAV1/ STATS(120)
      COMMON /GPRT1/  DOLLAR,EBSN
      COMMON /PRHSY/  IPRHR,JUMP,IPRT
      DIMENSION SAVEH(10,12),WIND(10,12),TDIR(10,12)
      CHARACTER*16 STATS
      CHARACTER*2  DOLLAR
      CHARACTER*1 EBSN
      DATA KHR,KHR2/0,0/
C
C
C       KEEP TRACK TIME, ON THE HOUR,HALF HOUR BETWEEN, OR ELSE
C       FROM MOD(IME,100)=1,OR 2,OR 3
C
      GO TO (10,20,30),IPRHR
  10  KHR=KHR+1
      IME=KHR*100+1
      GO TO 40
  20  KHR2=KHR2+1
      IME=KHR2*100+2
      GO TO 40
  30  IME=103
  40  CONTINUE
C      SAVE TIME HISTRIES AT SELECTED GRIDS
C       UPDATED FEB. 1985. SAVE TIME HISTRIES EVERY HALF HOUR.
      IF (IPRHR.EQ.3) RETURN
      LUNIT=NDATA(1)
      DO 195 N=1,KHSPT
      L1=(N-1)*10+1
      L2=L1+9
      DO 190 L=L1,L2
      M=L-L1+1
      I=IPN(L)
      J=IPL(L)
      SAVEH(M,N)=HB(I,J)
C      IF (DOLLAR.EQ.'2$') SAVEH(M,N)=HB(I,J)-ZSUB(J)
 190  CONTINUE
 195  CONTINUE
C        WRITING HISTORICAL SURGES AT SELECTED GRID PTS ONTO TAPE
      WRITE(LUNIT)   IME,((SAVEH(M,N),M=1,10),N=1,KHSPT)
CC      WRITE(*,'(i6,10f6.2)') IME,((SAVEH(M,1),M=1,10),N=1,1)
C
C++++++++COMPUTING VECTOR WIND AT 10 SELECTED POINTS++++++++++++++++++++
C
C
      LUNT=NDATA(2)
      LUNT1=NDATA(3)
      DO 305 N=1,KHSPT
      L1=(N-1)*10+1
      L2=L1+9
      DO 230 L=L1,L2
      M=L-L1+1
      I=IPN(L)
      J=IPL(L)
      X=ELPCL(I)*COSL(J)
      Y=ELPDL(I)*SINL(J)
      XP=X-C1-AX
      YP=Y-C2-AY
      RSQ=XP*XP+YP*YP
      RS=SQRT(RSQ)
      R1=RS/5280.+1.
      K=R1
      R2=K
      DR=R1-R2
      K=MIN0(K,790)
      if (itree(i,j).eq.'2') then
      ncatg=2
      else
      NCATG=1
      endif
      X1218=W1218(NCATG)
      CK1=CW(K)+DR*(CW(K+1)-CW(K))
      SK1=SW(K)+DR*(SW(K+1)-SW(K))
      CCN=X12(15)+RSQ
      CC=1./CCN
      RHOL=ABS(XP*X12(20)+YP*X12(21))
      CCC=CCN*RHOL/(X12(15)+RHOL*RHOL)
      A=RS*X12(9) -X1218*(YP*CK1+XP*SK1)+CCC*X12(23)
      B=RS*X12(10)+X1218*(XP*CK1-YP*SK1)+CCC*X12(24)
      SS=SQRT(A*A+B*B)
      WIND(M,N)=X12(4)*SS*CC*3600./5280.
         IF (SS.LT.1.E-5) THEN
         Z=180.
         ELSE
      Z      =ATAN2(A,B)/1.74532925E-2+180.
         ENDIF
  230 TDIR(M,N)=AMOD(Z+PHI,360.)
C++++++++END COMPUTATION OF VECTOR WINDS++++++++++++++++++++++++++++++++
C
 305  CONTINUE
C        WRITING HISTORICAL VECTOR WINDS AT SELECTED POINTS ONTO TAPE
      WRITE(LUNT)   IME,((WIND(M,N),M=1,10),N=1,KHSPT)
      WRITE(LUNT1)  IME,((TDIR(M,N),M=1,10),N=1,KHSPT)
      RETURN
      END
C********************************************************************      
      SUBROUTINE FILTRP
C        JELESNIANSKI   OCTOBER 1980   TDL   IBM 360/195
C
C        PURPOSE
C           THIS SUBROUTINE (FILTRP) SMOOTHS THE COMPUTED SURGE ENVELOPE
C           OF HIGHEST WATERS, IN SPACE. THE PROCEDURES ARE THE SILLILER
C           IN 'FILTER' AND 'HMXSV', 2 PASSES OF 3-POINT SMOOTHER.
C           IT IS FOR COSMATIC APPEARANCE. NO SMOOTHING ACROSS THE NON-
C           OVERTOPPED BARRIERS IS ALLOWED.
C********************************************************************
C        DATA SET USE
C           NONE
C
C        VARIABLES
C         IMAX JMAX = MAXIMUM GRID POINTS IN THE BASIN
C       IMXB1 JMXB1 = IMAX LESS 1, JMXB LESS 1
C        HMX(  ,  ) = SURGE ENVELOPE
C          HZ(  ,3) = DUMMY STORAGE FOR 3 LINES
C         ZB(  ,  ) = DEPTH FIELD
C     IIH(4) JJH(4) = SHIFT SUBSCRIPTS TO 4 ADJOINING MOMENTUM POINTS
C       IP(4) JP(4) = SHIFT SUBSCRIPTS TO 4 ADJOINING SURGE POINTS
C        ZBM(  ,  ) = MAX BARIER HEIGHTS AT MOMENTUM POINTS
C
C        GENERAL COMMENTS
C           THIS SUBROUTINE RESIDES IN OVERLAY 'PLOTS'. IT IS CALLED
C           IN BY SUBROUTINE 'PLOTS'.
C
      INCLUDE 'parm.for'
C
      COMMON /FFTH/   ITIME,MHALT
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      COMMON /DUMB8/  IP(4),JP(4),IH(4),JH(4)
      COMMON /DUM88/  IIH(4),JJH(4),IHH(4),JHH(4)
      DIMENSION       HZ(M_,3)
      DIMENSION       GAMF(4)
       DATA HT/0./
C
C        STORE 2 OF 3 INITIAL LINES FOR SMOOTHING MIDDLE LINE
      DO 300 IPS=1,2
      KR=IPS
C
      GO TO (104,102),IPS
 102  I1=2
      I2=IMXB2
      J1=1
      J2=JMXB1
      DO 100 J=1,2
      DO 100 I=1,IMXB1
 100  HZ(I,J+1)=HMX(I,J)
      GO TO 105
 104  I1=1
      I2=IMXB1
      J1=2
      J2=JMXB2
      DO 112 J=1,3
      DO 112 I=1,IMXB1
 112  HZ(I,J)=HMX(I,J)
 105  CONTINUE
      DO 220 J=J1,J2
      DO 190 I=I1,I2
      IF(ZB(I,J).LE.(-35.)) GO TO 190
      HST=HMX(I,J)+ZB(I,J)
      IF(HST.LT.HT) GO TO 190
      HSM=0.
      HDIF=0.
       GAM0=ELPDL2(I)+(ELPCL2(I)-ELPDL2(I))*SINL2(J)
C
C**************SMOOTHING ROUTINE****************************************
      DO 150 K=KR,4,2
      II=I+IIH(K)
      JK=J+JJH(K)
      IF (II.EQ.0.OR.JK.EQ.0) THEN
        GAMF(K)=0.
        GOTO 160
        ENDIF
      GAMFK=ELPDL2(II)+(ELPCL2(II)-ELPDL2(II))*SINL2(JK)
c      GAMF(K)=.5*(1.+GAMFK/GAM0)-1.
      Z=GAMFK/GAM0
      GAMF(K)=2.*Z/(1.+Z)-1.
      IF (II.EQ.IMXB.OR.JK.EQ.JMXB) GO TO 160
      JJ=JJH(K)+2
      IF (HZ(II,JJ)+ZB(II,JK).LT.HT) GO TO 160
      KK=MOD(K,4)+1
      IA=I+IP(K)
      IB=I+IP(KK)
      JA=J+JP(K)
      JB=J+JP(KK)
      Z =ZBM(IA,JA)
      ZZ=ZBM(IB,JB)
      ZZZ=AMIN1(Z,ZZ)+HT
      IF( HZ(I,2).LT.ZZZ.OR.HZ(II,JJ).LT.ZZZ) THEN
          HSM=HSM+HZ(I,2)
          HZZ=HZ(I,2)
          ELSE
          HSM=HSM+HZ(II,JJ)
          HZZ=HZ(II,JJ)
          ENDIF
      GOTO 210
 160  CONTINUE
          HSM=HSM+HZ(I,2)
          HZZ=HZ(I,2)
 210  CONTINUE
C       WEIGHTING ADJUSTMENTS IN I-DIRECTION DUE TO POLAR GRIDS.
        HDIF=HDIF+HZZ*GAMF(K)
 150  CONTINUE
C**************END SMOOTHING ROUTINE************************************
C
      HMX(I,J)=(2.*HMX(I,J)+HSM)/4.
C 180  HMX(I,J)=HMX(I,J)+HDIF/4.
      HMX(I,J)=AMAX1(HMX(I,J),-ZB(I,J))
  190 CONTINUE
C
C        UPDATE 3 LINES FOR SMOOTHING
      IF(J.GE.J2) GO TO 220
      DO 200 II=1,IMXB1
      HZ(II,1)=HZ(II,2)
      HZ(II,2)=HZ(II,3)
  200 HZ(II,3)=HMX(II,J+2)
  220 CONTINUE
 300  CONTINUE
      RETURN
       END
C********************************************************************       
      SUBROUTINE HMXSV
C        SEPTEMBER 1980    JYE CHEN    TDL   IBM 360/195
C
C        PURPOSE
C           THIS SUBROUTINE (HMXSV) STORES MAXIMUM SURGE AS ADVANCING
C           IN TIME AT EACH GRID POINT, INTO ARRAY HMX(  ,  ).
C           THE 'SMOOTHED' SURGE VALUE IS COMPUTED AND COMPARED LOCALLY
C           AGAINST PREVIOUSLY SAVED HMX. THE REASON IS TO AVOID
C           TEMPORARY NOISE ENTERING THE FINAL ENVELOP.
C********************************************************************
C        DATA SET USE
C
C        VARIABLES
C        HMX(  ,  ) = MAXIMUM SURGE AT EACH GRID PT
C       IP(4) JP(4) = SHIFTS OF I J FROM HEIGHT PT TO 4 MOMNTN CORNERS
C          IBB(6,M) = RANGES AND INCREMENTS FOR 3 DO-LOOPS OF I,J
C                     M=1 INTERIOR,M=2 HORZNTL BNDY,M=3 VERTICAL BNDY
C                     RANGES ON THREE BASIN SEGMENTS ARE:
C                     SEE SUBROUTINE FILTER
C        HB(  ,   ) = SURGE FIELD
C         ZB(  ,  ) = DEPTH FIELD
C     IIH(4) JJH(4) = I/J-SHIFT SUBSCRIPTS FOR SURGE POINTS
C
C        GENERAL COMMENTS
C           THIS SUBROUTINE RESIDES IN OVERLAY 'CMPUTE'. IT IS CALLED
C           BY SUBROUTINE 'CMPUTE'.
C           A 5-POINT SMOOTHING OPERATOR SIMILLER TO ONE
C           IN SUBROUTINE FILTER IS USED, SEE 'FILTER'.
C
      INCLUDE 'parm.for'
      COMMON /FFTH/   ITIME,MHALT
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      COMMON /EGTH/   DELS,DELT,G,COR
      COMMON /DUMB8/  IP(4),JP(4),IH(4),JH(4)
      COMMON /DUM88/  IIH(4),JJH(4),IHH(4),JHH(4)
      COMMON /GPRT2/  EBSN1,EBSN2
      CHARACTER*1     EBSN,EBSN1,EBSN2
C
       DIMENSION       GAMF(4)
       DIMENSION       IBB(6,3)
C         DATA IIH/0,1,0,-1/,JJH/-1,0,1,0/
      DATA IBB(1,1),IBB(1,2),IBB(1,3)/2,1,2/,
     1     IBB(3,1),         IBB(3,3)/1,  1/,
     2     IBB(4,1),IBB(4,2),IBB(4,3)/2,1,1/,
     3     IBB(6,1),IBB(6,2)         /1,1  /
      IBB(2,1)=JMXB2
      IBB(2,3)=JMXB2
      IBB(3,2)=JMXB2
      IBB(2,2)=JMXB1
      IBB(5,1)=IMXB2
      IBB(6,3)=IMXB2
      IBB(5,2)=IMXB1
      IBB(5,3)=IMXB1
C
      DO 200 M=1,3
      JL  =IBB(1,M)
      JM  =IBB(2,M)
      JNCR=IBB(3,M)
      IL  =IBB(4,M)
      IM  =IBB(5,M)
      INCR=IBB(6,M)
C
      DO 190 J=JL,JM,JNCR
C
      DO 180 I=IL,IM,INCR
C        NO UPDATING IF SURGE IS DECREASING.
      HX=HMX(I,J)
      IF(HX.GE.HB(I,J)) GOTO 180
C        SMOOTHING IS UNNECESSARY FOR WATER DEPTH GREATER THAN 40 FT.
      IF (ZB(I,J).GT.40..OR.EBSN1.EQ.'&') GOTO 175
      HST=HB(I,J)+ZB(I,J)
C        TEST FOR LAND WETTED LESS THAN 1 FT.
      IF(HST.LT.1.) GO TO 175
      HSM=0.
      HDIF=0.
      GAM0=ELPDL2(I)+(ELPCL2(I)-ELPDL2(I))*SINL2(J)
C
C******** 'LOOP' FOR SMOOTHING******************************************
      DO 150 K=1,4
      II=I+IIH(K)
      JJ=J+JJH(K)
      IF (M.EQ.1) GOTO 158
        IF (II.EQ.0.OR.JJ.EQ.0) THEN
        GAMF(K)=0.
        GO TO 140
        ENDIF
 158  CONTINUE
      GAMFK=ELPDL2(II)+(ELPCL2(II)-ELPDL2(II))*SINL2(JJ)
c      GAMF(K)=.5*(1.+GAMFK/GAM0)-1.
      Z=GAMFK/GAM0
      GAMF(K)=2.*Z/(1.+Z)-1.
      IF (JJ.EQ.JMXB.OR.II.EQ.IMXB) GO TO 140
C
C        THE NEIGHBORING SQUARE IS DRY.
      IF (HB(II,JJ)+ZB(II,JJ).LT.1.) GO TO 140
      KK=MOD(K,4)+1
      IA=I+IP(K)
      IB=I+IP(KK)
      JA=J+JP(K)
      JB=J+JP(KK)
      Z =ZBM(IA,JA)
      ZZ=ZBM(IB,JB)
      ZZZ=AMIN1(Z,ZZ)+1.
C
C        WATER ON EITHER SIDE MUST EXCEED THE BARRIER(LOWER) BY AT
C        LEAST 1 FT.
      IF( HB(I,J).LT.ZZZ.OR.HB(II,JJ).LT.ZZZ) THEN
          HSM=HSM+HB(I,J)
          HZZ=HB(I,J)
          ELSE
          HSM=HSM+HB(II,JJ)
          HZZ=HB(II,JJ)
          ENDIF
      GOTO 212
 140  CONTINUE
          HSM=HSM+HB(I,J)
          HZZ=HB(I,J)
 212  CONTINUE
C       WEIGHTING ADJUSTMENTS IN I-DIRECTION DUE TO POLAR GRIDS.
       HDIF=HDIF+HZZ*GAMF(K)
  150 CONTINUE
C******* END 'LOOP' FOR SMOOTHING **************************************
C
      HTEMP=(4.*HB(I,J)+HSM+HDIF)/8.
      HMX(I,J)=AMAX1(HX,HTEMP)
      GOTO 180
 175  HMX(I,J)=HB(I,J)
 180  CONTINUE
 190  CONTINUE
 200  CONTINUE
C      write (*,*) 'hmxsv:E',HMX(17,18),HB(17,18),HMX(64,21),HB(64,21)
      RETURN
       END
C********************************************************************       
      SUBROUTINE SMPT2G
C        J. CHEN , AUG 22 1984            TDL   IBM 360/195
C        PURPOSE
C           TO COLLECT MOMENTUM GRID POINTS AJACENT TO ANY INTERIOR
C           BOUNDARIES (U=V=0) THEN CONVERT TO HEIGHT POINTS.
C           REPETITION IS AVOIDED. SPECIAL POINTS, ONE OF TH 4 IS
C           DRY, ARE TAGGED AS 888. FOR HEAVIER SMOOTHING.
C           CALL SUBROUTINE 'FLT2G' FOR SMOOTHING.
C********************************************************************
C        DATA SET USE
C           NONE
C        VARIABLES
C           HSUB( , ) = TEMPORARY STORAGE SPACE FOR HEIGHT FIELD
C
      INCLUDE 'parm.for'

C     MCT_ set to 8000  06/09/10
      PARAMETER (MCT_=8000)
C      PARAMETER (MCT_=1500)
C
      COMMON /FLWCPT/ NSQRS,NSQRW,NSQRWC,NPSS,NCUT
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      COMMON /SM2G/   MM2G,MCMX,I2G(M2G_),J2G(M2G_)
      COMMON /DUMB8/  IP(4),JP(4),IH(4),JH(4)
      COMMON /DUM88/  IIH(4),JJH(4),IHH(4),JHH(4)
      COMMON /FFTH/   ITIME,MHALT
      INTEGER*2       MM2G,MCMX,I2G,J2G
      INTEGER*2       MCT(MCT_),I2GG(MCT_),J2GG(MCT_)
      M=0
      DO 10 J=2,JMXB2
      DO 10 I=2,IMXB2
      IF (UB(I,J).EQ.0..OR.ZBM(I,J).LE.-30.) GOTO 10
      IF (UB(I-1,J  ).EQ.0.) GOTO 20
      IF (UB(I  ,J-1).EQ.0.) GOTO 20
      IF (UB(I  ,J+1).EQ.0.) GOTO 20
      IF (UB(I+1,J  ).EQ.0.) GOTO 20
      GOTO 10
 20   IF (M+1.GE.M2G_) GOTO 22
      M=M+1
      I2G(M)=I
      J2G(M)=J
 10   CONTINUE
      GOTO 23
C
 22   CONTINUE
CC      WRITE(*,998)I2G(M),J2G(M)
 998  FORMAT(' TOTAL MOMN. POINTS FOR SMOOTHING REACHES 3000.',
     1 ' LAST I,J =',2I8)
      STOP
C      SAVE THE TOTAL COUNT OF CORNER MOMN. POINTS
 23    MM2G=M
C      write (*,*) "num momn points for smooth", mm2g
C
      DO 100 J=1,JMXB1
      DO 100 I=1,IMXB1
C
C       COLLECT MOMNTURMUMTURM POINTS NEXT TO THE INTERIOR BOUNDARY OF
C       COMPUTATIONS
 100  HSUB(I,J)=999.
C
      MC=0
      DO 120 M=1,MM2G
      II=I2G(M)
      IF(II.LE.1.OR.II.GE.IMXB) GO TO 120
      JJ=J2G(M)
      IF(JJ.LE.1.OR.JJ.GE.JMXB) GO TO 120
      DO 110 K=1,4
      I=II+IH(K)
      J=JJ+JH(K)
      IF(HB(I,J)+ZB(I,J).EQ.0.) GO TO 112
      HSUB(I,J)=HB(I,J)
      GO TO 110
 112  IF(MC+1.GE.MCT_) GO TO 113
      MC=MC+1
      MCT(MC)=M
 110  CONTINUE
 120  CONTINUE
      GOTO 125
 113  CONTINUE
CC      WRITE(*,997) I2G(M),J2G(M)
 997  FORMAT(' TOTAL SPECIAL CORNER POINTS (MOMN) REACHES 1500.',
     1 ' LAST I,J =',2I8)
       STOP
 125   MCMX=MC
C      write (*,*) "num special corner points smooth", mcmx
C
      IF(MCMX.EQ.0) GO TO 115
      DO 114 M=1,MCMX
      MM=MCT(M)
      II=I2G(MM)
      JJ=J2G(MM)
      DO 116 K=1,4
      I=II+IH(K)
      J=JJ+JH(K)
      IF(HB(I,J)+ZB(I,J).EQ.0.) GO TO 116
      HSUB(I,J)=888.
 116  CONTINUE
 114  CONTINUE
 115  CONTINUE
C
      IF(NSQRW.EQ.0) GO TO 124
      DO 122 L=1,NSQRW
      IF(F1DACT(L).EQ.'T') GO TO 122
      I=ISQR(L)
      IF(I.LE.1.OR.I.GE.IMXB1) GO TO 122
      J=JSQR(L)
      IF(J.LE.1.OR.J.GE.JMXB1) GO TO 122
      IF(HSUB(I,J).EQ.999.) GO TO 122
      K=ISIDE(L)
      II=I+IHH(K)
      JJ=J+JHH(K)
      IF(HSUB(II,JJ).EQ.999.) GO TO 122
      IF(HSUB(I,J).LE.(ZBMIN(L)+1.)) GO TO 123
      IF(HSUB(II,JJ).LE.(ZBMIN(L)+1.)) GO TO 123
      GO TO 122
 123  HSUB(I,J)=888.
      HSUB(II,JJ)=888.
 122  CONTINUE
 124  CONTINUE
      M=0
      MM=0
      DO 130 J=1,JMXB1
      DO 130 I=1,IMXB1
      IF(HSUB(I,J).EQ.999.) GO TO 130
      IF(HSUB(I,J).EQ.888.) GO TO 132
      IF(M+MM.GE.M2G_) GO TO 140
      M=M+1
      I2G(M)=I
      J2G(M)=J
      GO TO 130
 132  IF(MM.GE.MCT_) GO TO 140
      MM=MM+1
      I2GG(MM)=I
      J2GG(MM)=J
 130  CONTINUE
 140  MM2G=M
      MCMX=MM
      IF (MM2G.GE.M2G_) THEN
CC       WRITE(*,1998) M2G_,I2G(M),J2G(M)
 1998  FORMAT(' TOTAL HGHT. POINTS FOR SMOOTHING REACHES MAX.',I8,
     1 ' LAST I,J =',2I8)
      STOP
      ENDIF 
      IF (MCMX.GE.MCT_) THEN 
CC      WRITE(*,1997) MCT_,I2G(M),J2G(M)
 1997 FORMAT(' TOTAL SPECIAL CORNER POINTS (HGHTS) REACHES MAX.',I8,
     1 ' LAST I,J =',2I8)
      STOP
      ENDIF
C        
      IF(MCMX.EQ.0) GO TO 400
      DO 310 M=1,MCMX
      I2G(M+MM2G)=I2GG(M)
      J2G(M+MM2G)=J2GG(M)
 310  CONTINUE
 400  CONTINUE
C
C      write (*,*)'  itime = ',ITIME
C      WRITE(*,150)MM2G,MCMX
C 150  FORMAT('  TOTAL NO OF SQUARES FOR SMOOTHING = ',I10,' + ',I10)
C      WRITE(*,332)MCMX
C 332  FORMAT('   TOTAL SPECIAL CORNER POINTS=',I7,' I AND J =')
c     PRINT 333,(I2GG(M),M=1,MCMX)
c     PRINT 333,(J2GG(M),M=1,MCMX)
C 333  FORMAT (40I3)
c
      CALL FLT2G
      RETURN
        END
C********************************************************************        
      SUBROUTINE FLT2G
C        AUG 22 1984   J. CHEN         TDL   IBM 360/195
C        PURPOSE
C           TO ELIMINATE 2-GRID COMPUTATIONAL NOISE NEARBY LAND-WATER
C           BOUNDARIES. GRIG POINTS NEARBY INTERIOR BOUNDARIES ARE
C           PICKED OUT FROM TESTING IN SUBROUTINE 'SMPT2G'. SMOOTHING
C           DOES CONSERVE MASS BY ASSUMING OUSIDE OF SELECTED POINTS IS
C           NON-INTERACTING WITH THE POINTS TO BE SMOOTHED.
C********************************************************************
C        DATA SET USE
C           NONE
C        RETURNS
C           NO
C        VARIABLES
C                MM2G = TOTAL NO. OF POINTS TO BE SMOOTHED
C                MCMX = SPECIAL SMOOTHING POINTS
C         I2G(),J2G() = I,J COORD'S OF GRID POINTS FOR SMOOTHING
C             HB( , ) = SURGE HEIGHT FILED
C             ZB( , ) = TERRAIN HEIGHTS
C            ZBM( , ) = BARRIER HEIGHTS
C                 HCT = CUTOFF DEPTH ,1 FT EXCEPT THE SPECIAL POINTS
C                       WHICH 0 FT IS USED
C       COORDINATES ARE PICKED OUT FROM SUBROUTINE 'CONTTY)'.
C
      INCLUDE 'parm.for'
C
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      COMMON /GAMAF/  GAMA,GAMA1,GAMFP(4)
      COMMON /GPRT1/  DOLLAR,EBSN
      CHARACTER*2     DOLLAR
      CHARACTER*1     EBSN
      COMMON /SM2G/   MM2G,MCMX,I2G(M2G_),J2G(M2G_)
      INTEGER*2       MM2G,MCMX,I2G,J2G
      COMMON /DUMB8/  IP(4),JP(4),IH(4),JH(4)
      COMMON /DUM88/  IIH(4),JJH(4),IHH(4),JHH(4)
      DIMENSION   GAMF(4)
C
C
      IF (MCMX.EQ.0) GO TO 10
      DO 1010 M=1,MCMX
      I=I2G(MM2G+M)
      J=J2G(MM2G+M)
 1010 HSUB(I,J)=999.
 10   CONTINUE
C
      HCT=1.
      M1=1
      MMM=MM2G
      NNN=0
 3000 CONTINUE
      NNN=NNN+1
      IF (NNN.GT.2) GO TO 2000
      DO 190 M=M1,MMM
      I=I2G(M)
      J=J2G(M)
      IF(HSUB(I,J)+ZB(I,J).LE.HCT) GO TO 190
C
      HSM=0.
      HDIF=0.
      GAM0=ELPDL2(I)+(ELPCL2(I)-ELPDL2(I))*SINL2(J)
C
      DO 170 K=1,4
      II=I+IIH(K)
      JJ=J+JJH(K)
      IF (II.EQ.0.OR.JJ.EQ.0) THEN
        GAMF(K)=0.
        GOTO 160
        ENDIF
      IF (EBSN.EQ.'$'.OR.EBSN.EQ.'+') THEN
      GAMFK=ELPDL2(II)+(ELPCL2(II)-ELPDL2(II))*SINL2(JJ)
c      GAMF(K)=.5*(1.+GAMFK/GAM0)-1.
      Z=GAMFK/GAM0
      GAMF(K)=2.*Z/(1.+Z)-1.
      ELSE
      GAMF(K)=GAMFP(K)
      ENDIF
c
      IF (II.EQ.IMXB.OR.JJ.EQ.JMXB) GOTO 160
      IF (HSUB(II,JJ).EQ.999.) GO TO 160
      IF (HSUB(II,JJ)+ZB(II,JJ).LE.HCT) GO TO 160
      KK=MOD(K,4)+1
      IA=I+IP(K)
      IB=I+IP(KK)
      JA=J+JP(K)
      JB=J+JP(KK)
      Z =ZBM(IA,JA)
      ZZ=ZBM(IB,JB)
      ZZZ=AMIN1(Z,ZZ)+HCT
C        WATER ON EITHER SIDE MUST EXCEED THE BARRIER(LOWER) BY AT
      IF(NNN.EQ.2) GO TO 200
      IF( HSUB(I,J).LT.ZZZ.OR.HSUB(II,JJ).LT.ZZZ) THEN
          HSM=HSM+HSUB(I,J)
          HZZ=HSUB(I,J)
          ELSE
          HSM=HSM+HSUB(II,JJ)
          HZZ=HSUB(II,JJ)
          ENDIF
      GOTO 210
 200  IF( HSUB(I,J).LT.ZZZ.AND.HSUB(II,JJ).LT.ZZZ) THEN
          HSM=HSM+HSUB(I,J)
          HZZ=HSUB(I,J)
          ELSE
          HSM=HSM+HSUB(II,JJ)
          HZZ=HSUB(II,JJ)
          ENDIF
      GOTO 210
 160  CONTINUE
          HSM=HSM+HSUB(I,J)
          HZZ=HSUB(I,J)
 210  CONTINUE
C       WEIGHTING ADJUSTMENTS IN I-DIRECTION DUE TO POLAR GRIDS.
       HDIF=HDIF+HZZ*GAMF(K)
  170 CONTINUE
C
      HBTEMP=(1./3.)*HSUB(I,J)+(HSM+HDIF)/6.
C      HBTEMP=.5*HSUB(I,J)+.125*(HSM+HDIF)
      HB(I,J)=AMAX1(HBTEMP,-ZB(I,J))
  190 CONTINUE
      IF(MCMX.EQ.0) GO TO 2000
      DO 1020 M=1,MM2G
      I=I2G(M)
      J=J2G(M)
 1020 HSUB(I,J)=999.
      HCT=0.
      M1=MM2G+1
      MMM=MM2G+MCMX
      DO 1030 M=M1,MMM
      I=I2G(M)
      J=J2G(M)
 1030 HSUB(I,J)=HB(I,J)
      GO TO 3000
 2000  CONTINUE
      RETURN
      END
C********************************************************************
      SUBROUTINE FILTER
C        SEPTEMBER 1980    JYE CHEN    TDL   IBM 360/195
C        PURPOSE
C           TO SMOOTH THE SURGE HEIGHTS ONCE AN HOUR TO ELIMINATE
C           2-INTERVAL NOISES IN THE FIELDS.
C********************************************************************
C        DATA SET USE
C           NONE
C
C        VARIABLES
C       HSUB(  ,  ) = SCRATCH SPACES
C       IP(4) JP(4) = SHIFTS OF I J FROM HEIGHT PT TO 4 MOMNTN CORNERS
C          IBB(6,M) = RANGES AND INCREMENTS FOR 3 DO-LOOPS OF I,J
C                     M=1 INTERIOR,M=2 HORZNTL BNDY,M=3 VERTICAL BNDY
C                     RANGES ON THREE BASIN SEGMENTS ARE:
C
C                              222222222........2222222
C                              311111111........1111113
C                              311111111........1111113
C                              .                      .    J
C                              .                      .    J
C                              311111111........1111113    J
C                              311111111........1111113    J
C                              222222222........2222222    ---->I
C
C          J2(J) JC = SHIFT J-SUBSCRIPT TO PRESENT TIME OF SURGE FIELD
C        HB(  ,   ) = SURGE FIELD
C         ZB(  ,  ) = DEPTH FIELD
C     IIH(4) JJH(4) = I/J-SHIFT SUBSCRIPTS FOR SURGE POINTS
C       IP(4) JP(4) = I/J-SHIFT SUBSCRPTS FOR MOMNTM PTS, IN 'BLCKDT'
C
C           THE (I,J) SHIFTS TO MOMENTUM POINTS, VIA IP(4) AND JP(4),
C           ON CORNER POINTS K=1 TO 4 ARE:
C
C                        I+0,J+1      I+1,J+1
C                           K=4.-----.K=3
C                              I     I
C                              I I*J I
C                              I     I
C                           K=1.-----.K=2
C                        I+0,J+0      I+1,J+0
C
C        ZBM(  ,  ) = MAX BARRIER HEIGHTS AT MOMENTUM POINTS
C        GENERAL COMMENTS
C           THIS SUBROUTINE RESIDES IN OVERLAY 'CMPUTE'.
C           A 5-POINT SMOOTHING OPERATOR IS USED, NEIGHBORING GRIDS
C           WEIGHED CONDITIONALLY IF THEY ARE DRY OR BLOCKED
C           BY BARRIERS. SHIFTS OF (I,J) TO ADJACENT SQUARES ARE SET
C           VIA IIH(4) AND JJH(4). IIH/0,1,0,-1/,JJH/-1,0,1,0/
C
C                    I-1     I      I+1
C                        .-----.             +HMX,HB,ZB HEIGHT PTS
C                  I+IIH I I+0 I             .ZBM BARRIER PTS
C             J+1    +   I 3+  I
C                  J+JJH I J+1 I             EXAMPLE 0.INTERIOR POINTS
C                  .-----.-----.-----.        I  1  I        I  0  I
C                  I I-1 I     I I+1 I        I     I        I     I
C             J    I 4+  I  +  I 2+  I  (1/8) I1 4 1I + (1/8)IA 0 BI
C                  I J+0 I(I,J)I J+0 I        I     I        I     I
C                  .-----.-----.-----.        I  1  I        I  0  I
C                        I I+0 I
C             J-1        I 1+  I
C                        I J-1 I             A=GAMA1,B=GAMA
C                        .-----.
C                    I-1     I      I+1
C
C                        .-----.
C                        I     I
C             J+1        I 3+  I       EXAMPLE 1. SUQARE 2 EXCLUDED
C                        I     I
C                  .-----.-----.          I  1  I        I  0  I
C                  I     I     I          I     I        I     I
C             J    I 4+  I  +  I    (1/8) I1 5 0I + (1/8)IA B 0I
C                  I     I(I,J)I          I     I        I     I
C                  .-----.-----.          I  1  I        I  0  I
C                        I     I
C             J-1        I 1+  I
C                        I     I
C                        .-----.
C
C                                       EXAMPLE 2. SQUARES 2 AND 3
C                                                  ARE EXCLUDED
C                  .-----.-----.          I  0  I        I  0  I
C                  I     I     I          I     I        I     I
C             J    I 4+  I  +  I    (1/8) I1 6 0I + (1/8)IA B 0I
C                  I     I(I,J)I          I     I        I     I
C                  .-----.-----.          I  1  I        I  0  I
C                        I     I
C             J-1        I 1+  I
C                        I     I
C                        .-----.
C
      INCLUDE 'parm.for'
C
      COMMON /FFTH/   ITIME,MHALT
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      COMMON /EGTH/   DELS,DELT,G,COR
      COMMON /DUMB8/  IP(4),JP(4),IH(4),JH(4)
      COMMON /DUM88/  IIH(4),JJH(4),IHH(4),JHH(4)
      COMMON /GAMAF/  GAMA,GAMA1,GAMFP(4)
      COMMON /GPRT1/  DOLLAR,EBSN
      DIMENSION       GAMF(4)
      DIMENSION       IBB(6,3)
      CHARACTER*2     DOLLAR
      CHARACTER*1     EBSN
      DATA HCRT/0.5/
      DATA IBB(1,1),IBB(1,2),IBB(1,3)/2,1,2/,
     1     IBB(3,1),         IBB(3,3)/1,  1/,
     2     IBB(4,1),IBB(4,2),IBB(4,3)/2,1,1/,
     3     IBB(6,1),IBB(6,2)         /1,1  /
C      write (*,*) "Inside filter"
      IBB(2,1)=JMXB2
      IBB(2,3)=JMXB2
      IBB(3,2)=JMXB2
      IBB(2,2)=JMXB1
      IBB(5,1)=IMXB2
      IBB(6,3)=IMXB2
      IBB(5,2)=IMXB1
      IBB(5,3)=IMXB1
      DO 100 J=1,JMXB1
      DO 100 I=1,IMXB1
 100  HSUB(I,J)=HB(I,J)
      DO 210 M=1,3
      JL  =IBB(1,M)
      JM  =IBB(2,M)
      JNCR=IBB(3,M)
      IL  =IBB(4,M)
      IM  =IBB(5,M)
      INCR=IBB(6,M)
      DO 200 J=JL,JM,JNCR
      DO 190 I=IL,IM,INCR
C        SKIP COMPUTATIONS FOR TERRAIN HIGHER THAN 35 FT.
      IF(ZB(I,J).LE.-35.) GO TO 190
      HST=HSUB(I,J)+ZB(I,J)
C        TEST FOR LAND WETTED LESS THAN 1 FT.
      IF(HST.LT.HCRT) GO TO 190
      HSM=0.
      HDIF=0.
C
C******** 'LOOP' FOR SMOOTHING******************************************
      GAM0=ELPDL2(I)+(ELPCL2(I)-ELPDL2(I))*SINL2(J)
      DO 170 K=1,4
      II=I+IIH(K)
      JJ=J+JJH(K)
      IF (M.EQ.1) GOTO 158
        IF (II.EQ.0.OR.JJ.EQ.0) THEN
        GAMF(K)=0.
        GO TO 160
        ENDIF
 158  CONTINUE
      IF (EBSN.EQ.'$'.OR.EBSN.EQ.'+') THEN
      GAMFK=ELPDL2(II)+(ELPCL2(II)-ELPDL2(II))*SINL2(JJ)
C      GAMF(K)=.5*(1.+GAMFK/GAM0)-1.
      Z=GAMFK/GAM0
      GAMF(K)=2.*Z/(1.+Z)-1.
      ELSE
      GAMF(K)=GAMFP(K)
      ENDIF
      IF (II.EQ.IMXB.OR.JJ.EQ.JMXB) GOTO 160
C        THE NEIGHBORING SQUARE IS MERELY WET(LESS THAN 1 FT).
      IF (HSUB(II,JJ)+ZB(II,JJ).LT.HCRT) GO TO 160
      KK=MOD(K,4)+1
      IA=I+IP(K)
      IB=I+IP(KK)
      JA=J+JP(K)
      JB=J+JP(KK)
      Z =ZBM(IA,JA)
      ZZ=ZBM(IB,JB)
      ZZZ=AMIN1(Z,ZZ)+1.
C        WATER ON EITHER SIDE MUST EXCEED THE BARRIER(LOWER) BY AT
C        LEAST 1 FT.
      IF( HSUB(I,J).LT.ZZZ.OR.HSUB(II,JJ).LT.ZZZ) THEN
          HSM=HSM+HSUB(I,J)
          HZZ=HSUB(I,J)
          ELSE
          HSM=HSM+HSUB(II,JJ)
          HZZ=HSUB(II,JJ)
          ENDIF
      GOTO 212
 160  CONTINUE
          HSM=HSM+HSUB(I,J)
          HZZ=HSUB(I,J)
 212  CONTINUE
C       WEIGHTING ADJUSTMENTS IN I-DIRECTION DUE TO POLAR GRIDS.
       HDIF=HDIF+HZZ*GAMF(K)
C
 170  CONTINUE
      HTEMP=.5*HSUB(I,J)+(HSM+HDIF)/8.
C******* END 'LOOP' FOR SMOOTHING **************************************
C
 180  HB(I,J)=AMAX1(-ZB(I,J),HTEMP)
 190  CONTINUE
 200  CONTINUE
 210  CONTINUE
      RETURN
      END
      SUBROUTINE FLTER2
      INCLUDE 'parm.for'
C
      COMMON /FFTH/   ITIME,MHALT
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      COMMON /EGTH/   DELS,DELT,G,COR
      COMMON /DUMB8/  IP(4),JP(4),IH(4),JH(4)
      COMMON /DUM88/  IIH(4),JJH(4),IHH(4),JHH(4)
      COMMON /GAMAF/  GAMA,GAMA1,GAMFP(4)
      COMMON /GPRT1/  DOLLAR,EBSN
      DIMENSION       GAMF(4)
      CHARACTER*2     DOLLAR
      CHARACTER*1     EBSN
      DATA HCRT/0.5/
C
      DO 100 J=1,JMXB
      DO 100 I=1,IMXB
 100  HSUB(I,J)=HB(I,J)
      DO 210 M=1,2
C     TOP AND BOTTOM BOUNDARY CONDITIONS M=2
C     INTERIOR POINTS M=1 INCLUDING SIDE BOUNDARIES.
       IF (M.EQ.1) THEN
         IL  =2
         IM  =IMXB2
         INCR=1
         ELSE
         IL  =1
         IM  =IMXB1
         INCR=IMXB2
         ENDIF
      DO 200 J=1,JMXB1
      DO 190 I=IL,IM,INCR
C        SKIP COMPUTATIONS FOR TERRAIN HIGHER THAN 35 FT.
      IF(ZB(I,J).LE.-35.) GO TO 190
      HST=HSUB(I,J)+ZB(I,J)
C        TEST FOR LAND WETTED LESS THAN 1 FT.
      IF(HST.LT.HCRT) GO TO 190
      HSM=0.
      HDIF=0.
C
C******** 'LOOP' FOR SMOOTHING******************************************
      GAM0=ELPDL2(I)+(ELPCL2(I)-ELPDL2(I))*SINL2(J)
      DO 170 K=1,4
      II=I+IIH(K)
      JJ=J+JJH(K)
      IF (JJ.EQ.0) JJ=JMXB1
        IF (II.EQ.0) THEN
        GAMF(K)=0.
        GO TO 160
        ENDIF
 158  CONTINUE
      IF (EBSN.EQ.'$'.OR.EBSN.EQ.'+') THEN
      GAMFK=ELPDL2(II)+(ELPCL2(II)-ELPDL2(II))*SINL2(JJ)
c      GAMF(K)=.5*(1.+GAMFK/GAM0)-1.
      Z=GAMFK/GAM0
      GAMF(K)=2.*Z/(1.+Z)-1.
      ELSE
      GAMF(K)=GAMFP(K)
      ENDIF
      IF (II.EQ.IMXB) GOTO 160
C        THE NEIGHBORING SQUARE IS MERELY WET(LESS THAN 1 FT).
      IF (HSUB(II,JJ)+ZB(II,JJ).LT.HCRT) GO TO 160
      KK=MOD(K,4)+1
      IA=I+IP(K)
      IB=I+IP(KK)
      JA=J+JP(K)
      JB=J+JP(KK)
      Z =ZBM(IA,JA)
      ZZ=ZBM(IB,JB)
      ZZZ=AMIN1(Z,ZZ)+1.
C        WATER ON EITHER SIDE MUST EXCEED THE BARRIER(LOWER) BY AT
C        LEAST 1 FT.
      IF( HSUB(I,J).LT.ZZZ.OR.HSUB(II,JJ).LT.ZZZ) THEN
          HSM=HSM+HSUB(I,J)
          HZZ=HSUB(I,J)
          ELSE
          HSM=HSM+HSUB(II,JJ)
          HZZ=HSUB(II,JJ)
          ENDIF
      GOTO 212
 160  CONTINUE
          HSM=HSM+HSUB(I,J)
          HZZ=HSUB(I,J)
 212  CONTINUE
C       WEIGHTING ADJUSTMENTS IN I-DIRECTION DUE TO POLAR GRIDS.
       HDIF=HDIF+HZZ*GAMF(K)
C
 170  CONTINUE
      HTEMP=.5*HSUB(I,J)+(HSM+HDIF)/8.
C******* END 'LOOP' FOR SMOOTHING **************************************
C
 180  HB(I,J)=AMAX1(-ZB(I,J),HTEMP)
 190  CONTINUE
 200  CONTINUE
 210  CONTINUE
      DO 300 I=1,IMXB
 300  HB(I,JMXB)=HB(I,1)
      RETURN
       END
C********************************************************************       
      SUBROUTINE SNAPSH
C       CONVERT SURGE ENVELOP DATA WITH 999 FOR DRY SQUARES SO THAT ZB()
C       CAN BE FREE FROM THE MEMORY.
C********************************************************************
      INCLUDE 'parm.for'
C
      COMMON /IDENT/  AIDENT(40),DACLOK(7)
      COMMON /GPRT1/  DOLLAR,EBSN
      COMMON /SWTCH/  IOPERL(5)
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      CHARACTER*2     DOLLAR
      CHARACTER*1     EBSN
C        REPLACE HMX BY 999 IF THE SQUARE IS DRY.
       DO 1 J=1,JMXB
       DO 1 I=1,IMXB
        IF (HB(I,J)+ZB(I,J).EQ.0) THEN
         IHMX(I,J)=999
         ELSE
         IHMX(I,J)=HB(I,J)*10.+.5
         ENDIF
  1    CONTINUE
C
C      WRITE(77) IMXB,JMXB
C      WRITE(77) AIDENT
C      WRITE (77) ((IHMX(I,J),I=1,IMXB),J=1,JMXB)
C
      IF (DOLLAR.EQ.'2$') THEN
      DO  20 J=1,JMXB
      DO  20 I=1,IMXB
      IF (IHMX(I,J).EQ.999) GOTO 20
      IHMX(I,J)=(HMX(I,J)-ZSUB(J))*10.+.5
 20   CONTINUE
      ENDIF
C       
      IF(IOPERL(1).NE.2) THEN 
      NGRP=(JMXB1-1)/25+1
      DO 1130 NN=1,NGRP
      J1=1+(NN-1)*25
      J2=J1+MIN0(24,JMXB1-J1  )
CC      WRITE(*,180)(J,J=J1,J2)
 180  FORMAT(/I6,26I5)
C
      DO 1120 I=1,IMXB1
CC      WRITE(*,'(1H ,I2,26I5)') I,(IHMX(I,J),J=J1,J2)
 1120  CONTINUE
 1130  CONTINUE
       ENDIF
C
       RETURN
       END
       
C********************************************************************
      subroutine gridWrite (imxb,jmxb)
C     RA Dominguez 06/12/2012      
C This subroutine calculates the latitudes
C and longitudes of the SLOSH grid and
C writes them to netCDF along with the
C weighting values of the structured grid
C********************************************************************
      include 'netcdf.inc'
      include 'parm.for'
C Define variables
      integer :: NCID
      integer :: NC_DimID_j, NC_DimID_i, NC_DimID_time
      integer :: NC_DimID_single
      integer :: NC_VarID_lat, NC_VarID_lon, NC_VarID_time
      integer :: NC_VarID_etamax, NC_VarID_eta, NC_VarID_depth
      integer :: NC_VarID_fxx, NC_VarID_fyy
      integer :: NC_VarID_pxx, NC_VarID_pyy
      integer :: NC_VarID_wxx, NC_VarID_wyy      
      integer :: NC_VarID_fpx, NC_VarID_fpy
      integer :: NC_VarID_fwx, NC_VarID_fwy            
      character*33 :: NCDATE
      character*10 :: NCSTART      

      integer :: LATLONDIM(2), TLL(3)
      integer :: WASTE

C Create the netCDF file
      WASTE = NF_CREATE(NCFILE,NF_NETCDF4,NCID)
C Define dimensions
      WASTE = NF_DEF_DIM(NCID,'i_pts',imxb,NC_DimID_i)
      WASTE = NF_DEF_DIM(NCID,'j_pts',jmxb,NC_DimID_j)
      WASTE = NF_DEF_DIM(NCID,'time',NF_UNLIMITED,NC_DimID_time)
      WASTE = NF_DEF_DIM(NCID,'single',1,NC_DimID_single)      
C Define the dimensions of the variables
      LATLONDIM(1) = NC_DimID_i
      LATLONDIM(2) = NC_DimID_j
      TLL(1) = NC_DimID_i
      TLL(2) = NC_DimID_j
      TLL(3) = NC_DimID_time

      NCDATE='seconds since 0000-00-00 00:00:00'
      write(NCSTART,'(i10)') TBEGIN
      NCDATE(15:18)=NCSTART(1:4)
      NCDATE(20:21)=NCSTART(5:6)
      NCDATE(23:24)=NCSTART(7:8)
      NCDATE(26:27)=NCSTART(9:10)      
      
      
C Define the netCDF variables and attributes
C--Longitude      
      WASTE = NF_DEF_VAR(NCID,'lon',NF_FLOAT,2,LATLONDIM,NC_VarID_lon)
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_lon,'long_name',9,
     &'longitude')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_lon,'standard_name',9,
     &'Longitude')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_lon,'units',12,
     &'degrees_east')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_lon,'positive',4,'east')

C--Latitude      
      WASTE = NF_DEF_VAR(NCID,'lat',NF_FLOAT,2,LATLONDIM,NC_VarID_lat)
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_lat,'long_name',8,
     &'latitude')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_lat,'standard_name',8,
     &'Latitude')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_lat,'units',13,
     &'degrees_north')  
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_lat,'positive',5,'north')

C--Depth
      WASTE = NF_DEF_VAR(NCID,'depth',NF_FLOAT,2,LATLONDIM,
     &NC_VarID_depth)
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_depth,'long_name',19,
     &'distance from geoid')          
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_depth,'standard_name',17,
     &'depth_below_geoid')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_depth,'coordinates',7,
     &'lon lat')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_depth,'mesh',10,
     &'slosh_mesh')                  
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_depth,'location',7,
     &'element')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_depth,'units',1,
     &'m')

C--Time
      WASTE = NF_DEF_VAR(NCID,'time',NF_FLOAT,1,NC_DimID_time,
     &NC_VarID_time)
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_time,'long_name',4,'Time')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_time,'standard_name',4,
     &'time')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_time,'calendar',9,
     &'Gregorian')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_time,'units',33,
     &NCDATE)      

C--Etamax
      WASTE = NF_DEF_VAR(NCID,'etamax',NF_FLOAT,2,LATLONDIM,
     &NC_VarID_etamax)
      WASTE = NF_PUT_ATT_REAL(NCID,NC_VarID_etamax,'_FillValue',
     &NF_FLOAT,1,-999.0)
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_etamax,'long_name',43,
     &'maximum water surface elevation above geoid')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_etamax,'standard_name',38,
     &'maximum_sea_surface_height_above_geoid')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_etamax,'coordinates',7,
     &'lat lon')      
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_etamax,'location',7,
     &'element')      
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_etamax,'mesh',10,
     &'slosh_mesh')            
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_etamax,'units',1,
     &'m')                  

C--Eta
      WASTE = NF_DEF_VAR(NCID,'eta',NF_FLOAT,3,TLL,NC_VarID_eta)
      WASTE = NF_PUT_ATT_REAL(NCID,NC_VarID_eta,'_FillValue',NF_FLOAT,1,
     &-999.0)
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_eta,'long_name',35,
     &'water surface elevation above geoid')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_eta,'standard_name',30,
     &'sea_surface_height_above_geoid')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_eta,'coordinates',12,
     &'time lat lon')      
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_eta,'location',7,
     &'element')      
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_eta,'mesh',10,
     &'slosh_mesh')            
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_eta,'units',1,
     &'m')                  
     
C--Fxx
      WASTE = NF_DEF_VAR(NCID,'fxx',NF_FLOAT,3,TLL,NC_VarID_fxx)
      WASTE = NF_PUT_ATT_REAL(NCID,NC_VarID_fxx,'_FillValue',NF_FLOAT,1,
     &-999.0)
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_fxx,'long_name',13,
     &'wind_stress_x')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_fxx,'standard_name',13,
     &'wind_stress_x')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_fxx,'coordinates',12,
     &'time lat lon')           
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_fxx,'location',7,
     &'element')      
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_fxx,'mesh',10,
     &'slosh_mesh')            
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_fxx,'units',7,
     &'m^2/s^2')      
C--Fyy      
      WASTE = NF_DEF_VAR(NCID,'fyy',NF_FLOAT,3,TLL,NC_VarID_fyy)
      WASTE = NF_PUT_ATT_REAL(NCID,NC_VarID_fyy,'_FillValue',NF_FLOAT,1,
     &-999.0)
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_fyy,'long_name',13,
     &'wind_stress_y')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_fyy,'standard_name',13,
     &'wind_stress_y')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_fyy,'coordinates',12,
     &'time lat lon')      
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_fyy,'location',7,
     &'element')      
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_fyy,'mesh',10,
     &'slosh_mesh')            
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_fyy,'units',7,
     &'m^2/s^2')      
C--Pxx      
      WASTE = NF_DEF_VAR(NCID,'pxx',NF_FLOAT,3,TLL,NC_VarID_pxx)
      WASTE = NF_PUT_ATT_REAL(NCID,NC_VarID_pxx,'_FillValue',NF_FLOAT,1,
     &-999.0)
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_pxx,'long_name',19,
     &'pressure_gradient_x')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_pxx,'standard_name',19,
     &'pressure_gradient_x')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_pxx,'coordinates',12,
     &'time lat lon')      
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_pxx,'location',7,
     &'element')      
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_pxx,'mesh',10,
     &'slosh_mesh')            
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_pxx,'units',6,
     &'mbar/m')      
C--Pyy      
      WASTE = NF_DEF_VAR(NCID,'pyy',NF_FLOAT,3,TLL,NC_VarID_pyy)
      WASTE = NF_PUT_ATT_REAL(NCID,NC_VarID_pyy,'_FillValue',NF_FLOAT,1,
     &-999.0)
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_pyy,'long_name',19,
     &'pressure_gradient_y')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_pyy,'standard_name',19,
     &'pressure_gradient_y')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_pyy,'coordinates',12,
     &'time lat lon')      
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_pyy,'location',7,
     &'element')      
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_pyy,'mesh',10,
     &'slosh_mesh')            
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_pyy,'units',6,
     &'mbar/m')      
C--Wxx      
      WASTE = NF_DEF_VAR(NCID,'wxx',NF_FLOAT,3,TLL,NC_VarID_wxx)
      WASTE = NF_PUT_ATT_REAL(NCID,NC_VarID_wxx,'_FillValue',NF_FLOAT,1,
     &-999.0)
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_wxx,'long_name',12,
     &'wind_speed_x')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_wxx,'standard_name',12,
     &'wind_speed_x')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_wxx,'coordinates',12,
     &'time lat lon')      
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_wxx,'location',7,
     &'element')      
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_wxx,'mesh',10,
     &'slosh_mesh')            
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_wxx,'units',1,
     &'m/s')
C--Wyy      
      WASTE = NF_DEF_VAR(NCID,'wyy',NF_FLOAT,3,TLL,NC_VarID_wyy)      
      WASTE = NF_PUT_ATT_REAL(NCID,NC_VarID_wyy,'_FillValue',NF_FLOAT,1,
     &-999.0)
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_wyy,'long_name',12,
     &'wind_speed_y')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_wyy,'standard_name',12,
     &'wind_speed_y')
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_wyy,'coordinates',12,
     &'time lat lon')      
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_wyy,'location',7,
     &'element')      
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_wyy,'mesh',10,
     &'slosh_mesh')            
      WASTE = NF_PUT_ATT_TEXT(NCID,NC_VarID_wyy,'units',1,
     &'m/s')      


      WASTE = NF_DEF_VAR(NCID,'fwy',NF_FLOAT,3,TLL,NC_VarID_fwy)      
      WASTE = NF_PUT_ATT_REAL(NCID,NC_VarID_fwy,'_FillValue',NF_FLOAT,1,
     &-999.0)
      WASTE = NF_DEF_VAR(NCID,'fwx',NF_FLOAT,3,TLL,NC_VarID_fwx)      
      WASTE = NF_PUT_ATT_REAL(NCID,NC_VarID_fwx,'_FillValue',NF_FLOAT,1,
     &-999.0)
      WASTE = NF_DEF_VAR(NCID,'fpy',NF_FLOAT,3,TLL,NC_VarID_fpy)      
      WASTE = NF_PUT_ATT_REAL(NCID,NC_VarID_fpy,'_FillValue',NF_FLOAT,1,
     &-999.0)
      WASTE = NF_DEF_VAR(NCID,'fpx',NF_FLOAT,3,TLL,NC_VarID_fpx)      
      WASTE = NF_PUT_ATT_REAL(NCID,NC_VarID_fpx,'_FillValue',NF_FLOAT,1,
     &-999.0)      




      WASTE = NF_PUT_ATT_TEXT (NCID, NF_GLOBAL, 'model',5,'SLOSH')

     
C Set compression parameters
C      WASTE = NF_DEF_VAR_DEFLATE(NCID,LAT_ID,0,1,4)
C      WASTE = NF_DEF_VAR_DEFLATE(NCID,LON_ID,0,1,4)
      WASTE = NF_ENDDEF(NCID)

C Store latitude and longitude
      WASTE = NF_PUT_VAR_REAL(NCID,NC_VarID_lon,YLG(1:imxb,1:jmxb))
      WASTE = NF_PUT_VAR_REAL(NCID,NC_VarID_lat,YLT(1:imxb,1:jmxb))
      WASTE = NF_PUT_VAR_REAL(NCID,NC_VarID_depth,ZB(1:imxb,1:jmxb)
     &        /3.28084)
C Close      
      WASTE = NF_CLOSE(NCID)

      write(*,*) "NetCDF has been initialized"

      end subroutine gridWrite

C********************************************************************
      subroutine NetCDFWrite (PCNT)
C********************************************************************
      include 'netcdf.inc'
      include 'parm.for'
C Define variables
      integer :: NCID
      integer, intent(in) :: PCNT
      integer :: NC_VarID_time
      integer :: NC_VarID_etamax, NC_VarID_eta
C      integer :: NC_VarID_fxx, NC_VarID_fyy
C      integer :: NC_VarID_pxx, NC_VarID_pyy
C      integer :: NC_VarID_wxx, NC_VarID_wyy      
C      integer :: NC_VarID_fpx, NC_VarID_fpy
C      integer :: NC_VarID_fwx, NC_VarID_fwy      

      integer :: WASTE
      REAL,allocatable :: NC_eta(:,:), NC_etamax(:,:)
      REAL,allocatable :: NC_depth(:,:)

      COMMON /FFTH/   ITIME, MHALT
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2      

C Create the netCDF file
      WASTE = NF_OPEN(NCFILE,NF_WRITE,NCID)
C Determine variable IDs
      WASTE = NF_INQ_VARID(NCID,'time',NC_VarID_time)   
      WASTE = NF_INQ_VARID(NCID,'eta',NC_VarID_eta)   
      WASTE = NF_INQ_VARID(NCID,'etamax',NC_VarID_etamax)   
C      WASTE = NF_INQ_VARID(NCID,'fxx',NC_VarID_fxx)   
C      WASTE = NF_INQ_VARID(NCID,'fyy',NC_VarID_fyy)   
C      WASTE = NF_INQ_VARID(NCID,'pxx',NC_VarID_pxx)         
C      WASTE = NF_INQ_VARID(NCID,'pyy',NC_VarID_pyy)   
C      WASTE = NF_INQ_VARID(NCID,'wxx',NC_VarID_wxx)         
C      WASTE = NF_INQ_VARID(NCID,'wyy',NC_VarID_wyy)         
C      WASTE = NF_INQ_VARID(NCID,'fpx',NC_VarID_fpx)         
C      WASTE = NF_INQ_VARID(NCID,'fpy',NC_VarID_fpy)   
C      WASTE = NF_INQ_VARID(NCID,'fwx',NC_VarID_fwx)         
C      WASTE = NF_INQ_VARID(NCID,'fwy',NC_VarID_fwy)         

C Store Values
      WASTE = NF_PUT_VAR1_REAL(NCID,NC_VarID_time,pcnt,etime)
      allocate(NC_depth(1:IMXB,1:JMXB))
      allocate(NC_etamax(1:IMXB,1:JMXB))
      allocate(NC_eta(1:IMXB,1:JMXB))      
      do I = 1,IMXB
         do J = 1,JMXB
           NC_depth(i,j)  = -ZB(I,J)
           NC_etamax(i,j) = HMX(I,J)
           NC_eta(i,j)    =  HB(I,J)          
           if (NC_etamax(i,j).eq.NC_depth(i,j)) then
             NC_etamax(i,j) = -999.
           elseif ((J.eq.JMXB).or.(I.eq.IMXB)) then
             NC_etamax(i,j) = -999.
           else           
             NC_etamax(i,j) = NC_etamax(i,j)/3.28084
           endif
           if (NC_eta(i,j).eq.NC_depth(i,j) ) then
             NC_eta(i,j) = -999.
           elseif ((J.eq.JMXB).or.(I.eq.IMXB)) then
             NC_eta(i,j) = -999.             
           else
             NC_eta(i,j) = NC_eta(i,j)/3.28084
           endif
        enddo
      enddo
      WASTE = NF_PUT_VAR_REAL(NCID,NC_VarID_etamax,NC_etamax)
      WASTE = NF_PUT_VARA_REAL(NCID,NC_VarID_eta,         
     &             (/I,J,PCNT/),(/IMXB,JMXB,1/),NC_eta)
C      WASTE = NF_PUT_VARA_REAL(NCID,NC_VarID_fxx,
C     &             (/I,J,PCNT/),(/IMXB,JMXB,1/),GFXX)
C      WASTE = NF_PUT_VARA_REAL(NCID,NC_VarID_fyy,
C     &             (/I,J,PCNT/),(/IMXB,JMXB,1/),GFYY)
C      WASTE = NF_PUT_VARA_REAL(NCID,NC_VarID_pxx,
C     &             (/I,J,PCNT/),(/IMXB,JMXB,1/),GPXX)
C      WASTE = NF_PUT_VARA_REAL(NCID,NC_VarID_pyy,
C     &             (/I,J,PCNT/),(/IMXB,JMXB,1/),GPYY)           
C      WASTE = NF_PUT_VARA_REAL(NCID,NC_VarID_wxx,
C     &             (/I,J,PCNT/),(/IMXB,JMXB,1/),GWXX)
C      WASTE = NF_PUT_VARA_REAL(NCID,NC_VarID_wyy,
C     &             (/I,J,PCNT/),(/IMXB,JMXB,1/),GWYY)                
C      WASTE = NF_PUT_VARA_REAL(NCID,NC_VarID_fpx,
C     &             (/I,J,PCNT/),(/IMXB,JMXB,1/),GFPX)
C      WASTE = NF_PUT_VARA_REAL(NCID,NC_VarID_fpy,
C     &             (/I,J,PCNT/),(/IMXB,JMXB,1/),GFPY)           
C      WASTE = NF_PUT_VARA_REAL(NCID,NC_VarID_fwx,
C     &             (/I,J,PCNT/),(/IMXB,JMXB,1/),GFWX)
C      WASTE = NF_PUT_VARA_REAL(NCID,NC_VarID_fwy,
C     &             (/I,J,PCNT/),(/IMXB,JMXB,1/),GFWY)           

      Deallocate(NC_depth,NC_eta,NC_etamax)
C Close      
      WASTE = NF_CLOSE(NCID)
      end subroutine

C********************************************************************      
      SUBROUTINE NETPRESSURE()
C This subroutine extracts pressure from the netcdf pressure file
C********************************************************************            
      INCLUDE 'netcdf.inc'
      include 'parm.for'

      INTEGER :: NCID, WASTE
      INTEGER :: NC_DimID_Lat, NC_DimID_Lon, NC_DimID_Time
      INTEGER :: NC_VarID_Pressure,DLAT_ID,DLON_ID
      INTEGER :: NLAT_ID,NLON_ID,SWLAT_ID,SWLON_ID
      INTEGER :: NC_VarID_date
      INTEGER :: TSTART_ID,TFINAL_ID,DT_ID
      INTEGER :: DT,NT, TSNAP
      INTEGER :: I,J,T,K,L

      DOUBLE PRECISION :: TSTART,TFINAL
      DOUBLE PRECISION, allocatable :: NCTIMES(:)
      DOUBLE PRECISION, allocatable :: NCOWI(:,:,:)      

      REAL :: pi
      REAL :: T_W

      COMMON /FFTH/   ITIME, MHALT
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2

C Determine whether file is opened yet
      if(POPEN.eq.0) then
C Open NetCDF data set
        WASTE = NF_OPEN(PRFILE,NF_NOWRITE,NCID)
C Determine dimension IDs
        WASTE = NF_INQ_DIMID(NCID,'longitude',NC_DimID_Lon)
        WASTE = NF_INQ_DIMID(NCID,'latitude',NC_DimID_Lat)
        WASTE = NF_INQ_DIMID(NCID,'time',NC_DimID_Time)      
C Determine variable IDs
        WASTE = NF_INQ_VARID(NCID,'pressure',NC_VarID_Pressure)
        WASTE = NF_INQ_VARID(NCID,'dlat',DLAT_ID)
        WASTE = NF_INQ_VARID(NCID,'dlon',DLON_ID)      
        WASTE = NF_INQ_VARID(NCID,'nlat',NLAT_ID)
        WASTE = NF_INQ_VARID(NCID,'nlon',NLON_ID)
        WASTE = NF_INQ_VARID(NCID,'SWlat',SWLAT_ID)
        WASTE = NF_INQ_VARID(NCID,'SWlon',SWLON_ID)      
        WASTE = NF_INQ_VARID(NCID,'TSTART',TSTART_ID)
        WASTE = NF_INQ_VARID(NCID,'TFINAL',TFINAL_ID)
        WASTE = NF_INQ_VARID(NCID,'DT',DT_ID)
        WASTE = NF_INQ_VARID(NCID,'date',NC_VarID_date)      
C Read the variables from the netCDF
        WASTE = NF_GET_VAR1(NCID,DLAT_ID,(/1/),DLAT)
        WASTE = NF_GET_VAR1(NCID,DLON_ID,(/1/),DLON)
        WASTE = NF_GET_VAR1_INT(NCID,NLAT_ID,(/1/),NLAT)
        WASTE = NF_GET_VAR1_INT(NCID,NLON_ID,(/1/),NLON)
        WASTE = NF_GET_VAR1(NCID,SWLAT_ID,(/1/),SWLAT)
        WASTE = NF_GET_VAR1(NCID,SWLON_ID,(/1/),SWLON)
        WASTE = NF_GET_VAR1(NCID,TSTART_ID,(/1/),TSTART)
        WASTE = NF_GET_VAR1(NCID,TFINAL_ID,(/1/),TFINAL)
        WASTE = NF_GET_VAR1_INT(NCID,DT_ID,(/1/),DT)
C Determine number of time snaps
        WASTE = NF_INQ_DIMLEN(NCID,NC_DimID_Time,NT)      
        allocate(NCTIMES(1:NT))
        WASTE = NF_GET_VAR(NCID,NC_VarID_date,NCTIMES)
C Search through time snaps for matching start time
        do TIMEI=1,NT
          IF (TBEGIN.EQ.(NCTIMES(I)/100)) THEN
            exit
          ENDIF
        ENDDO
        deallocate(NCTIMES)
        ALLOCATE( NCOWI(1:NLON,1:NLAT,1))
        PSNAP = 0
        POPEN=1
      elseif(POPEN.eq.2) then
C File has been closed
        return      
      endif

      ALLOCATE( NCOWI(1:NLON,1:NLAT,1))

C Determine Relative Time Snap
      TSNAP = ETIME/DT+I
      T = FLOOR(ETIME/DT)+1
      T_W = 1-(ETIME/DT-(T-1))

      IF (TSNAP.LT.NT) Then
        if (PSNAP.eq.0) then
          WASTE = NF_GET_VARA_DOUBLE(NCID,NC_VarID_Pressure,
     &    (/1,1,TSNAP/),(/NLON,NLAT,1/),NCOWI)       
          CALL  INTERPOWIP(NCOWI,PXX1,PYY1)
          WASTE = NF_GET_VARA_DOUBLE(NCID,NC_VarID_Pressure,
     &    (/1,1,TSNAP+1/),(/NLON,NLAT,1/),NCOWI)       
          CALL  INTERPOWIP(NCOWI,PXX2,PYY2)
          PSNAP = TSNAP
        elseif (PSNAP.ne.TSNAP) then
          PXX1 = PXX2
          PYY1 = PYY2          
          WASTE = NF_GET_VARA_DOUBLE(NCID,NC_VarID_Pressure,
     &    (/1,1,TSNAP+1/),(/NLON,NLAT,1/),NCOWI)
          CALL  INTERPOWIP(NCOWI,PXX2,PYY2)
          PSNAP = TSNAP          
        endif
      else
        WASTE = NF_CLOSE(NCID)
        POPEN=2
        RETURN
      endif      

      DEALLOCATE( NCOWI)      
      write(6,*) PSNAP, TSNAP, ETIME

C     Interpolate Pressure Temporally      
      DO I = 1,IMXB-1
        DO J = 1,JMXB-1
            GPXX(I,J) = (PXX1(I,J)*T_W + PXX2(I,J)*(1.-T_W))
            GPYY(I,J) = (PYY1(I,J)*T_W + PYY2(I,J)*(1.-T_W))         
        ENDDO
      ENDDO

      END SUBROUTINE 

C********************************************************************      
      SUBROUTINE NETSTRESS()
C This subroutine extracts windstress from the netcdf windstress file
C********************************************************************            

      INCLUDE 'netcdf.inc'
      include 'parm.for'

      INTEGER :: NCID, WASTE
      INTEGER :: NC_DimID_Lat, NC_DimID_Lon, NC_DimID_Time
      INTEGER :: FX_ID,FY_ID,DLAT_ID,DLON_ID      
      INTEGER :: NLAT_ID,NLON_ID,SWLAT_ID,SWLON_ID
      INTEGER :: NC_VarID_date
      INTEGER :: TSTART_ID,TFINAL_ID,DT_ID
      INTEGER :: DT,NT, TSNAP
      INTEGER :: I,J,T,K,L

      DOUBLE PRECISION :: TSTART,TFINAL
      DOUBLE PRECISION, allocatable :: NCTIMES(:)
      DOUBLE PRECISION, allocatable :: NCOWI(:,:,:)      

      REAL :: T_W

      COMMON /FFTH/   ITIME, MHALT
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2

C Determine whether file is opened yet
      if(SOPEN.eq.0) then
C Open NetCDF data set
        WASTE = NF_OPEN(WNFILE,NF_NOWRITE,NCID)
C Determine dimension IDs
        WASTE = NF_INQ_DIMID(NCID,'gridx',NC_DimID_Lon)
        WASTE = NF_INQ_DIMID(NCID,'gridy',NC_DimID_Lat)
        WASTE = NF_INQ_DIMID(NCID,'time',NC_DimID_Time)      
C Determine variable IDs
        WASTE = NF_INQ_VARID(NCID,'wind_stress_x',FX_ID)
        WASTE = NF_INQ_VARID(NCID,'wind_stress_y',FY_ID)   
        WASTE = NF_INQ_VARID(NCID,'dlat',DLAT_ID)
        WASTE = NF_INQ_VARID(NCID,'dlon',DLON_ID)      
        WASTE = NF_INQ_VARID(NCID,'nlat',NLAT_ID)
        WASTE = NF_INQ_VARID(NCID,'nlon',NLON_ID)
        WASTE = NF_INQ_VARID(NCID,'SWlat',SWLAT_ID)
        WASTE = NF_INQ_VARID(NCID,'SWlon',SWLON_ID)      
        WASTE = NF_INQ_VARID(NCID,'TSTART',TSTART_ID)
        WASTE = NF_INQ_VARID(NCID,'TFINAL',TFINAL_ID)
        WASTE = NF_INQ_VARID(NCID,'DT',DT_ID)
        WASTE = NF_INQ_VARID(NCID,'date',NC_VarID_date)      
C Read the variables from the netCDF
        WASTE = NF_GET_VAR1(NCID,DLAT_ID,(/1/),DLAT)
        WASTE = NF_GET_VAR1(NCID,DLON_ID,(/1/),DLON)
        WASTE = NF_GET_VAR1_INT(NCID,NLAT_ID,(/1/),NLAT)
        WASTE = NF_GET_VAR1_INT(NCID,NLON_ID,(/1/),NLON)
        WASTE = NF_GET_VAR1(NCID,SWLAT_ID,(/1/),SWLAT)
        WASTE = NF_GET_VAR1(NCID,SWLON_ID,(/1/),SWLON)
        WASTE = NF_GET_VAR1(NCID,TSTART_ID,(/1/),TSTART)
        WASTE = NF_GET_VAR1(NCID,TFINAL_ID,(/1/),TFINAL)
        WASTE = NF_GET_VAR1_INT(NCID,DT_ID,(/1/),DT)
C Determine number of time snaps
        WASTE = NF_INQ_DIMLEN(NCID,NC_DimID_Time,NT)      
        allocate(NCTIMES(1:NT))
        WASTE = NF_GET_VAR(NCID,NC_VarID_date,NCTIMES)
C Search through time snaps for matching start time
        do TIMEI=1,NT
          IF (TBEGIN.EQ.(NCTIMES(I)/100)) THEN
            exit
          ENDIF
        ENDDO
        deallocate(NCTIMES)
        SSNAP = 0
        SOPEN=1
      elseif(SOPEN.eq.2) then
C File has been closed
        return      
      endif
 
      ALLOCATE( NCOWI(1:NLON,1:NLAT,1))

C Determine Relative Time Snap
      TSNAP = ETIME/DT+I
      T = FLOOR(ETIME/DT)+1
      T_W = 1-(ETIME/DT-(T-1))

      IF (TSNAP.LT.NT) Then
        if (SSNAP.eq.0) then
          WASTE = NF_GET_VARA_DOUBLE(NCID,FX_ID,
     &    (/1,1,TSNAP/),(/NLON,NLAT,1/),NCOWI)
          CALL  INTERPOWIST(NCOWI,FXX1)
          WASTE = NF_GET_VARA_DOUBLE(NCID,FY_ID,
     &    (/1,1,TSNAP/),(/NLON,NLAT,1/),NCOWI)
          CALL  INTERPOWIST(NCOWI,FYY1)
          WASTE = NF_GET_VARA_DOUBLE(NCID,FX_ID,
     &    (/1,1,TSNAP+1/),(/NLON,NLAT,1/),NCOWI)       
          CALL  INTERPOWIST(NCOWI,FXX2)
          WASTE = NF_GET_VARA_DOUBLE(NCID,FY_ID,
     &    (/1,1,TSNAP+1/),(/NLON,NLAT,1/),NCOWI)       
          CALL  INTERPOWIST(NCOWI,FYY2)          
          SSNAP = TSNAP
        elseif (SSNAP.ne.TSNAP) then
          FXX1 = FXX2
          FYY1 = FYY2          
          WASTE = NF_GET_VARA_DOUBLE(NCID,FX_ID,
     &    (/1,1,TSNAP+1/),(/NLON,NLAT,1/),NCOWI)
          CALL  INTERPOWIST(NCOWI,FXX2)
          WASTE = NF_GET_VARA_DOUBLE(NCID,FY_ID,
     &    (/1,1,TSNAP+1/),(/NLON,NLAT,1/),NCOWI)
          CALL  INTERPOWIST(NCOWI,FYY2)
          SSNAP = TSNAP          
        endif
      else
        WASTE = NF_CLOSE(NCID)
        SOPEN=2
        RETURN
      endif      
      DEALLOCATE( NCOWI)      
      DO I = 1,IMXB-1
        DO J = 1,JMXB-1
            GFXX(I,J) = FXX1(I,J)*T_W + FXX2(I,J)*(1.-T_W)
            GFYY(I,J) = FYY1(I,J)*T_W + FYY2(I,J)*(1.-T_W)
        ENDDO
      ENDDO

      END SUBROUTINE  

C********************************************************************      
      SUBROUTINE NETWIND()
C This subroutine extracts windstress from the netcdf windstress file
C********************************************************************            

      INCLUDE 'netcdf.inc'
      include 'parm.for'      
      INTEGER :: NCID, WASTE
      INTEGER :: NC_DimID_Lat, NC_DimID_Lon, NC_DimID_Time
      INTEGER :: WX_ID,WY_ID,DLAT_ID,DLON_ID      
      INTEGER :: NLAT_ID,NLON_ID,SWLAT_ID,SWLON_ID
      INTEGER :: NC_VarID_date
      INTEGER :: TSTART_ID,TFINAL_ID,DT_ID
      INTEGER :: DT,NT, TSNAP
      INTEGER :: I,J,T,K,L

      DOUBLE PRECISION :: TSTART,TFINAL
      DOUBLE PRECISION, allocatable :: NCTIMES(:)
      DOUBLE PRECISION, allocatable :: NCOWI(:,:,:)      

      REAL :: T_W

      COMMON /FFTH/   ITIME, MHALT
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2

C Determine whether file is opened yet
      if(WOPEN.eq.0) then
C Open NetCDF data set
        WASTE = NF_OPEN(WNFILE,NF_NOWRITE,NCID)
C Determine dimension IDs
        WASTE = NF_INQ_DIMID(NCID,'gridx',NC_DimID_Lon)
        WASTE = NF_INQ_DIMID(NCID,'gridy',NC_DimID_Lat)
        WASTE = NF_INQ_DIMID(NCID,'time',NC_DimID_Time)      
C Determine variable IDs
        WASTE = NF_INQ_VARID(NCID,'wind_speed_x',WX_ID)
        WASTE = NF_INQ_VARID(NCID,'wind_speed_y',WY_ID)   
        WASTE = NF_INQ_VARID(NCID,'dlat',DLAT_ID)
        WASTE = NF_INQ_VARID(NCID,'dlon',DLON_ID)      
        WASTE = NF_INQ_VARID(NCID,'nlat',NLAT_ID)
        WASTE = NF_INQ_VARID(NCID,'nlon',NLON_ID)
        WASTE = NF_INQ_VARID(NCID,'SWlat',SWLAT_ID)
        WASTE = NF_INQ_VARID(NCID,'SWlon',SWLON_ID)      
        WASTE = NF_INQ_VARID(NCID,'TSTART',TSTART_ID)
        WASTE = NF_INQ_VARID(NCID,'TFINAL',TFINAL_ID)
        WASTE = NF_INQ_VARID(NCID,'DT',DT_ID)
        WASTE = NF_INQ_VARID(NCID,'date',NC_VarID_date)      
C Read the variables from the netCDF
        WASTE = NF_GET_VAR1(NCID,DLAT_ID,(/1/),DLAT)
        WASTE = NF_GET_VAR1(NCID,DLON_ID,(/1/),DLON)
        WASTE = NF_GET_VAR1_INT(NCID,NLAT_ID,(/1/),NLAT)
        WASTE = NF_GET_VAR1_INT(NCID,NLON_ID,(/1/),NLON)
        WASTE = NF_GET_VAR1(NCID,SWLAT_ID,(/1/),SWLAT)
        WASTE = NF_GET_VAR1(NCID,SWLON_ID,(/1/),SWLON)
        WASTE = NF_GET_VAR1(NCID,TSTART_ID,(/1/),TSTART)
        WASTE = NF_GET_VAR1(NCID,TFINAL_ID,(/1/),TFINAL)
        WASTE = NF_GET_VAR1_INT(NCID,DT_ID,(/1/),DT)
C Determine number of time snaps
        WASTE = NF_INQ_DIMLEN(NCID,NC_DimID_Time,NT)      
        allocate(NCTIMES(1:NT))
        WASTE = NF_GET_VAR(NCID,NC_VarID_date,NCTIMES)
C Search through time snaps for matching start time
        do TIMEI=1,NT
          IF (TBEGIN.EQ.(NCTIMES(I)/100)) THEN
            exit
          ENDIF
        ENDDO
        deallocate(NCTIMES)
        WSNAP = 0
        WOPEN=1
      elseif(WOPEN.eq.2) then
C File has been closed
        return      
      endif

      ALLOCATE( NCOWI(1:NLON,1:NLAT,1))

C Determine Relative Time Snap
      TSNAP = ETIME/DT+I
      T = FLOOR(ETIME/DT)+1
      T_W = 1-(ETIME/DT-(T-1))

      IF (TSNAP.LT.NT) Then
        if (WSNAP.eq.0) then
          WASTE = NF_GET_VARA_DOUBLE(NCID,WX_ID,
     &    (/1,1,TSNAP/),(/NLON,NLAT,1/),NCOWI)
          CALL  INTERPOWIST(NCOWI,WXX1)
          WASTE = NF_GET_VARA_DOUBLE(NCID,WY_ID,
     &    (/1,1,TSNAP/),(/NLON,NLAT,1/),NCOWI)
          CALL  INTERPOWIST(NCOWI,WYY1)
          WASTE = NF_GET_VARA_DOUBLE(NCID,WX_ID,
     &    (/1,1,TSNAP+1/),(/NLON,NLAT,1/),NCOWI)       
          CALL  INTERPOWIST(NCOWI,WXX2)
          WASTE = NF_GET_VARA_DOUBLE(NCID,WY_ID,
     &    (/1,1,TSNAP+1/),(/NLON,NLAT,1/),NCOWI)       
          CALL  INTERPOWIST(NCOWI,WYY2)          
          WSNAP = TSNAP
        elseif (WSNAP.ne.TSNAP) then
          WXX1 = WXX2
          WYY1 = WYY2          
          WASTE = NF_GET_VARA_DOUBLE(NCID,WX_ID,
     &    (/1,1,TSNAP+1/),(/NLON,NLAT,1/),NCOWI)
          CALL  INTERPOWIST(NCOWI,WXX2)
          WASTE = NF_GET_VARA_DOUBLE(NCID,WY_ID,
     &    (/1,1,TSNAP+1/),(/NLON,NLAT,1/),NCOWI)
          CALL  INTERPOWIST(NCOWI,WYY2)
          WSNAP = TSNAP          
        endif
      else
        WASTE = NF_CLOSE(NCID)
        WOPEN=2
        RETURN
      endif      
      DEALLOCATE( NCOWI)      
      DO I = 1,IMXB-1
        DO J = 1,JMXB-1
            GWXX(I,J) = WXX1(I,J)*T_W + WXX2(I,J)*(1.-T_W)
            GWYY(I,J) = WYY1(I,J)*T_W + WYY2(I,J)*(1.-T_W)
        ENDDO
      ENDDO

      END SUBROUTINE

C********************************************************************      
      SUBROUTINE NETWAVES()
C This subroutine extracts windstress from the netcdf windstress file
C********************************************************************            

      INCLUDE 'netcdf.inc'
      include 'parm.for'      
      INTEGER :: NCID, WASTE
      INTEGER :: NC_DimID_Lat, NC_DimID_Lon, NC_DimID_Time
      INTEGER :: RX_ID,RY_ID,DLAT_ID,DLON_ID      
      INTEGER :: NLAT_ID,NLON_ID,SWLAT_ID,SWLON_ID
      INTEGER :: NC_VarID_date
      INTEGER :: TSTART_ID,TFINAL_ID,DT_ID
      INTEGER :: DT,NT, TSNAP
      INTEGER :: I,J,T,K,L

      DOUBLE PRECISION :: TSTART,TFINAL
      DOUBLE PRECISION, allocatable :: NCTIMES(:)
      DOUBLE PRECISION, allocatable :: NCOWI(:,:,:)      

      REAL :: T_W

      COMMON /FFTH/   ITIME, MHALT
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2

C Determine whether file is opened yet
      if(ROPEN.eq.0) then
C Open NetCDF data set
        WASTE = NF_OPEN(WNFILE,NF_NOWRITE,NCID)
C Determine dimension IDs
        WASTE = NF_INQ_DIMID(NCID,'gridx',NC_DimID_Lon)
        WASTE = NF_INQ_DIMID(NCID,'gridy',NC_DimID_Lat)
        WASTE = NF_INQ_DIMID(NCID,'time',NC_DimID_Time)      
C Determine variable IDs
        WASTE = NF_INQ_VARID(NCID,'radiation_stress_x',RX_ID)
        WASTE = NF_INQ_VARID(NCID,'radiation_stress_y',RY_ID)   
        WASTE = NF_INQ_VARID(NCID,'dlat',DLAT_ID)
        WASTE = NF_INQ_VARID(NCID,'dlon',DLON_ID)      
        WASTE = NF_INQ_VARID(NCID,'nlat',NLAT_ID)
        WASTE = NF_INQ_VARID(NCID,'nlon',NLON_ID)
        WASTE = NF_INQ_VARID(NCID,'SWlat',SWLAT_ID)
        WASTE = NF_INQ_VARID(NCID,'SWlon',SWLON_ID)      
        WASTE = NF_INQ_VARID(NCID,'TSTART',TSTART_ID)
        WASTE = NF_INQ_VARID(NCID,'TFINAL',TFINAL_ID)
        WASTE = NF_INQ_VARID(NCID,'DT',DT_ID)
        WASTE = NF_INQ_VARID(NCID,'date',NC_VarID_date)      
C Read the variables from the netCDF
        WASTE = NF_GET_VAR1(NCID,DLAT_ID,(/1/),DLAT)
        WASTE = NF_GET_VAR1(NCID,DLON_ID,(/1/),DLON)
        WASTE = NF_GET_VAR1_INT(NCID,NLAT_ID,(/1/),NLAT)
        WASTE = NF_GET_VAR1_INT(NCID,NLON_ID,(/1/),NLON)
        WASTE = NF_GET_VAR1(NCID,SWLAT_ID,(/1/),SWLAT)
        WASTE = NF_GET_VAR1(NCID,SWLON_ID,(/1/),SWLON)
        WASTE = NF_GET_VAR1(NCID,TSTART_ID,(/1/),TSTART)
        WASTE = NF_GET_VAR1(NCID,TFINAL_ID,(/1/),TFINAL)
        WASTE = NF_GET_VAR1_INT(NCID,DT_ID,(/1/),DT)
C Determine number of time snaps
        WASTE = NF_INQ_DIMLEN(NCID,NC_DimID_Time,NT)      
        allocate(NCTIMES(1:NT))
        WASTE = NF_GET_VAR(NCID,NC_VarID_date,NCTIMES)
C Search through time snaps for matching start time
        do TIMEI=1,NT
          IF (TBEGIN.EQ.(NCTIMES(I)/100)) THEN
            exit
          ENDIF
        ENDDO
        deallocate(NCTIMES)
        RSNAP = 0
        ROPEN=1
      elseif(ROPEN.eq.2) then
C File has been closed
        return      
      endif

      ALLOCATE( NCOWI(1:NLON,1:NLAT,1))

C Determine Relative Time Snap
      TSNAP = ETIME/DT+I
      T = FLOOR(ETIME/DT)+1
      T_W = 1-(ETIME/DT-(T-1))

      IF (TSNAP.LT.NT) Then
        if (RSNAP.eq.0) then
          WASTE = NF_GET_VARA_DOUBLE(NCID,RX_ID,
     &    (/1,1,TSNAP/),(/NLON,NLAT,1/),NCOWI)
          CALL  INTERPOWIST(NCOWI,RXX1)
          WASTE = NF_GET_VARA_DOUBLE(NCID,RY_ID,
     &    (/1,1,TSNAP/),(/NLON,NLAT,1/),NCOWI)
          CALL  INTERPOWIST(NCOWI,RYY1)
          WASTE = NF_GET_VARA_DOUBLE(NCID,RX_ID,
     &    (/1,1,TSNAP+1/),(/NLON,NLAT,1/),NCOWI)       
          CALL  INTERPOWIST(NCOWI,RXX2)
          WASTE = NF_GET_VARA_DOUBLE(NCID,RY_ID,
     &    (/1,1,TSNAP+1/),(/NLON,NLAT,1/),NCOWI)       
          CALL  INTERPOWIST(NCOWI,RYY2)          
          RSNAP = TSNAP
        elseif (RSNAP.ne.TSNAP) then
          RXX1 = RXX2
          RYY1 = RYY2          
          WASTE = NF_GET_VARA_DOUBLE(NCID,RX_ID,
     &    (/1,1,TSNAP+1/),(/NLON,NLAT,1/),NCOWI)
          CALL  INTERPOWIST(NCOWI,RXX2)
          WASTE = NF_GET_VARA_DOUBLE(NCID,RY_ID,
     &    (/1,1,TSNAP+1/),(/NLON,NLAT,1/),NCOWI)
          CALL  INTERPOWIST(NCOWI,RYY2)
          RSNAP = TSNAP          
        endif
      else
        WASTE = NF_CLOSE(NCID)
        ROPEN=2
        RETURN
      endif      
      DEALLOCATE( NCOWI)      
      DO I = 1,IMXB-1
        DO J = 1,JMXB-1
            GRXX(I,J) = RXX1(I,J)*T_W + RXX2(I,J)*(1.-T_W)
            GRYY(I,J) = RYY1(I,J)*T_W + RYY2(I,J)*(1.-T_W)
        ENDDO
      ENDDO

      END SUBROUTINE   

C********************************************************************      
      SUBROUTINE INTERPOWIST(NCOWI,OWIST)
C This subroutine extracts windstress from the netcdf windstress file
C********************************************************************            

      include 'parm.for'      

      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      integer :: I, J, K, L
      REAL :: SW_W,SE_W,NE_W,NW_W
      REAL :: SW_F,SE_F,NE_F,NW_F      
      DOUBLE PRECISION :: LAT, LON
      DOUBLE PRECISION :: WLON,WLAT
      DOUBLE PRECISION, intent(inout) :: OWIST
      DOUBLE PRECISION, intent(in) :: NCOWI

      DO I = 1,IMXB-1
        DO J = 1,JMXB-1
          LAT = (YLT(I,J)+YLT(I+1,J)+YLT(I,J+1)+YLT(I+1,J+1))/4.
          LON = (YLG(I,J)+YLG(I+1,J)+YLG(I,J+1)+YLG(I+1,J+1))/4.
          IF ((LAT.LT.SWLAT).or.
     &      (LON.LT.SWLON).or.
     &      (LAT.GT.(SWLAT+DLAT*(NLAT-1))).or.
     &      (LON.GT.(SWLON+DLON*(NLON-1)))) then
            OWIST(I,J) = 0.0d0
          ELSE
            K = FLOOR((LON-SWLON)/DLON)+1
            L = FLOOR((LAT-SWLAT)/DLAT)+1
            WLON = LON-SWLON-DLON*(K-1)
            WLAT = LAT-SWLAT-DLAT*(L-1)
            SW_W = (WLAT*WLON)/DLAT/DLON
            SE_W = (WLAT*(DLON-WLON))/DLAT/DLON
            NE_W = ((DLAT-WLAT)*(DLON-WLON))/DLAT/DLON
            NW_W = ((DLAT-WLAT)*WLON)/DLAT/DLON
            SW_F = NCOWI(K,L,1)
            SE_F = NCOWI(K+1,L,1)
            NE_F = NCOWI(K+1,L+1,1)
            NW_F = NCOWI(K,L+1,1)
            OWIST = SW_F*SW_W + SE_F*SE_W + NE_F*NE_W + NW_F*NW_W
          ENDIF
        ENDDO
      ENDDO

      END SUBROUTINE      

C********************************************************************      
      SUBROUTINE INTERPOWIP(NCOWI,OWIX,OWIY)
C This subroutine extracts windstress from the netcdf windstress file
C********************************************************************            

      include 'parm.for'      
      COMMON /DUMB3/  IMXB,JMXB,IMXB1,JMXB1,IMXB2,JMXB2
      INTEGER :: I, J, K, L
      REAL :: SW_P,SE_P,NE_P,NW_P
      REAL :: A, B, C, D
      DOUBLE PRECISION :: LAT, LON
      DOUBLE PRECISION :: WLON,WLAT
      DOUBLE PRECISION, intent(inout) :: OWIX
      DOUBLE PRECISION, intent(inout) :: OWIY
      DOUBLE PRECISION, intent(in) :: NCOWI      

      pi = 2*ACOS(0.0)      

      DO I = 1,IMXB-1
        DO J = 1,JMXB-1
          LAT = (YLT(I,J)+YLT(I+1,J)+YLT(I,J+1)+YLT(I+1,J+1))/4.
          LON = (YLG(I,J)+YLG(I+1,J)+YLG(I,J+1)+YLG(I+1,J+1))/4.
          IF ((LAT.LT.SWLAT).or.
     &      (LON.LT.SWLON).or.
     &      (LAT.GT.(SWLAT+DLAT*(NLAT-1))).or.
     &      (LON.GT.(SWLON+DLON*(NLON-1)))) then
            OWIX(I,J) = 0.0d0
            OWIY(I,J) = 0.0d0
          ELSE
            K = FLOOR((LON-SWLON)/DLON)+1
            L = FLOOR((LAT-SWLAT)/DLAT)+1
            WLON = LON-SWLON-DLON*(K-1)
            WLAT = LAT-SWLAT-DLAT*(L-1)
            SW_P = NCOWI(K,L,1)
            SE_P = NCOWI(K+1,L,1)
            NE_P = NCOWI(K+1,L+1,1)
            NW_P = NCOWI(K,L+1,1)
            A = SW_P
            B = (SE_P-A)/DLON
            C = (NW_P-A)/DLAT
            D = (NE_P-A-B*DLON-C*DLAT)/DLAT/DLON
            OWIX(I,J) = (B+D*WLON)/111200.0
            OWIY(I,J) = (C+D*WLAT)/abs(111200.0*COS(LAT*pi/180.))
          ENDIF
        ENDDO
      ENDDO

      END SUBROUTINE
      
