source: trunk/LMDZ.COMMON/libf/dyn3d/groupeun.F @ 1540

Last change on this file since 1540 was 1422, checked in by milmd, 10 years ago

In GENERIC, MARS and COMMON models replace some include files by modules (usefull for decoupling physics with dynamics).
File size: 5.0 KB
Line 
1!
2! $Header$
3!
4      SUBROUTINE groupeun(jjmax,llmax,q)
5      IMPLICIT NONE
6
7#include "dimensions.h"
8#include "paramet.h"
9#include "comgeom2.h"
10
11      INTEGER jjmax,llmax
12      REAL q(iip1,jjmax,llmax)
13
14      INTEGER ngroup
15      PARAMETER (ngroup=3)
16
17      REAL airecn,qn
18      REAL airecs,qs
19
20      INTEGER i,j,l,ig,ig2,j1,j2,i0,jd
21
22c--------------------------------------------------------------------c
23c Strategie d'optimisation                                           c
24c stocker les valeurs systematiquement recalculees                   c
25c et identiques d'un pas de temps sur l'autre. Il s'agit des         c
26c aires des cellules qui sont sommees. S'il n'y a pas de changement  c
27c de grille au cours de la simulation tout devrait bien se passer.   c
28c Autre optimisation : determination des bornes entre lesquelles "j" c
29c varie, au lieu de faire un test à chaque fois...
30c--------------------------------------------------------------------c
31
32      INTEGER j_start, j_finish
33
34      REAL, SAVE :: airen_tab(iip1,jjp1,0:1)
35      REAL, SAVE :: aires_tab(iip1,jjp1,0:1)
36
37      LOGICAL, SAVE :: first = .TRUE.
38      INTEGER,SAVE :: i_index(iim,ngroup)
39      INTEGER      :: offset
40      REAL         :: qsum(iim/ngroup)
41
42      IF (first) THEN
43         CALL INIT_GROUPEUN(airen_tab, aires_tab)
44         first = .FALSE.
45      ENDIF
46
47
48c Champs 3D
49      jd=jjp1-jjmax
50c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
51      DO l=1,llm
52         j1=1+jd
53         j2=2
54         DO ig=1,ngroup
55
56c     Concerne le pole nord
57            j_start  = j1-jd
58            j_finish = j2-jd
59            DO ig2=1,ngroup-ig+1
60              offset=2**(ig2-1)
61              DO j=j_start, j_finish
62!CDIR NODEP
63!CDIR ON_ADB(q)
64                 DO i0=1,iim,2**ig2
65                   q(i0,j,l)=q(i0,j,l)+q(i0+offset,j,l)
66                 ENDDO
67              ENDDO
68            ENDDO
69           
70            DO j=j_start, j_finish
71!CDIR NODEP
72!CDIR ON_ADB(q)
73               DO i=1,iim
74                 q(i,j,l)=q(i-MOD(i-1,2**(ngroup-ig+1)),j,l)
75               ENDDO
76            ENDDO
77
78            DO j=j_start, j_finish
79!CDIR ON_ADB(airen_tab)
80!CDIR ON_ADB(q)
81               DO i=1,iim
82                 q(i,j,l)=q(i,j,l)*airen_tab(i,j,jd)
83               ENDDO
84               q(iip1,j,l)=q(1,j,l)
85            ENDDO
86       
87!c     Concerne le pole sud
88            j_start  = j1-jd
89            j_finish = j2-jd
90            DO ig2=1,ngroup-ig+1
91              offset=2**(ig2-1)
92              DO j=j_start, j_finish
93!CDIR NODEP
94!CDIR ON_ADB(q)
95                 DO i0=1,iim,2**ig2
96                   q(i0,jjp1-j+1-jd,l)= q(i0,jjp1-j+1-jd,l)
97     &                                 +q(i0+offset,jjp1-j+1-jd,l)
98                 ENDDO
99              ENDDO
100            ENDDO
101
102
103            DO j=j_start, j_finish
104!CDIR NODEP
105!CDIR ON_ADB(q)
106               DO i=1,iim
107                 q(i,jjp1-j+1-jd,l)=q(i-MOD(i-1,2**(ngroup-ig+1)),
108     &                                jjp1-j+1-jd,l)
109               ENDDO
110            ENDDO
111
112            DO j=j_start, j_finish
113!CDIR ON_ADB(aires_tab)
114!CDIR ON_ADB(q)
115               DO i=1,iim
116                 q(i,jjp1-j+1-jd,l)=q(i,jjp1-j+1-jd,l)* 
117     &                              aires_tab(i,jjp1-j+1,jd)
118               ENDDO
119               q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l)
120            ENDDO
121
122       
123            j1=j2+1
124            j2=j2+2**ig
125         ENDDO
126      ENDDO
127!$OMP END DO NOWAIT
128
129      RETURN
130      END
131     
132     
133     
134     
135      SUBROUTINE INIT_GROUPEUN(airen_tab, aires_tab)
136      IMPLICIT NONE
137
138#include "dimensions.h"
139#include "paramet.h"
140#include "comgeom2.h"
141
142      INTEGER ngroup
143      PARAMETER (ngroup=3)
144
145      REAL airen,airecn
146      REAL aires,airecs
147
148      INTEGER i,j,l,ig,j1,j2,i0,jd
149
150      INTEGER j_start, j_finish
151
152      REAL :: airen_tab(iip1,jjp1,0:1)
153      REAL :: aires_tab(iip1,jjp1,0:1)
154
155      DO jd=0, 1
156         j1=1+jd
157         j2=2
158         DO ig=1,ngroup
159           
160!     c     Concerne le pole nord
161            j_start = j1-jd
162            j_finish = j2-jd
163            DO j=j_start, j_finish
164               DO i0=1,iim,2**(ngroup-ig+1)
165                  airen=0.
166                  DO i=i0,i0+2**(ngroup-ig+1)-1
167                     airen = airen+aire(i,j)
168                  ENDDO
169                  DO i=i0,i0+2**(ngroup-ig+1)-1
170                     airen_tab(i,j,jd) =
171     &                    aire(i,j) / airen
172                  ENDDO
173               ENDDO
174            ENDDO
175           
176!     c     Concerne le pole sud
177            j_start = j1-jd
178            j_finish = j2-jd
179            DO j=j_start, j_finish
180               DO i0=1,iim,2**(ngroup-ig+1)
181                  aires=0.
182                  DO i=i0,i0+2**(ngroup-ig+1)-1
183                     aires=aires+aire(i,jjp1-j+1)
184                  ENDDO
185                  DO i=i0,i0+2**(ngroup-ig+1)-1
186                     aires_tab(i,jjp1-j+1,jd) =
187     &                    aire(i,jjp1-j+1) / aires
188                  ENDDO
189               ENDDO
190            ENDDO
191           
192            j1=j2+1
193            j2=j2+2**ig
194         ENDDO
195      ENDDO
196     
197      RETURN
198      END
Note: See TracBrowser for help on using the repository browser.