gtool5 Fortran 90/95 Library 1.0.0-rc5
日本語
Loading...
Searching...
No Matches
Public Member Functions | List of all members
dc_test::assertequal Interface Reference

Public Member Functions

subroutine dctestassertequalchar0 (message, answer, check)
subroutine dctestassertequalchar1 (message, answer, check)
subroutine dctestassertequalchar2 (message, answer, check)
subroutine dctestassertequalchar3 (message, answer, check)
subroutine dctestassertequalchar4 (message, answer, check)
subroutine dctestassertequalchar5 (message, answer, check)
subroutine dctestassertequalchar6 (message, answer, check)
subroutine dctestassertequalchar7 (message, answer, check)
subroutine dctestassertequalint0 (message, answer, check)
subroutine dctestassertequalint1 (message, answer, check)
subroutine dctestassertequalint2 (message, answer, check)
subroutine dctestassertequalint3 (message, answer, check)
subroutine dctestassertequalint4 (message, answer, check)
subroutine dctestassertequalint5 (message, answer, check)
subroutine dctestassertequalint6 (message, answer, check)
subroutine dctestassertequalint7 (message, answer, check)
subroutine dctestassertequalreal0 (message, answer, check)
subroutine dctestassertequalreal1 (message, answer, check)
subroutine dctestassertequalreal2 (message, answer, check)
subroutine dctestassertequalreal3 (message, answer, check)
subroutine dctestassertequalreal4 (message, answer, check)
subroutine dctestassertequalreal5 (message, answer, check)
subroutine dctestassertequalreal6 (message, answer, check)
subroutine dctestassertequalreal7 (message, answer, check)
subroutine dctestassertequaldouble0 (message, answer, check)
subroutine dctestassertequaldouble1 (message, answer, check)
subroutine dctestassertequaldouble2 (message, answer, check)
subroutine dctestassertequaldouble3 (message, answer, check)
subroutine dctestassertequaldouble4 (message, answer, check)
subroutine dctestassertequaldouble5 (message, answer, check)
subroutine dctestassertequaldouble6 (message, answer, check)
subroutine dctestassertequaldouble7 (message, answer, check)
subroutine dctestassertequallogical0 (message, answer, check)
subroutine dctestassertequallogical1 (message, answer, check)
subroutine dctestassertequallogical2 (message, answer, check)
subroutine dctestassertequallogical3 (message, answer, check)
subroutine dctestassertequallogical4 (message, answer, check)
subroutine dctestassertequallogical5 (message, answer, check)
subroutine dctestassertequallogical6 (message, answer, check)
subroutine dctestassertequallogical7 (message, answer, check)
subroutine dctestassertequalreal0digits (message, answer, check, significant_digits, ignore_digits)
subroutine dctestassertequalreal1digits (message, answer, check, significant_digits, ignore_digits)
subroutine dctestassertequalreal2digits (message, answer, check, significant_digits, ignore_digits)
subroutine dctestassertequalreal3digits (message, answer, check, significant_digits, ignore_digits)
subroutine dctestassertequalreal4digits (message, answer, check, significant_digits, ignore_digits)
subroutine dctestassertequalreal5digits (message, answer, check, significant_digits, ignore_digits)
subroutine dctestassertequalreal6digits (message, answer, check, significant_digits, ignore_digits)
subroutine dctestassertequalreal7digits (message, answer, check, significant_digits, ignore_digits)
subroutine dctestassertequaldouble0digits (message, answer, check, significant_digits, ignore_digits)
subroutine dctestassertequaldouble1digits (message, answer, check, significant_digits, ignore_digits)
subroutine dctestassertequaldouble2digits (message, answer, check, significant_digits, ignore_digits)
subroutine dctestassertequaldouble3digits (message, answer, check, significant_digits, ignore_digits)
subroutine dctestassertequaldouble4digits (message, answer, check, significant_digits, ignore_digits)
subroutine dctestassertequaldouble5digits (message, answer, check, significant_digits, ignore_digits)
subroutine dctestassertequaldouble6digits (message, answer, check, significant_digits, ignore_digits)
subroutine dctestassertequaldouble7digits (message, answer, check, significant_digits, ignore_digits)

Detailed Description

Definition at line 160 of file dc_test.f90.

Member Function/Subroutine Documentation

◆ dctestassertequalchar0()

subroutine dc_test::assertequal::dctestassertequalchar0 ( character(*), intent(in) message,
character(*), intent(in) answer,
character(*), intent(in) check )

Definition at line 395 of file dc_test.f90.

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
dc_types
Provides kind type parameter values.
Definition dc_types.f90:55
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

References sysdep::abortprogram(), and dc_types::string.

Here is the call graph for this function:

◆ dctestassertequalchar1()

subroutine dc_test::assertequal::dctestassertequalchar1 ( character(*), intent(in) message,
character(*), dimension(:), intent(in) answer,
character(*), dimension(:), intent(in) check )

Definition at line 440 of file dc_test.f90.

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
dc_types::token
integer, parameter, public token
Character length for word, token
Definition dc_types.f90:128

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalchar2()

subroutine dc_test::assertequal::dctestassertequalchar2 ( character(*), intent(in) message,
character(*), dimension(:,:), intent(in) answer,
character(*), dimension(:,:), intent(in) check )

Definition at line 562 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalchar3()

subroutine dc_test::assertequal::dctestassertequalchar3 ( character(*), intent(in) message,
character(*), dimension(:,:,:), intent(in) answer,
character(*), dimension(:,:,:), intent(in) check )

Definition at line 694 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalchar4()

subroutine dc_test::assertequal::dctestassertequalchar4 ( character(*), intent(in) message,
character(*), dimension(:,:,:,:), intent(in) answer,
character(*), dimension(:,:,:,:), intent(in) check )

Definition at line 844 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalchar5()

subroutine dc_test::assertequal::dctestassertequalchar5 ( character(*), intent(in) message,
character(*), dimension(:,:,:,:,:), intent(in) answer,
character(*), dimension(:,:,:,:,:), intent(in) check )

Definition at line 1012 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalchar6()

subroutine dc_test::assertequal::dctestassertequalchar6 ( character(*), intent(in) message,
character(*), dimension(:,:,:,:,:,:), intent(in) answer,
character(*), dimension(:,:,:,:,:,:), intent(in) check )

Definition at line 1198 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalchar7()

subroutine dc_test::assertequal::dctestassertequalchar7 ( character(*), intent(in) message,
character(*), dimension(:,:,:,:,:,:,:), intent(in) answer,
character(*), dimension(:,:,:,:,:,:,:), intent(in) check )

Definition at line 1402 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequaldouble0()

subroutine dc_test::assertequal::dctestassertequaldouble0 ( character(*), intent(in) message,
real(dp), intent(in) answer,
real(dp), intent(in) check )

Definition at line 3712 of file dc_test.f90.

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

References sysdep::abortprogram(), and dc_types::string.

Here is the call graph for this function:

◆ dctestassertequaldouble0digits()

subroutine dc_test::assertequal::dctestassertequaldouble0digits ( character(*), intent(in) message,
real(dp), intent(in) answer,
real(dp), intent(in) check,
integer, intent(in) significant_digits,
integer, intent(in) ignore_digits )

Definition at line 7185 of file dc_test.f90.

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

References sysdep::abortprogram(), and dc_types::string.

Here is the call graph for this function:

◆ dctestassertequaldouble1()

subroutine dc_test::assertequal::dctestassertequaldouble1 ( character(*), intent(in) message,
real(dp), dimension(:), intent(in) answer,
real(dp), dimension(:), intent(in) check )

Definition at line 3756 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequaldouble1digits()

subroutine dc_test::assertequal::dctestassertequaldouble1digits ( character(*), intent(in) message,
real(dp), dimension(:), intent(in) answer,
real(dp), dimension(:), intent(in) check,
integer, intent(in) significant_digits,
integer, intent(in) ignore_digits )

Definition at line 7277 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequaldouble2()

subroutine dc_test::assertequal::dctestassertequaldouble2 ( character(*), intent(in) message,
real(dp), dimension(:,:), intent(in) answer,
real(dp), dimension(:,:), intent(in) check )

Definition at line 3862 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequaldouble2digits()

subroutine dc_test::assertequal::dctestassertequaldouble2digits ( character(*), intent(in) message,
real(dp), dimension(:,:), intent(in) answer,
real(dp), dimension(:,:), intent(in) check,
integer, intent(in) significant_digits,
integer, intent(in) ignore_digits )

Definition at line 7462 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequaldouble3()

