source: LMDZ5/branches/LMDZ5_SPLA/libf/phylmd/rrtm/lwvd.F90

Last change on this file was 1990, checked in by Laurent Fairhead, 11 years ago

Corrections à la version r1989 pour permettre la compilation avec RRTM
Inclusion de la licence CeCILL_V2 pour RRTM

Changes to revision r1989 to enable RRTM code compilation
RRTM part put under CeCILL_V2 licence
  • Property copyright set to
    Name of program: LMDZ
    Creation date: 1984
    Version: LMDZ5
    License: CeCILL version 2
    Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
    See the license file in the root directory
File size: 7.3 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!        M.Hamrud      01-Oct-2003 CY28 Cleaning
57!-----------------------------------------------------------------------
58
59USE PARKIND1  ,ONLY : JPIM     ,JPRB
60USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
61
62USE YOELW    , ONLY : NSIL     ,NIPD     ,NTRA     ,NUA      ,NG1P1
63
64IMPLICIT NONE
65
66INTEGER(KIND=JPIM),INTENT(IN)    :: KLON
67INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV
68INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA
69INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA
70INTEGER(KIND=JPIM),INTENT(IN)    :: KTRAER
71REAL(KIND=JPRB)   ,INTENT(IN)    :: PABCU(KLON,NUA,3*KLEV+1)
72REAL(KIND=JPRB)   ,INTENT(IN)    :: PDBDT(KLON,NSIL,KLEV)
73REAL(KIND=JPRB)   ,INTENT(IN)    :: PGA(KLON,NIPD,2,KLEV)
74REAL(KIND=JPRB)   ,INTENT(IN)    :: PGB(KLON,NIPD,2,KLEV)
75REAL(KIND=JPRB)   ,INTENT(OUT)   :: PCNTRB(KLON,KLEV+1,KLEV+1)
76REAL(KIND=JPRB)   ,INTENT(OUT)   :: PDISD(KLON,KLEV+1)
77REAL(KIND=JPRB)   ,INTENT(OUT)   :: PDISU(KLON,KLEV+1)
78REAL(KIND=JPRB)   ,INTENT(INOUT) :: PDWFSU(KLON,NSIL)
79!-----------------------------------------------------------------------
80
81!*       0.1   ARGUMENTS
82!              ---------
83
84!-----------------------------------------------------------------------
85
86!              ------------
87
88REAL(KIND=JPRB) :: ZTT(KLON,NTRA), ZTT1(KLON,NTRA), ZTT2(KLON,NTRA)
89
90INTEGER(KIND=JPIM) :: IJKL, IKD1, IKD2, IKJ, IKJP1, IKM1, IKN,&
91 & IKP1, IKU1, IKU2, ITT, JA, JK, JKJ, JL, JLK 
92
93REAL(KIND=JPRB) :: ZWW, ZWW1, ZWW2, ZWW3, ZWW4, ZWW5, ZWW6
94REAL(KIND=JPRB) :: ZHOOK_HANDLE
95
96#include "lwttm.intfb.h"
97
98!-----------------------------------------------------------------------
99
100!*         1.    INITIALIZATION
101!                --------------
102
103!*         1.1     INITIALIZE LAYER CONTRIBUTIONS
104!                  ------------------------------
105
106IF (LHOOK) CALL DR_HOOK('LWVD',0,ZHOOK_HANDLE)
107DO JK = 1, KLEV+1
108  DO JL = KIDIA,KFDIA
109    PDISD(JL,JK) = 0.0_JPRB
110    PDISU(JL,JK) = 0.0_JPRB
111  ENDDO
112ENDDO
113
114!*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
115!                  ---------------------------------
116
117DO JA = 1, NTRA
118  DO JL = KIDIA,KFDIA
119    ZTT (JL,JA) = 1.0_JPRB
120    ZTT1(JL,JA) = 1.0_JPRB
121    ZTT2(JL,JA) = 1.0_JPRB
122  ENDDO
123ENDDO
124
125!     ------------------------------------------------------------------
126
127!*         2.      VERTICAL INTEGRATION
128!                  --------------------
129
130!*         2.2     CONTRIBUTION FROM DISTANT LAYERS
131!                  ---------------------------------
132
133!*         2.2.1   DISTANT AND ABOVE LAYERS
134!                  ------------------------
135
136!*         2.2.2   FIRST UPPER LEVEL
137!                  -----------------
138
139DO JK = 1 , KLEV-1
140  IKP1=JK+1
141  IKN=(JK-1)*NG1P1+1
142  IKD1= JK  *NG1P1+1
143
144  CALL LWTTM &
145   & ( KIDIA         , KFDIA          , KLON,&
146   & PGA(1,1,1,JK) , PGB(1,1,1,JK),&
147   & PABCU(1,1,IKN), PABCU(1,1,IKD1), ZTT1 &
148   & ) 
149
150!*         2.2.3   HIGHER UP
151!                  ---------
152
153  ITT=1
154  DO JKJ=IKP1,KLEV
155    IF(ITT == 1) THEN
156      ITT=2
157    ELSE
158      ITT=1
159    ENDIF
160    IKJP1=JKJ+1
161    IKD2= JKJ  *NG1P1+1
162
163    IF(ITT == 1) THEN
164      CALL LWTTM &
165       & ( KIDIA         , KFDIA          , KLON,&
166       & PGA(1,1,1,JKJ), PGB(1,1,1,JKJ),&
167       & PABCU(1,1,IKN), PABCU(1,1,IKD2), ZTT1 &
168       & ) 
169
170    ELSE
171      CALL LWTTM &
172       & ( KIDIA         , KFDIA          , KLON,&
173       & PGA(1,1,1,JKJ), PGB(1,1,1,JKJ),&
174       & PABCU(1,1,IKN), PABCU(1,1,IKD2), ZTT2 &
175       & ) 
176
177    ENDIF
178
179    DO JA = 1, KTRAER
180      DO JL = KIDIA,KFDIA
181        ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5_JPRB
182      ENDDO
183    ENDDO
184
185    DO JL = KIDIA,KFDIA
186      ZWW1=PDBDT(JL,1,JKJ)*ZTT(JL,1)          *ZTT(JL,10)
187      ZWW2=PDBDT(JL,2,JKJ)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
188      ZWW3=PDBDT(JL,3,JKJ)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
189      ZWW4=PDBDT(JL,4,JKJ)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
190      ZWW5=PDBDT(JL,5,JKJ)*ZTT(JL,3)          *ZTT(JL,14)
191      ZWW6=PDBDT(JL,6,JKJ)*ZTT(JL,6)          *ZTT(JL,15)
192      ZWW=ZWW1+ZWW2+ZWW3+ZWW4+ZWW5+ZWW6
193      PDISD(JL,JK)=PDISD(JL,JK)+ZWW
194      PCNTRB(JL,JK,IKJP1)=ZWW
195      IF (JK == 1) THEN
196        PDWFSU(JL,1)=PDWFSU(JL,1)+ZWW1
197        PDWFSU(JL,2)=PDWFSU(JL,2)+ZWW2
198        PDWFSU(JL,3)=PDWFSU(JL,3)+ZWW3
199        PDWFSU(JL,4)=PDWFSU(JL,4)+ZWW4
200        PDWFSU(JL,5)=PDWFSU(JL,5)+ZWW5
201        PDWFSU(JL,6)=PDWFSU(JL,6)+ZWW6
202      ENDIF
203    ENDDO
204
205  ENDDO
206ENDDO
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  CALL LWTTM &
221   & ( 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!*         2.2.6   DOWN BELOW
227!                  ----------
228
229  ITT=1
230  DO JLK=1,IKJ
231    IF(ITT == 1) THEN
232      ITT=2
233    ELSE
234      ITT=1
235    ENDIF
236    IJKL=IKM1-JLK
237    IKU2=(IJKL-1)*NG1P1+1
238
239    IF(ITT == 1) THEN
240      CALL LWTTM &
241       & ( KIDIA          , KFDIA          , KLON,&
242       & PGA(1,1,1,IJKL), PGB(1,1,1,IJKL),&
243       & PABCU(1,1,IKU2), PABCU(1,1,IKN) , ZTT1 &
244       & ) 
245
246    ELSE
247      CALL LWTTM &
248       & ( KIDIA          , KFDIA          , KLON,&
249       & PGA(1,1,1,IJKL), PGB(1,1,1,IJKL),&
250       & PABCU(1,1,IKU2), PABCU(1,1,IKN) , ZTT2 &
251       & ) 
252
253    ENDIF
254
255    DO JA = 1, KTRAER
256      DO JL = KIDIA,KFDIA
257        ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5_JPRB
258      ENDDO
259    ENDDO
260
261    DO JL = KIDIA,KFDIA
262      ZWW=PDBDT(JL,1,IJKL)*ZTT(JL,1)          *ZTT(JL,10)&
263       & +PDBDT(JL,2,IJKL)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)&
264       & +PDBDT(JL,3,IJKL)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)&
265       & +PDBDT(JL,4,IJKL)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)&
266       & +PDBDT(JL,5,IJKL)*ZTT(JL,3)          *ZTT(JL,14)&
267       & +PDBDT(JL,6,IJKL)*ZTT(JL,6)          *ZTT(JL,15) 
268      PDISU(JL,JK)=PDISU(JL,JK)+ZWW
269      PCNTRB(JL,JK,IJKL)=ZWW
270    ENDDO
271
272  ENDDO
273ENDDO
274
275!     ------------------------------------------------------------------
276
277IF (LHOOK) CALL DR_HOOK('LWVD',1,ZHOOK_HANDLE)
278END SUBROUTINE LWVD
Note: See TracBrowser for help on using the repository browser.