GCC Code Coverage Report


Directory: ./
File: phys/phystokenc_mod.f90
Date: 2022-01-11 19:19:34
Exec Total Coverage
Lines: 4 170 2.4%
Branches: 0 294 0.0%

Line Branch Exec Source
1 !
2 ! $Id: phystokenc_mod.F90 2343 2015-08-20 10:02:53Z emillour $
3 !
4 MODULE phystokenc_mod
5
6 IMPLICIT NONE
7
8 LOGICAL,SAVE :: offline
9 !$OMP THREADPRIVATE(offline)
10 INTEGER,SAVE :: istphy
11 !$OMP THREADPRIVATE(istphy)
12
13
14 CONTAINS
15
16 1 SUBROUTINE init_phystokenc(offline_dyn,istphy_dyn)
17 IMPLICIT NONE
18 LOGICAL,INTENT(IN) :: offline_dyn
19 INTEGER,INTENT(IN) :: istphy_dyn
20
21 1 offline=offline_dyn
22 1 istphy=istphy_dyn
23
24 1 END SUBROUTINE init_phystokenc
25
26 SUBROUTINE phystokenc (nlon,nlev,pdtphys,rlon,rlat, &
27 pt,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, &
28 pfm_therm,pentr_therm, &
29 cdragh, pcoefh,yu1,yv1,ftsol,pctsrf, &
30 frac_impa,frac_nucl, &
31 pphis,paire,dtime,itap, &
32 psh, pda, pphi, pmp, pupwd, pdnwd)
33
34 USE ioipsl
35 USE dimphy
36 USE infotrac_phy, ONLY : nqtot
37 USE iophy
38 USE indice_sol_mod
39 USE print_control_mod, ONLY: lunout
40 USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat
41
42 IMPLICIT NONE
43
44 !======================================================================
45 ! Auteur(s) FH
46 ! Objet: Ecriture des variables pour transport offline
47 !
48 !======================================================================
49
50 ! Arguments:
51 !
52 REAL,DIMENSION(klon,klev), INTENT(IN) :: psh ! humidite specifique
53 REAL,DIMENSION(klon,klev), INTENT(IN) :: pda
54 REAL,DIMENSION(klon,klev,klev), INTENT(IN):: pphi
55 REAL,DIMENSION(klon,klev), INTENT(IN) :: pmp
56 REAL,DIMENSION(klon,klev), INTENT(IN) :: pupwd ! saturated updraft mass flux
57 REAL,DIMENSION(klon,klev), INTENT(IN) :: pdnwd ! saturated downdraft mass flux
58
59 ! EN ENTREE:
60 ! ==========
61 !
62 ! divers:
63 ! -------
64 !
65 INTEGER nlon ! nombre de points horizontaux
66 INTEGER nlev ! nombre de couches verticales
67 REAL pdtphys ! pas d'integration pour la physique (seconde)
68 INTEGER itap
69 INTEGER, SAVE :: physid
70 !$OMP THREADPRIVATE(physid)
71
72 ! convection:
73 ! -----------
74 !
75 REAL pmfu(klon,klev) ! flux de masse dans le panache montant
76 REAL pmfd(klon,klev) ! flux de masse dans le panache descendant
77 REAL pen_u(klon,klev) ! flux entraine dans le panache montant
78 REAL pde_u(klon,klev) ! flux detraine dans le panache montant
79 REAL pen_d(klon,klev) ! flux entraine dans le panache descendant
80 REAL pde_d(klon,klev) ! flux detraine dans le panache descendant
81 REAL pt(klon,klev)
82 REAL,ALLOCATABLE,SAVE :: t(:,:)
83 !$OMP THREADPRIVATE(t)
84 !
85 REAL rlon(klon), rlat(klon), dtime
86 REAL zx_tmp_3d(nbp_lon,nbp_lat,klev),zx_tmp_2d(nbp_lon,nbp_lat)
87
88 ! Couche limite:
89 ! --------------
90 !
91 REAL cdragh(klon) ! cdrag
92 REAL pcoefh(klon,klev) ! coeff melange CL
93 REAL pcoefh_buf(klon,klev) ! coeff melange CL + cdrag
94 REAL yv1(klon)
95 REAL yu1(klon),pphis(klon),paire(klon)
96
97 ! Les Thermiques : (Abderr 25 11 02)
98 ! ---------------
99 REAL, INTENT(IN) :: pfm_therm(klon,klev+1)
100 REAL pentr_therm(klon,klev)
101
102 REAL,ALLOCATABLE,SAVE :: entr_therm(:,:)
103 REAL,ALLOCATABLE,SAVE :: fm_therm(:,:)
104 !$OMP THREADPRIVATE(entr_therm)
105 !$OMP THREADPRIVATE(fm_therm)
106 !
107 ! Lessivage:
108 ! ----------
109 !
110 REAL frac_impa(klon,klev)
111 REAL frac_nucl(klon,klev)
112 !
113 ! Arguments necessaires pour les sources et puits de traceur
114 !
115 REAL ftsol(klon,nbsrf) ! Temperature du sol (surf)(Kelvin)
116 REAL pctsrf(klon,nbsrf) ! Pourcentage de sol f(nature du sol)
117 !======================================================================
118 !
119 INTEGER i, k, kk
120 REAL,ALLOCATABLE,SAVE :: mfu(:,:) ! flux de masse dans le panache montant
121 REAL,ALLOCATABLE,SAVE :: mfd(:,:) ! flux de masse dans le panache descendant
122 REAL,ALLOCATABLE,SAVE :: en_u(:,:) ! flux entraine dans le panache montant
123 REAL,ALLOCATABLE,SAVE :: de_u(:,:) ! flux detraine dans le panache montant
124 REAL,ALLOCATABLE,SAVE :: en_d(:,:) ! flux entraine dans le panache descendant
125 REAL,ALLOCATABLE,SAVE :: de_d(:,:) ! flux detraine dans le panache descendant
126 REAL,ALLOCATABLE,SAVE :: coefh(:,:) ! flux detraine dans le panache descendant
127
128 REAL,ALLOCATABLE,SAVE :: pyu1(:)
129 REAL,ALLOCATABLE,SAVE :: pyv1(:)
130 REAL,ALLOCATABLE,SAVE :: pftsol(:,:)
131 REAL,ALLOCATABLE,SAVE :: ppsrf(:,:)
132 !$OMP THREADPRIVATE(mfu,mfd,en_u,de_u,en_d,de_d,coefh)
133 !$OMP THREADPRIVATE(pyu1,pyv1,pftsol,ppsrf)
134
135
136 REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: sh
137 REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: da
138 REAL,DIMENSION(:,:,:), ALLOCATABLE,SAVE :: phi
139 REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: mp
140 REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: upwd
141 REAL,DIMENSION(:,:), ALLOCATABLE,SAVE :: dnwd
142
143 REAL, SAVE :: dtcum
144 INTEGER, SAVE:: iadvtr=0
145 !$OMP THREADPRIVATE(dtcum,iadvtr)
146 REAL zmin,zmax
147 LOGICAL ok_sync
148 CHARACTER(len=12) :: nvar
149 logical, parameter :: lstokenc=.FALSE.
150 !
151 !======================================================================
152
153 iadvtr=iadvtr+1
154
155 ! Dans le meme vecteur on recombine le drag et les coeff d'echange
156 pcoefh_buf(:,1) = cdragh(:)
157 pcoefh_buf(:,2:klev) = pcoefh(:,2:klev)
158
159 ok_sync = .TRUE.
160
161 ! Initialization done only once
162 !======================================================================
163 IF (iadvtr==1) THEN
164 ALLOCATE( t(klon,klev))
165 ALLOCATE( mfu(klon,klev))
166 ALLOCATE( mfd(klon,klev))
167 ALLOCATE( en_u(klon,klev))
168 ALLOCATE( de_u(klon,klev))
169 ALLOCATE( en_d(klon,klev))
170 ALLOCATE( de_d(klon,klev))
171 ALLOCATE( coefh(klon,klev))
172 ALLOCATE( entr_therm(klon,klev))
173 ALLOCATE( fm_therm(klon,klev))
174 ALLOCATE( pyu1(klon))
175 ALLOCATE( pyv1(klon))
176 ALLOCATE( pftsol(klon,nbsrf))
177 ALLOCATE( ppsrf(klon,nbsrf))
178
179 ALLOCATE(sh(klon,klev))
180 ALLOCATE(da(klon,klev))
181 ALLOCATE(phi(klon,klev,klev))
182 ALLOCATE(mp(klon,klev))
183 ALLOCATE(upwd(klon,klev))
184 ALLOCATE(dnwd(klon,klev))
185
186 CALL initphysto('phystoke', dtime, dtime*istphy,dtime*istphy,physid)
187
188 ! Write field phis and aire only once
189 CALL histwrite_phy(physid,lstokenc,"phis",itap,pphis)
190 CALL histwrite_phy(physid,lstokenc,"aire",itap,paire)
191 CALL histwrite_phy(physid,lstokenc,"longitudes",itap,rlon)
192 CALL histwrite_phy(physid,lstokenc,"latitudes",itap,rlat)
193
194 END IF
195
196
197 ! Set to zero cumulating fields
198 !======================================================================
199 IF (MOD(iadvtr,istphy)==1.OR.istphy==1) THEN
200 WRITE(lunout,*)'reinitialisation des champs cumules a iadvtr=',iadvtr
201 mfu(:,:)=0.
202 mfd(:,:)=0.
203 en_u(:,:)=0.
204 de_u(:,:)=0.
205 en_d(:,:)=0.
206 de_d(:,:)=0.
207 coefh(:,:)=0.
208 t(:,:)=0.
209 fm_therm(:,:)=0.
210 entr_therm(:,:)=0.
211 pyv1(:)=0.
212 pyu1(:)=0.
213 pftsol(:,:)=0.
214 ppsrf(:,:)=0.
215 sh(:,:)=0.
216 da(:,:)=0.
217 phi(:,:,:)=0.
218 mp(:,:)=0.
219 upwd(:,:)=0.
220 dnwd(:,:)=0.
221 dtcum=0.
222 ENDIF
223
224
225 ! Cumulate fields at each time step
226 !======================================================================
227 DO k=1,klev
228 DO i=1,klon
229 mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys
230 mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys
231 en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys
232 de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys
233 en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys
234 de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys
235 coefh(i,k)=coefh(i,k)+pcoefh_buf(i,k)*pdtphys
236 t(i,k)=t(i,k)+pt(i,k)*pdtphys
237 fm_therm(i,k)=fm_therm(i,k)+pfm_therm(i,k)*pdtphys
238 entr_therm(i,k)=entr_therm(i,k)+pentr_therm(i,k)*pdtphys
239 sh(i,k) = sh(i,k) + psh(i,k)*pdtphys
240 da(i,k) = da(i,k) + pda(i,k)*pdtphys
241 mp(i,k) = mp(i,k) + pmp(i,k)*pdtphys
242 upwd(i,k) = upwd(i,k) + pupwd(i,k)*pdtphys
243 dnwd(i,k) = dnwd(i,k) + pdnwd(i,k)*pdtphys
244 ENDDO
245 ENDDO
246
247 DO kk=1,klev
248 DO k=1,klev
249 DO i=1,klon
250 phi(i,k,kk) = phi(i,k,kk) + pphi(i,k,kk)*pdtphys
251 END DO
252 END DO
253 END DO
254
255 DO i=1,klon
256 pyv1(i)=pyv1(i)+yv1(i)*pdtphys
257 pyu1(i)=pyu1(i)+yu1(i)*pdtphys
258 END DO
259 DO k=1,nbsrf
260 DO i=1,klon
261 pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys
262 ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys
263 ENDDO
264 ENDDO
265
266 ! Add time step to cumulated time
267 dtcum=dtcum+pdtphys
268
269
270 ! Write fields to file, if it is time to do so
271 !======================================================================
272 IF(MOD(iadvtr,istphy)==0) THEN
273
274 ! normalize with time period
275 DO k=1,klev
276 DO i=1,klon
277 mfu(i,k)=mfu(i,k)/dtcum
278 mfd(i,k)=mfd(i,k)/dtcum
279 en_u(i,k)=en_u(i,k)/dtcum
280 de_u(i,k)=de_u(i,k)/dtcum
281 en_d(i,k)=en_d(i,k)/dtcum
282 de_d(i,k)=de_d(i,k)/dtcum
283 coefh(i,k)=coefh(i,k)/dtcum
284 t(i,k)=t(i,k)/dtcum
285 fm_therm(i,k)=fm_therm(i,k)/dtcum
286 entr_therm(i,k)=entr_therm(i,k)/dtcum
287 sh(i,k)=sh(i,k)/dtcum
288 da(i,k)=da(i,k)/dtcum
289 mp(i,k)=mp(i,k)/dtcum
290 upwd(i,k)=upwd(i,k)/dtcum
291 dnwd(i,k)=dnwd(i,k)/dtcum
292 ENDDO
293 ENDDO
294 DO kk=1,klev
295 DO k=1,klev
296 DO i=1,klon
297 phi(i,k,kk) = phi(i,k,kk)/dtcum
298 END DO
299 END DO
300 END DO
301 DO i=1,klon
302 pyv1(i)=pyv1(i)/dtcum
303 pyu1(i)=pyu1(i)/dtcum
304 END DO
305 DO k=1,nbsrf
306 DO i=1,klon
307 pftsol(i,k)=pftsol(i,k)/dtcum
308 ppsrf(i,k)=ppsrf(i,k)/dtcum
309 ENDDO
310 ENDDO
311
312 ! write fields
313 CALL histwrite_phy(physid,lstokenc,"t",itap,t)
314 CALL histwrite_phy(physid,lstokenc,"mfu",itap,mfu)
315 CALL histwrite_phy(physid,lstokenc,"mfd",itap,mfd)
316 CALL histwrite_phy(physid,lstokenc,"en_u",itap,en_u)
317 CALL histwrite_phy(physid,lstokenc,"de_u",itap,de_u)
318 CALL histwrite_phy(physid,lstokenc,"en_d",itap,en_d)
319 CALL histwrite_phy(physid,lstokenc,"de_d",itap,de_d)
320 CALL histwrite_phy(physid,lstokenc,"coefh",itap,coefh)
321 CALL histwrite_phy(physid,lstokenc,"fm_th",itap,fm_therm)
322 CALL histwrite_phy(physid,lstokenc,"en_th",itap,entr_therm)
323 CALL histwrite_phy(physid,lstokenc,"frac_impa",itap,frac_impa)
324 CALL histwrite_phy(physid,lstokenc,"frac_nucl",itap,frac_nucl)
325 CALL histwrite_phy(physid,lstokenc,"pyu1",itap,pyu1)
326 CALL histwrite_phy(physid,lstokenc,"pyv1",itap,pyv1)
327 CALL histwrite_phy(physid,lstokenc,"ftsol1",itap,pftsol(:,1))
328 CALL histwrite_phy(physid,lstokenc,"ftsol2",itap,pftsol(:,2))
329 CALL histwrite_phy(physid,lstokenc,"ftsol3",itap,pftsol(:,3))
330 CALL histwrite_phy(physid,lstokenc,"ftsol4",itap,pftsol(:,4))
331 CALL histwrite_phy(physid,lstokenc,"psrf1",itap,ppsrf(:,1))
332 CALL histwrite_phy(physid,lstokenc,"psrf2",itap,ppsrf(:,2))
333 CALL histwrite_phy(physid,lstokenc,"psrf3",itap,ppsrf(:,3))
334 CALL histwrite_phy(physid,lstokenc,"psrf4",itap,ppsrf(:,4))
335 CALL histwrite_phy(physid,lstokenc,"sh",itap,sh)
336 CALL histwrite_phy(physid,lstokenc,"da",itap,da)
337 CALL histwrite_phy(physid,lstokenc,"mp",itap,mp)
338 CALL histwrite_phy(physid,lstokenc,"upwd",itap,upwd)
339 CALL histwrite_phy(physid,lstokenc,"dnwd",itap,dnwd)
340
341
342 ! phi
343 DO k=1,klev
344 IF (k<10) THEN
345 WRITE(nvar,'(i1)') k
346 ELSE IF (k<100) THEN
347 WRITE(nvar,'(i2)') k
348 ELSE
349 WRITE(nvar,'(i3)') k
350 END IF
351 nvar='phi_lev'//trim(nvar)
352
353 CALL histwrite_phy(physid,lstokenc,nvar,itap,phi(:,:,k))
354 END DO
355
356 ! Syncronize file
357 !$OMP MASTER
358 IF (ok_sync) CALL histsync(physid)
359 !$OMP END MASTER
360
361
362 ! Calculate min and max values for some fields (coefficients de lessivage)
363 zmin=1e33
364 zmax=-1e33
365 DO k=1,klev
366 DO i=1,klon
367 zmax=MAX(zmax,frac_nucl(i,k))
368 zmin=MIN(zmin,frac_nucl(i,k))
369 ENDDO
370 ENDDO
371 WRITE(lunout,*)'------ coefs de lessivage (min et max) --------'
372 WRITE(lunout,*)'facteur de nucleation ',zmin,zmax
373 zmin=1e33
374 zmax=-1e33
375 DO k=1,klev
376 DO i=1,klon
377 zmax=MAX(zmax,frac_impa(i,k))
378 zmin=MIN(zmin,frac_impa(i,k))
379 ENDDO
380 ENDDO
381 WRITE(lunout,*)'facteur d impaction ',zmin,zmax
382
383 ENDIF ! IF(MOD(iadvtr,istphy)==0)
384
385 END SUBROUTINE phystokenc
386
387 END MODULE phystokenc_mod
388