rrtm_init_140gp.F90

Go to the documentation of this file.

!***************************************************************************
SUBROUTINE rrtm_init_140gp
!***************************************************************************
!     Reformatted for F90 by JJMorcrette, ECMWF, 980714

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

USE parrrtm  , ONLY : jpband   ,jpg      ,jpgpt
USE yoerrtwn , ONLY : ng       
USE yoerrtftr, ONLY : ngc      ,ngn      ,ngm     , wt
! Output
USE yoerrtbg2, ONLY : corr1    ,corr2
USE yoerrtrwt, ONLY : frefa    ,frefb    ,frefadf  ,frefbdf   ,rwgt


IMPLICIT NONE
REAL(KIND=JPRB) :: Z_WTSM(jpg)

INTEGER(KIND=JPIM) :: I, IBND, IG, IGC, IGCSM, IND, IPR, IPRSM, IPT

REAL(KIND=JPRB) :: Z_FP, Z_RTFP, Z_WTSUM
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "rrtm_kgb1.intfb.h"
#include "rrtm_kgb10.intfb.h"
#include "rrtm_kgb11.intfb.h"
#include "rrtm_kgb12.intfb.h"
#include "rrtm_kgb13.intfb.h"
#include "rrtm_kgb14.intfb.h"
#include "rrtm_kgb15.intfb.h"
#include "rrtm_kgb16.intfb.h"
#include "rrtm_kgb2.intfb.h"
#include "rrtm_kgb3.intfb.h"
#include "rrtm_kgb4.intfb.h"
#include "rrtm_kgb5.intfb.h"
#include "rrtm_kgb6.intfb.h"
#include "rrtm_kgb7.intfb.h"
#include "rrtm_kgb8.intfb.h"
#include "rrtm_kgb9.intfb.h"

#include "rrtm_cmbgb1.intfb.h"
#include "rrtm_cmbgb10.intfb.h"
#include "rrtm_cmbgb11.intfb.h"
#include "rrtm_cmbgb12.intfb.h"
#include "rrtm_cmbgb13.intfb.h"
#include "rrtm_cmbgb14.intfb.h"
#include "rrtm_cmbgb15.intfb.h"
#include "rrtm_cmbgb16.intfb.h"
#include "rrtm_cmbgb2.intfb.h"
#include "rrtm_cmbgb3.intfb.h"
#include "rrtm_cmbgb4.intfb.h"
#include "rrtm_cmbgb5.intfb.h"
#include "rrtm_cmbgb6.intfb.h"
#include "rrtm_cmbgb7.intfb.h"
#include "rrtm_cmbgb8.intfb.h"
#include "rrtm_cmbgb9.intfb.h"

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

! Read the absorption-related coefficients over the 16 x 16 g-points

CALL rrtm_kgb1
CALL rrtm_kgb2
CALL rrtm_kgb3
CALL rrtm_kgb4
CALL rrtm_kgb5
CALL rrtm_kgb6
CALL rrtm_kgb7
CALL rrtm_kgb8
CALL rrtm_kgb9
CALL rrtm_kgb10
CALL rrtm_kgb11
CALL rrtm_kgb12
CALL rrtm_kgb13
CALL rrtm_kgb14
CALL rrtm_kgb15
CALL rrtm_kgb16

!  Calculate lookup tables for functions needed in routine TAUMOL (TAUGB2)

corr1(0) = 1.0_jprb
corr1(200) = 1.0_jprb
corr2(0) = 1.0_jprb
corr2(200) = 1.0_jprb
DO i = 1,199
  z_fp = 0.005_jprb*REAL(i)
  z_rtfp = sqrt(z_fp)
  corr1(i) = z_rtfp/z_fp
  corr2(i) = (1.0_jprb-z_rtfp)/(1.0_jprb-z_fp)
ENDDO

!  Perform g-point reduction from 16 per band (256 total points) to
!  a band dependant number (140 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,jpband
  iprsm = 0
  IF (ngc(ibnd) < 16) THEN
    DO igc = 1,ngc(ibnd)
      igcsm = igcsm + 1
      z_wtsum = 0.0_jprb
      DO ipr = 1, ngn(igcsm)
        iprsm = iprsm + 1
        z_wtsum = z_wtsum + wt(iprsm)
      ENDDO
      z_wtsm(igc) = z_wtsum
    ENDDO
    DO ig = 1,ng(ibnd)
      ind = (ibnd-1)*16 + ig
      rwgt(ind) = wt(ig)/z_wtsm(ngm(ind))
    ENDDO
  ELSE
    DO ig = 1,ng(ibnd)
      igcsm = igcsm + 1
      ind = (ibnd-1)*16 + ig
      rwgt(ind) = 1.0_jprb
    ENDDO
  ENDIF
ENDDO

!  Initialize arrays for combined Planck fraction data.

DO ipt = 1,13
  DO ipr = 1, jpgpt
    frefa(ipr,ipt) = 0.0_jprb
    frefadf(ipr,ipt) = 0.0_jprb
  ENDDO
ENDDO
DO ipt = 1,6
  DO ipr = 1, jpgpt
    frefb(ipr,ipt) = 0.0_jprb
    frefbdf(ipr,ipt) = 0.0_jprb
  ENDDO
ENDDO

!  Reduce g-points for relevant data in each LW spectral band.

CALL rrtm_cmbgb1
CALL rrtm_cmbgb2
CALL rrtm_cmbgb3
CALL rrtm_cmbgb4
CALL rrtm_cmbgb5
CALL rrtm_cmbgb6
CALL rrtm_cmbgb7
CALL rrtm_cmbgb8
CALL rrtm_cmbgb9
CALL rrtm_cmbgb10
CALL rrtm_cmbgb11
CALL rrtm_cmbgb12
CALL rrtm_cmbgb13
CALL rrtm_cmbgb14
CALL rrtm_cmbgb15
CALL rrtm_cmbgb16

IF (lhook) CALL dr_hook('RRTM_INIT_140GP',1,zhook_handle)
END SUBROUTINE rrtm_init_140gp