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 : !!***
|
