GCC Code Coverage Report
Directory: ./ Exec Total Coverage
File: phylmd/rrtm/lwc.F90 Lines: 0 117 0.0 %
Date: 2023-06-30 12:51:15 Branches: 0 108 0.0 %

Line Branch Exec Source
1
SUBROUTINE LWC &
2
 & ( KIDIA , KFDIA, KLON  , KLEV,&
3
 & PBINT , PBSUI, PCLDLD, PCLDLU,&
4
 & PCNTRB, PEMIT, PFLUC,&
5
 & PFLUX                              &
6
 & )
7
8
!**** *LWC*   - LONGWAVE RADIATION, CLOUD EFFECTS
9
10
!     PURPOSE.
11
!     --------
12
!           INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR
13
!           RADIANCES
14
15
!**   INTERFACE.
16
!     ----------
17
18
!        EXPLICIT ARGUMENTS :
19
!        --------------------
20
!     ==== INPUTS ===
21
! PBINT  : (KLON,KLEV+1)       ; HALF LEVEL PLANCK FUNCTION
22
! PBSUI  : (KLON)              ; SURFACE PLANCK FUNCTION
23
! PCLDLD : (KLON,KLEV)         ; DOWNWARD EFFECTIVE CLOUD FRACTION
24
! PCLDLU : (KLON,KLEV)         ; UPWARD EFFECTIVE CLOUD FRACTION
25
! PCNTRB : (KLON,KLEV+1,KLEV+1); CLEAR-SKY ENERGY EXCHANGE MATRIX
26
! PEMIT  : (KLON)              ; SURFACE TOTAL LW EMISSIVITY
27
! PFLUC  : (KLON,2,KLEV+1)     ; CLEAR-SKY LW RADIATIVE FLUXES
28
!     ==== OUTPUTS ===
29
! PFLUX  : (KLON,2,KLEV+1)     ; TOTAL SKY LW RADIATIVE FLUXES :
30
!                     1  ==>  UPWARD   FLUX TOTAL
31
!                     2  ==>  DOWNWARD FLUX TOTAL
32
33
!        IMPLICIT ARGUMENTS :   NONE
34
!        --------------------
35
36
!     METHOD.
37
!     -------
38
39
!          1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES
40
!          2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER
41
!          3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED
42
!     CLOUDS
43
44
!     EXTERNALS.
45
!     ----------
46
47
!          NONE
48
49
!     REFERENCE.
50
!     ----------
51
52
!        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
53
!        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
54
55
!     AUTHOR.
56
!     -------
57
!        JEAN-JACQUES MORCRETTE  *ECMWF*
58
59
!     MODIFICATIONS.
60
!     --------------
61
!        ORIGINAL : 89-07-14
62
!        JJ Morcrette 97-04-18   Cleaning
63
!        JJMorcrette 01-02-16 Hogan & Illingworth (2001)'s mixed overlap
64
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
65
66
!-----------------------------------------------------------------------
67
68
USE PARKIND1  ,ONLY : JPIM     ,JPRB
69
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
70
71
USE YOERAD   , ONLY : NOVLP
72
USE YOERDI   , ONLY : REPCLC
73
USE YOEOVLP  , ONLY : RA1OVLP
74
75
IMPLICIT NONE
76
77
INTEGER(KIND=JPIM),INTENT(IN)    :: KLON
78
INTEGER(KIND=JPIM),INTENT(IN)    :: KLEV
79
INTEGER(KIND=JPIM),INTENT(IN)    :: KIDIA
80
INTEGER(KIND=JPIM),INTENT(IN)    :: KFDIA
81
REAL(KIND=JPRB)   ,INTENT(IN)    :: PBINT(KLON,KLEV+1)
82
REAL(KIND=JPRB)   ,INTENT(IN)    :: PBSUI(KLON)
83
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCLDLD(KLON,KLEV)
84
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCLDLU(KLON,KLEV)
85
REAL(KIND=JPRB)   ,INTENT(IN)    :: PCNTRB(KLON,KLEV+1,KLEV+1)
86
REAL(KIND=JPRB)   ,INTENT(IN)    :: PEMIT(KLON)
87
REAL(KIND=JPRB)   ,INTENT(IN)    :: PFLUC(KLON,2,KLEV+1)
88
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PFLUX(KLON,2,KLEV+1)
89
!-----------------------------------------------------------------------
90
91
!*       0.1   ARGUMENTS
92
!              ---------
93
94
!-----------------------------------------------------------------------
95
96
!              ------------
97
98
REAL(KIND=JPRB) :: ZCLEAR(KLON)            , ZCLOUD(KLON)&
99
 & ,  ZCLM(KLON,KLEV+1,KLEV+1), ZDNF(KLON,KLEV+1,KLEV+1)&
100
 & ,  ZFD(KLON)               , ZFU(KLON)&