subroutine dc_test::assertequal::dctestassertequaldouble3 ( character(*), intent(in) message,
real(dp), dimension(:,:,:), intent(in) answer,
real(dp), dimension(:,:,:), intent(in) check )

Definition at line 3976 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequaldouble3digits()

subroutine dc_test::assertequal::dctestassertequaldouble3digits ( character(*), intent(in) message,
real(dp), dimension(:,:,:), intent(in) answer,
real(dp), dimension(:,:,:), intent(in) check,
integer, intent(in) significant_digits,
integer, intent(in) ignore_digits )

Definition at line 7661 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequaldouble4()

subroutine dc_test::assertequal::dctestassertequaldouble4 ( character(*), intent(in) message,
real(dp), dimension(:,:,:,:), intent(in) answer,
real(dp), dimension(:,:,:,:), intent(in) check )

Definition at line 4104 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequaldouble4digits()

subroutine dc_test::assertequal::dctestassertequaldouble4digits ( character(*), intent(in) message,
real(dp), dimension(:,:,:,:), intent(in) answer,
real(dp), dimension(:,:,:,:), intent(in) check,
integer, intent(in) significant_digits,
integer, intent(in) ignore_digits )

Definition at line 7886 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequaldouble5()

subroutine dc_test::assertequal::dctestassertequaldouble5 ( character(*), intent(in) message,
real(dp), dimension(:,:,:,:,:), intent(in) answer,
real(dp), dimension(:,:,:,:,:), intent(in) check )

Definition at line 4246 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequaldouble5digits()

subroutine dc_test::assertequal::dctestassertequaldouble5digits ( character(*), intent(in) message,
real(dp), dimension(:,:,:,:,:), intent(in) answer,
real(dp), dimension(:,:,:,:,:), intent(in) check,
integer, intent(in) significant_digits,
integer, intent(in) ignore_digits )

Definition at line 8137 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequaldouble6()

subroutine dc_test::assertequal::dctestassertequaldouble6 ( character(*), intent(in) message,
real(dp), dimension(:,:,:,:,:,:), intent(in) answer,
real(dp), dimension(:,:,:,:,:,:), intent(in) check )

Definition at line 4402 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequaldouble6digits()

subroutine dc_test::assertequal::dctestassertequaldouble6digits ( character(*), intent(in) message,
real(dp), dimension(:,:,:,:,:,:), intent(in) answer,
real(dp), dimension(:,:,:,:,:,:), intent(in) check,
integer, intent(in) significant_digits,
integer, intent(in) ignore_digits )

Definition at line 8414 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequaldouble7()

subroutine dc_test::assertequal::dctestassertequaldouble7 ( character(*), intent(in) message,
real(dp), dimension(:,:,:,:,:,:,:), intent(in) answer,
real(dp), dimension(:,:,:,:,:,:,:), intent(in) check )

Definition at line 4572 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequaldouble7digits()

subroutine dc_test::assertequal::dctestassertequaldouble7digits ( character(*), intent(in) message,
real(dp), dimension(:,:,:,:,:,:,:), intent(in) answer,
real(dp), dimension(:,:,:,:,:,:,:), intent(in) check,
integer, intent(in) significant_digits,
integer, intent(in) ignore_digits )

Definition at line 8717 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalint0()

subroutine dc_test::assertequal::dctestassertequalint0 ( character(*), intent(in) message,
integer, intent(in) answer,
integer, intent(in) check )

Definition at line 1624 of file dc_test.f90.

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

References sysdep::abortprogram(), and dc_types::string.

Here is the call graph for this function:

◆ dctestassertequalint1()

subroutine dc_test::assertequal::dctestassertequalint1 ( character(*), intent(in) message,
integer, dimension(:), intent(in) answer,
integer, dimension(:), intent(in) check )

Definition at line 1668 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalint2()

subroutine dc_test::assertequal::dctestassertequalint2 ( character(*), intent(in) message,
integer, dimension(:,:), intent(in) answer,
integer, dimension(:,:), intent(in) check )

Definition at line 1774 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalint3()

subroutine dc_test::assertequal::dctestassertequalint3 ( character(*), intent(in) message,
integer, dimension(:,:,:), intent(in) answer,
integer, dimension(:,:,:), intent(in) check )

Definition at line 1888 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalint4()

subroutine dc_test::assertequal::dctestassertequalint4 ( character(*), intent(in) message,
integer, dimension(:,:,:,:), intent(in) answer,
integer, dimension(:,:,:,:), intent(in) check )

