source: LMDZ.3.3/trunk/libf/dyn3d/groupeun.F @ 2880

Last change on this file since 2880 was 2, checked in by lmdz, 25 years ago

Initial revision
  • Property svn:eol-style set to native
  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
File size: 1.3 KB
RevLine 
[2]1      subroutine groupeun(jjmax,llmax,q)
2      implicit none
3
4#include "dimensions.h"
5#include "paramet.h"
6#include "comconst.h"
7#include "comgeom2.h"
8
9      integer jjmax,llmax
10      real q(iip1,jjmax,llmax)
11
12      integer ngroup
13      parameter (ngroup=3)
14
15      real airen,airecn,qn
16      real aires,airecs,qs
17
18      integer i,j,l,ig,j1,j2,i0,jd
19
20Champs 3D
21      jd=jjp1-jjmax
22      do l=1,llm
23      j1=1+jd
24      j2=2
25      do ig=1,ngroup
26         do j=j1-jd,j2-jd
27c           print*,'groupe ',ig,'  j= ',j,2**(ngroup-ig+1),'pts groupes'
28            do i0=1,iim,2**(ngroup-ig+1)
29               airen=0.
30               airecn=0.
31               qn=0.
32               aires=0.
33               airecs=0.
34               qs=0.
35               do i=i0,i0+2**(ngroup-ig+1)-1
36                  airen=airen+aire(i,j)
37                  aires=aires+aire(i,jjp1-j+1)
38                  qn=qn+q(i,j,l)
39                  qs=qs+q(i,jjp1-j+1-jd,l)
40               enddo
41               airecn=0.
42               airecs=0.
43               do i=i0,i0+2**(ngroup-ig+1)-1
44                  q(i,j,l)=qn*aire(i,j)/airen
45                  q(i,jjp1-j+1-jd,l)=qs*aire(i,jjp1-j+1)/aires
46               enddo
47            enddo
48            q(iip1,j,l)=q(1,j,l)
49            q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l)
50         enddo
51         j1=j2+1
52         j2=j2+2**ig
53      enddo
54      enddo
55
56      return
57      end
Note: See TracBrowser for help on using the repository browser.