SCALE-RM
Data Types | Functions/Subroutines
dc_test Module Reference

Functions/Subroutines

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)
 
subroutine dctestassertgreaterthanint0 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanint1 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanint2 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanint3 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanint4 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanint5 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanint6 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanint7 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanreal0 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanreal1 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanreal2 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanreal3 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanreal4 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanreal5 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanreal6 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthanreal7 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthandouble0 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthandouble1 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthandouble2 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthandouble3 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthandouble4 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthandouble5 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthandouble6 (message, answer, check, negative_support)
 
subroutine dctestassertgreaterthandouble7 (message, answer, check, negative_support)
 
subroutine dctestassertlessthanint0 (message, answer, check, negative_support)
 
subroutine dctestassertlessthanint1 (message, answer, check, negative_support)
 
subroutine dctestassertlessthanint2 (message, answer, check, negative_support)
 
subroutine dctestassertlessthanint3 (message, answer, check, negative_support)
 
subroutine dctestassertlessthanint4 (message, answer, check, negative_support)
 
subroutine dctestassertlessthanint5 (message, answer, check, negative_support)
 
subroutine dctestassertlessthanint6 (message, answer, check, negative_support)
 
subroutine dctestassertlessthanint7 (message, answer, check, negative_support)
 
subroutine dctestassertlessthanreal0 (message, answer, check, negative_support)
 
subroutine dctestassertlessthanreal1 (message, answer, check, negative_support)
 
subroutine dctestassertlessthanreal2 (message, answer, check, negative_support)
 
subroutine dctestassertlessthanreal3 (message, answer, check, negative_support)
 
subroutine dctestassertlessthanreal4 (message, answer, check, negative_support)
 
subroutine dctestassertlessthanreal5 (message, answer, check, negative_support)
 
subroutine dctestassertlessthanreal6 (message, answer, check, negative_support)
 
subroutine dctestassertlessthanreal7 (message, answer, check, negative_support)
 
subroutine dctestassertlessthandouble0 (message, answer, check, negative_support)
 
subroutine dctestassertlessthandouble1 (message, answer, check, negative_support)
 
subroutine dctestassertlessthandouble2 (message, answer, check, negative_support)
 
subroutine dctestassertlessthandouble3 (message, answer, check, negative_support)
 
subroutine dctestassertlessthandouble4 (message, answer, check, negative_support)
 
subroutine dctestassertlessthandouble5 (message, answer, check, negative_support)
 
subroutine dctestassertlessthandouble6 (message, answer, check, negative_support)
 
subroutine dctestassertlessthandouble7 (message, answer, check, negative_support)
 

Function/Subroutine Documentation

◆ dctestassertequalchar1()

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

Definition at line 574 of file dc_test.f90.

References dc_types::string, and dc_types::token.

Referenced by dctestassertequallogical1().

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

◆ dctestassertequalchar2()

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

Definition at line 695 of file dc_test.f90.

References dc_types::string, and dc_types::token.

Referenced by dctestassertequallogical2().

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

◆ dctestassertequalchar3()

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

Definition at line 826 of file dc_test.f90.

References dc_types::string, and dc_types::token.

Referenced by dctestassertequallogical3().

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

◆ dctestassertequalchar4()

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

Definition at line 975 of file dc_test.f90.

References dc_types::string, and dc_types::token.

Referenced by dctestassertequallogical4().

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

◆ dctestassertequalchar5()

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

Definition at line 1142 of file dc_test.f90.

References dc_types::string, and dc_types::token.

Referenced by dctestassertequallogical5().

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

◆ dctestassertequalchar6()

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

Definition at line 1327 of file dc_test.f90.

References dc_types::string, and dc_types::token.

Referenced by dctestassertequallogical6().

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

◆ dctestassertequalchar7()

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

Definition at line 1530 of file dc_test.f90.

References dc_types::string, and dc_types::token.

Referenced by dctestassertequallogical7().

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

◆ dctestassertequalint0()

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

Definition at line 1751 of file dc_test.f90.

References dc_types::string, and dc_types::token.

1751  use dc_types, only: string, token
1752  implicit none
1753  character(*), intent(in):: message
1754  integer, intent(in):: answer
1755  integer, intent(in):: check
1756  logical:: err_flag
1757  character(STRING):: pos_str
1758  integer:: wrong, right
1759 
1760 
1761 
1762 
1763 
1764  continue
1765  err_flag = .false.
1766 
1767 
1768  err_flag = .not. answer == check
1769  wrong = check
1770  right = answer
1771  pos_str = ''
1772 
1773 
1774 
1775 
1776  if (err_flag) then
1777  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
1778  write(*,*) ''
1779  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
1780  write(*,*) ' is NOT EQUAL to'
1781  write(*,*) ' answer' // trim(pos_str) // ' = ', right
1782 
1783  call abort()
1784  else
1785  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
1786  end if
1787 
1788 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequalint1()

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

Definition at line 1793 of file dc_test.f90.

References dc_types::string, and dc_types::token.

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

◆ dctestassertequalint2()

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

Definition at line 1897 of file dc_test.f90.

References dc_types::string, and dc_types::token.

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

◆ dctestassertequalint3()

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

Definition at line 2009 of file dc_test.f90.

References dc_types::string, and dc_types::token.

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

◆ dctestassertequalint4()

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

Definition at line 2135 of file dc_test.f90.

References dc_types::string, and dc_types::token.

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

◆ dctestassertequalint5()

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

Definition at line 2275 of file dc_test.f90.

References dc_types::string, and dc_types::token.

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

◆ dctestassertequalint6()

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

Definition at line 2429 of file dc_test.f90.

References dc_types::string, and dc_types::token.

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

◆ dctestassertequalint7()

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

Definition at line 2597 of file dc_test.f90.

References dc_types::string, and dc_types::token.

2597  use dc_types, only: string, token
2598  implicit none
2599  character(*), intent(in):: message
2600  integer, intent(in):: answer(:,:,:,:,:,:,:)
2601  integer, intent(in):: check(:,:,:,:,:,:,:)
2602  logical:: err_flag
2603  character(STRING):: pos_str
2604  integer:: wrong, right
2605 
2606  integer:: answer_shape(7), check_shape(7), pos(7)
2607  logical:: consist_shape(7)
2608  character(TOKEN):: pos_array(7)
2609  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
2610  logical, allocatable:: judge(:,:,:,:,:,:,:)
2611  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
2612 
2613 
2614 
2615 
2616  continue
2617  err_flag = .false.
2618 
2619 
2620  answer_shape = shape(answer)
2621  check_shape = shape(check)
2622 
2623  consist_shape = answer_shape == check_shape
2624 
2625  if (.not. all(consist_shape)) then
2626  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2627  write(*,*) ''
2628  write(*,*) ' shape of check is (', check_shape, ')'
2629  write(*,*) ' is INCORRECT'
2630  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2631 
2632  call abort()
2633  end if
2634 
2635 
2636  allocate( mask_array( &
2637  & answer_shape(1), &
2638 
2639  & answer_shape(2), &
2640 
2641  & answer_shape(3), &
2642 
2643  & answer_shape(4), &
2644 
2645  & answer_shape(5), &
2646 
2647  & answer_shape(6), &
2648 
2649  & answer_shape(7) ) &
2650  & )
2651 
2652  allocate( judge( &
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_rev( &
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 
2685  judge = answer == check
2686 
2687 
2688 
2689  judge_rev = .not. judge
2690  err_flag = any(judge_rev)
2691  mask_array = 1
2692  pos = maxloc(mask_array, judge_rev)
2693 
2694  if (err_flag) then
2695 
2696  wrong = check( &
2697  & pos(1), &
2698 
2699  & pos(2), &
2700 
2701  & pos(3), &
2702 
2703  & pos(4), &
2704 
2705  & pos(5), &
2706 
2707  & pos(6), &
2708 
2709  & pos(7) )
2710 
2711  right = answer( &
2712  & pos(1), &
2713 
2714  & pos(2), &
2715 
2716  & pos(3), &
2717 
2718  & pos(4), &
2719 
2720  & pos(5), &
2721 
2722  & pos(6), &
2723 
2724  & pos(7) )
2725 
2726  write(unit=pos_array(1), fmt="(i20)") pos(1)
2727 
2728  write(unit=pos_array(2), fmt="(i20)") pos(2)
2729 
2730  write(unit=pos_array(3), fmt="(i20)") pos(3)
2731 
2732  write(unit=pos_array(4), fmt="(i20)") pos(4)
2733 
2734  write(unit=pos_array(5), fmt="(i20)") pos(5)
2735 
2736  write(unit=pos_array(6), fmt="(i20)") pos(6)
2737 
2738  write(unit=pos_array(7), fmt="(i20)") pos(7)
2739 
2740 
2741  pos_str = '(' // &
2742  & trim(adjustl(pos_array(1))) // ',' // &
2743 
2744  & trim(adjustl(pos_array(2))) // ',' // &
2745 
2746  & trim(adjustl(pos_array(3))) // ',' // &
2747 
2748  & trim(adjustl(pos_array(4))) // ',' // &
2749 
2750  & trim(adjustl(pos_array(5))) // ',' // &
2751 
2752  & trim(adjustl(pos_array(6))) // ',' // &
2753 
2754  & trim(adjustl(pos_array(7))) // ')'
2755 
2756  end if
2757  deallocate(mask_array, judge, judge_rev)
2758 
2759 
2760 
2761 
2762  if (err_flag) then
2763  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2764  write(*,*) ''
2765  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2766  write(*,*) ' is NOT EQUAL to'
2767  write(*,*) ' answer' // trim(pos_str) // ' = ', right
2768 
2769  call abort()
2770  else
2771  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2772  end if
2773 
2774 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequalreal0()

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

Definition at line 2779 of file dc_test.f90.

References dc_types::string, and dc_types::token.

2779  use dc_types, only: string, token
2780  implicit none
2781  character(*), intent(in):: message
2782  real, intent(in):: answer
2783  real, intent(in):: check
2784  logical:: err_flag
2785  character(STRING):: pos_str
2786  real:: wrong, right
2787 
2788 
2789 
2790 
2791 
2792  continue
2793  err_flag = .false.
2794 
2795 
2796  err_flag = .not. answer == check
2797  wrong = check
2798  right = answer
2799  pos_str = ''
2800 
2801 
2802 
2803 
2804  if (err_flag) then
2805  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2806  write(*,*) ''
2807  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2808  write(*,*) ' is NOT EQUAL to'
2809  write(*,*) ' answer' // trim(pos_str) // ' = ', right
2810 
2811  call abort()
2812  else
2813  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2814  end if
2815 
2816 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequalreal1()

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

Definition at line 2821 of file dc_test.f90.

References dc_types::string, and dc_types::token.

2821  use dc_types, only: string, token
2822  implicit none
2823  character(*), intent(in):: message
2824  real, intent(in):: answer(:)
2825  real, intent(in):: check(:)
2826  logical:: err_flag
2827  character(STRING):: pos_str
2828  real:: wrong, right
2829 
2830  integer:: answer_shape(1), check_shape(1), pos(1)
2831  logical:: consist_shape(1)
2832  character(TOKEN):: pos_array(1)
2833  integer, allocatable:: mask_array(:)
2834  logical, allocatable:: judge(:)
2835  logical, allocatable:: judge_rev(:)
2836 
2837 
2838 
2839 
2840  continue
2841  err_flag = .false.
2842 
2843 
2844  answer_shape = shape(answer)
2845  check_shape = shape(check)
2846 
2847  consist_shape = answer_shape == check_shape
2848 
2849  if (.not. all(consist_shape)) then
2850  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2851  write(*,*) ''
2852  write(*,*) ' shape of check is (', check_shape, ')'
2853  write(*,*) ' is INCORRECT'
2854  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2855 
2856  call abort()
2857  end if
2858 
2859 
2860  allocate( mask_array( &
2861 
2862  & answer_shape(1) ) &
2863  & )
2864 
2865  allocate( judge( &
2866 
2867  & answer_shape(1) ) &
2868  & )
2869 
2870  allocate( judge_rev( &
2871 
2872  & answer_shape(1) ) &
2873  & )
2874 
2875 
2876  judge = answer == check
2877 
2878 
2879 
2880  judge_rev = .not. judge
2881  err_flag = any(judge_rev)
2882  mask_array = 1
2883  pos = maxloc(mask_array, judge_rev)
2884 
2885  if (err_flag) then
2886 
2887  wrong = check( &
2888 
2889  & pos(1) )
2890 
2891  right = answer( &
2892 
2893  & pos(1) )
2894 
2895  write(unit=pos_array(1), fmt="(i20)") pos(1)
2896 
2897 
2898  pos_str = '(' // &
2899 
2900  & trim(adjustl(pos_array(1))) // ')'
2901 
2902  end if
2903  deallocate(mask_array, judge, judge_rev)
2904 
2905 
2906 
2907 
2908  if (err_flag) then
2909  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2910  write(*,*) ''
2911  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
2912  write(*,*) ' is NOT EQUAL to'
2913  write(*,*) ' answer' // trim(pos_str) // ' = ', right
2914 
2915  call abort()
2916  else
2917  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
2918  end if
2919 
2920 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequalreal2()

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

Definition at line 2925 of file dc_test.f90.

References dc_types::string, and dc_types::token.

2925  use dc_types, only: string, token
2926  implicit none
2927  character(*), intent(in):: message
2928  real, intent(in):: answer(:,:)
2929  real, intent(in):: check(:,:)
2930  logical:: err_flag
2931  character(STRING):: pos_str
2932  real:: wrong, right
2933 
2934  integer:: answer_shape(2), check_shape(2), pos(2)
2935  logical:: consist_shape(2)
2936  character(TOKEN):: pos_array(2)
2937  integer, allocatable:: mask_array(:,:)
2938  logical, allocatable:: judge(:,:)
2939  logical, allocatable:: judge_rev(:,:)
2940 
2941 
2942 
2943 
2944  continue
2945  err_flag = .false.
2946 
2947 
2948  answer_shape = shape(answer)
2949  check_shape = shape(check)
2950 
2951  consist_shape = answer_shape == check_shape
2952 
2953  if (.not. all(consist_shape)) then
2954  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
2955  write(*,*) ''
2956  write(*,*) ' shape of check is (', check_shape, ')'
2957  write(*,*) ' is INCORRECT'
2958  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
2959 
2960  call abort()
2961  end if
2962 
2963 
2964  allocate( mask_array( &
2965  & answer_shape(1), &
2966 
2967  & answer_shape(2) ) &
2968  & )
2969 
2970  allocate( judge( &
2971  & answer_shape(1), &
2972 
2973  & answer_shape(2) ) &
2974  & )
2975 
2976  allocate( judge_rev( &
2977  & answer_shape(1), &
2978 
2979  & answer_shape(2) ) &
2980  & )
2981 
2982 
2983  judge = answer == check
2984 
2985 
2986 
2987  judge_rev = .not. judge
2988  err_flag = any(judge_rev)
2989  mask_array = 1
2990  pos = maxloc(mask_array, judge_rev)
2991 
2992  if (err_flag) then
2993 
2994  wrong = check( &
2995  & pos(1), &
2996 
2997  & pos(2) )
2998 
2999  right = answer( &
3000  & pos(1), &
3001 
3002  & pos(2) )
3003 
3004  write(unit=pos_array(1), fmt="(i20)") pos(1)
3005 
3006  write(unit=pos_array(2), fmt="(i20)") pos(2)
3007 
3008 
3009  pos_str = '(' // &
3010  & trim(adjustl(pos_array(1))) // ',' // &
3011 
3012  & trim(adjustl(pos_array(2))) // ')'
3013 
3014  end if
3015  deallocate(mask_array, judge, judge_rev)
3016 
3017 
3018 
3019 
3020  if (err_flag) then
3021  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3022  write(*,*) ''
3023  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3024  write(*,*) ' is NOT EQUAL to'
3025  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3026 
3027  call abort()
3028  else
3029  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3030  end if
3031 
3032 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequalreal3()

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

Definition at line 3037 of file dc_test.f90.

References dc_types::string, and dc_types::token.

3037  use dc_types, only: string, token
3038  implicit none
3039  character(*), intent(in):: message
3040  real, intent(in):: answer(:,:,:)
3041  real, intent(in):: check(:,:,:)
3042  logical:: err_flag
3043  character(STRING):: pos_str
3044  real:: wrong, right
3045 
3046  integer:: answer_shape(3), check_shape(3), pos(3)
3047  logical:: consist_shape(3)
3048  character(TOKEN):: pos_array(3)
3049  integer, allocatable:: mask_array(:,:,:)
3050  logical, allocatable:: judge(:,:,:)
3051  logical, allocatable:: judge_rev(:,:,:)
3052 
3053 
3054 
3055 
3056  continue
3057  err_flag = .false.
3058 
3059 
3060  answer_shape = shape(answer)
3061  check_shape = shape(check)
3062 
3063  consist_shape = answer_shape == check_shape
3064 
3065  if (.not. all(consist_shape)) then
3066  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3067  write(*,*) ''
3068  write(*,*) ' shape of check is (', check_shape, ')'
3069  write(*,*) ' is INCORRECT'
3070  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3071 
3072  call abort()
3073  end if
3074 
3075 
3076  allocate( mask_array( &
3077  & answer_shape(1), &
3078 
3079  & answer_shape(2), &
3080 
3081  & answer_shape(3) ) &
3082  & )
3083 
3084  allocate( judge( &
3085  & answer_shape(1), &
3086 
3087  & answer_shape(2), &
3088 
3089  & answer_shape(3) ) &
3090  & )
3091 
3092  allocate( judge_rev( &
3093  & answer_shape(1), &
3094 
3095  & answer_shape(2), &
3096 
3097  & answer_shape(3) ) &
3098  & )
3099 
3100 
3101  judge = answer == check
3102 
3103 
3104 
3105  judge_rev = .not. judge
3106  err_flag = any(judge_rev)
3107  mask_array = 1
3108  pos = maxloc(mask_array, judge_rev)
3109 
3110  if (err_flag) then
3111 
3112  wrong = check( &
3113  & pos(1), &
3114 
3115  & pos(2), &
3116 
3117  & pos(3) )
3118 
3119  right = answer( &
3120  & pos(1), &
3121 
3122  & pos(2), &
3123 
3124  & pos(3) )
3125 
3126  write(unit=pos_array(1), fmt="(i20)") pos(1)
3127 
3128  write(unit=pos_array(2), fmt="(i20)") pos(2)
3129 
3130  write(unit=pos_array(3), fmt="(i20)") pos(3)
3131 
3132 
3133  pos_str = '(' // &
3134  & trim(adjustl(pos_array(1))) // ',' // &
3135 
3136  & trim(adjustl(pos_array(2))) // ',' // &
3137 
3138  & trim(adjustl(pos_array(3))) // ')'
3139 
3140  end if
3141  deallocate(mask_array, judge, judge_rev)
3142 
3143 
3144 
3145 
3146  if (err_flag) then
3147  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3148  write(*,*) ''
3149  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3150  write(*,*) ' is NOT EQUAL to'
3151  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3152 
3153  call abort()
3154  else
3155  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3156  end if
3157 
3158 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequalreal4()

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

Definition at line 3163 of file dc_test.f90.

References dc_types::string, and dc_types::token.

3163  use dc_types, only: string, token
3164  implicit none
3165  character(*), intent(in):: message
3166  real, intent(in):: answer(:,:,:,:)
3167  real, intent(in):: check(:,:,:,:)
3168  logical:: err_flag
3169  character(STRING):: pos_str
3170  real:: wrong, right
3171 
3172  integer:: answer_shape(4), check_shape(4), pos(4)
3173  logical:: consist_shape(4)
3174  character(TOKEN):: pos_array(4)
3175  integer, allocatable:: mask_array(:,:,:,:)
3176  logical, allocatable:: judge(:,:,:,:)
3177  logical, allocatable:: judge_rev(:,:,:,:)
3178 
3179 
3180 
3181 
3182  continue
3183  err_flag = .false.
3184 
3185 
3186  answer_shape = shape(answer)
3187  check_shape = shape(check)
3188 
3189  consist_shape = answer_shape == check_shape
3190 
3191  if (.not. all(consist_shape)) then
3192  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3193  write(*,*) ''
3194  write(*,*) ' shape of check is (', check_shape, ')'
3195  write(*,*) ' is INCORRECT'
3196  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3197 
3198  call abort()
3199  end if
3200 
3201 
3202  allocate( mask_array( &
3203  & answer_shape(1), &
3204 
3205  & answer_shape(2), &
3206 
3207  & answer_shape(3), &
3208 
3209  & answer_shape(4) ) &
3210  & )
3211 
3212  allocate( judge( &
3213  & answer_shape(1), &
3214 
3215  & answer_shape(2), &
3216 
3217  & answer_shape(3), &
3218 
3219  & answer_shape(4) ) &
3220  & )
3221 
3222  allocate( judge_rev( &
3223  & answer_shape(1), &
3224 
3225  & answer_shape(2), &
3226 
3227  & answer_shape(3), &
3228 
3229  & answer_shape(4) ) &
3230  & )
3231 
3232 
3233  judge = answer == check
3234 
3235 
3236 
3237  judge_rev = .not. judge
3238  err_flag = any(judge_rev)
3239  mask_array = 1
3240  pos = maxloc(mask_array, judge_rev)
3241 
3242  if (err_flag) then
3243 
3244  wrong = check( &
3245  & pos(1), &
3246 
3247  & pos(2), &
3248 
3249  & pos(3), &
3250 
3251  & pos(4) )
3252 
3253  right = answer( &
3254  & pos(1), &
3255 
3256  & pos(2), &
3257 
3258  & pos(3), &
3259 
3260  & pos(4) )
3261 
3262  write(unit=pos_array(1), fmt="(i20)") pos(1)
3263 
3264  write(unit=pos_array(2), fmt="(i20)") pos(2)
3265 
3266  write(unit=pos_array(3), fmt="(i20)") pos(3)
3267 
3268  write(unit=pos_array(4), fmt="(i20)") pos(4)
3269 
3270 
3271  pos_str = '(' // &
3272  & trim(adjustl(pos_array(1))) // ',' // &
3273 
3274  & trim(adjustl(pos_array(2))) // ',' // &
3275 
3276  & trim(adjustl(pos_array(3))) // ',' // &
3277 
3278  & trim(adjustl(pos_array(4))) // ')'
3279 
3280  end if
3281  deallocate(mask_array, judge, judge_rev)
3282 
3283 
3284 
3285 
3286  if (err_flag) then
3287  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3288  write(*,*) ''
3289  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3290  write(*,*) ' is NOT EQUAL to'
3291  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3292 
3293  call abort()
3294  else
3295  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3296  end if
3297 
3298 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequalreal5()

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

Definition at line 3303 of file dc_test.f90.

References dc_types::string, and dc_types::token.

3303  use dc_types, only: string, token
3304  implicit none
3305  character(*), intent(in):: message
3306  real, intent(in):: answer(:,:,:,:,:)
3307  real, intent(in):: check(:,:,:,:,:)
3308  logical:: err_flag
3309  character(STRING):: pos_str
3310  real:: wrong, right
3311 
3312  integer:: answer_shape(5), check_shape(5), pos(5)
3313  logical:: consist_shape(5)
3314  character(TOKEN):: pos_array(5)
3315  integer, allocatable:: mask_array(:,:,:,:,:)
3316  logical, allocatable:: judge(:,:,:,:,:)
3317  logical, allocatable:: judge_rev(:,:,:,:,:)
3318 
3319 
3320 
3321 
3322  continue
3323  err_flag = .false.
3324 
3325 
3326  answer_shape = shape(answer)
3327  check_shape = shape(check)
3328 
3329  consist_shape = answer_shape == check_shape
3330 
3331  if (.not. all(consist_shape)) then
3332  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3333  write(*,*) ''
3334  write(*,*) ' shape of check is (', check_shape, ')'
3335  write(*,*) ' is INCORRECT'
3336  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3337 
3338  call abort()
3339  end if
3340 
3341 
3342  allocate( mask_array( &
3343  & answer_shape(1), &
3344 
3345  & answer_shape(2), &
3346 
3347  & answer_shape(3), &
3348 
3349  & answer_shape(4), &
3350 
3351  & answer_shape(5) ) &
3352  & )
3353 
3354  allocate( judge( &
3355  & answer_shape(1), &
3356 
3357  & answer_shape(2), &
3358 
3359  & answer_shape(3), &
3360 
3361  & answer_shape(4), &
3362 
3363  & answer_shape(5) ) &
3364  & )
3365 
3366  allocate( judge_rev( &
3367  & answer_shape(1), &
3368 
3369  & answer_shape(2), &
3370 
3371  & answer_shape(3), &
3372 
3373  & answer_shape(4), &
3374 
3375  & answer_shape(5) ) &
3376  & )
3377 
3378 
3379  judge = answer == check
3380 
3381 
3382 
3383  judge_rev = .not. judge
3384  err_flag = any(judge_rev)
3385  mask_array = 1
3386  pos = maxloc(mask_array, judge_rev)
3387 
3388  if (err_flag) then
3389 
3390  wrong = check( &
3391  & pos(1), &
3392 
3393  & pos(2), &
3394 
3395  & pos(3), &
3396 
3397  & pos(4), &
3398 
3399  & pos(5) )
3400 
3401  right = answer( &
3402  & pos(1), &
3403 
3404  & pos(2), &
3405 
3406  & pos(3), &
3407 
3408  & pos(4), &
3409 
3410  & pos(5) )
3411 
3412  write(unit=pos_array(1), fmt="(i20)") pos(1)
3413 
3414  write(unit=pos_array(2), fmt="(i20)") pos(2)
3415 
3416  write(unit=pos_array(3), fmt="(i20)") pos(3)
3417 
3418  write(unit=pos_array(4), fmt="(i20)") pos(4)
3419 
3420  write(unit=pos_array(5), fmt="(i20)") pos(5)
3421 
3422 
3423  pos_str = '(' // &
3424  & trim(adjustl(pos_array(1))) // ',' // &
3425 
3426  & trim(adjustl(pos_array(2))) // ',' // &
3427 
3428  & trim(adjustl(pos_array(3))) // ',' // &
3429 
3430  & trim(adjustl(pos_array(4))) // ',' // &
3431 
3432  & trim(adjustl(pos_array(5))) // ')'
3433 
3434  end if
3435  deallocate(mask_array, judge, judge_rev)
3436 
3437 
3438 
3439 
3440  if (err_flag) then
3441  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3442  write(*,*) ''
3443  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3444  write(*,*) ' is NOT EQUAL to'
3445  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3446 
3447  call abort()
3448  else
3449  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3450  end if
3451 
3452 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequalreal6()

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

Definition at line 3457 of file dc_test.f90.

References dc_types::string, and dc_types::token.

3457  use dc_types, only: string, token
3458  implicit none
3459  character(*), intent(in):: message
3460  real, intent(in):: answer(:,:,:,:,:,:)
3461  real, intent(in):: check(:,:,:,:,:,:)
3462  logical:: err_flag
3463  character(STRING):: pos_str
3464  real:: wrong, right
3465 
3466  integer:: answer_shape(6), check_shape(6), pos(6)
3467  logical:: consist_shape(6)
3468  character(TOKEN):: pos_array(6)
3469  integer, allocatable:: mask_array(:,:,:,:,:,:)
3470  logical, allocatable:: judge(:,:,:,:,:,:)
3471  logical, allocatable:: judge_rev(:,:,:,:,:,:)
3472 
3473 
3474 
3475 
3476  continue
3477  err_flag = .false.
3478 
3479 
3480  answer_shape = shape(answer)
3481  check_shape = shape(check)
3482 
3483  consist_shape = answer_shape == check_shape
3484 
3485  if (.not. all(consist_shape)) then
3486  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3487  write(*,*) ''
3488  write(*,*) ' shape of check is (', check_shape, ')'
3489  write(*,*) ' is INCORRECT'
3490  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3491 
3492  call abort()
3493  end if
3494 
3495 
3496  allocate( mask_array( &
3497  & answer_shape(1), &
3498 
3499  & answer_shape(2), &
3500 
3501  & answer_shape(3), &
3502 
3503  & answer_shape(4), &
3504 
3505  & answer_shape(5), &
3506 
3507  & answer_shape(6) ) &
3508  & )
3509 
3510  allocate( judge( &
3511  & answer_shape(1), &
3512 
3513  & answer_shape(2), &
3514 
3515  & answer_shape(3), &
3516 
3517  & answer_shape(4), &
3518 
3519  & answer_shape(5), &
3520 
3521  & answer_shape(6) ) &
3522  & )
3523 
3524  allocate( judge_rev( &
3525  & answer_shape(1), &
3526 
3527  & answer_shape(2), &
3528 
3529  & answer_shape(3), &
3530 
3531  & answer_shape(4), &
3532 
3533  & answer_shape(5), &
3534 
3535  & answer_shape(6) ) &
3536  & )
3537 
3538 
3539  judge = answer == check
3540 
3541 
3542 
3543  judge_rev = .not. judge
3544  err_flag = any(judge_rev)
3545  mask_array = 1
3546  pos = maxloc(mask_array, judge_rev)
3547 
3548  if (err_flag) then
3549 
3550  wrong = check( &
3551  & pos(1), &
3552 
3553  & pos(2), &
3554 
3555  & pos(3), &
3556 
3557  & pos(4), &
3558 
3559  & pos(5), &
3560 
3561  & pos(6) )
3562 
3563  right = answer( &
3564  & pos(1), &
3565 
3566  & pos(2), &
3567 
3568  & pos(3), &
3569 
3570  & pos(4), &
3571 
3572  & pos(5), &
3573 
3574  & pos(6) )
3575 
3576  write(unit=pos_array(1), fmt="(i20)") pos(1)
3577 
3578  write(unit=pos_array(2), fmt="(i20)") pos(2)
3579 
3580  write(unit=pos_array(3), fmt="(i20)") pos(3)
3581 
3582  write(unit=pos_array(4), fmt="(i20)") pos(4)
3583 
3584  write(unit=pos_array(5), fmt="(i20)") pos(5)
3585 
3586  write(unit=pos_array(6), fmt="(i20)") pos(6)
3587 
3588 
3589  pos_str = '(' // &
3590  & trim(adjustl(pos_array(1))) // ',' // &
3591 
3592  & trim(adjustl(pos_array(2))) // ',' // &
3593 
3594  & trim(adjustl(pos_array(3))) // ',' // &
3595 
3596  & trim(adjustl(pos_array(4))) // ',' // &
3597 
3598  & trim(adjustl(pos_array(5))) // ',' // &
3599 
3600  & trim(adjustl(pos_array(6))) // ')'
3601 
3602  end if
3603  deallocate(mask_array, judge, judge_rev)
3604 
3605 
3606 
3607 
3608  if (err_flag) then
3609  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3610  write(*,*) ''
3611  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3612  write(*,*) ' is NOT EQUAL to'
3613  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3614 
3615  call abort()
3616  else
3617  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3618  end if
3619 
3620 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequalreal7()

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

Definition at line 3625 of file dc_test.f90.

References dc_types::string, and dc_types::token.

3625  use dc_types, only: string, token
3626  implicit none
3627  character(*), intent(in):: message
3628  real, intent(in):: answer(:,:,:,:,:,:,:)
3629  real, intent(in):: check(:,:,:,:,:,:,:)
3630  logical:: err_flag
3631  character(STRING):: pos_str
3632  real:: wrong, right
3633 
3634  integer:: answer_shape(7), check_shape(7), pos(7)
3635  logical:: consist_shape(7)
3636  character(TOKEN):: pos_array(7)
3637  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
3638  logical, allocatable:: judge(:,:,:,:,:,:,:)
3639  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
3640 
3641 
3642 
3643 
3644  continue
3645  err_flag = .false.
3646 
3647 
3648  answer_shape = shape(answer)
3649  check_shape = shape(check)
3650 
3651  consist_shape = answer_shape == check_shape
3652 
3653  if (.not. all(consist_shape)) then
3654  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3655  write(*,*) ''
3656  write(*,*) ' shape of check is (', check_shape, ')'
3657  write(*,*) ' is INCORRECT'
3658  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3659 
3660  call abort()
3661  end if
3662 
3663 
3664  allocate( mask_array( &
3665  & answer_shape(1), &
3666 
3667  & answer_shape(2), &
3668 
3669  & answer_shape(3), &
3670 
3671  & answer_shape(4), &
3672 
3673  & answer_shape(5), &
3674 
3675  & answer_shape(6), &
3676 
3677  & answer_shape(7) ) &
3678  & )
3679 
3680  allocate( judge( &
3681  & answer_shape(1), &
3682 
3683  & answer_shape(2), &
3684 
3685  & answer_shape(3), &
3686 
3687  & answer_shape(4), &
3688 
3689  & answer_shape(5), &
3690 
3691  & answer_shape(6), &
3692 
3693  & answer_shape(7) ) &
3694  & )
3695 
3696  allocate( judge_rev( &
3697  & answer_shape(1), &
3698 
3699  & answer_shape(2), &
3700 
3701  & answer_shape(3), &
3702 
3703  & answer_shape(4), &
3704 
3705  & answer_shape(5), &
3706 
3707  & answer_shape(6), &
3708 
3709  & answer_shape(7) ) &
3710  & )
3711 
3712 
3713  judge = answer == check
3714 
3715 
3716 
3717  judge_rev = .not. judge
3718  err_flag = any(judge_rev)
3719  mask_array = 1
3720  pos = maxloc(mask_array, judge_rev)
3721 
3722  if (err_flag) then
3723 
3724  wrong = check( &
3725  & pos(1), &
3726 
3727  & pos(2), &
3728 
3729  & pos(3), &
3730 
3731  & pos(4), &
3732 
3733  & pos(5), &
3734 
3735  & pos(6), &
3736 
3737  & pos(7) )
3738 
3739  right = answer( &
3740  & pos(1), &
3741 
3742  & pos(2), &
3743 
3744  & pos(3), &
3745 
3746  & pos(4), &
3747 
3748  & pos(5), &
3749 
3750  & pos(6), &
3751 
3752  & pos(7) )
3753 
3754  write(unit=pos_array(1), fmt="(i20)") pos(1)
3755 
3756  write(unit=pos_array(2), fmt="(i20)") pos(2)
3757 
3758  write(unit=pos_array(3), fmt="(i20)") pos(3)
3759 
3760  write(unit=pos_array(4), fmt="(i20)") pos(4)
3761 
3762  write(unit=pos_array(5), fmt="(i20)") pos(5)
3763 
3764  write(unit=pos_array(6), fmt="(i20)") pos(6)
3765 
3766  write(unit=pos_array(7), fmt="(i20)") pos(7)
3767 
3768 
3769  pos_str = '(' // &
3770  & trim(adjustl(pos_array(1))) // ',' // &
3771 
3772  & trim(adjustl(pos_array(2))) // ',' // &
3773 
3774  & trim(adjustl(pos_array(3))) // ',' // &
3775 
3776  & trim(adjustl(pos_array(4))) // ',' // &
3777 
3778  & trim(adjustl(pos_array(5))) // ',' // &
3779 
3780  & trim(adjustl(pos_array(6))) // ',' // &
3781 
3782  & trim(adjustl(pos_array(7))) // ')'
3783 
3784  end if
3785  deallocate(mask_array, judge, judge_rev)
3786 
3787 
3788 
3789 
3790  if (err_flag) then
3791  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3792  write(*,*) ''
3793  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3794  write(*,*) ' is NOT EQUAL to'
3795  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3796 
3797  call abort()
3798  else
3799  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3800  end if
3801 
3802 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequaldouble0()

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

Definition at line 3807 of file dc_test.f90.

References dc_types::string, and dc_types::token.

3807  use dc_types, only: string, token
3808  implicit none
3809  character(*), intent(in):: message
3810  real(DP), intent(in):: answer
3811  real(DP), intent(in):: check
3812  logical:: err_flag
3813  character(STRING):: pos_str
3814  real(DP):: wrong, right
3815 
3816 
3817 
3818 
3819 
3820  continue
3821  err_flag = .false.
3822 
3823 
3824  err_flag = .not. answer == check
3825  wrong = check
3826  right = answer
3827  pos_str = ''
3828 
3829 
3830 
3831 
3832  if (err_flag) then
3833  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3834  write(*,*) ''
3835  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3836  write(*,*) ' is NOT EQUAL to'
3837  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3838 
3839  call abort()
3840  else
3841  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3842  end if
3843 
3844 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequaldouble1()

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

Definition at line 3849 of file dc_test.f90.

References dc_types::string, and dc_types::token.

3849  use dc_types, only: string, token
3850  implicit none
3851  character(*), intent(in):: message
3852  real(DP), intent(in):: answer(:)
3853  real(DP), intent(in):: check(:)
3854  logical:: err_flag
3855  character(STRING):: pos_str
3856  real(DP):: wrong, right
3857 
3858  integer:: answer_shape(1), check_shape(1), pos(1)
3859  logical:: consist_shape(1)
3860  character(TOKEN):: pos_array(1)
3861  integer, allocatable:: mask_array(:)
3862  logical, allocatable:: judge(:)
3863  logical, allocatable:: judge_rev(:)
3864 
3865 
3866 
3867 
3868  continue
3869  err_flag = .false.
3870 
3871 
3872  answer_shape = shape(answer)
3873  check_shape = shape(check)
3874 
3875  consist_shape = answer_shape == check_shape
3876 
3877  if (.not. all(consist_shape)) then
3878  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3879  write(*,*) ''
3880  write(*,*) ' shape of check is (', check_shape, ')'
3881  write(*,*) ' is INCORRECT'
3882  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3883 
3884  call abort()
3885  end if
3886 
3887 
3888  allocate( mask_array( &
3889 
3890  & answer_shape(1) ) &
3891  & )
3892 
3893  allocate( judge( &
3894 
3895  & answer_shape(1) ) &
3896  & )
3897 
3898  allocate( judge_rev( &
3899 
3900  & answer_shape(1) ) &
3901  & )
3902 
3903 
3904  judge = answer == check
3905 
3906 
3907 
3908  judge_rev = .not. judge
3909  err_flag = any(judge_rev)
3910  mask_array = 1
3911  pos = maxloc(mask_array, judge_rev)
3912 
3913  if (err_flag) then
3914 
3915  wrong = check( &
3916 
3917  & pos(1) )
3918 
3919  right = answer( &
3920 
3921  & pos(1) )
3922 
3923  write(unit=pos_array(1), fmt="(i20)") pos(1)
3924 
3925 
3926  pos_str = '(' // &
3927 
3928  & trim(adjustl(pos_array(1))) // ')'
3929 
3930  end if
3931  deallocate(mask_array, judge, judge_rev)
3932 
3933 
3934 
3935 
3936  if (err_flag) then
3937  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3938  write(*,*) ''
3939  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
3940  write(*,*) ' is NOT EQUAL to'
3941  write(*,*) ' answer' // trim(pos_str) // ' = ', right
3942 
3943  call abort()
3944  else
3945  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
3946  end if
3947 
3948 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequaldouble2()

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

Definition at line 3953 of file dc_test.f90.

References dc_types::string, and dc_types::token.

3953  use dc_types, only: string, token
3954  implicit none
3955  character(*), intent(in):: message
3956  real(DP), intent(in):: answer(:,:)
3957  real(DP), intent(in):: check(:,:)
3958  logical:: err_flag
3959  character(STRING):: pos_str
3960  real(DP):: wrong, right
3961 
3962  integer:: answer_shape(2), check_shape(2), pos(2)
3963  logical:: consist_shape(2)
3964  character(TOKEN):: pos_array(2)
3965  integer, allocatable:: mask_array(:,:)
3966  logical, allocatable:: judge(:,:)
3967  logical, allocatable:: judge_rev(:,:)
3968 
3969 
3970 
3971 
3972  continue
3973  err_flag = .false.
3974 
3975 
3976  answer_shape = shape(answer)
3977  check_shape = shape(check)
3978 
3979  consist_shape = answer_shape == check_shape
3980 
3981  if (.not. all(consist_shape)) then
3982  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
3983  write(*,*) ''
3984  write(*,*) ' shape of check is (', check_shape, ')'
3985  write(*,*) ' is INCORRECT'
3986  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
3987 
3988  call abort()
3989  end if
3990 
3991 
3992  allocate( mask_array( &
3993  & answer_shape(1), &
3994 
3995  & answer_shape(2) ) &
3996  & )
3997 
3998  allocate( judge( &
3999  & answer_shape(1), &
4000 
4001  & answer_shape(2) ) &
4002  & )
4003 
4004  allocate( judge_rev( &
4005  & answer_shape(1), &
4006 
4007  & answer_shape(2) ) &
4008  & )
4009 
4010 
4011  judge = answer == check
4012 
4013 
4014 
4015  judge_rev = .not. judge
4016  err_flag = any(judge_rev)
4017  mask_array = 1
4018  pos = maxloc(mask_array, judge_rev)
4019 
4020  if (err_flag) then
4021 
4022  wrong = check( &
4023  & pos(1), &
4024 
4025  & pos(2) )
4026 
4027  right = answer( &
4028  & pos(1), &
4029 
4030  & pos(2) )
4031 
4032  write(unit=pos_array(1), fmt="(i20)") pos(1)
4033 
4034  write(unit=pos_array(2), fmt="(i20)") pos(2)
4035 
4036 
4037  pos_str = '(' // &
4038  & trim(adjustl(pos_array(1))) // ',' // &
4039 
4040  & trim(adjustl(pos_array(2))) // ')'
4041 
4042  end if
4043  deallocate(mask_array, judge, judge_rev)
4044 
4045 
4046 
4047 
4048  if (err_flag) then
4049  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4050  write(*,*) ''
4051  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
4052  write(*,*) ' is NOT EQUAL to'
4053  write(*,*) ' answer' // trim(pos_str) // ' = ', right
4054 
4055  call abort()
4056  else
4057  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
4058  end if
4059 
4060 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequaldouble3()

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

Definition at line 4065 of file dc_test.f90.

References dc_types::string, and dc_types::token.

4065  use dc_types, only: string, token
4066  implicit none
4067  character(*), intent(in):: message
4068  real(DP), intent(in):: answer(:,:,:)
4069  real(DP), intent(in):: check(:,:,:)
4070  logical:: err_flag
4071  character(STRING):: pos_str
4072  real(DP):: wrong, right
4073 
4074  integer:: answer_shape(3), check_shape(3), pos(3)
4075  logical:: consist_shape(3)
4076  character(TOKEN):: pos_array(3)
4077  integer, allocatable:: mask_array(:,:,:)
4078  logical, allocatable:: judge(:,:,:)
4079  logical, allocatable:: judge_rev(:,:,:)
4080 
4081 
4082 
4083 
4084  continue
4085  err_flag = .false.
4086 
4087 
4088  answer_shape = shape(answer)
4089  check_shape = shape(check)
4090 
4091  consist_shape = answer_shape == check_shape
4092 
4093  if (.not. all(consist_shape)) then
4094  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4095  write(*,*) ''
4096  write(*,*) ' shape of check is (', check_shape, ')'
4097  write(*,*) ' is INCORRECT'
4098  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
4099 
4100  call abort()
4101  end if
4102 
4103 
4104  allocate( mask_array( &
4105  & answer_shape(1), &
4106 
4107  & answer_shape(2), &
4108 
4109  & answer_shape(3) ) &
4110  & )
4111 
4112  allocate( judge( &
4113  & answer_shape(1), &
4114 
4115  & answer_shape(2), &
4116 
4117  & answer_shape(3) ) &
4118  & )
4119 
4120  allocate( judge_rev( &
4121  & answer_shape(1), &
4122 
4123  & answer_shape(2), &
4124 
4125  & answer_shape(3) ) &
4126  & )
4127 
4128 
4129  judge = answer == check
4130 
4131 
4132 
4133  judge_rev = .not. judge
4134  err_flag = any(judge_rev)
4135  mask_array = 1
4136  pos = maxloc(mask_array, judge_rev)
4137 
4138  if (err_flag) then
4139 
4140  wrong = check( &
4141  & pos(1), &
4142 
4143  & pos(2), &
4144 
4145  & pos(3) )
4146 
4147  right = answer( &
4148  & pos(1), &
4149 
4150  & pos(2), &
4151 
4152  & pos(3) )
4153 
4154  write(unit=pos_array(1), fmt="(i20)") pos(1)
4155 
4156  write(unit=pos_array(2), fmt="(i20)") pos(2)
4157 
4158  write(unit=pos_array(3), fmt="(i20)") pos(3)
4159 
4160 
4161  pos_str = '(' // &
4162  & trim(adjustl(pos_array(1))) // ',' // &
4163 
4164  & trim(adjustl(pos_array(2))) // ',' // &
4165 
4166  & trim(adjustl(pos_array(3))) // ')'
4167 
4168  end if
4169  deallocate(mask_array, judge, judge_rev)
4170 
4171 
4172 
4173 
4174  if (err_flag) then
4175  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4176  write(*,*) ''
4177  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
4178  write(*,*) ' is NOT EQUAL to'
4179  write(*,*) ' answer' // trim(pos_str) // ' = ', right
4180 
4181  call abort()
4182  else
4183  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
4184  end if
4185 
4186 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequaldouble4()

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

Definition at line 4191 of file dc_test.f90.

References dc_types::string, and dc_types::token.

4191  use dc_types, only: string, token
4192  implicit none
4193  character(*), intent(in):: message
4194  real(DP), intent(in):: answer(:,:,:,:)
4195  real(DP), intent(in):: check(:,:,:,:)
4196  logical:: err_flag
4197  character(STRING):: pos_str
4198  real(DP):: wrong, right
4199 
4200  integer:: answer_shape(4), check_shape(4), pos(4)
4201  logical:: consist_shape(4)
4202  character(TOKEN):: pos_array(4)
4203  integer, allocatable:: mask_array(:,:,:,:)
4204  logical, allocatable:: judge(:,:,:,:)
4205  logical, allocatable:: judge_rev(:,:,:,:)
4206 
4207 
4208 
4209 
4210  continue
4211  err_flag = .false.
4212 
4213 
4214  answer_shape = shape(answer)
4215  check_shape = shape(check)
4216 
4217  consist_shape = answer_shape == check_shape
4218 
4219  if (.not. all(consist_shape)) then
4220  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4221  write(*,*) ''
4222  write(*,*) ' shape of check is (', check_shape, ')'
4223  write(*,*) ' is INCORRECT'
4224  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
4225 
4226  call abort()
4227  end if
4228 
4229 
4230  allocate( mask_array( &
4231  & answer_shape(1), &
4232 
4233  & answer_shape(2), &
4234 
4235  & answer_shape(3), &
4236 
4237  & answer_shape(4) ) &
4238  & )
4239 
4240  allocate( judge( &
4241  & answer_shape(1), &
4242 
4243  & answer_shape(2), &
4244 
4245  & answer_shape(3), &
4246 
4247  & answer_shape(4) ) &
4248  & )
4249 
4250  allocate( judge_rev( &
4251  & answer_shape(1), &
4252 
4253  & answer_shape(2), &
4254 
4255  & answer_shape(3), &
4256 
4257  & answer_shape(4) ) &
4258  & )
4259 
4260 
4261  judge = answer == check
4262 
4263 
4264 
4265  judge_rev = .not. judge
4266  err_flag = any(judge_rev)
4267  mask_array = 1
4268  pos = maxloc(mask_array, judge_rev)
4269 
4270  if (err_flag) then
4271 
4272  wrong = check( &
4273  & pos(1), &
4274 
4275  & pos(2), &
4276 
4277  & pos(3), &
4278 
4279  & pos(4) )
4280 
4281  right = answer( &
4282  & pos(1), &
4283 
4284  & pos(2), &
4285 
4286  & pos(3), &
4287 
4288  & pos(4) )
4289 
4290  write(unit=pos_array(1), fmt="(i20)") pos(1)
4291 
4292  write(unit=pos_array(2), fmt="(i20)") pos(2)
4293 
4294  write(unit=pos_array(3), fmt="(i20)") pos(3)
4295 
4296  write(unit=pos_array(4), fmt="(i20)") pos(4)
4297 
4298 
4299  pos_str = '(' // &
4300  & trim(adjustl(pos_array(1))) // ',' // &
4301 
4302  & trim(adjustl(pos_array(2))) // ',' // &
4303 
4304  & trim(adjustl(pos_array(3))) // ',' // &
4305 
4306  & trim(adjustl(pos_array(4))) // ')'
4307 
4308  end if
4309  deallocate(mask_array, judge, judge_rev)
4310 
4311 
4312 
4313 
4314  if (err_flag) then
4315  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4316  write(*,*) ''
4317  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
4318  write(*,*) ' is NOT EQUAL to'
4319  write(*,*) ' answer' // trim(pos_str) // ' = ', right
4320 
4321  call abort()
4322  else
4323  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
4324  end if
4325 
4326 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequaldouble5()

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

Definition at line 4331 of file dc_test.f90.

References dc_types::string, and dc_types::token.

4331  use dc_types, only: string, token
4332  implicit none
4333  character(*), intent(in):: message
4334  real(DP), intent(in):: answer(:,:,:,:,:)
4335  real(DP), intent(in):: check(:,:,:,:,:)
4336  logical:: err_flag
4337  character(STRING):: pos_str
4338  real(DP):: wrong, right
4339 
4340  integer:: answer_shape(5), check_shape(5), pos(5)
4341  logical:: consist_shape(5)
4342  character(TOKEN):: pos_array(5)
4343  integer, allocatable:: mask_array(:,:,:,:,:)
4344  logical, allocatable:: judge(:,:,:,:,:)
4345  logical, allocatable:: judge_rev(:,:,:,:,:)
4346 
4347 
4348 
4349 
4350  continue
4351  err_flag = .false.
4352 
4353 
4354  answer_shape = shape(answer)
4355  check_shape = shape(check)
4356 
4357  consist_shape = answer_shape == check_shape
4358 
4359  if (.not. all(consist_shape)) then
4360  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4361  write(*,*) ''
4362  write(*,*) ' shape of check is (', check_shape, ')'
4363  write(*,*) ' is INCORRECT'
4364  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
4365 
4366  call abort()
4367  end if
4368 
4369 
4370  allocate( mask_array( &
4371  & answer_shape(1), &
4372 
4373  & answer_shape(2), &
4374 
4375  & answer_shape(3), &
4376 
4377  & answer_shape(4), &
4378 
4379  & answer_shape(5) ) &
4380  & )
4381 
4382  allocate( judge( &
4383  & answer_shape(1), &
4384 
4385  & answer_shape(2), &
4386 
4387  & answer_shape(3), &
4388 
4389  & answer_shape(4), &
4390 
4391  & answer_shape(5) ) &
4392  & )
4393 
4394  allocate( judge_rev( &
4395  & answer_shape(1), &
4396 
4397  & answer_shape(2), &
4398 
4399  & answer_shape(3), &
4400 
4401  & answer_shape(4), &
4402 
4403  & answer_shape(5) ) &
4404  & )
4405 
4406 
4407  judge = answer == check
4408 
4409 
4410 
4411  judge_rev = .not. judge
4412  err_flag = any(judge_rev)
4413  mask_array = 1
4414  pos = maxloc(mask_array, judge_rev)
4415 
4416  if (err_flag) then
4417 
4418  wrong = check( &
4419  & pos(1), &
4420 
4421  & pos(2), &
4422 
4423  & pos(3), &
4424 
4425  & pos(4), &
4426 
4427  & pos(5) )
4428 
4429  right = answer( &
4430  & pos(1), &
4431 
4432  & pos(2), &
4433 
4434  & pos(3), &
4435 
4436  & pos(4), &
4437 
4438  & pos(5) )
4439 
4440  write(unit=pos_array(1), fmt="(i20)") pos(1)
4441 
4442  write(unit=pos_array(2), fmt="(i20)") pos(2)
4443 
4444  write(unit=pos_array(3), fmt="(i20)") pos(3)
4445 
4446  write(unit=pos_array(4), fmt="(i20)") pos(4)
4447 
4448  write(unit=pos_array(5), fmt="(i20)") pos(5)
4449 
4450 
4451  pos_str = '(' // &
4452  & trim(adjustl(pos_array(1))) // ',' // &
4453 
4454  & trim(adjustl(pos_array(2))) // ',' // &
4455 
4456  & trim(adjustl(pos_array(3))) // ',' // &
4457 
4458  & trim(adjustl(pos_array(4))) // ',' // &
4459 
4460  & trim(adjustl(pos_array(5))) // ')'
4461 
4462  end if
4463  deallocate(mask_array, judge, judge_rev)
4464 
4465 
4466 
4467 
4468  if (err_flag) then
4469  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4470  write(*,*) ''
4471  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
4472  write(*,*) ' is NOT EQUAL to'
4473  write(*,*) ' answer' // trim(pos_str) // ' = ', right
4474 
4475  call abort()
4476  else
4477  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
4478  end if
4479 
4480 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequaldouble6()

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

Definition at line 4485 of file dc_test.f90.

References dc_types::string, and dc_types::token.

4485  use dc_types, only: string, token
4486  implicit none
4487  character(*), intent(in):: message
4488  real(DP), intent(in):: answer(:,:,:,:,:,:)
4489  real(DP), intent(in):: check(:,:,:,:,:,:)
4490  logical:: err_flag
4491  character(STRING):: pos_str
4492  real(DP):: wrong, right
4493 
4494  integer:: answer_shape(6), check_shape(6), pos(6)
4495  logical:: consist_shape(6)
4496  character(TOKEN):: pos_array(6)
4497  integer, allocatable:: mask_array(:,:,:,:,:,:)
4498  logical, allocatable:: judge(:,:,:,:,:,:)
4499  logical, allocatable:: judge_rev(:,:,:,:,:,:)
4500 
4501 
4502 
4503 
4504  continue
4505  err_flag = .false.
4506 
4507 
4508  answer_shape = shape(answer)
4509  check_shape = shape(check)
4510 
4511  consist_shape = answer_shape == check_shape
4512 
4513  if (.not. all(consist_shape)) then
4514  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4515  write(*,*) ''
4516  write(*,*) ' shape of check is (', check_shape, ')'
4517  write(*,*) ' is INCORRECT'
4518  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
4519 
4520  call abort()
4521  end if
4522 
4523 
4524  allocate( mask_array( &
4525  & answer_shape(1), &
4526 
4527  & answer_shape(2), &
4528 
4529  & answer_shape(3), &
4530 
4531  & answer_shape(4), &
4532 
4533  & answer_shape(5), &
4534 
4535  & answer_shape(6) ) &
4536  & )
4537 
4538  allocate( judge( &
4539  & answer_shape(1), &
4540 
4541  & answer_shape(2), &
4542 
4543  & answer_shape(3), &
4544 
4545  & answer_shape(4), &
4546 
4547  & answer_shape(5), &
4548 
4549  & answer_shape(6) ) &
4550  & )
4551 
4552  allocate( judge_rev( &
4553  & answer_shape(1), &
4554 
4555  & answer_shape(2), &
4556 
4557  & answer_shape(3), &
4558 
4559  & answer_shape(4), &
4560 
4561  & answer_shape(5), &
4562 
4563  & answer_shape(6) ) &
4564  & )
4565 
4566 
4567  judge = answer == check
4568 
4569 
4570 
4571  judge_rev = .not. judge
4572  err_flag = any(judge_rev)
4573  mask_array = 1
4574  pos = maxloc(mask_array, judge_rev)
4575 
4576  if (err_flag) then
4577 
4578  wrong = check( &
4579  & pos(1), &
4580 
4581  & pos(2), &
4582 
4583  & pos(3), &
4584 
4585  & pos(4), &
4586 
4587  & pos(5), &
4588 
4589  & pos(6) )
4590 
4591  right = answer( &
4592  & pos(1), &
4593 
4594  & pos(2), &
4595 
4596  & pos(3), &
4597 
4598  & pos(4), &
4599 
4600  & pos(5), &
4601 
4602  & pos(6) )
4603 
4604  write(unit=pos_array(1), fmt="(i20)") pos(1)
4605 
4606  write(unit=pos_array(2), fmt="(i20)") pos(2)
4607 
4608  write(unit=pos_array(3), fmt="(i20)") pos(3)
4609 
4610  write(unit=pos_array(4), fmt="(i20)") pos(4)
4611 
4612  write(unit=pos_array(5), fmt="(i20)") pos(5)
4613 
4614  write(unit=pos_array(6), fmt="(i20)") pos(6)
4615 
4616 
4617  pos_str = '(' // &
4618  & trim(adjustl(pos_array(1))) // ',' // &
4619 
4620  & trim(adjustl(pos_array(2))) // ',' // &
4621 
4622  & trim(adjustl(pos_array(3))) // ',' // &
4623 
4624  & trim(adjustl(pos_array(4))) // ',' // &
4625 
4626  & trim(adjustl(pos_array(5))) // ',' // &
4627 
4628  & trim(adjustl(pos_array(6))) // ')'
4629 
4630  end if
4631  deallocate(mask_array, judge, judge_rev)
4632 
4633 
4634 
4635 
4636  if (err_flag) then
4637  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4638  write(*,*) ''
4639  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
4640  write(*,*) ' is NOT EQUAL to'
4641  write(*,*) ' answer' // trim(pos_str) // ' = ', right
4642 
4643  call abort()
4644  else
4645  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
4646  end if
4647 
4648 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequaldouble7()

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

Definition at line 4653 of file dc_test.f90.

References dc_types::string, and dc_types::token.

4653  use dc_types, only: string, token
4654  implicit none
4655  character(*), intent(in):: message
4656  real(DP), intent(in):: answer(:,:,:,:,:,:,:)
4657  real(DP), intent(in):: check(:,:,:,:,:,:,:)
4658  logical:: err_flag
4659  character(STRING):: pos_str
4660  real(DP):: wrong, right
4661 
4662  integer:: answer_shape(7), check_shape(7), pos(7)
4663  logical:: consist_shape(7)
4664  character(TOKEN):: pos_array(7)
4665  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
4666  logical, allocatable:: judge(:,:,:,:,:,:,:)
4667  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
4668 
4669 
4670 
4671 
4672  continue
4673  err_flag = .false.
4674 
4675 
4676  answer_shape = shape(answer)
4677  check_shape = shape(check)
4678 
4679  consist_shape = answer_shape == check_shape
4680 
4681  if (.not. all(consist_shape)) then
4682  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4683  write(*,*) ''
4684  write(*,*) ' shape of check is (', check_shape, ')'
4685  write(*,*) ' is INCORRECT'
4686  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
4687 
4688  call abort()
4689  end if
4690 
4691 
4692  allocate( mask_array( &
4693  & answer_shape(1), &
4694 
4695  & answer_shape(2), &
4696 
4697  & answer_shape(3), &
4698 
4699  & answer_shape(4), &
4700 
4701  & answer_shape(5), &
4702 
4703  & answer_shape(6), &
4704 
4705  & answer_shape(7) ) &
4706  & )
4707 
4708  allocate( judge( &
4709  & answer_shape(1), &
4710 
4711  & answer_shape(2), &
4712 
4713  & answer_shape(3), &
4714 
4715  & answer_shape(4), &
4716 
4717  & answer_shape(5), &
4718 
4719  & answer_shape(6), &
4720 
4721  & answer_shape(7) ) &
4722  & )
4723 
4724  allocate( judge_rev( &
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 
4741  judge = answer == check
4742 
4743 
4744 
4745  judge_rev = .not. judge
4746  err_flag = any(judge_rev)
4747  mask_array = 1
4748  pos = maxloc(mask_array, judge_rev)
4749 
4750  if (err_flag) then
4751 
4752  wrong = check( &
4753  & pos(1), &
4754 
4755  & pos(2), &
4756 
4757  & pos(3), &
4758 
4759  & pos(4), &
4760 
4761  & pos(5), &
4762 
4763  & pos(6), &
4764 
4765  & pos(7) )
4766 
4767  right = answer( &
4768  & pos(1), &
4769 
4770  & pos(2), &
4771 
4772  & pos(3), &
4773 
4774  & pos(4), &
4775 
4776  & pos(5), &
4777 
4778  & pos(6), &
4779 
4780  & pos(7) )
4781 
4782  write(unit=pos_array(1), fmt="(i20)") pos(1)
4783 
4784  write(unit=pos_array(2), fmt="(i20)") pos(2)
4785 
4786  write(unit=pos_array(3), fmt="(i20)") pos(3)
4787 
4788  write(unit=pos_array(4), fmt="(i20)") pos(4)
4789 
4790  write(unit=pos_array(5), fmt="(i20)") pos(5)
4791 
4792  write(unit=pos_array(6), fmt="(i20)") pos(6)
4793 
4794  write(unit=pos_array(7), fmt="(i20)") pos(7)
4795 
4796 
4797  pos_str = '(' // &
4798  & trim(adjustl(pos_array(1))) // ',' // &
4799 
4800  & trim(adjustl(pos_array(2))) // ',' // &
4801 
4802  & trim(adjustl(pos_array(3))) // ',' // &
4803 
4804  & trim(adjustl(pos_array(4))) // ',' // &
4805 
4806  & trim(adjustl(pos_array(5))) // ',' // &
4807 
4808  & trim(adjustl(pos_array(6))) // ',' // &
4809 
4810  & trim(adjustl(pos_array(7))) // ')'
4811 
4812  end if
4813  deallocate(mask_array, judge, judge_rev)
4814 
4815 
4816 
4817 
4818  if (err_flag) then
4819  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
4820  write(*,*) ''
4821  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
4822  write(*,*) ' is NOT EQUAL to'
4823  write(*,*) ' answer' // trim(pos_str) // ' = ', right
4824 
4825  call abort()
4826  else
4827  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
4828  end if
4829 
4830 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequallogical0()

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

Definition at line 4834 of file dc_test.f90.

References dc_types::string.

4834  use dc_types, only: string
4835  implicit none
4836  character(*), intent(in):: message
4837  logical, intent(in):: answer
4838  logical, intent(in):: check
4839 
4840  character(STRING):: answer_str
4841  character(STRING):: check_str
4842 
4843 
4844 
4845  continue
4846 
4847 
4848  if (answer) then
4849  answer_str = ".true."
4850  else
4851  answer_str = ".false."
4852  end if
4853 
4854  if (check) then
4855  check_str = ".true."
4856  else
4857  check_str = ".false."
4858  end if
4859 
4860 
4861 
4862  call dctestassertequalchar0(message, answer_str, check_str)
4863 
4864 
4865 
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequallogical1()

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

Definition at line 4868 of file dc_test.f90.

References dctestassertequalchar1(), and dc_types::string.

4868  use dc_types, only: string
4869  implicit none
4870  character(*), intent(in):: message
4871  logical, intent(in):: answer(:)
4872  logical, intent(in):: check(:)
4873 
4874  integer:: answer_shape(1), check_shape(1), i
4875  logical, allocatable:: answer_tmp(:), check_tmp(:)
4876  character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
4877  character(STRING), allocatable:: answer_str(:)
4878  character(STRING), allocatable:: check_str(:)
4879 
4880 
4881 
4882  continue
4883 
4884 
4885  allocate(answer_tmp(size(answer)))
4886  allocate(check_tmp(size(check)))
4887  allocate(answer_str_tmp(size(answer)))
4888  allocate(check_str_tmp(size(check)))
4889  answer_tmp = pack(answer, .true.)
4890  check_tmp = pack(check, .true.)
4891 
4892  do i = 1, size(answer_tmp)
4893  if (answer_tmp(i)) then
4894  answer_str_tmp(i) = '.true.'
4895  else
4896  answer_str_tmp(i) = '.false.'
4897  end if
4898  end do
4899 
4900  do i = 1, size(check_tmp)
4901  if (check_tmp(i)) then
4902  check_str_tmp(i) = '.true.'
4903  else
4904  check_str_tmp(i) = '.false.'
4905  end if
4906  end do
4907 
4908  answer_shape = shape(answer)
4909  check_shape = shape(check)
4910 
4911  allocate( answer_str( &
4912 
4913  & answer_shape(1) ) &
4914  & )
4915 
4916  allocate( check_str( &
4917 
4918  & check_shape(1) ) &
4919  & )
4920 
4921  answer_str = reshape(answer_str_tmp, answer_shape)
4922  check_str = reshape(check_str_tmp, check_shape)
4923 
4924 
4925 
4926  call dctestassertequalchar1(message, answer_str, check_str)
4927 
4928  deallocate(answer_str, answer_tmp, answer_str_tmp)
4929  deallocate(check_str, check_tmp, check_str_tmp)
4930 
4931 
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12
Here is the call graph for this function:

◆ dctestassertequallogical2()

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

Definition at line 4934 of file dc_test.f90.

References dctestassertequalchar2(), and dc_types::string.

4934  use dc_types, only: string
4935  implicit none
4936  character(*), intent(in):: message
4937  logical, intent(in):: answer(:,:)
4938  logical, intent(in):: check(:,:)
4939 
4940  integer:: answer_shape(2), check_shape(2), i
4941  logical, allocatable:: answer_tmp(:), check_tmp(:)
4942  character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
4943  character(STRING), allocatable:: answer_str(:,:)
4944  character(STRING), allocatable:: check_str(:,:)
4945 
4946 
4947 
4948  continue
4949 
4950 
4951  allocate(answer_tmp(size(answer)))
4952  allocate(check_tmp(size(check)))
4953  allocate(answer_str_tmp(size(answer)))
4954  allocate(check_str_tmp(size(check)))
4955  answer_tmp = pack(answer, .true.)
4956  check_tmp = pack(check, .true.)
4957 
4958  do i = 1, size(answer_tmp)
4959  if (answer_tmp(i)) then
4960  answer_str_tmp(i) = '.true.'
4961  else
4962  answer_str_tmp(i) = '.false.'
4963  end if
4964  end do
4965 
4966  do i = 1, size(check_tmp)
4967  if (check_tmp(i)) then
4968  check_str_tmp(i) = '.true.'
4969  else
4970  check_str_tmp(i) = '.false.'
4971  end if
4972  end do
4973 
4974  answer_shape = shape(answer)
4975  check_shape = shape(check)
4976 
4977  allocate( answer_str( &
4978  & answer_shape(1), &
4979 
4980  & answer_shape(2) ) &
4981  & )
4982 
4983  allocate( check_str( &
4984  & check_shape(1), &
4985 
4986  & check_shape(2) ) &
4987  & )
4988 
4989  answer_str = reshape(answer_str_tmp, answer_shape)
4990  check_str = reshape(check_str_tmp, check_shape)
4991 
4992 
4993 
4994  call dctestassertequalchar2(message, answer_str, check_str)
4995 
4996  deallocate(answer_str, answer_tmp, answer_str_tmp)
4997  deallocate(check_str, check_tmp, check_str_tmp)
4998 
4999 
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12
Here is the call graph for this function:

◆ dctestassertequallogical3()

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

Definition at line 5002 of file dc_test.f90.

References dctestassertequalchar3(), and dc_types::string.

5002  use dc_types, only: string
5003  implicit none
5004  character(*), intent(in):: message
5005  logical, intent(in):: answer(:,:,:)
5006  logical, intent(in):: check(:,:,:)
5007 
5008  integer:: answer_shape(3), check_shape(3), i
5009  logical, allocatable:: answer_tmp(:), check_tmp(:)
5010  character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
5011  character(STRING), allocatable:: answer_str(:,:,:)
5012  character(STRING), allocatable:: check_str(:,:,:)
5013 
5014 
5015 
5016  continue
5017 
5018 
5019  allocate(answer_tmp(size(answer)))
5020  allocate(check_tmp(size(check)))
5021  allocate(answer_str_tmp(size(answer)))
5022  allocate(check_str_tmp(size(check)))
5023  answer_tmp = pack(answer, .true.)
5024  check_tmp = pack(check, .true.)
5025 
5026  do i = 1, size(answer_tmp)
5027  if (answer_tmp(i)) then
5028  answer_str_tmp(i) = '.true.'
5029  else
5030  answer_str_tmp(i) = '.false.'
5031  end if
5032  end do
5033 
5034  do i = 1, size(check_tmp)
5035  if (check_tmp(i)) then
5036  check_str_tmp(i) = '.true.'
5037  else
5038  check_str_tmp(i) = '.false.'
5039  end if
5040  end do
5041 
5042  answer_shape = shape(answer)
5043  check_shape = shape(check)
5044 
5045  allocate( answer_str( &
5046  & answer_shape(1), &
5047 
5048  & answer_shape(2), &
5049 
5050  & answer_shape(3) ) &
5051  & )
5052 
5053  allocate( check_str( &
5054  & check_shape(1), &
5055 
5056  & check_shape(2), &
5057 
5058  & check_shape(3) ) &
5059  & )
5060 
5061  answer_str = reshape(answer_str_tmp, answer_shape)
5062  check_str = reshape(check_str_tmp, check_shape)
5063 
5064 
5065 
5066  call dctestassertequalchar3(message, answer_str, check_str)
5067 
5068  deallocate(answer_str, answer_tmp, answer_str_tmp)
5069  deallocate(check_str, check_tmp, check_str_tmp)
5070 
5071 
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12
Here is the call graph for this function:

◆ dctestassertequallogical4()

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

Definition at line 5074 of file dc_test.f90.

References dctestassertequalchar4(), and dc_types::string.

5074  use dc_types, only: string
5075  implicit none
5076  character(*), intent(in):: message
5077  logical, intent(in):: answer(:,:,:,:)
5078  logical, intent(in):: check(:,:,:,:)
5079 
5080  integer:: answer_shape(4), check_shape(4), i
5081  logical, allocatable:: answer_tmp(:), check_tmp(:)
5082  character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
5083  character(STRING), allocatable:: answer_str(:,:,:,:)
5084  character(STRING), allocatable:: check_str(:,:,:,:)
5085 
5086 
5087 
5088  continue
5089 
5090 
5091  allocate(answer_tmp(size(answer)))
5092  allocate(check_tmp(size(check)))
5093  allocate(answer_str_tmp(size(answer)))
5094  allocate(check_str_tmp(size(check)))
5095  answer_tmp = pack(answer, .true.)
5096  check_tmp = pack(check, .true.)
5097 
5098  do i = 1, size(answer_tmp)
5099  if (answer_tmp(i)) then
5100  answer_str_tmp(i) = '.true.'
5101  else
5102  answer_str_tmp(i) = '.false.'
5103  end if
5104  end do
5105 
5106  do i = 1, size(check_tmp)
5107  if (check_tmp(i)) then
5108  check_str_tmp(i) = '.true.'
5109  else
5110  check_str_tmp(i) = '.false.'
5111  end if
5112  end do
5113 
5114  answer_shape = shape(answer)
5115  check_shape = shape(check)
5116 
5117  allocate( answer_str( &
5118  & answer_shape(1), &
5119 
5120  & answer_shape(2), &
5121 
5122  & answer_shape(3), &
5123 
5124  & answer_shape(4) ) &
5125  & )
5126 
5127  allocate( check_str( &
5128  & check_shape(1), &
5129 
5130  & check_shape(2), &
5131 
5132  & check_shape(3), &
5133 
5134  & check_shape(4) ) &
5135  & )
5136 
5137  answer_str = reshape(answer_str_tmp, answer_shape)
5138  check_str = reshape(check_str_tmp, check_shape)
5139 
5140 
5141 
5142  call dctestassertequalchar4(message, answer_str, check_str)
5143 
5144  deallocate(answer_str, answer_tmp, answer_str_tmp)
5145  deallocate(check_str, check_tmp, check_str_tmp)
5146 
5147 
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12
Here is the call graph for this function:

◆ dctestassertequallogical5()

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

Definition at line 5150 of file dc_test.f90.

References dctestassertequalchar5(), and dc_types::string.

5150  use dc_types, only: string
5151  implicit none
5152  character(*), intent(in):: message
5153  logical, intent(in):: answer(:,:,:,:,:)
5154  logical, intent(in):: check(:,:,:,:,:)
5155 
5156  integer:: answer_shape(5), check_shape(5), i
5157  logical, allocatable:: answer_tmp(:), check_tmp(:)
5158  character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
5159  character(STRING), allocatable:: answer_str(:,:,:,:,:)
5160  character(STRING), allocatable:: check_str(:,:,:,:,:)
5161 
5162 
5163 
5164  continue
5165 
5166 
5167  allocate(answer_tmp(size(answer)))
5168  allocate(check_tmp(size(check)))
5169  allocate(answer_str_tmp(size(answer)))
5170  allocate(check_str_tmp(size(check)))
5171  answer_tmp = pack(answer, .true.)
5172  check_tmp = pack(check, .true.)
5173 
5174  do i = 1, size(answer_tmp)
5175  if (answer_tmp(i)) then
5176  answer_str_tmp(i) = '.true.'
5177  else
5178  answer_str_tmp(i) = '.false.'
5179  end if
5180  end do
5181 
5182  do i = 1, size(check_tmp)
5183  if (check_tmp(i)) then
5184  check_str_tmp(i) = '.true.'
5185  else
5186  check_str_tmp(i) = '.false.'
5187  end if
5188  end do
5189 
5190  answer_shape = shape(answer)
5191  check_shape = shape(check)
5192 
5193  allocate( answer_str( &
5194  & answer_shape(1), &
5195 
5196  & answer_shape(2), &
5197 
5198  & answer_shape(3), &
5199 
5200  & answer_shape(4), &
5201 
5202  & answer_shape(5) ) &
5203  & )
5204 
5205  allocate( check_str( &
5206  & check_shape(1), &
5207 
5208  & check_shape(2), &
5209 
5210  & check_shape(3), &
5211 
5212  & check_shape(4), &
5213 
5214  & check_shape(5) ) &
5215  & )
5216 
5217  answer_str = reshape(answer_str_tmp, answer_shape)
5218  check_str = reshape(check_str_tmp, check_shape)
5219 
5220 
5221 
5222  call dctestassertequalchar5(message, answer_str, check_str)
5223 
5224  deallocate(answer_str, answer_tmp, answer_str_tmp)
5225  deallocate(check_str, check_tmp, check_str_tmp)
5226 
5227 
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12
Here is the call graph for this function:

◆ dctestassertequallogical6()

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

Definition at line 5230 of file dc_test.f90.

References dctestassertequalchar6(), and dc_types::string.

5230  use dc_types, only: string
5231  implicit none
5232  character(*), intent(in):: message
5233  logical, intent(in):: answer(:,:,:,:,:,:)
5234  logical, intent(in):: check(:,:,:,:,:,:)
5235 
5236  integer:: answer_shape(6), check_shape(6), i
5237  logical, allocatable:: answer_tmp(:), check_tmp(:)
5238  character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
5239  character(STRING), allocatable:: answer_str(:,:,:,:,:,:)
5240  character(STRING), allocatable:: check_str(:,:,:,:,:,:)
5241 
5242 
5243 
5244  continue
5245 
5246 
5247  allocate(answer_tmp(size(answer)))
5248  allocate(check_tmp(size(check)))
5249  allocate(answer_str_tmp(size(answer)))
5250  allocate(check_str_tmp(size(check)))
5251  answer_tmp = pack(answer, .true.)
5252  check_tmp = pack(check, .true.)
5253 
5254  do i = 1, size(answer_tmp)
5255  if (answer_tmp(i)) then
5256  answer_str_tmp(i) = '.true.'
5257  else
5258  answer_str_tmp(i) = '.false.'
5259  end if
5260  end do
5261 
5262  do i = 1, size(check_tmp)
5263  if (check_tmp(i)) then
5264  check_str_tmp(i) = '.true.'
5265  else
5266  check_str_tmp(i) = '.false.'
5267  end if
5268  end do
5269 
5270  answer_shape = shape(answer)
5271  check_shape = shape(check)
5272 
5273  allocate( answer_str( &
5274  & answer_shape(1), &
5275 
5276  & answer_shape(2), &
5277 
5278  & answer_shape(3), &
5279 
5280  & answer_shape(4), &
5281 
5282  & answer_shape(5), &
5283 
5284  & answer_shape(6) ) &
5285  & )
5286 
5287  allocate( check_str( &
5288  & check_shape(1), &
5289 
5290  & check_shape(2), &
5291 
5292  & check_shape(3), &
5293 
5294  & check_shape(4), &
5295 
5296  & check_shape(5), &
5297 
5298  & check_shape(6) ) &
5299  & )
5300 
5301  answer_str = reshape(answer_str_tmp, answer_shape)
5302  check_str = reshape(check_str_tmp, check_shape)
5303 
5304 
5305 
5306  call dctestassertequalchar6(message, answer_str, check_str)
5307 
5308  deallocate(answer_str, answer_tmp, answer_str_tmp)
5309  deallocate(check_str, check_tmp, check_str_tmp)
5310 
5311 
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12
Here is the call graph for this function:

◆ dctestassertequallogical7()

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

Definition at line 5314 of file dc_test.f90.

References dctestassertequalchar7(), and dc_types::string.

5314  use dc_types, only: string
5315  implicit none
5316  character(*), intent(in):: message
5317  logical, intent(in):: answer(:,:,:,:,:,:,:)
5318  logical, intent(in):: check(:,:,:,:,:,:,:)
5319 
5320  integer:: answer_shape(7), check_shape(7), i
5321  logical, allocatable:: answer_tmp(:), check_tmp(:)
5322  character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
5323  character(STRING), allocatable:: answer_str(:,:,:,:,:,:,:)
5324  character(STRING), allocatable:: check_str(:,:,:,:,:,:,:)
5325 
5326 
5327 
5328  continue
5329 
5330 
5331  allocate(answer_tmp(size(answer)))
5332  allocate(check_tmp(size(check)))
5333  allocate(answer_str_tmp(size(answer)))
5334  allocate(check_str_tmp(size(check)))
5335  answer_tmp = pack(answer, .true.)
5336  check_tmp = pack(check, .true.)
5337 
5338  do i = 1, size(answer_tmp)
5339  if (answer_tmp(i)) then
5340  answer_str_tmp(i) = '.true.'
5341  else
5342  answer_str_tmp(i) = '.false.'
5343  end if
5344  end do
5345 
5346  do i = 1, size(check_tmp)
5347  if (check_tmp(i)) then
5348  check_str_tmp(i) = '.true.'
5349  else
5350  check_str_tmp(i) = '.false.'
5351  end if
5352  end do
5353 
5354  answer_shape = shape(answer)
5355  check_shape = shape(check)
5356 
5357  allocate( answer_str( &
5358  & answer_shape(1), &
5359 
5360  & answer_shape(2), &
5361 
5362  & answer_shape(3), &
5363 
5364  & answer_shape(4), &
5365 
5366  & answer_shape(5), &
5367 
5368  & answer_shape(6), &
5369 
5370  & answer_shape(7) ) &
5371  & )
5372 
5373  allocate( check_str( &
5374  & check_shape(1), &
5375 
5376  & check_shape(2), &
5377 
5378  & check_shape(3), &
5379 
5380  & check_shape(4), &
5381 
5382  & check_shape(5), &
5383 
5384  & check_shape(6), &
5385 
5386  & check_shape(7) ) &
5387  & )
5388 
5389  answer_str = reshape(answer_str_tmp, answer_shape)
5390  check_str = reshape(check_str_tmp, check_shape)
5391 
5392 
5393 
5394  call dctestassertequalchar7(message, answer_str, check_str)
5395 
5396  deallocate(answer_str, answer_tmp, answer_str_tmp)
5397  deallocate(check_str, check_tmp, check_str_tmp)
5398 
5399 
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12
Here is the call graph for this function:

◆ dctestassertequalreal0digits()

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

Definition at line 5404 of file dc_test.f90.

References dc_types::string, and dc_types::token.

5404  use dc_types, only: string, token
5405  implicit none
5406  character(*), intent(in):: message
5407  real, intent(in):: answer
5408  real, intent(in):: check
5409  integer, intent(in):: significant_digits
5410  integer, intent(in):: ignore_digits
5411  logical:: err_flag
5412  character(STRING):: pos_str
5413  real:: wrong, right_max, right_min
5414  character(STRING):: pos_str_space
5415  integer:: pos_str_len
5416  real:: right_tmp
5417 
5418  real:: answer_max
5419  real:: answer_min
5420 
5421  continue
5422  err_flag = .false.
5423 
5424  if ( significant_digits < 1 ) then
5425  write(*,*) ' *** Error [AssertEQ] *** '
5426  write(*,*) ' Specify a number more than 1 to "significant_digits"'
5427  call abort()
5428  end if
5429 
5430  if ( answer < 0.0 .and. check < 0.0 ) then
5431  answer_max = &
5432  & answer &
5433  & * ( 1.0 &
5434  & - 0.1 ** significant_digits ) &
5435  & + 0.1 ** (- ignore_digits)
5436 
5437  answer_min = &
5438  & answer &
5439  & * ( 1.0 &
5440  & + 0.1 ** significant_digits ) &
5441  & - 0.1 ** (- ignore_digits)
5442  else
5443 
5444  answer_max = &
5445  & answer &
5446  & * ( 1.0 &
5447  & + 0.1 ** significant_digits ) &
5448  & + 0.1 ** (- ignore_digits)
5449 
5450  answer_min = &
5451  & answer &
5452  & * ( 1.0 &
5453  & - 0.1 ** significant_digits ) &
5454  & - 0.1 ** (- ignore_digits)
5455  end if
5456 
5457  wrong = check
5458  right_max = answer_max
5459  right_min = answer_min
5460  if ( right_max < right_min ) then
5461  right_tmp = right_max
5462  right_max = right_min
5463  right_min = right_tmp
5464  end if
5465 
5466  err_flag = .not. (answer_max > check .and. check > answer_min)
5467 
5468  pos_str = ''
5469 
5470 
5471 
5472  if (err_flag) then
5473  pos_str_space = ''
5474  pos_str_len = len_trim(pos_str)
5475 
5476  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5477  write(*,*) ''
5478  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
5479  write(*,*) ' is NOT EQUAL to'
5480  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
5481  & // ' ', right_min, ' < '
5482  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
5483 
5484  call abort()
5485  else
5486  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
5487  end if
5488 
5489 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequalreal1digits()

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

Definition at line 5495 of file dc_test.f90.

References dc_types::string, and dc_types::token.

5495  use dc_types, only: string, token
5496  implicit none
5497  character(*), intent(in):: message
5498  real, intent(in):: answer(:)
5499  real, intent(in):: check(:)
5500  integer, intent(in):: significant_digits
5501  integer, intent(in):: ignore_digits
5502  logical:: err_flag
5503  character(STRING):: pos_str
5504  real:: wrong, right_max, right_min
5505  character(STRING):: pos_str_space
5506  integer:: pos_str_len
5507  real:: right_tmp
5508 
5509  integer:: answer_shape(1), check_shape(1), pos(1)
5510  logical:: consist_shape(1)
5511  character(TOKEN):: pos_array(1)
5512  integer, allocatable:: mask_array(:)
5513  logical, allocatable:: judge(:)
5514  logical, allocatable:: judge_rev(:)
5515  logical, allocatable:: answer_negative(:)
5516  logical, allocatable:: check_negative(:)
5517  logical, allocatable:: both_negative(:)
5518  real, allocatable:: answer_max(:)
5519  real, allocatable:: answer_min(:)
5520 
5521  continue
5522  err_flag = .false.
5523 
5524  if ( significant_digits < 1 ) then
5525  write(*,*) ' *** Error [AssertEQ] *** '
5526  write(*,*) ' Specify a number more than 1 to "significant_digits"'
5527  call abort()
5528  end if
5529 
5530  answer_shape = shape(answer)
5531  check_shape = shape(check)
5532 
5533  consist_shape = answer_shape == check_shape
5534 
5535  if (.not. all(consist_shape)) then
5536  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5537  write(*,*) ''
5538  write(*,*) ' shape of check is (', check_shape, ')'
5539  write(*,*) ' is INCORRECT'
5540  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
5541 
5542  call abort()
5543  end if
5544 
5545 
5546  allocate( mask_array( &
5547 
5548  & answer_shape(1) ) &
5549  & )
5550 
5551  allocate( judge( &
5552 
5553  & answer_shape(1) ) &
5554  & )
5555 
5556  allocate( judge_rev( &
5557 
5558  & answer_shape(1) ) &
5559  & )
5560 
5561  allocate( answer_negative( &
5562 
5563  & answer_shape(1) ) &
5564  & )
5565 
5566  allocate( check_negative( &
5567 
5568  & answer_shape(1) ) &
5569  & )
5570 
5571  allocate( both_negative( &
5572 
5573  & answer_shape(1) ) &
5574  & )
5575 
5576  allocate( answer_max( &
5577 
5578  & answer_shape(1) ) &
5579  & )
5580 
5581  allocate( answer_min( &
5582 
5583  & answer_shape(1) ) &
5584  & )
5585 
5586  answer_negative = answer < 0.0
5587  check_negative = check < 0.0
5588  both_negative = answer_negative .and. check_negative
5589 
5590  where (both_negative)
5591  answer_max = &
5592  & answer &
5593  & * ( 1.0 &
5594  & - 0.1 ** significant_digits ) &
5595  & + 0.1 ** (- ignore_digits)
5596 
5597  answer_min = &
5598  & answer &
5599  & * ( 1.0 &
5600  & + 0.1 ** significant_digits ) &
5601  & - 0.1 ** (- ignore_digits)
5602  elsewhere
5603  answer_max = &
5604  & answer &
5605  & * ( 1.0 &
5606  & + 0.1 ** significant_digits ) &
5607  & + 0.1 ** (- ignore_digits)
5608 
5609  answer_min = &
5610  & answer &
5611  & * ( 1.0 &
5612  & - 0.1 ** significant_digits ) &
5613  & - 0.1 ** (- ignore_digits)
5614  end where
5615 
5616  judge = answer_max > check .and. check > answer_min
5617  judge_rev = .not. judge
5618  err_flag = any(judge_rev)
5619  mask_array = 1
5620  pos = maxloc(mask_array, judge_rev)
5621 
5622  if (err_flag) then
5623 
5624  wrong = check( &
5625 
5626  & pos(1) )
5627 
5628  right_max = answer_max( &
5629 
5630  & pos(1) )
5631 
5632  right_min = answer_min( &
5633 
5634  & pos(1) )
5635 
5636  if ( right_max < right_min ) then
5637  right_tmp = right_max
5638  right_max = right_min
5639  right_min = right_tmp
5640  end if
5641 
5642  write(unit=pos_array(1), fmt="(i20)") pos(1)
5643 
5644 
5645  pos_str = '(' // &
5646 
5647  & trim(adjustl(pos_array(1))) // ')'
5648 
5649  end if
5650  deallocate(mask_array, judge, judge_rev)
5651  deallocate(answer_negative, check_negative, both_negative)
5652  deallocate(answer_max, answer_min)
5653 
5654 
5655 
5656  if (err_flag) then
5657  pos_str_space = ''
5658  pos_str_len = len_trim(pos_str)
5659 
5660  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5661  write(*,*) ''
5662  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
5663  write(*,*) ' is NOT EQUAL to'
5664  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
5665  & // ' ', right_min, ' < '
5666  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
5667 
5668  call abort()
5669  else
5670  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
5671  end if
5672 
5673 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequalreal2digits()

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

Definition at line 5679 of file dc_test.f90.

References dc_types::string, and dc_types::token.

5679  use dc_types, only: string, token
5680  implicit none
5681  character(*), intent(in):: message
5682  real, intent(in):: answer(:,:)
5683  real, intent(in):: check(:,:)
5684  integer, intent(in):: significant_digits
5685  integer, intent(in):: ignore_digits
5686  logical:: err_flag
5687  character(STRING):: pos_str
5688  real:: wrong, right_max, right_min
5689  character(STRING):: pos_str_space
5690  integer:: pos_str_len
5691  real:: right_tmp
5692 
5693  integer:: answer_shape(2), check_shape(2), pos(2)
5694  logical:: consist_shape(2)
5695  character(TOKEN):: pos_array(2)
5696  integer, allocatable:: mask_array(:,:)
5697  logical, allocatable:: judge(:,:)
5698  logical, allocatable:: judge_rev(:,:)
5699  logical, allocatable:: answer_negative(:,:)
5700  logical, allocatable:: check_negative(:,:)
5701  logical, allocatable:: both_negative(:,:)
5702  real, allocatable:: answer_max(:,:)
5703  real, allocatable:: answer_min(:,:)
5704 
5705  continue
5706  err_flag = .false.
5707 
5708  if ( significant_digits < 1 ) then
5709  write(*,*) ' *** Error [AssertEQ] *** '
5710  write(*,*) ' Specify a number more than 1 to "significant_digits"'
5711  call abort()
5712  end if
5713 
5714  answer_shape = shape(answer)
5715  check_shape = shape(check)
5716 
5717  consist_shape = answer_shape == check_shape
5718 
5719  if (.not. all(consist_shape)) then
5720  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5721  write(*,*) ''
5722  write(*,*) ' shape of check is (', check_shape, ')'
5723  write(*,*) ' is INCORRECT'
5724  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
5725 
5726  call abort()
5727  end if
5728 
5729 
5730  allocate( mask_array( &
5731  & answer_shape(1), &
5732 
5733  & answer_shape(2) ) &
5734  & )
5735 
5736  allocate( judge( &
5737  & answer_shape(1), &
5738 
5739  & answer_shape(2) ) &
5740  & )
5741 
5742  allocate( judge_rev( &
5743  & answer_shape(1), &
5744 
5745  & answer_shape(2) ) &
5746  & )
5747 
5748  allocate( answer_negative( &
5749  & answer_shape(1), &
5750 
5751  & answer_shape(2) ) &
5752  & )
5753 
5754  allocate( check_negative( &
5755  & answer_shape(1), &
5756 
5757  & answer_shape(2) ) &
5758  & )
5759 
5760  allocate( both_negative( &
5761  & answer_shape(1), &
5762 
5763  & answer_shape(2) ) &
5764  & )
5765 
5766  allocate( answer_max( &
5767  & answer_shape(1), &
5768 
5769  & answer_shape(2) ) &
5770  & )
5771 
5772  allocate( answer_min( &
5773  & answer_shape(1), &
5774 
5775  & answer_shape(2) ) &
5776  & )
5777 
5778  answer_negative = answer < 0.0
5779  check_negative = check < 0.0
5780  both_negative = answer_negative .and. check_negative
5781 
5782  where (both_negative)
5783  answer_max = &
5784  & answer &
5785  & * ( 1.0 &
5786  & - 0.1 ** significant_digits ) &
5787  & + 0.1 ** (- ignore_digits)
5788 
5789  answer_min = &
5790  & answer &
5791  & * ( 1.0 &
5792  & + 0.1 ** significant_digits ) &
5793  & - 0.1 ** (- ignore_digits)
5794  elsewhere
5795  answer_max = &
5796  & answer &
5797  & * ( 1.0 &
5798  & + 0.1 ** significant_digits ) &
5799  & + 0.1 ** (- ignore_digits)
5800 
5801  answer_min = &
5802  & answer &
5803  & * ( 1.0 &
5804  & - 0.1 ** significant_digits ) &
5805  & - 0.1 ** (- ignore_digits)
5806  end where
5807 
5808  judge = answer_max > check .and. check > answer_min
5809  judge_rev = .not. judge
5810  err_flag = any(judge_rev)
5811  mask_array = 1
5812  pos = maxloc(mask_array, judge_rev)
5813 
5814  if (err_flag) then
5815 
5816  wrong = check( &
5817  & pos(1), &
5818 
5819  & pos(2) )
5820 
5821  right_max = answer_max( &
5822  & pos(1), &
5823 
5824  & pos(2) )
5825 
5826  right_min = answer_min( &
5827  & pos(1), &
5828 
5829  & pos(2) )
5830 
5831  if ( right_max < right_min ) then
5832  right_tmp = right_max
5833  right_max = right_min
5834  right_min = right_tmp
5835  end if
5836 
5837  write(unit=pos_array(1), fmt="(i20)") pos(1)
5838 
5839  write(unit=pos_array(2), fmt="(i20)") pos(2)
5840 
5841 
5842  pos_str = '(' // &
5843  & trim(adjustl(pos_array(1))) // ',' // &
5844 
5845  & trim(adjustl(pos_array(2))) // ')'
5846 
5847  end if
5848  deallocate(mask_array, judge, judge_rev)
5849  deallocate(answer_negative, check_negative, both_negative)
5850  deallocate(answer_max, answer_min)
5851 
5852 
5853 
5854  if (err_flag) then
5855  pos_str_space = ''
5856  pos_str_len = len_trim(pos_str)
5857 
5858  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5859  write(*,*) ''
5860  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
5861  write(*,*) ' is NOT EQUAL to'
5862  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
5863  & // ' ', right_min, ' < '
5864  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
5865 
5866  call abort()
5867  else
5868  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
5869  end if
5870 
5871 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequalreal3digits()

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

Definition at line 5877 of file dc_test.f90.

References dc_types::string, and dc_types::token.

5877  use dc_types, only: string, token
5878  implicit none
5879  character(*), intent(in):: message
5880  real, intent(in):: answer(:,:,:)
5881  real, intent(in):: check(:,:,:)
5882  integer, intent(in):: significant_digits
5883  integer, intent(in):: ignore_digits
5884  logical:: err_flag
5885  character(STRING):: pos_str
5886  real:: wrong, right_max, right_min
5887  character(STRING):: pos_str_space
5888  integer:: pos_str_len
5889  real:: right_tmp
5890 
5891  integer:: answer_shape(3), check_shape(3), pos(3)
5892  logical:: consist_shape(3)
5893  character(TOKEN):: pos_array(3)
5894  integer, allocatable:: mask_array(:,:,:)
5895  logical, allocatable:: judge(:,:,:)
5896  logical, allocatable:: judge_rev(:,:,:)
5897  logical, allocatable:: answer_negative(:,:,:)
5898  logical, allocatable:: check_negative(:,:,:)
5899  logical, allocatable:: both_negative(:,:,:)
5900  real, allocatable:: answer_max(:,:,:)
5901  real, allocatable:: answer_min(:,:,:)
5902 
5903  continue
5904  err_flag = .false.
5905 
5906  if ( significant_digits < 1 ) then
5907  write(*,*) ' *** Error [AssertEQ] *** '
5908  write(*,*) ' Specify a number more than 1 to "significant_digits"'
5909  call abort()
5910  end if
5911 
5912  answer_shape = shape(answer)
5913  check_shape = shape(check)
5914 
5915  consist_shape = answer_shape == check_shape
5916 
5917  if (.not. all(consist_shape)) then
5918  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
5919  write(*,*) ''
5920  write(*,*) ' shape of check is (', check_shape, ')'
5921  write(*,*) ' is INCORRECT'
5922  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
5923 
5924  call abort()
5925  end if
5926 
5927 
5928  allocate( mask_array( &
5929  & answer_shape(1), &
5930 
5931  & answer_shape(2), &
5932 
5933  & answer_shape(3) ) &
5934  & )
5935 
5936  allocate( judge( &
5937  & answer_shape(1), &
5938 
5939  & answer_shape(2), &
5940 
5941  & answer_shape(3) ) &
5942  & )
5943 
5944  allocate( judge_rev( &
5945  & answer_shape(1), &
5946 
5947  & answer_shape(2), &
5948 
5949  & answer_shape(3) ) &
5950  & )
5951 
5952  allocate( answer_negative( &
5953  & answer_shape(1), &
5954 
5955  & answer_shape(2), &
5956 
5957  & answer_shape(3) ) &
5958  & )
5959 
5960  allocate( check_negative( &
5961  & answer_shape(1), &
5962 
5963  & answer_shape(2), &
5964 
5965  & answer_shape(3) ) &
5966  & )
5967 
5968  allocate( both_negative( &
5969  & answer_shape(1), &
5970 
5971  & answer_shape(2), &
5972 
5973  & answer_shape(3) ) &
5974  & )
5975 
5976  allocate( answer_max( &
5977  & answer_shape(1), &
5978 
5979  & answer_shape(2), &
5980 
5981  & answer_shape(3) ) &
5982  & )
5983 
5984  allocate( answer_min( &
5985  & answer_shape(1), &
5986 
5987  & answer_shape(2), &
5988 
5989  & answer_shape(3) ) &
5990  & )
5991 
5992  answer_negative = answer < 0.0
5993  check_negative = check < 0.0
5994  both_negative = answer_negative .and. check_negative
5995 
5996  where (both_negative)
5997  answer_max = &
5998  & answer &
5999  & * ( 1.0 &
6000  & - 0.1 ** significant_digits ) &
6001  & + 0.1 ** (- ignore_digits)
6002 
6003  answer_min = &
6004  & answer &
6005  & * ( 1.0 &
6006  & + 0.1 ** significant_digits ) &
6007  & - 0.1 ** (- ignore_digits)
6008  elsewhere
6009  answer_max = &
6010  & answer &
6011  & * ( 1.0 &
6012  & + 0.1 ** significant_digits ) &
6013  & + 0.1 ** (- ignore_digits)
6014 
6015  answer_min = &
6016  & answer &
6017  & * ( 1.0 &
6018  & - 0.1 ** significant_digits ) &
6019  & - 0.1 ** (- ignore_digits)
6020  end where
6021 
6022  judge = answer_max > check .and. check > answer_min
6023  judge_rev = .not. judge
6024  err_flag = any(judge_rev)
6025  mask_array = 1
6026  pos = maxloc(mask_array, judge_rev)
6027 
6028  if (err_flag) then
6029 
6030  wrong = check( &
6031  & pos(1), &
6032 
6033  & pos(2), &
6034 
6035  & pos(3) )
6036 
6037  right_max = answer_max( &
6038  & pos(1), &
6039 
6040  & pos(2), &
6041 
6042  & pos(3) )
6043 
6044  right_min = answer_min( &
6045  & pos(1), &
6046 
6047  & pos(2), &
6048 
6049  & pos(3) )
6050 
6051  if ( right_max < right_min ) then
6052  right_tmp = right_max
6053  right_max = right_min
6054  right_min = right_tmp
6055  end if
6056 
6057  write(unit=pos_array(1), fmt="(i20)") pos(1)
6058 
6059  write(unit=pos_array(2), fmt="(i20)") pos(2)
6060 
6061  write(unit=pos_array(3), fmt="(i20)") pos(3)
6062 
6063 
6064  pos_str = '(' // &
6065  & trim(adjustl(pos_array(1))) // ',' // &
6066 
6067  & trim(adjustl(pos_array(2))) // ',' // &
6068 
6069  & trim(adjustl(pos_array(3))) // ')'
6070 
6071  end if
6072  deallocate(mask_array, judge, judge_rev)
6073  deallocate(answer_negative, check_negative, both_negative)
6074  deallocate(answer_max, answer_min)
6075 
6076 
6077 
6078  if (err_flag) then
6079  pos_str_space = ''
6080  pos_str_len = len_trim(pos_str)
6081 
6082  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6083  write(*,*) ''
6084  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
6085  write(*,*) ' is NOT EQUAL to'
6086  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
6087  & // ' ', right_min, ' < '
6088  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
6089 
6090  call abort()
6091  else
6092  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
6093  end if
6094 
6095 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequalreal4digits()

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

Definition at line 6101 of file dc_test.f90.

References dc_types::string, and dc_types::token.

6101  use dc_types, only: string, token
6102  implicit none
6103  character(*), intent(in):: message
6104  real, intent(in):: answer(:,:,:,:)
6105  real, intent(in):: check(:,:,:,:)
6106  integer, intent(in):: significant_digits
6107  integer, intent(in):: ignore_digits
6108  logical:: err_flag
6109  character(STRING):: pos_str
6110  real:: wrong, right_max, right_min
6111  character(STRING):: pos_str_space
6112  integer:: pos_str_len
6113  real:: right_tmp
6114 
6115  integer:: answer_shape(4), check_shape(4), pos(4)
6116  logical:: consist_shape(4)
6117  character(TOKEN):: pos_array(4)
6118  integer, allocatable:: mask_array(:,:,:,:)
6119  logical, allocatable:: judge(:,:,:,:)
6120  logical, allocatable:: judge_rev(:,:,:,:)
6121  logical, allocatable:: answer_negative(:,:,:,:)
6122  logical, allocatable:: check_negative(:,:,:,:)
6123  logical, allocatable:: both_negative(:,:,:,:)
6124  real, allocatable:: answer_max(:,:,:,:)
6125  real, allocatable:: answer_min(:,:,:,:)
6126 
6127  continue
6128  err_flag = .false.
6129 
6130  if ( significant_digits < 1 ) then
6131  write(*,*) ' *** Error [AssertEQ] *** '
6132  write(*,*) ' Specify a number more than 1 to "significant_digits"'
6133  call abort()
6134  end if
6135 
6136  answer_shape = shape(answer)
6137  check_shape = shape(check)
6138 
6139  consist_shape = answer_shape == check_shape
6140 
6141  if (.not. all(consist_shape)) then
6142  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6143  write(*,*) ''
6144  write(*,*) ' shape of check is (', check_shape, ')'
6145  write(*,*) ' is INCORRECT'
6146  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
6147 
6148  call abort()
6149  end if
6150 
6151 
6152  allocate( mask_array( &
6153  & answer_shape(1), &
6154 
6155  & answer_shape(2), &
6156 
6157  & answer_shape(3), &
6158 
6159  & answer_shape(4) ) &
6160  & )
6161 
6162  allocate( judge( &
6163  & answer_shape(1), &
6164 
6165  & answer_shape(2), &
6166 
6167  & answer_shape(3), &
6168 
6169  & answer_shape(4) ) &
6170  & )
6171 
6172  allocate( judge_rev( &
6173  & answer_shape(1), &
6174 
6175  & answer_shape(2), &
6176 
6177  & answer_shape(3), &
6178 
6179  & answer_shape(4) ) &
6180  & )
6181 
6182  allocate( answer_negative( &
6183  & answer_shape(1), &
6184 
6185  & answer_shape(2), &
6186 
6187  & answer_shape(3), &
6188 
6189  & answer_shape(4) ) &
6190  & )
6191 
6192  allocate( check_negative( &
6193  & answer_shape(1), &
6194 
6195  & answer_shape(2), &
6196 
6197  & answer_shape(3), &
6198 
6199  & answer_shape(4) ) &
6200  & )
6201 
6202  allocate( both_negative( &
6203  & answer_shape(1), &
6204 
6205  & answer_shape(2), &
6206 
6207  & answer_shape(3), &
6208 
6209  & answer_shape(4) ) &
6210  & )
6211 
6212  allocate( answer_max( &
6213  & answer_shape(1), &
6214 
6215  & answer_shape(2), &
6216 
6217  & answer_shape(3), &
6218 
6219  & answer_shape(4) ) &
6220  & )
6221 
6222  allocate( answer_min( &
6223  & answer_shape(1), &
6224 
6225  & answer_shape(2), &
6226 
6227  & answer_shape(3), &
6228 
6229  & answer_shape(4) ) &
6230  & )
6231 
6232  answer_negative = answer < 0.0
6233  check_negative = check < 0.0
6234  both_negative = answer_negative .and. check_negative
6235 
6236  where (both_negative)
6237  answer_max = &
6238  & answer &
6239  & * ( 1.0 &
6240  & - 0.1 ** significant_digits ) &
6241  & + 0.1 ** (- ignore_digits)
6242 
6243  answer_min = &
6244  & answer &
6245  & * ( 1.0 &
6246  & + 0.1 ** significant_digits ) &
6247  & - 0.1 ** (- ignore_digits)
6248  elsewhere
6249  answer_max = &
6250  & answer &
6251  & * ( 1.0 &
6252  & + 0.1 ** significant_digits ) &
6253  & + 0.1 ** (- ignore_digits)
6254 
6255  answer_min = &
6256  & answer &
6257  & * ( 1.0 &
6258  & - 0.1 ** significant_digits ) &
6259  & - 0.1 ** (- ignore_digits)
6260  end where
6261 
6262  judge = answer_max > check .and. check > answer_min
6263  judge_rev = .not. judge
6264  err_flag = any(judge_rev)
6265  mask_array = 1
6266  pos = maxloc(mask_array, judge_rev)
6267 
6268  if (err_flag) then
6269 
6270  wrong = check( &
6271  & pos(1), &
6272 
6273  & pos(2), &
6274 
6275  & pos(3), &
6276 
6277  & pos(4) )
6278 
6279  right_max = answer_max( &
6280  & pos(1), &
6281 
6282  & pos(2), &
6283 
6284  & pos(3), &
6285 
6286  & pos(4) )
6287 
6288  right_min = answer_min( &
6289  & pos(1), &
6290 
6291  & pos(2), &
6292 
6293  & pos(3), &
6294 
6295  & pos(4) )
6296 
6297  if ( right_max < right_min ) then
6298  right_tmp = right_max
6299  right_max = right_min
6300  right_min = right_tmp
6301  end if
6302 
6303  write(unit=pos_array(1), fmt="(i20)") pos(1)
6304 
6305  write(unit=pos_array(2), fmt="(i20)") pos(2)
6306 
6307  write(unit=pos_array(3), fmt="(i20)") pos(3)
6308 
6309  write(unit=pos_array(4), fmt="(i20)") pos(4)
6310 
6311 
6312  pos_str = '(' // &
6313  & trim(adjustl(pos_array(1))) // ',' // &
6314 
6315  & trim(adjustl(pos_array(2))) // ',' // &
6316 
6317  & trim(adjustl(pos_array(3))) // ',' // &
6318 
6319  & trim(adjustl(pos_array(4))) // ')'
6320 
6321  end if
6322  deallocate(mask_array, judge, judge_rev)
6323  deallocate(answer_negative, check_negative, both_negative)
6324  deallocate(answer_max, answer_min)
6325 
6326 
6327 
6328  if (err_flag) then
6329  pos_str_space = ''
6330  pos_str_len = len_trim(pos_str)
6331 
6332  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6333  write(*,*) ''
6334  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
6335  write(*,*) ' is NOT EQUAL to'
6336  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
6337  & // ' ', right_min, ' < '
6338  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
6339 
6340  call abort()
6341  else
6342  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
6343  end if
6344 
6345 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequalreal5digits()

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

Definition at line 6351 of file dc_test.f90.

References dc_types::string, and dc_types::token.

6351  use dc_types, only: string, token
6352  implicit none
6353  character(*), intent(in):: message
6354  real, intent(in):: answer(:,:,:,:,:)
6355  real, intent(in):: check(:,:,:,:,:)
6356  integer, intent(in):: significant_digits
6357  integer, intent(in):: ignore_digits
6358  logical:: err_flag
6359  character(STRING):: pos_str
6360  real:: wrong, right_max, right_min
6361  character(STRING):: pos_str_space
6362  integer:: pos_str_len
6363  real:: right_tmp
6364 
6365  integer:: answer_shape(5), check_shape(5), pos(5)
6366  logical:: consist_shape(5)
6367  character(TOKEN):: pos_array(5)
6368  integer, allocatable:: mask_array(:,:,:,:,:)
6369  logical, allocatable:: judge(:,:,:,:,:)
6370  logical, allocatable:: judge_rev(:,:,:,:,:)
6371  logical, allocatable:: answer_negative(:,:,:,:,:)
6372  logical, allocatable:: check_negative(:,:,:,:,:)
6373  logical, allocatable:: both_negative(:,:,:,:,:)
6374  real, allocatable:: answer_max(:,:,:,:,:)
6375  real, allocatable:: answer_min(:,:,:,:,:)
6376 
6377  continue
6378  err_flag = .false.
6379 
6380  if ( significant_digits < 1 ) then
6381  write(*,*) ' *** Error [AssertEQ] *** '
6382  write(*,*) ' Specify a number more than 1 to "significant_digits"'
6383  call abort()
6384  end if
6385 
6386  answer_shape = shape(answer)
6387  check_shape = shape(check)
6388 
6389  consist_shape = answer_shape == check_shape
6390 
6391  if (.not. all(consist_shape)) then
6392  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6393  write(*,*) ''
6394  write(*,*) ' shape of check is (', check_shape, ')'
6395  write(*,*) ' is INCORRECT'
6396  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
6397 
6398  call abort()
6399  end if
6400 
6401 
6402  allocate( mask_array( &
6403  & answer_shape(1), &
6404 
6405  & answer_shape(2), &
6406 
6407  & answer_shape(3), &
6408 
6409  & answer_shape(4), &
6410 
6411  & answer_shape(5) ) &
6412  & )
6413 
6414  allocate( judge( &
6415  & answer_shape(1), &
6416 
6417  & answer_shape(2), &
6418 
6419  & answer_shape(3), &
6420 
6421  & answer_shape(4), &
6422 
6423  & answer_shape(5) ) &
6424  & )
6425 
6426  allocate( judge_rev( &
6427  & answer_shape(1), &
6428 
6429  & answer_shape(2), &
6430 
6431  & answer_shape(3), &
6432 
6433  & answer_shape(4), &
6434 
6435  & answer_shape(5) ) &
6436  & )
6437 
6438  allocate( answer_negative( &
6439  & answer_shape(1), &
6440 
6441  & answer_shape(2), &
6442 
6443  & answer_shape(3), &
6444 
6445  & answer_shape(4), &
6446 
6447  & answer_shape(5) ) &
6448  & )
6449 
6450  allocate( check_negative( &
6451  & answer_shape(1), &
6452 
6453  & answer_shape(2), &
6454 
6455  & answer_shape(3), &
6456 
6457  & answer_shape(4), &
6458 
6459  & answer_shape(5) ) &
6460  & )
6461 
6462  allocate( both_negative( &
6463  & answer_shape(1), &
6464 
6465  & answer_shape(2), &
6466 
6467  & answer_shape(3), &
6468 
6469  & answer_shape(4), &
6470 
6471  & answer_shape(5) ) &
6472  & )
6473 
6474  allocate( answer_max( &
6475  & answer_shape(1), &
6476 
6477  & answer_shape(2), &
6478 
6479  & answer_shape(3), &
6480 
6481  & answer_shape(4), &
6482 
6483  & answer_shape(5) ) &
6484  & )
6485 
6486  allocate( answer_min( &
6487  & answer_shape(1), &
6488 
6489  & answer_shape(2), &
6490 
6491  & answer_shape(3), &
6492 
6493  & answer_shape(4), &
6494 
6495  & answer_shape(5) ) &
6496  & )
6497 
6498  answer_negative = answer < 0.0
6499  check_negative = check < 0.0
6500  both_negative = answer_negative .and. check_negative
6501 
6502  where (both_negative)
6503  answer_max = &
6504  & answer &
6505  & * ( 1.0 &
6506  & - 0.1 ** significant_digits ) &
6507  & + 0.1 ** (- ignore_digits)
6508 
6509  answer_min = &
6510  & answer &
6511  & * ( 1.0 &
6512  & + 0.1 ** significant_digits ) &
6513  & - 0.1 ** (- ignore_digits)
6514  elsewhere
6515  answer_max = &
6516  & answer &
6517  & * ( 1.0 &
6518  & + 0.1 ** significant_digits ) &
6519  & + 0.1 ** (- ignore_digits)
6520 
6521  answer_min = &
6522  & answer &
6523  & * ( 1.0 &
6524  & - 0.1 ** significant_digits ) &
6525  & - 0.1 ** (- ignore_digits)
6526  end where
6527 
6528  judge = answer_max > check .and. check > answer_min
6529  judge_rev = .not. judge
6530  err_flag = any(judge_rev)
6531  mask_array = 1
6532  pos = maxloc(mask_array, judge_rev)
6533 
6534  if (err_flag) then
6535 
6536  wrong = check( &
6537  & pos(1), &
6538 
6539  & pos(2), &
6540 
6541  & pos(3), &
6542 
6543  & pos(4), &
6544 
6545  & pos(5) )
6546 
6547  right_max = answer_max( &
6548  & pos(1), &
6549 
6550  & pos(2), &
6551 
6552  & pos(3), &
6553 
6554  & pos(4), &
6555 
6556  & pos(5) )
6557 
6558  right_min = answer_min( &
6559  & pos(1), &
6560 
6561  & pos(2), &
6562 
6563  & pos(3), &
6564 
6565  & pos(4), &
6566 
6567  & pos(5) )
6568 
6569  if ( right_max < right_min ) then
6570  right_tmp = right_max
6571  right_max = right_min
6572  right_min = right_tmp
6573  end if
6574 
6575  write(unit=pos_array(1), fmt="(i20)") pos(1)
6576 
6577  write(unit=pos_array(2), fmt="(i20)") pos(2)
6578 
6579  write(unit=pos_array(3), fmt="(i20)") pos(3)
6580 
6581  write(unit=pos_array(4), fmt="(i20)") pos(4)
6582 
6583  write(unit=pos_array(5), fmt="(i20)") pos(5)
6584 
6585 
6586  pos_str = '(' // &
6587  & trim(adjustl(pos_array(1))) // ',' // &
6588 
6589  & trim(adjustl(pos_array(2))) // ',' // &
6590 
6591  & trim(adjustl(pos_array(3))) // ',' // &
6592 
6593  & trim(adjustl(pos_array(4))) // ',' // &
6594 
6595  & trim(adjustl(pos_array(5))) // ')'
6596 
6597  end if
6598  deallocate(mask_array, judge, judge_rev)
6599  deallocate(answer_negative, check_negative, both_negative)
6600  deallocate(answer_max, answer_min)
6601 
6602 
6603 
6604  if (err_flag) then
6605  pos_str_space = ''
6606  pos_str_len = len_trim(pos_str)
6607 
6608  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6609  write(*,*) ''
6610  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
6611  write(*,*) ' is NOT EQUAL to'
6612  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
6613  & // ' ', right_min, ' < '
6614  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
6615 
6616  call abort()
6617  else
6618  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
6619  end if
6620 
6621 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequalreal6digits()

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

Definition at line 6627 of file dc_test.f90.

References dc_types::string, and dc_types::token.

6627  use dc_types, only: string, token
6628  implicit none
6629  character(*), intent(in):: message
6630  real, intent(in):: answer(:,:,:,:,:,:)
6631  real, intent(in):: check(:,:,:,:,:,:)
6632  integer, intent(in):: significant_digits
6633  integer, intent(in):: ignore_digits
6634  logical:: err_flag
6635  character(STRING):: pos_str
6636  real:: wrong, right_max, right_min
6637  character(STRING):: pos_str_space
6638  integer:: pos_str_len
6639  real:: right_tmp
6640 
6641  integer:: answer_shape(6), check_shape(6), pos(6)
6642  logical:: consist_shape(6)
6643  character(TOKEN):: pos_array(6)
6644  integer, allocatable:: mask_array(:,:,:,:,:,:)
6645  logical, allocatable:: judge(:,:,:,:,:,:)
6646  logical, allocatable:: judge_rev(:,:,:,:,:,:)
6647  logical, allocatable:: answer_negative(:,:,:,:,:,:)
6648  logical, allocatable:: check_negative(:,:,:,:,:,:)
6649  logical, allocatable:: both_negative(:,:,:,:,:,:)
6650  real, allocatable:: answer_max(:,:,:,:,:,:)
6651  real, allocatable:: answer_min(:,:,:,:,:,:)
6652 
6653  continue
6654  err_flag = .false.
6655 
6656  if ( significant_digits < 1 ) then
6657  write(*,*) ' *** Error [AssertEQ] *** '
6658  write(*,*) ' Specify a number more than 1 to "significant_digits"'
6659  call abort()
6660  end if
6661 
6662  answer_shape = shape(answer)
6663  check_shape = shape(check)
6664 
6665  consist_shape = answer_shape == check_shape
6666 
6667  if (.not. all(consist_shape)) then
6668  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6669  write(*,*) ''
6670  write(*,*) ' shape of check is (', check_shape, ')'
6671  write(*,*) ' is INCORRECT'
6672  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
6673 
6674  call abort()
6675  end if
6676 
6677 
6678  allocate( mask_array( &
6679  & answer_shape(1), &
6680 
6681  & answer_shape(2), &
6682 
6683  & answer_shape(3), &
6684 
6685  & answer_shape(4), &
6686 
6687  & answer_shape(5), &
6688 
6689  & answer_shape(6) ) &
6690  & )
6691 
6692  allocate( judge( &
6693  & answer_shape(1), &
6694 
6695  & answer_shape(2), &
6696 
6697  & answer_shape(3), &
6698 
6699  & answer_shape(4), &
6700 
6701  & answer_shape(5), &
6702 
6703  & answer_shape(6) ) &
6704  & )
6705 
6706  allocate( judge_rev( &
6707  & answer_shape(1), &
6708 
6709  & answer_shape(2), &
6710 
6711  & answer_shape(3), &
6712 
6713  & answer_shape(4), &
6714 
6715  & answer_shape(5), &
6716 
6717  & answer_shape(6) ) &
6718  & )
6719 
6720  allocate( answer_negative( &
6721  & answer_shape(1), &
6722 
6723  & answer_shape(2), &
6724 
6725  & answer_shape(3), &
6726 
6727  & answer_shape(4), &
6728 
6729  & answer_shape(5), &
6730 
6731  & answer_shape(6) ) &
6732  & )
6733 
6734  allocate( check_negative( &
6735  & answer_shape(1), &
6736 
6737  & answer_shape(2), &
6738 
6739  & answer_shape(3), &
6740 
6741  & answer_shape(4), &
6742 
6743  & answer_shape(5), &
6744 
6745  & answer_shape(6) ) &
6746  & )
6747 
6748  allocate( both_negative( &
6749  & answer_shape(1), &
6750 
6751  & answer_shape(2), &
6752 
6753  & answer_shape(3), &
6754 
6755  & answer_shape(4), &
6756 
6757  & answer_shape(5), &
6758 
6759  & answer_shape(6) ) &
6760  & )
6761 
6762  allocate( answer_max( &
6763  & answer_shape(1), &
6764 
6765  & answer_shape(2), &
6766 
6767  & answer_shape(3), &
6768 
6769  & answer_shape(4), &
6770 
6771  & answer_shape(5), &
6772 
6773  & answer_shape(6) ) &
6774  & )
6775 
6776  allocate( answer_min( &
6777  & answer_shape(1), &
6778 
6779  & answer_shape(2), &
6780 
6781  & answer_shape(3), &
6782 
6783  & answer_shape(4), &
6784 
6785  & answer_shape(5), &
6786 
6787  & answer_shape(6) ) &
6788  & )
6789 
6790  answer_negative = answer < 0.0
6791  check_negative = check < 0.0
6792  both_negative = answer_negative .and. check_negative
6793 
6794  where (both_negative)
6795  answer_max = &
6796  & answer &
6797  & * ( 1.0 &
6798  & - 0.1 ** significant_digits ) &
6799  & + 0.1 ** (- ignore_digits)
6800 
6801  answer_min = &
6802  & answer &
6803  & * ( 1.0 &
6804  & + 0.1 ** significant_digits ) &
6805  & - 0.1 ** (- ignore_digits)
6806  elsewhere
6807  answer_max = &
6808  & answer &
6809  & * ( 1.0 &
6810  & + 0.1 ** significant_digits ) &
6811  & + 0.1 ** (- ignore_digits)
6812 
6813  answer_min = &
6814  & answer &
6815  & * ( 1.0 &
6816  & - 0.1 ** significant_digits ) &
6817  & - 0.1 ** (- ignore_digits)
6818  end where
6819 
6820  judge = answer_max > check .and. check > answer_min
6821  judge_rev = .not. judge
6822  err_flag = any(judge_rev)
6823  mask_array = 1
6824  pos = maxloc(mask_array, judge_rev)
6825 
6826  if (err_flag) then
6827 
6828  wrong = check( &
6829  & pos(1), &
6830 
6831  & pos(2), &
6832 
6833  & pos(3), &
6834 
6835  & pos(4), &
6836 
6837  & pos(5), &
6838 
6839  & pos(6) )
6840 
6841  right_max = answer_max( &
6842  & pos(1), &
6843 
6844  & pos(2), &
6845 
6846  & pos(3), &
6847 
6848  & pos(4), &
6849 
6850  & pos(5), &
6851 
6852  & pos(6) )
6853 
6854  right_min = answer_min( &
6855  & pos(1), &
6856 
6857  & pos(2), &
6858 
6859  & pos(3), &
6860 
6861  & pos(4), &
6862 
6863  & pos(5), &
6864 
6865  & pos(6) )
6866 
6867  if ( right_max < right_min ) then
6868  right_tmp = right_max
6869  right_max = right_min
6870  right_min = right_tmp
6871  end if
6872 
6873  write(unit=pos_array(1), fmt="(i20)") pos(1)
6874 
6875  write(unit=pos_array(2), fmt="(i20)") pos(2)
6876 
6877  write(unit=pos_array(3), fmt="(i20)") pos(3)
6878 
6879  write(unit=pos_array(4), fmt="(i20)") pos(4)
6880 
6881  write(unit=pos_array(5), fmt="(i20)") pos(5)
6882 
6883  write(unit=pos_array(6), fmt="(i20)") pos(6)
6884 
6885 
6886  pos_str = '(' // &
6887  & trim(adjustl(pos_array(1))) // ',' // &
6888 
6889  & trim(adjustl(pos_array(2))) // ',' // &
6890 
6891  & trim(adjustl(pos_array(3))) // ',' // &
6892 
6893  & trim(adjustl(pos_array(4))) // ',' // &
6894 
6895  & trim(adjustl(pos_array(5))) // ',' // &
6896 
6897  & trim(adjustl(pos_array(6))) // ')'
6898 
6899  end if
6900  deallocate(mask_array, judge, judge_rev)
6901  deallocate(answer_negative, check_negative, both_negative)
6902  deallocate(answer_max, answer_min)
6903 
6904 
6905 
6906  if (err_flag) then
6907  pos_str_space = ''
6908  pos_str_len = len_trim(pos_str)
6909 
6910  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6911  write(*,*) ''
6912  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
6913  write(*,*) ' is NOT EQUAL to'
6914  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
6915  & // ' ', right_min, ' < '
6916  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
6917 
6918  call abort()
6919  else
6920  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
6921  end if
6922 
6923 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequalreal7digits()

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

Definition at line 6929 of file dc_test.f90.

References dc_types::string, and dc_types::token.

6929  use dc_types, only: string, token
6930  implicit none
6931  character(*), intent(in):: message
6932  real, intent(in):: answer(:,:,:,:,:,:,:)
6933  real, intent(in):: check(:,:,:,:,:,:,:)
6934  integer, intent(in):: significant_digits
6935  integer, intent(in):: ignore_digits
6936  logical:: err_flag
6937  character(STRING):: pos_str
6938  real:: wrong, right_max, right_min
6939  character(STRING):: pos_str_space
6940  integer:: pos_str_len
6941  real:: right_tmp
6942 
6943  integer:: answer_shape(7), check_shape(7), pos(7)
6944  logical:: consist_shape(7)
6945  character(TOKEN):: pos_array(7)
6946  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
6947  logical, allocatable:: judge(:,:,:,:,:,:,:)
6948  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
6949  logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
6950  logical, allocatable:: check_negative(:,:,:,:,:,:,:)
6951  logical, allocatable:: both_negative(:,:,:,:,:,:,:)
6952  real, allocatable:: answer_max(:,:,:,:,:,:,:)
6953  real, allocatable:: answer_min(:,:,:,:,:,:,:)
6954 
6955  continue
6956  err_flag = .false.
6957 
6958  if ( significant_digits < 1 ) then
6959  write(*,*) ' *** Error [AssertEQ] *** '
6960  write(*,*) ' Specify a number more than 1 to "significant_digits"'
6961  call abort()
6962  end if
6963 
6964  answer_shape = shape(answer)
6965  check_shape = shape(check)
6966 
6967  consist_shape = answer_shape == check_shape
6968 
6969  if (.not. all(consist_shape)) then
6970  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
6971  write(*,*) ''
6972  write(*,*) ' shape of check is (', check_shape, ')'
6973  write(*,*) ' is INCORRECT'
6974  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
6975 
6976  call abort()
6977  end if
6978 
6979 
6980  allocate( mask_array( &
6981  & answer_shape(1), &
6982 
6983  & answer_shape(2), &
6984 
6985  & answer_shape(3), &
6986 
6987  & answer_shape(4), &
6988 
6989  & answer_shape(5), &
6990 
6991  & answer_shape(6), &
6992 
6993  & answer_shape(7) ) &
6994  & )
6995 
6996  allocate( judge( &
6997  & answer_shape(1), &
6998 
6999  & answer_shape(2), &
7000 
7001  & answer_shape(3), &
7002 
7003  & answer_shape(4), &
7004 
7005  & answer_shape(5), &
7006 
7007  & answer_shape(6), &
7008 
7009  & answer_shape(7) ) &
7010  & )
7011 
7012  allocate( judge_rev( &
7013  & answer_shape(1), &
7014 
7015  & answer_shape(2), &
7016 
7017  & answer_shape(3), &
7018 
7019  & answer_shape(4), &
7020 
7021  & answer_shape(5), &
7022 
7023  & answer_shape(6), &
7024 
7025  & answer_shape(7) ) &
7026  & )
7027 
7028  allocate( answer_negative( &
7029  & answer_shape(1), &
7030 
7031  & answer_shape(2), &
7032 
7033  & answer_shape(3), &
7034 
7035  & answer_shape(4), &
7036 
7037  & answer_shape(5), &
7038 
7039  & answer_shape(6), &
7040 
7041  & answer_shape(7) ) &
7042  & )
7043 
7044  allocate( check_negative( &
7045  & answer_shape(1), &
7046 
7047  & answer_shape(2), &
7048 
7049  & answer_shape(3), &
7050 
7051  & answer_shape(4), &
7052 
7053  & answer_shape(5), &
7054 
7055  & answer_shape(6), &
7056 
7057  & answer_shape(7) ) &
7058  & )
7059 
7060  allocate( both_negative( &
7061  & answer_shape(1), &
7062 
7063  & answer_shape(2), &
7064 
7065  & answer_shape(3), &
7066 
7067  & answer_shape(4), &
7068 
7069  & answer_shape(5), &
7070 
7071  & answer_shape(6), &
7072 
7073  & answer_shape(7) ) &
7074  & )
7075 
7076  allocate( answer_max( &
7077  & answer_shape(1), &
7078 
7079  & answer_shape(2), &
7080 
7081  & answer_shape(3), &
7082 
7083  & answer_shape(4), &
7084 
7085  & answer_shape(5), &
7086 
7087  & answer_shape(6), &
7088 
7089  & answer_shape(7) ) &
7090  & )
7091 
7092  allocate( answer_min( &
7093  & answer_shape(1), &
7094 
7095  & answer_shape(2), &
7096 
7097  & answer_shape(3), &
7098 
7099  & answer_shape(4), &
7100 
7101  & answer_shape(5), &
7102 
7103  & answer_shape(6), &
7104 
7105  & answer_shape(7) ) &
7106  & )
7107 
7108  answer_negative = answer < 0.0
7109  check_negative = check < 0.0
7110  both_negative = answer_negative .and. check_negative
7111 
7112  where (both_negative)
7113  answer_max = &
7114  & answer &
7115  & * ( 1.0 &
7116  & - 0.1 ** significant_digits ) &
7117  & + 0.1 ** (- ignore_digits)
7118 
7119  answer_min = &
7120  & answer &
7121  & * ( 1.0 &
7122  & + 0.1 ** significant_digits ) &
7123  & - 0.1 ** (- ignore_digits)
7124  elsewhere
7125  answer_max = &
7126  & answer &
7127  & * ( 1.0 &
7128  & + 0.1 ** significant_digits ) &
7129  & + 0.1 ** (- ignore_digits)
7130 
7131  answer_min = &
7132  & answer &
7133  & * ( 1.0 &
7134  & - 0.1 ** significant_digits ) &
7135  & - 0.1 ** (- ignore_digits)
7136  end where
7137 
7138  judge = answer_max > check .and. check > answer_min
7139  judge_rev = .not. judge
7140  err_flag = any(judge_rev)
7141  mask_array = 1
7142  pos = maxloc(mask_array, judge_rev)
7143 
7144  if (err_flag) then
7145 
7146  wrong = check( &
7147  & pos(1), &
7148 
7149  & pos(2), &
7150 
7151  & pos(3), &
7152 
7153  & pos(4), &
7154 
7155  & pos(5), &
7156 
7157  & pos(6), &
7158 
7159  & pos(7) )
7160 
7161  right_max = answer_max( &
7162  & pos(1), &
7163 
7164  & pos(2), &
7165 
7166  & pos(3), &
7167 
7168  & pos(4), &
7169 
7170  & pos(5), &
7171 
7172  & pos(6), &
7173 
7174  & pos(7) )
7175 
7176  right_min = answer_min( &
7177  & pos(1), &
7178 
7179  & pos(2), &
7180 
7181  & pos(3), &
7182 
7183  & pos(4), &
7184 
7185  & pos(5), &
7186 
7187  & pos(6), &
7188 
7189  & pos(7) )
7190 
7191  if ( right_max < right_min ) then
7192  right_tmp = right_max
7193  right_max = right_min
7194  right_min = right_tmp
7195  end if
7196 
7197  write(unit=pos_array(1), fmt="(i20)") pos(1)
7198 
7199  write(unit=pos_array(2), fmt="(i20)") pos(2)
7200 
7201  write(unit=pos_array(3), fmt="(i20)") pos(3)
7202 
7203  write(unit=pos_array(4), fmt="(i20)") pos(4)
7204 
7205  write(unit=pos_array(5), fmt="(i20)") pos(5)
7206 
7207  write(unit=pos_array(6), fmt="(i20)") pos(6)
7208 
7209  write(unit=pos_array(7), fmt="(i20)") pos(7)
7210 
7211 
7212  pos_str = '(' // &
7213  & trim(adjustl(pos_array(1))) // ',' // &
7214 
7215  & trim(adjustl(pos_array(2))) // ',' // &
7216 
7217  & trim(adjustl(pos_array(3))) // ',' // &
7218 
7219  & trim(adjustl(pos_array(4))) // ',' // &
7220 
7221  & trim(adjustl(pos_array(5))) // ',' // &
7222 
7223  & trim(adjustl(pos_array(6))) // ',' // &
7224 
7225  & trim(adjustl(pos_array(7))) // ')'
7226 
7227  end if
7228  deallocate(mask_array, judge, judge_rev)
7229  deallocate(answer_negative, check_negative, both_negative)
7230  deallocate(answer_max, answer_min)
7231 
7232 
7233 
7234  if (err_flag) then
7235  pos_str_space = ''
7236  pos_str_len = len_trim(pos_str)
7237 
7238  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7239  write(*,*) ''
7240  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
7241  write(*,*) ' is NOT EQUAL to'
7242  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
7243  & // ' ', right_min, ' < '
7244  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
7245 
7246  call abort()
7247  else
7248  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
7249  end if
7250 
7251 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequaldouble0digits()

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

Definition at line 7257 of file dc_test.f90.

References dc_types::string, and dc_types::token.

7257  use dc_types, only: string, token
7258  implicit none
7259  character(*), intent(in):: message
7260  real(DP), intent(in):: answer
7261  real(DP), intent(in):: check
7262  integer, intent(in):: significant_digits
7263  integer, intent(in):: ignore_digits
7264  logical:: err_flag
7265  character(STRING):: pos_str
7266  real(DP):: wrong, right_max, right_min
7267  character(STRING):: pos_str_space
7268  integer:: pos_str_len
7269  real(DP):: right_tmp
7270 
7271  real(DP):: answer_max
7272  real(DP):: answer_min
7273 
7274  continue
7275  err_flag = .false.
7276 
7277  if ( significant_digits < 1 ) then
7278  write(*,*) ' *** Error [AssertEQ] *** '
7279  write(*,*) ' Specify a number more than 1 to "significant_digits"'
7280  call abort()
7281  end if
7282 
7283  if ( answer < 0.0_dp .and. check < 0.0_dp ) then
7284  answer_max = &
7285  & answer &
7286  & * ( 1.0_dp &
7287  & - 0.1_dp ** significant_digits ) &
7288  & + 0.1_dp ** (- ignore_digits)
7289 
7290  answer_min = &
7291  & answer &
7292  & * ( 1.0_dp &
7293  & + 0.1_dp ** significant_digits ) &
7294  & - 0.1_dp ** (- ignore_digits)
7295  else
7296 
7297  answer_max = &
7298  & answer &
7299  & * ( 1.0_dp &
7300  & + 0.1_dp ** significant_digits ) &
7301  & + 0.1_dp ** (- ignore_digits)
7302 
7303  answer_min = &
7304  & answer &
7305  & * ( 1.0_dp &
7306  & - 0.1_dp ** significant_digits ) &
7307  & - 0.1_dp ** (- ignore_digits)
7308  end if
7309 
7310  wrong = check
7311  right_max = answer_max
7312  right_min = answer_min
7313  if ( right_max < right_min ) then
7314  right_tmp = right_max
7315  right_max = right_min
7316  right_min = right_tmp
7317  end if
7318 
7319  err_flag = .not. (answer_max > check .and. check > answer_min)
7320 
7321  pos_str = ''
7322 
7323 
7324 
7325  if (err_flag) then
7326  pos_str_space = ''
7327  pos_str_len = len_trim(pos_str)
7328 
7329  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7330  write(*,*) ''
7331  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
7332  write(*,*) ' is NOT EQUAL to'
7333  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
7334  & // ' ', right_min, ' < '
7335  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
7336 
7337  call abort()
7338  else
7339  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
7340  end if
7341 
7342 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequaldouble1digits()

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

Definition at line 7348 of file dc_test.f90.

References dc_types::string, and dc_types::token.

7348  use dc_types, only: string, token
7349  implicit none
7350  character(*), intent(in):: message
7351  real(DP), intent(in):: answer(:)
7352  real(DP), intent(in):: check(:)
7353  integer, intent(in):: significant_digits
7354  integer, intent(in):: ignore_digits
7355  logical:: err_flag
7356  character(STRING):: pos_str
7357  real(DP):: wrong, right_max, right_min
7358  character(STRING):: pos_str_space
7359  integer:: pos_str_len
7360  real(DP):: right_tmp
7361 
7362  integer:: answer_shape(1), check_shape(1), pos(1)
7363  logical:: consist_shape(1)
7364  character(TOKEN):: pos_array(1)
7365  integer, allocatable:: mask_array(:)
7366  logical, allocatable:: judge(:)
7367  logical, allocatable:: judge_rev(:)
7368  logical, allocatable:: answer_negative(:)
7369  logical, allocatable:: check_negative(:)
7370  logical, allocatable:: both_negative(:)
7371  real(DP), allocatable:: answer_max(:)
7372  real(DP), allocatable:: answer_min(:)
7373 
7374  continue
7375  err_flag = .false.
7376 
7377  if ( significant_digits < 1 ) then
7378  write(*,*) ' *** Error [AssertEQ] *** '
7379  write(*,*) ' Specify a number more than 1 to "significant_digits"'
7380  call abort()
7381  end if
7382 
7383  answer_shape = shape(answer)
7384  check_shape = shape(check)
7385 
7386  consist_shape = answer_shape == check_shape
7387 
7388  if (.not. all(consist_shape)) then
7389  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7390  write(*,*) ''
7391  write(*,*) ' shape of check is (', check_shape, ')'
7392  write(*,*) ' is INCORRECT'
7393  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
7394 
7395  call abort()
7396  end if
7397 
7398 
7399  allocate( mask_array( &
7400 
7401  & answer_shape(1) ) &
7402  & )
7403 
7404  allocate( judge( &
7405 
7406  & answer_shape(1) ) &
7407  & )
7408 
7409  allocate( judge_rev( &
7410 
7411  & answer_shape(1) ) &
7412  & )
7413 
7414  allocate( answer_negative( &
7415 
7416  & answer_shape(1) ) &
7417  & )
7418 
7419  allocate( check_negative( &
7420 
7421  & answer_shape(1) ) &
7422  & )
7423 
7424  allocate( both_negative( &
7425 
7426  & answer_shape(1) ) &
7427  & )
7428 
7429  allocate( answer_max( &
7430 
7431  & answer_shape(1) ) &
7432  & )
7433 
7434  allocate( answer_min( &
7435 
7436  & answer_shape(1) ) &
7437  & )
7438 
7439  answer_negative = answer < 0.0_dp
7440  check_negative = check < 0.0_dp
7441  both_negative = answer_negative .and. check_negative
7442 
7443  where (both_negative)
7444  answer_max = &
7445  & answer &
7446  & * ( 1.0_dp &
7447  & - 0.1_dp ** significant_digits ) &
7448  & + 0.1_dp ** (- ignore_digits)
7449 
7450  answer_min = &
7451  & answer &
7452  & * ( 1.0_dp &
7453  & + 0.1_dp ** significant_digits ) &
7454  & - 0.1_dp ** (- ignore_digits)
7455  elsewhere
7456  answer_max = &
7457  & answer &
7458  & * ( 1.0_dp &
7459  & + 0.1_dp ** significant_digits ) &
7460  & + 0.1_dp ** (- ignore_digits)
7461 
7462  answer_min = &
7463  & answer &
7464  & * ( 1.0_dp &
7465  & - 0.1_dp ** significant_digits ) &
7466  & - 0.1_dp ** (- ignore_digits)
7467  end where
7468 
7469  judge = answer_max > check .and. check > answer_min
7470  judge_rev = .not. judge
7471  err_flag = any(judge_rev)
7472  mask_array = 1
7473  pos = maxloc(mask_array, judge_rev)
7474 
7475  if (err_flag) then
7476 
7477  wrong = check( &
7478 
7479  & pos(1) )
7480 
7481  right_max = answer_max( &
7482 
7483  & pos(1) )
7484 
7485  right_min = answer_min( &
7486 
7487  & pos(1) )
7488 
7489  if ( right_max < right_min ) then
7490  right_tmp = right_max
7491  right_max = right_min
7492  right_min = right_tmp
7493  end if
7494 
7495  write(unit=pos_array(1), fmt="(i20)") pos(1)
7496 
7497 
7498  pos_str = '(' // &
7499 
7500  & trim(adjustl(pos_array(1))) // ')'
7501 
7502  end if
7503  deallocate(mask_array, judge, judge_rev)
7504  deallocate(answer_negative, check_negative, both_negative)
7505  deallocate(answer_max, answer_min)
7506 
7507 
7508 
7509  if (err_flag) then
7510  pos_str_space = ''
7511  pos_str_len = len_trim(pos_str)
7512 
7513  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7514  write(*,*) ''
7515  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
7516  write(*,*) ' is NOT EQUAL to'
7517  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
7518  & // ' ', right_min, ' < '
7519  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
7520 
7521  call abort()
7522  else
7523  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
7524  end if
7525 
7526 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequaldouble2digits()

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

Definition at line 7532 of file dc_test.f90.

References dc_types::string, and dc_types::token.

7532  use dc_types, only: string, token
7533  implicit none
7534  character(*), intent(in):: message
7535  real(DP), intent(in):: answer(:,:)
7536  real(DP), intent(in):: check(:,:)
7537  integer, intent(in):: significant_digits
7538  integer, intent(in):: ignore_digits
7539  logical:: err_flag
7540  character(STRING):: pos_str
7541  real(DP):: wrong, right_max, right_min
7542  character(STRING):: pos_str_space
7543  integer:: pos_str_len
7544  real(DP):: right_tmp
7545 
7546  integer:: answer_shape(2), check_shape(2), pos(2)
7547  logical:: consist_shape(2)
7548  character(TOKEN):: pos_array(2)
7549  integer, allocatable:: mask_array(:,:)
7550  logical, allocatable:: judge(:,:)
7551  logical, allocatable:: judge_rev(:,:)
7552  logical, allocatable:: answer_negative(:,:)
7553  logical, allocatable:: check_negative(:,:)
7554  logical, allocatable:: both_negative(:,:)
7555  real(DP), allocatable:: answer_max(:,:)
7556  real(DP), allocatable:: answer_min(:,:)
7557 
7558  continue
7559  err_flag = .false.
7560 
7561  if ( significant_digits < 1 ) then
7562  write(*,*) ' *** Error [AssertEQ] *** '
7563  write(*,*) ' Specify a number more than 1 to "significant_digits"'
7564  call abort()
7565  end if
7566 
7567  answer_shape = shape(answer)
7568  check_shape = shape(check)
7569 
7570  consist_shape = answer_shape == check_shape
7571 
7572  if (.not. all(consist_shape)) then
7573  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7574  write(*,*) ''
7575  write(*,*) ' shape of check is (', check_shape, ')'
7576  write(*,*) ' is INCORRECT'
7577  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
7578 
7579  call abort()
7580  end if
7581 
7582 
7583  allocate( mask_array( &
7584  & answer_shape(1), &
7585 
7586  & answer_shape(2) ) &
7587  & )
7588 
7589  allocate( judge( &
7590  & answer_shape(1), &
7591 
7592  & answer_shape(2) ) &
7593  & )
7594 
7595  allocate( judge_rev( &
7596  & answer_shape(1), &
7597 
7598  & answer_shape(2) ) &
7599  & )
7600 
7601  allocate( answer_negative( &
7602  & answer_shape(1), &
7603 
7604  & answer_shape(2) ) &
7605  & )
7606 
7607  allocate( check_negative( &
7608  & answer_shape(1), &
7609 
7610  & answer_shape(2) ) &
7611  & )
7612 
7613  allocate( both_negative( &
7614  & answer_shape(1), &
7615 
7616  & answer_shape(2) ) &
7617  & )
7618 
7619  allocate( answer_max( &
7620  & answer_shape(1), &
7621 
7622  & answer_shape(2) ) &
7623  & )
7624 
7625  allocate( answer_min( &
7626  & answer_shape(1), &
7627 
7628  & answer_shape(2) ) &
7629  & )
7630 
7631  answer_negative = answer < 0.0_dp
7632  check_negative = check < 0.0_dp
7633  both_negative = answer_negative .and. check_negative
7634 
7635  where (both_negative)
7636  answer_max = &
7637  & answer &
7638  & * ( 1.0_dp &
7639  & - 0.1_dp ** significant_digits ) &
7640  & + 0.1_dp ** (- ignore_digits)
7641 
7642  answer_min = &
7643  & answer &
7644  & * ( 1.0_dp &
7645  & + 0.1_dp ** significant_digits ) &
7646  & - 0.1_dp ** (- ignore_digits)
7647  elsewhere
7648  answer_max = &
7649  & answer &
7650  & * ( 1.0_dp &
7651  & + 0.1_dp ** significant_digits ) &
7652  & + 0.1_dp ** (- ignore_digits)
7653 
7654  answer_min = &
7655  & answer &
7656  & * ( 1.0_dp &
7657  & - 0.1_dp ** significant_digits ) &
7658  & - 0.1_dp ** (- ignore_digits)
7659  end where
7660 
7661  judge = answer_max > check .and. check > answer_min
7662  judge_rev = .not. judge
7663  err_flag = any(judge_rev)
7664  mask_array = 1
7665  pos = maxloc(mask_array, judge_rev)
7666 
7667  if (err_flag) then
7668 
7669  wrong = check( &
7670  & pos(1), &
7671 
7672  & pos(2) )
7673 
7674  right_max = answer_max( &
7675  & pos(1), &
7676 
7677  & pos(2) )
7678 
7679  right_min = answer_min( &
7680  & pos(1), &
7681 
7682  & pos(2) )
7683 
7684  if ( right_max < right_min ) then
7685  right_tmp = right_max
7686  right_max = right_min
7687  right_min = right_tmp
7688  end if
7689 
7690  write(unit=pos_array(1), fmt="(i20)") pos(1)
7691 
7692  write(unit=pos_array(2), fmt="(i20)") pos(2)
7693 
7694 
7695  pos_str = '(' // &
7696  & trim(adjustl(pos_array(1))) // ',' // &
7697 
7698  & trim(adjustl(pos_array(2))) // ')'
7699 
7700  end if
7701  deallocate(mask_array, judge, judge_rev)
7702  deallocate(answer_negative, check_negative, both_negative)
7703  deallocate(answer_max, answer_min)
7704 
7705 
7706 
7707  if (err_flag) then
7708  pos_str_space = ''
7709  pos_str_len = len_trim(pos_str)
7710 
7711  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7712  write(*,*) ''
7713  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
7714  write(*,*) ' is NOT EQUAL to'
7715  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
7716  & // ' ', right_min, ' < '
7717  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
7718 
7719  call abort()
7720  else
7721  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
7722  end if
7723 
7724 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequaldouble3digits()

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

Definition at line 7730 of file dc_test.f90.

References dc_types::string, and dc_types::token.

7730  use dc_types, only: string, token
7731  implicit none
7732  character(*), intent(in):: message
7733  real(DP), intent(in):: answer(:,:,:)
7734  real(DP), intent(in):: check(:,:,:)
7735  integer, intent(in):: significant_digits
7736  integer, intent(in):: ignore_digits
7737  logical:: err_flag
7738  character(STRING):: pos_str
7739  real(DP):: wrong, right_max, right_min
7740  character(STRING):: pos_str_space
7741  integer:: pos_str_len
7742  real(DP):: right_tmp
7743 
7744  integer:: answer_shape(3), check_shape(3), pos(3)
7745  logical:: consist_shape(3)
7746  character(TOKEN):: pos_array(3)
7747  integer, allocatable:: mask_array(:,:,:)
7748  logical, allocatable:: judge(:,:,:)
7749  logical, allocatable:: judge_rev(:,:,:)
7750  logical, allocatable:: answer_negative(:,:,:)
7751  logical, allocatable:: check_negative(:,:,:)
7752  logical, allocatable:: both_negative(:,:,:)
7753  real(DP), allocatable:: answer_max(:,:,:)
7754  real(DP), allocatable:: answer_min(:,:,:)
7755 
7756  continue
7757  err_flag = .false.
7758 
7759  if ( significant_digits < 1 ) then
7760  write(*,*) ' *** Error [AssertEQ] *** '
7761  write(*,*) ' Specify a number more than 1 to "significant_digits"'
7762  call abort()
7763  end if
7764 
7765  answer_shape = shape(answer)
7766  check_shape = shape(check)
7767 
7768  consist_shape = answer_shape == check_shape
7769 
7770  if (.not. all(consist_shape)) then
7771  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7772  write(*,*) ''
7773  write(*,*) ' shape of check is (', check_shape, ')'
7774  write(*,*) ' is INCORRECT'
7775  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
7776 
7777  call abort()
7778  end if
7779 
7780 
7781  allocate( mask_array( &
7782  & answer_shape(1), &
7783 
7784  & answer_shape(2), &
7785 
7786  & answer_shape(3) ) &
7787  & )
7788 
7789  allocate( judge( &
7790  & answer_shape(1), &
7791 
7792  & answer_shape(2), &
7793 
7794  & answer_shape(3) ) &
7795  & )
7796 
7797  allocate( judge_rev( &
7798  & answer_shape(1), &
7799 
7800  & answer_shape(2), &
7801 
7802  & answer_shape(3) ) &
7803  & )
7804 
7805  allocate( answer_negative( &
7806  & answer_shape(1), &
7807 
7808  & answer_shape(2), &
7809 
7810  & answer_shape(3) ) &
7811  & )
7812 
7813  allocate( check_negative( &
7814  & answer_shape(1), &
7815 
7816  & answer_shape(2), &
7817 
7818  & answer_shape(3) ) &
7819  & )
7820 
7821  allocate( both_negative( &
7822  & answer_shape(1), &
7823 
7824  & answer_shape(2), &
7825 
7826  & answer_shape(3) ) &
7827  & )
7828 
7829  allocate( answer_max( &
7830  & answer_shape(1), &
7831 
7832  & answer_shape(2), &
7833 
7834  & answer_shape(3) ) &
7835  & )
7836 
7837  allocate( answer_min( &
7838  & answer_shape(1), &
7839 
7840  & answer_shape(2), &
7841 
7842  & answer_shape(3) ) &
7843  & )
7844 
7845  answer_negative = answer < 0.0_dp
7846  check_negative = check < 0.0_dp
7847  both_negative = answer_negative .and. check_negative
7848 
7849  where (both_negative)
7850  answer_max = &
7851  & answer &
7852  & * ( 1.0_dp &
7853  & - 0.1_dp ** significant_digits ) &
7854  & + 0.1_dp ** (- ignore_digits)
7855 
7856  answer_min = &
7857  & answer &
7858  & * ( 1.0_dp &
7859  & + 0.1_dp ** significant_digits ) &
7860  & - 0.1_dp ** (- ignore_digits)
7861  elsewhere
7862  answer_max = &
7863  & answer &
7864  & * ( 1.0_dp &
7865  & + 0.1_dp ** significant_digits ) &
7866  & + 0.1_dp ** (- ignore_digits)
7867 
7868  answer_min = &
7869  & answer &
7870  & * ( 1.0_dp &
7871  & - 0.1_dp ** significant_digits ) &
7872  & - 0.1_dp ** (- ignore_digits)
7873  end where
7874 
7875  judge = answer_max > check .and. check > answer_min
7876  judge_rev = .not. judge
7877  err_flag = any(judge_rev)
7878  mask_array = 1
7879  pos = maxloc(mask_array, judge_rev)
7880 
7881  if (err_flag) then
7882 
7883  wrong = check( &
7884  & pos(1), &
7885 
7886  & pos(2), &
7887 
7888  & pos(3) )
7889 
7890  right_max = answer_max( &
7891  & pos(1), &
7892 
7893  & pos(2), &
7894 
7895  & pos(3) )
7896 
7897  right_min = answer_min( &
7898  & pos(1), &
7899 
7900  & pos(2), &
7901 
7902  & pos(3) )
7903 
7904  if ( right_max < right_min ) then
7905  right_tmp = right_max
7906  right_max = right_min
7907  right_min = right_tmp
7908  end if
7909 
7910  write(unit=pos_array(1), fmt="(i20)") pos(1)
7911 
7912  write(unit=pos_array(2), fmt="(i20)") pos(2)
7913 
7914  write(unit=pos_array(3), fmt="(i20)") pos(3)
7915 
7916 
7917  pos_str = '(' // &
7918  & trim(adjustl(pos_array(1))) // ',' // &
7919 
7920  & trim(adjustl(pos_array(2))) // ',' // &
7921 
7922  & trim(adjustl(pos_array(3))) // ')'
7923 
7924  end if
7925  deallocate(mask_array, judge, judge_rev)
7926  deallocate(answer_negative, check_negative, both_negative)
7927  deallocate(answer_max, answer_min)
7928 
7929 
7930 
7931  if (err_flag) then
7932  pos_str_space = ''
7933  pos_str_len = len_trim(pos_str)
7934 
7935  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7936  write(*,*) ''
7937  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
7938  write(*,*) ' is NOT EQUAL to'
7939  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
7940  & // ' ', right_min, ' < '
7941  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
7942 
7943  call abort()
7944  else
7945  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
7946  end if
7947 
7948 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequaldouble4digits()

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

Definition at line 7954 of file dc_test.f90.

References dc_types::string, and dc_types::token.

7954  use dc_types, only: string, token
7955  implicit none
7956  character(*), intent(in):: message
7957  real(DP), intent(in):: answer(:,:,:,:)
7958  real(DP), intent(in):: check(:,:,:,:)
7959  integer, intent(in):: significant_digits
7960  integer, intent(in):: ignore_digits
7961  logical:: err_flag
7962  character(STRING):: pos_str
7963  real(DP):: wrong, right_max, right_min
7964  character(STRING):: pos_str_space
7965  integer:: pos_str_len
7966  real(DP):: right_tmp
7967 
7968  integer:: answer_shape(4), check_shape(4), pos(4)
7969  logical:: consist_shape(4)
7970  character(TOKEN):: pos_array(4)
7971  integer, allocatable:: mask_array(:,:,:,:)
7972  logical, allocatable:: judge(:,:,:,:)
7973  logical, allocatable:: judge_rev(:,:,:,:)
7974  logical, allocatable:: answer_negative(:,:,:,:)
7975  logical, allocatable:: check_negative(:,:,:,:)
7976  logical, allocatable:: both_negative(:,:,:,:)
7977  real(DP), allocatable:: answer_max(:,:,:,:)
7978  real(DP), allocatable:: answer_min(:,:,:,:)
7979 
7980  continue
7981  err_flag = .false.
7982 
7983  if ( significant_digits < 1 ) then
7984  write(*,*) ' *** Error [AssertEQ] *** '
7985  write(*,*) ' Specify a number more than 1 to "significant_digits"'
7986  call abort()
7987  end if
7988 
7989  answer_shape = shape(answer)
7990  check_shape = shape(check)
7991 
7992  consist_shape = answer_shape == check_shape
7993 
7994  if (.not. all(consist_shape)) then
7995  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
7996  write(*,*) ''
7997  write(*,*) ' shape of check is (', check_shape, ')'
7998  write(*,*) ' is INCORRECT'
7999  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
8000 
8001  call abort()
8002  end if
8003 
8004 
8005  allocate( mask_array( &
8006  & answer_shape(1), &
8007 
8008  & answer_shape(2), &
8009 
8010  & answer_shape(3), &
8011 
8012  & answer_shape(4) ) &
8013  & )
8014 
8015  allocate( judge( &
8016  & answer_shape(1), &
8017 
8018  & answer_shape(2), &
8019 
8020  & answer_shape(3), &
8021 
8022  & answer_shape(4) ) &
8023  & )
8024 
8025  allocate( judge_rev( &
8026  & answer_shape(1), &
8027 
8028  & answer_shape(2), &
8029 
8030  & answer_shape(3), &
8031 
8032  & answer_shape(4) ) &
8033  & )
8034 
8035  allocate( answer_negative( &
8036  & answer_shape(1), &
8037 
8038  & answer_shape(2), &
8039 
8040  & answer_shape(3), &
8041 
8042  & answer_shape(4) ) &
8043  & )
8044 
8045  allocate( check_negative( &
8046  & answer_shape(1), &
8047 
8048  & answer_shape(2), &
8049 
8050  & answer_shape(3), &
8051 
8052  & answer_shape(4) ) &
8053  & )
8054 
8055  allocate( both_negative( &
8056  & answer_shape(1), &
8057 
8058  & answer_shape(2), &
8059 
8060  & answer_shape(3), &
8061 
8062  & answer_shape(4) ) &
8063  & )
8064 
8065  allocate( answer_max( &
8066  & answer_shape(1), &
8067 
8068  & answer_shape(2), &
8069 
8070  & answer_shape(3), &
8071 
8072  & answer_shape(4) ) &
8073  & )
8074 
8075  allocate( answer_min( &
8076  & answer_shape(1), &
8077 
8078  & answer_shape(2), &
8079 
8080  & answer_shape(3), &
8081 
8082  & answer_shape(4) ) &
8083  & )
8084 
8085  answer_negative = answer < 0.0_dp
8086  check_negative = check < 0.0_dp
8087  both_negative = answer_negative .and. check_negative
8088 
8089  where (both_negative)
8090  answer_max = &
8091  & answer &
8092  & * ( 1.0_dp &
8093  & - 0.1_dp ** significant_digits ) &
8094  & + 0.1_dp ** (- ignore_digits)
8095 
8096  answer_min = &
8097  & answer &
8098  & * ( 1.0_dp &
8099  & + 0.1_dp ** significant_digits ) &
8100  & - 0.1_dp ** (- ignore_digits)
8101  elsewhere
8102  answer_max = &
8103  & answer &
8104  & * ( 1.0_dp &
8105  & + 0.1_dp ** significant_digits ) &
8106  & + 0.1_dp ** (- ignore_digits)
8107 
8108  answer_min = &
8109  & answer &
8110  & * ( 1.0_dp &
8111  & - 0.1_dp ** significant_digits ) &
8112  & - 0.1_dp ** (- ignore_digits)
8113  end where
8114 
8115  judge = answer_max > check .and. check > answer_min
8116  judge_rev = .not. judge
8117  err_flag = any(judge_rev)
8118  mask_array = 1
8119  pos = maxloc(mask_array, judge_rev)
8120 
8121  if (err_flag) then
8122 
8123  wrong = check( &
8124  & pos(1), &
8125 
8126  & pos(2), &
8127 
8128  & pos(3), &
8129 
8130  & pos(4) )
8131 
8132  right_max = answer_max( &
8133  & pos(1), &
8134 
8135  & pos(2), &
8136 
8137  & pos(3), &
8138 
8139  & pos(4) )
8140 
8141  right_min = answer_min( &
8142  & pos(1), &
8143 
8144  & pos(2), &
8145 
8146  & pos(3), &
8147 
8148  & pos(4) )
8149 
8150  if ( right_max < right_min ) then
8151  right_tmp = right_max
8152  right_max = right_min
8153  right_min = right_tmp
8154  end if
8155 
8156  write(unit=pos_array(1), fmt="(i20)") pos(1)
8157 
8158  write(unit=pos_array(2), fmt="(i20)") pos(2)
8159 
8160  write(unit=pos_array(3), fmt="(i20)") pos(3)
8161 
8162  write(unit=pos_array(4), fmt="(i20)") pos(4)
8163 
8164 
8165  pos_str = '(' // &
8166  & trim(adjustl(pos_array(1))) // ',' // &
8167 
8168  & trim(adjustl(pos_array(2))) // ',' // &
8169 
8170  & trim(adjustl(pos_array(3))) // ',' // &
8171 
8172  & trim(adjustl(pos_array(4))) // ')'
8173 
8174  end if
8175  deallocate(mask_array, judge, judge_rev)
8176  deallocate(answer_negative, check_negative, both_negative)
8177  deallocate(answer_max, answer_min)
8178 
8179 
8180 
8181  if (err_flag) then
8182  pos_str_space = ''
8183  pos_str_len = len_trim(pos_str)
8184 
8185  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8186  write(*,*) ''
8187  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
8188  write(*,*) ' is NOT EQUAL to'
8189  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
8190  & // ' ', right_min, ' < '
8191  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
8192 
8193  call abort()
8194  else
8195  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
8196  end if
8197 
8198 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequaldouble5digits()

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

Definition at line 8204 of file dc_test.f90.

References dc_types::string, and dc_types::token.

8204  use dc_types, only: string, token
8205  implicit none
8206  character(*), intent(in):: message
8207  real(DP), intent(in):: answer(:,:,:,:,:)
8208  real(DP), intent(in):: check(:,:,:,:,:)
8209  integer, intent(in):: significant_digits
8210  integer, intent(in):: ignore_digits
8211  logical:: err_flag
8212  character(STRING):: pos_str
8213  real(DP):: wrong, right_max, right_min
8214  character(STRING):: pos_str_space
8215  integer:: pos_str_len
8216  real(DP):: right_tmp
8217 
8218  integer:: answer_shape(5), check_shape(5), pos(5)
8219  logical:: consist_shape(5)
8220  character(TOKEN):: pos_array(5)
8221  integer, allocatable:: mask_array(:,:,:,:,:)
8222  logical, allocatable:: judge(:,:,:,:,:)
8223  logical, allocatable:: judge_rev(:,:,:,:,:)
8224  logical, allocatable:: answer_negative(:,:,:,:,:)
8225  logical, allocatable:: check_negative(:,:,:,:,:)
8226  logical, allocatable:: both_negative(:,:,:,:,:)
8227  real(DP), allocatable:: answer_max(:,:,:,:,:)
8228  real(DP), allocatable:: answer_min(:,:,:,:,:)
8229 
8230  continue
8231  err_flag = .false.
8232 
8233  if ( significant_digits < 1 ) then
8234  write(*,*) ' *** Error [AssertEQ] *** '
8235  write(*,*) ' Specify a number more than 1 to "significant_digits"'
8236  call abort()
8237  end if
8238 
8239  answer_shape = shape(answer)
8240  check_shape = shape(check)
8241 
8242  consist_shape = answer_shape == check_shape
8243 
8244  if (.not. all(consist_shape)) then
8245  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8246  write(*,*) ''
8247  write(*,*) ' shape of check is (', check_shape, ')'
8248  write(*,*) ' is INCORRECT'
8249  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
8250 
8251  call abort()
8252  end if
8253 
8254 
8255  allocate( mask_array( &
8256  & answer_shape(1), &
8257 
8258  & answer_shape(2), &
8259 
8260  & answer_shape(3), &
8261 
8262  & answer_shape(4), &
8263 
8264  & answer_shape(5) ) &
8265  & )
8266 
8267  allocate( judge( &
8268  & answer_shape(1), &
8269 
8270  & answer_shape(2), &
8271 
8272  & answer_shape(3), &
8273 
8274  & answer_shape(4), &
8275 
8276  & answer_shape(5) ) &
8277  & )
8278 
8279  allocate( judge_rev( &
8280  & answer_shape(1), &
8281 
8282  & answer_shape(2), &
8283 
8284  & answer_shape(3), &
8285 
8286  & answer_shape(4), &
8287 
8288  & answer_shape(5) ) &
8289  & )
8290 
8291  allocate( answer_negative( &
8292  & answer_shape(1), &
8293 
8294  & answer_shape(2), &
8295 
8296  & answer_shape(3), &
8297 
8298  & answer_shape(4), &
8299 
8300  & answer_shape(5) ) &
8301  & )
8302 
8303  allocate( check_negative( &
8304  & answer_shape(1), &
8305 
8306  & answer_shape(2), &
8307 
8308  & answer_shape(3), &
8309 
8310  & answer_shape(4), &
8311 
8312  & answer_shape(5) ) &
8313  & )
8314 
8315  allocate( both_negative( &
8316  & answer_shape(1), &
8317 
8318  & answer_shape(2), &
8319 
8320  & answer_shape(3), &
8321 
8322  & answer_shape(4), &
8323 
8324  & answer_shape(5) ) &
8325  & )
8326 
8327  allocate( answer_max( &
8328  & answer_shape(1), &
8329 
8330  & answer_shape(2), &
8331 
8332  & answer_shape(3), &
8333 
8334  & answer_shape(4), &
8335 
8336  & answer_shape(5) ) &
8337  & )
8338 
8339  allocate( answer_min( &
8340  & answer_shape(1), &
8341 
8342  & answer_shape(2), &
8343 
8344  & answer_shape(3), &
8345 
8346  & answer_shape(4), &
8347 
8348  & answer_shape(5) ) &
8349  & )
8350 
8351  answer_negative = answer < 0.0_dp
8352  check_negative = check < 0.0_dp
8353  both_negative = answer_negative .and. check_negative
8354 
8355  where (both_negative)
8356  answer_max = &
8357  & answer &
8358  & * ( 1.0_dp &
8359  & - 0.1_dp ** significant_digits ) &
8360  & + 0.1_dp ** (- ignore_digits)
8361 
8362  answer_min = &
8363  & answer &
8364  & * ( 1.0_dp &
8365  & + 0.1_dp ** significant_digits ) &
8366  & - 0.1_dp ** (- ignore_digits)
8367  elsewhere
8368  answer_max = &
8369  & answer &
8370  & * ( 1.0_dp &
8371  & + 0.1_dp ** significant_digits ) &
8372  & + 0.1_dp ** (- ignore_digits)
8373 
8374  answer_min = &
8375  & answer &
8376  & * ( 1.0_dp &
8377  & - 0.1_dp ** significant_digits ) &
8378  & - 0.1_dp ** (- ignore_digits)
8379  end where
8380 
8381  judge = answer_max > check .and. check > answer_min
8382  judge_rev = .not. judge
8383  err_flag = any(judge_rev)
8384  mask_array = 1
8385  pos = maxloc(mask_array, judge_rev)
8386 
8387  if (err_flag) then
8388 
8389  wrong = check( &
8390  & pos(1), &
8391 
8392  & pos(2), &
8393 
8394  & pos(3), &
8395 
8396  & pos(4), &
8397 
8398  & pos(5) )
8399 
8400  right_max = answer_max( &
8401  & pos(1), &
8402 
8403  & pos(2), &
8404 
8405  & pos(3), &
8406 
8407  & pos(4), &
8408 
8409  & pos(5) )
8410 
8411  right_min = answer_min( &
8412  & pos(1), &
8413 
8414  & pos(2), &
8415 
8416  & pos(3), &
8417 
8418  & pos(4), &
8419 
8420  & pos(5) )
8421 
8422  if ( right_max < right_min ) then
8423  right_tmp = right_max
8424  right_max = right_min
8425  right_min = right_tmp
8426  end if
8427 
8428  write(unit=pos_array(1), fmt="(i20)") pos(1)
8429 
8430  write(unit=pos_array(2), fmt="(i20)") pos(2)
8431 
8432  write(unit=pos_array(3), fmt="(i20)") pos(3)
8433 
8434  write(unit=pos_array(4), fmt="(i20)") pos(4)
8435 
8436  write(unit=pos_array(5), fmt="(i20)") pos(5)
8437 
8438 
8439  pos_str = '(' // &
8440  & trim(adjustl(pos_array(1))) // ',' // &
8441 
8442  & trim(adjustl(pos_array(2))) // ',' // &
8443 
8444  & trim(adjustl(pos_array(3))) // ',' // &
8445 
8446  & trim(adjustl(pos_array(4))) // ',' // &
8447 
8448  & trim(adjustl(pos_array(5))) // ')'
8449 
8450  end if
8451  deallocate(mask_array, judge, judge_rev)
8452  deallocate(answer_negative, check_negative, both_negative)
8453  deallocate(answer_max, answer_min)
8454 
8455 
8456 
8457  if (err_flag) then
8458  pos_str_space = ''
8459  pos_str_len = len_trim(pos_str)
8460 
8461  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8462  write(*,*) ''
8463  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
8464  write(*,*) ' is NOT EQUAL to'
8465  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
8466  & // ' ', right_min, ' < '
8467  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
8468 
8469  call abort()
8470  else
8471  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
8472  end if
8473 
8474 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequaldouble6digits()

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

Definition at line 8480 of file dc_test.f90.

References dc_types::string, and dc_types::token.

8480  use dc_types, only: string, token
8481  implicit none
8482  character(*), intent(in):: message
8483  real(DP), intent(in):: answer(:,:,:,:,:,:)
8484  real(DP), intent(in):: check(:,:,:,:,:,:)
8485  integer, intent(in):: significant_digits
8486  integer, intent(in):: ignore_digits
8487  logical:: err_flag
8488  character(STRING):: pos_str
8489  real(DP):: wrong, right_max, right_min
8490  character(STRING):: pos_str_space
8491  integer:: pos_str_len
8492  real(DP):: right_tmp
8493 
8494  integer:: answer_shape(6), check_shape(6), pos(6)
8495  logical:: consist_shape(6)
8496  character(TOKEN):: pos_array(6)
8497  integer, allocatable:: mask_array(:,:,:,:,:,:)
8498  logical, allocatable:: judge(:,:,:,:,:,:)
8499  logical, allocatable:: judge_rev(:,:,:,:,:,:)
8500  logical, allocatable:: answer_negative(:,:,:,:,:,:)
8501  logical, allocatable:: check_negative(:,:,:,:,:,:)
8502  logical, allocatable:: both_negative(:,:,:,:,:,:)
8503  real(DP), allocatable:: answer_max(:,:,:,:,:,:)
8504  real(DP), allocatable:: answer_min(:,:,:,:,:,:)
8505 
8506  continue
8507  err_flag = .false.
8508 
8509  if ( significant_digits < 1 ) then
8510  write(*,*) ' *** Error [AssertEQ] *** '
8511  write(*,*) ' Specify a number more than 1 to "significant_digits"'
8512  call abort()
8513  end if
8514 
8515  answer_shape = shape(answer)
8516  check_shape = shape(check)
8517 
8518  consist_shape = answer_shape == check_shape
8519 
8520  if (.not. all(consist_shape)) then
8521  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8522  write(*,*) ''
8523  write(*,*) ' shape of check is (', check_shape, ')'
8524  write(*,*) ' is INCORRECT'
8525  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
8526 
8527  call abort()
8528  end if
8529 
8530 
8531  allocate( mask_array( &
8532  & answer_shape(1), &
8533 
8534  & answer_shape(2), &
8535 
8536  & answer_shape(3), &
8537 
8538  & answer_shape(4), &
8539 
8540  & answer_shape(5), &
8541 
8542  & answer_shape(6) ) &
8543  & )
8544 
8545  allocate( judge( &
8546  & answer_shape(1), &
8547 
8548  & answer_shape(2), &
8549 
8550  & answer_shape(3), &
8551 
8552  & answer_shape(4), &
8553 
8554  & answer_shape(5), &
8555 
8556  & answer_shape(6) ) &
8557  & )
8558 
8559  allocate( judge_rev( &
8560  & answer_shape(1), &
8561 
8562  & answer_shape(2), &
8563 
8564  & answer_shape(3), &
8565 
8566  & answer_shape(4), &
8567 
8568  & answer_shape(5), &
8569 
8570  & answer_shape(6) ) &
8571  & )
8572 
8573  allocate( answer_negative( &
8574  & answer_shape(1), &
8575 
8576  & answer_shape(2), &
8577 
8578  & answer_shape(3), &
8579 
8580  & answer_shape(4), &
8581 
8582  & answer_shape(5), &
8583 
8584  & answer_shape(6) ) &
8585  & )
8586 
8587  allocate( check_negative( &
8588  & answer_shape(1), &
8589 
8590  & answer_shape(2), &
8591 
8592  & answer_shape(3), &
8593 
8594  & answer_shape(4), &
8595 
8596  & answer_shape(5), &
8597 
8598  & answer_shape(6) ) &
8599  & )
8600 
8601  allocate( both_negative( &
8602  & answer_shape(1), &
8603 
8604  & answer_shape(2), &
8605 
8606  & answer_shape(3), &
8607 
8608  & answer_shape(4), &
8609 
8610  & answer_shape(5), &
8611 
8612  & answer_shape(6) ) &
8613  & )
8614 
8615  allocate( answer_max( &
8616  & answer_shape(1), &
8617 
8618  & answer_shape(2), &
8619 
8620  & answer_shape(3), &
8621 
8622  & answer_shape(4), &
8623 
8624  & answer_shape(5), &
8625 
8626  & answer_shape(6) ) &
8627  & )
8628 
8629  allocate( answer_min( &
8630  & answer_shape(1), &
8631 
8632  & answer_shape(2), &
8633 
8634  & answer_shape(3), &
8635 
8636  & answer_shape(4), &
8637 
8638  & answer_shape(5), &
8639 
8640  & answer_shape(6) ) &
8641  & )
8642 
8643  answer_negative = answer < 0.0_dp
8644  check_negative = check < 0.0_dp
8645  both_negative = answer_negative .and. check_negative
8646 
8647  where (both_negative)
8648  answer_max = &
8649  & answer &
8650  & * ( 1.0_dp &
8651  & - 0.1_dp ** significant_digits ) &
8652  & + 0.1_dp ** (- ignore_digits)
8653 
8654  answer_min = &
8655  & answer &
8656  & * ( 1.0_dp &
8657  & + 0.1_dp ** significant_digits ) &
8658  & - 0.1_dp ** (- ignore_digits)
8659  elsewhere
8660  answer_max = &
8661  & answer &
8662  & * ( 1.0_dp &
8663  & + 0.1_dp ** significant_digits ) &
8664  & + 0.1_dp ** (- ignore_digits)
8665 
8666  answer_min = &
8667  & answer &
8668  & * ( 1.0_dp &
8669  & - 0.1_dp ** significant_digits ) &
8670  & - 0.1_dp ** (- ignore_digits)
8671  end where
8672 
8673  judge = answer_max > check .and. check > answer_min
8674  judge_rev = .not. judge
8675  err_flag = any(judge_rev)
8676  mask_array = 1
8677  pos = maxloc(mask_array, judge_rev)
8678 
8679  if (err_flag) then
8680 
8681  wrong = check( &
8682  & pos(1), &
8683 
8684  & pos(2), &
8685 
8686  & pos(3), &
8687 
8688  & pos(4), &
8689 
8690  & pos(5), &
8691 
8692  & pos(6) )
8693 
8694  right_max = answer_max( &
8695  & pos(1), &
8696 
8697  & pos(2), &
8698 
8699  & pos(3), &
8700 
8701  & pos(4), &
8702 
8703  & pos(5), &
8704 
8705  & pos(6) )
8706 
8707  right_min = answer_min( &
8708  & pos(1), &
8709 
8710  & pos(2), &
8711 
8712  & pos(3), &
8713 
8714  & pos(4), &
8715 
8716  & pos(5), &
8717 
8718  & pos(6) )
8719 
8720  if ( right_max < right_min ) then
8721  right_tmp = right_max
8722  right_max = right_min
8723  right_min = right_tmp
8724  end if
8725 
8726  write(unit=pos_array(1), fmt="(i20)") pos(1)
8727 
8728  write(unit=pos_array(2), fmt="(i20)") pos(2)
8729 
8730  write(unit=pos_array(3), fmt="(i20)") pos(3)
8731 
8732  write(unit=pos_array(4), fmt="(i20)") pos(4)
8733 
8734  write(unit=pos_array(5), fmt="(i20)") pos(5)
8735 
8736  write(unit=pos_array(6), fmt="(i20)") pos(6)
8737 
8738 
8739  pos_str = '(' // &
8740  & trim(adjustl(pos_array(1))) // ',' // &
8741 
8742  & trim(adjustl(pos_array(2))) // ',' // &
8743 
8744  & trim(adjustl(pos_array(3))) // ',' // &
8745 
8746  & trim(adjustl(pos_array(4))) // ',' // &
8747 
8748  & trim(adjustl(pos_array(5))) // ',' // &
8749 
8750  & trim(adjustl(pos_array(6))) // ')'
8751 
8752  end if
8753  deallocate(mask_array, judge, judge_rev)
8754  deallocate(answer_negative, check_negative, both_negative)
8755  deallocate(answer_max, answer_min)
8756 
8757 
8758 
8759  if (err_flag) then
8760  pos_str_space = ''
8761  pos_str_len = len_trim(pos_str)
8762 
8763  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8764  write(*,*) ''
8765  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
8766  write(*,*) ' is NOT EQUAL to'
8767  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
8768  & // ' ', right_min, ' < '
8769  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
8770 
8771  call abort()
8772  else
8773  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
8774  end if
8775 
8776 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertequaldouble7digits()

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

Definition at line 8782 of file dc_test.f90.

References dc_types::string, and dc_types::token.

8782  use dc_types, only: string, token
8783  implicit none
8784  character(*), intent(in):: message
8785  real(DP), intent(in):: answer(:,:,:,:,:,:,:)
8786  real(DP), intent(in):: check(:,:,:,:,:,:,:)
8787  integer, intent(in):: significant_digits
8788  integer, intent(in):: ignore_digits
8789  logical:: err_flag
8790  character(STRING):: pos_str
8791  real(DP):: wrong, right_max, right_min
8792  character(STRING):: pos_str_space
8793  integer:: pos_str_len
8794  real(DP):: right_tmp
8795 
8796  integer:: answer_shape(7), check_shape(7), pos(7)
8797  logical:: consist_shape(7)
8798  character(TOKEN):: pos_array(7)
8799  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
8800  logical, allocatable:: judge(:,:,:,:,:,:,:)
8801  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
8802  logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
8803  logical, allocatable:: check_negative(:,:,:,:,:,:,:)
8804  logical, allocatable:: both_negative(:,:,:,:,:,:,:)
8805  real(DP), allocatable:: answer_max(:,:,:,:,:,:,:)
8806  real(DP), allocatable:: answer_min(:,:,:,:,:,:,:)
8807 
8808  continue
8809  err_flag = .false.
8810 
8811  if ( significant_digits < 1 ) then
8812  write(*,*) ' *** Error [AssertEQ] *** '
8813  write(*,*) ' Specify a number more than 1 to "significant_digits"'
8814  call abort()
8815  end if
8816 
8817  answer_shape = shape(answer)
8818  check_shape = shape(check)
8819 
8820  consist_shape = answer_shape == check_shape
8821 
8822  if (.not. all(consist_shape)) then
8823  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
8824  write(*,*) ''
8825  write(*,*) ' shape of check is (', check_shape, ')'
8826  write(*,*) ' is INCORRECT'
8827  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
8828 
8829  call abort()
8830  end if
8831 
8832 
8833  allocate( mask_array( &
8834  & answer_shape(1), &
8835 
8836  & answer_shape(2), &
8837 
8838  & answer_shape(3), &
8839 
8840  & answer_shape(4), &
8841 
8842  & answer_shape(5), &
8843 
8844  & answer_shape(6), &
8845 
8846  & answer_shape(7) ) &
8847  & )
8848 
8849  allocate( judge( &
8850  & answer_shape(1), &
8851 
8852  & answer_shape(2), &
8853 
8854  & answer_shape(3), &
8855 
8856  & answer_shape(4), &
8857 
8858  & answer_shape(5), &
8859 
8860  & answer_shape(6), &
8861 
8862  & answer_shape(7) ) &
8863  & )
8864 
8865  allocate( judge_rev( &
8866  & answer_shape(1), &
8867 
8868  & answer_shape(2), &
8869 
8870  & answer_shape(3), &
8871 
8872  & answer_shape(4), &
8873 
8874  & answer_shape(5), &
8875 
8876  & answer_shape(6), &
8877 
8878  & answer_shape(7) ) &
8879  & )
8880 
8881  allocate( answer_negative( &
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( check_negative( &
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( both_negative( &
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_max( &
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( answer_min( &
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  answer_negative = answer < 0.0_dp
8962  check_negative = check < 0.0_dp
8963  both_negative = answer_negative .and. check_negative
8964 
8965  where (both_negative)
8966  answer_max = &
8967  & answer &
8968  & * ( 1.0_dp &
8969  & - 0.1_dp ** significant_digits ) &
8970  & + 0.1_dp ** (- ignore_digits)
8971 
8972  answer_min = &
8973  & answer &
8974  & * ( 1.0_dp &
8975  & + 0.1_dp ** significant_digits ) &
8976  & - 0.1_dp ** (- ignore_digits)
8977  elsewhere
8978  answer_max = &
8979  & answer &
8980  & * ( 1.0_dp &
8981  & + 0.1_dp ** significant_digits ) &
8982  & + 0.1_dp ** (- ignore_digits)
8983 
8984  answer_min = &
8985  & answer &
8986  & * ( 1.0_dp &
8987  & - 0.1_dp ** significant_digits ) &
8988  & - 0.1_dp ** (- ignore_digits)
8989  end where
8990 
8991  judge = answer_max > check .and. check > answer_min
8992  judge_rev = .not. judge
8993  err_flag = any(judge_rev)
8994  mask_array = 1
8995  pos = maxloc(mask_array, judge_rev)
8996 
8997  if (err_flag) then
8998 
8999  wrong = check( &
9000  & pos(1), &
9001 
9002  & pos(2), &
9003 
9004  & pos(3), &
9005 
9006  & pos(4), &
9007 
9008  & pos(5), &
9009 
9010  & pos(6), &
9011 
9012  & pos(7) )
9013 
9014  right_max = answer_max( &
9015  & pos(1), &
9016 
9017  & pos(2), &
9018 
9019  & pos(3), &
9020 
9021  & pos(4), &
9022 
9023  & pos(5), &
9024 
9025  & pos(6), &
9026 
9027  & pos(7) )
9028 
9029  right_min = answer_min( &
9030  & pos(1), &
9031 
9032  & pos(2), &
9033 
9034  & pos(3), &
9035 
9036  & pos(4), &
9037 
9038  & pos(5), &
9039 
9040  & pos(6), &
9041 
9042  & pos(7) )
9043 
9044  if ( right_max < right_min ) then
9045  right_tmp = right_max
9046  right_max = right_min
9047  right_min = right_tmp
9048  end if
9049 
9050  write(unit=pos_array(1), fmt="(i20)") pos(1)
9051 
9052  write(unit=pos_array(2), fmt="(i20)") pos(2)
9053 
9054  write(unit=pos_array(3), fmt="(i20)") pos(3)
9055 
9056  write(unit=pos_array(4), fmt="(i20)") pos(4)
9057 
9058  write(unit=pos_array(5), fmt="(i20)") pos(5)
9059 
9060  write(unit=pos_array(6), fmt="(i20)") pos(6)
9061 
9062  write(unit=pos_array(7), fmt="(i20)") pos(7)
9063 
9064 
9065  pos_str = '(' // &
9066  & trim(adjustl(pos_array(1))) // ',' // &
9067 
9068  & trim(adjustl(pos_array(2))) // ',' // &
9069 
9070  & trim(adjustl(pos_array(3))) // ',' // &
9071 
9072  & trim(adjustl(pos_array(4))) // ',' // &
9073 
9074  & trim(adjustl(pos_array(5))) // ',' // &
9075 
9076  & trim(adjustl(pos_array(6))) // ',' // &
9077 
9078  & trim(adjustl(pos_array(7))) // ')'
9079 
9080  end if
9081  deallocate(mask_array, judge, judge_rev)
9082  deallocate(answer_negative, check_negative, both_negative)
9083  deallocate(answer_max, answer_min)
9084 
9085 
9086 
9087  if (err_flag) then
9088  pos_str_space = ''
9089  pos_str_len = len_trim(pos_str)
9090 
9091  write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
9092  write(*,*) ''
9093  write(*,*) ' check' // trim(pos_str) // ' = ', wrong
9094  write(*,*) ' is NOT EQUAL to'
9095  write(*,*) ' ' // pos_str_space(1:pos_str_len) &
9096  & // ' ', right_min, ' < '
9097  write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
9098 
9099  call abort()
9100  else
9101  write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
9102  end if
9103 
9104 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthanint0()

subroutine dc_test::dctestassertgreaterthanint0 ( character(*), intent(in)  message,
integer, intent(in)  answer,
integer, intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 9110 of file dc_test.f90.

References dc_types::string, and dc_types::token.

9110  use dc_types, only: string, token
9111  implicit none
9112  character(*), intent(in):: message
9113  integer, intent(in):: answer
9114  integer, intent(in):: check
9115  logical, intent(in), optional:: negative_support
9116  logical:: err_flag
9117  logical:: negative_support_on
9118  character(STRING):: pos_str
9119  character(TOKEN):: abs_mes
9120  integer:: wrong, right
9121 
9122 
9123 
9124  continue
9125  if (present(negative_support)) then
9126  negative_support_on = negative_support
9127  else
9128  negative_support_on = .true.
9129  end if
9130 
9131  err_flag = .false.
9132 
9133 
9134  err_flag = .not. answer < check
9135  abs_mes = ''
9136 
9137  if ( answer < 0 &
9138  & .and. check < 0 &
9139  & .and. negative_support_on ) then
9140 
9141  err_flag = .not. err_flag
9142  abs_mes = 'ABSOLUTE value of'
9143  end if
9144 
9145  wrong = check
9146  right = answer
9147  pos_str = ''
9148 
9149 
9150 
9151 
9152  if (err_flag) then
9153  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9154  write(*,*) ''
9155  write(*,*) ' ' // trim(abs_mes) // &
9156  & ' check' // trim(pos_str) // ' = ', wrong
9157  write(*,*) ' is NOT GREATER THAN'
9158  write(*,*) ' ' // trim(abs_mes) // &
9159  & ' answer' // trim(pos_str) // ' = ', right
9160 
9161  call abort()
9162  else
9163  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
9164  end if
9165 
9166 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthanint1()

subroutine dc_test::dctestassertgreaterthanint1 ( character(*), intent(in)  message,
integer, dimension(:), intent(in)  answer,
integer, dimension(:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 9172 of file dc_test.f90.

References dc_types::string, and dc_types::token.

9172  use dc_types, only: string, token
9173  implicit none
9174  character(*), intent(in):: message
9175  integer, intent(in):: answer(:)
9176  integer, intent(in):: check(:)
9177  logical, intent(in), optional:: negative_support
9178  logical:: err_flag
9179  logical:: negative_support_on
9180  character(STRING):: pos_str
9181  character(TOKEN):: abs_mes
9182  integer:: wrong, right
9183 
9184  integer:: answer_shape(1), check_shape(1), pos(1)
9185  logical:: consist_shape(1)
9186  character(TOKEN):: pos_array(1)
9187  integer, allocatable:: mask_array(:)
9188  logical, allocatable:: judge(:)
9189  logical, allocatable:: judge_rev(:)
9190  logical, allocatable:: answer_negative(:)
9191  logical, allocatable:: check_negative(:)
9192  logical, allocatable:: both_negative(:)
9193 
9194 
9195  continue
9196  if (present(negative_support)) then
9197  negative_support_on = negative_support
9198  else
9199  negative_support_on = .true.
9200  end if
9201 
9202  err_flag = .false.
9203 
9204 
9205  answer_shape = shape(answer)
9206  check_shape = shape(check)
9207 
9208  consist_shape = answer_shape == check_shape
9209 
9210  if (.not. all(consist_shape)) then
9211  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9212  write(*,*) ''
9213  write(*,*) ' shape of check is (', check_shape, ')'
9214  write(*,*) ' is INCORRECT'
9215  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
9216 
9217  call abort()
9218  end if
9219 
9220 
9221  allocate( mask_array( &
9222 
9223  & answer_shape(1) ) &
9224  & )
9225 
9226  allocate( judge( &
9227 
9228  & answer_shape(1) ) &
9229  & )
9230 
9231  allocate( judge_rev( &
9232 
9233  & answer_shape(1) ) &
9234  & )
9235 
9236  allocate( answer_negative( &
9237 
9238  & answer_shape(1) ) &
9239  & )
9240 
9241  allocate( check_negative( &
9242 
9243  & answer_shape(1) ) &
9244  & )
9245 
9246  allocate( both_negative( &
9247 
9248  & answer_shape(1) ) &
9249  & )
9250 
9251  answer_negative = answer < 0
9252  check_negative = check < 0
9253  both_negative = answer_negative .and. check_negative
9254  if (.not. negative_support_on) both_negative = .false.
9255 
9256  judge = answer < check
9257  where (both_negative) judge = .not. judge
9258 
9259  judge_rev = .not. judge
9260  err_flag = any(judge_rev)
9261  mask_array = 1
9262  pos = maxloc(mask_array, judge_rev)
9263 
9264  if (err_flag) then
9265 
9266  wrong = check( &
9267 
9268  & pos(1) )
9269 
9270  right = answer( &
9271 
9272  & pos(1) )
9273 
9274  write(unit=pos_array(1), fmt="(i20)") pos(1)
9275 
9276 
9277  pos_str = '(' // &
9278 
9279  & trim(adjustl(pos_array(1))) // ')'
9280 
9281  if ( both_negative( &
9282 
9283  & pos(1) ) ) then
9284 
9285  abs_mes = 'ABSOLUTE value of'
9286  else
9287  abs_mes = ''
9288 
9289  end if
9290 
9291  end if
9292  deallocate(mask_array, judge, judge_rev)
9293  deallocate(answer_negative, check_negative, both_negative)
9294 
9295 
9296 
9297 
9298  if (err_flag) then
9299  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9300  write(*,*) ''
9301  write(*,*) ' ' // trim(abs_mes) // &
9302  & ' check' // trim(pos_str) // ' = ', wrong
9303  write(*,*) ' is NOT GREATER THAN'
9304  write(*,*) ' ' // trim(abs_mes) // &
9305  & ' answer' // trim(pos_str) // ' = ', right
9306 
9307  call abort()
9308  else
9309  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
9310  end if
9311 
9312 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthanint2()

subroutine dc_test::dctestassertgreaterthanint2 ( character(*), intent(in)  message,
integer, dimension(:,:), intent(in)  answer,
integer, dimension(:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 9318 of file dc_test.f90.

References dc_types::string, and dc_types::token.

9318  use dc_types, only: string, token
9319  implicit none
9320  character(*), intent(in):: message
9321  integer, intent(in):: answer(:,:)
9322  integer, intent(in):: check(:,:)
9323  logical, intent(in), optional:: negative_support
9324  logical:: err_flag
9325  logical:: negative_support_on
9326  character(STRING):: pos_str
9327  character(TOKEN):: abs_mes
9328  integer:: wrong, right
9329 
9330  integer:: answer_shape(2), check_shape(2), pos(2)
9331  logical:: consist_shape(2)
9332  character(TOKEN):: pos_array(2)
9333  integer, allocatable:: mask_array(:,:)
9334  logical, allocatable:: judge(:,:)
9335  logical, allocatable:: judge_rev(:,:)
9336  logical, allocatable:: answer_negative(:,:)
9337  logical, allocatable:: check_negative(:,:)
9338  logical, allocatable:: both_negative(:,:)
9339 
9340 
9341  continue
9342  if (present(negative_support)) then
9343  negative_support_on = negative_support
9344  else
9345  negative_support_on = .true.
9346  end if
9347 
9348  err_flag = .false.
9349 
9350 
9351  answer_shape = shape(answer)
9352  check_shape = shape(check)
9353 
9354  consist_shape = answer_shape == check_shape
9355 
9356  if (.not. all(consist_shape)) then
9357  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9358  write(*,*) ''
9359  write(*,*) ' shape of check is (', check_shape, ')'
9360  write(*,*) ' is INCORRECT'
9361  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
9362 
9363  call abort()
9364  end if
9365 
9366 
9367  allocate( mask_array( &
9368  & answer_shape(1), &
9369 
9370  & answer_shape(2) ) &
9371  & )
9372 
9373  allocate( judge( &
9374  & answer_shape(1), &
9375 
9376  & answer_shape(2) ) &
9377  & )
9378 
9379  allocate( judge_rev( &
9380  & answer_shape(1), &
9381 
9382  & answer_shape(2) ) &
9383  & )
9384 
9385  allocate( answer_negative( &
9386  & answer_shape(1), &
9387 
9388  & answer_shape(2) ) &
9389  & )
9390 
9391  allocate( check_negative( &
9392  & answer_shape(1), &
9393 
9394  & answer_shape(2) ) &
9395  & )
9396 
9397  allocate( both_negative( &
9398  & answer_shape(1), &
9399 
9400  & answer_shape(2) ) &
9401  & )
9402 
9403  answer_negative = answer < 0
9404  check_negative = check < 0
9405  both_negative = answer_negative .and. check_negative
9406  if (.not. negative_support_on) both_negative = .false.
9407 
9408  judge = answer < check
9409  where (both_negative) judge = .not. judge
9410 
9411  judge_rev = .not. judge
9412  err_flag = any(judge_rev)
9413  mask_array = 1
9414  pos = maxloc(mask_array, judge_rev)
9415 
9416  if (err_flag) then
9417 
9418  wrong = check( &
9419  & pos(1), &
9420 
9421  & pos(2) )
9422 
9423  right = answer( &
9424  & pos(1), &
9425 
9426  & pos(2) )
9427 
9428  write(unit=pos_array(1), fmt="(i20)") pos(1)
9429 
9430  write(unit=pos_array(2), fmt="(i20)") pos(2)
9431 
9432 
9433  pos_str = '(' // &
9434  & trim(adjustl(pos_array(1))) // ',' // &
9435 
9436  & trim(adjustl(pos_array(2))) // ')'
9437 
9438  if ( both_negative( &
9439  & pos(1), &
9440 
9441  & pos(2) ) ) then
9442 
9443  abs_mes = 'ABSOLUTE value of'
9444  else
9445  abs_mes = ''
9446 
9447  end if
9448 
9449  end if
9450  deallocate(mask_array, judge, judge_rev)
9451  deallocate(answer_negative, check_negative, both_negative)
9452 
9453 
9454 
9455 
9456  if (err_flag) then
9457  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9458  write(*,*) ''
9459  write(*,*) ' ' // trim(abs_mes) // &
9460  & ' check' // trim(pos_str) // ' = ', wrong
9461  write(*,*) ' is NOT GREATER THAN'
9462  write(*,*) ' ' // trim(abs_mes) // &
9463  & ' answer' // trim(pos_str) // ' = ', right
9464 
9465  call abort()
9466  else
9467  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
9468  end if
9469 
9470 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthanint3()

subroutine dc_test::dctestassertgreaterthanint3 ( character(*), intent(in)  message,
integer, dimension(:,:,:), intent(in)  answer,
integer, dimension(:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 9476 of file dc_test.f90.

References dc_types::string, and dc_types::token.

9476  use dc_types, only: string, token
9477  implicit none
9478  character(*), intent(in):: message
9479  integer, intent(in):: answer(:,:,:)
9480  integer, intent(in):: check(:,:,:)
9481  logical, intent(in), optional:: negative_support
9482  logical:: err_flag
9483  logical:: negative_support_on
9484  character(STRING):: pos_str
9485  character(TOKEN):: abs_mes
9486  integer:: wrong, right
9487 
9488  integer:: answer_shape(3), check_shape(3), pos(3)
9489  logical:: consist_shape(3)
9490  character(TOKEN):: pos_array(3)
9491  integer, allocatable:: mask_array(:,:,:)
9492  logical, allocatable:: judge(:,:,:)
9493  logical, allocatable:: judge_rev(:,:,:)
9494  logical, allocatable:: answer_negative(:,:,:)
9495  logical, allocatable:: check_negative(:,:,:)
9496  logical, allocatable:: both_negative(:,:,:)
9497 
9498 
9499  continue
9500  if (present(negative_support)) then
9501  negative_support_on = negative_support
9502  else
9503  negative_support_on = .true.
9504  end if
9505 
9506  err_flag = .false.
9507 
9508 
9509  answer_shape = shape(answer)
9510  check_shape = shape(check)
9511 
9512  consist_shape = answer_shape == check_shape
9513 
9514  if (.not. all(consist_shape)) then
9515  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9516  write(*,*) ''
9517  write(*,*) ' shape of check is (', check_shape, ')'
9518  write(*,*) ' is INCORRECT'
9519  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
9520 
9521  call abort()
9522  end if
9523 
9524 
9525  allocate( mask_array( &
9526  & answer_shape(1), &
9527 
9528  & answer_shape(2), &
9529 
9530  & answer_shape(3) ) &
9531  & )
9532 
9533  allocate( judge( &
9534  & answer_shape(1), &
9535 
9536  & answer_shape(2), &
9537 
9538  & answer_shape(3) ) &
9539  & )
9540 
9541  allocate( judge_rev( &
9542  & answer_shape(1), &
9543 
9544  & answer_shape(2), &
9545 
9546  & answer_shape(3) ) &
9547  & )
9548 
9549  allocate( answer_negative( &
9550  & answer_shape(1), &
9551 
9552  & answer_shape(2), &
9553 
9554  & answer_shape(3) ) &
9555  & )
9556 
9557  allocate( check_negative( &
9558  & answer_shape(1), &
9559 
9560  & answer_shape(2), &
9561 
9562  & answer_shape(3) ) &
9563  & )
9564 
9565  allocate( both_negative( &
9566  & answer_shape(1), &
9567 
9568  & answer_shape(2), &
9569 
9570  & answer_shape(3) ) &
9571  & )
9572 
9573  answer_negative = answer < 0
9574  check_negative = check < 0
9575  both_negative = answer_negative .and. check_negative
9576  if (.not. negative_support_on) both_negative = .false.
9577 
9578  judge = answer < check
9579  where (both_negative) judge = .not. judge
9580 
9581  judge_rev = .not. judge
9582  err_flag = any(judge_rev)
9583  mask_array = 1
9584  pos = maxloc(mask_array, judge_rev)
9585 
9586  if (err_flag) then
9587 
9588  wrong = check( &
9589  & pos(1), &
9590 
9591  & pos(2), &
9592 
9593  & pos(3) )
9594 
9595  right = answer( &
9596  & pos(1), &
9597 
9598  & pos(2), &
9599 
9600  & pos(3) )
9601 
9602  write(unit=pos_array(1), fmt="(i20)") pos(1)
9603 
9604  write(unit=pos_array(2), fmt="(i20)") pos(2)
9605 
9606  write(unit=pos_array(3), fmt="(i20)") pos(3)
9607 
9608 
9609  pos_str = '(' // &
9610  & trim(adjustl(pos_array(1))) // ',' // &
9611 
9612  & trim(adjustl(pos_array(2))) // ',' // &
9613 
9614  & trim(adjustl(pos_array(3))) // ')'
9615 
9616  if ( both_negative( &
9617  & pos(1), &
9618 
9619  & pos(2), &
9620 
9621  & pos(3) ) ) then
9622 
9623  abs_mes = 'ABSOLUTE value of'
9624  else
9625  abs_mes = ''
9626 
9627  end if
9628 
9629  end if
9630  deallocate(mask_array, judge, judge_rev)
9631  deallocate(answer_negative, check_negative, both_negative)
9632 
9633 
9634 
9635 
9636  if (err_flag) then
9637  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9638  write(*,*) ''
9639  write(*,*) ' ' // trim(abs_mes) // &
9640  & ' check' // trim(pos_str) // ' = ', wrong
9641  write(*,*) ' is NOT GREATER THAN'
9642  write(*,*) ' ' // trim(abs_mes) // &
9643  & ' answer' // trim(pos_str) // ' = ', right
9644 
9645  call abort()
9646  else
9647  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
9648  end if
9649 
9650 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthanint4()

subroutine dc_test::dctestassertgreaterthanint4 ( character(*), intent(in)  message,
integer, dimension(:,:,:,:), intent(in)  answer,
integer, dimension(:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 9656 of file dc_test.f90.

References dc_types::string, and dc_types::token.

9656  use dc_types, only: string, token
9657  implicit none
9658  character(*), intent(in):: message
9659  integer, intent(in):: answer(:,:,:,:)
9660  integer, intent(in):: check(:,:,:,:)
9661  logical, intent(in), optional:: negative_support
9662  logical:: err_flag
9663  logical:: negative_support_on
9664  character(STRING):: pos_str
9665  character(TOKEN):: abs_mes
9666  integer:: wrong, right
9667 
9668  integer:: answer_shape(4), check_shape(4), pos(4)
9669  logical:: consist_shape(4)
9670  character(TOKEN):: pos_array(4)
9671  integer, allocatable:: mask_array(:,:,:,:)
9672  logical, allocatable:: judge(:,:,:,:)
9673  logical, allocatable:: judge_rev(:,:,:,:)
9674  logical, allocatable:: answer_negative(:,:,:,:)
9675  logical, allocatable:: check_negative(:,:,:,:)
9676  logical, allocatable:: both_negative(:,:,:,:)
9677 
9678 
9679  continue
9680  if (present(negative_support)) then
9681  negative_support_on = negative_support
9682  else
9683  negative_support_on = .true.
9684  end if
9685 
9686  err_flag = .false.
9687 
9688 
9689  answer_shape = shape(answer)
9690  check_shape = shape(check)
9691 
9692  consist_shape = answer_shape == check_shape
9693 
9694  if (.not. all(consist_shape)) then
9695  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9696  write(*,*) ''
9697  write(*,*) ' shape of check is (', check_shape, ')'
9698  write(*,*) ' is INCORRECT'
9699  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
9700 
9701  call abort()
9702  end if
9703 
9704 
9705  allocate( mask_array( &
9706  & answer_shape(1), &
9707 
9708  & answer_shape(2), &
9709 
9710  & answer_shape(3), &
9711 
9712  & answer_shape(4) ) &
9713  & )
9714 
9715  allocate( judge( &
9716  & answer_shape(1), &
9717 
9718  & answer_shape(2), &
9719 
9720  & answer_shape(3), &
9721 
9722  & answer_shape(4) ) &
9723  & )
9724 
9725  allocate( judge_rev( &
9726  & answer_shape(1), &
9727 
9728  & answer_shape(2), &
9729 
9730  & answer_shape(3), &
9731 
9732  & answer_shape(4) ) &
9733  & )
9734 
9735  allocate( answer_negative( &
9736  & answer_shape(1), &
9737 
9738  & answer_shape(2), &
9739 
9740  & answer_shape(3), &
9741 
9742  & answer_shape(4) ) &
9743  & )
9744 
9745  allocate( check_negative( &
9746  & answer_shape(1), &
9747 
9748  & answer_shape(2), &
9749 
9750  & answer_shape(3), &
9751 
9752  & answer_shape(4) ) &
9753  & )
9754 
9755  allocate( both_negative( &
9756  & answer_shape(1), &
9757 
9758  & answer_shape(2), &
9759 
9760  & answer_shape(3), &
9761 
9762  & answer_shape(4) ) &
9763  & )
9764 
9765  answer_negative = answer < 0
9766  check_negative = check < 0
9767  both_negative = answer_negative .and. check_negative
9768  if (.not. negative_support_on) both_negative = .false.
9769 
9770  judge = answer < check
9771  where (both_negative) judge = .not. judge
9772 
9773  judge_rev = .not. judge
9774  err_flag = any(judge_rev)
9775  mask_array = 1
9776  pos = maxloc(mask_array, judge_rev)
9777 
9778  if (err_flag) then
9779 
9780  wrong = check( &
9781  & pos(1), &
9782 
9783  & pos(2), &
9784 
9785  & pos(3), &
9786 
9787  & pos(4) )
9788 
9789  right = answer( &
9790  & pos(1), &
9791 
9792  & pos(2), &
9793 
9794  & pos(3), &
9795 
9796  & pos(4) )
9797 
9798  write(unit=pos_array(1), fmt="(i20)") pos(1)
9799 
9800  write(unit=pos_array(2), fmt="(i20)") pos(2)
9801 
9802  write(unit=pos_array(3), fmt="(i20)") pos(3)
9803 
9804  write(unit=pos_array(4), fmt="(i20)") pos(4)
9805 
9806 
9807  pos_str = '(' // &
9808  & trim(adjustl(pos_array(1))) // ',' // &
9809 
9810  & trim(adjustl(pos_array(2))) // ',' // &
9811 
9812  & trim(adjustl(pos_array(3))) // ',' // &
9813 
9814  & trim(adjustl(pos_array(4))) // ')'
9815 
9816  if ( both_negative( &
9817  & pos(1), &
9818 
9819  & pos(2), &
9820 
9821  & pos(3), &
9822 
9823  & pos(4) ) ) then
9824 
9825  abs_mes = 'ABSOLUTE value of'
9826  else
9827  abs_mes = ''
9828 
9829  end if
9830 
9831  end if
9832  deallocate(mask_array, judge, judge_rev)
9833  deallocate(answer_negative, check_negative, both_negative)
9834 
9835 
9836 
9837 
9838  if (err_flag) then
9839  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9840  write(*,*) ''
9841  write(*,*) ' ' // trim(abs_mes) // &
9842  & ' check' // trim(pos_str) // ' = ', wrong
9843  write(*,*) ' is NOT GREATER THAN'
9844  write(*,*) ' ' // trim(abs_mes) // &
9845  & ' answer' // trim(pos_str) // ' = ', right
9846 
9847  call abort()
9848  else
9849  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
9850  end if
9851 
9852 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthanint5()

subroutine dc_test::dctestassertgreaterthanint5 ( character(*), intent(in)  message,
integer, dimension(:,:,:,:,:), intent(in)  answer,
integer, dimension(:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 9858 of file dc_test.f90.

References dc_types::string, and dc_types::token.

9858  use dc_types, only: string, token
9859  implicit none
9860  character(*), intent(in):: message
9861  integer, intent(in):: answer(:,:,:,:,:)
9862  integer, intent(in):: check(:,:,:,:,:)
9863  logical, intent(in), optional:: negative_support
9864  logical:: err_flag
9865  logical:: negative_support_on
9866  character(STRING):: pos_str
9867  character(TOKEN):: abs_mes
9868  integer:: wrong, right
9869 
9870  integer:: answer_shape(5), check_shape(5), pos(5)
9871  logical:: consist_shape(5)
9872  character(TOKEN):: pos_array(5)
9873  integer, allocatable:: mask_array(:,:,:,:,:)
9874  logical, allocatable:: judge(:,:,:,:,:)
9875  logical, allocatable:: judge_rev(:,:,:,:,:)
9876  logical, allocatable:: answer_negative(:,:,:,:,:)
9877  logical, allocatable:: check_negative(:,:,:,:,:)
9878  logical, allocatable:: both_negative(:,:,:,:,:)
9879 
9880 
9881  continue
9882  if (present(negative_support)) then
9883  negative_support_on = negative_support
9884  else
9885  negative_support_on = .true.
9886  end if
9887 
9888  err_flag = .false.
9889 
9890 
9891  answer_shape = shape(answer)
9892  check_shape = shape(check)
9893 
9894  consist_shape = answer_shape == check_shape
9895 
9896  if (.not. all(consist_shape)) then
9897  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
9898  write(*,*) ''
9899  write(*,*) ' shape of check is (', check_shape, ')'
9900  write(*,*) ' is INCORRECT'
9901  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
9902 
9903  call abort()
9904  end if
9905 
9906 
9907  allocate( mask_array( &
9908  & answer_shape(1), &
9909 
9910  & answer_shape(2), &
9911 
9912  & answer_shape(3), &
9913 
9914  & answer_shape(4), &
9915 
9916  & answer_shape(5) ) &
9917  & )
9918 
9919  allocate( judge( &
9920  & answer_shape(1), &
9921 
9922  & answer_shape(2), &
9923 
9924  & answer_shape(3), &
9925 
9926  & answer_shape(4), &
9927 
9928  & answer_shape(5) ) &
9929  & )
9930 
9931  allocate( judge_rev( &
9932  & answer_shape(1), &
9933 
9934  & answer_shape(2), &
9935 
9936  & answer_shape(3), &
9937 
9938  & answer_shape(4), &
9939 
9940  & answer_shape(5) ) &
9941  & )
9942 
9943  allocate( answer_negative( &
9944  & answer_shape(1), &
9945 
9946  & answer_shape(2), &
9947 
9948  & answer_shape(3), &
9949 
9950  & answer_shape(4), &
9951 
9952  & answer_shape(5) ) &
9953  & )
9954 
9955  allocate( check_negative( &
9956  & answer_shape(1), &
9957 
9958  & answer_shape(2), &
9959 
9960  & answer_shape(3), &
9961 
9962  & answer_shape(4), &
9963 
9964  & answer_shape(5) ) &
9965  & )
9966 
9967  allocate( both_negative( &
9968  & answer_shape(1), &
9969 
9970  & answer_shape(2), &
9971 
9972  & answer_shape(3), &
9973 
9974  & answer_shape(4), &
9975 
9976  & answer_shape(5) ) &
9977  & )
9978 
9979  answer_negative = answer < 0
9980  check_negative = check < 0
9981  both_negative = answer_negative .and. check_negative
9982  if (.not. negative_support_on) both_negative = .false.
9983 
9984  judge = answer < check
9985  where (both_negative) judge = .not. judge
9986 
9987  judge_rev = .not. judge
9988  err_flag = any(judge_rev)
9989  mask_array = 1
9990  pos = maxloc(mask_array, judge_rev)
9991 
9992  if (err_flag) then
9993 
9994  wrong = check( &
9995  & pos(1), &
9996 
9997  & pos(2), &
9998 
9999  & pos(3), &
10000 
10001  & pos(4), &
10002 
10003  & pos(5) )
10004 
10005  right = answer( &
10006  & pos(1), &
10007 
10008  & pos(2), &
10009 
10010  & pos(3), &
10011 
10012  & pos(4), &
10013 
10014  & pos(5) )
10015 
10016  write(unit=pos_array(1), fmt="(i20)") pos(1)
10017 
10018  write(unit=pos_array(2), fmt="(i20)") pos(2)
10019 
10020  write(unit=pos_array(3), fmt="(i20)") pos(3)
10021 
10022  write(unit=pos_array(4), fmt="(i20)") pos(4)
10023 
10024  write(unit=pos_array(5), fmt="(i20)") pos(5)
10025 
10026 
10027  pos_str = '(' // &
10028  & trim(adjustl(pos_array(1))) // ',' // &
10029 
10030  & trim(adjustl(pos_array(2))) // ',' // &
10031 
10032  & trim(adjustl(pos_array(3))) // ',' // &
10033 
10034  & trim(adjustl(pos_array(4))) // ',' // &
10035 
10036  & trim(adjustl(pos_array(5))) // ')'
10037 
10038  if ( both_negative( &
10039  & pos(1), &
10040 
10041  & pos(2), &
10042 
10043  & pos(3), &
10044 
10045  & pos(4), &
10046 
10047  & pos(5) ) ) then
10048 
10049  abs_mes = 'ABSOLUTE value of'
10050  else
10051  abs_mes = ''
10052 
10053  end if
10054 
10055  end if
10056  deallocate(mask_array, judge, judge_rev)
10057  deallocate(answer_negative, check_negative, both_negative)
10058 
10059 
10060 
10061 
10062  if (err_flag) then
10063  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10064  write(*,*) ''
10065  write(*,*) ' ' // trim(abs_mes) // &
10066  & ' check' // trim(pos_str) // ' = ', wrong
10067  write(*,*) ' is NOT GREATER THAN'
10068  write(*,*) ' ' // trim(abs_mes) // &
10069  & ' answer' // trim(pos_str) // ' = ', right
10070 
10071  call abort()
10072  else
10073  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
10074  end if
10075 
10076 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthanint6()

subroutine dc_test::dctestassertgreaterthanint6 ( character(*), intent(in)  message,
integer, dimension(:,:,:,:,:,:), intent(in)  answer,
integer, dimension(:,:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 10082 of file dc_test.f90.

References dc_types::string, and dc_types::token.

10082  use dc_types, only: string, token
10083  implicit none
10084  character(*), intent(in):: message
10085  integer, intent(in):: answer(:,:,:,:,:,:)
10086  integer, intent(in):: check(:,:,:,:,:,:)
10087  logical, intent(in), optional:: negative_support
10088  logical:: err_flag
10089  logical:: negative_support_on
10090  character(STRING):: pos_str
10091  character(TOKEN):: abs_mes
10092  integer:: wrong, right
10093 
10094  integer:: answer_shape(6), check_shape(6), pos(6)
10095  logical:: consist_shape(6)
10096  character(TOKEN):: pos_array(6)
10097  integer, allocatable:: mask_array(:,:,:,:,:,:)
10098  logical, allocatable:: judge(:,:,:,:,:,:)
10099  logical, allocatable:: judge_rev(:,:,:,:,:,:)
10100  logical, allocatable:: answer_negative(:,:,:,:,:,:)
10101  logical, allocatable:: check_negative(:,:,:,:,:,:)
10102  logical, allocatable:: both_negative(:,:,:,:,:,:)
10103 
10104 
10105  continue
10106  if (present(negative_support)) then
10107  negative_support_on = negative_support
10108  else
10109  negative_support_on = .true.
10110  end if
10111 
10112  err_flag = .false.
10113 
10114 
10115  answer_shape = shape(answer)
10116  check_shape = shape(check)
10117 
10118  consist_shape = answer_shape == check_shape
10119 
10120  if (.not. all(consist_shape)) then
10121  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10122  write(*,*) ''
10123  write(*,*) ' shape of check is (', check_shape, ')'
10124  write(*,*) ' is INCORRECT'
10125  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
10126 
10127  call abort()
10128  end if
10129 
10130 
10131  allocate( mask_array( &
10132  & answer_shape(1), &
10133 
10134  & answer_shape(2), &
10135 
10136  & answer_shape(3), &
10137 
10138  & answer_shape(4), &
10139 
10140  & answer_shape(5), &
10141 
10142  & answer_shape(6) ) &
10143  & )
10144 
10145  allocate( judge( &
10146  & answer_shape(1), &
10147 
10148  & answer_shape(2), &
10149 
10150  & answer_shape(3), &
10151 
10152  & answer_shape(4), &
10153 
10154  & answer_shape(5), &
10155 
10156  & answer_shape(6) ) &
10157  & )
10158 
10159  allocate( judge_rev( &
10160  & answer_shape(1), &
10161 
10162  & answer_shape(2), &
10163 
10164  & answer_shape(3), &
10165 
10166  & answer_shape(4), &
10167 
10168  & answer_shape(5), &
10169 
10170  & answer_shape(6) ) &
10171  & )
10172 
10173  allocate( answer_negative( &
10174  & answer_shape(1), &
10175 
10176  & answer_shape(2), &
10177 
10178  & answer_shape(3), &
10179 
10180  & answer_shape(4), &
10181 
10182  & answer_shape(5), &
10183 
10184  & answer_shape(6) ) &
10185  & )
10186 
10187  allocate( check_negative( &
10188  & answer_shape(1), &
10189 
10190  & answer_shape(2), &
10191 
10192  & answer_shape(3), &
10193 
10194  & answer_shape(4), &
10195 
10196  & answer_shape(5), &
10197 
10198  & answer_shape(6) ) &
10199  & )
10200 
10201  allocate( both_negative( &
10202  & answer_shape(1), &
10203 
10204  & answer_shape(2), &
10205 
10206  & answer_shape(3), &
10207 
10208  & answer_shape(4), &
10209 
10210  & answer_shape(5), &
10211 
10212  & answer_shape(6) ) &
10213  & )
10214 
10215  answer_negative = answer < 0
10216  check_negative = check < 0
10217  both_negative = answer_negative .and. check_negative
10218  if (.not. negative_support_on) both_negative = .false.
10219 
10220  judge = answer < check
10221  where (both_negative) judge = .not. judge
10222 
10223  judge_rev = .not. judge
10224  err_flag = any(judge_rev)
10225  mask_array = 1
10226  pos = maxloc(mask_array, judge_rev)
10227 
10228  if (err_flag) then
10229 
10230  wrong = check( &
10231  & pos(1), &
10232 
10233  & pos(2), &
10234 
10235  & pos(3), &
10236 
10237  & pos(4), &
10238 
10239  & pos(5), &
10240 
10241  & pos(6) )
10242 
10243  right = answer( &
10244  & pos(1), &
10245 
10246  & pos(2), &
10247 
10248  & pos(3), &
10249 
10250  & pos(4), &
10251 
10252  & pos(5), &
10253 
10254  & pos(6) )
10255 
10256  write(unit=pos_array(1), fmt="(i20)") pos(1)
10257 
10258  write(unit=pos_array(2), fmt="(i20)") pos(2)
10259 
10260  write(unit=pos_array(3), fmt="(i20)") pos(3)
10261 
10262  write(unit=pos_array(4), fmt="(i20)") pos(4)
10263 
10264  write(unit=pos_array(5), fmt="(i20)") pos(5)
10265 
10266  write(unit=pos_array(6), fmt="(i20)") pos(6)
10267 
10268 
10269  pos_str = '(' // &
10270  & trim(adjustl(pos_array(1))) // ',' // &
10271 
10272  & trim(adjustl(pos_array(2))) // ',' // &
10273 
10274  & trim(adjustl(pos_array(3))) // ',' // &
10275 
10276  & trim(adjustl(pos_array(4))) // ',' // &
10277 
10278  & trim(adjustl(pos_array(5))) // ',' // &
10279 
10280  & trim(adjustl(pos_array(6))) // ')'
10281 
10282  if ( both_negative( &
10283  & pos(1), &
10284 
10285  & pos(2), &
10286 
10287  & pos(3), &
10288 
10289  & pos(4), &
10290 
10291  & pos(5), &
10292 
10293  & pos(6) ) ) then
10294 
10295  abs_mes = 'ABSOLUTE value of'
10296  else
10297  abs_mes = ''
10298 
10299  end if
10300 
10301  end if
10302  deallocate(mask_array, judge, judge_rev)
10303  deallocate(answer_negative, check_negative, both_negative)
10304 
10305 
10306 
10307 
10308  if (err_flag) then
10309  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10310  write(*,*) ''
10311  write(*,*) ' ' // trim(abs_mes) // &
10312  & ' check' // trim(pos_str) // ' = ', wrong
10313  write(*,*) ' is NOT GREATER THAN'
10314  write(*,*) ' ' // trim(abs_mes) // &
10315  & ' answer' // trim(pos_str) // ' = ', right
10316 
10317  call abort()
10318  else
10319  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
10320  end if
10321 
10322 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthanint7()

subroutine dc_test::dctestassertgreaterthanint7 ( character(*), intent(in)  message,
integer, dimension(:,:,:,:,:,:,:), intent(in)  answer,
integer, dimension(:,:,:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 10328 of file dc_test.f90.

References dc_types::string, and dc_types::token.

10328  use dc_types, only: string, token
10329  implicit none
10330  character(*), intent(in):: message
10331  integer, intent(in):: answer(:,:,:,:,:,:,:)
10332  integer, intent(in):: check(:,:,:,:,:,:,:)
10333  logical, intent(in), optional:: negative_support
10334  logical:: err_flag
10335  logical:: negative_support_on
10336  character(STRING):: pos_str
10337  character(TOKEN):: abs_mes
10338  integer:: wrong, right
10339 
10340  integer:: answer_shape(7), check_shape(7), pos(7)
10341  logical:: consist_shape(7)
10342  character(TOKEN):: pos_array(7)
10343  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
10344  logical, allocatable:: judge(:,:,:,:,:,:,:)
10345  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
10346  logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
10347  logical, allocatable:: check_negative(:,:,:,:,:,:,:)
10348  logical, allocatable:: both_negative(:,:,:,:,:,:,:)
10349 
10350 
10351  continue
10352  if (present(negative_support)) then
10353  negative_support_on = negative_support
10354  else
10355  negative_support_on = .true.
10356  end if
10357 
10358  err_flag = .false.
10359 
10360 
10361  answer_shape = shape(answer)
10362  check_shape = shape(check)
10363 
10364  consist_shape = answer_shape == check_shape
10365 
10366  if (.not. all(consist_shape)) then
10367  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10368  write(*,*) ''
10369  write(*,*) ' shape of check is (', check_shape, ')'
10370  write(*,*) ' is INCORRECT'
10371  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
10372 
10373  call abort()
10374  end if
10375 
10376 
10377  allocate( mask_array( &
10378  & answer_shape(1), &
10379 
10380  & answer_shape(2), &
10381 
10382  & answer_shape(3), &
10383 
10384  & answer_shape(4), &
10385 
10386  & answer_shape(5), &
10387 
10388  & answer_shape(6), &
10389 
10390  & answer_shape(7) ) &
10391  & )
10392 
10393  allocate( judge( &
10394  & answer_shape(1), &
10395 
10396  & answer_shape(2), &
10397 
10398  & answer_shape(3), &
10399 
10400  & answer_shape(4), &
10401 
10402  & answer_shape(5), &
10403 
10404  & answer_shape(6), &
10405 
10406  & answer_shape(7) ) &
10407  & )
10408 
10409  allocate( judge_rev( &
10410  & answer_shape(1), &
10411 
10412  & answer_shape(2), &
10413 
10414  & answer_shape(3), &
10415 
10416  & answer_shape(4), &
10417 
10418  & answer_shape(5), &
10419 
10420  & answer_shape(6), &
10421 
10422  & answer_shape(7) ) &
10423  & )
10424 
10425  allocate( answer_negative( &
10426  & answer_shape(1), &
10427 
10428  & answer_shape(2), &
10429 
10430  & answer_shape(3), &
10431 
10432  & answer_shape(4), &
10433 
10434  & answer_shape(5), &
10435 
10436  & answer_shape(6), &
10437 
10438  & answer_shape(7) ) &
10439  & )
10440 
10441  allocate( check_negative( &
10442  & answer_shape(1), &
10443 
10444  & answer_shape(2), &
10445 
10446  & answer_shape(3), &
10447 
10448  & answer_shape(4), &
10449 
10450  & answer_shape(5), &
10451 
10452  & answer_shape(6), &
10453 
10454  & answer_shape(7) ) &
10455  & )
10456 
10457  allocate( both_negative( &
10458  & answer_shape(1), &
10459 
10460  & answer_shape(2), &
10461 
10462  & answer_shape(3), &
10463 
10464  & answer_shape(4), &
10465 
10466  & answer_shape(5), &
10467 
10468  & answer_shape(6), &
10469 
10470  & answer_shape(7) ) &
10471  & )
10472 
10473  answer_negative = answer < 0
10474  check_negative = check < 0
10475  both_negative = answer_negative .and. check_negative
10476  if (.not. negative_support_on) both_negative = .false.
10477 
10478  judge = answer < check
10479  where (both_negative) judge = .not. judge
10480 
10481  judge_rev = .not. judge
10482  err_flag = any(judge_rev)
10483  mask_array = 1
10484  pos = maxloc(mask_array, judge_rev)
10485 
10486  if (err_flag) then
10487 
10488  wrong = check( &
10489  & pos(1), &
10490 
10491  & pos(2), &
10492 
10493  & pos(3), &
10494 
10495  & pos(4), &
10496 
10497  & pos(5), &
10498 
10499  & pos(6), &
10500 
10501  & pos(7) )
10502 
10503  right = answer( &
10504  & pos(1), &
10505 
10506  & pos(2), &
10507 
10508  & pos(3), &
10509 
10510  & pos(4), &
10511 
10512  & pos(5), &
10513 
10514  & pos(6), &
10515 
10516  & pos(7) )
10517 
10518  write(unit=pos_array(1), fmt="(i20)") pos(1)
10519 
10520  write(unit=pos_array(2), fmt="(i20)") pos(2)
10521 
10522  write(unit=pos_array(3), fmt="(i20)") pos(3)
10523 
10524  write(unit=pos_array(4), fmt="(i20)") pos(4)
10525 
10526  write(unit=pos_array(5), fmt="(i20)") pos(5)
10527 
10528  write(unit=pos_array(6), fmt="(i20)") pos(6)
10529 
10530  write(unit=pos_array(7), fmt="(i20)") pos(7)
10531 
10532 
10533  pos_str = '(' // &
10534  & trim(adjustl(pos_array(1))) // ',' // &
10535 
10536  & trim(adjustl(pos_array(2))) // ',' // &
10537 
10538  & trim(adjustl(pos_array(3))) // ',' // &
10539 
10540  & trim(adjustl(pos_array(4))) // ',' // &
10541 
10542  & trim(adjustl(pos_array(5))) // ',' // &
10543 
10544  & trim(adjustl(pos_array(6))) // ',' // &
10545 
10546  & trim(adjustl(pos_array(7))) // ')'
10547 
10548  if ( both_negative( &
10549  & pos(1), &
10550 
10551  & pos(2), &
10552 
10553  & pos(3), &
10554 
10555  & pos(4), &
10556 
10557  & pos(5), &
10558 
10559  & pos(6), &
10560 
10561  & pos(7) ) ) then
10562 
10563  abs_mes = 'ABSOLUTE value of'
10564  else
10565  abs_mes = ''
10566 
10567  end if
10568 
10569  end if
10570  deallocate(mask_array, judge, judge_rev)
10571  deallocate(answer_negative, check_negative, both_negative)
10572 
10573 
10574 
10575 
10576  if (err_flag) then
10577  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10578  write(*,*) ''
10579  write(*,*) ' ' // trim(abs_mes) // &
10580  & ' check' // trim(pos_str) // ' = ', wrong
10581  write(*,*) ' is NOT GREATER THAN'
10582  write(*,*) ' ' // trim(abs_mes) // &
10583  & ' answer' // trim(pos_str) // ' = ', right
10584 
10585  call abort()
10586  else
10587  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
10588  end if
10589 
10590 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthanreal0()

subroutine dc_test::dctestassertgreaterthanreal0 ( character(*), intent(in)  message,
real, intent(in)  answer,
real, intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 10596 of file dc_test.f90.

References dc_types::string, and dc_types::token.

10596  use dc_types, only: string, token
10597  implicit none
10598  character(*), intent(in):: message
10599  real, intent(in):: answer
10600  real, intent(in):: check
10601  logical, intent(in), optional:: negative_support
10602  logical:: err_flag
10603  logical:: negative_support_on
10604  character(STRING):: pos_str
10605  character(TOKEN):: abs_mes
10606  real:: wrong, right
10607 
10608 
10609 
10610  continue
10611  if (present(negative_support)) then
10612  negative_support_on = negative_support
10613  else
10614  negative_support_on = .true.
10615  end if
10616 
10617  err_flag = .false.
10618 
10619 
10620  err_flag = .not. answer < check
10621  abs_mes = ''
10622 
10623  if ( answer < 0.0 &
10624  & .and. check < 0.0 &
10625  & .and. negative_support_on ) then
10626 
10627  err_flag = .not. err_flag
10628  abs_mes = 'ABSOLUTE value of'
10629  end if
10630 
10631  wrong = check
10632  right = answer
10633  pos_str = ''
10634 
10635 
10636 
10637 
10638  if (err_flag) then
10639  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10640  write(*,*) ''
10641  write(*,*) ' ' // trim(abs_mes) // &
10642  & ' check' // trim(pos_str) // ' = ', wrong
10643  write(*,*) ' is NOT GREATER THAN'
10644  write(*,*) ' ' // trim(abs_mes) // &
10645  & ' answer' // trim(pos_str) // ' = ', right
10646 
10647  call abort()
10648  else
10649  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
10650  end if
10651 
10652 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthanreal1()

subroutine dc_test::dctestassertgreaterthanreal1 ( character(*), intent(in)  message,
real, dimension(:), intent(in)  answer,
real, dimension(:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 10658 of file dc_test.f90.

References dc_types::string, and dc_types::token.

10658  use dc_types, only: string, token
10659  implicit none
10660  character(*), intent(in):: message
10661  real, intent(in):: answer(:)
10662  real, intent(in):: check(:)
10663  logical, intent(in), optional:: negative_support
10664  logical:: err_flag
10665  logical:: negative_support_on
10666  character(STRING):: pos_str
10667  character(TOKEN):: abs_mes
10668  real:: wrong, right
10669 
10670  integer:: answer_shape(1), check_shape(1), pos(1)
10671  logical:: consist_shape(1)
10672  character(TOKEN):: pos_array(1)
10673  integer, allocatable:: mask_array(:)
10674  logical, allocatable:: judge(:)
10675  logical, allocatable:: judge_rev(:)
10676  logical, allocatable:: answer_negative(:)
10677  logical, allocatable:: check_negative(:)
10678  logical, allocatable:: both_negative(:)
10679 
10680 
10681  continue
10682  if (present(negative_support)) then
10683  negative_support_on = negative_support
10684  else
10685  negative_support_on = .true.
10686  end if
10687 
10688  err_flag = .false.
10689 
10690 
10691  answer_shape = shape(answer)
10692  check_shape = shape(check)
10693 
10694  consist_shape = answer_shape == check_shape
10695 
10696  if (.not. all(consist_shape)) then
10697  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10698  write(*,*) ''
10699  write(*,*) ' shape of check is (', check_shape, ')'
10700  write(*,*) ' is INCORRECT'
10701  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
10702 
10703  call abort()
10704  end if
10705 
10706 
10707  allocate( mask_array( &
10708 
10709  & answer_shape(1) ) &
10710  & )
10711 
10712  allocate( judge( &
10713 
10714  & answer_shape(1) ) &
10715  & )
10716 
10717  allocate( judge_rev( &
10718 
10719  & answer_shape(1) ) &
10720  & )
10721 
10722  allocate( answer_negative( &
10723 
10724  & answer_shape(1) ) &
10725  & )
10726 
10727  allocate( check_negative( &
10728 
10729  & answer_shape(1) ) &
10730  & )
10731 
10732  allocate( both_negative( &
10733 
10734  & answer_shape(1) ) &
10735  & )
10736 
10737  answer_negative = answer < 0.0
10738  check_negative = check < 0.0
10739  both_negative = answer_negative .and. check_negative
10740  if (.not. negative_support_on) both_negative = .false.
10741 
10742  judge = answer < check
10743  where (both_negative) judge = .not. judge
10744 
10745  judge_rev = .not. judge
10746  err_flag = any(judge_rev)
10747  mask_array = 1
10748  pos = maxloc(mask_array, judge_rev)
10749 
10750  if (err_flag) then
10751 
10752  wrong = check( &
10753 
10754  & pos(1) )
10755 
10756  right = answer( &
10757 
10758  & pos(1) )
10759 
10760  write(unit=pos_array(1), fmt="(i20)") pos(1)
10761 
10762 
10763  pos_str = '(' // &
10764 
10765  & trim(adjustl(pos_array(1))) // ')'
10766 
10767  if ( both_negative( &
10768 
10769  & pos(1) ) ) then
10770 
10771  abs_mes = 'ABSOLUTE value of'
10772  else
10773  abs_mes = ''
10774 
10775  end if
10776 
10777  end if
10778  deallocate(mask_array, judge, judge_rev)
10779  deallocate(answer_negative, check_negative, both_negative)
10780 
10781 
10782 
10783 
10784  if (err_flag) then
10785  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10786  write(*,*) ''
10787  write(*,*) ' ' // trim(abs_mes) // &
10788  & ' check' // trim(pos_str) // ' = ', wrong
10789  write(*,*) ' is NOT GREATER THAN'
10790  write(*,*) ' ' // trim(abs_mes) // &
10791  & ' answer' // trim(pos_str) // ' = ', right
10792 
10793  call abort()
10794  else
10795  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
10796  end if
10797 
10798 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthanreal2()

subroutine dc_test::dctestassertgreaterthanreal2 ( character(*), intent(in)  message,
real, dimension(:,:), intent(in)  answer,
real, dimension(:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 10804 of file dc_test.f90.

References dc_types::string, and dc_types::token.

10804  use dc_types, only: string, token
10805  implicit none
10806  character(*), intent(in):: message
10807  real, intent(in):: answer(:,:)
10808  real, intent(in):: check(:,:)
10809  logical, intent(in), optional:: negative_support
10810  logical:: err_flag
10811  logical:: negative_support_on
10812  character(STRING):: pos_str
10813  character(TOKEN):: abs_mes
10814  real:: wrong, right
10815 
10816  integer:: answer_shape(2), check_shape(2), pos(2)
10817  logical:: consist_shape(2)
10818  character(TOKEN):: pos_array(2)
10819  integer, allocatable:: mask_array(:,:)
10820  logical, allocatable:: judge(:,:)
10821  logical, allocatable:: judge_rev(:,:)
10822  logical, allocatable:: answer_negative(:,:)
10823  logical, allocatable:: check_negative(:,:)
10824  logical, allocatable:: both_negative(:,:)
10825 
10826 
10827  continue
10828  if (present(negative_support)) then
10829  negative_support_on = negative_support
10830  else
10831  negative_support_on = .true.
10832  end if
10833 
10834  err_flag = .false.
10835 
10836 
10837  answer_shape = shape(answer)
10838  check_shape = shape(check)
10839 
10840  consist_shape = answer_shape == check_shape
10841 
10842  if (.not. all(consist_shape)) then
10843  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10844  write(*,*) ''
10845  write(*,*) ' shape of check is (', check_shape, ')'
10846  write(*,*) ' is INCORRECT'
10847  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
10848 
10849  call abort()
10850  end if
10851 
10852 
10853  allocate( mask_array( &
10854  & answer_shape(1), &
10855 
10856  & answer_shape(2) ) &
10857  & )
10858 
10859  allocate( judge( &
10860  & answer_shape(1), &
10861 
10862  & answer_shape(2) ) &
10863  & )
10864 
10865  allocate( judge_rev( &
10866  & answer_shape(1), &
10867 
10868  & answer_shape(2) ) &
10869  & )
10870 
10871  allocate( answer_negative( &
10872  & answer_shape(1), &
10873 
10874  & answer_shape(2) ) &
10875  & )
10876 
10877  allocate( check_negative( &
10878  & answer_shape(1), &
10879 
10880  & answer_shape(2) ) &
10881  & )
10882 
10883  allocate( both_negative( &
10884  & answer_shape(1), &
10885 
10886  & answer_shape(2) ) &
10887  & )
10888 
10889  answer_negative = answer < 0.0
10890  check_negative = check < 0.0
10891  both_negative = answer_negative .and. check_negative
10892  if (.not. negative_support_on) both_negative = .false.
10893 
10894  judge = answer < check
10895  where (both_negative) judge = .not. judge
10896 
10897  judge_rev = .not. judge
10898  err_flag = any(judge_rev)
10899  mask_array = 1
10900  pos = maxloc(mask_array, judge_rev)
10901 
10902  if (err_flag) then
10903 
10904  wrong = check( &
10905  & pos(1), &
10906 
10907  & pos(2) )
10908 
10909  right = answer( &
10910  & pos(1), &
10911 
10912  & pos(2) )
10913 
10914  write(unit=pos_array(1), fmt="(i20)") pos(1)
10915 
10916  write(unit=pos_array(2), fmt="(i20)") pos(2)
10917 
10918 
10919  pos_str = '(' // &
10920  & trim(adjustl(pos_array(1))) // ',' // &
10921 
10922  & trim(adjustl(pos_array(2))) // ')'
10923 
10924  if ( both_negative( &
10925  & pos(1), &
10926 
10927  & pos(2) ) ) then
10928 
10929  abs_mes = 'ABSOLUTE value of'
10930  else
10931  abs_mes = ''
10932 
10933  end if
10934 
10935  end if
10936  deallocate(mask_array, judge, judge_rev)
10937  deallocate(answer_negative, check_negative, both_negative)
10938 
10939 
10940 
10941 
10942  if (err_flag) then
10943  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
10944  write(*,*) ''
10945  write(*,*) ' ' // trim(abs_mes) // &
10946  & ' check' // trim(pos_str) // ' = ', wrong
10947  write(*,*) ' is NOT GREATER THAN'
10948  write(*,*) ' ' // trim(abs_mes) // &
10949  & ' answer' // trim(pos_str) // ' = ', right
10950 
10951  call abort()
10952  else
10953  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
10954  end if
10955 
10956 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthanreal3()

subroutine dc_test::dctestassertgreaterthanreal3 ( character(*), intent(in)  message,
real, dimension(:,:,:), intent(in)  answer,
real, dimension(:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 10962 of file dc_test.f90.

References dc_types::string, and dc_types::token.

10962  use dc_types, only: string, token
10963  implicit none
10964  character(*), intent(in):: message
10965  real, intent(in):: answer(:,:,:)
10966  real, intent(in):: check(:,:,:)
10967  logical, intent(in), optional:: negative_support
10968  logical:: err_flag
10969  logical:: negative_support_on
10970  character(STRING):: pos_str
10971  character(TOKEN):: abs_mes
10972  real:: wrong, right
10973 
10974  integer:: answer_shape(3), check_shape(3), pos(3)
10975  logical:: consist_shape(3)
10976  character(TOKEN):: pos_array(3)
10977  integer, allocatable:: mask_array(:,:,:)
10978  logical, allocatable:: judge(:,:,:)
10979  logical, allocatable:: judge_rev(:,:,:)
10980  logical, allocatable:: answer_negative(:,:,:)
10981  logical, allocatable:: check_negative(:,:,:)
10982  logical, allocatable:: both_negative(:,:,:)
10983 
10984 
10985  continue
10986  if (present(negative_support)) then
10987  negative_support_on = negative_support
10988  else
10989  negative_support_on = .true.
10990  end if
10991 
10992  err_flag = .false.
10993 
10994 
10995  answer_shape = shape(answer)
10996  check_shape = shape(check)
10997 
10998  consist_shape = answer_shape == check_shape
10999 
11000  if (.not. all(consist_shape)) then
11001  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11002  write(*,*) ''
11003  write(*,*) ' shape of check is (', check_shape, ')'
11004  write(*,*) ' is INCORRECT'
11005  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
11006 
11007  call abort()
11008  end if
11009 
11010 
11011  allocate( mask_array( &
11012  & answer_shape(1), &
11013 
11014  & answer_shape(2), &
11015 
11016  & answer_shape(3) ) &
11017  & )
11018 
11019  allocate( judge( &
11020  & answer_shape(1), &
11021 
11022  & answer_shape(2), &
11023 
11024  & answer_shape(3) ) &
11025  & )
11026 
11027  allocate( judge_rev( &
11028  & answer_shape(1), &
11029 
11030  & answer_shape(2), &
11031 
11032  & answer_shape(3) ) &
11033  & )
11034 
11035  allocate( answer_negative( &
11036  & answer_shape(1), &
11037 
11038  & answer_shape(2), &
11039 
11040  & answer_shape(3) ) &
11041  & )
11042 
11043  allocate( check_negative( &
11044  & answer_shape(1), &
11045 
11046  & answer_shape(2), &
11047 
11048  & answer_shape(3) ) &
11049  & )
11050 
11051  allocate( both_negative( &
11052  & answer_shape(1), &
11053 
11054  & answer_shape(2), &
11055 
11056  & answer_shape(3) ) &
11057  & )
11058 
11059  answer_negative = answer < 0.0
11060  check_negative = check < 0.0
11061  both_negative = answer_negative .and. check_negative
11062  if (.not. negative_support_on) both_negative = .false.
11063 
11064  judge = answer < check
11065  where (both_negative) judge = .not. judge
11066 
11067  judge_rev = .not. judge
11068  err_flag = any(judge_rev)
11069  mask_array = 1
11070  pos = maxloc(mask_array, judge_rev)
11071 
11072  if (err_flag) then
11073 
11074  wrong = check( &
11075  & pos(1), &
11076 
11077  & pos(2), &
11078 
11079  & pos(3) )
11080 
11081  right = answer( &
11082  & pos(1), &
11083 
11084  & pos(2), &
11085 
11086  & pos(3) )
11087 
11088  write(unit=pos_array(1), fmt="(i20)") pos(1)
11089 
11090  write(unit=pos_array(2), fmt="(i20)") pos(2)
11091 
11092  write(unit=pos_array(3), fmt="(i20)") pos(3)
11093 
11094 
11095  pos_str = '(' // &
11096  & trim(adjustl(pos_array(1))) // ',' // &
11097 
11098  & trim(adjustl(pos_array(2))) // ',' // &
11099 
11100  & trim(adjustl(pos_array(3))) // ')'
11101 
11102  if ( both_negative( &
11103  & pos(1), &
11104 
11105  & pos(2), &
11106 
11107  & pos(3) ) ) then
11108 
11109  abs_mes = 'ABSOLUTE value of'
11110  else
11111  abs_mes = ''
11112 
11113  end if
11114 
11115  end if
11116  deallocate(mask_array, judge, judge_rev)
11117  deallocate(answer_negative, check_negative, both_negative)
11118 
11119 
11120 
11121 
11122  if (err_flag) then
11123  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11124  write(*,*) ''
11125  write(*,*) ' ' // trim(abs_mes) // &
11126  & ' check' // trim(pos_str) // ' = ', wrong
11127  write(*,*) ' is NOT GREATER THAN'
11128  write(*,*) ' ' // trim(abs_mes) // &
11129  & ' answer' // trim(pos_str) // ' = ', right
11130 
11131  call abort()
11132  else
11133  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
11134  end if
11135 
11136 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthanreal4()

subroutine dc_test::dctestassertgreaterthanreal4 ( character(*), intent(in)  message,
real, dimension(:,:,:,:), intent(in)  answer,
real, dimension(:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 11142 of file dc_test.f90.

References dc_types::string, and dc_types::token.

11142  use dc_types, only: string, token
11143  implicit none
11144  character(*), intent(in):: message
11145  real, intent(in):: answer(:,:,:,:)
11146  real, intent(in):: check(:,:,:,:)
11147  logical, intent(in), optional:: negative_support
11148  logical:: err_flag
11149  logical:: negative_support_on
11150  character(STRING):: pos_str
11151  character(TOKEN):: abs_mes
11152  real:: wrong, right
11153 
11154  integer:: answer_shape(4), check_shape(4), pos(4)
11155  logical:: consist_shape(4)
11156  character(TOKEN):: pos_array(4)
11157  integer, allocatable:: mask_array(:,:,:,:)
11158  logical, allocatable:: judge(:,:,:,:)
11159  logical, allocatable:: judge_rev(:,:,:,:)
11160  logical, allocatable:: answer_negative(:,:,:,:)
11161  logical, allocatable:: check_negative(:,:,:,:)
11162  logical, allocatable:: both_negative(:,:,:,:)
11163 
11164 
11165  continue
11166  if (present(negative_support)) then
11167  negative_support_on = negative_support
11168  else
11169  negative_support_on = .true.
11170  end if
11171 
11172  err_flag = .false.
11173 
11174 
11175  answer_shape = shape(answer)
11176  check_shape = shape(check)
11177 
11178  consist_shape = answer_shape == check_shape
11179 
11180  if (.not. all(consist_shape)) then
11181  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11182  write(*,*) ''
11183  write(*,*) ' shape of check is (', check_shape, ')'
11184  write(*,*) ' is INCORRECT'
11185  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
11186 
11187  call abort()
11188  end if
11189 
11190 
11191  allocate( mask_array( &
11192  & answer_shape(1), &
11193 
11194  & answer_shape(2), &
11195 
11196  & answer_shape(3), &
11197 
11198  & answer_shape(4) ) &
11199  & )
11200 
11201  allocate( judge( &
11202  & answer_shape(1), &
11203 
11204  & answer_shape(2), &
11205 
11206  & answer_shape(3), &
11207 
11208  & answer_shape(4) ) &
11209  & )
11210 
11211  allocate( judge_rev( &
11212  & answer_shape(1), &
11213 
11214  & answer_shape(2), &
11215 
11216  & answer_shape(3), &
11217 
11218  & answer_shape(4) ) &
11219  & )
11220 
11221  allocate( answer_negative( &
11222  & answer_shape(1), &
11223 
11224  & answer_shape(2), &
11225 
11226  & answer_shape(3), &
11227 
11228  & answer_shape(4) ) &
11229  & )
11230 
11231  allocate( check_negative( &
11232  & answer_shape(1), &
11233 
11234  & answer_shape(2), &
11235 
11236  & answer_shape(3), &
11237 
11238  & answer_shape(4) ) &
11239  & )
11240 
11241  allocate( both_negative( &
11242  & answer_shape(1), &
11243 
11244  & answer_shape(2), &
11245 
11246  & answer_shape(3), &
11247 
11248  & answer_shape(4) ) &
11249  & )
11250 
11251  answer_negative = answer < 0.0
11252  check_negative = check < 0.0
11253  both_negative = answer_negative .and. check_negative
11254  if (.not. negative_support_on) both_negative = .false.
11255 
11256  judge = answer < check
11257  where (both_negative) judge = .not. judge
11258 
11259  judge_rev = .not. judge
11260  err_flag = any(judge_rev)
11261  mask_array = 1
11262  pos = maxloc(mask_array, judge_rev)
11263 
11264  if (err_flag) then
11265 
11266  wrong = check( &
11267  & pos(1), &
11268 
11269  & pos(2), &
11270 
11271  & pos(3), &
11272 
11273  & pos(4) )
11274 
11275  right = answer( &
11276  & pos(1), &
11277 
11278  & pos(2), &
11279 
11280  & pos(3), &
11281 
11282  & pos(4) )
11283 
11284  write(unit=pos_array(1), fmt="(i20)") pos(1)
11285 
11286  write(unit=pos_array(2), fmt="(i20)") pos(2)
11287 
11288  write(unit=pos_array(3), fmt="(i20)") pos(3)
11289 
11290  write(unit=pos_array(4), fmt="(i20)") pos(4)
11291 
11292 
11293  pos_str = '(' // &
11294  & trim(adjustl(pos_array(1))) // ',' // &
11295 
11296  & trim(adjustl(pos_array(2))) // ',' // &
11297 
11298  & trim(adjustl(pos_array(3))) // ',' // &
11299 
11300  & trim(adjustl(pos_array(4))) // ')'
11301 
11302  if ( both_negative( &
11303  & pos(1), &
11304 
11305  & pos(2), &
11306 
11307  & pos(3), &
11308 
11309  & pos(4) ) ) then
11310 
11311  abs_mes = 'ABSOLUTE value of'
11312  else
11313  abs_mes = ''
11314 
11315  end if
11316 
11317  end if
11318  deallocate(mask_array, judge, judge_rev)
11319  deallocate(answer_negative, check_negative, both_negative)
11320 
11321 
11322 
11323 
11324  if (err_flag) then
11325  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11326  write(*,*) ''
11327  write(*,*) ' ' // trim(abs_mes) // &
11328  & ' check' // trim(pos_str) // ' = ', wrong
11329  write(*,*) ' is NOT GREATER THAN'
11330  write(*,*) ' ' // trim(abs_mes) // &
11331  & ' answer' // trim(pos_str) // ' = ', right
11332 
11333  call abort()
11334  else
11335  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
11336  end if
11337 
11338 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthanreal5()

subroutine dc_test::dctestassertgreaterthanreal5 ( character(*), intent(in)  message,
real, dimension(:,:,:,:,:), intent(in)  answer,
real, dimension(:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 11344 of file dc_test.f90.

References dc_types::string, and dc_types::token.

11344  use dc_types, only: string, token
11345  implicit none
11346  character(*), intent(in):: message
11347  real, intent(in):: answer(:,:,:,:,:)
11348  real, intent(in):: check(:,:,:,:,:)
11349  logical, intent(in), optional:: negative_support
11350  logical:: err_flag
11351  logical:: negative_support_on
11352  character(STRING):: pos_str
11353  character(TOKEN):: abs_mes
11354  real:: wrong, right
11355 
11356  integer:: answer_shape(5), check_shape(5), pos(5)
11357  logical:: consist_shape(5)
11358  character(TOKEN):: pos_array(5)
11359  integer, allocatable:: mask_array(:,:,:,:,:)
11360  logical, allocatable:: judge(:,:,:,:,:)
11361  logical, allocatable:: judge_rev(:,:,:,:,:)
11362  logical, allocatable:: answer_negative(:,:,:,:,:)
11363  logical, allocatable:: check_negative(:,:,:,:,:)
11364  logical, allocatable:: both_negative(:,:,:,:,:)
11365 
11366 
11367  continue
11368  if (present(negative_support)) then
11369  negative_support_on = negative_support
11370  else
11371  negative_support_on = .true.
11372  end if
11373 
11374  err_flag = .false.
11375 
11376 
11377  answer_shape = shape(answer)
11378  check_shape = shape(check)
11379 
11380  consist_shape = answer_shape == check_shape
11381 
11382  if (.not. all(consist_shape)) then
11383  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11384  write(*,*) ''
11385  write(*,*) ' shape of check is (', check_shape, ')'
11386  write(*,*) ' is INCORRECT'
11387  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
11388 
11389  call abort()
11390  end if
11391 
11392 
11393  allocate( mask_array( &
11394  & answer_shape(1), &
11395 
11396  & answer_shape(2), &
11397 
11398  & answer_shape(3), &
11399 
11400  & answer_shape(4), &
11401 
11402  & answer_shape(5) ) &
11403  & )
11404 
11405  allocate( judge( &
11406  & answer_shape(1), &
11407 
11408  & answer_shape(2), &
11409 
11410  & answer_shape(3), &
11411 
11412  & answer_shape(4), &
11413 
11414  & answer_shape(5) ) &
11415  & )
11416 
11417  allocate( judge_rev( &
11418  & answer_shape(1), &
11419 
11420  & answer_shape(2), &
11421 
11422  & answer_shape(3), &
11423 
11424  & answer_shape(4), &
11425 
11426  & answer_shape(5) ) &
11427  & )
11428 
11429  allocate( answer_negative( &
11430  & answer_shape(1), &
11431 
11432  & answer_shape(2), &
11433 
11434  & answer_shape(3), &
11435 
11436  & answer_shape(4), &
11437 
11438  & answer_shape(5) ) &
11439  & )
11440 
11441  allocate( check_negative( &
11442  & answer_shape(1), &
11443 
11444  & answer_shape(2), &
11445 
11446  & answer_shape(3), &
11447 
11448  & answer_shape(4), &
11449 
11450  & answer_shape(5) ) &
11451  & )
11452 
11453  allocate( both_negative( &
11454  & answer_shape(1), &
11455 
11456  & answer_shape(2), &
11457 
11458  & answer_shape(3), &
11459 
11460  & answer_shape(4), &
11461 
11462  & answer_shape(5) ) &
11463  & )
11464 
11465  answer_negative = answer < 0.0
11466  check_negative = check < 0.0
11467  both_negative = answer_negative .and. check_negative
11468  if (.not. negative_support_on) both_negative = .false.
11469 
11470  judge = answer < check
11471  where (both_negative) judge = .not. judge
11472 
11473  judge_rev = .not. judge
11474  err_flag = any(judge_rev)
11475  mask_array = 1
11476  pos = maxloc(mask_array, judge_rev)
11477 
11478  if (err_flag) then
11479 
11480  wrong = check( &
11481  & pos(1), &
11482 
11483  & pos(2), &
11484 
11485  & pos(3), &
11486 
11487  & pos(4), &
11488 
11489  & pos(5) )
11490 
11491  right = answer( &
11492  & pos(1), &
11493 
11494  & pos(2), &
11495 
11496  & pos(3), &
11497 
11498  & pos(4), &
11499 
11500  & pos(5) )
11501 
11502  write(unit=pos_array(1), fmt="(i20)") pos(1)
11503 
11504  write(unit=pos_array(2), fmt="(i20)") pos(2)
11505 
11506  write(unit=pos_array(3), fmt="(i20)") pos(3)
11507 
11508  write(unit=pos_array(4), fmt="(i20)") pos(4)
11509 
11510  write(unit=pos_array(5), fmt="(i20)") pos(5)
11511 
11512 
11513  pos_str = '(' // &
11514  & trim(adjustl(pos_array(1))) // ',' // &
11515 
11516  & trim(adjustl(pos_array(2))) // ',' // &
11517 
11518  & trim(adjustl(pos_array(3))) // ',' // &
11519 
11520  & trim(adjustl(pos_array(4))) // ',' // &
11521 
11522  & trim(adjustl(pos_array(5))) // ')'
11523 
11524  if ( both_negative( &
11525  & pos(1), &
11526 
11527  & pos(2), &
11528 
11529  & pos(3), &
11530 
11531  & pos(4), &
11532 
11533  & pos(5) ) ) then
11534 
11535  abs_mes = 'ABSOLUTE value of'
11536  else
11537  abs_mes = ''
11538 
11539  end if
11540 
11541  end if
11542  deallocate(mask_array, judge, judge_rev)
11543  deallocate(answer_negative, check_negative, both_negative)
11544 
11545 
11546 
11547 
11548  if (err_flag) then
11549  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11550  write(*,*) ''
11551  write(*,*) ' ' // trim(abs_mes) // &
11552  & ' check' // trim(pos_str) // ' = ', wrong
11553  write(*,*) ' is NOT GREATER THAN'
11554  write(*,*) ' ' // trim(abs_mes) // &
11555  & ' answer' // trim(pos_str) // ' = ', right
11556 
11557  call abort()
11558  else
11559  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
11560  end if
11561 
11562 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthanreal6()

subroutine dc_test::dctestassertgreaterthanreal6 ( character(*), intent(in)  message,
real, dimension(:,:,:,:,:,:), intent(in)  answer,
real, dimension(:,:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 11568 of file dc_test.f90.

References dc_types::string, and dc_types::token.

11568  use dc_types, only: string, token
11569  implicit none
11570  character(*), intent(in):: message
11571  real, intent(in):: answer(:,:,:,:,:,:)
11572  real, intent(in):: check(:,:,:,:,:,:)
11573  logical, intent(in), optional:: negative_support
11574  logical:: err_flag
11575  logical:: negative_support_on
11576  character(STRING):: pos_str
11577  character(TOKEN):: abs_mes
11578  real:: wrong, right
11579 
11580  integer:: answer_shape(6), check_shape(6), pos(6)
11581  logical:: consist_shape(6)
11582  character(TOKEN):: pos_array(6)
11583  integer, allocatable:: mask_array(:,:,:,:,:,:)
11584  logical, allocatable:: judge(:,:,:,:,:,:)
11585  logical, allocatable:: judge_rev(:,:,:,:,:,:)
11586  logical, allocatable:: answer_negative(:,:,:,:,:,:)
11587  logical, allocatable:: check_negative(:,:,:,:,:,:)
11588  logical, allocatable:: both_negative(:,:,:,:,:,:)
11589 
11590 
11591  continue
11592  if (present(negative_support)) then
11593  negative_support_on = negative_support
11594  else
11595  negative_support_on = .true.
11596  end if
11597 
11598  err_flag = .false.
11599 
11600 
11601  answer_shape = shape(answer)
11602  check_shape = shape(check)
11603 
11604  consist_shape = answer_shape == check_shape
11605 
11606  if (.not. all(consist_shape)) then
11607  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11608  write(*,*) ''
11609  write(*,*) ' shape of check is (', check_shape, ')'
11610  write(*,*) ' is INCORRECT'
11611  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
11612 
11613  call abort()
11614  end if
11615 
11616 
11617  allocate( mask_array( &
11618  & answer_shape(1), &
11619 
11620  & answer_shape(2), &
11621 
11622  & answer_shape(3), &
11623 
11624  & answer_shape(4), &
11625 
11626  & answer_shape(5), &
11627 
11628  & answer_shape(6) ) &
11629  & )
11630 
11631  allocate( judge( &
11632  & answer_shape(1), &
11633 
11634  & answer_shape(2), &
11635 
11636  & answer_shape(3), &
11637 
11638  & answer_shape(4), &
11639 
11640  & answer_shape(5), &
11641 
11642  & answer_shape(6) ) &
11643  & )
11644 
11645  allocate( judge_rev( &
11646  & answer_shape(1), &
11647 
11648  & answer_shape(2), &
11649 
11650  & answer_shape(3), &
11651 
11652  & answer_shape(4), &
11653 
11654  & answer_shape(5), &
11655 
11656  & answer_shape(6) ) &
11657  & )
11658 
11659  allocate( answer_negative( &
11660  & answer_shape(1), &
11661 
11662  & answer_shape(2), &
11663 
11664  & answer_shape(3), &
11665 
11666  & answer_shape(4), &
11667 
11668  & answer_shape(5), &
11669 
11670  & answer_shape(6) ) &
11671  & )
11672 
11673  allocate( check_negative( &
11674  & answer_shape(1), &
11675 
11676  & answer_shape(2), &
11677 
11678  & answer_shape(3), &
11679 
11680  & answer_shape(4), &
11681 
11682  & answer_shape(5), &
11683 
11684  & answer_shape(6) ) &
11685  & )
11686 
11687  allocate( both_negative( &
11688  & answer_shape(1), &
11689 
11690  & answer_shape(2), &
11691 
11692  & answer_shape(3), &
11693 
11694  & answer_shape(4), &
11695 
11696  & answer_shape(5), &
11697 
11698  & answer_shape(6) ) &
11699  & )
11700 
11701  answer_negative = answer < 0.0
11702  check_negative = check < 0.0
11703  both_negative = answer_negative .and. check_negative
11704  if (.not. negative_support_on) both_negative = .false.
11705 
11706  judge = answer < check
11707  where (both_negative) judge = .not. judge
11708 
11709  judge_rev = .not. judge
11710  err_flag = any(judge_rev)
11711  mask_array = 1
11712  pos = maxloc(mask_array, judge_rev)
11713 
11714  if (err_flag) then
11715 
11716  wrong = check( &
11717  & pos(1), &
11718 
11719  & pos(2), &
11720 
11721  & pos(3), &
11722 
11723  & pos(4), &
11724 
11725  & pos(5), &
11726 
11727  & pos(6) )
11728 
11729  right = answer( &
11730  & pos(1), &
11731 
11732  & pos(2), &
11733 
11734  & pos(3), &
11735 
11736  & pos(4), &
11737 
11738  & pos(5), &
11739 
11740  & pos(6) )
11741 
11742  write(unit=pos_array(1), fmt="(i20)") pos(1)
11743 
11744  write(unit=pos_array(2), fmt="(i20)") pos(2)
11745 
11746  write(unit=pos_array(3), fmt="(i20)") pos(3)
11747 
11748  write(unit=pos_array(4), fmt="(i20)") pos(4)
11749 
11750  write(unit=pos_array(5), fmt="(i20)") pos(5)
11751 
11752  write(unit=pos_array(6), fmt="(i20)") pos(6)
11753 
11754 
11755  pos_str = '(' // &
11756  & trim(adjustl(pos_array(1))) // ',' // &
11757 
11758  & trim(adjustl(pos_array(2))) // ',' // &
11759 
11760  & trim(adjustl(pos_array(3))) // ',' // &
11761 
11762  & trim(adjustl(pos_array(4))) // ',' // &
11763 
11764  & trim(adjustl(pos_array(5))) // ',' // &
11765 
11766  & trim(adjustl(pos_array(6))) // ')'
11767 
11768  if ( both_negative( &
11769  & pos(1), &
11770 
11771  & pos(2), &
11772 
11773  & pos(3), &
11774 
11775  & pos(4), &
11776 
11777  & pos(5), &
11778 
11779  & pos(6) ) ) then
11780 
11781  abs_mes = 'ABSOLUTE value of'
11782  else
11783  abs_mes = ''
11784 
11785  end if
11786 
11787  end if
11788  deallocate(mask_array, judge, judge_rev)
11789  deallocate(answer_negative, check_negative, both_negative)
11790 
11791 
11792 
11793 
11794  if (err_flag) then
11795  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11796  write(*,*) ''
11797  write(*,*) ' ' // trim(abs_mes) // &
11798  & ' check' // trim(pos_str) // ' = ', wrong
11799  write(*,*) ' is NOT GREATER THAN'
11800  write(*,*) ' ' // trim(abs_mes) // &
11801  & ' answer' // trim(pos_str) // ' = ', right
11802 
11803  call abort()
11804  else
11805  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
11806  end if
11807 
11808 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthanreal7()

subroutine dc_test::dctestassertgreaterthanreal7 ( character(*), intent(in)  message,
real, dimension(:,:,:,:,:,:,:), intent(in)  answer,
real, dimension(:,:,:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 11814 of file dc_test.f90.

References dc_types::string, and dc_types::token.

11814  use dc_types, only: string, token
11815  implicit none
11816  character(*), intent(in):: message
11817  real, intent(in):: answer(:,:,:,:,:,:,:)
11818  real, intent(in):: check(:,:,:,:,:,:,:)
11819  logical, intent(in), optional:: negative_support
11820  logical:: err_flag
11821  logical:: negative_support_on
11822  character(STRING):: pos_str
11823  character(TOKEN):: abs_mes
11824  real:: wrong, right
11825 
11826  integer:: answer_shape(7), check_shape(7), pos(7)
11827  logical:: consist_shape(7)
11828  character(TOKEN):: pos_array(7)
11829  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
11830  logical, allocatable:: judge(:,:,:,:,:,:,:)
11831  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
11832  logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
11833  logical, allocatable:: check_negative(:,:,:,:,:,:,:)
11834  logical, allocatable:: both_negative(:,:,:,:,:,:,:)
11835 
11836 
11837  continue
11838  if (present(negative_support)) then
11839  negative_support_on = negative_support
11840  else
11841  negative_support_on = .true.
11842  end if
11843 
11844  err_flag = .false.
11845 
11846 
11847  answer_shape = shape(answer)
11848  check_shape = shape(check)
11849 
11850  consist_shape = answer_shape == check_shape
11851 
11852  if (.not. all(consist_shape)) then
11853  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
11854  write(*,*) ''
11855  write(*,*) ' shape of check is (', check_shape, ')'
11856  write(*,*) ' is INCORRECT'
11857  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
11858 
11859  call abort()
11860  end if
11861 
11862 
11863  allocate( mask_array( &
11864  & answer_shape(1), &
11865 
11866  & answer_shape(2), &
11867 
11868  & answer_shape(3), &
11869 
11870  & answer_shape(4), &
11871 
11872  & answer_shape(5), &
11873 
11874  & answer_shape(6), &
11875 
11876  & answer_shape(7) ) &
11877  & )
11878 
11879  allocate( judge( &
11880  & answer_shape(1), &
11881 
11882  & answer_shape(2), &
11883 
11884  & answer_shape(3), &
11885 
11886  & answer_shape(4), &
11887 
11888  & answer_shape(5), &
11889 
11890  & answer_shape(6), &
11891 
11892  & answer_shape(7) ) &
11893  & )
11894 
11895  allocate( judge_rev( &
11896  & answer_shape(1), &
11897 
11898  & answer_shape(2), &
11899 
11900  & answer_shape(3), &
11901 
11902  & answer_shape(4), &
11903 
11904  & answer_shape(5), &
11905 
11906  & answer_shape(6), &
11907 
11908  & answer_shape(7) ) &
11909  & )
11910 
11911  allocate( answer_negative( &
11912  & answer_shape(1), &
11913 
11914  & answer_shape(2), &
11915 
11916  & answer_shape(3), &
11917 
11918  & answer_shape(4), &
11919 
11920  & answer_shape(5), &
11921 
11922  & answer_shape(6), &
11923 
11924  & answer_shape(7) ) &
11925  & )
11926 
11927  allocate( check_negative( &
11928  & answer_shape(1), &
11929 
11930  & answer_shape(2), &
11931 
11932  & answer_shape(3), &
11933 
11934  & answer_shape(4), &
11935 
11936  & answer_shape(5), &
11937 
11938  & answer_shape(6), &
11939 
11940  & answer_shape(7) ) &
11941  & )
11942 
11943  allocate( both_negative( &
11944  & answer_shape(1), &
11945 
11946  & answer_shape(2), &
11947 
11948  & answer_shape(3), &
11949 
11950  & answer_shape(4), &
11951 
11952  & answer_shape(5), &
11953 
11954  & answer_shape(6), &
11955 
11956  & answer_shape(7) ) &
11957  & )
11958 
11959  answer_negative = answer < 0.0
11960  check_negative = check < 0.0
11961  both_negative = answer_negative .and. check_negative
11962  if (.not. negative_support_on) both_negative = .false.
11963 
11964  judge = answer < check
11965  where (both_negative) judge = .not. judge
11966 
11967  judge_rev = .not. judge
11968  err_flag = any(judge_rev)
11969  mask_array = 1
11970  pos = maxloc(mask_array, judge_rev)
11971 
11972  if (err_flag) then
11973 
11974  wrong = check( &
11975  & pos(1), &
11976 
11977  & pos(2), &
11978 
11979  & pos(3), &
11980 
11981  & pos(4), &
11982 
11983  & pos(5), &
11984 
11985  & pos(6), &
11986 
11987  & pos(7) )
11988 
11989  right = answer( &
11990  & pos(1), &
11991 
11992  & pos(2), &
11993 
11994  & pos(3), &
11995 
11996  & pos(4), &
11997 
11998  & pos(5), &
11999 
12000  & pos(6), &
12001 
12002  & pos(7) )
12003 
12004  write(unit=pos_array(1), fmt="(i20)") pos(1)
12005 
12006  write(unit=pos_array(2), fmt="(i20)") pos(2)
12007 
12008  write(unit=pos_array(3), fmt="(i20)") pos(3)
12009 
12010  write(unit=pos_array(4), fmt="(i20)") pos(4)
12011 
12012  write(unit=pos_array(5), fmt="(i20)") pos(5)
12013 
12014  write(unit=pos_array(6), fmt="(i20)") pos(6)
12015 
12016  write(unit=pos_array(7), fmt="(i20)") pos(7)
12017 
12018 
12019  pos_str = '(' // &
12020  & trim(adjustl(pos_array(1))) // ',' // &
12021 
12022  & trim(adjustl(pos_array(2))) // ',' // &
12023 
12024  & trim(adjustl(pos_array(3))) // ',' // &
12025 
12026  & trim(adjustl(pos_array(4))) // ',' // &
12027 
12028  & trim(adjustl(pos_array(5))) // ',' // &
12029 
12030  & trim(adjustl(pos_array(6))) // ',' // &
12031 
12032  & trim(adjustl(pos_array(7))) // ')'
12033 
12034  if ( both_negative( &
12035  & pos(1), &
12036 
12037  & pos(2), &
12038 
12039  & pos(3), &
12040 
12041  & pos(4), &
12042 
12043  & pos(5), &
12044 
12045  & pos(6), &
12046 
12047  & pos(7) ) ) then
12048 
12049  abs_mes = 'ABSOLUTE value of'
12050  else
12051  abs_mes = ''
12052 
12053  end if
12054 
12055  end if
12056  deallocate(mask_array, judge, judge_rev)
12057  deallocate(answer_negative, check_negative, both_negative)
12058 
12059 
12060 
12061 
12062  if (err_flag) then
12063  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12064  write(*,*) ''
12065  write(*,*) ' ' // trim(abs_mes) // &
12066  & ' check' // trim(pos_str) // ' = ', wrong
12067  write(*,*) ' is NOT GREATER THAN'
12068  write(*,*) ' ' // trim(abs_mes) // &
12069  & ' answer' // trim(pos_str) // ' = ', right
12070 
12071  call abort()
12072  else
12073  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12074  end if
12075 
12076 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthandouble0()

subroutine dc_test::dctestassertgreaterthandouble0 ( character(*), intent(in)  message,
real(dp), intent(in)  answer,
real(dp), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 12082 of file dc_test.f90.

References dc_types::string, and dc_types::token.

12082  use dc_types, only: string, token
12083  implicit none
12084  character(*), intent(in):: message
12085  real(DP), intent(in):: answer
12086  real(DP), intent(in):: check
12087  logical, intent(in), optional:: negative_support
12088  logical:: err_flag
12089  logical:: negative_support_on
12090  character(STRING):: pos_str
12091  character(TOKEN):: abs_mes
12092  real(DP):: wrong, right
12093 
12094 
12095 
12096  continue
12097  if (present(negative_support)) then
12098  negative_support_on = negative_support
12099  else
12100  negative_support_on = .true.
12101  end if
12102 
12103  err_flag = .false.
12104 
12105 
12106  err_flag = .not. answer < check
12107  abs_mes = ''
12108 
12109  if ( answer < 0.0_dp &
12110  & .and. check < 0.0_dp &
12111  & .and. negative_support_on ) then
12112 
12113  err_flag = .not. err_flag
12114  abs_mes = 'ABSOLUTE value of'
12115  end if
12116 
12117  wrong = check
12118  right = answer
12119  pos_str = ''
12120 
12121 
12122 
12123 
12124  if (err_flag) then
12125  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12126  write(*,*) ''
12127  write(*,*) ' ' // trim(abs_mes) // &
12128  & ' check' // trim(pos_str) // ' = ', wrong
12129  write(*,*) ' is NOT GREATER THAN'
12130  write(*,*) ' ' // trim(abs_mes) // &
12131  & ' answer' // trim(pos_str) // ' = ', right
12132 
12133  call abort()
12134  else
12135  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12136  end if
12137 
12138 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthandouble1()

subroutine dc_test::dctestassertgreaterthandouble1 ( character(*), intent(in)  message,
real(dp), dimension(:), intent(in)  answer,
real(dp), dimension(:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 12144 of file dc_test.f90.

References dc_types::string, and dc_types::token.

12144  use dc_types, only: string, token
12145  implicit none
12146  character(*), intent(in):: message
12147  real(DP), intent(in):: answer(:)
12148  real(DP), intent(in):: check(:)
12149  logical, intent(in), optional:: negative_support
12150  logical:: err_flag
12151  logical:: negative_support_on
12152  character(STRING):: pos_str
12153  character(TOKEN):: abs_mes
12154  real(DP):: wrong, right
12155 
12156  integer:: answer_shape(1), check_shape(1), pos(1)
12157  logical:: consist_shape(1)
12158  character(TOKEN):: pos_array(1)
12159  integer, allocatable:: mask_array(:)
12160  logical, allocatable:: judge(:)
12161  logical, allocatable:: judge_rev(:)
12162  logical, allocatable:: answer_negative(:)
12163  logical, allocatable:: check_negative(:)
12164  logical, allocatable:: both_negative(:)
12165 
12166 
12167  continue
12168  if (present(negative_support)) then
12169  negative_support_on = negative_support
12170  else
12171  negative_support_on = .true.
12172  end if
12173 
12174  err_flag = .false.
12175 
12176 
12177  answer_shape = shape(answer)
12178  check_shape = shape(check)
12179 
12180  consist_shape = answer_shape == check_shape
12181 
12182  if (.not. all(consist_shape)) then
12183  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12184  write(*,*) ''
12185  write(*,*) ' shape of check is (', check_shape, ')'
12186  write(*,*) ' is INCORRECT'
12187  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
12188 
12189  call abort()
12190  end if
12191 
12192 
12193  allocate( mask_array( &
12194 
12195  & answer_shape(1) ) &
12196  & )
12197 
12198  allocate( judge( &
12199 
12200  & answer_shape(1) ) &
12201  & )
12202 
12203  allocate( judge_rev( &
12204 
12205  & answer_shape(1) ) &
12206  & )
12207 
12208  allocate( answer_negative( &
12209 
12210  & answer_shape(1) ) &
12211  & )
12212 
12213  allocate( check_negative( &
12214 
12215  & answer_shape(1) ) &
12216  & )
12217 
12218  allocate( both_negative( &
12219 
12220  & answer_shape(1) ) &
12221  & )
12222 
12223  answer_negative = answer < 0.0_dp
12224  check_negative = check < 0.0_dp
12225  both_negative = answer_negative .and. check_negative
12226  if (.not. negative_support_on) both_negative = .false.
12227 
12228  judge = answer < check
12229  where (both_negative) judge = .not. judge
12230 
12231  judge_rev = .not. judge
12232  err_flag = any(judge_rev)
12233  mask_array = 1
12234  pos = maxloc(mask_array, judge_rev)
12235 
12236  if (err_flag) then
12237 
12238  wrong = check( &
12239 
12240  & pos(1) )
12241 
12242  right = answer( &
12243 
12244  & pos(1) )
12245 
12246  write(unit=pos_array(1), fmt="(i20)") pos(1)
12247 
12248 
12249  pos_str = '(' // &
12250 
12251  & trim(adjustl(pos_array(1))) // ')'
12252 
12253  if ( both_negative( &
12254 
12255  & pos(1) ) ) then
12256 
12257  abs_mes = 'ABSOLUTE value of'
12258  else
12259  abs_mes = ''
12260 
12261  end if
12262 
12263  end if
12264  deallocate(mask_array, judge, judge_rev)
12265  deallocate(answer_negative, check_negative, both_negative)
12266 
12267 
12268 
12269 
12270  if (err_flag) then
12271  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12272  write(*,*) ''
12273  write(*,*) ' ' // trim(abs_mes) // &
12274  & ' check' // trim(pos_str) // ' = ', wrong
12275  write(*,*) ' is NOT GREATER THAN'
12276  write(*,*) ' ' // trim(abs_mes) // &
12277  & ' answer' // trim(pos_str) // ' = ', right
12278 
12279  call abort()
12280  else
12281  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12282  end if
12283 
12284 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthandouble2()

subroutine dc_test::dctestassertgreaterthandouble2 ( character(*), intent(in)  message,
real(dp), dimension(:,:), intent(in)  answer,
real(dp), dimension(:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 12290 of file dc_test.f90.

References dc_types::string, and dc_types::token.

12290  use dc_types, only: string, token
12291  implicit none
12292  character(*), intent(in):: message
12293  real(DP), intent(in):: answer(:,:)
12294  real(DP), intent(in):: check(:,:)
12295  logical, intent(in), optional:: negative_support
12296  logical:: err_flag
12297  logical:: negative_support_on
12298  character(STRING):: pos_str
12299  character(TOKEN):: abs_mes
12300  real(DP):: wrong, right
12301 
12302  integer:: answer_shape(2), check_shape(2), pos(2)
12303  logical:: consist_shape(2)
12304  character(TOKEN):: pos_array(2)
12305  integer, allocatable:: mask_array(:,:)
12306  logical, allocatable:: judge(:,:)
12307  logical, allocatable:: judge_rev(:,:)
12308  logical, allocatable:: answer_negative(:,:)
12309  logical, allocatable:: check_negative(:,:)
12310  logical, allocatable:: both_negative(:,:)
12311 
12312 
12313  continue
12314  if (present(negative_support)) then
12315  negative_support_on = negative_support
12316  else
12317  negative_support_on = .true.
12318  end if
12319 
12320  err_flag = .false.
12321 
12322 
12323  answer_shape = shape(answer)
12324  check_shape = shape(check)
12325 
12326  consist_shape = answer_shape == check_shape
12327 
12328  if (.not. all(consist_shape)) then
12329  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12330  write(*,*) ''
12331  write(*,*) ' shape of check is (', check_shape, ')'
12332  write(*,*) ' is INCORRECT'
12333  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
12334 
12335  call abort()
12336  end if
12337 
12338 
12339  allocate( mask_array( &
12340  & answer_shape(1), &
12341 
12342  & answer_shape(2) ) &
12343  & )
12344 
12345  allocate( judge( &
12346  & answer_shape(1), &
12347 
12348  & answer_shape(2) ) &
12349  & )
12350 
12351  allocate( judge_rev( &
12352  & answer_shape(1), &
12353 
12354  & answer_shape(2) ) &
12355  & )
12356 
12357  allocate( answer_negative( &
12358  & answer_shape(1), &
12359 
12360  & answer_shape(2) ) &
12361  & )
12362 
12363  allocate( check_negative( &
12364  & answer_shape(1), &
12365 
12366  & answer_shape(2) ) &
12367  & )
12368 
12369  allocate( both_negative( &
12370  & answer_shape(1), &
12371 
12372  & answer_shape(2) ) &
12373  & )
12374 
12375  answer_negative = answer < 0.0_dp
12376  check_negative = check < 0.0_dp
12377  both_negative = answer_negative .and. check_negative
12378  if (.not. negative_support_on) both_negative = .false.
12379 
12380  judge = answer < check
12381  where (both_negative) judge = .not. judge
12382 
12383  judge_rev = .not. judge
12384  err_flag = any(judge_rev)
12385  mask_array = 1
12386  pos = maxloc(mask_array, judge_rev)
12387 
12388  if (err_flag) then
12389 
12390  wrong = check( &
12391  & pos(1), &
12392 
12393  & pos(2) )
12394 
12395  right = answer( &
12396  & pos(1), &
12397 
12398  & pos(2) )
12399 
12400  write(unit=pos_array(1), fmt="(i20)") pos(1)
12401 
12402  write(unit=pos_array(2), fmt="(i20)") pos(2)
12403 
12404 
12405  pos_str = '(' // &
12406  & trim(adjustl(pos_array(1))) // ',' // &
12407 
12408  & trim(adjustl(pos_array(2))) // ')'
12409 
12410  if ( both_negative( &
12411  & pos(1), &
12412 
12413  & pos(2) ) ) then
12414 
12415  abs_mes = 'ABSOLUTE value of'
12416  else
12417  abs_mes = ''
12418 
12419  end if
12420 
12421  end if
12422  deallocate(mask_array, judge, judge_rev)
12423  deallocate(answer_negative, check_negative, both_negative)
12424 
12425 
12426 
12427 
12428  if (err_flag) then
12429  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12430  write(*,*) ''
12431  write(*,*) ' ' // trim(abs_mes) // &
12432  & ' check' // trim(pos_str) // ' = ', wrong
12433  write(*,*) ' is NOT GREATER THAN'
12434  write(*,*) ' ' // trim(abs_mes) // &
12435  & ' answer' // trim(pos_str) // ' = ', right
12436 
12437  call abort()
12438  else
12439  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12440  end if
12441 
12442 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthandouble3()

subroutine dc_test::dctestassertgreaterthandouble3 ( character(*), intent(in)  message,
real(dp), dimension(:,:,:), intent(in)  answer,
real(dp), dimension(:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 12448 of file dc_test.f90.

References dc_types::string, and dc_types::token.

12448  use dc_types, only: string, token
12449  implicit none
12450  character(*), intent(in):: message
12451  real(DP), intent(in):: answer(:,:,:)
12452  real(DP), intent(in):: check(:,:,:)
12453  logical, intent(in), optional:: negative_support
12454  logical:: err_flag
12455  logical:: negative_support_on
12456  character(STRING):: pos_str
12457  character(TOKEN):: abs_mes
12458  real(DP):: wrong, right
12459 
12460  integer:: answer_shape(3), check_shape(3), pos(3)
12461  logical:: consist_shape(3)
12462  character(TOKEN):: pos_array(3)
12463  integer, allocatable:: mask_array(:,:,:)
12464  logical, allocatable:: judge(:,:,:)
12465  logical, allocatable:: judge_rev(:,:,:)
12466  logical, allocatable:: answer_negative(:,:,:)
12467  logical, allocatable:: check_negative(:,:,:)
12468  logical, allocatable:: both_negative(:,:,:)
12469 
12470 
12471  continue
12472  if (present(negative_support)) then
12473  negative_support_on = negative_support
12474  else
12475  negative_support_on = .true.
12476  end if
12477 
12478  err_flag = .false.
12479 
12480 
12481  answer_shape = shape(answer)
12482  check_shape = shape(check)
12483 
12484  consist_shape = answer_shape == check_shape
12485 
12486  if (.not. all(consist_shape)) then
12487  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12488  write(*,*) ''
12489  write(*,*) ' shape of check is (', check_shape, ')'
12490  write(*,*) ' is INCORRECT'
12491  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
12492 
12493  call abort()
12494  end if
12495 
12496 
12497  allocate( mask_array( &
12498  & answer_shape(1), &
12499 
12500  & answer_shape(2), &
12501 
12502  & answer_shape(3) ) &
12503  & )
12504 
12505  allocate( judge( &
12506  & answer_shape(1), &
12507 
12508  & answer_shape(2), &
12509 
12510  & answer_shape(3) ) &
12511  & )
12512 
12513  allocate( judge_rev( &
12514  & answer_shape(1), &
12515 
12516  & answer_shape(2), &
12517 
12518  & answer_shape(3) ) &
12519  & )
12520 
12521  allocate( answer_negative( &
12522  & answer_shape(1), &
12523 
12524  & answer_shape(2), &
12525 
12526  & answer_shape(3) ) &
12527  & )
12528 
12529  allocate( check_negative( &
12530  & answer_shape(1), &
12531 
12532  & answer_shape(2), &
12533 
12534  & answer_shape(3) ) &
12535  & )
12536 
12537  allocate( both_negative( &
12538  & answer_shape(1), &
12539 
12540  & answer_shape(2), &
12541 
12542  & answer_shape(3) ) &
12543  & )
12544 
12545  answer_negative = answer < 0.0_dp
12546  check_negative = check < 0.0_dp
12547  both_negative = answer_negative .and. check_negative
12548  if (.not. negative_support_on) both_negative = .false.
12549 
12550  judge = answer < check
12551  where (both_negative) judge = .not. judge
12552 
12553  judge_rev = .not. judge
12554  err_flag = any(judge_rev)
12555  mask_array = 1
12556  pos = maxloc(mask_array, judge_rev)
12557 
12558  if (err_flag) then
12559 
12560  wrong = check( &
12561  & pos(1), &
12562 
12563  & pos(2), &
12564 
12565  & pos(3) )
12566 
12567  right = answer( &
12568  & pos(1), &
12569 
12570  & pos(2), &
12571 
12572  & pos(3) )
12573 
12574  write(unit=pos_array(1), fmt="(i20)") pos(1)
12575 
12576  write(unit=pos_array(2), fmt="(i20)") pos(2)
12577 
12578  write(unit=pos_array(3), fmt="(i20)") pos(3)
12579 
12580 
12581  pos_str = '(' // &
12582  & trim(adjustl(pos_array(1))) // ',' // &
12583 
12584  & trim(adjustl(pos_array(2))) // ',' // &
12585 
12586  & trim(adjustl(pos_array(3))) // ')'
12587 
12588  if ( both_negative( &
12589  & pos(1), &
12590 
12591  & pos(2), &
12592 
12593  & pos(3) ) ) then
12594 
12595  abs_mes = 'ABSOLUTE value of'
12596  else
12597  abs_mes = ''
12598 
12599  end if
12600 
12601  end if
12602  deallocate(mask_array, judge, judge_rev)
12603  deallocate(answer_negative, check_negative, both_negative)
12604 
12605 
12606 
12607 
12608  if (err_flag) then
12609  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12610  write(*,*) ''
12611  write(*,*) ' ' // trim(abs_mes) // &
12612  & ' check' // trim(pos_str) // ' = ', wrong
12613  write(*,*) ' is NOT GREATER THAN'
12614  write(*,*) ' ' // trim(abs_mes) // &
12615  & ' answer' // trim(pos_str) // ' = ', right
12616 
12617  call abort()
12618  else
12619  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12620  end if
12621 
12622 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthandouble4()

subroutine dc_test::dctestassertgreaterthandouble4 ( character(*), intent(in)  message,
real(dp), dimension(:,:,:,:), intent(in)  answer,
real(dp), dimension(:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 12628 of file dc_test.f90.

References dc_types::string, and dc_types::token.

12628  use dc_types, only: string, token
12629  implicit none
12630  character(*), intent(in):: message
12631  real(DP), intent(in):: answer(:,:,:,:)
12632  real(DP), intent(in):: check(:,:,:,:)
12633  logical, intent(in), optional:: negative_support
12634  logical:: err_flag
12635  logical:: negative_support_on
12636  character(STRING):: pos_str
12637  character(TOKEN):: abs_mes
12638  real(DP):: wrong, right
12639 
12640  integer:: answer_shape(4), check_shape(4), pos(4)
12641  logical:: consist_shape(4)
12642  character(TOKEN):: pos_array(4)
12643  integer, allocatable:: mask_array(:,:,:,:)
12644  logical, allocatable:: judge(:,:,:,:)
12645  logical, allocatable:: judge_rev(:,:,:,:)
12646  logical, allocatable:: answer_negative(:,:,:,:)
12647  logical, allocatable:: check_negative(:,:,:,:)
12648  logical, allocatable:: both_negative(:,:,:,:)
12649 
12650 
12651  continue
12652  if (present(negative_support)) then
12653  negative_support_on = negative_support
12654  else
12655  negative_support_on = .true.
12656  end if
12657 
12658  err_flag = .false.
12659 
12660 
12661  answer_shape = shape(answer)
12662  check_shape = shape(check)
12663 
12664  consist_shape = answer_shape == check_shape
12665 
12666  if (.not. all(consist_shape)) then
12667  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12668  write(*,*) ''
12669  write(*,*) ' shape of check is (', check_shape, ')'
12670  write(*,*) ' is INCORRECT'
12671  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
12672 
12673  call abort()
12674  end if
12675 
12676 
12677  allocate( mask_array( &
12678  & answer_shape(1), &
12679 
12680  & answer_shape(2), &
12681 
12682  & answer_shape(3), &
12683 
12684  & answer_shape(4) ) &
12685  & )
12686 
12687  allocate( judge( &
12688  & answer_shape(1), &
12689 
12690  & answer_shape(2), &
12691 
12692  & answer_shape(3), &
12693 
12694  & answer_shape(4) ) &
12695  & )
12696 
12697  allocate( judge_rev( &
12698  & answer_shape(1), &
12699 
12700  & answer_shape(2), &
12701 
12702  & answer_shape(3), &
12703 
12704  & answer_shape(4) ) &
12705  & )
12706 
12707  allocate( answer_negative( &
12708  & answer_shape(1), &
12709 
12710  & answer_shape(2), &
12711 
12712  & answer_shape(3), &
12713 
12714  & answer_shape(4) ) &
12715  & )
12716 
12717  allocate( check_negative( &
12718  & answer_shape(1), &
12719 
12720  & answer_shape(2), &
12721 
12722  & answer_shape(3), &
12723 
12724  & answer_shape(4) ) &
12725  & )
12726 
12727  allocate( both_negative( &
12728  & answer_shape(1), &
12729 
12730  & answer_shape(2), &
12731 
12732  & answer_shape(3), &
12733 
12734  & answer_shape(4) ) &
12735  & )
12736 
12737  answer_negative = answer < 0.0_dp
12738  check_negative = check < 0.0_dp
12739  both_negative = answer_negative .and. check_negative
12740  if (.not. negative_support_on) both_negative = .false.
12741 
12742  judge = answer < check
12743  where (both_negative) judge = .not. judge
12744 
12745  judge_rev = .not. judge
12746  err_flag = any(judge_rev)
12747  mask_array = 1
12748  pos = maxloc(mask_array, judge_rev)
12749 
12750  if (err_flag) then
12751 
12752  wrong = check( &
12753  & pos(1), &
12754 
12755  & pos(2), &
12756 
12757  & pos(3), &
12758 
12759  & pos(4) )
12760 
12761  right = answer( &
12762  & pos(1), &
12763 
12764  & pos(2), &
12765 
12766  & pos(3), &
12767 
12768  & pos(4) )
12769 
12770  write(unit=pos_array(1), fmt="(i20)") pos(1)
12771 
12772  write(unit=pos_array(2), fmt="(i20)") pos(2)
12773 
12774  write(unit=pos_array(3), fmt="(i20)") pos(3)
12775 
12776  write(unit=pos_array(4), fmt="(i20)") pos(4)
12777 
12778 
12779  pos_str = '(' // &
12780  & trim(adjustl(pos_array(1))) // ',' // &
12781 
12782  & trim(adjustl(pos_array(2))) // ',' // &
12783 
12784  & trim(adjustl(pos_array(3))) // ',' // &
12785 
12786  & trim(adjustl(pos_array(4))) // ')'
12787 
12788  if ( both_negative( &
12789  & pos(1), &
12790 
12791  & pos(2), &
12792 
12793  & pos(3), &
12794 
12795  & pos(4) ) ) then
12796 
12797  abs_mes = 'ABSOLUTE value of'
12798  else
12799  abs_mes = ''
12800 
12801  end if
12802 
12803  end if
12804  deallocate(mask_array, judge, judge_rev)
12805  deallocate(answer_negative, check_negative, both_negative)
12806 
12807 
12808 
12809 
12810  if (err_flag) then
12811  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12812  write(*,*) ''
12813  write(*,*) ' ' // trim(abs_mes) // &
12814  & ' check' // trim(pos_str) // ' = ', wrong
12815  write(*,*) ' is NOT GREATER THAN'
12816  write(*,*) ' ' // trim(abs_mes) // &
12817  & ' answer' // trim(pos_str) // ' = ', right
12818 
12819  call abort()
12820  else
12821  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
12822  end if
12823 
12824 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthandouble5()

subroutine dc_test::dctestassertgreaterthandouble5 ( character(*), intent(in)  message,
real(dp), dimension(:,:,:,:,:), intent(in)  answer,
real(dp), dimension(:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 12830 of file dc_test.f90.

References dc_types::string, and dc_types::token.

12830  use dc_types, only: string, token
12831  implicit none
12832  character(*), intent(in):: message
12833  real(DP), intent(in):: answer(:,:,:,:,:)
12834  real(DP), intent(in):: check(:,:,:,:,:)
12835  logical, intent(in), optional:: negative_support
12836  logical:: err_flag
12837  logical:: negative_support_on
12838  character(STRING):: pos_str
12839  character(TOKEN):: abs_mes
12840  real(DP):: wrong, right
12841 
12842  integer:: answer_shape(5), check_shape(5), pos(5)
12843  logical:: consist_shape(5)
12844  character(TOKEN):: pos_array(5)
12845  integer, allocatable:: mask_array(:,:,:,:,:)
12846  logical, allocatable:: judge(:,:,:,:,:)
12847  logical, allocatable:: judge_rev(:,:,:,:,:)
12848  logical, allocatable:: answer_negative(:,:,:,:,:)
12849  logical, allocatable:: check_negative(:,:,:,:,:)
12850  logical, allocatable:: both_negative(:,:,:,:,:)
12851 
12852 
12853  continue
12854  if (present(negative_support)) then
12855  negative_support_on = negative_support
12856  else
12857  negative_support_on = .true.
12858  end if
12859 
12860  err_flag = .false.
12861 
12862 
12863  answer_shape = shape(answer)
12864  check_shape = shape(check)
12865 
12866  consist_shape = answer_shape == check_shape
12867 
12868  if (.not. all(consist_shape)) then
12869  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
12870  write(*,*) ''
12871  write(*,*) ' shape of check is (', check_shape, ')'
12872  write(*,*) ' is INCORRECT'
12873  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
12874 
12875  call abort()
12876  end if
12877 
12878 
12879  allocate( mask_array( &
12880  & answer_shape(1), &
12881 
12882  & answer_shape(2), &
12883 
12884  & answer_shape(3), &
12885 
12886  & answer_shape(4), &
12887 
12888  & answer_shape(5) ) &
12889  & )
12890 
12891  allocate( judge( &
12892  & answer_shape(1), &
12893 
12894  & answer_shape(2), &
12895 
12896  & answer_shape(3), &
12897 
12898  & answer_shape(4), &
12899 
12900  & answer_shape(5) ) &
12901  & )
12902 
12903  allocate( judge_rev( &
12904  & answer_shape(1), &
12905 
12906  & answer_shape(2), &
12907 
12908  & answer_shape(3), &
12909 
12910  & answer_shape(4), &
12911 
12912  & answer_shape(5) ) &
12913  & )
12914 
12915  allocate( answer_negative( &
12916  & answer_shape(1), &
12917 
12918  & answer_shape(2), &
12919 
12920  & answer_shape(3), &
12921 
12922  & answer_shape(4), &
12923 
12924  & answer_shape(5) ) &
12925  & )
12926 
12927  allocate( check_negative( &
12928  & answer_shape(1), &
12929 
12930  & answer_shape(2), &
12931 
12932  & answer_shape(3), &
12933 
12934  & answer_shape(4), &
12935 
12936  & answer_shape(5) ) &
12937  & )
12938 
12939  allocate( both_negative( &
12940  & answer_shape(1), &
12941 
12942  & answer_shape(2), &
12943 
12944  & answer_shape(3), &
12945 
12946  & answer_shape(4), &
12947 
12948  & answer_shape(5) ) &
12949  & )
12950 
12951  answer_negative = answer < 0.0_dp
12952  check_negative = check < 0.0_dp
12953  both_negative = answer_negative .and. check_negative
12954  if (.not. negative_support_on) both_negative = .false.
12955 
12956  judge = answer < check
12957  where (both_negative) judge = .not. judge
12958 
12959  judge_rev = .not. judge
12960  err_flag = any(judge_rev)
12961  mask_array = 1
12962  pos = maxloc(mask_array, judge_rev)
12963 
12964  if (err_flag) then
12965 
12966  wrong = check( &
12967  & pos(1), &
12968 
12969  & pos(2), &
12970 
12971  & pos(3), &
12972 
12973  & pos(4), &
12974 
12975  & pos(5) )
12976 
12977  right = answer( &
12978  & pos(1), &
12979 
12980  & pos(2), &
12981 
12982  & pos(3), &
12983 
12984  & pos(4), &
12985 
12986  & pos(5) )
12987 
12988  write(unit=pos_array(1), fmt="(i20)") pos(1)
12989 
12990  write(unit=pos_array(2), fmt="(i20)") pos(2)
12991 
12992  write(unit=pos_array(3), fmt="(i20)") pos(3)
12993 
12994  write(unit=pos_array(4), fmt="(i20)") pos(4)
12995 
12996  write(unit=pos_array(5), fmt="(i20)") pos(5)
12997 
12998 
12999  pos_str = '(' // &
13000  & trim(adjustl(pos_array(1))) // ',' // &
13001 
13002  & trim(adjustl(pos_array(2))) // ',' // &
13003 
13004  & trim(adjustl(pos_array(3))) // ',' // &
13005 
13006  & trim(adjustl(pos_array(4))) // ',' // &
13007 
13008  & trim(adjustl(pos_array(5))) // ')'
13009 
13010  if ( both_negative( &
13011  & pos(1), &
13012 
13013  & pos(2), &
13014 
13015  & pos(3), &
13016 
13017  & pos(4), &
13018 
13019  & pos(5) ) ) then
13020 
13021  abs_mes = 'ABSOLUTE value of'
13022  else
13023  abs_mes = ''
13024 
13025  end if
13026 
13027  end if
13028  deallocate(mask_array, judge, judge_rev)
13029  deallocate(answer_negative, check_negative, both_negative)
13030 
13031 
13032 
13033 
13034  if (err_flag) then
13035  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
13036  write(*,*) ''
13037  write(*,*) ' ' // trim(abs_mes) // &
13038  & ' check' // trim(pos_str) // ' = ', wrong
13039  write(*,*) ' is NOT GREATER THAN'
13040  write(*,*) ' ' // trim(abs_mes) // &
13041  & ' answer' // trim(pos_str) // ' = ', right
13042 
13043  call abort()
13044  else
13045  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
13046  end if
13047 
13048 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthandouble6()

subroutine dc_test::dctestassertgreaterthandouble6 ( character(*), intent(in)  message,
real(dp), dimension(:,:,:,:,:,:), intent(in)  answer,
real(dp), dimension(:,:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 13054 of file dc_test.f90.

References dc_types::string, and dc_types::token.

13054  use dc_types, only: string, token
13055  implicit none
13056  character(*), intent(in):: message
13057  real(DP), intent(in):: answer(:,:,:,:,:,:)
13058  real(DP), intent(in):: check(:,:,:,:,:,:)
13059  logical, intent(in), optional:: negative_support
13060  logical:: err_flag
13061  logical:: negative_support_on
13062  character(STRING):: pos_str
13063  character(TOKEN):: abs_mes
13064  real(DP):: wrong, right
13065 
13066  integer:: answer_shape(6), check_shape(6), pos(6)
13067  logical:: consist_shape(6)
13068  character(TOKEN):: pos_array(6)
13069  integer, allocatable:: mask_array(:,:,:,:,:,:)
13070  logical, allocatable:: judge(:,:,:,:,:,:)
13071  logical, allocatable:: judge_rev(:,:,:,:,:,:)
13072  logical, allocatable:: answer_negative(:,:,:,:,:,:)
13073  logical, allocatable:: check_negative(:,:,:,:,:,:)
13074  logical, allocatable:: both_negative(:,:,:,:,:,:)
13075 
13076 
13077  continue
13078  if (present(negative_support)) then
13079  negative_support_on = negative_support
13080  else
13081  negative_support_on = .true.
13082  end if
13083 
13084  err_flag = .false.
13085 
13086 
13087  answer_shape = shape(answer)
13088  check_shape = shape(check)
13089 
13090  consist_shape = answer_shape == check_shape
13091 
13092  if (.not. all(consist_shape)) then
13093  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
13094  write(*,*) ''
13095  write(*,*) ' shape of check is (', check_shape, ')'
13096  write(*,*) ' is INCORRECT'
13097  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
13098 
13099  call abort()
13100  end if
13101 
13102 
13103  allocate( mask_array( &
13104  & answer_shape(1), &
13105 
13106  & answer_shape(2), &
13107 
13108  & answer_shape(3), &
13109 
13110  & answer_shape(4), &
13111 
13112  & answer_shape(5), &
13113 
13114  & answer_shape(6) ) &
13115  & )
13116 
13117  allocate( judge( &
13118  & answer_shape(1), &
13119 
13120  & answer_shape(2), &
13121 
13122  & answer_shape(3), &
13123 
13124  & answer_shape(4), &
13125 
13126  & answer_shape(5), &
13127 
13128  & answer_shape(6) ) &
13129  & )
13130 
13131  allocate( judge_rev( &
13132  & answer_shape(1), &
13133 
13134  & answer_shape(2), &
13135 
13136  & answer_shape(3), &
13137 
13138  & answer_shape(4), &
13139 
13140  & answer_shape(5), &
13141 
13142  & answer_shape(6) ) &
13143  & )
13144 
13145  allocate( answer_negative( &
13146  & answer_shape(1), &
13147 
13148  & answer_shape(2), &
13149 
13150  & answer_shape(3), &
13151 
13152  & answer_shape(4), &
13153 
13154  & answer_shape(5), &
13155 
13156  & answer_shape(6) ) &
13157  & )
13158 
13159  allocate( check_negative( &
13160  & answer_shape(1), &
13161 
13162  & answer_shape(2), &
13163 
13164  & answer_shape(3), &
13165 
13166  & answer_shape(4), &
13167 
13168  & answer_shape(5), &
13169 
13170  & answer_shape(6) ) &
13171  & )
13172 
13173  allocate( both_negative( &
13174  & answer_shape(1), &
13175 
13176  & answer_shape(2), &
13177 
13178  & answer_shape(3), &
13179 
13180  & answer_shape(4), &
13181 
13182  & answer_shape(5), &
13183 
13184  & answer_shape(6) ) &
13185  & )
13186 
13187  answer_negative = answer < 0.0_dp
13188  check_negative = check < 0.0_dp
13189  both_negative = answer_negative .and. check_negative
13190  if (.not. negative_support_on) both_negative = .false.
13191 
13192  judge = answer < check
13193  where (both_negative) judge = .not. judge
13194 
13195  judge_rev = .not. judge
13196  err_flag = any(judge_rev)
13197  mask_array = 1
13198  pos = maxloc(mask_array, judge_rev)
13199 
13200  if (err_flag) then
13201 
13202  wrong = check( &
13203  & pos(1), &
13204 
13205  & pos(2), &
13206 
13207  & pos(3), &
13208 
13209  & pos(4), &
13210 
13211  & pos(5), &
13212 
13213  & pos(6) )
13214 
13215  right = answer( &
13216  & pos(1), &
13217 
13218  & pos(2), &
13219 
13220  & pos(3), &
13221 
13222  & pos(4), &
13223 
13224  & pos(5), &
13225 
13226  & pos(6) )
13227 
13228  write(unit=pos_array(1), fmt="(i20)") pos(1)
13229 
13230  write(unit=pos_array(2), fmt="(i20)") pos(2)
13231 
13232  write(unit=pos_array(3), fmt="(i20)") pos(3)
13233 
13234  write(unit=pos_array(4), fmt="(i20)") pos(4)
13235 
13236  write(unit=pos_array(5), fmt="(i20)") pos(5)
13237 
13238  write(unit=pos_array(6), fmt="(i20)") pos(6)
13239 
13240 
13241  pos_str = '(' // &
13242  & trim(adjustl(pos_array(1))) // ',' // &
13243 
13244  & trim(adjustl(pos_array(2))) // ',' // &
13245 
13246  & trim(adjustl(pos_array(3))) // ',' // &
13247 
13248  & trim(adjustl(pos_array(4))) // ',' // &
13249 
13250  & trim(adjustl(pos_array(5))) // ',' // &
13251 
13252  & trim(adjustl(pos_array(6))) // ')'
13253 
13254  if ( both_negative( &
13255  & pos(1), &
13256 
13257  & pos(2), &
13258 
13259  & pos(3), &
13260 
13261  & pos(4), &
13262 
13263  & pos(5), &
13264 
13265  & pos(6) ) ) then
13266 
13267  abs_mes = 'ABSOLUTE value of'
13268  else
13269  abs_mes = ''
13270 
13271  end if
13272 
13273  end if
13274  deallocate(mask_array, judge, judge_rev)
13275  deallocate(answer_negative, check_negative, both_negative)
13276 
13277 
13278 
13279 
13280  if (err_flag) then
13281  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
13282  write(*,*) ''
13283  write(*,*) ' ' // trim(abs_mes) // &
13284  & ' check' // trim(pos_str) // ' = ', wrong
13285  write(*,*) ' is NOT GREATER THAN'
13286  write(*,*) ' ' // trim(abs_mes) // &
13287  & ' answer' // trim(pos_str) // ' = ', right
13288 
13289  call abort()
13290  else
13291  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
13292  end if
13293 
13294 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertgreaterthandouble7()

subroutine dc_test::dctestassertgreaterthandouble7 ( character(*), intent(in)  message,
real(dp), dimension(:,:,:,:,:,:,:), intent(in)  answer,
real(dp), dimension(:,:,:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 13300 of file dc_test.f90.

References dc_types::string, and dc_types::token.

13300  use dc_types, only: string, token
13301  implicit none
13302  character(*), intent(in):: message
13303  real(DP), intent(in):: answer(:,:,:,:,:,:,:)
13304  real(DP), intent(in):: check(:,:,:,:,:,:,:)
13305  logical, intent(in), optional:: negative_support
13306  logical:: err_flag
13307  logical:: negative_support_on
13308  character(STRING):: pos_str
13309  character(TOKEN):: abs_mes
13310  real(DP):: wrong, right
13311 
13312  integer:: answer_shape(7), check_shape(7), pos(7)
13313  logical:: consist_shape(7)
13314  character(TOKEN):: pos_array(7)
13315  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
13316  logical, allocatable:: judge(:,:,:,:,:,:,:)
13317  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
13318  logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
13319  logical, allocatable:: check_negative(:,:,:,:,:,:,:)
13320  logical, allocatable:: both_negative(:,:,:,:,:,:,:)
13321 
13322 
13323  continue
13324  if (present(negative_support)) then
13325  negative_support_on = negative_support
13326  else
13327  negative_support_on = .true.
13328  end if
13329 
13330  err_flag = .false.
13331 
13332 
13333  answer_shape = shape(answer)
13334  check_shape = shape(check)
13335 
13336  consist_shape = answer_shape == check_shape
13337 
13338  if (.not. all(consist_shape)) then
13339  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
13340  write(*,*) ''
13341  write(*,*) ' shape of check is (', check_shape, ')'
13342  write(*,*) ' is INCORRECT'
13343  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
13344 
13345  call abort()
13346  end if
13347 
13348 
13349  allocate( mask_array( &
13350  & answer_shape(1), &
13351 
13352  & answer_shape(2), &
13353 
13354  & answer_shape(3), &
13355 
13356  & answer_shape(4), &
13357 
13358  & answer_shape(5), &
13359 
13360  & answer_shape(6), &
13361 
13362  & answer_shape(7) ) &
13363  & )
13364 
13365  allocate( judge( &
13366  & answer_shape(1), &
13367 
13368  & answer_shape(2), &
13369 
13370  & answer_shape(3), &
13371 
13372  & answer_shape(4), &
13373 
13374  & answer_shape(5), &
13375 
13376  & answer_shape(6), &
13377 
13378  & answer_shape(7) ) &
13379  & )
13380 
13381  allocate( judge_rev( &
13382  & answer_shape(1), &
13383 
13384  & answer_shape(2), &
13385 
13386  & answer_shape(3), &
13387 
13388  & answer_shape(4), &
13389 
13390  & answer_shape(5), &
13391 
13392  & answer_shape(6), &
13393 
13394  & answer_shape(7) ) &
13395  & )
13396 
13397  allocate( answer_negative( &
13398  & answer_shape(1), &
13399 
13400  & answer_shape(2), &
13401 
13402  & answer_shape(3), &
13403 
13404  & answer_shape(4), &
13405 
13406  & answer_shape(5), &
13407 
13408  & answer_shape(6), &
13409 
13410  & answer_shape(7) ) &
13411  & )
13412 
13413  allocate( check_negative( &
13414  & answer_shape(1), &
13415 
13416  & answer_shape(2), &
13417 
13418  & answer_shape(3), &
13419 
13420  & answer_shape(4), &
13421 
13422  & answer_shape(5), &
13423 
13424  & answer_shape(6), &
13425 
13426  & answer_shape(7) ) &
13427  & )
13428 
13429  allocate( both_negative( &
13430  & answer_shape(1), &
13431 
13432  & answer_shape(2), &
13433 
13434  & answer_shape(3), &
13435 
13436  & answer_shape(4), &
13437 
13438  & answer_shape(5), &
13439 
13440  & answer_shape(6), &
13441 
13442  & answer_shape(7) ) &
13443  & )
13444 
13445  answer_negative = answer < 0.0_dp
13446  check_negative = check < 0.0_dp
13447  both_negative = answer_negative .and. check_negative
13448  if (.not. negative_support_on) both_negative = .false.
13449 
13450  judge = answer < check
13451  where (both_negative) judge = .not. judge
13452 
13453  judge_rev = .not. judge
13454  err_flag = any(judge_rev)
13455  mask_array = 1
13456  pos = maxloc(mask_array, judge_rev)
13457 
13458  if (err_flag) then
13459 
13460  wrong = check( &
13461  & pos(1), &
13462 
13463  & pos(2), &
13464 
13465  & pos(3), &
13466 
13467  & pos(4), &
13468 
13469  & pos(5), &
13470 
13471  & pos(6), &
13472 
13473  & pos(7) )
13474 
13475  right = answer( &
13476  & pos(1), &
13477 
13478  & pos(2), &
13479 
13480  & pos(3), &
13481 
13482  & pos(4), &
13483 
13484  & pos(5), &
13485 
13486  & pos(6), &
13487 
13488  & pos(7) )
13489 
13490  write(unit=pos_array(1), fmt="(i20)") pos(1)
13491 
13492  write(unit=pos_array(2), fmt="(i20)") pos(2)
13493 
13494  write(unit=pos_array(3), fmt="(i20)") pos(3)
13495 
13496  write(unit=pos_array(4), fmt="(i20)") pos(4)
13497 
13498  write(unit=pos_array(5), fmt="(i20)") pos(5)
13499 
13500  write(unit=pos_array(6), fmt="(i20)") pos(6)
13501 
13502  write(unit=pos_array(7), fmt="(i20)") pos(7)
13503 
13504 
13505  pos_str = '(' // &
13506  & trim(adjustl(pos_array(1))) // ',' // &
13507 
13508  & trim(adjustl(pos_array(2))) // ',' // &
13509 
13510  & trim(adjustl(pos_array(3))) // ',' // &
13511 
13512  & trim(adjustl(pos_array(4))) // ',' // &
13513 
13514  & trim(adjustl(pos_array(5))) // ',' // &
13515 
13516  & trim(adjustl(pos_array(6))) // ',' // &
13517 
13518  & trim(adjustl(pos_array(7))) // ')'
13519 
13520  if ( both_negative( &
13521  & pos(1), &
13522 
13523  & pos(2), &
13524 
13525  & pos(3), &
13526 
13527  & pos(4), &
13528 
13529  & pos(5), &
13530 
13531  & pos(6), &
13532 
13533  & pos(7) ) ) then
13534 
13535  abs_mes = 'ABSOLUTE value of'
13536  else
13537  abs_mes = ''
13538 
13539  end if
13540 
13541  end if
13542  deallocate(mask_array, judge, judge_rev)
13543  deallocate(answer_negative, check_negative, both_negative)
13544 
13545 
13546 
13547 
13548  if (err_flag) then
13549  write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
13550  write(*,*) ''
13551  write(*,*) ' ' // trim(abs_mes) // &
13552  & ' check' // trim(pos_str) // ' = ', wrong
13553  write(*,*) ' is NOT GREATER THAN'
13554  write(*,*) ' ' // trim(abs_mes) // &
13555  & ' answer' // trim(pos_str) // ' = ', right
13556 
13557  call abort()
13558  else
13559  write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
13560  end if
13561 
13562 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthanint0()

subroutine dc_test::dctestassertlessthanint0 ( character(*), intent(in)  message,
integer, intent(in)  answer,
integer, intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 13568 of file dc_test.f90.

References dc_types::string, and dc_types::token.

13568  use dc_types, only: string, token
13569  implicit none
13570  character(*), intent(in):: message
13571  integer, intent(in):: answer
13572  integer, intent(in):: check
13573  logical, intent(in), optional:: negative_support
13574  logical:: err_flag
13575  logical:: negative_support_on
13576  character(STRING):: pos_str
13577  character(TOKEN):: abs_mes
13578  integer:: wrong, right
13579 
13580 
13581 
13582  continue
13583  if (present(negative_support)) then
13584  negative_support_on = negative_support
13585  else
13586  negative_support_on = .true.
13587  end if
13588 
13589  err_flag = .false.
13590 
13591 
13592 
13593 
13594  err_flag = .not. answer > check
13595  abs_mes = ''
13596 
13597  if ( answer < 0 &
13598  & .and. check < 0 &
13599  & .and. negative_support_on ) then
13600 
13601  err_flag = .not. err_flag
13602  abs_mes = 'ABSOLUTE value of'
13603  end if
13604 
13605  wrong = check
13606  right = answer
13607  pos_str = ''
13608 
13609 
13610 
13611 
13612  if (err_flag) then
13613  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13614  write(*,*) ''
13615  write(*,*) ' ' // trim(abs_mes) // &
13616  & ' check' // trim(pos_str) // ' = ', wrong
13617  write(*,*) ' is NOT LESS THAN'
13618  write(*,*) ' ' // trim(abs_mes) // &
13619  & ' answer' // trim(pos_str) // ' = ', right
13620 
13621  call abort()
13622  else
13623  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
13624  end if
13625 
13626 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthanint1()

subroutine dc_test::dctestassertlessthanint1 ( character(*), intent(in)  message,
integer, dimension(:), intent(in)  answer,
integer, dimension(:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 13632 of file dc_test.f90.

References dc_types::string, and dc_types::token.

13632  use dc_types, only: string, token
13633  implicit none
13634  character(*), intent(in):: message
13635  integer, intent(in):: answer(:)
13636  integer, intent(in):: check(:)
13637  logical, intent(in), optional:: negative_support
13638  logical:: err_flag
13639  logical:: negative_support_on
13640  character(STRING):: pos_str
13641  character(TOKEN):: abs_mes
13642  integer:: wrong, right
13643 
13644  integer:: answer_shape(1), check_shape(1), pos(1)
13645  logical:: consist_shape(1)
13646  character(TOKEN):: pos_array(1)
13647  integer, allocatable:: mask_array(:)
13648  logical, allocatable:: judge(:)
13649  logical, allocatable:: judge_rev(:)
13650  logical, allocatable:: answer_negative(:)
13651  logical, allocatable:: check_negative(:)
13652  logical, allocatable:: both_negative(:)
13653 
13654 
13655  continue
13656  if (present(negative_support)) then
13657  negative_support_on = negative_support
13658  else
13659  negative_support_on = .true.
13660  end if
13661 
13662  err_flag = .false.
13663 
13664 
13665  answer_shape = shape(answer)
13666  check_shape = shape(check)
13667 
13668  consist_shape = answer_shape == check_shape
13669 
13670  if (.not. all(consist_shape)) then
13671  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13672  write(*,*) ''
13673  write(*,*) ' shape of check is (', check_shape, ')'
13674  write(*,*) ' is INCORRECT'
13675  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
13676 
13677  call abort()
13678  end if
13679 
13680 
13681  allocate( mask_array( &
13682 
13683  & answer_shape(1) ) &
13684  & )
13685 
13686  allocate( judge( &
13687 
13688  & answer_shape(1) ) &
13689  & )
13690 
13691  allocate( judge_rev( &
13692 
13693  & answer_shape(1) ) &
13694  & )
13695 
13696  allocate( answer_negative( &
13697 
13698  & answer_shape(1) ) &
13699  & )
13700 
13701  allocate( check_negative( &
13702 
13703  & answer_shape(1) ) &
13704  & )
13705 
13706  allocate( both_negative( &
13707 
13708  & answer_shape(1) ) &
13709  & )
13710 
13711  answer_negative = answer < 0
13712  check_negative = check < 0
13713  both_negative = answer_negative .and. check_negative
13714  if (.not. negative_support_on) both_negative = .false.
13715 
13716  judge = answer > check
13717  where (both_negative) judge = .not. judge
13718 
13719  judge_rev = .not. judge
13720  err_flag = any(judge_rev)
13721  mask_array = 1
13722  pos = maxloc(mask_array, judge_rev)
13723 
13724  if (err_flag) then
13725 
13726  wrong = check( &
13727 
13728  & pos(1) )
13729 
13730  right = answer( &
13731 
13732  & pos(1) )
13733 
13734  write(unit=pos_array(1), fmt="(i20)") pos(1)
13735 
13736 
13737  pos_str = '(' // &
13738 
13739  & trim(adjustl(pos_array(1))) // ')'
13740 
13741  if ( both_negative( &
13742 
13743  & pos(1) ) ) then
13744 
13745  abs_mes = 'ABSOLUTE value of'
13746  else
13747  abs_mes = ''
13748 
13749  end if
13750 
13751  end if
13752  deallocate(mask_array, judge, judge_rev)
13753  deallocate(answer_negative, check_negative, both_negative)
13754 
13755 
13756 
13757 
13758  if (err_flag) then
13759  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13760  write(*,*) ''
13761  write(*,*) ' ' // trim(abs_mes) // &
13762  & ' check' // trim(pos_str) // ' = ', wrong
13763  write(*,*) ' is NOT LESS THAN'
13764  write(*,*) ' ' // trim(abs_mes) // &
13765  & ' answer' // trim(pos_str) // ' = ', right
13766 
13767  call abort()
13768  else
13769  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
13770  end if
13771 
13772 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthanint2()

subroutine dc_test::dctestassertlessthanint2 ( character(*), intent(in)  message,
integer, dimension(:,:), intent(in)  answer,
integer, dimension(:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 13778 of file dc_test.f90.

References dc_types::string, and dc_types::token.

13778  use dc_types, only: string, token
13779  implicit none
13780  character(*), intent(in):: message
13781  integer, intent(in):: answer(:,:)
13782  integer, intent(in):: check(:,:)
13783  logical, intent(in), optional:: negative_support
13784  logical:: err_flag
13785  logical:: negative_support_on
13786  character(STRING):: pos_str
13787  character(TOKEN):: abs_mes
13788  integer:: wrong, right
13789 
13790  integer:: answer_shape(2), check_shape(2), pos(2)
13791  logical:: consist_shape(2)
13792  character(TOKEN):: pos_array(2)
13793  integer, allocatable:: mask_array(:,:)
13794  logical, allocatable:: judge(:,:)
13795  logical, allocatable:: judge_rev(:,:)
13796  logical, allocatable:: answer_negative(:,:)
13797  logical, allocatable:: check_negative(:,:)
13798  logical, allocatable:: both_negative(:,:)
13799 
13800 
13801  continue
13802  if (present(negative_support)) then
13803  negative_support_on = negative_support
13804  else
13805  negative_support_on = .true.
13806  end if
13807 
13808  err_flag = .false.
13809 
13810 
13811  answer_shape = shape(answer)
13812  check_shape = shape(check)
13813 
13814  consist_shape = answer_shape == check_shape
13815 
13816  if (.not. all(consist_shape)) then
13817  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13818  write(*,*) ''
13819  write(*,*) ' shape of check is (', check_shape, ')'
13820  write(*,*) ' is INCORRECT'
13821  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
13822 
13823  call abort()
13824  end if
13825 
13826 
13827  allocate( mask_array( &
13828  & answer_shape(1), &
13829 
13830  & answer_shape(2) ) &
13831  & )
13832 
13833  allocate( judge( &
13834  & answer_shape(1), &
13835 
13836  & answer_shape(2) ) &
13837  & )
13838 
13839  allocate( judge_rev( &
13840  & answer_shape(1), &
13841 
13842  & answer_shape(2) ) &
13843  & )
13844 
13845  allocate( answer_negative( &
13846  & answer_shape(1), &
13847 
13848  & answer_shape(2) ) &
13849  & )
13850 
13851  allocate( check_negative( &
13852  & answer_shape(1), &
13853 
13854  & answer_shape(2) ) &
13855  & )
13856 
13857  allocate( both_negative( &
13858  & answer_shape(1), &
13859 
13860  & answer_shape(2) ) &
13861  & )
13862 
13863  answer_negative = answer < 0
13864  check_negative = check < 0
13865  both_negative = answer_negative .and. check_negative
13866  if (.not. negative_support_on) both_negative = .false.
13867 
13868  judge = answer > check
13869  where (both_negative) judge = .not. judge
13870 
13871  judge_rev = .not. judge
13872  err_flag = any(judge_rev)
13873  mask_array = 1
13874  pos = maxloc(mask_array, judge_rev)
13875 
13876  if (err_flag) then
13877 
13878  wrong = check( &
13879  & pos(1), &
13880 
13881  & pos(2) )
13882 
13883  right = answer( &
13884  & pos(1), &
13885 
13886  & pos(2) )
13887 
13888  write(unit=pos_array(1), fmt="(i20)") pos(1)
13889 
13890  write(unit=pos_array(2), fmt="(i20)") pos(2)
13891 
13892 
13893  pos_str = '(' // &
13894  & trim(adjustl(pos_array(1))) // ',' // &
13895 
13896  & trim(adjustl(pos_array(2))) // ')'
13897 
13898  if ( both_negative( &
13899  & pos(1), &
13900 
13901  & pos(2) ) ) then
13902 
13903  abs_mes = 'ABSOLUTE value of'
13904  else
13905  abs_mes = ''
13906 
13907  end if
13908 
13909  end if
13910  deallocate(mask_array, judge, judge_rev)
13911  deallocate(answer_negative, check_negative, both_negative)
13912 
13913 
13914 
13915 
13916  if (err_flag) then
13917  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13918  write(*,*) ''
13919  write(*,*) ' ' // trim(abs_mes) // &
13920  & ' check' // trim(pos_str) // ' = ', wrong
13921  write(*,*) ' is NOT LESS THAN'
13922  write(*,*) ' ' // trim(abs_mes) // &
13923  & ' answer' // trim(pos_str) // ' = ', right
13924 
13925  call abort()
13926  else
13927  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
13928  end if
13929 
13930 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthanint3()

subroutine dc_test::dctestassertlessthanint3 ( character(*), intent(in)  message,
integer, dimension(:,:,:), intent(in)  answer,
integer, dimension(:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 13936 of file dc_test.f90.

References dc_types::string, and dc_types::token.

13936  use dc_types, only: string, token
13937  implicit none
13938  character(*), intent(in):: message
13939  integer, intent(in):: answer(:,:,:)
13940  integer, intent(in):: check(:,:,:)
13941  logical, intent(in), optional:: negative_support
13942  logical:: err_flag
13943  logical:: negative_support_on
13944  character(STRING):: pos_str
13945  character(TOKEN):: abs_mes
13946  integer:: wrong, right
13947 
13948  integer:: answer_shape(3), check_shape(3), pos(3)
13949  logical:: consist_shape(3)
13950  character(TOKEN):: pos_array(3)
13951  integer, allocatable:: mask_array(:,:,:)
13952  logical, allocatable:: judge(:,:,:)
13953  logical, allocatable:: judge_rev(:,:,:)
13954  logical, allocatable:: answer_negative(:,:,:)
13955  logical, allocatable:: check_negative(:,:,:)
13956  logical, allocatable:: both_negative(:,:,:)
13957 
13958 
13959  continue
13960  if (present(negative_support)) then
13961  negative_support_on = negative_support
13962  else
13963  negative_support_on = .true.
13964  end if
13965 
13966  err_flag = .false.
13967 
13968 
13969  answer_shape = shape(answer)
13970  check_shape = shape(check)
13971 
13972  consist_shape = answer_shape == check_shape
13973 
13974  if (.not. all(consist_shape)) then
13975  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13976  write(*,*) ''
13977  write(*,*) ' shape of check is (', check_shape, ')'
13978  write(*,*) ' is INCORRECT'
13979  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
13980 
13981  call abort()
13982  end if
13983 
13984 
13985  allocate( mask_array( &
13986  & answer_shape(1), &
13987 
13988  & answer_shape(2), &
13989 
13990  & answer_shape(3) ) &
13991  & )
13992 
13993  allocate( judge( &
13994  & answer_shape(1), &
13995 
13996  & answer_shape(2), &
13997 
13998  & answer_shape(3) ) &
13999  & )
14000 
14001  allocate( judge_rev( &
14002  & answer_shape(1), &
14003 
14004  & answer_shape(2), &
14005 
14006  & answer_shape(3) ) &
14007  & )
14008 
14009  allocate( answer_negative( &
14010  & answer_shape(1), &
14011 
14012  & answer_shape(2), &
14013 
14014  & answer_shape(3) ) &
14015  & )
14016 
14017  allocate( check_negative( &
14018  & answer_shape(1), &
14019 
14020  & answer_shape(2), &
14021 
14022  & answer_shape(3) ) &
14023  & )
14024 
14025  allocate( both_negative( &
14026  & answer_shape(1), &
14027 
14028  & answer_shape(2), &
14029 
14030  & answer_shape(3) ) &
14031  & )
14032 
14033  answer_negative = answer < 0
14034  check_negative = check < 0
14035  both_negative = answer_negative .and. check_negative
14036  if (.not. negative_support_on) both_negative = .false.
14037 
14038  judge = answer > check
14039  where (both_negative) judge = .not. judge
14040 
14041  judge_rev = .not. judge
14042  err_flag = any(judge_rev)
14043  mask_array = 1
14044  pos = maxloc(mask_array, judge_rev)
14045 
14046  if (err_flag) then
14047 
14048  wrong = check( &
14049  & pos(1), &
14050 
14051  & pos(2), &
14052 
14053  & pos(3) )
14054 
14055  right = answer( &
14056  & pos(1), &
14057 
14058  & pos(2), &
14059 
14060  & pos(3) )
14061 
14062  write(unit=pos_array(1), fmt="(i20)") pos(1)
14063 
14064  write(unit=pos_array(2), fmt="(i20)") pos(2)
14065 
14066  write(unit=pos_array(3), fmt="(i20)") pos(3)
14067 
14068 
14069  pos_str = '(' // &
14070  & trim(adjustl(pos_array(1))) // ',' // &
14071 
14072  & trim(adjustl(pos_array(2))) // ',' // &
14073 
14074  & trim(adjustl(pos_array(3))) // ')'
14075 
14076  if ( both_negative( &
14077  & pos(1), &
14078 
14079  & pos(2), &
14080 
14081  & pos(3) ) ) then
14082 
14083  abs_mes = 'ABSOLUTE value of'
14084  else
14085  abs_mes = ''
14086 
14087  end if
14088 
14089  end if
14090  deallocate(mask_array, judge, judge_rev)
14091  deallocate(answer_negative, check_negative, both_negative)
14092 
14093 
14094 
14095 
14096  if (err_flag) then
14097  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14098  write(*,*) ''
14099  write(*,*) ' ' // trim(abs_mes) // &
14100  & ' check' // trim(pos_str) // ' = ', wrong
14101  write(*,*) ' is NOT LESS THAN'
14102  write(*,*) ' ' // trim(abs_mes) // &
14103  & ' answer' // trim(pos_str) // ' = ', right
14104 
14105  call abort()
14106  else
14107  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
14108  end if
14109 
14110 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthanint4()

subroutine dc_test::dctestassertlessthanint4 ( character(*), intent(in)  message,
integer, dimension(:,:,:,:), intent(in)  answer,
integer, dimension(:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 14116 of file dc_test.f90.

References dc_types::string, and dc_types::token.

14116  use dc_types, only: string, token
14117  implicit none
14118  character(*), intent(in):: message
14119  integer, intent(in):: answer(:,:,:,:)
14120  integer, intent(in):: check(:,:,:,:)
14121  logical, intent(in), optional:: negative_support
14122  logical:: err_flag
14123  logical:: negative_support_on
14124  character(STRING):: pos_str
14125  character(TOKEN):: abs_mes
14126  integer:: wrong, right
14127 
14128  integer:: answer_shape(4), check_shape(4), pos(4)
14129  logical:: consist_shape(4)
14130  character(TOKEN):: pos_array(4)
14131  integer, allocatable:: mask_array(:,:,:,:)
14132  logical, allocatable:: judge(:,:,:,:)
14133  logical, allocatable:: judge_rev(:,:,:,:)
14134  logical, allocatable:: answer_negative(:,:,:,:)
14135  logical, allocatable:: check_negative(:,:,:,:)
14136  logical, allocatable:: both_negative(:,:,:,:)
14137 
14138 
14139  continue
14140  if (present(negative_support)) then
14141  negative_support_on = negative_support
14142  else
14143  negative_support_on = .true.
14144  end if
14145 
14146  err_flag = .false.
14147 
14148 
14149  answer_shape = shape(answer)
14150  check_shape = shape(check)
14151 
14152  consist_shape = answer_shape == check_shape
14153 
14154  if (.not. all(consist_shape)) then
14155  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14156  write(*,*) ''
14157  write(*,*) ' shape of check is (', check_shape, ')'
14158  write(*,*) ' is INCORRECT'
14159  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
14160 
14161  call abort()
14162  end if
14163 
14164 
14165  allocate( mask_array( &
14166  & answer_shape(1), &
14167 
14168  & answer_shape(2), &
14169 
14170  & answer_shape(3), &
14171 
14172  & answer_shape(4) ) &
14173  & )
14174 
14175  allocate( judge( &
14176  & answer_shape(1), &
14177 
14178  & answer_shape(2), &
14179 
14180  & answer_shape(3), &
14181 
14182  & answer_shape(4) ) &
14183  & )
14184 
14185  allocate( judge_rev( &
14186  & answer_shape(1), &
14187 
14188  & answer_shape(2), &
14189 
14190  & answer_shape(3), &
14191 
14192  & answer_shape(4) ) &
14193  & )
14194 
14195  allocate( answer_negative( &
14196  & answer_shape(1), &
14197 
14198  & answer_shape(2), &
14199 
14200  & answer_shape(3), &
14201 
14202  & answer_shape(4) ) &
14203  & )
14204 
14205  allocate( check_negative( &
14206  & answer_shape(1), &
14207 
14208  & answer_shape(2), &
14209 
14210  & answer_shape(3), &
14211 
14212  & answer_shape(4) ) &
14213  & )
14214 
14215  allocate( both_negative( &
14216  & answer_shape(1), &
14217 
14218  & answer_shape(2), &
14219 
14220  & answer_shape(3), &
14221 
14222  & answer_shape(4) ) &
14223  & )
14224 
14225  answer_negative = answer < 0
14226  check_negative = check < 0
14227  both_negative = answer_negative .and. check_negative
14228  if (.not. negative_support_on) both_negative = .false.
14229 
14230  judge = answer > check
14231  where (both_negative) judge = .not. judge
14232 
14233  judge_rev = .not. judge
14234  err_flag = any(judge_rev)
14235  mask_array = 1
14236  pos = maxloc(mask_array, judge_rev)
14237 
14238  if (err_flag) then
14239 
14240  wrong = check( &
14241  & pos(1), &
14242 
14243  & pos(2), &
14244 
14245  & pos(3), &
14246 
14247  & pos(4) )
14248 
14249  right = answer( &
14250  & pos(1), &
14251 
14252  & pos(2), &
14253 
14254  & pos(3), &
14255 
14256  & pos(4) )
14257 
14258  write(unit=pos_array(1), fmt="(i20)") pos(1)
14259 
14260  write(unit=pos_array(2), fmt="(i20)") pos(2)
14261 
14262  write(unit=pos_array(3), fmt="(i20)") pos(3)
14263 
14264  write(unit=pos_array(4), fmt="(i20)") pos(4)
14265 
14266 
14267  pos_str = '(' // &
14268  & trim(adjustl(pos_array(1))) // ',' // &
14269 
14270  & trim(adjustl(pos_array(2))) // ',' // &
14271 
14272  & trim(adjustl(pos_array(3))) // ',' // &
14273 
14274  & trim(adjustl(pos_array(4))) // ')'
14275 
14276  if ( both_negative( &
14277  & pos(1), &
14278 
14279  & pos(2), &
14280 
14281  & pos(3), &
14282 
14283  & pos(4) ) ) then
14284 
14285  abs_mes = 'ABSOLUTE value of'
14286  else
14287  abs_mes = ''
14288 
14289  end if
14290 
14291  end if
14292  deallocate(mask_array, judge, judge_rev)
14293  deallocate(answer_negative, check_negative, both_negative)
14294 
14295 
14296 
14297 
14298  if (err_flag) then
14299  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14300  write(*,*) ''
14301  write(*,*) ' ' // trim(abs_mes) // &
14302  & ' check' // trim(pos_str) // ' = ', wrong
14303  write(*,*) ' is NOT LESS THAN'
14304  write(*,*) ' ' // trim(abs_mes) // &
14305  & ' answer' // trim(pos_str) // ' = ', right
14306 
14307  call abort()
14308  else
14309  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
14310  end if
14311 
14312 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthanint5()

subroutine dc_test::dctestassertlessthanint5 ( character(*), intent(in)  message,
integer, dimension(:,:,:,:,:), intent(in)  answer,
integer, dimension(:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 14318 of file dc_test.f90.

References dc_types::string, and dc_types::token.

14318  use dc_types, only: string, token
14319  implicit none
14320  character(*), intent(in):: message
14321  integer, intent(in):: answer(:,:,:,:,:)
14322  integer, intent(in):: check(:,:,:,:,:)
14323  logical, intent(in), optional:: negative_support
14324  logical:: err_flag
14325  logical:: negative_support_on
14326  character(STRING):: pos_str
14327  character(TOKEN):: abs_mes
14328  integer:: wrong, right
14329 
14330  integer:: answer_shape(5), check_shape(5), pos(5)
14331  logical:: consist_shape(5)
14332  character(TOKEN):: pos_array(5)
14333  integer, allocatable:: mask_array(:,:,:,:,:)
14334  logical, allocatable:: judge(:,:,:,:,:)
14335  logical, allocatable:: judge_rev(:,:,:,:,:)
14336  logical, allocatable:: answer_negative(:,:,:,:,:)
14337  logical, allocatable:: check_negative(:,:,:,:,:)
14338  logical, allocatable:: both_negative(:,:,:,:,:)
14339 
14340 
14341  continue
14342  if (present(negative_support)) then
14343  negative_support_on = negative_support
14344  else
14345  negative_support_on = .true.
14346  end if
14347 
14348  err_flag = .false.
14349 
14350 
14351  answer_shape = shape(answer)
14352  check_shape = shape(check)
14353 
14354  consist_shape = answer_shape == check_shape
14355 
14356  if (.not. all(consist_shape)) then
14357  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14358  write(*,*) ''
14359  write(*,*) ' shape of check is (', check_shape, ')'
14360  write(*,*) ' is INCORRECT'
14361  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
14362 
14363  call abort()
14364  end if
14365 
14366 
14367  allocate( mask_array( &
14368  & answer_shape(1), &
14369 
14370  & answer_shape(2), &
14371 
14372  & answer_shape(3), &
14373 
14374  & answer_shape(4), &
14375 
14376  & answer_shape(5) ) &
14377  & )
14378 
14379  allocate( judge( &
14380  & answer_shape(1), &
14381 
14382  & answer_shape(2), &
14383 
14384  & answer_shape(3), &
14385 
14386  & answer_shape(4), &
14387 
14388  & answer_shape(5) ) &
14389  & )
14390 
14391  allocate( judge_rev( &
14392  & answer_shape(1), &
14393 
14394  & answer_shape(2), &
14395 
14396  & answer_shape(3), &
14397 
14398  & answer_shape(4), &
14399 
14400  & answer_shape(5) ) &
14401  & )
14402 
14403  allocate( answer_negative( &
14404  & answer_shape(1), &
14405 
14406  & answer_shape(2), &
14407 
14408  & answer_shape(3), &
14409 
14410  & answer_shape(4), &
14411 
14412  & answer_shape(5) ) &
14413  & )
14414 
14415  allocate( check_negative( &
14416  & answer_shape(1), &
14417 
14418  & answer_shape(2), &
14419 
14420  & answer_shape(3), &
14421 
14422  & answer_shape(4), &
14423 
14424  & answer_shape(5) ) &
14425  & )
14426 
14427  allocate( both_negative( &
14428  & answer_shape(1), &
14429 
14430  & answer_shape(2), &
14431 
14432  & answer_shape(3), &
14433 
14434  & answer_shape(4), &
14435 
14436  & answer_shape(5) ) &
14437  & )
14438 
14439  answer_negative = answer < 0
14440  check_negative = check < 0
14441  both_negative = answer_negative .and. check_negative
14442  if (.not. negative_support_on) both_negative = .false.
14443 
14444  judge = answer > check
14445  where (both_negative) judge = .not. judge
14446 
14447  judge_rev = .not. judge
14448  err_flag = any(judge_rev)
14449  mask_array = 1
14450  pos = maxloc(mask_array, judge_rev)
14451 
14452  if (err_flag) then
14453 
14454  wrong = check( &
14455  & pos(1), &
14456 
14457  & pos(2), &
14458 
14459  & pos(3), &
14460 
14461  & pos(4), &
14462 
14463  & pos(5) )
14464 
14465  right = answer( &
14466  & pos(1), &
14467 
14468  & pos(2), &
14469 
14470  & pos(3), &
14471 
14472  & pos(4), &
14473 
14474  & pos(5) )
14475 
14476  write(unit=pos_array(1), fmt="(i20)") pos(1)
14477 
14478  write(unit=pos_array(2), fmt="(i20)") pos(2)
14479 
14480  write(unit=pos_array(3), fmt="(i20)") pos(3)
14481 
14482  write(unit=pos_array(4), fmt="(i20)") pos(4)
14483 
14484  write(unit=pos_array(5), fmt="(i20)") pos(5)
14485 
14486 
14487  pos_str = '(' // &
14488  & trim(adjustl(pos_array(1))) // ',' // &
14489 
14490  & trim(adjustl(pos_array(2))) // ',' // &
14491 
14492  & trim(adjustl(pos_array(3))) // ',' // &
14493 
14494  & trim(adjustl(pos_array(4))) // ',' // &
14495 
14496  & trim(adjustl(pos_array(5))) // ')'
14497 
14498  if ( both_negative( &
14499  & pos(1), &
14500 
14501  & pos(2), &
14502 
14503  & pos(3), &
14504 
14505  & pos(4), &
14506 
14507  & pos(5) ) ) then
14508 
14509  abs_mes = 'ABSOLUTE value of'
14510  else
14511  abs_mes = ''
14512 
14513  end if
14514 
14515  end if
14516  deallocate(mask_array, judge, judge_rev)
14517  deallocate(answer_negative, check_negative, both_negative)
14518 
14519 
14520 
14521 
14522  if (err_flag) then
14523  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14524  write(*,*) ''
14525  write(*,*) ' ' // trim(abs_mes) // &
14526  & ' check' // trim(pos_str) // ' = ', wrong
14527  write(*,*) ' is NOT LESS THAN'
14528  write(*,*) ' ' // trim(abs_mes) // &
14529  & ' answer' // trim(pos_str) // ' = ', right
14530 
14531  call abort()
14532  else
14533  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
14534  end if
14535 
14536 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthanint6()

subroutine dc_test::dctestassertlessthanint6 ( character(*), intent(in)  message,
integer, dimension(:,:,:,:,:,:), intent(in)  answer,
integer, dimension(:,:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 14542 of file dc_test.f90.

References dc_types::string, and dc_types::token.

14542  use dc_types, only: string, token
14543  implicit none
14544  character(*), intent(in):: message
14545  integer, intent(in):: answer(:,:,:,:,:,:)
14546  integer, intent(in):: check(:,:,:,:,:,:)
14547  logical, intent(in), optional:: negative_support
14548  logical:: err_flag
14549  logical:: negative_support_on
14550  character(STRING):: pos_str
14551  character(TOKEN):: abs_mes
14552  integer:: wrong, right
14553 
14554  integer:: answer_shape(6), check_shape(6), pos(6)
14555  logical:: consist_shape(6)
14556  character(TOKEN):: pos_array(6)
14557  integer, allocatable:: mask_array(:,:,:,:,:,:)
14558  logical, allocatable:: judge(:,:,:,:,:,:)
14559  logical, allocatable:: judge_rev(:,:,:,:,:,:)
14560  logical, allocatable:: answer_negative(:,:,:,:,:,:)
14561  logical, allocatable:: check_negative(:,:,:,:,:,:)
14562  logical, allocatable:: both_negative(:,:,:,:,:,:)
14563 
14564 
14565  continue
14566  if (present(negative_support)) then
14567  negative_support_on = negative_support
14568  else
14569  negative_support_on = .true.
14570  end if
14571 
14572  err_flag = .false.
14573 
14574 
14575  answer_shape = shape(answer)
14576  check_shape = shape(check)
14577 
14578  consist_shape = answer_shape == check_shape
14579 
14580  if (.not. all(consist_shape)) then
14581  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14582  write(*,*) ''
14583  write(*,*) ' shape of check is (', check_shape, ')'
14584  write(*,*) ' is INCORRECT'
14585  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
14586 
14587  call abort()
14588  end if
14589 
14590 
14591  allocate( mask_array( &
14592  & answer_shape(1), &
14593 
14594  & answer_shape(2), &
14595 
14596  & answer_shape(3), &
14597 
14598  & answer_shape(4), &
14599 
14600  & answer_shape(5), &
14601 
14602  & answer_shape(6) ) &
14603  & )
14604 
14605  allocate( judge( &
14606  & answer_shape(1), &
14607 
14608  & answer_shape(2), &
14609 
14610  & answer_shape(3), &
14611 
14612  & answer_shape(4), &
14613 
14614  & answer_shape(5), &
14615 
14616  & answer_shape(6) ) &
14617  & )
14618 
14619  allocate( judge_rev( &
14620  & answer_shape(1), &
14621 
14622  & answer_shape(2), &
14623 
14624  & answer_shape(3), &
14625 
14626  & answer_shape(4), &
14627 
14628  & answer_shape(5), &
14629 
14630  & answer_shape(6) ) &
14631  & )
14632 
14633  allocate( answer_negative( &
14634  & answer_shape(1), &
14635 
14636  & answer_shape(2), &
14637 
14638  & answer_shape(3), &
14639 
14640  & answer_shape(4), &
14641 
14642  & answer_shape(5), &
14643 
14644  & answer_shape(6) ) &
14645  & )
14646 
14647  allocate( check_negative( &
14648  & answer_shape(1), &
14649 
14650  & answer_shape(2), &
14651 
14652  & answer_shape(3), &
14653 
14654  & answer_shape(4), &
14655 
14656  & answer_shape(5), &
14657 
14658  & answer_shape(6) ) &
14659  & )
14660 
14661  allocate( both_negative( &
14662  & answer_shape(1), &
14663 
14664  & answer_shape(2), &
14665 
14666  & answer_shape(3), &
14667 
14668  & answer_shape(4), &
14669 
14670  & answer_shape(5), &
14671 
14672  & answer_shape(6) ) &
14673  & )
14674 
14675  answer_negative = answer < 0
14676  check_negative = check < 0
14677  both_negative = answer_negative .and. check_negative
14678  if (.not. negative_support_on) both_negative = .false.
14679 
14680  judge = answer > check
14681  where (both_negative) judge = .not. judge
14682 
14683  judge_rev = .not. judge
14684  err_flag = any(judge_rev)
14685  mask_array = 1
14686  pos = maxloc(mask_array, judge_rev)
14687 
14688  if (err_flag) then
14689 
14690  wrong = check( &
14691  & pos(1), &
14692 
14693  & pos(2), &
14694 
14695  & pos(3), &
14696 
14697  & pos(4), &
14698 
14699  & pos(5), &
14700 
14701  & pos(6) )
14702 
14703  right = answer( &
14704  & pos(1), &
14705 
14706  & pos(2), &
14707 
14708  & pos(3), &
14709 
14710  & pos(4), &
14711 
14712  & pos(5), &
14713 
14714  & pos(6) )
14715 
14716  write(unit=pos_array(1), fmt="(i20)") pos(1)
14717 
14718  write(unit=pos_array(2), fmt="(i20)") pos(2)
14719 
14720  write(unit=pos_array(3), fmt="(i20)") pos(3)
14721 
14722  write(unit=pos_array(4), fmt="(i20)") pos(4)
14723 
14724  write(unit=pos_array(5), fmt="(i20)") pos(5)
14725 
14726  write(unit=pos_array(6), fmt="(i20)") pos(6)
14727 
14728 
14729  pos_str = '(' // &
14730  & trim(adjustl(pos_array(1))) // ',' // &
14731 
14732  & trim(adjustl(pos_array(2))) // ',' // &
14733 
14734  & trim(adjustl(pos_array(3))) // ',' // &
14735 
14736  & trim(adjustl(pos_array(4))) // ',' // &
14737 
14738  & trim(adjustl(pos_array(5))) // ',' // &
14739 
14740  & trim(adjustl(pos_array(6))) // ')'
14741 
14742  if ( both_negative( &
14743  & pos(1), &
14744 
14745  & pos(2), &
14746 
14747  & pos(3), &
14748 
14749  & pos(4), &
14750 
14751  & pos(5), &
14752 
14753  & pos(6) ) ) then
14754 
14755  abs_mes = 'ABSOLUTE value of'
14756  else
14757  abs_mes = ''
14758 
14759  end if
14760 
14761  end if
14762  deallocate(mask_array, judge, judge_rev)
14763  deallocate(answer_negative, check_negative, both_negative)
14764 
14765 
14766 
14767 
14768  if (err_flag) then
14769  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14770  write(*,*) ''
14771  write(*,*) ' ' // trim(abs_mes) // &
14772  & ' check' // trim(pos_str) // ' = ', wrong
14773  write(*,*) ' is NOT LESS THAN'
14774  write(*,*) ' ' // trim(abs_mes) // &
14775  & ' answer' // trim(pos_str) // ' = ', right
14776 
14777  call abort()
14778  else
14779  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
14780  end if
14781 
14782 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthanint7()

subroutine dc_test::dctestassertlessthanint7 ( character(*), intent(in)  message,
integer, dimension(:,:,:,:,:,:,:), intent(in)  answer,
integer, dimension(:,:,:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 14788 of file dc_test.f90.

References dc_types::string, and dc_types::token.

14788  use dc_types, only: string, token
14789  implicit none
14790  character(*), intent(in):: message
14791  integer, intent(in):: answer(:,:,:,:,:,:,:)
14792  integer, intent(in):: check(:,:,:,:,:,:,:)
14793  logical, intent(in), optional:: negative_support
14794  logical:: err_flag
14795  logical:: negative_support_on
14796  character(STRING):: pos_str
14797  character(TOKEN):: abs_mes
14798  integer:: wrong, right
14799 
14800  integer:: answer_shape(7), check_shape(7), pos(7)
14801  logical:: consist_shape(7)
14802  character(TOKEN):: pos_array(7)
14803  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
14804  logical, allocatable:: judge(:,:,:,:,:,:,:)
14805  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
14806  logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
14807  logical, allocatable:: check_negative(:,:,:,:,:,:,:)
14808  logical, allocatable:: both_negative(:,:,:,:,:,:,:)
14809 
14810 
14811  continue
14812  if (present(negative_support)) then
14813  negative_support_on = negative_support
14814  else
14815  negative_support_on = .true.
14816  end if
14817 
14818  err_flag = .false.
14819 
14820 
14821  answer_shape = shape(answer)
14822  check_shape = shape(check)
14823 
14824  consist_shape = answer_shape == check_shape
14825 
14826  if (.not. all(consist_shape)) then
14827  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14828  write(*,*) ''
14829  write(*,*) ' shape of check is (', check_shape, ')'
14830  write(*,*) ' is INCORRECT'
14831  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
14832 
14833  call abort()
14834  end if
14835 
14836 
14837  allocate( mask_array( &
14838  & answer_shape(1), &
14839 
14840  & answer_shape(2), &
14841 
14842  & answer_shape(3), &
14843 
14844  & answer_shape(4), &
14845 
14846  & answer_shape(5), &
14847 
14848  & answer_shape(6), &
14849 
14850  & answer_shape(7) ) &
14851  & )
14852 
14853  allocate( judge( &
14854  & answer_shape(1), &
14855 
14856  & answer_shape(2), &
14857 
14858  & answer_shape(3), &
14859 
14860  & answer_shape(4), &
14861 
14862  & answer_shape(5), &
14863 
14864  & answer_shape(6), &
14865 
14866  & answer_shape(7) ) &
14867  & )
14868 
14869  allocate( judge_rev( &
14870  & answer_shape(1), &
14871 
14872  & answer_shape(2), &
14873 
14874  & answer_shape(3), &
14875 
14876  & answer_shape(4), &
14877 
14878  & answer_shape(5), &
14879 
14880  & answer_shape(6), &
14881 
14882  & answer_shape(7) ) &
14883  & )
14884 
14885  allocate( answer_negative( &
14886  & answer_shape(1), &
14887 
14888  & answer_shape(2), &
14889 
14890  & answer_shape(3), &
14891 
14892  & answer_shape(4), &
14893 
14894  & answer_shape(5), &
14895 
14896  & answer_shape(6), &
14897 
14898  & answer_shape(7) ) &
14899  & )
14900 
14901  allocate( check_negative( &
14902  & answer_shape(1), &
14903 
14904  & answer_shape(2), &
14905 
14906  & answer_shape(3), &
14907 
14908  & answer_shape(4), &
14909 
14910  & answer_shape(5), &
14911 
14912  & answer_shape(6), &
14913 
14914  & answer_shape(7) ) &
14915  & )
14916 
14917  allocate( both_negative( &
14918  & answer_shape(1), &
14919 
14920  & answer_shape(2), &
14921 
14922  & answer_shape(3), &
14923 
14924  & answer_shape(4), &
14925 
14926  & answer_shape(5), &
14927 
14928  & answer_shape(6), &
14929 
14930  & answer_shape(7) ) &
14931  & )
14932 
14933  answer_negative = answer < 0
14934  check_negative = check < 0
14935  both_negative = answer_negative .and. check_negative
14936  if (.not. negative_support_on) both_negative = .false.
14937 
14938  judge = answer > check
14939  where (both_negative) judge = .not. judge
14940 
14941  judge_rev = .not. judge
14942  err_flag = any(judge_rev)
14943  mask_array = 1
14944  pos = maxloc(mask_array, judge_rev)
14945 
14946  if (err_flag) then
14947 
14948  wrong = check( &
14949  & pos(1), &
14950 
14951  & pos(2), &
14952 
14953  & pos(3), &
14954 
14955  & pos(4), &
14956 
14957  & pos(5), &
14958 
14959  & pos(6), &
14960 
14961  & pos(7) )
14962 
14963  right = answer( &
14964  & pos(1), &
14965 
14966  & pos(2), &
14967 
14968  & pos(3), &
14969 
14970  & pos(4), &
14971 
14972  & pos(5), &
14973 
14974  & pos(6), &
14975 
14976  & pos(7) )
14977 
14978  write(unit=pos_array(1), fmt="(i20)") pos(1)
14979 
14980  write(unit=pos_array(2), fmt="(i20)") pos(2)
14981 
14982  write(unit=pos_array(3), fmt="(i20)") pos(3)
14983 
14984  write(unit=pos_array(4), fmt="(i20)") pos(4)
14985 
14986  write(unit=pos_array(5), fmt="(i20)") pos(5)
14987 
14988  write(unit=pos_array(6), fmt="(i20)") pos(6)
14989 
14990  write(unit=pos_array(7), fmt="(i20)") pos(7)
14991 
14992 
14993  pos_str = '(' // &
14994  & trim(adjustl(pos_array(1))) // ',' // &
14995 
14996  & trim(adjustl(pos_array(2))) // ',' // &
14997 
14998  & trim(adjustl(pos_array(3))) // ',' // &
14999 
15000  & trim(adjustl(pos_array(4))) // ',' // &
15001 
15002  & trim(adjustl(pos_array(5))) // ',' // &
15003 
15004  & trim(adjustl(pos_array(6))) // ',' // &
15005 
15006  & trim(adjustl(pos_array(7))) // ')'
15007 
15008  if ( both_negative( &
15009  & pos(1), &
15010 
15011  & pos(2), &
15012 
15013  & pos(3), &
15014 
15015  & pos(4), &
15016 
15017  & pos(5), &
15018 
15019  & pos(6), &
15020 
15021  & pos(7) ) ) then
15022 
15023  abs_mes = 'ABSOLUTE value of'
15024  else
15025  abs_mes = ''
15026 
15027  end if
15028 
15029  end if
15030  deallocate(mask_array, judge, judge_rev)
15031  deallocate(answer_negative, check_negative, both_negative)
15032 
15033 
15034 
15035 
15036  if (err_flag) then
15037  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15038  write(*,*) ''
15039  write(*,*) ' ' // trim(abs_mes) // &
15040  & ' check' // trim(pos_str) // ' = ', wrong
15041  write(*,*) ' is NOT LESS THAN'
15042  write(*,*) ' ' // trim(abs_mes) // &
15043  & ' answer' // trim(pos_str) // ' = ', right
15044 
15045  call abort()
15046  else
15047  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15048  end if
15049 
15050 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthanreal0()

subroutine dc_test::dctestassertlessthanreal0 ( character(*), intent(in)  message,
real, intent(in)  answer,
real, intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 15056 of file dc_test.f90.

References dc_types::string, and dc_types::token.

15056  use dc_types, only: string, token
15057  implicit none
15058  character(*), intent(in):: message
15059  real, intent(in):: answer
15060  real, intent(in):: check
15061  logical, intent(in), optional:: negative_support
15062  logical:: err_flag
15063  logical:: negative_support_on
15064  character(STRING):: pos_str
15065  character(TOKEN):: abs_mes
15066  real:: wrong, right
15067 
15068 
15069 
15070  continue
15071  if (present(negative_support)) then
15072  negative_support_on = negative_support
15073  else
15074  negative_support_on = .true.
15075  end if
15076 
15077  err_flag = .false.
15078 
15079 
15080 
15081 
15082  err_flag = .not. answer > check
15083  abs_mes = ''
15084 
15085  if ( answer < 0.0 &
15086  & .and. check < 0.0 &
15087  & .and. negative_support_on ) then
15088 
15089  err_flag = .not. err_flag
15090  abs_mes = 'ABSOLUTE value of'
15091  end if
15092 
15093  wrong = check
15094  right = answer
15095  pos_str = ''
15096 
15097 
15098 
15099 
15100  if (err_flag) then
15101  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15102  write(*,*) ''
15103  write(*,*) ' ' // trim(abs_mes) // &
15104  & ' check' // trim(pos_str) // ' = ', wrong
15105  write(*,*) ' is NOT LESS THAN'
15106  write(*,*) ' ' // trim(abs_mes) // &
15107  & ' answer' // trim(pos_str) // ' = ', right
15108 
15109  call abort()
15110  else
15111  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15112  end if
15113 
15114 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthanreal1()

subroutine dc_test::dctestassertlessthanreal1 ( character(*), intent(in)  message,
real, dimension(:), intent(in)  answer,
real, dimension(:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 15120 of file dc_test.f90.

References dc_types::string, and dc_types::token.

15120  use dc_types, only: string, token
15121  implicit none
15122  character(*), intent(in):: message
15123  real, intent(in):: answer(:)
15124  real, intent(in):: check(:)
15125  logical, intent(in), optional:: negative_support
15126  logical:: err_flag
15127  logical:: negative_support_on
15128  character(STRING):: pos_str
15129  character(TOKEN):: abs_mes
15130  real:: wrong, right
15131 
15132  integer:: answer_shape(1), check_shape(1), pos(1)
15133  logical:: consist_shape(1)
15134  character(TOKEN):: pos_array(1)
15135  integer, allocatable:: mask_array(:)
15136  logical, allocatable:: judge(:)
15137  logical, allocatable:: judge_rev(:)
15138  logical, allocatable:: answer_negative(:)
15139  logical, allocatable:: check_negative(:)
15140  logical, allocatable:: both_negative(:)
15141 
15142 
15143  continue
15144  if (present(negative_support)) then
15145  negative_support_on = negative_support
15146  else
15147  negative_support_on = .true.
15148  end if
15149 
15150  err_flag = .false.
15151 
15152 
15153  answer_shape = shape(answer)
15154  check_shape = shape(check)
15155 
15156  consist_shape = answer_shape == check_shape
15157 
15158  if (.not. all(consist_shape)) then
15159  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15160  write(*,*) ''
15161  write(*,*) ' shape of check is (', check_shape, ')'
15162  write(*,*) ' is INCORRECT'
15163  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15164 
15165  call abort()
15166  end if
15167 
15168 
15169  allocate( mask_array( &
15170 
15171  & answer_shape(1) ) &
15172  & )
15173 
15174  allocate( judge( &
15175 
15176  & answer_shape(1) ) &
15177  & )
15178 
15179  allocate( judge_rev( &
15180 
15181  & answer_shape(1) ) &
15182  & )
15183 
15184  allocate( answer_negative( &
15185 
15186  & answer_shape(1) ) &
15187  & )
15188 
15189  allocate( check_negative( &
15190 
15191  & answer_shape(1) ) &
15192  & )
15193 
15194  allocate( both_negative( &
15195 
15196  & answer_shape(1) ) &
15197  & )
15198 
15199  answer_negative = answer < 0.0
15200  check_negative = check < 0.0
15201  both_negative = answer_negative .and. check_negative
15202  if (.not. negative_support_on) both_negative = .false.
15203 
15204  judge = answer > check
15205  where (both_negative) judge = .not. judge
15206 
15207  judge_rev = .not. judge
15208  err_flag = any(judge_rev)
15209  mask_array = 1
15210  pos = maxloc(mask_array, judge_rev)
15211 
15212  if (err_flag) then
15213 
15214  wrong = check( &
15215 
15216  & pos(1) )
15217 
15218  right = answer( &
15219 
15220  & pos(1) )
15221 
15222  write(unit=pos_array(1), fmt="(i20)") pos(1)
15223 
15224 
15225  pos_str = '(' // &
15226 
15227  & trim(adjustl(pos_array(1))) // ')'
15228 
15229  if ( both_negative( &
15230 
15231  & pos(1) ) ) then
15232 
15233  abs_mes = 'ABSOLUTE value of'
15234  else
15235  abs_mes = ''
15236 
15237  end if
15238 
15239  end if
15240  deallocate(mask_array, judge, judge_rev)
15241  deallocate(answer_negative, check_negative, both_negative)
15242 
15243 
15244 
15245 
15246  if (err_flag) then
15247  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15248  write(*,*) ''
15249  write(*,*) ' ' // trim(abs_mes) // &
15250  & ' check' // trim(pos_str) // ' = ', wrong
15251  write(*,*) ' is NOT LESS THAN'
15252  write(*,*) ' ' // trim(abs_mes) // &
15253  & ' answer' // trim(pos_str) // ' = ', right
15254 
15255  call abort()
15256  else
15257  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15258  end if
15259 
15260 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthanreal2()

subroutine dc_test::dctestassertlessthanreal2 ( character(*), intent(in)  message,
real, dimension(:,:), intent(in)  answer,
real, dimension(:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 15266 of file dc_test.f90.

References dc_types::string, and dc_types::token.

15266  use dc_types, only: string, token
15267  implicit none
15268  character(*), intent(in):: message
15269  real, intent(in):: answer(:,:)
15270  real, intent(in):: check(:,:)
15271  logical, intent(in), optional:: negative_support
15272  logical:: err_flag
15273  logical:: negative_support_on
15274  character(STRING):: pos_str
15275  character(TOKEN):: abs_mes
15276  real:: wrong, right
15277 
15278  integer:: answer_shape(2), check_shape(2), pos(2)
15279  logical:: consist_shape(2)
15280  character(TOKEN):: pos_array(2)
15281  integer, allocatable:: mask_array(:,:)
15282  logical, allocatable:: judge(:,:)
15283  logical, allocatable:: judge_rev(:,:)
15284  logical, allocatable:: answer_negative(:,:)
15285  logical, allocatable:: check_negative(:,:)
15286  logical, allocatable:: both_negative(:,:)
15287 
15288 
15289  continue
15290  if (present(negative_support)) then
15291  negative_support_on = negative_support
15292  else
15293  negative_support_on = .true.
15294  end if
15295 
15296  err_flag = .false.
15297 
15298 
15299  answer_shape = shape(answer)
15300  check_shape = shape(check)
15301 
15302  consist_shape = answer_shape == check_shape
15303 
15304  if (.not. all(consist_shape)) then
15305  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15306  write(*,*) ''
15307  write(*,*) ' shape of check is (', check_shape, ')'
15308  write(*,*) ' is INCORRECT'
15309  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15310 
15311  call abort()
15312  end if
15313 
15314 
15315  allocate( mask_array( &
15316  & answer_shape(1), &
15317 
15318  & answer_shape(2) ) &
15319  & )
15320 
15321  allocate( judge( &
15322  & answer_shape(1), &
15323 
15324  & answer_shape(2) ) &
15325  & )
15326 
15327  allocate( judge_rev( &
15328  & answer_shape(1), &
15329 
15330  & answer_shape(2) ) &
15331  & )
15332 
15333  allocate( answer_negative( &
15334  & answer_shape(1), &
15335 
15336  & answer_shape(2) ) &
15337  & )
15338 
15339  allocate( check_negative( &
15340  & answer_shape(1), &
15341 
15342  & answer_shape(2) ) &
15343  & )
15344 
15345  allocate( both_negative( &
15346  & answer_shape(1), &
15347 
15348  & answer_shape(2) ) &
15349  & )
15350 
15351  answer_negative = answer < 0.0
15352  check_negative = check < 0.0
15353  both_negative = answer_negative .and. check_negative
15354  if (.not. negative_support_on) both_negative = .false.
15355 
15356  judge = answer > check
15357  where (both_negative) judge = .not. judge
15358 
15359  judge_rev = .not. judge
15360  err_flag = any(judge_rev)
15361  mask_array = 1
15362  pos = maxloc(mask_array, judge_rev)
15363 
15364  if (err_flag) then
15365 
15366  wrong = check( &
15367  & pos(1), &
15368 
15369  & pos(2) )
15370 
15371  right = answer( &
15372  & pos(1), &
15373 
15374  & pos(2) )
15375 
15376  write(unit=pos_array(1), fmt="(i20)") pos(1)
15377 
15378  write(unit=pos_array(2), fmt="(i20)") pos(2)
15379 
15380 
15381  pos_str = '(' // &
15382  & trim(adjustl(pos_array(1))) // ',' // &
15383 
15384  & trim(adjustl(pos_array(2))) // ')'
15385 
15386  if ( both_negative( &
15387  & pos(1), &
15388 
15389  & pos(2) ) ) then
15390 
15391  abs_mes = 'ABSOLUTE value of'
15392  else
15393  abs_mes = ''
15394 
15395  end if
15396 
15397  end if
15398  deallocate(mask_array, judge, judge_rev)
15399  deallocate(answer_negative, check_negative, both_negative)
15400 
15401 
15402 
15403 
15404  if (err_flag) then
15405  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15406  write(*,*) ''
15407  write(*,*) ' ' // trim(abs_mes) // &
15408  & ' check' // trim(pos_str) // ' = ', wrong
15409  write(*,*) ' is NOT LESS THAN'
15410  write(*,*) ' ' // trim(abs_mes) // &
15411  & ' answer' // trim(pos_str) // ' = ', right
15412 
15413  call abort()
15414  else
15415  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15416  end if
15417 
15418 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthanreal3()

subroutine dc_test::dctestassertlessthanreal3 ( character(*), intent(in)  message,
real, dimension(:,:,:), intent(in)  answer,
real, dimension(:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 15424 of file dc_test.f90.

References dc_types::string, and dc_types::token.

15424  use dc_types, only: string, token
15425  implicit none
15426  character(*), intent(in):: message
15427  real, intent(in):: answer(:,:,:)
15428  real, intent(in):: check(:,:,:)
15429  logical, intent(in), optional:: negative_support
15430  logical:: err_flag
15431  logical:: negative_support_on
15432  character(STRING):: pos_str
15433  character(TOKEN):: abs_mes
15434  real:: wrong, right
15435 
15436  integer:: answer_shape(3), check_shape(3), pos(3)
15437  logical:: consist_shape(3)
15438  character(TOKEN):: pos_array(3)
15439  integer, allocatable:: mask_array(:,:,:)
15440  logical, allocatable:: judge(:,:,:)
15441  logical, allocatable:: judge_rev(:,:,:)
15442  logical, allocatable:: answer_negative(:,:,:)
15443  logical, allocatable:: check_negative(:,:,:)
15444  logical, allocatable:: both_negative(:,:,:)
15445 
15446 
15447  continue
15448  if (present(negative_support)) then
15449  negative_support_on = negative_support
15450  else
15451  negative_support_on = .true.
15452  end if
15453 
15454  err_flag = .false.
15455 
15456 
15457  answer_shape = shape(answer)
15458  check_shape = shape(check)
15459 
15460  consist_shape = answer_shape == check_shape
15461 
15462  if (.not. all(consist_shape)) then
15463  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15464  write(*,*) ''
15465  write(*,*) ' shape of check is (', check_shape, ')'
15466  write(*,*) ' is INCORRECT'
15467  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15468 
15469  call abort()
15470  end if
15471 
15472 
15473  allocate( mask_array( &
15474  & answer_shape(1), &
15475 
15476  & answer_shape(2), &
15477 
15478  & answer_shape(3) ) &
15479  & )
15480 
15481  allocate( judge( &
15482  & answer_shape(1), &
15483 
15484  & answer_shape(2), &
15485 
15486  & answer_shape(3) ) &
15487  & )
15488 
15489  allocate( judge_rev( &
15490  & answer_shape(1), &
15491 
15492  & answer_shape(2), &
15493 
15494  & answer_shape(3) ) &
15495  & )
15496 
15497  allocate( answer_negative( &
15498  & answer_shape(1), &
15499 
15500  & answer_shape(2), &
15501 
15502  & answer_shape(3) ) &
15503  & )
15504 
15505  allocate( check_negative( &
15506  & answer_shape(1), &
15507 
15508  & answer_shape(2), &
15509 
15510  & answer_shape(3) ) &
15511  & )
15512 
15513  allocate( both_negative( &
15514  & answer_shape(1), &
15515 
15516  & answer_shape(2), &
15517 
15518  & answer_shape(3) ) &
15519  & )
15520 
15521  answer_negative = answer < 0.0
15522  check_negative = check < 0.0
15523  both_negative = answer_negative .and. check_negative
15524  if (.not. negative_support_on) both_negative = .false.
15525 
15526  judge = answer > check
15527  where (both_negative) judge = .not. judge
15528 
15529  judge_rev = .not. judge
15530  err_flag = any(judge_rev)
15531  mask_array = 1
15532  pos = maxloc(mask_array, judge_rev)
15533 
15534  if (err_flag) then
15535 
15536  wrong = check( &
15537  & pos(1), &
15538 
15539  & pos(2), &
15540 
15541  & pos(3) )
15542 
15543  right = answer( &
15544  & pos(1), &
15545 
15546  & pos(2), &
15547 
15548  & pos(3) )
15549 
15550  write(unit=pos_array(1), fmt="(i20)") pos(1)
15551 
15552  write(unit=pos_array(2), fmt="(i20)") pos(2)
15553 
15554  write(unit=pos_array(3), fmt="(i20)") pos(3)
15555 
15556 
15557  pos_str = '(' // &
15558  & trim(adjustl(pos_array(1))) // ',' // &
15559 
15560  & trim(adjustl(pos_array(2))) // ',' // &
15561 
15562  & trim(adjustl(pos_array(3))) // ')'
15563 
15564  if ( both_negative( &
15565  & pos(1), &
15566 
15567  & pos(2), &
15568 
15569  & pos(3) ) ) then
15570 
15571  abs_mes = 'ABSOLUTE value of'
15572  else
15573  abs_mes = ''
15574 
15575  end if
15576 
15577  end if
15578  deallocate(mask_array, judge, judge_rev)
15579  deallocate(answer_negative, check_negative, both_negative)
15580 
15581 
15582 
15583 
15584  if (err_flag) then
15585  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15586  write(*,*) ''
15587  write(*,*) ' ' // trim(abs_mes) // &
15588  & ' check' // trim(pos_str) // ' = ', wrong
15589  write(*,*) ' is NOT LESS THAN'
15590  write(*,*) ' ' // trim(abs_mes) // &
15591  & ' answer' // trim(pos_str) // ' = ', right
15592 
15593  call abort()
15594  else
15595  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15596  end if
15597 
15598 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthanreal4()

subroutine dc_test::dctestassertlessthanreal4 ( character(*), intent(in)  message,
real, dimension(:,:,:,:), intent(in)  answer,
real, dimension(:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 15604 of file dc_test.f90.

References dc_types::string, and dc_types::token.

15604  use dc_types, only: string, token
15605  implicit none
15606  character(*), intent(in):: message
15607  real, intent(in):: answer(:,:,:,:)
15608  real, intent(in):: check(:,:,:,:)
15609  logical, intent(in), optional:: negative_support
15610  logical:: err_flag
15611  logical:: negative_support_on
15612  character(STRING):: pos_str
15613  character(TOKEN):: abs_mes
15614  real:: wrong, right
15615 
15616  integer:: answer_shape(4), check_shape(4), pos(4)
15617  logical:: consist_shape(4)
15618  character(TOKEN):: pos_array(4)
15619  integer, allocatable:: mask_array(:,:,:,:)
15620  logical, allocatable:: judge(:,:,:,:)
15621  logical, allocatable:: judge_rev(:,:,:,:)
15622  logical, allocatable:: answer_negative(:,:,:,:)
15623  logical, allocatable:: check_negative(:,:,:,:)
15624  logical, allocatable:: both_negative(:,:,:,:)
15625 
15626 
15627  continue
15628  if (present(negative_support)) then
15629  negative_support_on = negative_support
15630  else
15631  negative_support_on = .true.
15632  end if
15633 
15634  err_flag = .false.
15635 
15636 
15637  answer_shape = shape(answer)
15638  check_shape = shape(check)
15639 
15640  consist_shape = answer_shape == check_shape
15641 
15642  if (.not. all(consist_shape)) then
15643  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15644  write(*,*) ''
15645  write(*,*) ' shape of check is (', check_shape, ')'
15646  write(*,*) ' is INCORRECT'
15647  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15648 
15649  call abort()
15650  end if
15651 
15652 
15653  allocate( mask_array( &
15654  & answer_shape(1), &
15655 
15656  & answer_shape(2), &
15657 
15658  & answer_shape(3), &
15659 
15660  & answer_shape(4) ) &
15661  & )
15662 
15663  allocate( judge( &
15664  & answer_shape(1), &
15665 
15666  & answer_shape(2), &
15667 
15668  & answer_shape(3), &
15669 
15670  & answer_shape(4) ) &
15671  & )
15672 
15673  allocate( judge_rev( &
15674  & answer_shape(1), &
15675 
15676  & answer_shape(2), &
15677 
15678  & answer_shape(3), &
15679 
15680  & answer_shape(4) ) &
15681  & )
15682 
15683  allocate( answer_negative( &
15684  & answer_shape(1), &
15685 
15686  & answer_shape(2), &
15687 
15688  & answer_shape(3), &
15689 
15690  & answer_shape(4) ) &
15691  & )
15692 
15693  allocate( check_negative( &
15694  & answer_shape(1), &
15695 
15696  & answer_shape(2), &
15697 
15698  & answer_shape(3), &
15699 
15700  & answer_shape(4) ) &
15701  & )
15702 
15703  allocate( both_negative( &
15704  & answer_shape(1), &
15705 
15706  & answer_shape(2), &
15707 
15708  & answer_shape(3), &
15709 
15710  & answer_shape(4) ) &
15711  & )
15712 
15713  answer_negative = answer < 0.0
15714  check_negative = check < 0.0
15715  both_negative = answer_negative .and. check_negative
15716  if (.not. negative_support_on) both_negative = .false.
15717 
15718  judge = answer > check
15719  where (both_negative) judge = .not. judge
15720 
15721  judge_rev = .not. judge
15722  err_flag = any(judge_rev)
15723  mask_array = 1
15724  pos = maxloc(mask_array, judge_rev)
15725 
15726  if (err_flag) then
15727 
15728  wrong = check( &
15729  & pos(1), &
15730 
15731  & pos(2), &
15732 
15733  & pos(3), &
15734 
15735  & pos(4) )
15736 
15737  right = answer( &
15738  & pos(1), &
15739 
15740  & pos(2), &
15741 
15742  & pos(3), &
15743 
15744  & pos(4) )
15745 
15746  write(unit=pos_array(1), fmt="(i20)") pos(1)
15747 
15748  write(unit=pos_array(2), fmt="(i20)") pos(2)
15749 
15750  write(unit=pos_array(3), fmt="(i20)") pos(3)
15751 
15752  write(unit=pos_array(4), fmt="(i20)") pos(4)
15753 
15754 
15755  pos_str = '(' // &
15756  & trim(adjustl(pos_array(1))) // ',' // &
15757 
15758  & trim(adjustl(pos_array(2))) // ',' // &
15759 
15760  & trim(adjustl(pos_array(3))) // ',' // &
15761 
15762  & trim(adjustl(pos_array(4))) // ')'
15763 
15764  if ( both_negative( &
15765  & pos(1), &
15766 
15767  & pos(2), &
15768 
15769  & pos(3), &
15770 
15771  & pos(4) ) ) then
15772 
15773  abs_mes = 'ABSOLUTE value of'
15774  else
15775  abs_mes = ''
15776 
15777  end if
15778 
15779  end if
15780  deallocate(mask_array, judge, judge_rev)
15781  deallocate(answer_negative, check_negative, both_negative)
15782 
15783 
15784 
15785 
15786  if (err_flag) then
15787  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15788  write(*,*) ''
15789  write(*,*) ' ' // trim(abs_mes) // &
15790  & ' check' // trim(pos_str) // ' = ', wrong
15791  write(*,*) ' is NOT LESS THAN'
15792  write(*,*) ' ' // trim(abs_mes) // &
15793  & ' answer' // trim(pos_str) // ' = ', right
15794 
15795  call abort()
15796  else
15797  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15798  end if
15799 
15800 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthanreal5()

subroutine dc_test::dctestassertlessthanreal5 ( character(*), intent(in)  message,
real, dimension(:,:,:,:,:), intent(in)  answer,
real, dimension(:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 15806 of file dc_test.f90.

References dc_types::string, and dc_types::token.

15806  use dc_types, only: string, token
15807  implicit none
15808  character(*), intent(in):: message
15809  real, intent(in):: answer(:,:,:,:,:)
15810  real, intent(in):: check(:,:,:,:,:)
15811  logical, intent(in), optional:: negative_support
15812  logical:: err_flag
15813  logical:: negative_support_on
15814  character(STRING):: pos_str
15815  character(TOKEN):: abs_mes
15816  real:: wrong, right
15817 
15818  integer:: answer_shape(5), check_shape(5), pos(5)
15819  logical:: consist_shape(5)
15820  character(TOKEN):: pos_array(5)
15821  integer, allocatable:: mask_array(:,:,:,:,:)
15822  logical, allocatable:: judge(:,:,:,:,:)
15823  logical, allocatable:: judge_rev(:,:,:,:,:)
15824  logical, allocatable:: answer_negative(:,:,:,:,:)
15825  logical, allocatable:: check_negative(:,:,:,:,:)
15826  logical, allocatable:: both_negative(:,:,:,:,:)
15827 
15828 
15829  continue
15830  if (present(negative_support)) then
15831  negative_support_on = negative_support
15832  else
15833  negative_support_on = .true.
15834  end if
15835 
15836  err_flag = .false.
15837 
15838 
15839  answer_shape = shape(answer)
15840  check_shape = shape(check)
15841 
15842  consist_shape = answer_shape == check_shape
15843 
15844  if (.not. all(consist_shape)) then
15845  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15846  write(*,*) ''
15847  write(*,*) ' shape of check is (', check_shape, ')'
15848  write(*,*) ' is INCORRECT'
15849  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15850 
15851  call abort()
15852  end if
15853 
15854 
15855  allocate( mask_array( &
15856  & answer_shape(1), &
15857 
15858  & answer_shape(2), &
15859 
15860  & answer_shape(3), &
15861 
15862  & answer_shape(4), &
15863 
15864  & answer_shape(5) ) &
15865  & )
15866 
15867  allocate( judge( &
15868  & answer_shape(1), &
15869 
15870  & answer_shape(2), &
15871 
15872  & answer_shape(3), &
15873 
15874  & answer_shape(4), &
15875 
15876  & answer_shape(5) ) &
15877  & )
15878 
15879  allocate( judge_rev( &
15880  & answer_shape(1), &
15881 
15882  & answer_shape(2), &
15883 
15884  & answer_shape(3), &
15885 
15886  & answer_shape(4), &
15887 
15888  & answer_shape(5) ) &
15889  & )
15890 
15891  allocate( answer_negative( &
15892  & answer_shape(1), &
15893 
15894  & answer_shape(2), &
15895 
15896  & answer_shape(3), &
15897 
15898  & answer_shape(4), &
15899 
15900  & answer_shape(5) ) &
15901  & )
15902 
15903  allocate( check_negative( &
15904  & answer_shape(1), &
15905 
15906  & answer_shape(2), &
15907 
15908  & answer_shape(3), &
15909 
15910  & answer_shape(4), &
15911 
15912  & answer_shape(5) ) &
15913  & )
15914 
15915  allocate( both_negative( &
15916  & answer_shape(1), &
15917 
15918  & answer_shape(2), &
15919 
15920  & answer_shape(3), &
15921 
15922  & answer_shape(4), &
15923 
15924  & answer_shape(5) ) &
15925  & )
15926 
15927  answer_negative = answer < 0.0
15928  check_negative = check < 0.0
15929  both_negative = answer_negative .and. check_negative
15930  if (.not. negative_support_on) both_negative = .false.
15931 
15932  judge = answer > check
15933  where (both_negative) judge = .not. judge
15934 
15935  judge_rev = .not. judge
15936  err_flag = any(judge_rev)
15937  mask_array = 1
15938  pos = maxloc(mask_array, judge_rev)
15939 
15940  if (err_flag) then
15941 
15942  wrong = check( &
15943  & pos(1), &
15944 
15945  & pos(2), &
15946 
15947  & pos(3), &
15948 
15949  & pos(4), &
15950 
15951  & pos(5) )
15952 
15953  right = answer( &
15954  & pos(1), &
15955 
15956  & pos(2), &
15957 
15958  & pos(3), &
15959 
15960  & pos(4), &
15961 
15962  & pos(5) )
15963 
15964  write(unit=pos_array(1), fmt="(i20)") pos(1)
15965 
15966  write(unit=pos_array(2), fmt="(i20)") pos(2)
15967 
15968  write(unit=pos_array(3), fmt="(i20)") pos(3)
15969 
15970  write(unit=pos_array(4), fmt="(i20)") pos(4)
15971 
15972  write(unit=pos_array(5), fmt="(i20)") pos(5)
15973 
15974 
15975  pos_str = '(' // &
15976  & trim(adjustl(pos_array(1))) // ',' // &
15977 
15978  & trim(adjustl(pos_array(2))) // ',' // &
15979 
15980  & trim(adjustl(pos_array(3))) // ',' // &
15981 
15982  & trim(adjustl(pos_array(4))) // ',' // &
15983 
15984  & trim(adjustl(pos_array(5))) // ')'
15985 
15986  if ( both_negative( &
15987  & pos(1), &
15988 
15989  & pos(2), &
15990 
15991  & pos(3), &
15992 
15993  & pos(4), &
15994 
15995  & pos(5) ) ) then
15996 
15997  abs_mes = 'ABSOLUTE value of'
15998  else
15999  abs_mes = ''
16000 
16001  end if
16002 
16003  end if
16004  deallocate(mask_array, judge, judge_rev)
16005  deallocate(answer_negative, check_negative, both_negative)
16006 
16007 
16008 
16009 
16010  if (err_flag) then
16011  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16012  write(*,*) ''
16013  write(*,*) ' ' // trim(abs_mes) // &
16014  & ' check' // trim(pos_str) // ' = ', wrong
16015  write(*,*) ' is NOT LESS THAN'
16016  write(*,*) ' ' // trim(abs_mes) // &
16017  & ' answer' // trim(pos_str) // ' = ', right
16018 
16019  call abort()
16020  else
16021  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16022  end if
16023 
16024 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthanreal6()

subroutine dc_test::dctestassertlessthanreal6 ( character(*), intent(in)  message,
real, dimension(:,:,:,:,:,:), intent(in)  answer,
real, dimension(:,:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 16030 of file dc_test.f90.

References dc_types::string, and dc_types::token.

16030  use dc_types, only: string, token
16031  implicit none
16032  character(*), intent(in):: message
16033  real, intent(in):: answer(:,:,:,:,:,:)
16034  real, intent(in):: check(:,:,:,:,:,:)
16035  logical, intent(in), optional:: negative_support
16036  logical:: err_flag
16037  logical:: negative_support_on
16038  character(STRING):: pos_str
16039  character(TOKEN):: abs_mes
16040  real:: wrong, right
16041 
16042  integer:: answer_shape(6), check_shape(6), pos(6)
16043  logical:: consist_shape(6)
16044  character(TOKEN):: pos_array(6)
16045  integer, allocatable:: mask_array(:,:,:,:,:,:)
16046  logical, allocatable:: judge(:,:,:,:,:,:)
16047  logical, allocatable:: judge_rev(:,:,:,:,:,:)
16048  logical, allocatable:: answer_negative(:,:,:,:,:,:)
16049  logical, allocatable:: check_negative(:,:,:,:,:,:)
16050  logical, allocatable:: both_negative(:,:,:,:,:,:)
16051 
16052 
16053  continue
16054  if (present(negative_support)) then
16055  negative_support_on = negative_support
16056  else
16057  negative_support_on = .true.
16058  end if
16059 
16060  err_flag = .false.
16061 
16062 
16063  answer_shape = shape(answer)
16064  check_shape = shape(check)
16065 
16066  consist_shape = answer_shape == check_shape
16067 
16068  if (.not. all(consist_shape)) then
16069  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16070  write(*,*) ''
16071  write(*,*) ' shape of check is (', check_shape, ')'
16072  write(*,*) ' is INCORRECT'
16073  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
16074 
16075  call abort()
16076  end if
16077 
16078 
16079  allocate( mask_array( &
16080  & answer_shape(1), &
16081 
16082  & answer_shape(2), &
16083 
16084  & answer_shape(3), &
16085 
16086  & answer_shape(4), &
16087 
16088  & answer_shape(5), &
16089 
16090  & answer_shape(6) ) &
16091  & )
16092 
16093  allocate( judge( &
16094  & answer_shape(1), &
16095 
16096  & answer_shape(2), &
16097 
16098  & answer_shape(3), &
16099 
16100  & answer_shape(4), &
16101 
16102  & answer_shape(5), &
16103 
16104  & answer_shape(6) ) &
16105  & )
16106 
16107  allocate( judge_rev( &
16108  & answer_shape(1), &
16109 
16110  & answer_shape(2), &
16111 
16112  & answer_shape(3), &
16113 
16114  & answer_shape(4), &
16115 
16116  & answer_shape(5), &
16117 
16118  & answer_shape(6) ) &
16119  & )
16120 
16121  allocate( answer_negative( &
16122  & answer_shape(1), &
16123 
16124  & answer_shape(2), &
16125 
16126  & answer_shape(3), &
16127 
16128  & answer_shape(4), &
16129 
16130  & answer_shape(5), &
16131 
16132  & answer_shape(6) ) &
16133  & )
16134 
16135  allocate( check_negative( &
16136  & answer_shape(1), &
16137 
16138  & answer_shape(2), &
16139 
16140  & answer_shape(3), &
16141 
16142  & answer_shape(4), &
16143 
16144  & answer_shape(5), &
16145 
16146  & answer_shape(6) ) &
16147  & )
16148 
16149  allocate( both_negative( &
16150  & answer_shape(1), &
16151 
16152  & answer_shape(2), &
16153 
16154  & answer_shape(3), &
16155 
16156  & answer_shape(4), &
16157 
16158  & answer_shape(5), &
16159 
16160  & answer_shape(6) ) &
16161  & )
16162 
16163  answer_negative = answer < 0.0
16164  check_negative = check < 0.0
16165  both_negative = answer_negative .and. check_negative
16166  if (.not. negative_support_on) both_negative = .false.
16167 
16168  judge = answer > check
16169  where (both_negative) judge = .not. judge
16170 
16171  judge_rev = .not. judge
16172  err_flag = any(judge_rev)
16173  mask_array = 1
16174  pos = maxloc(mask_array, judge_rev)
16175 
16176  if (err_flag) then
16177 
16178  wrong = check( &
16179  & pos(1), &
16180 
16181  & pos(2), &
16182 
16183  & pos(3), &
16184 
16185  & pos(4), &
16186 
16187  & pos(5), &
16188 
16189  & pos(6) )
16190 
16191  right = answer( &
16192  & pos(1), &
16193 
16194  & pos(2), &
16195 
16196  & pos(3), &
16197 
16198  & pos(4), &
16199 
16200  & pos(5), &
16201 
16202  & pos(6) )
16203 
16204  write(unit=pos_array(1), fmt="(i20)") pos(1)
16205 
16206  write(unit=pos_array(2), fmt="(i20)") pos(2)
16207 
16208  write(unit=pos_array(3), fmt="(i20)") pos(3)
16209 
16210  write(unit=pos_array(4), fmt="(i20)") pos(4)
16211 
16212  write(unit=pos_array(5), fmt="(i20)") pos(5)
16213 
16214  write(unit=pos_array(6), fmt="(i20)") pos(6)
16215 
16216 
16217  pos_str = '(' // &
16218  & trim(adjustl(pos_array(1))) // ',' // &
16219 
16220  & trim(adjustl(pos_array(2))) // ',' // &
16221 
16222  & trim(adjustl(pos_array(3))) // ',' // &
16223 
16224  & trim(adjustl(pos_array(4))) // ',' // &
16225 
16226  & trim(adjustl(pos_array(5))) // ',' // &
16227 
16228  & trim(adjustl(pos_array(6))) // ')'
16229 
16230  if ( both_negative( &
16231  & pos(1), &
16232 
16233  & pos(2), &
16234 
16235  & pos(3), &
16236 
16237  & pos(4), &
16238 
16239  & pos(5), &
16240 
16241  & pos(6) ) ) then
16242 
16243  abs_mes = 'ABSOLUTE value of'
16244  else
16245  abs_mes = ''
16246 
16247  end if
16248 
16249  end if
16250  deallocate(mask_array, judge, judge_rev)
16251  deallocate(answer_negative, check_negative, both_negative)
16252 
16253 
16254 
16255 
16256  if (err_flag) then
16257  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16258  write(*,*) ''
16259  write(*,*) ' ' // trim(abs_mes) // &
16260  & ' check' // trim(pos_str) // ' = ', wrong
16261  write(*,*) ' is NOT LESS THAN'
16262  write(*,*) ' ' // trim(abs_mes) // &
16263  & ' answer' // trim(pos_str) // ' = ', right
16264 
16265  call abort()
16266  else
16267  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16268  end if
16269 
16270 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthanreal7()

subroutine dc_test::dctestassertlessthanreal7 ( character(*), intent(in)  message,
real, dimension(:,:,:,:,:,:,:), intent(in)  answer,
real, dimension(:,:,:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 16276 of file dc_test.f90.

References dc_types::string, and dc_types::token.

16276  use dc_types, only: string, token
16277  implicit none
16278  character(*), intent(in):: message
16279  real, intent(in):: answer(:,:,:,:,:,:,:)
16280  real, intent(in):: check(:,:,:,:,:,:,:)
16281  logical, intent(in), optional:: negative_support
16282  logical:: err_flag
16283  logical:: negative_support_on
16284  character(STRING):: pos_str
16285  character(TOKEN):: abs_mes
16286  real:: wrong, right
16287 
16288  integer:: answer_shape(7), check_shape(7), pos(7)
16289  logical:: consist_shape(7)
16290  character(TOKEN):: pos_array(7)
16291  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
16292  logical, allocatable:: judge(:,:,:,:,:,:,:)
16293  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
16294  logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
16295  logical, allocatable:: check_negative(:,:,:,:,:,:,:)
16296  logical, allocatable:: both_negative(:,:,:,:,:,:,:)
16297 
16298 
16299  continue
16300  if (present(negative_support)) then
16301  negative_support_on = negative_support
16302  else
16303  negative_support_on = .true.
16304  end if
16305 
16306  err_flag = .false.
16307 
16308 
16309  answer_shape = shape(answer)
16310  check_shape = shape(check)
16311 
16312  consist_shape = answer_shape == check_shape
16313 
16314  if (.not. all(consist_shape)) then
16315  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16316  write(*,*) ''
16317  write(*,*) ' shape of check is (', check_shape, ')'
16318  write(*,*) ' is INCORRECT'
16319  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
16320 
16321  call abort()
16322  end if
16323 
16324 
16325  allocate( mask_array( &
16326  & answer_shape(1), &
16327 
16328  & answer_shape(2), &
16329 
16330  & answer_shape(3), &
16331 
16332  & answer_shape(4), &
16333 
16334  & answer_shape(5), &
16335 
16336  & answer_shape(6), &
16337 
16338  & answer_shape(7) ) &
16339  & )
16340 
16341  allocate( judge( &
16342  & answer_shape(1), &
16343 
16344  & answer_shape(2), &
16345 
16346  & answer_shape(3), &
16347 
16348  & answer_shape(4), &
16349 
16350  & answer_shape(5), &
16351 
16352  & answer_shape(6), &
16353 
16354  & answer_shape(7) ) &
16355  & )
16356 
16357  allocate( judge_rev( &
16358  & answer_shape(1), &
16359 
16360  & answer_shape(2), &
16361 
16362  & answer_shape(3), &
16363 
16364  & answer_shape(4), &
16365 
16366  & answer_shape(5), &
16367 
16368  & answer_shape(6), &
16369 
16370  & answer_shape(7) ) &
16371  & )
16372 
16373  allocate( answer_negative( &
16374  & answer_shape(1), &
16375 
16376  & answer_shape(2), &
16377 
16378  & answer_shape(3), &
16379 
16380  & answer_shape(4), &
16381 
16382  & answer_shape(5), &
16383 
16384  & answer_shape(6), &
16385 
16386  & answer_shape(7) ) &
16387  & )
16388 
16389  allocate( check_negative( &
16390  & answer_shape(1), &
16391 
16392  & answer_shape(2), &
16393 
16394  & answer_shape(3), &
16395 
16396  & answer_shape(4), &
16397 
16398  & answer_shape(5), &
16399 
16400  & answer_shape(6), &
16401 
16402  & answer_shape(7) ) &
16403  & )
16404 
16405  allocate( both_negative( &
16406  & answer_shape(1), &
16407 
16408  & answer_shape(2), &
16409 
16410  & answer_shape(3), &
16411 
16412  & answer_shape(4), &
16413 
16414  & answer_shape(5), &
16415 
16416  & answer_shape(6), &
16417 
16418  & answer_shape(7) ) &
16419  & )
16420 
16421  answer_negative = answer < 0.0
16422  check_negative = check < 0.0
16423  both_negative = answer_negative .and. check_negative
16424  if (.not. negative_support_on) both_negative = .false.
16425 
16426  judge = answer > check
16427  where (both_negative) judge = .not. judge
16428 
16429  judge_rev = .not. judge
16430  err_flag = any(judge_rev)
16431  mask_array = 1
16432  pos = maxloc(mask_array, judge_rev)
16433 
16434  if (err_flag) then
16435 
16436  wrong = check( &
16437  & pos(1), &
16438 
16439  & pos(2), &
16440 
16441  & pos(3), &
16442 
16443  & pos(4), &
16444 
16445  & pos(5), &
16446 
16447  & pos(6), &
16448 
16449  & pos(7) )
16450 
16451  right = answer( &
16452  & pos(1), &
16453 
16454  & pos(2), &
16455 
16456  & pos(3), &
16457 
16458  & pos(4), &
16459 
16460  & pos(5), &
16461 
16462  & pos(6), &
16463 
16464  & pos(7) )
16465 
16466  write(unit=pos_array(1), fmt="(i20)") pos(1)
16467 
16468  write(unit=pos_array(2), fmt="(i20)") pos(2)
16469 
16470  write(unit=pos_array(3), fmt="(i20)") pos(3)
16471 
16472  write(unit=pos_array(4), fmt="(i20)") pos(4)
16473 
16474  write(unit=pos_array(5), fmt="(i20)") pos(5)
16475 
16476  write(unit=pos_array(6), fmt="(i20)") pos(6)
16477 
16478  write(unit=pos_array(7), fmt="(i20)") pos(7)
16479 
16480 
16481  pos_str = '(' // &
16482  & trim(adjustl(pos_array(1))) // ',' // &
16483 
16484  & trim(adjustl(pos_array(2))) // ',' // &
16485 
16486  & trim(adjustl(pos_array(3))) // ',' // &
16487 
16488  & trim(adjustl(pos_array(4))) // ',' // &
16489 
16490  & trim(adjustl(pos_array(5))) // ',' // &
16491 
16492  & trim(adjustl(pos_array(6))) // ',' // &
16493 
16494  & trim(adjustl(pos_array(7))) // ')'
16495 
16496  if ( both_negative( &
16497  & pos(1), &
16498 
16499  & pos(2), &
16500 
16501  & pos(3), &
16502 
16503  & pos(4), &
16504 
16505  & pos(5), &
16506 
16507  & pos(6), &
16508 
16509  & pos(7) ) ) then
16510 
16511  abs_mes = 'ABSOLUTE value of'
16512  else
16513  abs_mes = ''
16514 
16515  end if
16516 
16517  end if
16518  deallocate(mask_array, judge, judge_rev)
16519  deallocate(answer_negative, check_negative, both_negative)
16520 
16521 
16522 
16523 
16524  if (err_flag) then
16525  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16526  write(*,*) ''
16527  write(*,*) ' ' // trim(abs_mes) // &
16528  & ' check' // trim(pos_str) // ' = ', wrong
16529  write(*,*) ' is NOT LESS THAN'
16530  write(*,*) ' ' // trim(abs_mes) // &
16531  & ' answer' // trim(pos_str) // ' = ', right
16532 
16533  call abort()
16534  else
16535  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16536  end if
16537 
16538 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthandouble0()

subroutine dc_test::dctestassertlessthandouble0 ( character(*), intent(in)  message,
real(dp), intent(in)  answer,
real(dp), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 16544 of file dc_test.f90.

References dc_types::string, and dc_types::token.

16544  use dc_types, only: string, token
16545  implicit none
16546  character(*), intent(in):: message
16547  real(DP), intent(in):: answer
16548  real(DP), intent(in):: check
16549  logical, intent(in), optional:: negative_support
16550  logical:: err_flag
16551  logical:: negative_support_on
16552  character(STRING):: pos_str
16553  character(TOKEN):: abs_mes
16554  real(DP):: wrong, right
16555 
16556 
16557 
16558  continue
16559  if (present(negative_support)) then
16560  negative_support_on = negative_support
16561  else
16562  negative_support_on = .true.
16563  end if
16564 
16565  err_flag = .false.
16566 
16567 
16568 
16569 
16570  err_flag = .not. answer > check
16571  abs_mes = ''
16572 
16573  if ( answer < 0.0_dp &
16574  & .and. check < 0.0_dp &
16575  & .and. negative_support_on ) then
16576 
16577  err_flag = .not. err_flag
16578  abs_mes = 'ABSOLUTE value of'
16579  end if
16580 
16581  wrong = check
16582  right = answer
16583  pos_str = ''
16584 
16585 
16586 
16587 
16588  if (err_flag) then
16589  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16590  write(*,*) ''
16591  write(*,*) ' ' // trim(abs_mes) // &
16592  & ' check' // trim(pos_str) // ' = ', wrong
16593  write(*,*) ' is NOT LESS THAN'
16594  write(*,*) ' ' // trim(abs_mes) // &
16595  & ' answer' // trim(pos_str) // ' = ', right
16596 
16597  call abort()
16598  else
16599  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16600  end if
16601 
16602 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthandouble1()

subroutine dc_test::dctestassertlessthandouble1 ( character(*), intent(in)  message,
real(dp), dimension(:), intent(in)  answer,
real(dp), dimension(:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 16608 of file dc_test.f90.

References dc_types::string, and dc_types::token.

16608  use dc_types, only: string, token
16609  implicit none
16610  character(*), intent(in):: message
16611  real(DP), intent(in):: answer(:)
16612  real(DP), intent(in):: check(:)
16613  logical, intent(in), optional:: negative_support
16614  logical:: err_flag
16615  logical:: negative_support_on
16616  character(STRING):: pos_str
16617  character(TOKEN):: abs_mes
16618  real(DP):: wrong, right
16619 
16620  integer:: answer_shape(1), check_shape(1), pos(1)
16621  logical:: consist_shape(1)
16622  character(TOKEN):: pos_array(1)
16623  integer, allocatable:: mask_array(:)
16624  logical, allocatable:: judge(:)
16625  logical, allocatable:: judge_rev(:)
16626  logical, allocatable:: answer_negative(:)
16627  logical, allocatable:: check_negative(:)
16628  logical, allocatable:: both_negative(:)
16629 
16630 
16631  continue
16632  if (present(negative_support)) then
16633  negative_support_on = negative_support
16634  else
16635  negative_support_on = .true.
16636  end if
16637 
16638  err_flag = .false.
16639 
16640 
16641  answer_shape = shape(answer)
16642  check_shape = shape(check)
16643 
16644  consist_shape = answer_shape == check_shape
16645 
16646  if (.not. all(consist_shape)) then
16647  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16648  write(*,*) ''
16649  write(*,*) ' shape of check is (', check_shape, ')'
16650  write(*,*) ' is INCORRECT'
16651  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
16652 
16653  call abort()
16654  end if
16655 
16656 
16657  allocate( mask_array( &
16658 
16659  & answer_shape(1) ) &
16660  & )
16661 
16662  allocate( judge( &
16663 
16664  & answer_shape(1) ) &
16665  & )
16666 
16667  allocate( judge_rev( &
16668 
16669  & answer_shape(1) ) &
16670  & )
16671 
16672  allocate( answer_negative( &
16673 
16674  & answer_shape(1) ) &
16675  & )
16676 
16677  allocate( check_negative( &
16678 
16679  & answer_shape(1) ) &
16680  & )
16681 
16682  allocate( both_negative( &
16683 
16684  & answer_shape(1) ) &
16685  & )
16686 
16687  answer_negative = answer < 0.0_dp
16688  check_negative = check < 0.0_dp
16689  both_negative = answer_negative .and. check_negative
16690  if (.not. negative_support_on) both_negative = .false.
16691 
16692  judge = answer > check
16693  where (both_negative) judge = .not. judge
16694 
16695  judge_rev = .not. judge
16696  err_flag = any(judge_rev)
16697  mask_array = 1
16698  pos = maxloc(mask_array, judge_rev)
16699 
16700  if (err_flag) then
16701 
16702  wrong = check( &
16703 
16704  & pos(1) )
16705 
16706  right = answer( &
16707 
16708  & pos(1) )
16709 
16710  write(unit=pos_array(1), fmt="(i20)") pos(1)
16711 
16712 
16713  pos_str = '(' // &
16714 
16715  & trim(adjustl(pos_array(1))) // ')'
16716 
16717  if ( both_negative( &
16718 
16719  & pos(1) ) ) then
16720 
16721  abs_mes = 'ABSOLUTE value of'
16722  else
16723  abs_mes = ''
16724 
16725  end if
16726 
16727  end if
16728  deallocate(mask_array, judge, judge_rev)
16729  deallocate(answer_negative, check_negative, both_negative)
16730 
16731 
16732 
16733 
16734  if (err_flag) then
16735  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16736  write(*,*) ''
16737  write(*,*) ' ' // trim(abs_mes) // &
16738  & ' check' // trim(pos_str) // ' = ', wrong
16739  write(*,*) ' is NOT LESS THAN'
16740  write(*,*) ' ' // trim(abs_mes) // &
16741  & ' answer' // trim(pos_str) // ' = ', right
16742 
16743  call abort()
16744  else
16745  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16746  end if
16747 
16748 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthandouble2()

subroutine dc_test::dctestassertlessthandouble2 ( character(*), intent(in)  message,
real(dp), dimension(:,:), intent(in)  answer,
real(dp), dimension(:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 16754 of file dc_test.f90.

References dc_types::string, and dc_types::token.

16754  use dc_types, only: string, token
16755  implicit none
16756  character(*), intent(in):: message
16757  real(DP), intent(in):: answer(:,:)
16758  real(DP), intent(in):: check(:,:)
16759  logical, intent(in), optional:: negative_support
16760  logical:: err_flag
16761  logical:: negative_support_on
16762  character(STRING):: pos_str
16763  character(TOKEN):: abs_mes
16764  real(DP):: wrong, right
16765 
16766  integer:: answer_shape(2), check_shape(2), pos(2)
16767  logical:: consist_shape(2)
16768  character(TOKEN):: pos_array(2)
16769  integer, allocatable:: mask_array(:,:)
16770  logical, allocatable:: judge(:,:)
16771  logical, allocatable:: judge_rev(:,:)
16772  logical, allocatable:: answer_negative(:,:)
16773  logical, allocatable:: check_negative(:,:)
16774  logical, allocatable:: both_negative(:,:)
16775 
16776 
16777  continue
16778  if (present(negative_support)) then
16779  negative_support_on = negative_support
16780  else
16781  negative_support_on = .true.
16782  end if
16783 
16784  err_flag = .false.
16785 
16786 
16787  answer_shape = shape(answer)
16788  check_shape = shape(check)
16789 
16790  consist_shape = answer_shape == check_shape
16791 
16792  if (.not. all(consist_shape)) then
16793  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16794  write(*,*) ''
16795  write(*,*) ' shape of check is (', check_shape, ')'
16796  write(*,*) ' is INCORRECT'
16797  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
16798 
16799  call abort()
16800  end if
16801 
16802 
16803  allocate( mask_array( &
16804  & answer_shape(1), &
16805 
16806  & answer_shape(2) ) &
16807  & )
16808 
16809  allocate( judge( &
16810  & answer_shape(1), &
16811 
16812  & answer_shape(2) ) &
16813  & )
16814 
16815  allocate( judge_rev( &
16816  & answer_shape(1), &
16817 
16818  & answer_shape(2) ) &
16819  & )
16820 
16821  allocate( answer_negative( &
16822  & answer_shape(1), &
16823 
16824  & answer_shape(2) ) &
16825  & )
16826 
16827  allocate( check_negative( &
16828  & answer_shape(1), &
16829 
16830  & answer_shape(2) ) &
16831  & )
16832 
16833  allocate( both_negative( &
16834  & answer_shape(1), &
16835 
16836  & answer_shape(2) ) &
16837  & )
16838 
16839  answer_negative = answer < 0.0_dp
16840  check_negative = check < 0.0_dp
16841  both_negative = answer_negative .and. check_negative
16842  if (.not. negative_support_on) both_negative = .false.
16843 
16844  judge = answer > check
16845  where (both_negative) judge = .not. judge
16846 
16847  judge_rev = .not. judge
16848  err_flag = any(judge_rev)
16849  mask_array = 1
16850  pos = maxloc(mask_array, judge_rev)
16851 
16852  if (err_flag) then
16853 
16854  wrong = check( &
16855  & pos(1), &
16856 
16857  & pos(2) )
16858 
16859  right = answer( &
16860  & pos(1), &
16861 
16862  & pos(2) )
16863 
16864  write(unit=pos_array(1), fmt="(i20)") pos(1)
16865 
16866  write(unit=pos_array(2), fmt="(i20)") pos(2)
16867 
16868 
16869  pos_str = '(' // &
16870  & trim(adjustl(pos_array(1))) // ',' // &
16871 
16872  & trim(adjustl(pos_array(2))) // ')'
16873 
16874  if ( both_negative( &
16875  & pos(1), &
16876 
16877  & pos(2) ) ) then
16878 
16879  abs_mes = 'ABSOLUTE value of'
16880  else
16881  abs_mes = ''
16882 
16883  end if
16884 
16885  end if
16886  deallocate(mask_array, judge, judge_rev)
16887  deallocate(answer_negative, check_negative, both_negative)
16888 
16889 
16890 
16891 
16892  if (err_flag) then
16893  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16894  write(*,*) ''
16895  write(*,*) ' ' // trim(abs_mes) // &
16896  & ' check' // trim(pos_str) // ' = ', wrong
16897  write(*,*) ' is NOT LESS THAN'
16898  write(*,*) ' ' // trim(abs_mes) // &
16899  & ' answer' // trim(pos_str) // ' = ', right
16900 
16901  call abort()
16902  else
16903  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16904  end if
16905 
16906 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthandouble3()

subroutine dc_test::dctestassertlessthandouble3 ( character(*), intent(in)  message,
real(dp), dimension(:,:,:), intent(in)  answer,
real(dp), dimension(:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 16912 of file dc_test.f90.

References dc_types::string, and dc_types::token.

16912  use dc_types, only: string, token
16913  implicit none
16914  character(*), intent(in):: message
16915  real(DP), intent(in):: answer(:,:,:)
16916  real(DP), intent(in):: check(:,:,:)
16917  logical, intent(in), optional:: negative_support
16918  logical:: err_flag
16919  logical:: negative_support_on
16920  character(STRING):: pos_str
16921  character(TOKEN):: abs_mes
16922  real(DP):: wrong, right
16923 
16924  integer:: answer_shape(3), check_shape(3), pos(3)
16925  logical:: consist_shape(3)
16926  character(TOKEN):: pos_array(3)
16927  integer, allocatable:: mask_array(:,:,:)
16928  logical, allocatable:: judge(:,:,:)
16929  logical, allocatable:: judge_rev(:,:,:)
16930  logical, allocatable:: answer_negative(:,:,:)
16931  logical, allocatable:: check_negative(:,:,:)
16932  logical, allocatable:: both_negative(:,:,:)
16933 
16934 
16935  continue
16936  if (present(negative_support)) then
16937  negative_support_on = negative_support
16938  else
16939  negative_support_on = .true.
16940  end if
16941 
16942  err_flag = .false.
16943 
16944 
16945  answer_shape = shape(answer)
16946  check_shape = shape(check)
16947 
16948  consist_shape = answer_shape == check_shape
16949 
16950  if (.not. all(consist_shape)) then
16951  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16952  write(*,*) ''
16953  write(*,*) ' shape of check is (', check_shape, ')'
16954  write(*,*) ' is INCORRECT'
16955  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
16956 
16957  call abort()
16958  end if
16959 
16960 
16961  allocate( mask_array( &
16962  & answer_shape(1), &
16963 
16964  & answer_shape(2), &
16965 
16966  & answer_shape(3) ) &
16967  & )
16968 
16969  allocate( judge( &
16970  & answer_shape(1), &
16971 
16972  & answer_shape(2), &
16973 
16974  & answer_shape(3) ) &
16975  & )
16976 
16977  allocate( judge_rev( &
16978  & answer_shape(1), &
16979 
16980  & answer_shape(2), &
16981 
16982  & answer_shape(3) ) &
16983  & )
16984 
16985  allocate( answer_negative( &
16986  & answer_shape(1), &
16987 
16988  & answer_shape(2), &
16989 
16990  & answer_shape(3) ) &
16991  & )
16992 
16993  allocate( check_negative( &
16994  & answer_shape(1), &
16995 
16996  & answer_shape(2), &
16997 
16998  & answer_shape(3) ) &
16999  & )
17000 
17001  allocate( both_negative( &
17002  & answer_shape(1), &
17003 
17004  & answer_shape(2), &
17005 
17006  & answer_shape(3) ) &
17007  & )
17008 
17009  answer_negative = answer < 0.0_dp
17010  check_negative = check < 0.0_dp
17011  both_negative = answer_negative .and. check_negative
17012  if (.not. negative_support_on) both_negative = .false.
17013 
17014  judge = answer > check
17015  where (both_negative) judge = .not. judge
17016 
17017  judge_rev = .not. judge
17018  err_flag = any(judge_rev)
17019  mask_array = 1
17020  pos = maxloc(mask_array, judge_rev)
17021 
17022  if (err_flag) then
17023 
17024  wrong = check( &
17025  & pos(1), &
17026 
17027  & pos(2), &
17028 
17029  & pos(3) )
17030 
17031  right = answer( &
17032  & pos(1), &
17033 
17034  & pos(2), &
17035 
17036  & pos(3) )
17037 
17038  write(unit=pos_array(1), fmt="(i20)") pos(1)
17039 
17040  write(unit=pos_array(2), fmt="(i20)") pos(2)
17041 
17042  write(unit=pos_array(3), fmt="(i20)") pos(3)
17043 
17044 
17045  pos_str = '(' // &
17046  & trim(adjustl(pos_array(1))) // ',' // &
17047 
17048  & trim(adjustl(pos_array(2))) // ',' // &
17049 
17050  & trim(adjustl(pos_array(3))) // ')'
17051 
17052  if ( both_negative( &
17053  & pos(1), &
17054 
17055  & pos(2), &
17056 
17057  & pos(3) ) ) then
17058 
17059  abs_mes = 'ABSOLUTE value of'
17060  else
17061  abs_mes = ''
17062 
17063  end if
17064 
17065  end if
17066  deallocate(mask_array, judge, judge_rev)
17067  deallocate(answer_negative, check_negative, both_negative)
17068 
17069 
17070 
17071 
17072  if (err_flag) then
17073  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17074  write(*,*) ''
17075  write(*,*) ' ' // trim(abs_mes) // &
17076  & ' check' // trim(pos_str) // ' = ', wrong
17077  write(*,*) ' is NOT LESS THAN'
17078  write(*,*) ' ' // trim(abs_mes) // &
17079  & ' answer' // trim(pos_str) // ' = ', right
17080 
17081  call abort()
17082  else
17083  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
17084  end if
17085 
17086 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthandouble4()

subroutine dc_test::dctestassertlessthandouble4 ( character(*), intent(in)  message,
real(dp), dimension(:,:,:,:), intent(in)  answer,
real(dp), dimension(:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 17092 of file dc_test.f90.

References dc_types::string, and dc_types::token.

17092  use dc_types, only: string, token
17093  implicit none
17094  character(*), intent(in):: message
17095  real(DP), intent(in):: answer(:,:,:,:)
17096  real(DP), intent(in):: check(:,:,:,:)
17097  logical, intent(in), optional:: negative_support
17098  logical:: err_flag
17099  logical:: negative_support_on
17100  character(STRING):: pos_str
17101  character(TOKEN):: abs_mes
17102  real(DP):: wrong, right
17103 
17104  integer:: answer_shape(4), check_shape(4), pos(4)
17105  logical:: consist_shape(4)
17106  character(TOKEN):: pos_array(4)
17107  integer, allocatable:: mask_array(:,:,:,:)
17108  logical, allocatable:: judge(:,:,:,:)
17109  logical, allocatable:: judge_rev(:,:,:,:)
17110  logical, allocatable:: answer_negative(:,:,:,:)
17111  logical, allocatable:: check_negative(:,:,:,:)
17112  logical, allocatable:: both_negative(:,:,:,:)
17113 
17114 
17115  continue
17116  if (present(negative_support)) then
17117  negative_support_on = negative_support
17118  else
17119  negative_support_on = .true.
17120  end if
17121 
17122  err_flag = .false.
17123 
17124 
17125  answer_shape = shape(answer)
17126  check_shape = shape(check)
17127 
17128  consist_shape = answer_shape == check_shape
17129 
17130  if (.not. all(consist_shape)) then
17131  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17132  write(*,*) ''
17133  write(*,*) ' shape of check is (', check_shape, ')'
17134  write(*,*) ' is INCORRECT'
17135  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
17136 
17137  call abort()
17138  end if
17139 
17140 
17141  allocate( mask_array( &
17142  & answer_shape(1), &
17143 
17144  & answer_shape(2), &
17145 
17146  & answer_shape(3), &
17147 
17148  & answer_shape(4) ) &
17149  & )
17150 
17151  allocate( judge( &
17152  & answer_shape(1), &
17153 
17154  & answer_shape(2), &
17155 
17156  & answer_shape(3), &
17157 
17158  & answer_shape(4) ) &
17159  & )
17160 
17161  allocate( judge_rev( &
17162  & answer_shape(1), &
17163 
17164  & answer_shape(2), &
17165 
17166  & answer_shape(3), &
17167 
17168  & answer_shape(4) ) &
17169  & )
17170 
17171  allocate( answer_negative( &
17172  & answer_shape(1), &
17173 
17174  & answer_shape(2), &
17175 
17176  & answer_shape(3), &
17177 
17178  & answer_shape(4) ) &
17179  & )
17180 
17181  allocate( check_negative( &
17182  & answer_shape(1), &
17183 
17184  & answer_shape(2), &
17185 
17186  & answer_shape(3), &
17187 
17188  & answer_shape(4) ) &
17189  & )
17190 
17191  allocate( both_negative( &
17192  & answer_shape(1), &
17193 
17194  & answer_shape(2), &
17195 
17196  & answer_shape(3), &
17197 
17198  & answer_shape(4) ) &
17199  & )
17200 
17201  answer_negative = answer < 0.0_dp
17202  check_negative = check < 0.0_dp
17203  both_negative = answer_negative .and. check_negative
17204  if (.not. negative_support_on) both_negative = .false.
17205 
17206  judge = answer > check
17207  where (both_negative) judge = .not. judge
17208 
17209  judge_rev = .not. judge
17210  err_flag = any(judge_rev)
17211  mask_array = 1
17212  pos = maxloc(mask_array, judge_rev)
17213 
17214  if (err_flag) then
17215 
17216  wrong = check( &
17217  & pos(1), &
17218 
17219  & pos(2), &
17220 
17221  & pos(3), &
17222 
17223  & pos(4) )
17224 
17225  right = answer( &
17226  & pos(1), &
17227 
17228  & pos(2), &
17229 
17230  & pos(3), &
17231 
17232  & pos(4) )
17233 
17234  write(unit=pos_array(1), fmt="(i20)") pos(1)
17235 
17236  write(unit=pos_array(2), fmt="(i20)") pos(2)
17237 
17238  write(unit=pos_array(3), fmt="(i20)") pos(3)
17239 
17240  write(unit=pos_array(4), fmt="(i20)") pos(4)
17241 
17242 
17243  pos_str = '(' // &
17244  & trim(adjustl(pos_array(1))) // ',' // &
17245 
17246  & trim(adjustl(pos_array(2))) // ',' // &
17247 
17248  & trim(adjustl(pos_array(3))) // ',' // &
17249 
17250  & trim(adjustl(pos_array(4))) // ')'
17251 
17252  if ( both_negative( &
17253  & pos(1), &
17254 
17255  & pos(2), &
17256 
17257  & pos(3), &
17258 
17259  & pos(4) ) ) then
17260 
17261  abs_mes = 'ABSOLUTE value of'
17262  else
17263  abs_mes = ''
17264 
17265  end if
17266 
17267  end if
17268  deallocate(mask_array, judge, judge_rev)
17269  deallocate(answer_negative, check_negative, both_negative)
17270 
17271 
17272 
17273 
17274  if (err_flag) then
17275  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17276  write(*,*) ''
17277  write(*,*) ' ' // trim(abs_mes) // &
17278  & ' check' // trim(pos_str) // ' = ', wrong
17279  write(*,*) ' is NOT LESS THAN'
17280  write(*,*) ' ' // trim(abs_mes) // &
17281  & ' answer' // trim(pos_str) // ' = ', right
17282 
17283  call abort()
17284  else
17285  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
17286  end if
17287 
17288 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthandouble5()

subroutine dc_test::dctestassertlessthandouble5 ( character(*), intent(in)  message,
real(dp), dimension(:,:,:,:,:), intent(in)  answer,
real(dp), dimension(:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 17294 of file dc_test.f90.

References dc_types::string, and dc_types::token.

17294  use dc_types, only: string, token
17295  implicit none
17296  character(*), intent(in):: message
17297  real(DP), intent(in):: answer(:,:,:,:,:)
17298  real(DP), intent(in):: check(:,:,:,:,:)
17299  logical, intent(in), optional:: negative_support
17300  logical:: err_flag
17301  logical:: negative_support_on
17302  character(STRING):: pos_str
17303  character(TOKEN):: abs_mes
17304  real(DP):: wrong, right
17305 
17306  integer:: answer_shape(5), check_shape(5), pos(5)
17307  logical:: consist_shape(5)
17308  character(TOKEN):: pos_array(5)
17309  integer, allocatable:: mask_array(:,:,:,:,:)
17310  logical, allocatable:: judge(:,:,:,:,:)
17311  logical, allocatable:: judge_rev(:,:,:,:,:)
17312  logical, allocatable:: answer_negative(:,:,:,:,:)
17313  logical, allocatable:: check_negative(:,:,:,:,:)
17314  logical, allocatable:: both_negative(:,:,:,:,:)
17315 
17316 
17317  continue
17318  if (present(negative_support)) then
17319  negative_support_on = negative_support
17320  else
17321  negative_support_on = .true.
17322  end if
17323 
17324  err_flag = .false.
17325 
17326 
17327  answer_shape = shape(answer)
17328  check_shape = shape(check)
17329 
17330  consist_shape = answer_shape == check_shape
17331 
17332  if (.not. all(consist_shape)) then
17333  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17334  write(*,*) ''
17335  write(*,*) ' shape of check is (', check_shape, ')'
17336  write(*,*) ' is INCORRECT'
17337  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
17338 
17339  call abort()
17340  end if
17341 
17342 
17343  allocate( mask_array( &
17344  & answer_shape(1), &
17345 
17346  & answer_shape(2), &
17347 
17348  & answer_shape(3), &
17349 
17350  & answer_shape(4), &
17351 
17352  & answer_shape(5) ) &
17353  & )
17354 
17355  allocate( judge( &
17356  & answer_shape(1), &
17357 
17358  & answer_shape(2), &
17359 
17360  & answer_shape(3), &
17361 
17362  & answer_shape(4), &
17363 
17364  & answer_shape(5) ) &
17365  & )
17366 
17367  allocate( judge_rev( &
17368  & answer_shape(1), &
17369 
17370  & answer_shape(2), &
17371 
17372  & answer_shape(3), &
17373 
17374  & answer_shape(4), &
17375 
17376  & answer_shape(5) ) &
17377  & )
17378 
17379  allocate( answer_negative( &
17380  & answer_shape(1), &
17381 
17382  & answer_shape(2), &
17383 
17384  & answer_shape(3), &
17385 
17386  & answer_shape(4), &
17387 
17388  & answer_shape(5) ) &
17389  & )
17390 
17391  allocate( check_negative( &
17392  & answer_shape(1), &
17393 
17394  & answer_shape(2), &
17395 
17396  & answer_shape(3), &
17397 
17398  & answer_shape(4), &
17399 
17400  & answer_shape(5) ) &
17401  & )
17402 
17403  allocate( both_negative( &
17404  & answer_shape(1), &
17405 
17406  & answer_shape(2), &
17407 
17408  & answer_shape(3), &
17409 
17410  & answer_shape(4), &
17411 
17412  & answer_shape(5) ) &
17413  & )
17414 
17415  answer_negative = answer < 0.0_dp
17416  check_negative = check < 0.0_dp
17417  both_negative = answer_negative .and. check_negative
17418  if (.not. negative_support_on) both_negative = .false.
17419 
17420  judge = answer > check
17421  where (both_negative) judge = .not. judge
17422 
17423  judge_rev = .not. judge
17424  err_flag = any(judge_rev)
17425  mask_array = 1
17426  pos = maxloc(mask_array, judge_rev)
17427 
17428  if (err_flag) then
17429 
17430  wrong = check( &
17431  & pos(1), &
17432 
17433  & pos(2), &
17434 
17435  & pos(3), &
17436 
17437  & pos(4), &
17438 
17439  & pos(5) )
17440 
17441  right = answer( &
17442  & pos(1), &
17443 
17444  & pos(2), &
17445 
17446  & pos(3), &
17447 
17448  & pos(4), &
17449 
17450  & pos(5) )
17451 
17452  write(unit=pos_array(1), fmt="(i20)") pos(1)
17453 
17454  write(unit=pos_array(2), fmt="(i20)") pos(2)
17455 
17456  write(unit=pos_array(3), fmt="(i20)") pos(3)
17457 
17458  write(unit=pos_array(4), fmt="(i20)") pos(4)
17459 
17460  write(unit=pos_array(5), fmt="(i20)") pos(5)
17461 
17462 
17463  pos_str = '(' // &
17464  & trim(adjustl(pos_array(1))) // ',' // &
17465 
17466  & trim(adjustl(pos_array(2))) // ',' // &
17467 
17468  & trim(adjustl(pos_array(3))) // ',' // &
17469 
17470  & trim(adjustl(pos_array(4))) // ',' // &
17471 
17472  & trim(adjustl(pos_array(5))) // ')'
17473 
17474  if ( both_negative( &
17475  & pos(1), &
17476 
17477  & pos(2), &
17478 
17479  & pos(3), &
17480 
17481  & pos(4), &
17482 
17483  & pos(5) ) ) then
17484 
17485  abs_mes = 'ABSOLUTE value of'
17486  else
17487  abs_mes = ''
17488 
17489  end if
17490 
17491  end if
17492  deallocate(mask_array, judge, judge_rev)
17493  deallocate(answer_negative, check_negative, both_negative)
17494 
17495 
17496 
17497 
17498  if (err_flag) then
17499  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17500  write(*,*) ''
17501  write(*,*) ' ' // trim(abs_mes) // &
17502  & ' check' // trim(pos_str) // ' = ', wrong
17503  write(*,*) ' is NOT LESS THAN'
17504  write(*,*) ' ' // trim(abs_mes) // &
17505  & ' answer' // trim(pos_str) // ' = ', right
17506 
17507  call abort()
17508  else
17509  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
17510  end if
17511 
17512 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthandouble6()

subroutine dc_test::dctestassertlessthandouble6 ( character(*), intent(in)  message,
real(dp), dimension(:,:,:,:,:,:), intent(in)  answer,
real(dp), dimension(:,:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 17518 of file dc_test.f90.

References dc_types::string, and dc_types::token.

17518  use dc_types, only: string, token
17519  implicit none
17520  character(*), intent(in):: message
17521  real(DP), intent(in):: answer(:,:,:,:,:,:)
17522  real(DP), intent(in):: check(:,:,:,:,:,:)
17523  logical, intent(in), optional:: negative_support
17524  logical:: err_flag
17525  logical:: negative_support_on
17526  character(STRING):: pos_str
17527  character(TOKEN):: abs_mes
17528  real(DP):: wrong, right
17529 
17530  integer:: answer_shape(6), check_shape(6), pos(6)
17531  logical:: consist_shape(6)
17532  character(TOKEN):: pos_array(6)
17533  integer, allocatable:: mask_array(:,:,:,:,:,:)
17534  logical, allocatable:: judge(:,:,:,:,:,:)
17535  logical, allocatable:: judge_rev(:,:,:,:,:,:)
17536  logical, allocatable:: answer_negative(:,:,:,:,:,:)
17537  logical, allocatable:: check_negative(:,:,:,:,:,:)
17538  logical, allocatable:: both_negative(:,:,:,:,:,:)
17539 
17540 
17541  continue
17542  if (present(negative_support)) then
17543  negative_support_on = negative_support
17544  else
17545  negative_support_on = .true.
17546  end if
17547 
17548  err_flag = .false.
17549 
17550 
17551  answer_shape = shape(answer)
17552  check_shape = shape(check)
17553 
17554  consist_shape = answer_shape == check_shape
17555 
17556  if (.not. all(consist_shape)) then
17557  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17558  write(*,*) ''
17559  write(*,*) ' shape of check is (', check_shape, ')'
17560  write(*,*) ' is INCORRECT'
17561  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
17562 
17563  call abort()
17564  end if
17565 
17566 
17567  allocate( mask_array( &
17568  & answer_shape(1), &
17569 
17570  & answer_shape(2), &
17571 
17572  & answer_shape(3), &
17573 
17574  & answer_shape(4), &
17575 
17576  & answer_shape(5), &
17577 
17578  & answer_shape(6) ) &
17579  & )
17580 
17581  allocate( judge( &
17582  & answer_shape(1), &
17583 
17584  & answer_shape(2), &
17585 
17586  & answer_shape(3), &
17587 
17588  & answer_shape(4), &
17589 
17590  & answer_shape(5), &
17591 
17592  & answer_shape(6) ) &
17593  & )
17594 
17595  allocate( judge_rev( &
17596  & answer_shape(1), &
17597 
17598  & answer_shape(2), &
17599 
17600  & answer_shape(3), &
17601 
17602  & answer_shape(4), &
17603 
17604  & answer_shape(5), &
17605 
17606  & answer_shape(6) ) &
17607  & )
17608 
17609  allocate( answer_negative( &
17610  & answer_shape(1), &
17611 
17612  & answer_shape(2), &
17613 
17614  & answer_shape(3), &
17615 
17616  & answer_shape(4), &
17617 
17618  & answer_shape(5), &
17619 
17620  & answer_shape(6) ) &
17621  & )
17622 
17623  allocate( check_negative( &
17624  & answer_shape(1), &
17625 
17626  & answer_shape(2), &
17627 
17628  & answer_shape(3), &
17629 
17630  & answer_shape(4), &
17631 
17632  & answer_shape(5), &
17633 
17634  & answer_shape(6) ) &
17635  & )
17636 
17637  allocate( both_negative( &
17638  & answer_shape(1), &
17639 
17640  & answer_shape(2), &
17641 
17642  & answer_shape(3), &
17643 
17644  & answer_shape(4), &
17645 
17646  & answer_shape(5), &
17647 
17648  & answer_shape(6) ) &
17649  & )
17650 
17651  answer_negative = answer < 0.0_dp
17652  check_negative = check < 0.0_dp
17653  both_negative = answer_negative .and. check_negative
17654  if (.not. negative_support_on) both_negative = .false.
17655 
17656  judge = answer > check
17657  where (both_negative) judge = .not. judge
17658 
17659  judge_rev = .not. judge
17660  err_flag = any(judge_rev)
17661  mask_array = 1
17662  pos = maxloc(mask_array, judge_rev)
17663 
17664  if (err_flag) then
17665 
17666  wrong = check( &
17667  & pos(1), &
17668 
17669  & pos(2), &
17670 
17671  & pos(3), &
17672 
17673  & pos(4), &
17674 
17675  & pos(5), &
17676 
17677  & pos(6) )
17678 
17679  right = answer( &
17680  & pos(1), &
17681 
17682  & pos(2), &
17683 
17684  & pos(3), &
17685 
17686  & pos(4), &
17687 
17688  & pos(5), &
17689 
17690  & pos(6) )
17691 
17692  write(unit=pos_array(1), fmt="(i20)") pos(1)
17693 
17694  write(unit=pos_array(2), fmt="(i20)") pos(2)
17695 
17696  write(unit=pos_array(3), fmt="(i20)") pos(3)
17697 
17698  write(unit=pos_array(4), fmt="(i20)") pos(4)
17699 
17700  write(unit=pos_array(5), fmt="(i20)") pos(5)
17701 
17702  write(unit=pos_array(6), fmt="(i20)") pos(6)
17703 
17704 
17705  pos_str = '(' // &
17706  & trim(adjustl(pos_array(1))) // ',' // &
17707 
17708  & trim(adjustl(pos_array(2))) // ',' // &
17709 
17710  & trim(adjustl(pos_array(3))) // ',' // &
17711 
17712  & trim(adjustl(pos_array(4))) // ',' // &
17713 
17714  & trim(adjustl(pos_array(5))) // ',' // &
17715 
17716  & trim(adjustl(pos_array(6))) // ')'
17717 
17718  if ( both_negative( &
17719  & pos(1), &
17720 
17721  & pos(2), &
17722 
17723  & pos(3), &
17724 
17725  & pos(4), &
17726 
17727  & pos(5), &
17728 
17729  & pos(6) ) ) then
17730 
17731  abs_mes = 'ABSOLUTE value of'
17732  else
17733  abs_mes = ''
17734 
17735  end if
17736 
17737  end if
17738  deallocate(mask_array, judge, judge_rev)
17739  deallocate(answer_negative, check_negative, both_negative)
17740 
17741 
17742 
17743 
17744  if (err_flag) then
17745  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17746  write(*,*) ''
17747  write(*,*) ' ' // trim(abs_mes) // &
17748  & ' check' // trim(pos_str) // ' = ', wrong
17749  write(*,*) ' is NOT LESS THAN'
17750  write(*,*) ' ' // trim(abs_mes) // &
17751  & ' answer' // trim(pos_str) // ' = ', right
17752 
17753  call abort()
17754  else
17755  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
17756  end if
17757 
17758 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12

◆ dctestassertlessthandouble7()

subroutine dc_test::dctestassertlessthandouble7 ( character(*), intent(in)  message,
real(dp), dimension(:,:,:,:,:,:,:), intent(in)  answer,
real(dp), dimension(:,:,:,:,:,:,:), intent(in)  check,
logical, intent(in), optional  negative_support 
)

Definition at line 17764 of file dc_test.f90.

References dc_types::string, and dc_types::token.

17764  use dc_types, only: string, token
17765  implicit none
17766  character(*), intent(in):: message
17767  real(DP), intent(in):: answer(:,:,:,:,:,:,:)
17768  real(DP), intent(in):: check(:,:,:,:,:,:,:)
17769  logical, intent(in), optional:: negative_support
17770  logical:: err_flag
17771  logical:: negative_support_on
17772  character(STRING):: pos_str
17773  character(TOKEN):: abs_mes
17774  real(DP):: wrong, right
17775 
17776  integer:: answer_shape(7), check_shape(7), pos(7)
17777  logical:: consist_shape(7)
17778  character(TOKEN):: pos_array(7)
17779  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
17780  logical, allocatable:: judge(:,:,:,:,:,:,:)
17781  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
17782  logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
17783  logical, allocatable:: check_negative(:,:,:,:,:,:,:)
17784  logical, allocatable:: both_negative(:,:,:,:,:,:,:)
17785 
17786 
17787  continue
17788  if (present(negative_support)) then
17789  negative_support_on = negative_support
17790  else
17791  negative_support_on = .true.
17792  end if
17793 
17794  err_flag = .false.
17795 
17796 
17797  answer_shape = shape(answer)
17798  check_shape = shape(check)
17799 
17800  consist_shape = answer_shape == check_shape
17801 
17802  if (.not. all(consist_shape)) then
17803  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17804  write(*,*) ''
17805  write(*,*) ' shape of check is (', check_shape, ')'
17806  write(*,*) ' is INCORRECT'
17807  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
17808 
17809  call abort()
17810  end if
17811 
17812 
17813  allocate( mask_array( &
17814  & answer_shape(1), &
17815 
17816  & answer_shape(2), &
17817 
17818  & answer_shape(3), &
17819 
17820  & answer_shape(4), &
17821 
17822  & answer_shape(5), &
17823 
17824  & answer_shape(6), &
17825 
17826  & answer_shape(7) ) &
17827  & )
17828 
17829  allocate( judge( &
17830  & answer_shape(1), &
17831 
17832  & answer_shape(2), &
17833 
17834  & answer_shape(3), &
17835 
17836  & answer_shape(4), &
17837 
17838  & answer_shape(5), &
17839 
17840  & answer_shape(6), &
17841 
17842  & answer_shape(7) ) &
17843  & )
17844 
17845  allocate( judge_rev( &
17846  & answer_shape(1), &
17847 
17848  & answer_shape(2), &
17849 
17850  & answer_shape(3), &
17851 
17852  & answer_shape(4), &
17853 
17854  & answer_shape(5), &
17855 
17856  & answer_shape(6), &
17857 
17858  & answer_shape(7) ) &
17859  & )
17860 
17861  allocate( answer_negative( &
17862  & answer_shape(1), &
17863 
17864  & answer_shape(2), &
17865 
17866  & answer_shape(3), &
17867 
17868  & answer_shape(4), &
17869 
17870  & answer_shape(5), &
17871 
17872  & answer_shape(6), &
17873 
17874  & answer_shape(7) ) &
17875  & )
17876 
17877  allocate( check_negative( &
17878  & answer_shape(1), &
17879 
17880  & answer_shape(2), &
17881 
17882  & answer_shape(3), &
17883 
17884  & answer_shape(4), &
17885 
17886  & answer_shape(5), &
17887 
17888  & answer_shape(6), &
17889 
17890  & answer_shape(7) ) &
17891  & )
17892 
17893  allocate( both_negative( &
17894  & answer_shape(1), &
17895 
17896  & answer_shape(2), &
17897 
17898  & answer_shape(3), &
17899 
17900  & answer_shape(4), &
17901 
17902  & answer_shape(5), &
17903 
17904  & answer_shape(6), &
17905 
17906  & answer_shape(7) ) &
17907  & )
17908 
17909  answer_negative = answer < 0.0_dp
17910  check_negative = check < 0.0_dp
17911  both_negative = answer_negative .and. check_negative
17912  if (.not. negative_support_on) both_negative = .false.
17913 
17914  judge = answer > check
17915  where (both_negative) judge = .not. judge
17916 
17917  judge_rev = .not. judge
17918  err_flag = any(judge_rev)
17919  mask_array = 1
17920  pos = maxloc(mask_array, judge_rev)
17921 
17922  if (err_flag) then
17923 
17924  wrong = check( &
17925  & pos(1), &
17926 
17927  & pos(2), &
17928 
17929  & pos(3), &
17930 
17931  & pos(4), &
17932 
17933  & pos(5), &
17934 
17935  & pos(6), &
17936 
17937  & pos(7) )
17938 
17939  right = answer( &
17940  & pos(1), &
17941 
17942  & pos(2), &
17943 
17944  & pos(3), &
17945 
17946  & pos(4), &
17947 
17948  & pos(5), &
17949 
17950  & pos(6), &
17951 
17952  & pos(7) )
17953 
17954  write(unit=pos_array(1), fmt="(i20)") pos(1)
17955 
17956  write(unit=pos_array(2), fmt="(i20)") pos(2)
17957 
17958  write(unit=pos_array(3), fmt="(i20)") pos(3)
17959 
17960  write(unit=pos_array(4), fmt="(i20)") pos(4)
17961 
17962  write(unit=pos_array(5), fmt="(i20)") pos(5)
17963 
17964  write(unit=pos_array(6), fmt="(i20)") pos(6)
17965 
17966  write(unit=pos_array(7), fmt="(i20)") pos(7)
17967 
17968 
17969  pos_str = '(' // &
17970  & trim(adjustl(pos_array(1))) // ',' // &
17971 
17972  & trim(adjustl(pos_array(2))) // ',' // &
17973 
17974  & trim(adjustl(pos_array(3))) // ',' // &
17975 
17976  & trim(adjustl(pos_array(4))) // ',' // &
17977 
17978  & trim(adjustl(pos_array(5))) // ',' // &
17979 
17980  & trim(adjustl(pos_array(6))) // ',' // &
17981 
17982  & trim(adjustl(pos_array(7))) // ')'
17983 
17984  if ( both_negative( &
17985  & pos(1), &
17986 
17987  & pos(2), &
17988 
17989  & pos(3), &
17990 
17991  & pos(4), &
17992 
17993  & pos(5), &
17994 
17995  & pos(6), &
17996 
17997  & pos(7) ) ) then
17998 
17999  abs_mes = 'ABSOLUTE value of'
18000  else
18001  abs_mes = ''
18002 
18003  end if
18004 
18005  end if
18006  deallocate(mask_array, judge, judge_rev)
18007  deallocate(answer_negative, check_negative, both_negative)
18008 
18009 
18010 
18011 
18012  if (err_flag) then
18013  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
18014  write(*,*) ''
18015  write(*,*) ' ' // trim(abs_mes) // &
18016  & ' check' // trim(pos_str) // ' = ', wrong
18017  write(*,*) ' is NOT LESS THAN'
18018  write(*,*) ' ' // trim(abs_mes) // &
18019  & ' answer' // trim(pos_str) // ' = ', right
18020 
18021  call abort()
18022  else
18023  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
18024  end if
18025 
18026 
dc_types::token
integer, parameter, public token
Definition: dc_types.f90:32
dc_types::string
integer, parameter, public string
Definition: dc_types.f90:37
dc_types
Definition: dc_types.f90:12
Generated by   doxygen 1.8.13