GCC Code Coverage Report

Directory: ./
File: rad/sutoph.f90
Date: 2022-01-11 19:19:34
Exec Total Coverage
Lines: 53 72 73.6%
Branches: 9 26 34.6%
Line Branch Exec Source
1 !OPTIONS XOPT(NOEVAL)
2 1 SUBROUTINE SUTOPH(KULOUT)
3
4 !**** *SUTOPH* - Initialize common YOMTOPH top parameterization
5
6 ! Purpose.
7 ! --------
8 ! Initialize YOMTOPH, the common that contains the top pressure
9 ! and the first level of parameterization
10 ! it also contains mesospheric drag vertical profil
11
12 !** Interface.
13 ! ----------
14 ! *CALL* *SUTOPH(KULOUT)
15
16 ! Explicit arguments :
17 ! --------------------
18 ! KULOUT : Logical unit for the output
19
20 ! Implicit arguments :
21 ! --------------------
22 ! COMMON YOMTOPH, YOMSTA
23
24 ! Method.
25 ! -------
26 ! See documentation
27
28 ! Externals.
29 ! ----------
30
31 ! Reference.
32 ! ----------
33 ! Documentation ARPEGE
34
35 ! Author.
36 ! -------
37 ! A. Lasserre-Bigorry
38
39 ! Modifications.
40 ! --------------
41 ! Original : 91-06-10
42 ! Modified 92-02-22 by M. Deque (test of consistency between phys. para.)
43 ! Modified by R. EL Khatib : 93-04-02 Set-up defaults controled by LECMWF
44 ! Modified 93-11-17 by Ph. Dandin : FMR scheme with MF physics
45 ! Modified 97-05-17 by M. Deque : frozen FMR
46 ! M.Hamrud 01-Oct-2003 CY28 Cleaning
47 ! F.Bouyssel 04-11-22 : NTCOET,ETCOET
48 ! P. Marquet 05-09-12 : NTAJUC
49 ! M. Deque 05-09-12 : default RCLX
50 ! M. Deque 05-09-12 : default TPSCLIM
51 ! ------------------------------------------------------------------
52
53 USE PARKIND1 ,ONLY : JPIM ,JPRB
54 USE YOMHOOK ,ONLY : LHOOK, DR_HOOK
55
56 USE YOMDIM , ONLY : NFLEVG
57 ! Ce qui concerne NULNAM commente par MPL le 15.04.09
58 !USE YOMLUN , ONLY : NULNAM
59 USE YOMCT0B , ONLY : LECMWF
60 USE YOMSTA , ONLY : STPRE
61 USE YOMTOPH , ONLY : RMESOU ,RMESOT ,NTQSAT ,NTDIFU ,&
62 & NTCOEF ,NTDRAG ,NTCVIM ,NTPLUI ,NTRADI ,&
63 & NTNEBU ,NTOZON ,NTDRME ,ETQSAT ,ETDIFU ,&
64 & ETCOEF ,ETDRAG ,ETCVIM ,ETPLUI ,ETRADI ,&
65 & ETNEBU ,ETOZON ,ETDRME ,XDRMUK ,XDRMUX ,XDRMUP ,&
66 & XDRMTK ,XDRMTX ,XDRMTP ,NTCOET ,ETCOET ,&
67 & RMESOQ ,XDRMQK ,XDRMQP ,RFMESOQ ,RCLX ,&
68 & NTAJUC ,ETAJUC ,TPSCLIM
69 USE YOMPHY , ONLY : LRAY ,LRAYFM ,LRAYFM15 ,LRRMES
70 USE YOEPHY , ONLY : LAGPHY
71
72 ! ------------------------------------------------------------------
73
74 IMPLICIT NONE
75
76 INTEGER(KIND=JPIM),INTENT(IN) :: KULOUT
77
78 ! ------------------------------------------------------------------
79
80 INTEGER(KIND=JPIM) :: JLEV
81
82 REAL(KIND=JPRB) :: PAP, PAPX, ZMEST, ZMESU, ZMESQ
83
84 REAL(KIND=JPRB) :: PMESQF
85 REAL(KIND=JPRB) :: PMESTF
86 REAL(KIND=JPRB) :: PMESUF
87 REAL(KIND=JPRB) :: ZHOOK_HANDLE
88
89 ! ------------------------------------------------------------------
90
91 ! ------------------------------------------------------------------
92 NAMELIST/NAMTOPH/&
93 &ETQSAT,ETDIFU,ETCOEF,ETDRAG,ETCVIM,ETPLUI,ETRADI,ETNEBU &
94 &,ETOZON,ETDRME,ETCOET &
95 &,XDRMUK,XDRMUX,XDRMUP,XDRMTK,XDRMTX,XDRMTP &
96 &,XDRMQK,XDRMQP,RFMESOQ &
97 &,ETAJUC,NTAJUC,RCLX,TPSCLIM
98 ! ------------------------------------------------------------------
99
100
101 ! ------------------------------------------------------------------
102
103 !* Mesospheric drag shape function
104
105 ! PMESUF(PAP,PAPX) = MAX( (PAPX-PAP)/MAX(PAP**1.5,1.E-10),0. )
106 PMESUF(PAP,PAPX) = MAX( (PAPX-PAP)/MAX(PAP,1.E-10_JPRB),0.0_JPRB )
107 PMESTF(PAP,PAPX) = MAX( (PAPX-PAP)/MAX(PAP,1.E-10_JPRB),0.0_JPRB )
108 PMESQF(PAP,PAPX) = MAX( (PAPX-PAP)/MAX(PAP,1.E-10_JPRB),0.0_JPRB )
109
110 ! ------------------------------------------------------------------
111
112 INTERFACE
113 SUBROUTINE ABOR1(CDTEXT)
114 CHARACTER(LEN=*) :: CDTEXT
115 END SUBROUTINE ABOR1
116 END INTERFACE
117 INTERFACE
118 SUBROUTINE POSNAM(KULNAM,CDNAML)
119 USE PARKIND1 ,ONLY : JPIM ,JPRB
120 INTEGER(KIND=JPIM),INTENT(IN) :: KULNAM
121 CHARACTER(LEN=*) ,INTENT(IN) :: CDNAML
122 END SUBROUTINE POSNAM
123 END INTERFACE
124 INTERFACE
125 SUBROUTINE SEAPRE(PARA,KPARA,PSTPRE,KLEV)
126 USE PARKIND1 ,ONLY : JPIM ,JPRB
127 INTEGER(KIND=JPIM),INTENT(IN) :: KLEV
128 REAL(KIND=JPRB) ,INTENT(IN) :: PARA
129 INTEGER(KIND=JPIM),INTENT(OUT) :: KPARA
130 REAL(KIND=JPRB) ,INTENT(IN) :: PSTPRE(KLEV)
131 END SUBROUTINE SEAPRE
132 END INTERFACE
133
134 ! ------------------------------------------------------------------
135
136
1/2
✓ Branch 0 taken 1 times.
✗ Branch 1 not taken.
 1 IF (LHOOK) CALL DR_HOOK('SUTOPH',0,ZHOOK_HANDLE)
