srtm_cmbgb29.F90

Go to the documentation of this file.

SUBROUTINE srtm_cmbgb29

!     BAND 29:  820-2600 cm-1 (low - H2O; high - CO2)
!-----------------------------------------------------------------------

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

USE yoesrtwn , ONLY : ngc, ngs, ngn, rwgt
USE yoesrta29, ONLY : ka, kb, selfref, forref, sfluxref, &
                    & absh2o, absco2, &
                    & kac, kbc, selfrefc, forrefc, sfluxrefc, &
                    & absh2oc, absco2c

IMPLICIT NONE

! Local variables
INTEGER(KIND=JPIM) :: JT, JP, IGC, IPR, IPRSM
REAL(KIND=JPRB)    :: ZSUMK, ZSUMF1, ZSUMF2, ZSUMF3

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

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

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

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

DO jt = 1,4
  iprsm = 0
  DO igc = 1,ngc(14)
    zsumk = 0.
    DO ipr = 1, ngn(ngs(13)+igc)
      iprsm = iprsm + 1
      zsumk = zsumk + forref(jt,iprsm)*rwgt(iprsm+208)
    ENDDO
    forrefc(jt,igc) = zsumk
  ENDDO
ENDDO

iprsm = 0
DO igc = 1,ngc(14)
  zsumf1 = 0.
  zsumf2 = 0.
  zsumf3 = 0.
  DO ipr = 1, ngn(ngs(13)+igc)
    iprsm = iprsm + 1
    zsumf1 = zsumf1 + sfluxref(iprsm)
    zsumf2 = zsumf2 + absco2(iprsm)*rwgt(iprsm+208)
    zsumf3 = zsumf3 + absh2o(iprsm)*rwgt(iprsm+208)
  ENDDO
  sfluxrefc(igc) = zsumf1
  absco2c(igc) = zsumf2
  absh2oc(igc) = zsumf3
ENDDO

!     -----------------------------------------------------------------
IF (lhook) CALL dr_hook('SRTM_CMBGB29',1,zhook_handle)
END SUBROUTINE srtm_cmbgb29