Commit 846eb4e0 authored by Thomas Jahns's avatar Thomas Jahns 🤸
Browse files

Add dedicated, switchable abort function.

parent d57a14b7
......@@ -6,7 +6,8 @@ AM_CFLAGS = $(MPI_C_INCLUDE) -I@top_srcdir@/include -I../include \
lib_LIBRARIES=libscalesppm.a
libscalesppm_a_SOURCES=ppm/core.c ppm/scales_ppm.f90
libscalesppm_a_SOURCES=ppm/core.c ppm/scales_ppm.f90 \
ppm/scales_ppm_base.f90
clean-local:
-rm -f *.@FCMODEXT@ i.*.L
......
......@@ -4,8 +4,10 @@
#ifdef HAVE_CONFIG_H
#include <config.h>
#endif
#include <stdio.h>
#include <cfortran.h>
#include <parmetis.h>
#include "core.h"
#ifdef HAVE_MPI_COMM_F2C
void ParMETIS_V3_PartKway_Wrapper(
......@@ -39,10 +41,29 @@ FCALLSCSUB15(ParMETIS_V3_PartKway_Wrapper, PARMETIS_V3_PARTKWAY,
PINT, PINT, PINT, PINT, PINT, PINT, PINT, PINT,
PINT, PFLOAT, PFLOAT, PINT, PINT, PINT, PVOID)
#endif
void
abort_ppm_fwrap(MPI_Fint *comm_f, const char *msg, const char *source, int line)
{
#ifdef HAVE_MPI_COMM_F2C
MPI_Comm comm_c = MPI_Comm_f2c((MPI_Fint)*comm_f);
#else
MPI_Comm comm_c = *comm_f;
#endif
abort_ppm(&comm_c, msg, source, line);
}
FCALLSCSUB4(abort_ppm_fwrap, ABORT_PPM_F, abort_ppm_f, PVOID, STRING,
STRING, INT)
int scales_ppm_dummy(void)
void
abort_ppm_default(MPI_Comm *comm, const char *msg, const char *source, int line)
{
fprintf(stderr, "Fatal error in %s, line %d: %s\n", source, line, msg);
MPI_Abort(*comm, 1);
}
#endif
abort_func abort_ppm = abort_ppm_default;
#ifdef HAVE_CONFIG_H
#include <config.h>
#endif
#include <mpi.h>
typedef void (*abort_func)(MPI_Comm *comm, const char *msg,
const char *source, int line);
extern abort_func abort_ppm;
MODULE scales_ppm
USE iso_c_binding
USE scales_ppm_base, ONLY: abort_ppm
IMPLICIT NONE
include 'mpif.h'
INCLUDE 'mpif.h'
#include <ppm.inc>
EXTERNAL :: parmetis_v3_partkway
PUBLIC :: graph_partition, abort_ppm, &
initialize_scales_ppm
CONTAINS
SUBROUTINE graph_partition(num_vertices, edge_list_lens, &
edge_lists, partition_out, comm, &
balance, num_vertex_weights, vertex_weights, edge_weights, &
ierror_out)
balance, num_vertex_weights, vertex_weights, edge_weights)
INTEGER(ppm_idx), INTENT(in) :: num_vertices
INTEGER(ppm_idx), INTENT(in) :: edge_list_lens(:)
INTEGER(ppm_idx), INTENT(in) :: edge_lists(:)
......@@ -18,16 +20,23 @@ CONTAINS
INTEGER, OPTIONAL, INTENT(in) :: num_vertex_weights
INTEGER(ppm_idx), OPTIONAL, INTENT(in) :: vertex_weights(:)
INTEGER(ppm_idx), OPTIONAL, INTENT(in) :: edge_weights(:)
INTEGER, OPTIONAL, INTENT(out) :: ierror_out
INTEGER(c_int) :: wgtflag
INTEGER :: comm_size, comm_rank, ierror, i
INTEGER, ALLOCATABLE :: vtxdist(:)
INTEGER :: metis_options(0:2), edge_cut
INTEGER, PARAMETER :: max_msg_len=1024
CHARACTER(len=max_msg_len) :: msg
CALL mpi_comm_size(comm, comm_size, ierror)
IF (ierror /= MPI_SUCCESS) CALL mpi_abort(comm, 1)
IF (ierror /= MPI_SUCCESS) THEN
CALL mpi_error_string(ierror, msg, max_msg_len, ierror)
CALL abort_ppm(msg, __FILE__, __LINE__, comm)
END IF
CALL mpi_comm_rank(comm, comm_rank, ierror)
IF (ierror /= MPI_SUCCESS) CALL mpi_abort(comm, 1)
IF (ierror /= MPI_SUCCESS) THEN
CALL mpi_error_string(ierror, msg, max_msg_len, ierror)
CALL abort_ppm(msg, __FILE__, __LINE__, comm)
END IF
! build table of node distribution
ALLOCATE(vtxdist(0:comm_size))
......@@ -35,7 +44,10 @@ CONTAINS
i = INT(num_vertices)
CALL mpi_allgather(i, 1, MPI_INTEGER, &
vtxdist(1:comm_size), 1, MPI_INTEGER, comm, ierror)
IF (ierror /= MPI_SUCCESS) CALL mpi_abort(comm, 1)
IF (ierror /= MPI_SUCCESS) then
CALL mpi_error_string(ierror, msg, max_msg_len, ierror)
CALL abort_ppm(msg, __FILE__, __LINE__, comm)
END IF
vtxdist(0) = 1
vtxdist(comm_rank + 1) = i
......@@ -54,6 +66,8 @@ CONTAINS
vertex_weights, edge_weights, wgtflag, 1, num_vertex_weights, &
comm_size, balance, REAL(1.05, 4), metis_options, edge_cut, &
partition_out, comm)
IF (PRESENT(ierror_out)) ierror_out = ierror
END SUBROUTINE graph_partition
SUBROUTINE initialize_scales_ppm
END SUBROUTINE initialize_scales_ppm
END MODULE scales_ppm
MODULE scales_ppm_base
IMPLICIT NONE
INCLUDE 'mpif.h'
PRIVATE
PUBLIC :: abort_ppm, assertion
CONTAINS
SUBROUTINE abort_ppm(msg, source, line, comm)
CHARACTER(len=*), INTENT(in) :: source, msg
INTEGER, INTENT(in) :: line
INTEGER, OPTIONAL, INTENT(in) :: comm
INTEGER :: comm_dummy
comm_dummy = MERGE(comm, mpi_comm_world, PRESENT(comm))
CALL abort_ppm_f(comm_dummy, msg, source, line)
END SUBROUTINE abort_ppm
SUBROUTINE assertion(cond, origfile, origline)
LOGICAL, INTENT(in) :: cond
CHARACTER(len=*), OPTIONAL, INTENT(in) :: origfile
INTEGER, OPTIONAL, INTENT(in) :: origline
CHARACTER(len=255) :: file
INTEGER :: line
IF (PRESENT(origfile)) THEN
file = origfile
ELSE
file = 'unknown'
ENDIF
IF (PRESENT(origline)) THEN
line = origline
ELSE
line = -1
ENDIF
IF (.NOT. cond) CALL abort_ppm('assertion failed', TRIM(file), line)
END SUBROUTINE assertion
END MODULE scales_ppm_base
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment