source: LMDZ4/branches/LMDZ4-dev/libf/dyn3dpar/groupeun_p.F @ 1074

Last change on this file since 1074 was 764, checked in by Laurent Fairhead, 17 years ago

Merge entre la version V3_conv et le HEAD
YM, JG, LF

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 1.9 KB
Line 
1      subroutine groupeun_p(jjmax,llmax,jjb,jje,q)
2      USE parallel
3      implicit none
4
5#include "dimensions.h"
6#include "paramet.h"
7#include "comconst.h"
8#include "comgeom2.h"
9
10      integer jjmax,llmax,jjb,jje
11      real q(iip1,jjmax,llmax)
12
13      integer ngroup
14      parameter (ngroup=3)
15
16      real airen,airecn,qn
17      real aires,airecs,qs
18
19      integer i,j,l,ig,j1,j2,i0,jd
20
21Champs 3D
22      jd=jjp1-jjmax
23c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
24      do l=1,llm
25      j1=1+jd
26      j2=2
27      do ig=1,ngroup
28         do j=j1-jd,j2-jd
29c           print*,'groupe ',ig,'  j= ',j,2**(ngroup-ig+1),'pts groupes'
30            if ( j >= jjb .AND. j <= jje) THEN
31             
32              do i0=1,iim,2**(ngroup-ig+1)
33                 
34                 airen=0.
35                 airecn=0.
36                 qn=0.
37                 
38                 do i=i0,i0+2**(ngroup-ig+1)-1
39                    airen=airen+aire(i,j)
40                    qn=qn+q(i,j,l)
41                 enddo
42                 airecn=0.
43                 do i=i0,i0+2**(ngroup-ig+1)-1
44                   q(i,j,l)=qn*aire(i,j)/airen
45                 enddo
46              enddo
47              q(iip1,j,l)=q(1,j,l)
48             
49            endif
50           
51            if ( jjp1-j+1-jd >= jjb .AND. jjp1-j+1-jd <= jje) THEN
52             
53              do i0=1,iim,2**(ngroup-ig+1)
54                 aires=0.
55                 airecs=0.
56                 qs=0.
57                 do i=i0,i0+2**(ngroup-ig+1)-1
58                    aires=aires+aire(i,jjp1-j+1)
59                    qs=qs+q(i,jjp1-j+1-jd,l)
60                 enddo
61                 airecs=0.
62                 do i=i0,i0+2**(ngroup-ig+1)-1
63                   q(i,jjp1-j+1-jd,l)=qs*aire(i,jjp1-j+1)/aires
64                 enddo
65              enddo
66              q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l)
67           
68            endif
69         enddo
70             
71           j1=j2+1
72           j2=j2+2**ig
73      enddo
74      enddo
75c$OMP END DO NOWAIT
76      return
77      end
Note: See TracBrowser for help on using the repository browser.