Verify the correctness of a BCSR matrix.
| Type | Intent | Optional | Attributes | Name | ||
|---|---|---|---|---|---|---|
| type(dbcsr_type), | intent(in) | :: | m |
bcsr matrix |
||
| integer, | intent(in), | optional | :: | verbosity |
how detailed errors are; 0=nothing; 1=summary at end if matrix not consistent; 2=also individual errors; 3=always print info about matrix; >3=even more info |
|
| logical, | intent(in), | optional | :: | local |
no global communication |
SUBROUTINE dbcsr_verify_matrix(m, verbosity, local) !! Verify the correctness of a BCSR matrix. TYPE(dbcsr_type), INTENT(IN) :: m !! bcsr matrix INTEGER, INTENT(IN), OPTIONAL :: verbosity !! how detailed errors are; 0=nothing; 1=summary at end if matrix not consistent; 2=also individual errors; 3=always print !! info about matrix; >3=even more info LOGICAL, INTENT(IN), OPTIONAL :: local !! no global communication CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_verify_matrix', r = moduleN//':'//routineN INTEGER :: bc, blk, blk_p, br, & data_size_referenced, dbg, handle, i, & mb, mn, n, n_have_blocks_local, & n_have_blocks_total, prev_br INTEGER(KIND=int_8) :: n_full_blocks_total INTEGER, DIMENSION(:), POINTER :: col_blk_size, row_blk_size LOGICAL :: nocomm REAL(KIND=dp) :: sparsity_total ! --------------------------------------------------------------------------- CALL timeset(routineN, handle) dbg = 2 nocomm = .FALSE. IF (PRESENT(local)) nocomm = local IF (PRESENT(verbosity)) dbg = verbosity IF (dbg .GE. 3) WRITE (*, '(1X,A,A,A,3(L1))') r//'Matrix name: ', m%name, & " of types ", m%symmetry, m%negate_real, & m%negate_imaginary IF (dbg .GE. 3) THEN WRITE (*, '(1X,A,I5,"x",I5,A,I5,"x",I5)') r//' Size blocked', & m%nblkrows_total, m%nblkcols_total, ", full ", & m%nfullrows_total, m%nfullcols_total END IF row_blk_size => array_data(m%row_blk_size) col_blk_size => array_data(m%col_blk_size) ! IF (.NOT. dbcsr_has_symmetry(m)) THEN n_full_blocks_total = INT(m%nblkrows_total, KIND=int_8)*INT(m%nblkcols_total, KIND=int_8) ELSE IF (m%nblkrows_total /= m%nblkcols_total) & DBCSR_ABORT('Symmetric matrix is not square') n_full_blocks_total = INT(m%nblkrows_total, KIND=int_8)*(m%nblkrows_total + 1)/2 END IF n_have_blocks_local = m%nblks 2045 FORMAT(I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, I5) 2047 FORMAT(I7, 1X, I7, 1X, I7, 1X, I7, 1X, I7, 1X, I7, 1X, I7, 1X, I7, 1X, I7, 1X, I7) IF (dbg .GE. 4) THEN WRITE (*, '(1X,A)') r//' index=' WRITE (*, 2045) m%index(:dbcsr_num_slots) END IF IF (m%index(1) .LE. 0) & DBCSR_ABORT('Index size 0') DO i = dbcsr_slot_row_p, dbcsr_num_slots !IF(m%index(i) .LE. 0) & ! DBCSR_ABORT('Index member is 0') IF (.NOT. (i .EQ. dbcsr_slot_col_i .OR. i .EQ. dbcsr_slot_blk_p)) THEN IF (m%index(i) > m%index(1)) & DBCSR_ABORT('Index member is greater than size') END IF END DO ! IF (dbg .GE. 4) WRITE (*, *) r//' row_p extents', m%index(dbcsr_slot_row_p + 1), & m%index(dbcsr_slot_row_p), SIZE(m%row_p) IF (m%index(dbcsr_slot_row_p + 1) - m%index(dbcsr_slot_row_p) + 1 /= m%nblkrows_total + 1) & DBCSR_ABORT('Size of row_p index inconsistent with number of rows') IF (SIZE(m%row_p) /= m%nblkrows_total + 1) & DBCSR_ABORT('Size of row_p inconsistent with number of rows') ! IF (dbg .GE. 4) WRITE (*, *) r//' col_i extents', m%index(dbcsr_slot_col_i + 1), & m%index(dbcsr_slot_col_i), SIZE(m%col_i) IF (m%index(dbcsr_slot_col_i + 1) - m%index(dbcsr_slot_col_i) + 1 /= m%nblks) & DBCSR_ABORT('Size of col_i index inconsistent with number of blocks') IF (SIZE(m%col_i) /= m%nblks) & DBCSR_ABORT('Size of col inconsistent with number of blocks') ! IF (dbg .GE. 4) WRITE (*, *) r//' blk_p extents', m%index(dbcsr_slot_blk_p + 1), & m%index(dbcsr_slot_blk_p), SIZE(m%blk_p) IF (m%index(dbcsr_slot_blk_p + 1) - m%index(dbcsr_slot_blk_p) + 1 /= m%nblks) & DBCSR_ABORT('Size of blk_p index inconsistent with number of blocks') IF (SIZE(m%col_i) /= m%nblks) & DBCSR_ABORT('Size of blk_p inconsistent with number of blocks') ! IF (SIZE(row_blk_size) /= m%nblkrows_total) & DBCSR_ABORT('Row block size array inconsistent with number of blocked rows') IF (SIZE(col_blk_size) /= m%nblkcols_total) & DBCSR_ABORT('Column block size array inconsistent with number of blocked columns') ! IF (dbg .GE. 4) THEN WRITE (*, '(1X,A,I7,A,I7)') r//' nze=', m%nze, 'data size', & dbcsr_data_get_size(m%data_area) END IF data_size_referenced = dbcsr_data_get_size_referenced(m%data_area) !This tends to be too verbose and usually untrue for symmetric !matrices. !IF(dbcsr_get_data_size(m%data_area) < m%nze) & ! DBCSR_ABORT('Data storage may be too small.') IF (dbg .GE. 5) THEN WRITE (*, '(1X,A,I7,A)') r//' size=', SIZE(m%row_p), ' row_p=' WRITE (*, 2047) m%row_p(1:m%nblkrows_total + 1) WRITE (*, '(1X,A)') r//' col_i=' WRITE (*, 2047) m%col_i(1:m%nblks) WRITE (*, '(1X,A)') r//' blk_p=' WRITE (*, 2047) m%blk_p(1:m%nblks) END IF prev_br = 0 DO br = 1, m%nblkrows_total IF (m%row_p(br) < 0) DBCSR_ABORT('row_p less than zero') IF (br .GT. 1) THEN IF (m%row_p(br) < m%row_p(prev_br)) DBCSR_ABORT('row_p decreases') END IF mb = row_blk_size(br) IF (mb < 0) & DBCSR_ABORT('Row blocked size is negative') DO blk = m%row_p(br) + 1, m%row_p(br + 1) IF (blk < 0) DBCSR_ABORT('Block number is zero') IF (blk > m%nblks) DBCSR_ABORT('Block number too high') bc = m%col_i(blk) IF (dbg .GE. 5) THEN WRITE (*, '(1X,A,I7,"(",I5,",",I5,")")') r//' block', blk, br, bc END IF IF (bc .LE. 0) DBCSR_ABORT('col_i is zero') IF (bc > m%nblkcols_total) DBCSR_ABORT('col_i too high') n = col_blk_size(bc) IF (n < 0) DBCSR_ABORT('Column blocked size is negative') blk_p = m%blk_p(blk) mn = mb*n !IF(blk_p.LE.0) DBCSR_ABORT('Block pointer is negative') !IF(blk_p > m%nze) & ! DBCSR_ABORT('Block pointer too large') !IF(blk_p+mn-1 > m%nze) & ! DBCSR_ABORT('Block extends too far') IF (mn .GT. 0 .AND. ABS(blk_p) > data_size_referenced) & DBCSR_ABORT("Block pointer pointso outside of declared referenced area") IF (ABS(blk_p) + mn - 1 > data_size_referenced) & DBCSR_ABORT("Block extends outside of declared referenced area") END DO prev_br = br END DO IF (dbg .GE. 3 .AND. .NOT. nocomm) THEN CALL mp_sum(n_have_blocks_local, dbcsr_mp_group(dbcsr_distribution_mp( & m%dist))) n_have_blocks_total = n_have_blocks_local sparsity_total = REAL(n_have_blocks_total, KIND=dp) & /REAL(n_full_blocks_total, KIND=dp)*100.0_dp !WRITE(*,FMT='(30A,F5.1,A)')r//' Sparsity: ', sparsity_total,'%' WRITE (*, FMT='(1X,A,F5.1,A)') r//' Non-sparsity: ', & sparsity_total, '%' END IF CALL timestop(handle) END SUBROUTINE dbcsr_verify_matrix