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

Last change on this file since 5419 was 5159, checked in by abarral, 17 months ago

Put dimensions.h and paramet.h into modules
  • 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.7 KB
Line 
1! $Header$
2
3SUBROUTINE groupeun(jjmax, llmax, q)
4
5  USE comconst_mod, ONLY: ngroup
6  USE lmdz_comgeom2
7
8USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
9  USE lmdz_paramet
10  IMPLICIT NONE
11
12
13
14
15  INTEGER :: jjmax, llmax
16  REAL :: q(iip1, jjmax, llmax)
17
18  ! INTEGER ngroup
19  ! PARAMETER (ngroup=3)
20
21  INTEGER :: i, j, l, ig, ig2, j1, j2, i0, jd
22
23  !--------------------------------------------------------------------c
24  ! Strategie d'optimisation                                           c
25  ! stocker les valeurs systematiquement recalculees                   c
26  ! et identiques d'un pas de temps sur l'autre. Il s'agit des         c
27  ! aires des cellules qui sont sommees. S'il n'y a pas de changement  c
28  ! de grille au cours de la simulation tout devrait bien se passer.   c
29  ! Autre optimisation : determination des bornes entre lesquelles "j" c
30  ! varie, au lieu de faire un test à chaque fois...
31  !--------------------------------------------------------------------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
49  ! Champs 3D
50  jd = jjp1 - jjmax
51  !$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
52  DO l = 1, llm
53    j1 = 1 + jd
54    j2 = 2
55    DO ig = 1, ngroup
56
57      ! 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      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      j1 = j2 + 1
123      j2 = j2 + 2**ig
124    ENDDO
125  ENDDO
126  !$OMP END DO NOWAIT
127
128
129END SUBROUTINE groupeun
130
131
132SUBROUTINE INIT_GROUPEUN(airen_tab, aires_tab)
133
134  USE comconst_mod, ONLY: ngroup
135  USE lmdz_comgeom2
136
137USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm
138  USE lmdz_paramet
139  IMPLICIT NONE
140
141
142
143
144  ! INTEGER ngroup
145  ! PARAMETER (ngroup=3)
146
147  REAL :: airen
148  REAL :: aires
149
150  INTEGER :: i, j, 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
200END SUBROUTINE INIT_GROUPEUN
Note: See TracBrowser for help on using the repository browser.