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 : ! Copyright of the original code rests with the authors inside the ELPA
44 : ! consortium. The copyright of any additional modifications shall rest
45 : ! with their original authors, but shall adhere to the licensing terms
46 : ! distributed along with the original code in the file "COPYING".
47 : !
48 : ! Author: Andreas Marek, MPCDF
49 :
50 : #include "config-f90.h"
51 :
52 : module ELPA_utilities
53 :
54 : #ifdef HAVE_ISO_FORTRAN_ENV
55 : use iso_fortran_env, only : output_unit, error_unit
56 : #endif
57 : use, intrinsic :: iso_c_binding
58 : implicit none
59 :
60 : private ! By default, all routines contained are private
61 :
62 : public :: output_unit, error_unit
63 : public :: check_alloc, check_alloc_CUDA_f, check_memcpy_CUDA_f, check_dealloc_CUDA_f
64 : public :: map_global_array_index_to_local_index
65 : public :: pcol, prow
66 : public :: local_index ! Get local index of a block cyclic distributed matrix
67 : public :: least_common_multiple ! Get least common multiple
68 :
69 : #ifndef HAVE_ISO_FORTRAN_ENV
70 : integer, parameter :: error_unit = 0
71 : integer, parameter :: output_unit = 6
72 : #endif
73 :
74 : !******
75 : contains
76 :
77 : #include "prow_pcol.F90"
78 :
79 : !-------------------------------------------------------------------------------
80 : #include "map_global_to_local.F90"
81 :
82 328825332 : integer function local_index(idx, my_proc, num_procs, nblk, iflag)
83 :
84 : !-------------------------------------------------------------------------------
85 : ! local_index: returns the local index for a given global index
86 : ! If the global index has no local index on the
87 : ! processor my_proc behaviour is defined by iflag
88 : !
89 : ! Parameters
90 : !
91 : ! idx Global index
92 : !
93 : ! my_proc Processor row/column for which to calculate the local index
94 : !
95 : ! num_procs Total number of processors along row/column
96 : !
97 : ! nblk Blocksize
98 : !
99 : ! iflag Controls the behaviour if idx is not on local processor
100 : ! iflag< 0 : Return last local index before that row/col
101 : ! iflag==0 : Return 0
102 : ! iflag> 0 : Return next local index after that row/col
103 : !-------------------------------------------------------------------------------
104 : implicit none
105 :
106 : integer(kind=c_int) :: idx, my_proc, num_procs, nblk, iflag
107 :
108 : integer(kind=c_int) :: iblk
109 :
110 328825332 : iblk = (idx-1)/nblk ! global block number, 0 based
111 :
112 328825332 : if (mod(iblk,num_procs) == my_proc) then
113 :
114 : ! block is local, always return local row/col number
115 :
116 319496832 : local_index = (iblk/num_procs)*nblk + mod(idx-1,nblk) + 1
117 :
118 : else
119 :
120 : ! non local block
121 :
122 9328500 : if (iflag == 0) then
123 :
124 0 : local_index = 0
125 :
126 : else
127 :
128 9328500 : local_index = (iblk/num_procs)*nblk
129 :
130 9328500 : if (mod(iblk,num_procs) > my_proc) local_index = local_index + nblk
131 :
132 9328500 : if (iflag>0) local_index = local_index + 1
133 : endif
134 : endif
135 :
136 328825332 : end function local_index
137 :
138 6837144 : integer function least_common_multiple(a, b)
139 :
140 : ! Returns the least common multiple of a and b
141 : ! There may be more efficient ways to do this, we use the most simple approach
142 : implicit none
143 : integer(kind=c_int), intent(in) :: a, b
144 :
145 8695416 : do least_common_multiple = a, a*(b-1), a
146 1858272 : if(mod(least_common_multiple,b)==0) exit
147 : enddo
148 : ! if the loop is left regularly, least_common_multiple = a*b
149 :
150 6837144 : end function least_common_multiple
151 :
152 130176 : subroutine check_alloc(function_name, variable_name, istat, errorMessage)
153 :
154 : implicit none
155 :
156 : character(len=*), intent(in) :: function_name
157 : character(len=*), intent(in) :: variable_name
158 : integer(kind=c_int), intent(in) :: istat
159 : character(len=*), intent(in) :: errorMessage
160 :
161 130176 : if (istat .ne. 0) then
162 0 : print *, function_name, ": error when allocating ", variable_name, " ", errorMessage
163 0 : stop 1
164 : endif
165 260352 : end subroutine
166 :
167 0 : subroutine check_alloc_CUDA_f(file_name, line, successCUDA)
168 :
169 : implicit none
170 :
171 : character(len=*), intent(in) :: file_name
172 : integer(kind=c_int), intent(in) :: line
173 : logical :: successCUDA
174 :
175 0 : if (.not.(successCUDA)) then
176 0 : print *, file_name, ":", line, " error in cuda_malloc when allocating "
177 0 : stop 1
178 : endif
179 0 : end subroutine
180 :
181 0 : subroutine check_dealloc_CUDA_f(file_name, line, successCUDA)
182 :
183 : implicit none
184 :
185 : character(len=*), intent(in) :: file_name
186 : integer(kind=c_int), intent(in) :: line
187 : logical :: successCUDA
188 :
189 0 : if (.not.(successCUDA)) then
190 0 : print *, file_name, ":", line, " error in cuda_free when deallocating "
191 0 : stop 1
192 : endif
193 0 : end subroutine
194 :
195 0 : subroutine check_memcpy_CUDA_f(file_name, line, successCUDA)
196 :
197 : implicit none
198 :
199 : character(len=*), intent(in) :: file_name
200 : integer(kind=c_int), intent(in) :: line
201 : logical :: successCUDA
202 :
203 0 : if (.not.(successCUDA)) then
204 0 : print *, file_name, ":", line, " error in cuda_memcpy when copying "
205 0 : stop 1
206 : endif
207 0 : end subroutine
208 :
209 : end module ELPA_utilities
|