Definition at line 2016 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalint5()

subroutine dc_test::assertequal::dctestassertequalint5 ( character(*), intent(in) message,
integer, dimension(:,:,:,:,:), intent(in) answer,
integer, dimension(:,:,:,:,:), intent(in) check )

Definition at line 2158 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalint6()

subroutine dc_test::assertequal::dctestassertequalint6 ( character(*), intent(in) message,
integer, dimension(:,:,:,:,:,:), intent(in) answer,
integer, dimension(:,:,:,:,:,:), intent(in) check )

Definition at line 2314 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalint7()

subroutine dc_test::assertequal::dctestassertequalint7 ( character(*), intent(in) message,
integer, dimension(:,:,:,:,:,:,:), intent(in) answer,
integer, dimension(:,:,:,:,:,:,:), intent(in) check )

Definition at line 2484 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequallogical0()

subroutine dc_test::assertequal::dctestassertequallogical0 ( character(*), intent(in) message,
logical, intent(in) answer,
logical, intent(in) check )

Definition at line 4755 of file dc_test.f90.

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

References dc_types::string.

◆ dctestassertequallogical1()

subroutine dc_test::assertequal::dctestassertequallogical1 ( character(*), intent(in) message,
logical, dimension(:), intent(in) answer,
logical, dimension(:), intent(in) check )

Definition at line 4789 of file dc_test.f90.

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

References dc_types::string.

◆ dctestassertequallogical2()

subroutine dc_test::assertequal::dctestassertequallogical2 ( character(*), intent(in) message,
logical, dimension(:,:), intent(in) answer,
logical, dimension(:,:), intent(in) check )

Definition at line 4855 of file dc_test.f90.

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

References dc_types::string.

◆ dctestassertequallogical3()

subroutine dc_test::assertequal::dctestassertequallogical3 ( character(*), intent(in) message,
logical, dimension(:,:,:), intent(in) answer,
logical, dimension(:,:,:), intent(in) check )

Definition at line 4923 of file dc_test.f90.

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

References dc_types::string.

◆ dctestassertequallogical4()

subroutine dc_test::assertequal::dctestassertequallogical4 ( character(*), intent(in) message,
logical, dimension(:,:,:,:), intent(in) answer,
logical, dimension(:,:,:,:), intent(in) check )

Definition at line 4995 of file dc_test.f90.

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

References dc_types::string.

◆ dctestassertequallogical5()

subroutine dc_test::assertequal::dctestassertequallogical5 ( character(*), intent(in) message,
logical, dimension(:,:,:,:,:), intent(in) answer,
logical, dimension(:,:,:,:,:), intent(in) check )

Definition at line 5071 of file dc_test.f90.

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

References dc_types::string.

◆ dctestassertequallogical6()

subroutine dc_test::assertequal::dctestassertequallogical6 ( character(*), intent(in) message,
logical, dimension(:,:,:,:,:,:), intent(in) answer,
logical, dimension(:,:,:,:,:,:), intent(in) check )

Definition at line 5151 of file dc_test.f90.

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

References dc_types::string.

◆ dctestassertequallogical7()

subroutine dc_test::assertequal::dctestassertequallogical7 ( character(*), intent(in) message,
logical, dimension(:,:,:,:,:,:,:), intent(in) answer,
logical, dimension(:,:,:,:,:,:,:), intent(in) check )

Definition at line 5235 of file dc_test.f90.

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

References dc_types::string.

◆ dctestassertequalreal0()

subroutine dc_test::assertequal::dctestassertequalreal0 ( character(*), intent(in) message,
real, intent(in) answer,
real, intent(in) check )

Definition at line 2668 of file dc_test.f90.

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

References sysdep::abortprogram(), and dc_types::string.

Here is the call graph for this function:

◆ dctestassertequalreal0digits()

subroutine dc_test::assertequal::dctestassertequalreal0digits ( character(*), intent(in) message,
real, intent(in) answer,
real, intent(in) check,
integer, intent(in) significant_digits,
integer, intent(in) ignore_digits )

Definition at line 5324 of file dc_test.f90.

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

References sysdep::abortprogram(), and dc_types::string.

Here is the call graph for this function:

◆ dctestassertequalreal1()