101
 & ,  ZUPF(KLON,KLEV+1,KLEV+1)
102
103
INTEGER(KIND=JPIM) :: IKCP1, IKM1, IKP1, IMAXC, IMXM1, IMXP1, JCLOUD,&
104
 & JK, JK1, JK2, JKJ, JL
105
106
REAL(KIND=JPRB) :: ZALPHA1, ZCFRAC
107
REAL(KIND=JPRB) :: ZHOOK_HANDLE
108
109
!     ------------------------------------------------------------------
110
111
!*         1.     INITIALIZATION
112
!                 --------------
113
114
!100  CONTINUE
115
116
!      print *,' Enter LWC '
117
IF (LHOOK) CALL DR_HOOK('LWC',0,ZHOOK_HANDLE)
118
DO JL = KIDIA,KFDIA
119
  ZCLOUD(JL) = 0.0_JPRB
120
ENDDO
121
122
DO JK = 1 , KLEV+1
123
  DO JL = KIDIA,KFDIA
124
    PFLUX(JL,1,JK) = PFLUC(JL,1,JK)
125
    PFLUX(JL,2,JK) = PFLUC(JL,2,JK)
126
  ENDDO
127
ENDDO
128
129
!GM*******
130
IMAXC=KLEV
131
!GM*******
132
133
!     ------------------------------------------------------------------
134
135
!*         2.      EFFECT OF CLOUDINESS ON LONGWAVE FLUXES
136
!                  ---------------------------------------
137
138
IMXP1 = IMAXC + 1
139
IMXM1 = IMAXC - 1
140
141
!*         2.0     INITIALIZE TO CLEAR-SKY FLUXES
142
!                  ------------------------------
143
144
!200  CONTINUE
145
146
DO JK1=1,KLEV+1
147
  DO JK2=1,KLEV+1
148
    DO JL = KIDIA,KFDIA
149
      ZUPF(JL,JK2,JK1)=PFLUC(JL,1,JK1)
150
      ZDNF(JL,JK2,JK1)=PFLUC(JL,2,JK1)
151
    ENDDO
152
  ENDDO
153
ENDDO
154
!      print *,' LWC after Initialisation to clear-sky fluxes'
155
156
!*         2.1     FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD
157
!                  ----------------------------------------------
158
159
!210  CONTINUE
160
161
DO JCLOUD = 1 , IMAXC
162
  IKCP1=JCLOUD+1
163
164
!*         2.1.1   ABOVE THE CLOUD
165
!                  ---------------
166
167
!2110 CONTINUE
168
169
  DO JK=IKCP1,KLEV+1
170
    IKM1=JK-1
171
    DO JL = KIDIA,KFDIA
172
      ZFU(JL)=0.0_JPRB
173
    ENDDO
174
175
    IF (JK  >  IKCP1) THEN
176
      DO JKJ=IKCP1,IKM1
177
        DO JL = KIDIA,KFDIA
178
          ZFU(JL) = ZFU(JL) + PCNTRB(JL,JK,JKJ)
179
        ENDDO
180
      ENDDO
181
    ENDIF
182
183
    DO JL = KIDIA,KFDIA
184
      ZUPF(JL,IKCP1,JK)=PBINT(JL,JK)-ZFU(JL)
185
    ENDDO
186
  ENDDO
187
188
!*         2.1.2   BELOW THE CLOUD
189
!                  ---------------
190
191
!2120 CONTINUE
192
193
  DO JK=1,JCLOUD
194
    IKP1=JK+1
195
    DO JL = KIDIA,KFDIA
196
      ZFD(JL)=0.0_JPRB
197
    ENDDO
198
199
    IF (JK  <  JCLOUD) THEN
200
      DO JKJ=IKP1,JCLOUD
201
        DO JL = KIDIA,KFDIA
202
          ZFD(JL) = ZFD(JL) + PCNTRB(JL,JK,JKJ)
203
        ENDDO
204
      ENDDO
205
    ENDIF
206
207
    DO JL = KIDIA,KFDIA
208
      ZDNF(JL,IKCP1,JK)=-PBINT(JL,JK)-ZFD(JL)
209
    ENDDO
210
  ENDDO
211
212
ENDDO
213
!      print *,' LWC after 213: Fluxes for unity emissivity'
214
215
!*         2.2     CLOUD COVER MATRIX
216
!                  ------------------
217
218
!*    ZCLM(JK1,JK2) IS THE OBSCURATION FACTOR BY CLOUD LAYERS BETWEEN
219
!     HALF-LEVELS JK1 AND JK2 AS SEEN FROM JK1
220
221
!220  CONTINUE
222
223
DO JK1 = 1 , KLEV+1
224
  DO JK2 = 1 , KLEV+1
225
    DO JL = KIDIA,KFDIA
226
      ZCLM(JL,JK1,JK2) = 0.0_JPRB
