SUBROUTINE translv

!-----------------------------------------------------------------------
!
! Solution driver. Contains the time and outer loops. Calls for outer
! iteration work. Checks convergence and handles eventual output.
!
  !!  write (*,*) 'got past 208'
  !  write (*,*) 'got past 208'
!209 FORMAT( /, 2X, '***UNCONVERGED*** Stopping Iterations!!', /, 2X!, !&
!-----------------------------------------------------------------------

  USE global_module, ONLY: i_knd, r_knd, ounit, zero, half, one, two

  USE plib_module, ONLY: glmax, comm_snap, iproc, root, thread_num,    &
    ichunk, nthreads, nnested

  USE geom_module, ONLY: geom_alloc, geom_dealloc, dinv, param_calc,   &
    nx, ny_gl, nz_gl

  USE sn_module, ONLY: nang, noct, mu, eta, xi, nmom

  USE data_module, ONLY: ng, v, vdelt, mat, sigt, siga, slgg, src_opt, &
    qim

  USE control_module, ONLY: nsteps, timedep, dt, oitm, otrdone,        &
    control_alloc, control_dealloc, dfmxo, it_det, popout, swp_typ

  USE utils_module, ONLY: print_error, stop_run

  USE solvar_module, ONLY: solvar_alloc, ptr_in, ptr_out, t_xs, a_xs,  &
    s_xs, flux0, fluxm

  USE expxs_module, ONLY: expxs_reg

  USE outer_module, ONLY: outer

  USE time_module, ONLY: tslv, wtime, tgrind, tparam

  USE ISO_C_BINDING
  USE analyze_module, ONLY: pop_calc

  IMPLICIT NONE
!_______________________________________________________________________
!
! Local variables
!_______________________________________________________________________

  CHARACTER(LEN=1) :: star='*'

  CHARACTER(LEN=64) :: error

  INTEGER(i_knd) :: cy, otno, ierr, g, l, i, tot_iits, cy_iits, out_iits

  REAL(r_knd) :: sf, time, t1, t2, t3, t4, t5, tmp

  REAL(r_knd), DIMENSION(:,:,:,:,:,:), POINTER :: ptr_tmp
!_______________________________________________________________________
!
! Call for data allocations. Some allocations depend on the problem
! type being requested.
!_______________________________________________________________________

!!    !WRITE (*, *) 'wtiming'
!!    !WRITE (*, *) 'wtiming'
!!    !WRITE (*, *) 'wtiming'
!!    !WRITE (*, *) 'wtiming'
  CALL wtime ( t1 )

  ierr = 0
  error = ' '

  CALL geom_alloc ( nang, ng, swp_typ, ichunk, ierr )
  CALL glmax ( ierr, comm_snap )
  IF ( ierr /= 0 ) THEN
    error = '***ERROR: GEOM_ALLOC: Allocation error of sweep parameters'
!!    !WRITE (*, *) 'geom alloc'
!!    !WRITE (*, *) 'geom alloc'
!!    !WRITE (*, *) 'geom alloc'
!!    !WRITE (*, *) 'geom alloc'
    CALL print_error ( ounit, error )
    CALL stop_run ( 1, 3, 0, 0 )
  END IF

!!    !WRITE (*, *) 'solvar_allocing'
!!    !WRITE (*, *) 'solvar_allocing'
!!    !WRITE (*, *) 'solvar_allocing'
!!    !WRITE (*, *) 'solvar_allocing'
  CALL solvar_alloc ( ierr )
!!  !WRITE (*, *) 'glmaxing'
!!  !WRITE (*, *) 'glmaxing'
!!  !WRITE (*, *) 'glmaxing'
!!  !WRITE (*, *) 'glmaxing'
  CALL glmax ( ierr, comm_snap )
  IF ( ierr /= 0 ) THEN
    error = '***ERROR: SOLVAR_ALLOC: Allocation error of solution ' // &
            'arrays'
    CALL print_error ( ounit, error )
    CALL stop_run ( 1, 3, 1, 0 )
  END IF

!!    !WRITE (*, *) 'control_allocing'
!!    !WRITE (*, *) 'control_allocing'
!!    !WRITE (*, *) 'control_allocing'
!!    !WRITE (*, *) 'control_allocing'
  CALL control_alloc ( ng, ierr )
!!  !WRITE (*, *) 'glmaxing'
!!  !WRITE (*, *) 'glmaxing'
!!  !WRITE (*, *) 'glmaxing'
!!  !WRITE (*, *) 'glmaxing'
  CALL glmax ( ierr, comm_snap )
  IF ( ierr /= 0 ) THEN
    error = '***ERROR: CONTROL_ALLOC: Allocation error of control ' // &
            'arrays'
    CALL print_error ( ounit, error )
    CALL stop_run ( 1, 3, 2, 0 )
  END IF

!!    WRITE (*, *) 'wtiming'
!!    WRITE (*, *) 'wtiming'
!!    WRITE (*, *) 'wtiming'
!!    WRITE (*, *) 'wtiming'
  CALL wtime ( t2 )
  tparam = tparam + t2 - t1
!_______________________________________________________________________
!
! The time loop solves the problem for nsteps. If static, there is
! only one step, and it does not have any time-absorption or -source
! terms. Set the pointers to angular flux arrays. Set time to one for
! static for proper multiplication in octsweep.
!_______________________________________________________________________

  IF ( iproc == root ) THEN
    WRITE( *, 201)     ( star, i = 1, 80 )
    WRITE( ounit, 201) ( star, i = 1, 80 )
  END IF

  tot_iits = 0
!!    WRITE (*, *) 'time_looping'
!!    WRITE (*, *) 'time_looping'
!!    WRITE (*, *) 'time_looping'
!!    WRITE (*, *) 'time_looping'
  time_loop: DO cy = 1, nsteps
!     write (*,*) 'next time step'
!     write (*,*) 'next time step'
    CALL wtime ( t3 )

    vdelt = zero
    time = one
!    write (*,*) 'checking timedep ', timedep
!    write (*,*) 'checking timedep ', timedep
    IF ( timedep == 1 ) THEN
      IF ( iproc == root ) THEN
        WRITE( *, 202 )     ( star, i = 1, 30 ), cy
        WRITE( ounit, 202 ) ( star, i = 1, 30 ), cy
      END IF
      vdelt = two / ( dt * v )
      time = dt * ( REAL( cy, r_knd ) - half )
    END IF

    IF ( cy > 1 ) THEN
      ptr_tmp => ptr_out
      ptr_out => ptr_in
      ptr_in  => ptr_tmp
    END IF
!_______________________________________________________________________
!
!   Prepare some cross sections: total, in-group scattering, absorption.
!   Keep in the time loop for better consistency with PARTISN. Set up
!   geometric sweep parameters. Reset flux moments to zero at start of
!   each time step. Parallelize group loop with threads.
!_______________________________________________________________________

  !$OMP PARALLEL DO SCHEDULE(STATIC,1) NUM_THREADS(nthreads*nnested)   &
  !$OMP& DEFAULT(SHARED) PRIVATE(g,l)
    DO g = 1, ng
      CALL expxs_reg ( siga(:,g), mat, a_xs(:,:,:,g) )
      CALL expxs_reg ( sigt(:,g), mat, t_xs(:,:,:,g) )
      CALL param_calc ( nang, ichunk, mu, eta, xi, t_xs(:,:,:,g),      &
        vdelt(g), dinv(:,:,:,:,:,g) )
      DO l = 1, nmom
        CALL expxs_reg ( slgg(:,l,g,g), mat, s_xs(:,:,:,l,g) )
      END DO
      flux0(:,:,:,g) = zero
      fluxm(:,:,:,:,g) = zero
    END DO
  !$OMP END PARALLEL DO
!_______________________________________________________________________
!
!   Scale the manufactured source for time
!_______________________________________________________________________

    IF ( src_opt == 3 ) THEN
      IF ( cy == 1 ) THEN
        qim = time*qim
      ELSE
        sf = REAL( 2*cy - 1, r_knd ) / REAL( 2*cy-3, r_knd )
        qim = qim*sf
      END IF
    END IF
!_______________________________________________________________________
!
!   Using Jacobi iterations in energy, and the work in the outer loop
!   will be parallelized with threads.
!_______________________________________________________________________
!    write (*, *) 'use jacobi iterations'
!    write (*, *) 'use jacobi iterations'
    otrdone = .FALSE.

    cy_iits = 0

    IF ( iproc==root .AND. it_det==0 ) THEN
      !WRITE( *, 203 )
      WRITE( ounit, 203 )
    END IF

    CALL wtime ( t4 )
    tparam = tparam + t4 - t3
!!    WRITE (*, *) 'outer_looping oitm ', oitm, ' times'
!!    WRITE (*, *) 'outer_looping oitm ', oitm, ' times'
!!    WRITE (*, *) 'outer_looping oitm ', oitm, ' times'
!!    WRITE (*, *) 'outer_looping oitm ', oitm, ' times'
    outer_loop: DO otno = 1, oitm

      IF ( iproc==root .AND. it_det==1 ) THEN
        !WRITE( *, 204 )     ( star, i = 1, 20 ), otno
        WRITE( ounit, 204 ) ( star, i = 1, 20 ), otno
      END IF
!_______________________________________________________________________
!
!     Perform an outer iteration. Add up inners. Check convergence.
!_______________________________________________________________________

      CALL outer ( out_iits )
!      write (*, *) 'outered'
!      write (*, *) 'outered'
      cy_iits = cy_iits + out_iits

      IF ( iproc == root ) THEN
        !WRITE( *, 205 )     otno, dfmxo, out_iits
        WRITE( ounit, 205 ) otno, dfmxo, out_iits
      END IF

      ! XXX: kludge make this portable
      ! why did I put this here?
      !CALL aspace_copy(aspace_id)

!!      WRITE (*,*) 'should finish otrdone', otrdone
!!      WRITE (*,*) 'should finish otrdone', otrdone
!!      WRITE (*,*) 'should finish otrdone', otrdone
!!      WRITE (*,*) 'should finish otrdone', otrdone
      IF ( otrdone ) EXIT outer_loop
!      write (*, *) 'didnt leave outer_loop'
!      write (*, *) 'didnt leave outer_loop'
   END DO outer_loop
!   write (*, *) 'ended outer_loop'
!   write (*, *) 'ended outer_loop'
!_______________________________________________________________________
!
!   Compute and print the particle spectrum every cycle.
!_______________________________________________________________________

    IF ( popout == 2 ) CALL pop_calc ( cy, time )
!_______________________________________________________________________
!
!   Print the time cycle details. Add time cycle iterations.
!_______________________________________________________________________
!!    WRITE (*,*) 'printing time cycle details'
!!    WRITE (*,*) 'printing time cycle details'
!!    WRITE (*,*) 'printing time cycle details'
!!    WRITE (*,*) 'printing time cycle details'

    IF ( iproc == root ) THEN
      IF ( timedep == 1 ) THEN
        IF ( otrdone ) THEN
          WRITE( *, 206 )     cy, time, otno, cy_iits
          WRITE( ounit, 206 ) cy, time, otno, cy_iits
        ELSE
          WRITE( *, 207 )     cy, time, otno, cy_iits
          WRITE( ounit, 207 ) cy, time, otno, cy_iits
        END IF
      ELSE
        IF ( otrdone ) THEN
          WRITE( *, 208 )     otno, cy_iits
          WRITE( ounit, 208 ) otno, cy_iits
        ELSE
          WRITE( *, 209 )     otno, cy_iits
          WRITE( ounit, 209 ) otno, cy_iits
        END IF
      END IF
    END IF

    tot_iits = tot_iits + cy_iits
    CALL publish
  END DO time_loop
!_______________________________________________________________________
!
!   Compute and print the particle spectrum only at end of calc.
!_______________________________________________________________________

    IF ( popout == 1 ) CALL pop_calc ( cy, time )
!_______________________________________________________________________
!
!   Final prints.
!_______________________________________________________________________

  IF ( iproc == root ) THEN
    IF ( timedep == 1 ) THEN
      WRITE( *, 210 )     ( star, i = 1, 30 ), tot_iits
      WRITE( ounit, 210 ) ( star, i = 1, 30 ), tot_iits
    END IF
    WRITE( *, 211 )     ( star, i = 1, 80 )
    WRITE( ounit, 211 ) ( star, i = 1, 80 )
  END IF

  CALL wtime ( t5 )
  tslv = t5 - t1
  tmp = REAL( nx, r_knd ) * REAL( ny_gl, r_knd ) * REAL( nz_gl, r_knd )&
        * REAL( nang, r_knd ) * REAL( noct, r_knd )                    &
        * REAL( tot_iits, r_knd )
!  write (*,*) 'set tmp'
!  write (*,*) 'set tmp'
  tgrind = tslv*1.0E9_r_knd / tmp
!  write (*,*) 'got past grind'
!  write (*,*) 'got past grind'
!_______________________________________________________________________

  201 FORMAT( 10X, 'keyword Iteration Monitor', /, 80A )
  202 FORMAT( /, 1X, 30A, /, 2X, 'Time Cycle ', I3 )
!  write (*,*) 'got past 202'
!  write (*,*) 'got past 202'
  203 FORMAT( 2X, 'Outer' )
!  write (*,*) 'got past 203'
!  write (*,*) 'got past 203'
  204 FORMAT( 1X, 20A, /, 2X, 'Outer ', I3 )
!  write (*,*) 'got past 204'
!  write (*,*) 'got past 204'
  205 FORMAT( 2X, I3, 4X, 'Dfmxo=', ES11.4, 4X, 'No. Inners=', I5 )
!  write (*,*) 'got past 205'
!  write (*,*) 'got past 205'
  206 FORMAT( /, 2X, 'Cycle=', I4, 4X, 'Time=', ES11.4, 4X, 'No. ',    &
              'Outers=', I4, 4X, 'No. Inners=', I5 )
  207 FORMAT( /, 2X, '*WARNING: Unconverged outer iterations', /, 2X,  &
             'Cycle=', I4, 4X, 'Time=', ES11.4, 4X, 'No. Outers=', I4, &
             4X, 'No. Inners=', I5, / )
!  write (*,*) 'got past 207'
!  write (*,*) 'got past 207'
  208 FORMAT( /, 2X, 'No. Outers=', I4, 4X, 'No. Inners=', I5 )
  209 FORMAT( /, 2X, '*WARNING: Unconverged outer iteration!', /, 2X,  &
              'No. Outers=', I4, 4X, 'No. Inners=', I5, / )
!  write (*,*) 'got past 209'
!  write (*,*) 'got past 209'
  210 FORMAT( /, 1X, 30A, /, 2X, 'Total inners for all time steps, '   &
              'outers = ', I6 )
!  write (*,*) 'got past 210'
!  write (*,*) 'got past 210'
  211 FORMAT( /, 80A, / )
!  write (*,*) 'got past 211'
!  write (*,*) 'got past 211'

END SUBROUTINE translv


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE HIDCOR (LINSET, IPSET, NPART, IEDSET, NEDGES,
     &                   LENF, NLNKF, LINKF, XN, YN, ZN,
     *                   MREF, LREF)
C=======================================================================

C   --*** HIDCOR *** (MESH) Hide partial lines by face
C   --   Written by Amy Gilkey - revised 10/22/87
C   --
C   --HIDCOR deletes partial lines that have a visible node as a corner
C   --of a quarilateral and the hidden node is within the area defined
C   --by the vectors from the corner to the two adjacent nodes.  Such
C   --a face totally hides the partial line.
C   --
C   --Parameters:
C   --   LINSET   - IN  - the sorted line set
C   --   IPSET    - I/O - the indices of the partial line set
C   --   NPART    - I/O - the number of lines in the partial line set
C   --   IEDSET   - I/O - the edge line set;
C   --                    (0) = face defining edge; 0 to delete edge
C   --   NEDGES   - I/O - the number of lines in the edge set
C   --   LENF     - IN  - the cumulative face counts by element block
C   --   NLNKF    - IN  - the number of nodes per face
C   --   LINKF    - IN  - the connectivity for all faces
C   --   XN,YN,ZN - IN  - the nodal coordinates
C   --
C   --Common Variables:
C   --   Uses LLNSET of /D3NUMS/

      include 'debug.blk'
      include 'dbnums.blk'
      include 'd3nums.blk'

      INTEGER LINSET(LLNSET,*)
      INTEGER IPSET(*)
      INTEGER IEDSET(0:2,*)
      INTEGER LENF(0:NELBLK)
      INTEGER NLNKF(NELBLK)
      INTEGER LINKF(*)
      REAL XN(*), YN(*), ZN(*)
      INTEGER MREF(*), LREF(*)

      LOGICAL CKCROS

C   --Check each edge line against each partial line for overlap

      NOLDPT = NPART

      call iniint(numnpf, 0, mref)
      call iniint(numnpf, 0, lref)

      do ip=1,npart
        lref(LINSET(1,IPSET(IP))) = ip
        lref(LINSET(2,IPSET(IP))) = ip
      end do

      do ip=npart,1,-1
        mref(LINSET(1,IPSET(IP))) = ip
        mref(LINSET(2,IPSET(IP))) = ip
      end do

      nhid = 0
      DO 120 IEDG = 1, NEDGES
         IFAC = IEDSET(0,IEDG)
         N1 = IEDSET(1,IEDG)
         N2 = IEDSET(2,IEDG)

         imin = max(1, mref(n1), mref(n2))
         imax = min(npart, lref(n1), lref(n2))
         do ip = imin, imax
           if (ipset(ip) .gt. 0) then
C         --Process only if visible node is corner node of face
             IV = LINSET(1,IPSET(IP))
             IF ((N1 .EQ. IV) .OR. (N2 .EQ. IV)) THEN
               IH = LINSET(2,IPSET(IP))
               IF (N2 .EQ. IH) GOTO 110

C            --Check if face hides the visible part of the line
               IELB = 0
               IXL = IDBLNK (IELB, IFAC, LENF, NLNKF)
               IF (CKCROS (IV, IH, NLNKF(IELB), LINKF(IXL),
     &           XN, YN, ZN)) THEN

C               --Move totally hidden lines from partial set to totally
C               --hidden lines
                 ipset(ip) = -ipset(ip)
                 nhid = nhid + 1

               END IF
             END IF
           end if
 110       CONTINUE
         end do
 120  CONTINUE
      if ((cdebug .eq. 'HIDDEN') .and. (idebug .ge. 1))
     &  write (*, '(1x,a,i5)') 'partial lines hidden by face =', nhid

      nhid = 0
      ip = 1
 100  continue
      if (ip .le. npart) then
        if (ipset(ip) .lt. 0) then
          I = -IPSET(IP)
          IPSET(IP) = IPSET(NPART)
          IPSET(NPART) = I
          NPART = NPART - 1
          IP = IP - 1
          nhid = nhid + 1
        end if
        ip = ip + 1
        go to 100
      end if
C   --Delete the edges which are totally hidden lines

      nhid = 0
      DO 140 IP = NPART+1, NOLDPT
         IV = LINSET(1,IPSET(IP))
         IH = LINSET(2,IPSET(IP))
         DO 130 IEDG = 1, NEDGES
            IF (IEDSET(1,IEDG) .EQ. IV) THEN
               IF (IEDSET(2,IEDG) .EQ. IH) THEN
                  IEDSET(0,IEDG) = 0
                  nhid = nhid + 1
                  GOTO 140
               END IF
            END IF
  130    CONTINUE
  140 CONTINUE
      if ((cdebug .eq. 'HIDDEN') .and. (idebug .ge. 1))
     &   write (*, '(1x,a,i5)') 'edges hidden by face =', nhid

      RETURN
      END


!
! NLTECoeff_Define
!
! Module defining the NLTECoeff structure and containing routines to
! manipulate it.
!
!
! CREATION HISTORY:
!       Written by:     Yong Han, 08-05-2010
!                       yong.han@noaa.gov
!
!       Refactored by:  Paul van Delst, 19-Jan-2011
!                       paul.vandelst@noaa.gov
!

MODULE NLTECoeff_Define

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module use
  USE Type_Kinds,            ONLY: Long, Double
  USE Message_Handler      , ONLY: SUCCESS, FAILURE, INFORMATION, Display_Message
  USE Compare_Float_Numbers, ONLY: OPERATOR(.EqualTo.)
  USE Subset_Define        , ONLY: Subset_type      , &
                                   Subset_Associated, &
                                   Subset_GetValue  , &
                                   Subset_Generate
  USE SensorInfo_Parameters, ONLY: INVALID_WMO_SATELLITE_ID, &
                                   INVALID_WMO_SENSOR_ID
  ! Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  ! Everything private by default
  PRIVATE
  ! Datatypes
  PUBLIC :: NLTECoeff_type
  ! Operators
  PUBLIC :: OPERATOR(==)
  ! Procedures
  PUBLIC :: NLTECoeff_Associated
  PUBLIC :: NLTECoeff_Destroy
  PUBLIC :: NLTECoeff_Create
  PUBLIC :: NLTECoeff_Inspect
  PUBLIC :: NLTECoeff_ValidRelease
  PUBLIC :: NLTECoeff_Info
  PUBLIC :: NLTECoeff_DefineVersion
  PUBLIC :: NLTECoeff_Subset
  PUBLIC :: NLTECoeff_Concat
  PUBLIC :: NLTECoeff_ChannelReindex

  ! ---------------------
  ! Procedure overloading
  ! ---------------------
  INTERFACE OPERATOR(==)
    MODULE PROCEDURE NLTECoeff_Equal
  END INTERFACE OPERATOR(==)

  ! -----------------
  ! Module parameters
  ! -----------------
  ! Version Id for the module
  CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = &
  '$Id: NLTECoeff_Define.f90,v 1.1 2013/04/07 22:56:27 jguo Exp $'
  ! Literal constants
  REAL(Double), PARAMETER :: ZERO = 0.0_Double
  REAL(Double), PARAMETER :: ONE  = 1.0_Double
  ! Default message string length
  INTEGER, PARAMETER :: ML = 512
  ! Sensor id string length
  INTEGER, PARAMETER :: SL = 20
  ! Current valid release and version numbers
  INTEGER, PARAMETER :: NLTECOEFF_RELEASE = 2   ! This determines structure and file formats.
  INTEGER, PARAMETER :: NLTECOEFF_VERSION = 1   ! This is just the data version.
  ! Number of layers for which mean temperatures are computed
  INTEGER, PARAMETER :: N_LAYERS = 2
  ! Integer flags corresponding to logical false/true
  INTEGER, PARAMETER :: FALSE = 0
  INTEGER, PARAMETER :: TRUE  = 1

  ! -----------------------
  ! Derived type definition
  ! -----------------------
  TYPE :: NLTECoeff_type
    ! Allocation indicator
    LOGICAL :: Is_Allocated = .FALSE.
    ! Release and version information
    INTEGER(Long) :: Release = NLTECOEFF_RELEASE
    INTEGER(Long) :: Version = NLTECOEFF_VERSION
    ! Dimensions
    INTEGER(Long) :: n_Predictors     = 0  ! n1 dimension
    INTEGER(Long) :: n_Sensor_Angles  = 0  ! n2 dimension
    INTEGER(Long) :: n_Solar_Angles   = 0  ! n3 dimension
    INTEGER(Long) :: n_NLTE_Channels  = 0  ! n4 dimension
    INTEGER(Long) :: n_Channels       = 0  ! n5 dimension
    ! ..."Internal" dimension
    INTEGER(Long) :: n_Layers = N_LAYERS
    ! Sensor info
    CHARACTER(SL)              :: Sensor_Id        = ''
    INTEGER(Long)              :: WMO_Satellite_ID = INVALID_WMO_SATELLITE_ID
    INTEGER(Long)              :: WMO_Sensor_ID    = INVALID_WMO_SENSOR_ID
    INTEGER(Long), ALLOCATABLE :: Sensor_Channel(:)        ! n5
    ! Pressure levels used for computing mean temperatures in the two layers
    REAL(Double) :: Upper_Plevel(N_LAYERS) = ZERO
    REAL(Double) :: Lower_Plevel(N_LAYERS) = ZERO
    ! Min., max. and mean layer temperatures used as the temperature predictor limits
    REAL(Double) :: Min_Tm(N_LAYERS)  = ZERO
    REAL(Double) :: Max_Tm(N_LAYERS)  = ZERO
    REAL(Double) :: Mean_Tm(N_LAYERS) = ZERO
    ! Coefficient table dimension vectors
    REAL(Double) , ALLOCATABLE :: Secant_Sensor_Zenith(:)  ! n2
    REAL(Double) , ALLOCATABLE :: Secant_Solar_Zenith(:)   ! n3
    INTEGER(Long), ALLOCATABLE :: NLTE_Channel(:)          ! n4
    LOGICAL      , ALLOCATABLE :: Is_NLTE_Channel(:)       ! n5
    ! Coefficients for NLTE corrections
    INTEGER(Long), ALLOCATABLE :: C_Index(:)               ! n5
    REAL(Double) , ALLOCATABLE :: C(:,:,:,:)               ! n1 x n2 x n3 x n4
  END TYPE NLTECoeff_type

CONTAINS

!################################################################################
!################################################################################
!##                                                                            ##
!##                         ## PUBLIC MODULE ROUTINES ##                       ##
!##                                                                            ##
!################################################################################
!################################################################################

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       NLTECoeff_Associated
!
! PURPOSE:
!       Elemental function to test the status of the allocatable components
!       of the NLTECoeff structure.
!
! CALLING SEQUENCE:
!       Status = NLTECoeff_Associated( NLTECoeff )
!
! OBJECTS:
!       NLTECoeff:  Structure which is to have its member's
!                   status tested.
!                   UNITS:      N/A
!                   TYPE:       NLTECoeff_type
!                   DIMENSION:  Scalar or any rank
!                   ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
!       Status:     The return value is a logical value indicating the
!                   status of the NLTE members.
!                    .TRUE.  - if ANY of the NLTECoeff allocatable members
!                              are in use.
!                    .FALSE. - if ALL of the NLTECoeff allocatable members
!                              are not in use.
!                   UNITS:      N/A
!                   TYPE:       LOGICAL
!                   DIMENSION:  Same as input
!
!:sdoc-:
!--------------------------------------------------------------------------------

  ELEMENTAL FUNCTION NLTECoeff_Associated( NLTECoeff ) RESULT( Status )
    TYPE(NLTECoeff_type), INTENT(IN) :: NLTECoeff
    LOGICAL :: Status
    Status = NLTECoeff%Is_Allocated
  END FUNCTION NLTECoeff_Associated

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       NLTECoeff_Destroy
!
! PURPOSE:
!       Elemental subroutine to re-initialize NLTECoeff objects.
!
! CALLING SEQUENCE:
!       CALL NLTECoeff_Destroy( NLTECoeff )
!
! OBJECTS:
!       NLTECoeff:    Re-initialized NLTECoeff structure.
!                     UNITS:      N/A
!                     TYPE:       NLTECoeff_type
!                     DIMENSION:  Scalar or any rank
!                     ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE NLTECoeff_Destroy( NLTECoeff )
    TYPE(NLTECoeff_type), INTENT(OUT) :: NLTECoeff
    NLTECoeff%Is_Allocated = .FALSE.
    NLTECoeff%n_Predictors     = 0
    NLTECoeff%n_Sensor_Angles  = 0
    NLTECoeff%n_Solar_Angles   = 0
    NLTECoeff%n_NLTE_Channels  = 0
    NLTECoeff%n_Channels       = 0
    NLTECoeff%Sensor_Id        = ''
    NLTECoeff%WMO_Satellite_ID = INVALID_WMO_SATELLITE_ID
    NLTECoeff%WMO_Sensor_ID    = INVALID_WMO_SENSOR_ID
  END SUBROUTINE NLTECoeff_Destroy

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       NLTECoeff_Create
!
! PURPOSE:
!       Elemental subroutine to create an instance of an NLTECoeff object.
!
! CALLING SEQUENCE:
!       CALL NLTECoeff_Create( NLTECoeff       , &
!                              n_Predictors    , &
!                              n_Sensor_Angles , &
!                              n_Solar_Angles  , &
!                              n_NLTE_Channels , &
!                              n_Channels        )
!
! OBJECTS:
!       NLTECoeff:          NLTECoeff object structure.
!                           UNITS:      N/A
!                           TYPE:       NLTECoeff_type
!                           DIMENSION:  Scalar or any rank
!                           ATTRIBUTES: INTENT(OUT)
!
! INPUTS:
!       n_Predictors:       Number of predictors used in NLTE correction algorithm.
!                           Must be > 0.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Same as the NLTECoeff object
!                           ATTRIBUTES: INTENT(IN)
!
!       n_Sensor_Angles:    Number of sensor zenith angles.
!                           Must be > 0.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Same as the NLTECoeff object
!                           ATTRIBUTES: INTENT(IN)
!
!       n_Solar_Angles:     Number of solar zenith angles.
!                           Must be > 0.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Same as the NLTECoeff object
!                           ATTRIBUTES: INTENT(IN)
!
!       n_NLTE_Channels:    Number of NLTE channels for the sensor.
!                           Must be > 0.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Same as the NLTECoeff object
!                           ATTRIBUTES: INTENT(IN)
!
!        n_Channels:        Total number of channels for the sensor.
!                           Must be >= n_NLTE_Channels.
!                           UNITS:      N/A
!                           TYPE:       INTEGER
!                           DIMENSION:  Same as NLTECoeff object
!                           ATTRIBUTES: INTENT(IN)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE NLTECoeff_Create( &
    NLTECoeff       , &  ! Output
    n_Predictors    , &  ! Input
    n_Sensor_Angles , &  ! Input
    n_Solar_Angles  , &  ! Input
    n_NLTE_Channels , &  ! Input
    n_Channels        )  ! Input
    ! Arguments
    TYPE(NLTECoeff_type), INTENT(OUT) :: NLTECoeff
    INTEGER             , INTENT(IN)  :: n_Predictors
    INTEGER             , INTENT(IN)  :: n_Sensor_Angles
    INTEGER             , INTENT(IN)  :: n_Solar_Angles
    INTEGER             , INTENT(IN)  :: n_NLTE_Channels
    INTEGER             , INTENT(IN)  :: n_Channels
    ! Local variables
    INTEGER :: alloc_stat

    ! Check input
    IF ( n_Predictors    < 1 .OR. &
         n_Sensor_Angles < 1 .OR. &
         n_Solar_Angles  < 1 .OR. &
         n_NLTE_Channels < 1 .OR. &
         n_Channels < n_NLTE_Channels ) RETURN

    ! Perform the allocation
    ALLOCATE( NLTECoeff%Sensor_Channel( n_Channels ), &
              NLTECoeff%Secant_Sensor_Zenith( n_Sensor_Angles ), &
              NLTECoeff%Secant_Solar_Zenith( n_Solar_Angles ), &
              NLTECoeff%NLTE_Channel( n_NLTE_Channels ), &
              NLTECoeff%Is_NLTE_Channel( n_Channels ), &
              NLTECoeff%C_Index( n_Channels ), &
              NLTECoeff%C( n_Predictors, n_Sensor_Angles, n_Solar_Angles, n_NLTE_Channels ), &
              STAT = alloc_stat )
    IF ( alloc_stat /= 0 ) RETURN

    ! Initialise
    ! ...Dimensions
    NLTECoeff%n_Predictors    = n_Predictors
    NLTECoeff%n_Sensor_Angles = n_Sensor_Angles
    NLTECoeff%n_Solar_Angles  = n_Solar_Angles
    NLTECoeff%n_NLTE_Channels = n_NLTE_Channels
    NLTECoeff%n_Channels      = n_Channels
    ! ...Arrays
    NLTECoeff%Sensor_Channel       = 0
    NLTECoeff%Secant_Sensor_Zenith = ZERO
    NLTECoeff%Secant_Solar_Zenith  = ZERO
    NLTECoeff%NLTE_Channel         = 0
    NLTECoeff%Is_NLTE_Channel      = .FALSE.
    NLTECoeff%C_Index              = 0
    NLTECoeff%C                    = ZERO

    ! Set allocation indicator
    NLTECoeff%Is_Allocated = .TRUE.

  END SUBROUTINE NLTECoeff_Create

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       NLTECoeff_Inspect
!
! PURPOSE:
!       Subroutine to print the contents of a NLTECoeff object to stdout.
!
! CALLING SEQUENCE:
!       CALL NLTECoeff_Inspect( NLTECoeff )
!
! OBJECTS:
!       NLTECoeff:     NLTECoeff object to display.
!                      UNITS:      N/A
!                      TYPE:       NLTECoeff_type
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE NLTECoeff_Inspect( NLTECoeff )
    TYPE(NLTECoeff_type), INTENT(IN) :: NLTECoeff
    INTEGER :: i
    CHARACTER(3) :: maybe
    WRITE(*,'(1x,"NLTECoeff OBJECT")')
    ! Release/version info
    WRITE(*,'(3x,"Release.Version  :",1x,i0,".",i0)') NLTECoeff%Release, NLTECoeff%Version
    ! Dimensions
    WRITE(*,'(3x,"n_Predictors     :",1x,i0)') NLTECoeff%n_Predictors
    WRITE(*,'(3x,"n_Sensor_Angles  :",1x,i0)') NLTECoeff%n_Sensor_Angles
    WRITE(*,'(3x,"n_Solar_Angles   :",1x,i0)') NLTECoeff%n_Solar_Angles
    WRITE(*,'(3x,"n_NLTE_Channels  :",1x,i0)') NLTECoeff%n_NLTE_Channels
    WRITE(*,'(3x,"n_Channels       :",1x,i0)') NLTECoeff%n_Channels
    IF ( .NOT. NLTECoeff_Associated(NLTECoeff) ) RETURN
    ! Sensor info
    WRITE(*,'(3x,"Sensor_Id        :",1x,a )') TRIM(NLTECoeff%Sensor_Id)
    WRITE(*,'(3x,"WMO_Satellite_ID :",1x,i0)') NLTECoeff%WMO_Satellite_ID
    WRITE(*,'(3x,"WMO_Sensor_ID    :",1x,i0)') NLTECoeff%WMO_Sensor_ID
    WRITE(*,'(3x,"Sensor_Channel   :")')
    WRITE(*,'(10(1x,i5,:))') NLTECoeff%Sensor_Channel
    ! Pressure arrays
    WRITE(*,'(3x,"Upper_Plevel :")')
    WRITE(*,'(5(1x,es13.6,:))') NLTECoeff%Upper_Plevel
    WRITE(*,'(3x,"Lower_Plevel :")')
    WRITE(*,'(5(1x,es13.6,:))') NLTECoeff%Lower_Plevel
    ! Temperature arrays
    WRITE(*,'(3x,"Min_Tm  :")')
    WRITE(*,'(5(1x,es13.6,:))') NLTECoeff%Min_Tm
    WRITE(*,'(3x,"Max_Tm  :")')
    WRITE(*,'(5(1x,es13.6,:))') NLTECoeff%Max_Tm
    WRITE(*,'(3x,"Mean_Tm :")')
    WRITE(*,'(5(1x,es13.6,:))') NLTECoeff%Mean_Tm
    ! Coefficient table dimension vectors
    WRITE(*,'(3x,"Secant_Sensor_Zenith :")')
    WRITE(*,'(5(1x,es13.6,:))') NLTECoeff%Secant_Sensor_Zenith
    WRITE(*,'(3x,"Secant_Solar_Zenith  :")')
    WRITE(*,'(5(1x,es13.6,:))') NLTECoeff%Secant_Solar_Zenith
    WRITE(*,'(3x,"NLTE_Channel         :")')
    WRITE(*,'(10(1x,i5,:))') NLTECoeff%NLTE_Channel
    ! NLTE channel flag
    WRITE(*,'(3x,"NLTE_Channel_Flag :")')
    DO i = 1, NLTECoeff%n_Channels
      IF ( MOD(i,5) == 0 .OR. i == NLTECoeff%n_Channels ) THEN
        maybe = 'yes'
      ELSE
        maybe = 'no'
      END IF
      WRITE(*,FMT='(1x,i5,":",l1,", c-index: ",i0)',ADVANCE=maybe) NLTECoeff%Sensor_Channel(i), &
                                                                   NLTECoeff%Is_NLTE_Channel(i), &
                                                                   NLTECoeff%C_Index(i)
    END DO
    ! Coefficient data
    WRITE(*,'(3x,"NLTE correction coefficients :")')
    WRITE(*,'(5(1x,es13.6,:))') NLTECoeff%C
  END SUBROUTINE NLTECoeff_Inspect

!----------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       NLTECoeff_ValidRelease
!
! PURPOSE:
!       Function to check the NLTECoeff Release value.
!
! CALLING SEQUENCE:
!       IsValid = NLTECoeff_ValidRelease( NLTECoeff )
!
! INPUTS:
!       NLTECoeff:     NLTECoeff object for which the Release component
!                      is to be checked.
!                      UNITS:      N/A
!                      TYPE:       NLTECoeff_type
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
!       IsValid:       Logical value defining the release validity.
!                      UNITS:      N/A
!                      TYPE:       LOGICAL
!                      DIMENSION:  Scalar
!
!:sdoc-:
!----------------------------------------------------------------------------------

  FUNCTION NLTECoeff_ValidRelease( NLTECoeff ) RESULT( IsValid )
    ! Arguments
    TYPE(NLTECoeff_type), INTENT(IN) :: NLTECoeff
    ! Function result
    LOGICAL :: IsValid
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'NLTECoeff_ValidRelease'
    ! Local variables
    CHARACTER(ML) :: msg

    ! Set up
    IsValid = .TRUE.

    ! Check release is not too old
    IF ( NLTECoeff%Release < NLTECOEFF_RELEASE ) THEN
      IsValid = .FALSE.
      WRITE( msg,'("A NLTECoeff data update is needed. ", &
                  &"NLTECoeff release is ",i0,". Valid release is ",i0,"." )' ) &
                  NLTECoeff%Release, NLTECOEFF_RELEASE
      CALL Display_Message( ROUTINE_NAME, msg, INFORMATION )
      RETURN
    END IF

    ! Check release is not too new
    IF ( NLTECoeff%Release > NLTECOEFF_RELEASE ) THEN
      IsValid = .FALSE.
      WRITE( msg,'("A NLTECoeff software update is needed. ", &
                  &"NLTECoeff release is ",i0,". Valid release is ",i0,"." )' ) &
                  NLTECoeff%Release, NLTECOEFF_RELEASE
      CALL Display_Message( ROUTINE_NAME, msg, INFORMATION )
      RETURN
    END IF

  END FUNCTION NLTECoeff_ValidRelease

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       NLTECoeff_Info
!
! PURPOSE:
!       Subroutine to return a string containing version and dimension
!       information about a NLTECoeff object.
!
! CALLING SEQUENCE:
!       CALL NLTECoeff_Info( NLTECoeff, Info )
!
! OBJECTS:
!       NLTECoeff:     NLTECoeff object about which info is required.
!                      UNITS:      N/A
!                      TYPE:       NLTECoeff_type
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Info:          String containing version and dimension information
!                      about the NLTECoeff object.
!                      UNITS:      N/A
!                      TYPE:       CHARACTER(*)
!                      DIMENSION:  Scalar
!                      ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE NLTECoeff_Info( NLTECoeff, Info )
    ! Arguments
    TYPE(NLTECoeff_type), INTENT(IN)  :: NLTECoeff
    CHARACTER(*),         INTENT(OUT) :: Info
    ! Parameters
    INTEGER, PARAMETER :: CARRIAGE_RETURN = 13
    INTEGER, PARAMETER :: LINEFEED = 10
    ! Local variables
    CHARACTER(2000) :: Long_String

    ! Write the required data to the local string
    WRITE( Long_String, &
           '(a,1x,"NLTECoeff RELEASE.VERSION: ",i2,".",i2.2,a,3x, &
           &"N_PREDICTORS=",i0,2x,&
           &"N_SENSOR_ANGLES=",i0,2x,&
           &"N_SOLAR_ANGLES=",i0,2x,&
           &"N_NLTE_CHANNELS=",i0,2x,&
           &"N_CHANNELS=",i0 )' ) &
           ACHAR(CARRIAGE_RETURN)//ACHAR(LINEFEED), &
           NLTECoeff%Release, NLTECoeff%Version, &
           ACHAR(CARRIAGE_RETURN)//ACHAR(LINEFEED), &
           NLTECoeff%n_Predictors    , &
           NLTECoeff%n_Sensor_Angles , &
           NLTECoeff%n_Solar_Angles  , &
           NLTECoeff%n_NLTE_Channels , &
           NLTECoeff%n_Channels

    ! Trim the output based on the
    ! dummy argument string length
    Info = Long_String(1:MIN(LEN(Info), LEN_TRIM(Long_String)))

  END SUBROUTINE NLTECoeff_Info

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       NLTECoeff_DefineVersion
!
! PURPOSE:
!       Subroutine to return the module version information.
!
! CALLING SEQUENCE:
!       CALL NLTECoeff_DefineVersion( Id )
!
! OUTPUTS:
!       Id:    Character string containing the version Id information
!              for the module.
!              UNITS:      N/A
!              TYPE:       CHARACTER(*)
!              DIMENSION:  Scalar
!              ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE NLTECoeff_DefineVersion( Id )
    CHARACTER(*), INTENT(OUT) :: Id
    Id = MODULE_VERSION_ID
  END SUBROUTINE NLTECoeff_DefineVersion

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       NLTECoeff_Subset
!
! PURPOSE:
!       Subroutine to return a channel subset of the input NLTECoeff object.
!
! CALLING SEQUENCE:
!       CALL NLTECoeff_Subset( NLTECoeff, Subset, NC_Subset )
!
! OBJECTS:
!       NLTECoeff:      NLTECoeff object which is to be subsetted.
!                     UNITS:      N/A
!                     TYPE:       NLTECoeff_type
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: INTENT(IN)
!
! INPUTS:
!       Subset:       Subset object containing the list of indices
!                     corresponding the channels to be extracted.
!                     UNITS:      N/A
!                     TYPE:       Subset_type
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       NC_Subset:    NLTECoeff object containing the requested channel subset
!                     of the input NLTECoeff data.
!                     UNITS:      N/A
!                     TYPE:       NLTECoeff_type
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: INTENT(OUT)
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE NLTECoeff_Subset( &
    NLTECoeff     , &  ! Input
    Sensor_Channel, &  ! Input
    NC_Subset       )  ! Output
    ! Arguments
    TYPE(NLTECoeff_type), INTENT(IN)  :: NLTECoeff
    INTEGER             , INTENT(IN)  :: Sensor_Channel(:)
    TYPE(NLTECoeff_type), INTENT(OUT) :: NC_Subset
    ! Local variables
    TYPE(Subset_type) :: subset, nlte_subset
    INTEGER :: n_subset_channels, n_nlte_subset_channels
    INTEGER, ALLOCATABLE :: idx(:), nlte_idx(:)

    ! Check input is valid
    IF ( .NOT. NLTECoeff_Associated(NLTECoeff) ) RETURN

    ! Generate the channel subset list
    CALL Subset_Generate( &
           subset, &
           NLTECoeff%Sensor_Channel, &
           Sensor_Channel )
    IF ( .NOT. Subset_Associated( subset ) ) RETURN
    ! ...Generate the NLTE channel subset list
    ! ...(which is itself a subset of the sensor channel list)
    CALL Subset_Generate( &
           nlte_subset, &
           NLTECoeff%NLTE_Channel, &
           Sensor_Channel )
    IF ( .NOT. Subset_Associated( nlte_subset ) ) RETURN

    ! Allocate the output subset NLTECoeff object
    CALL Subset_GetValue( subset     , n_Values = n_subset_channels     , Index = idx )
    CALL Subset_GetValue( nlte_subset, n_Values = n_nlte_subset_channels, Index = nlte_idx )
    CALL NLTECoeff_Create( &
           NC_Subset                , &
           NLTECoeff%n_Predictors   , &
           NLTECoeff%n_Sensor_Angles, &
           NLTECoeff%n_Solar_Angles , &
           n_nlte_subset_channels   , &
           n_subset_channels          )
    IF ( .NOT. NLTECoeff_Associated(NC_Subset) ) RETURN

    ! Extract out the subset channels
    ! ...First assign the non-channel dependent data
    NC_Subset%Version              = NLTECoeff%Version
    NC_Subset%Sensor_Id            = NLTECoeff%Sensor_Id
    NC_Subset%WMO_Satellite_ID     = NLTECoeff%WMO_Satellite_ID
    NC_Subset%WMO_Sensor_ID        = NLTECoeff%WMO_Sensor_ID
    NC_Subset%Upper_Plevel         = NLTECoeff%Upper_Plevel
    NC_Subset%Lower_Plevel         = NLTECoeff%Lower_Plevel
    NC_Subset%Min_Tm               = NLTECoeff%Min_Tm
    NC_Subset%Max_Tm               = NLTECoeff%Max_Tm
    NC_Subset%Mean_Tm              = NLTECoeff%Mean_Tm
    NC_Subset%Secant_Sensor_Zenith = NLTECoeff%Secant_Sensor_Zenith
    NC_Subset%Secant_Solar_Zenith  = NLTECoeff%Secant_Solar_Zenith
    ! ...and now extract the subset
    NC_Subset%Sensor_Channel  = NLTECoeff%Sensor_Channel(idx)
    NC_Subset%NLTE_Channel    = NLTECoeff%NLTE_Channel(nlte_idx)
    NC_Subset%Is_NLTE_Channel = NLTECoeff%Is_NLTE_Channel(idx)
    NC_Subset%C_Index         = NLTECoeff%C_Index(idx)
    NC_Subset%C               = NLTECoeff%C(:,:,:,nlte_idx)
    ! ...Reindex the correction coefficient index array
    CALL NLTECoeff_Reindex( NC_Subset )

  END SUBROUTINE NLTECoeff_Subset

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       NLTECoeff_Concat
!
! PURPOSE:
!       Subroutine to concatenate multiple NLTECoeff objects along the channel
!       dimension into a single NLTECoeff object.
!
! CALLING SEQUENCE:
!       CALL NLTECoeff_Concat( NLTECoeff, NC_Array, Sensor_Id=Sensor_Id )
!
! OBJECTS:
!       NLTECoeff:    NLTECoeff object containing the concatenated result.
!                     UNITS:      N/A
!                     TYPE:       NLTECoeff_type
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: INTENT(OUT)
!
! INPUTS:
!       NC_Array:     Array of NLTECoeff objects to be concatenated.
!                     UNITS:      N/A
!                     TYPE:       NLTECoeff_type
!                     DIMENSION:  Rank-1
!                     ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUTS:
!       Sensor_Id:    Sensor id character to string to use for the concatenated
!                     result. If not specified, the sensor id of the first valid
!                     element of NC_Array is used.
!                     UNITS:      N/A
!                     TYPE:       CHARACTER(*)
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: INTENT(IN), OPTIONAL
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE NLTECoeff_Concat( &
    NLTECoeff, &  ! Output
    NC_Array , &  ! Input
    Sensor_Id  )  ! Optional input
    ! Arguments
    TYPE(NLTECoeff_type)  , INTENT(OUT) :: NLTECoeff
    TYPE(NLTECoeff_type)  , INTENT(IN)  :: NC_Array(:)
    CHARACTER(*), OPTIONAL, INTENT(IN)  :: Sensor_Id
    ! Local variables
    INTEGER, ALLOCATABLE :: valid_index(:)
    INTEGER :: i, j, n_nc, n_valid, n_channels, n_nlte_channels
    INTEGER :: ch1, ch2, nlte_ch1, nlte_ch2

    ! Set up
    ! ...Check input is valid
    n_nc = SIZE(NC_Array)
    IF ( n_nc < 1 ) RETURN
    ! ...Count valid input
    n_valid = COUNT(NLTECoeff_Associated(NC_Array))
    IF ( n_valid == 0 ) RETURN
    ! ...Index the valid input
    ALLOCATE( valid_index(n_valid) )
    valid_index = PACK( (/(i,i=1,n_nc)/), MASK=NLTECoeff_Associated(NC_Array) )
    ! ...Check non-channel dimensions and ids
    DO j = 1, n_valid
      i = valid_index(j)
      IF ( NC_Array(i)%n_Predictors     /= NC_Array(valid_index(1))%n_Predictors     .OR. &
           NC_Array(i)%n_Sensor_Angles  /= NC_Array(valid_index(1))%n_Sensor_Angles  .OR. &
           NC_Array(i)%n_Solar_Angles   /= NC_Array(valid_index(1))%n_Solar_Angles   .OR. &
           NC_Array(i)%WMO_Satellite_ID /= NC_Array(valid_index(1))%WMO_Satellite_ID .OR. &
           NC_Array(i)%WMO_Sensor_ID    /= NC_Array(valid_index(1))%WMO_Sensor_ID         ) THEN
        RETURN
      END IF
    END DO

    ! Sum channel dimensions
    n_nlte_channels = SUM(NC_Array(valid_index)%n_NLTE_Channels)
    n_channels      = SUM(NC_Array(valid_index)%n_Channels)

    ! Allocate the output concatenated NLTECoeff object
    CALL NLTECoeff_Create( &
           NLTECoeff                  , &
           NC_Array(valid_index(1))%n_Predictors   , &
           NC_Array(valid_index(1))%n_Sensor_Angles, &
           NC_Array(valid_index(1))%n_Solar_Angles , &
           n_nlte_channels            , &
           n_channels                   )
    IF ( .NOT. NLTECoeff_Associated(NLTECoeff) ) RETURN

    ! Concatenate the channel data
    ! ...First assign the non-channel dependent data
    NLTECoeff%Version = NC_Array(valid_index(1))%Version
    IF ( PRESENT(Sensor_Id) ) THEN
      NLTECoeff%Sensor_Id = ADJUSTL(Sensor_Id)
    ELSE
      NLTECoeff%Sensor_Id = NC_Array(valid_index(1))%Sensor_Id
    END IF
    NLTECoeff%WMO_Satellite_ID     = NC_Array(valid_index(1))%WMO_Satellite_ID
    NLTECoeff%WMO_Sensor_ID        = NC_Array(valid_index(1))%WMO_Sensor_ID
    NLTECoeff%Upper_Plevel         = NC_Array(valid_index(1))%Upper_Plevel
    NLTECoeff%Lower_Plevel         = NC_Array(valid_index(1))%Lower_Plevel
    NLTECoeff%Min_Tm               = NC_Array(valid_index(1))%Min_Tm
    NLTECoeff%Max_Tm               = NC_Array(valid_index(1))%Max_Tm
    NLTECoeff%Mean_Tm              = NC_Array(valid_index(1))%Mean_Tm
    NLTECoeff%Secant_Sensor_Zenith = NC_Array(valid_index(1))%Secant_Sensor_Zenith
    NLTECoeff%Secant_Solar_Zenith  = NC_Array(valid_index(1))%Secant_Solar_Zenith
    ! ...and now concatenate the channel data
    ch1      = 1
    nlte_ch1 = 1
    DO j = 1, n_valid
      i = valid_index(j)

      nlte_ch2 = nlte_ch1 + NC_Array(i)%n_NLTE_Channels - 1
      ch2      = ch1      + NC_Array(i)%n_Channels      - 1

      NLTECoeff%Sensor_Channel(ch1:ch2)         = NC_Array(i)%Sensor_Channel
      NLTECoeff%NLTE_Channel(nlte_ch1:nlte_ch2) = NC_Array(i)%NLTE_Channel
      NLTECoeff%Is_NLTE_Channel(ch1:ch2)        = NC_Array(i)%Is_NLTE_Channel
      NLTECoeff%C_Index(ch1:ch2)                = NC_Array(i)%C_Index
      NLTECoeff%C(:,:,:,nlte_ch1:nlte_ch2)      = NC_Array(i)%C

      nlte_ch1 = nlte_ch2 + 1
      ch1      = ch2      + 1
    END DO
    ! ...Reindex the correction coefficient index array
    CALL NLTECoeff_Reindex( NLTECoeff )

    ! Cleanup
    DEALLOCATE( valid_index )

  END SUBROUTINE NLTECoeff_Concat

!--------------------------------------------------------------------------------
!:sdoc+:
!
! NAME:
!       NLTECoeff_ChannelReindex
!
! PURPOSE:
!       Subroutine to re-index an NLTECoeff object for a different complete
!       channel set.
!
! CALLING SEQUENCE:
!       CALL NLTECoeff_ChannelReindex( NLTECoeff, Sensor_Channels )
!
! OBJECTS:
!       NLTECoeff:      NLTECoeff object to have its channel information reindexed.
!                       UNITS:      N/A
!                       TYPE:       NLTECoeff_type
!                       DIMENSION:  Scalar
!                       ATTRIBUTES: INTENT(IN OUT)
!
! INPUTS:
!       Sensor_Channel: Array of channel numbers for which the NLTECoeff object
!                       is to be re-indexed against.
!                       UNITS:      N/A
!                       TYPE:       INTEGER
!                       DIMENSION:  Rank-1
!                       ATTRIBUTES: INTENT(IN)
!
! COMMENTS:
!       If there is a mismatch between the channel sets, e.g. total number of
!       sensor channels is less than the number of NLTE channels, or if ANY of
!       the NLTE channels are NOT in the sensor channel list, no reindexing is
!       performed and the input structure is returned with no changes.
!
!:sdoc-:
!--------------------------------------------------------------------------------

  SUBROUTINE NLTECoeff_ChannelReindex( NLTECoeff, Sensor_Channel )
    ! Arguments
    TYPE(NLTECoeff_type), INTENT(IN OUT) :: NLTECoeff
    INTEGER             , INTENT(IN)     :: Sensor_Channel(:)
    ! Local variables
    TYPE(NLTECoeff_type) :: nc_copy
    INTEGER :: i, i_nlte
    INTEGER :: n_channels, n_nlte_channels

    ! Setup
    IF ( .NOT. NLTECoeff_Associated(NLTECoeff) ) RETURN
    n_channels = SIZE(Sensor_Channel)
    IF ( n_channels < 1 ) RETURN
    IF ( n_channels < NLTECoeff%n_NLTE_Channels ) RETURN

    ! Copy the input structure
    nc_copy = NLTECoeff

    ! Allocate the reindexed NLTECoeff object
    CALL NLTECoeff_Create( &
           NLTECoeff              , &
           nc_copy%n_Predictors   , &
           nc_copy%n_Sensor_Angles, &
           nc_copy%n_Solar_Angles , &
           nc_copy%n_NLTE_Channels, &
           n_channels               )
    IF ( .NOT. NLTECoeff_Associated(NLTECoeff) ) RETURN

    ! Fill the new structure
    ! ...Copy over the non-channel related information
    NLTECoeff%Version              = nc_copy%Version
    NLTECoeff%Sensor_Id            = nc_copy%Sensor_Id
    NLTECoeff%WMO_Satellite_ID     = nc_copy%WMO_Satellite_ID
    NLTECoeff%WMO_Sensor_ID        = nc_copy%WMO_Sensor_ID
    NLTECoeff%Upper_Plevel         = nc_copy%Upper_Plevel
    NLTECoeff%Lower_Plevel         = nc_copy%Lower_Plevel
    NLTECoeff%Min_Tm               = nc_copy%Min_Tm
    NLTECoeff%Max_Tm               = nc_copy%Max_Tm
    NLTECoeff%Mean_Tm              = nc_copy%Mean_Tm
    NLTECoeff%Secant_Sensor_Zenith = nc_copy%Secant_Sensor_Zenith
    NLTECoeff%Secant_Solar_Zenith  = nc_copy%Secant_Solar_Zenith
    ! ...Copy over the NLTE channel related information
    NLTECoeff%NLTE_Channel = nc_copy%NLTE_Channel
    NLTECoeff%C            = nc_copy%C
    ! ...Copy over the all-channel related information
    NLTECoeff%Sensor_Channel = Sensor_Channel

    ! Perform the channel reindexing
    i_nlte = 1
    Reindex_Loop: DO i = 1, n_channels
      IF ( NLTECoeff%Sensor_Channel(i) == NLTECoeff%NLTE_Channel(i_nlte) ) THEN
        NLTECoeff%Is_NLTE_Channel(i) = .TRUE.
        NLTECoeff%C_Index(i)         = i_nlte
        i_nlte = i_nlte + 1
        IF (i_nlte > NLTECoeff%n_NLTE_Channels) EXIT Reindex_Loop
      END IF
    END DO Reindex_Loop
    ! ...Unless ALL the NLTE channel were reindexed, restore the original structure
    n_nlte_channels = i_nlte - 1
    IF ( n_nlte_channels /= NLTECoeff%n_NLTE_Channels ) NLTECoeff = nc_copy

    ! Clean up
    CALL NLTECoeff_Destroy(nc_copy)

  END SUBROUTINE NLTECoeff_ChannelReindex

!##################################################################################
!##################################################################################
!##                                                                              ##
!##                          ## PRIVATE MODULE ROUTINES ##                       ##
!##                                                                              ##
!##################################################################################
!##################################################################################

!------------------------------------------------------------------------------
!
! NAME:
!       NLTECoeff_Equal
!
! PURPOSE:
!       Elemental function to test the equality of two NLTECoeff objects.
!       Used in OPERATOR(==) interface block.
!
! CALLING SEQUENCE:
!       is_equal = NLTECoeff_Equal( x, y )
!
!         or
!
!       IF ( x == y ) THEN
!         ...
!       END IF
!
! OBJECTS:
!       x, y:          Two NLTECoeff objects to be compared.
!                      UNITS:      N/A
!                      TYPE:       NLTECoeff_type
!                      DIMENSION:  Scalar or any rank
!                      ATTRIBUTES: INTENT(IN)
!
! FUNCTION RESULT:
!       is_equal:      Logical value indicating whether the inputs are equal.
!                      UNITS:      N/A
!                      TYPE:       LOGICAL
!                      DIMENSION:  Same as inputs.
!
!------------------------------------------------------------------------------

  ELEMENTAL FUNCTION NLTECoeff_Equal( x, y ) RESULT( is_equal )
    TYPE(NLTECoeff_type), INTENT(IN)  :: x, y
    LOGICAL :: is_equal

    ! Set up
    is_equal = .FALSE.

    ! Check the object association status
    IF ( (.NOT. NLTECoeff_Associated(x)) .OR. &
         (.NOT. NLTECoeff_Associated(y))      ) RETURN

    ! Check contents
    ! ...Release/version info
    IF ( (x%Release /= y%Release) .OR. &
         (x%Version /= y%Version) ) RETURN
    ! ...Dimensions
    IF ( (x%n_Predictors     /= y%n_Predictors    ) .OR. &
         (x%n_Sensor_Angles  /= y%n_Sensor_Angles ) .OR. &
         (x%n_Solar_Angles   /= y%n_Solar_Angles  ) .OR. &
         (x%n_NLTE_Channels  /= y%n_NLTE_Channels ) .OR. &
         (x%n_Channels       /= y%n_Channels      ) ) RETURN
    ! ...Scalars
    IF ( (x%Sensor_Id        /= y%Sensor_Id       ) .OR. &
         (x%WMO_Satellite_ID /= y%WMO_Satellite_ID) .OR. &
         (x%WMO_Sensor_ID    /= y%WMO_Sensor_ID   ) ) RETURN
    ! ...Arrays
    IF ( ALL(x%Sensor_Channel           ==    y%Sensor_Channel      ) .AND. &
         ALL(x%Upper_Plevel         .EqualTo. y%Upper_Plevel        ) .AND. &
         ALL(x%Lower_Plevel         .EqualTo. y%Lower_Plevel        ) .AND. &
         ALL(x%Min_Tm               .EqualTo. y%Min_Tm              ) .AND. &
         ALL(x%Max_Tm               .EqualTo. y%Max_Tm              ) .AND. &
         ALL(x%Mean_Tm              .EqualTo. y%Mean_Tm             ) .AND. &
         ALL(x%Secant_Sensor_Zenith .EqualTo. y%Secant_Sensor_Zenith) .AND. &
         ALL(x%Secant_Solar_Zenith  .EqualTo. y%Secant_Solar_Zenith ) .AND. &
         ALL(x%NLTE_Channel             ==    y%NLTE_Channel        ) .AND. &
         ALL(x%Is_NLTE_Channel        .EQV.   y%Is_NLTE_Channel     ) .AND. &
         ALL(x%C_Index                  ==    y%C_Index             ) .AND. &
         ALL(x%C                    .EqualTo. y%C                   ) ) &
      is_equal = .TRUE.

  END FUNCTION NLTECoeff_Equal

!--------------------------------------------------------------------------------
!
! NAME:
!       NLTECoeff_Reindex
!
! PURPOSE:
!       Subroutine to reindex the C_Index component of an NLTECoeff object after,
!       for example, subsetting or concatenation.
!
! CALLING SEQUENCE:
!       CALL NLTECoeff_Reindex( NLTECoeff )
!
! OBJECTS:
!       NLTECoeff:    NLTECoeff object which is to have its C_Index
!                     component reindexed.
!                     UNITS:      N/A
!                     TYPE:       NLTECoeff_type
!                     DIMENSION:  Scalar
!                     ATTRIBUTES: INTENT(IN OUT)
!
!--------------------------------------------------------------------------------

  SUBROUTINE NLTECoeff_Reindex( NLTECoeff )
    TYPE(NLTECoeff_type), INTENT(IN OUT) :: NLTECoeff
    INTEGER :: i, j
    j = 1
    DO i = 1, NLTECoeff%n_Channels
      IF ( NLTECoeff%C_Index(i) > 0 ) THEN
        NLTECoeff%C_Index(i) = j
        j = j + 1
      END IF
    END DO
  END SUBROUTINE NLTECoeff_Reindex

END MODULE NLTECoeff_Define


!------------------------------------------------------------------------------
!    'cmn_fjx_mod.f90'  for fast-JX code v 7.4+ (prather 8/15)
!         note that module and file begin with 'cmn_"
!         small changes: LREF=51 instead of hardwired, JVMAP replaces JMAP
!         MASFAC param added, also cloud params - see below
!------------------------------------------------------------------------------
!
! NB - ALL of these common variables are set paramters,
!    They are NOT to be used as variables for a local solution
!    Thus this entire set is 'in' only after it is initialized
!-----------------------------------------------------------------------
!
! !INTERFACE:
!
      MODULE FJX_CMN_MOD

      implicit none
      public

!-----------------------------------------------------------------------
      ! Turn on/off RRTM-G absorption cross sections
      logical, parameter::  LRRTMG= .true.
!-----------------------------------------------------------------------

      ! JXL_: vertical(levels) dim for J-values computed within fast-JX
      integer, parameter ::  JXL_=100, JXL1_=JXL_+1
      ! JXL2_: 2*JXL_ + 2 = mx no.levels in basic FJX grid (mid-level)
      integer, parameter ::  JXL2_=2*JXL_+2
      ! W_   = dim = no. of Fast-J Wavelength bins:  currenly only 18, TROP-ONLY is done by zeroing FL fluxes
      integer, parameter ::  W_=18
      ! S_   = dim = number of wavelength bins INLCUDING the Solar-J extensions (RRTMG value = 27)
      integer, parameter ::  S_=27
      ! X_   = dim = max no. of X-section data sets (input data)
      integer, parameter ::  X_=72
      ! A_   = dim = max no. of Aerosol Mie sets (input data) not including clouds and SSA
      integer, parameter ::  A_=40
      ! SSA_   = dim = no. of strat sulfate aerosol types (input data)
      integer, parameter ::  SSA_=18
      ! C_   = dim = no. of cld-data sets (input data) ///currently just 4xLiq and 2xIce
      integer, parameter ::  C_=6
      ! N_  = no. of levels in Mie scattering arrays
      !     = 2*NC+1 = 4*(L_+1) + 1`+ 2*sum(JADDLV)
      integer, parameter ::  N_=601
      ! M_  = no. of Gauss points used, must = 4 in fast_JX (no option)
      integer, parameter ::  M_=4
      ! M2_ = 2*M_ = 8, replaces MFIT
      integer, parameter ::  M2_=2*M_

!-----------------------------------------------------------------------
      ! 4 Gauss pts = 8-stream
      real*8, DIMENSION(M_), parameter  ::  &
                         EMU = [.06943184420297d0, .33000947820757d0, &
                                .66999052179243d0, .93056815579703d0]
      real*8, DIMENSION(M_), parameter  :: &
                         WT  = [.17392742256873d0, .32607257743127d0, &
                                .32607257743127d0, .17392742256873d0]
!-----------------------------------------------------------------------

      ! MASFAC: Conversion factor for pressure to column density
      real*8, parameter   ::  &
                         MASFAC = 100.d0*6.022d+23/(28.97d0*9.8d0*10.d0)
      ! ZZHT: scale height (cm) used above top of CTM ZHL(LPAR+1)
      real*8, parameter   :: ZZHT = 5.d5
      ! RAD: Radius of Earth (cm)
      real*8, parameter   :: RAD = 6375.d5
      ! ATAU: heating rate (factor increase from one layer to the next)
      real*8, parameter   :: ATAU = 1.120d0
      ! ATAU0: minimum heating rate
      real*8, parameter   :: ATAU0 = 0.010d0
      ! JTAUMX = maximum number of divisions (i.e., may not get to ATAUMN)
      integer, parameter  :: JTAUMX = (N_ - 4*JXL_)/2

      character*25, dimension(8), parameter :: TITCLD =  &
      ['clear sky - no clouds    ', &
       'avg cloud cover          ', &
       'avg cloud cover^3/2      ', &
       'ICAs - avg direct beam   ', &
       'ICAs - random N ICAs     ', &
       'QCAs - midpt of bins     ', &
       'QCAs - avg clouds in bins', &
       'ICAs - use all ICAs***   ']

!---- Variables in file 'FJX_spec.dat' (RD_XXX)
      ! WL: Centres of wavelength bins - 'effective wavelength'  (nm)
      real*8  WL(S_)
      ! WBIN: Boundaries of wavelength bins                  (microns)
      real*8  WBIN(S_+1)
      ! FL: Solar flux incident on top of atmosphere (cm-2.s-1)
      ! FW: Solar flux in W/m2
      ! FP: PAR quantum action spectrum
      real*8  FL(S_),FW(S_),FP(S_)
      ! QRAYL: Rayleigh parameters (effective cross-section) (cm2)
      real*8  QRAYL(S_)
      ! SJSUB:  intended for breakdown of the super-bins (1:27) into smaller sub-bins.
      real*8  SJSUB(S_,15)
      real*8  QO2(W_,3)   ! QO2: O2 cross-sections
      real*8  QO3(W_,3)   ! QO3: O3 cross-sections
      real*8  Q1D(W_,3)   ! Q1D: O3 => O(1D) quantum yield

      ! QQQ: Supplied cross sections in each wavelength bin (cm2)
      real*8  QQQ(W_,3,X_)
      ! TQQ: Temperature for supplied cross sections
      real*8  TQQ(3,X_)
      ! LQQ = 1, 2, or 3 to determine interpolation with T or P
      integer LQQ(X_)

      ! TITLEJX: Title (short & long) for supplied cross sections, from 'FJX_spec.dat'
      CHARACTER*6  TITLEJX(X_)
      CHARACTER*16 TITLEJL(X_)
      ! SQQ: Flag for supplied cross sections, from 'FJX_spec.dat'
      CHARACTER*1  SQQ(X_)

!---- Variables in file 'FJX_scat-aer.dat' (RD_MIE)
      ! TITLAA: Aerosol Mie Titles
      character*12  TITLAA(A_)
      ! QAA: Aerosol scattering phase functions
      real*8  QAA(5,A_)
      ! WAA: 5 Wavelengths for the supplied phase functions
      real*8  WAA(5,A_)
      ! PAA: Phase function: first 8 terms of expansion
      real*8  PAA(8,5,A_)
      ! RAA: Effective radius associated with aerosol type
      real*8  RAA(A_)
      ! SAA: Single scattering albedo
      real*8  SAA(5,A_)
      ! DAA: density (g/cm^3)
      real*8  DAA(A_)
      ! NAA: Number of categories for scattering phase functions
      integer NAA

!---- Variables in file 'FJX_scat-cld.dat' (RD_CLD)
      ! NCC: Number of categories for cloud scattering phase functions
      integer NCC
      ! TITLCC: Cloud type titles
      character*12  TITLCC(C_)
      ! RCC: Effective radius associated with cloud type
      real*8  RCC(C_)
      ! GCC: Effective geometric cross section
      real*8  GCC(C_)
      ! DCC: density (g/cm^3)
      real*8  DCC(C_)
      ! QCC: Cloud Q-ext
      real*8  QCC(S_,C_)
      ! WCC: Wavelengths for supplied phase functions
      real*8  WCC(S_,C_)
      ! SCC: Single scattering albedo
      real*8  SCC(S_,C_)
      ! PCC: Phase function: first 8 terms of expansion
      real*8  PCC(8,S_,C_)

!---- Variables in file 'FJX_scat-ssa.dat' (RD_SSA)
      ! NSS: Number of categories for Strat Sulf Aerosol scattering phase functions
      integer NSS
      ! TITLSS: Cloud type titles
      character*12  TITLSS(SSA_)
      ! RSS: Effective radius associated with cloud type
      real*8  RSS(SSA_)
      ! GSS: Effective geometric cross section
      real*8  GSS(SSA_)
      ! DSS: density (g/cm^3)
      real*8  DSS(SSA_)
      ! TSS: temperature (K)
      real*8  TSS(SSA_)
      ! WSS: weight percent sulfuric acid (%)
      real*8  WSS(SSA_)
      ! QSS: Q-ext      ----begin wavelength dependent quantities
      real*8  QSS(S_,SSA_)
      ! SSS: Single scattering albedo
      real*8  SSS(S_,SSA_)
      ! PSS: Phase function: first 8 terms of expansion
      real*8  PSS(8,S_,SSA_)

!---- Variables in file 'FJX_scat-UMa.dat' (RD_CLD)
      ! WMM: U Michigan aerosol wavelengths
      real*8  WMM(6)
      ! UMAER: U Michigan aerosol data sets
      real*8  UMAER(3,6,21,33)

!---- Variables in file 'atmos_std.dat' (RD_PROF)
      integer, parameter ::  LREF=51   ! layer dim. in reference profiles
      integer, parameter ::  JREF=18   ! latitude dim. in reference profiles

!----- T and O3, H2O, CH4, reference profiles added underscore _ because TREF used in RRTMG_SW
      real*8, DIMENSION(LREF,JREF,12) :: T_REF, O_REF, H2O_REF, CH4_REF
      integer NJX,NW1,NW2,NS1,NS2

!-----------------NEW for FJX72 parameters for cloud grid now here------
      integer, parameter :: &
            LPAR= 57, LWEPAR=34  &   !this can be set by CTM code
           ,L_=LPAR, L1_=L_+1 &   ! L_ = number of CTM layers
           ,L2_=2*L_+2 &        ! no. levels in the Fast-JX grid that
                       ! includes both layer edges and layer mid-points
           ,JVL_=LPAR &  ! vertical(levels) dim for J-values sent to CTM
           ,JVN_=101 &  ! max no. of J-values
           ,AN_=25     ! # FJX aerosols in layer (needs NDX for each)

!-----------------------------------------------------------------------
      ! variables used to map fast-JX J's onto CTM J's
!-----------------------------------------------------------------------
      real*8  JFACTA(JVN_)  ! multiplication factor for fast-JX calculated J
      integer JIND(JVN_)    ! index arrays that map Jvalue(j) onto rates
      integer NRATJ         ! number of Photolysis reactions in CTM chemistry, NRATJ <= JVN_
      integer NWBIN         ! used to shut off SFlux (and Fast-J calc) for strat wavelengths
                            ! only values that invoke action are 8 & 12 (mimic W_=8 or 12)
      integer NSBIN         ! likewise used to zero FL, if NSBIN = 18 then FL(19:27)=0.0

      character*6 JVMAP(JVN_) !label of J-value used to match w/FJX J's
      character*50 JLABEL(JVN_) ! label of J-value used in the chem model

! Cloud Cover parameters
!-----------------------------------------------------------------------
! NB CBIN_ was set at 20, but with NRG=6 groups, 10 gives a more reasonable number of ICAs
      integer, parameter :: CBIN_ = 10     ! # of quantized cloud fraction bins
      integer, parameter :: ICA_ = 20000   ! Max # of indep colm atmospheres
      integer, parameter :: NQD_ = 4       ! # of cloud fraction bins (4)

      real*8,  parameter ::  CPI    = 3.141592653589793d0
      real*8,  parameter ::  C2PI   = 2.d0*CPI
      real*8,  parameter ::  CPI180 = CPI/180.d0
      real*8,  parameter ::  G0     = 9.80665d0
      real*8,  parameter ::  G100 = 100.d0/G0
!-------data to set up the random number sequence for use in cloud-JX
      integer, parameter :: NRAN_ = 10007  ! dimension for random number
      real*4   RAN4(NRAN_)      ! Random number set

! Solar J parameters - for Cloud-J v7.4 just do one sub-bin per RRTMg superbin
!-----------------------------------------------------------------------
      integer, parameter:: W_r = S_-W_              ! Cloud-J fix, W_r = 82 for RRTMg in rrsw_fasj_cmn.f90
      real*8, dimension(L1_,W_r)  ::  TAUG_RRTMG    ! Cloud-J fix, is defined in rrsw_fasj_cmn.f90

      integer,  parameter, dimension(S_) ::   NGC =        &
        [  1,  1,  1,  1,  1,  1,  1,  1,  1,  1,          &
           1,  1,  1,  1,  1,  1,  1,  1,  1,  1,          &
           1,  1,  1,  1,  1,  1,  1  ]
! actual RRMTMg values
!      integer,  parameter, dimension(S_) ::   NGC =       &
!       [   1,  1,  1,  1,  1,  1,  1,  1,  1,  1,         &
!           1,  1,  1,  1,  1,  1,  1,  5, 10,  2,         &
!          10, 10,  8,  8, 12,  6, 12]

      END MODULE FJX_CMN_MOD


	SUBROUTINE GH_KGIP ( tlat, tlon, rmnlat, rmnlon, rmxlat, rmxlon,
     +                       bxlgth, slnlat, slnlon, numln, bxwdth,
     +                       ddev, curlat, curlon,
     +                       nabk, abklat, abklon,
     +                       cclat, cclon, poslb, iret )
C************************************************************************
C* GH_KGIP								*
C*									*
C* This subroutine determines the legend box position for the tropical  *
C* cyclone watch/warn graphic.  It checks the possible legend box corner*
C* positions in the order of LR, UR, LL, UL.  It first performs a crude *
C* check against a box which encloses the track error area, including   *
C* a surrounding margin.  If this check fails, it checks against the    *
C* track error area itself.  If the legend box and track error box/track*
C* error cone do not overlap, the check for overlap of brekapoints and  *
C* legend box is performed.  If there is no overlap the check of overlap*
C* of NOAA logo and track error box is performed.  The position will 	*
C* default to the LR corner if an overlap is found for all four corner  *
C* positions.								*
C*									*
C* GH_KGIP ( TLAT, TLON, RMNLAT, RMNLON, RMXLAT, RMXLON, BXLGTH, 	*
C*           SLNLAT, SLNLON, NUMLN, BXWDTH, DDEV, CURLAT, CURLON,       *
C*	     NABK, ABKLAT, ABKLON, CCLAT, CCLON, POSLB, IRET )		*
C*									*
C* Input Parameters:							*
C*	TLAT (*)	REAL		Track error box area - lats.	*
C*	TLON (*)	REAL		Track error box area - lons.	*
C*	RMNLAT 		REAL		Minumum garea latitude		*
C*	RMNLON 		REAL		Mininum garea longitude		*
C*	RMXLAT 		REAL		Maximum garea latitude		*
C*	RMXLON 		REAL		Maximum garea longitude		*
C*	BXLGTH		REAL		Legend box length (norm. coords)*
C*	SLNLAT (NUMLN) 	REAL		Track error area - lats.	*
C*	SLNLON (NUMLN)	REAL		Track error area - longs.	*
C*	NUMLN		INTEGER		Number of track error points	*
C*	BXWDTH		REAL		Legend box width (norm. coords) *
C*	DDEV		CHAR*		Device driver			*
C*	CURLAT		REAL		Current latitude                *
C*	CURLON		REAL		Current longitude               *
C*	NABK		INTEGER		Number of all breakpoints	*
C*	ABKLAT (NABK) 	REAL		All breakpoints - lats.		*
C*	ABKLON (NABK)	REAL		All breakpoints - longs.	*
C*									*
C* Output Parameters:							*
C*	CCLAT		REAL 		Anchor corner lat. (norm.)      *
C*	CCLON		REAL 		Anchor corner long. (norm.)     *
C*	POSLB		CHAR 		Flag for legend position	*
C*	IRET		INTEGER		Return code			*
C*					    0 = normal return           *
C*					   -1 = unable to place box     *
C**									*
C* Log:									*
C* A. Hardy/GSC		 4/01						*
C* A. Hardy/GSC		 6/01	Added 2 more checks for legend  	*
C* A. Hardy/SAIC	 8/01	Added PS check;incr. box size		*
C* D. Kidwell/NCEP	10/01	Increased dims of xlat, ylon    	*
C* A. Hardy/SAIC	10/01	Added current lat/lon			*
C* D. Kidwell/NCEP	 4/02	Cleaned up, added iret = -1     	*
C* D. Kidwell/NCEP	 4/02	Added check around current loc. 	*
C* D. Kidwell/NCEP	 4/04	Added check for logo overlap    	*
C* S. Gilbert/NCEP	 7/05	Corrected position of label box 	*
C* m.gamazaychikov/SAIC	09/08	CSC - added nabk, abklat, abklon,	*
C*                          	cleaned up and added check for overlap	*
C*                          	between breakpoints and legend box	*
C************************************************************************
	REAL  		tlat(*), tlon(*), slnlat(*), slnlon(*),
     +                  abklat(*), abklon(*)
        CHARACTER*(*)   ddev
        CHARACTER       poslb
C*
        REAL            xlat(500), ylon(500), xpoly(5), ypoly(5),
     +			bxlat (3), bxlon (3), xlatbx (5), ylonbx (5),
     +			xlogo (9), ylogob (9), ylogot (9)
        CHARACTER       sysn*2, svlb, fliplb
 	LOGICAL         done, good,
     +                  curchck, curgood, logchck, loggood,
     +                  boxchck, conchck, bkpchck,
     +                  boxgood, congood, bkpgood
C
C*	The following are the normalized coordinates for an octagon
C*	surrounding the NOAA logo.
C
      DATA		xlogo  / .982, .967, .930, .893, .878, .893,
     +				 .930, .967, .982 /
      DATA		ylogob / .070, .107, .122, .107, .070, .033,
     +				 .018, .033, .070 /
      DATA		ylogot / .720, .757, .772, .757, .720, .683,
     +				 .668, .683, .720 /
C------------------------------------------------------------------------
        iret  = 0
	poslb = 'B'
	done  = .false.
	bkpchck  = .false.
	boxchck  = .false.
	conchck  = .false.
	curchck  = .false.
	logchck  = .false.
	bkpgood  = .false.
	boxgood  = .false.
	congood  = .false.
	curgood  = .false.
	loggood  = .false.
        ipoly = 5
        sysn  = 'N'
        CALL ST_NULL ( sysn, sysn, lens, ier )
C
C*      Get normalized coordinates for both box around track error area
C*	and for track error area itself.
C
	CALL GTRANS ( 'M', 'N', ipoly, tlat, tlon, xlatbx, ylonbx, ier )
	CALL GTRANS ( 'M', 'N', numln, slnlat, slnlon, xlat, ylon, ier )
        xmax = rmxlat
        xmin = rmnlat
        ymax = rmxlon
        ymin = rmnlon
C
C*      Find the suitable placement of legend box.
C
        ii    = 1
        isave = 0
        bxcnr = bxwdth - .19
        bxcnr = bxwdth + .01
        DO WHILE ( ( .not. done ) .and. ( ii .le. 4 ) )
             IF ( ii .eq. 1 ) THEN
C
C*              Lower right
C
                poslb = 'B'
                xpoly (1) = xmax - bxcnr
                ypoly (1) = ymin + bxlgth + .03
                IF  ( ddev(1:2) .eq. 'PS' ) xpoly(1)=xmax-bxcnr+.02
             ELSE IF ( ii .eq. 2 ) THEN
C
C*              Upper right
C
                poslb = 'T'
                xpoly (1) = xmax - bxcnr
                ypoly (1) = ymax - .03
                IF  ( ddev(1:2) .eq. 'PS' )  THEN
                    xpoly (1) = xmax - bxcnr +.02
                    ypoly (1) = ymax - .05
                END IF
             ELSE IF ( ii .eq. 3 ) THEN
C
C*              Lower left
C
                poslb = 'B'
                xpoly (1) = .045
                ypoly (1) = ymin + bxlgth + .03
             ELSE
C
C*              Upper left
C
                poslb = 'T'
                xpoly (1) = .045
                ypoly (1) = ymax - .03
                IF  ( ddev(1:2) .eq. 'PS' ) ypoly (1) = ymax - .05
             END IF
C
C*           Set up legend box polygon.
C
             xpoly (2) = xpoly(1)
             ypoly (2) = ypoly(1) - bxlgth
             xpoly (3) = xpoly(2) + bxwdth
             ypoly (3) = ypoly(2)
             xpoly (4) = xpoly(3)
             ypoly (4) = ypoly(1)
             xpoly (5) = xpoly(1)
             ypoly (5) = ypoly(1)
C
C*           Overlap of error box and legend box check
C
             IF ( .not. boxchck ) THEN
C
C*               Check the error box overlap with the proposed
C*               legend box position
C
                 CALL CGR_POLYINT ( sysn(:lens), 5, xpoly, ypoly,
     +                              sysn(:lens), ipoly, xlatbx,
     +                              ylonbx, inout, ier )
                 IF ( inout .eq. 0 ) THEN
                    boxgood = .true.
                    cclat = ypoly(1)
                    cclon = xpoly(1)
                    isave = ii
                    svlat = ypoly (1)
                    svlon = xpoly (1)
                    svlb  = poslb (1:1)
                 END IF
                 boxchck = .true.
             END IF
C
C*           Overlap of error cone and legend box check
C
             IF ( .not. conchck .and. .not. boxgood ) THEN
C
C                Check the current storm location relative to the
C*               proposed legend box position.
C
                 IF ( .not. curchck ) THEN
                    CALL GTRANS ( 'N', 'M', 3, xpoly, ypoly, bxlat,
     +                            bxlon, ier )
                    bxrgt = bxlon ( 3 ) + 3.
                    bxlft = bxlon ( 1 ) - 3.
                    bxtop = bxlat ( 1 ) + 3.
                    bxbot = bxlat ( 2 ) - 3.
                    curgood  = .false.
                    IF ( ii .eq. 1 ) THEN
                       IF ( ( curlon .le. bxlft ) .or.
     +                      ( curlat .ge. bxtop ) )  curgood = .true.
                    ELSE IF ( ii .eq. 2 ) THEN
                       IF ( ( curlon .le. bxlft ) .or.
     +                      ( curlat .le. bxbot ) )  curgood = .true.
                    ELSE IF ( ii .eq. 3 ) THEN
                       IF ( ( curlon .ge. bxrgt ) .or.
     +                      ( curlat .ge. bxtop ) )  curgood = .true.
                    ELSE
                       IF ( ( curlon .ge. bxrgt ) .or.
     +                      ( curlat .le. bxbot ) )  curgood = .true.
                    END IF
                 END IF
                 curchck  = .true.
C
C*               Check the error cone overlap with the proposed
C*               legend box position
C
                 CALL CGR_POLYINT ( sysn(:lens), 5, xpoly, ypoly,
     +                              sysn(:lens), numln, xlat, ylon,
     +                              inout, ier )
                 IF ( ( inout .eq. 0 ) .and. curgood ) THEN
                    cclat = ypoly(1)
                    cclon = xpoly(1)
                    conchck = .true.
                    congood = .true.
                    isave = ii
                    svlat = ypoly (1)
                    svlon = xpoly (1)
                    svlb  = poslb (1:1)
                 ELSE
C
C*                    Set the conchck to false to try to place
C*                    legend in a different corner
C
                      conchck = .false.
                 END IF
             END IF
C
C*           Overlap of breakpoints and legend box check
C
             IF ( .not. bkpchck .and. ( boxgood .or. congood ) ) THEN
                 ibk = 1
                 DO WHILE ( (ibk .le. nabk) .and. (inout .eq. 0) )
                    CALL GTRANS ( 'M', 'N', 1, abklat(ibk), abklon(ibk),
     +                             xbk, ybk, ier )
                    CALL CGR_INPOLY ( sysn(:lens), 1, xbk,   ybk,
     +                                sysn(:lens), 5, xpoly, ypoly,
     +                                inout, ier)
                    ibk = ibk + 1
                 END DO
                 bkpchck = .true.
                 IF ( inout .eq. 0 ) bkpgood = .true.
             END IF
C
C*           Overlap of NOAA Logo and legend box check
C
             IF ( .not. logchck .and. ( boxgood .or. congood )
     +                          .and.   bkpgood                ) THEN
C
C*               Check the logo position relative to the
C*               proposed legend box position.
C
                 logchck = .true.
                 IF ( poslb .eq. 'B' ) THEN
                    CALL CGR_POLYINT ( sysn(:lens), 9, xlogo, ylogot,
     +                                 sysn(:lens), numln, xlat, ylon,
     +                                 inout, ier )
                 ELSE
                    CALL CGR_POLYINT ( sysn(:lens), 9, xlogo, ylogob,
     +                                 sysn(:lens), numln, xlat, ylon,
     +                                 inout, ier )
                 END IF
                 IF ( inout .eq. 0 ) THEN
                    loggood = .true.
                 ELSE
                 END IF
             END IF

C
C*           Go to the next corner in the progression
C*           unless there is no overlap between either:
C*           - error box  and legend box
C*           - error cone and legend box
C*                     AND
C*           - breakpoints and legend box
C*                     AND
C*           - NOAA logo and legend box
C
             ii = ii + 1
             IF ( ( boxgood .or. congood ) .and. bkpgood
     +                .and. loggood ) THEN
                  done = .true.
             ELSE
                  bkpchck = .false.
                  boxchck = .false.
                  conchck = .false.
                  curchck = .false.
                  logchck = .false.
             END IF
        END DO
C
        IF ( .not. done ) THEN
C
C*          An overlap or near overlap is going to occur anywhere.  In
C*	    case this is the final attempt to place the box, default to
C*	    LR corner for an overlap, or to previously saved corner
C*	    (with current point near box).
C
	    iret  = -1
	    IF ( isave .le. 1 ) THEN
	        poslb = 'B'
                cclat = ymin + bxlgth + .03
                cclon = xmax - bxcnr
                IF ( ddev(1:2) .eq. 'PS' ) cclon = cclon +.02
	      ELSE
		poslb = svlb
		cclat = svlat
		cclon = svlon
                IF ( ddev(1:2) .eq. 'PS' ) THEN
		    IF ( isave .eq. 2 ) THEN
		        cclat = cclat - .02
			cclon = cclon + .02
		      ELSE IF ( isave .eq. 4 ) THEN
			cclat = cclat - .02
		    END IF
		END IF
	    END IF
        END IF
C*
	RETURN
	END