source: LMDZ6/branches/Amaury_dev/libf/dyn3d/groupeun.F90 @ 5112

Last change on this file since 5112 was 5105, checked in by abarral, 4 months ago

Replace 1DUTILS.h by module lmdz_1dutils.f90
Replace 1DConv.h by module lmdz_old_1dconv.f90 (it's only used by old_* files)
Convert *.F to *.f90
Fix gradsdef.h formatting
Remove unnecessary "RETURN" at the end of functions/subroutines
  • 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: 4.8 KB
Line 
1! $Header$
2
3SUBROUTINE groupeun(jjmax, llmax, q)
4
5  USE comconst_mod, ONLY: ngroup
6
7  IMPLICIT NONE
8
9  include "dimensions.h"
10  include "paramet.h"
11  include "comgeom2.h"
12
13  INTEGER :: jjmax, llmax
14  REAL :: q(iip1, jjmax, llmax)
15
16  ! INTEGER ngroup
17  ! PARAMETER (ngroup=3)
18
19  REAL :: airecn, qn
20  REAL :: airecs, qs
21
22  INTEGER :: i, j, l, ig, ig2, j1, j2, i0, jd
23
24  !--------------------------------------------------------------------c
25  ! Strategie d'optimisation                                           c
26  ! stocker les valeurs systematiquement recalculees                   c
27  ! et identiques d'un pas de temps sur l'autre. Il s'agit des         c
28  ! aires des cellules qui sont sommees. S'il n'y a pas de changement  c
29  ! de grille au cours de la simulation tout devrait bien se passer.   c
30  ! Autre optimisation : determination des bornes entre lesquelles "j" c
31  ! varie, au lieu de faire un test à chaque fois...
32  !--------------------------------------------------------------------c
33
34  INTEGER :: j_start, j_finish
35
36  REAL, SAVE :: airen_tab(iip1, jjp1, 0:1)
37  REAL, SAVE :: aires_tab(iip1, jjp1, 0:1)
38
39  LOGICAL, SAVE :: first = .TRUE.
40  ! INTEGER,SAVE :: i_index(iim,ngroup)
41  INTEGER :: offset
42  ! REAL         :: qsum(iim/ngroup)
43
44  IF (first) THEN
45    CALL INIT_GROUPEUN(airen_tab, aires_tab)
46    first = .FALSE.
47  ENDIF
48
49
50  ! Champs 3D
51  jd = jjp1 - jjmax
52  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
53  DO l = 1, llm
54    j1 = 1 + jd
55    j2 = 2
56    DO ig = 1, ngroup
57
58      ! Concerne le pole nord
59      j_start = j1 - jd
60      j_finish = j2 - jd
61      DO ig2 = 1, ngroup - ig + 1
62        offset = 2**(ig2 - 1)
63        DO j = j_start, j_finish
64          !CDIR NODEP
65          !CDIR ON_ADB(q)
66          DO i0 = 1, iim, 2**ig2
67            q(i0, j, l) = q(i0, j, l) + q(i0 + offset, j, l)
68          ENDDO
69        ENDDO
70      ENDDO
71
72      DO j = j_start, j_finish
73        !CDIR NODEP
74        !CDIR ON_ADB(q)
75        DO i = 1, iim
76          q(i, j, l) = q(i - MOD(i - 1, 2**(ngroup - ig + 1)), j, l)
77        ENDDO
78      ENDDO
79
80      DO j = j_start, j_finish
81        !CDIR ON_ADB(airen_tab)
82        !CDIR ON_ADB(q)
83        DO i = 1, iim
84          q(i, j, l) = q(i, j, l) * airen_tab(i, j, jd)
85        ENDDO
86        q(iip1, j, l) = q(1, j, l)
87      ENDDO
88
89      !c     Concerne le pole sud
90      j_start = j1 - jd
91      j_finish = j2 - jd
92      DO ig2 = 1, ngroup - ig + 1
93        offset = 2**(ig2 - 1)
94        DO j = j_start, j_finish
95          !CDIR NODEP
96          !CDIR ON_ADB(q)
97          DO i0 = 1, iim, 2**ig2
98            q(i0, jjp1 - j + 1 - jd, l) = q(i0, jjp1 - j + 1 - jd, l) &
99                    + q(i0 + offset, jjp1 - j + 1 - jd, l)
100          ENDDO
101        ENDDO
102      ENDDO
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      j1 = j2 + 1
124      j2 = j2 + 2**ig
125    ENDDO
126  ENDDO
127  !$OMP END DO NOWAIT
128
129
130END SUBROUTINE groupeun
131
132
133SUBROUTINE INIT_GROUPEUN(airen_tab, aires_tab)
134
135  USE comconst_mod, ONLY: ngroup
136
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
199END SUBROUTINE INIT_GROUPEUN
Note: See TracBrowser for help on using the repository browser.