source: LMDZ6/branches/DYNAMICO-conv/libf/phymar/rrtm_cmbgb9.F90 @ 3106

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

Inclusion de la physique de MAR


Integration of MAR physics

File size: 4.0 KB
Line 
1!***************************************************************************
2SUBROUTINE RRTM_CMBGB9
3!***************************************************************************
4
5!     BAND 9:  1180-1390 cm-1 (low - H2O,CH4; high - CH4)
6!***************************************************************************
7
8! Parameters
9#include "tsmbkind.h"
10
11USE PARRRTM  , ONLY : JPBAND  ,JPG     ,JPXSEC     ,JPGPT
12
13USE YOERRTO9 , ONLY : KAO     ,KBO     ,SELFREFO   ,FRACREFAO ,&
14           &FRACREFBO, ABSN2OO
15USE YOERRTA9 , ONLY : KA      ,KB      ,SELFREF    ,FRACREFA  ,&
16             &        FRACREFB,ABSN2O                         ,&
17             &        ABSA    ,ABSB    ,NG9
18USE YOERRTRWT, ONLY : FREFA    ,FREFB    ,FREFADF  ,FREFBDF   ,RWGT
19USE YOERRTFTR, ONLY : NGC      ,NGS      ,NGN      ,NGB       ,NGM     , WT
20
21IMPLICIT NONE
22
23!     LOCAL INTEGER SCALARS
24INTEGER_M :: IGC, IPR, IPRSM, JN, JND, JNDC, JP, JT
25INTEGER_M :: MEQ, NEQ                    ! To force equivalence, HG, 13-DEC-2003
26
27!     LOCAL REAL SCALARS
28REAL_B :: SUMF, SUMK
29
30
31DO JN = 1,11
32  DO JT = 1,5
33    DO JP = 1,13
34      IPRSM = 0
35      DO IGC = 1,NGC(9)
36        SUMK = _ZERO_
37        DO IPR = 1, NGN(NGS(8)+IGC)
38          IPRSM = IPRSM + 1
39
40          SUMK = SUMK + KAO(JN,JT,JP,IPRSM)*RWGT(IPRSM+128)
41        ENDDO
42
43        KA(JN,JT,JP,IGC) = SUMK
44      ENDDO
45    ENDDO
46  ENDDO
47ENDDO
48
49DO JT = 1,5
50  DO JP = 13,59
51    IPRSM = 0
52    DO IGC = 1,NGC(9)
53      SUMK = _ZERO_
54      DO IPR = 1, NGN(NGS(8)+IGC)
55        IPRSM = IPRSM + 1
56
57        SUMK = SUMK + KBO(JT,JP,IPRSM)*RWGT(IPRSM+128)
58      ENDDO
59
60      KB(JT,JP,IGC) = SUMK
61    ENDDO
62  ENDDO
63ENDDO
64
65DO JT = 1,10
66  IPRSM = 0
67  DO IGC = 1,NGC(9)
68    SUMK = _ZERO_
69    DO IPR = 1, NGN(NGS(8)+IGC)
70      IPRSM = IPRSM + 1
71
72      SUMK = SUMK + SELFREFO(JT,IPRSM)*RWGT(IPRSM+128)
73    ENDDO
74
75    SELFREF(JT,IGC) = SUMK
76  ENDDO
77ENDDO
78
79DO JN = 1,3
80  IPRSM = 0
81  DO IGC = 1,NGC(9)
82    SUMK = _ZERO_
83    DO IPR = 1, NGN(NGS(8)+IGC)
84      IPRSM = IPRSM + 1
85      JND = (JN-1)*16
86
87      SUMK = SUMK + ABSN2OO(JND+IPRSM)*RWGT(IPRSM+128)
88    ENDDO
89    JNDC = (JN-1)*NGC(9)
90
91    ABSN2O(JNDC+IGC) = SUMK
92  ENDDO
93ENDDO
94
95DO JP = 1,9
96  IPRSM = 0
97  DO IGC = 1,NGC(9)
98    SUMF = _ZERO_
99    DO IPR = 1, NGN(NGS(8)+IGC)
100      IPRSM = IPRSM + 1
101
102      SUMF = SUMF + FRACREFAO(IPRSM,JP)
103    ENDDO
104
105    FRACREFA(IGC,JP) = SUMF
106  ENDDO
107ENDDO
108
109IPRSM = 0
110DO IGC = 1,NGC(9)
111  SUMF = _ZERO_
112  DO IPR = 1, NGN(NGS(8)+IGC)
113    IPRSM = IPRSM + 1
114
115    SUMF = SUMF + FRACREFBO(IPRSM)
116  ENDDO
117
118  FRACREFB(IGC) = SUMF
119ENDDO
120
121DO JP = 1,9
122  DO IGC = 1,NGC(9)
123
124    FREFA(NGS(8)+IGC,JP) = FRACREFA(IGC,JP)
125  ENDDO
126ENDDO
127DO JP = 1,8
128  DO IGC = 1,NGC(9)
129
130
131    FREFADF(NGS(8)+IGC,JP) = FRACREFA(IGC,JP+1) -FRACREFA(IGC,JP)
132  ENDDO
133ENDDO
134DO IGC = 1,NGC(9)
135
136  FREFB(NGS(8)+IGC,1) = FRACREFB(IGC)
137ENDDO
138
139
140! +--Force the equivalence: BEGIN (HG, 13-DEC-2003)
141! +  ============================
142
143! +--ABSA
144! +  ^^^^
145         JN  = 0
146         JT  = 1
147         JP  = 1
148         IGC = 1
149      DO NEQ=1,NG9
150      DO MEQ=1,715
151             JN =  JN  + 1
152      IF   ( JN == 11  + 1)                                         THEN
153             JN =  1
154             JT =  JT  + 1
155       IF  ( JT == 5   + 1 )                                        THEN
156             JT =  1
157             JP =  JP  + 1
158        IF ( JP == 13  + 1 )                                        THEN
159             JP =  1
160             IGC=  IGC + 1
161        END IF
162       END IF
163      END IF
164             ABSA(MEQ,NEQ) = KA(JN,JT,JP,IGC)
165      ENDDO
166      ENDDO
167
168! +--ABSB
169! +  ^^^^
170         JT  = 0
171         JP  = 13
172         IGC = 1
173      DO NEQ=1,NG9
174      DO MEQ=1,235
175             JT =  JT  + 1
176       IF  ( JT == 5   + 1 )                                        THEN
177             JT =  1
178             JP =  JP  + 1
179        IF ( JP == 59  + 1 )                                        THEN
180             JP =  13
181             IGC=  IGC + 1
182        END IF
183       END IF
184             ABSB(MEQ,NEQ) = KB(JT,JP,IGC)
185      ENDDO
186      ENDDO
187
188! +--Force the equivalence: END   (HG, 13-DEC-2003)
189! +  ==========================
190
191
192RETURN
193END SUBROUTINE RRTM_CMBGB9
Note: See TracBrowser for help on using the repository browser.