1!--------------------------------------------------------------------------------------------------! 2! Copyright (C) by the DBCSR developers group - All rights reserved ! 3! This file is part of the DBCSR library. ! 4! ! 5! For information on the license, see the LICENSE file. ! 6! For further information please visit https://dbcsr.cp2k.org ! 7! SPDX-License-Identifier: GPL-2.0+ ! 8!--------------------------------------------------------------------------------------------------! 9 10MODULE dbcsr_io 11 !! DBCSR input/output 12 USE dbcsr_array_types, ONLY: array_data 13 USE dbcsr_data_methods, ONLY: dbcsr_data_clear_pointer, & 14 dbcsr_data_get_size_referenced, & 15 dbcsr_data_init, & 16 dbcsr_data_new, & 17 dbcsr_get_data 18 USE dbcsr_dist_methods, ONLY: dbcsr_distribution_mp 19 USE dbcsr_kinds, ONLY: default_string_length, & 20 dp, & 21 real_4, & 22 real_4_size, & 23 real_8, & 24 real_8_size, & 25 sp 26 USE dbcsr_machine, ONLY: default_output_unit 27 USE dbcsr_methods, ONLY: & 28 dbcsr_data_area, dbcsr_distribution, dbcsr_get_data_size, dbcsr_get_data_type, & 29 dbcsr_get_matrix_type, dbcsr_get_num_blocks, dbcsr_name, dbcsr_nblkcols_total, & 30 dbcsr_nblkrows_total, dbcsr_valid_index 31 USE dbcsr_mp_methods, ONLY: dbcsr_mp_group, & 32 dbcsr_mp_pgrid 33 USE dbcsr_mp_operations, ONLY: dbcsr_mp_type_from_anytype 34 USE dbcsr_mpiwrap, ONLY: & 35 file_amode_create, file_amode_rdonly, file_amode_wronly, file_offset, mp_allgather, & 36 mp_environ, mp_file_close, mp_file_get_size, mp_file_open, mp_file_read_at_all, & 37 mp_file_write_at, mp_file_write_at_all, mp_sum, mp_type_descriptor_type, mp_type_size, & 38 mpi_character_size, mpi_integer_size 39 USE dbcsr_transformations, ONLY: dbcsr_datablock_redistribute 40 USE dbcsr_types, ONLY: dbcsr_data_obj, & 41 dbcsr_distribution_obj, & 42 dbcsr_mp_obj, & 43 dbcsr_type, & 44 dbcsr_type_complex_4, & 45 dbcsr_type_complex_8, & 46 dbcsr_type_real_4, & 47 dbcsr_type_real_8 48 USE dbcsr_work_operations, ONLY: dbcsr_create 49#include "base/dbcsr_base_uses.f90" 50 51!$ USE OMP_LIB, ONLY: omp_get_max_threads, omp_get_thread_num, omp_get_num_threads 52 53 IMPLICIT NONE 54 55 PRIVATE 56 57 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'dbcsr_io' 58 59 ! Main 60 PUBLIC :: dbcsr_print 61 PUBLIC :: dbcsr_print_block_sum 62 ! Low-level printing 63! PUBLIC :: dbcsr_printmat, dbcsr_print2dmat 64 ! Utility printing 65 PUBLIC :: dbcsr_binary_write 66 PUBLIC :: dbcsr_binary_read 67 68 LOGICAL, PARAMETER :: bcsr_debug = .TRUE. 69 LOGICAL, PARAMETER :: bcsr_info = .FALSE. 70 LOGICAL, PARAMETER :: bcsr_verbose = .FALSE. 71 72 INTERFACE dbcsr_printmat 73 MODULE PROCEDURE printmat_s, printmat_d, printmat_c, printmat_z 74 END INTERFACE 75 76CONTAINS 77 78 SUBROUTINE dbcsr_print(matrix, nodata, matlab_format, variable_name, unit_nr) 79 !! Prints a BCSR matrix (block-style, not full) 80 81 TYPE(dbcsr_type), INTENT(IN) :: matrix 82 !! matrix 83 LOGICAL, INTENT(IN), OPTIONAL :: nodata, matlab_format 84 !! don't print actual data 85 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable_name 86 INTEGER, INTENT(IN), OPTIONAL :: unit_nr 87 88 CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_print', routineP = moduleN//':'//routineN 89 90 COMPLEX(KIND=real_4), DIMENSION(:), POINTER :: c_sp 91 COMPLEX(KIND=real_8), DIMENSION(:), POINTER :: c_dp 92 INTEGER :: ablk_p, bc, blk, blk_p, br, ebr, fblk, & 93 handle, ibr, iunit, lblk, m, mn, n, & 94 sblk 95 INTEGER, DIMENSION(:), POINTER :: col_blk_offset, col_blk_size, & 96 local_cols, local_rows, & 97 row_blk_offset, row_blk_size 98 LOGICAL :: my_matlab_format, tr, yesprint 99 REAL(KIND=dp) :: blk_cs 100 REAL(KIND=real_4), DIMENSION(:), POINTER :: r_sp 101 REAL(KIND=real_8), DIMENSION(:), POINTER :: r_dp 102 103! --------------------------------------------------------------------------- 104 105 CALL timeset(routineN, handle) 106 IF (.NOT. dbcsr_valid_index(matrix)) & 107 DBCSR_WARN("Can not print invalid matrix.") 108 109 iunit = default_output_unit 110 IF (PRESENT(unit_nr)) iunit = unit_nr 111 112 my_matlab_format = .FALSE. 113 IF (PRESENT(matlab_format)) my_matlab_format = matlab_format 114 yesprint = .TRUE. 115 IF (PRESENT(nodata)) yesprint = .NOT. nodata 116 WRITE (iunit, *) routineP//' Contents of matrix named ', matrix%name 117 WRITE (iunit, *) routineP//' Flags ', matrix%symmetry, & 118 matrix%negate_real, matrix%negate_imaginary, "type", & 119 dbcsr_get_data_type(matrix), "serial", matrix%serial_number 120 WRITE (iunit, '(1X,A,3(1X,I9,1X,A))') routineP, matrix%nblks, "blocks", & 121 matrix%nze, "nzes,", dbcsr_get_data_size(matrix), "data els", & 122 dbcsr_data_get_size_referenced(matrix%data_area), "used" 123 WRITE (iunit, '(1X,A,I5,A,I5)') routineP//" Full size", & 124 matrix%nfullrows_total, "x", matrix%nfullcols_total 125 WRITE (iunit, '(1X,A,I5,A,I5)') routineP//" Blocked size", & 126 matrix%nblkrows_total, "x", matrix%nblkcols_total 127 SELECT CASE (matrix%data_type) 128 CASE (dbcsr_type_real_8) 129 CALL dbcsr_get_data(matrix%data_area, r_dp) 130 CASE (dbcsr_type_real_4) 131 CALL dbcsr_get_data(matrix%data_area, r_sp) 132 CASE (dbcsr_type_complex_8) 133 CALL dbcsr_get_data(matrix%data_area, c_dp) 134 CASE (dbcsr_type_complex_4) 135 CALL dbcsr_get_data(matrix%data_area, c_sp) 136 END SELECT 137 row_blk_size => array_data(matrix%row_blk_size) 138 col_blk_size => array_data(matrix%col_blk_size) 139 row_blk_offset => array_data(matrix%row_blk_offset) 140 col_blk_offset => array_data(matrix%col_blk_offset) 141 142 IF (matrix%nblks .GT. 0) THEN 143 IF (matrix%list_indexing) THEN 144 IF (SIZE(matrix%coo_l) .NE. 3*matrix%nblks) & 145 DBCSR_ABORT("Wrong list") 146 ebr = 1 147 sblk = 3 148 ELSE 149 ebr = matrix%nblkrows_total 150 sblk = 1 151 ENDIF 152 DO ibr = 1, ebr 153 IF (matrix%list_indexing) THEN 154 fblk = 1 155 lblk = SIZE(matrix%coo_l) 156 ELSE 157 br = ibr 158 fblk = matrix%row_p(br) + 1 159 lblk = matrix%row_p(br + 1) 160 m = row_blk_size(br) 161 ENDIF 162 DO blk = fblk, lblk, sblk 163 IF (matrix%list_indexing) THEN 164 br = matrix%coo_l(blk) 165 bc = matrix%coo_l(blk + 1) 166 IF (matrix%local_indexing) THEN 167 local_rows => array_data(matrix%local_rows) 168 local_cols => array_data(matrix%local_cols) 169 br = local_rows(br) 170 bc = local_cols(bc) 171 ENDIF 172 m = row_blk_size(br) 173 ablk_p = matrix%coo_l(blk + 2) 174 ELSE 175 bc = matrix%col_i(blk) 176 ablk_p = matrix%blk_p(blk) 177 ENDIF 178 n = col_blk_size(bc) 179 mn = m*n 180 blk_p = ABS(ablk_p) 181 tr = ablk_p .LT. 0 182 block_exists: IF (blk_p .NE. 0) THEN 183 IF (mn .GT. 0) THEN 184 SELECT CASE (matrix%data_type) 185 CASE (dbcsr_type_real_8) 186 blk_cs = REAL(DOT_PRODUCT(r_dp(blk_p:blk_p + mn - 1), & 187 r_dp(blk_p:blk_p + mn - 1)), KIND=dp) 188 !CALL & 189 ! dbcsr_printmat(r_dp(blk_p:blk_p+mn-1),m,n, tr=tr) 190 CASE (dbcsr_type_real_4) 191 blk_cs = REAL(DOT_PRODUCT(r_sp(blk_p:blk_p + mn - 1), & 192 r_sp(blk_p:blk_p + mn - 1)), KIND=dp) 193 !CALL & 194 ! dbcsr_printmat(r_sp(blk_p:blk_p+mn-1),m,n, tr=tr) 195 CASE (dbcsr_type_complex_8) 196 blk_cs = REAL(DOT_PRODUCT(c_dp(blk_p:blk_p + mn - 1), & 197 c_dp(blk_p:blk_p + mn - 1)), KIND=dp) 198 !CALL & 199 ! dbcsr_printmat(c_dp(blk_p:blk_p+mn-1),m,n, tr=tr) 200 CASE (dbcsr_type_complex_4) 201 blk_cs = REAL(DOT_PRODUCT(c_sp(blk_p:blk_p + mn - 1), & 202 c_sp(blk_p:blk_p + mn - 1)), KIND=dp) 203 !CALL & 204 ! dbcsr_printmat(c_sp(blk_p:blk_p+mn-1),m,n, tr=tr) 205 END SELECT 206 ELSE 207 blk_cs = 0.0_dp 208 ENDIF 209 !WRITE(iunit,*)routineP//' chksum for (',br,',',bc,') at',& 210 ! blk_p,'l',mn,'= ', blk_cs,'size',m,n 211 IF (.NOT. my_matlab_format) WRITE (iunit, '(A,I6,",",I6,A,I7,A,I6,I6,"=",I7,A,E12.3)') & 212 !" Checksum for (",br,bc,") at ",blk_p," size ",m,n,mn,& 213 " Checksum for (", br, bc, ") at ", ablk_p, " size ", m, n, mn, & 214 " checksum=", blk_cs 215 IF (yesprint .AND. blk_p .NE. 0) THEN 216 IF (mn .GT. 0) THEN 217 SELECT CASE (matrix%data_type) 218 CASE (dbcsr_type_real_8) 219 !WRITE(iunit,'(10(1X,F7.2))')r_dp(blk_p:blk_p+mn-1) 220 IF (my_matlab_format) THEN 221 CALL dbcsr_printmat_matlab_d(r_dp(blk_p:blk_p + mn - 1), m, n, & 222 row_blk_offset(br), col_blk_offset(bc), iunit, tr=tr, & 223 variable_name=variable_name) 224 ELSE 225 CALL dbcsr_printmat(r_dp(blk_p:blk_p + mn - 1), m, n, iunit=iunit, tr=tr) 226 ENDIF 227 CASE (dbcsr_type_real_4) 228 IF (my_matlab_format) THEN 229 CALL dbcsr_printmat_matlab_s(r_sp(blk_p:blk_p + mn - 1), m, n, & 230 row_blk_offset(br), col_blk_offset(bc), iunit, tr=tr, & 231 variable_name=variable_name) 232 ELSE 233 CALL dbcsr_printmat(r_sp(blk_p:blk_p + mn - 1), m, n, iunit=iunit, tr=tr) 234 ENDIF 235 CASE (dbcsr_type_complex_8) 236 IF (my_matlab_format) THEN 237 CALL dbcsr_printmat_matlab_z(c_dp(blk_p:blk_p + mn - 1), m, n, & 238 row_blk_offset(br), col_blk_offset(bc), iunit, tr=tr, & 239 variable_name=variable_name) 240 ELSE 241 CALL dbcsr_printmat(c_dp(blk_p:blk_p + mn - 1), m, n, iunit=iunit, tr=tr) 242 ENDIF 243 CASE (dbcsr_type_complex_4) 244 IF (my_matlab_format) THEN 245 CALL dbcsr_printmat_matlab_c(c_sp(blk_p:blk_p + mn - 1), m, n, & 246 row_blk_offset(br), col_blk_offset(bc), iunit, tr=tr, & 247 variable_name=variable_name) 248 ELSE 249 CALL dbcsr_printmat(c_sp(blk_p:blk_p + mn - 1), m, n, iunit=iunit, tr=tr) 250 ENDIF 251 END SELECT 252 ENDIF 253 ENDIF 254 ENDIF block_exists 255 ENDDO 256 ENDDO 257 ENDIF 258 CALL timestop(handle) 259 END SUBROUTINE dbcsr_print 260 261 SUBROUTINE dbcsr_printmat_matlab_d(matrix, rows, cols, r_offset, c_offset, iunit, tr, variable_name) 262 !! Prints the elements of a matrix. 263 264 REAL(KIND=real_8), DIMENSION(:), INTENT(IN) :: matrix 265 INTEGER, INTENT(IN) :: rows, cols, r_offset, c_offset, iunit 266 !! the logical (possibly detransposed) matrix size, not the stored size 267 !! the logical (possibly detransposed) matrix size, not the stored size 268 LOGICAL, INTENT(IN), OPTIONAL :: tr 269 !! specifies whether the elements are stored transposed 270 CHARACTER(len=*), INTENT(in), OPTIONAL :: variable_name 271 272 INTEGER :: c, c_off, m, n, r, r_off 273 LOGICAL :: t 274 275! --------------------------------------------------------------------------- 276 277 m = rows 278 n = cols 279 r_off = r_offset 280 c_off = c_offset 281 t = .FALSE. 282 IF (PRESENT(tr)) THEN 283 IF (tr) THEN 284 t = .TRUE. 285 m = cols 286 n = rows 287 r_off = c_offset 288 c_off = r_offset 289 ENDIF 290 ENDIF 291 292 DO c = 1, cols 293 DO r = 1, rows 294 IF (.NOT. t) THEN 295 IF (PRESENT(variable_name)) THEN 296 WRITE (iunit, '(A,I4,A,I4,A,E23.16,A)') & 297 variable_name//'(', r + r_offset - 1, ',', c + c_offset - 1, ')=', matrix(r + (c - 1)*rows), ';' 298 ELSE 299 WRITE (iunit, '(A,I4,A,I4,A,E23.16,A)') 'a(', r + r_offset - 1, ',', & 300 c + c_offset - 1, ')=', matrix(r + (c - 1)*rows), ';' 301 ENDIF 302 ELSE 303 IF (PRESENT(variable_name)) THEN 304 WRITE (iunit, '(A,I4,A,I4,A,E23.16,A)') & 305 variable_name//'(', r + r_offset - 1, ',', c + c_offset - 1, ')=', matrix((r - 1)*cols + c), ';' 306 ELSE 307 WRITE (iunit, '(A,I4,A,I4,A,E23.16,A)') 'a(', r + r_offset - 1, ',', & 308 c + c_offset - 1, ')=', matrix((r - 1)*cols + c), ';' 309 ENDIF 310 ENDIF 311 ENDDO 312 ENDDO 313 END SUBROUTINE dbcsr_printmat_matlab_d 314 315 SUBROUTINE dbcsr_printmat_matlab_s(matrix, rows, cols, r_offset, c_offset, iunit, tr, variable_name) 316 REAL(KIND=real_4), DIMENSION(:), INTENT(IN) :: matrix 317 INTEGER, INTENT(IN) :: rows, cols, r_offset, c_offset, iunit 318 LOGICAL, INTENT(IN), OPTIONAL :: tr 319 CHARACTER(len=*), INTENT(in), OPTIONAL :: variable_name 320 321 INTEGER :: c, c_off, m, n, r, r_off 322 LOGICAL :: t 323 324! --------------------------------------------------------------------------- 325 326 m = rows 327 n = cols 328 r_off = r_offset 329 c_off = c_offset 330 t = .FALSE. 331 IF (PRESENT(tr)) THEN 332 IF (tr) THEN 333 t = .TRUE. 334 m = cols 335 n = rows 336 r_off = c_offset 337 c_off = r_offset 338 ENDIF 339 ENDIF 340 341 DO c = 1, cols 342 DO r = 1, rows 343 IF (.NOT. t) THEN 344 IF (PRESENT(variable_name)) THEN 345 WRITE (iunit, '(A,I4,A,I4,A,E15.7,A)') & 346 variable_name//'(', r + r_offset - 1, ',', c + c_offset - 1, ')=', matrix(r + (c - 1)*rows), ';' 347 ELSE 348 WRITE (iunit, '(A,I4,A,I4,A,E15.7,A)') 'a(', r + r_offset - 1, ',', & 349 c + c_offset - 1, ')=', matrix(r + (c - 1)*rows), ';' 350 ENDIF 351 ELSE 352 IF (PRESENT(variable_name)) THEN 353 WRITE (iunit, '(A,I4,A,I4,A,E15.7,A)') & 354 variable_name//'(', r + r_offset - 1, ',', c + c_offset - 1, ')=', matrix((r - 1)*cols + c), ';' 355 ELSE 356 WRITE (iunit, '(A,I4,A,I4,A,E15.7,A)') 'a(', r + r_offset - 1, ',', & 357 c + c_offset - 1, ')=', matrix((r - 1)*cols + c), ';' 358 ENDIF 359 ENDIF 360 ENDDO 361 ENDDO 362 END SUBROUTINE dbcsr_printmat_matlab_s 363 364 SUBROUTINE dbcsr_printmat_matlab_z(matrix, rows, cols, r_offset, c_offset, iunit, tr, variable_name) 365 COMPLEX(KIND=real_8), DIMENSION(:), INTENT(IN) :: matrix 366 INTEGER, INTENT(IN) :: rows, cols, r_offset, c_offset, iunit 367 LOGICAL, INTENT(IN), OPTIONAL :: tr 368 CHARACTER(len=*), INTENT(in), OPTIONAL :: variable_name 369 370 INTEGER :: c, c_off, m, n, r, r_off 371 LOGICAL :: t 372 373! --------------------------------------------------------------------------- 374 375 m = rows 376 n = cols 377 r_off = r_offset 378 c_off = c_offset 379 t = .FALSE. 380 IF (PRESENT(tr)) THEN 381 IF (tr) THEN 382 t = .TRUE. 383 m = cols 384 n = rows 385 r_off = c_offset 386 c_off = r_offset 387 ENDIF 388 ENDIF 389 390 DO c = 1, cols 391 DO r = 1, rows 392 IF (.NOT. t) THEN 393 IF (PRESENT(variable_name)) THEN 394 WRITE (iunit, '(A,I3,A,I3,A,E23.16,A,E23.16,A)') variable_name//'(', r + r_offset - 1, ',', & 395 c + c_offset - 1, ')=', & 396 REAL(matrix(r + (c - 1)*rows)), '+', AIMAG(matrix(r + (c - 1)*rows)), 'i;' 397 ELSE 398 WRITE (iunit, '(A,I3,A,I3,A,E23.16,A,E23.16,A)') 'a(', r + r_offset - 1, ',', c + c_offset - 1, ')=', & 399 REAL(matrix(r + (c - 1)*rows)), '+', AIMAG(matrix(r + (c - 1)*rows)), 'i;' 400 ENDIF 401 ELSE 402 IF (PRESENT(variable_name)) THEN 403 WRITE (iunit, '(A,I3,A,I3,A,E23.16,A,E23.16,A)') variable_name//'(', r + r_offset - 1, ',', & 404 c + c_offset - 1, ')=', & 405 REAL(matrix((r - 1)*cols + c)), '+', AIMAG(matrix((r - 1)*cols + c)), 'i;' 406 ELSE 407 WRITE (iunit, '(A,I3,A,I3,A,E23.16,A,E23.16,A)') 'a(', r + r_offset - 1, ',', c + c_offset - 1, ')=', & 408 REAL(matrix((r - 1)*cols + c)), '+', AIMAG(matrix((r - 1)*cols + c)), 'i;' 409 ENDIF 410 ENDIF 411 ENDDO 412 ENDDO 413 END SUBROUTINE dbcsr_printmat_matlab_z 414 415 SUBROUTINE dbcsr_printmat_matlab_c(matrix, rows, cols, r_offset, c_offset, iunit, tr, variable_name) 416 COMPLEX(KIND=real_4), DIMENSION(:), INTENT(IN) :: matrix 417 INTEGER, INTENT(IN) :: rows, cols, r_offset, c_offset, iunit 418 LOGICAL, INTENT(IN), OPTIONAL :: tr 419 CHARACTER(len=*), INTENT(in), OPTIONAL :: variable_name 420 421 INTEGER :: c, c_off, m, n, r, r_off 422 LOGICAL :: t 423 424! --------------------------------------------------------------------------- 425 426 m = rows 427 n = cols 428 r_off = r_offset 429 c_off = c_offset 430 t = .FALSE. 431 IF (PRESENT(tr)) THEN 432 IF (tr) THEN 433 t = .TRUE. 434 m = cols 435 n = rows 436 r_off = c_offset 437 c_off = r_offset 438 ENDIF 439 ENDIF 440 441 DO c = 1, cols 442 DO r = 1, rows 443 IF (.NOT. t) THEN 444 IF (PRESENT(variable_name)) THEN 445 WRITE (iunit, '(A,I3,A,I3,A,E15.7,A,E15.7,A)') variable_name//'(', r + r_offset - 1, ',', & 446 c + c_offset - 1, ')=', & 447 REAL(matrix(r + (c - 1)*rows)), '+', AIMAG(matrix(r + (c - 1)*rows)), 'i;' 448 ELSE 449 WRITE (iunit, '(A,I3,A,I3,A,E15.7,A,E15.7,A)') 'a(', r + r_offset - 1, ',', c + c_offset - 1, ')=', & 450 REAL(matrix(r + (c - 1)*rows)), '+', AIMAG(matrix(r + (c - 1)*rows)), 'i;' 451 ENDIF 452 ELSE 453 IF (PRESENT(variable_name)) THEN 454 WRITE (iunit, '(A,I3,A,I3,A,E15.7,A,E15.7,A)') variable_name//'(', r + r_offset - 1, ',', & 455 c + c_offset - 1, ')=', & 456 REAL(matrix((r - 1)*cols + c)), '+', AIMAG(matrix((r - 1)*cols + c)), 'i;' 457 ELSE 458 WRITE (iunit, '(A,I3,A,I3,A,E15.7,A,E15.7,A)') 'a(', r + r_offset - 1, ',', c + c_offset - 1, ')=', & 459 REAL(matrix((r - 1)*cols + c)), '+', AIMAG(matrix((r - 1)*cols + c)), 'i;' 460 ENDIF 461 ENDIF 462 ENDDO 463 ENDDO 464 END SUBROUTINE dbcsr_printmat_matlab_c 465 466 SUBROUTINE printmat_s(matrix, rows, cols, iunit, title, tr) 467 !! Prints the elements of a matrix. 468 469 REAL(KIND=real_4), DIMENSION(:), INTENT(IN) :: matrix 470 INTEGER, INTENT(IN) :: rows, cols, iunit 471 !! the logical (possibly detransposed) matrix size, not the stored size 472 !! the logical (possibly detransposed) matrix size, not the stored size 473 CHARACTER(*), INTENT(IN), OPTIONAL :: title 474 LOGICAL, INTENT(IN), OPTIONAL :: tr 475 !! specifies whether the elements are stored transposed 476 477 CHARACTER(30) :: f 478 INTEGER :: m, n, r 479 LOGICAL :: t 480 REAL(KIND=dp) :: bit_bucket 481 482! --------------------------------------------------------------------------- 483 484 m = rows 485 n = cols 486 t = .FALSE. 487 IF (PRESENT(title)) WRITE (iunit, *) title 488 IF (PRESENT(tr)) THEN 489 IF (tr) THEN 490 t = .TRUE. 491 m = cols 492 n = rows 493 ENDIF 494 ENDIF 495 DO r = LBOUND(matrix, 1), UBOUND(matrix, 1) 496 bit_bucket = matrix(r) 497 ENDDO 498 bit_bucket = 0.0_dp 499 DO r = LBOUND(matrix, 1), UBOUND(matrix, 1) 500 bit_bucket = bit_bucket + matrix(r) 501 ENDDO 502 IF (m .GT. 10000) m = 0 503 IF (n .GT. 10000) n = 0 504 IF (m*n .LT. 1 .OR. m*n .GT. SIZE(matrix)) RETURN 505 WRITE (f, FMT="('(',I4,'(F9.4))')") cols 506 DO r = 1, rows 507 IF (.NOT. t) THEN 508 WRITE (iunit, FMT=f) matrix(r:r + (cols - 1)*rows:rows) 509 ELSE 510 WRITE (iunit, FMT=f) matrix((r - 1)*cols + 1:r*cols) 511 ENDIF 512 ENDDO 513 END SUBROUTINE printmat_s 514 515 SUBROUTINE printmat_d(matrix, rows, cols, iunit, title, tr) 516 REAL(KIND=real_8), DIMENSION(:), INTENT(IN) :: matrix 517 INTEGER, INTENT(IN) :: rows, cols, iunit 518 CHARACTER(*), INTENT(IN), OPTIONAL :: title 519 LOGICAL, INTENT(IN), OPTIONAL :: tr 520 521 IF (PRESENT(title)) THEN 522 IF (PRESENT(tr)) THEN 523 CALL printmat_s(REAL(matrix, KIND=sp), rows, cols, iunit, title, tr) 524 ELSE 525 CALL printmat_s(REAL(matrix, KIND=sp), rows, cols, iunit, title) 526 ENDIF 527 ELSE 528 IF (PRESENT(tr)) THEN 529 CALL printmat_s(REAL(matrix, KIND=sp), rows, cols, iunit, tr=tr) 530 ELSE 531 CALL printmat_s(REAL(matrix, KIND=sp), rows, cols, iunit) 532 ENDIF 533 ENDIF 534 END SUBROUTINE printmat_d 535 536 SUBROUTINE printmat_c(matrix, rows, cols, iunit, title, tr) 537 COMPLEX(KIND=real_4), DIMENSION(:), INTENT(IN) :: matrix 538 INTEGER, INTENT(IN) :: rows, cols, iunit 539 CHARACTER(*), INTENT(IN), OPTIONAL :: title 540 LOGICAL, INTENT(IN), OPTIONAL :: tr 541 542 IF (PRESENT(title)) THEN 543 IF (PRESENT(tr)) THEN 544 CALL printmat_s(REAL(matrix, KIND=sp), rows, cols, iunit, title, tr) 545 ELSE 546 CALL printmat_s(REAL(matrix, KIND=sp), rows, cols, iunit, title) 547 ENDIF 548 ELSE 549 IF (PRESENT(tr)) THEN 550 CALL printmat_s(REAL(matrix, KIND=sp), rows, cols, iunit, tr=tr) 551 ELSE 552 CALL printmat_s(REAL(matrix, KIND=sp), rows, cols, iunit) 553 ENDIF 554 ENDIF 555 END SUBROUTINE printmat_c 556 557 SUBROUTINE printmat_z(matrix, rows, cols, iunit, title, tr) 558 COMPLEX(KIND=real_8), DIMENSION(:), INTENT(IN) :: matrix 559 INTEGER, INTENT(IN) :: rows, cols, iunit 560 CHARACTER(*), INTENT(IN), OPTIONAL :: title 561 LOGICAL, INTENT(IN), OPTIONAL :: tr 562 563 IF (PRESENT(title)) THEN 564 IF (PRESENT(tr)) THEN 565 CALL printmat_s(REAL(matrix, KIND=sp), rows, cols, iunit, title, tr) 566 ELSE 567 CALL printmat_s(REAL(matrix, KIND=sp), rows, cols, iunit, title) 568 ENDIF 569 ELSE 570 IF (PRESENT(tr)) THEN 571 CALL printmat_s(REAL(matrix, KIND=sp), rows, cols, iunit, tr=tr) 572 ELSE 573 CALL printmat_s(REAL(matrix, KIND=sp), rows, cols, iunit) 574 ENDIF 575 ENDIF 576 END SUBROUTINE printmat_z 577 578 SUBROUTINE dbcsr_binary_write(matrix, filepath) 579 !! Writes a DBCSR matrix in a file 580 !! file's header consists of 3 sub-headers: 581 !! sub-header1 contains: 582 !! 1 string: (of length version_len) the current version of this routine, 583 !! 1 string: (of length default_string_length) matrix_name, 584 !! 1 character: matrix_type, 585 !! 4 integers: numnodes, data_type, nblkrows_total, nblkcols_total, 586 !! 2 vectors: row_blk_size (length = nblkrows_total), 587 !! col_blk_size (length = nblkcols_total), 588 !! sub-header2 contains: 589 !! 2 integers: nblks, data_area_size, 590 !! sub-header3 contains: 591 !! 3 vectors: row_p (length = nblkrows_total+1), 592 !! col_i (length = nblks), 593 !! blk_p (length = nblks); 594 !! and the file's body contains the block data 595 596 IMPLICIT NONE 597 598 TYPE(dbcsr_type), INTENT(IN) :: matrix 599 !! DBCSR matrix 600 CHARACTER(len=*), INTENT(IN) :: filepath 601 !! path to the file 602 603 CHARACTER(LEN=*), PARAMETER :: routineN = 'dbcsr_binary_write', & 604 routineP = moduleN//':'//routineN 605 606 INTEGER :: nblkrows_total, nblkcols_total, & 607 nblks, size_of_pgrid, & 608 thefile, i, sendbuf, data_area_size, & 609 data_type, type_size, & 610 mp_group, mynode, numnodes, & 611 ginfo_size, linfo_size, handle 612 INTEGER, DIMENSION(:), POINTER :: row_p, col_i, blk_p, & 613 row_blk_size, col_blk_size 614 INTEGER, DIMENSION(:, :), POINTER :: pgrid 615 TYPE(mp_type_descriptor_type) :: mp_type 616 TYPE(dbcsr_mp_obj) :: mp_env 617 TYPE(dbcsr_distribution_obj) :: distribution 618 TYPE(dbcsr_data_obj) :: data_area 619 COMPLEX(sp), DIMENSION(:), POINTER :: c_sp 620 COMPLEX(dp), DIMENSION(:), POINTER :: c_dp 621 REAL(sp), DIMENSION(:), POINTER :: r_sp 622 REAL(dp), DIMENSION(:), POINTER :: r_dp 623 CHARACTER :: matrix_type 624 CHARACTER(LEN=80) :: matrix_name_v_1_0 625 CHARACTER(LEN=default_string_length) :: matrix_name 626 INTEGER, PARAMETER :: version_len = 10 627 CHARACTER(LEN=version_len), PARAMETER :: version = "DBCSRv_1.0" 628 INTEGER, ALLOCATABLE, DIMENSION(:) :: linfo_sizes, da_sizes 629 INTEGER(kind=file_offset), ALLOCATABLE, DIMENSION(:) :: bdata_disps, bdata_offsets, & 630 subh2_disps, subh2_offsets, & 631 subh3_disps, subh3_offsets 632 INTEGER(kind=file_offset), PARAMETER :: BOF = 0 633 INTEGER, PARAMETER :: char_count = version_len + default_string_length + 1 !version, matrix_name, matrix_type 634 635 CALL timeset(routineN, handle) 636 637 IF (default_string_length /= 80) & 638 CALL dbcsr_warn(__LOCATION__, "Changing the default string length affects "// & 639 "the format of the written matrix. Version needs to be adjusted") 640 641 nblkrows_total = dbcsr_nblkrows_total(matrix) 642 nblkcols_total = dbcsr_nblkcols_total(matrix) 643 distribution = dbcsr_distribution(matrix) 644 matrix_name = dbcsr_name(matrix) 645 data_area = dbcsr_data_area(matrix) 646 matrix_type = dbcsr_get_matrix_type(matrix) 647 data_type = dbcsr_get_data_type(matrix) 648 mp_env = dbcsr_distribution_mp(distribution) 649 mp_group = dbcsr_mp_group(mp_env) 650 nblks = dbcsr_get_num_blocks(matrix) 651 row_p => matrix%row_p 652 col_i => matrix%col_i 653 blk_p => matrix%blk_p 654 row_blk_size => array_data(matrix%row_blk_size) 655 col_blk_size => array_data(matrix%col_blk_size) 656 pgrid => dbcsr_mp_pgrid(mp_env) 657 size_of_pgrid = SIZE(pgrid) 658 659 CALL mp_environ(numnodes, mynode, mp_group) 660 661 ALLOCATE (linfo_sizes(numnodes), da_sizes(numnodes), & 662 subh2_disps(numnodes), subh2_offsets(numnodes), & 663 subh3_disps(numnodes), subh3_offsets(numnodes), & 664 bdata_disps(numnodes), bdata_offsets(numnodes)) 665 subh2_disps(:) = (/((i - 1)*2, i=1, numnodes)/) 666 subh3_disps = BOF 667 bdata_disps = BOF 668 linfo_sizes = BOF 669 subh2_offsets = BOF 670 subh3_offsets = BOF 671 bdata_offsets = BOF 672 da_sizes = BOF 673 674 ginfo_size = char_count + 4 + nblkrows_total + nblkcols_total 675 linfo_size = 1 + nblkrows_total + 2*nblks 676 677 sendbuf = linfo_size 678 CALL mp_allgather(sendbuf, linfo_sizes, mp_group) 679 CALL cumsum_l(INT(linfo_sizes, kind=file_offset), subh3_disps) 680 subh3_disps(:) = CSHIFT(subh3_disps, shift=-1) + ginfo_size + 2*numnodes 681 subh3_disps(1) = ginfo_size + 2*numnodes 682 683 data_area_size = dbcsr_data_get_size_referenced(matrix%data_area) 684 sendbuf = data_area_size 685 CALL mp_allgather(sendbuf, da_sizes, mp_group) 686 CALL cumsum_l(INT(da_sizes, kind=file_offset), bdata_disps) 687 bdata_disps(:) = CSHIFT(bdata_disps, shift=-1) + SUM(INT(linfo_sizes, KIND=file_offset)) + & 688 ginfo_size + numnodes*2 689 bdata_disps(1) = SUM(INT(linfo_sizes, KIND=file_offset)) + ginfo_size + numnodes*2 690 691 CALL mp_file_open(mp_group, thefile, filepath, file_amode_create + file_amode_wronly) 692 693 IF (mynode .EQ. 0) THEN 694 CALL mp_file_write_at(thefile, BOF, version) 695 matrix_name_v_1_0 = matrix_name 696 CALL mp_file_write_at(thefile, BOF + version_len*mpi_character_size, matrix_name_v_1_0) 697 CALL mp_file_write_at(thefile, BOF + (version_len + default_string_length)*mpi_character_size, matrix_type) 698 CALL mp_file_write_at(thefile, BOF + char_count*mpi_character_size, & 699 (/size_of_pgrid, data_type, & 700 nblkrows_total, nblkcols_total, & 701 row_blk_size, col_blk_size/)) 702 END IF 703! write sub-header2 704 subh2_disps(:) = subh2_disps(:) + ginfo_size 705 subh2_offsets(:) = BOF + (subh2_disps - char_count)*mpi_integer_size + & 706 char_count*mpi_character_size 707 CALL mp_file_write_at_all(thefile, subh2_offsets(mynode + 1), (/nblks, data_area_size/)) 708! write sub-header3 709 subh3_offsets(:) = BOF + (subh3_disps - char_count)*mpi_integer_size + & 710 char_count*mpi_character_size 711 CALL mp_file_write_at_all(thefile, subh3_offsets(mynode + 1), (/row_p, col_i, blk_p/)) 712! write block data 713 mp_type = dbcsr_mp_type_from_anytype(data_area) 714 CALL mp_type_size(mp_type, type_size) 715 bdata_offsets(:) = BOF + (/((bdata_disps(i) - bdata_disps(1))*type_size, i=1, numnodes)/) + & 716 (bdata_disps(1) - char_count)*mpi_integer_size + & 717 char_count*mpi_character_size 718 SELECT CASE (data_type) 719 CASE (dbcsr_type_real_4) 720 r_sp => data_area%d%r_sp 721 CALL mp_file_write_at_all(thefile, bdata_offsets(mynode + 1), r_sp, msglen=data_area_size) 722 CASE (dbcsr_type_real_8) 723 r_dp => data_area%d%r_dp 724 CALL mp_file_write_at_all(thefile, bdata_offsets(mynode + 1), r_dp, msglen=data_area_size) 725 CASE (dbcsr_type_complex_4) 726 c_sp => data_area%d%c_sp 727 CALL mp_file_write_at_all(thefile, bdata_offsets(mynode + 1), c_sp, msglen=data_area_size) 728 CASE (dbcsr_type_complex_8) 729 c_dp => data_area%d%c_dp 730 CALL mp_file_write_at_all(thefile, bdata_offsets(mynode + 1), c_dp, msglen=data_area_size) 731 END SELECT 732 CALL mp_file_close(thefile) 733 734 DEALLOCATE (linfo_sizes, da_sizes) 735 DEALLOCATE (subh2_disps, subh2_offsets, subh3_disps, subh3_offsets) 736 DEALLOCATE (bdata_disps, bdata_offsets) 737 738 CALL timestop(handle) 739 740 CONTAINS 741 SUBROUTINE cumsum_l(arr, cumsum) 742 INTEGER(kind=file_offset), DIMENSION(:), & 743 INTENT(IN) :: arr 744 INTEGER(kind=file_offset), DIMENSION(SIZE(arr)), & 745 INTENT(OUT) :: cumsum 746 747 INTEGER :: i 748 749 cumsum(1) = arr(1) 750 DO i = 2, SIZE(arr) 751 cumsum(i) = cumsum(i - 1) + arr(i) 752 END DO 753 END SUBROUTINE cumsum_l 754 END SUBROUTINE dbcsr_binary_write 755 756 SUBROUTINE dbcsr_binary_read(filepath, distribution, groupid, matrix_new) 757 !! Reads a DBCSR matrix from a file 758 759 IMPLICIT NONE 760 761 CHARACTER(len=*), INTENT(IN) :: filepath 762 !! path to the file 763 TYPE(dbcsr_distribution_obj), INTENT(IN) :: distribution 764 !! row and column distribution 765 INTEGER, INTENT(IN), OPTIONAL :: groupid 766 !! message passing environment identifier 767 TYPE(dbcsr_type), INTENT(INOUT) :: matrix_new 768 !! DBCSR matrix 769 770 CHARACTER(LEN=*), PARAMETER :: routineN = 'dbcsr_binary_read', & 771 routineP = moduleN//':'//routineN 772 773 INTEGER :: nblkrows_total, nblkcols_total, & 774 nblks, darea_size, data_type, type_size, & 775 globalinfo_size, & 776 size_of_pgrid, & 777 thefile, i, j, & 778 nblocks, & 779 share_size, order, cur_blks, & 780 job_count, start_index, end_index, & 781 localinfo_length, blockdata_length, & 782 group_id, worker_id, group_list_size, handle, linfo_length 783 CHARACTER :: matrix_type 784 CHARACTER(LEN=default_string_length) :: matrix_name 785 INTEGER, PARAMETER :: version_len = 10 786 CHARACTER(LEN=version_len) :: version 787 CHARACTER(LEN=80) :: matrix_name_v_1_0 788 CHARACTER(LEN=version_len), PARAMETER :: version_v_1_0 = "DBCSRv_1.0" 789 790 INTEGER, DIMENSION(:), POINTER :: row_p, col_i, blk_p, & 791 proc_nblks, proc_darea_sizes 792 INTEGER, DIMENSION(4) :: values 793 INTEGER, ALLOCATABLE, DIMENSION(:) :: linfo_lens, bdata_lens 794 INTEGER, ALLOCATABLE, DIMENSION(:), TARGET :: ginfo_vec, linfo_vec, & 795 rowp, coli, blkp 796 INTEGER, ALLOCATABLE, DIMENSION(:, :), TARGET :: val_data 797 INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: row_blk_size, col_blk_size 798 TYPE(dbcsr_mp_obj) :: mp_env 799 TYPE(dbcsr_data_obj) :: dblk 800 REAL(sp) :: rsp_dummy(1) 801 REAL(dp) :: rdp_dummy(1) 802 COMPLEX(sp) :: csp_dummy(1) 803 COMPLEX(dp) :: cdp_dummy(1) 804 REAL(sp), ALLOCATABLE, DIMENSION(:), TARGET :: rsp 805 REAL(dp), ALLOCATABLE, DIMENSION(:), TARGET :: rdp 806 COMPLEX(sp), ALLOCATABLE, DIMENSION(:), TARGET :: csp 807 COMPLEX(dp), ALLOCATABLE, DIMENSION(:), TARGET :: cdp 808 INTEGER(kind=file_offset), ALLOCATABLE, DIMENSION(:) :: subh2_offsets, & 809 subh3_disps, subh3_offsets, & 810 bdata_disps, bdata_offsets 811 INTEGER(kind=file_offset), PARAMETER :: BOF = 0 812 INTEGER(kind=file_offset) :: offset, subh2_start, subh3_start, bdata_start, file_size, & 813 localinfo_offset, blockdata_offset, sum_nblks, subh3_length, data_area_size 814 INTEGER, PARAMETER :: char_count = 1 + version_len + default_string_length 815 816 CALL timeset(routineN, handle) 817 818 IF (PRESENT(groupid)) THEN 819 group_id = groupid 820 ELSE 821 mp_env = dbcsr_distribution_mp(distribution) 822 group_id = dbcsr_mp_group(mp_env) 823 END IF 824 825 CALL mp_environ(group_list_size, worker_id, group_id) 826 CALL mp_file_open(group_id, thefile, filepath, file_amode_rdonly) 827 828! read version, matrix name and matrix type 829 CALL mp_file_read_at_all(thefile, BOF, version) 830 831 IF (version /= version_v_1_0) & 832 DBCSR_WARN("Trying to read an unknown version of the matrix data file. Good luck!") 833 834 CALL mp_file_read_at_all(thefile, BOF + version_len*mpi_character_size, matrix_name_v_1_0) 835 matrix_name = matrix_name_v_1_0 836 837 CALL mp_file_read_at_all(thefile, BOF + (version_len + default_string_length)*mpi_character_size, matrix_type) 838! read 4 integer values form sub-header1 839 CALL mp_file_read_at_all(thefile, BOF + char_count*mpi_character_size, values) 840 size_of_pgrid = values(1) 841 data_type = values(2) 842 nblkrows_total = values(3) 843 nblkcols_total = values(4) 844! read 2 vectors, row_blk_size and col_blk_size, from sub-header1 845 globalinfo_size = nblkrows_total + nblkcols_total 846 ALLOCATE (ginfo_vec(globalinfo_size)) 847 CALL mp_file_read_at_all(thefile, BOF + char_count*mpi_character_size + 4*mpi_integer_size, ginfo_vec) 848 row_blk_size => ginfo_vec(1:nblkrows_total) 849 col_blk_size => ginfo_vec(nblkrows_total + 1:globalinfo_size) 850 851! compute the offsets where sub-header2 and sub-header3 start 852 subh2_start = (4 + globalinfo_size)*mpi_integer_size + char_count*mpi_character_size 853 subh3_start = subh2_start + 2*size_of_pgrid*mpi_integer_size 854 855! compute the offsets in sub-header2 and read 2 integers nblocks, data_area_size 856 ! number of data chunks from sub-header 2 and 3 to be read by every node rounded up 857 ! to the next integer to make it even for all the nodes in the specified mpi group 858 share_size = CEILING(REAL(size_of_pgrid, KIND=dp)/group_list_size) 859 860 ALLOCATE (subh2_offsets(share_size)) 861 subh2_offsets = BOF 862 DO i = 1, share_size 863 offset = subh2_start + mpi_integer_size*2*(worker_id + (i - 1)*group_list_size) 864 IF (offset .GE. subh3_start) EXIT 865 subh2_offsets(i) = offset 866 END DO 867 868 ALLOCATE (val_data(3, share_size)) 869 val_data(:, :) = 0 870 DO i = 1, share_size 871 CALL mp_file_read_at_all(thefile, subh2_offsets(i), values, msglen=2) 872 nblocks = values(1) 873 data_area_size = values(2) 874 IF (subh2_offsets(i) .EQ. 0) EXIT 875 val_data(1, i) = nblocks 876 IF (data_area_size >= HUGE(val_data(2, i))) & 877 DBCSR_ABORT("Data area too large, fix code.") 878 val_data(2, i) = INT(data_area_size) 879 val_data(3, i) = worker_id + (i - 1)*group_list_size + 1 ! order 880 ! order = indices of an array of length size_of_pgrid to be accessed by the current node 881 END DO 882 nblks = SUM(val_data(1, :)) 883 darea_size = SUM(val_data(2, :)) 884 proc_nblks => val_data(1, :) ! to be passed to dbcsr_datablock_redistribute 885 proc_darea_sizes => val_data(2, :) ! to be passed to dbcsr_datablock_redistribute 886 887! compute the offsets in sub-header3 and read 3 vectors row_p, col_i, blk_p 888 ! actual number of chunks to be read by the current node 889 job_count = COUNT(val_data(3, :) .NE. 0) 890 CALL mp_file_get_size(thefile, file_size) 891 892 ALLOCATE (linfo_lens(size_of_pgrid)) 893 ALLOCATE (subh3_disps(size_of_pgrid)) 894 ALLOCATE (subh3_offsets(size_of_pgrid)) 895 linfo_lens = 0; subh3_disps = 0 896 DO i = 1, size_of_pgrid 897 DO j = 1, share_size 898 order = val_data(3, j) 899 IF (i .EQ. order) linfo_lens(order) = & 900 1 + nblkrows_total + 2*val_data(1, j) 901 END DO 902 END DO 903 CALL mp_sum(linfo_lens, group_id) 904 CALL cumsum_l(INT(linfo_lens, kind=file_offset), subh3_disps) 905 subh3_disps(:) = CSHIFT(subh3_disps, shift=-1) 906 subh3_disps(1) = BOF 907 subh3_offsets(:) = subh3_start + subh3_disps*mpi_integer_size 908 909 sum_nblks = INT(nblks, kind=file_offset) 910 CALL mp_sum(sum_nblks, group_id) 911 subh3_length = size_of_pgrid*INT(1 + nblkrows_total, KIND=file_offset) + 2*sum_nblks 912 913 linfo_length = nblkrows_total + 1 + 2*MAXVAL(val_data(1, :)) 914 915 ALLOCATE (linfo_vec(linfo_length)) 916 ALLOCATE (rowp((nblkrows_total + 1)*job_count)) 917 ALLOCATE (coli(nblks)) 918 ALLOCATE (blkp(nblks)) 919 DO i = 1, share_size 920 order = val_data(3, i) 921 cur_blks = val_data(1, i) 922 IF (order .EQ. 0) THEN 923 localinfo_offset = file_size 924 localinfo_length = 0 925 ELSE 926 localinfo_offset = subh3_offsets(order) 927 localinfo_length = linfo_lens(order) 928 END IF 929 CALL mp_file_read_at_all(thefile, localinfo_offset, linfo_vec, msglen=localinfo_length) 930 IF (localinfo_length .EQ. 0) EXIT 931 932 rowp((i - 1)*(nblkrows_total + 1) + 1:i*(nblkrows_total + 1)) = linfo_vec(1:nblkrows_total + 1) 933 start_index = SUM(val_data(1, 1:i - 1)) + 1 934 end_index = SUM(val_data(1, 1:i)) 935 coli(start_index:end_index) = & 936 linfo_vec(nblkrows_total + 2:cur_blks + nblkrows_total + 1) 937 blkp(start_index:end_index) = & 938 linfo_vec(cur_blks + nblkrows_total + 2:2*cur_blks + nblkrows_total + 1) 939 END DO 940 row_p => rowp 941 col_i => coli 942 blk_p => blkp 943 944! compute the offsets and read block data 945 ALLOCATE (bdata_lens(size_of_pgrid)) 946 ALLOCATE (bdata_disps(size_of_pgrid)) 947 ALLOCATE (bdata_offsets(size_of_pgrid)) 948 bdata_lens = 0 949 DO i = 1, size_of_pgrid 950 DO j = 1, share_size 951 order = val_data(3, j) 952 IF (i .EQ. order) bdata_lens(order) = val_data(2, j) 953 END DO 954 END DO 955 CALL mp_sum(bdata_lens, group_id) 956 CALL cumsum_l(INT(bdata_lens, kind=file_offset), bdata_disps) 957 bdata_disps(:) = CSHIFT(bdata_disps, shift=-1) 958 bdata_disps(1) = BOF 959 960 bdata_start = subh3_start + subh3_length*mpi_integer_size 961 SELECT CASE (data_type) 962 CASE (dbcsr_type_real_4) 963 type_size = real_4_size 964 CASE (dbcsr_type_real_8) 965 type_size = real_8_size 966 CASE (dbcsr_type_complex_4) 967 type_size = 2*real_4_size 968 CASE (dbcsr_type_complex_8) 969 type_size = 2*real_8_size 970 END SELECT 971 bdata_offsets(:) = bdata_start + bdata_disps*type_size 972 973 SELECT CASE (data_type) 974 CASE (dbcsr_type_real_4) 975 ALLOCATE (rsp(darea_size)) 976 DO i = 1, share_size 977 order = val_data(3, i) 978 ! use dummy one-sized data array as buffer in place of empty array 979 ! when nothing is supposed to be read (order = 0) 980 IF (order .EQ. 0) THEN 981 blockdata_offset = file_size 982 CALL mp_file_read_at_all(thefile, blockdata_offset, rsp_dummy) 983 ELSE 984 start_index = SUM(val_data(2, 1:i - 1)) + 1 985 end_index = SUM(val_data(2, 1:i)) 986 blockdata_length = bdata_lens(order) 987 blockdata_offset = bdata_offsets(order) 988 CALL mp_file_read_at_all(thefile, blockdata_offset, rsp(start_index:end_index), & 989 msglen=blockdata_length) 990 END IF 991 END DO 992 CASE (dbcsr_type_real_8) 993 ALLOCATE (rdp(darea_size)) 994 DO i = 1, share_size 995 order = val_data(3, i) 996 IF (order .EQ. 0) THEN 997 blockdata_offset = file_size 998 CALL mp_file_read_at_all(thefile, blockdata_offset, rdp_dummy) 999 ELSE 1000 start_index = SUM(val_data(2, 1:i - 1)) + 1 1001 end_index = SUM(val_data(2, 1:i)) 1002 blockdata_length = bdata_lens(order) 1003 blockdata_offset = bdata_offsets(order) 1004 CALL mp_file_read_at_all(thefile, blockdata_offset, rdp(start_index:end_index), & 1005 msglen=blockdata_length) 1006 END IF 1007 END DO 1008 CASE (dbcsr_type_complex_4) 1009 ALLOCATE (csp(darea_size)) 1010 DO i = 1, share_size 1011 order = val_data(3, i) 1012 IF (order .EQ. 0) THEN 1013 blockdata_offset = file_size 1014 CALL mp_file_read_at_all(thefile, blockdata_offset, csp_dummy) 1015 ELSE 1016 start_index = SUM(val_data(2, 1:i - 1)) + 1 1017 end_index = SUM(val_data(2, 1:i)) 1018 blockdata_length = bdata_lens(order) 1019 blockdata_offset = bdata_offsets(order) 1020 CALL mp_file_read_at_all(thefile, blockdata_offset, csp(start_index:end_index), & 1021 msglen=blockdata_length) 1022 END IF 1023 END DO 1024 CASE (dbcsr_type_complex_8) 1025 ALLOCATE (cdp(darea_size)) 1026 DO i = 1, share_size 1027 order = val_data(3, i) 1028 IF (order .EQ. 0) THEN 1029 blockdata_offset = file_size 1030 CALL mp_file_read_at_all(thefile, blockdata_offset, cdp_dummy) 1031 ELSE 1032 start_index = SUM(val_data(2, 1:i - 1)) + 1 1033 end_index = SUM(val_data(2, 1:i)) 1034 blockdata_length = bdata_lens(order) 1035 blockdata_offset = bdata_offsets(order) 1036 CALL mp_file_read_at_all(thefile, blockdata_offset, cdp(start_index:end_index), & 1037 msglen=blockdata_length) 1038 END IF 1039 END DO 1040 END SELECT 1041 CALL dbcsr_data_init(dblk) 1042 CALL dbcsr_data_new(dblk, data_type) 1043 IF (ALLOCATED(rdp)) dblk%d%r_dp => rdp 1044 IF (ALLOCATED(rsp)) dblk%d%r_sp => rsp 1045 IF (ALLOCATED(cdp)) dblk%d%c_dp => cdp 1046 IF (ALLOCATED(csp)) dblk%d%c_sp => csp 1047 1048 CALL mp_file_close(thefile) 1049 1050 CALL dbcsr_create(matrix_new, matrix_name, distribution, matrix_type, & 1051 row_blk_size, col_blk_size, nze=darea_size, & 1052 data_type=data_type) 1053 CALL dbcsr_datablock_redistribute(dblk, row_p, col_i, blk_p, proc_nblks, proc_darea_sizes, matrix_new) 1054 1055 DEALLOCATE (subh2_offsets, subh3_offsets, bdata_offsets) 1056 DEALLOCATE (subh3_disps, bdata_disps) 1057 DEALLOCATE (linfo_lens, bdata_lens) 1058 DEALLOCATE (val_data, ginfo_vec, linfo_vec) 1059 DEALLOCATE (rowp, coli, blkp) 1060 IF (ALLOCATED(rdp)) DEALLOCATE (rdp) 1061 IF (ALLOCATED(rsp)) DEALLOCATE (rsp) 1062 IF (ALLOCATED(cdp)) DEALLOCATE (cdp) 1063 IF (ALLOCATED(csp)) DEALLOCATE (csp) 1064 CALL dbcsr_data_clear_pointer(dblk) 1065 DEALLOCATE (dblk%d) 1066 1067 CALL timestop(handle) 1068 CONTAINS 1069 SUBROUTINE cumsum_l(arr, cumsum) 1070 INTEGER(kind=file_offset), DIMENSION(:), & 1071 INTENT(IN) :: arr 1072 INTEGER(kind=file_offset), DIMENSION(SIZE(arr)), & 1073 INTENT(OUT) :: cumsum 1074 1075 INTEGER :: i 1076 1077 cumsum(1) = arr(1) 1078 DO i = 2, SIZE(arr) 1079 cumsum(i) = cumsum(i - 1) + arr(i) 1080 END DO 1081 END SUBROUTINE cumsum_l 1082 1083 END SUBROUTINE dbcsr_binary_read 1084 1085 SUBROUTINE dbcsr_print_block_sum(matrix, unit_nr) 1086 !! Prints the sum of the elements for each block 1087 1088 TYPE(dbcsr_type), INTENT(IN) :: matrix 1089 !! matrix 1090 INTEGER, INTENT(IN), OPTIONAL :: unit_nr 1091 1092 CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_print_block_sum', & 1093 routineP = moduleN//':'//routineN 1094 1095 COMPLEX(KIND=real_4) :: blk_sum_c_sp 1096 COMPLEX(KIND=real_4), DIMENSION(:), POINTER :: c_sp 1097 COMPLEX(KIND=real_8) :: blk_sum_c_dp 1098 COMPLEX(KIND=real_8), DIMENSION(:), POINTER :: c_dp 1099 INTEGER :: bc, blk, blk_p, br, handle, iunit, m, & 1100 mn, n 1101 INTEGER, DIMENSION(:), POINTER :: col_blk_offset, col_blk_size, & 1102 row_blk_offset, row_blk_size 1103 REAL(KIND=real_4) :: blk_sum_r_sp 1104 REAL(KIND=real_4), DIMENSION(:), POINTER :: r_sp 1105 REAL(KIND=real_8) :: blk_sum_r_dp 1106 REAL(KIND=real_8), DIMENSION(:), POINTER :: r_dp 1107 1108! --------------------------------------------------------------------------- 1109 1110 CALL timeset(routineN, handle) 1111 IF (.NOT. dbcsr_valid_index(matrix)) & 1112 DBCSR_WARN("Can not print invalid matrix.") 1113 1114 iunit = default_output_unit 1115 IF (PRESENT(unit_nr)) iunit = unit_nr 1116 1117 IF (iunit > 0) THEN 1118 1119 SELECT CASE (matrix%data_type) 1120 CASE (dbcsr_type_real_8) 1121 CALL dbcsr_get_data(matrix%data_area, r_dp) 1122 CASE (dbcsr_type_real_4) 1123 CALL dbcsr_get_data(matrix%data_area, r_sp) 1124 CASE (dbcsr_type_complex_8) 1125 CALL dbcsr_get_data(matrix%data_area, c_dp) 1126 CASE (dbcsr_type_complex_4) 1127 CALL dbcsr_get_data(matrix%data_area, c_sp) 1128 END SELECT 1129 row_blk_size => array_data(matrix%row_blk_size) 1130 col_blk_size => array_data(matrix%col_blk_size) 1131 row_blk_offset => array_data(matrix%row_blk_offset) 1132 col_blk_offset => array_data(matrix%col_blk_offset) 1133 1134 IF (matrix%nblks .GT. 0) THEN 1135 DO br = 1, matrix%nblkrows_total 1136 m = row_blk_size(br) 1137 DO blk = matrix%row_p(br) + 1, matrix%row_p(br + 1) 1138 bc = matrix%col_i(blk) 1139 n = col_blk_size(bc) 1140 mn = m*n 1141 blk_p = ABS(matrix%blk_p(blk)) 1142 block_exists: IF (blk_p .NE. 0) THEN 1143 IF (mn .GT. 0) THEN 1144 SELECT CASE (matrix%data_type) 1145 CASE (dbcsr_type_real_8) 1146 blk_sum_r_dp = SUM(r_dp(blk_p:blk_p + mn - 1)) 1147 WRITE (iunit, '(I6,I6,ES18.9)') & 1148 br, bc, blk_sum_r_dp 1149 CASE (dbcsr_type_real_4) 1150 blk_sum_r_sp = SUM(r_sp(blk_p:blk_p + mn - 1)) 1151 WRITE (iunit, '(I6,I6,ES18.9)') & 1152 br, bc, blk_sum_r_sp 1153 CASE (dbcsr_type_complex_8) 1154 blk_sum_c_dp = SUM(c_dp(blk_p:blk_p + mn - 1)) 1155 WRITE (iunit, '(I6,I6,ES18.9," I*",ES18.9)') & 1156 br, bc, REAL(blk_sum_c_dp), AIMAG(blk_sum_c_dp) 1157 CASE (dbcsr_type_complex_4) 1158 blk_sum_c_sp = SUM(c_sp(blk_p:blk_p + mn - 1)) 1159 WRITE (iunit, '(I6,I6,ES18.9," I*",ES18.9)') & 1160 br, bc, REAL(blk_sum_c_sp), AIMAG(blk_sum_c_sp) 1161 END SELECT 1162 ELSE 1163 blk_sum_r_dp = 0.0_dp 1164 WRITE (iunit, '(I6,I6,ES18.9)') & 1165 br, bc, blk_sum_r_dp 1166 ENDIF 1167 ENDIF block_exists 1168 ENDDO 1169 ENDDO 1170 ENDIF 1171 1172 ENDIF ! unit > 0 1173 1174 CALL timestop(handle) 1175 1176 END SUBROUTINE dbcsr_print_block_sum 1177 1178END MODULE dbcsr_io 1179