diff --git a/test/computational_routines/README.md b/test/computational_routines/README.md index db72c24a..e6aec7a0 100644 --- a/test/computational_routines/README.md +++ b/test/computational_routines/README.md @@ -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 [1]. Higham, Nicholas J. Testing linear algebra software. Springer US, 1997 diff --git a/test/computational_routines/backlog.txt b/test/computational_routines/backlog.txt index 5ea67657..6ae68b7e 100644 --- a/test/computational_routines/backlog.txt +++ b/test/computational_routines/backlog.txt @@ -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) diff --git a/test/computational_routines/geaxpby/Makefile b/test/computational_routines/geaxpby/Makefile index b4ebb57b..1307040b 100644 --- a/test/computational_routines/geaxpby/Makefile +++ b/test/computational_routines/geaxpby/Makefile @@ -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)\ diff --git a/test/computational_routines/geaxpby/README.md b/test/computational_routines/geaxpby/README.md index 797abc70..ee7b9e63 100644 --- a/test/computational_routines/geaxpby/README.md +++ b/test/computational_routines/geaxpby/README.md @@ -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 \ No newline at end of file +- Try using a matrix instead of a vector diff --git a/test/computational_routines/geaxpby/autotest.sh b/test/computational_routines/geaxpby/autotest.sh index be4444a9..562c189c 100755 --- a/test/computational_routines/geaxpby/autotest.sh +++ b/test/computational_routines/geaxpby/autotest.sh @@ -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}" diff --git a/test/computational_routines/geaxpby/geaxpby.f90 b/test/computational_routines/geaxpby/geaxpby.f90 deleted file mode 100644 index a07c797c..00000000 --- a/test/computational_routines/geaxpby/geaxpby.f90 +++ /dev/null @@ -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 \ No newline at end of file diff --git a/test/computational_routines/geaxpby/psb_geaxpby_test.f90 b/test/computational_routines/geaxpby/psb_geaxpby_test.f90 index 1c0794d2..28382655 100644 --- a/test/computational_routines/geaxpby/psb_geaxpby_test.f90 +++ b/test/computational_routines/geaxpby/psb_geaxpby_test.f90 @@ -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 diff --git a/test/computational_routines/gedot/Makefile b/test/computational_routines/gedot/Makefile index f59d5c8a..0fbeed0c 100644 --- a/test/computational_routines/gedot/Makefile +++ b/test/computational_routines/gedot/Makefile @@ -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 diff --git a/test/computational_routines/gedot/README.md b/test/computational_routines/gedot/README.md index e72ff67d..7bdbb0eb 100644 --- a/test/computational_routines/gedot/README.md +++ b/test/computational_routines/gedot/README.md @@ -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 \ No newline at end of file diff --git a/test/computational_routines/gedot/autotest.sh b/test/computational_routines/gedot/autotest.sh index fd102259..57c734e5 100755 --- a/test/computational_routines/gedot/autotest.sh +++ b/test/computational_routines/gedot/autotest.sh @@ -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}" \ No newline at end of file diff --git a/test/computational_routines/gedot/psb_gedot_test.f90 b/test/computational_routines/gedot/psb_gedot_test.f90 index 02320bc8..d13f25fe 100644 --- a/test/computational_routines/gedot/psb_gedot_test.f90 +++ b/test/computational_routines/gedot/psb_gedot_test.f90 @@ -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 \ No newline at end of file diff --git a/test/computational_routines/utils/psb_test_utils.f90 b/test/computational_routines/utils/psb_test_utils.f90 index c8280596..809d6f64 100644 --- a/test/computational_routines/utils/psb_test_utils.f90 +++ b/test/computational_routines/utils/psb_test_utils.f90 @@ -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 \ No newline at end of file