Private Member Functions
dc_test::assertequal Interface Reference

Private 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 295 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 
)
private

Definition at line 531 of file dc_test.f90.

531  use sysdep, only: abortprogram
532  use dc_types, only: string, token
533  implicit none
534  character(*), intent(in):: message
535  character(*), intent(in):: answer
536  character(*), intent(in):: check
537  logical:: err_flag
538  character(STRING):: pos_str
539  character(STRING):: wrong, right
540 
541 
542 
543 
544 
545 
546  continue
547  err_flag = .false.
548 
549 
550  err_flag = .not. trim(answer) == trim(check)
551  wrong = check
552  right = answer
553  pos_str = ''
554 
555 
556 
557 
558  if (err_flag) then
559  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
560  write(*,*) ''
561  write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
562  write(*,*) ' is NOT EQUAL to'
563  write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
564 
565  call abortprogram('')
566  else
567  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
568  end if
569 
570 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequalchar1()

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

Definition at line 575 of file dc_test.f90.

575  use sysdep, only: abortprogram
576  use dc_types, only: string, token
577  implicit none
578  character(*), intent(in):: message
579  character(*), intent(in):: answer(:)
580  character(*), intent(in):: check(:)
581  logical:: err_flag
582  character(STRING):: pos_str
583  character(STRING):: wrong, right
584 
585  integer:: answer_shape(1), check_shape(1), pos(1)
586  logical:: consist_shape(1)
587  character(TOKEN):: pos_array(1)
588  integer, allocatable:: mask_array(:)
589  logical, allocatable:: judge(:)
590  logical, allocatable:: judge_rev(:)
591 
592 
593  character(STRING), allocatable:: answer_fixed_length(:)
594  character(STRING), allocatable:: check_fixed_length(:)
595 
596 
597 
598  continue
599  err_flag = .false.
600 
601 
602  answer_shape = shape(answer)
603  check_shape = shape(check)
604 
605  consist_shape = answer_shape == check_shape
606 
607  if (.not. all(consist_shape)) then
608  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
609  write(*,*) ''
610  write(*,*) ' shape of check is (', check_shape, ')'
611  write(*,*) ' is INCORRECT'
612  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
613 
614  call abortprogram('')
615  end if
616 
617 
618  allocate( mask_array( &
619 
620  & answer_shape(1) ) &
621  & )
622 
623  allocate( judge( &
624 
625  & answer_shape(1) ) &
626  & )
627 
628  allocate( judge_rev( &
629 
630  & answer_shape(1) ) &
631  & )
632 
633 
634  allocate( answer_fixed_length( &
635 
636  & answer_shape(1) ) &
637  & )
638 
639  allocate( check_fixed_length( &
640 
641  & check_shape(1) ) &
642  & )
643 
644  answer_fixed_length = answer
645  check_fixed_length = check
646 
647  judge = answer_fixed_length == check_fixed_length
648  deallocate(answer_fixed_length, check_fixed_length)
649 
650 
651 
652  judge_rev = .not. judge
653  err_flag = any(judge_rev)
654  mask_array = 1
655  pos = maxloc(mask_array, judge_rev)
656 
657  if (err_flag) then
658 
659  wrong = check( &
660 
661  & pos(1) )
662 
663  right = answer( &
664 
665  & pos(1) )
666 
667  write(unit=pos_array(1), fmt="(i20)") pos(1)
668 
669 
670  pos_str = '(' // &
671 
672  & trim(adjustl(pos_array(1))) // ')'
673 
674  end if
675  deallocate(mask_array, judge, judge_rev)
676 
677 
678 
679 
680  if (err_flag) then
681  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
682  write(*,*) ''
683  write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
684  write(*,*) ' is NOT EQUAL to'
685  write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
686 
687  call abortprogram('')
688  else
689  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
690  end if
691 
692 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequalchar2()

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

Definition at line 697 of file dc_test.f90.

697  use sysdep, only: abortprogram
698  use dc_types, only: string, token
699  implicit none
700  character(*), intent(in):: message
701  character(*), intent(in):: answer(:,:)
702  character(*), intent(in):: check(:,:)
703  logical:: err_flag
704  character(STRING):: pos_str
705  character(STRING):: wrong, right
706 
707  integer:: answer_shape(2), check_shape(2), pos(2)
708  logical:: consist_shape(2)
709  character(TOKEN):: pos_array(2)
710  integer, allocatable:: mask_array(:,:)
711  logical, allocatable:: judge(:,:)
712  logical, allocatable:: judge_rev(:,:)
713 
714 
715  character(STRING), allocatable:: answer_fixed_length(:,:)
716  character(STRING), allocatable:: check_fixed_length(:,:)
717 
718 
719 
720  continue
721  err_flag = .false.
722 
723 
724  answer_shape = shape(answer)
725  check_shape = shape(check)
726 
727  consist_shape = answer_shape == check_shape
728 
729  if (.not. all(consist_shape)) then
730  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
731  write(*,*) ''
732  write(*,*) ' shape of check is (', check_shape, ')'
733  write(*,*) ' is INCORRECT'
734  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
735 
736  call abortprogram('')
737  end if
738 
739 
740  allocate( mask_array( &
741  & answer_shape(1), &
742 
743  & answer_shape(2) ) &
744  & )
745 
746  allocate( judge( &
747  & answer_shape(1), &
748 
749  & answer_shape(2) ) &
750  & )
751 
752  allocate( judge_rev( &
753  & answer_shape(1), &
754 
755  & answer_shape(2) ) &
756  & )
757 
758 
759  allocate( answer_fixed_length( &
760  & answer_shape(1), &
761 
762  & answer_shape(2) ) &
763  & )
764 
765  allocate( check_fixed_length( &
766  & check_shape(1), &
767 
768  & check_shape(2) ) &
769  & )
770 
771  answer_fixed_length = answer
772  check_fixed_length = check
773 
774  judge = answer_fixed_length == check_fixed_length
775  deallocate(answer_fixed_length, check_fixed_length)
776 
777 
778 
779  judge_rev = .not. judge
780  err_flag = any(judge_rev)
781  mask_array = 1
782  pos = maxloc(mask_array, judge_rev)
783 
784  if (err_flag) then
785 
786  wrong = check( &
787  & pos(1), &
788 
789  & pos(2) )
790 
791  right = answer( &
792  & pos(1), &
793 
794  & pos(2) )
795 
796  write(unit=pos_array(1), fmt="(i20)") pos(1)
797 
798  write(unit=pos_array(2), fmt="(i20)") pos(2)
799 
800 
801  pos_str = '(' // &
802  & trim(adjustl(pos_array(1))) // ',' // &
803 
804  & trim(adjustl(pos_array(2))) // ')'
805 
806  end if
807  deallocate(mask_array, judge, judge_rev)
808 
809 
810 
811 
812  if (err_flag) then
813  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
814  write(*,*) ''
815  write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
816  write(*,*) ' is NOT EQUAL to'
817  write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
818 
819  call abortprogram('')
820  else
821  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
822  end if
823 
824 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequalchar3()

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

Definition at line 829 of file dc_test.f90.

829  use sysdep, only: abortprogram
830  use dc_types, only: string, token
831  implicit none
832  character(*), intent(in):: message
833  character(*), intent(in):: answer(:,:,:)
834  character(*), intent(in):: check(:,:,:)
835  logical:: err_flag
836  character(STRING):: pos_str
837  character(STRING):: wrong, right
838 
839  integer:: answer_shape(3), check_shape(3), pos(3)
840  logical:: consist_shape(3)
841  character(TOKEN):: pos_array(3)
842  integer, allocatable:: mask_array(:,:,:)
843  logical, allocatable:: judge(:,:,:)
844  logical, allocatable:: judge_rev(:,:,:)
845 
846 
847  character(STRING), allocatable:: answer_fixed_length(:,:,:)
848  character(STRING), allocatable:: check_fixed_length(:,:,:)
849 
850 
851 
852  continue
853  err_flag = .false.
854 
855 
856  answer_shape = shape(answer)
857  check_shape = shape(check)
858 
859  consist_shape = answer_shape == check_shape
860 
861  if (.not. all(consist_shape)) then
862  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
863  write(*,*) ''
864  write(*,*) ' shape of check is (', check_shape, ')'
865  write(*,*) ' is INCORRECT'
866  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
867 
868  call abortprogram('')
869  end if
870 
871 
872  allocate( mask_array( &
873  & answer_shape(1), &
874 
875  & answer_shape(2), &
876 
877  & answer_shape(3) ) &
878  & )
879 
880  allocate( judge( &
881  & answer_shape(1), &
882 
883  & answer_shape(2), &
884 
885  & answer_shape(3) ) &
886  & )
887 
888  allocate( judge_rev( &
889  & answer_shape(1), &
890 
891  & answer_shape(2), &
892 
893  & answer_shape(3) ) &
894  & )
895 
896 
897  allocate( answer_fixed_length( &
898  & answer_shape(1), &
899 
900  & answer_shape(2), &
901 
902  & answer_shape(3) ) &
903  & )
904 
905  allocate( check_fixed_length( &
906  & check_shape(1), &
907 
908  & check_shape(2), &
909 
910  & check_shape(3) ) &
911  & )
912 
913  answer_fixed_length = answer
914  check_fixed_length = check
915 
916  judge = answer_fixed_length == check_fixed_length
917  deallocate(answer_fixed_length, check_fixed_length)
918 
919 
920 
921  judge_rev = .not. judge
922  err_flag = any(judge_rev)
923  mask_array = 1
924  pos = maxloc(mask_array, judge_rev)
925 
926  if (err_flag) then
927 
928  wrong = check( &
929  & pos(1), &
930 
931  & pos(2), &
932 
933  & pos(3) )
934 
935  right = answer( &
936  & pos(1), &
937 
938  & pos(2), &
939 
940  & pos(3) )
941 
942  write(unit=pos_array(1), fmt="(i20)") pos(1)
943 
944  write(unit=pos_array(2), fmt="(i20)") pos(2)
945 
946  write(unit=pos_array(3), fmt="(i20)") pos(3)
947 
948 
949  pos_str = '(' // &
950  & trim(adjustl(pos_array(1))) // ',' // &
951 
952  & trim(adjustl(pos_array(2))) // ',' // &
953 
954  & trim(adjustl(pos_array(3))) // ')'
955 
956  end if
957  deallocate(mask_array, judge, judge_rev)
958 
959 
960 
961 
962  if (err_flag) then
963  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
964  write(*,*) ''
965  write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
966  write(*,*) ' is NOT EQUAL to'
967  write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
968 
969  call abortprogram('')
970  else
971  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
972  end if
973 
974 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequalchar4()

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

Definition at line 979 of file dc_test.f90.

979  use sysdep, only: abortprogram
980  use dc_types, only: string, token
981  implicit none
982  character(*), intent(in):: message
983  character(*), intent(in):: answer(:,:,:,:)
984  character(*), intent(in):: check(:,:,:,:)
985  logical:: err_flag
986  character(STRING):: pos_str
987  character(STRING):: wrong, right
988 
989  integer:: answer_shape(4), check_shape(4), pos(4)
990  logical:: consist_shape(4)
991  character(TOKEN):: pos_array(4)
992  integer, allocatable:: mask_array(:,:,:,:)
993  logical, allocatable:: judge(:,:,:,:)
994  logical, allocatable:: judge_rev(:,:,:,:)
995 
996 
997  character(STRING), allocatable:: answer_fixed_length(:,:,:,:)
998  character(STRING), allocatable:: check_fixed_length(:,:,:,:)
999 
1000 
1001 
1002  continue
1003  err_flag = .false.
1004 
1005 
1006  answer_shape = shape(answer)
1007  check_shape = shape(check)
1008 
1009  consist_shape = answer_shape == check_shape
1010 
1011  if (.not. all(consist_shape)) then
1012  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1013  write(*,*) ''
1014  write(*,*) ' shape of check is (', check_shape, ')'
1015  write(*,*) ' is INCORRECT'
1016  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
1017 
1018  call abortprogram('')
1019  end if
1020 
1021 
1022  allocate( mask_array( &
1023  & answer_shape(1), &
1024 
1025  & answer_shape(2), &
1026 
1027  & answer_shape(3), &
1028 
1029  & answer_shape(4) ) &
1030  & )
1031 
1032  allocate( judge( &
1033  & answer_shape(1), &
1034 
1035  & answer_shape(2), &
1036 
1037  & answer_shape(3), &
1038 
1039  & answer_shape(4) ) &
1040  & )
1041 
1042  allocate( judge_rev( &
1043  & answer_shape(1), &
1044 
1045  & answer_shape(2), &
1046 
1047  & answer_shape(3), &
1048 
1049  & answer_shape(4) ) &
1050  & )
1051 
1052 
1053  allocate( answer_fixed_length( &
1054  & answer_shape(1), &
1055 
1056  & answer_shape(2), &
1057 
1058  & answer_shape(3), &
1059 
1060  & answer_shape(4) ) &
1061  & )
1062 
1063  allocate( check_fixed_length( &
1064  & check_shape(1), &
1065 
1066  & check_shape(2), &
1067 
1068  & check_shape(3), &
1069 
1070  & check_shape(4) ) &
1071  & )
1072 
1073  answer_fixed_length = answer
1074  check_fixed_length = check
1075 
1076  judge = answer_fixed_length == check_fixed_length
1077  deallocate(answer_fixed_length, check_fixed_length)
1078 
1079 
1080 
1081  judge_rev = .not. judge
1082  err_flag = any(judge_rev)
1083  mask_array = 1
1084  pos = maxloc(mask_array, judge_rev)
1085 
1086  if (err_flag) then
1087 
1088  wrong = check( &
1089  & pos(1), &
1090 
1091  & pos(2), &
1092 
1093  & pos(3), &
1094 
1095  & pos(4) )
1096 
1097  right = answer( &
1098  & pos(1), &
1099 
1100  & pos(2), &
1101 
1102  & pos(3), &
1103 
1104  & pos(4) )
1105 
1106  write(unit=pos_array(1), fmt="(i20)") pos(1)
1107 
1108  write(unit=pos_array(2), fmt="(i20)") pos(2)
1109 
1110  write(unit=pos_array(3), fmt="(i20)") pos(3)
1111 
1112  write(unit=pos_array(4), fmt="(i20)") pos(4)
1113 
1114 
1115  pos_str = '(' // &
1116  & trim(adjustl(pos_array(1))) // ',' // &
1117 
1118  & trim(adjustl(pos_array(2))) // ',' // &
1119 
1120  & trim(adjustl(pos_array(3))) // ',' // &
1121 
1122  & trim(adjustl(pos_array(4))) // ')'
1123 
1124  end if
1125  deallocate(mask_array, judge, judge_rev)
1126 
1127 
1128 
1129 
1130  if (err_flag) then
1131  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1132  write(*,*) ''
1133  write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
1134  write(*,*) ' is NOT EQUAL to'
1135  write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
1136 
1137  call abortprogram('')
1138  else
1139  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
1140  end if
1141 
1142 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequalchar5()

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

Definition at line 1147 of file dc_test.f90.

1147  use sysdep, only: abortprogram
1148  use dc_types, only: string, token
1149  implicit none
1150  character(*), intent(in):: message
1151  character(*), intent(in):: answer(:,:,:,:,:)
1152  character(*), intent(in):: check(:,:,:,:,:)
1153  logical:: err_flag
1154  character(STRING):: pos_str
1155  character(STRING):: wrong, right
1156 
1157  integer:: answer_shape(5), check_shape(5), pos(5)
1158  logical:: consist_shape(5)
1159  character(TOKEN):: pos_array(5)
1160  integer, allocatable:: mask_array(:,:,:,:,:)
1161  logical, allocatable:: judge(:,:,:,:,:)
1162  logical, allocatable:: judge_rev(:,:,:,:,:)
1163 
1164 
1165  character(STRING), allocatable:: answer_fixed_length(:,:,:,:,:)
1166  character(STRING), allocatable:: check_fixed_length(:,:,:,:,:)
1167 
1168 
1169 
1170  continue
1171  err_flag = .false.
1172 
1173 
1174  answer_shape = shape(answer)
1175  check_shape = shape(check)
1176 
1177  consist_shape = answer_shape == check_shape
1178 
1179  if (.not. all(consist_shape)) then
1180  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1181  write(*,*) ''
1182  write(*,*) ' shape of check is (', check_shape, ')'
1183  write(*,*) ' is INCORRECT'
1184  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
1185 
1186  call abortprogram('')
1187  end if
1188 
1189 
1190  allocate( mask_array( &
1191  & answer_shape(1), &
1192 
1193  & answer_shape(2), &
1194 
1195  & answer_shape(3), &
1196 
1197  & answer_shape(4), &
1198 
1199  & answer_shape(5) ) &
1200  & )
1201 
1202  allocate( judge( &
1203  & answer_shape(1), &
1204 
1205  & answer_shape(2), &
1206 
1207  & answer_shape(3), &
1208 
1209  & answer_shape(4), &
1210 
1211  & answer_shape(5) ) &
1212  & )
1213 
1214  allocate( judge_rev( &
1215  & answer_shape(1), &
1216 
1217  & answer_shape(2), &
1218 
1219  & answer_shape(3), &
1220 
1221  & answer_shape(4), &
1222 
1223  & answer_shape(5) ) &
1224  & )
1225 
1226 
1227  allocate( answer_fixed_length( &
1228  & answer_shape(1), &
1229 
1230  & answer_shape(2), &
1231 
1232  & answer_shape(3), &
1233 
1234  & answer_shape(4), &
1235 
1236  & answer_shape(5) ) &
1237  & )
1238 
1239  allocate( check_fixed_length( &
1240  & check_shape(1), &
1241 
1242  & check_shape(2), &
1243 
1244  & check_shape(3), &
1245 
1246  & check_shape(4), &
1247 
1248  & check_shape(5) ) &
1249  & )
1250 
1251  answer_fixed_length = answer
1252  check_fixed_length = check
1253 
1254  judge = answer_fixed_length == check_fixed_length
1255  deallocate(answer_fixed_length, check_fixed_length)
1256 
1257 
1258 
1259  judge_rev = .not. judge
1260  err_flag = any(judge_rev)
1261  mask_array = 1
1262  pos = maxloc(mask_array, judge_rev)
1263 
1264  if (err_flag) then
1265 
1266  wrong = check( &
1267  & pos(1), &
1268 
1269  & pos(2), &
1270 
1271  & pos(3), &
1272 
1273  & pos(4), &
1274 
1275  & pos(5) )
1276 
1277  right = answer( &
1278  & pos(1), &
1279 
1280  & pos(2), &
1281 
1282  & pos(3), &
1283 
1284  & pos(4), &
1285 
1286  & pos(5) )
1287 
1288  write(unit=pos_array(1), fmt="(i20)") pos(1)
1289 
1290  write(unit=pos_array(2), fmt="(i20)") pos(2)
1291 
1292  write(unit=pos_array(3), fmt="(i20)") pos(3)
1293 
1294  write(unit=pos_array(4), fmt="(i20)") pos(4)
1295 
1296  write(unit=pos_array(5), fmt="(i20)") pos(5)
1297 
1298 
1299  pos_str = '(' // &
1300  & trim(adjustl(pos_array(1))) // ',' // &
1301 
1302  & trim(adjustl(pos_array(2))) // ',' // &
1303 
1304  & trim(adjustl(pos_array(3))) // ',' // &
1305 
1306  & trim(adjustl(pos_array(4))) // ',' // &
1307 
1308  & trim(adjustl(pos_array(5))) // ')'
1309 
1310  end if
1311  deallocate(mask_array, judge, judge_rev)
1312 
1313 
1314 
1315 
1316  if (err_flag) then
1317  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1318  write(*,*) ''
1319  write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
1320  write(*,*) ' is NOT EQUAL to'
1321  write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
1322 
1323  call abortprogram('')
1324  else
1325  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
1326  end if
1327 
1328 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequalchar6()

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

Definition at line 1333 of file dc_test.f90.

1333  use sysdep, only: abortprogram
1334  use dc_types, only: string, token
1335  implicit none
1336  character(*), intent(in):: message
1337  character(*), intent(in):: answer(:,:,:,:,:,:)
1338  character(*), intent(in):: check(:,:,:,:,:,:)
1339  logical:: err_flag
1340  character(STRING):: pos_str
1341  character(STRING):: wrong, right
1342 
1343  integer:: answer_shape(6), check_shape(6), pos(6)
1344  logical:: consist_shape(6)
1345  character(TOKEN):: pos_array(6)
1346  integer, allocatable:: mask_array(:,:,:,:,:,:)
1347  logical, allocatable:: judge(:,:,:,:,:,:)
1348  logical, allocatable:: judge_rev(:,:,:,:,:,:)
1349 
1350 
1351  character(STRING), allocatable:: answer_fixed_length(:,:,:,:,:,:)
1352  character(STRING), allocatable:: check_fixed_length(:,:,:,:,:,:)
1353 
1354 
1355 
1356  continue
1357  err_flag = .false.
1358 
1359 
1360  answer_shape = shape(answer)
1361  check_shape = shape(check)
1362 
1363  consist_shape = answer_shape == check_shape
1364 
1365  if (.not. all(consist_shape)) then
1366  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1367  write(*,*) ''
1368  write(*,*) ' shape of check is (', check_shape, ')'
1369  write(*,*) ' is INCORRECT'
1370  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
1371 
1372  call abortprogram('')
1373  end if
1374 
1375 
1376  allocate( mask_array( &
1377  & answer_shape(1), &
1378 
1379  & answer_shape(2), &
1380 
1381  & answer_shape(3), &
1382 
1383  & answer_shape(4), &
1384 
1385  & answer_shape(5), &
1386 
1387  & answer_shape(6) ) &
1388  & )
1389 
1390  allocate( judge( &
1391  & answer_shape(1), &
1392 
1393  & answer_shape(2), &
1394 
1395  & answer_shape(3), &
1396 
1397  & answer_shape(4), &
1398 
1399  & answer_shape(5), &
1400 
1401  & answer_shape(6) ) &
1402  & )
1403 
1404  allocate( judge_rev( &
1405  & answer_shape(1), &
1406 
1407  & answer_shape(2), &
1408 
1409  & answer_shape(3), &
1410 
1411  & answer_shape(4), &
1412 
1413  & answer_shape(5), &
1414 
1415  & answer_shape(6) ) &
1416  & )
1417 
1418 
1419  allocate( answer_fixed_length( &
1420  & answer_shape(1), &
1421 
1422  & answer_shape(2), &
1423 
1424  & answer_shape(3), &
1425 
1426  & answer_shape(4), &
1427 
1428  & answer_shape(5), &
1429 
1430  & answer_shape(6) ) &
1431  & )
1432 
1433  allocate( check_fixed_length( &
1434  & check_shape(1), &
1435 
1436  & check_shape(2), &
1437 
1438  & check_shape(3), &
1439 
1440  & check_shape(4), &
1441 
1442  & check_shape(5), &
1443 
1444  & check_shape(6) ) &
1445  & )
1446 
1447  answer_fixed_length = answer
1448  check_fixed_length = check
1449 
1450  judge = answer_fixed_length == check_fixed_length
1451  deallocate(answer_fixed_length, check_fixed_length)
1452 
1453 
1454 
1455  judge_rev = .not. judge
1456  err_flag = any(judge_rev)
1457  mask_array = 1
1458  pos = maxloc(mask_array, judge_rev)
1459 
1460  if (err_flag) then
1461 
1462  wrong = check( &
1463  & pos(1), &
1464 
1465  & pos(2), &
1466 
1467  & pos(3), &
1468 
1469  & pos(4), &
1470 
1471  & pos(5), &
1472 
1473  & pos(6) )
1474 
1475  right = answer( &
1476  & pos(1), &
1477 
1478  & pos(2), &
1479 
1480  & pos(3), &
1481 
1482  & pos(4), &
1483 
1484  & pos(5), &
1485 
1486  & pos(6) )
1487 
1488  write(unit=pos_array(1), fmt="(i20)") pos(1)
1489 
1490  write(unit=pos_array(2), fmt="(i20)") pos(2)
1491 
1492  write(unit=pos_array(3), fmt="(i20)") pos(3)
1493 
1494  write(unit=pos_array(4), fmt="(i20)") pos(4)
1495 
1496  write(unit=pos_array(5), fmt="(i20)") pos(5)
1497 
1498  write(unit=pos_array(6), fmt="(i20)") pos(6)
1499 
1500 
1501  pos_str = '(' // &
1502  & trim(adjustl(pos_array(1))) // ',' // &
1503 
1504  & trim(adjustl(pos_array(2))) // ',' // &
1505 
1506  & trim(adjustl(pos_array(3))) // ',' // &
1507 
1508  & trim(adjustl(pos_array(4))) // ',' // &
1509 
1510  & trim(adjustl(pos_array(5))) // ',' // &
1511 
1512  & trim(adjustl(pos_array(6))) // ')'
1513 
1514  end if
1515  deallocate(mask_array, judge, judge_rev)
1516 
1517 
1518 
1519 
1520  if (err_flag) then
1521  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1522  write(*,*) ''
1523  write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
1524  write(*,*) ' is NOT EQUAL to'
1525  write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
1526 
1527  call abortprogram('')
1528  else
1529  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
1530  end if
1531 
1532 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequalchar7()

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

Definition at line 1537 of file dc_test.f90.

1537  use sysdep, only: abortprogram
1538  use dc_types, only: string, token
1539  implicit none
1540  character(*), intent(in):: message
1541  character(*), intent(in):: answer(:,:,:,:,:,:,:)
1542  character(*), intent(in):: check(:,:,:,:,:,:,:)
1543  logical:: err_flag
1544  character(STRING):: pos_str
1545  character(STRING):: wrong, right
1546 
1547  integer:: answer_shape(7), check_shape(7), pos(7)
1548  logical:: consist_shape(7)
1549  character(TOKEN):: pos_array(7)
1550  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
1551  logical, allocatable:: judge(:,:,:,:,:,:,:)
1552  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
1553 
1554 
1555  character(STRING), allocatable:: answer_fixed_length(:,:,:,:,:,:,:)
1556  character(STRING), allocatable:: check_fixed_length(:,:,:,:,:,:,:)
1557 
1558 
1559 
1560  continue
1561  err_flag = .false.
1562 
1563 
1564  answer_shape = shape(answer)
1565  check_shape = shape(check)
1566 
1567  consist_shape = answer_shape == check_shape
1568 
1569  if (.not. all(consist_shape)) then
1570  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1571  write(*,*) ''
1572  write(*,*) ' shape of check is (', check_shape, ')'
1573  write(*,*) ' is INCORRECT'
1574  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
1575 
1576  call abortprogram('')
1577  end if
1578 
1579 
1580  allocate( mask_array( &
1581  & answer_shape(1), &
1582 
1583  & answer_shape(2), &
1584 
1585  & answer_shape(3), &
1586 
1587  & answer_shape(4), &
1588 
1589  & answer_shape(5), &
1590 
1591  & answer_shape(6), &
1592 
1593  & answer_shape(7) ) &
1594  & )
1595 
1596  allocate( judge( &
1597  & answer_shape(1), &
1598 
1599  & answer_shape(2), &
1600 
1601  & answer_shape(3), &
1602 
1603  & answer_shape(4), &
1604 
1605  & answer_shape(5), &
1606 
1607  & answer_shape(6), &
1608 
1609  & answer_shape(7) ) &
1610  & )
1611 
1612  allocate( judge_rev( &
1613  & answer_shape(1), &
1614 
1615  & answer_shape(2), &
1616 
1617  & answer_shape(3), &
1618 
1619  & answer_shape(4), &
1620 
1621  & answer_shape(5), &
1622 
1623  & answer_shape(6), &
1624 
1625  & answer_shape(7) ) &
1626  & )
1627 
1628 
1629  allocate( answer_fixed_length( &
1630  & answer_shape(1), &
1631 
1632  & answer_shape(2), &
1633 
1634  & answer_shape(3), &
1635 
1636  & answer_shape(4), &
1637 
1638  & answer_shape(5), &
1639 
1640  & answer_shape(6), &
1641 
1642  & answer_shape(7) ) &
1643  & )
1644 
1645  allocate( check_fixed_length( &
1646  & check_shape(1), &
1647 
1648  & check_shape(2), &
1649 
1650  & check_shape(3), &
1651 
1652  & check_shape(4), &
1653 
1654  & check_shape(5), &
1655 
1656  & check_shape(6), &
1657 
1658  & check_shape(7) ) &
1659  & )
1660 
1661  answer_fixed_length = answer
1662  check_fixed_length = check
1663 
1664  judge = answer_fixed_length == check_fixed_length
1665  deallocate(answer_fixed_length, check_fixed_length)
1666 
1667 
1668 
1669  judge_rev = .not. judge
1670  err_flag = any(judge_rev)
1671  mask_array = 1
1672  pos = maxloc(mask_array, judge_rev)
1673 
1674  if (err_flag) then
1675 
1676  wrong = check( &
1677  & pos(1), &
1678 
1679  & pos(2), &
1680 
1681  & pos(3), &
1682 
1683  & pos(4), &
1684 
1685  & pos(5), &
1686 
1687  & pos(6), &
1688 
1689  & pos(7) )
1690 
1691  right = answer( &
1692  & pos(1), &
1693 
1694  & pos(2), &
1695 
1696  & pos(3), &
1697 
1698  & pos(4), &
1699 
1700  & pos(5), &
1701 
1702  & pos(6), &
1703 
1704  & pos(7) )
1705 
1706  write(unit=pos_array(1), fmt="(i20)") pos(1)
1707 
1708  write(unit=pos_array(2), fmt="(i20)") pos(2)
1709 
1710  write(unit=pos_array(3), fmt="(i20)") pos(3)
1711 
1712  write(unit=pos_array(4), fmt="(i20)") pos(4)
1713 
1714  write(unit=pos_array(5), fmt="(i20)") pos(5)
1715 
1716  write(unit=pos_array(6), fmt="(i20)") pos(6)
1717 
1718  write(unit=pos_array(7), fmt="(i20)") pos(7)
1719 
1720 
1721  pos_str = '(' // &
1722  & trim(adjustl(pos_array(1))) // ',' // &
1723 
1724  & trim(adjustl(pos_array(2))) // ',' // &
1725 
1726  & trim(adjustl(pos_array(3))) // ',' // &
1727 
1728  & trim(adjustl(pos_array(4))) // ',' // &
1729 
1730  & trim(adjustl(pos_array(5))) // ',' // &
1731 
1732  & trim(adjustl(pos_array(6))) // ',' // &
1733 
1734  & trim(adjustl(pos_array(7))) // ')'
1735 
1736  end if
1737  deallocate(mask_array, judge, judge_rev)
1738 
1739 
1740 
1741 
1742  if (err_flag) then
1743  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1744  write(*,*) ''
1745  write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
1746  write(*,*) ' is NOT EQUAL to'
1747  write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
1748 
1749  call abortprogram('')
1750  else
1751  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
1752  end if
1753 
1754 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequaldouble0()

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

