test_blacs_infrastructure.F90 6.48 KB
Newer Older
Andreas Marek's avatar
Andreas Marek committed
1
2
3
4
5
!    This file is part of ELPA.
!
!    The ELPA library was originally created by the ELPA consortium,
!    consisting of the following organizations:
!
6
7
!    - Max Planck Computing and Data Facility (MPCDF), formerly known as
!      Rechenzentrum Garching der Max-Planck-Gesellschaft (RZG),
Andreas Marek's avatar
Andreas Marek committed
8
9
10
11
12
13
14
15
16
17
18
19
!    - Bergische Universität Wuppertal, Lehrstuhl für angewandte
!      Informatik,
!    - Technische Universität München, Lehrstuhl für Informatik mit
!      Schwerpunkt Wissenschaftliches Rechnen ,
!    - Fritz-Haber-Institut, Berlin, Abt. Theorie,
!    - Max-Plack-Institut für Mathematik in den Naturwissenschaften,
!      Leipzig, Abt. Komplexe Strukutren in Biologie und Kognition,
!      and
!    - IBM Deutschland GmbH
!
!
!    More information can be found here:
20
!    http://elpa.mpcdf.mpg.de/
Andreas Marek's avatar
Andreas Marek committed
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
!
!    ELPA is free software: you can redistribute it and/or modify
!    it under the terms of the version 3 of the license of the
!    GNU Lesser General Public License as published by the Free
!    Software Foundation.
!
!    ELPA is distributed in the hope that it will be useful,
!    but WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!    GNU Lesser General Public License for more details.
!
!    You should have received a copy of the GNU Lesser General Public License
!    along with ELPA.  If not, see <http://www.gnu.org/licenses/>
!
!    ELPA reflects a substantial effort on the part of the original
!    ELPA consortium, and we ask you to respect the spirit of the
!    license that we chose: i.e., please contribute any changes you
!    may have back to the original ELPA library distribution, and keep
!    any derivatives of ELPA under the same license that we chose for
!    the original distribution, the GNU Lesser General Public License.
!
!
43
#include "config-f90.h"
44
module test_blacs_infrastructure
Andreas Marek's avatar
Andreas Marek committed
45
46
47

  contains

48
49
50
51
    !c> void set_up_blacsgrid_f(int mpi_comm_parent, int np_rows, int np_cols, char layout,
    !c>                         int* my_blacs_ctxt, int *my_prow, int *my_pcol);
    subroutine set_up_blacsgrid(mpi_comm_parent, np_rows, np_cols, layout, &
                                my_blacs_ctxt, my_prow, my_pcol) bind(C, name="set_up_blacsgrid_f")
Andreas Marek's avatar
Andreas Marek committed
52

53
      use test_util
54

Andreas Marek's avatar
Andreas Marek committed
55
      implicit none
56
57
58
59
60
61
62
63
64
65
66
67
      integer(kind=c_int), intent(in), value  :: mpi_comm_parent, np_rows, np_cols
      character(len=1), intent(in), value     :: layout
      integer(kind=c_int), intent(out)        :: my_blacs_ctxt, my_prow, my_pcol

#ifdef WITH_MPI
      integer :: np_rows_, np_cols_
#endif

      if (layout /= 'R' .and. layout /= 'C') then
        print *, "layout must be 'R' or 'C'"
        stop 1
      end if
Andreas Marek's avatar
Andreas Marek committed
68

69
      my_blacs_ctxt = mpi_comm_parent
70
#ifdef WITH_MPI
71
72
73
74
75
76
77
78
79
80
      call BLACS_Gridinit(my_blacs_ctxt, layout, np_rows, np_cols)
      call BLACS_Gridinfo(my_blacs_ctxt, np_rows_, np_cols_, my_prow, my_pcol)
      if (np_rows /= np_rows_) then
        print *, "BLACS_Gridinfo returned different values for np_rows as set by BLACS_Gridinit"
        stop 1
      endif
      if (np_cols /= np_cols_) then
        print *, "BLACS_Gridinfo returned different values for np_cols as set by BLACS_Gridinit"
        stop 1
      endif
81
82
83
84
#else
      my_prow = 0
      my_pcol = 0
