source: LMDZ5/trunk/libf/dyn3d/groupeun.F @ 4038

Last change on this file since 4038 was 2597, checked in by Ehouarn Millour, 8 years ago

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