        SUBROUTINE  LS_CLD1( lsfrpt, ipt, iret )
C************************************************************************
C* LS_CLD1                                                              *
C*                                                                      *
C* This subroutine decodes the section 1 cloud group 8N(h)C(L)C(M)C(H). *
C* The height of the lowest cloud level observed is determined from     *
C* the three levels.                                                    *
C*                                                                      *
C* LS_CLD1  ( LSFRPT, IPT, IRET )                                       *
C*                                                                      *
C* Input parameters:                                                    *
C*                                                                      *
C*      LSFRPT          CHAR*	        Report array                    *
C*      IPT             INTEGER         Points to 'N' in 8NCCC group    *
C*      HGTLCL          REAL            Height in hundredths of feet    *
C*                                      of the lowest cloud base        *
C*                                                                      *
C* Input and Output parameters:                                         *
C*      IPT             INTEGER         On input, points to 'N' in 8NCCC*
C*                                      group; on output, to the last C *
C*                                                                      *
C* Output parameters:                                                   *
C*      RIVALS(IRCFRL)  REAL            Low or mid cloud amount, WMO    *
C*                                      code table 2700                 *
C*      RIVALS(IRCTYL)  REAL            Low cloud genera, WMO table 0513*
C*      RIVALS(IRCLHL)  REAL            Low cloud height, 100s of feet  *
C*      RIVALS(IRCTYM)  REAL            Mid cloud genera, WMO table 0515*
C*      RIVALS(IRCLHM)  REAL            Mid cloud height, 100s of feet  *
C*      RIVALS(IRCTYH)  REAL            High cloud genera, WMO tbl 0509 *
C*      RIVALS(IRCLHH)  REAL            High cloud height, 100s of feet *
C*      RIVALS(IRNCLO)  REAL            Number of layers of cloud data  *
C*      RIVALS(IRVSSO)  REAL            Vertical significance           *
C*      RIVALS(IRCLAM)  REAL            Cloud amount                    *
C*      RIVALS(IRCLTP)  REAL            Cloud type                      *
C*      RIVALS(IRHOCB)  REAL            Height of base of cloud         *
C*	IRET            INTEGER         Return code                     *
C*				   	 0 = normal return 	        *
C*                                       1 = problems                   *
C*                                                                      *
C**                                                                     *
C* Log:							                *
C* R. Hollern/NCEP       4/96                                           *
C* R. Hollern/NCEP      12/96   Replaced ST_C2R with ST_INTG            *
C* R. Hollern/NCEP       1/98   Changed interface                       *
C************************************************************************
        INCLUDE          'GEMPRM.PRM'
        INCLUDE          'lscmn.cmn'
C*
        CHARACTER*(*)    lsfrpt
C*
        CHARACTER        fld1*1
C------------------------------------------------------------------------
        iret = 0
C
        IF ( lsfrpt(ipt:ipt+3) .ne. '////' ) THEN
C
C*          Specify vertical significance per WMO BUFR TABLE 0 08 002.
C
            xverts = 0.0
          ELSE
            ipt = ipt + 3
            RETURN
        END IF
C
C*      Get amount of the low clouds or middle clouds present.
C
        IF ( lsfrpt ( ipt:ipt ) .ne. '/' ) THEN
            fld1 = lsfrpt (ipt:ipt)
            CALL  ST_INTG ( fld1, ival, ier )
            IF ( ier .eq. 0 ) THEN
                xcfrl = FLOAT ( ival )
                rivals (ircfrl ) = xcfrl
            END IF
          ELSE
C
C*          Cloud amount is indiscernible.
C
            xcfrl = 15.
        END IF
C
        iflag = 0
C
C*      Get low-level cloud type.
C
        ipt = ipt + 1
        rivals ( irvsso ( 1 ) ) = xverts
C
        IF ( lsfrpt ( ipt:ipt ) .ne. '/' ) THEN
            fld1 = lsfrpt ( ipt:ipt )
            CALL  ST_INTG ( fld1, ival, ier )
            IF ( ier .eq. 0 ) THEN
                rivals ( irctyl ) = FLOAT ( ival )
                rivals ( ircltp ( 1 ) ) = rivals ( irctyl ) + 30.
                IF ( lsfrpt ( ipt:ipt ) .ne. '0' ) THEN
                    iflag = 1
                    rivals ( irclam ( 1 ) ) = xcfrl
                    IF ( hgtlcl .ne. RMISSD )  THEN
                        rivals ( irclhl ) = hgtlcl
                        rivals ( irhocb ( 1 ) ) = hgtlcx
                    END IF
                END IF
            END IF
          ELSE
C
C*          Clouds are invisible owing to darkness, fog, or etc.
C
            rivals ( ircltp ( 1 ) ) = 62.
        END IF
C
C*      Get middle-level cloud type.
C
        ipt = ipt + 1
        rivals ( irvsso ( 2 ) ) = xverts
C
        IF ( lsfrpt ( ipt:ipt ) .ne. '/' ) THEN
            fld1 = lsfrpt ( ipt:ipt )
            CALL  ST_INTG ( fld1, ival, ier )
            IF ( ier .eq. 0 ) THEN
                rivals ( irctym ) = FLOAT ( ival )
                rivals ( ircltp ( 2 ) ) = rivals ( irctym ) + 20.
                IF ( lsfrpt (ipt:ipt) .ne. '0' .and. iflag .eq. 0 ) THEN
                    iflag = 1
                    rivals ( irclam ( 2 ) ) = xcfrl
                    IF ( hgtlcl .ne. RMISSD )  THEN
                        rivals ( irclhm ) = hgtlcl
                        rivals ( irhocb ( 2 ) ) = hgtlcx
                    END IF
                END IF
            END IF
          ELSE
            rivals ( ircltp ( 2 ) ) = 61.
        END IF
C
C*      Get high-level cloud type.
C
        ipt = ipt + 1
        rivals ( irvsso ( 3 ) ) = xverts
C
        IF ( lsfrpt ( ipt:ipt ) .ne. '/' ) THEN
            fld1 = lsfrpt ( ipt:ipt )
            CALL  ST_INTG( fld1, ival, ier )
            IF ( ier .eq. 0 ) THEN
                rivals ( irctyh ) = FLOAT ( ival )
                rivals ( ircltp ( 3 ) ) = rivals ( irctyh ) + 10.
                IF ( lsfrpt (ipt:ipt) .ne. '0' .and. iflag .eq. 0 ) THEN
                    IF ( hgtlcl .ne. RMISSD )  THEN
                        rivals ( irclhh ) = hgtlcl
                        rivals ( irhocb ( 3 ) ) = hgtlcx
                    END IF
                END IF
            END IF
          ELSE
            rivals ( ircltp ( 3 ) ) = 60.
        END IF
C
C*      Store number of layers of cloud data.
C
        rivals ( irnclo ) = 3
C*
        RETURN
        END


c                              respect.f - revision 1.0
c*******************************************************************************
c
c     * * * *    history    * * * *
c
c   6/86 - nfs - added capability to read data in binary format by
c                entering the word "binary" or "binary" when asked for
c                the data format.  subroutine pseudo checks for this
c                in the variable format and reads accordingly.
c              - added check so that if ncomp .ne. 3, averaging will
c                not be done.
c   7/86 - nfs - modified so second title line defaults to station
c                name and component from first data file header line.
c              - added capability of windowing data
c   3/87 - nfs - revision 2
c              - changed all routines so that averaging in subroutine
c                averag is done using the absolute acceleration rather than
c                the pseudo absolute acceleration
c              - corrected test in main routine after question re
c                scaling by the average of psaa so that program did not
c                think there were multiple dampings when there weren't.
c   9/87 - nfs - revision 3
c              - modified bigp and spcplt so that multiple files can be
c                plotted on the same set of axes.  program now asks additional
c                questions.  see documentation for detail.
c   2/95 - nfs - Major overhaul and streamlining.- renamed from bigp to respect
c
c*******************************************************************************
c
c     * * * *    limitations    * * * *
c
c     1.  the number of points in the accelerogram must be <= 120000
c     2.  the number of periods must be <= 151
c     3.  the number of components must be = 1
c     4.  the number of dampings applied and/or plotted must be <=5
c     5.  the number of x,y coordinates for the target shape must be <=25
c

c*******************************************************************************
c
c     * * * *    Declarations   * * * *

      character*12 cname
      character*65 title1,title2
      integer      ncomp,npts,nptuse,ndamp,nper,ntypper
      real         period(151),damp(50),dt
      logical      flagt1,flagt2
      character*1  unit
      character*15 fmt
      integer      nhead
      real         anorm
      common /com1/ ncomp,cname,npts,nptuse,tws,twe,period,ndamp,
     &    damp,dt,nper,ntypper,flagt1,flagt2,title1,title2
      common /com2/ nhead,anorm,unit,fmt

      character*1  ysno
      character*256 filnam
      logical      exlog

c*******************************************************************************
c
c     * * * *    processing    * * * *

c --- Determine titles for the run to be used as plot labels

101   print *,'Do you want the main title of this run taken from the'
      print *,'first line of the input data file?  If yes, the title is'
      print *,'assumed to be in columns 16-80 of line 1 of the data file.'
      read (5,825) ysno
825   format (a1)
      write (6,825) ysno
      if (ysno.eq.'y' .or. ysno.eq.'Y') then
         flagt1 = .true.
      else
         flagt1 = .false.
         print *,'Main title for this run:'
         read (5,800) title1
         write (6,800) title1
      end if
800   format (a65)

      print *,'Do you want the 2nd title line taken from line 1 of the'
      print *,'file header (station name)?'
      read (5,825) ysno
      write (6,825) ysno
      if (ysno.eq.'y' .or. ysno.eq.'Y') then
         flagt2 = .true.
      else
         flagt2 = .false.
         print *,'Secondary title for this run:'
         read (5,800) title2
         write (6,800) title2
      end if

c --- Determine the components to be considered

      print *,'Enter name of the component:'
      read (5,810) cname
      write (6,810) cname
810   format (a12)

c --- Input info particular to spectacular (pseudo)

112   print *,'Input data file name:'
      read (5,820) filnam
      write (6,820) filnam
820   format (a256)
      inquire (file=filnam,exist=exlog)
      if (.not.exlog) then
         print *,'***** INPUT DATA FILE DOES NOT EXIST *****'
         stop '***** EXECUTION TERMINATED *****'
      end if

      print *,'Format for the input data.'
      print *,'Enter "binary" if data are in wcc binary format and "mclaren"'
      print *,'if data are in Jim McLaren''s binary format:'
      read (5,815) fmt
815   format (a15)
      if (fmt.ne.'binary         '.and.fmt.ne.'mclaren        ') then
         open (3,file=filnam)
      else
         open (3,file=filnam,form='unformatted')
      end if

      tws = 0.
      twe = 0.
      print *,'Data points to use:'
      print *,'   0 = all'
      print *,'   >1= the number of points to use'
      print *,'   -1= window the data'
      read (5,*) nptuse
      write (6,*) nptuse
      if (nptuse.lt.0) then
         print *, 'start and end times for the window:'
         read (5,*) tws,twe
         write (6,*) tws,twe
      end if

      print *,'Enter response spectral ouput file name:'
      read (5,820) filnam
      write (6,820) filnam
      open (4,file=filnam)
      close (4,status='delete')
      open (4,file=filnam)

114   print *,'what periods do you want to consider in spectacular?'
      print *,'     1 = unused'
      print *,'     2 = wcc-pasadena 106 standard periods'
      print *,'     3 = user inputted periods'
      print *,'     4 = user inputted frequencies'
      read (5,*) ntypper
      write (6,*) ntypper
      if (ntypper.lt.1 .or. ntypper.gt.4) stop 'Number of periods entered is invalid.'
      if (ntypper.eq.1) stop 991
      if (ntypper.eq.2) nper=106
      if (ntypper.eq.3) then
         print *,'How many periods?'
         read (5,*) nper
         write (6,*) nper
         print *,'Enter the periods desired:'
         read (5,*) (period(i),i=1,nper)
         write (6,*) (period(i),i=1,nper)
      end if
      if (ntypper.eq.4) then
         print *,'How many frequencies?'
         read (5,*) nper
         write (6,*) nper
         print *,'Enter the frequencies desired:'
         read (5,*) (period(i),i=1,nper)
         write (6,*) (period(i),i=1,nper)
         do i=1,nper
            period(i) = 1/period(i)
         enddo
         write (6,*) (period(i),i=1,nper)
      end if

      print *,'In what units are the data?'
      print *,'     1 = cm/sec/sec'
      print *,'     2 = g''s'
      read (5,*) nans
      write(6,*) nans
      if (nans.eq.2) then
         unit = 'g'
      else
         unit = 'c'
      end if

      print *,'Number of header cards to skip before the data begin:'
      print *,'It is assumed that the first card is a title and the'
      print *,'second contains the number of points and delta t.'
      print *,'These cards will be automatically read and need not be'
      print *,'skipped.'
      read (5,*) nhead
      write(6,*) nhead

      print *,'How many damping values are to be applied to the data?'
      read (5,*) ndamp
      write(6,*) ndamp
      print *,'Enter the damping values (max=5):'
      read (5,*) (damp(i),i=1,ndamp)
      write(6,*) (damp(i),i=1,ndamp)

      print *,'Enter the normalization factor (0. is converted to 1.)'
      read (5,*) anorm
      write(6,*) anorm

c --- start working

      icode = 0
      call pseudo (icode)
      if (icode.ne.0) then
         close (11)
         close (12)
         stop '***** ERROR IN SPECTACULAR (PSEUDO); EXECUTION TERMINATED *****'
      end if

      print *,'Do you want to process another set of data?'
      read (5,825) ysno
      write(6,825) ysno
      if (ysno.eq.'y' .or. ysno.eq.'Y') goto 101

      stop
      end