137
138 ! ------------------------------------------------------------------
139
140 !* 1. Set default values.
141 ! -------------------
142
143 ! 1.1 Set implicit default values
144
145 1 ETQSAT=0._JPRB
146 1 ETDIFU=0._JPRB
147 1 ETCOEF=0._JPRB
148 1 ETDRAG=0._JPRB
149 1 ETCVIM=0._JPRB
150 1 ETPLUI=0._JPRB
151 1 ETRADI=0._JPRB
152 1 ETNEBU=0._JPRB
153 1 ETOZON=0._JPRB
154 1 ETDRME=0._JPRB
155 1 ETCOET=0._JPRB
156 1 ETAJUC=0._JPRB
157 1 NTQSAT=1
158 1 NTDIFU=1
159 1 NTCOEF=1
160 1 NTDRAG=1
161 1 NTCVIM=1
162 1 NTPLUI=1
163 1 NTRADI=1
164 1 NTNEBU=1
165 1 NTOZON=1
166 1 NTDRME=1
167 1 NTCOET=1
168 1 NTAJUC=1
169
170 1 XDRMUK=0._JPRB
171 1 XDRMUX=0._JPRB
172 1 XDRMUP=0._JPRB
173 1 XDRMTK=0._JPRB
174 1 XDRMTX=0._JPRB
175 1 XDRMTP=0._JPRB
176 1 XDRMQK=0._JPRB
177 1 XDRMQP=0._JPRB
178
179 1 RFMESOQ=3.725E-06_JPRB
180 1 RCLX=0.0_JPRB
181 1 TPSCLIM=197._JPRB
182
183 ! 1.2 Modify default values according to LECMWF
184
185 IF (LECMWF) THEN
186 ELSE
187 ENDIF
188
189 ! ------------------------------------------------------------------
190
191 !* 2. Modify default values.
192 ! ----------------------
193
194 ! Ce qui concerne NAMTOPH commente par MPL le 15.04.09
195 !CALL POSNAM(NULNAM,'NAMTOPH')
196 !READ(NULNAM,NAMTOPH)
197
198 !* 2.1 Search corresponding level, to pressure in NAMTOPH
199 ! for each parameterization
200
201 IF(ETQSAT /= 0.0_JPRB) CALL SEAPRE (ETQSAT,NTQSAT,STPRE,NFLEVG)
202 IF(ETDIFU /= 0.0_JPRB) CALL SEAPRE (ETDIFU,NTDIFU,STPRE,NFLEVG)
203 IF(ETCOEF /= 0.0_JPRB) CALL SEAPRE (ETCOEF,NTCOEF,STPRE,NFLEVG)
204 IF(ETDRAG /= 0.0_JPRB) CALL SEAPRE (ETDRAG,NTDRAG,STPRE,NFLEVG)
205 IF(ETCVIM /= 0.0_JPRB) CALL SEAPRE (ETCVIM,NTCVIM,STPRE,NFLEVG)
206 IF(ETPLUI /= 0.0_JPRB) CALL SEAPRE (ETPLUI,NTPLUI,STPRE,NFLEVG)
207 IF(ETRADI /= 0.0_JPRB) THEN
208 IF (LRAY) THEN
209 CALL SEAPRE (ETRADI,NTRADI,STPRE,NFLEVG)
210 ENDIF
211 IF (LRAYFM.OR.LRAYFM15) THEN
212 ETRADI=0._JPRB
213 NTRADI=1
214 ENDIF
215 ENDIF
216 IF(ETNEBU /= 0.0_JPRB) CALL SEAPRE (ETNEBU,NTNEBU,STPRE,NFLEVG)
217 IF(ETOZON /= 0.0_JPRB) CALL SEAPRE (ETOZON,NTOZON,STPRE,NFLEVG)
218 IF(ETDRME /= 0.0_JPRB) CALL SEAPRE (ETDRME,NTDRME,STPRE,NFLEVG)
219 IF(ETCOET /= 0.0_JPRB) CALL SEAPRE (ETCOET,NTCOET,STPRE,NFLEVG)
220 IF(ETAJUC /= 0.0_JPRB) CALL SEAPRE (ETAJUC,NTAJUC,STPRE,NFLEVG)
221 ! ------------------------------------------------------------------
222
223 !* 3. Print final values.
224 ! -------------------
225
226 1 WRITE(UNIT=KULOUT,FMT='('' COMMON YOMTOPH '')')
227 WRITE(UNIT=KULOUT,FMT='('' ETQSAT = '',E10.4,'' NTQSAT = '',I10 &
228 & ,'' ETDIFU = '',E10.4,'' NTDIFU = '',I10 &
229 & ,/,'' ETCOEF = '',E10.4,'' NTCOEF = '',I10 &
230 & ,'' ETDRAG = '',E10.4,'' NTDRAG = '',I10 &
231 & ,/,'' ETCVIM = '',E10.4,'' NTCVIM = '',I10 &
232 & ,'' ETPLUI = '',E10.4,'' NTPLUI = '',I10 &
233 & ,/,'' ETRADI = '',E10.4,'' NTRADI = '',I10 &
234 & ,'' ETNEBU = '',E10.4,'' NTNEBU = '',I10 &
235 & ,/,'' ETOZON = '',E10.4,'' NTOZON = '',I10 &
236 & ,'' ETDRME = '',E10.4,'' NTDRME = '',I10 &
237 & ,/,'' ETCOET = '',E10.4,'' NTCOET = '',I10 &
238 & ,/,'' ETAJUC = '',E10.4,'' NTAJUC = '',I10 &
239 & ,/,'' XDRMUK = '',E10.4,'' XDRMUP = '',E10.4 &
240 & ,'' XDRMUX = '',E10.4,'' XDRMTK = '',E10.4 &
241 & ,'' XDRMTP = '',E10.4,'' XDRMTX = '',E10.4 &
242 & ,'' XDRMQK = '',E11.4,'' XDRMQP = '',E11.4 &
243 & ,/,'' RFMESOQ= '',E11.4,'' RCLX = '',E11.4 &
244 & )')&
245 1 & ETQSAT,NTQSAT,ETDIFU,NTDIFU &
246 1 & ,ETCOEF,NTCOEF,ETDRAG,NTDRAG &
247 1 & ,ETCVIM,NTCVIM,ETPLUI,NTPLUI &
248 1 & ,ETRADI,NTRADI,ETNEBU,NTNEBU &
249 1 & ,ETOZON,NTOZON,ETDRME,NTDRME &
250 1 & ,ETCOET,NTCOET &
251 1 & ,ETAJUC,NTAJUC &
252 1 & ,XDRMUK,XDRMUP,XDRMUX,XDRMTK,XDRMTP,XDRMTX &
253 2 & ,XDRMQK,XDRMQP,RFMESOQ,RCLX
254
255 ! VERIFICATION OF CONSISTENCY BETWEEN PHYSICAL PARAMETERIZATION
256
257
2/4
✓ Branch 0 taken 1 times.
✗ Branch 1 not taken.
✗ Branch 2 not taken.
✓ Branch 3 taken 1 times.
 1 IF (ETCOEF > ETDIFU.OR.ETCOEF > ETDRAG)THEN
