Home

Context Navigation

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

Last change on this file since 4180 was 4180, checked in by scharf, 5 years ago
removed comments in 'Former revisions' section that are older than 01.01.2019
Property svn:keywords set to `Id`
File size: 10.1 KB

Line
1	!> @file global_min_max.f90
2	!------------------------------------------------------------------------------!
3	! This file is part of the PALM model system.
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-2019 Leibniz Universitaet Hannover
18	!------------------------------------------------------------------------------!
19	!
20	! Current revisions:
21	! ------------------
22	!
23	!
24	! Former revisions:
25	! -----------------
26	! $Id: global_min_max.f90 4180 2019-08-21 14:37:54Z scharf $
27	! Corrected "Former revisions" section
28	!
29	!
30	! Description:
31	! ------------
32	!> Determine the array minimum/maximum and the corresponding indices.
33	!------------------------------------------------------------------------------!
34	SUBROUTINE global_min_max( i1, i2, j1, j2, k1, k2, ar, mode, offset, value, &
35	value_ijk, value1, value1_ijk )
36
37
38	USE indices, &
39	ONLY: nbgp, ny, nx
40
41	USE kinds
42
43	USE pegrid
44
45	IMPLICIT NONE
46
47	CHARACTER (LEN=*) :: mode !<
48
49	INTEGER(iwp) :: i !<
50	INTEGER(iwp) :: i1 !<
51	INTEGER(iwp) :: i2 !<
52	INTEGER(iwp) :: id_fmax !<
53	INTEGER(iwp) :: id_fmin !<
54	INTEGER(iwp) :: j !<
55	INTEGER(iwp) :: j1 !<
56	INTEGER(iwp) :: j2 !<
57	INTEGER(iwp) :: k !<
58	INTEGER(iwp) :: k1 !<
59	INTEGER(iwp) :: k2 !<
60	INTEGER(iwp) :: fmax_ijk(3) !<
61	INTEGER(iwp) :: fmax_ijk_l(3) !<
62	INTEGER(iwp) :: fmin_ijk(3) !<
63	INTEGER(iwp) :: fmin_ijk_l(3) !<
64	INTEGER(iwp) :: value_ijk(3) !<
65
66	INTEGER(iwp), OPTIONAL :: value1_ijk(3) !<
67
68	REAL(wp) :: offset !<
69	REAL(wp) :: value !<
70	REAL(wp) :: ar(i1:i2,j1:j2,k1:k2) !<
71
72	#if defined( __ibm )
73	REAL(sp) :: fmax(2) !<
74	REAL(sp) :: fmax_l(2) !<
75	REAL(sp) :: fmin(2) !<
76	REAL(sp) :: fmin_l(2) !<
77	! on 32bit-machines MPI_2REAL must not be replaced
78	! by MPI_2DOUBLE_PRECISION
79	#else
80	REAL(wp) :: fmax(2) !<
81	REAL(wp) :: fmax_l(2) !<
82	REAL(wp) :: fmin(2) !<
83	REAL(wp) :: fmin_l(2) !<
84	#endif
85	REAL(wp), OPTIONAL :: value1 !<
86
87
88	!
89	!-- Determine array minimum
90	IF ( mode == 'min' .OR. mode == 'minmax' ) THEN
91
92	!
93	!-- Determine the local minimum
94	fmin_ijk_l = MINLOC( ar )
95	fmin_ijk_l(1) = i1 + fmin_ijk_l(1) - 1 ! MINLOC assumes lowerbound = 1
96	fmin_ijk_l(2) = j1 + fmin_ijk_l(2) - nbgp
97	fmin_ijk_l(3) = k1 + fmin_ijk_l(3) - nbgp
98	fmin_l(1) = ar(fmin_ijk_l(1),fmin_ijk_l(2),fmin_ijk_l(3))
99
100	#if defined( __parallel )
101	fmin_l(2) = myid
102	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
103	CALL MPI_ALLREDUCE( fmin_l, fmin, 1, MPI_2REAL, MPI_MINLOC, comm2d, &
104	ierr )
105
106	!
107	!-- Determine the global minimum. Result stored on PE0.
108	id_fmin = fmin(2)
109	IF ( id_fmin /= 0 ) THEN
110	IF ( myid == 0 ) THEN
111	CALL MPI_RECV( fmin_ijk, 3, MPI_INTEGER, id_fmin, 0, comm2d, &
112	status, ierr )
113	ELSEIF ( myid == id_fmin ) THEN
114	CALL MPI_SEND( fmin_ijk_l, 3, MPI_INTEGER, 0, 0, comm2d, ierr )
115	ENDIF
116	ELSE
117	fmin_ijk = fmin_ijk_l
118	ENDIF
119	!
120	!-- Send the indices of the just determined array minimum to other PEs
121	CALL MPI_BCAST( fmin_ijk, 3, MPI_INTEGER, 0, comm2d, ierr )
122	#else
123	fmin(1) = fmin_l(1)
124	fmin_ijk = fmin_ijk_l
125	#endif
126
127	ENDIF
128
129	!
130	!-- Determine array maximum
131	IF ( mode == 'max' .OR. mode == 'minmax' ) THEN
132
133	!
134	!-- Determine the local maximum
135	fmax_ijk_l = MAXLOC( ar )
136	fmax_ijk_l(1) = i1 + fmax_ijk_l(1) - 1 ! MAXLOC assumes lowerbound = 1
137	fmax_ijk_l(2) = j1 + fmax_ijk_l(2) - nbgp
138	fmax_ijk_l(3) = k1 + fmax_ijk_l(3) - nbgp
139	fmax_l(1) = ar(fmax_ijk_l(1),fmax_ijk_l(2),fmax_ijk_l(3))
140
141	#if defined( __parallel )
142	fmax_l(2) = myid
143	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
144	CALL MPI_ALLREDUCE( fmax_l, fmax, 1, MPI_2REAL, MPI_MAXLOC, comm2d, &
145	ierr )
146
147	!
148	!-- Determine the global maximum. Result stored on PE0.
149	id_fmax = fmax(2)
150	IF ( id_fmax /= 0 ) THEN
151	IF ( myid == 0 ) THEN
152	CALL MPI_RECV( fmax_ijk, 3, MPI_INTEGER, id_fmax, 0, comm2d, &
153	status, ierr )
154	ELSEIF ( myid == id_fmax ) THEN
155	CALL MPI_SEND( fmax_ijk_l, 3, MPI_INTEGER, 0, 0, comm2d, ierr )
156	ENDIF
157	ELSE
158	fmax_ijk = fmax_ijk_l
159	ENDIF
160	!
161	!-- send the indices of the just determined array maximum to other PEs
162	CALL MPI_BCAST( fmax_ijk, 3, MPI_INTEGER, 0, comm2d, ierr )
163	#else
164	fmax(1) = fmax_l(1)
165	fmax_ijk = fmax_ijk_l
166	#endif
167
168	ENDIF
169
170	!
171	!-- Determine absolute array maximum
172	IF ( mode == 'abs' ) THEN
173
174	!
175	!-- Determine the local absolut maximum
176	fmax_l(1) = 0.0_wp
177	fmax_ijk_l(1) = i1
178	fmax_ijk_l(2) = j1
179	fmax_ijk_l(3) = k1
180	DO k = k1, k2
181	DO j = j1, j2
182	DO i = i1, i2
183	IF ( ABS( ar(i,j,k) ) > fmax_l(1) ) THEN
184	fmax_l(1) = ABS( ar(i,j,k) )
185	fmax_ijk_l(1) = i
186	fmax_ijk_l(2) = j
187	fmax_ijk_l(3) = k
188	ENDIF
189	ENDDO
190	ENDDO
191	ENDDO
192
193	!
194	!-- Set a flag in case that the determined value is negative.
195	!-- A constant offset has to be subtracted in order to handle the special
196	!-- case i=0 correctly
197	IF ( ar(fmax_ijk_l(1),fmax_ijk_l(2),fmax_ijk_l(3)) < 0.0_wp ) THEN
198	fmax_ijk_l(1) = -fmax_ijk_l(1) - 10
199	ENDIF
200
201	#if defined( __parallel )
202	fmax_l(2) = myid
203	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
204	CALL MPI_ALLREDUCE( fmax_l, fmax, 1, MPI_2REAL, MPI_MAXLOC, comm2d, &
205	ierr )
206
207	!
208	!-- Determine the global absolut maximum. Result stored on PE0.
209	id_fmax = fmax(2)
210	IF ( id_fmax /= 0 ) THEN
211	IF ( myid == 0 ) THEN
212	CALL MPI_RECV( fmax_ijk, 3, MPI_INTEGER, id_fmax, 0, comm2d, &
213	status, ierr )
214	ELSEIF ( myid == id_fmax ) THEN
215	CALL MPI_SEND( fmax_ijk_l, 3, MPI_INTEGER, 0, 0, comm2d, ierr )
216	ENDIF
217	ELSE
218	fmax_ijk = fmax_ijk_l
219	ENDIF
220	!
221	!-- Send the indices of the just determined absolut maximum to other PEs
222	CALL MPI_BCAST( fmax_ijk, 3, MPI_INTEGER, 0, comm2d, ierr )
223	#else
224	fmax(1) = fmax_l(1)
225	fmax_ijk = fmax_ijk_l
226	#endif
227
228	ENDIF
229
230	!
231	!-- Determine absolute maximum of ( array - offset )
232	IF ( mode == 'absoff' ) THEN
233
234	!
235	!-- Determine the local absolut maximum
236	fmax_l(1) = 0.0_wp
237	fmax_ijk_l(1) = i1
238	fmax_ijk_l(2) = j1
239	fmax_ijk_l(3) = k1
240	DO k = k1, k2
241	DO j = j1, j2
242	!
243	!-- Attention: the lowest gridpoint is excluded here, because there
244	!-- --------- is no advection at nzb=0 and mode 'absoff' is only
245	!-- used for calculating u,v extrema for CFL-criteria
246	DO i = i1+1, i2
247	IF ( ABS( ar(i,j,k) - offset ) > fmax_l(1) ) THEN
248	fmax_l(1) = ABS( ar(i,j,k) - offset )
249	fmax_ijk_l(1) = i
250	fmax_ijk_l(2) = j
251	fmax_ijk_l(3) = k
252	ENDIF
253	ENDDO
254	ENDDO
255	ENDDO
256
257	!
258	!-- Set a flag in case that the determined value is negative.
259	!-- A constant offset has to be subtracted in order to handle the special
260	!-- case i=0 correctly
261	IF ( ar(fmax_ijk_l(1),fmax_ijk_l(2),fmax_ijk_l(3)) < 0.0_wp ) THEN
262	fmax_ijk_l(1) = -fmax_ijk_l(1) - 10
263	ENDIF
264
265	#if defined( __parallel )
266	fmax_l(2) = myid
267	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
268	CALL MPI_ALLREDUCE( fmax_l, fmax, 1, MPI_2REAL, MPI_MAXLOC, comm2d, &
269	ierr )
270
271	!
272	!-- Determine the global absolut maximum. Result stored on PE0.
273	id_fmax = fmax(2)
274	IF ( id_fmax /= 0 ) THEN
275	IF ( myid == 0 ) THEN
276	CALL MPI_RECV( fmax_ijk, 3, MPI_INTEGER, id_fmax, 0, comm2d, &
277	status, ierr )
278	ELSEIF ( myid == id_fmax ) THEN
279	CALL MPI_SEND( fmax_ijk_l, 3, MPI_INTEGER, 0, 0, comm2d, ierr )
280	ENDIF
281	ELSE
282	fmax_ijk = fmax_ijk_l
283	ENDIF
284	!
285	!-- Send the indices of the just determined absolut maximum to other PEs
286	CALL MPI_BCAST( fmax_ijk, 3, MPI_INTEGER, 0, comm2d, ierr )
287	#else
288	fmax(1) = fmax_l(1)
289	fmax_ijk = fmax_ijk_l
290	#endif
291
292	ENDIF
293
294	!
295	!-- Determine output parameters
296	SELECT CASE( mode )
297
298	CASE( 'min' )
299
300	value = fmin(1)
301	value_ijk = fmin_ijk
302
303	CASE( 'max' )
304
305	value = fmax(1)
306	value_ijk = fmax_ijk
307
308	CASE( 'minmax' )
309
310	value = fmin(1)
311	value_ijk = fmin_ijk
312	value1 = fmax(1)
313	value1_ijk = fmax_ijk
314
315	CASE( 'abs', 'absoff' )
316
317	value = fmax(1)
318	value_ijk = fmax_ijk
319	IF ( fmax_ijk(1) < 0 ) THEN
320	value = -value
321	value_ijk(1) = -value_ijk(1) - 10 !???
322	ENDIF
323
324	END SELECT
325
326	!
327	!-- Limit index values to the range 0..nx, 0..ny
328	IF ( value_ijk(3) < 0 ) value_ijk(3) = nx +1 + value_ijk(3)
329	IF ( value_ijk(3) > nx ) value_ijk(3) = value_ijk(3) - (nx+1)
330	IF ( value_ijk(2) < 0 ) value_ijk(2) = ny +1 + value_ijk(2)
331	IF ( value_ijk(2) > ny ) value_ijk(2) = value_ijk(2) - (ny+1)
332
333
334	END SUBROUTINE global_min_max

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |