!***********************************************************************
!     Route PRMS gravity flow to MODFLOW cells
!***********************************************************************
      MODULE GSFPRMS2MF
      IMPLICIT NONE
!   Module Variables
      REAL, PARAMETER :: SZ_CHK = 0.00001
      DOUBLE PRECISION, PARAMETER :: PCT_CHK = 0.000005D0
      INTEGER, SAVE :: NTRAIL_CHK, Nlayp1
      ! Number of stream reaches in each stream segment
      INTEGER, SAVE, ALLOCATABLE :: Numreach_segment(:)
      REAL, SAVE, ALLOCATABLE :: Excess(:)
      DOUBLE PRECISION, SAVE :: Totalarea
      CHARACTER(LEN=14), SAVE :: MODNAME
!   Declared Variables
      DOUBLE PRECISION, SAVE :: Basin_reach_latflow, Net_sz2gw
!     INTEGER, SAVE, ALLOCATABLE :: Reach_id(:,:)
      REAL, SAVE, ALLOCATABLE :: Gw_rejected_grav(:)
!     DOUBLE PRECISION, SAVE, ALLOCATABLE :: Reach_latflow(:)
      REAL, SAVE, ALLOCATABLE :: Cell_drain_rate(:)
      DOUBLE PRECISION, SAVE, ALLOCATABLE :: Segment_pct_area(:)
!   Declared Parameters
!     INTEGER, SAVE, ALLOCATABLE :: Local_reachid(:)
!     INTEGER, SAVE, ALLOCATABLE :: Reach_segment(:)
      REAL, SAVE, ALLOCATABLE :: Gvr_hru_pct(:)
      END MODULE GSFPRMS2MF

!     ******************************************************************
!     Mapping module to convert PRMS & MODFLOW states for use by GSFLOW
!     NOTE: Assumes that the sm2gw_grav variable is in inches.
!           Produces cell_drain in MODFLOW units.
!     ******************************************************************
      INTEGER FUNCTION gsflow_prms2mf()
      USE PRMS_MODULE, ONLY: Process
      IMPLICIT NONE
! Functions
      INTEGER, EXTERNAL :: prms2mfdecl, prms2mfinit, prms2mfrun
!***********************************************************************
      gsflow_prms2mf = 0

      IF ( Process(:3)=='run' ) THEN
        gsflow_prms2mf = prms2mfrun()
      ELSEIF ( Process(:4)=='decl' ) THEN
        gsflow_prms2mf = prms2mfdecl()
      ELSEIF ( Process(:4)=='init' ) THEN
        gsflow_prms2mf = prms2mfinit()
      ENDIF

      END FUNCTION gsflow_prms2mf

!***********************************************************************
!     prms2mfdecl - set up parameters
!   Declared Parameters
!     gvr_hru_id, gvr_cell_id, gvr_hru_pct
!     hru_area, mxsziter
!***********************************************************************
      INTEGER FUNCTION prms2mfdecl()
      USE GSFPRMS2MF
      USE PRMS_MODULE, ONLY: Nhrucell, Ngwcell, Nhru, Nsegment, Model
      IMPLICIT NONE
      INTEGER, EXTERNAL :: declparam, declvar
      EXTERNAL read_error, print_module
! Save Variables
      CHARACTER(LEN=80), SAVE :: Version_gsflow_prms2mf
!***********************************************************************
      prms2mfdecl = 0

      Version_gsflow_prms2mf = 'gsflow_prms2mf.f90 2017-11-15 14:24:00Z'
      CALL print_module(Version_gsflow_prms2mf, 'GSFLOW PRMS to MODFLOW      ', 90)
      MODNAME = 'gsflow_prms2mf'

! Declared Variables
      IF ( declvar(MODNAME, 'net_sz2gw', 'one', 1, 'double', &
     &     'Net volumetric flow rate of gravity drainage from the'// &
     &     ' soil zone to the unsaturated and saturated zones', &
     &     'L3/T', Net_sz2gw)/=0 ) CALL read_error(3, 'net_sz2gw')

!     ALLOCATE (Reach_latflow(Nreach))
!     IF ( decl var(MODNAME, 'reach_latflow', 'nreach', Nreach, 'double', &
!    &     'Lateral flow (surface runoff and interflow) into each stream reach', &
!    &     'cfs', Reach_latflow)/=0 ) CALL read_error(3, 'reach_latflow')

!     ALLOCATE (Reach_id(Nreach, Nsegment))
!     IF ( decl var(MODNAME, 'reach_id', 'nsegment,nreach', &
!    &     Nsegment*Nreach, 'integer', &
!    &     'Mapping of reach id by segment id', &
!    &     'none', Reach_id)/=0 ) CALL read_error(3, 'reach_id')

      ALLOCATE (Cell_drain_rate(Ngwcell))
      IF ( declvar(MODNAME, 'cell_drain_rate', 'ngwcell', Ngwcell, 'real', &
     &     'Recharge rate for each cell', &
     &     'L/T', Cell_drain_rate)/=0 ) CALL read_error(3, 'Cell_drain_rate')

      IF ( declvar(MODNAME, 'basin_reach_latflow', 'one', 1, 'double', &
     &     'Lateral flow into all reaches in basin', &
     &     'cfs', Basin_reach_latflow)/=0 ) CALL read_error(3, 'basin_reach_latflow')

      ALLOCATE (Gw_rejected_grav(Nhrucell))
      IF ( declvar(MODNAME, 'gw_rejected_grav', 'nhrucell', Nhrucell, 'real', &
     &   'Recharge rejected by UZF for each gravity-flow reservoir', &
     &   'inches', Gw_rejected_grav)/=0 ) CALL read_error(3, 'gw_rejected_grav')

      !rsr, all reaches receive same precentage of flow to each segment
      ALLOCATE (Segment_pct_area(Nsegment))
!      IF ( declvar(MODNAME, 'segment_pct_area', 'nsegment', Nsegment, 'double', &
!     &     'Proportion of each segment that contributes flow to a stream reach', &
!     &     'decimal fraction', Segment_pct_area)/=0 ) CALL read_error(3, 'segment_pct_area')

      ! Allocate local arrays
      ALLOCATE ( Excess(Ngwcell) )

! Declared Parameters
        ! should be change code so that flow to each reach is computed, either based on a
        ! new parameter segment_reach_fraction or reach_carea or change cascade
        ! procedure to cascade flow to reaches instead of segments
!        ALLOCATE (Segment_reach_fraction(Nreach))
!        IF ( declparam(MODNAME, 'segment_reach_fraction', 'nreach', 'read', &
!      &      '0.0', '0.0', '1.0', &
!      &      'Proportion of each segment that contributes flow to a stream reach', &
!      &      'Proportion of each segment that contributes flow to a stream reach', &
!      &      'decimal fraction')/=0 ) CALL read_error(1, 'segment_reach_fraction')

!     ALLOCATE (Local_reachid(Nreach))
!     IF ( decl param(MODNAME, 'local_reachid', 'nreach', 'integer', &
!    &     '0', 'bounded', 'nreach', &
!    &     'Map of the global reach ids to reach ids of each segment', &
!    &     'Index of stream reach within a stream segment for each stream reach', &
!    &     'none')/=0 ) CALL read_error(1, 'local_reachid')

!     ALLOCATE (Reach_segment(Nreach))
!     IF ( decl param(MODNAME, 'reach_segment', 'nreach', 'integer', &
!    &     '0', 'bounded', 'nsegment', &
!    &     'Map of the stream reaches to the stream segments', &
!    &     'Index of stream segment associate with each stream reach', &
!    &     'none')/=0 ) CALL read_error(1, 'reach_segment')

      IF ( Nhru/=Nhrucell .OR. Model==99 ) THEN
        ALLOCATE ( Gvr_hru_pct(Nhrucell) )
        IF ( declparam('prms2mf', 'gvr_hru_pct', 'nhrucell', 'real', &
     &       '0.0', '0.0', '1.0', &
     &       'Proportion of the HRU associated with each GVR', &
     &       'Proportion of the HRU area associated with each gravity reservoir', &
     &       'decimal fraction').NE.0 ) RETURN
      ENDIF

      END FUNCTION prms2mfdecl

!***********************************************************************
!     prms2mfinit - Initialize PRMS2MF module - get parameter values
!***********************************************************************
      INTEGER FUNCTION prms2mfinit()
      USE GSFPRMS2MF
      USE GWFUZFMODULE, ONLY: NTRAIL, NWAV
      USE GWFSFRMODULE, ONLY: ISEG, NSS
      USE GWFLAKMODULE, ONLY: NLAKES
      USE GSFMODFLOW, ONLY: Gwc_row, Gwc_col, Have_lakes
      USE PRMS_MODULE, ONLY: Nhru, Nsegment, Nlake, Print_debug, &
     &    Nhrucell, Ngwcell, Gvr_cell_id, Logunt, Mxsziter
      USE PRMS_BASIN, ONLY: Active_hrus, Hru_route_order, Hru_type, &
     &    Basin_area_inv, Hru_area
      USE PRMS_SOILZONE, ONLY: Gvr_hru_id, Gvr_hru_pct_adjusted
      USE GLOBAL, ONLY: NLAY, NROW, NCOL
      USE GWFUZFMODULE, ONLY: IUZFBND
      IMPLICIT NONE
      INTEGER, EXTERNAL :: getparam
      EXTERNAL read_error
      INTRINSIC ABS, DBLE
! Local Variables
      INTEGER :: is, i, ii, ierr, ihru, icell, irow, icol
!     INTEGER :: iseg, max_seg, irch
!     INTEGER, ALLOCATABLE, DIMENSION(:) :: nseg_rch
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: hru_pct, newpct
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: temp_pct
!     DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: seg_area
      DOUBLE PRECISION :: pct
!***********************************************************************
      prms2mfinit = 0

      Nlayp1 = NLAY + 1

      ierr = 0
      IF ( NROW*NCOL/=Ngwcell ) THEN
        PRINT *, 'ERROR, dimension Ngwcell not equal to NROW*NCOL', Ngwcell, NROW, NCOL
        PRINT *, '       Check for use of correct Parameter File'
        ierr = 1
      ENDIF

      IF ( Have_lakes==1 ) THEN
        IF ( Nlake/=NLAKES ) THEN
          PRINT *, 'ERROR, PRMS dimension nlake must equal Lake Package NLAKES'
          PRINT *, '       nlake=', Nlake, ' NLAKES=', NLAKES
          ierr = 1
        ENDIF
      ENDIF

      IF ( Nsegment/=NSS ) THEN
        PRINT *, 'ERROR, nsegment must equal NSS', Nsegment, NSS
        ierr = 1
      ENDIF

      WRITE (Logunt, '(/, A,I4,/)') 'mxsziter =', Mxsziter
      WRITE (Logunt, '(A,D15.7)') 'Tolerance check for gvr_hru_pct:', PCT_CHK

      IF ( Nhru/=Nhrucell ) THEN
        IF ( getparam('prms2mf', 'gvr_hru_pct', Nhrucell, 'real', Gvr_hru_pct)/=0 ) CALL read_error(2, 'gvr_hru_pct')
      ENDIF

      ALLOCATE ( Numreach_segment(Nsegment) )
      DO i = 1, Nsegment
        Numreach_segment(i) = ISEG(4, i)
        IF ( Numreach_segment(i)<1 ) THEN
          PRINT *, 'ERROR, no reaches associated with segment:', i
          ierr = 1
        ELSE
          Segment_pct_area(i) = 1.0D0 / DBLE( Numreach_segment(i) )
        ENDIF
      ENDDO
      IF ( ierr==1 ) STOP

!     IF ( get param(MODNAME, 'reach_segment', Nreach, 'integer', Reach_segment)/=0 ) CALL read_error(2, 'reach_segment')

