source: LMDZ6/branches/Amaury_dev/libf/dyn3d/groupeun.F @ 5101

Last change on this file since 5101 was 5099, checked in by abarral, 4 months ago

Replace most uses of CPP_DUST by the corresponding logical defined in lmdz_cppkeys_wrapper.F90
Convert several files from .F to .f90 to allow Dust to compile w/o rrtm/ecrad
Create lmdz_yoerad.f90
(lint) Remove "!" on otherwise empty line
  • 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
Line 
1
2! $Header$
3
4      SUBROUTINE groupeun(jjmax,llmax,q)
5     
6      USE comconst_mod, ONLY: ngroup
7     
8      IMPLICIT NONE
9
10      include "dimensions.h"
11      include "paramet.h"
12      include "comgeom2.h"
13
14      INTEGER jjmax,llmax
15      REAL q(iip1,jjmax,llmax)
16
17!     INTEGER ngroup
18!     PARAMETER (ngroup=3)
19
20      REAL airecn,qn
21      REAL airecs,qs
22
23      INTEGER i,j,l,ig,ig2,j1,j2,i0,jd
24
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.
41!     INTEGER,SAVE :: i_index(iim,ngroup)
42      INTEGER      :: offset
43!     REAL         :: qsum(iim/ngroup)
44
45      IF (first) THEN
46         CALL INIT_GROUPEUN(airen_tab, aires_tab)
47         first = .FALSE.
48      ENDIF
49
50
51c Champs 3D
52      jd=jjp1-jjmax
53c$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
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
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           
73            DO j=j_start, j_finish
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)
78               ENDDO
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
87               q(iip1,j,l)=q(1,j,l)
88            ENDDO
89       
90!c     Concerne le pole sud
91            j_start  = j1-jd
92            j_finish = j2-jd
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
106            DO j=j_start, j_finish
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)
112               ENDDO
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
122               q(iip1,jjp1-j+1-jd,l)=q(1,jjp1-j+1-jd,l)
123            ENDDO
124
125       
126            j1=j2+1
127            j2=j2+2**ig
128         ENDDO
129      ENDDO
130!$OMP END DO NOWAIT
131
132      RETURN
133      END
134     
135     
136     
137     
138      SUBROUTINE INIT_GROUPEUN(airen_tab, aires_tab)
139     
140      USE comconst_mod, ONLY: ngroup
141     
142      IMPLICIT NONE
143
144      include "dimensions.h"
145      include "paramet.h"
146      include "comgeom2.h"
147
148!     INTEGER ngroup
149!     PARAMETER (ngroup=3)
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.