Definition at line 3831 of file dc_test.f90.

3831  use sysdep, only: abortprogram
3832  use dc_types, only: string, token
3833  implicit none
3834  character(*), intent(in):: message
3835  real(DP), intent(in):: answer
3836  real(DP), intent(in):: check
3837  logical:: err_flag
3838  character(STRING):: pos_str
3839  real(DP):: wrong, right
3840 
3841 
3842 
3843 
3844 
3845  continue
3846  err_flag = .false.
3847 
3848 
3849  err_flag = .not. answer == check
3850  wrong = check
3851  right = answer
3852  pos_str = ''
3853 
3854 
3855 
3856 
3857  if (err_flag) then
3858  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3859  write(*,*) ''
3860  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3861  write(*,*) ' is NOT EQUAL to'
3862  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3863 
3864  call abortprogram('')
3865  else
3866  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3867  end if
3868 
3869 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ 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 
)
private

Definition at line 7297 of file dc_test.f90.

7297  use sysdep, only: abortprogram
7298  use dc_types, only: string, token
7299  implicit none
7300  character(*), intent(in):: message
7301  real(DP), intent(in):: answer
7302  real(DP), intent(in):: check
7303  integer, intent(in):: significant_digits
7304  integer, intent(in):: ignore_digits
7305  logical:: err_flag
7306  character(STRING):: pos_str
7307  real(DP):: wrong, right_max, right_min
7308  character(STRING):: pos_str_space
7309  integer:: pos_str_len
7310  real(DP):: right_tmp
7311 
7312  real(DP):: answer_max
7313  real(DP):: answer_min
7314 
7315  continue
7316  err_flag = .false.
7317 
7318  if ( significant_digits < 1 ) then
7319  write(*,*) ' *** Error [AssertEQ] *** '
7320  write(*,*) ' Specify a number more than 1 to "significant_digits"'
7321  call abortprogram('')
7322  end if
7323 
7324  if ( answer < 0.0_dp .and. check < 0.0_dp ) then
7325  answer_max = &
7326  & answer &
7327  & * ( 1.0_dp &
7328  & - 0.1_dp ** significant_digits ) &
7329  & + 0.1_dp ** (- ignore_digits)
7330 
7331  answer_min = &
7332  & answer &
7333  & * ( 1.0_dp &
7334  & + 0.1_dp ** significant_digits ) &
7335  & - 0.1_dp ** (- ignore_digits)
7336  else
7337 
7338  answer_max = &
7339  & answer &
7340  & * ( 1.0_dp &
7341  & + 0.1_dp ** significant_digits ) &
7342  & + 0.1_dp ** (- ignore_digits)
7343 
7344  answer_min = &
7345  & answer &
7346  & * ( 1.0_dp &
7347  & - 0.1_dp ** significant_digits ) &
7348  & - 0.1_dp ** (- ignore_digits)
7349  end if
7350 
7351  wrong = check
7352  right_max = answer_max
7353  right_min = answer_min
7354  if ( right_max < right_min ) then
7355  right_tmp = right_max
7356  right_max = right_min
7357  right_min = right_tmp
7358  end if
7359 
7360  err_flag = .not. (answer_max > check .and. check > answer_min)
7361 
7362  pos_str = ''
7363 
7364 
7365 
7366  if (err_flag) then
7367  pos_str_space = ''
7368  pos_str_len = len_trim(pos_str)
7369 
7370  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7371  write(*,*) ''
7372  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
7373  write(*,*) ' is NOT EQUAL to'
7374  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
7375  & // ' ', right_min, ' < '
7376  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
7377 
7378  call abortprogram('')
7379  else
7380  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
7381  end if
7382 
7383 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequaldouble1()

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

Definition at line 3874 of file dc_test.f90.

3874  use sysdep, only: abortprogram
3875  use dc_types, only: string, token
3876  implicit none
3877  character(*), intent(in):: message
3878  real(DP), intent(in):: answer(:)
3879  real(DP), intent(in):: check(:)
3880  logical:: err_flag
3881  character(STRING):: pos_str
3882  real(DP):: wrong, right
3883 
3884  integer:: answer_shape(1), check_shape(1), pos(1)
3885  logical:: consist_shape(1)
3886  character(TOKEN):: pos_array(1)
3887  integer, allocatable:: mask_array(:)
3888  logical, allocatable:: judge(:)
3889  logical, allocatable:: judge_rev(:)
3890 
3891 
3892 
3893 
3894  continue
3895  err_flag = .false.
3896 
3897 
3898  answer_shape = shape(answer)
3899  check_shape = shape(check)
3900 
3901  consist_shape = answer_shape == check_shape
3902 
3903  if (.not. all(consist_shape)) then
3904  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3905  write(*,*) ''
3906  write(*,*) ' shape of check is (', check_shape, ')'
3907  write(*,*) ' is INCORRECT'
3908  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3909 
3910  call abortprogram('')
3911  end if
3912 
3913 
3914  allocate( mask_array( &
3915 
3916  & answer_shape(1) ) &
3917  & )
3918 
3919  allocate( judge( &
3920 
3921  & answer_shape(1) ) &
3922  & )
3923 
3924  allocate( judge_rev( &
3925 
3926  & answer_shape(1) ) &
3927  & )
3928 
3929 
3930  judge = answer == check
3931 
3932 
3933 
3934  judge_rev = .not. judge
3935  err_flag = any(judge_rev)
3936  mask_array = 1
3937  pos = maxloc(mask_array, judge_rev)
3938 
3939  if (err_flag) then
3940 
3941  wrong = check( &
3942 
3943  & pos(1) )
3944 
3945  right = answer( &
3946 
3947  & pos(1) )
3948 
3949  write(unit=pos_array(1), fmt="(i20)") pos(1)
3950 
3951 
3952  pos_str = '(' // &
3953 
3954  & trim(adjustl(pos_array(1))) // ')'
3955 
3956  end if
3957  deallocate(mask_array, judge, judge_rev)
3958 
3959 
3960 
3961 
3962  if (err_flag) then
3963  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3964  write(*,*) ''
3965  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3966  write(*,*) ' is NOT EQUAL to'
3967  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3968 
3969  call abortprogram('')
3970  else
3971  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3972  end if
3973 
3974 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ 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 
)
private

Definition at line 7389 of file dc_test.f90.

7389  use sysdep, only: abortprogram
7390  use dc_types, only: string, token
7391  implicit none
7392  character(*), intent(in):: message
7393  real(DP), intent(in):: answer(:)
7394  real(DP), intent(in):: check(:)
7395  integer, intent(in):: significant_digits
7396  integer, intent(in):: ignore_digits
7397  logical:: err_flag
7398  character(STRING):: pos_str
7399  real(DP):: wrong, right_max, right_min
7400  character(STRING):: pos_str_space
7401  integer:: pos_str_len
7402  real(DP):: right_tmp
7403 
7404  integer:: answer_shape(1), check_shape(1), pos(1)
7405  logical:: consist_shape(1)
7406  character(TOKEN):: pos_array(1)
7407  integer, allocatable:: mask_array(:)
7408  logical, allocatable:: judge(:)
7409  logical, allocatable:: judge_rev(:)
7410  logical, allocatable:: answer_negative(:)
7411  logical, allocatable:: check_negative(:)
7412  logical, allocatable:: both_negative(:)
7413  real(DP), allocatable:: answer_max(:)
7414  real(DP), allocatable:: answer_min(:)
7415 
7416  continue
7417  err_flag = .false.
7418 
7419  if ( significant_digits < 1 ) then
7420  write(*,*) ' *** Error [AssertEQ] *** '
7421  write(*,*) ' Specify a number more than 1 to "significant_digits"'
7422  call abortprogram('')
7423  end if
7424 
7425  answer_shape = shape(answer)
7426  check_shape = shape(check)
7427 
7428  consist_shape = answer_shape == check_shape
7429 
7430  if (.not. all(consist_shape)) then
7431  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7432  write(*,*) ''
7433  write(*,*) ' shape of check is (', check_shape, ')'
7434  write(*,*) ' is INCORRECT'
7435  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
7436 
7437  call abortprogram('')
7438  end if
7439 
7440 
7441  allocate( mask_array( &
7442 
7443  & answer_shape(1) ) &
7444  & )
7445 
7446  allocate( judge( &
7447 
7448  & answer_shape(1) ) &
7449  & )
7450 
7451  allocate( judge_rev( &
7452 
7453  & answer_shape(1) ) &
7454  & )
7455 
7456  allocate( answer_negative( &
7457 
7458  & answer_shape(1) ) &
7459  & )
7460 
7461  allocate( check_negative( &
7462 
7463  & answer_shape(1) ) &
7464  & )
7465 
7466  allocate( both_negative( &
7467 
7468  & answer_shape(1) ) &
7469  & )
7470 
7471  allocate( answer_max( &
7472 
7473  & answer_shape(1) ) &
7474  & )
7475 
7476  allocate( answer_min( &
7477 
7478  & answer_shape(1) ) &
7479  & )
7480 
7481  answer_negative = answer < 0.0_dp
7482  check_negative = check < 0.0_dp
7483  both_negative = answer_negative .and. check_negative
7484 
7485  where (both_negative)
7486  answer_max = &
7487  & answer &
7488  & * ( 1.0_dp &
7489  & - 0.1_dp ** significant_digits ) &
7490  & + 0.1_dp ** (- ignore_digits)
7491 
7492  answer_min = &
7493  & answer &
7494  & * ( 1.0_dp &
7495  & + 0.1_dp ** significant_digits ) &
7496  & - 0.1_dp ** (- ignore_digits)
7497  elsewhere
7498  answer_max = &
7499  & answer &
7500  & * ( 1.0_dp &
7501  & + 0.1_dp ** significant_digits ) &
7502  & + 0.1_dp ** (- ignore_digits)
7503 
7504  answer_min = &
7505  & answer &
7506  & * ( 1.0_dp &
7507  & - 0.1_dp ** significant_digits ) &
7508  & - 0.1_dp ** (- ignore_digits)
7509  end where
7510 
7511  judge = answer_max > check .and. check > answer_min
7512  judge_rev = .not. judge
7513  err_flag = any(judge_rev)
7514  mask_array = 1
7515  pos = maxloc(mask_array, judge_rev)
7516 
7517  if (err_flag) then
7518 
7519  wrong = check( &
7520 
7521  & pos(1) )
7522 
7523  right_max = answer_max( &
7524 
7525  & pos(1) )
7526 
7527  right_min = answer_min( &
7528 
7529  & pos(1) )
7530 
7531  if ( right_max < right_min ) then
7532  right_tmp = right_max
7533  right_max = right_min
7534  right_min = right_tmp
7535  end if
7536 
7537  write(unit=pos_array(1), fmt="(i20)") pos(1)
7538 
7539 
7540  pos_str = '(' // &
7541 
7542  & trim(adjustl(pos_array(1))) // ')'
7543 
7544  end if
7545  deallocate(mask_array, judge, judge_rev)
7546  deallocate(answer_negative, check_negative, both_negative)
7547  deallocate(answer_max, answer_min)
7548 
7549 
7550 
7551  if (err_flag) then
7552  pos_str_space = ''
7553  pos_str_len = len_trim(pos_str)
7554 
7555  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7556  write(*,*) ''
7557  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
7558  write(*,*) ' is NOT EQUAL to'
7559  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
7560  & // ' ', right_min, ' < '
7561  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
7562 
7563  call abortprogram('')
7564  else
7565  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
7566  end if
7567 
7568 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequaldouble2()

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

Definition at line 3979 of file dc_test.f90.

3979  use sysdep, only: abortprogram
3980  use dc_types, only: string, token
3981  implicit none
3982  character(*), intent(in):: message
3983  real(DP), intent(in):: answer(:,:)
3984  real(DP), intent(in):: check(:,:)
3985  logical:: err_flag
3986  character(STRING):: pos_str
3987  real(DP):: wrong, right
3988 
3989  integer:: answer_shape(2), check_shape(2), pos(2)
3990  logical:: consist_shape(2)
3991  character(TOKEN):: pos_array(2)
3992  integer, allocatable:: mask_array(:,:)
3993  logical, allocatable:: judge(:,:)
3994  logical, allocatable:: judge_rev(:,:)
3995 
3996 
3997 
3998 
3999  continue
4000  err_flag = .false.
4001 
4002 
4003  answer_shape = shape(answer)
4004  check_shape = shape(check)
4005 
4006  consist_shape = answer_shape == check_shape
4007 
4008  if (.not. all(consist_shape)) then
4009  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4010  write(*,*) ''
4011  write(*,*) ' shape of check is (', check_shape, ')'
4012  write(*,*) ' is INCORRECT'
4013  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
4014 
4015  call abortprogram('')
4016  end if
4017 
4018 
4019  allocate( mask_array( &
4020  & answer_shape(1), &
4021 
4022  & answer_shape(2) ) &
4023  & )
4024 
4025  allocate( judge( &
4026  & answer_shape(1), &
4027 
4028  & answer_shape(2) ) &
4029  & )
4030 
4031  allocate( judge_rev( &
4032  & answer_shape(1), &
4033 
4034  & answer_shape(2) ) &
4035  & )
4036 
4037 
4038  judge = answer == check
4039 
4040 
4041 
4042  judge_rev = .not. judge
4043  err_flag = any(judge_rev)
4044  mask_array = 1
4045  pos = maxloc(mask_array, judge_rev)
4046 
4047  if (err_flag) then
4048 
4049  wrong = check( &
4050  & pos(1), &
4051 
4052  & pos(2) )
4053 
4054  right = answer( &
4055  & pos(1), &
4056 
4057  & pos(2) )
4058 
4059  write(unit=pos_array(1), fmt="(i20)") pos(1)
4060 
4061  write(unit=pos_array(2), fmt="(i20)") pos(2)
4062 
4063 
4064  pos_str = '(' // &
4065  & trim(adjustl(pos_array(1))) // ',' // &
4066 
4067  & trim(adjustl(pos_array(2))) // ')'
4068 
4069  end if
4070  deallocate(mask_array, judge, judge_rev)
4071 
4072 
4073 
4074 
4075  if (err_flag) then
4076  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4077  write(*,*) ''
4078  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
4079  write(*,*) ' is NOT EQUAL to'
4080  write(*,*) ' answer' // trim(pos_str) // ' = ', right
4081 
4082  call abortprogram('')
4083  else
4084  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
4085  end if
4086 
4087 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ 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 
)
private

Definition at line 7574 of file dc_test.f90.

7574  use sysdep, only: abortprogram
7575  use dc_types, only: string, token
7576  implicit none
7577  character(*), intent(in):: message
7578  real(DP), intent(in):: answer(:,:)
7579  real(DP), intent(in):: check(:,:)
7580  integer, intent(in):: significant_digits
7581  integer, intent(in):: ignore_digits
7582  logical:: err_flag
7583  character(STRING):: pos_str
7584  real(DP):: wrong, right_max, right_min
7585  character(STRING):: pos_str_space
7586  integer:: pos_str_len
7587  real(DP):: right_tmp
7588 
7589  integer:: answer_shape(2), check_shape(2), pos(2)
7590  logical:: consist_shape(2)
7591  character(TOKEN):: pos_array(2)
7592  integer, allocatable:: mask_array(:,:)
7593  logical, allocatable:: judge(:,:)
7594  logical, allocatable:: judge_rev(:,:)
7595  logical, allocatable:: answer_negative(:,:)
7596  logical, allocatable:: check_negative(:,:)
7597  logical, allocatable:: both_negative(:,:)
7598  real(DP), allocatable:: answer_max(:,:)
7599  real(DP), allocatable:: answer_min(:,:)
7600 
7601  continue
7602  err_flag = .false.
7603 
7604  if ( significant_digits < 1 ) then
7605  write(*,*) ' *** Error [AssertEQ] *** '
7606  write(*,*) ' Specify a number more than 1 to "significant_digits"'
7607  call abortprogram('')
7608  end if
7609 
7610  answer_shape = shape(answer)
7611  check_shape = shape(check)
7612 
7613  consist_shape = answer_shape == check_shape
7614 
7615  if (.not. all(consist_shape)) then
7616  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7617  write(*,*) ''
7618  write(*,*) ' shape of check is (', check_shape, ')'
7619  write(*,*) ' is INCORRECT'
7620  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
7621 
7622  call abortprogram('')
7623  end if
7624 
7625 
7626  allocate( mask_array( &
7627  & answer_shape(1), &
7628 
7629  & answer_shape(2) ) &
7630  & )
7631 
7632  allocate( judge( &
7633  & answer_shape(1), &
7634 
7635  & answer_shape(2) ) &
7636  & )
7637 
7638  allocate( judge_rev( &
7639  & answer_shape(1), &
7640 
7641  & answer_shape(2) ) &
7642  & )
7643 
7644  allocate( answer_negative( &
7645  & answer_shape(1), &
7646 
7647  & answer_shape(2) ) &
7648  & )
7649 
7650  allocate( check_negative( &
7651  & answer_shape(1), &
7652 
7653  & answer_shape(2) ) &
7654  & )
7655 
7656  allocate( both_negative( &
7657  & answer_shape(1), &
7658 
7659  & answer_shape(2) ) &
7660  & )
7661 
7662  allocate( answer_max( &
7663  & answer_shape(1), &
7664 
7665  & answer_shape(2) ) &
7666  & )
7667 
7668  allocate( answer_min( &
7669  & answer_shape(1), &
7670 
7671  & answer_shape(2) ) &
7672  & )
7673 
7674  answer_negative = answer < 0.0_dp
7675  check_negative = check < 0.0_dp
7676  both_negative = answer_negative .and. check_negative
7677 
7678  where (both_negative)
7679  answer_max = &
7680  & answer &
7681  & * ( 1.0_dp &
7682  & - 0.1_dp ** significant_digits ) &
7683  & + 0.1_dp ** (- ignore_digits)
7684 
7685  answer_min = &
7686  & answer &
7687  & * ( 1.0_dp &
7688  & + 0.1_dp ** significant_digits ) &
7689  & - 0.1_dp ** (- ignore_digits)
7690  elsewhere
7691  answer_max = &
7692  & answer &
7693  & * ( 1.0_dp &
7694  & + 0.1_dp ** significant_digits ) &
7695  & + 0.1_dp ** (- ignore_digits)
7696 
7697  answer_min = &
7698  & answer &
7699  & * ( 1.0_dp &
7700  & - 0.1_dp ** significant_digits ) &
7701  & - 0.1_dp ** (- ignore_digits)
7702  end where
7703 
7704  judge = answer_max > check .and. check > answer_min
7705  judge_rev = .not. judge
7706  err_flag = any(judge_rev)
7707  mask_array = 1
7708  pos = maxloc(mask_array, judge_rev)
7709 
7710  if (err_flag) then
7711 
7712  wrong = check( &
7713  & pos(1), &
7714 
7715  & pos(2) )
7716 
7717  right_max = answer_max( &
7718  & pos(1), &
7719 
7720  & pos(2) )
7721 
7722  right_min = answer_min( &
7723  & pos(1), &
7724 
7725  & pos(2) )
7726 
7727  if ( right_max < right_min ) then
7728  right_tmp = right_max
7729  right_max = right_min
7730  right_min = right_tmp
7731  end if
7732 
7733  write(unit=pos_array(1), fmt="(i20)") pos(1)
7734 
7735  write(unit=pos_array(2), fmt="(i20)") pos(2)
7736 
7737 
7738  pos_str = '(' // &
7739  & trim(adjustl(pos_array(1))) // ',' // &
7740 
7741  & trim(adjustl(pos_array(2))) // ')'
7742 
7743  end if
7744  deallocate(mask_array, judge, judge_rev)
7745  deallocate(answer_negative, check_negative, both_negative)
7746  deallocate(answer_max, answer_min)
7747 
7748 
7749 
7750  if (err_flag) then
7751  pos_str_space = ''
7752  pos_str_len = len_trim(pos_str)
7753 
7754  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7755  write(*,*) ''
7756  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
7757  write(*,*) ' is NOT EQUAL to'
7758  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
7759  & // ' ', right_min, ' < '
7760  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
7761 
7762  call abortprogram('')
7763  else
7764  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
7765  end if
7766 
7767 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequaldouble3()

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

Definition at line 4092 of file dc_test.f90.

4092  use sysdep, only: abortprogram
4093  use dc_types, only: string, token
4094  implicit none
4095  character(*), intent(in):: message
4096  real(DP), intent(in):: answer(:,:,:)
4097  real(DP), intent(in):: check(:,:,:)
4098  logical:: err_flag
4099  character(STRING):: pos_str
4100  real(DP):: wrong, right
4101 
4102  integer:: answer_shape(3), check_shape(3), pos(3)
4103  logical:: consist_shape(3)
4104  character(TOKEN):: pos_array(3)
4105  integer, allocatable:: mask_array(:,:,:)
4106  logical, allocatable:: judge(:,:,:)
4107  logical, allocatable:: judge_rev(:,:,:)
4108 
4109 
4110 
4111 
4112  continue
4113  err_flag = .false.
4114 
4115 
4116  answer_shape = shape(answer)
4117  check_shape = shape(check)
4118 
4119  consist_shape = answer_shape == check_shape
4120 
4121  if (.not. all(consist_shape)) then
4122  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4123  write(*,*) ''
4124  write(*,*) ' shape of check is (', check_shape, ')'
4125  write(*,*) ' is INCORRECT'
4126  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
4127 
4128  call abortprogram('')
4129  end if
4130 
4131 
4132  allocate( mask_array( &
4133  & answer_shape(1), &
4134 
4135  & answer_shape(2), &
4136 
4137  & answer_shape(3) ) &
4138  & )
4139 
4140  allocate( judge( &
4141  & answer_shape(1), &
4142 
4143  & answer_shape(2), &
4144 
4145  & answer_shape(3) ) &
4146  & )
4147 
4148  allocate( judge_rev( &
4149  & answer_shape(1), &
4150 
4151  & answer_shape(2), &
4152 
4153  & answer_shape(3) ) &
4154  & )
4155 
4156 
4157  judge = answer == check
4158 
4159 
4160 
4161  judge_rev = .not. judge
4162  err_flag = any(judge_rev)
4163  mask_array = 1
4164  pos = maxloc(mask_array, judge_rev)
4165 
4166  if (err_flag) then
4167 
4168  wrong = check( &
4169  & pos(1), &
4170 
4171  & pos(2), &
4172 
4173  & pos(3) )
4174 
4175  right = answer( &
4176  & pos(1), &
4177 
4178  & pos(2), &
4179 
4180  & pos(3) )
4181 
4182  write(unit=pos_array(1), fmt="(i20)") pos(1)
4183 
4184  write(unit=pos_array(2), fmt="(i20)") pos(2)
4185 
4186  write(unit=pos_array(3), fmt="(i20)") pos(3)
4187 
4188 
4189  pos_str = '(' // &
4190  & trim(adjustl(pos_array(1))) // ',' // &
4191 
4192  & trim(adjustl(pos_array(2))) // ',' // &
4193 
4194  & trim(adjustl(pos_array(3))) // ')'
4195 
4196  end if
4197  deallocate(mask_array, judge, judge_rev)
4198 
4199 
4200 
4201 
4202  if (err_flag) then
4203  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4204  write(*,*) ''
4205  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
4206  write(*,*) ' is NOT EQUAL to'
4207  write(*,*) ' answer' // trim(pos_str) // ' = ', right
4208 
4209  call abortprogram('')
4210  else
4211  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
4212  end if
4213 
4214 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ 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 
)
private

Definition at line 7773 of file dc_test.f90.

7773  use sysdep, only: abortprogram
7774  use dc_types, only: string, token
7775  implicit none
7776  character(*), intent(in):: message
7777  real(DP), intent(in):: answer(:,:,:)
7778  real(DP), intent(in):: check(:,:,:)
7779  integer, intent(in):: significant_digits
7780  integer, intent(in):: ignore_digits
7781  logical:: err_flag
7782  character(STRING):: pos_str
7783  real(DP):: wrong, right_max, right_min
7784  character(STRING):: pos_str_space
7785  integer:: pos_str_len
7786  real(DP):: right_tmp
7787 
7788  integer:: answer_shape(3), check_shape(3), pos(3)
7789  logical:: consist_shape(3)
7790  character(TOKEN):: pos_array(3)
7791  integer, allocatable:: mask_array(:,:,:)
7792  logical, allocatable:: judge(:,:,:)
7793  logical, allocatable:: judge_rev(:,:,:)
7794  logical, allocatable:: answer_negative(:,:,:)
7795  logical, allocatable:: check_negative(:,:,:)
7796  logical, allocatable:: both_negative(:,:,:)
7797  real(DP), allocatable:: answer_max(:,:,:)
7798  real(DP), allocatable:: answer_min(:,:,:)
7799 
7800  continue
7801  err_flag = .false.
7802 
7803  if ( significant_digits < 1 ) then
7804  write(*,*) ' *** Error [AssertEQ] *** '
7805  write(*,*) ' Specify a number more than 1 to "significant_digits"'
7806  call abortprogram('')
7807  end if
7808 
7809  answer_shape = shape(answer)
7810  check_shape = shape(check)
7811 
7812  consist_shape = answer_shape == check_shape
7813 
7814  if (.not. all(consist_shape)) then
7815  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7816  write(*,*) ''
7817  write(*,*) ' shape of check is (', check_shape, ')'
7818  write(*,*) ' is INCORRECT'
7819  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
7820 
7821  call abortprogram('')
7822  end if
7823 
7824 
7825  allocate( mask_array( &
7826  & answer_shape(1), &
7827 
7828  & answer_shape(2), &
7829 
7830  & answer_shape(3) ) &
7831  & )
7832 
7833  allocate( judge( &
7834  & answer_shape(1), &
7835 
7836  & answer_shape(2), &
7837 
7838  & answer_shape(3) ) &
7839  & )
7840 
7841  allocate( judge_rev( &
7842  & answer_shape(1), &
7843 
7844  & answer_shape(2), &
7845 
7846  & answer_shape(3) ) &
7847  & )
7848 
7849  allocate( answer_negative( &
7850  & answer_shape(1), &
7851 
7852  & answer_shape(2), &
7853 
7854  & answer_shape(3) ) &
7855  & )
7856 
7857  allocate( check_negative( &
7858  & answer_shape(1), &
7859 
7860  & answer_shape(2), &
7861 
7862  & answer_shape(3) ) &
7863  & )
7864 
7865  allocate( both_negative( &
7866  & answer_shape(1), &
7867 
7868  & answer_shape(2), &
7869 
7870  & answer_shape(3) ) &
7871  & )
7872 
7873  allocate( answer_max( &
7874  & answer_shape(1), &
7875 
7876  & answer_shape(2), &
7877 
7878  & answer_shape(3) ) &
7879  & )
7880 
7881  allocate( answer_min( &
7882  & answer_shape(1), &
7883 
7884  & answer_shape(2), &
7885 
7886  & answer_shape(3) ) &
7887  & )
7888 
7889  answer_negative = answer < 0.0_dp
7890  check_negative = check < 0.0_dp
7891  both_negative = answer_negative .and. check_negative
7892 
7893  where (both_negative)
7894  answer_max = &
7895  & answer &
7896  & * ( 1.0_dp &
7897  & - 0.1_dp ** significant_digits ) &
7898  & + 0.1_dp ** (- ignore_digits)
7899 
7900  answer_min = &
7901  & answer &
7902  & * ( 1.0_dp &
7903  & + 0.1_dp ** significant_digits ) &
7904  & - 0.1_dp ** (- ignore_digits)
7905  elsewhere
7906  answer_max = &
7907  & answer &
7908  & * ( 1.0_dp &
7909  & + 0.1_dp ** significant_digits ) &
7910  & + 0.1_dp ** (- ignore_digits)
7911 
7912  answer_min = &
7913  & answer &
7914  & * ( 1.0_dp &
7915  & - 0.1_dp ** significant_digits ) &
7916  & - 0.1_dp ** (- ignore_digits)
7917  end where
7918 
7919  judge = answer_max > check .and. check > answer_min
7920  judge_rev = .not. judge
7921  err_flag = any(judge_rev)
7922  mask_array = 1
7923  pos = maxloc(mask_array, judge_rev)
7924 
7925  if (err_flag) then
7926 
7927  wrong = check( &
7928  & pos(1), &
7929 
7930  & pos(2), &
7931 
7932  & pos(3) )
7933 
7934  right_max = answer_max( &
7935  & pos(1), &
7936 
7937  & pos(2), &
7938 
7939  & pos(3) )
7940 
7941  right_min = answer_min( &
7942  & pos(1), &
7943 
7944  & pos(2), &
7945 
7946  & pos(3) )
7947 
7948  if ( right_max < right_min ) then
7949  right_tmp = right_max
7950  right_max = right_min
7951  right_min = right_tmp
7952  end if
7953 
7954  write(unit=pos_array(1), fmt="(i20)") pos(1)
7955 
7956  write(unit=pos_array(2), fmt="(i20)") pos(2)
7957 
7958  write(unit=pos_array(3), fmt="(i20)") pos(3)
7959 
7960 
7961  pos_str = '(' // &
7962  & trim(adjustl(pos_array(1))) // ',' // &
7963 
7964  & trim(adjustl(pos_array(2))) // ',' // &
7965 
7966  & trim(adjustl(pos_array(3))) // ')'
7967 
7968  end if
7969  deallocate(mask_array, judge, judge_rev)
7970  deallocate(answer_negative, check_negative, both_negative)
7971  deallocate(answer_max, answer_min)
7972 
7973 
7974 
7975  if (err_flag) then
7976  pos_str_space = ''
7977  pos_str_len = len_trim(pos_str)
7978 
7979  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7980  write(*,*) ''
7981  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
7982  write(*,*) ' is NOT EQUAL to'
7983  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
7984  & // ' ', right_min, ' < '
7985  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
7986 
7987  call abortprogram('')
7988  else
7989  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
7990  end if
7991 
7992 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequaldouble4()

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

Definition at line 4219 of file dc_test.f90.

4219  use sysdep, only: abortprogram
4220  use dc_types, only: string, token
4221  implicit none
4222  character(*), intent(in):: message
4223  real(DP), intent(in):: answer(:,:,:,:)
4224  real(DP), intent(in):: check(:,:,:,:)
4225  logical:: err_flag
4226  character(STRING):: pos_str
4227  real(DP):: wrong, right
4228 
4229  integer:: answer_shape(4), check_shape(4), pos(4)
4230  logical:: consist_shape(4)
4231  character(TOKEN):: pos_array(4)
4232  integer, allocatable:: mask_array(:,:,:,:)
4233  logical, allocatable:: judge(:,:,:,:)
4234  logical, allocatable:: judge_rev(:,:,:,:)
4235 
4236 
4237 
4238 
4239  continue
4240  err_flag = .false.
4241 
4242 
4243  answer_shape = shape(answer)
4244  check_shape = shape(check)
4245 
4246  consist_shape = answer_shape == check_shape
4247 
4248  if (.not. all(consist_shape)) then
4249  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4250  write(*,*) ''
4251  write(*,*) ' shape of check is (', check_shape, ')'
4252  write(*,*) ' is INCORRECT'
4253  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
4254 
4255  call abortprogram('')
4256  end if
4257 
4258 
4259  allocate( mask_array( &
4260  & answer_shape(1), &
4261 
4262  & answer_shape(2), &
4263 
4264  & answer_shape(3), &
4265 
4266  & answer_shape(4) ) &
4267  & )
4268 
4269  allocate( judge( &
4270  & answer_shape(1), &
4271 
4272  & answer_shape(2), &
4273 
4274  & answer_shape(3), &
4275 
4276  & answer_shape(4) ) &
4277  & )
4278 
4279  allocate( judge_rev( &
4280  & answer_shape(1), &
4281 
4282  & answer_shape(2), &
4283 
4284  & answer_shape(3), &
4285 
4286  & answer_shape(4) ) &
4287  & )
4288 
4289 
4290  judge = answer == check
4291 
4292 
4293 
4294  judge_rev = .not. judge
4295  err_flag = any(judge_rev)
4296  mask_array = 1
4297  pos = maxloc(mask_array, judge_rev)
4298 
4299  if (err_flag) then
4300 
4301  wrong = check( &
4302  & pos(1), &
4303 
4304  & pos(2), &
4305 
4306  & pos(3), &
4307 
4308  & pos(4) )
4309 
4310  right = answer( &
4311  & pos(1), &
4312 
4313  & pos(2), &
4314 
4315  & pos(3), &
4316 
4317  & pos(4) )
4318 
4319  write(unit=pos_array(1), fmt="(i20)") pos(1)
4320 
4321  write(unit=pos_array(2), fmt="(i20)") pos(2)
4322 
4323  write(unit=pos_array(3), fmt="(i20)") pos(3)
4324 
4325  write(unit=pos_array(4), fmt="(i20)") pos(4)
4326 
4327 
4328  pos_str = '(' // &
4329  & trim(adjustl(pos_array(1))) // ',' // &
4330 
4331  & trim(adjustl(pos_array(2))) // ',' // &
4332 
4333  & trim(adjustl(pos_array(3))) // ',' // &
4334 
4335  & trim(adjustl(pos_array(4))) // ')'
4336 
4337  end if
4338  deallocate(mask_array, judge, judge_rev)
4339 
4340 
4341 
4342 
4343  if (err_flag) then
4344  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4345  write(*,*) ''
4346  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
4347  write(*,*) ' is NOT EQUAL to'
4348  write(*,*) ' answer' // trim(pos_str) // ' = ', right
4349 
4350  call abortprogram('')
4351  else
4352  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
4353  end if
4354 
4355 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ 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 
)
private

Definition at line 7998 of file dc_test.f90.

7998  use sysdep, only: abortprogram
7999  use dc_types, only: string, token
8000  implicit none
8001  character(*), intent(in):: message
8002  real(DP), intent(in):: answer(:,:,:,:)
8003  real(DP), intent(in):: check(:,:,:,:)
8004  integer, intent(in):: significant_digits
8005  integer, intent(in):: ignore_digits
8006  logical:: err_flag
8007  character(STRING):: pos_str
8008  real(DP):: wrong, right_max, right_min
8009  character(STRING):: pos_str_space
8010  integer:: pos_str_len
8011  real(DP):: right_tmp
8012 
8013  integer:: answer_shape(4), check_shape(4), pos(4)
8014  logical:: consist_shape(4)
8015  character(TOKEN):: pos_array(4)
8016  integer, allocatable:: mask_array(:,:,:,:)
8017  logical, allocatable:: judge(:,:,:,:)
8018  logical, allocatable:: judge_rev(:,:,:,:)
8019  logical, allocatable:: answer_negative(:,:,:,:)
8020  logical, allocatable:: check_negative(:,:,:,:)
8021  logical, allocatable:: both_negative(:,:,:,:)
8022  real(DP), allocatable:: answer_max(:,:,:,:)
8023  real(DP), allocatable:: answer_min(:,:,:,:)
8024 
8025  continue
8026  err_flag = .false.
8027 
8028  if ( significant_digits < 1 ) then
8029  write(*,*) ' *** Error [AssertEQ] *** '
8030  write(*,*) ' Specify a number more than 1 to "significant_digits"'
8031  call abortprogram('')
8032  end if
8033 
8034  answer_shape = shape(answer)
8035  check_shape = shape(check)
8036 
8037  consist_shape = answer_shape == check_shape
8038 
8039  if (.not. all(consist_shape)) then
8040  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8041  write(*,*) ''
8042  write(*,*) ' shape of check is (', check_shape, ')'
8043  write(*,*) ' is INCORRECT'
8044  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
8045 
8046  call abortprogram('')
8047  end if
8048 
8049 
8050  allocate( mask_array( &
8051  & answer_shape(1), &
8052 
8053  & answer_shape(2), &
8054 
8055  & answer_shape(3), &
8056 
8057  & answer_shape(4) ) &
8058  & )
8059 
8060  allocate( judge( &
8061  & answer_shape(1), &
8062 
8063  & answer_shape(2), &
8064 
8065  & answer_shape(3), &
8066 
8067  & answer_shape(4) ) &
8068  & )
8069 
8070  allocate( judge_rev( &
8071  & answer_shape(1), &
8072 
8073  & answer_shape(2), &
8074 
8075  & answer_shape(3), &
8076 
8077  & answer_shape(4) ) &
8078  & )
8079 
8080  allocate( answer_negative( &
8081  & answer_shape(1), &
8082 
8083  & answer_shape(2), &
8084 
8085  & answer_shape(3), &
8086 
8087  & answer_shape(4) ) &
8088  & )
8089 
8090  allocate( check_negative( &
8091  & answer_shape(1), &
8092 
8093  & answer_shape(2), &
8094 
8095  & answer_shape(3), &
8096 
8097  & answer_shape(4) ) &
8098  & )
8099 
8100  allocate( both_negative( &
8101  & answer_shape(1), &
8102 
8103  & answer_shape(2), &
8104 
8105  & answer_shape(3), &
8106 
8107  & answer_shape(4) ) &
8108  & )
8109 
8110  allocate( answer_max( &
8111  & answer_shape(1), &
8112 
8113  & answer_shape(2), &
8114 
8115  & answer_shape(3), &
8116 
8117  & answer_shape(4) ) &
8118  & )
8119 
8120  allocate( answer_min( &
8121  & answer_shape(1), &
8122 
8123  & answer_shape(2), &
8124 
8125  & answer_shape(3), &
8126 
8127  & answer_shape(4) ) &
8128  & )
8129 
8130  answer_negative = answer < 0.0_dp
8131  check_negative = check < 0.0_dp
8132  both_negative = answer_negative .and. check_negative
8133 
8134  where (both_negative)
8135  answer_max = &
8136  & answer &
8137  & * ( 1.0_dp &
8138  & - 0.1_dp ** significant_digits ) &
8139  & + 0.1_dp ** (- ignore_digits)
8140 
8141  answer_min = &
8142  & answer &
8143  & * ( 1.0_dp &
8144  & + 0.1_dp ** significant_digits ) &
8145  & - 0.1_dp ** (- ignore_digits)
8146  elsewhere
8147  answer_max = &
8148  & answer &
8149  & * ( 1.0_dp &
8150  & + 0.1_dp ** significant_digits ) &
8151  & + 0.1_dp ** (- ignore_digits)
8152 
8153  answer_min = &
8154  & answer &
8155  & * ( 1.0_dp &
8156  & - 0.1_dp ** significant_digits ) &
8157  & - 0.1_dp ** (- ignore_digits)
8158  end where
8159 
8160  judge = answer_max > check .and. check > answer_min
8161  judge_rev = .not. judge
8162  err_flag = any(judge_rev)
8163  mask_array = 1
8164  pos = maxloc(mask_array, judge_rev)
8165 
8166  if (err_flag) then
8167 
8168  wrong = check( &
8169  & pos(1), &
8170 
8171  & pos(2), &
8172 
8173  & pos(3), &
8174 
8175  & pos(4) )
8176 
8177  right_max = answer_max( &
8178  & pos(1), &
8179 
8180  & pos(2), &
8181 
8182  & pos(3), &
8183 
8184  & pos(4) )
8185 
8186  right_min = answer_min( &
8187  & pos(1), &
8188 
8189  & pos(2), &
8190 
8191  & pos(3), &
8192 
8193  & pos(4) )
8194 
8195  if ( right_max < right_min ) then
8196  right_tmp = right_max
8197  right_max = right_min
8198  right_min = right_tmp
8199  end if
8200 
8201  write(unit=pos_array(1), fmt="(i20)") pos(1)
8202 
8203  write(unit=pos_array(2), fmt="(i20)") pos(2)
8204 
8205  write(unit=pos_array(3), fmt="(i20)") pos(3)
8206 
8207  write(unit=pos_array(4), fmt="(i20)") pos(4)
8208 
8209 
8210  pos_str = '(' // &
8211  & trim(adjustl(pos_array(1))) // ',' // &
8212 
8213  & trim(adjustl(pos_array(2))) // ',' // &
8214 
8215  & trim(adjustl(pos_array(3))) // ',' // &
8216 
8217  & trim(adjustl(pos_array(4))) // ')'
8218 
8219  end if
8220  deallocate(mask_array, judge, judge_rev)
8221  deallocate(answer_negative, check_negative, both_negative)
8222  deallocate(answer_max, answer_min)
8223 
8224 
8225 
8226  if (err_flag) then
8227  pos_str_space = ''
8228  pos_str_len = len_trim(pos_str)
8229 
8230  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8231  write(*,*) ''
8232  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
8233  write(*,*) ' is NOT EQUAL to'
8234  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
8235  & // ' ', right_min, ' < '
8236  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
8237 
8238  call abortprogram('')
8239  else
8240  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
8241  end if
8242 
8243 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequaldouble5()

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

Definition at line 4360 of file dc_test.f90.

4360  use sysdep, only: abortprogram
4361  use dc_types, only: string, token
4362  implicit none
4363  character(*), intent(in):: message
4364  real(DP), intent(in):: answer(:,:,:,:,:)
4365  real(DP), intent(in):: check(:,:,:,:,:)
4366  logical:: err_flag
4367  character(STRING):: pos_str
4368  real(DP):: wrong, right
4369 
4370  integer:: answer_shape(5), check_shape(5), pos(5)
4371  logical:: consist_shape(5)
4372  character(TOKEN):: pos_array(5)
4373  integer, allocatable:: mask_array(:,:,:,:,:)
4374  logical, allocatable:: judge(:,:,:,:,:)
4375  logical, allocatable:: judge_rev(:,:,:,:,:)
4376 
4377 
4378 
4379 
4380  continue
4381  err_flag = .false.
4382 
4383 
4384  answer_shape = shape(answer)
4385  check_shape = shape(check)
4386 
4387  consist_shape = answer_shape == check_shape
4388 
4389  if (.not. all(consist_shape)) then
4390  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4391  write(*,*) ''
4392  write(*,*) ' shape of check is (', check_shape, ')'
4393  write(*,*) ' is INCORRECT'
4394  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
4395 
4396  call abortprogram('')
4397  end if
4398 
4399 
4400  allocate( mask_array( &
4401  & answer_shape(1), &
4402 
4403  & answer_shape(2), &
4404 
4405  & answer_shape(3), &
4406 
4407  & answer_shape(4), &
4408 
4409  & answer_shape(5) ) &
4410  & )
4411 
4412  allocate( judge( &
4413  & answer_shape(1), &
4414 
4415  & answer_shape(2), &
4416 
4417  & answer_shape(3), &
4418 
4419  & answer_shape(4), &
4420 
4421  & answer_shape(5) ) &
4422  & )
4423 
4424  allocate( judge_rev( &
4425  & answer_shape(1), &
4426 
4427  & answer_shape(2), &
4428 
4429  & answer_shape(3), &
4430 
4431  & answer_shape(4), &
4432 
4433  & answer_shape(5) ) &
4434  & )
4435 
4436 
4437  judge = answer == check
4438 
4439 
4440 
4441  judge_rev = .not. judge
4442  err_flag = any(judge_rev)
4443  mask_array = 1
4444  pos = maxloc(mask_array, judge_rev)
4445 
4446  if (err_flag) then
4447 
4448  wrong = check( &
4449  & pos(1), &
4450 
4451  & pos(2), &
4452 
4453  & pos(3), &
4454 
4455  & pos(4), &
4456 
4457  & pos(5) )
4458 
4459  right = answer( &
4460  & pos(1), &
4461 
4462  & pos(2), &
4463 
4464  & pos(3), &
4465 
4466  & pos(4), &
4467 
4468  & pos(5) )
4469 
4470  write(unit=pos_array(1), fmt="(i20)") pos(1)
4471 
4472  write(unit=pos_array(2), fmt="(i20)") pos(2)
4473 
4474  write(unit=pos_array(3), fmt="(i20)") pos(3)
4475 
4476  write(unit=pos_array(4), fmt="(i20)") pos(4)
4477 
4478  write(unit=pos_array(5), fmt="(i20)") pos(5)
4479 
4480 
4481  pos_str = '(' // &
4482  & trim(adjustl(pos_array(1))) // ',' // &
4483 
4484  & trim(adjustl(pos_array(2))) // ',' // &
4485 
4486  & trim(adjustl(pos_array(3))) // ',' // &
4487 
4488  & trim(adjustl(pos_array(4))) // ',' // &
4489 
4490  & trim(adjustl(pos_array(5))) // ')'
4491 
4492  end if
4493  deallocate(mask_array, judge, judge_rev)
4494 
4495 
4496 
4497 
4498  if (err_flag) then
4499  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4500  write(*,*) ''
4501  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
4502  write(*,*) ' is NOT EQUAL to'
4503  write(*,*) ' answer' // trim(pos_str) // ' = ', right
4504 
4505  call abortprogram('')
4506  else
4507  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
4508  end if
4509 
4510 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ 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 
)
private

Definition at line 8249 of file dc_test.f90.

8249  use sysdep, only: abortprogram
8250  use dc_types, only: string, token
8251  implicit none
8252  character(*), intent(in):: message
8253  real(DP), intent(in):: answer(:,:,:,:,:)
8254  real(DP), intent(in):: check(:,:,:,:,:)
8255  integer, intent(in):: significant_digits
8256  integer, intent(in):: ignore_digits
8257  logical:: err_flag
8258  character(STRING):: pos_str
8259  real(DP):: wrong, right_max, right_min
8260  character(STRING):: pos_str_space
8261  integer:: pos_str_len
8262  real(DP):: right_tmp
8263 
8264  integer:: answer_shape(5), check_shape(5), pos(5)
8265  logical:: consist_shape(5)
8266  character(TOKEN):: pos_array(5)
8267  integer, allocatable:: mask_array(:,:,:,:,:)
8268  logical, allocatable:: judge(:,:,:,:,:)
8269  logical, allocatable:: judge_rev(:,:,:,:,:)
8270  logical, allocatable:: answer_negative(:,:,:,:,:)
8271  logical, allocatable:: check_negative(:,:,:,:,:)
8272  logical, allocatable:: both_negative(:,:,:,:,:)
8273  real(DP), allocatable:: answer_max(:,:,:,:,:)
8274  real(DP), allocatable:: answer_min(:,:,:,:,:)
8275 
8276  continue
8277  err_flag = .false.
8278 
8279  if ( significant_digits < 1 ) then
8280  write(*,*) ' *** Error [AssertEQ] *** '
8281  write(*,*) ' Specify a number more than 1 to "significant_digits"'
8282  call abortprogram('')
8283  end if
8284 
8285  answer_shape = shape(answer)
8286  check_shape = shape(check)
8287 
8288  consist_shape = answer_shape == check_shape
8289 
8290  if (.not. all(consist_shape)) then
8291  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8292  write(*,*) ''
8293  write(*,*) ' shape of check is (', check_shape, ')'
8294  write(*,*) ' is INCORRECT'
8295  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
8296 
8297  call abortprogram('')
8298  end if
8299 
8300 
8301  allocate( mask_array( &
8302  & answer_shape(1), &
8303 
8304  & answer_shape(2), &
8305 
8306  & answer_shape(3), &
8307 
8308  & answer_shape(4), &
8309 
8310  & answer_shape(5) ) &
8311  & )
8312 
8313  allocate( judge( &
8314  & answer_shape(1), &
8315 
8316  & answer_shape(2), &
8317 
8318  & answer_shape(3), &
8319 
8320  & answer_shape(4), &
8321 
8322  & answer_shape(5) ) &
8323  & )
8324 
8325  allocate( judge_rev( &
8326  & answer_shape(1), &
8327 
8328  & answer_shape(2), &
8329 
8330  & answer_shape(3), &
8331 
8332  & answer_shape(4), &
8333 
8334  & answer_shape(5) ) &
8335  & )
8336 
8337  allocate( answer_negative( &
8338  & answer_shape(1), &
8339 
8340  & answer_shape(2), &
8341 
8342  & answer_shape(3), &
8343 
8344  & answer_shape(4), &
8345 
8346  & answer_shape(5) ) &
8347  & )
8348 
8349  allocate( check_negative( &
8350  & answer_shape(1), &
8351 
8352  & answer_shape(2), &
8353 
8354  & answer_shape(3), &
8355 
8356  & answer_shape(4), &
8357 
8358  & answer_shape(5) ) &
8359  & )
8360 
8361  allocate( both_negative( &
8362  & answer_shape(1), &
8363 
8364  & answer_shape(2), &
8365 
8366  & answer_shape(3), &
8367 
8368  & answer_shape(4), &
8369 
8370  & answer_shape(5) ) &
8371  & )
8372 
8373  allocate( answer_max( &
8374  & answer_shape(1), &
8375 
8376  & answer_shape(2), &
8377 
8378  & answer_shape(3), &
8379 
8380  & answer_shape(4), &
8381 
8382  & answer_shape(5) ) &
8383  & )
8384 
8385  allocate( answer_min( &
8386  & answer_shape(1), &
8387 
8388  & answer_shape(2), &
8389 
8390  & answer_shape(3), &
8391 
8392  & answer_shape(4), &
8393 
8394  & answer_shape(5) ) &
8395  & )
8396 
8397  answer_negative = answer < 0.0_dp
8398  check_negative = check < 0.0_dp
8399  both_negative = answer_negative .and. check_negative
8400 
8401  where (both_negative)
8402  answer_max = &
8403  & answer &
8404  & * ( 1.0_dp &
8405  & - 0.1_dp ** significant_digits ) &
8406  & + 0.1_dp ** (- ignore_digits)
8407 
8408  answer_min = &
8409  & answer &
8410  & * ( 1.0_dp &
8411  & + 0.1_dp ** significant_digits ) &
8412  & - 0.1_dp ** (- ignore_digits)
8413  elsewhere
8414  answer_max = &
8415  & answer &
8416  & * ( 1.0_dp &
8417  & + 0.1_dp ** significant_digits ) &
8418  & + 0.1_dp ** (- ignore_digits)
8419 
8420  answer_min = &
8421  & answer &
8422  & * ( 1.0_dp &
8423  & - 0.1_dp ** significant_digits ) &
8424  & - 0.1_dp ** (- ignore_digits)
8425  end where
8426 
8427  judge = answer_max > check .and. check > answer_min
8428  judge_rev = .not. judge
8429  err_flag = any(judge_rev)
8430  mask_array = 1
8431  pos = maxloc(mask_array, judge_rev)
8432 
8433  if (err_flag) then
8434 
8435  wrong = check( &
8436  & pos(1), &
8437 
8438  & pos(2), &
8439 
8440  & pos(3), &
8441 
8442  & pos(4), &
8443 
8444  & pos(5) )
8445 
8446  right_max = answer_max( &
8447  & pos(1), &
8448 
8449  & pos(2), &
8450 
8451  & pos(3), &
8452 
8453  & pos(4), &
8454 
8455  & pos(5) )
8456 
8457  right_min = answer_min( &
8458  & pos(1), &
8459 
8460  & pos(2), &
8461 
8462  & pos(3), &
8463 
8464  & pos(4), &
8465 
8466  & pos(5) )
8467 
8468  if ( right_max < right_min ) then
8469  right_tmp = right_max
8470  right_max = right_min
8471  right_min = right_tmp
8472  end if
8473 
8474  write(unit=pos_array(1), fmt="(i20)") pos(1)
8475 
8476  write(unit=pos_array(2), fmt="(i20)") pos(2)
8477 
8478  write(unit=pos_array(3), fmt="(i20)") pos(3)
8479 
8480  write(unit=pos_array(4), fmt="(i20)") pos(4)
8481 
8482  write(unit=pos_array(5), fmt="(i20)") pos(5)
8483 
8484 
8485  pos_str = '(' // &
8486  & trim(adjustl(pos_array(1))) // ',' // &
8487 
8488  & trim(adjustl(pos_array(2))) // ',' // &
8489 
8490  & trim(adjustl(pos_array(3))) // ',' // &
8491 
8492  & trim(adjustl(pos_array(4))) // ',' // &
8493 
8494  & trim(adjustl(pos_array(5))) // ')'
8495 
8496  end if
8497  deallocate(mask_array, judge, judge_rev)
8498  deallocate(answer_negative, check_negative, both_negative)
8499  deallocate(answer_max, answer_min)
8500 
8501 
8502 
8503  if (err_flag) then
8504  pos_str_space = ''
8505  pos_str_len = len_trim(pos_str)
8506 
8507  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8508  write(*,*) ''
8509  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
8510  write(*,*) ' is NOT EQUAL to'
8511  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
8512  & // ' ', right_min, ' < '
8513  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
8514 
8515  call abortprogram('')
8516  else
8517  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
8518  end if
8519 
8520 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequaldouble6()

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

Definition at line 4515 of file dc_test.f90.

4515  use sysdep, only: abortprogram
4516  use dc_types, only: string, token
4517  implicit none
4518  character(*), intent(in):: message
4519  real(DP), intent(in):: answer(:,:,:,:,:,:)
4520  real(DP), intent(in):: check(:,:,:,:,:,:)
4521  logical:: err_flag
4522  character(STRING):: pos_str
4523  real(DP):: wrong, right
4524 
4525  integer:: answer_shape(6), check_shape(6), pos(6)
4526  logical:: consist_shape(6)
4527  character(TOKEN):: pos_array(6)
4528  integer, allocatable:: mask_array(:,:,:,:,:,:)
4529  logical, allocatable:: judge(:,:,:,:,:,:)
4530  logical, allocatable:: judge_rev(:,:,:,:,:,:)
4531 
4532 
4533 
4534 
4535  continue
4536  err_flag = .false.
4537 
4538 
4539  answer_shape = shape(answer)
4540  check_shape = shape(check)
4541 
4542  consist_shape = answer_shape == check_shape
4543 
4544  if (.not. all(consist_shape)) then
4545  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4546  write(*,*) ''
4547  write(*,*) ' shape of check is (', check_shape, ')'
4548  write(*,*) ' is INCORRECT'
4549  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
4550 
4551  call abortprogram('')
4552  end if
4553 
4554 
4555  allocate( mask_array( &
4556  & answer_shape(1), &
4557 
4558  & answer_shape(2), &
4559 
4560  & answer_shape(3), &
4561 
4562  & answer_shape(4), &
4563 
4564  & answer_shape(5), &
4565 
4566  & answer_shape(6) ) &
4567  & )
4568 
4569  allocate( judge( &
4570  & answer_shape(1), &
4571 
4572  & answer_shape(2), &
4573 
4574  & answer_shape(3), &
4575 
4576  & answer_shape(4), &
4577 
4578  & answer_shape(5), &
4579 
4580  & answer_shape(6) ) &
4581  & )
4582 
4583  allocate( judge_rev( &
4584  & answer_shape(1), &
4585 
4586  & answer_shape(2), &
4587 
4588  & answer_shape(3), &
4589 
4590  & answer_shape(4), &
4591 
4592  & answer_shape(5), &
4593 
4594  & answer_shape(6) ) &
4595  & )
4596 
4597 
4598  judge = answer == check
4599 
4600 
4601 
4602  judge_rev = .not. judge
4603  err_flag = any(judge_rev)
4604  mask_array = 1
4605  pos = maxloc(mask_array, judge_rev)
4606 
4607  if (err_flag) then
4608 
4609  wrong = check( &
4610  & pos(1), &
4611 
4612  & pos(2), &
4613 
4614  & pos(3), &
4615 
4616  & pos(4), &
4617 
4618  & pos(5), &
4619 
4620  & pos(6) )
4621 
4622  right = answer( &
4623  & pos(1), &
4624 
4625  & pos(2), &
4626 
4627  & pos(3), &
4628 
4629  & pos(4), &
4630 
4631  & pos(5), &
4632 
4633  & pos(6) )
4634 
4635  write(unit=pos_array(1), fmt="(i20)") pos(1)
4636 
4637  write(unit=pos_array(2), fmt="(i20)") pos(2)
4638 
4639  write(unit=pos_array(3), fmt="(i20)") pos(3)
4640 
4641  write(unit=pos_array(4), fmt="(i20)") pos(4)
4642 
4643  write(unit=pos_array(5), fmt="(i20)") pos(5)
4644 
4645  write(unit=pos_array(6), fmt="(i20)") pos(6)
4646 
4647 
4648  pos_str = '(' // &
4649  & trim(adjustl(pos_array(1))) // ',' // &
4650 
4651  & trim(adjustl(pos_array(2))) // ',' // &
4652 
4653  & trim(adjustl(pos_array(3))) // ',' // &
4654 
4655  & trim(adjustl(pos_array(4))) // ',' // &
4656 
4657  & trim(adjustl(pos_array(5))) // ',' // &
4658 
4659  & trim(adjustl(pos_array(6))) // ')'
4660 
4661  end if
4662  deallocate(mask_array, judge, judge_rev)
4663 
4664 
4665 
4666 
4667  if (err_flag) then
4668  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4669  write(*,*) ''
4670  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
4671  write(*,*) ' is NOT EQUAL to'
4672  write(*,*) ' answer' // trim(pos_str) // ' = ', right
4673 
4674  call abortprogram('')
4675  else
4676  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
4677  end if
4678 
4679 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ 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 
)
private

