source: LMDZ4/trunk/libf/dyn3d/groupeun.F @ 1258

Last change on this file since 1258 was 1146, checked in by Laurent Fairhead, 16 years ago

Réintegration dans le tronc des modifications issues de la branche LMDZ-dev
comprises entre la révision 1074 et 1145
Validation: une simulation de 1 jour en séquentiel sur PC donne les mêmes
résultats entre la trunk et la dev
LF
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 4.1 KB
RevLine 
[524]1!
2! $Header$
3!
[1146]4      SUBROUTINE groupeun(jjmax,llmax,q)
5      IMPLICIT NONE
[524]6
7#include "dimensions.h"
8#include "paramet.h"
9#include "comconst.h"
10#include "comgeom2.h"
11
[1146]12      INTEGER jjmax,llmax
13      REAL q(iip1,jjmax,llmax)
[524]14
[1146]15      INTEGER ngroup
16      PARAMETER (ngroup=3)
[524]17
[1146]18      REAL airecn,qn
19      REAL airecs,qs
[524]20
[1146]21      INTEGER i,j,l,ig,j1,j2,i0,jd
[524]22
[1146]23c--------------------------------------------------------------------c
24c Strategie d'optimisation                                           c
25c stocker les valeurs systematiquement recalculees                   c
26c et identiques d'un pas de temps sur l'autre. Il s'agit des         c
27c aires des cellules qui sont sommees. S'il n'y a pas de changement  c
28c de grille au cours de la simulation tout devrait bien se passer.   c
29c Autre optimisation : determination des bornes entre lesquelles "j" c
30c varie, au lieu de faire un test à chaque fois...
31c--------------------------------------------------------------------c
32
33      INTEGER j_start, j_finish
34
35      REAL, SAVE :: airen_tab(iip1,jjp1,0:1)
36      REAL, SAVE :: aires_tab(iip1,jjp1,0:1)
37
38      LOGICAL, SAVE :: first = .TRUE.
39
40      IF (first) THEN
41         CALL INIT_GROUPEUN(airen_tab, aires_tab)
42         first = .FALSE.
43      ENDIF
44
45c Champs 3D
[524]46      jd=jjp1-jjmax
47
[1146]48      DO l=1,llm
49         j1=1+jd
50         j2=2
51         DO ig=1,ngroup
52
53c     Concerne le pole nord
54            j_start  = j1-jd
55            j_finish = j2-jd
56            DO j=j_start, j_finish
57               DO i0=1,iim,2**(ngroup-ig+1)
58                  qn=0.
59                  DO i=i0,i0+2**(ngroup-ig+1)-1
60                     qn=qn+q(i,j,l)
61                  ENDDO
62                  DO i=i0,i0+2**(ngroup-ig+1)-1
63                     q(i,j,l)=qn*airen_tab(i,j,jd)
64                  ENDDO
65               ENDDO
66               q(iip1,j,l)=q(1,j,l)
67            ENDDO
68       
69!c     Concerne le pole sud
70            j_start  = j1-jd
71            j_finish = j2-jd
72            DO j=j_start, j_finish
73               DO i0=1,iim,2**(ngroup-ig+1)
74                  qs=0.
75                  DO i=i0,i0+2**(ngroup-ig+1)-1
76                     qs=qs+q(i,jjp1-j+1-jd,l)
77                  ENDDO
78                  DO i=i0,i0+2**(ngroup-ig+1)-1
79                     q(i,jjp1-j+1-jd,l)=qs*aires_tab(i,jjp1-j+1,jd)
80                  ENDDO
81               ENDDO
82               q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l)
83            ENDDO
84       
85            j1=j2+1
86            j2=j2+2**ig
87         ENDDO
88      ENDDO
89
90      RETURN
91      END
92
93
94
95      SUBROUTINE INIT_GROUPEUN(airen_tab, aires_tab)
96      IMPLICIT NONE
97
98#include "dimensions.h"
99#include "paramet.h"
100#include "comconst.h"
101#include "comgeom2.h"
102
103      INTEGER ngroup
104      PARAMETER (ngroup=3)
105
106      REAL airen,airecn
107      REAL aires,airecs
108
109      INTEGER i,j,l,ig,j1,j2,i0,jd
110
111      INTEGER j_start, j_finish
112
113      REAL :: airen_tab(iip1,jjp1,0:1)
114      REAL :: aires_tab(iip1,jjp1,0:1)
115
116      DO jd=0, 1
117         j1=1+jd
118         j2=2
119         DO ig=1,ngroup
120           
121!     c     Concerne le pole nord
122            j_start = j1-jd
123            j_finish = j2-jd
124            DO j=j_start, j_finish
125               DO i0=1,iim,2**(ngroup-ig+1)
126                  airen=0.
127                  DO i=i0,i0+2**(ngroup-ig+1)-1
128                     airen = airen+aire(i,j)
129                  ENDDO
130                  DO i=i0,i0+2**(ngroup-ig+1)-1
131                     airen_tab(i,j,jd) =
132     &                    aire(i,j) / airen
133                  ENDDO
134               ENDDO
135            ENDDO
136           
137!     c     Concerne le pole sud
138            j_start = j1-jd
139            j_finish = j2-jd
140            DO j=j_start, j_finish
141               DO i0=1,iim,2**(ngroup-ig+1)
142                  aires=0.
143                  DO i=i0,i0+2**(ngroup-ig+1)-1
144                     aires=aires+aire(i,jjp1-j+1)
145                  ENDDO
146                  DO i=i0,i0+2**(ngroup-ig+1)-1
147                     aires_tab(i,jjp1-j+1,jd) =
148     &                    aire(i,jjp1-j+1) / aires
149                  ENDDO
150               ENDDO
151            ENDDO
152           
153            j1=j2+1
154            j2=j2+2**ig
155         ENDDO
156      ENDDO
157     
158      RETURN
159      END
Note: See TracBrowser for help on using the repository browser.