source: LMDZ6/trunk/libf/phylmd/phystokenc_mod.f90 @ 5500

Last change on this file since 5500 was 5483, checked in by evignon, 6 days ago

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