GCC Code Coverage Report
Directory: ./ Exec Total Coverage
File: phylmd/phystokenc_mod.F90 Lines: 4 170 2.4 %
Date: 2023-06-30 12:51:15 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