GCC Code Coverage Report

Directory: ./
File: rad/swde.f90
Date: 2022-01-11 19:19:34
Exec Total Coverage
Lines: 76 83 91.6%
Branches: 10 20 50.0%
Line Branch Exec Source
1 !OPTIONS XOPT(HSFUN)
2 56160 SUBROUTINE SWDE &
3 & ( KIDIA, KFDIA, KLON,&
4 & PGG , PREF , PRMUZ, PTO1, PW,&
5 & PRE1 , PRE2 , PTR1 , PTR2 &
6 & )
7
8 !**** *SWDE* - DELTA-EDDINGTON IN A CLOUDY LAYER
9
10 ! PURPOSE.
11 ! --------
12 ! COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY OF A CLOUDY
13 ! LAYER USING THE DELTA-EDDINGTON'S APPROXIMATION.
14
15 !** INTERFACE.
16 ! ----------
17 ! *SWDE* IS CALLED BY *SWR*, *SWNI*
18
19 ! EXPLICIT ARGUMENTS :
20 ! --------------------
21 ! PGG : (KLON) ; ASSYMETRY FACTOR
22 ! PREF : (KLON) ; REFLECTIVITY OF THE UNDERLYING LAYER
23 ! PRMUZ : (KLON) ; COSINE OF SOLAR ZENITH ANGLE
24 ! PTO1 : (KLON) ; OPTICAL THICKNESS
25 ! PW : (KLON) ; SINGLE SCATTERING ALBEDO
26 ! ==== OUTPUTS ===
27 ! PRE1 : (KLON) ; LAYER REFLECTIVITY ASSUMING NO
28 ! ; REFLECTION FROM UNDERLYING LAYER
29 ! PTR1 : (KLON) ; LAYER TRANSMISSIVITY ASSUMING NO
30 ! ; REFLECTION FROM UNDERLYING LAYER
31 ! PRE2 : (KLON) ; LAYER REFLECTIVITY ASSUMING
32 ! ; REFLECTION FROM UNDERLYING LAYER
33 ! PTR2 : (KLON) ; LAYER TRANSMISSIVITY ASSUMING
34 ! ; REFLECTION FROM UNDERLYING LAYER
35
36 ! IMPLICIT ARGUMENTS : NONE
37 ! --------------------
38
39 ! METHOD.
40 ! -------
41
42 ! STANDARD DELTA-EDDINGTON LAYER CALCULATIONS.
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: 88-12-15
62 ! 96-05-30 Michel Deque (security in EXP())
63 ! M.Hamrud 01-Oct-2003 CY28 Cleaning
64 ! Modified: 03-10-10 Deborah Salmond and Marta Janiskova Optimisation
65 ! Modified: 03-12-13 John Hague - MASS Vector Fns
66 ! Y.Seity 06-09-09 : add modset from O.Thouron (MesoNH) under NOVLP tests
67 ! ------------------------------------------------------------------
68
69 ! ------------------------------------------------------------------
70
71 !* 0.1 ARGUMENTS
72 ! ---------
73
74 USE PARKIND1 ,ONLY : JPIM ,JPRB
75 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK
76
77 USE YOERDU , ONLY : REPLOG
78 USE YOMJFH , ONLY : N_VMASS
79 !++MODIFCODE
80 USE YOERAD , ONLY : NOVLP
81 !--MODIFCODE
82 IMPLICIT NONE
83
84 INTEGER(KIND=JPIM),INTENT(IN) :: KLON
85 INTEGER(KIND=JPIM),INTENT(IN) :: KIDIA
86 INTEGER(KIND=JPIM),INTENT(IN) :: KFDIA
87 REAL(KIND=JPRB) ,INTENT(IN) :: PGG(KLON)
88 REAL(KIND=JPRB) ,INTENT(IN) :: PREF(KLON)
89 REAL(KIND=JPRB) ,INTENT(IN) :: PRMUZ(KLON)
90 REAL(KIND=JPRB) ,INTENT(IN) :: PTO1(KLON)
91 REAL(KIND=JPRB) ,INTENT(IN) :: PW(KLON)
92 REAL(KIND=JPRB) ,INTENT(OUT) :: PRE1(KLON)
93 REAL(KIND=JPRB) ,INTENT(OUT) :: PRE2(KLON)
94 REAL(KIND=JPRB) ,INTENT(OUT) :: PTR1(KLON)
95 REAL(KIND=JPRB) ,INTENT(OUT) :: PTR2(KLON)
96 112320 REAL(KIND=JPRB) :: ZTMP (4,KFDIA-KIDIA+1)
97 112320 REAL(KIND=JPRB) :: ZTMP2 (KFDIA-KIDIA+1+N_VMASS)
98 112320 REAL(KIND=JPRB) :: ZTMP3 (KFDIA-KIDIA+1+N_VMASS)
99 112320 REAL(KIND=JPRB) :: ZZARG (KFDIA-KIDIA+1+N_VMASS)
100 112320 REAL(KIND=JPRB) :: ZZARG2 (KFDIA-KIDIA+1+N_VMASS)
101
102 INTEGER(KIND=JPIM) :: JL, JLL, JLEN
103
104 REAL(KIND=JPRB) :: ZA11, ZA12, ZA13, ZA21, ZA22, ZA23, ZALPHA,&
105 & ZAM2B, ZAP2B, ZB21, ZB22, ZB23, &
106 & ZBETA, ZC1A, ZC1B, ZC2A, ZC2B, ZDENA, ZDENB, &
107 & ZDT, ZEXKM, ZEXKP, ZEXMU0, ZFF, ZGP, ZRI0A, &
108 & ZRI0B, ZRI0C, ZRI0D, ZRI1A, ZRI1B, ZRI1C, &
109 & ZRI1D, ZRK, ZRM2, ZRP, ZTOP, ZWCP, ZWM, ZX1, &
110 & ZX2, ZXM2P, ZXP2P
111
112
113 REAL(KIND=JPRB) :: MINJ, MAXJ, X, Y
114 REAL(KIND=JPRB) :: ZPRMUZ,ZIDENA,ZIDENB,ZRR
115 REAL(KIND=JPRB) :: ZHOOK_HANDLE
116
117 ! STATEMENT DUNCTIONS
118 MINJ(X,Y) = Y - 0.5_JPRB*(ABS(X-Y)-(X-Y))
119 MAXJ(X,Y) = Y + 0.5_JPRB*(ABS(X-Y)+(X-Y))
120
121 ! ------------------------------------------------------------------
122
123 !* 1. DELTA-EDDINGTON CALCULATIONS
124
125
1/2
✓ Branch 0 taken 56160 times.
✗ Branch 1 not taken.
 56160 IF (LHOOK) CALL DR_HOOK('SWDE',0,ZHOOK_HANDLE)
