rrtm_init_140gp.F90

Go to the documentation of this file.

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

! Parameters
#include "tsmbkind.h"

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

! Local

IMPLICIT NONE
real_b :: wtsm(jpg)

!     LOCAL INTEGER SCALARS
integer_m :: i, ibnd, ig, igc, igcsm, ind, ipr, iprsm, ipt

!     LOCAL REAL SCALARS
real_b :: fp, rtfp, wtsum


!  Calculate lookup tables for functions needed in routine TAUMOL (TAUGB2)
corr1(0) = _one_
corr1(200) = _one_
corr2(0) = _one_
corr2(200) = _one_
DO i = 1,199
  fp = 0.005_jprb*REAL(i)
  rtfp = sqrt(fp)
  corr1(i) = rtfp/fp
  corr2(i) = (_one_-rtfp)/(_one_-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
      wtsum = _zero_
      DO ipr = 1, ngn(igcsm)
        iprsm = iprsm + 1
        wtsum = wtsum + wt(iprsm)
      ENDDO
      wtsm(igc) = wtsum
    ENDDO
    DO ig = 1,ng(ibnd)
      ind = (ibnd-1)*16 + ig
      rwgt(ind) = wt(ig)/wtsm(ngm(ind))
    ENDDO
  ELSE
    DO ig = 1,ng(ibnd)
      igcsm = igcsm + 1
      ind = (ibnd-1)*16 + ig
      rwgt(ind) = _one_
    ENDDO
  ENDIF
ENDDO

!  Initialize arrays for combined Planck fraction data.

DO ipt = 1,13
  DO ipr = 1, jpgpt
    frefa(ipr,ipt) = _zero_
    frefadf(ipr,ipt) = _zero_
  ENDDO
ENDDO
DO ipt = 1,6
  DO ipr = 1, jpgpt
    frefb(ipr,ipt) = _zero_
    frefbdf(ipr,ipt) = _zero_
  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

RETURN
END SUBROUTINE rrtm_init_140gp