Line data Source code
1 : ! This file is part of ELPA.
2 : !
3 : ! The ELPA library was originally created by the ELPA consortium,
4 : ! consisting of the following organizations:
5 : !
6 : ! - Max Planck Computing and Data Facility (MPCDF), formerly known as
7 : ! Rechenzentrum Garching der Max-Planck-Gesellschaft (RZG),
8 : ! - Bergische Universität Wuppertal, Lehrstuhl für angewandte
9 : ! Informatik,
10 : ! - Technische Universität München, Lehrstuhl für Informatik mit
11 : ! Schwerpunkt Wissenschaftliches Rechnen ,
12 : ! - Fritz-Haber-Institut, Berlin, Abt. Theorie,
13 : ! - Max-Plack-Institut für Mathematik in den Naturwissenschaften,
14 : ! Leipzig, Abt. Komplexe Strukutren in Biologie und Kognition,
15 : ! and
16 : ! - IBM Deutschland GmbH
17 : !
18 : !
19 : ! More information can be found here:
20 : ! http://elpa.mpcdf.mpg.de/
21 : !
22 : ! ELPA is free software: you can redistribute it and/or modify
23 : ! it under the terms of the version 3 of the license of the
24 : ! GNU Lesser General Public License as published by the Free
25 : ! Software Foundation.
26 : !
27 : ! ELPA is distributed in the hope that it will be useful,
28 : ! but WITHOUT ANY WARRANTY; without even the implied warranty of
29 : ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
30 : ! GNU Lesser General Public License for more details.
31 : !
32 : ! You should have received a copy of the GNU Lesser General Public License
33 : ! along with ELPA. If not, see <http://www.gnu.org/licenses/>
34 : !
35 : ! ELPA reflects a substantial effort on the part of the original
36 : ! ELPA consortium, and we ask you to respect the spirit of the
37 : ! license that we chose: i.e., please contribute any changes you
38 : ! may have back to the original ELPA library distribution, and keep
39 : ! any derivatives of ELPA under the same license that we chose for
40 : ! the original distribution, the GNU Lesser General Public License.
41 : !
42 : !
43 : #include "config-f90.h"
44 : module test_blacs_infrastructure
45 :
46 : contains
47 :
48 : !c> void set_up_blacsgrid_f(int mpi_comm_parent, int np_rows, int np_cols, char layout,
49 : !c> int* my_blacs_ctxt, int *my_prow, int *my_pcol);
50 18240 : subroutine set_up_blacsgrid(mpi_comm_parent, np_rows, np_cols, layout, &
51 : my_blacs_ctxt, my_prow, my_pcol) bind(C, name="set_up_blacsgrid_f")
52 :
53 : use test_util
54 :
55 : implicit none
56 : integer(kind=c_int), intent(in), value :: mpi_comm_parent, np_rows, np_cols
57 : character(len=1), intent(in), value :: layout
58 : integer(kind=c_int), intent(out) :: my_blacs_ctxt, my_prow, my_pcol
59 :
60 : #ifdef WITH_MPI
61 : integer :: np_rows_, np_cols_
62 : #endif
63 :
64 18240 : if (layout /= 'R' .and. layout /= 'C') then
65 0 : print *, "layout must be 'R' or 'C'"
66 0 : stop 1
67 : end if
68 :
69 18240 : my_blacs_ctxt = mpi_comm_parent
70 : #ifdef WITH_MPI
71 12288 : call BLACS_Gridinit(my_blacs_ctxt, layout, np_rows, np_cols)
72 12288 : call BLACS_Gridinfo(my_blacs_ctxt, np_rows_, np_cols_, my_prow, my_pcol)
73 12288 : if (np_rows /= np_rows_) then
74 0 : print *, "BLACS_Gridinfo returned different values for np_rows as set by BLACS_Gridinit"
75 0 : stop 1
76 : endif
77 12288 : if (np_cols /= np_cols_) then
78 0 : print *, "BLACS_Gridinfo returned different values for np_cols as set by BLACS_Gridinit"
79 0 : stop 1
80 : endif
81 : #else
82 5952 : my_prow = 0
83 5952 : my_pcol = 0
84 : #endif
85 18240 : end subroutine
86 :
87 18240 : subroutine set_up_blacs_descriptor(na, nblk, my_prow, my_pcol, &
88 : np_rows, np_cols, na_rows, &
89 : na_cols, sc_desc, my_blacs_ctxt, info)
90 :
91 : use elpa_utilities, only : error_unit
92 : use test_util
93 : implicit none
94 :
95 : integer(kind=ik), intent(in) :: na, nblk, my_prow, my_pcol, np_rows, &
96 : np_cols, &
97 : my_blacs_ctxt, info
98 : integer(kind=ik), intent(out) :: na_rows, na_cols, sc_desc(1:9)
99 :
100 : #ifdef WITH_MPI
101 : integer(kind=ik), external :: numroc
102 : integer(kind=ik) :: mpierr
103 :
104 12288 : sc_desc(:) = 0
105 : ! determine the neccessary size of the distributed matrices,
106 : ! we use the scalapack tools routine NUMROC
107 :
108 12288 : na_rows = numroc(na, nblk, my_prow, 0, np_rows)
109 12288 : na_cols = numroc(na, nblk, my_pcol, 0, np_cols)
110 :
111 : ! set up the scalapack descriptor for the checks below
112 : ! For ELPA the following restrictions hold:
113 : ! - block sizes in both directions must be identical (args 4 a. 5)
114 : ! - first row and column of the distributed matrix must be on
115 : ! row/col 0/0 (arg 6 and 7)
116 :
117 12288 : call descinit(sc_desc, na, na, nblk, nblk, 0, 0, my_blacs_ctxt, na_rows, info)
118 :
119 12288 : if (info .ne. 0) then
120 0 : write(error_unit,*) 'Error in BLACS descinit! info=',info
121 0 : write(error_unit,*) 'Most likely this happend since you want to use'
122 0 : write(error_unit,*) 'more MPI tasks than are possible for your'
123 0 : write(error_unit,*) 'problem size (matrix size and blocksize)!'
124 0 : write(error_unit,*) 'The blacsgrid can not be set up properly'
125 0 : write(error_unit,*) 'Try reducing the number of MPI tasks...'
126 0 : call MPI_ABORT(mpi_comm_world, 1, mpierr)
127 : endif
128 : #else /* WITH_MPI */
129 5952 : na_rows = na
130 5952 : na_cols = na
131 : #endif /* WITH_MPI */
132 :
133 18240 : end subroutine
134 :
135 : !c> void set_up_blacs_descriptor_f(int na, int nblk, int my_prow, int my_pcol,
136 : !c> int np_rows, int np_cols,
137 : !c> int *na_rows, int *na_cols,
138 : !c> int sc_desc[9],
139 : !c> int my_blacs_ctxt,
140 : !c> int *info);
141 3360 : subroutine set_up_blacs_descriptor_f(na, nblk, my_prow, my_pcol, &
142 : np_rows, np_cols, na_rows, &
143 : na_cols, sc_desc, &
144 : my_blacs_ctxt, info) &
145 : bind(C, name="set_up_blacs_descriptor_f")
146 :
147 : use iso_c_binding
148 : implicit none
149 :
150 :
151 : integer(kind=c_int), value :: na, nblk, my_prow, my_pcol, np_rows, &
152 : np_cols, my_blacs_ctxt
153 : integer(kind=c_int) :: na_rows, na_cols, info, sc_desc(1:9)
154 :
155 : call set_up_blacs_descriptor(na, nblk, my_prow, my_pcol, &
156 : np_rows, np_cols, na_rows, &
157 3360 : na_cols, sc_desc, my_blacs_ctxt, info)
158 :
159 :
160 3360 : end subroutine
161 :
162 8697600 : integer function index_l2g(idx_loc, nblk, iproc, nprocs)
163 8697600 : index_l2g = nprocs * nblk * ((idx_loc-1) / nblk) + mod(idx_loc-1,nblk) + mod(nprocs+iproc, nprocs)*nblk + 1
164 8697600 : return
165 : end function
166 :
167 : end module
|