126
127 ZDT = 2.0_JPRB/3._JPRB
128
129
2/2
✓ Branch 0 taken 55823040 times.
✓ Branch 1 taken 56160 times.
 55879200 DO JL = KIDIA,KFDIA
130 55823040 JLL=JL-KIDIA+1
131 55823040 ZPRMUZ=1.0_JPRB/PRMUZ(JL)
132 !++MODIFCODE
133
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 55823040 times.
 55823040 IF (NOVLP >= 5) THEN !MESONH_VERSION
134 ✗ ZGP = PGG(JL)
135 ✗ ZTOP = PTO1(JL)
136 ✗ ZWCP = PW(JL)
137 ELSE !ECMWF VERSION
138 55823040 ZFF = PGG(JL)*PGG(JL)
139 55823040 ZGP = PGG(JL)/(1.0_JPRB+PGG(JL))
140 55823040 ZTOP = (1.0_JPRB- PW(JL) * ZFF) * PTO1(JL)
141 55823040 ZWCP = (1-ZFF)* PW(JL) /(1.0_JPRB- PW(JL) * ZFF)
142 ENDIF
143 !--MODIFCODE
144 55823040 ZX1 = 1.0_JPRB-ZWCP*ZGP
145 55823040 ZWM = 1.0_JPRB-ZWCP
146 55823040 ZRM2 = PRMUZ(JL) * PRMUZ(JL)
147 55823040 ZRK = SQRT(MAXJ(REPLOG,3._JPRB*ZWM*ZX1))
148 55823040 ZX2 = (1.0_JPRB-ZRK*ZRK*ZRM2)*(4._JPRB/3._JPRB)
149 55823040 ZRR = 1.0_JPRB/ZX2
150 55823040 ZRP=ZRK/ZX1
151 55823040 ZALPHA = ZWCP*ZRM2*(1.0_JPRB+ZGP*ZWM)*ZRR
152 55823040 ZBETA = ZWCP* PRMUZ(JL) *(1.0_JPRB+3._JPRB*ZGP*ZRM2*ZWM)*ZRR
153 55823040 ZZARG(JLL) = -MAXJ( -200._JPRB, MINJ( ZTOP*ZPRMUZ, 200._JPRB) )
154 55823040 ZZARG2(JLL) = MINJ( ZRK*ZTOP, 200._JPRB)
155 55823040 ZTMP(1,JLL) = ZPRMUZ
156 55823040 ZTMP(2,JLL) = ZALPHA
157 55823040 ZTMP(3,JLL) = ZBETA
158 55879200 ZTMP(4,JLL) = ZRP
159 ENDDO
160
161
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 56160 times.
 56160 IF(N_VMASS /= 0 ) THEN !USING VECTOR MASS
