Creates a matrix, allocating the essentials.
The matrix itself is allocated, as well as the essential parts of the index. When passed the nze argument, the data is also allocated to that size. see dbcsr_types.F
| Type | Intent | Optional | Attributes | Name | ||
|---|---|---|---|---|---|---|
| type(dbcsr_type), | intent(inout) | :: | matrix |
new matrix |
||
| character(len=*), | intent(in) | :: | name | |||
| type(dbcsr_distribution_obj), | intent(in) | :: | dist |
distribution_2d distribution |
||
| character, | intent(in) | :: | matrix_type |
'N' for normal, 'T' for transposed, 'S' for symmetric, and 'A' for antisymmetric |
||
| integer, | intent(inout), | optional, | DIMENSION(:), POINTER, CONTIGUOUS | :: | row_blk_size | |
| integer, | intent(inout), | optional, | DIMENSION(:), POINTER, CONTIGUOUS | :: | col_blk_size | |
| type(array_i1d_obj), | intent(in), | optional | :: | row_blk_size_obj | ||
| type(array_i1d_obj), | intent(in), | optional | :: | col_blk_size_obj | ||
| integer, | intent(in), | optional | :: | nze |
number of elements type of data from 'rRcC' for single/double precision real/complex, default is 'R' |
|
| integer, | intent(in), | optional | :: | data_type |
number of elements type of data from 'rRcC' for single/double precision real/complex, default is 'R' |
|
| type(dbcsr_data_obj), | intent(in), | optional | :: | data_buffer | ||
| type(dbcsr_memtype_type), | intent(in), | optional | :: | data_memory_type |
allocate indices and data using special memory allocate indices using special memory |
|
| type(dbcsr_memtype_type), | intent(in), | optional | :: | index_memory_type |
allocate indices and data using special memory allocate indices using special memory |
|
| integer, | intent(in), | optional | :: | max_rbs | ||
| integer, | intent(in), | optional | :: | max_cbs | ||
| type(array_i1d_obj), | intent(in), | optional | :: | row_blk_offset | ||
| type(array_i1d_obj), | intent(in), | optional | :: | col_blk_offset | ||
| type(dbcsr_distribution_obj), | intent(in), | optional | :: | thread_dist | ||
| logical, | intent(in), | optional | :: | reuse |
reuses an existing matrix, default is to create a fresh one uses the mutable data for working and not the append-only data; default is append-only |
|
| logical, | intent(in), | optional | :: | reuse_arrays |
reuses an existing matrix, default is to create a fresh one uses the mutable data for working and not the append-only data; default is append-only |
|
| logical, | intent(in), | optional | :: | mutable_work |
reuses an existing matrix, default is to create a fresh one uses the mutable data for working and not the append-only data; default is append-only |
|
| logical, | intent(in), | optional | :: | make_index |
reuses an existing matrix, default is to create a fresh one uses the mutable data for working and not the append-only data; default is append-only |
|
| character, | intent(in), | optional | :: | replication_type |
replication to be used for this matrix; default is dbcsr_repl_none |
SUBROUTINE dbcsr_create_new(matrix, name, dist, matrix_type, &
row_blk_size, col_blk_size, row_blk_size_obj, col_blk_size_obj, &
nze, data_type, data_buffer, &
data_memory_type, index_memory_type, &
max_rbs, max_cbs, &
row_blk_offset, col_blk_offset, &
thread_dist, &
reuse, reuse_arrays, mutable_work, make_index, replication_type)
!! Creates a matrix, allocating the essentials.
!!
!! The matrix itself is allocated, as well as the essential parts of
!! the index. When passed the nze argument, the data is also allocated
!! to that size.
!! see dbcsr_types.F
TYPE(dbcsr_type), INTENT(INOUT) :: matrix
!! new matrix
CHARACTER(len=*), INTENT(IN) :: name
TYPE(dbcsr_distribution_obj), INTENT(IN) :: dist
!! distribution_2d distribution
CHARACTER, INTENT(IN) :: matrix_type
!! 'N' for normal, 'T' for transposed, 'S' for symmetric, and 'A' for antisymmetric
INTEGER, DIMENSION(:), INTENT(INOUT), POINTER, &
CONTIGUOUS, OPTIONAL :: row_blk_size, col_blk_size
TYPE(array_i1d_obj), INTENT(IN), OPTIONAL :: row_blk_size_obj, col_blk_size_obj
INTEGER, INTENT(IN), OPTIONAL :: nze, data_type
!! number of elements
!! type of data from 'rRcC' for single/double precision real/complex, default is 'R'
TYPE(dbcsr_data_obj), INTENT(IN), OPTIONAL :: data_buffer
TYPE(dbcsr_memtype_type), INTENT(IN), OPTIONAL :: data_memory_type, index_memory_type
!! allocate indices and data using special memory
!! allocate indices using special memory
INTEGER, INTENT(IN), OPTIONAL :: max_rbs, max_cbs
TYPE(array_i1d_obj), INTENT(IN), OPTIONAL :: row_blk_offset, col_blk_offset
TYPE(dbcsr_distribution_obj), INTENT(IN), OPTIONAL :: thread_dist
LOGICAL, INTENT(IN), OPTIONAL :: reuse, reuse_arrays, mutable_work, &
make_index
!! reuses an existing matrix, default is to create a fresh one
!! uses the mutable data for working and not the append-only data; default is append-only
CHARACTER, INTENT(IN), OPTIONAL :: replication_type
!! replication to be used for this matrix; default is dbcsr_repl_none
CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_create_new'
CHARACTER :: matrix_type_l
INTEGER :: handle, my_nze
INTEGER, DIMENSION(:), POINTER, CONTIGUOUS :: vec_col_blk_offset, vec_row_blk_offset
INTEGER, DIMENSION(dbcsr_meta_size) :: new_meta
LOGICAL :: hijack, my_make_index
! ---------------------------------------------------------------------------
MARK_USED(thread_dist) ! only used with OMP
CALL timeset(routineN, handle)
! Reuse matrix only if has actually been allocated.
hijack = ASSOCIATED(matrix%index)
IF (PRESENT(reuse)) hijack = reuse
my_make_index = .TRUE.
IF (PRESENT(make_index)) my_make_index = make_index
IF (.NOT. hijack) THEN
matrix = dbcsr_type()
matrix%refcount = 1
END IF
!$OMP CRITICAL (crit_counter)
matrix%serial_number = dbcsr_matrix_counter
dbcsr_matrix_counter = dbcsr_matrix_counter + 1
!$OMP END CRITICAL (crit_counter)
! Mark matrix index as having an invalid index.
matrix%valid = .FALSE.
matrix%name = name
! Sets the type of matrix building/modifying work structures.
IF (PRESENT(mutable_work)) THEN
matrix%work_mutable = mutable_work
ELSE
matrix%work_mutable = .FALSE.
END IF
! Sets the correct data type.
IF (PRESENT(data_type)) THEN
SELECT CASE (data_type)
CASE (dbcsr_type_real_4)
matrix%data_type = dbcsr_type_real_4
CASE (dbcsr_type_real_8)
matrix%data_type = dbcsr_type_real_8
CASE (dbcsr_type_complex_4)
matrix%data_type = dbcsr_type_complex_4
CASE (dbcsr_type_complex_8)
matrix%data_type = dbcsr_type_complex_8
CASE DEFAULT
DBCSR_ABORT("Invalid matrix type")
END SELECT
ELSE
matrix%data_type = dbcsr_type_real_default
END IF
matrix%data_memory_type = dbcsr_memtype_default
IF (PRESENT(data_memory_type)) &
matrix%data_memory_type = data_memory_type
matrix%index_memory_type = dbcsr_memtype_default
IF (PRESENT(index_memory_type)) &
matrix%index_memory_type = index_memory_type
IF (hijack) THEN
! Release/deallocate elements that are replaced or not needed
! by the new matrix. This is similar to what dbcsr_destroy
! does, except that it keeps the index and data.
CALL array_release(matrix%row_blk_size)
CALL array_release(matrix%col_blk_size)
CALL array_release(matrix%row_blk_offset)
CALL array_release(matrix%col_blk_offset)
IF (matrix%has_local_rows) &
CALL array_release(matrix%local_rows)
IF (matrix%has_global_rows) &
CALL array_release(matrix%global_rows)
IF (matrix%has_local_cols) &
CALL array_release(matrix%local_cols)
IF (matrix%has_global_cols) &
CALL array_release(matrix%global_cols)
CALL dbcsr_distribution_release(matrix%dist)
IF (ASSOCIATED(matrix%wms)) THEN
CALL dbcsr_work_destroy_all(matrix)
END IF
CALL array_nullify(matrix%local_rows)
CALL array_nullify(matrix%global_rows)
CALL array_nullify(matrix%local_cols)
CALL array_nullify(matrix%global_cols)
!
IF (matrix%data_type /= matrix%data_area%d%data_type) &
DBCSR_ABORT("Inconsistent data type for the existing buffer.")
CALL dbcsr_data_set_size_referenced(matrix%data_area, 0)
ELSE
! Invalidate index
NULLIFY (matrix%index)
! Invalidate data
IF (PRESENT(data_buffer)) THEN
IF (.NOT. dbcsr_data_valid(data_buffer)) &
DBCSR_ABORT("Input data buffer not valid.")
IF (matrix%data_type /= data_buffer%d%data_type) &
DBCSR_ABORT("Input buffer data type different by matrix data type.")
matrix%data_memory_type = data_buffer%d%memory_type
matrix%data_area = data_buffer
CALL dbcsr_data_hold(matrix%data_area)
ELSE
CALL dbcsr_data_init(matrix%data_area)
END IF
END IF
! These are always invalidated.
NULLIFY (matrix%row_p, matrix%col_i, matrix%blk_p, matrix%thr_c, &
matrix%coo_l)
IF (PRESENT(row_blk_size_obj)) THEN
matrix%row_blk_size = row_blk_size_obj
CALL array_hold(matrix%row_blk_size)
ELSEIF (PRESENT(row_blk_size)) THEN
CALL array_new(matrix%row_blk_size, row_blk_size, gift=reuse_arrays)
ELSE
DBCSR_ABORT("Missing row_blk_size")
END IF
IF (PRESENT(max_rbs)) THEN
matrix%max_rbs = max_rbs
ELSE IF (array_size(matrix%row_blk_size) .GT. 0) THEN
matrix%max_rbs = MAXVAL(array_data(matrix%row_blk_size))
ELSE
matrix%max_rbs = 0
END IF
IF (PRESENT(col_blk_size_obj)) THEN
matrix%col_blk_size = col_blk_size_obj
CALL array_hold(matrix%col_blk_size)
ELSEIF (PRESENT(col_blk_size)) THEN
CALL array_new(matrix%col_blk_size, col_blk_size, gift=reuse_arrays)
ELSE
DBCSR_ABORT("Missing col_blk_size")
END IF
IF (PRESENT(max_cbs)) THEN
matrix%max_cbs = max_cbs
ELSE IF (array_size(matrix%col_blk_size) .GT. 0) THEN
matrix%max_cbs = MAXVAL(array_data(matrix%col_blk_size))
ELSE
matrix%max_cbs = 0
END IF
!
IF (array_size(matrix%row_blk_size) /= dbcsr_distribution_nrows(dist)) &
DBCSR_ABORT("Number of blocked rows does match blocked row distribution.")
IF (array_size(matrix%col_blk_size) /= dbcsr_distribution_ncols(dist)) &
DBCSR_ABORT("Number of blocked columns does match blocked column distribution.")
! initialize row/col offsets
IF (PRESENT(row_blk_offset)) THEN
IF (dbcsr_distribution_nrows(dist) + 1 /= array_size(row_blk_offset)) &
CALL dbcsr_abort(__LOCATION__, &
"Number of blocked offset rows does match blocked row distribution.")
matrix%row_blk_offset = row_blk_offset
CALL array_hold(matrix%row_blk_offset)
ELSE
ALLOCATE (vec_row_blk_offset(array_size(matrix%row_blk_size) + 1))
CALL convert_sizes_to_offsets(array_data(matrix%row_blk_size), vec_row_blk_offset)
CALL array_new(matrix%row_blk_offset, vec_row_blk_offset, gift=.TRUE.)
END IF
IF (PRESENT(col_blk_offset)) THEN
IF (dbcsr_distribution_ncols(dist) + 1 /= array_size(col_blk_offset)) &
CALL dbcsr_abort(__LOCATION__, &
"Number of blocked offset columns does match blocked column distribution.")
matrix%col_blk_offset = col_blk_offset
CALL array_hold(matrix%col_blk_offset)
ELSE
ALLOCATE (vec_col_blk_offset(array_size(matrix%col_blk_size) + 1))
CALL convert_sizes_to_offsets(array_data(matrix%col_blk_size), vec_col_blk_offset)
CALL array_new(matrix%col_blk_offset, vec_col_blk_offset, gift=.TRUE.)
END IF
matrix%dist = dist
CALL dbcsr_distribution_hold(matrix%dist)
!$ IF (.NOT. dbcsr_distribution_has_threads(matrix%dist) .AND. PRESENT(thread_dist)) THEN
!$ IF (dbcsr_distribution_has_threads(thread_dist)) THEN
!$ matrix%dist%d%num_threads = thread_dist%d%num_threads
!$ matrix%dist%d%has_thread_dist = .TRUE.
!$ matrix%dist%d%thread_dist = thread_dist%d%thread_dist
!$ CALL array_hold(matrix%dist%d%thread_dist)
!$ END IF
!$ END IF
!$ IF (.NOT. dbcsr_distribution_has_threads(matrix%dist)) THEN
!$ CALL dbcsr_distribution_make_threads(matrix%dist, &
!$ array_data(matrix%row_blk_size))
!$ END IF
! Set up some data.
IF (my_make_index) THEN
CALL meta_from_dist(new_meta, dist, array_data(matrix%row_blk_size), &
array_data(matrix%col_blk_size))
matrix%nblkrows_total = new_meta(dbcsr_slot_nblkrows_total)
matrix%nblkcols_total = new_meta(dbcsr_slot_nblkcols_total)
matrix%nfullrows_total = new_meta(dbcsr_slot_nfullrows_total)
matrix%nfullcols_total = new_meta(dbcsr_slot_nfullcols_total)
matrix%nblkrows_local = new_meta(dbcsr_slot_nblkrows_local)
matrix%nblkcols_local = new_meta(dbcsr_slot_nblkcols_local)
matrix%nfullrows_local = new_meta(dbcsr_slot_nfullrows_local)
matrix%nfullcols_local = new_meta(dbcsr_slot_nfullcols_local)
END IF
my_nze = 0; IF (PRESENT(nze)) my_nze = nze
matrix%nblks = 0
matrix%nze = 0
IF (PRESENT(replication_type)) THEN
IF (replication_type .NE. dbcsr_repl_none &
.AND. replication_type .NE. dbcsr_repl_full &
.AND. replication_type .NE. dbcsr_repl_row &
.AND. replication_type .NE. dbcsr_repl_col) &
DBCSR_ABORT("Invalid replication type '"//replication_type//"'")
IF (replication_type .EQ. dbcsr_repl_row .OR. replication_type .EQ. dbcsr_repl_col) &
DBCSR_WARN("Row and column replication not fully supported")
matrix%replication_type = replication_type
ELSE
matrix%replication_type = dbcsr_repl_none
END IF
!
! Setup a matrix from scratch
IF (.NOT. hijack) THEN
IF (.NOT. PRESENT(data_buffer)) THEN
CALL dbcsr_data_new(matrix%data_area, matrix%data_type, my_nze, &
memory_type=matrix%data_memory_type)
CALL dbcsr_data_set_size_referenced(matrix%data_area, 0)
END IF
!
IF (my_make_index) THEN
NULLIFY (matrix%index)
CALL ensure_array_size(matrix%index, lb=1, ub=dbcsr_num_slots, &
zero_pad=.TRUE., memory_type=matrix%index_memory_type)
END IF
END IF
IF (my_make_index) THEN
IF (LBOUND(matrix%index, 1) .GT. 1 &
.OR. UBOUND(matrix%index, 1) .LT. dbcsr_num_slots) &
DBCSR_ABORT("Index is not large enough")
matrix%index(1:dbcsr_num_slots) = 0
matrix%index(1:dbcsr_meta_size) = new_meta(1:dbcsr_meta_size)
matrix%index(dbcsr_slot_size) = dbcsr_num_slots
END IF
!
matrix%symmetry = .FALSE.
matrix%negate_real = .FALSE.
matrix%negate_imaginary = .FALSE.
!matrix%transpose = .FALSE.
matrix_type_l = matrix_type
CALL uppercase(matrix_type_l)
SELECT CASE (matrix_type_l)
CASE (dbcsr_type_no_symmetry)
CASE (dbcsr_type_symmetric)
matrix%symmetry = .TRUE.
CASE (dbcsr_type_antisymmetric)
matrix%symmetry = .TRUE.
matrix%negate_real = .TRUE.
matrix%negate_imaginary = .TRUE.
CASE (dbcsr_type_hermitian)
matrix%symmetry = .TRUE.
matrix%negate_imaginary = .TRUE.
CASE (dbcsr_type_antihermitian)
matrix%symmetry = .TRUE.
matrix%negate_real = .TRUE.
CASE DEFAULT
DBCSR_ABORT("Invalid matrix type.")
END SELECT
matrix%bcsc = .FALSE.
matrix%local_indexing = .FALSE.
matrix%list_indexing = .FALSE.
CALL array_nullify(matrix%local_rows)
CALL array_nullify(matrix%global_rows)
CALL array_nullify(matrix%local_cols)
CALL array_nullify(matrix%global_cols)
matrix%has_local_rows = .FALSE.
matrix%has_global_rows = .FALSE.
matrix%has_local_cols = .FALSE.
matrix%has_global_cols = .FALSE.
IF (my_make_index) THEN
CALL dbcsr_make_index_exist(matrix)
END IF
matrix%valid = .TRUE.
CALL timestop(handle)
END SUBROUTINE dbcsr_create_new