[ADD] Added multiple process check also for geaxpby test making it compliant with the gedot one

test_dev
Stack-1 10 months ago
parent 448a6d6e0a
commit 30c53f8075

@ -30,9 +30,9 @@ Each directory has the name of the computational kernel routines described in th
In this test suite were considered only computational routines implemented by PSBLAS, according to the version 3.9 of the documentation. In the following table are reported all the kernels, their implementation and wheter or not they were tested yet.
|**Kernel**| **PSBLAS Subroutine**|**Description**|**Single Process Test**|**Multi-Process Test**|**Complex Test**|**GPU Test**|
| ------------------------------- | :--------------------------: | ---------------------------------------------------------------------- | :---------------: |:---------------: |:---------------: |:---------------: |
|**General Dense Matrix Sum**| `psb_geaxpby`| This subroutine is an interface to the computational kernel for dense matrix sum: $Y \leftarrow \alpha X + \beta Y$ |Work in progress :hammer_and_wrench:|Work in progress :hammer_and_wrench:|No ❌|No ❌|
|**General Dense Matrix Sum**| `psb_geaxpby`| This subroutine is an interface to the computational kernel for dense matrix sum: $Y \leftarrow \alpha X + \beta Y$ |Yes ✅|Yes ✅|No ❌|No ❌|
| **Dot product**|`psb_gedot`|This function computes dot product between two vectors x and y. $dot \leftarrow x^T y$ If x and y are real vectors it computes dot-product as: $dot \leftarrow x^H y$ |Yes ✅|Yes ✅|No ❌|No ❌|
| **Generalized Dot Product** |`psb_gedots`|This subroutine computes a series of dot products among the columns of two dense matrices x and y:$res(i) \leftarrow x(:,i)^T y(:,i)$If the matrices are complex, then the usual convention applies, i.e. the conjugate transpose of x is used. If x and y are of rank one, then res is a scalar, else it is a rank one array.|No ❌|No ❌|No ❌|No ❌|
| **Generalized Dot Product** |`psb_gedots`|This subroutine computes a series of dot products among the columns of two dense matrices x and y:$res(i) \leftarrow x(:,i)^T y(:,i)$ If the matrices are complex, then the usual convention applies, i.e. the conjugate transpose of x is used. If x and y are of rank one, then res is a scalar, else it is a rank one array.|No ❌|No ❌|No ❌|No ❌|
|**Infinity-Norm of Vector**|`psb_normi`/`psb_geamax`|This function computes the infinity-norm of a vector x. If x is a real vector it computes infinity norm as:$amax \leftarrow max \mid x_i \mid$else if x is a complex vector then it computes the infinity-norm as: $amax \leftarrow max(\mid re(x_i) \mid + \mid im(x_i) \mid)$ |No ❌|No ❌|No ❌|No ❌|
|**Generalized Infinity Norm**|`psb_geamaxs`|This subroutine computes a series of infinity norms on the columns of a dense matrix x: $res(i) \leftarrow max_k \mid x(k,i) \mid$ |No ❌|No ❌|No ❌|No ❌|
| **1-Norm of Vector**| `psb_norm1` / `psb_geasums`|This function computes the 1-norm of a vector x. If x is a real vector it computes 1-norm as: $asum \leftarrow \mid \mid x_i \mid \mid$ else if x is a complex vector then it computes 1-norm as: $asum \leftarrow \mid \mid re(x) \mid \mid_1 + \mid \mid im(x) \mid \mid_1$ |No ❌|No ❌|No ❌|No ❌|
@ -50,10 +50,6 @@ In this test suite were considered only computational routines implemented by PS
## Developer Notes
In order to keep compliant the excecution of the bash script used to automate the teest excecution, remember to create a new directory to put new tests and to use the name convention of psb_test_ signature for utilities functions and psb_kernel_test for tests used for new routines.
## TODO
- Finish the directories description
- Check memory occupancy of parallel/ serial/ and vectors/ directories (Maybe not the best way for lots of rputines?)
## References
<a id="testing">[1].</a> Higham, Nicholas J. Testing linear algebra software. Springer US, 1997

@ -4,10 +4,10 @@ COMPLETED:
- Remove file generation in order to save up memory [OK]
- Clean main log at each run [OK] (Log aggregation was deleted)
- Fix log aggregation in main directory, see number of total tests [OK] (Log aggregation was deleted)
- Fix parallel and serial, using a fortran routine instead of the diff between files [OK]
TODO:
- Fix parallel and serial, using a fortran routine instead of the diff between files
- Force recompilation in main script (A flag should be added)
- Generate input vectors only if vectors/ directory doesn't exist to save up time (It is really dependant on the kernel analyzed, it is not always possible)

