source: LMDZ5/trunk/libf/phylmd/rrtm/recmwf.F90 @ 2047

Last change on this file since 2047 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: 13.7 KB
Line 
1!OPTIONS XOPT(NOEVAL)
2SUBROUTINE RECMWF (KST, KEND, KPROMA, KTDIA , KLEV,&
3 & KMODE,&
4 & PALBD , PALBP , PAPRS , PAPRSF , PCCO2 , PCLFR,&
5 & PQO3  , PAER  , PDP   , PEMIS  , PMU0,&
6 & PQ    , PQS   , PQIWP , PQLWP , PSLM   , PT    , PTS,&
7 & PREF_LIQ, PREF_ICE,&
8 & PEMTD , PEMTU , PTRSO,&
9 & PTH   , PCTRSO, PCEMTR, PTRSOD,&
10 & PLWFC, PLWFT, PSWFC, PSWFT, PSFSWDIR, PSFSWDIF,&
11 & PFSDNN, PFSDNV,& 
12 & PPIZA_DST,PCGA_DST,PTAUREL_DST,PFLUX,PFLUC,&
13 & PFSDN ,PFSUP , PFSCDN , PFSCUP)
14
15!**** *RECMWF* - METEO-FRANCE RADIATION INTERFACE TO ECMWF RADIATION SCHEME
16
17!     PURPOSE.
18!     --------
19!           SIMPLE INTERFACE TO RADLSW (NO INTERPOLATION)
20
21!**   INTERFACE.
22!     ----------
23
24!     EXPLICIT ARGUMENTS :
25!        --------------------
26! KST    : START INDEX OF DATA IN KPROMA-LONG VECTOR
27! KEND   : END   INDEX OF DATA IN KPROMA-LONG VECTOR
28! KPROMA : VECTOR LENGTH
29! KTDIA  : INDEX OF TOP LEVEL FROM WHICH COMPUTATIONS ARE ACTIVE
30! KLEV   : NUMBER OF LEVELS
31! PAER   : (KPROMA,KLEV ,6)     ; OPTICAL THICKNESS OF THE AEROSOLS
32! PALBD  : (KPROMA,NSW)         ; DIFFUSE ALBEDO IN THE 2 SW INTERVALS
33! PALBP  : (KPROMA,NSW)         ; PARALLEL ALBEDO IN THE 2 SW INTERVALS
34! PAPRS  : (KPROMA,KLEV+1)      ; HALF LEVEL PRESSURE
35! PAPRSF : (KPROMA,KLEV )       ; FULL LEVEL PRESSURE
36! PCCO2  :                      ; CONCENTRATION IN CO2 (PA/PA)
37! PCLFR  : (KPROMA,KLEV )       ; CLOUD FRACTIONAL COVER
38! PQO3   : (KPROMA,KLEV )       ; OZONE MIXING RATIO (MASS)
39! PDP    : (KPROMA,KLEV)        ; LAYER PRESSURE THICKNESS
40! PEMIS  : (KPROMA)             ; SURFACE EMISSIVITY
41! PMU0   : (KPROMA)             ; SOLAR ANGLE
42! PQ     : (KPROMA,KLEV )       ; SPECIFIC HUMIDITY PA/PA
43! PQS    : (KPROMA,KLEV )       ; SATURATION SPECIFIC HUMIDITY PA/PA
44! PQIWP  : (KPROMA,KLEV )       ; ICE    WATER KG/KG
45! PQLWP  : (KPROMA,KLEV )       ; LIQUID WATER KG/KG
46! PSLM   : (KPROMA)             ; LAND-SEA MASK
47! PT     : (KPROMA,KLEV)        ; FULL LEVEL TEMPERATURE
48! PTS    : (KPROMA)             ; SURFACE TEMPERATURE
49! PPIZA_DST  : (KPROMA,KLEV,NSW); Single scattering albedo of dust
50! PCGA_DST   : (KPROMA,KLEV,NSW); Assymetry factor for dust
51! PTAUREL_DST: (KPROMA,KLEV,NSW); Optical depth of dust relative to at 550nm
52! PREF_LIQ (KPROMA,KLEV)        ; Liquid droplet radius (um)
53! PREF_ICE (KPROMA,KLEV)        ; Ice crystal radius (um)
54
55!     ==== OUTPUTS ===
56! PEMTD (KPROMA,KLEV+1)         ; TOTAL DOWNWARD LONGWAVE EMISSIVITY
57! PEMTU (KPROMA,KLEV+1)         ; TOTAL UPWARD   LONGWAVE EMISSIVITY
58! PTRSO (KPROMA,KLEV+1)         ; TOTAL SHORTWAVE TRANSMISSIVITY
59! PTH   (KPROMA,KLEV+1)         ; HALF LEVEL TEMPERATURE
60! PCTRSO(KPROMA,2)              ; CLEAR-SKY SHORTWAVE TRANSMISSIVITY
61! PCEMTR(KPROMA,2)              ; CLEAR-SKY NET LONGWAVE EMISSIVITY
62! PTRSOD(KPROMA)                ; TOTAL-SKY SURFACE SW TRANSMISSITY
63! PLWFC (KPROMA,2)              ; CLEAR-SKY LONGWAVE FLUXES
64! PLWFT (KPROMA,KLEV+1)         ; TOTAL-SKY LONGWAVE FLUXES
65! PSWFC (KPROMA,2)              ; CLEAR-SKY SHORTWAVE FLUXES
66! PSWFT (KPROMA,KLEV+1)         ; TOTAL-SKY SHORTWAVE FLUXES
67! Ajout flux LW et SW montants et descendants, et ciel clair (MPL 19.12.08)
68! PFLUX (KPROMA,2,KLEV+1)       ; LW total sky flux (1=up, 2=down)
69! PFLUC (KPROMA,2,KLEV+1)       ; LW clear sky flux (1=up, 2=down)
70! PFSDN(KPROMA,KLEV+1)          ; SW total sky flux down
71! PFSUP(KPROMA,KLEV+1)          ; SW total sky flux up
72! PFSCDN(KPROMA,KLEV+1)         ; SW clear sky flux down
73! PFSCUP(KPROMA,KLEV+1)         ; SW clear sky flux up
74
75
76!        IMPLICIT ARGUMENTS :   NONE
77!        --------------------
78
79!     METHOD.
80!     -------
81!     SEE DOCUMENTATION
82
83!     EXTERNALS.
84!     ----------
85
86!     REFERENCE.
87!     ----------
88!     ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
89
90!     AUTHORS.
91!     --------
92!     ORIGINAL BY  B. RITTER   *ECMWF*        83-10-13
93!     REWRITING FOR IFS BY J.-J. MORCRETTE    94-11-15
94!     96-11: Ph. Dandin. Meteo-France
95!     REWRITING FOR DM  BY J.PH. PIEDELIEVRE   1998-07
96!     Duplication of RFMR to use present (cy25) ECMWF radiation scheme : Y. Bouteloup 09-2003
97!     Use of 6 aerosols & introduce NSW : F. Bouyssel 09-2004
98!     04-11-18 : 4 New arguments for AROME : Y. Seity
99!     2005-10-10 Y. Seity : 3 optional arguments for dust optical properties
100!     JJMorcrette 20060721 PP of clear-sky PAR and TOA incident solar radiation (ECMWF)
101
102!-----------------------------------------------------------------------
103
104USE PARKIND1  ,ONLY : JPIM     ,JPRB
105USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
106
107USE YOEAERD  , ONLY : RCAEROS
108USE YOMCST   , ONLY :         RMD      ,RMO3
109USE YOMPHY3  , ONLY : RII0
110!USE YOERAD   , ONLY : NAER, NSW, RCCNLND  ,RCCNSEA 
111! NSW mis dans ;def MPL 20140211
112USE YOERAD   , ONLY : NAER, RCCNLND  ,RCCNSEA 
113USE YOERDU   , ONLY : REPSCQ
114USE YOMGEM   , ONLY : NGPTOT
115USE YOERDI   , ONLY : RRAE   ,REPCLC    ,REPH2O
116USE YOMARPHY , ONLY : LRDUST
117
118!-----------------------------------------------------------------------
119
120!*       0.1   ARGUMENTS.
121!              ----------
122
123IMPLICIT NONE
124
125include "clesphys.h"
126INTEGER(KIND=JPIM),INTENT(IN)    :: KPROMA
127INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV
128INTEGER(KIND=JPIM),INTENT(IN)    :: KST
129INTEGER(KIND=JPIM),INTENT(IN)    :: KEND
130INTEGER(KIND=JPIM)               :: KTDIA ! Argument NOT used
131INTEGER(KIND=JPIM),INTENT(IN)    :: KMODE
132REAL(KIND=JPRB)   ,INTENT(IN)    :: PALBD(KPROMA,NSW)
133REAL(KIND=JPRB)   ,INTENT(IN)    :: PALBP(KPROMA,NSW)
134REAL(KIND=JPRB)   ,INTENT(IN)    :: PAPRS(KPROMA,KLEV+1)
135REAL(KIND=JPRB)   ,INTENT(IN)    :: PAPRSF(KPROMA,KLEV)
136REAL(KIND=JPRB)   ,INTENT(IN)    :: PCCO2
137REAL(KIND=JPRB)   ,INTENT(IN)    :: PCLFR(KPROMA,KLEV)
138REAL(KIND=JPRB)   ,INTENT(IN)    :: PQO3(KPROMA,KLEV)
139REAL(KIND=JPRB)   ,INTENT(IN)    :: PAER(KPROMA,KLEV,6)
140REAL(KIND=JPRB)   ,INTENT(IN)    :: PDP(KPROMA,KLEV)
141REAL(KIND=JPRB)   ,INTENT(IN)    :: PEMIS(KPROMA)
142REAL(KIND=JPRB)   ,INTENT(IN)    :: PMU0(KPROMA)
143REAL(KIND=JPRB)   ,INTENT(IN)    :: PQ(KPROMA,KLEV)
144REAL(KIND=JPRB)   ,INTENT(IN)    :: PQS(KPROMA,KLEV)
145REAL(KIND=JPRB)   ,INTENT(IN)    :: PQIWP(KPROMA,KLEV)
146REAL(KIND=JPRB)   ,INTENT(IN)    :: PQLWP(KPROMA,KLEV)
147REAL(KIND=JPRB)   ,INTENT(IN)    :: PSLM(KPROMA)
148REAL(KIND=JPRB)   ,INTENT(IN)    :: PT(KPROMA,KLEV)
149REAL(KIND=JPRB)   ,INTENT(IN)    :: PTS(KPROMA)
150REAL(KIND=JPRB)   ,INTENT(IN)    :: PPIZA_DST(KPROMA,KLEV,NSW)
151REAL(KIND=JPRB)   ,INTENT(IN)    :: PCGA_DST(KPROMA,KLEV,NSW)
152REAL(KIND=JPRB)   ,INTENT(IN)    :: PTAUREL_DST(KPROMA,KLEV,NSW)
153REAL(KIND=JPRB)   ,INTENT(IN)    :: PREF_LIQ(KPROMA,KLEV)
154REAL(KIND=JPRB)   ,INTENT(IN)    :: PREF_ICE(KPROMA,KLEV)
155REAL(KIND=JPRB)   ,INTENT(OUT)   :: PEMTD(KPROMA,KLEV+1)
156REAL(KIND=JPRB)   ,INTENT(OUT)   :: PEMTU(KPROMA,KLEV+1)
157REAL(KIND=JPRB)   ,INTENT(OUT)   :: PTRSO(KPROMA,KLEV+1)
158REAL(KIND=JPRB)   ,INTENT(INOUT) :: PTH(KPROMA,KLEV+1)
159REAL(KIND=JPRB)   ,INTENT(OUT)   :: PCTRSO(KPROMA,2)
160REAL(KIND=JPRB)   ,INTENT(OUT)   :: PCEMTR(KPROMA,2)
161REAL(KIND=JPRB)   ,INTENT(OUT)   :: PTRSOD(KPROMA)
162REAL(KIND=JPRB)   ,INTENT(OUT)   :: PLWFC(KPROMA,2)
163REAL(KIND=JPRB)   ,INTENT(OUT)   :: PLWFT(KPROMA,KLEV+1)
164REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSWFC(KPROMA,2)
165REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSWFT(KPROMA,KLEV+1)
166REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSFSWDIR(KPROMA,NSW)
167REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSFSWDIF(KPROMA,NSW)
168REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFSDNN(KPROMA)
169REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFSDNV(KPROMA)
170REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFLUX(KPROMA,2,KLEV+1) ! LW total sky flux (1=up, 2=down)
171REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFLUC(KPROMA,2,KLEV+1) ! LW clear sky flux (1=up, 2=down)
172REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFSDN(KPROMA,KLEV+1)   ! SW total sky flux down
173REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFSUP(KPROMA,KLEV+1)   ! SW total sky flux up
174REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFSCDN(KPROMA,KLEV+1)  ! SW clear sky flux down
175REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFSCUP(KPROMA,KLEV+1)  ! SW clear sky flux up
176
177!     ==== COMPUTED IN RADITE ===
178!     ------------------------------------------------------------------
179!*       0.2   LOCAL ARRAYS.
180!              -------------
181REAL(KIND=JPRB) :: ZRAER  (KPROMA,6,KLEV)
182REAL(KIND=JPRB) :: ZRCLC  (KPROMA,KLEV)
183REAL(KIND=JPRB) :: ZRMU0  (KPROMA)
184REAL(KIND=JPRB) :: ZRPR   (KPROMA,KLEV)
185REAL(KIND=JPRB) :: ZRTI   (KPROMA,KLEV)
186REAL(KIND=JPRB) :: ZQLWP (KPROMA,KLEV ) , ZQIWP (KPROMA,KLEV )
187
188REAL(KIND=JPRB) :: ZPQO3 (KPROMA,KLEV)
189REAL(KIND=JPRB) :: ZQOZ (NGPTOT,KLEV)
190REAL(KIND=JPRB) :: ZQS    (KPROMA,KLEV)
191REAL(KIND=JPRB) :: ZQ     (KPROMA,KLEV)
192REAL(KIND=JPRB) :: ZEMTD  (KPROMA,KLEV+1)
193REAL(KIND=JPRB) :: ZEMTU  (KPROMA,KLEV+1)
194REAL(KIND=JPRB) :: ZTRSOC (KPROMA,2)
195REAL(KIND=JPRB) :: ZEMTC  (KPROMA,2)
196
197REAL(KIND=JPRB) :: ZNBAS  (KPROMA)
198REAL(KIND=JPRB) :: ZNTOP  (KPROMA)
199REAL(KIND=JPRB) :: ZQRAIN (KPROMA,KLEV)
200REAL(KIND=JPRB) :: ZQRAINT(KPROMA,KLEV)
201REAL(KIND=JPRB) :: ZCCNL  (KPROMA)
202REAL(KIND=JPRB) :: ZCCNO  (KPROMA)
203
204!  output of radlsw
205
206REAL(KIND=JPRB) :: ZEMIT  (KPROMA)
207REAL(KIND=JPRB) :: ZFCT   (KPROMA,KLEV+1)
208REAL(KIND=JPRB) :: ZFLT   (KPROMA,KLEV+1)
209REAL(KIND=JPRB) :: ZFCS   (KPROMA,KLEV+1)
210REAL(KIND=JPRB) :: ZFLS   (KPROMA,KLEV+1)
211REAL(KIND=JPRB) :: ZFRSOD (KPROMA),ZSUDU(KPROMA)
212REAL(KIND=JPRB) :: ZPARF  (KPROMA),ZUVDF(KPROMA),ZPARCF(KPROMA),ZTINCF(KPROMA)
213
214INTEGER(KIND=JPIM) :: IBEG, IEND, JK, JL
215
216REAL(KIND=JPRB) :: ZCRAE, ZRII0, ZEMIW(KPROMA)
217REAL(KIND=JPRB) :: ZHOOK_HANDLE
218
219#include "radlsw.intfb.h"
220
221IF (LHOOK) CALL DR_HOOK('RECMWF',0,ZHOOK_HANDLE)
222! print *,'RECMWF: PTS=',PTS
223IBEG=KST
224IEND=KEND
225
226!*       1.    PREPARATORY WORK
227!              ----------------
228
229!*       1.1    LOCAL CONSTANTS
230!                ---------------
231
232ZRII0=RII0
233!print *,'RECMWF: RII0 PMU0=',RII0,PMU0
234ZCRAE=RRAE*(RRAE+2.0_JPRB)
235
236!*       2.1    FULL-LEVEL QUANTITIES
237
238ZRPR =PAPRSF
239
240DO JK=1,KLEV
241  DO JL=IBEG,IEND
242!   ZPQO3(JL,JK)=PQO3(JL,JK)*PDP(JL,JK)*RMD/RMO3
243    ZPQO3(JL,JK)=PQO3(JL,JK)*PDP(JL,JK)
244    ZRCLC(JL,JK)=MAX( 0.0_JPRB ,MIN( 1.0_JPRB ,PCLFR(JL,JK)))
245    IF (ZRCLC(JL,JK) > REPCLC) THEN
246      ZQLWP(JL,JK)=PQLWP(JL,JK)
247      ZQIWP(JL,JK)=PQIWP(JL,JK)
248    ELSE
249      ZQLWP(JL,JK)=REPH2O*ZRCLC(JL,JK)
250      ZQIWP(JL,JK)=REPH2O*ZRCLC(JL,JK)
251    ENDIF
252    ZQRAIN(JL,JK)=0.
253    ZQRAINT(JL,JK)=0.
254    ZRTI(JL,JK) =PT(JL,JK)
255    ZQS (JL,JK)=MAX(2.0_JPRB*REPH2O,PQS(JL,JK))
256    ZQ  (JL,JK)=MAX(REPH2O,MIN(PQ(JL,JK),ZQS(JL,JK)*(1.0_JPRB-REPH2O)))
257    ZEMIW(JL)=PEMIS(JL)
258  ENDDO
259ENDDO
260
261IF (NAER == 0) THEN
262  ZRAER=RCAEROS
263ELSE
264  DO JK=1,KLEV
265    DO JL=IBEG,IEND
266      ZRAER(JL,1,JK)=PAER(JL,JK,1)
267      ZRAER(JL,2,JK)=PAER(JL,JK,2)
268      ZRAER(JL,3,JK)=PAER(JL,JK,3)
269      ZRAER(JL,4,JK)=PAER(JL,JK,4)
270      ZRAER(JL,5,JK)=RCAEROS
271      ZRAER(JL,6,JK)=PAER(JL,JK,6)
272    ENDDO
273  ENDDO
274ENDIF
275
276!*       2.2    HALF-LEVEL QUANTITIES
277
278DO JK=2,KLEV
279  DO JL=IBEG,IEND
280    PTH(JL,JK)=&
281     & (PT(JL,JK-1)*PAPRSF(JL,JK-1)*(PAPRSF(JL,JK)-PAPRS(JL,JK))&
282     & +PT(JL,JK)*PAPRSF(JL,JK)*(PAPRS(JL,JK)-PAPRSF(JL,JK-1)))&
283     & *(1.0_JPRB/(PAPRS(JL,JK)*(PAPRSF(JL,JK)-PAPRSF(JL,JK-1)))) 
284  ENDDO
285ENDDO
286
287!*       2.3     QUANTITIES AT BOUNDARIES
288
289DO JL=IBEG,IEND
290  PTH(JL,KLEV+1)=PTS(JL)
291  PTH(JL,1)=PT(JL,1)-PAPRSF(JL,1)*(PT(JL,1)-PTH(JL,2))&
292   & /(PAPRSF(JL,1)-PAPRS(JL,2)) 
293  ZNBAS(JL)=1.
294  ZNTOP(JL)=1.
295  ZCCNL(JL)=RCCNLND
296  ZCCNO(JL)=RCCNSEA
297ENDDO
298
299!*       3.1     SOLAR ZENITH ANGLE IS EARTH'S CURVATURE
300!                CORRECTED
301
302! CCMVAL: on impose ZRMU0=PMU0 MPL 25032010
303! 2eme essai en 3D MPL 20052010
304!DO JL=IBEG,IEND
305! ZRMU0(JL)=PMU0(JL)
306!ENDDO
307!!!!! A REVOIR MPL 20091201: enleve cette correction pour comparer a AR4
308 DO JL=IBEG,IEND
309   IF (PMU0(JL) > 1.E-10_JPRB) THEN
310     ZRMU0(JL)=RRAE/(SQRT(PMU0(JL)**2+ZCRAE)-PMU0(JL))
311   ELSE
312     ZRMU0(JL)= RRAE/SQRT(ZCRAE)
313   ENDIF   
314!  print *,'RECMWF CURV: JL PMU0, ZRMU0',JL,PMU0(JL),ZRMU0(JL)
315 ENDDO   
316
317
318
319!*         4.1     CALL TO ACTUAL RADIATION SCHEME
320!print *,'+++++ DANS RADLSW, LRDUST ',LRDUST
321!WRITE(*,'("PPIZA_DST=",10E12.5)') (PPIZA_DST(1,JK,1),JK=1,KLEV)
322!WRITE(*,'("PCGA_DST= ",10E12.5)') (PCGA_DST(1,JK,1),JK=1,KLEV)
323!WRITE(*,'("PTAUREL_DST=",10E12.5)') (PTAUREL_DST(1,JK,1),JK=1,KLEV)
324
325CALL RADLSW (&
326 & IBEG  , IEND   , KPROMA  , KLEV  , KMODE , NAER,&
327 & ZRII0 ,&
328 & ZRAER , PALBD  , PALBP   , PAPRS , ZRPR  ,&
329 & ZCCNL , ZCCNO  ,&
330 & PCCO2 , ZRCLC  , PDP     , PEMIS , ZEMIW ,PSLM    , ZRMU0 , ZPQO3,&
331 & ZQ    , ZQIWP  , ZQLWP   , ZQS   , ZQRAIN,ZQRAINT ,&
332 & PTH   , ZRTI   , PTS     , ZNBAS , ZNTOP ,&
333 & PREF_LIQ, PREF_ICE,&
334 & ZEMIT , ZFCT   , ZFLT    , ZFCS    , ZFLS  ,&
335 & ZFRSOD, ZSUDU  , ZUVDF   , ZPARF   , ZPARCF, ZTINCF, PSFSWDIR,&
336 & PSFSWDIF,PFSDNN, PFSDNV  ,& 
337 & LRDUST,PPIZA_DST,PCGA_DST,PTAUREL_DST,PFLUX,PFLUC,&
338 & PFSDN , PFSUP  , PFSCDN  , PFSCUP )
339
340!*         4.2     TRANSFORM FLUXES TO MODEL HISTORICAL VARIABLES
341
342DO JK=1,KLEV+1
343  DO JL=IBEG,IEND
344    PSWFT(JL,JK)=ZFLS(JL,JK)/(ZRII0*ZRMU0(JL))
345    PLWFT(JL,JK)=ZFLT(JL,JK)
346  ENDDO
347ENDDO
348
349ZEMTD=PLWFT
350ZEMTU=PLWFT
351
352DO JL=IBEG,IEND
353  ZTRSOC(JL, 1)=ZFCS(JL,     1)/(ZRII0*ZRMU0(JL))
354  ZTRSOC(JL, 2)=ZFCS(JL,KLEV+1)/(ZRII0*ZRMU0(JL))
355  ZEMTC (JL, 1)=ZFCT(JL,     1)
356  ZEMTC (JL, 2)=ZFCT(JL,KLEV+1)
357ENDDO
358
359!                 ------------ -- ------- -- ---- -----
360!*         5.1    STORAGE OF TRANSMISSIVITY AND EMISSIVITIES
361!*                IN KPROMA-LONG ARRAYS
362
363DO JK=1,KLEV+1
364  DO JL=IBEG,IEND
365    PEMTD(JL,JK)=ZEMTD(JL,JK)
366    PEMTU(JL,JK)=ZEMTU(JL,JK)
367    PTRSO(JL,JK)=MAX(0.0_JPRB,MIN(1.0_JPRB,PSWFT(JL,JK)))
368  ENDDO
369ENDDO
370DO JK=1,2
371  DO JL=IBEG,IEND
372    PCEMTR(JL,JK)=ZEMTC (JL,JK)
373    PCTRSO(JL,JK)=MAX( 0.0_JPRB,MIN(1.0_JPRB,ZTRSOC(JL,JK)))
374  ENDDO
375ENDDO
376DO JL=IBEG,IEND
377  PTRSOD(JL)=MAX(0.0_JPRB,MIN(1.0_JPRB,ZFRSOD(JL)/(ZRII0*ZRMU0(JL))))
378ENDDO
379
380!*         7.3   RECONSTRUCT FLUXES FOR DIAGNOSTICS
381
382DO JL=IBEG,IEND
383  IF (PMU0(JL) < 1.E-10_JPRB) ZRMU0(JL)=0.0_JPRB
384ENDDO
385DO JK=1,KLEV+1
386  DO JL=IBEG,IEND
387    PLWFT(JL,JK)=PEMTD(JL,JK)
388    PSWFT(JL,JK)=ZRMU0(JL)*ZRII0*PTRSO(JL,JK)
389  ENDDO
390ENDDO
391DO JK=1,2
392  DO JL=IBEG,IEND
393    PSWFC(JL,JK)=ZRMU0(JL)*ZRII0*PCTRSO(JL,JK)
394    PLWFC(JL,JK)=PCEMTR(JL,JK)
395  ENDDO
396ENDDO
397
398IF (LHOOK) CALL DR_HOOK('RECMWF',1,ZHOOK_HANDLE)
399END SUBROUTINE RECMWF
Note: See TracBrowser for help on using the repository browser.