Home

Context Navigation

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

Last change on this file since 2000 was 2000, checked in by knoop, 8 years ago
Forced header and separation lines into 80 columns
Property svn:keywords set to `Id`
File size: 10.9 KB

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

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |