source: dynamico_lmdz/aquaplanet/LMDZ5/libf/phymar/rrtm_cmbgb5.F90 @ 4031

Last change on this file since 4031 was 3990, checked in by millour, 8 years ago

An updated LMDZ5 (based on LMDZ rev 2786) to play with.
EM
File size: 4.3 KB
Line 
1!***************************************************************************
2SUBROUTINE RRTM_CMBGB5
3!***************************************************************************
4
5!     BAND 5:  700-820 cm-1 (low - H2O,CO2; high - O3,CO2)
6!***************************************************************************
7
8! Parameters
9#include "tsmbkind.h"
10
11USE PARRRTM  , ONLY : JPBAND   ,JPG      ,JPXSEC   ,JPGPT
12
13USE YOERRTO5 , ONLY : KAO     ,KBO     ,SELFREFO   ,FRACREFAO  ,&
14           &FRACREFBO, CCL4O
15USE YOERRTA5 , ONLY : KA      ,KB      ,SELFREF    ,FRACREFA   ,&
16             &        FRACREFB,CCL4                            ,&
17             &        ABSA    ,ABSB    ,NG5
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, 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,9
32  DO JT = 1,5
33    DO JP = 1,13
34      IPRSM = 0
35      DO IGC = 1,NGC(5)
36        SUMK = _ZERO_
37        DO IPR = 1, NGN(NGS(4)+IGC)
38          IPRSM = IPRSM + 1
39
40          SUMK = SUMK + KAO(JN,JT,JP,IPRSM)*RWGT(IPRSM+64)
41        ENDDO
42
43        KA(JN,JT,JP,IGC) = SUMK
44      ENDDO
45    ENDDO
46  ENDDO
47ENDDO
48DO JN = 1,5
49  DO JT = 1,5
50    DO JP = 13,59
51      IPRSM = 0
52      DO IGC = 1,NGC(5)
53        SUMK = _ZERO_
54        DO IPR = 1, NGN(NGS(4)+IGC)
55          IPRSM = IPRSM + 1
56
57          SUMK = SUMK + KBO(JN,JT,JP,IPRSM)*RWGT(IPRSM+64)
58        ENDDO
59
60        KB(JN,JT,JP,IGC) = SUMK
61      ENDDO
62    ENDDO
63  ENDDO
64ENDDO
65
66DO JT = 1,10
67  IPRSM = 0
68  DO IGC = 1,NGC(5)
69    SUMK = _ZERO_
70    DO IPR = 1, NGN(NGS(4)+IGC)
71      IPRSM = IPRSM + 1
72
73      SUMK = SUMK + SELFREFO(JT,IPRSM)*RWGT(IPRSM+64)
74    ENDDO
75
76    SELFREF(JT,IGC) = SUMK
77  ENDDO
78ENDDO
79
80DO JP = 1,9
81  IPRSM = 0
82  DO IGC = 1,NGC(5)
83    SUMF = _ZERO_
84    DO IPR = 1, NGN(NGS(4)+IGC)
85      IPRSM = IPRSM + 1
86
87      SUMF = SUMF + FRACREFAO(IPRSM,JP)
88    ENDDO
89
90    FRACREFA(IGC,JP) = SUMF
91  ENDDO
92ENDDO
93
94DO JP = 1,5
95  IPRSM = 0
96  DO IGC = 1,NGC(5)
97    SUMF = _ZERO_
98    DO IPR = 1, NGN(NGS(4)+IGC)
99      IPRSM = IPRSM + 1
100
101      SUMF = SUMF + FRACREFBO(IPRSM,JP)
102    ENDDO
103
104    FRACREFB(IGC,JP) = SUMF
105  ENDDO
106ENDDO
107
108IPRSM = 0
109DO IGC = 1,NGC(5)
110  SUMK = _ZERO_
111  DO IPR = 1, NGN(NGS(4)+IGC)
112    IPRSM = IPRSM + 1
113
114    SUMK = SUMK + CCL4O(IPRSM)*RWGT(IPRSM+64)
115  ENDDO
116
117  CCL4(IGC) = SUMK
118ENDDO
119
120DO JP = 1,9
121  DO IGC = 1,NGC(5)
122
123    FREFA(NGS(4)+IGC,JP) = FRACREFA(IGC,JP)
124  ENDDO
125ENDDO
126DO JP = 1,8
127  DO IGC = 1,NGC(5)
128
129
130    FREFADF(NGS(4)+IGC,JP) = FRACREFA(IGC,JP+1) -FRACREFA(IGC,JP)
131  ENDDO
132ENDDO
133DO JP = 1,5
134  DO IGC = 1,NGC(5)
135
136    FREFB(NGS(4)+IGC,JP) = FRACREFB(IGC,JP)
137  ENDDO
138ENDDO
139DO JP = 1,4
140  DO IGC = 1,NGC(5)
141
142
143    FREFBDF(NGS(4)+IGC,JP) = FRACREFB(IGC,JP+1) -FRACREFB(IGC,JP)
144  ENDDO
145ENDDO
146
147
148! +--Force the equivalence: BEGIN (HG, 13-DEC-2003)
149! +  ============================
150
151! +--ABSA
152! +  ^^^^
153         JN  = 0
154         JT  = 1
155         JP  = 1
156         IGC = 1
157      DO NEQ=1,NG5
158      DO MEQ=1,585
159             JN =  JN  + 1
160      IF   ( JN == 9   + 1)                                         THEN
161             JN =  1
162             JT =  JT  + 1
163       IF  ( JT == 5   + 1 )                                        THEN
164             JT =  1
165             JP =  JP  + 1
166        IF ( JP == 13  + 1 )                                        THEN
167             JP =  1
168             IGC=  IGC + 1
169        END IF
170       END IF
171      END IF
172             ABSA(MEQ,NEQ) = KA(JN,JT,JP,IGC)
173      ENDDO
174      ENDDO
175
176! +--ABSB
177! +  ^^^^
178         JN  = 0
179         JT  = 1
180         JP  = 13
181         IGC = 1
182      DO NEQ=1,NG5
183      DO MEQ=1,1175
184             JN =  JN  + 1
185      IF   ( JN == 5   + 1)                                         THEN
186             JN =  1
187             JT =  JT  + 1
188       IF  ( JT == 5   + 1 )                                        THEN
189             JT =  1
190             JP =  JP  + 1
191        IF ( JP == 59  + 1 )                                        THEN
192             JP =  13
193             IGC=  IGC + 1
194        END IF
195       END IF
196      END IF
197             ABSB(MEQ,NEQ) = KB(JN,JT,JP,IGC)
198      ENDDO
199      ENDDO
200
201! +--Force the equivalence: END   (HG, 13-DEC-2003)
202! +  ==========================
203
204
205RETURN
206END SUBROUTINE RRTM_CMBGB5
Note: See TracBrowser for help on using the repository browser.