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

Last change on this file since 623 was 623, checked in by raasch, 11 years ago

last commit documented

  • Property svn:keywords set to Id
File size: 6.8 KB
Line 
1 SUBROUTINE global_min_max( i1, i2, j1, j2, k1, k2, ar, mode, 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 623 2010-12-10 08:52:17Z raasch $
12!
13! 622 2010-12-10 08:08:13Z raasch
14! optional barriers included in order to speed up collective operations
15!
16! Feb. 2007
17! RCS Log replace by Id keyword, revision history cleaned up
18!
19! Revision 1.11  2003/04/16 12:56:58  raasch
20! Index values of the extrema are limited to the range 0..nx, 0..ny
21!
22! Revision 1.1  1997/07/24 11:14:03  raasch
23! Initial revision
24!
25!
26! Description:
27! ------------
28! Determine the array minimum/maximum and the corresponding indices.
29!------------------------------------------------------------------------------!
30
31    USE indices
32    USE pegrid
33
34    IMPLICIT NONE
35
36    CHARACTER (LEN=*) ::  mode
37
38    INTEGER           ::  i, i1, i2, id_fmax, id_fmin, j, j1, j2, k, k1, k2, &
39                          fmax_ijk(3), fmax_ijk_l(3), fmin_ijk(3), &
40                          fmin_ijk_l(3), value_ijk(3)
41    INTEGER, OPTIONAL ::  value1_ijk(3)
42    REAL              ::  value, &
43                          ar(i1:i2,j1:j2,k1:k2)
44#if defined( __ibm )
45    REAL (KIND=4)     ::  fmax(2), fmax_l(2), fmin(2), fmin_l(2)  ! on 32bit-
46                          ! machines MPI_2REAL must not be replaced by
47                          ! MPI_2DOUBLE_PRECISION
48#else
49    REAL              ::  fmax(2), fmax_l(2), fmin(2), fmin_l(2)
50#endif
51    REAL, OPTIONAL    ::  value1
52
53
54!
55!-- Determine array minimum
56    IF ( mode == 'min'  .OR.  mode == 'minmax' )  THEN
57
58!
59!--    Determine the local minimum
60       fmin_ijk_l = MINLOC( ar )
61       fmin_ijk_l(1) = i1 + fmin_ijk_l(1) - 1    ! MINLOC assumes lowerbound = 1
62       fmin_ijk_l(2) = j1 + fmin_ijk_l(2) - 1
63       fmin_ijk_l(3) = k1 + fmin_ijk_l(3) - 1
64       fmin_l(1)  = ar(fmin_ijk_l(1),fmin_ijk_l(2),fmin_ijk_l(3))
65
66#if defined( __parallel )
67       fmin_l(2)  = myid
68       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
69       CALL MPI_ALLREDUCE( fmin_l, fmin, 1, MPI_2REAL, MPI_MINLOC, comm2d, &
70                           ierr )
71
72!
73!--    Determine the global minimum. Result stored on PE0.
74       id_fmin = fmin(2)
75       IF ( id_fmin /= 0 )  THEN
76          IF ( myid == 0 )  THEN
77             CALL MPI_RECV( fmin_ijk, 3, MPI_INTEGER, id_fmin, 0, comm2d, &
78                            status, ierr )
79          ELSEIF ( myid == id_fmin )  THEN
80             CALL MPI_SEND( fmin_ijk_l, 3, MPI_INTEGER, 0, 0, comm2d, ierr )
81          ENDIF
82       ELSE
83          fmin_ijk = fmin_ijk_l
84       ENDIF
85!
86!--    Send the indices of the just determined array minimum to other PEs
87       CALL MPI_BCAST( fmin_ijk, 3, MPI_INTEGER, 0, comm2d, ierr )
88#else
89       fmin(1)  = fmin_l(1)
90       fmin_ijk = fmin_ijk_l
91#endif
92
93    ENDIF
94
95!
96!-- Determine array maximum
97    IF ( mode == 'max'  .OR.  mode == 'minmax' )  THEN
98
99!
100!--    Determine the local maximum
101       fmax_ijk_l = MAXLOC( ar )
102       fmax_ijk_l(1) = i1 + fmax_ijk_l(1) - 1    ! MAXLOC assumes lowerbound = 1
103       fmax_ijk_l(2) = j1 + fmax_ijk_l(2) - 1
104       fmax_ijk_l(3) = k1 + fmax_ijk_l(3) - 1
105       fmax_l(1) = ar(fmax_ijk_l(1),fmax_ijk_l(2),fmax_ijk_l(3))
106
107#if defined( __parallel )
108       fmax_l(2)  = myid
109       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
110       CALL MPI_ALLREDUCE( fmax_l, fmax, 1, MPI_2REAL, MPI_MAXLOC, comm2d, &
111                           ierr )
112
113!
114!--    Determine the global maximum. Result stored on PE0.
115       id_fmax = fmax(2)
116       IF ( id_fmax /= 0 )  THEN
117          IF ( myid == 0 )  THEN
118             CALL MPI_RECV( fmax_ijk, 3, MPI_INTEGER, id_fmax, 0, comm2d, &
119                            status, ierr )
120          ELSEIF ( myid == id_fmax )  THEN
121             CALL MPI_SEND( fmax_ijk_l, 3, MPI_INTEGER, 0, 0, comm2d, ierr )
122          ENDIF
123       ELSE
124          fmax_ijk = fmax_ijk_l
125       ENDIF
126!
127!--    send the indices of the just determined array maximum to other PEs
128       CALL MPI_BCAST( fmax_ijk, 3, MPI_INTEGER, 0, comm2d, ierr )
129#else
130       fmax(1)  = fmax_l(1)
131       fmax_ijk = fmax_ijk_l
132#endif
133
134    ENDIF
135
136!
137!-- Determine absolute array maximum
138    IF ( mode == 'abs' )  THEN
139
140!
141!--    Determine the local absolut maximum
142       fmax_l(1)     = 0.0
143       fmax_ijk_l(1) =  i1
144       fmax_ijk_l(2) =  j1
145       fmax_ijk_l(3) =  k1
146       DO  k = k1, k2
147          DO  j = j1, j2
148             DO  i = i1, i2
149                IF ( ABS( ar(i,j,k) ) > fmax_l(1) )  THEN
150                   fmax_l(1) = ABS( ar(i,j,k) )
151                   fmax_ijk_l(1) = i
152                   fmax_ijk_l(2) = j
153                   fmax_ijk_l(3) = k
154                ENDIF
155             ENDDO
156          ENDDO
157       ENDDO
158
159!
160!--    Set a flag in case that the determined value is negative.
161!--    A constant offset has to be subtracted in order to handle the special
162!--    case i=0 correctly
163       IF ( ar(fmax_ijk_l(1),fmax_ijk_l(2),fmax_ijk_l(3)) < 0.0 )  THEN
164          fmax_ijk_l(1) = -fmax_ijk_l(1) - 10
165       ENDIF
166
167#if defined( __parallel )
168       fmax_l(2)  = myid
169       IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
170       CALL MPI_ALLREDUCE( fmax_l, fmax, 1, MPI_2REAL, MPI_MAXLOC, comm2d, &
171                           ierr )
172
173!
174!--    Determine the global absolut maximum. Result stored on PE0.
175       id_fmax = fmax(2)
176       IF ( id_fmax /= 0 )  THEN
177          IF ( myid == 0 )  THEN
178             CALL MPI_RECV( fmax_ijk, 3, MPI_INTEGER, id_fmax, 0, comm2d, &
179                            status, ierr )
180          ELSEIF ( myid == id_fmax )  THEN
181             CALL MPI_SEND( fmax_ijk_l, 3, MPI_INTEGER, 0, 0, comm2d, ierr )
182          ENDIF
183       ELSE
184          fmax_ijk = fmax_ijk_l
185       ENDIF
186!
187!--    Send the indices of the just determined absolut maximum to other PEs
188       CALL MPI_BCAST( fmax_ijk, 3, MPI_INTEGER, 0, comm2d, ierr )
189#else
190       fmax(1)  = fmax_l(1)
191       fmax_ijk = fmax_ijk_l
192#endif
193
194    ENDIF
195
196!
197!-- Determine output parameters
198    SELECT CASE( mode )
199
200       CASE( 'min' )
201
202          value     = fmin(1)
203          value_ijk = fmin_ijk
204
205       CASE( 'max' )
206
207          value     = fmax(1)
208          value_ijk = fmax_ijk
209
210       CASE( 'minmax' )
211
212          value      = fmin(1)
213          value_ijk  = fmin_ijk
214          value1     = fmax(1)
215          value1_ijk = fmax_ijk
216
217       CASE( 'abs' )
218
219          value     = fmax(1)
220          value_ijk = fmax_ijk
221          IF ( fmax_ijk(1) < 0 )  THEN
222             value        = -value
223             value_ijk(1) = -value_ijk(1) - 10
224          ENDIF
225
226    END SELECT
227
228!
229!-- Limit index values to the range 0..nx, 0..ny
230    IF ( value_ijk(3) ==   -1 )  value_ijk(3) = nx
231    IF ( value_ijk(3) == nx+1 )  value_ijk(3) =  0
232    IF ( value_ijk(2) ==   -1 )  value_ijk(2) = ny
233    IF ( value_ijk(2) == ny+1 )  value_ijk(2) =  0
234
235
236 END SUBROUTINE global_min_max
Note: See TracBrowser for help on using the repository browser.