dc_test::assertlessthan Interface Reference
Public Member Functions | |
| 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) |
Detailed Description
Definition at line 338 of file dc_test.f90.
Member Function/Subroutine Documentation
◆ dctestassertlessthandouble0()
| subroutine dc_test::assertlessthan::dctestassertlessthandouble0 | ( | character(*), intent(in) | message, |
| real(dp), intent(in) | answer, | ||
| real(dp), intent(in) | check, | ||
| logical, intent(in), optional | negative_support ) |
Definition at line 16520 of file dc_test.f90.
16524 implicit none
16525 character(*), intent(in):: message
16526 real(DP), intent(in):: answer
16527 real(DP), intent(in):: check
16528 logical, intent(in), optional:: negative_support
16529 logical:: err_flag
16530 logical:: negative_support_on
16531 character(STRING):: pos_str
16532 character(TOKEN):: abs_mes
16533 real(DP):: wrong, right
16534
16535
16536
16537 continue
16538 if (present(negative_support)) then
16539 negative_support_on = negative_support
16540 else
16541 negative_support_on = .true.
16542 end if
16543
16544 err_flag = .false.
16545
16546
16547
16548
16549 err_flag = .not. answer > check
16550 abs_mes = ''
16551
16552 if ( answer < 0.0_dp &
16553 & .and. check < 0.0_dp &
16554 & .and. negative_support_on ) then
16555
16556 err_flag = .not. err_flag
16557 abs_mes = 'ABSOLUTE value of'
16558 end if
16559
16560 wrong = check
16561 right = answer
16562 pos_str = ''
16563
16564
16565
16566
16567 if (err_flag) then
16568 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16569 write(*,*) ''
16570 write(*,*) ' ' // trim(abs_mes) // &
16571 & ' check' // trim(pos_str) // ' = ', wrong
16572 write(*,*) ' is NOT LESS THAN'
16573 write(*,*) ' ' // trim(abs_mes) // &
16574 & ' answer' // trim(pos_str) // ' = ', right
16575
16577 else
16578 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16579 end if
16580
16581
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
◆ dctestassertlessthandouble1()
| subroutine dc_test::assertlessthan::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 16585 of file dc_test.f90.
16589 implicit none
16590 character(*), intent(in):: message
16591 real(DP), intent(in):: answer(:)
16592 real(DP), intent(in):: check(:)
16593 logical, intent(in), optional:: negative_support
16594 logical:: err_flag
16595 logical:: negative_support_on
16596 character(STRING):: pos_str
16597 character(TOKEN):: abs_mes
16598 real(DP):: wrong, right
16599
16600 integer:: answer_shape(1), check_shape(1), pos(1)
16601 logical:: consist_shape(1)
16602 character(TOKEN):: pos_array(1)
16603 integer, allocatable:: mask_array(:)
16604 logical, allocatable:: judge(:)
16605 logical, allocatable:: judge_rev(:)
16606 logical, allocatable:: answer_negative(:)
16607 logical, allocatable:: check_negative(:)
16608 logical, allocatable:: both_negative(:)
16609
16610
16611 continue
16612 if (present(negative_support)) then
16613 negative_support_on = negative_support
16614 else
16615 negative_support_on = .true.
16616 end if
16617
16618 err_flag = .false.
16619
16620
16621 answer_shape = shape(answer)
16622 check_shape = shape(check)
16623
16624 consist_shape = answer_shape == check_shape
16625
16626 if (.not. all(consist_shape)) then
16627 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16628 write(*,*) ''
16629 write(*,*) ' shape of check is (', check_shape, ')'
16630 write(*,*) ' is INCORRECT'
16631 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
16632
16634 end if
16635
16636
16637 allocate( mask_array( &
16638
16639 & answer_shape(1) ) &
16640 & )
16641
16642 allocate( judge( &
16643
16644 & answer_shape(1) ) &
16645 & )
16646
16647 allocate( judge_rev( &
16648
16649 & answer_shape(1) ) &
16650 & )
16651
16652 allocate( answer_negative( &
16653
16654 & answer_shape(1) ) &
16655 & )
16656
16657 allocate( check_negative( &
16658
16659 & answer_shape(1) ) &
16660 & )
16661
16662 allocate( both_negative( &
16663
16664 & answer_shape(1) ) &
16665 & )
16666
16667 answer_negative = answer < 0.0_dp
16668 check_negative = check < 0.0_dp
16669 both_negative = answer_negative .and. check_negative
16670 if (.not. negative_support_on) both_negative = .false.
16671
16672 judge = answer > check
16673 where (both_negative) judge = .not. judge
16674
16675 judge_rev = .not. judge
16676 err_flag = any(judge_rev)
16677 mask_array = 1
16678 pos = maxloc(mask_array, judge_rev)
16679
16680 if (err_flag) then
16681
16682 wrong = check( &
16683
16684 & pos(1) )
16685
16686 right = answer( &
16687
16688 & pos(1) )
16689
16690 write(unit=pos_array(1), fmt="(i20)") pos(1)
16691
16692
16693 pos_str = '(' // &
16694
16695 & trim(adjustl(pos_array(1))) // ')'
16696
16697 if ( both_negative( &
16698
16699 & pos(1) ) ) then
16700
16701 abs_mes = 'ABSOLUTE value of'
16702 else
16703 abs_mes = ''
16704
16705 end if
16706
16707 end if
16708 deallocate(mask_array, judge, judge_rev)
16709 deallocate(answer_negative, check_negative, both_negative)
16710
16711
16712
16713
16714 if (err_flag) then
16715 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16716 write(*,*) ''
16717 write(*,*) ' ' // trim(abs_mes) // &
16718 & ' check' // trim(pos_str) // ' = ', wrong
16719 write(*,*) ' is NOT LESS THAN'
16720 write(*,*) ' ' // trim(abs_mes) // &
16721 & ' answer' // trim(pos_str) // ' = ', right
16722
16724 else
16725 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16726 end if
16727
16728
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
◆ dctestassertlessthandouble2()
| subroutine dc_test::assertlessthan::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 16732 of file dc_test.f90.
16736 implicit none
16737 character(*), intent(in):: message
16738 real(DP), intent(in):: answer(:,:)
16739 real(DP), intent(in):: check(:,:)
16740 logical, intent(in), optional:: negative_support
16741 logical:: err_flag
16742 logical:: negative_support_on
16743 character(STRING):: pos_str
16744 character(TOKEN):: abs_mes
16745 real(DP):: wrong, right
16746
16747 integer:: answer_shape(2), check_shape(2), pos(2)
16748 logical:: consist_shape(2)
16749 character(TOKEN):: pos_array(2)
16750 integer, allocatable:: mask_array(:,:)
16751 logical, allocatable:: judge(:,:)
16752 logical, allocatable:: judge_rev(:,:)
16753 logical, allocatable:: answer_negative(:,:)
16754 logical, allocatable:: check_negative(:,:)
16755 logical, allocatable:: both_negative(:,:)
16756
16757
16758 continue
16759 if (present(negative_support)) then
16760 negative_support_on = negative_support
16761 else
16762 negative_support_on = .true.
16763 end if
16764
16765 err_flag = .false.
16766
16767
16768 answer_shape = shape(answer)
16769 check_shape = shape(check)
16770
16771 consist_shape = answer_shape == check_shape
16772
16773 if (.not. all(consist_shape)) then
16774 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16775 write(*,*) ''
16776 write(*,*) ' shape of check is (', check_shape, ')'
16777 write(*,*) ' is INCORRECT'
16778 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
16779
16781 end if
16782
16783
16784 allocate( mask_array( &
16785 & answer_shape(1), &
16786
16787 & answer_shape(2) ) &
16788 & )
16789
16790 allocate( judge( &
16791 & answer_shape(1), &
16792
16793 & answer_shape(2) ) &
16794 & )
16795
16796 allocate( judge_rev( &
16797 & answer_shape(1), &
16798
16799 & answer_shape(2) ) &
16800 & )
16801
16802 allocate( answer_negative( &
16803 & answer_shape(1), &
16804
16805 & answer_shape(2) ) &
16806 & )
16807
16808 allocate( check_negative( &
16809 & answer_shape(1), &
16810
16811 & answer_shape(2) ) &
16812 & )
16813
16814 allocate( both_negative( &
16815 & answer_shape(1), &
16816
16817 & answer_shape(2) ) &
16818 & )
16819
16820 answer_negative = answer < 0.0_dp
16821 check_negative = check < 0.0_dp
16822 both_negative = answer_negative .and. check_negative
16823 if (.not. negative_support_on) both_negative = .false.
16824
16825 judge = answer > check
16826 where (both_negative) judge = .not. judge
16827
16828 judge_rev = .not. judge
16829 err_flag = any(judge_rev)
16830 mask_array = 1
16831 pos = maxloc(mask_array, judge_rev)
16832
16833 if (err_flag) then
16834
16835 wrong = check( &
16836 & pos(1), &
16837
16838 & pos(2) )
16839
16840 right = answer( &
16841 & pos(1), &
16842
16843 & pos(2) )
16844
16845 write(unit=pos_array(1), fmt="(i20)") pos(1)
16846
16847 write(unit=pos_array(2), fmt="(i20)") pos(2)
16848
16849
16850 pos_str = '(' // &
16851 & trim(adjustl(pos_array(1))) // ',' // &
16852
16853 & trim(adjustl(pos_array(2))) // ')'
16854
16855 if ( both_negative( &
16856 & pos(1), &
16857
16858 & pos(2) ) ) then
16859
16860 abs_mes = 'ABSOLUTE value of'
16861 else
16862 abs_mes = ''
16863
16864 end if
16865
16866 end if
16867 deallocate(mask_array, judge, judge_rev)
16868 deallocate(answer_negative, check_negative, both_negative)
16869
16870
16871
16872
16873 if (err_flag) then
16874 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16875 write(*,*) ''
16876 write(*,*) ' ' // trim(abs_mes) // &
16877 & ' check' // trim(pos_str) // ' = ', wrong
16878 write(*,*) ' is NOT LESS THAN'
16879 write(*,*) ' ' // trim(abs_mes) // &
16880 & ' answer' // trim(pos_str) // ' = ', right
16881
16883 else
16884 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16885 end if
16886
16887
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
◆ dctestassertlessthandouble3()
| subroutine dc_test::assertlessthan::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 16891 of file dc_test.f90.
16895 implicit none
16896 character(*), intent(in):: message
16897 real(DP), intent(in):: answer(:,:,:)
16898 real(DP), intent(in):: check(:,:,:)
16899 logical, intent(in), optional:: negative_support
16900 logical:: err_flag
16901 logical:: negative_support_on
16902 character(STRING):: pos_str
16903 character(TOKEN):: abs_mes
16904 real(DP):: wrong, right
16905
16906 integer:: answer_shape(3), check_shape(3), pos(3)
16907 logical:: consist_shape(3)
16908 character(TOKEN):: pos_array(3)
16909 integer, allocatable:: mask_array(:,:,:)
16910 logical, allocatable:: judge(:,:,:)
16911 logical, allocatable:: judge_rev(:,:,:)
16912 logical, allocatable:: answer_negative(:,:,:)
16913 logical, allocatable:: check_negative(:,:,:)
16914 logical, allocatable:: both_negative(:,:,:)
16915
16916
16917 continue
16918 if (present(negative_support)) then
16919 negative_support_on = negative_support
16920 else
16921 negative_support_on = .true.
16922 end if
16923
16924 err_flag = .false.
16925
16926
16927 answer_shape = shape(answer)
16928 check_shape = shape(check)
16929
16930 consist_shape = answer_shape == check_shape
16931
16932 if (.not. all(consist_shape)) then
16933 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16934 write(*,*) ''
16935 write(*,*) ' shape of check is (', check_shape, ')'
16936 write(*,*) ' is INCORRECT'
16937 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
16938
16940 end if
16941
16942
16943 allocate( mask_array( &
16944 & answer_shape(1), &
16945
16946 & answer_shape(2), &
16947
16948 & answer_shape(3) ) &
16949 & )
16950
16951 allocate( judge( &
16952 & answer_shape(1), &
16953
16954 & answer_shape(2), &
16955
16956 & answer_shape(3) ) &
16957 & )
16958
16959 allocate( judge_rev( &
16960 & answer_shape(1), &
16961
16962 & answer_shape(2), &
16963
16964 & answer_shape(3) ) &
16965 & )
16966
16967 allocate( answer_negative( &
16968 & answer_shape(1), &
16969
16970 & answer_shape(2), &
16971
16972 & answer_shape(3) ) &
16973 & )
16974
16975 allocate( check_negative( &
16976 & answer_shape(1), &
16977
16978 & answer_shape(2), &
16979
16980 & answer_shape(3) ) &
16981 & )
16982
16983 allocate( both_negative( &
16984 & answer_shape(1), &
16985
16986 & answer_shape(2), &
16987
16988 & answer_shape(3) ) &
16989 & )
16990
16991 answer_negative = answer < 0.0_dp
16992 check_negative = check < 0.0_dp
16993 both_negative = answer_negative .and. check_negative
16994 if (.not. negative_support_on) both_negative = .false.
16995
16996 judge = answer > check
16997 where (both_negative) judge = .not. judge
16998
16999 judge_rev = .not. judge
17000 err_flag = any(judge_rev)
17001 mask_array = 1
17002 pos = maxloc(mask_array, judge_rev)
17003
17004 if (err_flag) then
17005
17006 wrong = check( &
17007 & pos(1), &
17008
17009 & pos(2), &
17010
17011 & pos(3) )
17012
17013 right = answer( &
17014 & pos(1), &
17015
17016 & pos(2), &
17017
17018 & pos(3) )
17019
17020 write(unit=pos_array(1), fmt="(i20)") pos(1)
17021
17022 write(unit=pos_array(2), fmt="(i20)") pos(2)
17023
17024 write(unit=pos_array(3), fmt="(i20)") pos(3)
17025
17026
17027 pos_str = '(' // &
17028 & trim(adjustl(pos_array(1))) // ',' // &
17029
17030 & trim(adjustl(pos_array(2))) // ',' // &
17031
17032 & trim(adjustl(pos_array(3))) // ')'
17033
17034 if ( both_negative( &
17035 & pos(1), &
17036
17037 & pos(2), &
17038
17039 & pos(3) ) ) then
17040
17041 abs_mes = 'ABSOLUTE value of'
17042 else
17043 abs_mes = ''
17044
17045 end if
17046
17047 end if
17048 deallocate(mask_array, judge, judge_rev)
17049 deallocate(answer_negative, check_negative, both_negative)
17050
17051
17052
17053
17054 if (err_flag) then
17055 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17056 write(*,*) ''
17057 write(*,*) ' ' // trim(abs_mes) // &
17058 & ' check' // trim(pos_str) // ' = ', wrong
17059 write(*,*) ' is NOT LESS THAN'
17060 write(*,*) ' ' // trim(abs_mes) // &
17061 & ' answer' // trim(pos_str) // ' = ', right
17062
17064 else
17065 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
17066 end if
17067
17068
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
◆ dctestassertlessthandouble4()
| subroutine dc_test::assertlessthan::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 17072 of file dc_test.f90.
17076 implicit none
17077 character(*), intent(in):: message
17078 real(DP), intent(in):: answer(:,:,:,:)
17079 real(DP), intent(in):: check(:,:,:,:)
17080 logical, intent(in), optional:: negative_support
17081 logical:: err_flag
17082 logical:: negative_support_on
17083 character(STRING):: pos_str
17084 character(TOKEN):: abs_mes
17085 real(DP):: wrong, right
17086
17087 integer:: answer_shape(4), check_shape(4), pos(4)
17088 logical:: consist_shape(4)
17089 character(TOKEN):: pos_array(4)
17090 integer, allocatable:: mask_array(:,:,:,:)
17091 logical, allocatable:: judge(:,:,:,:)
17092 logical, allocatable:: judge_rev(:,:,:,:)
17093 logical, allocatable:: answer_negative(:,:,:,:)
17094 logical, allocatable:: check_negative(:,:,:,:)
17095 logical, allocatable:: both_negative(:,:,:,:)
17096
17097
17098 continue
17099 if (present(negative_support)) then
17100 negative_support_on = negative_support
17101 else
17102 negative_support_on = .true.
17103 end if
17104
17105 err_flag = .false.
17106
17107
17108 answer_shape = shape(answer)
17109 check_shape = shape(check)
17110
17111 consist_shape = answer_shape == check_shape
17112
17113 if (.not. all(consist_shape)) then
17114 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17115 write(*,*) ''
17116 write(*,*) ' shape of check is (', check_shape, ')'
17117 write(*,*) ' is INCORRECT'
17118 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
17119
17121 end if
17122
17123
17124 allocate( mask_array( &
17125 & answer_shape(1), &
17126
17127 & answer_shape(2), &
17128
17129 & answer_shape(3), &
17130
17131 & answer_shape(4) ) &
17132 & )
17133
17134 allocate( judge( &
17135 & answer_shape(1), &
17136
17137 & answer_shape(2), &
17138
17139 & answer_shape(3), &
17140
17141 & answer_shape(4) ) &
17142 & )
17143
17144 allocate( judge_rev( &
17145 & answer_shape(1), &
17146
17147 & answer_shape(2), &
17148
17149 & answer_shape(3), &
17150
17151 & answer_shape(4) ) &
17152 & )
17153
17154 allocate( answer_negative( &
17155 & answer_shape(1), &
17156
17157 & answer_shape(2), &
17158
17159 & answer_shape(3), &
17160
17161 & answer_shape(4) ) &
17162 & )
17163
17164 allocate( check_negative( &
17165 & answer_shape(1), &
17166
17167 & answer_shape(2), &
17168
17169 & answer_shape(3), &
17170
17171 & answer_shape(4) ) &
17172 & )
17173
17174 allocate( both_negative( &
17175 & answer_shape(1), &
17176
17177 & answer_shape(2), &
17178
17179 & answer_shape(3), &
17180
17181 & answer_shape(4) ) &
17182 & )
17183
17184 answer_negative = answer < 0.0_dp
17185 check_negative = check < 0.0_dp
17186 both_negative = answer_negative .and. check_negative
17187 if (.not. negative_support_on) both_negative = .false.
17188
17189 judge = answer > check
17190 where (both_negative) judge = .not. judge
17191
17192 judge_rev = .not. judge
17193 err_flag = any(judge_rev)
17194 mask_array = 1
17195 pos = maxloc(mask_array, judge_rev)
17196
17197 if (err_flag) then
17198
17199 wrong = check( &
17200 & pos(1), &
17201
17202 & pos(2), &
17203
17204 & pos(3), &
17205
17206 & pos(4) )
17207
17208 right = answer( &
17209 & pos(1), &
17210
17211 & pos(2), &
17212
17213 & pos(3), &
17214
17215 & pos(4) )
17216
17217 write(unit=pos_array(1), fmt="(i20)") pos(1)
17218
17219 write(unit=pos_array(2), fmt="(i20)") pos(2)
17220
17221 write(unit=pos_array(3), fmt="(i20)") pos(3)
17222
17223 write(unit=pos_array(4), fmt="(i20)") pos(4)
17224
17225
17226 pos_str = '(' // &
17227 & trim(adjustl(pos_array(1))) // ',' // &
17228
17229 & trim(adjustl(pos_array(2))) // ',' // &
17230
17231 & trim(adjustl(pos_array(3))) // ',' // &
17232
17233 & trim(adjustl(pos_array(4))) // ')'
17234
17235 if ( both_negative( &
17236 & pos(1), &
17237
17238 & pos(2), &
17239
17240 & pos(3), &
17241
17242 & pos(4) ) ) then
17243
17244 abs_mes = 'ABSOLUTE value of'
17245 else
17246 abs_mes = ''
17247
17248 end if
17249
17250 end if
17251 deallocate(mask_array, judge, judge_rev)
17252 deallocate(answer_negative, check_negative, both_negative)
17253
17254
17255
17256
17257 if (err_flag) then
17258 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17259 write(*,*) ''
17260 write(*,*) ' ' // trim(abs_mes) // &
17261 & ' check' // trim(pos_str) // ' = ', wrong
17262 write(*,*) ' is NOT LESS THAN'
17263 write(*,*) ' ' // trim(abs_mes) // &
17264 & ' answer' // trim(pos_str) // ' = ', right
17265
17267 else
17268 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
17269 end if
17270
17271
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
◆ dctestassertlessthandouble5()
| subroutine dc_test::assertlessthan::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 17275 of file dc_test.f90.
17279 implicit none
17280 character(*), intent(in):: message
17281 real(DP), intent(in):: answer(:,:,:,:,:)
17282 real(DP), intent(in):: check(:,:,:,:,:)
17283 logical, intent(in), optional:: negative_support
17284 logical:: err_flag
17285 logical:: negative_support_on
17286 character(STRING):: pos_str
17287 character(TOKEN):: abs_mes
17288 real(DP):: wrong, right
17289
17290 integer:: answer_shape(5), check_shape(5), pos(5)
17291 logical:: consist_shape(5)
17292 character(TOKEN):: pos_array(5)
17293 integer, allocatable:: mask_array(:,:,:,:,:)
17294 logical, allocatable:: judge(:,:,:,:,:)
17295 logical, allocatable:: judge_rev(:,:,:,:,:)
17296 logical, allocatable:: answer_negative(:,:,:,:,:)
17297 logical, allocatable:: check_negative(:,:,:,:,:)
17298 logical, allocatable:: both_negative(:,:,:,:,:)
17299
17300
17301 continue
17302 if (present(negative_support)) then
17303 negative_support_on = negative_support
17304 else
17305 negative_support_on = .true.
17306 end if
17307
17308 err_flag = .false.
17309
17310
17311 answer_shape = shape(answer)
17312 check_shape = shape(check)
17313
17314 consist_shape = answer_shape == check_shape
17315
17316 if (.not. all(consist_shape)) then
17317 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17318 write(*,*) ''
17319 write(*,*) ' shape of check is (', check_shape, ')'
17320 write(*,*) ' is INCORRECT'
17321 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
17322
17324 end if
17325
17326
17327 allocate( mask_array( &
17328 & answer_shape(1), &
17329
17330 & answer_shape(2), &
17331
17332 & answer_shape(3), &
17333
17334 & answer_shape(4), &
17335
17336 & answer_shape(5) ) &
17337 & )
17338
17339 allocate( judge( &
17340 & answer_shape(1), &
17341
17342 & answer_shape(2), &
17343
17344 & answer_shape(3), &
17345
17346 & answer_shape(4), &
17347
17348 & answer_shape(5) ) &
17349 & )
17350
17351 allocate( judge_rev( &
17352 & answer_shape(1), &
17353
17354 & answer_shape(2), &
17355
17356 & answer_shape(3), &
17357
17358 & answer_shape(4), &
17359
17360 & answer_shape(5) ) &
17361 & )
17362
17363 allocate( answer_negative( &
17364 & answer_shape(1), &
17365
17366 & answer_shape(2), &
17367
17368 & answer_shape(3), &
17369
17370 & answer_shape(4), &
17371
17372 & answer_shape(5) ) &
17373 & )
17374
17375 allocate( check_negative( &
17376 & answer_shape(1), &
17377
17378 & answer_shape(2), &
17379
17380 & answer_shape(3), &
17381
17382 & answer_shape(4), &
17383
17384 & answer_shape(5) ) &
17385 & )
17386
17387 allocate( both_negative( &
17388 & answer_shape(1), &
17389
17390 & answer_shape(2), &
17391
17392 & answer_shape(3), &
17393
17394 & answer_shape(4), &
17395
17396 & answer_shape(5) ) &
17397 & )
17398
17399 answer_negative = answer < 0.0_dp
17400 check_negative = check < 0.0_dp
17401 both_negative = answer_negative .and. check_negative
17402 if (.not. negative_support_on) both_negative = .false.
17403
17404 judge = answer > check
17405 where (both_negative) judge = .not. judge
17406
17407 judge_rev = .not. judge
17408 err_flag = any(judge_rev)
17409 mask_array = 1
17410 pos = maxloc(mask_array, judge_rev)
17411
17412 if (err_flag) then
17413
17414 wrong = check( &
17415 & pos(1), &
17416
17417 & pos(2), &
17418
17419 & pos(3), &
17420
17421 & pos(4), &
17422
17423 & pos(5) )
17424
17425 right = answer( &
17426 & pos(1), &
17427
17428 & pos(2), &
17429
17430 & pos(3), &
17431
17432 & pos(4), &
17433
17434 & pos(5) )
17435
17436 write(unit=pos_array(1), fmt="(i20)") pos(1)
17437
17438 write(unit=pos_array(2), fmt="(i20)") pos(2)
17439
17440 write(unit=pos_array(3), fmt="(i20)") pos(3)
17441
17442 write(unit=pos_array(4), fmt="(i20)") pos(4)
17443
17444 write(unit=pos_array(5), fmt="(i20)") pos(5)
17445
17446
17447 pos_str = '(' // &
17448 & trim(adjustl(pos_array(1))) // ',' // &
17449
17450 & trim(adjustl(pos_array(2))) // ',' // &
17451
17452 & trim(adjustl(pos_array(3))) // ',' // &
17453
17454 & trim(adjustl(pos_array(4))) // ',' // &
17455
17456 & trim(adjustl(pos_array(5))) // ')'
17457
17458 if ( both_negative( &
17459 & pos(1), &
17460
17461 & pos(2), &
17462
17463 & pos(3), &
17464
17465 & pos(4), &
17466
17467 & pos(5) ) ) then
17468
17469 abs_mes = 'ABSOLUTE value of'
17470 else
17471 abs_mes = ''
17472
17473 end if
17474
17475 end if
17476 deallocate(mask_array, judge, judge_rev)
17477 deallocate(answer_negative, check_negative, both_negative)
17478
17479
17480
17481
17482 if (err_flag) then
17483 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17484 write(*,*) ''
17485 write(*,*) ' ' // trim(abs_mes) // &
17486 & ' check' // trim(pos_str) // ' = ', wrong
17487 write(*,*) ' is NOT LESS THAN'
17488 write(*,*) ' ' // trim(abs_mes) // &
17489 & ' answer' // trim(pos_str) // ' = ', right
17490
17492 else
17493 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
17494 end if
17495
17496
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
◆ dctestassertlessthandouble6()
| subroutine dc_test::assertlessthan::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 17500 of file dc_test.f90.
17504 implicit none
17505 character(*), intent(in):: message
17506 real(DP), intent(in):: answer(:,:,:,:,:,:)
17507 real(DP), intent(in):: check(:,:,:,:,:,:)
17508 logical, intent(in), optional:: negative_support
17509 logical:: err_flag
17510 logical:: negative_support_on
17511 character(STRING):: pos_str
17512 character(TOKEN):: abs_mes
17513 real(DP):: wrong, right
17514
17515 integer:: answer_shape(6), check_shape(6), pos(6)
17516 logical:: consist_shape(6)
17517 character(TOKEN):: pos_array(6)
17518 integer, allocatable:: mask_array(:,:,:,:,:,:)
17519 logical, allocatable:: judge(:,:,:,:,:,:)
17520 logical, allocatable:: judge_rev(:,:,:,:,:,:)
17521 logical, allocatable:: answer_negative(:,:,:,:,:,:)
17522 logical, allocatable:: check_negative(:,:,:,:,:,:)
17523 logical, allocatable:: both_negative(:,:,:,:,:,:)
17524
17525
17526 continue
17527 if (present(negative_support)) then
17528 negative_support_on = negative_support
17529 else
17530 negative_support_on = .true.
17531 end if
17532
17533 err_flag = .false.
17534
17535
17536 answer_shape = shape(answer)
17537 check_shape = shape(check)
17538
17539 consist_shape = answer_shape == check_shape
17540
17541 if (.not. all(consist_shape)) then
17542 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17543 write(*,*) ''
17544 write(*,*) ' shape of check is (', check_shape, ')'
17545 write(*,*) ' is INCORRECT'
17546 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
17547
17549 end if
17550
17551
17552 allocate( mask_array( &
17553 & answer_shape(1), &
17554
17555 & answer_shape(2), &
17556
17557 & answer_shape(3), &
17558
17559 & answer_shape(4), &
17560
17561 & answer_shape(5), &
17562
17563 & answer_shape(6) ) &
17564 & )
17565
17566 allocate( judge( &
17567 & answer_shape(1), &
17568
17569 & answer_shape(2), &
17570
17571 & answer_shape(3), &
17572
17573 & answer_shape(4), &
17574
17575 & answer_shape(5), &
17576
17577 & answer_shape(6) ) &
17578 & )
17579
17580 allocate( judge_rev( &
17581 & answer_shape(1), &
17582
17583 & answer_shape(2), &
17584
17585 & answer_shape(3), &
17586
17587 & answer_shape(4), &
17588
17589 & answer_shape(5), &
17590
17591 & answer_shape(6) ) &
17592 & )
17593
17594 allocate( answer_negative( &
17595 & answer_shape(1), &
17596
17597 & answer_shape(2), &
17598
17599 & answer_shape(3), &
17600
17601 & answer_shape(4), &
17602
17603 & answer_shape(5), &
17604
17605 & answer_shape(6) ) &
17606 & )
17607
17608 allocate( check_negative( &
17609 & answer_shape(1), &
17610
17611 & answer_shape(2), &
17612
17613 & answer_shape(3), &
17614
17615 & answer_shape(4), &
17616
17617 & answer_shape(5), &
17618
17619 & answer_shape(6) ) &
17620 & )
17621
17622 allocate( both_negative( &
17623 & answer_shape(1), &
17624
17625 & answer_shape(2), &
17626
17627 & answer_shape(3), &
17628
17629 & answer_shape(4), &
17630
17631 & answer_shape(5), &
17632
17633 & answer_shape(6) ) &
17634 & )
17635
17636 answer_negative = answer < 0.0_dp
17637 check_negative = check < 0.0_dp
17638 both_negative = answer_negative .and. check_negative
17639 if (.not. negative_support_on) both_negative = .false.
17640
17641 judge = answer > check
17642 where (both_negative) judge = .not. judge
17643
17644 judge_rev = .not. judge
17645 err_flag = any(judge_rev)
17646 mask_array = 1
17647 pos = maxloc(mask_array, judge_rev)
17648
17649 if (err_flag) then
17650
17651 wrong = check( &
17652 & pos(1), &
17653
17654 & pos(2), &
17655
17656 & pos(3), &
17657
17658 & pos(4), &
17659
17660 & pos(5), &
17661
17662 & pos(6) )
17663
17664 right = answer( &
17665 & pos(1), &
17666
17667 & pos(2), &
17668
17669 & pos(3), &
17670
17671 & pos(4), &
17672
17673 & pos(5), &
17674
17675 & pos(6) )
17676
17677 write(unit=pos_array(1), fmt="(i20)") pos(1)
17678
17679 write(unit=pos_array(2), fmt="(i20)") pos(2)
17680
17681 write(unit=pos_array(3), fmt="(i20)") pos(3)
17682
17683 write(unit=pos_array(4), fmt="(i20)") pos(4)
17684
17685 write(unit=pos_array(5), fmt="(i20)") pos(5)
17686
17687 write(unit=pos_array(6), fmt="(i20)") pos(6)
17688
17689
17690 pos_str = '(' // &
17691 & trim(adjustl(pos_array(1))) // ',' // &
17692
17693 & trim(adjustl(pos_array(2))) // ',' // &
17694
17695 & trim(adjustl(pos_array(3))) // ',' // &
17696
17697 & trim(adjustl(pos_array(4))) // ',' // &
17698
17699 & trim(adjustl(pos_array(5))) // ',' // &
17700
17701 & trim(adjustl(pos_array(6))) // ')'
17702
17703 if ( both_negative( &
17704 & pos(1), &
17705
17706 & pos(2), &
17707
17708 & pos(3), &
17709
17710 & pos(4), &
17711
17712 & pos(5), &
17713
17714 & pos(6) ) ) then
17715
17716 abs_mes = 'ABSOLUTE value of'
17717 else
17718 abs_mes = ''
17719
17720 end if
17721
17722 end if
17723 deallocate(mask_array, judge, judge_rev)
17724 deallocate(answer_negative, check_negative, both_negative)
17725
17726
17727
17728
17729 if (err_flag) then
17730 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17731 write(*,*) ''
17732 write(*,*) ' ' // trim(abs_mes) // &
17733 & ' check' // trim(pos_str) // ' = ', wrong
17734 write(*,*) ' is NOT LESS THAN'
17735 write(*,*) ' ' // trim(abs_mes) // &
17736 & ' answer' // trim(pos_str) // ' = ', right
17737
17739 else
17740 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
17741 end if
17742
17743
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
◆ dctestassertlessthandouble7()
| subroutine dc_test::assertlessthan::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 17747 of file dc_test.f90.
17751 implicit none
17752 character(*), intent(in):: message
17753 real(DP), intent(in):: answer(:,:,:,:,:,:,:)
17754 real(DP), intent(in):: check(:,:,:,:,:,:,:)
17755 logical, intent(in), optional:: negative_support
17756 logical:: err_flag
17757 logical:: negative_support_on
17758 character(STRING):: pos_str
17759 character(TOKEN):: abs_mes
17760 real(DP):: wrong, right
17761
17762 integer:: answer_shape(7), check_shape(7), pos(7)
17763 logical:: consist_shape(7)
17764 character(TOKEN):: pos_array(7)
17765 integer, allocatable:: mask_array(:,:,:,:,:,:,:)
17766 logical, allocatable:: judge(:,:,:,:,:,:,:)
17767 logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
17768 logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
17769 logical, allocatable:: check_negative(:,:,:,:,:,:,:)
17770 logical, allocatable:: both_negative(:,:,:,:,:,:,:)
17771
17772
17773 continue
17774 if (present(negative_support)) then
17775 negative_support_on = negative_support
17776 else
17777 negative_support_on = .true.
17778 end if
17779
17780 err_flag = .false.
17781
17782
17783 answer_shape = shape(answer)
17784 check_shape = shape(check)
17785
17786 consist_shape = answer_shape == check_shape
17787
17788 if (.not. all(consist_shape)) then
17789 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17790 write(*,*) ''
17791 write(*,*) ' shape of check is (', check_shape, ')'
17792 write(*,*) ' is INCORRECT'
17793 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
17794
17796 end if
17797
17798
17799 allocate( mask_array( &
17800 & answer_shape(1), &
17801
17802 & answer_shape(2), &
17803
17804 & answer_shape(3), &
17805
17806 & answer_shape(4), &
17807
17808 & answer_shape(5), &
17809
17810 & answer_shape(6), &
17811
17812 & answer_shape(7) ) &
17813 & )
17814
17815 allocate( judge( &
17816 & answer_shape(1), &
17817
17818 & answer_shape(2), &
17819
17820 & answer_shape(3), &
17821
17822 & answer_shape(4), &
17823
17824 & answer_shape(5), &
17825
17826 & answer_shape(6), &
17827
17828 & answer_shape(7) ) &
17829 & )
17830
17831 allocate( judge_rev( &
17832 & answer_shape(1), &
17833
17834 & answer_shape(2), &
17835
17836 & answer_shape(3), &
17837
17838 & answer_shape(4), &
17839
17840 & answer_shape(5), &
17841
17842 & answer_shape(6), &
17843
17844 & answer_shape(7) ) &
17845 & )
17846
17847 allocate( answer_negative( &
17848 & answer_shape(1), &
17849
17850 & answer_shape(2), &
17851
17852 & answer_shape(3), &
17853
17854 & answer_shape(4), &
17855
17856 & answer_shape(5), &
17857
17858 & answer_shape(6), &
17859
17860 & answer_shape(7) ) &
17861 & )
17862
17863 allocate( check_negative( &
17864 & answer_shape(1), &
17865
17866 & answer_shape(2), &
17867
17868 & answer_shape(3), &
17869
17870 & answer_shape(4), &
17871
17872 & answer_shape(5), &
17873
17874 & answer_shape(6), &
17875
17876 & answer_shape(7) ) &
17877 & )
17878
17879 allocate( both_negative( &
17880 & answer_shape(1), &
17881
17882 & answer_shape(2), &
17883
17884 & answer_shape(3), &
17885
17886 & answer_shape(4), &
17887
17888 & answer_shape(5), &
17889
17890 & answer_shape(6), &
17891
17892 & answer_shape(7) ) &
17893 & )
17894
17895 answer_negative = answer < 0.0_dp
17896 check_negative = check < 0.0_dp
17897 both_negative = answer_negative .and. check_negative
17898 if (.not. negative_support_on) both_negative = .false.
17899
17900 judge = answer > check
17901 where (both_negative) judge = .not. judge
17902
17903 judge_rev = .not. judge
17904 err_flag = any(judge_rev)
17905 mask_array = 1
17906 pos = maxloc(mask_array, judge_rev)
17907
17908 if (err_flag) then
17909
17910 wrong = check( &
17911 & pos(1), &
17912
17913 & pos(2), &
17914
17915 & pos(3), &
17916
17917 & pos(4), &
17918
17919 & pos(5), &
17920
17921 & pos(6), &
17922
17923 & pos(7) )
17924
17925 right = answer( &
17926 & pos(1), &
17927
17928 & pos(2), &
17929
17930 & pos(3), &
17931
17932 & pos(4), &
17933
17934 & pos(5), &
17935
17936 & pos(6), &
17937
17938 & pos(7) )
17939
17940 write(unit=pos_array(1), fmt="(i20)") pos(1)
17941
17942 write(unit=pos_array(2), fmt="(i20)") pos(2)
17943
17944 write(unit=pos_array(3), fmt="(i20)") pos(3)
17945
17946 write(unit=pos_array(4), fmt="(i20)") pos(4)
17947
17948 write(unit=pos_array(5), fmt="(i20)") pos(5)
17949
17950 write(unit=pos_array(6), fmt="(i20)") pos(6)
17951
17952 write(unit=pos_array(7), fmt="(i20)") pos(7)
17953
17954
17955 pos_str = '(' // &
17956 & trim(adjustl(pos_array(1))) // ',' // &
17957
17958 & trim(adjustl(pos_array(2))) // ',' // &
17959
17960 & trim(adjustl(pos_array(3))) // ',' // &
17961
17962 & trim(adjustl(pos_array(4))) // ',' // &
17963
17964 & trim(adjustl(pos_array(5))) // ',' // &
17965
17966 & trim(adjustl(pos_array(6))) // ',' // &
17967
17968 & trim(adjustl(pos_array(7))) // ')'
17969
17970 if ( both_negative( &
17971 & pos(1), &
17972
17973 & pos(2), &
17974
17975 & pos(3), &
17976
17977 & pos(4), &
17978
17979 & pos(5), &
17980
17981 & pos(6), &
17982
17983 & pos(7) ) ) then
17984
17985 abs_mes = 'ABSOLUTE value of'
17986 else
17987 abs_mes = ''
17988
17989 end if
17990
17991 end if
17992 deallocate(mask_array, judge, judge_rev)
17993 deallocate(answer_negative, check_negative, both_negative)
17994
17995
17996
17997
17998 if (err_flag) then
17999 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
18000 write(*,*) ''
18001 write(*,*) ' ' // trim(abs_mes) // &
18002 & ' check' // trim(pos_str) // ' = ', wrong
18003 write(*,*) ' is NOT LESS THAN'
18004 write(*,*) ' ' // trim(abs_mes) // &
18005 & ' answer' // trim(pos_str) // ' = ', right
18006
18008 else
18009 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
18010 end if
18011
18012
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
◆ dctestassertlessthanint0()
| subroutine dc_test::assertlessthan::dctestassertlessthanint0 | ( | character(*), intent(in) | message, |
| integer, intent(in) | answer, | ||
| integer, intent(in) | check, | ||
| logical, intent(in), optional | negative_support ) |
Definition at line 13528 of file dc_test.f90.
13532 implicit none
13533 character(*), intent(in):: message
13534 integer, intent(in):: answer
13535 integer, intent(in):: check
13536 logical, intent(in), optional:: negative_support
13537 logical:: err_flag
13538 logical:: negative_support_on
13539 character(STRING):: pos_str
13540 character(TOKEN):: abs_mes
13541 integer:: wrong, right
13542
13543
13544
13545 continue
13546 if (present(negative_support)) then
13547 negative_support_on = negative_support
13548 else
13549 negative_support_on = .true.
13550 end if
13551
13552 err_flag = .false.
13553
13554
13555
13556
13557 err_flag = .not. answer > check
13558 abs_mes = ''
13559
13560 if ( answer < 0 &
13561 & .and. check < 0 &
13562 & .and. negative_support_on ) then
13563
13564 err_flag = .not. err_flag
13565 abs_mes = 'ABSOLUTE value of'
13566 end if
13567
13568 wrong = check
13569 right = answer
13570 pos_str = ''
13571
13572
13573
13574
13575 if (err_flag) then
13576 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13577 write(*,*) ''
13578 write(*,*) ' ' // trim(abs_mes) // &
13579 & ' check' // trim(pos_str) // ' = ', wrong
13580 write(*,*) ' is NOT LESS THAN'
13581 write(*,*) ' ' // trim(abs_mes) // &
13582 & ' answer' // trim(pos_str) // ' = ', right
13583
13585 else
13586 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
13587 end if
13588
13589
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
◆ dctestassertlessthanint1()
| subroutine dc_test::assertlessthan::dctestassertlessthanint1 | ( | character(*), intent(in) | message, |
| integer, dimension(:), intent(in) | answer, | ||
| integer, dimension(:), intent(in) | check, | ||
| logical, intent(in), optional | negative_support ) |
Definition at line 13593 of file dc_test.f90.
13597 implicit none
13598 character(*), intent(in):: message
13599 integer, intent(in):: answer(:)
13600 integer, intent(in):: check(:)
13601 logical, intent(in), optional:: negative_support
13602 logical:: err_flag
13603 logical:: negative_support_on
13604 character(STRING):: pos_str
13605 character(TOKEN):: abs_mes
13606 integer:: wrong, right
13607
13608 integer:: answer_shape(1), check_shape(1), pos(1)
13609 logical:: consist_shape(1)
13610 character(TOKEN):: pos_array(1)
13611 integer, allocatable:: mask_array(:)
13612 logical, allocatable:: judge(:)
13613 logical, allocatable:: judge_rev(:)
13614 logical, allocatable:: answer_negative(:)
13615 logical, allocatable:: check_negative(:)
13616 logical, allocatable:: both_negative(:)
13617
13618
13619 continue
13620 if (present(negative_support)) then
13621 negative_support_on = negative_support
13622 else
13623 negative_support_on = .true.
13624 end if
13625
13626 err_flag = .false.
13627
13628
13629 answer_shape = shape(answer)
13630 check_shape = shape(check)
13631
13632 consist_shape = answer_shape == check_shape
13633
13634 if (.not. all(consist_shape)) then
13635 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13636 write(*,*) ''
13637 write(*,*) ' shape of check is (', check_shape, ')'
13638 write(*,*) ' is INCORRECT'
13639 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
13640
13642 end if
13643
13644
13645 allocate( mask_array( &
13646
13647 & answer_shape(1) ) &
13648 & )
13649
13650 allocate( judge( &
13651
13652 & answer_shape(1) ) &
13653 & )
13654
13655 allocate( judge_rev( &
13656
13657 & answer_shape(1) ) &
13658 & )
13659
13660 allocate( answer_negative( &
13661
13662 & answer_shape(1) ) &
13663 & )
13664
13665 allocate( check_negative( &
13666
13667 & answer_shape(1) ) &
13668 & )
13669
13670 allocate( both_negative( &
13671
13672 & answer_shape(1) ) &
13673 & )
13674
13675 answer_negative = answer < 0
13676 check_negative = check < 0
13677 both_negative = answer_negative .and. check_negative
13678 if (.not. negative_support_on) both_negative = .false.
13679
13680 judge = answer > check
13681 where (both_negative) judge = .not. judge
13682
13683 judge_rev = .not. judge
13684 err_flag = any(judge_rev)
13685 mask_array = 1
13686 pos = maxloc(mask_array, judge_rev)
13687
13688 if (err_flag) then
13689
13690 wrong = check( &
13691
13692 & pos(1) )
13693
13694 right = answer( &
13695
13696 & pos(1) )
13697
13698 write(unit=pos_array(1), fmt="(i20)") pos(1)
13699
13700
13701 pos_str = '(' // &
13702
13703 & trim(adjustl(pos_array(1))) // ')'
13704
13705 if ( both_negative( &
13706
13707 & pos(1) ) ) then
13708
13709 abs_mes = 'ABSOLUTE value of'
13710 else
13711 abs_mes = ''
13712
13713 end if
13714
13715 end if
13716 deallocate(mask_array, judge, judge_rev)
13717 deallocate(answer_negative, check_negative, both_negative)
13718
13719
13720
13721
13722 if (err_flag) then
13723 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13724 write(*,*) ''
13725 write(*,*) ' ' // trim(abs_mes) // &
13726 & ' check' // trim(pos_str) // ' = ', wrong
13727 write(*,*) ' is NOT LESS THAN'
13728 write(*,*) ' ' // trim(abs_mes) // &
13729 & ' answer' // trim(pos_str) // ' = ', right
13730
13732 else
13733 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
13734 end if
13735
13736
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
◆ dctestassertlessthanint2()
| subroutine dc_test::assertlessthan::dctestassertlessthanint2 | ( | character(*), intent(in) | message, |
| integer, dimension(:,:), intent(in) | answer, | ||
| integer, dimension(:,:), intent(in) | check, | ||
| logical, intent(in), optional | negative_support ) |
Definition at line 13740 of file dc_test.f90.
13744 implicit none
13745 character(*), intent(in):: message
13746 integer, intent(in):: answer(:,:)
13747 integer, intent(in):: check(:,:)
13748 logical, intent(in), optional:: negative_support
13749 logical:: err_flag
13750 logical:: negative_support_on
13751 character(STRING):: pos_str
13752 character(TOKEN):: abs_mes
13753 integer:: wrong, right
13754
13755 integer:: answer_shape(2), check_shape(2), pos(2)
13756 logical:: consist_shape(2)
13757 character(TOKEN):: pos_array(2)
13758 integer, allocatable:: mask_array(:,:)
13759 logical, allocatable:: judge(:,:)
13760 logical, allocatable:: judge_rev(:,:)
13761 logical, allocatable:: answer_negative(:,:)
13762 logical, allocatable:: check_negative(:,:)
13763 logical, allocatable:: both_negative(:,:)
13764
13765
13766 continue
13767 if (present(negative_support)) then
13768 negative_support_on = negative_support
13769 else
13770 negative_support_on = .true.
13771 end if
13772
13773 err_flag = .false.
13774
13775
13776 answer_shape = shape(answer)
13777 check_shape = shape(check)
13778
13779 consist_shape = answer_shape == check_shape
13780
13781 if (.not. all(consist_shape)) then
13782 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13783 write(*,*) ''
13784 write(*,*) ' shape of check is (', check_shape, ')'
13785 write(*,*) ' is INCORRECT'
13786 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
13787
13789 end if
13790
13791
13792 allocate( mask_array( &
13793 & answer_shape(1), &
13794
13795 & answer_shape(2) ) &
13796 & )
13797
13798 allocate( judge( &
13799 & answer_shape(1), &
13800
13801 & answer_shape(2) ) &
13802 & )
13803
13804 allocate( judge_rev( &
13805 & answer_shape(1), &
13806
13807 & answer_shape(2) ) &
13808 & )
13809
13810 allocate( answer_negative( &
13811 & answer_shape(1), &
13812
13813 & answer_shape(2) ) &
13814 & )
13815
13816 allocate( check_negative( &
13817 & answer_shape(1), &
13818
13819 & answer_shape(2) ) &
13820 & )
13821
13822 allocate( both_negative( &
13823 & answer_shape(1), &
13824
13825 & answer_shape(2) ) &
13826 & )
13827
13828 answer_negative = answer < 0
13829 check_negative = check < 0
13830 both_negative = answer_negative .and. check_negative
13831 if (.not. negative_support_on) both_negative = .false.
13832
13833 judge = answer > check
13834 where (both_negative) judge = .not. judge
13835
13836 judge_rev = .not. judge
13837 err_flag = any(judge_rev)
13838 mask_array = 1
13839 pos = maxloc(mask_array, judge_rev)
13840
13841 if (err_flag) then
13842
13843 wrong = check( &
13844 & pos(1), &
13845
13846 & pos(2) )
13847
13848 right = answer( &
13849 & pos(1), &
13850
13851 & pos(2) )
13852
13853 write(unit=pos_array(1), fmt="(i20)") pos(1)
13854
13855 write(unit=pos_array(2), fmt="(i20)") pos(2)
13856
13857
13858 pos_str = '(' // &
13859 & trim(adjustl(pos_array(1))) // ',' // &
13860
13861 & trim(adjustl(pos_array(2))) // ')'
13862
13863 if ( both_negative( &
13864 & pos(1), &
13865
13866 & pos(2) ) ) then
13867
13868 abs_mes = 'ABSOLUTE value of'
13869 else
13870 abs_mes = ''
13871
13872 end if
13873
13874 end if
13875 deallocate(mask_array, judge, judge_rev)
13876 deallocate(answer_negative, check_negative, both_negative)
13877
13878
13879
13880
13881 if (err_flag) then
13882 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13883 write(*,*) ''
13884 write(*,*) ' ' // trim(abs_mes) // &
13885 & ' check' // trim(pos_str) // ' = ', wrong
13886 write(*,*) ' is NOT LESS THAN'
13887 write(*,*) ' ' // trim(abs_mes) // &
13888 & ' answer' // trim(pos_str) // ' = ', right
13889
13891 else
13892 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
13893 end if
13894
13895
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
◆ dctestassertlessthanint3()
| subroutine dc_test::assertlessthan::dctestassertlessthanint3 | ( | character(*), intent(in) | message, |
| integer, dimension(:,:,:), intent(in) | answer, | ||
| integer, dimension(:,:,:), intent(in) | check, | ||
| logical, intent(in), optional | negative_support ) |
Definition at line 13899 of file dc_test.f90.
13903 implicit none
13904 character(*), intent(in):: message
13905 integer, intent(in):: answer(:,:,:)
13906 integer, intent(in):: check(:,:,:)
13907 logical, intent(in), optional:: negative_support
13908 logical:: err_flag
13909 logical:: negative_support_on
13910 character(STRING):: pos_str
13911 character(TOKEN):: abs_mes
13912 integer:: wrong, right
13913
13914 integer:: answer_shape(3), check_shape(3), pos(3)
13915 logical:: consist_shape(3)
13916 character(TOKEN):: pos_array(3)
13917 integer, allocatable:: mask_array(:,:,:)
13918 logical, allocatable:: judge(:,:,:)
13919 logical, allocatable:: judge_rev(:,:,:)
13920 logical, allocatable:: answer_negative(:,:,:)
13921 logical, allocatable:: check_negative(:,:,:)
13922 logical, allocatable:: both_negative(:,:,:)
13923
13924
13925 continue
13926 if (present(negative_support)) then
13927 negative_support_on = negative_support
13928 else
13929 negative_support_on = .true.
13930 end if
13931
13932 err_flag = .false.
13933
13934
13935 answer_shape = shape(answer)
13936 check_shape = shape(check)
13937
13938 consist_shape = answer_shape == check_shape
13939
13940 if (.not. all(consist_shape)) then
13941 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13942 write(*,*) ''
13943 write(*,*) ' shape of check is (', check_shape, ')'
13944 write(*,*) ' is INCORRECT'
13945 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
13946
13948 end if
13949
13950
13951 allocate( mask_array( &
13952 & answer_shape(1), &
13953
13954 & answer_shape(2), &
13955
13956 & answer_shape(3) ) &
13957 & )
13958
13959 allocate( judge( &
13960 & answer_shape(1), &
13961
13962 & answer_shape(2), &
13963
13964 & answer_shape(3) ) &
13965 & )
13966
13967 allocate( judge_rev( &
13968 & answer_shape(1), &
13969
13970 & answer_shape(2), &
13971
13972 & answer_shape(3) ) &
13973 & )
13974
13975 allocate( answer_negative( &
13976 & answer_shape(1), &
13977
13978 & answer_shape(2), &
13979
13980 & answer_shape(3) ) &
13981 & )
13982
13983 allocate( check_negative( &
13984 & answer_shape(1), &
13985
13986 & answer_shape(2), &
13987
13988 & answer_shape(3) ) &
13989 & )
13990
13991 allocate( both_negative( &
13992 & answer_shape(1), &
13993
13994 & answer_shape(2), &
13995
13996 & answer_shape(3) ) &
13997 & )
13998
13999 answer_negative = answer < 0
14000 check_negative = check < 0
14001 both_negative = answer_negative .and. check_negative
14002 if (.not. negative_support_on) both_negative = .false.
14003
14004 judge = answer > check
14005 where (both_negative) judge = .not. judge
14006
14007 judge_rev = .not. judge
14008 err_flag = any(judge_rev)
14009 mask_array = 1
14010 pos = maxloc(mask_array, judge_rev)
14011
14012 if (err_flag) then
14013
14014 wrong = check( &
14015 & pos(1), &
14016
14017 & pos(2), &
14018
14019 & pos(3) )
14020
14021 right = answer( &
14022 & pos(1), &
14023
14024 & pos(2), &
14025
14026 & pos(3) )
14027
14028 write(unit=pos_array(1), fmt="(i20)") pos(1)
14029
14030 write(unit=pos_array(2), fmt="(i20)") pos(2)
14031
14032 write(unit=pos_array(3), fmt="(i20)") pos(3)
14033
14034
14035 pos_str = '(' // &
14036 & trim(adjustl(pos_array(1))) // ',' // &
14037
14038 & trim(adjustl(pos_array(2))) // ',' // &
14039
14040 & trim(adjustl(pos_array(3))) // ')'
14041
14042 if ( both_negative( &
14043 & pos(1), &
14044
14045 & pos(2), &
14046
14047 & pos(3) ) ) then
14048
14049 abs_mes = 'ABSOLUTE value of'
14050 else
14051 abs_mes = ''
14052
14053 end if
14054
14055 end if
14056 deallocate(mask_array, judge, judge_rev)
14057 deallocate(answer_negative, check_negative, both_negative)
14058
14059
14060
14061
14062 if (err_flag) then
14063 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14064 write(*,*) ''
14065 write(*,*) ' ' // trim(abs_mes) // &
14066 & ' check' // trim(pos_str) // ' = ', wrong
14067 write(*,*) ' is NOT LESS THAN'
14068 write(*,*) ' ' // trim(abs_mes) // &
14069 & ' answer' // trim(pos_str) // ' = ', right
14070
14072 else
14073 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
14074 end if
14075
14076
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
◆ dctestassertlessthanint4()
| subroutine dc_test::assertlessthan::dctestassertlessthanint4 | ( | character(*), intent(in) | message, |
| integer, dimension(:,:,:,:), intent(in) | answer, | ||
| integer, dimension(:,:,:,:), intent(in) | check, | ||
| logical, intent(in), optional | negative_support ) |
Definition at line 14080 of file dc_test.f90.
14084 implicit none
14085 character(*), intent(in):: message
14086 integer, intent(in):: answer(:,:,:,:)
14087 integer, intent(in):: check(:,:,:,:)
14088 logical, intent(in), optional:: negative_support
14089 logical:: err_flag
14090 logical:: negative_support_on
14091 character(STRING):: pos_str
14092 character(TOKEN):: abs_mes
14093 integer:: wrong, right
14094
14095 integer:: answer_shape(4), check_shape(4), pos(4)
14096 logical:: consist_shape(4)
14097 character(TOKEN):: pos_array(4)
14098 integer, allocatable:: mask_array(:,:,:,:)
14099 logical, allocatable:: judge(:,:,:,:)
14100 logical, allocatable:: judge_rev(:,:,:,:)
14101 logical, allocatable:: answer_negative(:,:,:,:)
14102 logical, allocatable:: check_negative(:,:,:,:)
14103 logical, allocatable:: both_negative(:,:,:,:)
14104
14105
14106 continue
14107 if (present(negative_support)) then
14108 negative_support_on = negative_support
14109 else
14110 negative_support_on = .true.
14111 end if
14112
14113 err_flag = .false.
14114
14115
14116 answer_shape = shape(answer)
14117 check_shape = shape(check)
14118
14119 consist_shape = answer_shape == check_shape
14120
14121 if (.not. all(consist_shape)) then
14122 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14123 write(*,*) ''
14124 write(*,*) ' shape of check is (', check_shape, ')'
14125 write(*,*) ' is INCORRECT'
14126 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
14127
14129 end if
14130
14131
14132 allocate( mask_array( &
14133 & answer_shape(1), &
14134
14135 & answer_shape(2), &
14136
14137 & answer_shape(3), &
14138
14139 & answer_shape(4) ) &
14140 & )
14141
14142 allocate( judge( &
14143 & answer_shape(1), &
14144
14145 & answer_shape(2), &
14146
14147 & answer_shape(3), &
14148
14149 & answer_shape(4) ) &
14150 & )
14151
14152 allocate( judge_rev( &
14153 & answer_shape(1), &
14154
14155 & answer_shape(2), &
14156
14157 & answer_shape(3), &
14158
14159 & answer_shape(4) ) &
14160 & )
14161
14162 allocate( answer_negative( &
14163 & answer_shape(1), &
14164
14165 & answer_shape(2), &
14166
14167 & answer_shape(3), &
14168
14169 & answer_shape(4) ) &
14170 & )
14171
14172 allocate( check_negative( &
14173 & answer_shape(1), &
14174
14175 & answer_shape(2), &
14176
14177 & answer_shape(3), &
14178
14179 & answer_shape(4) ) &
14180 & )
14181
14182 allocate( both_negative( &
14183 & answer_shape(1), &
14184
14185 & answer_shape(2), &
14186
14187 & answer_shape(3), &
14188
14189 & answer_shape(4) ) &
14190 & )
14191
14192 answer_negative = answer < 0
14193 check_negative = check < 0
14194 both_negative = answer_negative .and. check_negative
14195 if (.not. negative_support_on) both_negative = .false.
14196
14197 judge = answer > check
14198 where (both_negative) judge = .not. judge
14199
14200 judge_rev = .not. judge
14201 err_flag = any(judge_rev)
14202 mask_array = 1
14203 pos = maxloc(mask_array, judge_rev)
14204
14205 if (err_flag) then
14206
14207 wrong = check( &
14208 & pos(1), &
14209
14210 & pos(2), &
14211
14212 & pos(3), &
14213
14214 & pos(4) )
14215
14216 right = answer( &
14217 & pos(1), &
14218
14219 & pos(2), &
14220
14221 & pos(3), &
14222
14223 & pos(4) )
14224
14225 write(unit=pos_array(1), fmt="(i20)") pos(1)
14226
14227 write(unit=pos_array(2), fmt="(i20)") pos(2)
14228
14229 write(unit=pos_array(3), fmt="(i20)") pos(3)
14230
14231 write(unit=pos_array(4), fmt="(i20)") pos(4)
14232
14233
14234 pos_str = '(' // &
14235 & trim(adjustl(pos_array(1))) // ',' // &
14236
14237 & trim(adjustl(pos_array(2))) // ',' // &
14238
14239 & trim(adjustl(pos_array(3))) // ',' // &
14240
14241 & trim(adjustl(pos_array(4))) // ')'
14242
14243 if ( both_negative( &
14244 & pos(1), &
14245
14246 & pos(2), &
14247
14248 & pos(3), &
14249
14250 & pos(4) ) ) then
14251
14252 abs_mes = 'ABSOLUTE value of'
14253 else
14254 abs_mes = ''
14255
14256 end if
14257
14258 end if
14259 deallocate(mask_array, judge, judge_rev)
14260 deallocate(answer_negative, check_negative, both_negative)
14261
14262
14263
14264
14265 if (err_flag) then
14266 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14267 write(*,*) ''
14268 write(*,*) ' ' // trim(abs_mes) // &
14269 & ' check' // trim(pos_str) // ' = ', wrong
14270 write(*,*) ' is NOT LESS THAN'
14271 write(*,*) ' ' // trim(abs_mes) // &
14272 & ' answer' // trim(pos_str) // ' = ', right
14273
14275 else
14276 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
14277 end if
14278
14279
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
◆ dctestassertlessthanint5()
| subroutine dc_test::assertlessthan::dctestassertlessthanint5 | ( | character(*), intent(in) | message, |
| integer, dimension(:,:,:,:,:), intent(in) | answer, | ||
| integer, dimension(:,:,:,:,:), intent(in) | check, | ||
| logical, intent(in), optional | negative_support ) |
Definition at line 14283 of file dc_test.f90.
14287 implicit none
14288 character(*), intent(in):: message
14289 integer, intent(in):: answer(:,:,:,:,:)
14290 integer, intent(in):: check(:,:,:,:,:)
14291 logical, intent(in), optional:: negative_support
14292 logical:: err_flag
14293 logical:: negative_support_on
14294 character(STRING):: pos_str
14295 character(TOKEN):: abs_mes
14296 integer:: wrong, right
14297
14298 integer:: answer_shape(5), check_shape(5), pos(5)
14299 logical:: consist_shape(5)
14300 character(TOKEN):: pos_array(5)
14301 integer, allocatable:: mask_array(:,:,:,:,:)
14302 logical, allocatable:: judge(:,:,:,:,:)
14303 logical, allocatable:: judge_rev(:,:,:,:,:)
14304 logical, allocatable:: answer_negative(:,:,:,:,:)
14305 logical, allocatable:: check_negative(:,:,:,:,:)
14306 logical, allocatable:: both_negative(:,:,:,:,:)
14307
14308
14309 continue
14310 if (present(negative_support)) then
14311 negative_support_on = negative_support
14312 else
14313 negative_support_on = .true.
14314 end if
14315
14316 err_flag = .false.
14317
14318
14319 answer_shape = shape(answer)
14320 check_shape = shape(check)
14321
14322 consist_shape = answer_shape == check_shape
14323
14324 if (.not. all(consist_shape)) then
14325 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14326 write(*,*) ''
14327 write(*,*) ' shape of check is (', check_shape, ')'
14328 write(*,*) ' is INCORRECT'
14329 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
14330
14332 end if
14333
14334
14335 allocate( mask_array( &
14336 & answer_shape(1), &
14337
14338 & answer_shape(2), &
14339
14340 & answer_shape(3), &
14341
14342 & answer_shape(4), &
14343
14344 & answer_shape(5) ) &
14345 & )
14346
14347 allocate( judge( &
14348 & answer_shape(1), &
14349
14350 & answer_shape(2), &
14351
14352 & answer_shape(3), &
14353
14354 & answer_shape(4), &
14355
14356 & answer_shape(5) ) &
14357 & )
14358
14359 allocate( judge_rev( &
14360 & answer_shape(1), &
14361
14362 & answer_shape(2), &
14363
14364 & answer_shape(3), &
14365
14366 & answer_shape(4), &
14367
14368 & answer_shape(5) ) &
14369 & )
14370
14371 allocate( answer_negative( &
14372 & answer_shape(1), &
14373
14374 & answer_shape(2), &
14375
14376 & answer_shape(3), &
14377
14378 & answer_shape(4), &
14379
14380 & answer_shape(5) ) &
14381 & )
14382
14383 allocate( check_negative( &
14384 & answer_shape(1), &
14385
14386 & answer_shape(2), &
14387
14388 & answer_shape(3), &
14389
14390 & answer_shape(4), &
14391
14392 & answer_shape(5) ) &
14393 & )
14394
14395 allocate( both_negative( &
14396 & answer_shape(1), &
14397
14398 & answer_shape(2), &
14399
14400 & answer_shape(3), &
14401
14402 & answer_shape(4), &
14403
14404 & answer_shape(5) ) &
14405 & )
14406
14407 answer_negative = answer < 0
14408 check_negative = check < 0
14409 both_negative = answer_negative .and. check_negative
14410 if (.not. negative_support_on) both_negative = .false.
14411
14412 judge = answer > check
14413 where (both_negative) judge = .not. judge
14414
14415 judge_rev = .not. judge
14416 err_flag = any(judge_rev)
14417 mask_array = 1
14418 pos = maxloc(mask_array, judge_rev)
14419
14420 if (err_flag) then
14421
14422 wrong = check( &
14423 & pos(1), &
14424
14425 & pos(2), &
14426
14427 & pos(3), &
14428
14429 & pos(4), &
14430
14431 & pos(5) )
14432
14433 right = answer( &
14434 & pos(1), &
14435
14436 & pos(2), &
14437
14438 & pos(3), &
14439
14440 & pos(4), &
14441
14442 & pos(5) )
14443
14444 write(unit=pos_array(1), fmt="(i20)") pos(1)
14445
14446 write(unit=pos_array(2), fmt="(i20)") pos(2)
14447
14448 write(unit=pos_array(3), fmt="(i20)") pos(3)
14449
14450 write(unit=pos_array(4), fmt="(i20)") pos(4)
14451
14452 write(unit=pos_array(5), fmt="(i20)") pos(5)
14453
14454
14455 pos_str = '(' // &
14456 & trim(adjustl(pos_array(1))) // ',' // &
14457
14458 & trim(adjustl(pos_array(2))) // ',' // &
14459
14460 & trim(adjustl(pos_array(3))) // ',' // &
14461
14462 & trim(adjustl(pos_array(4))) // ',' // &
14463
14464 & trim(adjustl(pos_array(5))) // ')'
14465
14466 if ( both_negative( &
14467 & pos(1), &
14468
14469 & pos(2), &
14470
14471 & pos(3), &
14472
14473 & pos(4), &
14474
14475 & pos(5) ) ) then
14476
14477 abs_mes = 'ABSOLUTE value of'
14478 else
14479 abs_mes = ''
14480
14481 end if
14482
14483 end if
14484 deallocate(mask_array, judge, judge_rev)
14485 deallocate(answer_negative, check_negative, both_negative)
14486
14487
14488
14489
14490 if (err_flag) then
14491 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14492 write(*,*) ''
14493 write(*,*) ' ' // trim(abs_mes) // &
14494 & ' check' // trim(pos_str) // ' = ', wrong
14495 write(*,*) ' is NOT LESS THAN'
14496 write(*,*) ' ' // trim(abs_mes) // &
14497 & ' answer' // trim(pos_str) // ' = ', right
14498
14500 else
14501 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
14502 end if
14503
14504
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
◆ dctestassertlessthanint6()
| subroutine dc_test::assertlessthan::dctestassertlessthanint6 | ( | character(*), intent(in) | message, |
| integer, dimension(:,:,:,:,:,:), intent(in) | answer, | ||
| integer, dimension(:,:,:,:,:,:), intent(in) | check, | ||
| logical, intent(in), optional | negative_support ) |
Definition at line 14508 of file dc_test.f90.
14512 implicit none
14513 character(*), intent(in):: message
14514 integer, intent(in):: answer(:,:,:,:,:,:)
14515 integer, intent(in):: check(:,:,:,:,:,:)
14516 logical, intent(in), optional:: negative_support
14517 logical:: err_flag
14518 logical:: negative_support_on
14519 character(STRING):: pos_str
14520 character(TOKEN):: abs_mes
14521 integer:: wrong, right
14522
14523 integer:: answer_shape(6), check_shape(6), pos(6)
14524 logical:: consist_shape(6)
14525 character(TOKEN):: pos_array(6)
14526 integer, allocatable:: mask_array(:,:,:,:,:,:)
14527 logical, allocatable:: judge(:,:,:,:,:,:)
14528 logical, allocatable:: judge_rev(:,:,:,:,:,:)
14529 logical, allocatable:: answer_negative(:,:,:,:,:,:)
14530 logical, allocatable:: check_negative(:,:,:,:,:,:)
14531 logical, allocatable:: both_negative(:,:,:,:,:,:)
14532
14533
14534 continue
14535 if (present(negative_support)) then
14536 negative_support_on = negative_support
14537 else
14538 negative_support_on = .true.
14539 end if
14540
14541 err_flag = .false.
14542
14543
14544 answer_shape = shape(answer)
14545 check_shape = shape(check)
14546
14547 consist_shape = answer_shape == check_shape
14548
14549 if (.not. all(consist_shape)) then
14550 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14551 write(*,*) ''
14552 write(*,*) ' shape of check is (', check_shape, ')'
14553 write(*,*) ' is INCORRECT'
14554 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
14555
14557 end if
14558
14559
14560 allocate( mask_array( &
14561 & answer_shape(1), &
14562
14563 & answer_shape(2), &
14564
14565 & answer_shape(3), &
14566
14567 & answer_shape(4), &
14568
14569 & answer_shape(5), &
14570
14571 & answer_shape(6) ) &
14572 & )
14573
14574 allocate( judge( &
14575 & answer_shape(1), &
14576
14577 & answer_shape(2), &
14578
14579 & answer_shape(3), &
14580
14581 & answer_shape(4), &
14582
14583 & answer_shape(5), &
14584
14585 & answer_shape(6) ) &
14586 & )
14587
14588 allocate( judge_rev( &
14589 & answer_shape(1), &
14590
14591 & answer_shape(2), &
14592
14593 & answer_shape(3), &
14594
14595 & answer_shape(4), &
14596
14597 & answer_shape(5), &
14598
14599 & answer_shape(6) ) &
14600 & )
14601
14602 allocate( answer_negative( &
14603 & answer_shape(1), &
14604
14605 & answer_shape(2), &
14606
14607 & answer_shape(3), &
14608
14609 & answer_shape(4), &
14610
14611 & answer_shape(5), &
14612
14613 & answer_shape(6) ) &
14614 & )
14615
14616 allocate( check_negative( &
14617 & answer_shape(1), &
14618
14619 & answer_shape(2), &
14620
14621 & answer_shape(3), &
14622
14623 & answer_shape(4), &
14624
14625 & answer_shape(5), &
14626
14627 & answer_shape(6) ) &
14628 & )
14629
14630 allocate( both_negative( &
14631 & answer_shape(1), &
14632
14633 & answer_shape(2), &
14634
14635 & answer_shape(3), &
14636
14637 & answer_shape(4), &
14638
14639 & answer_shape(5), &
14640
14641 & answer_shape(6) ) &
14642 & )
14643
14644 answer_negative = answer < 0
14645 check_negative = check < 0
14646 both_negative = answer_negative .and. check_negative
14647 if (.not. negative_support_on) both_negative = .false.
14648
14649 judge = answer > check
14650 where (both_negative) judge = .not. judge
14651
14652 judge_rev = .not. judge
14653 err_flag = any(judge_rev)
14654 mask_array = 1
14655 pos = maxloc(mask_array, judge_rev)
14656
14657 if (err_flag) then
14658
14659 wrong = check( &
14660 & pos(1), &
14661
14662 & pos(2), &
14663
14664 & pos(3), &
14665
14666 & pos(4), &
14667
14668 & pos(5), &
14669
14670 & pos(6) )
14671
14672 right = answer( &
14673 & pos(1), &
14674
14675 & pos(2), &
14676
14677 & pos(3), &
14678
14679 & pos(4), &
14680
14681 & pos(5), &
14682
14683 & pos(6) )
14684
14685 write(unit=pos_array(1), fmt="(i20)") pos(1)
14686
14687 write(unit=pos_array(2), fmt="(i20)") pos(2)
14688
14689 write(unit=pos_array(3), fmt="(i20)") pos(3)
14690
14691 write(unit=pos_array(4), fmt="(i20)") pos(4)
14692
14693 write(unit=pos_array(5), fmt="(i20)") pos(5)
14694
14695 write(unit=pos_array(6), fmt="(i20)") pos(6)
14696
14697
14698 pos_str = '(' // &
14699 & trim(adjustl(pos_array(1))) // ',' // &
14700
14701 & trim(adjustl(pos_array(2))) // ',' // &
14702
14703 & trim(adjustl(pos_array(3))) // ',' // &
14704
14705 & trim(adjustl(pos_array(4))) // ',' // &
14706
14707 & trim(adjustl(pos_array(5))) // ',' // &
14708
14709 & trim(adjustl(pos_array(6))) // ')'
14710
14711 if ( both_negative( &
14712 & pos(1), &
14713
14714 & pos(2), &
14715
14716 & pos(3), &
14717
14718 & pos(4), &
14719
14720 & pos(5), &
14721
14722 & pos(6) ) ) then
14723
14724 abs_mes = 'ABSOLUTE value of'
14725 else
14726 abs_mes = ''
14727
14728 end if
14729
14730 end if
14731 deallocate(mask_array, judge, judge_rev)
14732 deallocate(answer_negative, check_negative, both_negative)
14733
14734
14735
14736
14737 if (err_flag) then
14738 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14739 write(*,*) ''
14740 write(*,*) ' ' // trim(abs_mes) // &
14741 & ' check' // trim(pos_str) // ' = ', wrong
14742 write(*,*) ' is NOT LESS THAN'
14743 write(*,*) ' ' // trim(abs_mes) // &
14744 & ' answer' // trim(pos_str) // ' = ', right
14745
14747 else
14748 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
14749 end if
14750
14751
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
◆ dctestassertlessthanint7()
| subroutine dc_test::assertlessthan::dctestassertlessthanint7 | ( | character(*), intent(in) | message, |
| integer, dimension(:,:,:,:,:,:,:), intent(in) | answer, | ||
| integer, dimension(:,:,:,:,:,:,:), intent(in) | check, | ||
| logical, intent(in), optional | negative_support ) |
Definition at line 14755 of file dc_test.f90.
14759 implicit none
14760 character(*), intent(in):: message
14761 integer, intent(in):: answer(:,:,:,:,:,:,:)
14762 integer, intent(in):: check(:,:,:,:,:,:,:)
14763 logical, intent(in), optional:: negative_support
14764 logical:: err_flag
14765 logical:: negative_support_on
14766 character(STRING):: pos_str
14767 character(TOKEN):: abs_mes
14768 integer:: wrong, right
14769
14770 integer:: answer_shape(7), check_shape(7), pos(7)
14771 logical:: consist_shape(7)
14772 character(TOKEN):: pos_array(7)
14773 integer, allocatable:: mask_array(:,:,:,:,:,:,:)
14774 logical, allocatable:: judge(:,:,:,:,:,:,:)
14775 logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
14776 logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
14777 logical, allocatable:: check_negative(:,:,:,:,:,:,:)
14778 logical, allocatable:: both_negative(:,:,:,:,:,:,:)
14779
14780
14781 continue
14782 if (present(negative_support)) then
14783 negative_support_on = negative_support
14784 else
14785 negative_support_on = .true.
14786 end if
14787
14788 err_flag = .false.
14789
14790
14791 answer_shape = shape(answer)
14792 check_shape = shape(check)
14793
14794 consist_shape = answer_shape == check_shape
14795
14796 if (.not. all(consist_shape)) then
14797 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14798 write(*,*) ''
14799 write(*,*) ' shape of check is (', check_shape, ')'
14800 write(*,*) ' is INCORRECT'
14801 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
14802
14804 end if
14805
14806
14807 allocate( mask_array( &
14808 & answer_shape(1), &
14809
14810 & answer_shape(2), &
14811
14812 & answer_shape(3), &
14813
14814 & answer_shape(4), &
14815
14816 & answer_shape(5), &
14817
14818 & answer_shape(6), &
14819
14820 & answer_shape(7) ) &
14821 & )
14822
14823 allocate( judge( &
14824 & answer_shape(1), &
14825
14826 & answer_shape(2), &
14827
14828 & answer_shape(3), &
14829
14830 & answer_shape(4), &
14831
14832 & answer_shape(5), &
14833
14834 & answer_shape(6), &
14835
14836 & answer_shape(7) ) &
14837 & )
14838
14839 allocate( judge_rev( &
14840 & answer_shape(1), &
14841
14842 & answer_shape(2), &
14843
14844 & answer_shape(3), &
14845
14846 & answer_shape(4), &
14847
14848 & answer_shape(5), &
14849
14850 & answer_shape(6), &
14851
14852 & answer_shape(7) ) &
14853 & )
14854
14855 allocate( answer_negative( &
14856 & answer_shape(1), &
14857
14858 & answer_shape(2), &
14859
14860 & answer_shape(3), &
14861
14862 & answer_shape(4), &
14863
14864 & answer_shape(5), &
14865
14866 & answer_shape(6), &
14867
14868 & answer_shape(7) ) &
14869 & )
14870
14871 allocate( check_negative( &
14872 & answer_shape(1), &
14873
14874 & answer_shape(2), &
14875
14876 & answer_shape(3), &
14877
14878 & answer_shape(4), &
14879
14880 & answer_shape(5), &
14881
14882 & answer_shape(6), &
14883
14884 & answer_shape(7) ) &
14885 & )
14886
14887 allocate( both_negative( &
14888 & answer_shape(1), &
14889
14890 & answer_shape(2), &
14891
14892 & answer_shape(3), &
14893
14894 & answer_shape(4), &
14895
14896 & answer_shape(5), &
14897
14898 & answer_shape(6), &
14899
14900 & answer_shape(7) ) &
14901 & )
14902
14903 answer_negative = answer < 0
14904 check_negative = check < 0
14905 both_negative = answer_negative .and. check_negative
14906 if (.not. negative_support_on) both_negative = .false.
14907
14908 judge = answer > check
14909 where (both_negative) judge = .not. judge
14910
14911 judge_rev = .not. judge
14912 err_flag = any(judge_rev)
14913 mask_array = 1
14914 pos = maxloc(mask_array, judge_rev)
14915
14916 if (err_flag) then
14917
14918 wrong = check( &
14919 & pos(1), &
14920
14921 & pos(2), &
14922
14923 & pos(3), &
14924
14925 & pos(4), &
14926
14927 & pos(5), &
14928
14929 & pos(6), &
14930
14931 & pos(7) )
14932
14933 right = answer( &
14934 & pos(1), &
14935
14936 & pos(2), &
14937
14938 & pos(3), &
14939
14940 & pos(4), &
14941
14942 & pos(5), &
14943
14944 & pos(6), &
14945
14946 & pos(7) )
14947
14948 write(unit=pos_array(1), fmt="(i20)") pos(1)
14949
14950 write(unit=pos_array(2), fmt="(i20)") pos(2)
14951
14952 write(unit=pos_array(3), fmt="(i20)") pos(3)
14953
14954 write(unit=pos_array(4), fmt="(i20)") pos(4)
14955
14956 write(unit=pos_array(5), fmt="(i20)") pos(5)
14957
14958 write(unit=pos_array(6), fmt="(i20)") pos(6)
14959
14960 write(unit=pos_array(7), fmt="(i20)") pos(7)
14961
14962
14963 pos_str = '(' // &
14964 & trim(adjustl(pos_array(1))) // ',' // &
14965
14966 & trim(adjustl(pos_array(2))) // ',' // &
14967
14968 & trim(adjustl(pos_array(3))) // ',' // &
14969
14970 & trim(adjustl(pos_array(4))) // ',' // &
14971
14972 & trim(adjustl(pos_array(5))) // ',' // &
14973
14974 & trim(adjustl(pos_array(6))) // ',' // &
14975
14976 & trim(adjustl(pos_array(7))) // ')'
14977
14978 if ( both_negative( &
14979 & pos(1), &
14980
14981 & pos(2), &
14982
14983 & pos(3), &
14984
14985 & pos(4), &
14986
14987 & pos(5), &
14988
14989 & pos(6), &
14990
14991 & pos(7) ) ) then
14992
14993 abs_mes = 'ABSOLUTE value of'
14994 else
14995 abs_mes = ''
14996
14997 end if
14998
14999 end if
15000 deallocate(mask_array, judge, judge_rev)
15001 deallocate(answer_negative, check_negative, both_negative)
15002
15003
15004
15005
15006 if (err_flag) then
15007 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15008 write(*,*) ''
15009 write(*,*) ' ' // trim(abs_mes) // &
15010 & ' check' // trim(pos_str) // ' = ', wrong
15011 write(*,*) ' is NOT LESS THAN'
15012 write(*,*) ' ' // trim(abs_mes) // &
15013 & ' answer' // trim(pos_str) // ' = ', right
15014
15016 else
15017 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15018 end if
15019
15020
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
◆ dctestassertlessthanreal0()
| subroutine dc_test::assertlessthan::dctestassertlessthanreal0 | ( | character(*), intent(in) | message, |
| real, intent(in) | answer, | ||
| real, intent(in) | check, | ||
| logical, intent(in), optional | negative_support ) |
Definition at line 15024 of file dc_test.f90.
15028 implicit none
15029 character(*), intent(in):: message
15030 real, intent(in):: answer
15031 real, intent(in):: check
15032 logical, intent(in), optional:: negative_support
15033 logical:: err_flag
15034 logical:: negative_support_on
15035 character(STRING):: pos_str
15036 character(TOKEN):: abs_mes
15037 real:: wrong, right
15038
15039
15040
15041 continue
15042 if (present(negative_support)) then
15043 negative_support_on = negative_support
15044 else
15045 negative_support_on = .true.
15046 end if
15047
15048 err_flag = .false.
15049
15050
15051
15052
15053 err_flag = .not. answer > check
15054 abs_mes = ''
15055
15056 if ( answer < 0.0 &
15057 & .and. check < 0.0 &
15058 & .and. negative_support_on ) then
15059
15060 err_flag = .not. err_flag
15061 abs_mes = 'ABSOLUTE value of'
15062 end if
15063
15064 wrong = check
15065 right = answer
15066 pos_str = ''
15067
15068
15069
15070
15071 if (err_flag) then
15072 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15073 write(*,*) ''
15074 write(*,*) ' ' // trim(abs_mes) // &
15075 & ' check' // trim(pos_str) // ' = ', wrong
15076 write(*,*) ' is NOT LESS THAN'
15077 write(*,*) ' ' // trim(abs_mes) // &
15078 & ' answer' // trim(pos_str) // ' = ', right
15079
15081 else
15082 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15083 end if
15084
15085
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
◆ dctestassertlessthanreal1()
| subroutine dc_test::assertlessthan::dctestassertlessthanreal1 | ( | character(*), intent(in) | message, |
| real, dimension(:), intent(in) | answer, | ||
| real, dimension(:), intent(in) | check, | ||
| logical, intent(in), optional | negative_support ) |
Definition at line 15089 of file dc_test.f90.
15093 implicit none
15094 character(*), intent(in):: message
15095 real, intent(in):: answer(:)
15096 real, intent(in):: check(:)
15097 logical, intent(in), optional:: negative_support
15098 logical:: err_flag
15099 logical:: negative_support_on
15100 character(STRING):: pos_str
15101 character(TOKEN):: abs_mes
15102 real:: wrong, right
15103
15104 integer:: answer_shape(1), check_shape(1), pos(1)
15105 logical:: consist_shape(1)
15106 character(TOKEN):: pos_array(1)
15107 integer, allocatable:: mask_array(:)
15108 logical, allocatable:: judge(:)
15109 logical, allocatable:: judge_rev(:)
15110 logical, allocatable:: answer_negative(:)
15111 logical, allocatable:: check_negative(:)
15112 logical, allocatable:: both_negative(:)
15113
15114
15115 continue
15116 if (present(negative_support)) then
15117 negative_support_on = negative_support
15118 else
15119 negative_support_on = .true.
15120 end if
15121
15122 err_flag = .false.
15123
15124
15125 answer_shape = shape(answer)
15126 check_shape = shape(check)
15127
15128 consist_shape = answer_shape == check_shape
15129
15130 if (.not. all(consist_shape)) then
15131 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15132 write(*,*) ''
15133 write(*,*) ' shape of check is (', check_shape, ')'
15134 write(*,*) ' is INCORRECT'
15135 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15136
15138 end if
15139
15140
15141 allocate( mask_array( &
15142
15143 & answer_shape(1) ) &
15144 & )
15145
15146 allocate( judge( &
15147
15148 & answer_shape(1) ) &
15149 & )
15150
15151 allocate( judge_rev( &
15152
15153 & answer_shape(1) ) &
15154 & )
15155
15156 allocate( answer_negative( &
15157
15158 & answer_shape(1) ) &
15159 & )
15160
15161 allocate( check_negative( &
15162
15163 & answer_shape(1) ) &
15164 & )
15165
15166 allocate( both_negative( &
15167
15168 & answer_shape(1) ) &
15169 & )
15170
15171 answer_negative = answer < 0.0
15172 check_negative = check < 0.0
15173 both_negative = answer_negative .and. check_negative
15174 if (.not. negative_support_on) both_negative = .false.
15175
15176 judge = answer > check
15177 where (both_negative) judge = .not. judge
15178
15179 judge_rev = .not. judge
15180 err_flag = any(judge_rev)
15181 mask_array = 1
15182 pos = maxloc(mask_array, judge_rev)
15183
15184 if (err_flag) then
15185
15186 wrong = check( &
15187
15188 & pos(1) )
15189
15190 right = answer( &
15191
15192 & pos(1) )
15193
15194 write(unit=pos_array(1), fmt="(i20)") pos(1)
15195
15196
15197 pos_str = '(' // &
15198
15199 & trim(adjustl(pos_array(1))) // ')'
15200
15201 if ( both_negative( &
15202
15203 & pos(1) ) ) then
15204
15205 abs_mes = 'ABSOLUTE value of'
15206 else
15207 abs_mes = ''
15208
15209 end if
15210
15211 end if
15212 deallocate(mask_array, judge, judge_rev)
15213 deallocate(answer_negative, check_negative, both_negative)
15214
15215
15216
15217
15218 if (err_flag) then
15219 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15220 write(*,*) ''
15221 write(*,*) ' ' // trim(abs_mes) // &
15222 & ' check' // trim(pos_str) // ' = ', wrong
15223 write(*,*) ' is NOT LESS THAN'
15224 write(*,*) ' ' // trim(abs_mes) // &
15225 & ' answer' // trim(pos_str) // ' = ', right
15226
15228 else
15229 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15230 end if
15231
15232
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
◆ dctestassertlessthanreal2()
| subroutine dc_test::assertlessthan::dctestassertlessthanreal2 | ( | character(*), intent(in) | message, |
| real, dimension(:,:), intent(in) | answer, | ||
| real, dimension(:,:), intent(in) | check, | ||
| logical, intent(in), optional | negative_support ) |
Definition at line 15236 of file dc_test.f90.
15240 implicit none
15241 character(*), intent(in):: message
15242 real, intent(in):: answer(:,:)
15243 real, intent(in):: check(:,:)
15244 logical, intent(in), optional:: negative_support
15245 logical:: err_flag
15246 logical:: negative_support_on
15247 character(STRING):: pos_str
15248 character(TOKEN):: abs_mes
15249 real:: wrong, right
15250
15251 integer:: answer_shape(2), check_shape(2), pos(2)
15252 logical:: consist_shape(2)
15253 character(TOKEN):: pos_array(2)
15254 integer, allocatable:: mask_array(:,:)
15255 logical, allocatable:: judge(:,:)
15256 logical, allocatable:: judge_rev(:,:)
15257 logical, allocatable:: answer_negative(:,:)
15258 logical, allocatable:: check_negative(:,:)
15259 logical, allocatable:: both_negative(:,:)
15260
15261
15262 continue
15263 if (present(negative_support)) then
15264 negative_support_on = negative_support
15265 else
15266 negative_support_on = .true.
15267 end if
15268
15269 err_flag = .false.
15270
15271
15272 answer_shape = shape(answer)
15273 check_shape = shape(check)
15274
15275 consist_shape = answer_shape == check_shape
15276
15277 if (.not. all(consist_shape)) then
15278 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15279 write(*,*) ''
15280 write(*,*) ' shape of check is (', check_shape, ')'
15281 write(*,*) ' is INCORRECT'
15282 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15283
15285 end if
15286
15287
15288 allocate( mask_array( &
15289 & answer_shape(1), &
15290
15291 & answer_shape(2) ) &
15292 & )
15293
15294 allocate( judge( &
15295 & answer_shape(1), &
15296
15297 & answer_shape(2) ) &
15298 & )
15299
15300 allocate( judge_rev( &
15301 & answer_shape(1), &
15302
15303 & answer_shape(2) ) &
15304 & )
15305
15306 allocate( answer_negative( &
15307 & answer_shape(1), &
15308
15309 & answer_shape(2) ) &
15310 & )
15311
15312 allocate( check_negative( &
15313 & answer_shape(1), &
15314
15315 & answer_shape(2) ) &
15316 & )
15317
15318 allocate( both_negative( &
15319 & answer_shape(1), &
15320
15321 & answer_shape(2) ) &
15322 & )
15323
15324 answer_negative = answer < 0.0
15325 check_negative = check < 0.0
15326 both_negative = answer_negative .and. check_negative
15327 if (.not. negative_support_on) both_negative = .false.
15328
15329 judge = answer > check
15330 where (both_negative) judge = .not. judge
15331
15332 judge_rev = .not. judge
15333 err_flag = any(judge_rev)
15334 mask_array = 1
15335 pos = maxloc(mask_array, judge_rev)
15336
15337 if (err_flag) then
15338
15339 wrong = check( &
15340 & pos(1), &
15341
15342 & pos(2) )
15343
15344 right = answer( &
15345 & pos(1), &
15346
15347 & pos(2) )
15348
15349 write(unit=pos_array(1), fmt="(i20)") pos(1)
15350
15351 write(unit=pos_array(2), fmt="(i20)") pos(2)
15352
15353
15354 pos_str = '(' // &
15355 & trim(adjustl(pos_array(1))) // ',' // &
15356
15357 & trim(adjustl(pos_array(2))) // ')'
15358
15359 if ( both_negative( &
15360 & pos(1), &
15361
15362 & pos(2) ) ) then
15363
15364 abs_mes = 'ABSOLUTE value of'
15365 else
15366 abs_mes = ''
15367
15368 end if
15369
15370 end if
15371 deallocate(mask_array, judge, judge_rev)
15372 deallocate(answer_negative, check_negative, both_negative)
15373
15374
15375
15376
15377 if (err_flag) then
15378 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15379 write(*,*) ''
15380 write(*,*) ' ' // trim(abs_mes) // &
15381 & ' check' // trim(pos_str) // ' = ', wrong
15382 write(*,*) ' is NOT LESS THAN'
15383 write(*,*) ' ' // trim(abs_mes) // &
15384 & ' answer' // trim(pos_str) // ' = ', right
15385
15387 else
15388 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15389 end if
15390
15391
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
◆ dctestassertlessthanreal3()
| subroutine dc_test::assertlessthan::dctestassertlessthanreal3 | ( | character(*), intent(in) | message, |
| real, dimension(:,:,:), intent(in) | answer, | ||
| real, dimension(:,:,:), intent(in) | check, | ||
| logical, intent(in), optional | negative_support ) |
Definition at line 15395 of file dc_test.f90.
15399 implicit none
15400 character(*), intent(in):: message
15401 real, intent(in):: answer(:,:,:)
15402 real, intent(in):: check(:,:,:)
15403 logical, intent(in), optional:: negative_support
15404 logical:: err_flag
15405 logical:: negative_support_on
15406 character(STRING):: pos_str
15407 character(TOKEN):: abs_mes
15408 real:: wrong, right
15409
15410 integer:: answer_shape(3), check_shape(3), pos(3)
15411 logical:: consist_shape(3)
15412 character(TOKEN):: pos_array(3)
15413 integer, allocatable:: mask_array(:,:,:)
15414 logical, allocatable:: judge(:,:,:)
15415 logical, allocatable:: judge_rev(:,:,:)
15416 logical, allocatable:: answer_negative(:,:,:)
15417 logical, allocatable:: check_negative(:,:,:)
15418 logical, allocatable:: both_negative(:,:,:)
15419
15420
15421 continue
15422 if (present(negative_support)) then
15423 negative_support_on = negative_support
15424 else
15425 negative_support_on = .true.
15426 end if
15427
15428 err_flag = .false.
15429
15430
15431 answer_shape = shape(answer)
15432 check_shape = shape(check)
15433
15434 consist_shape = answer_shape == check_shape
15435
15436 if (.not. all(consist_shape)) then
15437 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15438 write(*,*) ''
15439 write(*,*) ' shape of check is (', check_shape, ')'
15440 write(*,*) ' is INCORRECT'
15441 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15442
15444 end if
15445
15446
15447 allocate( mask_array( &
15448 & answer_shape(1), &
15449
15450 & answer_shape(2), &
15451
15452 & answer_shape(3) ) &
15453 & )
15454
15455 allocate( judge( &
15456 & answer_shape(1), &
15457
15458 & answer_shape(2), &
15459
15460 & answer_shape(3) ) &
15461 & )
15462
15463 allocate( judge_rev( &
15464 & answer_shape(1), &
15465
15466 & answer_shape(2), &
15467
15468 & answer_shape(3) ) &
15469 & )
15470
15471 allocate( answer_negative( &
15472 & answer_shape(1), &
15473
15474 & answer_shape(2), &
15475
15476 & answer_shape(3) ) &
15477 & )
15478
15479 allocate( check_negative( &
15480 & answer_shape(1), &
15481
15482 & answer_shape(2), &
15483
15484 & answer_shape(3) ) &
15485 & )
15486
15487 allocate( both_negative( &
15488 & answer_shape(1), &
15489
15490 & answer_shape(2), &
15491
15492 & answer_shape(3) ) &
15493 & )
15494
15495 answer_negative = answer < 0.0
15496 check_negative = check < 0.0
15497 both_negative = answer_negative .and. check_negative
15498 if (.not. negative_support_on) both_negative = .false.
15499
15500 judge = answer > check
15501 where (both_negative) judge = .not. judge
15502
15503 judge_rev = .not. judge
15504 err_flag = any(judge_rev)
15505 mask_array = 1
15506 pos = maxloc(mask_array, judge_rev)
15507
15508 if (err_flag) then
15509
15510 wrong = check( &
15511 & pos(1), &
15512
15513 & pos(2), &
15514
15515 & pos(3) )
15516
15517 right = answer( &
15518 & pos(1), &
15519
15520 & pos(2), &
15521
15522 & pos(3) )
15523
15524 write(unit=pos_array(1), fmt="(i20)") pos(1)
15525
15526 write(unit=pos_array(2), fmt="(i20)") pos(2)
15527
15528 write(unit=pos_array(3), fmt="(i20)") pos(3)
15529
15530
15531 pos_str = '(' // &
15532 & trim(adjustl(pos_array(1))) // ',' // &
15533
15534 & trim(adjustl(pos_array(2))) // ',' // &
15535
15536 & trim(adjustl(pos_array(3))) // ')'
15537
15538 if ( both_negative( &
15539 & pos(1), &
15540
15541 & pos(2), &
15542
15543 & pos(3) ) ) then
15544
15545 abs_mes = 'ABSOLUTE value of'
15546 else
15547 abs_mes = ''
15548
15549 end if
15550
15551 end if
15552 deallocate(mask_array, judge, judge_rev)
15553 deallocate(answer_negative, check_negative, both_negative)
15554
15555
15556
15557
15558 if (err_flag) then
15559 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15560 write(*,*) ''
15561 write(*,*) ' ' // trim(abs_mes) // &
15562 & ' check' // trim(pos_str) // ' = ', wrong
15563 write(*,*) ' is NOT LESS THAN'
15564 write(*,*) ' ' // trim(abs_mes) // &
15565 & ' answer' // trim(pos_str) // ' = ', right
15566
15568 else
15569 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15570 end if
15571
15572
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
◆ dctestassertlessthanreal4()
| subroutine dc_test::assertlessthan::dctestassertlessthanreal4 | ( | character(*), intent(in) | message, |
| real, dimension(:,:,:,:), intent(in) | answer, | ||
| real, dimension(:,:,:,:), intent(in) | check, | ||
| logical, intent(in), optional | negative_support ) |
Definition at line 15576 of file dc_test.f90.
15580 implicit none
15581 character(*), intent(in):: message
15582 real, intent(in):: answer(:,:,:,:)
15583 real, intent(in):: check(:,:,:,:)
15584 logical, intent(in), optional:: negative_support
15585 logical:: err_flag
15586 logical:: negative_support_on
15587 character(STRING):: pos_str
15588 character(TOKEN):: abs_mes
15589 real:: wrong, right
15590
15591 integer:: answer_shape(4), check_shape(4), pos(4)
15592 logical:: consist_shape(4)
15593 character(TOKEN):: pos_array(4)
15594 integer, allocatable:: mask_array(:,:,:,:)
15595 logical, allocatable:: judge(:,:,:,:)
15596 logical, allocatable:: judge_rev(:,:,:,:)
15597 logical, allocatable:: answer_negative(:,:,:,:)
15598 logical, allocatable:: check_negative(:,:,:,:)
15599 logical, allocatable:: both_negative(:,:,:,:)
15600
15601
15602 continue
15603 if (present(negative_support)) then
15604 negative_support_on = negative_support
15605 else
15606 negative_support_on = .true.
15607 end if
15608
15609 err_flag = .false.
15610
15611
15612 answer_shape = shape(answer)
15613 check_shape = shape(check)
15614
15615 consist_shape = answer_shape == check_shape
15616
15617 if (.not. all(consist_shape)) then
15618 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15619 write(*,*) ''
15620 write(*,*) ' shape of check is (', check_shape, ')'
15621 write(*,*) ' is INCORRECT'
15622 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15623
15625 end if
15626
15627
15628 allocate( mask_array( &
15629 & answer_shape(1), &
15630
15631 & answer_shape(2), &
15632
15633 & answer_shape(3), &
15634
15635 & answer_shape(4) ) &
15636 & )
15637
15638 allocate( judge( &
15639 & answer_shape(1), &
15640
15641 & answer_shape(2), &
15642
15643 & answer_shape(3), &
15644
15645 & answer_shape(4) ) &
15646 & )
15647
15648 allocate( judge_rev( &
15649 & answer_shape(1), &
15650
15651 & answer_shape(2), &
15652
15653 & answer_shape(3), &
15654
15655 & answer_shape(4) ) &
15656 & )
15657
15658 allocate( answer_negative( &
15659 & answer_shape(1), &
15660
15661 & answer_shape(2), &
15662
15663 & answer_shape(3), &
15664
15665 & answer_shape(4) ) &
15666 & )
15667
15668 allocate( check_negative( &
15669 & answer_shape(1), &
15670
15671 & answer_shape(2), &
15672
15673 & answer_shape(3), &
15674
15675 & answer_shape(4) ) &
15676 & )
15677
15678 allocate( both_negative( &
15679 & answer_shape(1), &
15680
15681 & answer_shape(2), &
15682
15683 & answer_shape(3), &
15684
15685 & answer_shape(4) ) &
15686 & )
15687
15688 answer_negative = answer < 0.0
15689 check_negative = check < 0.0
15690 both_negative = answer_negative .and. check_negative
15691 if (.not. negative_support_on) both_negative = .false.
15692
15693 judge = answer > check
15694 where (both_negative) judge = .not. judge
15695
15696 judge_rev = .not. judge
15697 err_flag = any(judge_rev)
15698 mask_array = 1
15699 pos = maxloc(mask_array, judge_rev)
15700
15701 if (err_flag) then
15702
15703 wrong = check( &
15704 & pos(1), &
15705
15706 & pos(2), &
15707
15708 & pos(3), &
15709
15710 & pos(4) )
15711
15712 right = answer( &
15713 & pos(1), &
15714
15715 & pos(2), &
15716
15717 & pos(3), &
15718
15719 & pos(4) )
15720
15721 write(unit=pos_array(1), fmt="(i20)") pos(1)
15722
15723 write(unit=pos_array(2), fmt="(i20)") pos(2)
15724
15725 write(unit=pos_array(3), fmt="(i20)") pos(3)
15726
15727 write(unit=pos_array(4), fmt="(i20)") pos(4)
15728
15729
15730 pos_str = '(' // &
15731 & trim(adjustl(pos_array(1))) // ',' // &
15732
15733 & trim(adjustl(pos_array(2))) // ',' // &
15734
15735 & trim(adjustl(pos_array(3))) // ',' // &
15736
15737 & trim(adjustl(pos_array(4))) // ')'
15738
15739 if ( both_negative( &
15740 & pos(1), &
15741
15742 & pos(2), &
15743
15744 & pos(3), &
15745
15746 & pos(4) ) ) then
15747
15748 abs_mes = 'ABSOLUTE value of'
15749 else
15750 abs_mes = ''
15751
15752 end if
15753
15754 end if
15755 deallocate(mask_array, judge, judge_rev)
15756 deallocate(answer_negative, check_negative, both_negative)
15757
15758
15759
15760
15761 if (err_flag) then
15762 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15763 write(*,*) ''
15764 write(*,*) ' ' // trim(abs_mes) // &
15765 & ' check' // trim(pos_str) // ' = ', wrong
15766 write(*,*) ' is NOT LESS THAN'
15767 write(*,*) ' ' // trim(abs_mes) // &
15768 & ' answer' // trim(pos_str) // ' = ', right
15769
15771 else
15772 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15773 end if
15774
15775
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
◆ dctestassertlessthanreal5()
| subroutine dc_test::assertlessthan::dctestassertlessthanreal5 | ( | character(*), intent(in) | message, |
| real, dimension(:,:,:,:,:), intent(in) | answer, | ||
| real, dimension(:,:,:,:,:), intent(in) | check, | ||
| logical, intent(in), optional | negative_support ) |
Definition at line 15779 of file dc_test.f90.
15783 implicit none
15784 character(*), intent(in):: message
15785 real, intent(in):: answer(:,:,:,:,:)
15786 real, intent(in):: check(:,:,:,:,:)
15787 logical, intent(in), optional:: negative_support
15788 logical:: err_flag
15789 logical:: negative_support_on
15790 character(STRING):: pos_str
15791 character(TOKEN):: abs_mes
15792 real:: wrong, right
15793
15794 integer:: answer_shape(5), check_shape(5), pos(5)
15795 logical:: consist_shape(5)
15796 character(TOKEN):: pos_array(5)
15797 integer, allocatable:: mask_array(:,:,:,:,:)
15798 logical, allocatable:: judge(:,:,:,:,:)
15799 logical, allocatable:: judge_rev(:,:,:,:,:)
15800 logical, allocatable:: answer_negative(:,:,:,:,:)
15801 logical, allocatable:: check_negative(:,:,:,:,:)
15802 logical, allocatable:: both_negative(:,:,:,:,:)
15803
15804
15805 continue
15806 if (present(negative_support)) then
15807 negative_support_on = negative_support
15808 else
15809 negative_support_on = .true.
15810 end if
15811
15812 err_flag = .false.
15813
15814
15815 answer_shape = shape(answer)
15816 check_shape = shape(check)
15817
15818 consist_shape = answer_shape == check_shape
15819
15820 if (.not. all(consist_shape)) then
15821 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15822 write(*,*) ''
15823 write(*,*) ' shape of check is (', check_shape, ')'
15824 write(*,*) ' is INCORRECT'
15825 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15826
15828 end if
15829
15830
15831 allocate( mask_array( &
15832 & answer_shape(1), &
15833
15834 & answer_shape(2), &
15835
15836 & answer_shape(3), &
15837
15838 & answer_shape(4), &
15839
15840 & answer_shape(5) ) &
15841 & )
15842
15843 allocate( judge( &
15844 & answer_shape(1), &
15845
15846 & answer_shape(2), &
15847
15848 & answer_shape(3), &
15849
15850 & answer_shape(4), &
15851
15852 & answer_shape(5) ) &
15853 & )
15854
15855 allocate( judge_rev( &
15856 & answer_shape(1), &
15857
15858 & answer_shape(2), &
15859
15860 & answer_shape(3), &
15861
15862 & answer_shape(4), &
15863
15864 & answer_shape(5) ) &
15865 & )
15866
15867 allocate( answer_negative( &
15868 & answer_shape(1), &
15869
15870 & answer_shape(2), &
15871
15872 & answer_shape(3), &
15873
15874 & answer_shape(4), &
15875
15876 & answer_shape(5) ) &
15877 & )
15878
15879 allocate( check_negative( &
15880 & answer_shape(1), &
15881
15882 & answer_shape(2), &
15883
15884 & answer_shape(3), &
15885
15886 & answer_shape(4), &
15887
15888 & answer_shape(5) ) &
15889 & )
15890
15891 allocate( both_negative( &
15892 & answer_shape(1), &
15893
15894 & answer_shape(2), &
15895
15896 & answer_shape(3), &
15897
15898 & answer_shape(4), &
15899
15900 & answer_shape(5) ) &
15901 & )
15902
15903 answer_negative = answer < 0.0
15904 check_negative = check < 0.0
15905 both_negative = answer_negative .and. check_negative
15906 if (.not. negative_support_on) both_negative = .false.
15907
15908 judge = answer > check
15909 where (both_negative) judge = .not. judge
15910
15911 judge_rev = .not. judge
15912 err_flag = any(judge_rev)
15913 mask_array = 1
15914 pos = maxloc(mask_array, judge_rev)
15915
15916 if (err_flag) then
15917
15918 wrong = check( &
15919 & pos(1), &
15920
15921 & pos(2), &
15922
15923 & pos(3), &
15924
15925 & pos(4), &
15926
15927 & pos(5) )
15928
15929 right = answer( &
15930 & pos(1), &
15931
15932 & pos(2), &
15933
15934 & pos(3), &
15935
15936 & pos(4), &
15937
15938 & pos(5) )
15939
15940 write(unit=pos_array(1), fmt="(i20)") pos(1)
15941
15942 write(unit=pos_array(2), fmt="(i20)") pos(2)
15943
15944 write(unit=pos_array(3), fmt="(i20)") pos(3)
15945
15946 write(unit=pos_array(4), fmt="(i20)") pos(4)
15947
15948 write(unit=pos_array(5), fmt="(i20)") pos(5)
15949
15950
15951 pos_str = '(' // &
15952 & trim(adjustl(pos_array(1))) // ',' // &
15953
15954 & trim(adjustl(pos_array(2))) // ',' // &
15955
15956 & trim(adjustl(pos_array(3))) // ',' // &
15957
15958 & trim(adjustl(pos_array(4))) // ',' // &
15959
15960 & trim(adjustl(pos_array(5))) // ')'
15961
15962 if ( both_negative( &
15963 & pos(1), &
15964
15965 & pos(2), &
15966
15967 & pos(3), &
15968
15969 & pos(4), &
15970
15971 & pos(5) ) ) then
15972
15973 abs_mes = 'ABSOLUTE value of'
15974 else
15975 abs_mes = ''
15976
15977 end if
15978
15979 end if
15980 deallocate(mask_array, judge, judge_rev)
15981 deallocate(answer_negative, check_negative, both_negative)
15982
15983
15984
15985
15986 if (err_flag) then
15987 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15988 write(*,*) ''
15989 write(*,*) ' ' // trim(abs_mes) // &
15990 & ' check' // trim(pos_str) // ' = ', wrong
15991 write(*,*) ' is NOT LESS THAN'
15992 write(*,*) ' ' // trim(abs_mes) // &
15993 & ' answer' // trim(pos_str) // ' = ', right
15994
15996 else
15997 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15998 end if
15999
16000
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
◆ dctestassertlessthanreal6()
| subroutine dc_test::assertlessthan::dctestassertlessthanreal6 | ( | character(*), intent(in) | message, |
| real, dimension(:,:,:,:,:,:), intent(in) | answer, | ||
| real, dimension(:,:,:,:,:,:), intent(in) | check, | ||
| logical, intent(in), optional | negative_support ) |
Definition at line 16004 of file dc_test.f90.
16008 implicit none
16009 character(*), intent(in):: message
16010 real, intent(in):: answer(:,:,:,:,:,:)
16011 real, intent(in):: check(:,:,:,:,:,:)
16012 logical, intent(in), optional:: negative_support
16013 logical:: err_flag
16014 logical:: negative_support_on
16015 character(STRING):: pos_str
16016 character(TOKEN):: abs_mes
16017 real:: wrong, right
16018
16019 integer:: answer_shape(6), check_shape(6), pos(6)
16020 logical:: consist_shape(6)
16021 character(TOKEN):: pos_array(6)
16022 integer, allocatable:: mask_array(:,:,:,:,:,:)
16023 logical, allocatable:: judge(:,:,:,:,:,:)
16024 logical, allocatable:: judge_rev(:,:,:,:,:,:)
16025 logical, allocatable:: answer_negative(:,:,:,:,:,:)
16026 logical, allocatable:: check_negative(:,:,:,:,:,:)
16027 logical, allocatable:: both_negative(:,:,:,:,:,:)
16028
16029
16030 continue
16031 if (present(negative_support)) then
16032 negative_support_on = negative_support
16033 else
16034 negative_support_on = .true.
16035 end if
16036
16037 err_flag = .false.
16038
16039
16040 answer_shape = shape(answer)
16041 check_shape = shape(check)
16042
16043 consist_shape = answer_shape == check_shape
16044
16045 if (.not. all(consist_shape)) then
16046 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16047 write(*,*) ''
16048 write(*,*) ' shape of check is (', check_shape, ')'
16049 write(*,*) ' is INCORRECT'
16050 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
16051
16053 end if
16054
16055
16056 allocate( mask_array( &
16057 & answer_shape(1), &
16058
16059 & answer_shape(2), &
16060
16061 & answer_shape(3), &
16062
16063 & answer_shape(4), &
16064
16065 & answer_shape(5), &
16066
16067 & answer_shape(6) ) &
16068 & )
16069
16070 allocate( judge( &
16071 & answer_shape(1), &
16072
16073 & answer_shape(2), &
16074
16075 & answer_shape(3), &
16076
16077 & answer_shape(4), &
16078
16079 & answer_shape(5), &
16080
16081 & answer_shape(6) ) &
16082 & )
16083
16084 allocate( judge_rev( &
16085 & answer_shape(1), &
16086
16087 & answer_shape(2), &
16088
16089 & answer_shape(3), &
16090
16091 & answer_shape(4), &
16092
16093 & answer_shape(5), &
16094
16095 & answer_shape(6) ) &
16096 & )
16097
16098 allocate( answer_negative( &
16099 & answer_shape(1), &
16100
16101 & answer_shape(2), &
16102
16103 & answer_shape(3), &
16104
16105 & answer_shape(4), &
16106
16107 & answer_shape(5), &
16108
16109 & answer_shape(6) ) &
16110 & )
16111
16112 allocate( check_negative( &
16113 & answer_shape(1), &
16114
16115 & answer_shape(2), &
16116
16117 & answer_shape(3), &
16118
16119 & answer_shape(4), &
16120
16121 & answer_shape(5), &
16122
16123 & answer_shape(6) ) &
16124 & )
16125
16126 allocate( both_negative( &
16127 & answer_shape(1), &
16128
16129 & answer_shape(2), &
16130
16131 & answer_shape(3), &
16132
16133 & answer_shape(4), &
16134
16135 & answer_shape(5), &
16136
16137 & answer_shape(6) ) &
16138 & )
16139
16140 answer_negative = answer < 0.0
16141 check_negative = check < 0.0
16142 both_negative = answer_negative .and. check_negative
16143 if (.not. negative_support_on) both_negative = .false.
16144
16145 judge = answer > check
16146 where (both_negative) judge = .not. judge
16147
16148 judge_rev = .not. judge
16149 err_flag = any(judge_rev)
16150 mask_array = 1
16151 pos = maxloc(mask_array, judge_rev)
16152
16153 if (err_flag) then
16154
16155 wrong = check( &
16156 & pos(1), &
16157
16158 & pos(2), &
16159
16160 & pos(3), &
16161
16162 & pos(4), &
16163
16164 & pos(5), &
16165
16166 & pos(6) )
16167
16168 right = answer( &
16169 & pos(1), &
16170
16171 & pos(2), &
16172
16173 & pos(3), &
16174
16175 & pos(4), &
16176
16177 & pos(5), &
16178
16179 & pos(6) )
16180
16181 write(unit=pos_array(1), fmt="(i20)") pos(1)
16182
16183 write(unit=pos_array(2), fmt="(i20)") pos(2)
16184
16185 write(unit=pos_array(3), fmt="(i20)") pos(3)
16186
16187 write(unit=pos_array(4), fmt="(i20)") pos(4)
16188
16189 write(unit=pos_array(5), fmt="(i20)") pos(5)
16190
16191 write(unit=pos_array(6), fmt="(i20)") pos(6)
16192
16193
16194 pos_str = '(' // &
16195 & trim(adjustl(pos_array(1))) // ',' // &
16196
16197 & trim(adjustl(pos_array(2))) // ',' // &
16198
16199 & trim(adjustl(pos_array(3))) // ',' // &
16200
16201 & trim(adjustl(pos_array(4))) // ',' // &
16202
16203 & trim(adjustl(pos_array(5))) // ',' // &
16204
16205 & trim(adjustl(pos_array(6))) // ')'
16206
16207 if ( both_negative( &
16208 & pos(1), &
16209
16210 & pos(2), &
16211
16212 & pos(3), &
16213
16214 & pos(4), &
16215
16216 & pos(5), &
16217
16218 & pos(6) ) ) then
16219
16220 abs_mes = 'ABSOLUTE value of'
16221 else
16222 abs_mes = ''
16223
16224 end if
16225
16226 end if
16227 deallocate(mask_array, judge, judge_rev)
16228 deallocate(answer_negative, check_negative, both_negative)
16229
16230
16231
16232
16233 if (err_flag) then
16234 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16235 write(*,*) ''
16236 write(*,*) ' ' // trim(abs_mes) // &
16237 & ' check' // trim(pos_str) // ' = ', wrong
16238 write(*,*) ' is NOT LESS THAN'
16239 write(*,*) ' ' // trim(abs_mes) // &
16240 & ' answer' // trim(pos_str) // ' = ', right
16241
16243 else
16244 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16245 end if
16246
16247
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
◆ dctestassertlessthanreal7()
| subroutine dc_test::assertlessthan::dctestassertlessthanreal7 | ( | character(*), intent(in) | message, |
| real, dimension(:,:,:,:,:,:,:), intent(in) | answer, | ||
| real, dimension(:,:,:,:,:,:,:), intent(in) | check, | ||
| logical, intent(in), optional | negative_support ) |
Definition at line 16251 of file dc_test.f90.
16255 implicit none
16256 character(*), intent(in):: message
16257 real, intent(in):: answer(:,:,:,:,:,:,:)
16258 real, intent(in):: check(:,:,:,:,:,:,:)
16259 logical, intent(in), optional:: negative_support
16260 logical:: err_flag
16261 logical:: negative_support_on
16262 character(STRING):: pos_str
16263 character(TOKEN):: abs_mes
16264 real:: wrong, right
16265
16266 integer:: answer_shape(7), check_shape(7), pos(7)
16267 logical:: consist_shape(7)
16268 character(TOKEN):: pos_array(7)
16269 integer, allocatable:: mask_array(:,:,:,:,:,:,:)
16270 logical, allocatable:: judge(:,:,:,:,:,:,:)
16271 logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
16272 logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
16273 logical, allocatable:: check_negative(:,:,:,:,:,:,:)
16274 logical, allocatable:: both_negative(:,:,:,:,:,:,:)
16275
16276
16277 continue
16278 if (present(negative_support)) then
16279 negative_support_on = negative_support
16280 else
16281 negative_support_on = .true.
16282 end if
16283
16284 err_flag = .false.
16285
16286
16287 answer_shape = shape(answer)
16288 check_shape = shape(check)
16289
16290 consist_shape = answer_shape == check_shape
16291
16292 if (.not. all(consist_shape)) then
16293 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16294 write(*,*) ''
16295 write(*,*) ' shape of check is (', check_shape, ')'
16296 write(*,*) ' is INCORRECT'
16297 write(*,*) ' Correct shape of answer is (', answer_shape, ')'
16298
16300 end if
16301
16302
16303 allocate( mask_array( &
16304 & answer_shape(1), &
16305
16306 & answer_shape(2), &
16307
16308 & answer_shape(3), &
16309
16310 & answer_shape(4), &
16311
16312 & answer_shape(5), &
16313
16314 & answer_shape(6), &
16315
16316 & answer_shape(7) ) &
16317 & )
16318
16319 allocate( judge( &
16320 & answer_shape(1), &
16321
16322 & answer_shape(2), &
16323
16324 & answer_shape(3), &
16325
16326 & answer_shape(4), &
16327
16328 & answer_shape(5), &
16329
16330 & answer_shape(6), &
16331
16332 & answer_shape(7) ) &
16333 & )
16334
16335 allocate( judge_rev( &
16336 & answer_shape(1), &
16337
16338 & answer_shape(2), &
16339
16340 & answer_shape(3), &
16341
16342 & answer_shape(4), &
16343
16344 & answer_shape(5), &
16345
16346 & answer_shape(6), &
16347
16348 & answer_shape(7) ) &
16349 & )
16350
16351 allocate( answer_negative( &
16352 & answer_shape(1), &
16353
16354 & answer_shape(2), &
16355
16356 & answer_shape(3), &
16357
16358 & answer_shape(4), &
16359
16360 & answer_shape(5), &
16361
16362 & answer_shape(6), &
16363
16364 & answer_shape(7) ) &
16365 & )
16366
16367 allocate( check_negative( &
16368 & answer_shape(1), &
16369
16370 & answer_shape(2), &
16371
16372 & answer_shape(3), &
16373
16374 & answer_shape(4), &
16375
16376 & answer_shape(5), &
16377
16378 & answer_shape(6), &
16379
16380 & answer_shape(7) ) &
16381 & )
16382
16383 allocate( both_negative( &
16384 & answer_shape(1), &
16385
16386 & answer_shape(2), &
16387
16388 & answer_shape(3), &
16389
16390 & answer_shape(4), &
16391
16392 & answer_shape(5), &
16393
16394 & answer_shape(6), &
16395
16396 & answer_shape(7) ) &
16397 & )
16398
16399 answer_negative = answer < 0.0
16400 check_negative = check < 0.0
16401 both_negative = answer_negative .and. check_negative
16402 if (.not. negative_support_on) both_negative = .false.
16403
16404 judge = answer > check
16405 where (both_negative) judge = .not. judge
16406
16407 judge_rev = .not. judge
16408 err_flag = any(judge_rev)
16409 mask_array = 1
16410 pos = maxloc(mask_array, judge_rev)
16411
16412 if (err_flag) then
16413
16414 wrong = check( &
16415 & pos(1), &
16416
16417 & pos(2), &
16418
16419 & pos(3), &
16420
16421 & pos(4), &
16422
16423 & pos(5), &
16424
16425 & pos(6), &
16426
16427 & pos(7) )
16428
16429 right = answer( &
16430 & pos(1), &
16431
16432 & pos(2), &
16433
16434 & pos(3), &
16435
16436 & pos(4), &
16437
16438 & pos(5), &
16439
16440 & pos(6), &
16441
16442 & pos(7) )
16443
16444 write(unit=pos_array(1), fmt="(i20)") pos(1)
16445
16446 write(unit=pos_array(2), fmt="(i20)") pos(2)
16447
16448 write(unit=pos_array(3), fmt="(i20)") pos(3)
16449
16450 write(unit=pos_array(4), fmt="(i20)") pos(4)
16451
16452 write(unit=pos_array(5), fmt="(i20)") pos(5)
16453
16454 write(unit=pos_array(6), fmt="(i20)") pos(6)
16455
16456 write(unit=pos_array(7), fmt="(i20)") pos(7)
16457
16458
16459 pos_str = '(' // &
16460 & trim(adjustl(pos_array(1))) // ',' // &
16461
16462 & trim(adjustl(pos_array(2))) // ',' // &
16463
16464 & trim(adjustl(pos_array(3))) // ',' // &
16465
16466 & trim(adjustl(pos_array(4))) // ',' // &
16467
16468 & trim(adjustl(pos_array(5))) // ',' // &
16469
16470 & trim(adjustl(pos_array(6))) // ',' // &
16471
16472 & trim(adjustl(pos_array(7))) // ')'
16473
16474 if ( both_negative( &
16475 & pos(1), &
16476
16477 & pos(2), &
16478
16479 & pos(3), &
16480
16481 & pos(4), &
16482
16483 & pos(5), &
16484
16485 & pos(6), &
16486
16487 & pos(7) ) ) then
16488
16489 abs_mes = 'ABSOLUTE value of'
16490 else
16491 abs_mes = ''
16492
16493 end if
16494
16495 end if
16496 deallocate(mask_array, judge, judge_rev)
16497 deallocate(answer_negative, check_negative, both_negative)
16498
16499
16500
16501
16502 if (err_flag) then
16503 write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16504 write(*,*) ''
16505 write(*,*) ' ' // trim(abs_mes) // &
16506 & ' check' // trim(pos_str) // ' = ', wrong
16507 write(*,*) ' is NOT LESS THAN'
16508 write(*,*) ' ' // trim(abs_mes) // &
16509 & ' answer' // trim(pos_str) // ' = ', right
16510
16512 else
16513 write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16514 end if
16515
16516
References sysdep::abortprogram(), dc_types::string, and dc_types::token.
Here is the call graph for this function:
The documentation for this interface was generated from the following file:
- /build/gtool5-1.0.0~rc5/debian/build-parallel/src/dc_utils/dc_test.f90
Generated on for gtool5 Fortran 90/95 ライブラリ by
1.15.0