!  DANGER markstro - overriding the parameter Segment_pct_area to test
!                    precision issues
      !rsr, only need number of reaches per segment, divide inflow to
      !     segments by number of reaches
!     DO i = 1, Nreach
!       iseg = Reach_segment(i)
!       Segment_pct_area(i) = 1.0D0 / DBLE( Numreach_segment(iseg) )
!     ENDDO
      ! change so that this is actual contributing area for each reach, not constant value for each reach for each segment
!      IF ( get param(MODNAME, 'segment_reach_fraction', Nreach, 'real', Segment_reach_fraction)/=0 ) &
!     &     CALL read_error(2, 'segment_reach_fraction')
!      IF ( get param(MODNAME, 'segment_pct_area', Nreach, 'real', Segment_pct_area)/=0 ) CALL read_error(2, 'segment_pct_area')
!      IF ( get param(MODNAME, 'local_reachid', Nreach, 'integer', &
!     &     Local_reachid)/=0 ) CALL read_error(2, 'local_reachid')

!      ALLOCATE (nseg_rch(Nsegment), seg_area(Nsegment))
!      DO i = 1, Nsegment
!        nseg_rch(i) = 0
!        seg_area(i) = 0.0D0
!      ENDDO
!      k = 0
!      DO i = 1, Nsegment
!        DO j = 1, Numreach_segment(i)
!          k = k + 1
!          Reach_id(j, i) = k
!          Reach_latflow(k) = 0.0D0
!        ENDDO
!      ENDDO
!      IF ( k/=Nreach ) THEN
!        PRINT *, 'nreach (', nreach, ') should equal sum of number of reaches per segment (', k, ')'
!        RETURN
!      ENDIF
!      max_seg = 0
!      Reach_id = 0
!      DO i = 1, Nreach
!        iseg = Reach_segment(i)
!        IF ( iseg>max_seg ) max_seg = iseg
!        IF ( iseg>Nsegment ) PRINT *, 'Problem with segment number', i, Nsegment, iseg
!        irch = Local_reachid(i)
!        seg_area(iseg) = seg_area(iseg) + Segment_pct_area(i)
!        IF ( irch>Numreach_segment(iseg) ) PRINT *, &
!    &        'Problem with segment reach id', i, irch, Numreach_segment(iseg)
!        Reach_id(iseg, irch) = i
!        nseg_rch(iseg) = nseg_rch(iseg) + 1
!      ENDDO
!      IF ( max_seg/=Nsegment ) PRINT *, 'Problem with number of segments', Nsegment, max_seg

!      DO i = 1, Nsegment
!        IF ( nseg_rch(i)/=Numreach_segment(i) ) PRINT *, 'Problem with number of reaches in a segment', i,
!    &        nseg_rch(i), Numreach_segment(i)
!        IF ( ABS(seg_area(i)-1.0D0)>PCT_CHK ) WRITE (Logunt, *) &
!    &        'Possible issue with segment area percentages', i, seg_area(i)
!       ENDDO

! way to adjust segment_pct_area, rsr
!      WRITE ( 839, 9002 ) 'segment_pct_area 12', 'nreach', Nreach
!      DO i = 1, Nreach
!        iseg = Reach_segment(i)
!         Segment_pct_area(i) = Segment_pct_area(i) + &
!    &            Segment_pct_area(i)*(1.D0-seg_area(iseg))/seg_area(iseg)
!        WRITE (839,'(f15.13)') Segment_pct_area(i)
!      ENDDO
!      seg_area = 0.0
!      DO i = 1, Nreach
!        iseg = Reach_segment(i)
!        seg_area(iseg) = seg_area(iseg) + Segment_pct_area(i)
!      ENDDO
!      WRITE (839,'(f15.13)') seg_area
!      STOP

        Cell_drain_rate = 0.0 ! dimension ngwcell

      ierr = 0
      IF ( Nhru/=Nhrucell ) THEN
        ALLOCATE ( hru_pct(Nhru), newpct(Nhru), temp_pct(Nhrucell) )
        hru_pct = 0.0D0
        newpct = 0.0D0
      ENDIF
      DO i = 1, Nhrucell
        ihru = Gvr_hru_id(i)
        IF ( Nhru/=Nhrucell ) THEN
          temp_pct(i) = DBLE( Gvr_hru_pct(i) )
          is = Gvr_hru_id(i)
          hru_pct(is) = hru_pct(is) + temp_pct(i)
        ENDIF
        icell = Gvr_cell_id(i)
!        IF ( icell==0 ) CYCLE ! don't need as icell must be > 0
        irow = Gwc_row(icell)
        icol = Gwc_col(icell)
        IF ( Print_debug>-1 ) THEN
          IF ( Hru_type(ihru)==0 ) THEN
            IF ( IUZFBND(icol, irow)/=0 ) &
     &           PRINT *, 'WARNING, HRU inactive & UZF cell active, irow:', irow, 'icell:', icell, ' HRU:', ihru
          ENDIF
          IF ( IUZFBND(icol, irow)==0 ) THEN
            IF ( Hru_type(ihru)/=0 ) &
     &           PRINT *, 'WARNING, UZF cell inactive, irow:', irow, ' icell:', icell, ' HRU is active:', ihru
          ENDIF
        ENDIF
      ENDDO
      IF ( ierr==1 ) STOP

      IF ( Nhru/=Nhrucell ) THEN
! way to adjust gvr_hru_pct, rsr
!        WRITE ( 840, 9002 ) 'gvr_hru_pct 12', 'nhrucell', Nhrucell
        DO i = 1, Nhrucell
          is = Gvr_hru_id(i)
          temp_pct(i) = temp_pct(i) + temp_pct(i)*(1.0D0-hru_pct(is))/hru_pct(is)
          Gvr_hru_pct_adjusted(i) = temp_pct(i)
          newpct(is) = newpct(is) + temp_pct(i)
!        WRITE ( 840,'(F15.13)' ) temp_pct(i)
        ENDDO
      ELSE
        Gvr_hru_pct_adjusted = 1.0D0
      ENDIF
!      STOP

      Totalarea = 0.0D0
      DO ii = 1, Active_hrus
        i = Hru_route_order(ii)
        IF ( Nhru/=Nhrucell ) THEN
          pct = newpct(i)
          IF ( ABS(pct-1.0D0)>PCT_CHK ) PRINT *, 'Possible issue with GVR to HRU percentage, HRU:', i, pct
          IF ( pct==0.0D0 ) THEN                                                                                ! mm begin
            IF ( Print_debug>-1 ) PRINT *, 'WARNING, active HRU is not mapped to any cell', i, pct
          ELSEIF ( pct<0.99D0 ) THEN                                                                                ! mm end
            ierr = 1
            PRINT *, 'ERROR, portion of HRU not included in mapping to cells', i, pct
            WRITE ( Logunt, * ) 'ERROR, Portion of HRU not included in mapping to cells', i, pct
          ELSEIF ( pct>1.00001D0 ) THEN
            IF ( pct>1.0001D0 ) THEN
              ierr = 1
              PRINT *, 'ERROR, extra portion of HRU included in mapping to cells', i, pct
              WRITE ( Logunt, * ) 'ERROR, extra portion of HRU included in mapping to cells', i, pct
            ENDIF
          ELSEIF ( pct<0.0D0 ) THEN
            PRINT *, 'ERROR, HRU to cell mapping is < 0.0', i, pct
            ierr = 1
          ELSEIF ( pct<PCT_CHK ) THEN
            PRINT *, 'WARNING, active HRU is not mapped to any cell', i, pct
          ENDIF
          Totalarea = Totalarea + pct*DBLE( Hru_area(i) )
        ELSE
          Totalarea = Totalarea + DBLE( Hru_area(i) ) ! gvr_hru_pct = 1.0
        ENDIF
        IF ( Hru_type(i)==2 ) THEN
          ! Lake package active if Have_lakes=1
          IF ( Have_lakes==0 ) THEN
            WRITE (*, 9001) i
            ierr = 1
! must separate condition as lake_hru_id not allocated if have_lakes=0
          ENDIF
        ENDIF
      ENDDO
      IF ( ierr==1 ) STOP

      Totalarea = Totalarea*Basin_area_inv
      WRITE ( Logunt, 9003 ) (Totalarea-1.0D0)*100.0D0
      IF ( Print_debug>-1 ) PRINT 9003, (Totalarea-1.0D0)*100.0D0

      IF ( Nhru/=Nhrucell ) DEALLOCATE ( hru_pct, newpct, temp_pct )
      !DEALLOCATE ( nseg_rch, seg_area )

      Basin_reach_latflow = 0.0D0
      Net_sz2gw = 0.0D0
      Excess = 0.0 ! dimension ngwcell
      Gw_rejected_grav = 0.0 ! dimension nhrucell
      NTRAIL_CHK = NWAV - 3*NTRAIL + 1

      IF ( Nhru/=Nhrucell ) DEALLOCATE ( Gvr_hru_pct )

 9001 FORMAT ('ERROR, HRU:', I7, ' is specified as a lake (hru_type=2) and lake_hru_id is specified as 0', /, &
     &        'The associated MODFLOW lake must be specified as the value of lake_hru_id for this HRU')
! 9002 FORMAT ('####', /, A, /, '1', /, A, /, I10)
 9003 FORMAT (/, 'Percent difference between GVR mapping and active model domain:', D15.7)

      END FUNCTION prms2mfinit

!***********************************************************************
!     prms2mfrun - Maps the PRMS results to MODFLOW cells
! NOTE:  This module assumes that the Sm2gw_grav variable is in inches.
!        It produces cell_drain in MODFLOW units.
!***********************************************************************
      INTEGER FUNCTION prms2mfrun()
      USE GSFPRMS2MF
      USE GSFMODFLOW, ONLY: Gvr2cell_conv, Acre_inches_to_mfl3, &
     &    Inch_to_mfl_t, Gwc_row, Gwc_col, Have_lakes, Mft_to_days
      USE GLOBAL, ONLY: IBOUND
!     USE GLOBAL, ONLY: IOUT
      USE GWFUZFMODULE, ONLY: IUZFBND, NWAVST, PETRATE, IGSFLOW, FINF
      USE GWFLAKMODULE, ONLY: RNF, EVAPLK, PRCPLK, NLAKES
      USE PRMS_MODULE, ONLY: Nhrucell, Gvr_cell_id
      USE PRMS_BASIN, ONLY: Active_hrus, Hru_route_order, Hru_type, Hru_area, Lake_area, Lake_hru_id, NEARZERO
      USE PRMS_CLIMATEVARS, ONLY: Hru_ppt
      USE PRMS_FLOWVARS, ONLY: Hru_actet
      USE PRMS_SRUNOFF, ONLY: Hortonian_lakes
      USE PRMS_SOILZONE, ONLY: Sm2gw_grav, Lakein_sz, Hrucheck, Gvr_hru_id, Unused_potet, Gvr_hru_pct_adjusted
      IMPLICIT NONE
! FUNCTIONS AND SUBROUTINES
      INTEGER, EXTERNAL :: toStream
      EXTERNAL Bin_percolation
! Local Variables
      INTEGER :: irow, icol, ik, jk, ii, ilake
      INTEGER :: j, icell, ihru, is_draining
!***********************************************************************
      prms2mfrun = 0

!-----------------------------------------------------------------------
! Add runoff to stream reaches
!-----------------------------------------------------------------------
      IF ( toStream()/=0 ) RETURN

