[3331] | 1 | MODULE SDL_MODULE |
---|
| 2 | |
---|
| 3 | ! Interface between user applications and system-dependent intrinsic |
---|
| 4 | ! routines, provided by the computer vendors. |
---|
| 5 | |
---|
| 6 | ! All routines which wish to call these routines must contain: |
---|
| 7 | ! USE SDL_MODULE |
---|
| 8 | |
---|
| 9 | ! Author : |
---|
| 10 | ! ------ |
---|
| 11 | ! 11-Apr-2005 R. El Khatib *METEO-FRANCE* |
---|
| 12 | ! 26-Apr-2006 S.T.Saarinen Dr.Hook trace, calls to EC_RAISE, Intel/ifort traceback |
---|
| 13 | |
---|
| 14 | USE PARKIND1 ,ONLY : JPIM ,JPRB |
---|
| 15 | USE YOMHOOK ,ONLY : LHOOK ,DR_HOOK |
---|
| 16 | USE YOMOML, ONLY : OML_MY_THREAD |
---|
| 17 | |
---|
| 18 | IMPLICIT NONE |
---|
| 19 | |
---|
| 20 | SAVE |
---|
| 21 | |
---|
| 22 | PRIVATE |
---|
| 23 | |
---|
| 24 | INTEGER, parameter :: SIGABRT = 6 ! Hardcoded |
---|
| 25 | |
---|
| 26 | PUBLIC :: SDL_SRLABORT, SDL_DISABORT, SDL_TRACEBACK |
---|
| 27 | |
---|
| 28 | CONTAINS |
---|
| 29 | |
---|
| 30 | !----------------------------------------------------------------------------- |
---|
| 31 | SUBROUTINE SDL_TRACEBACK(KTID) |
---|
| 32 | |
---|
| 33 | ! Purpose : |
---|
| 34 | ! ------- |
---|
| 35 | ! Traceback |
---|
| 36 | |
---|
| 37 | ! KTID : thread |
---|
| 38 | |
---|
| 39 | INTEGER(KIND=JPIM), INTENT(IN), OPTIONAL :: KTID |
---|
| 40 | CALL ABOR1('DANS SDL_TRACEBACK') ! MPL 8.12.08 et commente toute la suite |
---|
| 41 | !INTEGER(KIND=JPIM) ITID, IPRINT_OPTION, ILEVEL |
---|
| 42 | !#ifdef NECSX |
---|
| 43 | !CHARACTER(LEN=*), PARAMETER :: CLNECMSG = '*** Calling NEC traceback ***' |
---|
| 44 | !#endif |
---|
| 45 | ! |
---|
| 46 | !IF (PRESENT(KTID)) THEN |
---|
| 47 | ! ITID = KTID |
---|
| 48 | !ELSE |
---|
| 49 | ! ITID = OML_MY_THREAD() |
---|
| 50 | !ENDIF |
---|
| 51 | ! |
---|
| 52 | !IF (LHOOK) THEN |
---|
| 53 | ! IPRINT_OPTION = 2 |
---|
| 54 | ! ILEVEL = 0 |
---|
| 55 | ! CALL C_DRHOOK_PRINT(0, ITID, IPRINT_OPTION, ILEVEL) ! from drhook.c |
---|
| 56 | !ENDIF |
---|
| 57 | ! |
---|
| 58 | !#ifdef VPP |
---|
| 59 | ! CALL ERRTRA |
---|
| 60 | ! IF (PRESENT(KTID)) CALL SLEEP(28) |
---|
| 61 | !#elif RS6K |
---|
| 62 | ! WRITE(0,*)'SDL_TRACEBACK: Calling XL_TRBK, THRD = ',ITID |
---|
| 63 | ! CALL XL__TRBK() |
---|
| 64 | ! WRITE(0,*)'SDL_TRACEBACK: Done XL_TRBK, THRD = ',ITID |
---|
| 65 | !#elif __INTEL_COMPILER |
---|
| 66 | ! WRITE(0,*)'SDL_TRACEBACK: Calling INTEL_TRBK, THRD = ',ITID |
---|
| 67 | ! CALL INTEL_TRBK() ! See ifsaux/utilities/gentrbk.F90 |
---|
| 68 | ! WRITE(0,*)'SDL_TRACEBACK: Done INTEL_TRBK, THRD = ',ITID |
---|
| 69 | !#elif defined(LINUX) || defined(SUN4) |
---|
| 70 | ! WRITE(0,*)'SDL_TRACEBACK: Calling LINUX_TRBK, THRD = ',ITID |
---|
| 71 | ! CALL LINUX_TRBK() ! See ifsaux/utilities/linuxtrbk.c |
---|
| 72 | ! WRITE(0,*)'SDL_TRACEBACK: Done LINUX_TRBK, THRD = ',ITID |
---|
| 73 | !#elif defined(NECSX) |
---|
| 74 | ! WRITE(0,*)'SDL_TRACEBACK: Calling NEC/MESPUT, THRD = ',ITID |
---|
| 75 | ! CALL MESPUT(CLNECMSG, LEN(CLNECMSG), 1) |
---|
| 76 | ! WRITE(0,*)'SDL_TRACEBACK: Done NEC/MESPUT, THRD = ',ITID |
---|
| 77 | !#else |
---|
| 78 | ! WRITE(0,*)'SDL_TRACEBACK: No proper traceback implemented.' |
---|
| 79 | ! ! A traceback using dbx-debugger, if available AND |
---|
| 80 | ! ! activated via 'export DBXDEBUGGER=1' |
---|
| 81 | ! WRITE(0,*)'SDL_TRACEBACK: Calling DBX_TRBK, THRD = ',ITID |
---|
| 82 | ! CALL DBX_TRBK() ! See ifsaux/utilities/linuxtrbk.c |
---|
| 83 | ! WRITE(0,*)'SDL_TRACEBACK: Done DBX_TRBK, THRD = ',ITID |
---|
| 84 | ! ! A traceback using gdb-debugger, if available AND |
---|
| 85 | ! ! activated via 'export GDBDEBUGGER=1' |
---|
| 86 | ! WRITE(0,*)'SDL_TRACEBACK: Calling GDB_TRBK, THRD = ',ITID |
---|
| 87 | ! CALL GDB_TRBK() ! See ifsaux/utilities/linuxtrbk.c |
---|
| 88 | ! WRITE(0,*)'SDL_TRACEBACK: Done GDB_TRBK, THRD = ',ITID |
---|
| 89 | !#endif |
---|
| 90 | |
---|
| 91 | END SUBROUTINE SDL_TRACEBACK |
---|
| 92 | !----------------------------------------------------------------------------- |
---|
| 93 | SUBROUTINE SDL_SRLABORT |
---|
| 94 | |
---|
| 95 | ! Purpose : |
---|
| 96 | ! ------- |
---|
| 97 | ! To abort in serial environment |
---|
| 98 | |
---|
| 99 | !CALL EC_RAISE(SIGABRT) ! EC_RAISE remplace par ABOR1 MPL 8.12.08 |
---|
| 100 | CALL ABOR1('DANS SRLABORT') |
---|
| 101 | STOP 'SDL_SRLABORT' |
---|
| 102 | |
---|
| 103 | END SUBROUTINE SDL_SRLABORT |
---|
| 104 | !----------------------------------------------------------------------------- |
---|
| 105 | SUBROUTINE SDL_DISABORT(KCOMM) |
---|
| 106 | |
---|
| 107 | ! Purpose : |
---|
| 108 | ! ------- |
---|
| 109 | ! To abort in distributed environment |
---|
| 110 | |
---|
| 111 | ! KCOMM : communicator |
---|
| 112 | |
---|
| 113 | INTEGER(KIND=JPIM), INTENT(IN) :: KCOMM |
---|
| 114 | |
---|
| 115 | INTEGER(KIND=JPIM) :: IRETURN_CODE,IERROR |
---|
| 116 | |
---|
| 117 | !MPL 4.12.08 |
---|
| 118 | !#ifdef VPP |
---|
| 119 | ! |
---|
| 120 | !CALL VPP_ABORT() |
---|
| 121 | ! |
---|
| 122 | !#else |
---|
| 123 | ! |
---|
| 124 | !IRETURN_CODE=1 |
---|
| 125 | !CALL MPI_ABORT(KCOMM,IRETURN_CODE,IERROR) |
---|
| 126 | |
---|
| 127 | !#endif |
---|
| 128 | |
---|
| 129 | !CALL EC_RAISE(SIGABRT) ! In case ever ends up here |
---|
| 130 | CALL ABOR1('DANS SRLDISABORT') ! EC_RAISE remplace par ABOR1 MPL 8.12.08 |
---|
| 131 | STOP 'SDL_DISABORT' |
---|
| 132 | |
---|
| 133 | END SUBROUTINE SDL_DISABORT |
---|
| 134 | !----------------------------------------------------------------------------- |
---|
| 135 | |
---|
| 136 | END MODULE SDL_MODULE |
---|