00001
00002
00003
00004
00005
00006 module ice_global_reductions
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021 use ice_kinds_mod
00022 use ice_communicate
00023 use ice_constants
00024 use ice_blocks
00025 use ice_distribution
00026 use ice_domain_size
00027
00028 implicit none
00029 private
00030 save
00031
00032 include 'mpif.h'
00033
00034
00035
00036 public :: global_sum, &
00037 global_sum_prod, &
00038 global_maxval, &
00039 global_minval, &
00040 init_global_reductions
00041
00042 public :: sum_vector_dbl
00043
00044
00045
00046
00047
00048
00049
00050
00051 interface global_sum
00052 module procedure global_sum_dbl, &
00053 global_sum_real, &
00054 global_sum_int, &
00055 global_sum_scalar_dbl, &
00056 global_sum_scalar_real, &
00057 global_sum_scalar_int
00058 end interface
00059
00060 interface global_sum_prod
00061 module procedure global_sum_prod_dbl, &
00062 global_sum_prod_real, &
00063 global_sum_prod_int
00064 end interface
00065
00066 interface global_maxval
00067 module procedure global_maxval_dbl, &
00068 global_maxval_real, &
00069 global_maxval_int, &
00070 global_maxval_scalar_dbl, &
00071 global_maxval_scalar_real, &
00072 global_maxval_scalar_int
00073 end interface
00074
00075 interface global_minval
00076 module procedure global_minval_dbl, &
00077 global_minval_real, &
00078 global_minval_int, &
00079 global_minval_scalar_dbl, &
00080 global_minval_scalar_real, &
00081 global_minval_scalar_int
00082 end interface
00083
00084
00085
00086
00087
00088
00089
00090 logical(log_kind) :: ltripole_grid
00091
00092
00093
00094
00095 contains
00096
00097
00098
00099
00100
00101
00102 subroutine init_global_reductions(tripole_flag)
00103
00104
00105
00106
00107
00108
00109
00110
00111
00112 logical(log_kind), intent(in) :: tripole_flag
00113
00114
00115
00116
00117
00118
00119 ltripole_grid = tripole_flag
00120
00121
00122
00123 end subroutine init_global_reductions
00124
00125 subroutine sum_vector_dbl(local_vector,global_vector, dist)
00126
00127
00128
00129
00130
00131
00132
00133 include 'mpif.h'
00134
00135 type (distrb), intent(in) ::
00136 dist
00137
00138 real (dbl_kind), intent(inout) ::
00139 local_vector(:)
00140
00141 real (dbl_kind) :: global_vector(:)
00142
00143 integer (int_kind) :: ierr
00144
00145 integer (int_kind) :: len
00146
00147
00148 len = size(local_vector)
00149 if (dist%nprocs > 1) then
00150 if (my_task < dist%nprocs) then
00151 call MPI_ALLREDUCE(local_vector, global_vector, len, &
00152 mpiR8, MPI_SUM, dist%communicator, ierr)
00153 else
00154 global_vector = c0
00155 endif
00156 else
00157 global_vector = local_vector
00158 endif
00159
00160
00161
00162 end subroutine sum_vector_dbl
00163
00164
00165
00166
00167
00168
00169 function global_sum_dbl(array, dist, field_loc, mMask, lMask) &
00170 result(globalSum)
00171
00172
00173
00174
00175
00176
00177
00178
00179
00180
00181
00182
00183
00184
00185
00186
00187
00188 real (dbl_kind), dimension(:,:,:), intent(in) ::
00189 array
00190
00191 type (distrb), intent(in) ::
00192 dist
00193
00194 integer (int_kind), intent(in) ::
00195 field_loc
00196
00197 real (dbl_kind), dimension(:,:,:), intent(in), optional ::
00198 mMask
00199
00200 logical (log_kind), dimension(:,:,:), intent(in), optional ::
00201 lMask
00202
00203
00204
00205 real (dbl_kind) ::
00206 globalSum
00207
00208
00209
00210
00211
00212
00213
00214
00215
00216 real (dbl_kind), dimension(:), allocatable ::
00217 blockSum,
00218 localSum,
00219 globalSumTmp
00220
00221 integer (int_kind) ::
00222 i,j,iblock,n,
00223 ib,ie,jb,je,
00224 ierr,
00225 blockID,
00226 numProcs,
00227 numBlocks,
00228 communicator,
00229 nreduce,
00230 maxiglob
00231
00232 logical (log_kind) ::
00233 Nrow
00234
00235 type (block) ::
00236 this_block
00237
00238
00239
00240 #ifdef REPRODUCIBLE
00241 nreduce = nblocks_tot
00242 #else
00243 nreduce = 1
00244 #endif
00245 allocate(blockSum(nreduce), &
00246 globalSumTmp(nreduce))
00247 blockSum = 0.0_dbl_kind
00248 globalSumTmp = 0.0_dbl_kind
00249 globalSum = 0.0_dbl_kind
00250
00251 call ice_distributionGet(dist, &
00252 numLocalBlocks = numBlocks, &
00253 nprocs = numProcs, &
00254 communicator = communicator)
00255
00256 do iblock=1,numBlocks
00257 call ice_distributionGetBlockID(dist, iblock, blockID)
00258
00259 this_block = get_block(blockID, blockID)
00260
00261 ib = this_block%ilo
00262 ie = this_block%ihi
00263 jb = this_block%jlo
00264 je = this_block%jhi
00265
00266 #ifdef REPRODUCIBLE
00267 n = blockID
00268 #else
00269 n = 1
00270 #endif
00271
00272 if (present(mMask)) then
00273 do j=jb,je
00274 do i=ib,ie
00275 blockSum(n) = &
00276 blockSum(n) + array(i,j,iblock)*mMask(i,j,iblock)
00277 end do
00278 end do
00279 else if (present(lMask)) then
00280 do j=jb,je
00281 do i=ib,ie
00282 if (lMask(i,j,iblock)) then
00283 blockSum(n) = &
00284 blockSum(n) + array(i,j,iblock)
00285 endif
00286 end do
00287 end do
00288 else
00289 do j=jb,je
00290 do i=ib,ie
00291 blockSum(n) = blockSum(n) + array(i,j,iblock)
00292 end do
00293 end do
00294 endif
00295
00296
00297
00298
00299 if (this_block%tripole) then
00300 Nrow=(field_loc == field_loc_Nface .or. &
00301 field_loc == field_loc_NEcorner)
00302 if (Nrow .and. this_block%tripoleTFlag) then
00303 maxiglob = 0
00304 elseif (Nrow .or. this_block%tripoleTFlag) then
00305 maxiglob = nx_global/2
00306 else
00307 maxiglob = -1
00308 endif
00309
00310 if (maxiglob > 0) then
00311
00312 j = je
00313
00314 if (present(mMask)) then
00315 do i=ib,ie
00316 if (this_block%i_glob(i) > maxiglob) then
00317 blockSum(n) = &
00318 blockSum(n) - array(i,j,iblock)*mMask(i,j,iblock)
00319 endif
00320 end do
00321 else if (present(lMask)) then
00322 do i=ib,ie
00323 if (this_block%i_glob(i) > maxiglob) then
00324 if (lMask(i,j,iblock)) &
00325 blockSum(n) = blockSum(n) - array(i,j,iblock)
00326 endif
00327 end do
00328 else
00329 do i=ib,ie
00330 if (this_block%i_glob(i) > maxiglob) then
00331 blockSum(n) = blockSum(n) - array(i,j,iblock)
00332 endif
00333 end do
00334 endif
00335
00336 endif
00337 endif
00338 end do
00339
00340 if (my_task < numProcs) then
00341 call MPI_ALLREDUCE(blockSum, globalSumTmp, nreduce, &
00342 mpiR8, MPI_SUM, communicator, ierr)
00343 endif
00344
00345 do n=1,nreduce
00346 globalSum = globalSum + globalSumTmp(n)
00347 enddo
00348
00349 deallocate(blockSum, globalSumTmp)
00350
00351
00352
00353
00354 end function global_sum_dbl
00355
00356
00357
00358
00359
00360
00361 function global_sum_real(array, dist, field_loc, mMask, lMask) &
00362 result(globalSum)
00363
00364
00365
00366
00367
00368
00369
00370
00371
00372
00373
00374
00375
00376
00377
00378
00379
00380 real (real_kind), dimension(:,:,:), intent(in) ::
00381 array
00382
00383 type (distrb), intent(in) ::
00384 dist
00385
00386 integer (int_kind), intent(in) ::
00387 field_loc
00388
00389 real (real_kind), dimension(:,:,:), intent(in), optional ::
00390 mMask
00391
00392 logical (log_kind), dimension(:,:,:), intent(in), optional ::
00393 lMask
00394
00395
00396
00397 real (real_kind) ::
00398 globalSum
00399
00400
00401
00402
00403
00404
00405
00406
00407
00408 #ifdef REPRODUCIBLE
00409 real (dbl_kind) ::
00410 blockSum,
00411 localSum,
00412 globalSumTmp
00413 #else
00414 real (real_kind) ::
00415 blockSum,
00416 localSum
00417 #endif
00418
00419 integer (int_kind) ::
00420 i,j,iblock,
00421 ib,ie,jb,je,
00422 ierr,
00423 blockID,
00424 numProcs,
00425 numBlocks,
00426 communicator,
00427 maxiglob
00428
00429 logical (log_kind) ::
00430 Nrow
00431
00432 type (block) ::
00433 this_block
00434
00435
00436
00437 #ifdef REPRODUCIBLE
00438 localSum = 0.0_dbl_kind
00439 #else
00440 localSum = 0.0_real_kind
00441 #endif
00442 globalSum = 0.0_real_kind
00443
00444 call ice_distributionGet(dist, &
00445 numLocalBlocks = numBlocks, &
00446 nprocs = numProcs, &
00447 communicator = communicator)
00448
00449 do iblock=1,numBlocks
00450 call ice_distributionGetBlockID(dist, iblock, blockID)
00451
00452 this_block = get_block(blockID, blockID)
00453
00454 ib = this_block%ilo
00455 ie = this_block%ihi
00456 jb = this_block%jlo
00457 je = this_block%jhi
00458
00459 #ifdef REPRODUCIBLE
00460 blockSum = 0.0_dbl_kind
00461 #else
00462 blockSum = 0.0_real_kind
00463 #endif
00464
00465 if (present(mMask)) then
00466 do j=jb,je
00467 do i=ib,ie
00468 blockSum = &
00469 blockSum + array(i,j,iblock)*mMask(i,j,iblock)
00470 end do
00471 end do
00472 else if (present(lMask)) then
00473 do j=jb,je
00474 do i=ib,ie
00475 if (lMask(i,j,iblock)) then
00476 blockSum = &
00477 blockSum + array(i,j,iblock)
00478 endif
00479 end do
00480 end do
00481 else
00482 do j=jb,je
00483 do i=ib,ie
00484 blockSum = blockSum + array(i,j,iblock)
00485 end do
00486 end do
00487 endif
00488
00489
00490
00491
00492 if (this_block%tripole) then
00493 Nrow=(field_loc == field_loc_Nface .or. &
00494 field_loc == field_loc_NEcorner)
00495 if (Nrow .and. this_block%tripoleTFlag) then
00496 maxiglob = 0
00497 elseif (Nrow .or. this_block%tripoleTFlag) then
00498 maxiglob = nx_global/2
00499 else
00500 maxiglob = -1
00501 endif
00502
00503 if (maxiglob > 0) then
00504
00505 j = je
00506
00507 if (present(mMask)) then
00508 do i=ib,ie
00509 if (this_block%i_glob(i) > maxiglob) then
00510 blockSum = &
00511 blockSum - array(i,j,iblock)*mMask(i,j,iblock)
00512 endif
00513 end do
00514 else if (present(lMask)) then
00515 do i=ib,ie
00516 if (this_block%i_glob(i) > maxiglob) then
00517 if (lMask(i,j,iblock)) &
00518 blockSum = blockSum - array(i,j,iblock)
00519 endif
00520 end do
00521 else
00522 do i=ib,ie
00523 if (this_block%i_glob(i) > maxiglob) then
00524 blockSum = blockSum - array(i,j,iblock)
00525 endif
00526 end do
00527 endif
00528
00529 endif
00530 endif
00531
00532
00533
00534 localSum = localSum + blockSum
00535
00536 end do
00537
00538
00539
00540
00541
00542
00543
00544 #ifdef REPRODUCIBLE
00545 if (my_task < numProcs) then
00546 call MPI_ALLREDUCE(localSum, globalSumTmp, 1, &
00547 mpiR8, MPI_SUM, communicator, ierr)
00548 globalSum = globalSumTmp
00549 endif
00550 #else
00551 if (my_task < numProcs) then
00552 call MPI_ALLREDUCE(localSum, globalSum, 1, &
00553 mpiR4, MPI_SUM, communicator, ierr)
00554 endif
00555 #endif
00556
00557
00558
00559
00560 end function global_sum_real
00561
00562
00563
00564
00565
00566
00567 function global_sum_int(array, dist, field_loc, mMask, lMask) &
00568 result(globalSum)
00569
00570
00571
00572
00573
00574
00575
00576
00577
00578
00579
00580
00581
00582
00583
00584
00585
00586 integer (int_kind), dimension(:,:,:), intent(in) ::
00587 array
00588
00589 type (distrb), intent(in) ::
00590 dist
00591
00592 integer (int_kind), intent(in) ::
00593 field_loc
00594
00595 integer (int_kind), dimension(:,:,:), intent(in), optional ::
00596 mMask
00597
00598 logical (log_kind), dimension(:,:,:), intent(in), optional ::
00599 lMask
00600
00601
00602
00603 integer (int_kind) ::
00604 globalSum
00605
00606
00607
00608
00609
00610
00611
00612
00613
00614 integer (int_kind) ::
00615 blockSum,
00616 localSum
00617
00618 integer (int_kind) ::
00619 i,j,iblock,
00620 ib,ie,jb,je,
00621 ierr,
00622 blockID,
00623 numProcs,
00624 numBlocks,
00625 communicator,
00626 maxiglob
00627
00628 logical (log_kind) ::
00629 Nrow
00630
00631 type (block) ::
00632 this_block
00633
00634
00635
00636 localSum = 0_int_kind
00637 globalSum = 0_int_kind
00638
00639 call ice_distributionGet(dist, &
00640 numLocalBlocks = numBlocks, &
00641 nprocs = numProcs, &
00642 communicator = communicator)
00643
00644 do iblock=1,numBlocks
00645 call ice_distributionGetBlockID(dist, iblock, blockID)
00646
00647 this_block = get_block(blockID, blockID)
00648
00649 ib = this_block%ilo
00650 ie = this_block%ihi
00651 jb = this_block%jlo
00652 je = this_block%jhi
00653
00654 blockSum = 0
00655
00656 if (present(mMask)) then
00657 do j=jb,je
00658 do i=ib,ie
00659 blockSum = &
00660 blockSum + array(i,j,iblock)*mMask(i,j,iblock)
00661 end do
00662 end do
00663 else if (present(lMask)) then
00664 do j=jb,je
00665 do i=ib,ie
00666 if (lMask(i,j,iblock)) then
00667 blockSum = &
00668 blockSum + array(i,j,iblock)
00669 endif
00670 end do
00671 end do
00672 else
00673 do j=jb,je
00674 do i=ib,ie
00675 blockSum = blockSum + array(i,j,iblock)
00676 end do
00677 end do
00678 endif
00679
00680
00681
00682
00683 if (this_block%tripole) then
00684 Nrow=(field_loc == field_loc_Nface .or. &
00685 field_loc == field_loc_NEcorner)
00686 if (Nrow .and. this_block%tripoleTFlag) then
00687 maxiglob = 0
00688 elseif (Nrow .or. this_block%tripoleTFlag) then
00689 maxiglob = nx_global/2
00690 else
00691 maxiglob = -1
00692 endif
00693
00694 if (maxiglob > 0) then
00695
00696 j = je
00697
00698 if (present(mMask)) then
00699 do i=ib,ie
00700 if (this_block%i_glob(i) > maxiglob) then
00701 blockSum = &
00702 blockSum - array(i,j,iblock)*mMask(i,j,iblock)
00703 endif
00704 end do
00705 else if (present(lMask)) then
00706 do i=ib,ie
00707 if (this_block%i_glob(i) > maxiglob) then
00708 if (lMask(i,j,iblock)) &
00709 blockSum = blockSum - array(i,j,iblock)
00710 endif
00711 end do
00712 else
00713 do i=ib,ie
00714 if (this_block%i_glob(i) > maxiglob) then
00715 blockSum = blockSum - array(i,j,iblock)
00716 endif
00717 end do
00718 endif
00719
00720 endif
00721 endif
00722
00723
00724
00725 localSum = localSum + blockSum
00726
00727 end do
00728
00729
00730
00731
00732
00733
00734
00735 if (my_task < numProcs) then
00736 call MPI_ALLREDUCE(localSum, globalSum, 1, &
00737 MPI_INTEGER, MPI_SUM, communicator, ierr)
00738 endif
00739
00740
00741
00742
00743 end function global_sum_int
00744
00745
00746
00747
00748
00749
00750 function global_sum_scalar_dbl(scalar, dist) &
00751 result(globalSum)
00752
00753
00754
00755
00756
00757
00758
00759
00760
00761
00762
00763
00764
00765
00766
00767
00768
00769
00770 real (dbl_kind), intent(in) ::
00771 scalar
00772
00773 type (distrb), intent(in) ::
00774 dist
00775
00776
00777
00778 real (dbl_kind) ::
00779 globalSum
00780
00781
00782
00783
00784
00785
00786
00787
00788
00789 integer (int_kind) ::
00790 ierr,
00791 numProcs,
00792 numBlocks,
00793 communicator
00794
00795
00796
00797
00798
00799
00800
00801
00802
00803
00804
00805
00806 call ice_distributionGet(dist, &
00807 numLocalBlocks = numBlocks, &
00808 nprocs = numProcs, &
00809 communicator = communicator)
00810
00811
00812
00813
00814
00815
00816
00817
00818
00819
00820
00821
00822
00823
00824
00825
00826
00827 if (my_task < numProcs) then
00828 call MPI_ALLREDUCE(scalar, globalSum, 1, &
00829 mpiR8, MPI_SUM, communicator, ierr)
00830 endif
00831
00832
00833
00834
00835
00836 end function global_sum_scalar_dbl
00837
00838
00839
00840
00841
00842
00843 function global_sum_scalar_real(scalar, dist) &
00844 result(globalSum)
00845
00846
00847
00848
00849
00850
00851
00852
00853
00854
00855
00856
00857
00858
00859
00860
00861
00862
00863 real (real_kind), intent(in) ::
00864 scalar
00865
00866 type (distrb), intent(in) ::
00867 dist
00868
00869
00870
00871 real (real_kind) ::
00872 globalSum
00873
00874
00875
00876
00877
00878
00879
00880
00881
00882 integer (int_kind) ::
00883 ierr,
00884 numProcs,
00885 numBlocks,
00886 communicator
00887
00888 #ifdef REPRODUCIBLE
00889 real (dbl_kind) ::
00890 scalarTmp, globalSumTmp
00891 #endif
00892
00893
00894
00895
00896
00897
00898
00899 call ice_distributionGet(dist, &
00900 numLocalBlocks = numBlocks, &
00901 nprocs = numProcs, &
00902 communicator = communicator)
00903
00904
00905
00906
00907
00908
00909
00910 #ifdef REPRODUCIBLE
00911 if (my_task < numProcs) then
00912 scalarTmp = scalar
00913 call MPI_ALLREDUCE(scalarTmp, globalSumTmp, 1, &
00914 mpiR8, MPI_SUM, communicator, ierr)
00915 globalSum = globalSumTmp
00916 endif
00917 #else
00918 if (my_task < numProcs) then
00919 call MPI_ALLREDUCE(scalar, globalSum, 1, &
00920 mpiR4, MPI_SUM, communicator, ierr)
00921 endif
00922 #endif
00923
00924
00925
00926
00927 end function global_sum_scalar_real
00928
00929
00930
00931
00932
00933
00934 function global_sum_scalar_int(scalar, dist) &
00935 result(globalSum)
00936
00937
00938
00939
00940
00941
00942
00943
00944
00945
00946
00947
00948
00949
00950
00951
00952
00953
00954 integer (int_kind), intent(in) ::
00955 scalar
00956
00957 type (distrb), intent(in) ::
00958 dist
00959
00960
00961
00962 integer (int_kind) ::
00963 globalSum
00964
00965
00966
00967
00968
00969
00970
00971
00972
00973 integer (int_kind) ::
00974 ierr,
00975 numProcs,
00976 numBlocks,
00977 communicator
00978
00979
00980
00981
00982
00983
00984
00985 call ice_distributionGet(dist, &
00986 numLocalBlocks = numBlocks, &
00987 nprocs = numProcs, &
00988 communicator = communicator)
00989
00990
00991
00992
00993
00994
00995
00996 if (my_task < numProcs) then
00997 call MPI_ALLREDUCE(scalar, globalSum, 1, &
00998 MPI_INTEGER, MPI_SUM, communicator, ierr)
00999 endif
01000
01001
01002
01003
01004 end function global_sum_scalar_int
01005
01006
01007
01008
01009
01010
01011 function global_sum_prod_dbl (array1, array2, dist, field_loc, &
01012 mMask, lMask) &
01013 result(globalSum)
01014
01015
01016
01017
01018
01019
01020
01021
01022
01023
01024
01025
01026
01027
01028
01029
01030
01031
01032 real (dbl_kind), dimension(:,:,:), intent(in) ::
01033 array1, array2
01034
01035 type (distrb), intent(in) ::
01036 dist
01037
01038 integer (int_kind), intent(in) ::
01039 field_loc
01040
01041 real (dbl_kind), dimension(:,:,:), intent(in), optional ::
01042 mMask
01043
01044 logical (log_kind), dimension(:,:,:), intent(in), optional ::
01045 lMask
01046
01047
01048
01049 real (dbl_kind) ::
01050 globalSum
01051
01052
01053
01054
01055
01056
01057
01058
01059
01060 real (dbl_kind), dimension(:), allocatable ::
01061 blockSum,
01062 localSum,
01063 globalSumTmp
01064
01065 integer (int_kind) ::
01066 i,j,iblock,n,
01067 ib,ie,jb,je,
01068 ierr,
01069 blockID,
01070 numBlocks,
01071 numProcs,
01072 communicator,
01073 nreduce,
01074 maxiglob
01075
01076 logical (log_kind) ::
01077 Nrow
01078
01079 type (block) ::
01080 this_block
01081
01082
01083
01084 #ifdef REPRODUCIBLE
01085 nreduce = nblocks_tot
01086 #else
01087 nreduce = 1
01088 #endif
01089 allocate(blockSum(nreduce), &
01090 globalSumTmp(nreduce))
01091 blockSum = 0.0_dbl_kind
01092 globalSumTmp = 0.0_dbl_kind
01093 globalSum = 0.0_dbl_kind
01094
01095 call ice_distributionGet(dist, &
01096 numLocalBlocks = numBlocks, &
01097 nprocs = numProcs, &
01098 communicator = communicator)
01099
01100 do iblock=1,numBlocks
01101 call ice_distributionGetBlockID(dist, iblock, blockID)
01102
01103 this_block = get_block(blockID, blockID)
01104
01105 ib = this_block%ilo
01106 ie = this_block%ihi
01107 jb = this_block%jlo
01108 je = this_block%jhi
01109
01110 #ifdef REPRODUCIBLE
01111 n = blockID
01112 #else
01113 n = 1
01114 #endif
01115
01116 if (present(mMask)) then
01117 do j=jb,je
01118 do i=ib,ie
01119 blockSum(n) = &
01120 blockSum(n) + array1(i,j,iblock)*array2(i,j,iblock)* &
01121 mMask(i,j,iblock)
01122 end do
01123 end do
01124 else if (present(lMask)) then
01125 do j=jb,je
01126 do i=ib,ie
01127 if (lMask(i,j,iblock)) then
01128 blockSum(n) = &
01129 blockSum(n) + array1(i,j,iblock)*array2(i,j,iblock)
01130 endif
01131 end do
01132 end do
01133 else
01134 do j=jb,je
01135 do i=ib,ie
01136 blockSum(n) = blockSum(n) + array1(i,j,iblock)*array2(i,j,iblock)
01137 end do
01138 end do
01139 endif
01140
01141
01142
01143
01144 if (this_block%tripole) then
01145 Nrow=(field_loc == field_loc_Nface .or. &
01146 field_loc == field_loc_NEcorner)
01147 if (Nrow .and. this_block%tripoleTFlag) then
01148 maxiglob = 0
01149 elseif (Nrow .or. this_block%tripoleTFlag) then
01150 maxiglob = nx_global/2
01151 else
01152 maxiglob = -1
01153 endif
01154
01155 if (maxiglob > 0) then
01156
01157 j = je
01158
01159 if (present(mMask)) then
01160 do i=ib,ie
01161 if (this_block%i_glob(i) > maxiglob) then
01162 blockSum(n) = &
01163 blockSum(n) - array1(i,j,iblock)*array2(i,j,iblock)* &
01164 mMask(i,j,iblock)
01165 endif
01166 end do
01167 else if (present(lMask)) then
01168 do i=ib,ie
01169 if (this_block%i_glob(i) > maxiglob) then
01170 if (lMask(i,j,iblock)) &
01171 blockSum(n) = blockSum(n) - &
01172 array1(i,j,iblock)*array2(i,j,iblock)
01173 endif
01174 end do
01175 else
01176 do i=ib,ie
01177 if (this_block%i_glob(i) > maxiglob) then
01178 blockSum(n) = blockSum(n) - &
01179 array1(i,j,iblock)*array2(i,j,iblock)
01180 endif
01181 end do
01182 endif
01183
01184 endif
01185 endif
01186
01187 end do
01188
01189 if (my_task < numProcs) then
01190 call MPI_ALLREDUCE(blockSum, globalSumTmp, nreduce, &
01191 mpiR8, MPI_SUM, communicator, ierr)
01192 endif
01193
01194 do n=1,nreduce
01195 globalSum = globalSum + globalSumTmp(n)
01196 enddo
01197
01198 deallocate(blockSum, globalSumTmp)
01199
01200
01201
01202
01203 end function global_sum_prod_dbl
01204
01205
01206
01207
01208
01209
01210 function global_sum_prod_real (array1, array2, dist, field_loc, &
01211 mMask, lMask) &
01212 result(globalSum)
01213
01214
01215
01216
01217
01218
01219
01220
01221
01222
01223
01224
01225
01226
01227
01228
01229
01230
01231 real (real_kind), dimension(:,:,:), intent(in) ::
01232 array1, array2
01233
01234 type (distrb), intent(in) ::
01235 dist
01236
01237 integer (int_kind), intent(in) ::
01238 field_loc
01239
01240 real (real_kind), dimension(:,:,:), intent(in), optional ::
01241 mMask
01242
01243 logical (log_kind), dimension(:,:,:), intent(in), optional ::
01244 lMask
01245
01246
01247
01248 real (real_kind) ::
01249 globalSum
01250
01251
01252
01253
01254
01255
01256
01257
01258
01259 #ifdef REPRODUCIBLE
01260 real (dbl_kind) ::
01261 blockSum,
01262 localSum,
01263 globalSumTmp
01264 #else
01265 real (real_kind) ::
01266 blockSum,
01267 localSum
01268 #endif
01269
01270 integer (int_kind) ::
01271 i,j,iblock,
01272 ib,ie,jb,je,
01273 ierr,
01274 blockID,
01275 numBlocks,
01276 numProcs,
01277 communicator,
01278 maxiglob
01279
01280 logical (log_kind) ::
01281 Nrow
01282
01283 type (block) ::
01284 this_block
01285
01286
01287
01288 #ifdef REPRODUCIBLE
01289 localSum = 0.0_dbl_kind
01290 #else
01291 localSum = 0.0_real_kind
01292 #endif
01293 globalSum = 0.0_real_kind
01294
01295 call ice_distributionGet(dist, &
01296 numLocalBlocks = numBlocks, &
01297 nprocs = numProcs, &
01298 communicator = communicator)
01299
01300 do iblock=1,numBlocks
01301 call ice_distributionGetBlockID(dist, iblock, blockID)
01302
01303 this_block = get_block(blockID, blockID)
01304
01305 ib = this_block%ilo
01306 ie = this_block%ihi
01307 jb = this_block%jlo
01308 je = this_block%jhi
01309
01310 #ifdef REPRODUCIBLE
01311 blockSum = 0.0_dbl_kind
01312 #else
01313 blockSum = 0.0_real_kind
01314 #endif
01315
01316 if (present(mMask)) then
01317 do j=jb,je
01318 do i=ib,ie
01319 blockSum = &
01320 blockSum + array1(i,j,iblock)*array2(i,j,iblock)* &
01321 mMask(i,j,iblock)
01322 end do
01323 end do
01324 else if (present(lMask)) then
01325 do j=jb,je
01326 do i=ib,ie
01327 if (lMask(i,j,iblock)) then
01328 blockSum = &
01329 blockSum + array1(i,j,iblock)*array2(i,j,iblock)
01330 endif
01331 end do
01332 end do
01333 else
01334 do j=jb,je
01335 do i=ib,ie
01336 blockSum = blockSum + array1(i,j,iblock)*array2(i,j,iblock)
01337 end do
01338 end do
01339 endif
01340
01341
01342
01343
01344 if (this_block%tripole) then
01345 Nrow=(field_loc == field_loc_Nface .or. &
01346 field_loc == field_loc_NEcorner)
01347 if (Nrow .and. this_block%tripoleTFlag) then
01348 maxiglob = 0
01349 elseif (Nrow .or. this_block%tripoleTFlag) then
01350 maxiglob = nx_global/2
01351 else
01352 maxiglob = -1
01353 endif
01354
01355 if (maxiglob > 0) then
01356
01357 j = je
01358
01359 if (present(mMask)) then
01360 do i=ib,ie
01361 if (this_block%i_glob(i) > maxiglob) then
01362 blockSum = &
01363 blockSum - array1(i,j,iblock)*array2(i,j,iblock)* &
01364 mMask(i,j,iblock)
01365 endif
01366 end do
01367 else if (present(lMask)) then
01368 do i=ib,ie
01369 if (this_block%i_glob(i) > maxiglob) then
01370 if (lMask(i,j,iblock)) &
01371 blockSum = blockSum - &
01372 array1(i,j,iblock)*array2(i,j,iblock)
01373 endif
01374 end do
01375 else
01376 do i=ib,ie
01377 if (this_block%i_glob(i) > maxiglob) then
01378 blockSum = blockSum - &
01379 array1(i,j,iblock)*array2(i,j,iblock)
01380 endif
01381 end do
01382 endif
01383
01384 endif
01385 endif
01386
01387
01388
01389 localSum = localSum + blockSum
01390
01391 end do
01392
01393
01394
01395
01396
01397
01398
01399 #ifdef REPRODUCIBLE
01400 if (my_task < numProcs) then
01401 call MPI_ALLREDUCE(localSum, globalSumTmp, 1, &
01402 mpiR8, MPI_SUM, communicator, ierr)
01403 globalSum = globalSumTmp
01404 endif
01405 #else
01406 if (my_task < numProcs) then
01407 call MPI_ALLREDUCE(localSum, globalSum, 1, &
01408 mpiR4, MPI_SUM, communicator, ierr)
01409 endif
01410 #endif
01411
01412
01413
01414
01415 end function global_sum_prod_real
01416
01417
01418
01419
01420
01421
01422 function global_sum_prod_int (array1, array2, dist, field_loc, &
01423 mMask, lMask) &
01424 result(globalSum)
01425
01426
01427
01428
01429
01430
01431
01432
01433
01434
01435
01436
01437
01438
01439
01440
01441
01442
01443 integer (int_kind), dimension(:,:,:), intent(in) ::
01444 array1, array2
01445
01446 type (distrb), intent(in) ::
01447 dist
01448
01449 integer (int_kind), intent(in) ::
01450 field_loc
01451
01452 integer (int_kind), dimension(:,:,:), intent(in), optional ::
01453 mMask
01454
01455 logical (log_kind), dimension(:,:,:), intent(in), optional ::
01456 lMask
01457
01458
01459
01460 integer (int_kind) ::
01461 globalSum
01462
01463
01464
01465
01466
01467
01468
01469
01470
01471 integer (int_kind) ::
01472 blockSum,
01473 localSum
01474
01475 integer (int_kind) ::
01476 i,j,iblock,
01477 ib,ie,jb,je,
01478 ierr,
01479 blockID,
01480 numBlocks,
01481 numProcs,
01482 communicator,
01483 maxiglob
01484
01485 logical (log_kind) ::
01486 Nrow
01487
01488 type (block) ::
01489 this_block
01490
01491
01492
01493 localSum = 0_int_kind
01494 globalSum = 0_int_kind
01495
01496 call ice_distributionGet(dist, &
01497 numLocalBlocks = numBlocks, &
01498 nprocs = numProcs, &
01499 communicator = communicator)
01500
01501 do iblock=1,numBlocks
01502 call ice_distributionGetBlockID(dist, iblock, blockID)
01503
01504 this_block = get_block(blockID, blockID)
01505
01506 ib = this_block%ilo
01507 ie = this_block%ihi
01508 jb = this_block%jlo
01509 je = this_block%jhi
01510
01511 blockSum = 0
01512
01513 if (present(mMask)) then
01514 do j=jb,je
01515 do i=ib,ie
01516 blockSum = &
01517 blockSum + array1(i,j,iblock)*array2(i,j,iblock)* &
01518 mMask(i,j,iblock)
01519 end do
01520 end do
01521 else if (present(lMask)) then
01522 do j=jb,je
01523 do i=ib,ie
01524 if (lMask(i,j,iblock)) then
01525 blockSum = &
01526 blockSum + array1(i,j,iblock)*array2(i,j,iblock)
01527 endif
01528 end do
01529 end do
01530 else
01531 do j=jb,je
01532 do i=ib,ie
01533 blockSum = blockSum + array1(i,j,iblock)*array2(i,j,iblock)
01534 end do
01535 end do
01536 endif
01537
01538
01539
01540
01541 if (this_block%tripole) then
01542 Nrow=(field_loc == field_loc_Nface .or. &
01543 field_loc == field_loc_NEcorner)
01544 if (Nrow .and. this_block%tripoleTFlag) then
01545 maxiglob = 0
01546 elseif (Nrow .or. this_block%tripoleTFlag) then
01547 maxiglob = nx_global/2
01548 else
01549 maxiglob = -1
01550 endif
01551
01552 if (maxiglob > 0) then
01553
01554 j = je
01555
01556 if (present(mMask)) then
01557 do i=ib,ie
01558 if (this_block%i_glob(i) > maxiglob) then
01559 blockSum = &
01560 blockSum - array1(i,j,iblock)*array2(i,j,iblock)* &
01561 mMask(i,j,iblock)
01562 endif
01563 end do
01564 else if (present(lMask)) then
01565 do i=ib,ie
01566 if (this_block%i_glob(i) > maxiglob) then
01567 if (lMask(i,j,iblock)) &
01568 blockSum = blockSum - &
01569 array1(i,j,iblock)*array2(i,j,iblock)
01570 endif
01571 end do
01572 else
01573 do i=ib,ie
01574 if (this_block%i_glob(i) > maxiglob) then
01575 blockSum = blockSum - &
01576 array1(i,j,iblock)*array2(i,j,iblock)
01577 endif
01578 end do
01579 endif
01580
01581 endif
01582 endif
01583
01584
01585
01586 localSum = localSum + blockSum
01587
01588 end do
01589
01590
01591
01592
01593
01594
01595
01596 if (my_task < numProcs) then
01597 call MPI_ALLREDUCE(localSum, globalSum, 1, &
01598 MPI_INTEGER, MPI_SUM, communicator, ierr)
01599 endif
01600
01601
01602
01603
01604 end function global_sum_prod_int
01605
01606
01607
01608
01609
01610
01611 function global_maxval_dbl (array, dist, lMask) &
01612 result(globalMaxval)
01613
01614
01615
01616
01617
01618
01619
01620
01621
01622
01623
01624
01625
01626 real (dbl_kind), dimension(:,:,:), intent(in) ::
01627 array
01628
01629 type (distrb), intent(in) ::
01630 dist
01631
01632 logical (log_kind), dimension(:,:,:), intent(in), optional ::
01633 lMask
01634
01635
01636
01637 real (dbl_kind) ::
01638 globalMaxval
01639
01640
01641
01642
01643
01644
01645
01646
01647
01648 real (dbl_kind) ::
01649 blockMaxval,
01650 localMaxval
01651
01652 integer (int_kind) ::
01653 i,j,iblock,
01654 ib,ie,jb,je,
01655 ierr,
01656 numBlocks,
01657 numProcs,
01658 communicator,
01659 blockID
01660
01661 type (block) ::
01662 this_block
01663
01664
01665
01666 localMaxval = -HUGE(0.0_dbl_kind)
01667 globalMaxval = -HUGE(0.0_dbl_kind)
01668
01669 call ice_distributionGet(dist, &
01670 numLocalBlocks = numBlocks, &
01671 nprocs = numProcs, &
01672 communicator = communicator)
01673
01674 do iblock=1,numBlocks
01675 call ice_distributionGetBlockID(dist, iblock, blockID)
01676
01677 this_block = get_block(blockID, blockID)
01678
01679 ib = this_block%ilo
01680 ie = this_block%ihi
01681 jb = this_block%jlo
01682 je = this_block%jhi
01683
01684 blockMaxval = -HUGE(0.0_dbl_kind)
01685
01686 if (present(lMask)) then
01687 do j=jb,je
01688 do i=ib,ie
01689 if (lMask(i,j,iblock)) then
01690 blockMaxval = max(blockMaxval,array(i,j,iblock))
01691 endif
01692 end do
01693 end do
01694 else
01695 do j=jb,je
01696 do i=ib,ie
01697 blockMaxval = max(blockMaxval,array(i,j,iblock))
01698 end do
01699 end do
01700 endif
01701
01702 localMaxval = max(localMaxval,blockMaxval)
01703
01704 end do
01705
01706
01707
01708
01709
01710
01711
01712 if (my_task < numProcs) then
01713 call MPI_ALLREDUCE(localMaxval, globalMaxval, 1, &
01714 mpiR8, MPI_MAX, communicator, ierr)
01715 endif
01716
01717
01718
01719 end function global_maxval_dbl
01720
01721
01722
01723
01724
01725
01726 function global_maxval_real (array, dist, lMask) &
01727 result(globalMaxval)
01728
01729
01730
01731
01732
01733
01734
01735
01736
01737
01738
01739
01740
01741 real (real_kind), dimension(:,:,:), intent(in) ::
01742 array
01743
01744 type (distrb), intent(in) ::
01745 dist
01746
01747 logical (log_kind), dimension(:,:,:), intent(in), optional ::
01748 lMask
01749
01750
01751
01752 real (real_kind) ::
01753 globalMaxval
01754
01755
01756
01757
01758
01759
01760
01761
01762
01763 real (real_kind) ::
01764 blockMaxval,
01765 localMaxval
01766
01767 integer (int_kind) ::
01768 i,j,iblock,
01769 ib,ie,jb,je,
01770 ierr,
01771 numBlocks,
01772 numProcs,
01773 communicator,
01774 blockID
01775
01776 type (block) ::
01777 this_block
01778
01779
01780
01781 localMaxval = -HUGE(0.0_real_kind)
01782 globalMaxval = -HUGE(0.0_real_kind)
01783
01784 call ice_distributionGet(dist, &
01785 numLocalBlocks = numBlocks, &
01786 nprocs = numProcs, &
01787 communicator = communicator)
01788
01789 do iblock=1,numBlocks
01790 call ice_distributionGetBlockID(dist, iblock, blockID)
01791
01792 this_block = get_block(blockID, blockID)
01793
01794 ib = this_block%ilo
01795 ie = this_block%ihi
01796 jb = this_block%jlo
01797 je = this_block%jhi
01798
01799 blockMaxval = -HUGE(0.0_real_kind)
01800
01801 if (present(lMask)) then
01802 do j=jb,je
01803 do i=ib,ie
01804 if (lMask(i,j,iblock)) then
01805 blockMaxval = max(blockMaxval,array(i,j,iblock))
01806 endif
01807 end do
01808 end do
01809 else
01810 do j=jb,je
01811 do i=ib,ie
01812 blockMaxval = max(blockMaxval,array(i,j,iblock))
01813 end do
01814 end do
01815 endif
01816
01817 localMaxval = max(localMaxval,blockMaxval)
01818
01819 end do
01820
01821
01822
01823
01824
01825
01826
01827 if (my_task < numProcs) then
01828 call MPI_ALLREDUCE(localMaxval, globalMaxval, 1, &
01829 mpiR4, MPI_MAX, communicator, ierr)
01830 endif
01831
01832
01833
01834 end function global_maxval_real
01835
01836
01837
01838
01839
01840
01841 function global_maxval_int (array, dist, lMask) &
01842 result(globalMaxval)
01843
01844
01845
01846
01847
01848
01849
01850
01851
01852
01853
01854
01855
01856 integer (int_kind), dimension(:,:,:), intent(in) ::
01857 array
01858
01859 type (distrb), intent(in) ::
01860 dist
01861
01862 logical (log_kind), dimension(:,:,:), intent(in), optional ::
01863 lMask
01864
01865
01866
01867 integer (int_kind) ::
01868 globalMaxval
01869
01870
01871
01872
01873
01874
01875
01876
01877
01878 integer (int_kind) ::
01879 blockMaxval,
01880 localMaxval
01881
01882 integer (int_kind) ::
01883 i,j,iblock,
01884 ib,ie,jb,je,
01885 ierr,
01886 numBlocks,
01887 numProcs,
01888 communicator,
01889 blockID
01890
01891 type (block) ::
01892 this_block
01893
01894
01895
01896 localMaxval = -HUGE(0_int_kind)
01897 globalMaxval = -HUGE(0_int_kind)
01898
01899 call ice_distributionGet(dist, &
01900 numLocalBlocks = numBlocks, &
01901 nprocs = numProcs, &
01902 communicator = communicator)
01903
01904 do iblock=1,numBlocks
01905 call ice_distributionGetBlockID(dist, iblock, blockID)
01906
01907 this_block = get_block(blockID, blockID)
01908
01909 ib = this_block%ilo
01910 ie = this_block%ihi
01911 jb = this_block%jlo
01912 je = this_block%jhi
01913
01914 blockMaxval = -HUGE(0_int_kind)
01915
01916 if (present(lMask)) then
01917 do j=jb,je
01918 do i=ib,ie
01919 if (lMask(i,j,iblock)) then
01920 blockMaxval = max(blockMaxval,array(i,j,iblock))
01921 endif
01922 end do
01923 end do
01924 else
01925 do j=jb,je
01926 do i=ib,ie
01927 blockMaxval = max(blockMaxval,array(i,j,iblock))
01928 end do
01929 end do
01930 endif
01931
01932 localMaxval = max(localMaxval,blockMaxval)
01933
01934 end do
01935
01936
01937
01938
01939
01940
01941
01942 if (my_task < numProcs) then
01943 call MPI_ALLREDUCE(localMaxval, globalMaxval, 1, &
01944 MPI_INTEGER, MPI_MAX, communicator, ierr)
01945 endif
01946
01947
01948
01949 end function global_maxval_int
01950
01951
01952
01953
01954
01955
01956 function global_maxval_scalar_dbl (scalar, dist) &
01957 result(globalMaxval)
01958
01959
01960
01961
01962
01963
01964
01965
01966
01967
01968
01969
01970
01971
01972 real (dbl_kind), intent(in) ::
01973 scalar
01974
01975 type (distrb), intent(in) ::
01976 dist
01977
01978
01979
01980 real (dbl_kind) ::
01981 globalMaxval
01982
01983
01984
01985
01986
01987
01988
01989
01990
01991 integer (int_kind) ::
01992 ierr,
01993 numProcs,
01994 communicator
01995
01996
01997
01998 call ice_distributionGet(dist, &
01999 nprocs = numProcs, &
02000 communicator = communicator)
02001
02002
02003
02004
02005
02006
02007
02008 if (my_task < numProcs) then
02009 call MPI_ALLREDUCE(scalar, globalMaxval, 1, &
02010 mpiR8, MPI_MAX, communicator, ierr)
02011 endif
02012
02013
02014
02015 end function global_maxval_scalar_dbl
02016
02017
02018
02019
02020
02021
02022 function global_maxval_scalar_real (scalar, dist) &
02023 result(globalMaxval)
02024
02025
02026
02027
02028
02029
02030
02031
02032
02033
02034
02035
02036
02037
02038 real (real_kind), intent(in) ::
02039 scalar
02040
02041 type (distrb), intent(in) ::
02042 dist
02043
02044
02045
02046 real (real_kind) ::
02047 globalMaxval
02048
02049
02050
02051
02052
02053
02054
02055
02056
02057 integer (int_kind) ::
02058 ierr,
02059 numProcs,
02060 communicator
02061
02062
02063
02064 call ice_distributionGet(dist, &
02065 nprocs = numProcs, &
02066 communicator = communicator)
02067
02068
02069
02070
02071
02072
02073
02074 if (my_task < numProcs) then
02075 call MPI_ALLREDUCE(scalar, globalMaxval, 1, &
02076 mpiR4, MPI_MAX, communicator, ierr)
02077 endif
02078
02079
02080
02081 end function global_maxval_scalar_real
02082
02083
02084
02085
02086
02087
02088 function global_maxval_scalar_int (scalar, dist) &
02089 result(globalMaxval)
02090
02091
02092
02093
02094
02095
02096
02097
02098
02099
02100
02101
02102
02103
02104 integer (int_kind), intent(in) ::
02105 scalar
02106
02107 type (distrb), intent(in) ::
02108 dist
02109
02110
02111
02112 integer (int_kind) ::
02113 globalMaxval
02114
02115
02116
02117
02118
02119
02120
02121
02122
02123 integer (int_kind) ::
02124 ierr,
02125 numProcs,
02126 communicator
02127
02128
02129
02130 call ice_distributionGet(dist, &
02131 nprocs = numProcs, &
02132 communicator = communicator)
02133
02134
02135
02136
02137
02138
02139
02140 if (my_task < numProcs) then
02141 call MPI_ALLREDUCE(scalar, globalMaxval, 1, &
02142 MPI_INTEGER, MPI_MAX, communicator, ierr)
02143 endif
02144
02145
02146
02147 end function global_maxval_scalar_int
02148
02149
02150
02151
02152
02153
02154 function global_minval_dbl (array, dist, lMask) &
02155 result(globalMinval)
02156
02157
02158
02159
02160
02161
02162
02163
02164
02165
02166
02167
02168
02169 real (dbl_kind), dimension(:,:,:), intent(in) ::
02170 array
02171
02172 type (distrb), intent(in) ::
02173 dist
02174
02175 logical (log_kind), dimension(:,:,:), intent(in), optional ::
02176 lMask
02177
02178
02179
02180 real (dbl_kind) ::
02181 globalMinval
02182
02183
02184
02185
02186
02187
02188
02189
02190
02191 real (dbl_kind) ::
02192 blockMinval,
02193 localMinval
02194
02195 integer (int_kind) ::
02196 i,j,iblock,
02197 ib,ie,jb,je,
02198 ierr,
02199 numBlocks,
02200 numProcs,
02201 communicator,
02202 blockID
02203
02204 type (block) ::
02205 this_block
02206
02207
02208
02209 localMinval = HUGE(0.0_dbl_kind)
02210 globalMinval = HUGE(0.0_dbl_kind)
02211
02212 call ice_distributionGet(dist, &
02213 numLocalBlocks = numBlocks, &
02214 nprocs = numProcs, &
02215 communicator = communicator)
02216
02217 do iblock=1,numBlocks
02218 call ice_distributionGetBlockID(dist, iblock, blockID)
02219
02220 this_block = get_block(blockID, blockID)
02221
02222 ib = this_block%ilo
02223 ie = this_block%ihi
02224 jb = this_block%jlo
02225 je = this_block%jhi
02226
02227 blockMinval = HUGE(0.0_dbl_kind)
02228
02229 if (present(lMask)) then
02230 do j=jb,je
02231 do i=ib,ie
02232 if (lMask(i,j,iblock)) then
02233 blockMinval = min(blockMinval,array(i,j,iblock))
02234 endif
02235 end do
02236 end do
02237 else
02238 do j=jb,je
02239 do i=ib,ie
02240 blockMinval = min(blockMinval,array(i,j,iblock))
02241 end do
02242 end do
02243 endif
02244
02245 localMinval = min(localMinval,blockMinval)
02246
02247 end do
02248
02249
02250
02251
02252
02253
02254
02255 if (my_task < numProcs) then
02256 call MPI_ALLREDUCE(localMinval, globalMinval, 1, &
02257 mpiR8, MPI_MIN, communicator, ierr)
02258 endif
02259
02260
02261
02262 end function global_minval_dbl
02263
02264
02265
02266
02267
02268
02269 function global_minval_real (array, dist, lMask) &
02270 result(globalMinval)
02271
02272
02273
02274
02275
02276
02277
02278
02279
02280
02281
02282
02283
02284 real (real_kind), dimension(:,:,:), intent(in) ::
02285 array
02286
02287 type (distrb), intent(in) ::
02288 dist
02289
02290 logical (log_kind), dimension(:,:,:), intent(in), optional ::
02291 lMask
02292
02293
02294
02295 real (real_kind) ::
02296 globalMinval
02297
02298
02299
02300
02301
02302
02303
02304
02305
02306 real (real_kind) ::
02307 blockMinval,
02308 localMinval
02309
02310 integer (int_kind) ::
02311 i,j,iblock,
02312 ib,ie,jb,je,
02313 ierr,
02314 numBlocks,
02315 numProcs,
02316 communicator,
02317 blockID
02318
02319 type (block) ::
02320 this_block
02321
02322
02323
02324 localMinval = HUGE(0.0_real_kind)
02325 globalMinval = HUGE(0.0_real_kind)
02326
02327 call ice_distributionGet(dist, &
02328 numLocalBlocks = numBlocks, &
02329 nprocs = numProcs, &
02330 communicator = communicator)
02331
02332 do iblock=1,numBlocks
02333 call ice_distributionGetBlockID(dist, iblock, blockID)
02334
02335 this_block = get_block(blockID, blockID)
02336
02337 ib = this_block%ilo
02338 ie = this_block%ihi
02339 jb = this_block%jlo
02340 je = this_block%jhi
02341
02342 blockMinval = HUGE(0.0_real_kind)
02343
02344 if (present(lMask)) then
02345 do j=jb,je
02346 do i=ib,ie
02347 if (lMask(i,j,iblock)) then
02348 blockMinval = min(blockMinval,array(i,j,iblock))
02349 endif
02350 end do
02351 end do
02352 else
02353 do j=jb,je
02354 do i=ib,ie
02355 blockMinval = min(blockMinval,array(i,j,iblock))
02356 end do
02357 end do
02358 endif
02359
02360 localMinval = min(localMinval,blockMinval)
02361
02362 end do
02363
02364
02365
02366
02367
02368
02369
02370 if (my_task < numProcs) then
02371 call MPI_ALLREDUCE(localMinval, globalMinval, 1, &
02372 mpiR4, MPI_MIN, communicator, ierr)
02373 endif
02374
02375
02376
02377 end function global_minval_real
02378
02379
02380
02381
02382
02383
02384 function global_minval_int (array, dist, lMask) &
02385 result(globalMinval)
02386
02387
02388
02389
02390
02391
02392
02393
02394
02395
02396
02397
02398
02399 integer (int_kind), dimension(:,:,:), intent(in) ::
02400 array
02401
02402 type (distrb), intent(in) ::
02403 dist
02404
02405 logical (log_kind), dimension(:,:,:), intent(in), optional ::
02406 lMask
02407
02408
02409
02410 integer (int_kind) ::
02411 globalMinval
02412
02413
02414
02415
02416
02417
02418
02419
02420
02421 integer (int_kind) ::
02422 blockMinval,
02423 localMinval
02424
02425 integer (int_kind) ::
02426 i,j,iblock,
02427 ib,ie,jb,je,
02428 ierr,
02429 numBlocks,
02430 numProcs,
02431 communicator,
02432 blockID
02433
02434 type (block) ::
02435 this_block
02436
02437
02438
02439 localMinval = HUGE(0_int_kind)
02440 globalMinval = HUGE(0_int_kind)
02441
02442 call ice_distributionGet(dist, &
02443 numLocalBlocks = numBlocks, &
02444 nprocs = numProcs, &
02445 communicator = communicator)
02446
02447 do iblock=1,numBlocks
02448 call ice_distributionGetBlockID(dist, iblock, blockID)
02449
02450 this_block = get_block(blockID, blockID)
02451
02452 ib = this_block%ilo
02453 ie = this_block%ihi
02454 jb = this_block%jlo
02455 je = this_block%jhi
02456
02457 blockMinval = HUGE(0_int_kind)
02458
02459 if (present(lMask)) then
02460 do j=jb,je
02461 do i=ib,ie
02462 if (lMask(i,j,iblock)) then
02463 blockMinval = min(blockMinval,array(i,j,iblock))
02464 endif
02465 end do
02466 end do
02467 else
02468 do j=jb,je
02469 do i=ib,ie
02470 blockMinval = min(blockMinval,array(i,j,iblock))
02471 end do
02472 end do
02473 endif
02474
02475 localMinval = min(localMinval,blockMinval)
02476
02477 end do
02478
02479
02480
02481
02482
02483
02484
02485 if (my_task < numProcs) then
02486 call MPI_ALLREDUCE(localMinval, globalMinval, 1, &
02487 MPI_INTEGER, MPI_MIN, communicator, ierr)
02488 endif
02489
02490
02491
02492 end function global_minval_int
02493
02494
02495
02496
02497
02498
02499 function global_minval_scalar_dbl (scalar, dist) &
02500 result(globalMinval)
02501
02502
02503
02504
02505
02506
02507
02508
02509
02510
02511
02512
02513
02514
02515 real (dbl_kind), intent(in) ::
02516 scalar
02517
02518 type (distrb), intent(in) ::
02519 dist
02520
02521
02522
02523 real (dbl_kind) ::
02524 globalMinval
02525
02526
02527
02528
02529
02530
02531
02532
02533
02534 integer (int_kind) ::
02535 ierr,
02536 numProcs,
02537 communicator
02538
02539
02540
02541 call ice_distributionGet(dist, &
02542 nprocs = numProcs, &
02543 communicator = communicator)
02544
02545
02546
02547
02548
02549
02550
02551 if (my_task < numProcs) then
02552 call MPI_ALLREDUCE(scalar, globalMinval, 1, &
02553 mpiR8, MPI_MIN, communicator, ierr)
02554 endif
02555
02556
02557
02558 end function global_minval_scalar_dbl
02559
02560
02561
02562
02563
02564
02565 function global_minval_scalar_real (scalar, dist) &
02566 result(globalMinval)
02567
02568
02569
02570
02571
02572
02573
02574
02575
02576
02577
02578
02579
02580
02581 real (real_kind), intent(in) ::
02582 scalar
02583
02584 type (distrb), intent(in) ::
02585 dist
02586
02587
02588
02589 real (real_kind) ::
02590 globalMinval
02591
02592
02593
02594
02595
02596
02597
02598
02599
02600 integer (int_kind) ::
02601 ierr,
02602 numProcs,
02603 communicator
02604
02605
02606
02607 call ice_distributionGet(dist, &
02608 nprocs = numProcs, &
02609 communicator = communicator)
02610
02611
02612
02613
02614
02615
02616
02617 if (my_task < numProcs) then
02618 call MPI_ALLREDUCE(scalar, globalMinval, 1, &
02619 mpiR4, MPI_MIN, communicator, ierr)
02620 endif
02621
02622
02623
02624 end function global_minval_scalar_real
02625
02626
02627
02628
02629
02630
02631 function global_minval_scalar_int (scalar, dist) &
02632 result(globalMinval)
02633
02634
02635
02636
02637
02638
02639
02640
02641
02642
02643
02644
02645
02646
02647 integer (int_kind), intent(in) ::
02648 scalar
02649
02650 type (distrb), intent(in) ::
02651 dist
02652
02653
02654
02655 integer (int_kind) ::
02656 globalMinval
02657
02658
02659
02660
02661
02662
02663
02664
02665
02666 integer (int_kind) ::
02667 ierr,
02668 numProcs,
02669 communicator
02670
02671
02672
02673 call ice_distributionGet(dist, &
02674 nprocs = numProcs, &
02675 communicator = communicator)
02676
02677
02678
02679
02680
02681
02682
02683 if (my_task < numProcs) then
02684 call MPI_ALLREDUCE(scalar, globalMinval, 1, &
02685 MPI_INTEGER, MPI_MIN, communicator, ierr)
02686 endif
02687
02688
02689
02690 end function global_minval_scalar_int
02691
02692
02693
02694 end module ice_global_reductions
02695
02696