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

Last change on this file since 1353 was 1353, checked in by heinze, 7 years ago

REAL constants provided with KIND-attribute

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