Branch data Line data Source code
1 : : !!****m* ABINIT/m_slk
2 : : !! NAME
3 : : !! m_slk
4 : : !!
5 : : !! FUNCTION
6 : : !! High-level objects and wrappers around the ScaLAPACK, ELPA and SLATE API.
7 : : !!
8 : : !! Object model:
9 : : !!
10 : : !! slk_grid_t 2D BLACS grid of nprocs = dims(1) * dims(2) processes (row-major ordering).
11 : : !! slk_processor_t One process of the grid: rank, coordinates, MPI communicator and a copy of the grid.
12 : : !! basemat_t Private base class: global and local shapes, block sizes, ScaLAPACK descriptor
13 : : !! and a POINTER to the slk_processor_t passed to init.
14 : : !! slkmat_dp_t Double precision matrix: local buffer in buffer_cplx (istwf_k /= 2) or buffer_real (istwf_k == 2).
15 : : !! slkmat_sp_t Single precision version (subset of the methods).
16 : : !!
17 : : !! The global matrix is stored with the 2D block-cyclic distribution of ScaLAPACK, the first block
18 : : !! belongs to the process with coordinates (0, 0) (RSRC = CSRC = 0 for all the matrices built by init).
19 : : !! Each process stores only its local buffer of shape size_local. Use loc2glob, loc2grow, loc2gcol
20 : : !! to get the global indices of the local entries and glob2loc to find the owner of a global entry.
21 : : !!
22 : : !! Typical usage:
23 : : !!
24 : : !! type(slk_processor_t) :: slkproc
25 : : !! type(slkmat_dp_t) :: mat, vec
26 : : !!
27 : : !! call slkproc%init(comm) ! BLACS grid built from the MPI communicator.
28 : : !! call mat%init(nn, nn, slkproc, istwf_k1) ! Complex nn x nn matrix, default block sizes.
29 : : !! do jloc=1,mat%size_local(2) ! Fill the local buffer.
30 : : !! do iloc=1,mat%size_local(1)
31 : : !! call mat%loc2glob(iloc, jloc, iglob, jglob)
32 : : !! mat%buffer_cplx(iloc, jloc) = ... ! Value of the (iglob, jglob) entry.
33 : : !! end do
34 : : !! end do
35 : : !! call vec%init(nn, nn, slkproc, istwf_k1)
36 : : !! call mat%heev("V", "U", vec, eigvals) ! Collective on the processes of the grid.
37 : : !! call slk_matrix_to_global_dpc_2D(vec, "A", glob_vec) ! Only the local entries are written:
38 : : !! call xmpi_sum(glob_vec, comm, ierr) ! glob_vec must be zero on entry, then MPI sum.
39 : : !! call mat%free(); call vec%free()
40 : : !! call slkproc%free() ! Free the processor after the matrices.
41 : : !!
42 : : !! A one-dimensional column distribution (used in m_gwr) is obtained with grid_dims=[1, nproc] and
43 : : !! size_blocs=[-1, col_bsize], where col_bsize is given by block_dist_1d.
44 : : !!
45 : : !! Backends:
46 : : !! HAVE_LINALG_SCALAPACK required by almost everything in this module.
47 : : !! HAVE_LINALG_ELPA compute_eigen_problem and compute_generalized_eigen_problem use ELPA.
48 : : !! HAVE_LINALG_SLATE compute_eigen_problem uses SLATE if ELPA is not available.
49 : : !! HAVE_OPENMP_OFFLOAD gpu_map, gpu_set_zero and is_gpu_mapped act on the GPU copy of the local buffer.
50 : : !!
51 : : !! NOTES
52 : : !! - Without HAVE_LINALG_SCALAPACK, init does not allocate the local buffer and most methods do nothing.
53 : : !! There is no sequential fallback: callers must check that ScaLAPACK is available.
54 : : !! - matrix%processor points to the slk_processor_t passed to init. The processor must outlive all the
55 : : !! matrices built with it: do not pass a local variable that goes out of scope before the matrix is freed.
56 : : !! - After init, slk_grid_t%comm contains the BLACS context returned by BLACS_GRIDINIT, not an MPI communicator.
57 : : !! Use slk_processor_t%comm for MPI calls.
58 : : !! - istwf_k selects the buffer: istwf_k == 2 means real matrix (buffer_real), any other value complex matrix
59 : : !! (buffer_cplx). Some methods (heev, invert, hpd_invert, collect_cplx) support only complex matrices.
60 : : !! - Default block size: 24 with ScaLAPACK, 16 on GPU, 1 if ELPA is available. Square blocks are enforced
61 : : !! if ELPA or SLATE are available.
62 : : !! - Routines based on p?gemr2d (take_from, cut, change_size_blocs, collect_cplx) must be called by all the
63 : : !! processes owning the input or the output matrix.
64 : : !!
65 : : !! COPYRIGHT
66 : : !! Copyright (C) 2004-2026 ABINIT group (CS,GZ,FB,MG,MT)
67 : : !! This file is distributed under the terms of the
68 : : !! GNU General Public License, see ~abinit/COPYING
69 : : !! or http://www.gnu.org/copyleft/gpl.txt .
70 : : !!
71 : : !! TODO
72 : : !! Provide fallbacks for sequential version (No scalapack) so that we can implement generic high-level algorithms.
73 : : !!
74 : : !! SOURCE
75 : :
76 : : #if defined HAVE_CONFIG_H
77 : : #include "config.h"
78 : : #endif
79 : :
80 : : #include "abi_common.h"
81 : :
82 : : module m_slk
83 : :
84 : : use, intrinsic :: iso_c_binding
85 : : use defs_basis
86 : : USE_MPI
87 : : use m_xmpi
88 : : use m_xomp
89 : : use m_errors
90 : : use m_abicore
91 : : use m_gputk
92 : : #ifdef HAVE_LINALG_ELPA
93 : : use m_elpa
94 : : #endif
95 : :
96 : : use m_fstrings, only : firstchar, toupper, itoa, sjoin, ltoa, string_in
97 : : use m_time, only : cwtime, cwtime_report
98 : : !use m_numeric_tools, only : blocked_loop !, print_arr
99 : :
100 : : implicit none
101 : :
102 : : #ifdef HAVE_MPI1
103 : : include 'mpif.h'
104 : : #endif
105 : :
106 : : private
107 : :
108 : : ! scaLAPACK array descriptor.
109 : : integer,private,parameter :: DLEN_ = 9 ! length
110 : : integer,private,parameter :: Dtype_ = 1 ! type
111 : : integer,private,parameter :: CTXT_ = 2 ! BLACS context
112 : : integer,private,parameter :: M_ = 3 ! nb global lines
113 : : integer,private,parameter :: N_ = 4 ! nb global columns
114 : : integer,private,parameter :: MB_ = 5 ! nb lines of a block
115 : : integer,private,parameter :: NB_ = 6 ! nb columns of a block
116 : : integer,private,parameter :: RSRC_ = 7 ! line of processors at the beginning
117 : : integer,private,parameter :: CSRC_ = 8 ! column of processors at the beginning
118 : : integer,private,parameter :: LLD_ = 9 ! local number of lines
119 : : !!***
120 : :
121 : : !----------------------------------------------------------------------
122 : :
123 : : !!****t* m_slk/slk_grid_t
124 : : !! NAME
125 : : !! slk_grid_t
126 : : !!
127 : : !! FUNCTION
128 : : !! Grid of ScaLAPACK processors.
129 : : !!
130 : : !! SOURCE
131 : :
132 : : type,public :: slk_grid_t
133 : :
134 : : integer :: nprocs = -1
135 : : ! Total number of processors
136 : :
137 : : integer :: dims(2) = -1
138 : : ! Number of procs for rows/columns
139 : :
140 : : integer :: comm = xmpi_comm_null
141 : : ! MPI communicator on input of init. BLACS_GRIDINIT replaces it with the BLACS context of the grid
142 : : ! so this is NOT an MPI communicator after init: use slk_processor_t%comm for MPI calls.
143 : :
144 : : logical :: use_gpu = .false.
145 : : ! Whether GPU is used, relevant for determining matrix block size.
146 : :
147 : : contains
148 : : procedure :: init => slk_grid_init ! Set up the processor grid for ScaLAPACK.
149 : : end type slk_grid_t
150 : : !!***
151 : :
152 : : !----------------------------------------------------------------------
153 : :
154 : : !!****t* m_slk/slk_processor_t
155 : : !! NAME
156 : : !! slk_processor_t
157 : : !!
158 : : !! FUNCTION
159 : : !! One processor in the grid.
160 : : !! Matrices store a pointer to this object so it must be freed after all the matrices built with it.
161 : : !!
162 : : !! SOURCE
163 : :
164 : : type,public :: slk_processor_t
165 : :
166 : : integer :: my_rank = -1
167 : : ! rank of the processor in comm
168 : :
169 : : integer :: comm = xmpi_comm_null
170 : : ! MPI communicator underlying the BLACS grid.
171 : :
172 : : integer :: coords(2) = -1
173 : : ! Coordinates (row, column) of the processor in the grid, starting from 0.
174 : :
175 : : type(slk_grid_t) :: grid
176 : : ! the grid to which the processor is associated to.
177 : :
178 : : contains
179 : : procedure :: init => slk_processor_init ! Initializes an instance of processor ScaLAPACK from a MPI communicator.
180 : : procedure :: free => slk_processor_free ! Free the object
181 : : end type slk_processor_t
182 : : !!***
183 : :
184 : : !----------------------------------------------------------------------
185 : :
186 : : !!****t* m_slk/basemat_t
187 : : !! NAME
188 : : !! basemat_t
189 : : !!
190 : : !! FUNCTION
191 : : !! Base class for scalapack matrices.
192 : : !! Methods that are agnostic about type and precision or methods that can handle both
193 : : !! single and double precision, real and complex arrays via `select type` should be defined here.
194 : : !!
195 : : !! SOURCE
196 : :
197 : : type, private :: basemat_t
198 : :
199 : : integer :: size_local(2) = -1
200 : : ! dimensions of the local buffer.
201 : :
202 : : integer(c_size_t) :: bufsize = -1
203 : : ! Number of elements in the local buffer: size_local(1) * size_local(2).
204 : :
205 : : integer :: size_global(2) = -1
206 : : ! dimensions of the global matrix. [-1, -1] before the first init, [0, 0] after free.
207 : :
208 : : integer :: size_blocs(2) = -1
209 : : ! Row and column block sizes of the block-cyclic distribution (MB and NB in ScaLAPACK).
210 : :
211 : : integer :: istwf_k = -1
212 : : ! 2 for a real matrix stored in buffer_real, any other value for a complex matrix stored in buffer_cplx.
213 : :
214 : : type(slk_processor_t),pointer :: processor => null()
215 : : ! Processor passed to init. Not owned by the matrix: free does not deallocate it.
216 : :
217 : : integer :: desc(DLEN_)
218 : : ! Scalapack descriptor. desc(CTXT_) = -1 tells p?gemr2d that this process does not own the matrix.
219 : :
220 : : contains
221 : :
222 : : procedure :: init => basemat_init
223 : : ! Basic Constructor
224 : :
225 : : procedure :: glob2loc => basemat_glob2loc
226 : : ! Determine the local indices of an element from its global indices and return haveit bool flag.
227 : :
228 : : procedure :: loc2glob => basemat_loc2glob
229 : : ! Return global indices of a matrix element from the local indices.
230 : :
231 : : procedure :: loc2grow => basemat_loc2grow
232 : : ! Determine the global row index from the local index
233 : :
234 : : procedure :: loc2gcol => basemat_loc2col
235 : : ! Determine the global column index from the local index
236 : :
237 : : procedure :: idx_loc => basemat_idx_loc
238 : : ! Number of rows (columns) among the first i (j) global rows (columns) that are stored on this processor.
239 : :
240 : : procedure :: locmem_mb => basemat_locmem_mb
241 : : ! Return memory allocated for the local buffer in Mb.
242 : :
243 : : procedure :: print => basemat_print
244 : : ! Print info on the object.
245 : :
246 : : procedure :: check_local_shape => basemat_check_local_shape
247 : : ! Debugging tool to test the local shape `lshape` of the local buffer.
248 : :
249 : : procedure :: is_gpu_mapped => basemat_is_gpu_mapped
250 : : ! True if the local buffer is mapped to the GPU.
251 : :
252 : : procedure :: gpu_map => basemat_gpu_map
253 : : ! Use OpenMP to allocate/delete the local buffer on the GPU.
254 : :
255 : : procedure :: gpu_set_zero => basemat_gpu_set_zero
256 : : ! Fill the local buffer on the GPU with zeros.
257 : :
258 : : procedure :: free => basemat_free
259 : : ! Free memory
260 : :
261 : : procedure :: change_size_blocs => basemat_change_size_blocs
262 : : ! Change the block sizes, return new object.
263 : :
264 : : procedure :: get_trace => basemat_get_trace
265 : : ! Compute the trace of an N-by-N distributed matrix.
266 : :
267 : : procedure :: set_imag_diago_to_zero => basemat_set_imag_diago_to_zero
268 : : ! Set the imaginary part of the diagonal to zero.
269 : :
270 : : procedure :: invert => basemat_invert
271 : : ! Inverse of a complex matrix (LU factorization). Requires square blocks.
272 : :
273 : : end type basemat_t
274 : : !!***
275 : :
276 : : !----------------------------------------------------------------------
277 : :
278 : : !!****t* m_slk/slkmat_dp_t
279 : : !! NAME
280 : : !! slkmat_dp_t
281 : : !!
282 : : !! FUNCTION
283 : : !! high-level interface to ScaLAPACK matrix (double precision version)
284 : : !!
285 : : !! SOURCE
286 : :
287 : : type, public, extends(basemat_t) :: slkmat_dp_t
288 : :
289 : : real(dp),allocatable :: buffer_real(:,:)
290 : : ! local part of the (real) matrix.
291 : : ! The istwf_k option passed to the constructor defines whether we have a real or complex matrix
292 : :
293 : : complex(dpc),allocatable :: buffer_cplx(:,:)
294 : : ! local part of the (complex) matrix
295 : :
296 : : contains
297 : :
298 : : procedure :: get_head_and_wings => slkmat_dp_get_head_and_wings
299 : : ! Return global arrays with the head and the wings of the matrix.
300 : :
301 : : procedure :: set_head_and_wings => slkmat_dp_set_head_and_wings
302 : : ! Set head and the wings of the matrix starting from global arrays.
303 : :
304 : : procedure :: copy => slkmat_dp_copy
305 : : ! Copy object
306 : :
307 : : procedure :: hpd_invert => slkmat_dp_hpd_invert
308 : : ! Inverse of a Hermitian positive definite matrix.
309 : :
310 : : procedure :: ptrans => slkmat_dp_ptrans
311 : : ! Transpose ("N") or conjugate transpose ("C") matrix, return new matrix.
312 : :
313 : : procedure :: cut => slkmat_dp_cut
314 : : ! Extract submatrix and create new matrix with `size_blocs` and `processor`
315 : :
316 : : procedure :: take_from => slkmat_dp_take_from
317 : : ! Copy values from source, possibly distributed with a different grid or block sizes.
318 : :
319 : : procedure :: collect_cplx => slkmat_dp_collect_cplx
320 : : ! Return on all processors the submatrix of shape (mm, nn) starting at position ija.
321 : :
322 : : procedure :: heev => slkmat_dp_heev
323 : : ! Compute eigenvalues and, optionally, eigenvectors of an Hermitian matrix A. A * X = lambda * X
324 : : ! (PZHEEV, complex matrices only)
325 : :
326 : : procedure :: pzheevx => slkmat_dp_pzheevx
327 : : ! Compute selected eigenvalues and, optionally, eigenvectors of a complex Hermitian matrix A. A * X = lambda * X
328 : :
329 : : procedure :: pzhegvx => slkmat_dp_pzhegvx
330 : : ! Eigenvalues and, optionally, eigenvectors of a complex
331 : : ! generalized Hermitian-definite eigenproblem, of the form
332 : : ! sub( A )*x=(lambda)*sub( B )*x, sub( A )*sub( B )x=(lambda)*x,
333 : : ! or sub( B )*sub( A )*x=(lambda)*x.
334 : :
335 : : procedure :: symmetrize => slkmat_dp_symmetrize
336 : : ! Symmetrizes a square scaLAPACK matrix.
337 : :
338 : : procedure :: bsize_and_type => slkmat_dp_bsize_and_type
339 : : ! Returns the byte size and the MPI datatype
340 : :
341 : : procedure :: svd => slkmat_dp_svd
342 : : ! Singular Value Decomposition (double precision version).
343 : :
344 : : ! Conversion between the distributed matrix and a global matrix replicated on all the processes.
345 : : ! from_*: each process copies the entries it owns from the global matrix.
346 : : ! to_*: each process writes only the entries it owns, the other entries of the global matrix are not changed.
347 : : ! Zero the global matrix before the call and sum over the processes after.
348 : :
349 : : procedure :: to_global => slkmat_dp_to_global
350 : : ! Insert the matrix into a full real(dp) array: (2*n, m) with real/imag pairs if complex, (n, m) if real.
351 : :
352 : : procedure :: from_real_glob => slkmat_dp_from_real_glob
353 : : ! Fill a real matrix from a full real(dp) array (n, m).
354 : :
355 : : procedure :: from_global_pack => slkmat_dp_from_global_pack
356 : : ! Fill the upper triangle of a matrix from a packed array (upper triangle, columnwise).
357 : :
358 : : procedure :: from_global_sym => slkmat_dp_from_global_sym
359 : : ! Fill a full Hermitian (symmetric) matrix from a packed array (upper triangle, columnwise).
360 : :
361 : : procedure :: to_global_pack => slkmat_dp_to_global_pack
362 : : ! Insert the upper triangle of the matrix into a packed array (upper triangle, columnwise).
363 : :
364 : : procedure :: to_real_glob => slkmat_dp_to_real_glob
365 : : ! Insert a real matrix into a full real(dp) array (n, m).
366 : :
367 : : procedure :: to_complex_glob => slkmat_dp_to_complex_glob
368 : : ! Insert a complex matrix into a full complex(dpc) array (n, m).
369 : :
370 : : procedure :: from_complex_glob => slkmat_dp_from_complex_glob
371 : : ! Fill a complex matrix from a full real(dp) array (2*n, m) with real/imag pairs.
372 : :
373 : : end type slkmat_dp_t
374 : : !!***
375 : :
376 : : !!****t* m_slk/slkmat_sp_t
377 : : !! NAME
378 : : !! slkmat_sp_t
379 : : !!
380 : : !! FUNCTION
381 : : !! High-level interface to ScaLAPACK matrix (single precision version).
382 : : !!
383 : : !! SOURCE
384 : :
385 : : type, public, extends(basemat_t) :: slkmat_sp_t
386 : :
387 : : real(sp),allocatable :: buffer_real(:,:)
388 : : ! local part of the (real) matrix.
389 : : ! The istwf_k option passed to the constructor defines whether we have a real or complex matrix
390 : :
391 : : complex(sp),allocatable :: buffer_cplx(:,:)
392 : : ! local part of the (complex) matrix
393 : :
394 : : contains
395 : :
396 : : procedure :: copy => slkmat_sp_copy
397 : : ! Copy object
398 : :
399 : : procedure :: take_from => slkmat_sp_take_from
400 : : ! Take values from source
401 : :
402 : : procedure :: ptrans => slkmat_sp_ptrans
403 : : ! Transpose matrix
404 : :
405 : : procedure :: set_head_and_wings => slkmat_sp_set_head_and_wings
406 : : ! Set head and the wings of the matrix starting from global arrays.
407 : :
408 : : procedure :: cut => slkmat_sp_cut
409 : : ! Extract submatrix and create new matrix with `size_blocs` and `processor`
410 : :
411 : : procedure :: collect_cplx => slkmat_sp_collect_cplx
412 : : ! Return on all processors the submatrix of shape (mm, nn) starting at position ija.
413 : :
414 : : procedure :: heev => slkmat_sp_heev
415 : : ! Compute eigenvalues and, optionally, eigenvectors of an Hermitian matrix A. A * X = lambda * X
416 : :
417 : : procedure :: hpd_invert => slkmat_sp_hpd_invert
418 : : ! Inverse of a Hermitian positive definite matrix.
419 : :
420 : : procedure :: svd => slkmat_sp_svd
421 : : ! Singular Value Decomposition (single precision version).
422 : :
423 : : end type slkmat_sp_t
424 : : !!***
425 : :
426 : : ! Utilities.
427 : : public :: block_dist_1d ! Return block size for one-dimensional block column/row distribution
428 : : public :: slk_has_elpa ! Return True if ELPA support is activated
429 : :
430 : : ! Access to the local buffer with local indices (equivalent to mat%buffer_cplx(i,j) and mat%buffer_real(i,j)).
431 : : public :: matrix_get_local_cplx ! Return a local matrix coefficient of complex type.
432 : : public :: matrix_get_local_real ! Return a local matrix coefficient of double precision type.
433 : : public :: matrix_set_local_cplx ! Sets a local matrix coefficient of complex type.
434 : : public :: matrix_set_local_real ! Sets a local matrix coefficient of double precision type.
435 : :
436 : : ! Conversion between distributed and global complex matrices (see also the from_* and to_* methods).
437 : : public :: slk_matrix_from_global_dpc_2D ! Fill a complex SCALAPACK matrix with respect to a global matrix.
438 : : public :: slk_matrix_from_global_dpc_1Dp ! Fill a complex SCALAPACK matrix with respect to a global matrix.
439 : : ! target: double precision complex matrix in packed form.
440 : : public :: slk_matrix_to_global_dpc_2D ! Fill a global matrix with respect to a SCALAPACK matrix.
441 : : ! target: Two-dimensional Double precision complex matrix.
442 : :
443 : : ! PBLAS.
444 : : public :: slk_pgemm ! Compute: C := alpha*op(A)*op(B) + beta*C
445 : : interface slk_pgemm
446 : : module procedure slk_pgemm_dp
447 : : module procedure slk_pgemm_sp
448 : : end interface slk_pgemm
449 : :
450 : : ! Eigensolvers using ELPA, SLATE or ScaLAPACK depending on the build (see also the heev, pzheevx, pzhegvx methods).
451 : : public :: compute_eigen_problem ! Compute eigenvalues and eigenvectors of: A * X = lambda * X.
452 : : ! complex and real cases.
453 : : public :: compute_generalized_eigen_problem ! Compute generalized eigenvalue problem
454 : : public :: compute_eigen1 ! Same as compute_eigen_problem but for a global matrix replicated on all procs.
455 : : ! complex and real cases.
456 : : public :: compute_eigen2 ! Same as compute_generalized_eigen_problem but for global matrices
457 : : ! replicated on all procs. A * X = lambda * B * X, complex and real cases.
458 : :
459 : : ! MPI-IO.
460 : :
461 : : public :: slk_write ! Writes a square scaLAPACK distributed matrix on an external file using MPI-IO.
462 : : public :: slk_read ! Read a square scaLAPACK distributed matrix from an external file using MPI-IO.
463 : : public :: slk_single_fview_read_mask ! Returns an MPI datatype that can be used to read a scaLAPACK matrix from
464 : : ! a binary file using MPI-IO.
465 : : ! The view is created using the user-defined mask function
466 : : public :: slk_single_fview_read ! Returns an MPI datatype to read a scaLAPACK distributed matrix
467 : : ! from a binary file using MPI-IO.
468 : : public :: slk_single_fview_write ! Returns an MPI datatype to write a scaLAPACK distributed matrix
469 : : ! to a binary file using MPI-IO.
470 : :
471 : : ! Arrays of matrices (slkmat_dp_t or slkmat_sp_t).
472 : : public :: slk_array_free ! Deallocate array of matrices
473 : : interface slk_array_free
474 : : module procedure slk_array1_free
475 : : module procedure slk_array2_free
476 : : module procedure slk_array3_free
477 : : module procedure slk_array4_free
478 : : module procedure slk_array5_free
479 : : end interface slk_array_free
480 : :
481 : : public :: slk_array_set_zero ! Elemental routine to zero the value of the local buffer.
482 : : public :: slk_array_locmem_mb ! Elemental function returning the memory allocated for the local buffer in Mb
483 : :
484 : : public :: slk_array_gpu_set_zero ! Zero the value of the local buffer on the GPU
485 : : interface slk_array_gpu_set_zero
486 : : module procedure slk_array1_gpu_set_zero
487 : : module procedure slk_array2_gpu_set_zero
488 : : module procedure slk_array3_gpu_set_zero
489 : : module procedure slk_array4_gpu_set_zero
490 : : module procedure slk_array5_gpu_set_zero
491 : : end interface slk_array_gpu_set_zero
492 : :
493 : : ! External functions.
494 : : #if defined(HAVE_LINALG_SCALAPACK) || defined(HAVE_LINALG_ELPA)
495 : : integer,external :: indxl2g, numroc
496 : : real(dp),external :: PDLAMCH
497 : : real(dp),external :: PDLATRA
498 : : real(sp),external :: PSLATRA
499 : : complex(sp),external :: PCLATRA
500 : : complex(dp),external :: PZLATRA
501 : : #endif
502 : :
503 : : #ifdef HAVE_LINALG_SLATE
504 : :
505 : : interface
506 : : ! Standard complex Hermitian: A * Z = Z * diag(w)
507 : : subroutine slate_zheev_c(n, nb, nprow, npcol, comm_f, &
508 : : lda, a_data, ldz, z_data, w, nev, use_gpu, info) &
509 : : bind(C, name="slate_zheev_c")
510 : : use, intrinsic :: iso_c_binding
511 : : integer(c_int), value :: n, nb, nprow, npcol, comm_f, lda, ldz, nev, use_gpu
512 : : complex(c_double_complex), intent(inout) :: a_data(*)
513 : : complex(c_double_complex), intent(out) :: z_data(*)
514 : : real(c_double), intent(out) :: w(*)
515 : : integer(c_int), intent(out) :: info
516 : : end subroutine slate_zheev_c
517 : :
518 : : ! Standard real symmetric: A * Z = Z * diag(w)
519 : : subroutine slate_dsyev_c(n, nb, nprow, npcol, comm_f, &
520 : : lda, a_data, ldz, z_data, w, nev, use_gpu, info) &
521 : : bind(C, name="slate_dsyev_c")
522 : : use, intrinsic :: iso_c_binding
523 : : integer(c_int), value :: n, nb, nprow, npcol, comm_f, lda, ldz, nev, use_gpu
524 : : real(c_double), intent(inout) :: a_data(*)
525 : : real(c_double), intent(out) :: z_data(*)
526 : : real(c_double), intent(out) :: w(*)
527 : : integer(c_int), intent(out) :: info
528 : : end subroutine slate_dsyev_c
529 : :
530 : : ! Generalised complex Hermitian: A * Z = B * Z * diag(w)
531 : : subroutine slate_zhegv_c(n, nb, nprow, npcol, comm_f, &
532 : : lda, a_data, ldb, b_data, ldz, z_data, &
533 : : w, nev, use_gpu, info) &
534 : : bind(C, name="slate_zhegv_c")
535 : : use, intrinsic :: iso_c_binding
536 : : integer(c_int), value :: n, nb, nprow, npcol, comm_f
537 : : integer(c_int), value :: lda, ldb, ldz, nev, use_gpu
538 : : complex(c_double_complex), intent(inout) :: a_data(*), b_data(*)
539 : : complex(c_double_complex), intent(out) :: z_data(*)
540 : : real(c_double), intent(out) :: w(*)
541 : : integer(c_int), intent(out) :: info
542 : : end subroutine slate_zhegv_c
543 : :
544 : : ! Generalised real symmetric: A * Z = B * Z * diag(w)
545 : : subroutine slate_dsygv_c(n, nb, nprow, npcol, comm_f, &
546 : : lda, a_data, ldb, b_data, ldz, z_data, &
547 : : w, nev, use_gpu, info) &
548 : : bind(C, name="slate_dsygv_c")
549 : : use, intrinsic :: iso_c_binding
550 : : integer(c_int), value :: n, nb, nprow, npcol, comm_f
551 : : integer(c_int), value :: lda, ldb, ldz, nev, use_gpu
552 : : real(c_double), intent(inout) :: a_data(*), b_data(*)
553 : : real(c_double), intent(out) :: z_data(*)
554 : : real(c_double), intent(out) :: w(*)
555 : : integer(c_int), intent(out) :: info
556 : : end subroutine slate_dsygv_c
557 : :
558 : : end interface
559 : :
560 : : #endif
561 : :
562 : : contains !==============================================================================
563 : : !!***
564 : :
565 : : !!****f* m_slk/slk_grid_init
566 : : !! NAME
567 : : !! slk_grid_init
568 : : !!
569 : : !! FUNCTION
570 : : !! Set up the ScaLAPACK grid given the total number of processors.
571 : : !! The processes are ordered row-major in the grid (BLACS_GRIDINIT with order 'R').
572 : : !!
573 : : !! INPUTS
574 : : !! nprocs= total number of processors
575 : : !! comm= MPI communicator
576 : : !! use_gpu= True if the matrices will be used on the GPU (selects the default block size).
577 : : !! [grid_dims]=Number of procs for each dimension. Default: the most square grid with
578 : : !! dims(1) <= dims(2) and dims(1) * dims(2) = nprocs (1 x nprocs if nprocs is prime).
579 : : !!
580 : : !! OUTPUT
581 : : !! grid= the grid of processors used by Scalapack
582 : : !!
583 : : !! SOURCE
584 : :
585 [ # # ]: 0 : subroutine slk_grid_init(grid, nprocs, comm, use_gpu, grid_dims)
586 : :
587 : : !Arguments ------------------------------------
588 : : class(slk_grid_t),intent(out) :: grid
589 : : integer,intent(in) :: nprocs,comm
590 : : logical,intent(in) :: use_gpu
591 : : integer,optional,intent(in) :: grid_dims(2)
592 : :
593 : : !Local variables-------------------------------
594 : : integer :: i
595 : : ! *********************************************************************
596 : :
597 : 0 : grid%nprocs = nprocs
598 : :
599 [ # # ]: 0 : if (.not. present(grid_dims)) then
600 : : ! Search for a rectangular grid of processors
601 : 0 : i=INT(SQRT(float(nprocs)))
602 [ # # ]: 0 : do while (MOD(nprocs,i) /= 0)
603 : 0 : i = i-1
604 : : end do
605 : 0 : i=max(i,1)
606 : :
607 : 0 : grid%dims(1) = i
608 : 0 : grid%dims(2) = INT(nprocs/i)
609 : :
610 : : else
611 [ # # ]: 0 : grid%dims = grid_dims
612 : : end if
613 : :
614 [ # # # # ]: 0 : ABI_CHECK(product(grid%dims) == nprocs, sjoin("grid%dims:", ltoa(grid%dims), "does not agree with nprocs:", itoa(nprocs)))
615 : :
616 : 0 : grid%comm = comm
617 : 0 : grid%use_gpu = use_gpu
618 : :
619 : : #ifdef HAVE_LINALG_SCALAPACK
620 : : ! 'R': Use row-major natural ordering
621 : : call BLACS_GRIDINIT(grid%comm, 'R', grid%dims(1), grid%dims(2))
622 : : #endif
623 : :
624 : 0 : end subroutine slk_grid_init
625 : : !!***
626 : :
627 : : !----------------------------------------------------------------------
628 : :
629 : : !!****f* m_slk/build_processor
630 : : !! NAME
631 : : !! build_processor
632 : : !!
633 : : !! FUNCTION
634 : : !! Builds a ScaLAPACK processor descriptor.
635 : : !! Build of the data related to one processor in a grid
636 : : !! The coordinates are computed from my_rank assuming the row-major ordering used in slk_grid_init:
637 : : !! coords = [my_rank / dims(2), mod(my_rank, dims(2))]. They overwrite the values returned by BLACS_GRIDINFO.
638 : : !!
639 : : !! INPUTS
640 : : !! grid= array representing the grid of processors.
641 : : !! my_rank= selected processor
642 : : !! comm= MPI communicator
643 : : !!
644 : : !! OUTPUT
645 : : !! processor= descriptor of a processor
646 : : !!
647 : : !! SOURCE
648 : :
649 : 0 : subroutine build_processor(processor, grid, my_rank, comm)
650 : :
651 : : !Arguments ------------------------------------
652 : : class(slk_processor_t),intent(inout) :: processor
653 : : class(slk_grid_t),intent(in) :: grid
654 : : integer,intent(in) :: my_rank, comm
655 : : ! *********************************************************************
656 : :
657 : 0 : processor%grid = grid
658 : 0 : processor%my_rank = my_rank
659 : 0 : processor%comm = comm
660 : :
661 : : #ifdef HAVE_LINALG_SCALAPACK
662 : : call BLACS_GRIDINFO(grid%comm, processor%grid%dims(1), processor%grid%dims(2), &
663 : : processor%coords(1), processor%coords(2))
664 : : #endif
665 : :
666 : : ! These values are the same as those computed by BLACS_GRIDINFO
667 : : ! except in the case where the my_rank argument is not the local proc
668 : 0 : processor%coords(1) = INT((my_rank) / grid%dims(2))
669 : 0 : processor%coords(2) = MOD((my_rank), grid%dims(2))
670 : :
671 : : end subroutine build_processor
672 : : !!***
673 : :
674 : : !----------------------------------------------------------------------
675 : :
676 : : !!****f* m_slk/slk_processor_init
677 : : !! NAME
678 : : !! slk_processor_init
679 : : !!
680 : : !! FUNCTION
681 : : !! Initializes an instance of processor ScaLAPACK from an MPI communicator.
682 : : !! All the processes in comm belong to the grid. use_gpu is set to False.
683 : : !!
684 : : !! INPUTS
685 : : !! comm= MPI communicator
686 : : !! [grid_dims]=Number of procs for each dimension. Default: see slk_grid_init.
687 : : !! Use [1, nprocs] for a one-dimensional column distribution.
688 : : !!
689 : : !! OUTPUT
690 : : !! processor= descriptor of a processor
691 : : !!
692 : : !! SOURCE
693 : :
694 : 0 : subroutine slk_processor_init(processor, comm, &
695 : : grid_dims) ! optional
696 : :
697 : : !Arguments ------------------------------------
698 : : class(slk_processor_t),intent(out) :: processor
699 : : integer, intent(in) :: comm
700 : : integer,optional,intent(in) :: grid_dims(2)
701 : :
702 : : !Local variables-------------------------------
703 : : type(slk_grid_t) :: grid
704 : : integer :: nprocs, my_rank
705 : : ! *********************************************************************
706 : :
707 : 0 : nprocs = xmpi_comm_size(comm)
708 : 0 : my_rank = xmpi_comm_rank(comm)
709 : :
710 [ # # ]: 0 : if (present(grid_dims)) then
711 : 0 : call grid%init(nprocs, comm, .false., grid_dims=grid_dims)
712 : : else
713 : 0 : call grid%init(nprocs, comm, .false.)
714 : : end if
715 : :
716 : 0 : call build_processor(processor, grid, my_rank, comm)
717 : :
718 [ # # # # ]: 0 : end subroutine slk_processor_init
719 : : !!***
720 : :
721 : : !----------------------------------------------------------------------
722 : :
723 : : !!****f* m_slk/slk_processor_free
724 : : !! NAME
725 : : !! slk_processor_free
726 : : !!
727 : : !! FUNCTION
728 : : !! Removes a processor from the ScaLAPACK grid.
729 : : !!
730 : : !! SOURCE
731 : :
732 : 0 : subroutine slk_processor_free(processor)
733 : :
734 : : !Arguments ------------------------------------
735 : : class(slk_processor_t),intent(inout) :: processor
736 : : ! *********************************************************************
737 : :
738 : : #ifdef HAVE_LINALG_SCALAPACK
739 : : if (processor%grid%comm /= xmpi_comm_null) then
740 : : call BLACS_GRIDEXIT(processor%grid%comm)
741 : : !call BLACS_EXIT(0)
742 : : end if
743 : : #endif
744 : :
745 : 0 : end subroutine slk_processor_free
746 : : !!***
747 : :
748 : : !----------------------------------------------------------------------
749 : :
750 : : !!****f* m_slk/basemat_init
751 : : !! NAME
752 : : !! basemat_init
753 : : !!
754 : : !! FUNCTION
755 : : !! Initialisation of a SCALAPACK matrix (each proc initializes its own part of the matrix)
756 : : !! The object is freed first, then the local buffer is allocated and set to zero.
757 : : !! Without HAVE_LINALG_SCALAPACK, the routine only frees the object and the local buffer is not allocated.
758 : : !!
759 : : !! INPUTS
760 : : !! processor= descriptor of a processor. The matrix stores a pointer to it.
761 : : !! nbli_global= total number of lines
762 : : !! nbco_global= total number of columns
763 : : !! istwf_k= 2 if we have a real matrix (buffer_real) else complex (buffer_cplx).
764 : : !! [size_blocs]= custom block sizes. Use -1 to use global size along that direction.
765 : : !! Useful to distribute only rows or columns. Obviously, [-1, -1] is not allowed.
766 : : !! Default: 24 (16 if processor%grid%use_gpu, 1 if ELPA is available), square blocks if ELPA or SLATE is available.
767 : : !! The block sizes are always <= the global sizes.
768 : : !! [gpu_action]= Action passed to gpu_map after allocation. See basemat_gpu_map.
769 : : !!
770 : : !! OUTPUT
771 : : !! matrix= the matrix to process
772 : : !!
773 : : !! SOURCE
774 : :
775 : 0 : subroutine basemat_init(matrix, nbli_global, nbco_global, processor, istwf_k, &
776 : : size_blocs, gpu_action) ! optional
777 : :
778 : : !Arguments ------------------------------------
779 : : class(basemat_t),intent(inout) :: matrix
780 : : integer,intent(in) :: nbli_global, nbco_global, istwf_k
781 : : type(slk_processor_t),target,intent(in) :: processor
782 : : integer,optional,intent(in) :: size_blocs(2)
783 : : character(len=*),optional,intent(in) :: gpu_action
784 : :
785 : : #ifdef HAVE_LINALG_SCALAPACK
786 : : !Local variables-------------------------------
787 : : #ifdef HAVE_LINALG_ELPA
788 : : integer, parameter :: DEFAULT_SIZE_BLOCS = 1
789 : : #else
790 : : ! As recommended by Intel MKL, a more sensible default than the previous value of 40
791 : : integer, parameter :: DEFAULT_SIZE_BLOCS = 24
792 : : #endif
793 : : ! As recommended in ELPA, which advises distributions as squared as possible using powers of 2
794 : : integer, parameter :: DEFAULT_SIZE_BLOCS_GPU = 16
795 : : integer :: info,sizeb
796 : : !character(len=500) :: msg
797 : : ! *********************************************************************
798 : :
799 : : call matrix%free()
800 : :
801 : : sizeb = DEFAULT_SIZE_BLOCS
802 : : if (processor%grid%use_gpu) sizeb = DEFAULT_SIZE_BLOCS_GPU
803 : :
804 : : !Records of the matrix type
805 : : matrix%processor => processor
806 : : matrix%size_blocs(1) = MIN(sizeb, nbli_global)
807 : : matrix%size_blocs(2) = MIN(sizeb, nbco_global)
808 : :
809 : : #if defined(HAVE_LINALG_ELPA) || defined(HAVE_LINALG_SLATE)
810 : : if(matrix%size_blocs(1) .ne. matrix%size_blocs(2)) then
811 : : matrix%size_blocs(1) = MIN(matrix%size_blocs(1), matrix%size_blocs(2))
812 : : matrix%size_blocs(2) = matrix%size_blocs(1)
813 : : end if
814 : : #endif
815 : :
816 : : ! Use custom block sizes.
817 : : if (present(size_blocs)) then
818 : : ABI_CHECK(.not. all(size_blocs == -1), "size_blocs [-1, -1] is not allowed")
819 : : if (size_blocs(1) == -1) then
820 : : matrix%size_blocs(1) = nbli_global
821 : : else
822 : : matrix%size_blocs(1) = MIN(size_blocs(1), nbli_global)
823 : : end if
824 : : if (size_blocs(2) == -1) then
825 : : matrix%size_blocs(2) = nbco_global
826 : : else
827 : : matrix%size_blocs(2) = MIN(size_blocs(2), nbco_global)
828 : : end if
829 : : end if
830 : :
831 : : matrix%size_global(1) = nbli_global
832 : : matrix%size_global(2) = nbco_global
833 : : !write(std_out, *)"matrix%size_global", matrix%size_global
834 : :
835 : : ! Size of the local buffer
836 : : ! NUMROC computes the NUMber of Rows Or Columns of a distributed matrix owned by the process indicated by IPROC.
837 : : ! NUMROC (n, nb, iproc, isrcproc, nprocs)
838 : : matrix%size_local(1) = NUMROC(nbli_global, matrix%size_blocs(1), &
839 : : processor%coords(1), 0, processor%grid%dims(1))
840 : :
841 : : matrix%size_local(2) = NUMROC(nbco_global,matrix%size_blocs(2), &
842 : : processor%coords(2), 0, processor%grid%dims(2))
843 : :
844 : : matrix%bufsize = int(matrix%size_local(1), c_size_t) * int(matrix%size_local(2), c_size_t)
845 : :
846 : : call matrix%idx_loc(matrix%size_global(1), matrix%size_global(2), &
847 : : matrix%size_local(1), matrix%size_local(2))
848 : :
849 : : ! Initialisation of the SCALAPACK description of the matrix
850 : : ! (desc, m, n, mb, nb, irsrc, icsrc, comm, lld, info)
851 : : call DESCINIT(matrix%desc, nbli_global, nbco_global, &
852 : : matrix%size_blocs(1), matrix%size_blocs(2), 0, 0, &
853 : : processor%grid%comm, MAX(1, matrix%size_local(1)), info)
854 : :
855 : : if (info /= 0) then
856 : : ABI_ERROR(sjoin("Error while initializing scalapack matrix. info:", itoa(info)))
857 : : end if
858 : :
859 : : ! Allocate local buffer.
860 : : matrix%istwf_k = istwf_k
861 : : select type (matrix)
862 : : class is (slkmat_dp_t)
863 : : if (istwf_k /= 2) then
864 : : ABI_MALLOC(matrix%buffer_cplx, (matrix%size_local(1), matrix%size_local(2)))
865 : : matrix%buffer_cplx = czero
866 : : else
867 : : ABI_MALLOC(matrix%buffer_real, (matrix%size_local(1), matrix%size_local(2)))
868 : : matrix%buffer_real = zero
869 : : end if
870 : :
871 : : class is (slkmat_sp_t)
872 : : if (istwf_k /= 2) then
873 : : ABI_MALLOC(matrix%buffer_cplx, (matrix%size_local(1), matrix%size_local(2)))
874 : : matrix%buffer_cplx = czero_sp
875 : : else
876 : : ABI_MALLOC(matrix%buffer_real, (matrix%size_local(1), matrix%size_local(2)))
877 : : matrix%buffer_real = zero_sp
878 : : end if
879 : :
880 : : class default
881 : : ABI_ERROR("Wrong class")
882 : : end select
883 : :
884 : : if (present(gpu_action)) call matrix%gpu_map(gpu_action)
885 : : #endif
886 : :
887 : 0 : end subroutine basemat_init
888 : : !!***
889 : :
890 : : !----------------------------------------------------------------------
891 : :
892 : : !!****f* m_slk/basemat_locmem_mb
893 : : !! NAME
894 : : !! basemat_locmem_mb
895 : : !!
896 : : !! FUNCTION
897 : : !! Returns memory allocated for the local buffer in Mb.
898 : : !!
899 : : !! SOURCE
900 : :
901 : 0 : pure real(dp) function basemat_locmem_mb(mat) result(locmem_mb)
902 : :
903 : : !Arguments ------------------------------------
904 : : class(basemat_t),intent(in) :: mat
905 : : ! *********************************************************************
906 : :
907 : 0 : locmem_mb = zero
908 : : select type (mat)
909 : : class is (slkmat_dp_t)
910 [ # # # # ]: 0 : if (allocated(mat%buffer_real)) locmem_mb = product(int(shape(mat%buffer_real))) * dp
911 [ # # # # ]: 0 : if (allocated(mat%buffer_cplx)) locmem_mb = product(int(shape(mat%buffer_cplx))) * two * dp
912 : : class is (slkmat_sp_t)
913 [ # # # # ]: 0 : if (allocated(mat%buffer_real)) locmem_mb = product(int(shape(mat%buffer_real))) * sp
914 [ # # # # ]: 0 : if (allocated(mat%buffer_cplx)) locmem_mb = product(int(shape(mat%buffer_cplx))) * two * sp
915 : : end select
916 : 0 : locmem_mb = locmem_mb * b2Mb
917 : :
918 : 0 : end function basemat_locmem_mb
919 : : !!***
920 : :
921 : : !----------------------------------------------------------------------
922 : :
923 : : !!****f* m_slk/basemat_print
924 : : !! NAME
925 : : !! basemat_print
926 : : !!
927 : : !! FUNCTION
928 : : !! Print info on scalapack matrix.
929 : : !!
930 : : !! INPUTS
931 : : !! [unit]=Unit number (default: std_out)
932 : : !! [header]=title for info
933 : : !! [prtvol]=Verbosity level (default: 0)
934 : : !!
935 : : !! SOURCE
936 : :
937 : 0 : subroutine basemat_print(mat, header, unit, prtvol)
938 : :
939 : : !Arguments ------------------------------------
940 : : class(basemat_t),intent(in) :: mat
941 : : character(len=*),optional,intent(in) :: header
942 : : integer,optional,intent(in) :: prtvol, unit
943 : :
944 : : !Local variables-------------------------------
945 : : integer :: unt, my_prtvol, grid_dims(2)
946 : : character(len=50) :: matrix_dtype
947 : : character(len=5000) :: msg
948 : : ! *********************************************************************
949 : :
950 : 0 : unt = std_out; if (present(unit)) unt =unit
951 : 0 : my_prtvol = 0; if (present(prtvol)) my_prtvol = prtvol
952 : :
953 : 0 : msg = ' ==== Info on scalapack matrix ==== '
954 [ # # # # : 0 : if (present(header)) msg=' ==== '//trim(adjustl(header))//' ==== '
# # ]
955 : 0 : call wrtout(unt, msg)
956 : :
957 : 0 : matrix_dtype = "undefined"
958 : : select type (mat)
959 : : class is (slkmat_dp_t)
960 [ # # ]: 0 : if (allocated(mat%buffer_real)) matrix_dtype = "real dp"
961 [ # # ]: 0 : if (allocated(mat%buffer_cplx)) matrix_dtype = "complex dp"
962 : :
963 : : class is (slkmat_sp_t)
964 [ # # ]: 0 : if (allocated(mat%buffer_real)) matrix_dtype = "real sp"
965 [ # # ]: 0 : if (allocated(mat%buffer_cplx)) matrix_dtype = "complex sp"
966 : :
967 : : class default
968 : 0 : ABI_ERROR("Wrong class")
969 : : end select
970 : :
971 : 0 : grid_dims = [-1, -1]
972 [ # # # # ]: 0 : if (associated(mat%processor)) grid_dims = mat%processor%grid%dims
973 : :
974 : : write(msg,'(5(3a),a,f8.1,a)') &
975 : 0 : " matrix_dtype ..... ", trim(matrix_dtype), ch10, &
976 [ # # ]: 0 : " size_global ...... ", trim(ltoa(mat%size_global)), ch10, &
977 [ # # ]: 0 : " size_local ...... ", trim(ltoa(mat%size_local)), ch10, &
978 [ # # ]: 0 : " size_blocs ...... ", trim(ltoa(mat%size_blocs)), ch10, &
979 [ # # ]: 0 : " processor grid ... ", trim(ltoa(grid_dims)), ch10, &
980 : 0 : " memory (Mb) ...... ", mat%locmem_mb(), ch10
981 : 0 : call wrtout(unt, msg)
982 : :
983 : : !if (prtvol > 10) call mat%write(unit)
984 : :
985 [ # # ]: 0 : end subroutine basemat_print
986 : : !!***
987 : :
988 : : !----------------------------------------------------------------------
989 : :
990 : : !!****f* m_slk/slkmat_check_shape
991 : : !! NAME
992 : : !! slkmat_check_shape
993 : : !!
994 : : !! FUNCTION
995 : : !! Debugging tool to test the local shape `lshape` of the local buffer.
996 : : !! Return exit status in `ok` and error message in `msg`.
997 : : !!
998 : : !! SOURCE
999 : :
1000 : 0 : logical function basemat_check_local_shape(mat, lshape, msg) result (ok)
1001 : :
1002 : : !Arguments ------------------------------------
1003 : : class(basemat_t),intent(in) :: mat
1004 : : integer,intent(in) :: lshape(2)
1005 : : character(len=*),intent(out) :: msg
1006 : : ! *********************************************************************
1007 : :
1008 : 0 : msg = ""
1009 [ # # # # ]: 0 : ok = all(mat%size_local == lshape)
1010 [ # # ]: 0 : if (.not. ok) then
1011 [ # # # # ]: 0 : msg = sjoin("mat%size_local:", ltoa(mat%size_local), " not equal to input local lshape ", ltoa(lshape))
1012 : 0 : return
1013 : : end if
1014 : :
1015 : : select type (mat)
1016 : : class is (slkmat_dp_t)
1017 [ # # ]: 0 : if (allocated(mat%buffer_cplx)) then
1018 [ # # # # ]: 0 : ok = all(shape(mat%buffer_cplx) == lshape)
1019 [ # # ]: 0 : if (.not. ok) then
1020 [ # # # # : 0 : msg = sjoin("shape(buffer_cplx):", ltoa(shape(mat%buffer_cplx)), " != input local lshape ", ltoa(lshape)); return
# # ]
1021 : : end if
1022 [ # # ]: 0 : else if (allocated(mat%buffer_real)) then
1023 [ # # # # ]: 0 : ok = all(shape(mat%buffer_real) == lshape)
1024 [ # # ]: 0 : if (.not. ok) then
1025 [ # # # # : 0 : msg = sjoin("shape(buffer_real):", ltoa(shape(mat%buffer_real)), " != input local lshape ", ltoa(lshape)); return
# # ]
1026 : : end if
1027 : : end if
1028 : :
1029 : : class is (slkmat_sp_t)
1030 : : ! Same piece of code as above. May use include file!
1031 [ # # ]: 0 : if (allocated(mat%buffer_cplx)) then
1032 [ # # # # ]: 0 : ok = all(shape(mat%buffer_cplx) == lshape)
1033 [ # # ]: 0 : if (.not. ok) then
1034 [ # # # # : 0 : msg = sjoin("shape(buffer_cplx):", ltoa(shape(mat%buffer_cplx)), " != input local lshape ", ltoa(lshape)); return
# # ]
1035 : : end if
1036 [ # # ]: 0 : else if (allocated(mat%buffer_real)) then
1037 [ # # # # ]: 0 : ok = all(shape(mat%buffer_real) == lshape)
1038 [ # # ]: 0 : if (.not. ok) then
1039 [ # # # # : 0 : msg = sjoin("shape(buffer_real):", ltoa(shape(mat%buffer_real)), " != input local lshape ", ltoa(lshape)); return
# # ]
1040 : : end if
1041 : : end if
1042 : :
1043 : : class default
1044 : 0 : ABI_ERROR("Wrong class")
1045 : : end select
1046 : :
1047 [ # # ]: 0 : end function basemat_check_local_shape
1048 : : !!***
1049 : :
1050 : : !----------------------------------------------------------------------
1051 : :
1052 : : !!****f* m_slk/slkmat_dp_get_head_and_wings
1053 : : !! NAME
1054 : : !! slkmat_dp_get_head_and_wings
1055 : : !!
1056 : : !! FUNCTION
1057 : : !! Return global arrays with head and wings of the matrix.
1058 : : !! If call_mpi if False, global MPI sum is postponed.
1059 : : !! Useful to reduce the number of MPI calls if one has to operate on multiple matrices.
1060 : : !!
1061 : : !! SOURCE
1062 : :
1063 : 0 : subroutine slkmat_dp_get_head_and_wings(mat, head, low_wing, up_wing, call_mpi)
1064 : :
1065 : : !Arguments ------------------------------------
1066 : : class(slkmat_dp_t),intent(in) :: mat
1067 : : complex(dp),intent(out) :: head, low_wing(mat%size_global(1)), up_wing(mat%size_global(2))
1068 : : logical,intent(in) :: call_mpi
1069 : :
1070 : : !Local variables-------------------------------
1071 : : integer :: ierr, il_g1, il_g2, iglob1, iglob2
1072 : : logical :: is_cplx
1073 : : ! *********************************************************************
1074 : :
1075 [ # # # # ]: 0 : head = zero; low_wing = zero; up_wing = zero
1076 : :
1077 : 0 : is_cplx = allocated(mat%buffer_cplx)
1078 : :
1079 [ # # ]: 0 : do il_g2=1,mat%size_local(2)
1080 : 0 : iglob2 = mat%loc2gcol(il_g2)
1081 [ # # ]: 0 : do il_g1=1,mat%size_local(1)
1082 : 0 : iglob1 = mat%loc2grow(il_g1)
1083 : :
1084 [ # # ]: 0 : if (iglob1 == 1 .or. iglob2 == 1) then
1085 [ # # ]: 0 : if (iglob1 == 1 .and. iglob2 == 1) then
1086 [ # # ]: 0 : if (is_cplx) then
1087 : 0 : head = mat%buffer_cplx(il_g1, il_g2)
1088 : : else
1089 : 0 : head = mat%buffer_real(il_g1, il_g2)
1090 : : end if
1091 [ # # ]: 0 : else if (iglob1 == 1) then
1092 [ # # ]: 0 : if (is_cplx) then
1093 : 0 : up_wing(iglob2) = mat%buffer_cplx(il_g1, il_g2)
1094 : : else
1095 : 0 : up_wing(iglob2) = mat%buffer_real(il_g1, il_g2)
1096 : : end if
1097 [ # # ]: 0 : else if (iglob2 == 1) then
1098 [ # # ]: 0 : if (is_cplx) then
1099 : 0 : low_wing(iglob1) = mat%buffer_cplx(il_g1, il_g2)
1100 : : else
1101 : 0 : low_wing(iglob1) = mat%buffer_real(il_g1, il_g2)
1102 : : end if
1103 : : end if
1104 : : end if
1105 : :
1106 : : end do
1107 : : end do
1108 : :
1109 [ # # ]: 0 : if (call_mpi) then
1110 : 0 : call xmpi_sum(head, mat%processor%comm, ierr)
1111 : 0 : call xmpi_sum(low_wing, mat%processor%comm, ierr)
1112 : 0 : call xmpi_sum(up_wing, mat%processor%comm, ierr)
1113 : : end if
1114 : :
1115 : 0 : end subroutine slkmat_dp_get_head_and_wings
1116 : : !!***
1117 : :
1118 : : !----------------------------------------------------------------------
1119 : :
1120 : : !!****f* m_slk/slkmat_dp_set_head_and_wings
1121 : : !! NAME
1122 : : !! slkmat_dp_set_head_and_wings
1123 : : !!
1124 : : !! FUNCTION
1125 : : !! Set head and wings of the matrix starting from global arrays.
1126 : : !!
1127 : : !! SOURCE
1128 : :
1129 : 0 : subroutine slkmat_dp_set_head_and_wings(mat, head, low_wing, up_wing)
1130 : :
1131 : : !Arguments ------------------------------------
1132 : : class(slkmat_dp_t),intent(inout) :: mat
1133 : : complex(dp),intent(in) :: head, low_wing(mat%size_global(1)), up_wing(mat%size_global(2))
1134 : :
1135 : : !Local variables-------------------------------
1136 : : integer :: il_g1, il_g2, iglob1, iglob2
1137 : : logical :: is_cplx
1138 : : ! *********************************************************************
1139 : :
1140 : 0 : is_cplx = allocated(mat%buffer_cplx)
1141 : :
1142 [ # # ]: 0 : do il_g2=1,mat%size_local(2)
1143 : 0 : iglob2 = mat%loc2gcol(il_g2)
1144 [ # # ]: 0 : do il_g1=1,mat%size_local(1)
1145 : 0 : iglob1 = mat%loc2grow(il_g1)
1146 : :
1147 [ # # ]: 0 : if (iglob1 == 1 .or. iglob2 == 1) then
1148 [ # # ]: 0 : if (iglob1 == 1 .and. iglob2 == 1) then
1149 [ # # ]: 0 : if (is_cplx) then
1150 : 0 : mat%buffer_cplx(il_g1, il_g2) = head
1151 : : else
1152 : 0 : mat%buffer_real(il_g1, il_g2) = real(head)
1153 : : end if
1154 [ # # ]: 0 : else if (iglob1 == 1) then
1155 [ # # ]: 0 : if (is_cplx) then
1156 : 0 : mat%buffer_cplx(il_g1, il_g2) = up_wing(iglob2)
1157 : : else
1158 : 0 : mat%buffer_real(il_g1, il_g2) = real(up_wing(iglob2))
1159 : : end if
1160 [ # # ]: 0 : else if (iglob2 == 1) then
1161 [ # # ]: 0 : if (is_cplx) then
1162 : 0 : mat%buffer_cplx(il_g1, il_g2) = low_wing(iglob1)
1163 : : else
1164 : 0 : mat%buffer_real(il_g1, il_g2) = real(low_wing(iglob1))
1165 : : end if
1166 : : end if
1167 : : end if
1168 : :
1169 : : end do
1170 : : end do
1171 : :
1172 : 0 : end subroutine slkmat_dp_set_head_and_wings
1173 : : !!***
1174 : :
1175 : : !----------------------------------------------------------------------
1176 : :
1177 : : !!****f* m_slk/slkmat_sp_set_head_and_wings
1178 : : !! NAME
1179 : : !! slkmat_sp_set_head_and_wings
1180 : : !!
1181 : : !! FUNCTION
1182 : : !! Set head and the wings of the matrix starting from global arrays.
1183 : : !!
1184 : : !! SOURCE
1185 : :
1186 : 0 : subroutine slkmat_sp_set_head_and_wings(mat, head, low_wing, up_wing)
1187 : :
1188 : : !Arguments ------------------------------------
1189 : : class(slkmat_sp_t),intent(inout) :: mat
1190 : : complex(sp),intent(in) :: head, low_wing(mat%size_global(1)), up_wing(mat%size_global(2))
1191 : :
1192 : : !Local variables-------------------------------
1193 : : integer :: il_g1, il_g2, iglob1, iglob2
1194 : : logical :: is_cplx
1195 : : ! *********************************************************************
1196 : :
1197 : 0 : is_cplx = allocated(mat%buffer_cplx)
1198 : :
1199 [ # # ]: 0 : do il_g2=1,mat%size_local(2)
1200 : 0 : iglob2 = mat%loc2gcol(il_g2)
1201 [ # # ]: 0 : do il_g1=1,mat%size_local(1)
1202 : 0 : iglob1 = mat%loc2grow(il_g1)
1203 : :
1204 [ # # ]: 0 : if (iglob1 == 1 .or. iglob2 == 1) then
1205 [ # # ]: 0 : if (iglob1 == 1 .and. iglob2 == 1) then
1206 [ # # ]: 0 : if (is_cplx) then
1207 : 0 : mat%buffer_cplx(il_g1, il_g2) = head
1208 : : else
1209 : 0 : mat%buffer_real(il_g1, il_g2) = real(head)
1210 : : end if
1211 [ # # ]: 0 : else if (iglob1 == 1) then
1212 [ # # ]: 0 : if (is_cplx) then
1213 : 0 : mat%buffer_cplx(il_g1, il_g2) = up_wing(iglob2)
1214 : : else
1215 : 0 : mat%buffer_real(il_g1, il_g2) = real(up_wing(iglob2))
1216 : : end if
1217 [ # # ]: 0 : else if (iglob2 == 1) then
1218 [ # # ]: 0 : if (is_cplx) then
1219 : 0 : mat%buffer_cplx(il_g1, il_g2) = low_wing(iglob1)
1220 : : else
1221 : 0 : mat%buffer_real(il_g1, il_g2) = real(low_wing(iglob1))
1222 : : end if
1223 : : end if
1224 : : end if
1225 : :
1226 : : end do
1227 : : end do
1228 : :
1229 : 0 : end subroutine slkmat_sp_set_head_and_wings
1230 : : !!***
1231 : :
1232 : : !----------------------------------------------------------------------
1233 : :
1234 : : !!****f* m_slk/slkmat_dp_copy
1235 : : !! NAME
1236 : : !! slkmat_dp_copy
1237 : : !!
1238 : : !! FUNCTION
1239 : : !! Copy in_mat to out_mat. If empty is True, the values in the local buffer are not copied. Default: False
1240 : : !!
1241 : : !! SOURCE
1242 : :
1243 [ # # ]: 0 : subroutine slkmat_dp_copy(in_mat, out_mat, empty)
1244 : :
1245 : : !Arguments ------------------------------------
1246 : : class(slkmat_dp_t),intent(in) :: in_mat
1247 : : class(slkmat_dp_t),intent(out) :: out_mat
1248 : : logical,optional,intent(in) :: empty
1249 : :
1250 : : !Local variables-------------------------------
1251 : : logical :: empty__
1252 : : type(c_ptr) :: gpu_ptr
1253 : : ! *********************************************************************
1254 : :
1255 : : call out_mat%init(in_mat%size_global(1), in_mat%size_global(2), in_mat%processor, in_mat%istwf_k, &
1256 : 0 : size_blocs=in_mat%size_blocs)
1257 : :
1258 [ # # ]: 0 : empty__ = .False.; if (present(empty)) empty__ = empty
1259 [ # # ]: 0 : if (.not. empty__) then
1260 [ # # ]: 0 : if (in_mat%istwf_k == 1) then
1261 [ # # # # : 0 : out_mat%buffer_cplx = in_mat%buffer_cplx
# # # # #
# # # # #
# # # # #
# ]
1262 : : else
1263 [ # # # # : 0 : out_mat%buffer_real = in_mat%buffer_real
# # # # #
# # # # #
# # # # #
# ]
1264 : : end if
1265 : : end if
1266 : :
1267 [ # # ]: 0 : if (in_mat%is_gpu_mapped(gpu_ptr)) then
1268 : 0 : call out_mat%gpu_map("alloc")
1269 [ # # ]: 0 : if (in_mat%istwf_k == 1) then
1270 : 0 : call gpu_copy_complex(out_mat%buffer_cplx, in_mat%buffer_cplx, in_mat%bufsize)
1271 : : else
1272 : 0 : call gpu_copy(out_mat%buffer_real, in_mat%buffer_real, in_mat%bufsize)
1273 : : end if
1274 : : end if
1275 : :
1276 : 0 : end subroutine slkmat_dp_copy
1277 : : !!***
1278 : :
1279 : : !----------------------------------------------------------------------
1280 : :
1281 : : !!****f* m_slk/slkmat_sp_copy
1282 : : !! NAME
1283 : : !! slkmat_sp_copy
1284 : : !!
1285 : : !! FUNCTION
1286 : : !! Copy in_mat to out_mat. If empty is True, the values in the local buffer are not copied. Default: False
1287 : : !!
1288 : : !! SOURCE
1289 : :
1290 [ # # ]: 0 : subroutine slkmat_sp_copy(in_mat, out_mat, empty)
1291 : :
1292 : : !Arguments ------------------------------------
1293 : : class(slkmat_sp_t),intent(in) :: in_mat
1294 : : class(slkmat_sp_t),intent(out) :: out_mat
1295 : : logical,optional,intent(in) :: empty
1296 : :
1297 : : !Local variables-------------------------------
1298 : : logical :: empty__
1299 : : type(c_ptr) :: gpu_ptr
1300 : : ! *********************************************************************
1301 : :
1302 : : call out_mat%init(in_mat%size_global(1), in_mat%size_global(2), in_mat%processor, in_mat%istwf_k, &
1303 : 0 : size_blocs=in_mat%size_blocs)
1304 : :
1305 [ # # ]: 0 : empty__ = .False.; if (present(empty)) empty__ = empty
1306 [ # # ]: 0 : if (.not. empty__) then
1307 [ # # ]: 0 : if (in_mat%istwf_k == 1) then
1308 [ # # # # : 0 : out_mat%buffer_cplx = in_mat%buffer_cplx
# # # # #
# # # # #
# # # # #
# ]
1309 : : else
1310 [ # # # # : 0 : out_mat%buffer_real = in_mat%buffer_real
# # # # #
# # # # #
# # # # #
# ]
1311 : : end if
1312 : : end if
1313 : :
1314 [ # # ]: 0 : if (in_mat%is_gpu_mapped(gpu_ptr)) then
1315 : 0 : call out_mat%gpu_map("alloc")
1316 [ # # ]: 0 : if (in_mat%istwf_k == 1) then
1317 : 0 : call gpu_copy_complex_sp(out_mat%buffer_cplx, in_mat%buffer_cplx, in_mat%bufsize)
1318 : : else
1319 : 0 : call gpu_copy_sp(out_mat%buffer_real, in_mat%buffer_real, in_mat%bufsize)
1320 : : end if
1321 : : end if
1322 : :
1323 : 0 : end subroutine slkmat_sp_copy
1324 : : !!***
1325 : :
1326 : : !----------------------------------------------------------------------
1327 : :
1328 : : !!****f* m_slk/basemat_free
1329 : : !! NAME
1330 : : !! basemat_free
1331 : : !!
1332 : : !! FUNCTION
1333 : : !! Free dynamic memory
1334 : : !!
1335 : : !! SOURCE
1336 : :
1337 : 0 : subroutine basemat_free(mat)
1338 : :
1339 : : !Arguments ------------------------------------
1340 : : class(basemat_t),intent(inout) :: mat
1341 : :
1342 : : !Local variables-------------------------------
1343 : : type(c_ptr) :: gpu_ptr
1344 : : ! *********************************************************************
1345 : :
1346 : : ! Don't free the grid. Just nullify the pointer as there might be other objects keeping a ref to processor.
1347 : 0 : mat%processor => null()
1348 : :
1349 [ # # ]: 0 : mat%size_global = 0
1350 [ # # ]: 0 : mat%size_blocs = 0
1351 [ # # ]: 0 : mat%size_local = 0
1352 [ # # ]: 0 : mat%desc = 0
1353 : :
1354 [ # # ]: 0 : if (mat%is_gpu_mapped(gpu_ptr)) then
1355 : 0 : call wrtout(std_out, "Deallocating mat%buffer on the GPU")
1356 : 0 : call mat%gpu_map("delete")
1357 : : end if
1358 : :
1359 : : select type (mat)
1360 : : class is (slkmat_dp_t)
1361 [ # # ]: 0 : ABI_SFREE(mat%buffer_cplx)
1362 [ # # ]: 0 : ABI_SFREE(mat%buffer_real)
1363 : :
1364 : : class is (slkmat_sp_t)
1365 [ # # ]: 0 : ABI_SFREE(mat%buffer_cplx)
1366 [ # # ]: 0 : ABI_SFREE(mat%buffer_real)
1367 : :
1368 : : class default
1369 : 0 : ABI_ERROR("Wrong class")
1370 : : end select
1371 : :
1372 : 0 : end subroutine basemat_free
1373 : : !!***
1374 : :
1375 : : !----------------------------------------------------------------------
1376 : :
1377 : : !!****f* m_slk/slk_array1_free
1378 : : !! NAME
1379 : : !! slk_array1_free
1380 : : !!
1381 : : !! FUNCTION
1382 : : !! Deallocate 1d array of slkmat_dp_t elements
1383 : : !!
1384 : : !! SOURCE
1385 : :
1386 : 0 : subroutine slk_array1_free(slk_arr1)
1387 : : class(basemat_t),intent(inout) :: slk_arr1(:)
1388 : : integer :: i1
1389 [ # # ]: 0 : do i1=1,size(slk_arr1, dim=1)
1390 : 0 : call slk_arr1(i1)%free()
1391 : : end do
1392 : 0 : end subroutine slk_array1_free
1393 : : !!***
1394 : :
1395 : : !----------------------------------------------------------------------
1396 : :
1397 : : !!****f* m_slk/slk_array2_free
1398 : : !! NAME
1399 : : !! slk_array2_free
1400 : : !!
1401 : : !! FUNCTION
1402 : : !! Deallocate 2d array of slkmat_dp_t elements
1403 : : !!
1404 : : !! SOURCE
1405 : :
1406 : 0 : subroutine slk_array2_free(slk_arr2)
1407 : : class(basemat_t),intent(inout) :: slk_arr2(:,:)
1408 : : integer :: i1, i2
1409 [ # # ]: 0 : do i2=1,size(slk_arr2, dim=2)
1410 [ # # ]: 0 : do i1=1,size(slk_arr2, dim=1)
1411 : 0 : call slk_arr2(i1, i2)%free()
1412 : : end do
1413 : : end do
1414 : 0 : end subroutine slk_array2_free
1415 : : !!***
1416 : :
1417 : : !----------------------------------------------------------------------
1418 : :
1419 : : !!****f* m_slk/slk_array3_free
1420 : : !! NAME
1421 : : !! slk_array3_free
1422 : : !!
1423 : : !! FUNCTION
1424 : : !! Deallocate 3d array of slkmat_dp_t elements
1425 : : !!
1426 : : !! SOURCE
1427 : :
1428 : 0 : subroutine slk_array3_free(slk_arr3)
1429 : : class(basemat_t),intent(inout) :: slk_arr3(:,:,:)
1430 : : integer :: i1, i2, i3
1431 [ # # ]: 0 : do i3=1,size(slk_arr3, dim=3)
1432 [ # # ]: 0 : do i2=1,size(slk_arr3, dim=2)
1433 [ # # ]: 0 : do i1=1,size(slk_arr3, dim=1)
1434 : 0 : call slk_arr3(i1, i2, i3)%free()
1435 : : end do
1436 : : end do
1437 : : end do
1438 : 0 : end subroutine slk_array3_free
1439 : : !!***
1440 : :
1441 : : !----------------------------------------------------------------------
1442 : :
1443 : : !!****f* m_slk/slk_array4_free
1444 : : !! NAME
1445 : : !! slk_array4_free
1446 : : !!
1447 : : !! FUNCTION
1448 : : !! Deallocate 4d array of slkmat_dp_t elements
1449 : : !!
1450 : : !! SOURCE
1451 : :
1452 : 0 : subroutine slk_array4_free(slk_arr4)
1453 : : class(basemat_t),intent(inout) :: slk_arr4(:,:,:,:)
1454 : : integer :: i1, i2, i3, i4
1455 [ # # ]: 0 : do i4=1,size(slk_arr4, dim=4)
1456 [ # # ]: 0 : do i3=1,size(slk_arr4, dim=3)
1457 [ # # ]: 0 : do i2=1,size(slk_arr4, dim=2)
1458 [ # # ]: 0 : do i1=1,size(slk_arr4, dim=1)
1459 : 0 : call slk_arr4(i1, i2, i3, i4)%free()
1460 : : end do
1461 : : end do
1462 : : end do
1463 : : end do
1464 : 0 : end subroutine slk_array4_free
1465 : : !!***
1466 : :
1467 : : !----------------------------------------------------------------------
1468 : :
1469 : : !!****f* m_slk/slk_array5_free
1470 : : !! NAME
1471 : : !! slk_array5_free
1472 : : !!
1473 : : !! FUNCTION
1474 : : !! Deallocate 5d array of slkmat_dp_t elements
1475 : : !!
1476 : : !! SOURCE
1477 : :
1478 : 0 : subroutine slk_array5_free(slk_arr5)
1479 : : class(basemat_t),intent(inout) :: slk_arr5(:,:,:,:,:)
1480 : : integer :: i1, i2, i3, i4, i5
1481 [ # # ]: 0 : do i5=1,size(slk_arr5, dim=5)
1482 [ # # ]: 0 : do i4=1,size(slk_arr5, dim=4)
1483 [ # # ]: 0 : do i3=1,size(slk_arr5, dim=3)
1484 [ # # ]: 0 : do i2=1,size(slk_arr5, dim=2)
1485 [ # # ]: 0 : do i1=1,size(slk_arr5, dim=1)
1486 : 0 : call slk_arr5(i1, i2, i3, i4, i5)%free()
1487 : : end do
1488 : : end do
1489 : : end do
1490 : : end do
1491 : : end do
1492 : 0 : end subroutine slk_array5_free
1493 : : !!***
1494 : :
1495 : : !----------------------------------------------------------------------
1496 : :
1497 : : !!****f* m_slk/slk_array_set_zero
1498 : : !! NAME
1499 : : !! slk_array_set_zero
1500 : : !!
1501 : : !! FUNCTION
1502 : : !! Elemental routine to set the value of the PBLAS buffer to zero
1503 : : !!
1504 : : !! SOURCE
1505 : :
1506 : 0 : elemental subroutine slk_array_set_zero(mat)
1507 : :
1508 : : !Arguments ------------------------------------
1509 : : class(basemat_t),intent(inout) :: mat
1510 : :
1511 : : select type (mat)
1512 : : class is (slkmat_dp_t)
1513 [ # # # # : 0 : if (allocated(mat%buffer_cplx)) mat%buffer_cplx = zero
# # ]
1514 [ # # # # : 0 : if (allocated(mat%buffer_real)) mat%buffer_real = zero
# # ]
1515 : : class is (slkmat_sp_t)
1516 [ # # # # : 0 : if (allocated(mat%buffer_cplx)) mat%buffer_cplx = cmplx(zero, kind=sp)
# # ]
1517 [ # # # # : 0 : if (allocated(mat%buffer_real)) mat%buffer_real = real(zero, kind=sp)
# # ]
1518 : : end select
1519 : :
1520 : 0 : end subroutine slk_array_set_zero
1521 : : !!***
1522 : :
1523 : : !----------------------------------------------------------------------
1524 : :
1525 : : !!****f* m_slk/basemat_gpu_set_zero
1526 : : !! NAME
1527 : : !! basemat_gpu_set_zero
1528 : : !!
1529 : : !! FUNCTION
1530 : : !! Elemental routine to set the value of the PBLAS buffer to zero
1531 : : !!
1532 : : !! SOURCE
1533 : :
1534 : 0 : subroutine basemat_gpu_set_zero(mat)
1535 : :
1536 : : !Arguments ------------------------------------
1537 : : class(basemat_t),target,intent(inout) :: mat
1538 : :
1539 : : #ifdef HAVE_OPENMP_OFFLOAD
1540 : : !Local variables-------------------------------
1541 : : type(c_ptr) :: gpu_ptr
1542 : : ! *********************************************************************
1543 : :
1544 : : select type (mat)
1545 : : class is (slkmat_dp_t)
1546 : : if (allocated(mat%buffer_cplx)) then
1547 : : gpu_ptr = xomp_get_mapped_ptr(c_loc(mat%buffer_cplx))
1548 : : ABI_CHECK_CNULL(gpu_ptr, "buffer_cplx not on GPU!")
1549 : : call gpu_memset(gpu_ptr, 0, mat%bufsize*dp*2)
1550 : : end if
1551 : : if (allocated(mat%buffer_real)) then
1552 : : gpu_ptr = xomp_get_mapped_ptr(c_loc(mat%buffer_real))
1553 : : ABI_CHECK_CNULL(gpu_ptr, "buffer_real not on GPU!")
1554 : : call gpu_memset(gpu_ptr, 0, mat%bufsize*dp)
1555 : : end if
1556 : : class is (slkmat_sp_t)
1557 : : if (allocated(mat%buffer_cplx)) then
1558 : : gpu_ptr = xomp_get_mapped_ptr(c_loc(mat%buffer_cplx))
1559 : : ABI_CHECK_CNULL(gpu_ptr, "buffer_cplx not on GPU!")
1560 : : call gpu_memset(gpu_ptr, 0, mat%bufsize*sp*2)
1561 : : end if
1562 : : if (allocated(mat%buffer_real)) then
1563 : : gpu_ptr = xomp_get_mapped_ptr(c_loc(mat%buffer_real))
1564 : : ABI_CHECK_CNULL(gpu_ptr, "buffer_real not on GPU!")
1565 : : call gpu_memset(gpu_ptr, 0, mat%bufsize*sp)
1566 : : end if
1567 : : end select
1568 : : #else
1569 : 0 : ABI_ERROR("basemat_gpu_set cannot be used if HAVE_OPENMP_OFFLOAD is not defined!")
1570 : : ABI_UNUSED(mat%size_local(1))
1571 : : #endif
1572 : :
1573 : 0 : end subroutine basemat_gpu_set_zero
1574 : : !!***
1575 : :
1576 : : !!****f* m_slk/slk_array1_gpu_set_zero
1577 : : !! NAME
1578 : : !! slk_array1_gpu_set_zero
1579 : : !!
1580 : : !! FUNCTION
1581 : : !!
1582 : : !! SOURCE
1583 : :
1584 : 0 : subroutine slk_array1_gpu_set_zero(mat1d)
1585 : :
1586 : : !Arguments ------------------------------------
1587 : : class(basemat_t),intent(inout) :: mat1d(:)
1588 : :
1589 : : !Local variables-------------------------------
1590 : : integer :: i1
1591 : : ! *********************************************************************
1592 : :
1593 [ # # ]: 0 : do i1=1,size(mat1d, dim=1)
1594 : 0 : call mat1d(i1)%gpu_set_zero()
1595 : : end do
1596 : :
1597 : 0 : end subroutine slk_array1_gpu_set_zero
1598 : : !!***
1599 : :
1600 : : !!****f* m_slk/slk_array2_gpu_set_zero
1601 : : !! NAME
1602 : : !! slk_array2_gpu_set_zero
1603 : : !!
1604 : : !! FUNCTION
1605 : : !!
1606 : : !! SOURCE
1607 : :
1608 : 0 : subroutine slk_array2_gpu_set_zero(mat2d)
1609 : :
1610 : : !Arguments ------------------------------------
1611 : : class(basemat_t),intent(inout) :: mat2d(:,:)
1612 : :
1613 : : !Local variables-------------------------------
1614 : : integer :: i1, i2
1615 : : ! *********************************************************************
1616 : :
1617 [ # # ]: 0 : do i2=1,size(mat2d, dim=2)
1618 [ # # ]: 0 : do i1=1,size(mat2d, dim=1)
1619 : 0 : call mat2d(i1, i2)%gpu_set_zero()
1620 : : end do
1621 : : end do
1622 : :
1623 : 0 : end subroutine slk_array2_gpu_set_zero
1624 : : !!***
1625 : :
1626 : : !!****f* m_slk/slk_array3_gpu_set_zero
1627 : : !! NAME
1628 : : !! slk_array3_gpu_set_zero
1629 : : !!
1630 : : !! FUNCTION
1631 : : !!
1632 : : !! SOURCE
1633 : :
1634 : 0 : subroutine slk_array3_gpu_set_zero(mat3d)
1635 : :
1636 : : !Arguments ------------------------------------
1637 : : class(basemat_t),intent(inout) :: mat3d(:,:,:)
1638 : :
1639 : : !Local variables-------------------------------
1640 : : integer :: i1,i2,i3
1641 : : ! *********************************************************************
1642 : :
1643 [ # # ]: 0 : do i3=1,size(mat3d, dim=3)
1644 [ # # ]: 0 : do i2=1,size(mat3d, dim=2)
1645 [ # # ]: 0 : do i1=1,size(mat3d, dim=1)
1646 : 0 : call mat3d(i1,i2,i3)%gpu_set_zero()
1647 : : end do
1648 : : end do
1649 : : end do
1650 : :
1651 : 0 : end subroutine slk_array3_gpu_set_zero
1652 : : !!***
1653 : :
1654 : : !!****f* m_slk/slk_array4_gpu_set_zero
1655 : : !! NAME
1656 : : !! slk_array4_gpu_set_zero
1657 : : !!
1658 : : !! FUNCTION
1659 : : !!
1660 : : !! SOURCE
1661 : :
1662 : 0 : subroutine slk_array4_gpu_set_zero(mat4d)
1663 : :
1664 : : !Arguments ------------------------------------
1665 : : class(basemat_t),intent(inout) :: mat4d(:,:,:,:)
1666 : :
1667 : : !Local variables-------------------------------
1668 : : integer :: i1, i2, i3, i4
1669 : : ! *********************************************************************
1670 : :
1671 [ # # ]: 0 : do i4=1,size(mat4d, dim=4)
1672 [ # # ]: 0 : do i3=1,size(mat4d, dim=3)
1673 [ # # ]: 0 : do i2=1,size(mat4d, dim=2)
1674 [ # # ]: 0 : do i1=1,size(mat4d, dim=1)
1675 : 0 : call mat4d(i1, i2, i3, i4)%gpu_set_zero()
1676 : : end do
1677 : : end do
1678 : : end do
1679 : : end do
1680 : :
1681 : 0 : end subroutine slk_array4_gpu_set_zero
1682 : : !!***
1683 : :
1684 : : !!****f* m_slk/slk_array5_gpu_set_zero
1685 : : !! NAME
1686 : : !! slk_array5_gpu_set_zero
1687 : : !!
1688 : : !! FUNCTION
1689 : : !!
1690 : : !! SOURCE
1691 : :
1692 : 0 : subroutine slk_array5_gpu_set_zero(mat5d)
1693 : :
1694 : : !Arguments ------------------------------------
1695 : : class(basemat_t),intent(inout) :: mat5d(:,:,:,:,:)
1696 : :
1697 : : !Local variables-------------------------------
1698 : : integer :: i1,i2,i3,i4,i5
1699 : : ! *********************************************************************
1700 : :
1701 [ # # ]: 0 : do i5=1,size(mat5d, dim=5)
1702 [ # # ]: 0 : do i4=1,size(mat5d, dim=4)
1703 [ # # ]: 0 : do i3=1,size(mat5d, dim=3)
1704 [ # # ]: 0 : do i2=1,size(mat5d, dim=2)
1705 [ # # ]: 0 : do i1=1,size(mat5d, dim=1)
1706 : 0 : call mat5d(i1,i2,i3,i4,i5)%gpu_set_zero()
1707 : : end do
1708 : : end do
1709 : : end do
1710 : : end do
1711 : : end do
1712 : :
1713 : 0 : end subroutine slk_array5_gpu_set_zero
1714 : : !!***
1715 : :
1716 : : !----------------------------------------------------------------------
1717 : :
1718 : : !!****f* m_slk/basemat_is_gpu_mapped
1719 : : !! NAME
1720 : : !! basemat_is_gpu_mapped
1721 : : !!
1722 : : !! FUNCTION
1723 : : !! Return True if the local buffer is mapped to the GPU and the pointer on the gpu.
1724 : : !!
1725 : : !! SOURCE
1726 : :
1727 : 0 : logical function basemat_is_gpu_mapped(mat, gpu_ptr) result(is_gpu_mapped)
1728 : :
1729 : : !Arguments ------------------------------------
1730 : : class(basemat_t),target,intent(in) :: mat
1731 : : type(c_ptr),intent(out) :: gpu_ptr
1732 : :
1733 : : !Local variables-------------------------------
1734 : : #ifdef HAVE_OPENMP_OFFLOAD
1735 : : real(sp), contiguous, pointer :: buf_real_sp(:,:)
1736 : : real(dp), contiguous, pointer :: buf_real_dp(:,:)
1737 : : complex(sp), contiguous, pointer :: buf_cplx_sp(:,:)
1738 : : complex(dp), contiguous, pointer :: buf_cplx_dp(:,:)
1739 : : #endif
1740 : : ! *********************************************************************
1741 : :
1742 : 0 : is_gpu_mapped = .False.; gpu_ptr = c_null_ptr
1743 : : #ifdef HAVE_OPENMP_OFFLOAD
1744 : : select type (mat)
1745 : : class is (slkmat_dp_t)
1746 : : if (allocated(mat%buffer_cplx)) then
1747 : : buf_cplx_dp => mat%buffer_cplx
1748 : : gpu_ptr = xomp_get_mapped_ptr(c_loc(buf_cplx_dp))
1749 : : is_gpu_mapped = c_associated(gpu_ptr)
1750 : : end if
1751 : : if (allocated(mat%buffer_real)) then
1752 : : buf_real_dp => mat%buffer_real
1753 : : gpu_ptr = xomp_get_mapped_ptr(c_loc(buf_real_dp))
1754 : : is_gpu_mapped = c_associated(gpu_ptr)
1755 : : end if
1756 : :
1757 : : class is (slkmat_sp_t)
1758 : : if (allocated(mat%buffer_cplx)) then
1759 : : buf_cplx_sp => mat%buffer_cplx
1760 : : gpu_ptr= xomp_get_mapped_ptr(c_loc(buf_cplx_sp))
1761 : : is_gpu_mapped = c_associated(gpu_ptr)
1762 : : end if
1763 : : if (allocated(mat%buffer_real)) then
1764 : : buf_real_sp => mat%buffer_real
1765 : : gpu_ptr = xomp_get_mapped_ptr(c_loc(buf_real_sp))
1766 : : is_gpu_mapped = c_associated(gpu_ptr)
1767 : : end if
1768 : : end select
1769 : : #else
1770 : : ABI_UNUSED(mat%size_local(1))
1771 : : #endif
1772 : :
1773 : 0 : end function basemat_is_gpu_mapped
1774 : : !!***
1775 : :
1776 : : !----------------------------------------------------------------------
1777 : :
1778 : : !!****f* m_slk/basemat_gpu_map
1779 : : !! NAME
1780 : : !! basemat_gpu_map
1781 : : !!
1782 : : !! FUNCTION
1783 : : !! Use OpenMP to allocate/delete the local buffer on the GPU.
1784 : : !! Does nothing if HAVE_OPENMP_OFFLOAD is not defined.
1785 : : !!
1786 : : !! INPUTS
1787 : : !! gpu_action= "None": do nothing.
1788 : : !! "alloc": map the local buffer on the GPU (target enter data map(alloc)).
1789 : : !! "alloc_zero": as "alloc", then set the GPU buffer to zero.
1790 : : !! "delete": unmap the local buffer (target exit data map(delete)).
1791 : : !! "update_from": copy the GPU buffer to the host (target update from).
1792 : : !! "update_to": copy the host buffer to the GPU (target update to).
1793 : : !!
1794 : : !! SOURCE
1795 : :
1796 : 0 : subroutine basemat_gpu_map(mat, gpu_action)
1797 : :
1798 : : !Arguments ------------------------------------
1799 : : class(basemat_t),target,intent(inout) :: mat
1800 : : character(len=*), intent(in) :: gpu_action
1801 : :
1802 : : !Local variables-------------------------------
1803 : : #ifdef HAVE_OPENMP_OFFLOAD
1804 : : real(sp), contiguous, pointer :: buf_real_sp(:,:)
1805 : : real(dp), contiguous, pointer :: buf_real_dp(:,:)
1806 : : complex(sp), contiguous, pointer :: buf_cplx_sp(:,:)
1807 : : complex(dp), contiguous, pointer :: buf_cplx_dp(:,:)
1808 : : #endif
1809 : : ! *********************************************************************
1810 : :
1811 [ # # ]: 0 : if (.not. string_in(gpu_action, "None, alloc, alloc_zero, delete, update_from, update_to")) then
1812 : 0 : ABI_ERROR(sjoin("Invalid gpu_action", gpu_action))
1813 : : ABI_UNUSED(mat%size_local(1))
1814 : : end if
1815 : :
1816 : : if (gpu_action == "None") return
1817 : :
1818 : : #ifdef HAVE_OPENMP_OFFLOAD
1819 : : select type (mat)
1820 : : class is (slkmat_dp_t)
1821 : : if (allocated(mat%buffer_cplx)) then
1822 : : buf_cplx_dp => mat%buffer_cplx
1823 : : if (string_in(gpu_action, "alloc, alloc_zero")) then
1824 : : !$OMP TARGET ENTER DATA MAP(alloc:buf_cplx_dp)
1825 : : if (gpu_action == "alloc_zero") call gpu_set_to_zero_complex(mat%buffer_cplx, mat%bufsize)
1826 : : else if (gpu_action == "delete") then !.and. c_associated(xomp_get_mapped_ptr(c_loc(buf_cplx_dp))
1827 : : !$OMP TARGET EXIT DATA MAP(delete:buf_cplx_dp)
1828 : : else if (gpu_action == "update_from") then
1829 : : !$OMP TARGET UPDATE FROM(buf_cplx_dp)
1830 : : else if (gpu_action == "update_to") then
1831 : : !$OMP TARGET UPDATE TO(buf_cplx_dp)
1832 : : end if
1833 : : end if
1834 : : if (allocated(mat%buffer_real)) then
1835 : : buf_real_dp => mat%buffer_real
1836 : : if (string_in(gpu_action, "alloc, alloc_zero")) then
1837 : : !$OMP TARGET ENTER DATA MAP(alloc:buf_real_dp)
1838 : : if (gpu_action == "alloc_zero") call gpu_set_to_zero(mat%buffer_real, mat%bufsize)
1839 : : else if (gpu_action == "delete") then !.and. c_associated(xomp_get_mapped_ptr(c_loc(buf_real_dp))
1840 : : !$OMP TARGET EXIT DATA MAP(delete:buf_real_dp)
1841 : : else if (gpu_action == "update_from") then
1842 : : !$OMP TARGET UPDATE FROM(buf_real_dp)
1843 : : else if (gpu_action == "update_to") then
1844 : : !$OMP TARGET UPDATE TO(buf_real_dp)
1845 : : end if
1846 : : end if
1847 : :
1848 : : class is (slkmat_sp_t)
1849 : : if (allocated(mat%buffer_cplx)) then
1850 : : buf_cplx_sp => mat%buffer_cplx
1851 : : if (string_in(gpu_action, "alloc, alloc_zero")) then
1852 : : !$OMP TARGET ENTER DATA MAP(alloc:buf_cplx_sp)
1853 : : if (gpu_action == "alloc_zero") call gpu_set_to_zero_complex_sp(mat%buffer_cplx, mat%bufsize)
1854 : : else if (gpu_action == "delete") then !.and. c_associated(xomp_get_mapped_ptr(c_loc(buf_cplx_sp))
1855 : : !$OMP TARGET EXIT DATA MAP(delete:buf_cplx_sp)
1856 : : else if (gpu_action == "update_from") then
1857 : : !$OMP TARGET UPDATE FROM(buf_cplx_sp)
1858 : : else if (gpu_action == "update_to") then
1859 : : !$OMP TARGET UPDATE TO(buf_cplx_sp)
1860 : : end if
1861 : : end if
1862 : : if (allocated(mat%buffer_real)) then
1863 : : buf_real_sp => mat%buffer_real
1864 : : if (string_in(gpu_action, "alloc, alloc_zero")) then
1865 : : !$OMP TARGET ENTER DATA MAP(alloc:buf_real_sp)
1866 : : if (gpu_action == "alloc_zero") call gpu_set_to_zero_sp(mat%buffer_real, mat%bufsize)
1867 : : else if (gpu_action == "delete") then !.and. c_associated(xomp_get_mapped_ptr(c_loc(buf_real_sp))
1868 : : !$OMP TARGET EXIT DATA MAP(delete:buf_real_sp)
1869 : : else if (gpu_action == "update_from") then
1870 : : !$OMP TARGET UPDATE FROM(buf_real_sp)
1871 : : else if (gpu_action == "update_to") then
1872 : : !$OMP TARGET UPDATE TO(buf_real_sp)
1873 : : end if
1874 : : end if
1875 : : end select
1876 : : #endif
1877 : :
1878 : : end subroutine basemat_gpu_map
1879 : : !!***
1880 : :
1881 : : !----------------------------------------------------------------------
1882 : :
1883 : : !!****f* m_slk/slk_array_locmem_mb
1884 : : !! NAME
1885 : : !! slk_array_locmem_mb
1886 : : !!
1887 : : !! FUNCTION
1888 : : !! Elemental function to compute the memory allocated for an array of slkmat_dp_t elements
1889 : : !! Usage: mem_mb = sum(mat_array)
1890 : : !!
1891 : : !! SOURCE
1892 : :
1893 : 0 : elemental real(dp) function slk_array_locmem_mb(mat) result(mem_mb)
1894 : : class(basemat_t),intent(in) :: mat
1895 : 0 : mem_mb = mat%locmem_mb()
1896 : 0 : end function slk_array_locmem_mb
1897 : : !!***
1898 : :
1899 : : !----------------------------------------------------------------------
1900 : :
1901 : : !!****f* m_slk/block_dist_1d
1902 : : !! NAME
1903 : : !! block_dist_1d
1904 : : !!
1905 : : !! FUNCTION
1906 : : !! Return block size for one-dimensional block column (row) distribution.
1907 : : !! Mainly used to assign blocks of contiguous columns (rows) of a matrix to successive processes
1908 : : !! when a 1d grid is employed.
1909 : : !!
1910 : : !! It is usually interfaced with CPP macros, e.g:
1911 : : !!
1912 : : !! ABI_CHECK(block_dist_1d(mat_size, nproc, block_size, msg), msg)
1913 : : !!
1914 : : !! INPUTS
1915 : : !! mat_size=Size of the matrix (either number of rows or number of columns)
1916 : : !! nproc=Number of processes in the 1D scalapack grid
1917 : : !!
1918 : : !! OUTPUT
1919 : : !! ok= Boolean flag with exit status (idle processes are not allowed).
1920 : : !! block_size=Size of the block along this axis needed for one-dimensional block distribution
1921 : : !! msg=Error message (if not ok)
1922 : : !!
1923 : : !! SOURCE
1924 : :
1925 : 0 : logical function block_dist_1d(mat_size, nproc, block_size, msg) result (ok)
1926 : :
1927 : : !Arguments ------------------------------------
1928 : : integer, intent(in) :: mat_size, nproc
1929 : : integer,intent(out) :: block_size
1930 : : character(len=*),intent(out) :: msg
1931 : : ! *********************************************************************
1932 : :
1933 : 0 : ok = .True.; msg = ""
1934 : : !block_size = 1; return
1935 : :
1936 : 0 : block_size = mat_size / nproc
1937 [ # # ]: 0 : if (block_size == 0) then
1938 : 0 : ok = .False.
1939 : : write(msg, "(2(a,i0), 2a)") &
1940 : 0 : "The number of MPI processors: ", nproc, " exceeds the number of rows (columns) of the matrix: ", mat_size, ch10, &
1941 : 0 : "Decrease the number of MPI processes for the scalapack level."
1942 : 0 : return
1943 : : end if
1944 : :
1945 [ # # ]: 0 : if (mod(mat_size, nproc) /= 0) block_size = block_size + 1
1946 : :
1947 [ # # ]: 0 : end function block_dist_1d
1948 : : !!***
1949 : :
1950 : : !----------------------------------------------------------------------
1951 : :
1952 : : !!****f* m_slk/slk_has_elpa
1953 : : !! NAME
1954 : : !! slk_has_elpa
1955 : : !!
1956 : : !! FUNCTION
1957 : : !! Return True if ELPA support is activated
1958 : : !!
1959 : : !! SOURCE
1960 : :
1961 : 0 : pure logical function slk_has_elpa() result (ans)
1962 : :
1963 : 0 : ans = .False.
1964 : : #ifdef HAVE_LINALG_ELPA
1965 : : ans = .True.
1966 : : #endif
1967 : :
1968 : 0 : end function slk_has_elpa
1969 : : !!***
1970 : :
1971 : : !----------------------------------------------------------------------
1972 : :
1973 : : !!****f* m_slk/matrix_get_local_cplx
1974 : : !! NAME
1975 : : !! matrix_get_local_cplx
1976 : : !!
1977 : : !! FUNCTION
1978 : : !! Returns a local matrix coefficient of complex type.
1979 : : !! The coefficient is selected by its local indices.
1980 : : !!
1981 : : !! INPUTS
1982 : : !! matrix= the matrix to process
1983 : : !! i= row in the matrix
1984 : : !! j= column in the matrix
1985 : : !!
1986 : : !! OUTPUT
1987 : : !! The value of the local matrix.
1988 : : !!
1989 : : !! SOURCE
1990 : :
1991 : 0 : pure complex(dpc) function matrix_get_local_cplx(matrix, i, j)
1992 : :
1993 : : !Arguments ------------------------------------
1994 : : class(slkmat_dp_t),intent(in) :: matrix
1995 : : integer, intent(in) :: i,j
1996 : : ! *********************************************************************
1997 : :
1998 : 0 : matrix_get_local_cplx = matrix%buffer_cplx(i,j)
1999 : :
2000 : 0 : end function matrix_get_local_cplx
2001 : : !!***
2002 : :
2003 : : !----------------------------------------------------------------------
2004 : :
2005 : : !!****f* m_slk/matrix_get_local_real
2006 : : !! NAME
2007 : : !! matrix_get_local_real
2008 : : !!
2009 : : !! FUNCTION
2010 : : !! Returns a local matrix coefficient of double precision type.
2011 : : !!
2012 : : !! INPUTS
2013 : : !! matrix= the matrix to process
2014 : : !! i= row in the matrix
2015 : : !! j= column in the matrix
2016 : : !!
2017 : : !! SOURCE
2018 : :
2019 : 0 : pure real(dp) function matrix_get_local_real(matrix,i,j)
2020 : :
2021 : : !Arguments ------------------------------------
2022 : : class(slkmat_dp_t),intent(in) :: matrix
2023 : : integer, intent(in) :: i,j
2024 : : ! *********************************************************************
2025 : :
2026 : 0 : matrix_get_local_real = matrix%buffer_real(i,j)
2027 : :
2028 : 0 : end function matrix_get_local_real
2029 : : !!***
2030 : :
2031 : : !----------------------------------------------------------------------
2032 : :
2033 : : !!****f* m_slk/matrix_set_local_cplx
2034 : : !! NAME
2035 : : !! matrix_set_local_cplx
2036 : : !!
2037 : : !! FUNCTION
2038 : : !! Sets a local matrix coefficient of complex type.
2039 : : !! The coefficient is selected by its local indices.
2040 : : !!
2041 : : !! INPUTS
2042 : : !! i= row in the matrix
2043 : : !! j= column in the matrix
2044 : : !! value= the value to set
2045 : : !!
2046 : : !! SIDE EFFECTS
2047 : : !! matrix%buffer_cplx(i,j) filled with value
2048 : : !!
2049 : : !! SOURCE
2050 : :
2051 : 0 : pure subroutine matrix_set_local_cplx(matrix,i,j,value)
2052 : :
2053 : : !Arguments ------------------------------------
2054 : : class(slkmat_dp_t),intent(inout) :: matrix
2055 : : integer, intent(in) :: i,j
2056 : : complex(dp), intent(in) :: value
2057 : : ! *********************************************************************
2058 : :
2059 : 0 : matrix%buffer_cplx(i,j) = value
2060 : :
2061 : 0 : end subroutine matrix_set_local_cplx
2062 : : !!***
2063 : :
2064 : : !----------------------------------------------------------------------
2065 : :
2066 : : !!****f* m_slk/matrix_set_local_real
2067 : : !! NAME
2068 : : !! matrix_set_local_real
2069 : : !!
2070 : : !! FUNCTION
2071 : : !! Sets a local matrix coefficient of double precision type.
2072 : : !!
2073 : : !! INPUTS
2074 : : !! i= row in the matrix
2075 : : !! j= column in the matrix
2076 : : !! value= the value to set
2077 : : !!
2078 : : !! SIDE EFFECTS
2079 : : !! matrix%buffer_real(i,j) set to value
2080 : : !!
2081 : : !! SOURCE
2082 : :
2083 : 0 : pure subroutine matrix_set_local_real(matrix, i, j, value)
2084 : :
2085 : : !Arguments ------------------------------------
2086 : : class(slkmat_dp_t),intent(inout) :: matrix
2087 : : integer, intent(in) :: i,j
2088 : : real(dp), intent(in) :: value
2089 : : ! *********************************************************************
2090 : :
2091 : 0 : matrix%buffer_real(i,j) = value
2092 : :
2093 : 0 : end subroutine matrix_set_local_real
2094 : : !!***
2095 : :
2096 : : !----------------------------------------------------------------------
2097 : :
2098 : : !!****f* m_slk/idx_loc
2099 : : !! NAME
2100 : : !! idx_loc
2101 : : !!
2102 : : !! FUNCTION
2103 : : !! Return the number of rows (columns) among the first i (j) global rows (columns) that are stored
2104 : : !! on this processor (NUMROC). This is the local index of (i, j) only if this processor owns the entry,
2105 : : !! use glob2loc to find the owner. Called with the global sizes, it returns the local sizes.
2106 : : !!
2107 : : !! INPUTS
2108 : : !! matrix= the matrix to process
2109 : : !! i= global row index
2110 : : !! j= global column index
2111 : : !!
2112 : : !! OUTPUT
2113 : : !! iloc= number of local rows with global index <= i
2114 : : !! jloc= number of local columns with global index <= j
2115 : : !!
2116 : : !! SOURCE
2117 : :
2118 : 0 : subroutine basemat_idx_loc(matrix, i, j, iloc, jloc)
2119 : :
2120 : : !Arguments ------------------------------------
2121 : : class(basemat_t),intent(in) :: matrix
2122 : : integer, intent(in) :: i,j
2123 : : integer, intent(out) :: iloc,jloc
2124 : : ! *********************************************************************
2125 : :
2126 : 0 : iloc = glob_loc__(matrix, i, 1)
2127 : 0 : jloc = glob_loc__(matrix, j, 2)
2128 : :
2129 : 0 : end subroutine basemat_idx_loc
2130 : : !!***
2131 : :
2132 : : !----------------------------------------------------------------------
2133 : :
2134 : : !!****f* m_slk/glob_loc__
2135 : : !! NAME
2136 : : !! glob_loc__
2137 : : !!
2138 : : !! FUNCTION
2139 : : !! Return the number of rows (lico=1) or columns (lico=2) among the first idx global ones
2140 : : !! that are stored on this processor (NUMROC). See basemat_idx_loc.
2141 : : !!
2142 : : !! INPUTS
2143 : : !! matrix= the matrix to process
2144 : : !! idx= global row (column) index
2145 : : !! lico= 1 for rows, 2 for columns
2146 : : !!
2147 : : !! SOURCE
2148 : :
2149 : : integer function glob_loc__(matrix, idx, lico)
2150 : :
2151 : : !Arguments ------------------------------------
2152 : : class(basemat_t),intent(in) :: matrix
2153 : : integer, intent(in) :: idx, lico
2154 : : ! *********************************************************************
2155 : :
2156 : : #ifdef HAVE_LINALG_SCALAPACK
2157 : : glob_loc__ = NUMROC(idx, matrix%size_blocs(lico), &
2158 : : matrix%processor%coords(lico), 0, matrix%processor%grid%dims(lico))
2159 : : #endif
2160 : :
2161 : : end function glob_loc__
2162 : : !!***
2163 : :
2164 : : !----------------------------------------------------------------------
2165 : :
2166 : : !!****f* m_slk/basemat_glob2loc
2167 : : !! NAME
2168 : : !! basemat_glob2loc
2169 : : !!
2170 : : !! FUNCTION
2171 : : !! Determine the local indices of an element from its global indices and return haveit bool flag.
2172 : : !!
2173 : : !! INPUTS
2174 : : !! iglob= global row index.
2175 : : !! jglob= global column index.
2176 : : !!
2177 : : !! OUTPUT
2178 : : !! iloc= local row index in the buffer of the process owning (iglob, jglob)
2179 : : !! jloc= local column index in the buffer of the process owning (iglob, jglob)
2180 : : !! haveit= True if (iglob, jglob) is stored on this proc. iloc and jloc are valid on this proc only if haveit.
2181 : : !!
2182 : : !! SOURCE
2183 : :
2184 : 0 : subroutine basemat_glob2loc(mat, iglob, jglob, iloc, jloc, haveit)
2185 : :
2186 : : !Arguments ------------------------------------
2187 : : class(basemat_t),intent(in) :: mat
2188 : : integer, intent(in) :: iglob, jglob
2189 : : integer, intent(out) :: iloc, jloc
2190 : : logical,intent(out) :: haveit
2191 : :
2192 : : !Local variables-------------------------------
2193 : : integer :: row_src, col_src
2194 : : ! *********************************************************************
2195 : :
2196 : : #ifdef HAVE_LINALG_SCALAPACK
2197 : : ! SUBROUTINE INFOG2L( GRINDX, GCINDX, DESC, NPROW, NPCOL, MYROW, MYCOL, LRINDX, LCINDX, RSRC, CSRC)
2198 : :
2199 : : call INFOG2L(iglob, jglob, mat%desc, mat%processor%grid%dims(1), mat%processor%grid%dims(2), &
2200 : : mat%processor%coords(1), mat%processor%coords(2), iloc, jloc, row_src, col_src)
2201 : :
2202 : : haveit = all(mat%processor%coords == [row_src, col_src])
2203 : : #endif
2204 : :
2205 : 0 : end subroutine basemat_glob2loc
2206 : : !!***
2207 : :
2208 : : !----------------------------------------------------------------------
2209 : :
2210 : : !!****f* m_slk/basemat_loc2glob
2211 : : !! NAME
2212 : : !! basemat_loc2glob
2213 : : !!
2214 : : !! FUNCTION
2215 : : !! Determine the global indices of an element from its local indices.
2216 : : !!
2217 : : !! INPUTS
2218 : : !! matrix= the matrix to process.
2219 : : !! iloc= local row index.
2220 : : !! jloc= local column index.
2221 : : !!
2222 : : !! OUTPUT
2223 : : !! i= row in the matrix
2224 : : !! j= column in the matrix
2225 : : !!
2226 : : !! SOURCE
2227 : :
2228 : 0 : pure subroutine basemat_loc2glob(matrix, iloc, jloc, i, j)
2229 : :
2230 : : !Arguments ------------------------------------
2231 : : class(basemat_t),intent(in) :: matrix
2232 : : integer, intent(in) :: iloc,jloc
2233 : : integer, intent(out) :: i,j
2234 : : ! *********************************************************************
2235 : :
2236 : 0 : i = loc_glob__(matrix, matrix%processor, iloc, 1)
2237 : 0 : j = loc_glob__(matrix, matrix%processor, jloc, 2)
2238 : :
2239 : 0 : end subroutine basemat_loc2glob
2240 : : !!***
2241 : :
2242 : : !!****f* m_slk/basemat_loc2grow
2243 : : !! NAME
2244 : : !! basemat_loc2grow
2245 : : !!
2246 : : !! FUNCTION
2247 : : !! Determine the global row index from the local index
2248 : : !!
2249 : : !! INPUTS
2250 : : !! matrix= the matrix to process.
2251 : : !! iloc= local row index.
2252 : : !!
2253 : : !! SOURCE
2254 : :
2255 : 0 : integer pure function basemat_loc2grow(matrix, iloc) result(iglob)
2256 : :
2257 : : !Arguments ------------------------------------
2258 : : class(basemat_t),intent(in) :: matrix
2259 : : integer, intent(in) :: iloc
2260 : : ! *********************************************************************
2261 : :
2262 : 0 : iglob = loc_glob__(matrix, matrix%processor, iloc, 1)
2263 : :
2264 : 0 : end function basemat_loc2grow
2265 : : !!***
2266 : :
2267 : : !!****f* m_slk/basemat_loc2col
2268 : : !! NAME
2269 : : !! basemat_loc2col
2270 : : !!
2271 : : !! FUNCTION
2272 : : !! Determine the global column index of an element from the local index
2273 : : !!
2274 : : !! INPUTS
2275 : : !! matrix= the matrix to process.
2276 : : !! jloc= local column index.
2277 : : !!
2278 : : !! SOURCE
2279 : :
2280 : 0 : integer pure function basemat_loc2col(matrix, jloc) result(jglob)
2281 : :
2282 : : !Arguments ------------------------------------
2283 : : class(basemat_t),intent(in) :: matrix
2284 : : integer, intent(in) :: jloc
2285 : : ! *********************************************************************
2286 : :
2287 : 0 : jglob = loc_glob__(matrix, matrix%processor, jloc, 2)
2288 : :
2289 : 0 : end function basemat_loc2col
2290 : : !!***
2291 : :
2292 : : !----------------------------------------------------------------------
2293 : :
2294 : : !!****f* m_slk/loc_glob__
2295 : : !! NAME
2296 : : !! loc_glob__
2297 : : !!
2298 : : !! FUNCTION
2299 : : !! Determine the global index from a local index (row or column) as a function of a given processor
2300 : : !! Assumes that the first block is stored on the process with coordinate 0 (RSRC = CSRC = 0 as in basemat_init).
2301 : : !!
2302 : : !! INPUTS
2303 : : !! matrix= the matrix to process
2304 : : !! proc= descriptor of a processor
2305 : : !! idx= local row (column) index
2306 : : !! lico= block size index. 1 for rows. 2 for columns
2307 : : !!
2308 : : !! SOURCE
2309 : :
2310 : 0 : integer pure function loc_glob__(matrix, proc, idx, lico)
2311 : :
2312 : : !Arguments ------------------------------------
2313 : : class(basemat_t),intent(in) :: matrix
2314 : : class(slk_processor_t),intent(in) :: proc
2315 : : integer, intent(in) :: idx,lico
2316 : :
2317 : : !Local variables-------------------------------
2318 : : integer :: nbcyc, rest, nblocs
2319 : : ! *********************************************************************
2320 : :
2321 : 0 : nbcyc = INT((idx-1) / matrix%size_blocs(lico))
2322 : 0 : rest = MOD(idx-1, matrix%size_blocs(lico))
2323 : 0 : nblocs = nbcyc * proc%grid%dims(lico) + proc%coords(lico)
2324 : :
2325 : 0 : loc_glob__ = nblocs * matrix%size_blocs(lico) + rest + 1
2326 : :
2327 : 0 : end function loc_glob__
2328 : : !!***
2329 : :
2330 : : !----------------------------------------------------------------------
2331 : :
2332 : : !!****f* m_slk/slkmat_dp_from_global_pack
2333 : : !! NAME
2334 : : !! slkmat_dp_from_global_pack
2335 : : !!
2336 : : !! FUNCTION
2337 : : !! Routine to fill a SCALAPACK matrix from a global PACKED matrix.
2338 : : !! Only the upper triangle (iglob <= jglob) of the distributed matrix is meaningful:
2339 : : !! the local entries of the lower triangle are filled with unrelated values of the packed array.
2340 : : !! Use from_global_sym to get the full Hermitian matrix.
2341 : : !!
2342 : : !! INPUTS
2343 : : !! istwf_k= 2 if we have a real matrix else complex.
2344 : : !! glob_mat_pack= one-dimensional array with the upper triangle packed columnwise, replicated on all the processes.
2345 : : !! Complex case: real and imaginary parts of A(i,j) in glob_mat_pack(j*(j-1)+2*i-1:j*(j-1)+2*i), i <= j.
2346 : : !! Real case: A(i,j) in glob_mat_pack(j*(j-1)/2+i), i <= j.
2347 : : !!
2348 : : !! SIDE EFFECTS
2349 : : !! matrix= the matrix to process
2350 : : !!
2351 : : !! SOURCE
2352 : :
2353 : 0 : subroutine slkmat_dp_from_global_pack(matrix, glob_mat_pack, istwf_k)
2354 : :
2355 : : !Arguments ------------------------------------
2356 : : class(slkmat_dp_t),intent(inout) :: matrix
2357 : : integer,intent(in) :: istwf_k
2358 : : real(dp),intent(in) :: glob_mat_pack(*)
2359 : :
2360 : : !Local variables-------------------------------
2361 : : integer :: i,j,iglob,jglob,ind
2362 : : real(dp) :: val_real
2363 : : complex(dp) :: val_cplx
2364 : : ! *********************************************************************
2365 : :
2366 [ # # ]: 0 : do i=1,matrix%size_local(1)
2367 [ # # ]: 0 : do j=1,matrix%size_local(2)
2368 : 0 : call matrix%loc2glob(i, j, iglob, jglob)
2369 : :
2370 [ # # ]: 0 : if (istwf_k/=2) then
2371 : 0 : ind = jglob*(jglob-1)+2*iglob-1
2372 : 0 : val_cplx = dcmplx(glob_mat_pack(ind),glob_mat_pack(ind+1))
2373 : 0 : call matrix_set_local_cplx(matrix,i,j,val_cplx)
2374 : : else
2375 : 0 : ind = (jglob*(jglob-1))/2 + iglob
2376 : 0 : val_real = glob_mat_pack(ind)
2377 : 0 : call matrix_set_local_real(matrix,i,j,val_real)
2378 : : end if
2379 : :
2380 : : end do
2381 : : end do
2382 : :
2383 : 0 : end subroutine slkmat_dp_from_global_pack
2384 : : !!***
2385 : :
2386 : : !----------------------------------------------------------------------
2387 : :
2388 : : !!****f* m_slk/slkmat_dp_from_global_sym
2389 : : !! NAME
2390 : : !! slkmat_dp_from_global_sym
2391 : : !!
2392 : : !! FUNCTION
2393 : : !! Fill the full distributed matrix from the upper triangle of a Hermitian (real symmetric) matrix in packed form.
2394 : : !! The entries of the lower triangle are set to the complex conjugate of the upper triangle.
2395 : : !!
2396 : : !! INPUTS
2397 : : !! istwf_k= 2 if we have a real matrix else complex.
2398 : : !! glob_vec_pack= one-dimensional array with the upper triangle packed columnwise, replicated on all the processes.
2399 : : !! Same layout as in from_global_pack.
2400 : : !!
2401 : : !! SIDE EFFECTS
2402 : : !! matrix= the matrix to process
2403 : : !!
2404 : : !! SOURCE
2405 : :
2406 [ # # ]: 0 : subroutine slkmat_dp_from_global_sym(matrix, glob_vec_pack, istwf_k)
2407 : :
2408 : : !Arguments ------------------------------------
2409 : : class(slkmat_dp_t),intent(inout) :: matrix
2410 : : real(dp),intent(in) :: glob_vec_pack(:)
2411 : : integer,intent(in) :: istwf_k
2412 : :
2413 : : !Local variables-------------------------------
2414 : : integer :: i,j,iglob,jglob,ind
2415 : : complex(dp):: val_cplx
2416 : : real(dp) ::val_real
2417 : : ! *********************************************************************
2418 : :
2419 [ # # ]: 0 : do i=1,matrix%size_local(1)
2420 [ # # ]: 0 : do j=1,matrix%size_local(2)
2421 : 0 : call matrix%loc2glob(i,j,iglob,jglob)
2422 [ # # ]: 0 : if (jglob < iglob) then
2423 : 0 : ind = iglob*(iglob-1)+2*jglob-1
2424 : : else
2425 : 0 : ind = jglob*(jglob-1)+2*iglob-1
2426 : : end if
2427 [ # # ]: 0 : if (istwf_k /= 2) then
2428 : 0 : val_cplx = dcmplx(glob_vec_pack(ind),glob_vec_pack(ind+1))
2429 [ # # ]: 0 : if (jglob < iglob) then
2430 : 0 : call matrix_set_local_cplx(matrix,i,j,conjg(val_cplx))
2431 : : else
2432 : 0 : call matrix_set_local_cplx(matrix,i,j,val_cplx)
2433 : : end if
2434 : : else
2435 : 0 : ind = (ind + 1) / 2
2436 : 0 : val_real = glob_vec_pack(ind)
2437 : 0 : call matrix_set_local_real(matrix,i,j,val_real)
2438 : : end if
2439 : : end do
2440 : : end do
2441 : :
2442 : 0 : end subroutine slkmat_dp_from_global_sym
2443 : : !!***
2444 : :
2445 : : !----------------------------------------------------------------------
2446 : :
2447 : : !!****f* m_slk/slkmat_dp_from_real_glob
2448 : : !! NAME
2449 : : !! slkmat_dp_from_real_glob
2450 : : !!
2451 : : !! FUNCTION
2452 : : !! Routine to fill a SCALAPACK matrix from a real global matrix (FULL STORAGE MODE)
2453 : : !! The matrix must have been initialized with istwf_k = 2 (buffer_real).
2454 : : !!
2455 : : !! INPUTS
2456 : : !! istwf_k= Not used.
2457 : : !! glob_mat(n, m)= a real matrix, replicated on all the processes.
2458 : : !!
2459 : : !! SIDE EFFECTS
2460 : : !! matrix= the matrix to process
2461 : : !!
2462 : : !! SOURCE
2463 : :
2464 [ # # ]: 0 : subroutine slkmat_dp_from_real_glob(matrix, glob_mat, istwf_k)
2465 : :
2466 : : !Arguments ------------------------------------
2467 : : class(slkmat_dp_t),intent(inout) :: matrix
2468 : : integer,intent(in) :: istwf_k
2469 : : !arrays
2470 : : real(dp),intent(in) :: glob_mat(:,:)
2471 : :
2472 : : !Local variables-------------------------------
2473 : : integer :: i,j,iglob,jglob
2474 : : real(dp) :: val
2475 : : ! *********************************************************************
2476 : :
2477 : : ABI_UNUSED(istwf_k)
2478 : :
2479 [ # # ]: 0 : do i=1,matrix%size_local(1)
2480 [ # # ]: 0 : do j=1,matrix%size_local(2)
2481 : 0 : call matrix%loc2glob(i, j, iglob, jglob)
2482 : 0 : val = glob_mat(iglob, jglob)
2483 : 0 : call matrix_set_local_real(matrix,i,j,val)
2484 : : end do
2485 : : end do
2486 : :
2487 : 0 : end subroutine slkmat_dp_from_real_glob
2488 : : !!***
2489 : :
2490 : : !----------------------------------------------------------------------
2491 : :
2492 : : !!****f* m_slk/slkmat_dp_from_complex_glob
2493 : : !! NAME
2494 : : !! slkmat_dp_from_complex_glob
2495 : : !!
2496 : : !! FUNCTION
2497 : : !! Routine to fill a SCALAPACK matrix from a global matrix (FULL STORAGE MODE)
2498 : : !! The matrix must have been initialized with istwf_k /= 2 (buffer_cplx).
2499 : : !!
2500 : : !! INPUTS
2501 : : !! istwf_k= Not used.
2502 : : !! glob_mat(2*n, m)= a complex matrix stored as real/imag pairs, replicated on all the processes.
2503 : : !!
2504 : : !! SIDE EFFECTS
2505 : : !! matrix= the matrix to process
2506 : : !!
2507 : : !! SOURCE
2508 : :
2509 [ # # ]: 0 : subroutine slkmat_dp_from_complex_glob(matrix, glob_mat, istwf_k)
2510 : :
2511 : : !Arguments ------------------------------------
2512 : : class(slkmat_dp_t),intent(inout) :: matrix
2513 : : integer,intent(in) :: istwf_k
2514 : : !arrays
2515 : : real(dp),intent(in) :: glob_mat(:,:)
2516 : :
2517 : : !Local variables-------------------------------
2518 : : integer :: i,j,iglob,jglob
2519 : : complex(dpc) :: val
2520 : : ! *********************************************************************
2521 : :
2522 : : ABI_UNUSED(istwf_k)
2523 : :
2524 [ # # ]: 0 : do i=1,matrix%size_local(1)
2525 [ # # ]: 0 : do j=1,matrix%size_local(2)
2526 : 0 : call matrix%loc2glob(i, j, iglob, jglob)
2527 : 0 : val = dcmplx(glob_mat(2*iglob-1, jglob),glob_mat(2*iglob, jglob))
2528 : 0 : call matrix_set_local_cplx(matrix,i,j,val)
2529 : : end do
2530 : : end do
2531 : :
2532 : 0 : end subroutine slkmat_dp_from_complex_glob
2533 : : !!***
2534 : :
2535 : : !----------------------------------------------------------------------
2536 : :
2537 : : !!****f* m_slk/slkmat_dp_to_global_pack
2538 : : !! NAME
2539 : : !! slkmat_dp_to_global_pack
2540 : : !!
2541 : : !! FUNCTION
2542 : : !! Inserts the upper triangle of a ScaLAPACK matrix into a global one in PACKED storage mode (columnwise,
2543 : : !! same layout as in from_global_pack). Only the entries owned by this process are written,
2544 : : !! the lower triangle (iglob > jglob) is ignored.
2545 : : !!
2546 : : !! INPUTS
2547 : : !! matrix= the matrix to process
2548 : : !! istwf_k= 2 if we have a real matrix else complex.
2549 : : !!
2550 : : !! SIDE EFFECTS
2551 : : !! glob_pack(n*(n+1))= one-dimensional array (n*(n+1)/2 elements are used in the real case)
2552 : : !!
2553 : : !! SOURCE
2554 : :
2555 : 0 : subroutine slkmat_dp_to_global_pack(matrix, glob_pack, istwf_k)
2556 : :
2557 : : !Arguments ------------------------------------
2558 : : class(slkmat_dp_t),intent(in) :: matrix
2559 : : integer,intent(in) :: istwf_k !,nband_k
2560 : : real(dp),intent(inout) :: glob_pack(*) !(nband_k*(nband_k+1))
2561 : :
2562 : : !Local variables-------------------------------
2563 : : integer :: i,j,iglob,jglob,ind
2564 : : ! *********************************************************************
2565 : :
2566 [ # # ]: 0 : do i=1,matrix%size_local(1)
2567 [ # # ]: 0 : do j=1,matrix%size_local(2)
2568 : 0 : call matrix%loc2glob(i, j, iglob, jglob)
2569 [ # # ]: 0 : if (iglob > jglob) cycle ! Only the upper triangle is stored.
2570 : :
2571 : 0 : ind = jglob*(jglob-1)+2*iglob-1
2572 [ # # ]: 0 : if (istwf_k/=2) then
2573 : 0 : glob_pack(ind) = real(matrix_get_local_cplx(matrix,i,j))
2574 : 0 : glob_pack(ind+1) = aimag(matrix_get_local_cplx(matrix,i,j))
2575 : : else
2576 : 0 : ind=(ind+1)/2 !real packed storage
2577 : 0 : glob_pack(ind) = matrix_get_local_real(matrix,i,j)
2578 : : end if
2579 : : end do
2580 : : end do
2581 : :
2582 : 0 : end subroutine slkmat_dp_to_global_pack
2583 : : !!***
2584 : :
2585 : : !----------------------------------------------------------------------
2586 : :
2587 : : !!****f* m_slk/slkmat_dp_to_real_glob
2588 : : !! NAME
2589 : : !! slkmat_dp_to_real_glob
2590 : : !!
2591 : : !! FUNCTION
2592 : : !! Inserts a ScaLAPACK matrix into a real matrix in FULL STORAGE MODE.
2593 : : !! The matrix must have been initialized with istwf_k = 2 (buffer_real).
2594 : : !!
2595 : : !! INPUTS
2596 : : !! matrix= the matrix to process
2597 : : !! istwf_k= Not used.
2598 : : !!
2599 : : !! SIDE EFFECTS
2600 : : !! glob_mat(n, m)= the matrix to fill. Only the entries owned by this process are written.
2601 : : !!
2602 : : !! SOURCE
2603 : :
2604 [ # # ]: 0 : subroutine slkmat_dp_to_real_glob(matrix, glob_mat, istwf_k)
2605 : :
2606 : : !Arguments ------------------------------------
2607 : : class(slkmat_dp_t),intent(in) :: matrix
2608 : : integer,intent(in) :: istwf_k
2609 : : !arrays
2610 : : real(dp),intent(inout) :: glob_mat(:,:)
2611 : :
2612 : : !Local variables-------------------------------
2613 : : integer :: i,j,iglob,jglob
2614 : : ! *********************************************************************
2615 : :
2616 : : ABI_UNUSED(istwf_k)
2617 : :
2618 [ # # ]: 0 : do i=1,matrix%size_local(1)
2619 [ # # ]: 0 : do j=1,matrix%size_local(2)
2620 : 0 : call matrix%loc2glob(i, j, iglob, jglob)
2621 : 0 : glob_mat(iglob,jglob) = matrix_get_local_real(matrix,i,j)
2622 : : end do
2623 : : end do
2624 : :
2625 : 0 : end subroutine slkmat_dp_to_real_glob
2626 : : !!***
2627 : :
2628 : : !----------------------------------------------------------------------
2629 : :
2630 : : !!****f* m_slk/slkmat_dp_to_complex_glob
2631 : : !! NAME
2632 : : !! slkmat_dp_to_complex_glob
2633 : : !!
2634 : : !! FUNCTION
2635 : : !! Inserts a ScaLAPACK matrix into a complex matrix in FULL STORAGE MODE.
2636 : : !! The matrix must have been initialized with istwf_k /= 2 (buffer_cplx).
2637 : : !!
2638 : : !! INPUTS
2639 : : !! matrix= the matrix to process
2640 : : !! istwf_k= Not used.
2641 : : !!
2642 : : !! SIDE EFFECTS
2643 : : !! glob_cmat(n, m)= the matrix to fill. Only the entries owned by this process are written.
2644 : : !!
2645 : : !! SOURCE
2646 : :
2647 [ # # ]: 0 : subroutine slkmat_dp_to_complex_glob(matrix, glob_cmat, istwf_k)
2648 : :
2649 : : !Arguments ------------------------------------
2650 : : integer,intent(in) :: istwf_k
2651 : : class(slkmat_dp_t),intent(in) :: matrix
2652 : : !arrays
2653 : : complex(dpc),intent(inout) :: glob_cmat(:,:)
2654 : :
2655 : : !Local variables-------------------------------
2656 : : integer :: i,j,iglob,jglob
2657 : : ! *********************************************************************
2658 : :
2659 : : ABI_UNUSED(istwf_k)
2660 : :
2661 [ # # ]: 0 : do i=1,matrix%size_local(1)
2662 [ # # ]: 0 : do j=1,matrix%size_local(2)
2663 : 0 : call matrix%loc2glob(i, j, iglob, jglob)
2664 : 0 : glob_cmat(iglob,jglob) = matrix_get_local_cplx(matrix,i,j)
2665 : : end do
2666 : : end do
2667 : :
2668 : 0 : end subroutine slkmat_dp_to_complex_glob
2669 : : !!***
2670 : :
2671 : : !----------------------------------------------------------------------
2672 : :
2673 : : !!****f* m_slk/slkmat_dp_to_global
2674 : : !! NAME
2675 : : !! slkmat_dp_to_global
2676 : : !!
2677 : : !! FUNCTION
2678 : : !! Routine to fill a full matrix with respect to a SCALAPACK matrix.
2679 : : !!
2680 : : !! INPUTS
2681 : : !! matrix= the matrix to process
2682 : : !! istwf_k= 2 if we have a real matrix else complex.
2683 : : !!
2684 : : !! SIDE EFFECTS
2685 : : !! glob_mat= two-dimensional real(dp) array: (2*n, m) with real/imag pairs if istwf_k /= 2, (n, m) if istwf_k == 2.
2686 : : !! Only the entries owned by this process are written.
2687 : : !!
2688 : : !! SOURCE
2689 : :
2690 [ # # ]: 0 : subroutine slkmat_dp_to_global(matrix, glob_mat, istwf_k)
2691 : :
2692 : : !Arguments ------------------------------------
2693 : : class(slkmat_dp_t),intent(in) :: matrix
2694 : : integer,intent(in) :: istwf_k
2695 : : !arrays
2696 : : real(dp),intent(inout) :: glob_mat(:,:)
2697 : :
2698 : : !Local variables-------------------------------
2699 : : integer :: i,j,iglob,jglob,ind
2700 : : ! *********************************************************************
2701 : :
2702 [ # # ]: 0 : do i=1,matrix%size_local(1)
2703 [ # # ]: 0 : do j=1,matrix%size_local(2)
2704 : 0 : call matrix%loc2glob(i, j, iglob, jglob)
2705 : :
2706 [ # # ]: 0 : if (istwf_k/=2) then
2707 : 0 : ind=(iglob-1)*2+1
2708 : 0 : glob_mat(ind, jglob) = real(matrix_get_local_cplx(matrix,i,j))
2709 : 0 : glob_mat(ind+1,jglob) = aimag(matrix_get_local_cplx(matrix,i,j))
2710 : : else
2711 : 0 : ind=iglob
2712 : 0 : glob_mat(ind,jglob) = matrix_get_local_real(matrix,i,j)
2713 : : !glob_mat(ind+1,jglob) = 0._dp
2714 : : end if
2715 : :
2716 : : end do
2717 : : end do
2718 : :
2719 : 0 : end subroutine slkmat_dp_to_global
2720 : : !!***
2721 : :
2722 : : !----------------------------------------------------------------------
2723 : :
2724 : : !!****f* m_slk/slk_matrix_from_global_dpc_2D
2725 : : !! NAME
2726 : : !! slk_matrix_from_global_dpc_2D
2727 : : !!
2728 : : !! FUNCTION
2729 : : !! Routine to fill a complex SCALAPACK matrix with respect to a global matrix.
2730 : : !! target: Two-dimensional double precision complex matrix
2731 : : !!
2732 : : !! INPUTS
2733 : : !! glob_cmat=Two-dimensional array containing the global matrix.
2734 : : !! uplo=String specifying whether only the upper or lower triangular part of the global matrix is used:
2735 : : !! = "U": Upper triangular
2736 : : !! = "L": Lower triangular
2737 : : !! = "A": Full matrix (used for general complex matrices)
2738 : : !!
2739 : : !! SIDE EFFECTS
2740 : : !! mat<slkmat_dp_t>=The distributed matrix.
2741 : : !! %buffer_cplx=Local buffer containing the value this node is dealing with.
2742 : : !!
2743 : : !! SOURCE
2744 : :
2745 [ # # ]: 0 : subroutine slk_matrix_from_global_dpc_2D(mat, uplo, glob_cmat)
2746 : :
2747 : : !Arguments ------------------------------------
2748 : : !scalars
2749 : : class(slkmat_dp_t),intent(inout) :: mat
2750 : : character(len=*),intent(in) :: uplo
2751 : : !array
2752 : : complex(dpc),intent(in) :: glob_cmat(:,:)
2753 : :
2754 : : !Local variables-------------------------------
2755 : : integer :: ii, jj, iglob, jglob
2756 : : !************************************************************************
2757 : :
2758 [ # # ]: 0 : ABI_CHECK(allocated(mat%buffer_cplx), "%buffer_cplx not allocated")
2759 : :
2760 : 0 : select case (uplo(1:1))
2761 : :
2762 : : case ("A", "a")
2763 : : ! Full global matrix is used.
2764 [ # # ]: 0 : do jj=1,mat%size_local(2)
2765 [ # # ]: 0 : do ii=1,mat%size_local(1)
2766 : 0 : call mat%loc2glob(ii, jj, iglob, jglob)
2767 : 0 : mat%buffer_cplx(ii,jj) = glob_cmat(iglob,jglob)
2768 : : end do
2769 : : end do
2770 : :
2771 : : case ("U", "u")
2772 : : ! Only the upper triangle of the global matrix is used.
2773 [ # # ]: 0 : do jj=1,mat%size_local(2)
2774 [ # # ]: 0 : do ii=1,mat%size_local(1)
2775 : 0 : call mat%loc2glob(ii, jj, iglob, jglob)
2776 [ # # ]: 0 : if (jglob>=iglob) then
2777 : 0 : mat%buffer_cplx(ii,jj) = glob_cmat(iglob,jglob)
2778 : : else
2779 : 0 : mat%buffer_cplx(ii,jj) = DCONJG(glob_cmat(jglob,iglob))
2780 : : end if
2781 : : end do
2782 : : end do
2783 : :
2784 : : case ("L", "l")
2785 : : ! Only the lower triangle of the global matrix is used.
2786 [ # # ]: 0 : do jj=1,mat%size_local(2)
2787 [ # # ]: 0 : do ii=1,mat%size_local(1)
2788 : 0 : call mat%loc2glob(ii, jj, iglob, jglob)
2789 [ # # ]: 0 : if (jglob<=iglob) then
2790 : 0 : mat%buffer_cplx(ii,jj) = glob_cmat(iglob,jglob)
2791 : : else
2792 : 0 : mat%buffer_cplx(ii,jj) = DCONJG(glob_cmat(jglob,iglob))
2793 : : end if
2794 : : end do
2795 : : end do
2796 : :
2797 : : case default
2798 [ # # # # : 0 : ABI_BUG(" Wrong uplo: "//TRIM(uplo))
# # ]
2799 : : end select
2800 : :
2801 : 0 : end subroutine slk_matrix_from_global_dpc_2D
2802 : : !!***
2803 : :
2804 : : !----------------------------------------------------------------------
2805 : :
2806 : : !!****f* m_slk/slk_matrix_from_global_dpc_1Dp
2807 : : !! NAME
2808 : : !! slk_matrix_from_global_dpc_1Dp
2809 : : !!
2810 : : !! FUNCTION
2811 : : !! Routine to fill a complex SCALAPACK matrix with respect to a global matrix.
2812 : : !! target: double precision complex matrix in packed form.
2813 : : !!
2814 : : !! INPUTS
2815 : : !! glob_cmat_pack(n*(n+1)/2)=One-dimensional array containing the global matrix A packed columnwise in a linear array.
2816 : : !! The j-th column of A is stored in the array glob_cmat_pack as follows:
2817 : : !! if uplo = "U", glob_cmat_pack(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
2818 : : !! if uplo = "L", glob_cmat_pack(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
2819 : : !! where n is the number of rows or columns in the global matrix.
2820 : : !! uplo=String specifying whether only the upper or lower triangular part of the global matrix is used:
2821 : : !! = "U": Upper triangular
2822 : : !! = "L": Lower triangular
2823 : : !!
2824 : : !! SIDE EFFECTS
2825 : : !! mat<slkmat_dp_t>=The distributed matrix.
2826 : : !! %buffer_cplx=Local buffer containing the value this node is dealing with.
2827 : : !!
2828 : : !! SOURCE
2829 : :
2830 [ # # ]: 0 : subroutine slk_matrix_from_global_dpc_1Dp(mat,uplo, glob_cmat_pack)
2831 : :
2832 : : !Arguments ------------------------------------
2833 : : !scalars
2834 : : class(slkmat_dp_t),intent(inout) :: mat
2835 : : character(len=*),intent(in) :: uplo
2836 : : !array
2837 : : complex(dpc),intent(in) :: glob_cmat_pack(:)
2838 : :
2839 : : !Local variables-------------------------------
2840 : : integer :: ii,jj,iglob,jglob,ind,n
2841 : : real(dp) :: szm
2842 : : !************************************************************************
2843 : :
2844 [ # # ]: 0 : ABI_CHECK(allocated(mat%buffer_cplx), "%buffer_cplx not allocated")
2845 : :
2846 : 0 : szm = SIZE(glob_cmat_pack)
2847 : 0 : n = NINT( (-1 + SQRT(one+8*szm) )*half )
2848 [ # # ]: 0 : if (n*(n+1)/2 /= SIZE(glob_cmat_pack)) then
2849 : 0 : ABI_ERROR("Buggy compiler")
2850 : : end if
2851 : :
2852 : 0 : select case (uplo(1:1))
2853 : :
2854 : : case ("U", "u")
2855 : : ! Only the upper triangle of the global matrix is used.
2856 [ # # ]: 0 : do jj=1,mat%size_local(2)
2857 [ # # ]: 0 : do ii=1,mat%size_local(1)
2858 : 0 : call mat%loc2glob(ii, jj, iglob, jglob)
2859 : :
2860 [ # # ]: 0 : if (jglob>=iglob) then
2861 : 0 : ind = iglob + jglob*(jglob-1)/2
2862 : 0 : mat%buffer_cplx(ii,jj) = glob_cmat_pack(ind)
2863 : : else
2864 : 0 : ind = jglob + iglob*(iglob-1)/2
2865 : 0 : mat%buffer_cplx(ii,jj) = DCONJG( glob_cmat_pack(ind) )
2866 : : end if
2867 : :
2868 : : end do
2869 : : end do
2870 : :
2871 : : case ("L", "l")
2872 : : ! Only the lower triangle of the global matrix is used.
2873 [ # # ]: 0 : do jj=1,mat%size_local(2)
2874 [ # # ]: 0 : do ii=1,mat%size_local(1)
2875 : 0 : call mat%loc2glob(ii, jj, iglob, jglob)
2876 : :
2877 [ # # ]: 0 : if (jglob<=iglob) then
2878 : 0 : ind = iglob + (jglob-1)*(2*n-jglob)/2
2879 : 0 : mat%buffer_cplx(ii,jj) = glob_cmat_pack(ind)
2880 : : else
2881 : 0 : ind = jglob + (iglob-1)*(2*n-iglob)/2
2882 : 0 : mat%buffer_cplx(ii,jj) = DCONJG( glob_cmat_pack(ind) )
2883 : : end if
2884 : : end do
2885 : : end do
2886 : :
2887 : : case default
2888 [ # # # # : 0 : ABI_BUG(" Wrong uplo: "//TRIM(uplo))
# ]
2889 : : end select
2890 : :
2891 : 0 : end subroutine slk_matrix_from_global_dpc_1Dp
2892 : : !!***
2893 : :
2894 : : !----------------------------------------------------------------------
2895 : :
2896 : : !!****f* m_slk/slk_matrix_to_global_dpc_2D
2897 : : !! NAME
2898 : : !! slk_matrix_to_global_dpc_2D
2899 : : !!
2900 : : !! FUNCTION
2901 : : !! Fill a global matrix with respect to a SCALAPACK matrix.
2902 : : !! target: Two-dimensional double precision complex matrix.
2903 : : !!
2904 : : !! INPUTS
2905 : : !! Slk_mat<slkmat_dp_t>=The distributed matrix.
2906 : : !! uplo=String specifying whether the upper or lower triangular part of the global matrix has to be filled:
2907 : : !! = "U": Upper triangular
2908 : : !! = "L": Lower triangular
2909 : : !! = "A": Full matrix is filled (used for general complex matrices)
2910 : : !!
2911 : : !! SIDE EFFECTS
2912 : : !! glob_cmat=The global matrix where the entries owned by this processors have been overwritten.
2913 : : !! Note that the remaining entries not treated by this node are not changed.
2914 : : !!
2915 : : !! SOURCE
2916 : :
2917 [ # # ]: 0 : subroutine slk_matrix_to_global_dpc_2D(mat, uplo, glob_cmat)
2918 : :
2919 : : !Arguments ------------------------------------
2920 : : !scalars
2921 : : class(slkmat_dp_t),intent(in) :: mat
2922 : : character(len=*),intent(in) :: uplo
2923 : : !arrays
2924 : : complex(dpc),intent(inout) :: glob_cmat(:,:)
2925 : :
2926 : : !Local variables-------------------------------
2927 : : integer :: ii,jj,iglob,jglob
2928 : : !************************************************************************
2929 : :
2930 : 0 : select case (uplo(1:1))
2931 : : case ("A", "a")
2932 : : ! Full global matrix has to be filled.
2933 [ # # ]: 0 : do jj=1,mat%size_local(2)
2934 [ # # ]: 0 : do ii=1,mat%size_local(1)
2935 : 0 : call mat%loc2glob(ii, jj, iglob, jglob)
2936 : 0 : glob_cmat(iglob,jglob) = mat%buffer_cplx(ii,jj)
2937 : : end do
2938 : : end do
2939 : :
2940 : : case ("U", "u")
2941 : : ! Only the upper triangle of the global matrix is filled.
2942 [ # # ]: 0 : do jj=1,mat%size_local(2)
2943 [ # # ]: 0 : do ii=1,mat%size_local(1)
2944 : 0 : call mat%loc2glob(ii, jj, iglob, jglob)
2945 [ # # ]: 0 : if (jglob>=iglob) glob_cmat(iglob,jglob) = mat%buffer_cplx(ii,jj)
2946 : : end do
2947 : : end do
2948 : :
2949 : : case ("L", "l")
2950 : : ! Only the lower triangle of the global matrix is filled.
2951 [ # # ]: 0 : do jj=1,mat%size_local(2)
2952 [ # # ]: 0 : do ii=1,mat%size_local(1)
2953 : 0 : call mat%loc2glob(ii, jj, iglob, jglob)
2954 [ # # ]: 0 : if (jglob<=iglob) glob_cmat(iglob,jglob) = mat%buffer_cplx(ii,jj)
2955 : : end do
2956 : : end do
2957 : :
2958 : : case default
2959 [ # # # # : 0 : ABI_BUG(" Wrong uplo: "//TRIM(uplo))
# # ]
2960 : : end select
2961 : :
2962 : 0 : end subroutine slk_matrix_to_global_dpc_2D
2963 : : !!***
2964 : :
2965 : : !----------------------------------------------------------------------
2966 : :
2967 : : !!****f* m_slk/my_locr
2968 : : !! NAME
2969 : : !! my_locr
2970 : : !!
2971 : : !! FUNCTION
2972 : : !! Method of slkmat_dp_t wrapping the scaLAPACK tool LOCr.
2973 : : !!
2974 : : !! OUTPUT
2975 : : !! my_locr= For the meaning see NOTES below.
2976 : : !!
2977 : : !! NOTES
2978 : : !! Let K be the number of rows or columns of a distributed matrix, and assume that its process grid has dimension p x q.
2979 : : !! LOCr( K ) denotes the number of elements of K that a process would receive if K were distributed over the p
2980 : : !! processes of its process column.
2981 : : !! Similarly, LOCc( K ) denotes the number of elements of K that a process would receive if K were distributed over
2982 : : !! the q processes of its process row.
2983 : : !! The values of LOCr() and LOCc() may be determined via a call to the ScaLAPACK tool function, NUMROC:
2984 : : !! LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
2985 : : !! LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ). An upper bound for these quantities may be computed
2986 : : !! by:
2987 : : !! LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
2988 : : !! LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
2989 : : !!
2990 : : !! SOURCE
2991 : :
2992 : : integer function my_locr(mat)
2993 : :
2994 : : !Arguments ------------------------------------
2995 : : class(basemat_t),intent(in) :: mat
2996 : :
2997 : : !Local variables-------------------------------
2998 : : #ifdef HAVE_LINALG_SCALAPACK
2999 : : integer :: M, MB_A, MYROW, RSRC_A, NPROW
3000 : : ! *************************************************************************
3001 : :
3002 : : M = mat%desc(M_ ) ! The number of rows in the global matrix.
3003 : : MB_A = mat%desc(MB_) ! The number of rows in a block.
3004 : : MYROW = mat%processor%coords(1) ! The row index of my processor
3005 : : RSRC_A = mat%desc(RSRC_) ! The row of the processors at the beginning.
3006 : : NPROW = mat%processor%grid%dims(1) ! The number of processors per row in the Scalapack grid.
3007 : :
3008 : : my_locr = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW )
3009 : : #endif
3010 : :
3011 : : end function my_locr
3012 : : !!***
3013 : :
3014 : : !----------------------------------------------------------------------
3015 : :
3016 : : !!****f* m_slk/my_locc
3017 : : !! NAME
3018 : : !! my_locc
3019 : : !!
3020 : : !! FUNCTION
3021 : : !! Method of slkmat_dp_t wrapping the scaLAPACK tool LOCc.
3022 : : !!
3023 : : !! OUTPUT
3024 : : !! my_locc= For the meaning see NOTES below.
3025 : : !!
3026 : : !! NOTES
3027 : : !! Let K be the number of rows or columns of a distributed matrix, and assume that its process grid has dimension p x q.
3028 : : !! LOCr( K ) denotes the number of elements of K that a process would receive if K were distributed over the p
3029 : : !! processes of its process column.
3030 : : !! Similarly, LOCc( K ) denotes the number of elements of K that a process would receive if K were distributed over
3031 : : !! the q processes of its process row.
3032 : : !! The values of LOCr() and LOCc() may be determined via a call to the ScaLAPACK tool function, NUMROC:
3033 : : !! LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
3034 : : !! LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ). An upper bound for these quantities may be computed
3035 : : !! by:
3036 : : !! LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
3037 : : !! LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
3038 : : !!
3039 : : !! SOURCE
3040 : :
3041 : : integer function my_locc(mat)
3042 : :
3043 : : !Arguments ------------------------------------
3044 : : class(basemat_t),intent(in) :: mat
3045 : :
3046 : : #ifdef HAVE_LINALG_SCALAPACK
3047 : : !Local variables-------------------------------
3048 : : integer :: N, NB_A, MYCOL, CSRC_A, NPCOL
3049 : : ! *************************************************************************
3050 : :
3051 : : N = mat%desc(N_ ) ! The number of columns in the global matrix.
3052 : : NB_A = mat%desc(NB_) ! The number of columns in a block.
3053 : : MYCOL = mat%processor%coords(2) ! The column index of my processor
3054 : : CSRC_A = mat%desc(CSRC_) ! The column of the processors at the beginning.
3055 : : NPCOL = mat%processor%grid%dims(2) ! The number of processors per column in the Scalapack grid.
3056 : :
3057 : : my_locc = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL )
3058 : : #endif
3059 : :
3060 : : end function my_locc
3061 : : !!***
3062 : :
3063 : : !----------------------------------------------------------------------
3064 : :
3065 : : !!****f* m_slk/slk_pgemm_dp
3066 : : !! NAME
3067 : : !! slk_pgemm_dp
3068 : : !!
3069 : : !! FUNCTION
3070 : : !! Extended matrix * matrix product: C := alpha*op(A)*op(B) + beta*C
3071 : : !! For a simple matrix matrix product, one can simply pass alpha = cone and beta = czero
3072 : : !! The global sizes m, n, k of the product are taken from the global shapes of A and B
3073 : : !! so the (sub)matrices defined by ija, ijb, ijc must have these sizes.
3074 : : !!
3075 : : !! INPUTS
3076 : : !! transa, transb= "N" for op(X) = X, "T" for op(X) = X^T, "C" for op(X) = X^H.
3077 : : !! matrix1= first ScaLAPACK matrix (matrix A)
3078 : : !! matrix2= second ScaLAPACK matrix (matrix B)
3079 : : !! alpha= scalar multiplier for the A*B product
3080 : : !! beta= scalar multiplier for the C matrix
3081 : : !! [ija, ijb, ijc]: (global). The row and column indices in the distributed matrix A/B/C
3082 : : !! indicating the first row and the first column of the submatrix, respectively. Default [1, 1]
3083 : : !!
3084 : : !! OUTPUT
3085 : : !! results= ScaLAPACK matrix coming out of the operation
3086 : : !!
3087 : : !! NOTES
3088 : : !! The ESSL manual says that
3089 : : !! "matrices matrix1 and matrix2 must have no common elements otherwise, results are unpredictable."
3090 : : !! However the official scaLAPACK documentation does not report this (severe) limitation.
3091 : : !!
3092 : : !! The real case (istwf_k == 2) passes buffer_cplx instead of buffer_real to P?GEMM and does not work.
3093 : : !! Only complex matrices are used by the callers.
3094 : : !!
3095 : : !! SOURCE
3096 : :
3097 : 0 : subroutine slk_pgemm_dp(transa, transb, matrix1, alpha, matrix2, beta, results, &
3098 : : ija, ijb, ijc) ! optional
3099 : :
3100 : : !Arguments ------------------------------------
3101 : : character(len=1),intent(in) :: transa, transb
3102 : : class(slkmat_dp_t),intent(in) :: matrix1, matrix2
3103 : : class(slkmat_dp_t),intent(inout) :: results
3104 : : complex(dpc),intent(in) :: alpha, beta
3105 : : integer,optional,intent(in) :: ija(2), ijb(2), ijc(2)
3106 : :
3107 : : !Local variables-------------------------------
3108 : : integer :: mm, nn, kk, ija__(2), ijb__(2), ijc__(2)
3109 : : !************************************************************************
3110 : :
3111 : 0 : ija__ = [1, 1]; if (present(ija)) ija__ = ija
3112 : 0 : ijb__ = [1, 1]; if (present(ijb)) ijb__ = ijb
3113 : 0 : ijc__ = [1, 1]; if (present(ijc)) ijc__ = ijc
3114 : :
3115 : 0 : mm = matrix1%size_global(1)
3116 : 0 : nn = matrix2%size_global(2)
3117 : 0 : kk = matrix1%size_global(2)
3118 : :
3119 : 0 : if (toupper(transa) /= 'N') then
3120 : : mm = matrix1%size_global(2)
3121 : 0 : kk = matrix1%size_global(1)
3122 : : end if
3123 : 0 : if (toupper(transb) /= 'N') nn = matrix2%size_global(1)
3124 : :
3125 : : #ifdef HAVE_LINALG_SCALAPACK
3126 : : ! pzgemm(transa, transb, m, n, k, alpha, a, ia, ja, desca, b, ib, jb, descb, beta, c, ic, jc, descc)
3127 : : if (matrix1%istwf_k /= 2) then
3128 : : call PZGEMM(transa, transb, mm, nn, kk, alpha, &
3129 : : matrix1%buffer_cplx, ija__(1), ija__(2), matrix1%desc, &
3130 : : matrix2%buffer_cplx, ijb__(1), ijb__(2), matrix2%desc, &
3131 : : beta, results%buffer_cplx, ijc__(1), ijc__(2), results%desc)
3132 : : else
3133 : : ! FIXME: should use buffer_real for real matrices.
3134 : : call PDGEMM(transa, transb, mm, nn, kk, real(alpha, kind=dp), &
3135 : : matrix1%buffer_cplx, ija__(1), ija__(2), matrix1%desc, &
3136 : : matrix2%buffer_cplx, ijb__(1), ijb__(2), matrix2%desc, &
3137 : : real(beta, kind=dp), results%buffer_cplx, ijc__(1), ijc__(2), results%desc)
3138 : : end if
3139 : : #endif
3140 : :
3141 : 0 : end subroutine slk_pgemm_dp
3142 : : !!***
3143 : :
3144 : : !----------------------------------------------------------------------
3145 : :
3146 : : !!****f* m_slk/slk_pgemm_sp
3147 : : !! NAME
3148 : : !! slk_pgemm_sp
3149 : : !!
3150 : : !! FUNCTION
3151 : : !! Extended matrix * matrix product: C := alpha*op(A)*op(B) + beta*C
3152 : : !! For a simple matrix matrix product, one can simply pass alpha = cone and beta = czero
3153 : : !! The global sizes m, n, k of the product are taken from the global shapes of A and B
3154 : : !! so the (sub)matrices defined by ija, ijb, ijc must have these sizes.
3155 : : !!
3156 : : !! INPUTS
3157 : : !! transa, transb= "N" for op(X) = X, "T" for op(X) = X^T, "C" for op(X) = X^H.
3158 : : !! matrix1= first ScaLAPACK matrix (matrix A)
3159 : : !! matrix2= second ScaLAPACK matrix (matrix B)
3160 : : !! alpha= scalar multiplier for the A*B product
3161 : : !! beta= scalar multiplier for the C matrix
3162 : : !! [ija, ijb, ijc]: (global). The row and column indices in the distributed matrix A/B/C
3163 : : !! indicating the first row and the first column of the submatrix, respectively. Default [1, 1]
3164 : : !!
3165 : : !! OUTPUT
3166 : : !! results= ScaLAPACK matrix coming out of the operation
3167 : : !!
3168 : : !! NOTES
3169 : : !! The ESSL manual says that
3170 : : !! "matrices matrix1 and matrix2 must have no common elements otherwise, results are unpredictable."
3171 : : !! However the official scaLAPACK documentation does not report this (severe) limitation.
3172 : : !!
3173 : : !! The real case (istwf_k == 2) passes buffer_cplx instead of buffer_real to P?GEMM and does not work.
3174 : : !! Only complex matrices are used by the callers.
3175 : : !!
3176 : : !! SOURCE
3177 : :
3178 : 0 : subroutine slk_pgemm_sp(transa, transb, matrix1, alpha, matrix2, beta, results, &
3179 : : ija, ijb, ijc) ! optional
3180 : :
3181 : : !Arguments ------------------------------------
3182 : : character(len=1),intent(in) :: transa, transb
3183 : : class(slkmat_sp_t),intent(in) :: matrix1, matrix2
3184 : : class(slkmat_sp_t),intent(inout) :: results
3185 : : complex(sp),intent(in) :: alpha, beta
3186 : : integer,optional,intent(in) :: ija(2), ijb(2), ijc(2)
3187 : :
3188 : : !Local variables-------------------------------
3189 : : integer :: mm, nn, kk, ija__(2), ijb__(2), ijc__(2)
3190 : : !************************************************************************
3191 : :
3192 : 0 : ija__ = [1, 1]; if (present(ija)) ija__ = ija
3193 : 0 : ijb__ = [1, 1]; if (present(ijb)) ijb__ = ijb
3194 : 0 : ijc__ = [1, 1]; if (present(ijc)) ijc__ = ijc
3195 : :
3196 : 0 : mm = matrix1%size_global(1)
3197 : 0 : nn = matrix2%size_global(2)
3198 : 0 : kk = matrix1%size_global(2)
3199 : :
3200 : 0 : if (toupper(transa) /= 'N') then
3201 : : mm = matrix1%size_global(2)
3202 : 0 : kk = matrix1%size_global(1)
3203 : : end if
3204 : 0 : if (toupper(transb) /= 'N') nn = matrix2%size_global(1)
3205 : :
3206 : : #ifdef HAVE_LINALG_SCALAPACK
3207 : : ! pzgemm(transa, transb, m, n, k, alpha, a, ia, ja, desca, b, ib, jb, descb, beta, c, ic, jc, descc)
3208 : : if (matrix1%istwf_k /= 2) then
3209 : : call PCGEMM(transa, transb, mm, nn, kk, alpha, &
3210 : : matrix1%buffer_cplx, ija__(1), ija__(2), matrix1%desc, &
3211 : : matrix2%buffer_cplx, ijb__(1), ijb__(2), matrix2%desc, &
3212 : : beta, results%buffer_cplx, ijc__(1), ijc__(2), results%desc)
3213 : : else
3214 : : ! FIXME: should use buffer_real for real matrices.
3215 : : call PSGEMM(transa, transb, mm, nn, kk, real(alpha, kind=sp), &
3216 : : matrix1%buffer_cplx, ija__(1), ija__(2), matrix1%desc, &
3217 : : matrix2%buffer_cplx, ijb__(1), ijb__(2), matrix2%desc, &
3218 : : real(beta, kind=sp), results%buffer_cplx, ijc__(1), ijc__(2), results%desc)
3219 : : end if
3220 : : #endif
3221 : :
3222 : 0 : end subroutine slk_pgemm_sp
3223 : : !!***
3224 : :
3225 : : !----------------------------------------------------------------------
3226 : :
3227 : : !!****f* m_slk/compute_eigen_problem
3228 : : !! NAME
3229 : : !! compute_eigen_problem
3230 : : !!
3231 : : !! FUNCTION
3232 : : !! Calculation of eigenvalues and eigenvectors: A * X = lambda * X, complex and real cases.
3233 : : !! Backend: ELPA (1-stage solver) if available, else SLATE, else ScaLAPACK (PZHEEVX or PDSYEVX).
3234 : : !! ScaLAPACK uses only the upper triangle of A while ELPA and SLATE need the full matrix.
3235 : : !!
3236 : : !! INPUTS
3237 : : !! processor= descriptor of a processor
3238 : : !! matrix= the matrix to process. Destroyed on exit.
3239 : : !! comm= MPI communicator of the processes in the grid
3240 : : !! istwf_k= 2 if we have a real matrix else complex.
3241 : : !! [nev]= Number of eigenvalues needed. Default: full set
3242 : : !! [use_gpu_elpa]= Flag to activate the use of GPU (ELPA only)
3243 : : !!
3244 : : !! OUTPUT
3245 : : !! results= ScaLAPACK matrix coming out of the operation (global dimensions must be equal to matrix
3246 : : !! even if only a part of the eigenvectors is needed.
3247 : : !! eigen= eigenvalues of the matrix dimensioned as the global size of the square matrix
3248 : : !! even if only a part of the eigenvalues is needed.
3249 : : !!
3250 : : !! SOURCE
3251 : :
3252 : 0 : subroutine compute_eigen_problem(processor, matrix, results, eigen, comm, istwf_k, &
3253 : : nev, use_gpu_elpa) ! Optional arguments
3254 : :
3255 : : !Arguments ------------------------------------
3256 : : class(slk_processor_t),intent(in) :: processor
3257 : : class(slkmat_dp_t),intent(inout) :: matrix
3258 : : class(slkmat_dp_t),intent(inout) :: results
3259 : : DOUBLE PRECISION,intent(inout) :: eigen(:)
3260 : : integer,intent(in) :: comm,istwf_k
3261 : : integer,optional,intent(in) :: nev
3262 : : integer,optional,intent(in) :: use_gpu_elpa
3263 : :
3264 : : #if defined(HAVE_LINALG_ELPA)
3265 : : !Local variables ------------------------------
3266 : : type(elpa_hdl_t) :: elpa_hdl
3267 : : integer :: nev__,use_gpu_elpa_
3268 : : !************************************************************************
3269 : :
3270 : : nev__ = matrix%size_global(1); if (present(nev)) nev__ = nev
3271 : : use_gpu_elpa_=0; if (present(use_gpu_elpa)) use_gpu_elpa_=use_gpu_elpa
3272 : :
3273 : : call elpa_func_allocate(elpa_hdl,gpu=use_gpu_elpa_)
3274 : : call elpa_func_set_matrix(elpa_hdl,matrix%size_global(1),matrix%size_blocs(1),nev__,&
3275 : : matrix%size_local(1),matrix%size_local(2))
3276 : : call elpa_func_get_communicators(elpa_hdl,processor%comm,processor%coords(1),processor%coords(2))
3277 : :
3278 : : if (istwf_k/=2) then
3279 : : call elpa_func_solve_evp_1stage(elpa_hdl,matrix%buffer_cplx,results%buffer_cplx,eigen,nev__)
3280 : : else
3281 : : call elpa_func_solve_evp_1stage(elpa_hdl,matrix%buffer_real,results%buffer_real,eigen,nev__)
3282 : : end if
3283 : :
3284 : : call elpa_func_deallocate(elpa_hdl)
3285 : :
3286 : :
3287 : : #elif defined(HAVE_LINALG_SLATE)
3288 : : !Local variables-------------------------------
3289 : : integer :: nev__,use_gpu_elpa_, info_slate
3290 : : ! *************************************************************************
3291 : :
3292 : : if (istwf_k /= 2) then
3293 : : call slate_zheev_c( &
3294 : : matrix%size_global(1), & ! n
3295 : : matrix%size_blocs(1), & ! nb (mb==nb required)
3296 : : processor%grid%dims(1), & ! nprow
3297 : : processor%grid%dims(2), & ! npcol
3298 : : processor%comm, & ! Fortran MPI comm handle
3299 : : matrix%size_local(1), & ! lda
3300 : : matrix%buffer_cplx, & ! a_data (destroyed on exit)
3301 : : results%size_local(1), & ! ldz
3302 : : results%buffer_cplx, & ! z_data (eigenvectors out)
3303 : : eigen, & ! w (eigenvalues out)
3304 : : nev__, & ! nev
3305 : : use_gpu_elpa_, & ! use_gpu (reuse existing flag)
3306 : : info_slate)
3307 : : ABI_CHECK(info_slate == 0, "slate_zheev_c failed")
3308 : : else
3309 : : call slate_dsyev_c( &
3310 : : matrix%size_global(1), & ! n
3311 : : matrix%size_blocs(1), & ! nb (mb==nb required)
3312 : : processor%grid%dims(1), & ! nprow
3313 : : processor%grid%dims(2), & ! npcol
3314 : : processor%comm, & ! Fortran MPI comm handle
3315 : : matrix%size_local(1), & ! lda
3316 : : matrix%buffer_real, & ! a_data (destroyed on exit)
3317 : : results%size_local(1), & ! ldz
3318 : : results%buffer_real, & ! z_data (eigenvectors out)
3319 : : eigen, & ! w (eigenvalues out)
3320 : : nev__, & ! nev
3321 : : use_gpu_elpa_, & ! use_gpu (reuse existing flag)
3322 : : info_slate)
3323 : : ABI_CHECK(info_slate == 0, "slate_dsyev_c failed")
3324 : : end if
3325 : :
3326 : :
3327 : : #elif defined(HAVE_LINALG_SCALAPACK)
3328 : : !Local variables-------------------------------
3329 : : integer :: LRWORK,LIWORK,LCWORK,INFO
3330 : : !character(len=500) :: msg
3331 : : integer , dimension(1) :: IWORK_tmp
3332 : : DOUBLE PRECISION, dimension(1) :: RWORK_tmp
3333 : : complex(dpc) , dimension(1) :: CWORK_tmp
3334 : : integer , allocatable :: IWORK(:)
3335 : : DOUBLE PRECISION, allocatable :: RWORK(:)
3336 : : complex(dpc) , allocatable :: CWORK(:)
3337 : : integer, allocatable :: ICLUSTR(:)
3338 : : integer, allocatable :: IFAIL(:)
3339 : : DOUBLE PRECISION, allocatable :: GAP(:)
3340 : : DOUBLE PRECISION :: ABSTOL,ORFAC
3341 : : integer, parameter :: IZERO=0
3342 : : integer :: M,NZ,ierr,TWORK_tmp(3),TWORK(3) ! IA,JA,IZ,JZ,
3343 : : integer :: nev__, il, iu, use_gpu_elpa_
3344 : : character(len=1) :: range
3345 : : ! *************************************************************************
3346 : :
3347 : : ABI_UNUSED(use_gpu_elpa) ! No GPU implementation if using scaLAPACK
3348 : : use_gpu_elpa_=0; if (present(use_gpu_elpa)) use_gpu_elpa_=use_gpu_elpa
3349 : : nev__ = matrix%size_global(1); range = "A"; il = 0; iu = 0
3350 : : if (present(nev)) then
3351 : : nev__ = nev; range = "I"; il = 1; iu = nev
3352 : : end if
3353 : :
3354 : : ! Initialisation
3355 : : INFO = 0
3356 : : ABSTOL = zero
3357 : : ORFAC = -1.D+0
3358 : :
3359 : : ! Allocation of the variables for the results of the calculations
3360 : : ABI_MALLOC(IFAIL,(matrix%size_global(2)))
3361 : : ABI_MALLOC(ICLUSTR,(2*processor%grid%dims(1)*processor%grid%dims(2)))
3362 : : ABI_MALLOC(GAP,(processor%grid%dims(1)*processor%grid%dims(2)))
3363 : :
3364 : : CWORK_tmp = (0.0_DP,0.0_DP)
3365 : : RWORK_tmp = 0.0_DP
3366 : : ! Get the size of the work arrays
3367 : : if (istwf_k/=2) then
3368 : : call PZHEEVX('V', range, 'U',&
3369 : : matrix%size_global(2),&
3370 : : matrix%buffer_cplx,1,1,matrix%desc, &
3371 : : ZERO,ZERO,il,iu,ABSTOL,&
3372 : : m,nz,eigen,ORFAC, &
3373 : : results%buffer_cplx,1,1,results%desc, &
3374 : : CWORK_tmp,-1,RWORK_tmp,-1,IWORK_tmp,-1,&
3375 : : IFAIL,ICLUSTR,GAP,INFO)
3376 : : else
3377 : : call PDSYEVX('V', range, 'U',&
3378 : : matrix%size_global(2),&
3379 : : matrix%buffer_real,1,1,matrix%desc, &
3380 : : ZERO,ZERO,il,iu,ABSTOL,&
3381 : : m,nz,eigen,ORFAC, &
3382 : : results%buffer_real,1,1,results%desc, &
3383 : : RWORK_tmp,-1,IWORK_tmp,-1,&
3384 : : IFAIL,ICLUSTR,GAP,INFO)
3385 : : end if
3386 : :
3387 : : if (INFO/=0) then
3388 : : ABI_ERROR(sjoin("Problem to compute workspace to use ScaLAPACK, INFO: ", itoa(INFO)))
3389 : : endif
3390 : : !write(std_out, *)"First call to compute workspace OK"
3391 : :
3392 : : TWORK_tmp(1) = IWORK_tmp(1)
3393 : : TWORK_tmp(2) = INT(RWORK_tmp(1))
3394 : : TWORK_tmp(3) = INT(real(CWORK_tmp(1)))
3395 : :
3396 : : ! Get the maximum of the size of the work arrays processor%comm
3397 : : call MPI_ALLREDUCE(TWORK_tmp,TWORK,3,MPI_integer,MPI_MAX,comm,ierr)
3398 : :
3399 : : LIWORK = TWORK(1)
3400 : : LRWORK = TWORK(2) + matrix%size_global(2) *(matrix%size_global(2)-1)
3401 : : LCWORK = TWORK(3)
3402 : :
3403 : : ! Allocation of the work arrays
3404 : : if (LIWORK>0) then
3405 : : ABI_MALLOC(IWORK,(LIWORK))
3406 : : IWORK(:) = 0
3407 : : else
3408 : : ABI_MALLOC(IWORK,(1))
3409 : : end if
3410 : : if (LRWORK>0) then
3411 : : ! This workspace scales with the number of processors but not always in a simple linear way.
3412 : : ! and the optimal LRWORK might be pretty big (~1 Gb) even for small systems.
3413 : : ABI_MALLOC(RWORK,(LRWORK))
3414 : : RWORK(:) = 0._dp
3415 : : else
3416 : : ABI_MALLOC(RWORK,(1))
3417 : : end if
3418 : : if (LCWORK>0) then
3419 : : ABI_MALLOC(CWORK,(LCWORK))
3420 : : CWORK(:) = (0._dp,0._dp)
3421 : : else
3422 : : ABI_MALLOC(CWORK,(1))
3423 : : end if
3424 : :
3425 : : ! prototype
3426 : : !call pzheevx(jobz, range, uplo, n, a, ia, ja, desca, vl, vu, il, iu, abstol, m, nz, w,
3427 : : ! orfac, z, iz, jz, descz, work, lwork, rwork, lrwork, iwork, liwork, ifail, iclustr, gap, info)
3428 : :
3429 : : ! Call the calculation routine
3430 : : if (istwf_k/=2) then
3431 : : ! write(std_out,*) 'I am using PZHEEVX'
3432 : : call PZHEEVX('V', range, 'U',&
3433 : : matrix%size_global(2),&
3434 : : matrix%buffer_cplx,1,1,matrix%desc, &
3435 : : ZERO,ZERO,il,iu,ABSTOL,&
3436 : : m,nz,eigen,ORFAC, &
3437 : : results%buffer_cplx,1,1,results%desc, &
3438 : : CWORK,LCWORK,RWORK,LRWORK,IWORK,LIWORK,&
3439 : : IFAIL,ICLUSTR,GAP,INFO)
3440 : : else
3441 : : ! write(std_out,*) ' I am using PDSYEVX'
3442 : : call PDSYEVX('V', range, 'U',&
3443 : : matrix%size_global(2),&
3444 : : matrix%buffer_real,1,1,matrix%desc, &
3445 : : ZERO,ZERO,il,iu,ABSTOL,&
3446 : : m,nz,eigen,ORFAC, &
3447 : : results%buffer_real,1,1,results%desc, &
3448 : : RWORK,LRWORK,IWORK,LIWORK,&
3449 : : IFAIL,ICLUSTR,GAP,INFO)
3450 : : endif
3451 : :
3452 : : ! MG: TODO: Recheck the computation of the workspace as I got INFO 2 with a 5x5x5 si supercell.
3453 : : if (INFO/=0) then
3454 : : ABI_ERROR(sjoin("Problem to compute eigenvalues and eigenvectors with ScaLAPACK, INFO:", itoa(INFO)))
3455 : : endif
3456 : :
3457 : : ABI_FREE(IFAIl)
3458 : : ABI_FREE(ICLUSTR)
3459 : : ABI_FREE(GAP)
3460 : : ABI_SFREE(IWORK)
3461 : : ABI_SFREE(RWORK)
3462 : : ABI_SFREE(CWORK)
3463 : : #endif
3464 : 0 : return
3465 : :
3466 : : end subroutine compute_eigen_problem
3467 : : !!***
3468 : :
3469 : : !----------------------------------------------------------------------
3470 : :
3471 : : !!****f* m_slk/solve_gevp_complex
3472 : : !! NAME
3473 : : !! solve_gevp_complex
3474 : : !!
3475 : : !! FUNCTION
3476 : : !! Calculation of eigenvalues and eigenvectors: A * X = lambda * B * X
3477 : : !! complex and real cases.
3478 : : !!
3479 : : !! INPUTS
3480 : : !! processor= descriptor of a processor
3481 : : !! matrix1= first ScaLAPACK matrix (matrix A)
3482 : : !! matrix2= second ScaLAPACK matrix (matrix B)
3483 : : !! comm= MPI communicator
3484 : : !! istwf_k= 2 if we have a real matrix else complex.
3485 : : !! [use_gpu_elpa]= Flag to activate the use of GPU (ELPA only)
3486 : : !!
3487 : : !! SIDE EFFECTS
3488 : : !! results= ScaLAPACK matrix coming out of the operation
3489 : : !! eigen= eigenvalues of the matrix
3490 : : !!
3491 : : !! SOURCE
3492 : :
3493 : : #ifdef HAVE_LINALG_ELPA
3494 : :
3495 : : subroutine solve_gevp_complex(na,nev,na_rows,na_cols,nblk,a,b,ev,z,tmp1,tmp2, &
3496 : : my_prow,my_pcol,np_rows,np_cols,sc_desc,comm,&
3497 : : use_gpu_elpa) ! Optional parameter
3498 : :
3499 : : !-Arguments
3500 : : integer,intent(in) :: na
3501 : : integer,intent(in) :: nev
3502 : : integer,intent(in) :: na_rows,na_cols
3503 : : integer,intent(in) :: nblk
3504 : : integer,intent(in) :: my_pcol,my_prow
3505 : : integer,intent(in) :: np_cols,np_rows
3506 : : integer,intent(in) :: sc_desc(9)
3507 : : integer,intent(in) :: comm
3508 : : integer,optional,intent(in) :: use_gpu_elpa
3509 : : real*8 :: ev(na)
3510 : : complex*16 :: a(na_rows,na_cols),b(na_rows,na_cols),z(na_rows,na_cols)
3511 : : complex*16 :: tmp1(na_rows,na_cols),tmp2(na_rows,na_cols)
3512 : : !-Local variables
3513 : : integer :: i, n_col, n_row, use_gpu_elpa_
3514 : : complex*16, parameter :: CZERO = (0.d0,0.d0), CONE = (1.d0,0.d0)
3515 : : type(elpa_hdl_t) :: elpa_hdl
3516 : : ! *************************************************************************
3517 : :
3518 : : use_gpu_elpa_=0
3519 : : #ifdef HAVE_LINALG_ELPA
3520 : : if (present(use_gpu_elpa)) use_gpu_elpa_=use_gpu_elpa
3521 : : #endif
3522 : :
3523 : : ! Allocate ELPA handle
3524 : : call elpa_func_allocate(elpa_hdl,blacs_ctx=sc_desc(CTXT_),gpu=use_gpu_elpa_)
3525 : : call elpa_func_set_matrix(elpa_hdl,na,nblk,nev,na_rows,na_cols)
3526 : : call elpa_func_get_communicators(elpa_hdl,comm,my_prow,my_pcol)
3527 : : call elpa_func_solve_gevp_2stage(elpa_hdl,a,b,z,ev,nev)
3528 : : call elpa_func_deallocate(elpa_hdl)
3529 : :
3530 : : end subroutine solve_gevp_complex
3531 : :
3532 : : !----------------------------------------------------------------------
3533 : :
3534 : : subroutine solve_gevp_real(na,nev,na_rows,na_cols,nblk,a,b,ev,z,tmp1,tmp2, &
3535 : : my_prow,my_pcol,np_rows,np_cols,sc_desc,comm, &
3536 : : use_gpu_elpa) ! Optional argument
3537 : :
3538 : : !-Arguments
3539 : : integer,intent(in) :: na
3540 : : integer,intent(in) :: nev
3541 : : integer,intent(in) :: na_rows,na_cols
3542 : : integer,intent(in) :: nblk
3543 : : integer,intent(in) :: my_pcol,my_prow
3544 : : integer,intent(in) :: np_cols,np_rows
3545 : : integer,intent(in) :: sc_desc(9)
3546 : : integer,intent(in) :: comm
3547 : : integer,optional,intent(in) :: use_gpu_elpa
3548 : : real*8 :: ev(na)
3549 : : real*8 :: a(na_rows,na_cols),b(na_rows,na_cols),z(na_rows,na_cols)
3550 : : real*8 :: tmp1(na_rows,na_cols),tmp2(na_rows,na_cols)
3551 : : !-Local variables
3552 : : integer :: i, n_col, n_row, use_gpu_elpa_
3553 : : type(elpa_hdl_t) :: elpa_hdl
3554 : : ! *************************************************************************
3555 : :
3556 : : use_gpu_elpa_=0
3557 : : #ifdef HAVE_LINALG_ELPA
3558 : : if (present(use_gpu_elpa)) use_gpu_elpa_=use_gpu_elpa
3559 : : #endif
3560 : :
3561 : : ! Allocate ELPA handle
3562 : : call elpa_func_allocate(elpa_hdl,blacs_ctx=sc_desc(CTXT_),gpu=use_gpu_elpa_)
3563 : : call elpa_func_set_matrix(elpa_hdl,na,nblk,nev,na_rows,na_cols)
3564 : : call elpa_func_get_communicators(elpa_hdl,comm,my_prow,my_pcol)
3565 : :
3566 : : !FIXME Need to figure out why generalized_eigenvectors doesn't work in this real case
3567 : : ! while it is fine with complex case
3568 : : if(.false.) then
3569 : : call elpa_func_solve_gevp_2stage(elpa_hdl,a,b,tmp1,ev,nev)
3570 : : else
3571 : : ! 1. Calculate Cholesky factorization of Matrix B = U**T * U
3572 : : ! and invert triangular matrix U
3573 : : call elpa_func_cholesky(elpa_hdl,b)
3574 : : call elpa_func_invert_triangular(elpa_hdl,b)
3575 : : ! 2. Calculate U**-T * A * U**-1
3576 : : ! 2a. tmp1 = U**-T * A
3577 : : call elpa_func_hermitian_multiply(elpa_hdl,'U','L',na,b,a,na_rows,na_cols,tmp1,na_rows,na_cols)
3578 : : ! 2b. tmp2 = tmp1**T
3579 : : call pdtran(na,na,1.d0,tmp1,1,1,sc_desc,0.d0,tmp2,1,1,sc_desc)
3580 : : ! 2c. A = U**-T * tmp2 ( = U**-T * Aorig * U**-1 )
3581 : : call elpa_func_hermitian_multiply(elpa_hdl,'U','U',na,b,tmp2,na_rows,na_cols,a,na_rows,na_cols)
3582 : : ! A is only set in the upper half, solve_evp_real needs a full matrix
3583 : : ! Set lower half from upper half
3584 : : call pdtran(na,na,1.d0,a,1,1,sc_desc,0.d0,tmp1,1,1,sc_desc)
3585 : : do i=1,na_cols
3586 : : ! Get global column corresponding to i and number of local rows up to
3587 : : ! and including the diagonal, these are unchanged in A
3588 : : n_col = indxl2g(i, nblk, my_pcol, 0, np_cols)
3589 : : n_row = numroc (n_col, nblk, my_prow, 0, np_rows)
3590 : : a(n_row+1:na_rows,i) = tmp1(n_row+1:na_rows,i)
3591 : : enddo
3592 : : ! 3. Calculate eigenvalues/eigenvectors of U**-T * A * U**-1
3593 : : ! Eigenvectors go to tmp1
3594 : : call elpa_func_solve_evp_1stage(elpa_hdl,a,tmp1,ev,nev)
3595 : : ! 4. Backtransform eigenvectors: Z = U**-1 * tmp1
3596 : : ! hermitian_multiply needs the transpose of U**-1, thus tmp2 = (U**-1)**T
3597 : : call pdtran(na,na,1.d0,b,1,1,sc_desc,0.d0,tmp2,1,1,sc_desc)
3598 : : call elpa_func_hermitian_multiply(elpa_hdl,'L','N',nev,tmp2,tmp1,na_rows,na_cols,z,na_rows,na_cols)
3599 : : end if
3600 : :
3601 : : call elpa_func_deallocate(elpa_hdl)
3602 : :
3603 : : end subroutine solve_gevp_real
3604 : : !!***
3605 : : #endif
3606 : :
3607 : : !----------------------------------------------------------------------
3608 : :
3609 : : !!****f* m_slk/compute_generalized_eigen_problem
3610 : : !! NAME
3611 : : !! compute_generalized_eigen_problem
3612 : : !!
3613 : : !! FUNCTION
3614 : : !! Calculation of eigenvalues and eigenvectors of the generalized eigenvalue problem: A * X = lambda * B X
3615 : : !! complex and real cases. B must be Hermitian (symmetric) positive definite.
3616 : : !! Backend: ELPA if available, else ScaLAPACK (PZHEGVX or PDSYGVX).
3617 : : !! The SLATE version is disabled (it does not work), SLATE builds use ScaLAPACK here.
3618 : : !!
3619 : : !! INPUTS
3620 : : !! processor= descriptor of a processor
3621 : : !! matrix1= A matrix
3622 : : !! matrix2= B matrix
3623 : : !! comm= MPI communicator
3624 : : !! istwf_k= 2 if we have a real matrix else complex.
3625 : : !! [nev]= Number of eigenvalues needed. Default: full set
3626 : : !! [use_gpu_elpa]= Flag to activate the use of GPU (ELPA only)
3627 : : !!
3628 : : !! OUTPUT
3629 : : !! results= ScaLAPACK matrix coming out of the operation (global dimensions must be equal to matrix
3630 : : !! even if only a part of the eigenvectors is needed.
3631 : : !! eigen= eigenvalues of the matrix dimensioned as the global size of the square matrix
3632 : : !! even if only a part of the eigenvalues is needed.
3633 : : !!
3634 : : !! SOURCE
3635 : :
3636 : 0 : subroutine compute_generalized_eigen_problem(processor,matrix1,matrix2,results,eigen,comm,istwf_k,&
3637 : : nev,use_gpu_elpa) ! Optional arguments
3638 : :
3639 : : !Arguments ------------------------------------
3640 : : class(slk_processor_t),intent(in) :: processor
3641 : : class(slkmat_dp_t),intent(inout) :: matrix1,matrix2
3642 : : class(slkmat_dp_t),intent(inout) :: results
3643 : : DOUBLE PRECISION,intent(inout) :: eigen(:)
3644 : : integer,intent(in) :: comm,istwf_k
3645 : : integer,optional,intent(in) :: nev
3646 : : integer,optional,intent(in) :: use_gpu_elpa
3647 : : #ifdef HAVE_LINALG_ELPA
3648 : : !Local
3649 : : type(slkmat_dp_t) :: tmp1, tmp2
3650 : : integer :: i,n_col, n_row, nev__,use_gpu_elpa__
3651 : :
3652 : : nev__ = matrix1%size_global(2); if (present(nev)) nev__ = nev
3653 : : use_gpu_elpa__ = 0; if (present(use_gpu_elpa)) use_gpu_elpa__ = use_gpu_elpa
3654 : :
3655 : : call tmp1%init(matrix1%size_global(1),matrix1%size_global(2),processor,istwf_k)
3656 : : call tmp2%init(matrix1%size_global(1),matrix1%size_global(2),processor,istwf_k)
3657 : :
3658 : : if (istwf_k/=2) then
3659 : : call solve_gevp_complex(matrix1%size_global(1), nev__, &
3660 : : matrix1%size_local(1),matrix1%size_local(2),matrix1%size_blocs(1), &
3661 : : matrix1%buffer_cplx,matrix2%buffer_cplx,eigen,results%buffer_cplx, &
3662 : : tmp1%buffer_cplx,tmp2%buffer_cplx, &
3663 : : processor%coords(1),processor%coords(2), &
3664 : : processor%grid%dims(1),processor%grid%dims(2), &
3665 : : matrix1%desc,processor%comm,use_gpu_elpa=use_gpu_elpa__)
3666 : : else
3667 : : call solve_gevp_real(matrix1%size_global(1), nev__, &
3668 : : matrix1%size_local(1),matrix1%size_local(2),matrix1%size_blocs(1), &
3669 : : matrix1%buffer_real,matrix2%buffer_real,eigen,results%buffer_real, &
3670 : : tmp1%buffer_real,tmp2%buffer_real, &
3671 : : processor%coords(1),processor%coords(2), &
3672 : : processor%grid%dims(1),processor%grid%dims(2), &
3673 : : matrix1%desc,processor%comm,use_gpu_elpa=use_gpu_elpa__)
3674 : : end if
3675 : : call tmp1%free()
3676 : : call tmp2%free()
3677 : :
3678 : :
3679 : : !#elif defined HAVE_LINALG_SLATE
3680 : : !!FIXME Doesn't work. slate_zheev/syev is fine though so we fall back to scaLAPACK instead
3681 : : !!Local variables-------------------------------
3682 : : ! integer :: nev__, use_gpu_elpa_, info_slate
3683 : : !! *************************************************************************
3684 : : !
3685 : : ! nev__ = matrix1%size_global(2); if (present(nev)) nev__ = nev
3686 : : ! use_gpu_elpa__ = 0; if (present(use_gpu_elpa)) use_gpu_elpa__ = use_gpu_elpa
3687 : : !
3688 : : ! if (istwf_k /= 2) then
3689 : : ! call slate_zhegv_c( &
3690 : : ! matrix1%size_global(1), & ! n
3691 : : ! matrix1%size_blocs(1), & ! nb (mb==nb required)
3692 : : ! processor%grid%dims(1), & ! nprow
3693 : : ! processor%grid%dims(2), & ! npcol
3694 : : ! processor%comm, & ! Fortran MPI comm handle
3695 : : ! matrix1%size_local(1), & ! lda
3696 : : ! matrix1%buffer_cplx, & ! a_data (destroyed on exit)
3697 : : ! matrix2%size_local(1), & ! ldb
3698 : : ! matrix2%buffer_cplx, & ! b_data (destroyed on exit)
3699 : : ! results%size_local(1), & ! ldz
3700 : : ! results%buffer_cplx, & ! z_data (eigenvectors out)
3701 : : ! eigen, & ! w (eigenvalues out)
3702 : : ! nev__, & ! nev
3703 : : ! use_gpu_elpa_, & ! use_gpu (reuse existing flag)
3704 : : ! info_slate)
3705 : : ! ABI_CHECK(info_slate == 0, "slate_zhgev_c failed")
3706 : : ! else
3707 : : ! call slate_dsygv_c( &
3708 : : ! matrix1%size_global(1), & ! n
3709 : : ! matrix1%size_blocs(1), & ! nb (mb==nb required)
3710 : : ! processor%grid%dims(1), & ! nprow
3711 : : ! processor%grid%dims(2), & ! npcol
3712 : : ! processor%comm, & ! Fortran MPI comm handle
3713 : : ! matrix1%size_local(1), & ! lda
3714 : : ! matrix1%buffer_real, & ! a_data (destroyed on exit)
3715 : : ! matrix2%size_local(1), & ! ldb
3716 : : ! matrix2%buffer_real, & ! b_data (destroyed on exit)
3717 : : ! results%size_local(1), & ! ldz
3718 : : ! results%buffer_real, & ! z_data (eigenvectors out)
3719 : : ! eigen, & ! w (eigenvalues out)
3720 : : ! nev__, & ! nev
3721 : : ! use_gpu_elpa_, & ! use_gpu (reuse existing flag)
3722 : : ! info_slate)
3723 : : ! ABI_CHECK(info_slate == 0, "slate_dsygv_c failed")
3724 : : ! end if
3725 : :
3726 : :
3727 : : #elif defined(HAVE_LINALG_SCALAPACK)
3728 : : !Local variables-------------------------------
3729 : : integer :: LRWORK,LIWORK,LCWORK,INFO
3730 : : !character(len=500) :: msg
3731 : : integer , dimension(1) :: IWORK_tmp
3732 : : DOUBLE PRECISION, dimension(1) :: RWORK_tmp
3733 : : complex(dpc) , dimension(1) :: CWORK_tmp
3734 : :
3735 : : integer , allocatable :: IWORK(:)
3736 : : DOUBLE PRECISION, allocatable :: RWORK(:)
3737 : : complex(dpc) , allocatable :: CWORK(:)
3738 : : integer, allocatable :: ICLUSTR(:)
3739 : : integer, allocatable :: IFAIL(:)
3740 : : DOUBLE PRECISION, allocatable :: GAP(:)
3741 : : DOUBLE PRECISION :: ABSTOL,ORFAC
3742 : : integer , parameter :: IZERO=0
3743 : : integer :: M,NZ,ierr,TWORK_tmp(3),TWORK(3) ! IA,JA,IZ,JZ,
3744 : : character(len=1) :: range
3745 : : integer :: nev__, il, iu
3746 : : ! *************************************************************************
3747 : :
3748 : : ABI_UNUSED(use_gpu_elpa) ! No GPU implementation is using scaLAPACK
3749 : : nev__ = matrix1%size_global(2); range = "A"; il = 0; iu = 0
3750 : : if (present(nev)) then
3751 : : nev__ = nev; range = "I"; il = 1; iu = nev
3752 : : end if
3753 : :
3754 : : ! Initialisation
3755 : : INFO = 0
3756 : : ABSTOL = zero
3757 : : ORFAC = -1.D+0
3758 : :
3759 : : ! Allocate the arrays for the results of the calculation
3760 : : ABI_MALLOC(IFAIL ,(matrix1%size_global(2)))
3761 : : ABI_MALLOC(ICLUSTR,(2*processor%grid%dims(1)*processor%grid%dims(2)))
3762 : : ABI_MALLOC(GAP ,( processor%grid%dims(1)*processor%grid%dims(2)))
3763 : :
3764 : : CWORK_tmp = (0.0_DP,0.0_DP)
3765 : : RWORK_tmp = 0.0_DP
3766 : : ! Get the size of the work arrays
3767 : : if (istwf_k /= 2) then
3768 : : call PZHEGVX(1, 'V', range, 'U',&
3769 : : matrix1%size_global(2),&
3770 : : matrix1%buffer_cplx,1,1,matrix1%desc, &
3771 : : matrix2%buffer_cplx,1,1,matrix2%desc, &
3772 : : ZERO,ZERO,il,iu,ABSTOL,&
3773 : : m,nz,eigen,ORFAC, &
3774 : : results%buffer_cplx,1,1,results%desc, &
3775 : : CWORK_tmp,-1,RWORK_tmp,-1,IWORK_tmp,-1,&
3776 : : IFAIL,ICLUSTR,GAP,INFO)
3777 : : else
3778 : : call PDSYGVX(1,'V',range,'U',&
3779 : : matrix1%size_global(2),&
3780 : : matrix1%buffer_real,1,1,matrix1%desc, &
3781 : : matrix2%buffer_real,1,1,matrix2%desc, &
3782 : : ZERO,ZERO,il,iu,ABSTOL,&
3783 : : m,nz,eigen,ORFAC, &
3784 : : results%buffer_real,1,1,results%desc, &
3785 : : RWORK_tmp,-1,IWORK_tmp,-1,&
3786 : : IFAIL,ICLUSTR,GAP,INFO)
3787 : : endif
3788 : :
3789 : : if (INFO/=0) then
3790 : : ABI_ERROR(sjoin("Problem to compute workspace to use ScaLAPACK, INFO=",itoa(INFO)))
3791 : : endif
3792 : :
3793 : : TWORK_tmp(1) = IWORK_tmp(1)
3794 : : TWORK_tmp(2) = INT(RWORK_tmp(1)) + matrix1%size_global(2) *(matrix1%size_global(2)-1)
3795 : : TWORK_tmp(3) = INT(real(CWORK_tmp(1)))
3796 : :
3797 : : ! Get the maximum of sizes of the work arrays processor%comm
3798 : : call MPI_ALLREDUCE(TWORK_tmp,TWORK,3,MPI_integer,MPI_MAX,comm,ierr)
3799 : :
3800 : : LIWORK = TWORK(1)
3801 : : LRWORK = TWORK(2)
3802 : : LCWORK = TWORK(3)
3803 : :
3804 : : ! Allocate the work arrays
3805 : : if (LIWORK>0) then
3806 : : ABI_MALLOC(IWORK,(LIWORK))
3807 : : IWORK(:) = 0
3808 : : else
3809 : : ABI_MALLOC(IWORK,(1))
3810 : : end if
3811 : : if (LRWORK>0) then
3812 : : ABI_MALLOC(RWORK,(LRWORK))
3813 : : RWORK(:) = 0._dp
3814 : : else
3815 : : ABI_MALLOC(RWORK,(1))
3816 : : end if
3817 : : if (LCWORK>0) then
3818 : : ABI_MALLOC(CWORK,(LCWORK))
3819 : : CWORK(:) = (0._dp,0._dp)
3820 : : else
3821 : : ABI_MALLOC(CWORK,(1))
3822 : : end if
3823 : :
3824 : : ! Call the calculation routine
3825 : : if (istwf_k/=2) then
3826 : : ! write(std_out,*) 'I am using PZHEGVX'
3827 : : call PZHEGVX(1,'V',range,'U',&
3828 : : matrix1%size_global(2),&
3829 : : matrix1%buffer_cplx,1,1,matrix1%desc, &
3830 : : matrix2%buffer_cplx,1,1,matrix2%desc, &
3831 : : ZERO,ZERO,il,iu,ABSTOL,&
3832 : : m,nz,eigen,ORFAC, &
3833 : : results%buffer_cplx,1,1,results%desc, &
3834 : : CWORK,LCWORK,RWORK,LRWORK,IWORK,LIWORK,&
3835 : : IFAIL,ICLUSTR,GAP,INFO)
3836 : : else
3837 : : ! write(std_out,*) 'I am using PDSYGVX'
3838 : : call PDSYGVX(1,'V',range,'U',&
3839 : : matrix1%size_global(2),&
3840 : : matrix1%buffer_real,1,1,matrix1%desc, &
3841 : : matrix2%buffer_real,1,1,matrix2%desc, &
3842 : : ZERO,ZERO,il,iu,ABSTOL,&
3843 : : m,nz,eigen,ORFAC, &
3844 : : results%buffer_real,1,1,results%desc, &
3845 : : RWORK,LRWORK,IWORK,LIWORK,&
3846 : : IFAIL,ICLUSTR,GAP,INFO)
3847 : : endif
3848 : :
3849 : : if (INFO/=0) then
3850 : : ABI_ERROR(sjoin("Problem to compute eigen problem with ScaLAPACK, INFO=", itoa(INFO)))
3851 : : endif
3852 : :
3853 : : ABI_FREE(IFAIl)
3854 : : ABI_FREE(ICLUSTR)
3855 : : ABI_FREE(GAP)
3856 : : ABI_SFREE(IWORK)
3857 : : ABI_SFREE(RWORK)
3858 : : ABI_SFREE(CWORK)
3859 : : #endif
3860 : 0 : return
3861 : :
3862 : : end subroutine compute_generalized_eigen_problem
3863 : : !!***
3864 : :
3865 : : !----------------------------------------------------------------------
3866 : :
3867 : : !!****f* m_slk/compute_eigen1
3868 : : !! NAME
3869 : : !! compute_eigen1
3870 : : !!
3871 : : !! FUNCTION
3872 : : !! Calculation of eigenvalues and eigenvectors of a Hermitian (real symmetric) matrix. complex and real cases.
3873 : : !! The global matrix, replicated on all the processes, is distributed, diagonalized with compute_eigen_problem
3874 : : !! and the eigenvectors are gathered on all the processes.
3875 : : !!
3876 : : !! INPUTS
3877 : : !! comm= MPI communicator of the processes in the grid
3878 : : !! processor= descriptor of a processor
3879 : : !! cplex=1 if matrix is real, 2 if complex. Must be consistent with istwf_k.
3880 : : !! nbli_global number of lines
3881 : : !! nbco_global number of columns
3882 : : !! istwf_k= 2 if we have a real matrix else complex.
3883 : : !! [use_gpu_elpa]= Flag to activate the use of GPU (ELPA only)
3884 : : !!
3885 : : !! SIDE EFFECTS
3886 : : !! matrix(cplex*nbli_global, nbco_global)=
3887 : : !! input: the global matrix (real/imag pairs if cplex=2). Only the upper triangle is used.
3888 : : !! With ELPA or SLATE, the lower triangle is overwritten with the conjugate of the upper triangle.
3889 : : !! output: the eigenvectors (columns), on all the processes.
3890 : : !! vector(nbli_global)= eigenvalues in ascending order.
3891 : : !!
3892 : : !! SOURCE
3893 : :
3894 : 0 : subroutine compute_eigen1(comm,processor,cplex,nbli_global,nbco_global,matrix,vector,istwf_k,&
3895 : : use_gpu_elpa) ! Optional argument
3896 : :
3897 : : !Arguments ------------------------------------
3898 : : !scalars
3899 : : integer,intent(in) :: comm
3900 : : integer,intent(in) :: cplex,nbli_global,nbco_global
3901 : : integer,intent(in) :: istwf_k
3902 : : class(slk_processor_t),intent(in) :: processor
3903 : : integer,intent(in),optional :: use_gpu_elpa
3904 : : !arrays
3905 : : real(dp),intent(inout) :: matrix(cplex*nbli_global,nbco_global)
3906 : : real(dp),intent(inout) :: vector(:)
3907 : :
3908 : : !Local variables-------------------------------
3909 : : #if defined(HAVE_LINALG_ELPA) || defined(HAVE_LINALG_SLATE)
3910 : : integer :: i,j
3911 : : #endif
3912 : : integer :: ierr,use_gpu_elpa_
3913 [ # # # # : 0 : type(slkmat_dp_t) :: sca_matrix1
# # ]
3914 [ # # # # : 0 : type(slkmat_dp_t) :: sca_matrix2
# # ]
3915 : 0 : real(dp),allocatable :: r_tmp_evec(:,:)
3916 : 0 : complex(dpc),allocatable :: z_tmp_evec(:,:)
3917 : : ! *************************************************************************
3918 : :
3919 : 0 : use_gpu_elpa_=0
3920 : : #if defined(HAVE_LINALG_ELPA) || defined(HAVE_LINALG_SLATE)
3921 : : if (present(use_gpu_elpa)) use_gpu_elpa_=use_gpu_elpa
3922 : : #endif
3923 : :
3924 : : ! ================================
3925 : : ! INITIALISATION SCALAPACK MATRIX
3926 : : ! ================================
3927 : 0 : call sca_matrix1%init(nbli_global,nbco_global,processor,istwf_k)
3928 : 0 : call sca_matrix2%init(nbli_global,nbco_global,processor,istwf_k)
3929 : :
3930 : : ! ==============================
3931 : : ! FILLING SCALAPACK MATRIX
3932 : : ! ==============================
3933 [ # # ]: 0 : if ( istwf_k /= 2 ) then
3934 [ # # ]: 0 : ABI_CHECK_IEQ(cplex, 2, "cplex != 2")
3935 [ # # # # : 0 : ABI_MALLOC(z_tmp_evec,(nbli_global,nbco_global))
# # # # #
# # # # #
# # ]
3936 [ # # # # ]: 0 : z_tmp_evec=cmplx(0._DP,0._DP)
3937 : : #if defined(HAVE_LINALG_ELPA) || defined(HAVE_LINALG_SLATE)
3938 : : ! The full matrix must be set (not only one half like in scalapack).
3939 : : do j=1,nbco_global
3940 : : do i=j+1,nbli_global
3941 : : matrix(2*(i-1)+1,j) = matrix(2*(j-1)+1,i)
3942 : : matrix(2*(i-1)+2,j) = -matrix(2*(j-1)+2,i)
3943 : : end do
3944 : : end do
3945 : : #endif
3946 : 0 : call sca_matrix1%from_complex_glob(matrix,istwf_k)
3947 : : else
3948 [ # # ]: 0 : ABI_CHECK_IEQ(cplex, 1, "cplex != 2")
3949 [ # # # # : 0 : ABI_MALLOC(r_tmp_evec,(nbli_global,nbco_global))
# # # # #
# # # # #
# # ]
3950 [ # # # # ]: 0 : r_tmp_evec(:,:)=0._DP
3951 : : #if defined(HAVE_LINALG_ELPA) || defined(HAVE_LINALG_SLATE)
3952 : : ! The full matrix must be set (not only one half like in scalapack).
3953 : : do j=1,nbco_global
3954 : : do i=j+1,nbli_global
3955 : : matrix(i,j) = matrix(j,i)
3956 : : end do
3957 : : end do
3958 : : #endif
3959 : 0 : call sca_matrix1%from_real_glob(matrix, istwf_k)
3960 : : endif
3961 : :
3962 : : ! ================================
3963 : : ! COMPUTE EIGEN VALUES AND VECTORS : A * X = lambda * X
3964 : : ! ================================
3965 : : call compute_eigen_problem(processor,sca_matrix1, sca_matrix2,vector, comm,istwf_k, &
3966 : 0 : use_gpu_elpa=use_gpu_elpa_)
3967 : :
3968 : : ! ==============================
3969 : : ! CONCATENATE EIGEN VECTORS
3970 : : ! ==============================
3971 : : #ifdef HAVE_MPI
3972 [ # # ]: 0 : if (istwf_k /= 2) then
3973 : 0 : call sca_matrix2%to_complex_glob(z_tmp_evec, istwf_k)
3974 : 0 : call MPI_ALLREDUCE(z_tmp_evec, matrix, nbli_global*nbco_global, MPI_DOUBLE_complex, MPI_SUM,comm,ierr)
3975 : : else
3976 : 0 : call sca_matrix2%to_real_glob(r_tmp_evec, istwf_k)
3977 : 0 : call MPI_ALLREDUCE(r_tmp_evec, matrix, nbli_global*nbco_global, MPI_DOUBLE_PRECISION, MPI_SUM,comm,ierr)
3978 : : endif
3979 : : #endif
3980 : :
3981 : : ! ====================================
3982 : : ! DESTRUCTION SCALAPACK AND TMP MATRICES
3983 : : ! ====================================
3984 : 0 : call sca_matrix1%free()
3985 : 0 : call sca_matrix2%free()
3986 : :
3987 [ # # ]: 0 : ABI_SFREE(z_tmp_evec)
3988 [ # # ]: 0 : ABI_SFREE(r_tmp_evec)
3989 : :
3990 : : #ifndef HAVE_LINALG_ELPA
3991 : : ABI_UNUSED(use_gpu_elpa)
3992 : : #endif
3993 : :
3994 [ # # # # : 0 : end subroutine compute_eigen1
# # # # #
# # # ]
3995 : : !!***
3996 : :
3997 : : !----------------------------------------------------------------------
3998 : :
3999 : : !!****f* m_slk/compute_eigen2
4000 : : !! NAME
4001 : : !! compute_eigen2
4002 : : !!
4003 : : !! FUNCTION
4004 : : !! Calculation of eigenvalues and eigenvectors: A * X = lambda * B * X
4005 : : !! complex and real cases.
4006 : : !! The global matrices, replicated on all the processes, are distributed, the problem is solved with
4007 : : !! compute_generalized_eigen_problem and the eigenvectors are gathered on all the processes.
4008 : : !!
4009 : : !! INPUTS
4010 : : !! comm= MPI communicator of the processes in the grid
4011 : : !! processor= descriptor of a processor
4012 : : !! cplex=1 if matrix is real, 2 if complex. Must be consistent with istwf_k.
4013 : : !! nbli_global number of lines
4014 : : !! nbco_global number of columns
4015 : : !! istwf_k= 2 if we have a real matrix else complex.
4016 : : !! [use_gpu_elpa]= Flag to activate the use of GPU (ELPA only)
4017 : : !!
4018 : : !! SIDE EFFECTS
4019 : : !! matrix1(cplex*nbli_global, nbco_global)=
4020 : : !! input: the global matrix A (real/imag pairs if cplex=2). Only the upper triangle is used.
4021 : : !! output: the eigenvectors (columns), on all the processes.
4022 : : !! matrix2(cplex*nbli_global, nbco_global)= the global matrix B (Hermitian positive definite).
4023 : : !! Only the upper triangle is used.
4024 : : !! With ELPA or SLATE, the lower triangles of matrix1 and matrix2 are overwritten with the conjugate of the upper ones.
4025 : : !! vector(nbli_global)= eigenvalues in ascending order.
4026 : : !!
4027 : : !! SOURCE
4028 : :
4029 : 0 : subroutine compute_eigen2(comm,processor,cplex,nbli_global,nbco_global,matrix1,matrix2,vector,istwf_k, &
4030 : : use_gpu_elpa) ! Optional argument
4031 : :
4032 : : !Arguments ------------------------------------
4033 : : !scalars
4034 : : integer,intent(in) :: cplex,nbli_global,nbco_global
4035 : : integer,intent(in) :: comm
4036 : : integer,intent(in) :: istwf_k
4037 : : class(slk_processor_t),intent(in) :: processor
4038 : : integer,optional,intent(in) :: use_gpu_elpa
4039 : : !arrays
4040 : : real(dp),intent(inout) :: matrix1(cplex*nbli_global,nbco_global)
4041 : : real(dp),intent(inout) :: matrix2(cplex*nbli_global,nbco_global)
4042 : : real(dp),intent(inout) :: vector(:)
4043 : :
4044 : : !Local variables-------------------------------
4045 : : #if defined(HAVE_LINALG_ELPA) || defined(HAVE_LINALG_SLATE)
4046 : : integer :: i,j
4047 : : #endif
4048 : : integer :: ierr,use_gpu_elpa_
4049 [ # # # # : 0 : type(slkmat_dp_t) :: sca_matrix1, sca_matrix2, sca_matrix3
# # # # #
# # # # #
# # # # ]
4050 : 0 : real(dp),allocatable :: r_tmp_evec(:,:)
4051 : 0 : complex(dpc),allocatable :: z_tmp_evec(:,:)
4052 : : ! *************************************************************************
4053 : :
4054 : 0 : use_gpu_elpa_=0
4055 : : #if defined HAVE_LINALG_ELPA
4056 : : if (present(use_gpu_elpa)) use_gpu_elpa_=use_gpu_elpa
4057 : : #endif
4058 : :
4059 : : ! ================================
4060 : : ! INITIALISATION SCALAPACK MATRIX
4061 : : ! ================================
4062 : 0 : call sca_matrix1%init(nbli_global,nbco_global,processor,istwf_k)
4063 : 0 : call sca_matrix2%init(nbli_global,nbco_global,processor,istwf_k)
4064 : 0 : call sca_matrix3%init(nbli_global,nbco_global,processor,istwf_k)
4065 : :
4066 : : ! ==============================
4067 : : ! FILLING SCALAPACK MATRIX
4068 : : ! ==============================
4069 [ # # ]: 0 : if ( istwf_k /= 2 ) then
4070 [ # # ]: 0 : ABI_CHECK_IEQ(cplex, 2, "cplex != 2")
4071 [ # # # # : 0 : ABI_MALLOC(z_tmp_evec,(nbli_global,nbco_global))
# # # # #
# # # # #
# # ]
4072 [ # # # # ]: 0 : z_tmp_evec=cmplx(0._DP,0._DP)
4073 : : #if defined(HAVE_LINALG_ELPA) || defined(HAVE_LINALG_SLATE)
4074 : : ! The full matrix must be set (not only one half like in scalapack).
4075 : : do j=1,nbco_global
4076 : : do i=j+1,nbli_global
4077 : : matrix1(2*(i-1)+1,j) = matrix1(2*(j-1)+1,i)
4078 : : matrix1(2*(i-1)+2,j) = -matrix1(2*(j-1)+2,i)
4079 : : matrix2(2*(i-1)+1,j) = matrix2(2*(j-1)+1,i)
4080 : : matrix2(2*(i-1)+2,j) = -matrix2(2*(j-1)+2,i)
4081 : : end do
4082 : : end do
4083 : : #endif
4084 : 0 : call sca_matrix1%from_complex_glob(matrix1, istwf_k)
4085 : 0 : call sca_matrix2%from_complex_glob(matrix2, istwf_k)
4086 : : else
4087 [ # # ]: 0 : ABI_CHECK_IEQ(cplex, 1, "cplex != 1")
4088 [ # # # # : 0 : ABI_MALLOC(r_tmp_evec,(nbli_global,nbco_global))
# # # # #
# # # # #
# # ]
4089 [ # # # # ]: 0 : r_tmp_evec(:,:)=0._DP
4090 : : #if defined(HAVE_LINALG_ELPA) || defined(HAVE_LINALG_SLATE)
4091 : : ! The full matrix must be set (not only one half like in scalapack).
4092 : : do j=1,nbco_global
4093 : : do i=j+1,nbli_global
4094 : : matrix1(i,j) = matrix1(j,i)
4095 : : matrix2(i,j) = matrix2(j,i)
4096 : : end do
4097 : : end do
4098 : : #endif
4099 : 0 : call sca_matrix1%from_real_glob(matrix1,istwf_k)
4100 : 0 : call sca_matrix2%from_real_glob(matrix2,istwf_k)
4101 : : endif
4102 : :
4103 : : ! ================================
4104 : : ! COMPUTE EIGEN VALUES AND VECTORS : A * X = lambda * B * X
4105 : : ! ================================
4106 : : call compute_generalized_eigen_problem(processor,sca_matrix1,sca_matrix2,&
4107 : 0 : sca_matrix3,vector,comm,istwf_k,use_gpu_elpa=use_gpu_elpa_)
4108 : :
4109 : : ! ==============================
4110 : : ! CONCATENATE EIGEN VECTORS
4111 : : ! ==============================
4112 : : #ifdef HAVE_MPI
4113 [ # # ]: 0 : if ( istwf_k /= 2 ) then
4114 : 0 : call sca_matrix3%to_complex_glob(z_tmp_evec,istwf_k)
4115 : 0 : call MPI_ALLREDUCE(z_tmp_evec, matrix1, nbli_global*nbco_global, MPI_DOUBLE_complex, MPI_SUM,comm,ierr)
4116 [ # # ]: 0 : ABI_FREE(z_tmp_evec)
4117 : : else
4118 : 0 : call sca_matrix3%to_real_glob(r_tmp_evec, istwf_k)
4119 : 0 : call MPI_ALLREDUCE(r_tmp_evec, matrix1, nbli_global*nbco_global, MPI_DOUBLE_PRECISION, MPI_SUM,comm,ierr)
4120 [ # # ]: 0 : ABI_FREE(r_tmp_evec)
4121 : : endif
4122 : : #endif
4123 : :
4124 : : ! ====================================
4125 : : ! DESTRUCTION SCALAPACK AND TMP MATRICES
4126 : : ! ====================================
4127 : 0 : call sca_matrix1%free()
4128 : 0 : call sca_matrix2%free()
4129 : 0 : call sca_matrix3%free()
4130 : :
4131 : : #ifndef HAVE_LINALG_ELPA
4132 : : ABI_UNUSED(use_gpu_elpa)
4133 : : #endif
4134 : :
4135 [ # # # # : 0 : end subroutine compute_eigen2
# # # # #
# # # # #
# # ]
4136 : : !!***
4137 : :
4138 : : !----------------------------------------------------------------------
4139 : :
4140 : : !!****f* m_slk/slkmat_dp_heev
4141 : : !! NAME
4142 : : !! slkmat_dp_heev
4143 : : !!
4144 : : !! FUNCTION
4145 : : !! slkmat_dp_heev computes selected eigenvalues and, optionally, eigenvectors of an Hermitian matrix A.
4146 : : !! A * X = lambda * X
4147 : : !!
4148 : : !! INPUTS
4149 : : !! JOBZ (global input) CHARACTER*1
4150 : : !! Specifies whether or not to compute the eigenvectors:
4151 : : !! = "N": Compute eigenvalues only.
4152 : : !! = "V": Compute eigenvalues and eigenvectors.
4153 : : !! UPLO (global input) CHARACTER*1
4154 : : !! Specifies whether the upper or lower triangular part of the symmetric matrix A is stored:
4155 : : !! = "U": Upper triangular
4156 : : !! = "L": Lower triangular
4157 : : !!
4158 : : !! mat=The object storing the local buffer in DOUBLE PRECISION, the array descriptor, the PBLAS context.
4159 : : !! Only complex matrices (buffer_cplx) are supported.
4160 : : !! vec=The distributed eigenvectors. Not referenced if JOBZ="N"
4161 : : !! [mat_size]= Order N of the (sub)matrix. Default: mat%size_global(2)
4162 : : !! [ija(2)]= Global row and column indices of the first entry of sub(A) in mat. Default: [1, 1]
4163 : : !! [ijz(2)]= Global row and column indices of the first entry of sub(Z) in vec. Default: [1, 1]
4164 : : !!
4165 : : !! OUTPUT
4166 : : !! W (global output) array, dimension (N) where N is the rank of the global matrix.
4167 : : !! On normal exit, the first M entries contain the selected eigenvalues in ascending order.
4168 : : !!
4169 : : !! SIDE EFFECTS
4170 : : !! If JOBZ="V", the local buffer vec%buffer_cplx will contain part of the distributed eigenvectors.
4171 : : !! On exit, the lower triangle (if UPLO='L') or the upper triangle (if UPLO='U') of A, including the diagonal, is destroyed.
4172 : : !!
4173 : : !! SOURCE
4174 : :
4175 : 0 : subroutine slkmat_dp_heev(mat, jobz, uplo, vec, w, &
4176 : : mat_size, ija, ijz) ! Optional
4177 : :
4178 : : !Arguments ------------------------------------
4179 : : !scalars
4180 : : class(slkmat_dp_t),intent(inout) :: mat
4181 : : character(len=*),intent(in) :: jobz, uplo
4182 : : class(slkmat_dp_t),intent(inout) :: vec
4183 : : !arrays
4184 : : real(dp),intent(out) :: w(:)
4185 : : integer,optional,intent(in) :: mat_size, ija(2), ijz(2)
4186 : :
4187 : : #ifdef HAVE_LINALG_SCALAPACK
4188 : : !Local variables ------------------------------
4189 : : !scalars
4190 : : integer :: lwork, lrwork, info, nn
4191 : : !character(len=500) :: msg
4192 : : !arrays
4193 : : integer :: ija__(2), ijz__(2)
4194 : : real(dp),allocatable :: rwork_dp(:)
4195 : : complex(dp),allocatable :: work_dp(:)
4196 : : !************************************************************************
4197 : :
4198 : : ABI_CHECK(allocated(mat%buffer_cplx), "buffer_cplx not allocated")
4199 : :
4200 : : nn = mat%size_global(2); if (present(mat_size)) nn = mat_size
4201 : : ija__ = [1, 1]; if (present(ija)) ija__ = ija
4202 : : ijz__ = [1, 1]; if (present(ijz)) ijz__ = ijz
4203 : :
4204 : : ! Get optimal size of workspace.
4205 : : lwork = - 1; lrwork = -1
4206 : : ABI_MALLOC(work_dp, (1))
4207 : : ABI_MALLOC(rwork_dp, (1))
4208 : :
4209 : : !call pzheev(jobz, uplo, n, a, ia, ja, desca, w, z, iz, jz, descz, work, lwork, rwork, lrwork, info)
4210 : :
4211 : : call PZHEEV(jobz, uplo, nn, mat%buffer_cplx, ija__(1), ija__(2), mat%desc, &
4212 : : w, vec%buffer_cplx, ijz__(1), ijz__(2), vec%desc, work_dp, lwork, rwork_dp, lrwork, info)
4213 : : ABI_CHECK(info == 0, sjoin("Error in the calculation of the workspace size, info:", itoa(info)))
4214 : :
4215 : : lwork = NINT(real(work_dp(1))); lrwork= NINT(rwork_dp(1)) !*2
4216 : : ABI_FREE(work_dp)
4217 : : ABI_FREE(rwork_dp)
4218 : :
4219 : : ! MG: Nov 23 2011. On my mac with the official scalapack package, rwork(1) is not large enough and causes a SIGFAULT.
4220 : : if (firstchar(jobz, ['V'])) then
4221 : : if (lrwork < 2*nn + 2*nn-2) lrwork = 2*nn + 2*nn-2
4222 : : else if (firstchar(jobz, ['N'])) then
4223 : : if (lrwork < 2*nn) lrwork = 2*nn
4224 : : end if
4225 : : !write(std_out,*)lwork,lrwork
4226 : :
4227 : : ! Solve the problem.
4228 : : ABI_MALLOC(work_dp, (lwork))
4229 : : ABI_MALLOC(rwork_dp, (lrwork))
4230 : :
4231 : : call PZHEEV(jobz, uplo, nn, mat%buffer_cplx, ija__(1), ija__(2), mat%desc, &
4232 : : w, vec%buffer_cplx, ijz__(1), ijz__(2), vec%desc, work_dp, lwork, rwork_dp, lrwork, info)
4233 : : ABI_CHECK(info == 0, sjoin("PZHEEV returned info:", itoa(info)))
4234 : : ABI_FREE(work_dp)
4235 : : ABI_FREE(rwork_dp)
4236 : : #endif
4237 : :
4238 : 0 : end subroutine slkmat_dp_heev
4239 : : !!***
4240 : :
4241 : : !----------------------------------------------------------------------
4242 : :
4243 : : !!****f* m_slk/slkmat_sp_heev
4244 : : !! NAME
4245 : : !! slkmat_sp_heev
4246 : : !!
4247 : : !! FUNCTION
4248 : : !! slkmat_sp_heev computes selected eigenvalues and, optionally, eigenvectors of an Hermitian matrix A.
4249 : : !! A * X = lambda * X
4250 : : !!
4251 : : !! INPUTS
4252 : : !! JOBZ (global input) CHARACTER*1
4253 : : !! Specifies whether or not to compute the eigenvectors:
4254 : : !! = "N": Compute eigenvalues only.
4255 : : !! = "V": Compute eigenvalues and eigenvectors.
4256 : : !! UPLO (global input) CHARACTER*1
4257 : : !! Specifies whether the upper or lower triangular part of the symmetric matrix A is stored:
4258 : : !! = "U": Upper triangular
4259 : : !! = "L": Lower triangular
4260 : : !!
4261 : : !! mat=The object storing the local buffer in SINGLE PRECISION, the array descriptor, the PBLAS context.
4262 : : !! Only complex matrices (buffer_cplx) are supported.
4263 : : !! vec=The distributed eigenvectors. Not referenced if JOBZ="N"
4264 : : !! [mat_size]= Order N of the (sub)matrix. Default: mat%size_global(2)
4265 : : !! [ija(2)]= Global row and column indices of the first entry of sub(A) in mat. Default: [1, 1]
4266 : : !! [ijz(2)]= Global row and column indices of the first entry of sub(Z) in vec. Default: [1, 1]
4267 : : !!
4268 : : !! OUTPUT
4269 : : !! W (global output) array, dimension (N) where N is the rank of the global matrix.
4270 : : !! On normal exit, the first M entries contain the selected eigenvalues in ascending order.
4271 : : !!
4272 : : !! SIDE EFFECTS
4273 : : !! If JOBZ="V", the local buffer vec%buffer_cplx will contain part of the distributed eigenvectors.
4274 : : !! On exit, the lower triangle (if UPLO='L') or the upper triangle (if UPLO='U') of A, including the diagonal, is destroyed.
4275 : : !!
4276 : : !! SOURCE
4277 : :
4278 : 0 : subroutine slkmat_sp_heev(mat, jobz, uplo, vec, w, &
4279 : : mat_size, ija, ijz) ! Optional
4280 : :
4281 : : !Arguments ------------------------------------
4282 : : !scalars
4283 : : class(slkmat_sp_t),intent(inout) :: mat
4284 : : character(len=*),intent(in) :: jobz, uplo
4285 : : class(slkmat_sp_t),intent(inout) :: vec
4286 : : !arrays
4287 : : real(sp),intent(out) :: w(:)
4288 : : integer,optional,intent(in) :: mat_size, ija(2), ijz(2)
4289 : :
4290 : : #ifdef HAVE_LINALG_SCALAPACK
4291 : : !Local variables ------------------------------
4292 : : !scalars
4293 : : integer :: lwork, lrwork, info, nn
4294 : : !arrays
4295 : : integer :: ija__(2), ijz__(2)
4296 : : real(sp),allocatable :: rwork_sp(:)
4297 : : complex(sp),allocatable :: work_sp(:)
4298 : : !************************************************************************
4299 : :
4300 : : ABI_CHECK(allocated(mat%buffer_cplx), "buffer_cplx not allocated")
4301 : :
4302 : : nn = mat%size_global(2); if (present(mat_size)) nn = mat_size
4303 : : ija__ = [1, 1]; if (present(ija)) ija__ = ija
4304 : : ijz__ = [1, 1]; if (present(ijz)) ijz__ = ijz
4305 : :
4306 : : ! Get optimal size of workspace.
4307 : : lwork = - 1; lrwork = -1
4308 : : ABI_MALLOC(work_sp, (1))
4309 : : ABI_MALLOC(rwork_sp, (1))
4310 : :
4311 : : !call pzheev(jobz, uplo, n, a, ia, ja, desca, w, z, iz, jz, descz, work, lwork, rwork, lrwork, info)
4312 : :
4313 : : call PCHEEV(jobz, uplo, nn, mat%buffer_cplx, ija__(1), ija__(2), mat%desc, &
4314 : : w, vec%buffer_cplx, ijz__(1), ijz__(2), vec%desc, work_sp, lwork, rwork_sp, lrwork, info)
4315 : : ABI_CHECK(info == 0, sjoin("Error in the calculation of the workspace size, info:", itoa(info)))
4316 : :
4317 : : lwork = NINT(real(work_sp(1))); lrwork= NINT(rwork_sp(1)) !*2
4318 : : ABI_FREE(work_sp)
4319 : : ABI_FREE(rwork_sp)
4320 : :
4321 : : ! MG: Nov 23 2011. On my mac with the official scalapack package, rwork(1) is not large enough and causes a SIGFAULT.
4322 : : if (firstchar(jobz, ['V'])) then
4323 : : if (lrwork < 2*nn + 2*nn-2) lrwork = 2*nn + 2*nn-2
4324 : : else if (firstchar(jobz, ['N'])) then
4325 : : if (lrwork < 2*nn) lrwork = 2*nn
4326 : : end if
4327 : : !write(std_out,*)lwork,lrwork
4328 : :
4329 : : ! Solve the problem.
4330 : : ABI_MALLOC(work_sp, (lwork))
4331 : : ABI_MALLOC(rwork_sp, (lrwork))
4332 : :
4333 : : call PCHEEV(jobz, uplo, nn, mat%buffer_cplx, ija__(1), ija__(2), mat%desc, &
4334 : : w, vec%buffer_cplx, ijz__(1), ijz__(2), vec%desc, work_sp, lwork, rwork_sp, lrwork, info)
4335 : : ABI_CHECK(info == 0, sjoin("PCHEEV returned info:", itoa(info)))
4336 : : ABI_FREE(work_sp)
4337 : : ABI_FREE(rwork_sp)
4338 : : #endif
4339 : :
4340 : 0 : end subroutine slkmat_sp_heev
4341 : : !!***
4342 : :
4343 : : !----------------------------------------------------------------------
4344 : :
4345 : : !!****f* m_slk/slkmat_dp_pzheevx
4346 : : !! NAME
4347 : : !! slkmat_dp_pzheevx
4348 : : !!
4349 : : !! FUNCTION
4350 : : !! slkmat_dp_pzheevx computes selected eigenvalues and, optionally, eigenvectors of a complex Hermitian matrix A.
4351 : : !! A * X = lambda * X
4352 : : !!
4353 : : !! INPUTS
4354 : : !! mat=ScaLAPACK matrix (matrix A). Only complex matrices (buffer_cplx) are supported.
4355 : : !!
4356 : : !! vec=The distributed eigenvectors X. Not referenced if JOBZ="N"
4357 : : !!
4358 : : !! JOBZ (global input) CHARACTER*1
4359 : : !! Specifies whether or not to compute the eigenvectors:
4360 : : !! = "N": Compute eigenvalues only.
4361 : : !! = "V": Compute eigenvalues and eigenvectors.
4362 : : !!
4363 : : !! RANGE (global input) CHARACTER*1
4364 : : !! = "A": all eigenvalues will be found.
4365 : : !! = "V": all eigenvalues in the interval [VL,VU] will be found.
4366 : : !! = "I": the IL-th through IU-th eigenvalues will be found.
4367 : : !!
4368 : : !! UPLO (global input) CHARACTER*1
4369 : : !! Specifies whether the upper or lower triangular part of the Hermitian matrix A is stored:
4370 : : !! = "U": Upper triangular
4371 : : !! = "L": Lower triangular
4372 : : !!
4373 : : !! VL (global input) DOUBLE PRECISION
4374 : : !! If RANGE="V",the lower bound of the interval to be searched for eigenvalues. Not referenced if RANGE =
4375 : : !! "A" or "I"
4376 : : !!
4377 : : !! VU (global input) DOUBLE PRECISION
4378 : : !! If RANGE="V", the upper bound of the interval to be searched for eigenvalues. Not referenced if RANGE =
4379 : : !! "A" or "I".
4380 : : !!
4381 : : !! IL (global input) integer
4382 : : !! If RANGE="I", the index (from smallest to largest) of the smallest eigenvalue to be returned. IL >= 1.
4383 : : !! Not referenced if RANGE = "A" or "V".
4384 : : !!
4385 : : !! IU (global input) integer
4386 : : !! If RANGE="I", the index (from smallest to largest) of the largest eigenvalue to be returned. min(IL,N) <=
4387 : : !! IU <= N. Not referenced if RANGE = "A" or "V"
4388 : : !!
4389 : : !! ABSTOL (global input) DOUBLE PRECISION
4390 : : !! If JOBZ="V", setting ABSTOL to PDLAMCH( CONTEXT, "U") yields the most orthogonal eigenvectors.
4391 : : !! The absolute error tolerance for the eigenvalues. An approximate eigenvalue is accepted as converged when
4392 : : !! it is determined to lie in an interval [a,b] of width less than or equal to
4393 : : !!
4394 : : !! ABSTOL + EPS * max( |a|,|b| ) ,
4395 : : !!
4396 : : !! where EPS is the machine precision. If ABSTOL is less than or equal to zero, then EPS*norm(T) will be used
4397 : : !! in its place, where norm(T) is the 1-norm of the tridiagonal matrix obtained by reducing A to tridiagonal form.
4398 : : !! Eigenvalues will be computed most accurately when ABSTOL is set to twice the underflow threshold
4399 : : !! 2*PDLAMCH("S") not zero. If this routine returns with ((MOD(INFO,2).NE.0) .OR. (MOD(INFO/8,2).NE.0)),
4400 : : !! indicating that some eigenvalues or eigenvectors did not converge, try setting ABSTOL to 2*PDLAMCH("S").
4401 : : !!
4402 : : !! OUTPUT
4403 : : !! mene_found= (global output) Total number of eigenvalues found. 0 <= mene_found <= N.
4404 : : !! eigen(N)= (global output) Eigenvalues of A where N is the dimension of M
4405 : : !! On normal exit, the first mene_found entries contain the selected eigenvalues in ascending order.
4406 : : !!
4407 : : !! SIDE EFFECTS
4408 : : !! If JOBZ="V", the local buffer vec%buffer_cplx will contain part of the distributed eigenvectors.
4409 : : !! mat%buffer_cplx is destroyed when the routine returns
4410 : : !!
4411 : : !! SOURCE
4412 : :
4413 : 0 : subroutine slkmat_dp_pzheevx(mat, jobz, range, uplo, vl, vu, il, iu, abstol, vec, mene_found, eigen)
4414 : :
4415 : : !Arguments ------------------------------------
4416 : : class(slkmat_dp_t),intent(inout) :: mat
4417 : : integer,intent(in) :: il, iu
4418 : : integer,intent(out) :: mene_found
4419 : : real(dp),intent(in) :: abstol,vl,vu
4420 : : character(len=*),intent(in) :: jobz,range,uplo
4421 : : class(slkmat_dp_t),intent(inout) :: vec
4422 : : !arrays
4423 : : real(dp),intent(out) :: eigen(*)
4424 : :
4425 : : #ifdef HAVE_LINALG_SCALAPACK
4426 : : !Local variables-------------------------------
4427 : : !scalars
4428 : : integer :: lwork,lrwork,liwork,info,nvec_calc !,ierr
4429 : : real(dp) :: orfac
4430 : : character(len=500) :: msg
4431 : : !arrays
4432 : : !integer :: ibuff(3),max_ibuff(3)
4433 : : integer,allocatable :: iwork(:),iclustr(:),ifail(:)
4434 : : real(dp),allocatable :: rwork(:),gap(:)
4435 : : complex(dpc),allocatable :: work(:)
4436 : : !************************************************************************
4437 : :
4438 : : ABI_CHECK(allocated(mat%buffer_cplx), "buffer_cplx is not allocated!")
4439 : :
4440 : : ! abstol = PDLAMCH(vec%processor%grid%comm,'U')
4441 : :
4442 : : orfac = -one ! Only for eigenvectors: use default value 10d-3.
4443 : : ! Vectors within orfac*norm(A) will be reorthogonalized.
4444 : :
4445 : : ! Allocate the arrays for the results of the calculation
4446 : : ABI_MALLOC(gap, (mat%processor%grid%dims(1) * mat%processor%grid%dims(2)))
4447 : :
4448 : : if (firstchar(jobz, ["V","v"])) then
4449 : : ABI_MALLOC(ifail, (mat%size_global(2)))
4450 : : ABI_MALLOC(iclustr, (2*mat%processor%grid%dims(1) * mat%processor%grid%dims(2)))
4451 : : end if
4452 : :
4453 : : ! Get the optimal size of the work arrays.
4454 : : lwork=-1; lrwork=-1; liwork=-1
4455 : : ABI_MALLOC(work, (1))
4456 : : ABI_MALLOC(iwork, (1))
4457 : : ABI_MALLOC(rwork, (3))
4458 : : ! This is clearly seen in the source in which rwork(1:3) is accessed
4459 : : ! in the calculation of the workspace size.
4460 : :
4461 : : ! prototype
4462 : : !call pzheevx(jobz, range, uplo, n, a, ia, ja, desca, vl, vu, il, iu, abstol, m, nz, w,
4463 : : ! orfac, z, iz, jz, descz, work, lwork, rwork, lrwork, iwork, liwork, ifail, iclustr, gap, info)
4464 : :
4465 : : call PZHEEVX(jobz,range,uplo, mat%size_global(2),mat%buffer_cplx,1,1,mat%desc,&
4466 : : vl,vu,il,iu,abstol,mene_found,nvec_calc,eigen,orfac,&
4467 : : vec%buffer_cplx,1,1,vec%desc,&
4468 : : work,lwork,rwork,lrwork,iwork,liwork,ifail,iclustr,gap,info)
4469 : :
4470 : : ABI_CHECK(info == 0, sjoin("Problem to compute workspace, info:", itoa(info)))
4471 : :
4472 : : lwork = NINT(real(work(1)),kind=dp)
4473 : : lrwork = NINT(rwork(1))
4474 : : liwork = iwork(1)
4475 : :
4476 : : ABI_FREE(work)
4477 : : ABI_FREE(rwork)
4478 : : ABI_FREE(iwork)
4479 : : !
4480 : : ! FROM THE SCALAPACK MAN PAGE:
4481 : : ! The computed eigenvectors may not be orthogonal if the minimal workspace is supplied and ORFAC is too
4482 : : ! small. If you want to guarantee orthogonality (at the cost of potentially poor performance) you should
4483 : : ! add the following to LRWORK: (CLUSTERSIZE-1)*N where CLUSTERSIZE is the number of eigenvalues in the
4484 : : ! largest cluster, where a cluster is defined as a set of close eigenvalues: { W(K),...,W(K+CLUSTERSIZE-1) |
4485 : : ! W(J+1) <= W(J) + ORFAC*2*norm(A) }.
4486 : :
4487 : : if (firstchar(jobz, ["V","v"])) then
4488 : : lrwork = INT( lrwork + mat%size_global(2) *(mat%size_global(2)-1) )
4489 : : end if
4490 : :
4491 : : ! ibuff(1) = lwork
4492 : : ! ibuff(2) = lrwork !INT(lrwork + mat%size_global(2) *(mat%size_global(2)-1)
4493 : : ! ibuff(3) = liwork
4494 : :
4495 : : ! Get the maximum of sizes of the work arrays processor%comm
4496 : : ! call MPI_ALLREDUCE(ibuff,max_ibuff,3,MPI_integer,MPI_MAX,comm,ierr)
4497 : :
4498 : : ! lwork = max_ibuff(1)
4499 : : ! lrwork = max_ibuff(2)
4500 : : ! liwork = max_ibuff(3)
4501 : :
4502 : : ABI_MALLOC(work , (lwork ))
4503 : : ABI_MALLOC(rwork, (lrwork))
4504 : : ABI_MALLOC(iwork, (liwork))
4505 : :
4506 : : ! prototype
4507 : : !call pzheevx(jobz, range, uplo, n, a, ia, ja, desca, vl, vu, il, iu, abstol, m, nz, w,
4508 : : ! orfac, z, iz, jz, descz, work, lwork, rwork, lrwork, iwork, liwork, ifail, iclustr, gap, info)
4509 : :
4510 : : ! Call the scaLAPACK routine.
4511 : : ! write(std_out,*) 'I am using PZHEEVX'
4512 : : call PZHEEVX(jobz,range,uplo, mat%size_global(2),mat%buffer_cplx,1,1,mat%desc,&
4513 : : vl,vu,il,iu,abstol,mene_found,nvec_calc, eigen,orfac,&
4514 : : vec%buffer_cplx,1,1,vec%desc,&
4515 : : work,lwork,rwork,lrwork,iwork,liwork,ifail,iclustr,gap,info)
4516 : :
4517 : : ! Handle possible error.
4518 : : if (info < 0) then
4519 : : write(msg,'(a,i0,a)')" The ", -info, "-th argument of P?HEEVX had an illegal value."
4520 : : if (info == -25) msg = " LRWORK is too small to compute all the eigenvectors requested, no computation is performed"
4521 : : ABI_ERROR(msg)
4522 : : end if
4523 : :
4524 : : if (info > 0) then
4525 : : write(msg,'(a,i0)') " P?HEEVX returned info: ",info
4526 : : call wrtout(std_out, msg)
4527 : : if (MOD(info, 2) /= 0)then
4528 : : write(msg,'(3a)')&
4529 : : " One or more eigenvectors failed to converge. ",ch10,&
4530 : : " Their indices are stored in IFAIL. Ensure ABSTOL=2.0*PDLAMCH('U')"
4531 : : call wrtout(std_out, msg)
4532 : : end if
4533 : : if (MOD(info / 2, 2) /= 0) then
4534 : : write(msg,'(5a)')&
4535 : : " Eigenvectors corresponding to one or more clusters of eigenvalues ",ch10,&
4536 : : " could not be reorthogonalized because of insufficient workspace. ",ch10,&
4537 : : " The indices of the clusters are stored in the array ICLUSTR."
4538 : : call wrtout(std_out, msg)
4539 : : end if
4540 : : if (MOD(info / 4, 2) /= 0) then
4541 : : write(msg,'(3a)')" Space limit prevented PZHEEVX from computing all of the eigenvectors between VL and VU. ",ch10,&
4542 : : " The number of eigenvectors computed is returned in NZ."
4543 : : call wrtout(std_out, msg)
4544 : : end if
4545 : : if (MOD(info / 8, 2) /= 0) then
4546 : : call wrtout(std_out, "PZSTEBZ failed to compute eigenvalues. Ensure ABSTOL=2.0*PDLAMCH('U')")
4547 : : end if
4548 : : ABI_ERROR("Cannot continue")
4549 : : end if
4550 : :
4551 : : ! Check the number of eigenvalues found wrt to the number of vectors calculated.
4552 : : if (firstchar(jobz, ['V','v']) .and. mene_found /= nvec_calc) then
4553 : : write(msg,'(5a)') &
4554 : : " The user supplied insufficient space and PZHEEVX is not able to detect this before beginning computation. ",ch10,&
4555 : : " To get all the eigenvectors requested, the user must supply both sufficient space to hold the ",ch10,&
4556 : : " eigenvectors in Z (M .LE. DESCZ(N_)) and sufficient workspace to compute them. "
4557 : : ABI_ERROR(msg)
4558 : : end if
4559 : :
4560 : : ABI_FREE(work)
4561 : : ABI_FREE(rwork)
4562 : : ABI_FREE(iwork)
4563 : : ABI_FREE(gap)
4564 : : ABI_SFREE(ifail)
4565 : : ABI_SFREE(iclustr)
4566 : : #endif
4567 : :
4568 : 0 : end subroutine slkmat_dp_pzheevx
4569 : : !!***
4570 : :
4571 : : !----------------------------------------------------------------------
4572 : :
4573 : : !!****f* m_slk/slkmat_dp_pzhegvx
4574 : : !! NAME
4575 : : !! slkmat_dp_pzhegvx
4576 : : !!
4577 : : !! FUNCTION
4578 : : !! slkmat_dp_pzhegvx provides an object-oriented interface to the ScaLAPACK routine PZHEGVX that
4579 : : !! computes selected eigenvalues and, optionally, eigenvectors of a complex generalized
4580 : : !! Hermitian-definite eigenproblem, of the form
4581 : : !! sub( A )*x=(lambda)*sub( B )*x, sub( A )*sub( B )x=(lambda)*x, or sub( B )*sub( A )*x=(lambda)*x.
4582 : : !! Here sub( A ) denoting A( IA:IA+N-1, JA:JA+N-1 ) is assumed to be
4583 : : !! Hermitian, and sub( B ) denoting B( IB:IB+N-1, JB:JB+N-1 ) is assumed
4584 : : !! to be Hermitian positive definite.
4585 : : !!
4586 : : !! INPUTS
4587 : : !! Slk_matA<slkmat_dp_t>=ScaLAPACK matrix (matrix A)
4588 : : !! Slk_matB<slkmat_dp_t>=ScaLAPACK matrix (matrix B)
4589 : : !! Slk_vec<slkmat_dp_t>=The distributed eigenvectors X. Not referenced if JOBZ="N"
4590 : : !!
4591 : : !! IBtype (global input) integer
4592 : : !! Specifies the problem type to be solved:
4593 : : !! = 1: sub( A )*x = (lambda)*sub( B )*x
4594 : : !! = 2: sub( A )*sub( B )*x = (lambda)*x
4595 : : !! = 3: sub( B )*sub( A )*x = (lambda)*x
4596 : : !!
4597 : : !! JOBZ (global input) CHARACTER*1
4598 : : !! Specifies whether or not to compute the eigenvectors:
4599 : : !! = "N": Compute eigenvalues only.
4600 : : !! = "V": Compute eigenvalues and eigenvectors.
4601 : : !!
4602 : : !! RANGE (global input) CHARACTER*1
4603 : : !! = "A": all eigenvalues will be found.
4604 : : !! = "V": all eigenvalues in the interval [VL,VU] will be found.
4605 : : !! = "I": the IL-th through IU-th eigenvalues will be found.
4606 : : !!
4607 : : !! UPLO (global input) CHARACTER*1
4608 : : !! Specifies whether the upper or lower triangular part of the Hermitian matrix sub(A) and sub(B) is stored:
4609 : : !! = "U": Upper triangular
4610 : : !! = "L": Lower triangular
4611 : : !!
4612 : : !! VL (global input) DOUBLE PRECISION
4613 : : !! If RANGE="V",the lower bound of the interval to be searched for eigenvalues. Not referenced if RANGE =
4614 : : !! "A" or "I"
4615 : : !!
4616 : : !! VU (global input) DOUBLE PRECISION
4617 : : !! If RANGE="V", the upper bound of the interval to be searched for eigenvalues. Not referenced if RANGE =
4618 : : !! "A" or "I".
4619 : : !!
4620 : : !! IL (global input) integer
4621 : : !! If RANGE="I", the index (from smallest to largest) of the smallest eigenvalue to be returned. IL >= 1.
4622 : : !! Not referenced if RANGE = "A" or "V".
4623 : : !!
4624 : : !! IU (global input) integer
4625 : : !! If RANGE="I", the index (from smallest to largest) of the largest eigenvalue to be returned. min(IL,N) <=
4626 : : !! IU <= N. Not referenced if RANGE = "A" or "V"
4627 : : !!
4628 : : !! ABSTOL (global input) DOUBLE PRECISION
4629 : : !! If JOBZ="V", setting ABSTOL to PDLAMCH( CONTEXT, "U") yields the most orthogonal eigenvectors.
4630 : : !! The absolute error tolerance for the eigenvalues. An approximate eigenvalue is accepted as converged when
4631 : : !! it is determined to lie in an interval [a,b] of width less than or equal to
4632 : : !!
4633 : : !! ABSTOL + EPS * max( |a|,|b| ) ,
4634 : : !!
4635 : : !! where EPS is the machine precision. If ABSTOL is less than or equal to zero, then EPS*norm(T) will be used
4636 : : !! in its place, where norm(T) is the 1-norm of the tridiagonal matrix obtained by reducing A to tridiagonal form.
4637 : : !! Eigenvalues will be computed most accurately when ABSTOL is set to twice the underflow threshold
4638 : : !! 2*PDLAMCH("S") not zero. If this routine returns with ((MOD(INFO,2).NE.0) .OR. (MOD(INFO/8,2).NE.0)),
4639 : : !! indicating that some eigenvalues or eigenvectors did not converge, try setting ABSTOL to 2*PDLAMCH("S").
4640 : : !!
4641 : : !! OUTPUT
4642 : : !! mene_found= (global output) Total number of eigenvalues found. 0 <= mene_found <= N.
4643 : : !!
4644 : : !! eigen(N)= (global output) Eigenvalues of A where N is the dimension of M
4645 : : !! On normal exit, the first mene_found entries contain the selected eigenvalues in ascending order.
4646 : : !!
4647 : : !! SIDE EFFECTS
4648 : : !! Slk_vec<slkmat_dp_t>:
4649 : : !! %buffer_cplx local output (global dimension (N,N)
4650 : : !! If JOBZ = 'V', then on normal exit the first M columns of Z
4651 : : !! contain the orthonormal eigenvectors of the matrix
4652 : : !! corresponding to the selected eigenvalues.
4653 : : !! If JOBZ = 'N', then Z is not referenced.
4654 : : !!
4655 : : !! Slk_matA<slkmat_dp_t>:
4656 : : !! %buffer_cplx
4657 : : !! (local input/local output) complex(DP) pointer into the
4658 : : !! local memory to an array of dimension (LLD_A, LOCc(JA+N-1)).
4659 : : !! On entry, this array contains the local pieces of the
4660 : : !! N-by-N Hermitian distributed matrix sub( A ). If UPLO = 'U',
4661 : : !! the leading N-by-N upper triangular part of sub( A ) contains
4662 : : !! the upper triangular part of the matrix. If UPLO = 'L', the
4663 : : !! leading N-by-N lower triangular part of sub( A ) contains
4664 : : !! the lower triangular part of the matrix.
4665 : : !!
4666 : : !! On exit, if JOBZ = 'V', then if INFO = 0, sub( A ) contains
4667 : : !! the distributed matrix Z of eigenvectors. The eigenvectors
4668 : : !! are normalized as follows:
4669 : : !! if IBtype = 1 or 2, Z**H*sub( B )*Z = I;
4670 : : !! if IBtype = 3, Z**H*inv( sub( B ) )*Z = I.
4671 : : !! If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
4672 : : !! or the lower triangle (if UPLO='L') of sub( A ), including
4673 : : !! the diagonal, is destroyed.
4674 : : !!
4675 : : !! Slk_matB=
4676 : : !! %buffer_cplx
4677 : : !! (local input/local output) complex*(DP) pointer into the
4678 : : !! local memory to an array of dimension (LLD_B, LOCc(JB+N-1)).
4679 : : !! On entry, this array contains the local pieces of the
4680 : : !! N-by-N Hermitian distributed matrix sub( B ). If UPLO = 'U',
4681 : : !! the leading N-by-N upper triangular part of sub( B ) contains
4682 : : !! the upper triangular part of the matrix. If UPLO = 'L', the
4683 : : !! leading N-by-N lower triangular part of sub( B ) contains
4684 : : !! the lower triangular part of the matrix.
4685 : : !!
4686 : : !! On exit, if INFO <= N, the part of sub( B ) containing the
4687 : : !! matrix is overwritten by the triangular factor U or L from
4688 : : !! the Cholesky factorization sub( B ) = U**H*U or
4689 : : !! sub( B ) = L*L**H.
4690 : : !!
4691 : : !! SOURCE
4692 : :
4693 : 0 : subroutine slkmat_dp_pzhegvx(Slk_matA, ibtype, jobz, range, uplo, Slk_matB, vl, vu, il, iu, abstol, Slk_vec, mene_found, eigen)
4694 : :
4695 : : !Arguments ------------------------------------
4696 : : class(slkmat_dp_t),intent(inout) :: Slk_matA
4697 : : integer,intent(in) :: il,iu,ibtype
4698 : : integer,intent(out) :: mene_found
4699 : : real(dp),intent(in) :: abstol,vl,vu
4700 : : character(len=*),intent(in) :: jobz,range,uplo
4701 : : class(slkmat_dp_t),intent(inout) :: Slk_matB
4702 : : class(slkmat_dp_t),intent(inout) :: Slk_vec
4703 : : !arrays
4704 : : real(dp),intent(out) :: eigen(*)
4705 : :
4706 : : #ifdef HAVE_LINALG_SCALAPACK
4707 : : !Local variables-------------------------------
4708 : : !scalars
4709 : : integer :: lwork,lrwork,liwork,info,nvec_calc !,ierr
4710 : : real(dp) :: orfac
4711 : : logical :: ltest
4712 : : character(len=500) :: msg
4713 : : !arrays
4714 : : !integer :: ibuff(3),max_ibuff(3)
4715 : : integer :: desca(DLEN_),descb(DLEN_),descz(DLEN_)
4716 : : integer,allocatable :: iwork(:),iclustr(:),ifail(:)
4717 : : real(dp),allocatable :: rwork(:),gap(:)
4718 : : complex(dpc),allocatable :: work(:)
4719 : : !************************************************************************
4720 : :
4721 : : ABI_CHECK(allocated(Slk_matA%buffer_cplx), "buffer_cplx is not allocated!")
4722 : :
4723 : : ! abstol = PDLAMCH(Slk_vecprocessor%grid%comm,'U')
4724 : :
4725 : : orfac = -one ! Only for eigenvectors: use default value 10d-3.
4726 : : ! Vectors within orfac*norm(A) will be reorthogonalized.
4727 : :
4728 : : ! ======================
4729 : : ! Alignment requirements
4730 : : ! ======================
4731 : : ! The distributed submatrices A(IA:*, JA:*), C(IC:IC+M-1,JC:JC+N-1),
4732 : : ! and B( IB:IB+N-1, JB:JB+N-1 ) must verify some alignment properties,
4733 : :
4734 : : desca = Slk_matA%desc
4735 : : descb = Slk_matB%desc
4736 : : if (firstchar(jobz, ["V", "v"])) then
4737 : : descz = Slk_vec%desc
4738 : : else
4739 : : descz = Slk_matA%desc
4740 : : end if
4741 : :
4742 : : ltest = .TRUE.
4743 : : ltest = ltest .and. (DESCA(MB_) == DESCA(NB_))
4744 : : !IA = IB = IZ
4745 : : !JA = IB = JZ
4746 : : ltest = ltest .and.ALL(DESCA(M_ ) == [DESCB(M_ ), DESCZ(M_ )])
4747 : : ltest = ltest .and.ALL(DESCA(N_ ) == [DESCB(N_ ), DESCZ(N_ )])
4748 : : ltest = ltest .and.ALL(DESCA(MB_ ) == [DESCB(MB_ ), DESCZ(MB_ )])
4749 : : ltest = ltest .and.ALL(DESCA(NB_ ) == [DESCB(NB_ ), DESCZ(NB_ )])
4750 : : ltest = ltest .and.ALL(DESCA(RSRC_) == [DESCB(RSRC_), DESCZ(RSRC_)])
4751 : : ltest = ltest .and.ALL(DESCA(CSRC_) == [DESCB(CSRC_), DESCZ(CSRC_)])
4752 : : !MOD( IA-1, DESCA( MB_ ) ) = 0
4753 : : !MOD( JA-1, DESCA( NB_ ) ) = 0
4754 : : !MOD( IB-1, DESCB( MB_ ) ) = 0
4755 : : !MOD( JB-1, DESCB( NB_ ) ) = 0
4756 : :
4757 : : if (.not.ltest) then
4758 : : ABI_ERROR("Alignment requirements not satisfied, check the caller")
4759 : : end if
4760 : :
4761 : : !Allocate the arrays for the results of the calculation
4762 : : ABI_MALLOC(gap, (Slk_matA%processor%grid%dims(1) * Slk_matA%processor%grid%dims(2)))
4763 : :
4764 : : if (firstchar(jobz, ["V","v"])) then
4765 : : ABI_MALLOC(ifail,(Slk_matA%size_global(2)))
4766 : : ABI_MALLOC(iclustr,( 2*Slk_matA%processor%grid%dims(1) * Slk_matA%processor%grid%dims(2)))
4767 : : else
4768 : : ABI_MALLOC(ifail,(1))
4769 : : end if
4770 : :
4771 : : ! Get the optimal size of the work arrays.
4772 : : lwork=-1; lrwork=-1; liwork=-1
4773 : : ABI_MALLOC(work,(1))
4774 : : ABI_MALLOC(iwork,(1))
4775 : : ABI_MALLOC(rwork,(3))
4776 : : ! This is clearly seen in the source in which rwork(1:3) is accessed
4777 : : ! in the calculation of the workspace size.
4778 : :
4779 : : call pzhegvx(ibtype,jobz,range,uplo, Slk_matA%size_global(2),Slk_matA%buffer_cplx,1,1,Slk_matA%desc,&
4780 : : Slk_matB%buffer_cplx,1,1,Slk_matB%desc,&
4781 : : vl,vu,il,iu,abstol,mene_found,nvec_calc,eigen,orfac,&
4782 : : Slk_vec%buffer_cplx,1,1,Slk_vec%desc,&
4783 : : work,lwork,rwork,lrwork,iwork,liwork,ifail,iclustr,gap,info)
4784 : :
4785 : : ABI_CHECK(info == 0, sjoin("Problem to compute workspace, info:", itoa(info)))
4786 : :
4787 : : lwork = NINT(real(work(1)),kind=dp)
4788 : : lrwork = NINT(rwork(1))
4789 : : liwork = iwork(1)
4790 : :
4791 : : ABI_FREE(work)
4792 : : ABI_FREE(rwork)
4793 : : ABI_FREE(iwork)
4794 : :
4795 : : !FROM THE SCALAPACK MAN PAGE:
4796 : : !The computed eigenvectors may not be orthogonal if the minimal workspace is supplied and ORFAC is too
4797 : : !small. If you want to guarantee orthogonality (at the cost of potentially poor performance) you should
4798 : : !add the following to LRWORK: (CLUSTERSIZE-1)*N where CLUSTERSIZE is the number of eigenvalues in the
4799 : : !largest cluster, where a cluster is defined as a set of close eigenvalues: { W(K),...,W(K+CLUSTERSIZE-1) |
4800 : : !W(J+1) <= W(J) + ORFAC*2*norm(A) }.
4801 : :
4802 : : if (firstchar(jobz, ["V","v"])) then
4803 : : lrwork = INT( lrwork + Slk_matA%size_global(2) *(Slk_matA%size_global(2)-1) )
4804 : : end if
4805 : :
4806 : : !ibuff(1) = lwork
4807 : : !ibuff(2) = lrwork !INT(lrwork + Slk_matA%size_global(2) *(Slk_matA%size_global(2)-1)
4808 : : !ibuff(3) = liwork
4809 : :
4810 : : !Get the maximum of sizes of the work arrays processor%comm
4811 : : !call MPI_ALLREDUCE(ibuff,max_ibuff,3,MPI_integer,MPI_MAX,comm,ierr)
4812 : :
4813 : : !lwork = max_ibuff(1)
4814 : : !lrwork = max_ibuff(2)
4815 : : !liwork = max_ibuff(3)
4816 : :
4817 : : ABI_MALLOC(work , (lwork ))
4818 : : ABI_MALLOC(rwork, (lrwork))
4819 : : ABI_MALLOC(iwork, (liwork))
4820 : :
4821 : : ! Call the scaLAPACK routine.
4822 : : ! write(std_out,*) 'I am using PZHEGVX'
4823 : : call pzhegvx(ibtype,jobz,range,uplo, Slk_matA%size_global(2),Slk_matA%buffer_cplx,1,1,Slk_matA%desc,&
4824 : : Slk_matB%buffer_cplx,1,1,Slk_matB%desc,&
4825 : : vl,vu,il,iu,abstol,mene_found,nvec_calc, eigen,orfac,&
4826 : : Slk_vec%buffer_cplx,1,1,Slk_vec%desc,&
4827 : : work,lwork,rwork,lrwork,iwork,liwork,ifail,iclustr,gap,info)
4828 : :
4829 : : ! Handle the possible error.
4830 : : if (info < 0) then
4831 : : write(msg,'(a,i0,a)')" The ",-info,"-th argument of PZHEGVX had an illegal value."
4832 : : if (info==-25) msg = " LRWORK is too small to compute all the eigenvectors requested, no computation is performed"
4833 : : ABI_ERROR(msg)
4834 : : end if
4835 : :
4836 : : if (info > 0) then
4837 : : write(msg,'(a,i0)') " PZHEGVX returned info: ",info
4838 : : call wrtout(std_out, msg)
4839 : : if (MOD(info,2)/=0)then
4840 : : write(msg,'(3a)')&
4841 : : " One or more eigenvectors failed to converge. ",ch10,&
4842 : : " Their indices are stored in IFAIL. Ensure ABSTOL=2.0*PDLAMCH('U')"
4843 : : call wrtout(std_out, msg)
4844 : : end if
4845 : : if (MOD(info / 2, 2) /= 0) then
4846 : : write(msg,'(5a)')&
4847 : : " Eigenvectors corresponding to one or more clusters of eigenvalues ",ch10,&
4848 : : " could not be reorthogonalized because of insufficient workspace. ",ch10,&
4849 : : " The indices of the clusters are stored in the array ICLUSTR."
4850 : : call wrtout(std_out, msg)
4851 : : end if
4852 : : if (MOD(info / 4, 2) /= 0) then
4853 : : write(msg,'(3a)')&
4854 : : " Space limit prevented PZHEGVX from computing all of the eigenvectors between VL and VU. ",ch10,&
4855 : : " The number of eigenvectors computed is returned in NZ."
4856 : : call wrtout(std_out, msg)
4857 : : end if
4858 : : if (MOD(info / 8, 2) /= 0) then
4859 : : msg = " PZSTEBZ failed to compute eigenvalues. Ensure ABSTOL=2.0*PDLAMCH('U')"
4860 : : call wrtout(std_out, msg)
4861 : : end if
4862 : : if (MOD(info / 16, 2) /= 0) then
4863 : : write(msg,'(3a)')&
4864 : : " B was not positive definite.",ch10,&
4865 : : " IFAIL(1) indicates the order of the smallest minor which is not positive definite."
4866 : : call wrtout(std_out, msg)
4867 : : end if
4868 : : ABI_ERROR("Cannot continue")
4869 : : end if
4870 : :
4871 : : ! Check the number of eigenvalues found wrt to the number of vectors calculated.
4872 : : if ( firstchar(jobz, ['V','v']) .and. mene_found/=nvec_calc) then
4873 : : write(msg,'(5a)')&
4874 : : " The user supplied insufficient space and PZHEGVX is not able to detect this before beginning computation. ",ch10,&
4875 : : " To get all the eigenvectors requested, the user must supply both sufficient space to hold the ",ch10,&
4876 : : " eigenvectors in Z (M .LE. DESCZ(N_)) and sufficient workspace to compute them. "
4877 : : ABI_ERROR(msg)
4878 : : end if
4879 : :
4880 : : ABI_FREE(work)
4881 : : ABI_FREE(rwork)
4882 : : ABI_FREE(iwork)
4883 : : ABI_FREE(gap)
4884 : : ABI_FREE(ifail)
4885 : : ABI_SFREE(iclustr)
4886 : : #endif
4887 : :
4888 : 0 : end subroutine slkmat_dp_pzhegvx
4889 : : !!***
4890 : :
4891 : : !----------------------------------------------------------------------
4892 : :
4893 : : !!****f* m_slk/basemat_invert
4894 : : !! NAME
4895 : : !! basemat_invert
4896 : : !!
4897 : : !! FUNCTION
4898 : : !! Compute the inverse of a complex matrix.
4899 : : !! Uses LU factorization (P?GETRF + P?GETRI). Requires square blocks (MB == NB).
4900 : : !! Real matrices are not supported.
4901 : : !!
4902 : : !! SIDE EFFECTS
4903 : : !! mat
4904 : : !! In input, the matrix to invert.
4905 : : !! In output the matrix inverted and distributed among the nodes.
4906 : : !!
4907 : : !! SOURCE
4908 : :
4909 : 0 : subroutine basemat_invert(mat)
4910 : :
4911 : : !Arguments ------------------------------------
4912 : : class(basemat_t),intent(inout) :: mat
4913 : :
4914 : : #ifdef HAVE_LINALG_SCALAPACK
4915 : : !Local variables ------------------------------
4916 : : !scalars
4917 : : integer :: lwork,info,ipiv_size,liwork
4918 : : !array
4919 : : integer,allocatable :: ipiv(:), iwork(:)
4920 : : complex(dp),allocatable :: work_dp(:)
4921 : : complex(sp),allocatable :: work_sp(:)
4922 : : !************************************************************************
4923 : :
4924 : : if (mat%desc(MB_) /= mat%desc(NB_)) then
4925 : : ABI_ERROR("PZGETRF requires square block decomposition i.e MB_A = NB_A.")
4926 : : end if
4927 : :
4928 : : ipiv_size = my_locr(mat) + mat%desc(MB_)
4929 : : ABI_MALLOC(ipiv, (ipiv_size))
4930 : :
4931 : : select type (mat)
4932 : : class is (slkmat_dp_t)
4933 : : if (allocated(mat%buffer_cplx)) then
4934 : : ! P * L * U Factorization.
4935 : : call PZGETRF(mat%size_global(1), mat%size_global(2), mat%buffer_cplx, 1, 1, mat%desc,ipiv, info)
4936 : : ABI_CHECK(info == 0, sjoin(" PZGETRF returned info:", itoa(info)))
4937 : :
4938 : : ! Get optimal size of workspace for PZGETRI.
4939 : : lwork = -1; liwork = -1
4940 : : ABI_MALLOC(work_dp,(1))
4941 : : ABI_MALLOC(iwork,(1))
4942 : :
4943 : : call PZGETRI(mat%size_global(1), mat%buffer_cplx, 1, 1, mat%desc, ipiv, work_dp, lwork, iwork, liwork, info)
4944 : : ABI_CHECK(info == 0, "PZGETRI: Error while computing workspace size")
4945 : :
4946 : : lwork = nint(real(work_dp(1))); liwork=iwork(1)
4947 : : ABI_FREE(work_dp)
4948 : : ABI_FREE(iwork)
4949 : :
4950 : : ! Solve the problem.
4951 : : ABI_MALLOC(work_dp, (lwork))
4952 : : ABI_MALLOC(iwork, (liwork))
4953 : :
4954 : : call PZGETRI(mat%size_global(1), mat%buffer_cplx, 1, 1, mat%desc, ipiv, work_dp, lwork, iwork, liwork, info)
4955 : : ABI_CHECK(info == 0, sjoin("PZGETRI returned info:", itoa(info)))
4956 : : ABI_FREE(work_dp)
4957 : :
4958 : : else if (allocated(mat%buffer_real)) then
4959 : : ABI_ERROR("Inversion for real matrices not coded!")
4960 : : end if
4961 : :
4962 : : class is (slkmat_sp_t)
4963 : : if (allocated(mat%buffer_cplx)) then
4964 : : ! P * L * U Factorization.
4965 : : call PCGETRF(mat%size_global(1), mat%size_global(2), mat%buffer_cplx, 1, 1, mat%desc,ipiv, info)
4966 : : ABI_CHECK(info == 0, sjoin(" PCGETRF returned info:", itoa(info)))
4967 : :
4968 : : ! Get optimal size of workspace for PZGETRI.
4969 : : lwork = -1; liwork = -1
4970 : : ABI_MALLOC(work_sp,(1))
4971 : : ABI_MALLOC(iwork,(1))
4972 : :
4973 : : call PCGETRI(mat%size_global(1), mat%buffer_cplx, 1, 1, mat%desc, ipiv, work_sp, lwork, iwork, liwork, info)
4974 : : ABI_CHECK(info == 0, "PZGETRI: Error while computing workspace size")
4975 : :
4976 : : lwork = nint(real(work_sp(1))); liwork=iwork(1)
4977 : : ABI_FREE(work_sp)
4978 : : ABI_FREE(iwork)
4979 : :
4980 : : ! Solve the problem.
4981 : : ABI_MALLOC(work_sp, (lwork))
4982 : : ABI_MALLOC(iwork, (liwork))
4983 : :
4984 : : call PCGETRI(mat%size_global(1), mat%buffer_cplx, 1, 1, mat%desc, ipiv, work_sp, lwork, iwork, liwork, info)
4985 : : ABI_CHECK(info == 0, sjoin("PZGETRI returned info:", itoa(info)))
4986 : : ABI_FREE(work_sp)
4987 : :
4988 : : else if (allocated(mat%buffer_real)) then
4989 : : ABI_ERROR("Inversion for real matrices not coded!")
4990 : : end if
4991 : :
4992 : : class default
4993 : : ABI_ERROR("Wrong class")
4994 : : end select
4995 : :
4996 : : ABI_FREE(iwork)
4997 : : ABI_FREE(ipiv)
4998 : : #endif
4999 : :
5000 : 0 : end subroutine basemat_invert
5001 : : !!***
5002 : :
5003 : : !----------------------------------------------------------------------
5004 : :
5005 : : !!****f* m_slk/slkmat_dp_hpd_invert
5006 : : !! NAME
5007 : : !! slkmat_dp_hpd_invert
5008 : : !!
5009 : : !! FUNCTION
5010 : : !! Compute the inverse of an Hermitian positive definite matrix (Cholesky factorization).
5011 : : !! Only complex matrices (buffer_cplx) are supported.
5012 : : !!
5013 : : !! INPUTS
5014 : : !! uplo: global input
5015 : : !! = 'U': Upper triangle of sub( A ) is stored;
5016 : : !! = 'L': Lower triangle of sub( A ) is stored.
5017 : : !! [full]: If full PBLAS matrix is needed. Default: True
5018 : : !!
5019 : : !! SIDE EFFECTS
5020 : : !! mat= The object storing the local buffer, the array descriptor, the context, etc.
5021 : : !! On entry, this array contains the local pieces of the N-by-N Hermitian distributed matrix sub( A ) to be factored.
5022 : : !! If UPLO = 'U', the leading N-by-N upper triangular part of sub( A ) contains the upper triangular part of the matrix,
5023 : : !! and its strictly lower triangular part is not referenced.
5024 : : !! If UPLO = 'L', the leading N-by-N lower triangular part of sub( A ) contains the lower triangular part of the distribu-
5025 : : !! ted matrix, and its strictly upper triangular part is not referenced.
5026 : : !! On exit, the local pieces of the upper or lower triangle of the (Hermitian) inverse of sub( A )
5027 : : !!
5028 : : !! SOURCE
5029 : :
5030 : 0 : subroutine slkmat_dp_hpd_invert(mat, uplo, full)
5031 : :
5032 : : !Arguments ------------------------------------
5033 : : class(slkmat_dp_t),intent(inout) :: mat
5034 : : character(len=*),intent(in) :: uplo
5035 : : logical,optional,intent(in) :: full
5036 : :
5037 : : #ifdef HAVE_LINALG_SCALAPACK
5038 : : !Local variables ------------------------------
5039 : : !scalars
5040 : : integer :: info, mm, il1, il2, iglob1, iglob2
5041 : : type(slkmat_dp_t) :: work_mat
5042 : : logical :: full__
5043 : : !************************************************************************
5044 : :
5045 : : ABI_CHECK(allocated(mat%buffer_cplx), "buffer_cplx not allocated")
5046 : :
5047 : : ! ZPOTRF computes the Cholesky factorization of a complex Hermitian positive definite.
5048 : : ! A = U**H * U, if UPLO = 'U', or
5049 : : ! A = L * L**H, if UPLO = 'L',
5050 : : mm = mat%size_global(1)
5051 : : call PZPOTRF(uplo, mm, mat%buffer_cplx, 1, 1, mat%desc, info)
5052 : : ABI_CHECK(info == 0, sjoin("PZPOTRF returned info:", itoa(info)))
5053 : :
5054 : : ! PZPOTRI computes the inverse of a complex Hermitian positive definite
5055 : : ! distributed matrix sub( A ) = A(IA:IA+N-1,JA:JA+N-1) using the
5056 : : ! Cholesky factorization sub( A ) = U**H*U or L*L**H computed by PZPOTRF.
5057 : : call PZPOTRI(uplo, mm, mat%buffer_cplx, 1, 1, mat%desc, info)
5058 : : ABI_CHECK(info == 0, sjoin("PZPOTRI returned info:", itoa(info)))
5059 : :
5060 : : full__ = .True.; if (present(full)) full__ = full
5061 : : if (full__) then
5062 : : ! Only the uplo part contains the inverse so we need to fill the other triangular part.
5063 : : ! 1) Fill the missing triangle with zeros and copy results to work_mat
5064 : : ! 2) Call pzgeadd to compute: sub(C) := beta*sub(C) + alpha*op(sub(A))
5065 : : ! 3) Divide diagonal elements by two.
5066 : :
5067 : : do il2=1,mat%size_local(2)
5068 : : iglob2 = mat%loc2gcol(il2)
5069 : : do il1=1,mat%size_local(1)
5070 : : iglob1 = mat%loc2grow(il1)
5071 : : if (uplo == "L" .and. iglob2 > iglob1) mat%buffer_cplx(il1, il2) = zero
5072 : : if (uplo == "U" .and. iglob2 < iglob1) mat%buffer_cplx(il1, il2) = zero
5073 : : end do
5074 : : end do
5075 : :
5076 : : call mat%copy(work_mat, empty=.False.)
5077 : :
5078 : : ! call pzgeadd(trans, m, n, alpha, a, ia, ja, desca, beta, c, ic, jc, descc)
5079 : : ! sub(C) := beta*sub(C) + alpha*op(sub(A))
5080 : : call pzgeadd("C", mm, mm, cone, work_mat%buffer_cplx, 1, 1, work_mat%desc, &
5081 : : cone, mat%buffer_cplx, 1, 1, mat%desc)
5082 : : call work_mat%free()
5083 : :
5084 : : do il2=1,mat%size_local(2)
5085 : : iglob2 = mat%loc2gcol(il2)
5086 : : do il1=1,mat%size_local(1)
5087 : : iglob1 = mat%loc2grow(il1)
5088 : : if (iglob2 == iglob1) mat%buffer_cplx(il1, il2) = half * mat%buffer_cplx(il1, il2)
5089 : : end do
5090 : : end do
5091 : : end if ! full__
5092 : : #endif
5093 : :
5094 : 0 : end subroutine slkmat_dp_hpd_invert
5095 : : !!***
5096 : :
5097 : : !----------------------------------------------------------------------
5098 : :
5099 : : !!****f* m_slk/slkmat_sp_hpd_invert
5100 : : !! NAME
5101 : : !! slkmat_sp_hpd_invert
5102 : : !!
5103 : : !! FUNCTION
5104 : : !! Compute the inverse of an Hermitian positive definite matrix (Cholesky factorization).
5105 : : !! Only complex matrices (buffer_cplx) are supported.
5106 : : !!
5107 : : !! INPUTS
5108 : : !! uplo: global input
5109 : : !! = 'U': Upper triangle of sub( A ) is stored;
5110 : : !! = 'L': Lower triangle of sub( A ) is stored.
5111 : : !! [full]: If full PBLAS matrix is needed. Default: True
5112 : : !!
5113 : : !! SIDE EFFECTS
5114 : : !! mat= The object storing the local buffer, the array descriptor, the context, etc.
5115 : : !! On entry, this array contains the local pieces of the N-by-N Hermitian distributed matrix sub( A ) to be factored.
5116 : : !! If UPLO = 'U', the leading N-by-N upper triangular part of sub( A ) contains the upper triangular part of the matrix,
5117 : : !! and its strictly lower triangular part is not referenced.
5118 : : !! If UPLO = 'L', the leading N-by-N lower triangular part of sub( A ) contains the lower triangular part of the distribu-
5119 : : !! ted matrix, and its strictly upper triangular part is not referenced.
5120 : : !! On exit, the local pieces of the upper or lower triangle of the (Hermitian) inverse of sub( A )
5121 : : !!
5122 : : !! SOURCE
5123 : :
5124 : 0 : subroutine slkmat_sp_hpd_invert(mat, uplo, full)
5125 : :
5126 : : !Arguments ------------------------------------
5127 : : class(slkmat_sp_t),intent(inout) :: mat
5128 : : character(len=*),intent(in) :: uplo
5129 : : logical,optional,intent(in) :: full
5130 : :
5131 : : #ifdef HAVE_LINALG_SCALAPACK
5132 : : !Local variables ------------------------------
5133 : : !scalars
5134 : : integer :: info, mm, il1, il2, iglob1, iglob2
5135 : : type(slkmat_sp_t) :: work_mat
5136 : : logical :: full__
5137 : : !************************************************************************
5138 : :
5139 : : ABI_CHECK(allocated(mat%buffer_cplx), "buffer_cplx not allocated")
5140 : :
5141 : : ! ZPOTRF computes the Cholesky factorization of a complex Hermitian positive definite.
5142 : : ! A = U**H * U, if UPLO = 'U', or
5143 : : ! A = L * L**H, if UPLO = 'L',
5144 : : mm = mat%size_global(1)
5145 : : call PCPOTRF(uplo, mm, mat%buffer_cplx, 1, 1, mat%desc, info)
5146 : : ABI_CHECK(info == 0, sjoin("PCPOTRF returned info:", itoa(info)))
5147 : :
5148 : : ! PZPOTRI computes the inverse of a complex Hermitian positive definite
5149 : : ! distributed matrix sub( A ) = A(IA:IA+N-1,JA:JA+N-1) using the
5150 : : ! Cholesky factorization sub( A ) = U**H*U or L*L**H computed by PZPOTRF.
5151 : : call PCPOTRI(uplo, mm, mat%buffer_cplx, 1, 1, mat%desc, info)
5152 : : ABI_CHECK(info == 0, sjoin("PCPOTRI returned info:", itoa(info)))
5153 : :
5154 : : full__ = .True.; if (present(full)) full__ = full
5155 : : if (full__) then
5156 : : ! Only the uplo part contains the inverse so we need to fill the other triangular part.
5157 : : ! 1) Fill the missing triangle with zeros and copy results to work_mat
5158 : : ! 2) Call pzgeadd to compute: sub(C) := beta*sub(C) + alpha*op(sub(A))
5159 : : ! 3) Divide diagonal elements by two.
5160 : :
5161 : : do il2=1,mat%size_local(2)
5162 : : iglob2 = mat%loc2gcol(il2)
5163 : : do il1=1,mat%size_local(1)
5164 : : iglob1 = mat%loc2grow(il1)
5165 : : if (uplo == "L" .and. iglob2 > iglob1) mat%buffer_cplx(il1, il2) = zero_sp
5166 : : if (uplo == "U" .and. iglob2 < iglob1) mat%buffer_cplx(il1, il2) = zero_sp
5167 : : end do
5168 : : end do
5169 : :
5170 : : call mat%copy(work_mat, empty=.False.)
5171 : :
5172 : : ! call pzgeadd(trans, m, n, alpha, a, ia, ja, desca, beta, c, ic, jc, descc)
5173 : : ! sub(C) := beta*sub(C) + alpha*op(sub(A))
5174 : : call pcgeadd("C", mm, mm, cone_sp, work_mat%buffer_cplx, 1, 1, work_mat%desc, &
5175 : : cone_sp, mat%buffer_cplx, 1, 1, mat%desc)
5176 : : call work_mat%free()
5177 : :
5178 : : do il2=1,mat%size_local(2)
5179 : : iglob2 = mat%loc2gcol(il2)
5180 : : do il1=1,mat%size_local(1)
5181 : : iglob1 = mat%loc2grow(il1)
5182 : : if (iglob2 == iglob1) mat%buffer_cplx(il1, il2) = 0.5_sp * mat%buffer_cplx(il1, il2)
5183 : : end do
5184 : : end do
5185 : : end if ! full__
5186 : : #endif
5187 : :
5188 : 0 : end subroutine slkmat_sp_hpd_invert
5189 : : !!***
5190 : :
5191 : : !----------------------------------------------------------------------
5192 : :
5193 : : !!****f* m_slk/slkmat_dp_ptrans
5194 : : !! NAME
5195 : : !! slkmat_dp_ptrans
5196 : : !!
5197 : : !! FUNCTION
5198 : : !! Transposes a matrix
5199 : : !!
5200 : : !! sub( C ) := beta*sub( C ) + alpha*op( sub( A ) )
5201 : : !!
5202 : : !! where
5203 : : !!
5204 : : !! sub( C ) denotes C(IC:IC+M-1,JC:JC+N-1),
5205 : : !! sub( A ) denotes A(IA:IA+N-1,JA:JA+M-1), and, op( X ) = X'.
5206 : : !!
5207 : : !! Thus, op( sub( A ) ) denotes A(IA:IA+N-1,JA:JA+M-1)'.
5208 : : !! Beta is a scalar, sub( C ) is an m by n submatrix, and sub( A ) is an n by m submatrix.
5209 : : !!
5210 : : !! out_mat is initialized by the routine with the processor of in_mat.
5211 : : !!
5212 : : !! INPUTS
5213 : : !! trans= "N" for the transpose (p?tranu), "C" for the conjugate transpose (p?tranc).
5214 : : !! Ignored for real matrices.
5215 : : !! [out_gshape(2)]: Global shape of out_mat. Default: transpose of the global shape of in_mat.
5216 : : !! [size_blocs(2)]: Block sizes of out_mat. Default: one-dimensional column distribution
5217 : : !! [in_mat%size_global(2), ceiling(in_mat%size_global(1) / npcol)].
5218 : : !! [alpha], [beta]: Scalars in the formula above. Default: alpha = 1, beta = 0.
5219 : : !! Only the real part is used for real matrices.
5220 : : !! [ija(2)]: (global) The row and column indices in the distributed matrix in_mat indicating
5221 : : !! the first row and the first column of the submatrix sub(A), respectively.
5222 : : !! [ijc(2)]: (global) The row and column indices in the distributed matrix out_mat
5223 : : !! indicating the first row and the first column of the submatrix sub(C), respectively.
5224 : : !! [free]: True to deallocate in_mat. Default: False
5225 : : !!
5226 : : !! SOURCE
5227 : :
5228 : 0 : subroutine slkmat_dp_ptrans(in_mat, trans, out_mat, &
5229 : : out_gshape, ija, ijc, size_blocs, alpha, beta, free) ! optional
5230 : :
5231 : : !Arguments ------------------------------------
5232 : : class(slkmat_dp_t),intent(inout) :: in_mat
5233 : : character(len=1),intent(in) :: trans
5234 : : class(slkmat_dp_t),intent(inout) :: out_mat
5235 : : integer,optional,intent(in) :: out_gshape(2), size_blocs(2), ija(2), ijc(2)
5236 : : complex(dp),optional,intent(in) :: alpha, beta
5237 : : logical,optional,intent(in) :: free
5238 : :
5239 : : !Local variables-------------------------------
5240 : : integer :: sb, mm, nn, size_blocs__(2)
5241 : : real(dp) :: ralpha__, rbeta__
5242 : : integer :: ija__(2), ijc__(2)
5243 : : complex(dp) :: calpha__, cbeta__
5244 : : ! *************************************************************************
5245 : :
5246 : 0 : ija__ = [1, 1]; if (present(ija)) ija__ = ija
5247 : 0 : ijc__ = [1, 1]; if (present(ijc)) ijc__ = ijc
5248 : :
5249 : : ! transposed output (sub)matrix has shape (nn, mm)
5250 [ # # ]: 0 : if (present(out_gshape)) then
5251 : 0 : nn = out_gshape(1)
5252 : 0 : mm = out_gshape(2)
5253 : : else
5254 : 0 : nn = in_mat%size_global(2)
5255 : 0 : mm = in_mat%size_global(1)
5256 : : end if
5257 : :
5258 [ # # ]: 0 : if (present(size_blocs)) then
5259 : 0 : size_blocs__ = size_blocs
5260 : : else
5261 : : ! FIXME: This can cause problems if I start to use round-robin distribution in GWR!!!!!
5262 : 0 : size_blocs__(1) = in_mat%size_global(2)
5263 : 0 : sb = in_mat%size_global(1) / in_mat%processor%grid%dims(2)
5264 [ # # ]: 0 : if (mod(in_mat%size_global(1), in_mat%processor%grid%dims(2)) /= 0) sb = sb + 1
5265 : 0 : size_blocs__(2) = sb
5266 : : !size_blocs__(2) = in_mat%size_blocs(1); size_blocs__(1) = in_mat%size_blocs(2)
5267 : : end if
5268 : :
5269 : 0 : call out_mat%init(nn, mm, in_mat%processor, in_mat%istwf_k, size_blocs=size_blocs__)
5270 : :
5271 : : ! prototype: call pdtran(m, n, alpha, a, ia, ja, desca, beta, c, ic, jc, descc)
5272 : :
5273 [ # # ]: 0 : if (allocated(in_mat%buffer_cplx)) then
5274 : : #ifdef HAVE_LINALG_SCALAPACK
5275 : : select case (trans)
5276 : : case ("N")
5277 : : ! sub(C) := beta*sub(C) + alpha*sub(A)',
5278 : : calpha__ = cone; if (present(alpha)) calpha__ = alpha
5279 : : cbeta__ = czero; if (present(beta)) cbeta__ = beta
5280 : : call pztranu(nn, mm, calpha__, in_mat%buffer_cplx, ija__(1), ija__(2), &
5281 : : in_mat%desc, cbeta__, out_mat%buffer_cplx, ijc__(1), ijc__(2), out_mat%desc)
5282 : :
5283 : : case ("C")
5284 : : ! sub(C) := beta * sub(C) + alpha * conjg(sub(A)')
5285 : : calpha__ = cone; if (present(alpha)) calpha__ = alpha
5286 : : cbeta__ = czero; if (present(beta)) cbeta__ = beta
5287 : : call pztranc(nn, mm, calpha__, in_mat%buffer_cplx, ija__(1), ija__(2), &
5288 : : in_mat%desc, cbeta__, out_mat%buffer_cplx, ijc__(1), ijc__(2), out_mat%desc)
5289 : :
5290 : : case default
5291 : : ABI_ERROR(sjoin("Invalid value for trans:", trans))
5292 : : end select
5293 : :
5294 : : else if (allocated(in_mat%buffer_real)) then
5295 : : ralpha__ = one; if (present(alpha)) ralpha__ = real(alpha)
5296 : : rbeta__ = zero; if (present(beta)) rbeta__ = real(beta)
5297 : : call pdtran(nn, mm, ralpha__, in_mat%buffer_real, ija__(1), ija__(2), &
5298 : : in_mat%desc, rbeta__, out_mat%buffer_real, ijc__(1), ijc__(2), out_mat%desc)
5299 : : #endif
5300 : : else
5301 : 0 : ABI_ERROR("Neither buffer_cplx nor buffer_real are allocated!")
5302 : : end if
5303 : :
5304 [ # # ]: 0 : if (present(free)) then
5305 [ # # ]: 0 : if (free) call in_mat%free()
5306 : : end if
5307 : :
5308 : 0 : end subroutine slkmat_dp_ptrans
5309 : : !!***
5310 : :
5311 : : !!****f* m_slk/slkmat_sp_ptrans
5312 : : !! NAME
5313 : : !! slkmat_sp_ptrans
5314 : : !!
5315 : : !! FUNCTION
5316 : : !! Transposes a matrix
5317 : : !!
5318 : : !! sub( C ) := beta*sub( C ) + alpha*op( sub( A ) )
5319 : : !!
5320 : : !! where
5321 : : !!
5322 : : !! sub( C ) denotes C(IC:IC+M-1,JC:JC+N-1),
5323 : : !! sub( A ) denotes A(IA:IA+N-1,JA:JA+M-1), and, op( X ) = X'.
5324 : : !!
5325 : : !! Thus, op( sub( A ) ) denotes A(IA:IA+N-1,JA:JA+M-1)'.
5326 : : !! Beta is a scalar, sub( C ) is an m by n submatrix, and sub( A ) is an n by m submatrix.
5327 : : !!
5328 : : !! out_mat is initialized by the routine with the processor of in_mat.
5329 : : !!
5330 : : !! INPUTS
5331 : : !! trans= "N" for the transpose (p?tranu), "C" for the conjugate transpose (p?tranc).
5332 : : !! Ignored for real matrices.
5333 : : !! [out_gshape(2)]: Global shape of out_mat. Default: transpose of the global shape of in_mat.
5334 : : !! [size_blocs(2)]: Block sizes of out_mat. Default: one-dimensional column distribution
5335 : : !! [in_mat%size_global(2), ceiling(in_mat%size_global(1) / npcol)].
5336 : : !! [alpha], [beta]: Scalars in the formula above. Default: alpha = 1, beta = 0.
5337 : : !! Only the real part is used for real matrices.
5338 : : !! [ija(2)]: (global) The row and column indices in the distributed matrix in_mat indicating
5339 : : !! the first row and the first column of the submatrix sub(A), respectively.
5340 : : !! [ijc(2)]: (global) The row and column indices in the distributed matrix out_mat
5341 : : !! indicating the first row and the first column of the submatrix sub(C), respectively.
5342 : : !! [free]: True to deallocate in_mat. Default: False
5343 : : !!
5344 : : !! SOURCE
5345 : :
5346 : 0 : subroutine slkmat_sp_ptrans(in_mat, trans, out_mat, &
5347 : : out_gshape, ija, ijc, size_blocs, alpha, beta, free) ! optional
5348 : :
5349 : : !Arguments ------------------------------------
5350 : : class(slkmat_sp_t),intent(inout) :: in_mat
5351 : : character(len=1),intent(in) :: trans
5352 : : class(slkmat_sp_t),intent(inout) :: out_mat
5353 : : integer,optional,intent(in) :: out_gshape(2), size_blocs(2), ija(2), ijc(2)
5354 : : complex(sp),optional,intent(in) :: alpha, beta
5355 : : logical,optional,intent(in) :: free
5356 : :
5357 : : !Local variables-------------------------------
5358 : : integer :: sb, mm, nn, size_blocs__(2)
5359 : : real(sp) :: ralpha__, rbeta__
5360 : : integer :: ija__(2), ijc__(2)
5361 : : complex(sp) :: calpha__, cbeta__
5362 : : ! *************************************************************************
5363 : :
5364 : 0 : ija__ = [1, 1]; if (present(ija)) ija__ = ija
5365 : 0 : ijc__ = [1, 1]; if (present(ijc)) ijc__ = ijc
5366 : :
5367 : : ! transposed output (sub)matrix has shape (nn, mm)
5368 [ # # ]: 0 : if (present(out_gshape)) then
5369 : 0 : nn = out_gshape(1)
5370 : 0 : mm = out_gshape(2)
5371 : : else
5372 : 0 : nn = in_mat%size_global(2)
5373 : 0 : mm = in_mat%size_global(1)
5374 : : end if
5375 : :
5376 [ # # ]: 0 : if (present(size_blocs)) then
5377 : 0 : size_blocs__ = size_blocs
5378 : : else
5379 : : ! FIXME: This can cause problems if I start to use round-robin distribution in GWR!!!!!
5380 : 0 : size_blocs__(1) = in_mat%size_global(2)
5381 : 0 : sb = in_mat%size_global(1) / in_mat%processor%grid%dims(2)
5382 [ # # ]: 0 : if (mod(in_mat%size_global(1), in_mat%processor%grid%dims(2)) /= 0) sb = sb + 1
5383 : 0 : size_blocs__(2) = sb
5384 : : !size_blocs__(2) = in_mat%size_blocs(1); size_blocs__(1) = in_mat%size_blocs(2)
5385 : : end if
5386 : :
5387 : 0 : call out_mat%init(nn, mm, in_mat%processor, in_mat%istwf_k, size_blocs=size_blocs__)
5388 : :
5389 : : ! prototype: call pdtran(m, n, alpha, a, ia, ja, desca, beta, c, ic, jc, descc)
5390 : :
5391 [ # # ]: 0 : if (allocated(in_mat%buffer_cplx)) then
5392 : : #ifdef HAVE_LINALG_SCALAPACK
5393 : : select case (trans)
5394 : : case ("N")
5395 : : ! sub(C) := beta*sub(C) + alpha*sub(A)',
5396 : : calpha__ = cone_sp; if (present(alpha)) calpha__ = alpha
5397 : : cbeta__ = czero_sp; if (present(beta)) cbeta__ = beta
5398 : : call pctranu(nn, mm, calpha__, in_mat%buffer_cplx, ija__(1), ija__(2), &
5399 : : in_mat%desc, cbeta__, out_mat%buffer_cplx, ijc__(1), ijc__(2), out_mat%desc)
5400 : :
5401 : : case ("C")
5402 : : ! sub(C) := beta * sub(C) + alpha * conjg(sub(A)')
5403 : : calpha__ = cone_sp; if (present(alpha)) calpha__ = alpha
5404 : : cbeta__ = czero_sp; if (present(beta)) cbeta__ = beta
5405 : : call pctranc(nn, mm, calpha__, in_mat%buffer_cplx, ija__(1), ija__(2), &
5406 : : in_mat%desc, cbeta__, out_mat%buffer_cplx, ijc__(1), ijc__(2), out_mat%desc)
5407 : :
5408 : : case default
5409 : : ABI_ERROR(sjoin("Invalid value for trans:", trans))
5410 : : end select
5411 : :
5412 : : else if (allocated(in_mat%buffer_real)) then
5413 : : ralpha__ = one_sp; if (present(alpha)) ralpha__ = real(alpha)
5414 : : rbeta__ = zero_sp; if (present(beta)) rbeta__ = real(beta)
5415 : : call pstran(nn, mm, ralpha__, in_mat%buffer_real, ija__(1), ija__(2), &
5416 : : in_mat%desc, rbeta__, out_mat%buffer_real, ijc__(1), ijc__(2), out_mat%desc)
5417 : : #endif
5418 : : else
5419 : 0 : ABI_ERROR("Neither buffer_cplx nor buffer_real are allocated!")
5420 : : end if
5421 : :
5422 [ # # ]: 0 : if (present(free)) then
5423 [ # # ]: 0 : if (free) call in_mat%free()
5424 : : end if
5425 : :
5426 : 0 : end subroutine slkmat_sp_ptrans
5427 : : !!***
5428 : :
5429 : : !----------------------------------------------------------------------
5430 : :
5431 : : !!****f* m_slk/basemat_change_size_blocs
5432 : : !! NAME
5433 : : !! basemat_change_size_blocs
5434 : : !!
5435 : : !! FUNCTION
5436 : : !! Change the block sizes, return new matrix in out_mat
5437 : : !! Uses p?gemr2d with the BLACS context of the output processor: its grid must include all the
5438 : : !! processes of the grid of in_mat. All these processes must call the routine.
5439 : : !!
5440 : : !! INPUTS
5441 : : !! [size_blocs(2)]: Block sizes of out_mat. Default: see basemat_init.
5442 : : !! [processor]: Processor used to initialize out_mat. Default: in_mat%processor.
5443 : : !! [free]: True if `in_mat` should be deallocated. Default: False
5444 : : !!
5445 : : !! OUTPUT
5446 : : !! out_mat: New matrix with the same global shape and the same values as in_mat.
5447 : : !!
5448 : : !! SOURCE
5449 : :
5450 [ # # ]: 0 : subroutine basemat_change_size_blocs(in_mat, out_mat, &
5451 : : size_blocs, processor, free) ! Optional
5452 : :
5453 : : !Arguments ------------------------------------
5454 : : class(basemat_t),target,intent(inout) :: in_mat
5455 : : class(basemat_t),intent(out) :: out_mat
5456 : : integer,optional,intent(in) :: size_blocs(2)
5457 : : class(slk_processor_t), target, optional,intent(in) :: processor
5458 : : logical,optional,intent(in) :: free
5459 : :
5460 : : !Local variables-------------------------------
5461 : : type(slk_processor_t), pointer :: processor__
5462 : : ! *************************************************************************
5463 : :
5464 [ # # # # ]: 0 : processor__ => in_mat%processor; if (present(processor)) processor__ => processor
5465 : :
5466 [ # # ]: 0 : if (present(size_blocs)) then
5467 : 0 : call out_mat%init(in_mat%size_global(1), in_mat%size_global(2), processor__, in_mat%istwf_k, size_blocs=size_blocs)
5468 : : else
5469 : 0 : call out_mat%init(in_mat%size_global(1), in_mat%size_global(2), processor__, in_mat%istwf_k)
5470 : : end if
5471 : :
5472 : : !write(std_out, *)"out_mat%size_global", out_mat%size_global
5473 : : !call in_mat%print(header="input matrix in by basemat_change_size_blocs")
5474 : : !call out_mat%print(header="output matrix generated by basemat_change_size_blocs")
5475 : :
5476 [ # # ]: 0 : ABI_CHECK(same_type_as(in_mat, out_mat), "in_mat and out_mat should have same type!")
5477 : :
5478 : : ! p?gemr2d: Copies a submatrix from one general rectangular matrix to another.
5479 : : ! prototype
5480 : : !call pzgemr2d(m, n, a, ia, ja, desca, b, ib, jb, descb, comm)
5481 : :
5482 : : #ifdef HAVE_LINALG_SCALAPACK
5483 : : select type (in_mat)
5484 : : class is (slkmat_dp_t)
5485 : : select type (out_mat)
5486 : : class is (slkmat_dp_t)
5487 : : if (allocated(in_mat%buffer_cplx)) then
5488 : : ABI_CHECK_IEQ(kind(in_mat%buffer_cplx), kind(out_mat%buffer_cplx), "Different kind")
5489 : : ABI_CHECK(allocated(out_mat%buffer_cplx), "out_mat%buffer_cplx should be allocated")
5490 : : call pzgemr2d(in_mat%size_global(1), in_mat%size_global(2), &
5491 : : in_mat%buffer_cplx, 1, 1, in_mat%desc, &
5492 : : out_mat%buffer_cplx, 1, 1, out_mat%desc, &
5493 : : processor__%grid%comm)
5494 : :
5495 : : else if (allocated(in_mat%buffer_real)) then
5496 : : ABI_CHECK_IEQ(kind(in_mat%buffer_real), kind(out_mat%buffer_real), "Different kind")
5497 : : ABI_CHECK(allocated(out_mat%buffer_real), "out_mat%buffer_real should be allocated")
5498 : : call pdgemr2d(in_mat%size_global(1), in_mat%size_global(2), &
5499 : : in_mat%buffer_real, 1, 1, in_mat%desc, &
5500 : : out_mat%buffer_real, 1, 1, out_mat%desc, &
5501 : : processor__%grid%comm)
5502 : : else
5503 : : ABI_ERROR("Neither buffer_cplx nor buffer_real are allocated!")
5504 : : end if
5505 : : end select
5506 : :
5507 : : class is (slkmat_sp_t)
5508 : : select type (out_mat)
5509 : : class is (slkmat_sp_t)
5510 : : if (allocated(in_mat%buffer_cplx)) then
5511 : : ABI_CHECK_IEQ(kind(in_mat%buffer_cplx), kind(out_mat%buffer_cplx), "Different kind")
5512 : :
5513 : : ABI_CHECK(allocated(out_mat%buffer_cplx), "out_mat%buffer should be allocated")
5514 : : call pcgemr2d(in_mat%size_global(1), in_mat%size_global(2), &
5515 : : in_mat%buffer_cplx, 1, 1, in_mat%desc, &
5516 : : out_mat%buffer_cplx, 1, 1, out_mat%desc, &
5517 : : processor__%grid%comm)
5518 : :
5519 : : else if (allocated(in_mat%buffer_real)) then
5520 : : ABI_CHECK_IEQ(kind(in_mat%buffer_real), kind(out_mat%buffer_real), "Different kind")
5521 : : ABI_CHECK(allocated(out_mat%buffer_real), "out_mat%buffer_real should be allocated")
5522 : : call psgemr2d(in_mat%size_global(1), in_mat%size_global(2), &
5523 : : in_mat%buffer_real, 1, 1, in_mat%desc, &
5524 : : out_mat%buffer_real, 1, 1, out_mat%desc, &
5525 : : processor__%grid%comm)
5526 : : else
5527 : : ABI_ERROR("Neither buffer_cplx nor buffer_real are allocated!")
5528 : : end if
5529 : : end select
5530 : :
5531 : : class default
5532 : : ABI_ERROR("Wrong class")
5533 : : end select
5534 : : #endif
5535 : :
5536 [ # # ]: 0 : if (present(free)) then
5537 [ # # ]: 0 : if (free) call in_mat%free()
5538 : : end if
5539 : :
5540 : 0 : end subroutine basemat_change_size_blocs
5541 : : !!***
5542 : :
5543 : : !----------------------------------------------------------------------
5544 : :
5545 : : !!****f* m_slk/slkmat_dp_cut
5546 : : !! NAME
5547 : : !! slkmat_dp_cut
5548 : : !!
5549 : : !! FUNCTION
5550 : : !! Extract submatrix of shape (glob_nrows, glob_ncols) starting at `ija` from `in_mat`
5551 : : !! and create new matrix with `size_blocs` and `processor`
5552 : : !! Uses p?gemr2d with the BLACS context of the output processor: its grid must include all the
5553 : : !! processes of the grid of in_mat. All these processes must call the routine.
5554 : : !!
5555 : : !! INPUTS
5556 : : !! glob_nrows, glob_ncols: Global shape of the submatrix.
5557 : : !! [size_blocs(2)]: Block sizes of out_mat. Default: see basemat_init.
5558 : : !! [processor]: Processor used to initialize out_mat. Default: in_mat%processor.
5559 : : !! [ija(2)]: Global row and column indices of the first entry of the submatrix in in_mat. Default: [1, 1]
5560 : : !! [ijb(2)]: Global row and column indices where the submatrix is copied in out_mat. Default: [1, 1]
5561 : : !! [free]: True if `in_mat` should be deallocated. Default: False
5562 : : !!
5563 : : !! OUTPUT
5564 : : !! out_mat: New matrix of global shape (glob_nrows, glob_ncols).
5565 : : !!
5566 : : !! SOURCE
5567 : :
5568 [ # # ]: 0 : subroutine slkmat_dp_cut(in_mat, glob_nrows, glob_ncols, out_mat, &
5569 : : size_blocs, processor, ija, ijb, free) ! Optional
5570 : :
5571 : : !Arguments ------------------------------------
5572 : : class(slkmat_dp_t),target,intent(inout) :: in_mat
5573 : : integer,intent(in) :: glob_nrows, glob_ncols
5574 : : class(slkmat_dp_t),intent(out) :: out_mat
5575 : : integer,optional,intent(in) :: size_blocs(2)
5576 : : class(slk_processor_t), target, optional,intent(in) :: processor
5577 : : integer,optional,intent(in) :: ija(2), ijb(2)
5578 : : logical,optional,intent(in) :: free
5579 : :
5580 : : !Local variables-------------------------------
5581 : : type(slk_processor_t), pointer :: processor__
5582 : : integer :: ija__(2), ijb__(2)
5583 : : ! *************************************************************************
5584 : :
5585 : 0 : ija__ = [1, 1]; if (present(ija)) ija__ = ija
5586 : 0 : ijb__ = [1, 1]; if (present(ijb)) ijb__ = ijb
5587 : :
5588 [ # # # # ]: 0 : processor__ => in_mat%processor; if (present(processor)) processor__ => processor
5589 : :
5590 [ # # ]: 0 : if (present(size_blocs)) then
5591 : 0 : call out_mat%init(glob_nrows, glob_ncols, processor__, in_mat%istwf_k, size_blocs=size_blocs)
5592 : : else
5593 : 0 : call out_mat%init(glob_nrows, glob_ncols, processor__, in_mat%istwf_k)
5594 : : end if
5595 : : !call out_mat%print(header="output matrix generated by slkmat_dp_cut")
5596 : :
5597 : : ! p?gemr2d: Copies a submatrix from one general rectangular matrix to another.
5598 : : ! prototype
5599 : : !call pzgemr2d(m, n, a, ia, ja, desca, b, ib, jb, descb, comm)
5600 : :
5601 [ # # ]: 0 : if (allocated(in_mat%buffer_cplx)) then
5602 : : #ifdef HAVE_LINALG_SCALAPACK
5603 : : call pzgemr2d(glob_nrows, glob_ncols, &
5604 : : in_mat%buffer_cplx, ija__(1), ija__(2), in_mat%desc, &
5605 : : out_mat%buffer_cplx, ijb__(1), ijb__(2), out_mat%desc, &
5606 : : processor__%grid%comm)
5607 : :
5608 : : else if (allocated(in_mat%buffer_real)) then
5609 : : call pdgemr2d(glob_nrows, glob_ncols, &
5610 : : in_mat%buffer_real, ija__(1), ija__(2), in_mat%desc, &
5611 : : out_mat%buffer_real, ijb__(1), ijb__(2), out_mat%desc, &
5612 : : processor__%grid%comm)
5613 : : #endif
5614 : : else
5615 : 0 : ABI_ERROR("Neither buffer_cplx nor buffer_real are allocated!")
5616 : : end if
5617 : :
5618 [ # # ]: 0 : if (present(free)) then
5619 [ # # ]: 0 : if (free) call in_mat%free()
5620 : : end if
5621 : :
5622 : 0 : end subroutine slkmat_dp_cut
5623 : : !!***
5624 : :
5625 : : !----------------------------------------------------------------------
5626 : :
5627 : : !!****f* m_slk/slkmat_sp_cut
5628 : : !! NAME
5629 : : !! slkmat_sp_cut
5630 : : !!
5631 : : !! FUNCTION
5632 : : !! Extract submatrix of shape (glob_nrows, glob_ncols) starting at `ija` from `in_mat`
5633 : : !! and create new matrix with `size_blocs` and `processor`
5634 : : !! Uses p?gemr2d with the BLACS context of the output processor: its grid must include all the
5635 : : !! processes of the grid of in_mat. All these processes must call the routine.
5636 : : !!
5637 : : !! INPUTS
5638 : : !! glob_nrows, glob_ncols: Global shape of the submatrix.
5639 : : !! [size_blocs(2)]: Block sizes of out_mat. Default: see basemat_init.
5640 : : !! [processor]: Processor used to initialize out_mat. Default: in_mat%processor.
5641 : : !! [ija(2)]: Global row and column indices of the first entry of the submatrix in in_mat. Default: [1, 1]
5642 : : !! [ijb(2)]: Global row and column indices where the submatrix is copied in out_mat. Default: [1, 1]
5643 : : !! [free]: True if `in_mat` should be deallocated. Default: False
5644 : : !!
5645 : : !! OUTPUT
5646 : : !! out_mat: New matrix of global shape (glob_nrows, glob_ncols).
5647 : : !!
5648 : : !! SOURCE
5649 : :
5650 [ # # ]: 0 : subroutine slkmat_sp_cut(in_mat, glob_nrows, glob_ncols, out_mat, &
5651 : : size_blocs, processor, ija, ijb, free) ! Optional
5652 : :
5653 : : !Arguments ------------------------------------
5654 : : class(slkmat_sp_t),target,intent(inout) :: in_mat
5655 : : integer,intent(in) :: glob_nrows, glob_ncols
5656 : : class(slkmat_sp_t),intent(out) :: out_mat
5657 : : integer,optional,intent(in) :: size_blocs(2)
5658 : : class(slk_processor_t), target, optional,intent(in) :: processor
5659 : : integer,optional,intent(in) :: ija(2), ijb(2)
5660 : : logical,optional,intent(in) :: free
5661 : :
5662 : : !Local variables-------------------------------
5663 : : type(slk_processor_t), pointer :: processor__
5664 : : integer :: ija__(2), ijb__(2)
5665 : : ! *************************************************************************
5666 : :
5667 : 0 : ija__ = [1, 1]; if (present(ija)) ija__ = ija
5668 : 0 : ijb__ = [1, 1]; if (present(ijb)) ijb__ = ijb
5669 : :
5670 [ # # # # ]: 0 : processor__ => in_mat%processor; if (present(processor)) processor__ => processor
5671 : :
5672 [ # # ]: 0 : if (present(size_blocs)) then
5673 : 0 : call out_mat%init(glob_nrows, glob_ncols, processor__, in_mat%istwf_k, size_blocs=size_blocs)
5674 : : else
5675 : 0 : call out_mat%init(glob_nrows, glob_ncols, processor__, in_mat%istwf_k)
5676 : : end if
5677 : : !call out_mat%print(header="output matrix generated by slkmat_dp_cut")
5678 : :
5679 : : ! p?gemr2d: Copies a submatrix from one general rectangular matrix to another.
5680 : : ! prototype
5681 : : !call pzgemr2d(m, n, a, ia, ja, desca, b, ib, jb, descb, comm)
5682 : :
5683 [ # # ]: 0 : if (allocated(in_mat%buffer_cplx)) then
5684 : : #ifdef HAVE_LINALG_SCALAPACK
5685 : : call pcgemr2d(glob_nrows, glob_ncols, &
5686 : : in_mat%buffer_cplx, ija__(1), ija__(2), in_mat%desc, &
5687 : : out_mat%buffer_cplx, ijb__(1), ijb__(2), out_mat%desc, &
5688 : : processor__%grid%comm)
5689 : :
5690 : : else if (allocated(in_mat%buffer_real)) then
5691 : : call psgemr2d(glob_nrows, glob_ncols, &
5692 : : in_mat%buffer_real, ija__(1), ija__(2), in_mat%desc, &
5693 : : out_mat%buffer_real, ijb__(1), ijb__(2), out_mat%desc, &
5694 : : processor__%grid%comm)
5695 : : #endif
5696 : : else
5697 : 0 : ABI_ERROR("Neither buffer_cplx nor buffer_real are allocated!")
5698 : : end if
5699 : :
5700 [ # # ]: 0 : if (present(free)) then
5701 [ # # ]: 0 : if (free) call in_mat%free()
5702 : : end if
5703 : :
5704 : 0 : end subroutine slkmat_sp_cut
5705 : : !!***
5706 : :
5707 : : !----------------------------------------------------------------------
5708 : :
5709 : : !!****f* m_slk/slkmat_dp_take_from
5710 : : !! NAME
5711 : : !! slkmat_dp_take_from
5712 : : !!
5713 : : !! FUNCTION
5714 : : !! Take values from source
5715 : : !! NB: This routine should be called by all procs owning mat and source.
5716 : : !! Uses p?gemr2d with the BLACS context of source: the grid of source must include all the processes
5717 : : !! of the grid of out_mat. out_mat and source must have the same global shape and the same istwf_k
5718 : : !! but they can have different grids and block sizes.
5719 : : !! On the processes that do not own out_mat, out_mat must never have been initialized
5720 : : !! (size_global = [-1, -1]): then desc(CTXT_) is set to -1. A freed matrix has size_global = [0, 0].
5721 : : !!
5722 : : !! INPUTS
5723 : : !! [ija(2)]: Global row and column indices of the first entry to copy in source. Default: [1, 1]
5724 : : !! [ijb(2)]: Global row and column indices of the first entry to write in out_mat. Default: [1, 1]
5725 : : !! [free]: True if source should be deallocated. Default: False
5726 : : !!
5727 : : !! SIDE EFFECTS
5728 : : !! out_mat: Filled with the values of source.
5729 : : !!
5730 : : !! SOURCE
5731 : :
5732 : 0 : subroutine slkmat_dp_take_from(out_mat, source, &
5733 : : ija, ijb, free) ! optional
5734 : :
5735 : : !Arguments ------------------------------------
5736 : : class(slkmat_dp_t),intent(inout) :: out_mat
5737 : : class(slkmat_dp_t),intent(inout) :: source
5738 : : integer,optional,intent(in) :: ija(2), ijb(2)
5739 : : logical,optional,intent(in) :: free
5740 : :
5741 : : !Local variables-------------------------------
5742 : : integer :: mm, nn
5743 : : character(len=500) :: msg
5744 : : integer :: ija__(2), ijb__(2)
5745 : : ! *************************************************************************
5746 : :
5747 : : ! prototype
5748 : : !call pzgemr2d(m, n, a, ia, ja, desca, b, ib, jb, descb, comm)
5749 : :
5750 : : ! Take care when context A is disjoint from context B. The general rules for which parameters need to be set are:
5751 : : !
5752 : : ! - All calling processes must have the correct m and n.
5753 : : ! - Processes in context A must correctly define all parameters describing A.
5754 : : ! - Processes in context B must correctly define all parameters describing B.
5755 : : ! - Processes which are not members of context A must pass ctxt_a = -1 and need not set other parameters describing A.
5756 : : ! - Processes which are not members of contextB must pass ctxt_b = -1 and need not set other parameters describing B.
5757 : :
5758 : 0 : mm = source%size_global(1)
5759 : 0 : nn = source%size_global(2)
5760 : :
5761 : 0 : ija__ = [1, 1]; if (present(ija)) ija__ = ija
5762 : 0 : ijb__ = [1, 1]; if (present(ijb)) ijb__ = ijb
5763 : :
5764 [ # # # # : 0 : if (all(out_mat%size_global == -1)) then
# # ]
5765 : 0 : out_mat%desc(CTXT_) = -1
5766 : : else
5767 [ # # ]: 0 : ABI_CHECK_IEQ(out_mat%istwf_k, source%istwf_k, "istwfk_mat /= istwfk_source")
5768 [ # # # # : 0 : if (any(out_mat%size_global /= source%size_global)) then
# # ]
5769 : : msg = sjoin("Matrices should have same global shape but out_mat:", ltoa(out_mat%size_global), &
5770 [ # # ]: 0 : "source:", ltoa(source%size_global))
5771 : 0 : ABI_ERROR(msg)
5772 : : end if
5773 : : end if
5774 : :
5775 [ # # ]: 0 : if (allocated(source%buffer_cplx)) then
5776 : : #ifdef HAVE_LINALG_SCALAPACK
5777 : : call pzgemr2d(mm, nn, &
5778 : : source%buffer_cplx, ija__(1), ija__(2), source%desc, &
5779 : : out_mat%buffer_cplx, ijb__(1), ijb__(2), out_mat%desc, &
5780 : : source%processor%grid%comm)
5781 : :
5782 : : else if (allocated(source%buffer_real)) then
5783 : : call pdgemr2d(mm, nn, &
5784 : : source%buffer_real, ija__(1), ija__(2), source%desc, &
5785 : : out_mat%buffer_real,ijb__(1), ijb__(2), out_mat%desc, &
5786 : : source%processor%grid%comm)
5787 : : #endif
5788 : : else
5789 : 0 : ABI_ERROR("Neither buffer_cplx nor buffer_real are allocated!")
5790 : : end if
5791 : :
5792 [ # # ]: 0 : if (present(free)) then
5793 [ # # ]: 0 : if (free) call source%free()
5794 : : end if
5795 : :
5796 : 0 : end subroutine slkmat_dp_take_from
5797 : : !!***
5798 : :
5799 : : !----------------------------------------------------------------------
5800 : :
5801 : : !!****f* m_slk/slkmat_sp_take_from
5802 : : !! NAME
5803 : : !! slkmat_sp_take_from
5804 : : !!
5805 : : !! FUNCTION
5806 : : !! Take values from source
5807 : : !! NB: This routine should be called by all procs owning mat and source.
5808 : : !! Uses p?gemr2d with the BLACS context of source: the grid of source must include all the processes
5809 : : !! of the grid of out_mat. out_mat and source must have the same global shape and the same istwf_k
5810 : : !! but they can have different grids and block sizes.
5811 : : !! On the processes that do not own out_mat, out_mat must never have been initialized
5812 : : !! (size_global = [-1, -1]): then desc(CTXT_) is set to -1. A freed matrix has size_global = [0, 0].
5813 : : !!
5814 : : !! INPUTS
5815 : : !! [ija(2)]: Global row and column indices of the first entry to copy in source. Default: [1, 1]
5816 : : !! [ijb(2)]: Global row and column indices of the first entry to write in out_mat. Default: [1, 1]
5817 : : !! [free]: True if source should be deallocated. Default: False
5818 : : !!
5819 : : !! SIDE EFFECTS
5820 : : !! out_mat: Filled with the values of source.
5821 : : !!
5822 : : !! SOURCE
5823 : :
5824 : 0 : subroutine slkmat_sp_take_from(out_mat, source, &
5825 : : ija, ijb, free) ! optional
5826 : :
5827 : : !Arguments ------------------------------------
5828 : : class(slkmat_sp_t),intent(inout) :: out_mat
5829 : : class(slkmat_sp_t),intent(inout) :: source
5830 : : integer,optional,intent(in) :: ija(2), ijb(2)
5831 : : logical,optional,intent(in) :: free
5832 : :
5833 : : !Local variables-------------------------------
5834 : : integer :: mm, nn
5835 : : character(len=500) :: msg
5836 : : integer :: ija__(2), ijb__(2)
5837 : : ! *************************************************************************
5838 : :
5839 : : ! prototype
5840 : : !call pzgemr2d(m, n, a, ia, ja, desca, b, ib, jb, descb, comm)
5841 : :
5842 : : ! Take care when context A is disjoint from context B. The general rules for which parameters need to be set are:
5843 : : !
5844 : : ! - All calling processes must have the correct m and n.
5845 : : ! - Processes in context A must correctly define all parameters describing A.
5846 : : ! - Processes in context B must correctly define all parameters describing B.
5847 : : ! - Processes which are not members of context A must pass ctxt_a = -1 and need not set other parameters describing A.
5848 : : ! - Processes which are not members of contextB must pass ctxt_b = -1 and need not set other parameters describing B.
5849 : :
5850 : 0 : mm = source%size_global(1)
5851 : 0 : nn = source%size_global(2)
5852 : :
5853 : 0 : ija__ = [1, 1]; if (present(ija)) ija__ = ija
5854 : 0 : ijb__ = [1, 1]; if (present(ijb)) ijb__ = ijb
5855 : :
5856 [ # # # # : 0 : if (all(out_mat%size_global == -1)) then
# # ]
5857 : 0 : out_mat%desc(CTXT_) = -1
5858 : : else
5859 [ # # ]: 0 : ABI_CHECK_IEQ(out_mat%istwf_k, source%istwf_k, "istwfk_mat /= istwfk_source")
5860 [ # # # # : 0 : if (any(out_mat%size_global /= source%size_global)) then
# # ]
5861 : : msg = sjoin("Matrices should have same global shape but out_mat:", ltoa(out_mat%size_global), &
5862 [ # # ]: 0 : "source:", ltoa(source%size_global))
5863 : 0 : ABI_ERROR(msg)
5864 : : end if
5865 : : end if
5866 : :
5867 [ # # ]: 0 : if (allocated(source%buffer_cplx)) then
5868 : : #ifdef HAVE_LINALG_SCALAPACK
5869 : : call pcgemr2d(mm, nn, &
5870 : : source%buffer_cplx, ija__(1), ija__(2), source%desc, &
5871 : : out_mat%buffer_cplx, ijb__(1), ijb__(2), out_mat%desc, &
5872 : : source%processor%grid%comm)
5873 : :
5874 : : else if (allocated(source%buffer_real)) then
5875 : : call psgemr2d(mm, nn, &
5876 : : source%buffer_real, ija__(1), ija__(2), source%desc, &
5877 : : out_mat%buffer_real,ijb__(1), ijb__(2), out_mat%desc, &
5878 : : source%processor%grid%comm)
5879 : : #endif
5880 : : else
5881 : 0 : ABI_ERROR("Neither buffer_cplx nor buffer_real are allocated!")
5882 : : end if
5883 : :
5884 [ # # ]: 0 : if (present(free)) then
5885 [ # # ]: 0 : if (free) call source%free()
5886 : : end if
5887 : :
5888 : 0 : end subroutine slkmat_sp_take_from
5889 : : !!***
5890 : :
5891 : : !----------------------------------------------------------------------
5892 : :
5893 : : !!****f* m_slk/slkmat_dp_collect_cplx
5894 : : !! NAME
5895 : : !! slkmat_dp_collect_cplx
5896 : : !!
5897 : : !! FUNCTION
5898 : : !! Return on all processors the complex submatrix of shape (mm, nn) starting at position ija.
5899 : : !! NB: `out_carr` is allocated by the routine.
5900 : : !! If optional argument request is use, the routine uses non-blocking BCAST and client code is
5901 : : !! supposed to wait before accessing out_carr.
5902 : : !! Collective call: all the processes of the grid of in_mat must call the routine.
5903 : : !! The submatrix is first gathered on the master with p?gemr2d, then broadcast.
5904 : : !!
5905 : : !! INPUTS
5906 : : !! mm, nn: Global shape of the submatrix.
5907 : : !! ija(2): Global row and column indices of the first entry of the submatrix.
5908 : : !!
5909 : : !! OUTPUT
5910 : : !! out_carr(mm, nn): The submatrix, on all the processes.
5911 : : !! [request]: MPI request of the non-blocking broadcast.
5912 : : !!
5913 : : !! SOURCE
5914 : :
5915 : 0 : subroutine slkmat_dp_collect_cplx(in_mat, mm, nn, ija, out_carr, request)
5916 : :
5917 : : !Arguments ------------------------------------
5918 : : class(slkmat_dp_t),intent(in) :: in_mat
5919 : : integer,intent(in) :: mm, nn, ija(2)
5920 : : complex(dp) ABI_ASYNC, allocatable,intent(out) :: out_carr(:,:)
5921 : : integer ABI_ASYNC, optional,intent(out) :: request
5922 : :
5923 : : !Local variables-------------------------------
5924 : : integer,parameter :: master = 0
5925 : : integer :: ierr
5926 : : type(slk_processor_t) :: self_processor
5927 [ # # # # : 0 : type(slkmat_dp_t) :: out_mat
# # ]
5928 : : ! *************************************************************************
5929 : :
5930 : 0 : ABI_CHECK(allocated(in_mat%buffer_cplx), "buffer_cplx is not allocated")
5931 : :
5932 [ # # ]: 0 : if (in_mat%processor%grid%nprocs == 1) then
5933 : : ! Copy buffer and return
5934 [ # # # # : 0 : ABI_MALLOC(out_carr, (mm, nn))
# # # # #
# # # # #
# # # # ]
5935 [ # # # # ]: 0 : out_carr(:,:) = in_mat%buffer_cplx(ija(1):ija(1)+mm-1, ija(2):ija(2)+nn-1); return
5936 : : end if
5937 : :
5938 : : ! Two-step algorithm:
5939 : : ! 1) Use pzgemr2d to collect submatrix on master.
5940 : : ! 2) Master broadcasts submatrix.
5941 : :
5942 [ # # ]: 0 : if (in_mat%processor%my_rank == master) then
5943 : 0 : call self_processor%init(xmpi_comm_self)
5944 [ # # ]: 0 : call out_mat%init(mm, nn, self_processor, in_mat%istwf_k, size_blocs=[mm, nn])
5945 : : else
5946 : 0 : out_mat%desc(CTXT_) = -1
5947 : : end if
5948 : :
5949 : : #ifdef HAVE_LINALG_SCALAPACK
5950 : : call pzgemr2d(mm, nn, &
5951 : : in_mat%buffer_cplx, ija(1), ija(2), in_mat%desc, &
5952 : : out_mat%buffer_cplx, 1, 1, out_mat%desc, &
5953 : : in_mat%processor%grid%comm)
5954 : : #endif
5955 : :
5956 [ # # ]: 0 : if (in_mat%processor%my_rank == master) then
5957 [ # # ]: 0 : ABI_MOVE_ALLOC(out_mat%buffer_cplx, out_carr)
5958 : 0 : call out_mat%free()
5959 : 0 : call self_processor%free()
5960 : : else
5961 [ # # # # : 0 : ABI_MALLOC(out_carr, (mm, nn))
# # # # #
# # # # #
# # # # ]
5962 : : end if
5963 : :
5964 [ # # ]: 0 : if (present(request)) then
5965 : 0 : call xmpi_ibcast(out_carr, master, in_mat%processor%comm, request, ierr)
5966 : : else
5967 : 0 : call xmpi_bcast(out_carr, master, in_mat%processor%comm, ierr)
5968 : : end if
5969 : :
5970 [ # # # # : 0 : end subroutine slkmat_dp_collect_cplx
# # # # #
# # # #
# ]
5971 : : !!***
5972 : :
5973 : : !----------------------------------------------------------------------
5974 : :
5975 : : !!****f* m_slk/slkmat_sp_collect_cplx
5976 : : !! NAME
5977 : : !! slkmat_sp_collect_cplx
5978 : : !!
5979 : : !! FUNCTION
5980 : : !! Return on all processors the complex submatrix of shape (mm, nn) starting at position ija.
5981 : : !! NB: `out_carr` is allocated by the routine.
5982 : : !! If optional argument request is use, the routine uses non-blocking BCAST and client code is
5983 : : !! supposed to wait before accessing out_carr.
5984 : : !! Collective call: all the processes of the grid of in_mat must call the routine.
5985 : : !! The submatrix is first gathered on the master with p?gemr2d, then broadcast.
5986 : : !!
5987 : : !! INPUTS
5988 : : !! mm, nn: Global shape of the submatrix.
5989 : : !! ija(2): Global row and column indices of the first entry of the submatrix.
5990 : : !!
5991 : : !! OUTPUT
5992 : : !! out_carr(mm, nn): The submatrix, on all the processes.
5993 : : !! [request]: MPI request of the non-blocking broadcast.
5994 : : !!
5995 : : !! SOURCE
5996 : :
5997 : 0 : subroutine slkmat_sp_collect_cplx(in_mat, mm, nn, ija, out_carr, request)
5998 : :
5999 : : !Arguments ------------------------------------
6000 : : class(slkmat_sp_t),intent(in) :: in_mat
6001 : : integer,intent(in) :: mm, nn, ija(2)
6002 : : complex(sp) ABI_ASYNC, allocatable,intent(out) :: out_carr(:,:)
6003 : : integer ABI_ASYNC, optional,intent(out) :: request
6004 : :
6005 : : !Local variables-------------------------------
6006 : : integer,parameter :: master = 0
6007 : : integer :: ierr
6008 : : type(slk_processor_t) :: self_processor
6009 [ # # # # : 0 : type(slkmat_sp_t) :: out_mat
# # ]
6010 : : ! *************************************************************************
6011 : :
6012 : 0 : ABI_CHECK(allocated(in_mat%buffer_cplx), "buffer_cplx is not allocated")
6013 : :
6014 [ # # ]: 0 : if (in_mat%processor%grid%nprocs == 1) then
6015 : : ! Copy buffer and return
6016 [ # # # # : 0 : ABI_MALLOC(out_carr, (mm, nn))
# # # # #
# # # # #
# # # # ]
6017 [ # # # # ]: 0 : out_carr(:,:) = in_mat%buffer_cplx(ija(1):ija(1)+mm-1, ija(2):ija(2)+nn-1); return
6018 : : end if
6019 : :
6020 : : ! Two-step algorithm:
6021 : : ! 1) Use pzgemr2d to collect submatrix on master.
6022 : : ! 2) Master broadcasts submatrix.
6023 : :
6024 [ # # ]: 0 : if (in_mat%processor%my_rank == master) then
6025 : 0 : call self_processor%init(xmpi_comm_self)
6026 [ # # ]: 0 : call out_mat%init(mm, nn, self_processor, in_mat%istwf_k, size_blocs=[mm, nn])
6027 : : else
6028 : 0 : out_mat%desc(CTXT_) = -1
6029 : : end if
6030 : :
6031 : : #ifdef HAVE_LINALG_SCALAPACK
6032 : : call pcgemr2d(mm, nn, &
6033 : : in_mat%buffer_cplx, ija(1), ija(2), in_mat%desc, &
6034 : : out_mat%buffer_cplx, 1, 1, out_mat%desc, &
6035 : : in_mat%processor%grid%comm)
6036 : : #endif
6037 : :
6038 [ # # ]: 0 : if (in_mat%processor%my_rank == master) then
6039 [ # # ]: 0 : ABI_MOVE_ALLOC(out_mat%buffer_cplx, out_carr)
6040 : 0 : call out_mat%free()
6041 : 0 : call self_processor%free()
6042 : : else
6043 [ # # # # : 0 : ABI_MALLOC(out_carr, (mm, nn))
# # # # #
# # # # #
# # # # ]
6044 : : end if
6045 : :
6046 [ # # ]: 0 : if (present(request)) then
6047 : 0 : call xmpi_ibcast(out_carr, master, in_mat%processor%comm, request, ierr)
6048 : : else
6049 : 0 : call xmpi_bcast(out_carr, master, in_mat%processor%comm, ierr)
6050 : : end if
6051 : :
6052 [ # # # # : 0 : end subroutine slkmat_sp_collect_cplx
# # # # #
# # # #
# ]
6053 : : !!***
6054 : :
6055 : : !----------------------------------------------------------------------
6056 : :
6057 : : !!****f* m_slk/basemat_get_trace
6058 : : !! NAME
6059 : : !! basemat_get_trace
6060 : : !!
6061 : : !! FUNCTION
6062 : : !! Compute the trace of an N-by-N distributed matrix.
6063 : : !! The result is summed over mat%processor%comm (collective call) and returned as complex(dp)
6064 : : !! also for real and single precision matrices.
6065 : : !!
6066 : : !! SOURCE
6067 : :
6068 : 0 : complex(dp) function basemat_get_trace(mat) result(ctrace)
6069 : :
6070 : : !Arguments ------------------------------------
6071 : : class(basemat_t), intent(in) :: mat
6072 : :
6073 : : !Local variables-------------------------------
6074 : : #ifdef HAVE_LINALG_SCALAPACK
6075 : : integer :: iloc, jloc, iglob, jglob, ierr
6076 : : real(dp) :: rtrace
6077 : : real(sp) :: rtrace_sp
6078 : : complex(sp) :: ctrace_sp
6079 : : #endif
6080 : : ! *************************************************************************
6081 : :
6082 [ # # ]: 0 : ABI_CHECK_IEQ(mat%size_global(1), mat%size_global(2), "get_trace assumes square matrix!")
6083 : :
6084 : : ! prototype for complex version.
6085 : : ! COMPLEX*16 FUNCTION PZLATRA( N, A, IA, JA, DESCA )
6086 : : !
6087 : : ! NOTE: We don't use PZLATRA and friends as these calls can lead to SIGSEGV when
6088 : : ! we compile with gcc and link with intel scalapack (very likely there's an ABI mismatch
6089 : : ! even when the compatibility layer is used --> we implement our own version.
6090 : :
6091 : : #ifdef HAVE_LINALG_SCALAPACK
6092 : : select type (mat)
6093 : : class is (slkmat_dp_t)
6094 : : if (allocated(mat%buffer_cplx)) then
6095 : : !ctrace = PZLATRA(mat%size_global(1), mat%buffer_cplx, 1, 1, mat%desc)
6096 : : ctrace = zero
6097 : : do jloc=1,mat%size_local(2)
6098 : : do iloc=1,mat%size_local(1)
6099 : : call mat%loc2glob(iloc, jloc, iglob, jglob)
6100 : : if (iglob == jglob) ctrace = ctrace + mat%buffer_cplx(iloc, jloc)
6101 : : end do
6102 : : end do
6103 : :
6104 : : else if (allocated(mat%buffer_real)) then
6105 : : !rtrace = PDLATRA(mat%size_global(1), mat%buffer_real, 1, 1, mat%desc)
6106 : : rtrace = zero
6107 : : do jloc=1,mat%size_local(2)
6108 : : do iloc=1,mat%size_local(1)
6109 : : call mat%loc2glob(iloc, jloc, iglob, jglob)
6110 : : if (iglob == jglob) rtrace = rtrace + mat%buffer_real(iloc, jloc)
6111 : : end do
6112 : : end do
6113 : : ctrace = rtrace
6114 : :
6115 : : else
6116 : : ABI_ERROR("Neither buffer_cplx nor buffer_real are allocated!")
6117 : : end if
6118 : :
6119 : : class is (slkmat_sp_t)
6120 : : if (allocated(mat%buffer_cplx)) then
6121 : : !ctrace_sp = PCLATRA(mat%size_global(1), mat%buffer_cplx, 1, 1, mat%desc)
6122 : : ctrace_sp = zero
6123 : : do jloc=1,mat%size_local(2)
6124 : : do iloc=1,mat%size_local(1)
6125 : : call mat%loc2glob(iloc, jloc, iglob, jglob)
6126 : : if (iglob == jglob) ctrace_sp = ctrace_sp + mat%buffer_cplx(iloc, jloc)
6127 : : end do
6128 : : end do
6129 : : ctrace = ctrace_sp
6130 : :
6131 : : else if (allocated(mat%buffer_real)) then
6132 : : !rtrace_sp = PSLATRA(mat%size_global(1), mat%buffer_real, 1, 1, mat%desc)
6133 : : rtrace_sp = zero
6134 : : do jloc=1,mat%size_local(2)
6135 : : do iloc=1,mat%size_local(1)
6136 : : call mat%loc2glob(iloc, jloc, iglob, jglob)
6137 : : if (iglob == jglob) rtrace_sp = rtrace_sp + mat%buffer_real(iloc, jloc)
6138 : : end do
6139 : : end do
6140 : : ctrace = rtrace_sp
6141 : :
6142 : : else
6143 : : ABI_ERROR("Neither buffer_cplx nor buffer_real are allocated!")
6144 : : end if
6145 : :
6146 : : class default
6147 : : ABI_ERROR("Wrong class")
6148 : : end select
6149 : :
6150 : : call xmpi_sum(ctrace, mat%processor%comm, ierr)
6151 : : #endif
6152 : :
6153 : 0 : end function basemat_get_trace
6154 : : !!***
6155 : :
6156 : : !----------------------------------------------------------------------
6157 : :
6158 : : !!****f* m_slk/basemat_set_imag_diago_to_zero
6159 : : !! NAME
6160 : : !! basemat_set_imag_diago_to_zero
6161 : : !!
6162 : : !! FUNCTION
6163 : : !! Set the imaginary part of the diagonal to zero.
6164 : : !! Return in local_max the max of the imaginary part in the local buffer.
6165 : : !! No MPI communication is performed inside the routine. Client code can easily reduce
6166 : : !! local_max within the PBLAS communicator if needed.
6167 : : !!
6168 : : !! OUTPUT
6169 : : !! local_max: Max of the imaginary part (signed, not the absolute value) of the local diagonal entries
6170 : : !! before zeroing. -huge(one) if this process does not own diagonal entries.
6171 : : !!
6172 : : !! SOURCE
6173 : :
6174 : 0 : subroutine basemat_set_imag_diago_to_zero(mat, local_max)
6175 : :
6176 : : !Arguments ------------------------------------
6177 : : class(basemat_t), intent(inout) :: mat
6178 : : real(dp),intent(out) :: local_max
6179 : :
6180 : : !Local variables-------------------------------
6181 : : integer :: il1, iglob1, il2, iglob2
6182 : : ! *************************************************************************
6183 : :
6184 : 0 : local_max = -huge(one)
6185 : :
6186 : : select type (mat)
6187 : : class is (slkmat_dp_t)
6188 [ # # ]: 0 : if (allocated(mat%buffer_real)) return
6189 [ # # ]: 0 : do il2=1,mat%size_local(2)
6190 : 0 : iglob2 = mat%loc2gcol(il2)
6191 [ # # ]: 0 : do il1=1,mat%size_local(1)
6192 : 0 : iglob1 = mat%loc2grow(il1)
6193 [ # # ]: 0 : if (iglob1 == iglob2) then
6194 : 0 : local_max = max(local_max, aimag(mat%buffer_cplx(il1, il2)))
6195 : 0 : mat%buffer_cplx(il1, il2) = real(mat%buffer_cplx(il1, il2))
6196 : : end if
6197 : : end do
6198 : : end do
6199 : :
6200 : : class is (slkmat_sp_t)
6201 [ # # ]: 0 : if (allocated(mat%buffer_real)) return
6202 [ # # ]: 0 : do il2=1,mat%size_local(2)
6203 : 0 : iglob2 = mat%loc2gcol(il2)
6204 [ # # ]: 0 : do il1=1,mat%size_local(1)
6205 : 0 : iglob1 = mat%loc2grow(il1)
6206 [ # # ]: 0 : if (iglob1 == iglob2) then
6207 : 0 : local_max = max(local_max, aimag(mat%buffer_cplx(il1, il2)))
6208 : 0 : mat%buffer_cplx(il1, il2) = real(mat%buffer_cplx(il1, il2))
6209 : : end if
6210 : : end do
6211 : : end do
6212 : :
6213 : : class default
6214 : 0 : ABI_ERROR("Wrong class")
6215 : : end select
6216 : :
6217 : : end subroutine basemat_set_imag_diago_to_zero
6218 : : !!***
6219 : :
6220 : : !----------------------------------------------------------------------
6221 : :
6222 : : !!****f* m_slk/slk_write
6223 : : !! NAME
6224 : : !! slk_write
6225 : : !!
6226 : : !! FUNCTION
6227 : : !! Routine to write a square scaLAPACK-distributed matrix to an external file using MPI-IO.
6228 : : !!
6229 : : !! INPUTS
6230 : : !! Slk_mat<slkmat_dp_t>=Structured datatype defining the scaLAPACK distribution with the local buffer
6231 : : !! containing the distributed matrix.
6232 : : !! uplo=String specifying whether only the upper or lower triangular part of the global matrix is used:
6233 : : !! = "U": Upper triangular
6234 : : !! = "L": Lower triangular
6235 : : !! = "A": Full matrix (used for general complex matrices)
6236 : : !! is_fortran_file=.FALSE. is C stream is used. .TRUE. for writing Fortran binary files.
6237 : : !! [fname]= Mutually exclusive with mpi_fh. The name of the external file on which the matrix will be written.
6238 : : !! The file is open and closed inside the routine with MPI flags specified by flags.
6239 : : !! [mpi_fh]=File handler associated to the file (already open in the caller). Not compatible with fname.
6240 : : !! [flags]=MPI-IO flags used to open the file in MPI_FILE_OPEN.
6241 : : !! Default is MPI_MODE_CREATE + MPI_MODE_WRONLY + MPI_MODE_EXCL.
6242 : : !! [glob_subarray(2,2)] = Used to select the subarray of the global matrix. Used only when uplo="All"
6243 : : !! NOTE that each node should call the routine with the same value.
6244 : : !! glob_subarray(:,1)=starting global coordinates of the subarray in each dimension
6245 : : !! (array of nonnegative integers >=1, <=array_of_sizes)
6246 : : !! glob_subarray(:,2)=Number of elements in each dimension of the subarray (array of positive integers)
6247 : : !!
6248 : : !! OUTPUT
6249 : : !! Only writing. The global scaLAPACK matrix is written to file fname.
6250 : : !! If fname is present then the file is open and closed inside the routine. Any exception is fatal.
6251 : : !!
6252 : : !! SIDE EFFECTS
6253 : : !! [offset]=
6254 : : !! input: Offset used to access the content of the file. Default is zero.
6255 : : !! output: New offset incremented with the byte size of the matrix that has been read (Fortran
6256 : : !! markers are included if is_fortran_file=.TRUE.)
6257 : : !! TODO
6258 : : !! - Generalize the implementation adding the writing the real buffer.
6259 : : !! - This routine should be removed and replaced by hdf5 + mpi-io
6260 : : !!
6261 : : !! SOURCE
6262 : :
6263 : 0 : subroutine slk_write(Slk_mat, uplo, is_fortran_file, fname,mpi_fh, offset, flags, glob_subarray)
6264 : :
6265 : : !Arguments ------------------------------------
6266 : : !scalars
6267 : : integer,optional,intent(in) :: flags
6268 : : integer,optional,intent(inout) :: mpi_fh
6269 : : integer(XMPI_OFFSET_KIND),optional,intent(inout) :: offset
6270 : : logical,intent(in) :: is_fortran_file
6271 : : character(len=*),optional,intent(in) :: fname
6272 : : character(len=*),intent(in) :: uplo
6273 : : class(slkmat_dp_t),intent(in) :: Slk_mat
6274 : : !array
6275 : : integer,optional,intent(in) :: glob_subarray(2,2)
6276 : :
6277 : : !Local variables ------------------------------
6278 : : !scalars
6279 : : #if defined HAVE_LINALG_SCALAPACK && defined HAVE_MPI_IO
6280 : : integer :: jloc,iloc,nrows_glob,ncols_glob,elw,nrows_w,ncols_w ! iglob,jglob,
6281 : : integer :: slk_type,offset_err,etype,nfrec,bsize_elm,mpi_type_elm
6282 : : integer(XMPI_OFFSET_KIND) :: my_offset
6283 : : logical :: do_open
6284 : : integer :: comm,my_flags,my_fh,buffer_size
6285 : : integer :: ierr,nelw,col_glob ! ij_loc,
6286 : : !arrays
6287 : : integer(XMPI_OFFSET_KIND),allocatable :: bsize_frecord(:)
6288 : : integer,pointer :: elw2slk(:,:)
6289 : : complex(dpc),allocatable :: buffer1_cplx(:)
6290 : : character(len=500) :: msg
6291 : : !************************************************************************
6292 : :
6293 : : ABI_CHECK(allocated(Slk_mat%buffer_cplx), "buffer_cplx not allocated")
6294 : :
6295 : : if (firstchar(uplo, ["U","L"]) .and. Slk_mat%size_global(1) /= Slk_mat%size_global(2) ) then
6296 : : ABI_ERROR("rectangular matrices are not compatible with the specified uplo")
6297 : : end if
6298 : :
6299 : : if (PRESENT(glob_subarray).and. .not. firstchar(uplo, ["A"])) then
6300 : : ABI_ERROR("glob_subarray should not be used when uplo/=All")
6301 : : end if
6302 : :
6303 : : do_open = PRESENT(fname)
6304 : : if (do_open) then
6305 : : ABI_CHECK(.not.PRESENT(fname),"fname should not be present")
6306 : : else
6307 : : ABI_CHECK(PRESENT(mpi_fh),"mpi_fh should be present")
6308 : : end if
6309 : :
6310 : : my_offset=0; if (PRESENT(offset)) my_offset=offset
6311 : :
6312 : : comm = Slk_mat%processor%comm
6313 : :
6314 : : nrows_glob=Slk_mat%size_global(1)
6315 : : ncols_glob=Slk_mat%size_global(1)
6316 : : buffer_size= PRODUCT(Slk_mat%size_local(1:2))
6317 : :
6318 : : call slk_mat%bsize_and_type(bsize_elm, mpi_type_elm)
6319 : :
6320 : : if (do_open) then !Open the file.
6321 : : my_flags=MPI_MODE_CREATE + MPI_MODE_WRONLY + MPI_MODE_APPEND
6322 : : if (PRESENT(flags)) my_flags = flags
6323 : :
6324 : : call MPI_FILE_OPEN(comm, fname, my_flags, MPI_INFO_NULL, my_fh, ierr)
6325 : : ABI_CHECK_MPI(ierr, "MPI_FILE_OPEN "//TRIM(fname))
6326 : : else
6327 : : my_fh = mpi_fh
6328 : : end if
6329 : :
6330 : : if (PRESENT(glob_subarray)) then
6331 : : call slk_single_fview_write(Slk_mat,uplo,nelw,elw2slk,etype,slk_type,offset_err,&
6332 : : is_fortran_file=is_fortran_file,glob_subarray=glob_subarray)
6333 : : else
6334 : : call slk_single_fview_write(Slk_mat,uplo,nelw,elw2slk,etype,slk_type,offset_err,&
6335 : : is_fortran_file=is_fortran_file)
6336 : : end if
6337 : :
6338 : : if (offset_err /= 0) then
6339 : : write(msg,"(3a)")&
6340 : : " Global position index cannot be stored in standard Fortran integer ",ch10,&
6341 : : " scaLAPACK matrix cannot be read with a single MPI-IO call."
6342 : : ABI_ERROR(msg)
6343 : : end if
6344 : :
6345 : : call MPI_FILE_SET_VIEW(my_fh, my_offset, etype, slk_type, 'native', MPI_INFO_NULL, ierr)
6346 : : ABI_CHECK_MPI(ierr,"SET_VIEW")
6347 : :
6348 : : call MPI_TYPE_FREE(slk_type,ierr)
6349 : : ABI_CHECK_MPI(ierr,"MPI_type_FREE")
6350 : :
6351 : : if (nelw == buffer_size) then
6352 : : ! Dump Slk_mat% immediately.
6353 : : call MPI_FILE_WRITE_ALL(my_fh, Slk_mat%buffer_cplx, buffer_size, MPI_DOUBLE_complex, MPI_STATUS_IGNORE, ierr)
6354 : : ABI_CHECK_MPI(ierr,"WRITE_ALL")
6355 : : else
6356 : : ! Have to extract the data to be written.
6357 : : ABI_MALLOC(buffer1_cplx,(nelw))
6358 : : do elw=1,nelw
6359 : : iloc = elw2slk(1,elw)
6360 : : jloc = elw2slk(2,elw)
6361 : : buffer1_cplx(elw) = Slk_mat%buffer_cplx(iloc,jloc)
6362 : : end do
6363 : : call MPI_FILE_WRITE_ALL(my_fh, buffer1_cplx, nelw, MPI_DOUBLE_complex, MPI_STATUS_IGNORE, ierr)
6364 : : ABI_CHECK_MPI(ierr,"WRITE_ALL")
6365 : : ABI_FREE(buffer1_cplx)
6366 : : end if
6367 : :
6368 : : ABI_FREE(elw2slk)
6369 : : !
6370 : : ! Number of columns and rows that have been written.
6371 : : ! Used to write the Fortran markers and to increment the offset.
6372 : : nrows_w = nrows_glob
6373 : : ncols_w = ncols_glob
6374 : : if (PRESENT(glob_subarray)) then
6375 : : nrows_w = glob_subarray(1,2) - glob_subarray(1,1) + 1
6376 : : ncols_w = glob_subarray(2,2) - glob_subarray(2,1) + 1
6377 : : if (.not.firstchar(uplo, ["A"])) then
6378 : : ABI_ERROR("glob_subarray should not be used when uplo/=All")
6379 : : end if
6380 : : end if
6381 : :
6382 : : !TODO check whether slk_single_fview_write can report an offset to reduce the extent.
6383 : : if (is_fortran_file) then ! Collective writing of the Fortran markers.
6384 : : nfrec = ncols_w
6385 : : ABI_MALLOC(bsize_frecord,(nfrec))
6386 : : if (firstchar(uplo, ["A"])) then
6387 : : bsize_frecord = nrows_w * bsize_elm
6388 : : else if (firstchar(uplo, ["U"])) then
6389 : : bsize_frecord = (/(col_glob * bsize_elm, col_glob=1,nfrec)/)
6390 : : else if (firstchar(uplo, ["L"])) then
6391 : : bsize_frecord = (/(col_glob * bsize_elm, col_glob=nfrec,1,-1)/)
6392 : : else
6393 : : ABI_ERROR("Wrong uplo")
6394 : : end if
6395 : : call xmpio_write_frmarkers(mpi_fh,my_offset,xmpio_collective,nfrec,bsize_frecord,ierr)
6396 : : ABI_CHECK(ierr==0,"Error while writing Fortran markers")
6397 : : ABI_FREE(bsize_frecord)
6398 : : end if
6399 : :
6400 : : if (do_open) then
6401 : : ! Close the file.
6402 : : call MPI_FILE_CLOSE(my_fh, ierr)
6403 : : ABI_CHECK_MPI(ierr,"FILE_CLOSE")
6404 : : end if
6405 : :
6406 : : ! Increment the offset
6407 : : if (PRESENT(offset)) then
6408 : : if (firstchar(uplo, ["A"])) then
6409 : : offset = offset + nrows_w*ncols_w*bsize_elm
6410 : : if (is_fortran_file) offset = offset + ncols_w*2*xmpio_bsize_frm
6411 : : else if (firstchar(uplo, ["U","L"])) then
6412 : : offset = offset + ( (Slk_mat%size_global(2) * (Slk_mat%size_global(2))+1)/2 ) * bsize_elm
6413 : : if (is_fortran_file) offset = offset + Slk_mat%size_global(2)*2*xmpio_bsize_frm
6414 : : else
6415 : : ABI_ERROR("Wrong uplo")
6416 : : end if
6417 : : end if
6418 : :
6419 : : call xmpi_barrier(comm)
6420 : : RETURN
6421 : :
6422 : : #else
6423 : 0 : ABI_ERROR("MPI-IO support not activated")
6424 : : #endif
6425 : :
6426 : 0 : end subroutine slk_write
6427 : : !!***
6428 : :
6429 : : !----------------------------------------------------------------------
6430 : :
6431 : : !!****f* m_slk/slk_read
6432 : : !! NAME
6433 : : !! slk_read
6434 : : !!
6435 : : !! FUNCTION
6436 : : !! Routine to read a square scaLAPACK distributed matrix from an external file using MPI-IO.
6437 : : !!
6438 : : !! INPUTS
6439 : : !! uplo=String specifying whether only the upper or lower triangular part of the global matrix is stored on disk:
6440 : : !! = "U": Upper triangular is stored
6441 : : !! = "L": Lower triangular is stored
6442 : : !! = "A": Full matrix (used for general complex matrices)
6443 : : !! symtype=Symmetry type of the matrix stored on disk (used only if uplo = "L" or "A").
6444 : : !! = "H" for Hermitian matrix
6445 : : !! = "S" for symmetric matrix.
6446 : : !! = "N" if matrix has no symmetry (not compatible with uplo="L" or uplo="U".
6447 : : !! is_fortran_file=.FALSE. is C stream is used. .TRUE. for writing Fortran binary files.
6448 : : !! [fname]= Mutually exclusive with mpi_fh. The name of the external file from which the matrix will be read.
6449 : : !! The file is open and closed inside the routine with MPI flags specified by flags.
6450 : : !! [mpi_fh]=File handler associated to the file (already open in the caller). Not compatible with fname.
6451 : : !! [flags]=MPI-IO flags used to open the file in MPI_FILE_OPEN. Default is MPI_MODE_RDONLY. Referenced only when fname is used.
6452 : : !!
6453 : : !! SIDE EFFECTS
6454 : : !! Slk_mat<slkmat_dp_t>=Structured datatype defining the scaLAPACK distribution with the local buffer
6455 : : !! supposed to be allocated.
6456 : : !! %buffer_cplx=Local buffer containing the distributed matrix stored on the external file.
6457 : : !! If fname is present then the file is opened and closed inside the routine. Any exception is fatal.
6458 : : !! [offset]=
6459 : : !! input: Offset used to access the content of the file. Default is zero.
6460 : : !! output: New offset incremented with the byte size of the matrix that has been read (Fortran
6461 : : !! markers are included if is_fortran_file=.TRUE.)
6462 : : !!
6463 : : !! TODO
6464 : : !! - Generalize the implementation adding the reading of the real buffer.
6465 : : !!
6466 : : !! - This routine is not portable as this kind of access pattern is not supported by all MPI implementations
6467 : : !! E.g. with MPICH we have
6468 : : !!
6469 : : !! --- !ERROR
6470 : : !! src_file: m_slk.F90
6471 : : !! src_line: 3780
6472 : : !! mpi_rank: 1
6473 : : !! message: |
6474 : : !! SET_VIEW
6475 : : !! Other I/O error , error stack:
6476 : : !! ADIO_Set_view(48): **iobadoverlap displacements of filetype must be in a monotonically nondecreasing order
6477 : : !! ...
6478 : : !!
6479 : : !! - This routine should be removed and replaced by hdf5 + mpi-io
6480 : : !!
6481 : : !! SOURCE
6482 : :
6483 : 0 : subroutine slk_read(Slk_mat,uplo,symtype,is_fortran_file,fname,mpi_fh,offset,flags)
6484 : :
6485 : : !Arguments ------------------------------------
6486 : : !scalars
6487 : : integer,optional,intent(in) :: flags,mpi_fh
6488 : : integer(XMPI_OFFSET_KIND),optional,intent(inout) :: offset
6489 : : character(len=*),optional,intent(in) :: fname
6490 : : character(len=*),intent(in) :: uplo,symtype
6491 : : logical,intent(in) :: is_fortran_file
6492 : : class(slkmat_dp_t),intent(inout) :: Slk_mat
6493 : :
6494 : : !Local variables ------------------------------
6495 : : #if defined HAVE_LINALG_SCALAPACK && defined HAVE_MPI_IO
6496 : : !scalars
6497 : : integer :: nrows_glob,offset_err,slk_type,etype
6498 : : integer(XMPI_OFFSET_KIND) :: my_offset
6499 : : logical :: do_open
6500 : : integer :: comm,my_flags,my_fh,buffer_size,ierr,col_glob
6501 : : integer :: nfrec,bsize_elm,mpi_type_elm
6502 : : !complex(dpc) :: ctest
6503 : : logical,parameter :: check_frm=.TRUE.
6504 : : integer(XMPI_OFFSET_KIND),allocatable :: bsize_frecord(:)
6505 : : !arrays
6506 : : character(len=500) :: msg
6507 : : !************************************************************************
6508 : :
6509 : : do_open = PRESENT(fname)
6510 : : if (do_open) then
6511 : : ABI_CHECK(.not.PRESENT(fname), "fname should not be present")
6512 : : else
6513 : : ABI_CHECK(PRESENT(mpi_fh), "mpi_fh should be present")
6514 : : end if
6515 : :
6516 : : my_offset=0; if (PRESENT(offset)) my_offset=offset
6517 : :
6518 : : ABI_CHECK(allocated(Slk_mat%buffer_cplx), "%buffer_cplx not allocated")
6519 : : if (firstchar(uplo, ["U","L"]) .and. Slk_mat%size_global(1) /= Slk_mat%size_global(2) ) then
6520 : : ABI_ERROR("rectangular matrices are not compatible with the specified uplo")
6521 : : end if
6522 : :
6523 : : nrows_glob = Slk_mat%size_global(1)
6524 : :
6525 : : buffer_size= PRODUCT(Slk_mat%size_local(1:2))
6526 : :
6527 : : call wrtout(std_out, "slk_read: Using MPI-IO")
6528 : :
6529 : : comm = Slk_mat%processor%comm
6530 : :
6531 : : if (do_open) then ! Open the file.
6532 : : my_flags=MPI_MODE_RDONLY; if (PRESENT(flags)) my_flags = flags
6533 : : call MPI_FILE_OPEN(comm, fname, my_flags, MPI_INFO_NULL, my_fh, ierr)
6534 : : ABI_CHECK_MPI(ierr,"FILE_OPEN "//TRIM(fname))
6535 : : else
6536 : : my_fh = mpi_fh
6537 : : end if
6538 : :
6539 : : call slk_single_fview_read(Slk_mat,uplo,etype,slk_type,offset_err,is_fortran_file=is_fortran_file)
6540 : :
6541 : : if (offset_err/=0) then
6542 : : write(msg,"(3a)")&
6543 : : "Global position index cannot be stored in standard Fortran integer ",ch10,&
6544 : : "scaLAPACK matrix cannot be read with a single MPI-IO call."
6545 : : ABI_ERROR(msg)
6546 : : end if
6547 : :
6548 : : call MPI_FILE_SET_VIEW(my_fh, my_offset, etype, slk_type, 'native', MPI_INFO_NULL, ierr)
6549 : : ABI_CHECK_MPI(ierr,"SET_VIEW")
6550 : :
6551 : : call MPI_FILE_READ_ALL(my_fh, Slk_mat%buffer_cplx, buffer_size, MPI_DOUBLE_complex, MPI_STATUS_IGNORE, ierr)
6552 : : ABI_CHECK_MPI(ierr,"READ_ALL")
6553 : :
6554 : : ! Symmetrize local buffer if uplo /= "All"
6555 : : call Slk_mat%symmetrize(uplo, symtype)
6556 : :
6557 : : !BEGINDEBUG
6558 : : !call MPI_FILE_READ_AT(mpi_fh,my_offset+xmpio_bsize_frm,ctest,1,MPI_DOUBLE_complex,MPI_STATUS_IGNORE,ierr)
6559 : : !write(std_out,*)"ctest",ctest
6560 : : !call MPI_FILE_READ_AT(mpi_fh,my_offset+2*xmpio_bsize_frm,ctest,1,MPI_DOUBLE_complex,MPI_STATUS_IGNORE,ierr)
6561 : : !write(std_out,*)"ctest",ctest
6562 : : !ENDDEBUG
6563 : :
6564 : : !call print_arr(Slk_mat%buffer_cplx,max_r=10,max_c=10,unit=std_out)
6565 : : !
6566 : : ! Close the file and release the MPI filetype.
6567 : : call MPI_type_FREE(slk_type,ierr)
6568 : : ABI_CHECK_MPI(ierr,"MPI_type_FREE")
6569 : :
6570 : : call slk_mat%bsize_and_type(bsize_elm, mpi_type_elm)
6571 : :
6572 : : !It seems that personal call makes the code stuck
6573 : : !if (is_fortran_file .and. check_frm .and. Slk_mat%Processor%my_rank==0) then ! Master checks the Fortran markers.
6574 : : if (is_fortran_file .and. check_frm) then ! Master checks the Fortran markers.
6575 : : call wrtout(std_out,"Checking Fortran record markers...", do_flush=.True.)
6576 : : nfrec = Slk_mat%size_global(2)
6577 : : ABI_MALLOC(bsize_frecord,(nfrec))
6578 : : if (firstchar(uplo, ["A"])) then
6579 : : bsize_frecord = Slk_mat%size_global(1) * bsize_elm
6580 : : else if (firstchar(uplo, ["U"])) then
6581 : : bsize_frecord = (/(col_glob * bsize_elm, col_glob=1,nfrec)/)
6582 : : else if (firstchar(uplo, ["L"])) then
6583 : : bsize_frecord = (/(col_glob * bsize_elm, col_glob=nfrec,1,-1)/)
6584 : : else
6585 : : ABI_ERROR("Wrong uplo")
6586 : : end if
6587 : : call xmpio_check_frmarkers(my_fh,my_offset,xmpio_collective,nfrec,bsize_frecord,ierr)
6588 : : ABI_CHECK(ierr==0,"Wrong Fortran record markers")
6589 : : ABI_FREE(bsize_frecord)
6590 : : end if
6591 : :
6592 : : if (do_open) then ! Close the file.
6593 : : call MPI_FILE_CLOSE(my_fh, ierr)
6594 : : ABI_CHECK_MPI(ierr,"FILE_CLOSE")
6595 : : end if
6596 : :
6597 : : !Increment the offset
6598 : : if (PRESENT(offset)) then
6599 : : if (firstchar(uplo, ["A"])) then
6600 : : offset = offset + PRODUCT(Slk_mat%size_global(1:2)) * bsize_elm
6601 : : if (is_fortran_file) offset = offset + Slk_mat%size_global(2)*2*xmpio_bsize_frm
6602 : : else if (firstchar(uplo, ["U","L"])) then
6603 : : offset = offset + ( (Slk_mat%size_global(2) * (Slk_mat%size_global(2))+1)/2 ) * bsize_elm
6604 : : if (is_fortran_file) offset = offset + Slk_mat%size_global(2)*2*xmpio_bsize_frm
6605 : : else
6606 : : ABI_ERROR("Wrong uplo")
6607 : : end if
6608 : : end if
6609 : :
6610 : : call xmpi_barrier(comm)
6611 : : RETURN
6612 : :
6613 : : #else
6614 : 0 : ABI_ERROR("MPI-IO support not enabled")
6615 : : #endif
6616 : :
6617 : 0 : end subroutine slk_read
6618 : : !!***
6619 : :
6620 : : !----------------------------------------------------------------------
6621 : :
6622 : : !!****f* m_slk/slk_single_fview_read_mask
6623 : : !! NAME
6624 : : !! slk_single_fview_read_mask
6625 : : !!
6626 : : !! FUNCTION
6627 : : !! Return an MPI datatype that can be used to read a scaLAPACK distributed matrix from
6628 : : !! a binary file using MPI-IO. The view is created using the user-defined mask function
6629 : : !! mask_of_glob. The storage of the data on file is described via the user-defined function offset_of_glob.
6630 : : !!
6631 : : !! INPUTS
6632 : : !! Slk_mat<slkmat_dp_t>=Structured datatype defining the scaLAPACK matrix.
6633 : : !! mask_of_glob(row_glob,col_glob,size_glob) is an integer function that accepts in input
6634 : : !! the global indices of the matrix size_glob(1:2) are the global dimensions.
6635 : : !! Return 0 if (row_glob,col_glob) should not be read.
6636 : : !! offset_of_glob(row_glob,col_glob,size_glob,nsblocks,sub_block,bsize_elm,bsize_frm)
6637 : : !! nsblocks=Number of sub-blocks (will be passed to offset_of_glob)
6638 : : !! sub_block(2,2,nsblocks)=Global coordinates of the extremal points delimiting the sub-blocs
6639 : : !! e.g. sub_block(:,1,1) gives the coordinates of the left upper corner of the first block.
6640 : : !! sub_block(:,2,1) gives the coordinates of the right lower corner of the first block.
6641 : : !! [is_fortran_file]=.FALSE. is C stream is used. Set to .TRUE. for writing Fortran binary files
6642 : : !! with record marker.
6643 : : !!
6644 : : !! OUTPUT
6645 : : !! my_nel=Number of elements that will be read by this node.
6646 : : !! etype=Elementary data type (handle) defining the elementary unit used to access the file.
6647 : : !! This is the elementary type that must be used to create the view (MPI_BYTE is used).
6648 : : !! slk_type=New MPI type that can be used to instantiate the MPI-IO view for the Fortran file.
6649 : : !! Note that the view assumes that the file pointer points to the FIRST Fortran record marker.
6650 : : !! offset_err=Error code. A returned non-zero value signals that the global matrix is too large
6651 : : !! for a single MPI-IO access. See notes in other slk_single_fview_* routines.
6652 : : !!
6653 : : !! SIDE EFFECTS
6654 : : !! myel2loc(:,:)
6655 : : !! input: pointer to NULL
6656 : : !! output: myel2loc(2,my_nel): myel2loc(:,el) gives (iloc,jloc) for el=1,my_nel.
6657 : : !!
6658 : : !! SOURCE
6659 : :
6660 : 0 : subroutine slk_single_fview_read_mask(Slk_mat,mask_of_glob,offset_of_glob,nsblocks,sub_block,&
6661 : : my_nel,myel2loc,etype,slk_type,offset_err,is_fortran_file)
6662 : :
6663 : : !Arguments ------------------------------------
6664 : : !scalars
6665 : : integer,intent(in) :: nsblocks
6666 : : integer,intent(out) :: my_nel,offset_err,slk_type,etype
6667 : : logical,optional,intent(in) :: is_fortran_file
6668 : : class(slkmat_dp_t),intent(in) :: Slk_mat
6669 : : !arrays
6670 : : integer,intent(in) :: sub_block(2,2,nsblocks)
6671 : : integer,pointer :: myel2loc(:,:)
6672 : :
6673 : : interface
6674 : : function mask_of_glob(row_glob,col_glob,size_glob)
6675 : : use defs_basis
6676 : : integer :: mask_of_glob
6677 : : integer,intent(in) :: row_glob,col_glob
6678 : : integer,intent(in) :: size_glob(2)
6679 : : end function mask_of_glob
6680 : : end interface
6681 : :
6682 : : interface
6683 : : function offset_of_glob(row_glob,col_glob,size_glob,nsblocks,sub_block,bsize_elm,bsize_frm)
6684 : : use defs_basis
6685 : : use m_xmpi
6686 : : integer(XMPI_OFFSET_KIND) :: offset_of_glob
6687 : : integer,intent(in) :: row_glob,col_glob,bsize_elm,bsize_frm,nsblocks
6688 : : integer,intent(in) :: size_glob(2),sub_block(2,2,nsblocks)
6689 : : end function offset_of_glob
6690 : : end interface
6691 : :
6692 : : !Local variables ------------------------------
6693 : : !scalars
6694 : : integer :: el,jloc,iloc,iglob,jglob,mpi_err,sweep
6695 : : integer :: bsize_frm,mpi_type_elm,bsize_elm
6696 : : integer(XMPI_OFFSET_KIND) :: tmp_off,max_displ
6697 : : !arrays
6698 : : character(len=500) :: msg
6699 : 0 : integer,allocatable :: block_length(:),block_type(:)
6700 : 0 : integer(XMPI_ADDRESS_KIND),allocatable :: block_displ(:)
6701 : : !************************************************************************
6702 : :
6703 : : #ifdef HAVE_MPI_IO
6704 : 0 : bsize_frm = xmpio_bsize_frm ! Byte size of the Fortran record marker.
6705 [ # # ]: 0 : if (PRESENT(is_fortran_file)) then
6706 [ # # ]: 0 : if (.not.is_fortran_file) bsize_frm = 0
6707 : : end if
6708 : :
6709 : : ! Byte size of the matrix element.
6710 : 0 : call slk_mat%bsize_and_type(bsize_elm, mpi_type_elm)
6711 : :
6712 : : ! Find the number of local matrix elements to be read, then create the table myel2loc.
6713 [ # # ]: 0 : do sweep=1,2
6714 [ # # ]: 0 : if (sweep==2) then
6715 [ # # # # : 0 : ABI_MALLOC(myel2loc,(2,my_nel))
# # # # #
# # # ]
6716 : : end if
6717 : 0 : my_nel=0
6718 : :
6719 [ # # ]: 0 : do jloc=1,Slk_mat%size_local(2)
6720 [ # # ]: 0 : do iloc=1,Slk_mat%size_local(1)
6721 : 0 : call slk_mat%loc2glob(iloc, jloc, iglob, jglob)
6722 [ # # ]: 0 : if ( mask_of_glob(iglob,jglob,Slk_mat%size_global)/= 0) then ! Will fill this entry.
6723 : 0 : my_nel = my_nel+1
6724 [ # # # # ]: 0 : if (sweep==2) myel2loc(:,my_nel) = (/iloc,jloc/)
6725 : : end if
6726 : : end do
6727 : : end do
6728 : : end do
6729 : :
6730 : 0 : etype = MPI_BYTE
6731 : :
6732 : : ! Define the mapping between scaLAPACK buffer and the storage on file.
6733 : : ! Note that the view assumes that the file pointer points to the first Fortran record marker.
6734 [ # # # # : 0 : ABI_MALLOC(block_length,(my_nel+2))
# # # # #
# # # #
# ]
6735 [ # # # # : 0 : ABI_MALLOC(block_displ,(my_nel+2))
# # # # #
# # # ]
6736 [ # # # # : 0 : ABI_MALLOC(block_type,(my_nel+2))
# # # # ]
6737 : 0 : block_length(1)=1
6738 : 0 : block_displ (1)=0
6739 : 0 : block_type (1)=MPI_LB
6740 : :
6741 : 0 : offset_err=0; max_displ=0
6742 [ # # ]: 0 : do el=1,my_nel
6743 : 0 : iloc = myel2loc(1,el)
6744 : 0 : jloc = myel2loc(2,el)
6745 : 0 : call slk_mat%loc2glob(iloc, jloc, iglob, jglob)
6746 : 0 : tmp_off = offset_of_glob(iglob,jglob,Slk_mat%size_global,nsblocks,sub_block,bsize_elm,bsize_frm)
6747 [ # # ]: 0 : if (xmpio_max_address(tmp_off)) offset_err=1 ! Test for possible wraparounds.
6748 : 0 : max_displ = MAX(max_displ,tmp_off)
6749 : 0 : block_displ (el+1) = tmp_off
6750 : 0 : block_type (el+1) = mpi_type_elm
6751 : 0 : block_length(el+1) = 1
6752 : : !write(std_out,*)" iglob, jglob, tmp_off ",iglob, jglob, tmp_off
6753 : : end do
6754 : : !write(std_out,*)" MAX displ is ",MAXVAL(block_displ)
6755 : :
6756 [ # # ]: 0 : if (offset_err/=0) then ! just warn, let the caller handle the exception.
6757 : : write(msg,"(3a)")&
6758 : 0 : " Global position index cannot be stored in standard Fortran integer ",ch10,&
6759 : 0 : " scaLAPACK matrix cannot be read with a single MPI-IO call ."
6760 : 0 : ABI_WARNING(msg)
6761 : : end if
6762 : :
6763 : 0 : block_length(my_nel+2) = 1
6764 : 0 : block_displ (my_nel+2) = max_displ
6765 : 0 : block_type (my_nel+2) = MPI_UB
6766 : :
6767 : 0 : call xmpio_type_struct(my_nel+2,block_length,block_displ,block_type,slk_type,mpi_err)
6768 : 0 : ABI_CHECK_MPI(mpi_err,"MPI_type_STRUCT")
6769 : :
6770 : 0 : ABI_FREE(block_length)
6771 : 0 : ABI_FREE(block_displ)
6772 : 0 : ABI_FREE(block_type)
6773 : :
6774 : 0 : call MPI_type_COMMIT(slk_type,mpi_err)
6775 : 0 : ABI_CHECK_MPI(mpi_err,"MPI_type_COMMIT")
6776 : :
6777 : : #else
6778 : : ABI_ERROR("MPI-IO is mandatatory in slk_single_fview_read_mask")
6779 : : #endif
6780 : :
6781 : 0 : end subroutine slk_single_fview_read_mask
6782 : : !!***
6783 : :
6784 : : !----------------------------------------------------------------------
6785 : :
6786 : : !!****f* m_slk/slkmat_dp_symmetrize
6787 : : !! NAME
6788 : : !! slkmat_dp_symmetrize
6789 : : !!
6790 : : !! FUNCTION
6791 : : !! Symmetrize a square scaLAPACK matrix.
6792 : : !!
6793 : : !! INPUTS
6794 : : !! uplo=String specifying whether only the upper or lower triangular part of the global matrix has been read
6795 : : !! = "U": Upper triangular has been read.
6796 : : !! = "L": Lower triangular has been read.
6797 : : !! = "A": Full matrix (used for general complex matrices)
6798 : : !! symtype=Symmetry type of the matrix (used only if uplo = "L" or "A").
6799 : : !! = "H" for Hermitian matrix
6800 : : !! = "S" for symmetric matrix.
6801 : : !! = "N" if matrix has no symmetry (not compatible with uplo="L" or uplo="U").
6802 : : !!
6803 : : !! SIDE EFFECTS
6804 : : !! Slk_mat<slkmat_dp_t>=Structured datatype defining the scaLAPACK distribution with the local buffer
6805 : : !! supposed to be allocated.
6806 : : !! %buffer_cplx=Local buffer containing the distributed matrix. On exit, the missing triangle is filled.
6807 : : !!
6808 : : !! SOURCE
6809 : :
6810 : 0 : subroutine slkmat_dp_symmetrize(Slk_mat, uplo, symtype)
6811 : :
6812 : : !Arguments ------------------------------------
6813 : : !scalars
6814 : : class(slkmat_dp_t),intent(inout) :: Slk_mat
6815 : : character(len=*),intent(in) :: uplo, symtype
6816 : :
6817 : : !Local variables ------------------------------
6818 : : !scalars
6819 : : integer :: jloc,iloc,iglob,jglob,ij_loc
6820 : : logical :: is_hermitian,is_real,is_cplx,is_symmetric
6821 : : character(len=500) :: msg
6822 : : !************************************************************************
6823 : :
6824 : 0 : is_cplx = (allocated(Slk_mat%buffer_cplx))
6825 : 0 : is_real = (allocated(Slk_mat%buffer_real))
6826 : :
6827 : : ! One and only one buffer should be allocated.
6828 [ # # ]: 0 : if (is_real .and. is_cplx) then
6829 : 0 : write(msg,'(a,2l1)')" ScaLAPACK buffers are not allocated correctly, is_real, is_cplx ",is_real,is_cplx
6830 : 0 : ABI_ERROR(msg)
6831 : : end if
6832 : :
6833 [ # # ]: 0 : if (is_real) RETURN
6834 : :
6835 : 0 : is_hermitian=.FALSE.; is_symmetric=.FALSE.
6836 : : select case (symtype(1:1))
6837 : : case ("H", "h")
6838 : : is_hermitian = .TRUE.
6839 : : case ("S","s")
6840 : 0 : is_symmetric = .TRUE.
6841 : : case("N","n")
6842 [ # # # # : 0 : if (ALL(uplo(1:1) /= ["A","a"])) then
# # ]
6843 [ # # ]: 0 : msg = " Found symtype= "//TRIM(symtype)//", but uplo= "//TRIM(uplo)
6844 : 0 : ABI_ERROR(msg)
6845 : : end if
6846 : 0 : RETURN ! Nothing to do.
6847 : : case default
6848 [ # # # # : 0 : ABI_ERROR("Wrong symtype "//TRIM(symtype))
# # ]
6849 : : end select
6850 : :
6851 : : !write(std_out,*)"is_cplx",is_cplx
6852 : : !write(std_out,*)"is_hermitian",is_hermitian
6853 : :
6854 : : select case (uplo(1:1))
6855 : : case ("A","a")
6856 : : ! Full global matrix has been read, nothing to do.
6857 : 0 : return
6858 : :
6859 : : case ("U", "u")
6860 : : ! Only the upper triangle of the global matrix was read.
6861 [ # # # # ]: 0 : if (is_cplx .and. is_hermitian) then
6862 : 0 : ij_loc=0
6863 [ # # ]: 0 : do jloc=1,Slk_mat%size_local(2)
6864 [ # # ]: 0 : do iloc=1,Slk_mat%size_local(1)
6865 : 0 : call slk_mat%loc2glob(iloc, jloc, iglob, jglob)
6866 : 0 : ij_loc = ij_loc+1
6867 [ # # ]: 0 : if (jglob < iglob) then
6868 : : ! Diagonal elements are not forced to be real.
6869 : 0 : Slk_mat%buffer_cplx(iloc,jloc) = DCONJG(Slk_mat%buffer_cplx(iloc,jloc))
6870 : : end if
6871 : : !if (iglob==jglob) Slk_mat%buffer_cplx(iloc,jloc) = real(Slk_mat%buffer_cplx(iloc,jloc))
6872 : : end do
6873 : : end do
6874 : : end if
6875 : :
6876 : : case ("L", "l")
6877 : : ! Only the lower triangle of the global matrix was read.
6878 [ # # # # ]: 0 : if (is_cplx .and. is_hermitian) then
6879 : 0 : ij_loc=0
6880 [ # # ]: 0 : do jloc=1,Slk_mat%size_local(2)
6881 [ # # ]: 0 : do iloc=1,Slk_mat%size_local(1)
6882 : 0 : call slk_mat%loc2glob(iloc, jloc, iglob, jglob)
6883 : 0 : ij_loc = ij_loc+1
6884 [ # # ]: 0 : if (jglob>iglob) then ! diagonal elements are not forced to be real.
6885 : 0 : Slk_mat%buffer_cplx(iloc,jloc) = DCONJG(Slk_mat%buffer_cplx(iloc,jloc))
6886 : : end if
6887 : : !if (iglob==jglob) Slk_mat%buffer_cplx(iloc,jloc) = real(Slk_mat%buffer_cplx(iloc,jloc))
6888 : : end do
6889 : : end do
6890 : : end if
6891 : :
6892 : : case default
6893 [ # # # # : 0 : ABI_BUG(" Wrong uplo: "//TRIM(uplo))
# # ]
6894 : : end select
6895 : :
6896 : : end subroutine slkmat_dp_symmetrize
6897 : : !!***
6898 : :
6899 : : !----------------------------------------------------------------------
6900 : :
6901 : : !!****f* m_slk/slk_single_fview_read
6902 : : !! NAME
6903 : : !! slk_single_fview_read
6904 : : !!
6905 : : !! FUNCTION
6906 : : !! Return an MPI datatype that can be used to read a scaLAPACK distributed matrix from
6907 : : !! a binary file using MPI-IO.
6908 : : !!
6909 : : !! INPUTS
6910 : : !! Slk_mat<slkmat_dp_t>=Structured datatype defining the scaLAPACK distribution with the local buffer.
6911 : : !! uplo=String specifying whether only the upper or lower triangular part of the global matrix is stored on disk:
6912 : : !! = "U": Upper triangular is stored
6913 : : !! = "L": Lower triangular is stored
6914 : : !! = "A": Full matrix (used for general complex matrices)
6915 : : !! [is_fortran_file]=.FALSE. is C stream is used. .TRUE. for writing Fortran binary files
6916 : : !! with record markers. In this case etype is set xmpio_mpi_type_frm provided that
6917 : : !! the mpi_type of the matrix element is commensurate with xmpio_mpi_type_frm. Defaults to .TRUE.
6918 : : !!
6919 : : !! OUTPUT
6920 : : !! etype=Elementary data type (handle) defining the elementary unit used to access the file.
6921 : : !! slk_type=New MPI type that can be used to instantiate the MPI-IO view for the Fortran file.
6922 : : !! Note that the view assumes that the file pointer points to the FIRST Fortran record marker.
6923 : : !! offset_err=Error code. A non-zero value signals that the global matrix is too large
6924 : : !! for a single MPI-IO access (see notes below).
6925 : : !!
6926 : : !! NOTES
6927 : : !! With (signed) Fortran integers, the maximum size of the file that
6928 : : !! that can be read in one-shot is around 2Gb when etype is set to byte.
6929 : : !! Using a larger etype might create portability problems (real data on machines using
6930 : : !! integer*16 for the marker) since etype must be a multiple of the Fortran record marker
6931 : : !! Due to the above reason, block_displ is given in bytes and must be stored in a integer
6932 : : !! of kind XMPI_ADDRESS_KIND. If the displacement is too large, the routine returns
6933 : : !! offset_err=1 so that the caller will know that several MPI-IO reads are needed to
6934 : : !! read the local buffer.
6935 : : !!
6936 : : !! SOURCE
6937 : :
6938 : 0 : subroutine slk_single_fview_read(Slk_mat,uplo,etype,slk_type,offset_err,is_fortran_file)
6939 : :
6940 : : !Arguments ------------------------------------
6941 : : !scalars
6942 : : class(slkmat_dp_t),intent(in) :: Slk_mat
6943 : : integer,intent(out) :: offset_err,slk_type,etype
6944 : : character(len=*),intent(in) :: uplo
6945 : : logical,optional,intent(in) :: is_fortran_file
6946 : :
6947 : : !Local variables ------------------------------
6948 : : !scalars
6949 : : integer :: jloc,iloc,iglob,jglob,nrows_glob,ncols_glob,mpi_err,nel
6950 : : integer :: bsize_frm,mpi_type_elm,ij_loc,bsize_etype,bsize_elm
6951 : : integer(XMPI_OFFSET_KIND) :: ijp_glob,my_offset,cpad_frm
6952 : : !arrays
6953 : : character(len=500) :: msg
6954 : 0 : integer,allocatable :: block_length(:),block_type(:)
6955 : 0 : integer(XMPI_ADDRESS_KIND),allocatable :: block_displ(:)
6956 : : !************************************************************************
6957 : :
6958 : : #ifdef HAVE_MPI_IO
6959 : : !@slkmat_dp_t
6960 : 0 : bsize_frm = xmpio_bsize_frm ! Byte size of the Fortran record marker.
6961 [ # # ]: 0 : if (PRESENT(is_fortran_file)) then
6962 [ # # ]: 0 : if (.not.is_fortran_file) bsize_frm = 0
6963 : : end if
6964 : :
6965 : 0 : call slk_mat%bsize_and_type(bsize_elm, mpi_type_elm)
6966 : :
6967 : : ! Global dimensions.
6968 : 0 : nrows_glob=Slk_mat%size_global(1)
6969 : 0 : ncols_glob=Slk_mat%size_global(2)
6970 : :
6971 : : ! Number of matrix elements treated by this node.
6972 [ # # ]: 0 : nel = PRODUCT(Slk_mat%size_local(1:2))
6973 : :
6974 : : !Cannot use MPI_type_CREATE_INDEXED_BLOCK since it is not correctly implemented in several MPI libraries.
6975 : : !etype has to be set to MPI_BYTE, since the displacement in MPI structures is always in byte.
6976 : : ! ABI_WARNING("Using MPI_type_STRUCT for the MPI-IO file view")
6977 : :
6978 : 0 : etype = MPI_BYTE
6979 : 0 : call MPI_type_SIZE(etype,bsize_etype,mpi_err)
6980 : :
6981 : : ! Define the mapping between scaLAPACK buffer and the storage on file.
6982 [ # # # # : 0 : ABI_MALLOC(block_length, (nel+2))
# # # # #
# # # #
# ]
6983 [ # # # # : 0 : ABI_MALLOC(block_displ, (nel+2))
# # # # #
# # # ]
6984 [ # # # # : 0 : ABI_MALLOC(block_type, (nel+2))
# # # # ]
6985 : 0 : block_length(1)=1
6986 : 0 : block_displ (1)=0
6987 : 0 : block_type (1)=MPI_LB
6988 : :
6989 : : ! Note that the view assumes that the file pointer points to the first Fortran record marker.
6990 : 0 : offset_err=0
6991 : 0 : select case (uplo(1:1))
6992 : : case ("A","a")
6993 : : ! The entire global matrix is stored on disk.
6994 : : ! TODO can use contiguous vectors for better access.
6995 : 0 : ij_loc=0
6996 [ # # ]: 0 : do jloc=1,Slk_mat%size_local(2)
6997 [ # # ]: 0 : do iloc=1,Slk_mat%size_local(1)
6998 : 0 : call slk_mat%loc2glob(iloc, jloc, iglob, jglob)
6999 : 0 : ij_loc = ij_loc+1
7000 : 0 : my_offset = 2*(jglob-1)*bsize_frm + bsize_frm + (jglob-1)*nrows_glob*bsize_elm + (iglob-1) * bsize_elm
7001 : 0 : my_offset = my_offset / bsize_etype
7002 [ # # ]: 0 : if (xmpio_max_address(my_offset)) offset_err=1 ! Test for possible wraparounds
7003 : 0 : block_displ (ij_loc+1) = my_offset
7004 : 0 : block_type (ij_loc+1) = mpi_type_elm
7005 : 0 : block_length(ij_loc+1) = 1
7006 : : end do
7007 : : end do
7008 : :
7009 : : case ("U","u")
7010 : : ! Only the upper triangle of the global matrix is stored on disk.
7011 : 0 : ij_loc=0
7012 [ # # ]: 0 : do jloc=1,Slk_mat%size_local(2)
7013 [ # # ]: 0 : do iloc=1,Slk_mat%size_local(1)
7014 : 0 : call slk_mat%loc2glob(iloc, jloc, iglob, jglob)
7015 [ # # ]: 0 : if (jglob>=iglob) then
7016 : 0 : ijp_glob = iglob + jglob*(jglob-1)/2 ! Index for packed form
7017 : 0 : cpad_frm = 2*(jglob-1)*bsize_frm
7018 : : else
7019 : 0 : ijp_glob = jglob + iglob*(iglob-1)/2 ! Index for packed form
7020 : 0 : cpad_frm = 2*(iglob-1)*bsize_frm
7021 : : end if
7022 : 0 : ij_loc = ij_loc+1
7023 : 0 : my_offset = cpad_frm + bsize_frm + (ijp_glob-1) * bsize_elm
7024 : 0 : my_offset = my_offset / bsize_etype
7025 [ # # ]: 0 : if (xmpio_max_address(my_offset)) offset_err=1 ! Test for possible wraparounds
7026 : 0 : block_displ (ij_loc+1) = my_offset
7027 : 0 : block_type (ij_loc+1) = mpi_type_elm
7028 : 0 : block_length(ij_loc+1) = 1
7029 : : end do
7030 : : end do
7031 : :
7032 : : case ("L","l")
7033 : : ! Only the lower triangle of the global matrix is stored on disk.
7034 : 0 : ij_loc=0
7035 [ # # ]: 0 : do jloc=1,Slk_mat%size_local(2)
7036 [ # # ]: 0 : do iloc=1,Slk_mat%size_local(1)
7037 : 0 : call slk_mat%loc2glob(iloc, jloc, iglob, jglob)
7038 [ # # ]: 0 : if (jglob<=iglob) then
7039 : 0 : ijp_glob = iglob + (jglob-1)*(2*nrows_glob-jglob)/2 ! Index for packed form
7040 : 0 : cpad_frm = 2*(jglob-1)*bsize_frm
7041 : : else
7042 : 0 : ijp_glob = jglob + (iglob-1)*(2*nrows_glob-iglob)/2 ! Index for packed form
7043 : 0 : cpad_frm = 2*(iglob-1)*bsize_frm
7044 : : end if
7045 : 0 : ij_loc = ij_loc+1
7046 : 0 : my_offset = cpad_frm + bsize_frm + (ijp_glob-1) * bsize_elm
7047 : 0 : my_offset = my_offset / bsize_etype
7048 [ # # ]: 0 : if (xmpio_max_address(my_offset)) offset_err=1 ! block_displ is usually integer*4. Test for possible wraparounds
7049 : 0 : block_displ (ij_loc+1) = my_offset
7050 : 0 : block_type (ij_loc+1) = mpi_type_elm
7051 : 0 : block_length(ij_loc+1) = 1
7052 : : end do
7053 : : end do
7054 : :
7055 [ # # ]: 0 : if (offset_err/=0) then ! just warn, let the caller handle the exception.
7056 : : write(msg,"(3a)")&
7057 : 0 : " Global position index cannot be stored in standard Fortran integer ",ch10,&
7058 : 0 : " scaLAPACK matrix cannot be read with a single MPI-IO call ."
7059 : 0 : ABI_WARNING(msg)
7060 : : end if
7061 : :
7062 : : case default
7063 [ # # # # : 0 : ABI_BUG(" Wrong uplo: "//TRIM(uplo))
# # ]
7064 : : end select
7065 : :
7066 : 0 : block_length(nel+2)= 1
7067 : 0 : block_displ (nel+2)= ncols_glob * (nrows_glob*bsize_elm + 2*bsize_frm) / bsize_etype
7068 : 0 : block_type (nel+2)= MPI_UB
7069 : :
7070 : 0 : call xmpio_type_struct(nel+2,block_length,block_displ,block_type,slk_type,mpi_err)
7071 : 0 : ABI_CHECK_MPI(mpi_err,"MPI_type_STRUCT")
7072 : :
7073 : 0 : ABI_FREE(block_length)
7074 : 0 : ABI_FREE(block_displ)
7075 : 0 : ABI_FREE(block_type)
7076 : :
7077 : 0 : call MPI_type_COMMIT(slk_type,mpi_err)
7078 : 0 : ABI_CHECK_MPI(mpi_err,"MPI_type_COMMIT")
7079 : :
7080 : : #else
7081 : : ABI_ERROR("MPI-IO is mandatatory in slk_single_fview_read")
7082 : : #endif
7083 : :
7084 : 0 : end subroutine slk_single_fview_read
7085 : : !!***
7086 : :
7087 : : !----------------------------------------------------------------------
7088 : :
7089 : : !!****f* m_slk/slk_single_fview_write
7090 : : !! NAME
7091 : : !! slk_single_fview_write
7092 : : !!
7093 : : !! FUNCTION
7094 : : !! Returns an MPI datatype that can be used to write a scaLAPACK distributed matrix to
7095 : : !! a binary file using MPI-IO.
7096 : : !!
7097 : : !! INPUTS
7098 : : !! Slk_mat<slkmat_dp_t>=Structured datatype defining the scaLAPACK distribution with the local buffer.
7099 : : !! uplo=String specifying whether only the upper or lower triangular part of the global matrix is stored on disk:
7100 : : !! = "U": Upper triangular is stored
7101 : : !! = "L": Lower triangular is stored
7102 : : !! = "A": Full matrix (used for general complex matrices)
7103 : : !! [is_fortran_file]=.FALSE. is C stream is used. .TRUE. for writing Fortran binary files
7104 : : !! with record marker. In this case etype is set xmpio_mpi_type_frm provided that
7105 : : !! the mpi_type of the matrix element is commensurate with xmpio_mpi_type_frm. Defaults to .TRUE.
7106 : : !! glob_subarray(2,2) = Used to select the subarray of the global matrix. Used only when uplo="All"
7107 : : !! glob_subarray(:,1)=starting global coordinates of the subarray in each dimension
7108 : : !! (array of nonnegative integers >=1, <=array_of_sizes)
7109 : : !! glob_subarray(:,2)=Number of elements in each dimension of the subarray (array of positive integers)
7110 : : !!
7111 : : !! OUTPUT
7112 : : !! nelw=Number of elements to be written.
7113 : : !! etype=Elementary data type (handle) defining the elementary unit used to access the file.
7114 : : !! slk_type=New MPI type that can be used to instantiate the MPI-IO view for the Fortran file.
7115 : : !! Note that the view assumes that the file pointer points to the FIRST Fortran record marker.
7116 : : !! offset_err=Error code. A non-zero value signals that the global matrix is too large
7117 : : !! for a single MPI-IO access (see notes below).
7118 : : !!
7119 : : !! SIDE EFFECTS
7120 : : !! elw2slk(:,:) =
7121 : : !! input: pointer to null().
7122 : : !! output: elw2slk(2,nelw) contains the local coordinates of the matrix elements to be written.
7123 : : !! (useful only if the upper or lower triangle of the global matrix has to be written or when
7124 : : !! uplo="all" but a global subarray is written.
7125 : : !!
7126 : : !! NOTES
7127 : : !! With (signed) Fortran integers, the maximum size of the file that
7128 : : !! that can be read in one-shot is around 2Gb when etype is set to byte.
7129 : : !! Using a larger etype might create portability problems (real data on machines using
7130 : : !! integer*16 for the marker) since etype must be a multiple of the Fortran record marker
7131 : : !! Due to the above reason, block_displ is given in bytes and must be stored in a Fortran
7132 : : !! integer of kind XMPI_ADDRESS_KIND. If the displacement is too large, the routine returns
7133 : : !! offset_err=1 so that the caller will know that several MPI-IO reads are needed to
7134 : : !! write the local buffer.
7135 : : !!
7136 : : !! SOURCE
7137 : :
7138 : 0 : subroutine slk_single_fview_write(Slk_mat,uplo,nelw,elw2slk,etype,slk_type,offset_err,is_fortran_file,glob_subarray)
7139 : :
7140 : : !Arguments ------------------------------------
7141 : : !scalars
7142 : : class(slkmat_dp_t),intent(in) :: Slk_mat
7143 : : integer,intent(out) :: offset_err,slk_type,etype,nelw
7144 : : character(len=*),intent(in) :: uplo
7145 : : logical,optional,intent(in) :: is_fortran_file
7146 : : !arrays
7147 : : integer,pointer :: elw2slk(:,:)
7148 : : integer,optional,intent(in) :: glob_subarray(2,2)
7149 : :
7150 : : !Local variables ------------------------------
7151 : : !scalars
7152 : : integer :: jloc,iloc,iglob,jglob,nrows_glob,ncols_glob,mpi_err,nel_max
7153 : : integer :: grow_min,grow_max,gcol_min,gcol_max
7154 : : integer :: bsize_frm,mpi_type_elm,ij_loc,bsize_elm
7155 : : integer(XMPI_OFFSET_KIND) :: ijp_glob,my_offset,cpad_frm
7156 : : !arrays
7157 : : character(len=500) :: msg
7158 : 0 : integer,allocatable :: block_length(:),block_type(:)
7159 : 0 : integer(XMPI_ADDRESS_KIND),allocatable :: block_displ(:)
7160 : : !************************************************************************
7161 : :
7162 : : #ifdef HAVE_MPI_IO
7163 : : !@slkmat_dp_t
7164 : 0 : bsize_frm = xmpio_bsize_frm ! Byte size of the Fortran record marker.
7165 [ # # ]: 0 : if (PRESENT(is_fortran_file)) then
7166 [ # # ]: 0 : if (.not.is_fortran_file) bsize_frm = 0
7167 : : end if
7168 : :
7169 [ # # # # : 0 : if (PRESENT(glob_subarray).and..not.firstchar(uplo, ["A"])) then
# # ]
7170 : 0 : ABI_ERROR("glob_subarray should not be used when uplo/=All")
7171 : : end if
7172 : :
7173 : 0 : call slk_mat%bsize_and_type(bsize_elm, mpi_type_elm)
7174 : :
7175 : : ! Global dimensions.
7176 : 0 : nrows_glob=Slk_mat%size_global(1)
7177 : 0 : ncols_glob=Slk_mat%size_global(2)
7178 : :
7179 : : ! Number of matrix elements treated by this node.
7180 [ # # ]: 0 : nel_max = PRODUCT(Slk_mat%size_local(1:2))
7181 : :
7182 [ # # # # : 0 : ABI_MALLOC(elw2slk,(2,nel_max))
# # # # #
# # # ]
7183 [ # # # # ]: 0 : elw2slk=0
7184 : :
7185 : : ! Cannot use MPI_type_CREATE_INDEXED_BLOCK since it is not correctly implemented in several MPI libraries.
7186 : : ! etype has to be set to MPI_BYTE, since the displacement in MPI structures is always in byte.
7187 : 0 : etype = MPI_BYTE
7188 : :
7189 : : ! Define the mapping between scaLAPACK buffer and the storage on file.
7190 [ # # # # : 0 : ABI_MALLOC(block_length, (nel_max+2))
# # # # #
# # # #
# ]
7191 [ # # # # : 0 : ABI_MALLOC(block_displ, (nel_max+2))
# # # # #
# # # ]
7192 [ # # # # : 0 : ABI_MALLOC(block_type, (nel_max+2))
# # # # ]
7193 : 0 : block_length(1)=1
7194 : 0 : block_displ (1)=0
7195 : 0 : block_type (1)=MPI_LB
7196 : :
7197 : : ! Note that the view assumes that the file pointer points to the first Fortran record marker.
7198 : 0 : offset_err=0
7199 : :
7200 : 0 : select case (uplo(1:1))
7201 : : case ("A","a")
7202 : : ! The entire global matrix is written on disk. TODO can use contiguous vectors for better access.
7203 : 0 : grow_min=1; grow_max=nrows_glob
7204 : 0 : gcol_min=1; gcol_max=ncols_glob
7205 [ # # ]: 0 : if (PRESENT(glob_subarray)) then ! subarray access.
7206 : 0 : grow_min = glob_subarray(1,1)
7207 : 0 : gcol_min = glob_subarray(2,1)
7208 : 0 : grow_max = grow_min + glob_subarray(1,2) -1
7209 : 0 : gcol_max = gcol_min + glob_subarray(2,2) -1
7210 : : end if
7211 : :
7212 : 0 : ij_loc=0
7213 [ # # ]: 0 : do jloc=1,Slk_mat%size_local(2)
7214 [ # # ]: 0 : do iloc=1,Slk_mat%size_local(1)
7215 : 0 : call slk_mat%loc2glob(iloc, jloc, iglob, jglob)
7216 : : if (iglob>=grow_min.and.iglob<=grow_max .and. & ! glob_subarray element.
7217 [ # # # # : 0 : jglob>=gcol_min.and.jglob<=gcol_max) then
# # # # ]
7218 : 0 : ij_loc = ij_loc+1
7219 : 0 : my_offset = 2*(jglob-1)*bsize_frm + bsize_frm + (jglob-1)*nrows_glob*bsize_elm + (iglob-1) * bsize_elm
7220 [ # # ]: 0 : if (xmpio_max_address(my_offset)) offset_err=1 ! Test for possible wraparounds
7221 : 0 : block_displ (ij_loc+1) = my_offset
7222 : 0 : block_type (ij_loc+1) = mpi_type_elm
7223 : 0 : block_length(ij_loc+1) = 1
7224 [ # # ]: 0 : elw2slk(:,ij_loc) = (/iloc,jloc/) ! useless when subarray are not used but oh well!
7225 : : end if
7226 : : end do
7227 : : end do
7228 : :
7229 : : case ("U","u")
7230 : : ! Only the upper triangle of the global matrix is stored on disk.
7231 : 0 : ij_loc=0
7232 [ # # ]: 0 : do jloc=1,Slk_mat%size_local(2)
7233 [ # # ]: 0 : do iloc=1,Slk_mat%size_local(1)
7234 : 0 : call slk_mat%loc2glob(iloc, jloc, iglob, jglob)
7235 [ # # ]: 0 : if (jglob>=iglob) then
7236 : 0 : ijp_glob = iglob + jglob*(jglob-1)/2 ! Index for packed form
7237 : 0 : cpad_frm = 2*(jglob-1)*bsize_frm
7238 : 0 : ij_loc = ij_loc+1
7239 : 0 : my_offset = cpad_frm + bsize_frm + (ijp_glob-1) * bsize_elm
7240 [ # # ]: 0 : if (xmpio_max_address(my_offset)) offset_err=1 ! Test for possible wraparounds
7241 : 0 : block_displ (ij_loc+1) = my_offset
7242 : 0 : block_type (ij_loc+1) = mpi_type_elm
7243 : 0 : block_length(ij_loc+1) = 1
7244 [ # # ]: 0 : elw2slk(:,ij_loc) = (/iloc,jloc/)
7245 : : end if
7246 : : end do
7247 : : end do
7248 : :
7249 : : case ("L","l")
7250 : : ! Only the lower triangle of the global matrix is stored on disk.
7251 : 0 : ij_loc=0
7252 [ # # ]: 0 : do jloc=1,Slk_mat%size_local(2)
7253 [ # # ]: 0 : do iloc=1,Slk_mat%size_local(1)
7254 : 0 : call slk_mat%loc2glob(iloc, jloc, iglob, jglob)
7255 [ # # ]: 0 : if (jglob<=iglob) then
7256 : 0 : ijp_glob = iglob + (jglob-1)*(2*nrows_glob-jglob)/2 ! Index for packed form
7257 : 0 : cpad_frm = 2*(jglob-1)*bsize_frm
7258 : 0 : ij_loc = ij_loc+1
7259 : 0 : my_offset = cpad_frm + bsize_frm + (ijp_glob-1) * bsize_elm
7260 [ # # ]: 0 : if (xmpio_max_address(my_offset)) offset_err=1 ! block_displ is usually integer*4. Test for possible wraparounds
7261 : 0 : block_displ (ij_loc+1) = my_offset
7262 : 0 : block_type (ij_loc+1) = mpi_type_elm
7263 : 0 : block_length(ij_loc+1) = 1
7264 [ # # ]: 0 : elw2slk(:,ij_loc) = (/iloc,jloc/)
7265 : : end if
7266 : : end do
7267 : : end do
7268 : :
7269 : : case default
7270 [ # # # # : 0 : ABI_BUG(" Wrong uplo: "//TRIM(uplo))
# # ]
7271 : : end select
7272 : :
7273 [ # # ]: 0 : if (offset_err/=0) then ! just warn, let the caller handle the exception.
7274 : : write(msg,"(3a)")&
7275 : 0 : "Global position index cannot be stored in standard Fortran integer ",ch10,&
7276 : 0 : "scaLAPACK matrix cannot be read with a single MPI-IO call ."
7277 : 0 : ABI_WARNING(msg)
7278 : : end if
7279 : :
7280 : : ! Final number of matrix elements that will be written by this node.
7281 : 0 : nelw = ij_loc
7282 : :
7283 : 0 : block_length(nelw+2)= 1
7284 : 0 : block_displ (nelw+2)= ncols_glob * (nrows_glob*bsize_elm + 2*bsize_frm)
7285 : 0 : block_type (nelw+2)= MPI_UB
7286 : :
7287 : 0 : call xmpio_type_struct(nelw+2,block_length,block_displ,block_type,slk_type,mpi_err)
7288 : 0 : ABI_CHECK_MPI(mpi_err, "MPI_type_STRUCT")
7289 : :
7290 : 0 : ABI_FREE(block_length)
7291 : 0 : ABI_FREE(block_displ)
7292 : 0 : ABI_FREE(block_type)
7293 : :
7294 : 0 : call MPI_type_COMMIT(slk_type,mpi_err)
7295 : 0 : ABI_CHECK_MPI(mpi_err, "MPI_type_COMMIT")
7296 : :
7297 : : #else
7298 : : ABI_ERROR("MPI-IO is mandatatory in slk_single_fview_read")
7299 : : #endif
7300 : :
7301 : 0 : end subroutine slk_single_fview_write
7302 : : !!***
7303 : :
7304 : : !----------------------------------------------------------------------
7305 : :
7306 : : !!****f* m_slk/slkmat_dp_bsize_and_type
7307 : : !! NAME
7308 : : !! slkmat_dp_bsize_and_type
7309 : : !!
7310 : : !! FUNCTION
7311 : : !! Returns the byte size and the MPI datatype associated to the matrix elements
7312 : : !! that are stored in the ScaLAPACK_matrix
7313 : : !!
7314 : : !! INPUTS
7315 : : !! Slk_mat<slkmat_dp_t>=Structured datatype defining the scaLAPACK distribution with the local buffer
7316 : : !!
7317 : : !! OUTPUT
7318 : : !! bsize_elm=Byte size of the matrix element.
7319 : : !! mpi_type_elm=MPI datatype of the matrix element.
7320 : : !!
7321 : : !! SOURCE
7322 : :
7323 : 0 : subroutine slkmat_dp_bsize_and_type(Slk_mat, bsize_elm, mpi_type_elm)
7324 : :
7325 : : !Arguments ------------------------------------
7326 : : !scalars
7327 : : class(slkmat_dp_t),intent(in) :: Slk_mat
7328 : : integer,intent(out) :: bsize_elm,mpi_type_elm
7329 : :
7330 : : !Local variables ------------------------------
7331 : : !scalars
7332 : : integer :: ierr
7333 : : character(len=500) :: msg
7334 : : ! ************************************************************************
7335 : :
7336 : 0 : ierr=0
7337 : : #ifdef HAVE_MPI
7338 [ # # ]: 0 : if (allocated(Slk_mat%buffer_cplx)) then
7339 : 0 : ierr = ierr + 1
7340 : 0 : mpi_type_elm = MPI_DOUBLE_COMPLEX
7341 : 0 : bsize_elm = xmpi_bsize_dpc
7342 : : end if
7343 : :
7344 [ # # ]: 0 : if (allocated(Slk_mat%buffer_real)) then
7345 : 0 : ierr = ierr + 1
7346 : 0 : mpi_type_elm = MPI_DOUBLE_PRECISION
7347 : 0 : bsize_elm = xmpi_bsize_dp
7348 : : end if
7349 : : #endif
7350 : :
7351 : : ! One and only one buffer should be allocated.
7352 [ # # ]: 0 : if (ierr /= 1) then
7353 : 0 : write(msg,'(a,i0)')" ScaLAPACK buffers are not allocated correctly, ierr= ",ierr
7354 : 0 : ABI_ERROR(msg)
7355 : : end if
7356 : :
7357 : 0 : end subroutine slkmat_dp_bsize_and_type
7358 : : !!***
7359 : :
7360 : : !----------------------------------------------------------------------
7361 : :
7362 : : !!****f* m_slk/slkmat_sp_svd
7363 : : !! NAME
7364 : : !! slkmat_sp_svd
7365 : : !!
7366 : : !! FUNCTION
7367 : : !! Compute Singular Value Decomposition of matrix in_mat (single precision version).
7368 : : !!
7369 : : !! SIDE EFFECTS
7370 : : !! in_mat: matrix is destroyed in output.
7371 : : !!
7372 : : !! SOURCE
7373 : :
7374 [ # # # # ]: 0 : subroutine slkmat_sp_svd(in_mat, jobu, jobvt, u_mat, s_vals, vt_mat)
7375 : :
7376 : : !Arguments ------------------------------------
7377 : : class(slkmat_sp_t),intent(inout) :: in_mat
7378 : : character(len=1),intent(in) :: jobu, jobvt
7379 : : class(slkmat_sp_t),intent(out) :: u_mat, vt_mat
7380 : : real(sp),allocatable, intent(out) :: s_vals(:)
7381 : :
7382 : : #ifdef HAVE_LINALG_SCALAPACK
7383 : : !Local variables ------------------------------
7384 : : !scalars
7385 : : integer :: info, lwork, lrwork, isize, mm, nn
7386 : : !array
7387 : : real(sp),allocatable :: rwork_sp(:)
7388 : : complex(sp),allocatable :: cwork_sp(:)
7389 : : !************************************************************************
7390 : :
7391 : : if (in_mat%desc(MB_) /= in_mat%desc(NB_)) then
7392 : : ABI_ERROR("PCGESVD requires square block decomposition i.e MB_A = NB_A.")
7393 : : end if
7394 : :
7395 : : mm = in_mat%size_global(1); nn = in_mat%size_global(2); isize = min(mm, nn)
7396 : :
7397 : : ! Allocate singular values and output matrices.
7398 : :
7399 : : ABI_CALLOC(s_vals, (isize))
7400 : : if (jobu == "V") call u_mat%init(mm, isize, in_mat%processor, in_mat%istwf_k)
7401 : : if (jobvt == "V") call vt_mat%init(isize, nn, in_mat%processor, in_mat%istwf_k)
7402 : :
7403 : : if (allocated(in_mat%buffer_cplx)) then
7404 : : ! Query optimal workspace size
7405 : : lwork = -1
7406 : : ABI_MALLOC(cwork_sp, (1))
7407 : : ABI_MALLOC(rwork_sp, (1))
7408 : :
7409 : : call PCGESVD(jobu, jobvt, &
7410 : : mm, nn, in_mat%buffer_cplx, 1, 1, in_mat%desc, s_vals, &
7411 : : u_mat%buffer_cplx, 1, 1, u_mat%desc, &
7412 : : vt_mat%buffer_cplx, 1, 1, vt_mat%desc, &
7413 : : cwork_sp, lwork, rwork_sp, info)
7414 : :
7415 : : ABI_CHECK(info == 0, sjoin("CZGESVD returned info:", itoa(info)))
7416 : :
7417 : : ! Allocate optimal workspace
7418 : : lwork = nint(real(cwork_sp(1)))
7419 : : lrwork = nint(rwork_sp(1))
7420 : : ABI_FREE(cwork_sp)
7421 : : ABI_FREE(rwork_sp)
7422 : :
7423 : : ABI_MALLOC(cwork_sp, (lwork))
7424 : : ABI_MALLOC(rwork_sp, (lrwork))
7425 : :
7426 : : ! Perform SVD
7427 : : call PCGESVD(jobu, jobvt, &
7428 : : mm, nn, in_mat%buffer_cplx, 1, 1, in_mat%desc, s_vals, &
7429 : : u_mat%buffer_cplx, 1, 1, u_mat%desc, &
7430 : : vt_mat%buffer_cplx, 1, 1, vt_mat%desc, &
7431 : : cwork_sp, lwork, rwork_sp, info)
7432 : :
7433 : : ABI_FREE(cwork_sp)
7434 : : ABI_FREE(rwork_sp)
7435 : : ABI_CHECK(info == 0, sjoin("PCGESVD returned info:", itoa(info)))
7436 : :
7437 : : else if (allocated(in_mat%buffer_real)) then
7438 : : ABI_ERROR("SVD for real matrices not coded!")
7439 : : else
7440 : : ABI_ERROR("Neither complex nor real buffer are allocated!")
7441 : : end if
7442 : : #endif
7443 : :
7444 : 0 : end subroutine slkmat_sp_svd
7445 : : !!***
7446 : :
7447 : : !----------------------------------------------------------------------
7448 : :
7449 : : !!****f* m_slk/slkmat_dp_svd
7450 : : !! NAME
7451 : : !! slkmat_dp_svd
7452 : : !!
7453 : : !! FUNCTION
7454 : : !! Compute Singular Value Decomposition of matrix in_mat (double precision version).
7455 : : !!
7456 : : !! SIDE EFFECTS
7457 : : !! in_mat: matrix is destroyed in output.
7458 : : !!
7459 : : !! SOURCE
7460 : :
7461 [ # # # # ]: 0 : subroutine slkmat_dp_svd(in_mat, jobu, jobvt, u_mat, s_vals, vt_mat)
7462 : :
7463 : : !Arguments ------------------------------------
7464 : : class(slkmat_dp_t),intent(inout) :: in_mat
7465 : : character(len=1),intent(in) :: jobu, jobvt
7466 : : class(slkmat_dp_t),intent(out) :: u_mat, vt_mat
7467 : : real(dp),allocatable, intent(out) :: s_vals(:)
7468 : :
7469 : : #ifdef HAVE_LINALG_SCALAPACK
7470 : : !Local variables ------------------------------
7471 : : !scalars
7472 : : integer :: info, lwork, lrwork, isize, mm, nn
7473 : : !array
7474 : : real(dp),allocatable :: rwork_dp(:)
7475 : : complex(dp),allocatable :: cwork_dp(:)
7476 : : !************************************************************************
7477 : :
7478 : : if (in_mat%desc(MB_) /= in_mat%desc(NB_)) then
7479 : : ABI_ERROR("PZGESVD requires square block decomposition i.e MB_A = NB_A.")
7480 : : end if
7481 : :
7482 : : mm = in_mat%size_global(1); nn = in_mat%size_global(2); isize = min(mm, nn)
7483 : :
7484 : : ! Allocate singular values and output matrices.
7485 : : ABI_CALLOC(s_vals, (isize))
7486 : :
7487 : : if (jobu == "V") call u_mat%init(mm, isize, in_mat%processor, in_mat%istwf_k)
7488 : : if (jobvt == "V") call vt_mat%init(isize, nn, in_mat%processor, in_mat%istwf_k)
7489 : :
7490 : : if (allocated(in_mat%buffer_cplx)) then
7491 : : ! Query optimal workspace size
7492 : : lwork = -1
7493 : : ABI_MALLOC(cwork_dp, (1))
7494 : : ABI_MALLOC(rwork_dp, (1))
7495 : :
7496 : : call PZGESVD(jobu, jobvt, &
7497 : : mm, nn, in_mat%buffer_cplx, 1, 1, in_mat%desc, s_vals, &
7498 : : u_mat%buffer_cplx, 1, 1, u_mat%desc, &
7499 : : vt_mat%buffer_cplx, 1, 1, vt_mat%desc, &
7500 : : cwork_dp, lwork, rwork_dp, info)
7501 : :
7502 : : ABI_CHECK(info == 0, sjoin("CZGESVD returned info:", itoa(info)))
7503 : :
7504 : : ! Allocate optimal workspace
7505 : : lwork = nint(real(cwork_dp(1)))
7506 : : lrwork = nint(rwork_dp(1))
7507 : : ABI_FREE(cwork_dp)
7508 : : ABI_FREE(rwork_dp)
7509 : :
7510 : : ABI_MALLOC(cwork_dp, (lwork))
7511 : : ABI_MALLOC(rwork_dp, (lrwork))
7512 : :
7513 : : ! Perform SVD
7514 : : call PZGESVD(jobu, jobvt, &
7515 : : mm, nn, in_mat%buffer_cplx, 1, 1, in_mat%desc, s_vals, &
7516 : : u_mat%buffer_cplx, 1, 1, u_mat%desc, &
7517 : : vt_mat%buffer_cplx, 1, 1, vt_mat%desc, &
7518 : : cwork_dp, lwork, rwork_dp, info)
7519 : :
7520 : : ABI_FREE(cwork_dp)
7521 : : ABI_FREE(rwork_dp)
7522 : : ABI_CHECK(info == 0, sjoin("CZGESVD returned info:", itoa(info)))
7523 : :
7524 : : else if (allocated(in_mat%buffer_real)) then
7525 : : ABI_ERROR("SVD for real matrices not coded!")
7526 : : else
7527 : : ABI_ERROR("Neither complex nor real buffer are allocated!")
7528 : : end if
7529 : : #endif
7530 : :
7531 : 0 : end subroutine slkmat_dp_svd
7532 : : !!***
7533 : :
7534 [ # # # # : 0 : end module m_slk
# # # # #
# # # # #
# # # # #
# # # #
# ]
7535 : : !!***
|
