Home

Context Navigation

source: palm/trunk/SOURCE/global_min_max.f90 @ 1504

Last change on this file since 1504 was 1354, checked in by heinze, 11 years ago
last commit documented
Property svn:keywords set to `Id`
File size: 10.8 KB

Line
1	SUBROUTINE global_min_max( i1, i2, j1, j2, k1, k2, ar, mode, offset, value, &
2	value_ijk, value1, value1_ijk )
3
4	!--------------------------------------------------------------------------------!
5	! This file is part of PALM.
6	!
7	! PALM is free software: you can redistribute it and/or modify it under the terms
8	! of the GNU General Public License as published by the Free Software Foundation,
9	! either version 3 of the License, or (at your option) any later version.
10	!
11	! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
12	! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
13	! A PARTICULAR PURPOSE. See the GNU General Public License for more details.
14	!
15	! You should have received a copy of the GNU General Public License along with
16	! PALM. If not, see <http://www.gnu.org/licenses/>.
17	!
18	! Copyright 1997-2014 Leibniz Universitaet Hannover
19	!--------------------------------------------------------------------------------!
20	!
21	! Current revisions:
22	! ------------------
23	!
24	!
25	! Former revisions:
26	! -----------------
27	! $Id: global_min_max.f90 1354 2014-04-08 15:22:57Z maronga $
28	!
29	! 1353 2014-04-08 15:21:23Z heinze
30	! REAL constants provided with KIND-attribute
31	!
32	! 1320 2014-03-20 08:40:49Z raasch
33	! ONLY-attribute added to USE-statements,
34	! kind-parameters added to all INTEGER and REAL declaration statements,
35	! kinds are defined in new module kinds,
36	! revision history before 2012 removed,
37	! comment fields (!:) to be used for variable explanations added to
38	! all variable declaration statements
39	!
40	! 1188 2013-06-20 12:00:08Z heinze
41	! Bugfix in modes 'min' and 'max': x and z component were interchanged
42	!
43	! 1036 2012-10-22 13:43:42Z raasch
44	! code put under GPL (PALM 3.9)
45	!
46	! 866 2012-03-28 06:44:41Z raasch
47	! new mode "absoff" accounts for an offset in the respective array
48	!
49	! Revision 1.1 1997/07/24 11:14:03 raasch
50	! Initial revision
51	!
52	!
53	! Description:
54	! ------------
55	! Determine the array minimum/maximum and the corresponding indices.
56	!------------------------------------------------------------------------------!
57
58	USE indices, &
59	ONLY: nbgp, ny, nx
60
61	USE kinds
62
63	USE pegrid
64
65	IMPLICIT NONE
66
67	CHARACTER (LEN=*) :: mode !:
68
69	INTEGER(iwp) :: i !:
70	INTEGER(iwp) :: i1 !:
71	INTEGER(iwp) :: i2 !:
72	INTEGER(iwp) :: id_fmax !:
73	INTEGER(iwp) :: id_fmin !:
74	INTEGER(iwp) :: j !:
75	INTEGER(iwp) :: j1 !:
76	INTEGER(iwp) :: j2 !:
77	INTEGER(iwp) :: k !:
78	INTEGER(iwp) :: k1 !:
79	INTEGER(iwp) :: k2 !:
80	INTEGER(iwp) :: fmax_ijk(3) !:
81	INTEGER(iwp) :: fmax_ijk_l(3) !:
82	INTEGER(iwp) :: fmin_ijk(3) !:
83	INTEGER(iwp) :: fmin_ijk_l(3) !:
84	INTEGER(iwp) :: value_ijk(3) !:
85
86	INTEGER(iwp), OPTIONAL :: value1_ijk(3) !:
87
88	REAL(wp) :: offset !:
89	REAL(wp) :: value !:
90	REAL(wp) :: ar(i1:i2,j1:j2,k1:k2) !:
91
92	#if defined( __ibm )
93	REAL(sp) :: fmax(2) !:
94	REAL(sp) :: fmax_l(2) !:
95	REAL(sp) :: fmin(2) !:
96	REAL(sp) :: fmin_l(2) !:
97	! on 32bit-machines MPI_2REAL must not be replaced
98	! by MPI_2DOUBLE_PRECISION
99	#else
100	REAL(wp) :: fmax(2) !:
101	REAL(wp) :: fmax_l(2) !:
102	REAL(wp) :: fmin(2) !:
103	REAL(wp) :: fmin_l(2) !:
104	#endif
105	REAL(wp), OPTIONAL :: value1 !:
106
107
108	!
109	!-- Determine array minimum
110	IF ( mode == 'min' .OR. mode == 'minmax' ) THEN
111
112	!
113	!-- Determine the local minimum
114	fmin_ijk_l = MINLOC( ar )
115	fmin_ijk_l(1) = i1 + fmin_ijk_l(1) - 1 ! MINLOC assumes lowerbound = 1
116	fmin_ijk_l(2) = j1 + fmin_ijk_l(2) - nbgp
117	fmin_ijk_l(3) = k1 + fmin_ijk_l(3) - nbgp
118	fmin_l(1) = ar(fmin_ijk_l(1),fmin_ijk_l(2),fmin_ijk_l(3))
119
120	#if defined( __parallel )
121	fmin_l(2) = myid
122	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
123	CALL MPI_ALLREDUCE( fmin_l, fmin, 1, MPI_2REAL, MPI_MINLOC, comm2d, &
124	ierr )
125
126	!
127	!-- Determine the global minimum. Result stored on PE0.
128	id_fmin = fmin(2)
129	IF ( id_fmin /= 0 ) THEN
130	IF ( myid == 0 ) THEN
131	CALL MPI_RECV( fmin_ijk, 3, MPI_INTEGER, id_fmin, 0, comm2d, &
132	status, ierr )
133	ELSEIF ( myid == id_fmin ) THEN
134	CALL MPI_SEND( fmin_ijk_l, 3, MPI_INTEGER, 0, 0, comm2d, ierr )
135	ENDIF
136	ELSE
137	fmin_ijk = fmin_ijk_l
138	ENDIF
139	!
140	!-- Send the indices of the just determined array minimum to other PEs
141	CALL MPI_BCAST( fmin_ijk, 3, MPI_INTEGER, 0, comm2d, ierr )
142	#else
143	fmin(1) = fmin_l(1)
144	fmin_ijk = fmin_ijk_l
145	#endif
146
147	ENDIF
148
149	!
150	!-- Determine array maximum
151	IF ( mode == 'max' .OR. mode == 'minmax' ) THEN
152
153	!
154	!-- Determine the local maximum
155	fmax_ijk_l = MAXLOC( ar )
156	fmax_ijk_l(1) = i1 + fmax_ijk_l(1) - 1 ! MAXLOC assumes lowerbound = 1
157	fmax_ijk_l(2) = j1 + fmax_ijk_l(2) - nbgp
158	fmax_ijk_l(3) = k1 + fmax_ijk_l(3) - nbgp
159	fmax_l(1) = ar(fmax_ijk_l(1),fmax_ijk_l(2),fmax_ijk_l(3))
160
161	#if defined( __parallel )
162	fmax_l(2) = myid
163	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
164	CALL MPI_ALLREDUCE( fmax_l, fmax, 1, MPI_2REAL, MPI_MAXLOC, comm2d, &
165	ierr )
166
167	!
168	!-- Determine the global maximum. Result stored on PE0.
169	id_fmax = fmax(2)
170	IF ( id_fmax /= 0 ) THEN
171	IF ( myid == 0 ) THEN
172	CALL MPI_RECV( fmax_ijk, 3, MPI_INTEGER, id_fmax, 0, comm2d, &
173	status, ierr )
174	ELSEIF ( myid == id_fmax ) THEN
175	CALL MPI_SEND( fmax_ijk_l, 3, MPI_INTEGER, 0, 0, comm2d, ierr )
176	ENDIF
177	ELSE
178	fmax_ijk = fmax_ijk_l
179	ENDIF
180	!
181	!-- send the indices of the just determined array maximum to other PEs
182	CALL MPI_BCAST( fmax_ijk, 3, MPI_INTEGER, 0, comm2d, ierr )
183	#else
184	fmax(1) = fmax_l(1)
185	fmax_ijk = fmax_ijk_l
186	#endif
187
188	ENDIF
189
190	!
191	!-- Determine absolute array maximum
192	IF ( mode == 'abs' ) THEN
193
194	!
195	!-- Determine the local absolut maximum
196	fmax_l(1) = 0.0_wp
197	fmax_ijk_l(1) = i1
198	fmax_ijk_l(2) = j1
199	fmax_ijk_l(3) = k1
200	DO k = k1, k2
201	DO j = j1, j2
202	DO i = i1, i2
203	IF ( ABS( ar(i,j,k) ) > fmax_l(1) ) THEN
204	fmax_l(1) = ABS( ar(i,j,k) )
205	fmax_ijk_l(1) = i
206	fmax_ijk_l(2) = j
207	fmax_ijk_l(3) = k
208	ENDIF
209	ENDDO
210	ENDDO
211	ENDDO
212
213	!
214	!-- Set a flag in case that the determined value is negative.
215	!-- A constant offset has to be subtracted in order to handle the special
216	!-- case i=0 correctly
217	IF ( ar(fmax_ijk_l(1),fmax_ijk_l(2),fmax_ijk_l(3)) < 0.0_wp ) THEN
218	fmax_ijk_l(1) = -fmax_ijk_l(1) - 10
219	ENDIF
220
221	#if defined( __parallel )
222	fmax_l(2) = myid
223	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
224	CALL MPI_ALLREDUCE( fmax_l, fmax, 1, MPI_2REAL, MPI_MAXLOC, comm2d, &
225	ierr )
226
227	!
228	!-- Determine the global absolut maximum. Result stored on PE0.
229	id_fmax = fmax(2)
230	IF ( id_fmax /= 0 ) THEN
231	IF ( myid == 0 ) THEN
232	CALL MPI_RECV( fmax_ijk, 3, MPI_INTEGER, id_fmax, 0, comm2d, &
233	status, ierr )
234	ELSEIF ( myid == id_fmax ) THEN
235	CALL MPI_SEND( fmax_ijk_l, 3, MPI_INTEGER, 0, 0, comm2d, ierr )
236	ENDIF
237	ELSE
238	fmax_ijk = fmax_ijk_l
239	ENDIF
240	!
241	!-- Send the indices of the just determined absolut maximum to other PEs
242	CALL MPI_BCAST( fmax_ijk, 3, MPI_INTEGER, 0, comm2d, ierr )
243	#else
244	fmax(1) = fmax_l(1)
245	fmax_ijk = fmax_ijk_l
246	#endif
247
248	ENDIF
249
250	!
251	!-- Determine absolute maximum of ( array - offset )
252	IF ( mode == 'absoff' ) THEN
253
254	!
255	!-- Determine the local absolut maximum
256	fmax_l(1) = 0.0_wp
257	fmax_ijk_l(1) = i1
258	fmax_ijk_l(2) = j1
259	fmax_ijk_l(3) = k1
260	DO k = k1, k2
261	DO j = j1, j2
262	!
263	!-- Attention: the lowest gridpoint is excluded here, because there
264	!-- --------- is no advection at nzb=0 and mode 'absoff' is only
265	!-- used for calculating u,v extrema for CFL-criteria
266	DO i = i1+1, i2
267	IF ( ABS( ar(i,j,k) - offset ) > fmax_l(1) ) THEN
268	fmax_l(1) = ABS( ar(i,j,k) - offset )
269	fmax_ijk_l(1) = i
270	fmax_ijk_l(2) = j
271	fmax_ijk_l(3) = k
272	ENDIF
273	ENDDO
274	ENDDO
275	ENDDO
276
277	!
278	!-- Set a flag in case that the determined value is negative.
279	!-- A constant offset has to be subtracted in order to handle the special
280	!-- case i=0 correctly
281	IF ( ar(fmax_ijk_l(1),fmax_ijk_l(2),fmax_ijk_l(3)) < 0.0_wp ) THEN
282	fmax_ijk_l(1) = -fmax_ijk_l(1) - 10
283	ENDIF
284
285	#if defined( __parallel )
286	fmax_l(2) = myid
287	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
288	CALL MPI_ALLREDUCE( fmax_l, fmax, 1, MPI_2REAL, MPI_MAXLOC, comm2d, &
289	ierr )
290
291	!
292	!-- Determine the global absolut maximum. Result stored on PE0.
293	id_fmax = fmax(2)
294	IF ( id_fmax /= 0 ) THEN
295	IF ( myid == 0 ) THEN
296	CALL MPI_RECV( fmax_ijk, 3, MPI_INTEGER, id_fmax, 0, comm2d, &
297	status, ierr )
298	ELSEIF ( myid == id_fmax ) THEN
299	CALL MPI_SEND( fmax_ijk_l, 3, MPI_INTEGER, 0, 0, comm2d, ierr )
300	ENDIF
301	ELSE
302	fmax_ijk = fmax_ijk_l
303	ENDIF
304	!
305	!-- Send the indices of the just determined absolut maximum to other PEs
306	CALL MPI_BCAST( fmax_ijk, 3, MPI_INTEGER, 0, comm2d, ierr )
307	#else
308	fmax(1) = fmax_l(1)
309	fmax_ijk = fmax_ijk_l
310	#endif
311
312	ENDIF
313
314	!
315	!-- Determine output parameters
316	SELECT CASE( mode )
317
318	CASE( 'min' )
319
320	value = fmin(1)
321	value_ijk = fmin_ijk
322
323	CASE( 'max' )
324
325	value = fmax(1)
326	value_ijk = fmax_ijk
327
328	CASE( 'minmax' )
329
330	value = fmin(1)
331	value_ijk = fmin_ijk
332	value1 = fmax(1)
333	value1_ijk = fmax_ijk
334
335	CASE( 'abs', 'absoff' )
336
337	value = fmax(1)
338	value_ijk = fmax_ijk
339	IF ( fmax_ijk(1) < 0 ) THEN
340	value = -value
341	value_ijk(1) = -value_ijk(1) - 10 !???
342	ENDIF
343
344	END SELECT
345
346	!
347	!-- Limit index values to the range 0..nx, 0..ny
348	IF ( value_ijk(3) < 0 ) value_ijk(3) = nx +1 + value_ijk(3)
349	IF ( value_ijk(3) > nx ) value_ijk(3) = value_ijk(3) - (nx+1)
350	IF ( value_ijk(2) < 0 ) value_ijk(2) = ny +1 + value_ijk(2)
351	IF ( value_ijk(2) > ny ) value_ijk(2) = value_ijk(2) - (ny+1)
352
353
354	END SUBROUTINE global_min_max

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |