source: trunk/LMDZ.COMMON/libf/dyn3dpar/groupeun_p.F @ 1453

Last change on this file since 1453 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.2 KB
Line 
1      SUBROUTINE groupeun_p(jjmax,llmax,jjb,jje,q)
2      USE parallel_lmdz
3      USE Write_Field_p
4      IMPLICIT NONE
5
6#include "dimensions.h"
7#include "paramet.h"
8#include "comgeom2.h"
9
10      INTEGER jjmax,llmax,jjb,jje
11      REAL q(iip1,jjmax,llmax)
12
13      INTEGER ngroup
14      PARAMETER (ngroup=3)
15
16      REAL airecn,qn
17      REAL airecs,qs
18
19      INTEGER i,j,l,ig,ig2,j1,j2,i0,jd
20
21c--------------------------------------------------------------------c
22c Strategie d'optimisation                                           c
23c stocker les valeurs systematiquement recalculees                   c
24c et identiques d'un pas de temps sur l'autre. Il s'agit des         c
25c aires des cellules qui sont sommees. S'il n'y a pas de changement  c
26c de grille au cours de la simulation tout devrait bien se passer.   c
27c Autre optimisation : determination des bornes entre lesquelles "j" c
28c varie, au lieu de faire un test à chaque fois...
29c--------------------------------------------------------------------c
30
31      INTEGER j_start, j_finish
32
33      REAL, SAVE :: airen_tab(iip1,jjp1,0:1)
34      REAL, SAVE :: aires_tab(iip1,jjp1,0:1)
35!$OMP THREADPRIVATE(airen_tab, aires_tab)
36
37      LOGICAL, SAVE :: first = .TRUE.
38!$OMP THREADPRIVATE(first)
39      INTEGER,SAVE :: i_index(iim,ngroup)
40      INTEGER      :: offset
41      REAL         :: qsum(iim/ngroup)
42
43      IF (first) THEN
44         CALL INIT_GROUPEUN_P(airen_tab, aires_tab)
45         first = .FALSE.
46      ENDIF
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  = MAX(jjb, j1-jd)
58            j_finish = MIN(jje, 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  = MAX(1+jjp1-jje-jd, j1-jd)
89            j_finish = MIN(1+jjp1-jjb-jd, 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      SUBROUTINE INIT_GROUPEUN_P(airen_tab, aires_tab)
135
136      USE parallel_lmdz
137      IMPLICIT NONE
138
139#include "dimensions.h"
140#include "paramet.h"
141#include "comgeom2.h"
142
143      INTEGER ngroup
144      PARAMETER (ngroup=3)
145
146      REAL airen,airecn
147      REAL aires,airecs
148
149      INTEGER i,j,l,ig,j1,j2,i0,jd
150
151      INTEGER j_start, j_finish
152
153      REAL :: airen_tab(iip1,jjp1,0:1)
154      REAL :: aires_tab(iip1,jjp1,0:1)
155
156      DO jd=0, 1
157         j1=1+jd
158         j2=2
159         DO ig=1,ngroup
160           
161!     c     Concerne le pole nord
162            j_start = j1-jd
163            j_finish = j2-jd
164            DO j=j_start, j_finish
165               DO i0=1,iim,2**(ngroup-ig+1)
166                  airen=0.
167                  DO i=i0,i0+2**(ngroup-ig+1)-1
168                     airen = airen+aire(i,j)
169                  ENDDO
170                  DO i=i0,i0+2**(ngroup-ig+1)-1
171                     airen_tab(i,j,jd) =
172     &                    aire(i,j) / airen
173                  ENDDO
174               ENDDO
175            ENDDO
176           
177!     c     Concerne le pole sud
178            j_start = j1-jd
179            j_finish = j2-jd
180            DO j=j_start, j_finish
181               DO i0=1,iim,2**(ngroup-ig+1)
182                  aires=0.
183                  DO i=i0,i0+2**(ngroup-ig+1)-1
184                     aires=aires+aire(i,jjp1-j+1)
185                  ENDDO
186                  DO i=i0,i0+2**(ngroup-ig+1)-1
187                     aires_tab(i,jjp1-j+1,jd) =
188     &                    aire(i,jjp1-j+1) / aires
189                  ENDDO
190               ENDDO
191            ENDDO
192           
193            j1=j2+1
194            j2=j2+2**ig
195         ENDDO
196      ENDDO
197     
198      RETURN
199      END
Note: See TracBrowser for help on using the repository browser.