GCC Code Coverage Report

Directory: ./
File: rad/rrtm_init_140gp.f90
Date: 2022-01-11 19:19:34
Exec Total Coverage
Lines: 68 68 100.0%
Branches: 24 26 92.3%
Line Branch Exec Source
1 !***************************************************************************
2 1 SUBROUTINE RRTM_INIT_140GP
3 !***************************************************************************
4 ! Reformatted for F90 by JJMorcrette, ECMWF, 980714
5
6 ! Parameters
7 USE PARKIND1 ,ONLY : JPIM ,JPRB
8 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK
9
10 USE PARRRTM , ONLY : JPBAND ,JPG ,JPGPT
11 USE YOERRTWN , ONLY : NG
12 USE YOERRTFTR, ONLY : NGC ,NGN ,NGM , WT
13 ! Output
14 USE YOERRTBG2, ONLY : CORR1 ,CORR2
15 USE YOERRTRWT, ONLY : FREFA ,FREFB ,FREFADF ,FREFBDF ,RWGT
16
17
18 IMPLICIT NONE
19 REAL(KIND=JPRB) :: Z_WTSM(JPG)
20
21 INTEGER(KIND=JPIM) :: I, IBND, IG, IGC, IGCSM, IND, IPR, IPRSM, IPT
22
23 REAL(KIND=JPRB) :: Z_FP, Z_RTFP, Z_WTSUM
24 REAL(KIND=JPRB) :: ZHOOK_HANDLE
25
26 INTERFACE
27 SUBROUTINE RRTM_KGB1
28 END SUBROUTINE RRTM_KGB1
29 END INTERFACE
30 INTERFACE
31 SUBROUTINE RRTM_KGB10
32 END SUBROUTINE RRTM_KGB10
33 END INTERFACE
34 INTERFACE
35 SUBROUTINE RRTM_KGB11
36 END SUBROUTINE RRTM_KGB11
37 END INTERFACE
38 INTERFACE
39 SUBROUTINE RRTM_KGB12
40 END SUBROUTINE RRTM_KGB12
41 END INTERFACE
42 INTERFACE
43 SUBROUTINE RRTM_KGB13
44 END SUBROUTINE RRTM_KGB13
45 END INTERFACE
46 INTERFACE
47 SUBROUTINE RRTM_KGB14
48 END SUBROUTINE RRTM_KGB14
49 END INTERFACE
50 INTERFACE
51 SUBROUTINE RRTM_KGB15
52 END SUBROUTINE RRTM_KGB15
53 END INTERFACE
54 INTERFACE
55 SUBROUTINE RRTM_KGB16
56 END SUBROUTINE RRTM_KGB16
57 END INTERFACE
58 INTERFACE
59 SUBROUTINE RRTM_KGB2
60 END SUBROUTINE RRTM_KGB2
61 END INTERFACE
62 INTERFACE
63 SUBROUTINE RRTM_KGB3
64 END SUBROUTINE RRTM_KGB3
65 END INTERFACE
66 INTERFACE
67 SUBROUTINE RRTM_KGB4
68 END SUBROUTINE RRTM_KGB4
69 END INTERFACE
70 INTERFACE
71 SUBROUTINE RRTM_KGB5
72 END SUBROUTINE RRTM_KGB5
73 END INTERFACE
74 INTERFACE
75 SUBROUTINE RRTM_KGB6
76 END SUBROUTINE RRTM_KGB6
77 END INTERFACE
78 INTERFACE
79 SUBROUTINE RRTM_KGB7
80 END SUBROUTINE RRTM_KGB7
81 END INTERFACE
82 INTERFACE
83 SUBROUTINE RRTM_KGB8
84 END SUBROUTINE RRTM_KGB8
85 END INTERFACE
86 INTERFACE
87 SUBROUTINE RRTM_KGB9
88 END SUBROUTINE RRTM_KGB9
89 END INTERFACE
90
91 INTERFACE
92 SUBROUTINE RRTM_CMBGB1
93 END SUBROUTINE RRTM_CMBGB1
94 END INTERFACE
95 INTERFACE
96 SUBROUTINE RRTM_CMBGB10
97 END SUBROUTINE RRTM_CMBGB10
98 END INTERFACE
99 INTERFACE
100 SUBROUTINE RRTM_CMBGB11
101 END SUBROUTINE RRTM_CMBGB11
102 END INTERFACE
103 INTERFACE
104 SUBROUTINE RRTM_CMBGB12
105 END SUBROUTINE RRTM_CMBGB12
106 END INTERFACE
107 INTERFACE
108 SUBROUTINE RRTM_CMBGB13
109 END SUBROUTINE RRTM_CMBGB13
110 END INTERFACE
111 INTERFACE
112 SUBROUTINE RRTM_CMBGB14
113 END SUBROUTINE RRTM_CMBGB14
114 END INTERFACE
115 INTERFACE
116 SUBROUTINE RRTM_CMBGB15
117 END SUBROUTINE RRTM_CMBGB15
118 END INTERFACE
119 INTERFACE
120 SUBROUTINE RRTM_CMBGB16
121 END SUBROUTINE RRTM_CMBGB16
122 END INTERFACE
123 INTERFACE
124 SUBROUTINE RRTM_CMBGB2
125 END SUBROUTINE RRTM_CMBGB2
126 END INTERFACE
127 INTERFACE
128 SUBROUTINE RRTM_CMBGB3
129 END SUBROUTINE RRTM_CMBGB3
130 END INTERFACE
131 INTERFACE
132 SUBROUTINE RRTM_CMBGB4
133 END SUBROUTINE RRTM_CMBGB4
134 END INTERFACE
135 INTERFACE
136 SUBROUTINE RRTM_CMBGB5
137 END SUBROUTINE RRTM_CMBGB5
138 END INTERFACE
139 INTERFACE
140 SUBROUTINE RRTM_CMBGB6
141 END SUBROUTINE RRTM_CMBGB6
142 END INTERFACE
143 INTERFACE
144 SUBROUTINE RRTM_CMBGB7
145 END SUBROUTINE RRTM_CMBGB7
146 END INTERFACE
147 INTERFACE
148 SUBROUTINE RRTM_CMBGB8
149 END SUBROUTINE RRTM_CMBGB8
150 END INTERFACE
151 INTERFACE
152 SUBROUTINE RRTM_CMBGB9
153 END SUBROUTINE RRTM_CMBGB9
154 END INTERFACE
155
156
1/2
✓ Branch 0 taken 1 times.
✗ Branch 1 not taken.
 1 IF (LHOOK) CALL DR_HOOK('RRTM_INIT_140GP',0,ZHOOK_HANDLE)
