diff --git a/BLACS/INSTALL/CMakeLists.txt b/BLACS/INSTALL/CMakeLists.txt index d6c027e6..1e19bcb0 100644 --- a/BLACS/INSTALL/CMakeLists.txt +++ b/BLACS/INSTALL/CMakeLists.txt @@ -1,5 +1,5 @@ ##Copyright (C) 2021, Advanced Micro Devices, Inc. All rights reserved.## -cmake_minimum_required(VERSION 3.0) +cmake_minimum_required(VERSION 3.22) project(INSTALL C Fortran) if (UNIX) diff --git a/BLACS/TESTING/CMakeLists.txt b/BLACS/TESTING/CMakeLists.txt index 20e49bf3..4e4d499c 100644 --- a/BLACS/TESTING/CMakeLists.txt +++ b/BLACS/TESTING/CMakeLists.txt @@ -1,4 +1,4 @@ -##Copyright (C) 2021, Advanced Micro Devices, Inc. All rights reserved.## +##Copyright (C) 2021-2024, Advanced Micro Devices, Inc. All rights reserved.## set(FTestObj blacstest.f btprim.f tools.f) @@ -6,19 +6,56 @@ if ("${CMAKE_Fortran_COMPILER_ID}" STREQUAL "GNU" AND CMAKE_Fortran_COMPILER_VER set_source_files_properties(blacstest.f PROPERTIES COMPILE_FLAGS "-std=legacy") endif() -add_executable(xFbtest ${FTestObj}) -target_link_libraries(xFbtest scalapack) +# SCALAPACK_BUILD_SOURCE flag determines whether to compile the source code. If this of OFF we need to linked pre-compiled +# ScaLAPACK library. +if(SCALAPACK_BUILD_SOURCE STREQUAL "OFF") + if(UNIX) + if(BUILD_SHARED_LIBS) + add_library(scalapack SHARED IMPORTED) + set_target_properties(scalapack PROPERTIES + IMPORTED_LOCATION "${SCALAPACK_LIBRARY_PATH}/libscalapack.so" + ) + else() + add_library(scalapack STATIC IMPORTED) + set_target_properties(scalapack PROPERTIES + IMPORTED_LOCATION "${SCALAPACK_LIBRARY_PATH}/libscalapack.a" + ) + endif() + custom_macros_for_each_scalapack_source (scalapack) + target_link_libraries( scalapack INTERFACE ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) + else(UNIX) + if(BUILD_SHARED_LIBS) + add_library(scalapack SHARED IMPORTED) + set_target_properties(scalapack PROPERTIES + IMPORTED_LOCATION "${SCALAPACK_LIBRARY_PATH}/scalapack.dll" + IMPORTED_IMPLIB "${SCALAPACK_LIBRARY_PATH}/scalapack.lib" + ) + else() + add_library(scalapack STATIC IMPORTED) + set_target_properties(scalapack PROPERTIES + IMPORTED_LOCATION "${SCALAPACK_LIBRARY_PATH}/scalapack.lib" + ) + endif() + target_link_libraries( scalapack INTERFACE ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES} ${MPI_LIBRARY}) + endif(UNIX) +endif() -set(CTestObj - Cbt.c) +# SCALAPACK_BUILD_TESTS flag determines whether to compile the test framework. +if(SCALAPACK_BUILD_TESTS) + add_executable(xFbtest ${FTestObj}) + target_link_libraries(xFbtest scalapack) -if (UNIX) + set(CTestObj + Cbt.c) + + if (UNIX) add_executable(xCbtest ${CTestObj} ${FTestObj}) target_link_libraries(xCbtest scalapack) -else () + else () add_library(CTestObj OBJECT Cbt.c) add_executable(xCbtest ${FTestObj}) target_link_libraries(xCbtest scalapack CTestObj) + endif () endif () if (UNIX) diff --git a/BUILD.md b/BUILD.md new file mode 100644 index 00000000..22faed39 --- /dev/null +++ b/BUILD.md @@ -0,0 +1,218 @@ +#AOCL-ScaLAPACK: +---------------- +AOCL-ScaLAPACK is a library of high-performance linear algebra routines for parallel distributed memory machines. +It can be used to solve linear systems, least squares problems, eigenvalue problems, and singular value problems. + +AOCL-ScaLAPACK is forked from upstream Netlib ScaLAPACK GitHub [repository](https://github.com/Reference-ScaLAPACK/scalapack). +This fork has ScaLAPACK optimized for AMD “Zen” core-based processors. It depends on external libraries BLAS and LAPACK. +For AMD CPUs, use of AOCL-BLIS, AOCL-libFLAME and AOCL-Utils is recommended. + +#Installation: +-------------- +1. Download the latest stable release from the Github repository GitHub URL: https://github.com/amd/aocl-scalapack +2. Install CMake on the machine where the sources are to be compiled. +3. Use the CMake based build system to compile and generate AOCL-ScaLAPACK library and test suite binary as + explained below for Linux® and Windows® platforms. + +#Building AOCL-ScaLAPACK from Source on Linux +--------------------------------------------- +#Prerequisites: +--------------- +Following are the prerequisite libraries for building AOCL-ScaLAPACK: +- AOCL-BLAS +- AOCL-LAPACK +- AOCL-Utils +- An MPI library (validated with OpenMPI library) + +#Build Instruction: +------------------- +1. Execute the command: + $ cd aocl-scalapack +2. CMake as follows: + a. Create a new directory. For example, build: + $ mkdir build + $ cd build + b. Export PATH and LD_LIBRARY_PATH to the lib and bin folders of the MPI installation + respectively: + $ export PATH=/bin:$PATH + $ export LD_LIBRARY_PATH=/lib:$LD_LIBRARY_PATH + c. Run cmake command based on the compiler and the type of library generation required. + + #Note: + ------ + 1. AOCL-LAPACK is dependent on the AOCL-Utils library, which in turn depends on + libstdc++. Hence, you must link with AOCL-Utils and libstdc++(-lstdc++) along with the + AOCL-LAPACK library while specifying the path for LAPACK_LIBRARIES in the CMake flags. + 2. OpenMPI library must be compiled with respective compiler either with GCC or AOCC + before building static or shared library. + 3. For ILP64 - use flag [-DENABLE_ILP64=ON] with below configuration, default is LP64 + + #Building static library using GCC/AOCC compiler: + ------------------------------------------------- + i) Single-thread-AOCL-BLAS: + $ cmake .. -DBUILD_SHARED_LIBS=OFF -DBLAS_LIBRARIES="-fopenmp /libblis.a" + -DLAPACK_LIBRARIES="/libflame.a;/libaoclutils.a;-lstdc++" + -DCMAKE_C_COMPILER=mpicc -DCMAKE_Fortran_COMPILER=mpif90 -DUSE_OPTIMIZED_LAPACK_BLAS=OFF + + ii)Multi-thread-AOCL-BLAS: + $ cmake .. -DBUILD_SHARED_LIBS=OFF -DBLAS_LIBRARIES="-fopenmp /libblis-mt.a" + -DLAPACK_LIBRARIES="/libflame.a;/libaoclutils.a;-lstdc++" + -DCMAKE_C_COMPILER=mpicc -DCMAKE_Fortran_COMPILER=mpif90 -DUSE_OPTIMIZED_LAPACK_BLAS=OFF + + #Building shared library using GCC/AOCC compiler: + ------------------------------------------------- + i) Single-thread-AOCL-BLAS: + $ cmake .. -DBUILD_SHARED_LIBS=ON -DBLAS_LIBRARIES="-fopenmp /libblis.so" + -DLAPACK_LIBRARIES="/libflame.so;/libaoclutils.so;-lstdc++" + -DCMAKE_C_COMPILER=mpicc -DCMAKE_Fortran_COMPILER=mpif90 -DUSE_OPTIMIZED_LAPACK_BLAS=OFF + + ii)Multi-thread-AOCL-BLAS: + $ cmake .. -DBUILD_SHARED_LIBS=ON -DBLAS_LIBRARIES="-fopenmp /libblis-mt.so" + -DLAPACK_LIBRARIES="/libflame.so;/libaoclutils.so;-lstdc++" + -DCMAKE_C_COMPILER=mpicc -DCMAKE_Fortran_COMPILER=mpif90 -DUSE_OPTIMIZED_LAPACK_BLAS=OFF + + #Static library with external BLACS library: + -------------------------------------------- + $ cmake .. -DBUILD_SHARED_LIBS=OFF -DBLAS_LIBRARIES="-fopenmp /libblis-mt.a" + -DLAPACK_LIBRARIES="/libflame.a;/libaoclutils.a;-lstdc++" + -DBLACS_LIBRARIES=/libBLACS.a -DCMAKE_C_COMPILER=mpicc -DCMAKE_Fortran_COMPILER=mpif90 + -DUSE_OPTIMIZED_LAPACK_BLAS=OFF + + #Static library with Intel MPI and ICC compiler: + ------------------------------------------------ + $ cmake .. -DBUILD_SHARED_LIBS=OFF -DBLAS_LIBRARIES="-fopenmp /libblis-mt.a" + -DLAPACK_LIBRARIES="/libflame.a;/libaoclutils.a;-lstdc++" + -DCMAKE_C_COMPILER=mpiicc -DCMAKE_Fortran_COMPILER=mpiifort -DUSE_OPTIMIZED_LAPACK_BLAS=OFF; + + d. Ensure CMake locates AOCL-LAPACK and AOCL-BLAS libraries. On completion, a message, “LAPACK routine dgesv is found: 1” + similar to the following in CMake output is displayed: + -- CHECKING BLAS AND LAPACK LIBRARIES + -- --> LAPACK supplied by user is /libflame.a. + -- --> LAPACK routine dgesv is found: 1. + -- --> LAPACK supplied by user is WORKING, will use /libflame.a. + -- BLAS library: /libblis.a + -- LAPACK library: /libflame.a + + e. Compile the code: + $ make -j + + #Note: On Linux, the inbuilt communications sub-module of AOCL-ScaLAPACK, called Basic Linear Algebra Communication Subprogram (BLACS), + exposes the API symbols in lower case with underscore format. + +#Building AOCL-ScaLAPACK from Source on Windows +----------------------------------------------- +#Prerequisites: +--------------- +Following are the prerequisite libraries for building AOCL-ScaLAPACK: +- AOCL-BLAS, AOCL-LAPACK and AOCL-Utils libraries +- Windows10/11 or Windows Server 2019/2022 +- LLVM 15/16 +- LLVM plug-in for Microsoft Visual Studio (if latest version of LLVM is installed separately, + this plug-in enables linking Microsoft Visual Studio with the installed LLVM toolchain) +- CMake versions 3.0 through 3.23.3 +- Intel MPI compiler +- Microsoft Visual Studio 2019 (build 16.8.7) through 2022 (build 17.3.2) +- Microsoft Visual Studio tools + - Python development + - Desktop development with C++: C++ Clang-Cl for v142 build tool (x64 or x86) + +#Build Instruction +------------------ +1. Preparing and Building Project with CMake GUI: + + a. Set the source (folder containing aocl-scalapack source code) and build (folder in which the + project files will be generated, for example, out) folder paths. It is not recommended to use the + folder named build as a folder with that name exists at the top of AOCL-LAPACK source tree. + b. Click on the Configure button to prepare the project options. + c. Set the generator to Visual Studio 17 2022 and the compiler to ClangCl or LLVM. + d. Select the available and recommended options in CMake GUI. + e. Click the Generate button and then Open Project. + f. Open the project generated by CMake (build folder) in (Point#a) + g. To generate the AOCL-ScaLAPACK binaries, build the ScaLAPACK project. The library files would be + generated in the folder /out based on the project settings. + +2. Configuring and Building Project with Command-line Arguments: + + a. In the ScaLAPACK project folder, create a folder out. + $ cd aocl-scalapack + $ mkdir out + b. Open the command prompt in out directory and run the following command: + $ cd out + $ cmake -S .. -B . -G "Visual Studio 17 2022" -DCMAKE_BUILD_TYPE=Release -DBUILD_SHARED_LIBS=ON + -DCDEFS=UpCase -DBUILD_STATIC_LIBS=OFF -DBLAS_LIBRARIES="/AOCLLibBlis-Win-MT-dll.lib" + -DLAPACK_LIBRARIES="/AOCL-LibFLAME-Win-MT-dll.lib;/libaoclutils.lib + c. Open command prompt in the aocl-scalapack/out directory. + $ cd aocl-scalapack/out + d. Invoke CMake with the build command and release or debug option. + $ cmake --build . --config Release + + e. The library files would be generated inside /out/Release or /out/Debug folder, based on the project settings. + + #Example: + aocl-scalapack/out/lib/Release/scalapack.lib + aocl-scalapack/out/Testing/Release/scalapack.dll + + #Note: On Windows, the inbuilt communications submodule of ScaLAPACK, called Basic Linear Algebra Communication Subprograms(BLACS), + exposes the API symbols in upper case without underscore format. + +#Additional Library Build Options +--------------------------------- +Use the following additional options to configure your build: + +Option | Description +------------------------------------|-------------------------------------------------------------------------------------------------------------- +ENABLE_ILP64 | Enable ILP64 build (Disabled by default) +ENABLE_DTL | Enable Trace and Log feature (Disabled by default) +ENABLE_AOCL_PROGRESS | Enable AOCL Progress feature which check how far a computation has progressed through a callback + function for 3 major factorization APIs (LU, QR, Cholesky ) for all data type variants (Disabled by default) +ENABLE_DRIVER_CHECK | This flag specifies whether to enable checking for negative inputs and early return test cases from the driver file or ScaLAPACK API. (Disabled by default) +ENABLE_ASAN_TESTS | Enable Address sanitizer tests feature (Disabled by default) +ENABLE_COVERAGE | Enable code coverage feature (Disabled by default) +ENABLE_SET_LIB_VERSION | Include build number in the version string (Disabled by default) +ENABLE_LARGE_MATRIX_TESTING | Dynamic allocation of work buffer memory in test code, which is helpful to test larger matrix + sizes more than 2K (Disabled by default) +CDEFS | Enable Fortran to C Name Mangling build option types i.e., Naming strategy needed for a fortran routine + to call a C routine. + Supported values: -DCDEFS=UpCase/NoChange/Add_ + Windows default: -DCDEFS=UpCase + Linux default: -DCDEFS=Add_ +SCALAPACK_BUILD_SOURCE | This flag specifies whether to compile the ScaLAPACK source files and build the ScaLAPACK library (Enabled by default) +SCALAPACK_BUILD_TESTS | This flag specifies whether to compile and build the ScaLAPACK test framework (Enabled by default) +SCALAPACK_LIBRARY_PATH | This flag specifies the path to the ScaLAPACK library when -DSCALAPACK_BUILD_SOURCE=OFF + -DSCALAPACK_LIBRARY_PATH="/home/amd/shared" (this is an example, path can be anything) + +#Enabling DTL at run-time +# To enables the log file, trace file and progress feature at run time in Linux use below command: +- export AOCL_SL_LOG=1 +- export AOCL_SL_TRACE=1 +- export AOCL_SL_PROGRESS=1 + +# To enables the log file, trace file and progress feature at run time in Windows use below command: +- set AOCL_SL_LOG=1 +- set AOCL_SL_TRACE=1 +- set AOCL_SL_PROGRESS=1 + +#Running Test Application On Linux: +----------------------------------- +The test application binaries are generated in the /build/TESTING folder. +You can find the applications demonstrating the usage of ScaLAPACK APIs in the TESTING +directory of ScaLAPACK source package + +#Example: +$ cd aocl-scalapack/TESTING +$ mpirun -np 4 ./xdlu + +#Running Test Application On Windows: +------------------------------------- +The test application binaries are generated in the folder /out/Testing/Release or +/out/Testing/Debug based on the project settings. Run the tests from the command +prompt as follows: + +#Example: +$ cd aocl-scalapack/out/Testing/Release +$ mpiexec -np 4 xdlu.exe + +#CONTACTS +--------- +AOCL-ScaLAPACK is developed and maintained by AMD. +For support, send an email to toolchainsupport@amd.com. diff --git a/CMakeLists.txt b/CMakeLists.txt index 01b258d5..9a7e0c65 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -1,6 +1,6 @@ -##Copyright (C) 2021-2023, Advanced Micro Devices, Inc. All rights reserved.## +##Copyright (C) 2021-2024, Advanced Micro Devices, Inc. All rights reserved.## -cmake_minimum_required(VERSION 3.2) +cmake_minimum_required(VERSION 3.22) project(SCALAPACK C Fortran) # Configure the warning and code coverage suppression file configure_file( @@ -32,6 +32,9 @@ option(ENABLE_AOCL_PROGRESS "Enable progress feature " OFF) # DTL option option(ENABLE_DTL "Enable DTL feature " OFF) +# Driver check option +option(ENABLE_DRIVER_CHECK "Enable driver check feature " OFF) + # ASAN testing option option(ENABLE_ASAN_TESTS "Enable Address sanitizer tests " OFF) @@ -117,7 +120,7 @@ endif () # -# MPI +# MPI # #set(MPI_BASE_DIR "/Users/julie/opt/openmpi/" CACHE PATH "MPI Path") #set(MPI_BASE_DIR "/Users/julie/opt/mpich2/" CACHE PATH "MPI Path") @@ -246,6 +249,10 @@ if(ENABLE_DTL) add_definitions("-DAOCL_DTL ") ENDIF(ENABLE_DTL) +if(ENABLE_DRIVER_CHECK) + add_definitions("-DENABLE_DRIVER_CHECK") +ENDIF(ENABLE_DRIVER_CHECK) + if(ENABLE_ILP64) if(UNIX) if (("${CMAKE_Fortran_COMPILER_ID}" STREQUAL "Intel") AND ( "${CMAKE_Fortran_COMPILER}" MATCHES "ifort" ) ) @@ -437,6 +444,23 @@ if(WIN32 AND BUILD_SHARED_LIBS) set (CMAKE_WINDOWS_EXPORT_ALL_SYMBOLS ON) endif () +# Option to choose whether to compile the source code and the test framework. By default both are ON. +option(SCALAPACK_BUILD_SOURCE "Build all source of the ScaLAPACK library" ON) +option(SCALAPACK_BUILD_TESTS "Build all tests of the ScaLAPACK library" ON) + +if(SCALAPACK_BUILD_SOURCE STREQUAL "OFF" AND SCALAPACK_BUILD_TESTS STREQUAL "ON") + if(NOT SCALAPACK_LIBRARY_PATH) + message (FATAL_ERROR "Please provide SCALAPACK_LIBRARY_PATH") + endif() +endif() + +# If user want to build ScaLAPACK source code, unset precompiled SCALAPACK_LIBRARY_PATH variable +if(SCALAPACK_BUILD_SOURCE STREQUAL "ON") + if(SCALAPACK_LIBRARY_PATH) + UNSET(SCALAPACK_LIBRARY_PATH CACHE) + endif() +endif() + if (UNIX) if(CUSTOM_BLACS_FOUND) add_library(scalapack ${dtl} ${framework} ${framework-C} ${tools} ${tools-C} ${extra_lapack} ${pblas} ${pblas-F} ${ptzblas} ${ptools} ${pbblas} ${redist} ${src} ${src-C}) @@ -444,10 +468,26 @@ if (UNIX) target_link_libraries( scalapack ${BLACS_LIBRARY} ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) scalapack_install_library(scalapack) else(CUSTOM_BLACS_FOUND) - add_library(scalapack ${dtl} ${framework} ${framework-C} ${blacs} ${tools} ${tools-C} ${extra_lapack} ${pblas} ${pblas-F} ${ptzblas} ${ptools} ${pbblas} ${redist} ${src} ${src-C}) - custom_macros_for_each_scalapack_source (scalapack) - target_link_libraries( scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) - scalapack_install_library(scalapack) + if(SCALAPACK_BUILD_SOURCE) + add_library(scalapack ${dtl} ${framework} ${framework-C} ${blacs} ${tools} ${tools-C} ${extra_lapack} ${pblas} ${pblas-F} ${ptzblas} ${ptools} ${pbblas} ${redist} ${src} ${src-C}) + custom_macros_for_each_scalapack_source (scalapack) + target_link_libraries( scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) + scalapack_install_library(scalapack) + else() + if(BUILD_SHARED_LIBS) + add_library(scalapack SHARED IMPORTED) + set_target_properties(scalapack PROPERTIES + IMPORTED_LOCATION "${SCALAPACK_LIBRARY_PATH}/libscalapack.so" + ) + else() + add_library(scalapack STATIC IMPORTED) + set_target_properties(scalapack PROPERTIES + IMPORTED_LOCATION "${SCALAPACK_LIBRARY_PATH}/libscalapack.a" + ) + endif() + custom_macros_for_each_scalapack_source (scalapack) + target_link_libraries( scalapack INTERFACE ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) + endif() endif(CUSTOM_BLACS_FOUND) if(ENABLE_COVERAGE) target_compile_options(scalapack PUBLIC -fprofile-arcs -ftest-coverage) @@ -463,11 +503,29 @@ else (UNIX) # Need to separate Fortran and C Code target_link_directories( scalapack PUBLIC ${CMAKE_IFORT_LIBDEPS_DIR}) scalapack_install_library(scalapack) else(CUSTOM_BLACS_FOUND) - add_library(scalapack-F OBJECT ${pblas-F} ${pbblas} ${ptzblas} ${tools} ${framework} ${src} ${extra_lapack} ) - add_library(scalapack $ ${blacs} ${tools-C} ${dtl} ${framework-C} ${pblas} ${ptools} ${redist} ${src-C}) - target_link_libraries( scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES} ${MPI_LIBRARY}) - target_link_directories( scalapack PUBLIC ${CMAKE_IFORT_LIBDEPS_DIR}) - scalapack_install_library(scalapack) + if(SCALAPACK_BUILD_SOURCE) + add_library(scalapack-F OBJECT ${pblas-F} ${pbblas} ${ptzblas} ${tools} ${framework} ${src} ${extra_lapack} ) + add_library(scalapack $ ${blacs} ${tools-C} ${dtl} ${framework-C} ${pblas} ${ptools} ${redist} ${src-C}) + target_link_libraries( scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES} ${MPI_LIBRARY}) + target_link_directories( scalapack PUBLIC ${CMAKE_IFORT_LIBDEPS_DIR}) + scalapack_install_library(scalapack) + else() + if(BUILD_SHARED_LIBS) + add_library(scalapack SHARED IMPORTED) + set_target_properties(scalapack PROPERTIES + IMPORTED_LOCATION "${SCALAPACK_LIBRARY_PATH}/scalapack.dll" + IMPORTED_IMPLIB "${SCALAPACK_LIBRARY_PATH}/scalapack.lib" + ) + file(COPY ${SCALAPACK_LIBRARY_PATH}/scalapack.dll + DESTINATION ${CMAKE_CURRENT_BINARY_DIR}/Testing/Release) + else() + add_library(scalapack STATIC IMPORTED) + set_target_properties(scalapack PROPERTIES + IMPORTED_LOCATION "${SCALAPACK_LIBRARY_PATH}/scalapack.lib" + ) + endif() + target_link_libraries( scalapack INTERFACE ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES} ${MPI_LIBRARY}) + endif() endif(CUSTOM_BLACS_FOUND) else (CMAKE_C_COMPILER_ID MATCHES Clang) # create C objects and add to scalapack library first @@ -480,18 +538,35 @@ else (UNIX) # Need to separate Fortran and C Code target_link_directories( scalapack PUBLIC ${CMAKE_IFORT_LIBDEPS_DIR}) scalapack_install_library(scalapack) else(CUSTOM_BLACS_FOUND) - add_library(scalapack-C OBJECT ${blacs} ${tools-C} ${dtl} ${framework-C} ${pblas} ${ptools} ${redist} ${src-C}) - target_link_libraries( scalapack-C ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES} ${MPI_LIBRARY}) - target_link_directories( scalapack-C PUBLIC ${CMAKE_IFORT_LIBDEPS_DIR}) - add_library(scalapack $ ${pblas-F} ${pbblas} ${ptzblas} ${tools} ${framework} ${src} ${extra_lapack} ) - target_link_libraries( scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES} ${MPI_LIBRARY}) - target_link_directories( scalapack PUBLIC ${CMAKE_IFORT_LIBDEPS_DIR}) - scalapack_install_library(scalapack) + if(SCALAPACK_BUILD_SOURCE) + add_library(scalapack-C OBJECT ${blacs} ${tools-C} ${dtl} ${framework-C} ${pblas} ${ptools} ${redist} ${src-C}) + target_link_libraries( scalapack-C ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES} ${MPI_LIBRARY}) + target_link_directories( scalapack-C PUBLIC ${CMAKE_IFORT_LIBDEPS_DIR}) + add_library(scalapack $ ${pblas-F} ${pbblas} ${ptzblas} ${tools} ${framework} ${src} ${extra_lapack} ) + target_link_libraries( scalapack ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES} ${MPI_LIBRARY}) + target_link_directories( scalapack PUBLIC ${CMAKE_IFORT_LIBDEPS_DIR}) + scalapack_install_library(scalapack) + else() + if(BUILD_SHARED_LIBS) + add_library(scalapack SHARED IMPORTED) + set_target_properties(scalapack PROPERTIES + IMPORTED_LOCATION "${SCALAPACK_LIBRARY_PATH}/scalapack.dll" + IMPORTED_IMPLIB "${SCALAPACK_LIBRARY_PATH}/scalapack.lib" + ) + file(COPY ${SCALAPACK_LIBRARY_PATH}/scalapack.dll + DESTINATION ${CMAKE_CURRENT_BINARY_DIR}/Testing/Release) + else() + add_library(scalapack STATIC IMPORTED) + set_target_properties(scalapack PROPERTIES + IMPORTED_LOCATION "${SCALAPACK_LIBRARY_PATH}/scalapack.lib" + ) + endif() + target_link_libraries( scalapack INTERFACE ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES} ${MPI_LIBRARY}) + endif() endif(CUSTOM_BLACS_FOUND) endif () endif (UNIX) -option(SCALAPACK_BUILD_TESTS "Build all tests of the ScaLAPACK library" ON) if(${SCALAPACK_BUILD_TESTS}) add_subdirectory(TESTING) endif() @@ -527,8 +602,9 @@ INCLUDE(CPack) # -------------------------------------------------- - +if(SCALAPACK_BUILD_SOURCE) export(TARGETS scalapack FILE scalapack-targets.cmake) +endif() if( NOT LAPACK_FOUND ) install(FILES @@ -556,7 +632,8 @@ install(FILES DESTINATION lib/cmake/scalapack-${SCALAPACK_VERSION} ) -install(EXPORT scalapack-targets - DESTINATION lib/cmake/scalapack-${SCALAPACK_VERSION}) - + if(SCALAPACK_BUILD_SOURCE) + install(EXPORT scalapack-targets + DESTINATION lib/cmake/scalapack-${SCALAPACK_VERSION}) + endif() file(COPY scalapack_test.sh DESTINATION ${SCALAPACK_BINARY_DIR}) diff --git a/FRAMEWORK/cpu_features.c b/FRAMEWORK/cpu_features.c index 3819f142..a99975ad 100644 --- a/FRAMEWORK/cpu_features.c +++ b/FRAMEWORK/cpu_features.c @@ -134,6 +134,7 @@ __init_cpu_features(void) static unsigned initialized = 0; struct alc_cpu_mfg_info* mfg_info = &cpu_features.cpu_mfg_info; int arr_size = ARRAY_SIZE(__cpuid_values); + int i; if (initialized == INITIALIZED_MAGIC) return; struct alc_cpuid_regs regs; @@ -143,7 +144,7 @@ __init_cpu_features(void) && regs.edx == 0x69746e65) { cpu_features.cpu_mfg_info.mfg_type = ALC_CPU_MFG_AMD; } - for (int i = 0; i < arr_size; i++) { + for (i = 0; i < arr_size; i++) { struct alc_cpuid_regs ft; __cpuid_2(__cpuid_values[i].eax, __cpuid_values[i].ecx, &ft); cpu_features.available[i].eax = ft.eax; diff --git a/SRC/get_aocl_scalapack_version.c b/SRC/get_aocl_scalapack_version.c index 0e6c141f..8c6b6d71 100644 --- a/SRC/get_aocl_scalapack_version.c +++ b/SRC/get_aocl_scalapack_version.c @@ -1,9 +1,7 @@ - - /* --------------------------------------------------------------------- * * -- AOCL ScaLAPACK routine -- -* Copyright (c) 2020-2023 Advanced Micro Devices, Inc.  All rights reserved. +* Copyright (c) 2020-2024 Advanced Micro Devices, Inc.  All rights reserved. * * --------------------------------------------------------------------- */ @@ -27,7 +25,7 @@ void get_aocl_scalapack_version_( version ) #endif { #ifdef AOCL_SCALAPACK_VERSION - char slmainversion[] = "AOCL-ScaLAPACK 4.2.0 "; + char slmainversion[] = "AOCL-ScaLAPACK 5.0.0 "; char slversion[1000]; char scalapackversion[] = ", supports ScaLAPACK 2.2.0"; int length, i; @@ -52,7 +50,7 @@ void get_aocl_scalapack_version_( version ) slversion[length] = '\0'; strcpy(version, slversion); #else - strcpy(version, "AOCL-ScaLAPACK 4.2.0, supports ScaLAPACK 2.2.0"); + strcpy(version, "AOCL-ScaLAPACK 5.0.0, supports ScaLAPACK 2.2.0"); #endif return; } diff --git a/SRC/pcheev.f b/SRC/pcheev.f index 17682a32..bb14365f 100644 --- a/SRC/pcheev.f +++ b/SRC/pcheev.f @@ -1,11 +1,17 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCHEEV( JOBZ, UPLO, N, A, IA, JA, DESCA, W, Z, IZ, JZ, $ DESCZ, WORK, LWORK, RWORK, LRWORK, INFO ) * * -- ScaLAPACK routine (version 1.7) -- * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. -* August 14, 2001 +* August 14, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER JOBZ, UPLO INTEGER IA, INFO, IZ, JA, JZ, LRWORK, LWORK, N @@ -283,14 +289,48 @@ SUBROUTINE PCHEEV( JOBZ, UPLO, N, A, IA, JA, DESCA, W, Z, IZ, JZ, $ SQRT * .. * .. Executable Statements .. +* +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) JOBZ, UPLO, IA, INFO, IZ, JA, + $ JZ, LRWORK, LWORK, N, eos_str + 102 FORMAT('PCHEEV inputs: ,JOBZ:',A5,', UPLO:',A5, + $ ', IA:',I5,', INFO:',I5,', IZ:',I5, + $ ', JA:',I5,', JZ:',I5,', LRWORK:',I5, + $ ', LWORK:',I5,', N:',I5, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF * This is just to keep ftnchek and toolpack/1 happy IF( BLOCK_CYCLIC_2D*CSRC_*CTXT_*DLEN_*DTYPE_*LLD_*MB_*M_*NB_*N_* - $ RSRC_.LT.0 )RETURN + $ RSRC_.LT.0 )THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Quick return * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Test the input arguments. * @@ -499,10 +539,18 @@ SUBROUTINE PCHEEV( JOBZ, UPLO, N, A, IA, JA, DESCA, W, Z, IZ, JZ, CALL PXERBLA( DESCA( CTXT_ ), 'PCHEEV', -INFO ) IF( WANTZ ) $ CALL BLACS_GRIDEXIT( CONTEXTC ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 ) THEN IF( WANTZ ) $ CALL BLACS_GRIDEXIT( CONTEXTC ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -629,6 +677,10 @@ SUBROUTINE PCHEEV( JOBZ, UPLO, N, A, IA, JA, DESCA, W, Z, IZ, JZ, 50 CONTINUE RWORK( 1 ) = LRMIN * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCHEEV diff --git a/SRC/pcheevd.f b/SRC/pcheevd.f index 45f62bd7..e236626d 100644 --- a/SRC/pcheevd.f +++ b/SRC/pcheevd.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCHEEVD( JOBZ, UPLO, N, A, IA, JA, DESCA, W, Z, IZ, JZ, $ DESCZ, WORK, LWORK, RWORK, LRWORK, IWORK, $ LIWORK, INFO ) @@ -7,6 +12,7 @@ SUBROUTINE PCHEEVD( JOBZ, UPLO, N, A, IA, JA, DESCA, W, Z, IZ, JZ, * and University of California, Berkeley. * March 25, 2002 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER JOBZ, UPLO INTEGER IA, INFO, IZ, JA, JZ, LIWORK, LRWORK, LWORK, N @@ -203,16 +209,50 @@ SUBROUTINE PCHEEVD( JOBZ, UPLO, N, A, IA, JA, DESCA, W, Z, IZ, JZ, INTRINSIC CMPLX, ICHAR, MAX, MIN, MOD, REAL, SQRT * .. * .. Executable Statements .. +* +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) JOBZ, UPLO, IA, INFO, IZ, JA, + $ JZ, LIWORK, LRWORK, LWORK, N, eos_str + 102 FORMAT('PCHEEVD inputs: ,JOBZ:',A5,', UPLO:',A5, + $ ', IA:',I5,', INFO:',I5,', IZ:',I5, + $ ', JA:',I5,', JZ:',I5,', LIWORK:',I5, + $ ', LRWORK:',I5,', LWORK:',I5,', N:',I5, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF * This is just to keep ftnchek and toolpack/1 happy IF( BLOCK_CYCLIC_2D*CSRC_*CTXT_*DLEN_*DTYPE_*LLD_*MB_*M_*NB_*N_* - $ RSRC_.LT.0 )RETURN + $ RSRC_.LT.0 )THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * INFO = 0 * * Quick return * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Test the input arguments. * @@ -300,8 +340,16 @@ SUBROUTINE PCHEEVD( JOBZ, UPLO, N, A, IA, JA, DESCA, W, Z, IZ, JZ, * IF( INFO.NE.0 ) THEN CALL PXERBLA( DESCA( CTXT_ ), 'PCHEEVD', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -435,6 +483,10 @@ SUBROUTINE PCHEEVD( JOBZ, UPLO, N, A, IA, JA, DESCA, W, Z, IZ, JZ, RWORK( 1 ) = REAL( LRWMIN ) IWORK( 1 ) = LIWMIN * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCHEEVD diff --git a/SRC/pcheevr.f b/SRC/pcheevr.f index b04a2e5b..47300692 100644 --- a/SRC/pcheevr.f +++ b/SRC/pcheevr.f @@ -1,9 +1,15 @@ - SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* + SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, $ DESCA, VL, VU, IL, IU, M, NZ, W, Z, IZ, - $ JZ, DESCZ, + $ JZ, DESCZ, $ WORK, LWORK, RWORK, LRWORK, IWORK, LIWORK, $ INFO ) + USE LINK_TO_C_GLOBALS IMPLICIT NONE * * -- ScaLAPACK routine (version 2.0.2) -- @@ -12,7 +18,6 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, * * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO - INTEGER IA, IL, INFO, IU, IZ, JA, JZ, LIWORK, LRWORK, $ LWORK, M, N, NZ REAL VL, VU @@ -28,14 +33,14 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, * * PCHEEVR computes selected eigenvalues and, optionally, eigenvectors * of a complex Hermitian matrix A distributed in 2D blockcyclic format -* by calling the recommended sequence of ScaLAPACK routines. +* by calling the recommended sequence of ScaLAPACK routines. * * First, the matrix A is reduced to real symmetric tridiagonal form. * Then, the eigenproblem is solved using the parallel MRRR algorithm. * Last, if eigenvectors have been computed, a backtransformation is done. * * Upon successful completion, each processor stores a copy of all computed -* eigenvalues in W. The eigenvector matrix Z is stored in +* eigenvalues in W. The eigenvector matrix Z is stored in * 2D blockcyclic format distributed over all processors. * * For constructive feedback and comments, please contact cvoemel@lbl.gov @@ -67,7 +72,7 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, * A (local input/workspace) 2D block cyclic COMPLEX array, * global dimension (N, N), * local dimension ( LLD_A, LOCc(JA+N-1) ) -* (see Notes below for more detailed explanation of 2d arrays) +* (see Notes below for more detailed explanation of 2d arrays) * * On entry, the symmetric matrix A. If UPLO = 'U', only the * upper triangular part of A is used to define the elements of @@ -92,16 +97,16 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, * DESCA (global and local input) INTEGER array of dimension DLEN_. * (The ScaLAPACK descriptor length is DLEN_ = 9.) * The array descriptor for the distributed matrix A. -* The descriptor stores details about the 2D block-cyclic -* storage, see the notes below. +* The descriptor stores details about the 2D block-cyclic +* storage, see the notes below. * If DESCA is incorrect, PCHEEVR cannot work correctly. * Also note the array alignment requirements specified below * -* VL (global input) REAL +* VL (global input) REAL * If RANGE='V', the lower bound of the interval to be searched * for eigenvalues. Not referenced if RANGE = 'A' or 'I'. * -* VU (global input) REAL +* VU (global input) REAL * If RANGE='V', the upper bound of the interval to be searched * for eigenvalues. Not referenced if RANGE = 'A' or 'I'. * @@ -122,7 +127,7 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, * Total number of eigenvectors computed. 0 <= NZ <= M. * The number of columns of Z that are filled. * If JOBZ .NE. 'V', NZ is not referenced. -* If JOBZ .EQ. 'V', NZ = M +* If JOBZ .EQ. 'V', NZ = M * * W (global output) REAL array, dimension (N) * On normal exit, the first M entries contain the selected @@ -161,7 +166,7 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, * LWORK >= N + MAX( NB * ( NP00 + 1 ), NB * 3 ) * If eigenvectors are requested: * LWORK >= N + ( NP00 + MQ00 + NB ) * NB -* For definitions of NP00 & MQ00, see LRWORK. +* For definitions of NP00 & MQ00, see LRWORK. * * For optimal performance, greater workspace is needed, i.e. * LWORK >= MAX( LWORK, NHETRD_LWORK ) @@ -232,7 +237,7 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, * Let NNP = MAX( N, NPROW*NPCOL + 1, 4 ). Then: * LIWORK >= 12*NNP + 2*N when the eigenvectors are desired * LIWORK >= 10*NNP + 2*N when only the eigenvalues have to be computed -* +* * If LIWORK = -1, then LIWORK is global input and a workspace * query is assumed; the routine only calculates the minimum * and optimal size for all work arrays. Each of these @@ -300,7 +305,7 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, * LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A * LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A * -* PCHEEVR assumes IEEE 754 standard compliant arithmetic. +* PCHEEVR assumes IEEE 754 standard compliant arithmetic. * * Alignment requirements * ====================== @@ -308,9 +313,9 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, * The distributed submatrices A(IA:*, JA:*) and Z(IZ:IZ+M-1,JZ:JZ+N-1) * must satisfy the following alignment properties: * -* 1.Identical (quadratic) dimension: +* 1.Identical (quadratic) dimension: * DESCA(M_) = DESCZ(M_) = DESCA(N_) = DESCZ(N_) -* 2.Quadratic conformal blocking: +* 2.Quadratic conformal blocking: * DESCA(MB_) = DESCA(NB_) = DESCZ(MB_) = DESCZ(NB_) * DESCA(RSRC_) = DESCZ(RSRC_) * 3.MOD( IA-1, MB_A ) = MOD( IZ-1, MB_Z ) = 0 @@ -368,6 +373,16 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, $ SQRT * .. * .. Executable Statements .. +* +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F * INFO = 0 @@ -395,7 +410,7 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, *********************************************************************** * * Set up pointers into the (complex) WORK array -* +* *********************************************************************** INDTAU = 1 INDWORK = INDTAU + N @@ -404,7 +419,7 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, *********************************************************************** * * Set up pointers into the RWORK array -* +* *********************************************************************** INDRTAU = 1 INDD = INDRTAU + N @@ -420,6 +435,26 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, * *********************************************************************** CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) JOBZ, RANGE, UPLO, IA, IL, + $ INFO, IU, IZ, JA, JZ, LIWORK, LRWORK, + $ LWORK, M, N, NZ, + $ VL, VU, NPROW, NPCOL, MYROW, MYCOL, + $ eos_str + 102 FORMAT('PCHEEVR inputs: ,JOBZ:',A5,', RANGE:',A5, + $ ', UPLO:',A5,', IA:',I5,', IL:',I5, + $ ', INFO:',I5,', IU:',I5,', IZ:',I5, + $ ', JA:',I5,', JZ:',I5,', LIWORK:',I5, + $ ', LRWORK:',I5,', LWORK:',I5,', M:',I5, + $ ', N:',I5,', NZ:',I5,', VL:',F9.4, + $ ', VU:',F9.4,', NPROW: ', I5,', NPCOL: ', I5 , + $ ', MYROW: ', I5,', MYCOL: ', I5, A1) + AOCL_DTL_LOG_ENTRY_F + END IF NPROCS = NPROW * NPCOL @@ -445,10 +480,10 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, * Take upper bound for VALEIG case MZ = N END IF -* +* NB = DESCA( NB_ ) NP00 = NUMROC( N, NB, 0, 0, NPROW ) - MQ00 = NUMROC( MZ, NB, 0, 0, NPCOL ) + MQ00 = NUMROC( MZ, NB, 0, 0, NPCOL ) IF ( WANTZ ) THEN INDRW = INDRWORK + MAX(18*N, NP00*MQ00 + 2*NB*NB) LRWMIN = INDRW - 1 + (ICEIL(MZ, NPROCS) + 2)*N @@ -456,7 +491,7 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, ELSE INDRW = INDRWORK + 12*N LRWMIN = INDRW - 1 - LWMIN = N + MAX( NB*( NP00 + 1 ), 3 * NB ) + LWMIN = N + MAX( NB*( NP00 + 1 ), 3 * NB ) END IF * The code that validates the input requires 3 workspace entries @@ -480,7 +515,7 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, *********************************************************************** NNP = MAX( N, NPROCS+1, 4 ) IF ( WANTZ ) THEN - LIWMIN = 12*NNP + 2*N + LIWMIN = 12*NNP + 2*N ELSE LIWMIN = 10*NNP + 2*N END IF @@ -488,12 +523,12 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, *********************************************************************** * * Set up pointers into the IWORK array -* +* *********************************************************************** * Pointer to eigenpair distribution over processors - INDILU = LIWMIN - 2*NPROCS + 1 - SIZE2 = INDILU - 2*N - + INDILU = LIWMIN - 2*NPROCS + 1 + SIZE2 = INDILU - 2*N + *********************************************************************** * @@ -532,9 +567,9 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, INFO = -( 800+NB_ ) END IF IF( WANTZ ) THEN - IAROW = INDXG2P( 1, DESCA( NB_ ), MYROW, + IAROW = INDXG2P( 1, DESCA( NB_ ), MYROW, $ DESCA( RSRC_ ), NPROW ) - IZROW = INDXG2P( 1, DESCA( NB_ ), MYROW, + IZROW = INDXG2P( 1, DESCA( NB_ ), MYROW, $ DESCZ( RSRC_ ), NPROW ) IF( IAROW.NE.IZROW ) THEN INFO = -19 @@ -595,8 +630,16 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCHEEVR', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF @@ -613,6 +656,10 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, WORK( 1 ) = CMPLX( LWOPT ) RWORK( 1 ) = REAL( LRWOPT ) IWORK( 1 ) = LIWMIN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF @@ -641,6 +688,10 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, IF (IINFO .NE. 0) THEN CALL PXERBLA( ICTXT, 'PCHENTRD', -IINFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF @@ -650,25 +701,25 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, * *********************************************************************** OFFSET = 0 - IF( IA.EQ.1 .AND. JA.EQ.1 .AND. + IF( IA.EQ.1 .AND. JA.EQ.1 .AND. $ DESCA( RSRC_ ).EQ.0 .AND. DESCA( CSRC_ ).EQ.0 ) $ THEN - CALL PSLARED1D( N, IA, JA, DESCA, RWORK( INDD ), + CALL PSLARED1D( N, IA, JA, DESCA, RWORK( INDD ), $ RWORK( INDD2 ), RWORK( INDRWORK ), LLRWORK ) * - CALL PSLARED1D( N, IA, JA, DESCA, RWORK( INDE ), + CALL PSLARED1D( N, IA, JA, DESCA, RWORK( INDE ), $ RWORK( INDE2 ), RWORK( INDRWORK ), LLRWORK ) IF( .NOT.LOWER ) $ OFFSET = 1 ELSE DO 10 I = 1, N - CALL PCELGET( 'A', ' ', WORK( INDWORK ), A, + CALL PCELGET( 'A', ' ', WORK( INDWORK ), A, $ I+IA-1, I+JA-1, DESCA ) RWORK( INDD2+I-1 ) = REAL( WORK( INDWORK ) ) 10 CONTINUE IF( LSAME( UPLO, 'U' ) ) THEN DO 20 I = 1, N - 1 - CALL PCELGET( 'A', ' ', WORK( INDWORK ), A, + CALL PCELGET( 'A', ' ', WORK( INDWORK ), A, $ I+IA-1, I+JA, DESCA ) RWORK( INDE2+I-1 ) = REAL( WORK( INDWORK ) ) 20 CONTINUE @@ -689,16 +740,16 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, * SET IIL, IIU * *********************************************************************** - IF ( ALLEIG ) THEN + IF ( ALLEIG ) THEN IIL = 1 IIU = N ELSE IF ( INDEIG ) THEN IIL = IL IIU = IU ELSE IF ( VALEIG ) THEN - CALL SLARRC('T', N, VLL, VUU, RWORK( INDD2 ), + CALL SLARRC('T', N, VLL, VUU, RWORK( INDD2 ), $ RWORK( INDE2 + OFFSET ), SAFMIN, EIGCNT, IIL, IIU, INFO) -* Refine upper bound N that was taken +* Refine upper bound N that was taken MZ = EIGCNT IIL = IIL + 1 ENDIF @@ -710,6 +761,10 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, END IF WORK( 1 ) = REAL( LWOPT ) IWORK( 1 ) = LIWMIN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF @@ -755,10 +810,10 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, DOU = MYIU - MYIL + 1 CALL SSTEGR2( JOBZ, 'I', N, RWORK( INDD2 ), $ RWORK( INDE2+OFFSET ), VLL, VUU, MYIL, MYIU, - $ IM, W( 1 ), RWORK( INDRW ), N, + $ IM, W( 1 ), RWORK( INDRW ), N, $ MYIU - MYIL + 1, - $ IWORK( 1 ), RWORK( INDRWORK ), SIZE1, - $ IWORK( 2*N+1 ), SIZE2, + $ IWORK( 1 ), RWORK( INDRWORK ), SIZE1, + $ IWORK( 2*N+1 ), SIZE2, $ DOL, DOU, ZOFFSET, IINFO ) * SSTEGR2 zeroes out the entire W array, so we can't just give * it the part of W we need. So here we copy the W entries into @@ -771,6 +826,10 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, END IF IF (IINFO .NE. 0) THEN CALL PXERBLA( ICTXT, 'SSTEGR2', -IINFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF ELSEIF ( WANTZ .AND. NPROCS.EQ.1 ) THEN @@ -783,20 +842,24 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, DOU = MYIU - IIL + 1 CALL SSTEGR2( JOBZ, 'I', N, RWORK( INDD2 ), $ RWORK( INDE2+OFFSET ), VLL, VUU, IIL, IIU, - $ IM, W( 1 ), RWORK( INDRW ), N, + $ IM, W( 1 ), RWORK( INDRW ), N, $ N, - $ IWORK( 1 ), RWORK( INDRWORK ), SIZE1, + $ IWORK( 1 ), RWORK( INDRWORK ), SIZE1, $ IWORK( 2*N+1 ), SIZE2, DOL, DOU, $ ZOFFSET, IINFO ) ENDIF IF (IINFO .NE. 0) THEN CALL PXERBLA( ICTXT, 'SSTEGR2', -IINFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF ELSEIF ( WANTZ ) THEN * Compute representations in parallel. * Share eigenvalue computation for root between all processors -* Then compute the eigenvectors. +* Then compute the eigenvectors. IINFO = 0 * Part 1. compute root representations and root eigenvalues IF ( MYIL.GT.0 ) THEN @@ -804,20 +867,24 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, DOU = MYIU - IIL + 1 CALL SSTEGR2A( JOBZ, 'I', N, RWORK( INDD2 ), $ RWORK( INDE2+OFFSET ), VLL, VUU, IIL, IIU, - $ IM, W( 1 ), RWORK( INDRW ), N, - $ N, RWORK( INDRWORK ), SIZE1, - $ IWORK( 2*N+1 ), SIZE2, DOL, + $ IM, W( 1 ), RWORK( INDRW ), N, + $ N, RWORK( INDRWORK ), SIZE1, + $ IWORK( 2*N+1 ), SIZE2, DOL, $ DOU, NEEDIL, NEEDIU, $ INDERR, NSPLIT, PIVMIN, SCALE, WL, WU, $ IINFO ) ENDIF IF (IINFO .NE. 0) THEN CALL PXERBLA( ICTXT, 'SSTEGR2A', -IINFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * The second part of parallel MRRR, the representation tree -* construction begins. Upon successful completion, the +* construction begins. Upon successful completion, the * eigenvectors have been computed. This is indicated by * the flag FINISH. * @@ -836,13 +903,13 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, * 2.) POINT2POINT between collaborators (those processors working * jointly on a cluster. * For efficiency, BROADCAST has been disabled. -* At a later stage, other more efficient communication algorithms +* At a later stage, other more efficient communication algorithms * might be implemented, e. g. group or tree-based communication. DOBCST = .FALSE. IF(DOBCST) THEN * First gather everything on the first processor. -* Then use BROADCAST-based communication +* Then use BROADCAST-based communication DO 45 I = 2, NPROCS IF (MYPROC .EQ. (I - 1)) THEN DSTROW = 0 @@ -855,25 +922,25 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, LENGTHI = 0 ENDIF IWORK(2) = LENGTHI - CALL IGESD2D( ICTXT, 2, 1, IWORK, 2, + CALL IGESD2D( ICTXT, 2, 1, IWORK, 2, $ DSTROW, DSTCOL ) IF (( STARTI.GE.1 ) .AND. ( LENGTHI.GE.1 )) THEN LENGTHI2 = 2*LENGTHI * Copy eigenvalues into communication buffer CALL SCOPY(LENGTHI,W( STARTI ),1, - $ RWORK( INDD ), 1) + $ RWORK( INDD ), 1) * Copy uncertainties into communication buffer CALL SCOPY(LENGTHI,RWORK(IINDERR+STARTI-1),1, - $ RWORK( INDD+LENGTHI ), 1) + $ RWORK( INDD+LENGTHI ), 1) * send buffer - CALL SGESD2D( ICTXT, LENGTHI2, + CALL SGESD2D( ICTXT, LENGTHI2, $ 1, RWORK( INDD ), LENGTHI2, $ DSTROW, DSTCOL ) END IF ELSE IF (MYPROC .EQ. 0) THEN SRCROW = (I-1) / NPCOL SRCCOL = MOD(I-1, NPCOL) - CALL IGERV2D( ICTXT, 2, 1, IWORK, 2, + CALL IGERV2D( ICTXT, 2, 1, IWORK, 2, $ SRCROW, SRCCOL ) STARTI = IWORK(1) LENGTHI = IWORK(2) @@ -884,10 +951,10 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, $ RWORK(INDD), LENGTHI2, SRCROW, SRCCOL ) * copy eigenvalues from communication buffer CALL SCOPY( LENGTHI, RWORK(INDD), 1, - $ W( STARTI ), 1) + $ W( STARTI ), 1) * copy uncertainties (errors) from communication buffer CALL SCOPY(LENGTHI,RWORK(INDD+LENGTHI),1, - $ RWORK( IINDERR+STARTI-1 ), 1) + $ RWORK( IINDERR+STARTI-1 ), 1) END IF END IF 45 CONTINUE @@ -895,10 +962,10 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, LENGTHI2 = LENGTHI * 2 IF (MYPROC .EQ. 0) THEN * Broadcast eigenvalues and errors to all processors - CALL SCOPY(LENGTHI,W ,1, RWORK( INDD ), 1) + CALL SCOPY(LENGTHI,W ,1, RWORK( INDD ), 1) CALL SCOPY(LENGTHI,RWORK( IINDERR ),1, - $ RWORK( INDD+LENGTHI ), 1) - CALL SGEBS2D( ICTXT, 'A', ' ', LENGTHI2, 1, + $ RWORK( INDD+LENGTHI ), 1) + CALL SGEBS2D( ICTXT, 'A', ' ', LENGTHI2, 1, $ RWORK(INDD), LENGTHI2 ) ELSE SRCROW = 0 @@ -907,14 +974,14 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, $ RWORK(INDD), LENGTHI2, SRCROW, SRCCOL ) CALL SCOPY( LENGTHI, RWORK(INDD), 1, W, 1) CALL SCOPY(LENGTHI,RWORK(INDD+LENGTHI),1, - $ RWORK( IINDERR ), 1) + $ RWORK( IINDERR ), 1) END IF ELSE * Enable point2point communication between collaborators -* Find collaborators of MYPROC +* Find collaborators of MYPROC IF( (NPROCS.GT.1).AND.(MYIL.GT.0) ) THEN - CALL PMPCOL( MYPROC, NPROCS, IIL, NEEDIL, NEEDIU, + CALL PMPCOL( MYPROC, NPROCS, IIL, NEEDIL, NEEDIU, $ IWORK(INDILU), IWORK(INDILU+NPROCS), $ COLBRT, FRSTCL, LASTCL ) ELSE @@ -923,34 +990,34 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, IF(COLBRT) THEN * If the processor collaborates with others, -* communicate information. +* communicate information. DO 47 IPROC = FRSTCL, LASTCL IF (MYPROC .EQ. IPROC) THEN STARTI = DOL IWORK(1) = STARTI LENGTHI = MYIU - MYIL + 1 IWORK(2) = LENGTHI - + IF ((STARTI.GE.1) .AND. (LENGTHI.GE.1)) THEN * Copy eigenvalues into communication buffer CALL SCOPY(LENGTHI,W( STARTI ),1, - $ RWORK(INDD), 1) + $ RWORK(INDD), 1) * Copy uncertainties into communication buffer CALL SCOPY(LENGTHI, $ RWORK( IINDERR+STARTI-1 ),1, - $ RWORK(INDD+LENGTHI), 1) + $ RWORK(INDD+LENGTHI), 1) ENDIF - DO 46 I = FRSTCL, LASTCL + DO 46 I = FRSTCL, LASTCL IF(I.EQ.MYPROC) GOTO 46 DSTROW = I/ NPCOL DSTCOL = MOD(I, NPCOL) - CALL IGESD2D( ICTXT, 2, 1, IWORK, 2, + CALL IGESD2D( ICTXT, 2, 1, IWORK, 2, $ DSTROW, DSTCOL ) IF ((STARTI.GE.1) .AND. (LENGTHI.GE.1)) THEN LENGTHI2 = 2*LENGTHI * send buffer - CALL SGESD2D( ICTXT, LENGTHI2, + CALL SGESD2D( ICTXT, LENGTHI2, $ 1, RWORK(INDD), LENGTHI2, $ DSTROW, DSTCOL ) END IF @@ -958,7 +1025,7 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, ELSE SRCROW = IPROC / NPCOL SRCCOL = MOD(IPROC, NPCOL) - CALL IGERV2D( ICTXT, 2, 1, IWORK, 2, + CALL IGERV2D( ICTXT, 2, 1, IWORK, 2, $ SRCROW, SRCCOL ) RSTARTI = IWORK(1) RLENGTHI = IWORK(2) @@ -969,10 +1036,10 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, $ SRCROW, SRCCOL ) * copy eigenvalues from communication buffer CALL SCOPY( RLENGTHI,RWORK(INDE), 1, - $ W( RSTARTI ), 1) + $ W( RSTARTI ), 1) * copy uncertainties (errors) from communication buffer CALL SCOPY(RLENGTHI,RWORK(INDE+RLENGTHI),1, - $ RWORK( IINDERR+RSTARTI-1 ), 1) + $ RWORK( IINDERR+RSTARTI-1 ), 1) END IF END IF 47 CONTINUE @@ -984,17 +1051,17 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, * is constructed in parallel from top to bottom, * on level at a time, until all eigenvectors * have been computed. -* +* 100 CONTINUE IF ( MYIL.GT.0 ) THEN CALL SSTEGR2B( JOBZ, N, RWORK( INDD2 ), - $ RWORK( INDE2+OFFSET ), + $ RWORK( INDE2+OFFSET ), $ IM, W( 1 ), RWORK( INDRW ), N, N, - $ IWORK( 1 ), RWORK( INDRWORK ), SIZE1, - $ IWORK( 2*N+1 ), SIZE2, DOL, + $ IWORK( 1 ), RWORK( INDRWORK ), SIZE1, + $ IWORK( 2*N+1 ), SIZE2, DOL, $ DOU, NEEDIL, NEEDIU, INDWLC, $ PIVMIN, SCALE, WL, WU, - $ VSTART, FINISH, + $ VSTART, FINISH, $ MAXCLS, NDEPTH, PARITY, ZOFFSET, IINFO ) IINDWLC = INDRWORK + INDWLC - 1 IF(.NOT.FINISH) THEN @@ -1008,7 +1075,7 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, LASTCL = MYPROC ENDIF * -* Check if this processor collaborates, i.e. +* Check if this processor collaborates, i.e. * communication is needed. * IF(COLBRT) THEN @@ -1026,23 +1093,23 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, * Copy eigenvalues into communication buffer CALL SCOPY(LENGTHI, $ RWORK( IINDWLC+STARTI-1 ),1, - $ RWORK(INDD), 1) + $ RWORK(INDD), 1) * Copy uncertainties into communication buffer CALL SCOPY(LENGTHI, $ RWORK( IINDERR+STARTI-1 ),1, - $ RWORK(INDD+LENGTHI), 1) + $ RWORK(INDD+LENGTHI), 1) ENDIF - - DO 146 I = FRSTCL, LASTCL + + DO 146 I = FRSTCL, LASTCL IF(I.EQ.MYPROC) GOTO 146 DSTROW = I/ NPCOL DSTCOL = MOD(I, NPCOL) - CALL IGESD2D( ICTXT, 2, 1, IWORK, 2, + CALL IGESD2D( ICTXT, 2, 1, IWORK, 2, $ DSTROW, DSTCOL ) IF ((STARTI.GE.1).AND.(LENGTHI.GE.1)) THEN LENGTHI2 = 2*LENGTHI * send buffer - CALL SGESD2D( ICTXT, LENGTHI2, + CALL SGESD2D( ICTXT, LENGTHI2, $ 1, RWORK(INDD), LENGTHI2, $ DSTROW, DSTCOL ) END IF @@ -1050,7 +1117,7 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, ELSE SRCROW = IPROC / NPCOL SRCCOL = MOD(IPROC, NPCOL) - CALL IGERV2D( ICTXT, 2, 1, IWORK, 2, + CALL IGERV2D( ICTXT, 2, 1, IWORK, 2, $ SRCROW, SRCCOL ) RSTARTI = IWORK(1) RLENGTHI = IWORK(2) @@ -1061,19 +1128,23 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, $ SRCROW, SRCCOL ) * copy eigenvalues from communication buffer CALL SCOPY(RLENGTHI,RWORK(INDE), 1, - $ RWORK( IINDWLC+RSTARTI-1 ), 1) + $ RWORK( IINDWLC+RSTARTI-1 ), 1) * copy uncertainties (errors) from communication buffer CALL SCOPY(RLENGTHI,RWORK(INDE+RLENGTHI), - $ 1,RWORK( IINDERR+RSTARTI-1 ), 1) + $ 1,RWORK( IINDERR+RSTARTI-1 ), 1) END IF END IF 147 CONTINUE ENDIF - GOTO 100 + GOTO 100 ENDIF ENDIF IF (IINFO .NE. 0) THEN CALL PXERBLA( ICTXT, 'SSTEGR2B', -IINFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -1106,17 +1177,17 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, LENGTHI = 0 ENDIF IWORK(2) = LENGTHI - CALL IGESD2D( ICTXT, 2, 1, IWORK, 2, + CALL IGESD2D( ICTXT, 2, 1, IWORK, 2, $ DSTROW, DSTCOL ) IF ((STARTI.GE.1).AND.(LENGTHI.GE.1)) THEN - CALL SGESD2D( ICTXT, LENGTHI, + CALL SGESD2D( ICTXT, LENGTHI, $ 1, W( STARTI ), LENGTHI, $ DSTROW, DSTCOL ) ENDIF ELSE IF (MYPROC .EQ. 0) THEN SRCROW = (I-1) / NPCOL SRCCOL = MOD(I-1, NPCOL) - CALL IGERV2D( ICTXT, 2, 1, IWORK, 2, + CALL IGERV2D( ICTXT, 2, 1, IWORK, 2, $ SRCROW, SRCCOL ) STARTI = IWORK(1) LENGTHI = IWORK(2) @@ -1151,12 +1222,16 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, CALL SLASRT2( 'I', M, W, IWORK( NPROCS+2 ), IINFO ) IF (IINFO.NE.0) THEN CALL PXERBLA( ICTXT, 'SLASRT2', -IINFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF *********************************************************************** * -* TRANSFORM Z FROM 1D WORKSPACE INTO 2D BLOCKCYCLIC STORAGE +* TRANSFORM Z FROM 1D WORKSPACE INTO 2D BLOCKCYCLIC STORAGE * *********************************************************************** IF ( WANTZ ) THEN @@ -1178,11 +1253,11 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, 180 CONTINUE IF ( FIRST ) THEN - CALL PCLAEVSWP(N, RWORK( INDRW ), N, Z, IZ, JZ, - $ DESCZ, IWORK( 1 ), IWORK( NPROCS+M+2 ), RWORK( INDRWORK ), + CALL PCLAEVSWP(N, RWORK( INDRW ), N, Z, IZ, JZ, + $ DESCZ, IWORK( 1 ), IWORK( NPROCS+M+2 ), RWORK( INDRWORK ), $ SIZE1 ) ELSE - CALL PCLAEVSWP(N, RWORK( INDRW + N ), N, Z, IZ, JZ, + CALL PCLAEVSWP(N, RWORK( INDRW + N ), N, Z, IZ, JZ, $ DESCZ, IWORK( 1 ), IWORK( NPROCS+M+2 ), RWORK( INDRWORK ), $ SIZE1 ) END IF @@ -1202,6 +1277,10 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, END IF IF (IINFO.NE.0) THEN CALL PXERBLA( ICTXT, 'PCUNMTR', -IINFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -1212,6 +1291,10 @@ SUBROUTINE PCHEEVR( JOBZ, RANGE, UPLO, N, A, IA, JA, RWORK( 1 ) = REAL( LRWOPT ) IWORK( 1 ) = LIWMIN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCHEEVR diff --git a/SRC/pcheevx.f b/SRC/pcheevx.f index 3de0547f..be5831a0 100644 --- a/SRC/pcheevx.f +++ b/SRC/pcheevx.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCHEEVX( JOBZ, RANGE, UPLO, N, A, IA, JA, DESCA, VL, $ VU, IL, IU, ABSTOL, M, NZ, W, ORFAC, Z, IZ, $ JZ, DESCZ, WORK, LWORK, RWORK, LRWORK, IWORK, @@ -8,6 +13,7 @@ SUBROUTINE PCHEEVX( JOBZ, RANGE, UPLO, N, A, IA, JA, DESCA, VL, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO INTEGER IA, IL, INFO, IU, IZ, JA, JZ, LIWORK, LRWORK, @@ -517,10 +523,49 @@ SUBROUTINE PCHEEVX( JOBZ, RANGE, UPLO, N, A, IA, JA, DESCA, VL, $ REAL, SQRT * .. * .. Executable Statements .. +* +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) JOBZ, RANGE, UPLO, IA, IL, + $ INFO, IU, IZ, JA, JZ, LIWORK, LRWORK, + $ LWORK, M, N, NZ, + $ ABSTOL, ORFAC, VL, VU, eos_str + 102 FORMAT('PCHEEVX inputs: ,JOBZ:',A5,', RANGE:',A5, + $ ', UPLO:',A5,', IA:',I5,', IL:',I5, + $ ', INFO:',I5,', IU:',I5,', IZ:',I5, + $ ', JA:',I5,', JZ:',I5,', LIWORK:',I5, + $ ', LRWORK:',I5,', LWORK:',I5,', M:',I5, + $ ', N:',I5,', NZ:',I5,', ABSTOL:',F9.4, + $ ', ORFAC:',F9.4,', VL:',F9.4, + $ ', VU:',F9.4, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF * This is just to keep ftnchek and toolpack/1 happy IF( BLOCK_CYCLIC_2D*CSRC_*CTXT_*DLEN_*DTYPE_*LLD_*MB_*M_*NB_*N_* - $ RSRC_.LT.0 )RETURN + $ RSRC_.LT.0 )THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF +* +* +* Capture the subroutine exit in the trace file * + AOCL_DTL_TRACE_EXIT_F QUICKRETURN = ( N.EQ.0 ) * * Test the input arguments. @@ -761,13 +806,25 @@ SUBROUTINE PCHEEVX( JOBZ, RANGE, UPLO, N, A, IA, JA, DESCA, VL, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCHEEVX', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F IF( QUICKRETURN ) THEN IF( WANTZ ) THEN NZ = 0 @@ -777,6 +834,10 @@ SUBROUTINE PCHEEVX( JOBZ, RANGE, UPLO, N, A, IA, JA, DESCA, VL, WORK( 1 ) = CMPLX( LWOPT ) RWORK( 1 ) = REAL( LRWMIN ) IWORK( 1 ) = LIWMIN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -997,6 +1058,10 @@ SUBROUTINE PCHEEVX( JOBZ, RANGE, UPLO, N, A, IA, JA, DESCA, VL, RWORK( 1 ) = REAL( LRWOPT ) IWORK( 1 ) = LIWMIN * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCHEEVX diff --git a/SRC/pchegs2.f b/SRC/pchegs2.f index b5fafa7d..611482b1 100644 --- a/SRC/pchegs2.f +++ b/SRC/pchegs2.f @@ -1,4 +1,8 @@ * +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" * SUBROUTINE PCHEGS2( IBTYPE, UPLO, N, A, IA, JA, DESCA, B, IB, JB, $ DESCB, INFO ) @@ -8,6 +12,7 @@ SUBROUTINE PCHEGS2( IBTYPE, UPLO, N, A, IA, JA, DESCA, B, IB, JB, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER IA, IB, IBTYPE, INFO, JA, JB, N @@ -193,9 +198,37 @@ SUBROUTINE PCHEGS2( IBTYPE, UPLO, N, A, IA, JA, DESCA, B, IB, JB, EXTERNAL LSAME, INDXG2P * .. * .. Executable Statements .. +* +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, IA, IB, IBTYPE, INFO, + $ JA, JB, N, eos_str + 102 FORMAT('PCHEGS2 inputs: ,UPLO:',A5,', IA:',I5, + $ ', IB:',I5,', IBTYPE:',I5,', INFO:',I5, + $ ', JA:',I5,', JB:',I5,', N:',I5, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF * This is just to keep ftnchek happy IF( BLOCK_CYCLIC_2D*CSRC_*CTXT_*DLEN_*DTYPE_*LLD_*MB_*M_*NB_*N_* - $ RSRC_.LT.0 )RETURN + $ RSRC_.LT.0 )THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Get grid parameters * @@ -255,13 +288,22 @@ SUBROUTINE PCHEGS2( IBTYPE, UPLO, N, A, IA, JA, DESCA, B, IB, JB, IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCHEGS2', -INFO ) CALL BLACS_EXIT( ICTXT ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.EQ.0 .OR. ( MYROW.NE.IAROW .OR. MYCOL.NE.IACOL ) ) - $ RETURN + IF( N.EQ.0 .OR. ( MYROW.NE.IAROW .OR. MYCOL.NE.IACOL ) ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Compute local information * @@ -426,6 +468,10 @@ SUBROUTINE PCHEGS2( IBTYPE, UPLO, N, A, IA, JA, DESCA, B, IB, JB, * END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCHEGS2 diff --git a/SRC/pchegst.f b/SRC/pchegst.f index 4969708c..358f2820 100644 --- a/SRC/pchegst.f +++ b/SRC/pchegst.f @@ -1,4 +1,8 @@ * +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" * SUBROUTINE PCHEGST( IBTYPE, UPLO, N, A, IA, JA, DESCA, B, IB, JB, $ DESCB, SCALE, INFO ) @@ -8,6 +12,7 @@ SUBROUTINE PCHEGST( IBTYPE, UPLO, N, A, IA, JA, DESCA, B, IB, JB, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER IA, IB, IBTYPE, INFO, JA, JB, N @@ -200,9 +205,37 @@ SUBROUTINE PCHEGST( IBTYPE, UPLO, N, A, IA, JA, DESCA, B, IB, JB, EXTERNAL LSAME, ICEIL, INDXG2P * .. * .. Executable Statements .. +* +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, IA, IB, IBTYPE, INFO, + $ JA, JB, N, SCALE, eos_str + 102 FORMAT('PCHEGST inputs: ,UPLO:',A5,', IA:',I5, + $ ', IB:',I5,', IBTYPE:',I5,', INFO:',I5, + $ ', JA:',I5,', JB:',I5,', N:',I5,', SCALE:',F9.4, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF * This is just to keep ftnchek happy IF( BLOCK_CYCLIC_2D*CSRC_*CTXT_*DLEN_*DTYPE_*LLD_*MB_*M_*NB_*N_* - $ RSRC_.LT.0 )RETURN + $ RSRC_.LT.0 )THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Get grid parameters * @@ -271,13 +304,22 @@ SUBROUTINE PCHEGST( IBTYPE, UPLO, N, A, IA, JA, DESCA, B, IB, JB, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCHEGST', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * IF( IBTYPE.EQ.1 ) THEN IF( UPPER ) THEN @@ -436,6 +478,10 @@ SUBROUTINE PCHEGST( IBTYPE, UPLO, N, A, IA, JA, DESCA, B, IB, JB, * END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCHEGST diff --git a/SRC/pchegvx.f b/SRC/pchegvx.f index 9309b07f..7cf33065 100644 --- a/SRC/pchegvx.f +++ b/SRC/pchegvx.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCHEGVX( IBTYPE, JOBZ, RANGE, UPLO, N, A, IA, JA, $ DESCA, B, IB, JB, DESCB, VL, VU, IL, IU, $ ABSTOL, M, NZ, W, ORFAC, Z, IZ, JZ, DESCZ, @@ -9,6 +14,7 @@ SUBROUTINE PCHEGVX( IBTYPE, JOBZ, RANGE, UPLO, N, A, IA, JA, * and University of California, Berkeley. * October 15, 1999 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER JOBZ, RANGE, UPLO INTEGER IA, IB, IBTYPE, IL, INFO, IU, IZ, JA, JB, JZ, @@ -532,9 +538,46 @@ SUBROUTINE PCHEGVX( IBTYPE, JOBZ, RANGE, UPLO, N, A, IA, JA, $ REAL, SQRT * .. * .. Executable Statements .. +* +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) JOBZ, RANGE, UPLO, IA, IB, + $ IBTYPE, IL, INFO, IU, IZ, JA, JB, JZ, + $ LIWORK, LRWORK, + $ LWORK, M, N, NZ, ABSTOL, ORFAC, VL, + $ VU, eos_str + 102 FORMAT('PCHEGVX inputs: ,JOBZ:',A5,', RANGE:',A5, + $ ', UPLO:',A5,', IA:',I5,', IB:',I5, + $ ', IBTYPE:',I5,', IL:',I5,', INFO:',I5, + $ ', IU:',I5,', IZ:',I5,', JA:',I5, + $ ', JB:',I5,', JZ:',I5,', LIWORK:',I5, + $ ', LRWORK:',I5,', LWORK:',I5,', M:',I5, + $ ', N:',I5,', NZ:',I5,', ABSTOL:',F9.4, + $ ', ORFAC:',F9.4,', VL:',F9.4, + $ ', VU:',F9.4, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF * This is just to keep ftnchek and toolpack/1 happy IF( BLOCK_CYCLIC_2D*CSRC_*CTXT_*DLEN_*DTYPE_*LLD_*MB_*M_*NB_*N_* - $ RSRC_.LT.0 )RETURN + $ RSRC_.LT.0 )THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Get grid parameters * @@ -760,8 +803,16 @@ SUBROUTINE PCHEGVX( IBTYPE, JOBZ, RANGE, UPLO, N, A, IA, JA, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCHEGVX ', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -774,6 +825,10 @@ SUBROUTINE PCHEGVX( IBTYPE, JOBZ, RANGE, UPLO, N, A, IA, JA, RWORK( 1 ) = REAL( LRWOPT ) IFAIL( 1 ) = INFO INFO = IERRNPD +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -829,6 +884,10 @@ SUBROUTINE PCHEGVX( IBTYPE, JOBZ, RANGE, UPLO, N, A, IA, JA, IWORK( 1 ) = LIWMIN WORK( 1 ) = CMPLX( REAL( LWOPT ) ) RWORK( 1 ) = REAL( LRWOPT ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCHEGVX diff --git a/SRC/pchengst.f b/SRC/pchengst.f index 3d970c21..930a9259 100644 --- a/SRC/pchengst.f +++ b/SRC/pchengst.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCHENGST( IBTYPE, UPLO, N, A, IA, JA, DESCA, B, IB, JB, $ DESCB, SCALE, WORK, LWORK, INFO ) * @@ -6,6 +11,7 @@ SUBROUTINE PCHENGST( IBTYPE, UPLO, N, A, IA, JA, DESCA, B, IB, JB, * and University of California, Berkeley. * October 15, 1999 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER IA, IB, IBTYPE, INFO, JA, JB, LWORK, N @@ -240,8 +246,34 @@ SUBROUTINE PCHENGST( IBTYPE, UPLO, N, A, IA, JA, DESCA, B, IB, JB, INTRINSIC CMPLX, CONJG, ICHAR, MAX, MIN, MOD, REAL * .. * .. Executable Statements .. +* +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, IA, IB, IBTYPE, INFO, + $ JA, JB, LWORK, N, SCALE, NPROW, NPCOL, + $ MYROW, MYCOL, eos_str + 102 FORMAT('PCHENGST inputs: ,UPLO:',A5,', IA:',I5, + $ ', IB:',I5,', IBTYPE:',I5,', INFO:',I5, + $ ', JA:',I5,', JB:',I5,', LWORK:',I5, + $ ', N:',I5,', SCALE:',F9.4,', NPROW: ', I5, + $ ', NPCOL: ', I5 ,', MYROW: ', I5, + $ ', MYCOL: ', I5, A1) + AOCL_DTL_LOG_ENTRY_F + END IF SCALE = 1.0E0 * NB = DESCA( MB_ ) @@ -319,20 +351,37 @@ SUBROUTINE PCHENGST( IBTYPE, UPLO, N, A, IA, JA, DESCA, B, IB, JB, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCHENGST', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * IF( IBTYPE.NE.1 .OR. UPPER .OR. LWORK.LT.LWOPT ) THEN CALL PCHEGST( IBTYPE, UPLO, N, A, IA, JA, DESCA, B, IB, JB, $ DESCB, SCALE, INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -422,5 +471,9 @@ SUBROUTINE PCHENGST( IBTYPE, UPLO, N, A, IA, JA, DESCA, B, IB, JB, * WORK( 1 ) = CMPLX( REAL( LWOPT ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END diff --git a/SRC/pchentrd.f b/SRC/pchentrd.f index d09f2536..6f0477d8 100644 --- a/SRC/pchentrd.f +++ b/SRC/pchentrd.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCHENTRD( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, $ LWORK, RWORK, LRWORK, INFO ) * @@ -6,6 +11,7 @@ SUBROUTINE PCHENTRD( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, * and University of California, Berkeley. * October 15, 1999 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER IA, INFO, JA, LRWORK, LWORK, N @@ -305,9 +311,37 @@ SUBROUTINE PCHENTRD( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, IA, INFO, JA, LRWORK, + $ LWORK, N, eos_str + 102 FORMAT('PCHENTRD inputs: ,UPLO:',A5,', IA:',I5, + $ ', INFO:',I5,', JA:',I5,', LRWORK:',I5, + $ ', LWORK:',I5,', N:',I5, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF +* * This is just to keep ftnchek and toolpack/1 happy IF( BLOCK_CYCLIC_2D*CSRC_*CTXT_*DLEN_*DTYPE_*LLD_*MB_*M_*NB_*N_* - $ RSRC_.LT.0 )RETURN + $ RSRC_.LT.0 )THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * Get grid parameters * ICTXT = DESCA( CTXT_ ) @@ -382,15 +416,28 @@ SUBROUTINE PCHENTRD( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCHENTRD', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * ONEPMIN = N*N + 3*N + 1 @@ -580,6 +627,10 @@ SUBROUTINE PCHENTRD( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, WORK( 1 ) = CMPLX( REAL( TTLWMIN ) ) RWORK( 1 ) = REAL( TTLRWMIN ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCHENTRD diff --git a/SRC/pchetd2.f b/SRC/pchetd2.f index 3703daae..594287ef 100644 --- a/SRC/pchetd2.f +++ b/SRC/pchetd2.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCHETD2( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, $ LWORK, INFO ) * @@ -6,6 +11,7 @@ SUBROUTINE PCHETD2( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER IA, INFO, JA, LWORK, N @@ -251,11 +257,34 @@ SUBROUTINE PCHETD2( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, IA, INFO, JA, LWORK, + $ N, NPROW, NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCHETD2 inputs: ,UPLO:',A5,', IA:',I5, + $ ', INFO:',I5,', JA:',I5,', LWORK:',I5, + $ ', N:',I5,', NPROW: ', I5,', NPCOL: ', I5 , + $ ', MYROW: ', I5,', MYCOL: ', I5, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -286,15 +315,28 @@ SUBROUTINE PCHETD2( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCHETD2', -INFO ) CALL BLACS_ABORT( ICTXT, 1 ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.LE.0 ) - $ RETURN + IF( N.LE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Compute local information * @@ -483,6 +525,10 @@ SUBROUTINE PCHETD2( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCHETD2 diff --git a/SRC/pchetrd.f b/SRC/pchetrd.f index 00aec5fd..0270936e 100644 --- a/SRC/pchetrd.f +++ b/SRC/pchetrd.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCHETRD( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, $ LWORK, INFO ) * @@ -6,6 +11,7 @@ SUBROUTINE PCHETRD( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER IA, INFO, JA, LWORK, N @@ -256,11 +262,34 @@ SUBROUTINE PCHETRD( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, IA, INFO, JA, LWORK, + $ N, NPROW, NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCHETRD inputs: ,UPLO:',A5,', IA:',I5, + $ ', INFO:',I5,', JA:',I5,', LWORK:',I5, + $ ', N:',I5,', NPROW: ', I5,', NPCOL: ', I5 , + $ ', MYROW: ', I5,', MYCOL: ', I5, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -310,15 +339,28 @@ SUBROUTINE PCHETRD( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCHETRD', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * CALL PB_TOPGET( ICTXT, 'Combine', 'Columnwise', COLCTOP ) CALL PB_TOPGET( ICTXT, 'Combine', 'Rowwise', ROWCTOP ) @@ -421,6 +463,10 @@ SUBROUTINE PCHETRD( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCHETRD diff --git a/SRC/pchettrd.f b/SRC/pchettrd.f index c3870c8a..e7e2d509 100644 --- a/SRC/pchettrd.f +++ b/SRC/pchettrd.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCHETTRD( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, $ LWORK, INFO ) * @@ -5,6 +10,7 @@ SUBROUTINE PCHETTRD( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, * Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver * May 1 2012 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER IA, INFO, JA, LWORK, N @@ -460,9 +466,37 @@ SUBROUTINE PCHETTRD( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, * * * .. Executable Statements .. +* +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, IA, INFO, JA, LWORK, + $ N, eos_str + 102 FORMAT('PCHETTRD inputs: ,UPLO:',A5,', IA:',I5, + $ ', INFO:',I5,', JA:',I5,', LWORK:',I5, + $ ', N:',I5, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF * This is just to keep ftnchek and toolpack/1 happy IF( BLOCK_CYCLIC_2D*CSRC_*CTXT_*DLEN_*DTYPE_*LLD_*MB_*M_*NB_*N_* - $ RSRC_.LT.0 )RETURN + $ RSRC_.LT.0 )THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * * @@ -569,13 +603,22 @@ SUBROUTINE PCHETTRD( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCHETTRD', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * * @@ -659,6 +702,10 @@ SUBROUTINE PCHETTRD( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCHETTRD', -INFO ) WORK( 1 ) = CMPLX( LWMIN ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -1195,6 +1242,10 @@ SUBROUTINE PCHETTRD( UPLO, N, A, IA, JA, DESCA, D, E, TAU, WORK, * * WORK( 1 ) = CMPLX( LWMIN ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCHETTRD diff --git a/SRC/pclahqr.f b/SRC/pclahqr.f index 732bbfa2..cb98f088 100644 --- a/SRC/pclahqr.f +++ b/SRC/pclahqr.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLAHQR( WANTT, WANTZ, N, ILO, IHI, A, DESCA, W, ILOZ, $ IHIZ, Z, DESCZ, WORK, LWORK, IWORK, ILWORK, $ INFO ) @@ -9,6 +14,7 @@ SUBROUTINE PCLAHQR( WANTT, WANTZ, N, ILO, IHI, A, DESCA, W, ILOZ, * modification suggested by Mark Fahey and Greg Henry * 1.7.0: July 31, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. LOGICAL WANTT, WANTZ INTEGER IHI, IHIZ, ILO, ILOZ, ILWORK, INFO, LWORK, N @@ -308,12 +314,40 @@ SUBROUTINE PCLAHQR( WANTT, WANTZ, N, ILO, IHI, A, DESCA, W, ILOZ, CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) ) * .. * .. Executable Statements .. +* +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) WANTT, WANTZ, IHI, IHIZ, ILO, + $ ILOZ, ILWORK, INFO, LWORK, N, eos_str + 102 FORMAT('PCLAHQR inputs: ,WANTT:',L1,', WANTZ:',L1, + $ ', IHI:',I5,', IHIZ:',I5,', ILO:',I5, + $ ', ILOZ:',I5,', ILWORK:',I5,', INFO:',I5, + $ ', LWORK:',I5,', N:',I5, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF * INFO = 0 * ITERMAX = 30*( IHI-ILO+1 ) - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * NODE (IAFIRST,JAFIRST) OWNS A(1,1) * @@ -348,6 +382,10 @@ SUBROUTINE PCLAHQR( WANTT, WANTZ, N, ILO, IHI, A, DESCA, W, ILOZ, JJ = JJ + MAX( 2*N, ( 8*LCMRC+2 )**2 ) IF( LWORK.EQ.-1 ) THEN WORK( 1 ) = JJ +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF IF( LWORK.LT.JJ ) THEN @@ -384,6 +422,10 @@ SUBROUTINE PCLAHQR( WANTT, WANTZ, N, ILO, IHI, A, DESCA, W, ILOZ, $ -1, -1 ) IF( INFO.LT.0 ) THEN CALL PXERBLA( CONTXT, 'PCLAHQR', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -411,6 +453,10 @@ SUBROUTINE PCLAHQR( WANTT, WANTZ, N, ILO, IHI, A, DESCA, W, ILOZ, ELSE W( ILO ) = ZERO END IF +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -2465,6 +2511,10 @@ SUBROUTINE PCLAHQR( WANTT, WANTZ, N, ILO, IHI, A, DESCA, W, ILOZ, * Failure to converge in remaining number of iterations * INFO = I +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * 550 CONTINUE @@ -2543,6 +2593,10 @@ SUBROUTINE PCLAHQR( WANTT, WANTZ, N, ILO, IHI, A, DESCA, W, ILOZ, * 570 CONTINUE CALL CGSUM2D( CONTXT, 'All', ' ', N, 1, W, N, -1, -1 ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * END OF PCLAHQR diff --git a/SRC/pclahrd.f b/SRC/pclahrd.f index 5f158fe4..21303edd 100644 --- a/SRC/pclahrd.f +++ b/SRC/pclahrd.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLAHRD( N, K, NB, A, IA, JA, DESCA, TAU, T, Y, IY, JY, $ DESCY, WORK ) * @@ -6,6 +11,7 @@ SUBROUTINE PCLAHRD( N, K, NB, A, IA, JA, DESCA, TAU, T, Y, IY, JY, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. INTEGER IA, IY, JA, JY, K, N, NB * .. @@ -161,10 +167,36 @@ SUBROUTINE PCLAHRD( N, K, NB, A, IA, JA, DESCA, TAU, T, Y, IY, JY, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) IA, IY, JA, JY, K, N, NB, eos_str + 102 FORMAT('PCLAHRD inputs: ,IA:',I5,', IY:',I5,', JA:',I5, + $ ', JY:',I5,', K:',I5,', N:',I5, + $ ', NB:',I5, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Quick return if possible * - IF( N.LE.1 ) - $ RETURN + IF( N.LE.1 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) @@ -283,6 +315,10 @@ SUBROUTINE PCLAHRD( N, K, NB, A, IA, JA, DESCA, TAU, T, Y, IY, JY, * CALL PCELSET( A, K+NB+IA-1, J, DESCA, EI ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLAHRD diff --git a/SRC/pclamr1d.f b/SRC/pclamr1d.f index 41f6d44e..3b9ae8d9 100644 --- a/SRC/pclamr1d.f +++ b/SRC/pclamr1d.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLAMR1D( N, A, IA, JA, DESCA, B, IB, JB, DESCB ) * * -- ScaLAPACK routine (version 1.7) -- @@ -5,6 +10,7 @@ SUBROUTINE PCLAMR1D( N, A, IA, JA, DESCA, B, IB, JB, DESCB ) * and University of California, Berkeley. * October 15, 1999 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. INTEGER IA, IB, JA, JB, N * .. @@ -106,14 +112,45 @@ SUBROUTINE PCLAMR1D( N, A, IA, JA, DESCA, B, IB, JB, DESCB ) EXTERNAL NUMROC * .. * .. Executable Statements .. +* +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) IA, IB, JA, JB, N, eos_str + 102 FORMAT('PCLAMR1D inputs: ,IA:',I5,', IB:',I5,', JA:',I5, + $ ', JB:',I5,', N:',I5, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF * This is just to keep ftnchek and toolpack/1 happy IF( BLOCK_CYCLIC_2D*CSRC_*CTXT_*DLEN_*DTYPE_*LLD_*MB_*M_*NB_*N_* - $ RSRC_.LT.0 )RETURN + $ RSRC_.LT.0 )THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Quick return if possible * - IF( N.LE.0 ) - $ RETURN + IF( N.LE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * DO 10 I = 1, DLEN_ DESCAA( I ) = DESCA( I ) @@ -137,6 +174,10 @@ SUBROUTINE PCLAMR1D( N, A, IA, JA, DESCA, B, IB, JB, DESCB ) CALL CGEBR2D( ICTXT, 'C', ' ', NQ, 1, B, NQ, 0, MYCOL ) END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLAMR1D diff --git a/SRC/pclange.f b/SRC/pclange.f index ca89e8cd..06c9cf1a 100644 --- a/SRC/pclange.f +++ b/SRC/pclange.f @@ -1,5 +1,11 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* REAL FUNCTION PCLANGE( NORM, M, N, A, IA, JA, DESCA, $ WORK ) + USE LINK_TO_C_GLOBALS IMPLICIT NONE * * -- ScaLAPACK auxiliary routine (version 1.7) -- @@ -178,10 +184,33 @@ REAL FUNCTION PCLANGE( NORM, M, N, A, IA, JA, DESCA, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters. * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) NORM, IA, JA, M, N, NPROW, + $ NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCLANGE inputs: ,NORM:',A5,', IA:',I5,', JA:',I5, + $ ', M:',I5,', N:',I5,', NPROW: ', I5, + $ ', NPCOL: ', I5 ,', MYROW: ', I5, + $ ', MYCOL: ', I5, A1) + AOCL_DTL_LOG_ENTRY_F + END IF * CALL INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL, II, JJ, $ IAROW, IACOL ) @@ -333,6 +362,10 @@ REAL FUNCTION PCLANGE( NORM, M, N, A, IA, JA, DESCA, * PCLANGE = VALUE * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLANGE diff --git a/SRC/pclanhe.f b/SRC/pclanhe.f index 67a6c48b..0a275570 100644 --- a/SRC/pclanhe.f +++ b/SRC/pclanhe.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* REAL FUNCTION PCLANHE( NORM, UPLO, N, A, IA, JA, $ DESCA, WORK ) * @@ -6,6 +11,7 @@ REAL FUNCTION PCLANHE( NORM, UPLO, N, A, IA, JA, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER NORM, UPLO INTEGER IA, JA, N @@ -194,10 +200,33 @@ REAL FUNCTION PCLANHE( NORM, UPLO, N, A, IA, JA, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters and local indexes. * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) NORM, UPLO, IA, JA, N, NPROW, + $ NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCLANHE inputs: ,NORM:',A5,', UPLO:',A5,', IA:',I5, + $ ', JA:',I5,', N:',I5,', NPROW: ', I5, + $ ', NPCOL: ', I5 ,', MYROW: ', I5, + $ ', MYCOL: ', I5, A1) + AOCL_DTL_LOG_ENTRY_F + END IF CALL INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL, $ IIA, JJA, IAROW, IACOL ) * @@ -941,6 +970,10 @@ REAL FUNCTION PCLANHE( NORM, UPLO, N, A, IA, JA, * PCLANHE = VALUE * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLANHE diff --git a/SRC/pclanhs.f b/SRC/pclanhs.f index 2426137f..960e6bd4 100644 --- a/SRC/pclanhs.f +++ b/SRC/pclanhs.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* REAL FUNCTION PCLANHS( NORM, N, A, IA, JA, DESCA, $ WORK ) * @@ -6,6 +11,7 @@ REAL FUNCTION PCLANHS( NORM, N, A, IA, JA, DESCA, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER NORM INTEGER IA, JA, N @@ -172,10 +178,32 @@ REAL FUNCTION PCLANHS( NORM, N, A, IA, JA, DESCA, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters. * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) NORM, IA, JA, N, NPROW, NPCOL, + $ MYROW, MYCOL, eos_str + 102 FORMAT('PCLANHS inputs: ,NORM:',A5,', IA:',I5,', JA:',I5, + $ ', N:',I5,', NPROW: ', I5,', NPCOL: ', I5 , + $ ', MYROW: ', I5,', MYCOL: ', I5, A1) + AOCL_DTL_LOG_ENTRY_F + END IF * CALL INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL, IIA, JJA, $ IAROW, IACOL ) @@ -734,6 +762,10 @@ REAL FUNCTION PCLANHS( NORM, N, A, IA, JA, DESCA, * PCLANHS = VALUE * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLANHS diff --git a/SRC/pclansy.f b/SRC/pclansy.f index e49c65e1..e7993e2b 100644 --- a/SRC/pclansy.f +++ b/SRC/pclansy.f @@ -1,5 +1,11 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* REAL FUNCTION PCLANSY( NORM, UPLO, N, A, IA, JA, $ DESCA, WORK ) + USE LINK_TO_C_GLOBALS IMPLICIT NONE * * -- ScaLAPACK auxiliary routine (version 1.7) -- @@ -195,10 +201,33 @@ REAL FUNCTION PCLANSY( NORM, UPLO, N, A, IA, JA, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters and local indexes. * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) NORM, UPLO, IA, JA, N, NPROW, + $ NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCLANSY inputs: ,NORM:',A5,', UPLO:',A5,', IA:',I5, + $ ', JA:',I5,', N:',I5,', NPROW: ', I5, + $ ', NPCOL: ', I5 ,', MYROW: ', I5, + $ ', MYCOL: ', I5, A1) + AOCL_DTL_LOG_ENTRY_F + END IF CALL INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL, $ IIA, JJA, IAROW, IACOL ) * @@ -857,6 +886,10 @@ REAL FUNCTION PCLANSY( NORM, UPLO, N, A, IA, JA, * PCLANSY = VALUE * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLANSY diff --git a/SRC/pclantr.f b/SRC/pclantr.f index 33969f6f..212d41de 100644 --- a/SRC/pclantr.f +++ b/SRC/pclantr.f @@ -1,5 +1,11 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* REAL FUNCTION PCLANTR( NORM, UPLO, DIAG, M, N, A, $ IA, JA, DESCA, WORK ) + USE LINK_TO_C_GLOBALS IMPLICIT NONE * * -- ScaLAPACK auxiliary routine (version 1.7) -- @@ -194,10 +200,33 @@ REAL FUNCTION PCLANTR( NORM, UPLO, DIAG, M, N, A, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) DIAG, NORM, UPLO, IA, JA, M, + $ N, NPROW, NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCLANTR inputs: ,DIAG:',A5,', NORM:',A5,', UPLO:',A5, + $ ', IA:',I5,', JA:',I5,', M:',I5, + $ ', N:',I5,', NPROW: ', I5,', NPCOL: ', I5 , + $ ', MYROW: ', I5,', MYCOL: ', I5, A1) + AOCL_DTL_LOG_ENTRY_F + END IF * UDIAG = LSAME( DIAG, 'U' ) CALL INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL, IIA, JJA, @@ -1098,6 +1127,10 @@ REAL FUNCTION PCLANTR( NORM, UPLO, DIAG, M, N, A, * PCLANTR = VALUE * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLANTR diff --git a/SRC/pclapiv.f b/SRC/pclapiv.f index e5a679b8..7342b9ec 100644 --- a/SRC/pclapiv.f +++ b/SRC/pclapiv.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLAPIV( DIREC, ROWCOL, PIVROC, M, N, A, IA, JA, $ DESCA, IPIV, IP, JP, DESCIP, IWORK ) * @@ -6,6 +11,7 @@ SUBROUTINE PCLAPIV( DIREC, ROWCOL, PIVROC, M, N, A, IA, JA, * and University of California, Berkeley. * November 15, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER*1 DIREC, PIVROC, ROWCOL INTEGER IA, IP, JA, JP, M, N @@ -224,17 +230,47 @@ SUBROUTINE PCLAPIV( DIREC, ROWCOL, PIVROC, M, N, A, IA, JA, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) DIREC, PIVROC, ROWCOL, IA, + $ IP, JA, JP, M, N, NPROW, NPCOL, MYROW, + $ MYCOL, eos_str + 102 FORMAT('PCLAPIV inputs: ,DIREC:',A2,', PIVROC:',A2, + $ ', ROWCOL:',A2,', IA:',I5,', IP:',I5, + $ ', JA:',I5,', JP:',I5,', M:',I5, + $ ', N:',I5,', NPROW: ', I5,', NPCOL: ', I5 , + $ ', MYROW: ', I5,', MYCOL: ', I5, A1) + AOCL_DTL_LOG_ENTRY_F + END IF ROWPVT = LSAME( ROWCOL, 'R' ) * * If we're pivoting the rows of sub( A ) * IF( ROWPVT ) THEN - IF( M.LE.1 .OR. N.LT.1 ) - $ RETURN + IF( M.LE.1 .OR. N.LT.1 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * If the pivot vector is already distributed correctly * @@ -293,8 +329,13 @@ SUBROUTINE PCLAPIV( DIREC, ROWCOL, PIVROC, M, N, A, IA, JA, * Otherwise, we're pivoting the columns of sub( A ) * ELSE - IF( M.LT.1 .OR. N.LE.1 ) - $ RETURN + IF( M.LT.1 .OR. N.LE.1 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * If the pivot vector is already distributed correctly * @@ -349,6 +390,10 @@ SUBROUTINE PCLAPIV( DIREC, ROWCOL, PIVROC, M, N, A, IA, JA, END IF END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLAPIV diff --git a/SRC/pclapv2.f b/SRC/pclapv2.f index 65fb412f..beb8ad2f 100644 --- a/SRC/pclapv2.f +++ b/SRC/pclapv2.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLAPV2( DIREC, ROWCOL, M, N, A, IA, JA, DESCA, IPIV, $ IP, JP, DESCIP ) * @@ -6,6 +11,7 @@ SUBROUTINE PCLAPV2( DIREC, ROWCOL, M, N, A, IA, JA, DESCA, IPIV, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER DIREC, ROWCOL INTEGER IA, IP, JA, JP, M, N @@ -168,14 +174,46 @@ SUBROUTINE PCLAPV2( DIREC, ROWCOL, M, N, A, IA, JA, DESCA, IPIV, INTRINSIC MIN, MOD * .. * .. Executable Statements .. +* +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) DIREC, ROWCOL, IA, IP, JA, + $ JP, M, N, eos_str + 102 FORMAT('PCLAPV2 inputs: ,DIREC:',A5,', ROWCOL:',A5, + $ ', IA:',I5,', IP:',I5,', JA:',I5, + $ ', JP:',I5,', M:',I5,', N:',I5, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF * ROWPVT = LSAME( ROWCOL, 'R' ) IF( ROWPVT ) THEN - IF( M.LE.1 .OR. N.LT.1 ) - $ RETURN + IF( M.LE.1 .OR. N.LT.1 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF ELSE - IF( M.LT.1 .OR. N.LE.1 ) - $ RETURN + IF( M.LT.1 .OR. N.LE.1 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF END IF FORWRD = LSAME( DIREC, 'F' ) * @@ -406,6 +444,10 @@ SUBROUTINE PCLAPV2( DIREC, ROWCOL, M, N, A, IA, JA, DESCA, IPIV, * END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End PCLAPV2 diff --git a/SRC/pclaqge.f b/SRC/pclaqge.f index ff40b743..18a0ea77 100644 --- a/SRC/pclaqge.f +++ b/SRC/pclaqge.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLAQGE( M, N, A, IA, JA, DESCA, R, C, ROWCND, COLCND, $ AMAX, EQUED ) * @@ -6,6 +11,7 @@ SUBROUTINE PCLAQGE( M, N, A, IA, JA, DESCA, R, C, ROWCND, COLCND, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER EQUED INTEGER IA, JA, M, N @@ -180,10 +186,36 @@ SUBROUTINE PCLAQGE( M, N, A, IA, JA, DESCA, R, C, ROWCND, COLCND, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) EQUED, IA, JA, M, N, AMAX, + $ COLCND, ROWCND, eos_str + 102 FORMAT('PCLAQGE inputs: ,EQUED:',A5,', IA:',I5, + $ ', JA:',I5,', M:',I5,', N:',I5,', AMAX:',F9.4, + $ ', COLCND:',F9.4,', ROWCND:',F9.4, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Quick return if possible * IF( M.LE.0 .OR. N.LE.0 ) THEN EQUED = 'N' +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -264,6 +296,10 @@ SUBROUTINE PCLAQGE( M, N, A, IA, JA, DESCA, R, C, ROWCND, COLCND, * END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLAQGE diff --git a/SRC/pclaqsy.f b/SRC/pclaqsy.f index b03a6854..4aa06160 100644 --- a/SRC/pclaqsy.f +++ b/SRC/pclaqsy.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLAQSY( UPLO, N, A, IA, JA, DESCA, SR, SC, SCOND, $ AMAX, EQUED ) * @@ -6,6 +11,7 @@ SUBROUTINE PCLAQSY( UPLO, N, A, IA, JA, DESCA, SR, SC, SCOND, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER EQUED, UPLO INTEGER IA, JA, N @@ -182,10 +188,36 @@ SUBROUTINE PCLAQSY( UPLO, N, A, IA, JA, DESCA, SR, SC, SCOND, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) EQUED, UPLO, IA, JA, N, AMAX, + $ SCOND, eos_str + 102 FORMAT('PCLAQSY inputs: ,EQUED:',A5,', UPLO:',A5, + $ ', IA:',I5,', JA:',I5,', N:',I5,', AMAX:',F9.4, + $ ', SCOND:',F9.4, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Quick return if possible * IF( N.LE.0 ) THEN EQUED = 'N' +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -353,6 +385,10 @@ SUBROUTINE PCLAQSY( UPLO, N, A, IA, JA, DESCA, SR, SC, SCOND, * END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLAQSY diff --git a/SRC/pclarf.f b/SRC/pclarf.f index 371f7107..c1b59035 100644 --- a/SRC/pclarf.f +++ b/SRC/pclarf.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, $ C, IC, JC, DESCC, WORK ) * @@ -6,6 +11,7 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER SIDE INTEGER IC, INCV, IV, JC, JV, M, N @@ -260,10 +266,37 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) SIDE, IC, INCV, IV, JC, JV, + $ M, N, eos_str + 102 FORMAT('PCLARF inputs: ,SIDE:',A5,', IC:',I5,', INCV:',I5, + $ ', IV:',I5,', JC:',I5,', JV:',I5, + $ ', M:',I5,', N:',I5, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Quick return if possible * - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN + IF( M.LE.0 .OR. N.LE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Get grid parameters. * @@ -807,6 +840,10 @@ SUBROUTINE PCLARF( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLARF diff --git a/SRC/pclarfb.f b/SRC/pclarfb.f index 4c11f359..ed5134cd 100644 --- a/SRC/pclarfb.f +++ b/SRC/pclarfb.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, IV, $ JV, DESCV, T, C, IC, JC, DESCC, WORK ) * @@ -5,6 +10,7 @@ SUBROUTINE PCLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, IV, * Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver * May 1 2012 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER SIDE, TRANS, DIRECT, STOREV INTEGER IC, IV, JC, JV, K, M, N @@ -250,10 +256,38 @@ SUBROUTINE PCLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, IV, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) SIDE, TRANS, DIRECT, STOREV, + $ IC, IV, JC, JV, K, M, N, eos_str + 102 FORMAT('PCLARFB inputs: ,SIDE:',A5,', TRANS:',A5, + $ ', DIRECT:',A5,', STOREV:',A5,', IC:',I5, + $ ', IV:',I5,', JC:',I5,', JV:',I5, + $ ', K:',I5,', M:',I5,', N:',I5, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Quick return if possible * - IF( M.LE.0 .OR. N.LE.0 .OR. K.LE.0 ) - $ RETURN + IF( M.LE.0 .OR. N.LE.0 .OR. K.LE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Get grid parameters * @@ -881,6 +915,10 @@ SUBROUTINE PCLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, IV, * END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLARFB diff --git a/SRC/pclarfc.f b/SRC/pclarfc.f index f84c4930..036769a2 100644 --- a/SRC/pclarfc.f +++ b/SRC/pclarfc.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, $ C, IC, JC, DESCC, WORK ) * @@ -6,6 +11,7 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER SIDE INTEGER IC, INCV, IV, JC, JV, M, N @@ -260,10 +266,37 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) SIDE, IC, INCV, IV, JC, JV, + $ M, N, eos_str + 102 FORMAT('PCLARFC inputs: ,SIDE:',A5,', IC:',I5, + $ ', INCV:',I5,', IV:',I5,', JC:',I5,', JV:',I5, + $ ', M:',I5,', N:',I5, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Quick return if possible * - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN + IF( M.LE.0 .OR. N.LE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Get grid parameters. * @@ -803,6 +836,10 @@ SUBROUTINE PCLARFC( SIDE, M, N, V, IV, JV, DESCV, INCV, TAU, * END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLARFC diff --git a/SRC/pclarfg.f b/SRC/pclarfg.f index 86a709ed..17d5bee7 100644 --- a/SRC/pclarfg.f +++ b/SRC/pclarfg.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLARFG( N, ALPHA, IAX, JAX, X, IX, JX, DESCX, INCX, $ TAU ) * @@ -6,6 +11,7 @@ SUBROUTINE PCLARFG( N, ALPHA, IAX, JAX, X, IX, JX, DESCX, INCX, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. INTEGER IAX, INCX, IX, JAX, JX, N COMPLEX ALPHA @@ -172,10 +178,35 @@ SUBROUTINE PCLARFG( N, ALPHA, IAX, JAX, X, IX, JX, DESCX, INCX, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters. * ICTXT = DESCX( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) IAX, INCX, IX, JAX, JX, N, + $ real(ALPHA),' + i ',aimag(ALPHA), NPROW, + $ NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCLARFG inputs: ,IAX:',I5,', INCX:',I5, + $ ', IX:',I5,', JAX:',I5,', JX:',I5,', N:',I5, + $ ', ALPHA:',F9.4, A, F9.4,', NPROW: ', I5, + $ ', NPCOL: ', I5 ,', MYROW: ', I5, + $ ', MYCOL: ', I5, A1) + AOCL_DTL_LOG_ENTRY_F + END IF * IF( INCX.EQ.DESCX( M_ ) ) THEN * @@ -184,8 +215,13 @@ SUBROUTINE PCLARFG( N, ALPHA, IAX, JAX, X, IX, JX, DESCX, INCX, CALL INFOG2L( IX, JAX, DESCX, NPROW, NPCOL, MYROW, MYCOL, $ IIAX, JJAX, IXROW, IXCOL ) * - IF( MYROW.NE.IXROW ) - $ RETURN + IF( MYROW.NE.IXROW ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Broadcast X(IAX,JAX) across the process row. * @@ -207,8 +243,13 @@ SUBROUTINE PCLARFG( N, ALPHA, IAX, JAX, X, IX, JX, DESCX, INCX, CALL INFOG2L( IAX, JX, DESCX, NPROW, NPCOL, MYROW, MYCOL, $ IIAX, JJAX, IXROW, IXCOL ) * - IF( MYCOL.NE.IXCOL ) - $ RETURN + IF( MYCOL.NE.IXCOL ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Broadcast X(IAX,JAX) across the process column. * @@ -227,6 +268,10 @@ SUBROUTINE PCLARFG( N, ALPHA, IAX, JAX, X, IX, JX, DESCX, INCX, * IF( N.LE.0 ) THEN TAU( INDXTAU ) = ZERO +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -296,6 +341,10 @@ SUBROUTINE PCLARFG( N, ALPHA, IAX, JAX, X, IX, JX, DESCX, INCX, END IF END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLARFG diff --git a/SRC/pclarft.f b/SRC/pclarft.f index e5bb0101..3404eee1 100644 --- a/SRC/pclarft.f +++ b/SRC/pclarft.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLARFT( DIRECT, STOREV, N, K, V, IV, JV, DESCV, TAU, $ T, WORK ) * @@ -6,6 +11,7 @@ SUBROUTINE PCLARFT( DIRECT, STOREV, N, K, V, IV, JV, DESCV, TAU, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER DIRECT, STOREV INTEGER IV, JV, K, N @@ -200,10 +206,37 @@ SUBROUTINE PCLARFT( DIRECT, STOREV, N, K, V, IV, JV, DESCV, TAU, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) DIRECT, STOREV, IV, JV, K, + $ N, eos_str + 102 FORMAT('PCLARFT inputs: ,DIRECT:',A5,', STOREV:',A5, + $ ', IV:',I5,', JV:',I5,', K:',I5, + $ ', N:',I5, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Quick return if possible * - IF( N.LE.0 .OR. K.LE.0 ) - $ RETURN + IF( N.LE.0 .OR. K.LE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * ICTXT = DESCV( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) @@ -536,6 +569,10 @@ SUBROUTINE PCLARFT( DIRECT, STOREV, N, K, V, IV, JV, DESCV, TAU, * END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLARFT diff --git a/SRC/pclarz.f b/SRC/pclarz.f index 673860a0..1bfd4126 100644 --- a/SRC/pclarz.f +++ b/SRC/pclarz.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ IC, JC, DESCC, WORK ) * @@ -6,6 +11,7 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER SIDE INTEGER IC, INCV, IV, JC, JV, L, M, N @@ -269,10 +275,37 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) SIDE, IC, INCV, IV, JC, JV, + $ L, M, N, eos_str + 102 FORMAT('PCLARZ inputs: ,SIDE:',A5,', IC:',I5,', INCV:',I5, + $ ', IV:',I5,', JC:',I5,', JV:',I5, + $ ', L:',I5,', M:',I5,', N:',I5, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Quick return if possible * - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN + IF( M.LE.0 .OR. N.LE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Get grid parameters. * @@ -909,6 +942,10 @@ SUBROUTINE PCLARZ( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLARZ diff --git a/SRC/pclarzb.f b/SRC/pclarzb.f index d67a9030..a4a614bc 100644 --- a/SRC/pclarzb.f +++ b/SRC/pclarzb.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, $ IV, JV, DESCV, T, C, IC, JC, DESCC, WORK ) * @@ -5,6 +10,7 @@ SUBROUTINE PCLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, * Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver * May 1 2012 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER DIRECT, SIDE, STOREV, TRANS INTEGER IC, IV, JC, JV, K, L, M, N @@ -256,10 +262,38 @@ SUBROUTINE PCLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) DIRECT, SIDE, STOREV, TRANS, + $ IC, IV, JC, JV, K, L, M, N, eos_str + 102 FORMAT('PCLARZB inputs: ,DIRECT:',A5,', SIDE:',A5, + $ ', STOREV:',A5,', TRANS:',A5,', IC:',I5, + $ ', IV:',I5,', JC:',I5,', JV:',I5, + $ ', K:',I5,', L:',I5,', M:',I5,', N:',I5, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Quick return if possible * - IF( M.LE.0 .OR. N.LE.0 .OR. K.LE.0 ) - $ RETURN + IF( M.LE.0 .OR. N.LE.0 .OR. K.LE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Get grid parameters * @@ -277,6 +311,10 @@ SUBROUTINE PCLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCLARZB', -INFO ) CALL BLACS_ABORT( ICTXT, 1 ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -618,6 +656,10 @@ SUBROUTINE PCLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, * END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLARZB diff --git a/SRC/pclarzc.f b/SRC/pclarzc.f index b6d3b6d4..a2fbbcb6 100644 --- a/SRC/pclarzc.f +++ b/SRC/pclarzc.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, $ IC, JC, DESCC, WORK ) * @@ -6,6 +11,7 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER SIDE INTEGER IC, INCV, IV, JC, JV, L, M, N @@ -269,10 +275,37 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) SIDE, IC, INCV, IV, JC, JV, + $ L, M, N, eos_str + 102 FORMAT('PCLARZC inputs: ,SIDE:',A5,', IC:',I5, + $ ', INCV:',I5,', IV:',I5,', JC:',I5,', JV:',I5, + $ ', L:',I5,', M:',I5,', N:',I5, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Quick return if possible * - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN + IF( M.LE.0 .OR. N.LE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Get grid parameters. * @@ -911,6 +944,10 @@ SUBROUTINE PCLARZC( SIDE, M, N, L, V, IV, JV, DESCV, INCV, TAU, C, * END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLARZC diff --git a/SRC/pclarzt.f b/SRC/pclarzt.f index acc8da58..8362c381 100644 --- a/SRC/pclarzt.f +++ b/SRC/pclarzt.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLARZT( DIRECT, STOREV, N, K, V, IV, JV, DESCV, TAU, $ T, WORK ) * @@ -6,6 +11,7 @@ SUBROUTINE PCLARZT( DIRECT, STOREV, N, K, V, IV, JV, DESCV, TAU, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER DIRECT, STOREV INTEGER IV, JV, K, N @@ -211,11 +217,34 @@ SUBROUTINE PCLARZT( DIRECT, STOREV, N, K, V, IV, JV, DESCV, TAU, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCV( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) DIRECT, STOREV, IV, JV, K, + $ N, NPROW, NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCLARZT inputs: ,DIRECT:',A5,', STOREV:',A5, + $ ', IV:',I5,', JV:',I5,', K:',I5, + $ ', N:',I5,', NPROW: ', I5,', NPCOL: ', I5 , + $ ', MYROW: ', I5,', MYCOL: ', I5, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Check for currently supported options * INFO = 0 @@ -227,6 +256,10 @@ SUBROUTINE PCLARZT( DIRECT, STOREV, N, K, V, IV, JV, DESCV, TAU, IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCLARZT', -INFO ) CALL BLACS_ABORT( ICTXT, 1 ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -294,6 +327,10 @@ SUBROUTINE PCLARZT( DIRECT, STOREV, N, K, V, IV, JV, DESCV, TAU, * END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLARZT diff --git a/SRC/pclascl.f b/SRC/pclascl.f index 9b167b87..a9ac00ba 100644 --- a/SRC/pclascl.f +++ b/SRC/pclascl.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLASCL( TYPE, CFROM, CTO, M, N, A, IA, JA, DESCA, $ INFO ) * @@ -6,6 +11,7 @@ SUBROUTINE PCLASCL( TYPE, CFROM, CTO, M, N, A, IA, JA, DESCA, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER TYPE INTEGER IA, INFO, JA, M, N @@ -163,11 +169,36 @@ SUBROUTINE PCLASCL( TYPE, CFROM, CTO, M, N, A, IA, JA, DESCA, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) TYPE, IA, INFO, JA, M, N, CFROM, + $ CTO, NPROW, NPCOL, MYROW, MYCOL, + $ eos_str + 102 FORMAT('PCLASCL inputs: ,TYPE:',A5,', IA:',I5, + $ ', INFO:',I5,', JA:',I5,', M:',I5,', N:',I5, + $ ', CFROM:',F9.4,', CTO:',F9.4, + $ ', NPROW: ', I5,', NPCOL: ', I5 , + $ ', MYROW: ', I5,', MYCOL: ', I5, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * IF( NPROW.EQ.-1 ) THEN @@ -199,13 +230,22 @@ SUBROUTINE PCLASCL( TYPE, CFROM, CTO, M, N, A, IA, JA, DESCA, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCLASCL', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN + IF( N.EQ.0 .OR. M.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Get machine parameters * @@ -521,6 +561,10 @@ SUBROUTINE PCLASCL( TYPE, CFROM, CTO, M, N, A, IA, JA, DESCA, IF( .NOT.DONE ) $ GO TO 10 * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLASCL diff --git a/SRC/pclase2.f b/SRC/pclase2.f index 1424b22c..0c8c9c22 100644 --- a/SRC/pclase2.f +++ b/SRC/pclase2.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLASE2( UPLO, M, N, ALPHA, BETA, A, IA, JA, DESCA ) * * -- ScaLAPACK auxiliary routine (version 1.7) -- @@ -5,6 +10,7 @@ SUBROUTINE PCLASE2( UPLO, M, N, ALPHA, BETA, A, IA, JA, DESCA ) * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER IA, JA, M, N @@ -156,8 +162,36 @@ SUBROUTINE PCLASE2( UPLO, M, N, ALPHA, BETA, A, IA, JA, DESCA ) * .. * .. Executable Statements .. * - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, IA, JA, M, N, real(ALPHA), + $ ' + i ',aimag(ALPHA),real(BETA), + $ ' + i ',aimag(BETA), eos_str + 102 FORMAT('PCLASE2 inputs: ,UPLO:',A5,', IA:',I5, + $ ', JA:',I5,', M:',I5,', N:',I5,', ALPHA:',F9.4, A, F9.4, + $ ', BETA:',F9.4, A, F9.4, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Get grid parameters * @@ -212,8 +246,13 @@ SUBROUTINE PCLASE2( UPLO, M, N, ALPHA, BETA, A, IA, JA, DESCA ) IF( MYCOL.EQ.IACOL ) THEN * MPA = NUMROC( M+IROFFA, MBA, MYROW, IAROW, NPROW ) - IF( MPA.LE.0 ) - $ RETURN + IF( MPA.LE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF IF( MYROW.EQ.IAROW ) $ MPA = MPA - IROFFA MYDIST = MOD( MYROW-IAROW+NPROW, NPROW ) @@ -321,8 +360,13 @@ SUBROUTINE PCLASE2( UPLO, M, N, ALPHA, BETA, A, IA, JA, DESCA ) IF( MYROW.EQ.IAROW ) THEN * NQA = NUMROC( N+ICOFFA, NBA, MYCOL, IACOL, NPCOL ) - IF( NQA.LE.0 ) - $ RETURN + IF( NQA.LE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF IF( MYCOL.EQ.IACOL ) $ NQA = NQA - ICOFFA MYDIST = MOD( MYCOL-IACOL+NPCOL, NPCOL ) @@ -404,6 +448,10 @@ SUBROUTINE PCLASE2( UPLO, M, N, ALPHA, BETA, A, IA, JA, DESCA ) * END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLASE2 diff --git a/SRC/pclaset.f b/SRC/pclaset.f index a5504c0a..74a114d7 100644 --- a/SRC/pclaset.f +++ b/SRC/pclaset.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLASET( UPLO, M, N, ALPHA, BETA, A, IA, JA, DESCA ) * * -- ScaLAPACK auxiliary routine (version 1.7) -- @@ -5,6 +10,7 @@ SUBROUTINE PCLASET( UPLO, M, N, ALPHA, BETA, A, IA, JA, DESCA ) * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER IA, JA, M, N @@ -151,8 +157,36 @@ SUBROUTINE PCLASET( UPLO, M, N, ALPHA, BETA, A, IA, JA, DESCA ) * .. * .. Executable Statements .. * - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, IA, JA, M, N, real(ALPHA), + $ ' + i ',aimag(ALPHA),real(BETA), + $ ' + i ',aimag(BETA), eos_str + 102 FORMAT('PCLASET inputs: ,UPLO:',A5,', IA:',I5, + $ ', JA:',I5,', M:',I5,', N:',I5,', ALPHA:',F9.4, A, F9.4, + $ ', BETA:',F9.4, A, F9.4, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF +* + IF( M.EQ.0 .OR. N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * IF( M.LE.( DESCA( MB_ ) - MOD( IA-1, DESCA( MB_ ) ) ) .OR. $ N.LE.( DESCA( NB_ ) - MOD( JA-1, DESCA( NB_ ) ) ) ) THEN @@ -213,6 +247,10 @@ SUBROUTINE PCLASET( UPLO, M, N, ALPHA, BETA, A, IA, JA, DESCA ) * END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLASET diff --git a/SRC/pclasmsub.f b/SRC/pclasmsub.f index a21564fa..9adfdfaf 100644 --- a/SRC/pclasmsub.f +++ b/SRC/pclasmsub.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLASMSUB( A, DESCA, I, L, K, SMLNUM, BUF, LWORK ) * * -- ScaLAPACK routine (version 1.7) -- @@ -5,6 +10,7 @@ SUBROUTINE PCLASMSUB( A, DESCA, I, L, K, SMLNUM, BUF, LWORK ) * and University of California, Berkeley. * July 31, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. INTEGER I, K, L, LWORK REAL SMLNUM @@ -175,12 +181,35 @@ SUBROUTINE PCLASMSUB( A, DESCA, I, L, K, SMLNUM, BUF, LWORK ) CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) ) * .. * .. Executable Statements .. +* +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F * HBL = DESCA( MB_ ) CONTXT = DESCA( CTXT_ ) LDA = DESCA( LLD_ ) ULP = PSLAMCH( CONTXT, 'PRECISION' ) CALL BLACS_GRIDINFO( CONTXT, NPROW, NPCOL, MYROW, MYCOL ) +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) I, K, L, LWORK, SMLNUM, NPROW, + $ NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCLASMSUB inputs: ,I:',I5,', K:',I5,', L:',I5, + $ ', LWORK:',I5,', SMLNUM:',F9.4, + $ ', NPROW: ', I5,', NPCOL: ', I5 , + $ ', MYROW: ', I5,', MYCOL: ', I5, A1) + AOCL_DTL_LOG_ENTRY_F + END IF LEFT = MOD( MYCOL+NPCOL-1, NPCOL ) RIGHT = MOD( MYCOL+1, NPCOL ) UP = MOD( MYROW+NPROW-1, NPROW ) @@ -204,6 +233,10 @@ SUBROUTINE PCLASMSUB( A, DESCA, I, L, K, SMLNUM, BUF, LWORK ) * * Error! * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF CALL INFOG2L( I, I, DESCA, NPROW, NPCOL, MYROW, MYCOL, IROW1, @@ -370,6 +403,10 @@ SUBROUTINE PCLASMSUB( A, DESCA, I, L, K, SMLNUM, BUF, LWORK ) 50 CONTINUE CALL IGAMX2D( CONTXT, 'ALL', ' ', 1, 1, K, 1, ITMP1, ITMP2, -1, $ -1, -1 ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLASMSUB diff --git a/SRC/pclassq.f b/SRC/pclassq.f index c1245e25..5d137352 100644 --- a/SRC/pclassq.f +++ b/SRC/pclassq.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLASSQ( N, X, IX, JX, DESCX, INCX, SCALE, SUMSQ ) * * -- ScaLAPACK auxiliary routine (version 1.7) -- @@ -5,6 +10,7 @@ SUBROUTINE PCLASSQ( N, X, IX, JX, DESCX, INCX, SCALE, SUMSQ ) * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. INTEGER IX, INCX, JX, N REAL SCALE, SUMSQ @@ -168,11 +174,34 @@ SUBROUTINE PCLASSQ( N, X, IX, JX, DESCX, INCX, SCALE, SUMSQ ) * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters. * ICTXT = DESCX( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) IX, INCX, JX, N, SCALE, SUMSQ, + $ NPROW, NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCLASSQ inputs: ,IX:',I5,', INCX:',I5, + $ ', JX:',I5,', N:',I5,', SCALE:',F9.4, + $ ', SUMSQ:',F9.4,', NPROW: ', I5,', NPCOL: ', I5 , + $ ', MYROW: ', I5,', MYCOL: ', I5, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Figure local indexes * CALL INFOG2L( IX, JX, DESCX, NPROW, NPCOL, MYROW, MYCOL, IIX, JJX, @@ -183,8 +212,13 @@ SUBROUTINE PCLASSQ( N, X, IX, JX, DESCX, INCX, SCALE, SUMSQ ) * * X is rowwise distributed. * - IF( MYROW.NE.IXROW ) - $ RETURN + IF( MYROW.NE.IXROW ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF ICOFF = MOD( JX, DESCX( NB_ ) ) NQ = NUMROC( N+ICOFF, DESCX( NB_ ), MYCOL, IXCOL, NPCOL ) IF( MYCOL.EQ.IXCOL ) @@ -232,8 +266,13 @@ SUBROUTINE PCLASSQ( N, X, IX, JX, DESCX, INCX, SCALE, SUMSQ ) * * X is columnwise distributed. * - IF( MYCOL.NE.IXCOL ) - $ RETURN + IF( MYCOL.NE.IXCOL ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF IROFF = MOD( IX, DESCX( MB_ ) ) NP = NUMROC( N+IROFF, DESCX( MB_ ), MYROW, IXROW, NPROW ) IF( MYROW.EQ.IXROW ) @@ -279,6 +318,10 @@ SUBROUTINE PCLASSQ( N, X, IX, JX, DESCX, INCX, SCALE, SUMSQ ) * END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLASSQ diff --git a/SRC/pclaswp.f b/SRC/pclaswp.f index 3548b779..8f6454d0 100644 --- a/SRC/pclaswp.f +++ b/SRC/pclaswp.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLASWP( DIREC, ROWCOL, N, A, IA, JA, DESCA, K1, K2, $ IPIV ) * @@ -6,6 +11,7 @@ SUBROUTINE PCLASWP( DIREC, ROWCOL, N, A, IA, JA, DESCA, K1, K2, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER DIREC, ROWCOL INTEGER IA, JA, K1, K2, N @@ -152,10 +158,37 @@ SUBROUTINE PCLASWP( DIREC, ROWCOL, N, A, IA, JA, DESCA, K1, K2, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) DIREC, ROWCOL, IA, JA, K1, + $ K2, N, eos_str + 102 FORMAT('PCLASWP inputs: ,DIREC:',A5,', ROWCOL:',A5, + $ ', IA:',I5,', JA:',I5,', K1:',I5, + $ ', K2:',I5,', N:',I5, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * CALL BLACS_GRIDINFO( DESCA( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL ) * @@ -201,6 +234,10 @@ SUBROUTINE PCLASWP( DIREC, ROWCOL, N, A, IA, JA, DESCA, K1, K2, END IF END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End PCLASWP diff --git a/SRC/pclatra.f b/SRC/pclatra.f index a62a5cf4..f4eeb7eb 100644 --- a/SRC/pclatra.f +++ b/SRC/pclatra.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* COMPLEX FUNCTION PCLATRA( N, A, IA, JA, DESCA ) * * -- ScaLAPACK auxiliary routine (version 1.7) -- @@ -5,6 +10,7 @@ COMPLEX FUNCTION PCLATRA( N, A, IA, JA, DESCA ) * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. INTEGER IA, JA, N * .. @@ -125,13 +131,39 @@ COMPLEX FUNCTION PCLATRA( N, A, IA, JA, DESCA ) * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * CALL BLACS_GRIDINFO( DESCA( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL ) +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) IA, JA, N, NPROW, NPCOL, MYROW, + $ MYCOL, eos_str + 102 FORMAT('PCLATRA inputs: ,IA:',I5,', JA:',I5,', N:',I5, + $ ', NPROW: ', I5,', NPCOL: ', I5 ,', MYROW: ', I5, + $ ', MYCOL: ', I5, A1) + AOCL_DTL_LOG_ENTRY_F + END IF * TRACE = ZERO IF( N.EQ.0 ) THEN PCLATRA = TRACE +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -180,6 +212,10 @@ COMPLEX FUNCTION PCLATRA( N, A, IA, JA, DESCA ) * PCLATRA = TRACE * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLATRA diff --git a/SRC/pclatrd.f b/SRC/pclatrd.f index 3a86fa78..f11c9a54 100644 --- a/SRC/pclatrd.f +++ b/SRC/pclatrd.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLATRD( UPLO, N, NB, A, IA, JA, DESCA, D, E, TAU, W, $ IW, JW, DESCW, WORK ) * @@ -6,6 +11,7 @@ SUBROUTINE PCLATRD( UPLO, N, NB, A, IA, JA, DESCA, D, E, TAU, W, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER IA, IW, JA, JW, N, NB @@ -253,10 +259,37 @@ SUBROUTINE PCLATRD( UPLO, N, NB, A, IA, JA, DESCA, D, E, TAU, W, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, IA, IW, JA, JW, N, NB, + $ eos_str + 102 FORMAT('PCLATRD inputs: ,UPLO:',A5,', IA:',I5, + $ ', IW:',I5,', JA:',I5,', JW:',I5,', N:',I5, + $ ', NB:',I5, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Quick return if possible * - IF( N.LE.0 ) - $ RETURN + IF( N.LE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) @@ -428,6 +461,10 @@ SUBROUTINE PCLATRD( UPLO, N, NB, A, IA, JA, DESCA, D, E, TAU, W, END IF END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLATRD diff --git a/SRC/pclatrs.f b/SRC/pclatrs.f index 62d28a78..810b3c2e 100644 --- a/SRC/pclatrs.f +++ b/SRC/pclatrs.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, $ JA, DESCA, X, IX, JX, DESCX, SCALE, CNORM, $ WORK ) @@ -7,6 +12,7 @@ SUBROUTINE PCLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO INTEGER IA, IX, JA, JX, N @@ -49,15 +55,46 @@ SUBROUTINE PCLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) DIAG, NORMIN, TRANS, UPLO, + $ IA, IX, JA, JX, N, SCALE, NPROW, NPCOL, + $ MYROW, MYCOL, eos_str + 102 FORMAT('PCLATRS inputs: ,DIAG:',A5,', NORMIN:',A5, + $ ', TRANS:',A5,', UPLO:',A5,', IA:',I5, + $ ', IX:',I5,', JA:',I5,', JX:',I5, + $ ', N:',I5,', SCALE:',F9.4,', NPROW: ', I5, + $ ', NPCOL: ', I5 ,', MYROW: ', I5, + $ ', MYCOL: ', I5, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * ***** NO SCALING ***** Call PCTRSV for all cases ***** * @@ -80,6 +117,10 @@ SUBROUTINE PCLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, $ LDX, MYROW, IXCOL ) END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLATRS diff --git a/SRC/pclatrz.f b/SRC/pclatrz.f index cadca18a..0117af5c 100644 --- a/SRC/pclatrz.f +++ b/SRC/pclatrz.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLATRZ( M, N, L, A, IA, JA, DESCA, TAU, WORK ) * * -- ScaLAPACK routine (version 1.7) -- @@ -5,6 +10,7 @@ SUBROUTINE PCLATRZ( M, N, L, A, IA, JA, DESCA, TAU, WORK ) * and University of California, Berkeley. * December 31, 1998 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. INTEGER IA, JA, L, M, N * .. @@ -196,10 +202,35 @@ SUBROUTINE PCLATRZ( M, N, L, A, IA, JA, DESCA, TAU, WORK ) * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) IA, JA, L, M, N, eos_str + 102 FORMAT('PCLATRZ inputs: ,IA:',I5,', JA:',I5,', L:',I5, + $ ', M:',I5,', N:',I5, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Quick return if possible * - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN + IF( M.EQ.0 .OR. N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Get grid parameters * @@ -248,6 +279,10 @@ SUBROUTINE PCLATRZ( M, N, L, A, IA, JA, DESCA, TAU, WORK ) * END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLATRZ diff --git a/SRC/pclattrs.f b/SRC/pclattrs.f index b0de2c6f..b20f1eb5 100644 --- a/SRC/pclattrs.f +++ b/SRC/pclattrs.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, $ DESCA, X, IX, JX, DESCX, SCALE, CNORM, INFO ) * @@ -6,6 +11,7 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, * and University of California, Berkeley. * July 31, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER DIAG, NORMIN, TRANS, UPLO INTEGER IA, INFO, IX, JA, JX, N @@ -306,6 +312,16 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, $ ABS( AIMAG( ZDUM ) / 2.E0 ) * .. * .. Executable Statements .. +* +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F * INFO = 0 UPPER = LSAME( UPLO, 'U' ) @@ -337,16 +353,41 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, END IF * CALL BLACS_GRIDINFO( CONTXT, NPROW, NPCOL, MYROW, MYCOL ) +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) DIAG, NORMIN, TRANS, UPLO, + $ IA, INFO, IX, JA, JX, N, SCALE, NPROW, + $ NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCLATTRS inputs: ,DIAG:',A5,', NORMIN:',A5, + $ ', TRANS:',A5,', UPLO:',A5,', IA:',I5, + $ ', INFO:',I5,', IX:',I5,', JA:',I5, + $ ', JX:',I5,', N:',I5,', SCALE:',F9.4, + $ ', NPROW: ', I5,', NPCOL: ', I5 , + $ ', MYROW: ', I5,', MYCOL: ', I5, A1) + AOCL_DTL_LOG_ENTRY_F + END IF * IF( INFO.NE.0 ) THEN CALL PXERBLA( CONTXT, 'PCLATTRS', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Determine machine dependent parameters to control overflow. * @@ -891,10 +932,10 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL PCSCAL( N-J, ZDUM, A, IA+J, JA+J-1, DESCA, 1 ) CALL PCDOTU( N-J, CSUMJ, A, IA+J, JA+J-1, DESCA, 1, $ X, IX+J, JX, DESCX, 1 ) - + #ifdef F2C CALL CLADIV( ZDUM, ZDUM, USCAL ) -#else +#else ZDUM = CLADIV( ZDUM, USCAL ) #endif CALL PCSCAL( N-J, ZDUM, A, IA+J, JA+J-1, DESCA, 1 ) @@ -1283,6 +1324,10 @@ SUBROUTINE PCLATTRS( UPLO, TRANS, DIAG, NORMIN, N, A, IA, JA, CALL SSCAL( N, ONE / TSCAL, CNORM, 1 ) END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLATTRS diff --git a/SRC/pclauu2.f b/SRC/pclauu2.f index ce3e2dc5..1e23e1cc 100644 --- a/SRC/pclauu2.f +++ b/SRC/pclauu2.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLAUU2( UPLO, N, A, IA, JA, DESCA ) * * -- ScaLAPACK auxiliary routine (version 1.7) -- @@ -5,6 +10,7 @@ SUBROUTINE PCLAUU2( UPLO, N, A, IA, JA, DESCA ) * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER IA, JA, N @@ -141,7 +147,7 @@ SUBROUTINE PCLAUU2( UPLO, N, A, IA, JA, DESCA ) * .. * .. External Functions .. LOGICAL LSAME -#ifndef F2C +#ifndef F2C COMPLEX CDOTC #endif EXTERNAL CDOTC, LSAME @@ -151,10 +157,35 @@ SUBROUTINE PCLAUU2( UPLO, N, A, IA, JA, DESCA ) * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, IA, JA, N, eos_str + 102 FORMAT('PCLAUU2 inputs: ,UPLO:',A5,', IA:',I5, + $ ', JA:',I5,', N:',I5, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Get grid parameters and compute local indexes * @@ -176,10 +207,10 @@ SUBROUTINE PCLAUU2( UPLO, N, A, IA, JA, DESCA ) AII = A( IDIAG ) ICURR = IDIAG + LDA #ifdef F2C - CALL CDOTC( TMP, NA, A( ICURR ), LDA, + CALL CDOTC( TMP, NA, A( ICURR ), LDA, $ A( ICURR ), LDA ) A( IDIAG ) = AII*AII + REAL( TMP ) -#else +#else A( IDIAG ) = AII*AII + REAL( CDOTC( NA, A( ICURR ), LDA, $ A( ICURR ), LDA ) ) #endif @@ -224,6 +255,10 @@ SUBROUTINE PCLAUU2( UPLO, N, A, IA, JA, DESCA ) * END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLAUU2 diff --git a/SRC/pclauum.f b/SRC/pclauum.f index 5250ebba..8aeb63ca 100644 --- a/SRC/pclauum.f +++ b/SRC/pclauum.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLAUUM( UPLO, N, A, IA, JA, DESCA ) * * -- ScaLAPACK auxiliary routine (version 1.7) -- @@ -5,6 +10,7 @@ SUBROUTINE PCLAUUM( UPLO, N, A, IA, JA, DESCA ) * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER IA, JA, N @@ -143,10 +149,35 @@ SUBROUTINE PCLAUUM( UPLO, N, A, IA, JA, DESCA ) * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, IA, JA, N, eos_str + 102 FORMAT('PCLAUUM inputs: ,UPLO:',A5,', IA:',I5, + $ ', JA:',I5,', N:',I5, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * JN = MIN( ICEIL( JA, DESCA( NB_ ) ) * DESCA( NB_ ), JA+N-1 ) IF( LSAME( UPLO, 'U' ) ) THEN @@ -213,6 +244,10 @@ SUBROUTINE PCLAUUM( UPLO, N, A, IA, JA, DESCA ) 20 CONTINUE END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLAUUM diff --git a/SRC/pclawil.f b/SRC/pclawil.f index b33b3b1a..b6dd12a8 100644 --- a/SRC/pclawil.f +++ b/SRC/pclawil.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCLAWIL( II, JJ, M, A, DESCA, H44, H33, H43H34, V ) * * -- ScaLAPACK routine (version 1.7) -- @@ -5,6 +10,7 @@ SUBROUTINE PCLAWIL( II, JJ, M, A, DESCA, H44, H33, H43H34, V ) * and University of California, Berkeley. * July 31, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. INTEGER II, JJ, M COMPLEX H33, H43H34, H44 @@ -142,11 +148,37 @@ SUBROUTINE PCLAWIL( II, JJ, M, A, DESCA, H44, H33, H43H34, V ) CABS1( CDUM ) = ABS( REAL( CDUM ) ) + ABS( AIMAG( CDUM ) ) * .. * .. Executable Statements .. +* +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F * HBL = DESCA( MB_ ) CONTXT = DESCA( CTXT_ ) LDA = DESCA( LLD_ ) CALL BLACS_GRIDINFO( CONTXT, NPROW, NPCOL, MYROW, MYCOL ) +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) II, JJ, M, real(H33),' + i ', + $ aimag(H33),real(H43H34),' + i ',aimag(H43H34), + $ real(H44),' + i ',aimag(H44), + $ NPROW, NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCLAWIL inputs: ,II:',I5,', JJ:',I5,', M:',I5, + $ ', H33:',F9.4, A, F9.4,', H43H34:',F9.4, A, F9.4, + $ ', H44:',F9.4, A, F9.4, + $ ', NPROW: ', I5,', NPCOL: ', I5 , + $ ', MYROW: ', I5,', MYCOL: ', I5, A1) + AOCL_DTL_LOG_ENTRY_F + END IF LEFT = MOD( MYCOL+NPCOL-1, NPCOL ) RIGHT = MOD( MYCOL+1, NPCOL ) UP = MOD( MYROW+NPROW-1, NPROW ) @@ -240,8 +272,13 @@ SUBROUTINE PCLAWIL( II, JJ, M, A, DESCA, H44, H33, H43H34, V ) V3( 1 ) = A( ( ICOL-2 )*LDA+IROW ) END IF END IF - IF( ( MYROW.NE.II ) .OR. ( MYCOL.NE.JJ ) ) - $ RETURN + IF( ( MYROW.NE.II ) .OR. ( MYCOL.NE.JJ ) ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * IF( MODKM1.GT.1 ) THEN CALL INFOG2L( M+2, M+2, DESCA, NPROW, NPCOL, MYROW, MYCOL, @@ -265,6 +302,10 @@ SUBROUTINE PCLAWIL( II, JJ, M, A, DESCA, H44, H33, H43H34, V ) V( 2 ) = V2 V( 3 ) = V3( 1 ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCLAWIL diff --git a/SRC/pcmax1.f b/SRC/pcmax1.f index 168bab7d..9540fb00 100644 --- a/SRC/pcmax1.f +++ b/SRC/pcmax1.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCMAX1( N, AMAX, INDX, X, IX, JX, DESCX, INCX ) * * -- ScaLAPACK auxiliary routine (version 1.7) -- @@ -5,6 +11,7 @@ SUBROUTINE PCMAX1( N, AMAX, INDX, X, IX, JX, DESCX, INCX ) * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. INTEGER INDX, INCX, IX, JX, N COMPLEX AMAX @@ -177,17 +184,47 @@ SUBROUTINE PCMAX1( N, AMAX, INDX, X, IX, JX, DESCX, INCX ) * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCX( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) INDX, INCX, IX, JX, N, real(AMAX), + $ ' + i ',aimag(AMAX), NPROW, NPCOL, + $ MYROW, MYCOL, eos_str + 102 FORMAT('PCMAX1 inputs: ,INDX:',I5,', INCX:',I5, + $ ', IX:',I5,', JX:',I5,', N:',I5, + $ ', AMAX:',F9.4, A, F9.4,', NPROW: ', I5, + $ ', NPCOL: ', I5 ,', MYROW: ', I5,', MYCOL: ', I5,A1) + + AOCL_DTL_LOG_ENTRY_F + END IF +* * Quick return if possible. * INDX = 0 AMAX = ZERO - IF( N.LE.0 ) - $ RETURN + IF( N.LE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Retrieve local information for vector X. * @@ -198,6 +235,10 @@ SUBROUTINE PCMAX1( N, AMAX, INDX, X, IX, JX, DESCX, INCX ) IF( INCX.EQ.1 .AND. DESCX( M_ ).EQ.1 .AND. N.EQ.1 ) THEN INDX = JX AMAX = X( IIX+(JJX-1)*LDX ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -351,11 +392,18 @@ SUBROUTINE PCMAX1( N, AMAX, INDX, X, IX, JX, DESCX, INCX ) * END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCMAX1 * END +* +* +#include "SL_Context_fortran_include.h" * SUBROUTINE CCOMBAMAX1 ( V1, V2 ) * @@ -391,12 +439,26 @@ SUBROUTINE CCOMBAMAX1 ( V1, V2 ) INTRINSIC ABS, REAL * .. * .. Executable Statements .. +* +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F * IF( ABS( REAL( V1( 1 ) ) ).LT.ABS( REAL( V2( 1 ) ) ) ) THEN V1( 1 ) = V2( 1 ) V1( 2 ) = V2( 2 ) END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of CCOMBAMAX1 diff --git a/SRC/pcpbsv.f b/SRC/pcpbsv.f index 38ab4175..801e623b 100644 --- a/SRC/pcpbsv.f +++ b/SRC/pcpbsv.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCPBSV( UPLO, N, BW, NRHS, A, JA, DESCA, B, IB, DESCB, $ WORK, LWORK, INFO ) * @@ -8,6 +14,7 @@ SUBROUTINE PCPBSV( UPLO, N, BW, NRHS, A, JA, DESCA, B, IB, DESCB, * and University of California, Berkeley. * November 15, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER BW, IB, INFO, JA, LWORK, N, NRHS @@ -387,6 +394,28 @@ SUBROUTINE PCPBSV( UPLO, N, BW, NRHS, A, JA, DESCA, B, IB, DESCB, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, BW, IB, INFO, JA, LWORK, + $ N, NRHS, eos_str + 102 FORMAT('PCPBSV inputs: ,UPLO:',A5,', BW:',I9,', IB:',I9, + $ ', INFO:',I9,', JA:',I9,', LWORK:',I9, + $ ', N:',I9,', NRHS:',I9, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Note: to avoid duplication, most error checking is not performed * in this routine and is left to routines * PCPBTRF and PCPBTRS. @@ -408,6 +437,10 @@ SUBROUTINE PCPBSV( UPLO, N, BW, NRHS, A, JA, DESCA, B, IB, DESCB, CALL PXERBLA( ICTXT, $ 'PCPBSV', $ -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ENDIF * @@ -430,6 +463,10 @@ SUBROUTINE PCPBSV( UPLO, N, BW, NRHS, A, JA, DESCA, B, IB, DESCB, IF( INFO .LT. 0 ) THEN CALL PXERBLA( ICTXT, 'PCPBSV', -INFO ) ENDIF +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -443,9 +480,17 @@ SUBROUTINE PCPBSV( UPLO, N, BW, NRHS, A, JA, DESCA, B, IB, DESCB, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCPBSV', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCPBSV diff --git a/SRC/pcpbtrf.f b/SRC/pcpbtrf.f index 2c857818..e9e6c6e1 100644 --- a/SRC/pcpbtrf.f +++ b/SRC/pcpbtrf.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCPBTRF( UPLO, N, BW, A, JA, DESCA, AF, LAF, WORK, $ LWORK, INFO ) * @@ -5,6 +11,7 @@ SUBROUTINE PCPBTRF( UPLO, N, BW, A, JA, DESCA, AF, LAF, WORK, * Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver * May 1 2012 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER BW, INFO, JA, LAF, LWORK, N @@ -394,6 +401,16 @@ SUBROUTINE PCPBTRF( UPLO, N, BW, A, JA, DESCA, AF, LAF, WORK, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Test the input parameters * INFO = 0 @@ -425,6 +442,21 @@ SUBROUTINE PCPBTRF( UPLO, N, BW, A, JA, DESCA, AF, LAF, WORK, MBW2 = BW * BW * CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, BW, INFO, JA, LAF, LWORK, + $ N, NPROW, NPCOL, MYROW, MYCOL, + $ eos_str + 102 FORMAT('PCPBTRF inputs: ,UPLO:',A5,', BW:',I9, + $ ', INFO:',I9,', JA:',I9,', LAF:',I9, + $ ', LWORK:',I9,', N:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9, + $ ', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF NP = NPROW * NPCOL * * @@ -477,6 +509,10 @@ SUBROUTINE PCPBTRF( UPLO, N, BW, A, JA, DESCA, AF, LAF, WORK, CALL PXERBLA( ICTXT, $ 'PCPBTRF, D&C alg.: only 1 block per proc', $ -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ENDIF * @@ -485,6 +521,10 @@ SUBROUTINE PCPBTRF( UPLO, N, BW, A, JA, DESCA, AF, LAF, WORK, CALL PXERBLA( ICTXT, $ 'PCPBTRF, D&C alg.: NB too small', $ -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ENDIF * @@ -500,6 +540,10 @@ SUBROUTINE PCPBTRF( UPLO, N, BW, A, JA, DESCA, AF, LAF, WORK, CALL PXERBLA( ICTXT, $ 'PCPBTRF: auxiliary storage error ', $ -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ENDIF * @@ -516,6 +560,10 @@ SUBROUTINE PCPBTRF( UPLO, N, BW, A, JA, DESCA, AF, LAF, WORK, $ 'PCPBTRF: worksize error ', $ -INFO ) ENDIF +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ENDIF * @@ -571,13 +619,22 @@ SUBROUTINE PCPBTRF( UPLO, N, BW, A, JA, DESCA, AF, LAF, WORK, * IF( INFO.LT.0 ) THEN CALL PXERBLA( ICTXT, 'PCPBTRF', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * * Adjust addressing into matrix space to properly get into @@ -1500,6 +1557,10 @@ SUBROUTINE PCPBTRF( UPLO, N, BW, A, JA, DESCA, AF, LAF, WORK, ENDIF * * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCPBTRF diff --git a/SRC/pcpbtrs.f b/SRC/pcpbtrs.f index fc14b8dd..e6e1f953 100644 --- a/SRC/pcpbtrs.f +++ b/SRC/pcpbtrs.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCPBTRS( UPLO, N, BW, NRHS, A, JA, DESCA, B, IB, DESCB, $ AF, LAF, WORK, LWORK, INFO ) * @@ -6,8 +12,9 @@ SUBROUTINE PCPBTRS( UPLO, N, BW, NRHS, A, JA, DESCA, B, IB, DESCB, * -- ScaLAPACK routine (version 1.7) -- * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. -* August 7, 2001 +* August 7, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER BW, IB, INFO, JA, LAF, LWORK, N, NRHS @@ -404,6 +411,16 @@ SUBROUTINE PCPBTRS( UPLO, N, BW, NRHS, A, JA, DESCA, B, IB, DESCB, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Test the input parameters * INFO = 0 @@ -461,6 +478,21 @@ SUBROUTINE PCPBTRS( UPLO, N, BW, NRHS, A, JA, DESCA, B, IB, DESCB, * * CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, BW, IB, INFO, JA, LAF, + $ LWORK, N, NRHS, NPROW, NPCOL, MYROW, + $ MYCOL, eos_str + 102 FORMAT('PCPBTRS inputs: ,UPLO:',A5,', BW:',I9, + $ ', IB:',I9,', INFO:',I9,', JA:',I9,', LAF:',I9, + $ ', LWORK:',I9,', N:',I9,', NRHS:',I9, + $ ', NPROW: ', I9,', NPCOL: ', I9 , + $ ', MYROW: ', I9,', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF NP = NPROW * NPCOL * * @@ -531,6 +563,10 @@ SUBROUTINE PCPBTRS( UPLO, N, BW, NRHS, A, JA, DESCA, B, IB, DESCB, CALL PXERBLA( ICTXT, $ 'PCPBTRS, D&C alg.: only 1 block per proc', $ -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ENDIF * @@ -539,6 +575,10 @@ SUBROUTINE PCPBTRS( UPLO, N, BW, NRHS, A, JA, DESCA, B, IB, DESCB, CALL PXERBLA( ICTXT, $ 'PCPBTRS, D&C alg.: NB too small', $ -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ENDIF * @@ -555,6 +595,10 @@ SUBROUTINE PCPBTRS( UPLO, N, BW, NRHS, A, JA, DESCA, B, IB, DESCB, $ 'PCPBTRS: worksize error', $ -INFO ) ENDIF +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ENDIF * @@ -624,16 +668,30 @@ SUBROUTINE PCPBTRS( UPLO, N, BW, NRHS, A, JA, DESCA, B, IB, DESCB, * IF( INFO.LT.0 ) THEN CALL PXERBLA( ICTXT, 'PCPBTRS', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file * - IF( NRHS.EQ.0 ) - $ RETURN + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF +* + IF( NRHS.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * * Adjust addressing into matrix space to properly get into @@ -746,6 +804,10 @@ SUBROUTINE PCPBTRS( UPLO, N, BW, NRHS, A, JA, DESCA, B, IB, DESCB, WORK( 1 ) = WORK_SIZE_MIN * * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCPBTRS diff --git a/SRC/pcpbtrsv.f b/SRC/pcpbtrsv.f index 2ec2835a..27c8c3c2 100644 --- a/SRC/pcpbtrsv.f +++ b/SRC/pcpbtrsv.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCPBTRSV( UPLO, TRANS, N, BW, NRHS, A, JA, DESCA, B, $ IB, DESCB, AF, LAF, WORK, LWORK, INFO ) * @@ -5,6 +11,7 @@ SUBROUTINE PCPBTRSV( UPLO, TRANS, N, BW, NRHS, A, JA, DESCA, B, * Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver * May 1 2012 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER TRANS, UPLO INTEGER BW, IB, INFO, JA, LAF, LWORK, N, NRHS @@ -411,6 +418,16 @@ SUBROUTINE PCPBTRSV( UPLO, TRANS, N, BW, NRHS, A, JA, DESCA, B, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Test the input parameters * INFO = 0 @@ -472,6 +489,22 @@ SUBROUTINE PCPBTRSV( UPLO, TRANS, N, BW, NRHS, A, JA, DESCA, B, MBW2 = BW * BW * CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) TRANS, UPLO, BW, IB, INFO, + $ JA, LAF, LWORK, N, NRHS, NPROW, NPCOL, + $ MYROW, MYCOL, eos_str + 102 FORMAT('PCPBTRSV inputs: ,TRANS:',A5,', UPLO:',A5, + $ ', BW:',I9,', IB:',I9,', INFO:',I9, + $ ', JA:',I9,', LAF:',I9,', LWORK:',I9, + $ ', N:',I9,', NRHS:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9, + $ ', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF NP = NPROW * NPCOL * * @@ -550,6 +583,10 @@ SUBROUTINE PCPBTRSV( UPLO, TRANS, N, BW, NRHS, A, JA, DESCA, B, CALL PXERBLA( ICTXT, $ 'PCPBTRSV, D&C alg.: only 1 block per proc', $ -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ENDIF * @@ -558,6 +595,10 @@ SUBROUTINE PCPBTRSV( UPLO, TRANS, N, BW, NRHS, A, JA, DESCA, B, CALL PXERBLA( ICTXT, $ 'PCPBTRSV, D&C alg.: NB too small', $ -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ENDIF * @@ -574,6 +615,10 @@ SUBROUTINE PCPBTRSV( UPLO, TRANS, N, BW, NRHS, A, JA, DESCA, B, $ 'PCPBTRSV: worksize error', $ -INFO ) ENDIF +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ENDIF * @@ -645,16 +690,30 @@ SUBROUTINE PCPBTRSV( UPLO, TRANS, N, BW, NRHS, A, JA, DESCA, B, * IF( INFO.LT.0 ) THEN CALL PXERBLA( ICTXT, 'PCPBTRSV', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file * - IF( NRHS.EQ.0 ) - $ RETURN + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF +* + IF( NRHS.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * * Adjust addressing into matrix space to properly get into @@ -1555,6 +1614,10 @@ SUBROUTINE PCPBTRSV( UPLO, TRANS, N, BW, NRHS, A, JA, DESCA, B, WORK( 1 ) = WORK_SIZE_MIN * * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCPBTRSV diff --git a/SRC/pcpocon.f b/SRC/pcpocon.f index e8cc99cf..6ae28a38 100644 --- a/SRC/pcpocon.f +++ b/SRC/pcpocon.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCPOCON( UPLO, N, A, IA, JA, DESCA, ANORM, RCOND, WORK, $ LWORK, RWORK, LRWORK, INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCPOCON( UPLO, N, A, IA, JA, DESCA, ANORM, RCOND, WORK, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER IA, INFO, JA, LRWORK, LWORK, N @@ -212,11 +219,37 @@ SUBROUTINE PCPOCON( UPLO, N, A, IA, JA, DESCA, ANORM, RCOND, WORK, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, IA, INFO, JA, LRWORK, + $ LWORK, N, ANORM, RCOND, NPROW, NPCOL, + $ MYROW, MYCOL, eos_str + 102 FORMAT('PCPOCON inputs: ,UPLO:',A5,', IA:',I9, + $ ', INFO:',I9,', JA:',I9,', LRWORK:',I9, + $ ', LWORK:',I9,', N:',I9,', ANORM:',F9.4, + $ ', RCOND:',F9.4,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9, + $ ', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -279,8 +312,16 @@ SUBROUTINE PCPOCON( UPLO, N, A, IA, JA, DESCA, ANORM, RCOND, WORK, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCPOCON', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -289,11 +330,23 @@ SUBROUTINE PCPOCON( UPLO, N, A, IA, JA, DESCA, ANORM, RCOND, WORK, RCOND = ZERO IF( N.EQ.0 ) THEN RCOND = ONE +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( ANORM.EQ.ZERO ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( N.EQ.1 ) THEN RCOND = ONE +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -406,6 +459,10 @@ SUBROUTINE PCPOCON( UPLO, N, A, IA, JA, DESCA, ANORM, RCOND, WORK, CALL PB_TOPSET( ICTXT, 'Combine', 'Columnwise', COLCTOP ) CALL PB_TOPSET( ICTXT, 'Combine', 'Rowwise', ROWCTOP ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCPOCON diff --git a/SRC/pcpoequ.f b/SRC/pcpoequ.f index 744517c7..0173ee09 100644 --- a/SRC/pcpoequ.f +++ b/SRC/pcpoequ.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCPOEQU( N, A, IA, JA, DESCA, SR, SC, SCOND, AMAX, $ INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCPOEQU( N, A, IA, JA, DESCA, SR, SC, SCOND, AMAX, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. INTEGER IA, INFO, JA, N REAL AMAX, SCOND @@ -181,11 +188,34 @@ SUBROUTINE PCPOEQU( N, A, IA, JA, DESCA, SR, SC, SCOND, AMAX, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) IA, INFO, JA, N, AMAX, SCOND, + $ NPROW, NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCPOEQU inputs: ,IA:',I9,', INFO:',I9, + $ ', JA:',I9,', N:',I9,', AMAX:',F9.4, + $ ', SCOND:',F9.4,', NPROW: ', I9,', NPCOL: ', I9 , + $ ', MYROW: ', I9,', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters. * INFO = 0 @@ -199,6 +229,10 @@ SUBROUTINE PCPOEQU( N, A, IA, JA, DESCA, SR, SC, SCOND, AMAX, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCPOEQU', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -207,6 +241,10 @@ SUBROUTINE PCPOEQU( N, A, IA, JA, DESCA, SR, SC, SCOND, AMAX, IF( N.EQ.0 ) THEN SCOND = ONE AMAX = ZERO +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -330,6 +368,10 @@ SUBROUTINE PCPOEQU( N, A, IA, JA, DESCA, SR, SC, SCOND, AMAX, * CALL IGAMN2D( ICTXT, 'All', ALLCTOP, 1, 1, INFO, 1, II, JJ, -1, $ -1, MYCOL ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * ELSE @@ -351,6 +393,10 @@ SUBROUTINE PCPOEQU( N, A, IA, JA, DESCA, SR, SC, SCOND, AMAX, * END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCPOEQU diff --git a/SRC/pcporfs.f b/SRC/pcporfs.f index 4f50306a..a1f7b161 100644 --- a/SRC/pcporfs.f +++ b/SRC/pcporfs.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCPORFS( UPLO, N, NRHS, A, IA, JA, DESCA, AF, IAF, JAF, $ DESCAF, B, IB, JB, DESCB, X, IX, JX, DESCX, $ FERR, BERR, WORK, LWORK, RWORK, LRWORK, INFO ) @@ -7,6 +13,7 @@ SUBROUTINE PCPORFS( UPLO, N, NRHS, A, IA, JA, DESCA, AF, IAF, JAF, * and University of California, Berkeley. * November 15, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER IA, IAF, IB, INFO, IX, JA, JAF, JB, JX, @@ -306,6 +313,16 @@ SUBROUTINE PCPORFS( UPLO, N, NRHS, A, IA, JA, DESCA, AF, IAF, JAF, CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) * .. * .. Executable Statements .. +* +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F * .. Initialize EST EST = (0.0, 0.0) * @@ -314,6 +331,24 @@ SUBROUTINE PCPORFS( UPLO, N, NRHS, A, IA, JA, DESCA, AF, IAF, JAF, ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, IA, IAF, IB, INFO, IX, + $ JA, JAF, JB, JX, LRWORK, + $ LWORK, N, NRHS, NPROW, NPCOL, + $ MYROW, MYCOL, eos_str + 102 FORMAT('PCPORFS inputs: ,UPLO:',A5,', IA:',I9, + $ ', IAF:',I9,', IB:',I9,', INFO:',I9, + $ ', IX:',I9,', JA:',I9,', JAF:',I9,', JB:',I9, + $ ', JX:',I9,', LRWORK:',I9,', LWORK:',I9, + $ ', N:',I9,', NRHS:',I9, + $ ', NPROW: ', I9,', NPCOL: ', I9 ,', MYROW: ', I9, + $ ', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters. * INFO = 0 @@ -430,8 +465,16 @@ SUBROUTINE PCPORFS( UPLO, N, NRHS, A, IA, JA, DESCA, AF, IAF, JAF, END IF IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCPORFS', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -446,6 +489,10 @@ SUBROUTINE PCPORFS( UPLO, N, NRHS, A, IA, JA, DESCA, AF, IAF, JAF, FERR( JJ ) = ZERO BERR( JJ ) = ZERO 10 CONTINUE +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -865,6 +912,10 @@ SUBROUTINE PCPORFS( UPLO, N, NRHS, A, IA, JA, DESCA, AF, IAF, JAF, WORK( 1 ) = CMPLX( REAL( LWMIN ) ) RWORK( 1 ) = REAL( LRWMIN ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCPORFS diff --git a/SRC/pcposv.f b/SRC/pcposv.f index 74cf0235..47d5cd04 100644 --- a/SRC/pcposv.f +++ b/SRC/pcposv.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCPOSV( UPLO, N, NRHS, A, IA, JA, DESCA, B, IB, JB, $ DESCB, INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCPOSV( UPLO, N, NRHS, A, IA, JA, DESCA, B, IB, JB, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER IA, IB, INFO, JA, JB, N, NRHS @@ -192,11 +199,36 @@ SUBROUTINE PCPOSV( UPLO, N, NRHS, A, IA, JA, DESCA, B, IB, JB, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, IA, IB, INFO, JA, JB, + $ N, NRHS, NPROW, NPCOL, MYROW, MYCOL, + $ eos_str + 102 FORMAT('PCPOSV inputs: ,UPLO:',A5,', IA:',I9,', IB:',I9, + $ ', INFO:',I9,', JA:',I9,', JB:',I9, + $ ', N:',I9,', NRHS:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9, + $ ', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -239,6 +271,10 @@ SUBROUTINE PCPOSV( UPLO, N, NRHS, A, IA, JA, DESCA, B, IB, JB, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCPOSV', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -256,6 +292,10 @@ SUBROUTINE PCPOSV( UPLO, N, NRHS, A, IA, JA, DESCA, B, IB, JB, * END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCPOSV diff --git a/SRC/pcposvx.f b/SRC/pcposvx.f index a6e0da0c..61217e8d 100644 --- a/SRC/pcposvx.f +++ b/SRC/pcposvx.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCPOSVX( FACT, UPLO, N, NRHS, A, IA, JA, DESCA, AF, $ IAF, JAF, DESCAF, EQUED, SR, SC, B, IB, JB, $ DESCB, X, IX, JX, DESCX, RCOND, FERR, BERR, @@ -8,6 +14,7 @@ SUBROUTINE PCPOSVX( FACT, UPLO, N, NRHS, A, IA, JA, DESCA, AF, * and University of California, Berkeley. * December 31, 1998 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER EQUED, FACT, UPLO INTEGER IA, IAF, IB, INFO, IX, JA, JAF, JB, JX, LRWORK, @@ -388,11 +395,41 @@ SUBROUTINE PCPOSVX( FACT, UPLO, N, NRHS, A, IA, JA, DESCA, AF, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) EQUED, FACT, UPLO, IA, IAF, + $ IB, INFO, IX, JA, JAF, JB, JX, LRWORK, + $ LWORK, N, NRHS, + $ RCOND, NPROW, NPCOL, MYROW, MYCOL, + $ eos_str + 102 FORMAT('PCPOSVX inputs: ,EQUED:',A5,', FACT:',A5, + $ ', UPLO:',A5,', IA:',I9,', IAF:',I9, + $ ', IB:',I9,', INFO:',I9,', IX:',I9, + $ ', JA:',I9,', JAF:',I9,', JB:',I9, + $ ', JX:',I9,', LRWORK:',I9,', LWORK:',I9, + $ ', N:',I9,', NRHS:',I9,', RCOND:',F9.4, + $ ', NPROW: ', I9,', NPCOL: ', I9 , + $ ', MYROW: ', I9,', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -545,8 +582,16 @@ SUBROUTINE PCPOSVX( FACT, UPLO, N, NRHS, A, IA, JA, DESCA, AF, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCPOSVX', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -600,6 +645,10 @@ SUBROUTINE PCPOSVX( FACT, UPLO, N, NRHS, A, IA, JA, DESCA, AF, IF( INFO.NE.0 ) THEN IF( INFO.GT.0 ) $ RCOND = ZERO +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF END IF @@ -617,6 +666,10 @@ SUBROUTINE PCPOSVX( FACT, UPLO, N, NRHS, A, IA, JA, DESCA, AF, * IF( RCOND.LT.PSLAMCH( ICTXT, 'Epsilon' ) ) THEN INFO = IA + N +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -660,6 +713,10 @@ SUBROUTINE PCPOSVX( FACT, UPLO, N, NRHS, A, IA, JA, DESCA, AF, * WORK( 1 ) = REAL( LWMIN ) RWORK( 1 ) = REAL( LRWMIN ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCPOSVX diff --git a/SRC/pcpotf2.f b/SRC/pcpotf2.f index 1f351361..f8c3555c 100644 --- a/SRC/pcpotf2.f +++ b/SRC/pcpotf2.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCPOTF2( UPLO, N, A, IA, JA, DESCA, INFO ) * * -- ScaLAPACK routine (version 1.7) -- @@ -5,6 +11,7 @@ SUBROUTINE PCPOTF2( UPLO, N, A, IA, JA, DESCA, INFO ) * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER IA, INFO, JA, N @@ -173,11 +180,34 @@ SUBROUTINE PCPOTF2( UPLO, N, A, IA, JA, DESCA, INFO ) * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, IA, INFO, JA, N, NPROW, + $ NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCPOTF2 inputs: ,UPLO:',A5,', IA:',I9, + $ ', INFO:',I9,', JA:',I9,', N:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9, + $ ', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters. * INFO = 0 @@ -206,13 +236,22 @@ SUBROUTINE PCPOTF2( UPLO, N, A, IA, JA, DESCA, INFO ) IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCPOTF2', -INFO ) CALL BLACS_ABORT( ICTXT, 1 ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Compute local information * @@ -311,7 +350,7 @@ SUBROUTINE PCPOTF2( UPLO, N, A, IA, JA, DESCA, INFO ) * Compute L(J,J) and test for non-positive-definiteness. * #ifdef F2C - CALL CDOTC( TMP, J-JA, A( IOFFA ), LDA, + CALL CDOTC( TMP, J-JA, A( IOFFA ), LDA, $ A( IOFFA ), LDA ) AJJ = REAL( A( IDIAG ) ) - TMP #else @@ -368,6 +407,10 @@ SUBROUTINE PCPOTF2( UPLO, N, A, IA, JA, DESCA, INFO ) * END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCPOTF2 diff --git a/SRC/pcpotrf.f b/SRC/pcpotrf.f index 2ded727f..db6f909b 100644 --- a/SRC/pcpotrf.f +++ b/SRC/pcpotrf.f @@ -1,8 +1,13 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* * -- ScaLAPACK routine -- -* Copyright (c) 2020-22 Advanced Micro Devices, Inc.  All rights reserved. * June 20, 2022 * #include "SL_Context_fortran_include.h" +* +* +#include "SL_Context_fortran_include.h" * SUBROUTINE PCPOTRF( UPLO, N, A, IA, JA, DESCA, INFO ) * @@ -13,6 +18,7 @@ SUBROUTINE PCPOTRF( UPLO, N, A, IA, JA, DESCA, INFO ) * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER IA, INFO, JA, N @@ -159,6 +165,9 @@ SUBROUTINE PCPOTRF( UPLO, N, A, IA, JA, DESCA, INFO ) * * .. Declaring 'API NAME' and its length as const objects * .. API_NAME string terminated with 'NULL' character. +* +#include "SL_Context_fortran_include.h" +* CHARACTER*8, PARAMETER :: API_NAME = FUNCTION_NAME // C_NULL_CHAR INTEGER, PARAMETER :: LEN_API_NAME = 8 #endif @@ -194,11 +203,34 @@ SUBROUTINE PCPOTRF( UPLO, N, A, IA, JA, DESCA, INFO ) * * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, IA, INFO, JA, N, NPROW, + $ NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCPOTRF inputs: ,UPLO:',A5,', IA:',I9, + $ ', INFO:',I9,', JA:',I9,', N:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9, + $ ', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -232,13 +264,22 @@ SUBROUTINE PCPOTRF( UPLO, N, A, IA, JA, DESCA, INFO ) * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCPOTRF', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * CALL PB_TOPGET( ICTXT, 'Broadcast', 'Rowwise', ROWBTOP ) CALL PB_TOPGET( ICTXT, 'Broadcast', 'Columnwise', COLBTOP ) @@ -419,6 +460,10 @@ SUBROUTINE PCPOTRF( UPLO, N, A, IA, JA, DESCA, INFO ) CALL PB_TOPSET( ICTXT, 'Broadcast', 'Rowwise', ROWBTOP ) CALL PB_TOPSET( ICTXT, 'Broadcast', 'Columnwise', COLBTOP ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCPOTRF diff --git a/SRC/pcpotri.f b/SRC/pcpotri.f index eeaf9684..2758ce27 100644 --- a/SRC/pcpotri.f +++ b/SRC/pcpotri.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCPOTRI( UPLO, N, A, IA, JA, DESCA, INFO ) * * -- ScaLAPACK routine (version 1.7) -- @@ -5,6 +11,7 @@ SUBROUTINE PCPOTRI( UPLO, N, A, IA, JA, DESCA, INFO ) * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER IA, INFO, JA, N @@ -145,11 +152,34 @@ SUBROUTINE PCPOTRI( UPLO, N, A, IA, JA, DESCA, INFO ) * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, IA, INFO, JA, N, NPROW, + $ NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCPOTRI inputs: ,UPLO:',A5,', IA:',I9, + $ ', INFO:',I9,', JA:',I9,', N:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9, + $ ', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -182,25 +212,43 @@ SUBROUTINE PCPOTRI( UPLO, N, A, IA, JA, DESCA, INFO ) * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCPOTRI', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Invert the triangular Cholesky factor U or L. * CALL PCTRTRI( UPLO, 'Non-unit', N, A, IA, JA, DESCA, INFO ) * - IF( INFO.GT.0 ) - $ RETURN + IF( INFO.GT.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Form inv(U)*inv(U)' or inv(L)'*inv(L). * CALL PCLAUUM( UPLO, N, A, IA, JA, DESCA ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCPOTRI diff --git a/SRC/pcpotrs.f b/SRC/pcpotrs.f index 0dd8e032..6ddee8b5 100644 --- a/SRC/pcpotrs.f +++ b/SRC/pcpotrs.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCPOTRS( UPLO, N, NRHS, A, IA, JA, DESCA, B, IB, JB, $ DESCB, INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCPOTRS( UPLO, N, NRHS, A, IA, JA, DESCA, B, IB, JB, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER IA, IB, INFO, JA, JB, N, NRHS @@ -173,11 +180,36 @@ SUBROUTINE PCPOTRS( UPLO, N, NRHS, A, IA, JA, DESCA, B, IB, JB, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters. * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, IA, IB, INFO, JA, JB, + $ N, NRHS, NPROW, NPCOL, MYROW, MYCOL, + $ eos_str + 102 FORMAT('PCPOTRS inputs: ,UPLO:',A5,', IA:',I9, + $ ', IB:',I9,', INFO:',I9,', JA:',I9,', JB:',I9, + $ ', N:',I9,', NRHS:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9, + $ ', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters. * INFO = 0 @@ -221,13 +253,22 @@ SUBROUTINE PCPOTRS( UPLO, N, NRHS, A, IA, JA, DESCA, B, IB, JB, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCPOTRS', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * IF( UPPER ) THEN * @@ -259,6 +300,10 @@ SUBROUTINE PCPOTRS( UPLO, N, NRHS, A, IA, JA, DESCA, B, IB, JB, $ JB, DESCB ) END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCPOTRS diff --git a/SRC/pcptsv.f b/SRC/pcptsv.f index 85661055..f3692973 100644 --- a/SRC/pcptsv.f +++ b/SRC/pcptsv.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCPTSV( UPLO, N, NRHS, D, E, JA, DESCA, B, IB, DESCB, $ WORK, LWORK, INFO ) * @@ -8,6 +14,7 @@ SUBROUTINE PCPTSV( UPLO, N, NRHS, D, E, JA, DESCA, B, IB, DESCB, * and University of California, Berkeley. * November 15, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER IB, INFO, JA, LWORK, N, NRHS @@ -393,6 +400,28 @@ SUBROUTINE PCPTSV( UPLO, N, NRHS, D, E, JA, DESCA, B, IB, DESCB, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, IB, INFO, JA, LWORK, + $ N, NRHS, eos_str + 102 FORMAT('PCPTSV inputs: ,UPLO:',A5,', IB:',I9,', INFO:',I9, + $ ', JA:',I9,', LWORK:',I9, + $ ', N:',I9,', NRHS:',I9, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Note: to avoid duplication, most error checking is not performed * in this routine and is left to routines * PCPTTRF and PCPTTRS. @@ -417,6 +446,10 @@ SUBROUTINE PCPTSV( UPLO, N, NRHS, D, E, JA, DESCA, B, IB, DESCB, CALL PXERBLA( ICTXT, $ 'PCPTSV', $ -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ENDIF * @@ -438,6 +471,10 @@ SUBROUTINE PCPTSV( UPLO, N, NRHS, D, E, JA, DESCA, B, IB, DESCB, IF( INFO .LT. 0 ) THEN CALL PXERBLA( ICTXT, 'PCPTSV', -INFO ) ENDIF +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -451,9 +488,17 @@ SUBROUTINE PCPTSV( UPLO, N, NRHS, D, E, JA, DESCA, B, IB, DESCB, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCPTSV', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCPTSV diff --git a/SRC/pcpttrf.f b/SRC/pcpttrf.f index aa32f6b3..32757822 100644 --- a/SRC/pcpttrf.f +++ b/SRC/pcpttrf.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCPTTRF( N, D, E, JA, DESCA, AF, LAF, WORK, LWORK, $ INFO ) * @@ -8,6 +14,7 @@ SUBROUTINE PCPTTRF( N, D, E, JA, DESCA, AF, LAF, WORK, LWORK, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. INTEGER INFO, JA, LAF, LWORK, N * .. @@ -395,6 +402,16 @@ SUBROUTINE PCPTTRF( N, D, E, JA, DESCA, AF, LAF, WORK, LWORK, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Test the input parameters * INFO = 0 @@ -430,6 +447,19 @@ SUBROUTINE PCPTTRF( N, D, E, JA, DESCA, AF, LAF, WORK, LWORK, * * CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) INFO, JA, LAF, LWORK, N, NPROW, + $ NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCPTTRF inputs: ,INFO:',I9,', JA:',I9, + $ ', LAF:',I9,', LWORK:',I9,', N:',I9, + $ ', NPROW: ', I9,', NPCOL: ', I9 ,', MYROW: ', I9, + $ ', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF NP = NPROW * NPCOL * * @@ -461,6 +491,10 @@ SUBROUTINE PCPTTRF( N, D, E, JA, DESCA, AF, LAF, WORK, LWORK, CALL PXERBLA( ICTXT, $ 'PCPTTRF, D&C alg.: only 1 block per proc', $ -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ENDIF * @@ -469,6 +503,10 @@ SUBROUTINE PCPTTRF( N, D, E, JA, DESCA, AF, LAF, WORK, LWORK, CALL PXERBLA( ICTXT, $ 'PCPTTRF, D&C alg.: NB too small', $ -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ENDIF * @@ -484,6 +522,10 @@ SUBROUTINE PCPTTRF( N, D, E, JA, DESCA, AF, LAF, WORK, LWORK, CALL PXERBLA( ICTXT, $ 'PCPTTRF: auxiliary storage error ', $ -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ENDIF * @@ -500,6 +542,10 @@ SUBROUTINE PCPTTRF( N, D, E, JA, DESCA, AF, LAF, WORK, LWORK, $ 'PCPTTRF: worksize error ', $ -INFO ) ENDIF +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ENDIF * @@ -551,13 +597,22 @@ SUBROUTINE PCPTTRF( N, D, E, JA, DESCA, AF, LAF, WORK, LWORK, * IF( INFO.LT.0 ) THEN CALL PXERBLA( ICTXT, 'PCPTTRF', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * * Adjust addressing into matrix space to properly get into @@ -1032,6 +1087,10 @@ SUBROUTINE PCPTTRF( N, D, E, JA, DESCA, AF, LAF, WORK, LWORK, ENDIF * * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCPTTRF diff --git a/SRC/pcpttrs.f b/SRC/pcpttrs.f index 565a022e..76c47fa9 100644 --- a/SRC/pcpttrs.f +++ b/SRC/pcpttrs.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCPTTRS( UPLO, N, NRHS, D, E, JA, DESCA, B, IB, DESCB, $ AF, LAF, WORK, LWORK, INFO ) * @@ -6,8 +12,9 @@ SUBROUTINE PCPTTRS( UPLO, N, NRHS, D, E, JA, DESCA, B, IB, DESCB, * -- ScaLAPACK routine (version 1.7) -- * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. -* August 7, 2001 +* August 7, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER UPLO INTEGER IB, INFO, JA, LAF, LWORK, N, NRHS @@ -416,6 +423,16 @@ SUBROUTINE PCPTTRS( UPLO, N, NRHS, D, E, JA, DESCA, B, IB, DESCB, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Test the input parameters * INFO = 0 @@ -481,6 +498,21 @@ SUBROUTINE PCPTTRS( UPLO, N, NRHS, D, E, JA, DESCA, B, IB, DESCB, * * CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) UPLO, IB, INFO, JA, LAF, LWORK, + $ N, NRHS, NPROW, NPCOL, MYROW, MYCOL, + $ eos_str + 102 FORMAT('PCPTTRS inputs: ,UPLO:',A5,', IB:',I9, + $ ', INFO:',I9,', JA:',I9,', LAF:',I9, + $ ', LWORK:',I9,', N:',I9,', NRHS:',I9, + $ ', NPROW: ', I9,', NPCOL: ', I9 ,', MYROW: ', I9, + $ ', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF NP = NPROW * NPCOL * * @@ -538,6 +570,10 @@ SUBROUTINE PCPTTRS( UPLO, N, NRHS, D, E, JA, DESCA, B, IB, DESCB, CALL PXERBLA( ICTXT, $ 'PCPTTRS, D&C alg.: only 1 block per proc', $ -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ENDIF * @@ -546,6 +582,10 @@ SUBROUTINE PCPTTRS( UPLO, N, NRHS, D, E, JA, DESCA, B, IB, DESCB, CALL PXERBLA( ICTXT, $ 'PCPTTRS, D&C alg.: NB too small', $ -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ENDIF * @@ -562,6 +602,10 @@ SUBROUTINE PCPTTRS( UPLO, N, NRHS, D, E, JA, DESCA, B, IB, DESCB, $ 'PCPTTRS: worksize error', $ -INFO ) ENDIF +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ENDIF * @@ -629,16 +673,30 @@ SUBROUTINE PCPTTRS( UPLO, N, NRHS, D, E, JA, DESCA, B, IB, DESCB, * IF( INFO.LT.0 ) THEN CALL PXERBLA( ICTXT, 'PCPTTRS', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file * - IF( NRHS.EQ.0 ) - $ RETURN + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF +* + IF( NRHS.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * * Adjust addressing into matrix space to properly get into @@ -791,6 +849,10 @@ SUBROUTINE PCPTTRS( UPLO, N, NRHS, D, E, JA, DESCA, B, IB, DESCB, WORK( 1 ) = WORK_SIZE_MIN * * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCPTTRS diff --git a/SRC/pcpttrsv.f b/SRC/pcpttrsv.f index 018b9944..0221f08e 100644 --- a/SRC/pcpttrsv.f +++ b/SRC/pcpttrsv.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCPTTRSV( UPLO, TRANS, N, NRHS, D, E, JA, DESCA, B, IB, $ DESCB, AF, LAF, WORK, LWORK, INFO ) * @@ -8,6 +14,7 @@ SUBROUTINE PCPTTRSV( UPLO, TRANS, N, NRHS, D, E, JA, DESCA, B, IB, * and University of California, Berkeley. * November 15, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER TRANS, UPLO INTEGER IB, INFO, JA, LAF, LWORK, N, NRHS @@ -423,6 +430,16 @@ SUBROUTINE PCPTTRSV( UPLO, TRANS, N, NRHS, D, E, JA, DESCA, B, IB, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Test the input parameters * INFO = 0 @@ -488,6 +505,21 @@ SUBROUTINE PCPTTRSV( UPLO, TRANS, N, NRHS, D, E, JA, DESCA, B, IB, * * CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) TRANS, UPLO, IB, INFO, JA, + $ LAF, LWORK, N, NRHS, NPROW, NPCOL, MYROW, + $ MYCOL, eos_str + 102 FORMAT('PCPTTRSV inputs: ,TRANS:',A5,', UPLO:',A5, + $ ', IB:',I9,', INFO:',I9,', JA:',I9, + $ ', LAF:',I9,', LWORK:',I9,', N:',I9, + $ ', NRHS:',I9,', NPROW: ', I9,', NPCOL: ', I9 , + $ ', MYROW: ', I9,', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF NP = NPROW * NPCOL * * @@ -553,6 +585,10 @@ SUBROUTINE PCPTTRSV( UPLO, TRANS, N, NRHS, D, E, JA, DESCA, B, IB, CALL PXERBLA( ICTXT, $ 'PCPTTRSV, D&C alg.: only 1 block per proc', $ -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ENDIF * @@ -561,6 +597,10 @@ SUBROUTINE PCPTTRSV( UPLO, TRANS, N, NRHS, D, E, JA, DESCA, B, IB, CALL PXERBLA( ICTXT, $ 'PCPTTRSV, D&C alg.: NB too small', $ -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ENDIF * @@ -577,6 +617,10 @@ SUBROUTINE PCPTTRSV( UPLO, TRANS, N, NRHS, D, E, JA, DESCA, B, IB, $ 'PCPTTRSV: worksize error', $ -INFO ) ENDIF +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ENDIF * @@ -646,16 +690,30 @@ SUBROUTINE PCPTTRSV( UPLO, TRANS, N, NRHS, D, E, JA, DESCA, B, IB, * IF( INFO.LT.0 ) THEN CALL PXERBLA( ICTXT, 'PCPTTRSV', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file * - IF( NRHS.EQ.0 ) - $ RETURN + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF +* + IF( NRHS.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * * Adjust addressing into matrix space to properly get into @@ -1504,6 +1562,10 @@ SUBROUTINE PCPTTRSV( UPLO, TRANS, N, NRHS, D, E, JA, DESCA, B, IB, WORK( 1 ) = WORK_SIZE_MIN * * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCPTTRSV diff --git a/SRC/pcsrscl.f b/SRC/pcsrscl.f index cc76b8d2..4566c737 100644 --- a/SRC/pcsrscl.f +++ b/SRC/pcsrscl.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCSRSCL( N, SA, SX, IX, JX, DESCX, INCX ) * * -- ScaLAPACK auxiliary routine (version 1.7) -- @@ -5,6 +10,7 @@ SUBROUTINE PCSRSCL( N, SA, SX, IX, JX, DESCX, INCX ) * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. INTEGER IX, INCX, JX, N REAL SA @@ -144,15 +150,43 @@ SUBROUTINE PCSRSCL( N, SA, SX, IX, JX, DESCX, INCX ) * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCX( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) IX, INCX, JX, N, SA, NPROW, + $ NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCSRSCL inputs: ,IX:',I5,', INCX:',I5, + $ ', JX:',I5,', N:',I5,', SA:',F9.4,', NPROW: ', I5, + $ ', NPCOL: ', I5 ,', MYROW: ', I5, + $ ', MYCOL: ', I5, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Quick return if possible * - IF( N.LE.0 ) - $ RETURN + IF( N.LE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Get machine parameters * @@ -199,6 +233,10 @@ SUBROUTINE PCSRSCL( N, SA, SX, IX, JX, DESCX, INCX ) IF( .NOT.DONE ) $ GO TO 10 * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCSRSCL diff --git a/SRC/pcstein.f b/SRC/pcstein.f index d3b99682..27569b88 100644 --- a/SRC/pcstein.f +++ b/SRC/pcstein.f @@ -1,3 +1,8 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, ORFAC, Z, IZ, $ JZ, DESCZ, WORK, LWORK, IWORK, LIWORK, IFAIL, $ ICLUSTR, GAP, INFO ) @@ -7,6 +12,7 @@ SUBROUTINE PCSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, ORFAC, Z, IZ, * and University of California, Berkeley. * November 15, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. INTEGER INFO, IZ, JZ, LIWORK, LWORK, M, N REAL ORFAC @@ -296,9 +302,37 @@ SUBROUTINE PCSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, ORFAC, Z, IZ, INTEGER IDUM1( 1 ), IDUM2( 1 ) * .. * .. Executable Statements .. +* +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) INFO, IZ, JZ, LIWORK, LWORK, + $ M, N, ORFAC, eos_str + 102 FORMAT('PCSTEIN inputs: ,INFO:',I5,', IZ:',I5, + $ ', JZ:',I5,', LIWORK:',I5,', LWORK:',I5, + $ ', M:',I5,', N:',I5,', ORFAC:',F9.4, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF * This is just to keep ftnchek happy IF( BLOCK_CYCLIC_2D*CSRC_*CTXT_*DLEN_*DTYPE_*LLD_*MB_*M_*NB_*N_* - $ RSRC_.LT.0 )RETURN + $ RSRC_.LT.0 )THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * CALL BLACS_GRIDINFO( DESCZ( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL ) SELF = MYROW*NPCOL + MYCOL @@ -376,8 +410,16 @@ SUBROUTINE PCSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, ORFAC, Z, IZ, END IF IF( INFO.NE.0 ) THEN CALL PXERBLA( DESCZ( CTXT_ ), 'PCSTEIN', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -396,8 +438,13 @@ SUBROUTINE PCSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, ORFAC, Z, IZ, * * Quick return if possible * - IF( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN + IF( N.EQ.0 .OR. M.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * IF( ORFAC.GE.ZERO ) THEN TMPFAC = ORFAC @@ -638,6 +685,10 @@ SUBROUTINE PCSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, ORFAC, Z, IZ, WORK( 1 ) = ( LGCLSIZ+LOAD-1 )*N + INDRW IWORK( 1 ) = 3*N + P + 1 * +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F +* * End of PCSTEIN * END diff --git a/SRC/pctrcon.f b/SRC/pctrcon.f index 082a3754..4d643051 100644 --- a/SRC/pctrcon.f +++ b/SRC/pctrcon.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCTRCON( NORM, UPLO, DIAG, N, A, IA, JA, DESCA, RCOND, $ WORK, LWORK, RWORK, LRWORK, INFO ) * @@ -7,6 +13,7 @@ SUBROUTINE PCTRCON( NORM, UPLO, DIAG, N, A, IA, JA, DESCA, RCOND, * May 25, 2001 * * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER DIAG, NORM, UPLO INTEGER IA, JA, INFO, LRWORK, LWORK, N @@ -225,11 +232,37 @@ SUBROUTINE PCTRCON( NORM, UPLO, DIAG, N, A, IA, JA, DESCA, RCOND, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) DIAG, NORM, UPLO, IA, JA, INFO, + $ LRWORK, LWORK, N, RCOND, NPROW, + $ NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCTRCON inputs: ,DIAG:',A5,', NORM:',A5, + $ ', UPLO:',A5,', IA:',I9,', JA:',I9, + $ ', INFO:',I9,', LRWORK:',I9,', LWORK:',I9, + $ ', N:',I9,', RCOND:',F9.4,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9, + $ ', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -308,8 +341,16 @@ SUBROUTINE PCTRCON( NORM, UPLO, DIAG, N, A, IA, JA, DESCA, RCOND, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCTRCON', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -317,6 +358,10 @@ SUBROUTINE PCTRCON( NORM, UPLO, DIAG, N, A, IA, JA, DESCA, RCOND, * IF( N.EQ.0 ) THEN RCOND = ONE +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -424,6 +469,10 @@ SUBROUTINE PCTRCON( NORM, UPLO, DIAG, N, A, IA, JA, DESCA, RCOND, CALL PB_TOPSET( ICTXT, 'Combine', 'Columnwise', COLCTOP ) CALL PB_TOPSET( ICTXT, 'Combine', 'Rowwise', ROWCTOP ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCTRCON diff --git a/SRC/pctrevc.f b/SRC/pctrevc.f index bf6c52bf..ecaaa47a 100644 --- a/SRC/pctrevc.f +++ b/SRC/pctrevc.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCTREVC( SIDE, HOWMNY, SELECT, N, T, DESCT, VL, DESCVL, $ VR, DESCVR, MM, M, WORK, RWORK, INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCTREVC( SIDE, HOWMNY, SELECT, N, T, DESCT, VL, DESCVL, * and University of California, Berkeley. * July 31, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER HOWMNY, SIDE INTEGER INFO, M, MM, N @@ -247,9 +254,37 @@ SUBROUTINE PCTREVC( SIDE, HOWMNY, SELECT, N, T, DESCT, VL, DESCVL, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) HOWMNY, SIDE, INFO, M, MM, + $ N, eos_str + 102 FORMAT('PCTREVC inputs: ,HOWMNY:',A5,', SIDE:',A5, + $ ', INFO:',I9,', M:',I9,', MM:',I9, + $ ', N:',I9, A1 ) + AOCL_DTL_LOG_ENTRY_F + END IF +* * This is just to keep ftnchek happy IF( BLOCK_CYCLIC_2D*CSRC_*CTXT_*DLEN_*DTYPE_*LLD_*MB_*M_*NB_*N_* - $ RSRC_.LT.0 )RETURN + $ RSRC_.LT.0 )THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * CONTXT = DESCT( CTXT_ ) RSRC = DESCT( RSRC_ ) @@ -301,13 +336,22 @@ SUBROUTINE PCTREVC( SIDE, HOWMNY, SELECT, N, T, DESCT, VL, DESCVL, $ -1, -1 ) IF( INFO.LT.0 ) THEN CALL PXERBLA( CONTXT, 'PCTREVC', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible. * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Set the constants to control overflow. * @@ -562,6 +606,10 @@ SUBROUTINE PCTREVC( SIDE, HOWMNY, SELECT, N, T, DESCT, VL, DESCVL, 110 CONTINUE END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCTREVC diff --git a/SRC/pctrrfs.f b/SRC/pctrrfs.f index 15873adc..743ee564 100644 --- a/SRC/pctrrfs.f +++ b/SRC/pctrrfs.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA, $ B, IB, JB, DESCB, X, IX, JX, DESCX, FERR, $ BERR, WORK, LWORK, RWORK, LRWORK, INFO ) @@ -7,6 +13,7 @@ SUBROUTINE PCTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO INTEGER INFO, IA, IB, IX, JA, JB, JX, LRWORK, LWORK, @@ -291,11 +298,39 @@ SUBROUTINE PCTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) DIAG, TRANS, UPLO, INFO, IA, + $ IB, IX, JA, JB, JX, LRWORK, LWORK, + $ N, NRHS, NPROW, NPCOL, + $ MYROW, MYCOL, eos_str + 102 FORMAT('PCTRRFS inputs: ,DIAG:',A5,', TRANS:',A5, + $ ', UPLO:',A5,', INFO:',I9,', IA:',I9, + $ ', IB:',I9,', IX:',I9,', JA:',I9, + $ ', JB:',I9,', JX:',I9,', LRWORK:',I9, + $ ', LWORK:',I9,', N:',I9,', NRHS:',I9, + $ ', NPROW: ', I9,', NPCOL: ', I9 , + $ ', MYROW: ', I9,', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters. * INFO = 0 @@ -410,8 +445,16 @@ SUBROUTINE PCTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA, END IF IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCTRRFS', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -426,6 +469,10 @@ SUBROUTINE PCTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA, FERR( JJ ) = ZERO BERR( JJ ) = ZERO 10 CONTINUE +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -799,6 +846,10 @@ SUBROUTINE PCTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA, WORK( 1 ) = CMPLX( REAL( LWMIN ) ) RWORK( 1 ) = REAL( LRWMIN ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCTRRFS diff --git a/SRC/pctrti2.f b/SRC/pctrti2.f index babfbb38..79c2e2df 100644 --- a/SRC/pctrti2.f +++ b/SRC/pctrti2.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCTRTI2( UPLO, DIAG, N, A, IA, JA, DESCA, INFO ) * * -- ScaLAPACK routine (version 1.7) -- @@ -5,6 +11,7 @@ SUBROUTINE PCTRTI2( UPLO, DIAG, N, A, IA, JA, DESCA, INFO ) * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER DIAG, UPLO INTEGER IA, INFO, JA, N @@ -149,11 +156,34 @@ SUBROUTINE PCTRTI2( UPLO, DIAG, N, A, IA, JA, DESCA, INFO ) * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) DIAG, UPLO, IA, INFO, JA, N, + $ NPROW, NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCTRTI2 inputs: ,DIAG:',A5,', UPLO:',A5, + $ ', IA:',I9,', INFO:',I9,', JA:',I9, + $ ', N:',I9,', NPROW: ', I9,', NPCOL: ', I9 , + $ ', MYROW: ', I9,', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -173,6 +203,10 @@ SUBROUTINE PCTRTI2( UPLO, DIAG, N, A, IA, JA, DESCA, INFO ) IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCTRTI2', -INFO ) CALL BLACS_ABORT( ICTXT, 1 ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * @@ -271,6 +305,10 @@ SUBROUTINE PCTRTI2( UPLO, DIAG, N, A, IA, JA, DESCA, INFO ) * END IF * +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F +* * End of PCTRTI2 * END diff --git a/SRC/pctrtri.f b/SRC/pctrtri.f index dc601af2..a1f91612 100644 --- a/SRC/pctrtri.f +++ b/SRC/pctrtri.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCTRTRI( UPLO, DIAG, N, A, IA, JA, DESCA, INFO ) * * -- ScaLAPACK routine (version 1.7) -- @@ -5,6 +11,7 @@ SUBROUTINE PCTRTRI( UPLO, DIAG, N, A, IA, JA, DESCA, INFO ) * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER DIAG, UPLO INTEGER IA, INFO, JA, N @@ -162,11 +169,34 @@ SUBROUTINE PCTRTRI( UPLO, DIAG, N, A, IA, JA, DESCA, INFO ) * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) DIAG, UPLO, IA, INFO, JA, N, + $ NPROW, NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCTRTRI inputs: ,DIAG:',A5,', UPLO:',A5, + $ ', IA:',I9,', INFO:',I9,', JA:',I9, + $ ', N:',I9,', NPROW: ', I9,', NPCOL: ', I9 , + $ ', MYROW: ', I9,', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test input parameters * INFO = 0 @@ -210,13 +240,22 @@ SUBROUTINE PCTRTRI( UPLO, DIAG, N, A, IA, JA, DESCA, INFO ) * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCTRTRI', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.EQ.0 ) - $ RETURN + IF( N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Check for singularity if non-unit. * @@ -265,8 +304,13 @@ SUBROUTINE PCTRTRI( UPLO, DIAG, N, A, IA, JA, DESCA, INFO ) 30 CONTINUE CALL IGAMX2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, IDUMMY, $ IDUMMY, -1, -1, MYCOL ) - IF( INFO.NE.0 ) - $ RETURN + IF( INFO.NE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF END IF * * Use blocked code @@ -346,6 +390,10 @@ SUBROUTINE PCTRTRI( UPLO, DIAG, N, A, IA, JA, DESCA, INFO ) * END IF * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End PCTRTRI diff --git a/SRC/pctrtrs.f b/SRC/pctrtrs.f index 1db98da5..3e4b898a 100644 --- a/SRC/pctrtrs.f +++ b/SRC/pctrtrs.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA, $ B, IB, JB, DESCB, INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER DIAG, TRANS, UPLO INTEGER IA, IB, INFO, JA, JB, N, NRHS @@ -194,11 +201,37 @@ SUBROUTINE PCTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) DIAG, TRANS, UPLO, IA, IB, + $ INFO, JA, JB, N, NRHS, NPROW, NPCOL, + $ MYROW, MYCOL, eos_str + 102 FORMAT('PCTRTRS inputs: ,DIAG:',A5,', TRANS:',A5, + $ ', UPLO:',A5,', IA:',I9,', IB:',I9, + $ ', INFO:',I9,', JA:',I9,', JB:',I9, + $ ', N:',I9,', NRHS:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9, + $ ', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test input parameters * INFO = 0 @@ -263,13 +296,22 @@ SUBROUTINE PCTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCTRTRS', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN + IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * * Check for singularity if non-unit. * @@ -319,8 +361,13 @@ SUBROUTINE PCTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA, 30 CONTINUE CALL IGAMX2D( ICTXT, 'All', ' ', 1, 1, INFO, 1, IDUM, IDUM, $ -1, -1, MYCOL ) - IF( INFO.NE.0 ) - $ RETURN + IF( INFO.NE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF END IF * * Solve A * x = b, A**T * x = b, or A**H * x = b. @@ -328,6 +375,10 @@ SUBROUTINE PCTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, IA, JA, DESCA, CALL PCTRSM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, IA, JA, $ DESCA, B, IB, JB, DESCB ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCTRTRS diff --git a/SRC/pctzrzf.f b/SRC/pctzrzf.f index eaff1aa0..fc21cfb6 100644 --- a/SRC/pctzrzf.f +++ b/SRC/pctzrzf.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCTZRZF( M, N, A, IA, JA, DESCA, TAU, WORK, LWORK, $ INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCTZRZF( M, N, A, IA, JA, DESCA, TAU, WORK, LWORK, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. INTEGER IA, INFO, JA, LWORK, M, N * .. @@ -214,11 +221,34 @@ SUBROUTINE PCTZRZF( M, N, A, IA, JA, DESCA, TAU, WORK, LWORK, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) IA, INFO, JA, LWORK, M, N, + $ NPROW, NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCTZRZF inputs: ,IA:',I9,', INFO:',I9, + $ ', JA:',I9,', LWORK:',I9,', M:',I9,', N:',I9, + $ ', NPROW: ', I9,', NPCOL: ', I9 , + $ ', MYROW: ', I9,', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -257,15 +287,28 @@ SUBROUTINE PCTZRZF( M, N, A, IA, JA, DESCA, TAU, WORK, LWORK, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCTZRZF', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN + IF( M.EQ.0 .OR. N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * IF( M.EQ.N ) THEN * @@ -328,6 +371,10 @@ SUBROUTINE PCTZRZF( M, N, A, IA, JA, DESCA, TAU, WORK, LWORK, * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCTZRZF diff --git a/SRC/pcung2l.f b/SRC/pcung2l.f index 9d3082ff..047736db 100644 --- a/SRC/pcung2l.f +++ b/SRC/pcung2l.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCUNG2L( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, $ INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCUNG2L( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. INTEGER IA, INFO, JA, K, LWORK, M, N * .. @@ -184,11 +191,34 @@ SUBROUTINE PCUNG2L( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) IA, INFO, JA, K, LWORK, M, + $ N, NPROW, NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCUNG2L inputs: ,IA:',I9,', INFO:',I9, + $ ', JA:',I9,', K:',I9,', LWORK:',I9,', M:',I9, + $ ', N:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9,', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -221,15 +251,28 @@ SUBROUTINE PCUNG2L( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCUNG2L', -INFO ) CALL BLACS_ABORT( ICTXT, 1 ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.LE.0 ) - $ RETURN + IF( N.LE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * CALL PB_TOPGET( ICTXT, 'Broadcast', 'Rowwise', ROWBTOP ) CALL PB_TOPGET( ICTXT, 'Broadcast', 'Columnwise', COLBTOP ) @@ -272,6 +315,10 @@ SUBROUTINE PCUNG2L( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCUNG2L diff --git a/SRC/pcung2r.f b/SRC/pcung2r.f index bcddd7a2..8bdc82d8 100644 --- a/SRC/pcung2r.f +++ b/SRC/pcung2r.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCUNG2R( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, $ INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCUNG2R( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. INTEGER IA, INFO, JA, K, LWORK, M, N * .. @@ -185,11 +192,34 @@ SUBROUTINE PCUNG2R( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) IA, INFO, JA, K, LWORK, M, + $ N, NPROW, NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCUNG2R inputs: ,IA:',I9,', INFO:',I9, + $ ', JA:',I9,', K:',I9,', LWORK:',I9,', M:',I9, + $ ', N:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9,', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -222,15 +252,28 @@ SUBROUTINE PCUNG2R( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCUNG2R', -INFO ) CALL BLACS_ABORT( ICTXT, 1 ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.LE.0 ) - $ RETURN + IF( N.LE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * CALL PB_TOPGET( ICTXT, 'Broadcast', 'Rowwise', ROWBTOP ) CALL PB_TOPGET( ICTXT, 'Broadcast', 'Columnwise', COLBTOP ) @@ -275,6 +318,10 @@ SUBROUTINE PCUNG2R( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCUNG2R diff --git a/SRC/pcungl2.f b/SRC/pcungl2.f index c6d3a72f..75a60003 100644 --- a/SRC/pcungl2.f +++ b/SRC/pcungl2.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCUNGL2( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, $ INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCUNGL2( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. INTEGER IA, INFO, JA, K, LWORK, M, N * .. @@ -184,11 +191,34 @@ SUBROUTINE PCUNGL2( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) IA, INFO, JA, K, LWORK, M, + $ N, NPROW, NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCUNGL2 inputs: ,IA:',I9,', INFO:',I9, + $ ', JA:',I9,', K:',I9,', LWORK:',I9,', M:',I9, + $ ', N:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9,', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -221,15 +251,28 @@ SUBROUTINE PCUNGL2( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCUNGL2', -INFO ) CALL BLACS_ABORT( ICTXT, 1 ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( M.LE.0 ) - $ RETURN + IF( M.LE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * CALL PB_TOPGET( ICTXT, 'Broadcast', 'Rowwise', ROWBTOP ) CALL PB_TOPGET( ICTXT, 'Broadcast', 'Columnwise', COLBTOP ) @@ -283,6 +326,10 @@ SUBROUTINE PCUNGL2( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCUNGL2 diff --git a/SRC/pcunglq.f b/SRC/pcunglq.f index f985cdd4..41d06849 100644 --- a/SRC/pcunglq.f +++ b/SRC/pcunglq.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCUNGLQ( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, $ INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCUNGLQ( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. INTEGER IA, INFO, JA, K, LWORK, M, N * .. @@ -186,11 +193,34 @@ SUBROUTINE PCUNGLQ( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) IA, INFO, JA, K, LWORK, M, + $ N, NPROW, NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCUNGLQ inputs: ,IA:',I9,', INFO:',I9, + $ ', JA:',I9,', K:',I9,', LWORK:',I9,', M:',I9, + $ ', N:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9,', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -233,15 +263,28 @@ SUBROUTINE PCUNGLQ( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCUNGLQ', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( M.LE.0 ) - $ RETURN + IF( M.LE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * IPW = DESCA( MB_ ) * DESCA( MB_ ) + 1 IN = MIN( ICEIL( IA, DESCA( MB_ ) ) * DESCA( MB_ ), IA+K-1 ) @@ -327,6 +370,10 @@ SUBROUTINE PCUNGLQ( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCUNGLQ diff --git a/SRC/pcungql.f b/SRC/pcungql.f index 3e9b6fac..c67b02d2 100644 --- a/SRC/pcungql.f +++ b/SRC/pcungql.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCUNGQL( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, $ INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCUNGQL( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. INTEGER IA, INFO, JA, K, LWORK, M, N * .. @@ -185,11 +192,34 @@ SUBROUTINE PCUNGQL( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) IA, INFO, JA, K, LWORK, M, + $ N, NPROW, NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCUNGQL inputs: ,IA:',I9,', INFO:',I9, + $ ', JA:',I9,', K:',I9,', LWORK:',I9,', M:',I9, + $ ', N:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9,', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -231,15 +261,28 @@ SUBROUTINE PCUNGQL( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, END IF IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCUNGQL', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.LE.0 ) - $ RETURN + IF( N.LE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * IPW = DESCA( NB_ )*DESCA( NB_ ) + 1 JN = MIN( ICEIL( JA+N-K, DESCA( NB_ ) )*DESCA( NB_ ), JA+N-1 ) @@ -293,6 +336,10 @@ SUBROUTINE PCUNGQL( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCUNGQL diff --git a/SRC/pcungqr.f b/SRC/pcungqr.f index 6f525125..c3c5a598 100644 --- a/SRC/pcungqr.f +++ b/SRC/pcungqr.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCUNGQR( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, $ INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCUNGQR( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. INTEGER IA, INFO, JA, K, LWORK, M, N * .. @@ -187,11 +194,34 @@ SUBROUTINE PCUNGQR( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) IA, INFO, JA, K, LWORK, M, + $ N, NPROW, NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCUNGQR inputs: ,IA:',I9,', INFO:',I9, + $ ', JA:',I9,', K:',I9,', LWORK:',I9,', M:',I9, + $ ', N:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9,', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -234,15 +264,28 @@ SUBROUTINE PCUNGQR( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCUNGQR', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( N.LE.0 ) - $ RETURN + IF( N.LE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * IPW = DESCA( NB_ )*DESCA( NB_ ) + 1 JN = MIN( ICEIL( JA, DESCA( NB_ ) ) * DESCA( NB_ ), JA+K-1 ) @@ -329,6 +372,10 @@ SUBROUTINE PCUNGQR( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCUNGQR diff --git a/SRC/pcungr2.f b/SRC/pcungr2.f index f39d940c..b2cbc600 100644 --- a/SRC/pcungr2.f +++ b/SRC/pcungr2.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCUNGR2( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, $ INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCUNGR2( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. INTEGER IA, INFO, JA, K, LWORK, M, N * .. @@ -184,11 +191,34 @@ SUBROUTINE PCUNGR2( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) IA, INFO, JA, K, LWORK, M, + $ N, NPROW, NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCUNGR2 inputs: ,IA:',I9,', INFO:',I9, + $ ', JA:',I9,', K:',I9,', LWORK:',I9,', M:',I9, + $ ', N:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9,', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -221,15 +251,28 @@ SUBROUTINE PCUNGR2( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCUNGR2', -INFO ) CALL BLACS_ABORT( ICTXT, 1 ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( M.LE.0 ) - $ RETURN + IF( M.LE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * CALL PB_TOPGET( ICTXT, 'Broadcast', 'Rowwise', ROWBTOP ) CALL PB_TOPGET( ICTXT, 'Broadcast', 'Columnwise', COLBTOP ) @@ -277,6 +320,10 @@ SUBROUTINE PCUNGR2( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCUNGR2 diff --git a/SRC/pcungrq.f b/SRC/pcungrq.f index ea18868a..1e9e9118 100644 --- a/SRC/pcungrq.f +++ b/SRC/pcungrq.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCUNGRQ( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, $ INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCUNGRQ( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. INTEGER IA, INFO, JA, K, LWORK, M, N * .. @@ -186,11 +193,34 @@ SUBROUTINE PCUNGRQ( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) IA, INFO, JA, K, LWORK, M, + $ N, NPROW, NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCUNGRQ inputs: ,IA:',I9,', INFO:',I9, + $ ', JA:',I9,', K:',I9,', LWORK:',I9,', M:',I9, + $ ', N:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9,', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -233,15 +263,28 @@ SUBROUTINE PCUNGRQ( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCUNGRQ', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( M.LE.0 ) - $ RETURN + IF( M.LE.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * IPW = DESCA( MB_ )*DESCA( MB_ ) + 1 IN = MIN( ICEIL( IA+M-K, DESCA( MB_ ) )*DESCA( MB_ ), IA+M-1 ) @@ -295,6 +338,10 @@ SUBROUTINE PCUNGRQ( M, N, K, A, IA, JA, DESCA, TAU, WORK, LWORK, * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCUNGRQ diff --git a/SRC/pcunm2l.f b/SRC/pcunm2l.f index 7daab3be..86af2ebe 100644 --- a/SRC/pcunm2l.f +++ b/SRC/pcunm2l.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCUNM2L( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, $ C, IC, JC, DESCC, WORK, LWORK, INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCUNM2L( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER IA, IC, INFO, JA, JC, K, LWORK, M, N @@ -239,11 +246,37 @@ SUBROUTINE PCUNM2L( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) SIDE, TRANS, IA, IC, INFO, + $ JA, JC, K, LWORK, M, N, NPROW, NPCOL, + $ MYROW, MYCOL, eos_str + 102 FORMAT('PCUNM2L inputs: ,SIDE:',A5,', TRANS:',A5, + $ ', IA:',I9,', IC:',I9,', INFO:',I9, + $ ', JA:',I9,', JC:',I9,', K:',I9,', LWORK:',I9, + $ ', M:',I9,', N:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9, + $ ', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -314,15 +347,28 @@ SUBROUTINE PCUNM2L( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCUNM2L', -INFO ) CALL BLACS_ABORT( ICTXT, 1 ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * IF( DESCA( M_ ).EQ.1 ) THEN CALL INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL, II, @@ -438,6 +484,10 @@ SUBROUTINE PCUNM2L( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCUNM2L diff --git a/SRC/pcunm2r.f b/SRC/pcunm2r.f index f52fdb65..52c93aa2 100644 --- a/SRC/pcunm2r.f +++ b/SRC/pcunm2r.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCUNM2R( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, $ C, IC, JC, DESCC, WORK, LWORK, INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCUNM2R( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER IA, IC, INFO, JA, JC, K, LWORK, M, N @@ -239,11 +246,37 @@ SUBROUTINE PCUNM2R( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) SIDE, TRANS, IA, IC, INFO, + $ JA, JC, K, LWORK, M, N, NPROW, NPCOL, + $ MYROW, MYCOL, eos_str + 102 FORMAT('PCUNM2R inputs: ,SIDE:',A5,', TRANS:',A5, + $ ', IA:',I9,', IC:',I9,', INFO:',I9, + $ ', JA:',I9,', JC:',I9,', K:',I9,', LWORK:',I9, + $ ', M:',I9,', N:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9, + $ ', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -315,15 +348,28 @@ SUBROUTINE PCUNM2R( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCUNM2R', -INFO ) CALL BLACS_ABORT( ICTXT, 1 ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * IF( DESCA( M_ ).EQ.1 ) THEN CALL INFOG2L( IA, JA, DESCA, NPROW, NPCOL, MYROW, MYCOL, II, @@ -442,6 +488,10 @@ SUBROUTINE PCUNM2R( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCUNM2R diff --git a/SRC/pcunmbr.f b/SRC/pcunmbr.f index b8d153aa..b5a50a29 100644 --- a/SRC/pcunmbr.f +++ b/SRC/pcunmbr.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCUNMBR( VECT, SIDE, TRANS, M, N, K, A, IA, JA, DESCA, $ TAU, C, IC, JC, DESCC, WORK, LWORK, INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCUNMBR( VECT, SIDE, TRANS, M, N, K, A, IA, JA, DESCA, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER SIDE, TRANS, VECT INTEGER IA, IC, INFO, JA, JC, K, LWORK, M, N @@ -311,11 +318,37 @@ SUBROUTINE PCUNMBR( VECT, SIDE, TRANS, M, N, K, A, IA, JA, DESCA, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) SIDE, TRANS, VECT, IA, IC, + $ INFO, JA, JC, K, LWORK, M, N, NPROW, + $ NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCUNMBR inputs: ,SIDE:',A5,', TRANS:',A5, + $ ', VECT:',A5,', IA:',I9,', IC:',I9, + $ ', INFO:',I9,', JA:',I9,', JC:',I9, + $ ', K:',I9,', LWORK:',I9,', M:',I9,', N:',I9, + $ ', NPROW: ', I9,', NPCOL: ', I9 , + $ ', MYROW: ', I9,', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -530,15 +563,28 @@ SUBROUTINE PCUNMBR( VECT, SIDE, TRANS, M, N, K, A, IA, JA, DESCA, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCUNMBR', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN + IF( M.EQ.0 .OR. N.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * IF( APPLYQ ) THEN * @@ -584,6 +630,10 @@ SUBROUTINE PCUNMBR( VECT, SIDE, TRANS, M, N, K, A, IA, JA, DESCA, * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCUNMBR diff --git a/SRC/pcunmhr.f b/SRC/pcunmhr.f index 4cae589d..9640b12a 100644 --- a/SRC/pcunmhr.f +++ b/SRC/pcunmhr.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, IA, JA, DESCA, $ TAU, C, IC, JC, DESCC, WORK, LWORK, INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, IA, JA, DESCA, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER IA, IC, IHI, ILO, INFO, JA, JC, LWORK, M, N @@ -248,11 +255,37 @@ SUBROUTINE PCUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, IA, JA, DESCA, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) SIDE, TRANS, IA, IC, IHI, ILO, + $ INFO, JA, JC, LWORK, M, N, NPROW, + $ NPCOL, MYROW, MYCOL, eos_str + 102 FORMAT('PCUNMHR inputs: ,SIDE:',A5,', TRANS:',A5, + $ ', IA:',I9,', IC:',I9,', IHI:',I9, + $ ', ILO:',I9,', INFO:',I9,', JA:',I9, + $ ', JC:',I9,', LWORK:',I9,', M:',I9, + $ ', N:',I9,', NPROW: ', I9,', NPCOL: ', I9 , + $ ', MYROW: ', I9,', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -374,21 +407,38 @@ SUBROUTINE PCUNMHR( SIDE, TRANS, M, N, ILO, IHI, A, IA, JA, DESCA, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCUNMHR', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 ) - $ RETURN + IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * CALL PCUNMQR( SIDE, TRANS, MI, NI, NH, A, IAA, JAA, DESCA, TAU, $ C, ICC, JCC, DESCC, WORK, LWORK, IINFO ) * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCUNMHR diff --git a/SRC/pcunml2.f b/SRC/pcunml2.f index 154944c8..9336e184 100644 --- a/SRC/pcunml2.f +++ b/SRC/pcunml2.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCUNML2( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, $ C, IC, JC, DESCC, WORK, LWORK, INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCUNML2( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER IA, IC, INFO, JA, JC, K, LWORK, M, N @@ -238,11 +245,37 @@ SUBROUTINE PCUNML2( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) SIDE, TRANS, IA, IC, INFO, + $ JA, JC, K, LWORK, M, N, NPROW, NPCOL, + $ MYROW, MYCOL, eos_str + 102 FORMAT('PCUNML2 inputs: ,SIDE:',A5,', TRANS:',A5, + $ ', IA:',I9,', IC:',I9,', INFO:',I9, + $ ', JA:',I9,', JC:',I9,', K:',I9,', LWORK:',I9, + $ ', M:',I9,', N:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9, + $ ', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -318,15 +351,28 @@ SUBROUTINE PCUNML2( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCUNML2', -INFO ) CALL BLACS_ABORT( ICTXT, 1 ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * CALL PB_TOPGET( ICTXT, 'Broadcast', 'Rowwise', ROWBTOP ) CALL PB_TOPGET( ICTXT, 'Broadcast', 'Columnwise', COLBTOP ) @@ -395,6 +441,10 @@ SUBROUTINE PCUNML2( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCUNML2 diff --git a/SRC/pcunmlq.f b/SRC/pcunmlq.f index 0671d5bc..20d985a7 100644 --- a/SRC/pcunmlq.f +++ b/SRC/pcunmlq.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCUNMLQ( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, $ C, IC, JC, DESCC, WORK, LWORK, INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCUNMLQ( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER IA, IC, INFO, JA, JC, K, LWORK, M, N @@ -247,11 +254,37 @@ SUBROUTINE PCUNMLQ( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) SIDE, TRANS, IA, IC, INFO, + $ JA, JC, K, LWORK, M, N, NPROW, NPCOL, + $ MYROW, MYCOL, eos_str + 102 FORMAT('PCUNMLQ inputs: ,SIDE:',A5,', TRANS:',A5, + $ ', IA:',I9,', IC:',I9,', INFO:',I9, + $ ', JA:',I9,', JC:',I9,', K:',I9,', LWORK:',I9, + $ ', M:',I9,', N:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9, + $ ', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -355,15 +388,28 @@ SUBROUTINE PCUNMLQ( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCUNMLQ', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * CALL PB_TOPGET( ICTXT, 'Broadcast', 'Rowwise', ROWBTOP ) CALL PB_TOPGET( ICTXT, 'Broadcast', 'Columnwise', COLBTOP ) @@ -444,6 +490,10 @@ SUBROUTINE PCUNMLQ( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCUNMLQ diff --git a/SRC/pcunmql.f b/SRC/pcunmql.f index 88aad1f4..62352471 100644 --- a/SRC/pcunmql.f +++ b/SRC/pcunmql.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCUNMQL( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, $ C, IC, JC, DESCC, WORK, LWORK, INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCUNMQL( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER IA, IC, INFO, JA, JC, K, LWORK, M, N @@ -247,11 +254,37 @@ SUBROUTINE PCUNMQL( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) SIDE, TRANS, IA, IC, INFO, + $ JA, JC, K, LWORK, M, N, NPROW, NPCOL, + $ MYROW, MYCOL, eos_str + 102 FORMAT('PCUNMQL inputs: ,SIDE:',A5,', TRANS:',A5, + $ ', IA:',I9,', IC:',I9,', INFO:',I9, + $ ', JA:',I9,', JC:',I9,', K:',I9,', LWORK:',I9, + $ ', M:',I9,', N:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9, + $ ', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -356,15 +389,28 @@ SUBROUTINE PCUNMQL( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCUNMQL', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * CALL PB_TOPGET( ICTXT, 'Broadcast', 'Rowwise', ROWBTOP ) CALL PB_TOPGET( ICTXT, 'Broadcast', 'Columnwise', COLBTOP ) @@ -451,6 +497,10 @@ SUBROUTINE PCUNMQL( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCUNMQL diff --git a/SRC/pcunmqr.f b/SRC/pcunmqr.f index 28098159..339718da 100644 --- a/SRC/pcunmqr.f +++ b/SRC/pcunmqr.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCUNMQR( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, $ C, IC, JC, DESCC, WORK, LWORK, INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCUNMQR( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER IA, IC, INFO, JA, JC, K, LWORK, M, N @@ -247,11 +254,37 @@ SUBROUTINE PCUNMQR( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) SIDE, TRANS, IA, IC, INFO, + $ JA, JC, K, LWORK, M, N, NPROW, NPCOL, + $ MYROW, MYCOL, eos_str + 102 FORMAT('PCUNMQR inputs: ,SIDE:',A5,', TRANS:',A5, + $ ', IA:',I9,', IC:',I9,', INFO:',I9, + $ ', JA:',I9,', JC:',I9,', K:',I9,', LWORK:',I9, + $ ', M:',I9,', N:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9, + $ ', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -356,15 +389,28 @@ SUBROUTINE PCUNMQR( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCUNMQR', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * CALL PB_TOPGET( ICTXT, 'Broadcast', 'Rowwise', ROWBTOP ) CALL PB_TOPGET( ICTXT, 'Broadcast', 'Columnwise', COLBTOP ) @@ -443,6 +489,10 @@ SUBROUTINE PCUNMQR( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCUNMQR diff --git a/SRC/pcunmr2.f b/SRC/pcunmr2.f index 9ae20c95..940c8a9a 100644 --- a/SRC/pcunmr2.f +++ b/SRC/pcunmr2.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCUNMR2( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, $ C, IC, JC, DESCC, WORK, LWORK, INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCUNMR2( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER IA, IC, INFO, JA, JC, K, LWORK, M, N @@ -237,11 +244,37 @@ SUBROUTINE PCUNMR2( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) SIDE, TRANS, IA, IC, INFO, + $ JA, JC, K, LWORK, M, N, NPROW, NPCOL, + $ MYROW, MYCOL, eos_str + 102 FORMAT('PCUNMR2 inputs: ,SIDE:',A5,', TRANS:',A5, + $ ', IA:',I9,', IC:',I9,', INFO:',I9, + $ ', JA:',I9,', JC:',I9,', K:',I9,', LWORK:',I9, + $ ', M:',I9,', N:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9, + $ ', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -313,15 +346,28 @@ SUBROUTINE PCUNMR2( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCUNMR2', -INFO ) CALL BLACS_ABORT( ICTXT, 1 ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * CALL PB_TOPGET( ICTXT, 'Broadcast', 'Rowwise', ROWBTOP ) CALL PB_TOPGET( ICTXT, 'Broadcast', 'Columnwise', COLBTOP ) @@ -382,6 +428,10 @@ SUBROUTINE PCUNMR2( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCUNMR2 diff --git a/SRC/pcunmr3.f b/SRC/pcunmr3.f index 419346ed..8aac70f4 100644 --- a/SRC/pcunmr3.f +++ b/SRC/pcunmr3.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCUNMR3( SIDE, TRANS, M, N, K, L, A, IA, JA, DESCA, $ TAU, C, IC, JC, DESCC, WORK, LWORK, INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCUNMR3( SIDE, TRANS, M, N, K, L, A, IA, JA, DESCA, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER IA, IC, INFO, JA, JC, K, L, LWORK, M, N @@ -239,11 +246,37 @@ SUBROUTINE PCUNMR3( SIDE, TRANS, M, N, K, L, A, IA, JA, DESCA, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) SIDE, TRANS, IA, IC, INFO, + $ JA, JC, K, L, LWORK, M, N, NPROW, NPCOL, + $ MYROW, MYCOL, eos_str + 102 FORMAT('PCUNMR3 inputs: ,SIDE:',A5,', TRANS:',A5, + $ ', IA:',I9,', IC:',I9,', INFO:',I9, + $ ', JA:',I9,', JC:',I9,', K:',I9,', L:',I9, + $ ', LWORK:',I9,', M:',I9,', N:',I9, + $ ', NPROW: ', I9,', NPCOL: ', I9 , + $ ', MYROW: ', I9,', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -317,15 +350,28 @@ SUBROUTINE PCUNMR3( SIDE, TRANS, M, N, K, L, A, IA, JA, DESCA, IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCUNMR3', -INFO ) CALL BLACS_ABORT( ICTXT, 1 ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * CALL PB_TOPGET( ICTXT, 'Broadcast', 'Rowwise', ROWBTOP ) CALL PB_TOPGET( ICTXT, 'Broadcast', 'Columnwise', COLBTOP ) @@ -388,6 +434,10 @@ SUBROUTINE PCUNMR3( SIDE, TRANS, M, N, K, L, A, IA, JA, DESCA, * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCUNMR3 diff --git a/SRC/pcunmrq.f b/SRC/pcunmrq.f index d25ecb93..e20cd0da 100644 --- a/SRC/pcunmrq.f +++ b/SRC/pcunmrq.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCUNMRQ( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, $ C, IC, JC, DESCC, WORK, LWORK, INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCUNMRQ( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER IA, IC, INFO, JA, JC, K, LWORK, M, N @@ -247,11 +254,37 @@ SUBROUTINE PCUNMRQ( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) SIDE, TRANS, IA, IC, INFO, + $ JA, JC, K, LWORK, M, N, NPROW, NPCOL, + $ MYROW, MYCOL, eos_str + 102 FORMAT('PCUNMRQ inputs: ,SIDE:',A5,', TRANS:',A5, + $ ', IA:',I9,', IC:',I9,', INFO:',I9, + $ ', JA:',I9,', JC:',I9,', K:',I9,', LWORK:',I9, + $ ', M:',I9,', N:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9, + $ ', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -367,15 +400,28 @@ SUBROUTINE PCUNMRQ( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCUNMRQ', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * CALL PB_TOPGET( ICTXT, 'Broadcast', 'Rowwise', ROWBTOP ) CALL PB_TOPGET( ICTXT, 'Broadcast', 'Columnwise', COLBTOP ) @@ -468,6 +514,10 @@ SUBROUTINE PCUNMRQ( SIDE, TRANS, M, N, K, A, IA, JA, DESCA, TAU, * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCUNMRQ diff --git a/SRC/pcunmrz.f b/SRC/pcunmrz.f index ee54ee18..b90dff8e 100644 --- a/SRC/pcunmrz.f +++ b/SRC/pcunmrz.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCUNMRZ( SIDE, TRANS, M, N, K, L, A, IA, JA, DESCA, $ TAU, C, IC, JC, DESCC, WORK, LWORK, INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCUNMRZ( SIDE, TRANS, M, N, K, L, A, IA, JA, DESCA, * and University of California, Berkeley. * May 25, 2001 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER SIDE, TRANS INTEGER IA, IC, INFO, JA, JC, K, L, LWORK, M, N @@ -252,11 +259,37 @@ SUBROUTINE PCUNMRZ( SIDE, TRANS, M, N, K, L, A, IA, JA, DESCA, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) SIDE, TRANS, IA, IC, INFO, + $ JA, JC, K, L, LWORK, M, N, NPROW, NPCOL, + $ MYROW, MYCOL, eos_str + 102 FORMAT('PCUNMRZ inputs: ,SIDE:',A5,', TRANS:',A5, + $ ', IA:',I9,', IC:',I9,', INFO:',I9, + $ ', JA:',I9,', JC:',I9,', K:',I9,', L:',I9, + $ ', LWORK:',I9,', M:',I9,', N:',I9, + $ ', NPROW: ', I9,', NPCOL: ', I9 , + $ ', MYROW: ', I9,', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -364,15 +397,28 @@ SUBROUTINE PCUNMRZ( SIDE, TRANS, M, N, K, L, A, IA, JA, DESCA, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCUNMRZ', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * CALL PB_TOPGET( ICTXT, 'Broadcast', 'Rowwise', ROWBTOP ) CALL PB_TOPGET( ICTXT, 'Broadcast', 'Columnwise', COLBTOP ) @@ -471,6 +517,10 @@ SUBROUTINE PCUNMRZ( SIDE, TRANS, M, N, K, L, A, IA, JA, DESCA, * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCUNMRZ diff --git a/SRC/pcunmtr.f b/SRC/pcunmtr.f index 7c2a4b64..95e0469c 100644 --- a/SRC/pcunmtr.f +++ b/SRC/pcunmtr.f @@ -1,3 +1,9 @@ +* +* Modifications Copyright (c) 2023 Advanced Micro Devices, Inc.  All rights reserved. +* +* +#include "SL_Context_fortran_include.h" +* SUBROUTINE PCUNMTR( SIDE, UPLO, TRANS, M, N, A, IA, JA, DESCA, $ TAU, C, IC, JC, DESCC, WORK, LWORK, INFO ) * @@ -6,6 +12,7 @@ SUBROUTINE PCUNMTR( SIDE, UPLO, TRANS, M, N, A, IA, JA, DESCA, * and University of California, Berkeley. * May 1, 1997 * + USE LINK_TO_C_GLOBALS * .. Scalar Arguments .. CHARACTER SIDE, TRANS, UPLO INTEGER IA, IC, INFO, JA, JC, LWORK, M, N @@ -262,11 +269,37 @@ SUBROUTINE PCUNMTR( SIDE, UPLO, TRANS, M, N, A, IA, JA, DESCA, * .. * .. Executable Statements .. * +* Initialize framework context structure if not initialized +* +* + CALL AOCL_SCALAPACK_INIT( ) +* +* +* Capture the subroutine entry in the trace file +* + AOCL_DTL_TRACE_ENTRY_F +* * Get grid parameters * ICTXT = DESCA( CTXT_ ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) * +* Update the log buffer with the scalar arguments details, +* MPI process grid information and write to the log file +* + IF( SCALAPACK_CONTEXT%IS_LOG_ENABLED.EQ.1 ) THEN + WRITE(LOG_BUF,102) SIDE, TRANS, UPLO, IA, IC, + $ INFO, JA, JC, LWORK, M, N, NPROW, NPCOL, + $ MYROW, MYCOL, eos_str + 102 FORMAT('PCUNMTR inputs: ,SIDE:',A5,', TRANS:',A5, + $ ', UPLO:',A5,', IA:',I9,', IC:',I9, + $ ', INFO:',I9,', JA:',I9,', JC:',I9, + $ ', LWORK:',I9,', M:',I9,', N:',I9,', NPROW: ', I9, + $ ', NPCOL: ', I9 ,', MYROW: ', I9, + $ ', MYCOL: ', I9, A1) + AOCL_DTL_LOG_ENTRY_F + END IF +* * Test the input parameters * INFO = 0 @@ -402,15 +435,28 @@ SUBROUTINE PCUNMTR( SIDE, UPLO, TRANS, M, N, A, IA, JA, DESCA, * IF( INFO.NE.0 ) THEN CALL PXERBLA( ICTXT, 'PCUNMTR', -INFO ) +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN ELSE IF( LQUERY ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN END IF * * Quick return if possible * - IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) - $ RETURN + IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F + RETURN + END IF * IF( UPPER ) THEN * @@ -430,6 +476,10 @@ SUBROUTINE PCUNMTR( SIDE, UPLO, TRANS, M, N, A, IA, JA, DESCA, * WORK( 1 ) = CMPLX( REAL( LWMIN ) ) * +* +* Capture the subroutine exit in the trace file +* + AOCL_DTL_TRACE_EXIT_F RETURN * * End of PCUNMTR diff --git a/SRC/pzlaconsb.f b/SRC/pzlaconsb.f index 69d32e8a..1bf9a0c3 100644 --- a/SRC/pzlaconsb.f +++ b/SRC/pzlaconsb.f @@ -223,8 +223,8 @@ SUBROUTINE PZLACONSB( A, DESCA, I, L, M, H44, H33, H43H34, BUF, WRITE(LOG_BUF,102) I, L, LWORK, M, H33, H43H34, $ H44, NPROW, NPCOL, MYROW, MYCOL, eos_str 102 FORMAT('PZLACONSB inputs: ,I:',I9,', L:',I9,', LWORK:',I9, - $ ', M:',I9,', H33:',F9.4, A, F9.4, - $ ', H43H34:',F9.4, A, F9.4,', H44:',F9.4, A, F9.4, + $ ', M:',I9,', H33:',A, F9.4, + $ ', H43H34:',A, F9.4,', H44:',A, F9.4, $ ', NPROW: ', I9, $ ', NPCOL: ', I9 ,', MYROW: ', I9, $ ', MYCOL: ', I9, A1) diff --git a/SRC/pzlarfg.f b/SRC/pzlarfg.f index 8e78cacb..378dc7ab 100644 --- a/SRC/pzlarfg.f +++ b/SRC/pzlarfg.f @@ -202,7 +202,7 @@ SUBROUTINE PZLARFG( N, ALPHA, IAX, JAX, X, IX, JX, DESCX, INCX, $ ALPHA, NPROW, NPCOL, MYROW, MYCOL, eos_str 102 FORMAT('PZLARFG inputs: ,IAX:',I9,', INCX:',I9, $ ', IX:',I9,', JAX:',I9,', JX:',I9,', N:',I9, - $ ', ALPHA:',F9.4, A, F9.4,', NPROW: ', I9, + $ ', ALPHA:',A, F9.4,', NPROW: ', I9, $ ', NPCOL: ', I9 ,', MYROW: ', I9, $ ', MYCOL: ', I9, A1) AOCL_DTL_LOG_ENTRY_F diff --git a/SRC/pzlawil.f b/SRC/pzlawil.f index 226e39ce..c4e1e4e6 100644 --- a/SRC/pzlawil.f +++ b/SRC/pzlawil.f @@ -172,8 +172,8 @@ SUBROUTINE PZLAWIL( II, JJ, M, A, DESCA, H44, H33, H43H34, V ) WRITE(LOG_BUF,102) II, JJ, M, H33, H43H34, H44, $ NPROW, NPCOL, MYROW, MYCOL, eos_str 102 FORMAT('PZLAWIL inputs: ,II:',I9,', JJ:',I9,', M:',I9, - $ ', H33:',F9.4, A, F9.4,', H43H34:',F9.4, A, F9.4, - $ ', H44:',F9.4, A, F9.4, + $ ', H33:',A, F9.4,', H43H34:',A, F9.4, + $ ', H44:',A, F9.4, $ ', NPROW: ', I9,', NPCOL: ', I9 , $ ', MYROW: ', I9,', MYCOL: ', I9, A1) AOCL_DTL_LOG_ENTRY_F diff --git a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pcgeqrf.c b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pcgeqrf.c index 122aee38..ec714371 100644 --- a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pcgeqrf.c +++ b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pcgeqrf.c @@ -109,12 +109,12 @@ int main(int argc, char **argv) { Int lwork = -1; tau = (SL_complex_float *)calloc((mpA+nqA),sizeof(SL_complex_float)) ; - Int k = 0; - for (Int j = 0; j < nqA; j++) { // local col + Int k = 0, i, j; + for (j = 0; j < nqA; j++) { // local col Int l_j = j / nb; // which block Int x_j = j % nb; // where within that block Int J = (l_j * npcol + mycol) * nb + x_j; // global col - for (Int i = 0; i < mpA; i++) { // local row + for (i = 0; i < mpA; i++) { // local row Int l_i = i / nb; // which block Int x_i = i % nb; // where within that block Int I = (l_i * nprow + myrow) * nb + x_i; // global row diff --git a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pcgetrf.c b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pcgetrf.c index 78987464..b3703d95 100644 --- a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pcgetrf.c +++ b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pcgetrf.c @@ -101,12 +101,12 @@ int main(int argc, char **argv) { IPPIV = (Int *)calloc(2*n,sizeof(Int)) ; if (IPPIV==NULL){ printf("Error of memory allocation IPPIV %d\n",2*n); exit(0); } - Int k = 0; - for (Int j = 0; j < nqA; j++) { // local col + Int k = 0, i, j; + for (j = 0; j < nqA; j++) { // local col Int l_j = j / nb; // which block Int x_j = j % nb; // where within that block Int J = (l_j * npcol + mycol) * nb + x_j; // global col - for (Int i = 0; i < mpA; i++) { // local row + for (i = 0; i < mpA; i++) { // local row Int l_i = i / nb; // which block Int x_i = i % nb; // where within that block Int I = (l_i * nprow + myrow) * nb + x_i; // global row diff --git a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pcpotrf.c b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pcpotrf.c index 91d1091d..666ef7d1 100644 --- a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pcpotrf.c +++ b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pcpotrf.c @@ -97,12 +97,12 @@ int main(int argc, char **argv) { A = (SL_complex_float *)calloc(mpA*nqA,sizeof(SL_complex_float)) ; if (A==NULL){ printf("Error of memory allocation A on proc %dx%d\n",myrow,mycol); exit(0); } - Int k = 0; - for (Int j = 0; j < nqA; j++) { // local col + Int k = 0, i, j; + for (j = 0; j < nqA; j++) { // local col Int l_j = j / nb; // which block Int x_j = j % nb; // where within that block Int J = (l_j * npcol + mycol) * nb + x_j; // global col - for (Int i = 0; i < mpA; i++) { // local row + for (i = 0; i < mpA; i++) { // local row Int l_i = i / nb; // which block Int x_i = i % nb; // where within that block Int I = (l_i * nprow + myrow) * nb + x_i; // global row diff --git a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pdgeqrf.c b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pdgeqrf.c index 47bb14a5..9dd09f49 100644 --- a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pdgeqrf.c +++ b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pdgeqrf.c @@ -108,12 +108,12 @@ int main(int argc, char **argv) { Int lwork = -1; tau = (double *)calloc((mpA+nqA),sizeof(double)) ; - Int k = 0; - for (Int j = 0; j < nqA; j++) { // local col + Int k = 0, i, j; + for (j = 0; j < nqA; j++) { // local col Int l_j = j / nb; // which block Int x_j = j % nb; // where within that block Int J = (l_j * npcol + mycol) * nb + x_j; // global col - for (Int i = 0; i < mpA; i++) { // local row + for (i = 0; i < mpA; i++) { // local row Int l_i = i / nb; // which block Int x_i = i % nb; // where within that block Int I = (l_i * nprow + myrow) * nb + x_i; // global row diff --git a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pdgetrf.c b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pdgetrf.c index 9afcb2f8..42407b21 100644 --- a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pdgetrf.c +++ b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pdgetrf.c @@ -99,12 +99,12 @@ int main(int argc, char **argv) { IPPIV = (Int *)calloc(2*n,sizeof(Int)) ; if (IPPIV==NULL){ printf("Error of memory allocation IPPIV %d\n",2*n); exit(0); } - Int k = 0; - for (Int j = 0; j < nqA; j++) { // local col + Int k = 0, i, j; + for (j = 0; j < nqA; j++) { // local col Int l_j = j / nb; // which block Int x_j = j % nb; // where within that block Int J = (l_j * npcol + mycol) * nb + x_j; // global col - for (Int i = 0; i < mpA; i++) { // local row + for (i = 0; i < mpA; i++) { // local row Int l_i = i / nb; // which block Int x_i = i % nb; // where within that block Int I = (l_i * nprow + myrow) * nb + x_i; // global row diff --git a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pdpotrf.c b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pdpotrf.c index cb3334d8..7266fac8 100644 --- a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pdpotrf.c +++ b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pdpotrf.c @@ -95,12 +95,12 @@ int main(int argc, char **argv) { A = (double *)calloc(mpA*nqA,sizeof(double)) ; if (A==NULL){ printf("Error of memory allocation A on proc %dx%d\n",myrow,mycol); exit(0); } - Int k = 0; - for (Int j = 0; j < nqA; j++) { // local col + Int k = 0, i, j; + for (j = 0; j < nqA; j++) { // local col Int l_j = j / nb; // which block Int x_j = j % nb; // where within that block Int J = (l_j * npcol + mycol) * nb + x_j; // global col - for (Int i = 0; i < mpA; i++) { // local row + for (i = 0; i < mpA; i++) { // local row Int l_i = i / nb; // which block Int x_i = i % nb; // where within that block Int I = (l_i * nprow + myrow) * nb + x_i; // global row diff --git a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_psgeqrf.c b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_psgeqrf.c index 793fdc5d..92ce25d5 100644 --- a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_psgeqrf.c +++ b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_psgeqrf.c @@ -108,12 +108,12 @@ int main(int argc, char **argv) { Int lwork = -1; tau = (float *)calloc((mpA+nqA),sizeof(float)) ; - Int k = 0; - for (Int j = 0; j < nqA; j++) { // local col + Int k = 0, i, j; + for (j = 0; j < nqA; j++) { // local col Int l_j = j / nb; // which block Int x_j = j % nb; // where within that block Int J = (l_j * npcol + mycol) * nb + x_j; // global col - for (Int i = 0; i < mpA; i++) { // local row + for (i = 0; i < mpA; i++) { // local row Int l_i = i / nb; // which block Int x_i = i % nb; // where within that block Int I = (l_i * nprow + myrow) * nb + x_i; // global row diff --git a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_psgetrf.c b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_psgetrf.c index 27792a24..6a609ef8 100644 --- a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_psgetrf.c +++ b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_psgetrf.c @@ -100,12 +100,12 @@ int main(int argc, char **argv) { IPPIV = (Int *)calloc(2*n,sizeof(Int)) ; if (IPPIV==NULL){ printf("Error of memory allocation IPPIV %d\n",2*n); exit(0); } - Int k = 0; - for (Int j = 0; j < nqA; j++) { // local col + Int k = 0, i, j; + for (j = 0; j < nqA; j++) { // local col Int l_j = j / nb; // which block Int x_j = j % nb; // where within that block Int J = (l_j * npcol + mycol) * nb + x_j; // global col - for (Int i = 0; i < mpA; i++) { // local row + for (i = 0; i < mpA; i++) { // local row Int l_i = i / nb; // which block Int x_i = i % nb; // where within that block Int I = (l_i * nprow + myrow) * nb + x_i; // global row diff --git a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pspotrf.c b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pspotrf.c index 457e1376..21405e43 100644 --- a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pspotrf.c +++ b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pspotrf.c @@ -94,12 +94,12 @@ int main(int argc, char **argv) { A = (float *)calloc(mpA*nqA,sizeof(float)) ; if (A==NULL){ printf("Error of memory allocation A on proc %dx%d\n",myrow,mycol); exit(0); } - Int k = 0; - for (Int j = 0; j < nqA; j++) { // local col + Int k = 0, i, j; + for (j = 0; j < nqA; j++) { // local col Int l_j = j / nb; // which block Int x_j = j % nb; // where within that block Int J = (l_j * npcol + mycol) * nb + x_j; // global col - for (Int i = 0; i < mpA; i++) { // local row + for (i = 0; i < mpA; i++) { // local row Int l_i = i / nb; // which block Int x_i = i % nb; // where within that block Int I = (l_i * nprow + myrow) * nb + x_i; // global row diff --git a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pzgeqrf.c b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pzgeqrf.c index 306b969a..29b1c69a 100644 --- a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pzgeqrf.c +++ b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pzgeqrf.c @@ -110,12 +110,12 @@ int main(int argc, char **argv) { Int lwork = -1; tau = (SL_complex_double *)calloc((mpA+nqA),sizeof(SL_complex_double)) ; - Int k = 0; - for (Int j = 0; j < nqA; j++) { // local col + Int k = 0, i, j; + for (j = 0; j < nqA; j++) { // local col Int l_j = j / nb; // which block Int x_j = j % nb; // where within that block Int J = (l_j * npcol + mycol) * nb + x_j; // global col - for (Int i = 0; i < mpA; i++) { // local row + for (i = 0; i < mpA; i++) { // local row Int l_i = i / nb; // which block Int x_i = i % nb; // where within that block Int I = (l_i * nprow + myrow) * nb + x_i; // global row diff --git a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pzgetrf.c b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pzgetrf.c index 6f98415a..25d0bb3b 100644 --- a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pzgetrf.c +++ b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pzgetrf.c @@ -101,12 +101,12 @@ int main(int argc, char **argv) { IPPIV = (Int *)calloc(2*n,sizeof(Int)) ; if (IPPIV==NULL){ printf("Error of memory allocation IPPIV %d\n",2*n); exit(0); } - Int k = 0; - for (Int j = 0; j < nqA; j++) { // local col + Int k = 0, i, j; + for (j = 0; j < nqA; j++) { // local col Int l_j = j / nb; // which block Int x_j = j % nb; // where within that block Int J = (l_j * npcol + mycol) * nb + x_j; // global col - for (Int i = 0; i < mpA; i++) { // local row + for (i = 0; i < mpA; i++) { // local row Int l_i = i / nb; // which block Int x_i = i % nb; // where within that block Int I = (l_i * nprow + myrow) * nb + x_i; // global row diff --git a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pzpotrf.c b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pzpotrf.c index 43b1a60e..cecb4b0d 100644 --- a/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pzpotrf.c +++ b/TESTING/AOCL_PROGRESS_TESTS/test_aocl_progress_pzpotrf.c @@ -97,12 +97,12 @@ int main(int argc, char **argv) { A = (SL_complex_double *)calloc(mpA*nqA,sizeof(SL_complex_double)) ; if (A==NULL){ printf("Error of memory allocation A on proc %dx%d\n",myrow,mycol); exit(0); } - Int k = 0; - for (Int j = 0; j < nqA; j++) { // local col + Int k = 0, i, j; + for (j = 0; j < nqA; j++) { // local col Int l_j = j / nb; // which block Int x_j = j % nb; // where within that block Int J = (l_j * npcol + mycol) * nb + x_j; // global col - for (Int i = 0; i < mpA; i++) { // local row + for (i = 0; i < mpA; i++) { // local row Int l_i = i / nb; // which block Int x_i = i % nb; // where within that block Int I = (l_i * nprow + myrow) * nb + x_i; // global row diff --git a/TESTING/BLLT.dat b/TESTING/BLLT.dat index b92ec255..f9293a65 100644 --- a/TESTING/BLLT.dat +++ b/TESTING/BLLT.dat @@ -1,4 +1,4 @@ -'ScaLAPACK, Version 1.2, banded linear systems input file' +'ScaLAPACK, banded linear systems input file' 'MPI machine' '' output file name (if any) 6 device out diff --git a/TESTING/BLU.dat b/TESTING/BLU.dat index dc3fad10..bf42f583 100644 --- a/TESTING/BLU.dat +++ b/TESTING/BLU.dat @@ -1,4 +1,4 @@ -'ScaLAPACK, Version 1.2, banded linear systems input file' +'ScaLAPACK, banded linear systems input file' 'MPI machine' '' output file name (if any) 6 device out diff --git a/TESTING/EIG/CMakeLists.txt b/TESTING/EIG/CMakeLists.txt index ff8c1e52..2aaf57a2 100644 --- a/TESTING/EIG/CMakeLists.txt +++ b/TESTING/EIG/CMakeLists.txt @@ -23,16 +23,16 @@ add_executable(xdhrd pdhrddriver.f pdhrdinfo.f pdgehdrv.f pdlafchk.f ${dmatgen}) add_executable(xchrd pchrddriver.f pchrdinfo.f pcgehdrv.f pclafchk.f ${cmatgen}) add_executable(xzhrd pzhrddriver.f pzhrdinfo.f pzgehdrv.f pzlafchk.f ${zmatgen}) -if(MSVC) -add_executable(xstrd xpjlaenv.f SL_Context_module_eig.f pstrddriver.f psttrdtester.f pslatran.f pstrdinfo.f pssytdrv.f pslafchk.f ${TTRD_SRC}/pssyttrd.f ${smatgen}) -add_executable(xdtrd xpjlaenv.f SL_Context_module_eig.f pdtrddriver.f pdttrdtester.f pdlatran.f pdtrdinfo.f pdsytdrv.f pdlafchk.f ${TTRD_SRC}/pdsyttrd.f ${dmatgen}) -add_executable(xctrd xpjlaenv.f SL_Context_module_eig.f pctrddriver.f pcttrdtester.f pclatran.f pctrdinfo.f pchetdrv.f pclafchk.f ${TTRD_SRC}/pchettrd.f ${cmatgen}) -add_executable(xztrd xpjlaenv.f SL_Context_module_eig.f pztrddriver.f pzttrdtester.f pzlatran.f pztrdinfo.f pzhetdrv.f pzlafchk.f ${TTRD_SRC}/pzhettrd.f ${zmatgen}) +if(MSVC AND BUILD_SHARED_LIBS) + add_executable(xstrd xpjlaenv.f pstrddriver.f psttrdtester.f pslatran.f pstrdinfo.f pssytdrv.f pslafchk.f ${TTRD_SRC}/pssyttrd.f ${smatgen} SL_Context_module_eig.f ) + add_executable(xdtrd xpjlaenv.f pdtrddriver.f pdttrdtester.f pdlatran.f pdtrdinfo.f pdsytdrv.f pdlafchk.f ${TTRD_SRC}/pdsyttrd.f ${dmatgen} SL_Context_module_eig.f ) + add_executable(xctrd xpjlaenv.f pctrddriver.f pcttrdtester.f pclatran.f pctrdinfo.f pchetdrv.f pclafchk.f ${TTRD_SRC}/pchettrd.f ${cmatgen} SL_Context_module_eig.f ) + add_executable(xztrd xpjlaenv.f pztrddriver.f pzttrdtester.f pzlatran.f pztrdinfo.f pzhetdrv.f pzlafchk.f ${TTRD_SRC}/pzhettrd.f ${zmatgen} SL_Context_module_eig.f ) else() -add_executable(xstrd pstrddriver.f psttrdtester.f pslatran.f pstrdinfo.f pssytdrv.f pslafchk.f xpjlaenv.f ${smatgen}) -add_executable(xdtrd pdtrddriver.f pdttrdtester.f pdlatran.f pdtrdinfo.f pdsytdrv.f pdlafchk.f xpjlaenv.f ${dmatgen}) -add_executable(xctrd pctrddriver.f pcttrdtester.f pclatran.f pctrdinfo.f pchetdrv.f pclafchk.f xpjlaenv.f ${cmatgen}) -add_executable(xztrd pztrddriver.f pzttrdtester.f pzlatran.f pztrdinfo.f pzhetdrv.f pzlafchk.f xpjlaenv.f ${zmatgen}) + add_executable(xstrd pstrddriver.f psttrdtester.f pslatran.f pstrdinfo.f pssytdrv.f pslafchk.f xpjlaenv.f ${smatgen}) + add_executable(xdtrd pdtrddriver.f pdttrdtester.f pdlatran.f pdtrdinfo.f pdsytdrv.f pdlafchk.f xpjlaenv.f ${dmatgen}) + add_executable(xctrd pctrddriver.f pcttrdtester.f pclatran.f pctrdinfo.f pchetdrv.f pclafchk.f xpjlaenv.f ${cmatgen}) + add_executable(xztrd pztrddriver.f pzttrdtester.f pzlatran.f pztrdinfo.f pzhetdrv.f pzlafchk.f xpjlaenv.f ${zmatgen}) endif() add_executable(xssvd pssvddriver.f pslagge.f pssvdchk.f pssvdcmp.f pssvdtst.f ${smatgen}) diff --git a/TESTING/EIG/pcbrddriver.f b/TESTING/EIG/pcbrddriver.f index 5a9c5192..44d61ea4 100644 --- a/TESTING/EIG/pcbrddriver.f +++ b/TESTING/EIG/pcbrddriver.f @@ -5,6 +5,8 @@ PROGRAM PCBRDDRIVER * and University of California, Berkeley. * March 13, 2000 * +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. +* * Purpose * ======= * @@ -58,6 +60,7 @@ PROGRAM PCBRDDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, $ LLD_, MB_, M_, NB_, N_, RSRC_ @@ -119,6 +122,16 @@ PROGRAM PCBRDDRIVER * .. Data statements .. DATA KTESTS, KPASS, KFAIL, KSKIP / 4*0 / * .. +* +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X +* * .. Executable Statements .. * * Get starting information @@ -133,6 +146,36 @@ PROGRAM PCBRDDRIVER $ NTESTS, THRESH, MEM, IAM, NPROCS ) CHECK = ( THRESH.GE.0.0E+0 ) * +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* +* * Print headings * IF( IAM.EQ.0 ) THEN @@ -192,6 +235,7 @@ PROGRAM PCBRDDRIVER * Make sure matrix information is correct * IERR( 1 ) = 0 +#ifdef ENABLE_DRIVER_CHECK IF( M.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'M', M @@ -201,6 +245,7 @@ PROGRAM PCBRDDRIVER $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Make sure no one had error * @@ -262,12 +307,35 @@ PROGRAM PCBRDDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 10 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 .OR. + $ IERR(1) .EQ. -3 .OR. IERR(1) .EQ. -12 )) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid M and N +* -4, -8 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9984 ) 'N' + ELSE IF(M .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 .OR. + $ IERR(1) .EQ. -3 .OR. IERR(1) .EQ. -12 )) THEN + WRITE( NOUT, FMT = 9984 ) 'M' + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF + +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -335,7 +403,7 @@ PROGRAM PCBRDDRIVER * * Need Infinity-norm of A for checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GE.0 .AND. M.GE.0 ) THEN CALL PCFILLPAD( ICTXT, MP, NQ, MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, $ PADVAL ) @@ -376,7 +444,7 @@ PROGRAM PCBRDDRIVER * CALL SLTIMER( 1 ) * - IF( CHECK ) THEN + IF( CHECK .AND. INFO .EQ. 0 .AND. .NOT.(EX_FLAG) ) THEN * * Check for memory overwrite * @@ -430,8 +498,17 @@ PROGRAM PCBRDDRIVER * * Test residual and detect NaN result * - IF( FRESID.LE.THRESH .AND. FRESID-FRESID.EQ.0.0E+0 - $ .AND. IERR( 1 ).EQ.0 ) THEN + IF((M .EQ. 0 .OR. N .EQ. 0) .AND. INFO .EQ. 0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) 'PCGEBRD' + PASSED = 'PASSED' + FRESID = 0 + ELSE IF( FRESID.LE.THRESH .AND. + $ FRESID-FRESID.EQ.0.0E+0 .AND. + $ IERR( 1 ).EQ.0 ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' ELSE @@ -449,9 +526,64 @@ PROGRAM PCBRDDRIVER * * Don't perform the checking, only the timing operation * - KPASS = KPASS + 1 FRESID = FRESID - FRESID - PASSED = 'BYPASS' +* Early return case + IF((M .EQ. 0 .OR. N .EQ. 0) .AND. INFO .EQ. 0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) 'PCGEBRD' + PASSED = 'PASSED' +* Invalid M/N + ELSE IF( ( M .LT. 0 .AND. INFO .EQ. -1 ) .OR. + $ ( N .LT. 0 .AND. INFO .EQ. -2 ) ) THEN +* +* When N < 0/Invalid, INFO = -2 +* When M < 0/Invalid, INFO = -1 +* Expected Error code for N < 0 +* Hence this case can be passed + WRITE( NOUT, FMT = 9983 ) 'PCGEBRD' + KPASS = KPASS + 1 + PASSED = 'PASSED' +* +* Extreme-value inputs + ELSE IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, M + DO JK = 1, N + X = MEM(IK*N + JK) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite(X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF +* + ELSE +* + KPASS = KPASS + 1 + PASSED = 'BYPASS' +* + END IF * END IF * @@ -544,6 +676,13 @@ PROGRAM PCBRDDRIVER 9988 FORMAT( I5, ' tests skipped because of illegal input values.' ) 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - Q*B*P|| / (||A|| * N * eps) = ', G25.7 ) + 9985 FORMAT( '----------Test Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9983 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') * STOP * diff --git a/TESTING/EIG/pcevcdriver.f b/TESTING/EIG/pcevcdriver.f index ee77bf13..c82d229c 100644 --- a/TESTING/EIG/pcevcdriver.f +++ b/TESTING/EIG/pcevcdriver.f @@ -4,6 +4,7 @@ PROGRAM PCEVCDRIVER * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * June, 2000 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======= @@ -200,11 +201,13 @@ PROGRAM PCEVCDRIVER * Make sure matrix information is correct * IERR( 1 ) = 0 +#ifdef ENABLE_DRIVER_CHECK IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 )'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * @@ -275,12 +278,31 @@ PROGRAM PCEVCDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 2, 1, IERR, 2, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 .OR. IERR( 2 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 )'descriptor' KSKIP = KSKIP + 1 GO TO 20 END IF +#else +* If N < 0 in EVC.dat file then DESCINIT API sets IERR( 1 ) = -3 + IF( N.LT.0 .AND. (IERR( 1 ).EQ.-2 .OR. + $ IERR( 1 ).EQ. -8 .OR. + $ IERR( 1 ).EQ. -4 .OR. + $ IERR( 2 ).EQ.-2 .OR. + $ IERR( 2 ).EQ. -8 .OR. + $ IERR( 2 ).EQ. -4) ) THEN +* If DESCINIT is returning correct error code we need to pass +* and it will be ScaLAPACK API + WRITE ( NOUT, FMT = 9984 ) 'PCTREVC' + ELSE IF( IERR( 1 ).LT.0 .OR. IERR( 2 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 20 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAE+1 ) @@ -358,7 +380,7 @@ PROGRAM PCEVCDRIVER * * Calculate inf-norm of A for residual error-checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GE.0 ) THEN CALL PCFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, $ PADVAL ) @@ -402,8 +424,13 @@ PROGRAM PCEVCDRIVER MEM( IPWR-1+JJJ ) = ZERO END IF 10 CONTINUE +* +* In case of N<0, surpassing the call off ZGSUM2D +* + IF(N.GT.0) THEN CALL CGSUM2D( ICTXT, 'All', ' ', N, 1, MEM( IPWR ), N, $ -1, -1 ) + END IF * SELECT( 1 ) = .TRUE. CALL SLBOOT() @@ -421,11 +448,23 @@ PROGRAM PCEVCDRIVER IF( INFO.NE.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = * )'PCTREVC INFO=', INFO - KFAIL = KFAIL + 1 - GO TO 20 +* If N < 0 in EVC.dat file then PCTREVC API sets +* INFO = -4 + IF (N.LT.0 .AND. INFO.EQ.-4) THEN +* If PCTREVC is returning correct error +* code we need to pass this case + WRITE( NOUT, FMT = 9983 ) 'PCTREVC' + ELSE IF ( N.GT.1 .AND. INFO.NE.0 ) THEN + KFAIL = KFAIL + 1 + GO TO 20 + END IF + ELSE IF (N.EQ.0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. + WRITE( NOUT, FMT = 9982 ) 'PCTREVC' END IF * - IF( CHECK ) THEN + IF( CHECK .AND. INFO.EQ.0 ) THEN * * Check for memory overwrite in NEP factorization * @@ -488,6 +527,10 @@ PROGRAM PCEVCDRIVER $ ( ( QRESID-QRESID ).EQ.0.0E+0 ) ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' + ELSE IF( N.EQ.0 ) THEN +* Passing residual checks for the case N = 0 + KPASS = KPASS + 1 + PASSED = 'PASSED' ELSE KFAIL = KFAIL + 1 PASSED = 'FAILED' @@ -504,7 +547,11 @@ PROGRAM PCEVCDRIVER KPASS = KPASS + 1 FRESID = FRESID - FRESID QRESID = QRESID - QRESID - PASSED = 'BYPASS' + IF (N.LT.0 .AND. INFO.EQ.-4) THEN + PASSED = 'PASSED' + ELSE + PASSED = 'BYPASS' + END IF * END IF * @@ -600,6 +647,11 @@ PROGRAM PCEVCDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||H*Z - Z*D|| / (||T|| * N * eps) = ', G25.7 ) 9985 FORMAT( 'max_j(max|Z(j)| - 1) / ( N * eps ) ', G25.7 ) + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, we will handle this case from ', + $ 'ScaLAPACK API.') + 9983 FORMAT( A, ' returned correct error code. Passing this case.') + 9982 FORMAT( 'This is safe exit from ', A, ' API. Passing this case.') * STOP * diff --git a/TESTING/EIG/pchrddriver.f b/TESTING/EIG/pchrddriver.f index 66818e3b..c07ac199 100644 --- a/TESTING/EIG/pchrddriver.f +++ b/TESTING/EIG/pchrddriver.f @@ -5,6 +5,8 @@ PROGRAM PCHRDDRIVER * and University of California, Berkeley. * March 13, 2000 * +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. +* * Purpose * ======= * @@ -58,6 +60,7 @@ PROGRAM PCHRDDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, $ LLD_, MB_, M_, NB_, N_, RSRC_ @@ -119,6 +122,16 @@ PROGRAM PCHRDDRIVER * .. Data statements .. DATA KTESTS, KPASS, KFAIL, KSKIP / 4*0 / * .. +* +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X +* * .. Executable Statements .. * * Get starting information @@ -133,6 +146,36 @@ PROGRAM PCHRDDRIVER $ NTESTS, THRESH, MEM, IAM, NPROCS ) CHECK = ( THRESH.GE.0.0E+0 ) * +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* +* * Print headings * IF( IAM.EQ.0 ) THEN @@ -193,11 +236,13 @@ PROGRAM PCHRDDRIVER * Make sure matrix information is correct * IERR( 1 ) = 0 +#ifdef ENABLE_DRIVER_CHECK IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * @@ -254,12 +299,31 @@ PROGRAM PCHRDDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 10 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 .OR. + $ IERR(1) .EQ. -3 .OR. IERR(1) .EQ. -12 )) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid N +* -4, -8 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9984 ) 'N' + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF + +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -327,7 +391,7 @@ PROGRAM PCHRDDRIVER * * Need Infinity-norm of A for checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GE.0 ) THEN CALL PCFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, $ PADVAL ) @@ -360,7 +424,7 @@ PROGRAM PCHRDDRIVER $ MEM( IPT ), MEM( IPW ), LWORK, INFO ) CALL SLTIMER( 1 ) * - IF( CHECK ) THEN + IF( CHECK .AND. INFO .EQ. 0 .AND. .NOT.(EX_FLAG) ) THEN * * Check for memory overwrite * @@ -401,8 +465,18 @@ PROGRAM PCHRDDRIVER * * Test residual and detect NaN result * - IF( FRESID.LE.THRESH .AND. FRESID-FRESID.EQ.0.0E+0 ) - $ THEN + IF((N .EQ. 0) .AND. INFO .EQ. 0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case +* When N = 0, set ILO = 1, IHI = N in dat, to validate early return. + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) 'PCGEHRD' + PASSED = 'PASSED' + FRESID = 0 + ELSE IF( FRESID.LE.THRESH .AND. + $ FRESID-FRESID.EQ.0.0E+0 .AND. + $ IERR( 1 ).EQ.0 ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' ELSE @@ -415,9 +489,64 @@ PROGRAM PCHRDDRIVER * * Don't perform the checking, only the timing operation * - KPASS = KPASS + 1 FRESID = FRESID - FRESID - PASSED = 'BYPASS' +* Early return case + IF(( N .EQ. 0) .AND. INFO .EQ. 0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) 'PCGEHRD' + PASSED = 'PASSED' +* Invalid M/N + ELSE IF( N .LT. 0 .AND. INFO .EQ. -1 ) THEN +* +* When N < 0/Invalid, INFO = -2 +* Expected Error code for N < 0 +* Hence this case can be passed + WRITE( NOUT, FMT = 9983 ) 'PCGEHRD' + KPASS = KPASS + 1 + PASSED = 'PASSED' +* +* Extreme-value inputs + ELSE IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, N-1 + DO JK = 1, N + X = MEM(IK*N + JK) +* PRINT *, X + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite(X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF +* + ELSE +* + KPASS = KPASS + 1 + PASSED = 'BYPASS' +* + END IF +* END IF * * Gather max. of all CPU and WALL clock timings @@ -513,6 +642,13 @@ PROGRAM PCHRDDRIVER 9988 FORMAT( I5, ' tests skipped because of illegal input values.' ) 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - Q*H*Q''|| / (||A|| * N * eps) = ', G25.7 ) + 9985 FORMAT( '----------Test Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9983 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') * STOP * diff --git a/TESTING/EIG/pcmatgen.f b/TESTING/EIG/pcmatgen.f index 47c0413d..1d6a7f20 100644 --- a/TESTING/EIG/pcmatgen.f +++ b/TESTING/EIG/pcmatgen.f @@ -6,6 +6,7 @@ SUBROUTINE PCMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * .. Scalar Arguments .. CHARACTER*1 AFORM, DIAG @@ -119,7 +120,7 @@ SUBROUTINE PCMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. - LOGICAL SYMM, HERM, TRAN + LOGICAL SYMM, HERM, TRAN, EXT_FLAG INTEGER I, IC, IK, INFO, IOFFC, IOFFR, IR, J, JK, $ JUMP1, JUMP2, JUMP3, JUMP4, JUMP5, JUMP6, $ JUMP7, MAXMN, MEND, MOFF, MP, MRCOL, MRROW, @@ -142,8 +143,15 @@ SUBROUTINE PCMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * .. External Functions .. LOGICAL LSAME INTEGER ICEIL, NUMROC + INTEGER CNT1, CNT2, CNT, TOT_CNT, DIV_FACTOR, REGION REAL PSRAND EXTERNAL ICEIL, NUMROC, LSAME, PSRAND +* + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .false. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 * .. * .. Executable Statements .. * @@ -154,6 +162,64 @@ SUBROUTINE PCMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, SYMM = LSAME( AFORM, 'S' ) HERM = LSAME( AFORM, 'H' ) TRAN = LSAME( AFORM, 'T' ) + EXT_FLAG = .FALSE. + +* Take command-line arguments if requested +* + +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EXT_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EXT_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do + + IF ( INF_PERCENT + NAN_PERCENT > 100) THEN + print *,"Sum of INF and NaN is", INF_PERCENT+NAN_PERCENT,"%" + help_flag = .true. + END IF + IF ( INF_PERCENT < 0 .OR. NAN_PERCENT < 0) THEN + print *, "Negative INF / NaN value is not allowed" + help_flag = .true. + END IF + +* Display help message if requested + IF (help_flag .AND. IAM.EQ.0) THEN + print *, "" + print *, "Options:" + print *, " -h, --help Display this help message" + print *, " -inf INF percentage in input", + $ " matrix (default: 0 %)" + print *, " -nan NaN percentage in input", + $ " matrix (default: 0 %)" + print *, "" + print *, " Note: INF + NaN values in input matrix", + $ " should be in the range of 0-100 %" + print *, "" + stop + END IF * INFO = 0 IF( .NOT.LSAME( DIAG, 'D' ) .AND. @@ -213,9 +279,46 @@ SUBROUTINE PCMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, JSEED(1) = ISEED JSEED(2) = 0 * +* Extreme-value parameter caclculations + IF( LSAME( DIAG, 'D' ) ) THEN + DIV_FACTOR = 2 + ELSE + DIV_FACTOR = 4 + END IF +* Find type of matrix to identify where to fill INF/NAN, +* If UPPER_TRIANGULAR_MATRIX., start above DIAG + IF( LSAME(AFORM, 'U' ) ) THEN + REGION = (IRNUM * ICNUM)/DIV_FACTOR +* If LOWER_TRIANGULAR/GENERAL MATRIX, start at beginning + ELSE + REGION = 1 + END IF + IF (EXT_FLAG) THEN + ZERO1 = 0.0E0 + ONE1 = 1.0E0 +* Calculate the number of NANs/INFs per grid + CNT1 = (IRNUM * ICNUM * NAN_PERCENT)/100 + CNT2 = (IRNUM * ICNUM * INF_PERCENT)/100 + CNT1 = CEILING(REAL(CNT1)) + CNT2 = CEILING(REAL(CNT2)) +* When Percentage requested by the user is low +* Replace atleast one element with NAN/INF +* Applicable for smaller matrices [2x2] + IF(NAN_PERCENT .GT. 0 .AND. CNT1 .EQ. 0 ) THEN + CNT1 = CNT1 + 1 + PRINT *, 'NAN Percentage is too low,', + $ 'Including one NAN element' + END IF + IF(INF_PERCENT .GT. 0 .AND. CNT2 .EQ. 0 ) THEN + CNT2 = CNT2 + 1 + PRINT *, 'INF Percentage is too low,', + $ 'Including one INF element' + END IF + END IF +* * Symmetric or Hermitian matrix will be generated. * - IF( SYMM.OR.HERM ) THEN + IF( (SYMM.OR.HERM) .AND. .NOT.(EXT_FLAG) ) THEN * * First, generate the lower triangular part (with diagonal block) * @@ -397,7 +500,8 @@ SUBROUTINE PCMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * * (Conjugate) Transposed matrix A will be generated. * - ELSE IF( TRAN .OR. LSAME( AFORM, 'C' ) ) THEN + ELSE IF(( TRAN .OR. LSAME( AFORM, 'C' )) .AND. + $ .NOT.(EXT_FLAG) ) THEN * JUMP1 = 1 JUMP2 = 2*NQNB @@ -470,6 +574,9 @@ SUBROUTINE PCMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * A random matrix is generated. * ELSE + + TOT_CNT = 0 + CNT = 0 * JUMP1 = 1 JUMP2 = 2*NPMB @@ -506,8 +613,21 @@ SUBROUTINE PCMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, IOFFR = ((IR-1)*NPROW+MRROW) * MB DO 250 J = 1, MB IF( IK .GT. IRNUM ) GO TO 270 - A(IK,JK) = CMPLX( ONE - TWO*PSRAND(0), +* Replace with NANs/INFs for extreme values + IF(EXT_FLAG .AND. CNT .LE. (CNT1 + CNT2) .AND. + $ TOT_CNT .GE. REGION) THEN + IF ( CNT .LT. CNT1) THEN + A(IK, JK) = CMPLX(ZERO1/ZERO1,ZERO1/ZERO1) + ELSE IF ( CNT .LT. (CNT1 + CNT2)) THEN + A(IK, JK) = CMPLX(ONE1/ZERO1, ONE1/ZERO1) + END IF + CNT = CNT + 1 + TOT_CNT = TOT_CNT + 1 + ELSE + A(IK,JK) = CMPLX( ONE - TWO*PSRAND(0), $ ONE - TWO*PSRAND(0) ) + TOT_CNT = TOT_CNT + 1 + END IF IK = IK + 1 250 CONTINUE CALL JUMPIT( IA2, IC2, IB1, IRAN2 ) @@ -544,6 +664,9 @@ SUBROUTINE PCMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, RETURN END IF * + + CNT = 0 + TOT_CNT = 0 MAXMN = MAX(M, N) JK = 1 DO 340 IC = NOFF+1, NEND @@ -554,12 +677,23 @@ SUBROUTINE PCMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, IF( IOFFC.EQ.IOFFR ) THEN DO 310 J = 0, MB-1 IF( IK .GT. IRNUM ) GO TO 330 - IF( HERM ) THEN + IF(EXT_FLAG .AND. CNT .LE. (CNT1 + CNT2) + $ .AND. TOT_CNT .GT. (N/2) ) THEN + IF ( CNT .LT. CNT1) THEN + A(IK, JK+J) = CMPLX(ZERO1/ZERO1,ZERO1/ZERO1) + ELSE IF ( CNT .LT. (CNT1 + CNT2)) THEN + A(IK, JK+J) = CMPLX(ONE1/ZERO1, ONE1/ZERO1) + END IF + CNT = CNT + 1 + TOT_CNT = TOT_CNT + 1 + ELSE IF( HERM ) THEN A(IK,JK+J) = CMPLX( $ ABS(REAL(A(IK,JK+J)))+2*MAXMN, ZERO ) + TOT_CNT = TOT_CNT + 1 ELSE A(IK,JK+J) = CMPLX( ABS(REAL(A(IK,JK+J)))+MAXMN, $ ABS(AIMAG(A(IK,JK+J)))+ MAXMN ) + TOT_CNT = TOT_CNT + 1 END IF IK = IK + 1 310 CONTINUE diff --git a/TESTING/EIG/pcnepdriver.f b/TESTING/EIG/pcnepdriver.f index 627f4ea6..17520fc9 100644 --- a/TESTING/EIG/pcnepdriver.f +++ b/TESTING/EIG/pcnepdriver.f @@ -4,6 +4,7 @@ PROGRAM PCNEPDRIVER * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * March, 2000 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======= @@ -195,11 +196,13 @@ PROGRAM PCNEPDRIVER * Make sure matrix information is correct * IERR( 1 ) = 0 +#ifdef ENABLE_DRIVER_CHECK IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 )'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * @@ -271,12 +274,32 @@ PROGRAM PCNEPDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 2, 1, IERR, 2, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 .OR. IERR( 2 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 )'descriptor' KSKIP = KSKIP + 1 GO TO 10 END IF +#else +* If N < 0 in NEP.dat file then DESCINIT API sets +* IERR( 1 ) to -2 or -8 or -4. +* If DESCINIT is returning correct error code then +* do nothing + IF( N.LT.0 .AND. (IERR( 1 ).EQ.-2 .OR. + $ IERR( 1 ).EQ. -8 .OR. + $ IERR( 1 ).EQ. -4 .OR. + $ IERR( 2 ).EQ.-2 .OR. + $ IERR( 2 ).EQ. -8 .OR. + $ IERR( 2 ).EQ. -4) ) THEN + WRITE ( NOUT, FMT = 9984 ) 'PCLAHQR' + ELSE IF( IERR( 1 ).LT.0 .OR. IERR( 2 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAE+1 ) @@ -389,11 +412,23 @@ PROGRAM PCNEPDRIVER IF( INFO.NE.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = * )'PCLAHQR INFO=', INFO - KFAIL = KFAIL + 1 - GO TO 10 +* If N < 0 in NEP.dat file then PCLAHQR API +* sets INFO = -5 + IF (N.LT.0 .AND. INFO.EQ.-5) THEN +* If PCLAHQR is returning correct error +* code we need to pass this case + WRITE( NOUT, FMT = 9983 ) 'PCLAHQR' + ELSE IF ( N.GT.1 .AND. INFO.NE.0 ) THEN + KFAIL = KFAIL + 1 + GO TO 10 + END IF + ELSE IF (N.EQ.0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. + WRITE( NOUT, FMT = 9982 ) 'PCLAHQR' END IF * - IF( CHECK ) THEN + IF( CHECK .AND. INFO.EQ.0 ) THEN * * Check for memory overwrite in NEP factorization * @@ -451,6 +486,10 @@ PROGRAM PCNEPDRIVER $ ( ( QRESID-QRESID ).EQ.0.0E+0 ) ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' + ELSE IF( N.EQ.0 ) THEN +* Passing residual checks for the case N = 0 + KPASS = KPASS + 1 + PASSED = 'PASSED' ELSE KFAIL = KFAIL + 1 PASSED = 'FAILED' @@ -467,7 +506,13 @@ PROGRAM PCNEPDRIVER KPASS = KPASS + 1 FRESID = FRESID - FRESID QRESID = QRESID - QRESID - PASSED = 'BYPASS' +* If the ScaLAPACK API is returning the correct +* INFO code for N < 0 then pass the case. + IF (N.LT.0 .AND. INFO.EQ.-5) THEN + PASSED = 'PASSED' + ELSE + PASSED = 'BYPASS' + END IF * END IF * @@ -563,6 +608,11 @@ PROGRAM PCNEPDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||H - Q*S*Q^T|| / (||H|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Q^T*Q - I|| / ( N * eps ) ', G25.7 ) + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, we will handle this case from ', + $ 'ScaLAPACK API.') + 9983 FORMAT( A, ' returned correct error code. Passing this case.') + 9982 FORMAT( 'This is safe exit from ', A, ' API. Passing this case.') * STOP * diff --git a/TESTING/EIG/pcseprreq.f b/TESTING/EIG/pcseprreq.f index edbfbc88..f3791552 100644 --- a/TESTING/EIG/pcseprreq.f +++ b/TESTING/EIG/pcseprreq.f @@ -5,6 +5,8 @@ SUBROUTINE PCSEPRREQ( HETERO, NIN, MEM, MEMSIZE, NOUT, ISEED, * University of California, Berkeley and * University of Tennessee, Knoxville. * October 21, 2006 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. +* All rights reserved. * IMPLICIT NONE * @@ -161,8 +163,17 @@ SUBROUTINE PCSEPRREQ( HETERO, NIN, MEM, MEMSIZE, NOUT, ISEED, $ MYCOL ) * IF( MYROW.GE.0 ) THEN +* If N < 0 in SEPR.dat file then DESCINIT API sets INFO = -2 CALL DESCINIT( DESCA, N, N, NB, NB, 0, 0, $ CONTEXT, LDA, INFO ) +* If DESCINIT is returning correct error code then +* do nothing + IF( N.LT.0 .AND. INFO.EQ.-2 ) THEN + WRITE( NOUT, FMT = 9999 ) 'N' + ELSE IF( INFO.LT.0 ) THEN + WRITE( NOUT, FMT = 9998 ) 'descriptor' + GO TO 40 + END IF CALL PCLASIZESEPR( DESCA, IPREPAD, IPOSTPAD, $ SIZEMQRLEFT, SIZEMQRRIGHT, $ SIZEQRF, SIZETMS, SIZEQTQ, @@ -226,6 +237,10 @@ SUBROUTINE PCSEPRREQ( HETERO, NIN, MEM, MEMSIZE, NOUT, ISEED, END IF * RETURN + 9999 FORMAT( A, ' < 0 case detected (Negative Test). ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9998 FORMAT( 'Bad ', A10, ' parameters: going on to next test case.' ) * * End of PCSEPRREQ * diff --git a/TESTING/EIG/pcseprsubtst.f b/TESTING/EIG/pcseprsubtst.f index d54ec171..58db7c79 100644 --- a/TESTING/EIG/pcseprsubtst.f +++ b/TESTING/EIG/pcseprsubtst.f @@ -9,6 +9,8 @@ SUBROUTINE PCSEPRSUBTST( WKNOWN, JOBZ, RANGE, UPLO, N, VL, VU, IL, * University of California, Berkeley and * University of Tennessee, Knoxville. * October 21, 2006 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. +* All rights reserved. * IMPLICIT NONE * @@ -409,6 +411,19 @@ SUBROUTINE PCSEPRSUBTST( WKNOWN, JOBZ, RANGE, UPLO, N, VL, VU, IL, * CALL SLTIMER( 6 ) CALL SLTIMER( 1 ) +* + IF ( N.LT.0 .AND. INFO.EQ.-4) THEN + WRITE( NOUT, FMT = * ) 'PCHEEVR INFO=', INFO +* When N < 0/Invalid, PCHEEVR INFO = -4 +* Expected Error code for N < 0 +* Hence this case can be passed. + WRITE( NOUT, FMT = 9980) 'PCHEEVR' + GO TO 150 + ELSE IF ( INFO.LT.0 ) THEN + WRITE( NOUT, FMT = * ) 'PCHEEVR INFO=', INFO + RESULT = 1 + GO TO 150 + END IF * * Indicate that there are no unresolved clusters. * This is necessary so that the tester @@ -821,6 +836,7 @@ SUBROUTINE PCSEPRSUBTST( WKNOWN, JOBZ, RANGE, UPLO, N, VL, VU, IL, 9983 FORMAT( 'ICLUSTR not zero terminated' ) 9982 FORMAT( 'IL, IU, VL or VU altered by PCHEEVR' ) 9981 FORMAT( 'NZ altered by PCHEEVR with JOBZ=N' ) + 9980 FORMAT( A, ' returned correct error code. Passing this case.') * * End of PCSEPRSUBTST * diff --git a/TESTING/EIG/pdbrddriver.f b/TESTING/EIG/pdbrddriver.f index 2af8ab0b..a6668996 100644 --- a/TESTING/EIG/pdbrddriver.f +++ b/TESTING/EIG/pdbrddriver.f @@ -5,6 +5,8 @@ PROGRAM PDBRDDRIVER * and University of California, Berkeley. * March 13, 2000 * +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. +* * Purpose * ======= * @@ -57,6 +59,7 @@ PROGRAM PDBRDDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, $ LLD_, MB_, M_, NB_, N_, RSRC_ @@ -118,6 +121,16 @@ PROGRAM PDBRDDRIVER * .. Data statements .. DATA KTESTS, KPASS, KFAIL, KSKIP / 4*0 / * .. +* +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X +* * .. Executable Statements .. * * Get starting information @@ -132,6 +145,36 @@ PROGRAM PDBRDDRIVER $ NTESTS, THRESH, MEM, IAM, NPROCS ) CHECK = ( THRESH.GE.0.0E+0 ) * +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* +* * Print headings * IF( IAM.EQ.0 ) THEN @@ -191,6 +234,7 @@ PROGRAM PDBRDDRIVER * Make sure matrix information is correct * IERR( 1 ) = 0 +#ifdef ENABLE_DRIVER_CHECK IF( M.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'M', M @@ -200,6 +244,7 @@ PROGRAM PDBRDDRIVER $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Make sure no one had error * @@ -261,12 +306,35 @@ PROGRAM PDBRDDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 10 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 .OR. + $ IERR(1) .EQ. -3 .OR. IERR(1) .EQ. -12 )) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid M and N +* -4, -8 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9984 ) 'N' + ELSE IF(M .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 .OR. + $ IERR(1) .EQ. -3 .OR. IERR(1) .EQ. -12 )) THEN + WRITE( NOUT, FMT = 9984 ) 'M' + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF + +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -330,7 +398,7 @@ PROGRAM PDBRDDRIVER * * Need Infinity-norm of A for checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GE.0 .AND. M.GE.0 ) THEN CALL PDFILLPAD( ICTXT, MP, NQ, MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, $ PADVAL ) @@ -371,7 +439,7 @@ PROGRAM PDBRDDRIVER * CALL SLTIMER( 1 ) * - IF( CHECK ) THEN + IF( CHECK .AND. INFO .EQ. 0 .AND. .NOT.(EX_FLAG) ) THEN * * Check for memory overwrite * @@ -425,8 +493,17 @@ PROGRAM PDBRDDRIVER * * Test residual and detect NaN result * - IF( FRESID.LE.THRESH .AND. FRESID-FRESID.EQ.0.0D+0 - $ .AND. IERR( 1 ).EQ.0 ) THEN + IF((M .EQ. 0 .OR. N .EQ. 0) .AND. INFO .EQ. 0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) 'PDGEBRD' + PASSED = 'PASSED' + FRESID = 0 + ELSE IF( FRESID.LE.THRESH .AND. + $ FRESID-FRESID.EQ.0.0D+0 .AND. + $ IERR( 1 ).EQ.0 ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' ELSE @@ -437,16 +514,71 @@ PROGRAM PDBRDDRIVER PASSED = 'FAILED' END IF * - IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 .AND. IERR( 1 ).NE.0 ) + IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 .AND. IERR( 1 ).NE.0) $ WRITE( NOUT, FMT = * ) $ 'D or E copies incorrect ...' ELSE * * Don't perform the checking, only the timing operation * - KPASS = KPASS + 1 FRESID = FRESID - FRESID - PASSED = 'BYPASS' +* Early return case + IF((M .EQ. 0 .OR. N .EQ. 0) .AND. INFO .EQ. 0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) 'PDGEBRD' + PASSED = 'PASSED' +* Invalid M/N + ELSE IF( ( M .LT. 0 .AND. INFO .EQ. -1 ) .OR. + $ ( N .LT. 0 .AND. INFO .EQ. -2 ) ) THEN +* +* When N < 0/Invalid, INFO = -2 +* When M < 0/Invalid, INFO = -1 +* Expected Error code for N < 0 +* Hence this case can be passed + WRITE( NOUT, FMT = 9983 ) 'PDGEBRD' + KPASS = KPASS + 1 + PASSED = 'PASSED' +* +* Extreme-value inputs + ELSE IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, M + DO JK = 1, N + X = MEM(IK*N + JK) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite(X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF +* + ELSE +* + KPASS = KPASS + 1 + PASSED = 'BYPASS' +* + END IF * END IF * @@ -539,6 +671,13 @@ PROGRAM PDBRDDRIVER 9988 FORMAT( I5, ' tests skipped because of illegal input values.' ) 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - Q*B*P|| / (||A|| * N * eps) = ', G25.7 ) + 9985 FORMAT( '----------Test Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9983 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') * STOP * diff --git a/TESTING/EIG/pdhrddriver.f b/TESTING/EIG/pdhrddriver.f index 1301a047..1a626c9d 100644 --- a/TESTING/EIG/pdhrddriver.f +++ b/TESTING/EIG/pdhrddriver.f @@ -5,6 +5,8 @@ PROGRAM PDHRDDRIVER * and University of California, Berkeley. * March 13, 2000 * +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. +* * Purpose * ======= * @@ -57,6 +59,7 @@ PROGRAM PDHRDDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, $ LLD_, MB_, M_, NB_, N_, RSRC_ @@ -118,6 +121,16 @@ PROGRAM PDHRDDRIVER * .. Data statements .. DATA KTESTS, KPASS, KFAIL, KSKIP / 4*0 / * .. +* +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X +* * .. Executable Statements .. * * Get starting information @@ -132,6 +145,36 @@ PROGRAM PDHRDDRIVER $ NTESTS, THRESH, MEM, IAM, NPROCS ) CHECK = ( THRESH.GE.0.0E+0 ) * +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* +* * Print headings * IF( IAM.EQ.0 ) THEN @@ -192,11 +235,13 @@ PROGRAM PDHRDDRIVER * Make sure matrix information is correct * IERR( 1 ) = 0 +#ifdef ENABLE_DRIVER_CHECK IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * @@ -253,12 +298,31 @@ PROGRAM PDHRDDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 10 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 .OR. + $ IERR(1) .EQ. -3 .OR. IERR(1) .EQ. -12 )) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid N +* -4, -8 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9984 ) 'N' + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF + +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -326,7 +390,7 @@ PROGRAM PDHRDDRIVER * * Need Infinity-norm of A for checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GE.0 ) THEN CALL PDFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, $ PADVAL ) @@ -359,7 +423,7 @@ PROGRAM PDHRDDRIVER $ MEM( IPT ), MEM( IPW ), LWORK, INFO ) CALL SLTIMER( 1 ) * - IF( CHECK ) THEN + IF( CHECK .AND. INFO .EQ. 0 .AND. .NOT.(EX_FLAG) ) THEN * * Check for memory overwrite * @@ -400,8 +464,18 @@ PROGRAM PDHRDDRIVER * * Test residual and detect NaN result * - IF( FRESID.LE.THRESH .AND. FRESID-FRESID.EQ.0.0D+0 ) - $ THEN + IF((N .EQ. 0) .AND. INFO .EQ. 0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case +* When N = 0, set ILO = 1, IHI = N in dat, to validate early return. + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) 'PDGEHRD' + PASSED = 'PASSED' + FRESID = 0 + ELSE IF( FRESID.LE.THRESH .AND. + $ FRESID-FRESID.EQ.0.0D+0 .AND. + $ IERR( 1 ).EQ.0 ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' ELSE @@ -414,9 +488,64 @@ PROGRAM PDHRDDRIVER * * Don't perform the checking, only the timing operation * - KPASS = KPASS + 1 FRESID = FRESID - FRESID - PASSED = 'BYPASS' +* Early return case + IF(( N .EQ. 0) .AND. INFO .EQ. 0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) 'PDGEHRD' + PASSED = 'PASSED' +* Invalid M/N + ELSE IF( N .LT. 0 .AND. INFO .EQ. -1 ) THEN +* +* When N < 0/Invalid, INFO = -2 +* Expected Error code for N < 0 +* Hence this case can be passed + WRITE( NOUT, FMT = 9983 ) 'PDGEHRD' + KPASS = KPASS + 1 + PASSED = 'PASSED' +* +* Extreme-value inputs + ELSE IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, N-1 + DO JK = 1, N + X = MEM(IK*N + JK) +* PRINT *, X + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite(X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF +* + ELSE +* + KPASS = KPASS + 1 + PASSED = 'BYPASS' +* + END IF +* END IF * * Gather max. of all CPU and WALL clock timings @@ -512,6 +641,13 @@ PROGRAM PDHRDDRIVER 9988 FORMAT( I5, ' tests skipped because of illegal input values.' ) 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - Q*H*Q''|| / (||A|| * N * eps) = ', G25.7 ) + 9985 FORMAT( '----------Test Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9983 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') * STOP * diff --git a/TESTING/EIG/pdmatgen.f b/TESTING/EIG/pdmatgen.f index fab962c1..0123f718 100644 --- a/TESTING/EIG/pdmatgen.f +++ b/TESTING/EIG/pdmatgen.f @@ -6,6 +6,7 @@ SUBROUTINE PDMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * .. Scalar Arguments .. CHARACTER*1 AFORM, DIAG @@ -119,7 +120,7 @@ SUBROUTINE PDMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 ) * .. * .. Local Scalars .. - LOGICAL SYMM, HERM, TRAN + LOGICAL SYMM, HERM, TRAN, EXT_FLAG INTEGER I, IC, IK, INFO, IOFFC, IOFFR, IR, J, JK, $ JUMP1, JUMP2, JUMP3, JUMP4, JUMP5, JUMP6, $ JUMP7, MAXMN, MEND, MOFF, MP, MRCOL, MRROW, @@ -141,8 +142,15 @@ SUBROUTINE PDMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * .. External Functions .. LOGICAL LSAME INTEGER ICEIL, NUMROC + INTEGER CNT1, CNT2, CNT,TOT_CNT, DIV_FACTOR, REGION DOUBLE PRECISION PDRAND EXTERNAL ICEIL, NUMROC, LSAME, PDRAND +* + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .false. + INTEGER :: NAN_PERCENT = 0 + INTEGER :: INF_PERCENT = 0 * .. * .. Executable Statements .. * @@ -153,6 +161,64 @@ SUBROUTINE PDMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, SYMM = LSAME( AFORM, 'S' ) HERM = LSAME( AFORM, 'H' ) TRAN = LSAME( AFORM, 'T' ) + EXT_FLAG = .FALSE. + +* Take command-line arguments if requested +* + +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EXT_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EXT_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do + + IF ( INF_PERCENT + NAN_PERCENT > 100) THEN + print *,"Sum of INF and NaN is", INF_PERCENT+NAN_PERCENT,"%" + help_flag = .true. + END IF + IF ( INF_PERCENT < 0 .OR. NAN_PERCENT < 0) THEN + print *, "Negative INF / NaN value is not allowed" + help_flag = .true. + END IF + +* Display help message if requested + IF (help_flag .AND. IAM.EQ.0) THEN + print *, "" + print *, "Options:" + print *, " -h, --help Display this help message" + print *, " -inf INF percentage in input", + $ " matrix (default: 0 %)" + print *, " -nan NaN percentage in input", + $ " matrix (default: 0 %)" + print *, "" + print *, " Note: INF + NaN values in input matrix", + $ " should be in the range of 0-100 %" + print *, "" + stop + END IF * INFO = 0 IF( .NOT.LSAME( DIAG, 'D' ) .AND. @@ -212,9 +278,46 @@ SUBROUTINE PDMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, JSEED(1) = ISEED JSEED(2) = 0 * +* Extreme-value parameter caclculations + IF( LSAME( DIAG, 'D' ) ) THEN + DIV_FACTOR = 2 + ELSE + DIV_FACTOR = 4 + END IF +* Find type of matrix to identify where to fill INF/NAN, +* If UPPER_TRIANGULAR_MATRIX., start above DIAG + IF( LSAME(AFORM, 'U' ) ) THEN + REGION = (IRNUM * ICNUM)/DIV_FACTOR +* If LOWER_TRIANGULAR/GENERAL MATRIX, start at beginning + ELSE + REGION = 1 + END IF + IF (EXT_FLAG) THEN + ZERO1 = 0.0E0 + ONE1 = 1.0E0 +* Calculate the number of NANs/INFs per grid + CNT1 = (IRNUM * ICNUM * NAN_PERCENT)/100 + CNT2 = (IRNUM * ICNUM * INF_PERCENT)/100 + CNT1 = CEILING(REAL(CNT1)) + CNT2 = CEILING(REAL(CNT2)) +* When Percentage requested by the user is low +* Replace atleast one element with NAN/INF +* Applicable for smaller matrices [2x2] + IF(NAN_PERCENT .GT. 0 .AND. CNT1 .EQ. 0 ) THEN + CNT1 = CNT1 + 1 + PRINT *, 'NAN Percentage is too low,', + $ 'Including one NAN element' + END IF + IF(INF_PERCENT .GT. 0 .AND. CNT2 .EQ. 0 ) THEN + CNT2 = CNT2 + 1 + PRINT *, 'INF Percentage is too low,', + $ 'Including one INF element' + END IF + END IF +* * Symmetric or Hermitian matrix will be generated. * - IF( SYMM.OR.HERM ) THEN + IF( (SYMM.OR.HERM) .AND. .NOT.(EXT_FLAG) ) THEN * * First, generate the lower triangular part (with diagonal block) * @@ -378,7 +481,8 @@ SUBROUTINE PDMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * * (Conjugate) Transposed matrix A will be generated. * - ELSE IF( TRAN .OR. LSAME( AFORM, 'C' ) ) THEN + ELSE IF(( TRAN .OR. LSAME( AFORM, 'C' )) .AND. + $ .NOT.(EXT_FLAG) ) THEN * JUMP1 = 1 JUMP2 = NQNB @@ -445,6 +549,9 @@ SUBROUTINE PDMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * A random matrix is generated. * ELSE + + TOT_CNT = 0 + CNT = 0 * JUMP1 = 1 JUMP2 = NPMB @@ -481,7 +588,20 @@ SUBROUTINE PDMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, IOFFR = ((IR-1)*NPROW+MRROW) * MB DO 250 J = 1, MB IF( IK .GT. IRNUM ) GO TO 270 - A(IK,JK) = ONE - TWO*PDRAND(0) +* Replace with NANs/INFs for extreme values + IF(EXT_FLAG .AND. CNT .LE. (CNT1 + CNT2) .AND. + $ TOT_CNT .GE. REGION) THEN + IF ( CNT .LT. CNT1) THEN + A(IK, JK) = ZERO1/ZERO1 + ELSE IF ( CNT .LT. (CNT1 + CNT2)) THEN + A(IK, JK) = ONE1/ZERO1 + END IF + CNT = CNT + 1 + TOT_CNT = TOT_CNT + 1 + ELSE + A(IK,JK) = ONE - TWO*PDRAND(0) + TOT_CNT = TOT_CNT + 1 + END IF IK = IK + 1 250 CONTINUE CALL JUMPIT( IA2, IC2, IB1, IRAN2 ) @@ -518,6 +638,8 @@ SUBROUTINE PDMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, RETURN END IF * + TOT_CNT = 0 + CNT = 0 MAXMN = MAX(M, N) JK = 1 DO 340 IC = NOFF+1, NEND @@ -528,7 +650,19 @@ SUBROUTINE PDMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, IF( IOFFC.EQ.IOFFR ) THEN DO 310 J = 0, MB-1 IF( IK .GT. IRNUM ) GO TO 330 - A(IK,JK+J) = ABS(A(IK,JK+J)) + MAXMN + IF(EXT_FLAG .AND. CNT .LE. (CNT1 + CNT2) .AND. + $ TOT_CNT .GT. (N/2) ) THEN + IF ( CNT .LT. CNT1) THEN + A(IK, JK+J) = ZERO1/ZERO1 + ELSE IF ( CNT .LT. (CNT1 + CNT2)) THEN + A(IK, JK+J) = ONE1/ZERO1 + END IF + CNT = CNT + 1 + TOT_CNT = TOT_CNT + 1 + ELSE + A(IK,JK+J) = ABS(A(IK,JK+J)) + MAXMN + TOT_CNT = TOT_CNT + 1 + END IF IK = IK + 1 310 CONTINUE ELSE diff --git a/TESTING/EIG/pdnepdriver.f b/TESTING/EIG/pdnepdriver.f index 2c87c73e..8c7e594e 100644 --- a/TESTING/EIG/pdnepdriver.f +++ b/TESTING/EIG/pdnepdriver.f @@ -4,6 +4,7 @@ PROGRAM PDNEPDRIVER * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======= @@ -188,11 +189,13 @@ PROGRAM PDNEPDRIVER * Make sure matrix information is correct * IERR( 1 ) = 0 +#ifdef ENABLE_DRIVER_CHECK IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 )'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * @@ -263,12 +266,32 @@ PROGRAM PDNEPDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 2, 1, IERR, 2, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 .OR. IERR( 2 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 )'descriptor' KSKIP = KSKIP + 1 GO TO 10 END IF +#else +* If N < 0 in NEP.dat file then DESCINIT API sets +* IERR( 1 ) to -2 or -8 or -4. +* If DESCINIT is returning correct error code then +* do nothing. + IF( N.LT.0 .AND. (IERR( 1 ).EQ.-2 .OR. + $ IERR( 1 ).EQ. -8 .OR. + $ IERR( 1 ).EQ. -4 .OR. + $ IERR( 2 ).EQ.-2 .OR. + $ IERR( 2 ).EQ. -8 .OR. + $ IERR( 2 ).EQ. -4) ) THEN + WRITE ( NOUT, FMT = 9984 ) 'PDLAHQR' + ELSE IF( IERR( 1 ).LT.0 .OR. IERR( 2 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -383,11 +406,23 @@ PROGRAM PDNEPDRIVER IF( INFO.NE.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = * )'PDLAHQR INFO=', INFO - KFAIL = KFAIL + 1 - GO TO 10 +* If N < 0 in NEP.dat file then PDLAHQR API sets +* INFO = -5 + IF (N.LT.0 .AND. INFO.EQ.-5) THEN +* If PDLAHQR is returning correct error +* code we need to pass this case + WRITE( NOUT, FMT = 9983 ) 'PDLAHQR' + ELSE IF ( N.GT.1 .AND. INFO.NE.0 ) THEN + KFAIL = KFAIL + 1 + GO TO 10 + END IF + ELSE IF (N.EQ.0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. + WRITE( NOUT, FMT = 9982 ) 'PDLAHQR' END IF * - IF( CHECK ) THEN + IF( CHECK .AND. INFO.EQ.0 ) THEN * * Check for memory overwrite in NEP factorization * @@ -448,6 +483,10 @@ PROGRAM PDNEPDRIVER $ ( ( QRESID-QRESID ).EQ.0.0D+0 ) ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' + ELSE IF( N.EQ.0 ) THEN +* Passing residual checks for the case N = 0 + KPASS = KPASS + 1 + PASSED = 'PASSED' ELSE KFAIL = KFAIL + 1 PASSED = 'FAILED' @@ -464,7 +503,13 @@ PROGRAM PDNEPDRIVER KPASS = KPASS + 1 FRESID = FRESID - FRESID QRESID = QRESID - QRESID - PASSED = 'BYPASS' +* If the ScaLAPACK API is returning the correct +* INFO code for N < 0 then pass the case. + IF (N.LT.0 .AND. INFO.EQ.-5) THEN + PASSED = 'PASSED' + ELSE + PASSED = 'BYPASS' + END IF * END IF * @@ -560,6 +605,11 @@ PROGRAM PDNEPDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||H - Q*S*Q^T|| / (||H|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Q^T*Q - I|| / ( N * eps ) ', G25.7 ) + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, we will handle this case from ', + $ 'ScaLAPACK API.') + 9983 FORMAT( A, ' returned correct error code. Passing this case.') + 9982 FORMAT( 'This is safe exit from ', A, ' API. Passing this case.') * STOP * diff --git a/TESTING/EIG/pdseprreq.f b/TESTING/EIG/pdseprreq.f index 3faf31c2..3ec421e9 100644 --- a/TESTING/EIG/pdseprreq.f +++ b/TESTING/EIG/pdseprreq.f @@ -5,6 +5,8 @@ SUBROUTINE PDSEPRREQ( HETERO, NIN, MEM, MEMSIZE, NOUT, ISEED, * University of California, Berkeley and * University of Tennessee, Knoxville. * October 21, 2006 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. +* All rights reserved. * IMPLICIT NONE * @@ -158,8 +160,17 @@ SUBROUTINE PDSEPRREQ( HETERO, NIN, MEM, MEMSIZE, NOUT, ISEED, $ MYCOL ) * IF( MYROW.GE.0 ) THEN +* If N < 0 in SEPR.dat file then DESCINIT API sets INFO = -2 CALL DESCINIT( DESCA, N, N, NB, NB, 0, 0, $ CONTEXT, LDA, INFO ) +* If DESCINIT is returning correct error code then +* do nothing + IF( N.LT.0 .AND. INFO.EQ.-2 ) THEN + WRITE( NOUT, FMT = 9999 ) 'N' + ELSE IF( INFO.LT.0 ) THEN + WRITE( NOUT, FMT = 9998 ) 'descriptor' + GO TO 40 + END IF CALL PDLASIZESEPR( DESCA, IPREPAD, IPOSTPAD, $ SIZEMQRLEFT, SIZEMQRRIGHT, $ SIZEQRF, SIZETMS, SIZEQTQ, @@ -219,6 +230,10 @@ SUBROUTINE PDSEPRREQ( HETERO, NIN, MEM, MEMSIZE, NOUT, ISEED, END IF * RETURN + 9999 FORMAT( A, ' < 0 case detected (Negative Test). ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9998 FORMAT( 'Bad ', A10, ' parameters: going on to next test case.' ) * * End of PDSEPRREQ * diff --git a/TESTING/EIG/pdseprsubtst.f b/TESTING/EIG/pdseprsubtst.f index 125463f0..8ff71d0e 100644 --- a/TESTING/EIG/pdseprsubtst.f +++ b/TESTING/EIG/pdseprsubtst.f @@ -9,6 +9,8 @@ SUBROUTINE PDSEPRSUBTST( WKNOWN, JOBZ, RANGE, UPLO, N, VL, VU, IL, * University of California, Berkeley and * University of Tennessee, Knoxville. * October 21, 2006 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. +* All rights reserved. * IMPLICIT NONE * @@ -388,6 +390,19 @@ SUBROUTINE PDSEPRSUBTST( WKNOWN, JOBZ, RANGE, UPLO, N, VL, VU, IL, * CALL SLTIMER( 6 ) CALL SLTIMER( 1 ) +* + IF ( N.LT.0 .AND. INFO.EQ.-4) THEN + WRITE( NOUT, FMT = * ) 'PDSYEVR INFO=', INFO +* When N < 0/Invalid, PDSYEVR INFO = -4 +* Expected Error code for N < 0 +* Hence this case can be passed. + WRITE( NOUT, FMT = 9980) 'PDSYEVR' + GO TO 150 + ELSE IF ( INFO.LT.0 ) THEN + WRITE( NOUT, FMT = * ) 'PDSYEVR INFO=', INFO + RESULT = 1 + GO TO 150 + END IF * * Indicate that there are no unresolved clusters. * This is necessary so that the tester @@ -796,6 +811,7 @@ SUBROUTINE PDSEPRSUBTST( WKNOWN, JOBZ, RANGE, UPLO, N, VL, VU, IL, 9983 FORMAT( 'ICLUSTR not zero terminated' ) 9982 FORMAT( 'IL, IU, VL or VU altered by PDSYEVR' ) 9981 FORMAT( 'NZ altered by PDSYEVR with JOBZ=N' ) + 9980 FORMAT( A, ' returned correct error code. Passing this case.') * * End of PDSEPRSUBTST * diff --git a/TESTING/EIG/pdsvdtst.f b/TESTING/EIG/pdsvdtst.f index e1b83452..ad0e907f 100644 --- a/TESTING/EIG/pdsvdtst.f +++ b/TESTING/EIG/pdsvdtst.f @@ -5,6 +5,7 @@ SUBROUTINE PDSVDTST( M, N, NPROW, NPCOL, NB, ISEED, THRESH, WORK, * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * .. Scalar Arguments .. INTEGER LWORK, M, N, NB, NOUT, NPCOL, NPROW @@ -267,11 +268,14 @@ SUBROUTINE PDSVDTST( M, N, NPROW, NPCOL, NB, ISEED, THRESH, WORK, * * Check input parameters. * +* Disabling check for M and N in Test directory +#ifdef ENABLE_DRIVER_CHECK IF( M.LE.0 ) THEN INFO = -1 ELSE IF( N.LE.0 ) THEN INFO = -2 - ELSE IF( NPROW.LE.0 ) THEN +#endif + IF( NPROW.LE.0 ) THEN INFO = -3 ELSE IF( NPCOL.LE.0 ) THEN INFO = -4 @@ -300,6 +304,18 @@ SUBROUTINE PDSVDTST( M, N, NPROW, NPCOL, NB, ISEED, THRESH, WORK, LDVT = NUMROC( SIZE, NB, MYROW, 0, NPROW ) LDVT = MAX( 1, LDVT ) CALL DESCINIT( DESCA, M, N, NB, NB, 0, 0, CONTEXT, LDA, DINFO ) +* If M < 0 in SVD.dat file then DESCINIT API sets DINFO = -2 +* If N < 0 in SVD.dat file then DESCINIT API sets DINFO = -3 + IF( M.LT.0 .AND. DINFO.EQ.-2 ) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9997 ) 'M' + ELSE IF( N.LT.0 .AND. DINFO.EQ.-3 ) THEN + WRITE( NOUT, FMT = 9997 ) 'N' + ELSE IF( DINFO.LT.0 ) THEN + WRITE( NOUT, FMT = 9996 ) 'descriptor' + GO TO 120 + END IF CALL DESCINIT( DESCU, M, SIZE, NB, NB, 0, 0, CONTEXT, LDU, DINFO ) CALL DESCINIT( DESCVT, SIZE, N, NB, NB, 0, 0, CONTEXT, LDVT, $ DINFO ) @@ -331,6 +347,48 @@ SUBROUTINE PDSVDTST( M, N, NPROW, NPCOL, NB, ISEED, THRESH, WORK, $ WORK( PTRWORK ), -1, DINFO ) WPDGESVD = INT( WORK( PTRWORK ) ) * + IF( (N.EQ.0 .OR. M.EQ.0) .AND. DINFO.EQ.0 ) THEN +* If N =0 or M =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + WRITE( NOUT, FMT = 9999 )'Passed', WTIME( 1 ), + $ CTIME( 1 ), M, N, NPROW, NPCOL, NB, ITYPE, CHK, MTM, + $ DELTA, HETERO + WRITE( NOUT, FMT = 9998) 'PDGESVD' + GO TO 120 + END IF +* +* If M < 0 in SVD.dat file then PDGESVD API sets DINFO = -3 +* If N < 0 in SVD.dat file then PDGESVD API sets DINFO = -4 +* + IF ( DINFO.LT.0 ) THEN + WRITE( NOUT, FMT = * ) 'PDGESVD DINFO=', DINFO + IF( M.LT.0 .AND. DINFO.EQ.-3 ) THEN +* When M < 0/Invalid, PDGESVD DINFO = -3 +* Expected Error code for M < 0 +* Hence this case can be passed + WRITE( NOUT, FMT = 9999 )'Passed', WTIME( 1 ), + $ CTIME( 1 ), M, N, NPROW, NPCOL, NB, ITYPE, + $ CHK, MTM, DELTA, HETERO + WRITE( NOUT, FMT = 9995) 'PDGESVD' + GO TO 120 + ELSE IF( N.LT.0 .AND. DINFO.EQ.-4 ) THEN +* When N < 0/Invalid, PDGESVD DINFO = -4 +* Expected Error code for N < 0 +* Hence this case can be passed + WRITE( NOUT, FMT = 9999 )'Passed', WTIME( 1 ), + $ CTIME( 1 ), M, N, NPROW, NPCOL, NB, ITYPE, + $ CHK, MTM, DELTA, HETERO + WRITE( NOUT, FMT = 9995) 'PDGESVD' + GO TO 120 + ELSE +* For other error code we will mark test case as fail + WRITE( NOUT, FMT = 9999 )'Failed', WTIME( 1 ), + $ CTIME( 1 ), M, N, NPROW, NPCOL, NB, ITYPE, CHK, MTM, + $ DELTA, HETERO + GO TO 120 + END IF + END IF CALL PDSVDCHK( M, N, WORK( PTRAC ), IA, JA, DESCA, WORK( PTRUC ), $ IU, JU, DESCU, WORK( PTRVT ), IVT, JVT, DESCVT, $ WORK( PTRS ), THRESH, WORK( PTRWORK ), -1, @@ -644,6 +702,13 @@ SUBROUTINE PDSVDTST( M, N, NPROW, NPCOL, NB, ISEED, THRESH, WORK, 110 CONTINUE * 9999 FORMAT( A6, 2E10.3, 2I6, 2I4, I5, I6, 3F6.2, 4X, A1 ) + 9998 FORMAT( '----------Test Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9997 FORMAT( A, ' < 0 case detected (Negative Test). ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9996 FORMAT( 'Bad ', A10, ' parameters: going on to next test case.' ) + 9995 FORMAT( A, ' returned correct error code. Passing this case.') 120 CONTINUE * * End of PDSVDTST diff --git a/TESTING/EIG/psbrddriver.f b/TESTING/EIG/psbrddriver.f index c3333da4..72a2e57f 100644 --- a/TESTING/EIG/psbrddriver.f +++ b/TESTING/EIG/psbrddriver.f @@ -5,6 +5,8 @@ PROGRAM PSBRDDRIVER * and University of California, Berkeley. * March 13, 2000 * +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. +* * Purpose * ======= * @@ -57,6 +59,7 @@ PROGRAM PSBRDDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, $ LLD_, MB_, M_, NB_, N_, RSRC_ @@ -117,6 +120,16 @@ PROGRAM PSBRDDRIVER * .. Data statements .. DATA KTESTS, KPASS, KFAIL, KSKIP / 4*0 / * .. +* +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X +* * .. Executable Statements .. * * Get starting information @@ -131,6 +144,36 @@ PROGRAM PSBRDDRIVER $ NTESTS, THRESH, MEM, IAM, NPROCS ) CHECK = ( THRESH.GE.0.0E+0 ) * +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* +* * Print headings * IF( IAM.EQ.0 ) THEN @@ -190,6 +233,7 @@ PROGRAM PSBRDDRIVER * Make sure matrix information is correct * IERR( 1 ) = 0 +#ifdef ENABLE_DRIVER_CHECK IF( M.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'M', M @@ -199,6 +243,7 @@ PROGRAM PSBRDDRIVER $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Make sure no one had error * @@ -260,12 +305,35 @@ PROGRAM PSBRDDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 10 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 .OR. + $ IERR(1) .EQ. -3 .OR. IERR(1) .EQ. -12 )) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid M and N +* -4, -8 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9984 ) 'N' + ELSE IF(M .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 .OR. + $ IERR(1) .EQ. -3 .OR. IERR(1) .EQ. -12 )) THEN + WRITE( NOUT, FMT = 9984 ) 'M' + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF + +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -329,7 +397,7 @@ PROGRAM PSBRDDRIVER * * Need Infinity-norm of A for checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GE.0 .AND. M.GE.0 ) THEN CALL PSFILLPAD( ICTXT, MP, NQ, MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, $ PADVAL ) @@ -370,7 +438,7 @@ PROGRAM PSBRDDRIVER * CALL SLTIMER( 1 ) * - IF( CHECK ) THEN + IF( CHECK .AND. INFO .EQ. 0 .AND. .NOT.(EX_FLAG)) THEN * * Check for memory overwrite * @@ -424,8 +492,17 @@ PROGRAM PSBRDDRIVER * * Test residual and detect NaN result * - IF( FRESID.LE.THRESH .AND. FRESID-FRESID.EQ.0.0E+0 - $ .AND. IERR( 1 ).EQ.0 ) THEN + IF((M .EQ. 0 .OR. N .EQ. 0) .AND. INFO .EQ. 0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) 'PSGEBRD' + PASSED = 'PASSED' + FRESID = 0 + ELSE IF( FRESID.LE.THRESH .AND. + $ FRESID-FRESID.EQ.0.0E+0 .AND. + $ IERR( 1 ).EQ.0 ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' ELSE @@ -443,9 +520,64 @@ PROGRAM PSBRDDRIVER * * Don't perform the checking, only the timing operation * - KPASS = KPASS + 1 FRESID = FRESID - FRESID - PASSED = 'BYPASS' +* Early return case + IF((M .EQ. 0 .OR. N .EQ. 0) .AND. INFO .EQ. 0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) 'PSGEBRD' + PASSED = 'PASSED' +* Invalid M/N + ELSE IF( ( M .LT. 0 .AND. INFO .EQ. -1 ) .OR. + $ ( N .LT. 0 .AND. INFO .EQ. -2 ) ) THEN +* +* When N < 0/Invalid, INFO = -2 +* When M < 0/Invalid, INFO = -1 +* Expected Error code for N < 0 +* Hence this case can be passed + WRITE( NOUT, FMT = 9983 ) 'PSGEBRD' + KPASS = KPASS + 1 + PASSED = 'PASSED' +* +* Extreme-value inputs + ELSE IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, M + DO JK = 1, N + X = MEM(IK*N + JK) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite(X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF +* + ELSE +* + KPASS = KPASS + 1 + PASSED = 'BYPASS' +* + END IF * END IF * @@ -538,6 +670,13 @@ PROGRAM PSBRDDRIVER 9988 FORMAT( I5, ' tests skipped because of illegal input values.' ) 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - Q*B*P|| / (||A|| * N * eps) = ', G25.7 ) + 9985 FORMAT( '----------Test Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9983 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') * STOP * diff --git a/TESTING/EIG/pshrddriver.f b/TESTING/EIG/pshrddriver.f index 912f3174..934ec383 100644 --- a/TESTING/EIG/pshrddriver.f +++ b/TESTING/EIG/pshrddriver.f @@ -5,6 +5,8 @@ PROGRAM PSHRDDRIVER * and University of California, Berkeley. * March 13, 2000 * +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. +* * Purpose * ======= * @@ -57,6 +59,7 @@ PROGRAM PSHRDDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, $ LLD_, MB_, M_, NB_, N_, RSRC_ @@ -118,6 +121,16 @@ PROGRAM PSHRDDRIVER * .. Data statements .. DATA KTESTS, KPASS, KFAIL, KSKIP / 4*0 / * .. +* +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X +* * .. Executable Statements .. * * Get starting information @@ -132,6 +145,36 @@ PROGRAM PSHRDDRIVER $ NTESTS, THRESH, MEM, IAM, NPROCS ) CHECK = ( THRESH.GE.0.0E+0 ) * +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* +* * Print headings * IF( IAM.EQ.0 ) THEN @@ -192,11 +235,13 @@ PROGRAM PSHRDDRIVER * Make sure matrix information is correct * IERR( 1 ) = 0 +#ifdef ENABLE_DRIVER_CHECK IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * @@ -253,12 +298,31 @@ PROGRAM PSHRDDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 10 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 .OR. + $ IERR(1) .EQ. -3 .OR. IERR(1) .EQ. -12 )) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid N +* -4, -8 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9984 ) 'N' + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF + +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -326,7 +390,7 @@ PROGRAM PSHRDDRIVER * * Need Infinity-norm of A for checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GE.0 ) THEN CALL PSFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, $ PADVAL ) @@ -359,7 +423,7 @@ PROGRAM PSHRDDRIVER $ MEM( IPT ), MEM( IPW ), LWORK, INFO ) CALL SLTIMER( 1 ) * - IF( CHECK ) THEN + IF( CHECK .AND. INFO .EQ. 0 .AND. .NOT.(EX_FLAG) ) THEN * * Check for memory overwrite * @@ -400,8 +464,18 @@ PROGRAM PSHRDDRIVER * * Test residual and detect NaN result * - IF( FRESID.LE.THRESH .AND. FRESID-FRESID.EQ.0.0E+0 ) - $ THEN + IF((N .EQ. 0) .AND. INFO .EQ. 0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case +* When N = 0, set ILO = 1, IHI = N in dat, to validate early return. + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) 'PSGEHRD' + PASSED = 'PASSED' + FRESID = 0 + ELSE IF( FRESID.LE.THRESH .AND. + $ FRESID-FRESID.EQ.0.0E+0 .AND. + $ IERR( 1 ).EQ.0 ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' ELSE @@ -414,9 +488,64 @@ PROGRAM PSHRDDRIVER * * Don't perform the checking, only the timing operation * - KPASS = KPASS + 1 FRESID = FRESID - FRESID - PASSED = 'BYPASS' +* Early return case + IF(( N .EQ. 0) .AND. INFO .EQ. 0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) 'PSGEHRD' + PASSED = 'PASSED' +* Invalid M/N + ELSE IF( N .LT. 0 .AND. INFO .EQ. -1 ) THEN +* +* When N < 0/Invalid, INFO = -2 +* Expected Error code for N < 0 +* Hence this case can be passed + WRITE( NOUT, FMT = 9983 ) 'PSGEHRD' + KPASS = KPASS + 1 + PASSED = 'PASSED' +* +* Extreme-value inputs + ELSE IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, N-1 + DO JK = 1, N + X = MEM(IK*N + JK) +* PRINT *, X + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite(X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF +* + ELSE +* + KPASS = KPASS + 1 + PASSED = 'BYPASS' +* + END IF +* END IF * * Gather max. of all CPU and WALL clock timings @@ -512,6 +641,13 @@ PROGRAM PSHRDDRIVER 9988 FORMAT( I5, ' tests skipped because of illegal input values.' ) 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - Q*H*Q''|| / (||A|| * N * eps) = ', G25.7 ) + 9985 FORMAT( '----------Test Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9983 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') * STOP * diff --git a/TESTING/EIG/psmatgen.f b/TESTING/EIG/psmatgen.f index df8faede..02133dd8 100644 --- a/TESTING/EIG/psmatgen.f +++ b/TESTING/EIG/psmatgen.f @@ -6,6 +6,7 @@ SUBROUTINE PSMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * .. Scalar Arguments .. CHARACTER*1 AFORM, DIAG @@ -119,7 +120,7 @@ SUBROUTINE PSMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0 ) * .. * .. Local Scalars .. - LOGICAL SYMM, HERM, TRAN + LOGICAL SYMM, HERM, TRAN, EXT_FLAG INTEGER I, IC, IK, INFO, IOFFC, IOFFR, IR, J, JK, $ JUMP1, JUMP2, JUMP3, JUMP4, JUMP5, JUMP6, $ JUMP7, MAXMN, MEND, MOFF, MP, MRCOL, MRROW, @@ -141,8 +142,15 @@ SUBROUTINE PSMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * .. External Functions .. LOGICAL LSAME INTEGER ICEIL, NUMROC + INTEGER CNT1, CNT2, CNT, TOT_CNT, DIV_FACTOR, REGION REAL PSRAND EXTERNAL ICEIL, NUMROC, LSAME, PSRAND +* + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .false. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 * .. * .. Executable Statements .. * @@ -153,6 +161,64 @@ SUBROUTINE PSMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, SYMM = LSAME( AFORM, 'S' ) HERM = LSAME( AFORM, 'H' ) TRAN = LSAME( AFORM, 'T' ) + EXT_FLAG = .FALSE. + +* Take command-line arguments if requested +* + +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EXT_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EXT_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do + + IF ( INF_PERCENT + NAN_PERCENT > 100) THEN + print *,"Sum of INF and NaN is", INF_PERCENT+NAN_PERCENT,"%" + help_flag = .true. + END IF + IF ( INF_PERCENT < 0 .OR. NAN_PERCENT < 0) THEN + print *, "Negative INF / NaN value is not allowed" + help_flag = .true. + END IF + +* Display help message if requested + IF (help_flag .AND. IAM.EQ.0) THEN + print *, "" + print *, "Options:" + print *, " -h, --help Display this help message" + print *, " -inf INF percentage in input", + $ " matrix (default: 0 %)" + print *, " -nan NaN percentage in input", + $ " matrix (default: 0 %)" + print *, "" + print *, " Note: INF + NaN values in input matrix", + $ " should be in the range of 0-100 %" + print *, "" + stop + END IF * INFO = 0 IF( .NOT.LSAME( DIAG, 'D' ) .AND. @@ -212,9 +278,46 @@ SUBROUTINE PSMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, JSEED(1) = ISEED JSEED(2) = 0 * +* Extreme-value parameter caclculations + IF( LSAME( DIAG, 'D' ) ) THEN + DIV_FACTOR = 2 + ELSE + DIV_FACTOR = 4 + END IF +* Find type of matrix to identify where to fill INF/NAN, +* If UPPER_TRIANGULAR_MATRIX., start above DIAG + IF( LSAME(AFORM, 'U' ) ) THEN + REGION = (IRNUM * ICNUM)/DIV_FACTOR +* If LOWER_TRIANGULAR/GENERAL MATRIX, start at beginning + ELSE + REGION = 1 + END IF + IF (EXT_FLAG) THEN + ZERO1 = 0.0E0 + ONE1 = 1.0E0 +* Calculate the number of NANs/INFs per grid + CNT1 = (IRNUM * ICNUM * NAN_PERCENT)/100 + CNT2 = (IRNUM * ICNUM * INF_PERCENT)/100 + CNT1 = CEILING(REAL(CNT1)) + CNT2 = CEILING(REAL(CNT2)) +* When Percentage requested by the user is low +* Replace atleast one element with NAN/INF +* Applicable for smaller matrices [2x2] + IF(NAN_PERCENT .GT. 0 .AND. CNT1 .EQ. 0 ) THEN + CNT1 = CNT1 + 1 + PRINT *, 'NAN Percentage is too low,', + $ 'Including one NAN element' + END IF + IF(INF_PERCENT .GT. 0 .AND. CNT2 .EQ. 0 ) THEN + CNT2 = CNT2 + 1 + PRINT *, 'INF Percentage is too low,', + $ 'Including one INF element' + END IF + END IF +* * Symmetric or Hermitian matrix will be generated. * - IF( SYMM.OR.HERM ) THEN + IF( (SYMM.OR.HERM) .AND. .NOT.(EXT_FLAG) ) THEN * * First, generate the lower triangular part (with diagonal block) * @@ -378,7 +481,8 @@ SUBROUTINE PSMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * * (Conjugate) Transposed matrix A will be generated. * - ELSE IF( TRAN .OR. LSAME( AFORM, 'C' ) ) THEN + ELSE IF(( TRAN .OR. LSAME( AFORM, 'C' )) .AND. + $ .NOT.(EXT_FLAG) ) THEN * JUMP1 = 1 JUMP2 = NQNB @@ -445,6 +549,9 @@ SUBROUTINE PSMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * A random matrix is generated. * ELSE + + TOT_CNT = 0 + CNT = 0 * JUMP1 = 1 JUMP2 = NPMB @@ -481,7 +588,20 @@ SUBROUTINE PSMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, IOFFR = ((IR-1)*NPROW+MRROW) * MB DO 250 J = 1, MB IF( IK .GT. IRNUM ) GO TO 270 - A(IK,JK) = ONE - TWO*PSRAND(0) +* Replace with NANs/INFs for extreme values + IF(EXT_FLAG .AND. CNT .LE. (CNT1 + CNT2) .AND. + $ TOT_CNT .GE. REGION) THEN + IF ( CNT .LT. CNT1) THEN + A(IK, JK) = ZERO1/ZERO1 + ELSE IF ( CNT .LT. (CNT1 + CNT2)) THEN + A(IK, JK) = ONE1/ZERO1 + END IF + CNT = CNT + 1 + TOT_CNT = TOT_CNT + 1 + ELSE + A(IK,JK) = ONE - TWO*PSRAND(0) + TOT_CNT = TOT_CNT + 1 + END IF IK = IK + 1 250 CONTINUE CALL JUMPIT( IA2, IC2, IB1, IRAN2 ) @@ -518,6 +638,9 @@ SUBROUTINE PSMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, RETURN END IF * +* + TOT_CNT = 0 + CNT = 0 MAXMN = MAX(M, N) JK = 1 DO 340 IC = NOFF+1, NEND @@ -528,7 +651,19 @@ SUBROUTINE PSMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, IF( IOFFC.EQ.IOFFR ) THEN DO 310 J = 0, MB-1 IF( IK .GT. IRNUM ) GO TO 330 - A(IK,JK+J) = ABS(A(IK,JK+J)) + MAXMN + IF(EXT_FLAG .AND. CNT .LE. (CNT1 + CNT2) + $ .AND. TOT_CNT .GT. (N/2) ) THEN + IF ( CNT .LT. CNT1) THEN + A(IK, JK+J) = ZERO1/ZERO1 + ELSE IF ( CNT .LT. (CNT1 + CNT2)) THEN + A(IK, JK+J) = ONE1/ZERO1 + END IF + CNT = CNT + 1 + TOT_CNT = TOT_CNT + 1 + ELSE + A(IK,JK+J) = ABS(A(IK,JK+J)) + MAXMN + TOT_CNT = TOT_CNT + 1 + END IF IK = IK + 1 310 CONTINUE ELSE diff --git a/TESTING/EIG/psnepdriver.f b/TESTING/EIG/psnepdriver.f index 38c312a6..489ede2c 100644 --- a/TESTING/EIG/psnepdriver.f +++ b/TESTING/EIG/psnepdriver.f @@ -4,6 +4,7 @@ PROGRAM PSNEPDRIVER * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======= @@ -189,11 +190,13 @@ PROGRAM PSNEPDRIVER * Make sure matrix information is correct * IERR( 1 ) = 0 +#ifdef ENABLE_DRIVER_CHECK IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 )'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * @@ -264,12 +267,32 @@ PROGRAM PSNEPDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 2, 1, IERR, 2, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 .OR. IERR( 2 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 )'descriptor' KSKIP = KSKIP + 1 GO TO 10 END IF +#else +* If N < 0 in NEP.dat file then DESCINIT API sets +* IERR( 1 ) to -2 or -8 or -4. +* If DESCINIT is returning correct error code then +* do nothing + IF( N.LT.0 .AND. (IERR( 1 ).EQ.-2 .OR. + $ IERR( 1 ).EQ. -8 .OR. + $ IERR( 1 ).EQ. -4 .OR. + $ IERR( 2 ).EQ.-2 .OR. + $ IERR( 2 ).EQ. -8 .OR. + $ IERR( 2 ).EQ. -4) ) THEN + WRITE ( NOUT, FMT = 9984 ) 'PSLAHQR' + ELSE IF( IERR( 1 ).LT.0 .OR. IERR( 2 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -384,11 +407,23 @@ PROGRAM PSNEPDRIVER IF( INFO.NE.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = * )'PSLAHQR INFO=', INFO - KFAIL = KFAIL + 1 - GO TO 10 +* If N < 0 in NEP.dat file then PSLAHQR API +* sets INFO = -5 + IF (N.LT.0 .AND. INFO.EQ.-5) THEN +* If PSLAHQR is returning correct error +* code we need to pass this case + WRITE( NOUT, FMT = 9983 ) 'PSLAHQR' + ELSE IF ( N.GT.1 .AND. INFO.NE.0 ) THEN + KFAIL = KFAIL + 1 + GO TO 10 + END IF + ELSE IF (N.EQ.0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. + WRITE( NOUT, FMT = 9982 ) 'PSLAHQR' END IF * - IF( CHECK ) THEN + IF( CHECK .AND. INFO.EQ.0 ) THEN * * Check for memory overwrite in NEP factorization * @@ -449,6 +484,10 @@ PROGRAM PSNEPDRIVER $ ( ( QRESID-QRESID ).EQ.0.0E+0 ) ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' + ELSE IF( N.EQ.0 ) THEN +* Passing residual checks for the case N = 0 + KPASS = KPASS + 1 + PASSED = 'PASSED' ELSE KFAIL = KFAIL + 1 PASSED = 'FAILED' @@ -465,7 +504,13 @@ PROGRAM PSNEPDRIVER KPASS = KPASS + 1 FRESID = FRESID - FRESID QRESID = QRESID - QRESID - PASSED = 'BYPASS' +* If the ScaLAPACK API is returning the correct +* INFO code for N < 0 then pass the case. + IF (N.LT.0 .AND. INFO.EQ.-5) THEN + PASSED = 'PASSED' + ELSE + PASSED = 'BYPASS' + END IF * END IF * @@ -561,6 +606,11 @@ PROGRAM PSNEPDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||H - Q*S*Q^T|| / (||H|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Q^T*Q - I|| / ( N * eps ) ', G25.7 ) + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, we will handle this case from ', + $ 'ScaLAPACK API.') + 9983 FORMAT( A, ' returned correct error code. Passing this case.') + 9982 FORMAT( 'This is safe exit from ', A, ' API. Passing this case.') * STOP * diff --git a/TESTING/EIG/psseprreq.f b/TESTING/EIG/psseprreq.f index e6e4b6cb..629509a2 100644 --- a/TESTING/EIG/psseprreq.f +++ b/TESTING/EIG/psseprreq.f @@ -5,6 +5,8 @@ SUBROUTINE PSSEPRREQ( HETERO, NIN, MEM, MEMSIZE, NOUT, ISEED, * University of California, Berkeley and * University of Tennessee, Knoxville. * October 21, 2006 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. +* All rights reserved. * IMPLICIT NONE * @@ -161,8 +163,17 @@ SUBROUTINE PSSEPRREQ( HETERO, NIN, MEM, MEMSIZE, NOUT, ISEED, $ MYCOL ) * IF( MYROW.GE.0 ) THEN +* If N < 0 in SEPR.dat file then DESCINIT API sets INFO = -2 CALL DESCINIT( DESCA, N, N, NB, NB, 0, 0, $ CONTEXT, LDA, INFO ) +* If DESCINIT is returning correct error code then +* do nothing + IF( N.LT.0 .AND. INFO.EQ.-2 ) THEN + WRITE( NOUT, FMT = 9999 ) 'N' + ELSE IF( INFO.LT.0 ) THEN + WRITE( NOUT, FMT = 9998 ) 'descriptor' + GO TO 40 + END IF CALL PSLASIZESEPR( DESCA, IPREPAD, IPOSTPAD, $ SIZEMQRLEFT, SIZEMQRRIGHT, $ SIZEQRF, SIZETMS, SIZEQTQ, @@ -232,6 +243,10 @@ SUBROUTINE PSSEPRREQ( HETERO, NIN, MEM, MEMSIZE, NOUT, ISEED, END IF * RETURN + 9999 FORMAT( A, ' < 0 case detected (Negative Test). ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9998 FORMAT( 'Bad ', A10, ' parameters: going on to next test case.' ) * * End of PSSEPRREQ * diff --git a/TESTING/EIG/psseprsubtst.f b/TESTING/EIG/psseprsubtst.f index 4451ef3f..cd3f04e2 100644 --- a/TESTING/EIG/psseprsubtst.f +++ b/TESTING/EIG/psseprsubtst.f @@ -9,6 +9,8 @@ SUBROUTINE PSSEPRSUBTST( WKNOWN, JOBZ, RANGE, UPLO, N, VL, VU, IL, * University of California, Berkeley and * University of Tennessee, Knoxville. * October 21, 2006 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. +* All rights reserved. * IMPLICIT NONE * @@ -388,6 +390,19 @@ SUBROUTINE PSSEPRSUBTST( WKNOWN, JOBZ, RANGE, UPLO, N, VL, VU, IL, * CALL SLTIMER( 6 ) CALL SLTIMER( 1 ) +* + IF ( N.LT.0 .AND. INFO.EQ.-4) THEN + WRITE( NOUT, FMT = * ) 'PSSYEVR INFO=', INFO +* When N < 0/Invalid, PSSYEVR INFO = -4 +* Expected Error code for N < 0 +* Hence this case can be passed. + WRITE( NOUT, FMT = 9980) 'PSSYEVR' + GO TO 150 + ELSE IF ( INFO.LT.0 ) THEN + WRITE( NOUT, FMT = * ) 'PSSYEVR INFO=', INFO + RESULT = 1 + GO TO 150 + END IF * * Indicate that there are no unresolved clusters. * This is necessary so that the tester @@ -796,6 +811,7 @@ SUBROUTINE PSSEPRSUBTST( WKNOWN, JOBZ, RANGE, UPLO, N, VL, VU, IL, 9983 FORMAT( 'ICLUSTR not zero terminated' ) 9982 FORMAT( 'IL, IU, VL or VU altered by PSSYEVR' ) 9981 FORMAT( 'NZ altered by PSSYEVR with JOBZ=N' ) + 9980 FORMAT( A, ' returned correct error code. Passing this case.') * * End of PSSEPRSUBTST * diff --git a/TESTING/EIG/pssvdtst.f b/TESTING/EIG/pssvdtst.f index b7137ac1..7ca37067 100644 --- a/TESTING/EIG/pssvdtst.f +++ b/TESTING/EIG/pssvdtst.f @@ -4,7 +4,8 @@ SUBROUTINE PSSVDTST( M, N, NPROW, NPCOL, NB, ISEED, THRESH, WORK, * -- ScaLAPACK routine (version 1.7) -- * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. -* May 1, 1997 +* May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * .. Scalar Arguments .. INTEGER LWORK, M, N, NB, NOUT, NPCOL, NPROW @@ -267,11 +268,13 @@ SUBROUTINE PSSVDTST( M, N, NPROW, NPCOL, NB, ISEED, THRESH, WORK, * * Check input parameters. * +#ifdef ENABLE_DRIVER_CHECK IF( M.LE.0 ) THEN INFO = -1 ELSE IF( N.LE.0 ) THEN INFO = -2 - ELSE IF( NPROW.LE.0 ) THEN +#endif + IF( NPROW.LE.0 ) THEN INFO = -3 ELSE IF( NPCOL.LE.0 ) THEN INFO = -4 @@ -300,6 +303,18 @@ SUBROUTINE PSSVDTST( M, N, NPROW, NPCOL, NB, ISEED, THRESH, WORK, LDVT = NUMROC( SIZE, NB, MYROW, 0, NPROW ) LDVT = MAX( 1, LDVT ) CALL DESCINIT( DESCA, M, N, NB, NB, 0, 0, CONTEXT, LDA, DINFO ) +* If M < 0 in SVD.dat file then DESCINIT API sets DINFO = -2 +* If N < 0 in SVD.dat file then DESCINIT API sets DINFO = -3 + IF( M.LT.0 .AND. DINFO.EQ.-2 ) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9997 ) 'M' + ELSE IF( N.LT.0 .AND. DINFO.EQ.-3 ) THEN + WRITE( NOUT, FMT = 9997 ) 'N' + ELSE IF( DINFO.LT.0 ) THEN + WRITE( NOUT, FMT = 9996 ) 'descriptor' + GO TO 120 + END IF CALL DESCINIT( DESCU, M, SIZE, NB, NB, 0, 0, CONTEXT, LDU, DINFO ) CALL DESCINIT( DESCVT, SIZE, N, NB, NB, 0, 0, CONTEXT, LDVT, $ DINFO ) @@ -330,6 +345,49 @@ SUBROUTINE PSSVDTST( M, N, NPROW, NPCOL, NB, ISEED, THRESH, WORK, $ WORK( PTRVT ), IVT, JVT, DESCVT, $ WORK( PTRWORK ), -1, DINFO ) WPSGESVD = INT( WORK( PTRWORK ) ) +* + IF( (N.EQ.0 .OR. M.EQ.0) .AND. DINFO.EQ.0 ) THEN +* If N =0 or M =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + WRITE( NOUT, FMT = 9999 )'Passed', WTIME( 1 ), + $ CTIME( 1 ), M, N, NPROW, NPCOL, NB, ITYPE, CHK, MTM, + $ DELTA, HETERO + WRITE( NOUT, FMT = 9998) 'PSGESVD' + GO TO 120 + END IF +* +* If M < 0 in SVD.dat file then PSGESVD API sets DINFO = -3 +* If N < 0 in SVD.dat file then PSGESVD API sets DINFO = -4 +* + IF ( DINFO.LT.0 ) THEN + WRITE( NOUT, FMT = * ) 'PSGESVD DINFO=', DINFO + IF( M.LT.0 .AND. DINFO.EQ.-3 ) THEN +* When M < 0/Invalid, PSGESVD DINFO = -3 +* Expected Error code for M < 0 +* Hence this case can be passed + WRITE( NOUT, FMT = 9999 )'Passed', WTIME( 1 ), + $ CTIME( 1 ), M, N, NPROW, NPCOL, NB, ITYPE, + $ CHK, MTM, DELTA, HETERO + WRITE( NOUT, FMT = 9995) 'PSGESVD' + GO TO 120 + ELSE IF( N.LT.0 .AND. DINFO.EQ.-4 ) THEN +* When N < 0/Invalid, PSGESVD DINFO = -4 +* Expected Error code for N < 0 +* Hence this case can be passed + WRITE( NOUT, FMT = 9999 )'Passed', WTIME( 1 ), + $ CTIME( 1 ), M, N, NPROW, NPCOL, NB, ITYPE, + $ CHK, MTM, DELTA, HETERO + WRITE( NOUT, FMT = 9995) 'PSGESVD' + GO TO 120 + ELSE +* For other error code we will mark test case as fail + WRITE( NOUT, FMT = 9999 )'Failed', WTIME( 1 ), + $ CTIME( 1 ), M, N, NPROW, NPCOL, NB, ITYPE, CHK, MTM, + $ DELTA, HETERO + GO TO 120 + END IF + END IF * CALL PSSVDCHK( M, N, WORK( PTRAC ), IA, JA, DESCA, WORK( PTRUC ), $ IU, JU, DESCU, WORK( PTRVT ), IVT, JVT, DESCVT, @@ -643,6 +701,13 @@ SUBROUTINE PSSVDTST( M, N, NPROW, NPCOL, NB, ISEED, THRESH, WORK, 110 CONTINUE * 9999 FORMAT( A6, 2E10.3, 2I6, 2I4, I5, I6, 3F6.2, 4X, A1 ) + 9998 FORMAT( '----------Test Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9997 FORMAT( A, ' < 0 case detected (Negative Test). ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9996 FORMAT( 'Bad ', A10, ' parameters: going on to next test case.' ) + 9995 FORMAT( A, ' returned correct error code. Passing this case.') 120 CONTINUE * * End of PSSVDTST diff --git a/TESTING/EIG/pzbrddriver.f b/TESTING/EIG/pzbrddriver.f index c6878d7e..3f279be4 100644 --- a/TESTING/EIG/pzbrddriver.f +++ b/TESTING/EIG/pzbrddriver.f @@ -5,6 +5,8 @@ PROGRAM PZBRDDRIVER * and University of California, Berkeley. * March 13, 2000 * +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. +* * Purpose * ======= * @@ -58,6 +60,7 @@ PROGRAM PZBRDDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, $ LLD_, MB_, M_, NB_, N_, RSRC_ @@ -118,6 +121,16 @@ PROGRAM PZBRDDRIVER * .. Data statements .. DATA KTESTS, KPASS, KFAIL, KSKIP / 4*0 / * .. +* +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X +* * .. Executable Statements .. * * Get starting information @@ -132,6 +145,36 @@ PROGRAM PZBRDDRIVER $ NTESTS, THRESH, MEM, IAM, NPROCS ) CHECK = ( THRESH.GE.0.0E+0 ) * +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* +* * Print headings * IF( IAM.EQ.0 ) THEN @@ -191,6 +234,7 @@ PROGRAM PZBRDDRIVER * Make sure matrix information is correct * IERR( 1 ) = 0 +#ifdef ENABLE_DRIVER_CHECK IF( M.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'M', M @@ -200,6 +244,7 @@ PROGRAM PZBRDDRIVER $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Make sure no one had error * @@ -261,12 +306,35 @@ PROGRAM PZBRDDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 10 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 .OR. + $ IERR(1) .EQ. -3 .OR. IERR(1) .EQ. -12 )) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid M and N +* -4, -8 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9984 ) 'N' + ELSE IF(M .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 .OR. + $ IERR(1) .EQ. -3 .OR. IERR(1) .EQ. -12 )) THEN + WRITE( NOUT, FMT = 9984 ) 'M' + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF + +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -334,7 +402,7 @@ PROGRAM PZBRDDRIVER * * Need Infinity-norm of A for checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GE.0 .AND. M.GE.0 ) THEN CALL PZFILLPAD( ICTXT, MP, NQ, MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, $ PADVAL ) @@ -375,7 +443,7 @@ PROGRAM PZBRDDRIVER * CALL SLTIMER( 1 ) * - IF( CHECK ) THEN + IF( CHECK .AND. INFO .EQ. 0 .AND. .NOT.(EX_FLAG)) THEN * * Check for memory overwrite * @@ -429,8 +497,17 @@ PROGRAM PZBRDDRIVER * * Test residual and detect NaN result * - IF( FRESID.LE.THRESH .AND. FRESID-FRESID.EQ.0.0D+0 - $ .AND. IERR( 1 ).EQ.0 ) THEN + IF((M .EQ. 0 .OR. N .EQ. 0) .AND. INFO .EQ. 0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) 'PZGEBRD' + PASSED = 'PASSED' + FRESID = 0 + ELSE IF( FRESID.LE.THRESH .AND. + $ FRESID-FRESID.EQ.0.0D+0 .AND. + $ IERR( 1 ).EQ.0 ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' ELSE @@ -448,9 +525,64 @@ PROGRAM PZBRDDRIVER * * Don't perform the checking, only the timing operation * - KPASS = KPASS + 1 FRESID = FRESID - FRESID - PASSED = 'BYPASS' +* Early return case + IF((M .EQ. 0 .OR. N .EQ. 0) .AND. INFO .EQ. 0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) 'PSGEBRD' + PASSED = 'PASSED' +* Invalid M/N + ELSE IF( ( M .LT. 0 .AND. INFO .EQ. -1 ) .OR. + $ ( N .LT. 0 .AND. INFO .EQ. -2 ) ) THEN +* +* When N < 0/Invalid, INFO = -2 +* When M < 0/Invalid, INFO = -1 +* Expected Error code for N < 0 +* Hence this case can be passed + WRITE( NOUT, FMT = 9983 ) 'PSGEBRD' + KPASS = KPASS + 1 + PASSED = 'PASSED' +* +* Extreme-value inputs + ELSE IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, M + DO JK = 1, N + X = MEM(IK*N + JK) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite(X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF +* + ELSE +* + KPASS = KPASS + 1 + PASSED = 'BYPASS' +* + END IF * END IF * @@ -543,6 +675,13 @@ PROGRAM PZBRDDRIVER 9988 FORMAT( I5, ' tests skipped because of illegal input values.' ) 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - Q*B*P|| / (||A|| * N * eps) = ', G25.7 ) + 9985 FORMAT( '----------Test Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9983 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') * STOP * diff --git a/TESTING/EIG/pzevcdriver.f b/TESTING/EIG/pzevcdriver.f index 093b499f..2156f60a 100644 --- a/TESTING/EIG/pzevcdriver.f +++ b/TESTING/EIG/pzevcdriver.f @@ -4,6 +4,7 @@ PROGRAM PZEVCDRIVER * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * June, 2000 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======= @@ -199,11 +200,13 @@ PROGRAM PZEVCDRIVER * Make sure matrix information is correct * IERR( 1 ) = 0 +#ifdef ENABLE_DRIVER_CHECK IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 )'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * @@ -274,12 +277,31 @@ PROGRAM PZEVCDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 2, 1, IERR, 2, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 .OR. IERR( 2 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 )'descriptor' KSKIP = KSKIP + 1 GO TO 20 END IF +#else +* If N < 0 in EVC.dat file then DESCINIT API sets IERR( 1 ) = -3 + IF( N.LT.0 .AND. (IERR( 1 ).EQ.-2 .OR. + $ IERR( 1 ).EQ. -8 .OR. + $ IERR( 1 ).EQ. -4 .OR. + $ IERR( 2 ).EQ.-2 .OR. + $ IERR( 2 ).EQ. -8 .OR. + $ IERR( 2 ).EQ. -4) ) THEN +* If DESCINIT is returning correct error code we need to pass +* and it will be ScaLAPACK API + WRITE ( NOUT, FMT = 9984 ) 'PZTREVC' + ELSE IF( IERR( 1 ).LT.0 .OR. IERR( 2 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 20 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -357,7 +379,7 @@ PROGRAM PZEVCDRIVER * * Calculate inf-norm of A for residual error-checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GE.0 ) THEN CALL PZFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, $ PADVAL ) @@ -401,8 +423,13 @@ PROGRAM PZEVCDRIVER MEM( IPWR-1+JJJ ) = ZERO END IF 10 CONTINUE - CALL ZGSUM2D( ICTXT, 'All', ' ', N, 1, MEM( IPWR ), N, +* +* In case of N<0, surpassing the call off ZGSUM2D +* + IF(N.GT.0) THEN + CALL ZGSUM2D( ICTXT, 'All', ' ', N, 1, MEM( IPWR ), N, $ -1, -1 ) + END IF * SELECT( 1 ) = .TRUE. CALL SLBOOT @@ -420,11 +447,23 @@ PROGRAM PZEVCDRIVER IF( INFO.NE.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = * )'PZTREVC INFO=', INFO - KFAIL = KFAIL + 1 - GO TO 20 +* If N < 0 in NEP.dat file then PZTREVC API sets +* INFO = -4 + IF (N.LT.0 .AND. INFO.EQ.-4) THEN +* If PZTREVC is returning correct error +* code we need to pass this case + WRITE( NOUT, FMT = 9983 ) 'PZTREVC' + ELSE IF ( N.GT.1 .AND. INFO.NE.0 ) THEN + KFAIL = KFAIL + 1 + GO TO 20 + END IF + ELSE IF (N.EQ.0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. + WRITE( NOUT, FMT = 9982 ) 'PZTREVC' END IF * - IF( CHECK ) THEN + IF( CHECK .AND. INFO.EQ.0 ) THEN * * Check for memory overwrite in NEP factorization * @@ -487,6 +526,10 @@ PROGRAM PZEVCDRIVER $ ( ( QRESID-QRESID ).EQ.0.0D+0 ) ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' + ELSE IF( N.EQ.0 ) THEN +* Passing residual checks for the case N = 0 + KPASS = KPASS + 1 + PASSED = 'PASSED' ELSE KFAIL = KFAIL + 1 PASSED = 'FAILED' @@ -503,7 +546,11 @@ PROGRAM PZEVCDRIVER KPASS = KPASS + 1 FRESID = FRESID - FRESID QRESID = QRESID - QRESID - PASSED = 'BYPASS' + IF (N.LT.0 .AND. INFO.EQ.-4) THEN + PASSED = 'PASSED' + ELSE + PASSED = 'BYPASS' + END IF * END IF * @@ -599,6 +646,11 @@ PROGRAM PZEVCDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||H*Z - Z*D|| / (||T|| * N * eps) = ', G25.7 ) 9985 FORMAT( 'max_j(max|Z(j)| - 1) / ( N * eps ) ', G25.7 ) + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, we will handle this case from ', + $ 'ScaLAPACK API.') + 9983 FORMAT( A, ' returned correct error code. Passing this case.') + 9982 FORMAT( 'This is safe exit from ', A, ' API. Passing this case.') * STOP * diff --git a/TESTING/EIG/pzhrddriver.f b/TESTING/EIG/pzhrddriver.f index 77c51795..3c4f9ece 100644 --- a/TESTING/EIG/pzhrddriver.f +++ b/TESTING/EIG/pzhrddriver.f @@ -5,6 +5,8 @@ PROGRAM PZHRDDRIVER * and University of California, Berkeley. * March 13, 2000 * +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. +* * Purpose * ======= * @@ -58,6 +60,7 @@ PROGRAM PZHRDDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, $ LLD_, MB_, M_, NB_, N_, RSRC_ @@ -119,6 +122,16 @@ PROGRAM PZHRDDRIVER * .. Data statements .. DATA KTESTS, KPASS, KFAIL, KSKIP / 4*0 / * .. +* +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X +* * .. Executable Statements .. * * Get starting information @@ -133,6 +146,36 @@ PROGRAM PZHRDDRIVER $ NTESTS, THRESH, MEM, IAM, NPROCS ) CHECK = ( THRESH.GE.0.0E+0 ) * +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* +* * Print headings * IF( IAM.EQ.0 ) THEN @@ -193,11 +236,13 @@ PROGRAM PZHRDDRIVER * Make sure matrix information is correct * IERR( 1 ) = 0 +#ifdef ENABLE_DRIVER_CHECK IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * @@ -254,12 +299,31 @@ PROGRAM PZHRDDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 10 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 .OR. + $ IERR(1) .EQ. -3 .OR. IERR(1) .EQ. -12 )) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid N +* -4, -8 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9984 ) 'N' + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF + +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -327,7 +391,7 @@ PROGRAM PZHRDDRIVER * * Need Infinity-norm of A for checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GE.0 ) THEN CALL PZFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, $ PADVAL ) @@ -360,7 +424,7 @@ PROGRAM PZHRDDRIVER $ MEM( IPT ), MEM( IPW ), LWORK, INFO ) CALL SLTIMER( 1 ) * - IF( CHECK ) THEN + IF( CHECK .AND. INFO .EQ. 0 .AND. .NOT.(EX_FLAG) ) THEN * * Check for memory overwrite * @@ -401,8 +465,18 @@ PROGRAM PZHRDDRIVER * * Test residual and detect NaN result * - IF( FRESID.LE.THRESH .AND. FRESID-FRESID.EQ.0.0D+0 ) - $ THEN + IF((N .EQ. 0) .AND. INFO .EQ. 0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case +* When N = 0, set ILO = 1, IHI = N in dat, to validate early return. + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) 'PZGEHRD' + PASSED = 'PASSED' + FRESID = 0 + ELSE IF( FRESID.LE.THRESH .AND. + $ FRESID-FRESID.EQ.0.0D+0 .AND. + $ IERR( 1 ).EQ.0 ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' ELSE @@ -415,9 +489,64 @@ PROGRAM PZHRDDRIVER * * Don't perform the checking, only the timing operation * - KPASS = KPASS + 1 FRESID = FRESID - FRESID - PASSED = 'BYPASS' +* Early return case + IF(( N .EQ. 0) .AND. INFO .EQ. 0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) 'PZGEHRD' + PASSED = 'PASSED' +* Invalid M/N + ELSE IF( N .LT. 0 .AND. INFO .EQ. -1 ) THEN +* +* When N < 0/Invalid, INFO = -2 +* Expected Error code for N < 0 +* Hence this case can be passed + WRITE( NOUT, FMT = 9983 ) 'PZGEHRD' + KPASS = KPASS + 1 + PASSED = 'PASSED' +* +* Extreme-value inputs + ELSE IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, N-1 + DO JK = 1, N + X = MEM(IK*N + JK) +* PRINT *, X + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite(X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF +* + ELSE +* + KPASS = KPASS + 1 + PASSED = 'BYPASS' +* + END IF +* END IF * * Gather max. of all CPU and WALL clock timings @@ -513,6 +642,13 @@ PROGRAM PZHRDDRIVER 9988 FORMAT( I5, ' tests skipped because of illegal input values.' ) 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - Q*H*Q''|| / (||A|| * N * eps) = ', G25.7 ) + 9985 FORMAT( '----------Test Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9983 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') * STOP * diff --git a/TESTING/EIG/pzmatgen.f b/TESTING/EIG/pzmatgen.f index f4ee5ab0..4232e537 100644 --- a/TESTING/EIG/pzmatgen.f +++ b/TESTING/EIG/pzmatgen.f @@ -6,6 +6,7 @@ SUBROUTINE PZMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * .. Scalar Arguments .. CHARACTER*1 AFORM, DIAG @@ -119,7 +120,7 @@ SUBROUTINE PZMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. - LOGICAL SYMM, HERM, TRAN + LOGICAL SYMM, HERM, TRAN, EXT_FLAG INTEGER I, IC, IK, INFO, IOFFC, IOFFR, IR, J, JK, $ JUMP1, JUMP2, JUMP3, JUMP4, JUMP5, JUMP6, $ JUMP7, MAXMN, MEND, MOFF, MP, MRCOL, MRROW, @@ -142,8 +143,15 @@ SUBROUTINE PZMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * .. External Functions .. LOGICAL LSAME INTEGER ICEIL, NUMROC + INTEGER CNT1, CNT2, CNT, TOT_CNT, DIV_FACTOR, REGION DOUBLE PRECISION PDRAND EXTERNAL ICEIL, NUMROC, LSAME, PDRAND +* + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .false. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 * .. * .. Executable Statements .. * @@ -154,6 +162,64 @@ SUBROUTINE PZMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, SYMM = LSAME( AFORM, 'S' ) HERM = LSAME( AFORM, 'H' ) TRAN = LSAME( AFORM, 'T' ) + EXT_FLAG = .FALSE. + +* Take command-line arguments if requested +* + +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EXT_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EXT_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do + + IF ( INF_PERCENT + NAN_PERCENT > 100) THEN + print *,"Sum of INF and NaN is", INF_PERCENT+NAN_PERCENT,"%" + help_flag = .true. + END IF + IF ( INF_PERCENT < 0 .OR. NAN_PERCENT < 0) THEN + print *, "Negative INF / NaN value is not allowed" + help_flag = .true. + END IF + +* Display help message if requested + IF (help_flag .AND. IAM.EQ.0) THEN + print *, "" + print *, "Options:" + print *, " -h, --help Display this help message" + print *, " -inf INF percentage in input", + $ " matrix (default: 0 %)" + print *, " -nan NaN percentage in input", + $ " matrix (default: 0 %)" + print *, "" + print *, " Note: INF + NaN values in input matrix", + $ " should be in the range of 0-100 %" + print *, "" + stop + END IF * INFO = 0 IF( .NOT.LSAME( DIAG, 'D' ) .AND. @@ -213,9 +279,47 @@ SUBROUTINE PZMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, JSEED(1) = ISEED JSEED(2) = 0 * +* Extreme-value parameter calculations + IF( LSAME( DIAG, 'D' ) ) THEN + DIV_FACTOR = 2 + ELSE + DIV_FACTOR = 4 + END IF +* Find type of matrix to identify where to fill INF/NAN, +* If UPPER_TRIANGULAR_MATRIX., start above DIAG + IF( LSAME(AFORM, 'U' ) ) THEN + REGION = (IRNUM * ICNUM)/DIV_FACTOR +* If LOWER_TRIANGULAR/GENERAL MATRIX, start at beginning + ELSE + REGION = 1 + END IF + IF (EXT_FLAG) THEN + CNT = 0 + ZERO1 = 0.0D+0 + ONE1 = 1.0D+0 +* Calculate the number of NANs/INFs per grid + CNT1 = (IRNUM * ICNUM * NAN_PERCENT)/100 + CNT2 = (IRNUM * ICNUM * INF_PERCENT)/100 + CNT1 = CEILING(REAL(CNT1)) + CNT2 = CEILING(REAL(CNT2)) +* When Percentage requested by the user is low +* Replace atleast one element with NAN/INF +* Applicable for smaller matrices [2x2] + IF(NAN_PERCENT .GT. 0 .AND. CNT1 .EQ. 0 ) THEN + CNT1 = CNT1 + 1 + PRINT *, 'NAN Percentage is too low,', + $ 'Including one NAN element' + END IF + IF(INF_PERCENT .GT. 0 .AND. CNT2 .EQ. 0 ) THEN + CNT2 = CNT2 + 1 + PRINT *, 'INF Percentage is too low,', + $ 'Including one INF element' + END IF + END IF +* * Symmetric or Hermitian matrix will be generated. * - IF( SYMM.OR.HERM ) THEN + IF( (SYMM.OR.HERM) .AND. .NOT.(EXT_FLAG) ) THEN * * First, generate the lower triangular part (with diagonal block) * @@ -397,7 +501,8 @@ SUBROUTINE PZMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * * (Conjugate) Transposed matrix A will be generated. * - ELSE IF( TRAN .OR. LSAME( AFORM, 'C' ) ) THEN + ELSE IF(( TRAN .OR. LSAME( AFORM, 'C' )) .AND. + $ .NOT.(EXT_FLAG) ) THEN * JUMP1 = 1 JUMP2 = 2*NQNB @@ -470,6 +575,9 @@ SUBROUTINE PZMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * A random matrix is generated. * ELSE + + TOT_CNT = 0 + CNT = 0 * JUMP1 = 1 JUMP2 = 2*NPMB @@ -506,8 +614,21 @@ SUBROUTINE PZMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, IOFFR = ((IR-1)*NPROW+MRROW) * MB DO 250 J = 1, MB IF( IK .GT. IRNUM ) GO TO 270 +* Replace with NANs/INFs for extreme values + IF(EXT_FLAG .AND. CNT .LE. (CNT1 + CNT2) .AND. + $ TOT_CNT .GE. REGION) THEN + IF ( CNT .LT. CNT1) THEN + A(IK, JK) = DCMPLX(ZERO1/ZERO1,ZERO1/ZERO1) + ELSE IF ( CNT .LT. (CNT1 + CNT2)) THEN + A(IK, JK) = DCMPLX(ONE1/ZERO1, ONE1/ZERO1) + END IF + CNT = CNT + 1 + TOT_CNT = TOT_CNT + 1 + ELSE A(IK,JK) = DCMPLX( ONE - TWO*PDRAND(0), $ ONE - TWO*PDRAND(0) ) + TOT_CNT = TOT_CNT + 1 + END IF IK = IK + 1 250 CONTINUE CALL JUMPIT( IA2, IC2, IB1, IRAN2 ) @@ -544,6 +665,8 @@ SUBROUTINE PZMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, RETURN END IF * + TOT_CNT = 0 + CNT = 0 MAXMN = MAX(M, N) JK = 1 DO 340 IC = NOFF+1, NEND @@ -554,12 +677,23 @@ SUBROUTINE PZMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, IF( IOFFC.EQ.IOFFR ) THEN DO 310 J = 0, MB-1 IF( IK .GT. IRNUM ) GO TO 330 - IF( HERM ) THEN + IF(EXT_FLAG .AND. CNT .LE. (CNT1 + CNT2) + $ .AND. TOT_CNT .GT. (N/2) ) THEN + IF ( CNT .LT. CNT1) THEN + A(IK, JK+J) = DCMPLX(ZERO1/ZERO1,ZERO1/ZERO1) + ELSE IF ( CNT .LT. (CNT1 + CNT2)) THEN + A(IK, JK+J) = DCMPLX(ONE1/ZERO1, ONE1/ZERO1) + END IF + CNT = CNT + 1 + TOT_CNT = TOT_CNT + 1 + ELSE IF( HERM ) THEN A(IK,JK+J) = DCMPLX( - $ ABS(DBLE(A(IK,JK+J)))+2*MAXMN, ZERO ) + $ ABS(REAL(A(IK,JK+J)))+2*MAXMN, ZERO) + TOT_CNT = TOT_CNT + 1 ELSE A(IK,JK+J)= DCMPLX( ABS(DBLE(A(IK,JK+J)))+MAXMN, $ ABS(DIMAG(A(IK,JK+J)))+ MAXMN ) + TOT_CNT = TOT_CNT + 1 END IF IK = IK + 1 310 CONTINUE diff --git a/TESTING/EIG/pznepdriver.f b/TESTING/EIG/pznepdriver.f index e4791dea..a128e631 100644 --- a/TESTING/EIG/pznepdriver.f +++ b/TESTING/EIG/pznepdriver.f @@ -4,6 +4,7 @@ PROGRAM PZNEPDRIVER * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * March, 2000 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======= @@ -194,11 +195,13 @@ PROGRAM PZNEPDRIVER * Make sure matrix information is correct * IERR( 1 ) = 0 +#ifdef ENABLE_DRIVER_CHECK IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 )'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * @@ -270,12 +273,32 @@ PROGRAM PZNEPDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 2, 1, IERR, 2, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 .OR. IERR( 2 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 )'descriptor' KSKIP = KSKIP + 1 GO TO 10 END IF +#else +* If N < 0 in NEP.dat file then DESCINIT API sets +* IERR( 1 ) to -2 or -8 or -4. +* If DESCINIT is returning correct error code then +* do nothing. + IF( N.LT.0 .AND. (IERR( 1 ).EQ.-2 .OR. + $ IERR( 1 ).EQ. -8 .OR. + $ IERR( 1 ).EQ. -4 .OR. + $ IERR( 2 ).EQ.-2 .OR. + $ IERR( 2 ).EQ. -8 .OR. + $ IERR( 2 ).EQ. -4) ) THEN + WRITE ( NOUT, FMT = 9984 ) 'PZLAHQR' + ELSE IF( IERR( 1 ).LT.0 .OR. IERR( 2 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -388,11 +411,23 @@ PROGRAM PZNEPDRIVER IF( INFO.NE.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = * )'PZLAHQR INFO=', INFO - KFAIL = KFAIL + 1 - GO TO 10 +* If N < 0 in NEP.dat file then PZLAHQR API sets +* INFO = -5 + IF (N.LT.0 .AND. INFO.EQ.-5) THEN +* If PZLAHQR is returning correct error +* code we need to pass this case + WRITE( NOUT, FMT = 9983 ) 'PZLAHQR' + ELSE IF ( N.GT.1 .AND. INFO.NE.0 ) THEN + KFAIL = KFAIL + 1 + GO TO 10 + END IF + ELSE IF (N.EQ.0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. + WRITE( NOUT, FMT = 9982 ) 'PZLAHQR' END IF * - IF( CHECK ) THEN + IF( CHECK .AND. INFO.EQ.0 ) THEN * * Check for memory overwrite in NEP factorization * @@ -450,6 +485,10 @@ PROGRAM PZNEPDRIVER $ ( ( QRESID-QRESID ).EQ.0.0D+0 ) ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' + ELSE IF( N.EQ.0 ) THEN +* Passing residual checks for the case N = 0 + KPASS = KPASS + 1 + PASSED = 'PASSED' ELSE KFAIL = KFAIL + 1 PASSED = 'FAILED' @@ -466,7 +505,13 @@ PROGRAM PZNEPDRIVER KPASS = KPASS + 1 FRESID = FRESID - FRESID QRESID = QRESID - QRESID - PASSED = 'BYPASS' +* If the ScaLAPACK API is returning the correct +* INFO code for N < 0 then pass the case. + IF (N.LT.0 .AND. INFO.EQ.-5) THEN + PASSED = 'PASSED' + ELSE + PASSED = 'BYPASS' + END IF * END IF * @@ -562,6 +607,11 @@ PROGRAM PZNEPDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||H - Q*S*Q^T|| / (||H|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Q^T*Q - I|| / ( N * eps ) ', G25.7 ) + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, we will handle this case from ', + $ 'ScaLAPACK API.') + 9983 FORMAT( A, ' returned correct error code. Passing this case.') + 9982 FORMAT( 'This is safe exit from ', A, ' API. Passing this case.') * STOP * diff --git a/TESTING/EIG/pzseprreq.f b/TESTING/EIG/pzseprreq.f index ec77f162..f456eb17 100644 --- a/TESTING/EIG/pzseprreq.f +++ b/TESTING/EIG/pzseprreq.f @@ -5,6 +5,8 @@ SUBROUTINE PZSEPRREQ( HETERO, NIN, MEM, MEMSIZE, NOUT, ISEED, * University of California, Berkeley and * University of Tennessee, Knoxville. * October 21, 2006 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. +* All rights reserved. * IMPLICIT NONE * @@ -161,8 +163,17 @@ SUBROUTINE PZSEPRREQ( HETERO, NIN, MEM, MEMSIZE, NOUT, ISEED, $ MYCOL ) * IF( MYROW.GE.0 ) THEN +* If N < 0 in SEPR.dat file then DESCINIT API sets INFO = -2 CALL DESCINIT( DESCA, N, N, NB, NB, 0, 0, $ CONTEXT, LDA, INFO ) +* If DESCINIT is returning correct error code then +* do nothing + IF( N.LT.0 .AND. INFO.EQ.-2 ) THEN + WRITE( NOUT, FMT = 9999 ) 'N' + ELSE IF( INFO.LT.0 ) THEN + WRITE( NOUT, FMT = 9998 ) 'descriptor' + GO TO 40 + END IF CALL PZLASIZESEPR( DESCA, IPREPAD, IPOSTPAD, $ SIZEMQRLEFT, SIZEMQRRIGHT, $ SIZEQRF, SIZETMS, SIZEQTQ, @@ -226,6 +237,10 @@ SUBROUTINE PZSEPRREQ( HETERO, NIN, MEM, MEMSIZE, NOUT, ISEED, END IF * RETURN + 9999 FORMAT( A, ' < 0 case detected (Negative Test). ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9998 FORMAT( 'Bad ', A10, ' parameters: going on to next test case.' ) * * End of PZSEPRREQ * diff --git a/TESTING/EIG/pzseprsubtst.f b/TESTING/EIG/pzseprsubtst.f index a7e09d6e..8ef1d900 100644 --- a/TESTING/EIG/pzseprsubtst.f +++ b/TESTING/EIG/pzseprsubtst.f @@ -9,6 +9,8 @@ SUBROUTINE PZSEPRSUBTST( WKNOWN, JOBZ, RANGE, UPLO, N, VL, VU, IL, * University of California, Berkeley and * University of Tennessee, Knoxville. * October 21, 2006 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. +* All rights reserved. * IMPLICIT NONE * @@ -410,6 +412,19 @@ SUBROUTINE PZSEPRSUBTST( WKNOWN, JOBZ, RANGE, UPLO, N, VL, VU, IL, * CALL SLTIMER( 6 ) CALL SLTIMER( 1 ) +* + IF ( N.LT.0 .AND. INFO.EQ.-4) THEN + WRITE( NOUT, FMT = * ) 'PZHEEVR INFO=', INFO +* When N < 0/Invalid, PZHEEVR INFO = -4 +* Expected Error code for N < 0 +* Hence this case can be passed. + WRITE( NOUT, FMT = 9980) 'PZHEEVR' + GO TO 150 + ELSE IF ( INFO.LT.0 ) THEN + WRITE( NOUT, FMT = * ) 'PZHEEVR INFO=', INFO + RESULT = 1 + GO TO 150 + END IF * * Indicate that there are no unresolved clusters. * This is necessary so that the tester @@ -822,6 +837,7 @@ SUBROUTINE PZSEPRSUBTST( WKNOWN, JOBZ, RANGE, UPLO, N, VL, VU, IL, 9983 FORMAT( 'ICLUSTR not zero terminated' ) 9982 FORMAT( 'IL, IU, VL or VU altered by PZHEEVR' ) 9981 FORMAT( 'NZ altered by PZHEEVR with JOBZ=N' ) + 9980 FORMAT( A, ' returned correct error code. Passing this case.') * * End of PZSEPRSUBTST * diff --git a/TESTING/EXT_TESTS/BLLT.dat b/TESTING/EXT_TESTS/BLLT.dat new file mode 100644 index 00000000..818d4919 --- /dev/null +++ b/TESTING/EXT_TESTS/BLLT.dat @@ -0,0 +1,18 @@ +'AOCL-ScaLAPACK, banded linear systems input file' +'MPI machine' +'' output file name (if any) +6 device out +'U' define Lower or Upper +10 number of problem sizes +67 118 -118 267 393 0 527 655 804 1023 values of N. The N value should be more than the BW values +6 number of bandwidths +1 2 4 10 31 64 values of BW +1 number of NB's +-1 values of NB (-1 for automatic determination) +1 number of NRHS's (must be 1) +4 values of NRHS +1 number of NBRHS's (ignored) +1 values of NBRHS (ignored) +4 number of process grids +1 2 3 4 values of "Number of Process Columns" +3.0 threshold \ No newline at end of file diff --git a/TESTING/EXT_TESTS/BLU.dat b/TESTING/EXT_TESTS/BLU.dat new file mode 100644 index 00000000..f74d7a5f --- /dev/null +++ b/TESTING/EXT_TESTS/BLU.dat @@ -0,0 +1,19 @@ +'AOCL-ScaLAPACK, banded linear systems input file' +'MPI machine' +'' output file name (if any) +6 device out +'N' define transpose or not + 5 number of problem sizes + 17 0 28 -10 37 121 200 1023 values of N. The N value should be more than the BWL, BWU values + 3 number of bandwidths + 1 3 15 6 13 20 values of BWL + 1 1 4 18 24 33 values of BWU +1 number of NB's +-1 values of NB (-1 for automatic determination) +1 number of NRHS's (must be 1) +4 values of NRHS +1 number of NBRHS's (ignored) +1 values of NBRHS (ignored) + 4 number of process grids + 1 2 3 4 values of "Number of Process Columns" +3.0 threshold diff --git a/TESTING/EXT_TESTS/BRD.dat b/TESTING/EXT_TESTS/BRD.dat new file mode 100644 index 00000000..57fe4705 --- /dev/null +++ b/TESTING/EXT_TESTS/BRD.dat @@ -0,0 +1,13 @@ +'ScaLAPACK BRD input file' +'MPI machine' +'BRD.out' output file name (if any) +6 device out +6 number of problems sizes +4 10 -12 17 11 13 23 31 57 values of M +4 12 10 13 0 13 23 31 50 values of N +4 number of NB's +2 3 4 5 values of NB +4 number of processor grids (ordered pairs of P & Q) +1 2 1 4 2 3 8 values of P +1 2 4 1 3 2 1 values of Q +10.0 threshold diff --git a/TESTING/EXT_TESTS/EVC.dat b/TESTING/EXT_TESTS/EVC.dat new file mode 100644 index 00000000..7cc359be --- /dev/null +++ b/TESTING/EXT_TESTS/EVC.dat @@ -0,0 +1,12 @@ +'SCALAPACK NEP (Nonsymmetric Eigenvalue Problem) input file' +'MPI Machine' +'EVC.out' output file name (if any) +6 device out +3 number of problems sizes +0 -10 1500 2000 2500 3000 Probs +1 number of NB's +8 values of NB +4 number of process grids (ordered pairs of P & Q) +1 1 4 2 3 2 2 1 values of P +1 4 1 2 3 1 4 8 values of Q +20.0 threshold diff --git a/TESTING/EXT_TESTS/HRD.dat b/TESTING/EXT_TESTS/HRD.dat new file mode 100644 index 00000000..d1a084e1 --- /dev/null +++ b/TESTING/EXT_TESTS/HRD.dat @@ -0,0 +1,14 @@ +'ScaLAPACK HRD input file' +'MPI machine' +'HRD.out' output file name (if any) +6 device out +6 number of problems sizes +50 -50 50 0 50 50 values of N +1 2 3 1 3 5 values of ILO +50 48 45 0 45 49 values of IHI +3 number of NB's +2 3 4 values of NB +4 number of processor grids (ordered pairs of P & Q) +1 2 1 4 2 3 8 values of P +1 2 4 1 3 2 1 values of Q +3.0 threshold diff --git a/TESTING/EXT_TESTS/INV.dat b/TESTING/EXT_TESTS/INV.dat new file mode 100644 index 00000000..1de1602f --- /dev/null +++ b/TESTING/EXT_TESTS/INV.dat @@ -0,0 +1,14 @@ +'AOCL-ScaLAPACK, Matrix Inversion Testing input file' +'MPI machine.' +'INV.out' output file name (if any) +6 device out +5 number of matrix types (next line) +'GEN' 'UTR' 'LTR' 'UPD' 'LPD' GEN, UTR, LTR, UPD, LPD +6 number of problems sizes +15 20 -3 26 0 50 values of N +4 number of NB's +2 3 4 5 6 20 values of NB +4 number of process grids (ordered P & Q) +1 2 1 4 2 3 8 values of P +1 1 2 1 3 2 1 values of Q +1.0 threshold \ No newline at end of file diff --git a/TESTING/EXT_TESTS/LLT.dat b/TESTING/EXT_TESTS/LLT.dat new file mode 100644 index 00000000..e5d261b9 --- /dev/null +++ b/TESTING/EXT_TESTS/LLT.dat @@ -0,0 +1,18 @@ +'ScaLAPACK, LLt factorization input file' +'MPI machine' +'LLT.out' output file name (if any) +6 device out +'U' define Lower or Upper +4 number of problems sizes +4 10 17 13 23 31 57 values of N +3 number of NB's +2 3 4 5 values of NB +3 number of NRHS's +1 3 9 28 values of NRHS +3 number of NBRHS's +1 3 5 7 values of NBRHS +4 number of process grids (ordered pairs P & Q) +1 2 1 4 2 3 8 values of P +1 2 4 1 3 2 1 values of Q +3.0 threshold +T (T or F) Test Cond. Est. and Iter. Ref. Routines diff --git a/TESTING/EXT_TESTS/LS.dat b/TESTING/EXT_TESTS/LS.dat new file mode 100644 index 00000000..37f82175 --- /dev/null +++ b/TESTING/EXT_TESTS/LS.dat @@ -0,0 +1,17 @@ +'ScaLAPACK LS solve input file' +'MPI machine' +'LS.out' output file name (if any) +6 device out +7 number of problems sizes +15 7 31 0 31 -7 7 values of M +5 21 31 31 0 21 -21 values of N +2 number of NB's +2 3 5 values of NB +3 number of NRHS's +2 -3 0 values of NRHS +2 number of NBRHS's +1 2 values of NBRHS +4 number of process grids (ordered pairs P & Q) +1 1 4 2 2 3 8 values of P +1 4 1 2 3 2 1 values of Q +4.0 threshold \ No newline at end of file diff --git a/TESTING/EXT_TESTS/LU.dat b/TESTING/EXT_TESTS/LU.dat new file mode 100644 index 00000000..b81ec2c6 --- /dev/null +++ b/TESTING/EXT_TESTS/LU.dat @@ -0,0 +1,18 @@ +'SCALAPACK, LU factorization input file' +'MPI Machine' +'LU.out' output file name (if any) +6 device out +4 number of problems sizes +4 10 17 13 23 31 57 values of M +4 12 13 13 23 31 50 values of N +3 number of NB's +2 3 4 5 values of NB +3 number of NRHS's +1 3 9 28 values of NRHS +3 Number of NBRHS's +1 3 5 7 values of NBRHS +4 number of process grids (ordered pairs of P & Q) +1 2 1 4 2 3 8 values of P +1 2 4 1 3 2 1 values of Q +1.0 threshold +T (T or F) Test Cond. Est. and Iter. Ref. Routines diff --git a/TESTING/EXT_TESTS/NEP.dat b/TESTING/EXT_TESTS/NEP.dat new file mode 100644 index 00000000..0ea6e6b7 --- /dev/null +++ b/TESTING/EXT_TESTS/NEP.dat @@ -0,0 +1,12 @@ +'SCALAPACK NEP (Nonsymmetric Eigenvalue Problem) input file' +'MPI machine' +'NEP.out' output file name (if any) +6 device out +7 number of problems sizes +2 3 0 4 6 10 50 -1 Probs +3 number of NB's +6 8 17 values of NB +2 number of process grids (ordered pairs of P & Q) +1 2 1 1 4 2 1 values of P +1 2 3 4 1 4 8 values of Q +20.0 threshold diff --git a/TESTING/EXT_TESTS/QR.dat b/TESTING/EXT_TESTS/QR.dat new file mode 100644 index 00000000..58f66230 --- /dev/null +++ b/TESTING/EXT_TESTS/QR.dat @@ -0,0 +1,16 @@ +'ScaLAPACK, Orthogonal factorizations input file' +'MPI machine' +'QR.out' output file name (if any) +6 device out +6 number of factorizations +'QR' 'QL' 'LQ' 'RQ' 'QP' 'TZ' factorizations: QR, QL, LQ, RQ, QP, TZ +4 number of problems sizes +42 15 -3 26 30 15 values of M. The M value should be more than the MB, NB values. +42 0 18 25 30 35 values of N. The N value should be more than the MB, NB values. +4 number of blocking sizes +4 3 5 2 4 6 values of MB +4 2 3 4 8 2 values of NB +4 number of process grids (ordered pairs P & Q) +1 2 1 4 2 3 8 values of P +1 2 4 1 3 2 1 values of Q +5.0 threshold diff --git a/TESTING/EXT_TESTS/SEP.dat b/TESTING/EXT_TESTS/SEP.dat new file mode 100644 index 00000000..cbc245b1 --- /dev/null +++ b/TESTING/EXT_TESTS/SEP.dat @@ -0,0 +1,146 @@ + + +'ScaLAPACK Symmetric Eigensolver Test File' +' ' +'sep.out' output file name (if any) +6 device out (13 & 14 reserved for internal testing) +4 maximum number of processes +'N' disable pxsyev tests, recommended for heterogeneous systems. +' ' +'TEST 1 - test tiny matrices - different process configurations' +3 number of matrices +0 1 2 matrix size +1 number of uplo choices +'L' uplo choices +2 number of processor configurations (P, Q, NB) +1 1 values of P (NPROW) +2 1 values of Q (NPCOL) +1 1 values of NB +1 number of matrix types +8 matrix types (see pdseptst.f) +'N' perform subset tests? +80.0 Threshold (* 5 for generalized tests) +-1 Absolute Tolerance +' ' +'TEST 2 - test tiny matrices - all requests' +2 number of matrices +0 1 +1 number of uplo choices +'L' uplo choices +1 number of processor configurations (P, Q, NB) +1 values of P (NPROW) +2 values of Q (NPCOL) +1 values of NB +1 number of matrix types +8 matrix types (see pdseptst.f) +'Y' perform subset tests? +80.0 Threshold (* 5 for generalized tests) +-1 Absolute Tolerance +' ' +'TEST 3 - test a small matrix - all types' +1 number of matrices +5 +1 number of uplo choices +'L' uplo choices +2 number of processor configurations (P, Q, NB) +1 1 values of P (NPROW) +1 2 values of Q (NPCOL) +1 2 values of NB +22 number of matrix types +1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 +'N' perform subset tests? +250.0 Threshold +-1 Absolute Tolerance +' ' +'TEST 4 - test a small matrix - all requests' +1 number of matrices +4 +1 number of uplo choices +'L' uplo choices +2 number of processor configurations (P, Q, NB) +1 1 values of P (NPROW) +1 2 values of Q (NPCOL) +1 2 values of NB +2 number of matrix types +10 22 matrix types +'Y' perform subset tests? +250.0 Threshold +-1 Absolute Tolerance +' ' +'TEST 5 - test a small matrix - all processor configurations' +1 number of matrices +6 matrix size +2 number of uplo choices +'L' 'U' uplo choices +13 number of processor configurations (P, Q, NB) +1 1 2 1 2 1 3 1 3 1 2 2 2 values of P (NPROW) +1 1 1 2 1 2 1 3 1 3 2 2 2 values of Q (NPCOL) +1 3 1 1 2 2 1 1 2 2 1 2 3 values of NB +1 number of matrix types +8 matrix types (see pdseptst.f) +'N' perform subset tests? +50.0 Threshold (* 5 for generalized tests) +-1 Absolute Tolerance +' ' +'TEST 6 - test a medium matrix - hard matrix types' +1 number of matrices +21 +1 number of uplo choices +'U' uplo choices +1 number of processor configurations (P, Q, NB) +2 values of P (NPROW) +2 values of Q (NPCOL) +8 values of NB +4 number of matrix types +9 10 21 22 +'N' perform subset tests? +50.0 Threshold (* 5 for generalized tests) +-1 Absolute Tolerance +' ' +'TEST 7 - test a medium matrix - all processor configurations' +1 number of matrices +27 +1 number of uplo choices +'U' uplo choices +13 number of processor configurations (P, Q, NB) +1 1 2 1 2 1 3 1 3 1 2 2 2 values of P (NPROW) +1 1 1 2 1 2 1 3 1 3 2 2 2 values of Q (NPCOL) +1 3 1 1 2 2 1 1 2 2 1 2 3 values of NB +1 number of matrix types +10 matrix types (see pdseptst.f) +'N' perform subset tests? +50.0 Threshold (* 5 for generalized tests) +-1 Absolute Tolerance +' ' +'TEST 8 - test a medium matrix - L and U' +1 number of matrices +24 +2 number of uplo choices +'L' 'U' uplo choices +4 number of processor configurations (P, Q, NB) +1 1 3 1 values of P (NPROW) +1 2 1 4 values of Q (NPCOL) +1 3 1 1 values of NB +1 number of matrix types +22 matrix types (see pdseptst.f) +'N' perform subset tests? +20.0 Threshold (* 5 for generalized tests) +-1 Absolute Tolerance +' ' +'TEST 9 - test one large matrix' +1 number of matrices +100 +1 number of uplo choices +'U' uplo choices +1 number of processor configurations (P, Q, NB) +2 values of P (NPROW) +2 values of Q (NPCOL) +8 values of NB +1 number of matrix types +8 matrix types (see pdseptst.f) +'N' perform subset tests? +20.0 Threshold (* 5 for generalized tests) +-1 Absolute Tolerance +' ' +'End of tests' +-1 diff --git a/TESTING/EXT_TESTS/SEPR.dat b/TESTING/EXT_TESTS/SEPR.dat new file mode 100644 index 00000000..eb69a711 --- /dev/null +++ b/TESTING/EXT_TESTS/SEPR.dat @@ -0,0 +1,26 @@ + + +'ScaLAPACK Symmetric Eigensolver Test File' +' ' +'sepr.out' output file name (if any) +6 device out (13 & 14 reserved for internal testing) +4 maximum number of processes +'Y' Switch set to 'Y' +' ' +'TEST 1 - negative and zero matrix sizes - different process configurations' +3 number of matrices +-1 0 2 Matrix sizes +1 number of uplo choices +'L' uplo choices +1 number of processor configurations (P, Q, NB) +1 values of P (NPROW) +2 values of Q (NPCOL) +1 values of NB +1 number of matrix types +8 matrix types (see pdseprtst.f) +'N' perform subset tests? +80.0 Threshold (* 5 for generalized tests) +-1 Absolute Tolerance +' ' +'End of tests' +-1 diff --git a/TESTING/EXT_TESTS/SVD.dat b/TESTING/EXT_TESTS/SVD.dat new file mode 100644 index 00000000..4712b0fd --- /dev/null +++ b/TESTING/EXT_TESTS/SVD.dat @@ -0,0 +1,36 @@ +'ScaLAPACK Singular Value Decomposition input file' +6 device out +4 maxnodes +' ' +'TEST 1 - test medium matrices - all types and requests' +20.0 Threshold +1 number of matrices +10 number of rows +0 number of columns +1 number of processor configurations (P, Q, NB) +2 values of P (NPROW) +2 values of Q (NPCOL) +8 values of NB +' ' +'TEST 2 - test medium matrices - all processor configurations' +20.0 Threshold +1 number of matrices +0 number of rows +32 number of columns +1 number of processor configurations (P, Q, NB) +2 values of P (NPROW) +2 values of Q (NPCOL) +8 values of NB +' ' +'TEST 3 - test one large matrix' +15.0 Threshold +1 number of matrices +-4 number of rows +8 number of columns +1 number of processor configurations (P, Q, NB) +2 values of P (NPROW) +2 values of Q (NPCOL) +8 values of NB +' ' +'End of tests' +-1 diff --git a/TESTING/EXT_TESTS/TRD.dat b/TESTING/EXT_TESTS/TRD.dat new file mode 100644 index 00000000..757eb789 --- /dev/null +++ b/TESTING/EXT_TESTS/TRD.dat @@ -0,0 +1,13 @@ +'ScaLAPACK TRD computation input file' +'MPI machine' +'TRD.out' output file name +6 device out +'L' define Lower or Upper +4 number of problems sizes +16 50 6 11 21 22 23 values of N +4 number of NB's +1 2 3 4 5 values of NB +3 Number of processor grids (ordered pairs of P & Q) +1 1 4 2 1 3 1 values of P +1 4 1 2 3 1 1 values of Q +10.0 threshold diff --git a/TESTING/INV.dat b/TESTING/INV.dat index ac33d0e6..b1275711 100644 --- a/TESTING/INV.dat +++ b/TESTING/INV.dat @@ -1,4 +1,4 @@ -'ScaLAPACK, Version 1.0, Matrix Inversion Testing input file' +'AOCLScaLAPACK, Matrix Inversion Testing input file' 'MPI machine.' 'INV.out' output file name (if any) 6 device out diff --git a/TESTING/LIN/pcdbdriver.f b/TESTING/LIN/pcdbdriver.f index 168d634f..428096bb 100644 --- a/TESTING/LIN/pcdbdriver.f +++ b/TESTING/LIN/pcdbdriver.f @@ -6,6 +6,8 @@ PROGRAM PCDBDRIVER * and University of California, Berkeley. * November 15, 1997 * +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. +* * Purpose * ======= * @@ -70,6 +72,7 @@ PROGRAM PCDBDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER TOTMEM #ifndef DYNAMIC_WORK_MEM_ALLOC @@ -145,6 +148,14 @@ PROGRAM PCDBDRIVER DATA KFAIL, KPASS, KSKIP, KTESTS / 4*0 / * .. * +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X * * * .. Executable Statements .. @@ -162,8 +173,37 @@ PROGRAM PCDBDRIVER $ BWLVAL, BWUVAL, NTESTS, NNB, NBVAL, NTESTS, NNR, $ NRVAL, NTESTS, NNBR, NBRVAL, NTESTS, NGRIDS, PVAL, $ NTESTS, QVAL, NTESTS, THRESH, MEM, IAM, NPROCS ) +* * CHECK = ( THRESH.GE.0.0E+0 ) +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do * * Print headings * @@ -183,6 +223,7 @@ PROGRAM PCDBDRIVER * * Make sure grid information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR( 1 ) = 0 IF( NPROW.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -204,6 +245,7 @@ PROGRAM PCDBDRIVER KSKIP = KSKIP + 1 GO TO 50 END IF +#endif * * Define process grid * @@ -233,23 +275,28 @@ PROGRAM PCDBDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'size' KSKIP = KSKIP + 1 GO TO 40 END IF +#endif * * DO 45 BW_NUM = 1, NBW @@ -287,10 +334,12 @@ PROGRAM PCDBDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 45 END IF +#endif * DO 30 K = 1, NNB * @@ -303,6 +352,10 @@ PROGRAM PCDBDRIVER NB = MAX( NB, 2*MAX(BWL,BWU) ) NB = MIN( N, NB ) END IF +* Altering the auto-assign for early return of N case + IF (N .EQ. 0 .AND. NB.EQ.0) THEN + NB = 1 + END IF * * Make sure NB is legal * @@ -316,10 +369,13 @@ PROGRAM PCDBDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 30 END IF +#endif * * Padding constants * @@ -361,12 +417,42 @@ PROGRAM PCDBDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -3 .OR. + $ IERR(1) .EQ. -6 .OR. IERR(1) .EQ. -9 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -12 )) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid M and N +* -4, -6 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9983 ) 'N' +* disable extreme value case when N < 0 + EX_FLAG = .FALSE. + ELSE IF(N .EQ. 0 .AND. (IERR(1) .EQ. 0 .OR. + $ IERR(1) .EQ. -5 .OR. IERR(1) .EQ. -10 .OR. + $ IERR(1) .EQ. -15 .OR. IERR(1) .EQ. -20 )) THEN +* DESCINIT returns the correct error code, +* When N = 0, IERR(1) could be return +* -5, -10 or -20 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING +* disable extreme value case when N = 0 + EX_FLAG = .FALSE. + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -483,17 +569,19 @@ PROGRAM PCDBDRIVER $ ((BWL+BWU+1)+10), 0, 0, IASEED, MYROW, $ MYCOL, NPROW, NPCOL ) * - CALL PCFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), + IF(N .GE. 0) THEN + CALL PCFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), $ ((BWL+BWU+1)+10), IPREPAD, IPOSTPAD, $ PADVAL ) * - CALL PCFILLPAD( ICTXT, WORKSIZ, 1, + CALL PCFILLPAD( ICTXT, WORKSIZ, 1, $ MEM( IP_DRIVER_W-IPREPAD ), WORKSIZ, $ IPREPAD, IPOSTPAD, PADVAL ) + END IF * * Calculate norm of A for residual error-checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0) THEN * ANORM = PCLANGE( '1', (BWL+BWU+1), $ N, MEM( IPA ), 1, 1, @@ -522,14 +610,25 @@ PROGRAM PCDBDRIVER CALL SLTIMER( 1 ) * IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) THEN - WRITE( NOUT, FMT = * ) 'PCDBTRF INFO=', INFO - ENDIF - KFAIL = KFAIL + 1 - GO TO 30 + IF(N .LT. 0 .AND. (INFO .EQ. -1 .OR. + $ INFO .EQ. -604 )) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PDDBTRF INFO=', INFO +* When N = 0, make BWL and BWU = 0 for early return + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -3) THEN +* expected error code, when bandwidth is incorrect +* pass this case to solve API + WRITE( NOUT, FMT = * ) 'PCDBTRF INFO=', INFO + ELSE + IF( IAM.EQ.0 ) THEN + WRITE( NOUT, FMT = * ) 'PCDBTRF INFO=', INFO + ENDIF + KFAIL = KFAIL + 1 + GO TO 30 + END IF END IF * - IF( CHECK ) THEN + IF( CHECK .AND. INFO .EQ. 0 ) THEN * * Check for memory overwrite in factorization * @@ -640,14 +739,23 @@ PROGRAM PCDBDRIVER CALL SLTIMER( 2 ) * IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) - $ WRITE( NOUT, FMT = * ) 'PCDBTRS INFO=', INFO - KFAIL = KFAIL + 1 - PASSED = 'FAILED' - GO TO 20 + IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804)) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PCDBTRS INFO=', INFO + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -4) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PCDBTRS INFO=', INFO + ELSE + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = * ) 'PCDBTRS INFO=', INFO + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + GO TO 20 + END IF END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN * * check for memory overwrite * @@ -661,12 +769,14 @@ PROGRAM PCDBDRIVER * SRESID = ZERO * - CALL PCDBLASCHK( 'N', 'D', TRANS, + IF(INFO .EQ. 0) THEN + CALL PCDBLASCHK( 'N', 'D', TRANS, $ N, BWL, BWU, NRHS, $ MEM( IPB ), 1, 1, DESCB2D, $ IASEED, MEM( IPA ), 1, 1, DESCA2D, $ IBSEED, ANORM, SRESID, $ MEM( IP_DRIVER_W ), WORKSIZ ) + END IF * IF( IAM.EQ.0 ) THEN IF( SRESID.GT.THRESH ) @@ -675,7 +785,23 @@ PROGRAM PCDBDRIVER * * The second test is a NaN trap * - IF( ( SRESID.LE.THRESH ).AND. + IF( N .EQ. 0 .AND. (INFO .EQ. -4 .OR. + $ INFO .EQ. 0)) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9984 ) 'PCDBTRS' + PASSED = 'PASSED' + ELSE IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804 )) THEN +* When N < 0/Invalid, PDDBTRS INFO = -1 +* Expected Error code for N < 0 +* Hence this case can be passed + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9982 ) 'PCDBTRS' + PASSED = 'PASSED' + ELSE IF( ( SRESID.LE.THRESH ).AND. $ ( (SRESID-SRESID).EQ.0.0E+0 ) ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' @@ -683,6 +809,35 @@ PROGRAM PCDBDRIVER KFAIL = KFAIL + 1 PASSED = 'FAILED' END IF + ELSE IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, N-1 + DO JK = 1, N + X = (MEM(IK*N + JK)) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite(X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF * END IF * @@ -932,6 +1087,13 @@ PROGRAM PCDBDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - ', A4, '|| / (||A|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Ax-b||/(||x||*||A||*eps*N) ', F25.7 ) + 9984 FORMAT( '----------Test Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9983 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9982 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') * STOP * diff --git a/TESTING/LIN/pcdtdriver.f b/TESTING/LIN/pcdtdriver.f index 80d3ee65..291a3685 100644 --- a/TESTING/LIN/pcdtdriver.f +++ b/TESTING/LIN/pcdtdriver.f @@ -6,6 +6,8 @@ PROGRAM PCDTDRIVER * and University of California, Berkeley. * November 15, 1997 * +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. +* * Purpose * ======= * @@ -70,6 +72,7 @@ PROGRAM PCDTDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER TOTMEM #ifndef DYNAMIC_WORK_MEM_ALLOC @@ -144,6 +147,14 @@ PROGRAM PCDTDRIVER DATA KFAIL, KPASS, KSKIP, KTESTS / 4*0 / * .. * +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X * * * .. Executable Statements .. @@ -163,6 +174,33 @@ PROGRAM PCDTDRIVER $ NTESTS, QVAL, NTESTS, THRESH, MEM, IAM, NPROCS ) * CHECK = ( THRESH.GE.0.0E+0 ) + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do * * Print headings * @@ -182,6 +220,7 @@ PROGRAM PCDTDRIVER * * Make sure grid information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR( 1 ) = 0 IF( NPROW.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -203,6 +242,7 @@ PROGRAM PCDTDRIVER KSKIP = KSKIP + 1 GO TO 50 END IF +#endif * * Define process grid * @@ -232,23 +272,28 @@ PROGRAM PCDTDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'size' KSKIP = KSKIP + 1 GO TO 40 END IF +#endif * * DO 45 BW_NUM = 1, NBW @@ -286,10 +331,12 @@ PROGRAM PCDTDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 45 END IF +#endif * DO 30 K = 1, NNB * @@ -302,6 +349,10 @@ PROGRAM PCDTDRIVER NB = MAX( NB, 2*INT_ONE ) NB = MIN( N, NB ) END IF +* Altering the auto-assign for early return of N case + IF (N .EQ. 0 .AND. NB.EQ.0) THEN + NB = 1 + END IF * * Make sure NB is legal * @@ -315,10 +366,13 @@ PROGRAM PCDTDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 30 END IF +#endif * * Padding constants * @@ -360,12 +414,43 @@ PROGRAM PCDTDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -3 .OR. + $ IERR(1) .EQ. -6 .OR. IERR(1) .EQ. -9 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -12 .OR. + $ IERR(1) .EQ. -2 .OR. IERR(1) .EQ. -8) ) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid M and N +* -4, -6 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9983 ) 'N' +* disable extreme value case when N < 0 + EX_FLAG = .FALSE. + ELSE IF(N .EQ. 0 .AND. (IERR(1) .EQ. 0 .OR. + $ IERR(1) .EQ. -5 .OR. IERR(1) .EQ. -10 .OR. + $ IERR(1) .EQ. -15 .OR. IERR(1) .EQ. -20 )) THEN +* DESCINIT returns the correct error code, +* When N = 0, +* -5, -10 or -20 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING +* disable extreme value case when N = 0 + EX_FLAG = .FALSE. + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -479,17 +564,20 @@ PROGRAM PCDTDRIVER CALL PCBMATGEN( ICTXT, 'T', 'D', BWL, BWU, N, (3), NB, $ MEM( IPA ), NB+10, 0, 0, IASEED, MYROW, $ MYCOL, NPROW, NPCOL ) - CALL PCFILLPAD( ICTXT, NQ, NP, MEM( IPA-IPREPAD ), + + IF(N .GE. 0) THEN + CALL PCFILLPAD( ICTXT, NQ, NP, MEM( IPA-IPREPAD ), $ NB+10, IPREPAD, IPOSTPAD, $ PADVAL ) * - CALL PCFILLPAD( ICTXT, WORKSIZ, 1, + CALL PCFILLPAD( ICTXT, WORKSIZ, 1, $ MEM( IP_DRIVER_W-IPREPAD ), WORKSIZ, $ IPREPAD, IPOSTPAD, PADVAL ) + END IF * * Calculate norm of A for residual error-checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * ANORM = PCLANGE( 'I', N, $ (3), MEM( IPA ), 1, 1, @@ -519,14 +607,25 @@ PROGRAM PCDTDRIVER CALL SLTIMER( 1 ) * IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) THEN - WRITE( NOUT, FMT = * ) 'PCDTTRF INFO=', INFO - ENDIF - KFAIL = KFAIL + 1 - GO TO 30 + IF(N .LT. 0 .AND. (INFO .EQ. -1 .OR. + $ INFO .EQ. -604 )) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PDDTTRF INFO=', INFO +* When N = 0, make BWL and BWU = 0 for early return + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -3) THEN +* expected error code, when bandwidth is > 0 +* pass this case to solve API + WRITE( NOUT, FMT = * ) 'PCDTTRF INFO=', INFO + ELSE + IF( IAM.EQ.0 ) THEN + WRITE( NOUT, FMT = * ) 'PCDTTRF INFO=', INFO + ENDIF + KFAIL = KFAIL + 1 + GO TO 30 + END IF END IF * - IF( CHECK ) THEN + IF( CHECK .AND. INFO .EQ. 0 ) THEN * * Check for memory overwrite in factorization * @@ -639,14 +738,23 @@ PROGRAM PCDTDRIVER CALL SLTIMER( 2 ) * IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) - $ WRITE( NOUT, FMT = * ) 'PCDTTRS INFO=', INFO - KFAIL = KFAIL + 1 - PASSED = 'FAILED' - GO TO 20 + IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804)) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PDDTTRS INFO=', INFO + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -4) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PCDTTRS INFO=', INFO + ELSE + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = * ) 'PCDTTRS INFO=', INFO + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + GO TO 20 + END IF END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN * * check for memory overwrite * @@ -666,12 +774,14 @@ PROGRAM PCDTDRIVER CALL DESCINIT( DESCA2D, (3), N, $ (3), NB, 0, 0, $ ICTXT, (3), IERR( 1 ) ) - CALL PCDTLASCHK( 'N', 'D', TRANS, + IF(INFO .EQ. 0) THEN + CALL PCDTLASCHK( 'N', 'D', TRANS, $ N, BWL, BWU, NRHS, $ MEM( IPB ), 1, 1, DESCB2D, $ IASEED, MEM( IPA ), 1, 1, DESCA2D, $ IBSEED, ANORM, SRESID, $ MEM( IP_DRIVER_W ), WORKSIZ ) + END IF * IF( IAM.EQ.0 ) THEN IF( SRESID.GT.THRESH ) @@ -680,7 +790,33 @@ PROGRAM PCDTDRIVER * * The second test is a NaN trap * - IF( ( SRESID.LE.THRESH ).AND. + IF( N .EQ. 0 .AND. (INFO .EQ. -4 .OR. + $ INFO .EQ. 0)) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9984 ) 'PCDTTRS' + PASSED = 'PASSED' +* Re-enable EX_FLAG + IF(NAN_PERCENT .GT. 0 .OR. + $ INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + ELSE IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804 )) THEN +* When N < 0/Invalid, PCDTTRS INFO = -1 +* Expected Error code for N < 0 +* Hence this case can be passed + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9982 ) 'PCDTTRS' + PASSED = 'PASSED' +* Re-enable EX_FLAG + IF(NAN_PERCENT .GT. 0 .OR. + $ INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + ELSE IF( ( SRESID.LE.THRESH ).AND. $ ( (SRESID-SRESID).EQ.0.0E+0 ) ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' @@ -688,6 +824,37 @@ PROGRAM PCDTDRIVER KFAIL = KFAIL + 1 PASSED = 'FAILED' END IF +* Extreme-value validation block + ELSE IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, N-1 + DO JK = 1, N + X = (MEM(IK*N + JK)) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF * END IF * @@ -937,6 +1104,13 @@ PROGRAM PCDTDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - ', A4, '|| / (||A|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Ax-b||/(||x||*||A||*eps*N) ', F25.7 ) + 9984 FORMAT( '----------Test Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9983 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9982 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') * STOP * diff --git a/TESTING/LIN/pcgbdriver.f b/TESTING/LIN/pcgbdriver.f index aba51f37..4ddadf50 100644 --- a/TESTING/LIN/pcgbdriver.f +++ b/TESTING/LIN/pcgbdriver.f @@ -6,6 +6,8 @@ PROGRAM PCGBDRIVER * and University of California, Berkeley. * November 15, 1997 * +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. +* * Purpose * ======= * @@ -76,6 +78,7 @@ PROGRAM PCGBDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER TOTMEM, INTMEM #ifndef DYNAMIC_WORK_MEM_ALLOC @@ -152,6 +155,14 @@ PROGRAM PCGBDRIVER DATA KFAIL, KPASS, KSKIP, KTESTS / 4*0 / * .. * +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X * * * .. Executable Statements .. @@ -172,6 +183,35 @@ PROGRAM PCGBDRIVER * CHECK = ( THRESH.GE.0.0E+0 ) * +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* * Print headings * IF( IAM.EQ.0 ) THEN @@ -190,6 +230,7 @@ PROGRAM PCGBDRIVER * * Make sure grid information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR( 1 ) = 0 IF( NPROW.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -211,6 +252,7 @@ PROGRAM PCGBDRIVER KSKIP = KSKIP + 1 GO TO 50 END IF +#endif * * Define process grid * @@ -240,23 +282,28 @@ PROGRAM PCGBDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'size' KSKIP = KSKIP + 1 GO TO 40 END IF +#endif * * DO 45 BW_NUM = 1, NBW @@ -294,10 +341,12 @@ PROGRAM PCGBDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 45 END IF +#endif * DO 30 K = 1, NNB * @@ -310,6 +359,10 @@ PROGRAM PCGBDRIVER NB = MAX( NB, 2*(BWL+BWU) ) NB = MIN( N, NB ) END IF +* Altering the auto-assign for early return of N case + IF (N .EQ. 0 .AND. NB.EQ.0) THEN + NB = 1 + END IF * * Make sure NB is legal * @@ -330,10 +383,13 @@ PROGRAM PCGBDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 30 END IF +#endif * * Padding constants * @@ -375,12 +431,43 @@ PROGRAM PCGBDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -3 .OR. + $ IERR(1) .EQ. -6 .OR. IERR(1) .EQ. -9 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -12 .OR. + $ IERR(1) .EQ. -2 .OR. IERR(1) .EQ. -8) ) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid M and N +* -4, -6 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9983 ) 'N' +* disable extreme value case when N < 0 + EX_FLAG = .FALSE. + ELSE IF(N .EQ. 0 .AND. (IERR(1) .EQ. 0 .OR. + $ IERR(1) .EQ. -5 .OR. IERR(1) .EQ. -10 .OR. + $ IERR(1) .EQ. -15 .OR. IERR(1) .EQ. -20 )) THEN +* DESCINIT returns the correct error code, +* When N = 0, +* -5, -10 or -20 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING +* disable extreme value case when N = 0 + EX_FLAG = .FALSE. + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -497,17 +584,20 @@ PROGRAM PCGBDRIVER $ ((2*BWL+2*BWU+1)+10), 0, 0, IASEED, $ MYROW, MYCOL, NPROW, NPCOL ) * - CALL PCFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), + + IF(N .GE. 0) THEN + CALL PCFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), $ ((2*BWL+2*BWU+1)+10), IPREPAD, IPOSTPAD, $ PADVAL ) * - CALL PCFILLPAD( ICTXT, WORKSIZ, 1, + CALL PCFILLPAD( ICTXT, WORKSIZ, 1, $ MEM( IP_DRIVER_W-IPREPAD ), WORKSIZ, $ IPREPAD, IPOSTPAD, PADVAL ) + END IF * * Calculate norm of A for residual error-checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * ANORM = PCLANGE( '1', (2*BWL+2*BWU+1), $ N, MEM( IPA ), 1, 1, @@ -535,15 +625,26 @@ PROGRAM PCGBDRIVER * CALL SLTIMER( 1 ) * - IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) THEN - WRITE( NOUT, FMT = * ) 'PCGBTRF INFO=', INFO - ENDIF - KFAIL = KFAIL + 1 - GO TO 30 + IF( INFO.NE.0 .AND. .NOT.(EX_FLAG)) THEN + IF(N .LT. 0 .AND. (INFO .EQ. -1 .OR. + $ INFO .EQ. -604 )) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PCGBTRF INFO=', INFO +* When N = 0, make BWL and BWU = 0 for early return + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -3) THEN +* expected error code, when bandwidth is > 0 +* pass this case to solve API + WRITE( NOUT, FMT = * ) 'PCGBTRF INFO=', INFO + ELSE + IF( IAM.EQ.0 ) THEN + WRITE( NOUT, FMT = * ) 'PCGBTRF INFO=', INFO + ENDIF + KFAIL = KFAIL + 1 + GO TO 30 + END IF END IF * - IF( CHECK ) THEN + IF( CHECK .AND. INFO .EQ. 0 ) THEN * * Check for memory overwrite in factorization * @@ -653,15 +754,24 @@ PROGRAM PCGBDRIVER * CALL SLTIMER( 2 ) * - IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) - $ WRITE( NOUT, FMT = * ) 'PCGBTRS INFO=', INFO - KFAIL = KFAIL + 1 - PASSED = 'FAILED' - GO TO 20 + IF( INFO.NE.0 .AND. .NOT.(EX_FLAG) ) THEN + IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804)) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PCGBTRS INFO=', INFO + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -4) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PCGBTRS INFO=', INFO + ELSE + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = * ) 'PCGBTRS INFO=', INFO + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + GO TO 20 + END IF END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN * * check for memory overwrite * @@ -675,12 +785,14 @@ PROGRAM PCGBDRIVER * SRESID = ZERO * - CALL PCDBLASCHK( 'N', 'N', TRANS, + IF(INFO .EQ. 0) THEN + CALL PCDBLASCHK( 'N', 'N', TRANS, $ N, BWL, BWU, NRHS, $ MEM( IPB ), 1, 1, DESCB2D, $ IASEED, MEM( IPA+BWL+BWU ), 1, 1, DESCA2D, $ IBSEED, ANORM, SRESID, $ MEM( IP_DRIVER_W ), WORKSIZ ) + END IF * IF( IAM.EQ.0 ) THEN IF( SRESID.GT.THRESH ) @@ -689,7 +801,33 @@ PROGRAM PCGBDRIVER * * The second test is a NaN trap * - IF( ( SRESID.LE.THRESH ).AND. + IF( N .EQ. 0 .AND. (INFO .EQ. -4 .OR. + $ INFO .EQ. 0)) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9984 ) 'PCDTTRS' + PASSED = 'PASSED' +* Re-enable EX_FLAG + IF(NAN_PERCENT .GT. 0 .OR. + $ INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + ELSE IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804 )) THEN +* When N < 0/Invalid, PCDTTRS INFO = -1 +* Expected Error code for N < 0 +* Hence this case can be passed + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9982 ) 'PCDTTRS' + PASSED = 'PASSED' +* Re-enable EX_FLAG + IF(NAN_PERCENT .GT. 0 .OR. + $ INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + ELSE IF( ( SRESID.LE.THRESH ).AND. $ ( (SRESID-SRESID).EQ.0.0E+0 ) ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' @@ -697,6 +835,37 @@ PROGRAM PCGBDRIVER KFAIL = KFAIL + 1 PASSED = 'FAILED' END IF +* Extreme-value validation block + ELSE IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, N-1 + DO JK = 1, N + X = (MEM(IK*N + JK)) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF * END IF * @@ -946,6 +1115,13 @@ PROGRAM PCGBDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - ', A4, '|| / (||A|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Ax-b||/(||x||*||A||*eps*N) ', F25.7 ) + 9984 FORMAT( '----------Test Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9983 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9982 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') * STOP * diff --git a/TESTING/LIN/pcinvdriver.f b/TESTING/LIN/pcinvdriver.f index 12b99f32..7a630662 100644 --- a/TESTING/LIN/pcinvdriver.f +++ b/TESTING/LIN/pcinvdriver.f @@ -1,868 +1,1040 @@ - PROGRAM PCINVDRIVER -* -* -- ScaLAPACK testing driver (version 1.7) -- -* University of Tennessee, Knoxville, Oak Ridge National Laboratory, -* and University of California, Berkeley. -* May 1, 1997 -* -* Purpose -* ======= -* -* PCINVDRIVER is the main test program for the COMPLEX -* SCALAPACK matrix inversion routines. This test driver computes the -* inverse of different kind of matrix and tests the results. -* -* The program must be driven by a short data file. An annotated example -* of a data file can be obtained by deleting the first 3 characters -* from the following 14 lines: -* 'ScaLAPACK Matrix Inversion Testing input file' -* 'PVM machine.' -* 'INV.out' output file name (if any) -* 6 device out -* 5 number of matrix types (next line) -* 'GEN' 'UTR' 'LTR' 'UPD' LPD' GEN, UTR, LTR, UPD, LPD -* 4 number of problems sizes -* 1000 2000 3000 4000 values of N -* 3 number of NB's -* 4 30 35 values of NB -* 2 number of process grids (ordered P & Q) -* 4 2 values of P -* 4 4 values of Q -* 1.0 threshold -* -* Internal Parameters -* =================== -* -* TOTMEM INTEGER, default = 2000000 -* TOTMEM is a machine-specific parameter indicating the -* maximum amount of available memory in bytes. -* The user should customize TOTMEM to his platform. Remember -* to leave room in memory for the operating system, the BLACS -* buffer, etc. For example, on a system with 8 MB of memory -* per process (e.g., one processor on an Intel iPSC/860), the -* parameters we use are TOTMEM=6200000 (leaving 1.8 MB for OS, -* code, BLACS buffer, etc). However, for PVM, we usually set -* TOTMEM = 2000000. Some experimenting with the maximum value -* of TOTMEM may be required. -* -* INTGSZ INTEGER, default = 4 bytes. -* REALSZ INTEGER, default = 4 bytes. -* CPLXSZ INTEGER, default = 8 bytes. -* INTGSZ, REALSZ and CPLXSZ indicate the length in bytes on -* the given platform for an integer, a single precision real -* and a single precision complex. -* MEM COMPLEX array, dimension ( TOTMEM / CPLXSZ ) -* -* All arrays used by SCALAPACK routines are allocated from -* this array and referenced by pointers. The integer IPA, -* for example, is a pointer to the starting element of MEM for -* the matrix A. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, - $ LLD_, MB_, M_, NB_, N_, RSRC_ - PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1, - $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6, - $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 ) - - INTEGER CPLXSZ, INTGSZ, MEMSIZ, NTESTS, REALSZ, TOTMEM -#ifndef DYNAMIC_WORK_MEM_ALLOC - PARAMETER ( TOTMEM = 2000000 ) -#else - PARAMETER ( TOTMEM = 2100000000 ) -#endif - COMPLEX PADVAL, ZERO -#ifdef ENABLE_ILP64 - PARAMETER ( INTGSZ = 8 ) -#else - PARAMETER ( INTGSZ = 4 ) -#endif - PARAMETER ( CPLXSZ = 8, REALSZ = 4, - $ MEMSIZ = TOTMEM / CPLXSZ, - $ NTESTS = 20, - $ PADVAL = ( -9923.0E+0, -9923.0E+0 ), - $ ZERO = ( 0.0E+0, 0.0E+0 ) ) -* .. -* .. Local Scalars .. - CHARACTER UPLO - CHARACTER*3 MTYP - CHARACTER*6 PASSED - CHARACTER*80 OUTFILE - LOGICAL CHECK - INTEGER I, IAM, IASEED, ICTXT, IMIDPAD, INFO, IPA, - $ IPPIV, IPREPAD, IPOSTPAD, IPIW, IPW, ITEMP, J, - $ K, KTESTS, KPASS, KFAIL, KSKIP, L, LCM, LIPIV, - $ LIWORK, LWORK, MYCOL, MYROW, N, NB, NGRIDS, - $ NMAT, NMTYP, NNB, NOUT, NP, NPCOL, NPROCS, - $ NPROW, NQ, WORKIINV, WORKINV, WORKSIZ - REAL ANORM, FRESID, RCOND, THRESH - DOUBLE PRECISION NOPS, TMFLOPS -* .. -* .. Local Arrays .. - CHARACTER*3 MATTYP( NTESTS ) - INTEGER DESCA( DLEN_ ), IERR( 1 ), NBVAL( NTESTS ), - $ NVAL( NTESTS ), PVAL( NTESTS ), - $ QVAL( NTESTS ) - DOUBLE PRECISION CTIME( 2 ), WTIME( 2 ) -#ifndef DYNAMIC_WORK_MEM_ALLOC - COMPLEX MEM( MEMSIZ ) -#else - COMPLEX, allocatable :: MEM (:) -#endif - -* .. -* .. External Subroutines .. - EXTERNAL BLACS_BARRIER, BLACS_EXIT, BLACS_GET, - $ BLACS_GRIDEXIT, BLACS_GRIDINFO, BLACS_GRIDINIT, - $ BLACS_PINFO, DESCINIT, IGSUM2D, PCCHEKPAD, - $ PCFILLPAD, PCGETRF, PCGETRI, - $ PCINVCHK, PCINVINFO, PCLASET, - $ PCMATGEN, PCPOTRF, PCPOTRI, - $ PCTRTRI, SLBOOT, SLCOMBINE, SLTIMER -* .. -* .. External Functions .. - LOGICAL LSAMEN - INTEGER ICEIL, ILCM, NUMROC - REAL PCLANGE, PCLANHE, PCLANSY, PCLANTR - EXTERNAL ICEIL, ILCM, LSAMEN, NUMROC, PCLANGE, - $ PCLANHE, PCLANSY, PCLANTR -* .. -* .. Intrinsic Functions .. - INTRINSIC DBLE, MAX -* .. -* .. Data Statements .. - DATA KTESTS, KPASS, KFAIL, KSKIP /4*0/ -* .. -* .. Executable Statements .. -* -* Get starting information -* -#ifdef DYNAMIC_WORK_MEM_ALLOC - allocate(MEM(MEMSIZ)) -#endif - CALL BLACS_PINFO( IAM, NPROCS ) - IASEED = 100 - CALL PCINVINFO( OUTFILE, NOUT, NMTYP, MATTYP, NTESTS, NMAT, NVAL, - $ NTESTS, NNB, NBVAL, NTESTS, NGRIDS, PVAL, NTESTS, - $ QVAL, NTESTS, THRESH, MEM, IAM, NPROCS ) - CHECK = ( THRESH.GE.0.0E+0 ) -* -* Loop over the different matrix types -* - DO 40 I = 1, NMTYP -* - MTYP = MATTYP( I ) -* -* Print headings -* - IF( IAM.EQ.0 ) THEN - WRITE( NOUT, FMT = * ) - IF( LSAMEN( 3, MTYP, 'GEN' ) ) THEN - WRITE( NOUT, FMT = 9986 ) - $ 'A is a general matrix.' - ELSE IF( LSAMEN( 3, MTYP, 'UTR' ) ) THEN - WRITE( NOUT, FMT = 9986 ) - $ 'A is an upper triangular matrix.' - ELSE IF( LSAMEN( 3, MTYP, 'LTR' ) ) THEN - WRITE( NOUT, FMT = 9986 ) - $ 'A is a lower triangular matrix.' - ELSE IF( LSAMEN( 3, MTYP, 'UPD' ) ) THEN - WRITE( NOUT, FMT = 9986 ) - $ 'A is a Hermitian positive definite matrix.' - WRITE( NOUT, FMT = 9986 ) - $ 'Only the upper triangular part will be '// - $ 'referenced.' - ELSE IF( LSAMEN( 3, MTYP, 'LPD' ) ) THEN - WRITE( NOUT, FMT = 9986 ) - $ 'A is a Hermitian positive definite matrix.' - WRITE( NOUT, FMT = 9986 ) - $ 'Only the lower triangular part will be '// - $ 'referenced.' - END IF - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9995 ) - WRITE( NOUT, FMT = 9994 ) - WRITE( NOUT, FMT = * ) - END IF -* -* Loop over different process grids -* - DO 30 J = 1, NGRIDS -* - NPROW = PVAL( J ) - NPCOL = QVAL( J ) -* -* Make sure grid information is correct -* - IERR( 1 ) = 0 - IF( NPROW.LT.1 ) THEN - IF( IAM.EQ.0 ) - $ WRITE( NOUT, FMT = 9999 ) 'GRID', 'nprow', NPROW - IERR( 1 ) = 1 - ELSE IF( NPCOL.LT.1 ) THEN - IF( IAM.EQ.0 ) - $ WRITE( NOUT, FMT = 9999 ) 'GRID', 'npcol', NPCOL - IERR( 1 ) = 1 - ELSE IF( NPROW*NPCOL.GT.NPROCS ) THEN - IF( IAM.EQ.0 ) - $ WRITE( NOUT, FMT = 9998 ) NPROW*NPCOL, NPROCS - IERR( 1 ) = 1 - END IF -* - IF( IERR( 1 ).GT.0 ) THEN - IF( IAM.EQ.0 ) - $ WRITE( NOUT, FMT = 9997 ) 'grid' - KSKIP = KSKIP + 1 - GO TO 30 - END IF -* -* Define process grid -* - CALL BLACS_GET( -1, 0, ICTXT ) - CALL BLACS_GRIDINIT( ICTXT, 'Row-major', NPROW, NPCOL ) - CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) -* -* Go to bottom of loop if this case doesn't use my process -* - IF( MYROW.GE.NPROW .OR. MYCOL.GE.NPCOL ) - $ GO TO 30 -* - DO 20 K = 1, NMAT -* - N = NVAL( K ) -* -* Make sure matrix information is correct -* - IERR( 1 ) = 0 - IF( N.LT.1 ) THEN - IF( IAM.EQ.0 ) - $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N - IERR( 1 ) = 1 - END IF -* -* Make sure no one had error -* - CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) -* - IF( IERR( 1 ).GT.0 ) THEN - IF( IAM.EQ.0 ) - $ WRITE( NOUT, FMT = 9997 ) 'matrix' - KSKIP = KSKIP + 1 - GO TO 20 - END IF -* -* Loop over different blocking sizes -* - DO 10 L = 1, NNB -* - NB = NBVAL( L ) -* -* Make sure nb is legal -* - IERR( 1 ) = 0 - IF( NB.LT.1 ) THEN - IERR( 1 ) = 1 - IF( IAM.EQ.0 ) - $ WRITE( NOUT, FMT = 9999 ) 'NB', 'NB', NB - END IF -* -* Check all processes for an error -* - CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, - $ 0 ) -* - IF( IERR( 1 ).GT.0 ) THEN - IF( IAM.EQ.0 ) - $ WRITE( NOUT, FMT = 9997 ) 'NB' - KSKIP = KSKIP + 1 - GO TO 10 - END IF -* -* Padding constants -* - NP = NUMROC( N, NB, MYROW, 0, NPROW ) - NQ = NUMROC( N, NB, MYCOL, 0, NPCOL ) - IF( CHECK ) THEN - IPREPAD = MAX( NB, NP ) - IMIDPAD = NB - IPOSTPAD = MAX( NB, NQ ) - ELSE - IPREPAD = 0 - IMIDPAD = 0 - IPOSTPAD = 0 - END IF -* -* Initialize the array descriptor for the matrix A -* - CALL DESCINIT( DESCA, N, N, NB, NB, 0, 0, ICTXT, - $ MAX( 1, NP ) + IMIDPAD, IERR( 1 ) ) -* -* Check all processes for an error -* - CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, - $ 0 ) -* - IF( IERR( 1 ).LT.0 ) THEN - IF( IAM.EQ.0 ) - $ WRITE( NOUT, FMT = 9997 ) 'descriptor' - KSKIP = KSKIP + 1 - GO TO 10 - END IF -* -* Assign pointers into MEM for ScaLAPACK arrays, A is -* allocated starting at position MEM( IPREPAD+1 ) -* - IPA = IPREPAD+1 -* - LCM = ILCM( NPROW, NPCOL ) - IF( LSAMEN( 3, MTYP, 'GEN' ) ) THEN -* -* Pivots are needed by LU factorization -* - IPPIV = IPA + DESCA( LLD_ ) * NQ + IPOSTPAD + - $ IPREPAD - LIPIV = ICEIL( INTGSZ * ( NP + NB ), CPLXSZ ) - IPW = IPPIV + LIPIV + IPOSTPAD + IPREPAD -* - LWORK = MAX( 1, NP * DESCA( NB_ ) ) - WORKINV = LWORK + IPOSTPAD -* -* Figure the amount of workspace required by the -* general matrix inversion -* - IF( NPROW.EQ.NPCOL ) THEN - LIWORK = NQ + DESCA( NB_ ) - ELSE -* -* change the integer workspace needed for PDGETRI -* LIWORK = MAX( DESCA( NB_ ), DESCA( MB_ ) * -* $ ICEIL( ICEIL( DESCA( LLD_ ), -* $ DESCA( MB_ ) ), LCM / NPROW ) ) -* $ + NQ - LIWORK = NUMROC( DESCA( M_ ) + - $ DESCA( MB_ ) * NPROW - $ + MOD ( 1 - 1, DESCA( MB_ ) ), DESCA ( NB_ ), - $ MYCOL, DESCA( CSRC_ ), NPCOL ) + - $ MAX ( DESCA( MB_ ) * ICEIL ( ICEIL( - $ NUMROC( DESCA( M_ ) + DESCA( MB_ ) * NPROW, - $ DESCA( MB_ ), MYROW, DESCA( RSRC_ ), NPROW ), - $ DESCA( MB_ ) ), LCM / NPROW ), DESCA( NB_ ) ) -* - END IF - WORKIINV = ICEIL( LIWORK*INTGSZ, CPLXSZ ) + - $ IPOSTPAD - IPIW = IPW + WORKINV + IPREPAD - WORKSIZ = WORKINV + IPREPAD + WORKIINV -* - ELSE -* -* No pivots or workspace needed for triangular or -* Hermitian positive definite matrices. -* - IPW = IPA + DESCA( LLD_ ) * NQ + IPOSTPAD + IPREPAD - WORKSIZ = 1 + IPOSTPAD -* - END IF -* - IF( CHECK ) THEN -* -* Figure amount of work space for the norm -* computations -* - IF( LSAMEN( 3, MTYP, 'GEN' ).OR. - $ LSAMEN( 2, MTYP( 2:3 ), 'TR' ) ) THEN - ITEMP = NQ - ELSE - ITEMP = 2 * NQ + NP - IF( NPROW.NE.NPCOL ) THEN - ITEMP = ITEMP + - $ NB * ICEIL( ICEIL( NP, NB ), - $ LCM / NPROW ) - END IF - END IF - WORKSIZ = MAX( WORKSIZ-IPOSTPAD, - $ ICEIL( REALSZ * ITEMP, CPLXSZ ) ) -* -* Figure the amount of workspace required by the -* checking routine -* - WORKSIZ = MAX( WORKSIZ, 2 * NB * MAX( 1, NP ) ) + - $ IPOSTPAD -* - END IF -* -* Check for adequate memory for problem size -* - IERR( 1 ) = 0 - IF( IPW+WORKSIZ.GT.MEMSIZ ) THEN - IF( IAM.EQ.0 ) - $ WRITE( NOUT, FMT = 9996 ) 'inversion', - $ ( IPW + WORKSIZ ) * CPLXSZ - IERR( 1 ) = 1 - END IF -* -* Check all processes for an error -* - CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, - $ 0 ) -* - IF( IERR( 1 ).GT.0 ) THEN - IF( IAM.EQ.0 ) - $ WRITE( NOUT, FMT = 9997 ) 'MEMORY' - KSKIP = KSKIP + 1 - GO TO 10 - END IF -* - IF( LSAMEN( 3, MTYP, 'GEN' ).OR. - $ LSAMEN( 2, MTYP( 2:3 ), 'TR' ) ) THEN -* -* Generate a general diagonally dominant matrix A -* - CALL PCMATGEN( ICTXT, 'N', 'D', DESCA( M_ ), - $ DESCA( N_ ), DESCA( MB_ ), - $ DESCA( NB_ ), MEM( IPA ), - $ DESCA( LLD_ ), DESCA( RSRC_ ), - $ DESCA( CSRC_ ), IASEED, 0, NP, 0, - $ NQ, MYROW, MYCOL, NPROW, NPCOL ) -* - ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'PD' ) ) THEN -* -* Generate a Hermitian positive definite matrix A -* - CALL PCMATGEN( ICTXT, 'H', 'D', DESCA( M_ ), - $ DESCA( N_ ), DESCA( MB_ ), - $ DESCA( NB_ ), MEM( IPA ), - $ DESCA( LLD_ ), DESCA( RSRC_ ), - $ DESCA( CSRC_ ), IASEED, 0, NP, 0, - $ NQ, MYROW, MYCOL, NPROW, NPCOL ) -* - END IF -* -* Zeros not-referenced part of A, if any. -* - IF( LSAMEN( 1, MTYP, 'U' ) ) THEN -* - UPLO = 'U' - CALL PCLASET( 'Lower', N-1, N-1, ZERO, ZERO, - $ MEM( IPA ), 2, 1, DESCA ) -* - ELSE IF( LSAMEN( 1, MTYP, 'L' ) ) THEN -* - UPLO = 'L' - CALL PCLASET( 'Upper', N-1, N-1, ZERO, ZERO, - $ MEM( IPA ), 1, 2, DESCA ) -* - ELSE -* - UPLO = 'G' -* - END IF -* -* Need 1-norm of A for checking -* - IF( CHECK ) THEN -* - CALL PCFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), - $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, - $ PADVAL ) - CALL PCFILLPAD( ICTXT, WORKSIZ-IPOSTPAD, 1, - $ MEM( IPW-IPREPAD ), - $ WORKSIZ-IPOSTPAD, IPREPAD, - $ IPOSTPAD, PADVAL ) -* - IF( LSAMEN( 3, MTYP, 'GEN' ) ) THEN -* - CALL PCFILLPAD( ICTXT, LIPIV, 1, - $ MEM( IPPIV-IPREPAD ), LIPIV, - $ IPREPAD, IPOSTPAD, PADVAL ) - ANORM = PCLANGE( '1', N, N, MEM( IPA ), 1, 1, - $ DESCA, MEM( IPW ) ) - CALL PCCHEKPAD( ICTXT, 'PCLANGE', NP, NQ, - $ MEM( IPA-IPREPAD ), - $ DESCA( LLD_ ), - $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PCCHEKPAD( ICTXT, 'PCLANGE', - $ WORKSIZ-IPOSTPAD, 1, - $ MEM( IPW-IPREPAD ), - $ WORKSIZ-IPOSTPAD, - $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PCFILLPAD( ICTXT, WORKINV-IPOSTPAD, 1, - $ MEM( IPW-IPREPAD ), - $ WORKINV-IPOSTPAD, - $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PCFILLPAD( ICTXT, WORKIINV-IPOSTPAD, 1, - $ MEM( IPIW-IPREPAD ), - $ WORKIINV-IPOSTPAD, IPREPAD, - $ IPOSTPAD, PADVAL ) - ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'TR' ) ) THEN -* - ANORM = PCLANTR( '1', UPLO, 'Non unit', N, N, - $ MEM( IPA ), 1, 1, DESCA, - $ MEM( IPW ) ) - CALL PCCHEKPAD( ICTXT, 'PCLANTR', NP, NQ, - $ MEM( IPA-IPREPAD ), - $ DESCA( LLD_ ), - $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PCCHEKPAD( ICTXT, 'PCLANTR', - $ WORKSIZ-IPOSTPAD, 1, - $ MEM( IPW-IPREPAD ), - $ WORKSIZ-IPOSTPAD, - $ IPREPAD, IPOSTPAD, PADVAL ) -* - ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'PD' ) ) THEN -* - ANORM = PCLANHE( '1', UPLO, N, MEM( IPA ), 1, 1, - $ DESCA, MEM( IPW ) ) - CALL PCCHEKPAD( ICTXT, 'PCLANHE', NP, NQ, - $ MEM( IPA-IPREPAD ), - $ DESCA( LLD_ ), - $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PCCHEKPAD( ICTXT, 'PCLANHE', - $ WORKSIZ-IPOSTPAD, 1, - $ MEM( IPW-IPREPAD ), - $ WORKSIZ-IPOSTPAD, - $ IPREPAD, IPOSTPAD, PADVAL ) -* - ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'SY' ) ) THEN -* - CALL PCFILLPAD( ICTXT, LIPIV, 1, - $ MEM( IPPIV-IPREPAD ), LIPIV, - $ IPREPAD, IPOSTPAD, PADVAL ) - ANORM = PCLANSY( '1', UPLO, N, MEM( IPA ), 1, 1, - $ DESCA, MEM( IPW ) ) - CALL PCCHEKPAD( ICTXT, 'PCLANSY', NP, NQ, - $ MEM( IPA-IPREPAD ), - $ DESCA( LLD_ ), - $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PCCHEKPAD( ICTXT, 'PCLANSY', - $ WORKSIZ-IPOSTPAD, 1, - $ MEM( IPW-IPREPAD ), - $ WORKSIZ-IPOSTPAD, - $ IPREPAD,IPOSTPAD, PADVAL ) -* - ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'HE' ) ) THEN - CALL PCFILLPAD( ICTXT, LIPIV, 1, - $ MEM( IPPIV-IPREPAD ), LIPIV, - $ IPREPAD, IPOSTPAD, PADVAL ) - ANORM = PCLANHE( '1', UPLO, N, MEM( IPA ), 1, 1, - $ DESCA, MEM( IPW ) ) - CALL PCCHEKPAD( ICTXT, 'PCLANHE', NP, NQ, - $ MEM( IPA-IPREPAD ), - $ DESCA( LLD_ ), - $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PCCHEKPAD( ICTXT, 'PCLANHE', - $ WORKSIZ-IPOSTPAD, 1, - $ MEM( IPW-IPREPAD ), - $ WORKSIZ-IPOSTPAD, - $ IPREPAD, IPOSTPAD, PADVAL ) -* - END IF -* - END IF -* - CALL SLBOOT() - CALL BLACS_BARRIER( ICTXT, 'All' ) -* - IF( LSAMEN( 3, MTYP, 'GEN' ) ) THEN -* -* Perform LU factorization -* - CALL SLTIMER( 1 ) - CALL PCGETRF( N, N, MEM( IPA ), 1, 1, DESCA, - $ MEM( IPPIV ), INFO ) - CALL SLTIMER( 1 ) -* - IF( CHECK ) THEN -* -* Check for memory overwrite -* - CALL PCCHEKPAD( ICTXT, 'PCGETRF', NP, NQ, - $ MEM( IPA-IPREPAD ), - $ DESCA( LLD_ ), - $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PCCHEKPAD( ICTXT, 'PCGETRF', LIPIV, 1, - $ MEM( IPPIV-IPREPAD ), LIPIV, - $ IPREPAD, IPOSTPAD, PADVAL ) - END IF -* -* Perform the general matrix inversion -* - CALL SLTIMER( 2 ) - CALL PCGETRI( N, MEM( IPA ), 1, 1, DESCA, - $ MEM( IPPIV ), MEM( IPW ), LWORK, - $ MEM( IPIW ), LIWORK, INFO ) - CALL SLTIMER( 2 ) -* - IF( CHECK ) THEN -* -* Check for memory overwrite -* - CALL PCCHEKPAD( ICTXT, 'PCGETRI', NP, NQ, - $ MEM( IPA-IPREPAD ), - $ DESCA( LLD_ ), - $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PCCHEKPAD( ICTXT, 'PCGETRI', LIPIV, 1, - $ MEM( IPPIV-IPREPAD ), LIPIV, - $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PCCHEKPAD( ICTXT, 'PCGETRI', - $ WORKIINV-IPOSTPAD, 1, - $ MEM( IPIW-IPREPAD ), - $ WORKIINV-IPOSTPAD, - $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PCCHEKPAD( ICTXT, 'PCGETRI', - $ WORKINV-IPOSTPAD, 1, - $ MEM( IPW-IPREPAD ), - $ WORKINV-IPOSTPAD, - $ IPREPAD, IPOSTPAD, PADVAL ) - END IF -* - ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'TR' ) ) THEN -* -* Perform the general matrix inversion -* - CALL SLTIMER( 2 ) - CALL PCTRTRI( UPLO, 'Non unit', N, MEM( IPA ), 1, - $ 1, DESCA, INFO ) - CALL SLTIMER( 2 ) -* - IF( CHECK ) THEN -* -* Check for memory overwrite -* - CALL PCCHEKPAD( ICTXT, 'PCTRTRI', NP, NQ, - $ MEM( IPA-IPREPAD ), - $ DESCA( LLD_ ), - $ IPREPAD, IPOSTPAD, PADVAL ) - END IF -* - ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'PD' ) ) THEN -* -* Perform Cholesky factorization -* - CALL SLTIMER( 1 ) - CALL PCPOTRF( UPLO, N, MEM( IPA ), 1, 1, DESCA, - $ INFO ) - CALL SLTIMER( 1 ) -* - IF( CHECK ) THEN -* -* Check for memory overwrite -* - CALL PCCHEKPAD( ICTXT, 'PCPOTRF', NP, NQ, - $ MEM( IPA-IPREPAD ), - $ DESCA( LLD_ ), - $ IPREPAD, IPOSTPAD, PADVAL ) - END IF -* -* Perform the Hermitian positive definite matrix -* inversion -* - CALL SLTIMER( 2 ) - CALL PCPOTRI( UPLO, N, MEM( IPA ), 1, 1, DESCA, - $ INFO ) - CALL SLTIMER( 2 ) -* - IF( CHECK ) THEN -* -* Check for memory overwrite -* - CALL PCCHEKPAD( ICTXT, 'PCPOTRI', NP, NQ, - $ MEM( IPA-IPREPAD ), - $ DESCA( LLD_ ), - $ IPREPAD, IPOSTPAD, PADVAL ) - END IF -* - END IF -* - IF( CHECK ) THEN -* - CALL PCFILLPAD( ICTXT, WORKSIZ-IPOSTPAD, 1, - $ MEM( IPW-IPREPAD ), - $ WORKSIZ-IPOSTPAD, IPREPAD, - $ IPOSTPAD, PADVAL ) -* -* Compute fresid = || inv(A)*A-I || -* - CALL PCINVCHK( MTYP, N, MEM( IPA ), 1, 1, DESCA, - $ IASEED, ANORM, FRESID, RCOND, - $ MEM( IPW ) ) -* -* Check for memory overwrite -* - CALL PCCHEKPAD( ICTXT, 'PCINVCHK', NP, NQ, - $ MEM( IPA-IPREPAD ), - $ DESCA( LLD_ ), - $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PCCHEKPAD( ICTXT, 'PCINVCHK', - $ WORKSIZ-IPOSTPAD, 1, - $ MEM( IPW-IPREPAD ), - $ WORKSIZ-IPOSTPAD, IPREPAD, - $ IPOSTPAD, PADVAL ) -* -* Test residual and detect NaN result -* - IF( FRESID.LE.THRESH .AND. INFO.EQ.0 .AND. - $ ( (FRESID-FRESID) .EQ. 0.0E+0 ) ) THEN - KPASS = KPASS + 1 - PASSED = 'PASSED' - ELSE - KFAIL = KFAIL + 1 - IF( INFO.GT.0 ) THEN - PASSED = 'SINGUL' - ELSE - PASSED = 'FAILED' - END IF - END IF -* - ELSE -* -* Don't perform the checking, only the timing -* operation -* - KPASS = KPASS + 1 - FRESID = FRESID - FRESID - PASSED = 'BYPASS' -* - END IF -* -* Gather maximum of all CPU and WALL clock timings -* - CALL SLCOMBINE( ICTXT, 'All', '>', 'W', 2, 1, WTIME ) - CALL SLCOMBINE( ICTXT, 'All', '>', 'C', 2, 1, CTIME ) -* -* Print results -* - IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN -* - IF( LSAMEN( 3, MTYP, 'GEN' ) ) THEN -* -* 8/3 N^3 - N^2 flops for LU factorization -* - NOPS = ( 8.0D+0 / 3.0D+0 ) * ( DBLE( N )**3 ) - - $ DBLE( N )**2 -* -* 16/3 N^3 for matrix inversion -* - NOPS = NOPS + - $ ( 16.0D+0 / 3.0D+0 ) * ( DBLE( N )**3 ) -* - ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'TR' ) ) THEN -* -* 4/3 N^3 + 2 N^2 for triangular matrix inversion -* - CTIME(1) = 0.0D+0 - WTIME(1) = 0.0D+0 - NOPS = ( 4.0D+0 / 3.0D+0 ) * ( DBLE( N )**3 ) + - $ 2.0D+0 * ( DBLE( N )**2 ) -* - ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'PD' ) ) THEN -* -* 4/3 N^3 + 3 N^2 flops for Cholesky factorization -* - NOPS = ( 4.0D+0 / 3.0D+0 ) * ( DBLE( N )**3 ) + - $ 2.0D+0 * ( DBLE( N )**2 ) -* -* 8/3 N^3 + 5 N^2 flops for Cholesky inversion -* - NOPS = NOPS + - $ ( 8.0D+0 / 3.0D+0 ) * ( DBLE( N )**3 ) + - $ 5.0D+0 * ( DBLE( N )**2 ) -* - END IF -* -* Figure total megaflops -- factorization and -* inversion, for WALL and CPU time, and print -* output. -* -* Print WALL time if machine supports it -* - IF( WTIME( 1 ) + WTIME( 2 ) .GT. 0.0D+0 ) THEN - TMFLOPS = NOPS / - $ ( ( WTIME( 1 )+WTIME( 2 ) ) * 1.0D+6 ) - ELSE - TMFLOPS = 0.0D+0 - END IF -* - IF( WTIME( 2 ) .GE. 0.0D+0 ) - $ WRITE( NOUT, FMT = 9993 ) 'WALL', N, NB, NPROW, - $ NPCOL, WTIME( 1 ), WTIME( 2 ), TMFLOPS, - $ RCOND, FRESID, PASSED -* -* Print CPU time if machine supports it -* - IF( CTIME( 1 ) + CTIME( 2 ) .GT. 0.0D+0 ) THEN - TMFLOPS = NOPS / - $ ( ( CTIME( 1 )+CTIME( 2 ) ) * 1.0D+6 ) - ELSE - TMFLOPS = 0.0D+0 - END IF -* - IF( CTIME( 2 ) .GE. 0.0D+0 ) - $ WRITE( NOUT, FMT = 9993 ) 'CPU ', N, NB, NPROW, - $ NPCOL, CTIME( 1 ), CTIME( 2 ), TMFLOPS, - $ RCOND, FRESID, PASSED - END IF -* - 10 CONTINUE -* - 20 CONTINUE -* - CALL BLACS_GRIDEXIT( ICTXT ) -* - 30 CONTINUE -* - 40 CONTINUE -* -* Print out ending messages and close output file -* - IF( IAM.EQ.0 ) THEN - KTESTS = KPASS + KFAIL + KSKIP - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9992 ) KTESTS - IF( CHECK ) THEN - WRITE( NOUT, FMT = 9991 ) KPASS - WRITE( NOUT, FMT = 9989 ) KFAIL - ELSE - WRITE( NOUT, FMT = 9990 ) KPASS - END IF - WRITE( NOUT, FMT = 9988 ) KSKIP - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = * ) - WRITE( NOUT, FMT = 9987 ) - IF( NOUT.NE.6 .AND. NOUT.NE.0 ) - $ CLOSE ( NOUT ) - END IF -* -#ifdef DYNAMIC_WORK_MEM_ALLOC - deallocate (MEM) -#endif - CALL BLACS_EXIT( 0 ) -* - 9999 FORMAT( 'ILLEGAL ', A6, ': ', A5, ' = ', I3, - $ '; It should be at least 1' ) - 9998 FORMAT( 'ILLEGAL GRID: nprow*npcol = ', I4, '. It can be at most', - $ I4 ) - 9997 FORMAT( 'Bad ', A6, ' parameters: going on to next test case.' ) - 9996 FORMAT( 'Unable to perform ', A, ': need TOTMEM of at least', - $ I11 ) - 9995 FORMAT( 'TIME N NB P Q Fct Time Inv Time ', - $ ' MFLOPS Cond Resid CHECK' ) - 9994 FORMAT( '---- ----- --- ----- ----- -------- -------- ', - $ '----------- ------- ------- ------' ) - 9993 FORMAT( A4, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, F8.2, 1X, F8.2, - $ 1X, F12.2, 1X, F7.1, 1X, F7.2, 1X, A6 ) - 9992 FORMAT( 'Finished ', I6, ' tests, with the following results:' ) - 9991 FORMAT( I5, ' tests completed and passed residual checks.' ) - 9990 FORMAT( I5, ' tests completed without checking.' ) - 9989 FORMAT( I5, ' tests completed and failed residual checks.' ) - 9988 FORMAT( I5, ' tests skipped because of illegal input values.' ) - 9987 FORMAT( 'END OF TESTS.' ) - 9986 FORMAT( A ) -* - STOP -* -* End of PCINVDRIVER -* - END + PROGRAM PCINVDRIVER +* +* -- ScaLAPACK testing driver (version 1.7) -- +* University of Tennessee, Knoxville, Oak Ridge National Laboratory, +* and University of California, Berkeley. +* May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. +* +* Purpose +* ======= +* +* PCINVDRIVER is the main test program for the COMPLEX +* SCALAPACK matrix inversion routines. This test driver computes the +* inverse of different kind of matrix and tests the results. +* +* The program must be driven by a short data file. An annotated example +* of a data file can be obtained by deleting the first 3 characters +* from the following 14 lines: +* 'ScaLAPACK Matrix Inversion Testing input file' +* 'PVM machine.' +* 'INV.out' output file name (if any) +* 6 device out +* 5 number of matrix types (next line) +* 'GEN' 'UTR' 'LTR' 'UPD' LPD' GEN, UTR, LTR, UPD, LPD +* 4 number of problems sizes +* 1000 2000 3000 4000 values of N +* 3 number of NB's +* 4 30 35 values of NB +* 2 number of process grids (ordered P & Q) +* 4 2 values of P +* 4 4 values of Q +* 1.0 threshold +* +* Internal Parameters +* =================== +* +* TOTMEM INTEGER, default = 2000000 +* TOTMEM is a machine-specific parameter indicating the +* maximum amount of available memory in bytes. +* The user should customize TOTMEM to his platform. Remember +* to leave room in memory for the operating system, the BLACS +* buffer, etc. For example, on a system with 8 MB of memory +* per process (e.g., one processor on an Intel iPSC/860), the +* parameters we use are TOTMEM=6200000 (leaving 1.8 MB for OS, +* code, BLACS buffer, etc). However, for PVM, we usually set +* TOTMEM = 2000000. Some experimenting with the maximum value +* of TOTMEM may be required. +* +* INTGSZ INTEGER, default = 4 bytes. +* REALSZ INTEGER, default = 4 bytes. +* CPLXSZ INTEGER, default = 8 bytes. +* INTGSZ, REALSZ and CPLXSZ indicate the length in bytes on +* the given platform for an integer, a single precision real +* and a single precision complex. +* MEM COMPLEX array, dimension ( TOTMEM / CPLXSZ ) +* +* All arrays used by SCALAPACK routines are allocated from +* this array and referenced by pointers. The integer IPA, +* for example, is a pointer to the starting element of MEM for +* the matrix A. +* +* ===================================================================== +* + use,intrinsic :: ieee_arithmetic +* .. Parameters .. + INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, + $ LLD_, MB_, M_, NB_, N_, RSRC_ + PARAMETER ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1, + $ CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6, + $ RSRC_ = 7, CSRC_ = 8, LLD_ = 9 ) + + INTEGER CPLXSZ, INTGSZ, MEMSIZ, NTESTS, REALSZ, TOTMEM +#ifndef DYNAMIC_WORK_MEM_ALLOC + PARAMETER ( TOTMEM = 2000000 ) +#else + PARAMETER ( TOTMEM = 2100000000 ) +#endif + COMPLEX PADVAL, ZERO +#ifdef ENABLE_ILP64 + PARAMETER ( INTGSZ = 8 ) +#else + PARAMETER ( INTGSZ = 4 ) +#endif + PARAMETER ( CPLXSZ = 8, REALSZ = 4, + $ MEMSIZ = TOTMEM / CPLXSZ, + $ NTESTS = 20, + $ PADVAL = ( -9923.0E+0, -9923.0E+0 ), + $ ZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + CHARACTER UPLO + CHARACTER*3 MTYP + CHARACTER*6 PASSED + CHARACTER*80 OUTFILE + LOGICAL CHECK + INTEGER I, IAM, IASEED, ICTXT, IMIDPAD, INFO, IPA, + $ IPPIV, IPREPAD, IPOSTPAD, IPIW, IPW, ITEMP, J, + $ K, KTESTS, KPASS, KFAIL, KSKIP, L, LCM, LIPIV, + $ LIWORK, LWORK, MYCOL, MYROW, N, NB, NGRIDS, + $ NMAT, NMTYP, NNB, NOUT, NP, NPCOL, NPROCS, + $ NPROW, NQ, WORKIINV, WORKINV, WORKSIZ + REAL ANORM, FRESID, RCOND, THRESH + DOUBLE PRECISION NOPS, TMFLOPS + CHARACTER*8 API_NAME +* .. +* .. Local Arrays .. + CHARACTER*3 MATTYP( NTESTS ) + INTEGER DESCA( DLEN_ ), IERR( 1 ), NBVAL( NTESTS ), + $ NVAL( NTESTS ), PVAL( NTESTS ), + $ QVAL( NTESTS ) + DOUBLE PRECISION CTIME( 2 ), WTIME( 2 ) +#ifndef DYNAMIC_WORK_MEM_ALLOC + COMPLEX MEM( MEMSIZ ) +#else + COMPLEX, allocatable :: MEM (:) +#endif + +* .. +* .. External Subroutines .. + EXTERNAL BLACS_BARRIER, BLACS_EXIT, BLACS_GET, + $ BLACS_GRIDEXIT, BLACS_GRIDINFO, BLACS_GRIDINIT, + $ BLACS_PINFO, DESCINIT, IGSUM2D, PCCHEKPAD, + $ PCFILLPAD, PCGETRF, PCGETRI, + $ PCINVCHK, PCINVINFO, PCLASET, + $ PCMATGEN, PCPOTRF, PCPOTRI, + $ PCTRTRI, SLBOOT, SLCOMBINE, SLTIMER +* .. +* .. External Functions .. + LOGICAL LSAMEN + INTEGER ICEIL, ILCM, NUMROC + REAL PCLANGE, PCLANHE, PCLANSY, PCLANTR + EXTERNAL ICEIL, ILCM, LSAMEN, NUMROC, PCLANGE, + $ PCLANHE, PCLANSY, PCLANTR +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX +* .. +* .. Data Statements .. + DATA KTESTS, KPASS, KFAIL, KSKIP /4*0/ +* .. +* .. Executable Statements .. +* +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X +* +* Get starting information +* +#ifdef DYNAMIC_WORK_MEM_ALLOC + allocate(MEM(MEMSIZ)) +#endif + CALL BLACS_PINFO( IAM, NPROCS ) + IASEED = 100 + CALL PCINVINFO( OUTFILE, NOUT, NMTYP, MATTYP, NTESTS, NMAT, NVAL, + $ NTESTS, NNB, NBVAL, NTESTS, NGRIDS, PVAL, NTESTS, + $ QVAL, NTESTS, THRESH, MEM, IAM, NPROCS ) + CHECK = ( THRESH.GE.0.0E+0 ) + +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* +* +* Loop over the different matrix types +* + DO 40 I = 1, NMTYP +* + MTYP = MATTYP( I ) +* +* Print headings +* + IF( IAM.EQ.0 ) THEN + WRITE( NOUT, FMT = * ) + IF( LSAMEN( 3, MTYP, 'GEN' ) ) THEN + WRITE( NOUT, FMT = 9986 ) + $ 'A is a general matrix.' + ELSE IF( LSAMEN( 3, MTYP, 'UTR' ) ) THEN + WRITE( NOUT, FMT = 9986 ) + $ 'A is an upper triangular matrix.' + ELSE IF( LSAMEN( 3, MTYP, 'LTR' ) ) THEN + WRITE( NOUT, FMT = 9986 ) + $ 'A is a lower triangular matrix.' + ELSE IF( LSAMEN( 3, MTYP, 'UPD' ) ) THEN + WRITE( NOUT, FMT = 9986 ) + $ 'A is a Hermitian positive definite matrix.' + WRITE( NOUT, FMT = 9986 ) + $ 'Only the upper triangular part will be '// + $ 'referenced.' + ELSE IF( LSAMEN( 3, MTYP, 'LPD' ) ) THEN + WRITE( NOUT, FMT = 9986 ) + $ 'A is a Hermitian positive definite matrix.' + WRITE( NOUT, FMT = 9986 ) + $ 'Only the lower triangular part will be '// + $ 'referenced.' + END IF + WRITE( NOUT, FMT = * ) + WRITE( NOUT, FMT = 9995 ) + WRITE( NOUT, FMT = 9994 ) + WRITE( NOUT, FMT = * ) + END IF +* +* Loop over different process grids +* + DO 30 J = 1, NGRIDS +* + NPROW = PVAL( J ) + NPCOL = QVAL( J ) +* +* Make sure grid information is correct +* + IERR( 1 ) = 0 + IF( NPROW.LT.1 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9999 ) 'GRID', 'nprow', NPROW + IERR( 1 ) = 1 + ELSE IF( NPCOL.LT.1 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9999 ) 'GRID', 'npcol', NPCOL + IERR( 1 ) = 1 + ELSE IF( NPROW*NPCOL.GT.NPROCS ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9998 ) NPROW*NPCOL, NPROCS + IERR( 1 ) = 1 + END IF +* + IF( IERR( 1 ).GT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'grid' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +* +* Define process grid +* + CALL BLACS_GET( -1, 0, ICTXT ) + CALL BLACS_GRIDINIT( ICTXT, 'Row-major', NPROW, NPCOL ) + CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) +* +* Go to bottom of loop if this case doesn't use my process +* + IF( MYROW.GE.NPROW .OR. MYCOL.GE.NPCOL ) + $ GO TO 30 +* + DO 20 K = 1, NMAT +* + N = NVAL( K ) +* +* Make sure matrix information is correct +* +#ifdef ENABLE_DRIVER_CHECK + IERR( 1 ) = 0 + IF( N.LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N + IERR( 1 ) = 1 + END IF +#endif +* +* Make sure no one had error +* + CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) +* + IF( IERR( 1 ).GT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'matrix' + KSKIP = KSKIP + 1 + GO TO 20 + END IF +* +* Loop over different blocking sizes +* + DO 10 L = 1, NNB +* + NB = NBVAL( L ) +* +* Make sure nb is legal +* + IERR( 1 ) = 0 + IF( NB.LT.1 ) THEN + IERR( 1 ) = 1 + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9999 ) 'NB', 'NB', NB + END IF +* +* Check all processes for an error +* + CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, + $ 0 ) +* + IF( IERR( 1 ).GT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'NB' + KSKIP = KSKIP + 1 + GO TO 10 + END IF +* +* Padding constants +* + NP = NUMROC( N, NB, MYROW, 0, NPROW ) + NQ = NUMROC( N, NB, MYCOL, 0, NPCOL ) + IF( CHECK ) THEN + IPREPAD = MAX( NB, NP ) + IMIDPAD = NB + IPOSTPAD = MAX( NB, NQ ) + ELSE + IPREPAD = 0 + IMIDPAD = 0 + IPOSTPAD = 0 + END IF +* +* Initialize the array descriptor for the matrix A +* + CALL DESCINIT( DESCA, N, N, NB, NB, 0, 0, ICTXT, + $ MAX( 1, NP ) + IMIDPAD, IERR( 1 ) ) +* +* Check all processes for an error +* + CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, + $ 0 ) +* +#ifdef ENABLE_DRIVER_CHECK + IF( IERR( 1 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 )) THEN +* DESCINIT returns the correct error code, +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9984 ) 'N' +* disable extreme flag for negative case + EX_FLAG = .FALSE. + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF + +#endif +* +* Assign pointers into MEM for ScaLAPACK arrays, A is +* allocated starting at position MEM( IPREPAD+1 ) +* + IPA = IPREPAD+1 +* + LCM = ILCM( NPROW, NPCOL ) + IF( LSAMEN( 3, MTYP, 'GEN' ) ) THEN +* +* Pivots are needed by LU factorization +* + IPPIV = IPA + DESCA( LLD_ ) * NQ + IPOSTPAD + + $ IPREPAD + LIPIV = ICEIL( INTGSZ * ( NP + NB ), CPLXSZ ) + IPW = IPPIV + LIPIV + IPOSTPAD + IPREPAD +* + LWORK = MAX( 1, NP * DESCA( NB_ ) ) + WORKINV = LWORK + IPOSTPAD +* +* Figure the amount of workspace required by the +* general matrix inversion +* + IF( NPROW.EQ.NPCOL ) THEN + LIWORK = NQ + DESCA( NB_ ) + ELSE +* +* change the integer workspace needed for PDGETRI +* LIWORK = MAX( DESCA( NB_ ), DESCA( MB_ ) * +* $ ICEIL( ICEIL( DESCA( LLD_ ), +* $ DESCA( MB_ ) ), LCM / NPROW ) ) +* $ + NQ + LIWORK = NUMROC( DESCA( M_ ) + + $ DESCA( MB_ ) * NPROW + $ + MOD ( 1 - 1, DESCA( MB_ ) ), DESCA ( NB_ ), + $ MYCOL, DESCA( CSRC_ ), NPCOL ) + + $ MAX ( DESCA( MB_ ) * ICEIL ( ICEIL( + $ NUMROC( DESCA( M_ ) + DESCA( MB_ ) * NPROW, + $ DESCA( MB_ ), MYROW, DESCA( RSRC_ ), NPROW ), + $ DESCA( MB_ ) ), LCM / NPROW ), DESCA( NB_ ) ) +* + END IF + WORKIINV = ICEIL( LIWORK*INTGSZ, CPLXSZ ) + + $ IPOSTPAD + IPIW = IPW + WORKINV + IPREPAD + WORKSIZ = WORKINV + IPREPAD + WORKIINV +* + ELSE +* +* No pivots or workspace needed for triangular or +* Hermitian positive definite matrices. +* + IPW = IPA + DESCA( LLD_ ) * NQ + IPOSTPAD + IPREPAD + WORKSIZ = 1 + IPOSTPAD +* + END IF +* + IF( CHECK ) THEN +* +* Figure amount of work space for the norm +* computations +* + IF( LSAMEN( 3, MTYP, 'GEN' ).OR. + $ LSAMEN( 2, MTYP( 2:3 ), 'TR' ) ) THEN + ITEMP = NQ + ELSE + ITEMP = 2 * NQ + NP + IF( NPROW.NE.NPCOL ) THEN + ITEMP = ITEMP + + $ NB * ICEIL( ICEIL( NP, NB ), + $ LCM / NPROW ) + END IF + END IF + WORKSIZ = MAX( WORKSIZ-IPOSTPAD, + $ ICEIL( REALSZ * ITEMP, CPLXSZ ) ) +* +* Figure the amount of workspace required by the +* checking routine +* + WORKSIZ = MAX( WORKSIZ, 2 * NB * MAX( 1, NP ) ) + + $ IPOSTPAD +* + END IF +* +* Check for adequate memory for problem size +* + IERR( 1 ) = 0 + IF( IPW+WORKSIZ.GT.MEMSIZ ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9996 ) 'inversion', + $ ( IPW + WORKSIZ ) * CPLXSZ + IERR( 1 ) = 1 + END IF +* +* Check all processes for an error +* + CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, + $ 0 ) +* + IF( IERR( 1 ).GT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'MEMORY' + KSKIP = KSKIP + 1 + GO TO 10 + END IF +* + IF( LSAMEN( 3, MTYP, 'GEN' ).OR. + $ LSAMEN( 2, MTYP( 2:3 ), 'TR' ) ) THEN +* +* Generate a general diagonally dominant matrix A +* + IF(EX_FLAG) THEN +* The extreme-value generation module for +* diagonally dominant matrices, requires +* Matrix-type info such as Upper/Lower. +* Hence, MTYP(1:1) is passed to MATGEN +* MTYP(1:1) is 'U'/'L'/'N' (default-case) + CALL PCMATGEN( ICTXT, MTYP(1:1), 'D', + $ DESCA( M_ ), + $ DESCA( N_ ), DESCA( MB_ ), + $ DESCA( NB_ ), MEM( IPA ), + $ DESCA( LLD_ ), DESCA( RSRC_ ), + $ DESCA( CSRC_ ), IASEED, 0, NP, 0, + $ NQ, MYROW, MYCOL, NPROW, NPCOL ) + + ELSE + CALL PCMATGEN( ICTXT, 'N', 'D', DESCA( M_ ), + $ DESCA( N_ ), DESCA( MB_ ), + $ DESCA( NB_ ), MEM( IPA ), + $ DESCA( LLD_ ), DESCA( RSRC_ ), + $ DESCA( CSRC_ ), IASEED, 0, NP, 0, + $ NQ, MYROW, MYCOL, NPROW, NPCOL ) + END IF +* + ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'PD' ) ) THEN +* +* Generate a Hermitian positive definite matrix A +* + IF(EX_FLAG) THEN +* MTYP(1:1) is 'U'/'L'/'N' (default-case) + CALL PCMATGEN( ICTXT, MTYP(1:1), 'D', + $ DESCA( M_ ), + $ DESCA( N_ ), DESCA( MB_ ), + $ DESCA( NB_ ), MEM( IPA ), + $ DESCA( LLD_ ), DESCA( RSRC_ ), + $ DESCA( CSRC_ ), IASEED, 0, NP, 0, + $ NQ, MYROW, MYCOL, NPROW, NPCOL ) + ELSE + CALL PCMATGEN( ICTXT, 'H', 'D', + $ DESCA( M_ ), + $ DESCA( N_ ), DESCA( MB_ ), + $ DESCA( NB_ ), MEM( IPA ), + $ DESCA( LLD_ ), DESCA( RSRC_ ), + $ DESCA( CSRC_ ), IASEED, 0, NP, 0, + $ NQ, MYROW, MYCOL, NPROW, NPCOL ) + END IF +* + END IF +* +* Zeros not-referenced part of A, if any. +* + IF( LSAMEN( 1, MTYP, 'U' ) ) THEN +* + UPLO = 'U' + CALL PCLASET( 'Lower', N-1, N-1, ZERO, ZERO, + $ MEM( IPA ), 2, 1, DESCA ) +* + ELSE IF( LSAMEN( 1, MTYP, 'L' ) ) THEN +* + UPLO = 'L' + CALL PCLASET( 'Upper', N-1, N-1, ZERO, ZERO, + $ MEM( IPA ), 1, 2, DESCA ) +* + ELSE +* + UPLO = 'G' +* + END IF +* +* Need 1-norm of A for checking +* + IF( CHECK .AND. N.GT.0 ) THEN +* + CALL PCFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), + $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, + $ PADVAL ) + CALL PCFILLPAD( ICTXT, WORKSIZ-IPOSTPAD, 1, + $ MEM( IPW-IPREPAD ), + $ WORKSIZ-IPOSTPAD, IPREPAD, + $ IPOSTPAD, PADVAL ) +* + IF( LSAMEN( 3, MTYP, 'GEN' ) ) THEN +* + CALL PCFILLPAD( ICTXT, LIPIV, 1, + $ MEM( IPPIV-IPREPAD ), LIPIV, + $ IPREPAD, IPOSTPAD, PADVAL ) + ANORM = PCLANGE( '1', N, N, MEM( IPA ), 1, 1, + $ DESCA, MEM( IPW ) ) + CALL PCCHEKPAD( ICTXT, 'PCLANGE', NP, NQ, + $ MEM( IPA-IPREPAD ), + $ DESCA( LLD_ ), + $ IPREPAD, IPOSTPAD, PADVAL ) + CALL PCCHEKPAD( ICTXT, 'PCLANGE', + $ WORKSIZ-IPOSTPAD, 1, + $ MEM( IPW-IPREPAD ), + $ WORKSIZ-IPOSTPAD, + $ IPREPAD, IPOSTPAD, PADVAL ) + CALL PCFILLPAD( ICTXT, WORKINV-IPOSTPAD, 1, + $ MEM( IPW-IPREPAD ), + $ WORKINV-IPOSTPAD, + $ IPREPAD, IPOSTPAD, PADVAL ) + CALL PCFILLPAD( ICTXT, WORKIINV-IPOSTPAD, 1, + $ MEM( IPIW-IPREPAD ), + $ WORKIINV-IPOSTPAD, IPREPAD, + $ IPOSTPAD, PADVAL ) + ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'TR' ) ) THEN +* + ANORM = PCLANTR( '1', UPLO, 'Non unit', N, N, + $ MEM( IPA ), 1, 1, DESCA, + $ MEM( IPW ) ) + CALL PCCHEKPAD( ICTXT, 'PCLANTR', NP, NQ, + $ MEM( IPA-IPREPAD ), + $ DESCA( LLD_ ), + $ IPREPAD, IPOSTPAD, PADVAL ) + CALL PCCHEKPAD( ICTXT, 'PCLANTR', + $ WORKSIZ-IPOSTPAD, 1, + $ MEM( IPW-IPREPAD ), + $ WORKSIZ-IPOSTPAD, + $ IPREPAD, IPOSTPAD, PADVAL ) +* + ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'PD' ) ) THEN +* + ANORM = PCLANHE( '1', UPLO, N, MEM( IPA ), 1, 1, + $ DESCA, MEM( IPW ) ) + CALL PCCHEKPAD( ICTXT, 'PCLANHE', NP, NQ, + $ MEM( IPA-IPREPAD ), + $ DESCA( LLD_ ), + $ IPREPAD, IPOSTPAD, PADVAL ) + CALL PCCHEKPAD( ICTXT, 'PCLANHE', + $ WORKSIZ-IPOSTPAD, 1, + $ MEM( IPW-IPREPAD ), + $ WORKSIZ-IPOSTPAD, + $ IPREPAD, IPOSTPAD, PADVAL ) +* + ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'SY' ) ) THEN +* + CALL PCFILLPAD( ICTXT, LIPIV, 1, + $ MEM( IPPIV-IPREPAD ), LIPIV, + $ IPREPAD, IPOSTPAD, PADVAL ) + ANORM = PCLANSY( '1', UPLO, N, MEM( IPA ), 1, 1, + $ DESCA, MEM( IPW ) ) + CALL PCCHEKPAD( ICTXT, 'PCLANSY', NP, NQ, + $ MEM( IPA-IPREPAD ), + $ DESCA( LLD_ ), + $ IPREPAD, IPOSTPAD, PADVAL ) + CALL PCCHEKPAD( ICTXT, 'PCLANSY', + $ WORKSIZ-IPOSTPAD, 1, + $ MEM( IPW-IPREPAD ), + $ WORKSIZ-IPOSTPAD, + $ IPREPAD,IPOSTPAD, PADVAL ) +* + ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'HE' ) ) THEN + CALL PCFILLPAD( ICTXT, LIPIV, 1, + $ MEM( IPPIV-IPREPAD ), LIPIV, + $ IPREPAD, IPOSTPAD, PADVAL ) + ANORM = PCLANHE( '1', UPLO, N, MEM( IPA ), 1, 1, + $ DESCA, MEM( IPW ) ) + CALL PCCHEKPAD( ICTXT, 'PCLANHE', NP, NQ, + $ MEM( IPA-IPREPAD ), + $ DESCA( LLD_ ), + $ IPREPAD, IPOSTPAD, PADVAL ) + CALL PCCHEKPAD( ICTXT, 'PCLANHE', + $ WORKSIZ-IPOSTPAD, 1, + $ MEM( IPW-IPREPAD ), + $ WORKSIZ-IPOSTPAD, + $ IPREPAD, IPOSTPAD, PADVAL ) +* + END IF +* + END IF +* + CALL SLBOOT() + CALL BLACS_BARRIER( ICTXT, 'All' ) +* + IF( LSAMEN( 3, MTYP, 'GEN' ) ) THEN +* +* Perform LU factorization +* + CALL SLTIMER( 1 ) + CALL PCGETRF( N, N, MEM( IPA ), 1, 1, DESCA, + $ MEM( IPPIV ), INFO ) + CALL SLTIMER( 1 ) +* + IF( CHECK .AND. N.GT.0 ) THEN +* +* Check for memory overwrite +* + CALL PCCHEKPAD( ICTXT, 'PCGETRF', NP, NQ, + $ MEM( IPA-IPREPAD ), + $ DESCA( LLD_ ), + $ IPREPAD, IPOSTPAD, PADVAL ) + CALL PCCHEKPAD( ICTXT, 'PCGETRF', LIPIV, 1, + $ MEM( IPPIV-IPREPAD ), LIPIV, + $ IPREPAD, IPOSTPAD, PADVAL ) + END IF +* +* Perform the general matrix inversion +* + + CALL SLTIMER( 2 ) + API_NAME = 'PCGETRI' + CALL PCGETRI( N, MEM( IPA ), 1, 1, DESCA, + $ MEM( IPPIV ), MEM( IPW ), LWORK, + $ MEM( IPIW ), LIWORK, INFO ) + CALL SLTIMER( 2 ) +* + IF( CHECK .AND. N.GT.0 ) THEN +* +* Check for memory overwrite +* + CALL PCCHEKPAD( ICTXT, 'PCGETRI', NP, NQ, + $ MEM( IPA-IPREPAD ), + $ DESCA( LLD_ ), + $ IPREPAD, IPOSTPAD, PADVAL ) + CALL PCCHEKPAD( ICTXT, 'PCGETRI', LIPIV, 1, + $ MEM( IPPIV-IPREPAD ), LIPIV, + $ IPREPAD, IPOSTPAD, PADVAL ) + CALL PCCHEKPAD( ICTXT, 'PCGETRI', + $ WORKIINV-IPOSTPAD, 1, + $ MEM( IPIW-IPREPAD ), + $ WORKIINV-IPOSTPAD, + $ IPREPAD, IPOSTPAD, PADVAL ) + CALL PCCHEKPAD( ICTXT, 'PCGETRI', + $ WORKINV-IPOSTPAD, 1, + $ MEM( IPW-IPREPAD ), + $ WORKINV-IPOSTPAD, + $ IPREPAD, IPOSTPAD, PADVAL ) + END IF +* + ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'TR' ) ) THEN +* +* Perform the general matrix inversion +* + CALL SLTIMER( 2 ) + API_NAME = 'PCTRTRI' + CALL PCTRTRI( UPLO, 'Non unit', N, MEM( IPA ), 1, + $ 1, DESCA, INFO ) + CALL SLTIMER( 2 ) +* + IF( CHECK .AND. N.GT.0 ) THEN +* +* Check for memory overwrite +* + CALL PCCHEKPAD( ICTXT, 'PCTRTRI', NP, NQ, + $ MEM( IPA-IPREPAD ), + $ DESCA( LLD_ ), + $ IPREPAD, IPOSTPAD, PADVAL ) + END IF +* + ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'PD' ) ) THEN +* +* Perform Cholesky factorization +* + CALL SLTIMER( 1 ) + CALL PCPOTRF( UPLO, N, MEM( IPA ), 1, 1, DESCA, + $ INFO ) + CALL SLTIMER( 1 ) +* + IF( CHECK .AND. N.GT.0 ) THEN +* +* Check for memory overwrite +* + CALL PCCHEKPAD( ICTXT, 'PCPOTRF', NP, NQ, + $ MEM( IPA-IPREPAD ), + $ DESCA( LLD_ ), + $ IPREPAD, IPOSTPAD, PADVAL ) + END IF +* +* Perform the Hermitian positive definite matrix +* inversion +* + CALL SLTIMER( 2 ) + API_NAME = 'PCPOTRI' + CALL PCPOTRI( UPLO, N, MEM( IPA ), 1, 1, DESCA, + $ INFO ) + CALL SLTIMER( 2 ) +* + IF( CHECK .AND. N.GT.0 ) THEN +* +* Check for memory overwrite +* + CALL PCCHEKPAD( ICTXT, 'PCPOTRI', NP, NQ, + $ MEM( IPA-IPREPAD ), + $ DESCA( LLD_ ), + $ IPREPAD, IPOSTPAD, PADVAL ) + END IF +* + END IF +* + IF( CHECK .AND. .NOT.(EX_FLAG)) THEN +* + IF(INFO.EQ.0 .AND. N.GT.0) THEN + CALL PCFILLPAD( ICTXT, WORKSIZ-IPOSTPAD, 1, + $ MEM( IPW-IPREPAD ), + $ WORKSIZ-IPOSTPAD, IPREPAD, + $ IPOSTPAD, PADVAL ) +* +* Compute fresid = || inv(A)*A-I || +* + CALL PCINVCHK( MTYP, N, MEM( IPA ), 1, 1, + $ DESCA, IASEED, ANORM, FRESID, + $ RCOND, MEM( IPW ) ) +* +* Check for memory overwrite +* + CALL PCCHEKPAD( ICTXT, 'PCINVCHK', NP, NQ, + $ MEM( IPA-IPREPAD ), + $ DESCA( LLD_ ), + $ IPREPAD, IPOSTPAD, PADVAL ) + CALL PCCHEKPAD( ICTXT, 'PCINVCHK', + $ WORKSIZ-IPOSTPAD, 1, + $ MEM( IPW-IPREPAD ), + $ WORKSIZ-IPOSTPAD, IPREPAD, + $ IPOSTPAD, PADVAL ) + END IF +* +* Test residual and detect NaN result +* + IF(N.EQ.0 .AND. INFO.EQ.0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) KPASS, API_NAME + PASSED = 'PASSED' + GO TO 10 + ELSE IF( FRESID.LE.THRESH .AND. INFO.EQ.0 .AND. + $ ( (FRESID-FRESID) .EQ. 0.0E+0 ) ) THEN + KPASS = KPASS + 1 + PASSED = 'PASSED' + ELSE IF(N.LT.0 .AND. + $ ((INFO.EQ.-1 + $ .AND. LSAMEN( 3, MTYP, 'GEN' )) .OR. + $ (INFO.EQ.-3 .AND. + $ LSAMEN( 2, MTYP( 2:3 ), 'TR' )) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, MTYP( 2:3 ), 'PD' )))) THEN +* When N < 0/Invalid, PCGETRI INFO = -1 +* PTPOTRI INFO = -2 and PCTRTRI INFO = -3 +* Expected Error code for N < 0 +* Hence this case can be passed + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9983 ) API_NAME + PASSED = 'PASSED' +* re-enable extreme flag for next case + IF(INF_PERCENT .GT. 0 .OR. + $ NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + ELSE + KFAIL = KFAIL + 1 + IF( INFO.GT.0 ) THEN + PASSED = 'SINGUL' + ELSE + PASSED = 'FAILED' + END IF + END IF +* + ELSE +* +* Extreme value case + IF(N.EQ.0 .AND. INFO.EQ.0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) KPASS, API_NAME + PASSED = 'PASSED' + GO TO 10 + ELSE IF(EX_FLAG .AND. N.GT.0) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, N-1 + DO JK = 1, N + X = REAL(MEM(IK*N + JK)) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF + FRESID = FRESID - FRESID +* +* Don't perform the checking, only the timing +* operation + ELSE + KPASS = KPASS + 1 + FRESID = FRESID - FRESID + PASSED = 'BYPASS' + END IF +* + END IF +* +* Gather maximum of all CPU and WALL clock timings +* + CALL SLCOMBINE( ICTXT, 'All', '>', 'W', 2, 1, WTIME ) + CALL SLCOMBINE( ICTXT, 'All', '>', 'C', 2, 1, CTIME ) +* +* Print results +* + IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN +* + IF( LSAMEN( 3, MTYP, 'GEN' ) ) THEN +* +* 8/3 N^3 - N^2 flops for LU factorization +* + NOPS = ( 8.0D+0 / 3.0D+0 ) * ( DBLE( N )**3 ) - + $ DBLE( N )**2 +* +* 16/3 N^3 for matrix inversion +* + NOPS = NOPS + + $ ( 16.0D+0 / 3.0D+0 ) * ( DBLE( N )**3 ) +* + ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'TR' ) ) THEN +* +* 4/3 N^3 + 2 N^2 for triangular matrix inversion +* + CTIME(1) = 0.0D+0 + WTIME(1) = 0.0D+0 + NOPS = ( 4.0D+0 / 3.0D+0 ) * ( DBLE( N )**3 ) + + $ 2.0D+0 * ( DBLE( N )**2 ) +* + ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'PD' ) ) THEN +* +* 4/3 N^3 + 3 N^2 flops for Cholesky factorization +* + NOPS = ( 4.0D+0 / 3.0D+0 ) * ( DBLE( N )**3 ) + + $ 2.0D+0 * ( DBLE( N )**2 ) +* +* 8/3 N^3 + 5 N^2 flops for Cholesky inversion +* + NOPS = NOPS + + $ ( 8.0D+0 / 3.0D+0 ) * ( DBLE( N )**3 ) + + $ 5.0D+0 * ( DBLE( N )**2 ) +* + END IF +* +* Figure total megaflops -- factorization and +* inversion, for WALL and CPU time, and print +* output. +* +* Print WALL time if machine supports it +* + IF( WTIME( 1 ) + WTIME( 2 ) .GT. 0.0D+0 ) THEN + TMFLOPS = NOPS / + $ ( ( WTIME( 1 )+WTIME( 2 ) ) * 1.0D+6 ) + ELSE + TMFLOPS = 0.0D+0 + END IF +* + IF( WTIME( 2 ) .GE. 0.0D+0 ) + $ WRITE( NOUT, FMT = 9993 ) 'WALL', N, NB, NPROW, + $ NPCOL, WTIME( 1 ), WTIME( 2 ), TMFLOPS, + $ RCOND, FRESID, PASSED +* +* Print CPU time if machine supports it +* + IF( CTIME( 1 ) + CTIME( 2 ) .GT. 0.0D+0 ) THEN + TMFLOPS = NOPS / + $ ( ( CTIME( 1 )+CTIME( 2 ) ) * 1.0D+6 ) + ELSE + TMFLOPS = 0.0D+0 + END IF +* + IF( CTIME( 2 ) .GE. 0.0D+0 ) + $ WRITE( NOUT, FMT = 9993 ) 'CPU ', N, NB, NPROW, + $ NPCOL, CTIME( 1 ), CTIME( 2 ), TMFLOPS, + $ RCOND, FRESID, PASSED + END IF +* + 10 CONTINUE +* + 20 CONTINUE +* + CALL BLACS_GRIDEXIT( ICTXT ) +* + 30 CONTINUE +* + 40 CONTINUE +* +* Print out ending messages and close output file +* + IF( IAM.EQ.0 ) THEN + KTESTS = KPASS + KFAIL + KSKIP + WRITE( NOUT, FMT = * ) + WRITE( NOUT, FMT = 9992 ) KTESTS + IF( CHECK ) THEN + WRITE( NOUT, FMT = 9991 ) KPASS + WRITE( NOUT, FMT = 9989 ) KFAIL + ELSE + WRITE( NOUT, FMT = 9990 ) KPASS + END IF + WRITE( NOUT, FMT = 9988 ) KSKIP + WRITE( NOUT, FMT = * ) + WRITE( NOUT, FMT = * ) + WRITE( NOUT, FMT = 9987 ) + IF( NOUT.NE.6 .AND. NOUT.NE.0 ) + $ CLOSE ( NOUT ) + END IF +* +#ifdef DYNAMIC_WORK_MEM_ALLOC + deallocate (MEM) +#endif + CALL BLACS_EXIT( 0 ) +* + 9999 FORMAT( 'ILLEGAL ', A6, ': ', A5, ' = ', I3, + $ '; It should be at least 1' ) + 9998 FORMAT( 'ILLEGAL GRID: nprow*npcol = ', I4, '. It can be at most', + $ I4 ) + 9997 FORMAT( 'Bad ', A6, ' parameters: going on to next test case.' ) + 9996 FORMAT( 'Unable to perform ', A, ': need TOTMEM of at least', + $ I11 ) + 9995 FORMAT( 'TIME N NB P Q Fct Time Inv Time ', + $ ' MFLOPS Cond Resid CHECK' ) + 9994 FORMAT( '---- ----- --- ----- ----- -------- -------- ', + $ '-------- ------- ----- ----- ------' ) + 9993 FORMAT( A4, 1X, I5, 1X, I5, 1X, I5, 1X, I5, 1X, F8.2, 1X, F8.2, + $ 1X, F12.2, 1X, F7.1, 1X, F7.2, 1X, A6 ) + 9992 FORMAT( 'Finished ', I6, ' tests, with the following results:' ) + 9991 FORMAT( I5, ' tests completed and passed residual checks.' ) + 9990 FORMAT( I5, ' tests completed without checking.' ) + 9989 FORMAT( I5, ' tests completed and failed residual checks.' ) + 9988 FORMAT( I5, ' tests skipped because of illegal input values.' ) + 9987 FORMAT( 'END OF TESTS.' ) + 9986 FORMAT( A ) + 9985 FORMAT( '----------Test-',I3,' Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9983 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') +* + STOP +* +* End of PCINVDRIVER +* + END diff --git a/TESTING/LIN/pclltdriver.f b/TESTING/LIN/pclltdriver.f index 91bf0fc0..a8f7a487 100644 --- a/TESTING/LIN/pclltdriver.f +++ b/TESTING/LIN/pclltdriver.f @@ -4,6 +4,7 @@ PROGRAM PCLLTDRIVER * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======= @@ -140,7 +141,7 @@ PROGRAM PCLLTDRIVER * #ifdef DYNAMIC_WORK_MEM_ALLOC allocate(MEM(MEMSIZ)) -#endif +#endif CALL BLACS_PINFO( IAM, NPROCS ) IASEED = 100 IBSEED = 200 @@ -208,6 +209,7 @@ PROGRAM PCLLTDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR( 1 ) = 0 IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -218,6 +220,7 @@ PROGRAM PCLLTDRIVER $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * @@ -277,12 +280,26 @@ PROGRAM PCLLTDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else +* If N < 0 in LLT.dat file then DESCINIT API sets IERR( 1 ) = -2 + IF( N.LT.0 .AND. IERR( 1 ).EQ.-2 ) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9984 ) 'N' + ELSE IF( IERR( 1 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -400,7 +417,24 @@ PROGRAM PCLLTDRIVER IF( INFO.NE.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = * ) 'PCPOTRF INFO=', INFO - KFAIL = KFAIL + 1 +* If N < 0 in LLT.dat file then PCPOTRF API sets INFO = -2 + IF (N.LT.0 .AND. INFO.EQ.-2) THEN +* If PCPOTRF is returning correct error +* code we need to pass this case + WRITE( NOUT, FMT = 9983 ) 'PCPOTRF' + KPASS = KPASS + 1 + ELSE +* For other error code we will mark test case as fail + KFAIL = KFAIL + 1 + END IF + RCOND = ZERO + GO TO 60 + ELSE IF (N.EQ.0) THEN +* If N = 0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API we need to pass this case + WRITE( NOUT, FMT = 9982 ) 'PCPOTRF' + KPASS = KPASS + 1 RCOND = ZERO GO TO 60 END IF @@ -493,6 +527,13 @@ PROGRAM PCLLTDRIVER CALL DESCINIT( DESCB, N, NRHS, NB, NBRHS, 0, 0, $ ICTXT, MAX( 1, NP )+IMIDPAD, $ IERR( 1 ) ) +* If NRHS < 0 in LLT.dat file then +* DESCINIT API sets IERR( 1 ) = -3 + IF (NRHS.LT.0 .AND. IERR( 1 ).EQ.-3 ) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9984 ) 'NRHS' + END IF * * move IPW to allow room for RHS * @@ -599,6 +640,23 @@ PROGRAM PCLLTDRIVER * CALL SLTIMER( 2 ) * + IF( INFO.NE.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = * ) 'PCPOTRS INFO=', INFO +* If NRHS < 0 in LLT.dat file then +* PCPOTRS API sets INFO = -3 + IF( NRHS.LT.0 .AND. INFO.EQ.-3 ) THEN +* If PCPOTRS is returning correct error code then +* we need to pass this case + WRITE( NOUT, FMT = 9983 ) 'PCPOTRS' + KPASS = KPASS + 1 + ELSE +* For other error code we will mark test case as fail + KFAIL = KFAIL + 1 + END IF + GO TO 60 + END IF + IF( CHECK ) THEN * * check for memory overwrite @@ -919,6 +977,11 @@ PROGRAM PCLLTDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - ', A4, '|| / (||A|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Ax-b||/(||x||*||A||*eps*N) ', F25.7 ) + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, we will handle this case from ', + $ 'ScaLAPACK API.') + 9983 FORMAT( A, ' returned correct error code. Passing this case.') + 9982 FORMAT( 'This is safe exit from ', A, ' API. Passing this case.') * STOP * diff --git a/TESTING/LIN/pclsdriver.f b/TESTING/LIN/pclsdriver.f index f84d045f..bf36f326 100644 --- a/TESTING/LIN/pclsdriver.f +++ b/TESTING/LIN/pclsdriver.f @@ -3,7 +3,8 @@ PROGRAM PCLSDRIVER * -- ScaLAPACK routine (version 1.7) -- * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. -* August 14, 2001 +* August 14, 2001 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======= @@ -60,6 +61,7 @@ PROGRAM PCLSDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, $ LLD_, MB_, M_, NB_, N_, RSRC_ @@ -133,6 +135,16 @@ PROGRAM PCLSDRIVER DATA KTESTS, KPASS, KFAIL, KSKIP / 4*0 / * .. * .. Executable Statements .. +* +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X + * * Get starting information * @@ -148,6 +160,35 @@ PROGRAM PCLSDRIVER $ NNBR, NBRVAL, NTESTS, NGRIDS, PVAL, NTESTS, QVAL, $ NTESTS, THRESH, MEM, IAM, NPROCS ) CHECK = ( THRESH.GE.0.0E+0 ) + +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do * * Print headings * @@ -208,15 +249,17 @@ PROGRAM PCLSDRIVER * Make sure matrix information is correct * IERR( 1 ) = 0 - IF( M.LT.1 ) THEN +#ifdef ENABLE_DRIVER_CHECK + IF( M.LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'M', M IERR( 1 ) = 1 - ELSE IF( N.LT.1 ) THEN + ELSE IF( N.LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Make sure no one had error * @@ -282,12 +325,35 @@ PROGRAM PCLSDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 70 END IF +#else +* If M < 0, DESCINIT API sets IERR( 1 ) = -2 +* If N < 0, DESCINIT API sets IERR( 1 ) = -3 +* When M/N < 0, LDA is Negative, DESCINIT IERR( 1 ) = -8 + IF( M.LT.0 .AND. (IERR( 1 ).EQ.-2 .OR. + $ IERR( 1 ).EQ. -8 .OR. IERR(1).EQ.-12 )) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9985 ) 'M' + ELSE IF (N.LT.0 .AND. (IERR( 1 ).EQ.-3 .OR. + $ IERR( 1 ).EQ. -8 .OR. IERR(1).EQ.-12 )) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9985 ) 'N' + ELSE IF( IERR( 1 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 70 + END IF +#endif * DO 60 ISCALE = 1, 3 * @@ -324,7 +390,7 @@ PROGRAM PCLSDRIVER GO TO 70 END IF * - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. N.GT.0 ) THEN CALL PCFILLPAD( ICTXT, MP, NQ, MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, $ PADVAL ) @@ -336,10 +402,12 @@ PROGRAM PCLSDRIVER * * Generate the matrix A and calculate its 1-norm * - CALL PCQRT13( ISCALE, M, N, MEM( IPA ), 1, 1, + IF( M.GT.0 .AND. N.GT.0 ) THEN + CALL PCQRT13( ISCALE, M, N, MEM( IPA ), 1, 1, $ DESCA, ANORM, IASEED, MEM( IPW ) ) + END IF * - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. N.GT.0) THEN CALL PCCHEKPAD( ICTXT, 'PCQRT13', MP, NQ, $ MEM( IPA-IPREPAD ), DESCA( LLD_ ), $ IPREPAD, IPOSTPAD, PADVAL ) @@ -400,12 +468,41 @@ PROGRAM PCLSDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 2, 1, IERR, $ 2, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 .OR. IERR( 2 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else + IF (NRHS.LT.0 .AND. (IERR( 1 ).EQ.-3 .OR. + $ IERR(1) .EQ. -12)) THEN +* If DESCINIT is returns correct error code then +* do nothing + WRITE( NOUT, FMT = 9985 ) 'NRHS' + ELSE IF (N.LT.0 .AND. (IERR( 1 ).EQ.-2 .OR. + $ IERR( 1 ).EQ. -8 .OR. + $ IERR( 2 ).EQ.-2 .OR. + $ IERR( 2 ).EQ. -8) ) THEN +* If DESCINIT is returns correct error code then +* do nothing + WRITE( NOUT, FMT = 9985 ) 'N' + ELSE IF (M.LT.0 .AND. (IERR( 1 ).EQ.-2 .OR. + $ IERR( 1 ).EQ. -8 .OR. + $ IERR( 2 ).EQ. -2 .OR. + $ IERR( 2 ).EQ. -8)) THEN +* If DESCINIT is returns correct error code then +* do nothing + WRITE( NOUT, FMT = 9985 ) 'M' + ELSE IF( IERR( 1 ).LT.0 .OR. + $ IERR( 2 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif * * Check for enough memory * @@ -437,8 +534,10 @@ PROGRAM PCLSDRIVER * * Generate RHS * - IF( TPSD ) THEN - CALL PCMATGEN( ICTXT, 'No', 'No', + IF (M.GT.0 .AND. N.GT.0 .AND. + $ NRHS.GT.0) THEN + IF( TPSD ) THEN + CALL PCMATGEN( ICTXT, 'No', 'No', $ DESCW( M_ ), DESCW( N_ ), $ DESCW( MB_ ), DESCW( NB_ ), $ MEM( IPW ), DESCW( LLD_ ), @@ -446,8 +545,8 @@ PROGRAM PCLSDRIVER $ DESCW( CSRC_ ), IBSEED, 0, $ MP, 0, NRHSQ, MYROW, MYCOL, $ NPROW, NPCOL ) - ELSE - CALL PCMATGEN( ICTXT, 'No', 'No', + ELSE + CALL PCMATGEN( ICTXT, 'No', 'No', $ DESCW( M_ ), DESCW( N_ ), $ DESCW( MB_ ), DESCW( NB_ ), $ MEM( IPW ), DESCW( LLD_ ), @@ -455,9 +554,10 @@ PROGRAM PCLSDRIVER $ DESCW( CSRC_ ), IBSEED, 0, $ NP, 0, NRHSQ, MYROW, MYCOL, $ NPROW, NPCOL ) + END IF END IF -* - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. N.GT.0 .AND. + $ NRHS.GT.0) THEN CALL PCFILLPAD( ICTXT, MNP, NRHSQ, $ MEM( IPX-IPREPAD ), $ DESCX( LLD_ ), IPREPAD, @@ -474,22 +574,29 @@ PROGRAM PCLSDRIVER $ IPOSTPAD, PADVAL ) END IF END IF -* - DO 10 JJ = 1, NRHS - CALL PSCNRM2( NCOLS, BNORM, MEM( IPW ), + IF( M.GT.0 .AND. N.GT.0 .AND. + $ NRHS.GT.0 ) THEN + DO 10 JJ = 1, NRHS + CALL PSCNRM2( NCOLS, BNORM, MEM( IPW ), $ 1, JJ, DESCW, 1 ) - IF( BNORM.GT.RZERO ) - $ CALL PCSSCAL( NCOLS, RONE / BNORM, - $ MEM( IPW ), 1, JJ, DESCW, - $ 1 ) + IF( BNORM.GT.RZERO ) + $ CALL PCSSCAL( NCOLS, RONE / BNORM, + $ MEM( IPW ), 1, JJ, + $ DESCW, 1 ) 10 CONTINUE + END IF * - CALL PCGEMM( TRANS, 'N', NROWS, NRHS, NCOLS, + IF (M.GE.0 .AND. N.GE.0 .AND. + $ NRHS.GE.0) THEN + CALL PCGEMM( TRANS, 'N', NROWS, + $ NRHS, NCOLS, $ ONE, MEM( IPA ), 1, 1, DESCA, $ MEM( IPW ), 1, 1, DESCW, ZERO, $ MEM( IPX ), 1, 1, DESCX ) + END IF * - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. N.GT.0 .AND. + $ NRHS.GT.0 ) THEN * * check for memory overwrite * @@ -594,7 +701,8 @@ PROGRAM PCLSDRIVER GO TO 30 END IF * - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. N.GT.0 .AND. + $ NRHS .GT.0 ) THEN * * Make the copy of the right hand side * @@ -631,7 +739,14 @@ PROGRAM PCLSDRIVER * CALL SLTIMER( 1 ) * - IF( CHECK ) THEN + IF( (N .EQ. 0 .OR. M.EQ.0 .OR. + $ NRHS .EQ. 0 ) .AND. INF0.EQ.0) THEN +* If M = 0 or N =0 this is the case of +* safe exit, early return from ScaLAPACK API. + WRITE( NOUT, FMT = 9983 ) 'PCGELS' + END IF + IF( CHECK .AND. M.GT.0 .AND. + $ N.GT.0 .AND. NRHS.GT.0 ) THEN * * check for memory overwrite * @@ -651,14 +766,20 @@ PROGRAM PCLSDRIVER * * Regenerate A in place for testing and next * iteration + + IF(M.GT.0 .AND. N.GT.0 .AND. NRHS.GT.0) THEN * - CALL PCQRT13( ISCALE, M, N, MEM( IPA ), 1, 1, - $ DESCA, ANORM, IASEED, + CALL PCQRT13( ISCALE, M, N, MEM( IPA ), + $ 1, 1, DESCA, ANORM, IASEED, $ MEM( IPW ) ) + + END IF * * check the solution to rhs * - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. + $ N.GT.0 .AND. NRHS.GT.0 .AND. + $ .NOT.(EX_FLAG) ) THEN * * Am I going to call PCQRT17 ? * @@ -842,7 +963,9 @@ PROGRAM PCLSDRIVER * Call PCQRT14 * IF( ( M.GE.N .AND. TPSD ) .OR. - $ ( M.LT.N .AND. ( .NOT.TPSD ) ) ) THEN + $ ( M.LT.N .AND. (.NOT.TPSD) ) .AND. + $ ( M.GT.0 .AND. N.GT.0 .AND. + $ NRHS.GT.0 ) ) THEN * IPW = IPB * @@ -933,7 +1056,15 @@ PROGRAM PCLSDRIVER * did not pass the threshold. * PASSED = 'PASSED' - DO 20 II = 1, 2 + IF((M.EQ.0 .OR. N.EQ.0 .OR. + $ NRHS .EQ. 0) .AND. INF0 .EQ. 0) THEN +* If M = 0, N =0, NRHS =0 this is the case of +* early return from ScaLAPACK API. +* Pass this case + KPASS = KPASS + 1 + SRESID = SRESID - SRESID + ELSE + DO 20 II = 1, 2 IF( ( RESULT( II ).GE.THRESH ) .AND. $ ( RESULT( II )-RESULT( II ).EQ.0.0E+0 $ ) ) THEN @@ -946,16 +1077,75 @@ PROGRAM PCLSDRIVER ELSE KPASS = KPASS + 1 END IF - 20 CONTINUE + 20 CONTINUE + END IF * ELSE * -* By-pass the solve check -* - KPASS = KPASS + 1 - SRESID = SRESID - SRESID - PASSED = 'BYPASS' -* + IF((M.EQ.0 .OR. N.EQ.0 .OR. + $ NRHS .EQ. 0) .AND. INF0 .EQ. 0) THEN +* If M = 0, N =0, NRHS =0 this is the case of +* early return from ScaLAPACK API. +* Pass this case + KPASS = KPASS + 1 + SRESID = SRESID - SRESID + PASSED = 'PASSED' +* +* When N < 0, PZGELS returns INF0 = -2 +* When M < 0, PZGELS returns INF0 = -3 +* When NRHS < 0, PZGELS returns INF0 = -4 +* + ELSE IF( (M .LT. 0 .AND. + $ INFO .EQ. -2 ) .OR. + $ (N .LT. 0 .AND. + $ INFO .EQ. -3 ) .OR. + $ (NRHS .LT. 0 .AND. + $ (INFO.EQ. -14 .OR. + $ INFO.EQ. -4 ))) THEN +* +* If PZGELS returns correct error code +* pass this case + WRITE( NOUT, FMT = 9984 ) 'PZGELS' + KPASS = KPASS + 1 + SRESID = SRESID - SRESID + PASSED = 'PASSED' +* Extreme value validation check + ELSE IF( EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, M + DO JK = 1, N + X = MEM(IK*N + JK) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF + ELSE + KPASS = KPASS + 1 + SRESID = SRESID - SRESID + PASSED = 'BYPASS' + + END IF END IF * * Gather maximum of all CPU and WALL clock @@ -1084,6 +1274,12 @@ PROGRAM PCLSDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( ' TRANS=''', A1, ''', M=', I5, ', N=', I5, ', NRHS=', I4, $ ', NB=', I4, ', type', I2, ', test(', I2, ')=', G12.5 ) + 9985 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handeld by', + $ 'the PCGELS API.') + 9984 FORMAT( A, ' returned correct error code. Passing this case.') + 9983 FORMAT( 'Early return case. Safe exit from ', A, 'API' + $ ' Passing this case.') * STOP * diff --git a/TESTING/LIN/pcludriver.f b/TESTING/LIN/pcludriver.f index c4382411..e395543f 100644 --- a/TESTING/LIN/pcludriver.f +++ b/TESTING/LIN/pcludriver.f @@ -4,6 +4,7 @@ PROGRAM PCLUDRIVER * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======== @@ -66,6 +67,7 @@ PROGRAM PCLUDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, $ LLD_, MB_, M_, NB_, N_, RSRC_ @@ -141,6 +143,15 @@ PROGRAM PCLUDRIVER * .. * .. Executable Statements .. * +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X +* * Get starting information * #ifdef DYNAMIC_WORK_MEM_ALLOC @@ -154,6 +165,35 @@ PROGRAM PCLUDRIVER $ NTESTS, NGRIDS, PVAL, NTESTS, QVAL, NTESTS, THRESH, $ EST, MEM, IAM, NPROCS ) CHECK = ( THRESH.GE.0.0E+0 ) + +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do * * Print headings * @@ -214,6 +254,7 @@ PROGRAM PCLUDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR( 1 ) = 0 IF( M.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -224,6 +265,7 @@ PROGRAM PCLUDRIVER $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * @@ -284,12 +326,31 @@ PROGRAM PCLUDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else +* If M < 0 in LU.dat file then DESCINIT API sets IERR( 1 ) = -2 +* If N < 0 in LU.dat file then DESCINIT API sets IERR( 1 ) = -3 + IF( M.LT.0 .AND. IERR( 1 ).EQ.-2 ) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9984 ) 'M' + ELSE IF (N.LT.0 .AND. IERR( 1 ).EQ.-3 ) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9984 ) 'N' + ELSE IF( IERR( 1 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -405,12 +466,36 @@ PROGRAM PCLUDRIVER IF( INFO.NE.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = * ) 'PCGETRF INFO=', INFO - KFAIL = KFAIL + 1 +* If M < 0 in LU.dat file then PCGETRF API sets INFO = -1 +* If N < 0 in LU.dat file then PCGETRF API sets INFO = -2 + IF ((M.LT.0 .AND. INFO.EQ.-1) .OR. + $ (N.LT.0 .AND. INFO.EQ.-2)) THEN +* If PCGETRF is returning correct error +* code we need to pass this case + WRITE( NOUT, FMT = 9983 ) 'PCGETRF' + KPASS = KPASS + 1 + RCOND = ZERO + GO TO 30 + ELSE IF (INFO.GT.0 .AND. EX_FLAG) THEN + WRITE(*,*) 'PCGETRF INFO=', INFO +* do nothing, skip residual calculation + ELSE +* For other error code we will mark test case as fail + KFAIL = KFAIL + 1 + RCOND = ZERO + GO TO 30 + END IF + ELSE IF (M.EQ.0 .OR. N.EQ.0) THEN +* If M = 0 or N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API we need to pass this case + WRITE( NOUT, FMT = 9982 ) 'PCGETRF' + KPASS = KPASS + 1 RCOND = ZERO GO TO 30 END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN * * Check for memory overwrite in LU factorization * @@ -429,7 +514,7 @@ PROGRAM PCLUDRIVER NRHS = 0 NBRHS = 0 * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN * * Compute FRESID = ||A - P*L*U|| / (||A|| * N * eps) * @@ -468,11 +553,43 @@ PROGRAM PCLUDRIVER * ELSE * -* Don't perform the checking, only timing -* - KPASS = KPASS + 1 - FRESID = FRESID - FRESID - PASSED = 'BYPASS' +* Extreme-value validation check + IF( EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, M + DO JK = 1, N + X = MEM(IK*N + JK) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF + ELSE +* Don't perform the checking, only timing + FRESID = FRESID - FRESID + KPASS = KPASS + 1 + PASSED = 'BYPASS' + END IF * END IF * @@ -567,7 +684,7 @@ PROGRAM PCLUDRIVER GO TO 30 END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN CALL PCFILLPAD( ICTXT, LWORK, 1, $ MEM( IPW-IPREPAD ), LWORK, $ IPREPAD, IPOSTPAD, PADVAL ) @@ -583,7 +700,7 @@ PROGRAM PCLUDRIVER $ ANORM1, RCOND, MEM( IPW ), LWORK, $ MEM( IPW2 ), LRWORK, INFO ) * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN CALL PCCHEKPAD( ICTXT, 'PCGECON', NP, NQ, $ MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, @@ -620,12 +737,26 @@ PROGRAM PCLUDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 10 END IF +#else +* If NRHS < 0 in LU.dat file then DESCINIT API sets IERR( 1 ) = -3 + IF (NRHS.LT.0 .AND. IERR( 1 ).EQ.-3 ) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9984 ) 'NRHS' + ELSE IF( IERR( 1 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF +#endif * * move IPW to allow room for RHS * @@ -691,7 +822,7 @@ PROGRAM PCLUDRIVER $ MYRHS, MYROW, MYCOL, NPROW, $ NPCOL ) * - IF( CHECK ) + IF( CHECK .AND. .NOT.(EX_FLAG)) $ CALL PCFILLPAD( ICTXT, NP, MYRHS, $ MEM( IPB-IPREPAD ), $ DESCB( LLD_ ), IPREPAD, @@ -706,7 +837,7 @@ PROGRAM PCLUDRIVER $ DESCB( CSRC_ ), IBSEED, 0, NP, $ 0, MYRHS, MYROW, MYCOL, NPROW, $ NPCOL ) - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN CALL PCFILLPAD( ICTXT, NP, MYRHS, $ MEM( IPB0-IPREPAD ), $ DESCB( LLD_ ), IPREPAD, @@ -733,7 +864,26 @@ PROGRAM PCLUDRIVER * CALL SLTIMER( 2 ) * - IF( CHECK ) THEN + IF( INFO.NE.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = * ) 'PCGETRS INFO=', INFO +* If NRHS < 0 in LU.dat file then PCGETRS API sets INFO = -3 + IF( NRHS.LT.0 .AND. INFO.EQ.-3 ) THEN +* If PCGETRS is returning correct error code we need to pass this case + WRITE( NOUT, FMT = 9983 ) 'PCGETRS' + KPASS = KPASS + 1 + GO TO 30 + ELSE IF( INFO .GT. 0 .AND. EX_FLAG) THEN + WRITE(*,*) 'PCGETRS INFO=', INFO +* Do Nothing, Pass this case in residual calculation + ELSE +* For other error code we will mark test case as fail + KFAIL = KFAIL + 1 + GO TO 30 + END IF + END IF +* + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN * * check for memory overwrite * @@ -787,9 +937,42 @@ PROGRAM PCLUDRIVER PASSED = 'FAILED' END IF ELSE - KPASS = KPASS + 1 - SRESID = SRESID - SRESID - PASSED = 'BYPASS' +* Extreme value validation check + IF( EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, M + DO JK = 1, N + X = MEM(IK*N + JK) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF + ELSE + SRESID = SRESID - SRESID + KPASS = KPASS + 1 + PASSED = 'BYPASS' + END IF END IF * IF( EST ) THEN @@ -823,7 +1006,7 @@ PROGRAM PCLUDRIVER GO TO 10 END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN CALL PCFILLPAD( ICTXT, LWORK, 1, $ MEM( IPW-IPREPAD ), $ LWORK, IPREPAD, IPOSTPAD, @@ -846,7 +1029,7 @@ PROGRAM PCLUDRIVER $ MEM( IPW ), LWORK, MEM( IPW2 ), $ LRWORK, INFO ) * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN CALL PCCHEKPAD( ICTXT, 'PCGERFS', NP, $ NQ, MEM( IPA0-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, @@ -979,7 +1162,8 @@ PROGRAM PCLUDRIVER 10 CONTINUE 20 END DO * - IF( CHECK.AND.( SRESID.GT.THRESH ) ) THEN + IF( CHECK.AND.( SRESID.GT.THRESH ) .AND. + $ .NOT.(EX_FLAG) ) THEN * * Compute fresid = ||A - P*L*U|| / (||A|| * N * eps) * @@ -1059,6 +1243,11 @@ PROGRAM PCLUDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - P*L*U|| / (||A|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Ax-b||/(||x||*||A||*eps*N) ', F25.7 ) + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, we will handle this case from ', + $ 'ScaLAPACK API.') + 9983 FORMAT( A, ' returned correct error code. Passing this case.') + 9982 FORMAT( 'This is safe exit from ', A, ' API. Passing this case.') * STOP * diff --git a/TESTING/LIN/pcmatgen.f b/TESTING/LIN/pcmatgen.f index 47c0413d..bb282744 100644 --- a/TESTING/LIN/pcmatgen.f +++ b/TESTING/LIN/pcmatgen.f @@ -6,6 +6,7 @@ SUBROUTINE PCMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * .. Scalar Arguments .. CHARACTER*1 AFORM, DIAG @@ -119,7 +120,7 @@ SUBROUTINE PCMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0, ZERO = 0.0E+0 ) * .. * .. Local Scalars .. - LOGICAL SYMM, HERM, TRAN + LOGICAL SYMM, HERM, TRAN, EXT_FLAG INTEGER I, IC, IK, INFO, IOFFC, IOFFR, IR, J, JK, $ JUMP1, JUMP2, JUMP3, JUMP4, JUMP5, JUMP6, $ JUMP7, MAXMN, MEND, MOFF, MP, MRCOL, MRROW, @@ -142,8 +143,15 @@ SUBROUTINE PCMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * .. External Functions .. LOGICAL LSAME INTEGER ICEIL, NUMROC + INTEGER CNT1, CNT2, CNT, TOT_CNT, DIV_FACTOR, REGION REAL PSRAND EXTERNAL ICEIL, NUMROC, LSAME, PSRAND +* + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .false. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 * .. * .. Executable Statements .. * @@ -154,6 +162,64 @@ SUBROUTINE PCMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, SYMM = LSAME( AFORM, 'S' ) HERM = LSAME( AFORM, 'H' ) TRAN = LSAME( AFORM, 'T' ) + EXT_FLAG = .FALSE. + +* Take command-line arguments if requested +* + +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EXT_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EXT_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do + + IF ( INF_PERCENT + NAN_PERCENT > 100) THEN + print *,"Sum of INF and NaN is", INF_PERCENT+NAN_PERCENT,"%" + help_flag = .true. + END IF + IF ( INF_PERCENT < 0 .OR. NAN_PERCENT < 0) THEN + print *, "Negative INF / NaN value is not allowed" + help_flag = .true. + END IF + +* Display help message if requested + IF (help_flag .AND. IAM.EQ.0) THEN + print *, "" + print *, "Options:" + print *, " -h, --help Display this help message" + print *, " -inf INF percentage in input", + $ " matrix (default: 0 %)" + print *, " -nan NaN percentage in input", + $ " matrix (default: 0 %)" + print *, "" + print *, " Note: INF + NaN values in input matrix", + $ " should be in the range of 0-100 %" + print *, "" + stop + END IF * INFO = 0 IF( .NOT.LSAME( DIAG, 'D' ) .AND. @@ -213,9 +279,46 @@ SUBROUTINE PCMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, JSEED(1) = ISEED JSEED(2) = 0 * +* Extreme-value parameter caclculations + IF( LSAME( DIAG, 'D' ) ) THEN + DIV_FACTOR = 2 + ELSE + DIV_FACTOR = 4 + END IF +* Find type of matrix to identify where to fill INF/NAN, +* If UPPER_TRIANGULAR_MATRIX., start above DIAG + IF( LSAME(AFORM, 'U' ) ) THEN + REGION = (IRNUM * ICNUM)/DIV_FACTOR +* If LOWER_TRIANGULAR/GENERAL MATRIX, start at beginning + ELSE + REGION = 1 + END IF + IF (EXT_FLAG) THEN + ZERO1 = 0.0E0 + ONE1 = 1.0E0 +* Calculate the number of NANs/INFs per grid + CNT1 = (IRNUM * ICNUM * NAN_PERCENT)/100 + CNT2 = (IRNUM * ICNUM * INF_PERCENT)/100 + CNT1 = CEILING(REAL(CNT1)) + CNT2 = CEILING(REAL(CNT2)) +* When Percentage requested by the user is low +* Replace atleast one element with NAN/INF +* Applicable for smaller matrices [2x2] + IF(NAN_PERCENT .GT. 0 .AND. CNT1 .EQ. 0 ) THEN + CNT1 = CNT1 + 1 + PRINT *, 'NAN Percentage is too low,', + $ 'Including one NAN element' + END IF + IF(INF_PERCENT .GT. 0 .AND. CNT2 .EQ. 0 ) THEN + CNT2 = CNT2 + 1 + PRINT *, 'INF Percentage is too low,', + $ 'Including one INF element' + END IF + END IF +* * Symmetric or Hermitian matrix will be generated. * - IF( SYMM.OR.HERM ) THEN + IF( (SYMM.OR.HERM) .AND. .NOT.(EXT_FLAG) ) THEN * * First, generate the lower triangular part (with diagonal block) * @@ -397,7 +500,8 @@ SUBROUTINE PCMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * * (Conjugate) Transposed matrix A will be generated. * - ELSE IF( TRAN .OR. LSAME( AFORM, 'C' ) ) THEN + ELSE IF(( TRAN .OR. LSAME( AFORM, 'C' )) .AND. + $ .NOT.(EXT_FLAG) ) THEN * JUMP1 = 1 JUMP2 = 2*NQNB @@ -470,6 +574,9 @@ SUBROUTINE PCMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * A random matrix is generated. * ELSE + + TOT_CNT = 0 + CNT = 0 * JUMP1 = 1 JUMP2 = 2*NPMB @@ -506,8 +613,21 @@ SUBROUTINE PCMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, IOFFR = ((IR-1)*NPROW+MRROW) * MB DO 250 J = 1, MB IF( IK .GT. IRNUM ) GO TO 270 - A(IK,JK) = CMPLX( ONE - TWO*PSRAND(0), - $ ONE - TWO*PSRAND(0) ) +* Replace with NANs/INFs for extreme values + IF(EXT_FLAG .AND. CNT .LE. (CNT1 + CNT2) .AND. + $ TOT_CNT .GE. REGION) THEN + IF ( CNT .LT. CNT1) THEN + A(IK, JK) = CMPLX(ZERO1/ZERO1,ZERO1/ZERO1) + ELSE IF ( CNT .LT. (CNT1 + CNT2)) THEN + A(IK, JK) = CMPLX(ONE1/ZERO1, ONE1/ZERO1) + END IF + CNT = CNT + 1 + TOT_CNT = TOT_CNT + 1 + ELSE + A(IK,JK) = CMPLX( ONE - TWO*PSRAND(0), + $ ONE - TWO*PSRAND(0) ) + TOT_CNT = TOT_CNT + 1 + END IF IK = IK + 1 250 CONTINUE CALL JUMPIT( IA2, IC2, IB1, IRAN2 ) @@ -533,7 +653,7 @@ SUBROUTINE PCMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, IB3(2) = IRAN4(2) 290 CONTINUE 300 CONTINUE - END IF + END IF * * Diagonally dominant matrix will be generated. * @@ -544,6 +664,9 @@ SUBROUTINE PCMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, RETURN END IF * + + CNT = 0 + TOT_CNT = 0 MAXMN = MAX(M, N) JK = 1 DO 340 IC = NOFF+1, NEND @@ -554,12 +677,23 @@ SUBROUTINE PCMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, IF( IOFFC.EQ.IOFFR ) THEN DO 310 J = 0, MB-1 IF( IK .GT. IRNUM ) GO TO 330 - IF( HERM ) THEN + IF(EXT_FLAG .AND. CNT .LE. (CNT1 + CNT2) + $ .AND. TOT_CNT .GT. (N/2) ) THEN + IF ( CNT .LT. CNT1) THEN + A(IK, JK+J) = CMPLX(ZERO1/ZERO1,ZERO1/ZERO1) + ELSE IF ( CNT .LT. (CNT1 + CNT2)) THEN + A(IK, JK+J) = CMPLX(ONE1/ZERO1, ONE1/ZERO1) + END IF + CNT = CNT + 1 + TOT_CNT = TOT_CNT + 1 + ELSE IF( HERM ) THEN A(IK,JK+J) = CMPLX( - $ ABS(REAL(A(IK,JK+J)))+2*MAXMN, ZERO ) + $ ABS(REAL(A(IK,JK+J)))+2*MAXMN, ZERO) + TOT_CNT = TOT_CNT + 1 ELSE A(IK,JK+J) = CMPLX( ABS(REAL(A(IK,JK+J)))+MAXMN, - $ ABS(AIMAG(A(IK,JK+J)))+ MAXMN ) + $ ABS(AIMAG(A(IK,JK+J)))+ MAXMN) + TOT_CNT = TOT_CNT + 1 END IF IK = IK + 1 310 CONTINUE diff --git a/TESTING/LIN/pcqrdriver.f b/TESTING/LIN/pcqrdriver.f index 5a1c69a8..2e770bcc 100644 --- a/TESTING/LIN/pcqrdriver.f +++ b/TESTING/LIN/pcqrdriver.f @@ -4,6 +4,7 @@ PROGRAM PCQRDRIVER * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 28, 2001 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======= @@ -64,6 +65,7 @@ PROGRAM PCQRDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, $ LLD_, MB_, M_, NB_, N_, RSRC_ @@ -94,6 +96,7 @@ PROGRAM PCQRDRIVER CHARACTER*8 ROUTCHK CHARACTER*80 OUTFILE LOGICAL CHECK + LOGICAL M_INVALID, N_INVALID INTEGER I, IAM, IASEED, ICTXT, IMIDPAD, INFO, IPA, $ IPOSTPAD, IPPIV, IPREPAD, IPTAU, IPRW, IPW, J, $ K, KFAIL, KPASS, KSKIP, KTESTS, L, LIPIV, @@ -103,6 +106,7 @@ PROGRAM PCQRDRIVER $ WORKFCT, WORKRFCT, WORKSIZ REAL ANORM, FRESID, THRESH DOUBLE PRECISION NOPS, TMFLOPS + CHARACTER*8 API_NAME * .. * .. Arrays .. CHARACTER*2 FACTOR( NTESTS ) @@ -138,6 +142,16 @@ PROGRAM PCQRDRIVER * .. * .. Data Statements .. DATA KTESTS, KPASS, KFAIL, KSKIP /4*0/ +* +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X +* * .. * .. Executable Statements .. * @@ -153,6 +167,37 @@ PROGRAM PCQRDRIVER $ NTESTS, NGRIDS, PVAL, NTESTS, QVAL, NTESTS, $ THRESH, MEM, IAM, NPROCS ) CHECK = ( THRESH.GE.0.0E+0 ) + M_INVALID = .TRUE. + N_INVALID = .TRUE. +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* * * Loop over the different factorization types * @@ -250,6 +295,7 @@ PROGRAM PCQRDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR(1) = 0 IF( M.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -260,17 +306,20 @@ PROGRAM PCQRDRIVER $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Make sure no one had error * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'matrix' KSKIP = KSKIP + 1 GO TO 20 END IF +#endif * * Loop over different blocking sizes * @@ -347,12 +396,41 @@ PROGRAM PCQRDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, $ 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 10 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 .OR. + $ IERR(1) .EQ. -3 .OR. IERR(1) .EQ. -12 )) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid M and N +* -4, -8 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9984 ) 'N' +* disable extreme value case when N < 0 + EX_FLAG = .FALSE. + ELSE IF(M .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 .OR. + $ IERR(1) .EQ. -3 .OR. IERR(1) .EQ. -12 )) THEN + WRITE( NOUT, FMT = 9984 ) 'M' +* disable extreme value case when M < 0 + EX_FLAG = .FALSE. + ELSE IF(M .EQ. 0 .OR. N .EQ. 0) THEN +* disable extreme value case when M < 0 + EX_FLAG = .FALSE. + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF +#endif * * Assign pointers into MEM for ScaLAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -541,7 +619,7 @@ PROGRAM PCQRDRIVER * * Need the Infinity of A for checking * - IF( CHECK ) THEN + IF( CHECK .AND. (N .GT. 0 .AND. M .GT. 0)) THEN CALL PCFILLPAD( ICTXT, MP, NQ, MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, $ PADVAL ) @@ -585,30 +663,35 @@ PROGRAM PCQRDRIVER * Perform QR factorizations * IF( LSAMEN( 2, FACT, 'QR' ) ) THEN + API_NAME = 'PCGEQRF' CALL SLTIMER( 1 ) CALL PCGEQRF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPTAU ), MEM( IPW ), LWORK, $ INFO ) CALL SLTIMER( 1 ) ELSE IF( LSAMEN( 2, FACT, 'QL' ) ) THEN + API_NAME = 'PCGEQLF' CALL SLTIMER( 1 ) CALL PCGEQLF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPTAU ), MEM( IPW ), LWORK, $ INFO ) CALL SLTIMER( 1 ) ELSE IF( LSAMEN( 2, FACT, 'LQ' ) ) THEN + API_NAME = 'PCGELQF' CALL SLTIMER( 1 ) CALL PCGELQF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPTAU ), MEM( IPW ), LWORK, $ INFO ) CALL SLTIMER( 1 ) ELSE IF( LSAMEN( 2, FACT, 'RQ' ) ) THEN + API_NAME = 'PCGERQF' CALL SLTIMER( 1 ) CALL PCGERQF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPTAU ), MEM( IPW ), LWORK, $ INFO ) CALL SLTIMER( 1 ) ELSE IF( LSAMEN( 2, FACT, 'QP' ) ) THEN + API_NAME = 'PCGEQPF' CALL SLTIMER( 1 ) CALL PCGEQPF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPPIV ), MEM( IPTAU ), @@ -616,147 +699,224 @@ PROGRAM PCQRDRIVER $ LRWORK, INFO ) CALL SLTIMER( 1 ) ELSE IF( LSAMEN( 2, FACT, 'TZ' ) ) THEN + API_NAME = 'PCTZRZF' CALL SLTIMER( 1 ) +#ifdef ENABLE_DRIVER_CHECK IF( N.GE.M ) $ CALL PCTZRZF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPTAU ), MEM( IPW ), LWORK, $ INFO ) +#else + IF( N .LT. M ) THEN + WRITE( NOUT, FMT = 9982 ) + END IF + CALL PCTZRZF( M, N, MEM( IPA ), 1, 1, DESCA, + $ MEM( IPTAU ), MEM( IPW ), LWORK, + $ INFO ) +#endif CALL SLTIMER( 1 ) END IF * - IF( CHECK ) THEN + IF( CHECK .AND. (.NOT.(EX_FLAG)) ) THEN * -* Check for memory overwrite in factorization + IF(INFO .EQ. 0 .AND. N .GT. 0 .AND. + $ M .GT. 0) THEN * - CALL PCCHEKPAD( ICTXT, ROUT, MP, NQ, +* +* Check for memory overwrite in factorization +* + CALL PCCHEKPAD( ICTXT, ROUT, MP, NQ, $ MEM( IPA-IPREPAD ), DESCA( LLD_ ), $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PCCHEKPAD( ICTXT, ROUT, LTAU, 1, + CALL PCCHEKPAD( ICTXT, ROUT, LTAU, 1, $ MEM( IPTAU-IPREPAD ), LTAU, $ IPREPAD, IPOSTPAD, PADVAL ) - IF( LSAMEN( 2, FACT, 'QP' ) ) THEN - CALL PCCHEKPAD( ICTXT, ROUT, LIPIV, 1, + IF( LSAMEN( 2, FACT, 'QP' ) ) THEN + CALL PCCHEKPAD( ICTXT, ROUT, LIPIV, 1, $ MEM( IPPIV-IPREPAD ), LIPIV, $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PCCHEKPAD( ICTXT, ROUT, WORKRFCT-IPOSTPAD, - $ 1, MEM( IPRW-IPREPAD ), + CALL PCCHEKPAD( ICTXT, ROUT, + $ WORKRFCT-IPOSTPAD, 1, + $ MEM( IPRW-IPREPAD ), $ WORKRFCT-IPOSTPAD, $ IPREPAD, IPOSTPAD, PADVAL ) - END IF - CALL PCCHEKPAD( ICTXT, ROUT, WORKFCT-IPOSTPAD, 1, - $ MEM( IPW-IPREPAD ), + END IF + CALL PCCHEKPAD( ICTXT, ROUT, WORKFCT-IPOSTPAD, + $ 1, MEM( IPW-IPREPAD ), $ WORKFCT-IPOSTPAD, IPREPAD, $ IPOSTPAD, PADVAL ) - CALL PCFILLPAD( ICTXT, WORKSIZ-IPOSTPAD, 1, + CALL PCFILLPAD( ICTXT, WORKSIZ-IPOSTPAD, 1, $ MEM( IPW-IPREPAD ), $ WORKSIZ-IPOSTPAD, $ IPREPAD, IPOSTPAD, PADVAL ) * - IF( LSAMEN( 2, FACT, 'QR' ) ) THEN + IF( LSAMEN( 2, FACT, 'QR' ) ) THEN * -* Compute residual = ||A-Q*R|| / (||A||*N*eps) +* Compute residual = ||A-Q*R|| / (||A||*N*eps) * - CALL PCGEQRRV( M, N, MEM( IPA ), 1, 1, DESCA, + CALL PCGEQRRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, $ MEM( IPTAU ), MEM( IPW ) ) - CALL PCLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, - $ 1, DESCA, IASEED, ANORM, FRESID, - $ MEM( IPW ) ) - ELSE IF( LSAMEN( 2, FACT, 'QL' ) ) THEN + CALL PCLAFCHK( 'No', 'No', M, N, MEM( IPA ), + $ 1, 1, DESCA, IASEED, ANORM, + $ FRESID, MEM( IPW ) ) + ELSE IF( LSAMEN( 2, FACT, 'QL' ) ) THEN * -* Compute residual = ||A-Q*L|| / (||A||*N*eps) +* Compute residual = ||A-Q*L|| / (||A||*N*eps) * - CALL PCGEQLRV( M, N, MEM( IPA ), 1, 1, DESCA, + CALL PCGEQLRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, $ MEM( IPTAU ), MEM( IPW ) ) - CALL PCLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, - $ 1, DESCA, IASEED, ANORM, FRESID, - $ MEM( IPW ) ) - ELSE IF( LSAMEN( 2, FACT, 'LQ' ) ) THEN + CALL PCLAFCHK( 'No', 'No', M, N, MEM( IPA ), + $ 1, 1, DESCA, IASEED, ANORM, + $ FRESID, MEM( IPW ) ) + ELSE IF( LSAMEN( 2, FACT, 'LQ' ) ) THEN * -* Compute residual = ||A-L*Q|| / (||A||*N*eps) +* Compute residual = ||A-L*Q|| / (||A||*N*eps) * - CALL PCGELQRV( M, N, MEM( IPA ), 1, 1, DESCA, + CALL PCGELQRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, $ MEM( IPTAU ), MEM( IPW ) ) - CALL PCLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, - $ 1, DESCA, IASEED, ANORM, FRESID, - $ MEM( IPW ) ) - ELSE IF( LSAMEN( 2, FACT, 'RQ' ) ) THEN + CALL PCLAFCHK( 'No', 'No', M, N, MEM( IPA ), + $ 1, 1, DESCA, IASEED, ANORM, + $ FRESID, MEM( IPW ) ) + ELSE IF( LSAMEN( 2, FACT, 'RQ' ) ) THEN * -* Compute residual = ||A-R*Q|| / (||A||*N*eps) +* Compute residual = ||A-R*Q|| / (||A||*N*eps) * - CALL PCGERQRV( M, N, MEM( IPA ), 1, 1, DESCA, + CALL PCGERQRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, $ MEM( IPTAU ), MEM( IPW ) ) - CALL PCLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, - $ 1, DESCA, IASEED, ANORM, FRESID, - $ MEM( IPW ) ) - ELSE IF( LSAMEN( 2, FACT, 'QP' ) ) THEN -* -* Compute residual = ||AP-Q*R|| / (||A||*N*eps) -* - CALL PCGEQRRV( M, N, MEM( IPA ), 1, 1, DESCA, - $ MEM( IPTAU ), MEM( IPW ) ) - ELSE IF( LSAMEN( 2, FACT, 'TZ' ) ) THEN -* -* Compute residual = ||A-T*Z|| / (||A||*N*eps) -* - IF( N.GE.M ) THEN - CALL PCTZRZRV( M, N, MEM( IPA ), 1, 1, DESCA, - $ MEM( IPTAU ), MEM( IPW ) ) + CALL PCLAFCHK( 'No', 'No', M, N, MEM( IPA ), + $ 1, 1, DESCA, IASEED, ANORM, + $ FRESID, MEM( IPW ) ) + ELSE IF( LSAMEN( 2, FACT, 'QP' ) ) THEN +* +* Compute residual = ||AP-Q*R|| / (||A||*N*eps) +* + CALL PCGEQRRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, MEM( IPTAU ), MEM( IPW )) + ELSE IF( LSAMEN( 2, FACT, 'TZ' ) ) THEN +* +* Compute residual = ||A-T*Z|| / (||A||*N*eps) +* + IF( N.GE.M ) THEN + CALL PCTZRZRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, MEM( IPTAU ), + $ MEM( IPW ) ) + END IF + CALL PCLAFCHK( 'No', 'No', M, N, MEM( IPA ), + $ 1, 1, DESCA, IASEED, ANORM, + $ FRESID, MEM( IPW ) ) END IF - CALL PCLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, - $ 1, DESCA, IASEED, ANORM, FRESID, - $ MEM( IPW ) ) - END IF * -* Check for memory overwrite +* Check for memory overwrite * - CALL PCCHEKPAD( ICTXT, ROUTCHK, MP, NQ, + CALL PCCHEKPAD( ICTXT, ROUTCHK, MP, NQ, $ MEM( IPA-IPREPAD ), DESCA( LLD_ ), $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PCCHEKPAD( ICTXT, ROUTCHK, LTAU, 1, + CALL PCCHEKPAD( ICTXT, ROUTCHK, LTAU, 1, $ MEM( IPTAU-IPREPAD ), LTAU, $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PCCHEKPAD( ICTXT, ROUTCHK, WORKSIZ-IPOSTPAD, + CALL PCCHEKPAD( ICTXT, ROUTCHK, + $ WORKSIZ-IPOSTPAD, $ 1, MEM( IPW-IPREPAD ), $ WORKSIZ-IPOSTPAD, IPREPAD, $ IPOSTPAD, PADVAL ) * - IF( LSAMEN( 2, FACT, 'QP' ) ) THEN + IF( LSAMEN( 2, FACT, 'QP' ) ) THEN * - CALL PCQPPIV( M, N, MEM( IPA ), 1, 1, DESCA, + CALL PCQPPIV( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPPIV ) ) * -* Check for memory overwrite +* Check for memory overwrite * - CALL PCCHEKPAD( ICTXT, 'PCQPPIV', MP, NQ, + CALL PCCHEKPAD( ICTXT, 'PCQPPIV', MP, NQ, $ MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PCCHEKPAD( ICTXT, 'PCQPPIV', LIPIV, 1, + CALL PCCHEKPAD( ICTXT, 'PCQPPIV', LIPIV, 1, $ MEM( IPPIV-IPREPAD ), LIPIV, $ IPREPAD, IPOSTPAD, PADVAL ) * - CALL PCLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, - $ 1, DESCA, IASEED, ANORM, FRESID, - $ MEM( IPW ) ) + CALL PCLAFCHK( 'No', 'No', M, N, MEM( IPA ), + $ 1, 1, DESCA, IASEED, ANORM, + $ FRESID, MEM( IPW ) ) * -* Check for memory overwrite +* Check for memory overwrite * - CALL PCCHEKPAD( ICTXT, 'PCLAFCHK', MP, NQ, + CALL PCCHEKPAD( ICTXT, 'PCLAFCHK', MP, NQ, $ MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PCCHEKPAD( ICTXT, 'PCLAFCHK', + CALL PCCHEKPAD( ICTXT, 'PCLAFCHK', $ WORKSIZ-IPOSTPAD, 1, $ MEM( IPW-IPREPAD ), $ WORKSIZ-IPOSTPAD, IPREPAD, $ IPOSTPAD, PADVAL ) + END IF END IF * * Test residual and detect NaN result * - IF( LSAMEN( 2, FACT, 'TZ' ) .AND. N.LT.M ) THEN - KSKIP = KSKIP + 1 - PASSED = 'BYPASS' + M_INVALID = M.LT.0 .AND. + $ ((INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'QR')) .OR. + $ (INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'QL')) .OR. + $ (INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'LQ')) .OR. + $ (INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'RQ')) .OR. + $ (INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'QP')) .OR. + $ (INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'TZ' ))) + N_INVALID = N.LT.0 .AND. + $ ((INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'QR')) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'QL')) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'LQ')) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'RQ')) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'QP')) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'TZ' ))) +* + IF( (N.EQ.0 .AND. INFO.EQ.0) .OR. + $ (M.EQ.0 .AND. INFO.EQ.0) ) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) KPASS, API_NAME + PASSED = 'PASSED' +* RE-ENABLE for EX CASE + IF(INF_PERCENT .GT. 0 .OR. + $ NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + GO TO 10 + ELSE IF(M_INVALID .OR. N_INVALID) THEN +* When N < 0/Invalid, INFO = -2 +* When M < 0/Invalid, INFO = -1 +* Expected Error code for N < 0 +* Hence this case can be passed + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9983 ) KPASS, API_NAME + PASSED = 'PASSED' +* RE-ENABLE for EX CASE + IF(INF_PERCENT .GT. 0 .OR. + $ NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + ELSE IF( LSAMEN( 2, FACT, 'TZ' ) .AND. + $ (N.LT.M .AND. INFO.EQ.-2 ) ) THEN + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9983 ) KPASS, API_NAME ELSE IF( FRESID.LE.THRESH .AND. $ (FRESID-FRESID).EQ.0.0E+0 ) THEN @@ -769,12 +929,47 @@ PROGRAM PCQRDRIVER END IF * ELSE + +* Extreme value cases + IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, M + DO JK = 1, N+1 + X = MEM(IK*N + JK) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF + FRESID = FRESID - FRESID * -* Don't perform the checking, only timing -* - KPASS = KPASS + 1 - FRESID = FRESID - FRESID - PASSED = 'BYPASS' +* Don't perform the checking, only the timing +* operation + ELSE + KPASS = KPASS + 1 + FRESID = FRESID - FRESID + PASSED = 'BYPASS' + END IF * END IF * @@ -785,7 +980,7 @@ PROGRAM PCQRDRIVER * * Print results * - IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN + IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 .AND. INFO.EQ.0) THEN * MINMN = MIN( M, N ) MAXMN = MAX( M, N ) @@ -898,6 +1093,16 @@ PROGRAM PCQRDRIVER 9988 FORMAT( I5, ' tests skipped because of illegal input values.' ) 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( A ) + 9985 FORMAT( '----------Test-',I3,' Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9983 FORMAT( '----------Negative Test-',I3,' Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') + 9982 FORMAT( ' N < M case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the PCTZRZF API.') * STOP * diff --git a/TESTING/LIN/pddbdriver.f b/TESTING/LIN/pddbdriver.f index c26f4bfa..02d7cda9 100644 --- a/TESTING/LIN/pddbdriver.f +++ b/TESTING/LIN/pddbdriver.f @@ -6,6 +6,8 @@ PROGRAM PDDBDRIVER * and University of California, Berkeley. * November 15, 1997 * +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. +* * Purpose * ======= * @@ -69,6 +71,7 @@ PROGRAM PDDBDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER TOTMEM #ifndef DYNAMIC_WORK_MEM_ALLOC @@ -143,6 +146,14 @@ PROGRAM PDDBDRIVER DATA KFAIL, KPASS, KSKIP, KTESTS / 4*0 / * .. * +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X * * * .. Executable Statements .. @@ -163,6 +174,35 @@ PROGRAM PDDBDRIVER * CHECK = ( THRESH.GE.0.0D+0 ) * +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* * Print headings * IF( IAM.EQ.0 ) THEN @@ -181,6 +221,7 @@ PROGRAM PDDBDRIVER * * Make sure grid information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR( 1 ) = 0 IF( NPROW.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -202,6 +243,7 @@ PROGRAM PDDBDRIVER KSKIP = KSKIP + 1 GO TO 50 END IF +#endif * * Define process grid * @@ -231,23 +273,28 @@ PROGRAM PDDBDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'size' KSKIP = KSKIP + 1 GO TO 40 END IF +#endif * * DO 45 BW_NUM = 1, NBW @@ -285,10 +332,12 @@ PROGRAM PDDBDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 45 END IF +#endif * DO 30 K = 1, NNB * @@ -301,6 +350,10 @@ PROGRAM PDDBDRIVER NB = MAX( NB, 2*MAX(BWL,BWU) ) NB = MIN( N, NB ) END IF +* Altering the auto-assign for early return of N case + IF (N .EQ. 0 .AND. NB.EQ.0) THEN + NB = 1 + END IF * * Make sure NB is legal * @@ -314,10 +367,13 @@ PROGRAM PDDBDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 30 END IF +#endif * * Padding constants * @@ -359,12 +415,42 @@ PROGRAM PDDBDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -3 .OR. + $ IERR(1) .EQ. -6 .OR. IERR(1) .EQ. -9 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -12 )) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid M and N +* -4, -6 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9983 ) 'N' +* disable extreme value case when N < 0 + EX_FLAG = .FALSE. + ELSE IF(N .EQ. 0 .AND. (IERR(1) .EQ. 0 .OR. + $ IERR(1) .EQ. -5 .OR. IERR(1) .EQ. -10 .OR. + $ IERR(1) .EQ. -15 .OR. IERR(1) .EQ. -20 )) THEN +* DESCINIT returns the correct error code, +* When N = 0, IERR(1) could be return +* -5, -10 or -20 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING +* disable extreme value case when N = 0 + EX_FLAG = .FALSE. + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -481,17 +567,19 @@ PROGRAM PDDBDRIVER $ ((BWL+BWU+1)+10), 0, 0, IASEED, MYROW, $ MYCOL, NPROW, NPCOL ) * - CALL PDFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), + IF(N .GE. 0) THEN + CALL PDFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), $ ((BWL+BWU+1)+10), IPREPAD, IPOSTPAD, $ PADVAL ) * - CALL PDFILLPAD( ICTXT, WORKSIZ, 1, + CALL PDFILLPAD( ICTXT, WORKSIZ, 1, $ MEM( IP_DRIVER_W-IPREPAD ), WORKSIZ, $ IPREPAD, IPOSTPAD, PADVAL ) + END IF * * Calculate norm of A for residual error-checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * ANORM = PDLANGE( '1', (BWL+BWU+1), $ N, MEM( IPA ), 1, 1, @@ -514,20 +602,31 @@ PROGRAM PDDBDRIVER CALL SLTIMER( 1 ) * CALL PDDBTRF( N, BWL, BWU, MEM( IPA ), 1, DESCA, - $ MEM( IP_FILLIN ), FILLIN_SIZE, MEM( IPW ), + $ MEM( IP_FILLIN ), FILLIN_SIZE, MEM(IPW), $ IPW_SIZE, INFO ) * CALL SLTIMER( 1 ) * IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) THEN - WRITE( NOUT, FMT = * ) 'PDDBTRF INFO=', INFO - ENDIF + IF(N .LT. 0 .AND. (INFO .EQ. -1 .OR. + $ INFO .EQ. -604 )) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PDDBTRF INFO=', INFO +* When N = 0, make BWL and BWU = 0 for early return + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -3) THEN +* expected error code, when bandwidth is incorrect +* pass this case to solve API + WRITE( NOUT, FMT = * ) 'PDDBTRF INFO=', INFO + ELSE + IF( IAM.EQ.0 ) THEN + WRITE( NOUT, FMT = * ) 'PDDBTRF INFO=', INFO + ENDIF KFAIL = KFAIL + 1 GO TO 30 + END IF END IF * - IF( CHECK ) THEN + IF( CHECK .AND. INFO .EQ. 0 ) THEN * * Check for memory overwrite in factorization * @@ -629,7 +728,7 @@ PROGRAM PDDBDRIVER * * Solve linear system via factorization * - CALL PDDBTRS( TRANS, N, BWL, BWU, NRHS, MEM( IPA ), + CALL PDDBTRS( TRANS, N, BWL, BWU, NRHS, MEM(IPA), $ 1, DESCA, MEM( IPB ), 1, DESCB, $ MEM( IP_FILLIN ), FILLIN_SIZE, $ MEM( IPW_SOLVE ), IPW_SOLVE_SIZE, @@ -638,14 +737,23 @@ PROGRAM PDDBDRIVER CALL SLTIMER( 2 ) * IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) - $ WRITE( NOUT, FMT = * ) 'PDDBTRS INFO=', INFO - KFAIL = KFAIL + 1 - PASSED = 'FAILED' - GO TO 20 + IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804)) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PDDBTRS INFO=', INFO + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -4) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PDDBTRS INFO=', INFO + ELSE + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = * ) 'PDDBTRS INFO=', INFO + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + GO TO 20 + END IF END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN * * check for memory overwrite * @@ -659,12 +767,14 @@ PROGRAM PDDBDRIVER * SRESID = ZERO * - CALL PDDBLASCHK( 'N', 'D', TRANS, + IF(INFO .EQ. 0) THEN + CALL PDDBLASCHK( 'N', 'D', TRANS, $ N, BWL, BWU, NRHS, $ MEM( IPB ), 1, 1, DESCB2D, $ IASEED, MEM( IPA ), 1, 1, DESCA2D, $ IBSEED, ANORM, SRESID, $ MEM( IP_DRIVER_W ), WORKSIZ ) + END IF * IF( IAM.EQ.0 ) THEN IF( SRESID.GT.THRESH ) @@ -673,7 +783,23 @@ PROGRAM PDDBDRIVER * * The second test is a NaN trap * - IF( ( SRESID.LE.THRESH ).AND. + IF( N .EQ. 0 .AND. (INFO .EQ. -4 .OR. + $ INFO .EQ. 0)) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9984 ) 'PDDBTRS' + PASSED = 'PASSED' + ELSE IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804 )) THEN +* When N < 0/Invalid, PDDBTRS INFO = -1 +* Expected Error code for N < 0 +* Hence this case can be passed + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9982 ) 'PDDBTRS' + PASSED = 'PASSED' + ELSE IF( ( SRESID.LE.THRESH ).AND. $ ( (SRESID-SRESID).EQ.0.0D+0 ) ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' @@ -681,6 +807,35 @@ PROGRAM PDDBDRIVER KFAIL = KFAIL + 1 PASSED = 'FAILED' END IF + ELSE IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, N-1 + DO JK = 1, N + X = (MEM(IK*N + JK)) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite(X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF * END IF * @@ -922,6 +1077,13 @@ PROGRAM PDDBDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - ', A4, '|| / (||A|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Ax-b||/(||x||*||A||*eps*N) ', F25.7 ) + 9984 FORMAT( '----------Test Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9983 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9982 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') * STOP * diff --git a/TESTING/LIN/pddtdriver.f b/TESTING/LIN/pddtdriver.f index 373a7747..05f6f3d2 100644 --- a/TESTING/LIN/pddtdriver.f +++ b/TESTING/LIN/pddtdriver.f @@ -6,6 +6,8 @@ PROGRAM PDDTDRIVER * and University of California, Berkeley. * November 15, 1997 * +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. +* * Purpose * ======= * @@ -69,6 +71,7 @@ PROGRAM PDDTDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER TOTMEM #ifndef DYNAMIC_WORK_MEM_ALLOC @@ -143,6 +146,14 @@ PROGRAM PDDTDRIVER DATA KFAIL, KPASS, KSKIP, KTESTS / 4*0 / * .. * +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X * * * .. Executable Statements .. @@ -163,6 +174,35 @@ PROGRAM PDDTDRIVER * CHECK = ( THRESH.GE.0.0D+0 ) * +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* * Print headings * IF( IAM.EQ.0 ) THEN @@ -181,6 +221,7 @@ PROGRAM PDDTDRIVER * * Make sure grid information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR( 1 ) = 0 IF( NPROW.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -202,6 +243,7 @@ PROGRAM PDDTDRIVER KSKIP = KSKIP + 1 GO TO 50 END IF +#endif * * Define process grid * @@ -231,23 +273,28 @@ PROGRAM PDDTDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'size' KSKIP = KSKIP + 1 GO TO 40 END IF +#endif * * DO 45 BW_NUM = 1, NBW @@ -285,10 +332,12 @@ PROGRAM PDDTDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 45 END IF +#endif * DO 30 K = 1, NNB * @@ -301,6 +350,10 @@ PROGRAM PDDTDRIVER NB = MAX( NB, 2*INT_ONE ) NB = MIN( N, NB ) END IF +* Altering the auto-assign for early return of N case + IF (N .EQ. 0 .AND. NB.EQ.0) THEN + NB = 1 + END IF * * Make sure NB is legal * @@ -314,10 +367,13 @@ PROGRAM PDDTDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 30 END IF +#endif * * Padding constants * @@ -359,12 +415,43 @@ PROGRAM PDDTDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -3 .OR. + $ IERR(1) .EQ. -6 .OR. IERR(1) .EQ. -9 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -12 .OR. + $ IERR(1) .EQ. -2 .OR. IERR(1) .EQ. -8) ) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid M and N +* -4, -6 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9983 ) 'N' +* disable extreme value case when N < 0 + EX_FLAG = .FALSE. + ELSE IF(N .EQ. 0 .AND. (IERR(1) .EQ. 0 .OR. + $ IERR(1) .EQ. -5 .OR. IERR(1) .EQ. -10 .OR. + $ IERR(1) .EQ. -15 .OR. IERR(1) .EQ. -20 )) THEN +* DESCINIT returns the correct error code, +* When N = 0, +* -5, -10 or -20 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING +* disable extreme value case when N = 0 + EX_FLAG = .FALSE. + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -478,17 +565,20 @@ PROGRAM PDDTDRIVER CALL PDBMATGEN( ICTXT, 'T', 'D', BWL, BWU, N, (3), NB, $ MEM( IPA ), NB+10, 0, 0, IASEED, MYROW, $ MYCOL, NPROW, NPCOL ) - CALL PDFILLPAD( ICTXT, NQ, NP, MEM( IPA-IPREPAD ), +* + IF(N .GE. 0) THEN + CALL PDFILLPAD( ICTXT, NQ, NP, MEM( IPA-IPREPAD ), $ NB+10, IPREPAD, IPOSTPAD, $ PADVAL ) * - CALL PDFILLPAD( ICTXT, WORKSIZ, 1, + CALL PDFILLPAD( ICTXT, WORKSIZ, 1, $ MEM( IP_DRIVER_W-IPREPAD ), WORKSIZ, $ IPREPAD, IPOSTPAD, PADVAL ) + END IF * * Calculate norm of A for residual error-checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * ANORM = PDLANGE( 'I', N, $ (3), MEM( IPA ), 1, 1, @@ -518,14 +608,25 @@ PROGRAM PDDTDRIVER CALL SLTIMER( 1 ) * IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) THEN - WRITE( NOUT, FMT = * ) 'PDDTTRF INFO=', INFO - ENDIF - KFAIL = KFAIL + 1 - GO TO 30 + IF(N .LT. 0 .AND. (INFO .EQ. -1 .OR. + $ INFO .EQ. -604 )) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PDDTTRF INFO=', INFO +* When N = 0, make BWL and BWU = 0 for early return + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -3) THEN +* expected error code, when bandwidth is > 0 +* pass this case to solve API + WRITE( NOUT, FMT = * ) 'PDDTTRF INFO=', INFO + ELSE + IF( IAM.EQ.0 ) THEN + WRITE( NOUT, FMT = * ) 'PDDTTRF INFO=', INFO + ENDIF + KFAIL = KFAIL + 1 + GO TO 30 + END IF END IF * - IF( CHECK ) THEN + IF( CHECK .AND. INFO .EQ. 0 ) THEN * * Check for memory overwrite in factorization * @@ -638,14 +739,23 @@ PROGRAM PDDTDRIVER CALL SLTIMER( 2 ) * IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) - $ WRITE( NOUT, FMT = * ) 'PDDTTRS INFO=', INFO - KFAIL = KFAIL + 1 - PASSED = 'FAILED' - GO TO 20 + IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804)) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PDDTTRS INFO=', INFO + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -4) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PDDTTRS INFO=', INFO + ELSE + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = * ) 'PDDTTRS INFO=', INFO + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + GO TO 20 + END IF END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN * * check for memory overwrite * @@ -665,12 +775,14 @@ PROGRAM PDDTDRIVER CALL DESCINIT( DESCA2D, (3), N, $ (3), NB, 0, 0, $ ICTXT, (3), IERR( 1 ) ) - CALL PDDTLASCHK( 'N', 'D', TRANS, + IF(INFO .EQ. 0) THEN + CALL PDDTLASCHK( 'N', 'D', TRANS, $ N, BWL, BWU, NRHS, $ MEM( IPB ), 1, 1, DESCB2D, $ IASEED, MEM( IPA ), 1, 1, DESCA2D, $ IBSEED, ANORM, SRESID, $ MEM( IP_DRIVER_W ), WORKSIZ ) + END IF * IF( IAM.EQ.0 ) THEN IF( SRESID.GT.THRESH ) @@ -679,7 +791,33 @@ PROGRAM PDDTDRIVER * * The second test is a NaN trap * - IF( ( SRESID.LE.THRESH ).AND. + IF( N .EQ. 0 .AND. (INFO .EQ. -4 .OR. + $ INFO .EQ. 0)) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9984 ) 'PDDTTRS' + PASSED = 'PASSED' +* Re-enable EX_FLAG + IF(NAN_PERCENT .GT. 0 .OR. + $ INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + ELSE IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804 )) THEN +* When N < 0/Invalid, PDDTTRS INFO = -1 +* Expected Error code for N < 0 +* Hence this case can be passed + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9982 ) 'PDDTTRS' + PASSED = 'PASSED' +* Re-enable EX_FLAG + IF(NAN_PERCENT .GT. 0 .OR. + $ INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + ELSE IF( ( SRESID.LE.THRESH ).AND. $ ( (SRESID-SRESID).EQ.0.0D+0 ) ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' @@ -687,6 +825,37 @@ PROGRAM PDDTDRIVER KFAIL = KFAIL + 1 PASSED = 'FAILED' END IF +* Extreme-value validation block + ELSE IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, N-1 + DO JK = 1, N + X = (MEM(IK*N + JK)) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF * END IF * @@ -928,6 +1097,13 @@ PROGRAM PDDTDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - ', A4, '|| / (||A|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Ax-b||/(||x||*||A||*eps*N) ', F25.7 ) + 9984 FORMAT( '----------Test Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9983 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9982 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') * STOP * diff --git a/TESTING/LIN/pdgbdriver.f b/TESTING/LIN/pdgbdriver.f index 0f15dfb6..fa9dab88 100644 --- a/TESTING/LIN/pdgbdriver.f +++ b/TESTING/LIN/pdgbdriver.f @@ -6,6 +6,8 @@ PROGRAM PDGBDRIVER * and University of California, Berkeley. * November 15, 1997 * +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. +* * Purpose * ======= * @@ -75,6 +77,7 @@ PROGRAM PDGBDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER TOTMEM, INTMEM #ifndef DYNAMIC_WORK_MEM_ALLOC @@ -150,6 +153,14 @@ PROGRAM PDGBDRIVER DATA KFAIL, KPASS, KSKIP, KTESTS / 4*0 / * .. * +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X * * * .. Executable Statements .. @@ -170,6 +181,35 @@ PROGRAM PDGBDRIVER * CHECK = ( THRESH.GE.0.0D+0 ) * +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* * Print headings * IF( IAM.EQ.0 ) THEN @@ -188,6 +228,7 @@ PROGRAM PDGBDRIVER * * Make sure grid information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR( 1 ) = 0 IF( NPROW.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -209,6 +250,7 @@ PROGRAM PDGBDRIVER KSKIP = KSKIP + 1 GO TO 50 END IF +#endif * * Define process grid * @@ -238,23 +280,28 @@ PROGRAM PDGBDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'size' KSKIP = KSKIP + 1 GO TO 40 END IF +#endif * * DO 45 BW_NUM = 1, NBW @@ -292,10 +339,12 @@ PROGRAM PDGBDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 45 END IF +#endif * DO 30 K = 1, NNB * @@ -308,6 +357,10 @@ PROGRAM PDGBDRIVER NB = MAX( NB, 2*(BWL+BWU) ) NB = MIN( N, NB ) END IF +* Altering the auto-assign for early return of N case + IF (N .EQ. 0 .AND. NB.EQ.0) THEN + NB = 1 + END IF * * Make sure NB is legal * @@ -328,10 +381,13 @@ PROGRAM PDGBDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 30 END IF +#endif * * Padding constants * @@ -373,12 +429,43 @@ PROGRAM PDGBDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -3 .OR. + $ IERR(1) .EQ. -6 .OR. IERR(1) .EQ. -9 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -12 .OR. + $ IERR(1) .EQ. -2 .OR. IERR(1) .EQ. -8) ) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid M and N +* -4, -6 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9983 ) 'N' +* disable extreme value case when N < 0 + EX_FLAG = .FALSE. + ELSE IF(N .EQ. 0 .AND. (IERR(1) .EQ. 0 .OR. + $ IERR(1) .EQ. -5 .OR. IERR(1) .EQ. -10 .OR. + $ IERR(1) .EQ. -15 .OR. IERR(1) .EQ. -20 )) THEN +* DESCINIT returns the correct error code, +* When N = 0, +* -5, -10 or -20 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING +* disable extreme value case when N = 0 + EX_FLAG = .FALSE. + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -495,17 +582,19 @@ PROGRAM PDGBDRIVER $ ((2*BWL+2*BWU+1)+10), 0, 0, IASEED, $ MYROW, MYCOL, NPROW, NPCOL ) * - CALL PDFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), + IF(N .GE. 0) THEN + CALL PDFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), $ ((2*BWL+2*BWU+1)+10), IPREPAD, IPOSTPAD, $ PADVAL ) * - CALL PDFILLPAD( ICTXT, WORKSIZ, 1, + CALL PDFILLPAD( ICTXT, WORKSIZ, 1, $ MEM( IP_DRIVER_W-IPREPAD ), WORKSIZ, $ IPREPAD, IPOSTPAD, PADVAL ) + END IF * * Calculate norm of A for residual error-checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * ANORM = PDLANGE( '1', (2*BWL+2*BWU+1), $ N, MEM( IPA ), 1, 1, @@ -533,15 +622,26 @@ PROGRAM PDGBDRIVER * CALL SLTIMER( 1 ) * - IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) THEN - WRITE( NOUT, FMT = * ) 'PDGBTRF INFO=', INFO - ENDIF - KFAIL = KFAIL + 1 - GO TO 30 + IF( INFO.NE.0 .AND. .NOT.(EX_FLAG)) THEN + IF(N .LT. 0 .AND. (INFO .EQ. -1 .OR. + $ INFO .EQ. -604 )) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PDGBTRF INFO=', INFO +* When N = 0, make BWL and BWU = 0 for early return + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -3) THEN +* expected error code, when bandwidth is > 0 +* pass this case to solve API + WRITE( NOUT, FMT = * ) 'PDGBTRF INFO=', INFO + ELSE + IF( IAM.EQ.0 ) THEN + WRITE( NOUT, FMT = * ) 'PDGBTRF INFO=', INFO + ENDIF + KFAIL = KFAIL + 1 + GO TO 30 + END IF END IF * - IF( CHECK ) THEN + IF( CHECK .AND. INFO .EQ. 0 ) THEN * * Check for memory overwrite in factorization * @@ -651,15 +751,24 @@ PROGRAM PDGBDRIVER * CALL SLTIMER( 2 ) * - IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) - $ WRITE( NOUT, FMT = * ) 'PDGBTRS INFO=', INFO - KFAIL = KFAIL + 1 - PASSED = 'FAILED' - GO TO 20 + IF( INFO.NE.0 .AND. .NOT.(EX_FLAG) ) THEN + IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804)) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PDGBTRS INFO=', INFO + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -4) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PDGBTRS INFO=', INFO + ELSE + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = * ) 'PDGBTRS INFO=', INFO + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + GO TO 20 + END IF END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN * * check for memory overwrite * @@ -673,12 +782,14 @@ PROGRAM PDGBDRIVER * SRESID = ZERO * - CALL PDDBLASCHK( 'N', 'N', TRANS, + IF(INFO .EQ. 0) THEN + CALL PDDBLASCHK( 'N', 'N', TRANS, $ N, BWL, BWU, NRHS, $ MEM( IPB ), 1, 1, DESCB2D, $ IASEED, MEM( IPA+BWL+BWU ), 1, 1, DESCA2D, $ IBSEED, ANORM, SRESID, $ MEM( IP_DRIVER_W ), WORKSIZ ) + END IF * IF( IAM.EQ.0 ) THEN IF( SRESID.GT.THRESH ) @@ -687,7 +798,33 @@ PROGRAM PDGBDRIVER * * The second test is a NaN trap * - IF( ( SRESID.LE.THRESH ).AND. + IF( N .EQ. 0 .AND. (INFO .EQ. -4 .OR. + $ INFO .EQ. 0)) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9984 ) 'PDGBTRS' + PASSED = 'PASSED' +* Re-enable EX_FLAG + IF(NAN_PERCENT .GT. 0 .OR. + $ INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + ELSE IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804 )) THEN +* When N < 0/Invalid, PDGBTRS INFO = -1 +* Expected Error code for N < 0 +* Hence this case can be passed + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9982 ) 'PDGBTRS' + PASSED = 'PASSED' +* Re-enable EX_FLAG + IF(NAN_PERCENT .GT. 0 .OR. + $ INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + ELSE IF( ( SRESID.LE.THRESH ).AND. $ ( (SRESID-SRESID).EQ.0.0D+0 ) ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' @@ -695,6 +832,37 @@ PROGRAM PDGBDRIVER KFAIL = KFAIL + 1 PASSED = 'FAILED' END IF +* Extreme-value validation block + ELSE IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, N-1 + DO JK = 1, N + X = (MEM(IK*N + JK)) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF * END IF * @@ -936,6 +1104,13 @@ PROGRAM PDGBDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - ', A4, '|| / (||A|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Ax-b||/(||x||*||A||*eps*N) ', F25.7 ) + 9984 FORMAT( '----------Test Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9983 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9982 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') * STOP * diff --git a/TESTING/LIN/pdinvdriver.f b/TESTING/LIN/pdinvdriver.f index e664e76b..afc63071 100644 --- a/TESTING/LIN/pdinvdriver.f +++ b/TESTING/LIN/pdinvdriver.f @@ -4,6 +4,7 @@ PROGRAM PDINVDRIVER * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======= @@ -58,6 +59,7 @@ PROGRAM PDINVDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, $ LLD_, MB_, M_, NB_, N_, RSRC_ @@ -96,6 +98,7 @@ PROGRAM PDINVDRIVER $ NPROW, NQ, WORKIINV, WORKINV, WORKSIZ REAL THRESH DOUBLE PRECISION ANORM, FRESID, NOPS, RCOND, TMFLOPS + CHARACTER*8 API_NAME * .. * .. Local Arrays .. CHARACTER*3 MATTYP( NTESTS ) @@ -133,6 +136,15 @@ PROGRAM PDINVDRIVER * .. * .. Executable Statements .. * +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X +* * Get starting information * #ifdef DYNAMIC_WORK_MEM_ALLOC @@ -144,6 +156,36 @@ PROGRAM PDINVDRIVER $ NTESTS, NNB, NBVAL, NTESTS, NGRIDS, PVAL, NTESTS, $ QVAL, NTESTS, THRESH, MEM, IAM, NPROCS ) CHECK = ( THRESH.GE.0.0E+0 ) + +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* * * Loop over the different matrix types * @@ -231,12 +273,14 @@ PROGRAM PDINVDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR( 1 ) = 0 - IF( N.LT.1 ) THEN + IF( N.LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Make sure no one had error * @@ -300,12 +344,29 @@ PROGRAM PDINVDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, $ 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 10 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 )) THEN +* DESCINIT returns the correct error code, +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9984 ) 'N' +* disable extreme flag for negative case + EX_FLAG = .FALSE. + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF +#endif * * Assign pointers into MEM for ScaLAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -414,24 +475,50 @@ PROGRAM PDINVDRIVER $ LSAMEN( 2, MTYP( 2:3 ), 'TR' ) ) THEN * * Generate a general diagonally dominant matrix A -* - CALL PDMATGEN( ICTXT, 'N', 'D', DESCA( M_ ), + IF(EX_FLAG) THEN +* The extreme-value generation module for +* diagonally dominant matrices, requires +* Matrix-type info such as Upper/Lower. +* Hence, MTYP(1:1) is passed to MATGEN +* MTYP(1:1) is 'U'/'L'/'N' (default-case) + CALL PDMATGEN( ICTXT, MTYP(1:1), 'D', + $ DESCA( M_ ), + $ DESCA( N_ ), DESCA( MB_ ), + $ DESCA( NB_ ), MEM( IPA ), + $ DESCA( LLD_ ), DESCA( RSRC_ ), + $ DESCA( CSRC_ ), IASEED, 0, NP, 0, + $ NQ, MYROW, MYCOL, NPROW, NPCOL ) + ELSE + CALL PDMATGEN( ICTXT, 'N', 'D', DESCA( M_ ), $ DESCA( N_ ), DESCA( MB_ ), $ DESCA( NB_ ), MEM( IPA ), $ DESCA( LLD_ ), DESCA( RSRC_ ), $ DESCA( CSRC_ ), IASEED, 0, NP, 0, $ NQ, MYROW, MYCOL, NPROW, NPCOL ) + END IF * - ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'PD' ) ) THEN + ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'PD' )) THEN * * Generate a symmetric positive definite matrix * - CALL PDMATGEN( ICTXT, 'S', 'D', DESCA( M_ ), + IF(EX_FLAG) THEN +* MTYP(1:1) is 'U'/'L'/'N' (default-case) + CALL PDMATGEN( ICTXT, MTYP(1:1), 'D', + $ DESCA( M_ ), $ DESCA( N_ ), DESCA( MB_ ), $ DESCA( NB_ ), MEM( IPA ), $ DESCA( LLD_ ), DESCA( RSRC_ ), $ DESCA( CSRC_ ), IASEED, 0, NP, 0, $ NQ, MYROW, MYCOL, NPROW, NPCOL ) + ELSE + CALL PDMATGEN( ICTXT, 'S', 'D', + $ DESCA( M_ ), + $ DESCA( N_ ), DESCA( MB_ ), + $ DESCA( NB_ ), MEM( IPA ), + $ DESCA( LLD_ ), DESCA( RSRC_ ), + $ DESCA( CSRC_ ), IASEED, 0, NP, 0, + $ NQ, MYROW, MYCOL, NPROW, NPCOL ) + END IF * END IF * @@ -457,7 +544,7 @@ PROGRAM PDINVDRIVER * * Need 1-norm of A for checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * CALL PDFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, @@ -553,7 +640,7 @@ PROGRAM PDINVDRIVER $ MEM( IPPIV ), INFO ) CALL SLTIMER( 1 ) * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * * Check for memory overwrite * @@ -565,16 +652,16 @@ PROGRAM PDINVDRIVER $ MEM( IPPIV-IPREPAD ), LIPIV, $ IPREPAD, IPOSTPAD, PADVAL ) END IF -* * Perform the general matrix inversion * CALL SLTIMER( 2 ) + API_NAME = 'PDGETRI' CALL PDGETRI( N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPPIV ), MEM( IPW ), LWORK, $ MEM( IPIW ), LIWORK, INFO ) CALL SLTIMER( 2 ) * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * * Check for memory overwrite * @@ -602,11 +689,12 @@ PROGRAM PDINVDRIVER * Perform the general matrix inversion * CALL SLTIMER( 2 ) + API_NAME = 'PDTRTRI' CALL PDTRTRI( UPLO, 'Non unit', N, MEM( IPA ), 1, $ 1, DESCA, INFO ) CALL SLTIMER( 2 ) * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * * Check for memory overwrite * @@ -625,7 +713,7 @@ PROGRAM PDINVDRIVER $ INFO ) CALL SLTIMER( 1 ) * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * * Check for memory overwrite * @@ -639,11 +727,12 @@ PROGRAM PDINVDRIVER * inversion * CALL SLTIMER( 2 ) + API_NAME = 'PDPOTRI' CALL PDPOTRI( UPLO, N, MEM( IPA ), 1, 1, DESCA, $ INFO ) CALL SLTIMER( 2 ) * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * * Check for memory overwrite * @@ -655,37 +744,66 @@ PROGRAM PDINVDRIVER * END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG)) THEN * - CALL PDFILLPAD( ICTXT, WORKSIZ-IPOSTPAD, 1, + IF(INFO.EQ.0 .AND. N.GT.0) THEN + CALL PCFILLPAD( ICTXT, WORKSIZ-IPOSTPAD, 1, $ MEM( IPW-IPREPAD ), $ WORKSIZ-IPOSTPAD, IPREPAD, $ IPOSTPAD, PADVAL ) * -* Compute fresid = || inv(A)*A-I || +* Compute fresid = || inv(A)*A-I || * - CALL PDINVCHK( MTYP, N, MEM( IPA ), 1, 1, DESCA, + CALL PDINVCHK( MTYP, N, MEM( IPA ), 1, 1, DESCA, $ IASEED, ANORM, FRESID, RCOND, $ MEM( IPW ) ) * -* Check for memory overwrite +* Check for memory overwrite * - CALL PDCHEKPAD( ICTXT, 'PDINVCHK', NP, NQ, + CALL PDCHEKPAD( ICTXT, 'PDINVCHK', NP, NQ, $ MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PDCHEKPAD( ICTXT, 'PDINVCHK', + CALL PDCHEKPAD( ICTXT, 'PDINVCHK', $ WORKSIZ-IPOSTPAD, 1, $ MEM( IPW-IPREPAD ), $ WORKSIZ-IPOSTPAD, IPREPAD, $ IPOSTPAD, PADVAL ) + END IF * * Test residual and detect NaN result * - IF( FRESID.LE.THRESH .AND. INFO.EQ.0 .AND. + IF(N.EQ.0 .AND. INFO.EQ.0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) KPASS, API_NAME + PASSED = 'PASSED' + GO TO 10 + ELSE IF( FRESID.LE.THRESH .AND. INFO.EQ.0 .AND. $ ( (FRESID-FRESID) .EQ. 0.0D+0 ) ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' + ELSE IF(N.LT.0 .AND. + $ ((INFO.EQ.-1 + $ .AND. LSAMEN( 3, MTYP, 'GEN' )) .OR. + $ (INFO.EQ.-3 .AND. + $ LSAMEN( 2, MTYP( 2:3 ), 'TR' )) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, MTYP( 2:3 ), 'PD' )))) THEN +* When N < 0/Invalid, PCGETRI INFO = -1 +* PTPOTRI INFO = -2 and PCTRTRI INFO = -3 +* Expected Error code for N < 0 +* Hence this case can be passed + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9983 ) API_NAME + PASSED = 'PASSED' +* re-enable extreme flag for next case + IF(INF_PERCENT .GT. 0 .OR. + $ NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF ELSE KFAIL = KFAIL + 1 IF( INFO.GT.0 ) THEN @@ -697,12 +815,54 @@ PROGRAM PDINVDRIVER * ELSE * +* Extreme value case + IF(N.EQ.0 .AND. INFO.EQ.0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) KPASS, API_NAME + PASSED = 'PASSED' + GO TO 10 + ELSE IF(EX_FLAG .AND. N.GT.0) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, N-1 + DO JK = 1, N + X = MEM(IK*N + JK) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF + FRESID = FRESID - FRESID +* * Don't perform the checking, only the timing * operation -* - KPASS = KPASS + 1 - FRESID = FRESID - FRESID - PASSED = 'BYPASS' + ELSE + KPASS = KPASS + 1 + FRESID = FRESID - FRESID + PASSED = 'BYPASS' + END IF * END IF * @@ -713,7 +873,7 @@ PROGRAM PDINVDRIVER * * Print results * - IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN + IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN * IF( LSAMEN( 3, MTYP, 'GEN' ) ) THEN * @@ -841,6 +1001,13 @@ PROGRAM PDINVDRIVER 9988 FORMAT( I5, ' tests skipped because of illegal input values.' ) 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( A ) + 9985 FORMAT( '----------Test-',I3,' Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9983 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') * STOP * diff --git a/TESTING/LIN/pdlltdriver.f b/TESTING/LIN/pdlltdriver.f index e3168791..cc4f0e83 100644 --- a/TESTING/LIN/pdlltdriver.f +++ b/TESTING/LIN/pdlltdriver.f @@ -4,6 +4,7 @@ PROGRAM PDLLTDRIVER * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======= @@ -212,6 +213,7 @@ PROGRAM PDLLTDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR( 1 ) = 0 IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -222,6 +224,7 @@ PROGRAM PDLLTDRIVER $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * @@ -281,12 +284,27 @@ PROGRAM PDLLTDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else +* If N < 0 in LLT.dat file then DESCINIT API sets IERR( 1 ) = -2 + IF( N.LT.0 .AND. IERR( 1 ).EQ.-2 ) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9984 ) 'N' + ELSE IF( IERR( 1 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif + * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -403,7 +421,24 @@ PROGRAM PDLLTDRIVER IF( INFO.NE.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = * ) 'PDPOTRF INFO=', INFO - KFAIL = KFAIL + 1 +* If N < 0 in LLT.dat file then PDPOTRF API sets INFO = -2 + IF (N.LT.0 .AND. INFO.EQ.-2) THEN +* If PDPOTRF is returning correct error +* code we need to pass this case + WRITE( NOUT, FMT = 9983 ) 'PDPOTRF' + KPASS = KPASS + 1 + ELSE +* For other error code we will mark test case as fail + KFAIL = KFAIL + 1 + END IF + RCOND = ZERO + GO TO 60 + ELSE IF (N.EQ.0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API we need to pass this case + WRITE( NOUT, FMT = 9982 ) 'PDPOTRF' + KPASS = KPASS + 1 RCOND = ZERO GO TO 60 END IF @@ -496,6 +531,14 @@ PROGRAM PDLLTDRIVER CALL DESCINIT( DESCB, N, NRHS, NB, NBRHS, 0, 0, $ ICTXT, MAX( 1, NP )+IMIDPAD, $ IERR( 1 ) ) + +* If NRHS < 0 in LLT.dat file then +* DESCINIT API sets IERR( 1 ) = -3 + IF (NRHS.LT.0 .AND. IERR( 1 ).EQ.-3 ) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9984 ) 'NRHS' + END IF * * move IPW to allow room for RHS * @@ -602,6 +645,23 @@ PROGRAM PDLLTDRIVER * CALL SLTIMER( 2 ) * + IF( INFO.NE.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = * ) 'PDPOTRS INFO=', INFO +* If NRHS < 0 in LLT.dat file then +* PDPOTRS API sets INFO = -3 + IF( NRHS.LT.0 .AND. INFO.EQ.-3 ) THEN +* If PDPOTRS is returning correct error code then +* we need to pass this case + WRITE( NOUT, FMT = 9983 ) 'PDPOTRS' + KPASS = KPASS + 1 + ELSE +* For other error code we will mark test case as fail + KFAIL = KFAIL + 1 + END IF + GO TO 60 + END IF + IF( CHECK ) THEN * * check for memory overwrite @@ -922,6 +982,11 @@ PROGRAM PDLLTDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - ', A4, '|| / (||A|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Ax-b||/(||x||*||A||*eps*N) ', F25.7 ) + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, we will handle this case from ', + $ 'ScaLAPACK API.') + 9983 FORMAT( A, ' returned correct error code. Passing this case.') + 9982 FORMAT( 'This is safe exit from ', A, ' API. Passing this case.') * STOP * diff --git a/TESTING/LIN/pdlsdriver.f b/TESTING/LIN/pdlsdriver.f index c85cc030..9c6ecd5a 100644 --- a/TESTING/LIN/pdlsdriver.f +++ b/TESTING/LIN/pdlsdriver.f @@ -4,6 +4,7 @@ PROGRAM PDLSDRIVER * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 28, 2001 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======= @@ -59,6 +60,7 @@ PROGRAM PDLSDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, $ LLD_, MB_, M_, NB_, N_, RSRC_ @@ -132,6 +134,16 @@ PROGRAM PDLSDRIVER DATA KTESTS, KPASS, KFAIL, KSKIP / 4*0 / * .. * .. Executable Statements .. +* +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X + * * Get starting information * @@ -147,6 +159,35 @@ PROGRAM PDLSDRIVER $ NNBR, NBRVAL, NTESTS, NGRIDS, PVAL, NTESTS, QVAL, $ NTESTS, THRESH, MEM, IAM, NPROCS ) CHECK = ( THRESH.GE.0.0E+0 ) + +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do * * Print headings * @@ -207,15 +248,17 @@ PROGRAM PDLSDRIVER * Make sure matrix information is correct * IERR( 1 ) = 0 - IF( M.LT.1 ) THEN +#ifdef ENABLE_DRIVER_CHECK + IF( M.LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'M', M IERR( 1 ) = 1 - ELSE IF( N.LT.1 ) THEN + ELSE IF( N.LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Make sure no one had error * @@ -281,12 +324,35 @@ PROGRAM PDLSDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 70 END IF +#else +* If M < 0, DESCINIT API sets IERR( 1 ) = -2 +* If N < 0, DESCINIT API sets IERR( 1 ) = -3 +* When M/N < 0, LDA is Negative, DESCINIT IERR( 1 ) = -8 + IF( M.LT.0 .AND. (IERR( 1 ).EQ.-2 .OR. + $ IERR( 1 ).EQ. -8 .OR. IERR(1).EQ.-12 )) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9985 ) 'M' + ELSE IF (N.LT.0 .AND. (IERR( 1 ).EQ.-3 .OR. + $ IERR( 1 ).EQ. -8 .OR. IERR(1).EQ.-12 )) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9985 ) 'N' + ELSE IF( IERR( 1 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 70 + END IF +#endif * DO 60 ISCALE = 1, 3 * @@ -323,7 +389,7 @@ PROGRAM PDLSDRIVER GO TO 70 END IF * - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. N.GT.0 ) THEN CALL PDFILLPAD( ICTXT, MP, NQ, MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, $ PADVAL ) @@ -335,10 +401,12 @@ PROGRAM PDLSDRIVER * * Generate the matrix A and calculate its 1-norm * - CALL PDQRT13( ISCALE, M, N, MEM( IPA ), 1, 1, + IF(M.GT.0 .AND. N.GT.0 ) THEN + CALL PDQRT13( ISCALE, M, N, MEM( IPA ), 1, 1, $ DESCA, ANORM, IASEED, MEM( IPW ) ) + END IF * - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. N.GT.0 ) THEN CALL PDCHEKPAD( ICTXT, 'PDQRT13', MP, NQ, $ MEM( IPA-IPREPAD ), DESCA( LLD_ ), $ IPREPAD, IPOSTPAD, PADVAL ) @@ -399,12 +467,41 @@ PROGRAM PDLSDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 2, 1, IERR, $ 2, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 .OR. IERR( 2 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else + IF (NRHS.LT.0 .AND. (IERR( 1 ).EQ.-3 .OR. + $ IERR(1) .EQ. -12)) THEN +* If DESCINIT is returns correct error code then +* do nothing + WRITE( NOUT, FMT = 9985 ) 'NRHS' + ELSE IF (N.LT.0 .AND. (IERR( 1 ).EQ.-2 .OR. + $ IERR( 1 ).EQ. -8 .OR. + $ IERR( 2 ).EQ.-2 .OR. + $ IERR( 2 ).EQ. -8) ) THEN +* If DESCINIT is returns correct error code then +* do nothing + WRITE( NOUT, FMT = 9985 ) 'N' + ELSE IF (M.LT.0 .AND. (IERR( 1 ).EQ.-2 .OR. + $ IERR( 1 ).EQ. -8 .OR. + $ IERR( 2 ).EQ. -2 .OR. + $ IERR( 2 ).EQ. -8)) THEN +* If DESCINIT is returns correct error code then +* do nothing + WRITE( NOUT, FMT = 9985 ) 'M' + ELSE IF( IERR( 1 ).LT.0 .OR. + $ IERR( 2 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif * * Check for enough memory * @@ -436,8 +533,10 @@ PROGRAM PDLSDRIVER * * Generate RHS * - IF( TPSD ) THEN - CALL PDMATGEN( ICTXT, 'No', 'No', + IF (M.GT.0 .AND. N.GT.0 .AND. + $ NRHS.GT.0) THEN + IF( TPSD ) THEN + CALL PDMATGEN( ICTXT, 'No', 'No', $ DESCW( M_ ), DESCW( N_ ), $ DESCW( MB_ ), DESCW( NB_ ), $ MEM( IPW ), DESCW( LLD_ ), @@ -445,7 +544,7 @@ PROGRAM PDLSDRIVER $ DESCW( CSRC_ ), IBSEED, 0, $ MP, 0, NRHSQ, MYROW, MYCOL, $ NPROW, NPCOL ) - ELSE + ELSE CALL PDMATGEN( ICTXT, 'No', 'No', $ DESCW( M_ ), DESCW( N_ ), $ DESCW( MB_ ), DESCW( NB_ ), @@ -454,9 +553,10 @@ PROGRAM PDLSDRIVER $ DESCW( CSRC_ ), IBSEED, 0, $ NP, 0, NRHSQ, MYROW, MYCOL, $ NPROW, NPCOL ) + END IF END IF -* - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. N.GT.0 .AND. + $ NRHS.GT.0) THEN CALL PDFILLPAD( ICTXT, MNP, NRHSQ, $ MEM( IPX-IPREPAD ), $ DESCX( LLD_ ), IPREPAD, @@ -473,22 +573,29 @@ PROGRAM PDLSDRIVER $ IPOSTPAD, PADVAL ) END IF END IF -* - DO 10 JJ = 1, NRHS - CALL PDNRM2( NCOLS, BNORM, MEM( IPW ), 1, - $ JJ, DESCW, 1 ) - IF( BNORM.GT.ZERO ) - $ CALL PDSCAL( NCOLS, ONE / BNORM, - $ MEM( IPW ), 1, JJ, DESCW, - $ 1 ) + IF( M.GT.0 .AND. N.GT.0 .AND. + $ NRHS.GT.0 ) THEN + DO 10 JJ = 1, NRHS + CALL PDNRM2( NCOLS, BNORM, MEM( IPW ), + $ 1, JJ, DESCW, 1 ) + IF( BNORM.GT.ZERO ) + $ CALL PDSCAL( NCOLS, ONE / BNORM, + $ MEM( IPW ), 1, JJ, + $ DESCW, 1 ) 10 CONTINUE + END IF * - CALL PDGEMM( TRANS, 'N', NROWS, NRHS, NCOLS, + IF (M.GE.0 .AND. N.GE.0 .AND. + $ NRHS.GE.0) THEN + CALL PDGEMM( TRANS, 'N', NROWS, + $ NRHS, NCOLS, $ ONE, MEM( IPA ), 1, 1, DESCA, $ MEM( IPW ), 1, 1, DESCW, ZERO, $ MEM( IPX ), 1, 1, DESCX ) + END IF * - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. N.GT.0 .AND. + $ NRHS.GT.0 ) THEN * * check for memory overwrite * @@ -539,8 +646,8 @@ PROGRAM PDLSDRIVER IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) $ 'descriptor' - KSKIP = KSKIP + 1 - GO TO 30 + KSKIP = KSKIP + 1 + GO TO 30 END IF * IPW = IPB + DESCB( LLD_ )*NRHSQ + @@ -593,7 +700,8 @@ PROGRAM PDLSDRIVER GO TO 30 END IF * - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. N.GT.0 .AND. + $ NRHS .GT.0 ) THEN * * Make the copy of the right hand side * @@ -624,13 +732,27 @@ PROGRAM PDLSDRIVER * * Solve the LS or overdetermined system * +* Induce incorrect case, TRANS has to be C or N +* Hence for the third iteration, use invalid TRANS +* IF( ITRAN.EQ.3 ) THEN +* TRANS = 'E' +* END IF + + CALL PDGELS( TRANS, M, N, NRHS, MEM( IPA ), $ 1, 1, DESCA, MEM( IPX ), 1, 1, $ DESCX, MEM( IPW ), LWORK, INFO ) * CALL SLTIMER( 1 ) * - IF( CHECK ) THEN + IF( (N .EQ. 0 .OR. M.EQ.0 .OR. + $ NRHS .EQ. 0 ) .AND. INF0.EQ.0) THEN +* If M = 0 or N =0 this is the case of +* safe exit, early return from ScaLAPACK API. + WRITE( NOUT, FMT = 9983 ) 'PDGELS' + END IF + IF( CHECK .AND. M.GT.0 .AND. + $ N.GT.0 .AND. NRHS.GT.0 ) THEN * * check for memory overwrite * @@ -650,14 +772,20 @@ PROGRAM PDLSDRIVER * * Regenerate A in place for testing and next * iteration + + IF(M.GT.0 .AND. N.GT.0 .AND. NRHS.GT.0) THEN * - CALL PDQRT13( ISCALE, M, N, MEM( IPA ), 1, 1, - $ DESCA, ANORM, IASEED, + CALL PDQRT13( ISCALE, M, N, MEM( IPA ), + $ 1, 1, DESCA, ANORM, IASEED, $ MEM( IPW ) ) + + END IF * * check the solution to rhs * - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. + $ N.GT.0 .AND. NRHS.GT.0 .AND. + $ .NOT.(EX_FLAG) ) THEN * * Am I going to call PDQRT17 ? * @@ -839,7 +967,9 @@ PROGRAM PDLSDRIVER * Call PDQRT14 * IF( ( M.GE.N .AND. TPSD ) .OR. - $ ( M.LT.N .AND. ( .NOT.TPSD ) ) ) THEN + $ ( M.LT.N .AND. (.NOT.TPSD) ) .AND. + $ ( M.GT.0 .AND. N.GT.0 .AND. + $ NRHS.GT.0 ) ) THEN * IPW = IPB * @@ -930,7 +1060,15 @@ PROGRAM PDLSDRIVER * did not pass the threshold. * PASSED = 'PASSED' - DO 20 II = 1, 2 + IF((M.EQ.0 .OR. N.EQ.0 .OR. + $ NRHS .EQ. 0) .AND. INF0 .EQ. 0) THEN +* If M = 0, N =0, NRHS =0 this is the case of +* early return from ScaLAPACK API. +* Pass this case + KPASS = KPASS + 1 + SRESID = SRESID - SRESID + ELSE + DO 20 II = 1, 2 IF( ( RESULT( II ).GE.THRESH ) .AND. $ ( RESULT( II )-RESULT( II ).EQ.0.0E+0 $ ) ) THEN @@ -943,16 +1081,75 @@ PROGRAM PDLSDRIVER ELSE KPASS = KPASS + 1 END IF - 20 CONTINUE + 20 CONTINUE + END IF * ELSE * -* By-pass the solve check -* - KPASS = KPASS + 1 - SRESID = SRESID - SRESID - PASSED = 'BYPASS' -* + IF((M.EQ.0 .OR. N.EQ.0 .OR. + $ NRHS .EQ. 0) .AND. INF0 .EQ. 0) THEN +* If M = 0, N =0, NRHS =0 this is the case of +* early return from ScaLAPACK API. +* Pass this case + KPASS = KPASS + 1 + SRESID = SRESID - SRESID + PASSED = 'PASSED' +* +* When N < 0, PZGELS returns INF0 = -2 +* When M < 0, PZGELS returns INF0 = -3 +* When NRHS < 0, PZGELS returns INF0 = -4 +* + ELSE IF( (M .LT. 0 .AND. + $ INFO .EQ. -2 ) .OR. + $ (N .LT. 0 .AND. + $ INFO .EQ. -3 ) .OR. + $ (NRHS .LT. 0 .AND. + $ (INFO.EQ. -14 .OR. + $ INFO.EQ. -4 ))) THEN +* +* If PZGELS returns correct error code +* pass this case + WRITE( NOUT, FMT = 9984 ) 'PZGELS' + KPASS = KPASS + 1 + SRESID = SRESID - SRESID + PASSED = 'PASSED' +* Extreme value validation check + ELSE IF( EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, M + DO JK = 1, N + X = MEM(IK*N + JK) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF + ELSE + KPASS = KPASS + 1 + SRESID = SRESID - SRESID + PASSED = 'BYPASS' + + END IF END IF * * Gather maximum of all CPU and WALL clock @@ -1081,6 +1278,12 @@ PROGRAM PDLSDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( ' TRANS=''', A1, ''', M=', I5, ', N=', I5, ', NRHS=', I4, $ ', NB=', I4, ', type', I2, ', test(', I2, ')=', G12.5 ) + 9985 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handeld by', + $ 'the PDGELS API.') + 9984 FORMAT( A, ' returned correct error code. Passing this case.') + 9983 FORMAT( 'Early return case. Safe exit from ', A, ' API' + $ ' Passing this case.') * STOP * diff --git a/TESTING/LIN/pdludriver.f b/TESTING/LIN/pdludriver.f index a6aa5ef2..04a3666c 100644 --- a/TESTING/LIN/pdludriver.f +++ b/TESTING/LIN/pdludriver.f @@ -3,7 +3,7 @@ PROGRAM PDLUDRIVER * -- ScaLAPACK testing driver (version 1.7) -- * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. -* May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======== @@ -65,6 +65,7 @@ PROGRAM PDLUDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, $ LLD_, MB_, M_, NB_, N_, RSRC_ @@ -112,7 +113,7 @@ PROGRAM PDLUDRIVER $ NBVAL( NTESTS ), NRVAL( NTESTS ), $ NVAL( NTESTS ), PVAL( NTESTS ), $ QVAL( NTESTS ) -#ifndef DYNAMIC_WORK_MEM_ALLOC +#ifndef DYNAMIC_WORK_MEM_ALLOC DOUBLE PRECISION MEM( MEMSIZ ), CTIME( 2 ), WTIME( 2 ) #else DOUBLE PRECISION CTIME( 2 ), WTIME( 2 ) @@ -143,6 +144,15 @@ PROGRAM PDLUDRIVER * .. * .. Executable Statements .. * +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X +* * Get starting information * #ifdef DYNAMIC_WORK_MEM_ALLOC @@ -156,14 +166,35 @@ PROGRAM PDLUDRIVER $ NTESTS, NGRIDS, PVAL, NTESTS, QVAL, NTESTS, THRESH, $ EST, MEM, IAM, NPROCS ) CHECK = ( THRESH.GE.0.0E+0 ) -* -* Print version -* - IF( IAM.EQ.0 ) THEN - CALL GET_AOCL_SCALAPACK_VERSION( SVERSION ) - WRITE(*, *) - WRITE(*, *) 'AOCL Version: ', SVERSION - END IF + +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do * * Print headings * @@ -224,6 +255,7 @@ PROGRAM PDLUDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR( 1 ) = 0 IF( M.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -234,6 +266,7 @@ PROGRAM PDLUDRIVER $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * @@ -294,12 +327,31 @@ PROGRAM PDLUDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else +* If M < 0 in LU.dat file then DESCINIT API sets IERR( 1 ) = -2 +* If N < 0 in LU.dat file then DESCINIT API sets IERR( 1 ) = -3 + IF( M.LT.0 .AND. IERR( 1 ).EQ.-2 ) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9984 ) 'M' + ELSE IF (N.LT.0 .AND. IERR( 1 ).EQ.-3 ) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9984 ) 'N' + ELSE IF( IERR( 1 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -415,12 +467,36 @@ PROGRAM PDLUDRIVER IF( INFO.NE.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = * ) 'PDGETRF INFO=', INFO - KFAIL = KFAIL + 1 +* If M < 0 in LU.dat file then PDGETRF API sets INFO = -1 +* If N < 0 in LU.dat file then PDGETRF API sets INFO = -2 + IF ((M.LT.0 .AND. INFO.EQ.-1) .OR. + $ (N.LT.0 .AND. INFO.EQ.-2)) THEN +* If PDGETRF is returning correct error code we need to pass this case +* code we need to pass this case + WRITE( NOUT, FMT = 9983 ) 'PDGETRF' + KPASS = KPASS + 1 + RCOND = ZERO + GO TO 30 + ELSE IF (INFO.GT.0 .AND. EX_FLAG) THEN + WRITE(*,*) 'PCGETRF INFO=', INFO +* Do Nothing, Pass this case in INF/NAN residual calculation + ELSE +* For other error code we will mark test case as fail + KFAIL = KFAIL + 1 + RCOND = ZERO + GO TO 30 + END IF + ELSE IF (M.EQ.0 .OR. N.EQ.0) THEN +* This is the case of early return from ScaLAPACK API +* early return from ScaLAPACK API. +* If there is safe exit from API we need to pass this case + WRITE( NOUT, FMT = 9982 ) 'PDGETRF' + KPASS = KPASS + 1 RCOND = ZERO GO TO 30 END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN * * Check for memory overwrite in LU factorization * @@ -439,7 +515,7 @@ PROGRAM PDLUDRIVER NRHS = 0 NBRHS = 0 * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN * * Compute FRESID = ||A - P*L*U|| / (||A|| * N * eps) * @@ -478,11 +554,43 @@ PROGRAM PDLUDRIVER * ELSE * -* Don't perform the checking, only timing -* - KPASS = KPASS + 1 - FRESID = FRESID - FRESID - PASSED = 'BYPASS' +* Extreme-value validation check + IF( EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, M + DO JK = 1, N + X = MEM(IK*N + JK) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF + ELSE +* Don't perform the checking, only timing + FRESID = FRESID - FRESID + KPASS = KPASS + 1 + PASSED = 'BYPASS' + END IF * END IF * @@ -576,7 +684,7 @@ PROGRAM PDLUDRIVER GO TO 30 END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN CALL PDFILLPAD( ICTXT, LWORK, 1, $ MEM( IPW-IPREPAD ), LWORK, $ IPREPAD, IPOSTPAD, PADVAL ) @@ -592,7 +700,7 @@ PROGRAM PDLUDRIVER $ ANORM1, RCOND, MEM( IPW ), LWORK, $ MEM( IPW2 ), LIWORK, INFO ) * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG)) THEN CALL PDCHEKPAD( ICTXT, 'PDGECON', NP, NQ, $ MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, @@ -629,12 +737,26 @@ PROGRAM PDLUDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 10 END IF +#else +* If NRHS < 0 in LU.dat file then DESCINIT API sets IERR( 1 ) = -3 + IF (NRHS.LT.0 .AND. IERR( 1 ).EQ.-3 ) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9984 ) 'NRHS' + ELSE IF( IERR( 1 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF +#endif * * move IPW to allow room for RHS * @@ -700,7 +822,7 @@ PROGRAM PDLUDRIVER $ MYRHS, MYROW, MYCOL, NPROW, $ NPCOL ) * - IF( CHECK ) + IF( CHECK .AND. .NOT.(EX_FLAG) ) $ CALL PDFILLPAD( ICTXT, NP, MYRHS, $ MEM( IPB-IPREPAD ), $ DESCB( LLD_ ), IPREPAD, @@ -715,7 +837,7 @@ PROGRAM PDLUDRIVER $ DESCB( CSRC_ ), IBSEED, 0, NP, $ 0, MYRHS, MYROW, MYCOL, NPROW, $ NPCOL ) - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN CALL PDFILLPAD( ICTXT, NP, MYRHS, $ MEM( IPB0-IPREPAD ), $ DESCB( LLD_ ), IPREPAD, @@ -741,8 +863,27 @@ PROGRAM PDLUDRIVER $ 1, 1, DESCB, INFO ) * CALL SLTIMER( 2 ) + + IF( INFO.NE.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = * ) 'PDGETRS INFO=', INFO +* If NRHS < 0 in LU.dat file then PDGETRS API sets INFO = -3 + IF( NRHS.LT.0 .AND. INFO.EQ.-3 ) THEN +* If PDGETRS is returning correct error code we need to pass this case + WRITE( NOUT, FMT = 9983 ) 'PDGETRS' + KPASS = KPASS + 1 + GO TO 30 + ELSE IF( INFO .GT. 0 .AND. EX_FLAG) THEN + WRITE(*,*) 'PDGETRS INFO=', INFO +* Do Nothing, Pass this case in residual calculation + ELSE +* For other error code we will mark test case as fail + KFAIL = KFAIL + 1 + GO TO 30 + END IF + END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG)) THEN * * check for memory overwrite * @@ -796,9 +937,42 @@ PROGRAM PDLUDRIVER PASSED = 'FAILED' END IF ELSE - KPASS = KPASS + 1 - SRESID = SRESID - SRESID - PASSED = 'BYPASS' +* Extreme value validation check + IF( EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, M + DO JK = 1, N + X = MEM(IK*N + JK) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF + ELSE + SRESID = SRESID - SRESID + KPASS = KPASS + 1 + PASSED = 'BYPASS' + END IF END IF * IF( EST ) THEN @@ -832,7 +1006,7 @@ PROGRAM PDLUDRIVER GO TO 10 END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG)) THEN CALL PDFILLPAD( ICTXT, LWORK, 1, $ MEM( IPW-IPREPAD ), $ LWORK, IPREPAD, IPOSTPAD, @@ -855,7 +1029,7 @@ PROGRAM PDLUDRIVER $ MEM( IPW ), LWORK, MEM( IPW2 ), $ LIWORK, INFO ) * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN CALL PDCHEKPAD( ICTXT, 'PDGERFS', NP, $ NQ, MEM( IPA0-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, @@ -988,7 +1162,8 @@ PROGRAM PDLUDRIVER 10 CONTINUE 20 END DO * - IF( CHECK.AND.( SRESID.GT.THRESH ) ) THEN + IF( CHECK.AND.( SRESID.GT.THRESH ) .AND. + $ .NOT.(EX_FLAG) ) THEN * * Compute fresid = ||A - P*L*U|| / (||A|| * N * eps) * @@ -1068,6 +1243,11 @@ PROGRAM PDLUDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - P*L*U|| / (||A|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Ax-b||/(||x||*||A||*eps*N) ', F25.7 ) + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, we will handle this case from ', + $ 'ScaLAPACK API.') + 9983 FORMAT( A, ' returned correct error code. Passing this case.') + 9982 FORMAT( 'This is safe exit from ', A, ' API. Passing this case.') * STOP * diff --git a/TESTING/LIN/pdmatgen.f b/TESTING/LIN/pdmatgen.f index fab962c1..eb3b403f 100644 --- a/TESTING/LIN/pdmatgen.f +++ b/TESTING/LIN/pdmatgen.f @@ -6,6 +6,7 @@ SUBROUTINE PDMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * .. Scalar Arguments .. CHARACTER*1 AFORM, DIAG @@ -119,7 +120,7 @@ SUBROUTINE PDMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 ) * .. * .. Local Scalars .. - LOGICAL SYMM, HERM, TRAN + LOGICAL SYMM, HERM, TRAN, EXT_FLAG INTEGER I, IC, IK, INFO, IOFFC, IOFFR, IR, J, JK, $ JUMP1, JUMP2, JUMP3, JUMP4, JUMP5, JUMP6, $ JUMP7, MAXMN, MEND, MOFF, MP, MRCOL, MRROW, @@ -141,8 +142,15 @@ SUBROUTINE PDMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * .. External Functions .. LOGICAL LSAME INTEGER ICEIL, NUMROC + INTEGER CNT1, CNT2, CNT,TOT_CNT, DIV_FACTOR, REGION DOUBLE PRECISION PDRAND EXTERNAL ICEIL, NUMROC, LSAME, PDRAND +* + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .false. + INTEGER :: NAN_PERCENT = 0 + INTEGER :: INF_PERCENT = 0 * .. * .. Executable Statements .. * @@ -153,6 +161,64 @@ SUBROUTINE PDMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, SYMM = LSAME( AFORM, 'S' ) HERM = LSAME( AFORM, 'H' ) TRAN = LSAME( AFORM, 'T' ) + EXT_FLAG = .FALSE. + +* Take command-line arguments if requested +* + +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EXT_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EXT_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do + + IF ( INF_PERCENT + NAN_PERCENT > 100) THEN + print *,"Sum of INF and NaN is", INF_PERCENT+NAN_PERCENT,"%" + help_flag = .true. + END IF + IF ( INF_PERCENT < 0 .OR. NAN_PERCENT < 0) THEN + print *, "Negative INF / NaN value is not allowed" + help_flag = .true. + END IF + +* Display help message if requested + IF (help_flag .AND. IAM.EQ.0) THEN + print *, "" + print *, "Options:" + print *, " -h, --help Display this help message" + print *, " -inf INF percentage in input", + $ " matrix (default: 0 %)" + print *, " -nan NaN percentage in input", + $ " matrix (default: 0 %)" + print *, "" + print *, " Note: INF + NaN values in input matrix", + $ " should be in the range of 0-100 %" + print *, "" + stop + END IF * INFO = 0 IF( .NOT.LSAME( DIAG, 'D' ) .AND. @@ -212,9 +278,46 @@ SUBROUTINE PDMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, JSEED(1) = ISEED JSEED(2) = 0 * +* Extreme-value parameter caclculations + IF( LSAME( DIAG, 'D' ) ) THEN + DIV_FACTOR = 2 + ELSE + DIV_FACTOR = 4 + END IF +* Find type of matrix to identify where to fill INF/NAN, +* If UPPER_TRIANGULAR_MATRIX., start above DIAG + IF( LSAME(AFORM, 'U' ) ) THEN + REGION = (IRNUM * ICNUM)/DIV_FACTOR +* If LOWER_TRIANGULAR/GENERAL MATRIX, start at beginning + ELSE + REGION = 1 + END IF + IF (EXT_FLAG) THEN + ZERO1 = 0.0E0 + ONE1 = 1.0E0 +* Calculate the number of NANs/INFs per grid + CNT1 = (IRNUM * ICNUM * NAN_PERCENT)/100 + CNT2 = (IRNUM * ICNUM * INF_PERCENT)/100 + CNT1 = CEILING(REAL(CNT1)) + CNT2 = CEILING(REAL(CNT2)) +* When Percentage requested by the user is low +* Replace atleast one element with NAN/INF +* Applicable for smaller matrices [2x2] + IF(NAN_PERCENT .GT. 0 .AND. CNT1 .EQ. 0 ) THEN + CNT1 = CNT1 + 1 + PRINT *, 'NAN Percentage is too low,', + $ 'Including one NAN element' + END IF + IF(INF_PERCENT .GT. 0 .AND. CNT2 .EQ. 0 ) THEN + CNT2 = CNT2 + 1 + PRINT *, 'INF Percentage is too low,', + $ 'Including one INF element' + END IF + END IF +* * Symmetric or Hermitian matrix will be generated. * - IF( SYMM.OR.HERM ) THEN + IF( (SYMM.OR.HERM) .AND. .NOT.(EXT_FLAG) ) THEN * * First, generate the lower triangular part (with diagonal block) * @@ -378,7 +481,8 @@ SUBROUTINE PDMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * * (Conjugate) Transposed matrix A will be generated. * - ELSE IF( TRAN .OR. LSAME( AFORM, 'C' ) ) THEN + ELSE IF(( TRAN .OR. LSAME( AFORM, 'C' )) .AND. + $ .NOT.(EXT_FLAG) ) THEN * JUMP1 = 1 JUMP2 = NQNB @@ -445,6 +549,9 @@ SUBROUTINE PDMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * A random matrix is generated. * ELSE + + TOT_CNT = 0 + CNT = 0 * JUMP1 = 1 JUMP2 = NPMB @@ -481,7 +588,20 @@ SUBROUTINE PDMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, IOFFR = ((IR-1)*NPROW+MRROW) * MB DO 250 J = 1, MB IF( IK .GT. IRNUM ) GO TO 270 - A(IK,JK) = ONE - TWO*PDRAND(0) +* Replace with NANs/INFs for extreme values + IF(EXT_FLAG .AND. CNT .LE. (CNT1 + CNT2) .AND. + $ TOT_CNT .GE. REGION) THEN + IF ( CNT .LT. CNT1) THEN + A(IK, JK) = ZERO1/ZERO1 + ELSE IF ( CNT .LT. (CNT1 + CNT2)) THEN + A(IK, JK) = ONE1/ZERO1 + END IF + CNT = CNT + 1 + TOT_CNT = TOT_CNT + 1 + ELSE + A(IK,JK) = ONE - TWO*PDRAND(0) + TOT_CNT = TOT_CNT + 1 + END IF IK = IK + 1 250 CONTINUE CALL JUMPIT( IA2, IC2, IB1, IRAN2 ) @@ -518,6 +638,8 @@ SUBROUTINE PDMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, RETURN END IF * + TOT_CNT = 0 + CNT = 0 MAXMN = MAX(M, N) JK = 1 DO 340 IC = NOFF+1, NEND @@ -528,7 +650,19 @@ SUBROUTINE PDMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, IF( IOFFC.EQ.IOFFR ) THEN DO 310 J = 0, MB-1 IF( IK .GT. IRNUM ) GO TO 330 - A(IK,JK+J) = ABS(A(IK,JK+J)) + MAXMN + IF(EXT_FLAG .AND. CNT .LE. (CNT1 + CNT2) .AND. + $ TOT_CNT .GT. (N/2) ) THEN + IF ( CNT .LT. CNT1) THEN + A(IK, JK+J) = ZERO1/ZERO1 + ELSE IF ( CNT .LT. (CNT1 + CNT2)) THEN + A(IK, JK+J) = ONE1/ZERO1 + END IF + CNT = CNT + 1 + TOT_CNT = TOT_CNT + 1 + ELSE + A(IK,JK+J) = ABS(A(IK,JK+J)) + MAXMN + TOT_CNT = TOT_CNT + 1 + END IF IK = IK + 1 310 CONTINUE ELSE @@ -544,4 +678,4 @@ SUBROUTINE PDMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * * End of PDMATGEN * - END + END \ No newline at end of file diff --git a/TESTING/LIN/pdqrdriver.f b/TESTING/LIN/pdqrdriver.f index 92cb83da..f8d0bff4 100644 --- a/TESTING/LIN/pdqrdriver.f +++ b/TESTING/LIN/pdqrdriver.f @@ -4,6 +4,7 @@ PROGRAM PDQRDRIVER * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 28, 2001 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======= @@ -62,6 +63,7 @@ PROGRAM PDQRDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, $ LLD_, MB_, M_, NB_, N_, RSRC_ @@ -94,6 +96,7 @@ PROGRAM PDQRDRIVER CHARACTER*8 ROUTCHK CHARACTER*80 OUTFILE LOGICAL CHECK + LOGICAL M_INVALID, N_INVALID INTEGER I, IAM, IASEED, ICTXT, IMIDPAD, INFO, IPA, $ IPOSTPAD, IPPIV, IPREPAD, IPTAU, IPW, J, K, $ KFAIL, KPASS, KSKIP, KTESTS, L, LIPIV, LTAU, @@ -103,6 +106,7 @@ PROGRAM PDQRDRIVER $ WORKSIZ REAL THRESH DOUBLE PRECISION ANORM, FRESID, NOPS, TMFLOPS + CHARACTER*8 API_NAME * .. * .. Arrays .. CHARACTER*2 FACTOR( NTESTS ) @@ -138,6 +142,16 @@ PROGRAM PDQRDRIVER * .. * .. Data Statements .. DATA KTESTS, KPASS, KFAIL, KSKIP /4*0/ +* +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X +* * .. * .. Executable Statements .. * @@ -153,6 +167,37 @@ PROGRAM PDQRDRIVER $ NTESTS, NGRIDS, PVAL, NTESTS, QVAL, NTESTS, $ THRESH, MEM, IAM, NPROCS ) CHECK = ( THRESH.GE.0.0E+0 ) + M_INVALID = .TRUE. + N_INVALID = .TRUE. +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* * * Loop over the different factorization types * @@ -188,7 +233,7 @@ PROGRAM PDQRDRIVER ROUT = 'PDGEQPF' ROUTCHK = 'PDGEQRRV' WRITE( NOUT, FMT = 9986 ) - $ 'QR factorization with column pivoting tests.' + $ 'QP factorization with column pivoting tests.' ELSE IF( LSAMEN( 2, FACT, 'TZ' ) ) THEN ROUT = 'PDTZRZF' ROUTCHK = 'PDTZRZRV' @@ -250,6 +295,7 @@ PROGRAM PDQRDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR(1) = 0 IF( M.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -260,17 +306,20 @@ PROGRAM PDQRDRIVER $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Make sure no one had error * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'matrix' KSKIP = KSKIP + 1 GO TO 20 END IF +#endif * * Loop over different blocking sizes * @@ -347,12 +396,41 @@ PROGRAM PDQRDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, $ 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 10 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 .OR. + $ IERR(1) .EQ. -3 .OR. IERR(1) .EQ. -12 )) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid M and N +* -4, -8 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9984 ) 'N' +* disable extreme value case when N < 0 + EX_FLAG = .FALSE. + ELSE IF(M .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 .OR. + $ IERR(1) .EQ. -3 .OR. IERR(1) .EQ. -12 )) THEN + WRITE( NOUT, FMT = 9984 ) 'M' +* disable extreme value case when M < 0 + EX_FLAG = .FALSE. + ELSE IF(M .EQ. 0 .OR. N .EQ. 0) THEN +* disable extreme value case when M < 0 + EX_FLAG = .FALSE. + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF +#endif * * Assign pointers into MEM for ScaLAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -537,7 +615,7 @@ PROGRAM PDQRDRIVER * * Need the Infinity of A for checking * - IF( CHECK ) THEN + IF( CHECK .AND. (N .GT. 0 .AND. M .GT. 0)) THEN CALL PDFILLPAD( ICTXT, MP, NQ, MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, $ PADVAL ) @@ -575,173 +653,261 @@ PROGRAM PDQRDRIVER * Perform QR factorizations * IF( LSAMEN( 2, FACT, 'QR' ) ) THEN + API_NAME = 'PDGEQRF' CALL SLTIMER( 1 ) CALL PDGEQRF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPTAU ), MEM( IPW ), LWORK, $ INFO ) CALL SLTIMER( 1 ) ELSE IF( LSAMEN( 2, FACT, 'QL' ) ) THEN + API_NAME = 'PDGEQLF' CALL SLTIMER( 1 ) CALL PDGEQLF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPTAU ), MEM( IPW ), LWORK, $ INFO ) CALL SLTIMER( 1 ) ELSE IF( LSAMEN( 2, FACT, 'LQ' ) ) THEN + API_NAME = 'PDGELQF' CALL SLTIMER( 1 ) CALL PDGELQF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPTAU ), MEM( IPW ), LWORK, $ INFO ) CALL SLTIMER( 1 ) ELSE IF( LSAMEN( 2, FACT, 'RQ' ) ) THEN + API_NAME = 'PDGERQF' CALL SLTIMER( 1 ) CALL PDGERQF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPTAU ), MEM( IPW ), LWORK, $ INFO ) CALL SLTIMER( 1 ) ELSE IF( LSAMEN( 2, FACT, 'QP' ) ) THEN + API_NAME = 'PDGEQPF' CALL SLTIMER( 1 ) CALL PDGEQPF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPPIV ), MEM( IPTAU ), $ MEM( IPW ), LWORK, INFO ) CALL SLTIMER( 1 ) ELSE IF( LSAMEN( 2, FACT, 'TZ' ) ) THEN + API_NAME = 'PDTZRZF' CALL SLTIMER( 1 ) +#ifdef ENABLE_DRIVER_CHECK IF( N.GE.M ) $ CALL PDTZRZF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPTAU ), MEM( IPW ), LWORK, $ INFO ) +#else + IF( N .LT. M ) THEN + WRITE( NOUT, FMT = 9982 ) + END IF + CALL PDTZRZF( M, N, MEM( IPA ), 1, 1, DESCA, + $ MEM( IPTAU ), MEM( IPW ), LWORK, + $ INFO ) +#endif CALL SLTIMER( 1 ) END IF * - IF( CHECK ) THEN + IF( CHECK .AND. (.NOT.(EX_FLAG)) ) THEN +* + IF(INFO .EQ. 0 .AND. N .GT. 0 .AND. + $ M .GT. 0) THEN * -* Check for memory overwrite in factorization * - CALL PDCHEKPAD( ICTXT, ROUT, MP, NQ, +* Check for memory overwrite in factorization +* + CALL PDCHEKPAD( ICTXT, ROUT, MP, NQ, $ MEM( IPA-IPREPAD ), DESCA( LLD_ ), $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PDCHEKPAD( ICTXT, ROUT, LTAU, 1, + CALL PDCHEKPAD( ICTXT, ROUT, LTAU, 1, $ MEM( IPTAU-IPREPAD ), LTAU, $ IPREPAD, IPOSTPAD, PADVAL ) - IF( LSAMEN( 2, FACT, 'QP' ) ) THEN - CALL PDCHEKPAD( ICTXT, ROUT, LIPIV, 1, + IF( LSAMEN( 2, FACT, 'QP' ) ) THEN + CALL PDCHEKPAD( ICTXT, ROUT, LIPIV, 1, $ MEM( IPPIV-IPREPAD ), LIPIV, $ IPREPAD, IPOSTPAD, PADVAL ) - END IF - CALL PDCHEKPAD( ICTXT, ROUT, WORKFCT-IPOSTPAD, 1, - $ MEM( IPW-IPREPAD ), + END IF + CALL PDCHEKPAD( ICTXT, ROUT, WORKFCT-IPOSTPAD, + $ 1, MEM( IPW-IPREPAD ), $ WORKFCT-IPOSTPAD, IPREPAD, $ IPOSTPAD, PADVAL ) - CALL PDFILLPAD( ICTXT, WORKSIZ-IPOSTPAD, 1, + CALL PDFILLPAD( ICTXT, WORKSIZ-IPOSTPAD, 1, $ MEM( IPW-IPREPAD ), $ WORKSIZ-IPOSTPAD, $ IPREPAD, IPOSTPAD, PADVAL ) * - IF( LSAMEN( 2, FACT, 'QR' ) ) THEN + IF( LSAMEN( 2, FACT, 'QR' ) ) THEN * -* Compute residual = ||A-Q*R|| / (||A||*N*eps) +* Compute residual = ||A-Q*R|| / (||A||*N*eps) * - CALL PDGEQRRV( M, N, MEM( IPA ), 1, 1, DESCA, - $ MEM( IPTAU ), MEM( IPW ) ) - CALL PDLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, - $ 1, DESCA, IASEED, ANORM, FRESID, + CALL PDGEQRRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, MEM( IPTAU ), MEM( IPW ) ) + CALL PDLAFCHK( 'No', 'No', M, N, MEM( IPA ), + $ 1, 1, DESCA, IASEED, ANORM, FRESID, $ MEM( IPW ) ) - ELSE IF( LSAMEN( 2, FACT, 'QL' ) ) THEN + ELSE IF( LSAMEN( 2, FACT, 'QL' ) ) THEN * -* Compute residual = ||A-Q*L|| / (||A||*N*eps) +* Compute residual = ||A-Q*L|| / (||A||*N*eps) * - CALL PDGEQLRV( M, N, MEM( IPA ), 1, 1, DESCA, + CALL PDGEQLRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, $ MEM( IPTAU ), MEM( IPW ) ) - CALL PDLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, + CALL PDLAFCHK( 'No', 'No', M, N, + $ MEM( IPA ), 1, $ 1, DESCA, IASEED, ANORM, FRESID, $ MEM( IPW ) ) - ELSE IF( LSAMEN( 2, FACT, 'LQ' ) ) THEN + ELSE IF( LSAMEN( 2, FACT, 'LQ' ) ) THEN * -* Compute residual = ||A-L*Q|| / (||A||*N*eps) +* Compute residual = ||A-L*Q|| / (||A||*N*eps) * - CALL PDGELQRV( M, N, MEM( IPA ), 1, 1, DESCA, + CALL PDGELQRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, $ MEM( IPTAU ), MEM( IPW ) ) - CALL PDLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, + CALL PDLAFCHK( 'No', 'No', M, N, + $ MEM( IPA ), 1, $ 1, DESCA, IASEED, ANORM, FRESID, $ MEM( IPW ) ) - ELSE IF( LSAMEN( 2, FACT, 'RQ' ) ) THEN + ELSE IF( LSAMEN( 2, FACT, 'RQ' ) ) THEN * -* Compute residual = ||A-R*Q|| / (||A||*N*eps) +* Compute residual = ||A-R*Q|| / (||A||*N*eps) * - CALL PDGERQRV( M, N, MEM( IPA ), 1, 1, DESCA, + CALL PDGERQRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, $ MEM( IPTAU ), MEM( IPW ) ) - CALL PDLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, + CALL PDLAFCHK( 'No', 'No', M, N, + $ MEM( IPA ), 1, $ 1, DESCA, IASEED, ANORM, FRESID, $ MEM( IPW ) ) - ELSE IF( LSAMEN( 2, FACT, 'QP' ) ) THEN + ELSE IF( LSAMEN( 2, FACT, 'QP' ) ) THEN * -* Compute residual = ||AP-Q*R|| / (||A||*N*eps) +* Compute residual = ||AP-Q*R|| / (||A||*N*eps) * - CALL PDGEQRRV( M, N, MEM( IPA ), 1, 1, DESCA, + CALL PDGEQRRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, $ MEM( IPTAU ), MEM( IPW ) ) - ELSE IF( LSAMEN( 2, FACT, 'TZ' ) ) THEN + ELSE IF( LSAMEN( 2, FACT, 'TZ' ) ) THEN * -* Compute residual = ||A-T*Z|| / (||A||*N*eps) +* Compute residual = ||A-T*Z|| / (||A||*N*eps) * - IF( N.GE.M ) THEN - CALL PDTZRZRV( M, N, MEM( IPA ), 1, 1, DESCA, + IF( N.GE.M ) THEN + CALL PDTZRZRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, $ MEM( IPTAU ), MEM( IPW ) ) + + END IF + CALL PDLAFCHK( 'No', 'No', M, N, + $ MEM( IPA ), 1, + $ 1, DESCA, IASEED, ANORM, + $ FRESID, MEM( IPW ) ) END IF - CALL PDLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, - $ 1, DESCA, IASEED, ANORM, FRESID, - $ MEM( IPW ) ) - END IF * -* Check for memory overwrite +* Check for memory overwrite * - CALL PDCHEKPAD( ICTXT, ROUTCHK, MP, NQ, + CALL PDCHEKPAD( ICTXT, ROUTCHK, MP, NQ, $ MEM( IPA-IPREPAD ), DESCA( LLD_ ), $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PDCHEKPAD( ICTXT, ROUTCHK, LTAU, 1, + CALL PDCHEKPAD( ICTXT, ROUTCHK, LTAU, 1, $ MEM( IPTAU-IPREPAD ), LTAU, $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PDCHEKPAD( ICTXT, ROUTCHK, WORKSIZ-IPOSTPAD, + CALL PDCHEKPAD( ICTXT, ROUTCHK, + $ WORKSIZ-IPOSTPAD, $ 1, MEM( IPW-IPREPAD ), $ WORKSIZ-IPOSTPAD, IPREPAD, $ IPOSTPAD, PADVAL ) * - IF( LSAMEN( 2, FACT, 'QP' ) ) THEN + IF( LSAMEN( 2, FACT, 'QP' ) ) THEN * - CALL PDQPPIV( M, N, MEM( IPA ), 1, 1, DESCA, - $ MEM( IPPIV ) ) + CALL PDQPPIV( M, N, MEM( IPA ), 1, 1, + $ DESCA, MEM( IPPIV ) ) * -* Check for memory overwrite +* Check for memory overwrite * - CALL PDCHEKPAD( ICTXT, 'PDQPPIV', MP, NQ, + CALL PDCHEKPAD( ICTXT, 'PDQPPIV', MP, NQ, $ MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PDCHEKPAD( ICTXT, 'PDQPPIV', LIPIV, 1, + CALL PDCHEKPAD( ICTXT, 'PDQPPIV', LIPIV, 1, $ MEM( IPPIV-IPREPAD ), LIPIV, $ IPREPAD, IPOSTPAD, PADVAL ) * - CALL PDLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, - $ 1, DESCA, IASEED, ANORM, FRESID, - $ MEM( IPW ) ) + CALL PDLAFCHK( 'No', 'No', M, N, + $ MEM( IPA ), 1, + $ 1, DESCA, IASEED, ANORM, FRESID, + $ MEM( IPW ) ) * -* Check for memory overwrite +* Check for memory overwrite * - CALL PDCHEKPAD( ICTXT, 'PDLAFCHK', MP, NQ, + CALL PDCHEKPAD( ICTXT, 'PDLAFCHK', MP, NQ, $ MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PDCHEKPAD( ICTXT, 'PDLAFCHK', + CALL PDCHEKPAD( ICTXT, 'PDLAFCHK', $ WORKSIZ-IPOSTPAD, 1, $ MEM( IPW-IPREPAD ), $ WORKSIZ-IPOSTPAD, IPREPAD, $ IPOSTPAD, PADVAL ) +* + END IF END IF * * Test residual and detect NaN result * - IF( LSAMEN( 2, FACT, 'TZ' ) .AND. N.LT.M ) THEN - KSKIP = KSKIP + 1 - PASSED = 'BYPASS' + M_INVALID = M.LT.0 .AND. + $ ((INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'QR')) .OR. + $ (INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'QL')) .OR. + $ (INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'LQ')) .OR. + $ (INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'RQ')) .OR. + $ (INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'QP')) .OR. + $ (INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'TZ' ))) + N_INVALID = N.LT.0 .AND. + $ ((INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'QR')) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'QL')) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'LQ')) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'RQ')) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'QP')) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'TZ' ))) +* + IF( (N.EQ.0 .AND. INFO.EQ.0) .OR. + $ (M.EQ.0 .AND. INFO.EQ.0) ) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) KPASS, API_NAME + PASSED = 'PASSED' +* RE-ENABLE for EX CASE + IF(INF_PERCENT .GT. 0 .OR. + $ NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + GO TO 10 + ELSE IF(M_INVALID .OR. N_INVALID) THEN +* When N < 0/Invalid, INFO = -2 +* When M < 0/Invalid, INFO = -1 +* Expected Error code for N < 0 +* Hence this case can be passed + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9983 ) KPASS, API_NAME + PASSED = 'PASSED' +* RE-ENABLE for EX CASE + IF(INF_PERCENT .GT. 0 .OR. + $ NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + ELSE IF( LSAMEN( 2, FACT, 'TZ' ) .AND. + $ (N.LT.M .AND. INFO.EQ.-2 ) ) THEN + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9983 ) KPASS, API_NAME ELSE IF( FRESID.LE.THRESH .AND. $ (FRESID-FRESID).EQ.0.0D+0 ) THEN @@ -754,12 +920,47 @@ PROGRAM PDQRDRIVER END IF * ELSE + +* Extreme value cases + IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, M + DO JK = 1, N+1 + X = MEM(IK*N + JK) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF + FRESID = FRESID - FRESID * -* Don't perform the checking, only timing -* - KPASS = KPASS + 1 - FRESID = FRESID - FRESID - PASSED = 'BYPASS' +* Don't perform the checking, only the timing +* operation + ELSE + KPASS = KPASS + 1 + FRESID = FRESID - FRESID + PASSED = 'BYPASS' + END IF * END IF * @@ -881,6 +1082,16 @@ PROGRAM PDQRDRIVER 9988 FORMAT( I5, ' tests skipped because of illegal input values.' ) 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( A ) + 9985 FORMAT( '----------Test-',I3,' Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9983 FORMAT( '----------Negative Test-',I3,' Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') + 9982 FORMAT( ' N < M case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the PCTZRZF API.') * STOP * diff --git a/TESTING/LIN/psdbdriver.f b/TESTING/LIN/psdbdriver.f index 535ae695..14fb1a44 100644 --- a/TESTING/LIN/psdbdriver.f +++ b/TESTING/LIN/psdbdriver.f @@ -6,6 +6,8 @@ PROGRAM PSDBDRIVER * and University of California, Berkeley. * November 15, 1997 * +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. +* * Purpose * ======= * @@ -69,6 +71,7 @@ PROGRAM PSDBDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER TOTMEM #ifndef DYNAMIC_WORK_MEM_ALLOC @@ -142,6 +145,14 @@ PROGRAM PSDBDRIVER DATA KFAIL, KPASS, KSKIP, KTESTS / 4*0 / * .. * +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X * * * .. Executable Statements .. @@ -159,8 +170,37 @@ PROGRAM PSDBDRIVER $ BWLVAL, BWUVAL, NTESTS, NNB, NBVAL, NTESTS, NNR, $ NRVAL, NTESTS, NNBR, NBRVAL, NTESTS, NGRIDS, PVAL, $ NTESTS, QVAL, NTESTS, THRESH, MEM, IAM, NPROCS ) +* * CHECK = ( THRESH.GE.0.0E+0 ) +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do * * Print headings * @@ -180,6 +220,7 @@ PROGRAM PSDBDRIVER * * Make sure grid information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR( 1 ) = 0 IF( NPROW.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -201,6 +242,7 @@ PROGRAM PSDBDRIVER KSKIP = KSKIP + 1 GO TO 50 END IF +#endif * * Define process grid * @@ -230,23 +272,28 @@ PROGRAM PSDBDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'size' KSKIP = KSKIP + 1 GO TO 40 END IF +#endif * * DO 45 BW_NUM = 1, NBW @@ -284,10 +331,12 @@ PROGRAM PSDBDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 45 END IF +#endif * DO 30 K = 1, NNB * @@ -300,6 +349,10 @@ PROGRAM PSDBDRIVER NB = MAX( NB, 2*MAX(BWL,BWU) ) NB = MIN( N, NB ) END IF +* Altering the auto-assign for early return of N case + IF (N .EQ. 0 .AND. NB.EQ.0) THEN + NB = 1 + END IF * * Make sure NB is legal * @@ -313,10 +366,13 @@ PROGRAM PSDBDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 30 END IF +#endif * * Padding constants * @@ -358,12 +414,42 @@ PROGRAM PSDBDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -3 .OR. + $ IERR(1) .EQ. -6 .OR. IERR(1) .EQ. -9 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -12 )) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid M and N +* -4, -6 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9983 ) 'N' +* disable extreme value case when N < 0 + EX_FLAG = .FALSE. + ELSE IF(N .EQ. 0 .AND. (IERR(1) .EQ. 0 .OR. + $ IERR(1) .EQ. -5 .OR. IERR(1) .EQ. -10 .OR. + $ IERR(1) .EQ. -15 .OR. IERR(1) .EQ. -20 )) THEN +* DESCINIT returns the correct error code, +* When N = 0, IERR(1) could be return +* -5, -10 or -20 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING +* disable extreme value case when N = 0 + EX_FLAG = .FALSE. + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -480,17 +566,19 @@ PROGRAM PSDBDRIVER $ ((BWL+BWU+1)+10), 0, 0, IASEED, MYROW, $ MYCOL, NPROW, NPCOL ) * - CALL PSFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), + IF(N .GE. 0) THEN + CALL PSFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), $ ((BWL+BWU+1)+10), IPREPAD, IPOSTPAD, $ PADVAL ) * - CALL PSFILLPAD( ICTXT, WORKSIZ, 1, + CALL PSFILLPAD( ICTXT, WORKSIZ, 1, $ MEM( IP_DRIVER_W-IPREPAD ), WORKSIZ, $ IPREPAD, IPOSTPAD, PADVAL ) + END IF * * Calculate norm of A for residual error-checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0) THEN * ANORM = PSLANGE( '1', (BWL+BWU+1), $ N, MEM( IPA ), 1, 1, @@ -519,14 +607,25 @@ PROGRAM PSDBDRIVER CALL SLTIMER( 1 ) * IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) THEN - WRITE( NOUT, FMT = * ) 'PSDBTRF INFO=', INFO - ENDIF - KFAIL = KFAIL + 1 - GO TO 30 + IF(N .LT. 0 .AND. (INFO .EQ. -1 .OR. + $ INFO .EQ. -604 )) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PDDBTRF INFO=', INFO +* When N = 0, make BWL and BWU = 0 for early return + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -3) THEN +* expected error code, when bandwidth is incorrect +* pass this case to solve API + WRITE( NOUT, FMT = * ) 'PSDBTRF INFO=', INFO + ELSE + IF( IAM.EQ.0 ) THEN + WRITE( NOUT, FMT = * ) 'PSDBTRF INFO=', INFO + ENDIF + KFAIL = KFAIL + 1 + GO TO 30 + END IF END IF * - IF( CHECK ) THEN + IF( CHECK .AND. INFO .EQ. 0 ) THEN * * Check for memory overwrite in factorization * @@ -637,14 +736,23 @@ PROGRAM PSDBDRIVER CALL SLTIMER( 2 ) * IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) - $ WRITE( NOUT, FMT = * ) 'PSDBTRS INFO=', INFO - KFAIL = KFAIL + 1 - PASSED = 'FAILED' - GO TO 20 + IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804)) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PCDBTRS INFO=', INFO + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -4) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PSDBTRS INFO=', INFO + ELSE + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = * ) 'PSDBTRS INFO=', INFO + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + GO TO 20 + END IF END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN * * check for memory overwrite * @@ -658,12 +766,14 @@ PROGRAM PSDBDRIVER * SRESID = ZERO * - CALL PSDBLASCHK( 'N', 'D', TRANS, + IF(INFO .EQ. 0) THEN + CALL PSDBLASCHK( 'N', 'D', TRANS, $ N, BWL, BWU, NRHS, $ MEM( IPB ), 1, 1, DESCB2D, $ IASEED, MEM( IPA ), 1, 1, DESCA2D, $ IBSEED, ANORM, SRESID, $ MEM( IP_DRIVER_W ), WORKSIZ ) + END IF * IF( IAM.EQ.0 ) THEN IF( SRESID.GT.THRESH ) @@ -672,7 +782,23 @@ PROGRAM PSDBDRIVER * * The second test is a NaN trap * - IF( ( SRESID.LE.THRESH ).AND. + IF( N .EQ. 0 .AND. (INFO .EQ. -4 .OR. + $ INFO .EQ. 0)) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9984 ) 'PCDBTRS' + PASSED = 'PASSED' + ELSE IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804 )) THEN +* When N < 0/Invalid, PDDBTRS INFO = -1 +* Expected Error code for N < 0 +* Hence this case can be passed + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9982 ) 'PCDBTRS' + PASSED = 'PASSED' + ELSE IF( ( SRESID.LE.THRESH ).AND. $ ( (SRESID-SRESID).EQ.0.0E+0 ) ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' @@ -680,6 +806,35 @@ PROGRAM PSDBDRIVER KFAIL = KFAIL + 1 PASSED = 'FAILED' END IF + ELSE IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, N-1 + DO JK = 1, N + X = (MEM(IK*N + JK)) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite(X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF * END IF * @@ -921,6 +1076,13 @@ PROGRAM PSDBDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - ', A4, '|| / (||A|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Ax-b||/(||x||*||A||*eps*N) ', F25.7 ) + 9984 FORMAT( '----------Test Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9983 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9982 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') * STOP * diff --git a/TESTING/LIN/psdtdriver.f b/TESTING/LIN/psdtdriver.f index 1f4599d0..ea0caad6 100644 --- a/TESTING/LIN/psdtdriver.f +++ b/TESTING/LIN/psdtdriver.f @@ -6,6 +6,8 @@ PROGRAM PSDTDRIVER * and University of California, Berkeley. * November 15, 1997 * +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. +* * Purpose * ======= * @@ -69,6 +71,7 @@ PROGRAM PSDTDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER TOTMEM #ifndef DYNAMIC_WORK_MEM_ALLOC @@ -142,6 +145,14 @@ PROGRAM PSDTDRIVER DATA KFAIL, KPASS, KSKIP, KTESTS / 4*0 / * .. * +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X * * * .. Executable Statements .. @@ -162,6 +173,35 @@ PROGRAM PSDTDRIVER * CHECK = ( THRESH.GE.0.0E+0 ) * +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* * Print headings * IF( IAM.EQ.0 ) THEN @@ -180,6 +220,7 @@ PROGRAM PSDTDRIVER * * Make sure grid information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR( 1 ) = 0 IF( NPROW.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -201,6 +242,7 @@ PROGRAM PSDTDRIVER KSKIP = KSKIP + 1 GO TO 50 END IF +#endif * * Define process grid * @@ -230,23 +272,28 @@ PROGRAM PSDTDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'size' KSKIP = KSKIP + 1 GO TO 40 END IF +#endif * * DO 45 BW_NUM = 1, NBW @@ -284,10 +331,12 @@ PROGRAM PSDTDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 45 END IF +#endif * DO 30 K = 1, NNB * @@ -300,6 +349,10 @@ PROGRAM PSDTDRIVER NB = MAX( NB, 2*INT_ONE ) NB = MIN( N, NB ) END IF +* Altering the auto-assign for early return of N case + IF (N .EQ. 0 .AND. NB.EQ.0) THEN + NB = 1 + END IF * * Make sure NB is legal * @@ -313,10 +366,13 @@ PROGRAM PSDTDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 30 END IF +#endif * * Padding constants * @@ -358,12 +414,43 @@ PROGRAM PSDTDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -3 .OR. + $ IERR(1) .EQ. -6 .OR. IERR(1) .EQ. -9 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -12 .OR. + $ IERR(1) .EQ. -2 .OR. IERR(1) .EQ. -8) ) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid M and N +* -4, -6 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9983 ) 'N' +* disable extreme value case when N < 0 + EX_FLAG = .FALSE. + ELSE IF(N .EQ. 0 .AND. (IERR(1) .EQ. 0 .OR. + $ IERR(1) .EQ. -5 .OR. IERR(1) .EQ. -10 .OR. + $ IERR(1) .EQ. -15 .OR. IERR(1) .EQ. -20 )) THEN +* DESCINIT returns the correct error code, +* When N = 0, +* -5, -10 or -20 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING +* disable extreme value case when N = 0 + EX_FLAG = .FALSE. + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -477,17 +564,19 @@ PROGRAM PSDTDRIVER CALL PSBMATGEN( ICTXT, 'T', 'D', BWL, BWU, N, (3), NB, $ MEM( IPA ), NB+10, 0, 0, IASEED, MYROW, $ MYCOL, NPROW, NPCOL ) - CALL PSFILLPAD( ICTXT, NQ, NP, MEM( IPA-IPREPAD ), + IF(N .GE. 0) THEN + CALL PSFILLPAD( ICTXT, NQ, NP, MEM( IPA-IPREPAD ), $ NB+10, IPREPAD, IPOSTPAD, $ PADVAL ) * - CALL PSFILLPAD( ICTXT, WORKSIZ, 1, + CALL PSFILLPAD( ICTXT, WORKSIZ, 1, $ MEM( IP_DRIVER_W-IPREPAD ), WORKSIZ, $ IPREPAD, IPOSTPAD, PADVAL ) + END IF * * Calculate norm of A for residual error-checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * ANORM = PSLANGE( 'I', N, $ (3), MEM( IPA ), 1, 1, @@ -517,14 +606,25 @@ PROGRAM PSDTDRIVER CALL SLTIMER( 1 ) * IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) THEN - WRITE( NOUT, FMT = * ) 'PSDTTRF INFO=', INFO - ENDIF - KFAIL = KFAIL + 1 - GO TO 30 + IF(N .LT. 0 .AND. (INFO .EQ. -1 .OR. + $ INFO .EQ. -604 )) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PSDTTRF INFO=', INFO +* When N = 0, make BWL and BWU = 0 for early return + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -3) THEN +* expected error code, when bandwidth is > 0 +* pass this case to solve API + WRITE( NOUT, FMT = * ) 'PSDTTRF INFO=', INFO + ELSE + IF( IAM.EQ.0 ) THEN + WRITE( NOUT, FMT = * ) 'PSDTTRF INFO=', INFO + ENDIF + KFAIL = KFAIL + 1 + GO TO 30 + END IF END IF * - IF( CHECK ) THEN + IF( CHECK .AND. INFO .EQ. 0 ) THEN * * Check for memory overwrite in factorization * @@ -637,14 +737,23 @@ PROGRAM PSDTDRIVER CALL SLTIMER( 2 ) * IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) - $ WRITE( NOUT, FMT = * ) 'PSDTTRS INFO=', INFO - KFAIL = KFAIL + 1 - PASSED = 'FAILED' - GO TO 20 + IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804)) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PSDTTRS INFO=', INFO + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -4) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PSDTTRS INFO=', INFO + ELSE + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = * ) 'PSDTTRS INFO=', INFO + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + GO TO 20 + END IF END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN * * check for memory overwrite * @@ -664,12 +773,14 @@ PROGRAM PSDTDRIVER CALL DESCINIT( DESCA2D, (3), N, $ (3), NB, 0, 0, $ ICTXT, (3), IERR( 1 ) ) - CALL PSDTLASCHK( 'N', 'D', TRANS, + IF(INFO .EQ. 0) THEN + CALL PSDTLASCHK( 'N', 'D', TRANS, $ N, BWL, BWU, NRHS, $ MEM( IPB ), 1, 1, DESCB2D, $ IASEED, MEM( IPA ), 1, 1, DESCA2D, $ IBSEED, ANORM, SRESID, $ MEM( IP_DRIVER_W ), WORKSIZ ) + END IF * IF( IAM.EQ.0 ) THEN IF( SRESID.GT.THRESH ) @@ -678,7 +789,33 @@ PROGRAM PSDTDRIVER * * The second test is a NaN trap * - IF( ( SRESID.LE.THRESH ).AND. + IF( N .EQ. 0 .AND. (INFO .EQ. -4 .OR. + $ INFO .EQ. 0)) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9984 ) 'PSDTTRS' + PASSED = 'PASSED' +* Re-enable EX_FLAG + IF(NAN_PERCENT .GT. 0 .OR. + $ INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + ELSE IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804 )) THEN +* When N < 0/Invalid, PSDTTRS INFO = -1 +* Expected Error code for N < 0 +* Hence this case can be passed + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9982 ) 'PSDTTRS' + PASSED = 'PASSED' +* Re-enable EX_FLAG + IF(NAN_PERCENT .GT. 0 .OR. + $ INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + ELSE IF( ( SRESID.LE.THRESH ).AND. $ ( (SRESID-SRESID).EQ.0.0E+0 ) ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' @@ -686,6 +823,37 @@ PROGRAM PSDTDRIVER KFAIL = KFAIL + 1 PASSED = 'FAILED' END IF +* Extreme-value validation block + ELSE IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, N-1 + DO JK = 1, N + X = (MEM(IK*N + JK)) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF * END IF * @@ -927,6 +1095,13 @@ PROGRAM PSDTDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - ', A4, '|| / (||A|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Ax-b||/(||x||*||A||*eps*N) ', F25.7 ) + 9984 FORMAT( '----------Test Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9983 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9982 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') * STOP * diff --git a/TESTING/LIN/psgbdriver.f b/TESTING/LIN/psgbdriver.f index ae1fe316..e1e78a90 100644 --- a/TESTING/LIN/psgbdriver.f +++ b/TESTING/LIN/psgbdriver.f @@ -6,6 +6,8 @@ PROGRAM PSGBDRIVER * and University of California, Berkeley. * November 15, 1997 * +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. +* * Purpose * ======= * @@ -75,6 +77,7 @@ PROGRAM PSGBDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER TOTMEM, INTMEM #ifndef DYNAMIC_WORK_MEM_ALLOC @@ -149,6 +152,14 @@ PROGRAM PSGBDRIVER DATA KFAIL, KPASS, KSKIP, KTESTS / 4*0 / * .. * +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X * * * .. Executable Statements .. @@ -169,6 +180,35 @@ PROGRAM PSGBDRIVER * CHECK = ( THRESH.GE.0.0E+0 ) * +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* * Print headings * IF( IAM.EQ.0 ) THEN @@ -187,6 +227,7 @@ PROGRAM PSGBDRIVER * * Make sure grid information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR( 1 ) = 0 IF( NPROW.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -208,6 +249,7 @@ PROGRAM PSGBDRIVER KSKIP = KSKIP + 1 GO TO 50 END IF +#endif * * Define process grid * @@ -237,23 +279,28 @@ PROGRAM PSGBDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'size' KSKIP = KSKIP + 1 GO TO 40 END IF +#endif * * DO 45 BW_NUM = 1, NBW @@ -291,10 +338,12 @@ PROGRAM PSGBDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 45 END IF +#endif * DO 30 K = 1, NNB * @@ -307,6 +356,10 @@ PROGRAM PSGBDRIVER NB = MAX( NB, 2*(BWL+BWU) ) NB = MIN( N, NB ) END IF +* Altering the auto-assign for early return of N case + IF (N .EQ. 0 .AND. NB.EQ.0) THEN + NB = 1 + END IF * * Make sure NB is legal * @@ -327,10 +380,13 @@ PROGRAM PSGBDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 30 END IF +#endif * * Padding constants * @@ -372,12 +428,43 @@ PROGRAM PSGBDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -3 .OR. + $ IERR(1) .EQ. -6 .OR. IERR(1) .EQ. -9 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -12 .OR. + $ IERR(1) .EQ. -2 .OR. IERR(1) .EQ. -8) ) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid M and N +* -4, -6 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9983 ) 'N' +* disable extreme value case when N < 0 + EX_FLAG = .FALSE. + ELSE IF(N .EQ. 0 .AND. (IERR(1) .EQ. 0 .OR. + $ IERR(1) .EQ. -5 .OR. IERR(1) .EQ. -10 .OR. + $ IERR(1) .EQ. -15 .OR. IERR(1) .EQ. -20 )) THEN +* DESCINIT returns the correct error code, +* When N = 0, +* -5, -10 or -20 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING +* disable extreme value case when N = 0 + EX_FLAG = .FALSE. + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -494,17 +581,19 @@ PROGRAM PSGBDRIVER $ ((2*BWL+2*BWU+1)+10), 0, 0, IASEED, $ MYROW, MYCOL, NPROW, NPCOL ) * - CALL PSFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), + IF(N .GE. 0) THEN + CALL PSFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), $ ((2*BWL+2*BWU+1)+10), IPREPAD, IPOSTPAD, $ PADVAL ) * - CALL PSFILLPAD( ICTXT, WORKSIZ, 1, + CALL PSFILLPAD( ICTXT, WORKSIZ, 1, $ MEM( IP_DRIVER_W-IPREPAD ), WORKSIZ, $ IPREPAD, IPOSTPAD, PADVAL ) + END IF * * Calculate norm of A for residual error-checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * ANORM = PSLANGE( '1', (2*BWL+2*BWU+1), $ N, MEM( IPA ), 1, 1, @@ -532,15 +621,26 @@ PROGRAM PSGBDRIVER * CALL SLTIMER( 1 ) * - IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) THEN - WRITE( NOUT, FMT = * ) 'PSGBTRF INFO=', INFO - ENDIF - KFAIL = KFAIL + 1 - GO TO 30 + IF( INFO.NE.0 .AND. .NOT.(EX_FLAG)) THEN + IF(N .LT. 0 .AND. (INFO .EQ. -1 .OR. + $ INFO .EQ. -604 )) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PSGBTRF INFO=', INFO +* When N = 0, make BWL and BWU = 0 for early return + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -3) THEN +* expected error code, when bandwidth is > 0 +* pass this case to solve API + WRITE( NOUT, FMT = * ) 'PSGBTRF INFO=', INFO + ELSE + IF( IAM.EQ.0 ) THEN + WRITE( NOUT, FMT = * ) 'PSGBTRF INFO=', INFO + ENDIF + KFAIL = KFAIL + 1 + GO TO 30 + END IF END IF * - IF( CHECK ) THEN + IF( CHECK .AND. INFO .EQ. 0 ) THEN * * Check for memory overwrite in factorization * @@ -650,15 +750,24 @@ PROGRAM PSGBDRIVER * CALL SLTIMER( 2 ) * - IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) - $ WRITE( NOUT, FMT = * ) 'PSGBTRS INFO=', INFO - KFAIL = KFAIL + 1 - PASSED = 'FAILED' - GO TO 20 + IF( INFO.NE.0 .AND. .NOT.(EX_FLAG) ) THEN + IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804)) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PSGBTRS INFO=', INFO + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -4) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PSGBTRS INFO=', INFO + ELSE + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = * ) 'PSGBTRS INFO=', INFO + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + GO TO 20 + END IF END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN * * check for memory overwrite * @@ -672,12 +781,14 @@ PROGRAM PSGBDRIVER * SRESID = ZERO * - CALL PSDBLASCHK( 'N', 'N', TRANS, + IF(INFO .EQ. 0) THEN + CALL PSDBLASCHK( 'N', 'N', TRANS, $ N, BWL, BWU, NRHS, $ MEM( IPB ), 1, 1, DESCB2D, $ IASEED, MEM( IPA+BWL+BWU ), 1, 1, DESCA2D, $ IBSEED, ANORM, SRESID, $ MEM( IP_DRIVER_W ), WORKSIZ ) + END IF * IF( IAM.EQ.0 ) THEN IF( SRESID.GT.THRESH ) @@ -686,7 +797,33 @@ PROGRAM PSGBDRIVER * * The second test is a NaN trap * - IF( ( SRESID.LE.THRESH ).AND. + IF( N .EQ. 0 .AND. (INFO .EQ. -4 .OR. + $ INFO .EQ. 0)) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9984 ) 'PSGBTRS' + PASSED = 'PASSED' +* Re-enable EX_FLAG + IF(NAN_PERCENT .GT. 0 .OR. + $ INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + ELSE IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804 )) THEN +* When N < 0/Invalid, PSGBTRS INFO = -1 +* Expected Error code for N < 0 +* Hence this case can be passed + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9982 ) 'PSGBTRS' + PASSED = 'PASSED' +* Re-enable EX_FLAG + IF(NAN_PERCENT .GT. 0 .OR. + $ INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + ELSE IF( ( SRESID.LE.THRESH ).AND. $ ( (SRESID-SRESID).EQ.0.0E+0 ) ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' @@ -694,6 +831,37 @@ PROGRAM PSGBDRIVER KFAIL = KFAIL + 1 PASSED = 'FAILED' END IF +* Extreme-value validation block + ELSE IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, N-1 + DO JK = 1, N + X = (MEM(IK*N + JK)) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF * END IF * @@ -935,6 +1103,13 @@ PROGRAM PSGBDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - ', A4, '|| / (||A|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Ax-b||/(||x||*||A||*eps*N) ', F25.7 ) + 9984 FORMAT( '----------Test Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9983 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9982 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') * STOP * diff --git a/TESTING/LIN/psinvdriver.f b/TESTING/LIN/psinvdriver.f index dde803c2..7a47255d 100644 --- a/TESTING/LIN/psinvdriver.f +++ b/TESTING/LIN/psinvdriver.f @@ -4,6 +4,7 @@ PROGRAM PSINVDRIVER * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======= @@ -58,6 +59,7 @@ PROGRAM PSINVDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, $ LLD_, MB_, M_, NB_, N_, RSRC_ @@ -97,6 +99,7 @@ PROGRAM PSINVDRIVER $ NPROW, NQ, WORKIINV, WORKINV, WORKSIZ REAL ANORM, FRESID, RCOND, THRESH DOUBLE PRECISION NOPS, TMFLOPS + CHARACTER*8 API_NAME * .. * .. Local Arrays .. CHARACTER*3 MATTYP( NTESTS ) @@ -134,6 +137,15 @@ PROGRAM PSINVDRIVER * .. * .. Executable Statements .. * +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X +* * Get starting information * #ifdef DYNAMIC_WORK_MEM_ALLOC @@ -145,6 +157,36 @@ PROGRAM PSINVDRIVER $ NTESTS, NNB, NBVAL, NTESTS, NGRIDS, PVAL, NTESTS, $ QVAL, NTESTS, THRESH, MEM, IAM, NPROCS ) CHECK = ( THRESH.GE.0.0E+0 ) + +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* * * Loop over the different matrix types * @@ -232,12 +274,14 @@ PROGRAM PSINVDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR( 1 ) = 0 - IF( N.LT.1 ) THEN + IF( N.LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Make sure no one had error * @@ -301,12 +345,29 @@ PROGRAM PSINVDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, $ 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 10 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 )) THEN +* DESCINIT returns the correct error code, +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9984 ) 'N' +* disable extreme flag for negative case + EX_FLAG = .FALSE. + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF +#endif * * Assign pointers into MEM for ScaLAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -416,23 +477,51 @@ PROGRAM PSINVDRIVER * * Generate a general diagonally dominant matrix A * - CALL PSMATGEN( ICTXT, 'N', 'D', DESCA( M_ ), + IF(EX_FLAG) THEN +* The extreme-value generation module for +* diagonally dominant matrices, requires +* Matrix-type info such as Upper/Lower. +* Hence, MTYP(1:1) is passed to MATGEN +* MTYP(1:1) is 'U'/'L'/'N'(default-case) + CALL PSMATGEN( ICTXT, MTYP(1:1), 'D', + $ DESCA( M_ ), + $ DESCA( N_ ), DESCA( MB_ ), + $ DESCA( NB_ ), MEM( IPA ), + $ DESCA( LLD_ ), DESCA( RSRC_ ), + $ DESCA( CSRC_ ), IASEED, 0, NP, 0, + $ NQ, MYROW, MYCOL, NPROW, NPCOL ) + ELSE + CALL PSMATGEN( ICTXT, 'N', 'D', + $ DESCA( M_ ), $ DESCA( N_ ), DESCA( MB_ ), $ DESCA( NB_ ), MEM( IPA ), $ DESCA( LLD_ ), DESCA( RSRC_ ), $ DESCA( CSRC_ ), IASEED, 0, NP, 0, $ NQ, MYROW, MYCOL, NPROW, NPCOL ) + END IF * ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'PD' ) ) THEN * * Generate a symmetric positive definite matrix * - CALL PSMATGEN( ICTXT, 'S', 'D', DESCA( M_ ), + IF(EX_FLAG) THEN +* MTYP(1:1) is 'U'/'L'/'N' (default-case) + CALL PSMATGEN( ICTXT, MTYP(1:1), 'D', + $ DESCA( M_ ), $ DESCA( N_ ), DESCA( MB_ ), $ DESCA( NB_ ), MEM( IPA ), $ DESCA( LLD_ ), DESCA( RSRC_ ), $ DESCA( CSRC_ ), IASEED, 0, NP, 0, $ NQ, MYROW, MYCOL, NPROW, NPCOL ) + ELSE + CALL PSMATGEN( ICTXT, 'S', 'D', + $ DESCA( M_ ), + $ DESCA( N_ ), DESCA( MB_ ), + $ DESCA( NB_ ), MEM( IPA ), + $ DESCA( LLD_ ), DESCA( RSRC_ ), + $ DESCA( CSRC_ ), IASEED, 0, NP, 0, + $ NQ, MYROW, MYCOL, NPROW, NPCOL ) + END IF * END IF * @@ -458,7 +547,7 @@ PROGRAM PSINVDRIVER * * Need 1-norm of A for checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * CALL PSFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, @@ -554,7 +643,7 @@ PROGRAM PSINVDRIVER $ MEM( IPPIV ), INFO ) CALL SLTIMER( 1 ) * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * * Check for memory overwrite * @@ -570,12 +659,13 @@ PROGRAM PSINVDRIVER * Perform the general matrix inversion * CALL SLTIMER( 2 ) + API_NAME = 'PSGETRI' CALL PSGETRI( N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPPIV ), MEM( IPW ), LWORK, $ MEM( IPIW ), LIWORK, INFO ) CALL SLTIMER( 2 ) * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * * Check for memory overwrite * @@ -603,11 +693,12 @@ PROGRAM PSINVDRIVER * Perform the general matrix inversion * CALL SLTIMER( 2 ) + API_NAME = 'PSTRTRI' CALL PSTRTRI( UPLO, 'Non unit', N, MEM( IPA ), 1, $ 1, DESCA, INFO ) CALL SLTIMER( 2 ) * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * * Check for memory overwrite * @@ -626,7 +717,7 @@ PROGRAM PSINVDRIVER $ INFO ) CALL SLTIMER( 1 ) * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * * Check for memory overwrite * @@ -640,11 +731,12 @@ PROGRAM PSINVDRIVER * inversion * CALL SLTIMER( 2 ) + API_NAME = 'PSPOTRI' CALL PSPOTRI( UPLO, N, MEM( IPA ), 1, 1, DESCA, $ INFO ) CALL SLTIMER( 2 ) * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * * Check for memory overwrite * @@ -656,37 +748,66 @@ PROGRAM PSINVDRIVER * END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG)) THEN * - CALL PSFILLPAD( ICTXT, WORKSIZ-IPOSTPAD, 1, + IF(INFO.EQ.0 .AND. N.GT.0) THEN + CALL PSFILLPAD( ICTXT, WORKSIZ-IPOSTPAD, 1, $ MEM( IPW-IPREPAD ), $ WORKSIZ-IPOSTPAD, IPREPAD, $ IPOSTPAD, PADVAL ) * -* Compute fresid = || inv(A)*A-I || +* Compute fresid = || inv(A)*A-I || * - CALL PSINVCHK( MTYP, N, MEM( IPA ), 1, 1, DESCA, + CALL PSINVCHK( MTYP, N, MEM( IPA ), 1, 1, DESCA, $ IASEED, ANORM, FRESID, RCOND, $ MEM( IPW ) ) * -* Check for memory overwrite +* Check for memory overwrite * - CALL PSCHEKPAD( ICTXT, 'PSINVCHK', NP, NQ, + CALL PSCHEKPAD( ICTXT, 'PSINVCHK', NP, NQ, $ MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PSCHEKPAD( ICTXT, 'PSINVCHK', + CALL PSCHEKPAD( ICTXT, 'PSINVCHK', $ WORKSIZ-IPOSTPAD, 1, $ MEM( IPW-IPREPAD ), $ WORKSIZ-IPOSTPAD, IPREPAD, $ IPOSTPAD, PADVAL ) + END IF * * Test residual and detect NaN result * - IF( FRESID.LE.THRESH .AND. INFO.EQ.0 .AND. + IF(N.EQ.0 .AND. INFO.EQ.0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) KPASS, API_NAME + PASSED = 'PASSED' + GO TO 10 + ELSE IF( FRESID.LE.THRESH .AND. INFO.EQ.0 .AND. $ ( (FRESID-FRESID) .EQ. 0.0E+0 ) ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' + ELSE IF(N.LT.0 .AND. + $ ((INFO.EQ.-1 + $ .AND. LSAMEN( 3, MTYP, 'GEN' )) .OR. + $ (INFO.EQ.-3 .AND. + $ LSAMEN( 2, MTYP( 2:3 ), 'TR' )) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, MTYP( 2:3 ), 'PD' )))) THEN +* When N < 0/Invalid, PCGETRI INFO = -1 +* PTPOTRI INFO = -2 and PCTRTRI INFO = -3 +* Expected Error code for N < 0 +* Hence this case can be passed + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9983 ) API_NAME + PASSED = 'PASSED' +* re-enable extreme flag for next case + IF(INF_PERCENT .GT. 0 .OR. + $ NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF ELSE KFAIL = KFAIL + 1 IF( INFO.GT.0 ) THEN @@ -698,12 +819,54 @@ PROGRAM PSINVDRIVER * ELSE * +* Extreme value case + IF(N.EQ.0 .AND. INFO.EQ.0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) KPASS, API_NAME + PASSED = 'PASSED' + GO TO 10 + ELSE IF(EX_FLAG .AND. N.GT.0) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, N-1 + DO JK = 1, N + X = MEM(IK*N +JK) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF + FRESID = FRESID - FRESID +* * Don't perform the checking, only the timing * operation -* - KPASS = KPASS + 1 - FRESID = FRESID - FRESID - PASSED = 'BYPASS' + ELSE + KPASS = KPASS + 1 + FRESID = FRESID - FRESID + PASSED = 'BYPASS' + END IF * END IF * @@ -714,7 +877,7 @@ PROGRAM PSINVDRIVER * * Print results * - IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN + IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN * IF( LSAMEN( 3, MTYP, 'GEN' ) ) THEN * @@ -842,6 +1005,13 @@ PROGRAM PSINVDRIVER 9988 FORMAT( I5, ' tests skipped because of illegal input values.' ) 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( A ) + 9985 FORMAT( '----------Test-',I3,' Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9983 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') * STOP * diff --git a/TESTING/LIN/pslltdriver.f b/TESTING/LIN/pslltdriver.f index ced011bb..bbfd651e 100644 --- a/TESTING/LIN/pslltdriver.f +++ b/TESTING/LIN/pslltdriver.f @@ -4,6 +4,7 @@ PROGRAM PSLLTDRIVER * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======= @@ -212,6 +213,7 @@ PROGRAM PSLLTDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR( 1 ) = 0 IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -222,6 +224,7 @@ PROGRAM PSLLTDRIVER $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * @@ -281,12 +284,26 @@ PROGRAM PSLLTDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else +* If N < 0 in LLT.dat file then DESCINIT API sets IERR( 1 ) = -2 + IF( N.LT.0 .AND. IERR( 1 ).EQ.-2 ) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9984 ) 'N' + ELSE IF( IERR( 1 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -403,7 +420,24 @@ PROGRAM PSLLTDRIVER IF( INFO.NE.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = * ) 'PSPOTRF INFO=', INFO - KFAIL = KFAIL + 1 +* If N < 0 in LLT.dat file then PSPOTRF API sets INFO = -2 + IF (N.LT.0 .AND. INFO.EQ.-2) THEN +* If PSPOTRF is returning correct error +* code we need to pass this case + WRITE( NOUT, FMT = 9983 ) 'PSPOTRF' + KPASS = KPASS + 1 + ELSE +* For other error code we will mark test case as fail + KFAIL = KFAIL + 1 + END IF + RCOND = ZERO + GO TO 60 + ELSE IF (N.EQ.0) THEN +* If N = 0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API we need to pass this case + WRITE( NOUT, FMT = 9982 ) 'PSPOTRF' + KPASS = KPASS + 1 RCOND = ZERO GO TO 60 END IF @@ -496,6 +530,13 @@ PROGRAM PSLLTDRIVER CALL DESCINIT( DESCB, N, NRHS, NB, NBRHS, 0, 0, $ ICTXT, MAX( 1, NP )+IMIDPAD, $ IERR( 1 ) ) +* If NRHS < 0 in LLT.dat file then +* DESCINIT API sets IERR( 1 ) = -3 + IF (NRHS.LT.0 .AND. IERR( 1 ).EQ.-3 ) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9984 ) 'NRHS' + END IF * * move IPW to allow room for RHS * @@ -602,6 +643,22 @@ PROGRAM PSLLTDRIVER * CALL SLTIMER( 2 ) * + IF( INFO.NE.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = * ) 'PSPOTRS INFO=', INFO +* If NRHS < 0 in LLT.dat file then +* PSPOTRS API sets INFO = -3 + IF( NRHS.LT.0 .AND. INFO.EQ.-3 ) THEN +* If PSPOTRS is returning correct error code then +* we need to pass this case + WRITE( NOUT, FMT = 9983 ) 'PSPOTRS' + KPASS = KPASS + 1 + ELSE +* For other error code we will mark test case as fail + KFAIL = KFAIL + 1 + END IF + GO TO 60 + END IF IF( CHECK ) THEN * * check for memory overwrite @@ -922,6 +979,11 @@ PROGRAM PSLLTDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - ', A4, '|| / (||A|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Ax-b||/(||x||*||A||*eps*N) ', F25.7 ) + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, we will handle this case from ', + $ 'ScaLAPACK API.') + 9983 FORMAT( A, ' returned correct error code. Passing this case.') + 9982 FORMAT( 'This is safe exit from ', A, ' API. Passing this case.') * STOP * diff --git a/TESTING/LIN/pslsdriver.f b/TESTING/LIN/pslsdriver.f index 07e6acbe..5eb06942 100644 --- a/TESTING/LIN/pslsdriver.f +++ b/TESTING/LIN/pslsdriver.f @@ -4,6 +4,7 @@ PROGRAM PSLSDRIVER * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 28, 2001 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======= @@ -59,6 +60,7 @@ PROGRAM PSLSDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, $ LLD_, MB_, M_, NB_, N_, RSRC_ @@ -131,6 +133,16 @@ PROGRAM PSLSDRIVER DATA KTESTS, KPASS, KFAIL, KSKIP / 4*0 / * .. * .. Executable Statements .. +* +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X + * * Get starting information * @@ -146,6 +158,35 @@ PROGRAM PSLSDRIVER $ NNBR, NBRVAL, NTESTS, NGRIDS, PVAL, NTESTS, QVAL, $ NTESTS, THRESH, MEM, IAM, NPROCS ) CHECK = ( THRESH.GE.0.0E+0 ) + +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do * * Print headings * @@ -206,15 +247,17 @@ PROGRAM PSLSDRIVER * Make sure matrix information is correct * IERR( 1 ) = 0 - IF( M.LT.1 ) THEN +#ifdef ENABLE_DRIVER_CHECK + IF( M.LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'M', M IERR( 1 ) = 1 - ELSE IF( N.LT.1 ) THEN + ELSE IF( N.LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Make sure no one had error * @@ -280,12 +323,35 @@ PROGRAM PSLSDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 70 END IF +#else +* If M < 0, DESCINIT API sets IERR( 1 ) = -2 +* If N < 0, DESCINIT API sets IERR( 1 ) = -3 +* When M/N < 0, LDA is Negative, DESCINIT IERR( 1 ) = -8 + IF( M.LT.0 .AND. (IERR( 1 ).EQ.-2 .OR. + $ IERR( 1 ).EQ. -8 .OR. IERR(1).EQ.-12 )) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9985 ) 'M' + ELSE IF (N.LT.0 .AND. (IERR( 1 ).EQ.-3 .OR. + $ IERR( 1 ).EQ. -8 .OR. IERR(1).EQ.-12 )) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9985 ) 'N' + ELSE IF( IERR( 1 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 70 + END IF +#endif * DO 60 ISCALE = 1, 3 * @@ -322,7 +388,7 @@ PROGRAM PSLSDRIVER GO TO 70 END IF * - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. N.GT.0) THEN CALL PSFILLPAD( ICTXT, MP, NQ, MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, $ PADVAL ) @@ -334,10 +400,12 @@ PROGRAM PSLSDRIVER * * Generate the matrix A and calculate its 1-norm * + IF(M.GT.0 .AND. N.GT.0) THEN CALL PSQRT13( ISCALE, M, N, MEM( IPA ), 1, 1, $ DESCA, ANORM, IASEED, MEM( IPW ) ) + END IF * - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. N.GT.0) THEN CALL PSCHEKPAD( ICTXT, 'PSQRT13', MP, NQ, $ MEM( IPA-IPREPAD ), DESCA( LLD_ ), $ IPREPAD, IPOSTPAD, PADVAL ) @@ -398,12 +466,41 @@ PROGRAM PSLSDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 2, 1, IERR, $ 2, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 .OR. IERR( 2 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else + IF (NRHS.LT.0 .AND. (IERR( 1 ).EQ.-3 .OR. + $ IERR(1) .EQ. -12)) THEN +* If DESCINIT is returns correct error code then +* do nothing + WRITE( NOUT, FMT = 9985 ) 'NRHS' + ELSE IF (N.LT.0 .AND. (IERR( 1 ).EQ.-2 .OR. + $ IERR( 1 ).EQ. -8 .OR. + $ IERR( 2 ).EQ.-2 .OR. + $ IERR( 2 ).EQ. -8) ) THEN +* If DESCINIT is returns correct error code then +* do nothing + WRITE( NOUT, FMT = 9985 ) 'N' + ELSE IF (M.LT.0 .AND. (IERR( 1 ).EQ.-2 .OR. + $ IERR( 1 ).EQ. -8 .OR. + $ IERR( 2 ).EQ. -2 .OR. + $ IERR( 2 ).EQ. -8)) THEN +* If DESCINIT is returns correct error code then +* do nothing + WRITE( NOUT, FMT = 9985 ) 'M' + ELSE IF( IERR( 1 ).LT.0 .OR. + $ IERR( 2 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif * * Check for enough memory * @@ -435,8 +532,10 @@ PROGRAM PSLSDRIVER * * Generate RHS * - IF( TPSD ) THEN - CALL PSMATGEN( ICTXT, 'No', 'No', + IF (M.GT.0 .AND. N.GT.0 .AND. + $ NRHS.GT.0) THEN + IF( TPSD ) THEN + CALL PSMATGEN( ICTXT, 'No', 'No', $ DESCW( M_ ), DESCW( N_ ), $ DESCW( MB_ ), DESCW( NB_ ), $ MEM( IPW ), DESCW( LLD_ ), @@ -444,8 +543,8 @@ PROGRAM PSLSDRIVER $ DESCW( CSRC_ ), IBSEED, 0, $ MP, 0, NRHSQ, MYROW, MYCOL, $ NPROW, NPCOL ) - ELSE - CALL PSMATGEN( ICTXT, 'No', 'No', + ELSE + CALL PSMATGEN( ICTXT, 'No', 'No', $ DESCW( M_ ), DESCW( N_ ), $ DESCW( MB_ ), DESCW( NB_ ), $ MEM( IPW ), DESCW( LLD_ ), @@ -453,9 +552,10 @@ PROGRAM PSLSDRIVER $ DESCW( CSRC_ ), IBSEED, 0, $ NP, 0, NRHSQ, MYROW, MYCOL, $ NPROW, NPCOL ) + END IF END IF -* - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. N.GT.0 .AND. + $ NRHS.GT.0) THEN CALL PSFILLPAD( ICTXT, MNP, NRHSQ, $ MEM( IPX-IPREPAD ), $ DESCX( LLD_ ), IPREPAD, @@ -472,22 +572,29 @@ PROGRAM PSLSDRIVER $ IPOSTPAD, PADVAL ) END IF END IF + IF( M.GT.0 .AND. N.GT.0 .AND. + $ NRHS.GT.0) THEN + DO 10 JJ = 1, NRHS + CALL PSNRM2( NCOLS, BNORM, MEM( IPW ), + $ 1, JJ, DESCW, 1 ) + IF( BNORM.GT.ZERO ) + $ CALL PSSCAL( NCOLS, ONE / BNORM, + $ MEM( IPW ), 1, JJ, + $ DESCW, 1 ) + 10 CONTINUE + END IF * - DO 10 JJ = 1, NRHS - CALL PSNRM2( NCOLS, BNORM, MEM( IPW ), 1, - $ JJ, DESCW, 1 ) - IF( BNORM.GT.ZERO ) - $ CALL PSSCAL( NCOLS, ONE / BNORM, - $ MEM( IPW ), 1, JJ, DESCW, - $ 1 ) - 10 CONTINUE -* - CALL PSGEMM( TRANS, 'N', NROWS, NRHS, NCOLS, + IF (M.GE.0 .AND. N.GE.0 .AND. + $ NRHS.GE.0) THEN + CALL PSGEMM( TRANS, 'N', NROWS, + $ NRHS, NCOLS, $ ONE, MEM( IPA ), 1, 1, DESCA, $ MEM( IPW ), 1, 1, DESCW, ZERO, $ MEM( IPX ), 1, 1, DESCX ) + END IF * - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. N.GT.0 .AND. + $ NRHS.GT.0 ) THEN * * check for memory overwrite * @@ -538,8 +645,8 @@ PROGRAM PSLSDRIVER IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) $ 'descriptor' - KSKIP = KSKIP + 1 - GO TO 30 + KSKIP = KSKIP + 1 + GO TO 30 END IF * IPW = IPB + DESCB( LLD_ )*NRHSQ + @@ -592,7 +699,8 @@ PROGRAM PSLSDRIVER GO TO 30 END IF * - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. N.GT.0 .AND. + $ NRHS .GT.0 ) THEN * * Make the copy of the right hand side * @@ -629,7 +737,14 @@ PROGRAM PSLSDRIVER * CALL SLTIMER( 1 ) * - IF( CHECK ) THEN + IF( (N .EQ. 0 .OR. M.EQ.0 .OR. + $ NRHS .EQ. 0 ) .AND. INF0.EQ.0) THEN +* If M = 0 or N =0 this is the case of +* safe exit, early return from ScaLAPACK API. + WRITE( NOUT, FMT = 9983 ) 'PSGELS' + END IF + IF( CHECK .AND. M.GT.0 .AND. + $ N.GT.0 .AND. NRHS.GT.0 ) THEN * * check for memory overwrite * @@ -649,14 +764,20 @@ PROGRAM PSLSDRIVER * * Regenerate A in place for testing and next * iteration + + IF(M.GT.0 .AND. N.GT.0 .AND. NRHS.GT.0) THEN * - CALL PSQRT13( ISCALE, M, N, MEM( IPA ), 1, 1, - $ DESCA, ANORM, IASEED, + CALL PSQRT13( ISCALE, M, N, MEM( IPA ), + $ 1, 1, DESCA, ANORM, IASEED, $ MEM( IPW ) ) + + END IF * * check the solution to rhs * - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. + $ N.GT.0 .AND. NRHS.GT.0 .AND. + $ .NOT.(EX_FLAG) ) THEN * * Am I going to call PSQRT17 ? * @@ -838,7 +959,9 @@ PROGRAM PSLSDRIVER * Call PSQRT14 * IF( ( M.GE.N .AND. TPSD ) .OR. - $ ( M.LT.N .AND. ( .NOT.TPSD ) ) ) THEN + $ ( M.LT.N .AND. (.NOT.TPSD) ) .AND. + $ ( M.GT.0 .AND. N.GT.0 .AND. + $ NRHS.GT.0 ) ) THEN * IPW = IPB * @@ -929,7 +1052,15 @@ PROGRAM PSLSDRIVER * did not pass the threshold. * PASSED = 'PASSED' - DO 20 II = 1, 2 + IF((M.EQ.0 .OR. N.EQ.0 .OR. + $ NRHS .EQ. 0) .AND. INF0 .EQ. 0) THEN +* If M = 0, N =0, NRHS =0 this is the case of +* early return from ScaLAPACK API. +* Pass this case + KPASS = KPASS + 1 + SRESID = SRESID - SRESID + ELSE + DO 20 II = 1, 2 IF( ( RESULT( II ).GE.THRESH ) .AND. $ ( RESULT( II )-RESULT( II ).EQ.0.0E+0 $ ) ) THEN @@ -942,16 +1073,75 @@ PROGRAM PSLSDRIVER ELSE KPASS = KPASS + 1 END IF - 20 CONTINUE + 20 CONTINUE + END IF * ELSE * -* By-pass the solve check -* - KPASS = KPASS + 1 - SRESID = SRESID - SRESID - PASSED = 'BYPASS' -* + IF((M.EQ.0 .OR. N.EQ.0 .OR. + $ NRHS .EQ. 0) .AND. INF0 .EQ. 0) THEN +* If M = 0, N =0, NRHS =0 this is the case of +* early return from ScaLAPACK API. +* Pass this case + KPASS = KPASS + 1 + SRESID = SRESID - SRESID + PASSED = 'PASSED' +* +* When N < 0, PZGELS returns INF0 = -2 +* When M < 0, PZGELS returns INF0 = -3 +* When NRHS < 0, PZGELS returns INF0 = -4 +* + ELSE IF( (M .LT. 0 .AND. + $ INFO .EQ. -2 ) .OR. + $ (N .LT. 0 .AND. + $ INFO .EQ. -3 ) .OR. + $ (NRHS .LT. 0 .AND. + $ (INFO.EQ. -14 .OR. + $ INFO.EQ. -4 ))) THEN +* +* If PZGELS returns correct error code +* pass this case + WRITE( NOUT, FMT = 9984 ) 'PZGELS' + KPASS = KPASS + 1 + SRESID = SRESID - SRESID + PASSED = 'PASSED' +* Extreme value validation check + ELSE IF( EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, M + DO JK = 1, N + X = MEM(IK*N + JK) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF + ELSE + KPASS = KPASS + 1 + SRESID = SRESID - SRESID + PASSED = 'BYPASS' + + END IF END IF * * Gather maximum of all CPU and WALL clock @@ -1080,6 +1270,12 @@ PROGRAM PSLSDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( ' TRANS=''', A1, ''', M=', I5, ', N=', I5, ', NRHS=', I4, $ ', NB=', I4, ', type', I2, ', test(', I2, ')=', G12.5 ) + 9985 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handeld by', + $ 'the PSGELS API.') + 9984 FORMAT( A, ' returned correct error code. Passing this case.') + 9983 FORMAT( 'Early return case. Safe exit from ', A, ' API' + $ ' Passing this case.') * STOP * diff --git a/TESTING/LIN/psludriver.f b/TESTING/LIN/psludriver.f index 1a149e49..febb636f 100644 --- a/TESTING/LIN/psludriver.f +++ b/TESTING/LIN/psludriver.f @@ -4,6 +4,7 @@ PROGRAM PSLUDRIVER * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======== @@ -65,6 +66,7 @@ PROGRAM PSLUDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, $ LLD_, MB_, M_, NB_, N_, RSRC_ @@ -141,6 +143,15 @@ PROGRAM PSLUDRIVER * .. * .. Executable Statements .. * +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X +* * Get starting information * #ifdef DYNAMIC_WORK_MEM_ALLOC @@ -154,6 +165,35 @@ PROGRAM PSLUDRIVER $ NTESTS, NGRIDS, PVAL, NTESTS, QVAL, NTESTS, THRESH, $ EST, MEM, IAM, NPROCS ) CHECK = ( THRESH.GE.0.0E+0 ) + +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do * * Print headings * @@ -214,6 +254,7 @@ PROGRAM PSLUDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR( 1 ) = 0 IF( M.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -224,6 +265,7 @@ PROGRAM PSLUDRIVER $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * @@ -284,12 +326,31 @@ PROGRAM PSLUDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else +* If M < 0 in LU.dat file then DESCINIT API sets IERR( 1 ) = -2 +* If N < 0 in LU.dat file then DESCINIT API sets IERR( 1 ) = -3 + IF( M.LT.0 .AND. IERR( 1 ).EQ.-2 ) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9984 ) 'M' + ELSE IF (N.LT.0 .AND. IERR( 1 ).EQ.-3 ) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9984 ) 'N' + ELSE IF( IERR( 1 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -405,12 +466,36 @@ PROGRAM PSLUDRIVER IF( INFO.NE.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = * ) 'PSGETRF INFO=', INFO - KFAIL = KFAIL + 1 +* If M < 0 in LU.dat file then PSGETRF API sets INFO = -1 +* If N < 0 in LU.dat file then PSGETRF API sets INFO = -2 + IF ((M.LT.0 .AND. INFO.EQ.-1) .OR. + $ (N.LT.0 .AND. INFO.EQ.-2)) THEN +* If PSGETRF is returning correct error +* code we need to pass this case + WRITE( NOUT, FMT = 9983 ) 'PSGETRF' + KPASS = KPASS + 1 + RCOND = ZERO + GO TO 30 + ELSE IF (INFO.GT.0 .AND. EX_FLAG) THEN + WRITE(*,*) 'PSGETRF INFO=', INFO +* Do Nothing, Pass this case in INF/NAN residual calculation + ELSE +* For other error code we will mark test case as fail + KFAIL = KFAIL + 1 + RCOND = ZERO + GO TO 30 + END IF + ELSE IF (M.EQ.0 .OR. N.EQ.0) THEN +* If M = 0 or N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API we need to pass this case + WRITE( NOUT, FMT = 9982 ) 'PSGETRF' + KPASS = KPASS + 1 RCOND = ZERO GO TO 30 END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN * * Check for memory overwrite in LU factorization * @@ -429,7 +514,7 @@ PROGRAM PSLUDRIVER NRHS = 0 NBRHS = 0 * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN * * Compute FRESID = ||A - P*L*U|| / (||A|| * N * eps) * @@ -468,11 +553,43 @@ PROGRAM PSLUDRIVER * ELSE * -* Don't perform the checking, only timing -* - KPASS = KPASS + 1 - FRESID = FRESID - FRESID - PASSED = 'BYPASS' +* Extreme-value validation check + IF( EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, M + DO JK = 1, N + X = MEM(IK*N + JK) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF + ELSE +* Don't perform the checking, only timing + FRESID = FRESID - FRESID + KPASS = KPASS + 1 + PASSED = 'BYPASS' + END IF * END IF * @@ -566,7 +683,7 @@ PROGRAM PSLUDRIVER GO TO 30 END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN CALL PSFILLPAD( ICTXT, LWORK, 1, $ MEM( IPW-IPREPAD ), LWORK, $ IPREPAD, IPOSTPAD, PADVAL ) @@ -582,7 +699,7 @@ PROGRAM PSLUDRIVER $ ANORM1, RCOND, MEM( IPW ), LWORK, $ MEM( IPW2 ), LIWORK, INFO ) * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG)) THEN CALL PSCHEKPAD( ICTXT, 'PSGECON', NP, NQ, $ MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, @@ -619,12 +736,26 @@ PROGRAM PSLUDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 10 END IF +#else +* If NRHS < 0 in LU.dat file then DESCINIT API sets IERR( 1 ) = -3 + IF (NRHS.LT.0 .AND. IERR( 1 ).EQ.-3 ) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9984 ) 'NRHS' + ELSE IF( IERR( 1 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF +#endif * * move IPW to allow room for RHS * @@ -690,7 +821,7 @@ PROGRAM PSLUDRIVER $ MYRHS, MYROW, MYCOL, NPROW, $ NPCOL ) * - IF( CHECK ) + IF( CHECK .AND. .NOT.(EX_FLAG) ) $ CALL PSFILLPAD( ICTXT, NP, MYRHS, $ MEM( IPB-IPREPAD ), $ DESCB( LLD_ ), IPREPAD, @@ -705,7 +836,7 @@ PROGRAM PSLUDRIVER $ DESCB( CSRC_ ), IBSEED, 0, NP, $ 0, MYRHS, MYROW, MYCOL, NPROW, $ NPCOL ) - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG)) THEN CALL PSFILLPAD( ICTXT, NP, MYRHS, $ MEM( IPB0-IPREPAD ), $ DESCB( LLD_ ), IPREPAD, @@ -732,7 +863,27 @@ PROGRAM PSLUDRIVER * CALL SLTIMER( 2 ) * - IF( CHECK ) THEN + + IF( INFO.NE.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = * ) 'PSGETRS INFO=', INFO +* If NRHS < 0 in LU.dat file then PSGETRS API sets INFO = -3 + IF( NRHS.LT.0 .AND. INFO.EQ.-3 ) THEN +* If PSGETRS is returning correct error code we need to pass this case + WRITE( NOUT, FMT = 9983 ) 'PSGETRS' + KPASS = KPASS + 1 + GO TO 30 + ELSE IF( INFO .GT. 0 .AND. EX_FLAG) THEN + WRITE(*,*) 'PSGETRS INFO=', INFO +* Do Nothing, Pass this case in residual calculation + ELSE +* For other error code we will mark test case as fail + KFAIL = KFAIL + 1 + GO TO 30 + END IF + END IF +* + IF( CHECK .AND. .NOT.(EX_FLAG)) THEN * * check for memory overwrite * @@ -786,9 +937,42 @@ PROGRAM PSLUDRIVER PASSED = 'FAILED' END IF ELSE - KPASS = KPASS + 1 - SRESID = SRESID - SRESID - PASSED = 'BYPASS' +* Extreme value validation check + IF( EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, M + DO JK = 1, N + X = MEM(IK*N + JK) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF + ELSE + SRESID = SRESID - SRESID + KPASS = KPASS + 1 + PASSED = 'BYPASS' + END IF END IF * IF( EST ) THEN @@ -822,7 +1006,7 @@ PROGRAM PSLUDRIVER GO TO 10 END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG)) THEN CALL PSFILLPAD( ICTXT, LWORK, 1, $ MEM( IPW-IPREPAD ), $ LWORK, IPREPAD, IPOSTPAD, @@ -845,7 +1029,7 @@ PROGRAM PSLUDRIVER $ MEM( IPW ), LWORK, MEM( IPW2 ), $ LIWORK, INFO ) * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN CALL PSCHEKPAD( ICTXT, 'PSGERFS', NP, $ NQ, MEM( IPA0-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, @@ -978,7 +1162,8 @@ PROGRAM PSLUDRIVER 10 CONTINUE 20 END DO * - IF( CHECK.AND.( SRESID.GT.THRESH ) ) THEN + IF( CHECK.AND.( SRESID.GT.THRESH ) .AND. + $ .NOT.(EX_FLAG) ) THEN * * Compute fresid = ||A - P*L*U|| / (||A|| * N * eps) * @@ -1058,6 +1243,11 @@ PROGRAM PSLUDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - P*L*U|| / (||A|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Ax-b||/(||x||*||A||*eps*N) ', F25.7 ) + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, we will handle this case from ', + $ 'ScaLAPACK API.') + 9983 FORMAT( A, ' returned correct error code. Passing this case.') + 9982 FORMAT( 'This is safe exit from ', A, ' API. Passing this case.') * STOP * diff --git a/TESTING/LIN/psmatgen.f b/TESTING/LIN/psmatgen.f index df8faede..30ae45d4 100644 --- a/TESTING/LIN/psmatgen.f +++ b/TESTING/LIN/psmatgen.f @@ -6,6 +6,7 @@ SUBROUTINE PSMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * .. Scalar Arguments .. CHARACTER*1 AFORM, DIAG @@ -119,7 +120,7 @@ SUBROUTINE PSMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0 ) * .. * .. Local Scalars .. - LOGICAL SYMM, HERM, TRAN + LOGICAL SYMM, HERM, TRAN, EXT_FLAG INTEGER I, IC, IK, INFO, IOFFC, IOFFR, IR, J, JK, $ JUMP1, JUMP2, JUMP3, JUMP4, JUMP5, JUMP6, $ JUMP7, MAXMN, MEND, MOFF, MP, MRCOL, MRROW, @@ -141,8 +142,15 @@ SUBROUTINE PSMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * .. External Functions .. LOGICAL LSAME INTEGER ICEIL, NUMROC + INTEGER CNT1, CNT2, CNT, TOT_CNT, DIV_FACTOR, REGION REAL PSRAND EXTERNAL ICEIL, NUMROC, LSAME, PSRAND +* + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .false. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 * .. * .. Executable Statements .. * @@ -153,6 +161,64 @@ SUBROUTINE PSMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, SYMM = LSAME( AFORM, 'S' ) HERM = LSAME( AFORM, 'H' ) TRAN = LSAME( AFORM, 'T' ) + EXT_FLAG = .FALSE. + +* Take command-line arguments if requested +* + +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EXT_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EXT_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do + + IF ( INF_PERCENT + NAN_PERCENT > 100) THEN + print *,"Sum of INF and NaN is", INF_PERCENT+NAN_PERCENT,"%" + help_flag = .true. + END IF + IF ( INF_PERCENT < 0 .OR. NAN_PERCENT < 0) THEN + print *, "Negative INF / NaN value is not allowed" + help_flag = .true. + END IF + +* Display help message if requested + IF (help_flag .AND. IAM.EQ.0) THEN + print *, "" + print *, "Options:" + print *, " -h, --help Display this help message" + print *, " -inf INF percentage in input", + $ " matrix (default: 0 %)" + print *, " -nan NaN percentage in input", + $ " matrix (default: 0 %)" + print *, "" + print *, " Note: INF + NaN values in input matrix", + $ " should be in the range of 0-100 %" + print *, "" + stop + END IF * INFO = 0 IF( .NOT.LSAME( DIAG, 'D' ) .AND. @@ -212,9 +278,46 @@ SUBROUTINE PSMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, JSEED(1) = ISEED JSEED(2) = 0 * +* Extreme-value parameter caclculations + IF( LSAME( DIAG, 'D' ) ) THEN + DIV_FACTOR = 2 + ELSE + DIV_FACTOR = 4 + END IF +* Find type of matrix to identify where to fill INF/NAN, +* If UPPER_TRIANGULAR_MATRIX., start above DIAG + IF( LSAME(AFORM, 'U' ) ) THEN + REGION = (IRNUM * ICNUM)/DIV_FACTOR +* If LOWER_TRIANGULAR/GENERAL MATRIX, start at beginning + ELSE + REGION = 1 + END IF + IF (EXT_FLAG) THEN + ZERO1 = 0.0E0 + ONE1 = 1.0E0 +* Calculate the number of NANs/INFs per grid + CNT1 = (IRNUM * ICNUM * NAN_PERCENT)/100 + CNT2 = (IRNUM * ICNUM * INF_PERCENT)/100 + CNT1 = CEILING(REAL(CNT1)) + CNT2 = CEILING(REAL(CNT2)) +* When Percentage requested by the user is low +* Replace atleast one element with NAN/INF +* Applicable for smaller matrices [2x2] + IF(NAN_PERCENT .GT. 0 .AND. CNT1 .EQ. 0 ) THEN + CNT1 = CNT1 + 1 + PRINT *, 'NAN Percentage is too low,', + $ 'Including one NAN element' + END IF + IF(INF_PERCENT .GT. 0 .AND. CNT2 .EQ. 0 ) THEN + CNT2 = CNT2 + 1 + PRINT *, 'INF Percentage is too low,', + $ 'Including one INF element' + END IF + END IF +* * Symmetric or Hermitian matrix will be generated. * - IF( SYMM.OR.HERM ) THEN + IF( (SYMM.OR.HERM) .AND. .NOT.(EXT_FLAG) ) THEN * * First, generate the lower triangular part (with diagonal block) * @@ -378,7 +481,8 @@ SUBROUTINE PSMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * * (Conjugate) Transposed matrix A will be generated. * - ELSE IF( TRAN .OR. LSAME( AFORM, 'C' ) ) THEN + ELSE IF(( TRAN .OR. LSAME( AFORM, 'C' )) .AND. + $ .NOT.(EXT_FLAG) ) THEN * JUMP1 = 1 JUMP2 = NQNB @@ -445,6 +549,9 @@ SUBROUTINE PSMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * A random matrix is generated. * ELSE + + TOT_CNT = 0 + CNT = 0 * JUMP1 = 1 JUMP2 = NPMB @@ -481,7 +588,20 @@ SUBROUTINE PSMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, IOFFR = ((IR-1)*NPROW+MRROW) * MB DO 250 J = 1, MB IF( IK .GT. IRNUM ) GO TO 270 - A(IK,JK) = ONE - TWO*PSRAND(0) +* Replace with NANs/INFs for extreme values + IF(EXT_FLAG .AND. CNT .LE. (CNT1 + CNT2) .AND. + $ TOT_CNT .GE. REGION) THEN + IF ( CNT .LT. CNT1) THEN + A(IK, JK) = ZERO1/ZERO1 + ELSE IF ( CNT .LT. (CNT1 + CNT2)) THEN + A(IK, JK) = ONE1/ZERO1 + END IF + CNT = CNT + 1 + TOT_CNT = TOT_CNT + 1 + ELSE + A(IK,JK) = ONE - TWO*PSRAND(0) + TOT_CNT = TOT_CNT + 1 + END IF IK = IK + 1 250 CONTINUE CALL JUMPIT( IA2, IC2, IB1, IRAN2 ) @@ -518,6 +638,9 @@ SUBROUTINE PSMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, RETURN END IF * +* + TOT_CNT = 0 + CNT = 0 MAXMN = MAX(M, N) JK = 1 DO 340 IC = NOFF+1, NEND @@ -528,7 +651,19 @@ SUBROUTINE PSMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, IF( IOFFC.EQ.IOFFR ) THEN DO 310 J = 0, MB-1 IF( IK .GT. IRNUM ) GO TO 330 - A(IK,JK+J) = ABS(A(IK,JK+J)) + MAXMN + IF(EXT_FLAG .AND. CNT .LE. (CNT1 + CNT2) + $ .AND. TOT_CNT .GT. (N/2) ) THEN + IF ( CNT .LT. CNT1) THEN + A(IK, JK+J) = ZERO1/ZERO1 + ELSE IF ( CNT .LT. (CNT1 + CNT2)) THEN + A(IK, JK+J) = ONE1/ZERO1 + END IF + CNT = CNT + 1 + TOT_CNT = TOT_CNT + 1 + ELSE + A(IK,JK+J) = ABS(A(IK,JK+J)) + MAXMN + TOT_CNT = TOT_CNT + 1 + END IF IK = IK + 1 310 CONTINUE ELSE diff --git a/TESTING/LIN/psqrdriver.f b/TESTING/LIN/psqrdriver.f index 050d4b46..42eaa51e 100644 --- a/TESTING/LIN/psqrdriver.f +++ b/TESTING/LIN/psqrdriver.f @@ -4,6 +4,7 @@ PROGRAM PSQRDRIVER * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 28, 2001 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======= @@ -62,6 +63,7 @@ PROGRAM PSQRDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, $ LLD_, MB_, M_, NB_, N_, RSRC_ @@ -94,6 +96,7 @@ PROGRAM PSQRDRIVER CHARACTER*8 ROUTCHK CHARACTER*80 OUTFILE LOGICAL CHECK + LOGICAL M_INVALID, N_INVALID INTEGER I, IAM, IASEED, ICTXT, IMIDPAD, INFO, IPA, $ IPOSTPAD, IPPIV, IPREPAD, IPTAU, IPW, J, K, $ KFAIL, KPASS, KSKIP, KTESTS, L, LIPIV, LTAU, @@ -103,6 +106,7 @@ PROGRAM PSQRDRIVER $ WORKSIZ REAL ANORM, FRESID, THRESH DOUBLE PRECISION NOPS, TMFLOPS + CHARACTER*8 API_NAME * .. * .. Arrays .. CHARACTER*2 FACTOR( NTESTS ) @@ -138,6 +142,16 @@ PROGRAM PSQRDRIVER * .. * .. Data Statements .. DATA KTESTS, KPASS, KFAIL, KSKIP /4*0/ +* +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X +* * .. * .. Executable Statements .. * @@ -153,6 +167,37 @@ PROGRAM PSQRDRIVER $ NTESTS, NGRIDS, PVAL, NTESTS, QVAL, NTESTS, $ THRESH, MEM, IAM, NPROCS ) CHECK = ( THRESH.GE.0.0E+0 ) + M_INVALID = .TRUE. + N_INVALID = .TRUE. +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* * * Loop over the different factorization types * @@ -250,6 +295,7 @@ PROGRAM PSQRDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR(1) = 0 IF( M.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -260,17 +306,20 @@ PROGRAM PSQRDRIVER $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Make sure no one had error * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'matrix' KSKIP = KSKIP + 1 GO TO 20 END IF +#endif * * Loop over different blocking sizes * @@ -347,12 +396,41 @@ PROGRAM PSQRDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, $ 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 10 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 .OR. + $ IERR(1) .EQ. -3 .OR. IERR(1) .EQ. -12 )) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid M and N +* -4, -8 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9984 ) 'N' +* disable extreme value case when N < 0 + EX_FLAG = .FALSE. + ELSE IF(M .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 .OR. + $ IERR(1) .EQ. -3 .OR. IERR(1) .EQ. -12 )) THEN + WRITE( NOUT, FMT = 9984 ) 'M' +* disable extreme value case when M < 0 + EX_FLAG = .FALSE. + ELSE IF(M .EQ. 0 .OR. N .EQ. 0) THEN +* disable extreme value case when M < 0 + EX_FLAG = .FALSE. + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF +#endif * * Assign pointers into MEM for ScaLAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -537,7 +615,7 @@ PROGRAM PSQRDRIVER * * Need the Infinity of A for checking * - IF( CHECK ) THEN + IF( CHECK .AND. (N .GT. 0 .AND. M .GT. 0)) THEN CALL PSFILLPAD( ICTXT, MP, NQ, MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, $ PADVAL ) @@ -575,173 +653,262 @@ PROGRAM PSQRDRIVER * Perform QR factorizations * IF( LSAMEN( 2, FACT, 'QR' ) ) THEN + API_NAME = 'PSGEQRF' CALL SLTIMER( 1 ) CALL PSGEQRF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPTAU ), MEM( IPW ), LWORK, $ INFO ) CALL SLTIMER( 1 ) ELSE IF( LSAMEN( 2, FACT, 'QL' ) ) THEN + API_NAME = 'PSGEQLF' CALL SLTIMER( 1 ) CALL PSGEQLF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPTAU ), MEM( IPW ), LWORK, $ INFO ) CALL SLTIMER( 1 ) ELSE IF( LSAMEN( 2, FACT, 'LQ' ) ) THEN + API_NAME = 'PSGELQF' CALL SLTIMER( 1 ) CALL PSGELQF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPTAU ), MEM( IPW ), LWORK, $ INFO ) CALL SLTIMER( 1 ) ELSE IF( LSAMEN( 2, FACT, 'RQ' ) ) THEN + API_NAME = 'PSGERQF' CALL SLTIMER( 1 ) CALL PSGERQF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPTAU ), MEM( IPW ), LWORK, $ INFO ) CALL SLTIMER( 1 ) ELSE IF( LSAMEN( 2, FACT, 'QP' ) ) THEN + API_NAME = 'PSGEQPF' CALL SLTIMER( 1 ) CALL PSGEQPF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPPIV ), MEM( IPTAU ), $ MEM( IPW ), LWORK, INFO ) CALL SLTIMER( 1 ) ELSE IF( LSAMEN( 2, FACT, 'TZ' ) ) THEN + API_NAME = 'PDTZRZF' CALL SLTIMER( 1 ) +#ifdef ENABLE_DRIVER_CHECK IF( N.GE.M ) $ CALL PSTZRZF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPTAU ), MEM( IPW ), LWORK, $ INFO ) +#else + IF( N .LT. M ) THEN + WRITE( NOUT, FMT = 9982 ) + END IF + CALL PSTZRZF( M, N, MEM( IPA ), 1, 1, DESCA, + $ MEM( IPTAU ), MEM( IPW ), LWORK, + $ INFO ) +#endif CALL SLTIMER( 1 ) END IF * - IF( CHECK ) THEN + IF( CHECK .AND. (.NOT.(EX_FLAG)) ) THEN +* + IF(INFO .EQ. 0 .AND. N .GT. 0 .AND. + $ M .GT. 0) THEN * -* Check for memory overwrite in factorization * - CALL PSCHEKPAD( ICTXT, ROUT, MP, NQ, +* Check for memory overwrite in factorization +* + CALL PSCHEKPAD( ICTXT, ROUT, MP, NQ, $ MEM( IPA-IPREPAD ), DESCA( LLD_ ), $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PSCHEKPAD( ICTXT, ROUT, LTAU, 1, + CALL PSCHEKPAD( ICTXT, ROUT, LTAU, 1, $ MEM( IPTAU-IPREPAD ), LTAU, $ IPREPAD, IPOSTPAD, PADVAL ) - IF( LSAMEN( 2, FACT, 'QP' ) ) THEN - CALL PSCHEKPAD( ICTXT, ROUT, LIPIV, 1, + IF( LSAMEN( 2, FACT, 'QP' ) ) THEN + CALL PSCHEKPAD( ICTXT, ROUT, LIPIV, 1, $ MEM( IPPIV-IPREPAD ), LIPIV, $ IPREPAD, IPOSTPAD, PADVAL ) - END IF - CALL PSCHEKPAD( ICTXT, ROUT, WORKFCT-IPOSTPAD, 1, - $ MEM( IPW-IPREPAD ), + END IF + CALL PSCHEKPAD( ICTXT, ROUT, WORKFCT-IPOSTPAD, + $ 1, MEM( IPW-IPREPAD ), $ WORKFCT-IPOSTPAD, IPREPAD, $ IPOSTPAD, PADVAL ) - CALL PSFILLPAD( ICTXT, WORKSIZ-IPOSTPAD, 1, + CALL PSFILLPAD( ICTXT, WORKSIZ-IPOSTPAD, 1, $ MEM( IPW-IPREPAD ), $ WORKSIZ-IPOSTPAD, $ IPREPAD, IPOSTPAD, PADVAL ) * - IF( LSAMEN( 2, FACT, 'QR' ) ) THEN + IF( LSAMEN( 2, FACT, 'QR' ) ) THEN * -* Compute residual = ||A-Q*R|| / (||A||*N*eps) +* Compute residual = ||A-Q*R|| / (||A||*N*eps) * - CALL PSGEQRRV( M, N, MEM( IPA ), 1, 1, DESCA, + CALL PSGEQRRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, $ MEM( IPTAU ), MEM( IPW ) ) - CALL PSLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, + CALL PSLAFCHK( 'No', 'No', M, N, + $ MEM( IPA ), 1, $ 1, DESCA, IASEED, ANORM, FRESID, $ MEM( IPW ) ) - ELSE IF( LSAMEN( 2, FACT, 'QL' ) ) THEN + ELSE IF( LSAMEN( 2, FACT, 'QL' ) ) THEN * -* Compute residual = ||A-Q*L|| / (||A||*N*eps) +* Compute residual = ||A-Q*L|| / (||A||*N*eps) * - CALL PSGEQLRV( M, N, MEM( IPA ), 1, 1, DESCA, + CALL PSGEQLRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, $ MEM( IPTAU ), MEM( IPW ) ) - CALL PSLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, + CALL PSLAFCHK( 'No', 'No', M, N, + $ MEM( IPA ), 1, $ 1, DESCA, IASEED, ANORM, FRESID, $ MEM( IPW ) ) - ELSE IF( LSAMEN( 2, FACT, 'LQ' ) ) THEN + ELSE IF( LSAMEN( 2, FACT, 'LQ' ) ) THEN * -* Compute residual = ||A-L*Q|| / (||A||*N*eps) +* Compute residual = ||A-L*Q|| / (||A||*N*eps) * - CALL PSGELQRV( M, N, MEM( IPA ), 1, 1, DESCA, + CALL PSGELQRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, $ MEM( IPTAU ), MEM( IPW ) ) - CALL PSLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, + CALL PSLAFCHK( 'No', 'No', M, N, + $ MEM( IPA ), 1, $ 1, DESCA, IASEED, ANORM, FRESID, $ MEM( IPW ) ) - ELSE IF( LSAMEN( 2, FACT, 'RQ' ) ) THEN + ELSE IF( LSAMEN( 2, FACT, 'RQ' ) ) THEN * -* Compute residual = ||A-R*Q|| / (||A||*N*eps) +* Compute residual = ||A-R*Q|| / (||A||*N*eps) * - CALL PSGERQRV( M, N, MEM( IPA ), 1, 1, DESCA, + CALL PSGERQRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, $ MEM( IPTAU ), MEM( IPW ) ) - CALL PSLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, + CALL PSLAFCHK( 'No', 'No', M, N, + $ MEM( IPA ), 1, $ 1, DESCA, IASEED, ANORM, FRESID, $ MEM( IPW ) ) - ELSE IF( LSAMEN( 2, FACT, 'QP' ) ) THEN + ELSE IF( LSAMEN( 2, FACT, 'QP' ) ) THEN * -* Compute residual = ||AP-Q*R|| / (||A||*N*eps) +* Compute residual = ||AP-Q*R|| / (||A||*N*eps) * - CALL PSGEQRRV( M, N, MEM( IPA ), 1, 1, DESCA, + CALL PSGEQRRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, $ MEM( IPTAU ), MEM( IPW ) ) - ELSE IF( LSAMEN( 2, FACT, 'TZ' ) ) THEN + ELSE IF( LSAMEN( 2, FACT, 'TZ' ) ) THEN * -* Compute residual = ||A-T*Z|| / (||A||*N*eps) +* Compute residual = ||A-T*Z|| / (||A||*N*eps) * - IF( N.GE.M ) THEN - CALL PSTZRZRV( M, N, MEM( IPA ), 1, 1, DESCA, + IF( N.GE.M ) THEN + CALL PSTZRZRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, $ MEM( IPTAU ), MEM( IPW ) ) - END IF - CALL PSLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, + END IF + CALL PSLAFCHK( 'No', 'No', M, N, + $ MEM( IPA ), 1, $ 1, DESCA, IASEED, ANORM, FRESID, $ MEM( IPW ) ) - END IF + END IF * -* Check for memory overwrite +* Check for memory overwrite * - CALL PSCHEKPAD( ICTXT, ROUTCHK, MP, NQ, + CALL PSCHEKPAD( ICTXT, ROUTCHK, MP, NQ, $ MEM( IPA-IPREPAD ), DESCA( LLD_ ), $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PSCHEKPAD( ICTXT, ROUTCHK, LTAU, 1, + CALL PSCHEKPAD( ICTXT, ROUTCHK, LTAU, 1, $ MEM( IPTAU-IPREPAD ), LTAU, $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PSCHEKPAD( ICTXT, ROUTCHK, WORKSIZ-IPOSTPAD, + CALL PSCHEKPAD( ICTXT, ROUTCHK, + $ WORKSIZ-IPOSTPAD, $ 1, MEM( IPW-IPREPAD ), $ WORKSIZ-IPOSTPAD, IPREPAD, $ IPOSTPAD, PADVAL ) * - IF( LSAMEN( 2, FACT, 'QP' ) ) THEN + IF( LSAMEN( 2, FACT, 'QP' ) ) THEN * - CALL PSQPPIV( M, N, MEM( IPA ), 1, 1, DESCA, + CALL PSQPPIV( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPPIV ) ) * -* Check for memory overwrite +* Check for memory overwrite * - CALL PSCHEKPAD( ICTXT, 'PSQPPIV', MP, NQ, + CALL PSCHEKPAD( ICTXT, 'PSQPPIV', MP, NQ, $ MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PSCHEKPAD( ICTXT, 'PSQPPIV', LIPIV, 1, + CALL PSCHEKPAD( ICTXT, 'PSQPPIV', LIPIV, 1, $ MEM( IPPIV-IPREPAD ), LIPIV, $ IPREPAD, IPOSTPAD, PADVAL ) * - CALL PSLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, + CALL PSLAFCHK( 'No', 'No', M, N, + $ MEM( IPA ), 1, $ 1, DESCA, IASEED, ANORM, FRESID, $ MEM( IPW ) ) * -* Check for memory overwrite +* Check for memory overwrite * - CALL PSCHEKPAD( ICTXT, 'PSLAFCHK', MP, NQ, + CALL PSCHEKPAD( ICTXT, 'PSLAFCHK', MP, NQ, $ MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PSCHEKPAD( ICTXT, 'PSLAFCHK', + CALL PSCHEKPAD( ICTXT, 'PSLAFCHK', $ WORKSIZ-IPOSTPAD, 1, $ MEM( IPW-IPREPAD ), $ WORKSIZ-IPOSTPAD, IPREPAD, $ IPOSTPAD, PADVAL ) +* + END IF END IF * * Test residual and detect NaN result * - IF( LSAMEN( 2, FACT, 'TZ' ) .AND. N.LT.M ) THEN - KSKIP = KSKIP + 1 - PASSED = 'BYPASS' + M_INVALID = M.LT.0 .AND. + $ ((INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'QR')) .OR. + $ (INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'QL')) .OR. + $ (INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'LQ')) .OR. + $ (INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'RQ')) .OR. + $ (INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'QP')) .OR. + $ (INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'TZ' ))) + N_INVALID = N.LT.0 .AND. + $ ((INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'QR')) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'QL')) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'LQ')) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'RQ')) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'QP')) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'TZ' ))) +* + IF( (N.EQ.0 .AND. INFO.EQ.0) .OR. + $ (M.EQ.0 .AND. INFO.EQ.0) ) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) KPASS, API_NAME + PASSED = 'PASSED' +* RE-ENABLE for EX CASE + IF(INF_PERCENT .GT. 0 .OR. + $ NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + GO TO 10 + ELSE IF(M_INVALID .OR. N_INVALID) THEN +* When N < 0/Invalid, INFO = -2 +* When M < 0/Invalid, INFO = -1 +* Expected Error code for N < 0 +* Hence this case can be passed + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9983 ) KPASS, API_NAME + PASSED = 'PASSED' +* RE-ENABLE for EX CASE + IF(INF_PERCENT .GT. 0 .OR. + $ NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + ELSE IF( LSAMEN( 2, FACT, 'TZ' ) .AND. + $ (N.LT.M .AND. INFO.EQ.-2 ) ) THEN + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9983 ) KPASS, API_NAME ELSE IF( FRESID.LE.THRESH .AND. $ (FRESID-FRESID).EQ.0.0E+0 ) THEN @@ -754,12 +921,47 @@ PROGRAM PSQRDRIVER END IF * ELSE + +* Extreme value cases + IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, M + DO JK = 1, N+1 + X = MEM(IK*N + JK) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF + FRESID = FRESID - FRESID * -* Don't perform the checking, only timing -* - KPASS = KPASS + 1 - FRESID = FRESID - FRESID - PASSED = 'BYPASS' +* Don't perform the checking, only the timing +* operation + ELSE + KPASS = KPASS + 1 + FRESID = FRESID - FRESID + PASSED = 'BYPASS' + END IF * END IF * @@ -881,6 +1083,16 @@ PROGRAM PSQRDRIVER 9988 FORMAT( I5, ' tests skipped because of illegal input values.' ) 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( A ) + 9985 FORMAT( '----------Test-',I3,' Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9983 FORMAT( '----------Negative Test-',I3,' Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') + 9982 FORMAT( ' N < M case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the PCTZRZF API.') * STOP * diff --git a/TESTING/LIN/pzdbdriver.f b/TESTING/LIN/pzdbdriver.f index 5edf9962..c3299df6 100644 --- a/TESTING/LIN/pzdbdriver.f +++ b/TESTING/LIN/pzdbdriver.f @@ -6,6 +6,8 @@ PROGRAM PZDBDRIVER * and University of California, Berkeley. * November 15, 1997 * +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. +* * Purpose * ======= * @@ -70,6 +72,7 @@ PROGRAM PZDBDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER TOTMEM #ifndef DYNAMIC_WORK_MEM_ALLOC @@ -145,6 +148,14 @@ PROGRAM PZDBDRIVER DATA KFAIL, KPASS, KSKIP, KTESTS / 4*0 / * .. * +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X * * * .. Executable Statements .. @@ -162,8 +173,37 @@ PROGRAM PZDBDRIVER $ BWLVAL, BWUVAL, NTESTS, NNB, NBVAL, NTESTS, NNR, $ NRVAL, NTESTS, NNBR, NBRVAL, NTESTS, NGRIDS, PVAL, $ NTESTS, QVAL, NTESTS, THRESH, MEM, IAM, NPROCS ) +* * CHECK = ( THRESH.GE.0.0D+0 ) +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do * * Print headings * @@ -183,6 +223,7 @@ PROGRAM PZDBDRIVER * * Make sure grid information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR( 1 ) = 0 IF( NPROW.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -204,6 +245,7 @@ PROGRAM PZDBDRIVER KSKIP = KSKIP + 1 GO TO 50 END IF +#endif * * Define process grid * @@ -233,23 +275,28 @@ PROGRAM PZDBDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'size' KSKIP = KSKIP + 1 GO TO 40 END IF +#endif * * DO 45 BW_NUM = 1, NBW @@ -287,10 +334,12 @@ PROGRAM PZDBDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 45 END IF +#endif * DO 30 K = 1, NNB * @@ -303,6 +352,10 @@ PROGRAM PZDBDRIVER NB = MAX( NB, 2*MAX(BWL,BWU) ) NB = MIN( N, NB ) END IF +* Altering the auto-assign for early return of N case + IF (N .EQ. 0 .AND. NB.EQ.0) THEN + NB = 1 + END IF * * Make sure NB is legal * @@ -316,10 +369,13 @@ PROGRAM PZDBDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 30 END IF +#endif * * Padding constants * @@ -361,12 +417,42 @@ PROGRAM PZDBDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -3 .OR. + $ IERR(1) .EQ. -6 .OR. IERR(1) .EQ. -9 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -12 )) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid M and N +* -4, -6 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9983 ) 'N' +* disable extreme value case when N < 0 + EX_FLAG = .FALSE. + ELSE IF(N .EQ. 0 .AND. (IERR(1) .EQ. 0 .OR. + $ IERR(1) .EQ. -5 .OR. IERR(1) .EQ. -10 .OR. + $ IERR(1) .EQ. -15 .OR. IERR(1) .EQ. -20 )) THEN +* DESCINIT returns the correct error code, +* When N = 0, IERR(1) could be return +* -5, -10 or -20 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING +* disable extreme value case when N = 0 + EX_FLAG = .FALSE. + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -483,17 +569,19 @@ PROGRAM PZDBDRIVER $ ((BWL+BWU+1)+10), 0, 0, IASEED, MYROW, $ MYCOL, NPROW, NPCOL ) * - CALL PZFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), + IF(N .GE. 0) THEN + CALL PZFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), $ ((BWL+BWU+1)+10), IPREPAD, IPOSTPAD, $ PADVAL ) * - CALL PZFILLPAD( ICTXT, WORKSIZ, 1, + CALL PZFILLPAD( ICTXT, WORKSIZ, 1, $ MEM( IP_DRIVER_W-IPREPAD ), WORKSIZ, $ IPREPAD, IPOSTPAD, PADVAL ) + END IF * * Calculate norm of A for residual error-checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0) THEN * ANORM = PZLANGE( '1', (BWL+BWU+1), $ N, MEM( IPA ), 1, 1, @@ -522,14 +610,25 @@ PROGRAM PZDBDRIVER CALL SLTIMER( 1 ) * IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) THEN - WRITE( NOUT, FMT = * ) 'PZDBTRF INFO=', INFO - ENDIF - KFAIL = KFAIL + 1 - GO TO 30 + IF(N .LT. 0 .AND. (INFO .EQ. -1 .OR. + $ INFO .EQ. -604 )) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PDDBTRF INFO=', INFO +* When N = 0, make BWL and BWU = 0 for early return + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -3) THEN +* expected error code, when bandwidth is incorrect +* pass this case to solve API + WRITE( NOUT, FMT = * ) 'PZDBTRF INFO=', INFO + ELSE + IF( IAM.EQ.0 ) THEN + WRITE( NOUT, FMT = * ) 'PZDBTRF INFO=', INFO + ENDIF + KFAIL = KFAIL + 1 + GO TO 30 + END IF END IF * - IF( CHECK ) THEN + IF( CHECK .AND. INFO .EQ. 0 ) THEN * * Check for memory overwrite in factorization * @@ -640,14 +739,23 @@ PROGRAM PZDBDRIVER CALL SLTIMER( 2 ) * IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) - $ WRITE( NOUT, FMT = * ) 'PZDBTRS INFO=', INFO - KFAIL = KFAIL + 1 - PASSED = 'FAILED' - GO TO 20 + IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804)) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PCDBTRS INFO=', INFO + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -4) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PZDBTRS INFO=', INFO + ELSE + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = * ) 'PZDBTRS INFO=', INFO + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + GO TO 20 + END IF END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN * * check for memory overwrite * @@ -661,12 +769,14 @@ PROGRAM PZDBDRIVER * SRESID = ZERO * - CALL PZDBLASCHK( 'N', 'D', TRANS, + IF(INFO .EQ. 0) THEN + CALL PZDBLASCHK( 'N', 'D', TRANS, $ N, BWL, BWU, NRHS, $ MEM( IPB ), 1, 1, DESCB2D, $ IASEED, MEM( IPA ), 1, 1, DESCA2D, $ IBSEED, ANORM, SRESID, $ MEM( IP_DRIVER_W ), WORKSIZ ) + END IF * IF( IAM.EQ.0 ) THEN IF( SRESID.GT.THRESH ) @@ -675,7 +785,23 @@ PROGRAM PZDBDRIVER * * The second test is a NaN trap * - IF( ( SRESID.LE.THRESH ).AND. + IF( N .EQ. 0 .AND. (INFO .EQ. -4 .OR. + $ INFO .EQ. 0)) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9984 ) 'PZDBTRS' + PASSED = 'PASSED' + ELSE IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804 )) THEN +* When N < 0/Invalid, PDDBTRS INFO = -1 +* Expected Error code for N < 0 +* Hence this case can be passed + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9982 ) 'PCDBTRS' + PASSED = 'PASSED' + ELSE IF( ( SRESID.LE.THRESH ).AND. $ ( (SRESID-SRESID).EQ.0.0D+0 ) ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' @@ -683,6 +809,35 @@ PROGRAM PZDBDRIVER KFAIL = KFAIL + 1 PASSED = 'FAILED' END IF + ELSE IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, N-1 + DO JK = 1, N + X = (MEM(IK*N + JK)) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite(X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF * END IF * @@ -932,6 +1087,13 @@ PROGRAM PZDBDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - ', A4, '|| / (||A|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Ax-b||/(||x||*||A||*eps*N) ', F25.7 ) + 9984 FORMAT( '----------Test Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9983 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9982 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') * STOP * diff --git a/TESTING/LIN/pzdtdriver.f b/TESTING/LIN/pzdtdriver.f index 2e841de1..2b6b36c5 100644 --- a/TESTING/LIN/pzdtdriver.f +++ b/TESTING/LIN/pzdtdriver.f @@ -6,6 +6,8 @@ PROGRAM PZDTDRIVER * and University of California, Berkeley. * November 15, 1997 * +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. +* * Purpose * ======= * @@ -70,6 +72,7 @@ PROGRAM PZDTDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER TOTMEM #ifndef DYNAMIC_WORK_MEM_ALLOC @@ -145,6 +148,14 @@ PROGRAM PZDTDRIVER DATA KFAIL, KPASS, KSKIP, KTESTS / 4*0 / * .. * +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X * * * .. Executable Statements .. @@ -165,6 +176,35 @@ PROGRAM PZDTDRIVER * CHECK = ( THRESH.GE.0.0D+0 ) * +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* * Print headings * IF( IAM.EQ.0 ) THEN @@ -183,6 +223,7 @@ PROGRAM PZDTDRIVER * * Make sure grid information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR( 1 ) = 0 IF( NPROW.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -204,6 +245,7 @@ PROGRAM PZDTDRIVER KSKIP = KSKIP + 1 GO TO 50 END IF +#endif * * Define process grid * @@ -233,23 +275,28 @@ PROGRAM PZDTDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'size' KSKIP = KSKIP + 1 GO TO 40 END IF +#endif * * DO 45 BW_NUM = 1, NBW @@ -287,10 +334,12 @@ PROGRAM PZDTDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 45 END IF +#endif * DO 30 K = 1, NNB * @@ -303,6 +352,10 @@ PROGRAM PZDTDRIVER NB = MAX( NB, 2*INT_ONE ) NB = MIN( N, NB ) END IF +* Altering the auto-assign for early return of N case + IF (N .EQ. 0 .AND. NB.EQ.0) THEN + NB = 1 + END IF * * Make sure NB is legal * @@ -316,10 +369,13 @@ PROGRAM PZDTDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 30 END IF +#endif * * Padding constants * @@ -361,12 +417,43 @@ PROGRAM PZDTDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -3 .OR. + $ IERR(1) .EQ. -6 .OR. IERR(1) .EQ. -9 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -12 .OR. + $ IERR(1) .EQ. -2 .OR. IERR(1) .EQ. -8) ) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid M and N +* -4, -6 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9983 ) 'N' +* disable extreme value case when N < 0 + EX_FLAG = .FALSE. + ELSE IF(N .EQ. 0 .AND. (IERR(1) .EQ. 0 .OR. + $ IERR(1) .EQ. -5 .OR. IERR(1) .EQ. -10 .OR. + $ IERR(1) .EQ. -15 .OR. IERR(1) .EQ. -20 )) THEN +* DESCINIT returns the correct error code, +* When N = 0, +* -5, -10 or -20 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING +* disable extreme value case when N = 0 + EX_FLAG = .FALSE. + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -480,17 +567,20 @@ PROGRAM PZDTDRIVER CALL PZBMATGEN( ICTXT, 'T', 'D', BWL, BWU, N, (3), NB, $ MEM( IPA ), NB+10, 0, 0, IASEED, MYROW, $ MYCOL, NPROW, NPCOL ) - CALL PZFILLPAD( ICTXT, NQ, NP, MEM( IPA-IPREPAD ), + + IF(N .GE. 0) THEN + CALL PZFILLPAD( ICTXT, NQ, NP, MEM( IPA-IPREPAD ), $ NB+10, IPREPAD, IPOSTPAD, $ PADVAL ) * - CALL PZFILLPAD( ICTXT, WORKSIZ, 1, + CALL PZFILLPAD( ICTXT, WORKSIZ, 1, $ MEM( IP_DRIVER_W-IPREPAD ), WORKSIZ, $ IPREPAD, IPOSTPAD, PADVAL ) + END IF * * Calculate norm of A for residual error-checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * ANORM = PZLANGE( 'I', N, $ (3), MEM( IPA ), 1, 1, @@ -520,14 +610,25 @@ PROGRAM PZDTDRIVER CALL SLTIMER( 1 ) * IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) THEN - WRITE( NOUT, FMT = * ) 'PZDTTRF INFO=', INFO - ENDIF - KFAIL = KFAIL + 1 - GO TO 30 + IF(N .LT. 0 .AND. (INFO .EQ. -1 .OR. + $ INFO .EQ. -604 )) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PZDTTRF INFO=', INFO +* When N = 0, make BWL and BWU = 0 for early return + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -3) THEN +* expected error code, when bandwidth is > 0 +* pass this case to solve API + WRITE( NOUT, FMT = * ) 'PZDTTRF INFO=', INFO + ELSE + IF( IAM.EQ.0 ) THEN + WRITE( NOUT, FMT = * ) 'PZDTTRF INFO=', INFO + ENDIF + KFAIL = KFAIL + 1 + GO TO 30 + END IF END IF * - IF( CHECK ) THEN + IF( CHECK .AND. INFO .EQ. 0 ) THEN * * Check for memory overwrite in factorization * @@ -640,14 +741,23 @@ PROGRAM PZDTDRIVER CALL SLTIMER( 2 ) * IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) - $ WRITE( NOUT, FMT = * ) 'PZDTTRS INFO=', INFO - KFAIL = KFAIL + 1 - PASSED = 'FAILED' - GO TO 20 + IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804)) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PZDTTRS INFO=', INFO + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -4) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PZDTTRS INFO=', INFO + ELSE + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = * ) 'PZDTTRS INFO=', INFO + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + GO TO 20 + END IF END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN * * check for memory overwrite * @@ -667,12 +777,14 @@ PROGRAM PZDTDRIVER CALL DESCINIT( DESCA2D, (3), N, $ (3), NB, 0, 0, $ ICTXT, (3), IERR( 1 ) ) - CALL PZDTLASCHK( 'N', 'D', TRANS, + IF(INFO .EQ. 0) THEN + CALL PZDTLASCHK( 'N', 'D', TRANS, $ N, BWL, BWU, NRHS, $ MEM( IPB ), 1, 1, DESCB2D, $ IASEED, MEM( IPA ), 1, 1, DESCA2D, $ IBSEED, ANORM, SRESID, $ MEM( IP_DRIVER_W ), WORKSIZ ) + END IF * IF( IAM.EQ.0 ) THEN IF( SRESID.GT.THRESH ) @@ -681,7 +793,33 @@ PROGRAM PZDTDRIVER * * The second test is a NaN trap * - IF( ( SRESID.LE.THRESH ).AND. + IF( N .EQ. 0 .AND. (INFO .EQ. -4 .OR. + $ INFO .EQ. 0)) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9984 ) 'PZDTTRS' + PASSED = 'PASSED' +* Re-enable EX_FLAG + IF(NAN_PERCENT .GT. 0 .OR. + $ INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + ELSE IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804 )) THEN +* When N < 0/Invalid, PDDTTRS INFO = -1 +* Expected Error code for N < 0 +* Hence this case can be passed + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9982 ) 'PZDTTRS' + PASSED = 'PASSED' +* Re-enable EX_FLAG + IF(NAN_PERCENT .GT. 0 .OR. + $ INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + ELSE IF( ( SRESID.LE.THRESH ).AND. $ ( (SRESID-SRESID).EQ.0.0D+0 ) ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' @@ -689,6 +827,37 @@ PROGRAM PZDTDRIVER KFAIL = KFAIL + 1 PASSED = 'FAILED' END IF +* Extreme-value validation block + ELSE IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, N-1 + DO JK = 1, N + X = (MEM(IK*N + JK)) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF * END IF * @@ -938,6 +1107,13 @@ PROGRAM PZDTDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - ', A4, '|| / (||A|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Ax-b||/(||x||*||A||*eps*N) ', F25.7 ) + 9984 FORMAT( '----------Test Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9983 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9982 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') * STOP * diff --git a/TESTING/LIN/pzgbdriver.f b/TESTING/LIN/pzgbdriver.f index 108ef5a3..4e71f4bc 100644 --- a/TESTING/LIN/pzgbdriver.f +++ b/TESTING/LIN/pzgbdriver.f @@ -6,6 +6,8 @@ PROGRAM PZGBDRIVER * and University of California, Berkeley. * November 15, 1997 * +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. +* * Purpose * ======= * @@ -76,6 +78,7 @@ PROGRAM PZGBDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER TOTMEM, INTMEM #ifndef DYNAMIC_WORK_MEM_ALLOC @@ -152,6 +155,14 @@ PROGRAM PZGBDRIVER DATA KFAIL, KPASS, KSKIP, KTESTS / 4*0 / * .. * +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X * * * .. Executable Statements .. @@ -172,6 +183,35 @@ PROGRAM PZGBDRIVER * CHECK = ( THRESH.GE.0.0D+0 ) * +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* * Print headings * IF( IAM.EQ.0 ) THEN @@ -190,6 +230,7 @@ PROGRAM PZGBDRIVER * * Make sure grid information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR( 1 ) = 0 IF( NPROW.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -211,6 +252,7 @@ PROGRAM PZGBDRIVER KSKIP = KSKIP + 1 GO TO 50 END IF +#endif * * Define process grid * @@ -240,23 +282,28 @@ PROGRAM PZGBDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'size' KSKIP = KSKIP + 1 GO TO 40 END IF +#endif * * DO 45 BW_NUM = 1, NBW @@ -294,10 +341,12 @@ PROGRAM PZGBDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 45 END IF +#endif * DO 30 K = 1, NNB * @@ -310,6 +359,10 @@ PROGRAM PZGBDRIVER NB = MAX( NB, 2*(BWL+BWU) ) NB = MIN( N, NB ) END IF +* Altering the auto-assign for early return of N case + IF (N .EQ. 0 .AND. NB.EQ.0) THEN + NB = 1 + END IF * * Make sure NB is legal * @@ -330,10 +383,13 @@ PROGRAM PZGBDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * + +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN KSKIP = KSKIP + 1 GO TO 30 END IF +#endif * * Padding constants * @@ -375,12 +431,43 @@ PROGRAM PZGBDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -3 .OR. + $ IERR(1) .EQ. -6 .OR. IERR(1) .EQ. -9 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -12 .OR. + $ IERR(1) .EQ. -2 .OR. IERR(1) .EQ. -8) ) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid M and N +* -4, -6 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9983 ) 'N' +* disable extreme value case when N < 0 + EX_FLAG = .FALSE. + ELSE IF(N .EQ. 0 .AND. (IERR(1) .EQ. 0 .OR. + $ IERR(1) .EQ. -5 .OR. IERR(1) .EQ. -10 .OR. + $ IERR(1) .EQ. -15 .OR. IERR(1) .EQ. -20 )) THEN +* DESCINIT returns the correct error code, +* When N = 0, +* -5, -10 or -20 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING +* disable extreme value case when N = 0 + EX_FLAG = .FALSE. + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -497,17 +584,19 @@ PROGRAM PZGBDRIVER $ ((2*BWL+2*BWU+1)+10), 0, 0, IASEED, $ MYROW, MYCOL, NPROW, NPCOL ) * - CALL PZFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), + IF(N .GE. 0) THEN + CALL PZFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), $ ((2*BWL+2*BWU+1)+10), IPREPAD, IPOSTPAD, $ PADVAL ) * - CALL PZFILLPAD( ICTXT, WORKSIZ, 1, + CALL PZFILLPAD( ICTXT, WORKSIZ, 1, $ MEM( IP_DRIVER_W-IPREPAD ), WORKSIZ, $ IPREPAD, IPOSTPAD, PADVAL ) + END IF * * Calculate norm of A for residual error-checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * ANORM = PZLANGE( '1', (2*BWL+2*BWU+1), $ N, MEM( IPA ), 1, 1, @@ -535,15 +624,26 @@ PROGRAM PZGBDRIVER * CALL SLTIMER( 1 ) * - IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) THEN - WRITE( NOUT, FMT = * ) 'PZGBTRF INFO=', INFO - ENDIF - KFAIL = KFAIL + 1 - GO TO 30 + IF( INFO.NE.0 .AND. .NOT.(EX_FLAG)) THEN + IF(N .LT. 0 .AND. (INFO .EQ. -1 .OR. + $ INFO .EQ. -604 )) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PZGBTRF INFO=', INFO +* When N = 0, make BWL and BWU = 0 for early return + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -3) THEN +* expected error code, when bandwidth is > 0 +* pass this case to solve API + WRITE( NOUT, FMT = * ) 'PZGBTRF INFO=', INFO + ELSE + IF( IAM.EQ.0 ) THEN + WRITE( NOUT, FMT = * ) 'PZGBTRF INFO=', INFO + ENDIF + KFAIL = KFAIL + 1 + GO TO 30 + END IF END IF * - IF( CHECK ) THEN + IF( CHECK .AND. INFO .EQ. 0 ) THEN * * Check for memory overwrite in factorization * @@ -653,12 +753,21 @@ PROGRAM PZGBDRIVER * CALL SLTIMER( 2 ) * - IF( INFO.NE.0 ) THEN - IF( IAM.EQ.0 ) - $ WRITE( NOUT, FMT = * ) 'PZGBTRS INFO=', INFO - KFAIL = KFAIL + 1 - PASSED = 'FAILED' - GO TO 20 + IF( INFO.NE.0 .AND. .NOT.(EX_FLAG) ) THEN + IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804)) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PZGBTRS INFO=', INFO + ELSE IF(N .EQ. 0 .AND. INFO .EQ. -4) THEN +* expected error code, pass this case to solve API + WRITE( NOUT, FMT = * ) 'PZGBTRS INFO=', INFO + ELSE + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = * ) 'PZGBTRS INFO=', INFO + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + GO TO 20 + END IF END IF * IF( CHECK ) THEN @@ -675,12 +784,14 @@ PROGRAM PZGBDRIVER * SRESID = ZERO * - CALL PZDBLASCHK( 'N', 'N', TRANS, + IF(INFO .EQ. 0) THEN + CALL PZDBLASCHK( 'N', 'N', TRANS, $ N, BWL, BWU, NRHS, $ MEM( IPB ), 1, 1, DESCB2D, $ IASEED, MEM( IPA+BWL+BWU ), 1, 1, DESCA2D, $ IBSEED, ANORM, SRESID, $ MEM( IP_DRIVER_W ), WORKSIZ ) + END IF * IF( IAM.EQ.0 ) THEN IF( SRESID.GT.THRESH ) @@ -689,7 +800,33 @@ PROGRAM PZGBDRIVER * * The second test is a NaN trap * - IF( ( SRESID.LE.THRESH ).AND. + IF( N .EQ. 0 .AND. (INFO .EQ. -4 .OR. + $ INFO .EQ. 0)) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9984 ) 'PZGBTRS' + PASSED = 'PASSED' +* Re-enable EX_FLAG + IF(NAN_PERCENT .GT. 0 .OR. + $ INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + ELSE IF(N .LT. 0 .AND. (INFO .EQ. -2 .OR. + $ INFO .EQ. -804 )) THEN +* When N < 0/Invalid, PZGBTRS INFO = -1 +* Expected Error code for N < 0 +* Hence this case can be passed + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9982 ) 'PZGBTRS' + PASSED = 'PASSED' +* Re-enable EX_FLAG + IF(NAN_PERCENT .GT. 0 .OR. + $ INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + ELSE IF( ( SRESID.LE.THRESH ).AND. $ ( (SRESID-SRESID).EQ.0.0D+0 ) ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' @@ -697,6 +834,37 @@ PROGRAM PZGBDRIVER KFAIL = KFAIL + 1 PASSED = 'FAILED' END IF +* Extreme-value validation block + ELSE IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, N-1 + DO JK = 1, N + X = (MEM(IK*N + JK)) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF * END IF * @@ -946,6 +1114,13 @@ PROGRAM PZGBDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - ', A4, '|| / (||A|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Ax-b||/(||x||*||A||*eps*N) ', F25.7 ) + 9984 FORMAT( '----------Test Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9983 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9982 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') * STOP * diff --git a/TESTING/LIN/pzinvdriver.f b/TESTING/LIN/pzinvdriver.f index c55cc2e6..a0cab956 100644 --- a/TESTING/LIN/pzinvdriver.f +++ b/TESTING/LIN/pzinvdriver.f @@ -4,6 +4,7 @@ PROGRAM PZINVDRIVER * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======= @@ -60,6 +61,7 @@ PROGRAM PZINVDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, $ LLD_, MB_, M_, NB_, N_, RSRC_ @@ -101,6 +103,7 @@ PROGRAM PZINVDRIVER $ NPROW, NQ, WORKIINV, WORKINV, WORKSIZ REAL THRESH DOUBLE PRECISION ANORM, FRESID, NOPS, RCOND, TMFLOPS + CHARACTER*8 API_NAME * .. * .. Local Arrays .. CHARACTER*3 MATTYP( NTESTS ) @@ -138,6 +141,15 @@ PROGRAM PZINVDRIVER * .. * .. Executable Statements .. * +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X +* * Get starting information * #ifdef DYNAMIC_WORK_MEM_ALLOC @@ -149,6 +161,36 @@ PROGRAM PZINVDRIVER $ NTESTS, NNB, NBVAL, NTESTS, NGRIDS, PVAL, NTESTS, $ QVAL, NTESTS, THRESH, MEM, IAM, NPROCS ) CHECK = ( THRESH.GE.0.0E+0 ) + +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* * * Loop over the different matrix types * @@ -236,12 +278,14 @@ PROGRAM PZINVDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR( 1 ) = 0 - IF( N.LT.1 ) THEN + IF( N.LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Make sure no one had error * @@ -305,12 +349,30 @@ PROGRAM PZINVDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, $ 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 10 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 )) THEN +* DESCINIT returns the correct error code, +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9984 ) 'N' +* disable extreme flag for negative case + EX_FLAG = .FALSE. + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF + +#endif * * Assign pointers into MEM for ScaLAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -421,23 +483,51 @@ PROGRAM PZINVDRIVER * * Generate a general diagonally dominant matrix A * - CALL PZMATGEN( ICTXT, 'N', 'D', DESCA( M_ ), + IF(EX_FLAG) THEN +* The extreme-value generation module for +* diagonally dominant matrices, requires +* Matrix-type info such as Upper/Lower. +* Hence, MTYP(1:1) is passed to MATGEN +* MTYP(1:1) is 'U'/'L'/'N' (default-case) + CALL PZMATGEN( ICTXT, MTYP(1:1), 'D', + $ DESCA( M_ ), + $ DESCA( N_ ), DESCA( MB_ ), + $ DESCA( NB_ ), MEM( IPA ), + $ DESCA( LLD_ ), DESCA( RSRC_ ), + $ DESCA( CSRC_ ), IASEED, 0, NP, 0, + $ NQ, MYROW, MYCOL, NPROW, NPCOL ) + ELSE + CALL PZMATGEN( ICTXT, 'N', 'D', + $ DESCA( M_ ), $ DESCA( N_ ), DESCA( MB_ ), $ DESCA( NB_ ), MEM( IPA ), $ DESCA( LLD_ ), DESCA( RSRC_ ), $ DESCA( CSRC_ ), IASEED, 0, NP, 0, $ NQ, MYROW, MYCOL, NPROW, NPCOL ) + END IF * ELSE IF( LSAMEN( 2, MTYP( 2:3 ), 'PD' ) ) THEN * * Generate a Hermitian positive definite matrix A * - CALL PZMATGEN( ICTXT, 'H', 'D', DESCA( M_ ), + IF(EX_FLAG) THEN +* MTYP(1:1) is 'U'/'L'/'N' (default-case) + CALL PZMATGEN( ICTXT, MTYP(1:1), 'D', + $ DESCA( M_ ), + $ DESCA( N_ ), DESCA( MB_ ), + $ DESCA( NB_ ), MEM( IPA ), + $ DESCA( LLD_ ), DESCA( RSRC_ ), + $ DESCA( CSRC_ ), IASEED, 0, NP, 0, + $ NQ, MYROW, MYCOL, NPROW, NPCOL ) + ELSE + CALL PZMATGEN( ICTXT, 'H', 'D', + $ DESCA( M_ ), $ DESCA( N_ ), DESCA( MB_ ), $ DESCA( NB_ ), MEM( IPA ), $ DESCA( LLD_ ), DESCA( RSRC_ ), $ DESCA( CSRC_ ), IASEED, 0, NP, 0, $ NQ, MYROW, MYCOL, NPROW, NPCOL ) + END IF * END IF * @@ -463,7 +553,7 @@ PROGRAM PZINVDRIVER * * Need 1-norm of A for checking * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * CALL PZFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, @@ -575,7 +665,7 @@ PROGRAM PZINVDRIVER $ MEM( IPPIV ), INFO ) CALL SLTIMER( 1 ) * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * * Check for memory overwrite * @@ -591,12 +681,13 @@ PROGRAM PZINVDRIVER * Perform the general matrix inversion * CALL SLTIMER( 2 ) + API_NAME = 'PZGETRI' CALL PZGETRI( N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPPIV ), MEM( IPW ), LWORK, $ MEM( IPIW ), LIWORK, INFO ) CALL SLTIMER( 2 ) * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * * Check for memory overwrite * @@ -624,11 +715,12 @@ PROGRAM PZINVDRIVER * Perform the general matrix inversion * CALL SLTIMER( 2 ) + API_NAME = 'PZTRTRI' CALL PZTRTRI( UPLO, 'Non unit', N, MEM( IPA ), 1, $ 1, DESCA, INFO ) CALL SLTIMER( 2 ) * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * * Check for memory overwrite * @@ -647,7 +739,7 @@ PROGRAM PZINVDRIVER $ INFO ) CALL SLTIMER( 1 ) * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * * Check for memory overwrite * @@ -661,11 +753,12 @@ PROGRAM PZINVDRIVER * inversion * CALL SLTIMER( 2 ) + API_NAME = 'PZPOTRI' CALL PZPOTRI( UPLO, N, MEM( IPA ), 1, 1, DESCA, $ INFO ) CALL SLTIMER( 2 ) * - IF( CHECK ) THEN + IF( CHECK .AND. N.GT.0 ) THEN * * Check for memory overwrite * @@ -677,37 +770,67 @@ PROGRAM PZINVDRIVER * END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG)) THEN * - CALL PZFILLPAD( ICTXT, WORKSIZ-IPOSTPAD, 1, + IF(INFO.EQ.0 .AND. N.GT.0) THEN +* + CALL PZFILLPAD( ICTXT, WORKSIZ-IPOSTPAD, 1, $ MEM( IPW-IPREPAD ), $ WORKSIZ-IPOSTPAD, IPREPAD, $ IPOSTPAD, PADVAL ) * -* Compute fresid = || inv(A)*A-I || +* Compute fresid = || inv(A)*A-I || * - CALL PZINVCHK( MTYP, N, MEM( IPA ), 1, 1, DESCA, + CALL PZINVCHK( MTYP, N, MEM( IPA ), 1, 1, DESCA, $ IASEED, ANORM, FRESID, RCOND, $ MEM( IPW ) ) * -* Check for memory overwrite +* Check for memory overwrite * - CALL PZCHEKPAD( ICTXT, 'PZINVCHK', NP, NQ, + CALL PZCHEKPAD( ICTXT, 'PZINVCHK', NP, NQ, $ MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PZCHEKPAD( ICTXT, 'PZINVCHK', + CALL PZCHEKPAD( ICTXT, 'PZINVCHK', $ WORKSIZ-IPOSTPAD, 1, $ MEM( IPW-IPREPAD ), $ WORKSIZ-IPOSTPAD, IPREPAD, $ IPOSTPAD, PADVAL ) + END IF * * Test residual and detect NaN result * - IF( FRESID.LE.THRESH .AND. INFO.EQ.0 .AND. + IF(N.EQ.0 .AND. INFO.EQ.0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) KPASS, API_NAME + PASSED = 'PASSED' + GO TO 10 + ELSE IF( FRESID.LE.THRESH .AND. INFO.EQ.0 .AND. $ ( (FRESID-FRESID) .EQ. 0.0D+0 ) ) THEN KPASS = KPASS + 1 PASSED = 'PASSED' + ELSE IF(N.LT.0 .AND. + $ ((INFO.EQ.-1 + $ .AND. LSAMEN( 3, MTYP, 'GEN' )) .OR. + $ (INFO.EQ.-3 .AND. + $ LSAMEN( 2, MTYP( 2:3 ), 'TR' )) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, MTYP( 2:3 ), 'PD' )))) THEN +* When N < 0/Invalid, PCGETRI INFO = -1 +* PTPOTRI INFO = -2 and PCTRTRI INFO = -3 +* Expected Error code for N < 0 +* Hence this case can be passed + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9983 ) API_NAME + PASSED = 'PASSED' +* re-enable extreme flag for next case + IF(INF_PERCENT .GT. 0 .OR. + $ NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF ELSE KFAIL = KFAIL + 1 IF( INFO.GT.0 ) THEN @@ -719,12 +842,54 @@ PROGRAM PZINVDRIVER * ELSE * +* Extreme value case + IF(N.EQ.0 .AND. INFO.EQ.0) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) KPASS, API_NAME + PASSED = 'PASSED' + GO TO 10 + ELSE IF(EX_FLAG .AND. N.GT.0) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, N-1 + DO JK = 1, N + X = REAL(MEM(IK*N + JK)) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF + FRESID = FRESID - FRESID +* * Don't perform the checking, only the timing * operation -* - KPASS = KPASS + 1 - FRESID = FRESID - FRESID - PASSED = 'BYPASS' + ELSE + KPASS = KPASS + 1 + FRESID = FRESID - FRESID + PASSED = 'BYPASS' + END IF * END IF * @@ -735,7 +900,7 @@ PROGRAM PZINVDRIVER * * Print results * - IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN + IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN * IF( LSAMEN( 3, MTYP, 'GEN' ) ) THEN * @@ -861,6 +1026,13 @@ PROGRAM PZINVDRIVER 9988 FORMAT( I5, ' tests skipped because of illegal input values.' ) 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( A ) + 9985 FORMAT( '----------Test-',I3,' Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9983 FORMAT( '----------Negative-Test Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') * STOP * diff --git a/TESTING/LIN/pzlltdriver.f b/TESTING/LIN/pzlltdriver.f index b14f5e2e..f0501119 100644 --- a/TESTING/LIN/pzlltdriver.f +++ b/TESTING/LIN/pzlltdriver.f @@ -4,6 +4,7 @@ PROGRAM PZLLTDRIVER * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======= @@ -207,6 +208,7 @@ PROGRAM PZLLTDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR( 1 ) = 0 IF( N.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -217,6 +219,7 @@ PROGRAM PZLLTDRIVER $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * @@ -276,12 +279,26 @@ PROGRAM PZLLTDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else +* If N < 0 in LLT.dat file then DESCINIT API sets IERR( 1 ) = -2 + IF( N.LT.0 .AND. IERR( 1 ).EQ.-2 ) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9984 ) 'N' + ELSE IF( IERR( 1 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -396,10 +413,28 @@ PROGRAM PZLLTDRIVER * CALL SLTIMER( 1 ) * + IF( INFO.NE.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = * ) 'PZPOTRF INFO=', INFO - KFAIL = KFAIL + 1 +* If N < 0 in LLT.dat file then PZPOTRF API sets INFO = -2 + IF (N.LT.0 .AND. INFO.EQ.-2) THEN +* If PZPOTRF is returning correct error +* code we need to pass this case + WRITE( NOUT, FMT = 9983 ) 'PZPOTRF' + KPASS = KPASS + 1 + ELSE +* For other error code we will mark test case as fail + KFAIL = KFAIL + 1 + END IF + RCOND = ZERO + GO TO 60 + ELSE IF (N.EQ.0) THEN +* If N = 0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API we need to pass this case + WRITE( NOUT, FMT = 9982 ) 'PZPOTRF' + KPASS = KPASS + 1 RCOND = ZERO GO TO 60 END IF @@ -492,6 +527,13 @@ PROGRAM PZLLTDRIVER CALL DESCINIT( DESCB, N, NRHS, NB, NBRHS, 0, 0, $ ICTXT, MAX( 1, NP )+IMIDPAD, $ IERR( 1 ) ) +* If NRHS < 0 in LLT.dat file then +* DESCINIT API sets IERR( 1 ) = -3 + IF (NRHS.LT.0 .AND. IERR( 1 ).EQ.-3 ) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9984 ) 'NRHS' + END IF * * move IPW to allow room for RHS * @@ -598,6 +640,23 @@ PROGRAM PZLLTDRIVER * CALL SLTIMER( 2 ) * + IF( INFO.NE.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = * ) 'PZPOTRS INFO=', INFO +* If NRHS < 0 in LLT.dat file then +* PZPOTRS API sets INFO = -3 + IF( NRHS.LT.0 .AND. INFO.EQ.-3 ) THEN +* If PZPOTRS is returning correct error code then +* we need to pass this case + WRITE( NOUT, FMT = 9983 ) 'PZPOTRS' + KPASS = KPASS + 1 + ELSE +* For other error code we will mark test case as fail + KFAIL = KFAIL + 1 + END IF + GO TO 60 + END IF + IF( CHECK ) THEN * * check for memory overwrite @@ -918,6 +977,11 @@ PROGRAM PZLLTDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - ', A4, '|| / (||A|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Ax-b||/(||x||*||A||*eps*N) ', F25.7 ) + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, we will handle this case from ', + $ 'ScaLAPACK API.') + 9983 FORMAT( A, ' returned correct error code. Passing this case.') + 9982 FORMAT( 'This is safe exit from ', A, ' API. Passing this case.') * STOP * diff --git a/TESTING/LIN/pzlsdriver.f b/TESTING/LIN/pzlsdriver.f index 6193ac72..7a297522 100644 --- a/TESTING/LIN/pzlsdriver.f +++ b/TESTING/LIN/pzlsdriver.f @@ -4,6 +4,7 @@ PROGRAM PZLSDRIVER * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * August 14, 2001 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======= @@ -60,6 +61,7 @@ PROGRAM PZLSDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, $ LLD_, MB_, M_, NB_, N_, RSRC_ @@ -133,6 +135,16 @@ PROGRAM PZLSDRIVER DATA KTESTS, KPASS, KFAIL, KSKIP / 4*0 / * .. * .. Executable Statements .. +* +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X + * * Get starting information * @@ -148,6 +160,35 @@ PROGRAM PZLSDRIVER $ NNBR, NBRVAL, NTESTS, NGRIDS, PVAL, NTESTS, QVAL, $ NTESTS, THRESH, MEM, IAM, NPROCS ) CHECK = ( THRESH.GE.0.0E+0 ) + +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do * * Print headings * @@ -194,6 +235,7 @@ PROGRAM PZLSDRIVER CALL BLACS_GET( -1, 0, ICTXT ) CALL BLACS_GRIDINIT( ICTXT, 'Row-major', NPROW, NPCOL ) CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL ) + * * Go to bottom of loop if this case doesn't use my process * @@ -208,15 +250,17 @@ PROGRAM PZLSDRIVER * Make sure matrix information is correct * IERR( 1 ) = 0 - IF( M.LT.1 ) THEN +#ifdef ENABLE_DRIVER_CHECK + IF( M.LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'M', M IERR( 1 ) = 1 - ELSE IF( N.LT.1 ) THEN + ELSE IF( N.LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Make sure no one had error * @@ -272,6 +316,7 @@ PROGRAM PZLSDRIVER IMIDPAD = 0 IPOSTPAD = 0 END IF + * * Initialize the array descriptor for the matrix A * @@ -282,12 +327,34 @@ PROGRAM PZLSDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 70 END IF +#else +* If M < 0, DESCINIT API sets IERR( 1 ) = -2 +* If N < 0, DESCINIT API sets IERR( 1 ) = -3 +* When M/N < 0, LDA is Negative, DESCINIT IERR( 1 ) = -8 + IF( M.LT.0 .AND. (IERR( 1 ).EQ.-2 .OR. + $ IERR( 1 ).EQ. -8 .OR. IERR(1).EQ.-12 )) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9985 ) 'M' + ELSE IF (N.LT.0 .AND. (IERR( 1 ).EQ.-3 .OR. + $ IERR( 1 ).EQ. -8 .OR. IERR(1).EQ.-12 )) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9985 ) 'N' + ELSE IF( IERR( 1 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 70 + END IF +#endif * DO 60 ISCALE = 1, 3 * @@ -324,7 +391,7 @@ PROGRAM PZLSDRIVER GO TO 70 END IF * - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. N.GT.0 ) THEN CALL PZFILLPAD( ICTXT, MP, NQ, MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, $ PADVAL ) @@ -336,10 +403,12 @@ PROGRAM PZLSDRIVER * * Generate the matrix A and calculate its 1-norm * - CALL PZQRT13( ISCALE, M, N, MEM( IPA ), 1, 1, + IF( M.GT.0 .AND. N.GT.0 ) THEN + CALL PZQRT13( ISCALE, M, N, MEM( IPA ), 1, 1, $ DESCA, ANORM, IASEED, MEM( IPW ) ) + END IF * - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. N.GT.0 ) THEN CALL PZCHEKPAD( ICTXT, 'PZQRT13', MP, NQ, $ MEM( IPA-IPREPAD ), DESCA( LLD_ ), $ IPREPAD, IPOSTPAD, PADVAL ) @@ -400,12 +469,41 @@ PROGRAM PZLSDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 2, 1, IERR, $ 2, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 .OR. IERR( 2 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else + IF (NRHS.LT.0 .AND. (IERR( 1 ).EQ.-3 .OR. + $ IERR(1) .EQ. -12)) THEN +* If DESCINIT is returns correct error code then +* do nothing + WRITE( NOUT, FMT = 9985 ) 'NRHS' + ELSE IF (N.LT.0 .AND. (IERR( 1 ).EQ.-2 .OR. + $ IERR( 1 ).EQ. -8 .OR. + $ IERR( 2 ).EQ.-2 .OR. + $ IERR( 2 ).EQ. -8) ) THEN +* If DESCINIT is returns correct error code then +* do nothing + WRITE( NOUT, FMT = 9985 ) 'N' + ELSE IF (M.LT.0 .AND. (IERR( 1 ).EQ.-2 .OR. + $ IERR( 1 ).EQ. -8 .OR. + $ IERR( 2 ).EQ. -2 .OR. + $ IERR( 2 ).EQ. -8)) THEN +* If DESCINIT is returns correct error code then +* do nothing + WRITE( NOUT, FMT = 9985 ) 'M' + ELSE IF( IERR( 1 ).LT.0 .OR. + $ IERR( 2 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif * * Check for enough memory * @@ -437,8 +535,10 @@ PROGRAM PZLSDRIVER * * Generate RHS * - IF( TPSD ) THEN - CALL PZMATGEN( ICTXT, 'No', 'No', + IF (M.GT.0 .AND. N.GT.0 .AND. + $ NRHS.GT.0) THEN + IF( TPSD) THEN + CALL PZMATGEN( ICTXT, 'No', 'No', $ DESCW( M_ ), DESCW( N_ ), $ DESCW( MB_ ), DESCW( NB_ ), $ MEM( IPW ), DESCW( LLD_ ), @@ -446,8 +546,8 @@ PROGRAM PZLSDRIVER $ DESCW( CSRC_ ), IBSEED, 0, $ MP, 0, NRHSQ, MYROW, MYCOL, $ NPROW, NPCOL ) - ELSE - CALL PZMATGEN( ICTXT, 'No', 'No', + ELSE + CALL PZMATGEN( ICTXT, 'No', 'No', $ DESCW( M_ ), DESCW( N_ ), $ DESCW( MB_ ), DESCW( NB_ ), $ MEM( IPW ), DESCW( LLD_ ), @@ -455,9 +555,10 @@ PROGRAM PZLSDRIVER $ DESCW( CSRC_ ), IBSEED, 0, $ NP, 0, NRHSQ, MYROW, MYCOL, $ NPROW, NPCOL ) + END IF END IF -* - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. N.GT.0 .AND. + $ NRHS.GT.0) THEN CALL PZFILLPAD( ICTXT, MNP, NRHSQ, $ MEM( IPX-IPREPAD ), $ DESCX( LLD_ ), IPREPAD, @@ -474,22 +575,29 @@ PROGRAM PZLSDRIVER $ IPOSTPAD, PADVAL ) END IF END IF -* - DO 10 JJ = 1, NRHS - CALL PDZNRM2( NCOLS, BNORM, MEM( IPW ), + IF( M.GT.0 .AND. N.GT.0 .AND. + $ NRHS.GT.0 ) THEN + DO 10 JJ = 1, NRHS + CALL PDZNRM2( NCOLS, BNORM, MEM( IPW ), $ 1, JJ, DESCW, 1 ) - IF( BNORM.GT.RZERO ) - $ CALL PZDSCAL( NCOLS, RONE / BNORM, - $ MEM( IPW ), 1, JJ, DESCW, - $ 1 ) - 10 CONTINUE + IF( BNORM.GT.RZERO ) + $ CALL PZDSCAL( NCOLS, RONE / BNORM, + $ MEM( IPW ), 1, JJ, + $ DESCW, 1 ) + 10 CONTINUE + END IF * - CALL PZGEMM( TRANS, 'N', NROWS, NRHS, NCOLS, + IF (M.GE.0 .AND. N.GE.0 .AND. + $ NRHS.GE.0) THEN + CALL PZGEMM( TRANS, 'N', NROWS, + $ NRHS, NCOLS, $ ONE, MEM( IPA ), 1, 1, DESCA, $ MEM( IPW ), 1, 1, DESCW, ZERO, $ MEM( IPX ), 1, 1, DESCX ) + END IF * - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. N.GT.0 .AND. + $ NRHS.GT.0 ) THEN * * check for memory overwrite * @@ -540,8 +648,8 @@ PROGRAM PZLSDRIVER IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) $ 'descriptor' - KSKIP = KSKIP + 1 - GO TO 30 + KSKIP = KSKIP + 1 + GO TO 30 END IF * IPW = IPB + DESCB( LLD_ )*NRHSQ + @@ -594,7 +702,8 @@ PROGRAM PZLSDRIVER GO TO 30 END IF * - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. N.GT.0 .AND. + $ NRHS .GT.0 ) THEN * * Make the copy of the right hand side * @@ -631,7 +740,14 @@ PROGRAM PZLSDRIVER * CALL SLTIMER( 1 ) * - IF( CHECK ) THEN + IF( (N .EQ. 0 .OR. M.EQ.0 .OR. + $ NRHS .EQ. 0 ) .AND. INF0.EQ.0) THEN +* If M = 0 or N =0 this is the case of +* safe exit, early return from ScaLAPACK API. + WRITE( NOUT, FMT = 9983 ) 'PZGELS' + END IF + IF( CHECK .AND. M.GT.0 .AND. + $ N.GT.0 .AND. NRHS.GT.0 ) THEN * * check for memory overwrite * @@ -651,14 +767,20 @@ PROGRAM PZLSDRIVER * * Regenerate A in place for testing and next * iteration + + IF(M.GT.0 .AND. N.GT.0 .AND. NRHS.GT.0) THEN * - CALL PZQRT13( ISCALE, M, N, MEM( IPA ), 1, 1, - $ DESCA, ANORM, IASEED, + CALL PZQRT13( ISCALE, M, N, MEM( IPA ), + $ 1, 1, DESCA, ANORM, IASEED, $ MEM( IPW ) ) + + END IF * * check the solution to rhs * - IF( CHECK ) THEN + IF( CHECK .AND. M.GT.0 .AND. + $ N.GT.0 .AND. NRHS.GT.0 .AND. + $ .NOT.(EX_FLAG) ) THEN * * Am I going to call PZQRT17 ? * @@ -842,7 +964,9 @@ PROGRAM PZLSDRIVER * Call PZQRT14 * IF( ( M.GE.N .AND. TPSD ) .OR. - $ ( M.LT.N .AND. ( .NOT.TPSD ) ) ) THEN + $ ( M.LT.N .AND. (.NOT.TPSD) ) .AND. + $ ( M.GT.0 .AND. N.GT.0 .AND. + $ NRHS.GT.0 ) ) THEN * IPW = IPB * @@ -933,9 +1057,17 @@ PROGRAM PZLSDRIVER * did not pass the threshold. * PASSED = 'PASSED' - DO 20 II = 1, 2 + IF((M.EQ.0 .OR. N.EQ.0 .OR. + $ NRHS .EQ. 0) .AND. INF0 .EQ. 0) THEN +* If M = 0, N =0, NRHS =0 this is the case of +* early return from ScaLAPACK API. +* Pass this case + KPASS = KPASS + 1 + SRESID = SRESID - SRESID + ELSE + DO 20 II = 1, 2 IF( ( RESULT( II ).GE.THRESH ) .AND. - $ ( RESULT( II )-RESULT( II ).EQ.0.0E+0 + $ (RESULT( II )-RESULT( II ).EQ.0.0E+0 $ ) ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9986 )TRANS, @@ -946,16 +1078,75 @@ PROGRAM PZLSDRIVER ELSE KPASS = KPASS + 1 END IF - 20 CONTINUE + 20 CONTINUE + END IF * ELSE * -* By-pass the solve check -* - KPASS = KPASS + 1 - SRESID = SRESID - SRESID - PASSED = 'BYPASS' -* + IF((M.EQ.0 .OR. N.EQ.0 .OR. + $ NRHS .EQ. 0) .AND. INF0 .EQ. 0) THEN +* If M = 0, N =0, NRHS =0 this is the case of +* early return from ScaLAPACK API. +* Pass this case + KPASS = KPASS + 1 + SRESID = SRESID - SRESID + PASSED = 'PASSED' +* +* When N < 0, PZGELS returns INF0 = -2 +* When M < 0, PZGELS returns INF0 = -3 +* When NRHS < 0, PZGELS returns INF0 = -4 +* + ELSE IF( (M .LT. 0 .AND. + $ INFO .EQ. -2 ) .OR. + $ (N .LT. 0 .AND. + $ INFO .EQ. -3 ) .OR. + $ (NRHS .LT. 0 .AND. + $ (INFO.EQ. -14 .OR. + $ INFO.EQ. -4 ))) THEN +* +* If PZGELS returns correct error code +* pass this case + WRITE( NOUT, FMT = 9984 ) 'PZGELS' + KPASS = KPASS + 1 + SRESID = SRESID - SRESID + PASSED = 'PASSED' +* Extreme value validation check + ELSE IF( EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, M + DO JK = 1, N + X = MEM(IK*N + JK) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF + ELSE + KPASS = KPASS + 1 + SRESID = SRESID - SRESID + PASSED = 'BYPASS' + + END IF END IF * * Gather maximum of all CPU and WALL clock @@ -1084,6 +1275,12 @@ PROGRAM PZLSDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( ' TRANS=''', A1, ''', M=', I5, ', N=', I5, ', NRHS=', I4, $ ', NB=', I4, ', type', I2, ', test(', I2, ')=', G12.5 ) + 9985 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handeld by', + $ 'the PZGELS API.') + 9984 FORMAT( A, ' returned correct error code. Passing this case.') + 9983 FORMAT( 'Early return case. Safe exit from ', A, ' API' + $ ' Passing this case.') * STOP * diff --git a/TESTING/LIN/pzludriver.f b/TESTING/LIN/pzludriver.f index 486fb0be..b611a2cc 100644 --- a/TESTING/LIN/pzludriver.f +++ b/TESTING/LIN/pzludriver.f @@ -4,6 +4,7 @@ PROGRAM PZLUDRIVER * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======== @@ -66,6 +67,7 @@ PROGRAM PZLUDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, $ LLD_, MB_, M_, NB_, N_, RSRC_ @@ -145,6 +147,15 @@ PROGRAM PZLUDRIVER * .. * .. Executable Statements .. * +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X +* * Get starting information * #ifdef DYNAMIC_WORK_MEM_ALLOC @@ -158,6 +169,35 @@ PROGRAM PZLUDRIVER $ NTESTS, NGRIDS, PVAL, NTESTS, QVAL, NTESTS, THRESH, $ EST, MEM, IAM, NPROCS ) CHECK = ( THRESH.GE.0.0E+0 ) + +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do * * Print headings * @@ -218,6 +258,7 @@ PROGRAM PZLUDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR( 1 ) = 0 IF( M.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -228,6 +269,7 @@ PROGRAM PZLUDRIVER $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Check all processes for an error * @@ -288,12 +330,31 @@ PROGRAM PZLUDRIVER * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 30 END IF +#else +* If M < 0 in LU.dat file then DESCINIT API sets IERR( 1 ) = -2 +* If N < 0 in LU.dat file then DESCINIT API sets IERR( 1 ) = -3 + IF( M.LT.0 .AND. IERR( 1 ).EQ.-2 ) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9984 ) 'M' + ELSE IF (N.LT.0 .AND. IERR( 1 ).EQ.-3 ) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9984 ) 'N' + ELSE IF( IERR( 1 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 30 + END IF +#endif * * Assign pointers into MEM for SCALAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -409,12 +470,36 @@ PROGRAM PZLUDRIVER IF( INFO.NE.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = * ) 'PZGETRF INFO=', INFO - KFAIL = KFAIL + 1 +* If M < 0 in LU.dat file then PZGETRF API sets INFO = -1 +* If N < 0 in LU.dat file then PZGETRF API sets INFO = -2 + IF ((M.LT.0 .AND. INFO.EQ.-1) .OR. + $ (N.LT.0 .AND. INFO.EQ.-2)) THEN +* If PZGETRF is returning correct error +* code we need to pass this case + WRITE( NOUT, FMT = 9983 ) 'PZGETRF' + KPASS = KPASS + 1 + RCOND = ZERO + GO TO 30 + ELSE IF (INFO.GT.0 .AND. EX_FLAG) THEN + WRITE(*,*) 'PZGETRF INFO=', INFO +* do nothing, skip residual calculation + ELSE +* For other error code we will mark test case as fail + KFAIL = KFAIL + 1 + RCOND = ZERO + GO TO 30 + END IF + ELSE IF (M.EQ.0 .OR. N.EQ.0) THEN +* If M = 0 or N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API we need to pass this case + WRITE( NOUT, FMT = 9982 ) 'PZGETRF' + KPASS = KPASS + 1 RCOND = ZERO GO TO 30 END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN * * Check for memory overwrite in LU factorization * @@ -433,7 +518,7 @@ PROGRAM PZLUDRIVER NRHS = 0 NBRHS = 0 * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN * * Compute FRESID = ||A - P*L*U|| / (||A|| * N * eps) * @@ -472,11 +557,43 @@ PROGRAM PZLUDRIVER * ELSE * -* Don't perform the checking, only timing -* - KPASS = KPASS + 1 - FRESID = FRESID - FRESID - PASSED = 'BYPASS' +* Extreme-value validation check + IF( EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, M + DO JK = 1, N + X = MEM(IK*N + JK) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF + ELSE +* Don't perform the checking, only timing + FRESID = FRESID - FRESID + KPASS = KPASS + 1 + PASSED = 'BYPASS' + END IF * END IF * @@ -571,7 +688,7 @@ PROGRAM PZLUDRIVER GO TO 30 END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN CALL PZFILLPAD( ICTXT, LWORK, 1, $ MEM( IPW-IPREPAD ), LWORK, $ IPREPAD, IPOSTPAD, PADVAL ) @@ -587,7 +704,7 @@ PROGRAM PZLUDRIVER $ ANORM1, RCOND, MEM( IPW ), LWORK, $ MEM( IPW2 ), LRWORK, INFO ) * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG)) THEN CALL PZCHEKPAD( ICTXT, 'PZGECON', NP, NQ, $ MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, @@ -624,12 +741,26 @@ PROGRAM PZLUDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, $ -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 10 END IF +#else +* If NRHS < 0 in LU.dat file then DESCINIT API sets IERR( 1 ) = -3 + IF (NRHS.LT.0 .AND. IERR( 1 ).EQ.-3 ) THEN +* If DESCINIT is returning correct error code then +* do nothing + WRITE( NOUT, FMT = 9984 ) 'NRHS' + ELSE IF( IERR( 1 ).LT.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF +#endif * * move IPW to allow room for RHS * @@ -695,7 +826,7 @@ PROGRAM PZLUDRIVER $ MYRHS, MYROW, MYCOL, NPROW, $ NPCOL ) * - IF( CHECK ) + IF( CHECK .AND. .NOT.(EX_FLAG) ) $ CALL PZFILLPAD( ICTXT, NP, MYRHS, $ MEM( IPB-IPREPAD ), $ DESCB( LLD_ ), IPREPAD, @@ -710,7 +841,7 @@ PROGRAM PZLUDRIVER $ DESCB( CSRC_ ), IBSEED, 0, NP, $ 0, MYRHS, MYROW, MYCOL, NPROW, $ NPCOL ) - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN CALL PZFILLPAD( ICTXT, NP, MYRHS, $ MEM( IPB0-IPREPAD ), $ DESCB( LLD_ ), IPREPAD, @@ -737,7 +868,26 @@ PROGRAM PZLUDRIVER * CALL SLTIMER( 2 ) * - IF( CHECK ) THEN + IF( INFO.NE.0 ) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = * ) 'PZGETRS INFO=', INFO +* If NRHS < 0 in LU.dat file then PZGETRS API sets INFO = -3 + IF( NRHS.LT.0 .AND. INFO.EQ.-3 ) THEN +* If PZGETRS is returning correct error code we need to pass this case + WRITE( NOUT, FMT = 9983 ) 'PZGETRS' + KPASS = KPASS + 1 + GO TO 30 + ELSE IF( INFO .GT. 0 .AND. EX_FLAG) THEN + WRITE(*,*) 'PZGETRS INFO=', INFO +* Do Nothing, Pass this case in residual calculation + ELSE +* For other error code we will mark test case as fail + KFAIL = KFAIL + 1 + GO TO 30 + END IF + END IF +* + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN * * check for memory overwrite * @@ -791,9 +941,42 @@ PROGRAM PZLUDRIVER PASSED = 'FAILED' END IF ELSE - KPASS = KPASS + 1 - SRESID = SRESID - SRESID - PASSED = 'BYPASS' +* Extreme value validation check + IF( EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, M + DO JK = 1, N + X = MEM(IK*N + JK) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF + ELSE + SRESID = SRESID - SRESID + KPASS = KPASS + 1 + PASSED = 'BYPASS' + END IF END IF * IF( EST ) THEN @@ -827,7 +1010,7 @@ PROGRAM PZLUDRIVER GO TO 10 END IF * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN CALL PZFILLPAD( ICTXT, LWORK, 1, $ MEM( IPW-IPREPAD ), $ LWORK, IPREPAD, IPOSTPAD, @@ -850,7 +1033,7 @@ PROGRAM PZLUDRIVER $ MEM( IPW ), LWORK, MEM( IPW2 ), $ LRWORK, INFO ) * - IF( CHECK ) THEN + IF( CHECK .AND. .NOT.(EX_FLAG) ) THEN CALL PZCHEKPAD( ICTXT, 'PZGERFS', NP, $ NQ, MEM( IPA0-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, @@ -983,7 +1166,8 @@ PROGRAM PZLUDRIVER 10 CONTINUE 20 END DO * - IF( CHECK.AND.( SRESID.GT.THRESH ) ) THEN + IF( CHECK.AND.( SRESID.GT.THRESH ) .AND. + $ .NOT.(EX_FLAG) ) THEN * * Compute fresid = ||A - P*L*U|| / (||A|| * N * eps) * @@ -1063,6 +1247,11 @@ PROGRAM PZLUDRIVER 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( '||A - P*L*U|| / (||A|| * N * eps) = ', G25.7 ) 9985 FORMAT( '||Ax-b||/(||x||*||A||*eps*N) ', F25.7 ) + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, we will handle this case from ', + $ 'ScaLAPACK API.') + 9983 FORMAT( A, ' returned correct error code. Passing this case.') + 9982 FORMAT( 'This is safe exit from ', A, ' API. Passing this case.') * STOP * diff --git a/TESTING/LIN/pzmatgen.f b/TESTING/LIN/pzmatgen.f index f4ee5ab0..08631896 100644 --- a/TESTING/LIN/pzmatgen.f +++ b/TESTING/LIN/pzmatgen.f @@ -6,6 +6,7 @@ SUBROUTINE PZMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 1, 1997 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * .. Scalar Arguments .. CHARACTER*1 AFORM, DIAG @@ -119,7 +120,7 @@ SUBROUTINE PZMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 ) * .. * .. Local Scalars .. - LOGICAL SYMM, HERM, TRAN + LOGICAL SYMM, HERM, TRAN, EXT_FLAG INTEGER I, IC, IK, INFO, IOFFC, IOFFR, IR, J, JK, $ JUMP1, JUMP2, JUMP3, JUMP4, JUMP5, JUMP6, $ JUMP7, MAXMN, MEND, MOFF, MP, MRCOL, MRROW, @@ -142,8 +143,15 @@ SUBROUTINE PZMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * .. External Functions .. LOGICAL LSAME INTEGER ICEIL, NUMROC + INTEGER CNT1, CNT2, CNT, TOT_CNT, DIV_FACTOR, REGION DOUBLE PRECISION PDRAND EXTERNAL ICEIL, NUMROC, LSAME, PDRAND +* + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .false. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 * .. * .. Executable Statements .. * @@ -154,6 +162,64 @@ SUBROUTINE PZMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, SYMM = LSAME( AFORM, 'S' ) HERM = LSAME( AFORM, 'H' ) TRAN = LSAME( AFORM, 'T' ) + EXT_FLAG = .FALSE. + +* Take command-line arguments if requested +* + +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EXT_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EXT_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do + + IF ( INF_PERCENT + NAN_PERCENT > 100) THEN + print *,"Sum of INF and NaN is", INF_PERCENT+NAN_PERCENT,"%" + help_flag = .true. + END IF + IF ( INF_PERCENT < 0 .OR. NAN_PERCENT < 0) THEN + print *, "Negative INF / NaN value is not allowed" + help_flag = .true. + END IF + +* Display help message if requested + IF (help_flag .AND. IAM.EQ.0) THEN + print *, "" + print *, "Options:" + print *, " -h, --help Display this help message" + print *, " -inf INF percentage in input", + $ " matrix (default: 0 %)" + print *, " -nan NaN percentage in input", + $ " matrix (default: 0 %)" + print *, "" + print *, " Note: INF + NaN values in input matrix", + $ " should be in the range of 0-100 %" + print *, "" + stop + END IF * INFO = 0 IF( .NOT.LSAME( DIAG, 'D' ) .AND. @@ -213,9 +279,47 @@ SUBROUTINE PZMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, JSEED(1) = ISEED JSEED(2) = 0 * +* Extreme-value parameter calculations + IF( LSAME( DIAG, 'D' ) ) THEN + DIV_FACTOR = 2 + ELSE + DIV_FACTOR = 4 + END IF +* Find type of matrix to identify where to fill INF/NAN, +* If UPPER_TRIANGULAR_MATRIX., start above DIAG + IF( LSAME(AFORM, 'U' ) ) THEN + REGION = (IRNUM * ICNUM)/DIV_FACTOR +* If LOWER_TRIANGULAR/GENERAL MATRIX, start at beginning + ELSE + REGION = 1 + END IF + IF (EXT_FLAG) THEN + CNT = 0 + ZERO1 = 0.0D+0 + ONE1 = 1.0D+0 +* Calculate the number of NANs/INFs per grid + CNT1 = (IRNUM * ICNUM * NAN_PERCENT)/100 + CNT2 = (IRNUM * ICNUM * INF_PERCENT)/100 + CNT1 = CEILING(REAL(CNT1)) + CNT2 = CEILING(REAL(CNT2)) +* When Percentage requested by the user is low +* Replace atleast one element with NAN/INF +* Applicable for smaller matrices [2x2] + IF(NAN_PERCENT .GT. 0 .AND. CNT1 .EQ. 0 ) THEN + CNT1 = CNT1 + 1 + PRINT *, 'NAN Percentage is too low,', + $ 'Including one NAN element' + END IF + IF(INF_PERCENT .GT. 0 .AND. CNT2 .EQ. 0 ) THEN + CNT2 = CNT2 + 1 + PRINT *, 'INF Percentage is too low,', + $ 'Including one INF element' + END IF + END IF +* * Symmetric or Hermitian matrix will be generated. * - IF( SYMM.OR.HERM ) THEN + IF( (SYMM.OR.HERM) .AND. .NOT.(EXT_FLAG) ) THEN * * First, generate the lower triangular part (with diagonal block) * @@ -397,7 +501,8 @@ SUBROUTINE PZMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * * (Conjugate) Transposed matrix A will be generated. * - ELSE IF( TRAN .OR. LSAME( AFORM, 'C' ) ) THEN + ELSE IF(( TRAN .OR. LSAME( AFORM, 'C' )) .AND. + $ .NOT.(EXT_FLAG) ) THEN * JUMP1 = 1 JUMP2 = 2*NQNB @@ -470,6 +575,9 @@ SUBROUTINE PZMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, * A random matrix is generated. * ELSE + + TOT_CNT = 0 + CNT = 0 * JUMP1 = 1 JUMP2 = 2*NPMB @@ -506,8 +614,21 @@ SUBROUTINE PZMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, IOFFR = ((IR-1)*NPROW+MRROW) * MB DO 250 J = 1, MB IF( IK .GT. IRNUM ) GO TO 270 - A(IK,JK) = DCMPLX( ONE - TWO*PDRAND(0), +* Replace with NANs/INFs for extreme values + IF(EXT_FLAG .AND. CNT .LE. (CNT1 + CNT2) .AND. + $ TOT_CNT .GE. REGION) THEN + IF ( CNT .LT. CNT1) THEN + A(IK, JK) = DCMPLX(ZERO1/ZERO1,ZERO1/ZERO1) + ELSE IF ( CNT .LT. (CNT1 + CNT2)) THEN + A(IK, JK) = DCMPLX(ONE1/ZERO1, ONE1/ZERO1) + END IF + CNT = CNT + 1 + TOT_CNT = TOT_CNT + 1 + ELSE + A(IK,JK) = DCMPLX( ONE - TWO*PDRAND(0), $ ONE - TWO*PDRAND(0) ) + TOT_CNT = TOT_CNT + 1 + END IF IK = IK + 1 250 CONTINUE CALL JUMPIT( IA2, IC2, IB1, IRAN2 ) @@ -544,6 +665,8 @@ SUBROUTINE PZMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, RETURN END IF * + TOT_CNT = 0 + CNT = 0 MAXMN = MAX(M, N) JK = 1 DO 340 IC = NOFF+1, NEND @@ -554,12 +677,23 @@ SUBROUTINE PZMATGEN( ICTXT, AFORM, DIAG, M, N, MB, NB, A, LDA, IF( IOFFC.EQ.IOFFR ) THEN DO 310 J = 0, MB-1 IF( IK .GT. IRNUM ) GO TO 330 - IF( HERM ) THEN + IF(EXT_FLAG .AND. CNT .LE. (CNT1 + CNT2) + $ .AND. TOT_CNT .GT. (N/2) ) THEN + IF ( CNT .LT. CNT1) THEN + A(IK, JK+J) = DCMPLX(ZERO1/ZERO1,ZERO1/ZERO1) + ELSE IF ( CNT .LT. (CNT1 + CNT2)) THEN + A(IK, JK+J) = DCMPLX(ONE1/ZERO1, ONE1/ZERO1) + END IF + CNT = CNT + 1 + TOT_CNT = TOT_CNT + 1 + ELSE IF( HERM ) THEN A(IK,JK+J) = DCMPLX( - $ ABS(DBLE(A(IK,JK+J)))+2*MAXMN, ZERO ) + $ ABS(REAL(A(IK,JK+J)))+2*MAXMN, ZERO) + TOT_CNT = TOT_CNT + 1 ELSE A(IK,JK+J)= DCMPLX( ABS(DBLE(A(IK,JK+J)))+MAXMN, $ ABS(DIMAG(A(IK,JK+J)))+ MAXMN ) + TOT_CNT = TOT_CNT + 1 END IF IK = IK + 1 310 CONTINUE diff --git a/TESTING/LIN/pzqrdriver.f b/TESTING/LIN/pzqrdriver.f index 48a151cd..d5d49d85 100644 --- a/TESTING/LIN/pzqrdriver.f +++ b/TESTING/LIN/pzqrdriver.f @@ -4,6 +4,7 @@ PROGRAM PZQRDRIVER * University of Tennessee, Knoxville, Oak Ridge National Laboratory, * and University of California, Berkeley. * May 28, 2001 +* Modifications Copyright (c) 2024 Advanced Micro Devices, Inc. All rights reserved. * * Purpose * ======= @@ -64,6 +65,7 @@ PROGRAM PZQRDRIVER * * ===================================================================== * + use,intrinsic :: ieee_arithmetic * .. Parameters .. INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_, $ LLD_, MB_, M_, NB_, N_, RSRC_ @@ -97,6 +99,7 @@ PROGRAM PZQRDRIVER CHARACTER*8 ROUTCHK CHARACTER*80 OUTFILE LOGICAL CHECK + LOGICAL M_INVALID, N_INVALID INTEGER I, IAM, IASEED, ICTXT, IMIDPAD, INFO, IPA, $ IPOSTPAD, IPPIV, IPREPAD, IPTAU, IPRW, IPW, J, $ K, KFAIL, KPASS, KSKIP, KTESTS, L, LIPIV, @@ -106,6 +109,7 @@ PROGRAM PZQRDRIVER $ WORKFCT, WORKRFCT, WORKSIZ REAL THRESH DOUBLE PRECISION ANORM, FRESID, NOPS, TMFLOPS + CHARACTER*8 API_NAME * .. * .. Arrays .. CHARACTER*2 FACTOR( NTESTS ) @@ -141,6 +145,16 @@ PROGRAM PZQRDRIVER * .. * .. Data Statements .. DATA KTESTS, KPASS, KFAIL, KSKIP /4*0/ +* +* Take command-line arguments if requested + CHARACTER*80 arg + INTEGER numArgs, count + LOGICAL :: help_flag = .FALSE. + LOGICAL :: EX_FLAG = .FALSE., RES_FLAG = .FALSE. + INTEGER :: INF_PERCENT = 0 + INTEGER :: NAN_PERCENT = 0 + DOUBLE PRECISION :: X +* * .. * .. Executable Statements .. * @@ -156,6 +170,37 @@ PROGRAM PZQRDRIVER $ NTESTS, NGRIDS, PVAL, NTESTS, QVAL, NTESTS, $ THRESH, MEM, IAM, NPROCS ) CHECK = ( THRESH.GE.0.0E+0 ) + M_INVALID = .TRUE. + N_INVALID = .TRUE. +* Get the number of command-line arguments + numArgs = command_argument_count() + +* Process command-line arguments + do count = 1, numArgs, 2 + call get_command_argument(count, arg) + select case (arg) + case ("-h", "--help") + help_flag = .true. + exit + case ("-inf") + call get_command_argument(count + 1, arg) + read(arg, *) INF_PERCENT + IF (INF_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case ("-nan") + call get_command_argument(count + 1, arg) + read(arg, *) NAN_PERCENT + IF (NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + case default + print *, "Invalid option: ", arg + help_flag = .true. + exit + end select + end do +* * * Loop over the different factorization types * @@ -253,6 +298,7 @@ PROGRAM PZQRDRIVER * * Make sure matrix information is correct * +#ifdef ENABLE_DRIVER_CHECK IERR(1) = 0 IF( M.LT.1 ) THEN IF( IAM.EQ.0 ) @@ -263,17 +309,20 @@ PROGRAM PZQRDRIVER $ WRITE( NOUT, FMT = 9999 ) 'MATRIX', 'N', N IERR( 1 ) = 1 END IF +#endif * * Make sure no one had error * CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).GT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'matrix' KSKIP = KSKIP + 1 GO TO 20 END IF +#endif * * Loop over different blocking sizes * @@ -350,12 +399,41 @@ PROGRAM PZQRDRIVER CALL IGSUM2D( ICTXT, 'All', ' ', 1, 1, IERR, 1, -1, $ 0 ) * +#ifdef ENABLE_DRIVER_CHECK IF( IERR( 1 ).LT.0 ) THEN IF( IAM.EQ.0 ) $ WRITE( NOUT, FMT = 9997 ) 'descriptor' KSKIP = KSKIP + 1 GO TO 10 END IF +#else + IF(N .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 .OR. + $ IERR(1) .EQ. -3 .OR. IERR(1) .EQ. -12 )) THEN +* DESCINIT returns the correct error code, +* -2, -3 incase of invalid M and N +* -4, -8 or -12 incase of incorrect grid info +* MAIN API can be validated. +* Do NOTHING + WRITE( NOUT, FMT = 9984 ) 'N' +* disable extreme value case when N < 0 + EX_FLAG = .FALSE. + ELSE IF(M .LT. 0 .AND. (IERR(1) .EQ. -2 .OR. + $ IERR(1) .EQ. -4 .OR. IERR(1) .EQ. -8 .OR. + $ IERR(1) .EQ. -3 .OR. IERR(1) .EQ. -12 )) THEN + WRITE( NOUT, FMT = 9984 ) 'M' +* disable extreme value case when M < 0 + EX_FLAG = .FALSE. + ELSE IF(M .EQ. 0 .OR. N .EQ. 0) THEN +* disable extreme value case when M < 0 + EX_FLAG = .FALSE. + ELSE IF(IERR(1) .LT. 0) THEN + IF( IAM.EQ.0 ) + $ WRITE( NOUT, FMT = 9997 ) 'descriptor' + KSKIP = KSKIP + 1 + GO TO 10 + END IF +#endif * * Assign pointers into MEM for ScaLAPACK arrays, A is * allocated starting at position MEM( IPREPAD+1 ) @@ -544,7 +622,7 @@ PROGRAM PZQRDRIVER * * Need the Infinity of A for checking * - IF( CHECK ) THEN + IF( CHECK .AND. (N .GT. 0 .AND. M .GT. 0) ) THEN CALL PZFILLPAD( ICTXT, MP, NQ, MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), IPREPAD, IPOSTPAD, $ PADVAL ) @@ -588,30 +666,35 @@ PROGRAM PZQRDRIVER * Perform QR factorizations * IF( LSAMEN( 2, FACT, 'QR' ) ) THEN + API_NAME = 'PZGEQRF' CALL SLTIMER( 1 ) CALL PZGEQRF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPTAU ), MEM( IPW ), LWORK, $ INFO ) CALL SLTIMER( 1 ) ELSE IF( LSAMEN( 2, FACT, 'QL' ) ) THEN + API_NAME = 'PZGEQLF' CALL SLTIMER( 1 ) CALL PZGEQLF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPTAU ), MEM( IPW ), LWORK, $ INFO ) CALL SLTIMER( 1 ) ELSE IF( LSAMEN( 2, FACT, 'LQ' ) ) THEN + API_NAME = 'PZGELQF' CALL SLTIMER( 1 ) CALL PZGELQF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPTAU ), MEM( IPW ), LWORK, $ INFO ) CALL SLTIMER( 1 ) ELSE IF( LSAMEN( 2, FACT, 'RQ' ) ) THEN + API_NAME = 'PZGERQF' CALL SLTIMER( 1 ) CALL PZGERQF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPTAU ), MEM( IPW ), LWORK, $ INFO ) CALL SLTIMER( 1 ) ELSE IF( LSAMEN( 2, FACT, 'QP' ) ) THEN + API_NAME = 'PZGEQPF' CALL SLTIMER( 1 ) CALL PZGEQPF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPPIV ), MEM( IPTAU ), @@ -619,147 +702,232 @@ PROGRAM PZQRDRIVER $ LRWORK, INFO ) CALL SLTIMER( 1 ) ELSE IF( LSAMEN( 2, FACT, 'TZ' ) ) THEN + API_NAME = 'ZDTZRZF' CALL SLTIMER( 1 ) +#ifdef ENABLE_DRIVER_CHECK IF( N.GE.M ) $ CALL PZTZRZF( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPTAU ), MEM( IPW ), LWORK, $ INFO ) +#else + IF( N .LT. M ) THEN + WRITE( NOUT, FMT = 9982 ) + END IF + CALL PZTZRZF( M, N, MEM( IPA ), 1, 1, DESCA, + $ MEM( IPTAU ), MEM( IPW ), LWORK, + $ INFO ) +#endif CALL SLTIMER( 1 ) END IF * - IF( CHECK ) THEN + IF( CHECK .AND. (.NOT.(EX_FLAG)) ) THEN +* + IF(INFO .EQ. 0 .AND. N .GT. 0 .AND. + $ M .GT. 0) THEN * -* Check for memory overwrite in factorization * - CALL PZCHEKPAD( ICTXT, ROUT, MP, NQ, +* Check for memory overwrite in factorization +* + CALL PZCHEKPAD( ICTXT, ROUT, MP, NQ, $ MEM( IPA-IPREPAD ), DESCA( LLD_ ), $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PZCHEKPAD( ICTXT, ROUT, LTAU, 1, + CALL PZCHEKPAD( ICTXT, ROUT, LTAU, 1, $ MEM( IPTAU-IPREPAD ), LTAU, $ IPREPAD, IPOSTPAD, PADVAL ) - IF( LSAMEN( 2, FACT, 'QP' ) ) THEN - CALL PZCHEKPAD( ICTXT, ROUT, LIPIV, 1, + IF( LSAMEN( 2, FACT, 'QP' ) ) THEN + CALL PZCHEKPAD( ICTXT, ROUT, LIPIV, 1, $ MEM( IPPIV-IPREPAD ), LIPIV, $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PZCHEKPAD( ICTXT, ROUT, WORKRFCT-IPOSTPAD, + CALL PZCHEKPAD( ICTXT, ROUT, + $ WORKRFCT-IPOSTPAD, $ 1, MEM( IPRW-IPREPAD ), $ WORKRFCT-IPOSTPAD, $ IPREPAD, IPOSTPAD, PADVAL ) - END IF - CALL PZCHEKPAD( ICTXT, ROUT, WORKFCT-IPOSTPAD, 1, - $ MEM( IPW-IPREPAD ), + END IF + CALL PZCHEKPAD( ICTXT, ROUT, WORKFCT-IPOSTPAD, + $ 1, MEM( IPW-IPREPAD ), $ WORKFCT-IPOSTPAD, IPREPAD, $ IPOSTPAD, PADVAL ) - CALL PZFILLPAD( ICTXT, WORKSIZ-IPOSTPAD, 1, + CALL PZFILLPAD( ICTXT, WORKSIZ-IPOSTPAD, 1, $ MEM( IPW-IPREPAD ), $ WORKSIZ-IPOSTPAD, $ IPREPAD, IPOSTPAD, PADVAL ) * - IF( LSAMEN( 2, FACT, 'QR' ) ) THEN + IF( LSAMEN( 2, FACT, 'QR' ) ) THEN * -* Compute residual = ||A-Q*R|| / (||A||*N*eps) +* Compute residual = ||A-Q*R|| / (||A||*N*eps) * - CALL PZGEQRRV( M, N, MEM( IPA ), 1, 1, DESCA, + CALL PZGEQRRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, $ MEM( IPTAU ), MEM( IPW ) ) - CALL PZLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, + CALL PZLAFCHK( 'No', 'No', M, N, + $ MEM( IPA ), 1, $ 1, DESCA, IASEED, ANORM, FRESID, $ MEM( IPW ) ) - ELSE IF( LSAMEN( 2, FACT, 'QL' ) ) THEN + ELSE IF( LSAMEN( 2, FACT, 'QL' ) ) THEN * -* Compute residual = ||A-Q*L|| / (||A||*N*eps) +* Compute residual = ||A-Q*L|| / (||A||*N*eps) * - CALL PZGEQLRV( M, N, MEM( IPA ), 1, 1, DESCA, + CALL PZGEQLRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, $ MEM( IPTAU ), MEM( IPW ) ) - CALL PZLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, + CALL PZLAFCHK( 'No', 'No', M, N, + $ MEM( IPA ), 1, $ 1, DESCA, IASEED, ANORM, FRESID, $ MEM( IPW ) ) - ELSE IF( LSAMEN( 2, FACT, 'LQ' ) ) THEN + ELSE IF( LSAMEN( 2, FACT, 'LQ' ) ) THEN * -* Compute residual = ||A-L*Q|| / (||A||*N*eps) +* Compute residual = ||A-L*Q|| / (||A||*N*eps) * - CALL PZGELQRV( M, N, MEM( IPA ), 1, 1, DESCA, + CALL PZGELQRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, $ MEM( IPTAU ), MEM( IPW ) ) - CALL PZLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, + CALL PZLAFCHK( 'No', 'No', M, N, + $ MEM( IPA ), 1, $ 1, DESCA, IASEED, ANORM, FRESID, $ MEM( IPW ) ) - ELSE IF( LSAMEN( 2, FACT, 'RQ' ) ) THEN + ELSE IF( LSAMEN( 2, FACT, 'RQ' ) ) THEN * -* Compute residual = ||A-R*Q|| / (||A||*N*eps) +* Compute residual = ||A-R*Q|| / (||A||*N*eps) * - CALL PZGERQRV( M, N, MEM( IPA ), 1, 1, DESCA, + CALL PZGERQRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, $ MEM( IPTAU ), MEM( IPW ) ) - CALL PZLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, + CALL PZLAFCHK( 'No', 'No', M, N, + $ MEM( IPA ), 1, $ 1, DESCA, IASEED, ANORM, FRESID, $ MEM( IPW ) ) - ELSE IF( LSAMEN( 2, FACT, 'QP' ) ) THEN + ELSE IF( LSAMEN( 2, FACT, 'QP' ) ) THEN * -* Compute residual = ||AP-Q*R|| / (||A||*N*eps) +* Compute residual = ||AP-Q*R|| / (||A||*N*eps) * - CALL PZGEQRRV( M, N, MEM( IPA ), 1, 1, DESCA, + CALL PZGEQRRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, $ MEM( IPTAU ), MEM( IPW ) ) - ELSE IF( LSAMEN( 2, FACT, 'TZ' ) ) THEN + ELSE IF( LSAMEN( 2, FACT, 'TZ' ) ) THEN * -* Compute residual = ||A-T*Z|| / (||A||*N*eps) +* Compute residual = ||A-T*Z|| / (||A||*N*eps) * - IF( N.GE.M ) THEN - CALL PZTZRZRV( M, N, MEM( IPA ), 1, 1, DESCA, + IF( N.GE.M ) THEN + CALL PZTZRZRV( M, N, MEM( IPA ), 1, 1, + $ DESCA, $ MEM( IPTAU ), MEM( IPW ) ) - END IF - CALL PZLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, + END IF + CALL PZLAFCHK( 'No', 'No', M, N, + $ MEM( IPA ), 1, $ 1, DESCA, IASEED, ANORM, FRESID, $ MEM( IPW ) ) - END IF + END IF * -* Check for memory overwrite +* Check for memory overwrite * - CALL PZCHEKPAD( ICTXT, ROUTCHK, MP, NQ, + CALL PZCHEKPAD( ICTXT, ROUTCHK, MP, NQ, $ MEM( IPA-IPREPAD ), DESCA( LLD_ ), $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PZCHEKPAD( ICTXT, ROUTCHK, LTAU, 1, + CALL PZCHEKPAD( ICTXT, ROUTCHK, LTAU, 1, $ MEM( IPTAU-IPREPAD ), LTAU, $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PZCHEKPAD( ICTXT, ROUTCHK, WORKSIZ-IPOSTPAD, + CALL PZCHEKPAD( ICTXT, ROUTCHK, + $ WORKSIZ-IPOSTPAD, $ 1, MEM( IPW-IPREPAD ), $ WORKSIZ-IPOSTPAD, IPREPAD, $ IPOSTPAD, PADVAL ) * - IF( LSAMEN( 2, FACT, 'QP' ) ) THEN + IF( LSAMEN( 2, FACT, 'QP' ) ) THEN * - CALL PZQPPIV( M, N, MEM( IPA ), 1, 1, DESCA, + CALL PZQPPIV( M, N, MEM( IPA ), 1, 1, DESCA, $ MEM( IPPIV ) ) * -* Check for memory overwrite +* Check for memory overwrite * - CALL PZCHEKPAD( ICTXT, 'PZQPPIV', MP, NQ, + CALL PZCHEKPAD( ICTXT, 'PZQPPIV', MP, NQ, $ MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PZCHEKPAD( ICTXT, 'PZQPPIV', LIPIV, 1, + CALL PZCHEKPAD( ICTXT, 'PZQPPIV', LIPIV, 1, $ MEM( IPPIV-IPREPAD ), LIPIV, $ IPREPAD, IPOSTPAD, PADVAL ) * - CALL PZLAFCHK( 'No', 'No', M, N, MEM( IPA ), 1, + CALL PZLAFCHK( 'No', 'No', M, N, + $ MEM( IPA ), 1, $ 1, DESCA, IASEED, ANORM, FRESID, $ MEM( IPW ) ) * -* Check for memory overwrite +* Check for memory overwrite * - CALL PZCHEKPAD( ICTXT, 'PZLAFCHK', MP, NQ, + CALL PZCHEKPAD( ICTXT, 'PZLAFCHK', MP, NQ, $ MEM( IPA-IPREPAD ), $ DESCA( LLD_ ), $ IPREPAD, IPOSTPAD, PADVAL ) - CALL PZCHEKPAD( ICTXT, 'PZLAFCHK', + CALL PZCHEKPAD( ICTXT, 'PZLAFCHK', $ WORKSIZ-IPOSTPAD, 1, $ MEM( IPW-IPREPAD ), $ WORKSIZ-IPOSTPAD, IPREPAD, $ IPOSTPAD, PADVAL ) + + END IF END IF * * Test residual and detect NaN result * - IF( LSAMEN( 2, FACT, 'TZ' ) .AND. N.LT.M ) THEN - KSKIP = KSKIP + 1 - PASSED = 'BYPASS' + M_INVALID = M.LT.0 .AND. + $ ((INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'QR')) .OR. + $ (INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'QL')) .OR. + $ (INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'LQ')) .OR. + $ (INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'RQ')) .OR. + $ (INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'QP')) .OR. + $ (INFO.EQ.-1 .AND. + $ LSAMEN( 2, FACT, 'TZ' ))) + N_INVALID = N.LT.0 .AND. + $ ((INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'QR')) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'QL')) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'LQ')) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'RQ')) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'QP')) .OR. + $ (INFO.EQ.-2 .AND. + $ LSAMEN( 2, FACT, 'TZ' ))) +* + IF( (N.EQ.0 .AND. INFO.EQ.0) .OR. + $ (M.EQ.0 .AND. INFO.EQ.0) ) THEN +* If N =0 this is the case of +* early return from ScaLAPACK API. +* If there is safe exit from API; pass this case + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9985 ) KPASS, API_NAME + PASSED = 'PASSED' +* RE-ENABLE for EX CASE + IF(INF_PERCENT .GT. 0 .OR. + $ NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + GO TO 10 + ELSE IF(M_INVALID .OR. N_INVALID) THEN +* When N < 0/Invalid, INFO = -2 +* When M < 0/Invalid, INFO = -1 +* Expected Error code for N < 0 +* Hence this case can be passed + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9983 ) KPASS, API_NAME + PASSED = 'PASSED' +* RE-ENABLE for EX CASE + IF(INF_PERCENT .GT. 0 .OR. + $ NAN_PERCENT .GT. 0) THEN + EX_FLAG = .TRUE. + END IF + ELSE IF( LSAMEN( 2, FACT, 'TZ' ) .AND. + $ (N.LT.M .AND. INFO.EQ.-2 ) ) THEN + KPASS = KPASS + 1 + WRITE( NOUT, FMT = 9983 ) KPASS, API_NAME ELSE IF( FRESID.LE.THRESH .AND. $ (FRESID-FRESID).EQ.0.0D+0 ) THEN @@ -772,12 +940,47 @@ PROGRAM PZQRDRIVER END IF * ELSE + +* Extreme value cases + IF(EX_FLAG) THEN +* Check presence of INF/NAN in output +* Pass the case if present + DO IK = 0, M + DO JK = 1, N+1 + X = MEM(IK*N + JK) + IF (isnan(X)) THEN +* NAN DETECTED + RES_FLAG = .TRUE. + EXIT + ELSE IF (.NOT.ieee_is_finite( + $ X)) THEN +* INFINITY DETECTED + RES_FLAG = .TRUE. + EXIT + END IF + END DO + IF(RES_FLAG) THEN + EXIT + END IF + END DO + IF (.NOT.(RES_FLAG)) THEN + KFAIL = KFAIL + 1 + PASSED = 'FAILED' + ELSE + KPASS = KPASS + 1 + PASSED = 'PASSED' +* RESET RESIDUAL FLAG + RES_FLAG = .FALSE. + END IF + FRESID = FRESID - FRESID * -* Don't perform the checking, only timing -* - KPASS = KPASS + 1 - FRESID = FRESID - FRESID - PASSED = 'BYPASS' +* Don't perform the checking, only the timing +* operation + ELSE + KPASS = KPASS + 1 + FRESID = FRESID - FRESID + PASSED = 'BYPASS' + END IF * END IF * @@ -901,6 +1104,16 @@ PROGRAM PZQRDRIVER 9988 FORMAT( I5, ' tests skipped because of illegal input values.' ) 9987 FORMAT( 'END OF TESTS.' ) 9986 FORMAT( A ) + 9985 FORMAT( '----------Test-',I3,' Passed but no compute was ', + $ 'performed! [Safe exit from ', A,']-----------') + 9984 FORMAT( A, ' < 0 case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the ScaLAPACK API.') + 9983 FORMAT( '----------Negative Test-',I3,' Passed with expected', + $ ' ERROR CODE in INFO from ', A,']-----------') + 9982 FORMAT( ' N < M case detected. ', + $ 'Instead of driver file, This case will be handled', + $ 'by the PCTZRZF API.') * STOP * diff --git a/TESTING/README.txt b/TESTING/README.txt index 6b5e9fe6..8ce962d5 100644 --- a/TESTING/README.txt +++ b/TESTING/README.txt @@ -45,3 +45,53 @@ Address Sanitizer(ASAN) testing: Address saitizer(ASAN) tests are supported through the AOCL-ScaLAPACK test suite. To enable the same, include the build configure option '-DENABLE_ASAN_TESTS=ON'. + +Extended test suite for AOCL-ScaLAPACK: +======================================= + +Extended test suite that includes additional cases such as + + a) Negative inputs. + b) Early reuturn inputs. + c) Extreme value inputs. + +NOTE: Not all testing executable support the extended test suite. + +Running extended test suite: +---------------------------- + +Eg: To test negative inputs and early return inputs. + Upon building the AOCL-ScaLAPACK library, by default '.dat' files + are copied from source TESTING folder to built TESTING folder. + In order to test extended test cases, copy the '.dat' files present + in the folder aocl-scalapack/TESTING/EXT_TESTS to TESTING folder + of the built workspace replacing the existing '.dat' files. + + For instance: + Running a test program: + + $ mpirun -np 4 ./xdinv + +Eg: To test extreme value inputs. + Upon building the AOCL-ScaLAPACK library, to test the infinity or NaN + input values, refer below illustration. + + For instance: + Infinity and NaN input values can be clubbed together or can be + used individually. Percentage of infinity and NaNs can be altered. + + 1)mpirun -np ./ -inf <%_of_inf> + + $ mpirun -np 4 ./xdinv -inf 10 + + 2)mpirun -np ./ -nan <%_of_nan> + + $ mpirun -np 4 ./xdinv -nan 10 + + 3)mpirun -np ./ -inf <%_of_inf> -nan <%_of_nan> + + $ mpirun -np 4 ./xdinv -inf 10 -nan 30 + + + + diff --git a/scalapack_build.cmake b/scalapack_build.cmake index ba30a872..21fc6e22 100644 --- a/scalapack_build.cmake +++ b/scalapack_build.cmake @@ -1,4 +1,4 @@ -cmake_minimum_required(VERSION 2.8) +cmake_minimum_required(VERSION 3.22) ################################################################### # The values in this section must always be provided ###################################################################