trunk/dyn3d/groupeun.f


! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/groupeun.F,v 1.1.1.1 2004/05/19
! 12:53:07 lmdzadmin Exp $

SUBROUTINE groupeun(jjmax, llmax, q)
  USE dimens_m
  USE paramet_m
  USE comconst
  USE comgeom
  IMPLICIT NONE


  INTEGER jjmax, llmax
  REAL q(iip1, jjmax, llmax)

  INTEGER ngroup
  PARAMETER (ngroup=3)

  REAL airen, airecn, qn
  REAL aires, airecs, qs

  INTEGER i, j, l, ig, j1, j2, i0, jd

  ! hamps 3D
  jd = jjp1 - jjmax
  DO l = 1, llm
    j1 = 1 + jd
    j2 = 2
    DO ig = 1, ngroup
      DO j = j1 - jd, j2 - jd
        DO i0 = 1, iim, 2**(ngroup-ig+1)
          airen = 0.
          airecn = 0.
          qn = 0.
          aires = 0.
          airecs = 0.
          qs = 0.
          DO i = i0, i0 + 2**(ngroup-ig+1) - 1
            airen = airen + aire_2d(i, j)
            aires = aires + aire_2d(i, jjp1-j+1)
            qn = qn + q(i, j, l)
            qs = qs + q(i, jjp1-j+1-jd, l)
          END DO
          airecn = 0.
          airecs = 0.
          DO i = i0, i0 + 2**(ngroup-ig+1) - 1
            q(i, j, l) = qn*aire_2d(i, j)/airen
            q(i, jjp1-j+1-jd, l) = qs*aire_2d(i, jjp1-j+1)/aires
          END DO
        END DO
        q(iip1, j, l) = q(1, j, l)
        q(iip1, jjp1-j+1-jd, l) = q(1, jjp1-j+1-jd, l)
      END DO
      j1 = j2 + 1
      j2 = j2 + 2**ig
    END DO
  END DO

  RETURN
END SUBROUTINE groupeun
1	guez	3
2	guez	81	! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/groupeun.F,v 1.1.1.1 2004/05/19
3			! 12:53:07 lmdzadmin Exp $
4	guez	3
5	guez	81	SUBROUTINE groupeun(jjmax, llmax, q)
6			USE dimens_m
7			USE paramet_m
8			USE comconst
9			USE comgeom
10			IMPLICIT NONE
11	guez	3
12
13	guez	81	INTEGER jjmax, llmax
14			REAL q(iip1, jjmax, llmax)
15	guez	3
16	guez	81	INTEGER ngroup
17			PARAMETER (ngroup=3)
18	guez	3
19	guez	81	REAL airen, airecn, qn
20			REAL aires, airecs, qs
21	guez	3
22	guez	81	INTEGER i, j, l, ig, j1, j2, i0, jd
23
24			! hamps 3D
25			jd = jjp1 - jjmax
26			DO l = 1, llm
27			j1 = 1 + jd
28			j2 = 2
29			DO ig = 1, ngroup
30			DO j = j1 - jd, j2 - jd
31			DO i0 = 1, iim, 2**(ngroup-ig+1)
32			airen = 0.
33			airecn = 0.
34			qn = 0.
35			aires = 0.
36			airecs = 0.
37			qs = 0.
38			DO i = i0, i0 + 2**(ngroup-ig+1) - 1
39			airen = airen + aire_2d(i, j)
40			aires = aires + aire_2d(i, jjp1-j+1)
41			qn = qn + q(i, j, l)
42			qs = qs + q(i, jjp1-j+1-jd, l)
43			END DO
44			airecn = 0.
45			airecs = 0.
46			DO i = i0, i0 + 2**(ngroup-ig+1) - 1
47			q(i, j, l) = qn*aire_2d(i, j)/airen
48			q(i, jjp1-j+1-jd, l) = qs*aire_2d(i, jjp1-j+1)/aires
49			END DO
50			END DO
51			q(iip1, j, l) = q(1, j, l)
52			q(iip1, jjp1-j+1-jd, l) = q(1, jjp1-j+1-jd, l)
53			END DO
54			j1 = j2 + 1
55			j2 = j2 + 2**ig
56			END DO
57			END DO
58
59			RETURN
60			END SUBROUTINE groupeun