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

Last change on this file since 4 was 4, checked in by raasch, 18 years ago

Id keyword set as property for all *.f90 files

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