srtm_cmbgb28.F90

Go to the documentation of this file.

SUBROUTINE srtm_cmbgb28

!     BAND 28:  38000-50000 cm-1 (low - O3,O2; high - O3,O2)
!-----------------------------------------------------------------------

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

USE yoesrtwn , ONLY : ngc, ngs, ngn, rwgt
USE yoesrta28, ONLY : ka, kb, sfluxref, &
                    & kac, kbc, 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_CMBGB28',0,zhook_handle)

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

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

DO jp = 1,5
  iprsm = 0
  DO igc = 1,ngc(13)
    zsumf = 0.
    DO ipr = 1, ngn(ngs(12)+igc)
      iprsm = iprsm + 1
      zsumf = zsumf + sfluxref(iprsm,jp)
    ENDDO
    sfluxrefc(igc,jp) = zsumf
  ENDDO
ENDDO

!     -----------------------------------------------------------------
IF (lhook) CALL dr_hook('SRTM_CMBGB28',1,zhook_handle)
END SUBROUTINE srtm_cmbgb28