#endif
Andreas Marek's avatar
Andreas Marek committed
85
86
87
88
89
90
    end subroutine

    subroutine set_up_blacs_descriptor(na, nblk, my_prow, my_pcol, &
                                       np_rows, np_cols, na_rows,  &
                                       na_cols, sc_desc, my_blacs_ctxt, info)

Andreas Marek's avatar
Andreas Marek committed
91
      use elpa_utilities, only : error_unit
92
      use test_util
Andreas Marek's avatar
Andreas Marek committed
93
94
      implicit none

95
96
97
98
      integer(kind=ik), intent(in)  :: na, nblk, my_prow, my_pcol, np_rows,   &
                                       np_cols, &
                                       my_blacs_ctxt, info
      integer(kind=ik), intent(out)  :: na_rows, na_cols, sc_desc(1:9)
99
#ifdef WITH_MPI
100
      integer(kind=ik), external       :: numroc
101
      integer(kind=ik)                 :: mpierr
Andreas Marek's avatar
Andreas Marek committed
102
103
104
105
106
107
108
109
110
111
112
113
114
115

      ! determine the neccessary size of the distributed matrices,
      ! we use the scalapack tools routine NUMROC

      na_rows = numroc(na, nblk, my_prow, 0, np_rows)
      na_cols = numroc(na, nblk, my_pcol, 0, np_cols)

      ! set up the scalapack descriptor for the checks below
      ! For ELPA the following restrictions hold:
      ! - block sizes in both directions must be identical (args 4 a. 5)
      ! - first row and column of the distributed matrix must be on
      !   row/col 0/0 (arg 6 and 7)

      call descinit(sc_desc, na, na, nblk, nblk, 0, 0, my_blacs_ctxt, na_rows, info)
Andreas Marek's avatar
Andreas Marek committed
116
117
118
119
120
121
122
123
124
125

      if (info .ne. 0) then
        write(error_unit,*) 'Error in BLACS descinit! info=',info
        write(error_unit,*) 'Most likely this happend since you want to use'
        write(error_unit,*) 'more MPI tasks than are possible for your'
        write(error_unit,*) 'problem size (matrix size and blocksize)!'
        write(error_unit,*) 'The blacsgrid can not be set up properly'
        write(error_unit,*) 'Try reducing the number of MPI tasks...'
        call MPI_ABORT(mpi_comm_world, 1, mpierr)
      endif
126
#else /* WITH_MPI */
127
128
      na_rows = na
      na_cols = na
129
#endif /* WITH_MPI */
Andreas Marek's avatar
Andreas Marek committed
130

Andreas Marek's avatar
Andreas Marek committed
131
132
    end subroutine

133
134
135
136
137
138
139
140
141
142
143
    !c> void set_up_blacs_descriptor_f(int na, int nblk, int my_prow, int my_pcol,
    !c>                                int np_rows, int np_cols,
    !c>                                int *na_rows, int *na_cols,
    !c>                                int sc_desc[9],
    !c>                                int my_blacs_ctxt,
    !c>                                int *info);
    subroutine set_up_blacs_descriptor_f(na, nblk, my_prow, my_pcol, &
                                         np_rows, np_cols, na_rows,  &
                                         na_cols, sc_desc,           &
                                         my_blacs_ctxt, info)        &
                                         bind(C, name="set_up_blacs_descriptor_f")
Andreas Marek's avatar
Andreas Marek committed
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159

      use iso_c_binding
      implicit none


      integer(kind=c_int), value :: na, nblk, my_prow, my_pcol, np_rows, &
                                    np_cols, my_blacs_ctxt
      integer(kind=c_int)        :: na_rows, na_cols, info, sc_desc(1:9)

      call set_up_blacs_descriptor(na, nblk, my_prow, my_pcol, &
                                   np_rows, np_cols, na_rows,  &
                                   na_cols, sc_desc, my_blacs_ctxt, info)


    end subroutine

160
161
162
    integer function index_l2g(idx_loc, nblk, iproc, nprocs)
     index_l2g = nprocs * nblk * ((idx_loc-1) / nblk) + mod(idx_loc-1,nblk) + mod(nprocs+iproc, nprocs)*nblk + 1
     return
Andreas Marek's avatar
Andreas Marek committed
163
   end function
164

Andreas Marek's avatar
Andreas Marek committed
165
end module