Definition at line 8526 of file dc_test.f90.

8526  use sysdep, only: abortprogram
8527  use dc_types, only: string, token
8528  implicit none
8529  character(*), intent(in):: message
8530  real(DP), intent(in):: answer(:,:,:,:,:,:)
8531  real(DP), intent(in):: check(:,:,:,:,:,:)
8532  integer, intent(in):: significant_digits
8533  integer, intent(in):: ignore_digits
8534  logical:: err_flag
8535  character(STRING):: pos_str
8536  real(DP):: wrong, right_max, right_min
8537  character(STRING):: pos_str_space
8538  integer:: pos_str_len
8539  real(DP):: right_tmp
8540 
8541  integer:: answer_shape(6), check_shape(6), pos(6)
8542  logical:: consist_shape(6)
8543  character(TOKEN):: pos_array(6)
8544  integer, allocatable:: mask_array(:,:,:,:,:,:)
8545  logical, allocatable:: judge(:,:,:,:,:,:)
8546  logical, allocatable:: judge_rev(:,:,:,:,:,:)
8547  logical, allocatable:: answer_negative(:,:,:,:,:,:)
8548  logical, allocatable:: check_negative(:,:,:,:,:,:)
8549  logical, allocatable:: both_negative(:,:,:,:,:,:)
8550  real(DP), allocatable:: answer_max(:,:,:,:,:,:)
8551  real(DP), allocatable:: answer_min(:,:,:,:,:,:)
8552 
8553  continue
8554  err_flag = .false.
8555 
8556  if ( significant_digits < 1 ) then
8557  write(*,*) ' *** Error [AssertEQ] *** '
8558  write(*,*) ' Specify a number more than 1 to "significant_digits"'
8559  call abortprogram('')
8560  end if
8561 
8562  answer_shape = shape(answer)
8563  check_shape = shape(check)
8564 
8565  consist_shape = answer_shape == check_shape
8566 
8567  if (.not. all(consist_shape)) then
8568  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8569  write(*,*) ''
8570  write(*,*) ' shape of check is (', check_shape, ')'
8571  write(*,*) ' is INCORRECT'
8572  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
8573 
8574  call abortprogram('')
8575  end if
8576 
8577 
8578  allocate( mask_array( &
8579  & answer_shape(1), &
8580 
8581  & answer_shape(2), &
8582 
8583  & answer_shape(3), &
8584 
8585  & answer_shape(4), &
8586 
8587  & answer_shape(5), &
8588 
8589  & answer_shape(6) ) &
8590  & )
8591 
8592  allocate( judge( &
8593  & answer_shape(1), &
8594 
8595  & answer_shape(2), &
8596 
8597  & answer_shape(3), &
8598 
8599  & answer_shape(4), &
8600 
8601  & answer_shape(5), &
8602 
8603  & answer_shape(6) ) &
8604  & )
8605 
8606  allocate( judge_rev( &
8607  & answer_shape(1), &
8608 
8609  & answer_shape(2), &
8610 
8611  & answer_shape(3), &
8612 
8613  & answer_shape(4), &
8614 
8615  & answer_shape(5), &
8616 
8617  & answer_shape(6) ) &
8618  & )
8619 
8620  allocate( answer_negative( &
8621  & answer_shape(1), &
8622 
8623  & answer_shape(2), &
8624 
8625  & answer_shape(3), &
8626 
8627  & answer_shape(4), &
8628 
8629  & answer_shape(5), &
8630 
8631  & answer_shape(6) ) &
8632  & )
8633 
8634  allocate( check_negative( &
8635  & answer_shape(1), &
8636 
8637  & answer_shape(2), &
8638 
8639  & answer_shape(3), &
8640 
8641  & answer_shape(4), &
8642 
8643  & answer_shape(5), &
8644 
8645  & answer_shape(6) ) &
8646  & )
8647 
8648  allocate( both_negative( &
8649  & answer_shape(1), &
8650 
8651  & answer_shape(2), &
8652 
8653  & answer_shape(3), &
8654 
8655  & answer_shape(4), &
8656 
8657  & answer_shape(5), &
8658 
8659  & answer_shape(6) ) &
8660  & )
8661 
8662  allocate( answer_max( &
8663  & answer_shape(1), &
8664 
8665  & answer_shape(2), &
8666 
8667  & answer_shape(3), &
8668 
8669  & answer_shape(4), &
8670 
8671  & answer_shape(5), &
8672 
8673  & answer_shape(6) ) &
8674  & )
8675 
8676  allocate( answer_min( &
8677  & answer_shape(1), &
8678 
8679  & answer_shape(2), &
8680 
8681  & answer_shape(3), &
8682 
8683  & answer_shape(4), &
8684 
8685  & answer_shape(5), &
8686 
8687  & answer_shape(6) ) &
8688  & )
8689 
8690  answer_negative = answer < 0.0_dp
8691  check_negative = check < 0.0_dp
8692  both_negative = answer_negative .and. check_negative
8693 
8694  where (both_negative)
8695  answer_max = &
8696  & answer &
8697  & * ( 1.0_dp &
8698  & - 0.1_dp ** significant_digits ) &
8699  & + 0.1_dp ** (- ignore_digits)
8700 
8701  answer_min = &
8702  & answer &
8703  & * ( 1.0_dp &
8704  & + 0.1_dp ** significant_digits ) &
8705  & - 0.1_dp ** (- ignore_digits)
8706  elsewhere
8707  answer_max = &
8708  & answer &
8709  & * ( 1.0_dp &
8710  & + 0.1_dp ** significant_digits ) &
8711  & + 0.1_dp ** (- ignore_digits)
8712 
8713  answer_min = &
8714  & answer &
8715  & * ( 1.0_dp &
8716  & - 0.1_dp ** significant_digits ) &
8717  & - 0.1_dp ** (- ignore_digits)
8718  end where
8719 
8720  judge = answer_max > check .and. check > answer_min
8721  judge_rev = .not. judge
8722  err_flag = any(judge_rev)
8723  mask_array = 1
8724  pos = maxloc(mask_array, judge_rev)
8725 
8726  if (err_flag) then
8727 
8728  wrong = check( &
8729  & pos(1), &
8730 
8731  & pos(2), &
8732 
8733  & pos(3), &
8734 
8735  & pos(4), &
8736 
8737  & pos(5), &
8738 
8739  & pos(6) )
8740 
8741  right_max = answer_max( &
8742  & pos(1), &
8743 
8744  & pos(2), &
8745 
8746  & pos(3), &
8747 
8748  & pos(4), &
8749 
8750  & pos(5), &
8751 
8752  & pos(6) )
8753 
8754  right_min = answer_min( &
8755  & pos(1), &
8756 
8757  & pos(2), &
8758 
8759  & pos(3), &
8760 
8761  & pos(4), &
8762 
8763  & pos(5), &
8764 
8765  & pos(6) )
8766 
8767  if ( right_max < right_min ) then
8768  right_tmp = right_max
8769  right_max = right_min
8770  right_min = right_tmp
8771  end if
8772 
8773  write(unit=pos_array(1), fmt="(i20)") pos(1)
8774 
8775  write(unit=pos_array(2), fmt="(i20)") pos(2)
8776 
8777  write(unit=pos_array(3), fmt="(i20)") pos(3)
8778 
8779  write(unit=pos_array(4), fmt="(i20)") pos(4)
8780 
8781  write(unit=pos_array(5), fmt="(i20)") pos(5)
8782 
8783  write(unit=pos_array(6), fmt="(i20)") pos(6)
8784 
8785 
8786  pos_str = '(' // &
8787  & trim(adjustl(pos_array(1))) // ',' // &
8788 
8789  & trim(adjustl(pos_array(2))) // ',' // &
8790 
8791  & trim(adjustl(pos_array(3))) // ',' // &
8792 
8793  & trim(adjustl(pos_array(4))) // ',' // &
8794 
8795  & trim(adjustl(pos_array(5))) // ',' // &
8796 
8797  & trim(adjustl(pos_array(6))) // ')'
8798 
8799  end if
8800  deallocate(mask_array, judge, judge_rev)
8801  deallocate(answer_negative, check_negative, both_negative)
8802  deallocate(answer_max, answer_min)
8803 
8804 
8805 
8806  if (err_flag) then
8807  pos_str_space = ''
8808  pos_str_len = len_trim(pos_str)
8809 
8810  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8811  write(*,*) ''
8812  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
8813  write(*,*) ' is NOT EQUAL to'
8814  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
8815  & // ' ', right_min, ' < '
8816  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
8817 
8818  call abortprogram('')
8819  else
8820  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
8821  end if
8822 
8823 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequaldouble7()

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

Definition at line 4684 of file dc_test.f90.

4684  use sysdep, only: abortprogram
4685  use dc_types, only: string, token
4686  implicit none
4687  character(*), intent(in):: message
4688  real(DP), intent(in):: answer(:,:,:,:,:,:,:)
4689  real(DP), intent(in):: check(:,:,:,:,:,:,:)
4690  logical:: err_flag
4691  character(STRING):: pos_str
4692  real(DP):: wrong, right
4693 
4694  integer:: answer_shape(7), check_shape(7), pos(7)
4695  logical:: consist_shape(7)
4696  character(TOKEN):: pos_array(7)
4697  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
4698  logical, allocatable:: judge(:,:,:,:,:,:,:)
4699  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
4700 
4701 
4702 
4703 
4704  continue
4705  err_flag = .false.
4706 
4707 
4708  answer_shape = shape(answer)
4709  check_shape = shape(check)
4710 
4711  consist_shape = answer_shape == check_shape
4712 
4713  if (.not. all(consist_shape)) then
4714  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4715  write(*,*) ''
4716  write(*,*) ' shape of check is (', check_shape, ')'
4717  write(*,*) ' is INCORRECT'
4718  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
4719 
4720  call abortprogram('')
4721  end if
4722 
4723 
4724  allocate( mask_array( &
4725  & answer_shape(1), &
4726 
4727  & answer_shape(2), &
4728 
4729  & answer_shape(3), &
4730 
4731  & answer_shape(4), &
4732 
4733  & answer_shape(5), &
4734 
4735  & answer_shape(6), &
4736 
4737  & answer_shape(7) ) &
4738  & )
4739 
4740  allocate( judge( &
4741  & answer_shape(1), &
4742 
4743  & answer_shape(2), &
4744 
4745  & answer_shape(3), &
4746 
4747  & answer_shape(4), &
4748 
4749  & answer_shape(5), &
4750 
4751  & answer_shape(6), &
4752 
4753  & answer_shape(7) ) &
4754  & )
4755 
4756  allocate( judge_rev( &
4757  & answer_shape(1), &
4758 
4759  & answer_shape(2), &
4760 
4761  & answer_shape(3), &
4762 
4763  & answer_shape(4), &
4764 
4765  & answer_shape(5), &
4766 
4767  & answer_shape(6), &
4768 
4769  & answer_shape(7) ) &
4770  & )
4771 
4772 
4773  judge = answer == check
4774 
4775 
4776 
4777  judge_rev = .not. judge
4778  err_flag = any(judge_rev)
4779  mask_array = 1
4780  pos = maxloc(mask_array, judge_rev)
4781 
4782  if (err_flag) then
4783 
4784  wrong = check( &
4785  & pos(1), &
4786 
4787  & pos(2), &
4788 
4789  & pos(3), &
4790 
4791  & pos(4), &
4792 
4793  & pos(5), &
4794 
4795  & pos(6), &
4796 
4797  & pos(7) )
4798 
4799  right = answer( &
4800  & pos(1), &
4801 
4802  & pos(2), &
4803 
4804  & pos(3), &
4805 
4806  & pos(4), &
4807 
4808  & pos(5), &
4809 
4810  & pos(6), &
4811 
4812  & pos(7) )
4813 
4814  write(unit=pos_array(1), fmt="(i20)") pos(1)
4815 
4816  write(unit=pos_array(2), fmt="(i20)") pos(2)
4817 
4818  write(unit=pos_array(3), fmt="(i20)") pos(3)
4819 
4820  write(unit=pos_array(4), fmt="(i20)") pos(4)
4821 
4822  write(unit=pos_array(5), fmt="(i20)") pos(5)
4823 
4824  write(unit=pos_array(6), fmt="(i20)") pos(6)
4825 
4826  write(unit=pos_array(7), fmt="(i20)") pos(7)
4827 
4828 
4829  pos_str = '(' // &
4830  & trim(adjustl(pos_array(1))) // ',' // &
4831 
4832  & trim(adjustl(pos_array(2))) // ',' // &
4833 
4834  & trim(adjustl(pos_array(3))) // ',' // &
4835 
4836  & trim(adjustl(pos_array(4))) // ',' // &
4837 
4838  & trim(adjustl(pos_array(5))) // ',' // &
4839 
4840  & trim(adjustl(pos_array(6))) // ',' // &
4841 
4842  & trim(adjustl(pos_array(7))) // ')'
4843 
4844  end if
4845  deallocate(mask_array, judge, judge_rev)
4846 
4847 
4848 
4849 
4850  if (err_flag) then
4851  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4852  write(*,*) ''
4853  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
4854  write(*,*) ' is NOT EQUAL to'
4855  write(*,*) ' answer' // trim(pos_str) // ' = ', right
4856 
4857  call abortprogram('')
4858  else
4859  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
4860  end if
4861 
4862 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ 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 
)
private

Definition at line 8829 of file dc_test.f90.

8829  use sysdep, only: abortprogram
8830  use dc_types, only: string, token
8831  implicit none
8832  character(*), intent(in):: message
8833  real(DP), intent(in):: answer(:,:,:,:,:,:,:)
8834  real(DP), intent(in):: check(:,:,:,:,:,:,:)
8835  integer, intent(in):: significant_digits
8836  integer, intent(in):: ignore_digits
8837  logical:: err_flag
8838  character(STRING):: pos_str
8839  real(DP):: wrong, right_max, right_min
8840  character(STRING):: pos_str_space
8841  integer:: pos_str_len
8842  real(DP):: right_tmp
8843 
8844  integer:: answer_shape(7), check_shape(7), pos(7)
8845  logical:: consist_shape(7)
8846  character(TOKEN):: pos_array(7)
8847  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
8848  logical, allocatable:: judge(:,:,:,:,:,:,:)
8849  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
8850  logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
8851  logical, allocatable:: check_negative(:,:,:,:,:,:,:)
8852  logical, allocatable:: both_negative(:,:,:,:,:,:,:)
8853  real(DP), allocatable:: answer_max(:,:,:,:,:,:,:)
8854  real(DP), allocatable:: answer_min(:,:,:,:,:,:,:)
8855 
8856  continue
8857  err_flag = .false.
8858 
8859  if ( significant_digits < 1 ) then
8860  write(*,*) ' *** Error [AssertEQ] *** '
8861  write(*,*) ' Specify a number more than 1 to "significant_digits"'
8862  call abortprogram('')
8863  end if
8864 
8865  answer_shape = shape(answer)
8866  check_shape = shape(check)
8867 
8868  consist_shape = answer_shape == check_shape
8869 
8870  if (.not. all(consist_shape)) then
8871  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8872  write(*,*) ''
8873  write(*,*) ' shape of check is (', check_shape, ')'
8874  write(*,*) ' is INCORRECT'
8875  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
8876 
8877  call abortprogram('')
8878  end if
8879 
8880 
8881  allocate( mask_array( &
8882  & answer_shape(1), &
8883 
8884  & answer_shape(2), &
8885 
8886  & answer_shape(3), &
8887 
8888  & answer_shape(4), &
8889 
8890  & answer_shape(5), &
8891 
8892  & answer_shape(6), &
8893 
8894  & answer_shape(7) ) &
8895  & )
8896 
8897  allocate( judge( &
8898  & answer_shape(1), &
8899 
8900  & answer_shape(2), &
8901 
8902  & answer_shape(3), &
8903 
8904  & answer_shape(4), &
8905 
8906  & answer_shape(5), &
8907 
8908  & answer_shape(6), &
8909 
8910  & answer_shape(7) ) &
8911  & )
8912 
8913  allocate( judge_rev( &
8914  & answer_shape(1), &
8915 
8916  & answer_shape(2), &
8917 
8918  & answer_shape(3), &
8919 
8920  & answer_shape(4), &
8921 
8922  & answer_shape(5), &
8923 
8924  & answer_shape(6), &
8925 
8926  & answer_shape(7) ) &
8927  & )
8928 
8929  allocate( answer_negative( &
8930  & answer_shape(1), &
8931 
8932  & answer_shape(2), &
8933 
8934  & answer_shape(3), &
8935 
8936  & answer_shape(4), &
8937 
8938  & answer_shape(5), &
8939 
8940  & answer_shape(6), &
8941 
8942  & answer_shape(7) ) &
8943  & )
8944 
8945  allocate( check_negative( &
8946  & answer_shape(1), &
8947 
8948  & answer_shape(2), &
8949 
8950  & answer_shape(3), &
8951 
8952  & answer_shape(4), &
8953 
8954  & answer_shape(5), &
8955 
8956  & answer_shape(6), &
8957 
8958  & answer_shape(7) ) &
8959  & )
8960 
8961  allocate( both_negative( &
8962  & answer_shape(1), &
8963 
8964  & answer_shape(2), &
8965 
8966  & answer_shape(3), &
8967 
8968  & answer_shape(4), &
8969 
8970  & answer_shape(5), &
8971 
8972  & answer_shape(6), &
8973 
8974  & answer_shape(7) ) &
8975  & )
8976 
8977  allocate( answer_max( &
8978  & answer_shape(1), &
8979 
8980  & answer_shape(2), &
8981 
8982  & answer_shape(3), &
8983 
8984  & answer_shape(4), &
8985 
8986  & answer_shape(5), &
8987 
8988  & answer_shape(6), &
8989 
8990  & answer_shape(7) ) &
8991  & )
8992 
8993  allocate( answer_min( &
8994  & answer_shape(1), &
8995 
8996  & answer_shape(2), &
8997 
8998  & answer_shape(3), &
8999 
9000  & answer_shape(4), &
9001 
9002  & answer_shape(5), &
9003 
9004  & answer_shape(6), &
9005 
9006  & answer_shape(7) ) &
9007  & )
9008 
9009  answer_negative = answer < 0.0_dp
9010  check_negative = check < 0.0_dp
9011  both_negative = answer_negative .and. check_negative
9012 
9013  where (both_negative)
9014  answer_max = &
9015  & answer &
9016  & * ( 1.0_dp &
9017  & - 0.1_dp ** significant_digits ) &
9018  & + 0.1_dp ** (- ignore_digits)
9019 
9020  answer_min = &
9021  & answer &
9022  & * ( 1.0_dp &
9023  & + 0.1_dp ** significant_digits ) &
9024  & - 0.1_dp ** (- ignore_digits)
9025  elsewhere
9026  answer_max = &
9027  & answer &
9028  & * ( 1.0_dp &
9029  & + 0.1_dp ** significant_digits ) &
9030  & + 0.1_dp ** (- ignore_digits)
9031 
9032  answer_min = &
9033  & answer &
9034  & * ( 1.0_dp &
9035  & - 0.1_dp ** significant_digits ) &
9036  & - 0.1_dp ** (- ignore_digits)
9037  end where
9038 
9039  judge = answer_max > check .and. check > answer_min
9040  judge_rev = .not. judge
9041  err_flag = any(judge_rev)
9042  mask_array = 1
9043  pos = maxloc(mask_array, judge_rev)
9044 
9045  if (err_flag) then
9046 
9047  wrong = check( &
9048  & pos(1), &
9049 
9050  & pos(2), &
9051 
9052  & pos(3), &
9053 
9054  & pos(4), &
9055 
9056  & pos(5), &
9057 
9058  & pos(6), &
9059 
9060  & pos(7) )
9061 
9062  right_max = answer_max( &
9063  & pos(1), &
9064 
9065  & pos(2), &
9066 
9067  & pos(3), &
9068 
9069  & pos(4), &
9070 
9071  & pos(5), &
9072 
9073  & pos(6), &
9074 
9075  & pos(7) )
9076 
9077  right_min = answer_min( &
9078  & pos(1), &
9079 
9080  & pos(2), &
9081 
9082  & pos(3), &
9083 
9084  & pos(4), &
9085 
9086  & pos(5), &
9087 
9088  & pos(6), &
9089 
9090  & pos(7) )
9091 
9092  if ( right_max < right_min ) then
9093  right_tmp = right_max
9094  right_max = right_min
9095  right_min = right_tmp
9096  end if
9097 
9098  write(unit=pos_array(1), fmt="(i20)") pos(1)
9099 
9100  write(unit=pos_array(2), fmt="(i20)") pos(2)
9101 
9102  write(unit=pos_array(3), fmt="(i20)") pos(3)
9103 
9104  write(unit=pos_array(4), fmt="(i20)") pos(4)
9105 
9106  write(unit=pos_array(5), fmt="(i20)") pos(5)
9107 
9108  write(unit=pos_array(6), fmt="(i20)") pos(6)
9109 
9110  write(unit=pos_array(7), fmt="(i20)") pos(7)
9111 
9112 
9113  pos_str = '(' // &
9114  & trim(adjustl(pos_array(1))) // ',' // &
9115 
9116  & trim(adjustl(pos_array(2))) // ',' // &
9117 
9118  & trim(adjustl(pos_array(3))) // ',' // &
9119 
9120  & trim(adjustl(pos_array(4))) // ',' // &
9121 
9122  & trim(adjustl(pos_array(5))) // ',' // &
9123 
9124  & trim(adjustl(pos_array(6))) // ',' // &
9125 
9126  & trim(adjustl(pos_array(7))) // ')'
9127 
9128  end if
9129  deallocate(mask_array, judge, judge_rev)
9130  deallocate(answer_negative, check_negative, both_negative)
9131  deallocate(answer_max, answer_min)
9132 
9133 
9134 
9135  if (err_flag) then
9136  pos_str_space = ''
9137  pos_str_len = len_trim(pos_str)
9138 
9139  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
9140  write(*,*) ''
9141  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
9142  write(*,*) ' is NOT EQUAL to'
9143  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
9144  & // ' ', right_min, ' < '
9145  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
9146 
9147  call abortprogram('')
9148  else
9149  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
9150  end if
9151 
9152 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequalint0()

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

Definition at line 1759 of file dc_test.f90.

1759  use sysdep, only: abortprogram
1760  use dc_types, only: string, token
1761  implicit none
1762  character(*), intent(in):: message
1763  integer, intent(in):: answer
1764  integer, intent(in):: check
1765  logical:: err_flag
1766  character(STRING):: pos_str
1767  integer:: wrong, right
1768 
1769 
1770 
1771 
1772 
1773  continue
1774  err_flag = .false.
1775 
1776 
1777  err_flag = .not. answer == check
1778  wrong = check
1779  right = answer
1780  pos_str = ''
1781 
1782 
1783 
1784 
1785  if (err_flag) then
1786  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1787  write(*,*) ''
1788  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
1789  write(*,*) ' is NOT EQUAL to'
1790  write(*,*) ' answer' // trim(pos_str) // ' = ', right
1791 
1792  call abortprogram('')
1793  else
1794  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
1795  end if
1796 
1797 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequalint1()

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

Definition at line 1802 of file dc_test.f90.

1802  use sysdep, only: abortprogram
1803  use dc_types, only: string, token
1804  implicit none
1805  character(*), intent(in):: message
1806  integer, intent(in):: answer(:)
1807  integer, intent(in):: check(:)
1808  logical:: err_flag
1809  character(STRING):: pos_str
1810  integer:: wrong, right
1811 
1812  integer:: answer_shape(1), check_shape(1), pos(1)
1813  logical:: consist_shape(1)
1814  character(TOKEN):: pos_array(1)
1815  integer, allocatable:: mask_array(:)
1816  logical, allocatable:: judge(:)
1817  logical, allocatable:: judge_rev(:)
1818 
1819 
1820 
1821 
1822  continue
1823  err_flag = .false.
1824 
1825 
1826  answer_shape = shape(answer)
1827  check_shape = shape(check)
1828 
1829  consist_shape = answer_shape == check_shape
1830 
1831  if (.not. all(consist_shape)) then
1832  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1833  write(*,*) ''
1834  write(*,*) ' shape of check is (', check_shape, ')'
1835  write(*,*) ' is INCORRECT'
1836  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
1837 
1838  call abortprogram('')
1839  end if
1840 
1841 
1842  allocate( mask_array( &
1843 
1844  & answer_shape(1) ) &
1845  & )
1846 
1847  allocate( judge( &
1848 
1849  & answer_shape(1) ) &
1850  & )
1851 
1852  allocate( judge_rev( &
1853 
1854  & answer_shape(1) ) &
1855  & )
1856 
1857 
1858  judge = answer == check
1859 
1860 
1861 
1862  judge_rev = .not. judge
1863  err_flag = any(judge_rev)
1864  mask_array = 1
1865  pos = maxloc(mask_array, judge_rev)
1866 
1867  if (err_flag) then
1868 
1869  wrong = check( &
1870 
1871  & pos(1) )
1872 
1873  right = answer( &
1874 
1875  & pos(1) )
1876 
1877  write(unit=pos_array(1), fmt="(i20)") pos(1)
1878 
1879 
1880  pos_str = '(' // &
1881 
1882  & trim(adjustl(pos_array(1))) // ')'
1883 
1884  end if
1885  deallocate(mask_array, judge, judge_rev)
1886 
1887 
1888 
1889 
1890  if (err_flag) then
1891  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1892  write(*,*) ''
1893  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
1894  write(*,*) ' is NOT EQUAL to'
1895  write(*,*) ' answer' // trim(pos_str) // ' = ', right
1896 
1897  call abortprogram('')
1898  else
1899  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
1900  end if
1901 
1902 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequalint2()

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

Definition at line 1907 of file dc_test.f90.

1907  use sysdep, only: abortprogram
1908  use dc_types, only: string, token
1909  implicit none
1910  character(*), intent(in):: message
1911  integer, intent(in):: answer(:,:)
1912  integer, intent(in):: check(:,:)
1913  logical:: err_flag
1914  character(STRING):: pos_str
1915  integer:: wrong, right
1916 
1917  integer:: answer_shape(2), check_shape(2), pos(2)
1918  logical:: consist_shape(2)
1919  character(TOKEN):: pos_array(2)
1920  integer, allocatable:: mask_array(:,:)
1921  logical, allocatable:: judge(:,:)
1922  logical, allocatable:: judge_rev(:,:)
1923 
1924 
1925 
1926 
1927  continue
1928  err_flag = .false.
1929 
1930 
1931  answer_shape = shape(answer)
1932  check_shape = shape(check)
1933 
1934  consist_shape = answer_shape == check_shape
1935 
1936  if (.not. all(consist_shape)) then
1937  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1938  write(*,*) ''
1939  write(*,*) ' shape of check is (', check_shape, ')'
1940  write(*,*) ' is INCORRECT'
1941  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
1942 
1943  call abortprogram('')
1944  end if
1945 
1946 
1947  allocate( mask_array( &
1948  & answer_shape(1), &
1949 
1950  & answer_shape(2) ) &
1951  & )
1952 
1953  allocate( judge( &
1954  & answer_shape(1), &
1955 
1956  & answer_shape(2) ) &
1957  & )
1958 
1959  allocate( judge_rev( &
1960  & answer_shape(1), &
1961 
1962  & answer_shape(2) ) &
1963  & )
1964 
1965 
1966  judge = answer == check
1967 
1968 
1969 
1970  judge_rev = .not. judge
1971  err_flag = any(judge_rev)
1972  mask_array = 1
1973  pos = maxloc(mask_array, judge_rev)
1974 
1975  if (err_flag) then
1976 
1977  wrong = check( &
1978  & pos(1), &
1979 
1980  & pos(2) )
1981 
1982  right = answer( &
1983  & pos(1), &
1984 
1985  & pos(2) )
1986 
1987  write(unit=pos_array(1), fmt="(i20)") pos(1)
1988 
1989  write(unit=pos_array(2), fmt="(i20)") pos(2)
1990 
1991 
1992  pos_str = '(' // &
1993  & trim(adjustl(pos_array(1))) // ',' // &
1994 
1995  & trim(adjustl(pos_array(2))) // ')'
1996 
1997  end if
1998  deallocate(mask_array, judge, judge_rev)
1999 
2000 
2001 
2002 
2003  if (err_flag) then
2004  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2005  write(*,*) ''
2006  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2007  write(*,*) ' is NOT EQUAL to'
2008  write(*,*) ' answer' // trim(pos_str) // ' = ', right
2009 
2010  call abortprogram('')
2011  else
2012  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2013  end if
2014 
2015 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequalint3()

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