157
158 ! Read the absorption-related coefficients over the 16 x 16 g-points
159
160 1 CALL RRTM_KGB1
161 1 CALL RRTM_KGB2
162 1 CALL RRTM_KGB3
163 1 CALL RRTM_KGB4
164 1 CALL RRTM_KGB5
165 1 CALL RRTM_KGB6
166 1 CALL RRTM_KGB7
167 1 CALL RRTM_KGB8
168 1 CALL RRTM_KGB9
169 1 CALL RRTM_KGB10
170 1 CALL RRTM_KGB11
171 1 CALL RRTM_KGB12
172 1 CALL RRTM_KGB13
173 1 CALL RRTM_KGB14
174 1 CALL RRTM_KGB15
175 1 CALL RRTM_KGB16
176
177 ! Calculate lookup tables for functions needed in routine TAUMOL (TAUGB2)
178
179 ! FH 2017/05/03
180 ! Ce facteur de correction CORR2 est vraiment bizare parce qu'on
181 ! impose 1. aux bornes, en I=1 et I=200 mais la fonction
182 ! CORE=( 1 - sqrt(i/im) ) / ( 1 - i/im ) = 1/ ( 1 + sqrt(i/im))
183 ! vaut 1 en i=1 et 1/2 en i=im ...
184
185 1 CORR1(0) = 1.0_JPRB
186 1 CORR1(200) = 1.0_JPRB
187 1 CORR2(0) = 1.0_JPRB
188 1 CORR2(200) = 1.0_JPRB
189
2/2
✓ Branch 0 taken 199 times.
✓ Branch 1 taken 1 times.
 200 DO I = 1,199