!-----------------------------------------------------------------------
! Add runoff and precip to lakes
! Pass in hru_actet for the lake
!-----------------------------------------------------------------------
      IF ( Have_lakes==1 ) THEN
        RNF = 0.0
        PRCPLK = 0.0
        EVAPLK = 0.0
        DO ii = 1, Active_hrus
          j = Hru_route_order(ii)
          IF ( Hru_type(j)==2 ) THEN
            ilake = Lake_hru_id(j)
            RNF(ilake) = RNF(ilake) + (Lakein_sz(j)+Hortonian_lakes(j)) &
     &                   *Hru_area(j)*Acre_inches_to_mfl3*Mft_to_days   !RGN 7/15/2015 added *Mft_to_days
            PRCPLK(ilake) = PRCPLK(ilake) + Hru_ppt(j)*Inch_to_mfl_t*Hru_area(j)
            EVAPLK(ilake) = EVAPLK(ilake) + Hru_actet(j)*Inch_to_mfl_t*Hru_area(j)
          ENDIF
        ENDDO
        DO ilake = 1, NLAKES
          PRCPLK(ilake) = PRCPLK(ilake)/Lake_area(ilake)
          EVAPLK(ilake) = EVAPLK(ilake)/Lake_area(ilake)
        ENDDO
      ENDIF

!-----------------------------------------------------------------------
      PETRATE = 0.0 ! should just be active cells
      Cell_drain_rate = 0.0 ! should just be active cells
      Gw_rejected_grav = Sm2gw_grav ! assume all is rejected to start with
      is_draining = 0

      DO j = 1, Nhrucell
        ihru = Gvr_hru_id(j)
        IF ( Hrucheck(ihru)==0 ) CYCLE ! make sure to skip lake and inactive HRUs
        icell = Gvr_cell_id(j)
!        IF ( icell==0 ) CYCLE ! don't need as icell must be > 0
        irow = Gwc_row(icell)
        icol = Gwc_col(icell)

        IF ( IUZFBND(icol, irow).LE.0 ) CYCLE                                                                               ! mm
        jk = 0
        ik = 1
        DO WHILE ( jk==0 .AND. ik<Nlayp1 )
          IF ( IBOUND(icol, irow, ik)>0 ) jk = 1
          ik = ik + 1
        ENDDO
        IF ( jk==0 ) CYCLE

!-----------------------------------------------------------------------
! If UZF cell is inactive OR if too many waves then dump water back into
! the soilzone
!-----------------------------------------------------------------------
        IF ( Sm2gw_grav(j)>0.0 ) THEN
          IF ( NWAVST(icol, irow)<NTRAIL_CHK ) THEN
!-----------------------------------------------------------------------
! Convert drainage from inches to MF Length/Time
!-----------------------------------------------------------------------
            Cell_drain_rate(icell) = Cell_drain_rate(icell) + Sm2gw_grav(j)*Gvr2cell_conv(j)
            Gw_rejected_grav(j) = 0.0
            is_draining = 1
          ENDIF
        ENDIF
!-----------------------------------------------------------------------
! Get the remaining potet from the HRU and put it into the cell
! Unused_potet() is in inches
!-----------------------------------------------------------------------
        IF ( Unused_potet(ihru)>NEARZERO ) THEN
          PETRATE(icol, irow) = PETRATE(icol, irow) + Unused_potet(ihru)*Gvr2cell_conv(j)
          Unused_potet(ihru) = Unused_potet(ihru) - Unused_potet(ihru)*Gvr_hru_pct_adjusted(j)
          IF ( Unused_potet(ihru)<0.0 ) Unused_potet(ihru) = 0.0
        ENDIF
      ENDDO

!-----------------------------------------------------------------------
! Bin precolation in cell_drain_rate
!-----------------------------------------------------------------------
! Set flag for UZF when PRMS sets FINF
      IGSFLOW = 1
      Net_sz2gw = 0.0D0
      Excess = 0.0
      FINF = 0.0
      IF ( is_draining==1 ) CALL Bin_percolation()

      END FUNCTION prms2mfrun

!***********************************************************************
!***********************************************************************
      INTEGER FUNCTION toStream()
      USE GSFPRMS2MF, ONLY: Numreach_segment, Segment_pct_area, Basin_reach_latflow
!     USE GSFPRMS2MF, ONLY: Reach_latflow, Reach_id
      USE GSFMODFLOW, ONLY: Sfr_conv
      USE GWFSFRMODULE, ONLY: STRM
      USE PRMS_MODULE, ONLY: Nsegment
      USE PRMS_SRUNOFF, ONLY: Strm_seg_in
      IMPLICIT NONE
      INTRINSIC SNGL
! Local Variables
      INTEGER :: j, k, iseg
!     INTEGER :: num_rch
      DOUBLE PRECISION :: latflow
!***********************************************************************
      toStream = 1

      Basin_reach_latflow = 0.0D0
      k = 0
      DO iseg = 1, Nsegment
        latflow = Strm_seg_in(iseg)*Segment_pct_area(iseg)
        DO j = 1, Numreach_segment(iseg)
!         k = Reach_id(j, iseg)
          k = k + 1
!-----------------------------------------------------------------------
! Convert inches over the HRU to CFS
!-----------------------------------------------------------------------
!         if (k<1 ) print *, iseg, j, reach_id(iseg,j)
!         print *, iseg, j, reach_id(iseg,j)
!         Reach_latflow(k) = Strm_seg_in(iseg)*Segment_pct_area(iseg)
!         Reach_latflow(k) = latflow
!-----------------------------------------------------------------------
! latflow is in cfs
! convert the gain to the SFR reach to correct units
!-----------------------------------------------------------------------
          STRM(12, k) = SNGL( latflow*Sfr_conv )
!         Basin_reach_latflow = Basin_reach_latflow + Reach_latflow(k)
          Basin_reach_latflow = Basin_reach_latflow + latflow
        ENDDO
      ENDDO

      toStream = 0

      END FUNCTION toStream

!***********************************************************************
! Bin percolation to reduce waves
!***********************************************************************
      SUBROUTINE Bin_percolation()
      USE GSFPRMS2MF, ONLY: Excess, Cell_drain_rate, Net_sz2gw
      USE GSFMODFLOW, ONLY: Cellarea, Gwc_row, Gwc_col !, Mft_to_days
      USE GWFUZFMODULE, ONLY: FINF, VKS, FBINS, IUZFBND, NUZTOP, SURFDEP
      USE GLOBAL, ONLY: HNEW, BOTM
      USE PRMS_MODULE, ONLY: Ngwcell
      IMPLICIT NONE
      INTRINSIC ABS
! Local Variables
      INTEGER :: icell, irow, icol, ij1, ij2, land, ij2m1
      REAL :: finfvks, finfprms, finf_temp, celtop
!***********************************************************************
!-----------------------------------------------------------------------
! loop on cells
!-----------------------------------------------------------------------
      DO icell = 1, Ngwcell
        IF ( Cell_drain_rate(icell)>0.0 ) THEN
          irow = Gwc_row(icell)
          icol = Gwc_col(icell)
          land = ABS(IUZFBND(icol, irow))
          IF ( NUZTOP==1 ) THEN
            celtop = BOTM(icol, irow, 0) - 0.5 * SURFDEP
          ELSE
            celtop = BOTM(icol, irow, land-1) - 0.5 * SURFDEP
          END IF
!-----------------------------------------------------------------------
! VKS in L/T, FINF in L/T
!-----------------------------------------------------------------------
          finfvks = VKS(icol, irow)
          finfprms = Cell_drain_rate(icell)
          IF ( finfprms>finfvks ) THEN
! reject part, as infiltration exceeds VKS, don't bin
            finf_temp = finfvks
! bin when water table is below celtop
          ELSE IF ( HNEW( icol, irow, land )<celtop ) THEN
!-----------------------------------------------------------------------
! can accept all infiltration, bin to avoid too many waves.
!-----------------------------------------------------------------------
            finf_temp = finfprms
            IF ( finf_temp<FBINS(1) ) THEN
              finf_temp = 0.0       ! reject small values
            ELSE
              IF ( finf_temp<FBINS(25) ) THEN
                ij1 = 25
                ij2 = 1
              ELSE
                ij1 = 51
                ij2 = 25
              ENDIF
              ij2m1 = ij2 - 1
              DO WHILE ( ij1>ij2m1 )
                IF ( finf_temp>=FBINS(ij1) ) THEN
                  finf_temp = FBINS(ij1)  ! set to bin value
                  EXIT
                ENDIF
                ij1 = ij1 - 1
              ENDDO
            ENDIF
          ELSE
            finf_temp = finfprms
          ENDIF
!-----------------------------------------------------------------------
! Put excess >VKS + bin difference in Excess array
!-----------------------------------------------------------------------
          Excess(icell) = (finfprms - finf_temp)
          FINF(icol, irow) = finf_temp
          Net_sz2gw = Net_sz2gw + finf_temp*Cellarea(icell)
        ENDIF
      ENDDO

      END SUBROUTINE Bin_percolation


C$Procedure      SCTIKS ( Convert spacecraft clock string to ticks. )

      SUBROUTINE SCTIKS ( SC, CLKSTR, TICKS )