162 ✗ JLEN=KFDIA-KIDIA+N_VMASS-MOD(KFDIA-KIDIA,N_VMASS)
163 ✗ IF(KFDIA-KIDIA+1 /= JLEN) THEN
164 ✗ ZZARG (KFDIA-KIDIA+2:JLEN)=1.0_JPRB
165 ✗ ZZARG2 (KFDIA-KIDIA+2:JLEN)=1.0_JPRB
166 ENDIF
167 ! Commente par MPL le 21.11.08
168 ! CALL VEXP(ZTMP2,ZZARG, JLEN)
169 ! CALL VEXP(ZTMP3,ZZARG2,JLEN)
170 ELSE
171
2/2
✓ Branch 0 taken 56160 times.
✓ Branch 1 taken 55823040 times.
 55879200 DO JL = KIDIA,KFDIA
172 55823040 JLL=JL-KIDIA+1
173 55823040 ZTMP2(JLL) = EXP(ZZARG(JLL))
174 55879200 ZTMP3(JLL) = EXP(ZZARG2(JLL))
175 ENDDO
176 ENDIF
177
178
2/2
✓ Branch 0 taken 55823040 times.
✓ Branch 1 taken 56160 times.
 55879200 DO JL = KIDIA,KFDIA
179 55823040 JLL=JL-KIDIA+1
180 55823040 ZEXMU0 = ZTMP2(JLL)
181 55823040 ZEXKP = ZTMP3(JLL)
182 55823040 ZPRMUZ = ZTMP(1,JLL)
183 55823040 ZALPHA = ZTMP(2,JLL)
184 55823040 ZBETA = ZTMP(3,JLL)
185 55823040 ZRP = ZTMP(4,JLL)
186 55823040 ZEXKM = 1.0_JPRB/ZEXKP
187 55823040 ZXP2P = 1.0_JPRB+ZDT*ZRP
188 55823040 ZXM2P = 1.0_JPRB-ZDT*ZRP
189 55823040 ZAP2B = ZALPHA+ZDT*ZBETA
190 55823040 ZAM2B = ZALPHA-ZDT*ZBETA
191
192 !* 1.2 WITHOUT REFLECTION FROM THE UNDERLYING LAYER
193
194 ZA11 = ZXP2P
195 ZA12 = ZXM2P
196 ZA13 = ZAP2B
197 55823040 ZA22 = ZXP2P*ZEXKP
198 55823040 ZA21 = ZXM2P*ZEXKM
199 55823040 ZA23 = ZAM2B*ZEXMU0
200 55823040 ZDENA = ZA11 * ZA22 - ZA21 * ZA12
201 55823040 ZIDENA=1.0_JPRB/ZDENA
202 55823040 ZC1A = (ZA22*ZA13-ZA12*ZA23)*ZIDENA
203 55823040 ZC2A = (ZA11*ZA23-ZA21*ZA13)*ZIDENA
204 55823040 ZRI0A = ZC1A+ZC2A-ZALPHA
205 55823040 ZRI1A = ZRP*(ZC1A-ZC2A)-ZBETA
206 55823040 PRE1(JL) = (ZRI0A-ZDT*ZRI1A)*ZPRMUZ
207 55823040 ZRI0B = ZC1A*ZEXKM+ZC2A*ZEXKP-ZALPHA*ZEXMU0
208 55823040 ZRI1B = ZRP*(ZC1A*ZEXKM-ZC2A*ZEXKP)-ZBETA*ZEXMU0
209 55823040 PTR1(JL) = ZEXMU0+(ZRI0B+ZDT*ZRI1B)*ZPRMUZ
210
211 !* 1.3 WITH REFLECTION FROM THE UNDERLYING LAYER
212
213 55823040 ZB21 = ZA21- PREF(JL) *ZXP2P*ZEXKM
214 55823040 ZB22 = ZA22- PREF(JL) *ZXM2P*ZEXKP
215 55823040 ZB23 = ZA23- PREF(JL) *ZEXMU0*(ZAP2B - PRMUZ(JL) )
216 55823040 ZDENB = ZA11 * ZB22 - ZB21 * ZA12
217 55823040 ZIDENB= 1.0_JPRB/ZDENB
218 55823040 ZC1B = (ZB22*ZA13-ZA12*ZB23)*ZIDENB
219 55823040 ZC2B = (ZA11*ZB23-ZB21*ZA13)*ZIDENB
220 55823040 ZRI0C = ZC1B+ZC2B-ZALPHA
221 55823040 ZRI1C = ZRP*(ZC1B-ZC2B)-ZBETA
222 55823040 PRE2(JL) = (ZRI0C-ZDT*ZRI1C) * ZPRMUZ
223 55823040 ZRI0D = ZC1B*ZEXKM + ZC2B*ZEXKP - ZALPHA*ZEXMU0
224 55823040 ZRI1D = ZRP * (ZC1B*ZEXKM - ZC2B*ZEXKP) - ZBETA*ZEXMU0
225 55879200 PTR2(JL) = ZEXMU0 + (ZRI0D + ZDT*ZRI1D) * ZPRMUZ
226 ENDDO
227
228
1/2
✓ Branch 0 taken 56160 times.
✗ Branch 1 not taken.
 56160 IF (LHOOK) CALL DR_HOOK('SWDE',1,ZHOOK_HANDLE)
229 56160 END SUBROUTINE SWDE
230
231