fortran_test_helper 1.0.0
A Fortran library to provide assistance to testing.
Loading...
Searching...
No Matches
fth_asserts.f90
1submodule(fortran_test_helper) fth_asserts
2contains
3! ******************************************************************************
4! REAL32 SUPPORT
5! ------------------------------------------------------------------------------
6 module function assert_r32(x, y, tol) result(rst)
7 ! Arguments
8 real(real32), intent(in) :: x, y
9 real(real32), intent(in), optional :: tol
10 logical :: rst
11
12 ! Local Variables
13 real(real32) :: t
14
15 ! Process
16 if (present(tol)) then
17 t = tol
18 else
19 t = sqrt(epsilon(t))
20 end if
21 rst = abs(x - y) < t
22 end function
23
24! ------------------------------------------------------------------------------
25 module function assert_r32_array(x, y, tol, flag) result(rst)
26 ! Arguments
27 real(real32), intent(in) :: x(:), y(:)
28 real(real32), intent(in), optional :: tol
29 integer(int32), intent(out), optional :: flag
30 logical :: rst
31
32 ! Local Variables
33 real(real32) :: t
34 integer(int32) :: i, n
35
36 ! Initialization
37 rst = .true.
38 if (present(flag)) flag = 0
39
40 ! Size Test
41 n = size(x)
42 if (size(y) /= n) then
43 rst = .false.
44 if (present(flag)) flag = -1
45 return
46 end if
47
48 ! Process
49 if (present(tol)) then
50 t = tol
51 else
52 t = sqrt(epsilon(t))
53 end if
54 do i = 1, n
55 if (abs(x(i) - y(i)) > t) then
56 rst = .false.
57 if (present(flag)) flag = i
58 exit
59 end if
60 end do
61 end function
62
63! ------------------------------------------------------------------------------
64 module function assert_r32_matrix(x, y, tol, flag, row, col) result(rst)
65 ! Arguments
66 real(real32), intent(in) :: x(:,:), y(:,:)
67 real(real32), intent(in), optional :: tol
68 integer(int32), intent(out), optional :: flag, row, col
69 logical :: rst
70
71 ! Local Variables
72 real(real32) :: t
73 integer(int32) :: i, j, m, n
74
75 ! Initialization
76 rst = .true.
77 if (present(flag)) flag = 0
78 if (present(row)) row = 0
79 if (present(col)) col = 0
80
81 ! Size Test
82 m = size(x, 1)
83 n = size(x, 2)
84 if (size(y, 1) /= m .or. size(y, 2) /= n) then
85 rst = .false.
86 if (present(flag)) flag = -1
87 return
88 end if
89
90 ! Process
91 if (present(tol)) then
92 t = tol
93 else
94 t = sqrt(epsilon(t))
95 end if
96 outer: do j = 1, n
97 do i = 1, m
98 if (abs(x(i,j) - y(i,j)) > t) then
99 rst = .false.
100 if (present(flag)) flag = m * (j - 1) + i
101 if (present(row)) row = i
102 if (present(col)) col = j
103 exit outer
104 end if
105 end do
106 end do outer
107 end function
108
109! ******************************************************************************
110! REAL64 SUPPORT
111! ------------------------------------------------------------------------------
112 module function assert_r64(x, y, tol) result(rst)
113 ! Arguments
114 real(real64), intent(in) :: x, y
115 real(real64), intent(in), optional :: tol
116 logical :: rst
117
118 ! Local Variables
119 real(real64) :: t
120
121 ! Process
122 if (present(tol)) then
123 t = tol
124 else
125 t = sqrt(epsilon(t))
126 end if
127 rst = abs(x - y) < t
128 end function
129
130! ------------------------------------------------------------------------------
131 module function assert_r64_array(x, y, tol, flag) result(rst)
132 ! Arguments
133 real(real64), intent(in) :: x(:), y(:)
134 real(real64), intent(in), optional :: tol
135 integer(int32), intent(out), optional :: flag
136 logical :: rst
137
138 ! Local Variables
139 real(real64) :: t
140 integer(int32) :: i, n
141
142 ! Initialization
143 rst = .true.
144 if (present(flag)) flag = 0
145
146 ! Size Test
147 n = size(x)
148 if (size(y) /= n) then
149 rst = .false.
150 if (present(flag)) flag = -1
151 return
152 end if
153
154 ! Process
155 if (present(tol)) then
156 t = tol
157 else
158 t = sqrt(epsilon(t))
159 end if
160 do i = 1, n
161 if (abs(x(i) - y(i)) > t) then
162 rst = .false.
163 if (present(flag)) flag = i
164 exit
165 end if
166 end do
167 end function
168
169! ------------------------------------------------------------------------------
170 module function assert_r64_matrix(x, y, tol, flag, row, col) result(rst)
171 ! Arguments
172 real(real64), intent(in) :: x(:,:), y(:,:)
173 real(real64), intent(in), optional :: tol
174 integer(int32), intent(out), optional :: flag, row, col
175 logical :: rst
176
177 ! Local Variables
178 real(real64) :: t
179 integer(int32) :: i, j, m, n
180
181 ! Initialization
182 rst = .true.
183 if (present(flag)) flag = 0
184 if (present(row)) row = 0
185 if (present(col)) col = 0
186
187 ! Size Test
188 m = size(x, 1)
189 n = size(x, 2)
190 if (size(y, 1) /= m .or. size(y, 2) /= n) then
191 rst = .false.
192 if (present(flag)) flag = -1
193 return
194 end if
195
196 ! Process
197 if (present(tol)) then
198 t = tol
199 else
200 t = sqrt(epsilon(t))
201 end if
202 outer: do j = 1, n
203 do i = 1, m
204 if (abs(x(i,j) - y(i,j)) > t) then
205 rst = .false.
206 if (present(flag)) flag = m * (j - 1) + i
207 if (present(row)) row = i
208 if (present(col)) col = j
209 exit outer
210 end if
211 end do
212 end do outer
213 end function
214
215! ******************************************************************************
216! COMPLEX32 SUPPORT
217! ------------------------------------------------------------------------------
218 module function assert_c32(x, y, tol) result(rst)
219 ! Arguments
220 complex(real32), intent(in) :: x, y
221 real(real32), intent(in), optional :: tol
222 logical :: rst
223
224 ! Local Variables
225 real(real32) :: t
226 complex(real32) :: delta
227
228 ! Process
229 if (present(tol)) then
230 t = tol
231 else
232 t = sqrt(epsilon(t))
233 end if
234 delta = x - y
235 rst = abs(real(delta)) < t .and. abs(aimag(delta)) < t
236 end function
237
238! ------------------------------------------------------------------------------
239 module function assert_c32_array(x, y, tol, flag) result(rst)
240 ! Arguments
241 complex(real32), intent(in) :: x(:), y(:)
242 real(real32), intent(in), optional :: tol
243 integer(int32), intent(out), optional :: flag
244 logical :: rst
245
246 ! Local Variables
247 real(real32) :: t
248 complex(real32) :: delta
249 integer(int32) :: i, n
250
251 ! Initialization
252 rst = .true.
253 if (present(flag)) flag = 0
254
255 ! Size Test
256 n = size(x)
257 if (size(y) /= n) then
258 rst = .false.
259 if (present(flag)) flag = -1
260 return
261 end if
262
263 ! Process
264 if (present(tol)) then
265 t = tol
266 else
267 t = sqrt(epsilon(t))
268 end if
269 do i = 1, n
270 delta = x(i) - y(i)
271 if (abs(real(delta)) > t .or. abs(aimag(delta)) > t) then
272 rst = .false.
273 if (present(flag)) flag = i
274 exit
275 end if
276 end do
277 end function
278
279! ------------------------------------------------------------------------------
280 module function assert_c32_matrix(x, y, tol, flag, row, col) result(rst)
281 ! Arguments
282 complex(real32), intent(in) :: x(:,:), y(:,:)
283 real(real32), intent(in), optional :: tol
284 integer(int32), intent(out), optional :: flag, row, col
285 logical :: rst
286
287 ! Local Variables
288 real(real32) :: t
289 complex(real32) :: delta
290 integer(int32) :: i, j, m, n
291
292 ! Initialization
293 rst = .true.
294 if (present(flag)) flag = 0
295 if (present(row)) row = 0
296 if (present(col)) col = 0
297
298 ! Size Test
299 m = size(x, 1)
300 n = size(x, 2)
301 if (size(y, 1) /= m .or. size(y, 2) /= n) then
302 rst = .false.
303 if (present(flag)) flag = -1
304 return
305 end if
306
307 ! Process
308 if (present(tol)) then
309 t = tol
310 else
311 t = sqrt(epsilon(t))
312 end if
313 outer: do j = 1, n
314 do i = 1, m
315 delta = x(i,j) - y(i,j)
316 if (abs(real(delta)) > t .or. abs(aimag(delta)) > t) then
317 rst = .false.
318 if (present(flag)) flag = m * (j - 1) + i
319 if (present(row)) row = i
320 if (present(col)) col = j
321 exit outer
322 end if
323 end do
324 end do outer
325 end function
326
327! ******************************************************************************
328! COMPLEX64 SUPPORT
329! ------------------------------------------------------------------------------
330 module function assert_c64(x, y, tol) result(rst)
331 ! Arguments
332 complex(real64), intent(in) :: x, y
333 real(real64), intent(in), optional :: tol
334 logical :: rst
335
336 ! Local Variables
337 real(real64) :: t
338 complex(real64) :: delta
339
340 ! Process
341 if (present(tol)) then
342 t = tol
343 else
344 t = sqrt(epsilon(t))
345 end if
346 delta = x - y
347 rst = abs(real(delta)) < t .and. abs(aimag(delta)) < t
348 end function
349
350! ------------------------------------------------------------------------------
351 module function assert_c64_array(x, y, tol, flag) result(rst)
352 ! Arguments
353 complex(real64), intent(in) :: x(:), y(:)
354 real(real64), intent(in), optional :: tol
355 integer(int32), intent(out), optional :: flag
356 logical :: rst
357
358 ! Local Variables
359 real(real64) :: t
360 complex(real64) :: delta
361 integer(int32) :: i, n
362
363 ! Initialization
364 rst = .true.
365 if (present(flag)) flag = 0
366
367 ! Size Test
368 n = size(x)
369 if (size(y) /= n) then
370 rst = .false.
371 if (present(flag)) flag = -1
372 return
373 end if
374
375 ! Process
376 if (present(tol)) then
377 t = tol
378 else
379 t = sqrt(epsilon(t))
380 end if
381 do i = 1, n
382 delta = x(i) - y(i)
383 if (abs(real(delta)) > t .or. abs(aimag(delta)) > t) then
384 rst = .false.
385 if (present(flag)) flag = i
386 exit
387 end if
388 end do
389 end function
390
391! ------------------------------------------------------------------------------
392 module function assert_c64_matrix(x, y, tol, flag, row, col) result(rst)
393 ! Arguments
394 complex(real64), intent(in) :: x(:,:), y(:,:)
395 real(real64), intent(in), optional :: tol
396 integer(int32), intent(out), optional :: flag, row, col
397 logical :: rst
398
399 ! Local Variables
400 real(real64) :: t
401 complex(real64) :: delta
402 integer(int32) :: i, j, m, n
403
404 ! Initialization
405 rst = .true.
406 if (present(flag)) flag = 0
407 if (present(row)) row = 0
408 if (present(col)) col = 0
409
410 ! Size Test
411 m = size(x, 1)
412 n = size(x, 2)
413 if (size(y, 1) /= m .or. size(y, 2) /= n) then
414 rst = .false.
415 if (present(flag)) flag = -1
416 return
417 end if
418
419 ! Process
420 if (present(tol)) then
421 t = tol
422 else
423 t = sqrt(epsilon(t))
424 end if
425 outer: do j = 1, n
426 do i = 1, m
427 delta = x(i,j) - y(i,j)
428 if (abs(real(delta)) > t .or. abs(aimag(delta)) > t) then
429 rst = .false.
430 if (present(flag)) flag = m * (j - 1) + i
431 if (present(row)) row = i
432 if (present(col)) col = j
433 exit outer
434 end if
435 end do
436 end do outer
437 end function
438
439! ******************************************************************************
440! INT16 SUPPORT
441! ------------------------------------------------------------------------------
442 module function assert_i16(x, y) result(rst)
443 ! Arguments
444 integer(int16), intent(in) :: x, y
445 logical :: rst
446
447 ! Process
448 rst = x == y
449 end function
450
451! ------------------------------------------------------------------------------
452 module function assert_i16_array(x, y, flag) result(rst)
453 ! Arguments
454 integer(int16), intent(in) :: x(:), y(:)
455 integer(int32), intent(out), optional :: flag
456 logical :: rst
457
458 ! Local Variables
459 integer(int32) :: i, n
460
461 ! Process
462 rst = .true.
463 if (present(flag)) flag = 0
464 n = size(x)
465 if (size(y) /= n) then
466 rst = .false.
467 if (present(flag)) flag = -1
468 return
469 end if
470
471 do i = 1, n
472 if (x(i) /= y(i)) then
473 rst = .false.
474 if (present(flag)) flag = i
475 exit
476 end if
477 end do
478 end function
479
480! ------------------------------------------------------------------------------
481 module function assert_i16_matrix(x, y, flag, row, col) result(rst)
482 ! Arguments
483 integer(int16), intent(in) :: x(:,:), y(:,:)
484 integer(int32), intent(out), optional :: flag, row, col
485 logical :: rst
486
487 ! Local Variables
488 integer(int32) :: i, j, m, n
489
490 ! Process
491 rst = .true.
492 if (present(flag)) flag = 0
493 if (present(row)) row = 0
494 if (present(col)) col = 0
495 m = size(x, 1)
496 n = size(x, 2)
497 if (size(y, 1) /= m .or. size(y, 2) /= n) then
498 rst = .false.
499 if (present(flag)) flag = -1
500 return
501 end if
502
503 outer: do j = 1, n
504 do i = 1, m
505 if (x(i,j) /= y(i,j)) then
506 rst = .false.
507 if (present(flag)) flag = m * (j - 1) + i
508 if (present(row)) row = i
509 if (present(col)) col = j
510 exit outer
511 end if
512 end do
513 end do outer
514 end function
515
516! ******************************************************************************
517! INT32 SUPPORT
518! ------------------------------------------------------------------------------
519 module function assert_i32(x, y) result(rst)
520 ! Arguments
521 integer(int32), intent(in) :: x, y
522 logical :: rst
523
524 ! Process
525 rst = x == y
526 end function
527
528! ------------------------------------------------------------------------------
529 module function assert_i32_array(x, y, flag) result(rst)
530 ! Arguments
531 integer(int32), intent(in) :: x(:), y(:)
532 integer(int32), intent(out), optional :: flag
533 logical :: rst
534
535 ! Local Variables
536 integer(int32) :: i, n
537
538 ! Process
539 rst = .true.
540 if (present(flag)) flag = 0
541 n = size(x)
542 if (size(y) /= n) then
543 rst = .false.
544 if (present(flag)) flag = -1
545 return
546 end if
547
548 do i = 1, n
549 if (x(i) /= y(i)) then
550 rst = .false.
551 if (present(flag)) flag = i
552 exit
553 end if
554 end do
555 end function
556
557! ------------------------------------------------------------------------------
558 module function assert_i32_matrix(x, y, flag, row, col) result(rst)
559 ! Arguments
560 integer(int32), intent(in) :: x(:,:), y(:,:)
561 integer(int32), intent(out), optional :: flag, row, col
562 logical :: rst
563
564 ! Local Variables
565 integer(int32) :: i, j, m, n
566
567 ! Process
568 rst = .true.
569 if (present(flag)) flag = 0
570 if (present(row)) row = 0
571 if (present(col)) col = 0
572 m = size(x, 1)
573 n = size(x, 2)
574 if (size(y, 1) /= m .or. size(y, 2) /= n) then
575 rst = .false.
576 if (present(flag)) flag = -1
577 return
578 end if
579
580 outer: do j = 1, n
581 do i = 1, m
582 if (x(i,j) /= y(i,j)) then
583 rst = .false.
584 if (present(flag)) flag = m * (j - 1) + i
585 if (present(row)) row = i
586 if (present(col)) col = j
587 exit outer
588 end if
589 end do
590 end do outer
591 end function
592
593! ******************************************************************************
594! INT64 SUPPORT
595! ------------------------------------------------------------------------------
596 module function assert_i64(x, y) result(rst)
597 ! Arguments
598 integer(int64), intent(in) :: x, y
599 logical :: rst
600
601 ! Process
602 rst = x == y
603 end function
604
605! ------------------------------------------------------------------------------
606 module function assert_i64_array(x, y, flag) result(rst)
607 ! Arguments
608 integer(int64), intent(in) :: x(:), y(:)
609 integer(int32), intent(out), optional :: flag
610 logical :: rst
611
612 ! Local Variables
613 integer(int32) :: i, n
614
615 ! Process
616 rst = .true.
617 if (present(flag)) flag = 0
618 n = size(x)
619 if (size(y) /= n) then
620 rst = .false.
621 if (present(flag)) flag = -1
622 return
623 end if
624
625 do i = 1, n
626 if (x(i) /= y(i)) then
627 rst = .false.
628 if (present(flag)) flag = i
629 exit
630 end if
631 end do
632 end function
633
634! ------------------------------------------------------------------------------
635 module function assert_i64_matrix(x, y, flag, row, col) result(rst)
636 ! Arguments
637 integer(int64), intent(in) :: x(:,:), y(:,:)
638 integer(int32), intent(out), optional :: flag, row, col
639 logical :: rst
640
641 ! Local Variables
642 integer(int32) :: i, j, m, n
643
644 ! Process
645 rst = .true.
646 if (present(flag)) flag = 0
647 if (present(row)) row = 0
648 if (present(col)) col = 0
649 m = size(x, 1)
650 n = size(x, 2)
651 if (size(y, 1) /= m .or. size(y, 2) /= n) then
652 rst = .false.
653 if (present(flag)) flag = -1
654 return
655 end if
656
657 outer: do j = 1, n
658 do i = 1, m
659 if (x(i,j) /= y(i,j)) then
660 rst = .false.
661 if (present(flag)) flag = m * (j - 1) + i
662 if (present(row)) row = i
663 if (present(col)) col = j
664 exit outer
665 end if
666 end do
667 end do outer
668 end function
669
670! ------------------------------------------------------------------------------
671end submodule
A collection of routines to assist in testing.