subroutine dc_test::assertequal::dctestassertequalreal1 ( character(*), intent(in) message,
real, dimension(:), intent(in) answer,
real, dimension(:), intent(in) check )

Definition at line 2712 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalreal1digits()

subroutine dc_test::assertequal::dctestassertequalreal1digits ( character(*), intent(in) message,
real, dimension(:), intent(in) answer,
real, dimension(:), intent(in) check,
integer, intent(in) significant_digits,
integer, intent(in) ignore_digits )

Definition at line 5416 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalreal2()

subroutine dc_test::assertequal::dctestassertequalreal2 ( character(*), intent(in) message,
real, dimension(:,:), intent(in) answer,
real, dimension(:,:), intent(in) check )

Definition at line 2818 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalreal2digits()

subroutine dc_test::assertequal::dctestassertequalreal2digits ( character(*), intent(in) message,
real, dimension(:,:), intent(in) answer,
real, dimension(:,:), intent(in) check,
integer, intent(in) significant_digits,
integer, intent(in) ignore_digits )

Definition at line 5601 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalreal3()

subroutine dc_test::assertequal::dctestassertequalreal3 ( character(*), intent(in) message,
real, dimension(:,:,:), intent(in) answer,
real, dimension(:,:,:), intent(in) check )

Definition at line 2932 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalreal3digits()

subroutine dc_test::assertequal::dctestassertequalreal3digits ( character(*), intent(in) message,
real, dimension(:,:,:), intent(in) answer,
real, dimension(:,:,:), intent(in) check,
integer, intent(in) significant_digits,
integer, intent(in) ignore_digits )

Definition at line 5800 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalreal4()

subroutine dc_test::assertequal::dctestassertequalreal4 ( character(*), intent(in) message,
real, dimension(:,:,:,:), intent(in) answer,
real, dimension(:,:,:,:), intent(in) check )

Definition at line 3060 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalreal4digits()

subroutine dc_test::assertequal::dctestassertequalreal4digits ( character(*), intent(in) message,
real, dimension(:,:,:,:), intent(in) answer,
real, dimension(:,:,:,:), intent(in) check,
integer, intent(in) significant_digits,
integer, intent(in) ignore_digits )

Definition at line 6025 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalreal5()

subroutine dc_test::assertequal::dctestassertequalreal5 ( character(*), intent(in) message,
real, dimension(:,:,:,:,:), intent(in) answer,
real, dimension(:,:,:,:,:), intent(in) check )

Definition at line 3202 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalreal5digits()

subroutine dc_test::assertequal::dctestassertequalreal5digits ( character(*), intent(in) message,
real, dimension(:,:,:,:,:), intent(in) answer,
real, dimension(:,:,:,:,:), intent(in) check,
integer, intent(in) significant_digits,
integer, intent(in) ignore_digits )

Definition at line 6276 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalreal6()

subroutine dc_test::assertequal::dctestassertequalreal6 ( character(*), intent(in) message,
real, dimension(:,:,:,:,:,:), intent(in) answer,
real, dimension(:,:,:,:,:,:), intent(in) check )

Definition at line 3358 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalreal6digits()

subroutine dc_test::assertequal::dctestassertequalreal6digits ( character(*), intent(in) message,
real, dimension(:,:,:,:,:,:), intent(in) answer,
real, dimension(:,:,:,:,:,:), intent(in) check,
integer, intent(in) significant_digits,
integer, intent(in) ignore_digits )

Definition at line 6553 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalreal7()

subroutine dc_test::assertequal::dctestassertequalreal7 ( character(*), intent(in) message,
real, dimension(:,:,:,:,:,:,:), intent(in) answer,
real, dimension(:,:,:,:,:,:,:), intent(in) check )

Definition at line 3528 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:

◆ dctestassertequalreal7digits()

subroutine dc_test::assertequal::dctestassertequalreal7digits ( character(*), intent(in) message,
real, dimension(:,:,:,:,:,:,:), intent(in) answer,
real, dimension(:,:,:,:,:,:,:), intent(in) check,
integer, intent(in) significant_digits,
integer, intent(in) ignore_digits )

Definition at line 6856 of file dc_test.f90.

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

References sysdep::abortprogram(), dc_types::string, and dc_types::token.

Here is the call graph for this function:
The documentation for this interface was generated from the following file:
Generated on for gtool5 Fortran 90/95 Library by doxygen 1.15.0