test_copy_into_existing Subroutine

subroutine test_copy_into_existing()

Arguments

None

Source Code

   SUBROUTINE test_copy_into_existing()
      INTEGER, POINTER, CONTIGUOUS :: sizes(:), row_dist(:), col_dist(:)
      INTEGER, ALLOCATABLE :: index_before(:)
      INTEGER :: itype, icase, i
      TYPE(dbcsr_distribution_obj) :: dist
      TYPE(dbcsr_type) :: source, target
      TYPE(dbcsr_data_obj) :: values, actual
      COMPLEX(dp) :: reference(25)

      ALLOCATE (sizes(4), row_dist(4), col_dist(4))
      sizes = [2, 3, 2, 3]
      row_dist = 0; col_dist = 0
      CALL dbcsr_distribution_new(dist, mp_env, row_dist, col_dist)
      CALL dbcsr_data_init(values)
      CALL dbcsr_data_init(actual)
      CALL dbcsr_data_new(values, dbcsr_type_complex_8, data_size=25)
      CALL dbcsr_data_new(actual, dbcsr_type_complex_8, data_size=25)
      DO itype = 1, SIZE(data_types)
         values%d%c_dp(:) = CMPLX([(REAL(i, dp), i=1, 25)], 0.0_dp, dp)
         IF (itype > 2) values%d%c_dp(:) = values%d%c_dp(:)*CMPLX(1.0_dp, -1.0_dp, dp)
         CALL dbcsr_create(source, "source", dist, dbcsr_type_no_symmetry, &
                           row_blk_size=sizes, col_blk_size=sizes, data_type=data_types(itype))
         IF (mynode == 0) THEN
            CALL dbcsr_reserve_blocks(source, [1, 1, 2, 3], [1, 2, 2, 4])
            CALL dbcsr_data_convert(source%data_area, values)
         END IF
         CALL dbcsr_copy(target, source)
         DO icase = 1, 4
            ! Equal layouts, different sparsity with equal sizes, transposition, empty source.
            IF (icase == 2) THEN
               CALL dbcsr_release(target)
               CALL dbcsr_create(target, template=source)
               IF (mynode == 0) CALL dbcsr_reserve_blocks(target, [1, 2, 3, 3], [2, 2, 3, 4])
            END IF
            IF (icase == 3 .AND. mynode == 0) source%blk_p(4) = -source%blk_p(4)
            IF (icase == 4) CALL dbcsr_clear(source)
            ALLOCATE (index_before, SOURCE=target%index)
            CALL dbcsr_copy_into_existing(target, source)
            IF (ANY(target%index /= index_before)) DBCSR_ABORT("Copy changed target sparsity")
            DEALLOCATE (index_before)
            IF (mynode == 0) THEN
               reference = values%d%c_dp(:)
               IF (icase > 1) THEN
                  reference(1:15) = values%d%c_dp(5:19)
                  reference(16:19) = 0.0_dp
               END IF
               IF (icase == 3) reference(20:25) = values%d%c_dp([20, 23, 21, 24, 22, 25])
               IF (icase == 4) reference = 0.0_dp
               CALL dbcsr_data_convert(actual, target%data_area)
               IF (ANY(ABS(actual%d%c_dp(:) - reference) > 1.0E-6_dp)) &
                  DBCSR_ABORT("Copy changed matrix values")
            END IF
         END DO
         CALL dbcsr_release(target)
         CALL dbcsr_release(source)
      END DO
      CALL dbcsr_data_release(values)
      CALL dbcsr_data_release(actual)
      CALL dbcsr_distribution_release(dist)
      DEALLOCATE (sizes, row_dist, col_dist)
   END SUBROUTINE test_copy_into_existing