pm_parallelism.F90

Go to the documentation of this file.

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!                                                                                                                            !!!!
!!!!    ParaMonte: Parallel Monte Carlo and Machine Learning Library.                                                           !!!!
!!!!                                                                                                                            !!!!
!!!!    Copyright (C) 2012-present, The Computational Data Science Lab                                                          !!!!
!!!!                                                                                                                            !!!!
!!!!    This file is part of the ParaMonte library.                                                                             !!!!
!!!!                                                                                                                            !!!!
!!!!    LICENSE                                                                                                                 !!!!
!!!!                                                                                                                            !!!!
!!!!       https://github.com/cdslaborg/paramonte/blob/main/LICENSE.md                                                          !!!!
!!!!                                                                                                                            !!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
module pm_parallelism
 
    use pm_kind, only: SK, IK, LK
    use pm_val2str, only: getStr
 
    implicit none
 
    character(*, SK), parameter :: MODULE_NAME = SK_"@pm_parallelism"
 
#if CAF_ENABLED || MPI_ENABLED
 
    character(*, SK), parameter :: PARALLELIZATION_MODE = SK_"parallel"
#else
    character(*, SK), parameter :: PARALLELIZATION_MODE = SK_"serial"
#endif
 
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
    type                                :: imageis_type
        logical(LK)                     :: first    = .false._LK
        logical(LK)                     :: extra    = .false._LK
        logical(LK)                     :: leader   = .false._LK
        logical(LK)                     :: rooter   = .false._LK
    end type
 
    type                                :: image_type
        integer(IK)                     :: count        = -huge(1_IK)
        integer(IK)                     :: id           = -huge(1_IK)
        type(imageis_type)              :: is           = imageis_type()
        character(:, SK), allocatable   :: label
        contains
        procedure, nopass               :: sync => setImageSynced
        procedure, nopass               :: finalize => setImageFinalized
    end type
 
    interface image_type
        module procedure :: image_typer
    end interface
 
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
 
    interface setForkJoinScaling
 
    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
#if RK5_ENABLED
    PURE module subroutine setForkJoinScaling_RK5(conProb, seqSecTime, parSecTime, comSecTime, scaling, numproc, scalingMaxVal, scalingMaxLoc, scalingMinLen)
#if __INTEL_COMPILER && DLL_ENABLED && (_WIN32 || _WIN64)
        !DEC$ ATTRIBUTES DLLEXPORT :: setForkJoinScaling_RK5
#endif
        use pm_kind, only: RKG => RK5
        integer(IK)         , intent(out)                   :: scalingMaxLoc
        integer(IK)         , intent(in)    , optional      :: scalingMinLen
        integer(IK)         , intent(out)   , allocatable   :: numproc(:)
        real(RKG)           , intent(out)   , allocatable   :: scaling(:)
        real(RKG)           , intent(in)                    :: conProb, seqSecTime, parSecTime, comSecTime
        real(RKG)           , intent(out)                   :: scalingMaxVal
    end subroutine
#endif
 
#if RK4_ENABLED
    PURE module subroutine setForkJoinScaling_RK4(conProb, seqSecTime, parSecTime, comSecTime, scaling, numproc, scalingMaxVal, scalingMaxLoc, scalingMinLen)
#if __INTEL_COMPILER && DLL_ENABLED && (_WIN32 || _WIN64)
        !DEC$ ATTRIBUTES DLLEXPORT :: setForkJoinScaling_RK4
#endif
        use pm_kind, only: RKG => RK4
        integer(IK)         , intent(out)                   :: scalingMaxLoc
        integer(IK)         , intent(in)    , optional      :: scalingMinLen
        integer(IK)         , intent(out)   , allocatable   :: numproc(:)
        real(RKG)           , intent(out)   , allocatable   :: scaling(:)
        real(RKG)           , intent(in)                    :: conProb, seqSecTime, parSecTime, comSecTime
        real(RKG)           , intent(out)                   :: scalingMaxVal
    end subroutine
#endif
 
#if RK3_ENABLED
    PURE module subroutine setForkJoinScaling_RK3(conProb, seqSecTime, parSecTime, comSecTime, scaling, numproc, scalingMaxVal, scalingMaxLoc, scalingMinLen)
