source: LMDZ6/branches/DYNAMICO-conv/libf/phymar/rrtm_cmbgb8.F90 @ 3024

Last change on this file since 3024 was 2089, checked in by Laurent Fairhead, 10 years ago

Inclusion de la physique de MAR


Integration of MAR physics

File size: 3.9 KB
Line 
1!***************************************************************************
2SUBROUTINE RRTM_CMBGB8
3!***************************************************************************
4
5!     BAND 8:  1080-1180 cm-1 (low (i.e.>~300mb) - H2O; high - O3)
6!***************************************************************************
7
8! Parameters
9#include "tsmbkind.h"
10
11USE PARRRTM  , ONLY : JPBAND   ,JPG      ,JPXSEC   ,JPGPT
12
13USE YOERRTO8 , ONLY : KAO     ,KBO     ,SELFREFO   ,FRACREFAO  ,&
14           &FRACREFBO, ABSCO2AO,ABSCO2BO,ABSN2OAO   ,ABSN2OBO   ,&
15           &CFC12O   , CFC22ADJO
16USE YOERRTA8 , ONLY : KA      ,KB      ,SELFREF    ,FRACREFA   ,&
17           &FRACREFB , ABSCO2A ,ABSCO2B ,ABSN2OA   ,ABSN2OB    ,&
18           &CFC12    , CFC22ADJ,ABSA    ,ABSB      ,NG8
19USE YOERRTRWT, ONLY : FREFA    ,FREFB    ,FREFADF  ,FREFBDF   ,RWGT
20USE YOERRTFTR, ONLY : NGC      ,NGS      ,NGN      ,NGB       ,NGM     , WT
21
22IMPLICIT NONE
23
24!     LOCAL INTEGER SCALARS
25INTEGER_M :: IGC, IPR, IPRSM, JP, JT
26INTEGER_M :: MEQ, NEQ                    ! To force equivalence, HG, 13-DEC-2003
27
28!     LOCAL REAL SCALARS
29REAL_B :: SUMF1, SUMF2, SUMK, SUMK1, SUMK2, SUMK3, SUMK4, SUMK5, SUMK6
30
31
32DO JT = 1,5
33  DO JP = 1,7
34    IPRSM = 0
35    DO IGC = 1,NGC(8)
36      SUMK = _ZERO_
37      DO IPR = 1, NGN(NGS(7)+IGC)
38        IPRSM = IPRSM + 1
39        SUMK = SUMK + KAO(JT,JP,IPRSM)*RWGT(IPRSM+112)
40      ENDDO
41      KA(JT,JP,IGC) = SUMK
42    ENDDO
43  ENDDO
44ENDDO
45DO JT = 1,5
46  DO JP = 7,59
47    IPRSM = 0
48    DO IGC = 1,NGC(8)
49      SUMK = _ZERO_
50      DO IPR = 1, NGN(NGS(7)+IGC)
51        IPRSM = IPRSM + 1
52        SUMK = SUMK + KBO(JT,JP,IPRSM)*RWGT(IPRSM+112)
53      ENDDO
54      KB(JT,JP,IGC) = SUMK
55    ENDDO
56  ENDDO
57ENDDO
58
59DO JT = 1,10
60  IPRSM = 0
61  DO IGC = 1,NGC(8)
62    SUMK = _ZERO_
63    DO IPR = 1, NGN(NGS(7)+IGC)
64      IPRSM = IPRSM + 1
65      SUMK = SUMK + SELFREFO(JT,IPRSM)*RWGT(IPRSM+112)
66    ENDDO
67    SELFREF(JT,IGC) = SUMK
68  ENDDO
69ENDDO
70
71IPRSM = 0
72DO IGC = 1,NGC(8)
73  SUMF1= _ZERO_
74  SUMF2= _ZERO_
75  SUMK1= _ZERO_
76  SUMK2= _ZERO_
77  SUMK3= _ZERO_
78  SUMK4= _ZERO_
79  SUMK5= _ZERO_
80  SUMK6= _ZERO_
81  DO IPR = 1, NGN(NGS(7)+IGC)
82    IPRSM = IPRSM + 1
83    SUMF1= SUMF1+ FRACREFAO(IPRSM)
84    SUMF2= SUMF2+ FRACREFBO(IPRSM)
85    SUMK1= SUMK1+ ABSCO2AO(IPRSM)*RWGT(IPRSM+112)
86    SUMK2= SUMK2+ ABSCO2BO(IPRSM)*RWGT(IPRSM+112)
87    SUMK3= SUMK3+ ABSN2OAO(IPRSM)*RWGT(IPRSM+112)
88    SUMK4= SUMK4+ ABSN2OBO(IPRSM)*RWGT(IPRSM+112)
89    SUMK5= SUMK5+ CFC12O(IPRSM)*RWGT(IPRSM+112)
90    SUMK6= SUMK6+ CFC22ADJO(IPRSM)*RWGT(IPRSM+112)
91  ENDDO
92  FRACREFA(IGC) = SUMF1
93  FRACREFB(IGC) = SUMF2
94  ABSCO2A(IGC) = SUMK1
95  ABSCO2B(IGC) = SUMK2
96  ABSN2OA(IGC) = SUMK3
97  ABSN2OB(IGC) = SUMK4
98  CFC12(IGC) = SUMK5
99  CFC22ADJ(IGC) = SUMK6
100ENDDO
101
102DO IGC = 1,NGC(8)
103  FREFA(NGS(7)+IGC,1) = FRACREFA(IGC)
104  FREFB(NGS(7)+IGC,1) = FRACREFB(IGC)
105ENDDO
106
107
108! +--Force the equivalence: BEGIN (HG, 13-DEC-2003)
109! +  ============================
110
111! +--ABSA
112! +  ^^^^
113         JT  = 0
114         JP  = 1
115         IGC = 1
116      DO NEQ=1,NG8
117      DO MEQ=1,35
118             JT =  JT  + 1
119       IF  ( JT == 5   + 1 )                                        THEN
120             JT =  1
121             JP =  JP  + 1
122        IF ( JP == 7   + 1 )                                        THEN
123             JP =  1
124             IGC=  IGC + 1
125        END IF
126       END IF
127             ABSA(MEQ,NEQ) = KA(JT,JP,IGC)
128      ENDDO
129      ENDDO
130
131! +--ABSB
132! +  ^^^^
133         JT  = 0
134         JP  = 7
135         IGC = 1
136      DO NEQ=1,NG8
137      DO MEQ=1,265
138             JT =  JT  + 1
139       IF  ( JT == 5   + 1 )                                        THEN
140             JT =  1
141             JP =  JP  + 1
142        IF ( JP == 59  + 1 )                                        THEN
143             JP =  7
144             IGC=  IGC + 1
145        END IF
146       END IF
147             ABSB(MEQ,NEQ) = KB(JT,JP,IGC)
148      ENDDO
149      ENDDO
150
151! +--Force the equivalence: END   (HG, 13-DEC-2003)
152! +  ==========================
153
154
155RETURN
156END SUBROUTINE RRTM_CMBGB8
Note: See TracBrowser for help on using the repository browser.