rrtm_cmbgb8.F90

Go to the documentation of this file.

!***************************************************************************
SUBROUTINE rrtm_cmbgb8
!***************************************************************************

!     BAND 8:  1080-1180 cm-1 (low (i.e.>~300mb) - H2O; high - O3)
!***************************************************************************

! Parameters
#include "tsmbkind.h"

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

USE yoerrto8 , ONLY : kao     ,kbo     ,selfrefo   ,fracrefao  ,&
           &fracrefbo, absco2ao,absco2bo,absn2oao   ,absn2obo   ,&
           &cfc12o   , cfc22adjo
USE yoerrta8 , ONLY : ka      ,kb      ,selfref    ,fracrefa   ,&
           &fracrefb , absco2a ,absco2b ,absn2oa   ,absn2ob    ,&
           &cfc12    , cfc22adj,absa    ,absb      ,ng8
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, sumk1, sumk2, sumk3, sumk4, sumk5, sumk6


DO jt = 1,5
  DO jp = 1,7
    iprsm = 0
    DO igc = 1,ngc(8)
      sumk = _zero_
      DO ipr = 1, ngn(ngs(7)+igc)
        iprsm = iprsm + 1
        sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+112)
      ENDDO
      ka(jt,jp,igc) = sumk
    ENDDO
  ENDDO
ENDDO
DO jt = 1,5
  DO jp = 7,59
    iprsm = 0
    DO igc = 1,ngc(8)
      sumk = _zero_
      DO ipr = 1, ngn(ngs(7)+igc)
        iprsm = iprsm + 1
        sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+112)
      ENDDO
      kb(jt,jp,igc) = sumk
    ENDDO
  ENDDO
ENDDO

DO jt = 1,10
  iprsm = 0
  DO igc = 1,ngc(8)
    sumk = _zero_
    DO ipr = 1, ngn(ngs(7)+igc)
      iprsm = iprsm + 1
      sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+112)
    ENDDO
    selfref(jt,igc) = sumk
  ENDDO
ENDDO

iprsm = 0
DO igc = 1,ngc(8)
  sumf1= _zero_
  sumf2= _zero_
  sumk1= _zero_
  sumk2= _zero_
  sumk3= _zero_
  sumk4= _zero_
  sumk5= _zero_
  sumk6= _zero_
  DO ipr = 1, ngn(ngs(7)+igc)
    iprsm = iprsm + 1
    sumf1= sumf1+ fracrefao(iprsm)
    sumf2= sumf2+ fracrefbo(iprsm)
    sumk1= sumk1+ absco2ao(iprsm)*rwgt(iprsm+112)
    sumk2= sumk2+ absco2bo(iprsm)*rwgt(iprsm+112)
    sumk3= sumk3+ absn2oao(iprsm)*rwgt(iprsm+112)
    sumk4= sumk4+ absn2obo(iprsm)*rwgt(iprsm+112)
    sumk5= sumk5+ cfc12o(iprsm)*rwgt(iprsm+112)
    sumk6= sumk6+ cfc22adjo(iprsm)*rwgt(iprsm+112)
  ENDDO
  fracrefa(igc) = sumf1
  fracrefb(igc) = sumf2
  absco2a(igc) = sumk1
  absco2b(igc) = sumk2
  absn2oa(igc) = sumk3
  absn2ob(igc) = sumk4
  cfc12(igc) = sumk5
  cfc22adj(igc) = sumk6
ENDDO

DO igc = 1,ngc(8)
  frefa(ngs(7)+igc,1) = fracrefa(igc)
  frefb(ngs(7)+igc,1) = fracrefb(igc)
ENDDO


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

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

! +--ABSB
! +  ^^^^
         jt  = 0
         jp  = 7
         igc = 1
      DO neq=1,ng8
      DO meq=1,265
             jt =  jt  + 1
       IF  ( jt == 5   + 1 )                                        THEN
             jt =  1
             jp =  jp  + 1
        IF ( jp == 59  + 1 )                                        THEN
             jp =  7
             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_cmbgb8