C$ Abstract
C
C     Convert a spacecraft clock format string to number of "ticks".
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     SCLK
C
C$ Keywords
C
C     CONVERSION
C     TIME
C
C$ Declarations
C
      INTEGER               SC
      CHARACTER*(*)         CLKSTR
      DOUBLE PRECISION      TICKS

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     SC         I   NAIF spacecraft identification code.
C     CLKSTR     I   Character representation of a spacecraft clock.
C     TICKS      O   Number of ticks represented by the clock string.
C
C$ Detailed_Input
C
C     SC         is the NAIF ID number for the spacecraft whose clock
C                string is being converted.
C
C     CLKSTR     is a character string representing a spacecraft clock
C                time, WITHOUT PARTITION NUMBER.
C
C                Using Galileo as an example, the full format is
C
C                               wwwwwwww:xx:y:z
C
C                where z is a mod-8 counter (values 0-7) which
C                increments approximately once every 8 1/3 ms., y is a
C                mod-10 counter (values 0-9) which increments once
C                every time z turns over, i.e., approximately once every
C                66 2/3 ms., xx is a mod-91 (values 0-90) counter
C                which increments once every time y turns over, i.e.,
C                once every 2/3 seconds. wwwwwwww is the Real-Time Image
C                Count (RIM), which increments once every time xx turns
C                over, i.e., once every 60 2/3 seconds. The roll-over
C                expression for the RIM is 16777215, which corresponds
C                to approximately 32 years.
C
C                wwwwwwww, xx, y, and z are referred to interchangeably
C                as the fields or components of the spacecraft clock.
C                SCLK components may be separated by any of the
C                following characters: ' '  '.'  ':'  ','  '-'
C                Any number of spaces may separate the components and
C                the delimiters. The presence of the RIM component
C                is required. Successive components may be omitted, and
C                in such cases are assumed to represent zero values.
C
C                Values for the individual components may exceed the
C                maximum expected values. For instance, '0:0:0:9' is
C                an acceptable Galileo clock string, and will convert
C                to the same number of ticks as '0:0:1:1'.
C
C                Consecutive delimiters containing no intervening digits
C                are treated as if they delimit zero components.
C
C                Trailing zeros should always be included to match the
C                length of the counter.  For example, a Galileo clock
C                count of '25684.90' should not be represented as
C                '25684.9'.
C
C                Some spacecraft clock components have offset, or
C                starting, values different from zero.  For example,
C                with an offset value of 1, a mod 20 counter would
C                cycle from 1 to 20 instead of from 0 to 19.
C
C                See the SCLK required reading for a detailed
C                description of the Voyager and Mars Observer clock
C                formats.
C
C
C$ Detailed_Output
C
C     TICKS      is the number of ticks represented by the spacecraft
C                clock string. A tick is defined to be the smallest
C                time increment expressible by the spacecraft clock.
C
C                An analogy may be drawn between a spacecraft clock
C                and a standard wall clock, measuring hours, minutes
C                and seconds. The number of ticks represented by the
C                wall clock string
C                                     hh:mm:ss
C
C                would be the number of seconds represented by that
C                time.
C
C                For example:
C
C                         00:00:10  would convert to 10
C                         00:01:00  would convert to 60
C                         00:10:00  would convert to 600
C                         01:00:00  would convert to 3600
C                         01:01:00  would convert to 3660
C
C                See the Examples section below for examples for
C                actual spacecraft clocks.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If the spacecraft clock type is not supported then the
C         error SPICE(NOTSUPPORTED) is signalled.
C
C     2)  If any of the extracted clock components cannot be parsed as
C         integers, or the string has too many components, or the value
C         of one of the components is less than the offset value, then
C         the error is diagnosed by routines called by this routine.
C
C     3)  Invalid spacecraft ID's are not diagnosed.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     Each spacecraft is assigned a clock type code in the kernel file.
C     SCTIKS calls the function SCTYPE to determine this value. If the
C     clock type is supported by SPICELIB, then the routine TIKSnn is
C     called to handle the actual conversion from clock format to number
C     of ticks. The nn in TIKSnn refers to the spacecraft clock type
C     code. Different spacecraft have distict clock formats but can
C     still be of the same clock type.
C
C     The TIKSnn routines are entry points to the routines SCLKnn, which
C     also contain the ticks-to-clock format conversion routines FMTnn.
C     FMTnn is called by the subroutine SCFMT, which performs the
C     inverse operation to SCTIKS.
C
C     Note the important difference between SCENCD and SCTIKS. SCENCD
C     converts a clock string to the number of ticks it represents
C     since the beginning of the mission, and so uses partition
C     information. SCTIKS just converts to absolute ticks.
C
C$ Examples
C
C     SCTIKS is used as part of the process of encoding spacecraft clock
C     by SCENCD, though SCTIKS does not process any partition informa-
C     tion.
C
C     Another use of SCTIKS, however, is to convert a clock measurement
C     to ticks for use as a tolerance for the CK reader CKGP.
C
C
C     C
C     C      Get the pointing from a CK file of the VGR 1 narrow angle
C     C      image corresponding to a particular SCLK count.
C     C
C     C      Load the CK file and the kernel file containing SCLK
C     C      partition information for SCENCD.
C     C
C            CALL CKLPF  ( 'VGR1NA.CK', HANDLE )
C            CALL FURNSH ( 'SCLK.KER' )
C
C     C
C     C      Get the right ID numbers.
C     C
C            SC    = -31
C            INSTR = -31001
C
C     C
C     C      The SCLK string includes a partition number. Pictures are
C     C      never shuttered at intervals smaller than 1 MOD60 count
C     C      from each other. So use 1 MOD60 count as the time
C     C      tolerance.
C     C
C            CLKSTR = '1/20556:14:768'
C            TOLSTR = '      0:01:000'
C
C     C
C     C      Encode the clock string and the tolerance.
C     C
C            CALL SCENCD ( SC, CLKSTR, SCLK )
C            CALL SCTIKS ( SC, TOLSTR, TOL  )
C
C     C
C     C      Get the pointing from the C-kernel.
C     C
C            CALL CKGP ( INSTR, SCLK, TOL, REF, CMAT, CLKOUT, FOUND )
C
C
C
C      Below are some examples illustrating various clock string inputs
C      and the resulting outputs for the Galileo spacecraft. See the
C      SCLK required reading for a detailed description of the Galileo
C      clock format.
C
C         CLKSTR                TICKS
C         ----------------      --------------------
C         '0:0:0:1'             1
C         '0:0:1'               8
C         '0:1'                 80
C         '1'                   7280
C         '1 0 0 0'             7280
C         '1,0,0,0'             7280
C         '1:90'                14480
C         '1:9'                 8000
C         '1:09'                8000
C         '0-0-10'              80   |--  Third component is supposed
C         '0-1-0'               80   |    to be a mod-10 count.
C         '0/1/0'               Error: '/' is not an accepted delimiter.
C         '1: 00 : 0 : 1'       7281
C         '1:::1'               7281
C         '1.1.1.1.1'           Error: Too many components
C         '1.1.1.1.'            Error: The last delimiter signals that
C                                      a fifth component will follow.
C
C
C         The following examples are for the Voyager 2 spacecraft. Note
C         that the last component of the Voyager clock has an offset
C         value of 1.
C
C         CLKSTR                TICKS
C         ----------------      --------------------
C          '0.0.001'              0
C          '0:0:002'              1
C          '0:01'                 800
C          '1'                    48000
C          '1.0'                  48000
C          '1.0.0'                Error: The 3rd component is never 0.
C          '0.0:100'              99
C          '0-60-1'               48000
C          '1-1-1'                48800
C          '1-1-2'                48801
C
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     J.M. Lynch     (JPL)
C     R.E. Thurman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.2, 22-AUG-2006 (EDW)
C
C        Replaced references to LDPOOL with references
C        to FURNSH.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 06-SEP-1990 (JML) (RET)
C
C-&

C$ Index_Entries
C
C     convert spacecraft_clock string to ticks
C
C-&

C
C     SPICELIB functions
C
      INTEGER               SCTYPE
      LOGICAL               RETURN

C
C     Local variables
C
      INTEGER               TYPE

C
C     Standard SPICE error handling.
C
      IF ( RETURN () ) THEN
         RETURN
      ELSE
         CALL CHKIN ( 'SCTIKS' )
      END IF

C
C     If the spacecraft clock type is supported by NAIF then
C     call TIKSnn to perform the conversion.
C

      TYPE = SCTYPE ( SC )

      IF ( TYPE .EQ. 1 )  THEN
         CALL SCTK01 ( SC, CLKSTR, TICKS )
      ELSE
         CALL SETMSG ( 'Clock type # is not supported.' )
         CALL ERRINT ( '#', TYPE                        )
         CALL SIGERR ( 'SPICE(NOTSUPPORTED)'            )
         CALL CHKOUT ( 'SCTIKS'                         )
         RETURN

      END IF

      CALL CHKOUT ( 'SCTIKS' )

      RETURN
      END


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     subroutine eabx: only energy for a distinct halogen bond
!
!     part of QMDFF
!
subroutine eabx(n,A,B,H,xyz,ca,energy)
use qmdff
implicit none
integer::A,B,H,n
real(kind=8)::xyz(3,n),energy,rab
real(kind=8)::ang,xy,cosabh,d2ij,d2ik,d2jk,term,temp,fa,fb
real(kind=8)::aterm,dampm,dampl,xm,ym,zm,rhm,rab2,ca,cb,da
REAL(kind=8)::longcut=120.
REAL(kind=8)::alp7= 6
REAL(kind=8)::alp3=6
real(kind=8)::rbond(3)
!
!     AB distance
!
rbond(1)=XYZ(1,A)-XYZ(1,B)
rbond(2)=XYZ(2,A)-XYZ(2,B)
rbond(3)=XYZ(3,A)-XYZ(3,B)

!
!     apply periodic boundaries, if needed
!
if (periodic) then
   call box_image(rbond)
end if

rab2=rbond(1)**2+rbond(2)**2+rbond(3)**2

!
!     long  damping
!
dampl=1./(1.+(rab2/longcut)**alp7)
!
!     cos angle A-B and H (or B-H H) is term
!
rbond(1)=XYZ(1,A)-XYZ(1,H)
rbond(2)=XYZ(2,A)-XYZ(2,H)
rbond(3)=XYZ(3,A)-XYZ(3,H)
!
!     apply periodic boundaries, if needed
!
if (periodic) then
   call box_image(rbond)
end if

D2IK=rbond(1)**2+rbond(2)**2+rbond(3)**2

rbond(1)=XYZ(1,H)-XYZ(1,B)
rbond(2)=XYZ(2,H)-XYZ(2,B)
rbond(3)=XYZ(3,H)-XYZ(3,B)
!
!     apply periodic boundaries, if needed
!
if (periodic) then
   call box_image(rbond)
end if

D2JK=rbond(1)**2+rbond(2)**2+rbond(3)**2

if (d2ik.gt.d2jk) then
     XY=SQRT(rab2*D2JK)
     term=0.5D0*(rab2+D2JK-D2IK)/XY
else
     XY = SQRT(rab2*D2IK)
     term=0.5D0*(rab2+D2IK-D2JK)/XY
end if
!
!     angle damping term
!
aterm = (0.5d0*(term+1.0d0))**alp3

energy=-ca*dampl*aterm/d2jk

return
end subroutine eabx


c******************************************************************************
c
c      Manifold junction support routines
c
c******************************************************************************
c
       SUBROUTINE OTHRXX(RW,IW,NRK2)
c
c      Computes other runner flows at angle RIW(IoI)
c----------------------------------------------------------------------------
       PARAMETER           (NMPTR = 96)
       PARAMETER           (NDRW = 21024)
       PARAMETER           (NDIW = 2904)
       DIMENSION           MPTR(NMPTR)
       DIMENSION           RW(NDRW)
       DIMENSION           IW(NDIW)
       COMMON  /MPTRXX/    MPTR
c------------------------------------------------------------------------------
       EQUIVALENCE (IoKM1K,MPTR(9))
       EQUIVALENCE (IoRKM1,MPTR(13))
       EQUIVALENCE (IoC   ,MPTR(44))
       EQUIVALENCE (IoV   ,MPTR(45))
       EQUIVALENCE (IoP   ,MPTR(47))
       EQUIVALENCE (IoP0J ,MPTR(50))
       EQUIVALENCE (IoFI  ,MPTR(52))
       EQUIVALENCE (IoQI  ,MPTR(53))
       EQUIVALENCE (IoFO  ,MPTR(54))
       EQUIVALENCE (IoAD  ,MPTR(65))
       EQUIVALENCE (IoFAVO,MPTR(75))
       EQUIVALENCE (IoFAVN,MPTR(76))
       EQUIVALENCE (IoJTAU,MPTR(84))
       EQUIVALENCE (IoNCYE,MPTR(86))
       EQUIVALENCE (IoNCYL,MPTR(88))
       EQUIVALENCE (IoMAN ,MPTR(90))
       EQUIVALENCE (IoI   ,MPTR(91))
c-----------------------------------------------------------------------------
c    RK2 restoration data
       DIMENSION FIH(2),QIH(2),FOH(2)
       COMMON  /RK2OXX/FIH,QIH,FOH
c-----------------------------------------------------------------------------
       I = IW(IoI)
       M = IW(IoMAN)
c        check for multicylinder
           IF (IW(IoNCYL).GT.1) THEN
c                multi-cylinder
                   if (M.EQ.1) THEN
c                        intake
                           JR = 2
                           NR = 3
                           KS = 1
                       ELSE
c                        exhaust
                           JR = 1
                           NR = 2
                           KS = -1
                       ENDIF
c                compute flows for other cylinders
                   FIS = 0
                   QIS = 0
                   FOS = 0
                   DO 9 J=1,IW(IoNCYL)-1
                       ID = IJPXX(I,-IW(IoJTAU)*J)
                       IX = ID+720*NR
                       VX = RW(IoV+IX)
                       CX = RW(IoC+IX)
                       PX = RW(IoP+IX)
                       P0JX = RW(IoP0J+ID)
                       FO = KS*RW(IoAD+JR)*RCPXX(RW,CX,PX)*VX
                       IF (FO.LT.0)  THEN
c                            inflow to junction
                               H0X = RW(IoRKM1)*CX*CX + 0.5*VX*VX
                               FIS = FIS - FO

C                              QIS = QIS - FO*H0X/P0JX**RW(IoKM1K)

                               QIS = QIS - FO*H0X

                           ELSE
c                            outflow from junction
                               FOS =  FOS + FO
                           ENDIF
9                      CONTINUE

                   IF (NRK2.EQ.1)  THEN
c                        save averages for RK2 step 2 restoration
                           FIH(M) = RW(IoFI+I)
                           QIH(M) = RW(IoQI+I)
                           FOH(M) = RW(IoFO+I)
c                        get averages at previous angle
                           IM1 = IM1XX(I)
                           FIP = RW(IoFI+IM1)
                           QIP = RW(IoQI+IM1)
                           FOP = RW(IoFO+IM1)
