srtm_cmbgb16.F90

Go to the documentation of this file.

SUBROUTINE srtm_cmbgb16

!
!  Original version:       Michael J. Iacono; July, 1998
!  Revision for RRTM_SW:   Michael J. Iacono; November, 2002
!  Revision for RRTMG_SW:  Michael J. Iacono; December, 2003
!
!  The subroutines CMBGB16->CMBGB29 input the absorption coefficient
!  data for each band, which are defined for 16 g-points and 14 spectral
!  bands. The data are combined with appropriate weighting following the
!  g-point mapping arrays specified in RRTMG_SW_INIT.  Solar source 
!  function data in array SFLUXREF are combined without weighting.  All
!  g-point reduced data are put into new arrays for use in RRTMG_SW.
!
!  BAND 16:  2600-3250 cm-1 (low key- H2O,CH4; high key - CH4)
!
!-----------------------------------------------------------------------

USE parkind1  ,ONLY : jpim , jprb
USE yomhook   ,ONLY : lhook, dr_hook

USE yoesrtwn , ONLY : ngc, ngn, rwgt
USE yoesrta16, ONLY : ka, kb, selfref, forref, sfluxref, &
                    & kac, kbc, selfrefc, forrefc, sfluxrefc

IMPLICIT NONE

! Local variables
INTEGER(KIND=JPIM) :: JN, JT, JP, IGC, IPR, IPRSM
REAL(KIND=JPRB)    :: ZSUMK, ZSUMF

REAL(KIND=JPRB) :: ZHOOK_HANDLE
!     ------------------------------------------------------------------
IF (lhook) CALL dr_hook('SRTM_CMBGB16',0,zhook_handle)

DO jn = 1,9
  DO jt = 1,5
    DO jp = 1,13
      iprsm = 0
      DO igc = 1,ngc(1)
        zsumk = 0.
        DO ipr = 1, ngn(igc)
          iprsm = iprsm + 1
          zsumk = zsumk + ka(jn,jt,jp,iprsm)*rwgt(iprsm)
        ENDDO
        kac(jn,jt,jp,igc) = zsumk
      ENDDO
    ENDDO
  ENDDO
ENDDO

DO jt = 1,5
  DO jp = 13,59
    iprsm = 0
    DO igc = 1,ngc(1)
      zsumk = 0.
      DO ipr = 1, ngn(igc)
        iprsm = iprsm + 1
        zsumk = zsumk + kb(jt,jp,iprsm)*rwgt(iprsm)
      ENDDO
      kbc(jt,jp,igc) = zsumk
    ENDDO
  ENDDO
ENDDO

DO jt = 1,10
  iprsm = 0
  DO igc = 1,ngc(1)
    zsumk = 0.
    DO ipr = 1, ngn(igc)
      iprsm = iprsm + 1
      zsumk = zsumk + selfref(jt,iprsm)*rwgt(iprsm)
    ENDDO
    selfrefc(jt,igc) = zsumk
  ENDDO
ENDDO

DO jt = 1,3
  iprsm = 0
  DO igc = 1,ngc(1)
    zsumk = 0.
    DO ipr = 1, ngn(igc)
      iprsm = iprsm + 1
      zsumk = zsumk + forref(jt,iprsm)*rwgt(iprsm)
    ENDDO
    forrefc(jt,igc) = zsumk
  ENDDO
ENDDO

iprsm = 0
DO igc = 1,ngc(1)
  zsumf = 0.
  DO ipr = 1, ngn(igc)
    iprsm = iprsm + 1
    zsumf = zsumf + sfluxref(iprsm)
  ENDDO
  sfluxrefc(igc) = zsumf
ENDDO

!     -----------------------------------------------------------------
IF (lhook) CALL dr_hook('SRTM_CMBGB16',1,zhook_handle)
END SUBROUTINE srtm_cmbgb16