source: LMDZ5/branches/testing/libf/phymar/rrtm_cmbgb7.F90 @ 5403

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

Merged trunk changes -r2070:2158 into testing branch. Compilation problems introduced by revision r2155 have been corrected by hand

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