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

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

last commit documented

  • Property svn:keywords set to Id
File size: 9.1 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! Current revisions:
6! ------------------
7!
8!
9! Former revisions:
10! -----------------
11! $Id: global_min_max.f90 867 2012-03-28 06:54:50Z raasch $
12!
13! 866 2012-03-28 06:44:41Z raasch
14! new mode "absoff" accounts for an offset in the respective array
15!
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!
20! 622 2010-12-10 08:08:13Z raasch
21! optional barriers included in order to speed up collective operations
22!
23! Feb. 2007
24! RCS Log replace by Id keyword, revision history cleaned up
25!
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.
36!------------------------------------------------------------------------------!
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)
49    REAL              ::  offset, value, &
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 )
68       fmin_ijk_l(1) = i1 + fmin_ijk_l(1) - nbgp ! MINLOC assumes lowerbound = 1
69       fmin_ijk_l(2) = j1 + fmin_ijk_l(2) - nbgp
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
75       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
76       CALL MPI_ALLREDUCE( fmin_l, fmin, 1, MPI_2REAL, MPI_MINLOC, comm2d, &
77                           ierr )
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 )
109       fmax_ijk_l(1) = i1 + fmax_ijk_l(1) - nbgp ! MAXLOC assumes lowerbound = 1
110       fmax_ijk_l(2) = j1 + fmax_ijk_l(2) - nbgp
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
116       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
117       CALL MPI_ALLREDUCE( fmax_l, fmax, 1, MPI_2REAL, MPI_MAXLOC, comm2d, &
118                           ierr )
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
176       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
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!
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!
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
288       CASE( 'abs', 'absoff' )
289
290          value     = fmax(1)
291          value_ijk = fmax_ijk
292          IF ( fmax_ijk(1) < 0 )  THEN
293             value        = -value
294             value_ijk(1) = -value_ijk(1) - 10         !???
295          ENDIF
296
297    END SELECT
298
299!
300!-- Limit index values to the range 0..nx, 0..ny
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)
305
306
307 END SUBROUTINE global_min_max
Note: See TracBrowser for help on using the repository browser.