Definition at line 2020 of file dc_test.f90.

2020  use sysdep, only: abortprogram
2021  use dc_types, only: string, token
2022  implicit none
2023  character(*), intent(in):: message
2024  integer, intent(in):: answer(:,:,:)
2025  integer, intent(in):: check(:,:,:)
2026  logical:: err_flag
2027  character(STRING):: pos_str
2028  integer:: wrong, right
2029 
2030  integer:: answer_shape(3), check_shape(3), pos(3)
2031  logical:: consist_shape(3)
2032  character(TOKEN):: pos_array(3)
2033  integer, allocatable:: mask_array(:,:,:)
2034  logical, allocatable:: judge(:,:,:)
2035  logical, allocatable:: judge_rev(:,:,:)
2036 
2037 
2038 
2039 
2040  continue
2041  err_flag = .false.
2042 
2043 
2044  answer_shape = shape(answer)
2045  check_shape = shape(check)
2046 
2047  consist_shape = answer_shape == check_shape
2048 
2049  if (.not. all(consist_shape)) then
2050  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2051  write(*,*) ''
2052  write(*,*) ' shape of check is (', check_shape, ')'
2053  write(*,*) ' is INCORRECT'
2054  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2055 
2056  call abortprogram('')
2057  end if
2058 
2059 
2060  allocate( mask_array( &
2061  & answer_shape(1), &
2062 
2063  & answer_shape(2), &
2064 
2065  & answer_shape(3) ) &
2066  & )
2067 
2068  allocate( judge( &
2069  & answer_shape(1), &
2070 
2071  & answer_shape(2), &
2072 
2073  & answer_shape(3) ) &
2074  & )
2075 
2076  allocate( judge_rev( &
2077  & answer_shape(1), &
2078 
2079  & answer_shape(2), &
2080 
2081  & answer_shape(3) ) &
2082  & )
2083 
2084 
2085  judge = answer == check
2086 
2087 
2088 
2089  judge_rev = .not. judge
2090  err_flag = any(judge_rev)
2091  mask_array = 1
2092  pos = maxloc(mask_array, judge_rev)
2093 
2094  if (err_flag) then
2095 
2096  wrong = check( &
2097  & pos(1), &
2098 
2099  & pos(2), &
2100 
2101  & pos(3) )
2102 
2103  right = answer( &
2104  & pos(1), &
2105 
2106  & pos(2), &
2107 
2108  & pos(3) )
2109 
2110  write(unit=pos_array(1), fmt="(i20)") pos(1)
2111 
2112  write(unit=pos_array(2), fmt="(i20)") pos(2)
2113 
2114  write(unit=pos_array(3), fmt="(i20)") pos(3)
2115 
2116 
2117  pos_str = '(' // &
2118  & trim(adjustl(pos_array(1))) // ',' // &
2119 
2120  & trim(adjustl(pos_array(2))) // ',' // &
2121 
2122  & trim(adjustl(pos_array(3))) // ')'
2123 
2124  end if
2125  deallocate(mask_array, judge, judge_rev)
2126 
2127 
2128 
2129 
2130  if (err_flag) then
2131  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2132  write(*,*) ''
2133  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2134  write(*,*) ' is NOT EQUAL to'
2135  write(*,*) ' answer' // trim(pos_str) // ' = ', right
2136 
2137  call abortprogram('')
2138  else
2139  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2140  end if
2141 
2142 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequalint4()

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

Definition at line 2147 of file dc_test.f90.

2147  use sysdep, only: abortprogram
2148  use dc_types, only: string, token
2149  implicit none
2150  character(*), intent(in):: message
2151  integer, intent(in):: answer(:,:,:,:)
2152  integer, intent(in):: check(:,:,:,:)
2153  logical:: err_flag
2154  character(STRING):: pos_str
2155  integer:: wrong, right
2156 
2157  integer:: answer_shape(4), check_shape(4), pos(4)
2158  logical:: consist_shape(4)
2159  character(TOKEN):: pos_array(4)
2160  integer, allocatable:: mask_array(:,:,:,:)
2161  logical, allocatable:: judge(:,:,:,:)
2162  logical, allocatable:: judge_rev(:,:,:,:)
2163 
2164 
2165 
2166 
2167  continue
2168  err_flag = .false.
2169 
2170 
2171  answer_shape = shape(answer)
2172  check_shape = shape(check)
2173 
2174  consist_shape = answer_shape == check_shape
2175 
2176  if (.not. all(consist_shape)) then
2177  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2178  write(*,*) ''
2179  write(*,*) ' shape of check is (', check_shape, ')'
2180  write(*,*) ' is INCORRECT'
2181  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2182 
2183  call abortprogram('')
2184  end if
2185 
2186 
2187  allocate( mask_array( &
2188  & answer_shape(1), &
2189 
2190  & answer_shape(2), &
2191 
2192  & answer_shape(3), &
2193 
2194  & answer_shape(4) ) &
2195  & )
2196 
2197  allocate( judge( &
2198  & answer_shape(1), &
2199 
2200  & answer_shape(2), &
2201 
2202  & answer_shape(3), &
2203 
2204  & answer_shape(4) ) &
2205  & )
2206 
2207  allocate( judge_rev( &
2208  & answer_shape(1), &
2209 
2210  & answer_shape(2), &
2211 
2212  & answer_shape(3), &
2213 
2214  & answer_shape(4) ) &
2215  & )
2216 
2217 
2218  judge = answer == check
2219 
2220 
2221 
2222  judge_rev = .not. judge
2223  err_flag = any(judge_rev)
2224  mask_array = 1
2225  pos = maxloc(mask_array, judge_rev)
2226 
2227  if (err_flag) then
2228 
2229  wrong = check( &
2230  & pos(1), &
2231 
2232  & pos(2), &
2233 
2234  & pos(3), &
2235 
2236  & pos(4) )
2237 
2238  right = answer( &
2239  & pos(1), &
2240 
2241  & pos(2), &
2242 
2243  & pos(3), &
2244 
2245  & pos(4) )
2246 
2247  write(unit=pos_array(1), fmt="(i20)") pos(1)
2248 
2249  write(unit=pos_array(2), fmt="(i20)") pos(2)
2250 
2251  write(unit=pos_array(3), fmt="(i20)") pos(3)
2252 
2253  write(unit=pos_array(4), fmt="(i20)") pos(4)
2254 
2255 
2256  pos_str = '(' // &
2257  & trim(adjustl(pos_array(1))) // ',' // &
2258 
2259  & trim(adjustl(pos_array(2))) // ',' // &
2260 
2261  & trim(adjustl(pos_array(3))) // ',' // &
2262 
2263  & trim(adjustl(pos_array(4))) // ')'
2264 
2265  end if
2266  deallocate(mask_array, judge, judge_rev)
2267 
2268 
2269 
2270 
2271  if (err_flag) then
2272  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2273  write(*,*) ''
2274  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2275  write(*,*) ' is NOT EQUAL to'
2276  write(*,*) ' answer' // trim(pos_str) // ' = ', right
2277 
2278  call abortprogram('')
2279  else
2280  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2281  end if
2282 
2283 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequalint5()

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

Definition at line 2288 of file dc_test.f90.

2288  use sysdep, only: abortprogram
2289  use dc_types, only: string, token
2290  implicit none
2291  character(*), intent(in):: message
2292  integer, intent(in):: answer(:,:,:,:,:)
2293  integer, intent(in):: check(:,:,:,:,:)
2294  logical:: err_flag
2295  character(STRING):: pos_str
2296  integer:: wrong, right
2297 
2298  integer:: answer_shape(5), check_shape(5), pos(5)
2299  logical:: consist_shape(5)
2300  character(TOKEN):: pos_array(5)
2301  integer, allocatable:: mask_array(:,:,:,:,:)
2302  logical, allocatable:: judge(:,:,:,:,:)
2303  logical, allocatable:: judge_rev(:,:,:,:,:)
2304 
2305 
2306 
2307 
2308  continue
2309  err_flag = .false.
2310 
2311 
2312  answer_shape = shape(answer)
2313  check_shape = shape(check)
2314 
2315  consist_shape = answer_shape == check_shape
2316 
2317  if (.not. all(consist_shape)) then
2318  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2319  write(*,*) ''
2320  write(*,*) ' shape of check is (', check_shape, ')'
2321  write(*,*) ' is INCORRECT'
2322  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2323 
2324  call abortprogram('')
2325  end if
2326 
2327 
2328  allocate( mask_array( &
2329  & answer_shape(1), &
2330 
2331  & answer_shape(2), &
2332 
2333  & answer_shape(3), &
2334 
2335  & answer_shape(4), &
2336 
2337  & answer_shape(5) ) &
2338  & )
2339 
2340  allocate( judge( &
2341  & answer_shape(1), &
2342 
2343  & answer_shape(2), &
2344 
2345  & answer_shape(3), &
2346 
2347  & answer_shape(4), &
2348 
2349  & answer_shape(5) ) &
2350  & )
2351 
2352  allocate( judge_rev( &
2353  & answer_shape(1), &
2354 
2355  & answer_shape(2), &
2356 
2357  & answer_shape(3), &
2358 
2359  & answer_shape(4), &
2360 
2361  & answer_shape(5) ) &
2362  & )
2363 
2364 
2365  judge = answer == check
2366 
2367 
2368 
2369  judge_rev = .not. judge
2370  err_flag = any(judge_rev)
2371  mask_array = 1
2372  pos = maxloc(mask_array, judge_rev)
2373 
2374  if (err_flag) then
2375 
2376  wrong = check( &
2377  & pos(1), &
2378 
2379  & pos(2), &
2380 
2381  & pos(3), &
2382 
2383  & pos(4), &
2384 
2385  & pos(5) )
2386 
2387  right = answer( &
2388  & pos(1), &
2389 
2390  & pos(2), &
2391 
2392  & pos(3), &
2393 
2394  & pos(4), &
2395 
2396  & pos(5) )
2397 
2398  write(unit=pos_array(1), fmt="(i20)") pos(1)
2399 
2400  write(unit=pos_array(2), fmt="(i20)") pos(2)
2401 
2402  write(unit=pos_array(3), fmt="(i20)") pos(3)
2403 
2404  write(unit=pos_array(4), fmt="(i20)") pos(4)
2405 
2406  write(unit=pos_array(5), fmt="(i20)") pos(5)
2407 
2408 
2409  pos_str = '(' // &
2410  & trim(adjustl(pos_array(1))) // ',' // &
2411 
2412  & trim(adjustl(pos_array(2))) // ',' // &
2413 
2414  & trim(adjustl(pos_array(3))) // ',' // &
2415 
2416  & trim(adjustl(pos_array(4))) // ',' // &
2417 
2418  & trim(adjustl(pos_array(5))) // ')'
2419 
2420  end if
2421  deallocate(mask_array, judge, judge_rev)
2422 
2423 
2424 
2425 
2426  if (err_flag) then
2427  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2428  write(*,*) ''
2429  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2430  write(*,*) ' is NOT EQUAL to'
2431  write(*,*) ' answer' // trim(pos_str) // ' = ', right
2432 
2433  call abortprogram('')
2434  else
2435  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2436  end if
2437 
2438 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequalint6()

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

Definition at line 2443 of file dc_test.f90.

2443  use sysdep, only: abortprogram
2444  use dc_types, only: string, token
2445  implicit none
2446  character(*), intent(in):: message
2447  integer, intent(in):: answer(:,:,:,:,:,:)
2448  integer, intent(in):: check(:,:,:,:,:,:)
2449  logical:: err_flag
2450  character(STRING):: pos_str
2451  integer:: wrong, right
2452 
2453  integer:: answer_shape(6), check_shape(6), pos(6)
2454  logical:: consist_shape(6)
2455  character(TOKEN):: pos_array(6)
2456  integer, allocatable:: mask_array(:,:,:,:,:,:)
2457  logical, allocatable:: judge(:,:,:,:,:,:)
2458  logical, allocatable:: judge_rev(:,:,:,:,:,:)
2459 
2460 
2461 
2462 
2463  continue
2464  err_flag = .false.
2465 
2466 
2467  answer_shape = shape(answer)
2468  check_shape = shape(check)
2469 
2470  consist_shape = answer_shape == check_shape
2471 
2472  if (.not. all(consist_shape)) then
2473  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2474  write(*,*) ''
2475  write(*,*) ' shape of check is (', check_shape, ')'
2476  write(*,*) ' is INCORRECT'
2477  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2478 
2479  call abortprogram('')
2480  end if
2481 
2482 
2483  allocate( mask_array( &
2484  & answer_shape(1), &
2485 
2486  & answer_shape(2), &
2487 
2488  & answer_shape(3), &
2489 
2490  & answer_shape(4), &
2491 
2492  & answer_shape(5), &
2493 
2494  & answer_shape(6) ) &
2495  & )
2496 
2497  allocate( judge( &
2498  & answer_shape(1), &
2499 
2500  & answer_shape(2), &
2501 
2502  & answer_shape(3), &
2503 
2504  & answer_shape(4), &
2505 
2506  & answer_shape(5), &
2507 
2508  & answer_shape(6) ) &
2509  & )
2510 
2511  allocate( judge_rev( &
2512  & answer_shape(1), &
2513 
2514  & answer_shape(2), &
2515 
2516  & answer_shape(3), &
2517 
2518  & answer_shape(4), &
2519 
2520  & answer_shape(5), &
2521 
2522  & answer_shape(6) ) &
2523  & )
2524 
2525 
2526  judge = answer == check
2527 
2528 
2529 
2530  judge_rev = .not. judge
2531  err_flag = any(judge_rev)
2532  mask_array = 1
2533  pos = maxloc(mask_array, judge_rev)
2534 
2535  if (err_flag) then
2536 
2537  wrong = check( &
2538  & pos(1), &
2539 
2540  & pos(2), &
2541 
2542  & pos(3), &
2543 
2544  & pos(4), &
2545 
2546  & pos(5), &
2547 
2548  & pos(6) )
2549 
2550  right = answer( &
2551  & pos(1), &
2552 
2553  & pos(2), &
2554 
2555  & pos(3), &
2556 
2557  & pos(4), &
2558 
2559  & pos(5), &
2560 
2561  & pos(6) )
2562 
2563  write(unit=pos_array(1), fmt="(i20)") pos(1)
2564 
2565  write(unit=pos_array(2), fmt="(i20)") pos(2)
2566 
2567  write(unit=pos_array(3), fmt="(i20)") pos(3)
2568 
2569  write(unit=pos_array(4), fmt="(i20)") pos(4)
2570 
2571  write(unit=pos_array(5), fmt="(i20)") pos(5)
2572 
2573  write(unit=pos_array(6), fmt="(i20)") pos(6)
2574 
2575 
2576  pos_str = '(' // &
2577  & trim(adjustl(pos_array(1))) // ',' // &
2578 
2579  & trim(adjustl(pos_array(2))) // ',' // &
2580 
2581  & trim(adjustl(pos_array(3))) // ',' // &
2582 
2583  & trim(adjustl(pos_array(4))) // ',' // &
2584 
2585  & trim(adjustl(pos_array(5))) // ',' // &
2586 
2587  & trim(adjustl(pos_array(6))) // ')'
2588 
2589  end if
2590  deallocate(mask_array, judge, judge_rev)
2591 
2592 
2593 
2594 
2595  if (err_flag) then
2596  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2597  write(*,*) ''
2598  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2599  write(*,*) ' is NOT EQUAL to'
2600  write(*,*) ' answer' // trim(pos_str) // ' = ', right
2601 
2602  call abortprogram('')
2603  else
2604  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2605  end if
2606 
2607 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequalint7()

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

Definition at line 2612 of file dc_test.f90.

2612  use sysdep, only: abortprogram
2613  use dc_types, only: string, token
2614  implicit none
2615  character(*), intent(in):: message
2616  integer, intent(in):: answer(:,:,:,:,:,:,:)
2617  integer, intent(in):: check(:,:,:,:,:,:,:)
2618  logical:: err_flag
2619  character(STRING):: pos_str
2620  integer:: wrong, right
2621 
2622  integer:: answer_shape(7), check_shape(7), pos(7)
2623  logical:: consist_shape(7)
2624  character(TOKEN):: pos_array(7)
2625  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
2626  logical, allocatable:: judge(:,:,:,:,:,:,:)
2627  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
2628 
2629 
2630 
2631 
2632  continue
2633  err_flag = .false.
2634 
2635 
2636  answer_shape = shape(answer)
2637  check_shape = shape(check)
2638 
2639  consist_shape = answer_shape == check_shape
2640 
2641  if (.not. all(consist_shape)) then
2642  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2643  write(*,*) ''
2644  write(*,*) ' shape of check is (', check_shape, ')'
2645  write(*,*) ' is INCORRECT'
2646  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2647 
2648  call abortprogram('')
2649  end if
2650 
2651 
2652  allocate( mask_array( &
2653  & answer_shape(1), &
2654 
2655  & answer_shape(2), &
2656 
2657  & answer_shape(3), &
2658 
2659  & answer_shape(4), &
2660 
2661  & answer_shape(5), &
2662 
2663  & answer_shape(6), &
2664 
2665  & answer_shape(7) ) &
2666  & )
2667 
2668  allocate( judge( &
2669  & answer_shape(1), &
2670 
2671  & answer_shape(2), &
2672 
2673  & answer_shape(3), &
2674 
2675  & answer_shape(4), &
2676 
2677  & answer_shape(5), &
2678 
2679  & answer_shape(6), &
2680 
2681  & answer_shape(7) ) &
2682  & )
2683 
2684  allocate( judge_rev( &
2685  & answer_shape(1), &
2686 
2687  & answer_shape(2), &
2688 
2689  & answer_shape(3), &
2690 
2691  & answer_shape(4), &
2692 
2693  & answer_shape(5), &
2694 
2695  & answer_shape(6), &
2696 
2697  & answer_shape(7) ) &
2698  & )
2699 
2700 
2701  judge = answer == check
2702 
2703 
2704 
2705  judge_rev = .not. judge
2706  err_flag = any(judge_rev)
2707  mask_array = 1
2708  pos = maxloc(mask_array, judge_rev)
2709 
2710  if (err_flag) then
2711 
2712  wrong = check( &
2713  & pos(1), &
2714 
2715  & pos(2), &
2716 
2717  & pos(3), &
2718 
2719  & pos(4), &
2720 
2721  & pos(5), &
2722 
2723  & pos(6), &
2724 
2725  & pos(7) )
2726 
2727  right = answer( &
2728  & pos(1), &
2729 
2730  & pos(2), &
2731 
2732  & pos(3), &
2733 
2734  & pos(4), &
2735 
2736  & pos(5), &
2737 
2738  & pos(6), &
2739 
2740  & pos(7) )
2741 
2742  write(unit=pos_array(1), fmt="(i20)") pos(1)
2743 
2744  write(unit=pos_array(2), fmt="(i20)") pos(2)
2745 
2746  write(unit=pos_array(3), fmt="(i20)") pos(3)
2747 
2748  write(unit=pos_array(4), fmt="(i20)") pos(4)
2749 
2750  write(unit=pos_array(5), fmt="(i20)") pos(5)
2751 
2752  write(unit=pos_array(6), fmt="(i20)") pos(6)
2753 
2754  write(unit=pos_array(7), fmt="(i20)") pos(7)
2755 
2756 
2757  pos_str = '(' // &
2758  & trim(adjustl(pos_array(1))) // ',' // &
2759 
2760  & trim(adjustl(pos_array(2))) // ',' // &
2761 
2762  & trim(adjustl(pos_array(3))) // ',' // &
2763 
2764  & trim(adjustl(pos_array(4))) // ',' // &
2765 
2766  & trim(adjustl(pos_array(5))) // ',' // &
2767 
2768  & trim(adjustl(pos_array(6))) // ',' // &
2769 
2770  & trim(adjustl(pos_array(7))) // ')'
2771 
2772  end if
2773  deallocate(mask_array, judge, judge_rev)
2774 
2775 
2776 
2777 
2778  if (err_flag) then
2779  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2780  write(*,*) ''
2781  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2782  write(*,*) ' is NOT EQUAL to'
2783  write(*,*) ' answer' // trim(pos_str) // ' = ', right
2784 
2785  call abortprogram('')
2786  else
2787  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2788  end if
2789 
2790 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequallogical0()

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

Definition at line 4866 of file dc_test.f90.

4866  use dc_types, only: string
4867  implicit none
4868  character(*), intent(in):: message
4869  logical, intent(in):: answer
4870  logical, intent(in):: check
4871 
4872  character(STRING):: answer_str
4873  character(STRING):: check_str
4874 
4875 
4876 
4877  continue
4878 
4879 
4880  if (answer) then
4881  answer_str = ".true."
4882  else
4883  answer_str = ".false."
4884  end if
4885 
4886  if (check) then
4887  check_str = ".true."
4888  else
4889  check_str = ".false."
4890  end if
4891 
4892 
4893 
4894  call dctestassertequalchar0(message, answer_str, check_str)
4895 
4896 
4897 
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequallogical1()

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

Definition at line 4900 of file dc_test.f90.

4900  use dc_types, only: string
4901  implicit none
4902  character(*), intent(in):: message
4903  logical, intent(in):: answer(:)
4904  logical, intent(in):: check(:)
4905 
4906  integer:: answer_shape(1), check_shape(1), i
4907  logical, allocatable:: answer_tmp(:), check_tmp(:)
4908  character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
4909  character(STRING), allocatable:: answer_str(:)
4910  character(STRING), allocatable:: check_str(:)
4911 
4912 
4913 
4914  continue
4915 
4916 
4917  allocate(answer_tmp(size(answer)))
4918  allocate(check_tmp(size(check)))
4919  allocate(answer_str_tmp(size(answer)))
4920  allocate(check_str_tmp(size(check)))
4921  answer_tmp = pack(answer, .true.)
4922  check_tmp = pack(check, .true.)
4923 
4924  do i = 1, size(answer_tmp)
4925  if (answer_tmp(i)) then
4926  answer_str_tmp(i) = '.true.'
4927  else
4928  answer_str_tmp(i) = '.false.'
4929  end if
4930  end do
4931 
4932  do i = 1, size(check_tmp)
4933  if (check_tmp(i)) then
4934  check_str_tmp(i) = '.true.'
4935  else
4936  check_str_tmp(i) = '.false.'
4937  end if
4938  end do
4939 
4940  answer_shape = shape(answer)
4941  check_shape = shape(check)
4942 
4943  allocate( answer_str( &
4944 
4945  & answer_shape(1) ) &
4946  & )
4947 
4948  allocate( check_str( &
4949 
4950  & check_shape(1) ) &
4951  & )
4952 
4953  answer_str = reshape(answer_str_tmp, answer_shape)
4954  check_str = reshape(check_str_tmp, check_shape)
4955 
4956 
4957 
4958  call dctestassertequalchar1(message, answer_str, check_str)
4959 
4960  deallocate(answer_str, answer_tmp, answer_str_tmp)
4961  deallocate(check_str, check_tmp, check_str_tmp)
4962 
4963 
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequallogical2()

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

Definition at line 4966 of file dc_test.f90.

4966  use dc_types, only: string
4967  implicit none
4968  character(*), intent(in):: message
4969  logical, intent(in):: answer(:,:)
4970  logical, intent(in):: check(:,:)
4971 
4972  integer:: answer_shape(2), check_shape(2), i
4973  logical, allocatable:: answer_tmp(:), check_tmp(:)
4974  character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
4975  character(STRING), allocatable:: answer_str(:,:)
4976  character(STRING), allocatable:: check_str(:,:)
4977 
4978 
4979 
4980  continue
4981 
4982 
4983  allocate(answer_tmp(size(answer)))
4984  allocate(check_tmp(size(check)))
4985  allocate(answer_str_tmp(size(answer)))
4986  allocate(check_str_tmp(size(check)))
4987  answer_tmp = pack(answer, .true.)
4988  check_tmp = pack(check, .true.)
4989 
4990  do i = 1, size(answer_tmp)
4991  if (answer_tmp(i)) then
4992  answer_str_tmp(i) = '.true.'
4993  else
4994  answer_str_tmp(i) = '.false.'
4995  end if
4996  end do
4997 
4998  do i = 1, size(check_tmp)
4999  if (check_tmp(i)) then
5000  check_str_tmp(i) = '.true.'
5001  else
5002  check_str_tmp(i) = '.false.'
5003  end if
5004  end do
5005 
5006  answer_shape = shape(answer)
5007  check_shape = shape(check)
5008 
5009  allocate( answer_str( &
5010  & answer_shape(1), &
5011 
5012  & answer_shape(2) ) &
5013  & )
5014 
5015  allocate( check_str( &
5016  & check_shape(1), &
5017 
5018  & check_shape(2) ) &
5019  & )
5020 
5021  answer_str = reshape(answer_str_tmp, answer_shape)
5022  check_str = reshape(check_str_tmp, check_shape)
5023 
5024 
5025 
5026  call dctestassertequalchar2(message, answer_str, check_str)
5027 
5028  deallocate(answer_str, answer_tmp, answer_str_tmp)
5029  deallocate(check_str, check_tmp, check_str_tmp)
5030 
5031 
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequallogical3()

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

Definition at line 5034 of file dc_test.f90.

5034  use dc_types, only: string
5035  implicit none
5036  character(*), intent(in):: message
5037  logical, intent(in):: answer(:,:,:)
5038  logical, intent(in):: check(:,:,:)
5039 
5040  integer:: answer_shape(3), check_shape(3), i
5041  logical, allocatable:: answer_tmp(:), check_tmp(:)
5042  character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
5043  character(STRING), allocatable:: answer_str(:,:,:)
5044  character(STRING), allocatable:: check_str(:,:,:)
5045 
5046 
5047 
5048  continue
5049 
5050 
5051  allocate(answer_tmp(size(answer)))
5052  allocate(check_tmp(size(check)))
5053  allocate(answer_str_tmp(size(answer)))
5054  allocate(check_str_tmp(size(check)))
5055  answer_tmp = pack(answer, .true.)
5056  check_tmp = pack(check, .true.)
5057 
5058  do i = 1, size(answer_tmp)
5059  if (answer_tmp(i)) then
5060  answer_str_tmp(i) = '.true.'
5061  else
5062  answer_str_tmp(i) = '.false.'
5063  end if
5064  end do
5065 
5066  do i = 1, size(check_tmp)
5067  if (check_tmp(i)) then
5068  check_str_tmp(i) = '.true.'
5069  else
5070  check_str_tmp(i) = '.false.'
5071  end if
5072  end do
5073 
5074  answer_shape = shape(answer)
5075  check_shape = shape(check)
5076 
5077  allocate( answer_str( &
5078  & answer_shape(1), &
5079 
5080  & answer_shape(2), &
5081 
5082  & answer_shape(3) ) &
5083  & )
5084 
5085  allocate( check_str( &
5086  & check_shape(1), &
5087 
5088  & check_shape(2), &
5089 
5090  & check_shape(3) ) &
5091  & )
5092 
5093  answer_str = reshape(answer_str_tmp, answer_shape)
5094  check_str = reshape(check_str_tmp, check_shape)
5095 
5096 
5097 
5098  call dctestassertequalchar3(message, answer_str, check_str)
5099 
5100  deallocate(answer_str, answer_tmp, answer_str_tmp)
5101  deallocate(check_str, check_tmp, check_str_tmp)
5102 
5103 
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequallogical4()

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

Definition at line 5106 of file dc_test.f90.