c                        interpolate to the half angle
                           FIS = 0.5*(FIS+FIP)
                           QIS = 0.5*(QIS+QIP)
                           FOS = 0.5*(FOS+FOP)
                       ELSE
c                        restore values
                           RW(IoFI+I) = FIH(M)
                           RW(IoQI+I) = QIH(M)
                           RW(IoFO+I) = FOH(M)
                       ENDIF
c                average with previous engine cycles
                   RW(IoFI+I) = RW(IoFAVO)*RW(IoFI+I) + RW(IoFAVN)*FIS
                   RW(IoQI+I) = RW(IoFAVO)*RW(IoQI+I) + RW(IoFAVN)*QIS
                   RW(IoFO+I) = RW(IoFAVO)*RW(IoFO+I) + RW(IoFAVN)*FOS
               ELSE
c                single cylinder
                   RW(IoFI+I) = 0
                   RW(IoQI+I) = 0
                   RW(IoFO+I) = 0
               ENDIF
           RETURN
           END
c*****************************************************************************


MODULE traadv_qck
  USE oce
  USE dom_oce
  USE trc_oce
  USE trd_oce
  USE trdtra
  USE diaptr
  USE in_out_manager
  USE lib_mpp
  USE lbclnk
  USE lib_fortran
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: tra_adv_qck
  REAL(KIND = wp) :: r1_6 = 1. / 6.
  LOGICAL :: l_trd
  LOGICAL :: l_ptr
  CONTAINS
  SUBROUTINE tra_adv_qck(kt, kit000, cdtype, p2dt, pun, pvn, pwn, ptb, ptn, pta, kjpt)
    INTEGER, INTENT(IN   ) :: kt
    INTEGER, INTENT(IN   ) :: kit000
    CHARACTER(LEN = 3), INTENT(IN   ) :: cdtype
    INTEGER, INTENT(IN   ) :: kjpt
    REAL(KIND = wp), INTENT(IN   ) :: p2dt
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(IN   ) :: pun, pvn, pwn
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, kjpt), INTENT(IN   ) :: ptb, ptn
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, kjpt), INTENT(INOUT) :: pta
    IF (kt == kit000) THEN
      IF (lwp) WRITE(numout, FMT = *)
      IF (lwp) WRITE(numout, FMT = *) 'tra_adv_qck : 3rd order quickest advection scheme on ', cdtype
      IF (lwp) WRITE(numout, FMT = *) '~~~~~~~~~~~~'
      IF (lwp) WRITE(numout, FMT = *)
    END IF
    l_trd = .FALSE.
    l_ptr = .FALSE.
    IF ((cdtype == 'TRA' .AND. l_trdtra) .OR. (cdtype == 'TRC' .AND. l_trdtrc)) l_trd = .TRUE.
    IF (cdtype == 'TRA' .AND. ln_diaptr) l_ptr = .TRUE.
    CALL tra_adv_qck_i(kt, cdtype, p2dt, pun, ptb, ptn, pta, kjpt)
    CALL tra_adv_qck_j(kt, cdtype, p2dt, pvn, ptb, ptn, pta, kjpt)
    CALL tra_adv_cen2_k(kt, cdtype, pwn, ptn, pta, kjpt)
  END SUBROUTINE tra_adv_qck
  SUBROUTINE tra_adv_qck_i(kt, cdtype, p2dt, pun, ptb, ptn, pta, kjpt)
    INTEGER, INTENT(IN   ) :: kt
    CHARACTER(LEN = 3), INTENT(IN   ) :: cdtype
    INTEGER, INTENT(IN   ) :: kjpt
    REAL(KIND = wp), INTENT(IN   ) :: p2dt
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(IN   ) :: pun
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, kjpt), INTENT(IN   ) :: ptb, ptn
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, kjpt), INTENT(INOUT) :: pta
    INTEGER :: ji, jj, jk, jn
    REAL(KIND = wp) :: ztra, zbtr, zdir, zdx, zmsk
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zwx, zfu, zfc, zfd
    DO jn = 1, kjpt
      !$ACC KERNELS
      zfu(:, :, :) = 0._wp
      zfc(:, :, :) = 0._wp
      zfd(:, :, :) = 0._wp
      zwx(:, :, :) = 0._wp
      DO jk = 1, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zfc(ji, jj, jk) = ptb(ji - 1, jj, jk, jn)
            zfd(ji, jj, jk) = ptb(ji + 1, jj, jk, jn)
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      CALL lbc_lnk_multi(zfc(:, :, :), 'T', 1., zfd(:, :, :), 'T', 1.)
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zdir = 0.5 + SIGN(0.5, pun(ji, jj, jk))
            zfu(ji, jj, jk) = zdir * zfc(ji, jj, jk) + (1. - zdir) * zfd(ji + 1, jj, jk)
          END DO
        END DO
      END DO
      DO jk = 1, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zdir = 0.5 + SIGN(0.5, pun(ji, jj, jk))
            zdx = (zdir * e1t(ji, jj) + (1. - zdir) * e1t(ji + 1, jj)) * e2u(ji, jj) * e3u_n(ji, jj, jk)
            zwx(ji, jj, jk) = ABS(pun(ji, jj, jk)) * p2dt / zdx
            zfc(ji, jj, jk) = zdir * ptb(ji, jj, jk, jn) + (1. - zdir) * ptb(ji + 1, jj, jk, jn)
            zfd(ji, jj, jk) = zdir * ptb(ji + 1, jj, jk, jn) + (1. - zdir) * ptb(ji, jj, jk, jn)
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      CALL lbc_lnk_multi(zfu(:, :, :), 'T', 1., zfd(:, :, :), 'T', 1., zfc(:, :, :), 'T', 1., zwx(:, :, :), 'T', 1.)
      CALL quickest(zfu, zfd, zfc, zwx)
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zfu(ji, jj, jk) = tmask(ji - 1, jj, jk) + tmask(ji, jj, jk) + tmask(ji + 1, jj, jk) - 2.
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      CALL lbc_lnk(zfu(:, :, :), 'T', 1.)
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zdir = 0.5 + SIGN(0.5, pun(ji, jj, jk))
            zmsk = zdir * zfu(ji, jj, jk) + (1. - zdir) * zfu(ji + 1, jj, jk)
            zwx(ji, jj, jk) = zmsk * zwx(ji, jj, jk) + (1. - zmsk) * zfc(ji, jj, jk)
            zwx(ji, jj, jk) = zwx(ji, jj, jk) * pun(ji, jj, jk)
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      CALL lbc_lnk(zwx(:, :, :), 'T', 1.)
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zbtr = r1_e1e2t(ji, jj) / e3t_n(ji, jj, jk)
            ztra = - zbtr * (zwx(ji, jj, jk) - zwx(ji - 1, jj, jk))
            pta(ji, jj, jk, jn) = pta(ji, jj, jk, jn) + ztra
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      IF (l_trd) CALL trd_tra(kt, cdtype, jn, jptra_xad, zwx, pun, ptn(:, :, :, jn))
    END DO
  END SUBROUTINE tra_adv_qck_i
  SUBROUTINE tra_adv_qck_j(kt, cdtype, p2dt, pvn, ptb, ptn, pta, kjpt)
    INTEGER, INTENT(IN   ) :: kt
    CHARACTER(LEN = 3), INTENT(IN   ) :: cdtype
    INTEGER, INTENT(IN   ) :: kjpt
    REAL(KIND = wp), INTENT(IN   ) :: p2dt
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(IN   ) :: pvn
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, kjpt), INTENT(IN   ) :: ptb, ptn
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, kjpt), INTENT(INOUT) :: pta
    INTEGER :: ji, jj, jk, jn
    REAL(KIND = wp) :: ztra, zbtr, zdir, zdx, zmsk
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zwy, zfu, zfc, zfd
    DO jn = 1, kjpt
      !$ACC KERNELS
      zfu(:, :, :) = 0.0
      zfc(:, :, :) = 0.0
      zfd(:, :, :) = 0.0
      zwy(:, :, :) = 0.0
      DO jk = 1, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zfc(ji, jj, jk) = ptb(ji, jj - 1, jk, jn)
            zfd(ji, jj, jk) = ptb(ji, jj + 1, jk, jn)
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      CALL lbc_lnk_multi(zfc(:, :, :), 'T', 1., zfd(:, :, :), 'T', 1.)
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zdir = 0.5 + SIGN(0.5, pvn(ji, jj, jk))
            zfu(ji, jj, jk) = zdir * zfc(ji, jj, jk) + (1. - zdir) * zfd(ji, jj + 1, jk)
          END DO
        END DO
      END DO
      DO jk = 1, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zdir = 0.5 + SIGN(0.5, pvn(ji, jj, jk))
            zdx = (zdir * e2t(ji, jj) + (1. - zdir) * e2t(ji, jj + 1)) * e1v(ji, jj) * e3v_n(ji, jj, jk)
            zwy(ji, jj, jk) = ABS(pvn(ji, jj, jk)) * p2dt / zdx
            zfc(ji, jj, jk) = zdir * ptb(ji, jj, jk, jn) + (1. - zdir) * ptb(ji, jj + 1, jk, jn)
            zfd(ji, jj, jk) = zdir * ptb(ji, jj + 1, jk, jn) + (1. - zdir) * ptb(ji, jj, jk, jn)
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      CALL lbc_lnk_multi(zfu(:, :, :), 'T', 1., zfd(:, :, :), 'T', 1., zfc(:, :, :), 'T', 1., zwy(:, :, :), 'T', 1.)
      CALL quickest(zfu, zfd, zfc, zwy)
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zfu(ji, jj, jk) = tmask(ji, jj - 1, jk) + tmask(ji, jj, jk) + tmask(ji, jj + 1, jk) - 2.
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      CALL lbc_lnk(zfu(:, :, :), 'T', 1.)
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zdir = 0.5 + SIGN(0.5, pvn(ji, jj, jk))
            zmsk = zdir * zfu(ji, jj, jk) + (1. - zdir) * zfu(ji, jj + 1, jk)
            zwy(ji, jj, jk) = zmsk * zwy(ji, jj, jk) + (1. - zmsk) * zfc(ji, jj, jk)
            zwy(ji, jj, jk) = zwy(ji, jj, jk) * pvn(ji, jj, jk)
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      CALL lbc_lnk(zwy(:, :, :), 'T', 1.)
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zbtr = r1_e1e2t(ji, jj) / e3t_n(ji, jj, jk)
            ztra = - zbtr * (zwy(ji, jj, jk) - zwy(ji, jj - 1, jk))
            pta(ji, jj, jk, jn) = pta(ji, jj, jk, jn) + ztra
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      IF (l_trd) CALL trd_tra(kt, cdtype, jn, jptra_yad, zwy, pvn, ptn(:, :, :, jn))
      IF (l_ptr) CALL dia_ptr_hst(jn, 'adv', zwy(:, :, :))
    END DO
  END SUBROUTINE tra_adv_qck_j
  SUBROUTINE tra_adv_cen2_k(kt, cdtype, pwn, ptn, pta, kjpt)
    INTEGER, INTENT(IN   ) :: kt
    CHARACTER(LEN = 3), INTENT(IN   ) :: cdtype
    INTEGER, INTENT(IN   ) :: kjpt
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(IN   ) :: pwn
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, kjpt), INTENT(IN   ) :: ptn
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, kjpt), INTENT(INOUT) :: pta
    INTEGER :: ji, jj, jk, jn
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zwz
    !$ACC KERNELS
    zwz(:, :, 1) = 0._wp
    zwz(:, :, jpk) = 0._wp
    !$ACC END KERNELS
    DO jn = 1, kjpt
      !$ACC KERNELS
      DO jk = 2, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zwz(ji, jj, jk) = 0.5 * pwn(ji, jj, jk) * (ptn(ji, jj, jk - 1, jn) + ptn(ji, jj, jk, jn)) * wmask(ji, jj, jk)
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      IF (ln_linssh) THEN
        IF (ln_isfcav) THEN
          !$ACC KERNELS
          DO jj = 1, jpj
            DO ji = 1, jpi
              zwz(ji, jj, mikt(ji, jj)) = pwn(ji, jj, mikt(ji, jj)) * ptn(ji, jj, mikt(ji, jj), jn)
            END DO
          END DO
          !$ACC END KERNELS
        ELSE
          !$ACC KERNELS
          zwz(:, :, 1) = pwn(:, :, 1) * ptn(:, :, 1, jn)
          !$ACC END KERNELS
        END IF
      END IF
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            pta(ji, jj, jk, jn) = pta(ji, jj, jk, jn) - (zwz(ji, jj, jk) - zwz(ji, jj, jk + 1)) * r1_e1e2t(ji, jj) / e3t_n(ji, jj, jk)
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      IF (l_trd) CALL trd_tra(kt, cdtype, jn, jptra_zad, zwz, pwn, ptn(:, :, :, jn))
    END DO
  END SUBROUTINE tra_adv_cen2_k
  SUBROUTINE quickest(pfu, pfd, pfc, puc)
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(IN   ) :: pfu
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(IN   ) :: pfd
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(IN   ) :: pfc
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(INOUT) :: puc
    INTEGER :: ji, jj, jk
    REAL(KIND = wp) :: zcoef1, zcoef2, zcoef3
    REAL(KIND = wp) :: zc, zcurv, zfho
    !$ACC KERNELS
    DO jk = 1, jpkm1
      DO jj = 1, jpj
        DO ji = 1, jpi
          zc = puc(ji, jj, jk)
          zcurv = pfd(ji, jj, jk) + pfu(ji, jj, jk) - 2. * pfc(ji, jj, jk)
          zcoef1 = 0.5 * (pfc(ji, jj, jk) + pfd(ji, jj, jk))
          zcoef2 = 0.5 * zc * (pfd(ji, jj, jk) - pfc(ji, jj, jk))
          zcoef3 = (1. - (zc * zc)) * r1_6 * zcurv
          zfho = zcoef1 - zcoef2 - zcoef3
          zcoef1 = pfd(ji, jj, jk) - pfu(ji, jj, jk)
          zcoef2 = ABS(zcoef1)
          zcoef3 = ABS(zcurv)
          IF (zcoef3 >= zcoef2) THEN
            zfho = pfc(ji, jj, jk)
          ELSE
            zcoef3 = pfu(ji, jj, jk) + ((pfc(ji, jj, jk) - pfu(ji, jj, jk)) / MAX(zc, 1.E-9))
            IF (zcoef1 >= 0.) THEN
              zfho = MAX(pfc(ji, jj, jk), zfho)
              zfho = MIN(zfho, MIN(zcoef3, pfd(ji, jj, jk)))
            ELSE
              zfho = MIN(pfc(ji, jj, jk), zfho)
              zfho = MAX(zfho, MAX(zcoef3, pfd(ji, jj, jk)))
            END IF
          END IF
          puc(ji, jj, jk) = zfho
        END DO
      END DO
    END DO
    !$ACC END KERNELS
  END SUBROUTINE quickest
