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

Last change on this file since 2000 was 2000, checked in by knoop, 5 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.