source: LMDZ4/branches/LMDZ4V5.0-LF/libf/dyn3dpar/calfis_p.F @ 5360

Last change on this file since 5360 was 1299, checked in by Laurent Fairhead, 15 years ago

Nettoyage general pour se rapprocher des normes et éviter des erreurs a la
compilation:

  • tous les FLOAT() sont remplacés par des REAL()
  • tous les STOP dans phylmd sont remplacés par des appels à abort_gcm
  • le common control défini dans le fichier control.h est remplacé par le module control_mod pour éviter des messages sur l'alignement des variables dans les déclarations
  • des $Header$ remplacés par des $Id$ pour svn

Quelques remplacements à faire ont pu m'échapper

General cleanup of the code to try and adhere to norms and to prevent some
compilation errors:

  • all FLOAT() instructions have been replaced by REAL() instructions
  • all STOP instructions in phylmd have been replaced by calls to abort_gcm
  • the common block control defined in the control.h file has been replaced by the control_mod to prevent compilation warnings on the alignement of declared variables
  • $Header$ replaced by $Id$ for svn

Some changes which should have been made might have escaped me
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 25.6 KB
Line 
1!
2! $Id: calfis_p.F 1299 2010-01-20 14:27:21Z abarral $
3!
4C
5C
6      SUBROUTINE calfis_p(lafin,
7     $                  jD_cur, jH_cur,
8     $                  pucov,
9     $                  pvcov,
10     $                  pteta,
11     $                  pq,
12     $                  pmasse,
13     $                  pps,
14     $                  pp,
15     $                  ppk,
16     $                  pphis,
17     $                  pphi,
18     $                  pducov,
19     $                  pdvcov,
20     $                  pdteta,
21     $                  pdq,
22     $                  flxw,
23     $                  clesphy0,
24     $                  pdufi,
25     $                  pdvfi,
26     $                  pdhfi,
27     $                  pdqfi,
28     $                  pdpsfi)
29#ifdef CPP_EARTH
30! Ehouarn: For now, calfis_p needs Earth physics
31c
32c    Auteur :  P. Le Van, F. Hourdin
33c   .........
34      USE dimphy
35      USE mod_phys_lmdz_para, mpi_root_xx=>mpi_root
36      USE parallel, ONLY : omp_chunk, using_mpi
37      USE mod_interface_dyn_phys
38      USE Write_Field
39      Use Write_field_p
40      USE Times
41      USE IOPHY
42      USE infotrac
43      USE control_mod
44
45      IMPLICIT NONE
46c=======================================================================
47c
48c   1. rearrangement des tableaux et transformation
49c      variables dynamiques  >  variables physiques
50c   2. calcul des termes physiques
51c   3. retransformation des tendances physiques en tendances dynamiques
52c
53c   remarques:
54c   ----------
55c
56c    - les vents sont donnes dans la physique par leurs composantes
57c      naturelles.
58c    - la variable thermodynamique de la physique est une variable
59c      intensive :   T
60c      pour la dynamique on prend    T * ( preff / p(l) ) **kappa
61c    - les deux seules variables dependant de la geometrie necessaires
62c      pour la physique sont la latitude pour le rayonnement et
63c      l'aire de la maille quand on veut integrer une grandeur
64c      horizontalement.
65c    - les points de la physique sont les points scalaires de la
66c      la dynamique; numerotation:
67c          1 pour le pole nord
68c          (jjm-1)*iim pour l'interieur du domaine
69c          ngridmx pour le pole sud
70c      ---> ngridmx=2+(jjm-1)*iim
71c
72c     Input :
73c     -------
74c       ecritphy        frequence d'ecriture (en jours)de histphy
75c       pucov           covariant zonal velocity
76c       pvcov           covariant meridional velocity
77c       pteta           potential temperature
78c       pps             surface pressure
79c       pmasse          masse d'air dans chaque maille
80c       pts             surface temperature  (K)
81c       callrad         clef d'appel au rayonnement
82c
83c    Output :
84c    --------
85c        pdufi          tendency for the natural zonal velocity (ms-1)
86c        pdvfi          tendency for the natural meridional velocity
87c        pdhfi          tendency for the potential temperature
88c        pdtsfi         tendency for the surface temperature
89c
90c        pdtrad         radiative tendencies  \  both input
91c        pfluxrad       radiative fluxes      /  and output
92c
93c=======================================================================
94c
95c-----------------------------------------------------------------------
96c
97c    0.  Declarations :
98c    ------------------
99
100#include "dimensions.h"
101#include "paramet.h"
102#include "temps.h"
103
104      INTEGER ngridmx
105      PARAMETER( ngridmx = 2+(jjm-1)*iim - 1/jjm   )
106
107#include "comconst.h"
108#include "comvert.h"
109#include "comgeom2.h"
110#ifdef CPP_MPI
111      include 'mpif.h'
112#endif
113c    Arguments :
114c    -----------
115      LOGICAL  lafin
116      REAL heure
117
118      REAL pvcov(iip1,jjm,llm)
119      REAL pucov(iip1,jjp1,llm)
120      REAL pteta(iip1,jjp1,llm)
121      REAL pmasse(iip1,jjp1,llm)
122      REAL pq(iip1,jjp1,llm,nqtot)
123      REAL pphis(iip1,jjp1)
124      REAL pphi(iip1,jjp1,llm)
125c
126      REAL pdvcov(iip1,jjm,llm)
127      REAL pducov(iip1,jjp1,llm)
128      REAL pdteta(iip1,jjp1,llm)
129      REAL pdq(iip1,jjp1,llm,nqtot)
130c
131      REAL pps(iip1,jjp1)
132      REAL pp(iip1,jjp1,llmp1)
133      REAL ppk(iip1,jjp1,llm)
134c
135      REAL pdvfi(iip1,jjm,llm)
136      REAL pdufi(iip1,jjp1,llm)
137      REAL pdhfi(iip1,jjp1,llm)
138      REAL pdqfi(iip1,jjp1,llm,nqtot)
139      REAL pdpsfi(iip1,jjp1)
140
141      INTEGER        longcles
142      PARAMETER    ( longcles = 20 )
143      REAL clesphy0( longcles )
144
145
146c    Local variables :
147c    -----------------
148
149      INTEGER i,j,l,ig0,ig,iq,iiq
150      REAL,ALLOCATABLE,SAVE :: zpsrf(:)
151      REAL,ALLOCATABLE,SAVE :: zplev(:,:),zplay(:,:)
152      REAL,ALLOCATABLE,SAVE :: zphi(:,:),zphis(:)
153c
154      REAL,ALLOCATABLE,SAVE :: zufi(:,:), zvfi(:,:)
155      REAL,ALLOCATABLE,SAVE :: ztfi(:,:),zqfi(:,:,:)
156c
157      REAL,ALLOCATABLE,SAVE :: pcvgu(:,:), pcvgv(:,:)
158      REAL,ALLOCATABLE,SAVE :: pcvgt(:,:), pcvgq(:,:,:)
159c
160      REAL,ALLOCATABLE,SAVE :: zdufi(:,:),zdvfi(:,:)
161      REAL,ALLOCATABLE,SAVE :: zdtfi(:,:),zdqfi(:,:,:)
162      REAL,ALLOCATABLE,SAVE :: zdpsrf(:)
163      REAL,SAVE,ALLOCATABLE ::  flxwfi(:,:)     ! Flux de masse verticale sur la grille physiq
164
165c
166      REAL,ALLOCATABLE,SAVE :: zplev_omp(:,:)
167      REAL,ALLOCATABLE,SAVE :: zplay_omp(:,:)
168      REAL,ALLOCATABLE,SAVE :: zphi_omp(:,:)
169      REAL,ALLOCATABLE,SAVE :: zphis_omp(:)
170      REAL,ALLOCATABLE,SAVE :: presnivs_omp(:)
171      REAL,ALLOCATABLE,SAVE :: zufi_omp(:,:)
172      REAL,ALLOCATABLE,SAVE :: zvfi_omp(:,:)
173      REAL,ALLOCATABLE,SAVE :: ztfi_omp(:,:)
174      REAL,ALLOCATABLE,SAVE :: zqfi_omp(:,:,:)
175      REAL,ALLOCATABLE,SAVE :: zdufi_omp(:,:)
176      REAL,ALLOCATABLE,SAVE :: zdvfi_omp(:,:)
177      REAL,ALLOCATABLE,SAVE :: zdtfi_omp(:,:)
178      REAL,ALLOCATABLE,SAVE :: zdqfi_omp(:,:,:)
179      REAL,ALLOCATABLE,SAVE :: zdpsrf_omp(:)
180      REAL,SAVE,ALLOCATABLE ::  flxwfi_omp(:,:)     ! Flux de masse verticale sur la grille physiq
181
182c$OMP THREADPRIVATE(zplev_omp,zplay_omp,zphi_omp,zphis_omp,
183c$OMP+                 presnivs_omp,zufi_omp,zvfi_omp,ztfi_omp,
184c$OMP+                 zqfi_omp,zdufi_omp,zdvfi_omp,
185c$OMP+                 zdtfi_omp,zdqfi_omp,zdpsrf_omp,flxwfi_omp)       
186
187      LOGICAL,SAVE :: first_omp=.true.
188c$OMP THREADPRIVATE(first_omp)
189     
190      REAL zsin(iim),zcos(iim),z1(iim)
191      REAL zsinbis(iim),zcosbis(iim),z1bis(iim)
192      REAL unskap, pksurcp
193c
194cIM diagnostique PVteta, Amip2
195      INTEGER ntetaSTD
196      PARAMETER(ntetaSTD=3)
197      REAL rtetaSTD(ntetaSTD)
198      DATA rtetaSTD/350., 380., 405./
199      REAL PVteta(klon,ntetaSTD)
200     
201      REAL flxw(iip1,jjp1,llm)  ! Flux de masse verticale sur la grille dynamique
202     
203      REAL SSUM
204
205      LOGICAL firstcal, debut
206      DATA firstcal/.true./
207      SAVE firstcal,debut
208c$OMP THREADPRIVATE(firstcal,debut)
209      REAL, intent(in):: jD_cur, jH_cur
210     
211      REAL,SAVE,dimension(1:iim,1:llm):: du_send,du_recv,dv_send,dv_recv
212      INTEGER :: ierr
213#ifdef CPP_MPI
214      INTEGER,dimension(MPI_STATUS_SIZE,4) :: Status
215#else
216      INTEGER,dimension(1,4) :: Status
217#endif
218      INTEGER, dimension(4) :: Req
219      REAL,ALLOCATABLE,SAVE:: zdufi2(:,:),zdvfi2(:,:)
220      integer :: k,kstart,kend
221      INTEGER :: offset 
222c
223c-----------------------------------------------------------------------
224c
225c    1. Initialisations :
226c    --------------------
227c
228
229      klon=klon_mpi
230     
231      PVteta(:,:)=0.
232           
233c
234      IF ( firstcal )  THEN
235        debut = .TRUE.
236        IF (ngridmx.NE.2+(jjm-1)*iim) THEN
237         PRINT*,'STOP dans calfis'
238         PRINT*,'La dimension ngridmx doit etre egale a 2 + (jjm-1)*iim'
239         PRINT*,'  ngridmx  jjm   iim   '
240         PRINT*,ngridmx,jjm,iim
241         STOP
242        ENDIF
243c$OMP MASTER
244      ALLOCATE(zpsrf(klon))
245      ALLOCATE(zplev(klon,llm+1),zplay(klon,llm))
246      ALLOCATE(zphi(klon,llm),zphis(klon))
247      ALLOCATE(zufi(klon,llm), zvfi(klon,llm))
248      ALLOCATE(ztfi(klon,llm),zqfi(klon,llm,nqtot))
249      ALLOCATE(pcvgu(klon,llm), pcvgv(klon,llm))
250      ALLOCATE(pcvgt(klon,llm), pcvgq(klon,llm,2))
251      ALLOCATE(zdufi(klon,llm),zdvfi(klon,llm))
252      ALLOCATE(zdtfi(klon,llm),zdqfi(klon,llm,nqtot))
253      ALLOCATE(zdpsrf(klon))
254      ALLOCATE(zdufi2(klon+iim,llm),zdvfi2(klon+iim,llm))
255      ALLOCATE(flxwfi(klon,llm))
256c$OMP END MASTER
257c$OMP BARRIER     
258      ELSE
259          debut = .FALSE.
260      ENDIF
261
262c
263c
264c-----------------------------------------------------------------------
265c   40. transformation des variables dynamiques en variables physiques:
266c   ---------------------------------------------------------------
267
268c   41. pressions au sol (en Pascals)
269c   ----------------------------------
270
271c$OMP MASTER
272      call start_timer(timer_physic)
273c$OMP END MASTER
274
275c$OMP MASTER             
276!CDIR ON_ADB(index_i)
277!CDIR ON_ADB(index_j)
278      do ig0=1,klon
279        i=index_i(ig0)
280        j=index_j(ig0)
281        zpsrf(ig0)=pps(i,j)
282      enddo
283c$OMP END MASTER
284
285
286c   42. pression intercouches :
287c
288c   -----------------------------------------------------------------
289c     .... zplev  definis aux (llm +1) interfaces des couches  ....
290c     .... zplay  definis aux (  llm )    milieux des couches  ....
291c   -----------------------------------------------------------------
292
293c    ...    Exner = cp * ( p(l) / preff ) ** kappa     ....
294c
295       unskap   = 1./ kappa
296c
297c      print *,omp_rank,'klon--->',klon
298c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
299      DO l = 1, llmp1
300!CDIR ON_ADB(index_i)
301!CDIR ON_ADB(index_j)
302        do ig0=1,klon
303          i=index_i(ig0)
304          j=index_j(ig0)
305          zplev( ig0,l ) = pp(i,j,l)
306        enddo
307      ENDDO
308c$OMP END DO NOWAIT
309c
310c
311
312c   43. temperature naturelle (en K) et pressions milieux couches .
313c   ---------------------------------------------------------------
314c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
315      DO l=1,llm
316!CDIR ON_ADB(index_i)
317!CDIR ON_ADB(index_j)
318        do ig0=1,klon
319          i=index_i(ig0)
320          j=index_j(ig0)
321          pksurcp        = ppk(i,j,l) / cpp
322          zplay(ig0,l)   = preff * pksurcp ** unskap
323          ztfi(ig0,l)    = pteta(i,j,l)  * pksurcp
324        enddo
325
326      ENDDO
327c$OMP END DO NOWAIT
328
329c   43.bis traceurs
330c   ---------------
331c
332
333      DO iq=1,nqtot
334         iiq=niadv(iq)
335c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
336         DO l=1,llm
337!CDIR ON_ADB(index_i)
338!CDIR ON_ADB(index_j)
339           do ig0=1,klon
340             i=index_i(ig0)
341             j=index_j(ig0)
342             zqfi(ig0,l,iq)  = pq(i,j,l,iiq)
343           enddo
344         ENDDO
345c$OMP END DO NOWAIT     
346      ENDDO
347
348
349c   Geopotentiel calcule par rapport a la surface locale:
350c   -----------------------------------------------------
351
352      CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,pphi,zphi)
353
354      CALL gr_dyn_fi_p(1,iip1,jjp1,klon,pphis,zphis)
355
356c$OMP BARRIER
357
358c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
359      DO l=1,llm
360         DO ig=1,klon
361           zphi(ig,l)=zphi(ig,l)-zphis(ig)
362         ENDDO
363      ENDDO
364c$OMP END DO NOWAIT
365     
366
367c
368c   45. champ u:
369c   ------------
370
371      kstart=1
372      kend=klon
373     
374      if (is_north_pole) kstart=2
375      if (is_south_pole) kend=klon-1
376     
377c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
378      DO l=1,llm
379!CDIR ON_ADB(index_i)
380!CDIR ON_ADB(index_j)
381!CDIR SPARSE
382        do ig0=kstart,kend
383          i=index_i(ig0)
384          j=index_j(ig0)
385          if (i==1) then
386            zufi(ig0,l)= 0.5 *(  pucov(iim,j,l)/cu(iim,j)
387     $                         + pucov(1,j,l)/cu(1,j) )
388          else
389            zufi(ig0,l)= 0.5*(  pucov(i-1,j,l)/cu(i-1,j)
390     $                       + pucov(i,j,l)/cu(i,j) )
391          endif
392        enddo
393      ENDDO
394c$OMP END DO NOWAIT
395
396c   46.champ v:
397c   -----------
398
399c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
400      DO l=1,llm
401!CDIR ON_ADB(index_i)
402!CDIR ON_ADB(index_j)
403        DO ig0=kstart,kend
404          i=index_i(ig0)
405          j=index_j(ig0)
406          zvfi(ig0,l)= 0.5 *(  pvcov(i,j-1,l)/cv(i,j-1)
407     $                       + pvcov(i,j,l)/cv(i,j) )
408   
409         ENDDO
410      ENDDO
411c$OMP END DO NOWAIT
412
413c   47. champs de vents aux pole nord   
414c   ------------------------------
415c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
416c        V = 1 / pi  *  integrale [ v * sin(long) * d long ]
417
418      if (is_north_pole) then
419c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
420        DO l=1,llm
421
422           z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,1,l)/cv(1,1)
423           DO i=2,iim
424              z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,1,l)/cv(i,1)
425           ENDDO
426 
427           DO i=1,iim
428              zcos(i)   = COS(rlonv(i))*z1(i)
429              zsin(i)   = SIN(rlonv(i))*z1(i)
430           ENDDO
431 
432           zufi(1,l)  = SSUM(iim,zcos,1)/pi
433           zvfi(1,l)  = SSUM(iim,zsin,1)/pi
434 
435        ENDDO
436c$OMP END DO NOWAIT     
437      endif
438
439
440c   48. champs de vents aux pole sud:
441c   ---------------------------------
442c        U = 1 / pi  *  integrale [ v * cos(long) * d long ]
443c        V = 1 / pi  *  integrale [ v * sin(long) * d long ]
444
445      if (is_south_pole) then
446c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
447        DO l=1,llm
448 
449         z1(1)   =(rlonu(1)-rlonu(iim)+2.*pi)*pvcov(1,jjm,l)/cv(1,jjm)
450           DO i=2,iim
451             z1(i)   =(rlonu(i)-rlonu(i-1))*pvcov(i,jjm,l)/cv(i,jjm)
452           ENDDO
453 
454           DO i=1,iim
455              zcos(i)    = COS(rlonv(i))*z1(i)
456              zsin(i)    = SIN(rlonv(i))*z1(i)
457           ENDDO
458 
459           zufi(klon,l)  = SSUM(iim,zcos,1)/pi
460           zvfi(klon,l)  = SSUM(iim,zsin,1)/pi
461        ENDDO
462c$OMP END DO NOWAIT       
463      endif
464
465
466      IF (is_sequential) THEN
467c
468cIM calcul PV a teta=350, 380, 405K
469        CALL PVtheta(ngridmx,llm,pucov,pvcov,pteta,
470     $           ztfi,zplay,zplev,
471     $           ntetaSTD,rtetaSTD,PVteta)
472c
473      ENDIF
474
475c On change de grille, dynamique vers physiq, pour le flux de masse verticale
476      CALL gr_dyn_fi_p(llm,iip1,jjp1,klon,flxw,flxwfi)
477
478c-----------------------------------------------------------------------
479c   Appel de la physique:
480c   ---------------------
481
482
483c$OMP BARRIER
484      if (first_omp) then
485        klon=klon_omp
486
487        allocate(zplev_omp(klon,llm+1))
488        allocate(zplay_omp(klon,llm))
489        allocate(zphi_omp(klon,llm))
490        allocate(zphis_omp(klon))
491        allocate(presnivs_omp(llm))
492        allocate(zufi_omp(klon,llm))
493        allocate(zvfi_omp(klon,llm))
494        allocate(ztfi_omp(klon,llm))
495        allocate(zqfi_omp(klon,llm,nqtot))
496        allocate(zdufi_omp(klon,llm))
497        allocate(zdvfi_omp(klon,llm))
498        allocate(zdtfi_omp(klon,llm))
499        allocate(zdqfi_omp(klon,llm,nqtot))
500        allocate(zdpsrf_omp(klon))
501        allocate(flxwfi_omp(klon,llm))
502        first_omp=.false.
503      endif
504       
505           
506      klon=klon_omp
507      offset=klon_omp_begin-1
508     
509      do l=1,llm+1
510        do i=1,klon
511          zplev_omp(i,l)=zplev(offset+i,l)
512        enddo
513      enddo
514         
515       do l=1,llm
516        do i=1,klon 
517          zplay_omp(i,l)=zplay(offset+i,l)
518        enddo
519      enddo
520       
521      do l=1,llm
522        do i=1,klon
523          zphi_omp(i,l)=zphi(offset+i,l)
524        enddo
525      enddo
526       
527      do i=1,klon
528        zphis_omp(i)=zphis(offset+i)
529      enddo
530     
531       
532      do l=1,llm
533        presnivs_omp(l)=presnivs(l)
534      enddo
535       
536      do l=1,llm
537        do i=1,klon
538          zufi_omp(i,l)=zufi(offset+i,l)
539        enddo
540      enddo
541       
542      do l=1,llm
543        do i=1,klon
544          zvfi_omp(i,l)=zvfi(offset+i,l)
545        enddo
546      enddo
547       
548      do l=1,llm
549        do i=1,klon
550          ztfi_omp(i,l)=ztfi(offset+i,l)
551        enddo
552      enddo
553       
554      do iq=1,nqtot
555        do l=1,llm
556          do i=1,klon
557            zqfi_omp(i,l,iq)=zqfi(offset+i,l,iq)
558          enddo
559        enddo
560      enddo
561       
562      do l=1,llm
563        do i=1,klon
564          zdufi_omp(i,l)=zdufi(offset+i,l)
565        enddo
566      enddo
567       
568      do l=1,llm
569        do i=1,klon
570          zdvfi_omp(i,l)=zdvfi(offset+i,l)
571        enddo
572      enddo
573       
574      do l=1,llm
575        do i=1,klon
576          zdtfi_omp(i,l)=zdtfi(offset+i,l)
577        enddo
578      enddo
579       
580      do iq=1,nqtot
581        do l=1,llm
582          do i=1,klon
583            zdqfi_omp(i,l,iq)=zdqfi(offset+i,l,iq)
584          enddo
585        enddo
586      enddo
587       
588      do i=1,klon
589        zdpsrf_omp(i)=zdpsrf(offset+i)
590      enddo
591
592      do l=1,llm
593        do i=1,klon
594          flxwfi_omp(i,l)=flxwfi(offset+i,l)
595        enddo
596      enddo
597     
598c$OMP BARRIER
599     
600      if (planet_type=="earth") then
601#ifdef CPP_EARTH
602      CALL physiq (klon,
603     .             llm,
604     .             debut,
605     .             lafin,
606     .             jD_cur,
607     .             jH_cur,
608     .             dtphys,
609     .             zplev_omp,
610     .             zplay_omp,
611     .             zphi_omp,
612     .             zphis_omp,
613     .             presnivs_omp,
614     .             clesphy0,
615     .             zufi_omp,
616     .             zvfi_omp,
617     .             ztfi_omp,
618     .             zqfi_omp,
619c#ifdef INCA
620     .             flxwfi_omp,
621c#endif
622     .             zdufi_omp,
623     .             zdvfi_omp,
624     .             zdtfi_omp,
625     .             zdqfi_omp,
626     .             zdpsrf_omp,
627cIM diagnostique PVteta, Amip2         
628     .             pducov,
629     .             PVteta)
630#endif
631      endif !of if (planet_type=="earth")
632c$OMP BARRIER
633
634      do l=1,llm+1
635        do i=1,klon
636          zplev(offset+i,l)=zplev_omp(i,l)
637        enddo
638      enddo
639         
640       do l=1,llm
641        do i=1,klon 
642          zplay(offset+i,l)=zplay_omp(i,l)
643        enddo
644      enddo
645       
646      do l=1,llm
647        do i=1,klon
648          zphi(offset+i,l)=zphi_omp(i,l)
649        enddo
650      enddo
651       
652
653      do i=1,klon
654        zphis(offset+i)=zphis_omp(i)
655      enddo
656     
657       
658      do l=1,llm
659        presnivs(l)=presnivs_omp(l)
660      enddo
661       
662      do l=1,llm
663        do i=1,klon
664          zufi(offset+i,l)=zufi_omp(i,l)
665        enddo
666      enddo
667       
668      do l=1,llm
669        do i=1,klon
670          zvfi(offset+i,l)=zvfi_omp(i,l)
671        enddo
672      enddo
673       
674      do l=1,llm
675        do i=1,klon
676          ztfi(offset+i,l)=ztfi_omp(i,l)
677        enddo
678      enddo
679       
680      do iq=1,nqtot
681        do l=1,llm
682          do i=1,klon
683            zqfi(offset+i,l,iq)=zqfi_omp(i,l,iq)
684          enddo
685        enddo
686      enddo
687       
688      do l=1,llm
689        do i=1,klon
690          zdufi(offset+i,l)=zdufi_omp(i,l)
691        enddo
692      enddo
693       
694      do l=1,llm
695        do i=1,klon
696          zdvfi(offset+i,l)=zdvfi_omp(i,l)
697        enddo
698      enddo
699       
700      do l=1,llm
701        do i=1,klon
702          zdtfi(offset+i,l)=zdtfi_omp(i,l)
703        enddo
704      enddo
705       
706      do iq=1,nqtot
707        do l=1,llm
708          do i=1,klon
709            zdqfi(offset+i,l,iq)=zdqfi_omp(i,l,iq)
710          enddo
711        enddo
712      enddo
713       
714      do i=1,klon
715        zdpsrf(offset+i)=zdpsrf_omp(i)
716      enddo
717     
718
719      klon=klon_mpi
720500   CONTINUE
721c$OMP BARRIER
722
723c$OMP MASTER
724      call stop_timer(timer_physic)
725c$OMP END MASTER
726
727      IF (using_mpi) THEN
728           
729      if (MPI_rank>0) then
730
731c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)       
732       DO l=1,llm     
733        du_send(1:iim,l)=zdufi(1:iim,l)
734        dv_send(1:iim,l)=zdvfi(1:iim,l)
735       ENDDO
736c$OMP END DO NOWAIT       
737
738c$OMP BARRIER
739#ifdef CPP_MPI
740c$OMP MASTER
741!$OMP CRITICAL (MPI)
742        call MPI_ISSEND(du_send,iim*llm,MPI_REAL8,MPI_Rank-1,401,
743     &                   COMM_LMDZ,Req(1),ierr)
744        call MPI_ISSEND(dv_send,iim*llm,MPI_REAL8,MPI_Rank-1,402,
745     &                  COMM_LMDZ,Req(2),ierr)
746!$OMP END CRITICAL (MPI)
747c$OMP END MASTER
748#endif
749c$OMP BARRIER
750     
751      endif
752   
753      if (MPI_rank<MPI_Size-1) then
754c$OMP BARRIER
755#ifdef CPP_MPI
756c$OMP MASTER     
757!$OMP CRITICAL (MPI)
758        call MPI_IRECV(du_recv,iim*llm,MPI_REAL8,MPI_Rank+1,401,
759     &                 COMM_LMDZ,Req(3),ierr)
760        call MPI_IRECV(dv_recv,iim*llm,MPI_REAL8,MPI_Rank+1,402,
761     &                 COMM_LMDZ,Req(4),ierr)
762!$OMP END CRITICAL (MPI)
763c$OMP END MASTER
764#endif
765      endif
766
767c$OMP BARRIER
768
769
770#ifdef CPP_MPI
771c$OMP MASTER   
772!$OMP CRITICAL (MPI)
773      if (MPI_rank>0 .and. MPI_rank< MPI_Size-1) then
774        call MPI_WAITALL(4,Req(1),Status,ierr)
775      else if (MPI_rank>0) then
776        call MPI_WAITALL(2,Req(1),Status,ierr)
777      else if (MPI_rank <MPI_Size-1) then
778        call MPI_WAITALL(2,Req(3),Status,ierr)
779      endif
780!$OMP END CRITICAL (MPI)
781c$OMP END MASTER
782#endif
783
784c$OMP BARRIER     
785
786      ENDIF ! using_mpi
787     
788     
789c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
790      DO l=1,llm
791           
792        zdufi2(1:klon,l)=zdufi(1:klon,l)
793        zdufi2(klon+1:klon+iim,l)=du_recv(1:iim,l)
794           
795        zdvfi2(1:klon,l)=zdvfi(1:klon,l)
796        zdvfi2(klon+1:klon+iim,l)=dv_recv(1:iim,l)
797 
798         pdhfi(:,jj_begin,l)=0
799         pdqfi(:,jj_begin,l,:)=0
800         pdufi(:,jj_begin,l)=0
801         pdvfi(:,jj_begin,l)=0
802         
803         if (.not. is_south_pole) then
804           pdhfi(:,jj_end,l)=0
805           pdqfi(:,jj_end,l,:)=0
806           pdufi(:,jj_end,l)=0
807           pdvfi(:,jj_end,l)=0
808         endif
809     
810       ENDDO
811c$OMP END DO NOWAIT
812
813c$OMP MASTER
814       pdpsfi(:,jj_begin)=0   
815       if (.not. is_south_pole) then
816         pdpsfi(:,jj_end)=0
817       endif
818c$OMP END MASTER
819c-----------------------------------------------------------------------
820c   transformation des tendances physiques en tendances dynamiques:
821c   ---------------------------------------------------------------
822
823c  tendance sur la pression :
824c  -----------------------------------
825      CALL gr_fi_dyn_p(1,klon,iip1,jjp1,zdpsrf,pdpsfi)
826c
827c   62. enthalpie potentielle
828c   ---------------------
829     
830      kstart=1
831      kend=klon
832
833      if (is_north_pole) kstart=2
834      if (is_south_pole)  kend=klon-1
835
836c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
837      DO l=1,llm
838
839!CDIR ON_ADB(index_i)
840!CDIR ON_ADB(index_j)
841!cdir NODEP
842        do ig0=kstart,kend
843          i=index_i(ig0)
844          j=index_j(ig0)
845          pdhfi(i,j,l) = cpp * zdtfi(ig0,l) / ppk(i,j,l)
846          if (i==1) pdhfi(iip1,j,l) =  cpp * zdtfi(ig0,l) / ppk(i,j,l)
847         enddo         
848
849        if (is_north_pole) then
850            DO i=1,iip1
851              pdhfi(i,1,l)    = cpp *  zdtfi(1,l)      / ppk(i, 1  ,l)
852            enddo
853        endif
854       
855        if (is_south_pole) then
856            DO i=1,iip1
857              pdhfi(i,jjp1,l) = cpp *  zdtfi(klon,l)/ ppk(i,jjp1,l)
858            ENDDO
859        endif
860      ENDDO
861c$OMP END DO NOWAIT
862     
863c   62. humidite specifique
864c   ---------------------
865! Ehouarn: removed this useless bit: was overwritten at step 63 anyways
866!      DO iq=1,nqtot
867!c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
868!         DO l=1,llm
869!!!cdir NODEP
870!           do ig0=kstart,kend
871!             i=index_i(ig0)
872!             j=index_j(ig0)
873!             pdqfi(i,j,l,iq) = zdqfi(ig0,l,iq)
874!             if (i==1) pdqfi(iip1,j,l,iq) = zdqfi(ig0,l,iq)
875!           enddo
876!           
877!           if (is_north_pole) then
878!             do i=1,iip1
879!               pdqfi(i,1,l,iq)    = zdqfi(1,l,iq)             
880!             enddo
881!           endif
882!           
883!           if (is_south_pole) then
884!             do i=1,iip1
885!               pdqfi(i,jjp1,l,iq) = zdqfi(klon,l,iq)
886!             enddo
887!           endif
888!         ENDDO
889!c$OMP END DO NOWAIT
890!      ENDDO
891
892c   63. traceurs
893c   ------------
894C     initialisation des tendances
895
896c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
897      DO l=1,llm
898        pdqfi(:,:,l,:)=0.
899      ENDDO
900c$OMP END DO NOWAIT     
901
902C
903!cdir NODEP
904      DO iq=1,nqtot
905         iiq=niadv(iq)
906c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
907         DO l=1,llm
908!CDIR ON_ADB(index_i)
909!CDIR ON_ADB(index_j)
910!cdir NODEP           
911             DO ig0=kstart,kend
912              i=index_i(ig0)
913              j=index_j(ig0)
914              pdqfi(i,j,l,iiq) = zdqfi(ig0,l,iq)
915              if (i==1) pdqfi(iip1,j,l,iiq) = zdqfi(ig0,l,iq)
916            ENDDO
917           
918            IF (is_north_pole) then
919              DO i=1,iip1
920                pdqfi(i,1,l,iiq)    = zdqfi(1,l,iq)
921              ENDDO
922            ENDIF
923           
924            IF (is_south_pole) then
925              DO i=1,iip1
926                pdqfi(i,jjp1,l,iiq) = zdqfi(klon,l,iq)
927              ENDDO
928            ENDIF
929           
930         ENDDO
931c$OMP END DO NOWAIT     
932      ENDDO
933     
934c   65. champ u:
935c   ------------
936c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
937      DO l=1,llm
938!CDIR ON_ADB(index_i)
939!CDIR ON_ADB(index_j)
940!cdir NODEP
941         do ig0=kstart,kend
942           i=index_i(ig0)
943           j=index_j(ig0)
944           
945           if (i/=iim) then
946             pdufi(i,j,l)=0.5*(zdufi2(ig0,l)+zdufi2(ig0+1,l))*cu(i,j)
947           endif
948           
949           if (i==1) then
950              pdufi(iim,j,l)=0.5*(  zdufi2(ig0,l)
951     $                            + zdufi2(ig0+iim-1,l))*cu(iim,j)
952             pdufi(iip1,j,l)=0.5*(zdufi2(ig0,l)+zdufi2(ig0+1,l))*cu(i,j)
953           endif
954         
955         enddo
956         
957         if (is_north_pole) then
958           DO i=1,iip1
959            pdufi(i,1,l)    = 0.
960           ENDDO
961         endif
962         
963         if (is_south_pole) then
964           DO i=1,iip1
965            pdufi(i,jjp1,l) = 0.
966           ENDDO
967         endif
968         
969      ENDDO
970c$OMP END DO NOWAIT
971
972c   67. champ v:
973c   ------------
974
975      kstart=1
976      kend=klon
977
978      if (is_north_pole) kstart=2
979      if (is_south_pole)  kend=klon-1-iim
980     
981c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
982      DO l=1,llm
983!CDIR ON_ADB(index_i)
984!CDIR ON_ADB(index_j)
985!cdir NODEP
986        do ig0=kstart,kend
987           i=index_i(ig0)
988           j=index_j(ig0)
989           pdvfi(i,j,l)=0.5*(zdvfi2(ig0,l)+zdvfi2(ig0+iim,l))*cv(i,j)
990           if (i==1) pdvfi(iip1,j,l) = 0.5*(zdvfi2(ig0,l)+
991     $                                      zdvfi2(ig0+iim,l))
992     $                                    *cv(i,j)
993        enddo
994         
995      ENDDO
996c$OMP END DO NOWAIT
997
998
999c   68. champ v pres des poles:
1000c   ---------------------------
1001c      v = U * cos(long) + V * SIN(long)
1002
1003      if (is_north_pole) then
1004
1005c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
1006        DO l=1,llm
1007
1008          DO i=1,iim
1009            pdvfi(i,1,l)=
1010     $      zdufi(1,l)*COS(rlonv(i))+zdvfi(1,l)*SIN(rlonv(i))
1011       
1012            pdvfi(i,1,l)=
1013     $      0.5*(pdvfi(i,1,l)+zdvfi(i+1,l))*cv(i,1)
1014          ENDDO
1015
1016          pdvfi(iip1,1,l)  = pdvfi(1,1,l)
1017
1018        ENDDO
1019c$OMP END DO NOWAIT
1020
1021      endif   
1022     
1023      if (is_south_pole) then
1024
1025c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
1026         DO l=1,llm
1027 
1028           DO i=1,iim
1029              pdvfi(i,jjm,l)=zdufi(klon,l)*COS(rlonv(i))
1030     $        +zdvfi(klon,l)*SIN(rlonv(i))
1031
1032              pdvfi(i,jjm,l)=
1033     $        0.5*(pdvfi(i,jjm,l)+zdvfi(klon-iip1+i,l))*cv(i,jjm)
1034           ENDDO
1035
1036           pdvfi(iip1,jjm,l)= pdvfi(1,jjm,l)
1037
1038        ENDDO
1039c$OMP END DO NOWAIT
1040     
1041      endif
1042c-----------------------------------------------------------------------
1043
1044700   CONTINUE
1045 
1046      firstcal = .FALSE.
1047
1048#else
1049      write(*,*) "calfis_p: for now can only work with parallel physics"
1050      stop
1051#endif
1052! of #ifdef CPP_EARTH
1053      RETURN
1054      END
Note: See TracBrowser for help on using the repository browser.