- Timestamp:
- 2010-10-29T09:39:51+02:00 (13 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/nemo_v3_3_beta/NEMOGCM/NEMO/OPA_SRC/OBS/obs_mpp.F90
r2287 r2335 1 #if defined key_mpp_mpi2 #if defined key_sp3 #define mpivar mpi_real4 #else5 #define mpivar mpi_double_precision6 #endif7 #endif8 1 MODULE obs_mpp 9 2 !!====================================================================== … … 11 4 !! Observation diagnostics: Various MPP support routines 12 5 !!====================================================================== 13 6 !! History : 2.0 ! 2006-03 (K. Mogensen) Original code 7 !! - ! 2006-05 (K. Mogensen) Reformatted 8 !! - ! 2008-01 (K. Mogensen) add mpp_global_max 14 9 !!---------------------------------------------------------------------- 15 !! obs_mpp_bcast_integer : Broadcast an integer array from a processor 16 !! to all processors 17 !! obs_mpp_max_integer : Find maximum on all processors of each 18 !! value in an integer on all processors 10 #if defined key_mpp_mpi 11 # if defined key_sp 12 # define mpivar mpi_real 13 # else 14 # define mpivar mpi_double_precision 15 # endif 16 #endif 17 !!---------------------------------------------------------------------- 18 !! obs_mpp_bcast_integer : Broadcast an integer array from a processor to all processors 19 !! obs_mpp_max_integer : Find maximum on all processors of each value in an integer on all processors 19 20 !! obs_mpp_find_obs_proc : Find processors which should hold the observations 20 21 !! obs_mpp_sum_integers : Sum an integer array from all processors 21 22 !! obs_mpp_sum_integer : Sum an integer from all processors 22 23 !!---------------------------------------------------------------------- 23 !! * Modules used 24 USE dom_oce, ONLY : & ! Ocean space and time domain variables 25 & nproc, & 26 & mig,mjg 27 USE mpp_map, ONLY : & 28 & mppmap 24 USE dom_oce, ONLY : nproc, mig, mjg ! Ocean space and time domain variables 25 USE mpp_map, ONLY : mppmap 29 26 USE in_out_manager 30 27 #if defined key_mpp_mpi 31 USE lib_mpp, ONLY : & ! MPP library 32 & mpi_comm_opa 28 USE lib_mpp, ONLY : mpi_comm_opa ! MPP library 33 29 #endif 34 30 IMPLICIT NONE 35 36 !! * Routine accessibility37 31 PRIVATE 38 32 39 PUBLIC obs_mpp_bcast_integer, & ! Broadcast an integer array from a proc to all procs40 & obs_mpp_max_integer, & ! Find maximum across processors in an integer array41 & obs_mpp_find_obs_proc, & ! Find processors which should hold the observations42 & obs_mpp_sum_integers, & ! Sum an integer array from all processors43 & obs_mpp_sum_integer, & ! Sum an integer from all processors33 PUBLIC obs_mpp_bcast_integer, & !: Broadcast an integer array from a proc to all procs 34 & obs_mpp_max_integer, & !: Find maximum across processors in an integer array 35 & obs_mpp_find_obs_proc, & !: Find processors which should hold the observations 36 & obs_mpp_sum_integers, & !: Sum an integer array from all processors 37 & obs_mpp_sum_integer, & !: Sum an integer from all processors 44 38 & mpp_alltoall_int, & 45 39 & mpp_alltoallv_int, & … … 50 44 !! NEMO/OPA 3.3 , NEMO Consortium (2010) 51 45 !! $Id$ 52 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt)46 !! Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 53 47 !!---------------------------------------------------------------------- 54 55 48 CONTAINS 56 49 57 SUBROUTINE obs_mpp_bcast_integer( kvals,kno,kroot)50 SUBROUTINE obs_mpp_bcast_integer( kvals, kno, kroot ) 58 51 !!---------------------------------------------------------------------- 59 52 !! *** ROUTINE obs_mpp_bcast_integer *** … … 64 57 !! 65 58 !! ** Action : This does only work for MPI. 66 !! It does not work for SHMEM.67 59 !! MPI_COMM_OPA needs to be replace for OASIS4.! 68 60 !! 69 61 !! References : http://www.mpi-forum.org 70 !! 71 !! History : 72 !! ! 06-03 (K. Mogensen) Original code 73 !! ! 06-05 (K. Mogensen) Reformatted 74 !!---------------------------------------------------------------------- 75 76 !! * Arguments 77 INTEGER, INTENT(IN) :: kno ! Number of elements in array 78 INTEGER, INTENT(IN) :: kroot ! Processor to send data 79 INTEGER, DIMENSION(kno), INTENT(INOUT) :: & 80 & kvals ! Array to send on kroot, receive for non-kroot 62 !!---------------------------------------------------------------------- 63 INTEGER , INTENT(in ) :: kno ! Number of elements in array 64 INTEGER , INTENT(in ) :: kroot ! Processor to send data 65 INTEGER, DIMENSION(kno), INTENT(inout) :: kvals ! Array to send on kroot, receive for non-kroot 66 !! 67 #if defined key_mpp_mpi 68 INTEGER :: ierr 69 INCLUDE 'mpif.h' 70 !!---------------------------------------------------------------------- 71 72 ! Call the MPI library to broadcast data 73 CALL mpi_bcast( kvals, kno, mpi_integer, & 74 & kroot, mpi_comm_opa, ierr ) 75 #else 76 ! no MPI: empty routine 77 #endif 78 ! 79 END SUBROUTINE obs_mpp_bcast_integer 80 81 81 82 #if defined key_mpp_mpi83 !! * Local declarations84 INTEGER :: ierr85 INCLUDE 'mpif.h'86 87 !-----------------------------------------------------------------------88 ! Call the MPI library to broadcast data89 !-----------------------------------------------------------------------90 CALL mpi_bcast( kvals, kno, mpi_integer, &91 & kroot, mpi_comm_opa, ierr )92 #elif defined key_mpp_shmem93 error "Only MPI support for MPP in NEMOVAR"94 #endif95 96 END SUBROUTINE obs_mpp_bcast_integer97 98 82 SUBROUTINE obs_mpp_max_integer( kvals, kno ) 99 83 !!---------------------------------------------------------------------- … … 109 93 !! 110 94 !! References : http://www.mpi-forum.org 111 !! 112 !! History : 113 !! ! 06-03 (K. Mogensen) Original code 114 !! ! 06-05 (K. Mogensen) Reformatted 115 !!---------------------------------------------------------------------- 116 117 !! * Arguments 118 INTEGER, INTENT(IN) ::kno ! Number of elements in array 119 INTEGER, DIMENSION(kno), INTENT(INOUT) :: & 120 & kvals ! Array to send on kroot, receive for non-kroot 121 122 #if defined key_mpp_mpi 123 !! * Local declarations 124 INTEGER :: ierr 125 INTEGER, DIMENSION(kno) :: & 126 & ivals 127 INCLUDE 'mpif.h' 128 129 !----------------------------------------------------------------------- 95 !!---------------------------------------------------------------------- 96 INTEGER , INTENT(in ) :: kno ! Number of elements in array 97 INTEGER, DIMENSION(kno), INTENT(inout) :: kvals ! Array to send on kroot, receive for non-kroot 98 !! 99 #if defined key_mpp_mpi 100 INTEGER :: ierr 101 INTEGER, DIMENSION(kno) :: ivals 102 INCLUDE 'mpif.h' 103 !!---------------------------------------------------------------------- 104 130 105 ! Call the MPI library to find the maximum across processors 131 !----------------------------------------------------------------------- 132 CALL mpi_allreduce( kvals, ivals, kno, mpi_integer, & 106 CALL mpi_allreduce( kvals, ivals, kno, mpi_integer, & 133 107 & mpi_max, mpi_comm_opa, ierr ) 134 108 kvals(:) = ivals(:) 135 #el if defined key_mpp_shmem136 error "Only MPI support for MPP in NEMOVAR" 109 #else 110 ! no MPI: empty routine 137 111 #endif 138 112 END SUBROUTINE obs_mpp_max_integer 139 113 140 SUBROUTINE obs_mpp_find_obs_proc(kobsp,kobsi,kobsj,kno) 114 115 SUBROUTINE obs_mpp_find_obs_proc( kobsp, kobsi, kobsj, kno ) 141 116 !!---------------------------------------------------------------------- 142 117 !! *** ROUTINE obs_mpp_find_obs_proc *** … … 155 130 !! 156 131 !! References : http://www.mpi-forum.org 157 !! 158 !! History : 159 !! ! 06-07 (K. Mogensen) Original code 160 !!---------------------------------------------------------------------- 161 162 !! * Arguments 163 INTEGER, INTENT(IN) :: kno 164 INTEGER, DIMENSION(kno), INTENT(IN) :: & 165 & kobsi, & 166 & kobsj 167 INTEGER, DIMENSION(kno), INTENT(INOUT) :: & 168 & kobsp 169 170 #if defined key_mpp_mpi 171 !! * Local declarations 132 !!---------------------------------------------------------------------- 133 INTEGER , INTENT(in ) :: kno 134 INTEGER, DIMENSION(kno), INTENT(in ) :: kobsi, kobsj 135 INTEGER, DIMENSION(kno), INTENT(inout) :: kobsp 136 !! 137 #if defined key_mpp_mpi 172 138 INTEGER :: ji 173 139 INTEGER :: jj … … 177 143 INTEGER :: iobsjp 178 144 INTEGER :: num_sus_obs 179 INTEGER, DIMENSION(kno) :: & 180 & iobsig, & 181 & iobsjg 182 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: & 183 & iobsp, iobsi, iobsj 184 185 INCLUDE 'mpif.h' 145 INTEGER, DIMENSION(kno) :: iobsig, iobsjg 146 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iobsp, iobsi, iobsj 147 !! 148 INCLUDE 'mpif.h' 149 !!---------------------------------------------------------------------- 186 150 187 151 !----------------------------------------------------------------------- … … 258 222 DEALLOCATE( iobsi ) 259 223 DEALLOCATE( iobsp ) 260 #el if defined key_mpp_shmem261 error "Only MPI support for MPP in NEMOVAR" 262 #endif 263 224 #else 225 ! no MPI: empty routine 226 #endif 227 ! 264 228 END SUBROUTINE obs_mpp_find_obs_proc 265 229 230 266 231 SUBROUTINE obs_mpp_sum_integers( kvalsin, kvalsout, kno ) 267 232 !!---------------------------------------------------------------------- … … 276 241 !! 277 242 !! References : http://www.mpi-forum.org 278 !! 279 !! History : 280 !! ! 06-07 (K. Mogensen) Original code 281 !!---------------------------------------------------------------------- 282 283 !! * Arguments 284 INTEGER, INTENT(IN) :: kno 285 INTEGER, DIMENSION(kno), INTENT(IN) :: & 286 & kvalsin 287 INTEGER, DIMENSION(kno), INTENT(OUT) :: & 288 & kvalsout 289 290 #if defined key_mpp_mpi 291 !! * Local declarations 292 INTEGER :: ierr 293 INCLUDE 'mpif.h' 294 243 !!---------------------------------------------------------------------- 244 INTEGER , INTENT(in ) :: kno 245 INTEGER, DIMENSION(kno), INTENT(in ) :: kvalsin 246 INTEGER, DIMENSION(kno), INTENT( out) :: kvalsout 247 !! 248 #if defined key_mpp_mpi 249 INTEGER :: ierr 250 !! 251 INCLUDE 'mpif.h' 252 !!---------------------------------------------------------------------- 253 ! 295 254 !----------------------------------------------------------------------- 296 255 ! Call the MPI library to find the sum across processors … … 298 257 CALL mpi_allreduce( kvalsin, kvalsout, kno, mpi_integer, & 299 258 & mpi_sum, mpi_comm_opa, ierr ) 300 #elif defined key_mpp_shmem 301 error "Only MPI support for MPP in NEMOVAR" 302 #else 303 259 #else 304 260 !----------------------------------------------------------------------- 305 261 ! For no-MPP just return input values … … 307 263 kvalsout(:) = kvalsin(:) 308 264 #endif 309 265 ! 310 266 END SUBROUTINE obs_mpp_sum_integers 311 267 268 312 269 SUBROUTINE obs_mpp_sum_integer( kvalin, kvalout ) 313 270 !!---------------------------------------------------------------------- … … 322 279 !! 323 280 !! References : http://www.mpi-forum.org 324 !! 325 !! History : 326 !! ! 06-07 (K. Mogensen) Original code 327 !!---------------------------------------------------------------------- 328 329 !! * Arguments 330 INTEGER, INTENT(IN) :: kvalin 331 INTEGER, INTENT(OUT) :: kvalout 332 333 #if defined key_mpp_mpi 334 !! * Local declarations 335 INTEGER :: ierr 336 INCLUDE 'mpif.h' 337 281 !!---------------------------------------------------------------------- 282 INTEGER, INTENT(in ) :: kvalin 283 INTEGER, INTENT( out) :: kvalout 284 !! 285 #if defined key_mpp_mpi 286 INTEGER :: ierr 287 !! 288 INCLUDE 'mpif.h' 289 !!---------------------------------------------------------------------- 290 ! 338 291 !----------------------------------------------------------------------- 339 292 ! Call the MPI library to find the sum across processors 340 293 !----------------------------------------------------------------------- 341 CALL mpi_allreduce( kvalin, kvalout, 1, mpi_integer, &294 CALL mpi_allreduce( kvalin, kvalout, 1, mpi_integer, & 342 295 & mpi_sum, mpi_comm_opa, ierr ) 343 #elif defined key_mpp_shmem 344 error "Only MPI support for MPP in NEMOVAR" 345 #else 346 296 #else 347 297 !----------------------------------------------------------------------- 348 298 ! For no-MPP just return input values … … 350 300 kvalout = kvalin 351 301 #endif 302 ! 352 303 END SUBROUTINE obs_mpp_sum_integer 304 353 305 354 306 SUBROUTINE mpp_global_max( pval ) … … 365 317 !! 366 318 !! References : http://www.mpi-forum.org 367 !! 368 !! History : 369 !! ! 08-01 (K. Mogensen) Original code 370 !!---------------------------------------------------------------------- 371 372 !! * Arguments 373 REAL(KIND=wp), DIMENSION(jpiglo,jpjglo), INTENT(INOUT) :: & 374 & pval 375 !! * Local declarations 376 INTEGER :: ierr 377 #if defined key_mpp_mpi 378 INCLUDE 'mpif.h' 379 REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: & 380 & zcp 319 !!---------------------------------------------------------------------- 320 REAL(KIND=wp), DIMENSION(jpiglo,jpjglo), INTENT(inout) :: pval 321 !! 322 INTEGER :: ierr 323 #if defined key_mpp_mpi 324 INCLUDE 'mpif.h' 325 REAL(KIND=wp), DIMENSION(:,:), ALLOCATABLE :: zcp 326 !!---------------------------------------------------------------------- 381 327 382 328 ! Copy data for input to MPI … … 396 342 & ) 397 343 398 #el if defined key_mpp_shmem399 error "Only MPI support for MPP in NEMOVAR" 400 #endif 401 344 #else 345 ! no MPI: empty routine 346 #endif 347 ! 402 348 END SUBROUTINE mpp_global_max 403 349 350 404 351 SUBROUTINE mpp_alltoall_int( kno, kvalsin, kvalsout ) 405 352 !!---------------------------------------------------------------------- … … 414 361 !! 415 362 !! References : http://www.mpi-forum.org 416 !! 417 !! History : 418 !! ! 06-09 (K. Mogensen) Original code 419 !!---------------------------------------------------------------------- 420 421 !! * Arguments 422 INTEGER, INTENT(IN) :: kno 423 INTEGER, DIMENSION(kno*jpnij), INTENT(IN) :: & 424 & kvalsin 425 INTEGER, DIMENSION(kno*jpnij), INTENT(OUT) :: & 426 & kvalsout 427 !! * Local declarations 363 !!---------------------------------------------------------------------- 364 INTEGER , INTENT(in ) :: kno 365 INTEGER, DIMENSION(kno*jpnij), INTENT(in ) :: kvalsin 366 INTEGER, DIMENSION(kno*jpnij), INTENT( out) :: kvalsout 367 !! 428 368 INTEGER :: ierr 429 369 #if defined key_mpp_mpi … … 435 375 & kvalsout, kno, mpi_integer, & 436 376 & mpi_comm_opa, ierr ) 437 #elif defined key_mpp_shmem438 error "Only MPI support for MPP in NEMOVAR"439 377 #else 440 378 !----------------------------------------------------------------------- … … 443 381 kvalsout = kvalsin 444 382 #endif 445 383 ! 446 384 END SUBROUTINE mpp_alltoall_int 447 385 448 SUBROUTINE mpp_alltoallv_int( kvalsin, knoin, kinv, kvalsout, & 449 & knoout, koutv ) 386 387 SUBROUTINE mpp_alltoallv_int( kvalsin, knoin , kinv , kvalsout, & 388 & knoout, koutv ) 450 389 !!---------------------------------------------------------------------- 451 390 !! *** ROUTINE mpp_alltoallv_int *** … … 459 398 !! 460 399 !! References : http://www.mpi-forum.org 461 !! 462 !! History : 463 !! ! 06-09 (K. Mogensen) Original code 464 !!---------------------------------------------------------------------- 465 466 !! * Arguments 467 INTEGER, INTENT(IN) :: knoin 468 INTEGER, INTENT(IN) :: knoout 469 INTEGER, DIMENSION(jpnij) :: & 470 & kinv, & 471 & koutv 472 INTEGER, DIMENSION(knoin), INTENT(IN) :: & 473 & kvalsin 474 INTEGER, DIMENSION(knoout), INTENT(OUT) :: & 475 & kvalsout 476 !! * Local declarations 400 !!---------------------------------------------------------------------- 401 INTEGER , INTENT(in) :: knoin 402 INTEGER , INTENT(in) :: knoout 403 INTEGER, DIMENSION(jpnij) :: kinv, koutv 404 INTEGER, DIMENSION(knoin) , INTENT(in ) :: kvalsin 405 INTEGER, DIMENSION(knoout), INTENT( out) :: kvalsout 406 !! 477 407 INTEGER :: ierr 478 408 INTEGER :: jproc 479 409 #if defined key_mpp_mpi 480 410 INCLUDE 'mpif.h' 481 INTEGER, DIMENSION(jpnij) :: & 482 & irdsp, & 483 & isdsp 411 INTEGER, DIMENSION(jpnij) :: irdsp, isdsp 484 412 !----------------------------------------------------------------------- 485 413 ! Compute displacements … … 497 425 & kvalsout, koutv, irdsp, mpi_integer, & 498 426 & mpi_comm_opa, ierr ) 499 #elif defined key_mpp_shmem500 error "Only MPI support for MPP in NEMOVAR"501 427 #else 502 428 !----------------------------------------------------------------------- … … 505 431 kvalsout = kvalsin 506 432 #endif 507 433 ! 508 434 END SUBROUTINE mpp_alltoallv_int 509 435 510 SUBROUTINE mpp_alltoallv_real( pvalsin, knoin, kinv, pvalsout, & 511 & knoout, koutv ) 436 437 SUBROUTINE mpp_alltoallv_real( pvalsin, knoin , kinv , pvalsout, & 438 & knoout, koutv ) 512 439 !!---------------------------------------------------------------------- 513 440 !! *** ROUTINE mpp_alltoallv_real *** … … 521 448 !! 522 449 !! References : http://www.mpi-forum.org 523 !! 524 !! History : 525 !! ! 06-09 (K. Mogensen) Original code 526 !!---------------------------------------------------------------------- 527 528 !! * Arguments 529 INTEGER, INTENT(IN) :: knoin 530 INTEGER, INTENT(IN) :: knoout 531 INTEGER, DIMENSION(jpnij) :: & 532 & kinv, & 533 & koutv 534 REAL(KIND=wp), DIMENSION(knoin), INTENT(IN) :: & 535 & pvalsin 536 REAL(KIND=wp), DIMENSION(knoout), INTENT(OUT) :: & 537 & pvalsout 538 !! * Local declarations 450 !!---------------------------------------------------------------------- 451 INTEGER , INTENT(in ) :: knoin 452 INTEGER , INTENT(in ) :: knoout 453 INTEGER , DIMENSION(jpnij) :: kinv, koutv 454 REAL(wp), DIMENSION(knoin) , INTENT(in ) :: pvalsin 455 REAL(wp), DIMENSION(knoout), INTENT( out) :: pvalsout 456 !! 539 457 INTEGER :: ierr 540 458 INTEGER :: jproc 541 459 #if defined key_mpp_mpi 542 460 INCLUDE 'mpif.h' 543 INTEGER, DIMENSION(jpnij) :: &544 & irdsp, &545 & isdsp461 INTEGER, DIMENSION(jpnij) :: irdsp, isdsp 462 !!---------------------------------------------------------------------- 463 ! 546 464 !----------------------------------------------------------------------- 547 465 ! Compute displacements … … 559 477 & pvalsout, koutv, irdsp, mpivar, & 560 478 & mpi_comm_opa, ierr ) 561 #elif defined key_mpp_shmem562 error "Only MPI support for MPP in NEMOVAR"563 479 #else 564 480 !----------------------------------------------------------------------- … … 567 483 pvalsout = pvalsin 568 484 #endif 569 485 ! 570 486 END SUBROUTINE mpp_alltoallv_real 571 487 488 !!====================================================================== 572 489 END MODULE obs_mpp
Note: See TracChangeset
for help on using the changeset viewer.
