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

Last change on this file since 4180 was 4180, checked in by scharf, 22 months 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.