rrtm_cmbgb1.F90

Go to the documentation of this file.

!***************************************************************************
SUBROUTINE rrtm_cmbgb1
!***************************************************************************

!  The subroutines CMBGB1->CMBGB16 input the absorption coefficient
!  data for each band, which are defined for 16 g-points and 16 spectral
!  bands. The data are combined with appropriate weighting following the
!  g-point mapping arrays specified in RRTMINIT.  Plank fraction data
!  in arrays FRACREFA and FRACREFB are combined without weighting.  All
!  g-point reduced data are put into new arrays for use in RRTM.

!  BAND 1:  10-250 cm-1 (low - H2O; high - H2O)
!***************************************************************************
!  INSTRUCTION EQUIVALENCE SUPPRESSED (H. Gallée, LGGE, 15 décembre 2003)
!***************************************************************************

! Parameters
#include "tsmbkind.h"

USE parrrtm  , ONLY : jpband   ,jpg      ,jpxsec   ,jpgpt 

USE yoerrto1 , ONLY : kao , kbo  , selfrefo, forrefo, fracrefao,fracrefbo
USE yoerrta1 , ONLY : ka  , kb   , selfref , forref , fracrefa ,fracrefb      &
             &      , absa, absb , ng1
USE yoerrtrwt, ONLY : frefa    ,frefb    ,frefadf  ,frefbdf   ,rwgt
USE yoerrtftr, ONLY : ngc      ,ngs      ,ngn      ,ngb       ,ngm     , wt

IMPLICIT NONE

!     LOCAL INTEGER SCALARS
integer_m :: igc, ipr, iprsm, jp, jt
integer_m :: meq, neq                    ! To force equivalence, HG, 13-DEC-2003

!     LOCAL REAL SCALARS
real_b :: sumf1, sumf2, sumk


DO jt = 1,5
  DO jp = 1,13
    iprsm = 0
    DO igc = 1,ngc(1)
      sumk = _zero_
      DO ipr = 1, ngn(igc)
        iprsm = iprsm + 1

        sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm)
      ENDDO

      ka(jt,jp,igc) = sumk
    ENDDO
  ENDDO
  DO jp = 13,59
    iprsm = 0
    DO igc = 1,ngc(1)
      sumk = _zero_
      DO ipr = 1, ngn(igc)
        iprsm = iprsm + 1

        sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm)
      ENDDO

      kb(jt,jp,igc) = sumk
    ENDDO
  ENDDO
ENDDO

DO jt = 1,10
  iprsm = 0
  DO igc = 1,ngc(1)
    sumk = _zero_
    DO ipr = 1, ngn(igc)
      iprsm = iprsm + 1

      sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm)
    ENDDO

    selfref(jt,igc) = sumk
  ENDDO
ENDDO

iprsm = 0
DO igc = 1,ngc(1)
  sumk = _zero_
  sumf1 = _zero_
  sumf2 = _zero_
  DO ipr = 1, ngn(igc)
    iprsm = iprsm + 1



    sumk = sumk + forrefo(iprsm)*rwgt(iprsm)
    sumf1= sumf1+ fracrefao(iprsm)
    sumf2= sumf2+ fracrefbo(iprsm)
  ENDDO



  forref(igc) = sumk
  fracrefa(igc) = sumf1
  fracrefb(igc) = sumf2
ENDDO

DO igc = 1,ngc(1)


  frefa(igc,1) = fracrefa(igc)
  frefb(igc,1) = fracrefb(igc)
ENDDO


! +--Force the equivalence: BEGIN (HG, 13-DEC-2003)
! +  ============================

! +--ABSA
! +  ^^^^
         jt  = 0
         jp  = 1
         igc = 1
      DO neq=1,ng1
      DO meq=1,65
             jt =  jt  + 1
       IF  ( jt == 5   + 1 )                                        THEN
             jt =  1
             jp =  jp  + 1
        IF ( jp == 13  + 1 )                                        THEN
             jp =  1
             igc=  igc + 1
        END IF
       END IF
             absa(meq,neq) = ka(jt,jp,igc)
      ENDDO
      ENDDO

! +--ABSB
! +  ^^^^
         jt  = 0
         jp  = 13
         igc = 1
      DO neq=1,ng1
      DO meq=1,235
             jt =  jt  + 1
       IF  ( jt == 5   + 1 )                                        THEN
             jt =  1
             jp =  jp  + 1
        IF ( jp == 59  + 1 )                                        THEN
             jp =  13
             igc=  igc + 1
        END IF
       END IF
             absb(meq,neq) = kb(jt,jp,igc)
      ENDDO
      ENDDO

! +--Force the equivalence: END   (HG, 13-DEC-2003)
! +  ==========================


RETURN
END SUBROUTINE rrtm_cmbgb1