Prints a BCSR matrix (block-style, not full)
| Type | Intent | Optional | Attributes | Name | ||
|---|---|---|---|---|---|---|
| type(dbcsr_type), | intent(in) | :: | matrix |
matrix |
||
| logical, | intent(in), | optional | :: | nodata |
don't print actual data |
|
| logical, | intent(in), | optional | :: | matlab_format |
don't print actual data |
|
| character(len=*), | intent(in), | optional | :: | variable_name | ||
| integer, | intent(in), | optional | :: | unit_nr |
SUBROUTINE dbcsr_print(matrix, nodata, matlab_format, variable_name, unit_nr)
!! Prints a BCSR matrix (block-style, not full)
TYPE(dbcsr_type), INTENT(IN) :: matrix
!! matrix
LOGICAL, INTENT(IN), OPTIONAL :: nodata, matlab_format
!! don't print actual data
CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: variable_name
INTEGER, INTENT(IN), OPTIONAL :: unit_nr
CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_print', routineP = moduleN//':'//routineN
COMPLEX(KIND=real_4), DIMENSION(:), POINTER :: c_sp
COMPLEX(KIND=real_8), DIMENSION(:), POINTER :: c_dp
INTEGER :: ablk_p, bc, blk, blk_p, br, ebr, fblk, &
handle, ibr, iunit, lblk, m, mn, n, &
sblk
INTEGER, DIMENSION(:), POINTER :: col_blk_offset, col_blk_size, &
local_cols, local_rows, &
row_blk_offset, row_blk_size
LOGICAL :: my_matlab_format, tr, yesprint
REAL(KIND=dp) :: blk_cs
REAL(KIND=real_4), DIMENSION(:), POINTER :: r_sp
REAL(KIND=real_8), DIMENSION(:), POINTER :: r_dp
! ---------------------------------------------------------------------------
CALL timeset(routineN, handle)
IF (.NOT. dbcsr_valid_index(matrix)) &
DBCSR_WARN("Can not print invalid matrix.")
iunit = default_output_unit
IF (PRESENT(unit_nr)) iunit = unit_nr
my_matlab_format = .FALSE.
IF (PRESENT(matlab_format)) my_matlab_format = matlab_format
yesprint = .TRUE.
IF (PRESENT(nodata)) yesprint = .NOT. nodata
WRITE (iunit, *) routineP//' Contents of matrix named ', matrix%name
WRITE (iunit, *) routineP//' Flags ', matrix%symmetry, &
matrix%negate_real, matrix%negate_imaginary, "type", &
dbcsr_get_data_type(matrix), "serial", matrix%serial_number
WRITE (iunit, '(1X,A,3(1X,I9,1X,A))') routineP, matrix%nblks, "blocks", &
matrix%nze, "nzes,", dbcsr_get_data_size(matrix), "data els", &
dbcsr_data_get_size_referenced(matrix%data_area), "used"
WRITE (iunit, '(1X,A,I5,A,I5)') routineP//" Full size", &
matrix%nfullrows_total, "x", matrix%nfullcols_total
WRITE (iunit, '(1X,A,I5,A,I5)') routineP//" Blocked size", &
matrix%nblkrows_total, "x", matrix%nblkcols_total
SELECT CASE (matrix%data_type)
CASE (dbcsr_type_real_8)
CALL dbcsr_get_data(matrix%data_area, r_dp)
CASE (dbcsr_type_real_4)
CALL dbcsr_get_data(matrix%data_area, r_sp)
CASE (dbcsr_type_complex_8)
CALL dbcsr_get_data(matrix%data_area, c_dp)
CASE (dbcsr_type_complex_4)
CALL dbcsr_get_data(matrix%data_area, c_sp)
END SELECT
row_blk_size => array_data(matrix%row_blk_size)
col_blk_size => array_data(matrix%col_blk_size)
row_blk_offset => array_data(matrix%row_blk_offset)
col_blk_offset => array_data(matrix%col_blk_offset)
IF (matrix%nblks .GT. 0) THEN
IF (matrix%list_indexing) THEN
IF (SIZE(matrix%coo_l) .NE. 3*matrix%nblks) &
DBCSR_ABORT("Wrong list")
ebr = 1
sblk = 3
ELSE
ebr = matrix%nblkrows_total
sblk = 1
END IF
DO ibr = 1, ebr
IF (matrix%list_indexing) THEN
fblk = 1
lblk = SIZE(matrix%coo_l)
ELSE
br = ibr
fblk = matrix%row_p(br) + 1
lblk = matrix%row_p(br + 1)
m = row_blk_size(br)
END IF
DO blk = fblk, lblk, sblk
IF (matrix%list_indexing) THEN
br = matrix%coo_l(blk)
bc = matrix%coo_l(blk + 1)
IF (matrix%local_indexing) THEN
local_rows => array_data(matrix%local_rows)
local_cols => array_data(matrix%local_cols)
br = local_rows(br)
bc = local_cols(bc)
END IF
m = row_blk_size(br)
ablk_p = matrix%coo_l(blk + 2)
ELSE
bc = matrix%col_i(blk)
ablk_p = matrix%blk_p(blk)
END IF
n = col_blk_size(bc)
mn = m*n
blk_p = ABS(ablk_p)
tr = ablk_p .LT. 0
block_exists: IF (blk_p .NE. 0) THEN
IF (mn .GT. 0) THEN
SELECT CASE (matrix%data_type)
CASE (dbcsr_type_real_8)
blk_cs = REAL(DOT_PRODUCT(r_dp(blk_p:blk_p + mn - 1), &
r_dp(blk_p:blk_p + mn - 1)), KIND=dp)
!CALL &
! dbcsr_printmat(r_dp(blk_p:blk_p+mn-1),m,n, tr=tr)
CASE (dbcsr_type_real_4)
blk_cs = REAL(DOT_PRODUCT(r_sp(blk_p:blk_p + mn - 1), &
r_sp(blk_p:blk_p + mn - 1)), KIND=dp)
!CALL &
! dbcsr_printmat(r_sp(blk_p:blk_p+mn-1),m,n, tr=tr)
CASE (dbcsr_type_complex_8)
blk_cs = REAL(DOT_PRODUCT(c_dp(blk_p:blk_p + mn - 1), &
c_dp(blk_p:blk_p + mn - 1)), KIND=dp)
!CALL &
! dbcsr_printmat(c_dp(blk_p:blk_p+mn-1),m,n, tr=tr)
CASE (dbcsr_type_complex_4)
blk_cs = REAL(DOT_PRODUCT(c_sp(blk_p:blk_p + mn - 1), &
c_sp(blk_p:blk_p + mn - 1)), KIND=dp)
!CALL &
! dbcsr_printmat(c_sp(blk_p:blk_p+mn-1),m,n, tr=tr)
END SELECT
ELSE
blk_cs = 0.0_dp
END IF
!WRITE(iunit,*)routineP//' chksum for (',br,',',bc,') at',&
! blk_p,'l',mn,'= ', blk_cs,'size',m,n
IF (.NOT. my_matlab_format) WRITE (iunit, '(A,I6,",",I6,A,I7,A,I6,I6,"=",I7,A,E12.3)') &
!" Checksum for (",br,bc,") at ",blk_p," size ",m,n,mn,&
" Checksum for (", br, bc, ") at ", ablk_p, " size ", m, n, mn, &
" checksum=", blk_cs
IF (yesprint .AND. blk_p .NE. 0) THEN
IF (mn .GT. 0) THEN
SELECT CASE (matrix%data_type)
CASE (dbcsr_type_real_8)
!WRITE(iunit,'(10(1X,F7.2))')r_dp(blk_p:blk_p+mn-1)
IF (my_matlab_format) THEN
CALL dbcsr_printmat_matlab_d(r_dp(blk_p:blk_p + mn - 1), m, n, &
row_blk_offset(br), col_blk_offset(bc), iunit, tr=tr, &
variable_name=variable_name)
ELSE
CALL dbcsr_printmat(r_dp(blk_p:blk_p + mn - 1), m, n, iunit=iunit, tr=tr)
END IF
CASE (dbcsr_type_real_4)
IF (my_matlab_format) THEN
CALL dbcsr_printmat_matlab_s(r_sp(blk_p:blk_p + mn - 1), m, n, &
row_blk_offset(br), col_blk_offset(bc), iunit, tr=tr, &
variable_name=variable_name)
ELSE
CALL dbcsr_printmat(r_sp(blk_p:blk_p + mn - 1), m, n, iunit=iunit, tr=tr)
END IF
CASE (dbcsr_type_complex_8)
IF (my_matlab_format) THEN
CALL dbcsr_printmat_matlab_z(c_dp(blk_p:blk_p + mn - 1), m, n, &
row_blk_offset(br), col_blk_offset(bc), iunit, tr=tr, &
variable_name=variable_name)
ELSE
CALL dbcsr_printmat(c_dp(blk_p:blk_p + mn - 1), m, n, iunit=iunit, tr=tr)
END IF
CASE (dbcsr_type_complex_4)
IF (my_matlab_format) THEN
CALL dbcsr_printmat_matlab_c(c_sp(blk_p:blk_p + mn - 1), m, n, &
row_blk_offset(br), col_blk_offset(bc), iunit, tr=tr, &
variable_name=variable_name)
ELSE
CALL dbcsr_printmat(c_sp(blk_p:blk_p + mn - 1), m, n, iunit=iunit, tr=tr)
END IF
END SELECT
END IF
END IF
END IF block_exists
END DO
END DO
END IF
CALL timestop(handle)
END SUBROUTINE dbcsr_print