#if __INTEL_COMPILER && DLL_ENABLED && (_WIN32 || _WIN64)
        !DEC$ ATTRIBUTES DLLEXPORT :: setForkJoinScaling_RK3
#endif
        use pm_kind, only: RKG => RK3
        integer(IK)         , intent(out)                   :: scalingMaxLoc
        integer(IK)         , intent(in)    , optional      :: scalingMinLen
        integer(IK)         , intent(out)   , allocatable   :: numproc(:)
        real(RKG)           , intent(out)   , allocatable   :: scaling(:)
        real(RKG)           , intent(in)                    :: conProb, seqSecTime, parSecTime, comSecTime
        real(RKG)           , intent(out)                   :: scalingMaxVal
    end subroutine
#endif
 
#if RK2_ENABLED
    PURE module subroutine setForkJoinScaling_RK2(conProb, seqSecTime, parSecTime, comSecTime, scaling, numproc, scalingMaxVal, scalingMaxLoc, scalingMinLen)
#if __INTEL_COMPILER && DLL_ENABLED && (_WIN32 || _WIN64)
        !DEC$ ATTRIBUTES DLLEXPORT :: setForkJoinScaling_RK2
#endif
        use pm_kind, only: RKG => RK2
        integer(IK)         , intent(out)                   :: scalingMaxLoc
        integer(IK)         , intent(in)    , optional      :: scalingMinLen
        integer(IK)         , intent(out)   , allocatable   :: numproc(:)
        real(RKG)           , intent(out)   , allocatable   :: scaling(:)
        real(RKG)           , intent(in)                    :: conProb, seqSecTime, parSecTime, comSecTime
        real(RKG)           , intent(out)                   :: scalingMaxVal
    end subroutine
#endif
 
#if RK1_ENABLED
    PURE module subroutine setForkJoinScaling_RK1(conProb, seqSecTime, parSecTime, comSecTime, scaling, numproc, scalingMaxVal, scalingMaxLoc, scalingMinLen)
#if __INTEL_COMPILER && DLL_ENABLED && (_WIN32 || _WIN64)
        !DEC$ ATTRIBUTES DLLEXPORT :: setForkJoinScaling_RK1
#endif
        use pm_kind, only: RKG => RK1
        integer(IK)         , intent(out)                   :: scalingMaxLoc
        integer(IK)         , intent(in)    , optional      :: scalingMinLen
        integer(IK)         , intent(out)   , allocatable   :: numproc(:)
        real(RKG)           , intent(out)   , allocatable   :: scaling(:)
        real(RKG)           , intent(in)                    :: conProb, seqSecTime, parSecTime, comSecTime
        real(RKG)           , intent(out)                   :: scalingMaxVal
    end subroutine
#endif
 
    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
    end interface
 
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
#if OMP_ENABLED
    logical(LK) , save :: mv_failed = .false._LK
#endif
 
 
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
contains
 
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
    function image_typer() result(image)
        type(image_type) :: image
        !integer(IK), intent(in), optional :: nthread
        ! setup general processor / coarray image variables
        image%id            = getImageID()
        image%count         = getImageCount()
        image%label         = SK_"@process("//getStr(image%id)//SK_")"
        image%is%first       = image%id == 1_IK
        image%is%extra    = image%id /= 1_IK
       !image%is%leader      = .false._LK ! ATTN: this is to be set by the user at runtime, depending on the parallelism type.
       !image%is%rooter      = .false._LK ! ATTN: this is to be set by the user at runtime, depending on the parallelism type.
    end function
 
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
    subroutine setImageSynced()
#if __INTEL_COMPILER && DLL_ENABLED && (_WIN32 || _WIN64)
        !DEC$ ATTRIBUTES DLLEXPORT :: setImageSynced
#endif
#if     CAF_ENABLED
        sync all
#elif   MPI_ENABLED
        block
            use mpi !, only: mpi_barrier, mpi_comm_world
            integer :: ierrMPI
            call mpi_barrier(mpi_comm_world, ierrMPI)
        end block
#elif   OMP_ENABLED
        !$omp barrier
