source: LMDZ6/branches/Amaury_dev/libf/phylmd/phystokenc_mod.F90 @ 5409

Last change on this file since 5409 was 5158, checked in by abarral, 5 months ago

Add missing klon on strataer_emiss_mod.F90
Correct various missing explicit declarations
Replace tabs by spaces (tabs are not part of the fortran charset)
Continue cleaning modules
Removed unused arguments and variables
  • 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.7 KB
Line 
1
2! $Id: phystokenc_mod.F90 5158 2024-08-02 12:12:03Z 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 lmdz_print_control, ONLY: lunout
40  USE lmdz_grid_phy, 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
385END SUBROUTINE phystokenc
386
387END MODULE phystokenc_mod
Note: See TracBrowser for help on using the repository browser.