source: LMDZ6/branches/LMDZ-ECRAD/libf/phylmd/rrtm/lwvb.F90 @ 4109

Last change on this file since 4109 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.7 KB
Line 
1SUBROUTINE LWVB &
2 & ( KIDIA , KFDIA , KLON  , KLEV  , KUAER,&
3 & PABCU , PADJD , PADJU,&
4 & PB    , PBINT , PBSUR , PBTOP,&
5 & PDISD , PDISU , PEMIS , PEMIW,&
6 & PGASUR, PGBSUR, PGATOP, PGBTOP,&
7 & PDWFSU,PFLUC                  &
8 & ) 
9
10!**** *LWVB*   - L.W., VERTICAL INTEGRATION, EXCHANGE WITH BOUNDARIES
11
12!     PURPOSE.
13!     --------
14!           INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL
15!           INTEGRATION
16
17!**   INTERFACE.
18!     ----------
19
20!        EXPLICIT ARGUMENTS :
21!        --------------------
22!     ==== INPUTS ===
23! PABCU : (KLON,NUA,3*KLEV+1); ABSORBER AMOUNTS
24! PADJ.. : (KLON,KLEV+1)     ; CONTRIBUTION BY ADJACENT LAYERS
25! PB     : (KLON,NSIL,KLEV+1); SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
26! PBINT  : (KLON,KLEV+1)     ; HALF-LEVEL PLANCK FUNCTIONS
27! PBSUR  : (KLON,NSIL)       ; SPECTRAL SURFACE PLANCK FUNCTION
28! PBTOP  : (KLON,NSIL)       ; SPECTRAL T.O.A. PLANCK FUNCTION
29! PDIS.. : (KLON,KLEV+1)     ; CONTRIBUTION BY DISTANT LAYERS
30! PEMIS  : (KLON)            ; SURFACE LW EMISSIVITY
31! PEMIW  : (KLON)            ; SURFACE LW WINDOW EMISSIVITY
32! PGASUR, PGBSUR             ; SURFACE PADE APPROXIMANTS
33! PGATOP, PGBTOP             ; T.O.A. PADE APPROXIMANTS
34!     ==== OUTPUTS ===
35! PDWFSU : (KLON,NSIL)       ; SPECTRAL DOWNWARD FLUX AT SURFACE
36! PFLUC(KLON,2,KLEV)         ; RADIATIVE FLUXES CLEAR-SKY:
37!                     1  ==>  UPWARD   FLUX TOTAL
38
39!        IMPLICIT ARGUMENTS :   NONE
40!        --------------------
41
42!     METHOD.
43!     -------
44
45!          COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE
46!     ATMOSPHERE AND ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY
47!     FLUXES
48
49!     EXTERNALS.
50!     ----------
51
52!          *LWTT*
53
54!     REFERENCE.
55!     ----------
56
57!        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
58!        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
59
60!     AUTHOR.
61!     -------
62!        JEAN-JACQUES MORCRETTE  *ECMWF*
63!     MODIFICATIONS.
64!     --------------
65!        ORIGINAL : 89-07-14
66!        JJ Morcrette 96-06-07  Surface LW Window Emissivity
67!        M.Hamrud      01-Oct-2003 CY28 Cleaning
68
69!-----------------------------------------------------------------------
70
71USE PARKIND1  ,ONLY : JPIM     ,JPRB
72USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
73
74USE YOELW    , ONLY : NSIL     ,NIPD     ,NTRA     ,NUA      ,NG1P1
75
76IMPLICIT NONE
77
78INTEGER(KIND=JPIM),INTENT(IN)    :: KLON
79INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV
80INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA
81INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA
82INTEGER(KIND=JPIM),INTENT(IN)    :: KUAER
83REAL(KIND=JPRB)   ,INTENT(IN)    :: PABCU(KLON,NUA,3*KLEV+1)
84REAL(KIND=JPRB)   ,INTENT(IN)    :: PADJD(KLON,KLEV+1)
85REAL(KIND=JPRB)   ,INTENT(IN)    :: PADJU(KLON,KLEV+1)
86REAL(KIND=JPRB)   ,INTENT(IN)    :: PB(KLON,NSIL,KLEV+1)
87REAL(KIND=JPRB)   ,INTENT(IN)    :: PBINT(KLON,KLEV+1)
88REAL(KIND=JPRB)   ,INTENT(IN)    :: PBSUR(KLON,NSIL)
89REAL(KIND=JPRB)   ,INTENT(IN)    :: PBTOP(KLON,NSIL)
90REAL(KIND=JPRB)   ,INTENT(IN)    :: PDISD(KLON,KLEV+1)
91REAL(KIND=JPRB)   ,INTENT(IN)    :: PDISU(KLON,KLEV+1)
92REAL(KIND=JPRB)   ,INTENT(IN)    :: PEMIS(KLON)
93REAL(KIND=JPRB)   ,INTENT(IN)    :: PEMIW(KLON)
94REAL(KIND=JPRB)   ,INTENT(IN)    :: PGASUR(KLON,NIPD,2)
95REAL(KIND=JPRB)   ,INTENT(IN)    :: PGBSUR(KLON,NIPD,2)
96REAL(KIND=JPRB)   ,INTENT(IN)    :: PGATOP(KLON,NIPD,2)
97REAL(KIND=JPRB)   ,INTENT(IN)    :: PGBTOP(KLON,NIPD,2)
98REAL(KIND=JPRB)   ,INTENT(INOUT) :: PDWFSU(KLON,NSIL)
99REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFLUC(KLON,2,KLEV+1)
100!-----------------------------------------------------------------------
101
102!*       0.1   ARGUMENTS
103!              ---------
104
105!-----------------------------------------------------------------------
106
107!              ------------
108
109REAL(KIND=JPRB) :: ZBSUR(KLON,NSIL)&
110 & ,  ZTT(KLON,NTRA), ZTT1(KLON,NTRA), ZTT2(KLON,NTRA)&
111 & ,  ZUU(KLON,NUA) , ZCNSOL(KLON)   , ZCNTOP(KLON) 
112
113INTEGER(KIND=JPIM) :: IN, JA, JK, JL
114
115REAL(KIND=JPRB) :: ZCNTOP1, ZCNTOP2, ZCNTOP3, ZCNTOP4, ZCNTOP5, ZCNTOP6
116REAL(KIND=JPRB) :: ZHOOK_HANDLE
117
118#include "lwtt.intfb.h"
119
120!-----------------------------------------------------------------------
121
122!*         1.    INITIALIZATION
123!                --------------
124
125!*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
126!                  ---------------------------------
127
128IF (LHOOK) CALL DR_HOOK('LWVB',0,ZHOOK_HANDLE)
129DO JA=1,NTRA
130  DO JL=KIDIA,KFDIA
131    ZTT (JL,JA)=1.0_JPRB
132    ZTT1(JL,JA)=1.0_JPRB
133    ZTT2(JL,JA)=1.0_JPRB
134  ENDDO
135ENDDO
136
137DO JA=1,NUA
138  DO JL=KIDIA,KFDIA
139    ZUU(JL,JA)=1.0_JPRB
140  ENDDO
141ENDDO
142
143!     ------------------------------------------------------------------
144
145!*         2.      VERTICAL INTEGRATION
146!                  --------------------
147
148!*         2.3     EXCHANGE WITH TOP OF THE ATMOSPHERE
149!                  -----------------------------------
150
151DO JK = 1 , KLEV
152  IN=(JK-1)*NG1P1+1
153
154  DO JA=1,KUAER
155    DO JL=KIDIA,KFDIA
156      ZUU(JL,JA)=PABCU(JL,JA,IN)
157    ENDDO
158  ENDDO
159
160  CALL LWTT &
161   & ( KIDIA        , KFDIA        , KLON,&
162   & PGATOP(1,1,1), PGBTOP(1,1,1),&
163   & ZUU          , ZTT &
164   & ) 
165
166  DO JL = KIDIA,KFDIA
167    ZCNTOP1=PBTOP(JL,1)*ZTT(JL,1)          *ZTT(JL,10)
168    ZCNTOP2=PBTOP(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
169    ZCNTOP3=PBTOP(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
170    ZCNTOP4=PBTOP(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
171    ZCNTOP5=PBTOP(JL,5)*ZTT(JL,3)          *ZTT(JL,14)
172    ZCNTOP6=PBTOP(JL,6)*ZTT(JL,6)          *ZTT(JL,15)
173    ZCNTOP(JL)=ZCNTOP1+ZCNTOP2+ZCNTOP3+ZCNTOP4+ZCNTOP5+ZCNTOP6
174    PFLUC(JL,2,JK)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
175    IF (JK == 1) THEN
176      PDWFSU(JL,1)=ZCNTOP1-PB(JL,1,JK)-PDWFSU(JL,1)
177      PDWFSU(JL,2)=ZCNTOP2-PB(JL,2,JK)-PDWFSU(JL,2)
178      PDWFSU(JL,3)=ZCNTOP3-PB(JL,3,JK)-PDWFSU(JL,3)
179      PDWFSU(JL,4)=ZCNTOP4-PB(JL,4,JK)-PDWFSU(JL,4)
180      PDWFSU(JL,5)=ZCNTOP5-PB(JL,5,JK)-PDWFSU(JL,5)
181      PDWFSU(JL,6)=ZCNTOP6-PB(JL,6,JK)-PDWFSU(JL,6)
182    ENDIF
183  ENDDO
184
185ENDDO
186
187JK = KLEV+1
188IN=(JK-1)*NG1P1+1
189
190DO JL = KIDIA,KFDIA
191  ZCNTOP(JL)= PBTOP(JL,1)&
192   & + PBTOP(JL,2)&
193   & + PBTOP(JL,3)&
194   & + PBTOP(JL,4)&
195   & + PBTOP(JL,5)&
196   & + PBTOP(JL,6) 
197  PFLUC(JL,2,JK)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
198ENDDO
199
200!*         2.5     EXCHANGE WITH LOWER LIMIT
201!                  -------------------------
202
203JK = 1
204IN=(JK-1)*NG1P1+1
205
206DO JL = KIDIA,KFDIA
207  ZBSUR(JL,1)=PBSUR(JL,1)*PEMIS(JL) -(1.0_JPRB-PEMIS(JL))*PDWFSU(JL,1)
208  ZBSUR(JL,2)=PBSUR(JL,2)*PEMIS(JL) -(1.0_JPRB-PEMIS(JL))*PDWFSU(JL,2)
209  ZBSUR(JL,3)=PBSUR(JL,3)*PEMIW(JL) -(1.0_JPRB-PEMIW(JL))*PDWFSU(JL,3)
210  ZBSUR(JL,4)=PBSUR(JL,4)*PEMIW(JL) -(1.0_JPRB-PEMIW(JL))*PDWFSU(JL,4)
211  ZBSUR(JL,5)=PBSUR(JL,5)*PEMIS(JL) -(1.0_JPRB-PEMIS(JL))*PDWFSU(JL,5)
212  ZBSUR(JL,6)=PBSUR(JL,6)*PEMIS(JL) -(1.0_JPRB-PEMIS(JL))*PDWFSU(JL,6)
213
214  PFLUC(JL,1,JK) = ZBSUR(JL,1)&
215   & + ZBSUR(JL,2)&
216   & + ZBSUR(JL,3)&
217   & + ZBSUR(JL,4)&
218   & + ZBSUR(JL,5)&
219   & + ZBSUR(JL,6) 
220
221  ZBSUR(JL,1)=ZBSUR(JL,1)-PB(JL,1,1)
222  ZBSUR(JL,2)=ZBSUR(JL,2)-PB(JL,2,1)
223  ZBSUR(JL,3)=ZBSUR(JL,3)-PB(JL,3,1)
224  ZBSUR(JL,4)=ZBSUR(JL,4)-PB(JL,4,1)
225  ZBSUR(JL,5)=ZBSUR(JL,5)-PB(JL,5,1)
226  ZBSUR(JL,6)=ZBSUR(JL,6)-PB(JL,6,1)
227ENDDO
228
229DO JK = 2 , KLEV+1
230  IN=(JK-1)*NG1P1+1
231
232  DO JA=1,KUAER
233    DO JL=KIDIA,KFDIA
234      ZUU(JL,JA)=PABCU(JL,JA,1)-PABCU(JL,JA,IN)
235    ENDDO
236  ENDDO
237
238  CALL LWTT &
239   & ( KIDIA        , KFDIA        , KLON,&
240   & PGASUR(1,1,1), PGBSUR(1,1,1),&
241   & ZUU, ZTT &
242   & ) 
243
244  DO JL = KIDIA,KFDIA
245    ZCNSOL(JL)=ZBSUR(JL,1)*ZTT(JL,1)          *ZTT(JL,10)&
246     & +ZBSUR(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)&
247     & +ZBSUR(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)&
248     & +ZBSUR(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)&
249     & +ZBSUR(JL,5)*ZTT(JL,3)          *ZTT(JL,14)&
250     & +ZBSUR(JL,6)*ZTT(JL,6)          *ZTT(JL,15) 
251    PFLUC(JL,1,JK)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
252  ENDDO
253
254ENDDO
255
256!     ------------------------------------------------------------------
257
258IF (LHOOK) CALL DR_HOOK('LWVB',1,ZHOOK_HANDLE)
259END SUBROUTINE LWVB
Note: See TracBrowser for help on using the repository browser.