190 199 Z_FP = 0.005_JPRB*REAL(I)
191 199 Z_RTFP = SQRT(Z_FP)
192 199 CORR1(I) = Z_RTFP/Z_FP
193 200 CORR2(I) = (1.0_JPRB-Z_RTFP)/(1.0_JPRB-Z_FP)
194 ENDDO
195
196 ! Perform g-point reduction from 16 per band (256 total points) to
197 ! a band dependant number (140 total points) for all absorption
198 ! coefficient input data and Planck fraction input data.
199 ! Compute relative weighting for new g-point combinations.
200
201 IGCSM = 0
202
2/2
✓ Branch 0 taken 16 times.
✓ Branch 1 taken 1 times.
 17 DO IBND = 1,JPBAND
203 IPRSM = 0
204
2/2
✓ Branch 0 taken 14 times.
✓ Branch 1 taken 2 times.
 17 IF (NGC(IBND) < 16) THEN
205
2/2
✓ Branch 0 taken 108 times.
✓ Branch 1 taken 14 times.
 122 DO IGC = 1,NGC(IBND)
206 108 IGCSM = IGCSM + 1
207 Z_WTSUM = 0.0_JPRB
208
2/2
✓ Branch 0 taken 224 times.
✓ Branch 1 taken 108 times.
 332 DO IPR = 1, NGN(IGCSM)
209 224 IPRSM = IPRSM + 1
210 332 Z_WTSUM = Z_WTSUM + WT(IPRSM)
211 ENDDO
212 122 Z_WTSM(IGC) = Z_WTSUM
213 ENDDO
214
2/2
✓ Branch 0 taken 224 times.
✓ Branch 1 taken 14 times.
 238 DO IG = 1,NG(IBND)
215 224 IND = (IBND-1)*16 + IG
216 238 RWGT(IND) = WT(IG)/Z_WTSM(NGM(IND))
217 ENDDO
218 ELSE
219
2/2
✓ Branch 0 taken 2 times.
✓ Branch 1 taken 32 times.
 34 DO IG = 1,NG(IBND)
220 32 IGCSM = IGCSM + 1
221 32 IND = (IBND-1)*16 + IG
222 34 RWGT(IND) = 1.0_JPRB
223 ENDDO
224 ENDIF
225 ENDDO
226
227 ! Initialize arrays for combined Planck fraction data.
228
229
2/2
✓ Branch 0 taken 13 times.
✓ Branch 1 taken 1 times.
 14 DO IPT = 1,13
230
2/2
✓ Branch 0 taken 1820 times.
✓ Branch 1 taken 13 times.
 1834 DO IPR = 1, JPGPT
231 1820 FREFA(IPR,IPT) = 0.0_JPRB
232 1833 FREFADF(IPR,IPT) = 0.0_JPRB
233 ENDDO
234 ENDDO
235
2/2
✓ Branch 0 taken 6 times.
✓ Branch 1 taken 1 times.
 7 DO IPT = 1,6
236
2/2
✓ Branch 0 taken 840 times.
✓ Branch 1 taken 6 times.
 847 DO IPR = 1, JPGPT
237 840 FREFB(IPR,IPT) = 0.0_JPRB
238 846 FREFBDF(IPR,IPT) = 0.0_JPRB
239 ENDDO
240 ENDDO
241
242 ! Reduce g-points for relevant data in each LW spectral band.
243
244 1 CALL RRTM_CMBGB1
245 1 CALL RRTM_CMBGB2
246 1 CALL RRTM_CMBGB3
247 1 CALL RRTM_CMBGB4
248 1 CALL RRTM_CMBGB5
249 1 CALL RRTM_CMBGB6
250 1 CALL RRTM_CMBGB7
251 1 CALL RRTM_CMBGB8
252 1 CALL RRTM_CMBGB9
253 1 CALL RRTM_CMBGB10
254 1 CALL RRTM_CMBGB11
255 1 CALL RRTM_CMBGB12
256 1 CALL RRTM_CMBGB13
257 1 CALL RRTM_CMBGB14
258 1 CALL RRTM_CMBGB15
259 1 CALL RRTM_CMBGB16
260
261
1/2
✓ Branch 0 taken 1 times.
✗ Branch 1 not taken.
 1 IF (LHOOK) CALL DR_HOOK('RRTM_INIT_140GP',1,ZHOOK_HANDLE)
262 1 END SUBROUTINE RRTM_INIT_140GP
263