#endif
    end subroutine
 
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
    subroutine setImageFinalized() ! LCOV_EXCL_LINE
#if __INTEL_COMPILER && DLL_ENABLED && (_WIN32 || _WIN64)
        !DEC$ ATTRIBUTES DLLEXPORT :: setImageFinalized
#endif
#if     CAF_ENABLED
        sync all
#elif   MPI_ENABLED
        use mpi !mpi_f08, only: mpi_comm_world, mpi_finalized, mpi_finalize, mpi_barrier
        implicit none
        integer :: ierrMPI
        logical :: isFinalized
        call mpi_finalized(isFinalized, ierrMPI)
        if (.not. isFinalized) then
            call mpi_barrier(mpi_comm_world, ierrMPI)
            call mpi_finalize(ierrMPI)
        end if
#elif   OMP_ENABLED
        !$omp barrier
#endif
    end subroutine
 
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
    function getImageID() result(imageID)
#if __INTEL_COMPILER && DLL_ENABLED && (_WIN32 || _WIN64)
        !DEC$ ATTRIBUTES DLLEXPORT :: getImageID
#endif
        integer(IK) :: imageID
#if     CAF_ENABLED
        imageID = this_image()
#elif   MPI_ENABLED
        block
            use mpi !mpi_f08, only : mpi_initialized, mpi_comm_world, mpi_comm_size, mpi_init
            integer :: rank, ierrMPI
            logical :: isinit, isfinit
            call mpi_initialized(isinit, ierrMPI)
            if (.not. isinit) then
                call mpi_finalized(isfinit, ierrMPI)
                if (isfinit) error stop MODULE_NAME//"@getImageID(): Error occurred. A finalized MPI library cannot be reinitialized."
                call mpi_init(ierrMPI)
            end if
            call mpi_comm_rank(mpi_comm_world, rank, ierrMPI)
            if (ierrMPI /= 0) error stop "Failed to fetch the MPI process counts."
            imageID = int(rank, IK) + 1_IK
        end block
#elif   OMP_ENABLED
        block
            use omp_lib, only: omp_get_thread_num
            imageID = int(omp_get_thread_num() + 1, IK)
        end block
#else
        imageID = 1_IK
#endif
    end function
 
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
    function getImageCount() result(imageCount)
#if __INTEL_COMPILER && DLL_ENABLED && (_WIN32 || _WIN64)
        !DEC$ ATTRIBUTES DLLEXPORT :: getImageCount
#endif
        integer(IK) :: imageCount
#if     CAF_ENABLED
        imageCount = num_images()
#elif   MPI_ENABLED
        imageCount = getImageCountMPI()
#elif   OMP_ENABLED
        imageCount = getImageCountOMP()
#else
        imageCount = 1_IK
#endif
    end function
 
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
    function getImageCountMPI() result(imageCount) bind(C, name = "getImageCountMPI")
#if __INTEL_COMPILER && DLL_ENABLED && (_WIN32 || _WIN64)
        !DEC$ ATTRIBUTES DLLEXPORT :: getImageCountMPI
#endif
#if     MPI_ENABLED
        use mpi !mpi_f08, only : mpi_initialized, mpi_comm_world, mpi_comm_size, mpi_init
        integer :: nproc
        integer :: ierrMPI
        logical :: isinit
        integer(IK) :: imageCount
        imageCount = 0_IK
        call mpi_initialized(isinit, ierrMPI)
        if (ierrMPI /= 0) return ! LCOV_EXCL_LINE
        if (.not. isinit) then
            call mpi_init(ierrMPI) ! LCOV_EXCL_LINE
            if (ierrMPI /= 0) return ! LCOV_EXCL_LINE
        end if
        call mpi_comm_size(mpi_comm_world, nproc, ierrMPI)
        if (ierrMPI /= 0) return ! LCOV_EXCL_LINE
        imageCount = int(nproc, IK)
#else
        integer(IK) :: imageCount
        imageCount = 0_IK
#endif
    end function
 
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
    function getImageCountOMP() result(imageCount) bind(C, name = "getImageCountOMP")
#if __INTEL_COMPILER && DLL_ENABLED && (_WIN32 || _WIN64)
        !DEC$ ATTRIBUTES DLLEXPORT :: getImageCountOMP