SUBROUTINE NEGDEP(NOPTIMAL,LDMOPT,QCHANUT,QCHANVT,ISTL_,SUB1,SVB1,NNEGFLG)

  ! ** SUBROUTINE NEGDEP CHECK EXTERNAL SOLUTION FOR NEGATIVE DEPTHS

  ! CHANGE RECORD

  ! CHANGE RECORD
  ! DATE MODIFIED     BY               DESCRIPTION
  !-------------------------------------------------------------------------------------------!
  !    2014-12       Paul M. Craig     Rewrote the NEGDEP function to be always called with
  !                                    a lot more information dumped to the EFDCLOG.OUT file,
  !                                    including the new ice sub-model information

  USE GLOBAL
  USE RESTART_MODULE
  USE EFDCOUT

  IMPLICIT NONE

  INTEGER, INTENT(IN)    :: NOPTIMAL,LDMOPT
  INTEGER, INTENT(INOUT) :: NNEGFLG

  REAL,INTENT(IN),DIMENSION(:) :: SUB1(0:LCM)
  REAL,INTENT(IN),DIMENSION(:) :: SVB1(0:LCM)

  INTEGER :: INEGFLG,ISTL_,L,NMD,LHOST,IHOST,JHOST,LCHNU,LCHNV,ICHNU,JCHNU,ICHNV,JCHNV,K,ND,LF,LL,LS,LN,LW,LE
  REAL    :: QCHANUT(NCHANM),QCHANVT(NCHANM),SRFCHAN,SRFHOST,SRFCHAN1,SRFHOST1,SURFTMP,DELTD2
  INTEGER, SAVE :: NEEOUT

  IF( NITER < 2 ) NEEOUT = 0
  INEGFLG = 0

  ! **  CHECK FOR NEGATIVE DEPTHS
  !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(ND,LF,LL,L)
  DO ND=1,NOPTIMAL
    LF=2+(ND-1)*LDMOPT
    LL=MIN(LF+LDMOPT-1,LA)
    DO L=LF,LL
      IF( HP(L) <=  0. )THEN
        INEGFLG = 1
        EXIT
      ENDIF
    ENDDO
  ENDDO
  !$OMP END PARALLEL DO

  IF( INEGFLG == 1 )THEN
    ! *** NEGATIVE DEPTHS FOUND, SO RE-SCAN THEN REPORT
    NNEGFLG = NNEGFLG+1

    OPEN(8,FILE=OUTDIR//'EFDCLOG.OUT',POSITION='APPEND')

    DO L=2,LA
      IF( HP(L) <=  0. )THEN
        LN=LNC(L)
        LS=LSC(L)
        LW=LWC(L)
        LE=LEC(L)
        WRITE(6,1111)TIMEDAY,N,L
        WRITE (6,6060)IL(L),JL(L),HP(L),H1P(L),H2P(L)
        WRITE (6,6061)IL(L),JL(L),HU(L),H1U(L)
        WRITE (6,6062)IL(L),JL(L),HU(LE),H1U(LE)
        WRITE (6,6063)IL(L),JL(L),HV(L),H1V(L)
        WRITE (6,6064)IL(L),JL(L),HV(LN),H1V(LN)
        WRITE (6,6065)IL(L),JL(L),QSUME(L),QSUM1E(L)
        WRITE (6,6066)IL(L),JL(L),SUB(L),SUB(LE),SVB(L),SVB(LN)
        IF( IEVAP > 0 )THEN
          WRITE (6,6067)IL(L),JL(L),RAINT(L),EVAPT(L)
        ENDIF
        IF( ISICE > 0 )THEN
          WRITE (6,6068)IL(L),JL(L),ICETHICK(L),ICETHICK1(L),TEM(L,KC),TATMT(L),SOLSWRT(L)
        ENDIF

        IF( ISDYNSTP == 0 )THEN
          DELT=DT
          DELTD2=0.5*DT
        ELSE
          DELT=DTDYN
          DELTD2=0.5*DTDYN
        ENDIF

        WRITE(8,1111)TIMEDAY,N,L,IL(L),JL(L)

        ! *** EE7.2 DIAGNOSTICS
        WRITE (8,'(2X,A14,5I14)')'L  CWESN',  L, LW, LE, LS, LN
        WRITE (8,'(A)')'DEPTHS'
        WRITE (8,'(2X,A14,5E14.6)')'HP CWESN',  HP(L), HP(LW), HP(LE), HP(LS), HP(LN)
        WRITE (8,'(2X,A14,5E14.6)')'H1P CWESN', H1P(L),H1P(LW),H1P(LE),H1P(LS),H1P(LN)
        WRITE (8,'(2X,A14,5E14.6)')'H2P CWESN', H2P(L),H2P(LW),H2P(LE),H2P(LS),H2P(LN)

        WRITE (8,'(A)')'WATER SURFACE ELEVATIONS'
        WRITE (8,'(2X,A14,5E14.6)')'WS CWESN',  BELV(L)+HP(L), BELV(LW)+HP(LW), BELV(LE)+HP(LE), BELV(LS)+HP(LS), BELV(LN)+HP(LN)
        WRITE (8,'(2X,A14,5E14.6)')'WS1 CWESN', BELV(L)+H1P(L),BELV(LW)+H1P(LW),BELV(LE)+H1P(LE),BELV(LS)+H1P(LS),BELV(LN)+H1P(LN)
        WRITE (8,'(2X,A14,5E14.6)')'WS2 CWESN', BELV(L)+H2P(L),BELV(LW)+H2P(LW),BELV(LE)+H2P(LE),BELV(LS)+H2P(LS),BELV(LN)+H2P(LN)

        WRITE (8,'(A)')'FACE DEPTHS'
        WRITE (8,'(2X,A14,4E14.6)')'HU/HV WESN',   HU(L),  HU(LE),  HV(L),  HV(LN)
        WRITE (8,'(2X,A14,4E14.6)')'H1U/H1V WESN', H1U(L), H1U(LE), H1V(L), H1V(LN)

        WRITE (8,'(A)')'MASKS'
        WRITE (8,'(2X,A14,4E14.6)')'SUB WESN',  SUB(L), SUB(LE), SVB(L), SVB(LN)
        WRITE (8,'(2X,A14,4E14.6)')'SUB1 WESN', SUB1(L),SUB1(LE),SVB1(L),SVB1(LN)
        WRITE (8,'(2X,A14,4E14.6)')'SUBO WESN', SUBO(L),SUBO(LE),SVBO(L),SVBO(LN)

        WRITE (8,'(A)')'DEPTH AVERAGE VELOCITIES'
        WRITE (8,'(2X,A14,4E14.6)')'U/V WESN',     UHDYE(L)/HU(L)/DYU(L),  UHDYE(LE)/HU(LE)/DYU(LE),  VHDXE(L)/HV(L)/DXV(L),  VHDXE(LN)/HV(LN)/DXV(LN)
        WRITE (8,'(2X,A14,4E14.6)')'U1/V1 WESN',   UHDY1E(L)/H1U(L)/DYU(L),UHDY1E(LE)/H1U(LE)/DYU(LE),VHDX1E(L)/H1V(L)/DXV(L),VHDX1E(LN)/H1V(LN)/DXV(LN)

        WRITE (8,'(A)')'BOTTOM SHEAR VELOCITIES'
        WRITE (8,'(2X,A14,4E14.6)')'UV/VU WESN',   UV(L), UV(LE), VU(L), VU(LN)
        WRITE (8,'(2X,A14,4E14.6)')'U1V/V1U WESN', U1V(L),U1V(LE),V1U(L),V1U(LN)

        WRITE (8,'(A)')'FLUX TERMS (W/E AND S/N)'
        WRITE (8,'(2X,A14,4E14.6)')'UHDYE/VHDXE',  UHDYE(L), UHDYE(LE), VHDXE(L), VHDXE(LN)
        WRITE (8,'(2X,A14,4E14.6)')'UHDY1E/VHDX1E',UHDY1E(L),UHDY1E(LE),VHDX1E(L),VHDX1E(LN)
        WRITE (8,'(A)')'MOMENTUM TERMS (W/E AND S/N)'
        WRITE (8,'(2X,A14,4E14.6)')'FUHDYE/FVHDXE',FUHDYE(L),FUHDYE(LE),FVHDXE(L),FVHDXE(LN)
        WRITE (8,'(A)')'SOURCE/SINK TERMS'
        WRITE (8,'(2X,A14,4E14.6)')'QSUME/QSUM1E',QSUME(L),QSUM1E(L)

        ! ***                       FUHDYE(L)=UHDYE(L)-DELTD2*SUB(L)*HRUO(L)*HU(L)*(P(L)-P(LW))+SUB(L)*DELT*DXIU(L)*(DXYU(L)*(TSX(L)-RITB1*TBX(L))+FCAXE(L)+FPGXE(L)-SNLT*FXE(L))
        ! ***                                       ***               WEST                            ******                 EAST
        WRITE (8,'(16X,A)')'     WEST          EAST'
        WRITE (8,'(2X,A14,4E14.6)')'X P GRADIENT',  SUBO(L)*DELTD2*HRUO(L)*H1U(L)*(P1(LW)-P1(L)),     SUBO(LE)*DELTD2*HRUO(LE)*H1U(LE)*(P1(L)-P1(LE))
        WRITE (8,'(2X,A14,4E14.6)')'X SHEARS TOT',  SUBO(L)*DELT*DXIU(L)*(DXYU(L)*(TSX(L)-RITB1*TBX(L))+FCAXE(L)+FPGXE(L)-SNLT*FXE(L)), SUBO(LE)*DELT*DXIU(LE)*(DXYU(LE)*(TSX(LE)-RITB1*TBX(LE))+FCAXE(LE)+FPGXE(LE)-SNLT*FXE(LE))
        WRITE (8,'(2X,A14,4E14.6)')'X SHEARS T/B',  SUBO(L)*DELT*DXIU(L)*(DXYU(L)*(TSX(L)-RITB1*TBX(L))), SUBO(LE)*DELT*DXIU(LE)*(DXYU(LE)*(TSX(LE)-RITB1*TBX(LE)))
        WRITE (8,'(2X,A14,4E14.6)')'X SHEARS FCAXE',SUBO(L)*DELT*DXIU(L)*FCAXE(L),                        SUBO(LE)*DELT*DXIU(L)*FCAXE(LE)
        WRITE (8,'(2X,A14,4E14.6)')'X SHEARS FPGXE',SUBO(L)*DELT*DXIU(L)*FPGXE(L),                        SUBO(LE)*DELT*DXIU(L)*FPGXE(LE)
        WRITE (8,'(2X,A14,4E14.6)')'X SHEARS FXE',  SUBO(L)*DELT*DXIU(L)*SNLT*FXE(L),                     SUBO(LE)*DELT*DXIU(L)*SNLT*FXE(LE)

        ! ***                       FVHDXE(L)=VHDXE(L)-DELTD2*SVB(L)*HRVO(L)*HV(L)*(P(L)-P(LS ))+SVB(L)*DELT*DYIV(L)*(DXYV(L)*(TSY(L)-RITB1*TBY(L))-FCAYE(L)+FPGYE(L)-SNLT*FYE(L))
        ! ***                                       ***               SOUTH                           ******                 NORTH
        WRITE (8,'(16X,A)')'     SOUTH        NORTH'
        WRITE (8,'(2X,A14,4E14.6)')'Y P GRADIENT',  SVBO(L)*DELTD2*HRVO(L)*HV(L)*(P1(L)-P1(LS )),         SVBO(LN)*DELTD2*HRVO(LN)*HV(LN)*(P1(LN)-P1(L))
        WRITE (8,'(2X,A14,4E14.6)')'Y SHEARS TOT',  SVBO(L)*DELT*DYIV(L)*(DXYV(L)*(TSY(L)-RITB1*TBY(L))-FCAYE(L)+FPGYE(L)-SNLT*FYE(L)), SVBO(LN)*DELT*DYIV(LN)*(DXYV(LN)*(TSY(LN)-RITB1*TBY(LN))-FCAYE(LN)+FPGYE(LN)-SNLT*FYE(LN))
        WRITE (8,'(2X,A14,4E14.6)')'Y SHEARS T/B',  SVBO(L)*DELT*DYIV(L)*(DXYV(L)*(TSY(L)-RITB1*TBY(L))), SVBO(LN)*DELT*DYIV(LN)*(DXYV(LN)*(TSY(LN)-RITB1*TBY(LN)))
        WRITE (8,'(2X,A14,4E14.6)')'Y SHEARS FCAYE',SVBO(L)*DELT*DYIV(L)*FCAYE(L),                        SVBO(LN)*DELT*DYIV(LN)*FCAYE(LN)
        WRITE (8,'(2X,A14,4E14.6)')'Y SHEARS FPGYE',SVBO(L)*DELT*DYIV(L)*FPGYE(L),                        SVBO(LN)*DELT*DYIV(LN)*FPGYE(LN)
        WRITE (8,'(2X,A14,4E14.6)')'Y SHEARS FYE',  SVBO(L)*DELT*DYIV(L)*SNLT*FYE(L),                     SVBO(LN)*DELT*DYIV(LN)*SNLT*FYE(LN)

        !RCX(L)=1./( 1.+DELT*FXVEGE(L) )
        !RCY(L)=1./( 1.+DELT*FYVEGE(L) )
        IF( ISVEG > 0 )THEN
          WRITE (8,'(/2X,A14,4E14.6)'),'FXVEGE X/Y',FXVEGE(L),FXVEGE(L),FYVEGE(L),FYVEGE(LN)
          WRITE (8,'( 2X,A14,4E14.6)'),'RCX/RCY', 1./( 1.+DELT*FXVEGE(L) ),1./( 1.+DELT*FYVEGE(L) ),1./( 1.+DELT*FXVEGE(LE) ),1./( 1.+DELT*FYVEGE(LN) )
        ENDIF

        IF( ISICE > 0 )THEN
          WRITE (8,'(A)')'ICE CONDITIONS'
          WRITE (8,'(2X,A14,6E14.6)')'TEM,TATM,SOLAR,ICETEMP,FRAZILICE,ICEVOL',TEM(L,KC),TATMT(L),SOLSWRT(L),ICETEMP(L),FRAZILICE(L,KC),ICEVOL(L)
          WRITE (8,'(A)')'ICE THICKNESS'
          WRITE (8,'(2X,A14,5E14.6)')'ICE  CWESN',  ICETHICK(L), ICETHICK(LE), ICETHICK(LW), ICETHICK(LS), ICETHICK(LN)
          WRITE (8,'(2X,A14,5E14.6)')'ICE1 CWESN',  ICETHICK1(L),ICETHICK1(LE),ICETHICK1(LW),ICETHICK1(LS),ICETHICK1(LN)
        ENDIF
      ENDIF
    ENDDO

    ! *** SAVE A SNAPSHOT FOR EE
    IF( ISPPH == 1 )THEN
      WRITE (6,6069)
      WRITE(8,*) 'NEGDEP: WRITING EE LINKAGE',TIMEDAY
      CALL EE_LINKAGE(-1)
      NEEOUT = NEEOUT + 1
      IF( NEEOUT > 10 )THEN
        STOP ' ABORTING RUN DUE TO TOO MANY NEGATIVE DEPTHS'
      ENDIF
    ENDIF

    DO L=2,LA
      IF( HU(L) < 0. .AND. SUBO(L) > 0.5 )THEN
        INEGFLG=2
        LN=LNC(L)
        WRITE(6,1112)
        WRITE (6,6060)IL(L),JL(L),HP(L),H1P(L),H2P(L)
        WRITE (6,6061)IL(L),JL(L),HU(L),H1U(L)
        WRITE (6,6062)IL(L),JL(L),HU(LEC(L)),H1U(LEC(L))
        WRITE (6,6063)IL(L),JL(L),HV(L),H1V(L)
        WRITE (6,6064)IL(L),JL(L),HV(LN),H1V(LN)
        WRITE (6,6065)IL(L),JL(L),QSUME(L),QSUM1E(L)
        WRITE(8,1112)
        WRITE (8,6060)IL(L),JL(L),HP(L),H1P(L),H2P(L)
        WRITE (8,6061)IL(L),JL(L),HU(L),H1U(L)
        WRITE (8,6062)IL(L),JL(L),HU(LEC(L)),H1U(LEC(L))
        WRITE (8,6063)IL(L),JL(L),HV(L),H1V(L)
        WRITE (8,6064)IL(L),JL(L),HV(LN),H1V(LN)
        WRITE (8,6065)IL(L),JL(L),QSUME(L),QSUM1E(L)
      ENDIF
    ENDDO
    DO L=2,LA
      IF( HV(L) < 0. .AND. SVBO(L) > 0.5 )THEN
        INEGFLG=3
        LN=LNC(L)
        WRITE(6,1113)
        WRITE (6,6060)IL(L),JL(L),HP(L),H1P(L),H2P(L)
        WRITE (6,6061)IL(L),JL(L),HU(L),H1U(L)
        WRITE (6,6062)IL(L),JL(L),HU(LEC(L)),H1U(LEC(L))
        WRITE (6,6063)IL(L),JL(L),HV(L),H1V(L)
        WRITE (6,6064)IL(L),JL(L),HV(LN),H1V(LN)
        WRITE (6,6065)IL(L),JL(L),QSUME(L),QSUM1E(L)
        WRITE(8,1113)
        WRITE (8,6060)IL(L),JL(L),HP(L),H1P(L),H2P(L)
        WRITE (8,6061)IL(L),JL(L),HU(L),H1U(L)
        WRITE (8,6062)IL(L),JL(L),HU(LEC(L)),H1U(LEC(L))
        WRITE (8,6063)IL(L),JL(L),HV(L),H1V(L)
        WRITE (8,6065)IL(L),JL(L),QSUME(L),QSUM1E(L)
        WRITE (8,6064)IL(L),JL(L),HV(LN),H1V(LN)
      ENDIF
    ENDDO

    IF( ISNEGH == 2 )THEN
      IF( MDCHH > 0 )THEN
        DO NMD=1,MDCHH
          WRITE(8,8000)
          LHOST=LMDCHH(NMD)
          IHOST=IL(LHOST)
          JHOST=JL(LHOST)
          LCHNU=LMDCHU(NMD)
          LCHNV=LMDCHV(NMD)

          ! *** X-DIRECTION CHANNEL
          IF( MDCHTYP(NMD) == 1 )THEN
            ICHNU=IL(LCHNU)
            JCHNU=JL(LCHNU)
            SRFCHAN=HP(LCHNU)+BELV(LCHNU)
            SRFHOST=HP(LHOST)+BELV(LHOST)
            SRFCHAN1=H1P(LCHNU)+BELV(LCHNU)
            SRFHOST1=H1P(LHOST)+BELV(LHOST)
            WRITE(8,8001)N,NMD,MDCHTYP(NMD),ICHNU,JCHNU,ISCDRY(LCHNU),SRFCHAN,HP(LCHNU),P1(LCHNU),H1P(LCHNU)
            WRITE(8,8002)IHOST,JHOST,ISCDRY(LHOST),SRFHOST,HP(LHOST),P1(LHOST),H1P(LHOST)
            WRITE(8,8003)QCHANU(NMD),QCHANUT(NMD),CCCCHU(NMD),CCCCHV(NMD)
          ENDIF
  !
  !         Y-DIRECTION CHANNEL
  !
          IF( MDCHTYP(NMD) == 2 )THEN
            ICHNV=IL(LCHNV)
            JCHNV=JL(LCHNV)
            SRFCHAN=HP(LCHNV)+BELV(LCHNV)
            SRFHOST=HP(LHOST)+BELV(LHOST)
            SRFCHAN1=H1P(LCHNV)+BELV(LCHNV)
            SRFHOST1=H1P(LHOST)+BELV(LHOST)
            WRITE(8,8001)N,NMD,MDCHTYP(NMD),ICHNV,JCHNV,ISCDRY(LCHNV),SRFCHAN,HP(LCHNV),SRFCHAN1,H1P(LCHNV)
            WRITE(8,8002)IHOST,JHOST,ISCDRY(LHOST),SRFHOST,HP(LHOST),SRFHOST1,H1P(LHOST)
            WRITE(8,8003)QCHANV(NMD),QCHANVT(NMD),CCCCHU(NMD),CCCCHV(NMD)
          ENDIF
          WRITE(8,8004)
        ENDDO
      ENDIF

      CALL RESTOUT(1)

      OPEN(1,FILE=OUTDIR//'EQCOEF.OUT',STATUS='UNKNOWN')
      CLOSE(1,STATUS='DELETE')
      OPEN(1,FILE=OUTDIR//'EQCOEF.OUT',POSITION='APPEND',STATUS='UNKNOWN')
      WRITE(1,1001)N,ISTL_
      DO L=2,LA
        SURFTMP=GI*P(L)
        WRITE(1,1001)IL(L),JL(L),CCS(L),CCW(L),CCC(L),CCE(L),CCN(L),FPTMP(L),SURFTMP
      ENDDO
      CLOSE(1)
      OPEN(1,FILE=OUTDIR//'EQTERM.OUT',STATUS='UNKNOWN')
      CLOSE(1,STATUS='DELETE')
      OPEN(1,FILE=OUTDIR//'EQTERM.OUT',POSITION='APPEND',STATUS='UNKNOWN')
      WRITE(1,1001)N,ISTL_
      DO L=2,LA
        WRITE(1,1001)IL(L),JL(L),SUB(L),SVB(L),HRUO(L),HRVO(L),HU(L),HV(L)
      ENDDO
      CLOSE(1)
      OPEN(1,FILE=OUTDIR//'CFLMAX.OUT')
      CLOSE(1,STATUS='DELETE')
      OPEN(1,FILE=OUTDIR//'CFLMAX.OUT')
      DO L=2,LA
        WRITE(1,1991)IL(L),JL(L),(CFLUUU(L,K),K=1,KC)
        WRITE(1,1992)(CFLVVV(L,K),K=1,KC)
        WRITE(1,1992)(CFLWWW(L,K),K=1,KC)
        WRITE(1,1992)(CFLCAC(L,K),K=1,KC)
      ENDDO
      CLOSE(1)
      CLOSE(8)
      STOP
    ENDIF   ! *** ISNEGH=2

    CLOSE(8)

  ELSE
    ! *** RESET NNEGFLG COUNTER
    NNEGFLG = 0
  ENDIF     ! *** INEGFLG=1

   1001 FORMAT(2I5,10(1X,E12.4))
   1002 FORMAT(3I4,10(1X,E9.2))
   1991 FORMAT(2I5,12F8.3)
   1992 FORMAT(10X,12F8.3)
   1111 FORMAT(' *************************************************************************************',/, &
               ' *************************************************************************************',/, &
               ' NEG DEPTH AT CELL CENTER (TIMEDAY, N, L)',F14.6,4I10)
   1112 FORMAT(' NEG DEPTH AT WEST FACE')
   1113 FORMAT(' NEG DEPTH AT SOUTH FACE')
   6060 FORMAT('  NEG DEPTH AT I,J =',2I4,'  HP,H1P,H2P   =',3(2X,E12.4))
   6061 FORMAT('  NEG DEPTH AT I,J =',2I4,'  HUW,H1UW     =',2(2X,E12.4))
   6062 FORMAT('  NEG DEPTH AT I,J =',2I4,'  HUE,H1UE     =',2(2X,E12.4))
   6063 FORMAT('  NEG DEPTH AT I,J =',2I4,'  HVS,H1VS     =',2(2X,E12.4))
   6064 FORMAT('  NEG DEPTH AT I,J =',2I4,'  HVN,H1VN     =',2(2X,E12.4))
   6065 FORMAT('  NEG DEPTH AT I,J =',2I4,'  QSUME,QSUM1E =',2(2X,E12.4))
   6067 FORMAT('  NEG DEPTH AT I,J =',2I4,'  RAIN,EVAP    =',2(2X,E12.4))
   6066 FORMAT('  NEG DEPTH AT I,J =',2I4,'  SUB,SVB      =',4F6.1)
   6068 FORMAT('  NEG DEPTH AT I,J =',2I4,'  ICETH,ICETH1,TEM,TATM,SOLAR =',2F8.3,2F8.2,F8.1)
   6069 FORMAT('  ************************************************************************************',/, &
               '  ***      MORE DETAILS CAN BE FOUND IN THE FILE:  EFDCLOG.OUT                     ***',/, &
               '  ***      THE LATEST MODEL RESULTS HAVE ALSO BEEN SAVED TO THE EE LINKAGE         ***',/, &
               '  ************************************************************************************')
   8001 FORMAT(I7,5I5,4E13.4)
   8002 FORMAT(17X,3I5,4E13.4)
   8003 FORMAT(32X,4E13.4)
   8000 FORMAT('    N    NMD  MTYP   I    J  IDRY      P           H           P1           H1')
   8004 FORMAT('                                     QCHANU       QCHANUT      CCCCHU       CCCCHV ')

   RETURN

END


module matterff
    use matterff_chemical_m, only: &
            chemical_t, &
            chemical_unsafe, &
            combine_by_atom_factors_unsafe, &
            combine_by_weight_factors_unsafe, &
            find, &
            natural_argon_gas, &
            natural_helium_gas, &
            natural_hydrogen_gas, &
            natural_krypton_gas, &
            natural_nitrogen_gas, &
            natural_oxygen_gas, &
            natural_water, &
            natural_xenon_gas
    use matterff_chemical_component_m, only: &
            chemical_component_t, combine_duplicates
    use matterff_chemical_symbol_m, only: &
            chemical_symbol_t, &
            argon_gas_symbol, &
            helium_gas_symbol, &
            hydrogen_gas_symbol, &
            krypton_gas_symbol, &
            nitrogen_gas_symbol, &
            oxygen_gas_symbol, &
            water_symbol, &
            xenon_gas_symbol
    use matterff_chemical_symbol_component_m, only: chemical_symbol_component_t
    use matterff_element_m, only: &
            element_t, &
            combine_by_atom_factors_unsafe, &
            combine_by_weight_factors_unsafe, &
            find, &
            from_atom_fractions_unsafe, &
            from_weight_fractions_unsafe, &
            natural_hydrogen, &
            natural_helium, &
            natural_lithium, &
            natural_beryllium, &
            natural_boron, &
            natural_carbon, &
            natural_nitrogen, &
            natural_oxygen, &
            natural_argon, &
            natural_krypton, &
            natural_xenon
    use matterff_element_component_m, only: &
            element_component_t, combine_duplicates
    use matterff_element_symbol_m, only: &
            element_symbol_t, &
            H, &
            He, &
            Li, &
            Be, &
            B, &
            C, &
            N, &
            O, &
            Ar, &
            Kr, &
            Xe
    use matterff_fallible_chemical_m, only: &
            fallible_chemical_t, &
            combine_by_atom_factors, &
            combine_by_weight_factors
    use matterff_fallible_chemical_component_m, only: &
            fallible_chemical_component_t
    use matterff_fallible_chemical_components_m, only: &
            fallible_chemical_components_t
    use matterff_fallible_chemical_symbol_m, only: fallible_chemical_symbol_t
    use matterff_fallbile_chemical_symbol_component_m, only: &
            fallible_chemical_symbol_component_t
    use matterff_fallible_element_m, only: &
            fallible_element_t, &
            combine_by_atom_factors, &
            combine_by_weight_factors, &
            from_atom_fractions, &
            from_weight_fractions
    use matterff_fallible_element_component_m, only: &
            fallible_element_component_t
    use matterff_fallible_element_components_m, only: &
            fallible_element_components_t
    use matterff_fallible_isotope_m, only: fallible_isotope_t
    use matterff_fallible_material_m, only: &
            fallible_material_t, &
            combine_by_atom_factors, &
            combine_by_weight_factors, &
            from_atom_fractions, &
            from_weight_fractions
    use matterff_fallible_material_component_m, only: &
            fallible_material_component_t
    use matterff_fallible_material_components_m, only: &
            fallible_material_components_t
    use matterff_fallible_matter_m, only: fallible_matter_t
    use matterff_isotope_m, only: &
            isotope_t, &
            find, &
            H_1, &
            H_2, &
            H_3, &
            He_3, &
            He_4, &
            Li_6, &
            Li_7, &
            Be_9, &
            B_10, &
            B_11, &
            C_12, &
            C_13, &
            N_14, &
            N_15, &
            O_16, &
            O_17, &
            O_18, &
            Ar_36, &
            Ar_38, &
            Ar_40, &
            Kr_78, &
            Kr_80, &
            Kr_82, &
            Kr_83, &
            Kr_84, &
            Kr_85, &
            Kr_86, &
            Xe_124, &
            Xe_126, &
            Xe_128, &
            Xe_129, &
            Xe_130, &
            Xe_131, &
            Xe_132, &
            Xe_134, &
            Xe_136
    use matterff_isotope_symbol_m, only: &
            isotope_symbol_t, &
            H_1_SYM, &
            H_2_SYM, &
            H_3_SYM, &
            He_3_SYM, &
            He_4_SYM, &
            Li_6_SYM, &
            Li_7_SYM, &
            Be_9_SYM, &
            B_10_SYM, &
            B_11_SYM, &
            C_12_SYM, &
            C_13_SYM, &
            N_14_SYM, &
            N_15_SYM, &
            O_16_SYM, &
            O_17_SYM, &
            O_18_SYM, &
            Ar_36_SYM, &
            Ar_38_SYM, &
            Ar_40_SYM, &
            Kr_78_SYM, &
            Kr_80_SYM, &
            Kr_82_SYM, &
            Kr_83_SYM, &
            Kr_84_SYM, &
            Kr_85_SYM, &
            Kr_86_SYM, &
            Xe_124_SYM, &
            Xe_126_SYM, &
            Xe_128_SYM, &
            Xe_129_SYM, &
            Xe_130_SYM, &
            Xe_131_SYM, &
            Xe_132_SYM, &
            Xe_134_SYM, &
            Xe_136_SYM
    use matterff_material_m, only: &
            material_t, &
            combine_by_atom_factors_unsafe, &
            combine_by_weight_factors_unsafe, &
            from_atom_fractions_unsafe, &
            from_weight_fractions_unsafe, &
            pure_natural_argon_gas, &
            pure_natural_helium_gas, &
            pure_natural_hydrogen_gas, &
            pure_natural_krypton_gas, &
            pure_natural_nitrogen_gas, &
            pure_natural_oxygen_gas, &
            pure_natural_water, &
            pure_natural_xenon_gas
    use matterff_material_component_m, only: &
            material_component_t, combine_duplicates
    use matterff_matter_m, only: matter_t, matter_unsafe
    use matterff_utilities_m, only: &
            INVALID_ARGUMENT, &
            MISMATCH, &
            NORMALIZED_FRACTIONS
end module