source: LMDZ5/branches/LMDZ5_SPLA/libf/dyn3dmem/groupe_loc.F @ 3157

Last change on this file since 3157 was 1907, checked in by lguez, 11 years ago

Added a copyright property to every file of the distribution, except
for the fcm files (which have their own copyright). Use svn propget on
a file to see the copyright. For instance:

$ svn propget copyright libf/phylmd/physiq.F90
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

Also added the files defining the CeCILL version 2 license, in French
and English, at the top of the LMDZ tree.

  • 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: 3.1 KB
Line 
1      subroutine groupe_loc(pext,pbaru,pbarv,pbarum,pbarvm,wm)
2      USE parallel_lmdz
3      USE Write_field_loc
4      USE groupe_mod
5      implicit none
6
7c   sous-programme servant a fitlrer les champs de flux de masse aux
8c   poles en "regroupant" les mailles 2 par 2 puis 4 par 4 etc. au fur
9c   et a mesure qu'on se rapproche du pole.
10c
11c   en entree: pext, pbaru et pbarv
12c
13c   en sortie:  pbarum,pbarvm et wm.
14c
15c   remarque, le wm est recalcule a partir des pbaru pbarv et on n'a donc
16c   pas besoin de w en entree.
17
18#include "dimensions.h"
19#include "paramet.h"
20#include "comconst.h"
21#include "comgeom2.h"
22#include "comvert.h"
23
24      integer ngroup
25      parameter (ngroup=3)
26
27
28      real pbaru(iip1,jjb_u:jje_u,llm),pbarv(iip1,jjb_v:jje_v,llm)
29      real pext(iip1,jjb_u:jje_u,llm)
30
31      real pbarum(iip1,jjb_u:jje_u,llm),pbarvm(iip1,jjb_v:jje_v,llm)
32      real wm(iip1,jjb_u:jje_u,llm)
33
34
35      real uu
36
37      integer i,j,l
38
39      logical firstcall
40      save firstcall
41c$OMP THREADPRIVATE(firstcall)
42
43      data firstcall/.true./
44      integer ijb,ije,jjb,jje
45     
46      if (firstcall) then
47         if(mod(iim,2**ngroup).ne.0) stop'probleme du nombre ede point'
48         firstcall=.false.
49      endif
50
51c   Champs 1D
52
53      call convflu_loc(pbaru,pbarv,llm,zconvm)
54
55c
56c      call scopy(ijp1llm,zconvm,1,zconvmm,1)
57c      call scopy(ijmllm,pbarv,1,pbarvm,1)
58     
59      jjb=jj_begin
60      jje=jj_end
61
62c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
63      do l=1,llm
64        zconvmm(:,jjb:jje,l)=zconvm(:,jjb:jje,l)
65      enddo
66c$OMP END DO NOWAIT
67
68      call groupeun_loc(jjp1,llm,jjb_u,jje_u,jjb,jje,zconvmm)
69     
70      jjb=jj_begin-1
71      jje=jj_end
72      if (pole_nord) jjb=jj_begin
73      if (pole_sud)  jje=jj_end-1
74c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
75      do l=1,llm
76        pbarvm(:,jjb:jje,l)=pbarv(:,jjb:jje,l)
77      enddo
78c$OMP END DO NOWAIT
79
80#ifdef DEBUG_IO   
81      CALL WriteField_v('pbarvm',reshape(pbarvm,(/ip1jm,llm/)))
82#endif
83      call groupeun_loc(jjm,llm,jjb_v,jje_v,jjb,jje,pbarvm)
84#ifdef DEBUG_IO   
85      CALL WriteField_v('pbarvm',reshape(pbarvm,(/ip1jm,llm/)))
86#endif
87c   Champs 3D
88   
89      jjb=jj_begin
90      jje=jj_end
91      if (pole_nord) jjb=jj_begin+1
92      if (pole_sud)  jje=jj_end-1
93     
94c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)     
95      do l=1,llm
96         do j=jjb,jje
97            uu=pbaru(iim,j,l)
98            do i=1,iim
99               uu=uu+pbarvm(i,j,l)-pbarvm(i,j-1,l)-zconvmm(i,j,l)
100               pbarum(i,j,l)=uu
101c     zconvm(i,j,l ) =  xflu(i-1,j,l)-xflu(i,j,l)+
102c    *                      yflu(i,j,l)-yflu(i,j-1,l)
103            enddo
104            pbarum(iip1,j,l)=pbarum(1,j,l)
105         enddo
106      enddo
107c$OMP END DO NOWAIT
108c    integration de la convergence de masse de haut  en bas ......
109   
110      jjb=jj_begin
111      jje=jj_end
112
113c$OMP BARRIER
114c$OMP MASTER     
115      do  l = llm-1,1,-1
116          do j=jjb,jje
117             do i=1,iip1
118                zconvmm(i,j,l)=zconvmm(i,j,l)+zconvmm(i,j,l+1)
119             enddo
120          enddo
121      enddo
122
123      if (.not. pole_sud) then
124        zconvmm(:,jj_end+1,:)=0
125cym     wm(:,jj_end+1,:)=0
126      endif
127     
128c$OMP END MASTER
129c$OMP BARRIER     
130
131      CALL vitvert_loc(zconvmm,wm)
132
133      return
134      end
135
Note: See TracBrowser for help on using the repository browser.