mirror of https://gitlab.com/QEF/q-e.git
Merge branch 'fftxlib-error' into 'develop'
Fix error handling in FFTXlib See merge request QEF/q-e!1291
This commit is contained in:
Ye Luo
commit
7b94aa9b36
|
|
@ -7,18 +7,99 @@
|
|||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
!----------------------------------------------------------------------------
|
||||
SUBROUTINE fftx_error__( calling_routine, message, ierr )
|
||||
|
||||
! ... Several routines which write an error message to stderr:
|
||||
! ... if ierr <= 0 it does nothing,
|
||||
! ... if ierr > 0 it stops.
|
||||
!
|
||||
! ... **** Important note for parallel execution ***
|
||||
! ... In QE parallel execution unit 6 is written only by the first node;
|
||||
! ... all other nodes have unit 6 redirected to nothing (/dev/null).
|
||||
! ... As a consequence an error not occurring on the first node
|
||||
! ... will be invisible. In addition, "first node" depends on the parallel
|
||||
! ... scopes like image, pool, bandgroup. It is better to avoid.
|
||||
! ...
|
||||
! ... For this reason, all the fft errors are printed to stderr defined in
|
||||
! ... module fft_param using iso_fortran_env from F2003.
|
||||
! ... fftx_error_uniform__ must be called by all the the ranks in an MPI
|
||||
! ... communicator. The uniform error will be printed only by rank 0 secured
|
||||
! ... by an MPI barrier before abort. Without the barrier, the error message
|
||||
! ... may not be seen if a non rank 0 node calls abort first.
|
||||
! ... In cases that errors don't occur uniformly, fftx_error__ prints the
|
||||
! ... error message and aborts the code. If it is used for uniform errors,
|
||||
! ... repeated error messages may be printed.
|
||||
! ... Use fftx_error_uniform__ wherever errors can be handled cleanly.
|
||||
! ... fftx_error__ is the last choice you may consider.
|
||||
|
||||
SUBROUTINE fftx_error_uniform__( calling_routine, message, ierr, comm )
|
||||
!----------------------------------------------------------------------------
|
||||
!
|
||||
! ... This is a simple routine which writes an error message to output:
|
||||
! ... Writes an uniform error via rank 0 of the given communicator
|
||||
!
|
||||
USE fft_param
|
||||
IMPLICIT NONE
|
||||
!
|
||||
CHARACTER(LEN=*), INTENT(IN) :: calling_routine, message
|
||||
! the name of the calling calling_routine
|
||||
! the output message
|
||||
INTEGER, INTENT(IN) :: ierr
|
||||
! the name of the calling calling_routine
|
||||
CHARACTER(LEN=*), INTENT(IN) :: calling_routine
|
||||
! the output message
|
||||
CHARACTER(LEN=*), INTENT(IN) :: message
|
||||
! the error number
|
||||
INTEGER, INTENT(IN) :: ierr
|
||||
! error scope MPI communicator
|
||||
INTEGER, INTENT(IN) :: comm
|
||||
!
|
||||
CHARACTER(LEN=6) :: cerr
|
||||
INTEGER :: info
|
||||
INTEGER :: my_rank
|
||||
!
|
||||
IF( ierr <= 0 ) THEN
|
||||
RETURN
|
||||
END IF
|
||||
!
|
||||
my_rank = 0
|
||||
#if defined(__MPI)
|
||||
CALL mpi_comm_rank(comm, my_rank, info)
|
||||
#endif
|
||||
if (my_rank == 0) then
|
||||
! ... the error message is written on the "stderr" unit
|
||||
!
|
||||
WRITE( cerr, FMT = '(I6)' ) ierr
|
||||
WRITE( stderr, FMT = '(/,1X,78("%"))' )
|
||||
WRITE( stderr, FMT = '(5X,"Error in routine ",A," (",A,"):")' ) &
|
||||
TRIM(calling_routine), TRIM(ADJUSTL(cerr))
|
||||
WRITE( stderr, FMT = '(1X,A)' ) TRIM(message)
|
||||
WRITE( stderr, FMT = '(1X,78("%"),/)' )
|
||||
!
|
||||
WRITE( stderr, '(" stopping ...")' )
|
||||
endif
|
||||
!
|
||||
#if defined(__MPI)
|
||||
!
|
||||
CALL mpi_barrier(MPI_COMM_WORLD, info)
|
||||
CALL mpi_abort(MPI_COMM_WORLD, ierr, info)
|
||||
!
|
||||
#endif
|
||||
!
|
||||
STOP 1
|
||||
!
|
||||
RETURN
|
||||
!
|
||||
END SUBROUTINE fftx_error_uniform__
|
||||
|
||||
SUBROUTINE fftx_error__( calling_routine, message, ierr )
|
||||
!----------------------------------------------------------------------------
|
||||
!
|
||||
! ... This is a simple routine which writes an error message to output:
|
||||
!
|
||||
USE fft_param
|
||||
IMPLICIT NONE
|
||||
!
|
||||
! the name of the calling calling_routine
|
||||
CHARACTER(LEN=*), INTENT(IN) :: calling_routine
|
||||
! the output message
|
||||
CHARACTER(LEN=*), INTENT(IN) :: message
|
||||
! the error number
|
||||
INTEGER, INTENT(IN) :: ierr
|
||||
!
|
||||
CHARACTER(LEN=6) :: cerr
|
||||
INTEGER :: info
|
||||
|
|
@ -27,20 +108,20 @@ SUBROUTINE fftx_error__( calling_routine, message, ierr )
|
|||
RETURN
|
||||
END IF
|
||||
!
|
||||
! ... the error message is written un the "*" unit
|
||||
! ... the error message is written on the "stderr" unit
|
||||
!
|
||||
WRITE( cerr, FMT = '(I6)' ) ierr
|
||||
WRITE( UNIT = *, FMT = '(/,1X,78("%"))' )
|
||||
WRITE( UNIT = *, FMT = '(5X,"Error in routine ",A," (",A,"):")' ) &
|
||||
WRITE( stderr, FMT = '(/,1X,78("%"))' )
|
||||
WRITE( stderr, FMT = '(5X,"Error in routine ",A," (",A,"):")' ) &
|
||||
TRIM(calling_routine), TRIM(ADJUSTL(cerr))
|
||||
WRITE( UNIT = *, FMT = '(5X,A)' ) TRIM(message)
|
||||
WRITE( UNIT = *, FMT = '(1X,78("%"),/)' )
|
||||
WRITE( stderr, FMT = '(1X,A)' ) TRIM(message)
|
||||
WRITE( stderr, FMT = '(1X,78("%"),/)' )
|
||||
!
|
||||
WRITE( *, '(" stopping ...")' )
|
||||
WRITE( stderr, '(" stopping ...")' )
|
||||
!
|
||||
#if defined(__MPI)
|
||||
!
|
||||
CALL mpi_abort(MPI_COMM_WORLD,ierr,info)
|
||||
CALL mpi_abort(MPI_COMM_WORLD, ierr, info)
|
||||
!
|
||||
#endif
|
||||
!
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@
|
|||
! or http://www.gnu.org/copyleft/gpl.txt .
|
||||
!
|
||||
MODULE fft_param
|
||||
|
||||
use iso_fortran_env, only : stderr=>ERROR_UNIT, stdout=>OUTPUT_UNIT
|
||||
#if defined(__MPI)
|
||||
#if defined(__MPI_MODULE)
|
||||
USE mpi
|
||||
|
|
@ -28,7 +28,6 @@ MODULE fft_param
|
|||
!!Max allowed fft dimension
|
||||
|
||||
INTEGER, PARAMETER :: DP = selected_real_kind(14,200)
|
||||
INTEGER, PARAMETER :: stdout = 6 ! unit connected to standard output
|
||||
|
||||
REAL(DP), PARAMETER :: eps8 = 1.0E-8_DP
|
||||
|
||||
|
|
|
|||
|
|
@ -206,10 +206,7 @@ CONTAINS
|
|||
INTEGER :: nx, ny, ierr, nzfft, i, nsubbatches
|
||||
INTEGER :: mype, root, nproc, iproc, iproc2, iproc3 ! mype starting from 0
|
||||
INTEGER :: color, key
|
||||
!write (6,*) ' inside fft_type_allocate' ; FLUSH(6)
|
||||
|
||||
IF ( ALLOCATED( desc%nsp ) ) &
|
||||
CALL fftx_error__(' fft_type_allocate ', ' fft arrays already allocated ', 1 )
|
||||
!write (6,*) ' inside fft_type_allocate' ; FLUSH(6)
|
||||
|
||||
desc%comm = comm
|
||||
#if defined(__MPI)
|
||||
|
|
@ -217,6 +214,10 @@ CONTAINS
|
|||
CALL fftx_error__( ' fft_type_allocate ', ' fft communicator is null ', 1 )
|
||||
END IF
|
||||
#endif
|
||||
!
|
||||
IF ( ALLOCATED( desc%nsp ) ) &
|
||||
CALL fftx_error_uniform__(' fft_type_allocate ', ' fft arrays already allocated ', 1, desc%comm )
|
||||
|
||||
!
|
||||
root = 0 ; mype = 0 ; nproc = 1
|
||||
#if defined(__MPI)
|
||||
|
|
@ -1002,7 +1003,7 @@ CONTAINS
|
|||
|
||||
IF ( PRESENT (use_pd) ) dfft%use_pencil_decomposition = use_pd
|
||||
IF ( ( .not. dfft%use_pencil_decomposition ) .and. ( nyfft > 1 ) ) &
|
||||
CALL fftx_error__(' fft_type_init ', ' Slab decomposition and task groups not implemented. ', 1 )
|
||||
CALL fftx_error_uniform__(' fft_type_init ', ' Slab decomposition and task groups not implemented. ', 1, dfft%comm )
|
||||
|
||||
dfft%lpara = lpara ! this descriptor can be either a descriptor for a
|
||||
! parallel FFT or a serial FFT even in parallel build
|
||||
|
|
|
|||
|
|
@ -43,7 +43,7 @@ SUBROUTINE errore( calling_routine, message, ierr )
|
|||
!
|
||||
IF( ierr <= 0 ) RETURN
|
||||
!
|
||||
! ... the error message is written un the "*" unit
|
||||
! ... the error message is written on the "*" unit
|
||||
!
|
||||
WRITE( cerr, FMT = '(I6)' ) ierr
|
||||
WRITE( UNIT = *, FMT = '(/,1X,78("%"))' )
|
||||
|
|
|
|||
Loading…
Reference in New Issue