Changeset 4646 for palm/trunk/SOURCE/global_min_max.f90
- Timestamp:
- Aug 24, 2020 4:02:40 PM (4 years ago)
- File:
-
- 1 edited
-
palm/trunk/SOURCE/global_min_max.f90 (modified) (18 diffs)
Legend:
- Unmodified
- Added
- Removed
-
palm/trunk/SOURCE/global_min_max.f90
r4429 r4646 1 !> @file global_min_max.f90 2 !------------------------------------------------------------------------------! 1 !--------------------------------------------------------------------------------------------------! 3 2 ! This file is part of the PALM model system. 4 3 ! 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/>. 4 ! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General 5 ! Public License as published by the Free Software Foundation, either version 3 of the License, or 6 ! (at your option) any later version. 7 ! 8 ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the 9 ! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 10 ! Public License for more details. 11 ! 12 ! You should have received a copy of the GNU General Public License along with PALM. If not, see 13 ! <http://www.gnu.org/licenses/>. 16 14 ! 17 15 ! Copyright 1997-2020 Leibniz Universitaet Hannover 18 !------------------------------------------------------------------------------ !16 !--------------------------------------------------------------------------------------------------! 19 17 ! 20 18 ! Current revisions: 21 19 ! ------------------ 22 ! 23 ! 20 ! 21 ! 24 22 ! Former revisions: 25 23 ! ----------------- 26 24 ! $Id$ 25 ! file re-formatted to follow the PALM coding standard 26 ! 27 ! 4429 2020-02-27 15:24:30Z raasch 27 28 ! bugfix: cpp-directives added for serial mode 28 ! 29 ! 29 30 ! 4360 2020-01-07 11:25:50Z suehring 30 31 ! OpenACC support added 31 ! 32 ! 32 33 ! 4182 2019-08-22 15:20:23Z scharf 33 34 ! Corrected "Former revisions" section 34 ! 35 ! 35 36 ! 3655 2019-01-07 16:51:22Z knoop 36 37 ! Corrected "Former revisions" section … … 43 44 ! ------------ 44 45 !> Determine the array minimum/maximum and the corresponding indices. 45 !------------------------------------------------------------------------------ !46 SUBROUTINE global_min_max( i1, i2, j1, j2, k1, k2, ar, mode, offset, value, &47 value _ijk, value1, value1_ijk )48 49 50 USE indices, &46 !--------------------------------------------------------------------------------------------------! 47 SUBROUTINE global_min_max( i1, i2, j1, j2, k1, k2, ar, mode, offset, value, value_ijk, value1, & 48 value1_ijk ) 49 50 51 USE indices, & 51 52 ONLY: nbgp, ny, nx 52 53 53 54 USE kinds 54 55 55 56 USE pegrid 56 57 … … 72 73 INTEGER(iwp) :: k1 !< 73 74 INTEGER(iwp) :: k2 !< 74 INTEGER(iwp) :: fmax_ijk(3) !<75 INTEGER(iwp) :: fmax_ijk_l(3) !<76 INTEGER(iwp) :: fmin_ijk(3) !<77 INTEGER(iwp) :: fmin_ijk_l(3) !<78 75 INTEGER(iwp) :: value_ijk(3) !< 79 80 INTEGER(iwp), OPTIONAL :: value1_ijk(3) !< 81 82 REAL(wp) :: offset !< 83 REAL(wp) :: value !< 76 77 INTEGER(iwp), DIMENSION(3) :: fmax_ijk !< 78 INTEGER(iwp), DIMENSION(3) :: fmax_ijk_l !< 79 INTEGER(iwp), DIMENSION(3) :: fmin_ijk !< 80 INTEGER(iwp), DIMENSION(3) :: fmin_ijk_l !< 81 82 INTEGER(iwp), DIMENSION(3), OPTIONAL :: value1_ijk !< 83 84 REAL(wp) :: offset !< 85 REAL(wp) :: value !< 86 REAL(wp), OPTIONAL :: value1 !< 87 84 88 REAL(wp) :: ar(i1:i2,j1:j2,k1:k2) !< 85 89 86 90 #if defined( __ibm ) 87 91 REAL(sp) :: fmax(2) !< … … 89 93 REAL(sp) :: fmin(2) !< 90 94 REAL(sp) :: fmin_l(2) !< 91 ! on 32bit-machines MPI_2REAL must not be replaced 95 ! on 32bit-machines MPI_2REAL must not be replaced 92 96 ! by MPI_2DOUBLE_PRECISION 93 97 #else 94 REAL(wp) :: fmax(2) !< 95 REAL(wp) :: fmax_l(2) !< 96 REAL(wp) :: fmin(2) !< 97 REAL(wp) :: fmin_l(2) !< 98 #endif 98 REAL(wp), DIMENSION(2) :: fmax !< 99 REAL(wp), DIMENSION(2) :: fmax_l !< 100 REAL(wp), DIMENSION(2) :: fmin !< 101 REAL(wp), DIMENSION(2) :: fmin_l !< 102 #endif 103 99 104 #if defined( _OPENACC ) 105 INTEGER(iwp) :: count_eq !< counter for locations of maximum 100 106 REAL(wp) :: red !< scalar for reduction with OpenACC 101 INTEGER(iwp) :: count_eq !< counter for locations of maximum 102 #endif 103 REAL(wp), OPTIONAL :: value1 !< 107 #endif 104 108 105 109 … … 119 123 fmin_l(2) = myid 120 124 IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr ) 121 CALL MPI_ALLREDUCE( fmin_l, fmin, 1, MPI_2REAL, MPI_MINLOC, comm2d, & 122 ierr ) 125 CALL MPI_ALLREDUCE( fmin_l, fmin, 1, MPI_2REAL, MPI_MINLOC, comm2d, ierr ) 123 126 124 127 ! … … 127 130 IF ( id_fmin /= 0 ) THEN 128 131 IF ( myid == 0 ) THEN 129 CALL MPI_RECV( fmin_ijk, 3, MPI_INTEGER, id_fmin, 0, comm2d, & 130 status, ierr ) 132 CALL MPI_RECV( fmin_ijk, 3, MPI_INTEGER, id_fmin, 0, comm2d, status, ierr ) 131 133 ELSEIF ( myid == id_fmin ) THEN 132 134 CALL MPI_SEND( fmin_ijk_l, 3, MPI_INTEGER, 0, 0, comm2d, ierr ) … … 160 162 fmax_l(2) = myid 161 163 IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr ) 162 CALL MPI_ALLREDUCE( fmax_l, fmax, 1, MPI_2REAL, MPI_MAXLOC, comm2d, & 163 ierr ) 164 CALL MPI_ALLREDUCE( fmax_l, fmax, 1, MPI_2REAL, MPI_MAXLOC, comm2d, ierr ) 164 165 165 166 ! … … 168 169 IF ( id_fmax /= 0 ) THEN 169 170 IF ( myid == 0 ) THEN 170 CALL MPI_RECV( fmax_ijk, 3, MPI_INTEGER, id_fmax, 0, comm2d, & 171 status, ierr ) 171 CALL MPI_RECV( fmax_ijk, 3, MPI_INTEGER, id_fmax, 0, comm2d, status, ierr ) 172 172 ELSEIF ( myid == id_fmax ) THEN 173 173 CALL MPI_SEND( fmax_ijk_l, 3, MPI_INTEGER, 0, 0, comm2d, ierr ) … … 177 177 ENDIF 178 178 ! 179 !-- send the indices of the just determined array maximum to other PEs179 !-- Send the indices of the just determined array maximum to other PEs 180 180 CALL MPI_BCAST( fmax_ijk, 3, MPI_INTEGER, 0, comm2d, ierr ) 181 181 #else … … 226 226 IF ( count_eq == 1 ) THEN 227 227 ! 228 !-- We found a single maximum element and correctly got its position. Transfer its 229 !-- value tohandle the negative case correctly.228 !-- We found a single maximum element and correctly got its position. Transfer its value to 229 !-- handle the negative case correctly. 230 230 !$ACC UPDATE HOST(ar(fmax_ijk_l(1):fmax_ijk_l(1),fmax_ijk_l(2),fmax_ijk_l(3))) 231 231 ELSE … … 257 257 #if defined( _OPENACC ) 258 258 ! 259 !-- 259 !-- Close ELSE case from above 260 260 ENDIF 261 261 #endif … … 263 263 ! 264 264 !-- Set a flag in case that the determined value is negative. 265 !-- A constant offset has to be subtracted in order to handle the special 266 !-- case i=0 correctly 265 !-- A constant offset has to be subtracted in order to handle the special case i=0 correctly. 267 266 IF ( ar(fmax_ijk_l(1),fmax_ijk_l(2),fmax_ijk_l(3)) < 0.0_wp ) THEN 268 267 fmax_ijk_l(1) = -fmax_ijk_l(1) - 10 … … 272 271 fmax_l(2) = myid 273 272 IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr ) 274 CALL MPI_ALLREDUCE( fmax_l, fmax, 1, MPI_2REAL, MPI_MAXLOC, comm2d, & 275 ierr ) 273 CALL MPI_ALLREDUCE( fmax_l, fmax, 1, MPI_2REAL, MPI_MAXLOC, comm2d, ierr ) 276 274 277 275 ! … … 280 278 IF ( id_fmax /= 0 ) THEN 281 279 IF ( myid == 0 ) THEN 282 CALL MPI_RECV( fmax_ijk, 3, MPI_INTEGER, id_fmax, 0, comm2d, & 283 status, ierr ) 280 CALL MPI_RECV( fmax_ijk, 3, MPI_INTEGER, id_fmax, 0, comm2d, status, ierr ) 284 281 ELSEIF ( myid == id_fmax ) THEN 285 282 CALL MPI_SEND( fmax_ijk_l, 3, MPI_INTEGER, 0, 0, comm2d, ierr ) … … 311 308 DO j = j1, j2 312 309 ! 313 !-- Attention: the lowest gridpoint is excluded here, because there 314 !-- --------- is no advection at nzb=0 and mode 'absoff' is only315 !-- used for calculating u,v extrema for CFL-criteria310 !-- Attention: the lowest gridpoint is excluded here, because there is no advection at 311 !-- ---------- nzb=0 and mode 'absoff' is only used for calculating u,v extrema for 312 !-- CFL-criteria. 316 313 DO i = i1+1, i2 317 314 IF ( ABS( ar(i,j,k) - offset ) > fmax_l(1) ) THEN … … 327 324 ! 328 325 !-- Set a flag in case that the determined value is negative. 329 !-- A constant offset has to be subtracted in order to handle the special 330 !-- case i=0 correctly 326 !-- A constant offset has to be subtracted in order to handle the special case i=0 correctly. 331 327 IF ( ar(fmax_ijk_l(1),fmax_ijk_l(2),fmax_ijk_l(3)) < 0.0_wp ) THEN 332 328 fmax_ijk_l(1) = -fmax_ijk_l(1) - 10 … … 336 332 fmax_l(2) = myid 337 333 IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr ) 338 CALL MPI_ALLREDUCE( fmax_l, fmax, 1, MPI_2REAL, MPI_MAXLOC, comm2d, & 339 ierr ) 334 CALL MPI_ALLREDUCE( fmax_l, fmax, 1, MPI_2REAL, MPI_MAXLOC, comm2d, ierr ) 340 335 341 336 ! … … 344 339 IF ( id_fmax /= 0 ) THEN 345 340 IF ( myid == 0 ) THEN 346 CALL MPI_RECV( fmax_ijk, 3, MPI_INTEGER, id_fmax, 0, comm2d, & 347 status, ierr ) 341 CALL MPI_RECV( fmax_ijk, 3, MPI_INTEGER, id_fmax, 0, comm2d, status, ierr ) 348 342 ELSEIF ( myid == id_fmax ) THEN 349 343 CALL MPI_SEND( fmax_ijk_l, 3, MPI_INTEGER, 0, 0, comm2d, ierr )
Note: See TracChangeset
for help on using the changeset viewer.
