sdl_mod.F90

Go to the documentation of this file.

MODULE sdl_mod

!    Interface between user applications and system-dependent intrinsic
!    routines, provided by the computer vendors.

!    All routines which wish to call these routines must contain:
!    USE SDL_MOD

! Author :
! ------
!   11-Apr-2005 R. El Khatib  *METEO-FRANCE*
!   26-Apr-2006 S.T.Saarinen  Dr.Hook trace, calls to EC_RAISE, Intel/ifort traceback

USE parkind1  ,ONLY : jpim  ,jprb
USE yomhook   ,ONLY : lhook ,dr_hook
USE oml_mod, ONLY : oml_my_thread

IMPLICIT NONE

SAVE

PRIVATE

INTEGER, PARAMETER :: sigabrt = 6 ! Hardcoded

PUBLIC :: sdl_srlabort, sdl_disabort, sdl_traceback

CONTAINS

!-----------------------------------------------------------------------------
SUBROUTINE sdl_traceback(KTID)

! Purpose :
! -------
!   Traceback

!   KTID : thread 

INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: KTID
INTEGER(KIND=JPIM) ITID, IPRINT_OPTION, ILEVEL
#ifdef NECSX
CHARACTER(LEN=*), PARAMETER :: CLNECMSG = '*** Calling NEC traceback ***'
#endif

IF (PRESENT(ktid)) THEN
  itid = ktid
ELSE
  itid = oml_my_thread()
ENDIF

IF (lhook) THEN
  iprint_option = 2
  ilevel = 0
  CALL c_drhook_print(0, itid, iprint_option, ilevel) ! from drhook.c
ENDIF

#if defined(VPP)
  CALL errtra
  IF (PRESENT(ktid)) CALL sleep(28)
#elif defined(RS6K)
  WRITE(0,*)'SDL_TRACEBACK: Calling XL_TRBK, THRD = ',itid
  CALL xl__trbk()
  WRITE(0,*)'SDL_TRACEBACK: Done XL_TRBK, THRD = ',itid
#elif defined(__INTEL_COMPILER)
  WRITE(0,*)'SDL_TRACEBACK: Calling INTEL_TRBK, THRD = ',itid
  CALL intel_trbk() ! See ifsaux/utilities/gentrbk.F90
  WRITE(0,*)'SDL_TRACEBACK: Done INTEL_TRBK, THRD = ',itid
#elif defined(LINUX) || defined(SUN4)
  WRITE(0,*)'SDL_TRACEBACK: Calling LINUX_TRBK, THRD = ',itid
  CALL linux_trbk() ! See ifsaux/utilities/linuxtrbk.c
  WRITE(0,*)'SDL_TRACEBACK: Done LINUX_TRBK, THRD = ',itid
#elif defined(NECSX)
! MESPUT writes out onto unit 6
  WRITE(6,*)'SDL_TRACEBACK: Calling NEC/MESPUT, THRD = ',itid
  CALL necsx_trbk(clnecmsg)
  CALL flush(6)
  WRITE(6,*)'SDL_TRACEBACK: Done NEC/MESPUT, THRD = ',itid
#else
  WRITE(0,*)'SDL_TRACEBACK: No proper traceback implemented.'
  ! A traceback using dbx-debugger, if available AND 
  ! activated via 'export DBXDEBUGGER=1'
  WRITE(0,*)'SDL_TRACEBACK: Calling DBX_TRBK, THRD = ',itid
  CALL dbx_trbk() ! See ifsaux/utilities/linuxtrbk.c
  WRITE(0,*)'SDL_TRACEBACK: Done DBX_TRBK, THRD = ',itid
  ! A traceback using gdb-debugger, if available AND 
  ! activated via 'export GDBDEBUGGER=1'
  WRITE(0,*)'SDL_TRACEBACK: Calling GDB_TRBK, THRD = ',itid
  CALL gdb_trbk() ! See ifsaux/utilities/linuxtrbk.c
  WRITE(0,*)'SDL_TRACEBACK: Done GDB_TRBK, THRD = ',itid
#endif

END SUBROUTINE sdl_traceback
!-----------------------------------------------------------------------------
SUBROUTINE sdl_srlabort

! Purpose :
! -------
!   To abort in serial environment

CALL ec_raise(sigabrt)
stop 'SDL_SRLABORT'

END SUBROUTINE sdl_srlabort
!-----------------------------------------------------------------------------
SUBROUTINE sdl_disabort(KCOMM)

! Purpose :
! -------
!   To abort in distributed environment

!   KCOMM : communicator

INTEGER(KIND=JPIM), INTENT(IN) :: KCOMM

INTEGER(KIND=JPIM) :: IRETURN_CODE,IERROR

#ifdef VPP

CALL vpp_abort()

#else

ireturn_code=1
#ifdef SFX_MPI
CALL mpi_abort(kcomm,ireturn_code,ierror)
#endif
#endif

CALL ec_raise(sigabrt) ! In case ever ends up here
stop 'SDL_DISABORT'

END SUBROUTINE sdl_disabort
!-----------------------------------------------------------------------------

END MODULE sdl_mod