MODULE SDL_MODULE ! 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_MODULE ! 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 YOMOML, 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 CALL ABOR1('DANS SDL_TRACEBACK') ! MPL 8.12.08 et commente toute la suite !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 ! !#ifdef VPP ! CALL ERRTRA ! IF (PRESENT(KTID)) CALL SLEEP(28) !#elif RS6K ! WRITE(0,*)'SDL_TRACEBACK: Calling XL_TRBK, THRD = ',ITID ! CALL XL__TRBK() ! WRITE(0,*)'SDL_TRACEBACK: Done XL_TRBK, THRD = ',ITID !#elif __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) ! WRITE(0,*)'SDL_TRACEBACK: Calling NEC/MESPUT, THRD = ',ITID ! CALL MESPUT(CLNECMSG, LEN(CLNECMSG), 1) ! WRITE(0,*)'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) ! EC_RAISE remplace par ABOR1 MPL 8.12.08 CALL ABOR1('DANS SRLABORT') 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 !MPL 4.12.08 !#ifdef VPP ! !CALL VPP_ABORT() ! !#else ! !IRETURN_CODE=1 !CALL MPI_ABORT(KCOMM,IRETURN_CODE,IERROR) !#endif !CALL EC_RAISE(SIGABRT) ! In case ever ends up here CALL ABOR1('DANS SRLDISABORT') ! EC_RAISE remplace par ABOR1 MPL 8.12.08 STOP 'SDL_DISABORT' END SUBROUTINE SDL_DISABORT !----------------------------------------------------------------------------- END MODULE SDL_MODULE