File: /nfs/home/0/users/jenkins/mfix.git/model/dmp_modules/debug_mod.f
1 module debug
2
3 USE funits
4
5 implicit none
6
7 integer :: idebug = 0
8
9 interface assert
10 module procedure assert_i, assert_d, assert_i2, assert_d2
11 end interface
12
13
14
15 interface write_debug
16 module procedure write_debug_0i, write_debug_0d, write_debug_0, &
17 write_debug_1i, write_debug_1d, write_debug_0l
18 end interface
19
20
21 contains
22
23
24
25 subroutine debug_init(myPE)
26 integer, intent(in) :: myPE
27
28 character(LEN=80) :: filename
29
30 write(filename,'("debug",f6.3)') dble(myPE)/dble(1000)
31 print*,'filename ', filename
32
33 open(unit_log, file=filename, access='sequential',form='formatted')
34 rewind(unit_log)
35
36 return
37 end subroutine debug_init
38
39
40 subroutine assert_i( lcond, msg, value )
41 logical, intent(in) :: lcond
42 character(len=*), intent(in) :: msg
43 integer, intent(in) :: value
44
45 if (.not. lcond) then
46 print*,'Assertion error: ', msg, value
47 stop '** ERROR ** '
48 endif
49
50 return
51 end subroutine assert_i
52
53
54 subroutine assert_i2( lcond, msg, value, value2 )
55 logical, intent(in) :: lcond
56 character(len=*), intent(in) :: msg
57 integer, intent(in) :: value, value2
58
59 if (.not. lcond) then
60 print*,'Assertion error: ', msg, value, value2
61 stop '** ERROR ** '
62 endif
63
64 return
65 end subroutine assert_i2
66
67
68
69
70 subroutine assert_d( lcond, msg, value )
71 logical, intent(in) :: lcond
72 character(len=*), intent(in) :: msg
73 double precision, intent(in) :: value
74
75 if (.not. lcond) then
76 print*,'Assertion error: ', msg, value
77 stop '** ERROR ** '
78 endif
79
80 return
81 end subroutine assert_d
82
83 subroutine assert_d2( lcond, msg, value, value2 )
84 logical, intent(in) :: lcond
85 character(len=*), intent(in) :: msg
86 double precision, intent(in) :: value, value2
87
88 if (.not. lcond) then
89 print*,'Assertion error: ', msg, value, value2
90 stop '** ERROR ** '
91 endif
92
93 return
94 end subroutine assert_d2
95
96
97 subroutine write_debug_0( name, msg )
98 character(len=*), intent(in) :: name, msg
99
100 character(len=80) :: line(1)
101
102 line(1) = msg
103 call write_error( name, line, 1 )
104
105 return
106 end subroutine write_debug_0
107
108 subroutine write_debug_1i( name, msg, x )
109 character(len=*), intent(in) :: name, msg
110 integer, intent(in), dimension(:) :: x
111
112
113
114
115 character(len=80) :: line(1+size(x))
116 integer :: i, ip
117
118 line(1) = " "
119 line(1) = msg
120
121 ip = 2
122 do i=lbound(x,1),ubound(x,1)
123 line(ip) = " "
124 write(line(ip), 9001) i, x(i)
125 9001 format('i = ', i7,' value = ', i9 )
126
127 ip = ip + 1
128 enddo
129
130 call write_error( name, line, 1+size(x) )
131 return
132 end subroutine write_debug_1i
133
134
135 subroutine write_debug_1d( name, msg, x )
136 character(len=*), intent(in) :: name, msg
137 double precision, intent(in), dimension(:) :: x
138
139
140
141
142 character(len=80) :: line(1+size(x))
143 integer :: i, ip
144
145 line(1) = " "
146 line(1) = msg
147
148 ip = 2
149 do i=lbound(x,1),ubound(x,1)
150 line(ip) = " "
151 write(line(ip), 9001) i, x(i)
152 9001 format('i = ', i7,' value = ', 1pd30.10 )
153
154 ip = ip + 1
155 enddo
156
157 call write_error( name, line, 1+size(x) )
158 return
159 end subroutine write_debug_1d
160
161
162
163 subroutine write_debug_0i(name, msg, x1, x2, x3, x4 )
164 character(len=*), intent(in) :: name, msg
165 integer, intent(in) :: x1
166 integer, intent(in), optional :: x2,x3,x4
167
168 character(len=80) :: line(1)
169 integer :: narg
170
171 narg = 1
172 if (present(x2)) then
173 narg = narg + 1
174 endif
175 if (present(x3)) then
176 narg = narg + 1
177 endif
178 if (present(x4)) then
179 narg = narg + 1
180 endif
181
182 select case ( narg )
183 case (1)
184 write(line(1),*) msg, x1
185 case (2)
186 write(line(1),*) msg, x1, x2
187 case (3)
188 write(line(1),*) msg, x1, x2, x3
189 case (4)
190 write(line(1),*) msg, x1, x2, x3, x4
191 case default
192 write(line(1),*) msg
193 end select
194
195 call write_error( name, line, 1 )
196
197 return
198 end subroutine write_debug_0i
199
200
201
202 subroutine write_debug_0d(name, msg, x1, x2, x3, x4 )
203 character(len=*), intent(in) :: name, msg
204 double precision, intent(in) :: x1
205 double precision, intent(in), optional :: x2,x3,x4
206
207 character(len=80) :: line(1)
208 integer :: narg
209
210 narg = 1
211 if (present(x2)) then
212 narg = narg + 1
213 endif
214 if (present(x3)) then
215 narg = narg + 1
216 endif
217 if (present(x4)) then
218 narg = narg + 1
219 endif
220
221 select case ( narg )
222 case (1)
223 write(line(1),*) msg, x1
224 case (2)
225 write(line(1),*) msg, x1, x2
226 case (3)
227 write(line(1),*) msg, x1, x2, x3
228 case (4)
229 write(line(1),*) msg, x1, x2, x3, x4
230 case default
231 write(line(1),*) msg
232 end select
233
234 call write_error( name, line, 1 )
235
236 return
237 end subroutine write_debug_0d
238
239 subroutine write_debug_0l(name, msg, x1, x2, x3, x4 )
240 character(len=*), intent(in) :: name, msg
241 logical, intent(in) :: x1
242 logical, intent(in), optional :: x2,x3,x4
243
244 character(len=80) :: line(1)
245 integer :: narg
246
247 narg = 1
248 if (present(x2)) then
249 narg = narg + 1
250 endif
251 if (present(x3)) then
252 narg = narg + 1
253 endif
254 if (present(x4)) then
255 narg = narg + 1
256 endif
257
258 select case ( narg )
259 case (1)
260 write(line(1),*) msg, x1
261 case (2)
262 write(line(1),*) msg, x1, x2
263 case (3)
264 write(line(1),*) msg, x1, x2, x3
265 case (4)
266 write(line(1),*) msg, x1, x2, x3, x4
267 case default
268 write(line(1),*) msg
269 end select
270
271 call write_error( name, line, 1 )
272
273 return
274 end subroutine write_debug_0l
275
276
277
278
279
280 subroutine write_error( name, line, lmax )
281 integer, intent(in) :: lmax
282 character(len=*) name,line(*)
283
284 integer :: L
285
286
287 WRITE (UNIT_LOG, 1000) NAME
288 DO L = 1, LMAX
289 WRITE (UNIT_LOG, 1010) LINE(L)
290 END DO
291 WRITE (UNIT_LOG, 1020)
292 flush(UNIT_LOG)
293
294 RETURN
295 1000 FORMAT(1X,70('*'),/,/,1X,'From : ',A)
296 1010 FORMAT(1X,A)
297 1020 FORMAT(/,/,1X,70('*'))
298 END SUBROUTINE WRITE_ERROR
299
300
301
302 end module debug
303
304