258 ✗ WRITE(UNIT=KULOUT,FMT='('' ETCOEF TOO LOW '')')
259 ✗ CALL ABOR1('SUTOPH')
260 ENDIF
261
3/6
✓ Branch 0 taken 1 times.
✗ Branch 1 not taken.
✓ Branch 2 taken 1 times.
✗ Branch 3 not taken.
✗ Branch 4 not taken.
✓ Branch 5 taken 1 times.
 1 IF (ETQSAT > ETNEBU.OR.ETQSAT > ETPLUI.OR.ETQSAT > ETCVIM)THEN
262 ✗ WRITE(UNIT=KULOUT,FMT='('' ETQSAT TOO LOW '')')
263 ✗ CALL ABOR1('SUTOPH')
264 ENDIF
265
1/2
✗ Branch 0 not taken.
✓ Branch 1 taken 1 times.
 1 IF (ETCVIM > ETNEBU)THEN
266 ✗ WRITE(UNIT=KULOUT,FMT='('' ETCVIM TOO LOW '')')
267 ✗ CALL ABOR1('SUTOPH')
268 ENDIF
269
270 ! ------------------------------------------------------------------
271
272 !* 4. INITIALIZE MESOSPHERIC DRAG FOR U,V AND T
273 ! -----------------------------------------
274
275
1/4
✗ Branch 0 not taken.
✓ Branch 1 taken 1 times.
✗ Branch 2 not taken.
✗ Branch 3 not taken.
 1 IF (LRRMES.AND..NOT.LAGPHY) THEN
