SUBROUTINE SRTM_INIT(DIRECTORY) !-- 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 YOESRTM , ONLY : NGN USE YOESRTWN , ONLY : NG, NGM, WT, NGC, RWGT, WTSM !USE YOESRTWN , ONLY : NG, NGM, WT, NGC, NGN, RWGT, WTSM !USE YOMLUN , ONLY : NULOUT IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: DIRECTORY ! Local variables INTEGER(KIND=JPIM) :: IGC, IGCSM, IBND, IG, IND, IPR, IPRSM REAL(KIND=JPRB) :: ZWTSUM REAL(KIND=JPRB) :: ZHOOK_HANDLE !#include "susrtmcf.intfb.h" #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 SUSRTMCF CALL SUSRTM !-- read in the molecular absorption coefficients CALL SRTM_KGB16(DIRECTORY) 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 !WRITE(NULOUT,9001) JPSW,JPG 9001 format(1x,'srtm_init JPSW=',I3,' JPG=',I3) DO IBND = 1,JPSW IPRSM = 0 ! WRITE(NULOUT,9002) IBND,NGC(IBND) 9002 format(1x,'srtm_init NGC(',I3,')=',I3) IF (NGC(IBND) < JPG) THEN DO IGC = 1,NGC(IBND) IGCSM = IGCSM + 1 ZWTSUM = 0. ! WRITE(NULOUT,9003) IGC,IGCSM,NGN(IGCSM) 9003 format(1x,'srtm_init IGC=',I3,' NGN(',I3,')=',I3) DO IPR = 1, NGN(IGCSM) IPRSM = IPRSM + 1 ! WRITE(NULOUT,9004) IPR,IPRSM,WT(IPRSM) 9004 format(1x,'srtm_init IPR=',I3,' WT(',I3,')=',E14.7) ZWTSUM = ZWTSUM + WT(IPRSM) ENDDO ! WRITE(NULOUT,9005) IGC,ZWTSUM 9005 format(1x,'srtm_init WTSM(',I3,')=',E14.7) WTSM(IGC) = ZWTSUM ENDDO ! WRITE(NULOUT,9006) IBND+15,NG(IBND+15) 9006 format(1x,'srtm_init NG(',I3,')=',I3) DO IG = 1,NG(IBND+15) IND = (IBND-1)*JPG + IG !! WRITE(NULOUT,9007) IND,NGM(IND), IG,WT(IG), WTSM(NGM(IND)), IND,RWGT(IND) 9007 format(1x,'srtm_init NGM(',I3,')=',I3,' WT(',I3,')=',E13.7,' WTSM=',E13.7,' RWGT(',I3,')=',E13.7) RWGT(IND) = WT(IG)/WTSM(NGM(IND)) ! WRITE(NULOUT,9007) IND,NGM(IND),IG,WT(IG),WTSM(NGM(IND)),IND,RWGT(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