source: LMDZ5/branches/IPSLCM6.0.12/libf/phymar/lwvd.F90 @ 5308

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

Inclusion de la physique de MAR

Integration of MAR physics
File size: 6.8 KB
Line 
1SUBROUTINE LWVD &
2 &( KIDIA,  KFDIA, KLON , KLEV  , KTRAER &
3 &, PABCU,  PDBDT &
4 &, PGA  ,  PGB &
5 &, PCNTRB, PDISD, PDISU, PDWFSU &
6 &)
7
8!**** *LWVD*   - L.W., VERTICAL INTEGRATION, DISTANT LAYERS
9
10!     PURPOSE.
11!     --------
12!           CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
13
14!**   INTERFACE.
15!     ----------
16
17!        EXPLICIT ARGUMENTS :
18!        --------------------
19!     ==== INPUTS ===
20! PABCU  : (KLON,NUA,3*KLEV+1) ; ABSORBER AMOUNTS
21! PDBDT  : (KLON,KLEV)         ; LAYER PLANCK FUNCTION GRADIENT
22! PGA, PGB                     ; PADE APPROXIMANTS
23!     ==== OUTPUTS ===
24! PCNTRB : (KLON,KLEV+1,KLEV+1); ENERGY EXCHANGE MATRIX
25! PDIS.. : (KLON,KLEV+1)       ; CONTRIBUTION BY DISTANT LAYERS
26! PDWFSU : (KLON,NSIL)         ; SPECTRAL DOWNWARD FLUX AT SURFACE
27
28!        IMPLICIT ARGUMENTS :   NONE
29!        --------------------
30
31!     METHOD.
32!     -------
33
34!          1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
35!     CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE
36
37!     EXTERNALS.
38!     ----------
39
40!          *LWTT*
41
42!     REFERENCE.
43!     ----------
44
45!        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
46!        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
47
48!     AUTHOR.
49!     -------
50!        JEAN-JACQUES MORCRETTE  *ECMWF*
51
52!     MODIFICATIONS.
53!     --------------
54!        ORIGINAL : 89-07-14
55!        JJ Morcrette 97-04-18 Revised continuum + Surf. Emissiv.
56!-----------------------------------------------------------------------
57
58#include "tsmbkind.h"
59
60USE YOELW    , ONLY : NSIL     ,NIPD     ,NTRA     ,NUA      ,NG1P1
61
62
63IMPLICIT NONE
64
65
66!     DUMMY INTEGER SCALARS
67INTEGER_M :: KFDIA
68INTEGER_M :: KIDIA
69INTEGER_M :: KLEV
70INTEGER_M :: KLON
71INTEGER_M :: KTRAER
72
73
74
75!-----------------------------------------------------------------------
76
77!*       0.1   ARGUMENTS
78!              ---------
79
80
81REAL_B :: PABCU(KLON,NUA,3*KLEV+1)&
82  &,  PDBDT(KLON,NSIL,KLEV)&
83  &,  PGA(KLON,NIPD,2,KLEV)   , PGB(KLON,NIPD,2,KLEV)
84
85REAL_B :: PCNTRB(KLON,KLEV+1,KLEV+1)&
86  &,  PDISD(KLON,KLEV+1)      , PDISU(KLON,KLEV+1)&
87  &,  PDWFSU(KLON,NSIL)
88
89!-----------------------------------------------------------------------
90
91!*       0.2   LOCAL ARRAYS
92!              ------------
93
94REAL_B :: ZTT(KLON,NTRA), ZTT1(KLON,NTRA), ZTT2(KLON,NTRA)
95
96!     LOCAL INTEGER SCALARS
97INTEGER_M :: IJKL, IKD1, IKD2, IKJ, IKJP1, IKM1, IKN,&
98             &IKP1, IKU1, IKU2, ITT, JA, JK, JKJ, JL, JLK
99
100!     LOCAL REAL SCALARS
101REAL_B :: ZWW, ZWW1, ZWW2, ZWW3, ZWW4, ZWW5, ZWW6
102
103
104!-----------------------------------------------------------------------
105
106!*         1.    INITIALIZATION
107!                --------------
108
109!*         1.1     INITIALIZE LAYER CONTRIBUTIONS
110!                  ------------------------------
111
112DO JK = 1, KLEV+1
113  DO JL = KIDIA,KFDIA
114    PDISD(JL,JK) = _ZERO_
115    PDISU(JL,JK) = _ZERO_
116  ENDDO
117ENDDO
118
119!*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
120!                  ---------------------------------
121
122DO JA = 1, NTRA
123  DO JL = KIDIA,KFDIA
124    ZTT (JL,JA) = _ONE_
125    ZTT1(JL,JA) = _ONE_
126    ZTT2(JL,JA) = _ONE_
127  ENDDO
128ENDDO
129
130!     ------------------------------------------------------------------
131
132!*         2.      VERTICAL INTEGRATION
133!                  --------------------
134
135
136!*         2.2     CONTRIBUTION FROM DISTANT LAYERS
137!                  ---------------------------------
138
139
140!*         2.2.1   DISTANT AND ABOVE LAYERS
141!                  ------------------------
142
143
144!*         2.2.2   FIRST UPPER LEVEL
145!                  -----------------
146
147DO JK = 1 , KLEV-1
148  IKP1=JK+1
149  IKN=(JK-1)*NG1P1+1
150  IKD1= JK  *NG1P1+1
151
152  CALL LWTTM &
153   &( KIDIA         , KFDIA          , KLON &
154   &, PGA(1,1,1,JK) , PGB(1,1,1,JK)&
155   &, PABCU(1,1,IKN), PABCU(1,1,IKD1), ZTT1 &
156   &)
157
158
159
160!*         2.2.3   HIGHER UP
161!                  ---------
162
163  ITT=1
164  DO JKJ=IKP1,KLEV
165    IF(ITT == 1) THEN
166      ITT=2
167    ELSE
168      ITT=1
169    ENDIF
170    IKJP1=JKJ+1
171    IKD2= JKJ  *NG1P1+1
172
173    IF(ITT == 1) THEN
174      CALL LWTTM &
175       &( KIDIA         , KFDIA          , KLON &
176       &, PGA(1,1,1,JKJ), PGB(1,1,1,JKJ)&
177       &, PABCU(1,1,IKN), PABCU(1,1,IKD2), ZTT1 &
178       &)
179
180
181    ELSE
182      CALL LWTTM &
183       &( KIDIA         , KFDIA          , KLON &
184       &, PGA(1,1,1,JKJ), PGB(1,1,1,JKJ)&
185       &, PABCU(1,1,IKN), PABCU(1,1,IKD2), ZTT2 &
186       &)
187
188
189    ENDIF
190
191    DO JA = 1, KTRAER
192      DO JL = KIDIA,KFDIA
193        ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*_HALF_
194      ENDDO
195    ENDDO
196
197    DO JL = KIDIA,KFDIA
198      ZWW1=PDBDT(JL,1,JKJ)*ZTT(JL,1)          *ZTT(JL,10)
199      ZWW2=PDBDT(JL,2,JKJ)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
200      ZWW3=PDBDT(JL,3,JKJ)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
201      ZWW4=PDBDT(JL,4,JKJ)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
202      ZWW5=PDBDT(JL,5,JKJ)*ZTT(JL,3)          *ZTT(JL,14)
203      ZWW6=PDBDT(JL,6,JKJ)*ZTT(JL,6)          *ZTT(JL,15)
204      ZWW=ZWW1+ZWW2+ZWW3+ZWW4+ZWW5+ZWW6
205      PDISD(JL,JK)=PDISD(JL,JK)+ZWW
206      PCNTRB(JL,JK,IKJP1)=ZWW
207      IF (JK == 1) THEN
208        PDWFSU(JL,1)=PDWFSU(JL,1)+ZWW1
209        PDWFSU(JL,2)=PDWFSU(JL,2)+ZWW2
210        PDWFSU(JL,3)=PDWFSU(JL,3)+ZWW3
211        PDWFSU(JL,4)=PDWFSU(JL,4)+ZWW4
212        PDWFSU(JL,5)=PDWFSU(JL,5)+ZWW5
213        PDWFSU(JL,6)=PDWFSU(JL,6)+ZWW6
214      ENDIF
215    ENDDO
216
217
218  ENDDO
219ENDDO
220
221
222!*         2.2.4   DISTANT AND BELOW LAYERS
223!                  ------------------------
224
225
226!*         2.2.5   FIRST LOWER LEVEL
227!                  -----------------
228
229DO JK=3,KLEV+1
230  IKN=(JK-1)*NG1P1+1
231  IKM1=JK-1
232  IKJ=JK-2
233  IKU1= IKJ  *NG1P1+1
234
235
236  CALL LWTTM &
237   &( KIDIA          , KFDIA         , KLON &
238   &, PGA(1,1,1,IKJ) , PGB(1,1,1,IKJ)&
239   &, PABCU(1,1,IKU1), PABCU(1,1,IKN), ZTT1 &
240   &)
241
242
243
244
245!*         2.2.6   DOWN BELOW
246!                  ----------
247
248  ITT=1
249  DO JLK=1,IKJ
250    IF(ITT == 1) THEN
251      ITT=2
252    ELSE
253      ITT=1
254    ENDIF
255    IJKL=IKM1-JLK
256    IKU2=(IJKL-1)*NG1P1+1
257
258
259    IF(ITT == 1) THEN
260      CALL LWTTM &
261       &( KIDIA          , KFDIA          , KLON &
262       &, PGA(1,1,1,IJKL), PGB(1,1,1,IJKL)&
263       &, PABCU(1,1,IKU2), PABCU(1,1,IKN) , ZTT1 &
264       &)
265
266
267    ELSE
268      CALL LWTTM &
269       &( KIDIA          , KFDIA          , KLON &
270       &, PGA(1,1,1,IJKL), PGB(1,1,1,IJKL)&
271       &, PABCU(1,1,IKU2), PABCU(1,1,IKN) , ZTT2 &
272       &)
273
274
275    ENDIF
276
277    DO JA = 1, KTRAER
278      DO JL = KIDIA,KFDIA
279        ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*_HALF_
280      ENDDO
281    ENDDO
282
283    DO JL = KIDIA,KFDIA
284      ZWW=PDBDT(JL,1,IJKL)*ZTT(JL,1)          *ZTT(JL,10)&
285       &+PDBDT(JL,2,IJKL)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)&
286       &+PDBDT(JL,3,IJKL)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)&
287       &+PDBDT(JL,4,IJKL)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)&
288       &+PDBDT(JL,5,IJKL)*ZTT(JL,3)          *ZTT(JL,14)&
289       &+PDBDT(JL,6,IJKL)*ZTT(JL,6)          *ZTT(JL,15)
290      PDISU(JL,JK)=PDISU(JL,JK)+ZWW
291      PCNTRB(JL,JK,IJKL)=ZWW
292    ENDDO
293
294
295  ENDDO
296ENDDO
297
298!     ------------------------------------------------------------------
299
300RETURN
301END SUBROUTINE LWVD
Note: See TracBrowser for help on using the repository browser.