1 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
2 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
3 | !----------------------------------------------------------------------- |
---|
4 | ! CVS m_dropdead.F90,v 1.4 2007-01-10 03:04:46 rloy Exp |
---|
5 | ! CVS MCT_2_8_0 |
---|
6 | !----------------------------------------------------------------------- |
---|
7 | !BOP |
---|
8 | ! |
---|
9 | ! !MODULE: m_dropdead - An abort() with a style |
---|
10 | ! |
---|
11 | ! !DESCRIPTION: |
---|
12 | ! |
---|
13 | ! !INTERFACE: |
---|
14 | |
---|
15 | module m_dropdead |
---|
16 | implicit none |
---|
17 | private ! except |
---|
18 | |
---|
19 | public :: die ! terminate a program with a condition |
---|
20 | |
---|
21 | interface die; module procedure & |
---|
22 | die_, & |
---|
23 | diex_ |
---|
24 | end interface |
---|
25 | |
---|
26 | ! !REVISION HISTORY: |
---|
27 | ! 20Feb97 - Jing Guo <guo@eramus> - defined template |
---|
28 | !EOP |
---|
29 | !_______________________________________________________________________ |
---|
30 | |
---|
31 | contains |
---|
32 | |
---|
33 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
34 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
35 | !----------------------------------------------------------------------- |
---|
36 | !BOP |
---|
37 | ! !IROUTINE: die_ - Clean up and raise an exception to the OS |
---|
38 | ! |
---|
39 | ! !DESCRIPTION: |
---|
40 | ! |
---|
41 | ! A call to die() exits the program with minimum information for |
---|
42 | ! both the user and the operating system. |
---|
43 | ! |
---|
44 | ! !INTERFACE: |
---|
45 | |
---|
46 | subroutine die_(where) |
---|
47 | use m_stdio, only : stderr |
---|
48 | use m_mpif90,only : MP_comm_world |
---|
49 | use m_mpif90,only : MP_comm_rank |
---|
50 | use m_mpif90,only : MP_abort |
---|
51 | use m_mpif90,only : MP_initialized |
---|
52 | implicit none |
---|
53 | character(len=*),intent(in) :: where ! where it is called |
---|
54 | |
---|
55 | ! !REVISION HISTORY: |
---|
56 | ! 20Feb97 - Jing Guo <guo@eramus> - defined template |
---|
57 | ! 09Jan07 - R. Loy <rloy@mcs.anl.gov> - check for initialized, add |
---|
58 | ! options for abort |
---|
59 | ! |
---|
60 | !EOP |
---|
61 | !_______________________________________________________________________ |
---|
62 | |
---|
63 | character(len=*),parameter :: myname_='MCT(MPEU)::die.' |
---|
64 | integer :: myrank,ier |
---|
65 | logical :: initialized |
---|
66 | |
---|
67 | call MP_initialized(initialized,ier) |
---|
68 | |
---|
69 | if (initialized) then |
---|
70 | |
---|
71 | !------------------------------------------------- |
---|
72 | ! MPI_ should have been initialized for this call |
---|
73 | !------------------------------------------------- |
---|
74 | |
---|
75 | call MP_comm_rank(MP_comm_world,myrank,ier) |
---|
76 | |
---|
77 | ! a message for the users: |
---|
78 | |
---|
79 | write(stderr,'(z3.3,5a)') myrank,'.',myname_, & |
---|
80 | ': from ',trim(where),'()' |
---|
81 | |
---|
82 | ! raise a condition to the OS |
---|
83 | |
---|
84 | #ifdef ENABLE_UNIX_ABORT |
---|
85 | call abort |
---|
86 | #else |
---|
87 | call MP_abort(MP_comm_world,2,ier) |
---|
88 | #endif |
---|
89 | |
---|
90 | else |
---|
91 | |
---|
92 | write(stderr,'(5a)') 'unknown rank .',myname_, & |
---|
93 | ': from ',trim(where),'()' |
---|
94 | |
---|
95 | call abort |
---|
96 | |
---|
97 | endif |
---|
98 | |
---|
99 | end subroutine die_ |
---|
100 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
101 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
102 | !----------------------------------------------------------------------- |
---|
103 | !BOP |
---|
104 | ! |
---|
105 | ! !IROUTINE: diex_ - Clean up and raise an exception to the OS |
---|
106 | ! |
---|
107 | ! !DESCRIPTION: |
---|
108 | ! |
---|
109 | ! A call to die() exits the program with minimum information for |
---|
110 | ! both the user and the operating system. This implementation, |
---|
111 | ! however, may be used in conjunction with with a source preprocessor |
---|
112 | ! to produce more detailed location information. |
---|
113 | ! |
---|
114 | ! !INTERFACE: |
---|
115 | |
---|
116 | subroutine diex_(where,fnam,line) |
---|
117 | use m_stdio, only : stderr |
---|
118 | use m_mpif90,only : MP_comm_world |
---|
119 | use m_mpif90,only : MP_comm_rank |
---|
120 | use m_mpif90,only : MP_abort |
---|
121 | use m_mpif90,only : MP_initialized |
---|
122 | implicit none |
---|
123 | character(len=*),intent(in) :: where ! where it is called |
---|
124 | character(len=*),intent(in) :: fnam |
---|
125 | integer,intent(in) :: line |
---|
126 | |
---|
127 | ! !REVISION HISTORY: |
---|
128 | ! 20Feb97 - Jing Guo <guo@eramus> - defined template |
---|
129 | ! 09Jan07 - R. Loy <rloy@mcs.anl.gov> - check for initialized, add |
---|
130 | ! options for abort |
---|
131 | ! |
---|
132 | !EOP |
---|
133 | !_______________________________________________________________________ |
---|
134 | |
---|
135 | character(len=*),parameter :: myname_='die.' |
---|
136 | integer :: myrank,ier |
---|
137 | character(len=16) :: lineno |
---|
138 | |
---|
139 | logical :: initialized |
---|
140 | |
---|
141 | write(lineno,'(i16)') line |
---|
142 | |
---|
143 | call MP_initialized(initialized,ier) |
---|
144 | |
---|
145 | if (initialized) then |
---|
146 | |
---|
147 | !------------------------------------------------- |
---|
148 | ! MPI_ should have been initialized for this call |
---|
149 | !------------------------------------------------- |
---|
150 | |
---|
151 | call MP_comm_rank(MP_comm_world,myrank,ier) |
---|
152 | |
---|
153 | ! a message for the users: |
---|
154 | write(stderr,'(z3.3,9a)') myrank,'.',myname_, & |
---|
155 | ': from ',trim(where),'()', & |
---|
156 | ', line ',trim(adjustl(lineno)), & |
---|
157 | ' of file ',fnam |
---|
158 | |
---|
159 | ! raise a condition to the OS |
---|
160 | |
---|
161 | #ifdef ENABLE_UNIX_ABORT |
---|
162 | call abort |
---|
163 | #else |
---|
164 | call MP_abort(MP_comm_world,2,ier) |
---|
165 | #endif |
---|
166 | |
---|
167 | else |
---|
168 | |
---|
169 | ! a message for the users: |
---|
170 | write(stderr,'(9a)') 'unknown rank .',myname_, & |
---|
171 | ': from ',trim(where),'()', & |
---|
172 | ', line ',trim(adjustl(lineno)), & |
---|
173 | ' of file ',fnam |
---|
174 | |
---|
175 | call abort |
---|
176 | endif |
---|
177 | |
---|
178 | |
---|
179 | end subroutine diex_ |
---|
180 | !======================================================================= |
---|
181 | end module m_dropdead |
---|
182 | !. |
---|