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

Last change on this file since 2194 was 1907, checked in by lguez, 11 years ago

Added a copyright property to every file of the distribution, except
for the fcm files (which have their own copyright). Use svn propget on
a file to see the copyright. For instance:

$ svn propget copyright libf/phylmd/physiq.F90
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

Also added the files defining the CeCILL version 2 license, in French
and English, at the top of the LMDZ tree.
  • 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.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 "comconst.h"
10#include "comgeom2.h"
11
12      INTEGER jjmax,llmax
13      REAL q(iip1,jjmax,llmax)
14
15      INTEGER ngroup
16      PARAMETER (ngroup=3)
17
18      REAL airecn,qn
19      REAL airecs,qs
20
21      INTEGER i,j,l,ig,ig2,j1,j2,i0,jd
22
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      INTEGER,SAVE :: i_index(iim,ngroup)
40      INTEGER      :: offset
41      REAL         :: qsum(iim/ngroup)
42
43      IF (first) THEN
44         CALL INIT_GROUPEUN(airen_tab, aires_tab)
45         first = .FALSE.
46      ENDIF
47
48
49c Champs 3D
50      jd=jjp1-jjmax
51c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
52      DO l=1,llm
53         j1=1+jd
54         j2=2
55         DO ig=1,ngroup
56
57c     Concerne le pole nord
58            j_start  = j1-jd
59            j_finish = j2-jd
60            DO ig2=1,ngroup-ig+1
61              offset=2**(ig2-1)
62              DO j=j_start, j_finish
63!CDIR NODEP
64!CDIR ON_ADB(q)
65                 DO i0=1,iim,2**ig2
66                   q(i0,j,l)=q(i0,j,l)+q(i0+offset,j,l)
67                 ENDDO
68              ENDDO
69            ENDDO
70           
71            DO j=j_start, j_finish
72!CDIR NODEP
73!CDIR ON_ADB(q)
74               DO i=1,iim
75                 q(i,j,l)=q(i-MOD(i-1,2**(ngroup-ig+1)),j,l)
76               ENDDO
77            ENDDO
78
79            DO j=j_start, j_finish
80!CDIR ON_ADB(airen_tab)
81!CDIR ON_ADB(q)
82               DO i=1,iim
83                 q(i,j,l)=q(i,j,l)*airen_tab(i,j,jd)
84               ENDDO
85               q(iip1,j,l)=q(1,j,l)
86            ENDDO
87       
88!c     Concerne le pole sud
89            j_start  = j1-jd
90            j_finish = j2-jd
91            DO ig2=1,ngroup-ig+1
92              offset=2**(ig2-1)
93              DO j=j_start, j_finish
94!CDIR NODEP
95!CDIR ON_ADB(q)
96                 DO i0=1,iim,2**ig2
97                   q(i0,jjp1-j+1-jd,l)= q(i0,jjp1-j+1-jd,l)
98     &                                 +q(i0+offset,jjp1-j+1-jd,l)
99                 ENDDO
100              ENDDO
101            ENDDO
102
103
104            DO j=j_start, j_finish
105!CDIR NODEP
106!CDIR ON_ADB(q)
107               DO i=1,iim
108                 q(i,jjp1-j+1-jd,l)=q(i-MOD(i-1,2**(ngroup-ig+1)),
109     &                                jjp1-j+1-jd,l)
110               ENDDO
111            ENDDO
112
113            DO j=j_start, j_finish
114!CDIR ON_ADB(aires_tab)
115!CDIR ON_ADB(q)
116               DO i=1,iim
117                 q(i,jjp1-j+1-jd,l)=q(i,jjp1-j+1-jd,l)* 
118     &                              aires_tab(i,jjp1-j+1,jd)
119               ENDDO
120               q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l)
121            ENDDO
122
123       
124            j1=j2+1
125            j2=j2+2**ig
126         ENDDO
127      ENDDO
128!$OMP END DO NOWAIT
129
130      RETURN
131      END
132     
133     
134     
135     
136      SUBROUTINE INIT_GROUPEUN(airen_tab, aires_tab)
137      IMPLICIT NONE
138
139#include "dimensions.h"
140#include "paramet.h"
141#include "comconst.h"
142#include "comgeom2.h"
143
144      INTEGER ngroup
145      PARAMETER (ngroup=3)
146
147      REAL airen,airecn
148      REAL aires,airecs
149
150      INTEGER i,j,l,ig,j1,j2,i0,jd
151
152      INTEGER j_start, j_finish
153
154      REAL :: airen_tab(iip1,jjp1,0:1)
155      REAL :: aires_tab(iip1,jjp1,0:1)
156
157      DO jd=0, 1
158         j1=1+jd
159         j2=2
160         DO ig=1,ngroup
161           
162!     c     Concerne le pole nord
163            j_start = j1-jd
164            j_finish = j2-jd
165            DO j=j_start, j_finish
166               DO i0=1,iim,2**(ngroup-ig+1)
167                  airen=0.
168                  DO i=i0,i0+2**(ngroup-ig+1)-1
169                     airen = airen+aire(i,j)
170                  ENDDO
171                  DO i=i0,i0+2**(ngroup-ig+1)-1
172                     airen_tab(i,j,jd) =
173     &                    aire(i,j) / airen
174                  ENDDO
175               ENDDO
176            ENDDO
177           
178!     c     Concerne le pole sud
179            j_start = j1-jd
180            j_finish = j2-jd
181            DO j=j_start, j_finish
182               DO i0=1,iim,2**(ngroup-ig+1)
183                  aires=0.
184                  DO i=i0,i0+2**(ngroup-ig+1)-1
185                     aires=aires+aire(i,jjp1-j+1)
186                  ENDDO
187                  DO i=i0,i0+2**(ngroup-ig+1)-1
188                     aires_tab(i,jjp1-j+1,jd) =
189     &                    aire(i,jjp1-j+1) / aires
190                  ENDDO
191               ENDDO
192            ENDDO
193           
194            j1=j2+1
195            j2=j2+2**ig
196         ENDDO
197      ENDDO
198     
199      RETURN
200      END
Note: See TracBrowser for help on using the repository browser.