dbcsr_unittest Program

PROGRAM dbcsr_unittest
   !! Tests for DBCSR operations

   USE dbcsr_kinds, ONLY: dp
   USE dbcsr_lib, ONLY: dbcsr_finalize_lib, &
                        dbcsr_init_lib, &
                        dbcsr_print_statistics
   USE dbcsr_machine, ONLY: default_output_unit
   USE dbcsr_mp_methods, ONLY: dbcsr_mp_new, &
                               dbcsr_mp_release
   USE dbcsr_mpiwrap, ONLY: mp_cart_create, &
                            mp_cart_rank, &
                            mp_comm_free, &
                            mp_environ, &
                            mp_world_finalize, &
                            mp_world_init, mp_comm_type
   USE dbcsr_test_add, ONLY: dbcsr_test_adds
   USE dbcsr_test_methods, ONLY: dbcsr_reset_randmat_seed
   USE dbcsr_test_scale_by_vector, ONLY: dbcsr_test_scale_by_vectors
   USE dbcsr_types, ONLY: dbcsr_mp_obj
#include "base/dbcsr_base_uses.f90"

   IMPLICIT NONE

   INTEGER                                  :: numnodes, mynode, &
                                               prow, pcol, io_unit, handle
   INTEGER, DIMENSION(2)                    :: npdims, myploc
   INTEGER, DIMENSION(:, :), POINTER        :: pgrid
   TYPE(dbcsr_mp_obj)                       :: mp_env
   LOGICAL                                  :: success
   TYPE(mp_comm_type)                       :: mp_comm, group

   CHARACTER(len=*), PARAMETER :: routineN = 'dbcsr_unittest'

   ! initialize mpi
   CALL mp_world_init(mp_comm)

   ! setup the mp environment
   npdims(:) = 0
   CALL mp_cart_create(mp_comm, 2, npdims, myploc, group)
   CALL mp_environ(numnodes, mynode, group)
   ALLOCATE (pgrid(0:npdims(1) - 1, 0:npdims(2) - 1))
   DO prow = 0, npdims(1) - 1
      DO pcol = 0, npdims(2) - 1
         CALL mp_cart_rank(group, (/prow, pcol/), pgrid(prow, pcol))
      END DO
   END DO
   CALL dbcsr_mp_new(mp_env, group, pgrid, mynode, numnodes, &
                     myprow=myploc(1), mypcol=myploc(2))
   DEALLOCATE (pgrid)

   ! set standard output parameters
   io_unit = 0
   IF (mynode .EQ. 0) io_unit = default_output_unit

   ! initialize DBCSR
   CALL dbcsr_init_lib(mp_comm%get_handle(), io_unit)

   ! start measuring the complete test
   CALL timeset(routineN, handle)

   CALL dbcsr_reset_randmat_seed()

   ! run tests
   success = .TRUE.

   success = dbcsr_test_scale_by_vectors("scale_by_vector_symmetric", &
                                         group, mp_env, npdims, io_unit, matrix_size=[20, 20], &
                                         sparsity=0.5_dp, bs_m=[1, 4], bs_n=[1, 4], do_exact_comparison=.FALSE.) &
             .AND. success

   ! specific reproducers of https://github.com/cp2k/dbcsr/issues/362
   ! the first one gives wrong results when scaling
   success = dbcsr_test_scale_by_vectors("scale_by_vector_asymm_exact1", &
                                         group, mp_env, npdims, io_unit, matrix_size=[30, 20], &
                                         sparsity=0.0_dp, bs_m=[1, 4], bs_n=[1, 4], do_exact_comparison=.TRUE.) &
             .AND. success
   ! the second one triggers segfaults without the fix
   success = dbcsr_test_scale_by_vectors("scale_by_vector_asymm_exact2", &
                                         group, mp_env, npdims, io_unit, matrix_size=[20, 30], &
                                         sparsity=0.0_dp, bs_m=[1, 4], bs_n=[1, 4], do_exact_comparison=.TRUE.) &
             .AND. success
   CALL timestop(handle)

   ! clean mp environment
   CALL dbcsr_mp_release(mp_env)

   ! finalize mpi
   CALL mp_comm_free(group)

   call dbcsr_print_statistics(.true.)
   ! finalize libdbcsr
   CALL dbcsr_finalize_lib()
   CALL mp_world_finalize()

   ! finalize libdbcsr errors
   IF (.NOT. success) &
      ERROR STOP "one or more tests failed"
END PROGRAM dbcsr_unittest