CESM_Driver: shr_mpi_mod.F90 Source File

00001 !===============================================================================
00002 ! SVN $Id: shr_mpi_mod.F90 18887 2009-10-13 23:42:53Z tcraig $
00003 ! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/branch_tags/cesm1_0_rel_tags/cesm1_0_rel01_share3_100616/shr/shr_mpi_mod.F90 $
00004 !===============================================================================
00005 
00006 Module shr_mpi_mod
00007 
00008 !-------------------------------------------------------------------------------
00009 ! PURPOSE: general layer on MPI functions
00010 !-------------------------------------------------------------------------------
00011 
00012    use shr_kind_mod
00013    use shr_log_mod, only: s_loglev  => shr_log_Level
00014    use shr_log_mod, only: s_logunit => shr_log_Unit
00015 
00016    implicit none
00017    private
00018 
00019 ! PUBLIC: Public interfaces
00020 
00021    public :: shr_mpi_chkerr
00022    public :: shr_mpi_send
00023    public :: shr_mpi_recv
00024    public :: shr_mpi_bcast
00025    public :: shr_mpi_gathScatVInit
00026    public :: shr_mpi_gatherV
00027    public :: shr_mpi_scatterV
00028    public :: shr_mpi_sum
00029    public :: shr_mpi_min
00030    public :: shr_mpi_max
00031    public :: shr_mpi_commsize
00032    public :: shr_mpi_commrank
00033    public :: shr_mpi_initialized
00034    public :: shr_mpi_abort
00035    public :: shr_mpi_barrier
00036    public :: shr_mpi_init
00037    public :: shr_mpi_finalize
00038 
00039    interface shr_mpi_send ; module procedure &
00040      shr_mpi_sendi0, &
00041      shr_mpi_sendi1, &
00042      shr_mpi_sendr0, &
00043      shr_mpi_sendr1, &
00044      shr_mpi_sendr3
00045    end interface
00046    interface shr_mpi_recv ; module procedure &
00047      shr_mpi_recvi0, &
00048      shr_mpi_recvi1, &
00049      shr_mpi_recvr0, &
00050      shr_mpi_recvr1, &
00051      shr_mpi_recvr3
00052    end interface
00053    interface shr_mpi_bcast ; module procedure &
00054      shr_mpi_bcastc0, &
00055      shr_mpi_bcastc1, &
00056      shr_mpi_bcastl0, &
00057      shr_mpi_bcastl1, &
00058      shr_mpi_bcasti0, &
00059      shr_mpi_bcasti1, &
00060      shr_mpi_bcasti2, &
00061      shr_mpi_bcastr0, &
00062      shr_mpi_bcastr1, &
00063      shr_mpi_bcastr2, &
00064      shr_mpi_bcastr3
00065    end interface
00066    interface shr_mpi_gathScatVInit ; module procedure &
00067      shr_mpi_gathScatVInitr1
00068    end interface
00069    interface shr_mpi_gatherv ; module procedure &
00070      shr_mpi_gatherVr1
00071    end interface
00072    interface shr_mpi_scatterv ; module procedure &
00073      shr_mpi_scatterVr1
00074    end interface
00075    interface shr_mpi_sum ; module procedure &
00076      shr_mpi_sumi0, &
00077      shr_mpi_sumi1, &
00078      shr_mpi_sumb0, &
00079      shr_mpi_sumb1, &
00080      shr_mpi_sumr0, &
00081      shr_mpi_sumr1, &
00082      shr_mpi_sumr2, &
00083      shr_mpi_sumr3
00084    end interface
00085    interface shr_mpi_min ; module procedure &
00086      shr_mpi_mini0, &
00087      shr_mpi_mini1, &
00088      shr_mpi_minr0, &
00089      shr_mpi_minr1
00090    end interface
00091    interface shr_mpi_max ; module procedure &
00092      shr_mpi_maxi0, &
00093      shr_mpi_maxi1, &
00094      shr_mpi_maxr0, &
00095      shr_mpi_maxr1
00096    end interface
00097 
00098 #include <mpif.h>         ! mpi library include file
00099 
00100 !===============================================================================
00101 CONTAINS
00102 !===============================================================================
00103 
00104 SUBROUTINE shr_mpi_chkerr(rcode,string)
00105 
00106    IMPLICIT none
00107 
00108    !----- arguments ---
00109    integer(SHR_KIND_IN), intent(in) :: rcode  ! input MPI error code
00110    character(*),         intent(in) :: string ! message
00111 
00112    !----- local ---
00113    character(*),parameter           :: subName = '(shr_mpi_chkerr) '
00114    character(MPI_MAX_ERROR_STRING)  :: lstring
00115    integer(SHR_KIND_IN)             :: len
00116    integer(SHR_KIND_IN)             :: ierr
00117 
00118 !-------------------------------------------------------------------------------
00119 ! PURPOSE: layer on MPI error checking
00120 !-------------------------------------------------------------------------------
00121 
00122    if (rcode /= MPI_SUCCESS) then
00123      call MPI_ERROR_STRING(rcode,lstring,len,ierr)
00124      write(s_logunit,*) trim(subName),":",lstring(1:len)
00125      call shr_mpi_abort(string,rcode)
00126    endif
00127 
00128 END SUBROUTINE shr_mpi_chkerr
00129 
00130 !===============================================================================
00131 !===============================================================================
00132 
00133 SUBROUTINE shr_mpi_sendi0(lvec,pid,tag,comm,string)
00134 
00135    IMPLICIT none
00136 
00137    !----- arguments ---
00138    integer(SHR_KIND_IN), intent(in) :: lvec     ! send value
00139    integer(SHR_KIND_IN), intent(in) :: pid      ! pid to send to
00140    integer(SHR_KIND_IN), intent(in) :: tag      ! tag
00141    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
00142    character(*),optional,intent(in) :: string   ! message
00143 
00144    !----- local ---
00145    character(*),parameter           :: subName = '(shr_mpi_sendi0) '
00146    integer(SHR_KIND_IN)             :: lsize
00147    integer(SHR_KIND_IN)             :: ierr
00148 
00149 !-------------------------------------------------------------------------------
00150 ! PURPOSE: Send a single integer
00151 !-------------------------------------------------------------------------------
00152 
00153    lsize = 1
00154 
00155    call MPI_SEND(lvec,lsize,MPI_INTEGER,pid,tag,comm,ierr)
00156    if (present(string)) then
00157      call shr_mpi_chkerr(ierr,subName//trim(string))
00158    else
00159      call shr_mpi_chkerr(ierr,subName)
00160    endif
00161 
00162 END SUBROUTINE shr_mpi_sendi0
00163 
00164 !===============================================================================
00165 !===============================================================================
00166 
00167 SUBROUTINE shr_mpi_sendi1(lvec,pid,tag,comm,string)
00168 
00169    IMPLICIT none
00170 
00171    !----- arguments ---
00172    integer(SHR_KIND_IN), intent(in) :: lvec(:)  ! in/out local values
00173    integer(SHR_KIND_IN), intent(in) :: pid      ! pid to send to
00174    integer(SHR_KIND_IN), intent(in) :: tag      ! tag
00175    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
00176    character(*),optional,intent(in) :: string   ! message
00177 
00178    !----- local ---
00179    character(*),parameter           :: subName = '(shr_mpi_sendi1) '
00180    integer(SHR_KIND_IN)             :: lsize
00181    integer(SHR_KIND_IN)             :: ierr
00182 
00183 !-------------------------------------------------------------------------------
00184 ! PURPOSE: Send a vector of integers
00185 !-------------------------------------------------------------------------------
00186 
00187    lsize = size(lvec)
00188 
00189    call MPI_SEND(lvec,lsize,MPI_INTEGER,pid,tag,comm,ierr)
00190    if (present(string)) then
00191      call shr_mpi_chkerr(ierr,subName//trim(string))
00192    else
00193      call shr_mpi_chkerr(ierr,subName)
00194    endif
00195 
00196 END SUBROUTINE shr_mpi_sendi1
00197 
00198 !===============================================================================
00199 !===============================================================================
00200 
00201 SUBROUTINE shr_mpi_sendr0(lvec,pid,tag,comm,string)
00202 
00203    IMPLICIT none
00204 
00205    !----- arguments ---
00206    real(SHR_KIND_R8),    intent(in) :: lvec     ! in/out local values
00207    integer(SHR_KIND_IN), intent(in) :: pid      ! pid to send to
00208    integer(SHR_KIND_IN), intent(in) :: tag      ! tag
00209    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
00210    character(*),optional,intent(in) :: string   ! message
00211 
00212    !----- local ---
00213    character(*),parameter           :: subName = '(shr_mpi_sendr0) '
00214    integer(SHR_KIND_IN)             :: lsize
00215    integer(SHR_KIND_IN)             :: ierr
00216 
00217 !-------------------------------------------------------------------------------
00218 ! PURPOSE: Send a real scalar
00219 !-------------------------------------------------------------------------------
00220 
00221    lsize = 1
00222 
00223    call MPI_SEND(lvec,lsize,MPI_REAL8,pid,tag,comm,ierr)
00224    if (present(string)) then
00225      call shr_mpi_chkerr(ierr,subName//trim(string))
00226    else
00227      call shr_mpi_chkerr(ierr,subName)
00228    endif
00229 
00230 END SUBROUTINE shr_mpi_sendr0
00231 
00232 !===============================================================================
00233 !===============================================================================
00234 
00235 SUBROUTINE shr_mpi_sendr1(lvec,pid,tag,comm,string)
00236 
00237    IMPLICIT none
00238 
00239    !----- arguments ---
00240    real(SHR_KIND_R8),    intent(in) :: lvec(:)  ! in/out local values
00241    integer(SHR_KIND_IN), intent(in) :: pid      ! pid to send to
00242    integer(SHR_KIND_IN), intent(in) :: tag      ! tag
00243    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
00244    character(*),optional,intent(in) :: string   ! message
00245 
00246    !----- local ---
00247    character(*),parameter           :: subName = '(shr_mpi_sendr1) '
00248    integer(SHR_KIND_IN)             :: lsize
00249    integer(SHR_KIND_IN)             :: ierr
00250 
00251 !-------------------------------------------------------------------------------
00252 ! PURPOSE: Send a vector of reals
00253 !-------------------------------------------------------------------------------
00254 
00255    lsize = size(lvec)
00256 
00257    call MPI_SEND(lvec,lsize,MPI_REAL8,pid,tag,comm,ierr)
00258    if (present(string)) then
00259      call shr_mpi_chkerr(ierr,subName//trim(string))
00260    else
00261      call shr_mpi_chkerr(ierr,subName)
00262    endif
00263 
00264 END SUBROUTINE shr_mpi_sendr1
00265 
00266 !===============================================================================
00267 !===============================================================================
00268 
00269 SUBROUTINE shr_mpi_sendr3(array,pid,tag,comm,string)
00270 
00271    IMPLICIT none
00272 
00273    !----- arguments ---
00274    real   (SHR_KIND_R8), intent(in) :: array(:,:,:)  ! in/out local values
00275    integer(SHR_KIND_IN), intent(in) :: pid           ! pid to send to
00276    integer(SHR_KIND_IN), intent(in) :: tag           ! tag
00277    integer(SHR_KIND_IN), intent(in) :: comm          ! mpi communicator
00278    character(*),optional,intent(in) :: string        ! message
00279 
00280    !----- local ---
00281    character(*),parameter           :: subName = '(shr_mpi_sendr3) '
00282    integer(SHR_KIND_IN)             :: lsize
00283    integer(SHR_KIND_IN)             :: ierr
00284 
00285 !-------------------------------------------------------------------------------
00286 ! PURPOSE: Send a vector of reals
00287 !-------------------------------------------------------------------------------
00288 
00289    lsize = size(array)
00290 
00291    call MPI_SEND(array,lsize,MPI_REAL8,pid,tag,comm,ierr)
00292    if (present(string)) then
00293      call shr_mpi_chkerr(ierr,subName//trim(string))
00294    else
00295      call shr_mpi_chkerr(ierr,subName)
00296    endif
00297 
00298 END SUBROUTINE shr_mpi_sendr3
00299 
00300 !===============================================================================
00301 !===============================================================================
00302 
00303 SUBROUTINE shr_mpi_recvi0(lvec,pid,tag,comm,string)
00304 
00305    IMPLICIT none
00306 
00307    !----- arguments ---
00308    integer(SHR_KIND_IN), intent(out):: lvec     ! in/out local values
00309    integer(SHR_KIND_IN), intent(in) :: pid      ! pid to recv from
00310    integer(SHR_KIND_IN), intent(in) :: tag      ! tag
00311    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
00312    character(*),optional,intent(in) :: string   ! message
00313 
00314    !----- local ---
00315    character(*),parameter           :: subName = '(shr_mpi_recvi0) '
00316    integer(SHR_KIND_IN)             :: lsize
00317    integer(SHR_KIND_IN)             :: status(MPI_STATUS_SIZE)  ! mpi status info
00318    integer(SHR_KIND_IN)             :: ierr
00319 
00320 !-------------------------------------------------------------------------------
00321 ! PURPOSE: Recv a vector of reals
00322 !-------------------------------------------------------------------------------
00323 
00324    lsize = 1
00325 
00326    call MPI_RECV(lvec,lsize,MPI_INTEGER,pid,tag,comm,status,ierr)
00327    if (present(string)) then
00328      call shr_mpi_chkerr(ierr,subName//trim(string))
00329    else
00330      call shr_mpi_chkerr(ierr,subName)
00331    endif
00332 
00333 END SUBROUTINE shr_mpi_recvi0
00334 
00335 !===============================================================================
00336 !===============================================================================
00337 
00338 SUBROUTINE shr_mpi_recvi1(lvec,pid,tag,comm,string)
00339 
00340    IMPLICIT none
00341 
00342    !----- arguments ---
00343    integer(SHR_KIND_IN), intent(out):: lvec(:)  ! in/out local values
00344    integer(SHR_KIND_IN), intent(in) :: pid      ! pid to recv from
00345    integer(SHR_KIND_IN), intent(in) :: tag      ! tag
00346    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
00347    character(*),optional,intent(in) :: string   ! message
00348 
00349    !----- local ---
00350    character(*),parameter           :: subName = '(shr_mpi_recvi1) '
00351    integer(SHR_KIND_IN)             :: lsize
00352    integer(SHR_KIND_IN)             :: status(MPI_STATUS_SIZE)  ! mpi status info
00353    integer(SHR_KIND_IN)             :: ierr
00354 
00355 !-------------------------------------------------------------------------------
00356 ! PURPOSE: Recv a vector of reals
00357 !-------------------------------------------------------------------------------
00358 
00359    lsize = size(lvec)
00360 
00361    call MPI_RECV(lvec,lsize,MPI_INTEGER,pid,tag,comm,status,ierr)
00362    if (present(string)) then
00363      call shr_mpi_chkerr(ierr,subName//trim(string))
00364    else
00365      call shr_mpi_chkerr(ierr,subName)
00366    endif
00367 
00368 END SUBROUTINE shr_mpi_recvi1
00369 
00370 !===============================================================================
00371 !===============================================================================
00372 
00373 SUBROUTINE shr_mpi_recvr0(lvec,pid,tag,comm,string)
00374 
00375    IMPLICIT none
00376 
00377    !----- arguments ---
00378    real(SHR_KIND_R8),    intent(out):: lvec     ! in/out local values
00379    integer(SHR_KIND_IN), intent(in) :: pid      ! pid to recv from
00380    integer(SHR_KIND_IN), intent(in) :: tag      ! tag
00381    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
00382    character(*),optional,intent(in) :: string   ! message
00383 
00384    !----- local ---
00385    character(*),parameter           :: subName = '(shr_mpi_recvr0) '
00386    integer(SHR_KIND_IN)             :: lsize
00387    integer(SHR_KIND_IN)             :: status(MPI_STATUS_SIZE)  ! mpi status info
00388    integer(SHR_KIND_IN)             :: ierr
00389 
00390 !-------------------------------------------------------------------------------
00391 ! PURPOSE: Recv a vector of reals
00392 !-------------------------------------------------------------------------------
00393 
00394    lsize = 1
00395 
00396    call MPI_RECV(lvec,lsize,MPI_REAL8,pid,tag,comm,status,ierr)
00397    if (present(string)) then
00398      call shr_mpi_chkerr(ierr,subName//trim(string))
00399    else
00400      call shr_mpi_chkerr(ierr,subName)
00401    endif
00402 
00403 END SUBROUTINE shr_mpi_recvr0
00404 
00405 !===============================================================================
00406 !===============================================================================
00407 
00408 SUBROUTINE shr_mpi_recvr1(lvec,pid,tag,comm,string)
00409 
00410    IMPLICIT none
00411 
00412    !----- arguments ---
00413    real(SHR_KIND_R8),    intent(out):: lvec(:)  ! in/out local values
00414    integer(SHR_KIND_IN), intent(in) :: pid      ! pid to recv from
00415    integer(SHR_KIND_IN), intent(in) :: tag      ! tag
00416    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
00417    character(*),optional,intent(in) :: string   ! message
00418 
00419    !----- local ---
00420    character(*),parameter           :: subName = '(shr_mpi_recvr1) '
00421    integer(SHR_KIND_IN)             :: lsize
00422    integer(SHR_KIND_IN)             :: status(MPI_STATUS_SIZE)  ! mpi status info
00423    integer(SHR_KIND_IN)             :: ierr
00424 
00425 !-------------------------------------------------------------------------------
00426 ! PURPOSE: Recv a vector of reals
00427 !-------------------------------------------------------------------------------
00428 
00429    lsize = size(lvec)
00430 
00431    call MPI_RECV(lvec,lsize,MPI_REAL8,pid,tag,comm,status,ierr)
00432    if (present(string)) then
00433      call shr_mpi_chkerr(ierr,subName//trim(string))
00434    else
00435      call shr_mpi_chkerr(ierr,subName)
00436    endif
00437 
00438 END SUBROUTINE shr_mpi_recvr1
00439 
00440 !===============================================================================
00441 !===============================================================================
00442 
00443 SUBROUTINE shr_mpi_recvr3(array,pid,tag,comm,string)
00444 
00445    IMPLICIT none
00446 
00447    !----- arguments ---
00448    real   (SHR_KIND_R8), intent(out):: array(:,:,:)  ! in/out local values
00449    integer(SHR_KIND_IN), intent(in) :: pid           ! pid to recv from
00450    integer(SHR_KIND_IN), intent(in) :: tag           ! tag
00451    integer(SHR_KIND_IN), intent(in) :: comm          ! mpi communicator
00452    character(*),optional,intent(in) :: string        ! message
00453 
00454    !----- local ---
00455    character(*),parameter           :: subName = '(shr_mpi_recvr3) '
00456    integer(SHR_KIND_IN)             :: lsize
00457    integer(SHR_KIND_IN)             :: status(MPI_STATUS_SIZE)  ! mpi status info
00458    integer(SHR_KIND_IN)             :: ierr
00459 
00460 !-------------------------------------------------------------------------------
00461 ! PURPOSE: Recv a vector of reals
00462 !-------------------------------------------------------------------------------
00463 
00464    lsize = size(array)
00465 
00466    call MPI_RECV(array,lsize,MPI_REAL8,pid,tag,comm,status,ierr)
00467    if (present(string)) then
00468      call shr_mpi_chkerr(ierr,subName//trim(string))
00469    else
00470      call shr_mpi_chkerr(ierr,subName)
00471    endif
00472 
00473 END SUBROUTINE shr_mpi_recvr3
00474 
00475 !===============================================================================
00476 !===============================================================================
00477 
00478 SUBROUTINE shr_mpi_bcasti0(vec,comm,string,pebcast)
00479 
00480    IMPLICIT none
00481 
00482    !----- arguments ---
00483    integer(SHR_KIND_IN), intent(inout):: vec      ! vector of 1
00484    integer(SHR_KIND_IN), intent(in)   :: comm     ! mpi communicator
00485    character(*),optional,intent(in)   :: string   ! message
00486    integer(SHR_KIND_IN), optional, intent(in)   :: pebcast  ! bcast pe (otherwise zero)
00487 
00488    !----- local ---
00489    character(*),parameter             :: subName = '(shr_mpi_bcasti0) '
00490    integer(SHR_KIND_IN)               :: ierr
00491    integer(SHR_KIND_IN)               :: lsize
00492    integer(SHR_KIND_IN)               :: lpebcast
00493 
00494 !-------------------------------------------------------------------------------
00495 ! PURPOSE: Broadcast an integer
00496 !-------------------------------------------------------------------------------
00497 
00498    lsize = 1
00499    lpebcast = 0
00500    if (present(pebcast)) lpebcast = pebcast
00501 
00502    call MPI_BCAST(vec,lsize,MPI_INTEGER,lpebcast,comm,ierr)
00503    if (present(string)) then
00504      call shr_mpi_chkerr(ierr,subName//trim(string))
00505    else
00506      call shr_mpi_chkerr(ierr,subName)
00507    endif
00508 
00509 END SUBROUTINE shr_mpi_bcasti0
00510 
00511 !===============================================================================
00512 !===============================================================================
00513 
00514 SUBROUTINE shr_mpi_bcastl0(vec,comm,string,pebcast)
00515 
00516    IMPLICIT none
00517 
00518    !----- arguments ---
00519    logical, intent(inout):: vec      ! vector of 1
00520    integer(SHR_KIND_IN), intent(in)   :: comm     ! mpi communicator
00521    character(*),optional,intent(in)   :: string   ! message
00522    integer(SHR_KIND_IN), optional, intent(in)   :: pebcast  ! bcast pe (otherwise zero)
00523 
00524    !----- local ---
00525    character(*),parameter             :: subName = '(shr_mpi_bcastl0) '
00526    integer(SHR_KIND_IN)               :: ierr
00527    integer(SHR_KIND_IN)               :: lsize
00528    integer(SHR_KIND_IN)               :: lpebcast
00529 
00530 !-------------------------------------------------------------------------------
00531 ! PURPOSE: Broadcast a logical
00532 !-------------------------------------------------------------------------------
00533 
00534    lsize = 1
00535    lpebcast = 0
00536    if (present(pebcast)) lpebcast = pebcast
00537 
00538    call MPI_BCAST(vec,lsize,MPI_LOGICAL,lpebcast,comm,ierr)
00539    if (present(string)) then
00540      call shr_mpi_chkerr(ierr,subName//trim(string))
00541    else
00542      call shr_mpi_chkerr(ierr,subName)
00543    endif
00544 
00545 END SUBROUTINE shr_mpi_bcastl0
00546 
00547 !===============================================================================
00548 !===============================================================================
00549 
00550 SUBROUTINE shr_mpi_bcastc0(vec,comm,string,pebcast)
00551 
00552    IMPLICIT none
00553 
00554    !----- arguments ---
00555    character(len=*), intent(inout)    :: vec      ! vector of 1
00556    integer(SHR_KIND_IN), intent(in)   :: comm     ! mpi communicator
00557    character(*),optional,intent(in)   :: string   ! message
00558    integer(SHR_KIND_IN), optional, intent(in)   :: pebcast  ! bcast pe (otherwise zero)
00559 
00560    !----- local ---
00561    character(*),parameter             :: subName = '(shr_mpi_bcastc0) '
00562    integer(SHR_KIND_IN)               :: ierr
00563    integer(SHR_KIND_IN)               :: lsize
00564    integer(SHR_KIND_IN)               :: lpebcast
00565 
00566 !-------------------------------------------------------------------------------
00567 ! PURPOSE: Broadcast a character string
00568 !-------------------------------------------------------------------------------
00569 
00570    lsize = len(vec)
00571    lpebcast = 0
00572    if (present(pebcast)) lpebcast = pebcast
00573 
00574    call MPI_BCAST(vec,lsize,MPI_CHARACTER,lpebcast,comm,ierr)
00575    if (present(string)) then
00576      call shr_mpi_chkerr(ierr,subName//trim(string))
00577    else
00578      call shr_mpi_chkerr(ierr,subName)
00579    endif
00580 
00581 END SUBROUTINE shr_mpi_bcastc0
00582 
00583 !===============================================================================
00584 !===============================================================================
00585 
00586 SUBROUTINE shr_mpi_bcastc1(vec,comm,string,pebcast)
00587 
00588    IMPLICIT none
00589 
00590    !----- arguments ---
00591    character(len=*), intent(inout)    :: vec(:)   ! 1D vector
00592    integer(SHR_KIND_IN), intent(in)   :: comm     ! mpi communicator
00593    character(*),optional,intent(in)   :: string   ! message
00594    integer(SHR_KIND_IN), optional, intent(in)   :: pebcast  ! bcast pe (otherwise zero)
00595 
00596    !----- local ---
00597    character(*),parameter             :: subName = '(shr_mpi_bcastc1) '
00598    integer(SHR_KIND_IN)               :: ierr
00599    integer(SHR_KIND_IN)               :: lsize
00600    integer(SHR_KIND_IN)               :: lpebcast
00601 
00602 !-------------------------------------------------------------------------------
00603 ! PURPOSE: Broadcast a character string
00604 !-------------------------------------------------------------------------------
00605 
00606    lsize = size(vec)*len(vec)
00607    lpebcast = 0
00608    if (present(pebcast)) lpebcast = pebcast
00609 
00610    call MPI_BCAST(vec,lsize,MPI_CHARACTER,lpebcast,comm,ierr)
00611    if (present(string)) then
00612      call shr_mpi_chkerr(ierr,subName//trim(string))
00613    else
00614      call shr_mpi_chkerr(ierr,subName)
00615    endif
00616 
00617 END SUBROUTINE shr_mpi_bcastc1
00618 
00619 !===============================================================================
00620 !===============================================================================
00621 
00622 SUBROUTINE shr_mpi_bcastr0(vec,comm,string,pebcast)
00623 
00624    IMPLICIT none
00625 
00626    !----- arguments ---
00627    real(SHR_KIND_R8),    intent(inout):: vec      ! vector of 1
00628    integer(SHR_KIND_IN), intent(in)   :: comm     ! mpi communicator
00629    character(*),optional,intent(in)   :: string   ! message
00630    integer(SHR_KIND_IN), optional, intent(in)   :: pebcast  ! bcast pe (otherwise zero)
00631 
00632    !----- local ---
00633    character(*),parameter             :: subName = '(shr_mpi_bcastr0) '
00634    integer(SHR_KIND_IN)               :: ierr
00635    integer(SHR_KIND_IN)               :: lsize
00636    integer(SHR_KIND_IN)               :: lpebcast
00637 
00638 !-------------------------------------------------------------------------------
00639 ! PURPOSE: Broadcast a real
00640 !-------------------------------------------------------------------------------
00641 
00642    lsize = 1
00643    lpebcast = 0
00644    if (present(pebcast)) lpebcast = pebcast
00645 
00646    call MPI_BCAST(vec,lsize,MPI_REAL8,lpebcast,comm,ierr)
00647    if (present(string)) then
00648      call shr_mpi_chkerr(ierr,subName//trim(string))
00649    else
00650      call shr_mpi_chkerr(ierr,subName)
00651    endif
00652 
00653 END SUBROUTINE shr_mpi_bcastr0
00654 
00655 !===============================================================================
00656 !===============================================================================
00657 
00658 SUBROUTINE shr_mpi_bcasti1(vec,comm,string,pebcast)
00659 
00660    IMPLICIT none
00661 
00662    !----- arguments ---
00663    integer(SHR_KIND_IN), intent(inout):: vec(:)   ! vector 
00664    integer(SHR_KIND_IN), intent(in)   :: comm     ! mpi communicator
00665    character(*),optional,intent(in)   :: string   ! message
00666    integer(SHR_KIND_IN), optional, intent(in)   :: pebcast  ! bcast pe (otherwise zero)
00667 
00668    !----- local ---
00669    character(*),parameter             :: subName = '(shr_mpi_bcasti1) '
00670    integer(SHR_KIND_IN)               :: ierr
00671    integer(SHR_KIND_IN)               :: lsize
00672    integer(SHR_KIND_IN)               :: lpebcast
00673 
00674 !-------------------------------------------------------------------------------
00675 ! PURPOSE: Broadcast a vector of integers
00676 !-------------------------------------------------------------------------------
00677 
00678    lsize = size(vec)
00679    lpebcast = 0
00680    if (present(pebcast)) lpebcast = pebcast
00681 
00682    call MPI_BCAST(vec,lsize,MPI_INTEGER,lpebcast,comm,ierr)
00683    if (present(string)) then
00684      call shr_mpi_chkerr(ierr,subName//trim(string))
00685    else
00686      call shr_mpi_chkerr(ierr,subName)
00687    endif
00688 
00689 END SUBROUTINE shr_mpi_bcasti1
00690 
00691 !===============================================================================
00692 !===============================================================================
00693 
00694 SUBROUTINE shr_mpi_bcastl1(vec,comm,string,pebcast)
00695 
00696    IMPLICIT none
00697 
00698    !----- arguments ---
00699    logical, intent(inout):: vec(:)      ! vector of 1
00700    integer(SHR_KIND_IN), intent(in)   :: comm     ! mpi communicator
00701    character(*),optional,intent(in)   :: string   ! message
00702    integer(SHR_KIND_IN), optional, intent(in)   :: pebcast  ! bcast pe (otherwise zero)
00703 
00704    !----- local ---
00705    character(*),parameter             :: subName = '(shr_mpi_bcastl1) '
00706    integer(SHR_KIND_IN)               :: ierr
00707    integer(SHR_KIND_IN)               :: lsize
00708    integer(SHR_KIND_IN)               :: lpebcast
00709 
00710 !-------------------------------------------------------------------------------
00711 ! PURPOSE: Broadcast a logical
00712 !-------------------------------------------------------------------------------
00713 
00714    lsize = size(vec)
00715    lpebcast = 0
00716    if (present(pebcast)) lpebcast = pebcast
00717 
00718    call MPI_BCAST(vec,lsize,MPI_LOGICAL,lpebcast,comm,ierr)
00719    if (present(string)) then
00720      call shr_mpi_chkerr(ierr,subName//trim(string))
00721    else
00722      call shr_mpi_chkerr(ierr,subName)
00723    endif
00724 
00725 END SUBROUTINE shr_mpi_bcastl1
00726 
00727 !===============================================================================
00728 !===============================================================================
00729 
00730 SUBROUTINE shr_mpi_bcastr1(vec,comm,string,pebcast)
00731 
00732    IMPLICIT none
00733 
00734    !----- arguments ---
00735    real(SHR_KIND_R8),    intent(inout):: vec(:)   ! vector 
00736    integer(SHR_KIND_IN), intent(in)   :: comm     ! mpi communicator
00737    character(*),optional,intent(in)   :: string   ! message
00738    integer(SHR_KIND_IN), optional, intent(in)   :: pebcast  ! bcast pe (otherwise zero)
00739 
00740    !----- local ---
00741    character(*),parameter             :: subName = '(shr_mpi_bcastr1) '
00742    integer(SHR_KIND_IN)               :: ierr
00743    integer(SHR_KIND_IN)               :: lsize
00744    integer(SHR_KIND_IN)               :: lpebcast
00745 
00746 !-------------------------------------------------------------------------------
00747 ! PURPOSE: Broadcast a vector of reals
00748 !-------------------------------------------------------------------------------
00749 
00750    lsize = size(vec)
00751    lpebcast = 0
00752    if (present(pebcast)) lpebcast = pebcast
00753 
00754    call MPI_BCAST(vec,lsize,MPI_REAL8,lpebcast,comm,ierr)
00755    if (present(string)) then
00756      call shr_mpi_chkerr(ierr,subName//trim(string))
00757    else
00758      call shr_mpi_chkerr(ierr,subName)
00759    endif
00760 
00761 END SUBROUTINE shr_mpi_bcastr1
00762 
00763 !===============================================================================
00764 !===============================================================================
00765 
00766 SUBROUTINE shr_mpi_bcastr2(arr,comm,string,pebcast)
00767 
00768    IMPLICIT none
00769 
00770    !----- arguments -----
00771    real(SHR_KIND_R8),    intent(inout):: arr(:,:) ! array, 2d 
00772    integer(SHR_KIND_IN), intent(in)   :: comm     ! mpi communicator
00773    character(*),optional,intent(in)   :: string   ! message
00774    integer(SHR_KIND_IN), optional, intent(in)   :: pebcast  ! bcast pe (otherwise zero)
00775 
00776    !----- local -----
00777    integer(SHR_KIND_IN)               :: ierr
00778    integer(SHR_KIND_IN)               :: lsize
00779    integer(SHR_KIND_IN)               :: lpebcast
00780 
00781    !----- formats -----
00782    character(*),parameter             :: subName = '(shr_mpi_bcastr2) '
00783 
00784 !-------------------------------------------------------------------------------
00785 ! PURPOSE: Broadcast a 2d array of reals
00786 !-------------------------------------------------------------------------------
00787 
00788    lsize = size(arr)
00789    lpebcast = 0
00790    if (present(pebcast)) lpebcast = pebcast
00791 
00792    call MPI_BCAST(arr,lsize,MPI_REAL8,lpebcast,comm,ierr)
00793    if (present(string)) then
00794      call shr_mpi_chkerr(ierr,subName//trim(string))
00795    else
00796      call shr_mpi_chkerr(ierr,subName)
00797    endif
00798 
00799 END SUBROUTINE shr_mpi_bcastr2
00800 
00801 !===============================================================================
00802 !===============================================================================
00803 
00804 SUBROUTINE shr_mpi_bcasti2(arr,comm,string,pebcast)
00805 
00806    IMPLICIT none
00807 
00808    !----- arguments -----
00809    integer,              intent(inout):: arr(:,:) ! array, 2d 
00810    integer(SHR_KIND_IN), intent(in)   :: comm     ! mpi communicator
00811    character(*),optional,intent(in)   :: string   ! message
00812    integer(SHR_KIND_IN), optional, intent(in)   :: pebcast  ! bcast pe (otherwise zero)
00813 
00814    !----- local -----
00815    integer(SHR_KIND_IN)               :: ierr
00816    integer(SHR_KIND_IN)               :: lsize
00817    integer(SHR_KIND_IN)               :: lpebcast
00818 
00819    !----- formats -----
00820    character(*),parameter             :: subName = '(shr_mpi_bcasti2) '
00821 
00822 !-------------------------------------------------------------------------------
00823 ! PURPOSE: Broadcast a 2d array of integers
00824 !-------------------------------------------------------------------------------
00825 
00826    lsize = size(arr)
00827    lpebcast = 0
00828    if (present(pebcast)) lpebcast = pebcast
00829 
00830    call MPI_BCAST(arr,lsize,MPI_INTEGER,lpebcast,comm,ierr)
00831    if (present(string)) then
00832      call shr_mpi_chkerr(ierr,subName//trim(string))
00833    else
00834      call shr_mpi_chkerr(ierr,subName)
00835    endif
00836 
00837 END SUBROUTINE shr_mpi_bcasti2
00838 
00839 !===============================================================================
00840 !===============================================================================
00841 
00842 SUBROUTINE shr_mpi_bcastr3(arr,comm,string,pebcast)
00843 
00844    IMPLICIT none
00845 
00846    !----- arguments -----
00847    real(SHR_KIND_R8),    intent(inout):: arr(:,:,:) ! array, 3d 
00848    integer(SHR_KIND_IN), intent(in)   :: comm       ! mpi communicator
00849    character(*),optional,intent(in)   :: string     ! message
00850    integer(SHR_KIND_IN), optional, intent(in)   :: pebcast  ! bcast pe (otherwise zero)
00851 
00852    !----- local -----
00853    integer(SHR_KIND_IN)               :: ierr
00854    integer(SHR_KIND_IN)               :: lsize
00855    integer(SHR_KIND_IN)               :: lpebcast
00856 
00857    !----- formats -----
00858    character(*),parameter             :: subName = '(shr_mpi_bcastr3) '
00859 
00860 !-------------------------------------------------------------------------------
00861 ! PURPOSE: Broadcast a 3d array of reals
00862 !-------------------------------------------------------------------------------
00863 
00864    lsize = size(arr)
00865    lpebcast = 0
00866    if (present(pebcast)) lpebcast = pebcast
00867 
00868    call MPI_BCAST(arr,lsize,MPI_REAL8,lpebcast,comm,ierr)
00869    if (present(string)) then
00870      call shr_mpi_chkerr(ierr,subName//trim(string))
00871    else
00872      call shr_mpi_chkerr(ierr,subName)
00873    endif
00874 
00875 END SUBROUTINE shr_mpi_bcastr3
00876 
00877 !===============================================================================
00878 !===============================================================================
00879 
00880 SUBROUTINE shr_mpi_gathScatvInitr1(comm, rootid, locArr, glob1DArr, globSize, &
00881                                    displs, string )
00882 
00883    IMPLICIT none
00884 
00885    !----- arguments -----
00886    integer(SHR_KIND_IN), intent(in)   :: comm          ! mpi communicator
00887    integer(SHR_KIND_IN), intent(in)   :: rootid        ! MPI task to gather/scatter on
00888    real(SHR_KIND_R8),    intent(in)   :: locArr(:)     ! Local array of distributed data
00889    real(SHR_KIND_R8),    pointer      :: glob1DArr(:)  ! Global 1D array of gathered data
00890    integer(SHR_KIND_IN), pointer      :: globSize(:)   ! Size of each distributed piece
00891    integer(SHR_KIND_IN), pointer      :: displs(:)     ! Displacements for receive
00892    character(*),optional,intent(in)   :: string        ! message
00893 
00894    !----- local -----
00895    integer(SHR_KIND_IN)               :: npes          ! Number of MPI tasks
00896    integer(SHR_KIND_IN)               :: locSize       ! Size of local distributed data
00897    integer(SHR_KIND_IN), pointer      :: sendSize(:)   ! Size to send for initial gather
00898    integer(SHR_KIND_IN)               :: i             ! Index
00899    integer(SHR_KIND_IN)               :: rank          ! Rank of this MPI task
00900    integer(SHR_KIND_IN)               :: nSize         ! Maximum size to send
00901    integer(SHR_KIND_IN)               :: ierr          ! Error code
00902    integer(SHR_KIND_IN)               :: nSiz1D        ! Size of 1D global array
00903    integer(SHR_KIND_IN)               :: maxSize       ! Maximum size
00904 
00905    !----- formats -----
00906    character(*),parameter             :: subName = '(shr_mpi_gathScatvInitr1) '
00907 
00908 !-------------------------------------------------------------------------------
00909 ! PURPOSE: Setup arrays for a gatherv/scatterv operation
00910 !-------------------------------------------------------------------------------
00911 
00912    locSize = size(locarr)
00913    call shr_mpi_commsize( comm, npes )
00914    call shr_mpi_commrank( comm, rank )
00915    allocate( globSize(npes) )
00916    !
00917    ! --- Gather the send global sizes from each MPI task -----------------------
00918    !
00919    allocate( sendSize(npes) )
00920    sendSize(:) = 1
00921    globSize(:) = 1
00922    call MPI_GATHER( locSize, 1, MPI_INTEGER, globSize, sendSize, &
00923                     MPI_INTEGER, rootid, comm, ierr )
00924    if (present(string)) then
00925      call shr_mpi_chkerr(ierr,subName//trim(string))
00926    else
00927      call shr_mpi_chkerr(ierr,subName)
00928    endif
00929    deallocate( sendSize )
00930    !
00931    ! --- Prepare the displacement and allocate arrays -------------------------
00932    !
00933    allocate( displs(npes) )
00934    displs(1) = 0
00935    if ( rootid /= rank )then
00936       maxSize = 1
00937       globSize = 1
00938    else
00939       maxSize = maxval(globSize)
00940    end if
00941    nsiz1D  = min(maxSize,globSize(1))
00942    do i = 2, npes
00943       nSize = min(maxSize,globSize(i-1))
00944       displs(i) = displs(i-1) + nSize
00945       nsiz1D = nsiz1D + min(maxSize,globSize(i))
00946    end do
00947    allocate( glob1DArr(nsiz1D) )
00948    !----- Do some error checking for the root task arrays computed ----
00949    if ( rootid == rank )then
00950       if ( nsiz1D /= sum(globSize) ) &
00951          call shr_mpi_abort( subName//" : Error, size of global array not right" )
00952       if ( any(displs < 0) .or. any(displs >= nsiz1D) ) &
00953          call shr_mpi_abort( subName//" : Error, displacement array not right" )
00954       if ( (displs(npes)+globSize(npes)) /= nsiz1D ) &
00955          call shr_mpi_abort( subName//" : Error, displacement array values too big" )
00956    end if
00957 
00958 END SUBROUTINE shr_mpi_gathScatvInitr1
00959 
00960 !===============================================================================
00961 !===============================================================================
00962 
00963 SUBROUTINE shr_mpi_gathervr1(locarr, locSize, glob1DArr, globSize, displs, rootid, &
00964                              comm, string )
00965 
00966    IMPLICIT none
00967 
00968    !----- arguments -----
00969    real(SHR_KIND_R8),    intent(in)   :: locArr(:)     ! Local array
00970    real(SHR_KIND_R8),    intent(inout):: glob1DArr(:)  ! Global 1D array to receive in on
00971    integer(SHR_KIND_IN), intent(in)   :: locSize       ! Number to send this PE
00972    integer(SHR_KIND_IN), intent(in)   :: globSize(:)   ! Number to receive each PE
00973    integer(SHR_KIND_IN), intent(in)   :: displs(:)     ! Displacements for receive
00974    integer(SHR_KIND_IN), intent(in)   :: rootid        ! MPI task to gather on
00975    integer(SHR_KIND_IN), intent(in)   :: comm          ! mpi communicator
00976    character(*),optional,intent(in)   :: string        ! message
00977 
00978    !----- local -----
00979    integer(SHR_KIND_IN)               :: ierr          ! Error code
00980 
00981    !----- formats -----
00982    character(*),parameter             :: subName = '(shr_mpi_gathervr1) '
00983 
00984 !-------------------------------------------------------------------------------
00985 ! PURPOSE: Gather a 1D array of reals
00986 !-------------------------------------------------------------------------------
00987 
00988    call MPI_GATHERV( locarr, locSize, MPI_REAL8, glob1Darr, globSize, displs, &
00989                      MPI_REAL8, rootid, comm, ierr )
00990    if (present(string)) then
00991      call shr_mpi_chkerr(ierr,subName//trim(string))
00992    else
00993      call shr_mpi_chkerr(ierr,subName)
00994    endif
00995 
00996 END SUBROUTINE shr_mpi_gathervr1
00997 
00998 !===============================================================================
00999 !===============================================================================
01000 
01001 SUBROUTINE shr_mpi_scattervr1(locarr, locSize, glob1Darr, globSize, displs, rootid, &
01002                               comm, string )
01003 
01004    IMPLICIT none
01005 
01006    !----- arguments -----
01007    real(SHR_KIND_R8),    intent(out)  :: locarr(:)     ! Local array
01008    real(SHR_KIND_R8),    intent(in)   :: glob1Darr(:)  ! Global 1D array to send from
01009    integer(SHR_KIND_IN), intent(in)   :: locSize       ! Number to receive this PE
01010    integer(SHR_KIND_IN), intent(in)   :: globSize(:)   ! Number to send to each PE
01011    integer(SHR_KIND_IN), intent(in)   :: displs(:)     ! Displacements for send
01012    integer(SHR_KIND_IN), intent(in)   :: rootid        ! MPI task to scatter on
01013    integer(SHR_KIND_IN), intent(in)   :: comm          ! mpi communicator
01014    character(*),optional,intent(in)   :: string        ! message
01015 
01016    !----- local -----
01017    integer(SHR_KIND_IN)               :: ierr          ! Error code
01018 
01019    !----- formats -----
01020    character(*),parameter             :: subName = '(shr_mpi_scattervr1) '
01021 
01022 !-------------------------------------------------------------------------------
01023 ! PURPOSE: Scatter a 1D array of reals
01024 !-------------------------------------------------------------------------------
01025 
01026 
01027    call MPI_SCATTERV( glob1Darr, globSize, displs, MPI_REAL8, locarr, locSize, &
01028                       MPI_REAL8, rootid, comm, ierr )
01029    if (present(string)) then
01030      call shr_mpi_chkerr(ierr,subName//trim(string))
01031    else
01032      call shr_mpi_chkerr(ierr,subName)
01033    endif
01034 
01035 END SUBROUTINE shr_mpi_scattervr1
01036 
01037 
01038 !===============================================================================
01039 !===============================================================================
01040 
01041 SUBROUTINE shr_mpi_sumi0(lvec,gvec,comm,string,all)
01042 
01043    IMPLICIT none
01044 
01045    !----- arguments ---
01046    integer(SHR_KIND_IN), intent(in) :: lvec     ! in/out local values
01047    integer(SHR_KIND_IN), intent(out):: gvec     ! in/out global values
01048    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
01049    character(*),optional,intent(in) :: string   ! message
01050    logical,     optional,intent(in) :: all      ! allreduce if true
01051 
01052    !----- local ---
01053    character(*),parameter           :: subName = '(shr_mpi_sumi0) '
01054    logical                          :: lall
01055    character(SHR_KIND_CL)           :: lstring
01056    integer(SHR_KIND_IN)             :: reduce_type  ! mpi reduction type
01057    integer(SHR_KIND_IN)             :: lsize
01058    integer(SHR_KIND_IN)             :: gsize
01059    integer(SHR_KIND_IN)             :: ierr
01060 
01061 !-------------------------------------------------------------------------------
01062 ! PURPOSE: Finds sum of a distributed vector of values, assume local sum
01063 !          already computed
01064 !-------------------------------------------------------------------------------
01065 
01066    reduce_type = MPI_SUM
01067    if (present(all)) then
01068      lall = all
01069    else
01070      lall = .false.
01071    endif
01072    if (present(string)) then
01073      lstring = trim(subName)//":"//trim(string)
01074    else
01075      lstring = trim(subName)
01076    endif
01077 
01078    lsize = 1
01079    gsize = 1
01080 
01081    if (lsize /= gsize) then
01082      call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
01083    endif
01084 
01085    if (lall) then
01086      call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr)
01087      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
01088    else
01089      call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr)
01090      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
01091    endif
01092 
01093 END SUBROUTINE shr_mpi_sumi0
01094 
01095 !===============================================================================
01096 !===============================================================================
01097 
01098 SUBROUTINE shr_mpi_sumi1(lvec,gvec,comm,string,all)
01099 
01100    IMPLICIT none
01101 
01102    !----- arguments ---
01103    integer(SHR_KIND_IN), intent(in) :: lvec(:)  ! in/out local values
01104    integer(SHR_KIND_IN), intent(out):: gvec(:)  ! in/out global values
01105    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
01106    character(*),optional,intent(in) :: string   ! message
01107    logical,     optional,intent(in) :: all      ! allreduce if true
01108 
01109    !----- local ---
01110    character(*),parameter           :: subName = '(shr_mpi_sumi1) '
01111    logical                          :: lall
01112    character(SHR_KIND_CL)           :: lstring
01113    integer(SHR_KIND_IN)             :: reduce_type  ! mpi reduction type
01114    integer(SHR_KIND_IN)             :: lsize
01115    integer(SHR_KIND_IN)             :: gsize
01116    integer(SHR_KIND_IN)             :: ierr
01117 
01118 !-------------------------------------------------------------------------------
01119 ! PURPOSE: Finds sum of a distributed vector of values, assume local sum
01120 !          already computed
01121 !-------------------------------------------------------------------------------
01122 
01123    reduce_type = MPI_SUM
01124    if (present(all)) then
01125      lall = all
01126    else
01127      lall = .false.
01128    endif
01129    if (present(string)) then
01130      lstring = trim(subName)//":"//trim(string)
01131    else
01132      lstring = trim(subName)
01133    endif
01134 
01135    lsize = size(lvec)
01136    gsize = size(gvec)
01137 
01138    if (lsize /= gsize) then
01139      call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
01140    endif
01141 
01142    if (lall) then
01143      call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr)
01144      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
01145    else
01146      call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr)
01147      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
01148    endif
01149 
01150 END SUBROUTINE shr_mpi_sumi1
01151 
01152 !===============================================================================
01153 !===============================================================================
01154 
01155 SUBROUTINE shr_mpi_sumb0(lvec,gvec,comm,string,all)
01156 
01157    IMPLICIT none
01158 
01159    !----- arguments ---
01160    integer(SHR_KIND_I8), intent(in) :: lvec     ! in/out local values
01161    integer(SHR_KIND_I8), intent(out):: gvec     ! in/out global values
01162    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
01163    character(*),optional,intent(in) :: string   ! message
01164    logical,     optional,intent(in) :: all      ! allreduce if true
01165 
01166    !----- local ---
01167    character(*),parameter           :: subName = '(shr_mpi_sumb0) '
01168    logical                          :: lall
01169    character(SHR_KIND_CL)           :: lstring
01170    integer(SHR_KIND_IN)             :: reduce_type  ! mpi reduction type
01171    integer(SHR_KIND_IN)             :: lsize
01172    integer(SHR_KIND_IN)             :: gsize
01173    integer(SHR_KIND_IN)             :: ierr
01174 
01175 !-------------------------------------------------------------------------------
01176 ! PURPOSE: Finds sum of a distributed vector of values, assume local sum
01177 !          already computed
01178 !-------------------------------------------------------------------------------
01179 
01180    reduce_type = MPI_SUM
01181    if (present(all)) then
01182      lall = all
01183    else
01184      lall = .false.
01185    endif
01186    if (present(string)) then
01187      lstring = trim(subName)//":"//trim(string)
01188    else
01189      lstring = trim(subName)
01190    endif
01191 
01192    lsize = 1
01193    gsize = 1
01194 
01195    if (lsize /= gsize) then
01196      call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
01197    endif
01198 
01199    if (lall) then
01200      call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,comm,ierr)
01201      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
01202    else
01203      call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,0,comm,ierr)
01204      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
01205    endif
01206 
01207 END SUBROUTINE shr_mpi_sumb0
01208 
01209 !===============================================================================
01210 !===============================================================================
01211 
01212 SUBROUTINE shr_mpi_sumb1(lvec,gvec,comm,string,all)
01213 
01214    IMPLICIT none
01215 
01216    !----- arguments ---
01217    integer(SHR_KIND_I8), intent(in) :: lvec(:)  ! in/out local values
01218    integer(SHR_KIND_I8), intent(out):: gvec(:)  ! in/out global values
01219    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
01220    character(*),optional,intent(in) :: string   ! message
01221    logical,     optional,intent(in) :: all      ! allreduce if true
01222 
01223    !----- local ---
01224    character(*),parameter           :: subName = '(shr_mpi_sumb1) '
01225    logical                          :: lall
01226    character(SHR_KIND_CL)           :: lstring
01227    integer(SHR_KIND_IN)             :: reduce_type  ! mpi reduction type
01228    integer(SHR_KIND_IN)             :: lsize
01229    integer(SHR_KIND_IN)             :: gsize
01230    integer(SHR_KIND_IN)             :: ierr
01231 
01232 !-------------------------------------------------------------------------------
01233 ! PURPOSE: Finds sum of a distributed vector of values, assume local sum
01234 !          already computed
01235 !-------------------------------------------------------------------------------
01236 
01237    reduce_type = MPI_SUM
01238    if (present(all)) then
01239      lall = all
01240    else
01241      lall = .false.
01242    endif
01243    if (present(string)) then
01244      lstring = trim(subName)//":"//trim(string)
01245    else
01246      lstring = trim(subName)
01247    endif
01248 
01249    lsize = size(lvec)
01250    gsize = size(gvec)
01251 
01252    if (lsize /= gsize) then
01253      call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
01254    endif
01255 
01256    if (lall) then
01257      call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,comm,ierr)
01258      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
01259    else
01260      call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,0,comm,ierr)
01261      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
01262    endif
01263 
01264 END SUBROUTINE shr_mpi_sumb1
01265 
01266 !===============================================================================
01267 !===============================================================================
01268 
01269 SUBROUTINE shr_mpi_sumr0(lvec,gvec,comm,string,all)
01270 
01271    IMPLICIT none
01272 
01273    !----- arguments ---
01274    real(SHR_KIND_R8),    intent(in) :: lvec     ! in/out local values
01275    real(SHR_KIND_R8),    intent(out):: gvec     ! in/out global values
01276    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
01277    character(*),optional,intent(in) :: string   ! message
01278    logical,     optional,intent(in) :: all      ! allreduce if true
01279 
01280    !----- local ---
01281    character(*),parameter           :: subName = '(shr_mpi_sumr0) '
01282    logical                          :: lall
01283    character(SHR_KIND_CL)           :: lstring
01284    integer(SHR_KIND_IN)             :: reduce_type  ! mpi reduction type
01285    integer(SHR_KIND_IN)             :: lsize
01286    integer(SHR_KIND_IN)             :: gsize
01287    integer(SHR_KIND_IN)             :: ierr
01288 
01289 !-------------------------------------------------------------------------------
01290 ! PURPOSE: Finds sum of a distributed vector of values, assume local sum
01291 !          already computed
01292 !-------------------------------------------------------------------------------
01293 
01294    reduce_type = MPI_SUM
01295    if (present(all)) then
01296      lall = all
01297    else
01298      lall = .false.
01299    endif
01300    if (present(string)) then
01301      lstring = trim(subName)//":"//trim(string)
01302    else
01303      lstring = trim(subName)
01304    endif
01305 
01306    lsize = 1
01307    gsize = 1
01308 
01309    if (lsize /= gsize) then
01310      call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
01311    endif
01312 
01313    if (lall) then
01314      call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr)
01315      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
01316    else
01317      call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr)
01318      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
01319    endif
01320 
01321 END SUBROUTINE shr_mpi_sumr0
01322 
01323 !===============================================================================
01324 !===============================================================================
01325 
01326 SUBROUTINE shr_mpi_sumr1(lvec,gvec,comm,string,all)
01327 
01328    IMPLICIT none
01329 
01330    !----- arguments ---
01331    real(SHR_KIND_R8),    intent(in) :: lvec(:)  ! in/out local values
01332    real(SHR_KIND_R8),    intent(out):: gvec(:)  ! in/out global values
01333    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
01334    character(*),optional,intent(in) :: string   ! message
01335    logical,     optional,intent(in) :: all      ! allreduce if true
01336 
01337    !----- local ---
01338    character(*),parameter           :: subName = '(shr_mpi_sumr1) '
01339    logical                          :: lall
01340    character(SHR_KIND_CL)           :: lstring
01341    integer(SHR_KIND_IN)             :: reduce_type  ! mpi reduction type
01342    integer(SHR_KIND_IN)             :: lsize
01343    integer(SHR_KIND_IN)             :: gsize
01344    integer(SHR_KIND_IN)             :: ierr
01345 
01346 !-------------------------------------------------------------------------------
01347 ! PURPOSE: Finds sum of a distributed vector of values, assume local sum
01348 !          already computed
01349 !-------------------------------------------------------------------------------
01350 
01351    reduce_type = MPI_SUM
01352    if (present(all)) then
01353      lall = all
01354    else
01355      lall = .false.
01356    endif
01357    if (present(string)) then
01358      lstring = trim(subName)//":"//trim(string)
01359    else
01360      lstring = trim(subName)
01361    endif
01362 
01363    lsize = size(lvec)
01364    gsize = size(gvec)
01365 
01366    if (lsize /= gsize) then
01367      call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
01368    endif
01369 
01370    if (lall) then
01371      call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr)
01372      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
01373    else
01374      call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr)
01375      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
01376    endif
01377 
01378 END SUBROUTINE shr_mpi_sumr1
01379 
01380 !===============================================================================
01381 !===============================================================================
01382 
01383 SUBROUTINE shr_mpi_sumr2(lvec,gvec,comm,string,all)
01384 
01385    IMPLICIT none
01386 
01387    !----- arguments ---
01388    real(SHR_KIND_R8),    intent(in) :: lvec(:,:)! in/out local values
01389    real(SHR_KIND_R8),    intent(out):: gvec(:,:)! in/out global values
01390    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
01391    character(*),optional,intent(in) :: string   ! message
01392    logical,     optional,intent(in) :: all      ! allreduce if true
01393 
01394    !----- local ---
01395    character(*),parameter           :: subName = '(shr_mpi_sumr2) '
01396    logical                          :: lall
01397    character(SHR_KIND_CL)           :: lstring
01398    integer(SHR_KIND_IN)             :: reduce_type  ! mpi reduction type
01399    integer(SHR_KIND_IN)             :: lsize
01400    integer(SHR_KIND_IN)             :: gsize
01401    integer(SHR_KIND_IN)             :: ierr
01402 
01403 !-------------------------------------------------------------------------------
01404 ! PURPOSE: Finds sum of a distributed vector of values, assume local sum
01405 !          already computed
01406 !-------------------------------------------------------------------------------
01407 
01408    reduce_type = MPI_SUM
01409    if (present(all)) then
01410      lall = all
01411    else
01412      lall = .false.
01413    endif
01414    if (present(string)) then
01415      lstring = trim(subName)//":"//trim(string)
01416    else
01417      lstring = trim(subName)
01418    endif
01419 
01420    lsize = size(lvec)
01421    gsize = size(gvec)
01422 
01423    if (lsize /= gsize) then
01424      call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
01425    endif
01426 
01427    if (lall) then
01428      call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr)
01429      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
01430    else
01431      call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr)
01432      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
01433    endif
01434 
01435 END SUBROUTINE shr_mpi_sumr2
01436 
01437 !===============================================================================
01438 !===============================================================================
01439 
01440 SUBROUTINE shr_mpi_sumr3(lvec,gvec,comm,string,all)
01441 
01442    IMPLICIT none
01443 
01444    !----- arguments ---
01445    real(SHR_KIND_R8),    intent(in) :: lvec(:,:,:) ! in/out local values
01446    real(SHR_KIND_R8),    intent(out):: gvec(:,:,:) ! in/out global values
01447    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
01448    character(*),optional,intent(in) :: string   ! message
01449    logical,     optional,intent(in) :: all      ! allreduce if true
01450 
01451    !----- local ---
01452    character(*),parameter           :: subName = '(shr_mpi_sumr3) '
01453    logical                          :: lall
01454    character(SHR_KIND_CL)           :: lstring
01455    integer(SHR_KIND_IN)             :: reduce_type  ! mpi reduction type
01456    integer(SHR_KIND_IN)             :: lsize
01457    integer(SHR_KIND_IN)             :: gsize
01458    integer(SHR_KIND_IN)             :: ierr
01459 
01460 !-------------------------------------------------------------------------------
01461 ! PURPOSE: Finds sum of a distributed vector of values, assume local sum
01462 !          already computed
01463 !-------------------------------------------------------------------------------
01464 
01465    reduce_type = MPI_SUM
01466    if (present(all)) then
01467      lall = all
01468    else
01469      lall = .false.
01470    endif
01471    if (present(string)) then
01472      lstring = trim(subName)//":"//trim(string)
01473    else
01474      lstring = trim(subName)
01475    endif
01476 
01477    lsize = size(lvec)
01478    gsize = size(gvec)
01479 
01480    if (lsize /= gsize) then
01481      call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
01482    endif
01483 
01484    if (lall) then
01485      call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr)
01486      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
01487    else
01488      call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr)
01489      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
01490    endif
01491 
01492 END SUBROUTINE shr_mpi_sumr3
01493 
01494 !===============================================================================
01495 !===============================================================================
01496 
01497 SUBROUTINE shr_mpi_mini0(lvec,gvec,comm,string,all)
01498 
01499    IMPLICIT none
01500 
01501    !----- arguments ---
01502    integer(SHR_KIND_IN), intent(in) :: lvec     ! in/out local values
01503    integer(SHR_KIND_IN), intent(out):: gvec     ! in/out global values
01504    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
01505    character(*),optional,intent(in) :: string   ! message
01506    logical,     optional,intent(in) :: all      ! allreduce if true
01507 
01508    !----- local ---
01509    character(*),parameter           :: subName = '(shr_mpi_mini0) '
01510    logical                          :: lall
01511    character(SHR_KIND_CL)           :: lstring
01512    integer(SHR_KIND_IN)             :: reduce_type  ! mpi reduction type
01513    integer(SHR_KIND_IN)             :: lsize
01514    integer(SHR_KIND_IN)             :: gsize
01515    integer(SHR_KIND_IN)             :: ierr
01516 
01517 !-------------------------------------------------------------------------------
01518 ! PURPOSE: Finds min of a distributed vector of values, assume local min
01519 !          already computed
01520 !-------------------------------------------------------------------------------
01521 
01522    reduce_type = MPI_MIN
01523    if (present(all)) then
01524      lall = all
01525    else
01526      lall = .false.
01527    endif
01528    if (present(string)) then
01529      lstring = trim(subName)//":"//trim(string)
01530    else
01531      lstring = trim(subName)
01532    endif
01533 
01534    lsize = 1
01535    gsize = 1
01536 
01537    if (lsize /= gsize) then
01538      call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
01539    endif
01540 
01541    if (lall) then
01542      call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr)
01543      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
01544    else
01545      call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr)
01546      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
01547    endif
01548 
01549 END SUBROUTINE shr_mpi_mini0
01550 
01551 !===============================================================================
01552 !===============================================================================
01553 
01554 SUBROUTINE shr_mpi_mini1(lvec,gvec,comm,string,all)
01555 
01556    IMPLICIT none
01557 
01558    !----- arguments ---
01559    integer(SHR_KIND_IN), intent(in) :: lvec(:)  ! in/out local values
01560    integer(SHR_KIND_IN), intent(out):: gvec(:)  ! in/out global values
01561    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
01562    character(*),optional,intent(in) :: string   ! message
01563    logical,     optional,intent(in) :: all      ! allreduce if true
01564 
01565    !----- local ---
01566    character(*),parameter           :: subName = '(shr_mpi_mini1) '
01567    logical                          :: lall
01568    character(SHR_KIND_CL)           :: lstring
01569    integer(SHR_KIND_IN)             :: reduce_type  ! mpi reduction type
01570    integer(SHR_KIND_IN)             :: lsize
01571    integer(SHR_KIND_IN)             :: gsize
01572    integer(SHR_KIND_IN)             :: ierr
01573 
01574 !-------------------------------------------------------------------------------
01575 ! PURPOSE: Finds min of a distributed vector of values, assume local min
01576 !          already computed
01577 !-------------------------------------------------------------------------------
01578 
01579    reduce_type = MPI_MIN
01580    if (present(all)) then
01581      lall = all
01582    else
01583      lall = .false.
01584    endif
01585    if (present(string)) then
01586      lstring = trim(subName)//":"//trim(string)
01587    else
01588      lstring = trim(subName)
01589    endif
01590 
01591    lsize = size(lvec)
01592    gsize = size(gvec)
01593 
01594    if (lsize /= gsize) then
01595      call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
01596    endif
01597 
01598    if (lall) then
01599      call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr)
01600      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
01601    else
01602      call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr)
01603      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
01604    endif
01605 
01606 END SUBROUTINE shr_mpi_mini1
01607 
01608 !===============================================================================
01609 !===============================================================================
01610 
01611 SUBROUTINE shr_mpi_minr0(lvec,gvec,comm,string,all)
01612 
01613    IMPLICIT none
01614 
01615    !----- arguments ---
01616    real(SHR_KIND_R8),    intent(in) :: lvec     ! in/out local values
01617    real(SHR_KIND_R8),    intent(out):: gvec     ! in/out global values
01618    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
01619    character(*),optional,intent(in) :: string   ! message
01620    logical,     optional,intent(in) :: all      ! allreduce if true
01621 
01622    !----- local ---
01623    character(*),parameter           :: subName = '(shr_mpi_minr0) '
01624    logical                          :: lall
01625    character(SHR_KIND_CL)           :: lstring
01626    integer(SHR_KIND_IN)             :: reduce_type  ! mpi reduction type
01627    integer(SHR_KIND_IN)             :: lsize
01628    integer(SHR_KIND_IN)             :: gsize
01629    integer(SHR_KIND_IN)             :: ierr
01630 
01631 !-------------------------------------------------------------------------------
01632 ! PURPOSE: Finds min of a distributed vector of values, assume local min
01633 !          already computed
01634 !-------------------------------------------------------------------------------
01635 
01636    reduce_type = MPI_MIN
01637    if (present(all)) then
01638      lall = all
01639    else
01640      lall = .false.
01641    endif
01642    if (present(string)) then
01643      lstring = trim(subName)//":"//trim(string)
01644    else
01645      lstring = trim(subName)
01646    endif
01647 
01648    lsize = 1
01649    gsize = 1
01650 
01651    if (lsize /= gsize) then
01652      call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
01653    endif
01654 
01655    if (lall) then
01656      call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr)
01657      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
01658    else
01659      call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr)
01660      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
01661    endif
01662 
01663 END SUBROUTINE shr_mpi_minr0
01664 
01665 !===============================================================================
01666 !===============================================================================
01667 
01668 SUBROUTINE shr_mpi_minr1(lvec,gvec,comm,string,all)
01669 
01670    IMPLICIT none
01671 
01672    !----- arguments ---
01673    real(SHR_KIND_R8),    intent(in) :: lvec(:)  ! in/out local values
01674    real(SHR_KIND_R8),    intent(out):: gvec(:)  ! in/out global values
01675    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
01676    character(*),optional,intent(in) :: string   ! message
01677    logical,     optional,intent(in) :: all      ! allreduce if true
01678 
01679    !----- local ---
01680    character(*),parameter           :: subName = '(shr_mpi_minr1) '
01681    logical                          :: lall
01682    character(SHR_KIND_CL)           :: lstring
01683    integer(SHR_KIND_IN)             :: reduce_type  ! mpi reduction type
01684    integer(SHR_KIND_IN)             :: lsize
01685    integer(SHR_KIND_IN)             :: gsize
01686    integer(SHR_KIND_IN)             :: ierr
01687 
01688 !-------------------------------------------------------------------------------
01689 ! PURPOSE: Finds min of a distributed vector of values, assume local min
01690 !          already computed
01691 !-------------------------------------------------------------------------------
01692 
01693    reduce_type = MPI_MIN
01694    if (present(all)) then
01695      lall = all
01696    else
01697      lall = .false.
01698    endif
01699    if (present(string)) then
01700      lstring = trim(subName)//":"//trim(string)
01701    else
01702      lstring = trim(subName)
01703    endif
01704 
01705    lsize = size(lvec)
01706    gsize = size(gvec)
01707 
01708    if (lsize /= gsize) then
01709      call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
01710    endif
01711 
01712    if (lall) then
01713      call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr)
01714      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
01715    else
01716      call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr)
01717      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
01718    endif
01719 
01720 END SUBROUTINE shr_mpi_minr1
01721 
01722 !===============================================================================
01723 !===============================================================================
01724 
01725 SUBROUTINE shr_mpi_maxi0(lvec,gvec,comm,string,all)
01726 
01727    IMPLICIT none
01728 
01729    !----- arguments ---
01730    integer(SHR_KIND_IN), intent(in) :: lvec     ! in/out local values
01731    integer(SHR_KIND_IN), intent(out):: gvec     ! in/out global values
01732    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
01733    character(*),optional,intent(in) :: string   ! message
01734    logical,     optional,intent(in) :: all      ! allreduce if true
01735 
01736    !----- local ---
01737    character(*),parameter           :: subName = '(shr_mpi_maxi0) '
01738    logical                          :: lall
01739    character(SHR_KIND_CL)           :: lstring
01740    integer(SHR_KIND_IN)             :: reduce_type  ! mpi reduction type
01741    integer(SHR_KIND_IN)             :: lsize
01742    integer(SHR_KIND_IN)             :: gsize
01743    integer(SHR_KIND_IN)             :: ierr
01744 
01745 !-------------------------------------------------------------------------------
01746 ! PURPOSE: Finds max of a distributed vector of values, assume local max
01747 !          already computed
01748 !-------------------------------------------------------------------------------
01749 
01750    reduce_type = MPI_MAX
01751    if (present(all)) then
01752      lall = all
01753    else
01754      lall = .false.
01755    endif
01756    if (present(string)) then
01757      lstring = trim(subName)//":"//trim(string)
01758    else
01759      lstring = trim(subName)
01760    endif
01761 
01762    lsize = 1
01763    gsize = 1
01764 
01765    if (lsize /= gsize) then
01766      call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
01767    endif
01768 
01769    if (lall) then
01770      call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr)
01771      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
01772    else
01773      call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr)
01774      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
01775    endif
01776 
01777 END SUBROUTINE shr_mpi_maxi0
01778 
01779 !===============================================================================
01780 !===============================================================================
01781 
01782 SUBROUTINE shr_mpi_maxi1(lvec,gvec,comm,string,all)
01783 
01784    IMPLICIT none
01785 
01786    !----- arguments ---
01787    integer(SHR_KIND_IN), intent(in) :: lvec(:)  ! in/out local values
01788    integer(SHR_KIND_IN), intent(out):: gvec(:)  ! in/out global values
01789    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
01790    character(*),optional,intent(in) :: string   ! message
01791    logical,     optional,intent(in) :: all      ! allreduce if true
01792 
01793    !----- local ---
01794    character(*),parameter           :: subName = '(shr_mpi_maxi1) '
01795    logical                          :: lall
01796    character(SHR_KIND_CL)           :: lstring
01797    integer(SHR_KIND_IN)             :: reduce_type  ! mpi reduction type
01798    integer(SHR_KIND_IN)             :: lsize
01799    integer(SHR_KIND_IN)             :: gsize
01800    integer(SHR_KIND_IN)             :: ierr
01801 
01802 !-------------------------------------------------------------------------------
01803 ! PURPOSE: Finds max of a distributed vector of values, assume local max
01804 !          already computed
01805 !-------------------------------------------------------------------------------
01806 
01807    reduce_type = MPI_MAX
01808    if (present(all)) then
01809      lall = all
01810    else
01811      lall = .false.
01812    endif
01813    if (present(string)) then
01814      lstring = trim(subName)//":"//trim(string)
01815    else
01816      lstring = trim(subName)
01817    endif
01818 
01819    lsize = size(lvec)
01820    gsize = size(gvec)
01821 
01822    if (lsize /= gsize) then
01823      call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
01824    endif
01825 
01826    if (lall) then
01827      call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr)
01828      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
01829    else
01830      call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr)
01831      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
01832    endif
01833 
01834 END SUBROUTINE shr_mpi_maxi1
01835 
01836 !===============================================================================
01837 !===============================================================================
01838 
01839 SUBROUTINE shr_mpi_maxr0(lvec,gvec,comm,string,all)
01840 
01841    IMPLICIT none
01842 
01843    !----- arguments ---
01844    real(SHR_KIND_R8),    intent(in) :: lvec     ! in/out local values
01845    real(SHR_KIND_R8),    intent(out):: gvec     ! in/out global values
01846    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
01847    character(*),optional,intent(in) :: string   ! message
01848    logical,     optional,intent(in) :: all      ! allreduce if true
01849 
01850    !----- local ---
01851    character(*),parameter           :: subName = '(shr_mpi_maxr0) '
01852    logical                          :: lall
01853    character(SHR_KIND_CL)           :: lstring
01854    integer(SHR_KIND_IN)             :: reduce_type  ! mpi reduction type
01855    integer(SHR_KIND_IN)             :: lsize
01856    integer(SHR_KIND_IN)             :: gsize
01857    integer(SHR_KIND_IN)             :: ierr
01858 
01859 !-------------------------------------------------------------------------------
01860 ! PURPOSE: Finds max of a distributed vector of values, assume local max
01861 !          already computed
01862 !-------------------------------------------------------------------------------
01863 
01864    reduce_type = MPI_MAX
01865    if (present(all)) then
01866      lall = all
01867    else
01868      lall = .false.
01869    endif
01870    if (present(string)) then
01871      lstring = trim(subName)//":"//trim(string)
01872    else
01873      lstring = trim(subName)
01874    endif
01875 
01876    lsize = 1
01877    gsize = 1
01878 
01879    if (lsize /= gsize) then
01880      call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
01881    endif
01882 
01883    if (lall) then
01884      call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr)
01885      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
01886    else
01887      call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr)
01888      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
01889    endif
01890 
01891 END SUBROUTINE shr_mpi_maxr0
01892 
01893 !===============================================================================
01894 !===============================================================================
01895 
01896 SUBROUTINE shr_mpi_maxr1(lvec,gvec,comm,string,all)
01897 
01898    IMPLICIT none
01899 
01900    !----- arguments ---
01901    real(SHR_KIND_R8),    intent(in) :: lvec(:)  ! in/out local values
01902    real(SHR_KIND_R8),    intent(out):: gvec(:)  ! in/out global values
01903    integer(SHR_KIND_IN), intent(in) :: comm     ! mpi communicator
01904    character(*),optional,intent(in) :: string   ! message
01905    logical,     optional,intent(in) :: all      ! allreduce if true
01906 
01907    !----- local ---
01908    character(*),parameter           :: subName = '(shr_mpi_maxr1) '
01909    logical                          :: lall
01910    character(SHR_KIND_CL)           :: lstring
01911    integer(SHR_KIND_IN)             :: reduce_type  ! mpi reduction type
01912    integer(SHR_KIND_IN)             :: lsize
01913    integer(SHR_KIND_IN)             :: gsize
01914    integer(SHR_KIND_IN)             :: ierr
01915 
01916 !-------------------------------------------------------------------------------
01917 ! PURPOSE: Finds max of a distributed vector of values, assume local max
01918 !          already computed
01919 !-------------------------------------------------------------------------------
01920 
01921    reduce_type = MPI_MAX
01922    if (present(all)) then
01923      lall = all
01924    else
01925      lall = .false.
01926    endif
01927    if (present(string)) then
01928      lstring = trim(subName)//":"//trim(string)
01929    else
01930      lstring = trim(subName)
01931    endif
01932 
01933    lsize = size(lvec)
01934    gsize = size(gvec)
01935 
01936    if (lsize /= gsize) then
01937      call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string))
01938    endif
01939 
01940    if (lall) then
01941      call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr)
01942      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE")
01943    else
01944      call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr)
01945      call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE")
01946    endif
01947 
01948 END SUBROUTINE shr_mpi_maxr1
01949 
01950 !===============================================================================
01951 !===============================================================================
01952 
01953 SUBROUTINE shr_mpi_commsize(comm,size,string)
01954 
01955    IMPLICIT none
01956 
01957    !----- arguments ---
01958    integer,intent(in)                 :: comm
01959    integer,intent(out)                :: size
01960    character(*),optional,intent(in)   :: string   ! message
01961 
01962    !----- local ---
01963    character(*),parameter             :: subName = '(shr_mpi_commsize) '
01964    integer(SHR_KIND_IN)               :: ierr
01965 
01966 !-------------------------------------------------------------------------------
01967 ! PURPOSE: MPI commsize
01968 !-------------------------------------------------------------------------------
01969 
01970    call MPI_COMM_SIZE(comm,size,ierr)
01971    if (present(string)) then
01972      call shr_mpi_chkerr(ierr,subName//trim(string))
01973    else
01974      call shr_mpi_chkerr(ierr,subName)
01975    endif
01976 
01977 END SUBROUTINE shr_mpi_commsize
01978 
01979 !===============================================================================
01980 !===============================================================================
01981 
01982 SUBROUTINE shr_mpi_commrank(comm,rank,string)
01983 
01984    IMPLICIT none
01985 
01986    !----- arguments ---
01987    integer,intent(in)                 :: comm
01988    integer,intent(out)                :: rank
01989    character(*),optional,intent(in)   :: string   ! message
01990 
01991    !----- local ---
01992    character(*),parameter             :: subName = '(shr_mpi_commrank) '
01993    integer(SHR_KIND_IN)               :: ierr
01994 
01995 !-------------------------------------------------------------------------------
01996 ! PURPOSE: MPI commrank
01997 !-------------------------------------------------------------------------------
01998 
01999    call MPI_COMM_RANK(comm,rank,ierr)
02000    if (present(string)) then
02001      call shr_mpi_chkerr(ierr,subName//trim(string))
02002    else
02003      call shr_mpi_chkerr(ierr,subName)
02004    endif
02005 
02006 END SUBROUTINE shr_mpi_commrank
02007 
02008 !===============================================================================
02009 !===============================================================================
02010 
02011 SUBROUTINE shr_mpi_initialized(flag,string)
02012 
02013    IMPLICIT none
02014 
02015    !----- arguments ---
02016    logical,intent(out)                :: flag
02017    character(*),optional,intent(in)   :: string   ! message
02018 
02019    !----- local ---
02020    character(*),parameter             :: subName = '(shr_mpi_initialized) '
02021    integer(SHR_KIND_IN)               :: ierr
02022 
02023 !-------------------------------------------------------------------------------
02024 ! PURPOSE: MPI initialized
02025 !-------------------------------------------------------------------------------
02026 
02027    call MPI_INITIALIZED(flag,ierr)
02028    if (present(string)) then
02029      call shr_mpi_chkerr(ierr,subName//trim(string))
02030    else
02031      call shr_mpi_chkerr(ierr,subName)
02032    endif
02033 
02034 END SUBROUTINE shr_mpi_initialized
02035 
02036 !===============================================================================
02037 !===============================================================================
02038 
02039 SUBROUTINE shr_mpi_abort(string,rcode)
02040 
02041    IMPLICIT none
02042 
02043    !----- arguments ---
02044    character(*),optional,intent(in)   :: string   ! message
02045    integer,optional,intent(in)        :: rcode    ! optional code
02046 
02047    !----- local ---
02048    character(*),parameter             :: subName = '(shr_mpi_abort) '
02049    integer(SHR_KIND_IN)               :: ierr
02050    integer                            :: rc       ! return code
02051 
02052 !-------------------------------------------------------------------------------
02053 ! PURPOSE: MPI abort
02054 !-------------------------------------------------------------------------------
02055 
02056    if ( present(string) .and. present(rcode) ) then
02057       write(s_logunit,*) trim(subName),":",trim(string),rcode
02058    endif
02059    if ( present(rcode) )then
02060       rc = rcode
02061    else
02062       rc = 1001
02063    end if
02064    call MPI_ABORT(MPI_COMM_WORLD,rcode,ierr)
02065 
02066 END SUBROUTINE shr_mpi_abort
02067 
02068 !===============================================================================
02069 !===============================================================================
02070 
02071 SUBROUTINE shr_mpi_barrier(comm,string)
02072 
02073    IMPLICIT none
02074 
02075    !----- arguments ---
02076    integer,intent(in)                 :: comm
02077    character(*),optional,intent(in)   :: string   ! message
02078 
02079    !----- local ---
02080    character(*),parameter             :: subName = '(shr_mpi_barrier) '
02081    integer(SHR_KIND_IN)               :: ierr
02082 
02083 !-------------------------------------------------------------------------------
02084 ! PURPOSE: MPI barrier
02085 !-------------------------------------------------------------------------------
02086 
02087    call MPI_BARRIER(comm,ierr)
02088    if (present(string)) then
02089      call shr_mpi_chkerr(ierr,subName//trim(string))
02090    else
02091      call shr_mpi_chkerr(ierr,subName)
02092    endif
02093 
02094 END SUBROUTINE shr_mpi_barrier
02095 
02096 !===============================================================================
02097 !===============================================================================
02098 
02099 SUBROUTINE shr_mpi_init(string)
02100 
02101    IMPLICIT none
02102 
02103    !----- arguments ---
02104    character(*),optional,intent(in)   :: string   ! message
02105 
02106    !----- local ---
02107    character(*),parameter             :: subName = '(shr_mpi_init) '
02108    integer(SHR_KIND_IN)               :: ierr
02109 
02110 !-------------------------------------------------------------------------------
02111 ! PURPOSE: MPI init
02112 !-------------------------------------------------------------------------------
02113 
02114    call MPI_INIT(ierr)
02115    if (present(string)) then
02116      call shr_mpi_chkerr(ierr,subName//trim(string))
02117    else
02118      call shr_mpi_chkerr(ierr,subName)
02119    endif
02120 
02121 END SUBROUTINE shr_mpi_init
02122 
02123 !===============================================================================
02124 !===============================================================================
02125 
02126 SUBROUTINE shr_mpi_finalize(string)
02127 
02128    IMPLICIT none
02129 
02130    !----- arguments ---
02131    character(*),optional,intent(in)   :: string   ! message
02132 
02133    !----- local ---
02134    character(*),parameter             :: subName = '(shr_mpi_finalize) '
02135    integer(SHR_KIND_IN)               :: ierr
02136 
02137 !-------------------------------------------------------------------------------
02138 ! PURPOSE: MPI finalize
02139 !-------------------------------------------------------------------------------
02140 
02141    call MPI_BARRIER(MPI_COMM_WORLD,ierr)
02142    call MPI_FINALIZE(ierr)
02143    if (present(string)) then
02144      call shr_mpi_chkerr(ierr,subName//trim(string))
02145    else
02146      call shr_mpi_chkerr(ierr,subName)
02147    endif
02148 
02149 END SUBROUTINE shr_mpi_finalize
02150 
02151 !===============================================================================
02152 !===============================================================================
02153 
02154 END MODULE shr_mpi_mod