5106  use dc_types, only: string
5107  implicit none
5108  character(*), intent(in):: message
5109  logical, intent(in):: answer(:,:,:,:)
5110  logical, intent(in):: check(:,:,:,:)
5111 
5112  integer:: answer_shape(4), check_shape(4), i
5113  logical, allocatable:: answer_tmp(:), check_tmp(:)
5114  character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
5115  character(STRING), allocatable:: answer_str(:,:,:,:)
5116  character(STRING), allocatable:: check_str(:,:,:,:)
5117 
5118 
5119 
5120  continue
5121 
5122 
5123  allocate(answer_tmp(size(answer)))
5124  allocate(check_tmp(size(check)))
5125  allocate(answer_str_tmp(size(answer)))
5126  allocate(check_str_tmp(size(check)))
5127  answer_tmp = pack(answer, .true.)
5128  check_tmp = pack(check, .true.)
5129 
5130  do i = 1, size(answer_tmp)
5131  if (answer_tmp(i)) then
5132  answer_str_tmp(i) = '.true.'
5133  else
5134  answer_str_tmp(i) = '.false.'
5135  end if
5136  end do
5137 
5138  do i = 1, size(check_tmp)
5139  if (check_tmp(i)) then
5140  check_str_tmp(i) = '.true.'
5141  else
5142  check_str_tmp(i) = '.false.'
5143  end if
5144  end do
5145 
5146  answer_shape = shape(answer)
5147  check_shape = shape(check)
5148 
5149  allocate( answer_str( &
5150  & answer_shape(1), &
5151 
5152  & answer_shape(2), &
5153 
5154  & answer_shape(3), &
5155 
5156  & answer_shape(4) ) &
5157  & )
5158 
5159  allocate( check_str( &
5160  & check_shape(1), &
5161 
5162  & check_shape(2), &
5163 
5164  & check_shape(3), &
5165 
5166  & check_shape(4) ) &
5167  & )
5168 
5169  answer_str = reshape(answer_str_tmp, answer_shape)
5170  check_str = reshape(check_str_tmp, check_shape)
5171 
5172 
5173 
5174  call dctestassertequalchar4(message, answer_str, check_str)
5175 
5176  deallocate(answer_str, answer_tmp, answer_str_tmp)
5177  deallocate(check_str, check_tmp, check_str_tmp)
5178 
5179 
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequallogical5()

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

Definition at line 5182 of file dc_test.f90.

5182  use dc_types, only: string
5183  implicit none
5184  character(*), intent(in):: message
5185  logical, intent(in):: answer(:,:,:,:,:)
5186  logical, intent(in):: check(:,:,:,:,:)
5187 
5188  integer:: answer_shape(5), check_shape(5), i
5189  logical, allocatable:: answer_tmp(:), check_tmp(:)
5190  character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
5191  character(STRING), allocatable:: answer_str(:,:,:,:,:)
5192  character(STRING), allocatable:: check_str(:,:,:,:,:)
5193 
5194 
5195 
5196  continue
5197 
5198 
5199  allocate(answer_tmp(size(answer)))
5200  allocate(check_tmp(size(check)))
5201  allocate(answer_str_tmp(size(answer)))
5202  allocate(check_str_tmp(size(check)))
5203  answer_tmp = pack(answer, .true.)
5204  check_tmp = pack(check, .true.)
5205 
5206  do i = 1, size(answer_tmp)
5207  if (answer_tmp(i)) then
5208  answer_str_tmp(i) = '.true.'
5209  else
5210  answer_str_tmp(i) = '.false.'
5211  end if
5212  end do
5213 
5214  do i = 1, size(check_tmp)
5215  if (check_tmp(i)) then
5216  check_str_tmp(i) = '.true.'
5217  else
5218  check_str_tmp(i) = '.false.'
5219  end if
5220  end do
5221 
5222  answer_shape = shape(answer)
5223  check_shape = shape(check)
5224 
5225  allocate( answer_str( &
5226  & answer_shape(1), &
5227 
5228  & answer_shape(2), &
5229 
5230  & answer_shape(3), &
5231 
5232  & answer_shape(4), &
5233 
5234  & answer_shape(5) ) &
5235  & )
5236 
5237  allocate( check_str( &
5238  & check_shape(1), &
5239 
5240  & check_shape(2), &
5241 
5242  & check_shape(3), &
5243 
5244  & check_shape(4), &
5245 
5246  & check_shape(5) ) &
5247  & )
5248 
5249  answer_str = reshape(answer_str_tmp, answer_shape)
5250  check_str = reshape(check_str_tmp, check_shape)
5251 
5252 
5253 
5254  call dctestassertequalchar5(message, answer_str, check_str)
5255 
5256  deallocate(answer_str, answer_tmp, answer_str_tmp)
5257  deallocate(check_str, check_tmp, check_str_tmp)
5258 
5259 
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequallogical6()

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

Definition at line 5262 of file dc_test.f90.

5262  use dc_types, only: string
5263  implicit none
5264  character(*), intent(in):: message
5265  logical, intent(in):: answer(:,:,:,:,:,:)
5266  logical, intent(in):: check(:,:,:,:,:,:)
5267 
5268  integer:: answer_shape(6), check_shape(6), i
5269  logical, allocatable:: answer_tmp(:), check_tmp(:)
5270  character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
5271  character(STRING), allocatable:: answer_str(:,:,:,:,:,:)
5272  character(STRING), allocatable:: check_str(:,:,:,:,:,:)
5273 
5274 
5275 
5276  continue
5277 
5278 
5279  allocate(answer_tmp(size(answer)))
5280  allocate(check_tmp(size(check)))
5281  allocate(answer_str_tmp(size(answer)))
5282  allocate(check_str_tmp(size(check)))
5283  answer_tmp = pack(answer, .true.)
5284  check_tmp = pack(check, .true.)
5285 
5286  do i = 1, size(answer_tmp)
5287  if (answer_tmp(i)) then
5288  answer_str_tmp(i) = '.true.'
5289  else
5290  answer_str_tmp(i) = '.false.'
5291  end if
5292  end do
5293 
5294  do i = 1, size(check_tmp)
5295  if (check_tmp(i)) then
5296  check_str_tmp(i) = '.true.'
5297  else
5298  check_str_tmp(i) = '.false.'
5299  end if
5300  end do
5301 
5302  answer_shape = shape(answer)
5303  check_shape = shape(check)
5304 
5305  allocate( answer_str( &
5306  & answer_shape(1), &
5307 
5308  & answer_shape(2), &
5309 
5310  & answer_shape(3), &
5311 
5312  & answer_shape(4), &
5313 
5314  & answer_shape(5), &
5315 
5316  & answer_shape(6) ) &
5317  & )
5318 
5319  allocate( check_str( &
5320  & check_shape(1), &
5321 
5322  & check_shape(2), &
5323 
5324  & check_shape(3), &
5325 
5326  & check_shape(4), &
5327 
5328  & check_shape(5), &
5329 
5330  & check_shape(6) ) &
5331  & )
5332 
5333  answer_str = reshape(answer_str_tmp, answer_shape)
5334  check_str = reshape(check_str_tmp, check_shape)
5335 
5336 
5337 
5338  call dctestassertequalchar6(message, answer_str, check_str)
5339 
5340  deallocate(answer_str, answer_tmp, answer_str_tmp)
5341  deallocate(check_str, check_tmp, check_str_tmp)
5342 
5343 
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequallogical7()

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

Definition at line 5346 of file dc_test.f90.

5346  use dc_types, only: string
5347  implicit none
5348  character(*), intent(in):: message
5349  logical, intent(in):: answer(:,:,:,:,:,:,:)
5350  logical, intent(in):: check(:,:,:,:,:,:,:)
5351 
5352  integer:: answer_shape(7), check_shape(7), i
5353  logical, allocatable:: answer_tmp(:), check_tmp(:)
5354  character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
5355  character(STRING), allocatable:: answer_str(:,:,:,:,:,:,:)
5356  character(STRING), allocatable:: check_str(:,:,:,:,:,:,:)
5357 
5358 
5359 
5360  continue
5361 
5362 
5363  allocate(answer_tmp(size(answer)))
5364  allocate(check_tmp(size(check)))
5365  allocate(answer_str_tmp(size(answer)))
5366  allocate(check_str_tmp(size(check)))
5367  answer_tmp = pack(answer, .true.)
5368  check_tmp = pack(check, .true.)
5369 
5370  do i = 1, size(answer_tmp)
5371  if (answer_tmp(i)) then
5372  answer_str_tmp(i) = '.true.'
5373  else
5374  answer_str_tmp(i) = '.false.'
5375  end if
5376  end do
5377 
5378  do i = 1, size(check_tmp)
5379  if (check_tmp(i)) then
5380  check_str_tmp(i) = '.true.'
5381  else
5382  check_str_tmp(i) = '.false.'
5383  end if
5384  end do
5385 
5386  answer_shape = shape(answer)
5387  check_shape = shape(check)
5388 
5389  allocate( answer_str( &
5390  & answer_shape(1), &
5391 
5392  & answer_shape(2), &
5393 
5394  & answer_shape(3), &
5395 
5396  & answer_shape(4), &
5397 
5398  & answer_shape(5), &
5399 
5400  & answer_shape(6), &
5401 
5402  & answer_shape(7) ) &
5403  & )
5404 
5405  allocate( check_str( &
5406  & check_shape(1), &
5407 
5408  & check_shape(2), &
5409 
5410  & check_shape(3), &
5411 
5412  & check_shape(4), &
5413 
5414  & check_shape(5), &
5415 
5416  & check_shape(6), &
5417 
5418  & check_shape(7) ) &
5419  & )
5420 
5421  answer_str = reshape(answer_str_tmp, answer_shape)
5422  check_str = reshape(check_str_tmp, check_shape)
5423 
5424 
5425 
5426  call dctestassertequalchar7(message, answer_str, check_str)
5427 
5428  deallocate(answer_str, answer_tmp, answer_str_tmp)
5429  deallocate(check_str, check_tmp, check_str_tmp)
5430 
5431 
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequalreal0()

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

Definition at line 2795 of file dc_test.f90.

2795  use sysdep, only: abortprogram
2796  use dc_types, only: string, token
2797  implicit none
2798  character(*), intent(in):: message
2799  real, intent(in):: answer
2800  real, intent(in):: check
2801  logical:: err_flag
2802  character(STRING):: pos_str
2803  real:: wrong, right
2804 
2805 
2806 
2807 
2808 
2809  continue
2810  err_flag = .false.
2811 
2812 
2813  err_flag = .not. answer == check
2814  wrong = check
2815  right = answer
2816  pos_str = ''
2817 
2818 
2819 
2820 
2821  if (err_flag) then
2822  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2823  write(*,*) ''
2824  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2825  write(*,*) ' is NOT EQUAL to'
2826  write(*,*) ' answer' // trim(pos_str) // ' = ', right
2827 
2828  call abortprogram('')
2829  else
2830  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2831  end if
2832 
2833 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ 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 
)
private

Definition at line 5436 of file dc_test.f90.

5436  use sysdep, only: abortprogram
5437  use dc_types, only: string, token
5438  implicit none
5439  character(*), intent(in):: message
5440  real, intent(in):: answer
5441  real, intent(in):: check
5442  integer, intent(in):: significant_digits
5443  integer, intent(in):: ignore_digits
5444  logical:: err_flag
5445  character(STRING):: pos_str
5446  real:: wrong, right_max, right_min
5447  character(STRING):: pos_str_space
5448  integer:: pos_str_len
5449  real:: right_tmp
5450 
5451  real:: answer_max
5452  real:: answer_min
5453 
5454  continue
5455  err_flag = .false.
5456 
5457  if ( significant_digits < 1 ) then
5458  write(*,*) ' *** Error [AssertEQ] *** '
5459  write(*,*) ' Specify a number more than 1 to "significant_digits"'
5460  call abortprogram('')
5461  end if
5462 
5463  if ( answer < 0.0 .and. check < 0.0 ) then
5464  answer_max = &
5465  & answer &
5466  & * ( 1.0 &
5467  & - 0.1 ** significant_digits ) &
5468  & + 0.1 ** (- ignore_digits)
5469 
5470  answer_min = &
5471  & answer &
5472  & * ( 1.0 &
5473  & + 0.1 ** significant_digits ) &
5474  & - 0.1 ** (- ignore_digits)
5475  else
5476 
5477  answer_max = &
5478  & answer &
5479  & * ( 1.0 &
5480  & + 0.1 ** significant_digits ) &
5481  & + 0.1 ** (- ignore_digits)
5482 
5483  answer_min = &
5484  & answer &
5485  & * ( 1.0 &
5486  & - 0.1 ** significant_digits ) &
5487  & - 0.1 ** (- ignore_digits)
5488  end if
5489 
5490  wrong = check
5491  right_max = answer_max
5492  right_min = answer_min
5493  if ( right_max < right_min ) then
5494  right_tmp = right_max
5495  right_max = right_min
5496  right_min = right_tmp
5497  end if
5498 
5499  err_flag = .not. (answer_max > check .and. check > answer_min)
5500 
5501  pos_str = ''
5502 
5503 
5504 
5505  if (err_flag) then
5506  pos_str_space = ''
5507  pos_str_len = len_trim(pos_str)
5508 
5509  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5510  write(*,*) ''
5511  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
5512  write(*,*) ' is NOT EQUAL to'
5513  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
5514  & // ' ', right_min, ' < '
5515  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
5516 
5517  call abortprogram('')
5518  else
5519  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
5520  end if
5521 
5522 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequalreal1()

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

Definition at line 2838 of file dc_test.f90.

2838  use sysdep, only: abortprogram
2839  use dc_types, only: string, token
2840  implicit none
2841  character(*), intent(in):: message
2842  real, intent(in):: answer(:)
2843  real, intent(in):: check(:)
2844  logical:: err_flag
2845  character(STRING):: pos_str
2846  real:: wrong, right
2847 
2848  integer:: answer_shape(1), check_shape(1), pos(1)
2849  logical:: consist_shape(1)
2850  character(TOKEN):: pos_array(1)
2851  integer, allocatable:: mask_array(:)
2852  logical, allocatable:: judge(:)
2853  logical, allocatable:: judge_rev(:)
2854 
2855 
2856 
2857 
2858  continue
2859  err_flag = .false.
2860 
2861 
2862  answer_shape = shape(answer)
2863  check_shape = shape(check)
2864 
2865  consist_shape = answer_shape == check_shape
2866 
2867  if (.not. all(consist_shape)) then
2868  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2869  write(*,*) ''
2870  write(*,*) ' shape of check is (', check_shape, ')'
2871  write(*,*) ' is INCORRECT'
2872  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2873 
2874  call abortprogram('')
2875  end if
2876 
2877 
2878  allocate( mask_array( &
2879 
2880  & answer_shape(1) ) &
2881  & )
2882 
2883  allocate( judge( &
2884 
2885  & answer_shape(1) ) &
2886  & )
2887 
2888  allocate( judge_rev( &
2889 
2890  & answer_shape(1) ) &
2891  & )
2892 
2893 
2894  judge = answer == check
2895 
2896 
2897 
2898  judge_rev = .not. judge
2899  err_flag = any(judge_rev)
2900  mask_array = 1
2901  pos = maxloc(mask_array, judge_rev)
2902 
2903  if (err_flag) then
2904 
2905  wrong = check( &
2906 
2907  & pos(1) )
2908 
2909  right = answer( &
2910 
2911  & pos(1) )
2912 
2913  write(unit=pos_array(1), fmt="(i20)") pos(1)
2914 
2915 
2916  pos_str = '(' // &
2917 
2918  & trim(adjustl(pos_array(1))) // ')'
2919 
2920  end if
2921  deallocate(mask_array, judge, judge_rev)
2922 
2923 
2924 
2925 
2926  if (err_flag) then
2927  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2928  write(*,*) ''
2929  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2930  write(*,*) ' is NOT EQUAL to'
2931  write(*,*) ' answer' // trim(pos_str) // ' = ', right
2932 
2933  call abortprogram('')
2934  else
2935  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2936  end if
2937 
2938 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ 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 
)
private

Definition at line 5528 of file dc_test.f90.

5528  use sysdep, only: abortprogram
5529  use dc_types, only: string, token
5530  implicit none
5531  character(*), intent(in):: message
5532  real, intent(in):: answer(:)
5533  real, intent(in):: check(:)
5534  integer, intent(in):: significant_digits
5535  integer, intent(in):: ignore_digits
5536  logical:: err_flag
5537  character(STRING):: pos_str
5538  real:: wrong, right_max, right_min
5539  character(STRING):: pos_str_space
5540  integer:: pos_str_len
5541  real:: right_tmp
5542 
5543  integer:: answer_shape(1), check_shape(1), pos(1)
5544  logical:: consist_shape(1)
5545  character(TOKEN):: pos_array(1)
5546  integer, allocatable:: mask_array(:)
5547  logical, allocatable:: judge(:)
5548  logical, allocatable:: judge_rev(:)
5549  logical, allocatable:: answer_negative(:)
5550  logical, allocatable:: check_negative(:)
5551  logical, allocatable:: both_negative(:)
5552  real, allocatable:: answer_max(:)
5553  real, allocatable:: answer_min(:)
5554 
5555  continue
5556  err_flag = .false.
5557 
5558  if ( significant_digits < 1 ) then
5559  write(*,*) ' *** Error [AssertEQ] *** '
5560  write(*,*) ' Specify a number more than 1 to "significant_digits"'
5561  call abortprogram('')
5562  end if
5563 
5564  answer_shape = shape(answer)
5565  check_shape = shape(check)
5566 
5567  consist_shape = answer_shape == check_shape
5568 
5569  if (.not. all(consist_shape)) then
5570  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5571  write(*,*) ''
5572  write(*,*) ' shape of check is (', check_shape, ')'
5573  write(*,*) ' is INCORRECT'
5574  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
5575 
5576  call abortprogram('')
5577  end if
5578 
5579 
5580  allocate( mask_array( &
5581 
5582  & answer_shape(1) ) &
5583  & )
5584 
5585  allocate( judge( &
5586 
5587  & answer_shape(1) ) &
5588  & )
5589 
5590  allocate( judge_rev( &
5591 
5592  & answer_shape(1) ) &
5593  & )
5594 
5595  allocate( answer_negative( &
5596 
5597  & answer_shape(1) ) &
5598  & )
5599 
5600  allocate( check_negative( &
5601 
5602  & answer_shape(1) ) &
5603  & )
5604 
5605  allocate( both_negative( &
5606 
5607  & answer_shape(1) ) &
5608  & )
5609 
5610  allocate( answer_max( &
5611 
5612  & answer_shape(1) ) &
5613  & )
5614 
5615  allocate( answer_min( &
5616 
5617  & answer_shape(1) ) &
5618  & )
5619 
5620  answer_negative = answer < 0.0
5621  check_negative = check < 0.0
5622  both_negative = answer_negative .and. check_negative
5623 
5624  where (both_negative)
5625  answer_max = &
5626  & answer &
5627  & * ( 1.0 &
5628  & - 0.1 ** significant_digits ) &
5629  & + 0.1 ** (- ignore_digits)
5630 
5631  answer_min = &
5632  & answer &
5633  & * ( 1.0 &
5634  & + 0.1 ** significant_digits ) &
5635  & - 0.1 ** (- ignore_digits)
5636  elsewhere
5637  answer_max = &
5638  & answer &
5639  & * ( 1.0 &
5640  & + 0.1 ** significant_digits ) &
5641  & + 0.1 ** (- ignore_digits)
5642 
5643  answer_min = &
5644  & answer &
5645  & * ( 1.0 &
5646  & - 0.1 ** significant_digits ) &
5647  & - 0.1 ** (- ignore_digits)
5648  end where
5649 
5650  judge = answer_max > check .and. check > answer_min
5651  judge_rev = .not. judge
5652  err_flag = any(judge_rev)
5653  mask_array = 1
5654  pos = maxloc(mask_array, judge_rev)
5655 
5656  if (err_flag) then
5657 
5658  wrong = check( &
5659 
5660  & pos(1) )
5661 
5662  right_max = answer_max( &
5663 
5664  & pos(1) )
5665 
5666  right_min = answer_min( &
5667 
5668  & pos(1) )
5669 
5670  if ( right_max < right_min ) then
5671  right_tmp = right_max
5672  right_max = right_min
5673  right_min = right_tmp
5674  end if
5675 
5676  write(unit=pos_array(1), fmt="(i20)") pos(1)
5677 
5678 
5679  pos_str = '(' // &
5680 
5681  & trim(adjustl(pos_array(1))) // ')'
5682 
5683  end if
5684  deallocate(mask_array, judge, judge_rev)
5685  deallocate(answer_negative, check_negative, both_negative)
5686  deallocate(answer_max, answer_min)
5687 
5688 
5689 
5690  if (err_flag) then
5691  pos_str_space = ''
5692  pos_str_len = len_trim(pos_str)
5693 
5694  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5695  write(*,*) ''
5696  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
5697  write(*,*) ' is NOT EQUAL to'
5698  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
5699  & // ' ', right_min, ' < '
5700  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
5701 
5702  call abortprogram('')
5703  else
5704  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
5705  end if
5706 
5707 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequalreal2()

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

Definition at line 2943 of file dc_test.f90.

2943  use sysdep, only: abortprogram
2944  use dc_types, only: string, token
2945  implicit none
2946  character(*), intent(in):: message
2947  real, intent(in):: answer(:,:)
2948  real, intent(in):: check(:,:)
2949  logical:: err_flag
2950  character(STRING):: pos_str
2951  real:: wrong, right
2952 
2953  integer:: answer_shape(2), check_shape(2), pos(2)
2954  logical:: consist_shape(2)
2955  character(TOKEN):: pos_array(2)
2956  integer, allocatable:: mask_array(:,:)
2957  logical, allocatable:: judge(:,:)
2958  logical, allocatable:: judge_rev(:,:)
2959 
2960 
2961 
2962 
2963  continue
2964  err_flag = .false.
2965 
2966 
2967  answer_shape = shape(answer)
2968  check_shape = shape(check)
2969 
2970  consist_shape = answer_shape == check_shape
2971 
2972  if (.not. all(consist_shape)) then
2973  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2974  write(*,*) ''
2975  write(*,*) ' shape of check is (', check_shape, ')'
2976  write(*,*) ' is INCORRECT'
2977  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2978 
2979  call abortprogram('')
2980  end if
2981 
2982 
2983  allocate( mask_array( &
2984  & answer_shape(1), &
2985 
2986  & answer_shape(2) ) &
2987  & )
2988 
2989  allocate( judge( &
2990  & answer_shape(1), &
2991 
2992  & answer_shape(2) ) &
2993  & )
2994 
2995  allocate( judge_rev( &
2996  & answer_shape(1), &
2997 
2998  & answer_shape(2) ) &
2999  & )
3000 
3001 
3002  judge = answer == check
3003 
3004 
3005 
3006  judge_rev = .not. judge
3007  err_flag = any(judge_rev)
3008  mask_array = 1
3009  pos = maxloc(mask_array, judge_rev)
3010 
3011  if (err_flag) then
3012 
3013  wrong = check( &
3014  & pos(1), &
3015 
3016  & pos(2) )
3017 
3018  right = answer( &
3019  & pos(1), &
3020 
3021  & pos(2) )
3022 
3023  write(unit=pos_array(1), fmt="(i20)") pos(1)
3024 
3025  write(unit=pos_array(2), fmt="(i20)") pos(2)
3026 
3027 
3028  pos_str = '(' // &
3029  & trim(adjustl(pos_array(1))) // ',' // &
3030 
3031  & trim(adjustl(pos_array(2))) // ')'
3032 
3033  end if
3034  deallocate(mask_array, judge, judge_rev)
3035 
3036 
3037 
3038 
3039  if (err_flag) then
3040  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3041  write(*,*) ''
3042  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3043  write(*,*) ' is NOT EQUAL to'
3044  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3045 
3046  call abortprogram('')
3047  else
3048  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3049  end if
3050 
3051 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ 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 
)
private

Definition at line 5713 of file dc_test.f90.

5713  use sysdep, only: abortprogram
5714  use dc_types, only: string, token
5715  implicit none
5716  character(*), intent(in):: message
5717  real, intent(in):: answer(:,:)
5718  real, intent(in):: check(:,:)
5719  integer, intent(in):: significant_digits
5720  integer, intent(in):: ignore_digits
5721  logical:: err_flag
5722  character(STRING):: pos_str
5723  real:: wrong, right_max, right_min
5724  character(STRING):: pos_str_space
5725  integer:: pos_str_len
5726  real:: right_tmp
5727 
5728  integer:: answer_shape(2), check_shape(2), pos(2)
5729  logical:: consist_shape(2)
5730  character(TOKEN):: pos_array(2)
5731  integer, allocatable:: mask_array(:,:)
5732  logical, allocatable:: judge(:,:)
5733  logical, allocatable:: judge_rev(:,:)
5734  logical, allocatable:: answer_negative(:,:)
5735  logical, allocatable:: check_negative(:,:)
5736  logical, allocatable:: both_negative(:,:)
5737  real, allocatable:: answer_max(:,:)
5738  real, allocatable:: answer_min(:,:)
5739 
5740  continue
5741  err_flag = .false.
5742 
5743  if ( significant_digits < 1 ) then
5744  write(*,*) ' *** Error [AssertEQ] *** '
5745  write(*,*) ' Specify a number more than 1 to "significant_digits"'
5746  call abortprogram('')
5747  end if
5748 
5749  answer_shape = shape(answer)
5750  check_shape = shape(check)
5751 
5752  consist_shape = answer_shape == check_shape
5753 
5754  if (.not. all(consist_shape)) then
5755  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5756  write(*,*) ''
5757  write(*,*) ' shape of check is (', check_shape, ')'
5758  write(*,*) ' is INCORRECT'
5759  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
5760 
5761  call abortprogram('')
5762  end if
5763 
5764 
5765  allocate( mask_array( &
5766  & answer_shape(1), &
5767 
5768  & answer_shape(2) ) &
5769  & )
5770 
5771  allocate( judge( &
5772  & answer_shape(1), &
5773 
5774  & answer_shape(2) ) &
5775  & )
5776 
5777  allocate( judge_rev( &
5778  & answer_shape(1), &
5779 
5780  & answer_shape(2) ) &
5781  & )
5782 
5783  allocate( answer_negative( &
5784  & answer_shape(1), &
5785 
5786  & answer_shape(2) ) &
5787  & )
5788 
5789  allocate( check_negative( &
5790  & answer_shape(1), &
5791 
5792  & answer_shape(2) ) &
5793  & )
5794 
5795  allocate( both_negative( &
5796  & answer_shape(1), &
5797 
5798  & answer_shape(2) ) &
5799  & )
5800 
5801  allocate( answer_max( &
5802  & answer_shape(1), &
5803 
5804  & answer_shape(2) ) &
5805  & )
5806 
5807  allocate( answer_min( &
5808  & answer_shape(1), &
5809 
5810  & answer_shape(2) ) &
5811  & )
5812 
5813  answer_negative = answer < 0.0
5814  check_negative = check < 0.0
5815  both_negative = answer_negative .and. check_negative
5816 
5817  where (both_negative)
5818  answer_max = &
5819  & answer &
5820  & * ( 1.0 &
5821  & - 0.1 ** significant_digits ) &
5822  & + 0.1 ** (- ignore_digits)
5823 
5824  answer_min = &
5825  & answer &
5826  & * ( 1.0 &
5827  & + 0.1 ** significant_digits ) &
5828  & - 0.1 ** (- ignore_digits)
5829  elsewhere
5830  answer_max = &
5831  & answer &
5832  & * ( 1.0 &
5833  & + 0.1 ** significant_digits ) &
5834  & + 0.1 ** (- ignore_digits)
5835 
5836  answer_min = &
5837  & answer &
5838  & * ( 1.0 &
5839  & - 0.1 ** significant_digits ) &
5840  & - 0.1 ** (- ignore_digits)
5841  end where
5842 
5843  judge = answer_max > check .and. check > answer_min
5844  judge_rev = .not. judge
5845  err_flag = any(judge_rev)
5846  mask_array = 1
5847  pos = maxloc(mask_array, judge_rev)
5848 
5849  if (err_flag) then
5850 
5851  wrong = check( &
5852  & pos(1), &
5853 
5854  & pos(2) )
5855 
5856  right_max = answer_max( &
5857  & pos(1), &
5858 
5859  & pos(2) )
5860 
5861  right_min = answer_min( &
5862  & pos(1), &
5863 
5864  & pos(2) )
5865 
5866  if ( right_max < right_min ) then
5867  right_tmp = right_max
5868  right_max = right_min
5869  right_min = right_tmp
5870  end if
5871 
5872  write(unit=pos_array(1), fmt="(i20)") pos(1)
5873 
5874  write(unit=pos_array(2), fmt="(i20)") pos(2)
5875 
5876 
5877  pos_str = '(' // &
5878  & trim(adjustl(pos_array(1))) // ',' // &
5879 
5880  & trim(adjustl(pos_array(2))) // ')'
5881 
5882  end if
5883  deallocate(mask_array, judge, judge_rev)
5884  deallocate(answer_negative, check_negative, both_negative)
5885  deallocate(answer_max, answer_min)
5886 
5887 
5888 
5889  if (err_flag) then
5890  pos_str_space = ''
5891  pos_str_len = len_trim(pos_str)
5892 
5893  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5894  write(*,*) ''
5895  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
5896  write(*,*) ' is NOT EQUAL to'
5897  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
5898  & // ' ', right_min, ' < '
5899  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
5900 
5901  call abortprogram('')
5902  else
5903  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
5904  end if
5905 
5906 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequalreal3()

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

Definition at line 3056 of file dc_test.f90.