@ -8,12 +8,10 @@ include $(INCDIR)/Make.inc.psblas
LIBDIR = $(INSTALLDIR)/lib/
PSBLAS_LIB = -L$(LIBDIR) -lpsb_util -lpsb_base
LDLIBS = $(PSBLDLIBS)
EXEDIR = ./runs
FINCLUDES=$(FMFLAG)$(MODDIR) $(FMFLAG).
EXEDIR=./runs
GREEN=\033[0;32m
RED=\033[0;31m
BLUE=\033[0;34m
@ -25,15 +23,12 @@ all: runsd psb_geaxpby_test
@printf "$(GREEN)[INFO]\t Compilation success!$(END_COLOUR)\n"
runsd:
@(if test ! -d runs ; then mkdir runs; fi)
@(if test ! -d $(EXEDIR) ; then mkdir $(EXEDIR); fi)
@printf "$(BLUE)[INFO]\t Build directory $(EXEDIR) correctly initialized$(END_COLOUR)\n"
psb_geaxpby_test:
@$(FLINK) $(LOPT) psb_geaxpby_test.f90 geaxpby.f90 -o psb_geaxpby_test -I$(MODDIR) -I. $(PSBLAS_LIB) $(LDLIBS)
@mv psb_geaxpby_test $(EXEDIR)
@printf "$(BLUE)[INFO]\t Testing files generated correctly$(END_COLOUR)\n"
@$(FLINK) $(LOPT) psb_geaxpby_test.f90 ../utils/psb_test_utils.o -o $(EXEDIR)/psb_geaxpby_test -I../utils/ -I$(MODDIR) -I. $(PSBLAS_LIB) $(LDLIBS)
@printf "$(BLUE)[INFO]\t Testing files for psb_geaxpby linked and compiled correctly$(END_COLOUR)\n"
clean:
@rm -f $(OBJS)\

@ -6,7 +6,7 @@ This is a directory developed by Luca Pepè Sciarria and Simone Staccone froma T
Steps to reproduce the tests:
- Compile the code using ``` make ``` (Optional)
- Launch the script ./autotest.sh or with source ./autotest.sh if you want to add modules to the .bashrc file permenently.
- Check the output log file psblas_geaxpby_test.log to collect results
- Check the output log file psb_geaxpby_test.log to collect results
NOTE: If the code is changed and a new compilation is needed to show the changes, the autotest.sh script isn't aware of this scenario, therefore it is necessary to manually recompile the code.
@ -18,6 +18,8 @@ The ```psb_geaxpby```. The signature of the function is:
call psb_geaxpby(alpha, x, beta, y, desc_a, info)
```
The strategy to validate the correctness of the computation is to compare single precision result and double precision result in the test cases in which the test should not give an error. In this way it is possible to have a correctness check of the computation comparing the two results considering a number of significant digits which is tuned on the single precision computation.
### Parameters Values
**x** vectors are located in the vectors/ directory. They are generated randomly using the same seed and then saved on different files based on their characteristics. The size of the vector is choosen accordingly to the size of the matrix column space considered for the single test instance.
|Vector|File Name|Coefficients|Coefficients Description|
@ -35,28 +37,22 @@ call psb_geaxpby(alpha, x, beta, y, desc_a, info)
|$y_3$|y3.txt|$y_i \ne 0, \forall i$|Random coefficients
|$y_4$|y4.txt|$y_i = 0, \forall i$|Null coefficients
**$\alpha$**
**$\alpha$** real coefficient multiplied by vector $x$
|$\alpha$|Value|Coefficients Description|
|:-:|:-:|:-:|
|$\alpha_1$|1.0|Positive value|
|$\alpha_2$|-1.0|Negative value|
|$\alpha_3$|0.0|Null value|
**$\beta$**
**$\beta$** real coefficient multiplied by vector $y$
|$\alpha$|Value|Coefficients Description|
|:-:|:-:|:-:|
|$\beta_1$|1.0|Positive value|
|$\beta_2$|-1.0|Negative value|
|$\beta_3$|0.0|Null value|
## Output
The ouput files generated by the test are automatically compared by the autotest.sh script, but if it is needed to manually run the test here it is the naming convenction used.
The results of the computation will be saved on different files based on the instance of the test considered. In particular the naming conventiona format the output file as sol_x#_y#_a#_b#.mtx, where each # is a number choosen w.r.t. the test instance. (Ex. sol_x1_y1_a1_b1.mtx is the solution computed using the first x vector file , the first y vector file, alpha = 1.0 and beta = 1.0). Moreover, the files will be saved in the serial/ directory if the program is launched using 1 process or in parrallel/ directory if the program is launched with more than one process.
## TODO
- Add computation with broken descriptor and catch the errore result
- Test using complex data
- Try multiple distributions
- Try using a matrix instead of a vector
- Try using a matrix instead of a vector

@ -1,9 +1,6 @@
#!/bin/bash
# Variables definition
dir1="serial"
dir2="parallel"
log_file_name="psblas_geaxpby_test.log"
num_procs=$(nproc)
@ -37,23 +34,8 @@ echo -e "${BLUE}[INFO]\t Starting $num_procs processes computation${RESET}"
mpirun -np $num_procs ./runs/psb_geaxpby_test
echo -e "${BLUE}[INFO]\t Multiple processes computation terminated correctly${RESET}"
echo "" >> ${log_file_name}
# Iterate through files in the first directory
for file1 in "$dir1"/*; do
filename=$(basename "$file1") # Extract the filename
file2="$dir2/$filename" # Construct the path for the second directory
# Check if the file exists in the second directory
if [ -f "$file2" ]; then
diff_count=$(diff "$file1" "$file2" | wc -l) # Compare the files
echo "Comparison between $file1 and $file2: $diff_count differences" >> ${log_file_name}
# echo "Comparing $file1 and $file2: $diff_count"
else
echo -e "${RED}[ERROR] File $filename does not exist in $dir2${RESET}"
fi
done
rm -f results/*
rm -f -r results/
echo -e "${BLUE}[INFO]\t PSBLAS psb_geaxpby test succesfully completed.${RESET}"

@ -1,201 +0,0 @@
program main
use psb_geaxpby_test
use psb_base_mod
implicit none
! MPI variables
integer(psb_ipk_) :: my_rank, np
! Communicator variable
type(psb_ctxt_type) :: ctxt
! parameters array
character(len=64) :: x(4),y(4)
real(psb_dpk_) :: alpha(3), beta(3)
integer(psb_ipk_) :: arr_size
integer(psb_ipk_) :: tests_number, count
! cycle indexes variables
integer(psb_ipk_) :: i,j,k,h,l
integer(psb_ipk_) :: info, ret, unit
! time stats variables
character(len=8) :: date ! YYYYMMDD
character(len=10) :: time ! HHMMSS.sss
character(len=5) :: zones ! Time zone
integer :: values(8)
! others
character(len=:), allocatable :: output_file_name
! Initialize parameters
x(1) = "vectors/x1.mtx"
x(2) = "vectors/x2.mtx"
x(3) = "vectors/x3.mtx"
x(4) = "vectors/x4.mtx"
y(1) = "vectors/y1.mtx"
y(2) = "vectors/y2.mtx"
y(3) = "vectors/y3.mtx"
y(4) = "vectors/y4.mtx"
alpha(1) = done
alpha(2) = -done
alpha(3) = dzero
beta(1) = done
beta(2) = -done
beta(3) = dzero
arr_size = 10000
tests_number = size(x) * size(y) * size(alpha) * size(beta)
count = 0
call psb_init(ctxt)
call psb_info(ctxt,my_rank,np)
if(my_rank == psb_root_) then
! Setup logger output
if(np == 1) then
open(newunit=unit, file='psblas_geaxpby_test.log', status='replace', action='write', iostat=info)
else
open(newunit=unit, file='psblas_geaxpby_test.log', status='old', action='write', position='append', iostat=info)
end if
if (info /= 0) then
print *, 'Error opening output file.'
print *, "I/O Status Code:", info
stop
end if
psb_out_unit = unit
write(psb_out_unit,'(A,A)') 'Welcome to PSBLAS version: ',psb_version_string_
write(psb_out_unit,'(A)') 'This is the psb_geaxpby_test sample program'
write(psb_out_unit,'(A,I0)') 'Number of processes used in this computation: ', np
write(psb_out_unit,'(A)') ''
call generate_vectors(arr_size)
end if
call psb_bcast(ctxt,psb_out_unit)
call psb_barrier(ctxt)
if(my_rank == psb_root_) write(*,'(A)') "[INFO] Starting single precision computation..."
do i=1,size(x)
do j=1,size(y)
do k=1,size(alpha)
do h=1,size(beta)
call psb_geaxpby_kernel(x_file=x(i), y_file=y(j), alpha = real(alpha(k),psb_spk_),&
& beta = real(beta(h),psb_spk_), arr_size = arr_size, ctxt = ctxt, ret = ret, &
& output_file_name = output_file_name)
if(my_rank == psb_root_) then
count = count + 1
call date_and_time(date, time, zones, values)
if(ret /= -1) then
! Success formatted output
write(psb_out_unit,'("[", I4.4,"-",I2.2,"-",I2.2," ",I2.2,":",I2.2,":",I2.2,"] ",&
& A,A,A,I0,A,I0,T110,A)') &
& values(1), values(2), values(3), values(5), values(6), values(7), &
& "Generation geaxpby single precision result file ", &
& output_file_name , ' ', count , "/", tests_number, "[OK]"
else
! Fail formatted output
write(psb_out_unit,'("[", I4.4,"-",I2.2,"-",I2.2," ",I2.2,":",I2.2,":",I2.2,"] ",&
& A,A,A,I0,A,I0,T110,A)') &
& values(1), values(2), values(3), values(5), values(6), values(7), &
& "Generation geaxpby single precision result file ", &
& output_file_name , ' ', count , "/", tests_number, "[FAIL]"
goto 9998
end if
end if
call psb_barrier(ctxt)
end do
end do
end do
end do
if(my_rank == psb_root_) write(*,'(A)') "[INFO] Single precision computation completed succesfully!"
if(my_rank == psb_root_) then
write(psb_out_unit, *) ''
count = 0
end if
if(my_rank == psb_root_) write(*,'(A)') "[INFO] Starting double precision check..."
call psb_barrier(ctxt)
! Here double precision comparison should be done
do i=1,size(x)
do j=1,size(y)
do k=1,size(alpha)
do h=1,size(beta)
call psb_geaxpby_check(x_file=x(i), y_file=y(j), alpha = alpha(k), beta = beta(h), &
& arr_size = arr_size, ctxt = ctxt, ret = ret, output_file_name = output_file_name)
if(my_rank == psb_root_) then
count = count + 1
call date_and_time(date, time, zones, values)
if(ret == 0) then
! Success formatted output
write(psb_out_unit,'("[", I4.4,"-",I2.2,"-",I2.2," ",I2.2,":",I2.2,":",I2.2,"] ",&
& A,A,A,I0,A,I0,T110,A)') &
& values(1), values(2), values(3), values(5), values(6), values(7), &
& "Double precision check on file ", &
& output_file_name , ' ', count , "/", tests_number, "[OK]"
else
! Fail formatted output
write(psb_out_unit,'("[", I4.4,"-",I2.2,"-",I2.2," ",I2.2,":",I2.2,":",I2.2,"] ",&
& A,A,A,I0,A,I0,T110,A)') &
& values(1), values(2), values(3), values(5), values(6), values(7), &
& "Double precision check on file ", &
& output_file_name , ' ', count , "/", tests_number, "[FAIL]"
write(psb_out_unit,'(A,I0)') "[ERROR] Error at element ", abs(ret)
write(psb_out_unit,'(A,F10.8)') "Alpha:", alpha(k)
write(psb_out_unit,'(A,F15.8)') "Beta: ", beta(h)
goto 9999
end if
end if
call psb_barrier(ctxt)
end do
end do
end do
end do
if(my_rank == psb_root_) then
write(*,'(A)') "[INFO] Duble precision check completed succesfully!"
close(unit)
end if
call psb_exit(ctxt)
return
9998 continue
if(my_rank == psb_root_) then
close(unit)
write(*,'(A,I0,A,I0,A)') "[ERROR] Error in geaxpby single precision computation ", &
& count, "/", tests_number, " see log file for details"
end if
9999 continue
if(my_rank == psb_root_) then
close(unit)
write(*,'(A,I0,A,I0,A)') "[ERROR] Error in geaxpby double precision check ", &
& count, "/", tests_number, " see log file for details"
end if
call psb_exit(ctxt)
return
end program main

@ -71,11 +71,6 @@
!! Intent: out.
!! Specified as: An integer value; 0 means no error has been detected.
!!
program main
use psb_base_mod
use psb_util_mod
@ -99,15 +94,14 @@ program main
integer(psb_ipk_) :: i,j,k,h,l
integer(psb_ipk_) :: info, ret, unit
! time stats variables
character(len=8) :: date ! YYYYMMDD
character(len=10) :: time ! HHMMSS.sss
character(len=5) :: zones ! Time zone
integer :: values(8)
! others
character(len=:), allocatable :: output_file_name
type(test_info_) :: test_info
type(psb_test_info) :: test_info
! result vectors
real(psb_spk_), allocatable :: y_single(:)
real(psb_dpk_), allocatable :: y_double(:)
! Initialize parameters
x(1) = "vectors/x1.mtx"
@ -129,13 +123,11 @@ program main
beta(3) = dzero
arr_size = 10000
tests_number = size(x) * size(y) * size(alpha) * size(beta)
count = 0
!! Initialize test metadata
test_info%total_tests = size(x) * size(y)
test_info%threshold_type = GAMMA
test_info%threshold = 0.0
test_info%total_tests = size(x) * size(y) * size(alpha) * size(beta)
test_info%threshold_type = VALUE
test_info%threshold = 1.0D-06
test_info%kernel_name = "psb_geaxpby"
call psb_test_init(test_info)
@ -143,169 +135,85 @@ program main
if(test_info%my_rank == psb_root_) then
psb_out_unit = test_info%output_unit
call psb_test_generate_input_vectors(arr_size)
allocate(y_single(arr_size))
allocate(y_double(arr_size))
end if
call psb_bcast(test_info%ctxt,test_info%output_unit)
call psb_barrier(test_info%ctxt)
if(test_info%my_rank == psb_root_) write(*,'(A)') "[INFO] Starting test excecution ..."
!call psb_init(ctxt)
!call psb_info(ctxt,my_rank,np)
! call generate_vectors(arr_size)
!call psb_bcast(ctxt,psb_out_unit)
!call psb_barrier(ctxt)
if(test_info%my_rank == psb_root_) write(*,'(A)') "[INFO] Starting single precision computation..."
do i=1,size(x)
do j=1,size(y)
do k=1,size(alpha)
do h=1,size(beta)
call psb_geaxpby_kernel(x_file=x(i), y_file=y(j), alpha = real(alpha(k),psb_spk_),&
& beta = real(beta(h),psb_spk_), arr_size = arr_size, ctxt = test_info%ctxt, ret = ret, &
& output_file_name = output_file_name)
call psb_geaxpby_real_kernel(x(i), y(j), alpha(k),beta(h), arr_size, test_info%ctxt, y_single, y_double)
if(test_info%my_rank == psb_root_) then
count = count + 1
call date_and_time(date, time, zones, values)
if(ret /= -1) then
! Success formatted output
write(psb_out_unit,'("[", I4.4,"-",I2.2,"-",I2.2," ",I2.2,":",I2.2,":",I2.2,"] ",&
& A,A,A,I0,A,I0,T110,A)') &
& values(1), values(2), values(3), values(5), values(6), values(7), &
& "Generation geaxpby single precision result file ", &
& output_file_name , ' ', count , "/", tests_number, "[OK]"
if(test_info%np > 1) then
! If the program is being run on multiple processes, we need to
! check the result on the root process with the one computed only using
! a single process
call psb_test_process_vector_check(y_single, test_info)
else
! Fail formatted output
write(psb_out_unit,'("[", I4.4,"-",I2.2,"-",I2.2," ",I2.2,":",I2.2,":",I2.2,"] ",&
& A,A,A,I0,A,I0,T110,A)') &
& values(1), values(2), values(3), values(5), values(6), values(7), &
& "Generation geaxpby single precision result file ", &
& output_file_name , ' ', count , "/", tests_number, "[FAIL]"
goto 9998
call psb_test_single_double_vector_check(y_single,y_double,test_info, arr_size)
! If the program is being run on a single process, we can save the result directly
call psb_test_save_vector_result(y_single, test_info)
end if
end if
call psb_barrier(test_info%ctxt)
end do
end do
end do
end do
if(test_info%my_rank == psb_root_) write(*,'(A)') "[INFO] Single precision computation completed succesfully!"
if(test_info%my_rank == psb_root_) then
write(psb_out_unit, *) ''
count = 0
end if
if(test_info%my_rank == psb_root_) write(*,'(A)') "[INFO] Starting double precision check..."
call psb_barrier(test_info%ctxt)
! Here double precision comparison should be done
do i=1,size(x)
do j=1,size(y)
do k=1,size(alpha)
do h=1,size(beta)
call psb_geaxpby_check(x_file=x(i), y_file=y(j), alpha = alpha(k), beta = beta(h), &
& arr_size = arr_size, ctxt = test_info%ctxt, ret = ret, output_file_name = output_file_name)
if(my_rank == psb_root_) then
count = count + 1
call date_and_time(date, time, zones, values)
if(ret == 0) then
! Success formatted output
write(psb_out_unit,'("[", I4.4,"-",I2.2,"-",I2.2," ",I2.2,":",I2.2,":",I2.2,"] ",&
& A,A,A,I0,A,I0,T110,A)') &
& values(1), values(2), values(3), values(5), values(6), values(7), &
& "Double precision check on file ", &
& output_file_name , ' ', count , "/", tests_number, "[OK]"
else
! Fail formatted output
write(psb_out_unit,'("[", I4.4,"-",I2.2,"-",I2.2," ",I2.2,":",I2.2,":",I2.2,"] ",&
& A,A,A,I0,A,I0,T110,A)') &
& values(1), values(2), values(3), values(5), values(6), values(7), &
& "Double precision check on file ", &
& output_file_name , ' ', count , "/", tests_number, "[FAIL]"
write(psb_out_unit,'(A,I0)') "[ERROR] Error at element ", abs(ret)
write(psb_out_unit,'(A,F10.8)') "Alpha:", alpha(k)
write(psb_out_unit,'(A,F15.8)') "Beta: ", beta(h)
goto 9999
end if
test_info%current_test = test_info%current_test + 1
end if
call psb_barrier(test_info%ctxt)
end do
end do
end do
end do
if(test_info%my_rank == psb_root_) then
write(*,'(A)') "[INFO] Duble precision check completed succesfully!"
close(unit)
end if
call psb_exit(test_info%ctxt)
return
9998 continue
if(test_info%my_rank == psb_root_) then
close(unit)
write(*,'(A,I0,A,I0,A)') "[ERROR] Error in geaxpby single precision computation ", &
& count, "/", tests_number, " see log file for details"
end if
9999 continue
if(test_info%my_rank == psb_root_) then
close(unit)
write(*,'(A,I0,A,I0,A)') "[ERROR] Error in geaxpby double precision check ", &
& count, "/", tests_number, " see log file for details"
end if
call psb_test_exit(test_info)
return
contains
contains
!> @brief Function to excecute psb_geaxpby in single precision and
!! save the results on file
!> @brief This subroutine implements the psb_geaxpby kernel for real vectors
!! performing the operation y = alpha * x + beta * y. It reads input from files,
!! performs the operation, and outputs the result.
!!
!! @param x_file: file name of the input vector x
!! @param y_file: file name of the input vector y
!! @param alpha: scalar alpha
!! @param beta: scalar beta
!! @param arr_size: size of the vectors
!! @param ctxt: communication context
!! @param y_single_global: single precision output vector
!! @param y_double_global: double precision output vector
!!
subroutine psb_geaxpby_kernel(x_file, y_file, alpha, beta, arr_size, ctxt, ret, output_file_name)
subroutine psb_geaxpby_real_kernel(x_file, y_file, alpha, beta, arr_size, ctxt, y_single_global, y_double_global)
! implicit none
! input parameters
character(len = *), intent(in) :: x_file, y_file
real(psb_spk_), intent(in) :: alpha, beta
real(psb_dpk_), intent(in) :: alpha, beta
integer(psb_ipk_), intent(in) :: arr_size
type(psb_ctxt_type), intent(in) :: ctxt
! output parameters
integer(psb_ipk_), intent(out) :: ret
character(len=:), allocatable, intent(out) :: output_file_name
! vectors
type(psb_s_vect_type) :: x, y
type(psb_s_vect_type) :: x_single, y_single
type(psb_d_vect_type) :: x_double, y_double
! matrix descriptor data structure
type(psb_desc_type) :: desc_a
type(psb_desc_type) :: desc_a
! communication context
integer(psb_ipk_) :: my_rank, np, info, err_act
integer(psb_ipk_) :: my_rank, np, info, err_act
! variables outside PSLBALS data structures
real(psb_spk_), allocatable :: x_global(:), y_global(:)
integer(psb_ipk_) :: i
real(psb_spk_), allocatable :: x_single_global(:)
real(psb_spk_), allocatable, intent(inout) :: y_single_global(:)
real(psb_dpk_), allocatable :: x_double_global(:)
real(psb_dpk_), allocatable, intent(inout) :: y_double_global(:)
integer(psb_ipk_) :: i, nl
! others
logical :: exists
@ -323,369 +231,151 @@ program main
! Generate random array for b using always the same seed
if(my_rank == psb_root_) then
allocate(x_global(arr_size))
allocate(y_global(arr_size))
call mm_array_read(x_global,info,filename=x_file)
call mm_array_read(y_global,info,filename=y_file)
end if
allocate(x_single_global(arr_size))
allocate(x_double_global(arr_size))
! Allocate descriptor as if it was a block rows distribution
call psb_cdall(ctxt, desc_a, info,nl=arr_size/np)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error allocating desc_a data structure"
goto 9999
call mm_array_read(x_single_global,info,filename=x_file)
call mm_array_read(y_single_global,info,filename=y_file)
call mm_array_read(x_double_global,info,filename=x_file)
call mm_array_read(y_double_global,info,filename=y_file)
end if
call psb_cdasb(desc_a, info)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error assembling desc_a data structure"
goto 9999
end if
! Allocate descriptor as if it was a block rows distribution
nl = (arr_size)/np + mod(arr_size,np)
call psb_geall(x,desc_a,info)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error allocating x data structure"
goto 9999
end if
call psb_bcast(test_info%ctxt,test_info%output_unit)
call psb_barrier(test_info%ctxt)
! Populate x class using data from x_global vector
call psb_scatter(x_global,x,desc_a,info,root=psb_root_)
call psb_cdall(ctxt, desc_a, info,nl=nl)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error in psb_scatter to populate x data structure"
goto 9999
end if
call psb_geall(y,desc_a,info)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error allocating y data structure"
write(psb_out_unit,'(A)') "Error allocating desc_a data structure"
goto 9999
end if
! Populate y class using data from y_global vector
call psb_scatter(y_global,y,desc_a,info,root=psb_root_)
call psb_cdasb(desc_a, info)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error in psb_scatter to populate y data structure"
write(psb_out_unit,'(A)') "Error assembling desc_a data structure"
goto 9999
end if
! y = alpha * x + beta * y
call psb_geaxpby(alpha,x,beta,y,desc_a,info)
call psb_geall(x_single,desc_a,info)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error in psb_geaxpby routine"
write(psb_out_unit,'(A)') "Error allocating single precision x data structure"
goto 9999
end if
! Make the root process be the one that saves everything on file
if(np == 1) then
! Check if output directory exists
inquire(file='serial/', exist=exists)
if (.not.exists) then
call system('mkdir serial/')
end if
output_file_name = "serial/"
else
! Check if output directory exists
inquire(file='parallel/', exist=exists)
if (.not.exists) then
call system('mkdir parallel/')
end if
output_file_name = "parallel/"
end if
output_file_name = output_file_name // "sol_" // x_file(9:10) // "_" // y_file(9:10)
if(alpha == sone) then
output_file_name = output_file_name // "_a1"
else if(alpha == -sone) then
output_file_name = output_file_name // "_a2"
else if(alpha == szero) then
output_file_name = output_file_name // "_a3"
end if
if(beta == sone) then
output_file_name = output_file_name // "_b1.mtx"
else if(beta == -sone) then
output_file_name = output_file_name // "_b2.mtx"
else if(beta == szero) then
output_file_name = output_file_name // "_b3.mtx"
end if
! gather the result combining all the partial ones
call psb_gather(y_global, y, desc_a, info)
call psb_geall(x_double,desc_a,info)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error gathering global vector x to write on file"
write(psb_out_unit,'(A)') "Error allocating double precision x data structure"
goto 9999
end if
! Save result to output file
if(my_rank == psb_root_) then
call mm_array_write(y_global,"Result vector",info,filename=output_file_name)
end if
! Deallocate
call psb_gefree(x, desc_a,info)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error in vector x free routine"
goto 9999
end if
call psb_gefree(y, desc_a,info)
! Populate x class using data from x_global vector
call psb_scatter(x_single_global,x_single,desc_a,info,root=psb_root_)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error in vector y free routine"
goto 9999
write(psb_out_unit,'(A)') "Error in psb_scatter to populate single precision x data structure"
return
end if
call psb_cdfree(desc_a,info)
call psb_scatter(x_double_global,x_double,desc_a,info,root=psb_root_)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error in matrix descriptor free routine"
goto 9999
end if
if(my_rank == 0) then
deallocate(x_global)
deallocate(y_global)
write(psb_out_unit,'(A)') "Error in psb_scatter to populate double precision x data structure"
return
end if
return
! Error handling
9999 ret = -1
stop
end subroutine
!> @brief Function to excecute psb_geaxpby in double precision and
!! compare the results with the ones on file
!!
subroutine psb_geaxpby_check(x_file, y_file, alpha, beta, arr_size, ctxt, ret, output_file_name)
use psb_base_mod
use psb_util_mod
implicit none
! input parameters
character(len = *), intent(in) :: x_file, y_file
real(psb_dpk_), intent(in) :: alpha, beta
integer(psb_ipk_), intent(in) :: arr_size
type(psb_ctxt_type), intent(in) :: ctxt
! output parameters
integer(psb_ipk_), intent(out) :: ret
character(len=:), allocatable, intent(out) :: output_file_name
! vectors
type(psb_d_vect_type) :: x, y
type(psb_s_vect_type) :: y_check
! matrix descriptor data structure
type(psb_desc_type) :: desc_a
! communication context
integer(psb_ipk_) :: my_rank, np, info, err_act
! variables outside PSLBALS data structures
real(psb_dpk_), allocatable :: x_global(:), y_global(:)
integer(psb_ipk_) :: i
! others
logical :: exists
info = psb_success_
call psb_info(ctxt,my_rank,np)
if (my_rank < 0) then
! This should not happen, but just in case
call psb_error(ctxt)
endif
! Generate random array for b using always the same seed
if(my_rank == psb_root_) then
allocate(x_global(arr_size))
allocate(y_global(arr_size))
call mm_array_read(x_global,info,filename=x_file)
call mm_array_read(y_global,info,filename=y_file)
end if
! Allocate descriptor as if it was a block rows distribution
call psb_cdall(ctxt, desc_a, info,nl=10000/np)
call psb_geall(y_single,desc_a,info)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error allocating desc_a data structure"
write(psb_out_unit,'(A)') "Error allocating single precision y data structure"
goto 9999
end if
call psb_cdasb(desc_a, info)
call psb_geall(y_double,desc_a,info)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error assembling desc_a data structure"
write(psb_out_unit,'(A)') "Error allocating double precision y data structure"
goto 9999
end if
call psb_geall(x,desc_a,info)
! Populate y class using data from y_global vector
call psb_scatter(y_single_global,y_single,desc_a,info,root=psb_root_)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error allocating x data structure"
write(psb_out_unit,'(A)') "Error in psb_scatter to populate single precision y data structure"
goto 9999
end if
! Populate x class using data from x_global vector
call psb_scatter(x_global,x,desc_a,info,root=psb_root_)
call psb_scatter(y_double_global,y_double,desc_a,info,root=psb_root_)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error in psb_scatter to populate x data structure"
write(psb_out_unit,'(A)') "Error in psb_scatter to populate double precision y data structure"
goto 9999
end if
call psb_geall(y,desc_a,info)
! y = alpha * x + beta * y
call psb_geaxpby(real(alpha,psb_spk_),x_single,real(beta,psb_spk_),y_single,desc_a,info)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error allocating y data structure"
write(psb_out_unit,'(A)') "Error in psb_geaxpby routine"
goto 9999
end if
! Populate y class using data from y_global vector
call psb_scatter(y_global,y,desc_a,info,root=psb_root_)
! y = alpha * x + beta * y
call psb_geaxpby(alpha,x_double,beta,y_double,desc_a,info)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error in psb_scatter to populate y data structure"
write(psb_out_unit,'(A)') "Error in psb_geaxpby routine"
goto 9999
end if
call psb_geall(y_check,desc_a,info)
! Gather final result
call psb_gather(y_single_global, y_single, desc_a, info, psb_root_)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error allocating y_check data structure"
write(psb_out_unit,'(A)') "Error in psb_gather routine"
goto 9999
end if
! y = alpha * x + beta * y
call psb_geaxpby(alpha,x,beta,y,desc_a,info)
call psb_gather(y_double_global, y_double, desc_a, info, psb_root_)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error in psb_geaxpby routine"
write(psb_out_unit,'(A)') "Error in psb_gather routine"
goto 9999
end if
! gather the result combining all the partial ones
call psb_gather(y_global, y, desc_a, info)
! Deallocate
9999 call psb_gefree(x_single, desc_a,info)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error gathering global vector y used for comparison"
goto 9999
write(psb_out_unit,'(A)') "Error in single precision vector x free routine"
end if
if(my_rank == psb_root_) then
! Make the root process be the one that saves everything on file
if(np == 1) then
! Check if output directory exists
inquire(file='serial/', exist=exists)
if(.not.exists) then
write(psb_out_unit,'(A)') "Error in psb_geaxpby_check routine, no single precision result is saved on file"
goto 9999
end if
output_file_name = "serial/"
else
! Check if output directory exists
inquire(file='parallel/', exist=exists)
if(.not.exists) then
write(psb_out_unit,'(A)') "Error in psb_geaxpby_check routine, no single precision result is saved on file"
goto 9999
end if
output_file_name = "parallel/"
end if
output_file_name = output_file_name // "sol_" // x_file(9:10) // "_" // y_file(9:10)
if(alpha == done) then
output_file_name = output_file_name // "_a1"
else if(alpha == -done) then
output_file_name = output_file_name // "_a2"
else if(alpha == dzero) then
output_file_name = output_file_name // "_a3"
end if
if(beta == done) then
output_file_name = output_file_name // "_b1.mtx"
else if(beta == -done) then
output_file_name = output_file_name // "_b2.mtx"
else if(beta == dzero) then
output_file_name = output_file_name // "_b3.mtx"
end if
! Read single precision result from file
call mm_array_read(y_check,info,filename=output_file_name)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error in mm_array_read for y_check data structure"
goto 9999
end if
! 5.96e-08 is 2^-24 (Single precision unit roundoff)
! 1.19e-07 is 2^-23 (Single precision unit interval)
do i=1, arr_size
!! write(*, *) abs(y_global(i) - y_check%v%v(i)) > 5.96D-08, &
!! & y_global(i), y_check%v%v(i), output_file_name
if(abs(y_global(i) - y_check%v%v(i)) > 1.19e-07) then
ret = -i
write(psb_out_unit, '(A,F10.8)') "Y computed in double precision: ", y_global(i)
write(psb_out_unit, '(A,F10.8)') "Y read from single precision file: ", y_check%v%v(i)
write(psb_out_unit, '(A,F10.8)') "Diff: ", abs(y_global(i) - y_check%v%v(i))
exit
end if
end do
end if
! Deallocate
call psb_gefree(x, desc_a,info)
call psb_gefree(y_single, desc_a,info)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error in vector x free routine"
goto 9999
write(psb_out_unit,'(A)') "Error in single precision vector y free routine"
end if
call psb_gefree(y, desc_a,info)
call psb_gefree(x_double, desc_a,info)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error in vector y free routine"
goto 9999
write(psb_out_unit,'(A)') "Error in double precision vector x free routine"
end if
call psb_gefree(y_check, desc_a,info)
call psb_gefree(y_double, desc_a,info)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error in vector y_check free routine"
goto 9999
write(psb_out_unit,'(A)') "Error in double precision vector y free routine"
end if
call psb_cdfree(desc_a,info)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error in matrix descriptor free routine"
goto 9999
end if
if(my_rank == 0) then
deallocate(x_global)
deallocate(y_global)
deallocate(x_single_global)
deallocate(x_double_global)
end if
ret = 0
return
! Error handling
9999 ret = -1
stop
end subroutine
end program main

@ -8,7 +8,7 @@ include $(INCDIR)/Make.inc.psblas
LIBDIR = $(INSTALLDIR)/lib/
PSBLAS_LIB = -L$(LIBDIR) -lpsb_util -lpsb_base
LDLIBS = $(PSBLDLIBS)
EXEDIR = runs
EXEDIR = ./runs
FINCLUDES=$(FMFLAG)$(MODDIR) $(FMFLAG).
@ -30,7 +30,6 @@ psb_gedot_test:
@$(FLINK) $(LOPT) psb_gedot_test.f90 ../utils/psb_test_utils.o -o $(EXEDIR)/psb_gedot_test -I../utils/ -I$(MODDIR) -I. $(PSBLAS_LIB) $(LDLIBS)
@printf "$(BLUE)[INFO]\t Testing files for psb_gedot linked and compiled correctly$(END_COLOUR)\n"
clean:
@rm -f $(OBJS)\
*$(.mod) $(EXEDIR)/psb_gedot_test

@ -46,7 +46,7 @@ The strategy to validate the correctness of the computation is to compare single
## TODO
List of things still to add in the test:
- Add computation with broken descriptor and catch the errore result
- Add computation with broken descriptor and catch the errore result (Use EXCECUTE_COMMAND_LINE from a fortran program and check the exit codes)
- Test using complex data ($dot \leftarrow x^H \cdot y$)
- Test also GPU excecution
- Try multiple distributions

@ -1,9 +1,6 @@
#!/bin/bash
# Variables definition
dir1="serial"
dir2="parallel"
log_file_name="psblas_gedot_test.log"
num_procs=$(nproc)
# Define color codes
@ -37,24 +34,7 @@ echo -e "${BLUE}[INFO]\t Starting $num_procs processes computation${RESET}"
mpirun -np $num_procs ./runs/psb_gedot_test
echo -e "${BLUE}[INFO]\t Multiple processes computation terminated correctly${RESET}"
rm results/*
rm -r results/
# echo "" >> ${log_file_name}
# Iterate through files in the first directory
# for file1 in "$dir1"/*; do
# filename=$(basename "$file1") # Extract the filename
# file2="$dir2/$filename" # Construct the path for the second directory
#
# # Check if the file exists in the second directory
# if [ -f "$file2" ]; then
# diff_count=$(diff "$file1" "$file2" | wc -l) # Compare the files
# echo "Comparison between $file1 and $file2: $diff_count differences" >> ${log_file_name}
# else
# echo -e "${RED}[ERROR] File $filename does not exist in $dir2${RESET}"
# fi
# done
rm -f results/*
rm -f -r results/
echo -e "${GREEN}[INFO]\t PSBLAS psb_gedot test succesfully completed.${RESET}"

@ -123,13 +123,11 @@ program main
!! Initialize test metadata
test_info%total_tests = size(x) * size(y) * size(global)
test_info%threshold_type = GAMMA
test_info%threshold = 1.0D-06
test_info%kernel_name = "psb_gedot"
call psb_test_init(test_info)
test_info%threshold = 1.0D-06
if(test_info%my_rank == psb_root_) then
psb_out_unit = test_info%output_unit
call psb_test_generate_input_vectors(arr_size)
@ -157,7 +155,7 @@ program main
! a single process
call psb_test_process_check(result_single, test_info)
else
call psb_test_single_double_check(result_single,result_double,test_info, arr_size)
call psb_test_single_double_scalar_check(result_single,result_double,test_info, arr_size)
! If the program is being run on a single process, we can save the result directly
call psb_test_save_result(result_single, test_info)
@ -333,32 +331,27 @@ contains
9999 call psb_gefree(x_single, desc_a,info)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error in single precision vector x free routine"
goto 9999
end if
call psb_gefree(y_single, desc_a,info)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error in single precision vector y free routine"
goto 9999
end if
call psb_gefree(x_double, desc_a,info)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error in double precision vector x free routine"
goto 9999
end if
call psb_gefree(y_double, desc_a,info)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error in double precision vector y free routine"
goto 9999
end if
call psb_cdfree(desc_a,info)
if(info /= psb_success_) then
write(psb_out_unit,'(A)') "Error in matrix descriptor free routine"
goto 9999
end if
if(my_rank == 0) then
@ -368,8 +361,6 @@ contains
deallocate(y_double_global)
end if
return
end subroutine
end program main

@ -159,55 +159,98 @@ contains
close(unit, iostat=info)
end subroutine
!> @brief Subroutine to save the result of a single precision vector computation
!! to a file in the results directory.
!! @param result_single The single precision vector result to be saved.
!! @param test_info The test information structure containing the current test count.
!!
subroutine psb_test_save_vector_result(result_single, test_info)
type(psb_test_info), intent(inout) :: test_info
real(psb_spk_), allocatable,intent(in) :: result_single(:)
integer(psb_ipk_) :: info, unit
character(len=32) :: filename
logical :: exists
! Check if results directory exists
inquire(file='results/', exist=exists)
if (.not.exists) then
call system('mkdir results/')
end if
! Set the filename based on the test count
write(filename, '(A,I0,A)') 'results/result_', test_info%current_test, '.txt'
! Open the file for writing
open(newunit=unit, file=trim(filename), status='replace', action='write', iostat=info)
! Check if the file was opened successfully
if (info /= 0) then
write(*, '(A,I0)') "Error opening result file: ", info
return
end if
! Close the file
close(unit, iostat=info)
! Write the result to the file
call mm_array_write(result_single,"",info,filename=filename)
if (info /= 0) then
write(*, '(A,I0)') "Error writing result file: ", info
return
end if
end subroutine
!> @brief Subroutine to shift the decimal point of a single precision number
!! and count the number of digits in the integer part.
!!
!! @param num The single precision number whose decimal point is to be shifted.
!! @param int_digits The integer to store the number of digits in the integer part.
!!
subroutine shift_decimal_double(num, int_digits)
real(psb_dpk_),intent(inout) :: num
integer(psb_ipk_), intent(out) :: int_digits
integer(psb_ipk_) :: n_digits
character(len=20) :: int_str
!! @return shifted_num The single precision number with the decimal point shifted.
!!
function shift_decimal_double(num) result(shifted_num)
real(psb_dpk_) :: num, shifted_num
integer(psb_ipk_) :: n_digits
character(len=20) :: int_str
! Convert the absolute value of the integer part to string
write(int_str, '(I0)') int(abs(num))
! Count number of digits
int_digits = int(floor(log10(abs(num)))) + 1
! int_digits = int(floor(log10(abs(num)))) + 1
n_digits = len_trim(adjustl(int_str))
! Shift the decimal point
num = abs(num) / 10.0**n_digits
shifted_num = abs(num) / 10.0**n_digits
end subroutine
end function shift_decimal_double
!> @brief Subroutine to shift the decimal point of a single precision number
!! and count the number of digits in the integer part.
!> @brief Function to shift the decimal point of a single precision number.
!!
!! @param num The single precision number whose decimal point is to be shifted.
!! @param int_digits The integer to store the number of digits in the integer part.
!!
subroutine shift_decimal_single(num, int_digits)
real(psb_spk_),intent(inout) :: num
integer(psb_ipk_), intent(out) :: int_digits
integer(psb_ipk_) :: n_digits
character(len=20) :: int_str
!! @return shifted_num The single precision number with the decimal point shifted.
!!
function shift_decimal_single(num) result(shifted_num)
real(psb_spk_) :: num, shifted_num
integer(psb_ipk_) :: n_digits
character(len=20) :: int_str
! Convert the absolute value of the integer part to string
write(int_str, '(I0)') int(abs(num))
! Count number of digits
int_digits = int(floor(log10(abs(num)))) + 1
! int_digits = int(floor(log10(abs(num)))) + 1
n_digits = len_trim(adjustl(int_str))
! Shift the decimal point
num = abs(num) / 10.0**n_digits
shifted_num = abs(num) / 10.0**n_digits
end subroutine
end function shift_decimal_single
!> @brief Function to validate the test information structure.
@ -220,21 +263,32 @@ contains
!!
subroutine psb_test_validate(result_single, result_double, test_info, arr_size, pass)
type(psb_test_info), intent(inout) :: test_info
real(psb_spk_), intent(inout) :: result_single
real(psb_dpk_), intent(inout) :: result_double
real(psb_spk_), intent(in) :: result_single
real(psb_dpk_), intent(in) :: result_double
integer(psb_ipk_), intent(in) :: arr_size
logical, intent(inout) :: pass
integer(psb_ipk_) :: int_digits, n
real(psb_spk_) :: local_single
real(psb_dpk_) :: local_double
integer(psb_ipk_) :: n
real(psb_dpk_) :: gamma_n, unit_roundoff, delta, rel_err
unit_roundoff = 5.96D-08 !! 1.11D-16
delta = abs(result_double - real(result_single,psb_dpk_))
rel_err = delta / abs(real(result_single,psb_dpk_))
n = (arr_size / test_info%np) + (test_info%np - 1)
!! call shift_decimal_double(delta,int_digits)
! write(psb_out_unit,'(A,F20.10)') "Computed delta: ", delta
if(test_info%threshold_type == VALUE) then
! Lower down values in order to match threshold for absolute error check
local_single = shift_decimal_single(result_single)
local_double = shift_decimal_double(result_double)
delta = abs(result_double - real(result_single,psb_dpk_))
if(delta < test_info%threshold) then
pass = .true.
else
@ -279,7 +333,7 @@ contains
!! @param test_info The test information structure containing the threshold and logging details.
!! @param arr_size The size of the array used in the computation.
!!
subroutine psb_test_single_double_check(result_single, result_double, test_info, arr_size)
subroutine psb_test_single_double_scalar_check(result_single, result_double, test_info, arr_size)
type(psb_test_info), intent(inout) :: test_info
real(psb_spk_), intent(inout) :: result_single
real(psb_dpk_), intent(inout) :: result_double
@ -303,10 +357,49 @@ contains
end if
write(psb_out_unit,'(A,F20.10)') "Single precision result: ", result_single
write(psb_out_unit,'(A,F20.10)') "Double precision result: ", result_double
write(psb_out_unit,'(A,F20.10)') "Computed delta: ", delta
write(psb_out_unit,'(A,F20.10)') "Threshold used: ", test_info%threshold
end subroutine
!> @brief Subroutine to check the results of a single and double precision vector computation.
!! It compares the results element-wise and logs the outcome.
!! @param result_single The single precision vector result to be checked.
!! @param result_double The double precision vector result to be checked.
!! @param test_info The test information structure containing the threshold and logging details.
!! @param arr_size The size of the array used in the computation.
!!
subroutine psb_test_single_double_vector_check(result_single, result_double, test_info, arr_size)
type(psb_test_info), intent(inout) :: test_info
real(psb_spk_), allocatable, intent(inout) :: result_single(:)
real(psb_dpk_), allocatable, intent(inout) :: result_double(:)
real(psb_dpk_) :: delta
integer(psb_ipk_) :: int_digits, arr_size, i
logical :: pass
character(len=64) :: out_string
out_string = "Double precision check: "
pass = .true.
call psb_test_progress_bar(test_info)
do i = 1, size(result_single)
call psb_test_validate(result_single(i), result_double(i), test_info, arr_size, pass)
if(pass .eqv. .false. ) exit
end do
if(pass .eqv. .true.) then
call psb_test_log_passed(test_info, out_string)
test_info%success = test_info%success + 1
else
call psb_test_log_failed(test_info, out_string)
test_info%failure = test_info%failure + 1
write(psb_out_unit,'(A,F20.10)') "Comparison error occurred at index: ", i
write(psb_out_unit,'(A,F20.10)') "Single precision result: ", result_single(i)
write(psb_out_unit,'(A,F20.10)') "Double precision result: ", result_double(i)
end if
! write(psb_out_unit,'(A,F20.10)') "Threshold used: ", test_info%threshold
end subroutine
!> @brief Subroutine to check the global and local results of a single precision computation.
!! It compares the global result with the local result and logs the outcome.
!!
@ -345,13 +438,14 @@ contains
subroutine psb_test_process_check(result_single, test_info)
real(psb_spk_), intent(inout) :: result_single
type(psb_test_info), intent(inout) :: test_info
real(psb_spk_) :: saved_result
integer(psb_ipk_) :: unit, info, file_size, int_digits
real(psb_spk_) :: saved_result, local_saved, local_single
integer(psb_ipk_) :: unit, info, file_size
character(len=32) :: filename
logical :: exists
character(len=64) :: out_string
out_string = "Multiprocess check: "
call psb_test_progress_bar(test_info)
! Set the filename based on the test count
write(filename, '(A,I0,A)') 'results/result_', test_info%current_test, '.txt'
@ -379,11 +473,11 @@ contains
! Close the file
close(unit, iostat=info)
call shift_decimal_single(saved_result,int_digits)
call shift_decimal_single(result_single,int_digits)
local_saved = shift_decimal_single(saved_result)
local_single = shift_decimal_single(result_single)
! Compare the saved result with the new result_single
if (abs(saved_result - result_single) <= test_info%threshold) then
if (abs(local_saved - local_single) <= test_info%threshold) then
call psb_test_log_passed(test_info, out_string)
test_info%success = test_info%success + 1
else
@ -391,11 +485,92 @@ contains
test_info%failure = test_info%failure + 1
end if
write(test_info%output_unit, '(F20.10,F20.10,A,L,A,L)') &
& saved_result - result_single, result_single - saved_result, " ", saved_result - result_single == 0, &
& " ", result_single - saved_result == 0
write(test_info%output_unit, '(A,F20.10)') "Multi-process result: ", result_single
write(test_info%output_unit, '(A,F20.10)') "Single process result: ", saved_result
& local_saved - local_single, local_single - local_saved, " ", local_saved - local_single == 0, &
& " ", local_single - local_saved == 0
write(test_info%output_unit, '(A,F20.10)') "Multi-process result: ", local_single
write(test_info%output_unit, '(A,F20.10)') "Single process result: ", local_saved
end subroutine
subroutine psb_test_process_vector_check(result_single, test_info)
real(psb_spk_), allocatable, intent(inout) :: result_single(:)
type(psb_test_info), intent(inout) :: test_info
real(psb_spk_), allocatable :: saved_result(:)
integer(psb_ipk_) :: unit, info, file_size, int_digits, i
character(len=32) :: filename
logical :: exists, pass
character(len=64) :: out_string
out_string = "Multiprocess check: "
pass = .true.
call psb_test_progress_bar(test_info)
! Set the filename based on the test count
write(filename, '(A,I0,A)') 'results/result_', test_info%current_test, '.txt'
! Check if the file exists
inquire(file=trim(filename), exist=exists)
if (.not.exists) then
write(test_info%output_unit, '(A)') "Error: Result file does not exist."
write(test_info%output_unit, '(A)') "Please ensure the single process test is run first to generate the result file."
call psb_test_exit(test_info)
end if
! Open the file for reading
open(newunit=unit, file=trim(filename), status='old', action='read', iostat=info)
! Check if the file was opened successfully
if (info /= 0) then
write(*, '(A,I0)') "Error opening result file: ", info
call psb_test_exit(test_info)
end if
! Close the file
close(unit, iostat=info)
! Read the saved result
call mm_array_read(saved_result, info, filename=trim(filename))
if (info /= 0) then
write(*, '(A,I0)') "Error reading result file: ", info
call psb_test_exit(test_info)
end if
do i = 1, size(result_single)
! call shift_decimal_single(saved_result(i),int_digits)
! call shift_decimal_single(result_single(i),int_digits)
! Compare the saved result with the new result_single
if (abs(saved_result(i) - result_single(i)) > test_info%threshold) then
pass = .false.
write(psb_out_unit,'(A,I0)') "Comparison error occurred at index: ", i
write(test_info%output_unit, '(F20.10,F20.10,A,L,A,L)') &
& saved_result(i) - result_single(i), result_single(i) - saved_result(i), " ", &
& saved_result(i) - result_single(i) == 0, " ", result_single(i) - saved_result(i) == 0
write(test_info%output_unit, '(A,F20.10)') "Multi-process result: ", result_single(i)
write(test_info%output_unit, '(A,F20.10)') "Single process result: ", saved_result(i)
exit
end if
end do
if(pass .eqv. .true.) then
call psb_test_log_passed(test_info, out_string)
test_info%success = test_info%success + 1
else
call psb_test_log_failed(test_info, out_string)
test_info%failure = test_info%failure + 1
end if
end subroutine
end module psb_test_utils
Loading…
Cancel
Save