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 |
---|