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
2	! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/groupeun.F,v 1.1.1.1 2004/05/19
3	! 12:53:07 lmdzadmin Exp $
4
5	SUBROUTINE groupeun(jjmax, llmax, q)
6	USE dimens_m
7	USE paramet_m
8	USE comconst
9	USE comgeom
10	IMPLICIT NONE
11
12
13	INTEGER jjmax, llmax
14	REAL q(iip1, jjmax, llmax)
15
16	INTEGER ngroup
17	PARAMETER (ngroup=3)
18
19	REAL airen, airecn, qn
20	REAL aires, airecs, qs
21
22	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