dbcsr_create_new Subroutine

   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