|
! |
|
|
! $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 |
|
|
|
|
|
Champs 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) |
|
|
enddo |
|
|
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 |
|
|
enddo |
|
|
enddo |
|
|
q(iip1,j,l)=q(1,j,l) |
|
|
q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l) |
|
|
enddo |
|
|
j1=j2+1 |
|
|
j2=j2+2**ig |
|
|
enddo |
|
|
enddo |
|
1 |
|
|
2 |
return |
! $Header: /home/cvsroot/LMDZ4/libf/dyn3d/groupeun.F,v 1.1.1.1 2004/05/19 |
3 |
end |
! 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 |