1 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
2 | ! Math and Computer Science Division, Argonne National Laboratory ! |
---|
3 | !----------------------------------------------------------------------- |
---|
4 | ! CVS m_TraceBack.F90,v 1.3 2004-04-21 22:54:46 jacob Exp |
---|
5 | ! CVS MCT_2_8_0 |
---|
6 | !BOP ------------------------------------------------------------------- |
---|
7 | ! |
---|
8 | ! !MODULE: m_TraceBack - Generation of Traceback Information |
---|
9 | ! |
---|
10 | ! !DESCRIPTION: |
---|
11 | ! This module supports the generation of traceback information for |
---|
12 | ! a given routine. |
---|
13 | ! |
---|
14 | ! |
---|
15 | ! !INTERFACE: |
---|
16 | |
---|
17 | module m_TraceBack |
---|
18 | |
---|
19 | ! !USES: |
---|
20 | ! No external modules are used in the declaration section of this module. |
---|
21 | |
---|
22 | implicit none |
---|
23 | |
---|
24 | private ! except |
---|
25 | |
---|
26 | ! !PUBLIC TYPES: |
---|
27 | ! No public types are declared in this module. |
---|
28 | |
---|
29 | |
---|
30 | ! !PUBLIC MEMBER FUNCTIONS: |
---|
31 | |
---|
32 | public :: GenTraceBackString |
---|
33 | |
---|
34 | interface GenTraceBackString; module procedure & |
---|
35 | GenTraceBackString1, & |
---|
36 | GenTraceBackString2 |
---|
37 | end interface |
---|
38 | |
---|
39 | ! !PUBLIC DATA MEMBERS: |
---|
40 | ! No public data member constants are declared in this module. |
---|
41 | |
---|
42 | |
---|
43 | ! !REVISION HISTORY: |
---|
44 | ! 5 Aug02 - J. Larson <larson@mcs.anl.gov> - Initial version. |
---|
45 | !EOP ___________________________________________________________________ |
---|
46 | |
---|
47 | ! Parameters local to this module: |
---|
48 | |
---|
49 | character(len=*),parameter :: myname='MCT(MPEU)::m_TraceBackString' |
---|
50 | |
---|
51 | character(len=len('|X|')), parameter :: StartChar = '|X|' |
---|
52 | character(len=len('->')), parameter :: ArrowChar = '->' |
---|
53 | |
---|
54 | contains |
---|
55 | |
---|
56 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
57 | ! Math and Computer Science Division, Argonne National Laboratory ! |
---|
58 | !BOP ------------------------------------------------------------------- |
---|
59 | ! |
---|
60 | ! !IROUTINE: GenTraceBackString1 - Start a TraceBack with One Routine Name |
---|
61 | ! |
---|
62 | ! !DESCRIPTION: |
---|
63 | ! This routine takes in CHARACTER form the names of the calling routine |
---|
64 | ! (the input argument {\tt RoutineName} and returns a {\tt String} |
---|
65 | ! (the output argument {\tt TraceBackString}) that portrays this routine |
---|
66 | ! as the starting point of a downwards procedural trace. The contents |
---|
67 | ! of {\tt TraceBackString} is merely an {\tt '|X|'}, followed immediately |
---|
68 | ! by the value of {\tt RoutineName}. |
---|
69 | ! |
---|
70 | ! !INTERFACE: |
---|
71 | |
---|
72 | subroutine GenTraceBackString1(TraceBackString, RoutineName) |
---|
73 | ! |
---|
74 | ! !USES: |
---|
75 | ! |
---|
76 | use m_stdio |
---|
77 | use m_die |
---|
78 | |
---|
79 | use m_String, only : String |
---|
80 | use m_String, only : String_init => init |
---|
81 | |
---|
82 | implicit none |
---|
83 | |
---|
84 | ! !INPUT PARAMETERS: |
---|
85 | ! |
---|
86 | character(len=*), intent(in) :: RoutineName |
---|
87 | |
---|
88 | ! !OUTPUT PARAMETERS: |
---|
89 | ! |
---|
90 | type(String), intent(out) :: TraceBackString |
---|
91 | |
---|
92 | ! !REVISION HISTORY: |
---|
93 | ! 5Aug02 - J. Larson <larson@mcs.anl.gov> - Initial version. |
---|
94 | !EOP ___________________________________________________________________ |
---|
95 | |
---|
96 | character(len=*),parameter :: myname_=myname//'::GenTraceBackString1' |
---|
97 | integer :: i, ierr |
---|
98 | integer :: RoutineNameLength, ScratchBufferLength |
---|
99 | character, dimension(:), allocatable :: ScratchBuffer |
---|
100 | |
---|
101 | ! Note: The value of ArrowChar is inherited |
---|
102 | ! from the declaration section of this module. |
---|
103 | |
---|
104 | ! Determine the lengths of ParentName and ChildName |
---|
105 | |
---|
106 | RoutineNameLength = len(RoutineName) |
---|
107 | |
---|
108 | ! Set up ScratchBuffer: |
---|
109 | |
---|
110 | ScratchBufferLength = len(StartChar) + RoutineNameLength |
---|
111 | |
---|
112 | allocate(ScratchBuffer(ScratchBufferLength), stat=ierr) |
---|
113 | if(ierr /= 0) then |
---|
114 | write(stderr,'(2a,i8)') myname_, & |
---|
115 | ':: Allocate(ScratchBuffer...) failed. ierr = ',ierr |
---|
116 | call die(myname_) |
---|
117 | endif |
---|
118 | |
---|
119 | ! Load ScratchBuffer: |
---|
120 | |
---|
121 | |
---|
122 | do i=1,len(StartChar) ! Load the '|X|'... |
---|
123 | ScratchBuffer(i) = StartChar(i:i) |
---|
124 | end do |
---|
125 | |
---|
126 | do i=1,RoutineNameLength |
---|
127 | ScratchBuffer(len(StartChar)+i) = RoutineName(i:i) |
---|
128 | end do |
---|
129 | |
---|
130 | ! Create TraceBackString |
---|
131 | |
---|
132 | call String_init(TraceBackString, ScratchBuffer) |
---|
133 | |
---|
134 | ! Clean up: |
---|
135 | |
---|
136 | deallocate(ScratchBuffer, stat=ierr) |
---|
137 | if(ierr /= 0) then |
---|
138 | write(stderr,'(2a,i8)') myname_, & |
---|
139 | ':: Deallocate(ScratchBuffer...) failed. ierr = ',ierr |
---|
140 | call die(myname_) |
---|
141 | endif |
---|
142 | |
---|
143 | end subroutine GenTraceBackString1 |
---|
144 | |
---|
145 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
146 | ! Math and Computer Science Division, Argonne National Laboratory ! |
---|
147 | !BOP ------------------------------------------------------------------- |
---|
148 | ! |
---|
149 | ! !IROUTINE: GenTraceBackString2 - Connect Two Routine Names in a TraceBack |
---|
150 | ! |
---|
151 | ! !DESCRIPTION: |
---|
152 | ! This routine takes in CHARACTER form the names of the parent and |
---|
153 | ! child routines (the input arguments {\tt ParentName} and |
---|
154 | ! {\tt ChildName}, repsectively), and returns a {\tt String} (the output |
---|
155 | ! argument {\tt TraceBackString}) that portrays their procedural |
---|
156 | ! relationship. The contents of {\tt TraceBackString} is merely |
---|
157 | ! {\tt ParentName}, followe by an arrow ({\tt "->"}), followed by |
---|
158 | ! {\tt ChildName}. |
---|
159 | ! |
---|
160 | ! !INTERFACE: |
---|
161 | |
---|
162 | subroutine GenTraceBackString2(TraceBackString, ParentName, ChildName) |
---|
163 | ! |
---|
164 | ! !USES: |
---|
165 | ! |
---|
166 | use m_stdio |
---|
167 | use m_die |
---|
168 | |
---|
169 | use m_String, only : String |
---|
170 | use m_String, only : String_init => init |
---|
171 | |
---|
172 | implicit none |
---|
173 | |
---|
174 | ! !INPUT PARAMETERS: |
---|
175 | ! |
---|
176 | character(len=*), intent(in) :: ParentName |
---|
177 | character(len=*), intent(in) :: ChildName |
---|
178 | |
---|
179 | ! !OUTPUT PARAMETERS: |
---|
180 | ! |
---|
181 | type(String), intent(out) :: TraceBackString |
---|
182 | |
---|
183 | ! !REVISION HISTORY: |
---|
184 | ! 5Aug02 - J. Larson <larson@mcs.anl.gov> - Initial version. |
---|
185 | !EOP ___________________________________________________________________ |
---|
186 | |
---|
187 | character(len=*),parameter :: myname_=myname//'::GenTraceBackString2' |
---|
188 | integer :: i, ierr |
---|
189 | integer :: ParentNameLength, ChildNameLength, ScratchBufferLength |
---|
190 | character, dimension(:), allocatable :: ScratchBuffer |
---|
191 | |
---|
192 | ! Note: The value of ArrowChar is inherited |
---|
193 | ! from the declaration section of this module. |
---|
194 | |
---|
195 | ! Determine the lengths of ParentName and ChildName |
---|
196 | |
---|
197 | ParentNameLength = len(ParentName) |
---|
198 | ChildNameLength = len(ChildName) |
---|
199 | |
---|
200 | ! Set up ScratchBuffer: |
---|
201 | |
---|
202 | ScratchBufferLength = ParentNameLength + ChildNameLength + & |
---|
203 | len(ArrowChar) |
---|
204 | allocate(ScratchBuffer(ScratchBufferLength), stat=ierr) |
---|
205 | if(ierr /= 0) then |
---|
206 | write(stderr,'(2a,i8)') myname_, & |
---|
207 | ':: Allocate(ScratchBuffer...) failed. ierr = ',ierr |
---|
208 | call die(myname_) |
---|
209 | endif |
---|
210 | |
---|
211 | ! Load ScratchBuffer: |
---|
212 | |
---|
213 | do i=1,ParentNameLength ! Load the Parent Routine Name... |
---|
214 | ScratchBuffer(i) = ParentName(i:i) |
---|
215 | end do |
---|
216 | |
---|
217 | do i=1,len(ArrowChar) ! Load the Arrow... |
---|
218 | ScratchBuffer(ParentNameLength+i) = ArrowChar(i:i) |
---|
219 | end do |
---|
220 | |
---|
221 | do i=1,ChildNameLength |
---|
222 | ScratchBuffer(ParentNameLength+len(ArrowChar)+i) = ChildName(i:i) |
---|
223 | end do |
---|
224 | |
---|
225 | ! Create TraceBackString |
---|
226 | |
---|
227 | call String_init(TraceBackString, ScratchBuffer) |
---|
228 | |
---|
229 | ! Clean up: |
---|
230 | |
---|
231 | deallocate(ScratchBuffer, stat=ierr) |
---|
232 | if(ierr /= 0) then |
---|
233 | write(stderr,'(2a,i8)') myname_, & |
---|
234 | ':: Deallocate(ScratchBuffer...) failed. ierr = ',ierr |
---|
235 | call die(myname_) |
---|
236 | endif |
---|
237 | |
---|
238 | end subroutine GenTraceBackString2 |
---|
239 | |
---|
240 | end module m_TraceBack |
---|