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

Last change on this file since 883 was 867, checked in by raasch, 13 years ago

last commit documented

  • Property svn:keywords set to Id
File size: 9.1 KB
RevLine 
[866]1 SUBROUTINE global_min_max( i1, i2, j1, j2, k1, k2, ar, mode, offset, value, &
[1]2                            value_ijk, value1, value1_ijk )
3
[623]4!------------------------------------------------------------------------------!
[484]5! Current revisions:
[866]6! ------------------
[867]7!
[1]8!
9! Former revisions:
10! -----------------
[3]11! $Id: global_min_max.f90 867 2012-03-28 06:54:50Z suehring $
[623]12!
[867]13! 866 2012-03-28 06:44:41Z raasch
14! new mode "absoff" accounts for an offset in the respective array
15!
[668]16! 667 2010-12-23 12:06:00Z suehring/gryschka
17! Adapting of the index arrays, because MINLOC assumes lowerbound at 1 and not
18! at nbgp.
19!
[623]20! 622 2010-12-10 08:08:13Z raasch
21! optional barriers included in order to speed up collective operations
22!
23! Feb. 2007
[3]24! RCS Log replace by Id keyword, revision history cleaned up
25!
[1]26! Revision 1.11  2003/04/16 12:56:58  raasch
27! Index values of the extrema are limited to the range 0..nx, 0..ny
28!
29! Revision 1.1  1997/07/24 11:14:03  raasch
30! Initial revision
31!
32!
33! Description:
34! ------------
35! Determine the array minimum/maximum and the corresponding indices.
[623]36!------------------------------------------------------------------------------!
[1]37
38    USE indices
39    USE pegrid
40
41    IMPLICIT NONE
42
43    CHARACTER (LEN=*) ::  mode
44
45    INTEGER           ::  i, i1, i2, id_fmax, id_fmin, j, j1, j2, k, k1, k2, &
46                          fmax_ijk(3), fmax_ijk_l(3), fmin_ijk(3), &
47                          fmin_ijk_l(3), value_ijk(3)
48    INTEGER, OPTIONAL ::  value1_ijk(3)
[866]49    REAL              ::  offset, value, &
[1]50                          ar(i1:i2,j1:j2,k1:k2)
51#if defined( __ibm )
52    REAL (KIND=4)     ::  fmax(2), fmax_l(2), fmin(2), fmin_l(2)  ! on 32bit-
53                          ! machines MPI_2REAL must not be replaced by
54                          ! MPI_2DOUBLE_PRECISION
55#else
56    REAL              ::  fmax(2), fmax_l(2), fmin(2), fmin_l(2)
57#endif
58    REAL, OPTIONAL    ::  value1
59
60
61!
62!-- Determine array minimum
63    IF ( mode == 'min'  .OR.  mode == 'minmax' )  THEN
64
65!
66!--    Determine the local minimum
67       fmin_ijk_l = MINLOC( ar )
[866]68       fmin_ijk_l(1) = i1 + fmin_ijk_l(1) - nbgp ! MINLOC assumes lowerbound = 1
[667]69       fmin_ijk_l(2) = j1 + fmin_ijk_l(2) - nbgp
[1]70       fmin_ijk_l(3) = k1 + fmin_ijk_l(3) - 1
71       fmin_l(1)  = ar(fmin_ijk_l(1),fmin_ijk_l(2),fmin_ijk_l(3))
72
73#if defined( __parallel )
74       fmin_l(2)  = myid
[622]75       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
[623]76       CALL MPI_ALLREDUCE( fmin_l, fmin, 1, MPI_2REAL, MPI_MINLOC, comm2d, &
77                           ierr )
[1]78
79!
80!--    Determine the global minimum. Result stored on PE0.
81       id_fmin = fmin(2)
82       IF ( id_fmin /= 0 )  THEN
83          IF ( myid == 0 )  THEN
84             CALL MPI_RECV( fmin_ijk, 3, MPI_INTEGER, id_fmin, 0, comm2d, &
85                            status, ierr )
86          ELSEIF ( myid == id_fmin )  THEN
87             CALL MPI_SEND( fmin_ijk_l, 3, MPI_INTEGER, 0, 0, comm2d, ierr )
88          ENDIF
89       ELSE
90          fmin_ijk = fmin_ijk_l
91       ENDIF
92!
93!--    Send the indices of the just determined array minimum to other PEs
94       CALL MPI_BCAST( fmin_ijk, 3, MPI_INTEGER, 0, comm2d, ierr )
95#else
96       fmin(1)  = fmin_l(1)
97       fmin_ijk = fmin_ijk_l
98#endif
99
100    ENDIF
101
102!
103!-- Determine array maximum
104    IF ( mode == 'max'  .OR.  mode == 'minmax' )  THEN
105
106!
107!--    Determine the local maximum
108       fmax_ijk_l = MAXLOC( ar )
[866]109       fmax_ijk_l(1) = i1 + fmax_ijk_l(1) - nbgp ! MAXLOC assumes lowerbound = 1
[667]110       fmax_ijk_l(2) = j1 + fmax_ijk_l(2) - nbgp
[1]111       fmax_ijk_l(3) = k1 + fmax_ijk_l(3) - 1
112       fmax_l(1) = ar(fmax_ijk_l(1),fmax_ijk_l(2),fmax_ijk_l(3))
113
114#if defined( __parallel )
115       fmax_l(2)  = myid
[622]116       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
[623]117       CALL MPI_ALLREDUCE( fmax_l, fmax, 1, MPI_2REAL, MPI_MAXLOC, comm2d, &
118                           ierr )
[1]119
120!
121!--    Determine the global maximum. Result stored on PE0.
122       id_fmax = fmax(2)
123       IF ( id_fmax /= 0 )  THEN
124          IF ( myid == 0 )  THEN
125             CALL MPI_RECV( fmax_ijk, 3, MPI_INTEGER, id_fmax, 0, comm2d, &
126                            status, ierr )
127          ELSEIF ( myid == id_fmax )  THEN
128             CALL MPI_SEND( fmax_ijk_l, 3, MPI_INTEGER, 0, 0, comm2d, ierr )
129          ENDIF
130       ELSE
131          fmax_ijk = fmax_ijk_l
132       ENDIF
133!
134!--    send the indices of the just determined array maximum to other PEs
135       CALL MPI_BCAST( fmax_ijk, 3, MPI_INTEGER, 0, comm2d, ierr )
136#else
137       fmax(1)  = fmax_l(1)
138       fmax_ijk = fmax_ijk_l
139#endif
140
141    ENDIF
142
143!
144!-- Determine absolute array maximum
145    IF ( mode == 'abs' )  THEN
146
147!
148!--    Determine the local absolut maximum
149       fmax_l(1)     = 0.0
150       fmax_ijk_l(1) =  i1
151       fmax_ijk_l(2) =  j1
152       fmax_ijk_l(3) =  k1
153       DO  k = k1, k2
154          DO  j = j1, j2
155             DO  i = i1, i2
156                IF ( ABS( ar(i,j,k) ) > fmax_l(1) )  THEN
157                   fmax_l(1) = ABS( ar(i,j,k) )
158                   fmax_ijk_l(1) = i
159                   fmax_ijk_l(2) = j
160                   fmax_ijk_l(3) = k
161                ENDIF
162             ENDDO
163          ENDDO
164       ENDDO
165
166!
167!--    Set a flag in case that the determined value is negative.
168!--    A constant offset has to be subtracted in order to handle the special
169!--    case i=0 correctly
170       IF ( ar(fmax_ijk_l(1),fmax_ijk_l(2),fmax_ijk_l(3)) < 0.0 )  THEN
171          fmax_ijk_l(1) = -fmax_ijk_l(1) - 10
172       ENDIF
173
174#if defined( __parallel )
175       fmax_l(2)  = myid
[622]176       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
[1]177       CALL MPI_ALLREDUCE( fmax_l, fmax, 1, MPI_2REAL, MPI_MAXLOC, comm2d, &
178                           ierr )
179
180!
181!--    Determine the global absolut maximum. Result stored on PE0.
182       id_fmax = fmax(2)
183       IF ( id_fmax /= 0 )  THEN
184          IF ( myid == 0 )  THEN
185             CALL MPI_RECV( fmax_ijk, 3, MPI_INTEGER, id_fmax, 0, comm2d, &
186                            status, ierr )
187          ELSEIF ( myid == id_fmax )  THEN
188             CALL MPI_SEND( fmax_ijk_l, 3, MPI_INTEGER, 0, 0, comm2d, ierr )
189          ENDIF
190       ELSE
191          fmax_ijk = fmax_ijk_l
192       ENDIF
193!
194!--    Send the indices of the just determined absolut maximum to other PEs
195       CALL MPI_BCAST( fmax_ijk, 3, MPI_INTEGER, 0, comm2d, ierr )
196#else
197       fmax(1)  = fmax_l(1)
198       fmax_ijk = fmax_ijk_l
199#endif
200
201    ENDIF
202
203!
[866]204!-- Determine absolute maximum of ( array - offset )
205    IF ( mode == 'absoff' )  THEN
206
207!
208!--    Determine the local absolut maximum
209       fmax_l(1)     = 0.0
210       fmax_ijk_l(1) =  i1
211       fmax_ijk_l(2) =  j1
212       fmax_ijk_l(3) =  k1
213       DO  k = k1, k2
214          DO  j = j1, j2
215!
216!--          Attention: the lowest gridpoint is excluded here, because there
217!--          ---------  is no advection at nzb=0 and mode 'absoff' is only
218!--                     used for calculating u,v extrema for CFL-criteria
219             DO  i = i1+1, i2
220                IF ( ABS( ar(i,j,k) - offset ) > fmax_l(1) )  THEN
221                   fmax_l(1) = ABS( ar(i,j,k) - offset )
222                   fmax_ijk_l(1) = i
223                   fmax_ijk_l(2) = j
224                   fmax_ijk_l(3) = k
225                ENDIF
226             ENDDO
227          ENDDO
228       ENDDO
229
230!
231!--    Set a flag in case that the determined value is negative.
232!--    A constant offset has to be subtracted in order to handle the special
233!--    case i=0 correctly
234       IF ( ar(fmax_ijk_l(1),fmax_ijk_l(2),fmax_ijk_l(3)) < 0.0 )  THEN
235          fmax_ijk_l(1) = -fmax_ijk_l(1) - 10
236       ENDIF
237
238#if defined( __parallel )
239       fmax_l(2)  = myid
240       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
241       CALL MPI_ALLREDUCE( fmax_l, fmax, 1, MPI_2REAL, MPI_MAXLOC, comm2d, &
242                           ierr )
243
244!
245!--    Determine the global absolut maximum. Result stored on PE0.
246       id_fmax = fmax(2)
247       IF ( id_fmax /= 0 )  THEN
248          IF ( myid == 0 )  THEN
249             CALL MPI_RECV( fmax_ijk, 3, MPI_INTEGER, id_fmax, 0, comm2d, &
250                            status, ierr )
251          ELSEIF ( myid == id_fmax )  THEN
252             CALL MPI_SEND( fmax_ijk_l, 3, MPI_INTEGER, 0, 0, comm2d, ierr )
253          ENDIF
254       ELSE
255          fmax_ijk = fmax_ijk_l
256       ENDIF
257!
258!--    Send the indices of the just determined absolut maximum to other PEs
259       CALL MPI_BCAST( fmax_ijk, 3, MPI_INTEGER, 0, comm2d, ierr )
260#else
261       fmax(1)  = fmax_l(1)
262       fmax_ijk = fmax_ijk_l
263#endif
264
265    ENDIF
266
267!
[1]268!-- Determine output parameters
269    SELECT CASE( mode )
270
271       CASE( 'min' )
272
273          value     = fmin(1)
274          value_ijk = fmin_ijk
275
276       CASE( 'max' )
277
278          value     = fmax(1)
279          value_ijk = fmax_ijk
280
281       CASE( 'minmax' )
282
283          value      = fmin(1)
284          value_ijk  = fmin_ijk
285          value1     = fmax(1)
286          value1_ijk = fmax_ijk
287
[866]288       CASE( 'abs', 'absoff' )
[1]289
290          value     = fmax(1)
291          value_ijk = fmax_ijk
292          IF ( fmax_ijk(1) < 0 )  THEN
293             value        = -value
[667]294             value_ijk(1) = -value_ijk(1) - 10         !???
[1]295          ENDIF
296
297    END SELECT
298
299!
300!-- Limit index values to the range 0..nx, 0..ny
[667]301    IF ( value_ijk(3) < 0  ) value_ijk(3) = nx +1 + value_ijk(3)
302    IF ( value_ijk(3) > nx ) value_ijk(3) = value_ijk(3) - (nx+1)
303    IF ( value_ijk(2) < 0  ) value_ijk(2) = ny +1 + value_ijk(2)
304    IF ( value_ijk(2) > ny ) value_ijk(2) = value_ijk(2) - (ny+1)
[1]305
306
307 END SUBROUTINE global_min_max
Note: See TracBrowser for help on using the repository browser.