source: LMDZ6/branches/Amaury_dev/libf/dyn3dmem/groupeun_loc.f90 @ 5106

Last change on this file since 5106 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
File size: 4.7 KB
Line 
1SUBROUTINE groupeun_loc(jjmax,llmax,sb,se,jjb,jje,q)
2  USE parallel_lmdz
3  USE Write_Field_p
4  USE comconst_mod, ONLY: ngroup
5  IMPLICIT NONE
6
7  include "dimensions.h"
8  include "paramet.h"
9  include "comgeom2.h"
10
11  INTEGER :: jjmax,llmax,sb,se,jjb,jje
12  REAL :: q(iip1,sb:se,llmax)
13
14  ! INTEGER ngroup
15  ! PARAMETER (ngroup=3)
16
17  REAL :: airecn,qn
18  REAL :: airecs,qs
19
20  INTEGER :: i,j,l,ig,ig2,j1,j2,i0,jd
21
22  !--------------------------------------------------------------------c
23  ! Strategie d'optimisation                                           c
24  ! stocker les valeurs systematiquement recalculees                   c
25  ! et identiques d'un pas de temps sur l'autre. Il s'agit des         c
26  ! aires des cellules qui sont sommees. S'il n'y a pas de changement  c
27  ! de grille au cours de la simulation tout devrait bien se passer.   c
28  ! Autre optimisation : determination des bornes entre lesquelles "j" c
29  ! varie, au lieu de faire un test a chaque fois...
30  !--------------------------------------------------------------------c
31
32  INTEGER :: j_start, j_finish
33
34  REAL, SAVE :: airen_tab(iip1,jjp1,0:1)
35  REAL, SAVE :: aires_tab(iip1,jjp1,0:1)
36!$OMP THREADPRIVATE(airen_tab, aires_tab)
37
38  LOGICAL, SAVE :: first = .TRUE.
39!$OMP THREADPRIVATE(first)
40  ! INTEGER,SAVE :: i_index(iim,ngroup)
41  INTEGER      :: offset
42  ! REAL         :: qsum(iim/ngroup)
43
44  IF (first) THEN
45     CALL init_groupeun_loc(airen_tab, aires_tab)
46     first = .FALSE.
47  ENDIF
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  = MAX(jjb, j1-jd)
59        j_finish = MIN(jje, 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  = MAX(1+jjp1-jje-jd, j1-jd)
90        j_finish = MIN(1+jjp1-jjb-jd, 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
131END SUBROUTINE groupeun_loc
132
133
134
135SUBROUTINE init_groupeun_loc(airen_tab, aires_tab)
136
137  USE parallel_lmdz
138  USE comconst_mod, ONLY: ngroup
139  IMPLICIT NONE
140
141  include "dimensions.h"
142  include "paramet.h"
143  include "comgeom2.h"
144
145  ! INTEGER ngroup
146  ! PARAMETER (ngroup=3)
147
148  REAL :: airen,airecn
149  REAL :: aires,airecs
150
151  INTEGER :: i,j,l,ig,j1,j2,i0,jd
152
153  INTEGER :: j_start, j_finish
154
155  REAL :: airen_tab(iip1,jjp1,0:1)
156  REAL :: aires_tab(iip1,jjp1,0:1)
157
158  DO jd=0, 1
159     j1=1+jd
160     j2=2
161     DO ig=1,ngroup
162
163  ! c     Concerne le pole nord
164        j_start = j1-jd
165        j_finish = j2-jd
166        DO j=j_start, j_finish
167           DO i0=1,iim,2**(ngroup-ig+1)
168              airen=0.
169              DO i=i0,i0+2**(ngroup-ig+1)-1
170                 airen = airen+aire(i,j)
171              ENDDO
172              DO i=i0,i0+2**(ngroup-ig+1)-1
173                 airen_tab(i,j,jd) = &
174                       aire(i,j) / airen
175              ENDDO
176           ENDDO
177        ENDDO
178
179  ! c     Concerne le pole sud
180        j_start = j1-jd
181        j_finish = j2-jd
182        DO j=j_start, j_finish
183           DO i0=1,iim,2**(ngroup-ig+1)
184              aires=0.
185              DO i=i0,i0+2**(ngroup-ig+1)-1
186                 aires=aires+aire(i,jjp1-j+1)
187              ENDDO
188              DO i=i0,i0+2**(ngroup-ig+1)-1
189                 aires_tab(i,jjp1-j+1,jd) = &
190                       aire(i,jjp1-j+1) / aires
191              ENDDO
192           ENDDO
193        ENDDO
194
195        j1=j2+1
196        j2=j2+2**ig
197     ENDDO
198  ENDDO
199
200
201END SUBROUTINE init_groupeun_loc
Note: See TracBrowser for help on using the repository browser.