srtm_init.F90

Go to the documentation of this file.

SUBROUTINE srtm_init

!-- read in the basic coefficients to configure RRTM_SW
!- creates module YOESRTWN with BG, NSPA, NSPB, WAVENUM1, WAVENUM2,
!  DELWAVE, PREF, PREFLOG, TREF

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

USE parsrtm  , ONLY : jpg, jpsw
USE yoesrtwn , ONLY : ng, ngm, wt, ngc, ngn, rwgt, wtsm

IMPLICIT NONE

! Local variables
INTEGER(KIND=JPIM) :: IGC, IGCSM, IBND, IG, IND, IPR, IPRSM
REAL(KIND=JPRB)    :: ZWTSUM

REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "susrtm.intfb.h"
#include "srtm_kgb16.intfb.h"
#include "srtm_kgb17.intfb.h"
#include "srtm_kgb18.intfb.h"
#include "srtm_kgb19.intfb.h"
#include "srtm_kgb20.intfb.h"
#include "srtm_kgb21.intfb.h"
#include "srtm_kgb22.intfb.h"
#include "srtm_kgb23.intfb.h"
#include "srtm_kgb24.intfb.h"
#include "srtm_kgb25.intfb.h"
#include "srtm_kgb26.intfb.h"
#include "srtm_kgb27.intfb.h"
#include "srtm_kgb28.intfb.h"
#include "srtm_kgb29.intfb.h"
!#include "susrtop.intfb.h"

#include "srtm_cmbgb16.intfb.h"
#include "srtm_cmbgb17.intfb.h"
#include "srtm_cmbgb18.intfb.h"
#include "srtm_cmbgb19.intfb.h"
#include "srtm_cmbgb20.intfb.h"
#include "srtm_cmbgb21.intfb.h"
#include "srtm_cmbgb22.intfb.h"
#include "srtm_cmbgb23.intfb.h"
#include "srtm_cmbgb24.intfb.h"
#include "srtm_cmbgb25.intfb.h"
#include "srtm_cmbgb26.intfb.h"
#include "srtm_cmbgb27.intfb.h"
#include "srtm_cmbgb28.intfb.h"
#include "srtm_cmbgb29.intfb.h"

IF (lhook) CALL dr_hook('SRTM_INIT',0,zhook_handle)

CALL susrtm

!-- read in the molecular absorption coefficients

CALL srtm_kgb16
CALL srtm_kgb17
CALL srtm_kgb18
CALL srtm_kgb19
CALL srtm_kgb20
CALL srtm_kgb21
CALL srtm_kgb22
CALL srtm_kgb23
CALL srtm_kgb24
CALL srtm_kgb25
CALL srtm_kgb26
CALL srtm_kgb27
CALL srtm_kgb28
CALL srtm_kgb29

!-- read in the cloud optical properties
!- creates module YOESRTOP with EXTLIQ1, SSALIQ1, ASYLIQ1, 
!  EXTICE3, SSAICE3, ASYICE3, FDLICE3  

!-- RRTM_SW cloud optical properties are not used
!   SRTM_CLDPROP is not called
!   no need to call SUSRTOP

!CALL SUSRTOP ( -1 )


!Mike Iacono 20050804
!-- Perform g-point reduction from 16 per band (224 total points) to
!-- a band dependent number (112 total points) for all absorption
!-- coefficient input data and Planck fraction input data.
!-- Compute relative weighting for new g-point combinations.

igcsm = 0
DO ibnd = 1,jpsw
  iprsm = 0
  IF (ngc(ibnd) < jpg) THEN
    DO igc = 1,ngc(ibnd)
      igcsm = igcsm + 1
      zwtsum = 0.
      DO ipr = 1, ngn(igcsm)
        iprsm = iprsm + 1
        zwtsum = zwtsum + wt(iprsm)
      ENDDO
      wtsm(igc) = zwtsum
    ENDDO

    DO ig = 1,ng(ibnd+15)
      ind = (ibnd-1)*jpg + ig
      rwgt(ind) = wt(ig)/wtsm(ngm(ind))
    ENDDO
  ELSE
    DO ig = 1,ng(ibnd+15)
      igcsm = igcsm + 1
      ind = (ibnd-1)*jpg + ig
      rwgt(ind) = 1.0
    ENDDO
  ENDIF
ENDDO

CALL srtm_cmbgb16
CALL srtm_cmbgb17
CALL srtm_cmbgb18
CALL srtm_cmbgb19
CALL srtm_cmbgb20
CALL srtm_cmbgb21
CALL srtm_cmbgb22
CALL srtm_cmbgb23
CALL srtm_cmbgb24
CALL srtm_cmbgb25
CALL srtm_cmbgb26
CALL srtm_cmbgb27
CALL srtm_cmbgb28
CALL srtm_cmbgb29

!-----------------------------------------------------------------------
IF (lhook) CALL dr_hook('SRTM_INIT',1,zhook_handle)
END SUBROUTINE srtm_init