source: LMDZ6/trunk/libf/dyn3d/groupeun.f90 @ 5258

Last change on this file since 5258 was 5246, checked in by abarral, 6 weeks ago

Convert fixed-form to free-form sources .F -> .{f,F}90
(WIP: some .F remain, will be handled in subsequent commits)
  • 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.6 KB
Line 
1!
2! $Header$
3!
4SUBROUTINE 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
25  !--------------------------------------------------------------------c
26  ! Strategie d'optimisation                                           c
27  ! stocker les valeurs systematiquement recalculees                   c
28  ! et identiques d'un pas de temps sur l'autre. Il s'agit des         c
29  ! aires des cellules qui sont sommees. S'il n'y a pas de changement  c
30  ! de grille au cours de la simulation tout devrait bien se passer.   c
31  ! Autre optimisation : determination des bornes entre lesquelles "j" c
32  ! varie, au lieu de faire un test à chaque fois...
33  !--------------------------------------------------------------------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
51  ! Champs 3D
52  jd=jjp1-jjmax
53!$OMP DO SCHEDULE(STATIC,OMP_CHUNK)
54  DO l=1,llm
55     j1=1+jd
56     j2=2
57     DO ig=1,ngroup
58
59  ! 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
133END SUBROUTINE groupeun
134
135
136
137
138SUBROUTINE 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
204END SUBROUTINE INIT_GROUPEUN
Note: See TracBrowser for help on using the repository browser.