source: LMDZ6/trunk/libf/phylmd/yamada_c.F90 @ 5390

Last change on this file since 5390 was 5390, checked in by yann meurdesoif, 7 days ago
  • Remove UTF8 character that inihibit fortran parsing with GPU morphosis
  • Add missing END SUBROUTINE instead of simple END, that inhibit correct parsing with regulat expression parser (quick and dirty parsing)

YM
  • 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
File size: 15.5 KB
Line 
1!
2! $Header$
3!
4      SUBROUTINE yamada_c(ngrid,timestep,plev,play &
5     &   ,pu,pv,pt,d_u,d_v,d_t,cd,q2,km,kn,kq,d_t_diss,ustar &
6     &   ,iflag_pbl)
7      USE dimphy, ONLY: klon, klev
8      USE print_control_mod, ONLY: prt_level
9      USE ioipsl_getin_p_mod, ONLY : getin_p
10
11      USE yomcst_mod_h
12IMPLICIT NONE
13
14!
15! timestep : pas de temps
16! g  : g
17! zlev : altitude a chaque niveau (interface inferieure de la couche
18!        de meme indice)
19! zlay : altitude au centre de chaque couche
20! u,v : vitesse au centre de chaque couche
21!       (en entree : la valeur au debut du pas de temps)
22! teta : temperature potentielle au centre de chaque couche
23!        (en entree : la valeur au debut du pas de temps)
24! cd : cdrag
25!      (en entree : la valeur au debut du pas de temps)
26! q2 : $q^2$ au bas de chaque couche
27!      (en entree : la valeur au debut du pas de temps)
28!      (en sortie : la valeur a la fin du pas de temps)
29! km : diffusivite turbulente de quantite de mouvement (au bas de chaque
30!      couche)
31!      (en sortie : la valeur a la fin du pas de temps)
32! kn : diffusivite turbulente des scalaires (au bas de chaque couche)
33!      (en sortie : la valeur a la fin du pas de temps)
34!
35!  iflag_pbl doit valoir entre 6 et 9
36!      l=6, on prend  systematiquement une longueur d'equilibre
37!    iflag_pbl=6 : MY 2.0
38!    iflag_pbl=7 : MY 2.0.Fournier
39!    iflag_pbl=8/9 : MY 2.5
40!       iflag_pbl=8 with special obsolete treatments for convergence
41!       with Cmpi5 NPv3.1 simulations
42!    iflag_pbl=10/11 :  New scheme M2 and N2 explicit and dissiptation exact
43!    iflag_pbl=12 = 11 with vertical diffusion off q2
44!
45!  2013/04/01 (FH hourdin@lmd.jussieu.fr)
46!     Correction for very stable PBLs (iflag_pbl=10 and 11)
47!     iflag_pbl=8 converges numerically with NPv3.1
48!     iflag_pbl=11 -> the model starts with NP from start files created by ce0l
49!                  -> the model can run with longer time-steps.
50!.......................................................................
51
52      REAL, DIMENSION(klon,klev) :: d_u,d_v,d_t
53      REAL, DIMENSION(klon,klev) :: pu,pv,pt
54      REAL, DIMENSION(klon,klev) :: d_t_diss
55
56      REAL timestep
57      real plev(klon,klev+1)
58      real play(klon,klev)
59      real ustar(klon)
60      real kmin,qmin,pblhmin(klon),coriol(klon)
61      REAL zlev(klon,klev+1)
62      REAL zlay(klon,klev)
63      REAL zu(klon,klev)
64      REAL zv(klon,klev)
65      REAL zt(klon,klev)
66      REAL teta(klon,klev)
67      REAL cd(klon)
68      REAL q2(klon,klev+1),qpre
69      REAL unsdz(klon,klev)
70      REAL unsdzdec(klon,klev+1)
71
72      REAL km(klon,klev)
73      REAL kmpre(klon,klev+1),tmp2
74      REAL mpre(klon,klev+1)
75      REAL kn(klon,klev)
76      REAL kq(klon,klev)
77      real ff(klon,klev+1),delta(klon,klev+1)
78      real aa(klon,klev+1),aa0,aa1
79      integer iflag_pbl,ngrid
80      integer nlay,nlev
81
82      logical first
83      integer ipas
84      save first,ipas
85!FH/IM     data first,ipas/.true.,0/
86      data first,ipas/.false.,0/
87!$OMP THREADPRIVATE( first,ipas)
88       INTEGER, SAVE :: iflag_tke_diff=0
89!$OMP THREADPRIVATE(iflag_tke_diff)
90
91
92      integer ig,k
93
94
95      real ri,zrif,zalpha,zsm,zsn
96      real rif(klon,klev+1),sm(klon,klev+1),alpha(klon,klev)
97
98      real m2(klon,klev+1),dz(klon,klev+1),zq,n2(klon,klev+1)
99      REAL, DIMENSION(klon,klev+1) :: km2,kn2,sqrtq
100      real dtetadz(klon,klev+1)
101      real m2cstat,mcstat,kmcstat
102      real l(klon,klev+1)
103      real leff(klon,klev+1)
104      real,allocatable,save :: l0(:)
105!$OMP THREADPRIVATE(l0)     
106      real sq(klon),sqz(klon),zz(klon,klev+1)
107      integer iter
108
109      real ric,rifc,b1,kap
110      save ric,rifc,b1,kap
111      data ric,rifc,b1,kap/0.195,0.191,16.6,0.4/
112!$OMP THREADPRIVATE(ric,rifc,b1,kap)
113      real frif,falpha,fsm
114      real fl,zzz,zl0,zq2,zn2
115
116      real rino(klon,klev+1),smyam(klon,klev),styam(klon,klev)
117      real lyam(klon,klev),knyam(klon,klev)
118      real w2yam(klon,klev),t2yam(klon,klev)
119      logical,save :: firstcall=.true.
120!$OMP THREADPRIVATE(firstcall)       
121      CHARACTER(len=20),PARAMETER :: modname="yamada_c"
122REAL, DIMENSION(klon,klev+1) :: fluxu,fluxv,fluxt
123REAL, DIMENSION(klon,klev+1) :: dddu,dddv,dddt
124REAL, DIMENSION(klon,klev) :: exner,masse
125REAL, DIMENSION(klon,klev+1) :: masseb,q2old,q2neg
126      LOGICAL okiophys
127
128      frif(ri)=0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156))
129      falpha(ri)=1.318*(0.2231-ri)/(0.2341-ri)
130      fsm(ri)=1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri))
131      fl(zzz,zl0,zq2,zn2)= &
132     &     max(min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig)) &
133     &     ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10))) ,1.)
134
135
136      okiophys=klon==1
137      if (firstcall) then
138        CALL getin_p('iflag_tke_diff',iflag_tke_diff)
139        allocate(l0(klon))
140#define IOPHYS
141#ifdef IOPHYS
142!        call iophys_ini(timestep)
143#endif
144        firstcall=.false.
145      endif
146
147   IF (ngrid<=0) RETURN ! Bizarre : on n a pas ce probeleme pour coef_diff_turb
148
149#ifdef IOPHYS
150if (okiophys) then
151call iophys_ecrit('q2i',klev,'q2 debut my','m2/s2',q2(:,1:klev))
152call iophys_ecrit('kmi',klev,'Kz debut my','m/s2',km(:,1:klev))
153endif
154#endif
155
156      nlay=klev
157      nlev=klev+1
158
159
160!-------------------------------------------------------------------------
161! Computation of conservative source terms from the turbulent tendencies
162!-------------------------------------------------------------------------
163
164
165   zalpha=0.5 ! Anciennement 0.5. Essayer de voir pourquoi ?
166   zu(:,:)=pu(:,:)+zalpha*d_u(:,:)
167   zv(:,:)=pv(:,:)+zalpha*d_v(:,:)
168   zt(:,:)=pt(:,:)+zalpha*d_t(:,:)
169
170   do k=1,klev
171      exner(:,k)=(play(:,k)/plev(:,1))**RKAPPA
172      masse(:,k)=(plev(:,k)-plev(:,k+1))/RG
173      teta(:,k)=zt(:,k)/exner(:,k)
174   enddo
175
176! Atmospheric mass at layer interfaces, where the TKE is computed
177   masseb(:,:)=0.
178   do k=1,klev
179      masseb(:,k)=masseb(:,k)+masse(:,k)
180      masseb(:,k+1)=masseb(:,k+1)+masse(:,k)
181    enddo
182    masseb(:,:)=0.5*masseb(:,:)
183
184   zlev(:,1)=0.
185   zlay(:,1)=RCPD*teta(:,1)*(1.-exner(:,1))
186   do k=1,klev-1
187      zlay(:,k+1)=zlay(:,k)+0.5*RCPD*(teta(:,k)+teta(:,k+1))*(exner(:,k)-exner(:,k+1))/RG
188      zlev(:,k)=0.5*(zlay(:,k)+zlay(:,k+1)) ! PASBO
189   enddo
190
191   fluxu(:,klev+1)=0.
192   fluxv(:,klev+1)=0.
193   fluxt(:,klev+1)=0.
194
195   do k=klev,1,-1
196      fluxu(:,k)=fluxu(:,k+1)+masse(:,k)*d_u(:,k)
197      fluxv(:,k)=fluxv(:,k+1)+masse(:,k)*d_v(:,k)
198      fluxt(:,k)=fluxt(:,k+1)+masse(:,k)*d_t(:,k)/exner(:,k) ! Flux de theta
199   enddo
200
201   dddu(:,1)=2*zu(:,1)*fluxu(:,1)
202   dddv(:,1)=2*zv(:,1)*fluxv(:,1)
203   dddt(:,1)=(exner(:,1)-1.)*fluxt(:,1)
204
205   do k=2,klev
206      dddu(:,k)=(zu(:,k)-zu(:,k-1))*fluxu(:,k)
207      dddv(:,k)=(zv(:,k)-zv(:,k-1))*fluxv(:,k)
208      dddt(:,k)=(exner(:,k)-exner(:,k-1))*fluxt(:,k)
209   enddo
210   dddu(:,klev+1)=0.
211   dddv(:,klev+1)=0.
212   dddt(:,klev+1)=0.
213
214#ifdef IOPHYS
215if (okiophys) then
216      call iophys_ecrit('zlay',klev,'Geop','m',zlay)
217      call iophys_ecrit('teta',klev,'teta','K',teta)
218      call iophys_ecrit('temp',klev,'temp','K',zt)
219      call iophys_ecrit('pt',klev,'temp','K',pt)
220      call iophys_ecrit('pu',klev,'u','m/s',pu)
221      call iophys_ecrit('pv',klev,'v','m/s',pv)
222      call iophys_ecrit('d_u',klev,'d_u','m/s2',d_u)
223      call iophys_ecrit('d_v',klev,'d_v','m/s2',d_v)
224      call iophys_ecrit('d_t',klev,'d_t','K/s',d_t)
225      call iophys_ecrit('exner',klev,'exner','',exner)
226      call iophys_ecrit('masse',klev,'masse','',masse)
227      call iophys_ecrit('masseb',klev,'masseb','',masseb)
228endif
229#endif
230
231
232
233      ipas=ipas+1
234
235
236!.......................................................................
237!  les increments verticaux
238!.......................................................................
239!
240!!!!!! allerte !!!!!c
241!!!!!! zlev n'est pas declare a nlev !!!!!c
242!!!!!! ---->
243                                                      DO ig=1,ngrid
244            zlev(ig,nlev)=zlay(ig,nlay) &
245     &             +( zlay(ig,nlay) - zlev(ig,nlev-1) )
246                                                      ENDDO
247!!!!!! <----
248!!!!!! allerte !!!!!c
249!
250      DO k=1,nlay
251                                                      DO ig=1,ngrid
252        unsdz(ig,k)=1.E+0/(zlev(ig,k+1)-zlev(ig,k))
253                                                      ENDDO
254      ENDDO
255                                                      DO ig=1,ngrid
256      unsdzdec(ig,1)=1.E+0/(zlay(ig,1)-zlev(ig,1))
257                                                      ENDDO
258      DO k=2,nlay
259                                                      DO ig=1,ngrid
260        unsdzdec(ig,k)=1.E+0/(zlay(ig,k)-zlay(ig,k-1))
261                                                     ENDDO
262      ENDDO
263                                                      DO ig=1,ngrid
264      unsdzdec(ig,nlay+1)=1.E+0/(zlev(ig,nlay+1)-zlay(ig,nlay))
265                                                     ENDDO
266!
267!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
268! Computing M^2, N^2, Richardson numbers, stability functions
269!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
270
271
272      do k=2,klev
273                                                          do ig=1,ngrid
274         dz(ig,k)=zlay(ig,k)-zlay(ig,k-1)
275         m2(ig,k)=((zu(ig,k)-zu(ig,k-1))**2+(zv(ig,k)-zv(ig,k-1))**2)/(dz(ig,k)*dz(ig,k))
276         dtetadz(ig,k)=(teta(ig,k)-teta(ig,k-1))/dz(ig,k)
277         n2(ig,k)=RG*2.*dtetadz(ig,k)/(teta(ig,k-1)+teta(ig,k))
278!        n2(ig,k)=0.
279         ri=n2(ig,k)/max(m2(ig,k),1.e-10)
280         if (ri.lt.ric) then
281            rif(ig,k)=frif(ri)
282         else
283            rif(ig,k)=rifc
284         endif
285         if(rif(ig,k)<0.16) then
286            alpha(ig,k)=falpha(rif(ig,k))
287            sm(ig,k)=fsm(rif(ig,k))
288         else
289            alpha(ig,k)=1.12
290            sm(ig,k)=0.085
291         endif
292         zz(ig,k)=b1*m2(ig,k)*(1.-rif(ig,k))*sm(ig,k)
293                                                          enddo
294      enddo
295
296
297
298!====================================================================
299!  Computing the mixing length
300!====================================================================
301
302!   Mise a jour de l0
303      if (iflag_pbl==8.or.iflag_pbl==10) then
304
305!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
306! Iterative computation of l0
307! This version is kept for iflag_pbl only for convergence
308! with NPv3.1 Cmip5 simulations
309!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
310
311                                                          do ig=1,ngrid
312      sq(ig)=1.e-10
313      sqz(ig)=1.e-10
314                                                          enddo
315      do k=2,klev-1
316                                                          do ig=1,ngrid
317        zq=sqrt(q2(ig,k))
318        sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1))
319        sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1))
320                                                          enddo
321      enddo
322                                                          do ig=1,ngrid
323      l0(ig)=0.2*sqz(ig)/sq(ig)
324                                                          enddo
325      do k=2,klev
326                                                          do ig=1,ngrid
327         l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k))
328                                                          enddo
329      enddo
330!     print*,'L0 cas 8 ou 10 ',l0
331
332      else
333
334!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
335! In all other case, the assymptotic mixing length l0 is imposed (100m)
336!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
337
338          l0(:)=150.
339          do k=2,klev
340                                                          do ig=1,ngrid
341             l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k))
342                                                          enddo
343          enddo
344!     print*,'L0 cas autres ',l0
345
346      endif
347
348
349#ifdef IOPHYS
350if (okiophys) then
351call iophys_ecrit('rif',klev,'Flux Richardson','m',rif(:,1:klev))
352call iophys_ecrit('m2',klev,'m2 ','m/s',m2(:,1:klev))
353call iophys_ecrit('Km2app',klev,'m2 conserv','m/s',km(:,1:klev)*m2(:,1:klev))
354call iophys_ecrit('Km',klev,'Km','m2/s',km(:,1:klev))
355endif
356#endif
357
358
359IF (iflag_pbl<20) then
360      ! For diagnostics only
361      RETURN
362
363ELSE
364
365!  print*,'OK1'
366
367! Evolution of TKE under source terms K M2 and K N2
368   leff(:,:)=max(l(:,:),1.)
369
370!##################################################################
371!#  IF (iflag_pbl==29) THEN
372!#     STOP'Ne pas utiliser iflag_pbl=29'
373!#     km2(:,:)=km(:,:)*m2(:,:)
374!#     kn2(:,:)=kn2(:,:)*rif(:,:)
375!#  ELSEIF (iflag_pbl==25) THEN
376! VERSION AVEC LA TKE EN MILIEU DE COUCHE
377!#     STOP'Ne pas utiliser iflag_pbl=25'
378!#     DO k=1,klev
379!#        km2(:,k)=-0.5*(dddu(:,k)+dddv(:,k)+dddu(:,k+1)+dddv(:,k+1)) &
380!#        &        /(masse(:,k)*timestep)
381!#        kn2(:,k)=rcpd*0.5*(dddt(:,k)+dddt(:,k+1))/(masse(:,k)*timestep)
382!#        leff(:,k)=0.5*(leff(:,k)+leff(:,k+1))
383!#     ENDDO
384!#     km2(:,klev+1)=0. ; kn2(:,klev+1)=0.
385!#  ELSE
386!#################################################################
387
388      km2(:,:)=-(dddu(:,:)+dddv(:,:))/(masseb(:,:)*timestep)
389      kn2(:,:)=rcpd*dddt(:,:)/(masseb(:,:)*timestep)
390!   ENDIF
391   q2neg(:,:)=q2(:,:)+timestep*(km2(:,:)-kn2(:,:))
392   q2(:,:)=min(max(q2neg(:,:),1.e-10),1.e4)
393
394 
395#ifdef IOPHYS
396if (okiophys) then
397      call iophys_ecrit('km2',klev,'m2 conserv','m/s',km2(:,1:klev))
398      call iophys_ecrit('kn2',klev,'n2 conserv','m/s',kn2(:,1:klev))
399endif
400#endif
401
402! Dissipation of TKE
403   q2old(:,:)=q2(:,:)
404   q2(:,:)=1./(1./sqrt(q2(:,:))+timestep/(2*leff(:,:)*b1))
405   q2(:,:)=q2(:,:)*q2(:,:)
406!  IF (iflag_pbl<=24) THEN
407      DO k=1,klev
408         d_t_diss(:,k)=(masseb(:,k)*(q2neg(:,k)-q2(:,k))+masseb(:,k+1)*(q2neg(:,k+1)-q2(:,k+1)))/(2.*rcpd*masse(:,k))
409      ENDDO
410
411!###################################################################
412!  ELSE IF (iflag_pbl<=27) THEN
413!     DO k=1,klev
414!        d_t_diss(:,k)=(q2neg(:,k)-q2(:,k))/rcpd
415!     ENDDO
416!  ENDIF
417!  print*,'iflag_pbl ',d_t_diss
418!###################################################################
419
420
421! Compuation of stability functions
422!   IF (iflag_pbl/=29) THEN
423      DO k=1,klev
424      DO ig=1,ngrid
425         IF (ABS(km2(ig,k))<=1.e-20) THEN
426            rif(ig,k)=0.
427         ELSE
428            rif(ig,k)=min(kn2(ig,k)/km2(ig,k),rifc)
429         ENDIF
430         IF (rif(ig,k).lt.0.16) THEN
431            alpha(ig,k)=falpha(rif(ig,k))
432            sm(ig,k)=fsm(rif(ig,k))
433         else
434            alpha(ig,k)=1.12
435            sm(ig,k)=0.085
436         endif
437      ENDDO
438      ENDDO
439!    ENDIF
440
441! Computation of turbulent diffusivities
442!  IF (25<=iflag_pbl.and.iflag_pbl<=28) THEN
443!    DO k=2,klev
444!       sqrtq(:,k)=sqrt(0.5*(q2(:,k)+q2(:,k-1)))
445!    ENDDO
446!  ELSE
447   kq(:,:)=0.
448   DO k=1,klev
449      ! Coefficient au milieu des couches pour diffuser la TKE
450      kq(:,k)=0.5*leff(:,k)*sqrt(q2(:,k))*0.2
451   ENDDO
452
453#ifdef IOPHYS
454if (okiophys) then
455call iophys_ecrit('q2b',klev,'KTE inter','m2/s',q2(:,1:klev))
456endif
457#endif
458
459  IF (iflag_tke_diff==1) THEN
460    CALL vdif_q2(timestep, RG, RD, ngrid, plev, pt, kq, q2)
461  ENDIF
462
463   km(:,:)=0.
464   kn(:,:)=0.
465   DO k=1,klev
466      km(:,k)=leff(:,k)*sqrt(q2(:,k))*sm(:,k)
467      kn(:,k)=km(:,k)*alpha(:,k)
468   ENDDO
469
470
471#ifdef IOPHYS
472if (okiophys) then
473call iophys_ecrit('mixingl',klev,'Mixing length','m',leff(:,1:klev))
474call iophys_ecrit('rife',klev,'Flux Richardson','m',rif(:,1:klev))
475call iophys_ecrit('q2f',klev,'KTE finale','m2/s',q2(:,1:klev))
476call iophys_ecrit('q2neg',klev,'KTE non bornee','m2/s',q2neg(:,1:klev))
477call iophys_ecrit('alpha',klev,'alpha','',alpha(:,1:klev))
478call iophys_ecrit('sm',klev,'sm','',sm(:,1:klev))
479call iophys_ecrit('q2f',klev,'KTE finale','m2/s',q2(:,1:klev))
480call iophys_ecrit('kmf',klev,'Kz final','m2/s',km(:,1:klev))
481call iophys_ecrit('knf',klev,'Kz final','m2/s',kn(:,1:klev))
482call iophys_ecrit('kqf',klev,'Kz final','m2/s',kq(:,1:klev))
483endif
484#endif
485
486
487ENDIF
488
489
490!  print*,'OK2'
491      RETURN
492      END SUBROUTINE yamada_c
Note: See TracBrowser for help on using the repository browser.