My Project
 All Classes Files Functions Variables Macros
vlspltgen_loc.F
Go to the documentation of this file.
1 !
2 ! $Header$
3 !
4  SUBROUTINE vlspltgen_loc( q,iadv,pente_max,masse,w,pbaru,pbarv,
5  & pdt, p,pk,teta )
6 
7 c
8 c auteurs: p.le van, f.hourdin, f.forget, f.codron
9 c
10 c ********************************************************************
11 c shema d
12 
13 
14 
15 'advection " pseudo amont " .c + test sur humidite specifique: Q advecte< Qsat avalc (F. Codron, 10/99)c ********************************************************************c q,pbaru,pbarv,w sont des arguments d'entree pour le s-pg ....
16 c
17 c pente_max facteur de limitation des pentes: 2 en general
18 c 0 pour un schema amont
19 c pbaru,pbarv,w flux de masse en u ,v ,w
20 c pdt pas de temps
21 c
22 c teta temperature potentielle, p pression aux interfaces,
23 c pk exner au milieu des couches necessaire pour calculer qsat
24 c --------------------------------------------------------------------
25  USE parallel
26  USE mod_hallo
27  USE write_field_loc
28  USE vampir
29  USE infotrac, ONLY : nqtot
30  USE vlspltgen_mod
31  IMPLICIT NONE
32 
33 c
34 #include "dimensions.h"
35 #include "paramet.h"
36 #include "logic.h"
37 #include "comvert.h"
38 #include "comconst.h"
39 
40 c
41 c arguments:
42 c ----------
43  INTEGER iadv(nqtot)
44  REAL masse(ijb_u:ije_u,llm),pente_max
45  REAL pbaru( ijb_u:ije_u,llm ),pbarv( ijb_v:ije_v,llm)
46  REAL q(ijb_u:ije_u,llm,nqtot)
47  REAL w(ijb_u:ije_u,llm),pdt
48  REAL p(ijb_u:ije_u,llmp1),teta(ijb_u:ije_u,llm)
49  REAL pk(ijb_u:ije_u,llm)
50 c
51 c local
52 c ---------
53 c
54  INTEGER ij,l
55 c
56  REAL zzpbar, zzw
57 
58  REAL qmin,qmax
59  DATA qmin,qmax/0.,1.e33/
60 
61 c--pour rapport de melange saturant--
62 
63  REAL rtt,retv,r2es,r3les,r3ies,r4les,r4ies,play
64  REAL ptarg,pdelarg,foeew,zdelta
65  REAL tempe(ijb_u:ije_u)
66  INTEGER ijb,ije,iq
67  LOGICAL, SAVE :: firstcall=.true.
68 !$OMP THREADPRIVATE(firstcall)
69  type(request) :: myrequest1
70  type(request) :: myrequest2
71 
72 c fonction psat(t)
73 
74  foeew( ptarg,pdelarg ) = exp(
75  * (r3les*(1.-pdelarg)+r3ies*pdelarg) * (ptarg-rtt)
76  * / (ptarg-(r4les*(1.-pdelarg)+r4ies*pdelarg)) )
77 
78  r2es = 380.11733
79  r3les = 17.269
80  r3ies = 21.875
81  r4les = 35.86
82  r4ies = 7.66
83  retv = 0.6077667
84  rtt = 273.16
85 
86 c Allocate variables depending on dynamic variable nqtot
87 
88  IF (firstcall) THEN
89  firstcall=.false.
90  END IF
91 c-- calcul de qsat en chaque point
92 c-- approximation: au milieu des couches play(l)=(p(l)+p(l+1))/2
93 c pour eviter une exponentielle.
94 
95  call settag(myrequest1,100)
96  call settag(myrequest2,101)
97 
98 
99  ijb=ij_begin-iip1
100  ije=ij_end+iip1
101  if (pole_nord) ijb=ij_begin
102  if (pole_sud) ije=ij_end
103 
104 c$omp DO schedule(static,omp_chunk)
105  DO l = 1, llm
106  DO ij = ijb, ije
107  tempe(ij) = teta(ij,l) * pk(ij,l) /cpp
108  ENDDO
109  DO ij = ijb, ije
110  zdelta = max( 0., sign(1., rtt - tempe(ij)) )
111  play = 0.5*(p(ij,l)+p(ij,l+1))
112  qsat(ij,l) = min(0.5, r2es* foeew(tempe(ij),zdelta) / play )
113  qsat(ij,l) = qsat(ij,l) / ( 1. - retv * qsat(ij,l) )
114  ENDDO
115  ENDDO
116 c$omp END DO nowait
117 c print*,'Debut vlsplt version debug sans vlyqs'
118 
119  zzpbar = 0.5 * pdt
120  zzw = pdt
121 
122  ijb=ij_begin
123  ije=ij_end
124  if (pole_nord) ijb=ijb+iip1
125  if (pole_sud) ije=ije-iip1
126 
127 c$omp DO schedule(static,omp_chunk)
128  DO l=1,llm
129  DO ij = ijb,ije
130  mu(ij,l)=pbaru(ij,l) * zzpbar
131  ENDDO
132  ENDDO
133 c$omp END DO nowait
134 
135  ijb=ij_begin-iip1
136  ije=ij_end
137  if (pole_nord) ijb=ij_begin
138  if (pole_sud) ije=ij_end-iip1
139 
140 c$omp DO schedule(static,omp_chunk)
141  DO l=1,llm
142  DO ij=ijb,ije
143  mv(ij,l)=pbarv(ij,l) * zzpbar
144  ENDDO
145  ENDDO
146 c$omp END DO nowait
147 
148  ijb=ij_begin
149  ije=ij_end
150 
151 c$omp DO schedule(static,omp_chunk)
152  DO l=1,llm
153  DO ij=ijb,ije
154  mw(ij,l)=w(ij,l) * zzw
155  ENDDO
156  ENDDO
157 c$omp END DO nowait
158 
159 c$omp master
160  DO ij=ijb,ije
161  mw(ij,llm+1)=0.
162  ENDDO
163 c$omp END master
164 
165 c CALL scopy(ijp1llm,q,1,zq,1)
166 c CALL scopy(ijp1llm,masse,1,zm,1)
167 
168  ijb=ij_begin
169  ije=ij_end
170 
171  DO iq=1,nqtot
172 c$omp DO schedule(static,omp_chunk)
173  DO l=1,llm
174  zq(ijb:ije,l,iq)=q(ijb:ije,l,iq)
175  zm(ijb:ije,l,iq)=masse(ijb:ije,l)
176  ENDDO
177 c$omp END DO nowait
178  ENDDO
179 
180 #ifdef DEBUG_IO
181  CALL writefield_u('mu',mu)
182  CALL writefield_v('mv',mv)
183  CALL writefield_u('mw',mw)
184  CALL writefield_u('qsat',qsat)
185 #endif
186 
187 c$omp barrier
188  DO iq=1,nqtot
189 
190 #ifdef DEBUG_IO
191  CALL writefield_u('zq',zq(:,:,iq))
192  CALL writefield_u('zm',zm(:,:,iq))
193 #endif
194  if(iadv(iq) == 0) then
195 
196  cycle
197 
198  else if (iadv(iq)==10) then
199 
200 #ifdef _ADV_HALO
201  call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
202  & ij_begin,ij_begin+2*iip1-1)
203  call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
204  & ij_end-2*iip1+1,ij_end)
205 #else
206  call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
207  & ij_begin,ij_end)
208 #endif
209 
210 c$omp master
211  call vtb(vthallo)
212 c$omp END master
213  call register_hallo_u(zq(:,:,iq),llm,2,2,2,2,myrequest1)
214  call register_hallo_u(zm(:,:,iq),llm,1,1,1,1,myrequest1)
215 
216 c$omp master
217  call vte(vthallo)
218 c$omp END master
219  else if (iadv(iq)==14) then
220 
221 #ifdef _ADV_HALO
222  call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
223  & qsat,ij_begin,ij_begin+2*iip1-1)
224  call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
225  & qsat,ij_end-2*iip1+1,ij_end)
226 #else
227 
228  call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
229  & qsat,ij_begin,ij_end)
230 #endif
231 
232 c$omp master
233  call vtb(vthallo)
234 c$omp END master
235 
236  call register_hallo_u(zq(:,:,iq),llm,2,2,2,2,myrequest1)
237  call register_hallo_u(zm(:,:,iq),llm,1,1,1,1,myrequest1)
238 
239 c$omp master
240  call vte(vthallo)
241 c$omp END master
242  else
243 
244  stop 'vlspltgen_p : schema non parallelise'
245 
246  endif
247 
248  enddo
249 
250 
251 c$omp barrier
252 c$omp master
253  call vtb(vthallo)
254 c$omp END master
255 
256  call sendrequest(myrequest1)
257 
258 c$omp master
259  call vte(vthallo)
260 c$omp END master
261 c$omp barrier
262  do iq=1,nqtot
263 
264  if(iadv(iq) == 0) then
265 
266  cycle
267 
268  else if (iadv(iq)==10) then
269 
270 #ifdef _ADV_HALLO
271  call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
272  & ij_begin+2*iip1,ij_end-2*iip1)
273 #endif
274  else if (iadv(iq)==14) then
275 #ifdef _ADV_HALLO
276  call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
277  & qsat,ij_begin+2*iip1,ij_end-2*iip1)
278 #endif
279  else
280 
281  stop 'vlspltgen_p : schema non parallelise'
282 
283  endif
284 
285  enddo
286 c$omp barrier
287 c$omp master
288  call vtb(vthallo)
289 c$omp END master
290 
291 ! call WaitRecvRequest(MyRequest1)
292 ! call WaitSendRequest(MyRequest1)
293 c$omp barrier
294  call waitrequest(myrequest1)
295 
296 
297 c$omp master
298  call vte(vthallo)
299 c$omp END master
300 c$omp barrier
301 
302 
303  do iq=1,nqtot
304 #ifdef DEBUG_IO
305  CALL writefield_u('zq',zq(:,:,iq))
306  CALL writefield_u('zm',zm(:,:,iq))
307 #endif
308  if(iadv(iq) == 0) then
309 
310  cycle
311 
312  else if (iadv(iq)==10) then
313 
314  call vly_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mv)
315 
316  else if (iadv(iq)==14) then
317 
318  call vlyqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mv,
319  & qsat)
320 
321  else
322 
323  stop 'vlspltgen_p : schema non parallelise'
324 
325  endif
326 
327  enddo
328 
329 
330  do iq=1,nqtot
331 #ifdef DEBUG_IO
332  CALL writefield_u('zq',zq(:,:,iq))
333  CALL writefield_u('zm',zm(:,:,iq))
334 #endif
335  if(iadv(iq) == 0) then
336 
337  cycle
338 
339  else if (iadv(iq)==10 .or. iadv(iq)==14 ) then
340 
341 c$omp barrier
342 #ifdef _ADV_HALLO
343  call vlz_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mw,
344  & ij_begin,ij_begin+2*iip1-1)
345  call vlz_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mw,
346  & ij_end-2*iip1+1,ij_end)
347 #else
348  call vlz_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mw,
349  & ij_begin,ij_end)
350 #endif
351 c$omp barrier
352 
353 c$omp master
354  call vtb(vthallo)
355 c$omp END master
356 
357  call register_hallo_u(zq(:,:,iq),llm,2,2,2,2,myrequest2)
358  call register_hallo_u(zm(:,:,iq),llm,1,1,1,1,myrequest2)
359 
360 c$omp master
361  call vte(vthallo)
362 c$omp END master
363 c$omp barrier
364  else
365 
366  stop 'vlspltgen_p : schema non parallelise'
367 
368  endif
369 
370  enddo
371 c$omp barrier
372 
373 c$omp master
374  call vtb(vthallo)
375 c$omp END master
376 
377  call sendrequest(myrequest2)
378 
379 c$omp master
380  call vte(vthallo)
381 c$omp END master
382 
383 c$omp barrier
384  do iq=1,nqtot
385 
386  if(iadv(iq) == 0) then
387 
388  cycle
389 
390  else if (iadv(iq)==10 .or. iadv(iq)==14 ) then
391 c$omp barrier
392 
393 #ifdef _ADV_HALLO
394  call vlz_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mw,
395  & ij_begin+2*iip1,ij_end-2*iip1)
396 #endif
397 
398 c$omp barrier
399  else
400 
401  stop 'vlspltgen_p : schema non parallelise'
402 
403  endif
404 
405  enddo
406 
407 c$omp barrier
408 c$omp master
409  call vtb(vthallo)
410 c$omp END master
411 
412 ! call WaitRecvRequest(MyRequest2)
413 ! call WaitSendRequest(MyRequest2)
414 c$omp barrier
415  CALL waitrequest(myrequest2)
416 
417 c$omp master
418  call vte(vthallo)
419 c$omp END master
420 c$omp barrier
421 
422 
423  do iq=1,nqtot
424 #ifdef DEBUG_IO
425  CALL writefield_u('zq',zq(:,:,iq))
426  CALL writefield_u('zm',zm(:,:,iq))
427 #endif
428  if(iadv(iq) == 0) then
429 
430  cycle
431 
432  else if (iadv(iq)==10) then
433 
434  call vly_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mv)
435 
436  else if (iadv(iq)==14) then
437 
438  call vlyqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mv,
439  & qsat)
440 
441  else
442 
443  stop 'vlspltgen_p : schema non parallelise'
444 
445  endif
446 
447  enddo
448 
449 
450  do iq=1,nqtot
451 #ifdef DEBUG_IO
452  CALL writefield_u('zq',zq(:,:,iq))
453  CALL writefield_u('zm',zm(:,:,iq))
454 #endif
455  if(iadv(iq) == 0) then
456 
457  cycle
458 
459  else if (iadv(iq)==10) then
460 
461  call vlx_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
462  & ij_begin,ij_end)
463 
464  else if (iadv(iq)==14) then
465 
466  call vlxqs_loc(zq(ijb_u,1,iq),pente_max,zm(ijb_u,1,iq),mu,
467  & qsat, ij_begin,ij_end)
468 
469  else
470 
471  stop 'vlspltgen_p : schema non parallelise'
472 
473  endif
474 
475  enddo
476 
477 
478  ijb=ij_begin
479  ije=ij_end
480 c$omp barrier
481 
482 
483  DO iq=1,nqtot
484 #ifdef DEBUG_IO
485  CALL writefield_u('zq',zq(:,:,iq))
486  CALL writefield_u('zm',zm(:,:,iq))
487 #endif
488 c$omp DO schedule(static,omp_chunk)
489  DO l=1,llm
490  DO ij=ijb,ije
491 c print *,'zq-->',ij,l,iq,zq(ij,l,iq)
492 c print *,'q-->',ij,l,iq,q(ij,l,iq)
493  q(ij,l,iq)=zq(ij,l,iq)
494  ENDDO
495  ENDDO
496 c$omp END DO nowait
497 
498 c$omp DO schedule(static,omp_chunk)
499  DO l=1,llm
500  DO ij=ijb,ije-iip1+1,iip1
501  q(ij+iim,l,iq)=q(ij,l,iq)
502  ENDDO
503  ENDDO
504 c$omp END DO nowait
505 
506  ENDDO
507 
508 
509 c$omp barrier
510 
511 cc$omp master
512 c call waitsendrequest(myrequest1)
513 c call waitsendrequest(myrequest2)
514 cc$omp END master
515 cc$omp barrier
516 
517  RETURN
518  END