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 and ELPA API.
7 : : !!
8 : : !! COPYRIGHT
9 : : !! Copyright (C) 2004-2026 ABINIT group (CS,GZ,FB,MG,MT)
10 : : !! This file is distributed under the terms of the
11 : : !! GNU General Public License, see ~abinit/COPYING
12 : : !! or http://www.gnu.org/copyleft/gpl.txt .
13 : : !!
14 : : !! TODO
15 : : !! Provide fallbacks for sequential version (No scalapack) so that we can implement generic high-level algorithms.
16 : : !!
17 : : !! SOURCE
18 : :
19 : : #if defined HAVE_CONFIG_H
20 : : #include "config.h"
21 : : #endif
22 : :
23 : : #include "abi_common.h"
24 : :
25 : : module m_slk
26 : :
27 : : use, intrinsic :: iso_c_binding
28 : : use defs_basis
29 : : USE_MPI
30 : : use m_xmpi
31 : : use m_xomp
32 : : use m_errors
33 : : use m_abicore
34 : : use m_gputk
35 : : #ifdef HAVE_LINALG_ELPA
36 : : use m_elpa
37 : : #endif
38 : :
39 : : use m_fstrings, only : firstchar, toupper, itoa, sjoin, ltoa, string_in
40 : : use m_time, only : cwtime, cwtime_report
41 : : !use m_numeric_tools, only : blocked_loop !, print_arr
42 : :
43 : : implicit none
44 : :
45 : : #ifdef HAVE_MPI1
46 : : include 'mpif.h'
47 : : #endif
48 : :
49 : : private
50 : :
51 : : ! scaLAPACK array descriptor.
52 : : integer,private,parameter :: DLEN_ = 9 ! length
53 : : integer,private,parameter :: Dtype_ = 1 ! type
54 : : integer,private,parameter :: CTXT_ = 2 ! BLACS context
55 : : integer,private,parameter :: M_ = 3 ! nb global lines
56 : : integer,private,parameter :: N_ = 4 ! nb global columns
57 : : integer,private,parameter :: MB_ = 5 ! nb lines of a block
58 : : integer,private,parameter :: NB_ = 6 ! nb columns of a block
59 : : integer,private,parameter :: RSRC_ = 7 ! line of processors at the beginning
60 : : integer,private,parameter :: CSRC_ = 8 ! column of processors at the beginning
61 : : integer,private,parameter :: LLD_ = 9 ! local number of lines
62 : : !!***
63 : :
64 : : !----------------------------------------------------------------------
65 : :
66 : : !!****t* m_slk/slk_grid_t
67 : : !! NAME
68 : : !! slk_grid_t
69 : : !!
70 : : !! FUNCTION
71 : : !! Grid of ScaLAPACK processors.
72 : : !!
73 : : !! SOURCE
74 : :
75 : : type,public :: slk_grid_t
76 : :
77 : : integer :: nprocs = -1
78 : : ! Total number of processors
79 : :
80 : : integer :: dims(2) = -1
81 : : ! Number of procs for rows/columns
82 : :
83 : : integer :: comm = xmpi_comm_null
84 : : ! BLACS context i.e. MPI communicator.
85 : :
86 : : logical :: use_gpu = .false.
87 : : ! Wether GPU is used, relevant for determining matrix block size.
88 : :
89 : : contains
90 : : procedure :: init => slk_grid_init ! Set up the processor grid for ScaLAPACK.
91 : : end type slk_grid_t
92 : : !!***
93 : :
94 : : !----------------------------------------------------------------------
95 : :
96 : : !!****t* m_slk/slk_processor_t
97 : : !! NAME
98 : : !! slk_processor_t
99 : : !!
100 : : !! FUNCTION
101 : : !! One processor in the grid.
102 : : !!
103 : : !! SOURCE
104 : :
105 : : type,public :: slk_processor_t
106 : :
107 : : integer :: my_rank = -1
108 : : ! rank of the processor in comm
109 : :
110 : : integer :: comm = xmpi_comm_null
111 : : ! MPI communicator underlying the BLACS grid.
112 : :
113 : : integer :: coords(2) = -1
114 : : ! Coordinates of the processor in the grid.
115 : :
116 : : type(slk_grid_t) :: grid
117 : : ! the grid to which the processor is associated to.
118 : :
119 : : contains
120 : : procedure :: init => slk_processor_init ! Initializes an instance of processor ScaLAPACK from a MPI communicator.
121 : : procedure :: free => slk_processor_free ! Free the object
122 : : end type slk_processor_t
123 : : !!***
124 : :
125 : : !----------------------------------------------------------------------
126 : :
127 : : !!****t* m_slk/basemat_t
128 : : !! NAME
129 : : !! basemat_t
130 : : !!
131 : : !! FUNCTION
132 : : !! Base class for scalapack matrices.
133 : : !! Methods that are agnostic about type and precision or methods that can handle both
134 : : !! single and double precision, real and complex arrays via `select type` should be defined here.
135 : : !!
136 : : !! SOURCE
137 : :
138 : : type, private :: basemat_t
139 : :
140 : : integer :: size_local(2) = -1
141 : : ! dimensions of the local buffer.
142 : :
143 : : integer(c_size_t) :: bufsize = -1
144 : : ! Size of the local buffer.
145 : :
146 : : integer :: size_global(2) = -1
147 : : ! dimensions of the global matrix.
148 : :
149 : : integer :: size_blocs(2) = -1
150 : : ! size of the block of consecutive data
151 : :
152 : : integer :: istwf_k = -1
153 : :
154 : : type(slk_processor_t),pointer :: processor => null()
155 : :
156 : : integer :: desc(DLEN_)
157 : : ! Scalapack descriptor.
158 : :
159 : : contains
160 : :
161 : : procedure :: init => basemat_init
162 : : ! Basic Constructor
163 : :
164 : : procedure :: glob2loc => basemat_glob2loc
165 : : ! Determine the local indices of an element from its global indices and return haveit bool flag.
166 : :
167 : : procedure :: loc2glob => basemat_loc2glob
168 : : ! Return global indices of a matrix element from the local indices.
169 : :
170 : : procedure :: loc2grow => basemat_loc2grow
171 : : ! Determine the global row index from the local index
172 : :
173 : : procedure :: loc2gcol => basemat_loc2col
174 : : ! Determine the global column index from the local index
175 : :
176 : : procedure :: idx_loc => basemat_idx_loc
177 : : ! Local indices of an entry
178 : : ! from its global indices, independently of the processor.
179 : :
180 : : procedure :: locmem_mb => basemat_locmem_mb
181 : : ! Return memory allocated for the local buffer in Mb.
182 : :
183 : : procedure :: print => basemat_print
184 : : ! Print info on the object.
185 : :
186 : : procedure :: check_local_shape => basemat_check_local_shape
187 : : ! Debugging tool to test the local shape `lshape` of the local buffer.
188 : :
189 : : procedure :: is_gpu_mapped => basemat_is_gpu_mapped
190 : : ! True if the local buffer is mapped to the GPU.
191 : :
192 : : procedure :: gpu_map => basemat_gpu_map
193 : : ! Use Opemp to allocate/delete the local buffer on the GPU.
194 : :
195 : : procedure :: gpu_set_zero => basemat_gpu_set_zero
196 : : ! Fill the local buffer on the GPU with zeros.
197 : :
198 : : procedure :: free => basemat_free
199 : : ! Free memory
200 : :
201 : : procedure :: change_size_blocs => basemat_change_size_blocs
202 : : ! Change the block sizes, return new object.
203 : :
204 : : procedure :: get_trace => basemat_get_trace
205 : : ! Compute the trace of an N-by-N distributed matrix.
206 : :
207 : : procedure :: set_imag_diago_to_zero => basemat_set_imag_diago_to_zero
208 : : ! Set the imaginary part of the diagonal to zero.
209 : :
210 : : procedure :: invert => basemat_invert
211 : : ! Inverse of a complex matrix.
212 : :
213 : : end type basemat_t
214 : : !!***
215 : :
216 : : !----------------------------------------------------------------------
217 : :
218 : : !!****t* m_slk/slkmat_dp_t
219 : : !! NAME
220 : : !! slkmat_dp_t
221 : : !!
222 : : !! FUNCTION
223 : : !! high-level interface to ScaLAPACK matrix (double precision version)
224 : : !!
225 : : !! SOURCE
226 : :
227 : : type, public, extends(basemat_t) :: slkmat_dp_t
228 : :
229 : : real(dp),allocatable :: buffer_real(:,:)
230 : : ! local part of the (real) matrix.
231 : : ! The istwf_k option passed to the constructor defines whether we have a real or complex matrix
232 : :
233 : : complex(dpc),allocatable :: buffer_cplx(:,:)
234 : : ! local part of the (complex) matrix
235 : :
236 : : contains
237 : :
238 : : procedure :: get_head_and_wings => slkmat_dp_get_head_and_wings
239 : : ! Return global arrays with the head and the wings of the matrix.
240 : :
241 : : procedure :: set_head_and_wings => slkmat_dp_set_head_and_wings
242 : : ! Set head and the wings of the matrix starting from global arrays.
243 : :
244 : : procedure :: copy => slkmat_dp_copy
245 : : ! Copy object
246 : :
247 : : procedure :: hpd_invert => slkmat_dp_hpd_invert
248 : : ! Inverse of a Hermitian positive definite matrix.
249 : :
250 : : procedure :: ptrans => slkmat_dp_ptrans
251 : : ! Transpose matrix
252 : :
253 : : procedure :: cut => slkmat_dp_cut
254 : : ! Extract submatrix and create new matrix with `size_blocs` and `processor`
255 : :
256 : : procedure :: take_from => slkmat_dp_take_from
257 : : ! Take values from source
258 : :
259 : : procedure :: collect_cplx => slkmat_dp_collect_cplx
260 : : ! Return on all processors the submatrix of shape (mm, nn) starting at position ija.
261 : :
262 : : procedure :: heev => slkmat_dp_heev
263 : : ! Compute eigenvalues and, optionally, eigenvectors of an Hermitian matrix A. A * X = lambda * X
264 : :
265 : : procedure :: pzheevx => slkmat_dp_pzheevx
266 : : ! Compute Eigenvalues and, optionally, eigenvectors of a complex Hermitian matrix A. ! A * X = lambda * X
267 : :
268 : : procedure :: pzhegvx => slkmat_dp_pzhegvx
269 : : ! Eigenvalues and, optionally, eigenvectors of a complex
270 : : ! generalized Hermitian-definite eigenproblem, of the form
271 : : ! sub( A )*x=(lambda)*sub( B )*x, sub( A )*sub( B )x=(lambda)*x,
272 : : ! or sub( B )*sub( A )*x=(lambda)*x.
273 : :
274 : : procedure :: symmetrize => slkmat_dp_symmetrize
275 : : ! Symmetrizes a square scaLAPACK matrix.
276 : :
277 : : procedure :: bsize_and_type => slkmat_dp_bsize_and_type
278 : : ! Returns the byte size and the MPI datatype
279 : :
280 : : procedure :: svd => slkmat_dp_svd
281 : : ! Singular Value Decomposition (double precision version).
282 : :
283 : : procedure :: to_global => slkmat_dp_to_global
284 : : ! Fill a full matrix with respect to a SCALAPACK matrix.
285 : :
286 : : procedure :: from_real_glob => slkmat_dp_from_real_glob
287 : : ! Fills SCALAPACK matrix from full matrix.
288 : :
289 : : procedure :: from_global_pack => slkmat_dp_from_global_pack
290 : : ! Fills SCALAPACK matrix from full matrix.
291 : :
292 : : procedure :: from_global_sym => slkmat_dp_from_global_sym
293 : : ! Fills SCALAPACK matrix from full matrix.
294 : :
295 : : procedure :: to_global_pack => slkmat_dp_to_global_pack
296 : : ! Inserts a ScaLAPACK matrix into a global one.
297 : :
298 : : procedure :: to_real_glob => slkmat_dp_to_real_glob
299 : : ! Inserts a ScaLAPACK matrix into a real matrix.
300 : :
301 : : procedure :: to_complex_glob => slkmat_dp_to_complex_glob
302 : : ! Inserts a ScaLAPACK matrix into a complex matrix.
303 : :
304 : : procedure :: from_complex_glob => slkmat_dp_from_complex_glob
305 : : ! Fills SCALAPACK matrix from a full matrix.
306 : :
307 : : end type slkmat_dp_t
308 : : !!***
309 : :
310 : : !!****t* m_slk/slkmat_sp_t
311 : : !! NAME
312 : : !! slkmat_sp_t
313 : : !!
314 : : !! FUNCTION
315 : : !! High-level interface to ScaLAPACK matrix (single precision version).
316 : : !!
317 : : !! SOURCE
318 : :
319 : : type, public, extends(basemat_t) :: slkmat_sp_t
320 : :
321 : : real(sp),allocatable :: buffer_real(:,:)
322 : : ! local part of the (real) matrix.
323 : : ! The istwf_k option passed to the constructor defines whether we have a real or complex matrix
324 : :
325 : : complex(sp),allocatable :: buffer_cplx(:,:)
326 : : ! local part of the (complex) matrix
327 : :
328 : : contains
329 : :
330 : : procedure :: copy => slkmat_sp_copy
331 : : ! Copy object
332 : :
333 : : procedure :: take_from => slkmat_sp_take_from
334 : : ! Take values from source
335 : :
336 : : procedure :: ptrans => slkmat_sp_ptrans
337 : : ! Transpose matrix
338 : :
339 : : procedure :: set_head_and_wings => slkmat_sp_set_head_and_wings
340 : : ! Set head and the wings of the matrix starting from global arrays.
341 : :
342 : : procedure :: cut => slkmat_sp_cut
343 : : ! Extract submatrix and create new matrix with `size_blocs` and `processor`
344 : :
345 : : procedure :: collect_cplx => slkmat_sp_collect_cplx
346 : : ! Return on all processors the submatrix of shape (mm, nn) starting at position ija.
347 : :
348 : : procedure :: heev => slkmat_sp_heev
349 : : ! Compute eigenvalues and, optionally, eigenvectors of an Hermitian matrix A. A * X = lambda * X
350 : :
351 : : procedure :: hpd_invert => slkmat_sp_hpd_invert
352 : : ! Inverse of a Hermitian positive definite matrix.
353 : :
354 : : procedure :: svd => slkmat_sp_svd
355 : : ! Singular Value Decomposition (single precision version).
356 : :
357 : : end type slkmat_sp_t
358 : : !!***
359 : :
360 : : public :: block_dist_1d ! Return block size for one-dimensional block column/row distribution
361 : : public :: slk_has_elpa ! Return True if ELPA support is activated
362 : :
363 : : ! ???
364 : : public :: matrix_get_local_cplx ! Return a local matrix coefficient of complex type.
365 : : public :: matrix_get_local_real ! Return a local matrix coefficient of double precision type.
366 : : public :: matrix_set_local_cplx ! Sets a local matrix coefficient of complex type.
367 : : public :: matrix_set_local_real ! Sets a local matrix coefficient of double precision type.
368 : : ! ???
369 : :
370 : : public :: slk_matrix_from_global_dpc_2D ! Fill a complex SCALAPACK matrix with respect to a global matrix.
371 : : public :: slk_matrix_from_global_dpc_1Dp ! Fill a complex SCALAPACK matrix with respect to a global matrix.
372 : : ! target: double precision complex matrix in packed form.
373 : : public :: slk_matrix_to_global_dpc_2D ! Fill a global matrix with respect to a SCALAPACK matrix.
374 : : ! target: Two-dimensional Double precision complex matrix.
375 : :
376 : : public :: slk_pgemm ! Compute: C := alpha*A*B + beta*C
377 : : interface slk_pgemm
378 : : module procedure slk_pgemm_dp
379 : : module procedure slk_pgemm_sp
380 : : end interface slk_pgemm
381 : :
382 : :
383 : : public :: compute_eigen_problem ! Compute eigenvalues and eigenvectors of: A * X = lambda * X.
384 : : ! complex and real cases.
385 : : public :: compute_generalized_eigen_problem ! Compute generalized eigenvalue problem
386 : : public :: compute_eigen1 ! Compute eigenvalues and eigenvectors. complex and real cases.
387 : : public :: compute_eigen2 ! Compute eigenvalues and eigenvectors: A * X = lambda * B * X
388 : : ! complex and real cases.
389 : :
390 : : public :: slk_write ! Writes a square scaLAPACK distributed matrix on an external file using MPI-IO.
391 : : public :: slk_read ! Read a square scaLAPACK distributed matrix from an external file using MPI-IO.
392 : : public :: slk_single_fview_read_mask ! Returns an MPI datatype that can be used to read a scaLAPACK matrix from
393 : : ! a binary file using MPI-IO.
394 : : ! The view is created using the user-defined mask function
395 : : public :: slk_single_fview_read ! Returns an MPI datatype to read a scaLAPACK distributed matrix
396 : : ! from a binary file using MPI-IO.
397 : : public :: slk_single_fview_write ! Returns an MPI datatype to write a scaLAPACK distributed matrix
398 : : ! to a binary file using MPI-IO.
399 : :
400 : : public :: slk_array_free ! Deallocate array of slkmat_dp_t elements
401 : : interface slk_array_free
402 : : module procedure slk_array1_free
403 : : module procedure slk_array2_free
404 : : module procedure slk_array3_free
405 : : module procedure slk_array4_free
406 : : module procedure slk_array5_free
407 : : end interface slk_array_free
408 : :
409 : : public :: slk_array_set_zero ! Elemental routine to zero the value of the local buffer.
410 : : public :: slk_array_locmem_mb ! Compute memory allocated for an array of slkmat_dp_t elements
411 : :
412 : : public :: slk_array_gpu_set_zero ! Zero the value of the local buffer on the GPU
413 : : interface slk_array_gpu_set_zero
414 : : module procedure slk_array1_gpu_set_zero
415 : : module procedure slk_array2_gpu_set_zero
416 : : module procedure slk_array3_gpu_set_zero
417 : : module procedure slk_array4_gpu_set_zero
418 : : module procedure slk_array5_gpu_set_zero
419 : : end interface slk_array_gpu_set_zero
420 : :
421 : : ! External functions.
422 : : #if defined(HAVE_LINALG_SCALAPACK) || defined(HAVE_LINALG_ELPA)
423 : : integer,external :: indxl2g, numroc
424 : : real(dp),external :: PDLAMCH
425 : : real(dp),external :: PDLATRA
426 : : real(sp),external :: PSLATRA
427 : : complex(sp),external :: PCLATRA
428 : : complex(dp),external :: PZLATRA
429 : : #endif
430 : :
431 : : #ifdef HAVE_LINALG_SLATE
432 : :
433 : : interface
434 : : ! Standard complex Hermitian: A * Z = Z * diag(w)
435 : : subroutine slate_zheev_c(n, nb, nprow, npcol, comm_f, &
436 : : lda, a_data, ldz, z_data, w, nev, use_gpu, info) &
437 : : bind(C, name="slate_zheev_c")
438 : : use, intrinsic :: iso_c_binding
439 : : integer(c_int), value :: n, nb, nprow, npcol, comm_f, lda, ldz, nev, use_gpu
440 : : complex(c_double_complex), intent(inout) :: a_data(*)
441 : : complex(c_double_complex), intent(out) :: z_data(*)
442 : : real(c_double), intent(out) :: w(*)
443 : : integer(c_int), intent(out) :: info
444 : : end subroutine slate_zheev_c
445 : :
446 : : ! Standard real symmetric: A * Z = Z * diag(w)
447 : : subroutine slate_dsyev_c(n, nb, nprow, npcol, comm_f, &
448 : : lda, a_data, ldz, z_data, w, nev, use_gpu, info) &
449 : : bind(C, name="slate_dsyev_c")
450 : : use, intrinsic :: iso_c_binding
451 : : integer(c_int), value :: n, nb, nprow, npcol, comm_f, lda, ldz, nev, use_gpu
452 : : real(c_double), intent(inout) :: a_data(*)
453 : : real(c_double), intent(out) :: z_data(*)
454 : : real(c_double), intent(out) :: w(*)
455 : : integer(c_int), intent(out) :: info
456 : : end subroutine slate_dsyev_c
457 : :
458 : : ! Generalised complex Hermitian: A * Z = B * Z * diag(w)
459 : : subroutine slate_zhegv_c(n, nb, nprow, npcol, comm_f, &
460 : : lda, a_data, ldb, b_data, ldz, z_data, &
461 : : w, nev, use_gpu, info) &
462 : : bind(C, name="slate_zhegv_c")
463 : : use, intrinsic :: iso_c_binding
464 : : integer(c_int), value :: n, nb, nprow, npcol, comm_f
465 : : integer(c_int), value :: lda, ldb, ldz, nev, use_gpu
466 : : complex(c_double_complex), intent(inout) :: a_data(*), b_data(*)
467 : : complex(c_double_complex), intent(out) :: z_data(*)
468 : : real(c_double), intent(out) :: w(*)
469 : : integer(c_int), intent(out) :: info
470 : : end subroutine slate_zhegv_c
471 : :
472 : : ! Generalised real symmetric: A * Z = B * Z * diag(w)
473 : : subroutine slate_dsygv_c(n, nb, nprow, npcol, comm_f, &
474 : : lda, a_data, ldb, b_data, ldz, z_data, &
475 : : w, nev, use_gpu, info) &
476 : : bind(C, name="slate_dsygv_c")
477 : : use, intrinsic :: iso_c_binding
478 : : integer(c_int), value :: n, nb, nprow, npcol, comm_f
479 : : integer(c_int), value :: lda, ldb, ldz, nev, use_gpu
480 : : real(c_double), intent(inout) :: a_data(*), b_data(*)
481 : : real(c_double), intent(out) :: z_data(*)
482 : : real(c_double), intent(out) :: w(*)
483 : : integer(c_int), intent(out) :: info
484 : : end subroutine slate_dsygv_c
485 : :
486 : : end interface
487 : :
488 : : #endif
489 : :
490 : : contains !==============================================================================
491 : : !!***
492 : :
493 : : !!****f* m_slk/slk_grid_init
494 : : !! NAME
495 : : !! slk_grid_init
496 : : !!
497 : : !! FUNCTION
498 : : !! Set up the ScaLAPACK grid given the total number of processors.
499 : : !!
500 : : !! INPUTS
501 : : !! nprocs= total number of processors
502 : : !! comm= MPI communicator
503 : : !! [grid_dims]=Number of procs for each dimension.
504 : : !!
505 : : !! OUTPUT
506 : : !! grid= the grid of processors used by Scalapack
507 : : !!
508 : : !! SOURCE
509 : :
510 [ # # ]: 0 : subroutine slk_grid_init(grid, nprocs, comm, use_gpu, grid_dims)
511 : :
512 : : !Arguments ------------------------------------
513 : : class(slk_grid_t),intent(out) :: grid
514 : : integer,intent(in) :: nprocs,comm
515 : : logical,intent(in) :: use_gpu
516 : : integer,optional,intent(in) :: grid_dims(2)
517 : :
518 : : !Local variables-------------------------------
519 : : integer :: i
520 : : ! *********************************************************************
521 : :
522 : 0 : grid%nprocs = nprocs
523 : :
524 [ # # ]: 0 : if (.not. present(grid_dims)) then
525 : : ! Search for a rectangular grid of processors
526 : 0 : i=INT(SQRT(float(nprocs)))
527 [ # # ]: 0 : do while (MOD(nprocs,i) /= 0)
528 : 0 : i = i-1
529 : : end do
530 : 0 : i=max(i,1)
531 : :
532 : 0 : grid%dims(1) = i
533 : 0 : grid%dims(2) = INT(nprocs/i)
534 : :
535 : : else
536 [ # # ]: 0 : grid%dims = grid_dims
537 : : end if
538 : :
539 [ # # # # ]: 0 : ABI_CHECK(product(grid%dims) == nprocs, sjoin("grid%dims:", ltoa(grid%dims), "does not agree with nprocs:", itoa(nprocs)))
540 : :
541 : 0 : grid%comm = comm
542 : 0 : grid%use_gpu = use_gpu
543 : :
544 : : #ifdef HAVE_LINALG_SCALAPACK
545 : : ! 'R': Use row-major natural ordering
546 : : call BLACS_GRIDINIT(grid%comm, 'R', grid%dims(1), grid%dims(2))
547 : : #endif
548 : :
549 : 0 : end subroutine slk_grid_init
550 : : !!***
551 : :
552 : : !----------------------------------------------------------------------
553 : :
554 : : !!****f* m_slk/build_processor
555 : : !! NAME
556 : : !! build_processor
557 : : !!
558 : : !! FUNCTION
559 : : !! Builds a ScaLAPACK processor descriptor.
560 : : !! Build of the data related to one processor in a grid
561 : : !!
562 : : !! INPUTS
563 : : !! grid= array representing the grid of processors.
564 : : !! my_rank= selected processor
565 : : !! comm= MPI communicator
566 : : !!
567 : : !! OUTPUT
568 : : !! processor= descriptor of a processor
569 : : !!
570 : : !! SOURCE
571 : :
572 : 0 : subroutine build_processor(processor, grid, my_rank, comm)
573 : :
574 : : !Arguments ------------------------------------
575 : : class(slk_processor_t),intent(inout) :: processor
576 : : class(slk_grid_t),intent(in) :: grid
577 : : integer,intent(in) :: my_rank, comm
578 : : ! *********************************************************************
579 : :
580 : 0 : processor%grid = grid
581 : 0 : processor%my_rank = my_rank
582 : 0 : processor%comm = comm
583 : :
584 : : #ifdef HAVE_LINALG_SCALAPACK
585 : : call BLACS_GRIDINFO(grid%comm, processor%grid%dims(1), processor%grid%dims(2), &
586 : : processor%coords(1), processor%coords(2))
587 : : #endif
588 : :
589 : : ! These values are the same as those computed by BLACS_GRIDINFO
590 : : ! except in the case where the my_rank argument is not the local proc
591 : 0 : processor%coords(1) = INT((my_rank) / grid%dims(2))
592 : 0 : processor%coords(2) = MOD((my_rank), grid%dims(2))
593 : :
594 : : end subroutine build_processor
595 : : !!***
596 : :
597 : : !----------------------------------------------------------------------
598 : :
599 : : !!****f* m_slk/slk_processor_init
600 : : !! NAME
601 : : !! slk_processor_init
602 : : !!
603 : : !! FUNCTION
604 : : !! Initializes an instance of processor ScaLAPACK from an MPI communicator.
605 : : !!
606 : : !! INPUTS
607 : : !! comm= MPI communicator
608 : : !! [grid_dims]=Number of procs for each dimension.
609 : : !!
610 : : !! OUTPUT
611 : : !! processor= descriptor of a processor
612 : : !!
613 : : !! SOURCE
614 : :
615 : 0 : subroutine slk_processor_init(processor, comm, &
616 : : grid_dims) ! optional
617 : :
618 : : !Arguments ------------------------------------
619 : : class(slk_processor_t),intent(out) :: processor
620 : : integer, intent(in) :: comm
621 : : integer,optional,intent(in) :: grid_dims(2)
622 : :
623 : : !Local variables-------------------------------
624 : : type(slk_grid_t) :: grid
625 : : integer :: nprocs, my_rank
626 : : ! *********************************************************************
627 : :
628 : 0 : nprocs = xmpi_comm_size(comm)
629 : 0 : my_rank = xmpi_comm_rank(comm)
630 : :
631 [ # # ]: 0 : if (present(grid_dims)) then
632 : 0 : call grid%init(nprocs, comm, .false., grid_dims=grid_dims)
633 : : else
634 : 0 : call grid%init(nprocs, comm, .false.)
635 : : end if
636 : :
637 : 0 : call build_processor(processor, grid, my_rank, comm)
638 : :
639 [ # # # # ]: 0 : end subroutine slk_processor_init
640 : : !!***
641 : :
642 : : !----------------------------------------------------------------------
643 : :
644 : : !!****f* m_slk/slk_processor_free
645 : : !! NAME
646 : : !! slk_processor_free
647 : : !!
648 : : !! FUNCTION
649 : : !! Removes a processor from the ScaLAPACK grid.
650 : : !!
651 : : !! SOURCE
652 : :
653 : 0 : subroutine slk_processor_free(processor)
654 : :
655 : : !Arguments ------------------------------------
656 : : class(slk_processor_t),intent(inout) :: processor
657 : : ! *********************************************************************
658 : :
659 : : #ifdef HAVE_LINALG_SCALAPACK
660 : : if (processor%grid%comm /= xmpi_comm_null) then
661 : : call BLACS_GRIDEXIT(processor%grid%comm)
662 : : !call BLACS_EXIT(0)
663 : : end if
664 : : #endif
665 : :
666 : 0 : end subroutine slk_processor_free
667 : : !!***
668 : :
669 : : !----------------------------------------------------------------------
670 : :
671 : : !!****f* m_slk/basemat_init
672 : : !! NAME
673 : : !! basemat_init
674 : : !!
675 : : !! FUNCTION
676 : : !! Initialisation of a SCALAPACK matrix (each proc initializes its own part of the matrix)
677 : : !!
678 : : !! INPUTS
679 : : !! processor= descriptor of a processor
680 : : !! nbli_global= total number of lines
681 : : !! nbco_global= total number of columns
682 : : !! istwf_k= 2 if we have a real matrix else complex.
683 : : !! [size_blocs]= custom block sizes. Use -1 to use global size along that direction.
684 : : !! Useful to distribute only rows or columns. Obviously, [-1, -1] is not allowed.
685 : : !!
686 : : !! OUTPUT
687 : : !! matrix= the matrix to process
688 : : !!
689 : : !! SOURCE
690 : :
691 : 0 : subroutine basemat_init(matrix, nbli_global, nbco_global, processor, istwf_k, &
692 : : size_blocs, gpu_action) ! optional
693 : :
694 : : !Arguments ------------------------------------
695 : : class(basemat_t),intent(inout) :: matrix
696 : : integer,intent(in) :: nbli_global, nbco_global, istwf_k
697 : : type(slk_processor_t),target,intent(in) :: processor
698 : : integer,optional,intent(in) :: size_blocs(2)
699 : : character(len=*),optional,intent(in) :: gpu_action
700 : :
701 : : #ifdef HAVE_LINALG_SCALAPACK
702 : : !Local variables-------------------------------
703 : : #ifdef HAVE_LINALG_ELPA
704 : : integer, parameter :: DEFAULT_SIZE_BLOCS = 1
705 : : #else
706 : : ! As recommended by Intel MKL, a more sensible default than the previous value of 40
707 : : integer, parameter :: DEFAULT_SIZE_BLOCS = 24
708 : : #endif
709 : : ! As recommended in ELPA, which advises distributions as squared as possible using powers of 2
710 : : integer, parameter :: DEFAULT_SIZE_BLOCS_GPU = 16
711 : : integer :: info,sizeb
712 : : !character(len=500) :: msg
713 : : ! *********************************************************************
714 : :
715 : : call matrix%free()
716 : :
717 : : sizeb = DEFAULT_SIZE_BLOCS
718 : : if (processor%grid%use_gpu) sizeb = DEFAULT_SIZE_BLOCS_GPU
719 : :
720 : : !Records of the matrix type
721 : : matrix%processor => processor
722 : : matrix%size_blocs(1) = MIN(sizeb, nbli_global)
723 : : matrix%size_blocs(2) = MIN(sizeb, nbco_global)
724 : :
725 : : #if defined(HAVE_LINALG_ELPA) || defined(HAVE_LINALG_SLATE)
726 : : if(matrix%size_blocs(1) .ne. matrix%size_blocs(2)) then
727 : : matrix%size_blocs(1) = MIN(matrix%size_blocs(1), matrix%size_blocs(2))
728 : : matrix%size_blocs(2) = matrix%size_blocs(1)
729 : : end if
730 : : #endif
731 : :
732 : : ! Use custom block sizes.
733 : : if (present(size_blocs)) then
734 : : ABI_CHECK(.not. all(size_blocs == -1), "size_blocs [-1, -1] is not allowed")
735 : : if (size_blocs(1) == -1) then
736 : : matrix%size_blocs(1) = nbli_global
737 : : else
738 : : matrix%size_blocs(1) = MIN(size_blocs(1), nbli_global)
739 : : end if
740 : : if (size_blocs(2) == -1) then
741 : : matrix%size_blocs(2) = nbco_global
742 : : else
743 : : matrix%size_blocs(2) = MIN(size_blocs(2), nbco_global)
744 : : end if
745 : : end if
746 : :
747 : : matrix%size_global(1) = nbli_global
748 : : matrix%size_global(2) = nbco_global
749 : : !write(std_out, *)"matrix%size_global", matrix%size_global
750 : :
751 : : ! Size of the local buffer
752 : : ! NUMROC computes the NUMber of Rows Or Columns of a distributed matrix owned by the process indicated by IPROC.
753 : : ! NUMROC (n, nb, iproc, isrcproc, nprocs)
754 : : matrix%size_local(1) = NUMROC(nbli_global, matrix%size_blocs(1), &
755 : : processor%coords(1), 0, processor%grid%dims(1))
756 : :
757 : : matrix%size_local(2) = NUMROC(nbco_global,matrix%size_blocs(2), &
758 : : processor%coords(2), 0, processor%grid%dims(2))
759 : :
760 : : matrix%bufsize = int(matrix%size_local(1), c_size_t) * int(matrix%size_local(2), c_size_t)
761 : :
762 : : call matrix%idx_loc(matrix%size_global(1), matrix%size_global(2), &
763 : : matrix%size_local(1), matrix%size_local(2))
764 : :
765 : : ! Initialisation of the SCALAPACK description of the matrix
766 : : ! (desc, m, n, mb, nb, irsrc, icsrc, comm, lld, info)
767 : : call DESCINIT(matrix%desc, nbli_global, nbco_global, &
768 : : matrix%size_blocs(1), matrix%size_blocs(2), 0, 0, &
769 : : processor%grid%comm, MAX(1, matrix%size_local(1)), info)
770 : :
771 : : if (info /= 0) then
772 : : ABI_ERROR(sjoin("Error while initializing scalapack matrix. info:", itoa(info)))
773 : : end if
774 : :
775 : : ! Allocate local buffer.
776 : : matrix%istwf_k = istwf_k
777 : : select type (matrix)
778 : : class is (slkmat_dp_t)
779 : : if (istwf_k /= 2) then
780 : : ABI_MALLOC(matrix%buffer_cplx, (matrix%size_local(1), matrix%size_local(2)))
781 : : matrix%buffer_cplx = czero
782 : : else
783 : : ABI_MALLOC(matrix%buffer_real, (matrix%size_local(1), matrix%size_local(2)))
784 : : matrix%buffer_real = zero
785 : : end if
786 : :
787 : : class is (slkmat_sp_t)
788 : : if (istwf_k /= 2) then
789 : : ABI_MALLOC(matrix%buffer_cplx, (matrix%size_local(1), matrix%size_local(2)))
790 : : matrix%buffer_cplx = czero_sp
791 : : else
792 : : ABI_MALLOC(matrix%buffer_real, (matrix%size_local(1), matrix%size_local(2)))
793 : : matrix%buffer_real = zero_sp
794 : : end if
795 : :
796 : : class default
797 : : ABI_ERROR("Wrong class")
798 : : end select
799 : :
800 : : if (present(gpu_action)) call matrix%gpu_map(gpu_action)
801 : : #endif
802 : :
803 : 0 : end subroutine basemat_init
804 : : !!***
805 : :
806 : : !----------------------------------------------------------------------
807 : :
808 : : !!****f* m_slk/basemat_locmem_mb
809 : : !! NAME
810 : : !! basemat_locmem_mb
811 : : !!
812 : : !! FUNCTION
813 : : !! Returns memory allocated for the local buffer in Mb.
814 : : !!
815 : : !! SOURCE
816 : :
817 : 0 : pure real(dp) function basemat_locmem_mb(mat) result(locmem_mb)
818 : :
819 : : !Arguments ------------------------------------
820 : : class(basemat_t),intent(in) :: mat
821 : : ! *********************************************************************
822 : :
823 : 0 : locmem_mb = zero
824 : : select type (mat)
825 : : class is (slkmat_dp_t)
826 [ # # # # ]: 0 : if (allocated(mat%buffer_real)) locmem_mb = product(int(shape(mat%buffer_real))) * dp
827 [ # # # # ]: 0 : if (allocated(mat%buffer_cplx)) locmem_mb = product(int(shape(mat%buffer_cplx))) * two * dp
828 : : class is (slkmat_sp_t)
829 [ # # # # ]: 0 : if (allocated(mat%buffer_real)) locmem_mb = product(int(shape(mat%buffer_real))) * sp
830 [ # # # # ]: 0 : if (allocated(mat%buffer_cplx)) locmem_mb = product(int(shape(mat%buffer_cplx))) * two * sp
831 : : end select
832 : 0 : locmem_mb = locmem_mb * b2Mb
833 : :
834 : 0 : end function basemat_locmem_mb
835 : : !!***
836 : :
837 : : !----------------------------------------------------------------------
838 : :
839 : : !!****f* m_slk/basemat_print
840 : : !! NAME
841 : : !! basemat_print
842 : : !!
843 : : !! FUNCTION
844 : : !! Print info on scalapack matrix.
845 : : !!
846 : : !! INPUTS
847 : : !! [unit]=Unit number (default: std_out)
848 : : !! [header]=title for info
849 : : !! [prtvol]=Verbosity level (default: 0)
850 : : !!
851 : : !! SOURCE
852 : :
853 : 0 : subroutine basemat_print(mat, header, unit, prtvol)
854 : :
855 : : !Arguments ------------------------------------
856 : : class(basemat_t),intent(in) :: mat
857 : : character(len=*),optional,intent(in) :: header
858 : : integer,optional,intent(in) :: prtvol, unit
859 : :
860 : : !Local variables-------------------------------
861 : : integer :: unt, my_prtvol, grid_dims(2)
862 : : character(len=50) :: matrix_dtype
863 : : character(len=5000) :: msg
864 : : ! *********************************************************************
865 : :
866 : 0 : unt = std_out; if (present(unit)) unt =unit
867 : 0 : my_prtvol = 0; if (present(prtvol)) my_prtvol = prtvol
868 : :
869 : 0 : msg = ' ==== Info on scalapack matrix ==== '
870 [ # # # # : 0 : if (present(header)) msg=' ==== '//trim(adjustl(header))//' ==== '
# # ]
871 : 0 : call wrtout(unt, msg)
872 : :
873 : 0 : matrix_dtype = "undefined"
874 : : select type (mat)
875 : : class is (slkmat_dp_t)
876 [ # # ]: 0 : if (allocated(mat%buffer_real)) matrix_dtype = "real dp"
877 [ # # ]: 0 : if (allocated(mat%buffer_cplx)) matrix_dtype = "complex dp"
878 : :
879 : : class is (slkmat_sp_t)
880 [ # # ]: 0 : if (allocated(mat%buffer_real)) matrix_dtype = "real sp"
881 [ # # ]: 0 : if (allocated(mat%buffer_cplx)) matrix_dtype = "complex sp"
882 : :
883 : : class default
884 : 0 : ABI_ERROR("Wrong class")
885 : : end select
886 : :
887 : 0 : grid_dims = [-1, -1]
888 [ # # # # ]: 0 : if (associated(mat%processor)) grid_dims = mat%processor%grid%dims
889 : :
890 : : write(msg,'(5(3a),a,f8.1,a)') &
891 : 0 : " matrix_dtype ..... ", trim(matrix_dtype), ch10, &
892 [ # # ]: 0 : " size_global ...... ", trim(ltoa(mat%size_global)), ch10, &
893 [ # # ]: 0 : " size_local ...... ", trim(ltoa(mat%size_local)), ch10, &
894 [ # # ]: 0 : " size_blocs ...... ", trim(ltoa(mat%size_blocs)), ch10, &
895 [ # # ]: 0 : " processor grid ... ", trim(ltoa(grid_dims)), ch10, &
896 : 0 : " memory (Mb) ...... ", mat%locmem_mb(), ch10
897 : 0 : call wrtout(unt, msg)
898 : :
899 : : !if (prtvol > 10) call mat%write(unit)
900 : :
901 [ # # ]: 0 : end subroutine basemat_print
902 : : !!***
903 : :
904 : : !----------------------------------------------------------------------
905 : :
906 : : !!****f* m_slk/slkmat_check_shape
907 : : !! NAME
908 : : !! slkmat_check_shape
909 : : !!
910 : : !! FUNCTION
911 : : !! Debugging tool to test the local shape `lshape` of the local buffer.
912 : : !! Return exit status in `ok` and error message in `msg`.
913 : : !!
914 : : !! SOURCE
915 : :
916 : 0 : logical function basemat_check_local_shape(mat, lshape, msg) result (ok)
917 : :
918 : : !Arguments ------------------------------------
919 : : class(basemat_t),intent(in) :: mat
920 : : integer,intent(in) :: lshape(2)
921 : : character(len=*),intent(out) :: msg
922 : : ! *********************************************************************
923 : :
924 : 0 : msg = ""
925 [ # # # # ]: 0 : ok = all(mat%size_local == lshape)
926 [ # # ]: 0 : if (.not. ok) then
927 [ # # # # ]: 0 : msg = sjoin("mat%size_local:", ltoa(mat%size_local), " not equal to input local lshape ", ltoa(lshape))
928 : 0 : return
929 : : end if
930 : :
931 : : select type (mat)
932 : : class is (slkmat_dp_t)
933 [ # # ]: 0 : if (allocated(mat%buffer_cplx)) then
934 [ # # # # ]: 0 : ok = all(shape(mat%buffer_cplx) == lshape)
935 [ # # ]: 0 : if (.not. ok) then
936 [ # # # # : 0 : msg = sjoin("shape(buffer_cplx):", ltoa(shape(mat%buffer_cplx)), " != input local lshape ", ltoa(lshape)); return
# # ]
937 : : end if
938 [ # # ]: 0 : else if (allocated(mat%buffer_real)) then
939 [ # # # # ]: 0 : ok = all(shape(mat%buffer_real) == lshape)
940 [ # # ]: 0 : if (.not. ok) then
941 [ # # # # : 0 : msg = sjoin("shape(buffer_real):", ltoa(shape(mat%buffer_real)), " != input local lshape ", ltoa(lshape)); return
# # ]
942 : : end if
943 : : end if
944 : :
945 : : class is (slkmat_sp_t)
946 : : ! Same piece of code as above. May use include file!
947 [ # # ]: 0 : if (allocated(mat%buffer_cplx)) then
948 [ # # # # ]: 0 : ok = all(shape(mat%buffer_cplx) == lshape)
949 [ # # ]: 0 : if (.not. ok) then
950 [ # # # # : 0 : msg = sjoin("shape(buffer_cplx):", ltoa(shape(mat%buffer_cplx)), " != input local lshape ", ltoa(lshape)); return
# # ]
951 : : end if
952 [ # # ]: 0 : else if (allocated(mat%buffer_real)) then
953 [ # # # # ]: 0 : ok = all(shape(mat%buffer_real) == lshape)
954 [ # # ]: 0 : if (.not. ok) then
955 [ # # # # : 0 : msg = sjoin("shape(buffer_real):", ltoa(shape(mat%buffer_real)), " != input local lshape ", ltoa(lshape)); return
# # ]
956 : : end if
957 : : end if
958 : :
959 : : class default
960 : 0 : ABI_ERROR("Wrong class")
961 : : end select
962 : :
963 [ # # ]: 0 : end function basemat_check_local_shape
964 : : !!***
965 : :
966 : : !----------------------------------------------------------------------
967 : :
968 : : !!****f* m_slk/slkmat_dp_get_head_and_wings
969 : : !! NAME
970 : : !! slkmat_dp_get_head_and_wings
971 : : !!
972 : : !! FUNCTION
973 : : !! Return global arrays with head and wings of the matrix.
974 : : !! If call_mpi if False, global MPI sum is postponed.
975 : : !! Useful to reduce the number of MPI calls if one has to operate on multiple matrices.
976 : : !!
977 : : !! SOURCE
978 : :
979 : 0 : subroutine slkmat_dp_get_head_and_wings(mat, head, low_wing, up_wing, call_mpi)
980 : :
981 : : !Arguments ------------------------------------
982 : : class(slkmat_dp_t),intent(in) :: mat
983 : : complex(dp),intent(out) :: head, low_wing(mat%size_global(1)), up_wing(mat%size_global(2))
984 : : logical,intent(in) :: call_mpi
985 : :
986 : : !Local variables-------------------------------
987 : : integer :: ierr, il_g1, il_g2, iglob1, iglob2
988 : : logical :: is_cplx
989 : : ! *********************************************************************
990 : :
991 [ # # # # ]: 0 : head = zero; low_wing = zero; up_wing = zero
992 : :
993 : 0 : is_cplx = allocated(mat%buffer_cplx)
994 : :
995 [ # # ]: 0 : do il_g2=1,mat%size_local(2)
996 : 0 : iglob2 = mat%loc2gcol(il_g2)
997 [ # # ]: 0 : do il_g1=1,mat%size_local(1)
998 : 0 : iglob1 = mat%loc2grow(il_g1)
999 : :
1000 [ # # ]: 0 : if (iglob1 == 1 .or. iglob2 == 1) then
1001 [ # # ]: 0 : if (iglob1 == 1 .and. iglob2 == 1) then
1002 [ # # ]: 0 : if (is_cplx) then
1003 : 0 : head = mat%buffer_cplx(il_g1, il_g2)
1004 : : else
1005 : 0 : head = mat%buffer_real(il_g1, il_g2)
1006 : : end if
1007 [ # # ]: 0 : else if (iglob1 == 1) then
1008 [ # # ]: 0 : if (is_cplx) then
1009 : 0 : up_wing(iglob2) = mat%buffer_cplx(il_g1, il_g2)
1010 : : else
1011 : 0 : up_wing(iglob2) = mat%buffer_real(il_g1, il_g2)
1012 : : end if
1013 [ # # ]: 0 : else if (iglob2 == 1) then
1014 [ # # ]: 0 : if (is_cplx) then
1015 : 0 : low_wing(iglob1) = mat%buffer_cplx(il_g1, il_g2)
1016 : : else
1017 : 0 : low_wing(iglob1) = mat%buffer_real(il_g1, il_g2)
1018 : : end if
1019 : : end if
1020 : : end if
1021 : :
1022 : : end do
1023 : : end do
1024 : :
1025 [ # # ]: 0 : if (call_mpi) then
1026 : 0 : call xmpi_sum(head, mat%processor%comm, ierr)
1027 : 0 : call xmpi_sum(low_wing, mat%processor%comm, ierr)
1028 : 0 : call xmpi_sum(up_wing, mat%processor%comm, ierr)
1029 : : end if
1030 : :
1031 : 0 : end subroutine slkmat_dp_get_head_and_wings
1032 : : !!***
1033 : :
1034 : : !----------------------------------------------------------------------
1035 : :
1036 : : !!****f* m_slk/slkmat_dp_set_head_and_wings
1037 : : !! NAME
1038 : : !! slkmat_dp_set_head_and_wings
1039 : : !!
1040 : : !! FUNCTION
1041 : : !! Set head and wings of the matrix starting from global arrays.
1042 : : !!
1043 : : !! SOURCE
1044 : :
1045 : 0 : subroutine slkmat_dp_set_head_and_wings(mat, head, low_wing, up_wing)
1046 : :
1047 : : !Arguments ------------------------------------
1048 : : class(slkmat_dp_t),intent(inout) :: mat
1049 : : complex(dp),intent(in) :: head, low_wing(mat%size_global(1)), up_wing(mat%size_global(2))
1050 : :
1051 : : !Local variables-------------------------------
1052 : : integer :: il_g1, il_g2, iglob1, iglob2
1053 : : logical :: is_cplx
1054 : : ! *********************************************************************
1055 : :
1056 : 0 : is_cplx = allocated(mat%buffer_cplx)
1057 : :
1058 [ # # ]: 0 : do il_g2=1,mat%size_local(2)
1059 : 0 : iglob2 = mat%loc2gcol(il_g2)
1060 [ # # ]: 0 : do il_g1=1,mat%size_local(1)
1061 : 0 : iglob1 = mat%loc2grow(il_g1)
1062 : :
1063 [ # # ]: 0 : if (iglob1 == 1 .or. iglob2 == 1) then
1064 [ # # ]: 0 : if (iglob1 == 1 .and. iglob2 == 1) then
1065 [ # # ]: 0 : if (is_cplx) then
1066 : 0 : mat%buffer_cplx(il_g1, il_g2) = head
1067 : : else
1068 : 0 : mat%buffer_real(il_g1, il_g2) = real(head)
1069 : : end if
1070 [ # # ]: 0 : else if (iglob1 == 1) then
1071 [ # # ]: 0 : if (is_cplx) then
1072 : 0 : mat%buffer_cplx(il_g1, il_g2) = up_wing(iglob2)
1073 : : else
1074 : 0 : mat%buffer_real(il_g1, il_g2) = real(up_wing(iglob2))
1075 : : end if
1076 [ # # ]: 0 : else if (iglob2 == 1) then
1077 [ # # ]: 0 : if (is_cplx) then
1078 : 0 : mat%buffer_cplx(il_g1, il_g2) = low_wing(iglob1)
1079 : : else
1080 : 0 : mat%buffer_real(il_g1, il_g2) = real(low_wing(iglob1))
1081 : : end if
1082 : : end if
1083 : : end if
1084 : :
1085 : : end do
1086 : : end do
1087 : :
1088 : 0 : end subroutine slkmat_dp_set_head_and_wings
1089 : : !!***
1090 : :
1091 : : !----------------------------------------------------------------------
1092 : :
1093 : : !!****f* m_slk/slkmat_sp_set_head_and_wings
1094 : : !! NAME
1095 : : !! slkmat_sp_set_head_and_wings
1096 : : !!
1097 : : !! FUNCTION
1098 : : !! Set head and the wings of the matrix starting from global arrays.
1099 : : !!
1100 : : !! SOURCE
1101 : :
1102 : 0 : subroutine slkmat_sp_set_head_and_wings(mat, head, low_wing, up_wing)
1103 : :
1104 : : !Arguments ------------------------------------
1105 : : class(slkmat_sp_t),intent(inout) :: mat
1106 : : complex(sp),intent(in) :: head, low_wing(mat%size_global(1)), up_wing(mat%size_global(2))
1107 : :
1108 : : !Local variables-------------------------------
1109 : : integer :: il_g1, il_g2, iglob1, iglob2
1110 : : logical :: is_cplx
1111 : : ! *********************************************************************
1112 : :
1113 : 0 : is_cplx = allocated(mat%buffer_cplx)
1114 : :
1115 [ # # ]: 0 : do il_g2=1,mat%size_local(2)
1116 : 0 : iglob2 = mat%loc2gcol(il_g2)
1117 [ # # ]: 0 : do il_g1=1,mat%size_local(1)
1118 : 0 : iglob1 = mat%loc2grow(il_g1)
1119 : :
1120 [ # # ]: 0 : if (iglob1 == 1 .or. iglob2 == 1) then
1121 [ # # ]: 0 : if (iglob1 == 1 .and. iglob2 == 1) then
1122 [ # # ]: 0 : if (is_cplx) then
1123 : 0 : mat%buffer_cplx(il_g1, il_g2) = head
1124 : : else
1125 : 0 : mat%buffer_real(il_g1, il_g2) = real(head)
1126 : : end if
1127 [ # # ]: 0 : else if (iglob1 == 1) then
1128 [ # # ]: 0 : if (is_cplx) then
1129 : 0 : mat%buffer_cplx(il_g1, il_g2) = up_wing(iglob2)
1130 : : else
1131 : 0 : mat%buffer_real(il_g1, il_g2) = real(up_wing(iglob2))
1132 : : end if
1133 [ # # ]: 0 : else if (iglob2 == 1) then
1134 [ # # ]: 0 : if (is_cplx) then
1135 : 0 : mat%buffer_cplx(il_g1, il_g2) = low_wing(iglob1)
1136 : : else
1137 : 0 : mat%buffer_real(il_g1, il_g2) = real(low_wing(iglob1))
1138 : : end if
1139 : : end if
1140 : : end if
1141 : :
1142 : : end do
1143 : : end do
1144 : :
1145 : 0 : end subroutine slkmat_sp_set_head_and_wings
1146 : : !!***
1147 : :
1148 : : !----------------------------------------------------------------------
1149 : :
1150 : : !!****f* m_slk/slkmat_dp_copy
1151 : : !! NAME
1152 : : !! slkmat_dp_copy
1153 : : !!
1154 : : !! FUNCTION
1155 : : !! Copy in_mat to out_mat. If empty is True, the values in the local buffer are not copied. Default: False
1156 : : !!
1157 : : !! SOURCE
1158 : :
1159 [ # # ]: 0 : subroutine slkmat_dp_copy(in_mat, out_mat, empty)
1160 : :
1161 : : !Arguments ------------------------------------
1162 : : class(slkmat_dp_t),intent(in) :: in_mat
1163 : : class(slkmat_dp_t),intent(out) :: out_mat
1164 : : logical,optional,intent(in) :: empty
1165 : :
1166 : : !Local variables-------------------------------
1167 : : logical :: empty__
1168 : : type(c_ptr) :: gpu_ptr
1169 : : ! *********************************************************************
1170 : :
1171 : : call out_mat%init(in_mat%size_global(1), in_mat%size_global(2), in_mat%processor, in_mat%istwf_k, &
1172 : 0 : size_blocs=in_mat%size_blocs)
1173 : :
1174 [ # # ]: 0 : empty__ = .False.; if (present(empty)) empty__ = empty
1175 [ # # ]: 0 : if (.not. empty__) then
1176 [ # # ]: 0 : if (in_mat%istwf_k == 1) then
1177 [ # # # # : 0 : out_mat%buffer_cplx = in_mat%buffer_cplx
# # # # #
# # # # #
# # # # #
# ]
1178 : : else
1179 [ # # # # : 0 : out_mat%buffer_real = in_mat%buffer_real
# # # # #
# # # # #
# # # # #
# ]
1180 : : end if
1181 : : end if
1182 : :
1183 [ # # ]: 0 : if (in_mat%is_gpu_mapped(gpu_ptr)) then
1184 : 0 : call out_mat%gpu_map("alloc")
1185 [ # # ]: 0 : if (in_mat%istwf_k == 1) then
1186 : 0 : call gpu_copy_complex(out_mat%buffer_cplx, in_mat%buffer_cplx, in_mat%bufsize)
1187 : : else
1188 : 0 : call gpu_copy(out_mat%buffer_real, in_mat%buffer_real, in_mat%bufsize)
1189 : : end if
1190 : : end if
1191 : :
1192 : 0 : end subroutine slkmat_dp_copy
1193 : : !!***
1194 : :
1195 : : !----------------------------------------------------------------------
1196 : :
1197 : : !!****f* m_slk/slkmat_sp_copy
1198 : : !! NAME
1199 : : !! slkmat_sp_copy
1200 : : !!
1201 : : !! FUNCTION
1202 : : !! Copy in_mat to out_mat. If empty is True, the values in the local buffer are not copied. Default: False
1203 : : !!
1204 : : !! SOURCE
1205 : :
1206 [ # # ]: 0 : subroutine slkmat_sp_copy(in_mat, out_mat, empty)
1207 : :
1208 : : !Arguments ------------------------------------
1209 : : class(slkmat_sp_t),intent(in) :: in_mat
1210 : : class(slkmat_sp_t),intent(out) :: out_mat
1211 : : logical,optional,intent(in) :: empty
1212 : :
1213 : : !Local variables-------------------------------
1214 : : logical :: empty__
1215 : : type(c_ptr) :: gpu_ptr
1216 : : ! *********************************************************************
1217 : :
1218 : : call out_mat%init(in_mat%size_global(1), in_mat%size_global(2), in_mat%processor, in_mat%istwf_k, &
1219 : 0 : size_blocs=in_mat%size_blocs)
1220 : :
1221 [ # # ]: 0 : empty__ = .False.; if (present(empty)) empty__ = empty
1222 [ # # ]: 0 : if (.not. empty__) then
1223 [ # # ]: 0 : if (in_mat%istwf_k == 1) then
1224 [ # # # # : 0 : out_mat%buffer_cplx = in_mat%buffer_cplx
# # # # #
# # # # #
# # # # #
# ]
1225 : : else
1226 [ # # # # : 0 : out_mat%buffer_real = in_mat%buffer_real
# # # # #
# # # # #
# # # # #
# ]
1227 : : end if
1228 : : end if
1229 : :
1230 [ # # ]: 0 : if (in_mat%is_gpu_mapped(gpu_ptr)) then
1231 : 0 : call out_mat%gpu_map("alloc")
1232 [ # # ]: 0 : if (in_mat%istwf_k == 1) then
1233 : 0 : call gpu_copy_complex_sp(out_mat%buffer_cplx, in_mat%buffer_cplx, in_mat%bufsize)
1234 : : else
1235 : 0 : call gpu_copy_sp(out_mat%buffer_real, in_mat%buffer_real, in_mat%bufsize)
1236 : : end if
1237 : : end if
1238 : :
1239 : 0 : end subroutine slkmat_sp_copy
1240 : : !!***
1241 : :
1242 : : !----------------------------------------------------------------------
1243 : :
1244 : : !!****f* m_slk/basemat_free
1245 : : !! NAME
1246 : : !! basemat_free
1247 : : !!
1248 : : !! FUNCTION
1249 : : !! Free dynamic memory
1250 : : !!
1251 : : !! SOURCE
1252 : :
1253 : 0 : subroutine basemat_free(mat)
1254 : :
1255 : : !Arguments ------------------------------------
1256 : : class(basemat_t),intent(inout) :: mat
1257 : :
1258 : : !Local variables-------------------------------
1259 : : type(c_ptr) :: gpu_ptr
1260 : : ! *********************************************************************
1261 : :
1262 : : ! Don't free the grid. Just nullify the pointer as there might be other objects keeping a ref to processor.
1263 : 0 : mat%processor => null()
1264 : :
1265 [ # # ]: 0 : mat%size_global = 0
1266 [ # # ]: 0 : mat%size_blocs = 0
1267 [ # # ]: 0 : mat%size_local = 0
1268 [ # # ]: 0 : mat%desc = 0
1269 : :
1270 [ # # ]: 0 : if (mat%is_gpu_mapped(gpu_ptr)) then
1271 : 0 : call wrtout(std_out, "Deallocating mat%buffer on the GPU")
1272 : 0 : call mat%gpu_map("delete")
1273 : : end if
1274 : :
1275 : : select type (mat)
1276 : : class is (slkmat_dp_t)
1277 [ # # ]: 0 : ABI_SFREE(mat%buffer_cplx)
1278 [ # # ]: 0 : ABI_SFREE(mat%buffer_real)
1279 : :
1280 : : class is (slkmat_sp_t)
1281 [ # # ]: 0 : ABI_SFREE(mat%buffer_cplx)
1282 [ # # ]: 0 : ABI_SFREE(mat%buffer_real)
1283 : :
1284 : : class default
1285 : 0 : ABI_ERROR("Wrong class")
1286 : : end select
1287 : :
1288 : 0 : end subroutine basemat_free
1289 : : !!***
1290 : :
1291 : : !----------------------------------------------------------------------
1292 : :
1293 : : !!****f* m_slk/slk_array1_free
1294 : : !! NAME
1295 : : !! slk_array1_free
1296 : : !!
1297 : : !! FUNCTION
1298 : : !! Deallocate 1d array of slkmat_dp_t elements
1299 : : !!
1300 : : !! SOURCE
1301 : :
1302 : 0 : subroutine slk_array1_free(slk_arr1)
1303 : : class(basemat_t),intent(inout) :: slk_arr1(:)
1304 : : integer :: i1
1305 [ # # ]: 0 : do i1=1,size(slk_arr1, dim=1)
1306 : 0 : call slk_arr1(i1)%free()
1307 : : end do
1308 : 0 : end subroutine slk_array1_free
1309 : : !!***
1310 : :
1311 : : !----------------------------------------------------------------------
1312 : :
1313 : : !!****f* m_slk/slk_array2_free
1314 : : !! NAME
1315 : : !! slk_array2_free
1316 : : !!
1317 : : !! FUNCTION
1318 : : !! Deallocate 2d array of slkmat_dp_t elements
1319 : : !!
1320 : : !! SOURCE
1321 : :
1322 : 0 : subroutine slk_array2_free(slk_arr2)
1323 : : class(basemat_t),intent(inout) :: slk_arr2(:,:)
1324 : : integer :: i1, i2
1325 [ # # ]: 0 : do i2=1,size(slk_arr2, dim=2)
1326 [ # # ]: 0 : do i1=1,size(slk_arr2, dim=1)
1327 : 0 : call slk_arr2(i1, i2)%free()
1328 : : end do
1329 : : end do
1330 : 0 : end subroutine slk_array2_free
1331 : : !!***
1332 : :
1333 : : !----------------------------------------------------------------------
1334 : :
1335 : : !!****f* m_slk/slk_array3_free
1336 : : !! NAME
1337 : : !! slk_array3_free
1338 : : !!
1339 : : !! FUNCTION
1340 : : !! Deallocate 3d array of slkmat_dp_t elements
1341 : : !!
1342 : : !! SOURCE
1343 : :
1344 : 0 : subroutine slk_array3_free(slk_arr3)
1345 : : class(basemat_t),intent(inout) :: slk_arr3(:,:,:)
1346 : : integer :: i1, i2, i3
1347 [ # # ]: 0 : do i3=1,size(slk_arr3, dim=3)
1348 [ # # ]: 0 : do i2=1,size(slk_arr3, dim=2)
1349 [ # # ]: 0 : do i1=1,size(slk_arr3, dim=1)
1350 : 0 : call slk_arr3(i1, i2, i3)%free()
1351 : : end do
1352 : : end do
1353 : : end do
1354 : 0 : end subroutine slk_array3_free
1355 : : !!***
1356 : :
1357 : : !----------------------------------------------------------------------
1358 : :
1359 : : !!****f* m_slk/slk_array4_free
1360 : : !! NAME
1361 : : !! slk_array4_free
1362 : : !!
1363 : : !! FUNCTION
1364 : : !! Deallocate 4d array of slkmat_dp_t elements
1365 : : !!
1366 : : !! SOURCE
1367 : :
1368 : 0 : subroutine slk_array4_free(slk_arr4)
1369 : : class(basemat_t),intent(inout) :: slk_arr4(:,:,:,:)
1370 : : integer :: i1, i2, i3, i4
1371 [ # # ]: 0 : do i4=1,size(slk_arr4, dim=4)
1372 [ # # ]: 0 : do i3=1,size(slk_arr4, dim=3)
1373 [ # # ]: 0 : do i2=1,size(slk_arr4, dim=2)
1374 [ # # ]: 0 : do i1=1,size(slk_arr4, dim=1)
1375 : 0 : call slk_arr4(i1, i2, i3, i4)%free()
1376 : : end do
1377 : : end do
1378 : : end do
1379 : : end do
1380 : 0 : end subroutine slk_array4_free
1381 : : !!***
1382 : :
1383 : : !----------------------------------------------------------------------
1384 : :
1385 : : !!****f* m_slk/slk_array5_free
1386 : : !! NAME
1387 : : !! slk_array5_free
1388 : : !!
1389 : : !! FUNCTION
1390 : : !! Deallocate 5d array of slkmat_dp_t elements
1391 : : !!
1392 : : !! SOURCE
1393 : :
1394 : 0 : subroutine slk_array5_free(slk_arr5)
1395 : : class(basemat_t),intent(inout) :: slk_arr5(:,:,:,:,:)
1396 : : integer :: i1, i2, i3, i4, i5
1397 [ # # ]: 0 : do i5=1,size(slk_arr5, dim=5)
1398 [ # # ]: 0 : do i4=1,size(slk_arr5, dim=4)
1399 [ # # ]: 0 : do i3=1,size(slk_arr5, dim=3)
1400 [ # # ]: 0 : do i2=1,size(slk_arr5, dim=2)
1401 [ # # ]: 0 : do i1=1,size(slk_arr5, dim=1)
1402 : 0 : call slk_arr5(i1, i2, i3, i4, i5)%free()
1403 : : end do
1404 : : end do
1405 : : end do
1406 : : end do
1407 : : end do
1408 : 0 : end subroutine slk_array5_free
1409 : : !!***
1410 : :
1411 : : !----------------------------------------------------------------------
1412 : :
1413 : : !!****f* m_slk/slk_array_set_zero
1414 : : !! NAME
1415 : : !! slk_array_set_zero
1416 : : !!
1417 : : !! FUNCTION
1418 : : !! Elemental routine to set the value of the PBLAS buffer to zero
1419 : : !!
1420 : : !! SOURCE
1421 : :
1422 : 0 : elemental subroutine slk_array_set_zero(mat)
1423 : :
1424 : : !Arguments ------------------------------------
1425 : : class(basemat_t),intent(inout) :: mat
1426 : :
1427 : : select type (mat)
1428 : : class is (slkmat_dp_t)
1429 [ # # # # : 0 : if (allocated(mat%buffer_cplx)) mat%buffer_cplx = zero
# # ]
1430 [ # # # # : 0 : if (allocated(mat%buffer_real)) mat%buffer_real = zero
# # ]
1431 : : class is (slkmat_sp_t)
1432 [ # # # # : 0 : if (allocated(mat%buffer_cplx)) mat%buffer_cplx = cmplx(zero, kind=sp)
# # ]
1433 [ # # # # : 0 : if (allocated(mat%buffer_real)) mat%buffer_real = real(zero, kind=sp)
# # ]
1434 : : end select
1435 : :
1436 : 0 : end subroutine slk_array_set_zero
1437 : : !!***
1438 : :
1439 : : !----------------------------------------------------------------------
1440 : :
1441 : : !!****f* m_slk/basemat_gpu_set_zero
1442 : : !! NAME
1443 : : !! basemat_gpu_set_zero
1444 : : !!
1445 : : !! FUNCTION
1446 : : !! Elemental routine to set the value of the PBLAS buffer to zero
1447 : : !!
1448 : : !! SOURCE
1449 : :
1450 : 0 : subroutine basemat_gpu_set_zero(mat)
1451 : :
1452 : : !Arguments ------------------------------------
1453 : : class(basemat_t),target,intent(inout) :: mat
1454 : :
1455 : : #ifdef HAVE_OPENMP_OFFLOAD
1456 : : !Local variables-------------------------------
1457 : : type(c_ptr) :: gpu_ptr
1458 : : ! *********************************************************************
1459 : :
1460 : : select type (mat)
1461 : : class is (slkmat_dp_t)
1462 : : if (allocated(mat%buffer_cplx)) then
1463 : : gpu_ptr = xomp_get_mapped_ptr(c_loc(mat%buffer_cplx))
1464 : : ABI_CHECK_CNULL(gpu_ptr, "buffer_cplx not on GPU!")
1465 : : call gpu_memset(gpu_ptr, 0, mat%bufsize*dp*2)
1466 : : end if
1467 : : if (allocated(mat%buffer_real)) then
1468 : : gpu_ptr = xomp_get_mapped_ptr(c_loc(mat%buffer_real))
1469 : : ABI_CHECK_CNULL(gpu_ptr, "buffer_real not on GPU!")
1470 : : call gpu_memset(gpu_ptr, 0, mat%bufsize*dp)
1471 : : end if
1472 : : class is (slkmat_sp_t)
1473 : : if (allocated(mat%buffer_cplx)) then
1474 : : gpu_ptr = xomp_get_mapped_ptr(c_loc(mat%buffer_cplx))
1475 : : ABI_CHECK_CNULL(gpu_ptr, "buffer_cplx not on GPU!")
1476 : : call gpu_memset(gpu_ptr, 0, mat%bufsize*sp*2)
1477 : : end if
1478 : : if (allocated(mat%buffer_real)) then
1479 : : gpu_ptr = xomp_get_mapped_ptr(c_loc(mat%buffer_real))
1480 : : ABI_CHECK_CNULL(gpu_ptr, "buffer_real not on GPU!")
1481 : : call gpu_memset(gpu_ptr, 0, mat%bufsize*sp)
1482 : : end if
1483 : : end select
1484 : : #else
1485 : 0 : ABI_ERROR("basemat_gpu_set cannot be used if HAVE_OPENMP_OFFLOAD is not defined!")
1486 : : ABI_UNUSED(mat%size_local(1))
1487 : : #endif
1488 : :
1489 : 0 : end subroutine basemat_gpu_set_zero
1490 : : !!***
1491 : :
1492 : : !!****f* m_slk/slk_array1_gpu_set_zero
1493 : : !! NAME
1494 : : !! slk_array1_gpu_set_zero
1495 : : !!
1496 : : !! FUNCTION
1497 : : !!
1498 : : !! SOURCE
1499 : :
1500 : 0 : subroutine slk_array1_gpu_set_zero(mat1d)
1501 : :
1502 : : !Arguments ------------------------------------
1503 : : class(basemat_t),intent(inout) :: mat1d(:)
1504 : :
1505 : : !Local variables-------------------------------
1506 : : integer :: i1
1507 : : ! *********************************************************************
1508 : :
1509 [ # # ]: 0 : do i1=1,size(mat1d, dim=1)
1510 : 0 : call mat1d(i1)%gpu_set_zero()
1511 : : end do
1512 : :
1513 : 0 : end subroutine slk_array1_gpu_set_zero
1514 : : !!***
1515 : :
1516 : : !!****f* m_slk/slk_array2_gpu_set_zero
1517 : : !! NAME
1518 : : !! slk_array2_gpu_set_zero
1519 : : !!
1520 : : !! FUNCTION
1521 : : !!
1522 : : !! SOURCE
1523 : :
1524 : 0 : subroutine slk_array2_gpu_set_zero(mat2d)
1525 : :
1526 : : !Arguments ------------------------------------
1527 : : class(basemat_t),intent(inout) :: mat2d(:,:)
1528 : :
1529 : : !Local variables-------------------------------
1530 : : integer :: i1, i2
1531 : : ! *********************************************************************
1532 : :
1533 [ # # ]: 0 : do i2=1,size(mat2d, dim=2)
1534 [ # # ]: 0 : do i1=1,size(mat2d, dim=1)
1535 : 0 : call mat2d(i1, i2)%gpu_set_zero()
1536 : : end do
1537 : : end do
1538 : :
1539 : 0 : end subroutine slk_array2_gpu_set_zero
1540 : : !!***
1541 : :
1542 : : !!****f* m_slk/slk_array3_gpu_set_zero
1543 : : !! NAME
1544 : : !! slk_array3_gpu_set_zero
1545 : : !!
1546 : : !! FUNCTION
1547 : : !!
1548 : : !! SOURCE
1549 : :
1550 : 0 : subroutine slk_array3_gpu_set_zero(mat3d)
1551 : :
1552 : : !Arguments ------------------------------------
1553 : : class(basemat_t),intent(inout) :: mat3d(:,:,:)
1554 : :
1555 : : !Local variables-------------------------------
1556 : : integer :: i1,i2,i3
1557 : : ! *********************************************************************
1558 : :
1559 [ # # ]: 0 : do i3=1,size(mat3d, dim=3)
1560 [ # # ]: 0 : do i2=1,size(mat3d, dim=2)
1561 [ # # ]: 0 : do i1=1,size(mat3d, dim=1)
1562 : 0 : call mat3d(i1,i2,i3)%gpu_set_zero()
1563 : : end do
1564 : : end do
1565 : : end do
1566 : :
1567 : 0 : end subroutine slk_array3_gpu_set_zero
1568 : : !!***
1569 : :
1570 : : !!****f* m_slk/slk_array4_gpu_set_zero
1571 : : !! NAME
1572 : : !! slk_array4_gpu_set_zero
1573 : : !!
1574 : : !! FUNCTION
1575 : : !!
1576 : : !! SOURCE
1577 : :
1578 : 0 : subroutine slk_array4_gpu_set_zero(mat4d)
1579 : :
1580 : : !Arguments ------------------------------------
1581 : : class(basemat_t),intent(inout) :: mat4d(:,:,:,:)
1582 : :
1583 : : !Local variables-------------------------------
1584 : : integer :: i1, i2, i3, i4
1585 : : ! *********************************************************************
1586 : :
1587 [ # # ]: 0 : do i4=1,size(mat4d, dim=4)
1588 [ # # ]: 0 : do i3=1,size(mat4d, dim=3)
1589 [ # # ]: 0 : do i2=1,size(mat4d, dim=2)
1590 [ # # ]: 0 : do i1=1,size(mat4d, dim=1)
1591 : 0 : call mat4d(i1, i2, i3, i4)%gpu_set_zero()
1592 : : end do
1593 : : end do
1594 : : end do
1595 : : end do
1596 : :
1597 : 0 : end subroutine slk_array4_gpu_set_zero
1598 : : !!***
1599 : :
1600 : : !!****f* m_slk/slk_array5_gpu_set_zero
1601 : : !! NAME
1602 : : !! slk_array5_gpu_set_zero
1603 : : !!
1604 : : !! FUNCTION
1605 : : !!
1606 : : !! SOURCE
1607 : :
1608 : 0 : subroutine slk_array5_gpu_set_zero(mat5d)
1609 : :
1610 : : !Arguments ------------------------------------
1611 : : class(basemat_t),intent(inout) :: mat5d(:,:,:,:,:)
1612 : :
1613 : : !Local variables-------------------------------
1614 : : integer :: i1,i2,i3,i4,i5
1615 : : ! *********************************************************************
1616 : :
1617 [ # # ]: 0 : do i5=1,size(mat5d, dim=5)
1618 [ # # ]: 0 : do i4=1,size(mat5d, dim=4)
1619 [ # # ]: 0 : do i3=1,size(mat5d, dim=3)
1620 [ # # ]: 0 : do i2=1,size(mat5d, dim=2)
1621 [ # # ]: 0 : do i1=1,size(mat5d, dim=1)
1622 : 0 : call mat5d(i1,i2,i3,i4,i5)%gpu_set_zero()
1623 : : end do
1624 : : end do
1625 : : end do
1626 : : end do
1627 : : end do
1628 : :
1629 : 0 : end subroutine slk_array5_gpu_set_zero
1630 : : !!***
1631 : :
1632 : : !----------------------------------------------------------------------
1633 : :
1634 : : !!****f* m_slk/basemat_is_gpu_mapped
1635 : : !! NAME
1636 : : !! basemat_is_gpu_mapped
1637 : : !!
1638 : : !! FUNCTION
1639 : : !! Return True if the local buffer is mapped to the GPU and the pointer on the gpu.
1640 : : !!
1641 : : !! SOURCE
1642 : :
1643 : 0 : logical function basemat_is_gpu_mapped(mat, gpu_ptr) result(is_gpu_mapped)
1644 : :
1645 : : !Arguments ------------------------------------
1646 : : class(basemat_t),target,intent(in) :: mat
1647 : : type(c_ptr),intent(out) :: gpu_ptr
1648 : :
1649 : : !Local variables-------------------------------
1650 : : #ifdef HAVE_OPENMP_OFFLOAD
1651 : : real(sp), contiguous, pointer :: buf_real_sp(:,:)
1652 : : real(dp), contiguous, pointer :: buf_real_dp(:,:)
1653 : : complex(sp), contiguous, pointer :: buf_cplx_sp(:,:)
1654 : : complex(dp), contiguous, pointer :: buf_cplx_dp(:,:)
1655 : : #endif
1656 : : ! *********************************************************************
1657 : :
1658 : 0 : is_gpu_mapped = .False.; gpu_ptr = c_null_ptr
1659 : : #ifdef HAVE_OPENMP_OFFLOAD
1660 : : select type (mat)
1661 : : class is (slkmat_dp_t)
1662 : : if (allocated(mat%buffer_cplx)) then
1663 : : buf_cplx_dp => mat%buffer_cplx
1664 : : gpu_ptr = xomp_get_mapped_ptr(c_loc(buf_cplx_dp))
1665 : : is_gpu_mapped = c_associated(gpu_ptr)
1666 : : end if
1667 : : if (allocated(mat%buffer_real)) then
1668 : : buf_real_dp => mat%buffer_real
1669 : : gpu_ptr = xomp_get_mapped_ptr(c_loc(buf_real_dp))
1670 : : is_gpu_mapped = c_associated(gpu_ptr)
1671 : : end if
1672 : :
1673 : : class is (slkmat_sp_t)
1674 : : if (allocated(mat%buffer_cplx)) then
1675 : : buf_cplx_sp => mat%buffer_cplx
1676 : : gpu_ptr= xomp_get_mapped_ptr(c_loc(buf_cplx_sp))
1677 : : is_gpu_mapped = c_associated(gpu_ptr)
1678 : : end if
1679 : : if (allocated(mat%buffer_real)) then
1680 : : buf_real_sp => mat%buffer_real
1681 : : gpu_ptr = xomp_get_mapped_ptr(c_loc(buf_real_sp))
1682 : : is_gpu_mapped = c_associated(gpu_ptr)
1683 : : end if
1684 : : end select
1685 : : #else
1686 : : ABI_UNUSED(mat%size_local(1))
1687 : : #endif
1688 : :
1689 : 0 : end function basemat_is_gpu_mapped
1690 : : !!***
1691 : :
1692 : : !----------------------------------------------------------------------
1693 : :
1694 : : !!****f* m_slk/basemat_gpu_map
1695 : : !! NAME
1696 : : !! basemat_gpu_map
1697 : : !!
1698 : : !! FUNCTION
1699 : : !! Use Opemp to allocate/delete the local buffer on the GPU.
1700 : : !!
1701 : : !! SOURCE
1702 : :
1703 : 0 : subroutine basemat_gpu_map(mat, gpu_action)
1704 : :
1705 : : !Arguments ------------------------------------
1706 : : class(basemat_t),target,intent(inout) :: mat
1707 : : character(len=*), intent(in) :: gpu_action
1708 : :
1709 : : !Local variables-------------------------------
1710 : : #ifdef HAVE_OPENMP_OFFLOAD
1711 : : real(sp), contiguous, pointer :: buf_real_sp(:,:)
1712 : : real(dp), contiguous, pointer :: buf_real_dp(:,:)
1713 : : complex(sp), contiguous, pointer :: buf_cplx_sp(:,:)
1714 : : complex(dp), contiguous, pointer :: buf_cplx_dp(:,:)
1715 : : #endif
1716 : : ! *********************************************************************
1717 : :
1718 [ # # ]: 0 : if (.not. string_in(gpu_action, "None, alloc, alloc_zero, delete, update_from, update_to")) then
1719 : 0 : ABI_ERROR(sjoin("Invalid gpu_action", gpu_action))
1720 : : ABI_UNUSED(mat%size_local(1))
1721 : : end if
1722 : :
1723 : : if (gpu_action == "None") return
1724 : :
1725 : : #ifdef HAVE_OPENMP_OFFLOAD
1726 : : select type (mat)
1727 : : class is (slkmat_dp_t)
1728 : : if (allocated(mat%buffer_cplx)) then
1729 : : buf_cplx_dp => mat%buffer_cplx
1730 : : if (string_in(gpu_action, "alloc, alloc_zero")) then
1731 : : !$OMP TARGET ENTER DATA MAP(alloc:buf_cplx_dp)
1732 : : if (gpu_action == "alloc_zero") call gpu_set_to_zero_complex(mat%buffer_cplx, mat%bufsize)
1733 : : else if (gpu_action == "delete") then !.and. c_associated(xomp_get_mapped_ptr(c_loc(buf_cplx_dp))
1734 : : !$OMP TARGET EXIT DATA MAP(delete:buf_cplx_dp)
1735 : : else if (gpu_action == "update_from") then
1736 : : !$OMP TARGET UPDATE FROM(buf_cplx_dp)
1737 : : else if (gpu_action == "update_to") then
1738 : : !$OMP TARGET UPDATE TO(buf_cplx_dp)
1739 : : end if
1740 : : end if
1741 : : if (allocated(mat%buffer_real)) then
1742 : : buf_real_dp => mat%buffer_real
1743 : : if (string_in(gpu_action, "alloc, alloc_zero")) then
1744 : : !$OMP TARGET ENTER DATA MAP(alloc:buf_real_dp)
1745 : : if (gpu_action == "alloc_zero") call gpu_set_to_zero(mat%buffer_real, mat%bufsize)
1746 : : else if (gpu_action == "delete") then !.and. c_associated(xomp_get_mapped_ptr(c_loc(buf_real_dp))
1747 : : !$OMP TARGET EXIT DATA MAP(delete:buf_real_dp)
1748 : : else if (gpu_action == "update_from") then
1749 : : !$OMP TARGET UPDATE FROM(buf_real_dp)
1750 : : else if (gpu_action == "update_to") then
1751 : : !$OMP TARGET UPDATE TO(buf_real_dp)
1752 : : end if
1753 : : end if
1754 : :
1755 : : class is (slkmat_sp_t)
1756 : : if (allocated(mat%buffer_cplx)) then
1757 : : buf_cplx_sp => mat%buffer_cplx
1758 : : if (string_in(gpu_action, "alloc, alloc_zero")) then
1759 : : !$OMP TARGET ENTER DATA MAP(alloc:buf_cplx_sp)
1760 : : if (gpu_action == "alloc_zero") call gpu_set_to_zero_complex_sp(mat%buffer_cplx, mat%bufsize)
1761 : : else if (gpu_action == "delete") then !.and. c_associated(xomp_get_mapped_ptr(c_loc(buf_cplx_sp))
1762 : : !$OMP TARGET EXIT DATA MAP(delete:buf_cplx_sp)
1763 : : else if (gpu_action == "update_from") then
1764 : : !$OMP TARGET UPDATE FROM(buf_cplx_sp)
1765 : : else if (gpu_action == "update_to") then
1766 : : !$OMP TARGET UPDATE TO(buf_cplx_sp)
1767 : : end if
1768 : : end if
1769 : : if (allocated(mat%buffer_real)) then
1770 : : buf_real_sp => mat%buffer_real
1771 : : if (string_in(gpu_action, "alloc, alloc_zero")) then
1772 : : !$OMP TARGET ENTER DATA MAP(alloc:buf_real_sp)
1773 : : if (gpu_action == "alloc_zero") call gpu_set_to_zero_sp(mat%buffer_real, mat%bufsize)
1774 : : else if (gpu_action == "delete") then !.and. c_associated(xomp_get_mapped_ptr(c_loc(buf_real_sp))
1775 : : !$OMP TARGET EXIT DATA MAP(delete:buf_real_sp)
1776 : : else if (gpu_action == "update_from") then
1777 : : !$OMP TARGET UPDATE FROM(buf_real_sp)
1778 : : else if (gpu_action == "update_to") then
1779 : : !$OMP TARGET UPDATE TO(buf_real_sp)
1780 : : end if
1781 : : end if
1782 : : end select
1783 : : #endif
1784 : :
1785 : : end subroutine basemat_gpu_map
1786 : : !!***
1787 : :
1788 : : !----------------------------------------------------------------------
1789 : :
1790 : : !!****f* m_slk/slk_array_locmem_mb
1791 : : !! NAME
1792 : : !! slk_array_locmem_mb
1793 : : !!
1794 : : !! FUNCTION
1795 : : !! Elemental function to compute the memory allocated for an array of slkmat_dp_t elements
1796 : : !! Usage: mem_mb = sum(mat_array)
1797 : : !!
1798 : : !! SOURCE
1799 : :
1800 : 0 : elemental real(dp) function slk_array_locmem_mb(mat) result(mem_mb)
1801 : : class(basemat_t),intent(in) :: mat
1802 : 0 : mem_mb = mat%locmem_mb()
1803 : 0 : end function slk_array_locmem_mb
1804 : : !!***
1805 : :
1806 : : !----------------------------------------------------------------------
1807 : :
1808 : : !!****f* m_slk/block_dist_1d
1809 : : !! NAME
1810 : : !! block_dist_1d
1811 : : !!
1812 : : !! FUNCTION
1813 : : !! Return block size for one-dimensional block column (row) distribution.
1814 : : !! Mainly used to assign blocks of contiguous columns (rows) of a matrix to successive processes
1815 : : !! when a 1d grid is employed.
1816 : : !!
1817 : : !! It is usually interfaced with CPP macros, e.g:
1818 : : !!
1819 : : !! ABI_CHECK(block_dist_1d(mat_size, nproc, block_size, msg), msg)
1820 : : !!
1821 : : !! INPUTS
1822 : : !! mat_size=Size of the matrix (either number of rows or number of colums)
1823 : : !! nproc=Number of processoes in the 1D scalapack grid
1824 : : !!
1825 : : !! OUTPUT
1826 : : !! ok= Boolean flag with exit status (idle processes are not allowed).
1827 : : !! block_size=Size of the block along this axis needed for one-dimensional block distribution
1828 : : !! msg=Error message (if not ok)
1829 : : !!
1830 : : !! SOURCE
1831 : :
1832 : 0 : logical function block_dist_1d(mat_size, nproc, block_size, msg) result (ok)
1833 : :
1834 : : !Arguments ------------------------------------
1835 : : integer, intent(in) :: mat_size, nproc
1836 : : integer,intent(out) :: block_size
1837 : : character(len=*),intent(out) :: msg
1838 : : ! *********************************************************************
1839 : :
1840 : 0 : ok = .True.; msg = ""
1841 : : !block_size = 1; return
1842 : :
1843 : 0 : block_size = mat_size / nproc
1844 [ # # ]: 0 : if (block_size == 0) then
1845 : 0 : ok = .False.
1846 : : write(msg, "(2(a,i0), 2a)") &
1847 : 0 : "The number of MPI processors: ", nproc, " exceeeds the number of rows (columms) of the matrix: ", mat_size, ch10, &
1848 : 0 : "Decrease the number of MPI processes for the scalapack level."
1849 : 0 : return
1850 : : end if
1851 : :
1852 [ # # ]: 0 : if (mod(mat_size, nproc) /= 0) block_size = block_size + 1
1853 : :
1854 [ # # ]: 0 : end function block_dist_1d
1855 : : !!***
1856 : :
1857 : : !----------------------------------------------------------------------
1858 : :
1859 : : !!****f* m_slk/slk_has_elpa
1860 : : !! NAME
1861 : : !! slk_has_elpa
1862 : : !!
1863 : : !! FUNCTION
1864 : : !! Return True if ELPA support is activated
1865 : : !!
1866 : : !! SOURCE
1867 : :
1868 : 0 : pure logical function slk_has_elpa() result (ans)
1869 : :
1870 : 0 : ans = .False.
1871 : : #ifdef HAVE_LINALG_ELPA
1872 : : ans = .True.
1873 : : #endif
1874 : :
1875 : 0 : end function slk_has_elpa
1876 : : !!***
1877 : :
1878 : : !----------------------------------------------------------------------
1879 : :
1880 : : !!****f* m_slk/matrix_get_local_cplx
1881 : : !! NAME
1882 : : !! matrix_get_local_cplx
1883 : : !!
1884 : : !! FUNCTION
1885 : : !! Returns a local matrix coefficient of complex type.
1886 : : !! Access to a component thanks to its local indices
1887 : : !!
1888 : : !! INPUTS
1889 : : !! matrix= the matrix to process
1890 : : !! i= row in the matrix
1891 : : !! j= column in the matrix
1892 : : !!
1893 : : !! OUTPUT
1894 : : !! The value of the local matrix.
1895 : : !!
1896 : : !! SOURCE
1897 : :
1898 : 0 : pure complex(dpc) function matrix_get_local_cplx(matrix, i, j)
1899 : :
1900 : : !Arguments ------------------------------------
1901 : : class(slkmat_dp_t),intent(in) :: matrix
1902 : : integer, intent(in) :: i,j
1903 : : ! *********************************************************************
1904 : :
1905 : 0 : matrix_get_local_cplx = matrix%buffer_cplx(i,j)
1906 : :
1907 : 0 : end function matrix_get_local_cplx
1908 : : !!***
1909 : :
1910 : : !----------------------------------------------------------------------
1911 : :
1912 : : !!****f* m_slk/matrix_get_local_real
1913 : : !! NAME
1914 : : !! matrix_get_local_real
1915 : : !!
1916 : : !! FUNCTION
1917 : : !! Returns a local matrix coefficient of double precision type.
1918 : : !!
1919 : : !! INPUTS
1920 : : !! matrix= the matrix to process
1921 : : !! i= row in the matrix
1922 : : !! j= column in the matrix
1923 : : !!
1924 : : !! SOURCE
1925 : :
1926 : 0 : pure real(dp) function matrix_get_local_real(matrix,i,j)
1927 : :
1928 : : !Arguments ------------------------------------
1929 : : class(slkmat_dp_t),intent(in) :: matrix
1930 : : integer, intent(in) :: i,j
1931 : : ! *********************************************************************
1932 : :
1933 : 0 : matrix_get_local_real = matrix%buffer_real(i,j)
1934 : :
1935 : 0 : end function matrix_get_local_real
1936 : : !!***
1937 : :
1938 : : !----------------------------------------------------------------------
1939 : :
1940 : : !!****f* m_slk/matrix_set_local_cplx
1941 : : !! NAME
1942 : : !! matrix_set_local_cplx
1943 : : !!
1944 : : !! FUNCTION
1945 : : !! Sets a local matrix coefficient of complex type.
1946 : : !! -------------------------------------------------------
1947 : : !! Positioning of a component of a matrix thanks to its local indices
1948 : : !! -------------------------------------------------------
1949 : : !!
1950 : : !! INPUTS
1951 : : !! i= row in the matrix
1952 : : !! j= column in the matrix
1953 : : !! value= the value to set
1954 : : !!
1955 : : !! SIDE EFFECTS
1956 : : !! matrix%buffer_cplx(i,j) filled with value
1957 : : !!
1958 : : !! SOURCE
1959 : :
1960 : 0 : pure subroutine matrix_set_local_cplx(matrix,i,j,value)
1961 : :
1962 : : !Arguments ------------------------------------
1963 : : class(slkmat_dp_t),intent(inout) :: matrix
1964 : : integer, intent(in) :: i,j
1965 : : complex(dp), intent(in) :: value
1966 : : ! *********************************************************************
1967 : :
1968 : 0 : matrix%buffer_cplx(i,j) = value
1969 : :
1970 : 0 : end subroutine matrix_set_local_cplx
1971 : : !!***
1972 : :
1973 : : !----------------------------------------------------------------------
1974 : :
1975 : : !!****f* m_slk/matrix_set_local_real
1976 : : !! NAME
1977 : : !! matrix_set_local_real
1978 : : !!
1979 : : !! FUNCTION
1980 : : !! Sets a local matrix coefficient of double precision type.
1981 : : !!
1982 : : !! INPUTS
1983 : : !! i= row in the matrix
1984 : : !! j= column in the matrix
1985 : : !! value= the value to set
1986 : : !!
1987 : : !! SIDE EFFECTS
1988 : : !! matrix%buffer_real(i,j) set to value
1989 : : !!
1990 : : !! SOURCE
1991 : :
1992 : 0 : pure subroutine matrix_set_local_real(matrix, i, j, value)
1993 : :
1994 : : !Arguments ------------------------------------
1995 : : class(slkmat_dp_t),intent(inout) :: matrix
1996 : : integer, intent(in) :: i,j
1997 : : real(dp), intent(in) :: value
1998 : : ! *********************************************************************
1999 : :
2000 : 0 : matrix%buffer_real(i,j) = value
2001 : :
2002 : 0 : end subroutine matrix_set_local_real
2003 : : !!***
2004 : :
2005 : : !----------------------------------------------------------------------
2006 : :
2007 : : !!****f* m_slk/idx_loc
2008 : : !! NAME
2009 : : !! idx_loc
2010 : : !!
2011 : : !! FUNCTION
2012 : : !! Return local indices from global indices, **independently** of the processor.
2013 : : !!
2014 : : !! INPUTS
2015 : : !! matrix= the matrix to process
2016 : : !! i= row in the matrix
2017 : : !! j= column in the matrix
2018 : : !!
2019 : : !! OUTPUT
2020 : : !! iloc= local row of the coefficient
2021 : : !! jloc= local column of the coefficient
2022 : : !!
2023 : : !! SOURCE
2024 : :
2025 : 0 : subroutine basemat_idx_loc(matrix, i, j, iloc, jloc)
2026 : :
2027 : : !Arguments ------------------------------------
2028 : : class(basemat_t),intent(in) :: matrix
2029 : : integer, intent(in) :: i,j
2030 : : integer, intent(out) :: iloc,jloc
2031 : : ! *********************************************************************
2032 : :
2033 : 0 : iloc = glob_loc__(matrix, i, 1)
2034 : 0 : jloc = glob_loc__(matrix, j, 2)
2035 : :
2036 : 0 : end subroutine basemat_idx_loc
2037 : : !!***
2038 : :
2039 : : !----------------------------------------------------------------------
2040 : :
2041 : : !!****f* m_slk/glob_loc__
2042 : : !! NAME
2043 : : !! glob_loc__
2044 : : !!
2045 : : !! FUNCTION
2046 : : !! Returns the global location of a matrix coefficient.
2047 : : !!
2048 : : !! INPUTS
2049 : : !! matrix= the matrix to process
2050 : : !! idx= number of rows in the distributed matrix
2051 : : !! lico= block size index
2052 : : !!
2053 : : !! SOURCE
2054 : :
2055 : : integer function glob_loc__(matrix, idx, lico)
2056 : :
2057 : : !Arguments ------------------------------------
2058 : : class(basemat_t),intent(in) :: matrix
2059 : : integer, intent(in) :: idx, lico
2060 : : ! *********************************************************************
2061 : :
2062 : : #ifdef HAVE_LINALG_SCALAPACK
2063 : : glob_loc__ = NUMROC(idx, matrix%size_blocs(lico), &
2064 : : matrix%processor%coords(lico), 0, matrix%processor%grid%dims(lico))
2065 : : #endif
2066 : :
2067 : : end function glob_loc__
2068 : : !!***
2069 : :
2070 : : !----------------------------------------------------------------------
2071 : :
2072 : : !!****f* m_slk/basemat_glob2loc
2073 : : !! NAME
2074 : : !! basemat_glob2loc
2075 : : !!
2076 : : !! FUNCTION
2077 : : !! Determine the local indices of an element from its global indices and return haveit bool flag.
2078 : : !!
2079 : : !! INPUTS
2080 : : !! iloc= local row index.
2081 : : !! jloc= local column index.
2082 : : !!
2083 : : !! OUTPUT
2084 : : !! iloc= row in the matrix
2085 : : !! jloc= column in the matrix
2086 : : !! haveit= True if (iglob, jglob) is stored on this proc
2087 : : !!
2088 : : !! SOURCE
2089 : :
2090 : 0 : subroutine basemat_glob2loc(mat, iglob, jglob, iloc, jloc, haveit)
2091 : :
2092 : : !Arguments ------------------------------------
2093 : : class(basemat_t),intent(in) :: mat
2094 : : integer, intent(in) :: iglob, jglob
2095 : : integer, intent(out) :: iloc, jloc
2096 : : logical,intent(out) :: haveit
2097 : :
2098 : : !Local variables-------------------------------
2099 : : integer :: row_src, col_src
2100 : : ! *********************************************************************
2101 : :
2102 : : #ifdef HAVE_LINALG_SCALAPACK
2103 : : ! SUBROUTINE INFOG2L( GRINDX, GCINDX, DESC, NPROW, NPCOL, MYROW, MYCOL, LRINDX, LCINDX, RSRC, CSRC)
2104 : :
2105 : : call INFOG2L(iglob, jglob, mat%desc, mat%processor%grid%dims(1), mat%processor%grid%dims(2), &
2106 : : mat%processor%coords(1), mat%processor%coords(2), iloc, jloc, row_src, col_src)
2107 : :
2108 : : haveit = all(mat%processor%coords == [row_src, col_src])
2109 : : #endif
2110 : :
2111 : 0 : end subroutine basemat_glob2loc
2112 : : !!***
2113 : :
2114 : : !----------------------------------------------------------------------
2115 : :
2116 : : !!****f* m_slk/basemat_loc2glob
2117 : : !! NAME
2118 : : !! basemat_loc2glob
2119 : : !!
2120 : : !! FUNCTION
2121 : : !! Determine the global indices of an element from its local indices.
2122 : : !!
2123 : : !! INPUTS
2124 : : !! matrix= the matrix to process.
2125 : : !! iloc= local row index.
2126 : : !! jloc= local column index.
2127 : : !!
2128 : : !! OUTPUT
2129 : : !! i= row in the matrix
2130 : : !! j= column in the matrix
2131 : : !!
2132 : : !! SOURCE
2133 : :
2134 : 0 : pure subroutine basemat_loc2glob(matrix, iloc, jloc, i, j)
2135 : :
2136 : : !Arguments ------------------------------------
2137 : : class(basemat_t),intent(in) :: matrix
2138 : : integer, intent(in) :: iloc,jloc
2139 : : integer, intent(out) :: i,j
2140 : : ! *********************************************************************
2141 : :
2142 : 0 : i = loc_glob__(matrix, matrix%processor, iloc, 1)
2143 : 0 : j = loc_glob__(matrix, matrix%processor, jloc, 2)
2144 : :
2145 : 0 : end subroutine basemat_loc2glob
2146 : : !!***
2147 : :
2148 : : !!****f* m_slk/basemat_loc2grow
2149 : : !! NAME
2150 : : !! basemat_loc2grow
2151 : : !!
2152 : : !! FUNCTION
2153 : : !! Determine the global row index from the local index
2154 : : !!
2155 : : !! INPUTS
2156 : : !! matrix= the matrix to process.
2157 : : !! iloc= local row index.
2158 : : !!
2159 : : !! SOURCE
2160 : :
2161 : 0 : integer pure function basemat_loc2grow(matrix, iloc) result(iglob)
2162 : :
2163 : : !Arguments ------------------------------------
2164 : : class(basemat_t),intent(in) :: matrix
2165 : : integer, intent(in) :: iloc
2166 : : ! *********************************************************************
2167 : :
2168 : 0 : iglob = loc_glob__(matrix, matrix%processor, iloc, 1)
2169 : :
2170 : 0 : end function basemat_loc2grow
2171 : : !!***
2172 : :
2173 : : !!****f* m_slk/basemat_loc2col
2174 : : !! NAME
2175 : : !! basemat_loc2col
2176 : : !!
2177 : : !! FUNCTION
2178 : : !! Determine the global column index of an element from the local index
2179 : : !!
2180 : : !! INPUTS
2181 : : !! matrix= the matrix to process.
2182 : : !! jloc= local column index.
2183 : : !!
2184 : : !! SOURCE
2185 : :
2186 : 0 : integer pure function basemat_loc2col(matrix, jloc) result(jglob)
2187 : :
2188 : : !Arguments ------------------------------------
2189 : : class(basemat_t),intent(in) :: matrix
2190 : : integer, intent(in) :: jloc
2191 : : ! *********************************************************************
2192 : :
2193 : 0 : jglob = loc_glob__(matrix, matrix%processor, jloc, 2)
2194 : :
2195 : 0 : end function basemat_loc2col
2196 : : !!***
2197 : :
2198 : : !----------------------------------------------------------------------
2199 : :
2200 : : !!****f* m_slk/loc_glob__
2201 : : !! NAME
2202 : : !! loc_glob__
2203 : : !!
2204 : : !! FUNCTION
2205 : : !! Determine the global index from a local index (row or column) as a function of a given processor
2206 : : !!
2207 : : !! INPUTS
2208 : : !! matrix= the matrix to process
2209 : : !! proc= descriptor of a processor
2210 : : !! idx= number of rows in the distributed matrix
2211 : : !! lico= block size index. 1 for rows. 2 for columns
2212 : : !!
2213 : : !! SOURCE
2214 : :
2215 : 0 : integer pure function loc_glob__(matrix, proc, idx, lico)
2216 : :
2217 : : !Arguments ------------------------------------
2218 : : class(basemat_t),intent(in) :: matrix
2219 : : class(slk_processor_t),intent(in) :: proc
2220 : : integer, intent(in) :: idx,lico
2221 : :
2222 : : !Local variables-------------------------------
2223 : : integer :: nbcyc, rest, nblocs
2224 : : ! *********************************************************************
2225 : :
2226 : 0 : nbcyc = INT((idx-1) / matrix%size_blocs(lico))
2227 : 0 : rest = MOD(idx-1, matrix%size_blocs(lico))
2228 : 0 : nblocs = nbcyc * proc%grid%dims(lico) + proc%coords(lico)
2229 : :
2230 : 0 : loc_glob__ = nblocs * matrix%size_blocs(lico) + rest + 1
2231 : :
2232 : 0 : end function loc_glob__
2233 : : !!***
2234 : :
2235 : : !----------------------------------------------------------------------
2236 : :
2237 : : !!****f* m_slk/slkmat_dp_from_global_pack
2238 : : !! NAME
2239 : : !! slkmat_dp_from_global_pack
2240 : : !!
2241 : : !! FUNCTION
2242 : : !! Routine to fill a SCALAPACK matrix from a global PACKED matrix.
2243 : : !!
2244 : : !! INPUTS
2245 : : !! istwf_k= 2 if we have a real matrix else complex.
2246 : : !! glob_mat_pack= one-dimensional array with packed matrix.
2247 : : !!
2248 : : !! SIDE EFFECTS
2249 : : !! matrix= the matrix to process
2250 : : !!
2251 : : !! SOURCE
2252 : :
2253 : 0 : subroutine slkmat_dp_from_global_pack(matrix, glob_mat_pack, istwf_k)
2254 : :
2255 : : !Arguments ------------------------------------
2256 : : class(slkmat_dp_t),intent(inout) :: matrix
2257 : : integer,intent(in) :: istwf_k
2258 : : real(dp),intent(in) :: glob_mat_pack(*)
2259 : :
2260 : : !Local variables-------------------------------
2261 : : integer :: i,j,iglob,jglob,ind
2262 : : real(dp) :: val_real
2263 : : complex(dp) :: val_cplx
2264 : : ! *********************************************************************
2265 : :
2266 [ # # ]: 0 : do i=1,matrix%size_local(1)
2267 [ # # ]: 0 : do j=1,matrix%size_local(2)
2268 : 0 : call matrix%loc2glob(i, j, iglob, jglob)
2269 : :
2270 [ # # ]: 0 : if (istwf_k/=2) then
2271 : 0 : ind = jglob*(jglob-1)+2*iglob-1
2272 : 0 : val_cplx = dcmplx(glob_mat_pack(ind),glob_mat_pack(ind+1))
2273 : 0 : call matrix_set_local_cplx(matrix,i,j,val_cplx)
2274 : : else
2275 : 0 : ind = (jglob*(jglob-1))/2 + iglob
2276 : 0 : val_real = glob_mat_pack(ind)
2277 : 0 : call matrix_set_local_real(matrix,i,j,val_real)
2278 : : end if
2279 : :
2280 : : end do
2281 : : end do
2282 : :
2283 : 0 : end subroutine slkmat_dp_from_global_pack
2284 : : !!***
2285 : :
2286 : : !----------------------------------------------------------------------
2287 : :
2288 : : !!****f* m_slk/slkmat_dp_from_global_sym
2289 : : !! NAME
2290 : : !! slkmat_dp_from_global_sym
2291 : : !!
2292 : : !! FUNCTION
2293 : : !!
2294 : : !! INPUTS
2295 : : !! istwf_k= 2 if we have a real matrix else complex.
2296 : : !! glob_vec_pack= one-dimensional array in packed form
2297 : : !!
2298 : : !! SIDE EFFECTS
2299 : : !! matrix= the matrix to process
2300 : : !!
2301 : : !! SOURCE
2302 : :
2303 [ # # ]: 0 : subroutine slkmat_dp_from_global_sym(matrix, glob_vec_pack, istwf_k)
2304 : :
2305 : : !Arguments ------------------------------------
2306 : : class(slkmat_dp_t),intent(inout) :: matrix
2307 : : real(dp),intent(in) :: glob_vec_pack(:)
2308 : : integer,intent(in) :: istwf_k
2309 : :
2310 : : !Local variables-------------------------------
2311 : : integer :: i,j,iglob,jglob,ind
2312 : : complex(dp):: val_cplx
2313 : : real(dp) ::val_real
2314 : : ! *********************************************************************
2315 : :
2316 [ # # ]: 0 : do i=1,matrix%size_local(1)
2317 [ # # ]: 0 : do j=1,matrix%size_local(2)
2318 : 0 : call matrix%loc2glob(i,j,iglob,jglob)
2319 [ # # ]: 0 : if (jglob < iglob) then
2320 : 0 : ind = iglob*(iglob-1)+2*jglob-1
2321 : : else
2322 : 0 : ind = jglob*(jglob-1)+2*iglob-1
2323 : : end if
2324 [ # # ]: 0 : if (istwf_k /= 2) then
2325 : 0 : val_cplx = dcmplx(glob_vec_pack(ind),glob_vec_pack(ind+1))
2326 [ # # ]: 0 : if (jglob < iglob) then
2327 : 0 : call matrix_set_local_cplx(matrix,i,j,conjg(val_cplx))
2328 : : else
2329 : 0 : call matrix_set_local_cplx(matrix,i,j,val_cplx)
2330 : : end if
2331 : : else
2332 : 0 : ind = (ind + 1) / 2
2333 : 0 : val_real = glob_vec_pack(ind)
2334 : 0 : call matrix_set_local_real(matrix,i,j,val_real)
2335 : : end if
2336 : : end do
2337 : : end do
2338 : :
2339 : 0 : end subroutine slkmat_dp_from_global_sym
2340 : : !!***
2341 : :
2342 : : !----------------------------------------------------------------------
2343 : :
2344 : : !!****f* m_slk/slkmat_dp_from_real_glob
2345 : : !! NAME
2346 : : !! slkmat_dp_from_real_glob
2347 : : !!
2348 : : !! FUNCTION
2349 : : !! Routine to fill a SCALAPACK matrix from a real global matrix (FULL STORAGE MODE)
2350 : : !!
2351 : : !! INPUTS
2352 : : !! istwf_k= 2 if we have a real matrix else complex.
2353 : : !! glob_mat= a real matrix
2354 : : !!
2355 : : !! SIDE EFFECTS
2356 : : !! matrix= the matrix to process
2357 : : !!
2358 : : !! SOURCE
2359 : :
2360 [ # # ]: 0 : subroutine slkmat_dp_from_real_glob(matrix, glob_mat, istwf_k)
2361 : :
2362 : : !Arguments ------------------------------------
2363 : : class(slkmat_dp_t),intent(inout) :: matrix
2364 : : integer,intent(in) :: istwf_k
2365 : : !arrays
2366 : : real(dp),intent(in) :: glob_mat(:,:)
2367 : :
2368 : : !Local variables-------------------------------
2369 : : integer :: i,j,iglob,jglob
2370 : : real(dp) :: val
2371 : : ! *********************************************************************
2372 : :
2373 : : ABI_UNUSED(istwf_k)
2374 : :
2375 [ # # ]: 0 : do i=1,matrix%size_local(1)
2376 [ # # ]: 0 : do j=1,matrix%size_local(2)
2377 : 0 : call matrix%loc2glob(i, j, iglob, jglob)
2378 : 0 : val = glob_mat(iglob, jglob)
2379 : 0 : call matrix_set_local_real(matrix,i,j,val)
2380 : : end do
2381 : : end do
2382 : :
2383 : 0 : end subroutine slkmat_dp_from_real_glob
2384 : : !!***
2385 : :
2386 : : !----------------------------------------------------------------------
2387 : :
2388 : : !!****f* m_slk/slkmat_dp_from_complex_glob
2389 : : !! NAME
2390 : : !! slkmat_dp_from_complex_glob
2391 : : !!
2392 : : !! FUNCTION
2393 : : !! Routine to fill a SCALAPACK matrix from a global matrix (FULL STORAGE MODE)
2394 : : !!
2395 : : !! INPUTS
2396 : : !! istwf_k= 2 if we have a real matrix else complex.
2397 : : !! glob_mat= a complex matrix
2398 : : !!
2399 : : !! SIDE EFFECTS
2400 : : !! matrix= the matrix to process
2401 : : !!
2402 : : !! SOURCE
2403 : :
2404 [ # # ]: 0 : subroutine slkmat_dp_from_complex_glob(matrix, glob_mat, istwf_k)
2405 : :
2406 : : !Arguments ------------------------------------
2407 : : class(slkmat_dp_t),intent(inout) :: matrix
2408 : : integer,intent(in) :: istwf_k
2409 : : !arrays
2410 : : real(dp),intent(in) :: glob_mat(:,:)
2411 : :
2412 : : !Local variables-------------------------------
2413 : : integer :: i,j,iglob,jglob
2414 : : complex(dpc) :: val
2415 : : ! *********************************************************************
2416 : :
2417 : : ABI_UNUSED(istwf_k)
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 : val = dcmplx(glob_mat(2*iglob-1, jglob),glob_mat(2*iglob, jglob))
2423 : 0 : call matrix_set_local_cplx(matrix,i,j,val)
2424 : : end do
2425 : : end do
2426 : :
2427 : 0 : end subroutine slkmat_dp_from_complex_glob
2428 : : !!***
2429 : :
2430 : : !----------------------------------------------------------------------
2431 : :
2432 : : !!****f* m_slk/slkmat_dp_to_global_pack
2433 : : !! NAME
2434 : : !! slkmat_dp_to_global_pack
2435 : : !!
2436 : : !! FUNCTION
2437 : : !! Inserts a ScaLAPACK matrix into a global one in PACKED storage mode.
2438 : : !!
2439 : : !! INPUTS
2440 : : !! matrix= the matrix to process
2441 : : !! istwf_k= 2 if we have a real matrix else complex.
2442 : : !! nband_k= number of bands at this k point for that spin polarization
2443 : : !!
2444 : : !! SIDE EFFECTS
2445 : : !! glob_pack= one-dimensional array
2446 : : !!
2447 : : !! SOURCE
2448 : :
2449 : 0 : subroutine slkmat_dp_to_global_pack(matrix, glob_pack, istwf_k)
2450 : :
2451 : : !Arguments ------------------------------------
2452 : : class(slkmat_dp_t),intent(in) :: matrix
2453 : : integer,intent(in) :: istwf_k !,nband_k
2454 : : real(dp),intent(inout) :: glob_pack(*) !(nband_k*(nband_k+1))
2455 : :
2456 : : !Local variables-------------------------------
2457 : : integer :: i,j,iglob,jglob,ind
2458 : : ! *********************************************************************
2459 : :
2460 [ # # ]: 0 : do i=1,matrix%size_local(1)
2461 [ # # ]: 0 : do j=1,matrix%size_local(2)
2462 : 0 : call matrix%loc2glob(i, j, iglob, jglob)
2463 : :
2464 : 0 : ind = jglob*(jglob-1)+2*iglob-1
2465 [ # # ]: 0 : if (ind <= matrix%size_global(2)*(matrix%size_global(2)+1)) then
2466 [ # # ]: 0 : if (istwf_k/=2) then
2467 : 0 : glob_pack(ind) = real(matrix_get_local_cplx(matrix,i,j))
2468 : 0 : glob_pack(ind+1) = aimag(matrix_get_local_cplx(matrix,i,j))
2469 : : else
2470 : 0 : ind=(ind+1)/2 !real packed storage
2471 : 0 : glob_pack(ind) = matrix_get_local_real(matrix,i,j)
2472 : : end if
2473 : : end if
2474 : : end do
2475 : : end do
2476 : :
2477 : 0 : end subroutine slkmat_dp_to_global_pack
2478 : : !!***
2479 : :
2480 : : !----------------------------------------------------------------------
2481 : :
2482 : : !!****f* m_slk/slkmat_dp_to_real_glob
2483 : : !! NAME
2484 : : !! slkmat_dp_to_real_glob
2485 : : !!
2486 : : !! FUNCTION
2487 : : !! Inserts a ScaLAPACK matrix into a real matrix in FULL STORAGE MODE.
2488 : : !!
2489 : : !! INPUTS
2490 : : !! matrix= the matrix to process
2491 : : !! istwf_k= 2 if we have a real matrix else complex.
2492 : : !!
2493 : : !! SIDE EFFECTS
2494 : : !! glob_mat= the matrix to fill
2495 : : !!
2496 : : !! SOURCE
2497 : :
2498 [ # # ]: 0 : subroutine slkmat_dp_to_real_glob(matrix, glob_mat, istwf_k)
2499 : :
2500 : : !Arguments ------------------------------------
2501 : : class(slkmat_dp_t),intent(in) :: matrix
2502 : : integer,intent(in) :: istwf_k
2503 : : !arrays
2504 : : real(dp),intent(inout) :: glob_mat(:,:)
2505 : :
2506 : : !Local variables-------------------------------
2507 : : integer :: i,j,iglob,jglob
2508 : : ! *********************************************************************
2509 : :
2510 : : ABI_UNUSED(istwf_k)
2511 : :
2512 [ # # ]: 0 : do i=1,matrix%size_local(1)
2513 [ # # ]: 0 : do j=1,matrix%size_local(2)
2514 : 0 : call matrix%loc2glob(i, j, iglob, jglob)
2515 : 0 : glob_mat(iglob,jglob) = matrix_get_local_real(matrix,i,j)
2516 : : end do
2517 : : end do
2518 : :
2519 : 0 : end subroutine slkmat_dp_to_real_glob
2520 : : !!***
2521 : :
2522 : : !----------------------------------------------------------------------
2523 : :
2524 : : !!****f* m_slk/slkmat_dp_to_complex_glob
2525 : : !! NAME
2526 : : !! slkmat_dp_to_complex_glob
2527 : : !!
2528 : : !! FUNCTION
2529 : : !! Inserts a ScaLAPACK matrix into a complex matrix in FULL STORAGE MODE.
2530 : : !!
2531 : : !! INPUTS
2532 : : !! matrix= the matrix to process
2533 : : !! istwf_k= 2 if we have a real matrix else complex.
2534 : : !!
2535 : : !! SIDE EFFECTS
2536 : : !! glob_cmat= the matrix to fill
2537 : : !!
2538 : : !! SOURCE
2539 : :
2540 [ # # ]: 0 : subroutine slkmat_dp_to_complex_glob(matrix, glob_cmat, istwf_k)
2541 : :
2542 : : !Arguments ------------------------------------
2543 : : integer,intent(in) :: istwf_k
2544 : : class(slkmat_dp_t),intent(in) :: matrix
2545 : : !arrays
2546 : : complex(dpc),intent(inout) :: glob_cmat(:,:)
2547 : :
2548 : : !Local variables-------------------------------
2549 : : integer :: i,j,iglob,jglob
2550 : : ! *********************************************************************
2551 : :
2552 : : ABI_UNUSED(istwf_k)
2553 : :
2554 [ # # ]: 0 : do i=1,matrix%size_local(1)
2555 [ # # ]: 0 : do j=1,matrix%size_local(2)
2556 : 0 : call matrix%loc2glob(i, j, iglob, jglob)
2557 : 0 : glob_cmat(iglob,jglob) = matrix_get_local_cplx(matrix,i,j)
2558 : : end do
2559 : : end do
2560 : :
2561 : 0 : end subroutine slkmat_dp_to_complex_glob
2562 : : !!***
2563 : :
2564 : : !----------------------------------------------------------------------
2565 : :
2566 : : !!****f* m_slk/slkmat_dp_to_global
2567 : : !! NAME
2568 : : !! slkmat_dp_to_global
2569 : : !!
2570 : : !! FUNCTION
2571 : : !! Routine to fill a full matrix with respect to a SCALAPACK matrix.
2572 : : !!
2573 : : !! INPUTS
2574 : : !! matrix= the matrix to process
2575 : : !! istwf_k= 2 if we have a real matrix else complex.
2576 : : !!
2577 : : !! SIDE EFFECTS
2578 : : !! glob_mat= one-dimensional array
2579 : : !!
2580 : : !! SOURCE
2581 : :
2582 [ # # ]: 0 : subroutine slkmat_dp_to_global(matrix, glob_mat, istwf_k)
2583 : :
2584 : : !Arguments ------------------------------------
2585 : : class(slkmat_dp_t),intent(in) :: matrix
2586 : : integer,intent(in) :: istwf_k
2587 : : !arrays
2588 : : real(dp),intent(inout) :: glob_mat(:,:)
2589 : :
2590 : : !Local variables-------------------------------
2591 : : integer :: i,j,iglob,jglob,ind
2592 : : ! *********************************************************************
2593 : :
2594 [ # # ]: 0 : do i=1,matrix%size_local(1)
2595 [ # # ]: 0 : do j=1,matrix%size_local(2)
2596 : 0 : call matrix%loc2glob(i, j, iglob, jglob)
2597 : :
2598 [ # # ]: 0 : if (istwf_k/=2) then
2599 : 0 : ind=(iglob-1)*2+1
2600 : 0 : glob_mat(ind, jglob) = real(matrix_get_local_cplx(matrix,i,j))
2601 : 0 : glob_mat(ind+1,jglob) = aimag(matrix_get_local_cplx(matrix,i,j))
2602 : : else
2603 : 0 : ind=iglob
2604 : 0 : glob_mat(ind,jglob) = matrix_get_local_real(matrix,i,j)
2605 : : !glob_mat(ind+1,jglob) = 0._dp
2606 : : end if
2607 : :
2608 : : end do
2609 : : end do
2610 : :
2611 : 0 : end subroutine slkmat_dp_to_global
2612 : : !!***
2613 : :
2614 : : !----------------------------------------------------------------------
2615 : :
2616 : : !!****f* m_slk/slk_matrix_from_global_dpc_2D
2617 : : !! NAME
2618 : : !! slk_matrix_from_global_dpc_2D
2619 : : !!
2620 : : !! FUNCTION
2621 : : !! Routine to fill a complex SCALAPACK matrix with respect to a global matrix.
2622 : : !! target: Two-dimensional double precision complex matrix
2623 : : !!
2624 : : !! INPUTS
2625 : : !! glob_cmat=Two-dimensional array containing the global matrix.
2626 : : !! uplo=String specifying whether only the upper or lower triangular part of the global matrix is used:
2627 : : !! = "U": Upper triangular
2628 : : !! = "L": Lower triangular
2629 : : !! = "A": Full matrix (used for general complex matrices)
2630 : : !!
2631 : : !! SIDE EFFECTS
2632 : : !! mat<slkmat_dp_t>=The distributed matrix.
2633 : : !! %buffer_cplx=Local buffer containg the value this node is dealing with.
2634 : : !!
2635 : : !! SOURCE
2636 : :
2637 [ # # ]: 0 : subroutine slk_matrix_from_global_dpc_2D(mat, uplo, glob_cmat)
2638 : :
2639 : : !Arguments ------------------------------------
2640 : : !scalars
2641 : : class(slkmat_dp_t),intent(inout) :: mat
2642 : : character(len=*),intent(in) :: uplo
2643 : : !array
2644 : : complex(dpc),intent(in) :: glob_cmat(:,:)
2645 : :
2646 : : !Local variables-------------------------------
2647 : : integer :: ii, jj, iglob, jglob
2648 : : !************************************************************************
2649 : :
2650 [ # # ]: 0 : ABI_CHECK(allocated(mat%buffer_cplx), "%buffer_cplx not allocated")
2651 : :
2652 : 0 : select case (uplo(1:1))
2653 : :
2654 : : case ("A", "a")
2655 : : ! Full global matrix is used.
2656 [ # # ]: 0 : do jj=1,mat%size_local(2)
2657 [ # # ]: 0 : do ii=1,mat%size_local(1)
2658 : 0 : call mat%loc2glob(ii, jj, iglob, jglob)
2659 : 0 : mat%buffer_cplx(ii,jj) = glob_cmat(iglob,jglob)
2660 : : end do
2661 : : end do
2662 : :
2663 : : case ("U", "u")
2664 : : ! Only the upper triangle of the global matrix is used.
2665 [ # # ]: 0 : do jj=1,mat%size_local(2)
2666 [ # # ]: 0 : do ii=1,mat%size_local(1)
2667 : 0 : call mat%loc2glob(ii, jj, iglob, jglob)
2668 [ # # ]: 0 : if (jglob>=iglob) then
2669 : 0 : mat%buffer_cplx(ii,jj) = glob_cmat(iglob,jglob)
2670 : : else
2671 : 0 : mat%buffer_cplx(ii,jj) = DCONJG(glob_cmat(jglob,iglob))
2672 : : end if
2673 : : end do
2674 : : end do
2675 : :
2676 : : case ("L", "l")
2677 : : ! Only the lower triangle of the global matrix is used.
2678 [ # # ]: 0 : do jj=1,mat%size_local(2)
2679 [ # # ]: 0 : do ii=1,mat%size_local(1)
2680 : 0 : call mat%loc2glob(ii, jj, iglob, jglob)
2681 [ # # ]: 0 : if (jglob<=iglob) then
2682 : 0 : mat%buffer_cplx(ii,jj) = glob_cmat(iglob,jglob)
2683 : : else
2684 : 0 : mat%buffer_cplx(ii,jj) = DCONJG(glob_cmat(jglob,iglob))
2685 : : end if
2686 : : end do
2687 : : end do
2688 : :
2689 : : case default
2690 [ # # # # : 0 : ABI_BUG(" Wrong uplo: "//TRIM(uplo))
# # ]
2691 : : end select
2692 : :
2693 : 0 : end subroutine slk_matrix_from_global_dpc_2D
2694 : : !!***
2695 : :
2696 : : !----------------------------------------------------------------------
2697 : :
2698 : : !!****f* m_slk/slk_matrix_from_global_dpc_1Dp
2699 : : !! NAME
2700 : : !! slk_matrix_from_global_dpc_1Dp
2701 : : !!
2702 : : !! FUNCTION
2703 : : !! Routine to fill a complex SCALAPACK matrix with respect to a global matrix.
2704 : : !! target: double precision complex matrix in packed form.
2705 : : !!
2706 : : !! INPUTS
2707 : : !! glob_cmat_pack(n*(n+1)/2)=One-dimensional array containing the global matrix A packed columnwise in a linear array.
2708 : : !! The j-th column of A is stored in the array glob_cmat_pack as follows:
2709 : : !! if uplo = "U", glob_cmat_pack(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
2710 : : !! if uplo = "L", glob_cmat_pack(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
2711 : : !! where n is the number of rows or columns in the global matrix.
2712 : : !! uplo=String specifying whether only the upper or lower triangular part of the global matrix is used:
2713 : : !! = "U": Upper triangular
2714 : : !! = "L": Lower triangular
2715 : : !!
2716 : : !! SIDE EFFECTS
2717 : : !! mat<slkmat_dp_t>=The distributed matrix.
2718 : : !! %buffer_cplx=Local buffer containg the value this node is dealing with.
2719 : : !!
2720 : : !! SOURCE
2721 : :
2722 [ # # ]: 0 : subroutine slk_matrix_from_global_dpc_1Dp(mat,uplo, glob_cmat_pack)
2723 : :
2724 : : !Arguments ------------------------------------
2725 : : !scalars
2726 : : class(slkmat_dp_t),intent(inout) :: mat
2727 : : character(len=*),intent(in) :: uplo
2728 : : !array
2729 : : complex(dpc),intent(in) :: glob_cmat_pack(:)
2730 : :
2731 : : !Local variables-------------------------------
2732 : : integer :: ii,jj,iglob,jglob,ind,n
2733 : : real(dp) :: szm
2734 : : !************************************************************************
2735 : :
2736 [ # # ]: 0 : ABI_CHECK(allocated(mat%buffer_cplx), "%buffer_cplx not allocated")
2737 : :
2738 : 0 : szm = SIZE(glob_cmat_pack)
2739 : 0 : n = NINT( (-1 + SQRT(one+8*szm) )*half )
2740 [ # # ]: 0 : if (n*(n+1)/2 /= SIZE(glob_cmat_pack)) then
2741 : 0 : ABI_ERROR("Buggy compiler")
2742 : : end if
2743 : :
2744 : 0 : select case (uplo(1:1))
2745 : :
2746 : : case ("U", "u")
2747 : : ! Only the upper triangle of the global matrix is used.
2748 [ # # ]: 0 : do jj=1,mat%size_local(2)
2749 [ # # ]: 0 : do ii=1,mat%size_local(1)
2750 : 0 : call mat%loc2glob(ii, jj, iglob, jglob)
2751 : :
2752 [ # # ]: 0 : if (jglob>=iglob) then
2753 : 0 : ind = iglob + jglob*(jglob-1)/2
2754 : 0 : mat%buffer_cplx(ii,jj) = glob_cmat_pack(ind)
2755 : : else
2756 : 0 : ind = jglob + iglob*(iglob-1)/2
2757 : 0 : mat%buffer_cplx(ii,jj) = DCONJG( glob_cmat_pack(ind) )
2758 : : end if
2759 : :
2760 : : end do
2761 : : end do
2762 : :
2763 : : case ("L", "l")
2764 : : ! Only the lower triangle of the global matrix is used.
2765 [ # # ]: 0 : do jj=1,mat%size_local(2)
2766 [ # # ]: 0 : do ii=1,mat%size_local(1)
2767 : 0 : call mat%loc2glob(ii, jj, iglob, jglob)
2768 : :
2769 [ # # ]: 0 : if (jglob<=iglob) then
2770 : 0 : ind = iglob + (jglob-1)*(2*n-jglob)/2
2771 : 0 : mat%buffer_cplx(ii,jj) = glob_cmat_pack(ind)
2772 : : else
2773 : 0 : ind = jglob + (iglob-1)*(2*n-iglob)/2
2774 : 0 : mat%buffer_cplx(ii,jj) = DCONJG( glob_cmat_pack(ind) )
2775 : : end if
2776 : : end do
2777 : : end do
2778 : :
2779 : : case default
2780 [ # # # # : 0 : ABI_BUG(" Wrong uplo: "//TRIM(uplo))
# ]
2781 : : end select
2782 : :
2783 : 0 : end subroutine slk_matrix_from_global_dpc_1Dp
2784 : : !!***
2785 : :
2786 : : !----------------------------------------------------------------------
2787 : :
2788 : : !!****f* m_slk/slk_matrix_to_global_dpc_2D
2789 : : !! NAME
2790 : : !! slk_matrix_to_global_dpc_2D
2791 : : !!
2792 : : !! FUNCTION
2793 : : !! Fill a global matrix with respect to a SCALAPACK matrix.
2794 : : !! target: Two-dimensional double precision complex matrix.
2795 : : !!
2796 : : !! INPUTS
2797 : : !! Slk_mat<slkmat_dp_t>=The distributed matrix.
2798 : : !! uplo=String specifying whether the upper or lower triangular part of the global matrix has to be filled:
2799 : : !! = "U": Upper triangular
2800 : : !! = "L": Lower triangular
2801 : : !! = "A": Full matrix is filled (used for general complex matrices)
2802 : : !!
2803 : : !! SIDE EFFECTS
2804 : : !! glob_cmat=The global matrix where the entries owned by this processors have been overwritten.
2805 : : !! Note that the remaing entries not treated by this node are not changed.
2806 : : !!
2807 : : !! SOURCE
2808 : :
2809 [ # # ]: 0 : subroutine slk_matrix_to_global_dpc_2D(mat, uplo, glob_cmat)
2810 : :
2811 : : !Arguments ------------------------------------
2812 : : !scalaras
2813 : : class(slkmat_dp_t),intent(in) :: mat
2814 : : character(len=*),intent(in) :: uplo
2815 : : !arrays
2816 : : complex(dpc),intent(inout) :: glob_cmat(:,:)
2817 : :
2818 : : !Local variables-------------------------------
2819 : : integer :: ii,jj,iglob,jglob
2820 : : !************************************************************************
2821 : :
2822 : 0 : select case (uplo(1:1))
2823 : : case ("A", "a")
2824 : : ! Full global matrix has to be filled.
2825 [ # # ]: 0 : do jj=1,mat%size_local(2)
2826 [ # # ]: 0 : do ii=1,mat%size_local(1)
2827 : 0 : call mat%loc2glob(ii, jj, iglob, jglob)
2828 : 0 : glob_cmat(iglob,jglob) = mat%buffer_cplx(ii,jj)
2829 : : end do
2830 : : end do
2831 : :
2832 : : case ("U", "u")
2833 : : ! Only the upper triangle of the global matrix is filled.
2834 [ # # ]: 0 : do jj=1,mat%size_local(2)
2835 [ # # ]: 0 : do ii=1,mat%size_local(1)
2836 : 0 : call mat%loc2glob(ii, jj, iglob, jglob)
2837 [ # # ]: 0 : if (jglob>=iglob) glob_cmat(iglob,jglob) = mat%buffer_cplx(ii,jj)
2838 : : end do
2839 : : end do
2840 : :
2841 : : case ("L", "l")
2842 : : ! Only the lower triangle of the global matrix is filled.
2843 [ # # ]: 0 : do jj=1,mat%size_local(2)
2844 [ # # ]: 0 : do ii=1,mat%size_local(1)
2845 : 0 : call mat%loc2glob(ii, jj, iglob, jglob)
2846 [ # # ]: 0 : if (jglob<=iglob) glob_cmat(iglob,jglob) = mat%buffer_cplx(ii,jj)
2847 : : end do
2848 : : end do
2849 : :
2850 : : case default
2851 [ # # # # : 0 : ABI_BUG(" Wrong uplo: "//TRIM(uplo))
# # ]
2852 : : end select
2853 : :
2854 : 0 : end subroutine slk_matrix_to_global_dpc_2D
2855 : : !!***
2856 : :
2857 : : !----------------------------------------------------------------------
2858 : :
2859 : : !!****f* m_slk/my_locr
2860 : : !! NAME
2861 : : !! my_locr
2862 : : !!
2863 : : !! FUNCTION
2864 : : !! Method of slkmat_dp_t wrapping the scaLAPACK tool LOCr.
2865 : : !!
2866 : : !! OUTPUT
2867 : : !! my_locr= For the meaning see NOTES below.
2868 : : !!
2869 : : !! NOTES
2870 : : !! Let K be the number of rows or columns of a distributed matrix, and assume that its process grid has dimension p x q.
2871 : : !! LOCr( K ) denotes the number of elements of K that a process would receive if K were distributed over the p
2872 : : !! processes of its process column.
2873 : : !! Similarly, LOCc( K ) denotes the number of elements of K that a process would receive if K were distributed over
2874 : : !! the q processes of its process row.
2875 : : !! The values of LOCr() and LOCc() may be determined via a call to the ScaLAPACK tool function, NUMROC:
2876 : : !! LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
2877 : : !! LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ). An upper bound for these quantities may be computed
2878 : : !! by:
2879 : : !! LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
2880 : : !! LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
2881 : : !!
2882 : : !! SOURCE
2883 : :
2884 : : integer function my_locr(mat)
2885 : :
2886 : : !Arguments ------------------------------------
2887 : : class(basemat_t),intent(in) :: mat
2888 : :
2889 : : !Local variables-------------------------------
2890 : : #ifdef HAVE_LINALG_SCALAPACK
2891 : : integer :: M, MB_A, MYROW, RSRC_A, NPROW
2892 : : ! *************************************************************************
2893 : :
2894 : : M = mat%desc(M_ ) ! The number of rows in the global matrix.
2895 : : MB_A = mat%desc(MB_) ! The number of rows in a block.
2896 : : MYROW = mat%processor%coords(1) ! The row index of my processor
2897 : : RSRC_A = mat%desc(RSRC_) ! The row of the processors at the beginning.
2898 : : NPROW = mat%processor%grid%dims(1) ! The number of processors per row in the Scalapack grid.
2899 : :
2900 : : my_locr = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW )
2901 : : #endif
2902 : :
2903 : : end function my_locr
2904 : : !!***
2905 : :
2906 : : !----------------------------------------------------------------------
2907 : :
2908 : : !!****f* m_slk/my_locc
2909 : : !! NAME
2910 : : !! my_locc
2911 : : !!
2912 : : !! FUNCTION
2913 : : !! Method of slkmat_dp_t wrapping the scaLAPACK tool LOCc.
2914 : : !!
2915 : : !! OUTPUT
2916 : : !! my_locc= For the meaning see NOTES below.
2917 : : !!
2918 : : !! NOTES
2919 : : !! Let K be the number of rows or columns of a distributed matrix, and assume that its process grid has dimension p x q.
2920 : : !! LOCr( K ) denotes the number of elements of K that a process would receive if K were distributed over the p
2921 : : !! processes of its process column.
2922 : : !! Similarly, LOCc( K ) denotes the number of elements of K that a process would receive if K were distributed over
2923 : : !! the q processes of its process row.
2924 : : !! The values of LOCr() and LOCc() may be determined via a call to the ScaLAPACK tool function, NUMROC:
2925 : : !! LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
2926 : : !! LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ). An upper bound for these quantities may be computed
2927 : : !! by:
2928 : : !! LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
2929 : : !! LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
2930 : : !!
2931 : : !! SOURCE
2932 : :
2933 : : integer function my_locc(mat)
2934 : :
2935 : : !Arguments ------------------------------------
2936 : : class(basemat_t),intent(in) :: mat
2937 : :
2938 : : #ifdef HAVE_LINALG_SCALAPACK
2939 : : !Local variables-------------------------------
2940 : : integer :: N, NB_A, MYCOL, CSRC_A, NPCOL
2941 : : ! *************************************************************************
2942 : :
2943 : : N = mat%desc(N_ ) ! The number of columns in the global matrix.
2944 : : NB_A = mat%desc(NB_) ! The number of columns in a block.
2945 : : MYCOL = mat%processor%coords(2) ! The column index of my processor
2946 : : CSRC_A = mat%desc(CSRC_) ! The column of the processors at the beginning.
2947 : : NPCOL = mat%processor%grid%dims(2) ! The number of processors per column in the Scalapack grid.
2948 : :
2949 : : my_locc = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL )
2950 : : #endif
2951 : :
2952 : : end function my_locc
2953 : : !!***
2954 : :
2955 : : !----------------------------------------------------------------------
2956 : :
2957 : : !!****f* m_slk/slk_pgemm_dp
2958 : : !! NAME
2959 : : !! slk_pgemm_dp
2960 : : !!
2961 : : !! FUNCTION
2962 : : !! Extended matrix * matrix product: C := alpha*A*B + beta*C
2963 : : !! For a simple matrix vector product, one can simply pass alpha = cone and beta = czero
2964 : : !!
2965 : : !! INPUTS
2966 : : !! matrix1= first ScaLAPACK matrix (matrix A)
2967 : : !! matrix2= second ScaLAPACK matrix (matrix B)
2968 : : !! alpha= scalar multiplicator for the A*B product
2969 : : !! beta= scalar multiplicator for the C matrix
2970 : : !! [ija, ijb, ijc]: (global). The row and column indices in the distributed matrix A/B/C
2971 : : !! indicating the first row and the first column of the submatrix, respectively. Default [1, 1]
2972 : : !!
2973 : : !! OUTPUT
2974 : : !! results= ScaLAPACK matrix coming out of the operation
2975 : : !!
2976 : : !! NOTES
2977 : : !! The ESLL manual says that
2978 : : !! "matrices matrix1 and matrix2 must have no common elements otherwise, results are unpredictable."
2979 : : !! However the official scaLAPACK documentation does not report this (severe) limitation.
2980 : : !!
2981 : : !! SOURCE
2982 : :
2983 : 0 : subroutine slk_pgemm_dp(transa, transb, matrix1, alpha, matrix2, beta, results, &
2984 : : ija, ijb, ijc) ! optional
2985 : :
2986 : : !Arguments ------------------------------------
2987 : : character(len=1),intent(in) :: transa, transb
2988 : : class(slkmat_dp_t),intent(in) :: matrix1, matrix2
2989 : : class(slkmat_dp_t),intent(inout) :: results
2990 : : complex(dpc),intent(in) :: alpha, beta
2991 : : integer,optional,intent(in) :: ija(2), ijb(2), ijc(2)
2992 : :
2993 : : !Local variables-------------------------------
2994 : : integer :: mm, nn, kk, ija__(2), ijb__(2), ijc__(2)
2995 : : !************************************************************************
2996 : :
2997 : 0 : ija__ = [1, 1]; if (present(ija)) ija__ = ija
2998 : 0 : ijb__ = [1, 1]; if (present(ijb)) ijb__ = ijb
2999 : 0 : ijc__ = [1, 1]; if (present(ijc)) ijc__ = ijc
3000 : :
3001 : 0 : mm = matrix1%size_global(1)
3002 : 0 : nn = matrix2%size_global(2)
3003 : 0 : kk = matrix1%size_global(2)
3004 : :
3005 : 0 : if (toupper(transa) /= 'N') then
3006 : : mm = matrix1%size_global(2)
3007 : 0 : kk = matrix1%size_global(1)
3008 : : end if
3009 : 0 : if (toupper(transb) /= 'N') nn = matrix2%size_global(1)
3010 : :
3011 : : #ifdef HAVE_LINALG_SCALAPACK
3012 : : ! pzgemm(transa, transb, m, n, k, alpha, a, ia, ja, desca, b, ib, jb, descb, beta, c, ic, jc, descc)
3013 : : if (matrix1%istwf_k /= 2) then
3014 : : call PZGEMM(transa, transb, mm, nn, kk, alpha, &
3015 : : matrix1%buffer_cplx, ija__(1), ija__(2), matrix1%desc, &
3016 : : matrix2%buffer_cplx, ijb__(1), ijb__(2), matrix2%desc, &
3017 : : beta, results%buffer_cplx, ijc__(1), ijc__(2), results%desc)
3018 : : else
3019 : : call PDGEMM(transa, transb, mm, nn, kk, real(alpha, kind=dp), &
3020 : : matrix1%buffer_cplx, ija__(1), ija__(2), matrix1%desc, &
3021 : : matrix2%buffer_cplx, ijb__(1), ijb__(2), matrix2%desc, &
3022 : : real(beta, kind=dp), results%buffer_cplx, ijc__(1), ijc__(2), results%desc)
3023 : : end if
3024 : : #endif
3025 : :
3026 : 0 : end subroutine slk_pgemm_dp
3027 : : !!***
3028 : :
3029 : : !----------------------------------------------------------------------
3030 : :
3031 : : !!****f* m_slk/slk_pgemm_sp
3032 : : !! NAME
3033 : : !! slk_pgemm_sp
3034 : : !!
3035 : : !! FUNCTION
3036 : : !! Extended matrix * matrix product: C := alpha*A*B + beta*C
3037 : : !! For a simple matrix vector product, one can simply pass alpha = cone and beta = czero
3038 : : !!
3039 : : !! INPUTS
3040 : : !! matrix1= first ScaLAPACK matrix (matrix A)
3041 : : !! matrix2= second ScaLAPACK matrix (matrix B)
3042 : : !! alpha= scalar multiplicator for the A*B product
3043 : : !! beta= scalar multiplicator for the C matrix
3044 : : !! [ija, ijb, ijc]: (global). The row and column indices in the distributed matrix A/B/C
3045 : : !! indicating the first row and the first column of the submatrix, respectively. Default [1, 1]
3046 : : !!
3047 : : !! OUTPUT
3048 : : !! results= ScaLAPACK matrix coming out of the operation
3049 : : !!
3050 : : !! NOTES
3051 : : !! The ESLL manual says that
3052 : : !! "matrices matrix1 and matrix2 must have no common elements otherwise, results are unpredictable."
3053 : : !! However the official scaLAPACK documentation does not report this (severe) limitation.
3054 : : !!
3055 : : !! SOURCE
3056 : :
3057 : 0 : subroutine slk_pgemm_sp(transa, transb, matrix1, alpha, matrix2, beta, results, &
3058 : : ija, ijb, ijc) ! optional
3059 : :
3060 : : !Arguments ------------------------------------
3061 : : character(len=1),intent(in) :: transa, transb
3062 : : class(slkmat_sp_t),intent(in) :: matrix1, matrix2
3063 : : class(slkmat_sp_t),intent(inout) :: results
3064 : : complex(sp),intent(in) :: alpha, beta
3065 : : integer,optional,intent(in) :: ija(2), ijb(2), ijc(2)
3066 : :
3067 : : !Local variables-------------------------------
3068 : : integer :: mm, nn, kk, ija__(2), ijb__(2), ijc__(2)
3069 : : !************************************************************************
3070 : :
3071 : 0 : ija__ = [1, 1]; if (present(ija)) ija__ = ija
3072 : 0 : ijb__ = [1, 1]; if (present(ijb)) ijb__ = ijb
3073 : 0 : ijc__ = [1, 1]; if (present(ijc)) ijc__ = ijc
3074 : :
3075 : 0 : mm = matrix1%size_global(1)
3076 : 0 : nn = matrix2%size_global(2)
3077 : 0 : kk = matrix1%size_global(2)
3078 : :
3079 : 0 : if (toupper(transa) /= 'N') then
3080 : : mm = matrix1%size_global(2)
3081 : 0 : kk = matrix1%size_global(1)
3082 : : end if
3083 : 0 : if (toupper(transb) /= 'N') nn = matrix2%size_global(1)
3084 : :
3085 : : #ifdef HAVE_LINALG_SCALAPACK
3086 : : ! pzgemm(transa, transb, m, n, k, alpha, a, ia, ja, desca, b, ib, jb, descb, beta, c, ic, jc, descc)
3087 : : if (matrix1%istwf_k /= 2) then
3088 : : call PCGEMM(transa, transb, mm, nn, kk, alpha, &
3089 : : matrix1%buffer_cplx, ija__(1), ija__(2), matrix1%desc, &
3090 : : matrix2%buffer_cplx, ijb__(1), ijb__(2), matrix2%desc, &
3091 : : beta, results%buffer_cplx, ijc__(1), ijc__(2), results%desc)
3092 : : else
3093 : : call PSGEMM(transa, transb, mm, nn, kk, real(alpha, kind=sp), &
3094 : : matrix1%buffer_cplx, ija__(1), ija__(2), matrix1%desc, &
3095 : : matrix2%buffer_cplx, ijb__(1), ijb__(2), matrix2%desc, &
3096 : : real(beta, kind=sp), results%buffer_cplx, ijc__(1), ijc__(2), results%desc)
3097 : : end if
3098 : : #endif
3099 : :
3100 : 0 : end subroutine slk_pgemm_sp
3101 : : !!***
3102 : :
3103 : : !----------------------------------------------------------------------
3104 : :
3105 : : !!****f* m_slk/compute_eigen_problem
3106 : : !! NAME
3107 : : !! compute_eigen_problem
3108 : : !!
3109 : : !! FUNCTION
3110 : : !! Calculation of eigenvalues and eigenvectors: A * X = lambda * X, complex and real cases.
3111 : : !!
3112 : : !! INPUTS
3113 : : !! processor= descriptor of a processor
3114 : : !! matrix= the matrix to process
3115 : : !! comm= MPI communicator
3116 : : !! istwf_k= 2 if we have a real matrix else complex.
3117 : : !! [nev]= Number of eigenvalues needed. Default: full set
3118 : : !! [use_gpu_elpa]= Flag to activate the use of GPU (ELPA only)
3119 : : !!
3120 : : !! OUTPUT
3121 : : !! results= ScaLAPACK matrix coming out of the operation (global dimensions must be equal to matrix
3122 : : !! even if only a part of the eigenvectors is needed.
3123 : : !! eigen= eigenvalues of the matrix dimensioned as the global size of the square matrix
3124 : : !! even if only a part of the eigenvalues is needed.
3125 : : !!
3126 : : !! SOURCE
3127 : :
3128 : 0 : subroutine compute_eigen_problem(processor, matrix, results, eigen, comm, istwf_k, &
3129 : : nev, use_gpu_elpa) ! Optional arguments
3130 : :
3131 : : !Arguments ------------------------------------
3132 : : class(slk_processor_t),intent(in) :: processor
3133 : : class(slkmat_dp_t),intent(inout) :: matrix
3134 : : class(slkmat_dp_t),intent(inout) :: results
3135 : : DOUBLE PRECISION,intent(inout) :: eigen(:)
3136 : : integer,intent(in) :: comm,istwf_k
3137 : : integer,optional,intent(in) :: nev
3138 : : integer,optional,intent(in) :: use_gpu_elpa
3139 : :
3140 : : #if defined(HAVE_LINALG_ELPA)
3141 : : !Local variables ------------------------------
3142 : : type(elpa_hdl_t) :: elpa_hdl
3143 : : integer :: nev__,use_gpu_elpa_
3144 : : !************************************************************************
3145 : :
3146 : : nev__ = matrix%size_global(1); if (present(nev)) nev__ = nev
3147 : : use_gpu_elpa_=0; if (present(use_gpu_elpa)) use_gpu_elpa_=use_gpu_elpa
3148 : :
3149 : : call elpa_func_allocate(elpa_hdl,gpu=use_gpu_elpa_)
3150 : : call elpa_func_set_matrix(elpa_hdl,matrix%size_global(1),matrix%size_blocs(1),nev__,&
3151 : : matrix%size_local(1),matrix%size_local(2))
3152 : : call elpa_func_get_communicators(elpa_hdl,processor%comm,processor%coords(1),processor%coords(2))
3153 : :
3154 : : if (istwf_k/=2) then
3155 : : call elpa_func_solve_evp_1stage(elpa_hdl,matrix%buffer_cplx,results%buffer_cplx,eigen,nev__)
3156 : : else
3157 : : call elpa_func_solve_evp_1stage(elpa_hdl,matrix%buffer_real,results%buffer_real,eigen,nev__)
3158 : : end if
3159 : :
3160 : : call elpa_func_deallocate(elpa_hdl)
3161 : :
3162 : :
3163 : : #elif defined(HAVE_LINALG_SLATE)
3164 : : !Local variables-------------------------------
3165 : : integer :: nev__,use_gpu_elpa_, info_slate
3166 : : ! *************************************************************************
3167 : :
3168 : : if (istwf_k /= 2) then
3169 : : call slate_zheev_c( &
3170 : : matrix%size_global(1), & ! n
3171 : : matrix%size_blocs(1), & ! nb (mb==nb required)
3172 : : processor%grid%dims(1), & ! nprow
3173 : : processor%grid%dims(2), & ! npcol
3174 : : processor%comm, & ! Fortran MPI comm handle
3175 : : matrix%size_local(1), & ! lda
3176 : : matrix%buffer_cplx, & ! a_data (destroyed on exit)
3177 : : results%size_local(1), & ! ldz
3178 : : results%buffer_cplx, & ! z_data (eigenvectors out)
3179 : : eigen, & ! w (eigenvalues out)
3180 : : nev__, & ! nev
3181 : : use_gpu_elpa_, & ! use_gpu (reuse existing flag)
3182 : : info_slate)
3183 : : ABI_CHECK(info_slate == 0, "slate_zheev_c failed")
3184 : : else
3185 : : call slate_dsyev_c( &
3186 : : matrix%size_global(1), & ! n
3187 : : matrix%size_blocs(1), & ! nb (mb==nb required)
3188 : : processor%grid%dims(1), & ! nprow
3189 : : processor%grid%dims(2), & ! npcol
3190 : : processor%comm, & ! Fortran MPI comm handle
3191 : : matrix%size_local(1), & ! lda
3192 : : matrix%buffer_real, & ! a_data (destroyed on exit)
3193 : : results%size_local(1), & ! ldz
3194 : : results%buffer_real, & ! z_data (eigenvectors out)
3195 : : eigen, & ! w (eigenvalues out)
3196 : : nev__, & ! nev
3197 : : use_gpu_elpa_, & ! use_gpu (reuse existing flag)
3198 : : info_slate)
3199 : : ABI_CHECK(info_slate == 0, "slate_dsyev_c failed")
3200 : : end if
3201 : :
3202 : :
3203 : : #elif defined(HAVE_LINALG_SCALAPACK)
3204 : : !Local variables-------------------------------
3205 : : integer :: LRWORK,LIWORK,LCWORK,INFO
3206 : : !character(len=500) :: msg
3207 : : integer , dimension(1) :: IWORK_tmp
3208 : : DOUBLE PRECISION, dimension(1) :: RWORK_tmp
3209 : : complex(dpc) , dimension(1) :: CWORK_tmp
3210 : : integer , allocatable :: IWORK(:)
3211 : : DOUBLE PRECISION, allocatable :: RWORK(:)
3212 : : complex(dpc) , allocatable :: CWORK(:)
3213 : : integer, allocatable :: ICLUSTR(:)
3214 : : integer, allocatable :: IFAIL(:)
3215 : : DOUBLE PRECISION, allocatable :: GAP(:)
3216 : : DOUBLE PRECISION :: ABSTOL,ORFAC
3217 : : integer, parameter :: IZERO=0
3218 : : integer :: M,NZ,ierr,TWORK_tmp(3),TWORK(3) ! IA,JA,IZ,JZ,
3219 : : integer :: nev__, il, iu, use_gpu_elpa_
3220 : : character(len=1) :: range
3221 : : ! *************************************************************************
3222 : :
3223 : : ABI_UNUSED(use_gpu_elpa) ! No GPU implementation if using scaLAPACK
3224 : : use_gpu_elpa_=0; if (present(use_gpu_elpa)) use_gpu_elpa_=use_gpu_elpa
3225 : : nev__ = matrix%size_global(1); range = "A"; il = 0; iu = 0
3226 : : if (present(nev)) then
3227 : : nev__ = nev; range = "I"; il = 1; iu = nev
3228 : : end if
3229 : :
3230 : : ! Initialisation
3231 : : INFO = 0
3232 : : ABSTOL = zero
3233 : : ORFAC = -1.D+0
3234 : :
3235 : : ! Allocation of the variables for the results of the calculations
3236 : : ABI_MALLOC(IFAIL,(matrix%size_global(2)))
3237 : : ABI_MALLOC(ICLUSTR,(2*processor%grid%dims(1)*processor%grid%dims(2)))
3238 : : ABI_MALLOC(GAP,(processor%grid%dims(1)*processor%grid%dims(2)))
3239 : :
3240 : : CWORK_tmp = (0.0_DP,0.0_DP)
3241 : : RWORK_tmp = 0.0_DP
3242 : : ! Get the size of the work arrays
3243 : : if (istwf_k/=2) then
3244 : : call PZHEEVX('V', range, 'U',&
3245 : : matrix%size_global(2),&
3246 : : matrix%buffer_cplx,1,1,matrix%desc, &
3247 : : ZERO,ZERO,il,iu,ABSTOL,&
3248 : : m,nz,eigen,ORFAC, &
3249 : : results%buffer_cplx,1,1,results%desc, &
3250 : : CWORK_tmp,-1,RWORK_tmp,-1,IWORK_tmp,-1,&
3251 : : IFAIL,ICLUSTR,GAP,INFO)
3252 : : else
3253 : : call PDSYEVX('V', range, 'U',&
3254 : : matrix%size_global(2),&
3255 : : matrix%buffer_real,1,1,matrix%desc, &
3256 : : ZERO,ZERO,il,iu,ABSTOL,&
3257 : : m,nz,eigen,ORFAC, &
3258 : : results%buffer_real,1,1,results%desc, &
3259 : : RWORK_tmp,-1,IWORK_tmp,-1,&
3260 : : IFAIL,ICLUSTR,GAP,INFO)
3261 : : end if
3262 : :
3263 : : if (INFO/=0) then
3264 : : ABI_ERROR(sjoin("Problem to compute workspace to use ScaLAPACK, INFO: ", itoa(INFO)))
3265 : : endif
3266 : : !write(std_out, *)"First call to compute workspace OK"
3267 : :
3268 : : TWORK_tmp(1) = IWORK_tmp(1)
3269 : : TWORK_tmp(2) = INT(RWORK_tmp(1))
3270 : : TWORK_tmp(3) = INT(real(CWORK_tmp(1)))
3271 : :
3272 : : ! Get the maximum of the size of the work arrays processor%comm
3273 : : call MPI_ALLREDUCE(TWORK_tmp,TWORK,3,MPI_integer,MPI_MAX,comm,ierr)
3274 : :
3275 : : LIWORK = TWORK(1)
3276 : : LRWORK = TWORK(2) + matrix%size_global(2) *(matrix%size_global(2)-1)
3277 : : LCWORK = TWORK(3)
3278 : :
3279 : : ! Allocation of the work arrays
3280 : : if (LIWORK>0) then
3281 : : ABI_MALLOC(IWORK,(LIWORK))
3282 : : IWORK(:) = 0
3283 : : else
3284 : : ABI_MALLOC(IWORK,(1))
3285 : : end if
3286 : : if (LRWORK>0) then
3287 : : ! This workspace scales with the number of processors but not always in a simple linear way.
3288 : : ! and the optimal LRWORK might be pretty big (~1 Gb) even for small systems.
3289 : : ABI_MALLOC(RWORK,(LRWORK))
3290 : : RWORK(:) = 0._dp
3291 : : else
3292 : : ABI_MALLOC(RWORK,(1))
3293 : : end if
3294 : : if (LCWORK>0) then
3295 : : ABI_MALLOC(CWORK,(LCWORK))
3296 : : CWORK(:) = (0._dp,0._dp)
3297 : : else
3298 : : ABI_MALLOC(CWORK,(1))
3299 : : end if
3300 : :
3301 : : ! prototype
3302 : : !call pzheevx(jobz, range, uplo, n, a, ia, ja, desca, vl, vu, il, iu, abstol, m, nz, w,
3303 : : ! orfac, z, iz, jz, descz, work, lwork, rwork, lrwork, iwork, liwork, ifail, iclustr, gap, info)
3304 : :
3305 : : ! Call the calculation routine
3306 : : if (istwf_k/=2) then
3307 : : ! write(std_out,*) 'I am using PZHEEVX'
3308 : : call PZHEEVX('V', range, 'U',&
3309 : : matrix%size_global(2),&
3310 : : matrix%buffer_cplx,1,1,matrix%desc, &
3311 : : ZERO,ZERO,il,iu,ABSTOL,&
3312 : : m,nz,eigen,ORFAC, &
3313 : : results%buffer_cplx,1,1,results%desc, &
3314 : : CWORK,LCWORK,RWORK,LRWORK,IWORK,LIWORK,&
3315 : : IFAIL,ICLUSTR,GAP,INFO)
3316 : : else
3317 : : ! write(std_out,*) ' I am using PDSYEVX'
3318 : : call PDSYEVX('V', range, 'U',&
3319 : : matrix%size_global(2),&
3320 : : matrix%buffer_real,1,1,matrix%desc, &
3321 : : ZERO,ZERO,il,iu,ABSTOL,&
3322 : : m,nz,eigen,ORFAC, &
3323 : : results%buffer_real,1,1,results%desc, &
3324 : : RWORK,LRWORK,IWORK,LIWORK,&
3325 : : IFAIL,ICLUSTR,GAP,INFO)
3326 : : endif
3327 : :
3328 : : ! MG: TODO: Recheck the computation of the workspace as I got INFO 2 with a 5x5x5 si supercell.
3329 : : if (INFO/=0) then
3330 : : ABI_ERROR(sjoin("Problem to compute eigenvalues and eigenvectors with ScaLAPACK, INFO:", itoa(INFO)))
3331 : : endif
3332 : :
3333 : : ABI_FREE(IFAIl)
3334 : : ABI_FREE(ICLUSTR)
3335 : : ABI_FREE(GAP)
3336 : : ABI_SFREE(IWORK)
3337 : : ABI_SFREE(RWORK)
3338 : : ABI_SFREE(CWORK)
3339 : : #endif
3340 : 0 : return
3341 : :
3342 : : end subroutine compute_eigen_problem
3343 : : !!***
3344 : :
3345 : : !----------------------------------------------------------------------
3346 : :
3347 : : !!****f* m_slk/solve_gevp_complex
3348 : : !! NAME
3349 : : !! solve_gevp_complex
3350 : : !!
3351 : : !! FUNCTION
3352 : : !! Calculation of eigenvalues and eigenvectors: A * X = lambda * B * X
3353 : : !! complex and real cases.
3354 : : !!
3355 : : !! INPUTS
3356 : : !! processor= descriptor of a processor
3357 : : !! matrix1= first ScaLAPACK matrix (matrix A)
3358 : : !! matrix2= second ScaLAPACK matrix (matrix B)
3359 : : !! comm= MPI communicator
3360 : : !! istwf_k= 2 if we have a real matrix else complex.
3361 : : !! [use_gpu_elpa]= Flag to activate the use of GPU (ELPA only)
3362 : : !!
3363 : : !! SIDE EFFECTS
3364 : : !! results= ScaLAPACK matrix coming out of the operation
3365 : : !! eigen= eigenvalues of the matrix
3366 : : !!
3367 : : !! SOURCE
3368 : :
3369 : : #ifdef HAVE_LINALG_ELPA
3370 : :
3371 : : subroutine solve_gevp_complex(na,nev,na_rows,na_cols,nblk,a,b,ev,z,tmp1,tmp2, &
3372 : : my_prow,my_pcol,np_rows,np_cols,sc_desc,comm,&
3373 : : use_gpu_elpa) ! Optional parameter
3374 : :
3375 : : !-Arguments
3376 : : integer,intent(in) :: na
3377 : : integer,intent(in) :: nev
3378 : : integer,intent(in) :: na_rows,na_cols
3379 : : integer,intent(in) :: nblk
3380 : : integer,intent(in) :: my_pcol,my_prow
3381 : : integer,intent(in) :: np_cols,np_rows
3382 : : integer,intent(in) :: sc_desc(9)
3383 : : integer,intent(in) :: comm
3384 : : integer,optional,intent(in) :: use_gpu_elpa
3385 : : real*8 :: ev(na)
3386 : : complex*16 :: a(na_rows,na_cols),b(na_rows,na_cols),z(na_rows,na_cols)
3387 : : complex*16 :: tmp1(na_rows,na_cols),tmp2(na_rows,na_cols)
3388 : : !-Local variables
3389 : : integer :: i, n_col, n_row, use_gpu_elpa_
3390 : : complex*16, parameter :: CZERO = (0.d0,0.d0), CONE = (1.d0,0.d0)
3391 : : type(elpa_hdl_t) :: elpa_hdl
3392 : : ! *************************************************************************
3393 : :
3394 : : use_gpu_elpa_=0
3395 : : #ifdef HAVE_LINALG_ELPA
3396 : : if (present(use_gpu_elpa)) use_gpu_elpa_=use_gpu_elpa
3397 : : #endif
3398 : :
3399 : : ! Allocate ELPA handle
3400 : : call elpa_func_allocate(elpa_hdl,blacs_ctx=sc_desc(CTXT_),gpu=use_gpu_elpa_)
3401 : : call elpa_func_set_matrix(elpa_hdl,na,nblk,nev,na_rows,na_cols)
3402 : : call elpa_func_get_communicators(elpa_hdl,comm,my_prow,my_pcol)
3403 : : call elpa_func_solve_gevp_2stage(elpa_hdl,a,b,z,ev,nev)
3404 : : call elpa_func_deallocate(elpa_hdl)
3405 : :
3406 : : end subroutine solve_gevp_complex
3407 : :
3408 : : !----------------------------------------------------------------------
3409 : :
3410 : : subroutine solve_gevp_real(na,nev,na_rows,na_cols,nblk,a,b,ev,z,tmp1,tmp2, &
3411 : : my_prow,my_pcol,np_rows,np_cols,sc_desc,comm, &
3412 : : use_gpu_elpa) ! Optional argument
3413 : :
3414 : : !-Arguments
3415 : : integer,intent(in) :: na
3416 : : integer,intent(in) :: nev
3417 : : integer,intent(in) :: na_rows,na_cols
3418 : : integer,intent(in) :: nblk
3419 : : integer,intent(in) :: my_pcol,my_prow
3420 : : integer,intent(in) :: np_cols,np_rows
3421 : : integer,intent(in) :: sc_desc(9)
3422 : : integer,intent(in) :: comm
3423 : : integer,optional,intent(in) :: use_gpu_elpa
3424 : : real*8 :: ev(na)
3425 : : real*8 :: a(na_rows,na_cols),b(na_rows,na_cols),z(na_rows,na_cols)
3426 : : real*8 :: tmp1(na_rows,na_cols),tmp2(na_rows,na_cols)
3427 : : !-Local variables
3428 : : integer :: i, n_col, n_row, use_gpu_elpa_
3429 : : type(elpa_hdl_t) :: elpa_hdl
3430 : : ! *************************************************************************
3431 : :
3432 : : use_gpu_elpa_=0
3433 : : #ifdef HAVE_LINALG_ELPA
3434 : : if (present(use_gpu_elpa)) use_gpu_elpa_=use_gpu_elpa
3435 : : #endif
3436 : :
3437 : : ! Allocate ELPA handle
3438 : : call elpa_func_allocate(elpa_hdl,blacs_ctx=sc_desc(CTXT_),gpu=use_gpu_elpa_)
3439 : : call elpa_func_set_matrix(elpa_hdl,na,nblk,nev,na_rows,na_cols)
3440 : : call elpa_func_get_communicators(elpa_hdl,comm,my_prow,my_pcol)
3441 : :
3442 : : !FIXME Need to figure out why generalized_eigenvectors doesn't work in this real case
3443 : : ! while it is fine with complex case
3444 : : if(.false.) then
3445 : : call elpa_func_solve_gevp_2stage(elpa_hdl,a,b,tmp1,ev,nev)
3446 : : else
3447 : : ! 1. Calculate Cholesky factorization of Matrix B = U**T * U
3448 : : ! and invert triangular matrix U
3449 : : call elpa_func_cholesky(elpa_hdl,b)
3450 : : call elpa_func_invert_triangular(elpa_hdl,b)
3451 : : ! 2. Calculate U**-T * A * U**-1
3452 : : ! 2a. tmp1 = U**-T * A
3453 : : call elpa_func_hermitian_multiply(elpa_hdl,'U','L',na,b,a,na_rows,na_cols,tmp1,na_rows,na_cols)
3454 : : ! 2b. tmp2 = tmp1**T
3455 : : call pdtran(na,na,1.d0,tmp1,1,1,sc_desc,0.d0,tmp2,1,1,sc_desc)
3456 : : ! 2c. A = U**-T * tmp2 ( = U**-T * Aorig * U**-1 )
3457 : : call elpa_func_hermitian_multiply(elpa_hdl,'U','U',na,b,tmp2,na_rows,na_cols,a,na_rows,na_cols)
3458 : : ! A is only set in the upper half, solve_evp_real needs a full matrix
3459 : : ! Set lower half from upper half
3460 : : call pdtran(na,na,1.d0,a,1,1,sc_desc,0.d0,tmp1,1,1,sc_desc)
3461 : : do i=1,na_cols
3462 : : ! Get global column corresponding to i and number of local rows up to
3463 : : ! and including the diagonal, these are unchanged in A
3464 : : n_col = indxl2g(i, nblk, my_pcol, 0, np_cols)
3465 : : n_row = numroc (n_col, nblk, my_prow, 0, np_rows)
3466 : : a(n_row+1:na_rows,i) = tmp1(n_row+1:na_rows,i)
3467 : : enddo
3468 : : ! 3. Calculate eigenvalues/eigenvectors of U**-T * A * U**-1
3469 : : ! Eigenvectors go to tmp1
3470 : : call elpa_func_solve_evp_1stage(elpa_hdl,a,tmp1,ev,nev)
3471 : : ! 4. Backtransform eigenvectors: Z = U**-1 * tmp1
3472 : : ! hermitian_multiply needs the transpose of U**-1, thus tmp2 = (U**-1)**T
3473 : : call pdtran(na,na,1.d0,b,1,1,sc_desc,0.d0,tmp2,1,1,sc_desc)
3474 : : call elpa_func_hermitian_multiply(elpa_hdl,'L','N',nev,tmp2,tmp1,na_rows,na_cols,z,na_rows,na_cols)
3475 : : end if
3476 : :
3477 : : call elpa_func_deallocate(elpa_hdl)
3478 : :
3479 : : end subroutine solve_gevp_real
3480 : : !!***
3481 : : #endif
3482 : :
3483 : : !----------------------------------------------------------------------
3484 : :
3485 : : !!****f* m_slk/compute_generalized_eigen_problem
3486 : : !! NAME
3487 : : !! compute_generalized_eigen_problem
3488 : : !!
3489 : : !! FUNCTION
3490 : : !! Calculation of eigenvalues and eigenvectors of the generalized eigenvalue problem: A * X = lambda * B X
3491 : : !! complex and real cases.
3492 : : !!
3493 : : !! INPUTS
3494 : : !! processor= descriptor of a processor
3495 : : !! matrix1= A matrix
3496 : : !! matrix2= B matrix
3497 : : !! comm= MPI communicator
3498 : : !! istwf_k= 2 if we have a real matrix else complex.
3499 : : !! [nev]= Number of eigenvalues needed. Default: full set
3500 : : !! [use_gpu_elpa]= Flag to activate the use of GPU (ELPA only)
3501 : : !!
3502 : : !! OUTPUT
3503 : : !! results= ScaLAPACK matrix coming out of the operation (global dimensions must be equal to matrix
3504 : : !! even if only a part of the eigenvectors is needed.
3505 : : !! eigen= eigenvalues of the matrix dimensioned as the global size of the square matrix
3506 : : !! even if only a part of the eigenvalues is needed.
3507 : : !!
3508 : : !! SOURCE
3509 : :
3510 : 0 : subroutine compute_generalized_eigen_problem(processor,matrix1,matrix2,results,eigen,comm,istwf_k,&
3511 : : nev,use_gpu_elpa) ! Optional arguments
3512 : :
3513 : : !Arguments ------------------------------------
3514 : : class(slk_processor_t),intent(in) :: processor
3515 : : class(slkmat_dp_t),intent(inout) :: matrix1,matrix2
3516 : : class(slkmat_dp_t),intent(inout) :: results
3517 : : DOUBLE PRECISION,intent(inout) :: eigen(:)
3518 : : integer,intent(in) :: comm,istwf_k
3519 : : integer,optional,intent(in) :: nev
3520 : : integer,optional,intent(in) :: use_gpu_elpa
3521 : : #ifdef HAVE_LINALG_ELPA
3522 : : !Local
3523 : : type(slkmat_dp_t) :: tmp1, tmp2
3524 : : integer :: i,n_col, n_row, nev__,use_gpu_elpa__
3525 : :
3526 : : nev__ = matrix1%size_global(2); if (present(nev)) nev__ = nev
3527 : : use_gpu_elpa__ = 0; if (present(use_gpu_elpa)) use_gpu_elpa__ = use_gpu_elpa
3528 : :
3529 : : call tmp1%init(matrix1%size_global(1),matrix1%size_global(2),processor,istwf_k)
3530 : : call tmp2%init(matrix1%size_global(1),matrix1%size_global(2),processor,istwf_k)
3531 : :
3532 : : if (istwf_k/=2) then
3533 : : call solve_gevp_complex(matrix1%size_global(1), nev__, &
3534 : : matrix1%size_local(1),matrix1%size_local(2),matrix1%size_blocs(1), &
3535 : : matrix1%buffer_cplx,matrix2%buffer_cplx,eigen,results%buffer_cplx, &
3536 : : tmp1%buffer_cplx,tmp2%buffer_cplx, &
3537 : : processor%coords(1),processor%coords(2), &
3538 : : processor%grid%dims(1),processor%grid%dims(2), &
3539 : : matrix1%desc,processor%comm,use_gpu_elpa=use_gpu_elpa__)
3540 : : else
3541 : : call solve_gevp_real(matrix1%size_global(1), nev__, &
3542 : : matrix1%size_local(1),matrix1%size_local(2),matrix1%size_blocs(1), &
3543 : : matrix1%buffer_real,matrix2%buffer_real,eigen,results%buffer_real, &
3544 : : tmp1%buffer_real,tmp2%buffer_real, &
3545 : : processor%coords(1),processor%coords(2), &
3546 : : processor%grid%dims(1),processor%grid%dims(2), &
3547 : : matrix1%desc,processor%comm,use_gpu_elpa=use_gpu_elpa__)
3548 : : end if
3549 : : call tmp1%free()
3550 : : call tmp2%free()
3551 : :
3552 : :
3553 : : !#elif defined HAVE_LINALG_SLATE
3554 : : !!FIXME Doesn't work. slate_zheev/syev is fine though so we fall back to scaLAPACK instead
3555 : : !!Local variables-------------------------------
3556 : : ! integer :: nev__, use_gpu_elpa_, info_slate
3557 : : !! *************************************************************************
3558 : : !
3559 : : ! nev__ = matrix1%size_global(2); if (present(nev)) nev__ = nev
3560 : : ! use_gpu_elpa__ = 0; if (present(use_gpu_elpa)) use_gpu_elpa__ = use_gpu_elpa
3561 : : !
3562 : : ! if (istwf_k /= 2) then
3563 : : ! call slate_zhegv_c( &
3564 : : ! matrix1%size_global(1), & ! n
3565 : : ! matrix1%size_blocs(1), & ! nb (mb==nb required)
3566 : : ! processor%grid%dims(1), & ! nprow
3567 : : ! processor%grid%dims(2), & ! npcol
3568 : : ! processor%comm, & ! Fortran MPI comm handle
3569 : : ! matrix1%size_local(1), & ! lda
3570 : : ! matrix1%buffer_cplx, & ! a_data (destroyed on exit)
3571 : : ! matrix2%size_local(1), & ! ldb
3572 : : ! matrix2%buffer_cplx, & ! b_data (destroyed on exit)
3573 : : ! results%size_local(1), & ! ldz
3574 : : ! results%buffer_cplx, & ! z_data (eigenvectors out)
3575 : : ! eigen, & ! w (eigenvalues out)
3576 : : ! nev__, & ! nev
3577 : : ! use_gpu_elpa_, & ! use_gpu (reuse existing flag)
3578 : : ! info_slate)
3579 : : ! ABI_CHECK(info_slate == 0, "slate_zhgev_c failed")
3580 : : ! else
3581 : : ! call slate_dsygv_c( &
3582 : : ! matrix1%size_global(1), & ! n
3583 : : ! matrix1%size_blocs(1), & ! nb (mb==nb required)
3584 : : ! processor%grid%dims(1), & ! nprow
3585 : : ! processor%grid%dims(2), & ! npcol
3586 : : ! processor%comm, & ! Fortran MPI comm handle
3587 : : ! matrix1%size_local(1), & ! lda
3588 : : ! matrix1%buffer_real, & ! a_data (destroyed on exit)
3589 : : ! matrix2%size_local(1), & ! ldb
3590 : : ! matrix2%buffer_real, & ! b_data (destroyed on exit)
3591 : : ! results%size_local(1), & ! ldz
3592 : : ! results%buffer_real, & ! z_data (eigenvectors out)
3593 : : ! eigen, & ! w (eigenvalues out)
3594 : : ! nev__, & ! nev
3595 : : ! use_gpu_elpa_, & ! use_gpu (reuse existing flag)
3596 : : ! info_slate)
3597 : : ! ABI_CHECK(info_slate == 0, "slate_dsygv_c failed")
3598 : : ! end if
3599 : :
3600 : :
3601 : : #elif defined(HAVE_LINALG_SCALAPACK)
3602 : : !Local variables-------------------------------
3603 : : integer :: LRWORK,LIWORK,LCWORK,INFO
3604 : : !character(len=500) :: msg
3605 : : integer , dimension(1) :: IWORK_tmp
3606 : : DOUBLE PRECISION, dimension(1) :: RWORK_tmp
3607 : : complex(dpc) , dimension(1) :: CWORK_tmp
3608 : :
3609 : : integer , allocatable :: IWORK(:)
3610 : : DOUBLE PRECISION, allocatable :: RWORK(:)
3611 : : complex(dpc) , allocatable :: CWORK(:)
3612 : : integer, allocatable :: ICLUSTR(:)
3613 : : integer, allocatable :: IFAIL(:)
3614 : : DOUBLE PRECISION, allocatable :: GAP(:)
3615 : : DOUBLE PRECISION :: ABSTOL,ORFAC
3616 : : integer , parameter :: IZERO=0
3617 : : integer :: M,NZ,ierr,TWORK_tmp(3),TWORK(3) ! IA,JA,IZ,JZ,
3618 : : character(len=1) :: range
3619 : : integer :: nev__, il, iu
3620 : : ! *************************************************************************
3621 : :
3622 : : ABI_UNUSED(use_gpu_elpa) ! No GPU implementation is using scaLAPACK
3623 : : nev__ = matrix1%size_global(2); range = "A"; il = 0; iu = 0
3624 : : if (present(nev)) then
3625 : : nev__ = nev; range = "I"; il = 1; iu = nev
3626 : : end if
3627 : :
3628 : : ! Initialisation
3629 : : INFO = 0
3630 : : ABSTOL = zero
3631 : : ORFAC = -1.D+0
3632 : :
3633 : : ! Allocate the arrays for the results of the calculation
3634 : : ABI_MALLOC(IFAIL ,(matrix1%size_global(2)))
3635 : : ABI_MALLOC(ICLUSTR,(2*processor%grid%dims(1)*processor%grid%dims(2)))
3636 : : ABI_MALLOC(GAP ,( processor%grid%dims(1)*processor%grid%dims(2)))
3637 : :
3638 : : CWORK_tmp = (0.0_DP,0.0_DP)
3639 : : RWORK_tmp = 0.0_DP
3640 : : ! Get the size of the work arrays
3641 : : if (istwf_k /= 2) then
3642 : : call PZHEGVX(1, 'V', range, 'U',&
3643 : : matrix1%size_global(2),&
3644 : : matrix1%buffer_cplx,1,1,matrix1%desc, &
3645 : : matrix2%buffer_cplx,1,1,matrix2%desc, &
3646 : : ZERO,ZERO,il,iu,ABSTOL,&
3647 : : m,nz,eigen,ORFAC, &
3648 : : results%buffer_cplx,1,1,results%desc, &
3649 : : CWORK_tmp,-1,RWORK_tmp,-1,IWORK_tmp,-1,&
3650 : : IFAIL,ICLUSTR,GAP,INFO)
3651 : : else
3652 : : call PDSYGVX(1,'V',range,'U',&
3653 : : matrix1%size_global(2),&
3654 : : matrix1%buffer_real,1,1,matrix1%desc, &
3655 : : matrix2%buffer_real,1,1,matrix2%desc, &
3656 : : ZERO,ZERO,il,iu,ABSTOL,&
3657 : : m,nz,eigen,ORFAC, &
3658 : : results%buffer_real,1,1,results%desc, &
3659 : : RWORK_tmp,-1,IWORK_tmp,-1,&
3660 : : IFAIL,ICLUSTR,GAP,INFO)
3661 : : endif
3662 : :
3663 : : if (INFO/=0) then
3664 : : ABI_ERROR(sjoin("Problem to compute workspace to use ScaLAPACK, INFO=",itoa(INFO)))
3665 : : endif
3666 : :
3667 : : TWORK_tmp(1) = IWORK_tmp(1)
3668 : : TWORK_tmp(2) = INT(RWORK_tmp(1)) + matrix1%size_global(2) *(matrix1%size_global(2)-1)
3669 : : TWORK_tmp(3) = INT(real(CWORK_tmp(1)))
3670 : :
3671 : : ! Get the maximum of sizes of the work arrays processor%comm
3672 : : call MPI_ALLREDUCE(TWORK_tmp,TWORK,3,MPI_integer,MPI_MAX,comm,ierr)
3673 : :
3674 : : LIWORK = TWORK(1)
3675 : : LRWORK = TWORK(2)
3676 : : LCWORK = TWORK(3)
3677 : :
3678 : : ! Allocate the work arrays
3679 : : if (LIWORK>0) then
3680 : : ABI_MALLOC(IWORK,(LIWORK))
3681 : : IWORK(:) = 0
3682 : : else
3683 : : ABI_MALLOC(IWORK,(1))
3684 : : end if
3685 : : if (LRWORK>0) then
3686 : : ABI_MALLOC(RWORK,(LRWORK))
3687 : : RWORK(:) = 0._dp
3688 : : else
3689 : : ABI_MALLOC(RWORK,(1))
3690 : : end if
3691 : : if (LCWORK>0) then
3692 : : ABI_MALLOC(CWORK,(LCWORK))
3693 : : CWORK(:) = (0._dp,0._dp)
3694 : : else
3695 : : ABI_MALLOC(CWORK,(1))
3696 : : end if
3697 : :
3698 : : ! Call the calculation routine
3699 : : if (istwf_k/=2) then
3700 : : ! write(std_out,*) 'I am using PZHEGVX'
3701 : : call PZHEGVX(1,'V',range,'U',&
3702 : : matrix1%size_global(2),&
3703 : : matrix1%buffer_cplx,1,1,matrix1%desc, &
3704 : : matrix2%buffer_cplx,1,1,matrix2%desc, &
3705 : : ZERO,ZERO,il,iu,ABSTOL,&
3706 : : m,nz,eigen,ORFAC, &
3707 : : results%buffer_cplx,1,1,results%desc, &
3708 : : CWORK,LCWORK,RWORK,LRWORK,IWORK,LIWORK,&
3709 : : IFAIL,ICLUSTR,GAP,INFO)
3710 : : else
3711 : : ! write(std_out,*) 'I am using PDSYGVX'
3712 : : call PDSYGVX(1,'V',range,'U',&
3713 : : matrix1%size_global(2),&
3714 : : matrix1%buffer_real,1,1,matrix1%desc, &
3715 : : matrix2%buffer_real,1,1,matrix2%desc, &
3716 : : ZERO,ZERO,il,iu,ABSTOL,&
3717 : : m,nz,eigen,ORFAC, &
3718 : : results%buffer_real,1,1,results%desc, &
3719 : : RWORK,LRWORK,IWORK,LIWORK,&
3720 : : IFAIL,ICLUSTR,GAP,INFO)
3721 : : endif
3722 : :
3723 : : if (INFO/=0) then
3724 : : ABI_ERROR(sjoin("Problem to compute eigen problem with ScaLAPACK, INFO=", itoa(INFO)))
3725 : : endif
3726 : :
3727 : : ABI_FREE(IFAIl)
3728 : : ABI_FREE(ICLUSTR)
3729 : : ABI_FREE(GAP)
3730 : : ABI_SFREE(IWORK)
3731 : : ABI_SFREE(RWORK)
3732 : : ABI_SFREE(CWORK)
3733 : : #endif
3734 : 0 : return
3735 : :
3736 : : end subroutine compute_generalized_eigen_problem
3737 : : !!***
3738 : :
3739 : : !----------------------------------------------------------------------
3740 : :
3741 : : !!****f* m_slk/compute_eigen1
3742 : : !! NAME
3743 : : !! compute_eigen1
3744 : : !!
3745 : : !! FUNCTION
3746 : : !! Calculation of eigenvalues and eigenvectors. complex and real cases.
3747 : : !!
3748 : : !! INPUTS
3749 : : !! comm= MPI communicator
3750 : : !! cplex=1 if matrix is real, 2 if complex
3751 : : !! nbli_global number of lines
3752 : : !! nbco_global number of columns
3753 : : !! matrix= the matrix to process
3754 : : !! vector= eigenvalues of the matrix
3755 : : !! istwf_k= 2 if we have a real matrix else complex.
3756 : : !! [use_gpu_elpa]= Flag to activate the use of GPU (ELPA only)
3757 : : !!
3758 : : !! OUTPUT
3759 : : !! vector
3760 : : !!
3761 : : !! SIDE EFFECTS
3762 : : !! results= ScaLAPACK matrix coming out of the operation
3763 : : !! eigen= eigenvalues of the matrix
3764 : : !!
3765 : : !! SOURCE
3766 : :
3767 : 0 : subroutine compute_eigen1(comm,processor,cplex,nbli_global,nbco_global,matrix,vector,istwf_k,&
3768 : : use_gpu_elpa) ! Optional argument
3769 : :
3770 : : !Arguments ------------------------------------
3771 : : !scalaras
3772 : : integer,intent(in) :: comm
3773 : : integer,intent(in) :: cplex,nbli_global,nbco_global
3774 : : integer,intent(in) :: istwf_k
3775 : : class(slk_processor_t),intent(in) :: processor
3776 : : integer,intent(in),optional :: use_gpu_elpa
3777 : : !arrays
3778 : : real(dp),intent(inout) :: matrix(cplex*nbli_global,nbco_global)
3779 : : real(dp),intent(inout) :: vector(:)
3780 : :
3781 : : !Local variables-------------------------------
3782 : : #if defined(HAVE_LINALG_ELPA) || defined(HAVE_LINALG_SLATE)
3783 : : integer :: i,j
3784 : : #endif
3785 : : integer :: ierr,use_gpu_elpa_
3786 [ # # # # : 0 : type(slkmat_dp_t) :: sca_matrix1
# # ]
3787 [ # # # # : 0 : type(slkmat_dp_t) :: sca_matrix2
# # ]
3788 : 0 : real(dp),allocatable :: r_tmp_evec(:,:)
3789 : 0 : complex(dpc),allocatable :: z_tmp_evec(:,:)
3790 : : ! *************************************************************************
3791 : :
3792 : 0 : use_gpu_elpa_=0
3793 : : #if defined(HAVE_LINALG_ELPA) || defined(HAVE_LINALG_SLATE)
3794 : : if (present(use_gpu_elpa)) use_gpu_elpa_=use_gpu_elpa
3795 : : #endif
3796 : :
3797 : : ! ================================
3798 : : ! INITIALISATION SCALAPACK MATRIX
3799 : : ! ================================
3800 : 0 : call sca_matrix1%init(nbli_global,nbco_global,processor,istwf_k)
3801 : 0 : call sca_matrix2%init(nbli_global,nbco_global,processor,istwf_k)
3802 : :
3803 : : ! ==============================
3804 : : ! FILLING SCALAPACK MATRIX
3805 : : ! ==============================
3806 [ # # ]: 0 : if ( istwf_k /= 2 ) then
3807 [ # # ]: 0 : ABI_CHECK_IEQ(cplex, 2, "cplex != 2")
3808 [ # # # # : 0 : ABI_MALLOC(z_tmp_evec,(nbli_global,nbco_global))
# # # # #
# # # # #
# # ]
3809 [ # # # # ]: 0 : z_tmp_evec=cmplx(0._DP,0._DP)
3810 : : #if defined(HAVE_LINALG_ELPA) || defined(HAVE_LINALG_SLATE)
3811 : : ! The full matrix must be set (not only one half like in scalapack).
3812 : : do j=1,nbco_global
3813 : : do i=j+1,nbli_global
3814 : : matrix(2*(i-1)+1,j) = matrix(2*(j-1)+1,i)
3815 : : matrix(2*(i-1)+2,j) = -matrix(2*(j-1)+2,i)
3816 : : end do
3817 : : end do
3818 : : #endif
3819 : 0 : call sca_matrix1%from_complex_glob(matrix,istwf_k)
3820 : : else
3821 [ # # ]: 0 : ABI_CHECK_IEQ(cplex, 1, "cplex != 2")
3822 [ # # # # : 0 : ABI_MALLOC(r_tmp_evec,(nbli_global,nbco_global))
# # # # #
# # # # #
# # ]
3823 [ # # # # ]: 0 : r_tmp_evec(:,:)=0._DP
3824 : : #if defined(HAVE_LINALG_ELPA) || defined(HAVE_LINALG_SLATE)
3825 : : ! The full matrix must be set (not only one half like in scalapack).
3826 : : do j=1,nbco_global
3827 : : do i=j+1,nbli_global
3828 : : matrix(i,j) = matrix(j,i)
3829 : : end do
3830 : : end do
3831 : : #endif
3832 : 0 : call sca_matrix1%from_real_glob(matrix, istwf_k)
3833 : : endif
3834 : :
3835 : : ! ================================
3836 : : ! COMPUTE EIGEN VALUES AND VECTORS : A * X = lambda * X
3837 : : ! ================================
3838 : : call compute_eigen_problem(processor,sca_matrix1, sca_matrix2,vector, comm,istwf_k, &
3839 : 0 : use_gpu_elpa=use_gpu_elpa_)
3840 : :
3841 : : ! ==============================
3842 : : ! CONCATENATE EIGEN VECTORS
3843 : : ! ==============================
3844 : : #ifdef HAVE_MPI
3845 [ # # ]: 0 : if (istwf_k /= 2) then
3846 : 0 : call sca_matrix2%to_complex_glob(z_tmp_evec, istwf_k)
3847 : 0 : call MPI_ALLREDUCE(z_tmp_evec, matrix, nbli_global*nbco_global, MPI_DOUBLE_complex, MPI_SUM,comm,ierr)
3848 : : else
3849 : 0 : call sca_matrix2%to_real_glob(r_tmp_evec, istwf_k)
3850 : 0 : call MPI_ALLREDUCE(r_tmp_evec, matrix, nbli_global*nbco_global, MPI_DOUBLE_PRECISION, MPI_SUM,comm,ierr)
3851 : : endif
3852 : : #endif
3853 : :
3854 : : ! ====================================
3855 : : ! DESTRUCTION SCALAPACK AND TMP MATRICES
3856 : : ! ====================================
3857 : 0 : call sca_matrix1%free()
3858 : 0 : call sca_matrix2%free()
3859 : :
3860 [ # # ]: 0 : ABI_SFREE(z_tmp_evec)
3861 [ # # ]: 0 : ABI_SFREE(r_tmp_evec)
3862 : :
3863 : : #ifndef HAVE_LINALG_ELPA
3864 : : ABI_UNUSED(use_gpu_elpa)
3865 : : #endif
3866 : :
3867 [ # # # # : 0 : end subroutine compute_eigen1
# # # # #
# # # ]
3868 : : !!***
3869 : :
3870 : : !----------------------------------------------------------------------
3871 : :
3872 : : !!****f* m_slk/compute_eigen2
3873 : : !! NAME
3874 : : !! compute_eigen2
3875 : : !!
3876 : : !! FUNCTION
3877 : : !! Calculation of eigenvalues and eigenvectors: A * X = lambda * B * X
3878 : : !! complex and real cases.
3879 : : !!
3880 : : !! INPUTS
3881 : : !! comm= MPI communicator
3882 : : !! cplex=1 if matrix is real, 2 if complex
3883 : : !! nbli_global number of lines
3884 : : !! nbco_global number of columns
3885 : : !! matrix1= first ScaLAPACK matrix (matrix A)
3886 : : !! matrix2= second ScaLAPACK matrix (matrix B)
3887 : : !! vector=
3888 : : !! istwf_k= 2 if we have a real matrix else complex.
3889 : : !! [use_gpu_elpa]= Flag to activate the use of GPU (ELPA only)
3890 : : !!
3891 : : !! SIDE EFFECTS
3892 : : !! results= ScaLAPACK matrix coming out of the operation
3893 : : !! eigen= eigenvalues of the matrix
3894 : : !!
3895 : : !! SOURCE
3896 : :
3897 : 0 : subroutine compute_eigen2(comm,processor,cplex,nbli_global,nbco_global,matrix1,matrix2,vector,istwf_k, &
3898 : : use_gpu_elpa) ! Optional argument
3899 : :
3900 : : !Arguments ------------------------------------
3901 : : !scalars
3902 : : integer,intent(in) :: cplex,nbli_global,nbco_global
3903 : : integer,intent(in) :: comm
3904 : : integer,intent(in) :: istwf_k
3905 : : class(slk_processor_t),intent(in) :: processor
3906 : : integer,optional,intent(in) :: use_gpu_elpa
3907 : : !arrays
3908 : : real(dp),intent(inout) :: matrix1(cplex*nbli_global,nbco_global)
3909 : : real(dp),intent(inout) :: matrix2(cplex*nbli_global,nbco_global)
3910 : : real(dp),intent(inout) :: vector(:)
3911 : :
3912 : : !Local variables-------------------------------
3913 : : #if defined(HAVE_LINALG_ELPA) || defined(HAVE_LINALG_SLATE)
3914 : : integer :: i,j
3915 : : #endif
3916 : : integer :: ierr,use_gpu_elpa_
3917 [ # # # # : 0 : type(slkmat_dp_t) :: sca_matrix1, sca_matrix2, sca_matrix3
# # # # #
# # # # #
# # # # ]
3918 : 0 : real(dp),allocatable :: r_tmp_evec(:,:)
3919 : 0 : complex(dpc),allocatable :: z_tmp_evec(:,:)
3920 : : ! *************************************************************************
3921 : :
3922 : 0 : use_gpu_elpa_=0
3923 : : #if defined HAVE_LINALG_ELPA
3924 : : if (present(use_gpu_elpa)) use_gpu_elpa_=use_gpu_elpa
3925 : : #endif
3926 : :
3927 : : ! ================================
3928 : : ! INITIALISATION SCALAPACK MATRIX
3929 : : ! ================================
3930 : 0 : call sca_matrix1%init(nbli_global,nbco_global,processor,istwf_k)
3931 : 0 : call sca_matrix2%init(nbli_global,nbco_global,processor,istwf_k)
3932 : 0 : call sca_matrix3%init(nbli_global,nbco_global,processor,istwf_k)
3933 : :
3934 : : ! ==============================
3935 : : ! FILLING SCALAPACK MATRIX
3936 : : ! ==============================
3937 [ # # ]: 0 : if ( istwf_k /= 2 ) then
3938 [ # # ]: 0 : ABI_CHECK_IEQ(cplex, 2, "cplex != 2")
3939 [ # # # # : 0 : ABI_MALLOC(z_tmp_evec,(nbli_global,nbco_global))
# # # # #
# # # # #
# # ]
3940 [ # # # # ]: 0 : z_tmp_evec=cmplx(0._DP,0._DP)
3941 : : #if defined(HAVE_LINALG_ELPA) || defined(HAVE_LINALG_SLATE)
3942 : : ! The full matrix must be set (not only one half like in scalapack).
3943 : : do j=1,nbco_global
3944 : : do i=j+1,nbli_global
3945 : : matrix1(2*(i-1)+1,j) = matrix1(2*(j-1)+1,i)
3946 : : matrix1(2*(i-1)+2,j) = -matrix1(2*(j-1)+2,i)
3947 : : matrix2(2*(i-1)+1,j) = matrix2(2*(j-1)+1,i)
3948 : : matrix2(2*(i-1)+2,j) = -matrix2(2*(j-1)+2,i)
3949 : : end do
3950 : : end do
3951 : : #endif
3952 : 0 : call sca_matrix1%from_complex_glob(matrix1, istwf_k)
3953 : 0 : call sca_matrix2%from_complex_glob(matrix2, istwf_k)
3954 : : else
3955 [ # # ]: 0 : ABI_CHECK_IEQ(cplex, 1, "cplex != 1")
3956 [ # # # # : 0 : ABI_MALLOC(r_tmp_evec,(nbli_global,nbco_global))
# # # # #
# # # # #
# # ]
3957 [ # # # # ]: 0 : r_tmp_evec(:,:)=0._DP
3958 : : #if defined(HAVE_LINALG_ELPA) || defined(HAVE_LINALG_SLATE)
3959 : : ! The full matrix must be set (not only one half like in scalapack).
3960 : : do j=1,nbco_global
3961 : : do i=j+1,nbli_global
3962 : : matrix1(i,j) = matrix1(j,i)
3963 : : matrix2(i,j) = matrix2(j,i)
3964 : : end do
3965 : : end do
3966 : : #endif
3967 : 0 : call sca_matrix1%from_real_glob(matrix1,istwf_k)
3968 : 0 : call sca_matrix2%from_real_glob(matrix2,istwf_k)
3969 : : endif
3970 : :
3971 : : ! ================================
3972 : : ! COMPUTE EIGEN VALUES AND VECTORS : A * X = lambda * B * X
3973 : : ! ================================
3974 : : call compute_generalized_eigen_problem(processor,sca_matrix1,sca_matrix2,&
3975 : 0 : sca_matrix3,vector,comm,istwf_k,use_gpu_elpa=use_gpu_elpa_)
3976 : :
3977 : : ! ==============================
3978 : : ! CONCATENATE EIGEN VECTORS
3979 : : ! ==============================
3980 : : #ifdef HAVE_MPI
3981 [ # # ]: 0 : if ( istwf_k /= 2 ) then
3982 : 0 : call sca_matrix3%to_complex_glob(z_tmp_evec,istwf_k)
3983 : 0 : call MPI_ALLREDUCE(z_tmp_evec, matrix1, nbli_global*nbco_global, MPI_DOUBLE_complex, MPI_SUM,comm,ierr)
3984 [ # # ]: 0 : ABI_FREE(z_tmp_evec)
3985 : : else
3986 : 0 : call sca_matrix3%to_real_glob(r_tmp_evec, istwf_k)
3987 : 0 : call MPI_ALLREDUCE(r_tmp_evec, matrix1, nbli_global*nbco_global, MPI_DOUBLE_PRECISION, MPI_SUM,comm,ierr)
3988 [ # # ]: 0 : ABI_FREE(r_tmp_evec)
3989 : : endif
3990 : : #endif
3991 : :
3992 : : ! ====================================
3993 : : ! DESTRUCTION SCALAPACK AND TMP MATRICES
3994 : : ! ====================================
3995 : 0 : call sca_matrix1%free()
3996 : 0 : call sca_matrix2%free()
3997 : 0 : call sca_matrix3%free()
3998 : :
3999 : : #ifndef HAVE_LINALG_ELPA
4000 : : ABI_UNUSED(use_gpu_elpa)
4001 : : #endif
4002 : :
4003 [ # # # # : 0 : end subroutine compute_eigen2
# # # # #
# # # # #
# # ]
4004 : : !!***
4005 : :
4006 : : !----------------------------------------------------------------------
4007 : :
4008 : : !!****f* m_slk/slkmat_dp_heev
4009 : : !! NAME
4010 : : !! slkmat_dp_heev
4011 : : !!
4012 : : !! FUNCTION
4013 : : !! slkmat_dp_heev computes selected eigenvalues and, optionally, eigenvectors of an Hermitian matrix A.
4014 : : !! A * X = lambda * X
4015 : : !!
4016 : : !! INPUTS
4017 : : !! JOBZ (global input) CHARACTER*1
4018 : : !! Specifies whether or not to compute the eigenvectors:
4019 : : !! = "N": Compute eigenvalues only.
4020 : : !! = "V": Compute eigenvalues and eigenvectors.
4021 : : !! UPLO (global input) CHARACTER*1
4022 : : !! Specifies whether the upper or lower triangular part of the symmetric matrix A is stored:
4023 : : !! = "U": Upper triangular
4024 : : !! = "L": Lower triangular
4025 : : !!
4026 : : !! mat=The object storing the local buffer in DOUBLE PRECISION, the array descriptor, the PBLAS context.
4027 : : !! vec=The distributed eigenvectors. Not referenced if JOBZ="N"
4028 : : !!
4029 : : !! OUTPUT
4030 : : !! W (global output) array, dimension (N) where N is the rank of the global matrix.
4031 : : !! On normal exit, the first M entries contain the selected eigenvalues in ascending order.
4032 : : !!
4033 : : !! SIDE EFFECTS
4034 : : !! If JOBZ="V", the local buffer vec%buffer_cplx will contain part of the distributed eigenvectors.
4035 : : !! On exit, the lower triangle (if UPLO='L') or the upper triangle (if UPLO='U') of A, including the diagonal, is destroyed.
4036 : : !!
4037 : : !! SOURCE
4038 : :
4039 : 0 : subroutine slkmat_dp_heev(mat, jobz, uplo, vec, w, &
4040 : : mat_size, ija, ijz) ! Optional
4041 : :
4042 : : !Arguments ------------------------------------
4043 : : !scalars
4044 : : class(slkmat_dp_t),intent(inout) :: mat
4045 : : character(len=*),intent(in) :: jobz, uplo
4046 : : class(slkmat_dp_t),intent(inout) :: vec
4047 : : !arrays
4048 : : real(dp),intent(out) :: w(:)
4049 : : integer,optional,intent(in) :: mat_size, ija(2), ijz(2)
4050 : :
4051 : : #ifdef HAVE_LINALG_SCALAPACK
4052 : : !Local variables ------------------------------
4053 : : !scalars
4054 : : integer :: lwork, lrwork, info, nn
4055 : : !character(len=500) :: msg
4056 : : !arrays
4057 : : integer :: ija__(2), ijz__(2)
4058 : : real(dp),allocatable :: rwork_dp(:)
4059 : : complex(dp),allocatable :: work_dp(:)
4060 : : !************************************************************************
4061 : :
4062 : : ABI_CHECK(allocated(mat%buffer_cplx), "buffer_cplx not allocated")
4063 : :
4064 : : nn = mat%size_global(2); if (present(mat_size)) nn = mat_size
4065 : : ija__ = [1, 1]; if (present(ija)) ija__ = ija
4066 : : ijz__ = [1, 1]; if (present(ijz)) ijz__ = ijz
4067 : :
4068 : : ! Get optimal size of workspace.
4069 : : lwork = - 1; lrwork = -1
4070 : : ABI_MALLOC(work_dp, (1))
4071 : : ABI_MALLOC(rwork_dp, (1))
4072 : :
4073 : : !call pzheev(jobz, uplo, n, a, ia, ja, desca, w, z, iz, jz, descz, work, lwork, rwork, lrwork, info)
4074 : :
4075 : : call PZHEEV(jobz, uplo, nn, mat%buffer_cplx, ija__(1), ija__(2), mat%desc, &
4076 : : w, vec%buffer_cplx, ijz__(1), ijz__(2), vec%desc, work_dp, lwork, rwork_dp, lrwork, info)
4077 : : ABI_CHECK(info == 0, sjoin("Error in the calculation of the workspace size, info:", itoa(info)))
4078 : :
4079 : : lwork = NINT(real(work_dp(1))); lrwork= NINT(rwork_dp(1)) !*2
4080 : : ABI_FREE(work_dp)
4081 : : ABI_FREE(rwork_dp)
4082 : :
4083 : : ! MG: Nov 23 2011. On my mac with the official scalapack package, rwork(1) is not large enough and causes a SIGFAULT.
4084 : : if (firstchar(jobz, ['V'])) then
4085 : : if (lrwork < 2*nn + 2*nn-2) lrwork = 2*nn + 2*nn-2
4086 : : else if (firstchar(jobz, ['N'])) then
4087 : : if (lrwork < 2*nn) lrwork = 2*nn
4088 : : end if
4089 : : !write(std_out,*)lwork,lrwork
4090 : :
4091 : : ! Solve the problem.
4092 : : ABI_MALLOC(work_dp, (lwork))
4093 : : ABI_MALLOC(rwork_dp, (lrwork))
4094 : :
4095 : : call PZHEEV(jobz, uplo, nn, mat%buffer_cplx, ija__(1), ija__(2), mat%desc, &
4096 : : w, vec%buffer_cplx, ijz__(1), ijz__(2), vec%desc, work_dp, lwork, rwork_dp, lrwork, info)
4097 : : ABI_CHECK(info == 0, sjoin("PZHEEV returned info:", itoa(info)))
4098 : : ABI_FREE(work_dp)
4099 : : ABI_FREE(rwork_dp)
4100 : : #endif
4101 : :
4102 : 0 : end subroutine slkmat_dp_heev
4103 : : !!***
4104 : :
4105 : : !----------------------------------------------------------------------
4106 : :
4107 : : !!****f* m_slk/slkmat_sp_heev
4108 : : !! NAME
4109 : : !! slkmat_sp_heev
4110 : : !!
4111 : : !! FUNCTION
4112 : : !! slkmat_sp_heev computes selected eigenvalues and, optionally, eigenvectors of an Hermitian matrix A.
4113 : : !! A * X = lambda * X
4114 : : !!
4115 : : !! INPUTS
4116 : : !! JOBZ (global input) CHARACTER*1
4117 : : !! Specifies whether or not to compute the eigenvectors:
4118 : : !! = "N": Compute eigenvalues only.
4119 : : !! = "V": Compute eigenvalues and eigenvectors.
4120 : : !! UPLO (global input) CHARACTER*1
4121 : : !! Specifies whether the upper or lower triangular part of the symmetric matrix A is stored:
4122 : : !! = "U": Upper triangular
4123 : : !! = "L": Lower triangular
4124 : : !!
4125 : : !! mat=The object storing the local buffer in SINGLE PRECISION, the array descriptor, the PBLAS context.
4126 : : !! vec=The distributed eigenvectors. Not referenced if JOBZ="N"
4127 : : !!
4128 : : !! OUTPUT
4129 : : !! W (global output) array, dimension (N) where N is the rank of the global matrix.
4130 : : !! On normal exit, the first M entries contain the selected eigenvalues in ascending order.
4131 : : !!
4132 : : !! SIDE EFFECTS
4133 : : !! If JOBZ="V", the local buffer vec%buffer_cplx will contain part of the distributed eigenvectors.
4134 : : !! On exit, the lower triangle (if UPLO='L') or the upper triangle (if UPLO='U') of A, including the diagonal, is destroyed.
4135 : : !!
4136 : : !! SOURCE
4137 : :
4138 : 0 : subroutine slkmat_sp_heev(mat, jobz, uplo, vec, w, &
4139 : : mat_size, ija, ijz) ! Optional
4140 : :
4141 : : !Arguments ------------------------------------
4142 : : !scalars
4143 : : class(slkmat_sp_t),intent(inout) :: mat
4144 : : character(len=*),intent(in) :: jobz, uplo
4145 : : class(slkmat_sp_t),intent(inout) :: vec
4146 : : !arrays
4147 : : real(sp),intent(out) :: w(:)
4148 : : integer,optional,intent(in) :: mat_size, ija(2), ijz(2)
4149 : :
4150 : : #ifdef HAVE_LINALG_SCALAPACK
4151 : : !Local variables ------------------------------
4152 : : !scalars
4153 : : integer :: lwork, lrwork, info, nn
4154 : : !arrays
4155 : : integer :: ija__(2), ijz__(2)
4156 : : real(sp),allocatable :: rwork_sp(:)
4157 : : complex(sp),allocatable :: work_sp(:)
4158 : : !************************************************************************
4159 : :
4160 : : ABI_CHECK(allocated(mat%buffer_cplx), "buffer_cplx not allocated")
4161 : :
4162 : : nn = mat%size_global(2); if (present(mat_size)) nn = mat_size
4163 : : ija__ = [1, 1]; if (present(ija)) ija__ = ija
4164 : : ijz__ = [1, 1]; if (present(ijz)) ijz__ = ijz
4165 : :
4166 : : ! Get optimal size of workspace.
4167 : : lwork = - 1; lrwork = -1
4168 : : ABI_MALLOC(work_sp, (1))
4169 : : ABI_MALLOC(rwork_sp, (1))
4170 : :
4171 : : !call pzheev(jobz, uplo, n, a, ia, ja, desca, w, z, iz, jz, descz, work, lwork, rwork, lrwork, info)
4172 : :
4173 : : call PCHEEV(jobz, uplo, nn, mat%buffer_cplx, ija__(1), ija__(2), mat%desc, &
4174 : : w, vec%buffer_cplx, ijz__(1), ijz__(2), vec%desc, work_sp, lwork, rwork_sp, lrwork, info)
4175 : : ABI_CHECK(info == 0, sjoin("Error in the calculation of the workspace size, info:", itoa(info)))
4176 : :
4177 : : lwork = NINT(real(work_sp(1))); lrwork= NINT(rwork_sp(1)) !*2
4178 : : ABI_FREE(work_sp)
4179 : : ABI_FREE(rwork_sp)
4180 : :
4181 : : ! MG: Nov 23 2011. On my mac with the official scalapack package, rwork(1) is not large enough and causes a SIGFAULT.
4182 : : if (firstchar(jobz, ['V'])) then
4183 : : if (lrwork < 2*nn + 2*nn-2) lrwork = 2*nn + 2*nn-2
4184 : : else if (firstchar(jobz, ['N'])) then
4185 : : if (lrwork < 2*nn) lrwork = 2*nn
4186 : : end if
4187 : : !write(std_out,*)lwork,lrwork
4188 : :
4189 : : ! Solve the problem.
4190 : : ABI_MALLOC(work_sp, (lwork))
4191 : : ABI_MALLOC(rwork_sp, (lrwork))
4192 : :
4193 : : call PCHEEV(jobz, uplo, nn, mat%buffer_cplx, ija__(1), ija__(2), mat%desc, &
4194 : : w, vec%buffer_cplx, ijz__(1), ijz__(2), vec%desc, work_sp, lwork, rwork_sp, lrwork, info)
4195 : : ABI_CHECK(info == 0, sjoin("PCHEEV returned info:", itoa(info)))
4196 : : ABI_FREE(work_sp)
4197 : : ABI_FREE(rwork_sp)
4198 : : #endif
4199 : :
4200 : 0 : end subroutine slkmat_sp_heev
4201 : : !!***
4202 : :
4203 : : !----------------------------------------------------------------------
4204 : :
4205 : : !!****f* m_slk/slkmat_dp_pzheevx
4206 : : !! NAME
4207 : : !! slkmat_dp_pzheevx
4208 : : !!
4209 : : !! FUNCTION
4210 : : !! slkmat_dp_pzheevx computes selected eigenvalues and, optionally, eigenvectors of a complex Hermitian matrix A.
4211 : : !! A * X = lambda * X
4212 : : !!
4213 : : !! INPUTS
4214 : : !! mat=ScaLAPACK matrix (matrix A)
4215 : : !!
4216 : : !! vec=The distributed eigenvectors X. Not referenced if JOBZ="N"
4217 : : !!
4218 : : !! JOBZ (global input) CHARACTER*1
4219 : : !! Specifies whether or not to compute the eigenvectors:
4220 : : !! = "N": Compute eigenvalues only.
4221 : : !! = "V": Compute eigenvalues and eigenvectors.
4222 : : !!
4223 : : !! RANGE (global input) CHARACTER*1
4224 : : !! = "A": all eigenvalues will be found.
4225 : : !! = "V": all eigenvalues in the interval [VL,VU] will be found.
4226 : : !! = "I": the IL-th through IU-th eigenvalues will be found.
4227 : : !!
4228 : : !! UPLO (global input) CHARACTER*1
4229 : : !! Specifies whether the upper or lower triangular part of the Hermitian matrix A is stored:
4230 : : !! = "U": Upper triangular
4231 : : !! = "L": Lower triangular
4232 : : !!
4233 : : !! VL (global input) DOUBLE PRECISION
4234 : : !! If RANGE="V",the lower bound of the interval to be searched for eigenvalues. Not referenced if RANGE =
4235 : : !! "A" or "I"
4236 : : !!
4237 : : !! VU (global input) DOUBLE PRECISION
4238 : : !! If RANGE="V", the upper bound of the interval to be searched for eigenvalues. Not referenced if RANGE =
4239 : : !! "A" or "I".
4240 : : !!
4241 : : !! IL (global input) integer
4242 : : !! If RANGE="I", the index (from smallest to largest) of the smallest eigenvalue to be returned. IL >= 1.
4243 : : !! Not referenced if RANGE = "A" or "V".
4244 : : !!
4245 : : !! IU (global input) integer
4246 : : !! If RANGE="I", the index (from smallest to largest) of the largest eigenvalue to be returned. min(IL,N) <=
4247 : : !! IU <= N. Not referenced if RANGE = "A" or "V"
4248 : : !!
4249 : : !! ABSTOL (global input) DOUBLE PRECISION
4250 : : !! If JOBZ="V", setting ABSTOL to PDLAMCH( CONTEXT, "U") yields the most orthogonal eigenvectors.
4251 : : !! The absolute error tolerance for the eigenvalues. An approximate eigenvalue is accepted as converged when
4252 : : !! it is determined to lie in an interval [a,b] of width less than or equal to
4253 : : !!
4254 : : !! ABSTOL + EPS * max( |a|,|b| ) ,
4255 : : !!
4256 : : !! where EPS is the machine precision. If ABSTOL is less than or equal to zero, then EPS*norm(T) will be used
4257 : : !! in its place, where norm(T) is the 1-norm of the tridiagonal matrix obtained by reducing A to tridiagonal form.
4258 : : !! Eigenvalues will be computed most accurately when ABSTOL is set to twice the underflow threshold
4259 : : !! 2*PDLAMCH("S") not zero. If this routine returns with ((MOD(INFO,2).NE.0) .OR. (MOD(INFO/8,2).NE.0)),
4260 : : !! indicating that some eigenvalues or eigenvectors did not converge, try setting ABSTOL to 2*PDLAMCH("S").
4261 : : !!
4262 : : !! OUTPUT
4263 : : !! mene_found= (global output) Total number of eigenvalues found. 0 <= mene_found <= N.
4264 : : !! eigen(N)= (global output) Eigenvalues of A where N is the dimension of M
4265 : : !! On normal exit, the first mene_found entries contain the selected eigenvalues in ascending order.
4266 : : !!
4267 : : !! SIDE EFFECTS
4268 : : !! If JOBZ="V", the local buffer vec%buffer_cplx will contain part of the distributed eigenvectors.
4269 : : !! Slk%mat%buffer_cplx is destroyed when the routine returns
4270 : : !!
4271 : : !! SOURCE
4272 : :
4273 : 0 : subroutine slkmat_dp_pzheevx(mat, jobz, range, uplo, vl, vu, il, iu, abstol, vec, mene_found, eigen)
4274 : :
4275 : : !Arguments ------------------------------------
4276 : : class(slkmat_dp_t),intent(inout) :: mat
4277 : : integer,intent(in) :: il, iu
4278 : : integer,intent(out) :: mene_found
4279 : : real(dp),intent(in) :: abstol,vl,vu
4280 : : character(len=*),intent(in) :: jobz,range,uplo
4281 : : class(slkmat_dp_t),intent(inout) :: vec
4282 : : !arrays
4283 : : real(dp),intent(out) :: eigen(*)
4284 : :
4285 : : #ifdef HAVE_LINALG_SCALAPACK
4286 : : !Local variables-------------------------------
4287 : : !scalars
4288 : : integer :: lwork,lrwork,liwork,info,nvec_calc !,ierr
4289 : : real(dp) :: orfac
4290 : : character(len=500) :: msg
4291 : : !arrays
4292 : : !integer :: ibuff(3),max_ibuff(3)
4293 : : integer,allocatable :: iwork(:),iclustr(:),ifail(:)
4294 : : real(dp),allocatable :: rwork(:),gap(:)
4295 : : complex(dpc),allocatable :: work(:)
4296 : : !************************************************************************
4297 : :
4298 : : ABI_CHECK(allocated(mat%buffer_cplx), "buffer_cplx is not allocated!")
4299 : :
4300 : : ! abstol = PDLAMCH(vec%processor%grid%comm,'U')
4301 : :
4302 : : orfac = -one ! Only for eigenvectors: use default value 10d-3.
4303 : : ! Vectors within orfac*norm(A) will be reorthogonalized.
4304 : :
4305 : : ! Allocate the arrays for the results of the calculation
4306 : : ABI_MALLOC(gap, (mat%processor%grid%dims(1) * mat%processor%grid%dims(2)))
4307 : :
4308 : : if (firstchar(jobz, ["V","v"])) then
4309 : : ABI_MALLOC(ifail, (mat%size_global(2)))
4310 : : ABI_MALLOC(iclustr, (2*mat%processor%grid%dims(1) * mat%processor%grid%dims(2)))
4311 : : end if
4312 : :
4313 : : ! Get the optimal size of the work arrays.
4314 : : lwork=-1; lrwork=-1; liwork=-1
4315 : : ABI_MALLOC(work, (1))
4316 : : ABI_MALLOC(iwork, (1))
4317 : : ABI_MALLOC(rwork, (3))
4318 : : ! This is clearly seen in the source in which rwork(1:3) is accessed
4319 : : ! in the calculation of the workspace size.
4320 : :
4321 : : ! prototype
4322 : : !call pzheevx(jobz, range, uplo, n, a, ia, ja, desca, vl, vu, il, iu, abstol, m, nz, w,
4323 : : ! orfac, z, iz, jz, descz, work, lwork, rwork, lrwork, iwork, liwork, ifail, iclustr, gap, info)
4324 : :
4325 : : call PZHEEVX(jobz,range,uplo, mat%size_global(2),mat%buffer_cplx,1,1,mat%desc,&
4326 : : vl,vu,il,iu,abstol,mene_found,nvec_calc,eigen,orfac,&
4327 : : vec%buffer_cplx,1,1,vec%desc,&
4328 : : work,lwork,rwork,lrwork,iwork,liwork,ifail,iclustr,gap,info)
4329 : :
4330 : : ABI_CHECK(info == 0, sjoin("Problem to compute workspace, info:", itoa(info)))
4331 : :
4332 : : lwork = NINT(real(work(1)),kind=dp)
4333 : : lrwork = NINT(rwork(1))
4334 : : liwork = iwork(1)
4335 : :
4336 : : ABI_FREE(work)
4337 : : ABI_FREE(rwork)
4338 : : ABI_FREE(iwork)
4339 : : !
4340 : : ! FROM THE SCALAPACK MAN PAGE:
4341 : : ! The computed eigenvectors may not be orthogonal if the minimal workspace is supplied and ORFAC is too
4342 : : ! small. If you want to guarantee orthogonality (at the cost of potentially poor performance) you should
4343 : : ! add the following to LRWORK: (CLUSTERSIZE-1)*N where CLUSTERSIZE is the number of eigenvalues in the
4344 : : ! largest cluster, where a cluster is defined as a set of close eigenvalues: { W(K),...,W(K+CLUSTERSIZE-1) |
4345 : : ! W(J+1) <= W(J) + ORFAC*2*norm(A) }.
4346 : :
4347 : : if (firstchar(jobz, ["V","v"])) then
4348 : : lrwork = INT( lrwork + mat%size_global(2) *(mat%size_global(2)-1) )
4349 : : end if
4350 : :
4351 : : ! ibuff(1) = lwork
4352 : : ! ibuff(2) = lrwork !INT(lrwork + mat%size_global(2) *(mat%size_global(2)-1)
4353 : : ! ibuff(3) = liwork
4354 : :
4355 : : ! Get the maximum of sizes of the work arrays processor%comm
4356 : : ! call MPI_ALLREDUCE(ibuff,max_ibuff,3,MPI_integer,MPI_MAX,comm,ierr)
4357 : :
4358 : : ! lwork = max_ibuff(1)
4359 : : ! lrwork = max_ibuff(2)
4360 : : ! liwork = max_ibuff(3)
4361 : :
4362 : : ABI_MALLOC(work , (lwork ))
4363 : : ABI_MALLOC(rwork, (lrwork))
4364 : : ABI_MALLOC(iwork, (liwork))
4365 : :
4366 : : ! prototype
4367 : : !call pzheevx(jobz, range, uplo, n, a, ia, ja, desca, vl, vu, il, iu, abstol, m, nz, w,
4368 : : ! orfac, z, iz, jz, descz, work, lwork, rwork, lrwork, iwork, liwork, ifail, iclustr, gap, info)
4369 : :
4370 : : ! Call the scaLAPACK routine.
4371 : : ! write(std_out,*) 'I am using PZHEEVX'
4372 : : call PZHEEVX(jobz,range,uplo, mat%size_global(2),mat%buffer_cplx,1,1,mat%desc,&
4373 : : vl,vu,il,iu,abstol,mene_found,nvec_calc, eigen,orfac,&
4374 : : vec%buffer_cplx,1,1,vec%desc,&
4375 : : work,lwork,rwork,lrwork,iwork,liwork,ifail,iclustr,gap,info)
4376 : :
4377 : : ! Handle possible error.
4378 : : if (info < 0) then
4379 : : write(msg,'(a,i0,a)')" The ", -info, "-th argument of P?HEEVX had an illegal value."
4380 : : if (info == -25) msg = " LRWORK is too small to compute all the eigenvectors requested, no computation is performed"
4381 : : ABI_ERROR(msg)
4382 : : end if
4383 : :
4384 : : if (info > 0) then
4385 : : write(msg,'(a,i0)') " P?HEEVX returned info: ",info
4386 : : call wrtout(std_out, msg)
4387 : : if (MOD(info, 2) /= 0)then
4388 : : write(msg,'(3a)')&
4389 : : " One or more eigenvectors failed to converge. ",ch10,&
4390 : : " Their indices are stored in IFAIL. Ensure ABSTOL=2.0*PDLAMCH('U')"
4391 : : call wrtout(std_out, msg)
4392 : : end if
4393 : : if (MOD(info / 2, 2) /= 0) then
4394 : : write(msg,'(5a)')&
4395 : : " Eigenvectors corresponding to one or more clusters of eigenvalues ",ch10,&
4396 : : " could not be reorthogonalized because of insufficient workspace. ",ch10,&
4397 : : " The indices of the clusters are stored in the array ICLUSTR."
4398 : : call wrtout(std_out, msg)
4399 : : end if
4400 : : if (MOD(info / 4, 2) /= 0) then
4401 : : write(msg,'(3a)')" Space limit prevented PZHEEVX from computing all of the eigenvectors between VL and VU. ",ch10,&
4402 : : " The number of eigenvectors computed is returned in NZ."
4403 : : call wrtout(std_out, msg)
4404 : : end if
4405 : : if (MOD(info / 8, 2) /= 0) then
4406 : : call wrtout(std_out, "PZSTEBZ failed to compute eigenvalues. Ensure ABSTOL=2.0*PDLAMCH('U')")
4407 : : end if
4408 : : ABI_ERROR("Cannot continue")
4409 : : end if
4410 : :
4411 : : ! Check the number of eigenvalues found wrt to the number of vectors calculated.
4412 : : if (firstchar(jobz, ['V','v']) .and. mene_found /= nvec_calc) then
4413 : : write(msg,'(5a)') &
4414 : : " The user supplied insufficient space and PZHEEVX is not able to detect this before beginning computation. ",ch10,&
4415 : : " To get all the eigenvectors requested, the user must supply both sufficient space to hold the ",ch10,&
4416 : : " eigenvectors in Z (M .LE. DESCZ(N_)) and sufficient workspace to compute them. "
4417 : : ABI_ERROR(msg)
4418 : : end if
4419 : :
4420 : : ABI_FREE(work)
4421 : : ABI_FREE(rwork)
4422 : : ABI_FREE(iwork)
4423 : : ABI_FREE(gap)
4424 : : ABI_SFREE(ifail)
4425 : : ABI_SFREE(iclustr)
4426 : : #endif
4427 : :
4428 : 0 : end subroutine slkmat_dp_pzheevx
4429 : : !!***
4430 : :
4431 : : !----------------------------------------------------------------------
4432 : :
4433 : : !!****f* m_slk/slkmat_dp_pzhegvx
4434 : : !! NAME
4435 : : !! slkmat_dp_pzhegvx
4436 : : !!
4437 : : !! FUNCTION
4438 : : !! slkmat_dp_pzhegvx provides an object-oriented interface to the ScaLAPACK routine PZHEGVX that
4439 : : !! computes selected eigenvalues and, optionally, eigenvectors of a complex generalized
4440 : : !! Hermitian-definite eigenproblem, of the form
4441 : : !! sub( A )*x=(lambda)*sub( B )*x, sub( A )*sub( B )x=(lambda)*x, or sub( B )*sub( A )*x=(lambda)*x.
4442 : : !! Here sub( A ) denoting A( IA:IA+N-1, JA:JA+N-1 ) is assumed to be
4443 : : !! Hermitian, and sub( B ) denoting B( IB:IB+N-1, JB:JB+N-1 ) is assumed
4444 : : !! to be Hermitian positive definite.
4445 : : !!
4446 : : !! INPUTS
4447 : : !! Slk_matA<slkmat_dp_t>=ScaLAPACK matrix (matrix A)
4448 : : !! Slk_matB<slkmat_dp_t>=ScaLAPACK matrix (matrix B)
4449 : : !! Slk_vec<slkmat_dp_t>=The distributed eigenvectors X. Not referenced if JOBZ="N"
4450 : : !!
4451 : : !! IBtype (global input) integer
4452 : : !! Specifies the problem type to be solved:
4453 : : !! = 1: sub( A )*x = (lambda)*sub( B )*x
4454 : : !! = 2: sub( A )*sub( B )*x = (lambda)*x
4455 : : !! = 3: sub( B )*sub( A )*x = (lambda)*x
4456 : : !!
4457 : : !! JOBZ (global input) CHARACTER*1
4458 : : !! Specifies whether or not to compute the eigenvectors:
4459 : : !! = "N": Compute eigenvalues only.
4460 : : !! = "V": Compute eigenvalues and eigenvectors.
4461 : : !!
4462 : : !! RANGE (global input) CHARACTER*1
4463 : : !! = "A": all eigenvalues will be found.
4464 : : !! = "V": all eigenvalues in the interval [VL,VU] will be found.
4465 : : !! = "I": the IL-th through IU-th eigenvalues will be found.
4466 : : !!
4467 : : !! UPLO (global input) CHARACTER*1
4468 : : !! Specifies whether the upper or lower triangular part of the Hermitian matrix sub(A) and sub(B) is stored:
4469 : : !! = "U": Upper triangular
4470 : : !! = "L": Lower triangular
4471 : : !!
4472 : : !! VL (global input) DOUBLE PRECISION
4473 : : !! If RANGE="V",the lower bound of the interval to be searched for eigenvalues. Not referenced if RANGE =
4474 : : !! "A" or "I"
4475 : : !!
4476 : : !! VU (global input) DOUBLE PRECISION
4477 : : !! If RANGE="V", the upper bound of the interval to be searched for eigenvalues. Not referenced if RANGE =
4478 : : !! "A" or "I".
4479 : : !!
4480 : : !! IL (global input) integer
4481 : : !! If RANGE="I", the index (from smallest to largest) of the smallest eigenvalue to be returned. IL >= 1.
4482 : : !! Not referenced if RANGE = "A" or "V".
4483 : : !!
4484 : : !! IU (global input) integer
4485 : : !! If RANGE="I", the index (from smallest to largest) of the largest eigenvalue to be returned. min(IL,N) <=
4486 : : !! IU <= N. Not referenced if RANGE = "A" or "V"
4487 : : !!
4488 : : !! ABSTOL (global input) DOUBLE PRECISION
4489 : : !! If JOBZ="V", setting ABSTOL to PDLAMCH( CONTEXT, "U") yields the most orthogonal eigenvectors.
4490 : : !! The absolute error tolerance for the eigenvalues. An approximate eigenvalue is accepted as converged when
4491 : : !! it is determined to lie in an interval [a,b] of width less than or equal to
4492 : : !!
4493 : : !! ABSTOL + EPS * max( |a|,|b| ) ,
4494 : : !!
4495 : : !! where EPS is the machine precision. If ABSTOL is less than or equal to zero, then EPS*norm(T) will be used
4496 : : !! in its place, where norm(T) is the 1-norm of the tridiagonal matrix obtained by reducing A to tridiagonal form.
4497 : : !! Eigenvalues will be computed most accurately when ABSTOL is set to twice the underflow threshold
4498 : : !! 2*PDLAMCH("S") not zero. If this routine returns with ((MOD(INFO,2).NE.0) .OR. (MOD(INFO/8,2).NE.0)),
4499 : : !! indicating that some eigenvalues or eigenvectors did not converge, try setting ABSTOL to 2*PDLAMCH("S").
4500 : : !!
4501 : : !! OUTPUT
4502 : : !! mene_found= (global output) Total number of eigenvalues found. 0 <= mene_found <= N.
4503 : : !!
4504 : : !! eigen(N)= (global output) Eigenvalues of A where N is the dimension of M
4505 : : !! On normal exit, the first mene_found entries contain the selected eigenvalues in ascending order.
4506 : : !!
4507 : : !! SIDE EFFECTS
4508 : : !! Slk_vec<slkmat_dp_t>:
4509 : : !! %buffer_cplx local output (global dimension (N,N)
4510 : : !! If JOBZ = 'V', then on normal exit the first M columns of Z
4511 : : !! contain the orthonormal eigenvectors of the matrix
4512 : : !! corresponding to the selected eigenvalues.
4513 : : !! If JOBZ = 'N', then Z is not referenced.
4514 : : !!
4515 : : !! Slk_matA<slkmat_dp_t>:
4516 : : !! %buffer_cplx
4517 : : !! (local input/local output) complex(DP) pointer into the
4518 : : !! local memory to an array of dimension (LLD_A, LOCc(JA+N-1)).
4519 : : !! On entry, this array contains the local pieces of the
4520 : : !! N-by-N Hermitian distributed matrix sub( A ). If UPLO = 'U',
4521 : : !! the leading N-by-N upper triangular part of sub( A ) contains
4522 : : !! the upper triangular part of the matrix. If UPLO = 'L', the
4523 : : !! leading N-by-N lower triangular part of sub( A ) contains
4524 : : !! the lower triangular part of the matrix.
4525 : : !!
4526 : : !! On exit, if JOBZ = 'V', then if INFO = 0, sub( A ) contains
4527 : : !! the distributed matrix Z of eigenvectors. The eigenvectors
4528 : : !! are normalized as follows:
4529 : : !! if IBtype = 1 or 2, Z**H*sub( B )*Z = I;
4530 : : !! if IBtype = 3, Z**H*inv( sub( B ) )*Z = I.
4531 : : !! If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
4532 : : !! or the lower triangle (if UPLO='L') of sub( A ), including
4533 : : !! the diagonal, is destroyed.
4534 : : !!
4535 : : !! Slk_matB=
4536 : : !! %buffer_cplx
4537 : : !! (local input/local output) complex*(DP) pointer into the
4538 : : !! local memory to an array of dimension (LLD_B, LOCc(JB+N-1)).
4539 : : !! On entry, this array contains the local pieces of the
4540 : : !! N-by-N Hermitian distributed matrix sub( B ). If UPLO = 'U',
4541 : : !! the leading N-by-N upper triangular part of sub( B ) contains
4542 : : !! the upper triangular part of the matrix. If UPLO = 'L', the
4543 : : !! leading N-by-N lower triangular part of sub( B ) contains
4544 : : !! the lower triangular part of the matrix.
4545 : : !!
4546 : : !! On exit, if INFO <= N, the part of sub( B ) containing the
4547 : : !! matrix is overwritten by the triangular factor U or L from
4548 : : !! the Cholesky factorization sub( B ) = U**H*U or
4549 : : !! sub( B ) = L*L**H.
4550 : : !!
4551 : : !! SOURCE
4552 : :
4553 : 0 : subroutine slkmat_dp_pzhegvx(Slk_matA, ibtype, jobz, range, uplo, Slk_matB, vl, vu, il, iu, abstol, Slk_vec, mene_found, eigen)
4554 : :
4555 : : !Arguments ------------------------------------
4556 : : class(slkmat_dp_t),intent(inout) :: Slk_matA
4557 : : integer,intent(in) :: il,iu,ibtype
4558 : : integer,intent(out) :: mene_found
4559 : : real(dp),intent(in) :: abstol,vl,vu
4560 : : character(len=*),intent(in) :: jobz,range,uplo
4561 : : class(slkmat_dp_t),intent(inout) :: Slk_matB
4562 : : class(slkmat_dp_t),intent(inout) :: Slk_vec
4563 : : !arrays
4564 : : real(dp),intent(out) :: eigen(*)
4565 : :
4566 : : #ifdef HAVE_LINALG_SCALAPACK
4567 : : !Local variables-------------------------------
4568 : : !scalars
4569 : : integer :: lwork,lrwork,liwork,info,nvec_calc !,ierr
4570 : : real(dp) :: orfac
4571 : : logical :: ltest
4572 : : character(len=500) :: msg
4573 : : !arrays
4574 : : !integer :: ibuff(3),max_ibuff(3)
4575 : : integer :: desca(DLEN_),descb(DLEN_),descz(DLEN_)
4576 : : integer,allocatable :: iwork(:),iclustr(:),ifail(:)
4577 : : real(dp),allocatable :: rwork(:),gap(:)
4578 : : complex(dpc),allocatable :: work(:)
4579 : : !************************************************************************
4580 : :
4581 : : ABI_CHECK(allocated(Slk_matA%buffer_cplx), "buffer_cplx is not allocated!")
4582 : :
4583 : : ! abstol = PDLAMCH(Slk_vecprocessor%grid%comm,'U')
4584 : :
4585 : : orfac = -one ! Only for eigenvectors: use default value 10d-3.
4586 : : ! Vectors within orfac*norm(A) will be reorthogonalized.
4587 : :
4588 : : ! ======================
4589 : : ! Alignment requirements
4590 : : ! ======================
4591 : : ! The distributed submatrices A(IA:*, JA:*), C(IC:IC+M-1,JC:JC+N-1),
4592 : : ! and B( IB:IB+N-1, JB:JB+N-1 ) must verify some alignment properties,
4593 : :
4594 : : desca = Slk_matA%desc
4595 : : descb = Slk_matB%desc
4596 : : if (firstchar(jobz, ["V", "v"])) then
4597 : : descz = Slk_vec%desc
4598 : : else
4599 : : descz = Slk_matA%desc
4600 : : end if
4601 : :
4602 : : ltest = .TRUE.
4603 : : ltest = ltest .and. (DESCA(MB_) == DESCA(NB_))
4604 : : !IA = IB = IZ
4605 : : !JA = IB = JZ
4606 : : ltest = ltest .and.ALL(DESCA(M_ ) == [DESCB(M_ ), DESCZ(M_ )])
4607 : : ltest = ltest .and.ALL(DESCA(N_ ) == [DESCB(N_ ), DESCZ(N_ )])
4608 : : ltest = ltest .and.ALL(DESCA(MB_ ) == [DESCB(MB_ ), DESCZ(MB_ )])
4609 : : ltest = ltest .and.ALL(DESCA(NB_ ) == [DESCB(NB_ ), DESCZ(NB_ )])
4610 : : ltest = ltest .and.ALL(DESCA(RSRC_) == [DESCB(RSRC_), DESCZ(RSRC_)])
4611 : : ltest = ltest .and.ALL(DESCA(CSRC_) == [DESCB(CSRC_), DESCZ(CSRC_)])
4612 : : !MOD( IA-1, DESCA( MB_ ) ) = 0
4613 : : !MOD( JA-1, DESCA( NB_ ) ) = 0
4614 : : !MOD( IB-1, DESCB( MB_ ) ) = 0
4615 : : !MOD( JB-1, DESCB( NB_ ) ) = 0
4616 : :
4617 : : if (.not.ltest) then
4618 : : ABI_ERROR("Alignment requirements not satisfied, check the caller")
4619 : : end if
4620 : :
4621 : : !Allocate the arrays for the results of the calculation
4622 : : ABI_MALLOC(gap, (Slk_matA%processor%grid%dims(1) * Slk_matA%processor%grid%dims(2)))
4623 : :
4624 : : if (firstchar(jobz, ["V","v"])) then
4625 : : ABI_MALLOC(ifail,(Slk_matA%size_global(2)))
4626 : : ABI_MALLOC(iclustr,( 2*Slk_matA%processor%grid%dims(1) * Slk_matA%processor%grid%dims(2)))
4627 : : else
4628 : : ABI_MALLOC(ifail,(1))
4629 : : end if
4630 : :
4631 : : ! Get the optimal size of the work arrays.
4632 : : lwork=-1; lrwork=-1; liwork=-1
4633 : : ABI_MALLOC(work,(1))
4634 : : ABI_MALLOC(iwork,(1))
4635 : : ABI_MALLOC(rwork,(3))
4636 : : ! This is clearly seen in the source in which rwork(1:3) is accessed
4637 : : ! in the calcuation of the workspace size.
4638 : :
4639 : : call pzhegvx(ibtype,jobz,range,uplo, Slk_matA%size_global(2),Slk_matA%buffer_cplx,1,1,Slk_matA%desc,&
4640 : : Slk_matB%buffer_cplx,1,1,Slk_matB%desc,&
4641 : : vl,vu,il,iu,abstol,mene_found,nvec_calc,eigen,orfac,&
4642 : : Slk_vec%buffer_cplx,1,1,Slk_vec%desc,&
4643 : : work,lwork,rwork,lrwork,iwork,liwork,ifail,iclustr,gap,info)
4644 : :
4645 : : ABI_CHECK(info == 0, sjoin("Problem to compute workspace, info:", itoa(info)))
4646 : :
4647 : : lwork = NINT(real(work(1)),kind=dp)
4648 : : lrwork = NINT(rwork(1))
4649 : : liwork = iwork(1)
4650 : :
4651 : : ABI_FREE(work)
4652 : : ABI_FREE(rwork)
4653 : : ABI_FREE(iwork)
4654 : :
4655 : : !FROM THE SCALAPACK MAN PAGE:
4656 : : !The computed eigenvectors may not be orthogonal if the minimal workspace is supplied and ORFAC is too
4657 : : !small. If you want to guarantee orthogonality (at the cost of potentially poor performance) you should
4658 : : !add the following to LRWORK: (CLUSTERSIZE-1)*N where CLUSTERSIZE is the number of eigenvalues in the
4659 : : !largest cluster, where a cluster is defined as a set of close eigenvalues: { W(K),...,W(K+CLUSTERSIZE-1) |
4660 : : !W(J+1) <= W(J) + ORFAC*2*norm(A) }.
4661 : :
4662 : : if (firstchar(jobz, ["V","v"])) then
4663 : : lrwork = INT( lrwork + Slk_matA%size_global(2) *(Slk_matA%size_global(2)-1) )
4664 : : end if
4665 : :
4666 : : !ibuff(1) = lwork
4667 : : !ibuff(2) = lrwork !INT(lrwork + Slk_matA%size_global(2) *(Slk_matA%size_global(2)-1)
4668 : : !ibuff(3) = liwork
4669 : :
4670 : : !Get the maximum of sizes of the work arrays processor%comm
4671 : : !call MPI_ALLREDUCE(ibuff,max_ibuff,3,MPI_integer,MPI_MAX,comm,ierr)
4672 : :
4673 : : !lwork = max_ibuff(1)
4674 : : !lrwork = max_ibuff(2)
4675 : : !liwork = max_ibuff(3)
4676 : :
4677 : : ABI_MALLOC(work , (lwork ))
4678 : : ABI_MALLOC(rwork, (lrwork))
4679 : : ABI_MALLOC(iwork, (liwork))
4680 : :
4681 : : ! Call the scaLAPACK routine.
4682 : : ! write(std_out,*) 'I am using PZHEGVX'
4683 : : call pzhegvx(ibtype,jobz,range,uplo, Slk_matA%size_global(2),Slk_matA%buffer_cplx,1,1,Slk_matA%desc,&
4684 : : Slk_matB%buffer_cplx,1,1,Slk_matB%desc,&
4685 : : vl,vu,il,iu,abstol,mene_found,nvec_calc, eigen,orfac,&
4686 : : Slk_vec%buffer_cplx,1,1,Slk_vec%desc,&
4687 : : work,lwork,rwork,lrwork,iwork,liwork,ifail,iclustr,gap,info)
4688 : :
4689 : : ! Handle the possible error.
4690 : : if (info < 0) then
4691 : : write(msg,'(a,i0,a)')" The ",-info,"-th argument of PZHEGVX had an illegal value."
4692 : : if (info==-25) msg = " LRWORK is too small to compute all the eigenvectors requested, no computation is performed"
4693 : : ABI_ERROR(msg)
4694 : : end if
4695 : :
4696 : : if (info > 0) then
4697 : : write(msg,'(a,i0)') " PZHEGVX returned info: ",info
4698 : : call wrtout(std_out, msg)
4699 : : if (MOD(info,2)/=0)then
4700 : : write(msg,'(3a)')&
4701 : : " One or more eigenvectors failed to converge. ",ch10,&
4702 : : " Their indices are stored in IFAIL. Ensure ABSTOL=2.0*PDLAMCH('U')"
4703 : : call wrtout(std_out, msg)
4704 : : end if
4705 : : if (MOD(info / 2, 2) /= 0) then
4706 : : write(msg,'(5a)')&
4707 : : " Eigenvectors corresponding to one or more clusters of eigenvalues ",ch10,&
4708 : : " could not be reorthogonalized because of insufficient workspace. ",ch10,&
4709 : : " The indices of the clusters are stored in the array ICLUSTR."
4710 : : call wrtout(std_out, msg)
4711 : : end if
4712 : : if (MOD(info / 4, 2) /= 0) then
4713 : : write(msg,'(3a)')&
4714 : : " Space limit prevented PZHEGVX from computing all of the eigenvectors between VL and VU. ",ch10,&
4715 : : " The number of eigenvectors computed is returned in NZ."
4716 : : call wrtout(std_out, msg)
4717 : : end if
4718 : : if (MOD(info / 8, 2) /= 0) then
4719 : : msg = " PZSTEBZ failed to compute eigenvalues. Ensure ABSTOL=2.0*PDLAMCH('U')"
4720 : : call wrtout(std_out, msg)
4721 : : end if
4722 : : if (MOD(info / 16, 2) /= 0) then
4723 : : write(msg,'(3a)')&
4724 : : " B was not positive definite.",ch10,&
4725 : : " IFAIL(1) indicates the order of the smallest minor which is not positive definite."
4726 : : call wrtout(std_out, msg)
4727 : : end if
4728 : : ABI_ERROR("Cannot continue")
4729 : : end if
4730 : :
4731 : : ! Check the number of eigenvalues found wrt to the number of vectors calculated.
4732 : : if ( firstchar(jobz, ['V','v']) .and. mene_found/=nvec_calc) then
4733 : : write(msg,'(5a)')&
4734 : : " The user supplied insufficient space and PZHEGVX is not able to detect this before beginning computation. ",ch10,&
4735 : : " To get all the eigenvectors requested, the user must supply both sufficient space to hold the ",ch10,&
4736 : : " eigenvectors in Z (M .LE. DESCZ(N_)) and sufficient workspace to compute them. "
4737 : : ABI_ERROR(msg)
4738 : : end if
4739 : :
4740 : : ABI_FREE(work)
4741 : : ABI_FREE(rwork)
4742 : : ABI_FREE(iwork)
4743 : : ABI_FREE(gap)
4744 : : ABI_FREE(ifail)
4745 : : ABI_SFREE(iclustr)
4746 : : #endif
4747 : :
4748 : 0 : end subroutine slkmat_dp_pzhegvx
4749 : : !!***
4750 : :
4751 : : !----------------------------------------------------------------------
4752 : :
4753 : : !!****f* m_slk/basemat_invert
4754 : : !! NAME
4755 : : !! basemat_invert
4756 : : !!
4757 : : !! FUNCTION
4758 : : !! Compute the inverse of a complex matrix.
4759 : : !!
4760 : : !! SIDE EFFECTS
4761 : : !! mat
4762 : : !! In input, the matrix to invert.
4763 : : !! In output the matrix inverted and distributed among the nodes.
4764 : : !!
4765 : : !! SOURCE
4766 : :
4767 : 0 : subroutine basemat_invert(mat)
4768 : :
4769 : : !Arguments ------------------------------------
4770 : : class(basemat_t),intent(inout) :: mat
4771 : :
4772 : : #ifdef HAVE_LINALG_SCALAPACK
4773 : : !Local variables ------------------------------
4774 : : !scalars
4775 : : integer :: lwork,info,ipiv_size,liwork
4776 : : !array
4777 : : integer,allocatable :: ipiv(:), iwork(:)
4778 : : complex(dp),allocatable :: work_dp(:)
4779 : : complex(sp),allocatable :: work_sp(:)
4780 : : !************************************************************************
4781 : :
4782 : : if (mat%desc(MB_) /= mat%desc(NB_)) then
4783 : : ABI_ERROR("PZGETRF requires square block decomposition i.e MB_A = NB_A.")
4784 : : end if
4785 : :
4786 : : ipiv_size = my_locr(mat) + mat%desc(MB_)
4787 : : ABI_MALLOC(ipiv, (ipiv_size))
4788 : :
4789 : : select type (mat)
4790 : : class is (slkmat_dp_t)
4791 : : if (allocated(mat%buffer_cplx)) then
4792 : : ! P * L * U Factorization.
4793 : : call PZGETRF(mat%size_global(1), mat%size_global(2), mat%buffer_cplx, 1, 1, mat%desc,ipiv, info)
4794 : : ABI_CHECK(info == 0, sjoin(" PZGETRF returned info:", itoa(info)))
4795 : :
4796 : : ! Get optimal size of workspace for PZGETRI.
4797 : : lwork = -1; liwork = -1
4798 : : ABI_MALLOC(work_dp,(1))
4799 : : ABI_MALLOC(iwork,(1))
4800 : :
4801 : : call PZGETRI(mat%size_global(1), mat%buffer_cplx, 1, 1, mat%desc, ipiv, work_dp, lwork, iwork, liwork, info)
4802 : : ABI_CHECK(info == 0, "PZGETRI: Error while computing workspace size")
4803 : :
4804 : : lwork = nint(real(work_dp(1))); liwork=iwork(1)
4805 : : ABI_FREE(work_dp)
4806 : : ABI_FREE(iwork)
4807 : :
4808 : : ! Solve the problem.
4809 : : ABI_MALLOC(work_dp, (lwork))
4810 : : ABI_MALLOC(iwork, (liwork))
4811 : :
4812 : : call PZGETRI(mat%size_global(1), mat%buffer_cplx, 1, 1, mat%desc, ipiv, work_dp, lwork, iwork, liwork, info)
4813 : : ABI_CHECK(info == 0, sjoin("PZGETRI returned info:", itoa(info)))
4814 : : ABI_FREE(work_dp)
4815 : :
4816 : : else if (allocated(mat%buffer_real)) then
4817 : : ABI_ERROR("Inversion for real matrices not coded!")
4818 : : end if
4819 : :
4820 : : class is (slkmat_sp_t)
4821 : : if (allocated(mat%buffer_cplx)) then
4822 : : ! P * L * U Factorization.
4823 : : call PCGETRF(mat%size_global(1), mat%size_global(2), mat%buffer_cplx, 1, 1, mat%desc,ipiv, info)
4824 : : ABI_CHECK(info == 0, sjoin(" PCGETRF returned info:", itoa(info)))
4825 : :
4826 : : ! Get optimal size of workspace for PZGETRI.
4827 : : lwork = -1; liwork = -1
4828 : : ABI_MALLOC(work_sp,(1))
4829 : : ABI_MALLOC(iwork,(1))
4830 : :
4831 : : call PCGETRI(mat%size_global(1), mat%buffer_cplx, 1, 1, mat%desc, ipiv, work_sp, lwork, iwork, liwork, info)
4832 : : ABI_CHECK(info == 0, "PZGETRI: Error while computing workspace size")
4833 : :
4834 : : lwork = nint(real(work_sp(1))); liwork=iwork(1)
4835 : : ABI_FREE(work_sp)
4836 : : ABI_FREE(iwork)
4837 : :
4838 : : ! Solve the problem.
4839 : : ABI_MALLOC(work_sp, (lwork))
4840 : : ABI_MALLOC(iwork, (liwork))
4841 : :
4842 : : call PCGETRI(mat%size_global(1), mat%buffer_cplx, 1, 1, mat%desc, ipiv, work_sp, lwork, iwork, liwork, info)
4843 : : ABI_CHECK(info == 0, sjoin("PZGETRI returned info:", itoa(info)))
4844 : : ABI_FREE(work_sp)
4845 : :
4846 : : else if (allocated(mat%buffer_real)) then
4847 : : ABI_ERROR("Inversion for real matrices not coded!")
4848 : : end if
4849 : :
4850 : : class default
4851 : : ABI_ERROR("Wrong class")
4852 : : end select
4853 : :
4854 : : ABI_FREE(iwork)
4855 : : ABI_FREE(ipiv)
4856 : : #endif
4857 : :
4858 : 0 : end subroutine basemat_invert
4859 : : !!***
4860 : :
4861 : : !----------------------------------------------------------------------
4862 : :
4863 : : !!****f* m_slk/slkmat_dp_hpd_invert
4864 : : !! NAME
4865 : : !! slkmat_dp_hpd_invert
4866 : : !!
4867 : : !! FUNCTION
4868 : : !! Compute the inverse of an Hermitian positive definite matrix.
4869 : : !!
4870 : : !! INPUTS
4871 : : !! uplo: global input
4872 : : !! = 'U': Upper triangle of sub( A ) is stored;
4873 : : !! = 'L': Lower triangle of sub( A ) is stored.
4874 : : !! [full]: If full PBLAS matrix is neeeded. Default: True
4875 : : !!
4876 : : !! SIDE EFFECTS
4877 : : !! mat= The object storing the local buffer, the array descriptor, the context, etc.
4878 : : !! On entry, this array contains the local pieces of the N-by-N Hermitian distributed matrix sub( A ) to be factored.
4879 : : !! If UPLO = 'U', the leading N-by-N upper triangular part of sub( A ) contains the upper triangular part of the matrix,
4880 : : !! and its strictly lower triangular part is not referenced.
4881 : : !! If UPLO = 'L', the leading N-by-N lower triangular part of sub( A ) contains the lower triangular part of the distribu-
4882 : : !! ted matrix, and its strictly upper triangular part is not referenced.
4883 : : !! On exit, the local pieces of the upper or lower triangle of the (Hermitian) inverse of sub( A )
4884 : : !!
4885 : : !! SOURCE
4886 : :
4887 : 0 : subroutine slkmat_dp_hpd_invert(mat, uplo, full)
4888 : :
4889 : : !Arguments ------------------------------------
4890 : : class(slkmat_dp_t),intent(inout) :: mat
4891 : : character(len=*),intent(in) :: uplo
4892 : : logical,optional,intent(in) :: full
4893 : :
4894 : : #ifdef HAVE_LINALG_SCALAPACK
4895 : : !Local variables ------------------------------
4896 : : !scalars
4897 : : integer :: info, mm, il1, il2, iglob1, iglob2
4898 : : type(slkmat_dp_t) :: work_mat
4899 : : logical :: full__
4900 : : !************************************************************************
4901 : :
4902 : : ABI_CHECK(allocated(mat%buffer_cplx), "buffer_cplx not allocated")
4903 : :
4904 : : ! ZPOTRF computes the Cholesky factorization of a complex Hermitian positive definite.
4905 : : ! A = U**H * U, if UPLO = 'U', or
4906 : : ! A = L * L**H, if UPLO = 'L',
4907 : : mm = mat%size_global(1)
4908 : : call PZPOTRF(uplo, mm, mat%buffer_cplx, 1, 1, mat%desc, info)
4909 : : ABI_CHECK(info == 0, sjoin("PZPOTRF returned info:", itoa(info)))
4910 : :
4911 : : ! PZPOTRI computes the inverse of a complex Hermitian positive definite
4912 : : ! distributed matrix sub( A ) = A(IA:IA+N-1,JA:JA+N-1) using the
4913 : : ! Cholesky factorization sub( A ) = U**H*U or L*L**H computed by PZPOTRF.
4914 : : call PZPOTRI(uplo, mm, mat%buffer_cplx, 1, 1, mat%desc, info)
4915 : : ABI_CHECK(info == 0, sjoin("PZPOTRI returned info:", itoa(info)))
4916 : :
4917 : : full__ = .True.; if (present(full)) full__ = full
4918 : : if (full__) then
4919 : : ! Only the uplo part contains the inverse so we need to fill the other triangular part.
4920 : : ! 1) Fill the missing triangle with zeros and copy results to work_mat
4921 : : ! 2) Call pzgeadd to compute: sub(C) := beta*sub(C) + alpha*op(sub(A))
4922 : : ! 3) Divide diagonal elements by two.
4923 : :
4924 : : do il2=1,mat%size_local(2)
4925 : : iglob2 = mat%loc2gcol(il2)
4926 : : do il1=1,mat%size_local(1)
4927 : : iglob1 = mat%loc2grow(il1)
4928 : : if (uplo == "L" .and. iglob2 > iglob1) mat%buffer_cplx(il1, il2) = zero
4929 : : if (uplo == "U" .and. iglob2 < iglob1) mat%buffer_cplx(il1, il2) = zero
4930 : : end do
4931 : : end do
4932 : :
4933 : : call mat%copy(work_mat, empty=.False.)
4934 : :
4935 : : ! call pzgeadd(trans, m, n, alpha, a, ia, ja, desca, beta, c, ic, jc, descc)
4936 : : ! sub(C) := beta*sub(C) + alpha*op(sub(A))
4937 : : call pzgeadd("C", mm, mm, cone, work_mat%buffer_cplx, 1, 1, work_mat%desc, &
4938 : : cone, mat%buffer_cplx, 1, 1, mat%desc)
4939 : : call work_mat%free()
4940 : :
4941 : : do il2=1,mat%size_local(2)
4942 : : iglob2 = mat%loc2gcol(il2)
4943 : : do il1=1,mat%size_local(1)
4944 : : iglob1 = mat%loc2grow(il1)
4945 : : if (iglob2 == iglob1) mat%buffer_cplx(il1, il2) = half * mat%buffer_cplx(il1, il2)
4946 : : end do
4947 : : end do
4948 : : end if ! full__
4949 : : #endif
4950 : :
4951 : 0 : end subroutine slkmat_dp_hpd_invert
4952 : : !!***
4953 : :
4954 : : !----------------------------------------------------------------------
4955 : :
4956 : : !!****f* m_slk/slkmat_sp_hpd_invert
4957 : : !! NAME
4958 : : !! slkmat_sp_hpd_invert
4959 : : !!
4960 : : !! FUNCTION
4961 : : !! Compute the inverse of an Hermitian positive definite matrix.
4962 : : !!
4963 : : !! INPUTS
4964 : : !! uplo: global input
4965 : : !! = 'U': Upper triangle of sub( A ) is stored;
4966 : : !! = 'L': Lower triangle of sub( A ) is stored.
4967 : : !! [full]: If full PBLAS matrix is neeeded. Default: True
4968 : : !!
4969 : : !! SIDE EFFECTS
4970 : : !! mat= The object storing the local buffer, the array descriptor, the context, etc.
4971 : : !! On entry, this array contains the local pieces of the N-by-N Hermitian distributed matrix sub( A ) to be factored.
4972 : : !! If UPLO = 'U', the leading N-by-N upper triangular part of sub( A ) contains the upper triangular part of the matrix,
4973 : : !! and its strictly lower triangular part is not referenced.
4974 : : !! If UPLO = 'L', the leading N-by-N lower triangular part of sub( A ) contains the lower triangular part of the distribu-
4975 : : !! ted matrix, and its strictly upper triangular part is not referenced.
4976 : : !! On exit, the local pieces of the upper or lower triangle of the (Hermitian) inverse of sub( A )
4977 : : !!
4978 : : !! SOURCE
4979 : :
4980 : 0 : subroutine slkmat_sp_hpd_invert(mat, uplo, full)
4981 : :
4982 : : !Arguments ------------------------------------
4983 : : class(slkmat_sp_t),intent(inout) :: mat
4984 : : character(len=*),intent(in) :: uplo
4985 : : logical,optional,intent(in) :: full
4986 : :
4987 : : #ifdef HAVE_LINALG_SCALAPACK
4988 : : !Local variables ------------------------------
4989 : : !scalars
4990 : : integer :: info, mm, il1, il2, iglob1, iglob2
4991 : : type(slkmat_sp_t) :: work_mat
4992 : : logical :: full__
4993 : : !************************************************************************
4994 : :
4995 : : ABI_CHECK(allocated(mat%buffer_cplx), "buffer_cplx not allocated")
4996 : :
4997 : : ! ZPOTRF computes the Cholesky factorization of a complex Hermitian positive definite.
4998 : : ! A = U**H * U, if UPLO = 'U', or
4999 : : ! A = L * L**H, if UPLO = 'L',
5000 : : mm = mat%size_global(1)
5001 : : call PCPOTRF(uplo, mm, mat%buffer_cplx, 1, 1, mat%desc, info)
5002 : : ABI_CHECK(info == 0, sjoin("PCPOTRF returned info:", itoa(info)))
5003 : :
5004 : : ! PZPOTRI computes the inverse of a complex Hermitian positive definite
5005 : : ! distributed matrix sub( A ) = A(IA:IA+N-1,JA:JA+N-1) using the
5006 : : ! Cholesky factorization sub( A ) = U**H*U or L*L**H computed by PZPOTRF.
5007 : : call PCPOTRI(uplo, mm, mat%buffer_cplx, 1, 1, mat%desc, info)
5008 : : ABI_CHECK(info == 0, sjoin("PCPOTRI returned info:", itoa(info)))
5009 : :
5010 : : full__ = .True.; if (present(full)) full__ = full
5011 : : if (full__) then
5012 : : ! Only the uplo part contains the inverse so we need to fill the other triangular part.
5013 : : ! 1) Fill the missing triangle with zeros and copy results to work_mat
5014 : : ! 2) Call pzgeadd to compute: sub(C) := beta*sub(C) + alpha*op(sub(A))
5015 : : ! 3) Divide diagonal elements by two.
5016 : :
5017 : : do il2=1,mat%size_local(2)
5018 : : iglob2 = mat%loc2gcol(il2)
5019 : : do il1=1,mat%size_local(1)
5020 : : iglob1 = mat%loc2grow(il1)
5021 : : if (uplo == "L" .and. iglob2 > iglob1) mat%buffer_cplx(il1, il2) = zero_sp
5022 : : if (uplo == "U" .and. iglob2 < iglob1) mat%buffer_cplx(il1, il2) = zero_sp
5023 : : end do
5024 : : end do
5025 : :
5026 : : call mat%copy(work_mat, empty=.False.)
5027 : :
5028 : : ! call pzgeadd(trans, m, n, alpha, a, ia, ja, desca, beta, c, ic, jc, descc)
5029 : : ! sub(C) := beta*sub(C) + alpha*op(sub(A))
5030 : : call pcgeadd("C", mm, mm, cone_sp, work_mat%buffer_cplx, 1, 1, work_mat%desc, &
5031 : : cone_sp, mat%buffer_cplx, 1, 1, mat%desc)
5032 : : call work_mat%free()
5033 : :
5034 : : do il2=1,mat%size_local(2)
5035 : : iglob2 = mat%loc2gcol(il2)
5036 : : do il1=1,mat%size_local(1)
5037 : : iglob1 = mat%loc2grow(il1)
5038 : : if (iglob2 == iglob1) mat%buffer_cplx(il1, il2) = 0.5_sp * mat%buffer_cplx(il1, il2)
5039 : : end do
5040 : : end do
5041 : : end if ! full__
5042 : : #endif
5043 : :
5044 : 0 : end subroutine slkmat_sp_hpd_invert
5045 : : !!***
5046 : :
5047 : : !----------------------------------------------------------------------
5048 : :
5049 : : !!****f* m_slk/slkmat_dp_ptrans
5050 : : !! NAME
5051 : : !! slkmat_dp_ptrans
5052 : : !!
5053 : : !! FUNCTION
5054 : : !! Transposes a matrix
5055 : : !!
5056 : : !! sub( C ) := beta*sub( C ) + alpha*op( sub( A ) )
5057 : : !!
5058 : : !! where
5059 : : !!
5060 : : !! sub( C ) denotes C(IC:IC+M-1,JC:JC+N-1),
5061 : : !! sub( A ) denotes A(IA:IA+N-1,JA:JA+M-1), and, op( X ) = X'.
5062 : : !!
5063 : : !! Thus, op( sub( A ) ) denotes A(IA:IA+N-1,JA:JA+M-1)'.
5064 : : !! Beta is a scalar, sub( C ) is an m by n submatrix, and sub( A ) is an n by m submatrix.
5065 : : !!
5066 : : !! INPUTS
5067 : : !! [ija(2)]: (global) The row and column indices in the distributed matrix in_mat indicating
5068 : : !! the first row and the first column of the submatrix sub(A), respectively.
5069 : : !! [ijc(2)]: (global) The row and column indices in the distributed matrix out_mat
5070 : : !! indicating the first row and the first column of the submatrix sub(C), respectively.
5071 : : !! [free]: True to deallocate in_mat. Default: False
5072 : : !!
5073 : : !! SOURCE
5074 : :
5075 : 0 : subroutine slkmat_dp_ptrans(in_mat, trans, out_mat, &
5076 : : out_gshape, ija, ijc, size_blocs, alpha, beta, free) ! optional
5077 : :
5078 : : !Arguments ------------------------------------
5079 : : class(slkmat_dp_t),intent(inout) :: in_mat
5080 : : character(len=1),intent(in) :: trans
5081 : : class(slkmat_dp_t),intent(inout) :: out_mat
5082 : : integer,optional,intent(in) :: out_gshape(2), size_blocs(2), ija(2), ijc(2)
5083 : : complex(dp),optional,intent(in) :: alpha, beta
5084 : : logical,optional,intent(in) :: free
5085 : :
5086 : : !Local variables-------------------------------
5087 : : integer :: sb, mm, nn, size_blocs__(2)
5088 : : real(dp) :: ralpha__, rbeta__
5089 : : integer :: ija__(2), ijc__(2)
5090 : : complex(dp) :: calpha__, cbeta__
5091 : : ! *************************************************************************
5092 : :
5093 : 0 : ija__ = [1, 1]; if (present(ija)) ija__ = ija
5094 : 0 : ijc__ = [1, 1]; if (present(ijc)) ijc__ = ijc
5095 : :
5096 : : ! transposed output (sub)matrix has shape (nn, mm)
5097 [ # # ]: 0 : if (present(out_gshape)) then
5098 : 0 : nn = out_gshape(1)
5099 : 0 : mm = out_gshape(2)
5100 : : else
5101 : 0 : nn = in_mat%size_global(2)
5102 : 0 : mm = in_mat%size_global(1)
5103 : : end if
5104 : :
5105 [ # # ]: 0 : if (present(size_blocs)) then
5106 : 0 : size_blocs__ = size_blocs
5107 : : else
5108 : : ! FIXME: This can cause problems if I start to use round-robin distribution in GWR!!!!!
5109 : 0 : size_blocs__(1) = in_mat%size_global(2)
5110 : 0 : sb = in_mat%size_global(1) / in_mat%processor%grid%dims(2)
5111 [ # # ]: 0 : if (mod(in_mat%size_global(1), in_mat%processor%grid%dims(2)) /= 0) sb = sb + 1
5112 : 0 : size_blocs__(2) = sb
5113 : : !size_blocs__(2) = in_mat%size_blocs(1); size_blocs__(1) = in_mat%size_blocs(2)
5114 : : end if
5115 : :
5116 : 0 : call out_mat%init(nn, mm, in_mat%processor, in_mat%istwf_k, size_blocs=size_blocs__)
5117 : :
5118 : : ! prototype: call pdtran(m, n, alpha, a, ia, ja, desca, beta, c, ic, jc, descc)
5119 : :
5120 [ # # ]: 0 : if (allocated(in_mat%buffer_cplx)) then
5121 : : #ifdef HAVE_LINALG_SCALAPACK
5122 : : select case (trans)
5123 : : case ("N")
5124 : : ! sub(C) := beta*sub(C) + alpha*sub(A)',
5125 : : calpha__ = cone; if (present(alpha)) calpha__ = alpha
5126 : : cbeta__ = czero; if (present(beta)) cbeta__ = beta
5127 : : call pztranu(nn, mm, calpha__, in_mat%buffer_cplx, ija__(1), ija__(2), &
5128 : : in_mat%desc, cbeta__, out_mat%buffer_cplx, ijc__(1), ijc__(2), out_mat%desc)
5129 : :
5130 : : case ("C")
5131 : : ! sub(C) := beta * sub(C) + alpha * conjg(sub(A)')
5132 : : calpha__ = cone; if (present(alpha)) calpha__ = alpha
5133 : : cbeta__ = czero; if (present(beta)) cbeta__ = beta
5134 : : call pztranc(nn, mm, calpha__, in_mat%buffer_cplx, ija__(1), ija__(2), &
5135 : : in_mat%desc, cbeta__, out_mat%buffer_cplx, ijc__(1), ijc__(2), out_mat%desc)
5136 : :
5137 : : case default
5138 : : ABI_ERROR(sjoin("Invalid value for trans:", trans))
5139 : : end select
5140 : :
5141 : : else if (allocated(in_mat%buffer_real)) then
5142 : : ralpha__ = one; if (present(alpha)) ralpha__ = real(alpha)
5143 : : rbeta__ = zero; if (present(beta)) rbeta__ = real(beta)
5144 : : call pdtran(nn, mm, ralpha__, in_mat%buffer_real, ija__(1), ija__(2), &
5145 : : in_mat%desc, rbeta__, out_mat%buffer_real, ijc__(1), ijc__(2), out_mat%desc)
5146 : : #endif
5147 : : else
5148 : 0 : ABI_ERROR("Neither buffer_cplx nor buffer_real are allocated!")
5149 : : end if
5150 : :
5151 [ # # ]: 0 : if (present(free)) then
5152 [ # # ]: 0 : if (free) call in_mat%free()
5153 : : end if
5154 : :
5155 : 0 : end subroutine slkmat_dp_ptrans
5156 : : !!***
5157 : :
5158 : : !!****f* m_slk/slkmat_sp_ptrans
5159 : : !! NAME
5160 : : !! slkmat_sp_ptrans
5161 : : !!
5162 : : !! FUNCTION
5163 : : !! Transposes a matrix
5164 : : !!
5165 : : !! sub( C ) := beta*sub( C ) + alpha*op( sub( A ) )
5166 : : !!
5167 : : !! where
5168 : : !!
5169 : : !! sub( C ) denotes C(IC:IC+M-1,JC:JC+N-1),
5170 : : !! sub( A ) denotes A(IA:IA+N-1,JA:JA+M-1), and, op( X ) = X'.
5171 : : !!
5172 : : !! Thus, op( sub( A ) ) denotes A(IA:IA+N-1,JA:JA+M-1)'.
5173 : : !! Beta is a scalar, sub( C ) is an m by n submatrix, and sub( A ) is an n by m submatrix.
5174 : : !!
5175 : : !! INPUTS
5176 : : !! [ija(2)]: (global) The row and column indices in the distributed matrix in_mat indicating
5177 : : !! the first row and the first column of the submatrix sub(A), respectively.
5178 : : !! [ijc(2)]: (global) The row and column indices in the distributed matrix out_mat
5179 : : !! indicating the first row and the first column of the submatrix sub(C), respectively.
5180 : : !! [free]: True to deallocate in_mat. Default: False
5181 : : !!
5182 : : !! SOURCE
5183 : :
5184 : 0 : subroutine slkmat_sp_ptrans(in_mat, trans, out_mat, &
5185 : : out_gshape, ija, ijc, size_blocs, alpha, beta, free) ! optional
5186 : :
5187 : : !Arguments ------------------------------------
5188 : : class(slkmat_sp_t),intent(inout) :: in_mat
5189 : : character(len=1),intent(in) :: trans
5190 : : class(slkmat_sp_t),intent(inout) :: out_mat
5191 : : integer,optional,intent(in) :: out_gshape(2), size_blocs(2), ija(2), ijc(2)
5192 : : complex(sp),optional,intent(in) :: alpha, beta
5193 : : logical,optional,intent(in) :: free
5194 : :
5195 : : !Local variables-------------------------------
5196 : : integer :: sb, mm, nn, size_blocs__(2)
5197 : : real(sp) :: ralpha__, rbeta__
5198 : : integer :: ija__(2), ijc__(2)
5199 : : complex(sp) :: calpha__, cbeta__
5200 : : ! *************************************************************************
5201 : :
5202 : 0 : ija__ = [1, 1]; if (present(ija)) ija__ = ija
5203 : 0 : ijc__ = [1, 1]; if (present(ijc)) ijc__ = ijc
5204 : :
5205 : : ! transposed output (sub)matrix has shape (nn, mm)
5206 [ # # ]: 0 : if (present(out_gshape)) then
5207 : 0 : nn = out_gshape(1)
5208 : 0 : mm = out_gshape(2)
5209 : : else
5210 : 0 : nn = in_mat%size_global(2)
5211 : 0 : mm = in_mat%size_global(1)
5212 : : end if
5213 : :
5214 [ # # ]: 0 : if (present(size_blocs)) then
5215 : 0 : size_blocs__ = size_blocs
5216 : : else
5217 : : ! FIXME: This can cause problems if I start to use round-robin distribution in GWR!!!!!
5218 : 0 : size_blocs__(1) = in_mat%size_global(2)
5219 : 0 : sb = in_mat%size_global(1) / in_mat%processor%grid%dims(2)
5220 [ # # ]: 0 : if (mod(in_mat%size_global(1), in_mat%processor%grid%dims(2)) /= 0) sb = sb + 1
5221 : 0 : size_blocs__(2) = sb
5222 : : !size_blocs__(2) = in_mat%size_blocs(1); size_blocs__(1) = in_mat%size_blocs(2)
5223 : : end if
5224 : :
5225 : 0 : call out_mat%init(nn, mm, in_mat%processor, in_mat%istwf_k, size_blocs=size_blocs__)
5226 : :
5227 : : ! prototype: call pdtran(m, n, alpha, a, ia, ja, desca, beta, c, ic, jc, descc)
5228 : :
5229 [ # # ]: 0 : if (allocated(in_mat%buffer_cplx)) then
5230 : : #ifdef HAVE_LINALG_SCALAPACK
5231 : : select case (trans)
5232 : : case ("N")
5233 : : ! sub(C) := beta*sub(C) + alpha*sub(A)',
5234 : : calpha__ = cone_sp; if (present(alpha)) calpha__ = alpha
5235 : : cbeta__ = czero_sp; if (present(beta)) cbeta__ = beta
5236 : : call pctranu(nn, mm, calpha__, in_mat%buffer_cplx, ija__(1), ija__(2), &
5237 : : in_mat%desc, cbeta__, out_mat%buffer_cplx, ijc__(1), ijc__(2), out_mat%desc)
5238 : :
5239 : : case ("C")
5240 : : ! sub(C) := beta * sub(C) + alpha * conjg(sub(A)')
5241 : : calpha__ = cone_sp; if (present(alpha)) calpha__ = alpha
5242 : : cbeta__ = czero_sp; if (present(beta)) cbeta__ = beta
5243 : : call pctranc(nn, mm, calpha__, in_mat%buffer_cplx, ija__(1), ija__(2), &
5244 : : in_mat%desc, cbeta__, out_mat%buffer_cplx, ijc__(1), ijc__(2), out_mat%desc)
5245 : :
5246 : : case default
5247 : : ABI_ERROR(sjoin("Invalid value for trans:", trans))
5248 : : end select
5249 : :
5250 : : else if (allocated(in_mat%buffer_real)) then
5251 : : ralpha__ = one_sp; if (present(alpha)) ralpha__ = real(alpha)
5252 : : rbeta__ = zero_sp; if (present(beta)) rbeta__ = real(beta)
5253 : : call pstran(nn, mm, ralpha__, in_mat%buffer_real, ija__(1), ija__(2), &
5254 : : in_mat%desc, rbeta__, out_mat%buffer_real, ijc__(1), ijc__(2), out_mat%desc)
5255 : : #endif
5256 : : else
5257 : 0 : ABI_ERROR("Neither buffer_cplx nor buffer_real are allocated!")
5258 : : end if
5259 : :
5260 [ # # ]: 0 : if (present(free)) then
5261 [ # # ]: 0 : if (free) call in_mat%free()
5262 : : end if
5263 : :
5264 : 0 : end subroutine slkmat_sp_ptrans
5265 : : !!***
5266 : :
5267 : : !----------------------------------------------------------------------
5268 : :
5269 : : !!****f* m_slk/basemat_change_size_blocs
5270 : : !! NAME
5271 : : !! basemat_change_size_blocs
5272 : : !!
5273 : : !! FUNCTION
5274 : : !! Change the block sizes, return new matrix in out_mat
5275 : : !!
5276 : : !! INPUTS
5277 : : !! [free]: True if `in_mat` should be deallocated. Default: False
5278 : : !!
5279 : : !! OUTPUT
5280 : : !!
5281 : : !! SOURCE
5282 : :
5283 [ # # ]: 0 : subroutine basemat_change_size_blocs(in_mat, out_mat, &
5284 : : size_blocs, processor, free) ! Optional
5285 : :
5286 : : !Arguments ------------------------------------
5287 : : class(basemat_t),target,intent(inout) :: in_mat
5288 : : class(basemat_t),intent(out) :: out_mat
5289 : : integer,optional,intent(in) :: size_blocs(2)
5290 : : class(slk_processor_t), target, optional,intent(in) :: processor
5291 : : logical,optional,intent(in) :: free
5292 : :
5293 : : !Local variables-------------------------------
5294 : : type(slk_processor_t), pointer :: processor__
5295 : : ! *************************************************************************
5296 : :
5297 [ # # # # ]: 0 : processor__ => in_mat%processor; if (present(processor)) processor__ => processor
5298 : :
5299 [ # # ]: 0 : if (present(size_blocs)) then
5300 : 0 : call out_mat%init(in_mat%size_global(1), in_mat%size_global(2), processor__, in_mat%istwf_k, size_blocs=size_blocs)
5301 : : else
5302 : 0 : call out_mat%init(in_mat%size_global(1), in_mat%size_global(2), processor__, in_mat%istwf_k)
5303 : : end if
5304 : :
5305 : : !write(std_out, *)"out_mat%size_global", out_mat%size_global
5306 : : !call in_mat%print(header="input matrix in by basemat_change_size_blocs")
5307 : : !call out_mat%print(header="output matrix generated by basemat_change_size_blocs")
5308 : :
5309 [ # # ]: 0 : ABI_CHECK(same_type_as(in_mat, out_mat), "in_mat and out_mat should have same type!")
5310 : :
5311 : : ! p?gemr2d: Copies a submatrix from one general rectangular matrix to another.
5312 : : ! prototype
5313 : : !call pzgemr2d(m, n, a, ia, ja, desca, b, ib, jb, descb, comm)
5314 : :
5315 : : #ifdef HAVE_LINALG_SCALAPACK
5316 : : select type (in_mat)
5317 : : class is (slkmat_dp_t)
5318 : : select type (out_mat)
5319 : : class is (slkmat_dp_t)
5320 : : if (allocated(in_mat%buffer_cplx)) then
5321 : : ABI_CHECK_IEQ(kind(in_mat%buffer_cplx), kind(out_mat%buffer_cplx), "Different kind")
5322 : : ABI_CHECK(allocated(out_mat%buffer_cplx), "out_mat%buffer_cplx should be allocated")
5323 : : call pzgemr2d(in_mat%size_global(1), in_mat%size_global(2), &
5324 : : in_mat%buffer_cplx, 1, 1, in_mat%desc, &
5325 : : out_mat%buffer_cplx, 1, 1, out_mat%desc, &
5326 : : processor__%grid%comm)
5327 : :
5328 : : else if (allocated(in_mat%buffer_real)) then
5329 : : ABI_CHECK_IEQ(kind(in_mat%buffer_real), kind(out_mat%buffer_real), "Different kind")
5330 : : ABI_CHECK(allocated(out_mat%buffer_real), "out_mat%buffer_real should be allocated")
5331 : : call pdgemr2d(in_mat%size_global(1), in_mat%size_global(2), &
5332 : : in_mat%buffer_real, 1, 1, in_mat%desc, &
5333 : : out_mat%buffer_real, 1, 1, out_mat%desc, &
5334 : : processor__%grid%comm)
5335 : : else
5336 : : ABI_ERROR("Neither buffer_cplx nor buffer_real are allocated!")
5337 : : end if
5338 : : end select
5339 : :
5340 : : class is (slkmat_sp_t)
5341 : : select type (out_mat)
5342 : : class is (slkmat_sp_t)
5343 : : if (allocated(in_mat%buffer_cplx)) then
5344 : : ABI_CHECK_IEQ(kind(in_mat%buffer_cplx), kind(out_mat%buffer_cplx), "Different kind")
5345 : :
5346 : : ABI_CHECK(allocated(out_mat%buffer_cplx), "out_mat%buffer should be allocated")
5347 : : call pcgemr2d(in_mat%size_global(1), in_mat%size_global(2), &
5348 : : in_mat%buffer_cplx, 1, 1, in_mat%desc, &
5349 : : out_mat%buffer_cplx, 1, 1, out_mat%desc, &
5350 : : processor__%grid%comm)
5351 : :
5352 : : else if (allocated(in_mat%buffer_real)) then
5353 : : ABI_CHECK_IEQ(kind(in_mat%buffer_real), kind(out_mat%buffer_real), "Different kind")
5354 : : ABI_CHECK(allocated(out_mat%buffer_real), "out_mat%buffer_real should be allocated")
5355 : : call psgemr2d(in_mat%size_global(1), in_mat%size_global(2), &
5356 : : in_mat%buffer_real, 1, 1, in_mat%desc, &
5357 : : out_mat%buffer_real, 1, 1, out_mat%desc, &
5358 : : processor__%grid%comm)
5359 : : else
5360 : : ABI_ERROR("Neither buffer_cplx nor buffer_real are allocated!")
5361 : : end if
5362 : : end select
5363 : :
5364 : : class default
5365 : : ABI_ERROR("Wrong class")
5366 : : end select
5367 : : #endif
5368 : :
5369 [ # # ]: 0 : if (present(free)) then
5370 [ # # ]: 0 : if (free) call in_mat%free()
5371 : : end if
5372 : :
5373 : 0 : end subroutine basemat_change_size_blocs
5374 : : !!***
5375 : :
5376 : : !----------------------------------------------------------------------
5377 : :
5378 : : !!****f* m_slk/slkmat_dp_cut
5379 : : !! NAME
5380 : : !! slkmat_dp_cut
5381 : : !!
5382 : : !! FUNCTION
5383 : : !! Extract submatrix of shape (glob_nrows, glob_ncols) starting at `ija` from `in_mat`
5384 : : !! and create new matrix with `size_blocs` and `processor`
5385 : : !!
5386 : : !! INPUTS
5387 : : !! [free]: True if `in_mat` should be deallocated. Default: False
5388 : : !!
5389 : : !! OUTPUT
5390 : : !!
5391 : : !! SOURCE
5392 : :
5393 [ # # ]: 0 : subroutine slkmat_dp_cut(in_mat, glob_nrows, glob_ncols, out_mat, &
5394 : : size_blocs, processor, ija, ijb, free) ! Optional
5395 : :
5396 : : !Arguments ------------------------------------
5397 : : class(slkmat_dp_t),target,intent(inout) :: in_mat
5398 : : integer,intent(in) :: glob_nrows, glob_ncols
5399 : : class(slkmat_dp_t),intent(out) :: out_mat
5400 : : integer,optional,intent(in) :: size_blocs(2)
5401 : : class(slk_processor_t), target, optional,intent(in) :: processor
5402 : : integer,optional,intent(in) :: ija(2), ijb(2)
5403 : : logical,optional,intent(in) :: free
5404 : :
5405 : : !Local variables-------------------------------
5406 : : type(slk_processor_t), pointer :: processor__
5407 : : integer :: ija__(2), ijb__(2)
5408 : : ! *************************************************************************
5409 : :
5410 : 0 : ija__ = [1, 1]; if (present(ija)) ija__ = ija
5411 : 0 : ijb__ = [1, 1]; if (present(ijb)) ijb__ = ijb
5412 : :
5413 [ # # # # ]: 0 : processor__ => in_mat%processor; if (present(processor)) processor__ => processor
5414 : :
5415 [ # # ]: 0 : if (present(size_blocs)) then
5416 : 0 : call out_mat%init(glob_nrows, glob_ncols, processor__, in_mat%istwf_k, size_blocs=size_blocs)
5417 : : else
5418 : 0 : call out_mat%init(glob_nrows, glob_ncols, processor__, in_mat%istwf_k)
5419 : : end if
5420 : : !call out_mat%print(header="output matrix generated by slkmat_dp_cut")
5421 : :
5422 : : ! p?gemr2d: Copies a submatrix from one general rectangular matrix to another.
5423 : : ! prototype
5424 : : !call pzgemr2d(m, n, a, ia, ja, desca, b, ib, jb, descb, comm)
5425 : :
5426 [ # # ]: 0 : if (allocated(in_mat%buffer_cplx)) then
5427 : : #ifdef HAVE_LINALG_SCALAPACK
5428 : : call pzgemr2d(glob_nrows, glob_ncols, &
5429 : : in_mat%buffer_cplx, ija__(1), ija__(2), in_mat%desc, &
5430 : : out_mat%buffer_cplx, ijb__(1), ijb__(2), out_mat%desc, &
5431 : : processor__%grid%comm)
5432 : :
5433 : : else if (allocated(in_mat%buffer_real)) then
5434 : : call pdgemr2d(glob_nrows, glob_ncols, &
5435 : : in_mat%buffer_real, ija__(1), ija__(2), in_mat%desc, &
5436 : : out_mat%buffer_real, ijb__(1), ijb__(2), out_mat%desc, &
5437 : : processor__%grid%comm)
5438 : : #endif
5439 : : else
5440 : 0 : ABI_ERROR("Neither buffer_cplx nor buffer_real are allocated!")
5441 : : end if
5442 : :
5443 [ # # ]: 0 : if (present(free)) then
5444 [ # # ]: 0 : if (free) call in_mat%free()
5445 : : end if
5446 : :
5447 : 0 : end subroutine slkmat_dp_cut
5448 : : !!***
5449 : :
5450 : : !----------------------------------------------------------------------
5451 : :
5452 : : !!****f* m_slk/slkmat_sp_cut
5453 : : !! NAME
5454 : : !! slkmat_sp_cut
5455 : : !!
5456 : : !! FUNCTION
5457 : : !! Extract submatrix of shape (glob_nrows, glob_ncols) starting at `ija` from `in_mat`
5458 : : !! and create new matrix with `size_blocs` and `processor`
5459 : : !!
5460 : : !! INPUTS
5461 : : !! [free]: True if `in_mat` should be deallocated. Default: False
5462 : : !!
5463 : : !! OUTPUT
5464 : : !!
5465 : : !! SOURCE
5466 : :
5467 [ # # ]: 0 : subroutine slkmat_sp_cut(in_mat, glob_nrows, glob_ncols, out_mat, &
5468 : : size_blocs, processor, ija, ijb, free) ! Optional
5469 : :
5470 : : !Arguments ------------------------------------
5471 : : class(slkmat_sp_t),target,intent(inout) :: in_mat
5472 : : integer,intent(in) :: glob_nrows, glob_ncols
5473 : : class(slkmat_sp_t),intent(out) :: out_mat
5474 : : integer,optional,intent(in) :: size_blocs(2)
5475 : : class(slk_processor_t), target, optional,intent(in) :: processor
5476 : : integer,optional,intent(in) :: ija(2), ijb(2)
5477 : : logical,optional,intent(in) :: free
5478 : :
5479 : : !Local variables-------------------------------
5480 : : type(slk_processor_t), pointer :: processor__
5481 : : integer :: ija__(2), ijb__(2)
5482 : : ! *************************************************************************
5483 : :
5484 : 0 : ija__ = [1, 1]; if (present(ija)) ija__ = ija
5485 : 0 : ijb__ = [1, 1]; if (present(ijb)) ijb__ = ijb
5486 : :
5487 [ # # # # ]: 0 : processor__ => in_mat%processor; if (present(processor)) processor__ => processor
5488 : :
5489 [ # # ]: 0 : if (present(size_blocs)) then
5490 : 0 : call out_mat%init(glob_nrows, glob_ncols, processor__, in_mat%istwf_k, size_blocs=size_blocs)
5491 : : else
5492 : 0 : call out_mat%init(glob_nrows, glob_ncols, processor__, in_mat%istwf_k)
5493 : : end if
5494 : : !call out_mat%print(header="output matrix generated by slkmat_dp_cut")
5495 : :
5496 : : ! p?gemr2d: Copies a submatrix from one general rectangular matrix to another.
5497 : : ! prototype
5498 : : !call pzgemr2d(m, n, a, ia, ja, desca, b, ib, jb, descb, comm)
5499 : :
5500 [ # # ]: 0 : if (allocated(in_mat%buffer_cplx)) then
5501 : : #ifdef HAVE_LINALG_SCALAPACK
5502 : : call pcgemr2d(glob_nrows, glob_ncols, &
5503 : : in_mat%buffer_cplx, ija__(1), ija__(2), in_mat%desc, &
5504 : : out_mat%buffer_cplx, ijb__(1), ijb__(2), out_mat%desc, &
5505 : : processor__%grid%comm)
5506 : :
5507 : : else if (allocated(in_mat%buffer_real)) then
5508 : : call psgemr2d(glob_nrows, glob_ncols, &
5509 : : in_mat%buffer_real, ija__(1), ija__(2), in_mat%desc, &
5510 : : out_mat%buffer_real, ijb__(1), ijb__(2), out_mat%desc, &
5511 : : processor__%grid%comm)
5512 : : #endif
5513 : : else
5514 : 0 : ABI_ERROR("Neither buffer_cplx nor buffer_real are allocated!")
5515 : : end if
5516 : :
5517 [ # # ]: 0 : if (present(free)) then
5518 [ # # ]: 0 : if (free) call in_mat%free()
5519 : : end if
5520 : :
5521 : 0 : end subroutine slkmat_sp_cut
5522 : : !!***
5523 : :
5524 : : !----------------------------------------------------------------------
5525 : :
5526 : : !!****f* m_slk/slkmat_dp_take_from
5527 : : !! NAME
5528 : : !! slkmat_dp_take_from
5529 : : !!
5530 : : !! FUNCTION
5531 : : !! Take values from source
5532 : : !! NB: This routine should be called by all procs owning mat and source.
5533 : : !!
5534 : : !! INPUTS
5535 : : !! [free]: True if source should be deallocated. Default: False
5536 : : !!
5537 : : !! OUTPUT
5538 : : !!
5539 : : !! SOURCE
5540 : :
5541 : 0 : subroutine slkmat_dp_take_from(out_mat, source, &
5542 : : ija, ijb, free) ! optional
5543 : :
5544 : : !Arguments ------------------------------------
5545 : : class(slkmat_dp_t),intent(inout) :: out_mat
5546 : : class(slkmat_dp_t),intent(inout) :: source
5547 : : integer,optional,intent(in) :: ija(2), ijb(2)
5548 : : logical,optional,intent(in) :: free
5549 : :
5550 : : !Local variables-------------------------------
5551 : : integer :: mm, nn
5552 : : character(len=500) :: msg
5553 : : integer :: ija__(2), ijb__(2)
5554 : : ! *************************************************************************
5555 : :
5556 : : ! prototype
5557 : : !call pzgemr2d(m, n, a, ia, ja, desca, b, ib, jb, descb, comm)
5558 : :
5559 : : ! Take care when context A is disjoint from context B. The general rules for which parameters need to be set are:
5560 : : !
5561 : : ! - All calling processes must have the correct m and n.
5562 : : ! - Processes in context A must correctly define all parameters describing A.
5563 : : ! - Processes in context B must correctly define all parameters describing B.
5564 : : ! - Processes which are not members of context A must pass ctxt_a = -1 and need not set other parameters describing A.
5565 : : ! - Processes which are not members of contextB must pass ctxt_b = -1 and need not set other parameters describing B.
5566 : :
5567 : 0 : mm = source%size_global(1)
5568 : 0 : nn = source%size_global(2)
5569 : :
5570 : 0 : ija__ = [1, 1]; if (present(ija)) ija__ = ija
5571 : 0 : ijb__ = [1, 1]; if (present(ijb)) ijb__ = ijb
5572 : :
5573 [ # # # # : 0 : if (all(out_mat%size_global == -1)) then
# # ]
5574 : 0 : out_mat%desc(CTXT_) = -1
5575 : : else
5576 [ # # ]: 0 : ABI_CHECK_IEQ(out_mat%istwf_k, source%istwf_k, "istwfk_mat /= istwfk_source")
5577 [ # # # # : 0 : if (any(out_mat%size_global /= source%size_global)) then
# # ]
5578 : : msg = sjoin("Matrices should have same global shape but out_mat:", ltoa(out_mat%size_global), &
5579 [ # # ]: 0 : "source:", ltoa(source%size_global))
5580 : 0 : ABI_ERROR(msg)
5581 : : end if
5582 : : end if
5583 : :
5584 [ # # ]: 0 : if (allocated(source%buffer_cplx)) then
5585 : : #ifdef HAVE_LINALG_SCALAPACK
5586 : : call pzgemr2d(mm, nn, &
5587 : : source%buffer_cplx, ija__(1), ija__(2), source%desc, &
5588 : : out_mat%buffer_cplx, ijb__(1), ijb__(2), out_mat%desc, &
5589 : : source%processor%grid%comm)
5590 : :
5591 : : else if (allocated(source%buffer_real)) then
5592 : : call pdgemr2d(mm, nn, &
5593 : : source%buffer_real, ija__(1), ija__(2), source%desc, &
5594 : : out_mat%buffer_real,ijb__(1), ijb__(2), out_mat%desc, &
5595 : : source%processor%grid%comm)
5596 : : #endif
5597 : : else
5598 : 0 : ABI_ERROR("Neither buffer_cplx nor buffer_real are allocated!")
5599 : : end if
5600 : :
5601 [ # # ]: 0 : if (present(free)) then
5602 [ # # ]: 0 : if (free) call source%free()
5603 : : end if
5604 : :
5605 : 0 : end subroutine slkmat_dp_take_from
5606 : : !!***
5607 : :
5608 : : !----------------------------------------------------------------------
5609 : :
5610 : : !!****f* m_slk/slkmat_sp_take_from
5611 : : !! NAME
5612 : : !! slkmat_sp_take_from
5613 : : !!
5614 : : !! FUNCTION
5615 : : !! Take values from source
5616 : : !! NB: This routine should be called by all procs owning mat and source.
5617 : : !!
5618 : : !! INPUTS
5619 : : !! [free]: True if source should be deallocated. Default: False
5620 : : !!
5621 : : !! OUTPUT
5622 : : !!
5623 : : !! SOURCE
5624 : :
5625 : 0 : subroutine slkmat_sp_take_from(out_mat, source, &
5626 : : ija, ijb, free) ! optional
5627 : :
5628 : : !Arguments ------------------------------------
5629 : : class(slkmat_sp_t),intent(inout) :: out_mat
5630 : : class(slkmat_sp_t),intent(inout) :: source
5631 : : integer,optional,intent(in) :: ija(2), ijb(2)
5632 : : logical,optional,intent(in) :: free
5633 : :
5634 : : !Local variables-------------------------------
5635 : : integer :: mm, nn
5636 : : character(len=500) :: msg
5637 : : integer :: ija__(2), ijb__(2)
5638 : : ! *************************************************************************
5639 : :
5640 : : ! prototype
5641 : : !call pzgemr2d(m, n, a, ia, ja, desca, b, ib, jb, descb, comm)
5642 : :
5643 : : ! Take care when context A is disjoint from context B. The general rules for which parameters need to be set are:
5644 : : !
5645 : : ! - All calling processes must have the correct m and n.
5646 : : ! - Processes in context A must correctly define all parameters describing A.
5647 : : ! - Processes in context B must correctly define all parameters describing B.
5648 : : ! - Processes which are not members of context A must pass ctxt_a = -1 and need not set other parameters describing A.
5649 : : ! - Processes which are not members of contextB must pass ctxt_b = -1 and need not set other parameters describing B.
5650 : :
5651 : 0 : mm = source%size_global(1)
5652 : 0 : nn = source%size_global(2)
5653 : :
5654 : 0 : ija__ = [1, 1]; if (present(ija)) ija__ = ija
5655 : 0 : ijb__ = [1, 1]; if (present(ijb)) ijb__ = ijb
5656 : :
5657 [ # # # # : 0 : if (all(out_mat%size_global == -1)) then
# # ]
5658 : 0 : out_mat%desc(CTXT_) = -1
5659 : : else
5660 [ # # ]: 0 : ABI_CHECK_IEQ(out_mat%istwf_k, source%istwf_k, "istwfk_mat /= istwfk_source")
5661 [ # # # # : 0 : if (any(out_mat%size_global /= source%size_global)) then
# # ]
5662 : : msg = sjoin("Matrices should have same global shape but out_mat:", ltoa(out_mat%size_global), &
5663 [ # # ]: 0 : "source:", ltoa(source%size_global))
5664 : 0 : ABI_ERROR(msg)
5665 : : end if
5666 : : end if
5667 : :
5668 [ # # ]: 0 : if (allocated(source%buffer_cplx)) then
5669 : : #ifdef HAVE_LINALG_SCALAPACK
5670 : : call pcgemr2d(mm, nn, &
5671 : : source%buffer_cplx, ija__(1), ija__(2), source%desc, &
5672 : : out_mat%buffer_cplx, ijb__(1), ijb__(2), out_mat%desc, &
5673 : : source%processor%grid%comm)
5674 : :
5675 : : else if (allocated(source%buffer_real)) then
5676 : : call psgemr2d(mm, nn, &
5677 : : source%buffer_real, ija__(1), ija__(2), source%desc, &
5678 : : out_mat%buffer_real,ijb__(1), ijb__(2), out_mat%desc, &
5679 : : source%processor%grid%comm)
5680 : : #endif
5681 : : else
5682 : 0 : ABI_ERROR("Neither buffer_cplx nor buffer_real are allocated!")
5683 : : end if
5684 : :
5685 [ # # ]: 0 : if (present(free)) then
5686 [ # # ]: 0 : if (free) call source%free()
5687 : : end if
5688 : :
5689 : 0 : end subroutine slkmat_sp_take_from
5690 : : !!***
5691 : :
5692 : : !----------------------------------------------------------------------
5693 : :
5694 : : !!****f* m_slk/slkmat_dp_collect_cplx
5695 : : !! NAME
5696 : : !! slkmat_dp_collect_cplx
5697 : : !!
5698 : : !! FUNCTION
5699 : : !! Return on all processors the complex submatrix of shape (mm, nn) starting at position ija.
5700 : : !! NB: `out_carr` is allocated by the routine.
5701 : : !! If optional argument request is use, the routine uses non-blocking BCAST and client code is
5702 : : !! supposed to wait before accessing out_carr.
5703 : : !!
5704 : : !! SOURCE
5705 : :
5706 : 0 : subroutine slkmat_dp_collect_cplx(in_mat, mm, nn, ija, out_carr, request)
5707 : :
5708 : : !Arguments ------------------------------------
5709 : : class(slkmat_dp_t),intent(in) :: in_mat
5710 : : integer,intent(in) :: mm, nn, ija(2)
5711 : : complex(dp) ABI_ASYNC, allocatable,intent(out) :: out_carr(:,:)
5712 : : integer ABI_ASYNC, optional,intent(out) :: request
5713 : :
5714 : : !Local variables-------------------------------
5715 : : integer,parameter :: master = 0
5716 : : integer :: ierr
5717 : : type(slk_processor_t) :: self_processor
5718 [ # # # # : 0 : type(slkmat_dp_t) :: out_mat
# # ]
5719 : : ! *************************************************************************
5720 : :
5721 : 0 : ABI_CHECK(allocated(in_mat%buffer_cplx), "buffer_cplx is not allocated")
5722 : :
5723 [ # # ]: 0 : if (in_mat%processor%grid%nprocs == 1) then
5724 : : ! Copy buffer and return
5725 [ # # # # : 0 : ABI_MALLOC(out_carr, (mm, nn))
# # # # #
# # # # #
# # # # ]
5726 [ # # # # ]: 0 : out_carr(:,:) = in_mat%buffer_cplx(ija(1):ija(1)+mm-1, ija(2):ija(2)+nn-1); return
5727 : : end if
5728 : :
5729 : : ! Two-step algorithm:
5730 : : ! 1) Use pzgemr2d to collect submatrix on master.
5731 : : ! 2) Master brodacasts submatrix.
5732 : :
5733 [ # # ]: 0 : if (in_mat%processor%my_rank == master) then
5734 : 0 : call self_processor%init(xmpi_comm_self)
5735 [ # # ]: 0 : call out_mat%init(mm, nn, self_processor, in_mat%istwf_k, size_blocs=[mm, nn])
5736 : : else
5737 : 0 : out_mat%desc(CTXT_) = -1
5738 : : end if
5739 : :
5740 : : #ifdef HAVE_LINALG_SCALAPACK
5741 : : call pzgemr2d(mm, nn, &
5742 : : in_mat%buffer_cplx, ija(1), ija(2), in_mat%desc, &
5743 : : out_mat%buffer_cplx, 1, 1, out_mat%desc, &
5744 : : in_mat%processor%grid%comm)
5745 : : #endif
5746 : :
5747 [ # # ]: 0 : if (in_mat%processor%my_rank == master) then
5748 [ # # ]: 0 : ABI_MOVE_ALLOC(out_mat%buffer_cplx, out_carr)
5749 : 0 : call out_mat%free()
5750 : 0 : call self_processor%free()
5751 : : else
5752 [ # # # # : 0 : ABI_MALLOC(out_carr, (mm, nn))
# # # # #
# # # # #
# # # # ]
5753 : : end if
5754 : :
5755 [ # # ]: 0 : if (present(request)) then
5756 : 0 : call xmpi_ibcast(out_carr, master, in_mat%processor%comm, request, ierr)
5757 : : else
5758 : 0 : call xmpi_bcast(out_carr, master, in_mat%processor%comm, ierr)
5759 : : end if
5760 : :
5761 [ # # # # : 0 : end subroutine slkmat_dp_collect_cplx
# # # # #
# # # #
# ]
5762 : : !!***
5763 : :
5764 : : !----------------------------------------------------------------------
5765 : :
5766 : : !!****f* m_slk/slkmat_sp_collect_cplx
5767 : : !! NAME
5768 : : !! slkmat_sp_collect_cplx
5769 : : !!
5770 : : !! FUNCTION
5771 : : !! Return on all processors the complex submatrix of shape (mm, nn) starting at position ija.
5772 : : !! NB: `out_carr` is allocated by the routine.
5773 : : !! If optional argument request is use, the routine uses non-blocking BCAST and client code is
5774 : : !! supposed to wait before accessing out_carr.
5775 : : !!
5776 : : !! SOURCE
5777 : :
5778 : 0 : subroutine slkmat_sp_collect_cplx(in_mat, mm, nn, ija, out_carr, request)
5779 : :
5780 : : !Arguments ------------------------------------
5781 : : class(slkmat_sp_t),intent(in) :: in_mat
5782 : : integer,intent(in) :: mm, nn, ija(2)
5783 : : complex(sp) ABI_ASYNC, allocatable,intent(out) :: out_carr(:,:)
5784 : : integer ABI_ASYNC, optional,intent(out) :: request
5785 : :
5786 : : !Local variables-------------------------------
5787 : : integer,parameter :: master = 0
5788 : : integer :: ierr
5789 : : type(slk_processor_t) :: self_processor
5790 [ # # # # : 0 : type(slkmat_sp_t) :: out_mat
# # ]
5791 : : ! *************************************************************************
5792 : :
5793 : 0 : ABI_CHECK(allocated(in_mat%buffer_cplx), "buffer_cplx is not allocated")
5794 : :
5795 [ # # ]: 0 : if (in_mat%processor%grid%nprocs == 1) then
5796 : : ! Copy buffer and return
5797 [ # # # # : 0 : ABI_MALLOC(out_carr, (mm, nn))
# # # # #
# # # # #
# # # # ]
5798 [ # # # # ]: 0 : out_carr(:,:) = in_mat%buffer_cplx(ija(1):ija(1)+mm-1, ija(2):ija(2)+nn-1); return
5799 : : end if
5800 : :
5801 : : ! Two-step algorithm:
5802 : : ! 1) Use pzgemr2d to collect submatrix on master.
5803 : : ! 2) Master brodacasts submatrix.
5804 : :
5805 [ # # ]: 0 : if (in_mat%processor%my_rank == master) then
5806 : 0 : call self_processor%init(xmpi_comm_self)
5807 [ # # ]: 0 : call out_mat%init(mm, nn, self_processor, in_mat%istwf_k, size_blocs=[mm, nn])
5808 : : else
5809 : 0 : out_mat%desc(CTXT_) = -1
5810 : : end if
5811 : :
5812 : : #ifdef HAVE_LINALG_SCALAPACK
5813 : : call pcgemr2d(mm, nn, &
5814 : : in_mat%buffer_cplx, ija(1), ija(2), in_mat%desc, &
5815 : : out_mat%buffer_cplx, 1, 1, out_mat%desc, &
5816 : : in_mat%processor%grid%comm)
5817 : : #endif
5818 : :
5819 [ # # ]: 0 : if (in_mat%processor%my_rank == master) then
5820 [ # # ]: 0 : ABI_MOVE_ALLOC(out_mat%buffer_cplx, out_carr)
5821 : 0 : call out_mat%free()
5822 : 0 : call self_processor%free()
5823 : : else
5824 [ # # # # : 0 : ABI_MALLOC(out_carr, (mm, nn))
# # # # #
# # # # #
# # # # ]
5825 : : end if
5826 : :
5827 [ # # ]: 0 : if (present(request)) then
5828 : 0 : call xmpi_ibcast(out_carr, master, in_mat%processor%comm, request, ierr)
5829 : : else
5830 : 0 : call xmpi_bcast(out_carr, master, in_mat%processor%comm, ierr)
5831 : : end if
5832 : :
5833 [ # # # # : 0 : end subroutine slkmat_sp_collect_cplx
# # # # #
# # # #
# ]
5834 : : !!***
5835 : :
5836 : : !----------------------------------------------------------------------
5837 : :
5838 : : !!****f* m_slk/basemat_get_trace
5839 : : !! NAME
5840 : : !! basemat_get_trace
5841 : : !!
5842 : : !! FUNCTION
5843 : : !! Compute the trace of an N-by-N distributed matrix.
5844 : : !!
5845 : : !! SOURCE
5846 : :
5847 : 0 : complex(dp) function basemat_get_trace(mat) result(ctrace)
5848 : :
5849 : : !Arguments ------------------------------------
5850 : : class(basemat_t), intent(in) :: mat
5851 : :
5852 : : !Local variables-------------------------------
5853 : : #ifdef HAVE_LINALG_SCALAPACK
5854 : : integer :: iloc, jloc, iglob, jglob, ierr
5855 : : real(dp) :: rtrace
5856 : : real(sp) :: rtrace_sp
5857 : : complex(sp) :: ctrace_sp
5858 : : #endif
5859 : : ! *************************************************************************
5860 : :
5861 [ # # ]: 0 : ABI_CHECK_IEQ(mat%size_global(1), mat%size_global(2), "get_trace assumes square matrix!")
5862 : :
5863 : : ! prototype for complex version.
5864 : : ! COMPLEX*16 FUNCTION PZLATRA( N, A, IA, JA, DESCA )
5865 : : !
5866 : : ! NOTE: We don't use PZLATRA and friends as these calls can lead to SIGSEGV when
5867 : : ! we compile with gcc and link with intel scalack (very likely there's an ABI mismatch
5868 : : ! even when the compatibily layer is used --> we implement our own version.
5869 : :
5870 : : #ifdef HAVE_LINALG_SCALAPACK
5871 : : select type (mat)
5872 : : class is (slkmat_dp_t)
5873 : : if (allocated(mat%buffer_cplx)) then
5874 : : !ctrace = PZLATRA(mat%size_global(1), mat%buffer_cplx, 1, 1, mat%desc)
5875 : : ctrace = zero
5876 : : do jloc=1,mat%size_local(2)
5877 : : do iloc=1,mat%size_local(1)
5878 : : call mat%loc2glob(iloc, jloc, iglob, jglob)
5879 : : if (iglob == jglob) ctrace = ctrace + mat%buffer_cplx(iloc, jloc)
5880 : : end do
5881 : : end do
5882 : :
5883 : : else if (allocated(mat%buffer_real)) then
5884 : : !rtrace = PDLATRA(mat%size_global(1), mat%buffer_real, 1, 1, mat%desc)
5885 : : rtrace = zero
5886 : : do jloc=1,mat%size_local(2)
5887 : : do iloc=1,mat%size_local(1)
5888 : : call mat%loc2glob(iloc, jloc, iglob, jglob)
5889 : : if (iglob == jglob) rtrace = rtrace + mat%buffer_real(iloc, jloc)
5890 : : end do
5891 : : end do
5892 : : ctrace = rtrace
5893 : :
5894 : : else
5895 : : ABI_ERROR("Neither buffer_cplx nor buffer_real are allocated!")
5896 : : end if
5897 : :
5898 : : class is (slkmat_sp_t)
5899 : : if (allocated(mat%buffer_cplx)) then
5900 : : !ctrace_sp = PCLATRA(mat%size_global(1), mat%buffer_cplx, 1, 1, mat%desc)
5901 : : ctrace_sp = zero
5902 : : do jloc=1,mat%size_local(2)
5903 : : do iloc=1,mat%size_local(1)
5904 : : call mat%loc2glob(iloc, jloc, iglob, jglob)
5905 : : if (iglob == jglob) ctrace_sp = ctrace_sp + mat%buffer_cplx(iloc, jloc)
5906 : : end do
5907 : : end do
5908 : : ctrace = ctrace_sp
5909 : :
5910 : : else if (allocated(mat%buffer_real)) then
5911 : : !rtrace_sp = PSLATRA(mat%size_global(1), mat%buffer_real, 1, 1, mat%desc)
5912 : : rtrace_sp = zero
5913 : : do jloc=1,mat%size_local(2)
5914 : : do iloc=1,mat%size_local(1)
5915 : : call mat%loc2glob(iloc, jloc, iglob, jglob)
5916 : : if (iglob == jglob) rtrace_sp = rtrace_sp + mat%buffer_real(iloc, jloc)
5917 : : end do
5918 : : end do
5919 : : ctrace = rtrace_sp
5920 : :
5921 : : else
5922 : : ABI_ERROR("Neither buffer_cplx nor buffer_real are allocated!")
5923 : : end if
5924 : :
5925 : : class default
5926 : : ABI_ERROR("Wrong class")
5927 : : end select
5928 : :
5929 : : call xmpi_sum(ctrace, mat%processor%comm, ierr)
5930 : : #endif
5931 : :
5932 : 0 : end function basemat_get_trace
5933 : : !!***
5934 : :
5935 : : !----------------------------------------------------------------------
5936 : :
5937 : : !!****f* m_slk/basemat_set_imag_diago_to_zero
5938 : : !! NAME
5939 : : !! basemat_set_imag_diago_to_zero
5940 : : !!
5941 : : !! FUNCTION
5942 : : !! Set the imaginary part of the diagonal to zero.
5943 : : !! Return in local_max the max of the imaginar part in the local buffer.
5944 : : !! No MPI communication is performed inside the routine. Client code can easily reduce
5945 : : !! local_max within the PBLAS communicator if needed.
5946 : : !!
5947 : : !! INPUTS
5948 : : !!
5949 : : !! OUTPUT
5950 : : !!
5951 : : !! SOURCE
5952 : :
5953 : 0 : subroutine basemat_set_imag_diago_to_zero(mat, local_max)
5954 : :
5955 : : !Arguments ------------------------------------
5956 : : class(basemat_t), intent(inout) :: mat
5957 : : real(dp),intent(out) :: local_max
5958 : :
5959 : : !Local variables-------------------------------
5960 : : integer :: il1, iglob1, il2, iglob2
5961 : : ! *************************************************************************
5962 : :
5963 : 0 : local_max = -huge(one)
5964 : :
5965 : : select type (mat)
5966 : : class is (slkmat_dp_t)
5967 [ # # ]: 0 : if (allocated(mat%buffer_real)) return
5968 [ # # ]: 0 : do il2=1,mat%size_local(2)
5969 : 0 : iglob2 = mat%loc2gcol(il2)
5970 [ # # ]: 0 : do il1=1,mat%size_local(1)
5971 : 0 : iglob1 = mat%loc2grow(il1)
5972 [ # # ]: 0 : if (iglob1 == iglob2) then
5973 : 0 : local_max = max(local_max, aimag(mat%buffer_cplx(il1, il2)))
5974 : 0 : mat%buffer_cplx(il1, il2) = real(mat%buffer_cplx(il1, il2))
5975 : : end if
5976 : : end do
5977 : : end do
5978 : :
5979 : : class is (slkmat_sp_t)
5980 [ # # ]: 0 : if (allocated(mat%buffer_real)) return
5981 [ # # ]: 0 : do il2=1,mat%size_local(2)
5982 : 0 : iglob2 = mat%loc2gcol(il2)
5983 [ # # ]: 0 : do il1=1,mat%size_local(1)
5984 : 0 : iglob1 = mat%loc2grow(il1)
5985 [ # # ]: 0 : if (iglob1 == iglob2) then
5986 : 0 : local_max = max(local_max, aimag(mat%buffer_cplx(il1, il2)))
5987 : 0 : mat%buffer_cplx(il1, il2) = real(mat%buffer_cplx(il1, il2))
5988 : : end if
5989 : : end do
5990 : : end do
5991 : :
5992 : : class default
5993 : 0 : ABI_ERROR("Wrong class")
5994 : : end select
5995 : :
5996 : : end subroutine basemat_set_imag_diago_to_zero
5997 : : !!***
5998 : :
5999 : : !----------------------------------------------------------------------
6000 : :
6001 : : !!****f* m_slk/slk_write
6002 : : !! NAME
6003 : : !! slk_write
6004 : : !!
6005 : : !! FUNCTION
6006 : : !! Routine to write a square scaLAPACK-distributed matrix to an external file using MPI-IO.
6007 : : !!
6008 : : !! INPUTS
6009 : : !! Slk_mat<slkmat_dp_t>=Structured datatype defining the scaLAPACK distribution with the local buffer
6010 : : !! containing the distributed matrix.
6011 : : !! uplo=String specifying whether only the upper or lower triangular part of the global matrix is used:
6012 : : !! = "U": Upper triangular
6013 : : !! = "L": Lower triangular
6014 : : !! = "A": Full matrix (used for general complex matrices)
6015 : : !! is_fortran_file=.FALSE. is C stream is used. .TRUE. for writing Fortran binary files.
6016 : : !! [fname]= Mutually exclusive with mpi_fh. The name of the external file on which the matrix will be written.
6017 : : !! The file is open and closed inside the routine with MPI flags specified by flags.
6018 : : !! [mpi_fh]=File handler associated to the file (already open in the caller). Not compatible with fname.
6019 : : !! [flags]=MPI-IO flags used to open the file in MPI_FILE_OPEN.
6020 : : !! Default is MPI_MODE_CREATE + MPI_MODE_WRONLY + MPI_MODE_EXCL.
6021 : : !! [glob_subarray(2,2)] = Used to select the subarray of the global matrix. Used only when uplo="All"
6022 : : !! NOTE that each node should call the routine with the same value.
6023 : : !! glob_subarray(:,1)=starting global coordinates of the subarray in each dimension
6024 : : !! (array of nonnegative integers >=1, <=array_of_sizes)
6025 : : !! glob_subarray(:,2)=Number of elements in each dimension of the subarray (array of positive integers)
6026 : : !!
6027 : : !! OUTPUT
6028 : : !! Only writing. The global scaLAPACK matrix is written to file fname.
6029 : : !! If fname is present then the file is open and closed inside the routine. Any exception is fatal.
6030 : : !!
6031 : : !! SIDE EFFECTS
6032 : : !! [offset]=
6033 : : !! input: Offset used to access the content of the file. Default is zero.
6034 : : !! output: New offset incremented with the byte size of the matrix that has been read (Fortran
6035 : : !! markers are included if is_fortran_file=.TRUE.)
6036 : : !! TODO
6037 : : !! - Generalize the implementation adding the writing the real buffer.
6038 : : !! - This routine should be removed and replaced by hdf5 + mpi-io
6039 : : !!
6040 : : !! SOURCE
6041 : :
6042 : 0 : subroutine slk_write(Slk_mat, uplo, is_fortran_file, fname,mpi_fh, offset, flags, glob_subarray)
6043 : :
6044 : : !Arguments ------------------------------------
6045 : : !scalars
6046 : : integer,optional,intent(in) :: flags
6047 : : integer,optional,intent(inout) :: mpi_fh
6048 : : integer(XMPI_OFFSET_KIND),optional,intent(inout) :: offset
6049 : : logical,intent(in) :: is_fortran_file
6050 : : character(len=*),optional,intent(in) :: fname
6051 : : character(len=*),intent(in) :: uplo
6052 : : class(slkmat_dp_t),intent(in) :: Slk_mat
6053 : : !array
6054 : : integer,optional,intent(in) :: glob_subarray(2,2)
6055 : :
6056 : : !Local variables ------------------------------
6057 : : !scalars
6058 : : #if defined HAVE_LINALG_SCALAPACK && defined HAVE_MPI_IO
6059 : : integer :: jloc,iloc,nrows_glob,ncols_glob,elw,nrows_w,ncols_w ! iglob,jglob,
6060 : : integer :: slk_type,offset_err,etype,nfrec,bsize_elm,mpi_type_elm
6061 : : integer(XMPI_OFFSET_KIND) :: my_offset
6062 : : logical :: do_open
6063 : : integer :: comm,my_flags,my_fh,buffer_size
6064 : : integer :: ierr,nelw,col_glob ! ij_loc,
6065 : : !arrays
6066 : : integer(XMPI_OFFSET_KIND),allocatable :: bsize_frecord(:)
6067 : : integer,pointer :: elw2slk(:,:)
6068 : : complex(dpc),allocatable :: buffer1_cplx(:)
6069 : : character(len=500) :: msg
6070 : : !************************************************************************
6071 : :
6072 : : ABI_CHECK(allocated(Slk_mat%buffer_cplx), "buffer_cplx not allocated")
6073 : :
6074 : : if (firstchar(uplo, ["U","L"]) .and. Slk_mat%size_global(1) /= Slk_mat%size_global(2) ) then
6075 : : ABI_ERROR("rectangular matrices are not compatible with the specified uplo")
6076 : : end if
6077 : :
6078 : : if (PRESENT(glob_subarray).and. .not. firstchar(uplo, ["A"])) then
6079 : : ABI_ERROR("glob_subarray should not be used when uplo/=All")
6080 : : end if
6081 : :
6082 : : do_open = PRESENT(fname)
6083 : : if (do_open) then
6084 : : ABI_CHECK(.not.PRESENT(fname),"fname should not be present")
6085 : : else
6086 : : ABI_CHECK(PRESENT(mpi_fh),"mpi_fh should be present")
6087 : : end if
6088 : :
6089 : : my_offset=0; if (PRESENT(offset)) my_offset=offset
6090 : :
6091 : : comm = Slk_mat%processor%comm
6092 : :
6093 : : nrows_glob=Slk_mat%size_global(1)
6094 : : ncols_glob=Slk_mat%size_global(1)
6095 : : buffer_size= PRODUCT(Slk_mat%size_local(1:2))
6096 : :
6097 : : call slk_mat%bsize_and_type(bsize_elm, mpi_type_elm)
6098 : :
6099 : : if (do_open) then !Open the file.
6100 : : my_flags=MPI_MODE_CREATE + MPI_MODE_WRONLY + MPI_MODE_APPEND
6101 : : if (PRESENT(flags)) my_flags = flags
6102 : :
6103 : : call MPI_FILE_OPEN(comm, fname, my_flags, MPI_INFO_NULL, my_fh, ierr)
6104 : : ABI_CHECK_MPI(ierr, "MPI_FILE_OPEN "//TRIM(fname))
6105 : : else
6106 : : my_fh = mpi_fh
6107 : : end if
6108 : :
6109 : : if (PRESENT(glob_subarray)) then
6110 : : call slk_single_fview_write(Slk_mat,uplo,nelw,elw2slk,etype,slk_type,offset_err,&
6111 : : is_fortran_file=is_fortran_file,glob_subarray=glob_subarray)
6112 : : else
6113 : : call slk_single_fview_write(Slk_mat,uplo,nelw,elw2slk,etype,slk_type,offset_err,&
6114 : : is_fortran_file=is_fortran_file)
6115 : : end if
6116 : :
6117 : : if (offset_err /= 0) then
6118 : : write(msg,"(3a)")&
6119 : : " Global position index cannot be stored in standard Fortran integer ",ch10,&
6120 : : " scaLAPACK matrix cannot be read with a single MPI-IO call."
6121 : : ABI_ERROR(msg)
6122 : : end if
6123 : :
6124 : : call MPI_FILE_SET_VIEW(my_fh, my_offset, etype, slk_type, 'native', MPI_INFO_NULL, ierr)
6125 : : ABI_CHECK_MPI(ierr,"SET_VIEW")
6126 : :
6127 : : call MPI_TYPE_FREE(slk_type,ierr)
6128 : : ABI_CHECK_MPI(ierr,"MPI_type_FREE")
6129 : :
6130 : : if (nelw == buffer_size) then
6131 : : ! Dump Slk_mat% immediately.
6132 : : call MPI_FILE_WRITE_ALL(my_fh, Slk_mat%buffer_cplx, buffer_size, MPI_DOUBLE_complex, MPI_STATUS_IGNORE, ierr)
6133 : : ABI_CHECK_MPI(ierr,"WRITE_ALL")
6134 : : else
6135 : : ! Have to extract the data to be written.
6136 : : ABI_MALLOC(buffer1_cplx,(nelw))
6137 : : do elw=1,nelw
6138 : : iloc = elw2slk(1,elw)
6139 : : jloc = elw2slk(2,elw)
6140 : : buffer1_cplx(elw) = Slk_mat%buffer_cplx(iloc,jloc)
6141 : : end do
6142 : : call MPI_FILE_WRITE_ALL(my_fh, buffer1_cplx, nelw, MPI_DOUBLE_complex, MPI_STATUS_IGNORE, ierr)
6143 : : ABI_CHECK_MPI(ierr,"WRITE_ALL")
6144 : : ABI_FREE(buffer1_cplx)
6145 : : end if
6146 : :
6147 : : ABI_FREE(elw2slk)
6148 : : !
6149 : : ! Number of columns and rows that have been written.
6150 : : ! Used to write the Fortran markers and to increment the offset.
6151 : : nrows_w = nrows_glob
6152 : : ncols_w = ncols_glob
6153 : : if (PRESENT(glob_subarray)) then
6154 : : nrows_w = glob_subarray(1,2) - glob_subarray(1,1) + 1
6155 : : ncols_w = glob_subarray(2,2) - glob_subarray(2,1) + 1
6156 : : if (.not.firstchar(uplo, ["A"])) then
6157 : : ABI_ERROR("glob_subarray should not be used when uplo/=All")
6158 : : end if
6159 : : end if
6160 : :
6161 : : !TODO check whether slk_single_fview_write can report an offset to reduce the extent.
6162 : : if (is_fortran_file) then ! Collective writing of the Fortran markers.
6163 : : nfrec = ncols_w
6164 : : ABI_MALLOC(bsize_frecord,(nfrec))
6165 : : if (firstchar(uplo, ["A"])) then
6166 : : bsize_frecord = nrows_w * bsize_elm
6167 : : else if (firstchar(uplo, ["U"])) then
6168 : : bsize_frecord = (/(col_glob * bsize_elm, col_glob=1,nfrec)/)
6169 : : else if (firstchar(uplo, ["L"])) then
6170 : : bsize_frecord = (/(col_glob * bsize_elm, col_glob=nfrec,1,-1)/)
6171 : : else
6172 : : ABI_ERROR("Wrong uplo")
6173 : : end if
6174 : : call xmpio_write_frmarkers(mpi_fh,my_offset,xmpio_collective,nfrec,bsize_frecord,ierr)
6175 : : ABI_CHECK(ierr==0,"Error while writing Fortran markers")
6176 : : ABI_FREE(bsize_frecord)
6177 : : end if
6178 : :
6179 : : if (do_open) then
6180 : : ! Close the file.
6181 : : call MPI_FILE_CLOSE(my_fh, ierr)
6182 : : ABI_CHECK_MPI(ierr,"FILE_CLOSE")
6183 : : end if
6184 : :
6185 : : ! Increment the offset
6186 : : if (PRESENT(offset)) then
6187 : : if (firstchar(uplo, ["A"])) then
6188 : : offset = offset + nrows_w*ncols_w*bsize_elm
6189 : : if (is_fortran_file) offset = offset + ncols_w*2*xmpio_bsize_frm
6190 : : else if (firstchar(uplo, ["U","L"])) then
6191 : : offset = offset + ( (Slk_mat%size_global(2) * (Slk_mat%size_global(2))+1)/2 ) * bsize_elm
6192 : : if (is_fortran_file) offset = offset + Slk_mat%size_global(2)*2*xmpio_bsize_frm
6193 : : else
6194 : : ABI_ERROR("Wrong uplo")
6195 : : end if
6196 : : end if
6197 : :
6198 : : call xmpi_barrier(comm)
6199 : : RETURN
6200 : :
6201 : : #else
6202 : 0 : ABI_ERROR("MPI-IO support not activated")
6203 : : #endif
6204 : :
6205 : 0 : end subroutine slk_write
6206 : : !!***
6207 : :
6208 : : !----------------------------------------------------------------------
6209 : :
6210 : : !!****f* m_slk/slk_read
6211 : : !! NAME
6212 : : !! slk_read
6213 : : !!
6214 : : !! FUNCTION
6215 : : !! Routine to read a square scaLAPACK distributed matrix from an external file using MPI-IO.
6216 : : !!
6217 : : !! INPUTS
6218 : : !! uplo=String specifying whether only the upper or lower triangular part of the global matrix is stored on disk:
6219 : : !! = "U": Upper triangular is stored
6220 : : !! = "L": Lower triangular is stored
6221 : : !! = "A": Full matrix (used for general complex matrices)
6222 : : !! symtype=Symmetry type of the matrix stored on disk (used only if uplo = "L" or "A").
6223 : : !! = "H" for Hermitian matrix
6224 : : !! = "S" for symmetric matrix.
6225 : : !! = "N" if matrix has no symmetry (not compatible with uplo="L" or uplo="U".
6226 : : !! is_fortran_file=.FALSE. is C stream is used. .TRUE. for writing Fortran binary files.
6227 : : !! [fname]= Mutually exclusive with mpi_fh. The name of the external file from which the matrix will be read.
6228 : : !! The file is open and closed inside the routine with MPI flags specified by flags.
6229 : : !! [mpi_fh]=File handler associated to the file (already open in the caller). Not compatible with fname.
6230 : : !! [flags]=MPI-IO flags used to open the file in MPI_FILE_OPEN. Default is MPI_MODE_RDONLY. Referenced only when fname is used.
6231 : : !!
6232 : : !! SIDE EFFECTS
6233 : : !! Slk_mat<slkmat_dp_t>=Structured datatype defining the scaLAPACK distribution with the local buffer
6234 : : !! supposed to be allocated.
6235 : : !! %buffer_cplx=Local buffer containg the distributed matrix stored on the external file.
6236 : : !! If fname is present then the file is opened and closed inside the routine. Any exception is fatal.
6237 : : !! [offset]=
6238 : : !! input: Offset used to access the content of the file. Default is zero.
6239 : : !! output: New offset incremented with the byte size of the matrix that has been read (Fortran
6240 : : !! markers are included if is_fortran_file=.TRUE.)
6241 : : !!
6242 : : !! TODO
6243 : : !! - Generalize the implementation adding the reading of the real buffer.
6244 : : !!
6245 : : !! - This routine is not portable as this kind of access pattern is not supported by all MPI implementations
6246 : : !! E.g. with MPICH we have
6247 : : !!
6248 : : !! --- !ERROR
6249 : : !! src_file: m_slk.F90
6250 : : !! src_line: 3780
6251 : : !! mpi_rank: 1
6252 : : !! message: |
6253 : : !! SET_VIEW
6254 : : !! Other I/O error , error stack:
6255 : : !! ADIO_Set_view(48): **iobadoverlap displacements of filetype must be in a monotonically nondecreasing order
6256 : : !! ...
6257 : : !!
6258 : : !! - This routine should be removed and replaced by hdf5 + mpi-io
6259 : : !!
6260 : : !! SOURCE
6261 : :
6262 : 0 : subroutine slk_read(Slk_mat,uplo,symtype,is_fortran_file,fname,mpi_fh,offset,flags)
6263 : :
6264 : : !Arguments ------------------------------------
6265 : : !scalars
6266 : : integer,optional,intent(in) :: flags,mpi_fh
6267 : : integer(XMPI_OFFSET_KIND),optional,intent(inout) :: offset
6268 : : character(len=*),optional,intent(in) :: fname
6269 : : character(len=*),intent(in) :: uplo,symtype
6270 : : logical,intent(in) :: is_fortran_file
6271 : : class(slkmat_dp_t),intent(inout) :: Slk_mat
6272 : :
6273 : : !Local variables ------------------------------
6274 : : #if defined HAVE_LINALG_SCALAPACK && defined HAVE_MPI_IO
6275 : : !scalars
6276 : : integer :: nrows_glob,offset_err,slk_type,etype
6277 : : integer(XMPI_OFFSET_KIND) :: my_offset
6278 : : logical :: do_open
6279 : : integer :: comm,my_flags,my_fh,buffer_size,ierr,col_glob
6280 : : integer :: nfrec,bsize_elm,mpi_type_elm
6281 : : !complex(dpc) :: ctest
6282 : : logical,parameter :: check_frm=.TRUE.
6283 : : integer(XMPI_OFFSET_KIND),allocatable :: bsize_frecord(:)
6284 : : !arrays
6285 : : character(len=500) :: msg
6286 : : !************************************************************************
6287 : :
6288 : : do_open = PRESENT(fname)
6289 : : if (do_open) then
6290 : : ABI_CHECK(.not.PRESENT(fname), "fname should not be present")
6291 : : else
6292 : : ABI_CHECK(PRESENT(mpi_fh), "mpi_fh should be present")
6293 : : end if
6294 : :
6295 : : my_offset=0; if (PRESENT(offset)) my_offset=offset
6296 : :
6297 : : ABI_CHECK(allocated(Slk_mat%buffer_cplx), "%buffer_cplx not allocated")
6298 : : if (firstchar(uplo, ["U","L"]) .and. Slk_mat%size_global(1) /= Slk_mat%size_global(2) ) then
6299 : : ABI_ERROR("rectangular matrices are not compatible with the specified uplo")
6300 : : end if
6301 : :
6302 : : nrows_glob = Slk_mat%size_global(1)
6303 : :
6304 : : buffer_size= PRODUCT(Slk_mat%size_local(1:2))
6305 : :
6306 : : call wrtout(std_out, "slk_read: Using MPI-IO")
6307 : :
6308 : : comm = Slk_mat%processor%comm
6309 : :
6310 : : if (do_open) then ! Open the file.
6311 : : my_flags=MPI_MODE_RDONLY; if (PRESENT(flags)) my_flags = flags
6312 : : call MPI_FILE_OPEN(comm, fname, my_flags, MPI_INFO_NULL, my_fh, ierr)
6313 : : ABI_CHECK_MPI(ierr,"FILE_OPEN "//TRIM(fname))
6314 : : else
6315 : : my_fh = mpi_fh
6316 : : end if
6317 : :
6318 : : call slk_single_fview_read(Slk_mat,uplo,etype,slk_type,offset_err,is_fortran_file=is_fortran_file)
6319 : :
6320 : : if (offset_err/=0) then
6321 : : write(msg,"(3a)")&
6322 : : "Global position index cannot be stored in standard Fortran integer ",ch10,&
6323 : : "scaLAPACK matrix cannot be read with a single MPI-IO call."
6324 : : ABI_ERROR(msg)
6325 : : end if
6326 : :
6327 : : call MPI_FILE_SET_VIEW(my_fh, my_offset, etype, slk_type, 'native', MPI_INFO_NULL, ierr)
6328 : : ABI_CHECK_MPI(ierr,"SET_VIEW")
6329 : :
6330 : : call MPI_FILE_READ_ALL(my_fh, Slk_mat%buffer_cplx, buffer_size, MPI_DOUBLE_complex, MPI_STATUS_IGNORE, ierr)
6331 : : ABI_CHECK_MPI(ierr,"READ_ALL")
6332 : :
6333 : : ! Symmetrize local buffer if uplo /= "All"
6334 : : call Slk_mat%symmetrize(uplo, symtype)
6335 : :
6336 : : !BEGINDEBUG
6337 : : !call MPI_FILE_READ_AT(mpi_fh,my_offset+xmpio_bsize_frm,ctest,1,MPI_DOUBLE_complex,MPI_STATUS_IGNORE,ierr)
6338 : : !write(std_out,*)"ctest",ctest
6339 : : !call MPI_FILE_READ_AT(mpi_fh,my_offset+2*xmpio_bsize_frm,ctest,1,MPI_DOUBLE_complex,MPI_STATUS_IGNORE,ierr)
6340 : : !write(std_out,*)"ctest",ctest
6341 : : !ENDDEBUG
6342 : :
6343 : : !call print_arr(Slk_mat%buffer_cplx,max_r=10,max_c=10,unit=std_out)
6344 : : !
6345 : : ! Close the file and release the MPI filetype.
6346 : : call MPI_type_FREE(slk_type,ierr)
6347 : : ABI_CHECK_MPI(ierr,"MPI_type_FREE")
6348 : :
6349 : : call slk_mat%bsize_and_type(bsize_elm, mpi_type_elm)
6350 : :
6351 : : !It seems that personal call makes the code stuck
6352 : : !if (is_fortran_file .and. check_frm .and. Slk_mat%Processor%my_rank==0) then ! Master checks the Fortran markers.
6353 : : if (is_fortran_file .and. check_frm) then ! Master checks the Fortran markers.
6354 : : call wrtout(std_out,"Checking Fortran record markers...", do_flush=.True.)
6355 : : nfrec = Slk_mat%size_global(2)
6356 : : ABI_MALLOC(bsize_frecord,(nfrec))
6357 : : if (firstchar(uplo, ["A"])) then
6358 : : bsize_frecord = Slk_mat%size_global(1) * bsize_elm
6359 : : else if (firstchar(uplo, ["U"])) then
6360 : : bsize_frecord = (/(col_glob * bsize_elm, col_glob=1,nfrec)/)
6361 : : else if (firstchar(uplo, ["L"])) then
6362 : : bsize_frecord = (/(col_glob * bsize_elm, col_glob=nfrec,1,-1)/)
6363 : : else
6364 : : ABI_ERROR("Wrong uplo")
6365 : : end if
6366 : : call xmpio_check_frmarkers(my_fh,my_offset,xmpio_collective,nfrec,bsize_frecord,ierr)
6367 : : ABI_CHECK(ierr==0,"Wrong Fortran record markers")
6368 : : ABI_FREE(bsize_frecord)
6369 : : end if
6370 : :
6371 : : if (do_open) then ! Close the file.
6372 : : call MPI_FILE_CLOSE(my_fh, ierr)
6373 : : ABI_CHECK_MPI(ierr,"FILE_CLOSE")
6374 : : end if
6375 : :
6376 : : !Increment the offset
6377 : : if (PRESENT(offset)) then
6378 : : if (firstchar(uplo, ["A"])) then
6379 : : offset = offset + PRODUCT(Slk_mat%size_global(1:2)) * bsize_elm
6380 : : if (is_fortran_file) offset = offset + Slk_mat%size_global(2)*2*xmpio_bsize_frm
6381 : : else if (firstchar(uplo, ["U","L"])) then
6382 : : offset = offset + ( (Slk_mat%size_global(2) * (Slk_mat%size_global(2))+1)/2 ) * bsize_elm
6383 : : if (is_fortran_file) offset = offset + Slk_mat%size_global(2)*2*xmpio_bsize_frm
6384 : : else
6385 : : ABI_ERROR("Wrong uplo")
6386 : : end if
6387 : : end if
6388 : :
6389 : : call xmpi_barrier(comm)
6390 : : RETURN
6391 : :
6392 : : #else
6393 : 0 : ABI_ERROR("MPI-IO support not enabled")
6394 : : #endif
6395 : :
6396 : 0 : end subroutine slk_read
6397 : : !!***
6398 : :
6399 : : !----------------------------------------------------------------------
6400 : :
6401 : : !!****f* m_slk/slk_single_fview_read_mask
6402 : : !! NAME
6403 : : !! slk_single_fview_read_mask
6404 : : !!
6405 : : !! FUNCTION
6406 : : !! Return an MPI datatype that can be used to read a scaLAPACK distributed matrix from
6407 : : !! a binary file using MPI-IO. The view is created using the user-defined mask function
6408 : : !! mask_of_glob. The storage of the data on file is described via the user-defined function offset_of_glob.
6409 : : !!
6410 : : !! INPUTS
6411 : : !! Slk_mat<slkmat_dp_t>=Structured datatype defining the scaLAPACK matrix.
6412 : : !! mask_of_glob(row_glob,col_glob,size_glob) is an integer function that accepts in input
6413 : : !! the global indices of the matrix size_glob(1:2) are the global dimensions.
6414 : : !! Return 0 if (row_glob,col_glob) should not be read.
6415 : : !! offset_of_glob(row_glob,col_glob,size_glob,nsblocks,sub_block,bsize_elm,bsize_frm)
6416 : : !! nsblocks=Number of sub-blocks (will be passed to offset_of_glob)
6417 : : !! sub_block(2,2,nsblocks)=Global coordinates of the extremal points delimiting the sub-blocs
6418 : : !! e.g. sub_block(:,1,1) gives the coordinates of the left upper corner of the first block.
6419 : : !! sub_block(:,2,1) gives the coordinates of the right lower corner of the first block.
6420 : : !! [is_fortran_file]=.FALSE. is C stream is used. Set to .TRUE. for writing Fortran binary files
6421 : : !! with record marker.
6422 : : !!
6423 : : !! OUTPUT
6424 : : !! my_nel=Number of elements that will be read by this node.
6425 : : !! etype=Elementary data type (handle) defining the elementary unit used to access the file.
6426 : : !! This is the elementary type that must be used to creae the view (MPI_BYTE is used).
6427 : : !! slk_type=New MPI type that can be used to instantiate the MPI-IO view for the Fortran file.
6428 : : !! Note that the view assumes that the file pointer points to the FIRST Fortran record marker.
6429 : : !! offset_err=Error code. A returned non-zero value signals that the global matrix is too large
6430 : : !! for a single MPI-IO access. See notes in other slk_single_fview_* routines.
6431 : : !!
6432 : : !! SIDE EFFECTS
6433 : : !! myel2loc(:,:)
6434 : : !! input: pointer to NULL
6435 : : !! output: myel2loc(2,my_nel): myel2loc(:,el) gives (iloc,jloc) for el=1,my_nel.
6436 : : !!
6437 : : !! SOURCE
6438 : :
6439 : 0 : subroutine slk_single_fview_read_mask(Slk_mat,mask_of_glob,offset_of_glob,nsblocks,sub_block,&
6440 : : my_nel,myel2loc,etype,slk_type,offset_err,is_fortran_file)
6441 : :
6442 : : !Arguments ------------------------------------
6443 : : !scalars
6444 : : integer,intent(in) :: nsblocks
6445 : : integer,intent(out) :: my_nel,offset_err,slk_type,etype
6446 : : logical,optional,intent(in) :: is_fortran_file
6447 : : class(slkmat_dp_t),intent(in) :: Slk_mat
6448 : : !arrays
6449 : : integer,intent(in) :: sub_block(2,2,nsblocks)
6450 : : integer,pointer :: myel2loc(:,:)
6451 : :
6452 : : interface
6453 : : function mask_of_glob(row_glob,col_glob,size_glob)
6454 : : use defs_basis
6455 : : integer :: mask_of_glob
6456 : : integer,intent(in) :: row_glob,col_glob
6457 : : integer,intent(in) :: size_glob(2)
6458 : : end function mask_of_glob
6459 : : end interface
6460 : :
6461 : : interface
6462 : : function offset_of_glob(row_glob,col_glob,size_glob,nsblocks,sub_block,bsize_elm,bsize_frm)
6463 : : use defs_basis
6464 : : use m_xmpi
6465 : : integer(XMPI_OFFSET_KIND) :: offset_of_glob
6466 : : integer,intent(in) :: row_glob,col_glob,bsize_elm,bsize_frm,nsblocks
6467 : : integer,intent(in) :: size_glob(2),sub_block(2,2,nsblocks)
6468 : : end function offset_of_glob
6469 : : end interface
6470 : :
6471 : : !Local variables ------------------------------
6472 : : !scalars
6473 : : integer :: el,jloc,iloc,iglob,jglob,mpi_err,sweep
6474 : : integer :: bsize_frm,mpi_type_elm,bsize_elm
6475 : : integer(XMPI_OFFSET_KIND) :: tmp_off,max_displ
6476 : : !arrays
6477 : : character(len=500) :: msg
6478 : 0 : integer,allocatable :: block_length(:),block_type(:)
6479 : 0 : integer(XMPI_ADDRESS_KIND),allocatable :: block_displ(:)
6480 : : !************************************************************************
6481 : :
6482 : : #ifdef HAVE_MPI_IO
6483 : 0 : bsize_frm = xmpio_bsize_frm ! Byte size of the Fortran record marker.
6484 [ # # ]: 0 : if (PRESENT(is_fortran_file)) then
6485 [ # # ]: 0 : if (.not.is_fortran_file) bsize_frm = 0
6486 : : end if
6487 : :
6488 : : ! Byte size of the matrix element.
6489 : 0 : call slk_mat%bsize_and_type(bsize_elm, mpi_type_elm)
6490 : :
6491 : : ! Find the number of local matrix elements to be read, then create the table myel2loc.
6492 [ # # ]: 0 : do sweep=1,2
6493 [ # # ]: 0 : if (sweep==2) then
6494 [ # # # # : 0 : ABI_MALLOC(myel2loc,(2,my_nel))
# # # # #
# # # ]
6495 : : end if
6496 : 0 : my_nel=0
6497 : :
6498 [ # # ]: 0 : do jloc=1,Slk_mat%size_local(2)
6499 [ # # ]: 0 : do iloc=1,Slk_mat%size_local(1)
6500 : 0 : call slk_mat%loc2glob(iloc, jloc, iglob, jglob)
6501 [ # # ]: 0 : if ( mask_of_glob(iglob,jglob,Slk_mat%size_global)/= 0) then ! Will fill this entry.
6502 : 0 : my_nel = my_nel+1
6503 [ # # # # ]: 0 : if (sweep==2) myel2loc(:,my_nel) = (/iloc,jloc/)
6504 : : end if
6505 : : end do
6506 : : end do
6507 : : end do
6508 : :
6509 : 0 : etype = MPI_BYTE
6510 : :
6511 : : ! Define the mapping between scaLAPACK buffer and the storage on file.
6512 : : ! Note that the view assumes that the file pointer points to the first Fortran record marker.
6513 [ # # # # : 0 : ABI_MALLOC(block_length,(my_nel+2))
# # # # #
# # # #
# ]
6514 [ # # # # : 0 : ABI_MALLOC(block_displ,(my_nel+2))
# # # # #
# # # ]
6515 [ # # # # : 0 : ABI_MALLOC(block_type,(my_nel+2))
# # # # ]
6516 : 0 : block_length(1)=1
6517 : 0 : block_displ (1)=0
6518 : 0 : block_type (1)=MPI_LB
6519 : :
6520 : 0 : offset_err=0; max_displ=0
6521 [ # # ]: 0 : do el=1,my_nel
6522 : 0 : iloc = myel2loc(1,el)
6523 : 0 : jloc = myel2loc(2,el)
6524 : 0 : call slk_mat%loc2glob(iloc, jloc, iglob, jglob)
6525 : 0 : tmp_off = offset_of_glob(iglob,jglob,Slk_mat%size_global,nsblocks,sub_block,bsize_elm,bsize_frm)
6526 [ # # ]: 0 : if (xmpio_max_address(tmp_off)) offset_err=1 ! Test for possible wraparounds.
6527 : 0 : max_displ = MAX(max_displ,tmp_off)
6528 : 0 : block_displ (el+1) = tmp_off
6529 : 0 : block_type (el+1) = mpi_type_elm
6530 : 0 : block_length(el+1) = 1
6531 : : !write(std_out,*)" iglob, jglob, tmp_off ",iglob, jglob, tmp_off
6532 : : end do
6533 : : !write(std_out,*)" MAX displ is ",MAXVAL(block_displ)
6534 : :
6535 [ # # ]: 0 : if (offset_err/=0) then ! just warn, let the caller handle the exception.
6536 : : write(msg,"(3a)")&
6537 : 0 : " Global position index cannot be stored in standard Fortran integer ",ch10,&
6538 : 0 : " scaLAPACK matrix cannot be read with a single MPI-IO call ."
6539 : 0 : ABI_WARNING(msg)
6540 : : end if
6541 : :
6542 : 0 : block_length(my_nel+2) = 1
6543 : 0 : block_displ (my_nel+2) = max_displ
6544 : 0 : block_type (my_nel+2) = MPI_UB
6545 : :
6546 : 0 : call xmpio_type_struct(my_nel+2,block_length,block_displ,block_type,slk_type,mpi_err)
6547 : 0 : ABI_CHECK_MPI(mpi_err,"MPI_type_STRUCT")
6548 : :
6549 : 0 : ABI_FREE(block_length)
6550 : 0 : ABI_FREE(block_displ)
6551 : 0 : ABI_FREE(block_type)
6552 : :
6553 : 0 : call MPI_type_COMMIT(slk_type,mpi_err)
6554 : 0 : ABI_CHECK_MPI(mpi_err,"MPI_type_COMMIT")
6555 : :
6556 : : #else
6557 : : ABI_ERROR("MPI-IO is mandatatory in slk_single_fview_read_mask")
6558 : : #endif
6559 : :
6560 : 0 : end subroutine slk_single_fview_read_mask
6561 : : !!***
6562 : :
6563 : : !----------------------------------------------------------------------
6564 : :
6565 : : !!****f* m_slk/slkmat_dp_symmetrize
6566 : : !! NAME
6567 : : !! slkmat_dp_symmetrize
6568 : : !!
6569 : : !! FUNCTION
6570 : : !! Symmetrize a square scaLAPACK matrix.
6571 : : !!
6572 : : !! INPUTS
6573 : : !! uplo=String specifying whether only the upper or lower triangular part of the global matrix has been read
6574 : : !! = "U": Upper triangular has been read.
6575 : : !! = "L": Lower triangular has been read.
6576 : : !! = "A": Full matrix (used for general complex matrices)
6577 : : !! symtype=Symmetry type of the matrix (used only if uplo = "L" or "A").
6578 : : !! = "H" for Hermitian matrix
6579 : : !! = "S" for symmetric matrix.
6580 : : !! = "N" if matrix has no symmetry (not compatible with uplo="L" or uplo="U".
6581 : : !!
6582 : : !! SIDE EFFECTS
6583 : : !! Slk_mat<slkmat_dp_t>=Structured datatype defining the scaLAPACK distribution with the local buffer
6584 : : !! supposed to be allocated.
6585 : : !! %buffer_cplx=Local buffer containg the distributed matrix stored on the external file.
6586 : : !!
6587 : : !! SOURCE
6588 : :
6589 : 0 : subroutine slkmat_dp_symmetrize(Slk_mat, uplo, symtype)
6590 : :
6591 : : !Arguments ------------------------------------
6592 : : !scalars
6593 : : class(slkmat_dp_t),intent(inout) :: Slk_mat
6594 : : character(len=*),intent(in) :: uplo, symtype
6595 : :
6596 : : !Local variables ------------------------------
6597 : : !scalars
6598 : : integer :: jloc,iloc,iglob,jglob,ij_loc
6599 : : logical :: is_hermitian,is_real,is_cplx,is_symmetric
6600 : : character(len=500) :: msg
6601 : : !************************************************************************
6602 : :
6603 : 0 : is_cplx = (allocated(Slk_mat%buffer_cplx))
6604 : 0 : is_real = (allocated(Slk_mat%buffer_real))
6605 : :
6606 : : ! One and only one buffer should be allocated.
6607 [ # # ]: 0 : if (is_real .and. is_cplx) then
6608 : 0 : write(msg,'(a,2l1)')" ScaLAPACK buffers are not allocated correctly, is_real, is_cplx ",is_real,is_cplx
6609 : 0 : ABI_ERROR(msg)
6610 : : end if
6611 : :
6612 [ # # ]: 0 : if (is_real) RETURN
6613 : :
6614 : 0 : is_hermitian=.FALSE.; is_symmetric=.FALSE.
6615 : : select case (symtype(1:1))
6616 : : case ("H", "h")
6617 : : is_hermitian = .TRUE.
6618 : : case ("S","s")
6619 : 0 : is_symmetric = .TRUE.
6620 : : case("N","n")
6621 [ # # # # : 0 : if (ALL(uplo(1:1) /= ["A","a"])) then
# # ]
6622 [ # # ]: 0 : msg = " Found symtype= "//TRIM(symtype)//", but uplo= "//TRIM(uplo)
6623 : 0 : ABI_ERROR(msg)
6624 : : end if
6625 : 0 : RETURN ! Nothing to do.
6626 : : case default
6627 [ # # # # : 0 : ABI_ERROR("Wrong symtype "//TRIM(symtype))
# # ]
6628 : : end select
6629 : :
6630 : : !write(std_out,*)"is_cplx",is_cplx
6631 : : !write(std_out,*)"is_hermitian",is_hermitian
6632 : :
6633 : : select case (uplo(1:1))
6634 : : case ("A","a")
6635 : : ! Full global matrix has been read, nothing to do.
6636 : 0 : return
6637 : :
6638 : : case ("U", "u")
6639 : : ! Only the upper triangle of the global matrix was read.
6640 [ # # # # ]: 0 : if (is_cplx .and. is_hermitian) then
6641 : 0 : ij_loc=0
6642 [ # # ]: 0 : do jloc=1,Slk_mat%size_local(2)
6643 [ # # ]: 0 : do iloc=1,Slk_mat%size_local(1)
6644 : 0 : call slk_mat%loc2glob(iloc, jloc, iglob, jglob)
6645 : 0 : ij_loc = ij_loc+1
6646 [ # # ]: 0 : if (jglob < iglob) then
6647 : : ! Diagonal elements are not forced to be real.
6648 : 0 : Slk_mat%buffer_cplx(iloc,jloc) = DCONJG(Slk_mat%buffer_cplx(iloc,jloc))
6649 : : end if
6650 : : !if (iglob==jglob) Slk_mat%buffer_cplx(iloc,jloc) = real(Slk_mat%buffer_cplx(iloc,jloc))
6651 : : end do
6652 : : end do
6653 : : end if
6654 : :
6655 : : case ("L", "l")
6656 : : ! Only the lower triangle of the global matrix was read.
6657 [ # # # # ]: 0 : if (is_cplx .and. is_hermitian) then
6658 : 0 : ij_loc=0
6659 [ # # ]: 0 : do jloc=1,Slk_mat%size_local(2)
6660 [ # # ]: 0 : do iloc=1,Slk_mat%size_local(1)
6661 : 0 : call slk_mat%loc2glob(iloc, jloc, iglob, jglob)
6662 : 0 : ij_loc = ij_loc+1
6663 [ # # ]: 0 : if (jglob>iglob) then ! diagonal elements are not forced to be real.
6664 : 0 : Slk_mat%buffer_cplx(iloc,jloc) = DCONJG(Slk_mat%buffer_cplx(iloc,jloc))
6665 : : end if
6666 : : !if (iglob==jglob) Slk_mat%buffer_cplx(iloc,jloc) = real(Slk_mat%buffer_cplx(iloc,jloc))
6667 : : end do
6668 : : end do
6669 : : end if
6670 : :
6671 : : case default
6672 [ # # # # : 0 : ABI_BUG(" Wrong uplo: "//TRIM(uplo))
# # ]
6673 : : end select
6674 : :
6675 : : end subroutine slkmat_dp_symmetrize
6676 : : !!***
6677 : :
6678 : : !----------------------------------------------------------------------
6679 : :
6680 : : !!****f* m_slk/slk_single_fview_read
6681 : : !! NAME
6682 : : !! slk_single_fview_read
6683 : : !!
6684 : : !! FUNCTION
6685 : : !! Return an MPI datatype that can be used to read a scaLAPACK distributed matrix from
6686 : : !! a binary file using MPI-IO.
6687 : : !!
6688 : : !! INPUTS
6689 : : !! Slk_mat<slkmat_dp_t>=Structured datatype defining the scaLAPACK distribution with the local buffer.
6690 : : !! uplo=String specifying whether only the upper or lower triangular part of the global matrix is stored on disk:
6691 : : !! = "U": Upper triangular is stored
6692 : : !! = "L": Lower triangular is stored
6693 : : !! = "A": Full matrix (used for general complex matrices)
6694 : : !! [is_fortran_file]=.FALSE. is C stream is used. .TRUE. for writing Fortran binary files
6695 : : !! with record markers. In this case etype is set xmpio_mpi_type_frm provided that
6696 : : !! the mpi_type of the matrix element is commensurate with xmpio_mpi_type_frm. Defaults to .TRUE.
6697 : : !!
6698 : : !! OUTPUT
6699 : : !! etype=Elementary data type (handle) defining the elementary unit used to access the file.
6700 : : !! slk_type=New MPI type that can be used to instantiate the MPI-IO view for the Fortran file.
6701 : : !! Note that the view assumes that the file pointer points to the FIRST Fortran record marker.
6702 : : !! offset_err=Error code. A non-zero value signals that the global matrix is too large
6703 : : !! for a single MPI-IO access (see notes below).
6704 : : !!
6705 : : !! NOTES
6706 : : !! With (signed) Fortran integers, the maximum size of the file that
6707 : : !! that can be read in one-shot is around 2Gb when etype is set to byte.
6708 : : !! Using a larger etype might create portability problems (real data on machines using
6709 : : !! integer*16 for the marker) since etype must be a multiple of the Fortran record marker
6710 : : !! Due to the above reason, block_displ is given in bytes and must be stored in a integer
6711 : : !! of kind XMPI_ADDRESS_KIND. If the displacement is too large, the routine returns
6712 : : !! offset_err=1 so that the caller will know that several MPI-IO reads are needed to
6713 : : !! read the local buffer.
6714 : : !!
6715 : : !! SOURCE
6716 : :
6717 : 0 : subroutine slk_single_fview_read(Slk_mat,uplo,etype,slk_type,offset_err,is_fortran_file)
6718 : :
6719 : : !Arguments ------------------------------------
6720 : : !scalars
6721 : : class(slkmat_dp_t),intent(in) :: Slk_mat
6722 : : integer,intent(out) :: offset_err,slk_type,etype
6723 : : character(len=*),intent(in) :: uplo
6724 : : logical,optional,intent(in) :: is_fortran_file
6725 : :
6726 : : !Local variables ------------------------------
6727 : : !scalars
6728 : : integer :: jloc,iloc,iglob,jglob,nrows_glob,ncols_glob,mpi_err,nel
6729 : : integer :: bsize_frm,mpi_type_elm,ij_loc,bsize_etype,bsize_elm
6730 : : integer(XMPI_OFFSET_KIND) :: ijp_glob,my_offset,cpad_frm
6731 : : !arrays
6732 : : character(len=500) :: msg
6733 : 0 : integer,allocatable :: block_length(:),block_type(:)
6734 : 0 : integer(XMPI_ADDRESS_KIND),allocatable :: block_displ(:)
6735 : : !************************************************************************
6736 : :
6737 : : #ifdef HAVE_MPI_IO
6738 : : !@slkmat_dp_t
6739 : 0 : bsize_frm = xmpio_bsize_frm ! Byte size of the Fortran record marker.
6740 [ # # ]: 0 : if (PRESENT(is_fortran_file)) then
6741 [ # # ]: 0 : if (.not.is_fortran_file) bsize_frm = 0
6742 : : end if
6743 : :
6744 : 0 : call slk_mat%bsize_and_type(bsize_elm, mpi_type_elm)
6745 : :
6746 : : ! Global dimensions.
6747 : 0 : nrows_glob=Slk_mat%size_global(1)
6748 : 0 : ncols_glob=Slk_mat%size_global(2)
6749 : :
6750 : : ! Number of matrix elements treated by this node.
6751 [ # # ]: 0 : nel = PRODUCT(Slk_mat%size_local(1:2))
6752 : :
6753 : : !Cannot use MPI_type_CREATE_INDEXED_BLOCK since it is not correctly implemented in several MPI libraries.
6754 : : !etype has to be set to MPI_BYTE, since the displacement in MPI structures is always in byte.
6755 : : ! ABI_WARNING("Using MPI_type_STRUCT for the MPI-IO file view")
6756 : :
6757 : 0 : etype = MPI_BYTE
6758 : 0 : call MPI_type_SIZE(etype,bsize_etype,mpi_err)
6759 : :
6760 : : ! Define the mapping between scaLAPACK buffer and the storage on file.
6761 [ # # # # : 0 : ABI_MALLOC(block_length, (nel+2))
# # # # #
# # # #
# ]
6762 [ # # # # : 0 : ABI_MALLOC(block_displ, (nel+2))
# # # # #
# # # ]
6763 [ # # # # : 0 : ABI_MALLOC(block_type, (nel+2))
# # # # ]
6764 : 0 : block_length(1)=1
6765 : 0 : block_displ (1)=0
6766 : 0 : block_type (1)=MPI_LB
6767 : :
6768 : : ! Note that the view assumes that the file pointer points to the first Fortran record marker.
6769 : 0 : offset_err=0
6770 : 0 : select case (uplo(1:1))
6771 : : case ("A","a")
6772 : : ! The entire global matrix is stored on disk.
6773 : : ! TODO can use contigous vectors for better access.
6774 : 0 : ij_loc=0
6775 [ # # ]: 0 : do jloc=1,Slk_mat%size_local(2)
6776 [ # # ]: 0 : do iloc=1,Slk_mat%size_local(1)
6777 : 0 : call slk_mat%loc2glob(iloc, jloc, iglob, jglob)
6778 : 0 : ij_loc = ij_loc+1
6779 : 0 : my_offset = 2*(jglob-1)*bsize_frm + bsize_frm + (jglob-1)*nrows_glob*bsize_elm + (iglob-1) * bsize_elm
6780 : 0 : my_offset = my_offset / bsize_etype
6781 [ # # ]: 0 : if (xmpio_max_address(my_offset)) offset_err=1 ! Test for possible wraparounds
6782 : 0 : block_displ (ij_loc+1) = my_offset
6783 : 0 : block_type (ij_loc+1) = mpi_type_elm
6784 : 0 : block_length(ij_loc+1) = 1
6785 : : end do
6786 : : end do
6787 : :
6788 : : case ("U","u")
6789 : : ! Only the upper triangle of the global matrix is stored on disk.
6790 : 0 : ij_loc=0
6791 [ # # ]: 0 : do jloc=1,Slk_mat%size_local(2)
6792 [ # # ]: 0 : do iloc=1,Slk_mat%size_local(1)
6793 : 0 : call slk_mat%loc2glob(iloc, jloc, iglob, jglob)
6794 [ # # ]: 0 : if (jglob>=iglob) then
6795 : 0 : ijp_glob = iglob + jglob*(jglob-1)/2 ! Index for packed form
6796 : 0 : cpad_frm = 2*(jglob-1)*bsize_frm
6797 : : else
6798 : 0 : ijp_glob = jglob + iglob*(iglob-1)/2 ! Index for packed form
6799 : 0 : cpad_frm = 2*(iglob-1)*bsize_frm
6800 : : end if
6801 : 0 : ij_loc = ij_loc+1
6802 : 0 : my_offset = cpad_frm + bsize_frm + (ijp_glob-1) * bsize_elm
6803 : 0 : my_offset = my_offset / bsize_etype
6804 [ # # ]: 0 : if (xmpio_max_address(my_offset)) offset_err=1 ! Test for possible wraparounds
6805 : 0 : block_displ (ij_loc+1) = my_offset
6806 : 0 : block_type (ij_loc+1) = mpi_type_elm
6807 : 0 : block_length(ij_loc+1) = 1
6808 : : end do
6809 : : end do
6810 : :
6811 : : case ("L","l")
6812 : : ! Only the lower triangle of the global matrix is stored on disk.
6813 : 0 : ij_loc=0
6814 [ # # ]: 0 : do jloc=1,Slk_mat%size_local(2)
6815 [ # # ]: 0 : do iloc=1,Slk_mat%size_local(1)
6816 : 0 : call slk_mat%loc2glob(iloc, jloc, iglob, jglob)
6817 [ # # ]: 0 : if (jglob<=iglob) then
6818 : 0 : ijp_glob = iglob + (jglob-1)*(2*nrows_glob-jglob)/2 ! Index for packed form
6819 : 0 : cpad_frm = 2*(jglob-1)*bsize_frm
6820 : : else
6821 : 0 : ijp_glob = jglob + (iglob-1)*(2*nrows_glob-iglob)/2 ! Index for packed form
6822 : 0 : cpad_frm = 2*(iglob-1)*bsize_frm
6823 : : end if
6824 : 0 : ij_loc = ij_loc+1
6825 : 0 : my_offset = cpad_frm + bsize_frm + (ijp_glob-1) * bsize_elm
6826 : 0 : my_offset = my_offset / bsize_etype
6827 [ # # ]: 0 : if (xmpio_max_address(my_offset)) offset_err=1 ! block_displ is usually integer*4. Test for possible wraparounds
6828 : 0 : block_displ (ij_loc+1) = my_offset
6829 : 0 : block_type (ij_loc+1) = mpi_type_elm
6830 : 0 : block_length(ij_loc+1) = 1
6831 : : end do
6832 : : end do
6833 : :
6834 [ # # ]: 0 : if (offset_err/=0) then ! just warn, let the caller handle the exception.
6835 : : write(msg,"(3a)")&
6836 : 0 : " Global position index cannot be stored in standard Fortran integer ",ch10,&
6837 : 0 : " scaLAPACK matrix cannot be read with a single MPI-IO call ."
6838 : 0 : ABI_WARNING(msg)
6839 : : end if
6840 : :
6841 : : case default
6842 [ # # # # : 0 : ABI_BUG(" Wrong uplo: "//TRIM(uplo))
# # ]
6843 : : end select
6844 : :
6845 : 0 : block_length(nel+2)= 1
6846 : 0 : block_displ (nel+2)= ncols_glob * (nrows_glob*bsize_elm + 2*bsize_frm) / bsize_etype
6847 : 0 : block_type (nel+2)= MPI_UB
6848 : :
6849 : 0 : call xmpio_type_struct(nel+2,block_length,block_displ,block_type,slk_type,mpi_err)
6850 : 0 : ABI_CHECK_MPI(mpi_err,"MPI_type_STRUCT")
6851 : :
6852 : 0 : ABI_FREE(block_length)
6853 : 0 : ABI_FREE(block_displ)
6854 : 0 : ABI_FREE(block_type)
6855 : :
6856 : 0 : call MPI_type_COMMIT(slk_type,mpi_err)
6857 : 0 : ABI_CHECK_MPI(mpi_err,"MPI_type_COMMIT")
6858 : :
6859 : : #else
6860 : : ABI_ERROR("MPI-IO is mandatatory in slk_single_fview_read")
6861 : : #endif
6862 : :
6863 : 0 : end subroutine slk_single_fview_read
6864 : : !!***
6865 : :
6866 : : !----------------------------------------------------------------------
6867 : :
6868 : : !!****f* m_slk/slk_single_fview_write
6869 : : !! NAME
6870 : : !! slk_single_fview_write
6871 : : !!
6872 : : !! FUNCTION
6873 : : !! Returns an MPI datatype that can be used to write a scaLAPACK distributed matrix to
6874 : : !! a binary file using MPI-IO.
6875 : : !!
6876 : : !! INPUTS
6877 : : !! Slk_mat<slkmat_dp_t>=Structured datatype defining the scaLAPACK distribution with the local buffer.
6878 : : !! uplo=String specifying whether only the upper or lower triangular part of the global matrix is stored on disk:
6879 : : !! = "U": Upper triangular is stored
6880 : : !! = "L": Lower triangular is stored
6881 : : !! = "A": Full matrix (used for general complex matrices)
6882 : : !! [is_fortran_file]=.FALSE. is C stream is used. .TRUE. for writing Fortran binary files
6883 : : !! with record marker. In this case etype is set xmpio_mpi_type_frm provided that
6884 : : !! the mpi_type of the matrix element is commensurate with xmpio_mpi_type_frm. Defaults to .TRUE.
6885 : : !! glob_subarray(2,2) = Used to select the subarray of the global matrix. Used only when uplo="All"
6886 : : !! glob_subarray(:,1)=starting global coordinates of the subarray in each dimension
6887 : : !! (array of nonnegative integers >=1, <=array_of_sizes)
6888 : : !! glob_subarray(:,2)=Number of elements in each dimension of the subarray (array of positive integers)
6889 : : !!
6890 : : !! OUTPUT
6891 : : !! nelw=Number of elements to be written.
6892 : : !! etype=Elementary data type (handle) defining the elementary unit used to access the file.
6893 : : !! slk_type=New MPI type that can be used to instantiate the MPI-IO view for the Fortran file.
6894 : : !! Note that the view assumes that the file pointer points to the FIRST Fortran record marker.
6895 : : !! offset_err=Error code. A non-zero value signals that the global matrix is too large
6896 : : !! for a single MPI-IO access (see notes below).
6897 : : !!
6898 : : !! SIDE EFFECTS
6899 : : !! elw2slk(:,:) =
6900 : : !! input: pointer to null().
6901 : : !! output: elw2slk(2,nelw) contains the local coordinates of the matrix elements to be written.
6902 : : !! (useful only if the upper or lower triangle of the global matrix has to be written or when
6903 : : !! uplo="all" but a global subarray is written.
6904 : : !!
6905 : : !! NOTES
6906 : : !! With (signed) Fortran integers, the maximum size of the file that
6907 : : !! that can be read in one-shot is around 2Gb when etype is set to byte.
6908 : : !! Using a larger etype might create portability problems (real data on machines using
6909 : : !! integer*16 for the marker) since etype must be a multiple of the Fortran record marker
6910 : : !! Due to the above reason, block_displ is given in bytes and must be stored in a Fortran
6911 : : !! integer of kind XMPI_ADDRESS_KIND. If the displacement is too large, the routine returns
6912 : : !! offset_err=1 so that the caller will know that several MPI-IO reads are needed to
6913 : : !! write the local buffer.
6914 : : !!
6915 : : !! SOURCE
6916 : :
6917 : 0 : subroutine slk_single_fview_write(Slk_mat,uplo,nelw,elw2slk,etype,slk_type,offset_err,is_fortran_file,glob_subarray)
6918 : :
6919 : : !Arguments ------------------------------------
6920 : : !scalars
6921 : : class(slkmat_dp_t),intent(in) :: Slk_mat
6922 : : integer,intent(out) :: offset_err,slk_type,etype,nelw
6923 : : character(len=*),intent(in) :: uplo
6924 : : logical,optional,intent(in) :: is_fortran_file
6925 : : !arrays
6926 : : integer,pointer :: elw2slk(:,:)
6927 : : integer,optional,intent(in) :: glob_subarray(2,2)
6928 : :
6929 : : !Local variables ------------------------------
6930 : : !scalars
6931 : : integer :: jloc,iloc,iglob,jglob,nrows_glob,ncols_glob,mpi_err,nel_max
6932 : : integer :: grow_min,grow_max,gcol_min,gcol_max
6933 : : integer :: bsize_frm,mpi_type_elm,ij_loc,bsize_elm
6934 : : integer(XMPI_OFFSET_KIND) :: ijp_glob,my_offset,cpad_frm
6935 : : !arrays
6936 : : character(len=500) :: msg
6937 : 0 : integer,allocatable :: block_length(:),block_type(:)
6938 : 0 : integer(XMPI_ADDRESS_KIND),allocatable :: block_displ(:)
6939 : : !************************************************************************
6940 : :
6941 : : #ifdef HAVE_MPI_IO
6942 : : !@slkmat_dp_t
6943 : 0 : bsize_frm = xmpio_bsize_frm ! Byte size of the Fortran record marker.
6944 [ # # ]: 0 : if (PRESENT(is_fortran_file)) then
6945 [ # # ]: 0 : if (.not.is_fortran_file) bsize_frm = 0
6946 : : end if
6947 : :
6948 [ # # # # : 0 : if (PRESENT(glob_subarray).and..not.firstchar(uplo, ["A"])) then
# # ]
6949 : 0 : ABI_ERROR("glob_subarray should not be used when uplo/=All")
6950 : : end if
6951 : :
6952 : 0 : call slk_mat%bsize_and_type(bsize_elm, mpi_type_elm)
6953 : :
6954 : : ! Global dimensions.
6955 : 0 : nrows_glob=Slk_mat%size_global(1)
6956 : 0 : ncols_glob=Slk_mat%size_global(2)
6957 : :
6958 : : ! Number of matrix elements treated by this node.
6959 [ # # ]: 0 : nel_max = PRODUCT(Slk_mat%size_local(1:2))
6960 : :
6961 [ # # # # : 0 : ABI_MALLOC(elw2slk,(2,nel_max))
# # # # #
# # # ]
6962 [ # # # # ]: 0 : elw2slk=0
6963 : :
6964 : : ! Cannot use MPI_type_CREATE_INDEXED_BLOCK since it is not correctly implemented in several MPI libraries.
6965 : : ! etype has to be set to MPI_BYTE, since the displacement in MPI structures is always in byte.
6966 : 0 : etype = MPI_BYTE
6967 : :
6968 : : ! Define the mapping between scaLAPACK buffer and the storage on file.
6969 [ # # # # : 0 : ABI_MALLOC(block_length, (nel_max+2))
# # # # #
# # # #
# ]
6970 [ # # # # : 0 : ABI_MALLOC(block_displ, (nel_max+2))
# # # # #
# # # ]
6971 [ # # # # : 0 : ABI_MALLOC(block_type, (nel_max+2))
# # # # ]
6972 : 0 : block_length(1)=1
6973 : 0 : block_displ (1)=0
6974 : 0 : block_type (1)=MPI_LB
6975 : :
6976 : : ! Note that the view assumes that the file pointer points to the first Fortran record marker.
6977 : 0 : offset_err=0
6978 : :
6979 : 0 : select case (uplo(1:1))
6980 : : case ("A","a")
6981 : : ! The entire global matrix is written on disk. TODO can use contigous vectors for better access.
6982 : 0 : grow_min=1; grow_max=nrows_glob
6983 : 0 : gcol_min=1; gcol_max=ncols_glob
6984 [ # # ]: 0 : if (PRESENT(glob_subarray)) then ! subarray access.
6985 : 0 : grow_min = glob_subarray(1,1)
6986 : 0 : gcol_min = glob_subarray(2,1)
6987 : 0 : grow_max = grow_min + glob_subarray(1,2) -1
6988 : 0 : gcol_max = gcol_min + glob_subarray(2,2) -1
6989 : : end if
6990 : :
6991 : 0 : ij_loc=0
6992 [ # # ]: 0 : do jloc=1,Slk_mat%size_local(2)
6993 [ # # ]: 0 : do iloc=1,Slk_mat%size_local(1)
6994 : 0 : call slk_mat%loc2glob(iloc, jloc, iglob, jglob)
6995 : : if (iglob>=grow_min.and.iglob<=grow_max .and. & ! glob_subarray element.
6996 [ # # # # : 0 : jglob>=gcol_min.and.jglob<=gcol_max) then
# # # # ]
6997 : 0 : ij_loc = ij_loc+1
6998 : 0 : my_offset = 2*(jglob-1)*bsize_frm + bsize_frm + (jglob-1)*nrows_glob*bsize_elm + (iglob-1) * bsize_elm
6999 [ # # ]: 0 : if (xmpio_max_address(my_offset)) offset_err=1 ! Test for possible wraparounds
7000 : 0 : block_displ (ij_loc+1) = my_offset
7001 : 0 : block_type (ij_loc+1) = mpi_type_elm
7002 : 0 : block_length(ij_loc+1) = 1
7003 [ # # ]: 0 : elw2slk(:,ij_loc) = (/iloc,jloc/) ! useless when subarray are not used but oh well!
7004 : : end if
7005 : : end do
7006 : : end do
7007 : :
7008 : : case ("U","u")
7009 : : ! Only the upper triangle of the global matrix is stored on disk.
7010 : 0 : ij_loc=0
7011 [ # # ]: 0 : do jloc=1,Slk_mat%size_local(2)
7012 [ # # ]: 0 : do iloc=1,Slk_mat%size_local(1)
7013 : 0 : call slk_mat%loc2glob(iloc, jloc, iglob, jglob)
7014 [ # # ]: 0 : if (jglob>=iglob) then
7015 : 0 : ijp_glob = iglob + jglob*(jglob-1)/2 ! Index for packed form
7016 : 0 : cpad_frm = 2*(jglob-1)*bsize_frm
7017 : 0 : ij_loc = ij_loc+1
7018 : 0 : my_offset = cpad_frm + bsize_frm + (ijp_glob-1) * bsize_elm
7019 [ # # ]: 0 : if (xmpio_max_address(my_offset)) offset_err=1 ! Test for possible wraparounds
7020 : 0 : block_displ (ij_loc+1) = my_offset
7021 : 0 : block_type (ij_loc+1) = mpi_type_elm
7022 : 0 : block_length(ij_loc+1) = 1
7023 [ # # ]: 0 : elw2slk(:,ij_loc) = (/iloc,jloc/)
7024 : : end if
7025 : : end do
7026 : : end do
7027 : :
7028 : : case ("L","l")
7029 : : ! Only the lower triangle of the global matrix is stored on disk.
7030 : 0 : ij_loc=0
7031 [ # # ]: 0 : do jloc=1,Slk_mat%size_local(2)
7032 [ # # ]: 0 : do iloc=1,Slk_mat%size_local(1)
7033 : 0 : call slk_mat%loc2glob(iloc, jloc, iglob, jglob)
7034 [ # # ]: 0 : if (jglob<=iglob) then
7035 : 0 : ijp_glob = iglob + (jglob-1)*(2*nrows_glob-jglob)/2 ! Index for packed form
7036 : 0 : cpad_frm = 2*(jglob-1)*bsize_frm
7037 : 0 : ij_loc = ij_loc+1
7038 : 0 : my_offset = cpad_frm + bsize_frm + (ijp_glob-1) * bsize_elm
7039 [ # # ]: 0 : if (xmpio_max_address(my_offset)) offset_err=1 ! block_displ is usually integer*4. Test for possible wraparounds
7040 : 0 : block_displ (ij_loc+1) = my_offset
7041 : 0 : block_type (ij_loc+1) = mpi_type_elm
7042 : 0 : block_length(ij_loc+1) = 1
7043 [ # # ]: 0 : elw2slk(:,ij_loc) = (/iloc,jloc/)
7044 : : end if
7045 : : end do
7046 : : end do
7047 : :
7048 : : case default
7049 [ # # # # : 0 : ABI_BUG(" Wrong uplo: "//TRIM(uplo))
# # ]
7050 : : end select
7051 : :
7052 [ # # ]: 0 : if (offset_err/=0) then ! just warn, let the caller handle the exception.
7053 : : write(msg,"(3a)")&
7054 : 0 : "Global position index cannot be stored in standard Fortran integer ",ch10,&
7055 : 0 : "scaLAPACK matrix cannot be read with a single MPI-IO call ."
7056 : 0 : ABI_WARNING(msg)
7057 : : end if
7058 : :
7059 : : ! Final number of matrix elements that will be written by this node.
7060 : 0 : nelw = ij_loc
7061 : :
7062 : 0 : block_length(nelw+2)= 1
7063 : 0 : block_displ (nelw+2)= ncols_glob * (nrows_glob*bsize_elm + 2*bsize_frm)
7064 : 0 : block_type (nelw+2)= MPI_UB
7065 : :
7066 : 0 : call xmpio_type_struct(nelw+2,block_length,block_displ,block_type,slk_type,mpi_err)
7067 : 0 : ABI_CHECK_MPI(mpi_err, "MPI_type_STRUCT")
7068 : :
7069 : 0 : ABI_FREE(block_length)
7070 : 0 : ABI_FREE(block_displ)
7071 : 0 : ABI_FREE(block_type)
7072 : :
7073 : 0 : call MPI_type_COMMIT(slk_type,mpi_err)
7074 : 0 : ABI_CHECK_MPI(mpi_err, "MPI_type_COMMIT")
7075 : :
7076 : : #else
7077 : : ABI_ERROR("MPI-IO is mandatatory in slk_single_fview_read")
7078 : : #endif
7079 : :
7080 : 0 : end subroutine slk_single_fview_write
7081 : : !!***
7082 : :
7083 : : !----------------------------------------------------------------------
7084 : :
7085 : : !!****f* m_slk/slkmat_dp_bsize_and_type
7086 : : !! NAME
7087 : : !! slkmat_dp_bsize_and_type
7088 : : !!
7089 : : !! FUNCTION
7090 : : !! Returns the byte size and the MPI datatype associated to the matrix elements
7091 : : !! that are stored in the ScaLAPACK_matrix
7092 : : !!
7093 : : !! INPUTS
7094 : : !! Slk_mat<slkmat_dp_t>=Structured datatype defining the scaLAPACK distribution with the local buffer
7095 : : !!
7096 : : !! OUTPUT
7097 : : !! bsize_elm=Byte size of the matrix element.
7098 : : !! mpi_type_elm=MPI datatype of the matrix element.
7099 : : !!
7100 : : !! SOURCE
7101 : :
7102 : 0 : subroutine slkmat_dp_bsize_and_type(Slk_mat, bsize_elm, mpi_type_elm)
7103 : :
7104 : : !Arguments ------------------------------------
7105 : : !scalars
7106 : : class(slkmat_dp_t),intent(in) :: Slk_mat
7107 : : integer,intent(out) :: bsize_elm,mpi_type_elm
7108 : :
7109 : : !Local variables ------------------------------
7110 : : !scalars
7111 : : integer :: ierr
7112 : : character(len=500) :: msg
7113 : : ! ************************************************************************
7114 : :
7115 : 0 : ierr=0
7116 : : #ifdef HAVE_MPI
7117 [ # # ]: 0 : if (allocated(Slk_mat%buffer_cplx)) then
7118 : 0 : ierr = ierr + 1
7119 : 0 : mpi_type_elm = MPI_DOUBLE_COMPLEX
7120 : 0 : bsize_elm = xmpi_bsize_dpc
7121 : : end if
7122 : :
7123 [ # # ]: 0 : if (allocated(Slk_mat%buffer_real)) then
7124 : 0 : ierr = ierr + 1
7125 : 0 : mpi_type_elm = MPI_DOUBLE_PRECISION
7126 : 0 : bsize_elm = xmpi_bsize_dp
7127 : : end if
7128 : : #endif
7129 : :
7130 : : ! One and only one buffer should be allocated.
7131 [ # # ]: 0 : if (ierr /= 1) then
7132 : 0 : write(msg,'(a,i0)')" ScaLAPACK buffers are not allocated correctly, ierr= ",ierr
7133 : 0 : ABI_ERROR(msg)
7134 : : end if
7135 : :
7136 : 0 : end subroutine slkmat_dp_bsize_and_type
7137 : : !!***
7138 : :
7139 : : !----------------------------------------------------------------------
7140 : :
7141 : : !!****f* m_slk/slkmat_sp_svd
7142 : : !! NAME
7143 : : !! slkmat_sp_svd
7144 : : !!
7145 : : !! FUNCTION
7146 : : !! Compute Singular Value Decomposition of matrix in_mat (single precision version).
7147 : : !!
7148 : : !! SIDE EFFECTS
7149 : : !! in_mat: matrix is destroyed in output.
7150 : : !!
7151 : : !! SOURCE
7152 : :
7153 [ # # # # ]: 0 : subroutine slkmat_sp_svd(in_mat, jobu, jobvt, u_mat, s_vals, vt_mat)
7154 : :
7155 : : !Arguments ------------------------------------
7156 : : class(slkmat_sp_t),intent(inout) :: in_mat
7157 : : character(len=1),intent(in) :: jobu, jobvt
7158 : : class(slkmat_sp_t),intent(out) :: u_mat, vt_mat
7159 : : real(sp),allocatable, intent(out) :: s_vals(:)
7160 : :
7161 : : #ifdef HAVE_LINALG_SCALAPACK
7162 : : !Local variables ------------------------------
7163 : : !scalars
7164 : : integer :: info, lwork, lrwork, isize, mm, nn
7165 : : !array
7166 : : real(sp),allocatable :: rwork_sp(:)
7167 : : complex(sp),allocatable :: cwork_sp(:)
7168 : : !************************************************************************
7169 : :
7170 : : if (in_mat%desc(MB_) /= in_mat%desc(NB_)) then
7171 : : ABI_ERROR("PCGESVD requires square block decomposition i.e MB_A = NB_A.")
7172 : : end if
7173 : :
7174 : : mm = in_mat%size_global(1); nn = in_mat%size_global(2); isize = min(mm, nn)
7175 : :
7176 : : ! Allocate singular values and output matrices.
7177 : :
7178 : : ABI_CALLOC(s_vals, (isize))
7179 : : if (jobu == "V") call u_mat%init(mm, isize, in_mat%processor, in_mat%istwf_k)
7180 : : if (jobvt == "V") call vt_mat%init(isize, nn, in_mat%processor, in_mat%istwf_k)
7181 : :
7182 : : if (allocated(in_mat%buffer_cplx)) then
7183 : : ! Query optimal workspace size
7184 : : lwork = -1
7185 : : ABI_MALLOC(cwork_sp, (1))
7186 : : ABI_MALLOC(rwork_sp, (1))
7187 : :
7188 : : call PCGESVD(jobu, jobvt, &
7189 : : mm, nn, in_mat%buffer_cplx, 1, 1, in_mat%desc, s_vals, &
7190 : : u_mat%buffer_cplx, 1, 1, u_mat%desc, &
7191 : : vt_mat%buffer_cplx, 1, 1, vt_mat%desc, &
7192 : : cwork_sp, lwork, rwork_sp, info)
7193 : :
7194 : : ABI_CHECK(info == 0, sjoin("CZGESVD returned info:", itoa(info)))
7195 : :
7196 : : ! Allocate optimal workspace
7197 : : lwork = nint(real(cwork_sp(1)))
7198 : : lrwork = nint(rwork_sp(1))
7199 : : ABI_FREE(cwork_sp)
7200 : : ABI_FREE(rwork_sp)
7201 : :
7202 : : ABI_MALLOC(cwork_sp, (lwork))
7203 : : ABI_MALLOC(rwork_sp, (lrwork))
7204 : :
7205 : : ! Perform SVD
7206 : : call PCGESVD(jobu, jobvt, &
7207 : : mm, nn, in_mat%buffer_cplx, 1, 1, in_mat%desc, s_vals, &
7208 : : u_mat%buffer_cplx, 1, 1, u_mat%desc, &
7209 : : vt_mat%buffer_cplx, 1, 1, vt_mat%desc, &
7210 : : cwork_sp, lwork, rwork_sp, info)
7211 : :
7212 : : ABI_FREE(cwork_sp)
7213 : : ABI_FREE(rwork_sp)
7214 : : ABI_CHECK(info == 0, sjoin("PCGESVD returned info:", itoa(info)))
7215 : :
7216 : : else if (allocated(in_mat%buffer_real)) then
7217 : : ABI_ERROR("SVD for real matrices not coded!")
7218 : : else
7219 : : ABI_ERROR("Neither complex nor real buffer are allocated!")
7220 : : end if
7221 : : #endif
7222 : :
7223 : 0 : end subroutine slkmat_sp_svd
7224 : : !!***
7225 : :
7226 : : !----------------------------------------------------------------------
7227 : :
7228 : : !!****f* m_slk/slkmat_dp_svd
7229 : : !! NAME
7230 : : !! slkmat_dp_svd
7231 : : !!
7232 : : !! FUNCTION
7233 : : !! Compute Singular Value Decomposition of matrix in_mat (double precision version).
7234 : : !!
7235 : : !! SIDE EFFECTS
7236 : : !! in_mat: matrix is destroyed in output.
7237 : : !!
7238 : : !! SOURCE
7239 : :
7240 [ # # # # ]: 0 : subroutine slkmat_dp_svd(in_mat, jobu, jobvt, u_mat, s_vals, vt_mat)
7241 : :
7242 : : !Arguments ------------------------------------
7243 : : class(slkmat_dp_t),intent(inout) :: in_mat
7244 : : character(len=1),intent(in) :: jobu, jobvt
7245 : : class(slkmat_dp_t),intent(out) :: u_mat, vt_mat
7246 : : real(dp),allocatable, intent(out) :: s_vals(:)
7247 : :
7248 : : #ifdef HAVE_LINALG_SCALAPACK
7249 : : !Local variables ------------------------------
7250 : : !scalars
7251 : : integer :: info, lwork, lrwork, isize, mm, nn
7252 : : !array
7253 : : real(dp),allocatable :: rwork_dp(:)
7254 : : complex(dp),allocatable :: cwork_dp(:)
7255 : : !************************************************************************
7256 : :
7257 : : if (in_mat%desc(MB_) /= in_mat%desc(NB_)) then
7258 : : ABI_ERROR("PZGESVD requires square block decomposition i.e MB_A = NB_A.")
7259 : : end if
7260 : :
7261 : : mm = in_mat%size_global(1); nn = in_mat%size_global(2); isize = min(mm, nn)
7262 : :
7263 : : ! Allocate singular values and output matrices.
7264 : : ABI_CALLOC(s_vals, (isize))
7265 : :
7266 : : if (jobu == "V") call u_mat%init(mm, isize, in_mat%processor, in_mat%istwf_k)
7267 : : if (jobvt == "V") call vt_mat%init(isize, nn, in_mat%processor, in_mat%istwf_k)
7268 : :
7269 : : if (allocated(in_mat%buffer_cplx)) then
7270 : : ! Query optimal workspace size
7271 : : lwork = -1
7272 : : ABI_MALLOC(cwork_dp, (1))
7273 : : ABI_MALLOC(rwork_dp, (1))
7274 : :
7275 : : call PZGESVD(jobu, jobvt, &
7276 : : mm, nn, in_mat%buffer_cplx, 1, 1, in_mat%desc, s_vals, &
7277 : : u_mat%buffer_cplx, 1, 1, u_mat%desc, &
7278 : : vt_mat%buffer_cplx, 1, 1, vt_mat%desc, &
7279 : : cwork_dp, lwork, rwork_dp, info)
7280 : :
7281 : : ABI_CHECK(info == 0, sjoin("CZGESVD returned info:", itoa(info)))
7282 : :
7283 : : ! Allocate optimal workspace
7284 : : lwork = nint(real(cwork_dp(1)))
7285 : : lrwork = nint(rwork_dp(1))
7286 : : ABI_FREE(cwork_dp)
7287 : : ABI_FREE(rwork_dp)
7288 : :
7289 : : ABI_MALLOC(cwork_dp, (lwork))
7290 : : ABI_MALLOC(rwork_dp, (lrwork))
7291 : :
7292 : : ! Perform SVD
7293 : : call PZGESVD(jobu, jobvt, &
7294 : : mm, nn, in_mat%buffer_cplx, 1, 1, in_mat%desc, s_vals, &
7295 : : u_mat%buffer_cplx, 1, 1, u_mat%desc, &
7296 : : vt_mat%buffer_cplx, 1, 1, vt_mat%desc, &
7297 : : cwork_dp, lwork, rwork_dp, info)
7298 : :
7299 : : ABI_FREE(cwork_dp)
7300 : : ABI_FREE(rwork_dp)
7301 : : ABI_CHECK(info == 0, sjoin("CZGESVD returned info:", itoa(info)))
7302 : :
7303 : : else if (allocated(in_mat%buffer_real)) then
7304 : : ABI_ERROR("SVD for real matrices not coded!")
7305 : : else
7306 : : ABI_ERROR("Neither complex nor real buffer are allocated!")
7307 : : end if
7308 : : #endif
7309 : :
7310 : 0 : end subroutine slkmat_dp_svd
7311 : : !!***
7312 : :
7313 [ # # # # : 0 : end module m_slk
# # # # #
# # # # #
# # # # #
# # # #
# ]
7314 : : !!***
|