END MODULE traadv_qck


!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

!
!  *********************************************************************
!  *    SUBROUTINE TO DETERMINE LIMITS ON THE EXTINCTION COEFFICIENT   *
!  *********************************************************************
!
      SUBROUTINE CONSTR(SURF,DMIX,EMIN,ROOT,NUMGR)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(2),B(2),ROOT(2)
      INCLUDE 'blmdim.inc'
      INCLUDE 'arran.inc'
!
!  DETERMINES LIMITS ON THE EXTINCTION COEFFICIENT
!
    1 ROOT(1)=-1.0
      ROOT(2)=-1.0
      S0=DEXP(-ZVEC(NZ))
      IF (SURF .LE. S0) RETURN
!
!  FIND INTERVAL CONTAINING ALL ROOTS
!
      X=-DLOG(SURF)
      CALL EBCALC(X,FX,DERX,NUMGR)
      PHI=(FUN(NZ,NUMGR)-FX)/EMIN
      Y=X+PHI
      IF (DERX .GE. EMIN) ROOT(1)=0.0
      IF (Y .GE. ZVEC(NZ)) ROOT(2)=PHI/DMIX
      IF (ROOT(1) .GE. 0.0 .AND. ROOT(2) .GE. 0.0) RETURN
!
!  SPLIT INTERVAL TO ISOLATE EACH ROOT.
!
      B(1)=X
      B(2)=Y
      DO 110 K=1,10
      A(1)=0.5*(B(1)+B(2))
      CALL EBCALC(A(1),FM,FPR,NUMGR)
      EBAR=(FM-FX)/(A(1)-X)
      IF (EBAR .GE. EMIN) GO TO 120
      DERIV=(FPR-EBAR)/(A(1)-X)
      IF (DERIV .LT. 0.0) B(2)=A(1)
  110 IF (DERIV .GE. 0.0) B(1)=A(1)
!
!  NO ROOTS EXIST
!
      RETURN
!
!  WE HAVE SEPARATED THE ROOTS.
!
  120 A(2)=A(1)
      DO 130 I=1,2
      IF (ROOT(I) .GE. 0.0) GO TO 130
      DO 125 K=1,10
      XM=0.5*(A(I)+B(I))
      CALL EBCALC(XM,FM,FP,NUMGR)
      EBAR=(FM-FX)/(XM-X)
      IF (EBAR .GT. EMIN) A(I)=XM
  125 IF (EBAR .LE. EMIN) B(I)=XM
      ROOT(I)=(0.5*(A(I)+B(I))-X)/DMIX
  130 CONTINUE
      RETURN
      END


!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      subroutine difacr(icx       ,icy       ,j         ,nmmaxj    ,
     *                  nmmax     ,kmax      ,
     *                  lstsci    ,lsal      ,ltem      ,
     *                  kcs       ,kfu       ,kfv       ,
     *                  kadu      ,kadv      ,
     *                  s0        ,dps       ,r0        ,ddkl      ,
     *                  guu       ,gvv       ,guv       ,gvu       ,
     *                  thick     ,sig       ,dicuv     ,sigdif    ,
     *                  dsdksi    ,dtdksi    ,dsdeta    ,dtdeta    ,
     *                  dfluxx    ,dfluxy                          )
!-----------------------------------------------------------------------
!             Module: SUBROUTINE DIFACR
!           Function: Computes horizontal diffusion along Z-planes.
!                     Explicit in u-direction, explicit in v-
!                     direction.
!                     Horizontal gradients salinity and temperature
!                     are computed in subroutine dengra.
!                     Only if KMAX > 1 and Anti Creep
!        Method used: Reference : On the approximation of horizontal
!                     gradients in sigma co-ordinates for bathymetry
!                     with steep bottom slopes (G.S. Stelling and J.
!                     van Kester - International Journal for Methods
!                     in Fluids, Vol. 18 1994)
!               Date: 19-07-2000
!         Programmer: G.S. Stelling, J. v. Kester, A.J. Mourits
!         CVS header
!            $Author: Beek_j $
!              $Date: 22-09-03 15:46 $
!            $Source: /u/trisula/cvsroot/trisula/reken/difacr.f,v $
!          $Revision: 1 $
!-----------------------------------------------------------------------
!   Calling routines:              DIFU
!                                  DIFUEX
!                                  DIFUIM
!                                  DIFUVL
!-----------------------------------------------------------------------
!   Called  routines:              DIFHOR
!-----------------------------------------------------------------------
!  Formal parameters:
!  ------------------
!
!   Var. I/O  Type Dimensions
!   -------------------------
!
! DDKL    --  R*4  J:NMMAXJ,KMAX,LSTSCI
!                                  Internal work array, diagonal space
!                                  at (n,m,k,l)
! DFLUXX  IO  R*4  J:NMMAXJ,KMAX,LSTSCI
!                                  Work array for horizontal diffusion flux
! DFLUXY  IO  R*4  J:NMMAXJ,KMAX,LSTSCI
!                                  Work array for horizontal diffusion flux
! DICUV   --  R*4  J:NMMAXJ,KMAX   Horizontal diffusion coeff. [m2/s]
! DPS     I   R*4  J:NMMAXJ        Depth value at zeta points
! DSDETA  I   R*4  J:NMMAXJ,KMAX   Horizontal gradient salinity,
!                                  strictly horizontal in eta-direction
!                                  For Anti Creep: Contribution diffu-
!                                  sive flux interpolated on Cartesian
!                                  grid to cell NM
! DSDKSI  I   R*4  J:NMMAXJ,KMAX   Horizontal gradient salinity,
!                                  strictly horizontal in ksi-direction
!                                  For Anti Creep: Contribution diffu-
!                                  sive flux interpolated on Cartesian
!                                  grid to cell NM
! DTDETA  I   R*4  J:NMMAXJ,KMAX   Horizontal gradient temperature,
!                                  strictly horizontal in eta-direction
!                                  For Anti Creep: Contribution diffu-
!                                  sive flux interpolated on Cartesian
!                                  grid to cell NM
! DTDKSI  I   R*4  J:NMMAXJ,KMAX   Horizontal gradient temperature,
!                                  strictly horizontal in ksi-direction
!                                  For Anti Creep: Contribution diffu-
!                                  sive flux interpolated on Cartesian
!                                  grid to cell NM
! GUU     --  R*4  J:NMMAXJ        Grid distance in the eta-/y-direction
!                                  at u-velocity point
! GUV     --  R*4  J:NMMAXJ        Grid distance in the eta-/y-direction
!                                  at v-velocity point
! GVU     --  R*4  J:NMMAXJ        Grid distance in the ksi-/x-direction
!                                  at u-velocity point
! GVV     --  R*4  J:NMMAXJ        Grid distance in the ksi-/x-direction
!                                  at v-velocity point
! ICX     I   I*4                  Increment in the x-dir., if icx= nmax
!                                  then computation proceeds in the x-
!                                  dir. if icx=1 then computation pro-
!                                  ceeds in the y-dir.
! ICY     I   I*4                  Increment in the y-dir. (see icx)
! J       I   I*4                  Begin pointer for arrays which have
!                                  been transformed into 1d arrays.
!                                  due to the shift in the 2nd (m-)
!                                  index, j = -2*nmax + 1
! KADU    --  I*4  J:NMMAXJ,KMAX   Mask array for adv. term adjustment
!                                  for structures in U-points
!                                  = 1 no structure (HYD)
!                                  = 1 no gate (TRA)
!                                  = 0 structure
!                                  = 0 gate (KSPU(NM,0)*KSPU(NM,K)=4)
! KADV    --  I*4  J:NMMAXJ,KMAX   Mask array for adv. term adjustment
!                                  for structures in V-points
!                                  = 1 no structure (HYD)
!                                  = 1 no gate (TRA)
!                                  = 0 structure
!                                  = 0 gate (KSPV(NM,0)*KSPV(NM,K)=4)
! KCS     --  I*4  J:NMMAXJ        Mask array for the zeta points
!                                  (time independent)
!                                  =0 inactive point
!                                  =1 active   point
!                                  =2 open boundary point
! KFU     I   I*4  J:NMMAXJ        Mask array for the u-velocity point
!                                  (time dependent)
!                                  =0 dry      point
!                                  =1 active   point
! KFV     I   I*4  J:NMMAXJ        Mask array for the v-velocity point
!                                  (time dependent)
!                                  =0 dry      point
!                                  =1 active   point
! KMAX    I   I*4                  Number of layers in the z-dir.
! LSAL    --  I*4                  Pointer for salinity in array r
!                                  for constituents (if used, always 1)
! LSTSCI  I   I*4                  Number of Constituents (Salinity,
!                                  Temperature, Sediment, Conservative
!                                  Constituents and Secondary Flow)
! LTEM    --  I*4                  Pointer for temperature in array r
!                                  for constituents (lsal+1)
! NMMAX   --  I*4                  Total number of grid pts. (nmax*mmax)
! NMMAXJ  I   I*4                  End   pointer for arrays which have
!                                  been transformed into 1d arrays.
!                                  due to the shift in the 2nd (m-)
!                                  index, nmmaxj = nmmax + 2 * nmax
! R0      --  R*4  J:NMMAXJ,KMAX,LSTSCI
!                                  Concentrations at old time level
! S0      I   R*4  J:NMMAXJ        Zeta at old time level
! SIG     --  R*4  KMAX            Sigma coordinate density points.
! SIGDIF  --  R*4  LSTSCI          Prandtl/schmidt-numbers for const.
! THICK   --  R*4  KMAX            Relative layer thickness
!-----------------------------------------------------------------------
!    local variables:
!    ----------------
!
!   var.      type dimensions
!   -------------------------
!
! AREA        R*4
! CL          R*4
! CR          R*4
! DIFL        R*4
! DIFR        R*4
! FLUX        R*4
! K           I*4
! KENU        I*4
! KENV        I*4
! L           I*4
! NM          I*4
! NMU         I*4
! NUM         I*4
!-----------------------------------------------------------------------
!
! declaration
!
!-----------------------------------------------------------------------
!     GLOBAL DATA
!
!     global data structure definition and access functions
!     include 'globdat.igd'
!-----------------------------------------------------------------------
      use timers

      dimension   s0    (j:nmmaxj),dps   (j:nmmaxj),
     *            guu   (j:nmmaxj),gvv   (j:nmmaxj),
     *            guv   (j:nmmaxj),gvu   (j:nmmaxj)
