| 
 | 1 | +module blacstestutils  | 
 | 2 | +  use libscalapackfx_module, only : blacsgrid, blacsfx_exit, blacsfx_pinfo  | 
 | 3 | +  use fortuno_mpi, only : test_item, mpi_case, check => mpi_check, failed => mpi_failed, num_ranks  | 
 | 4 | +  implicit none  | 
 | 5 | + | 
 | 6 | +  private  | 
 | 7 | +  public :: this_proc, num_procs  | 
 | 8 | +  public :: blacs_test  | 
 | 9 | +  public :: blacs_grid_env, get_grid_or_fail  | 
 | 10 | + | 
 | 11 | + | 
 | 12 | +  !> Implements a test class with BLACS initialization and destruction  | 
 | 13 | +  type, extends(mpi_case) :: blacs_case  | 
 | 14 | +  contains  | 
 | 15 | +    procedure :: run => blacs_case_run  | 
 | 16 | +  end type blacs_case  | 
 | 17 | + | 
 | 18 | + | 
 | 19 | +  abstract interface  | 
 | 20 | +    !> Interface of the test procedure  | 
 | 21 | +    subroutine blacs_test_procedure()  | 
 | 22 | +    end subroutine blacs_test_procedure  | 
 | 23 | +  end interface  | 
 | 24 | + | 
 | 25 | + | 
 | 26 | +  !> Implements a BLACS grid wrapper enforcing grid finalization  | 
 | 27 | +  type, extends(blacsgrid) :: blacs_grid_env  | 
 | 28 | + | 
 | 29 | +    !> Whether the grid contains all BLACS processes  | 
 | 30 | +    logical :: has_all_procs = .false.  | 
 | 31 | +  contains  | 
 | 32 | +    final :: final_blacs_grid_env  | 
 | 33 | +  end type blacs_grid_env  | 
 | 34 | + | 
 | 35 | + | 
 | 36 | +  ! Number of processes available in the BLACS framework  | 
 | 37 | +  integer :: num_procs_ = -1  | 
 | 38 | + | 
 | 39 | +  ! The id of the current process in the BLACS framework  | 
 | 40 | +  integer :: this_proc_ = -1  | 
 | 41 | + | 
 | 42 | +contains  | 
 | 43 | + | 
 | 44 | + | 
 | 45 | +  !> Returns the id of the current process in the BLACS framework  | 
 | 46 | +  function this_proc()  | 
 | 47 | +    integer :: this_proc  | 
 | 48 | +    this_proc = this_proc_  | 
 | 49 | +  end function this_proc  | 
 | 50 | + | 
 | 51 | + | 
 | 52 | +  !> Returns the number for processes available in the BLACS framework  | 
 | 53 | +  function num_procs()  | 
 | 54 | +    integer :: num_procs  | 
 | 55 | +    num_procs = num_procs_  | 
 | 56 | +  end function num_procs  | 
 | 57 | + | 
 | 58 | + | 
 | 59 | +  !> Wraps a blacs_case instance as test_item suitable for array constructors.  | 
 | 60 | +  function blacs_test(name, proc) result(testitem)  | 
 | 61 | +    character(*), intent(in) :: name  | 
 | 62 | +    procedure(blacs_test_procedure) :: proc  | 
 | 63 | + | 
 | 64 | +    type(test_item) :: testitem  | 
 | 65 | + | 
 | 66 | +    testitem = test_item(blacs_case(name=name, proc=proc))  | 
 | 67 | + | 
 | 68 | +  end function blacs_test  | 
 | 69 | + | 
 | 70 | + | 
 | 71 | +  !> Run procedure of the tempfile_case type.  | 
 | 72 | +  subroutine blacs_case_run(this)  | 
 | 73 | +    class(blacs_case), intent(in) :: this  | 
 | 74 | + | 
 | 75 | +    call blacsfx_pinfo(this_proc_, num_procs_)  | 
 | 76 | +    call check(num_procs_ == num_ranks(),&  | 
 | 77 | +        & "Number of BLACS processes differ from number of MPI ranks")  | 
 | 78 | +    if (failed()) return  | 
 | 79 | +    call this%proc()  | 
 | 80 | +    call blacsfx_exit(keepmpi=.true.)  | 
 | 81 | +    this_proc_ = -1  | 
 | 82 | +    num_procs_ = -1  | 
 | 83 | + | 
 | 84 | +  end subroutine blacs_case_run  | 
 | 85 | + | 
 | 86 | + | 
 | 87 | +  !> Returns a grid environment or sets the calling test to failed if not possible  | 
 | 88 | +  !!  | 
 | 89 | +  !! Note: This routine must be called from within fortuno MPI test procedures.  | 
 | 90 | +  !!  | 
 | 91 | +  subroutine get_grid_or_fail(this, nrow, ncol, includeall)  | 
 | 92 | + | 
 | 93 | +    !> Instance  | 
 | 94 | +    type(blacs_grid_env), intent(out) :: this  | 
 | 95 | + | 
 | 96 | +    !> Number of process rows  | 
 | 97 | +    integer, optional, intent(in) :: nrow  | 
 | 98 | + | 
 | 99 | +    !> Number of process columns  | 
 | 100 | +    integer, optional, intent(in) :: ncol  | 
 | 101 | + | 
 | 102 | +    !> Whether it should be ensured that all processes are included in the grid (default: .true.)  | 
 | 103 | +    logical, optional, intent(in) :: includeall  | 
 | 104 | + | 
 | 105 | +    integer :: nprocs  | 
 | 106 | +    integer :: nrow_, ncol_  | 
 | 107 | +    logical :: includeall_, hasall  | 
 | 108 | +    type(blacsgrid) :: grid  | 
 | 109 | + | 
 | 110 | +    includeall_ = .true.  | 
 | 111 | +    if (present(includeall)) includeall_ = includeall  | 
 | 112 | + | 
 | 113 | +    nprocs = num_procs()  | 
 | 114 | +    if (present(nrow) .and. present(ncol)) then  | 
 | 115 | +      nrow_ = nrow  | 
 | 116 | +      ncol_ = ncol  | 
 | 117 | +    else if (present(nrow)) then  | 
 | 118 | +      nrow_ = nrow  | 
 | 119 | +      ncol_ = nprocs / nrow_  | 
 | 120 | +    else if (present(ncol)) then  | 
 | 121 | +      ncol_ = ncol  | 
 | 122 | +      nrow_ = nprocs / ncol_  | 
 | 123 | +    else if (includeall_) then  | 
 | 124 | +      do nrow_ = floor(sqrt(real(nprocs))), 1, -1  | 
 | 125 | +        ncol_ = nprocs / nrow_  | 
 | 126 | +        if (ncol_ * nrow_ == nprocs) exit  | 
 | 127 | +      end do  | 
 | 128 | +    else  | 
 | 129 | +      nrow_ = floor(sqrt(real(nprocs)))  | 
 | 130 | +      ncol_ = nprocs / nrow_  | 
 | 131 | +    end if  | 
 | 132 | +    hasall = ncol_ * nrow_ == nprocs  | 
 | 133 | + | 
 | 134 | +    call check(nrow_ * ncol_ <= nprocs, msg="Required grid needs more processes than available")  | 
 | 135 | +    if (failed()) return  | 
 | 136 | +    call check(nrow_ > 0, msg="Could not set up grid with at least one process row")  | 
 | 137 | +    if (failed()) return  | 
 | 138 | +    call check(ncol_ > 0, msg="Could not set up grid with at least one process column")  | 
 | 139 | +    if (failed()) return  | 
 | 140 | +    call check(.not. includeall_ .or. hasall,&  | 
 | 141 | +        & msg="Could not include all processes in the required grid")  | 
 | 142 | +    if (failed()) return  | 
 | 143 | + | 
 | 144 | +    call this%blacsgrid%initgrid(nrow_, ncol_)  | 
 | 145 | +    this%has_all_procs = hasall  | 
 | 146 | + | 
 | 147 | +  end subroutine get_grid_or_fail  | 
 | 148 | + | 
 | 149 | + | 
 | 150 | +  subroutine final_blacs_grid_env(this)  | 
 | 151 | +    type(blacs_grid_env), intent(inout) :: this  | 
 | 152 | + | 
 | 153 | +    call this%blacsgrid%destruct()  | 
 | 154 | + | 
 | 155 | +  end subroutine final_blacs_grid_env  | 
 | 156 | + | 
 | 157 | +end module blacstestutils  | 
0 commit comments