227
    ENDDO
228
  ENDDO
229
ENDDO
230
!      print *,' LWC after Initialisation CC matrix'
231
232
!*         2.4     CLOUD COVER BELOW THE LEVEL OF CALCULATION
233
!                  ------------------------------------------
234
235
!240  CONTINUE
236
237
DO JK1 = 2 , KLEV+1
238
  DO JL = KIDIA,KFDIA
239
    ZCLEAR(JL)=1.0_JPRB
240
    ZCLOUD(JL)=0.0_JPRB
241
  ENDDO
242
243
  DO JK = JK1 - 1 , 1 , -1
244
    ZALPHA1=RA1OVLP(KLEV+1-JK)
245
246
    DO JL = KIDIA,KFDIA
247
!++MODIFCODE
248
      IF ((NOVLP==1).OR.(NOVLP==6).OR.(NOVLP==8)) THEN
249
!--MODIFCODE
250
!* maximum-random
251
        ZCLEAR(JL)=ZCLEAR(JL)*(1.0_JPRB-MAX(PCLDLU(JL,JK),ZCLOUD(JL)))&
252
         & /(1.0_JPRB-MIN(ZCLOUD(JL),1.0_JPRB-REPCLC))
253
        ZCLM(JL,JK1,JK) = 1.0_JPRB - ZCLEAR(JL)
254
        ZCLOUD(JL) = PCLDLU(JL,JK)
255
!++MODIFCODE
256
      ELSEIF ((NOVLP==2).OR.(NOVLP==7)) THEN
257
!--MODIFCODE
258
!* maximum
259
        ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLU(JL,JK))
260
        ZCLM(JL,JK1,JK) = ZCLOUD(JL)
261
!++MODIFCODE
262
      ELSEIF ((NOVLP == 3).OR.(NOVLP==5)) THEN
263
!--MODIFCODE
264
!* random
265
        ZCLEAR(JL) = ZCLEAR(JL)*(1.0_JPRB - PCLDLU(JL,JK))
266
        ZCLOUD(JL) = 1.0_JPRB - ZCLEAR(JL)
267
        ZCLM(JL,JK1,JK) = ZCLOUD(JL)
268
      ELSEIF (NOVLP == 4) THEN
269
!** Hogan & Illingworth (2001)
270
        ZCLEAR(JL)=ZCLEAR(JL)*( &
271
         & ZALPHA1*(1.0_JPRB-MAX(PCLDLU(JL,JK),ZCLOUD(JL))) &
272
         & /(1.0_JPRB-MIN(ZCLOUD(JL),1.0_JPRB-REPCLC)) &
273
         & +(1.0_JPRB-ZALPHA1)*(1.0_JPRB-PCLDLU(JL,JK)) )
274
        ZCLM(JL,JK1,JK) = 1.0_JPRB - ZCLEAR(JL)
275
        ZCLOUD(JL) = PCLDLU(JL,JK)
276
      ENDIF
277
    ENDDO
278
  ENDDO
279
280
ENDDO
281
!      print *,' LWC after 244: CC below level of calculation'
282
283
!*         2.5     CLOUD COVER ABOVE THE LEVEL OF CALCULATION
284
!                  ------------------------------------------
285
286
!250  CONTINUE
287
288
DO JK1 = 1 , KLEV
289
  DO JL = KIDIA,KFDIA
290
    ZCLEAR(JL)=1.0_JPRB
291
    ZCLOUD(JL)=0.0_JPRB
292
  ENDDO
293
294
  DO JK = JK1 , KLEV
295
    ZALPHA1=RA1OVLP(KLEV+1-JK)
296
297
    DO JL = KIDIA,KFDIA
298
!++MODIFCODE
299
      IF ((NOVLP == 1).OR.(NOVLP==6).OR.(NOVLP==8)) THEN
300
!--MODIFCODE
301
!* maximum-random
302
        ZCLEAR(JL)=ZCLEAR(JL)*(1.0_JPRB-MAX(PCLDLD(JL,JK),ZCLOUD(JL)))&
303
         & /(1.0_JPRB-MIN(ZCLOUD(JL),1.0_JPRB-REPCLC))
304
        ZCLM(JL,JK1,JK) = 1.0_JPRB - ZCLEAR(JL)
305
        ZCLOUD(JL) = PCLDLD(JL,JK)
306
!++MODIFCODE
307
      ELSEIF ((NOVLP == 2).OR.(NOVLP==7)) THEN
308
!--MODIFCODE
309
!* maximum
310
        ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLD(JL,JK))
311
        ZCLM(JL,JK1,JK) = ZCLOUD(JL)
312
!++MODIFCODE
313
      ELSEIF ((NOVLP == 3).OR.(NOVLP==5)) THEN
