diff --git a/environ-mgmt/Makefile.am b/environ-mgmt/Makefile.am new file mode 100644 index 0000000..1b20eb3 --- /dev/null +++ b/environ-mgmt/Makefile.am @@ -0,0 +1,8 @@ +# +# Copyright (c) 2020 Cisco Systems, Inc. All rights reserved +# Copyright (c) 2025 UT-Battelle, LLC. All rights reserved +# +# $COPYRIGHT$ +# + +SUBDIRS = src diff --git a/environ-mgmt/README.md b/environ-mgmt/README.md new file mode 100644 index 0000000..76de3ec --- /dev/null +++ b/environ-mgmt/README.md @@ -0,0 +1,86 @@ +Environ Management Tests +------------------------ + +Tests for items in the "MPI Environmental Management" chapter. + +These are being created in the ompi-tests-public repository +to ensure they are easy to access. + +Using autotools to detect if we have the MPI-4.1 remove error code +functionality, otherwise skips. + +Usage +----- + - Ensure MPI `mpicc` in `PATH` + - Run autogen/configure/make to build test + + ``` + cd environ-mgmt/ + ./autogen.sh && ./configure && make + ``` + + - Run test(s) + + ``` + mpirun -np 1 ./src/test_add_del_err_codes + mpirun -np 1 ./src/test_add_del_err_codes_pthreads + ``` + + - (Fortran) Build/Run + ``` + ./autogen.sh && ./configure FC=mpifort && make + mpirun -np 1 ./src/test_add_err_codes_usempi + mpirun -np 1 ./src/test_add_err_codes_usempif08 + ``` + +Tests +----- + +### test_add_del_err_codes +Basic C test for `MPI_Add_error_class/code/string` and `MPI_Remove_error_class/code/string` functionality. + +### test_add_del_err_codes_pthreads +Multi-threaded stress test using pthreads to verify thread-safety of error code management APIs. Creates 10 concurrent threads that each add and remove error classes, codes, and strings with random sleep intervals to stress concurrent operations. Requires `MPI_THREAD_MULTIPLE` and pthread support. + +### test_add_err_codes_usempi +Fortran test using `use mpi` interface. + +### test_add_err_codes_usempif08 +Fortran test using `use mpi_f08` interface. + +Example Output +-------------- + + - On MPI 3.x + ``` + laptop:$ mpirun -np 1 ./src/test_add_del_err_codes + TEST: Success creating error class/code/string (last=92, newlast=94) + ==== Adds done ==== + ==== Remove estring ==== + Warning: MPI_Remove_error_xxx code/class/string NOT available! + ==== Remove ecode ==== + Warning: MPI_Remove_error_xxx code/class/string NOT available! + ==== Remove eclass ==== + Warning: MPI_Remove_error_xxx code/class/string NOT available! + DONE: Success + laptop$ echo $? + 0 + laptop$ + ``` + + - On MPI 4.1 or later + ``` + laptop:$ mpirun -np 1 ./src/test_add_del_err_codes + TEST: Success creating error class/code/string (last=92, newlast=94) + ==== Adds done ==== + ==== Remove estring ==== + ==== Remove ecode ==== + TEST: Success reomved error code (oldlast=94, newlast=93) + ==== Remove eclass ==== + TEST: Success reomved error class (oldlast=93, newlast=92) + DONE: Success + laptop$ echo $? + 0 + laptop$ + ``` + diff --git a/environ-mgmt/autogen.sh b/environ-mgmt/autogen.sh new file mode 100755 index 0000000..a28bc75 --- /dev/null +++ b/environ-mgmt/autogen.sh @@ -0,0 +1,4 @@ +#!/bin/sh + +autoreconf --install + diff --git a/environ-mgmt/config/.gitkeep b/environ-mgmt/config/.gitkeep new file mode 100644 index 0000000..e69de29 diff --git a/environ-mgmt/configure.ac b/environ-mgmt/configure.ac new file mode 100644 index 0000000..db40592 --- /dev/null +++ b/environ-mgmt/configure.ac @@ -0,0 +1,151 @@ +# -*- shell-script -*- +# +# Copyright (c) 2012-2020 Cisco Systems, Inc. All rights reserved. +# Copyright (c) 2025 UT-Battelle, LLC. All rights reserved. +# +# $COPYRIGHT$ +# + +dnl +dnl Init autoconf +dnl + +AC_PREREQ([2.67]) +AC_INIT([mpi-environmgmt-test], [1.0], [http://www.open-mpi.org]) +AC_CONFIG_AUX_DIR([config]) +AC_CONFIG_MACRO_DIR([config]) +AC_CONFIG_SRCDIR([.]) + +echo "Configuring Environmental Management test" + +AM_INIT_AUTOMAKE([1.11 foreign -Wall -Werror]) + +# If Automake supports silent rules, enable them. +m4_ifdef([AM_SILENT_RULES], [AM_SILENT_RULES([yes])]) + +AH_TOP([/* -*- c -*- + * + * Environmental Management test suite configuation header file. + * See the top-level LICENSE file for license and copyright + * information. + */ + +#ifndef MPI_ENVIRONMGMT_TEST_CONFIG_H +#define MPI_ENVIRONMGMT_TEST_CONFIG_H +]) +AH_BOTTOM([#endif /* MPI_ENVIRONMGMT_TEST_CONFIG_H */]) + +dnl +dnl Make automake clean emacs ~ files for "make clean" +dnl + +CLEANFILES="*~" +AC_SUBST(CLEANFILES) + +dnl +dnl Get various programs +dnl Bias towards mpicc/mpic++/mpif77 +dnl C compiler +dnl + +if test "$CC" != ""; then + BASE="`basename $CC`" +else + BASE= +fi +if test "$BASE" = "" -o "$BASE" = "." -o "$BASE" = "cc" -o \ + "$BASE" = "gcc" -o "$BASE" = "xlc" -o "$BASE" = "pgcc" -o \ + "$BASE" = "icc"; then + AC_CHECK_PROG(HAVE_MPICC, mpicc, yes, no) + if test "$HAVE_MPICC" = "yes"; then + CC=mpicc + export CC + fi +fi + +CFLAGS_save=$CFLAGS +AC_PROG_CC +CFLAGS=$CFLAGS_save + +dnl +dnl Fortran compiler - prefer mpifort if available +dnl + +if test "$FC" = ""; then + AC_CHECK_PROG(HAVE_MPIFORT, mpifort, yes, no) + if test "$HAVE_MPIFORT" = "yes"; then + FC=mpifort + export FC + fi +fi + +FFLAGS_save=$FFLAGS +AC_PROG_FC +FFLAGS=$FFLAGS_save + + +dnl +dnl Because these are meant to be used for debugging, after all +dnl + +if test -z "$CFLAGS"; then + CFLAGS="-g" +fi + +dnl +dnl Ensure that we can compile and link a C MPI program +dnl + +AC_LANG_PUSH([C]) +AC_CHECK_HEADERS(mpi.h) + +AC_MSG_CHECKING([if linking MPI program works]) +AC_LINK_IFELSE([AC_LANG_PROGRAM([[#include +]], + [[MPI_Comm a = MPI_COMM_WORLD]])], + [AC_MSG_RESULT([yes])], + [AC_MSG_RESULT([no]) + AC_MSG_WARN([Simple MPI program fails to link]) + AC_MSG_ERROR([Cannot continue]) + ]) + +AC_CHECK_LIB([mpi], [MPI_Add_error_code], + [AC_DEFINE([HAVE_MPI_ADD_ERROR_CODE], [1], [Define if have MPI_Add_error_code])], + [AC_MSG_WARN([MPI_Add_error_code not found; disable related features])]) + + +AC_CHECK_LIB([mpi], [MPI_Remove_error_code], + [AC_DEFINE([HAVE_MPI_REMOVE_ERROR_CODE], [1], [Define if have MPI_Remove_error_code])], + [AC_MSG_WARN([MPI_Remove_error_code not found; disable related features])]) + +AC_CHECK_LIB([mpi], [MPI_Remove_error_class], + [AC_DEFINE([HAVE_MPI_REMOVE_ERROR_CLASS], [1], [Define if have MPI_Remove_error_class])], + [AC_MSG_WARN([MPI_Remove_error_class not found; disable related features])]) + +AC_CHECK_LIB([mpi], [MPI_Remove_error_string], + [AC_DEFINE([HAVE_MPI_REMOVE_ERROR_STRING], [1], [Define if have MPI_Remove_error_string])], + [AC_MSG_WARN([MPI_Remove_error_string not found; disable related features])]) + +AC_SUBST([MPI_LIBS]) + +dnl +dnl Check for pthreads support +dnl + +AC_SEARCH_LIBS([pthread_create], [pthread], [have_pthread=yes], [have_pthread=no]) +if test "$have_pthread" = "yes"; then + AC_DEFINE([HAVE_PTHREAD], [1], [Define if have pthreads]) +fi + +AC_LANG_POP([C]) + +dnl +dnl Party on +dnl + +AC_CONFIG_HEADERS([config.h]) +AC_CONFIG_FILES([ + Makefile + src/Makefile +]) +AC_OUTPUT diff --git a/environ-mgmt/src/Makefile.am b/environ-mgmt/src/Makefile.am new file mode 100644 index 0000000..bca0445 --- /dev/null +++ b/environ-mgmt/src/Makefile.am @@ -0,0 +1,30 @@ +# +# Copyright (c) 2020 Cisco Systems, Inc. All rights reserved +# Copyright (c) 2025 UT-Battelle, LLC. All rights reserved +# +# +# $COPYRIGHT$ +# + +noinst_PROGRAMS = test_add_del_err_codes \ + test_add_del_err_codes_pthreads \ + test_add_err_codes_usempi \ + test_add_del_err_codes_usempi \ + test_add_del_err_codes_usempif08 + +test_add_del_err_codes_SOURCES = \ + test_add_del_err_codes.c + +test_add_del_err_codes_pthreads_SOURCES = \ + test_add_del_err_codes_pthreads.c + +test_add_err_codes_usempi_SOURCES = \ + test_add_err_codes_usempi.f90 + +test_add_del_err_codes_usempi_SOURCES = \ + test_add_del_err_codes_usempi.f90 + +test_add_del_err_codes_usempif08_SOURCES = \ + test_add_del_err_codes_usempif08.f90 + + diff --git a/environ-mgmt/src/test_add_del_err_codes.c b/environ-mgmt/src/test_add_del_err_codes.c new file mode 100644 index 0000000..d9a3510 --- /dev/null +++ b/environ-mgmt/src/test_add_del_err_codes.c @@ -0,0 +1,214 @@ +/* + * Copyright (c) 2025 UT-Battelle, LLC. All rights reserved. + * + * Tests for MPI_LASTUSEDCODE, MPI_Add_error_{class,code,string}, and + * MPI_Remove_error{class,code,string}. + * + * File: test_add_del_err_codes.c + * + * Referenced examples online and in ompi-tests: + * - "ompi-tests/random/add_error_class.c" + * - example from Lisandro Dalcin + * https://www.open-mpi.org/community/lists/devel/2014/04/14578.php + */ +#include "config.h" + +#include +#include + +#include "mpi.h" + +#define SUCCESS (0) +#define FAILURE (-1) +#define SKIPTEST (-2) + +#define CHECK_RC(_rc,_msg) do {\ + if (_rc != MPI_SUCCESS) { \ + fprintf(stderr, "[%s:%d] Error: %s failed (rc=%d)\n", __FUNCTION__, __LINE__, _msg, _rc); \ + exit(1); \ + } \ + } while(0) + +int get_lastused(MPI_Comm comm); +int do_add_error(MPI_Comm comm, int *eclass, int *ecode, char *estr); +int do_del_error_string(MPI_Comm comm, int eclass, int ecode, char *estr); +int do_del_error_code(MPI_Comm comm, int eclass, int ecode, char *estr); +int do_del_error_class(MPI_Comm comm, int eclass, int ecode, char *estr); + +int get_lastused(MPI_Comm comm) +{ + int *last = NULL; + int flag = 0; + + CHECK_RC( MPI_Comm_get_attr(comm, MPI_LASTUSEDCODE, &last, &flag), + "MPI_Comm_get_attr"); + + if (flag == 0) + return (-1); /* no key found */ + else + return (*last); +} + +int do_add_error(MPI_Comm comm, int *eclass, int *ecode, char *estr) +{ + int ret = SUCCESS; + +#ifdef HAVE_MPI_ADD_ERROR_CODE + int last = 0, newlast = 0; + last = get_lastused(MPI_COMM_WORLD); + + CHECK_RC( MPI_Add_error_class(eclass), "MPI_Add_error_class"); + CHECK_RC( MPI_Add_error_code(*eclass, ecode), "MPI_Add_error_code"); + CHECK_RC( MPI_Add_error_string(*ecode, estr), "MPI_Add_error_string"); + + newlast = get_lastused(MPI_COMM_WORLD); + + if (newlast > last) { + printf("TEST: Success creating error class/code/string (last=%d, newlast=%d)\n", last, newlast); + ret = SUCCESS; + } else { + printf("Error: MPI_Add_error_xxx failed LastUsedCode not increased (last=%d, new=%d)\n", last, newlast); + ret = FAILURE; + } + +#else + printf("Warning: MPI_Add_error_xxx code/class/string NOT available!\n"); + ret = SKIPTEST; +#endif /* HAVE_MPI_ADD_ERROR_CODE */ + + return(ret); +} + + +int do_del_error_string(MPI_Comm comm, int eclass, int ecode, char *estr) +{ + int ret = SUCCESS; + +#ifdef HAVE_MPI_REMOVE_ERROR_CODE + CHECK_RC( MPI_Remove_error_string(ecode), "MPI_Remove_error_string"); +#else + /* We should have MPI_Remove_error_xxx with MPI >= 4.1 */ + printf("Warning: MPI_Remove_error_string NOT available!\n"); + ret = SKIPTEST; +#endif /* HAVE_MPI_REMOVE_ERROR_CODE */ + + return(ret); +} + +int do_del_error_code(MPI_Comm comm, int eclass, int ecode, char *estr) +{ + int ret = SUCCESS; + +#ifdef HAVE_MPI_REMOVE_ERROR_CODE + int last = 0, newlast = 0; + last = get_lastused(MPI_COMM_WORLD); + + CHECK_RC( MPI_Remove_error_code(ecode), "MPI_Remove_error_code"); + + newlast = get_lastused(MPI_COMM_WORLD); + + if (newlast < last) { + printf("TEST: Success removed error code (oldlast=%d, newlast=%d)\n", last, newlast); + ret = SUCCESS; + } else { + printf("Error: MPI_Remove_error_code failed LastUsedCode not decreased (last=%d, new=%d)\n", last, newlast); + ret = FAILURE; + } + +#else + /* We should have MPI_Remove_error_xxx with MPI >= 4.1 */ + printf("Warning: MPI_Remove_error_code NOT available!\n"); + ret = SKIPTEST; +#endif /* HAVE_MPI_REMOVE_ERROR_CODE */ + + return(ret); +} + +int do_del_error_class(MPI_Comm comm, int eclass, int ecode, char *estr) +{ + int ret = SUCCESS; + +#ifdef HAVE_MPI_REMOVE_ERROR_CODE + int last = 0, newlast = 0; + last = get_lastused(MPI_COMM_WORLD); + + CHECK_RC( MPI_Remove_error_class(eclass), "MPI_Remove_error_class"); + + newlast = get_lastused(MPI_COMM_WORLD); + + if (newlast < last) { + printf("TEST: Success removed error class (oldlast=%d, newlast=%d)\n", last, newlast); + ret = SUCCESS; + } else { + printf("Error: MPI_Remove_error_class failed LastUsedCode not decreased (last=%d, new=%d)\n", last, newlast); + ret = FAILURE; + } + +#else + /* We should have MPI_Remove_error_xxx with MPI >= 4.1 */ + printf("Warning: MPI_Remove_error_class NOT available!\n"); + ret = SKIPTEST; +#endif /* HAVE_MPI_REMOVE_ERROR_CODE */ + + return(ret); +} + + +int main (int argc, char **argv) +{ + int rc, rank=0, size; + int retval = EXIT_SUCCESS; + int eclass, ecode; + char *estr = "My Dummy Error String"; + + CHECK_RC( MPI_Init(&argc, &argv), "MPI_Init"); + CHECK_RC( MPI_Comm_rank(MPI_COMM_WORLD, &rank), "MPI_Comm_rank"); + CHECK_RC( MPI_Comm_size(MPI_COMM_WORLD, &size), "MPI_Comm_size"); + + rc = do_add_error(MPI_COMM_WORLD, &eclass, &ecode, estr); + if ((SUCCESS != rc) && (SKIPTEST != rc)) { + printf("Error: Failed during do_add_error testing (rc=%d)\n", rc); + retval = EXIT_FAILURE; + goto fini; + } + + printf("==== Adds done ====\n"); + + printf("==== Remove estring ====\n"); + rc = do_del_error_string(MPI_COMM_WORLD, eclass, ecode, estr); + if ((SUCCESS != rc) && (SKIPTEST != rc)) { + printf("Error: Failed during do_del_error_string testing (rc=%d)\n", rc); + retval = EXIT_FAILURE; + goto fini; + } + + printf("==== Remove ecode ====\n"); + rc = do_del_error_code(MPI_COMM_WORLD, eclass, ecode, estr); + if ((SUCCESS != rc) && (SKIPTEST != rc)) { + printf("Error: Failed during do_del_error_code testing (rc=%d)\n", rc); + retval = EXIT_FAILURE; + goto fini; + } + + printf("==== Remove eclass ====\n"); + rc = do_del_error_class(MPI_COMM_WORLD, eclass, ecode, estr); + if ((SUCCESS != rc) && (SKIPTEST != rc)) { + printf("Error: Failed during do_del_error_class testing (rc=%d)\n", rc); + retval = EXIT_FAILURE; + goto fini; + } + +fini: + CHECK_RC( MPI_Finalize(), "MPI_Finalize"); + + if (rank == 0) { + if (retval == EXIT_SUCCESS) { + printf("DONE: Success\n"); + } else { + printf("DONE: Failure\n"); + } + } + + return(retval); +} + diff --git a/environ-mgmt/src/test_add_del_err_codes_pthreads.c b/environ-mgmt/src/test_add_del_err_codes_pthreads.c new file mode 100644 index 0000000..187d839 --- /dev/null +++ b/environ-mgmt/src/test_add_del_err_codes_pthreads.c @@ -0,0 +1,122 @@ +/* + * Copyright (c) 2025 UT-Battelle, LLC. All rights reserved. + * $COPYRIGHT$ + */ + +#include "config.h" + +#include +#include +#include + +#ifdef HAVE_PTHREAD +#include +#include +#include + +#define NUM_THREADS 10 +#define MAX_SLEEP_MS 100 + +typedef struct { + int thread_id; +} thread_arg_t; + +void *thread_func(void *arg) +{ + thread_arg_t *targ = (thread_arg_t *)arg; + int thread_id = targ->thread_id; + int errorclass, errorcode; + char errorstring[MPI_MAX_ERROR_STRING]; + char code_string[MPI_MAX_ERROR_STRING]; + int len; + unsigned int sleep_time; + + /* Seed random number generator with thread id and time */ + unsigned int seed = (unsigned int)(time(NULL) ^ (thread_id << 16)); + + /* Add error class */ + MPI_Add_error_class(&errorclass); + printf("Thread %d: Added error class %d\n", thread_id, errorclass); + + /* Add error code */ + MPI_Add_error_code(errorclass, &errorcode); + printf("Thread %d: Added error code %d\n", thread_id, errorcode); + + /* Add error string */ + snprintf(errorstring, MPI_MAX_ERROR_STRING, + "Error string for thread %d", thread_id); + MPI_Add_error_string(errorcode, errorstring); + printf("Thread %d: Added error string '%s'\n", thread_id, errorstring); + + /* Verify the error string was added correctly */ + MPI_Error_string(errorcode, code_string, &len); + printf("Thread %d: Verified error string: '%s'\n", thread_id, code_string); + + /* Sleep for random time to stress concurrent operations */ + sleep_time = rand_r(&seed) % MAX_SLEEP_MS; + usleep(sleep_time * 1000); + printf("Thread %d: Slept for %u ms\n", thread_id, sleep_time); + + /* Remove error string */ + MPI_Remove_error_string(errorcode); + printf("Thread %d: Removed error string for code %d\n", thread_id, errorcode); + + /* Remove error code */ + MPI_Remove_error_code(errorcode); + printf("Thread %d: Removed error code %d\n", thread_id, errorcode); + + /* Remove error class */ + MPI_Remove_error_class(errorclass); + printf("Thread %d: Removed error class %d\n", thread_id, errorclass); + + printf("Thread %d: Completed successfully\n", thread_id); + return NULL; +} +#endif + +int main(int argc, char **argv) +{ + int rank, size; + int provided; + + MPI_Init_thread(&argc, &argv, MPI_THREAD_MULTIPLE, &provided); + MPI_Comm_rank(MPI_COMM_WORLD, &rank); + MPI_Comm_size(MPI_COMM_WORLD, &size); + + if (provided < MPI_THREAD_MULTIPLE) { + printf("Warning: MPI does not provide MPI_THREAD_MULTIPLE support\n"); + } + + if (rank == 0) { + printf("MPI initialized with %d processes\n", size); + +#ifdef HAVE_PTHREAD + pthread_t threads[NUM_THREADS]; + thread_arg_t args[NUM_THREADS]; + int i; + + printf("pthread support available - creating %d threads\n", NUM_THREADS); + + /* Create threads */ + for (i = 0; i < NUM_THREADS; i++) { + args[i].thread_id = i; + if (pthread_create(&threads[i], NULL, thread_func, &args[i]) != 0) { + fprintf(stderr, "Failed to create thread %d\n", i); + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + /* Join threads */ + for (i = 0; i < NUM_THREADS; i++) { + pthread_join(threads[i], NULL); + } + + printf("All threads completed successfully\n"); +#else + printf("pthread support not available - test running without threads\n"); +#endif + } + + MPI_Finalize(); + return 0; +} diff --git a/environ-mgmt/src/test_add_del_err_codes_usempi.f90 b/environ-mgmt/src/test_add_del_err_codes_usempi.f90 new file mode 100644 index 0000000..1aee7af --- /dev/null +++ b/environ-mgmt/src/test_add_del_err_codes_usempi.f90 @@ -0,0 +1,161 @@ +! +! Copyright (c) 2025 UT-Battelle, LLC. All rights reserved. +! +! Tests for MPI_LASTUSEDCODE, MPI_Add_error_{class,code,string}, and +! MPI_Remove_error{class,code,string}. +! +! File: test_add_del_err_codes_usempi.f90 +! +! Referenced examples online and in ompi-tests: +! - "ompi-tests/random/add_error_class.c" +! - example from Lisandro Dalcin +! https://www.open-mpi.org/community/lists/devel/2014/04/14578.php +! +program main + use mpi + implicit none + integer :: ierr, rank, size, eclass, ecode + integer(kind=MPI_ADDRESS_KIND) :: last + integer(kind=MPI_ADDRESS_KIND) :: newlast + logical :: flag + character(len=*), parameter :: estr = "My Dummy Error String" + + call MPI_INIT(ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_INIT failed (ierr=', ierr, ')' + stop 1 + end if + + call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_COMM_RANK failed (ierr=', ierr, ')' + stop 1 + end if + + call MPI_COMM_SIZE(MPI_COMM_WORLD, size, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_COMM_SIZE failed (ierr=', ierr, ')' + stop 1 + end if + + write(*, '("Hello rank: ", i2, " of ", i2)') & + rank, size + + call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, last, flag, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')' + stop 1 + end if + write(*, '("DBG last: ", i0)') & + last + + ! Add error class/code/string + call MPI_ADD_ERROR_CLASS(eclass, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_ADD_ERROR_CLASS failed (ierr=', ierr, ')' + stop 1 + end if + + call MPI_ADD_ERROR_CODE(eclass, ecode, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_ADD_ERROR_CODE failed (ierr=', ierr, ')' + stop 1 + end if + + call MPI_ADD_ERROR_STRING(ecode, estr, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_ADD_ERROR_STRING failed (ierr=', ierr, ')' + stop 1 + end if + + call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, newlast, flag, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')' + stop 1 + end if + + ! Check that last error code increased + if (newlast > last) then + write(*, '("TEST: Success creating error class/code/string last: ", i0, " newlast: ", i0)') & + last, newlast + else + write(*, '("Error: MPI_Add_error_xxx failed LastUsedCode not increased last: ", i0, " newlast: ", i0)') & + last, newlast + end if + + write(*,*) '==== Adds done ====' + + ! Remove error string + write(*,*) '==== Remove estring ====' + call MPI_REMOVE_ERROR_STRING(ecode, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_REMOVE_ERROR_STRING failed (ierr=', ierr, ')' + stop 1 + end if + write(*,*) 'TEST: Success removing error string' + + ! Remove error code + write(*,*) '==== Remove ecode ====' + call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, last, flag, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')' + stop 1 + end if + + call MPI_REMOVE_ERROR_CODE(ecode, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_REMOVE_ERROR_CODE failed (ierr=', ierr, ')' + stop 1 + end if + + call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, newlast, flag, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')' + stop 1 + end if + + ! Check that last error code decreased + if (newlast < last) then + write(*, '("TEST: Success removed error code last: ", i0, " newlast: ", i0)') & + last, newlast + else + write(*, '("Error: MPI_REMOVE_ERROR_CODE failed LastUsedCode not decreased last: ", i0, " newlast: ", i0)') & + last, newlast + end if + + ! Remove error class + write(*,*) '==== Remove eclass ====' + call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, last, flag, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')' + stop 1 + end if + + call MPI_REMOVE_ERROR_CLASS(eclass, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_REMOVE_ERROR_CLASS failed (ierr=', ierr, ')' + stop 1 + end if + + call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, newlast, flag, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')' + stop 1 + end if + + ! Check that last error code decreased + if (newlast < last) then + write(*, '("TEST: Success removed error class last: ", i0, " newlast: ", i0)') & + last, newlast + else + write(*, '("Error: MPI_REMOVE_ERROR_CLASS failed LastUsedCode not decrea sed last: ", i0, " newlast: ", i0)') & + last, newlast + end if + + call MPI_FINALIZE(ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_FINALIZE failed (ierr=', ierr, ')' + stop 1 + end if +end + diff --git a/environ-mgmt/src/test_add_del_err_codes_usempif08.f90 b/environ-mgmt/src/test_add_del_err_codes_usempif08.f90 new file mode 100644 index 0000000..5d0278c --- /dev/null +++ b/environ-mgmt/src/test_add_del_err_codes_usempif08.f90 @@ -0,0 +1,162 @@ +! -*- f90 -*- +! +! Copyright (c) 2025 UT-Battelle, LLC. All rights reserved. +! +! Tests for MPI_LASTUSEDCODE, MPI_Add_error_{class,code,string}, and +! MPI_Remove_error{class,code,string}. +! +! File: test_add_del_err_codes_usempif08.f90 +! +! Referenced examples online and in ompi-tests: +! - "ompi-tests/random/add_error_class.c" +! - example from Lisandro Dalcin +! https://www.open-mpi.org/community/lists/devel/2014/04/14578.php +! +program main + use mpi_f08 + implicit none + integer :: rank, size, eclass, ecode, ierr + integer(kind=MPI_ADDRESS_KIND) :: last + integer(kind=MPI_ADDRESS_KIND) :: newlast + logical :: flag + character(len=*), parameter :: estr = "My Dummy Error String" + + call MPI_INIT(ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_INIT failed (ierr=', ierr, ')' + stop 1 + end if + + call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_COMM_RANK failed (ierr=', ierr, ')' + stop 1 + end if + + call MPI_COMM_SIZE(MPI_COMM_WORLD, size, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_COMM_SIZE failed (ierr=', ierr, ')' + stop 1 + end if + + write(*, '("Hello rank: ", i2, " of ", i2)') & + rank, size + + call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, last, flag, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')' + stop 1 + end if + write(*, '("DBG last: ", i0)') & + last + ! Add error class/code/string + call MPI_ADD_ERROR_CLASS(eclass, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_ADD_ERROR_CLASS failed (ierr=', ierr, ')' + stop 1 + end if + + call MPI_ADD_ERROR_CODE(eclass, ecode, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_ADD_ERROR_CODE failed (ierr=', ierr, ')' + stop 1 + end if + + call MPI_ADD_ERROR_STRING(ecode, estr, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_ADD_ERROR_STRING failed (ierr=', ierr, ')' + stop 1 + end if + + call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, newlast, flag, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')' + stop 1 + end if + + ! Check that last error code increased + if (newlast > last) then + write(*, '("TEST: Success creating error class/code/string last: ", i0, " newlast: ", i0)') & + last, newlast + else + write(*, '("Error: MPI_Add_error_xxx failed LastUsedCode not increased l ast: ", i0, " newlast: ", i0)') & + last, newlast + end if + + write(*,*) '==== Adds done ====' + + ! Remove error string + write(*,*) '==== Remove estring ====' + call MPI_REMOVE_ERROR_STRING(ecode, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_REMOVE_ERROR_STRING failed (ierr=', ierr, ')' + stop 1 + end if + write(*,*) 'TEST: Success removing error string' + + ! Remove error code + write(*,*) '==== Remove ecode ====' + call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, last, flag, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')' + stop 1 + end if + + call MPI_REMOVE_ERROR_CODE(ecode, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_REMOVE_ERROR_CODE failed (ierr=', ierr, ')' + stop 1 + end if + + call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, newlast, flag, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')' + stop 1 + end if + + ! Check that last error code decreased + if (newlast < last) then + write(*, '("TEST: Success removed error code last: ", i0, " newlast: ", i0)') & + last, newlast + else + write(*, '("Error: MPI_REMOVE_ERROR_CODE failed LastUsedCode not decreas ed last: ", i0, " newlast: ", i0)') & + last, newlast + end if + + ! Remove error class + write(*,*) '==== Remove eclass ====' + call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, last, flag, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')' + stop 1 + end if + + call MPI_REMOVE_ERROR_CLASS(eclass, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_REMOVE_ERROR_CLASS failed (ierr=', ierr, ')' + stop 1 + end if + + call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, newlast, flag, ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_COMM_GET_ATTR failed (ierr=', ierr, ')' + stop 1 + end if + + + ! Check that last error code decreased + if (newlast < last) then + write(*, '("TEST: Success removed error class last: ", i0, " newlast: ", i0)') & + last, newlast + else + write(*, '("Error: MPI_REMOVE_ERROR_CLASS failed LastUsedCode not decreased last: ", i0, " newlast: ", i0)') & + last, newlast + end if + + call MPI_FINALIZE(ierr) + if (ierr /= MPI_SUCCESS) then + write(*,*) 'Error: MPI_FINALIZE failed (ierr=', ierr, ')' + stop 1 + end if +end + diff --git a/environ-mgmt/src/test_add_err_codes_usempi.f90 b/environ-mgmt/src/test_add_err_codes_usempi.f90 new file mode 100644 index 0000000..f5106dd --- /dev/null +++ b/environ-mgmt/src/test_add_err_codes_usempi.f90 @@ -0,0 +1,52 @@ +! +! Copyright (c) 2004-2006 The Trustees of Indiana University and Indiana +! University Research and Technology +! Corporation. All rights reserved. +! Copyright (c) 2004-2005 The Regents of the University of California. +! All rights reserved. +! Copyright (c) 2006-2015 Cisco Systems, Inc. All rights reserved. +! Copyright (c) 2025 UT-Battelle, LLC. All rights reserved. +! $COPYRIGHT$ +! +! Tests the use of Add/Remove error_{class,code,string}. +! +program main + use mpi + implicit none + integer :: ierr, rank, size, len, eclass, ecode + integer(kind=MPI_ADDRESS_KIND) :: last + integer(kind=MPI_ADDRESS_KIND) :: newlast + logical :: flag + character(len=*), parameter :: estr = "My Dummy Error String" + + call MPI_INIT(ierr) + call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr) + call MPI_COMM_SIZE(MPI_COMM_WORLD, size, ierr) + + write(*, '("Hello rank: ", i2, " of ", i2)') & + rank, size + + call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, last, flag, ierr) + write(*, '("DBG last: ", i2)') & + last + + ! Add error class/code/string + call MPI_ADD_ERROR_CLASS(eclass, ierr) + call MPI_ADD_ERROR_CODE(eclass, ecode, ierr) + call MPI_ADD_ERROR_STRING(ecode, estr, ierr) + + call MPI_COMM_GET_ATTR(MPI_COMM_WORLD, MPI_LASTUSEDCODE, newlast, flag, ierr) + + ! Check that last error code increased + if (newlast > last) then + write(*, '("TEST: Success creating error class/code/string last: ", i2, " newlast: ", i2)') & + last, newlast + else + write(*, '("Error: MPI_Add_error_xxx failed LastUsedCode not increased l ast: ", i2, " newlast: ", i2)') & + last, newlast + end if + + ! TODO: Remove error class/code/string + + call MPI_FINALIZE(ierr) +end