!
      dimension   kcs   (j:nmmaxj),
     *            kfu   (j:nmmaxj),kfv   (j:nmmaxj),
     *            kadu  (j:nmmaxj,  kmax),
     *            kadv  (j:nmmaxj,  kmax)
!
      dimension   dicuv (j:nmmaxj,kmax),
     *            r0    (j:nmmaxj,kmax,lstsci),
     *            dsdksi(j:nmmaxj,kmax),dsdeta(j:nmmaxj,kmax  ),
     *            dtdksi(j:nmmaxj,kmax),dtdeta(j:nmmaxj,kmax  ),
     *            ddkl  (j:nmmaxj,kmax,lstsci),
     *            thick (kmax),sigdif(lstsci) ,
     *            sig   (kmax)

      dimension   dfluxx(j:nmmaxj,kmax,lstsci),
     *            dfluxy(j:nmmaxj,kmax,lstsci)

      integer(4) ithandl /0/
      if ( timon ) call timstrt ( "difacr", ithandl )

      dfluxx = 0.0
      dfluxy = 0.0

!
!***horizontal diffusion in both u- and v-diffusion
!   artificial creep is avoided by use
!   of a special limiter
!
!***calibration for SAL / TEMP in routine DENGRA
!
!$dir scalar
      if (lsal   .ne. 0) then
        do 10 nm=1,nmmax
          do 20 k=1,kmax
            ddkl(nm ,k,lsal)=ddkl(nm ,k,lsal)+dsdksi(nm,k)+
     *                                        dsdeta(nm,k)
 20       continue
 10     continue
      endif
      if (ltem   .ne. 0) then
        do 50 nm=1,nmmax
          do 60 k=1,kmax
            ddkl(nm ,k,ltem)=ddkl(nm ,k,ltem)+dtdksi(nm,k)+
     *                                        dtdeta(nm,k)
 60       continue
 50     continue
      endif
!
      if (lstsci.eq.MAX (lsal,ltem)) goto 1000
!
!***calibration for all other constituents
!   horizontal diffusion in u-diffusion
!   artificial creep is avoided by use
!   of a special limiter
!
      nmu = icx
      do 150 nm=1,nmmax
        nmu =nmu+1
        if (kfu(nm).ne.0) then
          sepnm =s0 (nm)
          sepnmu=s0 (nmu)
          dpnm  =dps(nm)
          dpnmu =dps(nmu)
          call   DIFHOR(nm        ,nmu       ,j         ,nmmaxj    ,
     *                  kmax      ,lstsci    ,lsal      ,ltem      ,
     *                  kcs       ,kadu      ,
     *                  sepnm     ,sepnmu    ,dpnm      ,dpnmu     ,
     *                  guu       ,gvu       ,
     *                  r0        ,ddkl      ,
     *                  thick     ,sig       ,dicuv     ,sigdif    ,
     *                  dfluxx                                     )

        endif
 150  continue
!
!***calibration for all other constituents
!   horizontal diffusion in v-direction
!   artificial creep is avoided by use
!   of a special limiter
!
      num = icy
      do 250 nm=1,nmmax
        num  =num+1
        if (kfv(nm).ne.0) then
          sepnm =s0 (nm)
          sepnum=s0 (num)
          dpnm  =dps(nm)
          dpnum =dps(num)
          call   DIFHOR(nm        ,num       ,j         ,nmmaxj    ,
     *                  kmax      ,lstsci    ,lsal      ,ltem      ,
     *                  kcs       ,kadv      ,
     *                  sepnm     ,sepnum    ,dpnm      ,dpnum     ,
     *                  gvv       ,guv       ,
     *                  r0        ,ddkl      ,
     *                  thick     ,sig       ,dicuv     ,sigdif    ,
     *                  dfluxy                                     )

        endif
 250  continue
!
 1000 continue
      if ( timon ) call timstop ( ithandl )
      return
      end


!------------------------------------------------------------------------!
!  The Community Multiscale Air Quality (CMAQ) system software is in     !
!  continuous development by various groups and is based on information  !
!  from these groups: Federal Government employees, contractors working  !
!  within a United States Government contract, and non-Federal sources   !
!  including research institutions.  These groups give the Government    !
!  permission to use, prepare derivative works of, and distribute copies !
!  of their work in the CMAQ system to the public and to permit others   !
!  to do so.  The United States Environmental Protection Agency          !
!  therefore grants similar permission to use the CMAQ system software,  !
!  but users are requested to provide copies of derivative works or      !
!  products designed to operate in the CMAQ system to the United States  !
!  Government without restrictions as to use by others.  Software        !
!  that is used with the CMAQ system but distributed under the GNU       !
!  General Public License or the GNU Lesser General Public License is    !
!  subject to their copyright restrictions.                              !
!------------------------------------------------------------------------!

C:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
      SUBROUTINE ACMCLD ( NSP, NLAYS, F, C, DZH, CBELOW, CLBASE, CLTOP,
     &                    FRAC, TCLIFE, DTCLD )
C-----------------------------------------------------------------------
C
C  FUNCTION:  Subroutine to compute convective mixing in the CBL
C             according to the Asymmetrical Convective Model (ACM).
C             Ref: Pleim and Chang (1992)
C
C  SUMMARY:
C   ACM is based on the Blackadar non-local convective model which is
C   used in HIRPBL where upward mixing similar to Blackadar but
C   downward mixing is to the next lower level representing more
C   realistic gradual subsidence.
C
C  REVISION  HISTORY:
C      Date   Who             What
C    -------- ---             -----------------------------------------
C     06/2005 J.Pleim         Initial version
C     07/2005 J.Young         Clean up for CMAQ-F
C     05/2015 J.Young         Clean up for CMAQv5.1
C     01/2018 J.Pleim         Convert from sigma to Z for MPAS
C-----------------------------------------------------------------------\

      IMPLICIT NONE

C Arguments

      INTEGER, INTENT( IN ) :: NSP            ! no. of species
      INTEGER, INTENT( IN ) :: NLAYS          ! no. of model layers
      REAL, INTENT( IN )    :: F( : )         ! entrainment fraction
      REAL, INTENT( INOUT ) :: C( :, : )      ! species concentration
      REAL, INTENT( IN )    :: DZH( : )
      REAL, INTENT( INOUT ) :: CBELOW( : )    ! spec conc in layer below cld base
      INTEGER, INTENT( IN ) :: CLBASE
      INTEGER, INTENT( IN ) :: CLTOP
      REAL, INTENT( IN )    :: FRAC           ! grid cell fractional cloud cover
      REAL, INTENT( IN )    :: TCLIFE         ! cloud lifetime (s)
      REAL, INTENT( IN )    :: DTCLD          ! cloud integration time step

C Parameters

      REAL, PARAMETER :: HALF = 0.5
      REAL, PARAMETER :: CRANKP = 0.5

C Local variables

      INTEGER NLP, K, NL, S          ! index variables
      INTEGER KB

      REAL DTLIM, F1
      REAL DTS, DELC, M1UP
      REAL( 8 ), ALLOCATABLE, SAVE :: AI( : ), BI( : ), EI( : )
      REAL( 8 ), ALLOCATABLE, SAVE :: DI( : ), UI( : )
      REAL( 8 ) :: ALPHA, BETA, GAMA
      REAL, ALLOCATABLE, SAVE :: VCI( :,: )
      REAL, ALLOCATABLE, SAVE :: MBARKS( : ), MDWN( : )

!--Local Arrays for MPAS implementation
      REAL, ALLOCATABLE, SAVE     :: DZHI  ( : )               ! 1/DZH

      INTEGER :: ALLOCSTAT
      LOGICAL, SAVE :: FIRSTIME = .TRUE.
      CHARACTER (LEN = 80) :: XMSG

C-----------------------------------------------------------------------

      IF (FIRSTIME) THEN
         ALLOCATE (AI( NLAYS ),
     &             BI( NLAYS ),
     &             EI( NLAYS ),
     &             DI( NLAYS ),
     &             UI( NLAYS ),
     &             VCI( NLAYS,NSP ),
     &             MBARKS( NLAYS ),
     &             MDWN( NLAYS ),
     &             DZHI  ( NLAYS ),
     &             STAT=ALLOCSTAT)
         IF ( ALLOCSTAT .NE. 0 ) THEN
            XMSG = 'EXIT: Failure allocating AI, BI, EI, DI, UI, VCI, MBARKS, MDWN or DZHI'
            write (6, *) trim(xmsg); stop
         END IF
         FIRSTIME = .FALSE.
      END IF

      DTLIM = DTCLD
      MDWN ( CLTOP + 1 ) = 0.0
      M1UP = 0.0
      DZHI = 1.0 / DZH ! array assignment
      KB  = CLBASE - 1
      DZHI( KB ) = 1.0 / DZH( KB )

C Compute ACM mixing rate

      DO K = CLTOP, CLBASE, -1
        MBARKS( K ) = ( 1.0 - F( K ) ) * FRAC / TCLIFE
        MDWN  ( K ) = MBARKS( K ) + MDWN( K + 1 ) * DZH( K + 1 ) * DZHI( K )
        M1UP  = M1UP + MBARKS( K ) * DZH( K )
        DTLIM = MIN( HALF / ( M1UP * DZHI( K ) ), DTLIM )
      END DO
      DTLIM = MIN( HALF / ( M1UP * DZHI( KB ) ), DTLIM )

      DO S = 1, NSP
        VCI( KB, S ) = CBELOW( S )
        VCI( CLTOP+1,S ) = 9999.0
        DO K = CLBASE, CLTOP
          VCI( K,S ) = C( S,K )
          UI( K )  = 0.0           ! init variable for use below
        END DO
      END DO

      NLP = INT( DTCLD / DTLIM + 1.0 )
      DTS = ( DTCLD / NLP )
      DO 2000 NL = 1, NLP      ! loop over sub timestep
        DO 1000 S = 1, NSP     ! loop over species