314
!--MODIFCODE
315
!* random
316
        ZCLEAR(JL) = ZCLEAR(JL)*(1.0_JPRB - PCLDLD(JL,JK))
317
        ZCLOUD(JL) = 1.0_JPRB - ZCLEAR(JL)
318
        ZCLM(JL,JK1,JK) = ZCLOUD(JL)
319
      ELSEIF (NOVLP == 4) THEN
320
!** Hogan & Illingworth (2001)
321
        ZCLEAR(JL)=ZCLEAR(JL)*( &
322
         & ZALPHA1*(1.0_JPRB-MAX(PCLDLD(JL,JK),ZCLOUD(JL))) &
323
         & /(1.0_JPRB-MIN(ZCLOUD(JL),1.0_JPRB-REPCLC)) &
324
         & +(1.0_JPRB-ZALPHA1)*(1.0_JPRB - PCLDLD(JL,JK)) )
325
        ZCLM(JL,JK1,JK) = 1.0_JPRB - ZCLEAR(JL)
326
        ZCLOUD(JL) = PCLDLD(JL,JK)
327
      ENDIF
328
    ENDDO
329
  ENDDO
330
ENDDO
331
!      print *,' LWC after 254: CC above level of calculation'
332
333
!*         3.      FLUXES FOR PARTIAL/MULTIPLE LAYERED CLOUDINESS
334
!                  ----------------------------------------------
335
336
!300  CONTINUE
337
338
!*         3.1     DOWNWARD FLUXES
339
!                  ---------------
340
341
!310  CONTINUE
342
343
DO JL = KIDIA,KFDIA
344
  PFLUX(JL,2,KLEV+1) = 0.0_JPRB
345
ENDDO
346
347
DO JK1 = KLEV , 1 , -1
348
349
!*                 CONTRIBUTION FROM CLEAR-SKY FRACTION
350
351
  DO JL = KIDIA,KFDIA
352
    ZFD (JL) = (1.0_JPRB - ZCLM(JL,JK1,KLEV)) * ZDNF(JL,1,JK1)
353
354
!*                 CONTRIBUTION FROM ADJACENT CLOUD
355
356
    ZFD(JL) = ZFD(JL) + ZCLM(JL,JK1,JK1) * ZDNF(JL,JK1+1,JK1)
357
  ENDDO
358
359
!*                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
360
361
  DO JK = KLEV-1 , JK1 , -1
362
    DO JL = KIDIA,KFDIA
363
      ZCFRAC = ZCLM(JL,JK1,JK+1) - ZCLM(JL,JK1,JK)
364
      ZFD(JL) =  ZFD(JL) + ZCFRAC * ZDNF(JL,JK+2,JK1)
365
    ENDDO
366
  ENDDO
367
368
  DO JL = KIDIA,KFDIA
369
    PFLUX(JL,2,JK1) = ZFD (JL)
370
  ENDDO
371
372
ENDDO
373
!      print *,' LWC after 317: Downward fluxes'
374
375
!*         3.2     UPWARD FLUX AT THE SURFACE
376
!                  --------------------------
377
378
!320  CONTINUE
379
380
DO JL = KIDIA,KFDIA
381
  PFLUX(JL,1,1) = PEMIT(JL)*PBSUI(JL)-(1.0_JPRB-PEMIT(JL))*PFLUX(JL,2,1)
382
ENDDO
383
384
!*         3.3     UPWARD FLUXES
385
!                  -------------
386
387
!330  CONTINUE
388
389
DO JK1 = 2 , KLEV+1
390
391
!*                 CONTRIBUTION FROM CLEAR-SKY FRACTION
392
393
  DO JL = KIDIA,KFDIA
394
    ZFU (JL) = (1.0_JPRB - ZCLM(JL,JK1,1)) * ZUPF(JL,1,JK1)
395
396
!*                 CONTRIBUTION FROM ADJACENT CLOUD
397
398
    ZFU(JL) =  ZFU(JL) + ZCLM(JL,JK1,JK1-1) * ZUPF(JL,JK1,JK1)
399
  ENDDO
400
401
!*                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
402
403
  DO JK = 2 , JK1-1
404
    DO JL = KIDIA,KFDIA
405
      ZCFRAC = ZCLM(JL,JK1,JK-1) - ZCLM(JL,JK1,JK)
406
      ZFU(JL) =  ZFU(JL) + ZCFRAC * ZUPF(JL,JK  ,JK1)
407
    ENDDO
408
  ENDDO
409
410
  DO JL = KIDIA,KFDIA
411
    PFLUX(JL,1,JK1) = ZFU (JL)
412
  ENDDO
413
414
ENDDO
415
!      print *,' LWC after 337: Upward fluxes'
416
417
!-----------------------------------------------------------------------
418
419
IF (LHOOK) CALL DR_HOOK('LWC',1,ZHOOK_HANDLE)
420
END SUBROUTINE LWC