rrtm_cmbgb3.F90

Go to the documentation of this file.

!***************************************************************************
SUBROUTINE rrtm_cmbgb3
!***************************************************************************

!     BAND 3:  500-630 cm-1 (low - H2O,CO2; high - H2O,CO2)
!***************************************************************************

! Parameters
#include "tsmbkind.h"

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

USE yoerrto3 , ONLY : kao     ,kbo     ,selfrefo   ,fracrefao  ,&
           &fracrefbo  ,forrefo    ,absn2oao   ,absn2obo
USE yoerrta3 , ONLY : ka      ,kb      ,selfref    ,fracrefa   ,&
             &        fracrefb,forref  ,absn2oa    ,absn2ob    ,&
             &        absa    ,absb    ,ng3
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, jn, jp, jt
integer_m :: meq, neq                    ! To force equivalence, HG, 13-DEC-2003

!     LOCAL REAL SCALARS
real_b :: sumf, sumk, sumk1, sumk2, sumk3


DO jn = 1,10
  DO jt = 1,5
    DO jp = 1,13
      iprsm = 0
      DO igc = 1,ngc(3)
        sumk = _zero_
        DO ipr = 1, ngn(ngs(2)+igc)
          iprsm = iprsm + 1

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

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

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

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

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


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


    selfref(jt,igc) = sumk
    fracrefa(igc,jt) = sumf
  ENDDO
ENDDO

DO jp = 1,5
  iprsm = 0
  DO igc = 1,ngc(3)
    sumf = _zero_
    DO ipr = 1, ngn(ngs(2)+igc)
      iprsm = iprsm + 1

      sumf = sumf + fracrefbo(iprsm,jp)
    ENDDO

    fracrefb(igc,jp) = sumf
  ENDDO
ENDDO

iprsm = 0
DO igc = 1,ngc(3)
  sumk1= _zero_
  sumk2= _zero_
  sumk3= _zero_
  DO ipr = 1, ngn(ngs(2)+igc)
    iprsm = iprsm + 1



    sumk1= sumk1+ forrefo(iprsm)*rwgt(iprsm+32)
    sumk2= sumk2+ absn2oao(iprsm)*rwgt(iprsm+32)
    sumk3= sumk3+ absn2obo(iprsm)*rwgt(iprsm+32)
  ENDDO



  forref(igc) = sumk1
  absn2oa(igc) = sumk2
  absn2ob(igc) = sumk3
ENDDO

DO jp = 1,10
  DO igc = 1,ngc(3)

    frefa(ngs(2)+igc,jp) = fracrefa(igc,jp)
  ENDDO
ENDDO
DO jp = 1,9
  DO igc = 1,ngc(3)


    frefadf(ngs(2)+igc,jp) = fracrefa(igc,jp+1) -fracrefa(igc,jp)
  ENDDO
ENDDO
DO jp = 1,5
  DO igc = 1,ngc(3)

    frefb(ngs(2)+igc,jp) = fracrefb(igc,jp)
  ENDDO
ENDDO
DO jp = 1,4
  DO igc = 1,ngc(3)


    frefbdf(ngs(2)+igc,jp) = fracrefb(igc,jp+1) -fracrefb(igc,jp)
  ENDDO
ENDDO


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

! +--ABSA
! +  ^^^^
         jn  = 0
         jt  = 1
         jp  = 1
         igc = 1
      DO neq=1,ng3
      DO meq=1,650
             jn =  jn  + 1
      IF   ( jn == 10  + 1)                                         THEN
             jn =  1
             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
      END IF
             absa(meq,neq) = ka(jn,jt,jp,igc)
      ENDDO
      ENDDO

! +--ABSB
! +  ^^^^
         jn  = 0
         jt  = 1
         jp  = 13
         igc = 1
      DO neq=1,ng3
      DO meq=1,1175
             jn =  jn  + 1
      IF   ( jn == 5   + 1)                                         THEN
             jn =  1
             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
      END IF
             absb(meq,neq) = kb(jn,jt,jp,igc)
      ENDDO
      ENDDO

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


RETURN
END SUBROUTINE rrtm_cmbgb3