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

Last change on this file since 1682 was 1682, checked in by knoop, 6 years ago

Code annotations made doxygen readable

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