C Compute tendency of CBL concentrations - Semi-Implicit solution

          DO K = CLBASE, CLTOP
            DELC = DTS
     &           * ( MBARKS( K ) * VCI( KB,S )
     &           -   MDWN( K ) * VCI( K,S )
     &           +   DZH( K+1 ) * DZHI( K ) * MDWN( K+1 ) * VCI( K+1,S ) )
            DI( K ) = VCI( K,S ) + ( 1.0 - CRANKP ) * DELC
            EI( K ) = -CRANKP * MDWN( K ) * DTS * DZH( K ) * DZHI( K-1 )
            BI( K ) = 1.0 + CRANKP * MDWN( K ) * DTS
            AI( K ) = -CRANKP * MBARKS( K ) * DTS
          END DO

          BI( KB ) = 1.0 + CRANKP * M1UP * DTS * DZHI( KB )
          F1 = M1UP * VCI( KB,S )
     &       - MDWN( CLBASE ) * VCI( CLBASE,S ) * DZH( CLBASE )
          DI( KB ) = VCI( KB,S ) - ( 1.0 - CRANKP ) * F1 * DZHI( KB ) * DTS

C Define arrays A,B,E which make up matrix and D which is RHS

          BETA = DI( KB )
          GAMA = BI( KB )
          ALPHA = 1.0
          DO K = CLBASE, CLTOP
            ALPHA = -ALPHA * EI( K ) / BI( K )
            BETA  = ALPHA * DI( K ) + BETA
            GAMA  = ALPHA * AI( K ) + GAMA
          END DO
          UI( KB )   = BETA / GAMA
          UI( CLTOP ) = ( DI( CLTOP ) - AI( CLTOP ) * UI( KB ) ) / BI( CLTOP )

          BETA = DI( KB )
          GAMA = BI( KB )
          ALPHA = 1.0

C Back substitution:
          DO K = CLTOP - 1, CLBASE, -1
            UI( K ) = ( DI( K ) - AI( K ) * UI( KB ) - EI( K+1 ) * UI( K+1 ) )
     &              / BI( K )
          END DO

C Update concentrations
          DO K = KB, CLTOP
            VCI( K,S ) = REAL( UI( K ), 4 )
          END DO

1000    CONTINUE   ! end loop for species
2000  CONTINUE   ! end timestep loop

      DO S = 1, NSP

        CBELOW( S ) = VCI( KB,S )

        DO K = CLBASE, CLTOP
          C( S,K ) = VCI( K,S )
        END DO

      END DO

      RETURN
      END


C$Procedure      SPKR08 ( Read SPK record from segment, type 8 )

      SUBROUTINE SPKR08 ( HANDLE, DESCR, ET, RECORD )
      IMPLICIT NONE

C$ Abstract
C
C     Read a single SPK data record from a segment of type 8
C     (equally spaced discrete states, interpolated by Lagrange
C     polynomials).
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     SPK
C     TIME
C
C$ Keywords
C
C     EPHEMERIS
C
C$ Declarations

      INTEGER               HANDLE
      DOUBLE PRECISION      DESCR    ( 5 )
      DOUBLE PRECISION      ET
      DOUBLE PRECISION      RECORD   ( * )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     HANDLE     I   File handle.
C     DESCR      I   Segment descriptor.
C     ET         I   Target epoch.
C     RECORD     O   Data record.
C
C$ Detailed_Input
C
C     HANDLE,
C     DESCR       are the file handle and segment descriptor for
C                 a SPK segment of type 8.
C
C     ET          is a target epoch, for which a data record from
C                 a specific segment is required.
C
C$ Detailed_Output
C
C     RECORD      is a set of data from the specified segment which,
C                 when evaluated at epoch ET, will give the state
C                 (position and velocity) of some body, relative
C                 to some center, in some inertial reference frame.
C
C                 The structure of the record is as follows:
C
C                    +----------------------+
C                    | number of states (n) |
C                    +----------------------+
C                    | start epoch          |
C                    +----------------------+
C                    | step size            |
C                    +----------------------+
C                    | state 1 (6 elts.)    |
C                    +----------------------+
C                    | state 2 (6 elts.)    |
C                    +----------------------+
C                                .
C                                .
C                                .
C                    +----------------------+
C                    | state n (6 elts.)    |
C                    +----------------------+
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     This routine follows the pattern established in the lower-numbered
C     SPK data type readers of not explicitly performing error
C     diagnoses.  Exceptions are listed below nonetheless.
C
C     1)  If the input HANDLE does not designate a loaded SPK file, the
C         error will be diagnosed by routines called by this routine.
C
C     2) If the segment specified by DESCR is not of data type 08,
C        the error 'SPICE(WRONGSPKTYPE)' is signalled.
C
C     3)  If the input ET value is not within the range specified
C         in the segment descriptor, the error SPICE(TIMEOUTOFBOUNDS)
C         is signalled.
C
C$ Files
C
C     See argument HANDLE.
C
C$ Particulars
C
C     See the SPK Required Reading file for a description of the
C     structure of a data type 8 segment.
C
C$ Examples
C
C     The data returned by the SPKRnn routine is in its rawest form,
C     taken directly from the segment.  As such, it will be meaningless
C     to a user unless he/she understands the structure of the data type
C     completely.  Given that understanding, however, the SPKRxx
C     routines might be used to "dump" and check segment data for a
C     particular epoch.
C
C
C     C
C     C     Get a segment applicable to a specified body and epoch.
C     C
C           CALL SPKSFS ( BODY, ET, HANDLE, DESCR, IDENT, FOUND )
C
C     C
C     C     Look at parts of the descriptor.
C     C
C           CALL DAFUS ( DESCR, 2, 6, DCD, ICD )
C           CENTER = ICD( 2 )
C           REF    = ICD( 3 )
C           TYPE   = ICD( 4 )
C
C           IF ( TYPE .EQ. 8 ) THEN
C              CALL SPKR08 ( HANDLE, DESCR, ET, RECORD )
C                  .
C                  .  Look at the RECORD data.
C                  .
C           END IF
C
C$ Restrictions
C
C     1)  Correctness of inputs must be ensured by the caller of
C         this routine.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C
C$ Version
C
C-    SPICELIB Version 2.1.0, 07-SEP-2001 (EDW)
C
C        Replaced DAFRDA call with DAFGDA.
C        Added IMPLICIT NONE.
C
C-    SPICELIB Version 2.0.0, 06-NOV-1999 (NJB)
C
C        Data type check was relaxed to enable reading type 12
C        segments.
C
C-    SPICELIB Version 1.0.1, 24-OCT-1994 (NJB)
C
C        In-line comment concerning transpose of state data was
C        removed.
C
C-    SPICELIB Version 1.0.0, 14-AUG-1993 (NJB)
C
C-&

C$ Index_Entries
C
C     read record from type_8 spk segment
C
C-&

C$ Revisions
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               ODD
      LOGICAL               RETURN

C
C     Local parameters
C
      INTEGER               ND
      PARAMETER           ( ND     = 2 )

      INTEGER               NI
      PARAMETER           ( NI     = 6 )

      INTEGER               STATSZ
      PARAMETER           ( STATSZ = 6 )

      INTEGER               CTRLSZ
      PARAMETER           ( CTRLSZ = 4 )

      INTEGER               STAIDX
      PARAMETER           ( STAIDX = 4 )

C
C     Local variables
C
      DOUBLE PRECISION      CONTRL ( CTRLSZ  )
      DOUBLE PRECISION      DC     ( ND )
      DOUBLE PRECISION      START
      DOUBLE PRECISION      STEP

      INTEGER               BEGIN
      INTEGER               DEGREE
      INTEGER               END
      INTEGER               FIRST
      INTEGER               GRPSIZ
      INTEGER               IC     ( NI )
      INTEGER               LAST
      INTEGER               LOW
      INTEGER               N
      INTEGER               NEAR
      INTEGER               TYPE

C
C     Use discovery check-in.
C
      IF ( RETURN () ) THEN
         RETURN
      END IF

C
C     Unpack the segment descriptor, and get the start and end addresses
C     of the segment.
C
      CALL DAFUS ( DESCR, 2, 6, DC, IC )

      TYPE  = IC( 4 )
      BEGIN = IC( 5 )
      END   = IC( 6 )

C
C     Make sure that this really is a type 8 or type 12 data segment.
C
      IF (  ( TYPE .NE. 08 ) .AND. ( TYPE .NE. 12 )  ) THEN
         CALL CHKIN ( 'SPKR08'                                        )
         CALL SETMSG( 'You are attempting to locate type 8 or type ' //
     .                '12 data in a type # data segment.'             )
         CALL ERRINT( '#',  TYPE                                      )
         CALL SIGERR( 'SPICE(WRONGSPKTYPE)'                           )
         CALL CHKOUT( 'SPKR08'                                        )
         RETURN
      END IF

C
C     Check the request time against the bounds in the segment
C     descriptor.
C
      IF (  ( ET .LT. DC(1) )  .OR.  ( ET .GT. DC(2) )  )  THEN
         CALL CHKIN ( 'SPKR08'                                      )
         CALL SETMSG( 'Request time # is outside of descriptor '   //
     .                'bounds # : #.'                               )
         CALL ERRDP ( '#',  ET                                      )
         CALL ERRDP ( '#',  DC(1)                                   )
         CALL ERRDP ( '#',  DC(2)                                   )
         CALL SIGERR( 'SPICE(TIMEOUTOFBOUNDS)'                      )
         CALL CHKOUT( 'SPKR08'                                      )
         RETURN

      END IF

C
C     The type 8 segment structure is described by this diagram from
C     the SPK Required Reading:
C
C        +-----------------------+
C        | State 1               |
C        +-----------------------+
C        | State 2               |
C        +-----------------------+
C                    .
C                    .
C                    .
C        +-----------------------+
C        | State N               |
C        +-----------------------+
C        | Epoch of state 1 (ET) |
C        +-----------------------+
C        | Step size             |
C        +-----------------------+
C        | Polynomial degree     |
C        +-----------------------+
C        | Number of states      |
C        +-----------------------+
C
C
C     We'll need the last four items before we can determine which
C     states make up our output record.
C
C
      CALL DAFGDA ( HANDLE, END-3, END, CONTRL )

      START   =  CONTRL(1)
      STEP    =  CONTRL(2)
      DEGREE  =  NINT ( CONTRL(3) )
      N       =  NINT ( CONTRL(4) )

      GRPSIZ  =  DEGREE + 1

C
C     We'll now select the set of states that define the interpolating
C     polynomials.  The cases of odd and even GRPSIZ are handled
C     separately.
C
      IF ( ODD(GRPSIZ) ) THEN
C
C        Find the index of the state whose epoch is closest to the
C        input epoch.  Find the first and last indices in the record
C        of the (GRPSIZ-1)/2 states on either side of this central
C        state.
C
         NEAR   =  NINT ( ( ET - START ) / STEP )  +  1

         FIRST  =  MIN (  MAX( 1,  NEAR - (DEGREE/2) ),  N-DEGREE )
         LAST   =  FIRST  +  DEGREE

      ELSE
C
C        Find the index of the last state whose epoch is less than or
C        equal to that of the input epoch.  Find the first and last
C        indices in the record of the set of GRPSIZ consecutive states
C        having this state as the (GRPSIZ/2)th one.
C
         LOW    =  INT ( ( ET - START ) / STEP )  +  1

         FIRST  =  MIN (  MAX( 1,  LOW - DEGREE/2 ),  N-DEGREE )
         LAST   =  FIRST  +  DEGREE

      END IF

C
C     Put the size of the group of states, the epoch of the first
C     state in the record, and the step size into the output record.
C
      RECORD(1) =  GRPSIZ
      RECORD(2) =  START  +  (FIRST-1)*STEP
      RECORD(3) =  STEP

C
C     Read the states.
C
      CALL DAFGDA ( HANDLE,
     .              BEGIN + (FIRST-1)*STATSZ,
     .              BEGIN +      LAST*STATSZ  -  1,
     .              RECORD(STAIDX)                  )

      RETURN
      END