gtool5 Fortran 90/95 Library 1.0.0-rc5
日本語
Loading...
Searching...
No Matches
dc_test.f90
Go to the documentation of this file.
1!--
2! *** Caution!! ***
3!
4! This file is generated from "dc_test.rb2f90" by Ruby 3.3.8.
5! Please do not edit this file directly.
6!
7! [JAPANESE]
8!
9! ※※※ 注意!!! ※※※
10!
11! このファイルは "dc_test.rb2f90" から Ruby 3.3.8
12! によって自動生成されたファイルです.
13! このファイルを直接編集しませんようお願い致します.
14!
15!
16!++
30
31module dc_test
155 use dc_types, only : string, dp
156 implicit none
157 private
158 public assertequal, assertgreaterthan, assertlessthan
159
160 interface assertequal
161 module procedure dctestassertequalchar0
162
163 module procedure dctestassertequalchar1
164
165 module procedure dctestassertequalchar2
166
167 module procedure dctestassertequalchar3
168
169 module procedure dctestassertequalchar4
170
171 module procedure dctestassertequalchar5
172
173 module procedure dctestassertequalchar6
174
175 module procedure dctestassertequalchar7
176
177
178 module procedure dctestassertequalint0
179
180 module procedure dctestassertequalint1
181
182 module procedure dctestassertequalint2
183
184 module procedure dctestassertequalint3
185
186 module procedure dctestassertequalint4
187
188 module procedure dctestassertequalint5
189
190 module procedure dctestassertequalint6
191
192 module procedure dctestassertequalint7
193
194
195 module procedure dctestassertequalreal0
196
197 module procedure dctestassertequalreal1
198
199 module procedure dctestassertequalreal2
200
201 module procedure dctestassertequalreal3
202
203 module procedure dctestassertequalreal4
204
205 module procedure dctestassertequalreal5
206
207 module procedure dctestassertequalreal6
208
209 module procedure dctestassertequalreal7
210
211
212 module procedure dctestassertequaldouble0
213
214 module procedure dctestassertequaldouble1
215
216 module procedure dctestassertequaldouble2
217
218 module procedure dctestassertequaldouble3
219
220 module procedure dctestassertequaldouble4
221
222 module procedure dctestassertequaldouble5
223
224 module procedure dctestassertequaldouble6
225
226 module procedure dctestassertequaldouble7
227
228
229
230 module procedure dctestassertequallogical0
231
232 module procedure dctestassertequallogical1
233
234 module procedure dctestassertequallogical2
235
236 module procedure dctestassertequallogical3
237
238 module procedure dctestassertequallogical4
239
240 module procedure dctestassertequallogical5
241
242 module procedure dctestassertequallogical6
243
244 module procedure dctestassertequallogical7
245
246
247 module procedure dctestassertequalreal0digits
248
249 module procedure dctestassertequalreal1digits
250
251 module procedure dctestassertequalreal2digits
252
253 module procedure dctestassertequalreal3digits
254
255 module procedure dctestassertequalreal4digits
256
257 module procedure dctestassertequalreal5digits
258
259 module procedure dctestassertequalreal6digits
260
261 module procedure dctestassertequalreal7digits
262
263
264 module procedure dctestassertequaldouble0digits
265
266 module procedure dctestassertequaldouble1digits
267
268 module procedure dctestassertequaldouble2digits
269
270 module procedure dctestassertequaldouble3digits
271
272 module procedure dctestassertequaldouble4digits
273
274 module procedure dctestassertequaldouble5digits
275
276 module procedure dctestassertequaldouble6digits
277
278 module procedure dctestassertequaldouble7digits
279
280
281
282 end interface
283
284 interface assertgreaterthan
285 module procedure dctestassertgreaterthanint0
286
287 module procedure dctestassertgreaterthanint1
288
289 module procedure dctestassertgreaterthanint2
290
291 module procedure dctestassertgreaterthanint3
292
293 module procedure dctestassertgreaterthanint4
294
295 module procedure dctestassertgreaterthanint5
296
297 module procedure dctestassertgreaterthanint6
298
299 module procedure dctestassertgreaterthanint7
300
301
302 module procedure dctestassertgreaterthanreal0
303
304 module procedure dctestassertgreaterthanreal1
305
306 module procedure dctestassertgreaterthanreal2
307
308 module procedure dctestassertgreaterthanreal3
309
310 module procedure dctestassertgreaterthanreal4
311
312 module procedure dctestassertgreaterthanreal5
313
314 module procedure dctestassertgreaterthanreal6
315
316 module procedure dctestassertgreaterthanreal7
317
318
319 module procedure dctestassertgreaterthandouble0
320
321 module procedure dctestassertgreaterthandouble1
322
323 module procedure dctestassertgreaterthandouble2
324
325 module procedure dctestassertgreaterthandouble3
326
327 module procedure dctestassertgreaterthandouble4
328
329 module procedure dctestassertgreaterthandouble5
330
331 module procedure dctestassertgreaterthandouble6
332
333 module procedure dctestassertgreaterthandouble7
334
335
336 end interface
337
338 interface assertlessthan
339 module procedure dctestassertlessthanint0
340
341 module procedure dctestassertlessthanint1
342
343 module procedure dctestassertlessthanint2
344
345 module procedure dctestassertlessthanint3
346
347 module procedure dctestassertlessthanint4
348
349 module procedure dctestassertlessthanint5
350
351 module procedure dctestassertlessthanint6
352
353 module procedure dctestassertlessthanint7
354
355
356 module procedure dctestassertlessthanreal0
357
358 module procedure dctestassertlessthanreal1
359
360 module procedure dctestassertlessthanreal2
361
362 module procedure dctestassertlessthanreal3
363
364 module procedure dctestassertlessthanreal4
365
366 module procedure dctestassertlessthanreal5
367
368 module procedure dctestassertlessthanreal6
369
370 module procedure dctestassertlessthanreal7
371
372
373 module procedure dctestassertlessthandouble0
374
375 module procedure dctestassertlessthandouble1
376
377 module procedure dctestassertlessthandouble2
378
379 module procedure dctestassertlessthandouble3
380
381 module procedure dctestassertlessthandouble4
382
383 module procedure dctestassertlessthandouble5
384
385 module procedure dctestassertlessthandouble6
386
387 module procedure dctestassertlessthandouble7
388
389
390 end interface
391
392contains
393
394
395 subroutine dctestassertequalchar0(message, answer, check)
396 use sysdep, only: abortprogram
397 use dc_types, only: string
398 implicit none
399 character(*), intent(in):: message
400 character(*), intent(in):: answer
401 character(*), intent(in):: check
402 logical:: err_flag
403 character(STRING):: pos_str
404 character(STRING):: wrong, right
405
406
407
408
409
410
411 continue
412 err_flag = .false.
413
414
415 err_flag = .not. trim(answer) == trim(check)
416
417 wrong = check
418 right = answer
419 pos_str = ''
420
421
422
423
424 if (err_flag) then
425 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
426 write(*,*) ''
427 write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
428 write(*,*) ' is NOT EQUAL to'
429 write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
430
431 call abortprogram('')
432 else
433 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
434 end if
435
436
437 end subroutine dctestassertequalchar0
438
439
440 subroutine dctestassertequalchar1(message, answer, check)
441 use sysdep, only: abortprogram
442 use dc_types, only: string, token
443 implicit none
444 character(*), intent(in):: message
445 character(*), intent(in):: answer(:)
446 character(*), intent(in):: check(:)
447 logical:: err_flag
448 character(STRING):: pos_str
449 character(STRING):: wrong, right
450
451 integer:: answer_shape(1), check_shape(1), pos(1)
452 logical:: consist_shape(1)
453 character(TOKEN):: pos_array(1)
454 integer, allocatable:: mask_array(:)
455 logical, allocatable:: judge(:)
456 logical, allocatable:: judge_rev(:)
457
458
459 character(STRING), allocatable:: answer_fixed_length(:)
460 character(STRING), allocatable:: check_fixed_length(:)
461
462
463
464 continue
465 err_flag = .false.
466
467
468 answer_shape = shape(answer)
469 check_shape = shape(check)
470
471 consist_shape = answer_shape == check_shape
472
473 if (.not. all(consist_shape)) then
474 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
475 write(*,*) ''
476 write(*,*) ' shape of check is (', check_shape, ')'
477 write(*,*) ' is INCORRECT'
478 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
479
480 call abortprogram('')
481 end if
482
483
484 allocate( mask_array( &
485
486 & answer_shape(1) ) &
487 & )
488
489 allocate( judge( &
490
491 & answer_shape(1) ) &
492 & )
493
494 allocate( judge_rev( &
495
496 & answer_shape(1) ) &
497 & )
498
499
500 allocate( answer_fixed_length( &
501
502 & answer_shape(1) ) &
503 & )
504
505 allocate( check_fixed_length( &
506
507 & check_shape(1) ) &
508 & )
509
510 answer_fixed_length = answer
511 check_fixed_length = check
512
513 judge = answer_fixed_length == check_fixed_length
514 deallocate(answer_fixed_length, check_fixed_length)
515
516
517
518 judge_rev = .not. judge
519 err_flag = any(judge_rev)
520 mask_array = 1
521 pos = maxloc(mask_array, judge_rev)
522
523 if (err_flag) then
524
525 wrong = check( &
526
527 & pos(1) )
528
529 right = answer( &
530
531 & pos(1) )
532
533 write(unit=pos_array(1), fmt="(i20)") pos(1)
534
535
536 pos_str = '(' // &
537
538 & trim(adjustl(pos_array(1))) // ')'
539
540 end if
541 deallocate(mask_array, judge, judge_rev)
542
543
544
545
546 if (err_flag) then
547 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
548 write(*,*) ''
549 write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
550 write(*,*) ' is NOT EQUAL to'
551 write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
552
553 call abortprogram('')
554 else
555 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
556 end if
557
558
559 end subroutine dctestassertequalchar1
560
561
562 subroutine dctestassertequalchar2(message, answer, check)
563 use sysdep, only: abortprogram
564 use dc_types, only: string, token
565 implicit none
566 character(*), intent(in):: message
567 character(*), intent(in):: answer(:,:)
568 character(*), intent(in):: check(:,:)
569 logical:: err_flag
570 character(STRING):: pos_str
571 character(STRING):: wrong, right
572
573 integer:: answer_shape(2), check_shape(2), pos(2)
574 logical:: consist_shape(2)
575 character(TOKEN):: pos_array(2)
576 integer, allocatable:: mask_array(:,:)
577 logical, allocatable:: judge(:,:)
578 logical, allocatable:: judge_rev(:,:)
579
580
581 character(STRING), allocatable:: answer_fixed_length(:,:)
582 character(STRING), allocatable:: check_fixed_length(:,:)
583
584
585
586 continue
587 err_flag = .false.
588
589
590 answer_shape = shape(answer)
591 check_shape = shape(check)
592
593 consist_shape = answer_shape == check_shape
594
595 if (.not. all(consist_shape)) then
596 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
597 write(*,*) ''
598 write(*,*) ' shape of check is (', check_shape, ')'
599 write(*,*) ' is INCORRECT'
600 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
601
602 call abortprogram('')
603 end if
604
605
606 allocate( mask_array( &
607 & answer_shape(1), &
608
609 & answer_shape(2) ) &
610 & )
611
612 allocate( judge( &
613 & answer_shape(1), &
614
615 & answer_shape(2) ) &
616 & )
617
618 allocate( judge_rev( &
619 & answer_shape(1), &
620
621 & answer_shape(2) ) &
622 & )
623
624
625 allocate( answer_fixed_length( &
626 & answer_shape(1), &
627
628 & answer_shape(2) ) &
629 & )
630
631 allocate( check_fixed_length( &
632 & check_shape(1), &
633
634 & check_shape(2) ) &
635 & )
636
637 answer_fixed_length = answer
638 check_fixed_length = check
639
640 judge = answer_fixed_length == check_fixed_length
641 deallocate(answer_fixed_length, check_fixed_length)
642
643
644
645 judge_rev = .not. judge
646 err_flag = any(judge_rev)
647 mask_array = 1
648 pos = maxloc(mask_array, judge_rev)
649
650 if (err_flag) then
651
652 wrong = check( &
653 & pos(1), &
654
655 & pos(2) )
656
657 right = answer( &
658 & pos(1), &
659
660 & pos(2) )
661
662 write(unit=pos_array(1), fmt="(i20)") pos(1)
663
664 write(unit=pos_array(2), fmt="(i20)") pos(2)
665
666
667 pos_str = '(' // &
668 & trim(adjustl(pos_array(1))) // ',' // &
669
670 & trim(adjustl(pos_array(2))) // ')'
671
672 end if
673 deallocate(mask_array, judge, judge_rev)
674
675
676
677
678 if (err_flag) then
679 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
680 write(*,*) ''
681 write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
682 write(*,*) ' is NOT EQUAL to'
683 write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
684
685 call abortprogram('')
686 else
687 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
688 end if
689
690
691 end subroutine dctestassertequalchar2
692
693
694 subroutine dctestassertequalchar3(message, answer, check)
695 use sysdep, only: abortprogram
696 use dc_types, only: string, token
697 implicit none
698 character(*), intent(in):: message
699 character(*), intent(in):: answer(:,:,:)
700 character(*), intent(in):: check(:,:,:)
701 logical:: err_flag
702 character(STRING):: pos_str
703 character(STRING):: wrong, right
704
705 integer:: answer_shape(3), check_shape(3), pos(3)
706 logical:: consist_shape(3)
707 character(TOKEN):: pos_array(3)
708 integer, allocatable:: mask_array(:,:,:)
709 logical, allocatable:: judge(:,:,:)
710 logical, allocatable:: judge_rev(:,:,:)
711
712
713 character(STRING), allocatable:: answer_fixed_length(:,:,:)
714 character(STRING), allocatable:: check_fixed_length(:,:,:)
715
716
717
718 continue
719 err_flag = .false.
720
721
722 answer_shape = shape(answer)
723 check_shape = shape(check)
724
725 consist_shape = answer_shape == check_shape
726
727 if (.not. all(consist_shape)) then
728 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
729 write(*,*) ''
730 write(*,*) ' shape of check is (', check_shape, ')'
731 write(*,*) ' is INCORRECT'
732 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
733
734 call abortprogram('')
735 end if
736
737
738 allocate( mask_array( &
739 & answer_shape(1), &
740
741 & answer_shape(2), &
742
743 & answer_shape(3) ) &
744 & )
745
746 allocate( judge( &
747 & answer_shape(1), &
748
749 & answer_shape(2), &
750
751 & answer_shape(3) ) &
752 & )
753
754 allocate( judge_rev( &
755 & answer_shape(1), &
756
757 & answer_shape(2), &
758
759 & answer_shape(3) ) &
760 & )
761
762
763 allocate( answer_fixed_length( &
764 & answer_shape(1), &
765
766 & answer_shape(2), &
767
768 & answer_shape(3) ) &
769 & )
770
771 allocate( check_fixed_length( &
772 & check_shape(1), &
773
774 & check_shape(2), &
775
776 & check_shape(3) ) &
777 & )
778
779 answer_fixed_length = answer
780 check_fixed_length = check
781
782 judge = answer_fixed_length == check_fixed_length
783 deallocate(answer_fixed_length, check_fixed_length)
784
785
786
787 judge_rev = .not. judge
788 err_flag = any(judge_rev)
789 mask_array = 1
790 pos = maxloc(mask_array, judge_rev)
791
792 if (err_flag) then
793
794 wrong = check( &
795 & pos(1), &
796
797 & pos(2), &
798
799 & pos(3) )
800
801 right = answer( &
802 & pos(1), &
803
804 & pos(2), &
805
806 & pos(3) )
807
808 write(unit=pos_array(1), fmt="(i20)") pos(1)
809
810 write(unit=pos_array(2), fmt="(i20)") pos(2)
811
812 write(unit=pos_array(3), fmt="(i20)") pos(3)
813
814
815 pos_str = '(' // &
816 & trim(adjustl(pos_array(1))) // ',' // &
817
818 & trim(adjustl(pos_array(2))) // ',' // &
819
820 & trim(adjustl(pos_array(3))) // ')'
821
822 end if
823 deallocate(mask_array, judge, judge_rev)
824
825
826
827
828 if (err_flag) then
829 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
830 write(*,*) ''
831 write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
832 write(*,*) ' is NOT EQUAL to'
833 write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
834
835 call abortprogram('')
836 else
837 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
838 end if
839
840
841 end subroutine dctestassertequalchar3
842
843
844 subroutine dctestassertequalchar4(message, answer, check)
845 use sysdep, only: abortprogram
846 use dc_types, only: string, token
847 implicit none
848 character(*), intent(in):: message
849 character(*), intent(in):: answer(:,:,:,:)
850 character(*), intent(in):: check(:,:,:,:)
851 logical:: err_flag
852 character(STRING):: pos_str
853 character(STRING):: wrong, right
854
855 integer:: answer_shape(4), check_shape(4), pos(4)
856 logical:: consist_shape(4)
857 character(TOKEN):: pos_array(4)
858 integer, allocatable:: mask_array(:,:,:,:)
859 logical, allocatable:: judge(:,:,:,:)
860 logical, allocatable:: judge_rev(:,:,:,:)
861
862
863 character(STRING), allocatable:: answer_fixed_length(:,:,:,:)
864 character(STRING), allocatable:: check_fixed_length(:,:,:,:)
865
866
867
868 continue
869 err_flag = .false.
870
871
872 answer_shape = shape(answer)
873 check_shape = shape(check)
874
875 consist_shape = answer_shape == check_shape
876
877 if (.not. all(consist_shape)) then
878 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
879 write(*,*) ''
880 write(*,*) ' shape of check is (', check_shape, ')'
881 write(*,*) ' is INCORRECT'
882 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
883
884 call abortprogram('')
885 end if
886
887
888 allocate( mask_array( &
889 & answer_shape(1), &
890
891 & answer_shape(2), &
892
893 & answer_shape(3), &
894
895 & answer_shape(4) ) &
896 & )
897
898 allocate( judge( &
899 & answer_shape(1), &
900
901 & answer_shape(2), &
902
903 & answer_shape(3), &
904
905 & answer_shape(4) ) &
906 & )
907
908 allocate( judge_rev( &
909 & answer_shape(1), &
910
911 & answer_shape(2), &
912
913 & answer_shape(3), &
914
915 & answer_shape(4) ) &
916 & )
917
918
919 allocate( answer_fixed_length( &
920 & answer_shape(1), &
921
922 & answer_shape(2), &
923
924 & answer_shape(3), &
925
926 & answer_shape(4) ) &
927 & )
928
929 allocate( check_fixed_length( &
930 & check_shape(1), &
931
932 & check_shape(2), &
933
934 & check_shape(3), &
935
936 & check_shape(4) ) &
937 & )
938
939 answer_fixed_length = answer
940 check_fixed_length = check
941
942 judge = answer_fixed_length == check_fixed_length
943 deallocate(answer_fixed_length, check_fixed_length)
944
945
946
947 judge_rev = .not. judge
948 err_flag = any(judge_rev)
949 mask_array = 1
950 pos = maxloc(mask_array, judge_rev)
951
952 if (err_flag) then
953
954 wrong = check( &
955 & pos(1), &
956
957 & pos(2), &
958
959 & pos(3), &
960
961 & pos(4) )
962
963 right = answer( &
964 & pos(1), &
965
966 & pos(2), &
967
968 & pos(3), &
969
970 & pos(4) )
971
972 write(unit=pos_array(1), fmt="(i20)") pos(1)
973
974 write(unit=pos_array(2), fmt="(i20)") pos(2)
975
976 write(unit=pos_array(3), fmt="(i20)") pos(3)
977
978 write(unit=pos_array(4), fmt="(i20)") pos(4)
979
980
981 pos_str = '(' // &
982 & trim(adjustl(pos_array(1))) // ',' // &
983
984 & trim(adjustl(pos_array(2))) // ',' // &
985
986 & trim(adjustl(pos_array(3))) // ',' // &
987
988 & trim(adjustl(pos_array(4))) // ')'
989
990 end if
991 deallocate(mask_array, judge, judge_rev)
992
993
994
995
996 if (err_flag) then
997 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
998 write(*,*) ''
999 write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
1000 write(*,*) ' is NOT EQUAL to'
1001 write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
1002
1003 call abortprogram('')
1004 else
1005 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
1006 end if
1007
1008
1009 end subroutine dctestassertequalchar4
1010
1011
1012 subroutine dctestassertequalchar5(message, answer, check)
1013 use sysdep, only: abortprogram
1014 use dc_types, only: string, token
1015 implicit none
1016 character(*), intent(in):: message
1017 character(*), intent(in):: answer(:,:,:,:,:)
1018 character(*), intent(in):: check(:,:,:,:,:)
1019 logical:: err_flag
1020 character(STRING):: pos_str
1021 character(STRING):: wrong, right
1022
1023 integer:: answer_shape(5), check_shape(5), pos(5)
1024 logical:: consist_shape(5)
1025 character(TOKEN):: pos_array(5)
1026 integer, allocatable:: mask_array(:,:,:,:,:)
1027 logical, allocatable:: judge(:,:,:,:,:)
1028 logical, allocatable:: judge_rev(:,:,:,:,:)
1029
1030
1031 character(STRING), allocatable:: answer_fixed_length(:,:,:,:,:)
1032 character(STRING), allocatable:: check_fixed_length(:,:,:,:,:)
1033
1034
1035
1036 continue
1037 err_flag = .false.
1038
1039
1040 answer_shape = shape(answer)
1041 check_shape = shape(check)
1042
1043 consist_shape = answer_shape == check_shape
1044
1045 if (.not. all(consist_shape)) then
1046 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1047 write(*,*) ''
1048 write(*,*) ' shape of check is (', check_shape, ')'
1049 write(*,*) ' is INCORRECT'
1050 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
1051
1052 call abortprogram('')
1053 end if
1054
1055
1056 allocate( mask_array( &
1057 & answer_shape(1), &
1058
1059 & answer_shape(2), &
1060
1061 & answer_shape(3), &
1062
1063 & answer_shape(4), &
1064
1065 & answer_shape(5) ) &
1066 & )
1067
1068 allocate( judge( &
1069 & answer_shape(1), &
1070
1071 & answer_shape(2), &
1072
1073 & answer_shape(3), &
1074
1075 & answer_shape(4), &
1076
1077 & answer_shape(5) ) &
1078 & )
1079
1080 allocate( judge_rev( &
1081 & answer_shape(1), &
1082
1083 & answer_shape(2), &
1084
1085 & answer_shape(3), &
1086
1087 & answer_shape(4), &
1088
1089 & answer_shape(5) ) &
1090 & )
1091
1092
1093 allocate( answer_fixed_length( &
1094 & answer_shape(1), &
1095
1096 & answer_shape(2), &
1097
1098 & answer_shape(3), &
1099
1100 & answer_shape(4), &
1101
1102 & answer_shape(5) ) &
1103 & )
1104
1105 allocate( check_fixed_length( &
1106 & check_shape(1), &
1107
1108 & check_shape(2), &
1109
1110 & check_shape(3), &
1111
1112 & check_shape(4), &
1113
1114 & check_shape(5) ) &
1115 & )
1116
1117 answer_fixed_length = answer
1118 check_fixed_length = check
1119
1120 judge = answer_fixed_length == check_fixed_length
1121 deallocate(answer_fixed_length, check_fixed_length)
1122
1123
1124
1125 judge_rev = .not. judge
1126 err_flag = any(judge_rev)
1127 mask_array = 1
1128 pos = maxloc(mask_array, judge_rev)
1129
1130 if (err_flag) then
1131
1132 wrong = check( &
1133 & pos(1), &
1134
1135 & pos(2), &
1136
1137 & pos(3), &
1138
1139 & pos(4), &
1140
1141 & pos(5) )
1142
1143 right = answer( &
1144 & pos(1), &
1145
1146 & pos(2), &
1147
1148 & pos(3), &
1149
1150 & pos(4), &
1151
1152 & pos(5) )
1153
1154 write(unit=pos_array(1), fmt="(i20)") pos(1)
1155
1156 write(unit=pos_array(2), fmt="(i20)") pos(2)
1157
1158 write(unit=pos_array(3), fmt="(i20)") pos(3)
1159
1160 write(unit=pos_array(4), fmt="(i20)") pos(4)
1161
1162 write(unit=pos_array(5), fmt="(i20)") pos(5)
1163
1164
1165 pos_str = '(' // &
1166 & trim(adjustl(pos_array(1))) // ',' // &
1167
1168 & trim(adjustl(pos_array(2))) // ',' // &
1169
1170 & trim(adjustl(pos_array(3))) // ',' // &
1171
1172 & trim(adjustl(pos_array(4))) // ',' // &
1173
1174 & trim(adjustl(pos_array(5))) // ')'
1175
1176 end if
1177 deallocate(mask_array, judge, judge_rev)
1178
1179
1180
1181
1182 if (err_flag) then
1183 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1184 write(*,*) ''
1185 write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
1186 write(*,*) ' is NOT EQUAL to'
1187 write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
1188
1189 call abortprogram('')
1190 else
1191 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
1192 end if
1193
1194
1195 end subroutine dctestassertequalchar5
1196
1197
1198 subroutine dctestassertequalchar6(message, answer, check)
1199 use sysdep, only: abortprogram
1200 use dc_types, only: string, token
1201 implicit none
1202 character(*), intent(in):: message
1203 character(*), intent(in):: answer(:,:,:,:,:,:)
1204 character(*), intent(in):: check(:,:,:,:,:,:)
1205 logical:: err_flag
1206 character(STRING):: pos_str
1207 character(STRING):: wrong, right
1208
1209 integer:: answer_shape(6), check_shape(6), pos(6)
1210 logical:: consist_shape(6)
1211 character(TOKEN):: pos_array(6)
1212 integer, allocatable:: mask_array(:,:,:,:,:,:)
1213 logical, allocatable:: judge(:,:,:,:,:,:)
1214 logical, allocatable:: judge_rev(:,:,:,:,:,:)
1215
1216
1217 character(STRING), allocatable:: answer_fixed_length(:,:,:,:,:,:)
1218 character(STRING), allocatable:: check_fixed_length(:,:,:,:,:,:)
1219
1220
1221
1222 continue
1223 err_flag = .false.
1224
1225
1226 answer_shape = shape(answer)
1227 check_shape = shape(check)
1228
1229 consist_shape = answer_shape == check_shape
1230
1231 if (.not. all(consist_shape)) then
1232 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1233 write(*,*) ''
1234 write(*,*) ' shape of check is (', check_shape, ')'
1235 write(*,*) ' is INCORRECT'
1236 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
1237
1238 call abortprogram('')
1239 end if
1240
1241
1242 allocate( mask_array( &
1243 & answer_shape(1), &
1244
1245 & answer_shape(2), &
1246
1247 & answer_shape(3), &
1248
1249 & answer_shape(4), &
1250
1251 & answer_shape(5), &
1252
1253 & answer_shape(6) ) &
1254 & )
1255
1256 allocate( judge( &
1257 & answer_shape(1), &
1258
1259 & answer_shape(2), &
1260
1261 & answer_shape(3), &
1262
1263 & answer_shape(4), &
1264
1265 & answer_shape(5), &
1266
1267 & answer_shape(6) ) &
1268 & )
1269
1270 allocate( judge_rev( &
1271 & answer_shape(1), &
1272
1273 & answer_shape(2), &
1274
1275 & answer_shape(3), &
1276
1277 & answer_shape(4), &
1278
1279 & answer_shape(5), &
1280
1281 & answer_shape(6) ) &
1282 & )
1283
1284
1285 allocate( answer_fixed_length( &
1286 & answer_shape(1), &
1287
1288 & answer_shape(2), &
1289
1290 & answer_shape(3), &
1291
1292 & answer_shape(4), &
1293
1294 & answer_shape(5), &
1295
1296 & answer_shape(6) ) &
1297 & )
1298
1299 allocate( check_fixed_length( &
1300 & check_shape(1), &
1301
1302 & check_shape(2), &
1303
1304 & check_shape(3), &
1305
1306 & check_shape(4), &
1307
1308 & check_shape(5), &
1309
1310 & check_shape(6) ) &
1311 & )
1312
1313 answer_fixed_length = answer
1314 check_fixed_length = check
1315
1316 judge = answer_fixed_length == check_fixed_length
1317 deallocate(answer_fixed_length, check_fixed_length)
1318
1319
1320
1321 judge_rev = .not. judge
1322 err_flag = any(judge_rev)
1323 mask_array = 1
1324 pos = maxloc(mask_array, judge_rev)
1325
1326 if (err_flag) then
1327
1328 wrong = check( &
1329 & pos(1), &
1330
1331 & pos(2), &
1332
1333 & pos(3), &
1334
1335 & pos(4), &
1336
1337 & pos(5), &
1338
1339 & pos(6) )
1340
1341 right = answer( &
1342 & pos(1), &
1343
1344 & pos(2), &
1345
1346 & pos(3), &
1347
1348 & pos(4), &
1349
1350 & pos(5), &
1351
1352 & pos(6) )
1353
1354 write(unit=pos_array(1), fmt="(i20)") pos(1)
1355
1356 write(unit=pos_array(2), fmt="(i20)") pos(2)
1357
1358 write(unit=pos_array(3), fmt="(i20)") pos(3)
1359
1360 write(unit=pos_array(4), fmt="(i20)") pos(4)
1361
1362 write(unit=pos_array(5), fmt="(i20)") pos(5)
1363
1364 write(unit=pos_array(6), fmt="(i20)") pos(6)
1365
1366
1367 pos_str = '(' // &
1368 & trim(adjustl(pos_array(1))) // ',' // &
1369
1370 & trim(adjustl(pos_array(2))) // ',' // &
1371
1372 & trim(adjustl(pos_array(3))) // ',' // &
1373
1374 & trim(adjustl(pos_array(4))) // ',' // &
1375
1376 & trim(adjustl(pos_array(5))) // ',' // &
1377
1378 & trim(adjustl(pos_array(6))) // ')'
1379
1380 end if
1381 deallocate(mask_array, judge, judge_rev)
1382
1383
1384
1385
1386 if (err_flag) then
1387 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1388 write(*,*) ''
1389 write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
1390 write(*,*) ' is NOT EQUAL to'
1391 write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
1392
1393 call abortprogram('')
1394 else
1395 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
1396 end if
1397
1398
1399 end subroutine dctestassertequalchar6
1400
1401
1402 subroutine dctestassertequalchar7(message, answer, check)
1403 use sysdep, only: abortprogram
1404 use dc_types, only: string, token
1405 implicit none
1406 character(*), intent(in):: message
1407 character(*), intent(in):: answer(:,:,:,:,:,:,:)
1408 character(*), intent(in):: check(:,:,:,:,:,:,:)
1409 logical:: err_flag
1410 character(STRING):: pos_str
1411 character(STRING):: wrong, right
1412
1413 integer:: answer_shape(7), check_shape(7), pos(7)
1414 logical:: consist_shape(7)
1415 character(TOKEN):: pos_array(7)
1416 integer, allocatable:: mask_array(:,:,:,:,:,:,:)
1417 logical, allocatable:: judge(:,:,:,:,:,:,:)
1418 logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
1419
1420
1421 character(STRING), allocatable:: answer_fixed_length(:,:,:,:,:,:,:)
1422 character(STRING), allocatable:: check_fixed_length(:,:,:,:,:,:,:)
1423
1424
1425
1426 continue
1427 err_flag = .false.
1428
1429
1430 answer_shape = shape(answer)
1431 check_shape = shape(check)
1432
1433 consist_shape = answer_shape == check_shape
1434
1435 if (.not. all(consist_shape)) then
1436 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1437 write(*,*) ''
1438 write(*,*) ' shape of check is (', check_shape, ')'
1439 write(*,*) ' is INCORRECT'
1440 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
1441
1442 call abortprogram('')
1443 end if
1444
1445
1446 allocate( mask_array( &
1447 & answer_shape(1), &
1448
1449 & answer_shape(2), &
1450
1451 & answer_shape(3), &
1452
1453 & answer_shape(4), &
1454
1455 & answer_shape(5), &
1456
1457 & answer_shape(6), &
1458
1459 & answer_shape(7) ) &
1460 & )
1461
1462 allocate( judge( &
1463 & answer_shape(1), &
1464
1465 & answer_shape(2), &
1466
1467 & answer_shape(3), &
1468
1469 & answer_shape(4), &
1470
1471 & answer_shape(5), &
1472
1473 & answer_shape(6), &
1474
1475 & answer_shape(7) ) &
1476 & )
1477
1478 allocate( judge_rev( &
1479 & answer_shape(1), &
1480
1481 & answer_shape(2), &
1482
1483 & answer_shape(3), &
1484
1485 & answer_shape(4), &
1486
1487 & answer_shape(5), &
1488
1489 & answer_shape(6), &
1490
1491 & answer_shape(7) ) &
1492 & )
1493
1494
1495 allocate( answer_fixed_length( &
1496 & answer_shape(1), &
1497
1498 & answer_shape(2), &
1499
1500 & answer_shape(3), &
1501
1502 & answer_shape(4), &
1503
1504 & answer_shape(5), &
1505
1506 & answer_shape(6), &
1507
1508 & answer_shape(7) ) &
1509 & )
1510
1511 allocate( check_fixed_length( &
1512 & check_shape(1), &
1513
1514 & check_shape(2), &
1515
1516 & check_shape(3), &
1517
1518 & check_shape(4), &
1519
1520 & check_shape(5), &
1521
1522 & check_shape(6), &
1523
1524 & check_shape(7) ) &
1525 & )
1526
1527 answer_fixed_length = answer
1528 check_fixed_length = check
1529
1530 judge = answer_fixed_length == check_fixed_length
1531 deallocate(answer_fixed_length, check_fixed_length)
1532
1533
1534
1535 judge_rev = .not. judge
1536 err_flag = any(judge_rev)
1537 mask_array = 1
1538 pos = maxloc(mask_array, judge_rev)
1539
1540 if (err_flag) then
1541
1542 wrong = check( &
1543 & pos(1), &
1544
1545 & pos(2), &
1546
1547 & pos(3), &
1548
1549 & pos(4), &
1550
1551 & pos(5), &
1552
1553 & pos(6), &
1554
1555 & pos(7) )
1556
1557 right = answer( &
1558 & pos(1), &
1559
1560 & pos(2), &
1561
1562 & pos(3), &
1563
1564 & pos(4), &
1565
1566 & pos(5), &
1567
1568 & pos(6), &
1569
1570 & pos(7) )
1571
1572 write(unit=pos_array(1), fmt="(i20)") pos(1)
1573
1574 write(unit=pos_array(2), fmt="(i20)") pos(2)
1575
1576 write(unit=pos_array(3), fmt="(i20)") pos(3)
1577
1578 write(unit=pos_array(4), fmt="(i20)") pos(4)
1579
1580 write(unit=pos_array(5), fmt="(i20)") pos(5)
1581
1582 write(unit=pos_array(6), fmt="(i20)") pos(6)
1583
1584 write(unit=pos_array(7), fmt="(i20)") pos(7)
1585
1586
1587 pos_str = '(' // &
1588 & trim(adjustl(pos_array(1))) // ',' // &
1589
1590 & trim(adjustl(pos_array(2))) // ',' // &
1591
1592 & trim(adjustl(pos_array(3))) // ',' // &
1593
1594 & trim(adjustl(pos_array(4))) // ',' // &
1595
1596 & trim(adjustl(pos_array(5))) // ',' // &
1597
1598 & trim(adjustl(pos_array(6))) // ',' // &
1599
1600 & trim(adjustl(pos_array(7))) // ')'
1601
1602 end if
1603 deallocate(mask_array, judge, judge_rev)
1604
1605
1606
1607
1608 if (err_flag) then
1609 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1610 write(*,*) ''
1611 write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
1612 write(*,*) ' is NOT EQUAL to'
1613 write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
1614
1615 call abortprogram('')
1616 else
1617 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
1618 end if
1619
1620
1621 end subroutine dctestassertequalchar7
1622
1623
1624 subroutine dctestassertequalint0(message, answer, check)
1625 use sysdep, only: abortprogram
1626 use dc_types, only: string
1627 implicit none
1628 character(*), intent(in):: message
1629 integer, intent(in):: answer
1630 integer, intent(in):: check
1631 logical:: err_flag
1632 character(STRING):: pos_str
1633 integer:: wrong, right
1634
1635
1636
1637
1638
1639 continue
1640 err_flag = .false.
1641
1642
1643 err_flag = .not. answer == check
1644
1645 wrong = check
1646 right = answer
1647 pos_str = ''
1648
1649
1650
1651
1652 if (err_flag) then
1653 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1654 write(*,*) ''
1655 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
1656 write(*,*) ' is NOT EQUAL to'
1657 write(*,*) ' answer' // trim(pos_str) // ' = ', right
1658
1659 call abortprogram('')
1660 else
1661 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
1662 end if
1663
1664
1665 end subroutine dctestassertequalint0
1666
1667
1668 subroutine dctestassertequalint1(message, answer, check)
1669 use sysdep, only: abortprogram
1670 use dc_types, only: string, token
1671 implicit none
1672 character(*), intent(in):: message
1673 integer, intent(in):: answer(:)
1674 integer, intent(in):: check(:)
1675 logical:: err_flag
1676 character(STRING):: pos_str
1677 integer:: wrong, right
1678
1679 integer:: answer_shape(1), check_shape(1), pos(1)
1680 logical:: consist_shape(1)
1681 character(TOKEN):: pos_array(1)
1682 integer, allocatable:: mask_array(:)
1683 logical, allocatable:: judge(:)
1684 logical, allocatable:: judge_rev(:)
1685
1686
1687
1688
1689 continue
1690 err_flag = .false.
1691
1692
1693 answer_shape = shape(answer)
1694 check_shape = shape(check)
1695
1696 consist_shape = answer_shape == check_shape
1697
1698 if (.not. all(consist_shape)) then
1699 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1700 write(*,*) ''
1701 write(*,*) ' shape of check is (', check_shape, ')'
1702 write(*,*) ' is INCORRECT'
1703 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
1704
1705 call abortprogram('')
1706 end if
1707
1708
1709 allocate( mask_array( &
1710
1711 & answer_shape(1) ) &
1712 & )
1713
1714 allocate( judge( &
1715
1716 & answer_shape(1) ) &
1717 & )
1718
1719 allocate( judge_rev( &
1720
1721 & answer_shape(1) ) &
1722 & )
1723
1724
1725 judge = answer == check
1726
1727
1728
1729
1730 judge_rev = .not. judge
1731 err_flag = any(judge_rev)
1732 mask_array = 1
1733 pos = maxloc(mask_array, judge_rev)
1734
1735 if (err_flag) then
1736
1737 wrong = check( &
1738
1739 & pos(1) )
1740
1741 right = answer( &
1742
1743 & pos(1) )
1744
1745 write(unit=pos_array(1), fmt="(i20)") pos(1)
1746
1747
1748 pos_str = '(' // &
1749
1750 & trim(adjustl(pos_array(1))) // ')'
1751
1752 end if
1753 deallocate(mask_array, judge, judge_rev)
1754
1755
1756
1757
1758 if (err_flag) then
1759 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1760 write(*,*) ''
1761 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
1762 write(*,*) ' is NOT EQUAL to'
1763 write(*,*) ' answer' // trim(pos_str) // ' = ', right
1764
1765 call abortprogram('')
1766 else
1767 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
1768 end if
1769
1770
1771 end subroutine dctestassertequalint1
1772
1773
1774 subroutine dctestassertequalint2(message, answer, check)
1775 use sysdep, only: abortprogram
1776 use dc_types, only: string, token
1777 implicit none
1778 character(*), intent(in):: message
1779 integer, intent(in):: answer(:,:)
1780 integer, intent(in):: check(:,:)
1781 logical:: err_flag
1782 character(STRING):: pos_str
1783 integer:: wrong, right
1784
1785 integer:: answer_shape(2), check_shape(2), pos(2)
1786 logical:: consist_shape(2)
1787 character(TOKEN):: pos_array(2)
1788 integer, allocatable:: mask_array(:,:)
1789 logical, allocatable:: judge(:,:)
1790 logical, allocatable:: judge_rev(:,:)
1791
1792
1793
1794
1795 continue
1796 err_flag = .false.
1797
1798
1799 answer_shape = shape(answer)
1800 check_shape = shape(check)
1801
1802 consist_shape = answer_shape == check_shape
1803
1804 if (.not. all(consist_shape)) then
1805 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1806 write(*,*) ''
1807 write(*,*) ' shape of check is (', check_shape, ')'
1808 write(*,*) ' is INCORRECT'
1809 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
1810
1811 call abortprogram('')
1812 end if
1813
1814
1815 allocate( mask_array( &
1816 & answer_shape(1), &
1817
1818 & answer_shape(2) ) &
1819 & )
1820
1821 allocate( judge( &
1822 & answer_shape(1), &
1823
1824 & answer_shape(2) ) &
1825 & )
1826
1827 allocate( judge_rev( &
1828 & answer_shape(1), &
1829
1830 & answer_shape(2) ) &
1831 & )
1832
1833
1834 judge = answer == check
1835
1836
1837
1838
1839 judge_rev = .not. judge
1840 err_flag = any(judge_rev)
1841 mask_array = 1
1842 pos = maxloc(mask_array, judge_rev)
1843
1844 if (err_flag) then
1845
1846 wrong = check( &
1847 & pos(1), &
1848
1849 & pos(2) )
1850
1851 right = answer( &
1852 & pos(1), &
1853
1854 & pos(2) )
1855
1856 write(unit=pos_array(1), fmt="(i20)") pos(1)
1857
1858 write(unit=pos_array(2), fmt="(i20)") pos(2)
1859
1860
1861 pos_str = '(' // &
1862 & trim(adjustl(pos_array(1))) // ',' // &
1863
1864 & trim(adjustl(pos_array(2))) // ')'
1865
1866 end if
1867 deallocate(mask_array, judge, judge_rev)
1868
1869
1870
1871
1872 if (err_flag) then
1873 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1874 write(*,*) ''
1875 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
1876 write(*,*) ' is NOT EQUAL to'
1877 write(*,*) ' answer' // trim(pos_str) // ' = ', right
1878
1879 call abortprogram('')
1880 else
1881 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
1882 end if
1883
1884
1885 end subroutine dctestassertequalint2
1886
1887
1888 subroutine dctestassertequalint3(message, answer, check)
1889 use sysdep, only: abortprogram
1890 use dc_types, only: string, token
1891 implicit none
1892 character(*), intent(in):: message
1893 integer, intent(in):: answer(:,:,:)
1894 integer, intent(in):: check(:,:,:)
1895 logical:: err_flag
1896 character(STRING):: pos_str
1897 integer:: wrong, right
1898
1899 integer:: answer_shape(3), check_shape(3), pos(3)
1900 logical:: consist_shape(3)
1901 character(TOKEN):: pos_array(3)
1902 integer, allocatable:: mask_array(:,:,:)
1903 logical, allocatable:: judge(:,:,:)
1904 logical, allocatable:: judge_rev(:,:,:)
1905
1906
1907
1908
1909 continue
1910 err_flag = .false.
1911
1912
1913 answer_shape = shape(answer)
1914 check_shape = shape(check)
1915
1916 consist_shape = answer_shape == check_shape
1917
1918 if (.not. all(consist_shape)) then
1919 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1920 write(*,*) ''
1921 write(*,*) ' shape of check is (', check_shape, ')'
1922 write(*,*) ' is INCORRECT'
1923 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
1924
1925 call abortprogram('')
1926 end if
1927
1928
1929 allocate( mask_array( &
1930 & answer_shape(1), &
1931
1932 & answer_shape(2), &
1933
1934 & answer_shape(3) ) &
1935 & )
1936
1937 allocate( judge( &
1938 & answer_shape(1), &
1939
1940 & answer_shape(2), &
1941
1942 & answer_shape(3) ) &
1943 & )
1944
1945 allocate( judge_rev( &
1946 & answer_shape(1), &
1947
1948 & answer_shape(2), &
1949
1950 & answer_shape(3) ) &
1951 & )
1952
1953
1954 judge = answer == check
1955
1956
1957
1958
1959 judge_rev = .not. judge
1960 err_flag = any(judge_rev)
1961 mask_array = 1
1962 pos = maxloc(mask_array, judge_rev)
1963
1964 if (err_flag) then
1965
1966 wrong = check( &
1967 & pos(1), &
1968
1969 & pos(2), &
1970
1971 & pos(3) )
1972
1973 right = answer( &
1974 & pos(1), &
1975
1976 & pos(2), &
1977
1978 & pos(3) )
1979
1980 write(unit=pos_array(1), fmt="(i20)") pos(1)
1981
1982 write(unit=pos_array(2), fmt="(i20)") pos(2)
1983
1984 write(unit=pos_array(3), fmt="(i20)") pos(3)
1985
1986
1987 pos_str = '(' // &
1988 & trim(adjustl(pos_array(1))) // ',' // &
1989
1990 & trim(adjustl(pos_array(2))) // ',' // &
1991
1992 & trim(adjustl(pos_array(3))) // ')'
1993
1994 end if
1995 deallocate(mask_array, judge, judge_rev)
1996
1997
1998
1999
2000 if (err_flag) then
2001 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2002 write(*,*) ''
2003 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2004 write(*,*) ' is NOT EQUAL to'
2005 write(*,*) ' answer' // trim(pos_str) // ' = ', right
2006
2007 call abortprogram('')
2008 else
2009 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2010 end if
2011
2012
2013 end subroutine dctestassertequalint3
2014
2015
2016 subroutine dctestassertequalint4(message, answer, check)
2017 use sysdep, only: abortprogram
2018 use dc_types, only: string, token
2019 implicit none
2020 character(*), intent(in):: message
2021 integer, intent(in):: answer(:,:,:,:)
2022 integer, intent(in):: check(:,:,:,:)
2023 logical:: err_flag
2024 character(STRING):: pos_str
2025 integer:: wrong, right
2026
2027 integer:: answer_shape(4), check_shape(4), pos(4)
2028 logical:: consist_shape(4)
2029 character(TOKEN):: pos_array(4)
2030 integer, allocatable:: mask_array(:,:,:,:)
2031 logical, allocatable:: judge(:,:,:,:)
2032 logical, allocatable:: judge_rev(:,:,:,:)
2033
2034
2035
2036
2037 continue
2038 err_flag = .false.
2039
2040
2041 answer_shape = shape(answer)
2042 check_shape = shape(check)
2043
2044 consist_shape = answer_shape == check_shape
2045
2046 if (.not. all(consist_shape)) then
2047 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2048 write(*,*) ''
2049 write(*,*) ' shape of check is (', check_shape, ')'
2050 write(*,*) ' is INCORRECT'
2051 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2052
2053 call abortprogram('')
2054 end if
2055
2056
2057 allocate( mask_array( &
2058 & answer_shape(1), &
2059
2060 & answer_shape(2), &
2061
2062 & answer_shape(3), &
2063
2064 & answer_shape(4) ) &
2065 & )
2066
2067 allocate( judge( &
2068 & answer_shape(1), &
2069
2070 & answer_shape(2), &
2071
2072 & answer_shape(3), &
2073
2074 & answer_shape(4) ) &
2075 & )
2076
2077 allocate( judge_rev( &
2078 & answer_shape(1), &
2079
2080 & answer_shape(2), &
2081
2082 & answer_shape(3), &
2083
2084 & answer_shape(4) ) &
2085 & )
2086
2087
2088 judge = answer == check
2089
2090
2091
2092
2093 judge_rev = .not. judge
2094 err_flag = any(judge_rev)
2095 mask_array = 1
2096 pos = maxloc(mask_array, judge_rev)
2097
2098 if (err_flag) then
2099
2100 wrong = check( &
2101 & pos(1), &
2102
2103 & pos(2), &
2104
2105 & pos(3), &
2106
2107 & pos(4) )
2108
2109 right = answer( &
2110 & pos(1), &
2111
2112 & pos(2), &
2113
2114 & pos(3), &
2115
2116 & pos(4) )
2117
2118 write(unit=pos_array(1), fmt="(i20)") pos(1)
2119
2120 write(unit=pos_array(2), fmt="(i20)") pos(2)
2121
2122 write(unit=pos_array(3), fmt="(i20)") pos(3)
2123
2124 write(unit=pos_array(4), fmt="(i20)") pos(4)
2125
2126
2127 pos_str = '(' // &
2128 & trim(adjustl(pos_array(1))) // ',' // &
2129
2130 & trim(adjustl(pos_array(2))) // ',' // &
2131
2132 & trim(adjustl(pos_array(3))) // ',' // &
2133
2134 & trim(adjustl(pos_array(4))) // ')'
2135
2136 end if
2137 deallocate(mask_array, judge, judge_rev)
2138
2139
2140
2141
2142 if (err_flag) then
2143 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2144 write(*,*) ''
2145 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2146 write(*,*) ' is NOT EQUAL to'
2147 write(*,*) ' answer' // trim(pos_str) // ' = ', right
2148
2149 call abortprogram('')
2150 else
2151 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2152 end if
2153
2154
2155 end subroutine dctestassertequalint4
2156
2157
2158 subroutine dctestassertequalint5(message, answer, check)
2159 use sysdep, only: abortprogram
2160 use dc_types, only: string, token
2161 implicit none
2162 character(*), intent(in):: message
2163 integer, intent(in):: answer(:,:,:,:,:)
2164 integer, intent(in):: check(:,:,:,:,:)
2165 logical:: err_flag
2166 character(STRING):: pos_str
2167 integer:: wrong, right
2168
2169 integer:: answer_shape(5), check_shape(5), pos(5)
2170 logical:: consist_shape(5)
2171 character(TOKEN):: pos_array(5)
2172 integer, allocatable:: mask_array(:,:,:,:,:)
2173 logical, allocatable:: judge(:,:,:,:,:)
2174 logical, allocatable:: judge_rev(:,:,:,:,:)
2175
2176
2177
2178
2179 continue
2180 err_flag = .false.
2181
2182
2183 answer_shape = shape(answer)
2184 check_shape = shape(check)
2185
2186 consist_shape = answer_shape == check_shape
2187
2188 if (.not. all(consist_shape)) then
2189 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2190 write(*,*) ''
2191 write(*,*) ' shape of check is (', check_shape, ')'
2192 write(*,*) ' is INCORRECT'
2193 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2194
2195 call abortprogram('')
2196 end if
2197
2198
2199 allocate( mask_array( &
2200 & answer_shape(1), &
2201
2202 & answer_shape(2), &
2203
2204 & answer_shape(3), &
2205
2206 & answer_shape(4), &
2207
2208 & answer_shape(5) ) &
2209 & )
2210
2211 allocate( judge( &
2212 & answer_shape(1), &
2213
2214 & answer_shape(2), &
2215
2216 & answer_shape(3), &
2217
2218 & answer_shape(4), &
2219
2220 & answer_shape(5) ) &
2221 & )
2222
2223 allocate( judge_rev( &
2224 & answer_shape(1), &
2225
2226 & answer_shape(2), &
2227
2228 & answer_shape(3), &
2229
2230 & answer_shape(4), &
2231
2232 & answer_shape(5) ) &
2233 & )
2234
2235
2236 judge = answer == check
2237
2238
2239
2240
2241 judge_rev = .not. judge
2242 err_flag = any(judge_rev)
2243 mask_array = 1
2244 pos = maxloc(mask_array, judge_rev)
2245
2246 if (err_flag) then
2247
2248 wrong = check( &
2249 & pos(1), &
2250
2251 & pos(2), &
2252
2253 & pos(3), &
2254
2255 & pos(4), &
2256
2257 & pos(5) )
2258
2259 right = answer( &
2260 & pos(1), &
2261
2262 & pos(2), &
2263
2264 & pos(3), &
2265
2266 & pos(4), &
2267
2268 & pos(5) )
2269
2270 write(unit=pos_array(1), fmt="(i20)") pos(1)
2271
2272 write(unit=pos_array(2), fmt="(i20)") pos(2)
2273
2274 write(unit=pos_array(3), fmt="(i20)") pos(3)
2275
2276 write(unit=pos_array(4), fmt="(i20)") pos(4)
2277
2278 write(unit=pos_array(5), fmt="(i20)") pos(5)
2279
2280
2281 pos_str = '(' // &
2282 & trim(adjustl(pos_array(1))) // ',' // &
2283
2284 & trim(adjustl(pos_array(2))) // ',' // &
2285
2286 & trim(adjustl(pos_array(3))) // ',' // &
2287
2288 & trim(adjustl(pos_array(4))) // ',' // &
2289
2290 & trim(adjustl(pos_array(5))) // ')'
2291
2292 end if
2293 deallocate(mask_array, judge, judge_rev)
2294
2295
2296
2297
2298 if (err_flag) then
2299 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2300 write(*,*) ''
2301 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2302 write(*,*) ' is NOT EQUAL to'
2303 write(*,*) ' answer' // trim(pos_str) // ' = ', right
2304
2305 call abortprogram('')
2306 else
2307 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2308 end if
2309
2310
2311 end subroutine dctestassertequalint5
2312
2313
2314 subroutine dctestassertequalint6(message, answer, check)
2315 use sysdep, only: abortprogram
2316 use dc_types, only: string, token
2317 implicit none
2318 character(*), intent(in):: message
2319 integer, intent(in):: answer(:,:,:,:,:,:)
2320 integer, intent(in):: check(:,:,:,:,:,:)
2321 logical:: err_flag
2322 character(STRING):: pos_str
2323 integer:: wrong, right
2324
2325 integer:: answer_shape(6), check_shape(6), pos(6)
2326 logical:: consist_shape(6)
2327 character(TOKEN):: pos_array(6)
2328 integer, allocatable:: mask_array(:,:,:,:,:,:)
2329 logical, allocatable:: judge(:,:,:,:,:,:)
2330 logical, allocatable:: judge_rev(:,:,:,:,:,:)
2331
2332
2333
2334
2335 continue
2336 err_flag = .false.
2337
2338
2339 answer_shape = shape(answer)
2340 check_shape = shape(check)
2341
2342 consist_shape = answer_shape == check_shape
2343
2344 if (.not. all(consist_shape)) then
2345 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2346 write(*,*) ''
2347 write(*,*) ' shape of check is (', check_shape, ')'
2348 write(*,*) ' is INCORRECT'
2349 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2350
2351 call abortprogram('')
2352 end if
2353
2354
2355 allocate( mask_array( &
2356 & answer_shape(1), &
2357
2358 & answer_shape(2), &
2359
2360 & answer_shape(3), &
2361
2362 & answer_shape(4), &
2363
2364 & answer_shape(5), &
2365
2366 & answer_shape(6) ) &
2367 & )
2368
2369 allocate( judge( &
2370 & answer_shape(1), &
2371
2372 & answer_shape(2), &
2373
2374 & answer_shape(3), &
2375
2376 & answer_shape(4), &
2377
2378 & answer_shape(5), &
2379
2380 & answer_shape(6) ) &
2381 & )
2382
2383 allocate( judge_rev( &
2384 & answer_shape(1), &
2385
2386 & answer_shape(2), &
2387
2388 & answer_shape(3), &
2389
2390 & answer_shape(4), &
2391
2392 & answer_shape(5), &
2393
2394 & answer_shape(6) ) &
2395 & )
2396
2397
2398 judge = answer == check
2399
2400
2401
2402
2403 judge_rev = .not. judge
2404 err_flag = any(judge_rev)
2405 mask_array = 1
2406 pos = maxloc(mask_array, judge_rev)
2407
2408 if (err_flag) then
2409
2410 wrong = check( &
2411 & pos(1), &
2412
2413 & pos(2), &
2414
2415 & pos(3), &
2416
2417 & pos(4), &
2418
2419 & pos(5), &
2420
2421 & pos(6) )
2422
2423 right = answer( &
2424 & pos(1), &
2425
2426 & pos(2), &
2427
2428 & pos(3), &
2429
2430 & pos(4), &
2431
2432 & pos(5), &
2433
2434 & pos(6) )
2435
2436 write(unit=pos_array(1), fmt="(i20)") pos(1)
2437
2438 write(unit=pos_array(2), fmt="(i20)") pos(2)
2439
2440 write(unit=pos_array(3), fmt="(i20)") pos(3)
2441
2442 write(unit=pos_array(4), fmt="(i20)") pos(4)
2443
2444 write(unit=pos_array(5), fmt="(i20)") pos(5)
2445
2446 write(unit=pos_array(6), fmt="(i20)") pos(6)
2447
2448
2449 pos_str = '(' // &
2450 & trim(adjustl(pos_array(1))) // ',' // &
2451
2452 & trim(adjustl(pos_array(2))) // ',' // &
2453
2454 & trim(adjustl(pos_array(3))) // ',' // &
2455
2456 & trim(adjustl(pos_array(4))) // ',' // &
2457
2458 & trim(adjustl(pos_array(5))) // ',' // &
2459
2460 & trim(adjustl(pos_array(6))) // ')'
2461
2462 end if
2463 deallocate(mask_array, judge, judge_rev)
2464
2465
2466
2467
2468 if (err_flag) then
2469 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2470 write(*,*) ''
2471 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2472 write(*,*) ' is NOT EQUAL to'
2473 write(*,*) ' answer' // trim(pos_str) // ' = ', right
2474
2475 call abortprogram('')
2476 else
2477 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2478 end if
2479
2480
2481 end subroutine dctestassertequalint6
2482
2483
2484 subroutine dctestassertequalint7(message, answer, check)
2485 use sysdep, only: abortprogram
2486 use dc_types, only: string, token
2487 implicit none
2488 character(*), intent(in):: message
2489 integer, intent(in):: answer(:,:,:,:,:,:,:)
2490 integer, intent(in):: check(:,:,:,:,:,:,:)
2491 logical:: err_flag
2492 character(STRING):: pos_str
2493 integer:: wrong, right
2494
2495 integer:: answer_shape(7), check_shape(7), pos(7)
2496 logical:: consist_shape(7)
2497 character(TOKEN):: pos_array(7)
2498 integer, allocatable:: mask_array(:,:,:,:,:,:,:)
2499 logical, allocatable:: judge(:,:,:,:,:,:,:)
2500 logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
2501
2502
2503
2504
2505 continue
2506 err_flag = .false.
2507
2508
2509 answer_shape = shape(answer)
2510 check_shape = shape(check)
2511
2512 consist_shape = answer_shape == check_shape
2513
2514 if (.not. all(consist_shape)) then
2515 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2516 write(*,*) ''
2517 write(*,*) ' shape of check is (', check_shape, ')'
2518 write(*,*) ' is INCORRECT'
2519 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2520
2521 call abortprogram('')
2522 end if
2523
2524
2525 allocate( mask_array( &
2526 & answer_shape(1), &
2527
2528 & answer_shape(2), &
2529
2530 & answer_shape(3), &
2531
2532 & answer_shape(4), &
2533
2534 & answer_shape(5), &
2535
2536 & answer_shape(6), &
2537
2538 & answer_shape(7) ) &
2539 & )
2540
2541 allocate( judge( &
2542 & answer_shape(1), &
2543
2544 & answer_shape(2), &
2545
2546 & answer_shape(3), &
2547
2548 & answer_shape(4), &
2549
2550 & answer_shape(5), &
2551
2552 & answer_shape(6), &
2553
2554 & answer_shape(7) ) &
2555 & )
2556
2557 allocate( judge_rev( &
2558 & answer_shape(1), &
2559
2560 & answer_shape(2), &
2561
2562 & answer_shape(3), &
2563
2564 & answer_shape(4), &
2565
2566 & answer_shape(5), &
2567
2568 & answer_shape(6), &
2569
2570 & answer_shape(7) ) &
2571 & )
2572
2573
2574 judge = answer == check
2575
2576
2577
2578
2579 judge_rev = .not. judge
2580 err_flag = any(judge_rev)
2581 mask_array = 1
2582 pos = maxloc(mask_array, judge_rev)
2583
2584 if (err_flag) then
2585
2586 wrong = check( &
2587 & pos(1), &
2588
2589 & pos(2), &
2590
2591 & pos(3), &
2592
2593 & pos(4), &
2594
2595 & pos(5), &
2596
2597 & pos(6), &
2598
2599 & pos(7) )
2600
2601 right = answer( &
2602 & pos(1), &
2603
2604 & pos(2), &
2605
2606 & pos(3), &
2607
2608 & pos(4), &
2609
2610 & pos(5), &
2611
2612 & pos(6), &
2613
2614 & pos(7) )
2615
2616 write(unit=pos_array(1), fmt="(i20)") pos(1)
2617
2618 write(unit=pos_array(2), fmt="(i20)") pos(2)
2619
2620 write(unit=pos_array(3), fmt="(i20)") pos(3)
2621
2622 write(unit=pos_array(4), fmt="(i20)") pos(4)
2623
2624 write(unit=pos_array(5), fmt="(i20)") pos(5)
2625
2626 write(unit=pos_array(6), fmt="(i20)") pos(6)
2627
2628 write(unit=pos_array(7), fmt="(i20)") pos(7)
2629
2630
2631 pos_str = '(' // &
2632 & trim(adjustl(pos_array(1))) // ',' // &
2633
2634 & trim(adjustl(pos_array(2))) // ',' // &
2635
2636 & trim(adjustl(pos_array(3))) // ',' // &
2637
2638 & trim(adjustl(pos_array(4))) // ',' // &
2639
2640 & trim(adjustl(pos_array(5))) // ',' // &
2641
2642 & trim(adjustl(pos_array(6))) // ',' // &
2643
2644 & trim(adjustl(pos_array(7))) // ')'
2645
2646 end if
2647 deallocate(mask_array, judge, judge_rev)
2648
2649
2650
2651
2652 if (err_flag) then
2653 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2654 write(*,*) ''
2655 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2656 write(*,*) ' is NOT EQUAL to'
2657 write(*,*) ' answer' // trim(pos_str) // ' = ', right
2658
2659 call abortprogram('')
2660 else
2661 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2662 end if
2663
2664
2665 end subroutine dctestassertequalint7
2666
2667
2668 subroutine dctestassertequalreal0(message, answer, check)
2669 use sysdep, only: abortprogram
2670 use dc_types, only: string
2671 implicit none
2672 character(*), intent(in):: message
2673 real, intent(in):: answer
2674 real, intent(in):: check
2675 logical:: err_flag
2676 character(STRING):: pos_str
2677 real:: wrong, right
2678
2679
2680
2681
2682
2683 continue
2684 err_flag = .false.
2685
2686
2687 err_flag = abs(answer - check) > 0.0
2688
2689 wrong = check
2690 right = answer
2691 pos_str = ''
2692
2693
2694
2695
2696 if (err_flag) then
2697 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2698 write(*,*) ''
2699 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2700 write(*,*) ' is NOT EQUAL to'
2701 write(*,*) ' answer' // trim(pos_str) // ' = ', right
2702
2703 call abortprogram('')
2704 else
2705 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2706 end if
2707
2708
2709 end subroutine dctestassertequalreal0
2710
2711
2712 subroutine dctestassertequalreal1(message, answer, check)
2713 use sysdep, only: abortprogram
2714 use dc_types, only: string, token
2715 implicit none
2716 character(*), intent(in):: message
2717 real, intent(in):: answer(:)
2718 real, intent(in):: check(:)
2719 logical:: err_flag
2720 character(STRING):: pos_str
2721 real:: wrong, right
2722
2723 integer:: answer_shape(1), check_shape(1), pos(1)
2724 logical:: consist_shape(1)
2725 character(TOKEN):: pos_array(1)
2726 integer, allocatable:: mask_array(:)
2727 logical, allocatable:: judge(:)
2728 logical, allocatable:: judge_rev(:)
2729
2730
2731
2732
2733 continue
2734 err_flag = .false.
2735
2736
2737 answer_shape = shape(answer)
2738 check_shape = shape(check)
2739
2740 consist_shape = answer_shape == check_shape
2741
2742 if (.not. all(consist_shape)) then
2743 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2744 write(*,*) ''
2745 write(*,*) ' shape of check is (', check_shape, ')'
2746 write(*,*) ' is INCORRECT'
2747 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2748
2749 call abortprogram('')
2750 end if
2751
2752
2753 allocate( mask_array( &
2754
2755 & answer_shape(1) ) &
2756 & )
2757
2758 allocate( judge( &
2759
2760 & answer_shape(1) ) &
2761 & )
2762
2763 allocate( judge_rev( &
2764
2765 & answer_shape(1) ) &
2766 & )
2767
2768
2769 judge = abs(answer - check) <= 0.0
2770
2771
2772
2773
2774 judge_rev = .not. judge
2775 err_flag = any(judge_rev)
2776 mask_array = 1
2777 pos = maxloc(mask_array, judge_rev)
2778
2779 if (err_flag) then
2780
2781 wrong = check( &
2782
2783 & pos(1) )
2784
2785 right = answer( &
2786
2787 & pos(1) )
2788
2789 write(unit=pos_array(1), fmt="(i20)") pos(1)
2790
2791
2792 pos_str = '(' // &
2793
2794 & trim(adjustl(pos_array(1))) // ')'
2795
2796 end if
2797 deallocate(mask_array, judge, judge_rev)
2798
2799
2800
2801
2802 if (err_flag) then
2803 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2804 write(*,*) ''
2805 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2806 write(*,*) ' is NOT EQUAL to'
2807 write(*,*) ' answer' // trim(pos_str) // ' = ', right
2808
2809 call abortprogram('')
2810 else
2811 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2812 end if
2813
2814
2815 end subroutine dctestassertequalreal1
2816
2817
2818 subroutine dctestassertequalreal2(message, answer, check)
2819 use sysdep, only: abortprogram
2820 use dc_types, only: string, token
2821 implicit none
2822 character(*), intent(in):: message
2823 real, intent(in):: answer(:,:)
2824 real, intent(in):: check(:,:)
2825 logical:: err_flag
2826 character(STRING):: pos_str
2827 real:: wrong, right
2828
2829 integer:: answer_shape(2), check_shape(2), pos(2)
2830 logical:: consist_shape(2)
2831 character(TOKEN):: pos_array(2)
2832 integer, allocatable:: mask_array(:,:)
2833 logical, allocatable:: judge(:,:)
2834 logical, allocatable:: judge_rev(:,:)
2835
2836
2837
2838
2839 continue
2840 err_flag = .false.
2841
2842
2843 answer_shape = shape(answer)
2844 check_shape = shape(check)
2845
2846 consist_shape = answer_shape == check_shape
2847
2848 if (.not. all(consist_shape)) then
2849 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2850 write(*,*) ''
2851 write(*,*) ' shape of check is (', check_shape, ')'
2852 write(*,*) ' is INCORRECT'
2853 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2854
2855 call abortprogram('')
2856 end if
2857
2858
2859 allocate( mask_array( &
2860 & answer_shape(1), &
2861
2862 & answer_shape(2) ) &
2863 & )
2864
2865 allocate( judge( &
2866 & answer_shape(1), &
2867
2868 & answer_shape(2) ) &
2869 & )
2870
2871 allocate( judge_rev( &
2872 & answer_shape(1), &
2873
2874 & answer_shape(2) ) &
2875 & )
2876
2877
2878 judge = abs(answer - check) <= 0.0
2879
2880
2881
2882
2883 judge_rev = .not. judge
2884 err_flag = any(judge_rev)
2885 mask_array = 1
2886 pos = maxloc(mask_array, judge_rev)
2887
2888 if (err_flag) then
2889
2890 wrong = check( &
2891 & pos(1), &
2892
2893 & pos(2) )
2894
2895 right = answer( &
2896 & pos(1), &
2897
2898 & pos(2) )
2899
2900 write(unit=pos_array(1), fmt="(i20)") pos(1)
2901
2902 write(unit=pos_array(2), fmt="(i20)") pos(2)
2903
2904
2905 pos_str = '(' // &
2906 & trim(adjustl(pos_array(1))) // ',' // &
2907
2908 & trim(adjustl(pos_array(2))) // ')'
2909
2910 end if
2911 deallocate(mask_array, judge, judge_rev)
2912
2913
2914
2915
2916 if (err_flag) then
2917 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2918 write(*,*) ''
2919 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2920 write(*,*) ' is NOT EQUAL to'
2921 write(*,*) ' answer' // trim(pos_str) // ' = ', right
2922
2923 call abortprogram('')
2924 else
2925 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2926 end if
2927
2928
2929 end subroutine dctestassertequalreal2
2930
2931
2932 subroutine dctestassertequalreal3(message, answer, check)
2933 use sysdep, only: abortprogram
2934 use dc_types, only: string, token
2935 implicit none
2936 character(*), intent(in):: message
2937 real, intent(in):: answer(:,:,:)
2938 real, intent(in):: check(:,:,:)
2939 logical:: err_flag
2940 character(STRING):: pos_str
2941 real:: wrong, right
2942
2943 integer:: answer_shape(3), check_shape(3), pos(3)
2944 logical:: consist_shape(3)
2945 character(TOKEN):: pos_array(3)
2946 integer, allocatable:: mask_array(:,:,:)
2947 logical, allocatable:: judge(:,:,:)
2948 logical, allocatable:: judge_rev(:,:,:)
2949
2950
2951
2952
2953 continue
2954 err_flag = .false.
2955
2956
2957 answer_shape = shape(answer)
2958 check_shape = shape(check)
2959
2960 consist_shape = answer_shape == check_shape
2961
2962 if (.not. all(consist_shape)) then
2963 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2964 write(*,*) ''
2965 write(*,*) ' shape of check is (', check_shape, ')'
2966 write(*,*) ' is INCORRECT'
2967 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2968
2969 call abortprogram('')
2970 end if
2971
2972
2973 allocate( mask_array( &
2974 & answer_shape(1), &
2975
2976 & answer_shape(2), &
2977
2978 & answer_shape(3) ) &
2979 & )
2980
2981 allocate( judge( &
2982 & answer_shape(1), &
2983
2984 & answer_shape(2), &
2985
2986 & answer_shape(3) ) &
2987 & )
2988
2989 allocate( judge_rev( &
2990 & answer_shape(1), &
2991
2992 & answer_shape(2), &
2993
2994 & answer_shape(3) ) &
2995 & )
2996
2997
2998 judge = abs(answer - check) <= 0.0
2999
3000
3001
3002
3003 judge_rev = .not. judge
3004 err_flag = any(judge_rev)
3005 mask_array = 1
3006 pos = maxloc(mask_array, judge_rev)
3007
3008 if (err_flag) then
3009
3010 wrong = check( &
3011 & pos(1), &
3012
3013 & pos(2), &
3014
3015 & pos(3) )
3016
3017 right = answer( &
3018 & pos(1), &
3019
3020 & pos(2), &
3021
3022 & pos(3) )
3023
3024 write(unit=pos_array(1), fmt="(i20)") pos(1)
3025
3026 write(unit=pos_array(2), fmt="(i20)") pos(2)
3027
3028 write(unit=pos_array(3), fmt="(i20)") pos(3)
3029
3030
3031 pos_str = '(' // &
3032 & trim(adjustl(pos_array(1))) // ',' // &
3033
3034 & trim(adjustl(pos_array(2))) // ',' // &
3035
3036 & trim(adjustl(pos_array(3))) // ')'
3037
3038 end if
3039 deallocate(mask_array, judge, judge_rev)
3040
3041
3042
3043
3044 if (err_flag) then
3045 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3046 write(*,*) ''
3047 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3048 write(*,*) ' is NOT EQUAL to'
3049 write(*,*) ' answer' // trim(pos_str) // ' = ', right
3050
3051 call abortprogram('')
3052 else
3053 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3054 end if
3055
3056
3057 end subroutine dctestassertequalreal3
3058
3059
3060 subroutine dctestassertequalreal4(message, answer, check)
3061 use sysdep, only: abortprogram
3062 use dc_types, only: string, token
3063 implicit none
3064 character(*), intent(in):: message
3065 real, intent(in):: answer(:,:,:,:)
3066 real, intent(in):: check(:,:,:,:)
3067 logical:: err_flag
3068 character(STRING):: pos_str
3069 real:: wrong, right
3070
3071 integer:: answer_shape(4), check_shape(4), pos(4)
3072 logical:: consist_shape(4)
3073 character(TOKEN):: pos_array(4)
3074 integer, allocatable:: mask_array(:,:,:,:)
3075 logical, allocatable:: judge(:,:,:,:)
3076 logical, allocatable:: judge_rev(:,:,:,:)
3077
3078
3079
3080
3081 continue
3082 err_flag = .false.
3083
3084
3085 answer_shape = shape(answer)
3086 check_shape = shape(check)
3087
3088 consist_shape = answer_shape == check_shape
3089
3090 if (.not. all(consist_shape)) then
3091 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3092 write(*,*) ''
3093 write(*,*) ' shape of check is (', check_shape, ')'
3094 write(*,*) ' is INCORRECT'
3095 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3096
3097 call abortprogram('')
3098 end if
3099
3100
3101 allocate( mask_array( &
3102 & answer_shape(1), &
3103
3104 & answer_shape(2), &
3105
3106 & answer_shape(3), &
3107
3108 & answer_shape(4) ) &
3109 & )
3110
3111 allocate( judge( &
3112 & answer_shape(1), &
3113
3114 & answer_shape(2), &
3115
3116 & answer_shape(3), &
3117
3118 & answer_shape(4) ) &
3119 & )
3120
3121 allocate( judge_rev( &
3122 & answer_shape(1), &
3123
3124 & answer_shape(2), &
3125
3126 & answer_shape(3), &
3127
3128 & answer_shape(4) ) &
3129 & )
3130
3131
3132 judge = abs(answer - check) <= 0.0
3133
3134
3135
3136
3137 judge_rev = .not. judge
3138 err_flag = any(judge_rev)
3139 mask_array = 1
3140 pos = maxloc(mask_array, judge_rev)
3141
3142 if (err_flag) then
3143
3144 wrong = check( &
3145 & pos(1), &
3146
3147 & pos(2), &
3148
3149 & pos(3), &
3150
3151 & pos(4) )
3152
3153 right = answer( &
3154 & pos(1), &
3155
3156 & pos(2), &
3157
3158 & pos(3), &
3159
3160 & pos(4) )
3161
3162 write(unit=pos_array(1), fmt="(i20)") pos(1)
3163
3164 write(unit=pos_array(2), fmt="(i20)") pos(2)
3165
3166 write(unit=pos_array(3), fmt="(i20)") pos(3)
3167
3168 write(unit=pos_array(4), fmt="(i20)") pos(4)
3169
3170
3171 pos_str = '(' // &
3172 & trim(adjustl(pos_array(1))) // ',' // &
3173
3174 & trim(adjustl(pos_array(2))) // ',' // &
3175
3176 & trim(adjustl(pos_array(3))) // ',' // &
3177
3178 & trim(adjustl(pos_array(4))) // ')'
3179
3180 end if
3181 deallocate(mask_array, judge, judge_rev)
3182
3183
3184
3185
3186 if (err_flag) then
3187 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3188 write(*,*) ''
3189 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3190 write(*,*) ' is NOT EQUAL to'
3191 write(*,*) ' answer' // trim(pos_str) // ' = ', right
3192
3193 call abortprogram('')
3194 else
3195 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3196 end if
3197
3198
3199 end subroutine dctestassertequalreal4
3200
3201
3202 subroutine dctestassertequalreal5(message, answer, check)
3203 use sysdep, only: abortprogram
3204 use dc_types, only: string, token
3205 implicit none
3206 character(*), intent(in):: message
3207 real, intent(in):: answer(:,:,:,:,:)
3208 real, intent(in):: check(:,:,:,:,:)
3209 logical:: err_flag
3210 character(STRING):: pos_str
3211 real:: wrong, right
3212
3213 integer:: answer_shape(5), check_shape(5), pos(5)
3214 logical:: consist_shape(5)
3215 character(TOKEN):: pos_array(5)
3216 integer, allocatable:: mask_array(:,:,:,:,:)
3217 logical, allocatable:: judge(:,:,:,:,:)
3218 logical, allocatable:: judge_rev(:,:,:,:,:)
3219
3220
3221
3222
3223 continue
3224 err_flag = .false.
3225
3226
3227 answer_shape = shape(answer)
3228 check_shape = shape(check)
3229
3230 consist_shape = answer_shape == check_shape
3231
3232 if (.not. all(consist_shape)) then
3233 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3234 write(*,*) ''
3235 write(*,*) ' shape of check is (', check_shape, ')'
3236 write(*,*) ' is INCORRECT'
3237 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3238
3239 call abortprogram('')
3240 end if
3241
3242
3243 allocate( mask_array( &
3244 & answer_shape(1), &
3245
3246 & answer_shape(2), &
3247
3248 & answer_shape(3), &
3249
3250 & answer_shape(4), &
3251
3252 & answer_shape(5) ) &
3253 & )
3254
3255 allocate( judge( &
3256 & answer_shape(1), &
3257
3258 & answer_shape(2), &
3259
3260 & answer_shape(3), &
3261
3262 & answer_shape(4), &
3263
3264 & answer_shape(5) ) &
3265 & )
3266
3267 allocate( judge_rev( &
3268 & answer_shape(1), &
3269
3270 & answer_shape(2), &
3271
3272 & answer_shape(3), &
3273
3274 & answer_shape(4), &
3275
3276 & answer_shape(5) ) &
3277 & )
3278
3279
3280 judge = abs(answer - check) <= 0.0
3281
3282
3283
3284
3285 judge_rev = .not. judge
3286 err_flag = any(judge_rev)
3287 mask_array = 1
3288 pos = maxloc(mask_array, judge_rev)
3289
3290 if (err_flag) then
3291
3292 wrong = check( &
3293 & pos(1), &
3294
3295 & pos(2), &
3296
3297 & pos(3), &
3298
3299 & pos(4), &
3300
3301 & pos(5) )
3302
3303 right = answer( &
3304 & pos(1), &
3305
3306 & pos(2), &
3307
3308 & pos(3), &
3309
3310 & pos(4), &
3311
3312 & pos(5) )
3313
3314 write(unit=pos_array(1), fmt="(i20)") pos(1)
3315
3316 write(unit=pos_array(2), fmt="(i20)") pos(2)
3317
3318 write(unit=pos_array(3), fmt="(i20)") pos(3)
3319
3320 write(unit=pos_array(4), fmt="(i20)") pos(4)
3321
3322 write(unit=pos_array(5), fmt="(i20)") pos(5)
3323
3324
3325 pos_str = '(' // &
3326 & trim(adjustl(pos_array(1))) // ',' // &
3327
3328 & trim(adjustl(pos_array(2))) // ',' // &
3329
3330 & trim(adjustl(pos_array(3))) // ',' // &
3331
3332 & trim(adjustl(pos_array(4))) // ',' // &
3333
3334 & trim(adjustl(pos_array(5))) // ')'
3335
3336 end if
3337 deallocate(mask_array, judge, judge_rev)
3338
3339
3340
3341
3342 if (err_flag) then
3343 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3344 write(*,*) ''
3345 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3346 write(*,*) ' is NOT EQUAL to'
3347 write(*,*) ' answer' // trim(pos_str) // ' = ', right
3348
3349 call abortprogram('')
3350 else
3351 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3352 end if
3353
3354
3355 end subroutine dctestassertequalreal5
3356
3357
3358 subroutine dctestassertequalreal6(message, answer, check)
3359 use sysdep, only: abortprogram
3360 use dc_types, only: string, token
3361 implicit none
3362 character(*), intent(in):: message
3363 real, intent(in):: answer(:,:,:,:,:,:)
3364 real, intent(in):: check(:,:,:,:,:,:)
3365 logical:: err_flag
3366 character(STRING):: pos_str
3367 real:: wrong, right
3368
3369 integer:: answer_shape(6), check_shape(6), pos(6)
3370 logical:: consist_shape(6)
3371 character(TOKEN):: pos_array(6)
3372 integer, allocatable:: mask_array(:,:,:,:,:,:)
3373 logical, allocatable:: judge(:,:,:,:,:,:)
3374 logical, allocatable:: judge_rev(:,:,:,:,:,:)
3375
3376
3377
3378
3379 continue
3380 err_flag = .false.
3381
3382
3383 answer_shape = shape(answer)
3384 check_shape = shape(check)
3385
3386 consist_shape = answer_shape == check_shape
3387
3388 if (.not. all(consist_shape)) then
3389 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3390 write(*,*) ''
3391 write(*,*) ' shape of check is (', check_shape, ')'
3392 write(*,*) ' is INCORRECT'
3393 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3394
3395 call abortprogram('')
3396 end if
3397
3398
3399 allocate( mask_array( &
3400 & answer_shape(1), &
3401
3402 & answer_shape(2), &
3403
3404 & answer_shape(3), &
3405
3406 & answer_shape(4), &
3407
3408 & answer_shape(5), &
3409
3410 & answer_shape(6) ) &
3411 & )
3412
3413 allocate( judge( &
3414 & answer_shape(1), &
3415
3416 & answer_shape(2), &
3417
3418 & answer_shape(3), &
3419
3420 & answer_shape(4), &
3421
3422 & answer_shape(5), &
3423
3424 & answer_shape(6) ) &
3425 & )
3426
3427 allocate( judge_rev( &
3428 & answer_shape(1), &
3429
3430 & answer_shape(2), &
3431
3432 & answer_shape(3), &
3433
3434 & answer_shape(4), &
3435
3436 & answer_shape(5), &
3437
3438 & answer_shape(6) ) &
3439 & )
3440
3441
3442 judge = abs(answer - check) <= 0.0
3443
3444
3445
3446
3447 judge_rev = .not. judge
3448 err_flag = any(judge_rev)
3449 mask_array = 1
3450 pos = maxloc(mask_array, judge_rev)
3451
3452 if (err_flag) then
3453
3454 wrong = check( &
3455 & pos(1), &
3456
3457 & pos(2), &
3458
3459 & pos(3), &
3460
3461 & pos(4), &
3462
3463 & pos(5), &
3464
3465 & pos(6) )
3466
3467 right = answer( &
3468 & pos(1), &
3469
3470 & pos(2), &
3471
3472 & pos(3), &
3473
3474 & pos(4), &
3475
3476 & pos(5), &
3477
3478 & pos(6) )
3479
3480 write(unit=pos_array(1), fmt="(i20)") pos(1)
3481
3482 write(unit=pos_array(2), fmt="(i20)") pos(2)
3483
3484 write(unit=pos_array(3), fmt="(i20)") pos(3)
3485
3486 write(unit=pos_array(4), fmt="(i20)") pos(4)
3487
3488 write(unit=pos_array(5), fmt="(i20)") pos(5)
3489
3490 write(unit=pos_array(6), fmt="(i20)") pos(6)
3491
3492
3493 pos_str = '(' // &
3494 & trim(adjustl(pos_array(1))) // ',' // &
3495
3496 & trim(adjustl(pos_array(2))) // ',' // &
3497
3498 & trim(adjustl(pos_array(3))) // ',' // &
3499
3500 & trim(adjustl(pos_array(4))) // ',' // &
3501
3502 & trim(adjustl(pos_array(5))) // ',' // &
3503
3504 & trim(adjustl(pos_array(6))) // ')'
3505
3506 end if
3507 deallocate(mask_array, judge, judge_rev)
3508
3509
3510
3511
3512 if (err_flag) then
3513 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3514 write(*,*) ''
3515 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3516 write(*,*) ' is NOT EQUAL to'
3517 write(*,*) ' answer' // trim(pos_str) // ' = ', right
3518
3519 call abortprogram('')
3520 else
3521 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3522 end if
3523
3524
3525 end subroutine dctestassertequalreal6
3526
3527
3528 subroutine dctestassertequalreal7(message, answer, check)
3529 use sysdep, only: abortprogram
3530 use dc_types, only: string, token
3531 implicit none
3532 character(*), intent(in):: message
3533 real, intent(in):: answer(:,:,:,:,:,:,:)
3534 real, intent(in):: check(:,:,:,:,:,:,:)
3535 logical:: err_flag
3536 character(STRING):: pos_str
3537 real:: wrong, right
3538
3539 integer:: answer_shape(7), check_shape(7), pos(7)
3540 logical:: consist_shape(7)
3541 character(TOKEN):: pos_array(7)
3542 integer, allocatable:: mask_array(:,:,:,:,:,:,:)
3543 logical, allocatable:: judge(:,:,:,:,:,:,:)
3544 logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
3545
3546
3547
3548
3549 continue
3550 err_flag = .false.
3551
3552
3553 answer_shape = shape(answer)
3554 check_shape = shape(check)
3555
3556 consist_shape = answer_shape == check_shape
3557
3558 if (.not. all(consist_shape)) then
3559 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3560 write(*,*) ''
3561 write(*,*) ' shape of check is (', check_shape, ')'
3562 write(*,*) ' is INCORRECT'
3563 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3564
3565 call abortprogram('')
3566 end if
3567
3568
3569 allocate( mask_array( &
3570 & answer_shape(1), &
3571
3572 & answer_shape(2), &
3573
3574 & answer_shape(3), &
3575
3576 & answer_shape(4), &
3577
3578 & answer_shape(5), &
3579
3580 & answer_shape(6), &
3581
3582 & answer_shape(7) ) &
3583 & )
3584
3585 allocate( judge( &
3586 & answer_shape(1), &
3587
3588 & answer_shape(2), &
3589
3590 & answer_shape(3), &
3591
3592 & answer_shape(4), &
3593
3594 & answer_shape(5), &
3595
3596 & answer_shape(6), &
3597
3598 & answer_shape(7) ) &
3599 & )
3600
3601 allocate( judge_rev( &
3602 & answer_shape(1), &
3603
3604 & answer_shape(2), &
3605
3606 & answer_shape(3), &
3607
3608 & answer_shape(4), &
3609
3610 & answer_shape(5), &
3611
3612 & answer_shape(6), &
3613
3614 & answer_shape(7) ) &
3615 & )
3616
3617
3618 judge = abs(answer - check) <= 0.0
3619
3620
3621
3622
3623 judge_rev = .not. judge
3624 err_flag = any(judge_rev)
3625 mask_array = 1
3626 pos = maxloc(mask_array, judge_rev)
3627
3628 if (err_flag) then
3629
3630 wrong = check( &
3631 & pos(1), &
3632
3633 & pos(2), &
3634
3635 & pos(3), &
3636
3637 & pos(4), &
3638
3639 & pos(5), &
3640
3641 & pos(6), &
3642
3643 & pos(7) )
3644
3645 right = answer( &
3646 & pos(1), &
3647
3648 & pos(2), &
3649
3650 & pos(3), &
3651
3652 & pos(4), &
3653
3654 & pos(5), &
3655
3656 & pos(6), &
3657
3658 & pos(7) )
3659
3660 write(unit=pos_array(1), fmt="(i20)") pos(1)
3661
3662 write(unit=pos_array(2), fmt="(i20)") pos(2)
3663
3664 write(unit=pos_array(3), fmt="(i20)") pos(3)
3665
3666 write(unit=pos_array(4), fmt="(i20)") pos(4)
3667
3668 write(unit=pos_array(5), fmt="(i20)") pos(5)
3669
3670 write(unit=pos_array(6), fmt="(i20)") pos(6)
3671
3672 write(unit=pos_array(7), fmt="(i20)") pos(7)
3673
3674
3675 pos_str = '(' // &
3676 & trim(adjustl(pos_array(1))) // ',' // &
3677
3678 & trim(adjustl(pos_array(2))) // ',' // &
3679
3680 & trim(adjustl(pos_array(3))) // ',' // &
3681
3682 & trim(adjustl(pos_array(4))) // ',' // &
3683
3684 & trim(adjustl(pos_array(5))) // ',' // &
3685
3686 & trim(adjustl(pos_array(6))) // ',' // &
3687
3688 & trim(adjustl(pos_array(7))) // ')'
3689
3690 end if
3691 deallocate(mask_array, judge, judge_rev)
3692
3693
3694
3695
3696 if (err_flag) then
3697 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3698 write(*,*) ''
3699 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3700 write(*,*) ' is NOT EQUAL to'
3701 write(*,*) ' answer' // trim(pos_str) // ' = ', right
3702
3703 call abortprogram('')
3704 else
3705 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3706 end if
3707
3708
3709 end subroutine dctestassertequalreal7
3710
3711
3712 subroutine dctestassertequaldouble0(message, answer, check)
3713 use sysdep, only: abortprogram
3714 use dc_types, only: string
3715 implicit none
3716 character(*), intent(in):: message
3717 real(DP), intent(in):: answer
3718 real(DP), intent(in):: check
3719 logical:: err_flag
3720 character(STRING):: pos_str
3721 real(DP):: wrong, right
3722
3723
3724
3725
3726
3727 continue
3728 err_flag = .false.
3729
3730
3731 err_flag = abs(answer - check) > 0.0_dp
3732
3733 wrong = check
3734 right = answer
3735 pos_str = ''
3736
3737
3738
3739
3740 if (err_flag) then
3741 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3742 write(*,*) ''
3743 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3744 write(*,*) ' is NOT EQUAL to'
3745 write(*,*) ' answer' // trim(pos_str) // ' = ', right
3746
3747 call abortprogram('')
3748 else
3749 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3750 end if
3751
3752
3753 end subroutine dctestassertequaldouble0
3754
3755
3756 subroutine dctestassertequaldouble1(message, answer, check)
3757 use sysdep, only: abortprogram
3758 use dc_types, only: string, token
3759 implicit none
3760 character(*), intent(in):: message
3761 real(DP), intent(in):: answer(:)
3762 real(DP), intent(in):: check(:)
3763 logical:: err_flag
3764 character(STRING):: pos_str
3765 real(DP):: wrong, right
3766
3767 integer:: answer_shape(1), check_shape(1), pos(1)
3768 logical:: consist_shape(1)
3769 character(TOKEN):: pos_array(1)
3770 integer, allocatable:: mask_array(:)
3771 logical, allocatable:: judge(:)
3772 logical, allocatable:: judge_rev(:)
3773
3774
3775
3776
3777 continue
3778 err_flag = .false.
3779
3780
3781 answer_shape = shape(answer)
3782 check_shape = shape(check)
3783
3784 consist_shape = answer_shape == check_shape
3785
3786 if (.not. all(consist_shape)) then
3787 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3788 write(*,*) ''
3789 write(*,*) ' shape of check is (', check_shape, ')'
3790 write(*,*) ' is INCORRECT'
3791 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3792
3793 call abortprogram('')
3794 end if
3795
3796
3797 allocate( mask_array( &
3798
3799 & answer_shape(1) ) &
3800 & )
3801
3802 allocate( judge( &
3803
3804 & answer_shape(1) ) &
3805 & )
3806
3807 allocate( judge_rev( &
3808
3809 & answer_shape(1) ) &
3810 & )
3811
3812
3813 judge = abs(answer - check) <= 0.0_dp
3814
3815
3816
3817
3818 judge_rev = .not. judge
3819 err_flag = any(judge_rev)
3820 mask_array = 1
3821 pos = maxloc(mask_array, judge_rev)
3822
3823 if (err_flag) then
3824
3825 wrong = check( &
3826
3827 & pos(1) )
3828
3829 right = answer( &
3830
3831 & pos(1) )
3832
3833 write(unit=pos_array(1), fmt="(i20)") pos(1)
3834
3835
3836 pos_str = '(' // &
3837
3838 & trim(adjustl(pos_array(1))) // ')'
3839
3840 end if
3841 deallocate(mask_array, judge, judge_rev)
3842
3843
3844
3845
3846 if (err_flag) then
3847 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3848 write(*,*) ''
3849 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3850 write(*,*) ' is NOT EQUAL to'
3851 write(*,*) ' answer' // trim(pos_str) // ' = ', right
3852
3853 call abortprogram('')
3854 else
3855 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3856 end if
3857
3858
3859 end subroutine dctestassertequaldouble1
3860
3861
3862 subroutine dctestassertequaldouble2(message, answer, check)
3863 use sysdep, only: abortprogram
3864 use dc_types, only: string, token
3865 implicit none
3866 character(*), intent(in):: message
3867 real(DP), intent(in):: answer(:,:)
3868 real(DP), intent(in):: check(:,:)
3869 logical:: err_flag
3870 character(STRING):: pos_str
3871 real(DP):: wrong, right
3872
3873 integer:: answer_shape(2), check_shape(2), pos(2)
3874 logical:: consist_shape(2)
3875 character(TOKEN):: pos_array(2)
3876 integer, allocatable:: mask_array(:,:)
3877 logical, allocatable:: judge(:,:)
3878 logical, allocatable:: judge_rev(:,:)
3879
3880
3881
3882
3883 continue
3884 err_flag = .false.
3885
3886
3887 answer_shape = shape(answer)
3888 check_shape = shape(check)
3889
3890 consist_shape = answer_shape == check_shape
3891
3892 if (.not. all(consist_shape)) then
3893 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3894 write(*,*) ''
3895 write(*,*) ' shape of check is (', check_shape, ')'
3896 write(*,*) ' is INCORRECT'
3897 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3898
3899 call abortprogram('')
3900 end if
3901
3902
3903 allocate( mask_array( &
3904 & answer_shape(1), &
3905
3906 & answer_shape(2) ) &
3907 & )
3908
3909 allocate( judge( &
3910 & answer_shape(1), &
3911
3912 & answer_shape(2) ) &
3913 & )
3914
3915 allocate( judge_rev( &
3916 & answer_shape(1), &
3917
3918 & answer_shape(2) ) &
3919 & )
3920
3921
3922 judge = abs(answer - check) <= 0.0_dp
3923
3924
3925
3926
3927 judge_rev = .not. judge
3928 err_flag = any(judge_rev)
3929 mask_array = 1
3930 pos = maxloc(mask_array, judge_rev)
3931
3932 if (err_flag) then
3933
3934 wrong = check( &
3935 & pos(1), &
3936
3937 & pos(2) )
3938
3939 right = answer( &
3940 & pos(1), &
3941
3942 & pos(2) )
3943
3944 write(unit=pos_array(1), fmt="(i20)") pos(1)
3945
3946 write(unit=pos_array(2), fmt="(i20)") pos(2)
3947
3948
3949 pos_str = '(' // &
3950 & trim(adjustl(pos_array(1))) // ',' // &
3951
3952 & trim(adjustl(pos_array(2))) // ')'
3953
3954 end if
3955 deallocate(mask_array, judge, judge_rev)
3956
3957
3958
3959
3960 if (err_flag) then
3961 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3962 write(*,*) ''
3963 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3964 write(*,*) ' is NOT EQUAL to'
3965 write(*,*) ' answer' // trim(pos_str) // ' = ', right
3966
3967 call abortprogram('')
3968 else
3969 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3970 end if
3971
3972
3973 end subroutine dctestassertequaldouble2
3974
3975
3976 subroutine dctestassertequaldouble3(message, answer, check)
3977 use sysdep, only: abortprogram
3978 use dc_types, only: string, token
3979 implicit none
3980 character(*), intent(in):: message
3981 real(DP), intent(in):: answer(:,:,:)
3982 real(DP), intent(in):: check(:,:,:)
3983 logical:: err_flag
3984 character(STRING):: pos_str
3985 real(DP):: wrong, right
3986
3987 integer:: answer_shape(3), check_shape(3), pos(3)
3988 logical:: consist_shape(3)
3989 character(TOKEN):: pos_array(3)
3990 integer, allocatable:: mask_array(:,:,:)
3991 logical, allocatable:: judge(:,:,:)
3992 logical, allocatable:: judge_rev(:,:,:)
3993
3994
3995
3996
3997 continue
3998 err_flag = .false.
3999
4000
4001 answer_shape = shape(answer)
4002 check_shape = shape(check)
4003
4004 consist_shape = answer_shape == check_shape
4005
4006 if (.not. all(consist_shape)) then
4007 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4008 write(*,*) ''
4009 write(*,*) ' shape of check is (', check_shape, ')'
4010 write(*,*) ' is INCORRECT'
4011 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
4012
4013 call abortprogram('')
4014 end if
4015
4016
4017 allocate( mask_array( &
4018 & answer_shape(1), &
4019
4020 & answer_shape(2), &
4021
4022 & answer_shape(3) ) &
4023 & )
4024
4025 allocate( judge( &
4026 & answer_shape(1), &
4027
4028 & answer_shape(2), &
4029
4030 & answer_shape(3) ) &
4031 & )
4032
4033 allocate( judge_rev( &
4034 & answer_shape(1), &
4035
4036 & answer_shape(2), &
4037
4038 & answer_shape(3) ) &
4039 & )
4040
4041
4042 judge = abs(answer - check) <= 0.0_dp
4043
4044
4045
4046
4047 judge_rev = .not. judge
4048 err_flag = any(judge_rev)
4049 mask_array = 1
4050 pos = maxloc(mask_array, judge_rev)
4051
4052 if (err_flag) then
4053
4054 wrong = check( &
4055 & pos(1), &
4056
4057 & pos(2), &
4058
4059 & pos(3) )
4060
4061 right = answer( &
4062 & pos(1), &
4063
4064 & pos(2), &
4065
4066 & pos(3) )
4067
4068 write(unit=pos_array(1), fmt="(i20)") pos(1)
4069
4070 write(unit=pos_array(2), fmt="(i20)") pos(2)
4071
4072 write(unit=pos_array(3), fmt="(i20)") pos(3)
4073
4074
4075 pos_str = '(' // &
4076 & trim(adjustl(pos_array(1))) // ',' // &
4077
4078 & trim(adjustl(pos_array(2))) // ',' // &
4079
4080 & trim(adjustl(pos_array(3))) // ')'
4081
4082 end if
4083 deallocate(mask_array, judge, judge_rev)
4084
4085
4086
4087
4088 if (err_flag) then
4089 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4090 write(*,*) ''
4091 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
4092 write(*,*) ' is NOT EQUAL to'
4093 write(*,*) ' answer' // trim(pos_str) // ' = ', right
4094
4095 call abortprogram('')
4096 else
4097 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
4098 end if
4099
4100
4101 end subroutine dctestassertequaldouble3
4102
4103
4104 subroutine dctestassertequaldouble4(message, answer, check)
4105 use sysdep, only: abortprogram
4106 use dc_types, only: string, token
4107 implicit none
4108 character(*), intent(in):: message
4109 real(DP), intent(in):: answer(:,:,:,:)
4110 real(DP), intent(in):: check(:,:,:,:)
4111 logical:: err_flag
4112 character(STRING):: pos_str
4113 real(DP):: wrong, right
4114
4115 integer:: answer_shape(4), check_shape(4), pos(4)
4116 logical:: consist_shape(4)
4117 character(TOKEN):: pos_array(4)
4118 integer, allocatable:: mask_array(:,:,:,:)
4119 logical, allocatable:: judge(:,:,:,:)
4120 logical, allocatable:: judge_rev(:,:,:,:)
4121
4122
4123
4124
4125 continue
4126 err_flag = .false.
4127
4128
4129 answer_shape = shape(answer)
4130 check_shape = shape(check)
4131
4132 consist_shape = answer_shape == check_shape
4133
4134 if (.not. all(consist_shape)) then
4135 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4136 write(*,*) ''
4137 write(*,*) ' shape of check is (', check_shape, ')'
4138 write(*,*) ' is INCORRECT'
4139 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
4140
4141 call abortprogram('')
4142 end if
4143
4144
4145 allocate( mask_array( &
4146 & answer_shape(1), &
4147
4148 & answer_shape(2), &
4149
4150 & answer_shape(3), &
4151
4152 & answer_shape(4) ) &
4153 & )
4154
4155 allocate( judge( &
4156 & answer_shape(1), &
4157
4158 & answer_shape(2), &
4159
4160 & answer_shape(3), &
4161
4162 & answer_shape(4) ) &
4163 & )
4164
4165 allocate( judge_rev( &
4166 & answer_shape(1), &
4167
4168 & answer_shape(2), &
4169
4170 & answer_shape(3), &
4171
4172 & answer_shape(4) ) &
4173 & )
4174
4175
4176 judge = abs(answer - check) <= 0.0_dp
4177
4178
4179
4180
4181 judge_rev = .not. judge
4182 err_flag = any(judge_rev)
4183 mask_array = 1
4184 pos = maxloc(mask_array, judge_rev)
4185
4186 if (err_flag) then
4187
4188 wrong = check( &
4189 & pos(1), &
4190
4191 & pos(2), &
4192
4193 & pos(3), &
4194
4195 & pos(4) )
4196
4197 right = answer( &
4198 & pos(1), &
4199
4200 & pos(2), &
4201
4202 & pos(3), &
4203
4204 & pos(4) )
4205
4206 write(unit=pos_array(1), fmt="(i20)") pos(1)
4207
4208 write(unit=pos_array(2), fmt="(i20)") pos(2)
4209
4210 write(unit=pos_array(3), fmt="(i20)") pos(3)
4211
4212 write(unit=pos_array(4), fmt="(i20)") pos(4)
4213
4214
4215 pos_str = '(' // &
4216 & trim(adjustl(pos_array(1))) // ',' // &
4217
4218 & trim(adjustl(pos_array(2))) // ',' // &
4219
4220 & trim(adjustl(pos_array(3))) // ',' // &
4221
4222 & trim(adjustl(pos_array(4))) // ')'
4223
4224 end if
4225 deallocate(mask_array, judge, judge_rev)
4226
4227
4228
4229
4230 if (err_flag) then
4231 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4232 write(*,*) ''
4233 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
4234 write(*,*) ' is NOT EQUAL to'
4235 write(*,*) ' answer' // trim(pos_str) // ' = ', right
4236
4237 call abortprogram('')
4238 else
4239 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
4240 end if
4241
4242
4243 end subroutine dctestassertequaldouble4
4244
4245
4246 subroutine dctestassertequaldouble5(message, answer, check)
4247 use sysdep, only: abortprogram
4248 use dc_types, only: string, token
4249 implicit none
4250 character(*), intent(in):: message
4251 real(DP), intent(in):: answer(:,:,:,:,:)
4252 real(DP), intent(in):: check(:,:,:,:,:)
4253 logical:: err_flag
4254 character(STRING):: pos_str
4255 real(DP):: wrong, right
4256
4257 integer:: answer_shape(5), check_shape(5), pos(5)
4258 logical:: consist_shape(5)
4259 character(TOKEN):: pos_array(5)
4260 integer, allocatable:: mask_array(:,:,:,:,:)
4261 logical, allocatable:: judge(:,:,:,:,:)
4262 logical, allocatable:: judge_rev(:,:,:,:,:)
4263
4264
4265
4266
4267 continue
4268 err_flag = .false.
4269
4270
4271 answer_shape = shape(answer)
4272 check_shape = shape(check)
4273
4274 consist_shape = answer_shape == check_shape
4275
4276 if (.not. all(consist_shape)) then
4277 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4278 write(*,*) ''
4279 write(*,*) ' shape of check is (', check_shape, ')'
4280 write(*,*) ' is INCORRECT'
4281 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
4282
4283 call abortprogram('')
4284 end if
4285
4286
4287 allocate( mask_array( &
4288 & answer_shape(1), &
4289
4290 & answer_shape(2), &
4291
4292 & answer_shape(3), &
4293
4294 & answer_shape(4), &
4295
4296 & answer_shape(5) ) &
4297 & )
4298
4299 allocate( judge( &
4300 & answer_shape(1), &
4301
4302 & answer_shape(2), &
4303
4304 & answer_shape(3), &
4305
4306 & answer_shape(4), &
4307
4308 & answer_shape(5) ) &
4309 & )
4310
4311 allocate( judge_rev( &
4312 & answer_shape(1), &
4313
4314 & answer_shape(2), &
4315
4316 & answer_shape(3), &
4317
4318 & answer_shape(4), &
4319
4320 & answer_shape(5) ) &
4321 & )
4322
4323
4324 judge = abs(answer - check) <= 0.0_dp
4325
4326
4327
4328
4329 judge_rev = .not. judge
4330 err_flag = any(judge_rev)
4331 mask_array = 1
4332 pos = maxloc(mask_array, judge_rev)
4333
4334 if (err_flag) then
4335
4336 wrong = check( &
4337 & pos(1), &
4338
4339 & pos(2), &
4340
4341 & pos(3), &
4342
4343 & pos(4), &
4344
4345 & pos(5) )
4346
4347 right = answer( &
4348 & pos(1), &
4349
4350 & pos(2), &
4351
4352 & pos(3), &
4353
4354 & pos(4), &
4355
4356 & pos(5) )
4357
4358 write(unit=pos_array(1), fmt="(i20)") pos(1)
4359
4360 write(unit=pos_array(2), fmt="(i20)") pos(2)
4361
4362 write(unit=pos_array(3), fmt="(i20)") pos(3)
4363
4364 write(unit=pos_array(4), fmt="(i20)") pos(4)
4365
4366 write(unit=pos_array(5), fmt="(i20)") pos(5)
4367
4368
4369 pos_str = '(' // &
4370 & trim(adjustl(pos_array(1))) // ',' // &
4371
4372 & trim(adjustl(pos_array(2))) // ',' // &
4373
4374 & trim(adjustl(pos_array(3))) // ',' // &
4375
4376 & trim(adjustl(pos_array(4))) // ',' // &
4377
4378 & trim(adjustl(pos_array(5))) // ')'
4379
4380 end if
4381 deallocate(mask_array, judge, judge_rev)
4382
4383
4384
4385
4386 if (err_flag) then
4387 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4388 write(*,*) ''
4389 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
4390 write(*,*) ' is NOT EQUAL to'
4391 write(*,*) ' answer' // trim(pos_str) // ' = ', right
4392
4393 call abortprogram('')
4394 else
4395 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
4396 end if
4397
4398
4399 end subroutine dctestassertequaldouble5
4400
4401
4402 subroutine dctestassertequaldouble6(message, answer, check)
4403 use sysdep, only: abortprogram
4404 use dc_types, only: string, token
4405 implicit none
4406 character(*), intent(in):: message
4407 real(DP), intent(in):: answer(:,:,:,:,:,:)
4408 real(DP), intent(in):: check(:,:,:,:,:,:)
4409 logical:: err_flag
4410 character(STRING):: pos_str
4411 real(DP):: wrong, right
4412
4413 integer:: answer_shape(6), check_shape(6), pos(6)
4414 logical:: consist_shape(6)
4415 character(TOKEN):: pos_array(6)
4416 integer, allocatable:: mask_array(:,:,:,:,:,:)
4417 logical, allocatable:: judge(:,:,:,:,:,:)
4418 logical, allocatable:: judge_rev(:,:,:,:,:,:)
4419
4420
4421
4422
4423 continue
4424 err_flag = .false.
4425
4426
4427 answer_shape = shape(answer)
4428 check_shape = shape(check)
4429
4430 consist_shape = answer_shape == check_shape
4431
4432 if (.not. all(consist_shape)) then
4433 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4434 write(*,*) ''
4435 write(*,*) ' shape of check is (', check_shape, ')'
4436 write(*,*) ' is INCORRECT'
4437 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
4438
4439 call abortprogram('')
4440 end if
4441
4442
4443 allocate( mask_array( &
4444 & answer_shape(1), &
4445
4446 & answer_shape(2), &
4447
4448 & answer_shape(3), &
4449
4450 & answer_shape(4), &
4451
4452 & answer_shape(5), &
4453
4454 & answer_shape(6) ) &
4455 & )
4456
4457 allocate( judge( &
4458 & answer_shape(1), &
4459
4460 & answer_shape(2), &
4461
4462 & answer_shape(3), &
4463
4464 & answer_shape(4), &
4465
4466 & answer_shape(5), &
4467
4468 & answer_shape(6) ) &
4469 & )
4470
4471 allocate( judge_rev( &
4472 & answer_shape(1), &
4473
4474 & answer_shape(2), &
4475
4476 & answer_shape(3), &
4477
4478 & answer_shape(4), &
4479
4480 & answer_shape(5), &
4481
4482 & answer_shape(6) ) &
4483 & )
4484
4485
4486 judge = abs(answer - check) <= 0.0_dp
4487
4488
4489
4490
4491 judge_rev = .not. judge
4492 err_flag = any(judge_rev)
4493 mask_array = 1
4494 pos = maxloc(mask_array, judge_rev)
4495
4496 if (err_flag) then
4497
4498 wrong = check( &
4499 & pos(1), &
4500
4501 & pos(2), &
4502
4503 & pos(3), &
4504
4505 & pos(4), &
4506
4507 & pos(5), &
4508
4509 & pos(6) )
4510
4511 right = answer( &
4512 & pos(1), &
4513
4514 & pos(2), &
4515
4516 & pos(3), &
4517
4518 & pos(4), &
4519
4520 & pos(5), &
4521
4522 & pos(6) )
4523
4524 write(unit=pos_array(1), fmt="(i20)") pos(1)
4525
4526 write(unit=pos_array(2), fmt="(i20)") pos(2)
4527
4528 write(unit=pos_array(3), fmt="(i20)") pos(3)
4529
4530 write(unit=pos_array(4), fmt="(i20)") pos(4)
4531
4532 write(unit=pos_array(5), fmt="(i20)") pos(5)
4533
4534 write(unit=pos_array(6), fmt="(i20)") pos(6)
4535
4536
4537 pos_str = '(' // &
4538 & trim(adjustl(pos_array(1))) // ',' // &
4539
4540 & trim(adjustl(pos_array(2))) // ',' // &
4541
4542 & trim(adjustl(pos_array(3))) // ',' // &
4543
4544 & trim(adjustl(pos_array(4))) // ',' // &
4545
4546 & trim(adjustl(pos_array(5))) // ',' // &
4547
4548 & trim(adjustl(pos_array(6))) // ')'
4549
4550 end if
4551 deallocate(mask_array, judge, judge_rev)
4552
4553
4554
4555
4556 if (err_flag) then
4557 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4558 write(*,*) ''
4559 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
4560 write(*,*) ' is NOT EQUAL to'
4561 write(*,*) ' answer' // trim(pos_str) // ' = ', right
4562
4563 call abortprogram('')
4564 else
4565 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
4566 end if
4567
4568
4569 end subroutine dctestassertequaldouble6
4570
4571
4572 subroutine dctestassertequaldouble7(message, answer, check)
4573 use sysdep, only: abortprogram
4574 use dc_types, only: string, token
4575 implicit none
4576 character(*), intent(in):: message
4577 real(DP), intent(in):: answer(:,:,:,:,:,:,:)
4578 real(DP), intent(in):: check(:,:,:,:,:,:,:)
4579 logical:: err_flag
4580 character(STRING):: pos_str
4581 real(DP):: wrong, right
4582
4583 integer:: answer_shape(7), check_shape(7), pos(7)
4584 logical:: consist_shape(7)
4585 character(TOKEN):: pos_array(7)
4586 integer, allocatable:: mask_array(:,:,:,:,:,:,:)
4587 logical, allocatable:: judge(:,:,:,:,:,:,:)
4588 logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
4589
4590
4591
4592
4593 continue
4594 err_flag = .false.
4595
4596
4597 answer_shape = shape(answer)
4598 check_shape = shape(check)
4599
4600 consist_shape = answer_shape == check_shape
4601
4602 if (.not. all(consist_shape)) then
4603 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4604 write(*,*) ''
4605 write(*,*) ' shape of check is (', check_shape, ')'
4606 write(*,*) ' is INCORRECT'
4607 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
4608
4609 call abortprogram('')
4610 end if
4611
4612
4613 allocate( mask_array( &
4614 & answer_shape(1), &
4615
4616 & answer_shape(2), &
4617
4618 & answer_shape(3), &
4619
4620 & answer_shape(4), &
4621
4622 & answer_shape(5), &
4623
4624 & answer_shape(6), &
4625
4626 & answer_shape(7) ) &
4627 & )
4628
4629 allocate( judge( &
4630 & answer_shape(1), &
4631
4632 & answer_shape(2), &
4633
4634 & answer_shape(3), &
4635
4636 & answer_shape(4), &
4637
4638 & answer_shape(5), &
4639
4640 & answer_shape(6), &
4641
4642 & answer_shape(7) ) &
4643 & )
4644
4645 allocate( judge_rev( &
4646 & answer_shape(1), &
4647
4648 & answer_shape(2), &
4649
4650 & answer_shape(3), &
4651
4652 & answer_shape(4), &
4653
4654 & answer_shape(5), &
4655
4656 & answer_shape(6), &
4657
4658 & answer_shape(7) ) &
4659 & )
4660
4661
4662 judge = abs(answer - check) <= 0.0_dp
4663
4664
4665
4666
4667 judge_rev = .not. judge
4668 err_flag = any(judge_rev)
4669 mask_array = 1
4670 pos = maxloc(mask_array, judge_rev)
4671
4672 if (err_flag) then
4673
4674 wrong = check( &
4675 & pos(1), &
4676
4677 & pos(2), &
4678
4679 & pos(3), &
4680
4681 & pos(4), &
4682
4683 & pos(5), &
4684
4685 & pos(6), &
4686
4687 & pos(7) )
4688
4689 right = answer( &
4690 & pos(1), &
4691
4692 & pos(2), &
4693
4694 & pos(3), &
4695
4696 & pos(4), &
4697
4698 & pos(5), &
4699
4700 & pos(6), &
4701
4702 & pos(7) )
4703
4704 write(unit=pos_array(1), fmt="(i20)") pos(1)
4705
4706 write(unit=pos_array(2), fmt="(i20)") pos(2)
4707
4708 write(unit=pos_array(3), fmt="(i20)") pos(3)
4709
4710 write(unit=pos_array(4), fmt="(i20)") pos(4)
4711
4712 write(unit=pos_array(5), fmt="(i20)") pos(5)
4713
4714 write(unit=pos_array(6), fmt="(i20)") pos(6)
4715
4716 write(unit=pos_array(7), fmt="(i20)") pos(7)
4717
4718
4719 pos_str = '(' // &
4720 & trim(adjustl(pos_array(1))) // ',' // &
4721
4722 & trim(adjustl(pos_array(2))) // ',' // &
4723
4724 & trim(adjustl(pos_array(3))) // ',' // &
4725
4726 & trim(adjustl(pos_array(4))) // ',' // &
4727
4728 & trim(adjustl(pos_array(5))) // ',' // &
4729
4730 & trim(adjustl(pos_array(6))) // ',' // &
4731
4732 & trim(adjustl(pos_array(7))) // ')'
4733
4734 end if
4735 deallocate(mask_array, judge, judge_rev)
4736
4737
4738
4739
4740 if (err_flag) then
4741 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4742 write(*,*) ''
4743 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
4744 write(*,*) ' is NOT EQUAL to'
4745 write(*,*) ' answer' // trim(pos_str) // ' = ', right
4746
4747 call abortprogram('')
4748 else
4749 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
4750 end if
4751
4752
4753 end subroutine dctestassertequaldouble7
4754
4755 subroutine dctestassertequallogical0(message, answer, check)
4756 use dc_types, only: string
4757 implicit none
4758 character(*), intent(in):: message
4759 logical, intent(in):: answer
4760 logical, intent(in):: check
4761
4762 character(STRING):: answer_str
4763 character(STRING):: check_str
4764
4765
4766
4767 continue
4768
4769
4770 if (answer) then
4771 answer_str = ".true."
4772 else
4773 answer_str = ".false."
4774 end if
4775
4776 if (check) then
4777 check_str = ".true."
4778 else
4779 check_str = ".false."
4780 end if
4781
4782
4783
4784 call dctestassertequalchar0(message, answer_str, check_str)
4785
4786
4787
4788 end subroutine dctestassertequallogical0
4789 subroutine dctestassertequallogical1(message, answer, check)
4790 use dc_types, only: string
4791 implicit none
4792 character(*), intent(in):: message
4793 logical, intent(in):: answer(:)
4794 logical, intent(in):: check(:)
4795
4796 integer:: answer_shape(1), check_shape(1), i
4797 logical, allocatable:: answer_tmp(:), check_tmp(:)
4798 character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
4799 character(STRING), allocatable:: answer_str(:)
4800 character(STRING), allocatable:: check_str(:)
4801
4802
4803
4804 continue
4805
4806
4807 allocate(answer_tmp(size(answer)))
4808 allocate(check_tmp(size(check)))
4809 allocate(answer_str_tmp(size(answer)))
4810 allocate(check_str_tmp(size(check)))
4811 answer_tmp = pack(answer, .true.)
4812 check_tmp = pack(check, .true.)
4813
4814 do i = 1, size(answer_tmp)
4815 if (answer_tmp(i)) then
4816 answer_str_tmp(i) = '.true.'
4817 else
4818 answer_str_tmp(i) = '.false.'
4819 end if
4820 end do
4821
4822 do i = 1, size(check_tmp)
4823 if (check_tmp(i)) then
4824 check_str_tmp(i) = '.true.'
4825 else
4826 check_str_tmp(i) = '.false.'
4827 end if
4828 end do
4829
4830 answer_shape = shape(answer)
4831 check_shape = shape(check)
4832
4833 allocate( answer_str( &
4834
4835 & answer_shape(1) ) &
4836 & )
4837
4838 allocate( check_str( &
4839
4840 & check_shape(1) ) &
4841 & )
4842
4843 answer_str = reshape(answer_str_tmp, answer_shape)
4844 check_str = reshape(check_str_tmp, check_shape)
4845
4846
4847
4848 call dctestassertequalchar1(message, answer_str, check_str)
4849
4850 deallocate(answer_str, answer_tmp, answer_str_tmp)
4851 deallocate(check_str, check_tmp, check_str_tmp)
4852
4853
4854 end subroutine dctestassertequallogical1
4855 subroutine dctestassertequallogical2(message, answer, check)
4856 use dc_types, only: string
4857 implicit none
4858 character(*), intent(in):: message
4859 logical, intent(in):: answer(:,:)
4860 logical, intent(in):: check(:,:)
4861
4862 integer:: answer_shape(2), check_shape(2), i
4863 logical, allocatable:: answer_tmp(:), check_tmp(:)
4864 character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
4865 character(STRING), allocatable:: answer_str(:,:)
4866 character(STRING), allocatable:: check_str(:,:)
4867
4868
4869
4870 continue
4871
4872
4873 allocate(answer_tmp(size(answer)))
4874 allocate(check_tmp(size(check)))
4875 allocate(answer_str_tmp(size(answer)))
4876 allocate(check_str_tmp(size(check)))
4877 answer_tmp = pack(answer, .true.)
4878 check_tmp = pack(check, .true.)
4879
4880 do i = 1, size(answer_tmp)
4881 if (answer_tmp(i)) then
4882 answer_str_tmp(i) = '.true.'
4883 else
4884 answer_str_tmp(i) = '.false.'
4885 end if
4886 end do
4887
4888 do i = 1, size(check_tmp)
4889 if (check_tmp(i)) then
4890 check_str_tmp(i) = '.true.'
4891 else
4892 check_str_tmp(i) = '.false.'
4893 end if
4894 end do
4895
4896 answer_shape = shape(answer)
4897 check_shape = shape(check)
4898
4899 allocate( answer_str( &
4900 & answer_shape(1), &
4901
4902 & answer_shape(2) ) &
4903 & )
4904
4905 allocate( check_str( &
4906 & check_shape(1), &
4907
4908 & check_shape(2) ) &
4909 & )
4910
4911 answer_str = reshape(answer_str_tmp, answer_shape)
4912 check_str = reshape(check_str_tmp, check_shape)
4913
4914
4915
4916 call dctestassertequalchar2(message, answer_str, check_str)
4917
4918 deallocate(answer_str, answer_tmp, answer_str_tmp)
4919 deallocate(check_str, check_tmp, check_str_tmp)
4920
4921
4922 end subroutine dctestassertequallogical2
4923 subroutine dctestassertequallogical3(message, answer, check)
4924 use dc_types, only: string
4925 implicit none
4926 character(*), intent(in):: message
4927 logical, intent(in):: answer(:,:,:)
4928 logical, intent(in):: check(:,:,:)
4929
4930 integer:: answer_shape(3), check_shape(3), i
4931 logical, allocatable:: answer_tmp(:), check_tmp(:)
4932 character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
4933 character(STRING), allocatable:: answer_str(:,:,:)
4934 character(STRING), allocatable:: check_str(:,:,:)
4935
4936
4937
4938 continue
4939
4940
4941 allocate(answer_tmp(size(answer)))
4942 allocate(check_tmp(size(check)))
4943 allocate(answer_str_tmp(size(answer)))
4944 allocate(check_str_tmp(size(check)))
4945 answer_tmp = pack(answer, .true.)
4946 check_tmp = pack(check, .true.)
4947
4948 do i = 1, size(answer_tmp)
4949 if (answer_tmp(i)) then
4950 answer_str_tmp(i) = '.true.'
4951 else
4952 answer_str_tmp(i) = '.false.'
4953 end if
4954 end do
4955
4956 do i = 1, size(check_tmp)
4957 if (check_tmp(i)) then
4958 check_str_tmp(i) = '.true.'
4959 else
4960 check_str_tmp(i) = '.false.'
4961 end if
4962 end do
4963
4964 answer_shape = shape(answer)
4965 check_shape = shape(check)
4966
4967 allocate( answer_str( &
4968 & answer_shape(1), &
4969
4970 & answer_shape(2), &
4971
4972 & answer_shape(3) ) &
4973 & )
4974
4975 allocate( check_str( &
4976 & check_shape(1), &
4977
4978 & check_shape(2), &
4979
4980 & check_shape(3) ) &
4981 & )
4982
4983 answer_str = reshape(answer_str_tmp, answer_shape)
4984 check_str = reshape(check_str_tmp, check_shape)
4985
4986
4987
4988 call dctestassertequalchar3(message, answer_str, check_str)
4989
4990 deallocate(answer_str, answer_tmp, answer_str_tmp)
4991 deallocate(check_str, check_tmp, check_str_tmp)
4992
4993
4994 end subroutine dctestassertequallogical3
4995 subroutine dctestassertequallogical4(message, answer, check)
4996 use dc_types, only: string
4997 implicit none
4998 character(*), intent(in):: message
4999 logical, intent(in):: answer(:,:,:,:)
5000 logical, intent(in):: check(:,:,:,:)
5001
5002 integer:: answer_shape(4), check_shape(4), i
5003 logical, allocatable:: answer_tmp(:), check_tmp(:)
5004 character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
5005 character(STRING), allocatable:: answer_str(:,:,:,:)
5006 character(STRING), allocatable:: check_str(:,:,:,:)
5007
5008
5009
5010 continue
5011
5012
5013 allocate(answer_tmp(size(answer)))
5014 allocate(check_tmp(size(check)))
5015 allocate(answer_str_tmp(size(answer)))
5016 allocate(check_str_tmp(size(check)))
5017 answer_tmp = pack(answer, .true.)
5018 check_tmp = pack(check, .true.)
5019
5020 do i = 1, size(answer_tmp)
5021 if (answer_tmp(i)) then
5022 answer_str_tmp(i) = '.true.'
5023 else
5024 answer_str_tmp(i) = '.false.'
5025 end if
5026 end do
5027
5028 do i = 1, size(check_tmp)
5029 if (check_tmp(i)) then
5030 check_str_tmp(i) = '.true.'
5031 else
5032 check_str_tmp(i) = '.false.'
5033 end if
5034 end do
5035
5036 answer_shape = shape(answer)
5037 check_shape = shape(check)
5038
5039 allocate( answer_str( &
5040 & answer_shape(1), &
5041
5042 & answer_shape(2), &
5043
5044 & answer_shape(3), &
5045
5046 & answer_shape(4) ) &
5047 & )
5048
5049 allocate( check_str( &
5050 & check_shape(1), &
5051
5052 & check_shape(2), &
5053
5054 & check_shape(3), &
5055
5056 & check_shape(4) ) &
5057 & )
5058
5059 answer_str = reshape(answer_str_tmp, answer_shape)
5060 check_str = reshape(check_str_tmp, check_shape)
5061
5062
5063
5064 call dctestassertequalchar4(message, answer_str, check_str)
5065
5066 deallocate(answer_str, answer_tmp, answer_str_tmp)
5067 deallocate(check_str, check_tmp, check_str_tmp)
5068
5069
5070 end subroutine dctestassertequallogical4
5071 subroutine dctestassertequallogical5(message, answer, check)
5072 use dc_types, only: string
5073 implicit none
5074 character(*), intent(in):: message
5075 logical, intent(in):: answer(:,:,:,:,:)
5076 logical, intent(in):: check(:,:,:,:,:)
5077
5078 integer:: answer_shape(5), check_shape(5), i
5079 logical, allocatable:: answer_tmp(:), check_tmp(:)
5080 character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
5081 character(STRING), allocatable:: answer_str(:,:,:,:,:)
5082 character(STRING), allocatable:: check_str(:,:,:,:,:)
5083
5084
5085
5086 continue
5087
5088
5089 allocate(answer_tmp(size(answer)))
5090 allocate(check_tmp(size(check)))
5091 allocate(answer_str_tmp(size(answer)))
5092 allocate(check_str_tmp(size(check)))
5093 answer_tmp = pack(answer, .true.)
5094 check_tmp = pack(check, .true.)
5095
5096 do i = 1, size(answer_tmp)
5097 if (answer_tmp(i)) then
5098 answer_str_tmp(i) = '.true.'
5099 else
5100 answer_str_tmp(i) = '.false.'
5101 end if
5102 end do
5103
5104 do i = 1, size(check_tmp)
5105 if (check_tmp(i)) then
5106 check_str_tmp(i) = '.true.'
5107 else
5108 check_str_tmp(i) = '.false.'
5109 end if
5110 end do
5111
5112 answer_shape = shape(answer)
5113 check_shape = shape(check)
5114
5115 allocate( answer_str( &
5116 & answer_shape(1), &
5117
5118 & answer_shape(2), &
5119
5120 & answer_shape(3), &
5121
5122 & answer_shape(4), &
5123
5124 & answer_shape(5) ) &
5125 & )
5126
5127 allocate( check_str( &
5128 & check_shape(1), &
5129
5130 & check_shape(2), &
5131
5132 & check_shape(3), &
5133
5134 & check_shape(4), &
5135
5136 & check_shape(5) ) &
5137 & )
5138
5139 answer_str = reshape(answer_str_tmp, answer_shape)
5140 check_str = reshape(check_str_tmp, check_shape)
5141
5142
5143
5144 call dctestassertequalchar5(message, answer_str, check_str)
5145
5146 deallocate(answer_str, answer_tmp, answer_str_tmp)
5147 deallocate(check_str, check_tmp, check_str_tmp)
5148
5149
5150 end subroutine dctestassertequallogical5
5151 subroutine dctestassertequallogical6(message, answer, check)
5152 use dc_types, only: string
5153 implicit none
5154 character(*), intent(in):: message
5155 logical, intent(in):: answer(:,:,:,:,:,:)
5156 logical, intent(in):: check(:,:,:,:,:,:)
5157
5158 integer:: answer_shape(6), check_shape(6), i
5159 logical, allocatable:: answer_tmp(:), check_tmp(:)
5160 character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
5161 character(STRING), allocatable:: answer_str(:,:,:,:,:,:)
5162 character(STRING), allocatable:: check_str(:,:,:,:,:,:)
5163
5164
5165
5166 continue
5167
5168
5169 allocate(answer_tmp(size(answer)))
5170 allocate(check_tmp(size(check)))
5171 allocate(answer_str_tmp(size(answer)))
5172 allocate(check_str_tmp(size(check)))
5173 answer_tmp = pack(answer, .true.)
5174 check_tmp = pack(check, .true.)
5175
5176 do i = 1, size(answer_tmp)
5177 if (answer_tmp(i)) then
5178 answer_str_tmp(i) = '.true.'
5179 else
5180 answer_str_tmp(i) = '.false.'
5181 end if
5182 end do
5183
5184 do i = 1, size(check_tmp)
5185 if (check_tmp(i)) then
5186 check_str_tmp(i) = '.true.'
5187 else
5188 check_str_tmp(i) = '.false.'
5189 end if
5190 end do
5191
5192 answer_shape = shape(answer)
5193 check_shape = shape(check)
5194
5195 allocate( answer_str( &
5196 & answer_shape(1), &
5197
5198 & answer_shape(2), &
5199
5200 & answer_shape(3), &
5201
5202 & answer_shape(4), &
5203
5204 & answer_shape(5), &
5205
5206 & answer_shape(6) ) &
5207 & )
5208
5209 allocate( check_str( &
5210 & check_shape(1), &
5211
5212 & check_shape(2), &
5213
5214 & check_shape(3), &
5215
5216 & check_shape(4), &
5217
5218 & check_shape(5), &
5219
5220 & check_shape(6) ) &
5221 & )
5222
5223 answer_str = reshape(answer_str_tmp, answer_shape)
5224 check_str = reshape(check_str_tmp, check_shape)
5225
5226
5227
5228 call dctestassertequalchar6(message, answer_str, check_str)
5229
5230 deallocate(answer_str, answer_tmp, answer_str_tmp)
5231 deallocate(check_str, check_tmp, check_str_tmp)
5232
5233
5234 end subroutine dctestassertequallogical6
5235 subroutine dctestassertequallogical7(message, answer, check)
5236 use dc_types, only: string
5237 implicit none
5238 character(*), intent(in):: message
5239 logical, intent(in):: answer(:,:,:,:,:,:,:)
5240 logical, intent(in):: check(:,:,:,:,:,:,:)
5241
5242 integer:: answer_shape(7), check_shape(7), i
5243 logical, allocatable:: answer_tmp(:), check_tmp(:)
5244 character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
5245 character(STRING), allocatable:: answer_str(:,:,:,:,:,:,:)
5246 character(STRING), allocatable:: check_str(:,:,:,:,:,:,:)
5247
5248
5249
5250 continue
5251
5252
5253 allocate(answer_tmp(size(answer)))
5254 allocate(check_tmp(size(check)))
5255 allocate(answer_str_tmp(size(answer)))
5256 allocate(check_str_tmp(size(check)))
5257 answer_tmp = pack(answer, .true.)
5258 check_tmp = pack(check, .true.)
5259
5260 do i = 1, size(answer_tmp)
5261 if (answer_tmp(i)) then
5262 answer_str_tmp(i) = '.true.'
5263 else
5264 answer_str_tmp(i) = '.false.'
5265 end if
5266 end do
5267
5268 do i = 1, size(check_tmp)
5269 if (check_tmp(i)) then
5270 check_str_tmp(i) = '.true.'
5271 else
5272 check_str_tmp(i) = '.false.'
5273 end if
5274 end do
5275
5276 answer_shape = shape(answer)
5277 check_shape = shape(check)
5278
5279 allocate( answer_str( &
5280 & answer_shape(1), &
5281
5282 & answer_shape(2), &
5283
5284 & answer_shape(3), &
5285
5286 & answer_shape(4), &
5287
5288 & answer_shape(5), &
5289
5290 & answer_shape(6), &
5291
5292 & answer_shape(7) ) &
5293 & )
5294
5295 allocate( check_str( &
5296 & check_shape(1), &
5297
5298 & check_shape(2), &
5299
5300 & check_shape(3), &
5301
5302 & check_shape(4), &
5303
5304 & check_shape(5), &
5305
5306 & check_shape(6), &
5307
5308 & check_shape(7) ) &
5309 & )
5310
5311 answer_str = reshape(answer_str_tmp, answer_shape)
5312 check_str = reshape(check_str_tmp, check_shape)
5313
5314
5315
5316 call dctestassertequalchar7(message, answer_str, check_str)
5317
5318 deallocate(answer_str, answer_tmp, answer_str_tmp)
5319 deallocate(check_str, check_tmp, check_str_tmp)
5320
5321
5322 end subroutine dctestassertequallogical7
5323
5324 subroutine dctestassertequalreal0digits( &
5325 & message, answer, check, significant_digits, ignore_digits )
5326 use sysdep, only: abortprogram
5327 use dc_types, only: string
5328 implicit none
5329 character(*), intent(in):: message
5330 real, intent(in):: answer
5331 real, intent(in):: check
5332 integer, intent(in):: significant_digits
5333 integer, intent(in):: ignore_digits
5334 logical:: err_flag
5335 character(STRING):: pos_str
5336 real:: wrong, right_max, right_min
5337 character(STRING):: pos_str_space
5338 integer:: pos_str_len
5339 real:: right_tmp
5340
5341 real:: answer_max
5342 real:: answer_min
5343
5344 continue
5345 err_flag = .false.
5346
5347 if ( significant_digits < 1 ) then
5348 write(*,*) ' *** Error [AssertEQ] *** '
5349 write(*,*) ' Specify a number more than 1 to "significant_digits"'
5350 call abortprogram('')
5351 end if
5352
5353 if ( answer < 0.0 .and. check < 0.0 ) then
5354 answer_max = &
5355 & answer &
5356 & * ( 1.0 &
5357 & - 0.1 ** significant_digits ) &
5358 & + 0.1 ** (- ignore_digits)
5359
5360 answer_min = &
5361 & answer &
5362 & * ( 1.0 &
5363 & + 0.1 ** significant_digits ) &
5364 & - 0.1 ** (- ignore_digits)
5365 else
5366
5367 answer_max = &
5368 & answer &
5369 & * ( 1.0 &
5370 & + 0.1 ** significant_digits ) &
5371 & + 0.1 ** (- ignore_digits)
5372
5373 answer_min = &
5374 & answer &
5375 & * ( 1.0 &
5376 & - 0.1 ** significant_digits ) &
5377 & - 0.1 ** (- ignore_digits)
5378 end if
5379
5380 wrong = check
5381 right_max = answer_max
5382 right_min = answer_min
5383 if ( right_max < right_min ) then
5384 right_tmp = right_max
5385 right_max = right_min
5386 right_min = right_tmp
5387 end if
5388
5389 err_flag = .not. (answer_max > check .and. check > answer_min)
5390
5391 pos_str = ''
5392
5393
5394
5395 if (err_flag) then
5396 pos_str_space = ''
5397 pos_str_len = len_trim(pos_str)
5398
5399 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5400 write(*,*) ''
5401 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
5402 write(*,*) ' is NOT EQUAL to'
5403 write(*,*) ' ' // pos_str_space(1:pos_str_len) &
5404 & // ' ', right_min, ' < '
5405 write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
5406
5407 call abortprogram('')
5408 else
5409 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
5410 end if
5411
5412
5413 end subroutine dctestassertequalreal0digits
5414
5415
5416 subroutine dctestassertequalreal1digits( &
5417 & message, answer, check, significant_digits, ignore_digits )
5418 use sysdep, only: abortprogram
5419 use dc_types, only: string, token
5420 implicit none
5421 character(*), intent(in):: message
5422 real, intent(in):: answer(:)
5423 real, intent(in):: check(:)
5424 integer, intent(in):: significant_digits
5425 integer, intent(in):: ignore_digits
5426 logical:: err_flag
5427 character(STRING):: pos_str
5428 real:: wrong, right_max, right_min
5429 character(STRING):: pos_str_space
5430 integer:: pos_str_len
5431 real:: right_tmp
5432
5433 integer:: answer_shape(1), check_shape(1), pos(1)
5434 logical:: consist_shape(1)
5435 character(TOKEN):: pos_array(1)
5436 integer, allocatable:: mask_array(:)
5437 logical, allocatable:: judge(:)
5438 logical, allocatable:: judge_rev(:)
5439 logical, allocatable:: answer_negative(:)
5440 logical, allocatable:: check_negative(:)
5441 logical, allocatable:: both_negative(:)
5442 real, allocatable:: answer_max(:)
5443 real, allocatable:: answer_min(:)
5444
5445 continue
5446 err_flag = .false.
5447
5448 if ( significant_digits < 1 ) then
5449 write(*,*) ' *** Error [AssertEQ] *** '
5450 write(*,*) ' Specify a number more than 1 to "significant_digits"'
5451 call abortprogram('')
5452 end if
5453
5454 answer_shape = shape(answer)
5455 check_shape = shape(check)
5456
5457 consist_shape = answer_shape == check_shape
5458
5459 if (.not. all(consist_shape)) then
5460 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5461 write(*,*) ''
5462 write(*,*) ' shape of check is (', check_shape, ')'
5463 write(*,*) ' is INCORRECT'
5464 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
5465
5466 call abortprogram('')
5467 end if
5468
5469
5470 allocate( mask_array( &
5471
5472 & answer_shape(1) ) &
5473 & )
5474
5475 allocate( judge( &
5476
5477 & answer_shape(1) ) &
5478 & )
5479
5480 allocate( judge_rev( &
5481
5482 & answer_shape(1) ) &
5483 & )
5484
5485 allocate( answer_negative( &
5486
5487 & answer_shape(1) ) &
5488 & )
5489
5490 allocate( check_negative( &
5491
5492 & answer_shape(1) ) &
5493 & )
5494
5495 allocate( both_negative( &
5496
5497 & answer_shape(1) ) &
5498 & )
5499
5500 allocate( answer_max( &
5501
5502 & answer_shape(1) ) &
5503 & )
5504
5505 allocate( answer_min( &
5506
5507 & answer_shape(1) ) &
5508 & )
5509
5510 answer_negative = answer < 0.0
5511 check_negative = check < 0.0
5512 both_negative = answer_negative .and. check_negative
5513
5514 where (both_negative)
5515 answer_max = &
5516 & answer &
5517 & * ( 1.0 &
5518 & - 0.1 ** significant_digits ) &
5519 & + 0.1 ** (- ignore_digits)
5520
5521 answer_min = &
5522 & answer &
5523 & * ( 1.0 &
5524 & + 0.1 ** significant_digits ) &
5525 & - 0.1 ** (- ignore_digits)
5526 elsewhere
5527 answer_max = &
5528 & answer &
5529 & * ( 1.0 &
5530 & + 0.1 ** significant_digits ) &
5531 & + 0.1 ** (- ignore_digits)
5532
5533 answer_min = &
5534 & answer &
5535 & * ( 1.0 &
5536 & - 0.1 ** significant_digits ) &
5537 & - 0.1 ** (- ignore_digits)
5538 end where
5539
5540 judge = answer_max > check .and. check > answer_min
5541 judge_rev = .not. judge
5542 err_flag = any(judge_rev)
5543 mask_array = 1
5544 pos = maxloc(mask_array, judge_rev)
5545
5546 if (err_flag) then
5547
5548 wrong = check( &
5549
5550 & pos(1) )
5551
5552 right_max = answer_max( &
5553
5554 & pos(1) )
5555
5556 right_min = answer_min( &
5557
5558 & pos(1) )
5559
5560 if ( right_max < right_min ) then
5561 right_tmp = right_max
5562 right_max = right_min
5563 right_min = right_tmp
5564 end if
5565
5566 write(unit=pos_array(1), fmt="(i20)") pos(1)
5567
5568
5569 pos_str = '(' // &
5570
5571 & trim(adjustl(pos_array(1))) // ')'
5572
5573 end if
5574 deallocate(mask_array, judge, judge_rev)
5575 deallocate(answer_negative, check_negative, both_negative)
5576 deallocate(answer_max, answer_min)
5577
5578
5579
5580 if (err_flag) then
5581 pos_str_space = ''
5582 pos_str_len = len_trim(pos_str)
5583
5584 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5585 write(*,*) ''
5586 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
5587 write(*,*) ' is NOT EQUAL to'
5588 write(*,*) ' ' // pos_str_space(1:pos_str_len) &
5589 & // ' ', right_min, ' < '
5590 write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
5591
5592 call abortprogram('')
5593 else
5594 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
5595 end if
5596
5597
5598 end subroutine dctestassertequalreal1digits
5599
5600
5601 subroutine dctestassertequalreal2digits( &
5602 & message, answer, check, significant_digits, ignore_digits )
5603 use sysdep, only: abortprogram
5604 use dc_types, only: string, token
5605 implicit none
5606 character(*), intent(in):: message
5607 real, intent(in):: answer(:,:)
5608 real, intent(in):: check(:,:)
5609 integer, intent(in):: significant_digits
5610 integer, intent(in):: ignore_digits
5611 logical:: err_flag
5612 character(STRING):: pos_str
5613 real:: wrong, right_max, right_min
5614 character(STRING):: pos_str_space
5615 integer:: pos_str_len
5616 real:: right_tmp
5617
5618 integer:: answer_shape(2), check_shape(2), pos(2)
5619 logical:: consist_shape(2)
5620 character(TOKEN):: pos_array(2)
5621 integer, allocatable:: mask_array(:,:)
5622 logical, allocatable:: judge(:,:)
5623 logical, allocatable:: judge_rev(:,:)
5624 logical, allocatable:: answer_negative(:,:)
5625 logical, allocatable:: check_negative(:,:)
5626 logical, allocatable:: both_negative(:,:)
5627 real, allocatable:: answer_max(:,:)
5628 real, allocatable:: answer_min(:,:)
5629
5630 continue
5631 err_flag = .false.
5632
5633 if ( significant_digits < 1 ) then
5634 write(*,*) ' *** Error [AssertEQ] *** '
5635 write(*,*) ' Specify a number more than 1 to "significant_digits"'
5636 call abortprogram('')
5637 end if
5638
5639 answer_shape = shape(answer)
5640 check_shape = shape(check)
5641
5642 consist_shape = answer_shape == check_shape
5643
5644 if (.not. all(consist_shape)) then
5645 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5646 write(*,*) ''
5647 write(*,*) ' shape of check is (', check_shape, ')'
5648 write(*,*) ' is INCORRECT'
5649 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
5650
5651 call abortprogram('')
5652 end if
5653
5654
5655 allocate( mask_array( &
5656 & answer_shape(1), &
5657
5658 & answer_shape(2) ) &
5659 & )
5660
5661 allocate( judge( &
5662 & answer_shape(1), &
5663
5664 & answer_shape(2) ) &
5665 & )
5666
5667 allocate( judge_rev( &
5668 & answer_shape(1), &
5669
5670 & answer_shape(2) ) &
5671 & )
5672
5673 allocate( answer_negative( &
5674 & answer_shape(1), &
5675
5676 & answer_shape(2) ) &
5677 & )
5678
5679 allocate( check_negative( &
5680 & answer_shape(1), &
5681
5682 & answer_shape(2) ) &
5683 & )
5684
5685 allocate( both_negative( &
5686 & answer_shape(1), &
5687
5688 & answer_shape(2) ) &
5689 & )
5690
5691 allocate( answer_max( &
5692 & answer_shape(1), &
5693
5694 & answer_shape(2) ) &
5695 & )
5696
5697 allocate( answer_min( &
5698 & answer_shape(1), &
5699
5700 & answer_shape(2) ) &
5701 & )
5702
5703 answer_negative = answer < 0.0
5704 check_negative = check < 0.0
5705 both_negative = answer_negative .and. check_negative
5706
5707 where (both_negative)
5708 answer_max = &
5709 & answer &
5710 & * ( 1.0 &
5711 & - 0.1 ** significant_digits ) &
5712 & + 0.1 ** (- ignore_digits)
5713
5714 answer_min = &
5715 & answer &
5716 & * ( 1.0 &
5717 & + 0.1 ** significant_digits ) &
5718 & - 0.1 ** (- ignore_digits)
5719 elsewhere
5720 answer_max = &
5721 & answer &
5722 & * ( 1.0 &
5723 & + 0.1 ** significant_digits ) &
5724 & + 0.1 ** (- ignore_digits)
5725
5726 answer_min = &
5727 & answer &
5728 & * ( 1.0 &
5729 & - 0.1 ** significant_digits ) &
5730 & - 0.1 ** (- ignore_digits)
5731 end where
5732
5733 judge = answer_max > check .and. check > answer_min
5734 judge_rev = .not. judge
5735 err_flag = any(judge_rev)
5736 mask_array = 1
5737 pos = maxloc(mask_array, judge_rev)
5738
5739 if (err_flag) then
5740
5741 wrong = check( &
5742 & pos(1), &
5743
5744 & pos(2) )
5745
5746 right_max = answer_max( &
5747 & pos(1), &
5748
5749 & pos(2) )
5750
5751 right_min = answer_min( &
5752 & pos(1), &
5753
5754 & pos(2) )
5755
5756 if ( right_max < right_min ) then
5757 right_tmp = right_max
5758 right_max = right_min
5759 right_min = right_tmp
5760 end if
5761
5762 write(unit=pos_array(1), fmt="(i20)") pos(1)
5763
5764 write(unit=pos_array(2), fmt="(i20)") pos(2)
5765
5766
5767 pos_str = '(' // &
5768 & trim(adjustl(pos_array(1))) // ',' // &
5769
5770 & trim(adjustl(pos_array(2))) // ')'
5771
5772 end if
5773 deallocate(mask_array, judge, judge_rev)
5774 deallocate(answer_negative, check_negative, both_negative)
5775 deallocate(answer_max, answer_min)
5776
5777
5778
5779 if (err_flag) then
5780 pos_str_space = ''
5781 pos_str_len = len_trim(pos_str)
5782
5783 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5784 write(*,*) ''
5785 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
5786 write(*,*) ' is NOT EQUAL to'
5787 write(*,*) ' ' // pos_str_space(1:pos_str_len) &
5788 & // ' ', right_min, ' < '
5789 write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
5790
5791 call abortprogram('')
5792 else
5793 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
5794 end if
5795
5796
5797 end subroutine dctestassertequalreal2digits
5798
5799
5800 subroutine dctestassertequalreal3digits( &
5801 & message, answer, check, significant_digits, ignore_digits )
5802 use sysdep, only: abortprogram
5803 use dc_types, only: string, token
5804 implicit none
5805 character(*), intent(in):: message
5806 real, intent(in):: answer(:,:,:)
5807 real, intent(in):: check(:,:,:)
5808 integer, intent(in):: significant_digits
5809 integer, intent(in):: ignore_digits
5810 logical:: err_flag
5811 character(STRING):: pos_str
5812 real:: wrong, right_max, right_min
5813 character(STRING):: pos_str_space
5814 integer:: pos_str_len
5815 real:: right_tmp
5816
5817 integer:: answer_shape(3), check_shape(3), pos(3)
5818 logical:: consist_shape(3)
5819 character(TOKEN):: pos_array(3)
5820 integer, allocatable:: mask_array(:,:,:)
5821 logical, allocatable:: judge(:,:,:)
5822 logical, allocatable:: judge_rev(:,:,:)
5823 logical, allocatable:: answer_negative(:,:,:)
5824 logical, allocatable:: check_negative(:,:,:)
5825 logical, allocatable:: both_negative(:,:,:)
5826 real, allocatable:: answer_max(:,:,:)
5827 real, allocatable:: answer_min(:,:,:)
5828
5829 continue
5830 err_flag = .false.
5831
5832 if ( significant_digits < 1 ) then
5833 write(*,*) ' *** Error [AssertEQ] *** '
5834 write(*,*) ' Specify a number more than 1 to "significant_digits"'
5835 call abortprogram('')
5836 end if
5837
5838 answer_shape = shape(answer)
5839 check_shape = shape(check)
5840
5841 consist_shape = answer_shape == check_shape
5842
5843 if (.not. all(consist_shape)) then
5844 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5845 write(*,*) ''
5846 write(*,*) ' shape of check is (', check_shape, ')'
5847 write(*,*) ' is INCORRECT'
5848 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
5849
5850 call abortprogram('')
5851 end if
5852
5853
5854 allocate( mask_array( &
5855 & answer_shape(1), &
5856
5857 & answer_shape(2), &
5858
5859 & answer_shape(3) ) &
5860 & )
5861
5862 allocate( judge( &
5863 & answer_shape(1), &
5864
5865 & answer_shape(2), &
5866
5867 & answer_shape(3) ) &
5868 & )
5869
5870 allocate( judge_rev( &
5871 & answer_shape(1), &
5872
5873 & answer_shape(2), &
5874
5875 & answer_shape(3) ) &
5876 & )
5877
5878 allocate( answer_negative( &
5879 & answer_shape(1), &
5880
5881 & answer_shape(2), &
5882
5883 & answer_shape(3) ) &
5884 & )
5885
5886 allocate( check_negative( &
5887 & answer_shape(1), &
5888
5889 & answer_shape(2), &
5890
5891 & answer_shape(3) ) &
5892 & )
5893
5894 allocate( both_negative( &
5895 & answer_shape(1), &
5896
5897 & answer_shape(2), &
5898
5899 & answer_shape(3) ) &
5900 & )
5901
5902 allocate( answer_max( &
5903 & answer_shape(1), &
5904
5905 & answer_shape(2), &
5906
5907 & answer_shape(3) ) &
5908 & )
5909
5910 allocate( answer_min( &
5911 & answer_shape(1), &
5912
5913 & answer_shape(2), &
5914
5915 & answer_shape(3) ) &
5916 & )
5917
5918 answer_negative = answer < 0.0
5919 check_negative = check < 0.0
5920 both_negative = answer_negative .and. check_negative
5921
5922 where (both_negative)
5923 answer_max = &
5924 & answer &
5925 & * ( 1.0 &
5926 & - 0.1 ** significant_digits ) &
5927 & + 0.1 ** (- ignore_digits)
5928
5929 answer_min = &
5930 & answer &
5931 & * ( 1.0 &
5932 & + 0.1 ** significant_digits ) &
5933 & - 0.1 ** (- ignore_digits)
5934 elsewhere
5935 answer_max = &
5936 & answer &
5937 & * ( 1.0 &
5938 & + 0.1 ** significant_digits ) &
5939 & + 0.1 ** (- ignore_digits)
5940
5941 answer_min = &
5942 & answer &
5943 & * ( 1.0 &
5944 & - 0.1 ** significant_digits ) &
5945 & - 0.1 ** (- ignore_digits)
5946 end where
5947
5948 judge = answer_max > check .and. check > answer_min
5949 judge_rev = .not. judge
5950 err_flag = any(judge_rev)
5951 mask_array = 1
5952 pos = maxloc(mask_array, judge_rev)
5953
5954 if (err_flag) then
5955
5956 wrong = check( &
5957 & pos(1), &
5958
5959 & pos(2), &
5960
5961 & pos(3) )
5962
5963 right_max = answer_max( &
5964 & pos(1), &
5965
5966 & pos(2), &
5967
5968 & pos(3) )
5969
5970 right_min = answer_min( &
5971 & pos(1), &
5972
5973 & pos(2), &
5974
5975 & pos(3) )
5976
5977 if ( right_max < right_min ) then
5978 right_tmp = right_max
5979 right_max = right_min
5980 right_min = right_tmp
5981 end if
5982
5983 write(unit=pos_array(1), fmt="(i20)") pos(1)
5984
5985 write(unit=pos_array(2), fmt="(i20)") pos(2)
5986
5987 write(unit=pos_array(3), fmt="(i20)") pos(3)
5988
5989
5990 pos_str = '(' // &
5991 & trim(adjustl(pos_array(1))) // ',' // &
5992
5993 & trim(adjustl(pos_array(2))) // ',' // &
5994
5995 & trim(adjustl(pos_array(3))) // ')'
5996
5997 end if
5998 deallocate(mask_array, judge, judge_rev)
5999 deallocate(answer_negative, check_negative, both_negative)
6000 deallocate(answer_max, answer_min)
6001
6002
6003
6004 if (err_flag) then
6005 pos_str_space = ''
6006 pos_str_len = len_trim(pos_str)
6007
6008 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6009 write(*,*) ''
6010 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
6011 write(*,*) ' is NOT EQUAL to'
6012 write(*,*) ' ' // pos_str_space(1:pos_str_len) &
6013 & // ' ', right_min, ' < '
6014 write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
6015
6016 call abortprogram('')
6017 else
6018 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
6019 end if
6020
6021
6022 end subroutine dctestassertequalreal3digits
6023
6024
6025 subroutine dctestassertequalreal4digits( &
6026 & message, answer, check, significant_digits, ignore_digits )
6027 use sysdep, only: abortprogram
6028 use dc_types, only: string, token
6029 implicit none
6030 character(*), intent(in):: message
6031 real, intent(in):: answer(:,:,:,:)
6032 real, intent(in):: check(:,:,:,:)
6033 integer, intent(in):: significant_digits
6034 integer, intent(in):: ignore_digits
6035 logical:: err_flag
6036 character(STRING):: pos_str
6037 real:: wrong, right_max, right_min
6038 character(STRING):: pos_str_space
6039 integer:: pos_str_len
6040 real:: right_tmp
6041
6042 integer:: answer_shape(4), check_shape(4), pos(4)
6043 logical:: consist_shape(4)
6044 character(TOKEN):: pos_array(4)
6045 integer, allocatable:: mask_array(:,:,:,:)
6046 logical, allocatable:: judge(:,:,:,:)
6047 logical, allocatable:: judge_rev(:,:,:,:)
6048 logical, allocatable:: answer_negative(:,:,:,:)
6049 logical, allocatable:: check_negative(:,:,:,:)
6050 logical, allocatable:: both_negative(:,:,:,:)
6051 real, allocatable:: answer_max(:,:,:,:)
6052 real, allocatable:: answer_min(:,:,:,:)
6053
6054 continue
6055 err_flag = .false.
6056
6057 if ( significant_digits < 1 ) then
6058 write(*,*) ' *** Error [AssertEQ] *** '
6059 write(*,*) ' Specify a number more than 1 to "significant_digits"'
6060 call abortprogram('')
6061 end if
6062
6063 answer_shape = shape(answer)
6064 check_shape = shape(check)
6065
6066 consist_shape = answer_shape == check_shape
6067
6068 if (.not. all(consist_shape)) then
6069 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6070 write(*,*) ''
6071 write(*,*) ' shape of check is (', check_shape, ')'
6072 write(*,*) ' is INCORRECT'
6073 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
6074
6075 call abortprogram('')
6076 end if
6077
6078
6079 allocate( mask_array( &
6080 & answer_shape(1), &
6081
6082 & answer_shape(2), &
6083
6084 & answer_shape(3), &
6085
6086 & answer_shape(4) ) &
6087 & )
6088
6089 allocate( judge( &
6090 & answer_shape(1), &
6091
6092 & answer_shape(2), &
6093
6094 & answer_shape(3), &
6095
6096 & answer_shape(4) ) &
6097 & )
6098
6099 allocate( judge_rev( &
6100 & answer_shape(1), &
6101
6102 & answer_shape(2), &
6103
6104 & answer_shape(3), &
6105
6106 & answer_shape(4) ) &
6107 & )
6108
6109 allocate( answer_negative( &
6110 & answer_shape(1), &
6111
6112 & answer_shape(2), &
6113
6114 & answer_shape(3), &
6115
6116 & answer_shape(4) ) &
6117 & )
6118
6119 allocate( check_negative( &
6120 & answer_shape(1), &
6121
6122 & answer_shape(2), &
6123
6124 & answer_shape(3), &
6125
6126 & answer_shape(4) ) &
6127 & )
6128
6129 allocate( both_negative( &
6130 & answer_shape(1), &
6131
6132 & answer_shape(2), &
6133
6134 & answer_shape(3), &
6135
6136 & answer_shape(4) ) &
6137 & )
6138
6139 allocate( answer_max( &
6140 & answer_shape(1), &
6141
6142 & answer_shape(2), &
6143
6144 & answer_shape(3), &
6145
6146 & answer_shape(4) ) &
6147 & )
6148
6149 allocate( answer_min( &
6150 & answer_shape(1), &
6151
6152 & answer_shape(2), &
6153
6154 & answer_shape(3), &
6155
6156 & answer_shape(4) ) &
6157 & )
6158
6159 answer_negative = answer < 0.0
6160 check_negative = check < 0.0
6161 both_negative = answer_negative .and. check_negative
6162
6163 where (both_negative)
6164 answer_max = &
6165 & answer &
6166 & * ( 1.0 &
6167 & - 0.1 ** significant_digits ) &
6168 & + 0.1 ** (- ignore_digits)
6169
6170 answer_min = &
6171 & answer &
6172 & * ( 1.0 &
6173 & + 0.1 ** significant_digits ) &
6174 & - 0.1 ** (- ignore_digits)
6175 elsewhere
6176 answer_max = &
6177 & answer &
6178 & * ( 1.0 &
6179 & + 0.1 ** significant_digits ) &
6180 & + 0.1 ** (- ignore_digits)
6181
6182 answer_min = &
6183 & answer &
6184 & * ( 1.0 &
6185 & - 0.1 ** significant_digits ) &
6186 & - 0.1 ** (- ignore_digits)
6187 end where
6188
6189 judge = answer_max > check .and. check > answer_min
6190 judge_rev = .not. judge
6191 err_flag = any(judge_rev)
6192 mask_array = 1
6193 pos = maxloc(mask_array, judge_rev)
6194
6195 if (err_flag) then
6196
6197 wrong = check( &
6198 & pos(1), &
6199
6200 & pos(2), &
6201
6202 & pos(3), &
6203
6204 & pos(4) )
6205
6206 right_max = answer_max( &
6207 & pos(1), &
6208
6209 & pos(2), &
6210
6211 & pos(3), &
6212
6213 & pos(4) )
6214
6215 right_min = answer_min( &
6216 & pos(1), &
6217
6218 & pos(2), &
6219
6220 & pos(3), &
6221
6222 & pos(4) )
6223
6224 if ( right_max < right_min ) then
6225 right_tmp = right_max
6226 right_max = right_min
6227 right_min = right_tmp
6228 end if
6229
6230 write(unit=pos_array(1), fmt="(i20)") pos(1)
6231
6232 write(unit=pos_array(2), fmt="(i20)") pos(2)
6233
6234 write(unit=pos_array(3), fmt="(i20)") pos(3)
6235
6236 write(unit=pos_array(4), fmt="(i20)") pos(4)
6237
6238
6239 pos_str = '(' // &
6240 & trim(adjustl(pos_array(1))) // ',' // &
6241
6242 & trim(adjustl(pos_array(2))) // ',' // &
6243
6244 & trim(adjustl(pos_array(3))) // ',' // &
6245
6246 & trim(adjustl(pos_array(4))) // ')'
6247
6248 end if
6249 deallocate(mask_array, judge, judge_rev)
6250 deallocate(answer_negative, check_negative, both_negative)
6251 deallocate(answer_max, answer_min)
6252
6253
6254
6255 if (err_flag) then
6256 pos_str_space = ''
6257 pos_str_len = len_trim(pos_str)
6258
6259 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6260 write(*,*) ''
6261 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
6262 write(*,*) ' is NOT EQUAL to'
6263 write(*,*) ' ' // pos_str_space(1:pos_str_len) &
6264 & // ' ', right_min, ' < '
6265 write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
6266
6267 call abortprogram('')
6268 else
6269 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
6270 end if
6271
6272
6273 end subroutine dctestassertequalreal4digits
6274
6275
6276 subroutine dctestassertequalreal5digits( &
6277 & message, answer, check, significant_digits, ignore_digits )
6278 use sysdep, only: abortprogram
6279 use dc_types, only: string, token
6280 implicit none
6281 character(*), intent(in):: message
6282 real, intent(in):: answer(:,:,:,:,:)
6283 real, intent(in):: check(:,:,:,:,:)
6284 integer, intent(in):: significant_digits
6285 integer, intent(in):: ignore_digits
6286 logical:: err_flag
6287 character(STRING):: pos_str
6288 real:: wrong, right_max, right_min
6289 character(STRING):: pos_str_space
6290 integer:: pos_str_len
6291 real:: right_tmp
6292
6293 integer:: answer_shape(5), check_shape(5), pos(5)
6294 logical:: consist_shape(5)
6295 character(TOKEN):: pos_array(5)
6296 integer, allocatable:: mask_array(:,:,:,:,:)
6297 logical, allocatable:: judge(:,:,:,:,:)
6298 logical, allocatable:: judge_rev(:,:,:,:,:)
6299 logical, allocatable:: answer_negative(:,:,:,:,:)
6300 logical, allocatable:: check_negative(:,:,:,:,:)
6301 logical, allocatable:: both_negative(:,:,:,:,:)
6302 real, allocatable:: answer_max(:,:,:,:,:)
6303 real, allocatable:: answer_min(:,:,:,:,:)
6304
6305 continue
6306 err_flag = .false.
6307
6308 if ( significant_digits < 1 ) then
6309 write(*,*) ' *** Error [AssertEQ] *** '
6310 write(*,*) ' Specify a number more than 1 to "significant_digits"'
6311 call abortprogram('')
6312 end if
6313
6314 answer_shape = shape(answer)
6315 check_shape = shape(check)
6316
6317 consist_shape = answer_shape == check_shape
6318
6319 if (.not. all(consist_shape)) then
6320 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6321 write(*,*) ''
6322 write(*,*) ' shape of check is (', check_shape, ')'
6323 write(*,*) ' is INCORRECT'
6324 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
6325
6326 call abortprogram('')
6327 end if
6328
6329
6330 allocate( mask_array( &
6331 & answer_shape(1), &
6332
6333 & answer_shape(2), &
6334
6335 & answer_shape(3), &
6336
6337 & answer_shape(4), &
6338
6339 & answer_shape(5) ) &
6340 & )
6341
6342 allocate( judge( &
6343 & answer_shape(1), &
6344
6345 & answer_shape(2), &
6346
6347 & answer_shape(3), &
6348
6349 & answer_shape(4), &
6350
6351 & answer_shape(5) ) &
6352 & )
6353
6354 allocate( judge_rev( &
6355 & answer_shape(1), &
6356
6357 & answer_shape(2), &
6358
6359 & answer_shape(3), &
6360
6361 & answer_shape(4), &
6362
6363 & answer_shape(5) ) &
6364 & )
6365
6366 allocate( answer_negative( &
6367 & answer_shape(1), &
6368
6369 & answer_shape(2), &
6370
6371 & answer_shape(3), &
6372
6373 & answer_shape(4), &
6374
6375 & answer_shape(5) ) &
6376 & )
6377
6378 allocate( check_negative( &
6379 & answer_shape(1), &
6380
6381 & answer_shape(2), &
6382
6383 & answer_shape(3), &
6384
6385 & answer_shape(4), &
6386
6387 & answer_shape(5) ) &
6388 & )
6389
6390 allocate( both_negative( &
6391 & answer_shape(1), &
6392
6393 & answer_shape(2), &
6394
6395 & answer_shape(3), &
6396
6397 & answer_shape(4), &
6398
6399 & answer_shape(5) ) &
6400 & )
6401
6402 allocate( answer_max( &
6403 & answer_shape(1), &
6404
6405 & answer_shape(2), &
6406
6407 & answer_shape(3), &
6408
6409 & answer_shape(4), &
6410
6411 & answer_shape(5) ) &
6412 & )
6413
6414 allocate( answer_min( &
6415 & answer_shape(1), &
6416
6417 & answer_shape(2), &
6418
6419 & answer_shape(3), &
6420
6421 & answer_shape(4), &
6422
6423 & answer_shape(5) ) &
6424 & )
6425
6426 answer_negative = answer < 0.0
6427 check_negative = check < 0.0
6428 both_negative = answer_negative .and. check_negative
6429
6430 where (both_negative)
6431 answer_max = &
6432 & answer &
6433 & * ( 1.0 &
6434 & - 0.1 ** significant_digits ) &
6435 & + 0.1 ** (- ignore_digits)
6436
6437 answer_min = &
6438 & answer &
6439 & * ( 1.0 &
6440 & + 0.1 ** significant_digits ) &
6441 & - 0.1 ** (- ignore_digits)
6442 elsewhere
6443 answer_max = &
6444 & answer &
6445 & * ( 1.0 &
6446 & + 0.1 ** significant_digits ) &
6447 & + 0.1 ** (- ignore_digits)
6448
6449 answer_min = &
6450 & answer &
6451 & * ( 1.0 &
6452 & - 0.1 ** significant_digits ) &
6453 & - 0.1 ** (- ignore_digits)
6454 end where
6455
6456 judge = answer_max > check .and. check > answer_min
6457 judge_rev = .not. judge
6458 err_flag = any(judge_rev)
6459 mask_array = 1
6460 pos = maxloc(mask_array, judge_rev)
6461
6462 if (err_flag) then
6463
6464 wrong = check( &
6465 & pos(1), &
6466
6467 & pos(2), &
6468
6469 & pos(3), &
6470
6471 & pos(4), &
6472
6473 & pos(5) )
6474
6475 right_max = answer_max( &
6476 & pos(1), &
6477
6478 & pos(2), &
6479
6480 & pos(3), &
6481
6482 & pos(4), &
6483
6484 & pos(5) )
6485
6486 right_min = answer_min( &
6487 & pos(1), &
6488
6489 & pos(2), &
6490
6491 & pos(3), &
6492
6493 & pos(4), &
6494
6495 & pos(5) )
6496
6497 if ( right_max < right_min ) then
6498 right_tmp = right_max
6499 right_max = right_min
6500 right_min = right_tmp
6501 end if
6502
6503 write(unit=pos_array(1), fmt="(i20)") pos(1)
6504
6505 write(unit=pos_array(2), fmt="(i20)") pos(2)
6506
6507 write(unit=pos_array(3), fmt="(i20)") pos(3)
6508
6509 write(unit=pos_array(4), fmt="(i20)") pos(4)
6510
6511 write(unit=pos_array(5), fmt="(i20)") pos(5)
6512
6513
6514 pos_str = '(' // &
6515 & trim(adjustl(pos_array(1))) // ',' // &
6516
6517 & trim(adjustl(pos_array(2))) // ',' // &
6518
6519 & trim(adjustl(pos_array(3))) // ',' // &
6520
6521 & trim(adjustl(pos_array(4))) // ',' // &
6522
6523 & trim(adjustl(pos_array(5))) // ')'
6524
6525 end if
6526 deallocate(mask_array, judge, judge_rev)
6527 deallocate(answer_negative, check_negative, both_negative)
6528 deallocate(answer_max, answer_min)
6529
6530
6531
6532 if (err_flag) then
6533 pos_str_space = ''
6534 pos_str_len = len_trim(pos_str)
6535
6536 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6537 write(*,*) ''
6538 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
6539 write(*,*) ' is NOT EQUAL to'
6540 write(*,*) ' ' // pos_str_space(1:pos_str_len) &
6541 & // ' ', right_min, ' < '
6542 write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
6543
6544 call abortprogram('')
6545 else
6546 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
6547 end if
6548
6549
6550 end subroutine dctestassertequalreal5digits
6551
6552
6553 subroutine dctestassertequalreal6digits( &
6554 & message, answer, check, significant_digits, ignore_digits )
6555 use sysdep, only: abortprogram
6556 use dc_types, only: string, token
6557 implicit none
6558 character(*), intent(in):: message
6559 real, intent(in):: answer(:,:,:,:,:,:)
6560 real, intent(in):: check(:,:,:,:,:,:)
6561 integer, intent(in):: significant_digits
6562 integer, intent(in):: ignore_digits
6563 logical:: err_flag
6564 character(STRING):: pos_str
6565 real:: wrong, right_max, right_min
6566 character(STRING):: pos_str_space
6567 integer:: pos_str_len
6568 real:: right_tmp
6569
6570 integer:: answer_shape(6), check_shape(6), pos(6)
6571 logical:: consist_shape(6)
6572 character(TOKEN):: pos_array(6)
6573 integer, allocatable:: mask_array(:,:,:,:,:,:)
6574 logical, allocatable:: judge(:,:,:,:,:,:)
6575 logical, allocatable:: judge_rev(:,:,:,:,:,:)
6576 logical, allocatable:: answer_negative(:,:,:,:,:,:)
6577 logical, allocatable:: check_negative(:,:,:,:,:,:)
6578 logical, allocatable:: both_negative(:,:,:,:,:,:)
6579 real, allocatable:: answer_max(:,:,:,:,:,:)
6580 real, allocatable:: answer_min(:,:,:,:,:,:)
6581
6582 continue
6583 err_flag = .false.
6584
6585 if ( significant_digits < 1 ) then
6586 write(*,*) ' *** Error [AssertEQ] *** '
6587 write(*,*) ' Specify a number more than 1 to "significant_digits"'
6588 call abortprogram('')
6589 end if
6590
6591 answer_shape = shape(answer)
6592 check_shape = shape(check)
6593
6594 consist_shape = answer_shape == check_shape
6595
6596 if (.not. all(consist_shape)) then
6597 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6598 write(*,*) ''
6599 write(*,*) ' shape of check is (', check_shape, ')'
6600 write(*,*) ' is INCORRECT'
6601 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
6602
6603 call abortprogram('')
6604 end if
6605
6606
6607 allocate( mask_array( &
6608 & answer_shape(1), &
6609
6610 & answer_shape(2), &
6611
6612 & answer_shape(3), &
6613
6614 & answer_shape(4), &
6615
6616 & answer_shape(5), &
6617
6618 & answer_shape(6) ) &
6619 & )
6620
6621 allocate( judge( &
6622 & answer_shape(1), &
6623
6624 & answer_shape(2), &
6625
6626 & answer_shape(3), &
6627
6628 & answer_shape(4), &
6629
6630 & answer_shape(5), &
6631
6632 & answer_shape(6) ) &
6633 & )
6634
6635 allocate( judge_rev( &
6636 & answer_shape(1), &
6637
6638 & answer_shape(2), &
6639
6640 & answer_shape(3), &
6641
6642 & answer_shape(4), &
6643
6644 & answer_shape(5), &
6645
6646 & answer_shape(6) ) &
6647 & )
6648
6649 allocate( answer_negative( &
6650 & answer_shape(1), &
6651
6652 & answer_shape(2), &
6653
6654 & answer_shape(3), &
6655
6656 & answer_shape(4), &
6657
6658 & answer_shape(5), &
6659
6660 & answer_shape(6) ) &
6661 & )
6662
6663 allocate( check_negative( &
6664 & answer_shape(1), &
6665
6666 & answer_shape(2), &
6667
6668 & answer_shape(3), &
6669
6670 & answer_shape(4), &
6671
6672 & answer_shape(5), &
6673
6674 & answer_shape(6) ) &
6675 & )
6676
6677 allocate( both_negative( &
6678 & answer_shape(1), &
6679
6680 & answer_shape(2), &
6681
6682 & answer_shape(3), &
6683
6684 & answer_shape(4), &
6685
6686 & answer_shape(5), &
6687
6688 & answer_shape(6) ) &
6689 & )
6690
6691 allocate( answer_max( &
6692 & answer_shape(1), &
6693
6694 & answer_shape(2), &
6695
6696 & answer_shape(3), &
6697
6698 & answer_shape(4), &
6699
6700 & answer_shape(5), &
6701
6702 & answer_shape(6) ) &
6703 & )
6704
6705 allocate( answer_min( &
6706 & answer_shape(1), &
6707
6708 & answer_shape(2), &
6709
6710 & answer_shape(3), &
6711
6712 & answer_shape(4), &
6713
6714 & answer_shape(5), &
6715
6716 & answer_shape(6) ) &
6717 & )
6718
6719 answer_negative = answer < 0.0
6720 check_negative = check < 0.0
6721 both_negative = answer_negative .and. check_negative
6722
6723 where (both_negative)
6724 answer_max = &
6725 & answer &
6726 & * ( 1.0 &
6727 & - 0.1 ** significant_digits ) &
6728 & + 0.1 ** (- ignore_digits)
6729
6730 answer_min = &
6731 & answer &
6732 & * ( 1.0 &
6733 & + 0.1 ** significant_digits ) &
6734 & - 0.1 ** (- ignore_digits)
6735 elsewhere
6736 answer_max = &
6737 & answer &
6738 & * ( 1.0 &
6739 & + 0.1 ** significant_digits ) &
6740 & + 0.1 ** (- ignore_digits)
6741
6742 answer_min = &
6743 & answer &
6744 & * ( 1.0 &
6745 & - 0.1 ** significant_digits ) &
6746 & - 0.1 ** (- ignore_digits)
6747 end where
6748
6749 judge = answer_max > check .and. check > answer_min
6750 judge_rev = .not. judge
6751 err_flag = any(judge_rev)
6752 mask_array = 1
6753 pos = maxloc(mask_array, judge_rev)
6754
6755 if (err_flag) then
6756
6757 wrong = check( &
6758 & pos(1), &
6759
6760 & pos(2), &
6761
6762 & pos(3), &
6763
6764 & pos(4), &
6765
6766 & pos(5), &
6767
6768 & pos(6) )
6769
6770 right_max = answer_max( &
6771 & pos(1), &
6772
6773 & pos(2), &
6774
6775 & pos(3), &
6776
6777 & pos(4), &
6778
6779 & pos(5), &
6780
6781 & pos(6) )
6782
6783 right_min = answer_min( &
6784 & pos(1), &
6785
6786 & pos(2), &
6787
6788 & pos(3), &
6789
6790 & pos(4), &
6791
6792 & pos(5), &
6793
6794 & pos(6) )
6795
6796 if ( right_max < right_min ) then
6797 right_tmp = right_max
6798 right_max = right_min
6799 right_min = right_tmp
6800 end if
6801
6802 write(unit=pos_array(1), fmt="(i20)") pos(1)
6803
6804 write(unit=pos_array(2), fmt="(i20)") pos(2)
6805
6806 write(unit=pos_array(3), fmt="(i20)") pos(3)
6807
6808 write(unit=pos_array(4), fmt="(i20)") pos(4)
6809
6810 write(unit=pos_array(5), fmt="(i20)") pos(5)
6811
6812 write(unit=pos_array(6), fmt="(i20)") pos(6)
6813
6814
6815 pos_str = '(' // &
6816 & trim(adjustl(pos_array(1))) // ',' // &
6817
6818 & trim(adjustl(pos_array(2))) // ',' // &
6819
6820 & trim(adjustl(pos_array(3))) // ',' // &
6821
6822 & trim(adjustl(pos_array(4))) // ',' // &
6823
6824 & trim(adjustl(pos_array(5))) // ',' // &
6825
6826 & trim(adjustl(pos_array(6))) // ')'
6827
6828 end if
6829 deallocate(mask_array, judge, judge_rev)
6830 deallocate(answer_negative, check_negative, both_negative)
6831 deallocate(answer_max, answer_min)
6832
6833
6834
6835 if (err_flag) then
6836 pos_str_space = ''
6837 pos_str_len = len_trim(pos_str)
6838
6839 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6840 write(*,*) ''
6841 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
6842 write(*,*) ' is NOT EQUAL to'
6843 write(*,*) ' ' // pos_str_space(1:pos_str_len) &
6844 & // ' ', right_min, ' < '
6845 write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
6846
6847 call abortprogram('')
6848 else
6849 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
6850 end if
6851
6852
6853 end subroutine dctestassertequalreal6digits
6854
6855
6856 subroutine dctestassertequalreal7digits( &
6857 & message, answer, check, significant_digits, ignore_digits )
6858 use sysdep, only: abortprogram
6859 use dc_types, only: string, token
6860 implicit none
6861 character(*), intent(in):: message
6862 real, intent(in):: answer(:,:,:,:,:,:,:)
6863 real, intent(in):: check(:,:,:,:,:,:,:)
6864 integer, intent(in):: significant_digits
6865 integer, intent(in):: ignore_digits
6866 logical:: err_flag
6867 character(STRING):: pos_str
6868 real:: wrong, right_max, right_min
6869 character(STRING):: pos_str_space
6870 integer:: pos_str_len
6871 real:: right_tmp
6872
6873 integer:: answer_shape(7), check_shape(7), pos(7)
6874 logical:: consist_shape(7)
6875 character(TOKEN):: pos_array(7)
6876 integer, allocatable:: mask_array(:,:,:,:,:,:,:)
6877 logical, allocatable:: judge(:,:,:,:,:,:,:)
6878 logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
6879 logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
6880 logical, allocatable:: check_negative(:,:,:,:,:,:,:)
6881 logical, allocatable:: both_negative(:,:,:,:,:,:,:)
6882 real, allocatable:: answer_max(:,:,:,:,:,:,:)
6883 real, allocatable:: answer_min(:,:,:,:,:,:,:)
6884
6885 continue
6886 err_flag = .false.
6887
6888 if ( significant_digits < 1 ) then
6889 write(*,*) ' *** Error [AssertEQ] *** '
6890 write(*,*) ' Specify a number more than 1 to "significant_digits"'
6891 call abortprogram('')
6892 end if
6893
6894 answer_shape = shape(answer)
6895 check_shape = shape(check)
6896
6897 consist_shape = answer_shape == check_shape
6898
6899 if (.not. all(consist_shape)) then
6900 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6901 write(*,*) ''
6902 write(*,*) ' shape of check is (', check_shape, ')'
6903 write(*,*) ' is INCORRECT'
6904 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
6905
6906 call abortprogram('')
6907 end if
6908
6909
6910 allocate( mask_array( &
6911 & answer_shape(1), &
6912
6913 & answer_shape(2), &
6914
6915 & answer_shape(3), &
6916
6917 & answer_shape(4), &
6918
6919 & answer_shape(5), &
6920
6921 & answer_shape(6), &
6922
6923 & answer_shape(7) ) &
6924 & )
6925
6926 allocate( judge( &
6927 & answer_shape(1), &
6928
6929 & answer_shape(2), &
6930
6931 & answer_shape(3), &
6932
6933 & answer_shape(4), &
6934
6935 & answer_shape(5), &
6936
6937 & answer_shape(6), &
6938
6939 & answer_shape(7) ) &
6940 & )
6941
6942 allocate( judge_rev( &
6943 & answer_shape(1), &
6944
6945 & answer_shape(2), &
6946
6947 & answer_shape(3), &
6948
6949 & answer_shape(4), &
6950
6951 & answer_shape(5), &
6952
6953 & answer_shape(6), &
6954
6955 & answer_shape(7) ) &
6956 & )
6957
6958 allocate( answer_negative( &
6959 & answer_shape(1), &
6960
6961 & answer_shape(2), &
6962
6963 & answer_shape(3), &
6964
6965 & answer_shape(4), &
6966
6967 & answer_shape(5), &
6968
6969 & answer_shape(6), &
6970
6971 & answer_shape(7) ) &
6972 & )
6973
6974 allocate( check_negative( &
6975 & answer_shape(1), &
6976
6977 & answer_shape(2), &
6978
6979 & answer_shape(3), &
6980
6981 & answer_shape(4), &
6982
6983 & answer_shape(5), &
6984
6985 & answer_shape(6), &
6986
6987 & answer_shape(7) ) &
6988 & )
6989
6990 allocate( both_negative( &
6991 & answer_shape(1), &
6992
6993 & answer_shape(2), &
6994
6995 & answer_shape(3), &
6996
6997 & answer_shape(4), &
6998
6999 & answer_shape(5), &
7000
7001 & answer_shape(6), &
7002
7003 & answer_shape(7) ) &
7004 & )
7005
7006 allocate( answer_max( &
7007 & answer_shape(1), &
7008
7009 & answer_shape(2), &
7010
7011 & answer_shape(3), &
7012
7013 & answer_shape(4), &
7014
7015 & answer_shape(5), &
7016
7017 & answer_shape(6), &
7018
7019 & answer_shape(7) ) &
7020 & )
7021
7022 allocate( answer_min( &
7023 & answer_shape(1), &
7024
7025 & answer_shape(2), &
7026
7027 & answer_shape(3), &
7028
7029 & answer_shape(4), &
7030
7031 & answer_shape(5), &
7032
7033 & answer_shape(6), &
7034
7035 & answer_shape(7) ) &
7036 & )
7037
7038 answer_negative = answer < 0.0
7039 check_negative = check < 0.0
7040 both_negative = answer_negative .and. check_negative
7041
7042 where (both_negative)
7043 answer_max = &
7044 & answer &
7045 & * ( 1.0 &
7046 & - 0.1 ** significant_digits ) &
7047 & + 0.1 ** (- ignore_digits)
7048
7049 answer_min = &
7050 & answer &
7051 & * ( 1.0 &
7052 & + 0.1 ** significant_digits ) &
7053 & - 0.1 ** (- ignore_digits)
7054 elsewhere
7055 answer_max = &
7056 & answer &
7057 & * ( 1.0 &
7058 & + 0.1 ** significant_digits ) &
7059 & + 0.1 ** (- ignore_digits)
7060
7061 answer_min = &
7062 & answer &
7063 & * ( 1.0 &
7064 & - 0.1 ** significant_digits ) &
7065 & - 0.1 ** (- ignore_digits)
7066 end where
7067
7068 judge = answer_max > check .and. check > answer_min
7069 judge_rev = .not. judge
7070 err_flag = any(judge_rev)
7071 mask_array = 1
7072 pos = maxloc(mask_array, judge_rev)
7073
7074 if (err_flag) then
7075
7076 wrong = check( &
7077 & pos(1), &
7078
7079 & pos(2), &
7080
7081 & pos(3), &
7082
7083 & pos(4), &
7084
7085 & pos(5), &
7086
7087 & pos(6), &
7088
7089 & pos(7) )
7090
7091 right_max = answer_max( &
7092 & pos(1), &
7093
7094 & pos(2), &
7095
7096 & pos(3), &
7097
7098 & pos(4), &
7099
7100 & pos(5), &
7101
7102 & pos(6), &
7103
7104 & pos(7) )
7105
7106 right_min = answer_min( &
7107 & pos(1), &
7108
7109 & pos(2), &
7110
7111 & pos(3), &
7112
7113 & pos(4), &
7114
7115 & pos(5), &
7116
7117 & pos(6), &
7118
7119 & pos(7) )
7120
7121 if ( right_max < right_min ) then
7122 right_tmp = right_max
7123 right_max = right_min
7124 right_min = right_tmp
7125 end if
7126
7127 write(unit=pos_array(1), fmt="(i20)") pos(1)
7128
7129 write(unit=pos_array(2), fmt="(i20)") pos(2)
7130
7131 write(unit=pos_array(3), fmt="(i20)") pos(3)
7132
7133 write(unit=pos_array(4), fmt="(i20)") pos(4)
7134
7135 write(unit=pos_array(5), fmt="(i20)") pos(5)
7136
7137 write(unit=pos_array(6), fmt="(i20)") pos(6)
7138
7139 write(unit=pos_array(7), fmt="(i20)") pos(7)
7140
7141
7142 pos_str = '(' // &
7143 & trim(adjustl(pos_array(1))) // ',' // &
7144
7145 & trim(adjustl(pos_array(2))) // ',' // &
7146
7147 & trim(adjustl(pos_array(3))) // ',' // &
7148
7149 & trim(adjustl(pos_array(4))) // ',' // &
7150
7151 & trim(adjustl(pos_array(5))) // ',' // &
7152
7153 & trim(adjustl(pos_array(6))) // ',' // &
7154
7155 & trim(adjustl(pos_array(7))) // ')'
7156
7157 end if
7158 deallocate(mask_array, judge, judge_rev)
7159 deallocate(answer_negative, check_negative, both_negative)
7160 deallocate(answer_max, answer_min)
7161
7162
7163
7164 if (err_flag) then
7165 pos_str_space = ''
7166 pos_str_len = len_trim(pos_str)
7167
7168 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7169 write(*,*) ''
7170 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
7171 write(*,*) ' is NOT EQUAL to'
7172 write(*,*) ' ' // pos_str_space(1:pos_str_len) &
7173 & // ' ', right_min, ' < '
7174 write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
7175
7176 call abortprogram('')
7177 else
7178 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
7179 end if
7180
7181
7182 end subroutine dctestassertequalreal7digits
7183
7184
7185 subroutine dctestassertequaldouble0digits( &
7186 & message, answer, check, significant_digits, ignore_digits )
7187 use sysdep, only: abortprogram
7188 use dc_types, only: string
7189 implicit none
7190 character(*), intent(in):: message
7191 real(DP), intent(in):: answer
7192 real(DP), intent(in):: check
7193 integer, intent(in):: significant_digits
7194 integer, intent(in):: ignore_digits
7195 logical:: err_flag
7196 character(STRING):: pos_str
7197 real(DP):: wrong, right_max, right_min
7198 character(STRING):: pos_str_space
7199 integer:: pos_str_len
7200 real(DP):: right_tmp
7201
7202 real(DP):: answer_max
7203 real(DP):: answer_min
7204
7205 continue
7206 err_flag = .false.
7207
7208 if ( significant_digits < 1 ) then
7209 write(*,*) ' *** Error [AssertEQ] *** '
7210 write(*,*) ' Specify a number more than 1 to "significant_digits"'
7211 call abortprogram('')
7212 end if
7213
7214 if ( answer < 0.0_dp .and. check < 0.0_dp ) then
7215 answer_max = &
7216 & answer &
7217 & * ( 1.0_dp &
7218 & - 0.1_dp ** significant_digits ) &
7219 & + 0.1_dp ** (- ignore_digits)
7220
7221 answer_min = &
7222 & answer &
7223 & * ( 1.0_dp &
7224 & + 0.1_dp ** significant_digits ) &
7225 & - 0.1_dp ** (- ignore_digits)
7226 else
7227
7228 answer_max = &
7229 & answer &
7230 & * ( 1.0_dp &
7231 & + 0.1_dp ** significant_digits ) &
7232 & + 0.1_dp ** (- ignore_digits)
7233
7234 answer_min = &
7235 & answer &
7236 & * ( 1.0_dp &
7237 & - 0.1_dp ** significant_digits ) &
7238 & - 0.1_dp ** (- ignore_digits)
7239 end if
7240
7241 wrong = check
7242 right_max = answer_max
7243 right_min = answer_min
7244 if ( right_max < right_min ) then
7245 right_tmp = right_max
7246 right_max = right_min
7247 right_min = right_tmp
7248 end if
7249
7250 err_flag = .not. (answer_max > check .and. check > answer_min)
7251
7252 pos_str = ''
7253
7254
7255
7256 if (err_flag) then
7257 pos_str_space = ''
7258 pos_str_len = len_trim(pos_str)
7259
7260 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7261 write(*,*) ''
7262 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
7263 write(*,*) ' is NOT EQUAL to'
7264 write(*,*) ' ' // pos_str_space(1:pos_str_len) &
7265 & // ' ', right_min, ' < '
7266 write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
7267
7268 call abortprogram('')
7269 else
7270 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
7271 end if
7272
7273
7274 end subroutine dctestassertequaldouble0digits
7275
7276
7277 subroutine dctestassertequaldouble1digits( &
7278 & message, answer, check, significant_digits, ignore_digits )
7279 use sysdep, only: abortprogram
7280 use dc_types, only: string, token
7281 implicit none
7282 character(*), intent(in):: message
7283 real(DP), intent(in):: answer(:)
7284 real(DP), intent(in):: check(:)
7285 integer, intent(in):: significant_digits
7286 integer, intent(in):: ignore_digits
7287 logical:: err_flag
7288 character(STRING):: pos_str
7289 real(DP):: wrong, right_max, right_min
7290 character(STRING):: pos_str_space
7291 integer:: pos_str_len
7292 real(DP):: right_tmp
7293
7294 integer:: answer_shape(1), check_shape(1), pos(1)
7295 logical:: consist_shape(1)
7296 character(TOKEN):: pos_array(1)
7297 integer, allocatable:: mask_array(:)
7298 logical, allocatable:: judge(:)
7299 logical, allocatable:: judge_rev(:)
7300 logical, allocatable:: answer_negative(:)
7301 logical, allocatable:: check_negative(:)
7302 logical, allocatable:: both_negative(:)
7303 real(DP), allocatable:: answer_max(:)
7304 real(DP), allocatable:: answer_min(:)
7305
7306 continue
7307 err_flag = .false.
7308
7309 if ( significant_digits < 1 ) then
7310 write(*,*) ' *** Error [AssertEQ] *** '
7311 write(*,*) ' Specify a number more than 1 to "significant_digits"'
7312 call abortprogram('')
7313 end if
7314
7315 answer_shape = shape(answer)
7316 check_shape = shape(check)
7317
7318 consist_shape = answer_shape == check_shape
7319
7320 if (.not. all(consist_shape)) then
7321 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7322 write(*,*) ''
7323 write(*,*) ' shape of check is (', check_shape, ')'
7324 write(*,*) ' is INCORRECT'
7325 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
7326
7327 call abortprogram('')
7328 end if
7329
7330
7331 allocate( mask_array( &
7332
7333 & answer_shape(1) ) &
7334 & )
7335
7336 allocate( judge( &
7337
7338 & answer_shape(1) ) &
7339 & )
7340
7341 allocate( judge_rev( &
7342
7343 & answer_shape(1) ) &
7344 & )
7345
7346 allocate( answer_negative( &
7347
7348 & answer_shape(1) ) &
7349 & )
7350
7351 allocate( check_negative( &
7352
7353 & answer_shape(1) ) &
7354 & )
7355
7356 allocate( both_negative( &
7357
7358 & answer_shape(1) ) &
7359 & )
7360
7361 allocate( answer_max( &
7362
7363 & answer_shape(1) ) &
7364 & )
7365
7366 allocate( answer_min( &
7367
7368 & answer_shape(1) ) &
7369 & )
7370
7371 answer_negative = answer < 0.0_dp
7372 check_negative = check < 0.0_dp
7373 both_negative = answer_negative .and. check_negative
7374
7375 where (both_negative)
7376 answer_max = &
7377 & answer &
7378 & * ( 1.0_dp &
7379 & - 0.1_dp ** significant_digits ) &
7380 & + 0.1_dp ** (- ignore_digits)
7381
7382 answer_min = &
7383 & answer &
7384 & * ( 1.0_dp &
7385 & + 0.1_dp ** significant_digits ) &
7386 & - 0.1_dp ** (- ignore_digits)
7387 elsewhere
7388 answer_max = &
7389 & answer &
7390 & * ( 1.0_dp &
7391 & + 0.1_dp ** significant_digits ) &
7392 & + 0.1_dp ** (- ignore_digits)
7393
7394 answer_min = &
7395 & answer &
7396 & * ( 1.0_dp &
7397 & - 0.1_dp ** significant_digits ) &
7398 & - 0.1_dp ** (- ignore_digits)
7399 end where
7400
7401 judge = answer_max > check .and. check > answer_min
7402 judge_rev = .not. judge
7403 err_flag = any(judge_rev)
7404 mask_array = 1
7405 pos = maxloc(mask_array, judge_rev)
7406
7407 if (err_flag) then
7408
7409 wrong = check( &
7410
7411 & pos(1) )
7412
7413 right_max = answer_max( &
7414
7415 & pos(1) )
7416
7417 right_min = answer_min( &
7418
7419 & pos(1) )
7420
7421 if ( right_max < right_min ) then
7422 right_tmp = right_max
7423 right_max = right_min
7424 right_min = right_tmp
7425 end if
7426
7427 write(unit=pos_array(1), fmt="(i20)") pos(1)
7428
7429
7430 pos_str = '(' // &
7431
7432 & trim(adjustl(pos_array(1))) // ')'
7433
7434 end if
7435 deallocate(mask_array, judge, judge_rev)
7436 deallocate(answer_negative, check_negative, both_negative)
7437 deallocate(answer_max, answer_min)
7438
7439
7440
7441 if (err_flag) then
7442 pos_str_space = ''
7443 pos_str_len = len_trim(pos_str)
7444
7445 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7446 write(*,*) ''
7447 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
7448 write(*,*) ' is NOT EQUAL to'
7449 write(*,*) ' ' // pos_str_space(1:pos_str_len) &
7450 & // ' ', right_min, ' < '
7451 write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
7452
7453 call abortprogram('')
7454 else
7455 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
7456 end if
7457
7458
7459 end subroutine dctestassertequaldouble1digits
7460
7461
7462 subroutine dctestassertequaldouble2digits( &
7463 & message, answer, check, significant_digits, ignore_digits )
7464 use sysdep, only: abortprogram
7465 use dc_types, only: string, token
7466 implicit none
7467 character(*), intent(in):: message
7468 real(DP), intent(in):: answer(:,:)
7469 real(DP), intent(in):: check(:,:)
7470 integer, intent(in):: significant_digits
7471 integer, intent(in):: ignore_digits
7472 logical:: err_flag
7473 character(STRING):: pos_str
7474 real(DP):: wrong, right_max, right_min
7475 character(STRING):: pos_str_space
7476 integer:: pos_str_len
7477 real(DP):: right_tmp
7478
7479 integer:: answer_shape(2), check_shape(2), pos(2)
7480 logical:: consist_shape(2)
7481 character(TOKEN):: pos_array(2)
7482 integer, allocatable:: mask_array(:,:)
7483 logical, allocatable:: judge(:,:)
7484 logical, allocatable:: judge_rev(:,:)
7485 logical, allocatable:: answer_negative(:,:)
7486 logical, allocatable:: check_negative(:,:)
7487 logical, allocatable:: both_negative(:,:)
7488 real(DP), allocatable:: answer_max(:,:)
7489 real(DP), allocatable:: answer_min(:,:)
7490
7491 continue
7492 err_flag = .false.
7493
7494 if ( significant_digits < 1 ) then
7495 write(*,*) ' *** Error [AssertEQ] *** '
7496 write(*,*) ' Specify a number more than 1 to "significant_digits"'
7497 call abortprogram('')
7498 end if
7499
7500 answer_shape = shape(answer)
7501 check_shape = shape(check)
7502
7503 consist_shape = answer_shape == check_shape
7504
7505 if (.not. all(consist_shape)) then
7506 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7507 write(*,*) ''
7508 write(*,*) ' shape of check is (', check_shape, ')'
7509 write(*,*) ' is INCORRECT'
7510 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
7511
7512 call abortprogram('')
7513 end if
7514
7515
7516 allocate( mask_array( &
7517 & answer_shape(1), &
7518
7519 & answer_shape(2) ) &
7520 & )
7521
7522 allocate( judge( &
7523 & answer_shape(1), &
7524
7525 & answer_shape(2) ) &
7526 & )
7527
7528 allocate( judge_rev( &
7529 & answer_shape(1), &
7530
7531 & answer_shape(2) ) &
7532 & )
7533
7534 allocate( answer_negative( &
7535 & answer_shape(1), &
7536
7537 & answer_shape(2) ) &
7538 & )
7539
7540 allocate( check_negative( &
7541 & answer_shape(1), &
7542
7543 & answer_shape(2) ) &
7544 & )
7545
7546 allocate( both_negative( &
7547 & answer_shape(1), &
7548
7549 & answer_shape(2) ) &
7550 & )
7551
7552 allocate( answer_max( &
7553 & answer_shape(1), &
7554
7555 & answer_shape(2) ) &
7556 & )
7557
7558 allocate( answer_min( &
7559 & answer_shape(1), &
7560
7561 & answer_shape(2) ) &
7562 & )
7563
7564 answer_negative = answer < 0.0_dp
7565 check_negative = check < 0.0_dp
7566 both_negative = answer_negative .and. check_negative
7567
7568 where (both_negative)
7569 answer_max = &
7570 & answer &
7571 & * ( 1.0_dp &
7572 & - 0.1_dp ** significant_digits ) &
7573 & + 0.1_dp ** (- ignore_digits)
7574
7575 answer_min = &
7576 & answer &
7577 & * ( 1.0_dp &
7578 & + 0.1_dp ** significant_digits ) &
7579 & - 0.1_dp ** (- ignore_digits)
7580 elsewhere
7581 answer_max = &
7582 & answer &
7583 & * ( 1.0_dp &
7584 & + 0.1_dp ** significant_digits ) &
7585 & + 0.1_dp ** (- ignore_digits)
7586
7587 answer_min = &
7588 & answer &
7589 & * ( 1.0_dp &
7590 & - 0.1_dp ** significant_digits ) &
7591 & - 0.1_dp ** (- ignore_digits)
7592 end where
7593
7594 judge = answer_max > check .and. check > answer_min
7595 judge_rev = .not. judge
7596 err_flag = any(judge_rev)
7597 mask_array = 1
7598 pos = maxloc(mask_array, judge_rev)
7599
7600 if (err_flag) then
7601
7602 wrong = check( &
7603 & pos(1), &
7604
7605 & pos(2) )
7606
7607 right_max = answer_max( &
7608 & pos(1), &
7609
7610 & pos(2) )
7611
7612 right_min = answer_min( &
7613 & pos(1), &
7614
7615 & pos(2) )
7616
7617 if ( right_max < right_min ) then
7618 right_tmp = right_max
7619 right_max = right_min
7620 right_min = right_tmp
7621 end if
7622
7623 write(unit=pos_array(1), fmt="(i20)") pos(1)
7624
7625 write(unit=pos_array(2), fmt="(i20)") pos(2)
7626
7627
7628 pos_str = '(' // &
7629 & trim(adjustl(pos_array(1))) // ',' // &
7630
7631 & trim(adjustl(pos_array(2))) // ')'
7632
7633 end if
7634 deallocate(mask_array, judge, judge_rev)
7635 deallocate(answer_negative, check_negative, both_negative)
7636 deallocate(answer_max, answer_min)
7637
7638
7639
7640 if (err_flag) then
7641 pos_str_space = ''
7642 pos_str_len = len_trim(pos_str)
7643
7644 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7645 write(*,*) ''
7646 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
7647 write(*,*) ' is NOT EQUAL to'
7648 write(*,*) ' ' // pos_str_space(1:pos_str_len) &
7649 & // ' ', right_min, ' < '
7650 write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
7651
7652 call abortprogram('')
7653 else
7654 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
7655 end if
7656
7657
7658 end subroutine dctestassertequaldouble2digits
7659
7660
7661 subroutine dctestassertequaldouble3digits( &
7662 & message, answer, check, significant_digits, ignore_digits )
7663 use sysdep, only: abortprogram
7664 use dc_types, only: string, token
7665 implicit none
7666 character(*), intent(in):: message
7667 real(DP), intent(in):: answer(:,:,:)
7668 real(DP), intent(in):: check(:,:,:)
7669 integer, intent(in):: significant_digits
7670 integer, intent(in):: ignore_digits
7671 logical:: err_flag
7672 character(STRING):: pos_str
7673 real(DP):: wrong, right_max, right_min
7674 character(STRING):: pos_str_space
7675 integer:: pos_str_len
7676 real(DP):: right_tmp
7677
7678 integer:: answer_shape(3), check_shape(3), pos(3)
7679 logical:: consist_shape(3)
7680 character(TOKEN):: pos_array(3)
7681 integer, allocatable:: mask_array(:,:,:)
7682 logical, allocatable:: judge(:,:,:)
7683 logical, allocatable:: judge_rev(:,:,:)
7684 logical, allocatable:: answer_negative(:,:,:)
7685 logical, allocatable:: check_negative(:,:,:)
7686 logical, allocatable:: both_negative(:,:,:)
7687 real(DP), allocatable:: answer_max(:,:,:)
7688 real(DP), allocatable:: answer_min(:,:,:)
7689
7690 continue
7691 err_flag = .false.
7692
7693 if ( significant_digits < 1 ) then
7694 write(*,*) ' *** Error [AssertEQ] *** '
7695 write(*,*) ' Specify a number more than 1 to "significant_digits"'
7696 call abortprogram('')
7697 end if
7698
7699 answer_shape = shape(answer)
7700 check_shape = shape(check)
7701
7702 consist_shape = answer_shape == check_shape
7703
7704 if (.not. all(consist_shape)) then
7705 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7706 write(*,*) ''
7707 write(*,*) ' shape of check is (', check_shape, ')'
7708 write(*,*) ' is INCORRECT'
7709 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
7710
7711 call abortprogram('')
7712 end if
7713
7714
7715 allocate( mask_array( &
7716 & answer_shape(1), &
7717
7718 & answer_shape(2), &
7719
7720 & answer_shape(3) ) &
7721 & )
7722
7723 allocate( judge( &
7724 & answer_shape(1), &
7725
7726 & answer_shape(2), &
7727
7728 & answer_shape(3) ) &
7729 & )
7730
7731 allocate( judge_rev( &
7732 & answer_shape(1), &
7733
7734 & answer_shape(2), &
7735
7736 & answer_shape(3) ) &
7737 & )
7738
7739 allocate( answer_negative( &
7740 & answer_shape(1), &
7741
7742 & answer_shape(2), &
7743
7744 & answer_shape(3) ) &
7745 & )
7746
7747 allocate( check_negative( &
7748 & answer_shape(1), &
7749
7750 & answer_shape(2), &
7751
7752 & answer_shape(3) ) &
7753 & )
7754
7755 allocate( both_negative( &
7756 & answer_shape(1), &
7757
7758 & answer_shape(2), &
7759
7760 & answer_shape(3) ) &
7761 & )
7762
7763 allocate( answer_max( &
7764 & answer_shape(1), &
7765
7766 & answer_shape(2), &
7767
7768 & answer_shape(3) ) &
7769 & )
7770
7771 allocate( answer_min( &
7772 & answer_shape(1), &
7773
7774 & answer_shape(2), &
7775
7776 & answer_shape(3) ) &
7777 & )
7778
7779 answer_negative = answer < 0.0_dp
7780 check_negative = check < 0.0_dp
7781 both_negative = answer_negative .and. check_negative
7782
7783 where (both_negative)
7784 answer_max = &
7785 & answer &
7786 & * ( 1.0_dp &
7787 & - 0.1_dp ** significant_digits ) &
7788 & + 0.1_dp ** (- ignore_digits)
7789
7790 answer_min = &
7791 & answer &
7792 & * ( 1.0_dp &
7793 & + 0.1_dp ** significant_digits ) &
7794 & - 0.1_dp ** (- ignore_digits)
7795 elsewhere
7796 answer_max = &
7797 & answer &
7798 & * ( 1.0_dp &
7799 & + 0.1_dp ** significant_digits ) &
7800 & + 0.1_dp ** (- ignore_digits)
7801
7802 answer_min = &
7803 & answer &
7804 & * ( 1.0_dp &
7805 & - 0.1_dp ** significant_digits ) &
7806 & - 0.1_dp ** (- ignore_digits)
7807 end where
7808
7809 judge = answer_max > check .and. check > answer_min
7810 judge_rev = .not. judge
7811 err_flag = any(judge_rev)
7812 mask_array = 1
7813 pos = maxloc(mask_array, judge_rev)
7814
7815 if (err_flag) then
7816
7817 wrong = check( &
7818 & pos(1), &
7819
7820 & pos(2), &
7821
7822 & pos(3) )
7823
7824 right_max = answer_max( &
7825 & pos(1), &
7826
7827 & pos(2), &
7828
7829 & pos(3) )
7830
7831 right_min = answer_min( &
7832 & pos(1), &
7833
7834 & pos(2), &
7835
7836 & pos(3) )
7837
7838 if ( right_max < right_min ) then
7839 right_tmp = right_max
7840 right_max = right_min
7841 right_min = right_tmp
7842 end if
7843
7844 write(unit=pos_array(1), fmt="(i20)") pos(1)
7845
7846 write(unit=pos_array(2), fmt="(i20)") pos(2)
7847
7848 write(unit=pos_array(3), fmt="(i20)") pos(3)
7849
7850
7851 pos_str = '(' // &
7852 & trim(adjustl(pos_array(1))) // ',' // &
7853
7854 & trim(adjustl(pos_array(2))) // ',' // &
7855
7856 & trim(adjustl(pos_array(3))) // ')'
7857
7858 end if
7859 deallocate(mask_array, judge, judge_rev)
7860 deallocate(answer_negative, check_negative, both_negative)
7861 deallocate(answer_max, answer_min)
7862
7863
7864
7865 if (err_flag) then
7866 pos_str_space = ''
7867 pos_str_len = len_trim(pos_str)
7868
7869 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7870 write(*,*) ''
7871 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
7872 write(*,*) ' is NOT EQUAL to'
7873 write(*,*) ' ' // pos_str_space(1:pos_str_len) &
7874 & // ' ', right_min, ' < '
7875 write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
7876
7877 call abortprogram('')
7878 else
7879 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
7880 end if
7881
7882
7883 end subroutine dctestassertequaldouble3digits
7884
7885
7886 subroutine dctestassertequaldouble4digits( &
7887 & message, answer, check, significant_digits, ignore_digits )
7888 use sysdep, only: abortprogram
7889 use dc_types, only: string, token
7890 implicit none
7891 character(*), intent(in):: message
7892 real(DP), intent(in):: answer(:,:,:,:)
7893 real(DP), intent(in):: check(:,:,:,:)
7894 integer, intent(in):: significant_digits
7895 integer, intent(in):: ignore_digits
7896 logical:: err_flag
7897 character(STRING):: pos_str
7898 real(DP):: wrong, right_max, right_min
7899 character(STRING):: pos_str_space
7900 integer:: pos_str_len
7901 real(DP):: right_tmp
7902
7903 integer:: answer_shape(4), check_shape(4), pos(4)
7904 logical:: consist_shape(4)
7905 character(TOKEN):: pos_array(4)
7906 integer, allocatable:: mask_array(:,:,:,:)
7907 logical, allocatable:: judge(:,:,:,:)
7908 logical, allocatable:: judge_rev(:,:,:,:)
7909 logical, allocatable:: answer_negative(:,:,:,:)
7910 logical, allocatable:: check_negative(:,:,:,:)
7911 logical, allocatable:: both_negative(:,:,:,:)
7912 real(DP), allocatable:: answer_max(:,:,:,:)
7913 real(DP), allocatable:: answer_min(:,:,:,:)
7914
7915 continue
7916 err_flag = .false.
7917
7918 if ( significant_digits < 1 ) then
7919 write(*,*) ' *** Error [AssertEQ] *** '
7920 write(*,*) ' Specify a number more than 1 to "significant_digits"'
7921 call abortprogram('')
7922 end if
7923
7924 answer_shape = shape(answer)
7925 check_shape = shape(check)
7926
7927 consist_shape = answer_shape == check_shape
7928
7929 if (.not. all(consist_shape)) then
7930 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7931 write(*,*) ''
7932 write(*,*) ' shape of check is (', check_shape, ')'
7933 write(*,*) ' is INCORRECT'
7934 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
7935
7936 call abortprogram('')
7937 end if
7938
7939
7940 allocate( mask_array( &
7941 & answer_shape(1), &
7942
7943 & answer_shape(2), &
7944
7945 & answer_shape(3), &
7946
7947 & answer_shape(4) ) &
7948 & )
7949
7950 allocate( judge( &
7951 & answer_shape(1), &
7952
7953 & answer_shape(2), &
7954
7955 & answer_shape(3), &
7956
7957 & answer_shape(4) ) &
7958 & )
7959
7960 allocate( judge_rev( &
7961 & answer_shape(1), &
7962
7963 & answer_shape(2), &
7964
7965 & answer_shape(3), &
7966
7967 & answer_shape(4) ) &
7968 & )
7969
7970 allocate( answer_negative( &
7971 & answer_shape(1), &
7972
7973 & answer_shape(2), &
7974
7975 & answer_shape(3), &
7976
7977 & answer_shape(4) ) &
7978 & )
7979
7980 allocate( check_negative( &
7981 & answer_shape(1), &
7982
7983 & answer_shape(2), &
7984
7985 & answer_shape(3), &
7986
7987 & answer_shape(4) ) &
7988 & )
7989
7990 allocate( both_negative( &
7991 & answer_shape(1), &
7992
7993 & answer_shape(2), &
7994
7995 & answer_shape(3), &
7996
7997 & answer_shape(4) ) &
7998 & )
7999
8000 allocate( answer_max( &
8001 & answer_shape(1), &
8002
8003 & answer_shape(2), &
8004
8005 & answer_shape(3), &
8006
8007 & answer_shape(4) ) &
8008 & )
8009
8010 allocate( answer_min( &
8011 & answer_shape(1), &
8012
8013 & answer_shape(2), &
8014
8015 & answer_shape(3), &
8016
8017 & answer_shape(4) ) &
8018 & )
8019
8020 answer_negative = answer < 0.0_dp
8021 check_negative = check < 0.0_dp
8022 both_negative = answer_negative .and. check_negative
8023
8024 where (both_negative)
8025 answer_max = &
8026 & answer &
8027 & * ( 1.0_dp &
8028 & - 0.1_dp ** significant_digits ) &
8029 & + 0.1_dp ** (- ignore_digits)
8030
8031 answer_min = &
8032 & answer &
8033 & * ( 1.0_dp &
8034 & + 0.1_dp ** significant_digits ) &
8035 & - 0.1_dp ** (- ignore_digits)
8036 elsewhere
8037 answer_max = &
8038 & answer &
8039 & * ( 1.0_dp &
8040 & + 0.1_dp ** significant_digits ) &
8041 & + 0.1_dp ** (- ignore_digits)
8042
8043 answer_min = &
8044 & answer &
8045 & * ( 1.0_dp &
8046 & - 0.1_dp ** significant_digits ) &
8047 & - 0.1_dp ** (- ignore_digits)
8048 end where
8049
8050 judge = answer_max > check .and. check > answer_min
8051 judge_rev = .not. judge
8052 err_flag = any(judge_rev)
8053 mask_array = 1
8054 pos = maxloc(mask_array, judge_rev)
8055
8056 if (err_flag) then
8057
8058 wrong = check( &
8059 & pos(1), &
8060
8061 & pos(2), &
8062
8063 & pos(3), &
8064
8065 & pos(4) )
8066
8067 right_max = answer_max( &
8068 & pos(1), &
8069
8070 & pos(2), &
8071
8072 & pos(3), &
8073
8074 & pos(4) )
8075
8076 right_min = answer_min( &
8077 & pos(1), &
8078
8079 & pos(2), &
8080
8081 & pos(3), &
8082
8083 & pos(4) )
8084
8085 if ( right_max < right_min ) then
8086 right_tmp = right_max
8087 right_max = right_min
8088 right_min = right_tmp
8089 end if
8090
8091 write(unit=pos_array(1), fmt="(i20)") pos(1)
8092
8093 write(unit=pos_array(2), fmt="(i20)") pos(2)
8094
8095 write(unit=pos_array(3), fmt="(i20)") pos(3)
8096
8097 write(unit=pos_array(4), fmt="(i20)") pos(4)
8098
8099
8100 pos_str = '(' // &
8101 & trim(adjustl(pos_array(1))) // ',' // &
8102
8103 & trim(adjustl(pos_array(2))) // ',' // &
8104
8105 & trim(adjustl(pos_array(3))) // ',' // &
8106
8107 & trim(adjustl(pos_array(4))) // ')'
8108
8109 end if
8110 deallocate(mask_array, judge, judge_rev)
8111 deallocate(answer_negative, check_negative, both_negative)
8112 deallocate(answer_max, answer_min)
8113
8114
8115
8116 if (err_flag) then
8117 pos_str_space = ''
8118 pos_str_len = len_trim(pos_str)
8119
8120 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8121 write(*,*) ''
8122 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
8123 write(*,*) ' is NOT EQUAL to'
8124 write(*,*) ' ' // pos_str_space(1:pos_str_len) &
8125 & // ' ', right_min, ' < '
8126 write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
8127
8128 call abortprogram('')
8129 else
8130 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
8131 end if
8132
8133
8134 end subroutine dctestassertequaldouble4digits
8135
8136
8137 subroutine dctestassertequaldouble5digits( &
8138 & message, answer, check, significant_digits, ignore_digits )
8139 use sysdep, only: abortprogram
8140 use dc_types, only: string, token
8141 implicit none
8142 character(*), intent(in):: message
8143 real(DP), intent(in):: answer(:,:,:,:,:)
8144 real(DP), intent(in):: check(:,:,:,:,:)
8145 integer, intent(in):: significant_digits
8146 integer, intent(in):: ignore_digits
8147 logical:: err_flag
8148 character(STRING):: pos_str
8149 real(DP):: wrong, right_max, right_min
8150 character(STRING):: pos_str_space
8151 integer:: pos_str_len
8152 real(DP):: right_tmp
8153
8154 integer:: answer_shape(5), check_shape(5), pos(5)
8155 logical:: consist_shape(5)
8156 character(TOKEN):: pos_array(5)
8157 integer, allocatable:: mask_array(:,:,:,:,:)
8158 logical, allocatable:: judge(:,:,:,:,:)
8159 logical, allocatable:: judge_rev(:,:,:,:,:)
8160 logical, allocatable:: answer_negative(:,:,:,:,:)
8161 logical, allocatable:: check_negative(:,:,:,:,:)
8162 logical, allocatable:: both_negative(:,:,:,:,:)
8163 real(DP), allocatable:: answer_max(:,:,:,:,:)
8164 real(DP), allocatable:: answer_min(:,:,:,:,:)
8165
8166 continue
8167 err_flag = .false.
8168
8169 if ( significant_digits < 1 ) then
8170 write(*,*) ' *** Error [AssertEQ] *** '
8171 write(*,*) ' Specify a number more than 1 to "significant_digits"'
8172 call abortprogram('')
8173 end if
8174
8175 answer_shape = shape(answer)
8176 check_shape = shape(check)
8177
8178 consist_shape = answer_shape == check_shape
8179
8180 if (.not. all(consist_shape)) then
8181 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8182 write(*,*) ''
8183 write(*,*) ' shape of check is (', check_shape, ')'
8184 write(*,*) ' is INCORRECT'
8185 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
8186
8187 call abortprogram('')
8188 end if
8189
8190
8191 allocate( mask_array( &
8192 & answer_shape(1), &
8193
8194 & answer_shape(2), &
8195
8196 & answer_shape(3), &
8197
8198 & answer_shape(4), &
8199
8200 & answer_shape(5) ) &
8201 & )
8202
8203 allocate( judge( &
8204 & answer_shape(1), &
8205
8206 & answer_shape(2), &
8207
8208 & answer_shape(3), &
8209
8210 & answer_shape(4), &
8211
8212 & answer_shape(5) ) &
8213 & )
8214
8215 allocate( judge_rev( &
8216 & answer_shape(1), &
8217
8218 & answer_shape(2), &
8219
8220 & answer_shape(3), &
8221
8222 & answer_shape(4), &
8223
8224 & answer_shape(5) ) &
8225 & )
8226
8227 allocate( answer_negative( &
8228 & answer_shape(1), &
8229
8230 & answer_shape(2), &
8231
8232 & answer_shape(3), &
8233
8234 & answer_shape(4), &
8235
8236 & answer_shape(5) ) &
8237 & )
8238
8239 allocate( check_negative( &
8240 & answer_shape(1), &
8241
8242 & answer_shape(2), &
8243
8244 & answer_shape(3), &
8245
8246 & answer_shape(4), &
8247
8248 & answer_shape(5) ) &
8249 & )
8250
8251 allocate( both_negative( &
8252 & answer_shape(1), &
8253
8254 & answer_shape(2), &
8255
8256 & answer_shape(3), &
8257
8258 & answer_shape(4), &
8259
8260 & answer_shape(5) ) &
8261 & )
8262
8263 allocate( answer_max( &
8264 & answer_shape(1), &
8265
8266 & answer_shape(2), &
8267
8268 & answer_shape(3), &
8269
8270 & answer_shape(4), &
8271
8272 & answer_shape(5) ) &
8273 & )
8274
8275 allocate( answer_min( &
8276 & answer_shape(1), &
8277
8278 & answer_shape(2), &
8279
8280 & answer_shape(3), &
8281
8282 & answer_shape(4), &
8283
8284 & answer_shape(5) ) &
8285 & )
8286
8287 answer_negative = answer < 0.0_dp
8288 check_negative = check < 0.0_dp
8289 both_negative = answer_negative .and. check_negative
8290
8291 where (both_negative)
8292 answer_max = &
8293 & answer &
8294 & * ( 1.0_dp &
8295 & - 0.1_dp ** significant_digits ) &
8296 & + 0.1_dp ** (- ignore_digits)
8297
8298 answer_min = &
8299 & answer &
8300 & * ( 1.0_dp &
8301 & + 0.1_dp ** significant_digits ) &
8302 & - 0.1_dp ** (- ignore_digits)
8303 elsewhere
8304 answer_max = &
8305 & answer &
8306 & * ( 1.0_dp &
8307 & + 0.1_dp ** significant_digits ) &
8308 & + 0.1_dp ** (- ignore_digits)
8309
8310 answer_min = &
8311 & answer &
8312 & * ( 1.0_dp &
8313 & - 0.1_dp ** significant_digits ) &
8314 & - 0.1_dp ** (- ignore_digits)
8315 end where
8316
8317 judge = answer_max > check .and. check > answer_min
8318 judge_rev = .not. judge
8319 err_flag = any(judge_rev)
8320 mask_array = 1
8321 pos = maxloc(mask_array, judge_rev)
8322
8323 if (err_flag) then
8324
8325 wrong = check( &
8326 & pos(1), &
8327
8328 & pos(2), &
8329
8330 & pos(3), &
8331
8332 & pos(4), &
8333
8334 & pos(5) )
8335
8336 right_max = answer_max( &
8337 & pos(1), &
8338
8339 & pos(2), &
8340
8341 & pos(3), &
8342
8343 & pos(4), &
8344
8345 & pos(5) )
8346
8347 right_min = answer_min( &
8348 & pos(1), &
8349
8350 & pos(2), &
8351
8352 & pos(3), &
8353
8354 & pos(4), &
8355
8356 & pos(5) )
8357
8358 if ( right_max < right_min ) then
8359 right_tmp = right_max
8360 right_max = right_min
8361 right_min = right_tmp
8362 end if
8363
8364 write(unit=pos_array(1), fmt="(i20)") pos(1)
8365
8366 write(unit=pos_array(2), fmt="(i20)") pos(2)
8367
8368 write(unit=pos_array(3), fmt="(i20)") pos(3)
8369
8370 write(unit=pos_array(4), fmt="(i20)") pos(4)
8371
8372 write(unit=pos_array(5), fmt="(i20)") pos(5)
8373
8374
8375 pos_str = '(' // &
8376 & trim(adjustl(pos_array(1))) // ',' // &
8377
8378 & trim(adjustl(pos_array(2))) // ',' // &
8379
8380 & trim(adjustl(pos_array(3))) // ',' // &
8381
8382 & trim(adjustl(pos_array(4))) // ',' // &
8383
8384 & trim(adjustl(pos_array(5))) // ')'
8385
8386 end if
8387 deallocate(mask_array, judge, judge_rev)
8388 deallocate(answer_negative, check_negative, both_negative)
8389 deallocate(answer_max, answer_min)
8390
8391
8392
8393 if (err_flag) then
8394 pos_str_space = ''
8395 pos_str_len = len_trim(pos_str)
8396
8397 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8398 write(*,*) ''
8399 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
8400 write(*,*) ' is NOT EQUAL to'
8401 write(*,*) ' ' // pos_str_space(1:pos_str_len) &
8402 & // ' ', right_min, ' < '
8403 write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
8404
8405 call abortprogram('')
8406 else
8407 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
8408 end if
8409
8410
8411 end subroutine dctestassertequaldouble5digits
8412
8413
8414 subroutine dctestassertequaldouble6digits( &
8415 & message, answer, check, significant_digits, ignore_digits )
8416 use sysdep, only: abortprogram
8417 use dc_types, only: string, token
8418 implicit none
8419 character(*), intent(in):: message
8420 real(DP), intent(in):: answer(:,:,:,:,:,:)
8421 real(DP), intent(in):: check(:,:,:,:,:,:)
8422 integer, intent(in):: significant_digits
8423 integer, intent(in):: ignore_digits
8424 logical:: err_flag
8425 character(STRING):: pos_str
8426 real(DP):: wrong, right_max, right_min
8427 character(STRING):: pos_str_space
8428 integer:: pos_str_len
8429 real(DP):: right_tmp
8430
8431 integer:: answer_shape(6), check_shape(6), pos(6)
8432 logical:: consist_shape(6)
8433 character(TOKEN):: pos_array(6)
8434 integer, allocatable:: mask_array(:,:,:,:,:,:)
8435 logical, allocatable:: judge(:,:,:,:,:,:)
8436 logical, allocatable:: judge_rev(:,:,:,:,:,:)
8437 logical, allocatable:: answer_negative(:,:,:,:,:,:)
8438 logical, allocatable:: check_negative(:,:,:,:,:,:)
8439 logical, allocatable:: both_negative(:,:,:,:,:,:)
8440 real(DP), allocatable:: answer_max(:,:,:,:,:,:)
8441 real(DP), allocatable:: answer_min(:,:,:,:,:,:)
8442
8443 continue
8444 err_flag = .false.
8445
8446 if ( significant_digits < 1 ) then
8447 write(*,*) ' *** Error [AssertEQ] *** '
8448 write(*,*) ' Specify a number more than 1 to "significant_digits"'
8449 call abortprogram('')
8450 end if
8451
8452 answer_shape = shape(answer)
8453 check_shape = shape(check)
8454
8455 consist_shape = answer_shape == check_shape
8456
8457 if (.not. all(consist_shape)) then
8458 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8459 write(*,*) ''
8460 write(*,*) ' shape of check is (', check_shape, ')'
8461 write(*,*) ' is INCORRECT'
8462 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
8463
8464 call abortprogram('')
8465 end if
8466
8467
8468 allocate( mask_array( &
8469 & answer_shape(1), &
8470
8471 & answer_shape(2), &
8472
8473 & answer_shape(3), &
8474
8475 & answer_shape(4), &
8476
8477 & answer_shape(5), &
8478
8479 & answer_shape(6) ) &
8480 & )
8481
8482 allocate( judge( &
8483 & answer_shape(1), &
8484
8485 & answer_shape(2), &
8486
8487 & answer_shape(3), &
8488
8489 & answer_shape(4), &
8490
8491 & answer_shape(5), &
8492
8493 & answer_shape(6) ) &
8494 & )
8495
8496 allocate( judge_rev( &
8497 & answer_shape(1), &
8498
8499 & answer_shape(2), &
8500
8501 & answer_shape(3), &
8502
8503 & answer_shape(4), &
8504
8505 & answer_shape(5), &
8506
8507 & answer_shape(6) ) &
8508 & )
8509
8510 allocate( answer_negative( &
8511 & answer_shape(1), &
8512
8513 & answer_shape(2), &
8514
8515 & answer_shape(3), &
8516
8517 & answer_shape(4), &
8518
8519 & answer_shape(5), &
8520
8521 & answer_shape(6) ) &
8522 & )
8523
8524 allocate( check_negative( &
8525 & answer_shape(1), &
8526
8527 & answer_shape(2), &
8528
8529 & answer_shape(3), &
8530
8531 & answer_shape(4), &
8532
8533 & answer_shape(5), &
8534
8535 & answer_shape(6) ) &
8536 & )
8537
8538 allocate( both_negative( &
8539 & answer_shape(1), &
8540
8541 & answer_shape(2), &
8542
8543 & answer_shape(3), &
8544
8545 & answer_shape(4), &
8546
8547 & answer_shape(5), &
8548
8549 & answer_shape(6) ) &
8550 & )
8551
8552 allocate( answer_max( &
8553 & answer_shape(1), &
8554
8555 & answer_shape(2), &
8556
8557 & answer_shape(3), &
8558
8559 & answer_shape(4), &
8560
8561 & answer_shape(5), &
8562
8563 & answer_shape(6) ) &
8564 & )
8565
8566 allocate( answer_min( &
8567 & answer_shape(1), &
8568
8569 & answer_shape(2), &
8570
8571 & answer_shape(3), &
8572
8573 & answer_shape(4), &
8574
8575 & answer_shape(5), &
8576
8577 & answer_shape(6) ) &
8578 & )
8579
8580 answer_negative = answer < 0.0_dp
8581 check_negative = check < 0.0_dp
8582 both_negative = answer_negative .and. check_negative
8583
8584 where (both_negative)
8585 answer_max = &
8586 & answer &
8587 & * ( 1.0_dp &
8588 & - 0.1_dp ** significant_digits ) &
8589 & + 0.1_dp ** (- ignore_digits)
8590
8591 answer_min = &
8592 & answer &
8593 & * ( 1.0_dp &
8594 & + 0.1_dp ** significant_digits ) &
8595 & - 0.1_dp ** (- ignore_digits)
8596 elsewhere
8597 answer_max = &
8598 & answer &
8599 & * ( 1.0_dp &
8600 & + 0.1_dp ** significant_digits ) &
8601 & + 0.1_dp ** (- ignore_digits)
8602
8603 answer_min = &
8604 & answer &
8605 & * ( 1.0_dp &
8606 & - 0.1_dp ** significant_digits ) &
8607 & - 0.1_dp ** (- ignore_digits)
8608 end where
8609
8610 judge = answer_max > check .and. check > answer_min
8611 judge_rev = .not. judge
8612 err_flag = any(judge_rev)
8613 mask_array = 1
8614 pos = maxloc(mask_array, judge_rev)
8615
8616 if (err_flag) then
8617
8618 wrong = check( &
8619 & pos(1), &
8620
8621 & pos(2), &
8622
8623 & pos(3), &
8624
8625 & pos(4), &
8626
8627 & pos(5), &
8628
8629 & pos(6) )
8630
8631 right_max = answer_max( &
8632 & pos(1), &
8633
8634 & pos(2), &
8635
8636 & pos(3), &
8637
8638 & pos(4), &
8639
8640 & pos(5), &
8641
8642 & pos(6) )
8643
8644 right_min = answer_min( &
8645 & pos(1), &
8646
8647 & pos(2), &
8648
8649 & pos(3), &
8650
8651 & pos(4), &
8652
8653 & pos(5), &
8654
8655 & pos(6) )
8656
8657 if ( right_max < right_min ) then
8658 right_tmp = right_max
8659 right_max = right_min
8660 right_min = right_tmp
8661 end if
8662
8663 write(unit=pos_array(1), fmt="(i20)") pos(1)
8664
8665 write(unit=pos_array(2), fmt="(i20)") pos(2)
8666
8667 write(unit=pos_array(3), fmt="(i20)") pos(3)
8668
8669 write(unit=pos_array(4), fmt="(i20)") pos(4)
8670
8671 write(unit=pos_array(5), fmt="(i20)") pos(5)
8672
8673 write(unit=pos_array(6), fmt="(i20)") pos(6)
8674
8675
8676 pos_str = '(' // &
8677 & trim(adjustl(pos_array(1))) // ',' // &
8678
8679 & trim(adjustl(pos_array(2))) // ',' // &
8680
8681 & trim(adjustl(pos_array(3))) // ',' // &
8682
8683 & trim(adjustl(pos_array(4))) // ',' // &
8684
8685 & trim(adjustl(pos_array(5))) // ',' // &
8686
8687 & trim(adjustl(pos_array(6))) // ')'
8688
8689 end if
8690 deallocate(mask_array, judge, judge_rev)
8691 deallocate(answer_negative, check_negative, both_negative)
8692 deallocate(answer_max, answer_min)
8693
8694
8695
8696 if (err_flag) then
8697 pos_str_space = ''
8698 pos_str_len = len_trim(pos_str)
8699
8700 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8701 write(*,*) ''
8702 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
8703 write(*,*) ' is NOT EQUAL to'
8704 write(*,*) ' ' // pos_str_space(1:pos_str_len) &
8705 & // ' ', right_min, ' < '
8706 write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
8707
8708 call abortprogram('')
8709 else
8710 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
8711 end if
8712
8713
8714 end subroutine dctestassertequaldouble6digits
8715
8716
8717 subroutine dctestassertequaldouble7digits( &
8718 & message, answer, check, significant_digits, ignore_digits )
8719 use sysdep, only: abortprogram
8720 use dc_types, only: string, token
8721 implicit none
8722 character(*), intent(in):: message
8723 real(DP), intent(in):: answer(:,:,:,:,:,:,:)
8724 real(DP), intent(in):: check(:,:,:,:,:,:,:)
8725 integer, intent(in):: significant_digits
8726 integer, intent(in):: ignore_digits
8727 logical:: err_flag
8728 character(STRING):: pos_str
8729 real(DP):: wrong, right_max, right_min
8730 character(STRING):: pos_str_space
8731 integer:: pos_str_len
8732 real(DP):: right_tmp
8733
8734 integer:: answer_shape(7), check_shape(7), pos(7)
8735 logical:: consist_shape(7)
8736 character(TOKEN):: pos_array(7)
8737 integer, allocatable:: mask_array(:,:,:,:,:,:,:)
8738 logical, allocatable:: judge(:,:,:,:,:,:,:)
8739 logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
8740 logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
8741 logical, allocatable:: check_negative(:,:,:,:,:,:,:)
8742 logical, allocatable:: both_negative(:,:,:,:,:,:,:)
8743 real(DP), allocatable:: answer_max(:,:,:,:,:,:,:)
8744 real(DP), allocatable:: answer_min(:,:,:,:,:,:,:)
8745
8746 continue
8747 err_flag = .false.
8748
8749 if ( significant_digits < 1 ) then
8750 write(*,*) ' *** Error [AssertEQ] *** '
8751 write(*,*) ' Specify a number more than 1 to "significant_digits"'
8752 call abortprogram('')
8753 end if
8754
8755 answer_shape = shape(answer)
8756 check_shape = shape(check)
8757
8758 consist_shape = answer_shape == check_shape
8759
8760 if (.not. all(consist_shape)) then
8761 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8762 write(*,*) ''
8763 write(*,*) ' shape of check is (', check_shape, ')'
8764 write(*,*) ' is INCORRECT'
8765 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
8766
8767 call abortprogram('')
8768 end if
8769
8770
8771 allocate( mask_array( &
8772 & answer_shape(1), &
8773
8774 & answer_shape(2), &
8775
8776 & answer_shape(3), &
8777
8778 & answer_shape(4), &
8779
8780 & answer_shape(5), &
8781
8782 & answer_shape(6), &
8783
8784 & answer_shape(7) ) &
8785 & )
8786
8787 allocate( judge( &
8788 & answer_shape(1), &
8789
8790 & answer_shape(2), &
8791
8792 & answer_shape(3), &
8793
8794 & answer_shape(4), &
8795
8796 & answer_shape(5), &
8797
8798 & answer_shape(6), &
8799
8800 & answer_shape(7) ) &
8801 & )
8802
8803 allocate( judge_rev( &
8804 & answer_shape(1), &
8805
8806 & answer_shape(2), &
8807
8808 & answer_shape(3), &
8809
8810 & answer_shape(4), &
8811
8812 & answer_shape(5), &
8813
8814 & answer_shape(6), &
8815
8816 & answer_shape(7) ) &
8817 & )
8818
8819 allocate( answer_negative( &
8820 & answer_shape(1), &
8821
8822 & answer_shape(2), &
8823
8824 & answer_shape(3), &
8825
8826 & answer_shape(4), &
8827
8828 & answer_shape(5), &
8829
8830 & answer_shape(6), &
8831
8832 & answer_shape(7) ) &
8833 & )
8834
8835 allocate( check_negative( &
8836 & answer_shape(1), &
8837
8838 & answer_shape(2), &
8839
8840 & answer_shape(3), &
8841
8842 & answer_shape(4), &
8843
8844 & answer_shape(5), &
8845
8846 & answer_shape(6), &
8847
8848 & answer_shape(7) ) &
8849 & )
8850
8851 allocate( both_negative( &
8852 & answer_shape(1), &
8853
8854 & answer_shape(2), &
8855
8856 & answer_shape(3), &
8857
8858 & answer_shape(4), &
8859
8860 & answer_shape(5), &
8861
8862 & answer_shape(6), &
8863
8864 & answer_shape(7) ) &
8865 & )
8866
8867 allocate( answer_max( &
8868 & answer_shape(1), &
8869
8870 & answer_shape(2), &
8871
8872 & answer_shape(3), &
8873
8874 & answer_shape(4), &
8875
8876 & answer_shape(5), &
8877
8878 & answer_shape(6), &
8879
8880 & answer_shape(7) ) &
8881 & )
8882
8883 allocate( answer_min( &
8884 & answer_shape(1), &
8885
8886 & answer_shape(2), &
8887
8888 & answer_shape(3), &
8889
8890 & answer_shape(4), &
8891
8892 & answer_shape(5), &
8893
8894 & answer_shape(6), &
8895
8896 & answer_shape(7) ) &
8897 & )
8898
8899 answer_negative = answer < 0.0_dp
8900 check_negative = check < 0.0_dp
8901 both_negative = answer_negative .and. check_negative
8902
8903 where (both_negative)
8904 answer_max = &
8905 & answer &
8906 & * ( 1.0_dp &
8907 & - 0.1_dp ** significant_digits ) &
8908 & + 0.1_dp ** (- ignore_digits)
8909
8910 answer_min = &
8911 & answer &
8912 & * ( 1.0_dp &
8913 & + 0.1_dp ** significant_digits ) &
8914 & - 0.1_dp ** (- ignore_digits)
8915 elsewhere
8916 answer_max = &
8917 & answer &
8918 & * ( 1.0_dp &
8919 & + 0.1_dp ** significant_digits ) &
8920 & + 0.1_dp ** (- ignore_digits)
8921
8922 answer_min = &
8923 & answer &
8924 & * ( 1.0_dp &
8925 & - 0.1_dp ** significant_digits ) &
8926 & - 0.1_dp ** (- ignore_digits)
8927 end where
8928
8929 judge = answer_max > check .and. check > answer_min
8930 judge_rev = .not. judge
8931 err_flag = any(judge_rev)
8932 mask_array = 1
8933 pos = maxloc(mask_array, judge_rev)
8934
8935 if (err_flag) then
8936
8937 wrong = check( &
8938 & pos(1), &
8939
8940 & pos(2), &
8941
8942 & pos(3), &
8943
8944 & pos(4), &
8945
8946 & pos(5), &
8947
8948 & pos(6), &
8949
8950 & pos(7) )
8951
8952 right_max = answer_max( &
8953 & pos(1), &
8954
8955 & pos(2), &
8956
8957 & pos(3), &
8958
8959 & pos(4), &
8960
8961 & pos(5), &
8962
8963 & pos(6), &
8964
8965 & pos(7) )
8966
8967 right_min = answer_min( &
8968 & pos(1), &
8969
8970 & pos(2), &
8971
8972 & pos(3), &
8973
8974 & pos(4), &
8975
8976 & pos(5), &
8977
8978 & pos(6), &
8979
8980 & pos(7) )
8981
8982 if ( right_max < right_min ) then
8983 right_tmp = right_max
8984 right_max = right_min
8985 right_min = right_tmp
8986 end if
8987
8988 write(unit=pos_array(1), fmt="(i20)") pos(1)
8989
8990 write(unit=pos_array(2), fmt="(i20)") pos(2)
8991
8992 write(unit=pos_array(3), fmt="(i20)") pos(3)
8993
8994 write(unit=pos_array(4), fmt="(i20)") pos(4)
8995
8996 write(unit=pos_array(5), fmt="(i20)") pos(5)
8997
8998 write(unit=pos_array(6), fmt="(i20)") pos(6)
8999
9000 write(unit=pos_array(7), fmt="(i20)") pos(7)
9001
9002
9003 pos_str = '(' // &
9004 & trim(adjustl(pos_array(1))) // ',' // &
9005
9006 & trim(adjustl(pos_array(2))) // ',' // &
9007
9008 & trim(adjustl(pos_array(3))) // ',' // &
9009
9010 & trim(adjustl(pos_array(4))) // ',' // &
9011
9012 & trim(adjustl(pos_array(5))) // ',' // &
9013
9014 & trim(adjustl(pos_array(6))) // ',' // &
9015
9016 & trim(adjustl(pos_array(7))) // ')'
9017
9018 end if
9019 deallocate(mask_array, judge, judge_rev)
9020 deallocate(answer_negative, check_negative, both_negative)
9021 deallocate(answer_max, answer_min)
9022
9023
9024
9025 if (err_flag) then
9026 pos_str_space = ''
9027 pos_str_len = len_trim(pos_str)
9028
9029 write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
9030 write(*,*) ''
9031 write(*,*) ' check' // trim(pos_str) // ' = ', wrong
9032 write(*,*) ' is NOT EQUAL to'
9033 write(*,*) ' ' // pos_str_space(1:pos_str_len) &
9034 & // ' ', right_min, ' < '
9035 write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
9036
9037 call abortprogram('')
9038 else
9039 write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
9040 end if
9041
9042
9043 end subroutine dctestassertequaldouble7digits
9044
9045
9046 subroutine dctestassertgreaterthanint0( &
9047 & message, answer, check, negative_support)
9048 use sysdep, only: abortprogram
9049 use dc_types, only: string, token
9050 implicit none
9051 character(*), intent(in):: message
9052 integer, intent(in):: answer
9053 integer, intent(in):: check
9054 logical, intent(in), optional:: negative_support
9055 logical:: err_flag
9056 logical:: negative_support_on
9057 character(STRING):: pos_str
9058 character(TOKEN):: abs_mes
9059 integer:: wrong, right
9060
9061
9062
9063 continue
9064 if (present(negative_support)) then
9065 negative_support_on = negative_support
9066 else
9067 negative_support_on = .true.
9068 end if
9069
9070 err_flag = .false.
9071
9072
9073 err_flag = .not. answer < check
9074 abs_mes = ''
9075
9076 if ( answer < 0 &
9077 & .and. check < 0 &
9078 & .and. negative_support_on ) then
9079
9080 err_flag = .not. err_flag
9081 abs_mes = 'ABSOLUTE value of'
9082 end if
9083
9084 wrong = check
9085 right = answer
9086 pos_str = ''
9087
9088
9089
9090
9091 if (err_flag) then
9092 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9093 write(*,*) ''
9094 write(*,*) ' ' // trim(abs_mes) // &
9095 & ' check' // trim(pos_str) // ' = ', wrong
9096 write(*,*) ' is NOT GREATER THAN'
9097 write(*,*) ' ' // trim(abs_mes) // &
9098 & ' answer' // trim(pos_str) // ' = ', right
9099
9100 call abortprogram('')
9101 else
9102 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
9103 end if
9104
9105
9106 end subroutine dctestassertgreaterthanint0
9107
9108
9109 subroutine dctestassertgreaterthanint1( &
9110 & message, answer, check, negative_support)
9111 use sysdep, only: abortprogram
9112 use dc_types, only: string, token
9113 implicit none
9114 character(*), intent(in):: message
9115 integer, intent(in):: answer(:)
9116 integer, intent(in):: check(:)
9117 logical, intent(in), optional:: negative_support
9118 logical:: err_flag
9119 logical:: negative_support_on
9120 character(STRING):: pos_str
9121 character(TOKEN):: abs_mes
9122 integer:: wrong, right
9123
9124 integer:: answer_shape(1), check_shape(1), pos(1)
9125 logical:: consist_shape(1)
9126 character(TOKEN):: pos_array(1)
9127 integer, allocatable:: mask_array(:)
9128 logical, allocatable:: judge(:)
9129 logical, allocatable:: judge_rev(:)
9130 logical, allocatable:: answer_negative(:)
9131 logical, allocatable:: check_negative(:)
9132 logical, allocatable:: both_negative(:)
9133
9134
9135 continue
9136 if (present(negative_support)) then
9137 negative_support_on = negative_support
9138 else
9139 negative_support_on = .true.
9140 end if
9141
9142 err_flag = .false.
9143
9144
9145 answer_shape = shape(answer)
9146 check_shape = shape(check)
9147
9148 consist_shape = answer_shape == check_shape
9149
9150 if (.not. all(consist_shape)) then
9151 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9152 write(*,*) ''
9153 write(*,*) ' shape of check is (', check_shape, ')'
9154 write(*,*) ' is INCORRECT'
9155 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
9156
9157 call abortprogram('')
9158 end if
9159
9160
9161 allocate( mask_array( &
9162
9163 & answer_shape(1) ) &
9164 & )
9165
9166 allocate( judge( &
9167
9168 & answer_shape(1) ) &
9169 & )
9170
9171 allocate( judge_rev( &
9172
9173 & answer_shape(1) ) &
9174 & )
9175
9176 allocate( answer_negative( &
9177
9178 & answer_shape(1) ) &
9179 & )
9180
9181 allocate( check_negative( &
9182
9183 & answer_shape(1) ) &
9184 & )
9185
9186 allocate( both_negative( &
9187
9188 & answer_shape(1) ) &
9189 & )
9190
9191 answer_negative = answer < 0
9192 check_negative = check < 0
9193 both_negative = answer_negative .and. check_negative
9194 if (.not. negative_support_on) both_negative = .false.
9195
9196 judge = answer < check
9197 where (both_negative) judge = .not. judge
9198
9199 judge_rev = .not. judge
9200 err_flag = any(judge_rev)
9201 mask_array = 1
9202 pos = maxloc(mask_array, judge_rev)
9203
9204 if (err_flag) then
9205
9206 wrong = check( &
9207
9208 & pos(1) )
9209
9210 right = answer( &
9211
9212 & pos(1) )
9213
9214 write(unit=pos_array(1), fmt="(i20)") pos(1)
9215
9216
9217 pos_str = '(' // &
9218
9219 & trim(adjustl(pos_array(1))) // ')'
9220
9221 if ( both_negative( &
9222
9223 & pos(1) ) ) then
9224
9225 abs_mes = 'ABSOLUTE value of'
9226 else
9227 abs_mes = ''
9228
9229 end if
9230
9231 end if
9232 deallocate(mask_array, judge, judge_rev)
9233 deallocate(answer_negative, check_negative, both_negative)
9234
9235
9236
9237
9238 if (err_flag) then
9239 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9240 write(*,*) ''
9241 write(*,*) ' ' // trim(abs_mes) // &
9242 & ' check' // trim(pos_str) // ' = ', wrong
9243 write(*,*) ' is NOT GREATER THAN'
9244 write(*,*) ' ' // trim(abs_mes) // &
9245 & ' answer' // trim(pos_str) // ' = ', right
9246
9247 call abortprogram('')
9248 else
9249 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
9250 end if
9251
9252
9253 end subroutine dctestassertgreaterthanint1
9254
9255
9256 subroutine dctestassertgreaterthanint2( &
9257 & message, answer, check, negative_support)
9258 use sysdep, only: abortprogram
9259 use dc_types, only: string, token
9260 implicit none
9261 character(*), intent(in):: message
9262 integer, intent(in):: answer(:,:)
9263 integer, intent(in):: check(:,:)
9264 logical, intent(in), optional:: negative_support
9265 logical:: err_flag
9266 logical:: negative_support_on
9267 character(STRING):: pos_str
9268 character(TOKEN):: abs_mes
9269 integer:: wrong, right
9270
9271 integer:: answer_shape(2), check_shape(2), pos(2)
9272 logical:: consist_shape(2)
9273 character(TOKEN):: pos_array(2)
9274 integer, allocatable:: mask_array(:,:)
9275 logical, allocatable:: judge(:,:)
9276 logical, allocatable:: judge_rev(:,:)
9277 logical, allocatable:: answer_negative(:,:)
9278 logical, allocatable:: check_negative(:,:)
9279 logical, allocatable:: both_negative(:,:)
9280
9281
9282 continue
9283 if (present(negative_support)) then
9284 negative_support_on = negative_support
9285 else
9286 negative_support_on = .true.
9287 end if
9288
9289 err_flag = .false.
9290
9291
9292 answer_shape = shape(answer)
9293 check_shape = shape(check)
9294
9295 consist_shape = answer_shape == check_shape
9296
9297 if (.not. all(consist_shape)) then
9298 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9299 write(*,*) ''
9300 write(*,*) ' shape of check is (', check_shape, ')'
9301 write(*,*) ' is INCORRECT'
9302 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
9303
9304 call abortprogram('')
9305 end if
9306
9307
9308 allocate( mask_array( &
9309 & answer_shape(1), &
9310
9311 & answer_shape(2) ) &
9312 & )
9313
9314 allocate( judge( &
9315 & answer_shape(1), &
9316
9317 & answer_shape(2) ) &
9318 & )
9319
9320 allocate( judge_rev( &
9321 & answer_shape(1), &
9322
9323 & answer_shape(2) ) &
9324 & )
9325
9326 allocate( answer_negative( &
9327 & answer_shape(1), &
9328
9329 & answer_shape(2) ) &
9330 & )
9331
9332 allocate( check_negative( &
9333 & answer_shape(1), &
9334
9335 & answer_shape(2) ) &
9336 & )
9337
9338 allocate( both_negative( &
9339 & answer_shape(1), &
9340
9341 & answer_shape(2) ) &
9342 & )
9343
9344 answer_negative = answer < 0
9345 check_negative = check < 0
9346 both_negative = answer_negative .and. check_negative
9347 if (.not. negative_support_on) both_negative = .false.
9348
9349 judge = answer < check
9350 where (both_negative) judge = .not. judge
9351
9352 judge_rev = .not. judge
9353 err_flag = any(judge_rev)
9354 mask_array = 1
9355 pos = maxloc(mask_array, judge_rev)
9356
9357 if (err_flag) then
9358
9359 wrong = check( &
9360 & pos(1), &
9361
9362 & pos(2) )
9363
9364 right = answer( &
9365 & pos(1), &
9366
9367 & pos(2) )
9368
9369 write(unit=pos_array(1), fmt="(i20)") pos(1)
9370
9371 write(unit=pos_array(2), fmt="(i20)") pos(2)
9372
9373
9374 pos_str = '(' // &
9375 & trim(adjustl(pos_array(1))) // ',' // &
9376
9377 & trim(adjustl(pos_array(2))) // ')'
9378
9379 if ( both_negative( &
9380 & pos(1), &
9381
9382 & pos(2) ) ) then
9383
9384 abs_mes = 'ABSOLUTE value of'
9385 else
9386 abs_mes = ''
9387
9388 end if
9389
9390 end if
9391 deallocate(mask_array, judge, judge_rev)
9392 deallocate(answer_negative, check_negative, both_negative)
9393
9394
9395
9396
9397 if (err_flag) then
9398 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9399 write(*,*) ''
9400 write(*,*) ' ' // trim(abs_mes) // &
9401 & ' check' // trim(pos_str) // ' = ', wrong
9402 write(*,*) ' is NOT GREATER THAN'
9403 write(*,*) ' ' // trim(abs_mes) // &
9404 & ' answer' // trim(pos_str) // ' = ', right
9405
9406 call abortprogram('')
9407 else
9408 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
9409 end if
9410
9411
9412 end subroutine dctestassertgreaterthanint2
9413
9414
9415 subroutine dctestassertgreaterthanint3( &
9416 & message, answer, check, negative_support)
9417 use sysdep, only: abortprogram
9418 use dc_types, only: string, token
9419 implicit none
9420 character(*), intent(in):: message
9421 integer, intent(in):: answer(:,:,:)
9422 integer, intent(in):: check(:,:,:)
9423 logical, intent(in), optional:: negative_support
9424 logical:: err_flag
9425 logical:: negative_support_on
9426 character(STRING):: pos_str
9427 character(TOKEN):: abs_mes
9428 integer:: wrong, right
9429
9430 integer:: answer_shape(3), check_shape(3), pos(3)
9431 logical:: consist_shape(3)
9432 character(TOKEN):: pos_array(3)
9433 integer, allocatable:: mask_array(:,:,:)
9434 logical, allocatable:: judge(:,:,:)
9435 logical, allocatable:: judge_rev(:,:,:)
9436 logical, allocatable:: answer_negative(:,:,:)
9437 logical, allocatable:: check_negative(:,:,:)
9438 logical, allocatable:: both_negative(:,:,:)
9439
9440
9441 continue
9442 if (present(negative_support)) then
9443 negative_support_on = negative_support
9444 else
9445 negative_support_on = .true.
9446 end if
9447
9448 err_flag = .false.
9449
9450
9451 answer_shape = shape(answer)
9452 check_shape = shape(check)
9453
9454 consist_shape = answer_shape == check_shape
9455
9456 if (.not. all(consist_shape)) then
9457 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9458 write(*,*) ''
9459 write(*,*) ' shape of check is (', check_shape, ')'
9460 write(*,*) ' is INCORRECT'
9461 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
9462
9463 call abortprogram('')
9464 end if
9465
9466
9467 allocate( mask_array( &
9468 & answer_shape(1), &
9469
9470 & answer_shape(2), &
9471
9472 & answer_shape(3) ) &
9473 & )
9474
9475 allocate( judge( &
9476 & answer_shape(1), &
9477
9478 & answer_shape(2), &
9479
9480 & answer_shape(3) ) &
9481 & )
9482
9483 allocate( judge_rev( &
9484 & answer_shape(1), &
9485
9486 & answer_shape(2), &
9487
9488 & answer_shape(3) ) &
9489 & )
9490
9491 allocate( answer_negative( &
9492 & answer_shape(1), &
9493
9494 & answer_shape(2), &
9495
9496 & answer_shape(3) ) &
9497 & )
9498
9499 allocate( check_negative( &
9500 & answer_shape(1), &
9501
9502 & answer_shape(2), &
9503
9504 & answer_shape(3) ) &
9505 & )
9506
9507 allocate( both_negative( &
9508 & answer_shape(1), &
9509
9510 & answer_shape(2), &
9511
9512 & answer_shape(3) ) &
9513 & )
9514
9515 answer_negative = answer < 0
9516 check_negative = check < 0
9517 both_negative = answer_negative .and. check_negative
9518 if (.not. negative_support_on) both_negative = .false.
9519
9520 judge = answer < check
9521 where (both_negative) judge = .not. judge
9522
9523 judge_rev = .not. judge
9524 err_flag = any(judge_rev)
9525 mask_array = 1
9526 pos = maxloc(mask_array, judge_rev)
9527
9528 if (err_flag) then
9529
9530 wrong = check( &
9531 & pos(1), &
9532
9533 & pos(2), &
9534
9535 & pos(3) )
9536
9537 right = answer( &
9538 & pos(1), &
9539
9540 & pos(2), &
9541
9542 & pos(3) )
9543
9544 write(unit=pos_array(1), fmt="(i20)") pos(1)
9545
9546 write(unit=pos_array(2), fmt="(i20)") pos(2)
9547
9548 write(unit=pos_array(3), fmt="(i20)") pos(3)
9549
9550
9551 pos_str = '(' // &
9552 & trim(adjustl(pos_array(1))) // ',' // &
9553
9554 & trim(adjustl(pos_array(2))) // ',' // &
9555
9556 & trim(adjustl(pos_array(3))) // ')'
9557
9558 if ( both_negative( &
9559 & pos(1), &
9560
9561 & pos(2), &
9562
9563 & pos(3) ) ) then
9564
9565 abs_mes = 'ABSOLUTE value of'
9566 else
9567 abs_mes = ''
9568
9569 end if
9570
9571 end if
9572 deallocate(mask_array, judge, judge_rev)
9573 deallocate(answer_negative, check_negative, both_negative)
9574
9575
9576
9577
9578 if (err_flag) then
9579 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9580 write(*,*) ''
9581 write(*,*) ' ' // trim(abs_mes) // &
9582 & ' check' // trim(pos_str) // ' = ', wrong
9583 write(*,*) ' is NOT GREATER THAN'
9584 write(*,*) ' ' // trim(abs_mes) // &
9585 & ' answer' // trim(pos_str) // ' = ', right
9586
9587 call abortprogram('')
9588 else
9589 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
9590 end if
9591
9592
9593 end subroutine dctestassertgreaterthanint3
9594
9595
9596 subroutine dctestassertgreaterthanint4( &
9597 & message, answer, check, negative_support)
9598 use sysdep, only: abortprogram
9599 use dc_types, only: string, token
9600 implicit none
9601 character(*), intent(in):: message
9602 integer, intent(in):: answer(:,:,:,:)
9603 integer, intent(in):: check(:,:,:,:)
9604 logical, intent(in), optional:: negative_support
9605 logical:: err_flag
9606 logical:: negative_support_on
9607 character(STRING):: pos_str
9608 character(TOKEN):: abs_mes
9609 integer:: wrong, right
9610
9611 integer:: answer_shape(4), check_shape(4), pos(4)
9612 logical:: consist_shape(4)
9613 character(TOKEN):: pos_array(4)
9614 integer, allocatable:: mask_array(:,:,:,:)
9615 logical, allocatable:: judge(:,:,:,:)
9616 logical, allocatable:: judge_rev(:,:,:,:)
9617 logical, allocatable:: answer_negative(:,:,:,:)
9618 logical, allocatable:: check_negative(:,:,:,:)
9619 logical, allocatable:: both_negative(:,:,:,:)
9620
9621
9622 continue
9623 if (present(negative_support)) then
9624 negative_support_on = negative_support
9625 else
9626 negative_support_on = .true.
9627 end if
9628
9629 err_flag = .false.
9630
9631
9632 answer_shape = shape(answer)
9633 check_shape = shape(check)
9634
9635 consist_shape = answer_shape == check_shape
9636
9637 if (.not. all(consist_shape)) then
9638 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9639 write(*,*) ''
9640 write(*,*) ' shape of check is (', check_shape, ')'
9641 write(*,*) ' is INCORRECT'
9642 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
9643
9644 call abortprogram('')
9645 end if
9646
9647
9648 allocate( mask_array( &
9649 & answer_shape(1), &
9650
9651 & answer_shape(2), &
9652
9653 & answer_shape(3), &
9654
9655 & answer_shape(4) ) &
9656 & )
9657
9658 allocate( judge( &
9659 & answer_shape(1), &
9660
9661 & answer_shape(2), &
9662
9663 & answer_shape(3), &
9664
9665 & answer_shape(4) ) &
9666 & )
9667
9668 allocate( judge_rev( &
9669 & answer_shape(1), &
9670
9671 & answer_shape(2), &
9672
9673 & answer_shape(3), &
9674
9675 & answer_shape(4) ) &
9676 & )
9677
9678 allocate( answer_negative( &
9679 & answer_shape(1), &
9680
9681 & answer_shape(2), &
9682
9683 & answer_shape(3), &
9684
9685 & answer_shape(4) ) &
9686 & )
9687
9688 allocate( check_negative( &
9689 & answer_shape(1), &
9690
9691 & answer_shape(2), &
9692
9693 & answer_shape(3), &
9694
9695 & answer_shape(4) ) &
9696 & )
9697
9698 allocate( both_negative( &
9699 & answer_shape(1), &
9700
9701 & answer_shape(2), &
9702
9703 & answer_shape(3), &
9704
9705 & answer_shape(4) ) &
9706 & )
9707
9708 answer_negative = answer < 0
9709 check_negative = check < 0
9710 both_negative = answer_negative .and. check_negative
9711 if (.not. negative_support_on) both_negative = .false.
9712
9713 judge = answer < check
9714 where (both_negative) judge = .not. judge
9715
9716 judge_rev = .not. judge
9717 err_flag = any(judge_rev)
9718 mask_array = 1
9719 pos = maxloc(mask_array, judge_rev)
9720
9721 if (err_flag) then
9722
9723 wrong = check( &
9724 & pos(1), &
9725
9726 & pos(2), &
9727
9728 & pos(3), &
9729
9730 & pos(4) )
9731
9732 right = answer( &
9733 & pos(1), &
9734
9735 & pos(2), &
9736
9737 & pos(3), &
9738
9739 & pos(4) )
9740
9741 write(unit=pos_array(1), fmt="(i20)") pos(1)
9742
9743 write(unit=pos_array(2), fmt="(i20)") pos(2)
9744
9745 write(unit=pos_array(3), fmt="(i20)") pos(3)
9746
9747 write(unit=pos_array(4), fmt="(i20)") pos(4)
9748
9749
9750 pos_str = '(' // &
9751 & trim(adjustl(pos_array(1))) // ',' // &
9752
9753 & trim(adjustl(pos_array(2))) // ',' // &
9754
9755 & trim(adjustl(pos_array(3))) // ',' // &
9756
9757 & trim(adjustl(pos_array(4))) // ')'
9758
9759 if ( both_negative( &
9760 & pos(1), &
9761
9762 & pos(2), &
9763
9764 & pos(3), &
9765
9766 & pos(4) ) ) then
9767
9768 abs_mes = 'ABSOLUTE value of'
9769 else
9770 abs_mes = ''
9771
9772 end if
9773
9774 end if
9775 deallocate(mask_array, judge, judge_rev)
9776 deallocate(answer_negative, check_negative, both_negative)
9777
9778
9779
9780
9781 if (err_flag) then
9782 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9783 write(*,*) ''
9784 write(*,*) ' ' // trim(abs_mes) // &
9785 & ' check' // trim(pos_str) // ' = ', wrong
9786 write(*,*) ' is NOT GREATER THAN'
9787 write(*,*) ' ' // trim(abs_mes) // &
9788 & ' answer' // trim(pos_str) // ' = ', right
9789
9790 call abortprogram('')
9791 else
9792 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
9793 end if
9794
9795
9796 end subroutine dctestassertgreaterthanint4
9797
9798
9799 subroutine dctestassertgreaterthanint5( &
9800 & message, answer, check, negative_support)
9801 use sysdep, only: abortprogram
9802 use dc_types, only: string, token
9803 implicit none
9804 character(*), intent(in):: message
9805 integer, intent(in):: answer(:,:,:,:,:)
9806 integer, intent(in):: check(:,:,:,:,:)
9807 logical, intent(in), optional:: negative_support
9808 logical:: err_flag
9809 logical:: negative_support_on
9810 character(STRING):: pos_str
9811 character(TOKEN):: abs_mes
9812 integer:: wrong, right
9813
9814 integer:: answer_shape(5), check_shape(5), pos(5)
9815 logical:: consist_shape(5)
9816 character(TOKEN):: pos_array(5)
9817 integer, allocatable:: mask_array(:,:,:,:,:)
9818 logical, allocatable:: judge(:,:,:,:,:)
9819 logical, allocatable:: judge_rev(:,:,:,:,:)
9820 logical, allocatable:: answer_negative(:,:,:,:,:)
9821 logical, allocatable:: check_negative(:,:,:,:,:)
9822 logical, allocatable:: both_negative(:,:,:,:,:)
9823
9824
9825 continue
9826 if (present(negative_support)) then
9827 negative_support_on = negative_support
9828 else
9829 negative_support_on = .true.
9830 end if
9831
9832 err_flag = .false.
9833
9834
9835 answer_shape = shape(answer)
9836 check_shape = shape(check)
9837
9838 consist_shape = answer_shape == check_shape
9839
9840 if (.not. all(consist_shape)) then
9841 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9842 write(*,*) ''
9843 write(*,*) ' shape of check is (', check_shape, ')'
9844 write(*,*) ' is INCORRECT'
9845 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
9846
9847 call abortprogram('')
9848 end if
9849
9850
9851 allocate( mask_array( &
9852 & answer_shape(1), &
9853
9854 & answer_shape(2), &
9855
9856 & answer_shape(3), &
9857
9858 & answer_shape(4), &
9859
9860 & answer_shape(5) ) &
9861 & )
9862
9863 allocate( judge( &
9864 & answer_shape(1), &
9865
9866 & answer_shape(2), &
9867
9868 & answer_shape(3), &
9869
9870 & answer_shape(4), &
9871
9872 & answer_shape(5) ) &
9873 & )
9874
9875 allocate( judge_rev( &
9876 & answer_shape(1), &
9877
9878 & answer_shape(2), &
9879
9880 & answer_shape(3), &
9881
9882 & answer_shape(4), &
9883
9884 & answer_shape(5) ) &
9885 & )
9886
9887 allocate( answer_negative( &
9888 & answer_shape(1), &
9889
9890 & answer_shape(2), &
9891
9892 & answer_shape(3), &
9893
9894 & answer_shape(4), &
9895
9896 & answer_shape(5) ) &
9897 & )
9898
9899 allocate( check_negative( &
9900 & answer_shape(1), &
9901
9902 & answer_shape(2), &
9903
9904 & answer_shape(3), &
9905
9906 & answer_shape(4), &
9907
9908 & answer_shape(5) ) &
9909 & )
9910
9911 allocate( both_negative( &
9912 & answer_shape(1), &
9913
9914 & answer_shape(2), &
9915
9916 & answer_shape(3), &
9917
9918 & answer_shape(4), &
9919
9920 & answer_shape(5) ) &
9921 & )
9922
9923 answer_negative = answer < 0
9924 check_negative = check < 0
9925 both_negative = answer_negative .and. check_negative
9926 if (.not. negative_support_on) both_negative = .false.
9927
9928 judge = answer < check
9929 where (both_negative) judge = .not. judge
9930
9931 judge_rev = .not. judge
9932 err_flag = any(judge_rev)
9933 mask_array = 1
9934 pos = maxloc(mask_array, judge_rev)
9935
9936 if (err_flag) then
9937
9938 wrong = check( &
9939 & pos(1), &
9940
9941 & pos(2), &
9942
9943 & pos(3), &
9944
9945 & pos(4), &
9946
9947 & pos(5) )
9948
9949 right = answer( &
9950 & pos(1), &
9951
9952 & pos(2), &
9953
9954 & pos(3), &
9955
9956 & pos(4), &
9957
9958 & pos(5) )
9959
9960 write(unit=pos_array(1), fmt="(i20)") pos(1)
9961
9962 write(unit=pos_array(2), fmt="(i20)") pos(2)
9963
9964 write(unit=pos_array(3), fmt="(i20)") pos(3)
9965
9966 write(unit=pos_array(4), fmt="(i20)") pos(4)
9967
9968 write(unit=pos_array(5), fmt="(i20)") pos(5)
9969
9970
9971 pos_str = '(' // &
9972 & trim(adjustl(pos_array(1))) // ',' // &
9973
9974 & trim(adjustl(pos_array(2))) // ',' // &
9975
9976 & trim(adjustl(pos_array(3))) // ',' // &
9977
9978 & trim(adjustl(pos_array(4))) // ',' // &
9979
9980 & trim(adjustl(pos_array(5))) // ')'
9981
9982 if ( both_negative( &
9983 & pos(1), &
9984
9985 & pos(2), &
9986
9987 & pos(3), &
9988
9989 & pos(4), &
9990
9991 & pos(5) ) ) then
9992
9993 abs_mes = 'ABSOLUTE value of'
9994 else
9995 abs_mes = ''
9996
9997 end if
9998
9999 end if
10000 deallocate(mask_array, judge, judge_rev)
10001 deallocate(answer_negative, check_negative, both_negative)
10002
10003
10004
10005
10006 if (err_flag) then
10007 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10008 write(*,*) ''
10009 write(*,*) ' ' // trim(abs_mes) // &
10010 & ' check' // trim(pos_str) // ' = ', wrong
10011 write(*,*) ' is NOT GREATER THAN'
10012 write(*,*) ' ' // trim(abs_mes) // &
10013 & ' answer' // trim(pos_str) // ' = ', right
10014
10015 call abortprogram('')
10016 else
10017 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
10018 end if
10019
10020
10021 end subroutine dctestassertgreaterthanint5
10022
10023
10024 subroutine dctestassertgreaterthanint6( &
10025 & message, answer, check, negative_support)
10026 use sysdep, only: abortprogram
10027 use dc_types, only: string, token
10028 implicit none
10029 character(*), intent(in):: message
10030 integer, intent(in):: answer(:,:,:,:,:,:)
10031 integer, intent(in):: check(:,:,:,:,:,:)
10032 logical, intent(in), optional:: negative_support
10033 logical:: err_flag
10034 logical:: negative_support_on
10035 character(STRING):: pos_str
10036 character(TOKEN):: abs_mes
10037 integer:: wrong, right
10038
10039 integer:: answer_shape(6), check_shape(6), pos(6)
10040 logical:: consist_shape(6)
10041 character(TOKEN):: pos_array(6)
10042 integer, allocatable:: mask_array(:,:,:,:,:,:)
10043 logical, allocatable:: judge(:,:,:,:,:,:)
10044 logical, allocatable:: judge_rev(:,:,:,:,:,:)
10045 logical, allocatable:: answer_negative(:,:,:,:,:,:)
10046 logical, allocatable:: check_negative(:,:,:,:,:,:)
10047 logical, allocatable:: both_negative(:,:,:,:,:,:)
10048
10049
10050 continue
10051 if (present(negative_support)) then
10052 negative_support_on = negative_support
10053 else
10054 negative_support_on = .true.
10055 end if
10056
10057 err_flag = .false.
10058
10059
10060 answer_shape = shape(answer)
10061 check_shape = shape(check)
10062
10063 consist_shape = answer_shape == check_shape
10064
10065 if (.not. all(consist_shape)) then
10066 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10067 write(*,*) ''
10068 write(*,*) ' shape of check is (', check_shape, ')'
10069 write(*,*) ' is INCORRECT'
10070 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
10071
10072 call abortprogram('')
10073 end if
10074
10075
10076 allocate( mask_array( &
10077 & answer_shape(1), &
10078
10079 & answer_shape(2), &
10080
10081 & answer_shape(3), &
10082
10083 & answer_shape(4), &
10084
10085 & answer_shape(5), &
10086
10087 & answer_shape(6) ) &
10088 & )
10089
10090 allocate( judge( &
10091 & answer_shape(1), &
10092
10093 & answer_shape(2), &
10094
10095 & answer_shape(3), &
10096
10097 & answer_shape(4), &
10098
10099 & answer_shape(5), &
10100
10101 & answer_shape(6) ) &
10102 & )
10103
10104 allocate( judge_rev( &
10105 & answer_shape(1), &
10106
10107 & answer_shape(2), &
10108
10109 & answer_shape(3), &
10110
10111 & answer_shape(4), &
10112
10113 & answer_shape(5), &
10114
10115 & answer_shape(6) ) &
10116 & )
10117
10118 allocate( answer_negative( &
10119 & answer_shape(1), &
10120
10121 & answer_shape(2), &
10122
10123 & answer_shape(3), &
10124
10125 & answer_shape(4), &
10126
10127 & answer_shape(5), &
10128
10129 & answer_shape(6) ) &
10130 & )
10131
10132 allocate( check_negative( &
10133 & answer_shape(1), &
10134
10135 & answer_shape(2), &
10136
10137 & answer_shape(3), &
10138
10139 & answer_shape(4), &
10140
10141 & answer_shape(5), &
10142
10143 & answer_shape(6) ) &
10144 & )
10145
10146 allocate( both_negative( &
10147 & answer_shape(1), &
10148
10149 & answer_shape(2), &
10150
10151 & answer_shape(3), &
10152
10153 & answer_shape(4), &
10154
10155 & answer_shape(5), &
10156
10157 & answer_shape(6) ) &
10158 & )
10159
10160 answer_negative = answer < 0
10161 check_negative = check < 0
10162 both_negative = answer_negative .and. check_negative
10163 if (.not. negative_support_on) both_negative = .false.
10164
10165 judge = answer < check
10166 where (both_negative) judge = .not. judge
10167
10168 judge_rev = .not. judge
10169 err_flag = any(judge_rev)
10170 mask_array = 1
10171 pos = maxloc(mask_array, judge_rev)
10172
10173 if (err_flag) then
10174
10175 wrong = check( &
10176 & pos(1), &
10177
10178 & pos(2), &
10179
10180 & pos(3), &
10181
10182 & pos(4), &
10183
10184 & pos(5), &
10185
10186 & pos(6) )
10187
10188 right = answer( &
10189 & pos(1), &
10190
10191 & pos(2), &
10192
10193 & pos(3), &
10194
10195 & pos(4), &
10196
10197 & pos(5), &
10198
10199 & pos(6) )
10200
10201 write(unit=pos_array(1), fmt="(i20)") pos(1)
10202
10203 write(unit=pos_array(2), fmt="(i20)") pos(2)
10204
10205 write(unit=pos_array(3), fmt="(i20)") pos(3)
10206
10207 write(unit=pos_array(4), fmt="(i20)") pos(4)
10208
10209 write(unit=pos_array(5), fmt="(i20)") pos(5)
10210
10211 write(unit=pos_array(6), fmt="(i20)") pos(6)
10212
10213
10214 pos_str = '(' // &
10215 & trim(adjustl(pos_array(1))) // ',' // &
10216
10217 & trim(adjustl(pos_array(2))) // ',' // &
10218
10219 & trim(adjustl(pos_array(3))) // ',' // &
10220
10221 & trim(adjustl(pos_array(4))) // ',' // &
10222
10223 & trim(adjustl(pos_array(5))) // ',' // &
10224
10225 & trim(adjustl(pos_array(6))) // ')'
10226
10227 if ( both_negative( &
10228 & pos(1), &
10229
10230 & pos(2), &
10231
10232 & pos(3), &
10233
10234 & pos(4), &
10235
10236 & pos(5), &
10237
10238 & pos(6) ) ) then
10239
10240 abs_mes = 'ABSOLUTE value of'
10241 else
10242 abs_mes = ''
10243
10244 end if
10245
10246 end if
10247 deallocate(mask_array, judge, judge_rev)
10248 deallocate(answer_negative, check_negative, both_negative)
10249
10250
10251
10252
10253 if (err_flag) then
10254 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10255 write(*,*) ''
10256 write(*,*) ' ' // trim(abs_mes) // &
10257 & ' check' // trim(pos_str) // ' = ', wrong
10258 write(*,*) ' is NOT GREATER THAN'
10259 write(*,*) ' ' // trim(abs_mes) // &
10260 & ' answer' // trim(pos_str) // ' = ', right
10261
10262 call abortprogram('')
10263 else
10264 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
10265 end if
10266
10267
10268 end subroutine dctestassertgreaterthanint6
10269
10270
10271 subroutine dctestassertgreaterthanint7( &
10272 & message, answer, check, negative_support)
10273 use sysdep, only: abortprogram
10274 use dc_types, only: string, token
10275 implicit none
10276 character(*), intent(in):: message
10277 integer, intent(in):: answer(:,:,:,:,:,:,:)
10278 integer, intent(in):: check(:,:,:,:,:,:,:)
10279 logical, intent(in), optional:: negative_support
10280 logical:: err_flag
10281 logical:: negative_support_on
10282 character(STRING):: pos_str
10283 character(TOKEN):: abs_mes
10284 integer:: wrong, right
10285
10286 integer:: answer_shape(7), check_shape(7), pos(7)
10287 logical:: consist_shape(7)
10288 character(TOKEN):: pos_array(7)
10289 integer, allocatable:: mask_array(:,:,:,:,:,:,:)
10290 logical, allocatable:: judge(:,:,:,:,:,:,:)
10291 logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
10292 logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
10293 logical, allocatable:: check_negative(:,:,:,:,:,:,:)
10294 logical, allocatable:: both_negative(:,:,:,:,:,:,:)
10295
10296
10297 continue
10298 if (present(negative_support)) then
10299 negative_support_on = negative_support
10300 else
10301 negative_support_on = .true.
10302 end if
10303
10304 err_flag = .false.
10305
10306
10307 answer_shape = shape(answer)
10308 check_shape = shape(check)
10309
10310 consist_shape = answer_shape == check_shape
10311
10312 if (.not. all(consist_shape)) then
10313 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10314 write(*,*) ''
10315 write(*,*) ' shape of check is (', check_shape, ')'
10316 write(*,*) ' is INCORRECT'
10317 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
10318
10319 call abortprogram('')
10320 end if
10321
10322
10323 allocate( mask_array( &
10324 & answer_shape(1), &
10325
10326 & answer_shape(2), &
10327
10328 & answer_shape(3), &
10329
10330 & answer_shape(4), &
10331
10332 & answer_shape(5), &
10333
10334 & answer_shape(6), &
10335
10336 & answer_shape(7) ) &
10337 & )
10338
10339 allocate( judge( &
10340 & answer_shape(1), &
10341
10342 & answer_shape(2), &
10343
10344 & answer_shape(3), &
10345
10346 & answer_shape(4), &
10347
10348 & answer_shape(5), &
10349
10350 & answer_shape(6), &
10351
10352 & answer_shape(7) ) &
10353 & )
10354
10355 allocate( judge_rev( &
10356 & answer_shape(1), &
10357
10358 & answer_shape(2), &
10359
10360 & answer_shape(3), &
10361
10362 & answer_shape(4), &
10363
10364 & answer_shape(5), &
10365
10366 & answer_shape(6), &
10367
10368 & answer_shape(7) ) &
10369 & )
10370
10371 allocate( answer_negative( &
10372 & answer_shape(1), &
10373
10374 & answer_shape(2), &
10375
10376 & answer_shape(3), &
10377
10378 & answer_shape(4), &
10379
10380 & answer_shape(5), &
10381
10382 & answer_shape(6), &
10383
10384 & answer_shape(7) ) &
10385 & )
10386
10387 allocate( check_negative( &
10388 & answer_shape(1), &
10389
10390 & answer_shape(2), &
10391
10392 & answer_shape(3), &
10393
10394 & answer_shape(4), &
10395
10396 & answer_shape(5), &
10397
10398 & answer_shape(6), &
10399
10400 & answer_shape(7) ) &
10401 & )
10402
10403 allocate( both_negative( &
10404 & answer_shape(1), &
10405
10406 & answer_shape(2), &
10407
10408 & answer_shape(3), &
10409
10410 & answer_shape(4), &
10411
10412 & answer_shape(5), &
10413
10414 & answer_shape(6), &
10415
10416 & answer_shape(7) ) &
10417 & )
10418
10419 answer_negative = answer < 0
10420 check_negative = check < 0
10421 both_negative = answer_negative .and. check_negative
10422 if (.not. negative_support_on) both_negative = .false.
10423
10424 judge = answer < check
10425 where (both_negative) judge = .not. judge
10426
10427 judge_rev = .not. judge
10428 err_flag = any(judge_rev)
10429 mask_array = 1
10430 pos = maxloc(mask_array, judge_rev)
10431
10432 if (err_flag) then
10433
10434 wrong = check( &
10435 & pos(1), &
10436
10437 & pos(2), &
10438
10439 & pos(3), &
10440
10441 & pos(4), &
10442
10443 & pos(5), &
10444
10445 & pos(6), &
10446
10447 & pos(7) )
10448
10449 right = answer( &
10450 & pos(1), &
10451
10452 & pos(2), &
10453
10454 & pos(3), &
10455
10456 & pos(4), &
10457
10458 & pos(5), &
10459
10460 & pos(6), &
10461
10462 & pos(7) )
10463
10464 write(unit=pos_array(1), fmt="(i20)") pos(1)
10465
10466 write(unit=pos_array(2), fmt="(i20)") pos(2)
10467
10468 write(unit=pos_array(3), fmt="(i20)") pos(3)
10469
10470 write(unit=pos_array(4), fmt="(i20)") pos(4)
10471
10472 write(unit=pos_array(5), fmt="(i20)") pos(5)
10473
10474 write(unit=pos_array(6), fmt="(i20)") pos(6)
10475
10476 write(unit=pos_array(7), fmt="(i20)") pos(7)
10477
10478
10479 pos_str = '(' // &
10480 & trim(adjustl(pos_array(1))) // ',' // &
10481
10482 & trim(adjustl(pos_array(2))) // ',' // &
10483
10484 & trim(adjustl(pos_array(3))) // ',' // &
10485
10486 & trim(adjustl(pos_array(4))) // ',' // &
10487
10488 & trim(adjustl(pos_array(5))) // ',' // &
10489
10490 & trim(adjustl(pos_array(6))) // ',' // &
10491
10492 & trim(adjustl(pos_array(7))) // ')'
10493
10494 if ( both_negative( &
10495 & pos(1), &
10496
10497 & pos(2), &
10498
10499 & pos(3), &
10500
10501 & pos(4), &
10502
10503 & pos(5), &
10504
10505 & pos(6), &
10506
10507 & pos(7) ) ) then
10508
10509 abs_mes = 'ABSOLUTE value of'
10510 else
10511 abs_mes = ''
10512
10513 end if
10514
10515 end if
10516 deallocate(mask_array, judge, judge_rev)
10517 deallocate(answer_negative, check_negative, both_negative)
10518
10519
10520
10521
10522 if (err_flag) then
10523 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10524 write(*,*) ''
10525 write(*,*) ' ' // trim(abs_mes) // &
10526 & ' check' // trim(pos_str) // ' = ', wrong
10527 write(*,*) ' is NOT GREATER THAN'
10528 write(*,*) ' ' // trim(abs_mes) // &
10529 & ' answer' // trim(pos_str) // ' = ', right
10530
10531 call abortprogram('')
10532 else
10533 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
10534 end if
10535
10536
10537 end subroutine dctestassertgreaterthanint7
10538
10539
10540 subroutine dctestassertgreaterthanreal0( &
10541 & message, answer, check, negative_support)
10542 use sysdep, only: abortprogram
10543 use dc_types, only: string, token
10544 implicit none
10545 character(*), intent(in):: message
10546 real, intent(in):: answer
10547 real, intent(in):: check
10548 logical, intent(in), optional:: negative_support
10549 logical:: err_flag
10550 logical:: negative_support_on
10551 character(STRING):: pos_str
10552 character(TOKEN):: abs_mes
10553 real:: wrong, right
10554
10555
10556
10557 continue
10558 if (present(negative_support)) then
10559 negative_support_on = negative_support
10560 else
10561 negative_support_on = .true.
10562 end if
10563
10564 err_flag = .false.
10565
10566
10567 err_flag = .not. answer < check
10568 abs_mes = ''
10569
10570 if ( answer < 0.0 &
10571 & .and. check < 0.0 &
10572 & .and. negative_support_on ) then
10573
10574 err_flag = .not. err_flag
10575 abs_mes = 'ABSOLUTE value of'
10576 end if
10577
10578 wrong = check
10579 right = answer
10580 pos_str = ''
10581
10582
10583
10584
10585 if (err_flag) then
10586 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10587 write(*,*) ''
10588 write(*,*) ' ' // trim(abs_mes) // &
10589 & ' check' // trim(pos_str) // ' = ', wrong
10590 write(*,*) ' is NOT GREATER THAN'
10591 write(*,*) ' ' // trim(abs_mes) // &
10592 & ' answer' // trim(pos_str) // ' = ', right
10593
10594 call abortprogram('')
10595 else
10596 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
10597 end if
10598
10599
10600 end subroutine dctestassertgreaterthanreal0
10601
10602
10603 subroutine dctestassertgreaterthanreal1( &
10604 & message, answer, check, negative_support)
10605 use sysdep, only: abortprogram
10606 use dc_types, only: string, token
10607 implicit none
10608 character(*), intent(in):: message
10609 real, intent(in):: answer(:)
10610 real, intent(in):: check(:)
10611 logical, intent(in), optional:: negative_support
10612 logical:: err_flag
10613 logical:: negative_support_on
10614 character(STRING):: pos_str
10615 character(TOKEN):: abs_mes
10616 real:: wrong, right
10617
10618 integer:: answer_shape(1), check_shape(1), pos(1)
10619 logical:: consist_shape(1)
10620 character(TOKEN):: pos_array(1)
10621 integer, allocatable:: mask_array(:)
10622 logical, allocatable:: judge(:)
10623 logical, allocatable:: judge_rev(:)
10624 logical, allocatable:: answer_negative(:)
10625 logical, allocatable:: check_negative(:)
10626 logical, allocatable:: both_negative(:)
10627
10628
10629 continue
10630 if (present(negative_support)) then
10631 negative_support_on = negative_support
10632 else
10633 negative_support_on = .true.
10634 end if
10635
10636 err_flag = .false.
10637
10638
10639 answer_shape = shape(answer)
10640 check_shape = shape(check)
10641
10642 consist_shape = answer_shape == check_shape
10643
10644 if (.not. all(consist_shape)) then
10645 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10646 write(*,*) ''
10647 write(*,*) ' shape of check is (', check_shape, ')'
10648 write(*,*) ' is INCORRECT'
10649 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
10650
10651 call abortprogram('')
10652 end if
10653
10654
10655 allocate( mask_array( &
10656
10657 & answer_shape(1) ) &
10658 & )
10659
10660 allocate( judge( &
10661
10662 & answer_shape(1) ) &
10663 & )
10664
10665 allocate( judge_rev( &
10666
10667 & answer_shape(1) ) &
10668 & )
10669
10670 allocate( answer_negative( &
10671
10672 & answer_shape(1) ) &
10673 & )
10674
10675 allocate( check_negative( &
10676
10677 & answer_shape(1) ) &
10678 & )
10679
10680 allocate( both_negative( &
10681
10682 & answer_shape(1) ) &
10683 & )
10684
10685 answer_negative = answer < 0.0
10686 check_negative = check < 0.0
10687 both_negative = answer_negative .and. check_negative
10688 if (.not. negative_support_on) both_negative = .false.
10689
10690 judge = answer < check
10691 where (both_negative) judge = .not. judge
10692
10693 judge_rev = .not. judge
10694 err_flag = any(judge_rev)
10695 mask_array = 1
10696 pos = maxloc(mask_array, judge_rev)
10697
10698 if (err_flag) then
10699
10700 wrong = check( &
10701
10702 & pos(1) )
10703
10704 right = answer( &
10705
10706 & pos(1) )
10707
10708 write(unit=pos_array(1), fmt="(i20)") pos(1)
10709
10710
10711 pos_str = '(' // &
10712
10713 & trim(adjustl(pos_array(1))) // ')'
10714
10715 if ( both_negative( &
10716
10717 & pos(1) ) ) then
10718
10719 abs_mes = 'ABSOLUTE value of'
10720 else
10721 abs_mes = ''
10722
10723 end if
10724
10725 end if
10726 deallocate(mask_array, judge, judge_rev)
10727 deallocate(answer_negative, check_negative, both_negative)
10728
10729
10730
10731
10732 if (err_flag) then
10733 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10734 write(*,*) ''
10735 write(*,*) ' ' // trim(abs_mes) // &
10736 & ' check' // trim(pos_str) // ' = ', wrong
10737 write(*,*) ' is NOT GREATER THAN'
10738 write(*,*) ' ' // trim(abs_mes) // &
10739 & ' answer' // trim(pos_str) // ' = ', right
10740
10741 call abortprogram('')
10742 else
10743 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
10744 end if
10745
10746
10747 end subroutine dctestassertgreaterthanreal1
10748
10749
10750 subroutine dctestassertgreaterthanreal2( &
10751 & message, answer, check, negative_support)
10752 use sysdep, only: abortprogram
10753 use dc_types, only: string, token
10754 implicit none
10755 character(*), intent(in):: message
10756 real, intent(in):: answer(:,:)
10757 real, intent(in):: check(:,:)
10758 logical, intent(in), optional:: negative_support
10759 logical:: err_flag
10760 logical:: negative_support_on
10761 character(STRING):: pos_str
10762 character(TOKEN):: abs_mes
10763 real:: wrong, right
10764
10765 integer:: answer_shape(2), check_shape(2), pos(2)
10766 logical:: consist_shape(2)
10767 character(TOKEN):: pos_array(2)
10768 integer, allocatable:: mask_array(:,:)
10769 logical, allocatable:: judge(:,:)
10770 logical, allocatable:: judge_rev(:,:)
10771 logical, allocatable:: answer_negative(:,:)
10772 logical, allocatable:: check_negative(:,:)
10773 logical, allocatable:: both_negative(:,:)
10774
10775
10776 continue
10777 if (present(negative_support)) then
10778 negative_support_on = negative_support
10779 else
10780 negative_support_on = .true.
10781 end if
10782
10783 err_flag = .false.
10784
10785
10786 answer_shape = shape(answer)
10787 check_shape = shape(check)
10788
10789 consist_shape = answer_shape == check_shape
10790
10791 if (.not. all(consist_shape)) then
10792 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10793 write(*,*) ''
10794 write(*,*) ' shape of check is (', check_shape, ')'
10795 write(*,*) ' is INCORRECT'
10796 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
10797
10798 call abortprogram('')
10799 end if
10800
10801
10802 allocate( mask_array( &
10803 & answer_shape(1), &
10804
10805 & answer_shape(2) ) &
10806 & )
10807
10808 allocate( judge( &
10809 & answer_shape(1), &
10810
10811 & answer_shape(2) ) &
10812 & )
10813
10814 allocate( judge_rev( &
10815 & answer_shape(1), &
10816
10817 & answer_shape(2) ) &
10818 & )
10819
10820 allocate( answer_negative( &
10821 & answer_shape(1), &
10822
10823 & answer_shape(2) ) &
10824 & )
10825
10826 allocate( check_negative( &
10827 & answer_shape(1), &
10828
10829 & answer_shape(2) ) &
10830 & )
10831
10832 allocate( both_negative( &
10833 & answer_shape(1), &
10834
10835 & answer_shape(2) ) &
10836 & )
10837
10838 answer_negative = answer < 0.0
10839 check_negative = check < 0.0
10840 both_negative = answer_negative .and. check_negative
10841 if (.not. negative_support_on) both_negative = .false.
10842
10843 judge = answer < check
10844 where (both_negative) judge = .not. judge
10845
10846 judge_rev = .not. judge
10847 err_flag = any(judge_rev)
10848 mask_array = 1
10849 pos = maxloc(mask_array, judge_rev)
10850
10851 if (err_flag) then
10852
10853 wrong = check( &
10854 & pos(1), &
10855
10856 & pos(2) )
10857
10858 right = answer( &
10859 & pos(1), &
10860
10861 & pos(2) )
10862
10863 write(unit=pos_array(1), fmt="(i20)") pos(1)
10864
10865 write(unit=pos_array(2), fmt="(i20)") pos(2)
10866
10867
10868 pos_str = '(' // &
10869 & trim(adjustl(pos_array(1))) // ',' // &
10870
10871 & trim(adjustl(pos_array(2))) // ')'
10872
10873 if ( both_negative( &
10874 & pos(1), &
10875
10876 & pos(2) ) ) then
10877
10878 abs_mes = 'ABSOLUTE value of'
10879 else
10880 abs_mes = ''
10881
10882 end if
10883
10884 end if
10885 deallocate(mask_array, judge, judge_rev)
10886 deallocate(answer_negative, check_negative, both_negative)
10887
10888
10889
10890
10891 if (err_flag) then
10892 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10893 write(*,*) ''
10894 write(*,*) ' ' // trim(abs_mes) // &
10895 & ' check' // trim(pos_str) // ' = ', wrong
10896 write(*,*) ' is NOT GREATER THAN'
10897 write(*,*) ' ' // trim(abs_mes) // &
10898 & ' answer' // trim(pos_str) // ' = ', right
10899
10900 call abortprogram('')
10901 else
10902 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
10903 end if
10904
10905
10906 end subroutine dctestassertgreaterthanreal2
10907
10908
10909 subroutine dctestassertgreaterthanreal3( &
10910 & message, answer, check, negative_support)
10911 use sysdep, only: abortprogram
10912 use dc_types, only: string, token
10913 implicit none
10914 character(*), intent(in):: message
10915 real, intent(in):: answer(:,:,:)
10916 real, intent(in):: check(:,:,:)
10917 logical, intent(in), optional:: negative_support
10918 logical:: err_flag
10919 logical:: negative_support_on
10920 character(STRING):: pos_str
10921 character(TOKEN):: abs_mes
10922 real:: wrong, right
10923
10924 integer:: answer_shape(3), check_shape(3), pos(3)
10925 logical:: consist_shape(3)
10926 character(TOKEN):: pos_array(3)
10927 integer, allocatable:: mask_array(:,:,:)
10928 logical, allocatable:: judge(:,:,:)
10929 logical, allocatable:: judge_rev(:,:,:)
10930 logical, allocatable:: answer_negative(:,:,:)
10931 logical, allocatable:: check_negative(:,:,:)
10932 logical, allocatable:: both_negative(:,:,:)
10933
10934
10935 continue
10936 if (present(negative_support)) then
10937 negative_support_on = negative_support
10938 else
10939 negative_support_on = .true.
10940 end if
10941
10942 err_flag = .false.
10943
10944
10945 answer_shape = shape(answer)
10946 check_shape = shape(check)
10947
10948 consist_shape = answer_shape == check_shape
10949
10950 if (.not. all(consist_shape)) then
10951 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10952 write(*,*) ''
10953 write(*,*) ' shape of check is (', check_shape, ')'
10954 write(*,*) ' is INCORRECT'
10955 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
10956
10957 call abortprogram('')
10958 end if
10959
10960
10961 allocate( mask_array( &
10962 & answer_shape(1), &
10963
10964 & answer_shape(2), &
10965
10966 & answer_shape(3) ) &
10967 & )
10968
10969 allocate( judge( &
10970 & answer_shape(1), &
10971
10972 & answer_shape(2), &
10973
10974 & answer_shape(3) ) &
10975 & )
10976
10977 allocate( judge_rev( &
10978 & answer_shape(1), &
10979
10980 & answer_shape(2), &
10981
10982 & answer_shape(3) ) &
10983 & )
10984
10985 allocate( answer_negative( &
10986 & answer_shape(1), &
10987
10988 & answer_shape(2), &
10989
10990 & answer_shape(3) ) &
10991 & )
10992
10993 allocate( check_negative( &
10994 & answer_shape(1), &
10995
10996 & answer_shape(2), &
10997
10998 & answer_shape(3) ) &
10999 & )
11000
11001 allocate( both_negative( &
11002 & answer_shape(1), &
11003
11004 & answer_shape(2), &
11005
11006 & answer_shape(3) ) &
11007 & )
11008
11009 answer_negative = answer < 0.0
11010 check_negative = check < 0.0
11011 both_negative = answer_negative .and. check_negative
11012 if (.not. negative_support_on) both_negative = .false.
11013
11014 judge = answer < check
11015 where (both_negative) judge = .not. judge
11016
11017 judge_rev = .not. judge
11018 err_flag = any(judge_rev)
11019 mask_array = 1
11020 pos = maxloc(mask_array, judge_rev)
11021
11022 if (err_flag) then
11023
11024 wrong = check( &
11025 & pos(1), &
11026
11027 & pos(2), &
11028
11029 & pos(3) )
11030
11031 right = answer( &
11032 & pos(1), &
11033
11034 & pos(2), &
11035
11036 & pos(3) )
11037
11038 write(unit=pos_array(1), fmt="(i20)") pos(1)
11039
11040 write(unit=pos_array(2), fmt="(i20)") pos(2)
11041
11042 write(unit=pos_array(3), fmt="(i20)") pos(3)
11043
11044
11045 pos_str = '(' // &
11046 & trim(adjustl(pos_array(1))) // ',' // &
11047
11048 & trim(adjustl(pos_array(2))) // ',' // &
11049
11050 & trim(adjustl(pos_array(3))) // ')'
11051
11052 if ( both_negative( &
11053 & pos(1), &
11054
11055 & pos(2), &
11056
11057 & pos(3) ) ) then
11058
11059 abs_mes = 'ABSOLUTE value of'
11060 else
11061 abs_mes = ''
11062
11063 end if
11064
11065 end if
11066 deallocate(mask_array, judge, judge_rev)
11067 deallocate(answer_negative, check_negative, both_negative)
11068
11069
11070
11071
11072 if (err_flag) then
11073 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11074 write(*,*) ''
11075 write(*,*) ' ' // trim(abs_mes) // &
11076 & ' check' // trim(pos_str) // ' = ', wrong
11077 write(*,*) ' is NOT GREATER THAN'
11078 write(*,*) ' ' // trim(abs_mes) // &
11079 & ' answer' // trim(pos_str) // ' = ', right
11080
11081 call abortprogram('')
11082 else
11083 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
11084 end if
11085
11086
11087 end subroutine dctestassertgreaterthanreal3
11088
11089
11090 subroutine dctestassertgreaterthanreal4( &
11091 & message, answer, check, negative_support)
11092 use sysdep, only: abortprogram
11093 use dc_types, only: string, token
11094 implicit none
11095 character(*), intent(in):: message
11096 real, intent(in):: answer(:,:,:,:)
11097 real, intent(in):: check(:,:,:,:)
11098 logical, intent(in), optional:: negative_support
11099 logical:: err_flag
11100 logical:: negative_support_on
11101 character(STRING):: pos_str
11102 character(TOKEN):: abs_mes
11103 real:: wrong, right
11104
11105 integer:: answer_shape(4), check_shape(4), pos(4)
11106 logical:: consist_shape(4)
11107 character(TOKEN):: pos_array(4)
11108 integer, allocatable:: mask_array(:,:,:,:)
11109 logical, allocatable:: judge(:,:,:,:)
11110 logical, allocatable:: judge_rev(:,:,:,:)
11111 logical, allocatable:: answer_negative(:,:,:,:)
11112 logical, allocatable:: check_negative(:,:,:,:)
11113 logical, allocatable:: both_negative(:,:,:,:)
11114
11115
11116 continue
11117 if (present(negative_support)) then
11118 negative_support_on = negative_support
11119 else
11120 negative_support_on = .true.
11121 end if
11122
11123 err_flag = .false.
11124
11125
11126 answer_shape = shape(answer)
11127 check_shape = shape(check)
11128
11129 consist_shape = answer_shape == check_shape
11130
11131 if (.not. all(consist_shape)) then
11132 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11133 write(*,*) ''
11134 write(*,*) ' shape of check is (', check_shape, ')'
11135 write(*,*) ' is INCORRECT'
11136 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
11137
11138 call abortprogram('')
11139 end if
11140
11141
11142 allocate( mask_array( &
11143 & answer_shape(1), &
11144
11145 & answer_shape(2), &
11146
11147 & answer_shape(3), &
11148
11149 & answer_shape(4) ) &
11150 & )
11151
11152 allocate( judge( &
11153 & answer_shape(1), &
11154
11155 & answer_shape(2), &
11156
11157 & answer_shape(3), &
11158
11159 & answer_shape(4) ) &
11160 & )
11161
11162 allocate( judge_rev( &
11163 & answer_shape(1), &
11164
11165 & answer_shape(2), &
11166
11167 & answer_shape(3), &
11168
11169 & answer_shape(4) ) &
11170 & )
11171
11172 allocate( answer_negative( &
11173 & answer_shape(1), &
11174
11175 & answer_shape(2), &
11176
11177 & answer_shape(3), &
11178
11179 & answer_shape(4) ) &
11180 & )
11181
11182 allocate( check_negative( &
11183 & answer_shape(1), &
11184
11185 & answer_shape(2), &
11186
11187 & answer_shape(3), &
11188
11189 & answer_shape(4) ) &
11190 & )
11191
11192 allocate( both_negative( &
11193 & answer_shape(1), &
11194
11195 & answer_shape(2), &
11196
11197 & answer_shape(3), &
11198
11199 & answer_shape(4) ) &
11200 & )
11201
11202 answer_negative = answer < 0.0
11203 check_negative = check < 0.0
11204 both_negative = answer_negative .and. check_negative
11205 if (.not. negative_support_on) both_negative = .false.
11206
11207 judge = answer < check
11208 where (both_negative) judge = .not. judge
11209
11210 judge_rev = .not. judge
11211 err_flag = any(judge_rev)
11212 mask_array = 1
11213 pos = maxloc(mask_array, judge_rev)
11214
11215 if (err_flag) then
11216
11217 wrong = check( &
11218 & pos(1), &
11219
11220 & pos(2), &
11221
11222 & pos(3), &
11223
11224 & pos(4) )
11225
11226 right = answer( &
11227 & pos(1), &
11228
11229 & pos(2), &
11230
11231 & pos(3), &
11232
11233 & pos(4) )
11234
11235 write(unit=pos_array(1), fmt="(i20)") pos(1)
11236
11237 write(unit=pos_array(2), fmt="(i20)") pos(2)
11238
11239 write(unit=pos_array(3), fmt="(i20)") pos(3)
11240
11241 write(unit=pos_array(4), fmt="(i20)") pos(4)
11242
11243
11244 pos_str = '(' // &
11245 & trim(adjustl(pos_array(1))) // ',' // &
11246
11247 & trim(adjustl(pos_array(2))) // ',' // &
11248
11249 & trim(adjustl(pos_array(3))) // ',' // &
11250
11251 & trim(adjustl(pos_array(4))) // ')'
11252
11253 if ( both_negative( &
11254 & pos(1), &
11255
11256 & pos(2), &
11257
11258 & pos(3), &
11259
11260 & pos(4) ) ) then
11261
11262 abs_mes = 'ABSOLUTE value of'
11263 else
11264 abs_mes = ''
11265
11266 end if
11267
11268 end if
11269 deallocate(mask_array, judge, judge_rev)
11270 deallocate(answer_negative, check_negative, both_negative)
11271
11272
11273
11274
11275 if (err_flag) then
11276 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11277 write(*,*) ''
11278 write(*,*) ' ' // trim(abs_mes) // &
11279 & ' check' // trim(pos_str) // ' = ', wrong
11280 write(*,*) ' is NOT GREATER THAN'
11281 write(*,*) ' ' // trim(abs_mes) // &
11282 & ' answer' // trim(pos_str) // ' = ', right
11283
11284 call abortprogram('')
11285 else
11286 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
11287 end if
11288
11289
11290 end subroutine dctestassertgreaterthanreal4
11291
11292
11293 subroutine dctestassertgreaterthanreal5( &
11294 & message, answer, check, negative_support)
11295 use sysdep, only: abortprogram
11296 use dc_types, only: string, token
11297 implicit none
11298 character(*), intent(in):: message
11299 real, intent(in):: answer(:,:,:,:,:)
11300 real, intent(in):: check(:,:,:,:,:)
11301 logical, intent(in), optional:: negative_support
11302 logical:: err_flag
11303 logical:: negative_support_on
11304 character(STRING):: pos_str
11305 character(TOKEN):: abs_mes
11306 real:: wrong, right
11307
11308 integer:: answer_shape(5), check_shape(5), pos(5)
11309 logical:: consist_shape(5)
11310 character(TOKEN):: pos_array(5)
11311 integer, allocatable:: mask_array(:,:,:,:,:)
11312 logical, allocatable:: judge(:,:,:,:,:)
11313 logical, allocatable:: judge_rev(:,:,:,:,:)
11314 logical, allocatable:: answer_negative(:,:,:,:,:)
11315 logical, allocatable:: check_negative(:,:,:,:,:)
11316 logical, allocatable:: both_negative(:,:,:,:,:)
11317
11318
11319 continue
11320 if (present(negative_support)) then
11321 negative_support_on = negative_support
11322 else
11323 negative_support_on = .true.
11324 end if
11325
11326 err_flag = .false.
11327
11328
11329 answer_shape = shape(answer)
11330 check_shape = shape(check)
11331
11332 consist_shape = answer_shape == check_shape
11333
11334 if (.not. all(consist_shape)) then
11335 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11336 write(*,*) ''
11337 write(*,*) ' shape of check is (', check_shape, ')'
11338 write(*,*) ' is INCORRECT'
11339 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
11340
11341 call abortprogram('')
11342 end if
11343
11344
11345 allocate( mask_array( &
11346 & answer_shape(1), &
11347
11348 & answer_shape(2), &
11349
11350 & answer_shape(3), &
11351
11352 & answer_shape(4), &
11353
11354 & answer_shape(5) ) &
11355 & )
11356
11357 allocate( judge( &
11358 & answer_shape(1), &
11359
11360 & answer_shape(2), &
11361
11362 & answer_shape(3), &
11363
11364 & answer_shape(4), &
11365
11366 & answer_shape(5) ) &
11367 & )
11368
11369 allocate( judge_rev( &
11370 & answer_shape(1), &
11371
11372 & answer_shape(2), &
11373
11374 & answer_shape(3), &
11375
11376 & answer_shape(4), &
11377
11378 & answer_shape(5) ) &
11379 & )
11380
11381 allocate( answer_negative( &
11382 & answer_shape(1), &
11383
11384 & answer_shape(2), &
11385
11386 & answer_shape(3), &
11387
11388 & answer_shape(4), &
11389
11390 & answer_shape(5) ) &
11391 & )
11392
11393 allocate( check_negative( &
11394 & answer_shape(1), &
11395
11396 & answer_shape(2), &
11397
11398 & answer_shape(3), &
11399
11400 & answer_shape(4), &
11401
11402 & answer_shape(5) ) &
11403 & )
11404
11405 allocate( both_negative( &
11406 & answer_shape(1), &
11407
11408 & answer_shape(2), &
11409
11410 & answer_shape(3), &
11411
11412 & answer_shape(4), &
11413
11414 & answer_shape(5) ) &
11415 & )
11416
11417 answer_negative = answer < 0.0
11418 check_negative = check < 0.0
11419 both_negative = answer_negative .and. check_negative
11420 if (.not. negative_support_on) both_negative = .false.
11421
11422 judge = answer < check
11423 where (both_negative) judge = .not. judge
11424
11425 judge_rev = .not. judge
11426 err_flag = any(judge_rev)
11427 mask_array = 1
11428 pos = maxloc(mask_array, judge_rev)
11429
11430 if (err_flag) then
11431
11432 wrong = check( &
11433 & pos(1), &
11434
11435 & pos(2), &
11436
11437 & pos(3), &
11438
11439 & pos(4), &
11440
11441 & pos(5) )
11442
11443 right = answer( &
11444 & pos(1), &
11445
11446 & pos(2), &
11447
11448 & pos(3), &
11449
11450 & pos(4), &
11451
11452 & pos(5) )
11453
11454 write(unit=pos_array(1), fmt="(i20)") pos(1)
11455
11456 write(unit=pos_array(2), fmt="(i20)") pos(2)
11457
11458 write(unit=pos_array(3), fmt="(i20)") pos(3)
11459
11460 write(unit=pos_array(4), fmt="(i20)") pos(4)
11461
11462 write(unit=pos_array(5), fmt="(i20)") pos(5)
11463
11464
11465 pos_str = '(' // &
11466 & trim(adjustl(pos_array(1))) // ',' // &
11467
11468 & trim(adjustl(pos_array(2))) // ',' // &
11469
11470 & trim(adjustl(pos_array(3))) // ',' // &
11471
11472 & trim(adjustl(pos_array(4))) // ',' // &
11473
11474 & trim(adjustl(pos_array(5))) // ')'
11475
11476 if ( both_negative( &
11477 & pos(1), &
11478
11479 & pos(2), &
11480
11481 & pos(3), &
11482
11483 & pos(4), &
11484
11485 & pos(5) ) ) then
11486
11487 abs_mes = 'ABSOLUTE value of'
11488 else
11489 abs_mes = ''
11490
11491 end if
11492
11493 end if
11494 deallocate(mask_array, judge, judge_rev)
11495 deallocate(answer_negative, check_negative, both_negative)
11496
11497
11498
11499
11500 if (err_flag) then
11501 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11502 write(*,*) ''
11503 write(*,*) ' ' // trim(abs_mes) // &
11504 & ' check' // trim(pos_str) // ' = ', wrong
11505 write(*,*) ' is NOT GREATER THAN'
11506 write(*,*) ' ' // trim(abs_mes) // &
11507 & ' answer' // trim(pos_str) // ' = ', right
11508
11509 call abortprogram('')
11510 else
11511 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
11512 end if
11513
11514
11515 end subroutine dctestassertgreaterthanreal5
11516
11517
11518 subroutine dctestassertgreaterthanreal6( &
11519 & message, answer, check, negative_support)
11520 use sysdep, only: abortprogram
11521 use dc_types, only: string, token
11522 implicit none
11523 character(*), intent(in):: message
11524 real, intent(in):: answer(:,:,:,:,:,:)
11525 real, intent(in):: check(:,:,:,:,:,:)
11526 logical, intent(in), optional:: negative_support
11527 logical:: err_flag
11528 logical:: negative_support_on
11529 character(STRING):: pos_str
11530 character(TOKEN):: abs_mes
11531 real:: wrong, right
11532
11533 integer:: answer_shape(6), check_shape(6), pos(6)
11534 logical:: consist_shape(6)
11535 character(TOKEN):: pos_array(6)
11536 integer, allocatable:: mask_array(:,:,:,:,:,:)
11537 logical, allocatable:: judge(:,:,:,:,:,:)
11538 logical, allocatable:: judge_rev(:,:,:,:,:,:)
11539 logical, allocatable:: answer_negative(:,:,:,:,:,:)
11540 logical, allocatable:: check_negative(:,:,:,:,:,:)
11541 logical, allocatable:: both_negative(:,:,:,:,:,:)
11542
11543
11544 continue
11545 if (present(negative_support)) then
11546 negative_support_on = negative_support
11547 else
11548 negative_support_on = .true.
11549 end if
11550
11551 err_flag = .false.
11552
11553
11554 answer_shape = shape(answer)
11555 check_shape = shape(check)
11556
11557 consist_shape = answer_shape == check_shape
11558
11559 if (.not. all(consist_shape)) then
11560 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11561 write(*,*) ''
11562 write(*,*) ' shape of check is (', check_shape, ')'
11563 write(*,*) ' is INCORRECT'
11564 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
11565
11566 call abortprogram('')
11567 end if
11568
11569
11570 allocate( mask_array( &
11571 & answer_shape(1), &
11572
11573 & answer_shape(2), &
11574
11575 & answer_shape(3), &
11576
11577 & answer_shape(4), &
11578
11579 & answer_shape(5), &
11580
11581 & answer_shape(6) ) &
11582 & )
11583
11584 allocate( judge( &
11585 & answer_shape(1), &
11586
11587 & answer_shape(2), &
11588
11589 & answer_shape(3), &
11590
11591 & answer_shape(4), &
11592
11593 & answer_shape(5), &
11594
11595 & answer_shape(6) ) &
11596 & )
11597
11598 allocate( judge_rev( &
11599 & answer_shape(1), &
11600
11601 & answer_shape(2), &
11602
11603 & answer_shape(3), &
11604
11605 & answer_shape(4), &
11606
11607 & answer_shape(5), &
11608
11609 & answer_shape(6) ) &
11610 & )
11611
11612 allocate( answer_negative( &
11613 & answer_shape(1), &
11614
11615 & answer_shape(2), &
11616
11617 & answer_shape(3), &
11618
11619 & answer_shape(4), &
11620
11621 & answer_shape(5), &
11622
11623 & answer_shape(6) ) &
11624 & )
11625
11626 allocate( check_negative( &
11627 & answer_shape(1), &
11628
11629 & answer_shape(2), &
11630
11631 & answer_shape(3), &
11632
11633 & answer_shape(4), &
11634
11635 & answer_shape(5), &
11636
11637 & answer_shape(6) ) &
11638 & )
11639
11640 allocate( both_negative( &
11641 & answer_shape(1), &
11642
11643 & answer_shape(2), &
11644
11645 & answer_shape(3), &
11646
11647 & answer_shape(4), &
11648
11649 & answer_shape(5), &
11650
11651 & answer_shape(6) ) &
11652 & )
11653
11654 answer_negative = answer < 0.0
11655 check_negative = check < 0.0
11656 both_negative = answer_negative .and. check_negative
11657 if (.not. negative_support_on) both_negative = .false.
11658
11659 judge = answer < check
11660 where (both_negative) judge = .not. judge
11661
11662 judge_rev = .not. judge
11663 err_flag = any(judge_rev)
11664 mask_array = 1
11665 pos = maxloc(mask_array, judge_rev)
11666
11667 if (err_flag) then
11668
11669 wrong = check( &
11670 & pos(1), &
11671
11672 & pos(2), &
11673
11674 & pos(3), &
11675
11676 & pos(4), &
11677
11678 & pos(5), &
11679
11680 & pos(6) )
11681
11682 right = answer( &
11683 & pos(1), &
11684
11685 & pos(2), &
11686
11687 & pos(3), &
11688
11689 & pos(4), &
11690
11691 & pos(5), &
11692
11693 & pos(6) )
11694
11695 write(unit=pos_array(1), fmt="(i20)") pos(1)
11696
11697 write(unit=pos_array(2), fmt="(i20)") pos(2)
11698
11699 write(unit=pos_array(3), fmt="(i20)") pos(3)
11700
11701 write(unit=pos_array(4), fmt="(i20)") pos(4)
11702
11703 write(unit=pos_array(5), fmt="(i20)") pos(5)
11704
11705 write(unit=pos_array(6), fmt="(i20)") pos(6)
11706
11707
11708 pos_str = '(' // &
11709 & trim(adjustl(pos_array(1))) // ',' // &
11710
11711 & trim(adjustl(pos_array(2))) // ',' // &
11712
11713 & trim(adjustl(pos_array(3))) // ',' // &
11714
11715 & trim(adjustl(pos_array(4))) // ',' // &
11716
11717 & trim(adjustl(pos_array(5))) // ',' // &
11718
11719 & trim(adjustl(pos_array(6))) // ')'
11720
11721 if ( both_negative( &
11722 & pos(1), &
11723
11724 & pos(2), &
11725
11726 & pos(3), &
11727
11728 & pos(4), &
11729
11730 & pos(5), &
11731
11732 & pos(6) ) ) then
11733
11734 abs_mes = 'ABSOLUTE value of'
11735 else
11736 abs_mes = ''
11737
11738 end if
11739
11740 end if
11741 deallocate(mask_array, judge, judge_rev)
11742 deallocate(answer_negative, check_negative, both_negative)
11743
11744
11745
11746
11747 if (err_flag) then
11748 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11749 write(*,*) ''
11750 write(*,*) ' ' // trim(abs_mes) // &
11751 & ' check' // trim(pos_str) // ' = ', wrong
11752 write(*,*) ' is NOT GREATER THAN'
11753 write(*,*) ' ' // trim(abs_mes) // &
11754 & ' answer' // trim(pos_str) // ' = ', right
11755
11756 call abortprogram('')
11757 else
11758 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
11759 end if
11760
11761
11762 end subroutine dctestassertgreaterthanreal6
11763
11764
11765 subroutine dctestassertgreaterthanreal7( &
11766 & message, answer, check, negative_support)
11767 use sysdep, only: abortprogram
11768 use dc_types, only: string, token
11769 implicit none
11770 character(*), intent(in):: message
11771 real, intent(in):: answer(:,:,:,:,:,:,:)
11772 real, intent(in):: check(:,:,:,:,:,:,:)
11773 logical, intent(in), optional:: negative_support
11774 logical:: err_flag
11775 logical:: negative_support_on
11776 character(STRING):: pos_str
11777 character(TOKEN):: abs_mes
11778 real:: wrong, right
11779
11780 integer:: answer_shape(7), check_shape(7), pos(7)
11781 logical:: consist_shape(7)
11782 character(TOKEN):: pos_array(7)
11783 integer, allocatable:: mask_array(:,:,:,:,:,:,:)
11784 logical, allocatable:: judge(:,:,:,:,:,:,:)
11785 logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
11786 logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
11787 logical, allocatable:: check_negative(:,:,:,:,:,:,:)
11788 logical, allocatable:: both_negative(:,:,:,:,:,:,:)
11789
11790
11791 continue
11792 if (present(negative_support)) then
11793 negative_support_on = negative_support
11794 else
11795 negative_support_on = .true.
11796 end if
11797
11798 err_flag = .false.
11799
11800
11801 answer_shape = shape(answer)
11802 check_shape = shape(check)
11803
11804 consist_shape = answer_shape == check_shape
11805
11806 if (.not. all(consist_shape)) then
11807 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11808 write(*,*) ''
11809 write(*,*) ' shape of check is (', check_shape, ')'
11810 write(*,*) ' is INCORRECT'
11811 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
11812
11813 call abortprogram('')
11814 end if
11815
11816
11817 allocate( mask_array( &
11818 & answer_shape(1), &
11819
11820 & answer_shape(2), &
11821
11822 & answer_shape(3), &
11823
11824 & answer_shape(4), &
11825
11826 & answer_shape(5), &
11827
11828 & answer_shape(6), &
11829
11830 & answer_shape(7) ) &
11831 & )
11832
11833 allocate( judge( &
11834 & answer_shape(1), &
11835
11836 & answer_shape(2), &
11837
11838 & answer_shape(3), &
11839
11840 & answer_shape(4), &
11841
11842 & answer_shape(5), &
11843
11844 & answer_shape(6), &
11845
11846 & answer_shape(7) ) &
11847 & )
11848
11849 allocate( judge_rev( &
11850 & answer_shape(1), &
11851
11852 & answer_shape(2), &
11853
11854 & answer_shape(3), &
11855
11856 & answer_shape(4), &
11857
11858 & answer_shape(5), &
11859
11860 & answer_shape(6), &
11861
11862 & answer_shape(7) ) &
11863 & )
11864
11865 allocate( answer_negative( &
11866 & answer_shape(1), &
11867
11868 & answer_shape(2), &
11869
11870 & answer_shape(3), &
11871
11872 & answer_shape(4), &
11873
11874 & answer_shape(5), &
11875
11876 & answer_shape(6), &
11877
11878 & answer_shape(7) ) &
11879 & )
11880
11881 allocate( check_negative( &
11882 & answer_shape(1), &
11883
11884 & answer_shape(2), &
11885
11886 & answer_shape(3), &
11887
11888 & answer_shape(4), &
11889
11890 & answer_shape(5), &
11891
11892 & answer_shape(6), &
11893
11894 & answer_shape(7) ) &
11895 & )
11896
11897 allocate( both_negative( &
11898 & answer_shape(1), &
11899
11900 & answer_shape(2), &
11901
11902 & answer_shape(3), &
11903
11904 & answer_shape(4), &
11905
11906 & answer_shape(5), &
11907
11908 & answer_shape(6), &
11909
11910 & answer_shape(7) ) &
11911 & )
11912
11913 answer_negative = answer < 0.0
11914 check_negative = check < 0.0
11915 both_negative = answer_negative .and. check_negative
11916 if (.not. negative_support_on) both_negative = .false.
11917
11918 judge = answer < check
11919 where (both_negative) judge = .not. judge
11920
11921 judge_rev = .not. judge
11922 err_flag = any(judge_rev)
11923 mask_array = 1
11924 pos = maxloc(mask_array, judge_rev)
11925
11926 if (err_flag) then
11927
11928 wrong = check( &
11929 & pos(1), &
11930
11931 & pos(2), &
11932
11933 & pos(3), &
11934
11935 & pos(4), &
11936
11937 & pos(5), &
11938
11939 & pos(6), &
11940
11941 & pos(7) )
11942
11943 right = answer( &
11944 & pos(1), &
11945
11946 & pos(2), &
11947
11948 & pos(3), &
11949
11950 & pos(4), &
11951
11952 & pos(5), &
11953
11954 & pos(6), &
11955
11956 & pos(7) )
11957
11958 write(unit=pos_array(1), fmt="(i20)") pos(1)
11959
11960 write(unit=pos_array(2), fmt="(i20)") pos(2)
11961
11962 write(unit=pos_array(3), fmt="(i20)") pos(3)
11963
11964 write(unit=pos_array(4), fmt="(i20)") pos(4)
11965
11966 write(unit=pos_array(5), fmt="(i20)") pos(5)
11967
11968 write(unit=pos_array(6), fmt="(i20)") pos(6)
11969
11970 write(unit=pos_array(7), fmt="(i20)") pos(7)
11971
11972
11973 pos_str = '(' // &
11974 & trim(adjustl(pos_array(1))) // ',' // &
11975
11976 & trim(adjustl(pos_array(2))) // ',' // &
11977
11978 & trim(adjustl(pos_array(3))) // ',' // &
11979
11980 & trim(adjustl(pos_array(4))) // ',' // &
11981
11982 & trim(adjustl(pos_array(5))) // ',' // &
11983
11984 & trim(adjustl(pos_array(6))) // ',' // &
11985
11986 & trim(adjustl(pos_array(7))) // ')'
11987
11988 if ( both_negative( &
11989 & pos(1), &
11990
11991 & pos(2), &
11992
11993 & pos(3), &
11994
11995 & pos(4), &
11996
11997 & pos(5), &
11998
11999 & pos(6), &
12000
12001 & pos(7) ) ) then
12002
12003 abs_mes = 'ABSOLUTE value of'
12004 else
12005 abs_mes = ''
12006
12007 end if
12008
12009 end if
12010 deallocate(mask_array, judge, judge_rev)
12011 deallocate(answer_negative, check_negative, both_negative)
12012
12013
12014
12015
12016 if (err_flag) then
12017 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12018 write(*,*) ''
12019 write(*,*) ' ' // trim(abs_mes) // &
12020 & ' check' // trim(pos_str) // ' = ', wrong
12021 write(*,*) ' is NOT GREATER THAN'
12022 write(*,*) ' ' // trim(abs_mes) // &
12023 & ' answer' // trim(pos_str) // ' = ', right
12024
12025 call abortprogram('')
12026 else
12027 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12028 end if
12029
12030
12031 end subroutine dctestassertgreaterthanreal7
12032
12033
12034 subroutine dctestassertgreaterthandouble0( &
12035 & message, answer, check, negative_support)
12036 use sysdep, only: abortprogram
12037 use dc_types, only: string, token
12038 implicit none
12039 character(*), intent(in):: message
12040 real(DP), intent(in):: answer
12041 real(DP), intent(in):: check
12042 logical, intent(in), optional:: negative_support
12043 logical:: err_flag
12044 logical:: negative_support_on
12045 character(STRING):: pos_str
12046 character(TOKEN):: abs_mes
12047 real(DP):: wrong, right
12048
12049
12050
12051 continue
12052 if (present(negative_support)) then
12053 negative_support_on = negative_support
12054 else
12055 negative_support_on = .true.
12056 end if
12057
12058 err_flag = .false.
12059
12060
12061 err_flag = .not. answer < check
12062 abs_mes = ''
12063
12064 if ( answer < 0.0_dp &
12065 & .and. check < 0.0_dp &
12066 & .and. negative_support_on ) then
12067
12068 err_flag = .not. err_flag
12069 abs_mes = 'ABSOLUTE value of'
12070 end if
12071
12072 wrong = check
12073 right = answer
12074 pos_str = ''
12075
12076
12077
12078
12079 if (err_flag) then
12080 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12081 write(*,*) ''
12082 write(*,*) ' ' // trim(abs_mes) // &
12083 & ' check' // trim(pos_str) // ' = ', wrong
12084 write(*,*) ' is NOT GREATER THAN'
12085 write(*,*) ' ' // trim(abs_mes) // &
12086 & ' answer' // trim(pos_str) // ' = ', right
12087
12088 call abortprogram('')
12089 else
12090 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12091 end if
12092
12093
12094 end subroutine dctestassertgreaterthandouble0
12095
12096
12097 subroutine dctestassertgreaterthandouble1( &
12098 & message, answer, check, negative_support)
12099 use sysdep, only: abortprogram
12100 use dc_types, only: string, token
12101 implicit none
12102 character(*), intent(in):: message
12103 real(DP), intent(in):: answer(:)
12104 real(DP), intent(in):: check(:)
12105 logical, intent(in), optional:: negative_support
12106 logical:: err_flag
12107 logical:: negative_support_on
12108 character(STRING):: pos_str
12109 character(TOKEN):: abs_mes
12110 real(DP):: wrong, right
12111
12112 integer:: answer_shape(1), check_shape(1), pos(1)
12113 logical:: consist_shape(1)
12114 character(TOKEN):: pos_array(1)
12115 integer, allocatable:: mask_array(:)
12116 logical, allocatable:: judge(:)
12117 logical, allocatable:: judge_rev(:)
12118 logical, allocatable:: answer_negative(:)
12119 logical, allocatable:: check_negative(:)
12120 logical, allocatable:: both_negative(:)
12121
12122
12123 continue
12124 if (present(negative_support)) then
12125 negative_support_on = negative_support
12126 else
12127 negative_support_on = .true.
12128 end if
12129
12130 err_flag = .false.
12131
12132
12133 answer_shape = shape(answer)
12134 check_shape = shape(check)
12135
12136 consist_shape = answer_shape == check_shape
12137
12138 if (.not. all(consist_shape)) then
12139 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12140 write(*,*) ''
12141 write(*,*) ' shape of check is (', check_shape, ')'
12142 write(*,*) ' is INCORRECT'
12143 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
12144
12145 call abortprogram('')
12146 end if
12147
12148
12149 allocate( mask_array( &
12150
12151 & answer_shape(1) ) &
12152 & )
12153
12154 allocate( judge( &
12155
12156 & answer_shape(1) ) &
12157 & )
12158
12159 allocate( judge_rev( &
12160
12161 & answer_shape(1) ) &
12162 & )
12163
12164 allocate( answer_negative( &
12165
12166 & answer_shape(1) ) &
12167 & )
12168
12169 allocate( check_negative( &
12170
12171 & answer_shape(1) ) &
12172 & )
12173
12174 allocate( both_negative( &
12175
12176 & answer_shape(1) ) &
12177 & )
12178
12179 answer_negative = answer < 0.0_dp
12180 check_negative = check < 0.0_dp
12181 both_negative = answer_negative .and. check_negative
12182 if (.not. negative_support_on) both_negative = .false.
12183
12184 judge = answer < check
12185 where (both_negative) judge = .not. judge
12186
12187 judge_rev = .not. judge
12188 err_flag = any(judge_rev)
12189 mask_array = 1
12190 pos = maxloc(mask_array, judge_rev)
12191
12192 if (err_flag) then
12193
12194 wrong = check( &
12195
12196 & pos(1) )
12197
12198 right = answer( &
12199
12200 & pos(1) )
12201
12202 write(unit=pos_array(1), fmt="(i20)") pos(1)
12203
12204
12205 pos_str = '(' // &
12206
12207 & trim(adjustl(pos_array(1))) // ')'
12208
12209 if ( both_negative( &
12210
12211 & pos(1) ) ) then
12212
12213 abs_mes = 'ABSOLUTE value of'
12214 else
12215 abs_mes = ''
12216
12217 end if
12218
12219 end if
12220 deallocate(mask_array, judge, judge_rev)
12221 deallocate(answer_negative, check_negative, both_negative)
12222
12223
12224
12225
12226 if (err_flag) then
12227 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12228 write(*,*) ''
12229 write(*,*) ' ' // trim(abs_mes) // &
12230 & ' check' // trim(pos_str) // ' = ', wrong
12231 write(*,*) ' is NOT GREATER THAN'
12232 write(*,*) ' ' // trim(abs_mes) // &
12233 & ' answer' // trim(pos_str) // ' = ', right
12234
12235 call abortprogram('')
12236 else
12237 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12238 end if
12239
12240
12241 end subroutine dctestassertgreaterthandouble1
12242
12243
12244 subroutine dctestassertgreaterthandouble2( &
12245 & message, answer, check, negative_support)
12246 use sysdep, only: abortprogram
12247 use dc_types, only: string, token
12248 implicit none
12249 character(*), intent(in):: message
12250 real(DP), intent(in):: answer(:,:)
12251 real(DP), intent(in):: check(:,:)
12252 logical, intent(in), optional:: negative_support
12253 logical:: err_flag
12254 logical:: negative_support_on
12255 character(STRING):: pos_str
12256 character(TOKEN):: abs_mes
12257 real(DP):: wrong, right
12258
12259 integer:: answer_shape(2), check_shape(2), pos(2)
12260 logical:: consist_shape(2)
12261 character(TOKEN):: pos_array(2)
12262 integer, allocatable:: mask_array(:,:)
12263 logical, allocatable:: judge(:,:)
12264 logical, allocatable:: judge_rev(:,:)
12265 logical, allocatable:: answer_negative(:,:)
12266 logical, allocatable:: check_negative(:,:)
12267 logical, allocatable:: both_negative(:,:)
12268
12269
12270 continue
12271 if (present(negative_support)) then
12272 negative_support_on = negative_support
12273 else
12274 negative_support_on = .true.
12275 end if
12276
12277 err_flag = .false.
12278
12279
12280 answer_shape = shape(answer)
12281 check_shape = shape(check)
12282
12283 consist_shape = answer_shape == check_shape
12284
12285 if (.not. all(consist_shape)) then
12286 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12287 write(*,*) ''
12288 write(*,*) ' shape of check is (', check_shape, ')'
12289 write(*,*) ' is INCORRECT'
12290 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
12291
12292 call abortprogram('')
12293 end if
12294
12295
12296 allocate( mask_array( &
12297 & answer_shape(1), &
12298
12299 & answer_shape(2) ) &
12300 & )
12301
12302 allocate( judge( &
12303 & answer_shape(1), &
12304
12305 & answer_shape(2) ) &
12306 & )
12307
12308 allocate( judge_rev( &
12309 & answer_shape(1), &
12310
12311 & answer_shape(2) ) &
12312 & )
12313
12314 allocate( answer_negative( &
12315 & answer_shape(1), &
12316
12317 & answer_shape(2) ) &
12318 & )
12319
12320 allocate( check_negative( &
12321 & answer_shape(1), &
12322
12323 & answer_shape(2) ) &
12324 & )
12325
12326 allocate( both_negative( &
12327 & answer_shape(1), &
12328
12329 & answer_shape(2) ) &
12330 & )
12331
12332 answer_negative = answer < 0.0_dp
12333 check_negative = check < 0.0_dp
12334 both_negative = answer_negative .and. check_negative
12335 if (.not. negative_support_on) both_negative = .false.
12336
12337 judge = answer < check
12338 where (both_negative) judge = .not. judge
12339
12340 judge_rev = .not. judge
12341 err_flag = any(judge_rev)
12342 mask_array = 1
12343 pos = maxloc(mask_array, judge_rev)
12344
12345 if (err_flag) then
12346
12347 wrong = check( &
12348 & pos(1), &
12349
12350 & pos(2) )
12351
12352 right = answer( &
12353 & pos(1), &
12354
12355 & pos(2) )
12356
12357 write(unit=pos_array(1), fmt="(i20)") pos(1)
12358
12359 write(unit=pos_array(2), fmt="(i20)") pos(2)
12360
12361
12362 pos_str = '(' // &
12363 & trim(adjustl(pos_array(1))) // ',' // &
12364
12365 & trim(adjustl(pos_array(2))) // ')'
12366
12367 if ( both_negative( &
12368 & pos(1), &
12369
12370 & pos(2) ) ) then
12371
12372 abs_mes = 'ABSOLUTE value of'
12373 else
12374 abs_mes = ''
12375
12376 end if
12377
12378 end if
12379 deallocate(mask_array, judge, judge_rev)
12380 deallocate(answer_negative, check_negative, both_negative)
12381
12382
12383
12384
12385 if (err_flag) then
12386 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12387 write(*,*) ''
12388 write(*,*) ' ' // trim(abs_mes) // &
12389 & ' check' // trim(pos_str) // ' = ', wrong
12390 write(*,*) ' is NOT GREATER THAN'
12391 write(*,*) ' ' // trim(abs_mes) // &
12392 & ' answer' // trim(pos_str) // ' = ', right
12393
12394 call abortprogram('')
12395 else
12396 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12397 end if
12398
12399
12400 end subroutine dctestassertgreaterthandouble2
12401
12402
12403 subroutine dctestassertgreaterthandouble3( &
12404 & message, answer, check, negative_support)
12405 use sysdep, only: abortprogram
12406 use dc_types, only: string, token
12407 implicit none
12408 character(*), intent(in):: message
12409 real(DP), intent(in):: answer(:,:,:)
12410 real(DP), intent(in):: check(:,:,:)
12411 logical, intent(in), optional:: negative_support
12412 logical:: err_flag
12413 logical:: negative_support_on
12414 character(STRING):: pos_str
12415 character(TOKEN):: abs_mes
12416 real(DP):: wrong, right
12417
12418 integer:: answer_shape(3), check_shape(3), pos(3)
12419 logical:: consist_shape(3)
12420 character(TOKEN):: pos_array(3)
12421 integer, allocatable:: mask_array(:,:,:)
12422 logical, allocatable:: judge(:,:,:)
12423 logical, allocatable:: judge_rev(:,:,:)
12424 logical, allocatable:: answer_negative(:,:,:)
12425 logical, allocatable:: check_negative(:,:,:)
12426 logical, allocatable:: both_negative(:,:,:)
12427
12428
12429 continue
12430 if (present(negative_support)) then
12431 negative_support_on = negative_support
12432 else
12433 negative_support_on = .true.
12434 end if
12435
12436 err_flag = .false.
12437
12438
12439 answer_shape = shape(answer)
12440 check_shape = shape(check)
12441
12442 consist_shape = answer_shape == check_shape
12443
12444 if (.not. all(consist_shape)) then
12445 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12446 write(*,*) ''
12447 write(*,*) ' shape of check is (', check_shape, ')'
12448 write(*,*) ' is INCORRECT'
12449 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
12450
12451 call abortprogram('')
12452 end if
12453
12454
12455 allocate( mask_array( &
12456 & answer_shape(1), &
12457
12458 & answer_shape(2), &
12459
12460 & answer_shape(3) ) &
12461 & )
12462
12463 allocate( judge( &
12464 & answer_shape(1), &
12465
12466 & answer_shape(2), &
12467
12468 & answer_shape(3) ) &
12469 & )
12470
12471 allocate( judge_rev( &
12472 & answer_shape(1), &
12473
12474 & answer_shape(2), &
12475
12476 & answer_shape(3) ) &
12477 & )
12478
12479 allocate( answer_negative( &
12480 & answer_shape(1), &
12481
12482 & answer_shape(2), &
12483
12484 & answer_shape(3) ) &
12485 & )
12486
12487 allocate( check_negative( &
12488 & answer_shape(1), &
12489
12490 & answer_shape(2), &
12491
12492 & answer_shape(3) ) &
12493 & )
12494
12495 allocate( both_negative( &
12496 & answer_shape(1), &
12497
12498 & answer_shape(2), &
12499
12500 & answer_shape(3) ) &
12501 & )
12502
12503 answer_negative = answer < 0.0_dp
12504 check_negative = check < 0.0_dp
12505 both_negative = answer_negative .and. check_negative
12506 if (.not. negative_support_on) both_negative = .false.
12507
12508 judge = answer < check
12509 where (both_negative) judge = .not. judge
12510
12511 judge_rev = .not. judge
12512 err_flag = any(judge_rev)
12513 mask_array = 1
12514 pos = maxloc(mask_array, judge_rev)
12515
12516 if (err_flag) then
12517
12518 wrong = check( &
12519 & pos(1), &
12520
12521 & pos(2), &
12522
12523 & pos(3) )
12524
12525 right = answer( &
12526 & pos(1), &
12527
12528 & pos(2), &
12529
12530 & pos(3) )
12531
12532 write(unit=pos_array(1), fmt="(i20)") pos(1)
12533
12534 write(unit=pos_array(2), fmt="(i20)") pos(2)
12535
12536 write(unit=pos_array(3), fmt="(i20)") pos(3)
12537
12538
12539 pos_str = '(' // &
12540 & trim(adjustl(pos_array(1))) // ',' // &
12541
12542 & trim(adjustl(pos_array(2))) // ',' // &
12543
12544 & trim(adjustl(pos_array(3))) // ')'
12545
12546 if ( both_negative( &
12547 & pos(1), &
12548
12549 & pos(2), &
12550
12551 & pos(3) ) ) then
12552
12553 abs_mes = 'ABSOLUTE value of'
12554 else
12555 abs_mes = ''
12556
12557 end if
12558
12559 end if
12560 deallocate(mask_array, judge, judge_rev)
12561 deallocate(answer_negative, check_negative, both_negative)
12562
12563
12564
12565
12566 if (err_flag) then
12567 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12568 write(*,*) ''
12569 write(*,*) ' ' // trim(abs_mes) // &
12570 & ' check' // trim(pos_str) // ' = ', wrong
12571 write(*,*) ' is NOT GREATER THAN'
12572 write(*,*) ' ' // trim(abs_mes) // &
12573 & ' answer' // trim(pos_str) // ' = ', right
12574
12575 call abortprogram('')
12576 else
12577 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12578 end if
12579
12580
12581 end subroutine dctestassertgreaterthandouble3
12582
12583
12584 subroutine dctestassertgreaterthandouble4( &
12585 & message, answer, check, negative_support)
12586 use sysdep, only: abortprogram
12587 use dc_types, only: string, token
12588 implicit none
12589 character(*), intent(in):: message
12590 real(DP), intent(in):: answer(:,:,:,:)
12591 real(DP), intent(in):: check(:,:,:,:)
12592 logical, intent(in), optional:: negative_support
12593 logical:: err_flag
12594 logical:: negative_support_on
12595 character(STRING):: pos_str
12596 character(TOKEN):: abs_mes
12597 real(DP):: wrong, right
12598
12599 integer:: answer_shape(4), check_shape(4), pos(4)
12600 logical:: consist_shape(4)
12601 character(TOKEN):: pos_array(4)
12602 integer, allocatable:: mask_array(:,:,:,:)
12603 logical, allocatable:: judge(:,:,:,:)
12604 logical, allocatable:: judge_rev(:,:,:,:)
12605 logical, allocatable:: answer_negative(:,:,:,:)
12606 logical, allocatable:: check_negative(:,:,:,:)
12607 logical, allocatable:: both_negative(:,:,:,:)
12608
12609
12610 continue
12611 if (present(negative_support)) then
12612 negative_support_on = negative_support
12613 else
12614 negative_support_on = .true.
12615 end if
12616
12617 err_flag = .false.
12618
12619
12620 answer_shape = shape(answer)
12621 check_shape = shape(check)
12622
12623 consist_shape = answer_shape == check_shape
12624
12625 if (.not. all(consist_shape)) then
12626 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12627 write(*,*) ''
12628 write(*,*) ' shape of check is (', check_shape, ')'
12629 write(*,*) ' is INCORRECT'
12630 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
12631
12632 call abortprogram('')
12633 end if
12634
12635
12636 allocate( mask_array( &
12637 & answer_shape(1), &
12638
12639 & answer_shape(2), &
12640
12641 & answer_shape(3), &
12642
12643 & answer_shape(4) ) &
12644 & )
12645
12646 allocate( judge( &
12647 & answer_shape(1), &
12648
12649 & answer_shape(2), &
12650
12651 & answer_shape(3), &
12652
12653 & answer_shape(4) ) &
12654 & )
12655
12656 allocate( judge_rev( &
12657 & answer_shape(1), &
12658
12659 & answer_shape(2), &
12660
12661 & answer_shape(3), &
12662
12663 & answer_shape(4) ) &
12664 & )
12665
12666 allocate( answer_negative( &
12667 & answer_shape(1), &
12668
12669 & answer_shape(2), &
12670
12671 & answer_shape(3), &
12672
12673 & answer_shape(4) ) &
12674 & )
12675
12676 allocate( check_negative( &
12677 & answer_shape(1), &
12678
12679 & answer_shape(2), &
12680
12681 & answer_shape(3), &
12682
12683 & answer_shape(4) ) &
12684 & )
12685
12686 allocate( both_negative( &
12687 & answer_shape(1), &
12688
12689 & answer_shape(2), &
12690
12691 & answer_shape(3), &
12692
12693 & answer_shape(4) ) &
12694 & )
12695
12696 answer_negative = answer < 0.0_dp
12697 check_negative = check < 0.0_dp
12698 both_negative = answer_negative .and. check_negative
12699 if (.not. negative_support_on) both_negative = .false.
12700
12701 judge = answer < check
12702 where (both_negative) judge = .not. judge
12703
12704 judge_rev = .not. judge
12705 err_flag = any(judge_rev)
12706 mask_array = 1
12707 pos = maxloc(mask_array, judge_rev)
12708
12709 if (err_flag) then
12710
12711 wrong = check( &
12712 & pos(1), &
12713
12714 & pos(2), &
12715
12716 & pos(3), &
12717
12718 & pos(4) )
12719
12720 right = answer( &
12721 & pos(1), &
12722
12723 & pos(2), &
12724
12725 & pos(3), &
12726
12727 & pos(4) )
12728
12729 write(unit=pos_array(1), fmt="(i20)") pos(1)
12730
12731 write(unit=pos_array(2), fmt="(i20)") pos(2)
12732
12733 write(unit=pos_array(3), fmt="(i20)") pos(3)
12734
12735 write(unit=pos_array(4), fmt="(i20)") pos(4)
12736
12737
12738 pos_str = '(' // &
12739 & trim(adjustl(pos_array(1))) // ',' // &
12740
12741 & trim(adjustl(pos_array(2))) // ',' // &
12742
12743 & trim(adjustl(pos_array(3))) // ',' // &
12744
12745 & trim(adjustl(pos_array(4))) // ')'
12746
12747 if ( both_negative( &
12748 & pos(1), &
12749
12750 & pos(2), &
12751
12752 & pos(3), &
12753
12754 & pos(4) ) ) then
12755
12756 abs_mes = 'ABSOLUTE value of'
12757 else
12758 abs_mes = ''
12759
12760 end if
12761
12762 end if
12763 deallocate(mask_array, judge, judge_rev)
12764 deallocate(answer_negative, check_negative, both_negative)
12765
12766
12767
12768
12769 if (err_flag) then
12770 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12771 write(*,*) ''
12772 write(*,*) ' ' // trim(abs_mes) // &
12773 & ' check' // trim(pos_str) // ' = ', wrong
12774 write(*,*) ' is NOT GREATER THAN'
12775 write(*,*) ' ' // trim(abs_mes) // &
12776 & ' answer' // trim(pos_str) // ' = ', right
12777
12778 call abortprogram('')
12779 else
12780 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12781 end if
12782
12783
12784 end subroutine dctestassertgreaterthandouble4
12785
12786
12787 subroutine dctestassertgreaterthandouble5( &
12788 & message, answer, check, negative_support)
12789 use sysdep, only: abortprogram
12790 use dc_types, only: string, token
12791 implicit none
12792 character(*), intent(in):: message
12793 real(DP), intent(in):: answer(:,:,:,:,:)
12794 real(DP), intent(in):: check(:,:,:,:,:)
12795 logical, intent(in), optional:: negative_support
12796 logical:: err_flag
12797 logical:: negative_support_on
12798 character(STRING):: pos_str
12799 character(TOKEN):: abs_mes
12800 real(DP):: wrong, right
12801
12802 integer:: answer_shape(5), check_shape(5), pos(5)
12803 logical:: consist_shape(5)
12804 character(TOKEN):: pos_array(5)
12805 integer, allocatable:: mask_array(:,:,:,:,:)
12806 logical, allocatable:: judge(:,:,:,:,:)
12807 logical, allocatable:: judge_rev(:,:,:,:,:)
12808 logical, allocatable:: answer_negative(:,:,:,:,:)
12809 logical, allocatable:: check_negative(:,:,:,:,:)
12810 logical, allocatable:: both_negative(:,:,:,:,:)
12811
12812
12813 continue
12814 if (present(negative_support)) then
12815 negative_support_on = negative_support
12816 else
12817 negative_support_on = .true.
12818 end if
12819
12820 err_flag = .false.
12821
12822
12823 answer_shape = shape(answer)
12824 check_shape = shape(check)
12825
12826 consist_shape = answer_shape == check_shape
12827
12828 if (.not. all(consist_shape)) then
12829 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12830 write(*,*) ''
12831 write(*,*) ' shape of check is (', check_shape, ')'
12832 write(*,*) ' is INCORRECT'
12833 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
12834
12835 call abortprogram('')
12836 end if
12837
12838
12839 allocate( mask_array( &
12840 & answer_shape(1), &
12841
12842 & answer_shape(2), &
12843
12844 & answer_shape(3), &
12845
12846 & answer_shape(4), &
12847
12848 & answer_shape(5) ) &
12849 & )
12850
12851 allocate( judge( &
12852 & answer_shape(1), &
12853
12854 & answer_shape(2), &
12855
12856 & answer_shape(3), &
12857
12858 & answer_shape(4), &
12859
12860 & answer_shape(5) ) &
12861 & )
12862
12863 allocate( judge_rev( &
12864 & answer_shape(1), &
12865
12866 & answer_shape(2), &
12867
12868 & answer_shape(3), &
12869
12870 & answer_shape(4), &
12871
12872 & answer_shape(5) ) &
12873 & )
12874
12875 allocate( answer_negative( &
12876 & answer_shape(1), &
12877
12878 & answer_shape(2), &
12879
12880 & answer_shape(3), &
12881
12882 & answer_shape(4), &
12883
12884 & answer_shape(5) ) &
12885 & )
12886
12887 allocate( check_negative( &
12888 & answer_shape(1), &
12889
12890 & answer_shape(2), &
12891
12892 & answer_shape(3), &
12893
12894 & answer_shape(4), &
12895
12896 & answer_shape(5) ) &
12897 & )
12898
12899 allocate( both_negative( &
12900 & answer_shape(1), &
12901
12902 & answer_shape(2), &
12903
12904 & answer_shape(3), &
12905
12906 & answer_shape(4), &
12907
12908 & answer_shape(5) ) &
12909 & )
12910
12911 answer_negative = answer < 0.0_dp
12912 check_negative = check < 0.0_dp
12913 both_negative = answer_negative .and. check_negative
12914 if (.not. negative_support_on) both_negative = .false.
12915
12916 judge = answer < check
12917 where (both_negative) judge = .not. judge
12918
12919 judge_rev = .not. judge
12920 err_flag = any(judge_rev)
12921 mask_array = 1
12922 pos = maxloc(mask_array, judge_rev)
12923
12924 if (err_flag) then
12925
12926 wrong = check( &
12927 & pos(1), &
12928
12929 & pos(2), &
12930
12931 & pos(3), &
12932
12933 & pos(4), &
12934
12935 & pos(5) )
12936
12937 right = answer( &
12938 & pos(1), &
12939
12940 & pos(2), &
12941
12942 & pos(3), &
12943
12944 & pos(4), &
12945
12946 & pos(5) )
12947
12948 write(unit=pos_array(1), fmt="(i20)") pos(1)
12949
12950 write(unit=pos_array(2), fmt="(i20)") pos(2)
12951
12952 write(unit=pos_array(3), fmt="(i20)") pos(3)
12953
12954 write(unit=pos_array(4), fmt="(i20)") pos(4)
12955
12956 write(unit=pos_array(5), fmt="(i20)") pos(5)
12957
12958
12959 pos_str = '(' // &
12960 & trim(adjustl(pos_array(1))) // ',' // &
12961
12962 & trim(adjustl(pos_array(2))) // ',' // &
12963
12964 & trim(adjustl(pos_array(3))) // ',' // &
12965
12966 & trim(adjustl(pos_array(4))) // ',' // &
12967
12968 & trim(adjustl(pos_array(5))) // ')'
12969
12970 if ( both_negative( &
12971 & pos(1), &
12972
12973 & pos(2), &
12974
12975 & pos(3), &
12976
12977 & pos(4), &
12978
12979 & pos(5) ) ) then
12980
12981 abs_mes = 'ABSOLUTE value of'
12982 else
12983 abs_mes = ''
12984
12985 end if
12986
12987 end if
12988 deallocate(mask_array, judge, judge_rev)
12989 deallocate(answer_negative, check_negative, both_negative)
12990
12991
12992
12993
12994 if (err_flag) then
12995 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12996 write(*,*) ''
12997 write(*,*) ' ' // trim(abs_mes) // &
12998 & ' check' // trim(pos_str) // ' = ', wrong
12999 write(*,*) ' is NOT GREATER THAN'
13000 write(*,*) ' ' // trim(abs_mes) // &
13001 & ' answer' // trim(pos_str) // ' = ', right
13002
13003 call abortprogram('')
13004 else
13005 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
13006 end if
13007
13008
13009 end subroutine dctestassertgreaterthandouble5
13010
13011
13012 subroutine dctestassertgreaterthandouble6( &
13013 & message, answer, check, negative_support)
13014 use sysdep, only: abortprogram
13015 use dc_types, only: string, token
13016 implicit none
13017 character(*), intent(in):: message
13018 real(DP), intent(in):: answer(:,:,:,:,:,:)
13019 real(DP), intent(in):: check(:,:,:,:,:,:)
13020 logical, intent(in), optional:: negative_support
13021 logical:: err_flag
13022 logical:: negative_support_on
13023 character(STRING):: pos_str
13024 character(TOKEN):: abs_mes
13025 real(DP):: wrong, right
13026
13027 integer:: answer_shape(6), check_shape(6), pos(6)
13028 logical:: consist_shape(6)
13029 character(TOKEN):: pos_array(6)
13030 integer, allocatable:: mask_array(:,:,:,:,:,:)
13031 logical, allocatable:: judge(:,:,:,:,:,:)
13032 logical, allocatable:: judge_rev(:,:,:,:,:,:)
13033 logical, allocatable:: answer_negative(:,:,:,:,:,:)
13034 logical, allocatable:: check_negative(:,:,:,:,:,:)
13035 logical, allocatable:: both_negative(:,:,:,:,:,:)
13036
13037
13038 continue
13039 if (present(negative_support)) then
13040 negative_support_on = negative_support
13041 else
13042 negative_support_on = .true.
13043 end if
13044
13045 err_flag = .false.
13046
13047
13048 answer_shape = shape(answer)
13049 check_shape = shape(check)
13050
13051 consist_shape = answer_shape == check_shape
13052
13053 if (.not. all(consist_shape)) then
13054 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
13055 write(*,*) ''
13056 write(*,*) ' shape of check is (', check_shape, ')'
13057 write(*,*) ' is INCORRECT'
13058 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
13059
13060 call abortprogram('')
13061 end if
13062
13063
13064 allocate( mask_array( &
13065 & answer_shape(1), &
13066
13067 & answer_shape(2), &
13068
13069 & answer_shape(3), &
13070
13071 & answer_shape(4), &
13072
13073 & answer_shape(5), &
13074
13075 & answer_shape(6) ) &
13076 & )
13077
13078 allocate( judge( &
13079 & answer_shape(1), &
13080
13081 & answer_shape(2), &
13082
13083 & answer_shape(3), &
13084
13085 & answer_shape(4), &
13086
13087 & answer_shape(5), &
13088
13089 & answer_shape(6) ) &
13090 & )
13091
13092 allocate( judge_rev( &
13093 & answer_shape(1), &
13094
13095 & answer_shape(2), &
13096
13097 & answer_shape(3), &
13098
13099 & answer_shape(4), &
13100
13101 & answer_shape(5), &
13102
13103 & answer_shape(6) ) &
13104 & )
13105
13106 allocate( answer_negative( &
13107 & answer_shape(1), &
13108
13109 & answer_shape(2), &
13110
13111 & answer_shape(3), &
13112
13113 & answer_shape(4), &
13114
13115 & answer_shape(5), &
13116
13117 & answer_shape(6) ) &
13118 & )
13119
13120 allocate( check_negative( &
13121 & answer_shape(1), &
13122
13123 & answer_shape(2), &
13124
13125 & answer_shape(3), &
13126
13127 & answer_shape(4), &
13128
13129 & answer_shape(5), &
13130
13131 & answer_shape(6) ) &
13132 & )
13133
13134 allocate( both_negative( &
13135 & answer_shape(1), &
13136
13137 & answer_shape(2), &
13138
13139 & answer_shape(3), &
13140
13141 & answer_shape(4), &
13142
13143 & answer_shape(5), &
13144
13145 & answer_shape(6) ) &
13146 & )
13147
13148 answer_negative = answer < 0.0_dp
13149 check_negative = check < 0.0_dp
13150 both_negative = answer_negative .and. check_negative
13151 if (.not. negative_support_on) both_negative = .false.
13152
13153 judge = answer < check
13154 where (both_negative) judge = .not. judge
13155
13156 judge_rev = .not. judge
13157 err_flag = any(judge_rev)
13158 mask_array = 1
13159 pos = maxloc(mask_array, judge_rev)
13160
13161 if (err_flag) then
13162
13163 wrong = check( &
13164 & pos(1), &
13165
13166 & pos(2), &
13167
13168 & pos(3), &
13169
13170 & pos(4), &
13171
13172 & pos(5), &
13173
13174 & pos(6) )
13175
13176 right = answer( &
13177 & pos(1), &
13178
13179 & pos(2), &
13180
13181 & pos(3), &
13182
13183 & pos(4), &
13184
13185 & pos(5), &
13186
13187 & pos(6) )
13188
13189 write(unit=pos_array(1), fmt="(i20)") pos(1)
13190
13191 write(unit=pos_array(2), fmt="(i20)") pos(2)
13192
13193 write(unit=pos_array(3), fmt="(i20)") pos(3)
13194
13195 write(unit=pos_array(4), fmt="(i20)") pos(4)
13196
13197 write(unit=pos_array(5), fmt="(i20)") pos(5)
13198
13199 write(unit=pos_array(6), fmt="(i20)") pos(6)
13200
13201
13202 pos_str = '(' // &
13203 & trim(adjustl(pos_array(1))) // ',' // &
13204
13205 & trim(adjustl(pos_array(2))) // ',' // &
13206
13207 & trim(adjustl(pos_array(3))) // ',' // &
13208
13209 & trim(adjustl(pos_array(4))) // ',' // &
13210
13211 & trim(adjustl(pos_array(5))) // ',' // &
13212
13213 & trim(adjustl(pos_array(6))) // ')'
13214
13215 if ( both_negative( &
13216 & pos(1), &
13217
13218 & pos(2), &
13219
13220 & pos(3), &
13221
13222 & pos(4), &
13223
13224 & pos(5), &
13225
13226 & pos(6) ) ) then
13227
13228 abs_mes = 'ABSOLUTE value of'
13229 else
13230 abs_mes = ''
13231
13232 end if
13233
13234 end if
13235 deallocate(mask_array, judge, judge_rev)
13236 deallocate(answer_negative, check_negative, both_negative)
13237
13238
13239
13240
13241 if (err_flag) then
13242 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
13243 write(*,*) ''
13244 write(*,*) ' ' // trim(abs_mes) // &
13245 & ' check' // trim(pos_str) // ' = ', wrong
13246 write(*,*) ' is NOT GREATER THAN'
13247 write(*,*) ' ' // trim(abs_mes) // &
13248 & ' answer' // trim(pos_str) // ' = ', right
13249
13250 call abortprogram('')
13251 else
13252 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
13253 end if
13254
13255
13256 end subroutine dctestassertgreaterthandouble6
13257
13258
13259 subroutine dctestassertgreaterthandouble7( &
13260 & message, answer, check, negative_support)
13261 use sysdep, only: abortprogram
13262 use dc_types, only: string, token
13263 implicit none
13264 character(*), intent(in):: message
13265 real(DP), intent(in):: answer(:,:,:,:,:,:,:)
13266 real(DP), intent(in):: check(:,:,:,:,:,:,:)
13267 logical, intent(in), optional:: negative_support
13268 logical:: err_flag
13269 logical:: negative_support_on
13270 character(STRING):: pos_str
13271 character(TOKEN):: abs_mes
13272 real(DP):: wrong, right
13273
13274 integer:: answer_shape(7), check_shape(7), pos(7)
13275 logical:: consist_shape(7)
13276 character(TOKEN):: pos_array(7)
13277 integer, allocatable:: mask_array(:,:,:,:,:,:,:)
13278 logical, allocatable:: judge(:,:,:,:,:,:,:)
13279 logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
13280 logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
13281 logical, allocatable:: check_negative(:,:,:,:,:,:,:)
13282 logical, allocatable:: both_negative(:,:,:,:,:,:,:)
13283
13284
13285 continue
13286 if (present(negative_support)) then
13287 negative_support_on = negative_support
13288 else
13289 negative_support_on = .true.
13290 end if
13291
13292 err_flag = .false.
13293
13294
13295 answer_shape = shape(answer)
13296 check_shape = shape(check)
13297
13298 consist_shape = answer_shape == check_shape
13299
13300 if (.not. all(consist_shape)) then
13301 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
13302 write(*,*) ''
13303 write(*,*) ' shape of check is (', check_shape, ')'
13304 write(*,*) ' is INCORRECT'
13305 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
13306
13307 call abortprogram('')
13308 end if
13309
13310
13311 allocate( mask_array( &
13312 & answer_shape(1), &
13313
13314 & answer_shape(2), &
13315
13316 & answer_shape(3), &
13317
13318 & answer_shape(4), &
13319
13320 & answer_shape(5), &
13321
13322 & answer_shape(6), &
13323
13324 & answer_shape(7) ) &
13325 & )
13326
13327 allocate( judge( &
13328 & answer_shape(1), &
13329
13330 & answer_shape(2), &
13331
13332 & answer_shape(3), &
13333
13334 & answer_shape(4), &
13335
13336 & answer_shape(5), &
13337
13338 & answer_shape(6), &
13339
13340 & answer_shape(7) ) &
13341 & )
13342
13343 allocate( judge_rev( &
13344 & answer_shape(1), &
13345
13346 & answer_shape(2), &
13347
13348 & answer_shape(3), &
13349
13350 & answer_shape(4), &
13351
13352 & answer_shape(5), &
13353
13354 & answer_shape(6), &
13355
13356 & answer_shape(7) ) &
13357 & )
13358
13359 allocate( answer_negative( &
13360 & answer_shape(1), &
13361
13362 & answer_shape(2), &
13363
13364 & answer_shape(3), &
13365
13366 & answer_shape(4), &
13367
13368 & answer_shape(5), &
13369
13370 & answer_shape(6), &
13371
13372 & answer_shape(7) ) &
13373 & )
13374
13375 allocate( check_negative( &
13376 & answer_shape(1), &
13377
13378 & answer_shape(2), &
13379
13380 & answer_shape(3), &
13381
13382 & answer_shape(4), &
13383
13384 & answer_shape(5), &
13385
13386 & answer_shape(6), &
13387
13388 & answer_shape(7) ) &
13389 & )
13390
13391 allocate( both_negative( &
13392 & answer_shape(1), &
13393
13394 & answer_shape(2), &
13395
13396 & answer_shape(3), &
13397
13398 & answer_shape(4), &
13399
13400 & answer_shape(5), &
13401
13402 & answer_shape(6), &
13403
13404 & answer_shape(7) ) &
13405 & )
13406
13407 answer_negative = answer < 0.0_dp
13408 check_negative = check < 0.0_dp
13409 both_negative = answer_negative .and. check_negative
13410 if (.not. negative_support_on) both_negative = .false.
13411
13412 judge = answer < check
13413 where (both_negative) judge = .not. judge
13414
13415 judge_rev = .not. judge
13416 err_flag = any(judge_rev)
13417 mask_array = 1
13418 pos = maxloc(mask_array, judge_rev)
13419
13420 if (err_flag) then
13421
13422 wrong = check( &
13423 & pos(1), &
13424
13425 & pos(2), &
13426
13427 & pos(3), &
13428
13429 & pos(4), &
13430
13431 & pos(5), &
13432
13433 & pos(6), &
13434
13435 & pos(7) )
13436
13437 right = answer( &
13438 & pos(1), &
13439
13440 & pos(2), &
13441
13442 & pos(3), &
13443
13444 & pos(4), &
13445
13446 & pos(5), &
13447
13448 & pos(6), &
13449
13450 & pos(7) )
13451
13452 write(unit=pos_array(1), fmt="(i20)") pos(1)
13453
13454 write(unit=pos_array(2), fmt="(i20)") pos(2)
13455
13456 write(unit=pos_array(3), fmt="(i20)") pos(3)
13457
13458 write(unit=pos_array(4), fmt="(i20)") pos(4)
13459
13460 write(unit=pos_array(5), fmt="(i20)") pos(5)
13461
13462 write(unit=pos_array(6), fmt="(i20)") pos(6)
13463
13464 write(unit=pos_array(7), fmt="(i20)") pos(7)
13465
13466
13467 pos_str = '(' // &
13468 & trim(adjustl(pos_array(1))) // ',' // &
13469
13470 & trim(adjustl(pos_array(2))) // ',' // &
13471
13472 & trim(adjustl(pos_array(3))) // ',' // &
13473
13474 & trim(adjustl(pos_array(4))) // ',' // &
13475
13476 & trim(adjustl(pos_array(5))) // ',' // &
13477
13478 & trim(adjustl(pos_array(6))) // ',' // &
13479
13480 & trim(adjustl(pos_array(7))) // ')'
13481
13482 if ( both_negative( &
13483 & pos(1), &
13484
13485 & pos(2), &
13486
13487 & pos(3), &
13488
13489 & pos(4), &
13490
13491 & pos(5), &
13492
13493 & pos(6), &
13494
13495 & pos(7) ) ) then
13496
13497 abs_mes = 'ABSOLUTE value of'
13498 else
13499 abs_mes = ''
13500
13501 end if
13502
13503 end if
13504 deallocate(mask_array, judge, judge_rev)
13505 deallocate(answer_negative, check_negative, both_negative)
13506
13507
13508
13509
13510 if (err_flag) then
13511 write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
13512 write(*,*) ''
13513 write(*,*) ' ' // trim(abs_mes) // &
13514 & ' check' // trim(pos_str) // ' = ', wrong
13515 write(*,*) ' is NOT GREATER THAN'
13516 write(*,*) ' ' // trim(abs_mes) // &
13517 & ' answer' // trim(pos_str) // ' = ', right
13518
13519 call abortprogram('')
13520 else
13521 write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
13522 end if
13523
13524
13525 end subroutine dctestassertgreaterthandouble7
13526
13527
13528 subroutine dctestassertlessthanint0( &
13529 & message, answer, check, negative_support)
13530 use sysdep, only: abortprogram
13531 use dc_types, only: string, token
13532 implicit none
13533 character(*), intent(in):: message
13534 integer, intent(in):: answer
13535 integer, intent(in):: check
13536 logical, intent(in), optional:: negative_support
13537 logical:: err_flag
13538 logical:: negative_support_on
13539 character(STRING):: pos_str
13540 character(TOKEN):: abs_mes
13541 integer:: wrong, right
13542
13543
13544
13545 continue
13546 if (present(negative_support)) then
13547 negative_support_on = negative_support
13548 else
13549 negative_support_on = .true.
13550 end if
13551
13552 err_flag = .false.
13553
13554
13555
13556
13557 err_flag = .not. answer > check
13558 abs_mes = ''
13559
13560 if ( answer < 0 &
13561 & .and. check < 0 &
13562 & .and. negative_support_on ) then
13563
13564 err_flag = .not. err_flag
13565 abs_mes = 'ABSOLUTE value of'
13566 end if
13567
13568 wrong = check
13569 right = answer
13570 pos_str = ''
13571
13572
13573
13574
13575 if (err_flag) then
13576 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13577 write(*,*) ''
13578 write(*,*) ' ' // trim(abs_mes) // &
13579 & ' check' // trim(pos_str) // ' = ', wrong
13580 write(*,*) ' is NOT LESS THAN'
13581 write(*,*) ' ' // trim(abs_mes) // &
13582 & ' answer' // trim(pos_str) // ' = ', right
13583
13584 call abortprogram('')
13585 else
13586 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
13587 end if
13588
13589
13590 end subroutine dctestassertlessthanint0
13591
13592
13593 subroutine dctestassertlessthanint1( &
13594 & message, answer, check, negative_support)
13595 use sysdep, only: abortprogram
13596 use dc_types, only: string, token
13597 implicit none
13598 character(*), intent(in):: message
13599 integer, intent(in):: answer(:)
13600 integer, intent(in):: check(:)
13601 logical, intent(in), optional:: negative_support
13602 logical:: err_flag
13603 logical:: negative_support_on
13604 character(STRING):: pos_str
13605 character(TOKEN):: abs_mes
13606 integer:: wrong, right
13607
13608 integer:: answer_shape(1), check_shape(1), pos(1)
13609 logical:: consist_shape(1)
13610 character(TOKEN):: pos_array(1)
13611 integer, allocatable:: mask_array(:)
13612 logical, allocatable:: judge(:)
13613 logical, allocatable:: judge_rev(:)
13614 logical, allocatable:: answer_negative(:)
13615 logical, allocatable:: check_negative(:)
13616 logical, allocatable:: both_negative(:)
13617
13618
13619 continue
13620 if (present(negative_support)) then
13621 negative_support_on = negative_support
13622 else
13623 negative_support_on = .true.
13624 end if
13625
13626 err_flag = .false.
13627
13628
13629 answer_shape = shape(answer)
13630 check_shape = shape(check)
13631
13632 consist_shape = answer_shape == check_shape
13633
13634 if (.not. all(consist_shape)) then
13635 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13636 write(*,*) ''
13637 write(*,*) ' shape of check is (', check_shape, ')'
13638 write(*,*) ' is INCORRECT'
13639 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
13640
13641 call abortprogram('')
13642 end if
13643
13644
13645 allocate( mask_array( &
13646
13647 & answer_shape(1) ) &
13648 & )
13649
13650 allocate( judge( &
13651
13652 & answer_shape(1) ) &
13653 & )
13654
13655 allocate( judge_rev( &
13656
13657 & answer_shape(1) ) &
13658 & )
13659
13660 allocate( answer_negative( &
13661
13662 & answer_shape(1) ) &
13663 & )
13664
13665 allocate( check_negative( &
13666
13667 & answer_shape(1) ) &
13668 & )
13669
13670 allocate( both_negative( &
13671
13672 & answer_shape(1) ) &
13673 & )
13674
13675 answer_negative = answer < 0
13676 check_negative = check < 0
13677 both_negative = answer_negative .and. check_negative
13678 if (.not. negative_support_on) both_negative = .false.
13679
13680 judge = answer > check
13681 where (both_negative) judge = .not. judge
13682
13683 judge_rev = .not. judge
13684 err_flag = any(judge_rev)
13685 mask_array = 1
13686 pos = maxloc(mask_array, judge_rev)
13687
13688 if (err_flag) then
13689
13690 wrong = check( &
13691
13692 & pos(1) )
13693
13694 right = answer( &
13695
13696 & pos(1) )
13697
13698 write(unit=pos_array(1), fmt="(i20)") pos(1)
13699
13700
13701 pos_str = '(' // &
13702
13703 & trim(adjustl(pos_array(1))) // ')'
13704
13705 if ( both_negative( &
13706
13707 & pos(1) ) ) then
13708
13709 abs_mes = 'ABSOLUTE value of'
13710 else
13711 abs_mes = ''
13712
13713 end if
13714
13715 end if
13716 deallocate(mask_array, judge, judge_rev)
13717 deallocate(answer_negative, check_negative, both_negative)
13718
13719
13720
13721
13722 if (err_flag) then
13723 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13724 write(*,*) ''
13725 write(*,*) ' ' // trim(abs_mes) // &
13726 & ' check' // trim(pos_str) // ' = ', wrong
13727 write(*,*) ' is NOT LESS THAN'
13728 write(*,*) ' ' // trim(abs_mes) // &
13729 & ' answer' // trim(pos_str) // ' = ', right
13730
13731 call abortprogram('')
13732 else
13733 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
13734 end if
13735
13736
13737 end subroutine dctestassertlessthanint1
13738
13739
13740 subroutine dctestassertlessthanint2( &
13741 & message, answer, check, negative_support)
13742 use sysdep, only: abortprogram
13743 use dc_types, only: string, token
13744 implicit none
13745 character(*), intent(in):: message
13746 integer, intent(in):: answer(:,:)
13747 integer, intent(in):: check(:,:)
13748 logical, intent(in), optional:: negative_support
13749 logical:: err_flag
13750 logical:: negative_support_on
13751 character(STRING):: pos_str
13752 character(TOKEN):: abs_mes
13753 integer:: wrong, right
13754
13755 integer:: answer_shape(2), check_shape(2), pos(2)
13756 logical:: consist_shape(2)
13757 character(TOKEN):: pos_array(2)
13758 integer, allocatable:: mask_array(:,:)
13759 logical, allocatable:: judge(:,:)
13760 logical, allocatable:: judge_rev(:,:)
13761 logical, allocatable:: answer_negative(:,:)
13762 logical, allocatable:: check_negative(:,:)
13763 logical, allocatable:: both_negative(:,:)
13764
13765
13766 continue
13767 if (present(negative_support)) then
13768 negative_support_on = negative_support
13769 else
13770 negative_support_on = .true.
13771 end if
13772
13773 err_flag = .false.
13774
13775
13776 answer_shape = shape(answer)
13777 check_shape = shape(check)
13778
13779 consist_shape = answer_shape == check_shape
13780
13781 if (.not. all(consist_shape)) then
13782 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13783 write(*,*) ''
13784 write(*,*) ' shape of check is (', check_shape, ')'
13785 write(*,*) ' is INCORRECT'
13786 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
13787
13788 call abortprogram('')
13789 end if
13790
13791
13792 allocate( mask_array( &
13793 & answer_shape(1), &
13794
13795 & answer_shape(2) ) &
13796 & )
13797
13798 allocate( judge( &
13799 & answer_shape(1), &
13800
13801 & answer_shape(2) ) &
13802 & )
13803
13804 allocate( judge_rev( &
13805 & answer_shape(1), &
13806
13807 & answer_shape(2) ) &
13808 & )
13809
13810 allocate( answer_negative( &
13811 & answer_shape(1), &
13812
13813 & answer_shape(2) ) &
13814 & )
13815
13816 allocate( check_negative( &
13817 & answer_shape(1), &
13818
13819 & answer_shape(2) ) &
13820 & )
13821
13822 allocate( both_negative( &
13823 & answer_shape(1), &
13824
13825 & answer_shape(2) ) &
13826 & )
13827
13828 answer_negative = answer < 0
13829 check_negative = check < 0
13830 both_negative = answer_negative .and. check_negative
13831 if (.not. negative_support_on) both_negative = .false.
13832
13833 judge = answer > check
13834 where (both_negative) judge = .not. judge
13835
13836 judge_rev = .not. judge
13837 err_flag = any(judge_rev)
13838 mask_array = 1
13839 pos = maxloc(mask_array, judge_rev)
13840
13841 if (err_flag) then
13842
13843 wrong = check( &
13844 & pos(1), &
13845
13846 & pos(2) )
13847
13848 right = answer( &
13849 & pos(1), &
13850
13851 & pos(2) )
13852
13853 write(unit=pos_array(1), fmt="(i20)") pos(1)
13854
13855 write(unit=pos_array(2), fmt="(i20)") pos(2)
13856
13857
13858 pos_str = '(' // &
13859 & trim(adjustl(pos_array(1))) // ',' // &
13860
13861 & trim(adjustl(pos_array(2))) // ')'
13862
13863 if ( both_negative( &
13864 & pos(1), &
13865
13866 & pos(2) ) ) then
13867
13868 abs_mes = 'ABSOLUTE value of'
13869 else
13870 abs_mes = ''
13871
13872 end if
13873
13874 end if
13875 deallocate(mask_array, judge, judge_rev)
13876 deallocate(answer_negative, check_negative, both_negative)
13877
13878
13879
13880
13881 if (err_flag) then
13882 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13883 write(*,*) ''
13884 write(*,*) ' ' // trim(abs_mes) // &
13885 & ' check' // trim(pos_str) // ' = ', wrong
13886 write(*,*) ' is NOT LESS THAN'
13887 write(*,*) ' ' // trim(abs_mes) // &
13888 & ' answer' // trim(pos_str) // ' = ', right
13889
13890 call abortprogram('')
13891 else
13892 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
13893 end if
13894
13895
13896 end subroutine dctestassertlessthanint2
13897
13898
13899 subroutine dctestassertlessthanint3( &
13900 & message, answer, check, negative_support)
13901 use sysdep, only: abortprogram
13902 use dc_types, only: string, token
13903 implicit none
13904 character(*), intent(in):: message
13905 integer, intent(in):: answer(:,:,:)
13906 integer, intent(in):: check(:,:,:)
13907 logical, intent(in), optional:: negative_support
13908 logical:: err_flag
13909 logical:: negative_support_on
13910 character(STRING):: pos_str
13911 character(TOKEN):: abs_mes
13912 integer:: wrong, right
13913
13914 integer:: answer_shape(3), check_shape(3), pos(3)
13915 logical:: consist_shape(3)
13916 character(TOKEN):: pos_array(3)
13917 integer, allocatable:: mask_array(:,:,:)
13918 logical, allocatable:: judge(:,:,:)
13919 logical, allocatable:: judge_rev(:,:,:)
13920 logical, allocatable:: answer_negative(:,:,:)
13921 logical, allocatable:: check_negative(:,:,:)
13922 logical, allocatable:: both_negative(:,:,:)
13923
13924
13925 continue
13926 if (present(negative_support)) then
13927 negative_support_on = negative_support
13928 else
13929 negative_support_on = .true.
13930 end if
13931
13932 err_flag = .false.
13933
13934
13935 answer_shape = shape(answer)
13936 check_shape = shape(check)
13937
13938 consist_shape = answer_shape == check_shape
13939
13940 if (.not. all(consist_shape)) then
13941 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13942 write(*,*) ''
13943 write(*,*) ' shape of check is (', check_shape, ')'
13944 write(*,*) ' is INCORRECT'
13945 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
13946
13947 call abortprogram('')
13948 end if
13949
13950
13951 allocate( mask_array( &
13952 & answer_shape(1), &
13953
13954 & answer_shape(2), &
13955
13956 & answer_shape(3) ) &
13957 & )
13958
13959 allocate( judge( &
13960 & answer_shape(1), &
13961
13962 & answer_shape(2), &
13963
13964 & answer_shape(3) ) &
13965 & )
13966
13967 allocate( judge_rev( &
13968 & answer_shape(1), &
13969
13970 & answer_shape(2), &
13971
13972 & answer_shape(3) ) &
13973 & )
13974
13975 allocate( answer_negative( &
13976 & answer_shape(1), &
13977
13978 & answer_shape(2), &
13979
13980 & answer_shape(3) ) &
13981 & )
13982
13983 allocate( check_negative( &
13984 & answer_shape(1), &
13985
13986 & answer_shape(2), &
13987
13988 & answer_shape(3) ) &
13989 & )
13990
13991 allocate( both_negative( &
13992 & answer_shape(1), &
13993
13994 & answer_shape(2), &
13995
13996 & answer_shape(3) ) &
13997 & )
13998
13999 answer_negative = answer < 0
14000 check_negative = check < 0
14001 both_negative = answer_negative .and. check_negative
14002 if (.not. negative_support_on) both_negative = .false.
14003
14004 judge = answer > check
14005 where (both_negative) judge = .not. judge
14006
14007 judge_rev = .not. judge
14008 err_flag = any(judge_rev)
14009 mask_array = 1
14010 pos = maxloc(mask_array, judge_rev)
14011
14012 if (err_flag) then
14013
14014 wrong = check( &
14015 & pos(1), &
14016
14017 & pos(2), &
14018
14019 & pos(3) )
14020
14021 right = answer( &
14022 & pos(1), &
14023
14024 & pos(2), &
14025
14026 & pos(3) )
14027
14028 write(unit=pos_array(1), fmt="(i20)") pos(1)
14029
14030 write(unit=pos_array(2), fmt="(i20)") pos(2)
14031
14032 write(unit=pos_array(3), fmt="(i20)") pos(3)
14033
14034
14035 pos_str = '(' // &
14036 & trim(adjustl(pos_array(1))) // ',' // &
14037
14038 & trim(adjustl(pos_array(2))) // ',' // &
14039
14040 & trim(adjustl(pos_array(3))) // ')'
14041
14042 if ( both_negative( &
14043 & pos(1), &
14044
14045 & pos(2), &
14046
14047 & pos(3) ) ) then
14048
14049 abs_mes = 'ABSOLUTE value of'
14050 else
14051 abs_mes = ''
14052
14053 end if
14054
14055 end if
14056 deallocate(mask_array, judge, judge_rev)
14057 deallocate(answer_negative, check_negative, both_negative)
14058
14059
14060
14061
14062 if (err_flag) then
14063 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14064 write(*,*) ''
14065 write(*,*) ' ' // trim(abs_mes) // &
14066 & ' check' // trim(pos_str) // ' = ', wrong
14067 write(*,*) ' is NOT LESS THAN'
14068 write(*,*) ' ' // trim(abs_mes) // &
14069 & ' answer' // trim(pos_str) // ' = ', right
14070
14071 call abortprogram('')
14072 else
14073 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
14074 end if
14075
14076
14077 end subroutine dctestassertlessthanint3
14078
14079
14080 subroutine dctestassertlessthanint4( &
14081 & message, answer, check, negative_support)
14082 use sysdep, only: abortprogram
14083 use dc_types, only: string, token
14084 implicit none
14085 character(*), intent(in):: message
14086 integer, intent(in):: answer(:,:,:,:)
14087 integer, intent(in):: check(:,:,:,:)
14088 logical, intent(in), optional:: negative_support
14089 logical:: err_flag
14090 logical:: negative_support_on
14091 character(STRING):: pos_str
14092 character(TOKEN):: abs_mes
14093 integer:: wrong, right
14094
14095 integer:: answer_shape(4), check_shape(4), pos(4)
14096 logical:: consist_shape(4)
14097 character(TOKEN):: pos_array(4)
14098 integer, allocatable:: mask_array(:,:,:,:)
14099 logical, allocatable:: judge(:,:,:,:)
14100 logical, allocatable:: judge_rev(:,:,:,:)
14101 logical, allocatable:: answer_negative(:,:,:,:)
14102 logical, allocatable:: check_negative(:,:,:,:)
14103 logical, allocatable:: both_negative(:,:,:,:)
14104
14105
14106 continue
14107 if (present(negative_support)) then
14108 negative_support_on = negative_support
14109 else
14110 negative_support_on = .true.
14111 end if
14112
14113 err_flag = .false.
14114
14115
14116 answer_shape = shape(answer)
14117 check_shape = shape(check)
14118
14119 consist_shape = answer_shape == check_shape
14120
14121 if (.not. all(consist_shape)) then
14122 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14123 write(*,*) ''
14124 write(*,*) ' shape of check is (', check_shape, ')'
14125 write(*,*) ' is INCORRECT'
14126 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
14127
14128 call abortprogram('')
14129 end if
14130
14131
14132 allocate( mask_array( &
14133 & answer_shape(1), &
14134
14135 & answer_shape(2), &
14136
14137 & answer_shape(3), &
14138
14139 & answer_shape(4) ) &
14140 & )
14141
14142 allocate( judge( &
14143 & answer_shape(1), &
14144
14145 & answer_shape(2), &
14146
14147 & answer_shape(3), &
14148
14149 & answer_shape(4) ) &
14150 & )
14151
14152 allocate( judge_rev( &
14153 & answer_shape(1), &
14154
14155 & answer_shape(2), &
14156
14157 & answer_shape(3), &
14158
14159 & answer_shape(4) ) &
14160 & )
14161
14162 allocate( answer_negative( &
14163 & answer_shape(1), &
14164
14165 & answer_shape(2), &
14166
14167 & answer_shape(3), &
14168
14169 & answer_shape(4) ) &
14170 & )
14171
14172 allocate( check_negative( &
14173 & answer_shape(1), &
14174
14175 & answer_shape(2), &
14176
14177 & answer_shape(3), &
14178
14179 & answer_shape(4) ) &
14180 & )
14181
14182 allocate( both_negative( &
14183 & answer_shape(1), &
14184
14185 & answer_shape(2), &
14186
14187 & answer_shape(3), &
14188
14189 & answer_shape(4) ) &
14190 & )
14191
14192 answer_negative = answer < 0
14193 check_negative = check < 0
14194 both_negative = answer_negative .and. check_negative
14195 if (.not. negative_support_on) both_negative = .false.
14196
14197 judge = answer > check
14198 where (both_negative) judge = .not. judge
14199
14200 judge_rev = .not. judge
14201 err_flag = any(judge_rev)
14202 mask_array = 1
14203 pos = maxloc(mask_array, judge_rev)
14204
14205 if (err_flag) then
14206
14207 wrong = check( &
14208 & pos(1), &
14209
14210 & pos(2), &
14211
14212 & pos(3), &
14213
14214 & pos(4) )
14215
14216 right = answer( &
14217 & pos(1), &
14218
14219 & pos(2), &
14220
14221 & pos(3), &
14222
14223 & pos(4) )
14224
14225 write(unit=pos_array(1), fmt="(i20)") pos(1)
14226
14227 write(unit=pos_array(2), fmt="(i20)") pos(2)
14228
14229 write(unit=pos_array(3), fmt="(i20)") pos(3)
14230
14231 write(unit=pos_array(4), fmt="(i20)") pos(4)
14232
14233
14234 pos_str = '(' // &
14235 & trim(adjustl(pos_array(1))) // ',' // &
14236
14237 & trim(adjustl(pos_array(2))) // ',' // &
14238
14239 & trim(adjustl(pos_array(3))) // ',' // &
14240
14241 & trim(adjustl(pos_array(4))) // ')'
14242
14243 if ( both_negative( &
14244 & pos(1), &
14245
14246 & pos(2), &
14247
14248 & pos(3), &
14249
14250 & pos(4) ) ) then
14251
14252 abs_mes = 'ABSOLUTE value of'
14253 else
14254 abs_mes = ''
14255
14256 end if
14257
14258 end if
14259 deallocate(mask_array, judge, judge_rev)
14260 deallocate(answer_negative, check_negative, both_negative)
14261
14262
14263
14264
14265 if (err_flag) then
14266 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14267 write(*,*) ''
14268 write(*,*) ' ' // trim(abs_mes) // &
14269 & ' check' // trim(pos_str) // ' = ', wrong
14270 write(*,*) ' is NOT LESS THAN'
14271 write(*,*) ' ' // trim(abs_mes) // &
14272 & ' answer' // trim(pos_str) // ' = ', right
14273
14274 call abortprogram('')
14275 else
14276 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
14277 end if
14278
14279
14280 end subroutine dctestassertlessthanint4
14281
14282
14283 subroutine dctestassertlessthanint5( &
14284 & message, answer, check, negative_support)
14285 use sysdep, only: abortprogram
14286 use dc_types, only: string, token
14287 implicit none
14288 character(*), intent(in):: message
14289 integer, intent(in):: answer(:,:,:,:,:)
14290 integer, intent(in):: check(:,:,:,:,:)
14291 logical, intent(in), optional:: negative_support
14292 logical:: err_flag
14293 logical:: negative_support_on
14294 character(STRING):: pos_str
14295 character(TOKEN):: abs_mes
14296 integer:: wrong, right
14297
14298 integer:: answer_shape(5), check_shape(5), pos(5)
14299 logical:: consist_shape(5)
14300 character(TOKEN):: pos_array(5)
14301 integer, allocatable:: mask_array(:,:,:,:,:)
14302 logical, allocatable:: judge(:,:,:,:,:)
14303 logical, allocatable:: judge_rev(:,:,:,:,:)
14304 logical, allocatable:: answer_negative(:,:,:,:,:)
14305 logical, allocatable:: check_negative(:,:,:,:,:)
14306 logical, allocatable:: both_negative(:,:,:,:,:)
14307
14308
14309 continue
14310 if (present(negative_support)) then
14311 negative_support_on = negative_support
14312 else
14313 negative_support_on = .true.
14314 end if
14315
14316 err_flag = .false.
14317
14318
14319 answer_shape = shape(answer)
14320 check_shape = shape(check)
14321
14322 consist_shape = answer_shape == check_shape
14323
14324 if (.not. all(consist_shape)) then
14325 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14326 write(*,*) ''
14327 write(*,*) ' shape of check is (', check_shape, ')'
14328 write(*,*) ' is INCORRECT'
14329 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
14330
14331 call abortprogram('')
14332 end if
14333
14334
14335 allocate( mask_array( &
14336 & answer_shape(1), &
14337
14338 & answer_shape(2), &
14339
14340 & answer_shape(3), &
14341
14342 & answer_shape(4), &
14343
14344 & answer_shape(5) ) &
14345 & )
14346
14347 allocate( judge( &
14348 & answer_shape(1), &
14349
14350 & answer_shape(2), &
14351
14352 & answer_shape(3), &
14353
14354 & answer_shape(4), &
14355
14356 & answer_shape(5) ) &
14357 & )
14358
14359 allocate( judge_rev( &
14360 & answer_shape(1), &
14361
14362 & answer_shape(2), &
14363
14364 & answer_shape(3), &
14365
14366 & answer_shape(4), &
14367
14368 & answer_shape(5) ) &
14369 & )
14370
14371 allocate( answer_negative( &
14372 & answer_shape(1), &
14373
14374 & answer_shape(2), &
14375
14376 & answer_shape(3), &
14377
14378 & answer_shape(4), &
14379
14380 & answer_shape(5) ) &
14381 & )
14382
14383 allocate( check_negative( &
14384 & answer_shape(1), &
14385
14386 & answer_shape(2), &
14387
14388 & answer_shape(3), &
14389
14390 & answer_shape(4), &
14391
14392 & answer_shape(5) ) &
14393 & )
14394
14395 allocate( both_negative( &
14396 & answer_shape(1), &
14397
14398 & answer_shape(2), &
14399
14400 & answer_shape(3), &
14401
14402 & answer_shape(4), &
14403
14404 & answer_shape(5) ) &
14405 & )
14406
14407 answer_negative = answer < 0
14408 check_negative = check < 0
14409 both_negative = answer_negative .and. check_negative
14410 if (.not. negative_support_on) both_negative = .false.
14411
14412 judge = answer > check
14413 where (both_negative) judge = .not. judge
14414
14415 judge_rev = .not. judge
14416 err_flag = any(judge_rev)
14417 mask_array = 1
14418 pos = maxloc(mask_array, judge_rev)
14419
14420 if (err_flag) then
14421
14422 wrong = check( &
14423 & pos(1), &
14424
14425 & pos(2), &
14426
14427 & pos(3), &
14428
14429 & pos(4), &
14430
14431 & pos(5) )
14432
14433 right = answer( &
14434 & pos(1), &
14435
14436 & pos(2), &
14437
14438 & pos(3), &
14439
14440 & pos(4), &
14441
14442 & pos(5) )
14443
14444 write(unit=pos_array(1), fmt="(i20)") pos(1)
14445
14446 write(unit=pos_array(2), fmt="(i20)") pos(2)
14447
14448 write(unit=pos_array(3), fmt="(i20)") pos(3)
14449
14450 write(unit=pos_array(4), fmt="(i20)") pos(4)
14451
14452 write(unit=pos_array(5), fmt="(i20)") pos(5)
14453
14454
14455 pos_str = '(' // &
14456 & trim(adjustl(pos_array(1))) // ',' // &
14457
14458 & trim(adjustl(pos_array(2))) // ',' // &
14459
14460 & trim(adjustl(pos_array(3))) // ',' // &
14461
14462 & trim(adjustl(pos_array(4))) // ',' // &
14463
14464 & trim(adjustl(pos_array(5))) // ')'
14465
14466 if ( both_negative( &
14467 & pos(1), &
14468
14469 & pos(2), &
14470
14471 & pos(3), &
14472
14473 & pos(4), &
14474
14475 & pos(5) ) ) then
14476
14477 abs_mes = 'ABSOLUTE value of'
14478 else
14479 abs_mes = ''
14480
14481 end if
14482
14483 end if
14484 deallocate(mask_array, judge, judge_rev)
14485 deallocate(answer_negative, check_negative, both_negative)
14486
14487
14488
14489
14490 if (err_flag) then
14491 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14492 write(*,*) ''
14493 write(*,*) ' ' // trim(abs_mes) // &
14494 & ' check' // trim(pos_str) // ' = ', wrong
14495 write(*,*) ' is NOT LESS THAN'
14496 write(*,*) ' ' // trim(abs_mes) // &
14497 & ' answer' // trim(pos_str) // ' = ', right
14498
14499 call abortprogram('')
14500 else
14501 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
14502 end if
14503
14504
14505 end subroutine dctestassertlessthanint5
14506
14507
14508 subroutine dctestassertlessthanint6( &
14509 & message, answer, check, negative_support)
14510 use sysdep, only: abortprogram
14511 use dc_types, only: string, token
14512 implicit none
14513 character(*), intent(in):: message
14514 integer, intent(in):: answer(:,:,:,:,:,:)
14515 integer, intent(in):: check(:,:,:,:,:,:)
14516 logical, intent(in), optional:: negative_support
14517 logical:: err_flag
14518 logical:: negative_support_on
14519 character(STRING):: pos_str
14520 character(TOKEN):: abs_mes
14521 integer:: wrong, right
14522
14523 integer:: answer_shape(6), check_shape(6), pos(6)
14524 logical:: consist_shape(6)
14525 character(TOKEN):: pos_array(6)
14526 integer, allocatable:: mask_array(:,:,:,:,:,:)
14527 logical, allocatable:: judge(:,:,:,:,:,:)
14528 logical, allocatable:: judge_rev(:,:,:,:,:,:)
14529 logical, allocatable:: answer_negative(:,:,:,:,:,:)
14530 logical, allocatable:: check_negative(:,:,:,:,:,:)
14531 logical, allocatable:: both_negative(:,:,:,:,:,:)
14532
14533
14534 continue
14535 if (present(negative_support)) then
14536 negative_support_on = negative_support
14537 else
14538 negative_support_on = .true.
14539 end if
14540
14541 err_flag = .false.
14542
14543
14544 answer_shape = shape(answer)
14545 check_shape = shape(check)
14546
14547 consist_shape = answer_shape == check_shape
14548
14549 if (.not. all(consist_shape)) then
14550 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14551 write(*,*) ''
14552 write(*,*) ' shape of check is (', check_shape, ')'
14553 write(*,*) ' is INCORRECT'
14554 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
14555
14556 call abortprogram('')
14557 end if
14558
14559
14560 allocate( mask_array( &
14561 & answer_shape(1), &
14562
14563 & answer_shape(2), &
14564
14565 & answer_shape(3), &
14566
14567 & answer_shape(4), &
14568
14569 & answer_shape(5), &
14570
14571 & answer_shape(6) ) &
14572 & )
14573
14574 allocate( judge( &
14575 & answer_shape(1), &
14576
14577 & answer_shape(2), &
14578
14579 & answer_shape(3), &
14580
14581 & answer_shape(4), &
14582
14583 & answer_shape(5), &
14584
14585 & answer_shape(6) ) &
14586 & )
14587
14588 allocate( judge_rev( &
14589 & answer_shape(1), &
14590
14591 & answer_shape(2), &
14592
14593 & answer_shape(3), &
14594
14595 & answer_shape(4), &
14596
14597 & answer_shape(5), &
14598
14599 & answer_shape(6) ) &
14600 & )
14601
14602 allocate( answer_negative( &
14603 & answer_shape(1), &
14604
14605 & answer_shape(2), &
14606
14607 & answer_shape(3), &
14608
14609 & answer_shape(4), &
14610
14611 & answer_shape(5), &
14612
14613 & answer_shape(6) ) &
14614 & )
14615
14616 allocate( check_negative( &
14617 & answer_shape(1), &
14618
14619 & answer_shape(2), &
14620
14621 & answer_shape(3), &
14622
14623 & answer_shape(4), &
14624
14625 & answer_shape(5), &
14626
14627 & answer_shape(6) ) &
14628 & )
14629
14630 allocate( both_negative( &
14631 & answer_shape(1), &
14632
14633 & answer_shape(2), &
14634
14635 & answer_shape(3), &
14636
14637 & answer_shape(4), &
14638
14639 & answer_shape(5), &
14640
14641 & answer_shape(6) ) &
14642 & )
14643
14644 answer_negative = answer < 0
14645 check_negative = check < 0
14646 both_negative = answer_negative .and. check_negative
14647 if (.not. negative_support_on) both_negative = .false.
14648
14649 judge = answer > check
14650 where (both_negative) judge = .not. judge
14651
14652 judge_rev = .not. judge
14653 err_flag = any(judge_rev)
14654 mask_array = 1
14655 pos = maxloc(mask_array, judge_rev)
14656
14657 if (err_flag) then
14658
14659 wrong = check( &
14660 & pos(1), &
14661
14662 & pos(2), &
14663
14664 & pos(3), &
14665
14666 & pos(4), &
14667
14668 & pos(5), &
14669
14670 & pos(6) )
14671
14672 right = answer( &
14673 & pos(1), &
14674
14675 & pos(2), &
14676
14677 & pos(3), &
14678
14679 & pos(4), &
14680
14681 & pos(5), &
14682
14683 & pos(6) )
14684
14685 write(unit=pos_array(1), fmt="(i20)") pos(1)
14686
14687 write(unit=pos_array(2), fmt="(i20)") pos(2)
14688
14689 write(unit=pos_array(3), fmt="(i20)") pos(3)
14690
14691 write(unit=pos_array(4), fmt="(i20)") pos(4)
14692
14693 write(unit=pos_array(5), fmt="(i20)") pos(5)
14694
14695 write(unit=pos_array(6), fmt="(i20)") pos(6)
14696
14697
14698 pos_str = '(' // &
14699 & trim(adjustl(pos_array(1))) // ',' // &
14700
14701 & trim(adjustl(pos_array(2))) // ',' // &
14702
14703 & trim(adjustl(pos_array(3))) // ',' // &
14704
14705 & trim(adjustl(pos_array(4))) // ',' // &
14706
14707 & trim(adjustl(pos_array(5))) // ',' // &
14708
14709 & trim(adjustl(pos_array(6))) // ')'
14710
14711 if ( both_negative( &
14712 & pos(1), &
14713
14714 & pos(2), &
14715
14716 & pos(3), &
14717
14718 & pos(4), &
14719
14720 & pos(5), &
14721
14722 & pos(6) ) ) then
14723
14724 abs_mes = 'ABSOLUTE value of'
14725 else
14726 abs_mes = ''
14727
14728 end if
14729
14730 end if
14731 deallocate(mask_array, judge, judge_rev)
14732 deallocate(answer_negative, check_negative, both_negative)
14733
14734
14735
14736
14737 if (err_flag) then
14738 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14739 write(*,*) ''
14740 write(*,*) ' ' // trim(abs_mes) // &
14741 & ' check' // trim(pos_str) // ' = ', wrong
14742 write(*,*) ' is NOT LESS THAN'
14743 write(*,*) ' ' // trim(abs_mes) // &
14744 & ' answer' // trim(pos_str) // ' = ', right
14745
14746 call abortprogram('')
14747 else
14748 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
14749 end if
14750
14751
14752 end subroutine dctestassertlessthanint6
14753
14754
14755 subroutine dctestassertlessthanint7( &
14756 & message, answer, check, negative_support)
14757 use sysdep, only: abortprogram
14758 use dc_types, only: string, token
14759 implicit none
14760 character(*), intent(in):: message
14761 integer, intent(in):: answer(:,:,:,:,:,:,:)
14762 integer, intent(in):: check(:,:,:,:,:,:,:)
14763 logical, intent(in), optional:: negative_support
14764 logical:: err_flag
14765 logical:: negative_support_on
14766 character(STRING):: pos_str
14767 character(TOKEN):: abs_mes
14768 integer:: wrong, right
14769
14770 integer:: answer_shape(7), check_shape(7), pos(7)
14771 logical:: consist_shape(7)
14772 character(TOKEN):: pos_array(7)
14773 integer, allocatable:: mask_array(:,:,:,:,:,:,:)
14774 logical, allocatable:: judge(:,:,:,:,:,:,:)
14775 logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
14776 logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
14777 logical, allocatable:: check_negative(:,:,:,:,:,:,:)
14778 logical, allocatable:: both_negative(:,:,:,:,:,:,:)
14779
14780
14781 continue
14782 if (present(negative_support)) then
14783 negative_support_on = negative_support
14784 else
14785 negative_support_on = .true.
14786 end if
14787
14788 err_flag = .false.
14789
14790
14791 answer_shape = shape(answer)
14792 check_shape = shape(check)
14793
14794 consist_shape = answer_shape == check_shape
14795
14796 if (.not. all(consist_shape)) then
14797 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14798 write(*,*) ''
14799 write(*,*) ' shape of check is (', check_shape, ')'
14800 write(*,*) ' is INCORRECT'
14801 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
14802
14803 call abortprogram('')
14804 end if
14805
14806
14807 allocate( mask_array( &
14808 & answer_shape(1), &
14809
14810 & answer_shape(2), &
14811
14812 & answer_shape(3), &
14813
14814 & answer_shape(4), &
14815
14816 & answer_shape(5), &
14817
14818 & answer_shape(6), &
14819
14820 & answer_shape(7) ) &
14821 & )
14822
14823 allocate( judge( &
14824 & answer_shape(1), &
14825
14826 & answer_shape(2), &
14827
14828 & answer_shape(3), &
14829
14830 & answer_shape(4), &
14831
14832 & answer_shape(5), &
14833
14834 & answer_shape(6), &
14835
14836 & answer_shape(7) ) &
14837 & )
14838
14839 allocate( judge_rev( &
14840 & answer_shape(1), &
14841
14842 & answer_shape(2), &
14843
14844 & answer_shape(3), &
14845
14846 & answer_shape(4), &
14847
14848 & answer_shape(5), &
14849
14850 & answer_shape(6), &
14851
14852 & answer_shape(7) ) &
14853 & )
14854
14855 allocate( answer_negative( &
14856 & answer_shape(1), &
14857
14858 & answer_shape(2), &
14859
14860 & answer_shape(3), &
14861
14862 & answer_shape(4), &
14863
14864 & answer_shape(5), &
14865
14866 & answer_shape(6), &
14867
14868 & answer_shape(7) ) &
14869 & )
14870
14871 allocate( check_negative( &
14872 & answer_shape(1), &
14873
14874 & answer_shape(2), &
14875
14876 & answer_shape(3), &
14877
14878 & answer_shape(4), &
14879
14880 & answer_shape(5), &
14881
14882 & answer_shape(6), &
14883
14884 & answer_shape(7) ) &
14885 & )
14886
14887 allocate( both_negative( &
14888 & answer_shape(1), &
14889
14890 & answer_shape(2), &
14891
14892 & answer_shape(3), &
14893
14894 & answer_shape(4), &
14895
14896 & answer_shape(5), &
14897
14898 & answer_shape(6), &
14899
14900 & answer_shape(7) ) &
14901 & )
14902
14903 answer_negative = answer < 0
14904 check_negative = check < 0
14905 both_negative = answer_negative .and. check_negative
14906 if (.not. negative_support_on) both_negative = .false.
14907
14908 judge = answer > check
14909 where (both_negative) judge = .not. judge
14910
14911 judge_rev = .not. judge
14912 err_flag = any(judge_rev)
14913 mask_array = 1
14914 pos = maxloc(mask_array, judge_rev)
14915
14916 if (err_flag) then
14917
14918 wrong = check( &
14919 & pos(1), &
14920
14921 & pos(2), &
14922
14923 & pos(3), &
14924
14925 & pos(4), &
14926
14927 & pos(5), &
14928
14929 & pos(6), &
14930
14931 & pos(7) )
14932
14933 right = answer( &
14934 & pos(1), &
14935
14936 & pos(2), &
14937
14938 & pos(3), &
14939
14940 & pos(4), &
14941
14942 & pos(5), &
14943
14944 & pos(6), &
14945
14946 & pos(7) )
14947
14948 write(unit=pos_array(1), fmt="(i20)") pos(1)
14949
14950 write(unit=pos_array(2), fmt="(i20)") pos(2)
14951
14952 write(unit=pos_array(3), fmt="(i20)") pos(3)
14953
14954 write(unit=pos_array(4), fmt="(i20)") pos(4)
14955
14956 write(unit=pos_array(5), fmt="(i20)") pos(5)
14957
14958 write(unit=pos_array(6), fmt="(i20)") pos(6)
14959
14960 write(unit=pos_array(7), fmt="(i20)") pos(7)
14961
14962
14963 pos_str = '(' // &
14964 & trim(adjustl(pos_array(1))) // ',' // &
14965
14966 & trim(adjustl(pos_array(2))) // ',' // &
14967
14968 & trim(adjustl(pos_array(3))) // ',' // &
14969
14970 & trim(adjustl(pos_array(4))) // ',' // &
14971
14972 & trim(adjustl(pos_array(5))) // ',' // &
14973
14974 & trim(adjustl(pos_array(6))) // ',' // &
14975
14976 & trim(adjustl(pos_array(7))) // ')'
14977
14978 if ( both_negative( &
14979 & pos(1), &
14980
14981 & pos(2), &
14982
14983 & pos(3), &
14984
14985 & pos(4), &
14986
14987 & pos(5), &
14988
14989 & pos(6), &
14990
14991 & pos(7) ) ) then
14992
14993 abs_mes = 'ABSOLUTE value of'
14994 else
14995 abs_mes = ''
14996
14997 end if
14998
14999 end if
15000 deallocate(mask_array, judge, judge_rev)
15001 deallocate(answer_negative, check_negative, both_negative)
15002
15003
15004
15005
15006 if (err_flag) then
15007 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15008 write(*,*) ''
15009 write(*,*) ' ' // trim(abs_mes) // &
15010 & ' check' // trim(pos_str) // ' = ', wrong
15011 write(*,*) ' is NOT LESS THAN'
15012 write(*,*) ' ' // trim(abs_mes) // &
15013 & ' answer' // trim(pos_str) // ' = ', right
15014
15015 call abortprogram('')
15016 else
15017 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15018 end if
15019
15020
15021 end subroutine dctestassertlessthanint7
15022
15023
15024 subroutine dctestassertlessthanreal0( &
15025 & message, answer, check, negative_support)
15026 use sysdep, only: abortprogram
15027 use dc_types, only: string, token
15028 implicit none
15029 character(*), intent(in):: message
15030 real, intent(in):: answer
15031 real, intent(in):: check
15032 logical, intent(in), optional:: negative_support
15033 logical:: err_flag
15034 logical:: negative_support_on
15035 character(STRING):: pos_str
15036 character(TOKEN):: abs_mes
15037 real:: wrong, right
15038
15039
15040
15041 continue
15042 if (present(negative_support)) then
15043 negative_support_on = negative_support
15044 else
15045 negative_support_on = .true.
15046 end if
15047
15048 err_flag = .false.
15049
15050
15051
15052
15053 err_flag = .not. answer > check
15054 abs_mes = ''
15055
15056 if ( answer < 0.0 &
15057 & .and. check < 0.0 &
15058 & .and. negative_support_on ) then
15059
15060 err_flag = .not. err_flag
15061 abs_mes = 'ABSOLUTE value of'
15062 end if
15063
15064 wrong = check
15065 right = answer
15066 pos_str = ''
15067
15068
15069
15070
15071 if (err_flag) then
15072 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15073 write(*,*) ''
15074 write(*,*) ' ' // trim(abs_mes) // &
15075 & ' check' // trim(pos_str) // ' = ', wrong
15076 write(*,*) ' is NOT LESS THAN'
15077 write(*,*) ' ' // trim(abs_mes) // &
15078 & ' answer' // trim(pos_str) // ' = ', right
15079
15080 call abortprogram('')
15081 else
15082 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15083 end if
15084
15085
15086 end subroutine dctestassertlessthanreal0
15087
15088
15089 subroutine dctestassertlessthanreal1( &
15090 & message, answer, check, negative_support)
15091 use sysdep, only: abortprogram
15092 use dc_types, only: string, token
15093 implicit none
15094 character(*), intent(in):: message
15095 real, intent(in):: answer(:)
15096 real, intent(in):: check(:)
15097 logical, intent(in), optional:: negative_support
15098 logical:: err_flag
15099 logical:: negative_support_on
15100 character(STRING):: pos_str
15101 character(TOKEN):: abs_mes
15102 real:: wrong, right
15103
15104 integer:: answer_shape(1), check_shape(1), pos(1)
15105 logical:: consist_shape(1)
15106 character(TOKEN):: pos_array(1)
15107 integer, allocatable:: mask_array(:)
15108 logical, allocatable:: judge(:)
15109 logical, allocatable:: judge_rev(:)
15110 logical, allocatable:: answer_negative(:)
15111 logical, allocatable:: check_negative(:)
15112 logical, allocatable:: both_negative(:)
15113
15114
15115 continue
15116 if (present(negative_support)) then
15117 negative_support_on = negative_support
15118 else
15119 negative_support_on = .true.
15120 end if
15121
15122 err_flag = .false.
15123
15124
15125 answer_shape = shape(answer)
15126 check_shape = shape(check)
15127
15128 consist_shape = answer_shape == check_shape
15129
15130 if (.not. all(consist_shape)) then
15131 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15132 write(*,*) ''
15133 write(*,*) ' shape of check is (', check_shape, ')'
15134 write(*,*) ' is INCORRECT'
15135 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15136
15137 call abortprogram('')
15138 end if
15139
15140
15141 allocate( mask_array( &
15142
15143 & answer_shape(1) ) &
15144 & )
15145
15146 allocate( judge( &
15147
15148 & answer_shape(1) ) &
15149 & )
15150
15151 allocate( judge_rev( &
15152
15153 & answer_shape(1) ) &
15154 & )
15155
15156 allocate( answer_negative( &
15157
15158 & answer_shape(1) ) &
15159 & )
15160
15161 allocate( check_negative( &
15162
15163 & answer_shape(1) ) &
15164 & )
15165
15166 allocate( both_negative( &
15167
15168 & answer_shape(1) ) &
15169 & )
15170
15171 answer_negative = answer < 0.0
15172 check_negative = check < 0.0
15173 both_negative = answer_negative .and. check_negative
15174 if (.not. negative_support_on) both_negative = .false.
15175
15176 judge = answer > check
15177 where (both_negative) judge = .not. judge
15178
15179 judge_rev = .not. judge
15180 err_flag = any(judge_rev)
15181 mask_array = 1
15182 pos = maxloc(mask_array, judge_rev)
15183
15184 if (err_flag) then
15185
15186 wrong = check( &
15187
15188 & pos(1) )
15189
15190 right = answer( &
15191
15192 & pos(1) )
15193
15194 write(unit=pos_array(1), fmt="(i20)") pos(1)
15195
15196
15197 pos_str = '(' // &
15198
15199 & trim(adjustl(pos_array(1))) // ')'
15200
15201 if ( both_negative( &
15202
15203 & pos(1) ) ) then
15204
15205 abs_mes = 'ABSOLUTE value of'
15206 else
15207 abs_mes = ''
15208
15209 end if
15210
15211 end if
15212 deallocate(mask_array, judge, judge_rev)
15213 deallocate(answer_negative, check_negative, both_negative)
15214
15215
15216
15217
15218 if (err_flag) then
15219 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15220 write(*,*) ''
15221 write(*,*) ' ' // trim(abs_mes) // &
15222 & ' check' // trim(pos_str) // ' = ', wrong
15223 write(*,*) ' is NOT LESS THAN'
15224 write(*,*) ' ' // trim(abs_mes) // &
15225 & ' answer' // trim(pos_str) // ' = ', right
15226
15227 call abortprogram('')
15228 else
15229 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15230 end if
15231
15232
15233 end subroutine dctestassertlessthanreal1
15234
15235
15236 subroutine dctestassertlessthanreal2( &
15237 & message, answer, check, negative_support)
15238 use sysdep, only: abortprogram
15239 use dc_types, only: string, token
15240 implicit none
15241 character(*), intent(in):: message
15242 real, intent(in):: answer(:,:)
15243 real, intent(in):: check(:,:)
15244 logical, intent(in), optional:: negative_support
15245 logical:: err_flag
15246 logical:: negative_support_on
15247 character(STRING):: pos_str
15248 character(TOKEN):: abs_mes
15249 real:: wrong, right
15250
15251 integer:: answer_shape(2), check_shape(2), pos(2)
15252 logical:: consist_shape(2)
15253 character(TOKEN):: pos_array(2)
15254 integer, allocatable:: mask_array(:,:)
15255 logical, allocatable:: judge(:,:)
15256 logical, allocatable:: judge_rev(:,:)
15257 logical, allocatable:: answer_negative(:,:)
15258 logical, allocatable:: check_negative(:,:)
15259 logical, allocatable:: both_negative(:,:)
15260
15261
15262 continue
15263 if (present(negative_support)) then
15264 negative_support_on = negative_support
15265 else
15266 negative_support_on = .true.
15267 end if
15268
15269 err_flag = .false.
15270
15271
15272 answer_shape = shape(answer)
15273 check_shape = shape(check)
15274
15275 consist_shape = answer_shape == check_shape
15276
15277 if (.not. all(consist_shape)) then
15278 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15279 write(*,*) ''
15280 write(*,*) ' shape of check is (', check_shape, ')'
15281 write(*,*) ' is INCORRECT'
15282 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15283
15284 call abortprogram('')
15285 end if
15286
15287
15288 allocate( mask_array( &
15289 & answer_shape(1), &
15290
15291 & answer_shape(2) ) &
15292 & )
15293
15294 allocate( judge( &
15295 & answer_shape(1), &
15296
15297 & answer_shape(2) ) &
15298 & )
15299
15300 allocate( judge_rev( &
15301 & answer_shape(1), &
15302
15303 & answer_shape(2) ) &
15304 & )
15305
15306 allocate( answer_negative( &
15307 & answer_shape(1), &
15308
15309 & answer_shape(2) ) &
15310 & )
15311
15312 allocate( check_negative( &
15313 & answer_shape(1), &
15314
15315 & answer_shape(2) ) &
15316 & )
15317
15318 allocate( both_negative( &
15319 & answer_shape(1), &
15320
15321 & answer_shape(2) ) &
15322 & )
15323
15324 answer_negative = answer < 0.0
15325 check_negative = check < 0.0
15326 both_negative = answer_negative .and. check_negative
15327 if (.not. negative_support_on) both_negative = .false.
15328
15329 judge = answer > check
15330 where (both_negative) judge = .not. judge
15331
15332 judge_rev = .not. judge
15333 err_flag = any(judge_rev)
15334 mask_array = 1
15335 pos = maxloc(mask_array, judge_rev)
15336
15337 if (err_flag) then
15338
15339 wrong = check( &
15340 & pos(1), &
15341
15342 & pos(2) )
15343
15344 right = answer( &
15345 & pos(1), &
15346
15347 & pos(2) )
15348
15349 write(unit=pos_array(1), fmt="(i20)") pos(1)
15350
15351 write(unit=pos_array(2), fmt="(i20)") pos(2)
15352
15353
15354 pos_str = '(' // &
15355 & trim(adjustl(pos_array(1))) // ',' // &
15356
15357 & trim(adjustl(pos_array(2))) // ')'
15358
15359 if ( both_negative( &
15360 & pos(1), &
15361
15362 & pos(2) ) ) then
15363
15364 abs_mes = 'ABSOLUTE value of'
15365 else
15366 abs_mes = ''
15367
15368 end if
15369
15370 end if
15371 deallocate(mask_array, judge, judge_rev)
15372 deallocate(answer_negative, check_negative, both_negative)
15373
15374
15375
15376
15377 if (err_flag) then
15378 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15379 write(*,*) ''
15380 write(*,*) ' ' // trim(abs_mes) // &
15381 & ' check' // trim(pos_str) // ' = ', wrong
15382 write(*,*) ' is NOT LESS THAN'
15383 write(*,*) ' ' // trim(abs_mes) // &
15384 & ' answer' // trim(pos_str) // ' = ', right
15385
15386 call abortprogram('')
15387 else
15388 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15389 end if
15390
15391
15392 end subroutine dctestassertlessthanreal2
15393
15394
15395 subroutine dctestassertlessthanreal3( &
15396 & message, answer, check, negative_support)
15397 use sysdep, only: abortprogram
15398 use dc_types, only: string, token
15399 implicit none
15400 character(*), intent(in):: message
15401 real, intent(in):: answer(:,:,:)
15402 real, intent(in):: check(:,:,:)
15403 logical, intent(in), optional:: negative_support
15404 logical:: err_flag
15405 logical:: negative_support_on
15406 character(STRING):: pos_str
15407 character(TOKEN):: abs_mes
15408 real:: wrong, right
15409
15410 integer:: answer_shape(3), check_shape(3), pos(3)
15411 logical:: consist_shape(3)
15412 character(TOKEN):: pos_array(3)
15413 integer, allocatable:: mask_array(:,:,:)
15414 logical, allocatable:: judge(:,:,:)
15415 logical, allocatable:: judge_rev(:,:,:)
15416 logical, allocatable:: answer_negative(:,:,:)
15417 logical, allocatable:: check_negative(:,:,:)
15418 logical, allocatable:: both_negative(:,:,:)
15419
15420
15421 continue
15422 if (present(negative_support)) then
15423 negative_support_on = negative_support
15424 else
15425 negative_support_on = .true.
15426 end if
15427
15428 err_flag = .false.
15429
15430
15431 answer_shape = shape(answer)
15432 check_shape = shape(check)
15433
15434 consist_shape = answer_shape == check_shape
15435
15436 if (.not. all(consist_shape)) then
15437 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15438 write(*,*) ''
15439 write(*,*) ' shape of check is (', check_shape, ')'
15440 write(*,*) ' is INCORRECT'
15441 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15442
15443 call abortprogram('')
15444 end if
15445
15446
15447 allocate( mask_array( &
15448 & answer_shape(1), &
15449
15450 & answer_shape(2), &
15451
15452 & answer_shape(3) ) &
15453 & )
15454
15455 allocate( judge( &
15456 & answer_shape(1), &
15457
15458 & answer_shape(2), &
15459
15460 & answer_shape(3) ) &
15461 & )
15462
15463 allocate( judge_rev( &
15464 & answer_shape(1), &
15465
15466 & answer_shape(2), &
15467
15468 & answer_shape(3) ) &
15469 & )
15470
15471 allocate( answer_negative( &
15472 & answer_shape(1), &
15473
15474 & answer_shape(2), &
15475
15476 & answer_shape(3) ) &
15477 & )
15478
15479 allocate( check_negative( &
15480 & answer_shape(1), &
15481
15482 & answer_shape(2), &
15483
15484 & answer_shape(3) ) &
15485 & )
15486
15487 allocate( both_negative( &
15488 & answer_shape(1), &
15489
15490 & answer_shape(2), &
15491
15492 & answer_shape(3) ) &
15493 & )
15494
15495 answer_negative = answer < 0.0
15496 check_negative = check < 0.0
15497 both_negative = answer_negative .and. check_negative
15498 if (.not. negative_support_on) both_negative = .false.
15499
15500 judge = answer > check
15501 where (both_negative) judge = .not. judge
15502
15503 judge_rev = .not. judge
15504 err_flag = any(judge_rev)
15505 mask_array = 1
15506 pos = maxloc(mask_array, judge_rev)
15507
15508 if (err_flag) then
15509
15510 wrong = check( &
15511 & pos(1), &
15512
15513 & pos(2), &
15514
15515 & pos(3) )
15516
15517 right = answer( &
15518 & pos(1), &
15519
15520 & pos(2), &
15521
15522 & pos(3) )
15523
15524 write(unit=pos_array(1), fmt="(i20)") pos(1)
15525
15526 write(unit=pos_array(2), fmt="(i20)") pos(2)
15527
15528 write(unit=pos_array(3), fmt="(i20)") pos(3)
15529
15530
15531 pos_str = '(' // &
15532 & trim(adjustl(pos_array(1))) // ',' // &
15533
15534 & trim(adjustl(pos_array(2))) // ',' // &
15535
15536 & trim(adjustl(pos_array(3))) // ')'
15537
15538 if ( both_negative( &
15539 & pos(1), &
15540
15541 & pos(2), &
15542
15543 & pos(3) ) ) then
15544
15545 abs_mes = 'ABSOLUTE value of'
15546 else
15547 abs_mes = ''
15548
15549 end if
15550
15551 end if
15552 deallocate(mask_array, judge, judge_rev)
15553 deallocate(answer_negative, check_negative, both_negative)
15554
15555
15556
15557
15558 if (err_flag) then
15559 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15560 write(*,*) ''
15561 write(*,*) ' ' // trim(abs_mes) // &
15562 & ' check' // trim(pos_str) // ' = ', wrong
15563 write(*,*) ' is NOT LESS THAN'
15564 write(*,*) ' ' // trim(abs_mes) // &
15565 & ' answer' // trim(pos_str) // ' = ', right
15566
15567 call abortprogram('')
15568 else
15569 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15570 end if
15571
15572
15573 end subroutine dctestassertlessthanreal3
15574
15575
15576 subroutine dctestassertlessthanreal4( &
15577 & message, answer, check, negative_support)
15578 use sysdep, only: abortprogram
15579 use dc_types, only: string, token
15580 implicit none
15581 character(*), intent(in):: message
15582 real, intent(in):: answer(:,:,:,:)
15583 real, intent(in):: check(:,:,:,:)
15584 logical, intent(in), optional:: negative_support
15585 logical:: err_flag
15586 logical:: negative_support_on
15587 character(STRING):: pos_str
15588 character(TOKEN):: abs_mes
15589 real:: wrong, right
15590
15591 integer:: answer_shape(4), check_shape(4), pos(4)
15592 logical:: consist_shape(4)
15593 character(TOKEN):: pos_array(4)
15594 integer, allocatable:: mask_array(:,:,:,:)
15595 logical, allocatable:: judge(:,:,:,:)
15596 logical, allocatable:: judge_rev(:,:,:,:)
15597 logical, allocatable:: answer_negative(:,:,:,:)
15598 logical, allocatable:: check_negative(:,:,:,:)
15599 logical, allocatable:: both_negative(:,:,:,:)
15600
15601
15602 continue
15603 if (present(negative_support)) then
15604 negative_support_on = negative_support
15605 else
15606 negative_support_on = .true.
15607 end if
15608
15609 err_flag = .false.
15610
15611
15612 answer_shape = shape(answer)
15613 check_shape = shape(check)
15614
15615 consist_shape = answer_shape == check_shape
15616
15617 if (.not. all(consist_shape)) then
15618 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15619 write(*,*) ''
15620 write(*,*) ' shape of check is (', check_shape, ')'
15621 write(*,*) ' is INCORRECT'
15622 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15623
15624 call abortprogram('')
15625 end if
15626
15627
15628 allocate( mask_array( &
15629 & answer_shape(1), &
15630
15631 & answer_shape(2), &
15632
15633 & answer_shape(3), &
15634
15635 & answer_shape(4) ) &
15636 & )
15637
15638 allocate( judge( &
15639 & answer_shape(1), &
15640
15641 & answer_shape(2), &
15642
15643 & answer_shape(3), &
15644
15645 & answer_shape(4) ) &
15646 & )
15647
15648 allocate( judge_rev( &
15649 & answer_shape(1), &
15650
15651 & answer_shape(2), &
15652
15653 & answer_shape(3), &
15654
15655 & answer_shape(4) ) &
15656 & )
15657
15658 allocate( answer_negative( &
15659 & answer_shape(1), &
15660
15661 & answer_shape(2), &
15662
15663 & answer_shape(3), &
15664
15665 & answer_shape(4) ) &
15666 & )
15667
15668 allocate( check_negative( &
15669 & answer_shape(1), &
15670
15671 & answer_shape(2), &
15672
15673 & answer_shape(3), &
15674
15675 & answer_shape(4) ) &
15676 & )
15677
15678 allocate( both_negative( &
15679 & answer_shape(1), &
15680
15681 & answer_shape(2), &
15682
15683 & answer_shape(3), &
15684
15685 & answer_shape(4) ) &
15686 & )
15687
15688 answer_negative = answer < 0.0
15689 check_negative = check < 0.0
15690 both_negative = answer_negative .and. check_negative
15691 if (.not. negative_support_on) both_negative = .false.
15692
15693 judge = answer > check
15694 where (both_negative) judge = .not. judge
15695
15696 judge_rev = .not. judge
15697 err_flag = any(judge_rev)
15698 mask_array = 1
15699 pos = maxloc(mask_array, judge_rev)
15700
15701 if (err_flag) then
15702
15703 wrong = check( &
15704 & pos(1), &
15705
15706 & pos(2), &
15707
15708 & pos(3), &
15709
15710 & pos(4) )
15711
15712 right = answer( &
15713 & pos(1), &
15714
15715 & pos(2), &
15716
15717 & pos(3), &
15718
15719 & pos(4) )
15720
15721 write(unit=pos_array(1), fmt="(i20)") pos(1)
15722
15723 write(unit=pos_array(2), fmt="(i20)") pos(2)
15724
15725 write(unit=pos_array(3), fmt="(i20)") pos(3)
15726
15727 write(unit=pos_array(4), fmt="(i20)") pos(4)
15728
15729
15730 pos_str = '(' // &
15731 & trim(adjustl(pos_array(1))) // ',' // &
15732
15733 & trim(adjustl(pos_array(2))) // ',' // &
15734
15735 & trim(adjustl(pos_array(3))) // ',' // &
15736
15737 & trim(adjustl(pos_array(4))) // ')'
15738
15739 if ( both_negative( &
15740 & pos(1), &
15741
15742 & pos(2), &
15743
15744 & pos(3), &
15745
15746 & pos(4) ) ) then
15747
15748 abs_mes = 'ABSOLUTE value of'
15749 else
15750 abs_mes = ''
15751
15752 end if
15753
15754 end if
15755 deallocate(mask_array, judge, judge_rev)
15756 deallocate(answer_negative, check_negative, both_negative)
15757
15758
15759
15760
15761 if (err_flag) then
15762 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15763 write(*,*) ''
15764 write(*,*) ' ' // trim(abs_mes) // &
15765 & ' check' // trim(pos_str) // ' = ', wrong
15766 write(*,*) ' is NOT LESS THAN'
15767 write(*,*) ' ' // trim(abs_mes) // &
15768 & ' answer' // trim(pos_str) // ' = ', right
15769
15770 call abortprogram('')
15771 else
15772 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15773 end if
15774
15775
15776 end subroutine dctestassertlessthanreal4
15777
15778
15779 subroutine dctestassertlessthanreal5( &
15780 & message, answer, check, negative_support)
15781 use sysdep, only: abortprogram
15782 use dc_types, only: string, token
15783 implicit none
15784 character(*), intent(in):: message
15785 real, intent(in):: answer(:,:,:,:,:)
15786 real, intent(in):: check(:,:,:,:,:)
15787 logical, intent(in), optional:: negative_support
15788 logical:: err_flag
15789 logical:: negative_support_on
15790 character(STRING):: pos_str
15791 character(TOKEN):: abs_mes
15792 real:: wrong, right
15793
15794 integer:: answer_shape(5), check_shape(5), pos(5)
15795 logical:: consist_shape(5)
15796 character(TOKEN):: pos_array(5)
15797 integer, allocatable:: mask_array(:,:,:,:,:)
15798 logical, allocatable:: judge(:,:,:,:,:)
15799 logical, allocatable:: judge_rev(:,:,:,:,:)
15800 logical, allocatable:: answer_negative(:,:,:,:,:)
15801 logical, allocatable:: check_negative(:,:,:,:,:)
15802 logical, allocatable:: both_negative(:,:,:,:,:)
15803
15804
15805 continue
15806 if (present(negative_support)) then
15807 negative_support_on = negative_support
15808 else
15809 negative_support_on = .true.
15810 end if
15811
15812 err_flag = .false.
15813
15814
15815 answer_shape = shape(answer)
15816 check_shape = shape(check)
15817
15818 consist_shape = answer_shape == check_shape
15819
15820 if (.not. all(consist_shape)) then
15821 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15822 write(*,*) ''
15823 write(*,*) ' shape of check is (', check_shape, ')'
15824 write(*,*) ' is INCORRECT'
15825 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15826
15827 call abortprogram('')
15828 end if
15829
15830
15831 allocate( mask_array( &
15832 & answer_shape(1), &
15833
15834 & answer_shape(2), &
15835
15836 & answer_shape(3), &
15837
15838 & answer_shape(4), &
15839
15840 & answer_shape(5) ) &
15841 & )
15842
15843 allocate( judge( &
15844 & answer_shape(1), &
15845
15846 & answer_shape(2), &
15847
15848 & answer_shape(3), &
15849
15850 & answer_shape(4), &
15851
15852 & answer_shape(5) ) &
15853 & )
15854
15855 allocate( judge_rev( &
15856 & answer_shape(1), &
15857
15858 & answer_shape(2), &
15859
15860 & answer_shape(3), &
15861
15862 & answer_shape(4), &
15863
15864 & answer_shape(5) ) &
15865 & )
15866
15867 allocate( answer_negative( &
15868 & answer_shape(1), &
15869
15870 & answer_shape(2), &
15871
15872 & answer_shape(3), &
15873
15874 & answer_shape(4), &
15875
15876 & answer_shape(5) ) &
15877 & )
15878
15879 allocate( check_negative( &
15880 & answer_shape(1), &
15881
15882 & answer_shape(2), &
15883
15884 & answer_shape(3), &
15885
15886 & answer_shape(4), &
15887
15888 & answer_shape(5) ) &
15889 & )
15890
15891 allocate( both_negative( &
15892 & answer_shape(1), &
15893
15894 & answer_shape(2), &
15895
15896 & answer_shape(3), &
15897
15898 & answer_shape(4), &
15899
15900 & answer_shape(5) ) &
15901 & )
15902
15903 answer_negative = answer < 0.0
15904 check_negative = check < 0.0
15905 both_negative = answer_negative .and. check_negative
15906 if (.not. negative_support_on) both_negative = .false.
15907
15908 judge = answer > check
15909 where (both_negative) judge = .not. judge
15910
15911 judge_rev = .not. judge
15912 err_flag = any(judge_rev)
15913 mask_array = 1
15914 pos = maxloc(mask_array, judge_rev)
15915
15916 if (err_flag) then
15917
15918 wrong = check( &
15919 & pos(1), &
15920
15921 & pos(2), &
15922
15923 & pos(3), &
15924
15925 & pos(4), &
15926
15927 & pos(5) )
15928
15929 right = answer( &
15930 & pos(1), &
15931
15932 & pos(2), &
15933
15934 & pos(3), &
15935
15936 & pos(4), &
15937
15938 & pos(5) )
15939
15940 write(unit=pos_array(1), fmt="(i20)") pos(1)
15941
15942 write(unit=pos_array(2), fmt="(i20)") pos(2)
15943
15944 write(unit=pos_array(3), fmt="(i20)") pos(3)
15945
15946 write(unit=pos_array(4), fmt="(i20)") pos(4)
15947
15948 write(unit=pos_array(5), fmt="(i20)") pos(5)
15949
15950
15951 pos_str = '(' // &
15952 & trim(adjustl(pos_array(1))) // ',' // &
15953
15954 & trim(adjustl(pos_array(2))) // ',' // &
15955
15956 & trim(adjustl(pos_array(3))) // ',' // &
15957
15958 & trim(adjustl(pos_array(4))) // ',' // &
15959
15960 & trim(adjustl(pos_array(5))) // ')'
15961
15962 if ( both_negative( &
15963 & pos(1), &
15964
15965 & pos(2), &
15966
15967 & pos(3), &
15968
15969 & pos(4), &
15970
15971 & pos(5) ) ) then
15972
15973 abs_mes = 'ABSOLUTE value of'
15974 else
15975 abs_mes = ''
15976
15977 end if
15978
15979 end if
15980 deallocate(mask_array, judge, judge_rev)
15981 deallocate(answer_negative, check_negative, both_negative)
15982
15983
15984
15985
15986 if (err_flag) then
15987 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15988 write(*,*) ''
15989 write(*,*) ' ' // trim(abs_mes) // &
15990 & ' check' // trim(pos_str) // ' = ', wrong
15991 write(*,*) ' is NOT LESS THAN'
15992 write(*,*) ' ' // trim(abs_mes) // &
15993 & ' answer' // trim(pos_str) // ' = ', right
15994
15995 call abortprogram('')
15996 else
15997 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15998 end if
15999
16000
16001 end subroutine dctestassertlessthanreal5
16002
16003
16004 subroutine dctestassertlessthanreal6( &
16005 & message, answer, check, negative_support)
16006 use sysdep, only: abortprogram
16007 use dc_types, only: string, token
16008 implicit none
16009 character(*), intent(in):: message
16010 real, intent(in):: answer(:,:,:,:,:,:)
16011 real, intent(in):: check(:,:,:,:,:,:)
16012 logical, intent(in), optional:: negative_support
16013 logical:: err_flag
16014 logical:: negative_support_on
16015 character(STRING):: pos_str
16016 character(TOKEN):: abs_mes
16017 real:: wrong, right
16018
16019 integer:: answer_shape(6), check_shape(6), pos(6)
16020 logical:: consist_shape(6)
16021 character(TOKEN):: pos_array(6)
16022 integer, allocatable:: mask_array(:,:,:,:,:,:)
16023 logical, allocatable:: judge(:,:,:,:,:,:)
16024 logical, allocatable:: judge_rev(:,:,:,:,:,:)
16025 logical, allocatable:: answer_negative(:,:,:,:,:,:)
16026 logical, allocatable:: check_negative(:,:,:,:,:,:)
16027 logical, allocatable:: both_negative(:,:,:,:,:,:)
16028
16029
16030 continue
16031 if (present(negative_support)) then
16032 negative_support_on = negative_support
16033 else
16034 negative_support_on = .true.
16035 end if
16036
16037 err_flag = .false.
16038
16039
16040 answer_shape = shape(answer)
16041 check_shape = shape(check)
16042
16043 consist_shape = answer_shape == check_shape
16044
16045 if (.not. all(consist_shape)) then
16046 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16047 write(*,*) ''
16048 write(*,*) ' shape of check is (', check_shape, ')'
16049 write(*,*) ' is INCORRECT'
16050 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
16051
16052 call abortprogram('')
16053 end if
16054
16055
16056 allocate( mask_array( &
16057 & answer_shape(1), &
16058
16059 & answer_shape(2), &
16060
16061 & answer_shape(3), &
16062
16063 & answer_shape(4), &
16064
16065 & answer_shape(5), &
16066
16067 & answer_shape(6) ) &
16068 & )
16069
16070 allocate( judge( &
16071 & answer_shape(1), &
16072
16073 & answer_shape(2), &
16074
16075 & answer_shape(3), &
16076
16077 & answer_shape(4), &
16078
16079 & answer_shape(5), &
16080
16081 & answer_shape(6) ) &
16082 & )
16083
16084 allocate( judge_rev( &
16085 & answer_shape(1), &
16086
16087 & answer_shape(2), &
16088
16089 & answer_shape(3), &
16090
16091 & answer_shape(4), &
16092
16093 & answer_shape(5), &
16094
16095 & answer_shape(6) ) &
16096 & )
16097
16098 allocate( answer_negative( &
16099 & answer_shape(1), &
16100
16101 & answer_shape(2), &
16102
16103 & answer_shape(3), &
16104
16105 & answer_shape(4), &
16106
16107 & answer_shape(5), &
16108
16109 & answer_shape(6) ) &
16110 & )
16111
16112 allocate( check_negative( &
16113 & answer_shape(1), &
16114
16115 & answer_shape(2), &
16116
16117 & answer_shape(3), &
16118
16119 & answer_shape(4), &
16120
16121 & answer_shape(5), &
16122
16123 & answer_shape(6) ) &
16124 & )
16125
16126 allocate( both_negative( &
16127 & answer_shape(1), &
16128
16129 & answer_shape(2), &
16130
16131 & answer_shape(3), &
16132
16133 & answer_shape(4), &
16134
16135 & answer_shape(5), &
16136
16137 & answer_shape(6) ) &
16138 & )
16139
16140 answer_negative = answer < 0.0
16141 check_negative = check < 0.0
16142 both_negative = answer_negative .and. check_negative
16143 if (.not. negative_support_on) both_negative = .false.
16144
16145 judge = answer > check
16146 where (both_negative) judge = .not. judge
16147
16148 judge_rev = .not. judge
16149 err_flag = any(judge_rev)
16150 mask_array = 1
16151 pos = maxloc(mask_array, judge_rev)
16152
16153 if (err_flag) then
16154
16155 wrong = check( &
16156 & pos(1), &
16157
16158 & pos(2), &
16159
16160 & pos(3), &
16161
16162 & pos(4), &
16163
16164 & pos(5), &
16165
16166 & pos(6) )
16167
16168 right = answer( &
16169 & pos(1), &
16170
16171 & pos(2), &
16172
16173 & pos(3), &
16174
16175 & pos(4), &
16176
16177 & pos(5), &
16178
16179 & pos(6) )
16180
16181 write(unit=pos_array(1), fmt="(i20)") pos(1)
16182
16183 write(unit=pos_array(2), fmt="(i20)") pos(2)
16184
16185 write(unit=pos_array(3), fmt="(i20)") pos(3)
16186
16187 write(unit=pos_array(4), fmt="(i20)") pos(4)
16188
16189 write(unit=pos_array(5), fmt="(i20)") pos(5)
16190
16191 write(unit=pos_array(6), fmt="(i20)") pos(6)
16192
16193
16194 pos_str = '(' // &
16195 & trim(adjustl(pos_array(1))) // ',' // &
16196
16197 & trim(adjustl(pos_array(2))) // ',' // &
16198
16199 & trim(adjustl(pos_array(3))) // ',' // &
16200
16201 & trim(adjustl(pos_array(4))) // ',' // &
16202
16203 & trim(adjustl(pos_array(5))) // ',' // &
16204
16205 & trim(adjustl(pos_array(6))) // ')'
16206
16207 if ( both_negative( &
16208 & pos(1), &
16209
16210 & pos(2), &
16211
16212 & pos(3), &
16213
16214 & pos(4), &
16215
16216 & pos(5), &
16217
16218 & pos(6) ) ) then
16219
16220 abs_mes = 'ABSOLUTE value of'
16221 else
16222 abs_mes = ''
16223
16224 end if
16225
16226 end if
16227 deallocate(mask_array, judge, judge_rev)
16228 deallocate(answer_negative, check_negative, both_negative)
16229
16230
16231
16232
16233 if (err_flag) then
16234 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16235 write(*,*) ''
16236 write(*,*) ' ' // trim(abs_mes) // &
16237 & ' check' // trim(pos_str) // ' = ', wrong
16238 write(*,*) ' is NOT LESS THAN'
16239 write(*,*) ' ' // trim(abs_mes) // &
16240 & ' answer' // trim(pos_str) // ' = ', right
16241
16242 call abortprogram('')
16243 else
16244 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16245 end if
16246
16247
16248 end subroutine dctestassertlessthanreal6
16249
16250
16251 subroutine dctestassertlessthanreal7( &
16252 & message, answer, check, negative_support)
16253 use sysdep, only: abortprogram
16254 use dc_types, only: string, token
16255 implicit none
16256 character(*), intent(in):: message
16257 real, intent(in):: answer(:,:,:,:,:,:,:)
16258 real, intent(in):: check(:,:,:,:,:,:,:)
16259 logical, intent(in), optional:: negative_support
16260 logical:: err_flag
16261 logical:: negative_support_on
16262 character(STRING):: pos_str
16263 character(TOKEN):: abs_mes
16264 real:: wrong, right
16265
16266 integer:: answer_shape(7), check_shape(7), pos(7)
16267 logical:: consist_shape(7)
16268 character(TOKEN):: pos_array(7)
16269 integer, allocatable:: mask_array(:,:,:,:,:,:,:)
16270 logical, allocatable:: judge(:,:,:,:,:,:,:)
16271 logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
16272 logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
16273 logical, allocatable:: check_negative(:,:,:,:,:,:,:)
16274 logical, allocatable:: both_negative(:,:,:,:,:,:,:)
16275
16276
16277 continue
16278 if (present(negative_support)) then
16279 negative_support_on = negative_support
16280 else
16281 negative_support_on = .true.
16282 end if
16283
16284 err_flag = .false.
16285
16286
16287 answer_shape = shape(answer)
16288 check_shape = shape(check)
16289
16290 consist_shape = answer_shape == check_shape
16291
16292 if (.not. all(consist_shape)) then
16293 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16294 write(*,*) ''
16295 write(*,*) ' shape of check is (', check_shape, ')'
16296 write(*,*) ' is INCORRECT'
16297 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
16298
16299 call abortprogram('')
16300 end if
16301
16302
16303 allocate( mask_array( &
16304 & answer_shape(1), &
16305
16306 & answer_shape(2), &
16307
16308 & answer_shape(3), &
16309
16310 & answer_shape(4), &
16311
16312 & answer_shape(5), &
16313
16314 & answer_shape(6), &
16315
16316 & answer_shape(7) ) &
16317 & )
16318
16319 allocate( judge( &
16320 & answer_shape(1), &
16321
16322 & answer_shape(2), &
16323
16324 & answer_shape(3), &
16325
16326 & answer_shape(4), &
16327
16328 & answer_shape(5), &
16329
16330 & answer_shape(6), &
16331
16332 & answer_shape(7) ) &
16333 & )
16334
16335 allocate( judge_rev( &
16336 & answer_shape(1), &
16337
16338 & answer_shape(2), &
16339
16340 & answer_shape(3), &
16341
16342 & answer_shape(4), &
16343
16344 & answer_shape(5), &
16345
16346 & answer_shape(6), &
16347
16348 & answer_shape(7) ) &
16349 & )
16350
16351 allocate( answer_negative( &
16352 & answer_shape(1), &
16353
16354 & answer_shape(2), &
16355
16356 & answer_shape(3), &
16357
16358 & answer_shape(4), &
16359
16360 & answer_shape(5), &
16361
16362 & answer_shape(6), &
16363
16364 & answer_shape(7) ) &
16365 & )
16366
16367 allocate( check_negative( &
16368 & answer_shape(1), &
16369
16370 & answer_shape(2), &
16371
16372 & answer_shape(3), &
16373
16374 & answer_shape(4), &
16375
16376 & answer_shape(5), &
16377
16378 & answer_shape(6), &
16379
16380 & answer_shape(7) ) &
16381 & )
16382
16383 allocate( both_negative( &
16384 & answer_shape(1), &
16385
16386 & answer_shape(2), &
16387
16388 & answer_shape(3), &
16389
16390 & answer_shape(4), &
16391
16392 & answer_shape(5), &
16393
16394 & answer_shape(6), &
16395
16396 & answer_shape(7) ) &
16397 & )
16398
16399 answer_negative = answer < 0.0
16400 check_negative = check < 0.0
16401 both_negative = answer_negative .and. check_negative
16402 if (.not. negative_support_on) both_negative = .false.
16403
16404 judge = answer > check
16405 where (both_negative) judge = .not. judge
16406
16407 judge_rev = .not. judge
16408 err_flag = any(judge_rev)
16409 mask_array = 1
16410 pos = maxloc(mask_array, judge_rev)
16411
16412 if (err_flag) then
16413
16414 wrong = check( &
16415 & pos(1), &
16416
16417 & pos(2), &
16418
16419 & pos(3), &
16420
16421 & pos(4), &
16422
16423 & pos(5), &
16424
16425 & pos(6), &
16426
16427 & pos(7) )
16428
16429 right = answer( &
16430 & pos(1), &
16431
16432 & pos(2), &
16433
16434 & pos(3), &
16435
16436 & pos(4), &
16437
16438 & pos(5), &
16439
16440 & pos(6), &
16441
16442 & pos(7) )
16443
16444 write(unit=pos_array(1), fmt="(i20)") pos(1)
16445
16446 write(unit=pos_array(2), fmt="(i20)") pos(2)
16447
16448 write(unit=pos_array(3), fmt="(i20)") pos(3)
16449
16450 write(unit=pos_array(4), fmt="(i20)") pos(4)
16451
16452 write(unit=pos_array(5), fmt="(i20)") pos(5)
16453
16454 write(unit=pos_array(6), fmt="(i20)") pos(6)
16455
16456 write(unit=pos_array(7), fmt="(i20)") pos(7)
16457
16458
16459 pos_str = '(' // &
16460 & trim(adjustl(pos_array(1))) // ',' // &
16461
16462 & trim(adjustl(pos_array(2))) // ',' // &
16463
16464 & trim(adjustl(pos_array(3))) // ',' // &
16465
16466 & trim(adjustl(pos_array(4))) // ',' // &
16467
16468 & trim(adjustl(pos_array(5))) // ',' // &
16469
16470 & trim(adjustl(pos_array(6))) // ',' // &
16471
16472 & trim(adjustl(pos_array(7))) // ')'
16473
16474 if ( both_negative( &
16475 & pos(1), &
16476
16477 & pos(2), &
16478
16479 & pos(3), &
16480
16481 & pos(4), &
16482
16483 & pos(5), &
16484
16485 & pos(6), &
16486
16487 & pos(7) ) ) then
16488
16489 abs_mes = 'ABSOLUTE value of'
16490 else
16491 abs_mes = ''
16492
16493 end if
16494
16495 end if
16496 deallocate(mask_array, judge, judge_rev)
16497 deallocate(answer_negative, check_negative, both_negative)
16498
16499
16500
16501
16502 if (err_flag) then
16503 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16504 write(*,*) ''
16505 write(*,*) ' ' // trim(abs_mes) // &
16506 & ' check' // trim(pos_str) // ' = ', wrong
16507 write(*,*) ' is NOT LESS THAN'
16508 write(*,*) ' ' // trim(abs_mes) // &
16509 & ' answer' // trim(pos_str) // ' = ', right
16510
16511 call abortprogram('')
16512 else
16513 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16514 end if
16515
16516
16517 end subroutine dctestassertlessthanreal7
16518
16519
16520 subroutine dctestassertlessthandouble0( &
16521 & message, answer, check, negative_support)
16522 use sysdep, only: abortprogram
16523 use dc_types, only: string, token
16524 implicit none
16525 character(*), intent(in):: message
16526 real(DP), intent(in):: answer
16527 real(DP), intent(in):: check
16528 logical, intent(in), optional:: negative_support
16529 logical:: err_flag
16530 logical:: negative_support_on
16531 character(STRING):: pos_str
16532 character(TOKEN):: abs_mes
16533 real(DP):: wrong, right
16534
16535
16536
16537 continue
16538 if (present(negative_support)) then
16539 negative_support_on = negative_support
16540 else
16541 negative_support_on = .true.
16542 end if
16543
16544 err_flag = .false.
16545
16546
16547
16548
16549 err_flag = .not. answer > check
16550 abs_mes = ''
16551
16552 if ( answer < 0.0_dp &
16553 & .and. check < 0.0_dp &
16554 & .and. negative_support_on ) then
16555
16556 err_flag = .not. err_flag
16557 abs_mes = 'ABSOLUTE value of'
16558 end if
16559
16560 wrong = check
16561 right = answer
16562 pos_str = ''
16563
16564
16565
16566
16567 if (err_flag) then
16568 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16569 write(*,*) ''
16570 write(*,*) ' ' // trim(abs_mes) // &
16571 & ' check' // trim(pos_str) // ' = ', wrong
16572 write(*,*) ' is NOT LESS THAN'
16573 write(*,*) ' ' // trim(abs_mes) // &
16574 & ' answer' // trim(pos_str) // ' = ', right
16575
16576 call abortprogram('')
16577 else
16578 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16579 end if
16580
16581
16582 end subroutine dctestassertlessthandouble0
16583
16584
16585 subroutine dctestassertlessthandouble1( &
16586 & message, answer, check, negative_support)
16587 use sysdep, only: abortprogram
16588 use dc_types, only: string, token
16589 implicit none
16590 character(*), intent(in):: message
16591 real(DP), intent(in):: answer(:)
16592 real(DP), intent(in):: check(:)
16593 logical, intent(in), optional:: negative_support
16594 logical:: err_flag
16595 logical:: negative_support_on
16596 character(STRING):: pos_str
16597 character(TOKEN):: abs_mes
16598 real(DP):: wrong, right
16599
16600 integer:: answer_shape(1), check_shape(1), pos(1)
16601 logical:: consist_shape(1)
16602 character(TOKEN):: pos_array(1)
16603 integer, allocatable:: mask_array(:)
16604 logical, allocatable:: judge(:)
16605 logical, allocatable:: judge_rev(:)
16606 logical, allocatable:: answer_negative(:)
16607 logical, allocatable:: check_negative(:)
16608 logical, allocatable:: both_negative(:)
16609
16610
16611 continue
16612 if (present(negative_support)) then
16613 negative_support_on = negative_support
16614 else
16615 negative_support_on = .true.
16616 end if
16617
16618 err_flag = .false.
16619
16620
16621 answer_shape = shape(answer)
16622 check_shape = shape(check)
16623
16624 consist_shape = answer_shape == check_shape
16625
16626 if (.not. all(consist_shape)) then
16627 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16628 write(*,*) ''
16629 write(*,*) ' shape of check is (', check_shape, ')'
16630 write(*,*) ' is INCORRECT'
16631 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
16632
16633 call abortprogram('')
16634 end if
16635
16636
16637 allocate( mask_array( &
16638
16639 & answer_shape(1) ) &
16640 & )
16641
16642 allocate( judge( &
16643
16644 & answer_shape(1) ) &
16645 & )
16646
16647 allocate( judge_rev( &
16648
16649 & answer_shape(1) ) &
16650 & )
16651
16652 allocate( answer_negative( &
16653
16654 & answer_shape(1) ) &
16655 & )
16656
16657 allocate( check_negative( &
16658
16659 & answer_shape(1) ) &
16660 & )
16661
16662 allocate( both_negative( &
16663
16664 & answer_shape(1) ) &
16665 & )
16666
16667 answer_negative = answer < 0.0_dp
16668 check_negative = check < 0.0_dp
16669 both_negative = answer_negative .and. check_negative
16670 if (.not. negative_support_on) both_negative = .false.
16671
16672 judge = answer > check
16673 where (both_negative) judge = .not. judge
16674
16675 judge_rev = .not. judge
16676 err_flag = any(judge_rev)
16677 mask_array = 1
16678 pos = maxloc(mask_array, judge_rev)
16679
16680 if (err_flag) then
16681
16682 wrong = check( &
16683
16684 & pos(1) )
16685
16686 right = answer( &
16687
16688 & pos(1) )
16689
16690 write(unit=pos_array(1), fmt="(i20)") pos(1)
16691
16692
16693 pos_str = '(' // &
16694
16695 & trim(adjustl(pos_array(1))) // ')'
16696
16697 if ( both_negative( &
16698
16699 & pos(1) ) ) then
16700
16701 abs_mes = 'ABSOLUTE value of'
16702 else
16703 abs_mes = ''
16704
16705 end if
16706
16707 end if
16708 deallocate(mask_array, judge, judge_rev)
16709 deallocate(answer_negative, check_negative, both_negative)
16710
16711
16712
16713
16714 if (err_flag) then
16715 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16716 write(*,*) ''
16717 write(*,*) ' ' // trim(abs_mes) // &
16718 & ' check' // trim(pos_str) // ' = ', wrong
16719 write(*,*) ' is NOT LESS THAN'
16720 write(*,*) ' ' // trim(abs_mes) // &
16721 & ' answer' // trim(pos_str) // ' = ', right
16722
16723 call abortprogram('')
16724 else
16725 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16726 end if
16727
16728
16729 end subroutine dctestassertlessthandouble1
16730
16731
16732 subroutine dctestassertlessthandouble2( &
16733 & message, answer, check, negative_support)
16734 use sysdep, only: abortprogram
16735 use dc_types, only: string, token
16736 implicit none
16737 character(*), intent(in):: message
16738 real(DP), intent(in):: answer(:,:)
16739 real(DP), intent(in):: check(:,:)
16740 logical, intent(in), optional:: negative_support
16741 logical:: err_flag
16742 logical:: negative_support_on
16743 character(STRING):: pos_str
16744 character(TOKEN):: abs_mes
16745 real(DP):: wrong, right
16746
16747 integer:: answer_shape(2), check_shape(2), pos(2)
16748 logical:: consist_shape(2)
16749 character(TOKEN):: pos_array(2)
16750 integer, allocatable:: mask_array(:,:)
16751 logical, allocatable:: judge(:,:)
16752 logical, allocatable:: judge_rev(:,:)
16753 logical, allocatable:: answer_negative(:,:)
16754 logical, allocatable:: check_negative(:,:)
16755 logical, allocatable:: both_negative(:,:)
16756
16757
16758 continue
16759 if (present(negative_support)) then
16760 negative_support_on = negative_support
16761 else
16762 negative_support_on = .true.
16763 end if
16764
16765 err_flag = .false.
16766
16767
16768 answer_shape = shape(answer)
16769 check_shape = shape(check)
16770
16771 consist_shape = answer_shape == check_shape
16772
16773 if (.not. all(consist_shape)) then
16774 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16775 write(*,*) ''
16776 write(*,*) ' shape of check is (', check_shape, ')'
16777 write(*,*) ' is INCORRECT'
16778 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
16779
16780 call abortprogram('')
16781 end if
16782
16783
16784 allocate( mask_array( &
16785 & answer_shape(1), &
16786
16787 & answer_shape(2) ) &
16788 & )
16789
16790 allocate( judge( &
16791 & answer_shape(1), &
16792
16793 & answer_shape(2) ) &
16794 & )
16795
16796 allocate( judge_rev( &
16797 & answer_shape(1), &
16798
16799 & answer_shape(2) ) &
16800 & )
16801
16802 allocate( answer_negative( &
16803 & answer_shape(1), &
16804
16805 & answer_shape(2) ) &
16806 & )
16807
16808 allocate( check_negative( &
16809 & answer_shape(1), &
16810
16811 & answer_shape(2) ) &
16812 & )
16813
16814 allocate( both_negative( &
16815 & answer_shape(1), &
16816
16817 & answer_shape(2) ) &
16818 & )
16819
16820 answer_negative = answer < 0.0_dp
16821 check_negative = check < 0.0_dp
16822 both_negative = answer_negative .and. check_negative
16823 if (.not. negative_support_on) both_negative = .false.
16824
16825 judge = answer > check
16826 where (both_negative) judge = .not. judge
16827
16828 judge_rev = .not. judge
16829 err_flag = any(judge_rev)
16830 mask_array = 1
16831 pos = maxloc(mask_array, judge_rev)
16832
16833 if (err_flag) then
16834
16835 wrong = check( &
16836 & pos(1), &
16837
16838 & pos(2) )
16839
16840 right = answer( &
16841 & pos(1), &
16842
16843 & pos(2) )
16844
16845 write(unit=pos_array(1), fmt="(i20)") pos(1)
16846
16847 write(unit=pos_array(2), fmt="(i20)") pos(2)
16848
16849
16850 pos_str = '(' // &
16851 & trim(adjustl(pos_array(1))) // ',' // &
16852
16853 & trim(adjustl(pos_array(2))) // ')'
16854
16855 if ( both_negative( &
16856 & pos(1), &
16857
16858 & pos(2) ) ) then
16859
16860 abs_mes = 'ABSOLUTE value of'
16861 else
16862 abs_mes = ''
16863
16864 end if
16865
16866 end if
16867 deallocate(mask_array, judge, judge_rev)
16868 deallocate(answer_negative, check_negative, both_negative)
16869
16870
16871
16872
16873 if (err_flag) then
16874 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16875 write(*,*) ''
16876 write(*,*) ' ' // trim(abs_mes) // &
16877 & ' check' // trim(pos_str) // ' = ', wrong
16878 write(*,*) ' is NOT LESS THAN'
16879 write(*,*) ' ' // trim(abs_mes) // &
16880 & ' answer' // trim(pos_str) // ' = ', right
16881
16882 call abortprogram('')
16883 else
16884 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16885 end if
16886
16887
16888 end subroutine dctestassertlessthandouble2
16889
16890
16891 subroutine dctestassertlessthandouble3( &
16892 & message, answer, check, negative_support)
16893 use sysdep, only: abortprogram
16894 use dc_types, only: string, token
16895 implicit none
16896 character(*), intent(in):: message
16897 real(DP), intent(in):: answer(:,:,:)
16898 real(DP), intent(in):: check(:,:,:)
16899 logical, intent(in), optional:: negative_support
16900 logical:: err_flag
16901 logical:: negative_support_on
16902 character(STRING):: pos_str
16903 character(TOKEN):: abs_mes
16904 real(DP):: wrong, right
16905
16906 integer:: answer_shape(3), check_shape(3), pos(3)
16907 logical:: consist_shape(3)
16908 character(TOKEN):: pos_array(3)
16909 integer, allocatable:: mask_array(:,:,:)
16910 logical, allocatable:: judge(:,:,:)
16911 logical, allocatable:: judge_rev(:,:,:)
16912 logical, allocatable:: answer_negative(:,:,:)
16913 logical, allocatable:: check_negative(:,:,:)
16914 logical, allocatable:: both_negative(:,:,:)
16915
16916
16917 continue
16918 if (present(negative_support)) then
16919 negative_support_on = negative_support
16920 else
16921 negative_support_on = .true.
16922 end if
16923
16924 err_flag = .false.
16925
16926
16927 answer_shape = shape(answer)
16928 check_shape = shape(check)
16929
16930 consist_shape = answer_shape == check_shape
16931
16932 if (.not. all(consist_shape)) then
16933 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16934 write(*,*) ''
16935 write(*,*) ' shape of check is (', check_shape, ')'
16936 write(*,*) ' is INCORRECT'
16937 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
16938
16939 call abortprogram('')
16940 end if
16941
16942
16943 allocate( mask_array( &
16944 & answer_shape(1), &
16945
16946 & answer_shape(2), &
16947
16948 & answer_shape(3) ) &
16949 & )
16950
16951 allocate( judge( &
16952 & answer_shape(1), &
16953
16954 & answer_shape(2), &
16955
16956 & answer_shape(3) ) &
16957 & )
16958
16959 allocate( judge_rev( &
16960 & answer_shape(1), &
16961
16962 & answer_shape(2), &
16963
16964 & answer_shape(3) ) &
16965 & )
16966
16967 allocate( answer_negative( &
16968 & answer_shape(1), &
16969
16970 & answer_shape(2), &
16971
16972 & answer_shape(3) ) &
16973 & )
16974
16975 allocate( check_negative( &
16976 & answer_shape(1), &
16977
16978 & answer_shape(2), &
16979
16980 & answer_shape(3) ) &
16981 & )
16982
16983 allocate( both_negative( &
16984 & answer_shape(1), &
16985
16986 & answer_shape(2), &
16987
16988 & answer_shape(3) ) &
16989 & )
16990
16991 answer_negative = answer < 0.0_dp
16992 check_negative = check < 0.0_dp
16993 both_negative = answer_negative .and. check_negative
16994 if (.not. negative_support_on) both_negative = .false.
16995
16996 judge = answer > check
16997 where (both_negative) judge = .not. judge
16998
16999 judge_rev = .not. judge
17000 err_flag = any(judge_rev)
17001 mask_array = 1
17002 pos = maxloc(mask_array, judge_rev)
17003
17004 if (err_flag) then
17005
17006 wrong = check( &
17007 & pos(1), &
17008
17009 & pos(2), &
17010
17011 & pos(3) )
17012
17013 right = answer( &
17014 & pos(1), &
17015
17016 & pos(2), &
17017
17018 & pos(3) )
17019
17020 write(unit=pos_array(1), fmt="(i20)") pos(1)
17021
17022 write(unit=pos_array(2), fmt="(i20)") pos(2)
17023
17024 write(unit=pos_array(3), fmt="(i20)") pos(3)
17025
17026
17027 pos_str = '(' // &
17028 & trim(adjustl(pos_array(1))) // ',' // &
17029
17030 & trim(adjustl(pos_array(2))) // ',' // &
17031
17032 & trim(adjustl(pos_array(3))) // ')'
17033
17034 if ( both_negative( &
17035 & pos(1), &
17036
17037 & pos(2), &
17038
17039 & pos(3) ) ) then
17040
17041 abs_mes = 'ABSOLUTE value of'
17042 else
17043 abs_mes = ''
17044
17045 end if
17046
17047 end if
17048 deallocate(mask_array, judge, judge_rev)
17049 deallocate(answer_negative, check_negative, both_negative)
17050
17051
17052
17053
17054 if (err_flag) then
17055 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17056 write(*,*) ''
17057 write(*,*) ' ' // trim(abs_mes) // &
17058 & ' check' // trim(pos_str) // ' = ', wrong
17059 write(*,*) ' is NOT LESS THAN'
17060 write(*,*) ' ' // trim(abs_mes) // &
17061 & ' answer' // trim(pos_str) // ' = ', right
17062
17063 call abortprogram('')
17064 else
17065 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
17066 end if
17067
17068
17069 end subroutine dctestassertlessthandouble3
17070
17071
17072 subroutine dctestassertlessthandouble4( &
17073 & message, answer, check, negative_support)
17074 use sysdep, only: abortprogram
17075 use dc_types, only: string, token
17076 implicit none
17077 character(*), intent(in):: message
17078 real(DP), intent(in):: answer(:,:,:,:)
17079 real(DP), intent(in):: check(:,:,:,:)
17080 logical, intent(in), optional:: negative_support
17081 logical:: err_flag
17082 logical:: negative_support_on
17083 character(STRING):: pos_str
17084 character(TOKEN):: abs_mes
17085 real(DP):: wrong, right
17086
17087 integer:: answer_shape(4), check_shape(4), pos(4)
17088 logical:: consist_shape(4)
17089 character(TOKEN):: pos_array(4)
17090 integer, allocatable:: mask_array(:,:,:,:)
17091 logical, allocatable:: judge(:,:,:,:)
17092 logical, allocatable:: judge_rev(:,:,:,:)
17093 logical, allocatable:: answer_negative(:,:,:,:)
17094 logical, allocatable:: check_negative(:,:,:,:)
17095 logical, allocatable:: both_negative(:,:,:,:)
17096
17097
17098 continue
17099 if (present(negative_support)) then
17100 negative_support_on = negative_support
17101 else
17102 negative_support_on = .true.
17103 end if
17104
17105 err_flag = .false.
17106
17107
17108 answer_shape = shape(answer)
17109 check_shape = shape(check)
17110
17111 consist_shape = answer_shape == check_shape
17112
17113 if (.not. all(consist_shape)) then
17114 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17115 write(*,*) ''
17116 write(*,*) ' shape of check is (', check_shape, ')'
17117 write(*,*) ' is INCORRECT'
17118 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
17119
17120 call abortprogram('')
17121 end if
17122
17123
17124 allocate( mask_array( &
17125 & answer_shape(1), &
17126
17127 & answer_shape(2), &
17128
17129 & answer_shape(3), &
17130
17131 & answer_shape(4) ) &
17132 & )
17133
17134 allocate( judge( &
17135 & answer_shape(1), &
17136
17137 & answer_shape(2), &
17138
17139 & answer_shape(3), &
17140
17141 & answer_shape(4) ) &
17142 & )
17143
17144 allocate( judge_rev( &
17145 & answer_shape(1), &
17146
17147 & answer_shape(2), &
17148
17149 & answer_shape(3), &
17150
17151 & answer_shape(4) ) &
17152 & )
17153
17154 allocate( answer_negative( &
17155 & answer_shape(1), &
17156
17157 & answer_shape(2), &
17158
17159 & answer_shape(3), &
17160
17161 & answer_shape(4) ) &
17162 & )
17163
17164 allocate( check_negative( &
17165 & answer_shape(1), &
17166
17167 & answer_shape(2), &
17168
17169 & answer_shape(3), &
17170
17171 & answer_shape(4) ) &
17172 & )
17173
17174 allocate( both_negative( &
17175 & answer_shape(1), &
17176
17177 & answer_shape(2), &
17178
17179 & answer_shape(3), &
17180
17181 & answer_shape(4) ) &
17182 & )
17183
17184 answer_negative = answer < 0.0_dp
17185 check_negative = check < 0.0_dp
17186 both_negative = answer_negative .and. check_negative
17187 if (.not. negative_support_on) both_negative = .false.
17188
17189 judge = answer > check
17190 where (both_negative) judge = .not. judge
17191
17192 judge_rev = .not. judge
17193 err_flag = any(judge_rev)
17194 mask_array = 1
17195 pos = maxloc(mask_array, judge_rev)
17196
17197 if (err_flag) then
17198
17199 wrong = check( &
17200 & pos(1), &
17201
17202 & pos(2), &
17203
17204 & pos(3), &
17205
17206 & pos(4) )
17207
17208 right = answer( &
17209 & pos(1), &
17210
17211 & pos(2), &
17212
17213 & pos(3), &
17214
17215 & pos(4) )
17216
17217 write(unit=pos_array(1), fmt="(i20)") pos(1)
17218
17219 write(unit=pos_array(2), fmt="(i20)") pos(2)
17220
17221 write(unit=pos_array(3), fmt="(i20)") pos(3)
17222
17223 write(unit=pos_array(4), fmt="(i20)") pos(4)
17224
17225
17226 pos_str = '(' // &
17227 & trim(adjustl(pos_array(1))) // ',' // &
17228
17229 & trim(adjustl(pos_array(2))) // ',' // &
17230
17231 & trim(adjustl(pos_array(3))) // ',' // &
17232
17233 & trim(adjustl(pos_array(4))) // ')'
17234
17235 if ( both_negative( &
17236 & pos(1), &
17237
17238 & pos(2), &
17239
17240 & pos(3), &
17241
17242 & pos(4) ) ) then
17243
17244 abs_mes = 'ABSOLUTE value of'
17245 else
17246 abs_mes = ''
17247
17248 end if
17249
17250 end if
17251 deallocate(mask_array, judge, judge_rev)
17252 deallocate(answer_negative, check_negative, both_negative)
17253
17254
17255
17256
17257 if (err_flag) then
17258 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17259 write(*,*) ''
17260 write(*,*) ' ' // trim(abs_mes) // &
17261 & ' check' // trim(pos_str) // ' = ', wrong
17262 write(*,*) ' is NOT LESS THAN'
17263 write(*,*) ' ' // trim(abs_mes) // &
17264 & ' answer' // trim(pos_str) // ' = ', right
17265
17266 call abortprogram('')
17267 else
17268 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
17269 end if
17270
17271
17272 end subroutine dctestassertlessthandouble4
17273
17274
17275 subroutine dctestassertlessthandouble5( &
17276 & message, answer, check, negative_support)
17277 use sysdep, only: abortprogram
17278 use dc_types, only: string, token
17279 implicit none
17280 character(*), intent(in):: message
17281 real(DP), intent(in):: answer(:,:,:,:,:)
17282 real(DP), intent(in):: check(:,:,:,:,:)
17283 logical, intent(in), optional:: negative_support
17284 logical:: err_flag
17285 logical:: negative_support_on
17286 character(STRING):: pos_str
17287 character(TOKEN):: abs_mes
17288 real(DP):: wrong, right
17289
17290 integer:: answer_shape(5), check_shape(5), pos(5)
17291 logical:: consist_shape(5)
17292 character(TOKEN):: pos_array(5)
17293 integer, allocatable:: mask_array(:,:,:,:,:)
17294 logical, allocatable:: judge(:,:,:,:,:)
17295 logical, allocatable:: judge_rev(:,:,:,:,:)
17296 logical, allocatable:: answer_negative(:,:,:,:,:)
17297 logical, allocatable:: check_negative(:,:,:,:,:)
17298 logical, allocatable:: both_negative(:,:,:,:,:)
17299
17300
17301 continue
17302 if (present(negative_support)) then
17303 negative_support_on = negative_support
17304 else
17305 negative_support_on = .true.
17306 end if
17307
17308 err_flag = .false.
17309
17310
17311 answer_shape = shape(answer)
17312 check_shape = shape(check)
17313
17314 consist_shape = answer_shape == check_shape
17315
17316 if (.not. all(consist_shape)) then
17317 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17318 write(*,*) ''
17319 write(*,*) ' shape of check is (', check_shape, ')'
17320 write(*,*) ' is INCORRECT'
17321 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
17322
17323 call abortprogram('')
17324 end if
17325
17326
17327 allocate( mask_array( &
17328 & answer_shape(1), &
17329
17330 & answer_shape(2), &
17331
17332 & answer_shape(3), &
17333
17334 & answer_shape(4), &
17335
17336 & answer_shape(5) ) &
17337 & )
17338
17339 allocate( judge( &
17340 & answer_shape(1), &
17341
17342 & answer_shape(2), &
17343
17344 & answer_shape(3), &
17345
17346 & answer_shape(4), &
17347
17348 & answer_shape(5) ) &
17349 & )
17350
17351 allocate( judge_rev( &
17352 & answer_shape(1), &
17353
17354 & answer_shape(2), &
17355
17356 & answer_shape(3), &
17357
17358 & answer_shape(4), &
17359
17360 & answer_shape(5) ) &
17361 & )
17362
17363 allocate( answer_negative( &
17364 & answer_shape(1), &
17365
17366 & answer_shape(2), &
17367
17368 & answer_shape(3), &
17369
17370 & answer_shape(4), &
17371
17372 & answer_shape(5) ) &
17373 & )
17374
17375 allocate( check_negative( &
17376 & answer_shape(1), &
17377
17378 & answer_shape(2), &
17379
17380 & answer_shape(3), &
17381
17382 & answer_shape(4), &
17383
17384 & answer_shape(5) ) &
17385 & )
17386
17387 allocate( both_negative( &
17388 & answer_shape(1), &
17389
17390 & answer_shape(2), &
17391
17392 & answer_shape(3), &
17393
17394 & answer_shape(4), &
17395
17396 & answer_shape(5) ) &
17397 & )
17398
17399 answer_negative = answer < 0.0_dp
17400 check_negative = check < 0.0_dp
17401 both_negative = answer_negative .and. check_negative
17402 if (.not. negative_support_on) both_negative = .false.
17403
17404 judge = answer > check
17405 where (both_negative) judge = .not. judge
17406
17407 judge_rev = .not. judge
17408 err_flag = any(judge_rev)
17409 mask_array = 1
17410 pos = maxloc(mask_array, judge_rev)
17411
17412 if (err_flag) then
17413
17414 wrong = check( &
17415 & pos(1), &
17416
17417 & pos(2), &
17418
17419 & pos(3), &
17420
17421 & pos(4), &
17422
17423 & pos(5) )
17424
17425 right = answer( &
17426 & pos(1), &
17427
17428 & pos(2), &
17429
17430 & pos(3), &
17431
17432 & pos(4), &
17433
17434 & pos(5) )
17435
17436 write(unit=pos_array(1), fmt="(i20)") pos(1)
17437
17438 write(unit=pos_array(2), fmt="(i20)") pos(2)
17439
17440 write(unit=pos_array(3), fmt="(i20)") pos(3)
17441
17442 write(unit=pos_array(4), fmt="(i20)") pos(4)
17443
17444 write(unit=pos_array(5), fmt="(i20)") pos(5)
17445
17446
17447 pos_str = '(' // &
17448 & trim(adjustl(pos_array(1))) // ',' // &
17449
17450 & trim(adjustl(pos_array(2))) // ',' // &
17451
17452 & trim(adjustl(pos_array(3))) // ',' // &
17453
17454 & trim(adjustl(pos_array(4))) // ',' // &
17455
17456 & trim(adjustl(pos_array(5))) // ')'
17457
17458 if ( both_negative( &
17459 & pos(1), &
17460
17461 & pos(2), &
17462
17463 & pos(3), &
17464
17465 & pos(4), &
17466
17467 & pos(5) ) ) then
17468
17469 abs_mes = 'ABSOLUTE value of'
17470 else
17471 abs_mes = ''
17472
17473 end if
17474
17475 end if
17476 deallocate(mask_array, judge, judge_rev)
17477 deallocate(answer_negative, check_negative, both_negative)
17478
17479
17480
17481
17482 if (err_flag) then
17483 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17484 write(*,*) ''
17485 write(*,*) ' ' // trim(abs_mes) // &
17486 & ' check' // trim(pos_str) // ' = ', wrong
17487 write(*,*) ' is NOT LESS THAN'
17488 write(*,*) ' ' // trim(abs_mes) // &
17489 & ' answer' // trim(pos_str) // ' = ', right
17490
17491 call abortprogram('')
17492 else
17493 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
17494 end if
17495
17496
17497 end subroutine dctestassertlessthandouble5
17498
17499
17500 subroutine dctestassertlessthandouble6( &
17501 & message, answer, check, negative_support)
17502 use sysdep, only: abortprogram
17503 use dc_types, only: string, token
17504 implicit none
17505 character(*), intent(in):: message
17506 real(DP), intent(in):: answer(:,:,:,:,:,:)
17507 real(DP), intent(in):: check(:,:,:,:,:,:)
17508 logical, intent(in), optional:: negative_support
17509 logical:: err_flag
17510 logical:: negative_support_on
17511 character(STRING):: pos_str
17512 character(TOKEN):: abs_mes
17513 real(DP):: wrong, right
17514
17515 integer:: answer_shape(6), check_shape(6), pos(6)
17516 logical:: consist_shape(6)
17517 character(TOKEN):: pos_array(6)
17518 integer, allocatable:: mask_array(:,:,:,:,:,:)
17519 logical, allocatable:: judge(:,:,:,:,:,:)
17520 logical, allocatable:: judge_rev(:,:,:,:,:,:)
17521 logical, allocatable:: answer_negative(:,:,:,:,:,:)
17522 logical, allocatable:: check_negative(:,:,:,:,:,:)
17523 logical, allocatable:: both_negative(:,:,:,:,:,:)
17524
17525
17526 continue
17527 if (present(negative_support)) then
17528 negative_support_on = negative_support
17529 else
17530 negative_support_on = .true.
17531 end if
17532
17533 err_flag = .false.
17534
17535
17536 answer_shape = shape(answer)
17537 check_shape = shape(check)
17538
17539 consist_shape = answer_shape == check_shape
17540
17541 if (.not. all(consist_shape)) then
17542 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17543 write(*,*) ''
17544 write(*,*) ' shape of check is (', check_shape, ')'
17545 write(*,*) ' is INCORRECT'
17546 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
17547
17548 call abortprogram('')
17549 end if
17550
17551
17552 allocate( mask_array( &
17553 & answer_shape(1), &
17554
17555 & answer_shape(2), &
17556
17557 & answer_shape(3), &
17558
17559 & answer_shape(4), &
17560
17561 & answer_shape(5), &
17562
17563 & answer_shape(6) ) &
17564 & )
17565
17566 allocate( judge( &
17567 & answer_shape(1), &
17568
17569 & answer_shape(2), &
17570
17571 & answer_shape(3), &
17572
17573 & answer_shape(4), &
17574
17575 & answer_shape(5), &
17576
17577 & answer_shape(6) ) &
17578 & )
17579
17580 allocate( judge_rev( &
17581 & answer_shape(1), &
17582
17583 & answer_shape(2), &
17584
17585 & answer_shape(3), &
17586
17587 & answer_shape(4), &
17588
17589 & answer_shape(5), &
17590
17591 & answer_shape(6) ) &
17592 & )
17593
17594 allocate( answer_negative( &
17595 & answer_shape(1), &
17596
17597 & answer_shape(2), &
17598
17599 & answer_shape(3), &
17600
17601 & answer_shape(4), &
17602
17603 & answer_shape(5), &
17604
17605 & answer_shape(6) ) &
17606 & )
17607
17608 allocate( check_negative( &
17609 & answer_shape(1), &
17610
17611 & answer_shape(2), &
17612
17613 & answer_shape(3), &
17614
17615 & answer_shape(4), &
17616
17617 & answer_shape(5), &
17618
17619 & answer_shape(6) ) &
17620 & )
17621
17622 allocate( both_negative( &
17623 & answer_shape(1), &
17624
17625 & answer_shape(2), &
17626
17627 & answer_shape(3), &
17628
17629 & answer_shape(4), &
17630
17631 & answer_shape(5), &
17632
17633 & answer_shape(6) ) &
17634 & )
17635
17636 answer_negative = answer < 0.0_dp
17637 check_negative = check < 0.0_dp
17638 both_negative = answer_negative .and. check_negative
17639 if (.not. negative_support_on) both_negative = .false.
17640
17641 judge = answer > check
17642 where (both_negative) judge = .not. judge
17643
17644 judge_rev = .not. judge
17645 err_flag = any(judge_rev)
17646 mask_array = 1
17647 pos = maxloc(mask_array, judge_rev)
17648
17649 if (err_flag) then
17650
17651 wrong = check( &
17652 & pos(1), &
17653
17654 & pos(2), &
17655
17656 & pos(3), &
17657
17658 & pos(4), &
17659
17660 & pos(5), &
17661
17662 & pos(6) )
17663
17664 right = answer( &
17665 & pos(1), &
17666
17667 & pos(2), &
17668
17669 & pos(3), &
17670
17671 & pos(4), &
17672
17673 & pos(5), &
17674
17675 & pos(6) )
17676
17677 write(unit=pos_array(1), fmt="(i20)") pos(1)
17678
17679 write(unit=pos_array(2), fmt="(i20)") pos(2)
17680
17681 write(unit=pos_array(3), fmt="(i20)") pos(3)
17682
17683 write(unit=pos_array(4), fmt="(i20)") pos(4)
17684
17685 write(unit=pos_array(5), fmt="(i20)") pos(5)
17686
17687 write(unit=pos_array(6), fmt="(i20)") pos(6)
17688
17689
17690 pos_str = '(' // &
17691 & trim(adjustl(pos_array(1))) // ',' // &
17692
17693 & trim(adjustl(pos_array(2))) // ',' // &
17694
17695 & trim(adjustl(pos_array(3))) // ',' // &
17696
17697 & trim(adjustl(pos_array(4))) // ',' // &
17698
17699 & trim(adjustl(pos_array(5))) // ',' // &
17700
17701 & trim(adjustl(pos_array(6))) // ')'
17702
17703 if ( both_negative( &
17704 & pos(1), &
17705
17706 & pos(2), &
17707
17708 & pos(3), &
17709
17710 & pos(4), &
17711
17712 & pos(5), &
17713
17714 & pos(6) ) ) then
17715
17716 abs_mes = 'ABSOLUTE value of'
17717 else
17718 abs_mes = ''
17719
17720 end if
17721
17722 end if
17723 deallocate(mask_array, judge, judge_rev)
17724 deallocate(answer_negative, check_negative, both_negative)
17725
17726
17727
17728
17729 if (err_flag) then
17730 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17731 write(*,*) ''
17732 write(*,*) ' ' // trim(abs_mes) // &
17733 & ' check' // trim(pos_str) // ' = ', wrong
17734 write(*,*) ' is NOT LESS THAN'
17735 write(*,*) ' ' // trim(abs_mes) // &
17736 & ' answer' // trim(pos_str) // ' = ', right
17737
17738 call abortprogram('')
17739 else
17740 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
17741 end if
17742
17743
17744 end subroutine dctestassertlessthandouble6
17745
17746
17747 subroutine dctestassertlessthandouble7( &
17748 & message, answer, check, negative_support)
17749 use sysdep, only: abortprogram
17750 use dc_types, only: string, token
17751 implicit none
17752 character(*), intent(in):: message
17753 real(DP), intent(in):: answer(:,:,:,:,:,:,:)
17754 real(DP), intent(in):: check(:,:,:,:,:,:,:)
17755 logical, intent(in), optional:: negative_support
17756 logical:: err_flag
17757 logical:: negative_support_on
17758 character(STRING):: pos_str
17759 character(TOKEN):: abs_mes
17760 real(DP):: wrong, right
17761
17762 integer:: answer_shape(7), check_shape(7), pos(7)
17763 logical:: consist_shape(7)
17764 character(TOKEN):: pos_array(7)
17765 integer, allocatable:: mask_array(:,:,:,:,:,:,:)
17766 logical, allocatable:: judge(:,:,:,:,:,:,:)
17767 logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
17768 logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
17769 logical, allocatable:: check_negative(:,:,:,:,:,:,:)
17770 logical, allocatable:: both_negative(:,:,:,:,:,:,:)
17771
17772
17773 continue
17774 if (present(negative_support)) then
17775 negative_support_on = negative_support
17776 else
17777 negative_support_on = .true.
17778 end if
17779
17780 err_flag = .false.
17781
17782
17783 answer_shape = shape(answer)
17784 check_shape = shape(check)
17785
17786 consist_shape = answer_shape == check_shape
17787
17788 if (.not. all(consist_shape)) then
17789 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17790 write(*,*) ''
17791 write(*,*) ' shape of check is (', check_shape, ')'
17792 write(*,*) ' is INCORRECT'
17793 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
17794
17795 call abortprogram('')
17796 end if
17797
17798
17799 allocate( mask_array( &
17800 & answer_shape(1), &
17801
17802 & answer_shape(2), &
17803
17804 & answer_shape(3), &
17805
17806 & answer_shape(4), &
17807
17808 & answer_shape(5), &
17809
17810 & answer_shape(6), &
17811
17812 & answer_shape(7) ) &
17813 & )
17814
17815 allocate( judge( &
17816 & answer_shape(1), &
17817
17818 & answer_shape(2), &
17819
17820 & answer_shape(3), &
17821
17822 & answer_shape(4), &
17823
17824 & answer_shape(5), &
17825
17826 & answer_shape(6), &
17827
17828 & answer_shape(7) ) &
17829 & )
17830
17831 allocate( judge_rev( &
17832 & answer_shape(1), &
17833
17834 & answer_shape(2), &
17835
17836 & answer_shape(3), &
17837
17838 & answer_shape(4), &
17839
17840 & answer_shape(5), &
17841
17842 & answer_shape(6), &
17843
17844 & answer_shape(7) ) &
17845 & )
17846
17847 allocate( answer_negative( &
17848 & answer_shape(1), &
17849
17850 & answer_shape(2), &
17851
17852 & answer_shape(3), &
17853
17854 & answer_shape(4), &
17855
17856 & answer_shape(5), &
17857
17858 & answer_shape(6), &
17859
17860 & answer_shape(7) ) &
17861 & )
17862
17863 allocate( check_negative( &
17864 & answer_shape(1), &
17865
17866 & answer_shape(2), &
17867
17868 & answer_shape(3), &
17869
17870 & answer_shape(4), &
17871
17872 & answer_shape(5), &
17873
17874 & answer_shape(6), &
17875
17876 & answer_shape(7) ) &
17877 & )
17878
17879 allocate( both_negative( &
17880 & answer_shape(1), &
17881
17882 & answer_shape(2), &
17883
17884 & answer_shape(3), &
17885
17886 & answer_shape(4), &
17887
17888 & answer_shape(5), &
17889
17890 & answer_shape(6), &
17891
17892 & answer_shape(7) ) &
17893 & )
17894
17895 answer_negative = answer < 0.0_dp
17896 check_negative = check < 0.0_dp
17897 both_negative = answer_negative .and. check_negative
17898 if (.not. negative_support_on) both_negative = .false.
17899
17900 judge = answer > check
17901 where (both_negative) judge = .not. judge
17902
17903 judge_rev = .not. judge
17904 err_flag = any(judge_rev)
17905 mask_array = 1
17906 pos = maxloc(mask_array, judge_rev)
17907
17908 if (err_flag) then
17909
17910 wrong = check( &
17911 & pos(1), &
17912
17913 & pos(2), &
17914
17915 & pos(3), &
17916
17917 & pos(4), &
17918
17919 & pos(5), &
17920
17921 & pos(6), &
17922
17923 & pos(7) )
17924
17925 right = answer( &
17926 & pos(1), &
17927
17928 & pos(2), &
17929
17930 & pos(3), &
17931
17932 & pos(4), &
17933
17934 & pos(5), &
17935
17936 & pos(6), &
17937
17938 & pos(7) )
17939
17940 write(unit=pos_array(1), fmt="(i20)") pos(1)
17941
17942 write(unit=pos_array(2), fmt="(i20)") pos(2)
17943
17944 write(unit=pos_array(3), fmt="(i20)") pos(3)
17945
17946 write(unit=pos_array(4), fmt="(i20)") pos(4)
17947
17948 write(unit=pos_array(5), fmt="(i20)") pos(5)
17949
17950 write(unit=pos_array(6), fmt="(i20)") pos(6)
17951
17952 write(unit=pos_array(7), fmt="(i20)") pos(7)
17953
17954
17955 pos_str = '(' // &
17956 & trim(adjustl(pos_array(1))) // ',' // &
17957
17958 & trim(adjustl(pos_array(2))) // ',' // &
17959
17960 & trim(adjustl(pos_array(3))) // ',' // &
17961
17962 & trim(adjustl(pos_array(4))) // ',' // &
17963
17964 & trim(adjustl(pos_array(5))) // ',' // &
17965
17966 & trim(adjustl(pos_array(6))) // ',' // &
17967
17968 & trim(adjustl(pos_array(7))) // ')'
17969
17970 if ( both_negative( &
17971 & pos(1), &
17972
17973 & pos(2), &
17974
17975 & pos(3), &
17976
17977 & pos(4), &
17978
17979 & pos(5), &
17980
17981 & pos(6), &
17982
17983 & pos(7) ) ) then
17984
17985 abs_mes = 'ABSOLUTE value of'
17986 else
17987 abs_mes = ''
17988
17989 end if
17990
17991 end if
17992 deallocate(mask_array, judge, judge_rev)
17993 deallocate(answer_negative, check_negative, both_negative)
17994
17995
17996
17997
17998 if (err_flag) then
17999 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
18000 write(*,*) ''
18001 write(*,*) ' ' // trim(abs_mes) // &
18002 & ' check' // trim(pos_str) // ' = ', wrong
18003 write(*,*) ' is NOT LESS THAN'
18004 write(*,*) ' ' // trim(abs_mes) // &
18005 & ' answer' // trim(pos_str) // ' = ', right
18006
18007 call abortprogram('')
18008 else
18009 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
18010 end if
18011
18012
18013 end subroutine dctestassertlessthandouble7
18014
18015end module dc_test
18016
18017!--
18018! vi:set readonly sw=4 ts=8:
18019!
18020!Local Variables:
18021!mode: f90
18022!buffer-read-only: t
18023!End:
18024!
18025!++
dc_test::assertequal
Definition dc_test.f90:160
dc_test::assertgreaterthan
Definition dc_test.f90:284
dc_test::assertlessthan
Definition dc_test.f90:338
dc_test
Support making test programs .
Definition dc_test.f90:31
dc_types
Provides kind type parameter values.
Definition dc_types.f90:55
dc_types::token
integer, parameter, public token
Character length for word, token
Definition dc_types.f90:128
dc_types::dp
integer, parameter, public dp
Double Precision Real number
Definition dc_types.f90:92
dc_types::string
integer, parameter, public string
Character length for string
Definition dc_types.f90:137
sysdep
Provides interface for system dependent procedures.
Definition sysdep.f90:54
sysdep::abortprogram
subroutine, public abortprogram(message)
Abort program execution.
Definition sysdep.f90:90
Generated on Fri May 29 2026 05:34:32 for gtool5 Fortran 90/95 Library by doxygen 1.9.8