3056  use sysdep, only: abortprogram
3057  use dc_types, only: string, token
3058  implicit none
3059  character(*), intent(in):: message
3060  real, intent(in):: answer(:,:,:)
3061  real, intent(in):: check(:,:,:)
3062  logical:: err_flag
3063  character(STRING):: pos_str
3064  real:: wrong, right
3065 
3066  integer:: answer_shape(3), check_shape(3), pos(3)
3067  logical:: consist_shape(3)
3068  character(TOKEN):: pos_array(3)
3069  integer, allocatable:: mask_array(:,:,:)
3070  logical, allocatable:: judge(:,:,:)
3071  logical, allocatable:: judge_rev(:,:,:)
3072 
3073 
3074 
3075 
3076  continue
3077  err_flag = .false.
3078 
3079 
3080  answer_shape = shape(answer)
3081  check_shape = shape(check)
3082 
3083  consist_shape = answer_shape == check_shape
3084 
3085  if (.not. all(consist_shape)) then
3086  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3087  write(*,*) ''
3088  write(*,*) ' shape of check is (', check_shape, ')'
3089  write(*,*) ' is INCORRECT'
3090  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3091 
3092  call abortprogram('')
3093  end if
3094 
3095 
3096  allocate( mask_array( &
3097  & answer_shape(1), &
3098 
3099  & answer_shape(2), &
3100 
3101  & answer_shape(3) ) &
3102  & )
3103 
3104  allocate( judge( &
3105  & answer_shape(1), &
3106 
3107  & answer_shape(2), &
3108 
3109  & answer_shape(3) ) &
3110  & )
3111 
3112  allocate( judge_rev( &
3113  & answer_shape(1), &
3114 
3115  & answer_shape(2), &
3116 
3117  & answer_shape(3) ) &
3118  & )
3119 
3120 
3121  judge = answer == check
3122 
3123 
3124 
3125  judge_rev = .not. judge
3126  err_flag = any(judge_rev)
3127  mask_array = 1
3128  pos = maxloc(mask_array, judge_rev)
3129 
3130  if (err_flag) then
3131 
3132  wrong = check( &
3133  & pos(1), &
3134 
3135  & pos(2), &
3136 
3137  & pos(3) )
3138 
3139  right = answer( &
3140  & pos(1), &
3141 
3142  & pos(2), &
3143 
3144  & pos(3) )
3145 
3146  write(unit=pos_array(1), fmt="(i20)") pos(1)
3147 
3148  write(unit=pos_array(2), fmt="(i20)") pos(2)
3149 
3150  write(unit=pos_array(3), fmt="(i20)") pos(3)
3151 
3152 
3153  pos_str = '(' // &
3154  & trim(adjustl(pos_array(1))) // ',' // &
3155 
3156  & trim(adjustl(pos_array(2))) // ',' // &
3157 
3158  & trim(adjustl(pos_array(3))) // ')'
3159 
3160  end if
3161  deallocate(mask_array, judge, judge_rev)
3162 
3163 
3164 
3165 
3166  if (err_flag) then
3167  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3168  write(*,*) ''
3169  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3170  write(*,*) ' is NOT EQUAL to'
3171  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3172 
3173  call abortprogram('')
3174  else
3175  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3176  end if
3177 
3178 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ 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 
)
private

Definition at line 5912 of file dc_test.f90.

5912  use sysdep, only: abortprogram
5913  use dc_types, only: string, token
5914  implicit none
5915  character(*), intent(in):: message
5916  real, intent(in):: answer(:,:,:)
5917  real, intent(in):: check(:,:,:)
5918  integer, intent(in):: significant_digits
5919  integer, intent(in):: ignore_digits
5920  logical:: err_flag
5921  character(STRING):: pos_str
5922  real:: wrong, right_max, right_min
5923  character(STRING):: pos_str_space
5924  integer:: pos_str_len
5925  real:: right_tmp
5926 
5927  integer:: answer_shape(3), check_shape(3), pos(3)
5928  logical:: consist_shape(3)
5929  character(TOKEN):: pos_array(3)
5930  integer, allocatable:: mask_array(:,:,:)
5931  logical, allocatable:: judge(:,:,:)
5932  logical, allocatable:: judge_rev(:,:,:)
5933  logical, allocatable:: answer_negative(:,:,:)
5934  logical, allocatable:: check_negative(:,:,:)
5935  logical, allocatable:: both_negative(:,:,:)
5936  real, allocatable:: answer_max(:,:,:)
5937  real, allocatable:: answer_min(:,:,:)
5938 
5939  continue
5940  err_flag = .false.
5941 
5942  if ( significant_digits < 1 ) then
5943  write(*,*) ' *** Error [AssertEQ] *** '
5944  write(*,*) ' Specify a number more than 1 to "significant_digits"'
5945  call abortprogram('')
5946  end if
5947 
5948  answer_shape = shape(answer)
5949  check_shape = shape(check)
5950 
5951  consist_shape = answer_shape == check_shape
5952 
5953  if (.not. all(consist_shape)) then
5954  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5955  write(*,*) ''
5956  write(*,*) ' shape of check is (', check_shape, ')'
5957  write(*,*) ' is INCORRECT'
5958  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
5959 
5960  call abortprogram('')
5961  end if
5962 
5963 
5964  allocate( mask_array( &
5965  & answer_shape(1), &
5966 
5967  & answer_shape(2), &
5968 
5969  & answer_shape(3) ) &
5970  & )
5971 
5972  allocate( judge( &
5973  & answer_shape(1), &
5974 
5975  & answer_shape(2), &
5976 
5977  & answer_shape(3) ) &
5978  & )
5979 
5980  allocate( judge_rev( &
5981  & answer_shape(1), &
5982 
5983  & answer_shape(2), &
5984 
5985  & answer_shape(3) ) &
5986  & )
5987 
5988  allocate( answer_negative( &
5989  & answer_shape(1), &
5990 
5991  & answer_shape(2), &
5992 
5993  & answer_shape(3) ) &
5994  & )
5995 
5996  allocate( check_negative( &
5997  & answer_shape(1), &
5998 
5999  & answer_shape(2), &
6000 
6001  & answer_shape(3) ) &
6002  & )
6003 
6004  allocate( both_negative( &
6005  & answer_shape(1), &
6006 
6007  & answer_shape(2), &
6008 
6009  & answer_shape(3) ) &
6010  & )
6011 
6012  allocate( answer_max( &
6013  & answer_shape(1), &
6014 
6015  & answer_shape(2), &
6016 
6017  & answer_shape(3) ) &
6018  & )
6019 
6020  allocate( answer_min( &
6021  & answer_shape(1), &
6022 
6023  & answer_shape(2), &
6024 
6025  & answer_shape(3) ) &
6026  & )
6027 
6028  answer_negative = answer < 0.0
6029  check_negative = check < 0.0
6030  both_negative = answer_negative .and. check_negative
6031 
6032  where (both_negative)
6033  answer_max = &
6034  & answer &
6035  & * ( 1.0 &
6036  & - 0.1 ** significant_digits ) &
6037  & + 0.1 ** (- ignore_digits)
6038 
6039  answer_min = &
6040  & answer &
6041  & * ( 1.0 &
6042  & + 0.1 ** significant_digits ) &
6043  & - 0.1 ** (- ignore_digits)
6044  elsewhere
6045  answer_max = &
6046  & answer &
6047  & * ( 1.0 &
6048  & + 0.1 ** significant_digits ) &
6049  & + 0.1 ** (- ignore_digits)
6050 
6051  answer_min = &
6052  & answer &
6053  & * ( 1.0 &
6054  & - 0.1 ** significant_digits ) &
6055  & - 0.1 ** (- ignore_digits)
6056  end where
6057 
6058  judge = answer_max > check .and. check > answer_min
6059  judge_rev = .not. judge
6060  err_flag = any(judge_rev)
6061  mask_array = 1
6062  pos = maxloc(mask_array, judge_rev)
6063 
6064  if (err_flag) then
6065 
6066  wrong = check( &
6067  & pos(1), &
6068 
6069  & pos(2), &
6070 
6071  & pos(3) )
6072 
6073  right_max = answer_max( &
6074  & pos(1), &
6075 
6076  & pos(2), &
6077 
6078  & pos(3) )
6079 
6080  right_min = answer_min( &
6081  & pos(1), &
6082 
6083  & pos(2), &
6084 
6085  & pos(3) )
6086 
6087  if ( right_max < right_min ) then
6088  right_tmp = right_max
6089  right_max = right_min
6090  right_min = right_tmp
6091  end if
6092 
6093  write(unit=pos_array(1), fmt="(i20)") pos(1)
6094 
6095  write(unit=pos_array(2), fmt="(i20)") pos(2)
6096 
6097  write(unit=pos_array(3), fmt="(i20)") pos(3)
6098 
6099 
6100  pos_str = '(' // &
6101  & trim(adjustl(pos_array(1))) // ',' // &
6102 
6103  & trim(adjustl(pos_array(2))) // ',' // &
6104 
6105  & trim(adjustl(pos_array(3))) // ')'
6106 
6107  end if
6108  deallocate(mask_array, judge, judge_rev)
6109  deallocate(answer_negative, check_negative, both_negative)
6110  deallocate(answer_max, answer_min)
6111 
6112 
6113 
6114  if (err_flag) then
6115  pos_str_space = ''
6116  pos_str_len = len_trim(pos_str)
6117 
6118  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6119  write(*,*) ''
6120  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
6121  write(*,*) ' is NOT EQUAL to'
6122  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
6123  & // ' ', right_min, ' < '
6124  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
6125 
6126  call abortprogram('')
6127  else
6128  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
6129  end if
6130 
6131 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequalreal4()

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

Definition at line 3183 of file dc_test.f90.

3183  use sysdep, only: abortprogram
3184  use dc_types, only: string, token
3185  implicit none
3186  character(*), intent(in):: message
3187  real, intent(in):: answer(:,:,:,:)
3188  real, intent(in):: check(:,:,:,:)
3189  logical:: err_flag
3190  character(STRING):: pos_str
3191  real:: wrong, right
3192 
3193  integer:: answer_shape(4), check_shape(4), pos(4)
3194  logical:: consist_shape(4)
3195  character(TOKEN):: pos_array(4)
3196  integer, allocatable:: mask_array(:,:,:,:)
3197  logical, allocatable:: judge(:,:,:,:)
3198  logical, allocatable:: judge_rev(:,:,:,:)
3199 
3200 
3201 
3202 
3203  continue
3204  err_flag = .false.
3205 
3206 
3207  answer_shape = shape(answer)
3208  check_shape = shape(check)
3209 
3210  consist_shape = answer_shape == check_shape
3211 
3212  if (.not. all(consist_shape)) then
3213  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3214  write(*,*) ''
3215  write(*,*) ' shape of check is (', check_shape, ')'
3216  write(*,*) ' is INCORRECT'
3217  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3218 
3219  call abortprogram('')
3220  end if
3221 
3222 
3223  allocate( mask_array( &
3224  & answer_shape(1), &
3225 
3226  & answer_shape(2), &
3227 
3228  & answer_shape(3), &
3229 
3230  & answer_shape(4) ) &
3231  & )
3232 
3233  allocate( judge( &
3234  & answer_shape(1), &
3235 
3236  & answer_shape(2), &
3237 
3238  & answer_shape(3), &
3239 
3240  & answer_shape(4) ) &
3241  & )
3242 
3243  allocate( judge_rev( &
3244  & answer_shape(1), &
3245 
3246  & answer_shape(2), &
3247 
3248  & answer_shape(3), &
3249 
3250  & answer_shape(4) ) &
3251  & )
3252 
3253 
3254  judge = answer == check
3255 
3256 
3257 
3258  judge_rev = .not. judge
3259  err_flag = any(judge_rev)
3260  mask_array = 1
3261  pos = maxloc(mask_array, judge_rev)
3262 
3263  if (err_flag) then
3264 
3265  wrong = check( &
3266  & pos(1), &
3267 
3268  & pos(2), &
3269 
3270  & pos(3), &
3271 
3272  & pos(4) )
3273 
3274  right = answer( &
3275  & pos(1), &
3276 
3277  & pos(2), &
3278 
3279  & pos(3), &
3280 
3281  & pos(4) )
3282 
3283  write(unit=pos_array(1), fmt="(i20)") pos(1)
3284 
3285  write(unit=pos_array(2), fmt="(i20)") pos(2)
3286 
3287  write(unit=pos_array(3), fmt="(i20)") pos(3)
3288 
3289  write(unit=pos_array(4), fmt="(i20)") pos(4)
3290 
3291 
3292  pos_str = '(' // &
3293  & trim(adjustl(pos_array(1))) // ',' // &
3294 
3295  & trim(adjustl(pos_array(2))) // ',' // &
3296 
3297  & trim(adjustl(pos_array(3))) // ',' // &
3298 
3299  & trim(adjustl(pos_array(4))) // ')'
3300 
3301  end if
3302  deallocate(mask_array, judge, judge_rev)
3303 
3304 
3305 
3306 
3307  if (err_flag) then
3308  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3309  write(*,*) ''
3310  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3311  write(*,*) ' is NOT EQUAL to'
3312  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3313 
3314  call abortprogram('')
3315  else
3316  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3317  end if
3318 
3319 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ 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 
)
private

Definition at line 6137 of file dc_test.f90.

6137  use sysdep, only: abortprogram
6138  use dc_types, only: string, token
6139  implicit none
6140  character(*), intent(in):: message
6141  real, intent(in):: answer(:,:,:,:)
6142  real, intent(in):: check(:,:,:,:)
6143  integer, intent(in):: significant_digits
6144  integer, intent(in):: ignore_digits
6145  logical:: err_flag
6146  character(STRING):: pos_str
6147  real:: wrong, right_max, right_min
6148  character(STRING):: pos_str_space
6149  integer:: pos_str_len
6150  real:: right_tmp
6151 
6152  integer:: answer_shape(4), check_shape(4), pos(4)
6153  logical:: consist_shape(4)
6154  character(TOKEN):: pos_array(4)
6155  integer, allocatable:: mask_array(:,:,:,:)
6156  logical, allocatable:: judge(:,:,:,:)
6157  logical, allocatable:: judge_rev(:,:,:,:)
6158  logical, allocatable:: answer_negative(:,:,:,:)
6159  logical, allocatable:: check_negative(:,:,:,:)
6160  logical, allocatable:: both_negative(:,:,:,:)
6161  real, allocatable:: answer_max(:,:,:,:)
6162  real, allocatable:: answer_min(:,:,:,:)
6163 
6164  continue
6165  err_flag = .false.
6166 
6167  if ( significant_digits < 1 ) then
6168  write(*,*) ' *** Error [AssertEQ] *** '
6169  write(*,*) ' Specify a number more than 1 to "significant_digits"'
6170  call abortprogram('')
6171  end if
6172 
6173  answer_shape = shape(answer)
6174  check_shape = shape(check)
6175 
6176  consist_shape = answer_shape == check_shape
6177 
6178  if (.not. all(consist_shape)) then
6179  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6180  write(*,*) ''
6181  write(*,*) ' shape of check is (', check_shape, ')'
6182  write(*,*) ' is INCORRECT'
6183  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
6184 
6185  call abortprogram('')
6186  end if
6187 
6188 
6189  allocate( mask_array( &
6190  & answer_shape(1), &
6191 
6192  & answer_shape(2), &
6193 
6194  & answer_shape(3), &
6195 
6196  & answer_shape(4) ) &
6197  & )
6198 
6199  allocate( judge( &
6200  & answer_shape(1), &
6201 
6202  & answer_shape(2), &
6203 
6204  & answer_shape(3), &
6205 
6206  & answer_shape(4) ) &
6207  & )
6208 
6209  allocate( judge_rev( &
6210  & answer_shape(1), &
6211 
6212  & answer_shape(2), &
6213 
6214  & answer_shape(3), &
6215 
6216  & answer_shape(4) ) &
6217  & )
6218 
6219  allocate( answer_negative( &
6220  & answer_shape(1), &
6221 
6222  & answer_shape(2), &
6223 
6224  & answer_shape(3), &
6225 
6226  & answer_shape(4) ) &
6227  & )
6228 
6229  allocate( check_negative( &
6230  & answer_shape(1), &
6231 
6232  & answer_shape(2), &
6233 
6234  & answer_shape(3), &
6235 
6236  & answer_shape(4) ) &
6237  & )
6238 
6239  allocate( both_negative( &
6240  & answer_shape(1), &
6241 
6242  & answer_shape(2), &
6243 
6244  & answer_shape(3), &
6245 
6246  & answer_shape(4) ) &
6247  & )
6248 
6249  allocate( answer_max( &
6250  & answer_shape(1), &
6251 
6252  & answer_shape(2), &
6253 
6254  & answer_shape(3), &
6255 
6256  & answer_shape(4) ) &
6257  & )
6258 
6259  allocate( answer_min( &
6260  & answer_shape(1), &
6261 
6262  & answer_shape(2), &
6263 
6264  & answer_shape(3), &
6265 
6266  & answer_shape(4) ) &
6267  & )
6268 
6269  answer_negative = answer < 0.0
6270  check_negative = check < 0.0
6271  both_negative = answer_negative .and. check_negative
6272 
6273  where (both_negative)
6274  answer_max = &
6275  & answer &
6276  & * ( 1.0 &
6277  & - 0.1 ** significant_digits ) &
6278  & + 0.1 ** (- ignore_digits)
6279 
6280  answer_min = &
6281  & answer &
6282  & * ( 1.0 &
6283  & + 0.1 ** significant_digits ) &
6284  & - 0.1 ** (- ignore_digits)
6285  elsewhere
6286  answer_max = &
6287  & answer &
6288  & * ( 1.0 &
6289  & + 0.1 ** significant_digits ) &
6290  & + 0.1 ** (- ignore_digits)
6291 
6292  answer_min = &
6293  & answer &
6294  & * ( 1.0 &
6295  & - 0.1 ** significant_digits ) &
6296  & - 0.1 ** (- ignore_digits)
6297  end where
6298 
6299  judge = answer_max > check .and. check > answer_min
6300  judge_rev = .not. judge
6301  err_flag = any(judge_rev)
6302  mask_array = 1
6303  pos = maxloc(mask_array, judge_rev)
6304 
6305  if (err_flag) then
6306 
6307  wrong = check( &
6308  & pos(1), &
6309 
6310  & pos(2), &
6311 
6312  & pos(3), &
6313 
6314  & pos(4) )
6315 
6316  right_max = answer_max( &
6317  & pos(1), &
6318 
6319  & pos(2), &
6320 
6321  & pos(3), &
6322 
6323  & pos(4) )
6324 
6325  right_min = answer_min( &
6326  & pos(1), &
6327 
6328  & pos(2), &
6329 
6330  & pos(3), &
6331 
6332  & pos(4) )
6333 
6334  if ( right_max < right_min ) then
6335  right_tmp = right_max
6336  right_max = right_min
6337  right_min = right_tmp
6338  end if
6339 
6340  write(unit=pos_array(1), fmt="(i20)") pos(1)
6341 
6342  write(unit=pos_array(2), fmt="(i20)") pos(2)
6343 
6344  write(unit=pos_array(3), fmt="(i20)") pos(3)
6345 
6346  write(unit=pos_array(4), fmt="(i20)") pos(4)
6347 
6348 
6349  pos_str = '(' // &
6350  & trim(adjustl(pos_array(1))) // ',' // &
6351 
6352  & trim(adjustl(pos_array(2))) // ',' // &
6353 
6354  & trim(adjustl(pos_array(3))) // ',' // &
6355 
6356  & trim(adjustl(pos_array(4))) // ')'
6357 
6358  end if
6359  deallocate(mask_array, judge, judge_rev)
6360  deallocate(answer_negative, check_negative, both_negative)
6361  deallocate(answer_max, answer_min)
6362 
6363 
6364 
6365  if (err_flag) then
6366  pos_str_space = ''
6367  pos_str_len = len_trim(pos_str)
6368 
6369  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6370  write(*,*) ''
6371  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
6372  write(*,*) ' is NOT EQUAL to'
6373  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
6374  & // ' ', right_min, ' < '
6375  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
6376 
6377  call abortprogram('')
6378  else
6379  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
6380  end if
6381 
6382 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequalreal5()

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

Definition at line 3324 of file dc_test.f90.

3324  use sysdep, only: abortprogram
3325  use dc_types, only: string, token
3326  implicit none
3327  character(*), intent(in):: message
3328  real, intent(in):: answer(:,:,:,:,:)
3329  real, intent(in):: check(:,:,:,:,:)
3330  logical:: err_flag
3331  character(STRING):: pos_str
3332  real:: wrong, right
3333 
3334  integer:: answer_shape(5), check_shape(5), pos(5)
3335  logical:: consist_shape(5)
3336  character(TOKEN):: pos_array(5)
3337  integer, allocatable:: mask_array(:,:,:,:,:)
3338  logical, allocatable:: judge(:,:,:,:,:)
3339  logical, allocatable:: judge_rev(:,:,:,:,:)
3340 
3341 
3342 
3343 
3344  continue
3345  err_flag = .false.
3346 
3347 
3348  answer_shape = shape(answer)
3349  check_shape = shape(check)
3350 
3351  consist_shape = answer_shape == check_shape
3352 
3353  if (.not. all(consist_shape)) then
3354  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3355  write(*,*) ''
3356  write(*,*) ' shape of check is (', check_shape, ')'
3357  write(*,*) ' is INCORRECT'
3358  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3359 
3360  call abortprogram('')
3361  end if
3362 
3363 
3364  allocate( mask_array( &
3365  & answer_shape(1), &
3366 
3367  & answer_shape(2), &
3368 
3369  & answer_shape(3), &
3370 
3371  & answer_shape(4), &
3372 
3373  & answer_shape(5) ) &
3374  & )
3375 
3376  allocate( judge( &
3377  & answer_shape(1), &
3378 
3379  & answer_shape(2), &
3380 
3381  & answer_shape(3), &
3382 
3383  & answer_shape(4), &
3384 
3385  & answer_shape(5) ) &
3386  & )
3387 
3388  allocate( judge_rev( &
3389  & answer_shape(1), &
3390 
3391  & answer_shape(2), &
3392 
3393  & answer_shape(3), &
3394 
3395  & answer_shape(4), &
3396 
3397  & answer_shape(5) ) &
3398  & )
3399 
3400 
3401  judge = answer == check
3402 
3403 
3404 
3405  judge_rev = .not. judge
3406  err_flag = any(judge_rev)
3407  mask_array = 1
3408  pos = maxloc(mask_array, judge_rev)
3409 
3410  if (err_flag) then
3411 
3412  wrong = check( &
3413  & pos(1), &
3414 
3415  & pos(2), &
3416 
3417  & pos(3), &
3418 
3419  & pos(4), &
3420 
3421  & pos(5) )
3422 
3423  right = answer( &
3424  & pos(1), &
3425 
3426  & pos(2), &
3427 
3428  & pos(3), &
3429 
3430  & pos(4), &
3431 
3432  & pos(5) )
3433 
3434  write(unit=pos_array(1), fmt="(i20)") pos(1)
3435 
3436  write(unit=pos_array(2), fmt="(i20)") pos(2)
3437 
3438  write(unit=pos_array(3), fmt="(i20)") pos(3)
3439 
3440  write(unit=pos_array(4), fmt="(i20)") pos(4)
3441 
3442  write(unit=pos_array(5), fmt="(i20)") pos(5)
3443 
3444 
3445  pos_str = '(' // &
3446  & trim(adjustl(pos_array(1))) // ',' // &
3447 
3448  & trim(adjustl(pos_array(2))) // ',' // &
3449 
3450  & trim(adjustl(pos_array(3))) // ',' // &
3451 
3452  & trim(adjustl(pos_array(4))) // ',' // &
3453 
3454  & trim(adjustl(pos_array(5))) // ')'
3455 
3456  end if
3457  deallocate(mask_array, judge, judge_rev)
3458 
3459 
3460 
3461 
3462  if (err_flag) then
3463  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3464  write(*,*) ''
3465  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3466  write(*,*) ' is NOT EQUAL to'
3467  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3468 
3469  call abortprogram('')
3470  else
3471  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3472  end if
3473 
3474 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ 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 
)
private

Definition at line 6388 of file dc_test.f90.

6388  use sysdep, only: abortprogram
6389  use dc_types, only: string, token
6390  implicit none
6391  character(*), intent(in):: message
6392  real, intent(in):: answer(:,:,:,:,:)
6393  real, intent(in):: check(:,:,:,:,:)
6394  integer, intent(in):: significant_digits
6395  integer, intent(in):: ignore_digits
6396  logical:: err_flag
6397  character(STRING):: pos_str
6398  real:: wrong, right_max, right_min
6399  character(STRING):: pos_str_space
6400  integer:: pos_str_len
6401  real:: right_tmp
6402 
6403  integer:: answer_shape(5), check_shape(5), pos(5)
6404  logical:: consist_shape(5)
6405  character(TOKEN):: pos_array(5)
6406  integer, allocatable:: mask_array(:,:,:,:,:)
6407  logical, allocatable:: judge(:,:,:,:,:)
6408  logical, allocatable:: judge_rev(:,:,:,:,:)
6409  logical, allocatable:: answer_negative(:,:,:,:,:)
6410  logical, allocatable:: check_negative(:,:,:,:,:)
6411  logical, allocatable:: both_negative(:,:,:,:,:)
6412  real, allocatable:: answer_max(:,:,:,:,:)
6413  real, allocatable:: answer_min(:,:,:,:,:)
6414 
6415  continue
6416  err_flag = .false.
6417 
6418  if ( significant_digits < 1 ) then
6419  write(*,*) ' *** Error [AssertEQ] *** '
6420  write(*,*) ' Specify a number more than 1 to "significant_digits"'
6421  call abortprogram('')
6422  end if
6423 
6424  answer_shape = shape(answer)
6425  check_shape = shape(check)
6426 
6427  consist_shape = answer_shape == check_shape
6428 
6429  if (.not. all(consist_shape)) then
6430  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6431  write(*,*) ''
6432  write(*,*) ' shape of check is (', check_shape, ')'
6433  write(*,*) ' is INCORRECT'
6434  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
6435 
6436  call abortprogram('')
6437  end if
6438 
6439 
6440  allocate( mask_array( &
6441  & answer_shape(1), &
6442 
6443  & answer_shape(2), &
6444 
6445  & answer_shape(3), &
6446 
6447  & answer_shape(4), &
6448 
6449  & answer_shape(5) ) &
6450  & )
6451 
6452  allocate( judge( &
6453  & answer_shape(1), &
6454 
6455  & answer_shape(2), &
6456 
6457  & answer_shape(3), &
6458 
6459  & answer_shape(4), &
6460 
6461  & answer_shape(5) ) &
6462  & )
6463 
6464  allocate( judge_rev( &
6465  & answer_shape(1), &
6466 
6467  & answer_shape(2), &
6468 
6469  & answer_shape(3), &
6470 
6471  & answer_shape(4), &
6472 
6473  & answer_shape(5) ) &
6474  & )
6475 
6476  allocate( answer_negative( &
6477  & answer_shape(1), &
6478 
6479  & answer_shape(2), &
6480 
6481  & answer_shape(3), &
6482 
6483  & answer_shape(4), &
6484 
6485  & answer_shape(5) ) &
6486  & )
6487 
6488  allocate( check_negative( &
6489  & answer_shape(1), &
6490 
6491  & answer_shape(2), &
6492 
6493  & answer_shape(3), &
6494 
6495  & answer_shape(4), &
6496 
6497  & answer_shape(5) ) &
6498  & )
6499 
6500  allocate( both_negative( &
6501  & answer_shape(1), &
6502 
6503  & answer_shape(2), &
6504 
6505  & answer_shape(3), &
6506 
6507  & answer_shape(4), &
6508 
6509  & answer_shape(5) ) &
6510  & )
6511 
6512  allocate( answer_max( &
6513  & answer_shape(1), &
6514 
6515  & answer_shape(2), &
6516 
6517  & answer_shape(3), &
6518 
6519  & answer_shape(4), &
6520 
6521  & answer_shape(5) ) &
6522  & )
6523 
6524  allocate( answer_min( &
6525  & answer_shape(1), &
6526 
6527  & answer_shape(2), &
6528 
6529  & answer_shape(3), &
6530 
6531  & answer_shape(4), &
6532 
6533  & answer_shape(5) ) &
6534  & )
6535 
6536  answer_negative = answer < 0.0
6537  check_negative = check < 0.0
6538  both_negative = answer_negative .and. check_negative
6539 
6540  where (both_negative)
6541  answer_max = &
6542  & answer &
6543  & * ( 1.0 &
6544  & - 0.1 ** significant_digits ) &
6545  & + 0.1 ** (- ignore_digits)
6546 
6547  answer_min = &
6548  & answer &
6549  & * ( 1.0 &
6550  & + 0.1 ** significant_digits ) &
6551  & - 0.1 ** (- ignore_digits)
6552  elsewhere
6553  answer_max = &
6554  & answer &
6555  & * ( 1.0 &
6556  & + 0.1 ** significant_digits ) &
6557  & + 0.1 ** (- ignore_digits)
6558 
6559  answer_min = &
6560  & answer &
6561  & * ( 1.0 &
6562  & - 0.1 ** significant_digits ) &
6563  & - 0.1 ** (- ignore_digits)
6564  end where
6565 
6566  judge = answer_max > check .and. check > answer_min
6567  judge_rev = .not. judge
6568  err_flag = any(judge_rev)
6569  mask_array = 1
6570  pos = maxloc(mask_array, judge_rev)
6571 
6572  if (err_flag) then
6573 
6574  wrong = check( &
6575  & pos(1), &
6576 
6577  & pos(2), &
6578 
6579  & pos(3), &
6580 
6581  & pos(4), &
6582 
6583  & pos(5) )
6584 
6585  right_max = answer_max( &
6586  & pos(1), &
6587 
6588  & pos(2), &
6589 
6590  & pos(3), &
6591 
6592  & pos(4), &
6593 
6594  & pos(5) )
6595 
6596  right_min = answer_min( &
6597  & pos(1), &
6598 
6599  & pos(2), &
6600 
6601  & pos(3), &
6602 
6603  & pos(4), &
6604 
6605  & pos(5) )
6606 
6607  if ( right_max < right_min ) then
6608  right_tmp = right_max
6609  right_max = right_min
6610  right_min = right_tmp
6611  end if
6612 
6613  write(unit=pos_array(1), fmt="(i20)") pos(1)
6614 
6615  write(unit=pos_array(2), fmt="(i20)") pos(2)
6616 
6617  write(unit=pos_array(3), fmt="(i20)") pos(3)
6618 
6619  write(unit=pos_array(4), fmt="(i20)") pos(4)
6620 
6621  write(unit=pos_array(5), fmt="(i20)") pos(5)
6622 
6623 
6624  pos_str = '(' // &
6625  & trim(adjustl(pos_array(1))) // ',' // &
6626 
6627  & trim(adjustl(pos_array(2))) // ',' // &
6628 
6629  & trim(adjustl(pos_array(3))) // ',' // &
6630 
6631  & trim(adjustl(pos_array(4))) // ',' // &
6632 
6633  & trim(adjustl(pos_array(5))) // ')'
6634 
6635  end if
6636  deallocate(mask_array, judge, judge_rev)
6637  deallocate(answer_negative, check_negative, both_negative)
6638  deallocate(answer_max, answer_min)
6639 
6640 
6641 
6642  if (err_flag) then
6643  pos_str_space = ''
6644  pos_str_len = len_trim(pos_str)
6645 
6646  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6647  write(*,*) ''
6648  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
6649  write(*,*) ' is NOT EQUAL to'
6650  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
6651  & // ' ', right_min, ' < '
6652  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
6653 
6654  call abortprogram('')
6655  else
6656  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
6657  end if
6658 
6659 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequalreal6()

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