#endif
#if     OMP_ENABLED
        use omp_lib, only: omp_get_num_threads
        integer(IK) :: imageCount
        imageCount = omp_get_num_threads()
#else
        integer(IK) :: imageCount
        imageCount = 0_IK
#endif
    end function
 
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
    subroutine setImageCount(count)
#if __INTEL_COMPILER && DLL_ENABLED && (_WIN32 || _WIN64)
        !DEC$ ATTRIBUTES DLLEXPORT :: setImageCount
#endif
        integer(IK), intent(in), optional :: count
#if     OMP_ENABLED
        block
            use omp_lib, only: omp_get_num_procs, omp_set_num_threads
            integer :: count_def
            count_def = omp_get_num_procs()
            if (present(count)) then
                if (0_IK < count) count_def = int(count)
            end if
            call omp_set_num_threads(count_def)
        end block
#endif
    end subroutine
 
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
        function isFailedImage(failed) result(failedParallelism)
#if     __INTEL_COMPILER && DLL_ENABLED && (_WIN32 || _WIN64)
            !DEC$ ATTRIBUTES DLLEXPORT :: isFailedImage
#endif
            logical(LK), intent(in) :: failed
            logical(LK) :: failedParallelism
#if         CAF_ENABLED
            logical(LK), allocatable, save :: failure(:)[:]
            integer :: iid, imageCount
            imageCount = num_images()
            allocate(failure(imageCount)[*])
            failure(this_image()) = failed
            sync all
            do iid = 1, imageCount
                failedParallelism = failure(iid)[iid]
                if (failedParallelism) return
            end do
#elif       MPI_ENABLED
            logical, allocatable :: failure(:) ! This must be default kind.
            integer :: imageCount!, imageID ! This must be default kind.
            block
                use mpi !mpi_f08, only: mpi_comm_world, mpi_comm_rank, mpi_comm_size, mpi_allgather, mpi_logical
                use pm_arrayResize, only: setResized
                integer :: ierrMPI
               !call mpi_comm_rank(mpi_comm_world, imageID, ierrMPI)
                call mpi_comm_size(mpi_comm_world, imageCount, ierrMPI)
                call setResized(failure, int(imageCount, IK))
                call mpi_allgather  ( logical(failed) & ! LCOV_EXCL_LINE : send buffer
                                    , 1 & ! LCOV_EXCL_LINE : send count
                                    , mpi_logical & ! LCOV_EXCL_LINE : send datatype
                                    , failure(:) & ! LCOV_EXCL_LINE : receive buffer
                                    , 1 & ! LCOV_EXCL_LINE : receive count
                                    , mpi_logical & ! LCOV_EXCL_LINE : receive datatype
                                    , mpi_comm_world & ! LCOV_EXCL_LINE : comm
                                    , ierrMPI & ! LCOV_EXCL_LINE : error code
                                    )
                !call mpi_alltoall   ( err%occurred &    ! buffer_send   : The buffer containing the data that will be scattered to other processes.<br>
                !                    , 1 &               ! count_send    : The number of elements that will be sent to each process.<br>
                !                    , mpi_logical &     ! datatype_send : The type of one send buffer element.<br>
                !                    , failure &   ! buffer_recv   : The buffer in which store the gathered data.<br>
                !                    , imageCount &      ! count_recv    : The number of elements in the message to receive per process, not the total number of elements to receive from all processes altogether.<br>
                !                    , mpi_logical &     ! datatype_recv : The type of one receive buffer element.<br>
                !                    , mpi_comm_world &  ! communicator  : The communicator in which the all to all takes place.<br>
                !                    , ierrMPI & ! LCOV_EXCL_LINE : error code
                !                    )
                failedParallelism = logical(any(failure), LK)
            end block
#elif       OMP_ENABLED
            !$omp critical
            mv_failed = mv_failed .or. failed
            !$omp end critical
            !$omp barrier
            failedParallelism = mv_failed
            !$omp master
            mv_failed = .false._LK
            !$omp end master
#else
            failedParallelism = failed
#endif
        end function
 
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 
end module pm_parallelism ! LCOV_EXCL_LINE