source: LMDZ5/branches/IPSLCM6.0.10/libf/phymar/olwvd.F90 @ 4778

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