276 WRITE (UNIT=KULOUT,FMT='('' PROFIL VERTICAL DE DRAG MESO'',/&
277 & ,'' LEV'',T15,''VITESSE'',T45,''TEMPERATURE'' &
278 ✗ & , T65, ''HUMIDITE'' )')
279 ✗ DO JLEV=1,NFLEVG
280 ✗ RMESOU(JLEV)=XDRMUK*PMESUF(STPRE(JLEV),XDRMUP)
281 ✗ RMESOT(JLEV)=XDRMTK*PMESTF(STPRE(JLEV),XDRMTP)
282 ✗ RMESOQ(JLEV)=XDRMQK*PMESQF(STPRE(JLEV),XDRMQP)
283 ✗ IF (XDRMUX /= 0.0_JPRB) RMESOU(JLEV)=MIN(RMESOU(JLEV),XDRMUX)
284 ✗ IF (XDRMTX /= 0.0_JPRB) RMESOT(JLEV)=MIN(RMESOT(JLEV),XDRMTX)
285 ✗ ZMESU=1.0_JPRB/MAX(1.E-8_JPRB,RMESOU(JLEV)*3600._JPRB*24._JPRB)
286 ✗ ZMEST=1.0_JPRB/MAX(1.E-8_JPRB,RMESOT(JLEV)*3600._JPRB*24._JPRB)
287 ✗ ZMESQ=1.0_JPRB/MAX(1.E-8_JPRB,RMESOQ(JLEV)*3600._JPRB*24._JPRB)
288 WRITE (UNIT=KULOUT,FMT='(I3,T10,E9.3,T20,G9.3,T40,E9.3,T50 &
289 ✗ & ,G9.3, T70,E9.3, T80,G9.3)') JLEV,RMESOU(JLEV),ZMESU, &
290 ✗ & RMESOT(JLEV),ZMEST, &
291 ✗ & RMESOQ(JLEV),ZMESQ
292 ENDDO
293 ENDIF
294
295 ! ------------------------------------------------------------------
296
297
1/2
✓ Branch 0 taken 1 times.
✗ Branch 1 not taken.
 1 IF (LHOOK) CALL DR_HOOK('SUTOPH',1,ZHOOK_HANDLE)
298 1 END SUBROUTINE SUTOPH
299