Definition at line 3479 of file dc_test.f90.

3479  use sysdep, only: abortprogram
3480  use dc_types, only: string, token
3481  implicit none
3482  character(*), intent(in):: message
3483  real, intent(in):: answer(:,:,:,:,:,:)
3484  real, intent(in):: check(:,:,:,:,:,:)
3485  logical:: err_flag
3486  character(STRING):: pos_str
3487  real:: wrong, right
3488 
3489  integer:: answer_shape(6), check_shape(6), pos(6)
3490  logical:: consist_shape(6)
3491  character(TOKEN):: pos_array(6)
3492  integer, allocatable:: mask_array(:,:,:,:,:,:)
3493  logical, allocatable:: judge(:,:,:,:,:,:)
3494  logical, allocatable:: judge_rev(:,:,:,:,:,:)
3495 
3496 
3497 
3498 
3499  continue
3500  err_flag = .false.
3501 
3502 
3503  answer_shape = shape(answer)
3504  check_shape = shape(check)
3505 
3506  consist_shape = answer_shape == check_shape
3507 
3508  if (.not. all(consist_shape)) then
3509  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3510  write(*,*) ''
3511  write(*,*) ' shape of check is (', check_shape, ')'
3512  write(*,*) ' is INCORRECT'
3513  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3514 
3515  call abortprogram('')
3516  end if
3517 
3518 
3519  allocate( mask_array( &
3520  & answer_shape(1), &
3521 
3522  & answer_shape(2), &
3523 
3524  & answer_shape(3), &
3525 
3526  & answer_shape(4), &
3527 
3528  & answer_shape(5), &
3529 
3530  & answer_shape(6) ) &
3531  & )
3532 
3533  allocate( judge( &
3534  & answer_shape(1), &
3535 
3536  & answer_shape(2), &
3537 
3538  & answer_shape(3), &
3539 
3540  & answer_shape(4), &
3541 
3542  & answer_shape(5), &
3543 
3544  & answer_shape(6) ) &
3545  & )
3546 
3547  allocate( judge_rev( &
3548  & answer_shape(1), &
3549 
3550  & answer_shape(2), &
3551 
3552  & answer_shape(3), &
3553 
3554  & answer_shape(4), &
3555 
3556  & answer_shape(5), &
3557 
3558  & answer_shape(6) ) &
3559  & )
3560 
3561 
3562  judge = answer == check
3563 
3564 
3565 
3566  judge_rev = .not. judge
3567  err_flag = any(judge_rev)
3568  mask_array = 1
3569  pos = maxloc(mask_array, judge_rev)
3570 
3571  if (err_flag) then
3572 
3573  wrong = check( &
3574  & pos(1), &
3575 
3576  & pos(2), &
3577 
3578  & pos(3), &
3579 
3580  & pos(4), &
3581 
3582  & pos(5), &
3583 
3584  & pos(6) )
3585 
3586  right = answer( &
3587  & pos(1), &
3588 
3589  & pos(2), &
3590 
3591  & pos(3), &
3592 
3593  & pos(4), &
3594 
3595  & pos(5), &
3596 
3597  & pos(6) )
3598 
3599  write(unit=pos_array(1), fmt="(i20)") pos(1)
3600 
3601  write(unit=pos_array(2), fmt="(i20)") pos(2)
3602 
3603  write(unit=pos_array(3), fmt="(i20)") pos(3)
3604 
3605  write(unit=pos_array(4), fmt="(i20)") pos(4)
3606 
3607  write(unit=pos_array(5), fmt="(i20)") pos(5)
3608 
3609  write(unit=pos_array(6), fmt="(i20)") pos(6)
3610 
3611 
3612  pos_str = '(' // &
3613  & trim(adjustl(pos_array(1))) // ',' // &
3614 
3615  & trim(adjustl(pos_array(2))) // ',' // &
3616 
3617  & trim(adjustl(pos_array(3))) // ',' // &
3618 
3619  & trim(adjustl(pos_array(4))) // ',' // &
3620 
3621  & trim(adjustl(pos_array(5))) // ',' // &
3622 
3623  & trim(adjustl(pos_array(6))) // ')'
3624 
3625  end if
3626  deallocate(mask_array, judge, judge_rev)
3627 
3628 
3629 
3630 
3631  if (err_flag) then
3632  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3633  write(*,*) ''
3634  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3635  write(*,*) ' is NOT EQUAL to'
3636  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3637 
3638  call abortprogram('')
3639  else
3640  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3641  end if
3642 
3643 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ 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 
)
private

Definition at line 6665 of file dc_test.f90.

6665  use sysdep, only: abortprogram
6666  use dc_types, only: string, token
6667  implicit none
6668  character(*), intent(in):: message
6669  real, intent(in):: answer(:,:,:,:,:,:)
6670  real, intent(in):: check(:,:,:,:,:,:)
6671  integer, intent(in):: significant_digits
6672  integer, intent(in):: ignore_digits
6673  logical:: err_flag
6674  character(STRING):: pos_str
6675  real:: wrong, right_max, right_min
6676  character(STRING):: pos_str_space
6677  integer:: pos_str_len
6678  real:: right_tmp
6679 
6680  integer:: answer_shape(6), check_shape(6), pos(6)
6681  logical:: consist_shape(6)
6682  character(TOKEN):: pos_array(6)
6683  integer, allocatable:: mask_array(:,:,:,:,:,:)
6684  logical, allocatable:: judge(:,:,:,:,:,:)
6685  logical, allocatable:: judge_rev(:,:,:,:,:,:)
6686  logical, allocatable:: answer_negative(:,:,:,:,:,:)
6687  logical, allocatable:: check_negative(:,:,:,:,:,:)
6688  logical, allocatable:: both_negative(:,:,:,:,:,:)
6689  real, allocatable:: answer_max(:,:,:,:,:,:)
6690  real, allocatable:: answer_min(:,:,:,:,:,:)
6691 
6692  continue
6693  err_flag = .false.
6694 
6695  if ( significant_digits < 1 ) then
6696  write(*,*) ' *** Error [AssertEQ] *** '
6697  write(*,*) ' Specify a number more than 1 to "significant_digits"'
6698  call abortprogram('')
6699  end if
6700 
6701  answer_shape = shape(answer)
6702  check_shape = shape(check)
6703 
6704  consist_shape = answer_shape == check_shape
6705 
6706  if (.not. all(consist_shape)) then
6707  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6708  write(*,*) ''
6709  write(*,*) ' shape of check is (', check_shape, ')'
6710  write(*,*) ' is INCORRECT'
6711  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
6712 
6713  call abortprogram('')
6714  end if
6715 
6716 
6717  allocate( mask_array( &
6718  & answer_shape(1), &
6719 
6720  & answer_shape(2), &
6721 
6722  & answer_shape(3), &
6723 
6724  & answer_shape(4), &
6725 
6726  & answer_shape(5), &
6727 
6728  & answer_shape(6) ) &
6729  & )
6730 
6731  allocate( judge( &
6732  & answer_shape(1), &
6733 
6734  & answer_shape(2), &
6735 
6736  & answer_shape(3), &
6737 
6738  & answer_shape(4), &
6739 
6740  & answer_shape(5), &
6741 
6742  & answer_shape(6) ) &
6743  & )
6744 
6745  allocate( judge_rev( &
6746  & answer_shape(1), &
6747 
6748  & answer_shape(2), &
6749 
6750  & answer_shape(3), &
6751 
6752  & answer_shape(4), &
6753 
6754  & answer_shape(5), &
6755 
6756  & answer_shape(6) ) &
6757  & )
6758 
6759  allocate( answer_negative( &
6760  & answer_shape(1), &
6761 
6762  & answer_shape(2), &
6763 
6764  & answer_shape(3), &
6765 
6766  & answer_shape(4), &
6767 
6768  & answer_shape(5), &
6769 
6770  & answer_shape(6) ) &
6771  & )
6772 
6773  allocate( check_negative( &
6774  & answer_shape(1), &
6775 
6776  & answer_shape(2), &
6777 
6778  & answer_shape(3), &
6779 
6780  & answer_shape(4), &
6781 
6782  & answer_shape(5), &
6783 
6784  & answer_shape(6) ) &
6785  & )
6786 
6787  allocate( both_negative( &
6788  & answer_shape(1), &
6789 
6790  & answer_shape(2), &
6791 
6792  & answer_shape(3), &
6793 
6794  & answer_shape(4), &
6795 
6796  & answer_shape(5), &
6797 
6798  & answer_shape(6) ) &
6799  & )
6800 
6801  allocate( answer_max( &
6802  & answer_shape(1), &
6803 
6804  & answer_shape(2), &
6805 
6806  & answer_shape(3), &
6807 
6808  & answer_shape(4), &
6809 
6810  & answer_shape(5), &
6811 
6812  & answer_shape(6) ) &
6813  & )
6814 
6815  allocate( answer_min( &
6816  & answer_shape(1), &
6817 
6818  & answer_shape(2), &
6819 
6820  & answer_shape(3), &
6821 
6822  & answer_shape(4), &
6823 
6824  & answer_shape(5), &
6825 
6826  & answer_shape(6) ) &
6827  & )
6828 
6829  answer_negative = answer < 0.0
6830  check_negative = check < 0.0
6831  both_negative = answer_negative .and. check_negative
6832 
6833  where (both_negative)
6834  answer_max = &
6835  & answer &
6836  & * ( 1.0 &
6837  & - 0.1 ** significant_digits ) &
6838  & + 0.1 ** (- ignore_digits)
6839 
6840  answer_min = &
6841  & answer &
6842  & * ( 1.0 &
6843  & + 0.1 ** significant_digits ) &
6844  & - 0.1 ** (- ignore_digits)
6845  elsewhere
6846  answer_max = &
6847  & answer &
6848  & * ( 1.0 &
6849  & + 0.1 ** significant_digits ) &
6850  & + 0.1 ** (- ignore_digits)
6851 
6852  answer_min = &
6853  & answer &
6854  & * ( 1.0 &
6855  & - 0.1 ** significant_digits ) &
6856  & - 0.1 ** (- ignore_digits)
6857  end where
6858 
6859  judge = answer_max > check .and. check > answer_min
6860  judge_rev = .not. judge
6861  err_flag = any(judge_rev)
6862  mask_array = 1
6863  pos = maxloc(mask_array, judge_rev)
6864 
6865  if (err_flag) then
6866 
6867  wrong = check( &
6868  & pos(1), &
6869 
6870  & pos(2), &
6871 
6872  & pos(3), &
6873 
6874  & pos(4), &
6875 
6876  & pos(5), &
6877 
6878  & pos(6) )
6879 
6880  right_max = answer_max( &
6881  & pos(1), &
6882 
6883  & pos(2), &
6884 
6885  & pos(3), &
6886 
6887  & pos(4), &
6888 
6889  & pos(5), &
6890 
6891  & pos(6) )
6892 
6893  right_min = answer_min( &
6894  & pos(1), &
6895 
6896  & pos(2), &
6897 
6898  & pos(3), &
6899 
6900  & pos(4), &
6901 
6902  & pos(5), &
6903 
6904  & pos(6) )
6905 
6906  if ( right_max < right_min ) then
6907  right_tmp = right_max
6908  right_max = right_min
6909  right_min = right_tmp
6910  end if
6911 
6912  write(unit=pos_array(1), fmt="(i20)") pos(1)
6913 
6914  write(unit=pos_array(2), fmt="(i20)") pos(2)
6915 
6916  write(unit=pos_array(3), fmt="(i20)") pos(3)
6917 
6918  write(unit=pos_array(4), fmt="(i20)") pos(4)
6919 
6920  write(unit=pos_array(5), fmt="(i20)") pos(5)
6921 
6922  write(unit=pos_array(6), fmt="(i20)") pos(6)
6923 
6924 
6925  pos_str = '(' // &
6926  & trim(adjustl(pos_array(1))) // ',' // &
6927 
6928  & trim(adjustl(pos_array(2))) // ',' // &
6929 
6930  & trim(adjustl(pos_array(3))) // ',' // &
6931 
6932  & trim(adjustl(pos_array(4))) // ',' // &
6933 
6934  & trim(adjustl(pos_array(5))) // ',' // &
6935 
6936  & trim(adjustl(pos_array(6))) // ')'
6937 
6938  end if
6939  deallocate(mask_array, judge, judge_rev)
6940  deallocate(answer_negative, check_negative, both_negative)
6941  deallocate(answer_max, answer_min)
6942 
6943 
6944 
6945  if (err_flag) then
6946  pos_str_space = ''
6947  pos_str_len = len_trim(pos_str)
6948 
6949  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6950  write(*,*) ''
6951  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
6952  write(*,*) ' is NOT EQUAL to'
6953  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
6954  & // ' ', right_min, ' < '
6955  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
6956 
6957  call abortprogram('')
6958  else
6959  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
6960  end if
6961 
6962 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ dctestassertequalreal7()

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

Definition at line 3648 of file dc_test.f90.

3648  use sysdep, only: abortprogram
3649  use dc_types, only: string, token
3650  implicit none
3651  character(*), intent(in):: message
3652  real, intent(in):: answer(:,:,:,:,:,:,:)
3653  real, intent(in):: check(:,:,:,:,:,:,:)
3654  logical:: err_flag
3655  character(STRING):: pos_str
3656  real:: wrong, right
3657 
3658  integer:: answer_shape(7), check_shape(7), pos(7)
3659  logical:: consist_shape(7)
3660  character(TOKEN):: pos_array(7)
3661  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
3662  logical, allocatable:: judge(:,:,:,:,:,:,:)
3663  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
3664 
3665 
3666 
3667 
3668  continue
3669  err_flag = .false.
3670 
3671 
3672  answer_shape = shape(answer)
3673  check_shape = shape(check)
3674 
3675  consist_shape = answer_shape == check_shape
3676 
3677  if (.not. all(consist_shape)) then
3678  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3679  write(*,*) ''
3680  write(*,*) ' shape of check is (', check_shape, ')'
3681  write(*,*) ' is INCORRECT'
3682  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3683 
3684  call abortprogram('')
3685  end if
3686 
3687 
3688  allocate( mask_array( &
3689  & answer_shape(1), &
3690 
3691  & answer_shape(2), &
3692 
3693  & answer_shape(3), &
3694 
3695  & answer_shape(4), &
3696 
3697  & answer_shape(5), &
3698 
3699  & answer_shape(6), &
3700 
3701  & answer_shape(7) ) &
3702  & )
3703 
3704  allocate( judge( &
3705  & answer_shape(1), &
3706 
3707  & answer_shape(2), &
3708 
3709  & answer_shape(3), &
3710 
3711  & answer_shape(4), &
3712 
3713  & answer_shape(5), &
3714 
3715  & answer_shape(6), &
3716 
3717  & answer_shape(7) ) &
3718  & )
3719 
3720  allocate( judge_rev( &
3721  & answer_shape(1), &
3722 
3723  & answer_shape(2), &
3724 
3725  & answer_shape(3), &
3726 
3727  & answer_shape(4), &
3728 
3729  & answer_shape(5), &
3730 
3731  & answer_shape(6), &
3732 
3733  & answer_shape(7) ) &
3734  & )
3735 
3736 
3737  judge = answer == check
3738 
3739 
3740 
3741  judge_rev = .not. judge
3742  err_flag = any(judge_rev)
3743  mask_array = 1
3744  pos = maxloc(mask_array, judge_rev)
3745 
3746  if (err_flag) then
3747 
3748  wrong = check( &
3749  & pos(1), &
3750 
3751  & pos(2), &
3752 
3753  & pos(3), &
3754 
3755  & pos(4), &
3756 
3757  & pos(5), &
3758 
3759  & pos(6), &
3760 
3761  & pos(7) )
3762 
3763  right = answer( &
3764  & pos(1), &
3765 
3766  & pos(2), &
3767 
3768  & pos(3), &
3769 
3770  & pos(4), &
3771 
3772  & pos(5), &
3773 
3774  & pos(6), &
3775 
3776  & pos(7) )
3777 
3778  write(unit=pos_array(1), fmt="(i20)") pos(1)
3779 
3780  write(unit=pos_array(2), fmt="(i20)") pos(2)
3781 
3782  write(unit=pos_array(3), fmt="(i20)") pos(3)
3783 
3784  write(unit=pos_array(4), fmt="(i20)") pos(4)
3785 
3786  write(unit=pos_array(5), fmt="(i20)") pos(5)
3787 
3788  write(unit=pos_array(6), fmt="(i20)") pos(6)
3789 
3790  write(unit=pos_array(7), fmt="(i20)") pos(7)
3791 
3792 
3793  pos_str = '(' // &
3794  & trim(adjustl(pos_array(1))) // ',' // &
3795 
3796  & trim(adjustl(pos_array(2))) // ',' // &
3797 
3798  & trim(adjustl(pos_array(3))) // ',' // &
3799 
3800  & trim(adjustl(pos_array(4))) // ',' // &
3801 
3802  & trim(adjustl(pos_array(5))) // ',' // &
3803 
3804  & trim(adjustl(pos_array(6))) // ',' // &
3805 
3806  & trim(adjustl(pos_array(7))) // ')'
3807 
3808  end if
3809  deallocate(mask_array, judge, judge_rev)
3810 
3811 
3812 
3813 
3814  if (err_flag) then
3815  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3816  write(*,*) ''
3817  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3818  write(*,*) ' is NOT EQUAL to'
3819  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3820 
3821  call abortprogram('')
3822  else
3823  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3824  end if
3825 
3826 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118

◆ 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 
)
private

Definition at line 6968 of file dc_test.f90.

6968  use sysdep, only: abortprogram
6969  use dc_types, only: string, token
6970  implicit none
6971  character(*), intent(in):: message
6972  real, intent(in):: answer(:,:,:,:,:,:,:)
6973  real, intent(in):: check(:,:,:,:,:,:,:)
6974  integer, intent(in):: significant_digits
6975  integer, intent(in):: ignore_digits
6976  logical:: err_flag
6977  character(STRING):: pos_str
6978  real:: wrong, right_max, right_min
6979  character(STRING):: pos_str_space
6980  integer:: pos_str_len
6981  real:: right_tmp
6982 
6983  integer:: answer_shape(7), check_shape(7), pos(7)
6984  logical:: consist_shape(7)
6985  character(TOKEN):: pos_array(7)
6986  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
6987  logical, allocatable:: judge(:,:,:,:,:,:,:)
6988  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
6989  logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
6990  logical, allocatable:: check_negative(:,:,:,:,:,:,:)
6991  logical, allocatable:: both_negative(:,:,:,:,:,:,:)
6992  real, allocatable:: answer_max(:,:,:,:,:,:,:)
6993  real, allocatable:: answer_min(:,:,:,:,:,:,:)
6994 
6995  continue
6996  err_flag = .false.
6997 
6998  if ( significant_digits < 1 ) then
6999  write(*,*) ' *** Error [AssertEQ] *** '
7000  write(*,*) ' Specify a number more than 1 to "significant_digits"'
7001  call abortprogram('')
7002  end if
7003 
7004  answer_shape = shape(answer)
7005  check_shape = shape(check)
7006 
7007  consist_shape = answer_shape == check_shape
7008 
7009  if (.not. all(consist_shape)) then
7010  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7011  write(*,*) ''
7012  write(*,*) ' shape of check is (', check_shape, ')'
7013  write(*,*) ' is INCORRECT'
7014  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
7015 
7016  call abortprogram('')
7017  end if
7018 
7019 
7020  allocate( mask_array( &
7021  & answer_shape(1), &
7022 
7023  & answer_shape(2), &
7024 
7025  & answer_shape(3), &
7026 
7027  & answer_shape(4), &
7028 
7029  & answer_shape(5), &
7030 
7031  & answer_shape(6), &
7032 
7033  & answer_shape(7) ) &
7034  & )
7035 
7036  allocate( judge( &
7037  & answer_shape(1), &
7038 
7039  & answer_shape(2), &
7040 
7041  & answer_shape(3), &
7042 
7043  & answer_shape(4), &
7044 
7045  & answer_shape(5), &
7046 
7047  & answer_shape(6), &
7048 
7049  & answer_shape(7) ) &
7050  & )
7051 
7052  allocate( judge_rev( &
7053  & answer_shape(1), &
7054 
7055  & answer_shape(2), &
7056 
7057  & answer_shape(3), &
7058 
7059  & answer_shape(4), &
7060 
7061  & answer_shape(5), &
7062 
7063  & answer_shape(6), &
7064 
7065  & answer_shape(7) ) &
7066  & )
7067 
7068  allocate( answer_negative( &
7069  & answer_shape(1), &
7070 
7071  & answer_shape(2), &
7072 
7073  & answer_shape(3), &
7074 
7075  & answer_shape(4), &
7076 
7077  & answer_shape(5), &
7078 
7079  & answer_shape(6), &
7080 
7081  & answer_shape(7) ) &
7082  & )
7083 
7084  allocate( check_negative( &
7085  & answer_shape(1), &
7086 
7087  & answer_shape(2), &
7088 
7089  & answer_shape(3), &
7090 
7091  & answer_shape(4), &
7092 
7093  & answer_shape(5), &
7094 
7095  & answer_shape(6), &
7096 
7097  & answer_shape(7) ) &
7098  & )
7099 
7100  allocate( both_negative( &
7101  & answer_shape(1), &
7102 
7103  & answer_shape(2), &
7104 
7105  & answer_shape(3), &
7106 
7107  & answer_shape(4), &
7108 
7109  & answer_shape(5), &
7110 
7111  & answer_shape(6), &
7112 
7113  & answer_shape(7) ) &
7114  & )
7115 
7116  allocate( answer_max( &
7117  & answer_shape(1), &
7118 
7119  & answer_shape(2), &
7120 
7121  & answer_shape(3), &
7122 
7123  & answer_shape(4), &
7124 
7125  & answer_shape(5), &
7126 
7127  & answer_shape(6), &
7128 
7129  & answer_shape(7) ) &
7130  & )
7131 
7132  allocate( answer_min( &
7133  & answer_shape(1), &
7134 
7135  & answer_shape(2), &
7136 
7137  & answer_shape(3), &
7138 
7139  & answer_shape(4), &
7140 
7141  & answer_shape(5), &
7142 
7143  & answer_shape(6), &
7144 
7145  & answer_shape(7) ) &
7146  & )
7147 
7148  answer_negative = answer < 0.0
7149  check_negative = check < 0.0
7150  both_negative = answer_negative .and. check_negative
7151 
7152  where (both_negative)
7153  answer_max = &
7154  & answer &
7155  & * ( 1.0 &
7156  & - 0.1 ** significant_digits ) &
7157  & + 0.1 ** (- ignore_digits)
7158 
7159  answer_min = &
7160  & answer &
7161  & * ( 1.0 &
7162  & + 0.1 ** significant_digits ) &
7163  & - 0.1 ** (- ignore_digits)
7164  elsewhere
7165  answer_max = &
7166  & answer &
7167  & * ( 1.0 &
7168  & + 0.1 ** significant_digits ) &
7169  & + 0.1 ** (- ignore_digits)
7170 
7171  answer_min = &
7172  & answer &
7173  & * ( 1.0 &
7174  & - 0.1 ** significant_digits ) &
7175  & - 0.1 ** (- ignore_digits)
7176  end where
7177 
7178  judge = answer_max > check .and. check > answer_min
7179  judge_rev = .not. judge
7180  err_flag = any(judge_rev)
7181  mask_array = 1
7182  pos = maxloc(mask_array, judge_rev)
7183 
7184  if (err_flag) then
7185 
7186  wrong = check( &
7187  & pos(1), &
7188 
7189  & pos(2), &
7190 
7191  & pos(3), &
7192 
7193  & pos(4), &
7194 
7195  & pos(5), &
7196 
7197  & pos(6), &
7198 
7199  & pos(7) )
7200 
7201  right_max = answer_max( &
7202  & pos(1), &
7203 
7204  & pos(2), &
7205 
7206  & pos(3), &
7207 
7208  & pos(4), &
7209 
7210  & pos(5), &
7211 
7212  & pos(6), &
7213 
7214  & pos(7) )
7215 
7216  right_min = answer_min( &
7217  & pos(1), &
7218 
7219  & pos(2), &
7220 
7221  & pos(3), &
7222 
7223  & pos(4), &
7224 
7225  & pos(5), &
7226 
7227  & pos(6), &
7228 
7229  & pos(7) )
7230 
7231  if ( right_max < right_min ) then
7232  right_tmp = right_max
7233  right_max = right_min
7234  right_min = right_tmp
7235  end if
7236 
7237  write(unit=pos_array(1), fmt="(i20)") pos(1)
7238 
7239  write(unit=pos_array(2), fmt="(i20)") pos(2)
7240 
7241  write(unit=pos_array(3), fmt="(i20)") pos(3)
7242 
7243  write(unit=pos_array(4), fmt="(i20)") pos(4)
7244 
7245  write(unit=pos_array(5), fmt="(i20)") pos(5)
7246 
7247  write(unit=pos_array(6), fmt="(i20)") pos(6)
7248 
7249  write(unit=pos_array(7), fmt="(i20)") pos(7)
7250 
7251 
7252  pos_str = '(' // &
7253  & trim(adjustl(pos_array(1))) // ',' // &
7254 
7255  & trim(adjustl(pos_array(2))) // ',' // &
7256 
7257  & trim(adjustl(pos_array(3))) // ',' // &
7258 
7259  & trim(adjustl(pos_array(4))) // ',' // &
7260 
7261  & trim(adjustl(pos_array(5))) // ',' // &
7262 
7263  & trim(adjustl(pos_array(6))) // ',' // &
7264 
7265  & trim(adjustl(pos_array(7))) // ')'
7266 
7267  end if
7268  deallocate(mask_array, judge, judge_rev)
7269  deallocate(answer_negative, check_negative, both_negative)
7270  deallocate(answer_max, answer_min)
7271 
7272 
7273 
7274  if (err_flag) then
7275  pos_str_space = ''
7276  pos_str_len = len_trim(pos_str)
7277 
7278  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7279  write(*,*) ''
7280  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
7281  write(*,*) ' is NOT EQUAL to'
7282  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
7283  & // ' ', right_min, ' < '
7284  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
7285 
7286  call abortprogram('')
7287  else
7288  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
7289  end if
7290 
7291 
dc_types::token
integer, parameter, public token
Character length for word, token.
Definition: dc_types.f90:109
dc_types
Provides kind type parameter values.
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
Character length for string.
Definition: dc_types.f90:118
The documentation for this interface was generated from the following file: