source: LMDZ5/trunk/libf/phymar/rrtm_cmbgb4.F90 @ 3847

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