Private Member Functions
dc_test::assertlessthan Interface Reference

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

Definition at line 16632 of file dc_test.f90.

16632  use sysdep, only: abortprogram
16633  use dc_types, only: string, token
16634  implicit none
16635  character(*), intent(in):: message
16636  real(DP), intent(in):: answer
16637  real(DP), intent(in):: check
16638  logical, intent(in), optional:: negative_support
16639  logical:: err_flag
16640  logical:: negative_support_on
16641  character(STRING):: pos_str
16642  character(TOKEN):: abs_mes
16643  real(DP):: wrong, right
16644 
16645 
16646 
16647  continue
16648  if (present(negative_support)) then
16649  negative_support_on = negative_support
16650  else
16651  negative_support_on = .true.
16652  end if
16653 
16654  err_flag = .false.
16655 
16656 
16657 
16658 
16659  err_flag = .not. answer > check
16660  abs_mes = ''
16661 
16662  if ( answer < 0.0_dp &
16663  & .and. check < 0.0_dp &
16664  & .and. negative_support_on ) then
16665 
16666  err_flag = .not. err_flag
16667  abs_mes = 'ABSOLUTE value of'
16668  end if
16669 
16670  wrong = check
16671  right = answer
16672  pos_str = ''
16673 
16674 
16675 
16676 
16677  if (err_flag) then
16678  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16679  write(*,*) ''
16680  write(*,*) ' ' // trim(abs_mes) // &
16681  & ' check' // trim(pos_str) // ' = ', wrong
16682  write(*,*) ' is NOT LESS THAN'
16683  write(*,*) ' ' // trim(abs_mes) // &
16684  & ' answer' // trim(pos_str) // ' = ', right
16685 
16686  call abortprogram('')
16687  else
16688  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16689  end if
16690 
16691 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118

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

Definition at line 16697 of file dc_test.f90.

16697  use sysdep, only: abortprogram
16698  use dc_types, only: string, token
16699  implicit none
16700  character(*), intent(in):: message
16701  real(DP), intent(in):: answer(:)
16702  real(DP), intent(in):: check(:)
16703  logical, intent(in), optional:: negative_support
16704  logical:: err_flag
16705  logical:: negative_support_on
16706  character(STRING):: pos_str
16707  character(TOKEN):: abs_mes
16708  real(DP):: wrong, right
16709 
16710  integer:: answer_shape(1), check_shape(1), pos(1)
16711  logical:: consist_shape(1)
16712  character(TOKEN):: pos_array(1)
16713  integer, allocatable:: mask_array(:)
16714  logical, allocatable:: judge(:)
16715  logical, allocatable:: judge_rev(:)
16716  logical, allocatable:: answer_negative(:)
16717  logical, allocatable:: check_negative(:)
16718  logical, allocatable:: both_negative(:)
16719 
16720 
16721  continue
16722  if (present(negative_support)) then
16723  negative_support_on = negative_support
16724  else
16725  negative_support_on = .true.
16726  end if
16727 
16728  err_flag = .false.
16729 
16730 
16731  answer_shape = shape(answer)
16732  check_shape = shape(check)
16733 
16734  consist_shape = answer_shape == check_shape
16735 
16736  if (.not. all(consist_shape)) then
16737  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16738  write(*,*) ''
16739  write(*,*) ' shape of check is (', check_shape, ')'
16740  write(*,*) ' is INCORRECT'
16741  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
16742 
16743  call abortprogram('')
16744  end if
16745 
16746 
16747  allocate( mask_array( &
16748 
16749  & answer_shape(1) ) &
16750  & )
16751 
16752  allocate( judge( &
16753 
16754  & answer_shape(1) ) &
16755  & )
16756 
16757  allocate( judge_rev( &
16758 
16759  & answer_shape(1) ) &
16760  & )
16761 
16762  allocate( answer_negative( &
16763 
16764  & answer_shape(1) ) &
16765  & )
16766 
16767  allocate( check_negative( &
16768 
16769  & answer_shape(1) ) &
16770  & )
16771 
16772  allocate( both_negative( &
16773 
16774  & answer_shape(1) ) &
16775  & )
16776 
16777  answer_negative = answer < 0.0_dp
16778  check_negative = check < 0.0_dp
16779  both_negative = answer_negative .and. check_negative
16780  if (.not. negative_support_on) both_negative = .false.
16781 
16782  judge = answer > check
16783  where (both_negative) judge = .not. judge
16784 
16785  judge_rev = .not. judge
16786  err_flag = any(judge_rev)
16787  mask_array = 1
16788  pos = maxloc(mask_array, judge_rev)
16789 
16790  if (err_flag) then
16791 
16792  wrong = check( &
16793 
16794  & pos(1) )
16795 
16796  right = answer( &
16797 
16798  & pos(1) )
16799 
16800  write(unit=pos_array(1), fmt="(i20)") pos(1)
16801 
16802 
16803  pos_str = '(' // &
16804 
16805  & trim(adjustl(pos_array(1))) // ')'
16806 
16807  if ( both_negative( &
16808 
16809  & pos(1) ) ) then
16810 
16811  abs_mes = 'ABSOLUTE value of'
16812  else
16813  abs_mes = ''
16814 
16815  end if
16816 
16817  end if
16818  deallocate(mask_array, judge, judge_rev)
16819  deallocate(answer_negative, check_negative, both_negative)
16820 
16821 
16822 
16823 
16824  if (err_flag) then
16825  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16826  write(*,*) ''
16827  write(*,*) ' ' // trim(abs_mes) // &
16828  & ' check' // trim(pos_str) // ' = ', wrong
16829  write(*,*) ' is NOT LESS THAN'
16830  write(*,*) ' ' // trim(abs_mes) // &
16831  & ' answer' // trim(pos_str) // ' = ', right
16832 
16833  call abortprogram('')
16834  else
16835  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16836  end if
16837 
16838 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118

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

Definition at line 16844 of file dc_test.f90.

16844  use sysdep, only: abortprogram
16845  use dc_types, only: string, token
16846  implicit none
16847  character(*), intent(in):: message
16848  real(DP), intent(in):: answer(:,:)
16849  real(DP), intent(in):: check(:,:)
16850  logical, intent(in), optional:: negative_support
16851  logical:: err_flag
16852  logical:: negative_support_on
16853  character(STRING):: pos_str
16854  character(TOKEN):: abs_mes
16855  real(DP):: wrong, right
16856 
16857  integer:: answer_shape(2), check_shape(2), pos(2)
16858  logical:: consist_shape(2)
16859  character(TOKEN):: pos_array(2)
16860  integer, allocatable:: mask_array(:,:)
16861  logical, allocatable:: judge(:,:)
16862  logical, allocatable:: judge_rev(:,:)
16863  logical, allocatable:: answer_negative(:,:)
16864  logical, allocatable:: check_negative(:,:)
16865  logical, allocatable:: both_negative(:,:)
16866 
16867 
16868  continue
16869  if (present(negative_support)) then
16870  negative_support_on = negative_support
16871  else
16872  negative_support_on = .true.
16873  end if
16874 
16875  err_flag = .false.
16876 
16877 
16878  answer_shape = shape(answer)
16879  check_shape = shape(check)
16880 
16881  consist_shape = answer_shape == check_shape
16882 
16883  if (.not. all(consist_shape)) then
16884  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16885  write(*,*) ''
16886  write(*,*) ' shape of check is (', check_shape, ')'
16887  write(*,*) ' is INCORRECT'
16888  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
16889 
16890  call abortprogram('')
16891  end if
16892 
16893 
16894  allocate( mask_array( &
16895  & answer_shape(1), &
16896 
16897  & answer_shape(2) ) &
16898  & )
16899 
16900  allocate( judge( &
16901  & answer_shape(1), &
16902 
16903  & answer_shape(2) ) &
16904  & )
16905 
16906  allocate( judge_rev( &
16907  & answer_shape(1), &
16908 
16909  & answer_shape(2) ) &
16910  & )
16911 
16912  allocate( answer_negative( &
16913  & answer_shape(1), &
16914 
16915  & answer_shape(2) ) &
16916  & )
16917 
16918  allocate( check_negative( &
16919  & answer_shape(1), &
16920 
16921  & answer_shape(2) ) &
16922  & )
16923 
16924  allocate( both_negative( &
16925  & answer_shape(1), &
16926 
16927  & answer_shape(2) ) &
16928  & )
16929 
16930  answer_negative = answer < 0.0_dp
16931  check_negative = check < 0.0_dp
16932  both_negative = answer_negative .and. check_negative
16933  if (.not. negative_support_on) both_negative = .false.
16934 
16935  judge = answer > check
16936  where (both_negative) judge = .not. judge
16937 
16938  judge_rev = .not. judge
16939  err_flag = any(judge_rev)
16940  mask_array = 1
16941  pos = maxloc(mask_array, judge_rev)
16942 
16943  if (err_flag) then
16944 
16945  wrong = check( &
16946  & pos(1), &
16947 
16948  & pos(2) )
16949 
16950  right = answer( &
16951  & pos(1), &
16952 
16953  & pos(2) )
16954 
16955  write(unit=pos_array(1), fmt="(i20)") pos(1)
16956 
16957  write(unit=pos_array(2), fmt="(i20)") pos(2)
16958 
16959 
16960  pos_str = '(' // &
16961  & trim(adjustl(pos_array(1))) // ',' // &
16962 
16963  & trim(adjustl(pos_array(2))) // ')'
16964 
16965  if ( both_negative( &
16966  & pos(1), &
16967 
16968  & pos(2) ) ) then
16969 
16970  abs_mes = 'ABSOLUTE value of'
16971  else
16972  abs_mes = ''
16973 
16974  end if
16975 
16976  end if
16977  deallocate(mask_array, judge, judge_rev)
16978  deallocate(answer_negative, check_negative, both_negative)
16979 
16980 
16981 
16982 
16983  if (err_flag) then
16984  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16985  write(*,*) ''
16986  write(*,*) ' ' // trim(abs_mes) // &
16987  & ' check' // trim(pos_str) // ' = ', wrong
16988  write(*,*) ' is NOT LESS THAN'
16989  write(*,*) ' ' // trim(abs_mes) // &
16990  & ' answer' // trim(pos_str) // ' = ', right
16991 
16992  call abortprogram('')
16993  else
16994  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16995  end if
16996 
16997 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118

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

Definition at line 17003 of file dc_test.f90.

17003  use sysdep, only: abortprogram
17004  use dc_types, only: string, token
17005  implicit none
17006  character(*), intent(in):: message
17007  real(DP), intent(in):: answer(:,:,:)
17008  real(DP), intent(in):: check(:,:,:)
17009  logical, intent(in), optional:: negative_support
17010  logical:: err_flag
17011  logical:: negative_support_on
17012  character(STRING):: pos_str
17013  character(TOKEN):: abs_mes
17014  real(DP):: wrong, right
17015 
17016  integer:: answer_shape(3), check_shape(3), pos(3)
17017  logical:: consist_shape(3)
17018  character(TOKEN):: pos_array(3)
17019  integer, allocatable:: mask_array(:,:,:)
17020  logical, allocatable:: judge(:,:,:)
17021  logical, allocatable:: judge_rev(:,:,:)
17022  logical, allocatable:: answer_negative(:,:,:)
17023  logical, allocatable:: check_negative(:,:,:)
17024  logical, allocatable:: both_negative(:,:,:)
17025 
17026 
17027  continue
17028  if (present(negative_support)) then
17029  negative_support_on = negative_support
17030  else
17031  negative_support_on = .true.
17032  end if
17033 
17034  err_flag = .false.
17035 
17036 
17037  answer_shape = shape(answer)
17038  check_shape = shape(check)
17039 
17040  consist_shape = answer_shape == check_shape
17041 
17042  if (.not. all(consist_shape)) then
17043  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17044  write(*,*) ''
17045  write(*,*) ' shape of check is (', check_shape, ')'
17046  write(*,*) ' is INCORRECT'
17047  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
17048 
17049  call abortprogram('')
17050  end if
17051 
17052 
17053  allocate( mask_array( &
17054  & answer_shape(1), &
17055 
17056  & answer_shape(2), &
17057 
17058  & answer_shape(3) ) &
17059  & )
17060 
17061  allocate( judge( &
17062  & answer_shape(1), &
17063 
17064  & answer_shape(2), &
17065 
17066  & answer_shape(3) ) &
17067  & )
17068 
17069  allocate( judge_rev( &
17070  & answer_shape(1), &
17071 
17072  & answer_shape(2), &
17073 
17074  & answer_shape(3) ) &
17075  & )
17076 
17077  allocate( answer_negative( &
17078  & answer_shape(1), &
17079 
17080  & answer_shape(2), &
17081 
17082  & answer_shape(3) ) &
17083  & )
17084 
17085  allocate( check_negative( &
17086  & answer_shape(1), &
17087 
17088  & answer_shape(2), &
17089 
17090  & answer_shape(3) ) &
17091  & )
17092 
17093  allocate( both_negative( &
17094  & answer_shape(1), &
17095 
17096  & answer_shape(2), &
17097 
17098  & answer_shape(3) ) &
17099  & )
17100 
17101  answer_negative = answer < 0.0_dp
17102  check_negative = check < 0.0_dp
17103  both_negative = answer_negative .and. check_negative
17104  if (.not. negative_support_on) both_negative = .false.
17105 
17106  judge = answer > check
17107  where (both_negative) judge = .not. judge
17108 
17109  judge_rev = .not. judge
17110  err_flag = any(judge_rev)
17111  mask_array = 1
17112  pos = maxloc(mask_array, judge_rev)
17113 
17114  if (err_flag) then
17115 
17116  wrong = check( &
17117  & pos(1), &
17118 
17119  & pos(2), &
17120 
17121  & pos(3) )
17122 
17123  right = answer( &
17124  & pos(1), &
17125 
17126  & pos(2), &
17127 
17128  & pos(3) )
17129 
17130  write(unit=pos_array(1), fmt="(i20)") pos(1)
17131 
17132  write(unit=pos_array(2), fmt="(i20)") pos(2)
17133 
17134  write(unit=pos_array(3), fmt="(i20)") pos(3)
17135 
17136 
17137  pos_str = '(' // &
17138  & trim(adjustl(pos_array(1))) // ',' // &
17139 
17140  & trim(adjustl(pos_array(2))) // ',' // &
17141 
17142  & trim(adjustl(pos_array(3))) // ')'
17143 
17144  if ( both_negative( &
17145  & pos(1), &
17146 
17147  & pos(2), &
17148 
17149  & pos(3) ) ) then
17150 
17151  abs_mes = 'ABSOLUTE value of'
17152  else
17153  abs_mes = ''
17154 
17155  end if
17156 
17157  end if
17158  deallocate(mask_array, judge, judge_rev)
17159  deallocate(answer_negative, check_negative, both_negative)
17160 
17161 
17162 
17163 
17164  if (err_flag) then
17165  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17166  write(*,*) ''
17167  write(*,*) ' ' // trim(abs_mes) // &
17168  & ' check' // trim(pos_str) // ' = ', wrong
17169  write(*,*) ' is NOT LESS THAN'
17170  write(*,*) ' ' // trim(abs_mes) // &
17171  & ' answer' // trim(pos_str) // ' = ', right
17172 
17173  call abortprogram('')
17174  else
17175  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
17176  end if
17177 
17178 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118

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

Definition at line 17184 of file dc_test.f90.

17184  use sysdep, only: abortprogram
17185  use dc_types, only: string, token
17186  implicit none
17187  character(*), intent(in):: message
17188  real(DP), intent(in):: answer(:,:,:,:)
17189  real(DP), intent(in):: check(:,:,:,:)
17190  logical, intent(in), optional:: negative_support
17191  logical:: err_flag
17192  logical:: negative_support_on
17193  character(STRING):: pos_str
17194  character(TOKEN):: abs_mes
17195  real(DP):: wrong, right
17196 
17197  integer:: answer_shape(4), check_shape(4), pos(4)
17198  logical:: consist_shape(4)
17199  character(TOKEN):: pos_array(4)
17200  integer, allocatable:: mask_array(:,:,:,:)
17201  logical, allocatable:: judge(:,:,:,:)
17202  logical, allocatable:: judge_rev(:,:,:,:)
17203  logical, allocatable:: answer_negative(:,:,:,:)
17204  logical, allocatable:: check_negative(:,:,:,:)
17205  logical, allocatable:: both_negative(:,:,:,:)
17206 
17207 
17208  continue
17209  if (present(negative_support)) then
17210  negative_support_on = negative_support
17211  else
17212  negative_support_on = .true.
17213  end if
17214 
17215  err_flag = .false.
17216 
17217 
17218  answer_shape = shape(answer)
17219  check_shape = shape(check)
17220 
17221  consist_shape = answer_shape == check_shape
17222 
17223  if (.not. all(consist_shape)) then
17224  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17225  write(*,*) ''
17226  write(*,*) ' shape of check is (', check_shape, ')'
17227  write(*,*) ' is INCORRECT'
17228  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
17229 
17230  call abortprogram('')
17231  end if
17232 
17233 
17234  allocate( mask_array( &
17235  & answer_shape(1), &
17236 
17237  & answer_shape(2), &
17238 
17239  & answer_shape(3), &
17240 
17241  & answer_shape(4) ) &
17242  & )
17243 
17244  allocate( judge( &
17245  & answer_shape(1), &
17246 
17247  & answer_shape(2), &
17248 
17249  & answer_shape(3), &
17250 
17251  & answer_shape(4) ) &
17252  & )
17253 
17254  allocate( judge_rev( &
17255  & answer_shape(1), &
17256 
17257  & answer_shape(2), &
17258 
17259  & answer_shape(3), &
17260 
17261  & answer_shape(4) ) &
17262  & )
17263 
17264  allocate( answer_negative( &
17265  & answer_shape(1), &
17266 
17267  & answer_shape(2), &
17268 
17269  & answer_shape(3), &
17270 
17271  & answer_shape(4) ) &
17272  & )
17273 
17274  allocate( check_negative( &
17275  & answer_shape(1), &
17276 
17277  & answer_shape(2), &
17278 
17279  & answer_shape(3), &
17280 
17281  & answer_shape(4) ) &
17282  & )
17283 
17284  allocate( both_negative( &
17285  & answer_shape(1), &
17286 
17287  & answer_shape(2), &
17288 
17289  & answer_shape(3), &
17290 
17291  & answer_shape(4) ) &
17292  & )
17293 
17294  answer_negative = answer < 0.0_dp
17295  check_negative = check < 0.0_dp
17296  both_negative = answer_negative .and. check_negative
17297  if (.not. negative_support_on) both_negative = .false.
17298 
17299  judge = answer > check
17300  where (both_negative) judge = .not. judge
17301 
17302  judge_rev = .not. judge
17303  err_flag = any(judge_rev)
17304  mask_array = 1
17305  pos = maxloc(mask_array, judge_rev)
17306 
17307  if (err_flag) then
17308 
17309  wrong = check( &
17310  & pos(1), &
17311 
17312  & pos(2), &
17313 
17314  & pos(3), &
17315 
17316  & pos(4) )
17317 
17318  right = answer( &
17319  & pos(1), &
17320 
17321  & pos(2), &
17322 
17323  & pos(3), &
17324 
17325  & pos(4) )
17326 
17327  write(unit=pos_array(1), fmt="(i20)") pos(1)
17328 
17329  write(unit=pos_array(2), fmt="(i20)") pos(2)
17330 
17331  write(unit=pos_array(3), fmt="(i20)") pos(3)
17332 
17333  write(unit=pos_array(4), fmt="(i20)") pos(4)
17334 
17335 
17336  pos_str = '(' // &
17337  & trim(adjustl(pos_array(1))) // ',' // &
17338 
17339  & trim(adjustl(pos_array(2))) // ',' // &
17340 
17341  & trim(adjustl(pos_array(3))) // ',' // &
17342 
17343  & trim(adjustl(pos_array(4))) // ')'
17344 
17345  if ( both_negative( &
17346  & pos(1), &
17347 
17348  & pos(2), &
17349 
17350  & pos(3), &
17351 
17352  & pos(4) ) ) then
17353 
17354  abs_mes = 'ABSOLUTE value of'
17355  else
17356  abs_mes = ''
17357 
17358  end if
17359 
17360  end if
17361  deallocate(mask_array, judge, judge_rev)
17362  deallocate(answer_negative, check_negative, both_negative)
17363 
17364 
17365 
17366 
17367  if (err_flag) then
17368  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17369  write(*,*) ''
17370  write(*,*) ' ' // trim(abs_mes) // &
17371  & ' check' // trim(pos_str) // ' = ', wrong
17372  write(*,*) ' is NOT LESS THAN'
17373  write(*,*) ' ' // trim(abs_mes) // &
17374  & ' answer' // trim(pos_str) // ' = ', right
17375 
17376  call abortprogram('')
17377  else
17378  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
17379  end if
17380 
17381 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118

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

Definition at line 17387 of file dc_test.f90.

17387  use sysdep, only: abortprogram
17388  use dc_types, only: string, token
17389  implicit none
17390  character(*), intent(in):: message
17391  real(DP), intent(in):: answer(:,:,:,:,:)
17392  real(DP), intent(in):: check(:,:,:,:,:)
17393  logical, intent(in), optional:: negative_support
17394  logical:: err_flag
17395  logical:: negative_support_on
17396  character(STRING):: pos_str
17397  character(TOKEN):: abs_mes
17398  real(DP):: wrong, right
17399 
17400  integer:: answer_shape(5), check_shape(5), pos(5)
17401  logical:: consist_shape(5)
17402  character(TOKEN):: pos_array(5)
17403  integer, allocatable:: mask_array(:,:,:,:,:)
17404  logical, allocatable:: judge(:,:,:,:,:)
17405  logical, allocatable:: judge_rev(:,:,:,:,:)
17406  logical, allocatable:: answer_negative(:,:,:,:,:)
17407  logical, allocatable:: check_negative(:,:,:,:,:)
17408  logical, allocatable:: both_negative(:,:,:,:,:)
17409 
17410 
17411  continue
17412  if (present(negative_support)) then
17413  negative_support_on = negative_support
17414  else
17415  negative_support_on = .true.
17416  end if
17417 
17418  err_flag = .false.
17419 
17420 
17421  answer_shape = shape(answer)
17422  check_shape = shape(check)
17423 
17424  consist_shape = answer_shape == check_shape
17425 
17426  if (.not. all(consist_shape)) then
17427  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17428  write(*,*) ''
17429  write(*,*) ' shape of check is (', check_shape, ')'
17430  write(*,*) ' is INCORRECT'
17431  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
17432 
17433  call abortprogram('')
17434  end if
17435 
17436 
17437  allocate( mask_array( &
17438  & answer_shape(1), &
17439 
17440  & answer_shape(2), &
17441 
17442  & answer_shape(3), &
17443 
17444  & answer_shape(4), &
17445 
17446  & answer_shape(5) ) &
17447  & )
17448 
17449  allocate( judge( &
17450  & answer_shape(1), &
17451 
17452  & answer_shape(2), &
17453 
17454  & answer_shape(3), &
17455 
17456  & answer_shape(4), &
17457 
17458  & answer_shape(5) ) &
17459  & )
17460 
17461  allocate( judge_rev( &
17462  & answer_shape(1), &
17463 
17464  & answer_shape(2), &
17465 
17466  & answer_shape(3), &
17467 
17468  & answer_shape(4), &
17469 
17470  & answer_shape(5) ) &
17471  & )
17472 
17473  allocate( answer_negative( &
17474  & answer_shape(1), &
17475 
17476  & answer_shape(2), &
17477 
17478  & answer_shape(3), &
17479 
17480  & answer_shape(4), &
17481 
17482  & answer_shape(5) ) &
17483  & )
17484 
17485  allocate( check_negative( &
17486  & answer_shape(1), &
17487 
17488  & answer_shape(2), &
17489 
17490  & answer_shape(3), &
17491 
17492  & answer_shape(4), &
17493 
17494  & answer_shape(5) ) &
17495  & )
17496 
17497  allocate( both_negative( &
17498  & answer_shape(1), &
17499 
17500  & answer_shape(2), &
17501 
17502  & answer_shape(3), &
17503 
17504  & answer_shape(4), &
17505 
17506  & answer_shape(5) ) &
17507  & )
17508 
17509  answer_negative = answer < 0.0_dp
17510  check_negative = check < 0.0_dp
17511  both_negative = answer_negative .and. check_negative
17512  if (.not. negative_support_on) both_negative = .false.
17513 
17514  judge = answer > check
17515  where (both_negative) judge = .not. judge
17516 
17517  judge_rev = .not. judge
17518  err_flag = any(judge_rev)
17519  mask_array = 1
17520  pos = maxloc(mask_array, judge_rev)
17521 
17522  if (err_flag) then
17523 
17524  wrong = check( &
17525  & pos(1), &
17526 
17527  & pos(2), &
17528 
17529  & pos(3), &
17530 
17531  & pos(4), &
17532 
17533  & pos(5) )
17534 
17535  right = answer( &
17536  & pos(1), &
17537 
17538  & pos(2), &
17539 
17540  & pos(3), &
17541 
17542  & pos(4), &
17543 
17544  & pos(5) )
17545 
17546  write(unit=pos_array(1), fmt="(i20)") pos(1)
17547 
17548  write(unit=pos_array(2), fmt="(i20)") pos(2)
17549 
17550  write(unit=pos_array(3), fmt="(i20)") pos(3)
17551 
17552  write(unit=pos_array(4), fmt="(i20)") pos(4)
17553 
17554  write(unit=pos_array(5), fmt="(i20)") pos(5)
17555 
17556 
17557  pos_str = '(' // &
17558  & trim(adjustl(pos_array(1))) // ',' // &
17559 
17560  & trim(adjustl(pos_array(2))) // ',' // &
17561 
17562  & trim(adjustl(pos_array(3))) // ',' // &
17563 
17564  & trim(adjustl(pos_array(4))) // ',' // &
17565 
17566  & trim(adjustl(pos_array(5))) // ')'
17567 
17568  if ( both_negative( &
17569  & pos(1), &
17570 
17571  & pos(2), &
17572 
17573  & pos(3), &
17574 
17575  & pos(4), &
17576 
17577  & pos(5) ) ) then
17578 
17579  abs_mes = 'ABSOLUTE value of'
17580  else
17581  abs_mes = ''
17582 
17583  end if
17584 
17585  end if
17586  deallocate(mask_array, judge, judge_rev)
17587  deallocate(answer_negative, check_negative, both_negative)
17588 
17589 
17590 
17591 
17592  if (err_flag) then
17593  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17594  write(*,*) ''
17595  write(*,*) ' ' // trim(abs_mes) // &
17596  & ' check' // trim(pos_str) // ' = ', wrong
17597  write(*,*) ' is NOT LESS THAN'
17598  write(*,*) ' ' // trim(abs_mes) // &
17599  & ' answer' // trim(pos_str) // ' = ', right
17600 
17601  call abortprogram('')
17602  else
17603  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
17604  end if
17605 
17606 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118

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

Definition at line 17612 of file dc_test.f90.

17612  use sysdep, only: abortprogram
17613  use dc_types, only: string, token
17614  implicit none
17615  character(*), intent(in):: message
17616  real(DP), intent(in):: answer(:,:,:,:,:,:)
17617  real(DP), intent(in):: check(:,:,:,:,:,:)
17618  logical, intent(in), optional:: negative_support
17619  logical:: err_flag
17620  logical:: negative_support_on
17621  character(STRING):: pos_str
17622  character(TOKEN):: abs_mes
17623  real(DP):: wrong, right
17624 
17625  integer:: answer_shape(6), check_shape(6), pos(6)
17626  logical:: consist_shape(6)
17627  character(TOKEN):: pos_array(6)
17628  integer, allocatable:: mask_array(:,:,:,:,:,:)
17629  logical, allocatable:: judge(:,:,:,:,:,:)
17630  logical, allocatable:: judge_rev(:,:,:,:,:,:)
17631  logical, allocatable:: answer_negative(:,:,:,:,:,:)
17632  logical, allocatable:: check_negative(:,:,:,:,:,:)
17633  logical, allocatable:: both_negative(:,:,:,:,:,:)
17634 
17635 
17636  continue
17637  if (present(negative_support)) then
17638  negative_support_on = negative_support
17639  else
17640  negative_support_on = .true.
17641  end if
17642 
17643  err_flag = .false.
17644 
17645 
17646  answer_shape = shape(answer)
17647  check_shape = shape(check)
17648 
17649  consist_shape = answer_shape == check_shape
17650 
17651  if (.not. all(consist_shape)) then
17652  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17653  write(*,*) ''
17654  write(*,*) ' shape of check is (', check_shape, ')'
17655  write(*,*) ' is INCORRECT'
17656  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
17657 
17658  call abortprogram('')
17659  end if
17660 
17661 
17662  allocate( mask_array( &
17663  & answer_shape(1), &
17664 
17665  & answer_shape(2), &
17666 
17667  & answer_shape(3), &
17668 
17669  & answer_shape(4), &
17670 
17671  & answer_shape(5), &
17672 
17673  & answer_shape(6) ) &
17674  & )
17675 
17676  allocate( judge( &
17677  & answer_shape(1), &
17678 
17679  & answer_shape(2), &
17680 
17681  & answer_shape(3), &
17682 
17683  & answer_shape(4), &
17684 
17685  & answer_shape(5), &
17686 
17687  & answer_shape(6) ) &
17688  & )
17689 
17690  allocate( judge_rev( &
17691  & answer_shape(1), &
17692 
17693  & answer_shape(2), &
17694 
17695  & answer_shape(3), &
17696 
17697  & answer_shape(4), &
17698 
17699  & answer_shape(5), &
17700 
17701  & answer_shape(6) ) &
17702  & )
17703 
17704  allocate( answer_negative( &
17705  & answer_shape(1), &
17706 
17707  & answer_shape(2), &
17708 
17709  & answer_shape(3), &
17710 
17711  & answer_shape(4), &
17712 
17713  & answer_shape(5), &
17714 
17715  & answer_shape(6) ) &
17716  & )
17717 
17718  allocate( check_negative( &
17719  & answer_shape(1), &
17720 
17721  & answer_shape(2), &
17722 
17723  & answer_shape(3), &
17724 
17725  & answer_shape(4), &
17726 
17727  & answer_shape(5), &
17728 
17729  & answer_shape(6) ) &
17730  & )
17731 
17732  allocate( both_negative( &
17733  & answer_shape(1), &
17734 
17735  & answer_shape(2), &
17736 
17737  & answer_shape(3), &
17738 
17739  & answer_shape(4), &
17740 
17741  & answer_shape(5), &
17742 
17743  & answer_shape(6) ) &
17744  & )
17745 
17746  answer_negative = answer < 0.0_dp
17747  check_negative = check < 0.0_dp
17748  both_negative = answer_negative .and. check_negative
17749  if (.not. negative_support_on) both_negative = .false.
17750 
17751  judge = answer > check
17752  where (both_negative) judge = .not. judge
17753 
17754  judge_rev = .not. judge
17755  err_flag = any(judge_rev)
17756  mask_array = 1
17757  pos = maxloc(mask_array, judge_rev)
17758 
17759  if (err_flag) then
17760 
17761  wrong = check( &
17762  & pos(1), &
17763 
17764  & pos(2), &
17765 
17766  & pos(3), &
17767 
17768  & pos(4), &
17769 
17770  & pos(5), &
17771 
17772  & pos(6) )
17773 
17774  right = answer( &
17775  & pos(1), &
17776 
17777  & pos(2), &
17778 
17779  & pos(3), &
17780 
17781  & pos(4), &
17782 
17783  & pos(5), &
17784 
17785  & pos(6) )
17786 
17787  write(unit=pos_array(1), fmt="(i20)") pos(1)
17788 
17789  write(unit=pos_array(2), fmt="(i20)") pos(2)
17790 
17791  write(unit=pos_array(3), fmt="(i20)") pos(3)
17792 
17793  write(unit=pos_array(4), fmt="(i20)") pos(4)
17794 
17795  write(unit=pos_array(5), fmt="(i20)") pos(5)
17796 
17797  write(unit=pos_array(6), fmt="(i20)") pos(6)
17798 
17799 
17800  pos_str = '(' // &
17801  & trim(adjustl(pos_array(1))) // ',' // &
17802 
17803  & trim(adjustl(pos_array(2))) // ',' // &
17804 
17805  & trim(adjustl(pos_array(3))) // ',' // &
17806 
17807  & trim(adjustl(pos_array(4))) // ',' // &
17808 
17809  & trim(adjustl(pos_array(5))) // ',' // &
17810 
17811  & trim(adjustl(pos_array(6))) // ')'
17812 
17813  if ( both_negative( &
17814  & pos(1), &
17815 
17816  & pos(2), &
17817 
17818  & pos(3), &
17819 
17820  & pos(4), &
17821 
17822  & pos(5), &
17823 
17824  & pos(6) ) ) then
17825 
17826  abs_mes = 'ABSOLUTE value of'
17827  else
17828  abs_mes = ''
17829 
17830  end if
17831 
17832  end if
17833  deallocate(mask_array, judge, judge_rev)
17834  deallocate(answer_negative, check_negative, both_negative)
17835 
17836 
17837 
17838 
17839  if (err_flag) then
17840  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17841  write(*,*) ''
17842  write(*,*) ' ' // trim(abs_mes) // &
17843  & ' check' // trim(pos_str) // ' = ', wrong
17844  write(*,*) ' is NOT LESS THAN'
17845  write(*,*) ' ' // trim(abs_mes) // &
17846  & ' answer' // trim(pos_str) // ' = ', right
17847 
17848  call abortprogram('')
17849  else
17850  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
17851  end if
17852 
17853 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118

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

Definition at line 17859 of file dc_test.f90.

17859  use sysdep, only: abortprogram
17860  use dc_types, only: string, token
17861  implicit none
17862  character(*), intent(in):: message
17863  real(DP), intent(in):: answer(:,:,:,:,:,:,:)
17864  real(DP), intent(in):: check(:,:,:,:,:,:,:)
17865  logical, intent(in), optional:: negative_support
17866  logical:: err_flag
17867  logical:: negative_support_on
17868  character(STRING):: pos_str
17869  character(TOKEN):: abs_mes
17870  real(DP):: wrong, right
17871 
17872  integer:: answer_shape(7), check_shape(7), pos(7)
17873  logical:: consist_shape(7)
17874  character(TOKEN):: pos_array(7)
17875  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
17876  logical, allocatable:: judge(:,:,:,:,:,:,:)
17877  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
17878  logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
17879  logical, allocatable:: check_negative(:,:,:,:,:,:,:)
17880  logical, allocatable:: both_negative(:,:,:,:,:,:,:)
17881 
17882 
17883  continue
17884  if (present(negative_support)) then
17885  negative_support_on = negative_support
17886  else
17887  negative_support_on = .true.
17888  end if
17889 
17890  err_flag = .false.
17891 
17892 
17893  answer_shape = shape(answer)
17894  check_shape = shape(check)
17895 
17896  consist_shape = answer_shape == check_shape
17897 
17898  if (.not. all(consist_shape)) then
17899  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
17900  write(*,*) ''
17901  write(*,*) ' shape of check is (', check_shape, ')'
17902  write(*,*) ' is INCORRECT'
17903  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
17904 
17905  call abortprogram('')
17906  end if
17907 
17908 
17909  allocate( mask_array( &
17910  & answer_shape(1), &
17911 
17912  & answer_shape(2), &
17913 
17914  & answer_shape(3), &
17915 
17916  & answer_shape(4), &
17917 
17918  & answer_shape(5), &
17919 
17920  & answer_shape(6), &
17921 
17922  & answer_shape(7) ) &
17923  & )
17924 
17925  allocate( judge( &
17926  & answer_shape(1), &
17927 
17928  & answer_shape(2), &
17929 
17930  & answer_shape(3), &
17931 
17932  & answer_shape(4), &
17933 
17934  & answer_shape(5), &
17935 
17936  & answer_shape(6), &
17937 
17938  & answer_shape(7) ) &
17939  & )
17940 
17941  allocate( judge_rev( &
17942  & answer_shape(1), &
17943 
17944  & answer_shape(2), &
17945 
17946  & answer_shape(3), &
17947 
17948  & answer_shape(4), &
17949 
17950  & answer_shape(5), &
17951 
17952  & answer_shape(6), &
17953 
17954  & answer_shape(7) ) &
17955  & )
17956 
17957  allocate( answer_negative( &
17958  & answer_shape(1), &
17959 
17960  & answer_shape(2), &
17961 
17962  & answer_shape(3), &
17963 
17964  & answer_shape(4), &
17965 
17966  & answer_shape(5), &
17967 
17968  & answer_shape(6), &
17969 
17970  & answer_shape(7) ) &
17971  & )
17972 
17973  allocate( check_negative( &
17974  & answer_shape(1), &
17975 
17976  & answer_shape(2), &
17977 
17978  & answer_shape(3), &
17979 
17980  & answer_shape(4), &
17981 
17982  & answer_shape(5), &
17983 
17984  & answer_shape(6), &
17985 
17986  & answer_shape(7) ) &
17987  & )
17988 
17989  allocate( both_negative( &
17990  & answer_shape(1), &
17991 
17992  & answer_shape(2), &
17993 
17994  & answer_shape(3), &
17995 
17996  & answer_shape(4), &
17997 
17998  & answer_shape(5), &
17999 
18000  & answer_shape(6), &
18001 
18002  & answer_shape(7) ) &
18003  & )
18004 
18005  answer_negative = answer < 0.0_dp
18006  check_negative = check < 0.0_dp
18007  both_negative = answer_negative .and. check_negative
18008  if (.not. negative_support_on) both_negative = .false.
18009 
18010  judge = answer > check
18011  where (both_negative) judge = .not. judge
18012 
18013  judge_rev = .not. judge
18014  err_flag = any(judge_rev)
18015  mask_array = 1
18016  pos = maxloc(mask_array, judge_rev)
18017 
18018  if (err_flag) then
18019 
18020  wrong = check( &
18021  & pos(1), &
18022 
18023  & pos(2), &
18024 
18025  & pos(3), &
18026 
18027  & pos(4), &
18028 
18029  & pos(5), &
18030 
18031  & pos(6), &
18032 
18033  & pos(7) )
18034 
18035  right = answer( &
18036  & pos(1), &
18037 
18038  & pos(2), &
18039 
18040  & pos(3), &
18041 
18042  & pos(4), &
18043 
18044  & pos(5), &
18045 
18046  & pos(6), &
18047 
18048  & pos(7) )
18049 
18050  write(unit=pos_array(1), fmt="(i20)") pos(1)
18051 
18052  write(unit=pos_array(2), fmt="(i20)") pos(2)
18053 
18054  write(unit=pos_array(3), fmt="(i20)") pos(3)
18055 
18056  write(unit=pos_array(4), fmt="(i20)") pos(4)
18057 
18058  write(unit=pos_array(5), fmt="(i20)") pos(5)
18059 
18060  write(unit=pos_array(6), fmt="(i20)") pos(6)
18061 
18062  write(unit=pos_array(7), fmt="(i20)") pos(7)
18063 
18064 
18065  pos_str = '(' // &
18066  & trim(adjustl(pos_array(1))) // ',' // &
18067 
18068  & trim(adjustl(pos_array(2))) // ',' // &
18069 
18070  & trim(adjustl(pos_array(3))) // ',' // &
18071 
18072  & trim(adjustl(pos_array(4))) // ',' // &
18073 
18074  & trim(adjustl(pos_array(5))) // ',' // &
18075 
18076  & trim(adjustl(pos_array(6))) // ',' // &
18077 
18078  & trim(adjustl(pos_array(7))) // ')'
18079 
18080  if ( both_negative( &
18081  & pos(1), &
18082 
18083  & pos(2), &
18084 
18085  & pos(3), &
18086 
18087  & pos(4), &
18088 
18089  & pos(5), &
18090 
18091  & pos(6), &
18092 
18093  & pos(7) ) ) then
18094 
18095  abs_mes = 'ABSOLUTE value of'
18096  else
18097  abs_mes = ''
18098 
18099  end if
18100 
18101  end if
18102  deallocate(mask_array, judge, judge_rev)
18103  deallocate(answer_negative, check_negative, both_negative)
18104 
18105 
18106 
18107 
18108  if (err_flag) then
18109  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
18110  write(*,*) ''
18111  write(*,*) ' ' // trim(abs_mes) // &
18112  & ' check' // trim(pos_str) // ' = ', wrong
18113  write(*,*) ' is NOT LESS THAN'
18114  write(*,*) ' ' // trim(abs_mes) // &
18115  & ' answer' // trim(pos_str) // ' = ', right
18116 
18117  call abortprogram('')
18118  else
18119  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
18120  end if
18121 
18122 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118

◆ dctestassertlessthanint0()

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

Definition at line 13640 of file dc_test.f90.

13640  use sysdep, only: abortprogram
13641  use dc_types, only: string, token
13642  implicit none
13643  character(*), intent(in):: message
13644  integer, intent(in):: answer
13645  integer, intent(in):: check
13646  logical, intent(in), optional:: negative_support
13647  logical:: err_flag
13648  logical:: negative_support_on
13649  character(STRING):: pos_str
13650  character(TOKEN):: abs_mes
13651  integer:: wrong, right
13652 
13653 
13654 
13655  continue
13656  if (present(negative_support)) then
13657  negative_support_on = negative_support
13658  else
13659  negative_support_on = .true.
13660  end if
13661 
13662  err_flag = .false.
13663 
13664 
13665 
13666 
13667  err_flag = .not. answer > check
13668  abs_mes = ''
13669 
13670  if ( answer < 0 &
13671  & .and. check < 0 &
13672  & .and. negative_support_on ) then
13673 
13674  err_flag = .not. err_flag
13675  abs_mes = 'ABSOLUTE value of'
13676  end if
13677 
13678  wrong = check
13679  right = answer
13680  pos_str = ''
13681 
13682 
13683 
13684 
13685  if (err_flag) then
13686  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13687  write(*,*) ''
13688  write(*,*) ' ' // trim(abs_mes) // &
13689  & ' check' // trim(pos_str) // ' = ', wrong
13690  write(*,*) ' is NOT LESS THAN'
13691  write(*,*) ' ' // trim(abs_mes) // &
13692  & ' answer' // trim(pos_str) // ' = ', right
13693 
13694  call abortprogram('')
13695  else
13696  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
13697  end if
13698 
13699 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118

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

Definition at line 13705 of file dc_test.f90.

13705  use sysdep, only: abortprogram
13706  use dc_types, only: string, token
13707  implicit none
13708  character(*), intent(in):: message
13709  integer, intent(in):: answer(:)
13710  integer, intent(in):: check(:)
13711  logical, intent(in), optional:: negative_support
13712  logical:: err_flag
13713  logical:: negative_support_on
13714  character(STRING):: pos_str
13715  character(TOKEN):: abs_mes
13716  integer:: wrong, right
13717 
13718  integer:: answer_shape(1), check_shape(1), pos(1)
13719  logical:: consist_shape(1)
13720  character(TOKEN):: pos_array(1)
13721  integer, allocatable:: mask_array(:)
13722  logical, allocatable:: judge(:)
13723  logical, allocatable:: judge_rev(:)
13724  logical, allocatable:: answer_negative(:)
13725  logical, allocatable:: check_negative(:)
13726  logical, allocatable:: both_negative(:)
13727 
13728 
13729  continue
13730  if (present(negative_support)) then
13731  negative_support_on = negative_support
13732  else
13733  negative_support_on = .true.
13734  end if
13735 
13736  err_flag = .false.
13737 
13738 
13739  answer_shape = shape(answer)
13740  check_shape = shape(check)
13741 
13742  consist_shape = answer_shape == check_shape
13743 
13744  if (.not. all(consist_shape)) then
13745  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13746  write(*,*) ''
13747  write(*,*) ' shape of check is (', check_shape, ')'
13748  write(*,*) ' is INCORRECT'
13749  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
13750 
13751  call abortprogram('')
13752  end if
13753 
13754 
13755  allocate( mask_array( &
13756 
13757  & answer_shape(1) ) &
13758  & )
13759 
13760  allocate( judge( &
13761 
13762  & answer_shape(1) ) &
13763  & )
13764 
13765  allocate( judge_rev( &
13766 
13767  & answer_shape(1) ) &
13768  & )
13769 
13770  allocate( answer_negative( &
13771 
13772  & answer_shape(1) ) &
13773  & )
13774 
13775  allocate( check_negative( &
13776 
13777  & answer_shape(1) ) &
13778  & )
13779 
13780  allocate( both_negative( &
13781 
13782  & answer_shape(1) ) &
13783  & )
13784 
13785  answer_negative = answer < 0
13786  check_negative = check < 0
13787  both_negative = answer_negative .and. check_negative
13788  if (.not. negative_support_on) both_negative = .false.
13789 
13790  judge = answer > check
13791  where (both_negative) judge = .not. judge
13792 
13793  judge_rev = .not. judge
13794  err_flag = any(judge_rev)
13795  mask_array = 1
13796  pos = maxloc(mask_array, judge_rev)
13797 
13798  if (err_flag) then
13799 
13800  wrong = check( &
13801 
13802  & pos(1) )
13803 
13804  right = answer( &
13805 
13806  & pos(1) )
13807 
13808  write(unit=pos_array(1), fmt="(i20)") pos(1)
13809 
13810 
13811  pos_str = '(' // &
13812 
13813  & trim(adjustl(pos_array(1))) // ')'
13814 
13815  if ( both_negative( &
13816 
13817  & pos(1) ) ) then
13818 
13819  abs_mes = 'ABSOLUTE value of'
13820  else
13821  abs_mes = ''
13822 
13823  end if
13824 
13825  end if
13826  deallocate(mask_array, judge, judge_rev)
13827  deallocate(answer_negative, check_negative, both_negative)
13828 
13829 
13830 
13831 
13832  if (err_flag) then
13833  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13834  write(*,*) ''
13835  write(*,*) ' ' // trim(abs_mes) // &
13836  & ' check' // trim(pos_str) // ' = ', wrong
13837  write(*,*) ' is NOT LESS THAN'
13838  write(*,*) ' ' // trim(abs_mes) // &
13839  & ' answer' // trim(pos_str) // ' = ', right
13840 
13841  call abortprogram('')
13842  else
13843  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
13844  end if
13845 
13846 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118

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

Definition at line 13852 of file dc_test.f90.

13852  use sysdep, only: abortprogram
13853  use dc_types, only: string, token
13854  implicit none
13855  character(*), intent(in):: message
13856  integer, intent(in):: answer(:,:)
13857  integer, intent(in):: check(:,:)
13858  logical, intent(in), optional:: negative_support
13859  logical:: err_flag
13860  logical:: negative_support_on
13861  character(STRING):: pos_str
13862  character(TOKEN):: abs_mes
13863  integer:: wrong, right
13864 
13865  integer:: answer_shape(2), check_shape(2), pos(2)
13866  logical:: consist_shape(2)
13867  character(TOKEN):: pos_array(2)
13868  integer, allocatable:: mask_array(:,:)
13869  logical, allocatable:: judge(:,:)
13870  logical, allocatable:: judge_rev(:,:)
13871  logical, allocatable:: answer_negative(:,:)
13872  logical, allocatable:: check_negative(:,:)
13873  logical, allocatable:: both_negative(:,:)
13874 
13875 
13876  continue
13877  if (present(negative_support)) then
13878  negative_support_on = negative_support
13879  else
13880  negative_support_on = .true.
13881  end if
13882 
13883  err_flag = .false.
13884 
13885 
13886  answer_shape = shape(answer)
13887  check_shape = shape(check)
13888 
13889  consist_shape = answer_shape == check_shape
13890 
13891  if (.not. all(consist_shape)) then
13892  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13893  write(*,*) ''
13894  write(*,*) ' shape of check is (', check_shape, ')'
13895  write(*,*) ' is INCORRECT'
13896  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
13897 
13898  call abortprogram('')
13899  end if
13900 
13901 
13902  allocate( mask_array( &
13903  & answer_shape(1), &
13904 
13905  & answer_shape(2) ) &
13906  & )
13907 
13908  allocate( judge( &
13909  & answer_shape(1), &
13910 
13911  & answer_shape(2) ) &
13912  & )
13913 
13914  allocate( judge_rev( &
13915  & answer_shape(1), &
13916 
13917  & answer_shape(2) ) &
13918  & )
13919 
13920  allocate( answer_negative( &
13921  & answer_shape(1), &
13922 
13923  & answer_shape(2) ) &
13924  & )
13925 
13926  allocate( check_negative( &
13927  & answer_shape(1), &
13928 
13929  & answer_shape(2) ) &
13930  & )
13931 
13932  allocate( both_negative( &
13933  & answer_shape(1), &
13934 
13935  & answer_shape(2) ) &
13936  & )
13937 
13938  answer_negative = answer < 0
13939  check_negative = check < 0
13940  both_negative = answer_negative .and. check_negative
13941  if (.not. negative_support_on) both_negative = .false.
13942 
13943  judge = answer > check
13944  where (both_negative) judge = .not. judge
13945 
13946  judge_rev = .not. judge
13947  err_flag = any(judge_rev)
13948  mask_array = 1
13949  pos = maxloc(mask_array, judge_rev)
13950 
13951  if (err_flag) then
13952 
13953  wrong = check( &
13954  & pos(1), &
13955 
13956  & pos(2) )
13957 
13958  right = answer( &
13959  & pos(1), &
13960 
13961  & pos(2) )
13962 
13963  write(unit=pos_array(1), fmt="(i20)") pos(1)
13964 
13965  write(unit=pos_array(2), fmt="(i20)") pos(2)
13966 
13967 
13968  pos_str = '(' // &
13969  & trim(adjustl(pos_array(1))) // ',' // &
13970 
13971  & trim(adjustl(pos_array(2))) // ')'
13972 
13973  if ( both_negative( &
13974  & pos(1), &
13975 
13976  & pos(2) ) ) then
13977 
13978  abs_mes = 'ABSOLUTE value of'
13979  else
13980  abs_mes = ''
13981 
13982  end if
13983 
13984  end if
13985  deallocate(mask_array, judge, judge_rev)
13986  deallocate(answer_negative, check_negative, both_negative)
13987 
13988 
13989 
13990 
13991  if (err_flag) then
13992  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
13993  write(*,*) ''
13994  write(*,*) ' ' // trim(abs_mes) // &
13995  & ' check' // trim(pos_str) // ' = ', wrong
13996  write(*,*) ' is NOT LESS THAN'
13997  write(*,*) ' ' // trim(abs_mes) // &
13998  & ' answer' // trim(pos_str) // ' = ', right
13999 
14000  call abortprogram('')
14001  else
14002  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
14003  end if
14004 
14005 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118

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

Definition at line 14011 of file dc_test.f90.

14011  use sysdep, only: abortprogram
14012  use dc_types, only: string, token
14013  implicit none
14014  character(*), intent(in):: message
14015  integer, intent(in):: answer(:,:,:)
14016  integer, intent(in):: check(:,:,:)
14017  logical, intent(in), optional:: negative_support
14018  logical:: err_flag
14019  logical:: negative_support_on
14020  character(STRING):: pos_str
14021  character(TOKEN):: abs_mes
14022  integer:: wrong, right
14023 
14024  integer:: answer_shape(3), check_shape(3), pos(3)
14025  logical:: consist_shape(3)
14026  character(TOKEN):: pos_array(3)
14027  integer, allocatable:: mask_array(:,:,:)
14028  logical, allocatable:: judge(:,:,:)
14029  logical, allocatable:: judge_rev(:,:,:)
14030  logical, allocatable:: answer_negative(:,:,:)
14031  logical, allocatable:: check_negative(:,:,:)
14032  logical, allocatable:: both_negative(:,:,:)
14033 
14034 
14035  continue
14036  if (present(negative_support)) then
14037  negative_support_on = negative_support
14038  else
14039  negative_support_on = .true.
14040  end if
14041 
14042  err_flag = .false.
14043 
14044 
14045  answer_shape = shape(answer)
14046  check_shape = shape(check)
14047 
14048  consist_shape = answer_shape == check_shape
14049 
14050  if (.not. all(consist_shape)) then
14051  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14052  write(*,*) ''
14053  write(*,*) ' shape of check is (', check_shape, ')'
14054  write(*,*) ' is INCORRECT'
14055  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
14056 
14057  call abortprogram('')
14058  end if
14059 
14060 
14061  allocate( mask_array( &
14062  & answer_shape(1), &
14063 
14064  & answer_shape(2), &
14065 
14066  & answer_shape(3) ) &
14067  & )
14068 
14069  allocate( judge( &
14070  & answer_shape(1), &
14071 
14072  & answer_shape(2), &
14073 
14074  & answer_shape(3) ) &
14075  & )
14076 
14077  allocate( judge_rev( &
14078  & answer_shape(1), &
14079 
14080  & answer_shape(2), &
14081 
14082  & answer_shape(3) ) &
14083  & )
14084 
14085  allocate( answer_negative( &
14086  & answer_shape(1), &
14087 
14088  & answer_shape(2), &
14089 
14090  & answer_shape(3) ) &
14091  & )
14092 
14093  allocate( check_negative( &
14094  & answer_shape(1), &
14095 
14096  & answer_shape(2), &
14097 
14098  & answer_shape(3) ) &
14099  & )
14100 
14101  allocate( both_negative( &
14102  & answer_shape(1), &
14103 
14104  & answer_shape(2), &
14105 
14106  & answer_shape(3) ) &
14107  & )
14108 
14109  answer_negative = answer < 0
14110  check_negative = check < 0
14111  both_negative = answer_negative .and. check_negative
14112  if (.not. negative_support_on) both_negative = .false.
14113 
14114  judge = answer > check
14115  where (both_negative) judge = .not. judge
14116 
14117  judge_rev = .not. judge
14118  err_flag = any(judge_rev)
14119  mask_array = 1
14120  pos = maxloc(mask_array, judge_rev)
14121 
14122  if (err_flag) then
14123 
14124  wrong = check( &
14125  & pos(1), &
14126 
14127  & pos(2), &
14128 
14129  & pos(3) )
14130 
14131  right = answer( &
14132  & pos(1), &
14133 
14134  & pos(2), &
14135 
14136  & pos(3) )
14137 
14138  write(unit=pos_array(1), fmt="(i20)") pos(1)
14139 
14140  write(unit=pos_array(2), fmt="(i20)") pos(2)
14141 
14142  write(unit=pos_array(3), fmt="(i20)") pos(3)
14143 
14144 
14145  pos_str = '(' // &
14146  & trim(adjustl(pos_array(1))) // ',' // &
14147 
14148  & trim(adjustl(pos_array(2))) // ',' // &
14149 
14150  & trim(adjustl(pos_array(3))) // ')'
14151 
14152  if ( both_negative( &
14153  & pos(1), &
14154 
14155  & pos(2), &
14156 
14157  & pos(3) ) ) then
14158 
14159  abs_mes = 'ABSOLUTE value of'
14160  else
14161  abs_mes = ''
14162 
14163  end if
14164 
14165  end if
14166  deallocate(mask_array, judge, judge_rev)
14167  deallocate(answer_negative, check_negative, both_negative)
14168 
14169 
14170 
14171 
14172  if (err_flag) then
14173  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14174  write(*,*) ''
14175  write(*,*) ' ' // trim(abs_mes) // &
14176  & ' check' // trim(pos_str) // ' = ', wrong
14177  write(*,*) ' is NOT LESS THAN'
14178  write(*,*) ' ' // trim(abs_mes) // &
14179  & ' answer' // trim(pos_str) // ' = ', right
14180 
14181  call abortprogram('')
14182  else
14183  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
14184  end if
14185 
14186 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118

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

Definition at line 14192 of file dc_test.f90.

14192  use sysdep, only: abortprogram
14193  use dc_types, only: string, token
14194  implicit none
14195  character(*), intent(in):: message
14196  integer, intent(in):: answer(:,:,:,:)
14197  integer, intent(in):: check(:,:,:,:)
14198  logical, intent(in), optional:: negative_support
14199  logical:: err_flag
14200  logical:: negative_support_on
14201  character(STRING):: pos_str
14202  character(TOKEN):: abs_mes
14203  integer:: wrong, right
14204 
14205  integer:: answer_shape(4), check_shape(4), pos(4)
14206  logical:: consist_shape(4)
14207  character(TOKEN):: pos_array(4)
14208  integer, allocatable:: mask_array(:,:,:,:)
14209  logical, allocatable:: judge(:,:,:,:)
14210  logical, allocatable:: judge_rev(:,:,:,:)
14211  logical, allocatable:: answer_negative(:,:,:,:)
14212  logical, allocatable:: check_negative(:,:,:,:)
14213  logical, allocatable:: both_negative(:,:,:,:)
14214 
14215 
14216  continue
14217  if (present(negative_support)) then
14218  negative_support_on = negative_support
14219  else
14220  negative_support_on = .true.
14221  end if
14222 
14223  err_flag = .false.
14224 
14225 
14226  answer_shape = shape(answer)
14227  check_shape = shape(check)
14228 
14229  consist_shape = answer_shape == check_shape
14230 
14231  if (.not. all(consist_shape)) then
14232  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14233  write(*,*) ''
14234  write(*,*) ' shape of check is (', check_shape, ')'
14235  write(*,*) ' is INCORRECT'
14236  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
14237 
14238  call abortprogram('')
14239  end if
14240 
14241 
14242  allocate( mask_array( &
14243  & answer_shape(1), &
14244 
14245  & answer_shape(2), &
14246 
14247  & answer_shape(3), &
14248 
14249  & answer_shape(4) ) &
14250  & )
14251 
14252  allocate( judge( &
14253  & answer_shape(1), &
14254 
14255  & answer_shape(2), &
14256 
14257  & answer_shape(3), &
14258 
14259  & answer_shape(4) ) &
14260  & )
14261 
14262  allocate( judge_rev( &
14263  & answer_shape(1), &
14264 
14265  & answer_shape(2), &
14266 
14267  & answer_shape(3), &
14268 
14269  & answer_shape(4) ) &
14270  & )
14271 
14272  allocate( answer_negative( &
14273  & answer_shape(1), &
14274 
14275  & answer_shape(2), &
14276 
14277  & answer_shape(3), &
14278 
14279  & answer_shape(4) ) &
14280  & )
14281 
14282  allocate( check_negative( &
14283  & answer_shape(1), &
14284 
14285  & answer_shape(2), &
14286 
14287  & answer_shape(3), &
14288 
14289  & answer_shape(4) ) &
14290  & )
14291 
14292  allocate( both_negative( &
14293  & answer_shape(1), &
14294 
14295  & answer_shape(2), &
14296 
14297  & answer_shape(3), &
14298 
14299  & answer_shape(4) ) &
14300  & )
14301 
14302  answer_negative = answer < 0
14303  check_negative = check < 0
14304  both_negative = answer_negative .and. check_negative
14305  if (.not. negative_support_on) both_negative = .false.
14306 
14307  judge = answer > check
14308  where (both_negative) judge = .not. judge
14309 
14310  judge_rev = .not. judge
14311  err_flag = any(judge_rev)
14312  mask_array = 1
14313  pos = maxloc(mask_array, judge_rev)
14314 
14315  if (err_flag) then
14316 
14317  wrong = check( &
14318  & pos(1), &
14319 
14320  & pos(2), &
14321 
14322  & pos(3), &
14323 
14324  & pos(4) )
14325 
14326  right = answer( &
14327  & pos(1), &
14328 
14329  & pos(2), &
14330 
14331  & pos(3), &
14332 
14333  & pos(4) )
14334 
14335  write(unit=pos_array(1), fmt="(i20)") pos(1)
14336 
14337  write(unit=pos_array(2), fmt="(i20)") pos(2)
14338 
14339  write(unit=pos_array(3), fmt="(i20)") pos(3)
14340 
14341  write(unit=pos_array(4), fmt="(i20)") pos(4)
14342 
14343 
14344  pos_str = '(' // &
14345  & trim(adjustl(pos_array(1))) // ',' // &
14346 
14347  & trim(adjustl(pos_array(2))) // ',' // &
14348 
14349  & trim(adjustl(pos_array(3))) // ',' // &
14350 
14351  & trim(adjustl(pos_array(4))) // ')'
14352 
14353  if ( both_negative( &
14354  & pos(1), &
14355 
14356  & pos(2), &
14357 
14358  & pos(3), &
14359 
14360  & pos(4) ) ) then
14361 
14362  abs_mes = 'ABSOLUTE value of'
14363  else
14364  abs_mes = ''
14365 
14366  end if
14367 
14368  end if
14369  deallocate(mask_array, judge, judge_rev)
14370  deallocate(answer_negative, check_negative, both_negative)
14371 
14372 
14373 
14374 
14375  if (err_flag) then
14376  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14377  write(*,*) ''
14378  write(*,*) ' ' // trim(abs_mes) // &
14379  & ' check' // trim(pos_str) // ' = ', wrong
14380  write(*,*) ' is NOT LESS THAN'
14381  write(*,*) ' ' // trim(abs_mes) // &
14382  & ' answer' // trim(pos_str) // ' = ', right
14383 
14384  call abortprogram('')
14385  else
14386  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
14387  end if
14388 
14389 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118

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

Definition at line 14395 of file dc_test.f90.

14395  use sysdep, only: abortprogram
14396  use dc_types, only: string, token
14397  implicit none
14398  character(*), intent(in):: message
14399  integer, intent(in):: answer(:,:,:,:,:)
14400  integer, intent(in):: check(:,:,:,:,:)
14401  logical, intent(in), optional:: negative_support
14402  logical:: err_flag
14403  logical:: negative_support_on
14404  character(STRING):: pos_str
14405  character(TOKEN):: abs_mes
14406  integer:: wrong, right
14407 
14408  integer:: answer_shape(5), check_shape(5), pos(5)
14409  logical:: consist_shape(5)
14410  character(TOKEN):: pos_array(5)
14411  integer, allocatable:: mask_array(:,:,:,:,:)
14412  logical, allocatable:: judge(:,:,:,:,:)
14413  logical, allocatable:: judge_rev(:,:,:,:,:)
14414  logical, allocatable:: answer_negative(:,:,:,:,:)
14415  logical, allocatable:: check_negative(:,:,:,:,:)
14416  logical, allocatable:: both_negative(:,:,:,:,:)
14417 
14418 
14419  continue
14420  if (present(negative_support)) then
14421  negative_support_on = negative_support
14422  else
14423  negative_support_on = .true.
14424  end if
14425 
14426  err_flag = .false.
14427 
14428 
14429  answer_shape = shape(answer)
14430  check_shape = shape(check)
14431 
14432  consist_shape = answer_shape == check_shape
14433 
14434  if (.not. all(consist_shape)) then
14435  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14436  write(*,*) ''
14437  write(*,*) ' shape of check is (', check_shape, ')'
14438  write(*,*) ' is INCORRECT'
14439  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
14440 
14441  call abortprogram('')
14442  end if
14443 
14444 
14445  allocate( mask_array( &
14446  & answer_shape(1), &
14447 
14448  & answer_shape(2), &
14449 
14450  & answer_shape(3), &
14451 
14452  & answer_shape(4), &
14453 
14454  & answer_shape(5) ) &
14455  & )
14456 
14457  allocate( judge( &
14458  & answer_shape(1), &
14459 
14460  & answer_shape(2), &
14461 
14462  & answer_shape(3), &
14463 
14464  & answer_shape(4), &
14465 
14466  & answer_shape(5) ) &
14467  & )
14468 
14469  allocate( judge_rev( &
14470  & answer_shape(1), &
14471 
14472  & answer_shape(2), &
14473 
14474  & answer_shape(3), &
14475 
14476  & answer_shape(4), &
14477 
14478  & answer_shape(5) ) &
14479  & )
14480 
14481  allocate( answer_negative( &
14482  & answer_shape(1), &
14483 
14484  & answer_shape(2), &
14485 
14486  & answer_shape(3), &
14487 
14488  & answer_shape(4), &
14489 
14490  & answer_shape(5) ) &
14491  & )
14492 
14493  allocate( check_negative( &
14494  & answer_shape(1), &
14495 
14496  & answer_shape(2), &
14497 
14498  & answer_shape(3), &
14499 
14500  & answer_shape(4), &
14501 
14502  & answer_shape(5) ) &
14503  & )
14504 
14505  allocate( both_negative( &
14506  & answer_shape(1), &
14507 
14508  & answer_shape(2), &
14509 
14510  & answer_shape(3), &
14511 
14512  & answer_shape(4), &
14513 
14514  & answer_shape(5) ) &
14515  & )
14516 
14517  answer_negative = answer < 0
14518  check_negative = check < 0
14519  both_negative = answer_negative .and. check_negative
14520  if (.not. negative_support_on) both_negative = .false.
14521 
14522  judge = answer > check
14523  where (both_negative) judge = .not. judge
14524 
14525  judge_rev = .not. judge
14526  err_flag = any(judge_rev)
14527  mask_array = 1
14528  pos = maxloc(mask_array, judge_rev)
14529 
14530  if (err_flag) then
14531 
14532  wrong = check( &
14533  & pos(1), &
14534 
14535  & pos(2), &
14536 
14537  & pos(3), &
14538 
14539  & pos(4), &
14540 
14541  & pos(5) )
14542 
14543  right = answer( &
14544  & pos(1), &
14545 
14546  & pos(2), &
14547 
14548  & pos(3), &
14549 
14550  & pos(4), &
14551 
14552  & pos(5) )
14553 
14554  write(unit=pos_array(1), fmt="(i20)") pos(1)
14555 
14556  write(unit=pos_array(2), fmt="(i20)") pos(2)
14557 
14558  write(unit=pos_array(3), fmt="(i20)") pos(3)
14559 
14560  write(unit=pos_array(4), fmt="(i20)") pos(4)
14561 
14562  write(unit=pos_array(5), fmt="(i20)") pos(5)
14563 
14564 
14565  pos_str = '(' // &
14566  & trim(adjustl(pos_array(1))) // ',' // &
14567 
14568  & trim(adjustl(pos_array(2))) // ',' // &
14569 
14570  & trim(adjustl(pos_array(3))) // ',' // &
14571 
14572  & trim(adjustl(pos_array(4))) // ',' // &
14573 
14574  & trim(adjustl(pos_array(5))) // ')'
14575 
14576  if ( both_negative( &
14577  & pos(1), &
14578 
14579  & pos(2), &
14580 
14581  & pos(3), &
14582 
14583  & pos(4), &
14584 
14585  & pos(5) ) ) then
14586 
14587  abs_mes = 'ABSOLUTE value of'
14588  else
14589  abs_mes = ''
14590 
14591  end if
14592 
14593  end if
14594  deallocate(mask_array, judge, judge_rev)
14595  deallocate(answer_negative, check_negative, both_negative)
14596 
14597 
14598 
14599 
14600  if (err_flag) then
14601  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14602  write(*,*) ''
14603  write(*,*) ' ' // trim(abs_mes) // &
14604  & ' check' // trim(pos_str) // ' = ', wrong
14605  write(*,*) ' is NOT LESS THAN'
14606  write(*,*) ' ' // trim(abs_mes) // &
14607  & ' answer' // trim(pos_str) // ' = ', right
14608 
14609  call abortprogram('')
14610  else
14611  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
14612  end if
14613 
14614 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118

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

Definition at line 14620 of file dc_test.f90.

14620  use sysdep, only: abortprogram
14621  use dc_types, only: string, token
14622  implicit none
14623  character(*), intent(in):: message
14624  integer, intent(in):: answer(:,:,:,:,:,:)
14625  integer, intent(in):: check(:,:,:,:,:,:)
14626  logical, intent(in), optional:: negative_support
14627  logical:: err_flag
14628  logical:: negative_support_on
14629  character(STRING):: pos_str
14630  character(TOKEN):: abs_mes
14631  integer:: wrong, right
14632 
14633  integer:: answer_shape(6), check_shape(6), pos(6)
14634  logical:: consist_shape(6)
14635  character(TOKEN):: pos_array(6)
14636  integer, allocatable:: mask_array(:,:,:,:,:,:)
14637  logical, allocatable:: judge(:,:,:,:,:,:)
14638  logical, allocatable:: judge_rev(:,:,:,:,:,:)
14639  logical, allocatable:: answer_negative(:,:,:,:,:,:)
14640  logical, allocatable:: check_negative(:,:,:,:,:,:)
14641  logical, allocatable:: both_negative(:,:,:,:,:,:)
14642 
14643 
14644  continue
14645  if (present(negative_support)) then
14646  negative_support_on = negative_support
14647  else
14648  negative_support_on = .true.
14649  end if
14650 
14651  err_flag = .false.
14652 
14653 
14654  answer_shape = shape(answer)
14655  check_shape = shape(check)
14656 
14657  consist_shape = answer_shape == check_shape
14658 
14659  if (.not. all(consist_shape)) then
14660  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14661  write(*,*) ''
14662  write(*,*) ' shape of check is (', check_shape, ')'
14663  write(*,*) ' is INCORRECT'
14664  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
14665 
14666  call abortprogram('')
14667  end if
14668 
14669 
14670  allocate( mask_array( &
14671  & answer_shape(1), &
14672 
14673  & answer_shape(2), &
14674 
14675  & answer_shape(3), &
14676 
14677  & answer_shape(4), &
14678 
14679  & answer_shape(5), &
14680 
14681  & answer_shape(6) ) &
14682  & )
14683 
14684  allocate( judge( &
14685  & answer_shape(1), &
14686 
14687  & answer_shape(2), &
14688 
14689  & answer_shape(3), &
14690 
14691  & answer_shape(4), &
14692 
14693  & answer_shape(5), &
14694 
14695  & answer_shape(6) ) &
14696  & )
14697 
14698  allocate( judge_rev( &
14699  & answer_shape(1), &
14700 
14701  & answer_shape(2), &
14702 
14703  & answer_shape(3), &
14704 
14705  & answer_shape(4), &
14706 
14707  & answer_shape(5), &
14708 
14709  & answer_shape(6) ) &
14710  & )
14711 
14712  allocate( answer_negative( &
14713  & answer_shape(1), &
14714 
14715  & answer_shape(2), &
14716 
14717  & answer_shape(3), &
14718 
14719  & answer_shape(4), &
14720 
14721  & answer_shape(5), &
14722 
14723  & answer_shape(6) ) &
14724  & )
14725 
14726  allocate( check_negative( &
14727  & answer_shape(1), &
14728 
14729  & answer_shape(2), &
14730 
14731  & answer_shape(3), &
14732 
14733  & answer_shape(4), &
14734 
14735  & answer_shape(5), &
14736 
14737  & answer_shape(6) ) &
14738  & )
14739 
14740  allocate( both_negative( &
14741  & answer_shape(1), &
14742 
14743  & answer_shape(2), &
14744 
14745  & answer_shape(3), &
14746 
14747  & answer_shape(4), &
14748 
14749  & answer_shape(5), &
14750 
14751  & answer_shape(6) ) &
14752  & )
14753 
14754  answer_negative = answer < 0
14755  check_negative = check < 0
14756  both_negative = answer_negative .and. check_negative
14757  if (.not. negative_support_on) both_negative = .false.
14758 
14759  judge = answer > check
14760  where (both_negative) judge = .not. judge
14761 
14762  judge_rev = .not. judge
14763  err_flag = any(judge_rev)
14764  mask_array = 1
14765  pos = maxloc(mask_array, judge_rev)
14766 
14767  if (err_flag) then
14768 
14769  wrong = check( &
14770  & pos(1), &
14771 
14772  & pos(2), &
14773 
14774  & pos(3), &
14775 
14776  & pos(4), &
14777 
14778  & pos(5), &
14779 
14780  & pos(6) )
14781 
14782  right = answer( &
14783  & pos(1), &
14784 
14785  & pos(2), &
14786 
14787  & pos(3), &
14788 
14789  & pos(4), &
14790 
14791  & pos(5), &
14792 
14793  & pos(6) )
14794 
14795  write(unit=pos_array(1), fmt="(i20)") pos(1)
14796 
14797  write(unit=pos_array(2), fmt="(i20)") pos(2)
14798 
14799  write(unit=pos_array(3), fmt="(i20)") pos(3)
14800 
14801  write(unit=pos_array(4), fmt="(i20)") pos(4)
14802 
14803  write(unit=pos_array(5), fmt="(i20)") pos(5)
14804 
14805  write(unit=pos_array(6), fmt="(i20)") pos(6)
14806 
14807 
14808  pos_str = '(' // &
14809  & trim(adjustl(pos_array(1))) // ',' // &
14810 
14811  & trim(adjustl(pos_array(2))) // ',' // &
14812 
14813  & trim(adjustl(pos_array(3))) // ',' // &
14814 
14815  & trim(adjustl(pos_array(4))) // ',' // &
14816 
14817  & trim(adjustl(pos_array(5))) // ',' // &
14818 
14819  & trim(adjustl(pos_array(6))) // ')'
14820 
14821  if ( both_negative( &
14822  & pos(1), &
14823 
14824  & pos(2), &
14825 
14826  & pos(3), &
14827 
14828  & pos(4), &
14829 
14830  & pos(5), &
14831 
14832  & pos(6) ) ) then
14833 
14834  abs_mes = 'ABSOLUTE value of'
14835  else
14836  abs_mes = ''
14837 
14838  end if
14839 
14840  end if
14841  deallocate(mask_array, judge, judge_rev)
14842  deallocate(answer_negative, check_negative, both_negative)
14843 
14844 
14845 
14846 
14847  if (err_flag) then
14848  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14849  write(*,*) ''
14850  write(*,*) ' ' // trim(abs_mes) // &
14851  & ' check' // trim(pos_str) // ' = ', wrong
14852  write(*,*) ' is NOT LESS THAN'
14853  write(*,*) ' ' // trim(abs_mes) // &
14854  & ' answer' // trim(pos_str) // ' = ', right
14855 
14856  call abortprogram('')
14857  else
14858  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
14859  end if
14860 
14861 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118

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

Definition at line 14867 of file dc_test.f90.

14867  use sysdep, only: abortprogram
14868  use dc_types, only: string, token
14869  implicit none
14870  character(*), intent(in):: message
14871  integer, intent(in):: answer(:,:,:,:,:,:,:)
14872  integer, intent(in):: check(:,:,:,:,:,:,:)
14873  logical, intent(in), optional:: negative_support
14874  logical:: err_flag
14875  logical:: negative_support_on
14876  character(STRING):: pos_str
14877  character(TOKEN):: abs_mes
14878  integer:: wrong, right
14879 
14880  integer:: answer_shape(7), check_shape(7), pos(7)
14881  logical:: consist_shape(7)
14882  character(TOKEN):: pos_array(7)
14883  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
14884  logical, allocatable:: judge(:,:,:,:,:,:,:)
14885  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
14886  logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
14887  logical, allocatable:: check_negative(:,:,:,:,:,:,:)
14888  logical, allocatable:: both_negative(:,:,:,:,:,:,:)
14889 
14890 
14891  continue
14892  if (present(negative_support)) then
14893  negative_support_on = negative_support
14894  else
14895  negative_support_on = .true.
14896  end if
14897 
14898  err_flag = .false.
14899 
14900 
14901  answer_shape = shape(answer)
14902  check_shape = shape(check)
14903 
14904  consist_shape = answer_shape == check_shape
14905 
14906  if (.not. all(consist_shape)) then
14907  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
14908  write(*,*) ''
14909  write(*,*) ' shape of check is (', check_shape, ')'
14910  write(*,*) ' is INCORRECT'
14911  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
14912 
14913  call abortprogram('')
14914  end if
14915 
14916 
14917  allocate( mask_array( &
14918  & answer_shape(1), &
14919 
14920  & answer_shape(2), &
14921 
14922  & answer_shape(3), &
14923 
14924  & answer_shape(4), &
14925 
14926  & answer_shape(5), &
14927 
14928  & answer_shape(6), &
14929 
14930  & answer_shape(7) ) &
14931  & )
14932 
14933  allocate( judge( &
14934  & answer_shape(1), &
14935 
14936  & answer_shape(2), &
14937 
14938  & answer_shape(3), &
14939 
14940  & answer_shape(4), &
14941 
14942  & answer_shape(5), &
14943 
14944  & answer_shape(6), &
14945 
14946  & answer_shape(7) ) &
14947  & )
14948 
14949  allocate( judge_rev( &
14950  & answer_shape(1), &
14951 
14952  & answer_shape(2), &
14953 
14954  & answer_shape(3), &
14955 
14956  & answer_shape(4), &
14957 
14958  & answer_shape(5), &
14959 
14960  & answer_shape(6), &
14961 
14962  & answer_shape(7) ) &
14963  & )
14964 
14965  allocate( answer_negative( &
14966  & answer_shape(1), &
14967 
14968  & answer_shape(2), &
14969 
14970  & answer_shape(3), &
14971 
14972  & answer_shape(4), &
14973 
14974  & answer_shape(5), &
14975 
14976  & answer_shape(6), &
14977 
14978  & answer_shape(7) ) &
14979  & )
14980 
14981  allocate( check_negative( &
14982  & answer_shape(1), &
14983 
14984  & answer_shape(2), &
14985 
14986  & answer_shape(3), &
14987 
14988  & answer_shape(4), &
14989 
14990  & answer_shape(5), &
14991 
14992  & answer_shape(6), &
14993 
14994  & answer_shape(7) ) &
14995  & )
14996 
14997  allocate( both_negative( &
14998  & answer_shape(1), &
14999 
15000  & answer_shape(2), &
15001 
15002  & answer_shape(3), &
15003 
15004  & answer_shape(4), &
15005 
15006  & answer_shape(5), &
15007 
15008  & answer_shape(6), &
15009 
15010  & answer_shape(7) ) &
15011  & )
15012 
15013  answer_negative = answer < 0
15014  check_negative = check < 0
15015  both_negative = answer_negative .and. check_negative
15016  if (.not. negative_support_on) both_negative = .false.
15017 
15018  judge = answer > check
15019  where (both_negative) judge = .not. judge
15020 
15021  judge_rev = .not. judge
15022  err_flag = any(judge_rev)
15023  mask_array = 1
15024  pos = maxloc(mask_array, judge_rev)
15025 
15026  if (err_flag) then
15027 
15028  wrong = check( &
15029  & pos(1), &
15030 
15031  & pos(2), &
15032 
15033  & pos(3), &
15034 
15035  & pos(4), &
15036 
15037  & pos(5), &
15038 
15039  & pos(6), &
15040 
15041  & pos(7) )
15042 
15043  right = answer( &
15044  & pos(1), &
15045 
15046  & pos(2), &
15047 
15048  & pos(3), &
15049 
15050  & pos(4), &
15051 
15052  & pos(5), &
15053 
15054  & pos(6), &
15055 
15056  & pos(7) )
15057 
15058  write(unit=pos_array(1), fmt="(i20)") pos(1)
15059 
15060  write(unit=pos_array(2), fmt="(i20)") pos(2)
15061 
15062  write(unit=pos_array(3), fmt="(i20)") pos(3)
15063 
15064  write(unit=pos_array(4), fmt="(i20)") pos(4)
15065 
15066  write(unit=pos_array(5), fmt="(i20)") pos(5)
15067 
15068  write(unit=pos_array(6), fmt="(i20)") pos(6)
15069 
15070  write(unit=pos_array(7), fmt="(i20)") pos(7)
15071 
15072 
15073  pos_str = '(' // &
15074  & trim(adjustl(pos_array(1))) // ',' // &
15075 
15076  & trim(adjustl(pos_array(2))) // ',' // &
15077 
15078  & trim(adjustl(pos_array(3))) // ',' // &
15079 
15080  & trim(adjustl(pos_array(4))) // ',' // &
15081 
15082  & trim(adjustl(pos_array(5))) // ',' // &
15083 
15084  & trim(adjustl(pos_array(6))) // ',' // &
15085 
15086  & trim(adjustl(pos_array(7))) // ')'
15087 
15088  if ( both_negative( &
15089  & pos(1), &
15090 
15091  & pos(2), &
15092 
15093  & pos(3), &
15094 
15095  & pos(4), &
15096 
15097  & pos(5), &
15098 
15099  & pos(6), &
15100 
15101  & pos(7) ) ) then
15102 
15103  abs_mes = 'ABSOLUTE value of'
15104  else
15105  abs_mes = ''
15106 
15107  end if
15108 
15109  end if
15110  deallocate(mask_array, judge, judge_rev)
15111  deallocate(answer_negative, check_negative, both_negative)
15112 
15113 
15114 
15115 
15116  if (err_flag) then
15117  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15118  write(*,*) ''
15119  write(*,*) ' ' // trim(abs_mes) // &
15120  & ' check' // trim(pos_str) // ' = ', wrong
15121  write(*,*) ' is NOT LESS THAN'
15122  write(*,*) ' ' // trim(abs_mes) // &
15123  & ' answer' // trim(pos_str) // ' = ', right
15124 
15125  call abortprogram('')
15126  else
15127  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15128  end if
15129 
15130 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118

◆ dctestassertlessthanreal0()

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

Definition at line 15136 of file dc_test.f90.

15136  use sysdep, only: abortprogram
15137  use dc_types, only: string, token
15138  implicit none
15139  character(*), intent(in):: message
15140  real, intent(in):: answer
15141  real, intent(in):: check
15142  logical, intent(in), optional:: negative_support
15143  logical:: err_flag
15144  logical:: negative_support_on
15145  character(STRING):: pos_str
15146  character(TOKEN):: abs_mes
15147  real:: wrong, right
15148 
15149 
15150 
15151  continue
15152  if (present(negative_support)) then
15153  negative_support_on = negative_support
15154  else
15155  negative_support_on = .true.
15156  end if
15157 
15158  err_flag = .false.
15159 
15160 
15161 
15162 
15163  err_flag = .not. answer > check
15164  abs_mes = ''
15165 
15166  if ( answer < 0.0 &
15167  & .and. check < 0.0 &
15168  & .and. negative_support_on ) then
15169 
15170  err_flag = .not. err_flag
15171  abs_mes = 'ABSOLUTE value of'
15172  end if
15173 
15174  wrong = check
15175  right = answer
15176  pos_str = ''
15177 
15178 
15179 
15180 
15181  if (err_flag) then
15182  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15183  write(*,*) ''
15184  write(*,*) ' ' // trim(abs_mes) // &
15185  & ' check' // trim(pos_str) // ' = ', wrong
15186  write(*,*) ' is NOT LESS THAN'
15187  write(*,*) ' ' // trim(abs_mes) // &
15188  & ' answer' // trim(pos_str) // ' = ', right
15189 
15190  call abortprogram('')
15191  else
15192  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15193  end if
15194 
15195 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118

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

Definition at line 15201 of file dc_test.f90.

15201  use sysdep, only: abortprogram
15202  use dc_types, only: string, token
15203  implicit none
15204  character(*), intent(in):: message
15205  real, intent(in):: answer(:)
15206  real, intent(in):: check(:)
15207  logical, intent(in), optional:: negative_support
15208  logical:: err_flag
15209  logical:: negative_support_on
15210  character(STRING):: pos_str
15211  character(TOKEN):: abs_mes
15212  real:: wrong, right
15213 
15214  integer:: answer_shape(1), check_shape(1), pos(1)
15215  logical:: consist_shape(1)
15216  character(TOKEN):: pos_array(1)
15217  integer, allocatable:: mask_array(:)
15218  logical, allocatable:: judge(:)
15219  logical, allocatable:: judge_rev(:)
15220  logical, allocatable:: answer_negative(:)
15221  logical, allocatable:: check_negative(:)
15222  logical, allocatable:: both_negative(:)
15223 
15224 
15225  continue
15226  if (present(negative_support)) then
15227  negative_support_on = negative_support
15228  else
15229  negative_support_on = .true.
15230  end if
15231 
15232  err_flag = .false.
15233 
15234 
15235  answer_shape = shape(answer)
15236  check_shape = shape(check)
15237 
15238  consist_shape = answer_shape == check_shape
15239 
15240  if (.not. all(consist_shape)) then
15241  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15242  write(*,*) ''
15243  write(*,*) ' shape of check is (', check_shape, ')'
15244  write(*,*) ' is INCORRECT'
15245  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15246 
15247  call abortprogram('')
15248  end if
15249 
15250 
15251  allocate( mask_array( &
15252 
15253  & answer_shape(1) ) &
15254  & )
15255 
15256  allocate( judge( &
15257 
15258  & answer_shape(1) ) &
15259  & )
15260 
15261  allocate( judge_rev( &
15262 
15263  & answer_shape(1) ) &
15264  & )
15265 
15266  allocate( answer_negative( &
15267 
15268  & answer_shape(1) ) &
15269  & )
15270 
15271  allocate( check_negative( &
15272 
15273  & answer_shape(1) ) &
15274  & )
15275 
15276  allocate( both_negative( &
15277 
15278  & answer_shape(1) ) &
15279  & )
15280 
15281  answer_negative = answer < 0.0
15282  check_negative = check < 0.0
15283  both_negative = answer_negative .and. check_negative
15284  if (.not. negative_support_on) both_negative = .false.
15285 
15286  judge = answer > check
15287  where (both_negative) judge = .not. judge
15288 
15289  judge_rev = .not. judge
15290  err_flag = any(judge_rev)
15291  mask_array = 1
15292  pos = maxloc(mask_array, judge_rev)
15293 
15294  if (err_flag) then
15295 
15296  wrong = check( &
15297 
15298  & pos(1) )
15299 
15300  right = answer( &
15301 
15302  & pos(1) )
15303 
15304  write(unit=pos_array(1), fmt="(i20)") pos(1)
15305 
15306 
15307  pos_str = '(' // &
15308 
15309  & trim(adjustl(pos_array(1))) // ')'
15310 
15311  if ( both_negative( &
15312 
15313  & pos(1) ) ) then
15314 
15315  abs_mes = 'ABSOLUTE value of'
15316  else
15317  abs_mes = ''
15318 
15319  end if
15320 
15321  end if
15322  deallocate(mask_array, judge, judge_rev)
15323  deallocate(answer_negative, check_negative, both_negative)
15324 
15325 
15326 
15327 
15328  if (err_flag) then
15329  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15330  write(*,*) ''
15331  write(*,*) ' ' // trim(abs_mes) // &
15332  & ' check' // trim(pos_str) // ' = ', wrong
15333  write(*,*) ' is NOT LESS THAN'
15334  write(*,*) ' ' // trim(abs_mes) // &
15335  & ' answer' // trim(pos_str) // ' = ', right
15336 
15337  call abortprogram('')
15338  else
15339  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15340  end if
15341 
15342 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118

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

Definition at line 15348 of file dc_test.f90.

15348  use sysdep, only: abortprogram
15349  use dc_types, only: string, token
15350  implicit none
15351  character(*), intent(in):: message
15352  real, intent(in):: answer(:,:)
15353  real, intent(in):: check(:,:)
15354  logical, intent(in), optional:: negative_support
15355  logical:: err_flag
15356  logical:: negative_support_on
15357  character(STRING):: pos_str
15358  character(TOKEN):: abs_mes
15359  real:: wrong, right
15360 
15361  integer:: answer_shape(2), check_shape(2), pos(2)
15362  logical:: consist_shape(2)
15363  character(TOKEN):: pos_array(2)
15364  integer, allocatable:: mask_array(:,:)
15365  logical, allocatable:: judge(:,:)
15366  logical, allocatable:: judge_rev(:,:)
15367  logical, allocatable:: answer_negative(:,:)
15368  logical, allocatable:: check_negative(:,:)
15369  logical, allocatable:: both_negative(:,:)
15370 
15371 
15372  continue
15373  if (present(negative_support)) then
15374  negative_support_on = negative_support
15375  else
15376  negative_support_on = .true.
15377  end if
15378 
15379  err_flag = .false.
15380 
15381 
15382  answer_shape = shape(answer)
15383  check_shape = shape(check)
15384 
15385  consist_shape = answer_shape == check_shape
15386 
15387  if (.not. all(consist_shape)) then
15388  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15389  write(*,*) ''
15390  write(*,*) ' shape of check is (', check_shape, ')'
15391  write(*,*) ' is INCORRECT'
15392  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15393 
15394  call abortprogram('')
15395  end if
15396 
15397 
15398  allocate( mask_array( &
15399  & answer_shape(1), &
15400 
15401  & answer_shape(2) ) &
15402  & )
15403 
15404  allocate( judge( &
15405  & answer_shape(1), &
15406 
15407  & answer_shape(2) ) &
15408  & )
15409 
15410  allocate( judge_rev( &
15411  & answer_shape(1), &
15412 
15413  & answer_shape(2) ) &
15414  & )
15415 
15416  allocate( answer_negative( &
15417  & answer_shape(1), &
15418 
15419  & answer_shape(2) ) &
15420  & )
15421 
15422  allocate( check_negative( &
15423  & answer_shape(1), &
15424 
15425  & answer_shape(2) ) &
15426  & )
15427 
15428  allocate( both_negative( &
15429  & answer_shape(1), &
15430 
15431  & answer_shape(2) ) &
15432  & )
15433 
15434  answer_negative = answer < 0.0
15435  check_negative = check < 0.0
15436  both_negative = answer_negative .and. check_negative
15437  if (.not. negative_support_on) both_negative = .false.
15438 
15439  judge = answer > check
15440  where (both_negative) judge = .not. judge
15441 
15442  judge_rev = .not. judge
15443  err_flag = any(judge_rev)
15444  mask_array = 1
15445  pos = maxloc(mask_array, judge_rev)
15446 
15447  if (err_flag) then
15448 
15449  wrong = check( &
15450  & pos(1), &
15451 
15452  & pos(2) )
15453 
15454  right = answer( &
15455  & pos(1), &
15456 
15457  & pos(2) )
15458 
15459  write(unit=pos_array(1), fmt="(i20)") pos(1)
15460 
15461  write(unit=pos_array(2), fmt="(i20)") pos(2)
15462 
15463 
15464  pos_str = '(' // &
15465  & trim(adjustl(pos_array(1))) // ',' // &
15466 
15467  & trim(adjustl(pos_array(2))) // ')'
15468 
15469  if ( both_negative( &
15470  & pos(1), &
15471 
15472  & pos(2) ) ) then
15473 
15474  abs_mes = 'ABSOLUTE value of'
15475  else
15476  abs_mes = ''
15477 
15478  end if
15479 
15480  end if
15481  deallocate(mask_array, judge, judge_rev)
15482  deallocate(answer_negative, check_negative, both_negative)
15483 
15484 
15485 
15486 
15487  if (err_flag) then
15488  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15489  write(*,*) ''
15490  write(*,*) ' ' // trim(abs_mes) // &
15491  & ' check' // trim(pos_str) // ' = ', wrong
15492  write(*,*) ' is NOT LESS THAN'
15493  write(*,*) ' ' // trim(abs_mes) // &
15494  & ' answer' // trim(pos_str) // ' = ', right
15495 
15496  call abortprogram('')
15497  else
15498  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15499  end if
15500 
15501 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118

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

Definition at line 15507 of file dc_test.f90.

15507  use sysdep, only: abortprogram
15508  use dc_types, only: string, token
15509  implicit none
15510  character(*), intent(in):: message
15511  real, intent(in):: answer(:,:,:)
15512  real, intent(in):: check(:,:,:)
15513  logical, intent(in), optional:: negative_support
15514  logical:: err_flag
15515  logical:: negative_support_on
15516  character(STRING):: pos_str
15517  character(TOKEN):: abs_mes
15518  real:: wrong, right
15519 
15520  integer:: answer_shape(3), check_shape(3), pos(3)
15521  logical:: consist_shape(3)
15522  character(TOKEN):: pos_array(3)
15523  integer, allocatable:: mask_array(:,:,:)
15524  logical, allocatable:: judge(:,:,:)
15525  logical, allocatable:: judge_rev(:,:,:)
15526  logical, allocatable:: answer_negative(:,:,:)
15527  logical, allocatable:: check_negative(:,:,:)
15528  logical, allocatable:: both_negative(:,:,:)
15529 
15530 
15531  continue
15532  if (present(negative_support)) then
15533  negative_support_on = negative_support
15534  else
15535  negative_support_on = .true.
15536  end if
15537 
15538  err_flag = .false.
15539 
15540 
15541  answer_shape = shape(answer)
15542  check_shape = shape(check)
15543 
15544  consist_shape = answer_shape == check_shape
15545 
15546  if (.not. all(consist_shape)) then
15547  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15548  write(*,*) ''
15549  write(*,*) ' shape of check is (', check_shape, ')'
15550  write(*,*) ' is INCORRECT'
15551  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15552 
15553  call abortprogram('')
15554  end if
15555 
15556 
15557  allocate( mask_array( &
15558  & answer_shape(1), &
15559 
15560  & answer_shape(2), &
15561 
15562  & answer_shape(3) ) &
15563  & )
15564 
15565  allocate( judge( &
15566  & answer_shape(1), &
15567 
15568  & answer_shape(2), &
15569 
15570  & answer_shape(3) ) &
15571  & )
15572 
15573  allocate( judge_rev( &
15574  & answer_shape(1), &
15575 
15576  & answer_shape(2), &
15577 
15578  & answer_shape(3) ) &
15579  & )
15580 
15581  allocate( answer_negative( &
15582  & answer_shape(1), &
15583 
15584  & answer_shape(2), &
15585 
15586  & answer_shape(3) ) &
15587  & )
15588 
15589  allocate( check_negative( &
15590  & answer_shape(1), &
15591 
15592  & answer_shape(2), &
15593 
15594  & answer_shape(3) ) &
15595  & )
15596 
15597  allocate( both_negative( &
15598  & answer_shape(1), &
15599 
15600  & answer_shape(2), &
15601 
15602  & answer_shape(3) ) &
15603  & )
15604 
15605  answer_negative = answer < 0.0
15606  check_negative = check < 0.0
15607  both_negative = answer_negative .and. check_negative
15608  if (.not. negative_support_on) both_negative = .false.
15609 
15610  judge = answer > check
15611  where (both_negative) judge = .not. judge
15612 
15613  judge_rev = .not. judge
15614  err_flag = any(judge_rev)
15615  mask_array = 1
15616  pos = maxloc(mask_array, judge_rev)
15617 
15618  if (err_flag) then
15619 
15620  wrong = check( &
15621  & pos(1), &
15622 
15623  & pos(2), &
15624 
15625  & pos(3) )
15626 
15627  right = answer( &
15628  & pos(1), &
15629 
15630  & pos(2), &
15631 
15632  & pos(3) )
15633 
15634  write(unit=pos_array(1), fmt="(i20)") pos(1)
15635 
15636  write(unit=pos_array(2), fmt="(i20)") pos(2)
15637 
15638  write(unit=pos_array(3), fmt="(i20)") pos(3)
15639 
15640 
15641  pos_str = '(' // &
15642  & trim(adjustl(pos_array(1))) // ',' // &
15643 
15644  & trim(adjustl(pos_array(2))) // ',' // &
15645 
15646  & trim(adjustl(pos_array(3))) // ')'
15647 
15648  if ( both_negative( &
15649  & pos(1), &
15650 
15651  & pos(2), &
15652 
15653  & pos(3) ) ) then
15654 
15655  abs_mes = 'ABSOLUTE value of'
15656  else
15657  abs_mes = ''
15658 
15659  end if
15660 
15661  end if
15662  deallocate(mask_array, judge, judge_rev)
15663  deallocate(answer_negative, check_negative, both_negative)
15664 
15665 
15666 
15667 
15668  if (err_flag) then
15669  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15670  write(*,*) ''
15671  write(*,*) ' ' // trim(abs_mes) // &
15672  & ' check' // trim(pos_str) // ' = ', wrong
15673  write(*,*) ' is NOT LESS THAN'
15674  write(*,*) ' ' // trim(abs_mes) // &
15675  & ' answer' // trim(pos_str) // ' = ', right
15676 
15677  call abortprogram('')
15678  else
15679  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15680  end if
15681 
15682 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118

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

Definition at line 15688 of file dc_test.f90.

15688  use sysdep, only: abortprogram
15689  use dc_types, only: string, token
15690  implicit none
15691  character(*), intent(in):: message
15692  real, intent(in):: answer(:,:,:,:)
15693  real, intent(in):: check(:,:,:,:)
15694  logical, intent(in), optional:: negative_support
15695  logical:: err_flag
15696  logical:: negative_support_on
15697  character(STRING):: pos_str
15698  character(TOKEN):: abs_mes
15699  real:: wrong, right
15700 
15701  integer:: answer_shape(4), check_shape(4), pos(4)
15702  logical:: consist_shape(4)
15703  character(TOKEN):: pos_array(4)
15704  integer, allocatable:: mask_array(:,:,:,:)
15705  logical, allocatable:: judge(:,:,:,:)
15706  logical, allocatable:: judge_rev(:,:,:,:)
15707  logical, allocatable:: answer_negative(:,:,:,:)
15708  logical, allocatable:: check_negative(:,:,:,:)
15709  logical, allocatable:: both_negative(:,:,:,:)
15710 
15711 
15712  continue
15713  if (present(negative_support)) then
15714  negative_support_on = negative_support
15715  else
15716  negative_support_on = .true.
15717  end if
15718 
15719  err_flag = .false.
15720 
15721 
15722  answer_shape = shape(answer)
15723  check_shape = shape(check)
15724 
15725  consist_shape = answer_shape == check_shape
15726 
15727  if (.not. all(consist_shape)) then
15728  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15729  write(*,*) ''
15730  write(*,*) ' shape of check is (', check_shape, ')'
15731  write(*,*) ' is INCORRECT'
15732  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15733 
15734  call abortprogram('')
15735  end if
15736 
15737 
15738  allocate( mask_array( &
15739  & answer_shape(1), &
15740 
15741  & answer_shape(2), &
15742 
15743  & answer_shape(3), &
15744 
15745  & answer_shape(4) ) &
15746  & )
15747 
15748  allocate( judge( &
15749  & answer_shape(1), &
15750 
15751  & answer_shape(2), &
15752 
15753  & answer_shape(3), &
15754 
15755  & answer_shape(4) ) &
15756  & )
15757 
15758  allocate( judge_rev( &
15759  & answer_shape(1), &
15760 
15761  & answer_shape(2), &
15762 
15763  & answer_shape(3), &
15764 
15765  & answer_shape(4) ) &
15766  & )
15767 
15768  allocate( answer_negative( &
15769  & answer_shape(1), &
15770 
15771  & answer_shape(2), &
15772 
15773  & answer_shape(3), &
15774 
15775  & answer_shape(4) ) &
15776  & )
15777 
15778  allocate( check_negative( &
15779  & answer_shape(1), &
15780 
15781  & answer_shape(2), &
15782 
15783  & answer_shape(3), &
15784 
15785  & answer_shape(4) ) &
15786  & )
15787 
15788  allocate( both_negative( &
15789  & answer_shape(1), &
15790 
15791  & answer_shape(2), &
15792 
15793  & answer_shape(3), &
15794 
15795  & answer_shape(4) ) &
15796  & )
15797 
15798  answer_negative = answer < 0.0
15799  check_negative = check < 0.0
15800  both_negative = answer_negative .and. check_negative
15801  if (.not. negative_support_on) both_negative = .false.
15802 
15803  judge = answer > check
15804  where (both_negative) judge = .not. judge
15805 
15806  judge_rev = .not. judge
15807  err_flag = any(judge_rev)
15808  mask_array = 1
15809  pos = maxloc(mask_array, judge_rev)
15810 
15811  if (err_flag) then
15812 
15813  wrong = check( &
15814  & pos(1), &
15815 
15816  & pos(2), &
15817 
15818  & pos(3), &
15819 
15820  & pos(4) )
15821 
15822  right = answer( &
15823  & pos(1), &
15824 
15825  & pos(2), &
15826 
15827  & pos(3), &
15828 
15829  & pos(4) )
15830 
15831  write(unit=pos_array(1), fmt="(i20)") pos(1)
15832 
15833  write(unit=pos_array(2), fmt="(i20)") pos(2)
15834 
15835  write(unit=pos_array(3), fmt="(i20)") pos(3)
15836 
15837  write(unit=pos_array(4), fmt="(i20)") pos(4)
15838 
15839 
15840  pos_str = '(' // &
15841  & trim(adjustl(pos_array(1))) // ',' // &
15842 
15843  & trim(adjustl(pos_array(2))) // ',' // &
15844 
15845  & trim(adjustl(pos_array(3))) // ',' // &
15846 
15847  & trim(adjustl(pos_array(4))) // ')'
15848 
15849  if ( both_negative( &
15850  & pos(1), &
15851 
15852  & pos(2), &
15853 
15854  & pos(3), &
15855 
15856  & pos(4) ) ) then
15857 
15858  abs_mes = 'ABSOLUTE value of'
15859  else
15860  abs_mes = ''
15861 
15862  end if
15863 
15864  end if
15865  deallocate(mask_array, judge, judge_rev)
15866  deallocate(answer_negative, check_negative, both_negative)
15867 
15868 
15869 
15870 
15871  if (err_flag) then
15872  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15873  write(*,*) ''
15874  write(*,*) ' ' // trim(abs_mes) // &
15875  & ' check' // trim(pos_str) // ' = ', wrong
15876  write(*,*) ' is NOT LESS THAN'
15877  write(*,*) ' ' // trim(abs_mes) // &
15878  & ' answer' // trim(pos_str) // ' = ', right
15879 
15880  call abortprogram('')
15881  else
15882  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
15883  end if
15884 
15885 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118

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

Definition at line 15891 of file dc_test.f90.

15891  use sysdep, only: abortprogram
15892  use dc_types, only: string, token
15893  implicit none
15894  character(*), intent(in):: message
15895  real, intent(in):: answer(:,:,:,:,:)
15896  real, intent(in):: check(:,:,:,:,:)
15897  logical, intent(in), optional:: negative_support
15898  logical:: err_flag
15899  logical:: negative_support_on
15900  character(STRING):: pos_str
15901  character(TOKEN):: abs_mes
15902  real:: wrong, right
15903 
15904  integer:: answer_shape(5), check_shape(5), pos(5)
15905  logical:: consist_shape(5)
15906  character(TOKEN):: pos_array(5)
15907  integer, allocatable:: mask_array(:,:,:,:,:)
15908  logical, allocatable:: judge(:,:,:,:,:)
15909  logical, allocatable:: judge_rev(:,:,:,:,:)
15910  logical, allocatable:: answer_negative(:,:,:,:,:)
15911  logical, allocatable:: check_negative(:,:,:,:,:)
15912  logical, allocatable:: both_negative(:,:,:,:,:)
15913 
15914 
15915  continue
15916  if (present(negative_support)) then
15917  negative_support_on = negative_support
15918  else
15919  negative_support_on = .true.
15920  end if
15921 
15922  err_flag = .false.
15923 
15924 
15925  answer_shape = shape(answer)
15926  check_shape = shape(check)
15927 
15928  consist_shape = answer_shape == check_shape
15929 
15930  if (.not. all(consist_shape)) then
15931  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
15932  write(*,*) ''
15933  write(*,*) ' shape of check is (', check_shape, ')'
15934  write(*,*) ' is INCORRECT'
15935  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
15936 
15937  call abortprogram('')
15938  end if
15939 
15940 
15941  allocate( mask_array( &
15942  & answer_shape(1), &
15943 
15944  & answer_shape(2), &
15945 
15946  & answer_shape(3), &
15947 
15948  & answer_shape(4), &
15949 
15950  & answer_shape(5) ) &
15951  & )
15952 
15953  allocate( judge( &
15954  & answer_shape(1), &
15955 
15956  & answer_shape(2), &
15957 
15958  & answer_shape(3), &
15959 
15960  & answer_shape(4), &
15961 
15962  & answer_shape(5) ) &
15963  & )
15964 
15965  allocate( judge_rev( &
15966  & answer_shape(1), &
15967 
15968  & answer_shape(2), &
15969 
15970  & answer_shape(3), &
15971 
15972  & answer_shape(4), &
15973 
15974  & answer_shape(5) ) &
15975  & )
15976 
15977  allocate( answer_negative( &
15978  & answer_shape(1), &
15979 
15980  & answer_shape(2), &
15981 
15982  & answer_shape(3), &
15983 
15984  & answer_shape(4), &
15985 
15986  & answer_shape(5) ) &
15987  & )
15988 
15989  allocate( check_negative( &
15990  & answer_shape(1), &
15991 
15992  & answer_shape(2), &
15993 
15994  & answer_shape(3), &
15995 
15996  & answer_shape(4), &
15997 
15998  & answer_shape(5) ) &
15999  & )
16000 
16001  allocate( both_negative( &
16002  & answer_shape(1), &
16003 
16004  & answer_shape(2), &
16005 
16006  & answer_shape(3), &
16007 
16008  & answer_shape(4), &
16009 
16010  & answer_shape(5) ) &
16011  & )
16012 
16013  answer_negative = answer < 0.0
16014  check_negative = check < 0.0
16015  both_negative = answer_negative .and. check_negative
16016  if (.not. negative_support_on) both_negative = .false.
16017 
16018  judge = answer > check
16019  where (both_negative) judge = .not. judge
16020 
16021  judge_rev = .not. judge
16022  err_flag = any(judge_rev)
16023  mask_array = 1
16024  pos = maxloc(mask_array, judge_rev)
16025 
16026  if (err_flag) then
16027 
16028  wrong = check( &
16029  & pos(1), &
16030 
16031  & pos(2), &
16032 
16033  & pos(3), &
16034 
16035  & pos(4), &
16036 
16037  & pos(5) )
16038 
16039  right = answer( &
16040  & pos(1), &
16041 
16042  & pos(2), &
16043 
16044  & pos(3), &
16045 
16046  & pos(4), &
16047 
16048  & pos(5) )
16049 
16050  write(unit=pos_array(1), fmt="(i20)") pos(1)
16051 
16052  write(unit=pos_array(2), fmt="(i20)") pos(2)
16053 
16054  write(unit=pos_array(3), fmt="(i20)") pos(3)
16055 
16056  write(unit=pos_array(4), fmt="(i20)") pos(4)
16057 
16058  write(unit=pos_array(5), fmt="(i20)") pos(5)
16059 
16060 
16061  pos_str = '(' // &
16062  & trim(adjustl(pos_array(1))) // ',' // &
16063 
16064  & trim(adjustl(pos_array(2))) // ',' // &
16065 
16066  & trim(adjustl(pos_array(3))) // ',' // &
16067 
16068  & trim(adjustl(pos_array(4))) // ',' // &
16069 
16070  & trim(adjustl(pos_array(5))) // ')'
16071 
16072  if ( both_negative( &
16073  & pos(1), &
16074 
16075  & pos(2), &
16076 
16077  & pos(3), &
16078 
16079  & pos(4), &
16080 
16081  & pos(5) ) ) then
16082 
16083  abs_mes = 'ABSOLUTE value of'
16084  else
16085  abs_mes = ''
16086 
16087  end if
16088 
16089  end if
16090  deallocate(mask_array, judge, judge_rev)
16091  deallocate(answer_negative, check_negative, both_negative)
16092 
16093 
16094 
16095 
16096  if (err_flag) then
16097  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16098  write(*,*) ''
16099  write(*,*) ' ' // trim(abs_mes) // &
16100  & ' check' // trim(pos_str) // ' = ', wrong
16101  write(*,*) ' is NOT LESS THAN'
16102  write(*,*) ' ' // trim(abs_mes) // &
16103  & ' answer' // trim(pos_str) // ' = ', right
16104 
16105  call abortprogram('')
16106  else
16107  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16108  end if
16109 
16110 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118

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

Definition at line 16116 of file dc_test.f90.

16116  use sysdep, only: abortprogram
16117  use dc_types, only: string, token
16118  implicit none
16119  character(*), intent(in):: message
16120  real, intent(in):: answer(:,:,:,:,:,:)
16121  real, intent(in):: check(:,:,:,:,:,:)
16122  logical, intent(in), optional:: negative_support
16123  logical:: err_flag
16124  logical:: negative_support_on
16125  character(STRING):: pos_str
16126  character(TOKEN):: abs_mes
16127  real:: wrong, right
16128 
16129  integer:: answer_shape(6), check_shape(6), pos(6)
16130  logical:: consist_shape(6)
16131  character(TOKEN):: pos_array(6)
16132  integer, allocatable:: mask_array(:,:,:,:,:,:)
16133  logical, allocatable:: judge(:,:,:,:,:,:)
16134  logical, allocatable:: judge_rev(:,:,:,:,:,:)
16135  logical, allocatable:: answer_negative(:,:,:,:,:,:)
16136  logical, allocatable:: check_negative(:,:,:,:,:,:)
16137  logical, allocatable:: both_negative(:,:,:,:,:,:)
16138 
16139 
16140  continue
16141  if (present(negative_support)) then
16142  negative_support_on = negative_support
16143  else
16144  negative_support_on = .true.
16145  end if
16146 
16147  err_flag = .false.
16148 
16149 
16150  answer_shape = shape(answer)
16151  check_shape = shape(check)
16152 
16153  consist_shape = answer_shape == check_shape
16154 
16155  if (.not. all(consist_shape)) then
16156  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16157  write(*,*) ''
16158  write(*,*) ' shape of check is (', check_shape, ')'
16159  write(*,*) ' is INCORRECT'
16160  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
16161 
16162  call abortprogram('')
16163  end if
16164 
16165 
16166  allocate( mask_array( &
16167  & answer_shape(1), &
16168 
16169  & answer_shape(2), &
16170 
16171  & answer_shape(3), &
16172 
16173  & answer_shape(4), &
16174 
16175  & answer_shape(5), &
16176 
16177  & answer_shape(6) ) &
16178  & )
16179 
16180  allocate( judge( &
16181  & answer_shape(1), &
16182 
16183  & answer_shape(2), &
16184 
16185  & answer_shape(3), &
16186 
16187  & answer_shape(4), &
16188 
16189  & answer_shape(5), &
16190 
16191  & answer_shape(6) ) &
16192  & )
16193 
16194  allocate( judge_rev( &
16195  & answer_shape(1), &
16196 
16197  & answer_shape(2), &
16198 
16199  & answer_shape(3), &
16200 
16201  & answer_shape(4), &
16202 
16203  & answer_shape(5), &
16204 
16205  & answer_shape(6) ) &
16206  & )
16207 
16208  allocate( answer_negative( &
16209  & answer_shape(1), &
16210 
16211  & answer_shape(2), &
16212 
16213  & answer_shape(3), &
16214 
16215  & answer_shape(4), &
16216 
16217  & answer_shape(5), &
16218 
16219  & answer_shape(6) ) &
16220  & )
16221 
16222  allocate( check_negative( &
16223  & answer_shape(1), &
16224 
16225  & answer_shape(2), &
16226 
16227  & answer_shape(3), &
16228 
16229  & answer_shape(4), &
16230 
16231  & answer_shape(5), &
16232 
16233  & answer_shape(6) ) &
16234  & )
16235 
16236  allocate( both_negative( &
16237  & answer_shape(1), &
16238 
16239  & answer_shape(2), &
16240 
16241  & answer_shape(3), &
16242 
16243  & answer_shape(4), &
16244 
16245  & answer_shape(5), &
16246 
16247  & answer_shape(6) ) &
16248  & )
16249 
16250  answer_negative = answer < 0.0
16251  check_negative = check < 0.0
16252  both_negative = answer_negative .and. check_negative
16253  if (.not. negative_support_on) both_negative = .false.
16254 
16255  judge = answer > check
16256  where (both_negative) judge = .not. judge
16257 
16258  judge_rev = .not. judge
16259  err_flag = any(judge_rev)
16260  mask_array = 1
16261  pos = maxloc(mask_array, judge_rev)
16262 
16263  if (err_flag) then
16264 
16265  wrong = check( &
16266  & pos(1), &
16267 
16268  & pos(2), &
16269 
16270  & pos(3), &
16271 
16272  & pos(4), &
16273 
16274  & pos(5), &
16275 
16276  & pos(6) )
16277 
16278  right = answer( &
16279  & pos(1), &
16280 
16281  & pos(2), &
16282 
16283  & pos(3), &
16284 
16285  & pos(4), &
16286 
16287  & pos(5), &
16288 
16289  & pos(6) )
16290 
16291  write(unit=pos_array(1), fmt="(i20)") pos(1)
16292 
16293  write(unit=pos_array(2), fmt="(i20)") pos(2)
16294 
16295  write(unit=pos_array(3), fmt="(i20)") pos(3)
16296 
16297  write(unit=pos_array(4), fmt="(i20)") pos(4)
16298 
16299  write(unit=pos_array(5), fmt="(i20)") pos(5)
16300 
16301  write(unit=pos_array(6), fmt="(i20)") pos(6)
16302 
16303 
16304  pos_str = '(' // &
16305  & trim(adjustl(pos_array(1))) // ',' // &
16306 
16307  & trim(adjustl(pos_array(2))) // ',' // &
16308 
16309  & trim(adjustl(pos_array(3))) // ',' // &
16310 
16311  & trim(adjustl(pos_array(4))) // ',' // &
16312 
16313  & trim(adjustl(pos_array(5))) // ',' // &
16314 
16315  & trim(adjustl(pos_array(6))) // ')'
16316 
16317  if ( both_negative( &
16318  & pos(1), &
16319 
16320  & pos(2), &
16321 
16322  & pos(3), &
16323 
16324  & pos(4), &
16325 
16326  & pos(5), &
16327 
16328  & pos(6) ) ) then
16329 
16330  abs_mes = 'ABSOLUTE value of'
16331  else
16332  abs_mes = ''
16333 
16334  end if
16335 
16336  end if
16337  deallocate(mask_array, judge, judge_rev)
16338  deallocate(answer_negative, check_negative, both_negative)
16339 
16340 
16341 
16342 
16343  if (err_flag) then
16344  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16345  write(*,*) ''
16346  write(*,*) ' ' // trim(abs_mes) // &
16347  & ' check' // trim(pos_str) // ' = ', wrong
16348  write(*,*) ' is NOT LESS THAN'
16349  write(*,*) ' ' // trim(abs_mes) // &
16350  & ' answer' // trim(pos_str) // ' = ', right
16351 
16352  call abortprogram('')
16353  else
16354  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16355  end if
16356 
16357 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118

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

Definition at line 16363 of file dc_test.f90.

16363  use sysdep, only: abortprogram
16364  use dc_types, only: string, token
16365  implicit none
16366  character(*), intent(in):: message
16367  real, intent(in):: answer(:,:,:,:,:,:,:)
16368  real, intent(in):: check(:,:,:,:,:,:,:)
16369  logical, intent(in), optional:: negative_support
16370  logical:: err_flag
16371  logical:: negative_support_on
16372  character(STRING):: pos_str
16373  character(TOKEN):: abs_mes
16374  real:: wrong, right
16375 
16376  integer:: answer_shape(7), check_shape(7), pos(7)
16377  logical:: consist_shape(7)
16378  character(TOKEN):: pos_array(7)
16379  integer, allocatable:: mask_array(:,:,:,:,:,:,:)
16380  logical, allocatable:: judge(:,:,:,:,:,:,:)
16381  logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
16382  logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
16383  logical, allocatable:: check_negative(:,:,:,:,:,:,:)
16384  logical, allocatable:: both_negative(:,:,:,:,:,:,:)
16385 
16386 
16387  continue
16388  if (present(negative_support)) then
16389  negative_support_on = negative_support
16390  else
16391  negative_support_on = .true.
16392  end if
16393 
16394  err_flag = .false.
16395 
16396 
16397  answer_shape = shape(answer)
16398  check_shape = shape(check)
16399 
16400  consist_shape = answer_shape == check_shape
16401 
16402  if (.not. all(consist_shape)) then
16403  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16404  write(*,*) ''
16405  write(*,*) ' shape of check is (', check_shape, ')'
16406  write(*,*) ' is INCORRECT'
16407  write(*,*) ' Correct shape of answer is (', answer_shape, ')'
16408 
16409  call abortprogram('')
16410  end if
16411 
16412 
16413  allocate( mask_array( &
16414  & answer_shape(1), &
16415 
16416  & answer_shape(2), &
16417 
16418  & answer_shape(3), &
16419 
16420  & answer_shape(4), &
16421 
16422  & answer_shape(5), &
16423 
16424  & answer_shape(6), &
16425 
16426  & answer_shape(7) ) &
16427  & )
16428 
16429  allocate( judge( &
16430  & answer_shape(1), &
16431 
16432  & answer_shape(2), &
16433 
16434  & answer_shape(3), &
16435 
16436  & answer_shape(4), &
16437 
16438  & answer_shape(5), &
16439 
16440  & answer_shape(6), &
16441 
16442  & answer_shape(7) ) &
16443  & )
16444 
16445  allocate( judge_rev( &
16446  & answer_shape(1), &
16447 
16448  & answer_shape(2), &
16449 
16450  & answer_shape(3), &
16451 
16452  & answer_shape(4), &
16453 
16454  & answer_shape(5), &
16455 
16456  & answer_shape(6), &
16457 
16458  & answer_shape(7) ) &
16459  & )
16460 
16461  allocate( answer_negative( &
16462  & answer_shape(1), &
16463 
16464  & answer_shape(2), &
16465 
16466  & answer_shape(3), &
16467 
16468  & answer_shape(4), &
16469 
16470  & answer_shape(5), &
16471 
16472  & answer_shape(6), &
16473 
16474  & answer_shape(7) ) &
16475  & )
16476 
16477  allocate( check_negative( &
16478  & answer_shape(1), &
16479 
16480  & answer_shape(2), &
16481 
16482  & answer_shape(3), &
16483 
16484  & answer_shape(4), &
16485 
16486  & answer_shape(5), &
16487 
16488  & answer_shape(6), &
16489 
16490  & answer_shape(7) ) &
16491  & )
16492 
16493  allocate( both_negative( &
16494  & answer_shape(1), &
16495 
16496  & answer_shape(2), &
16497 
16498  & answer_shape(3), &
16499 
16500  & answer_shape(4), &
16501 
16502  & answer_shape(5), &
16503 
16504  & answer_shape(6), &
16505 
16506  & answer_shape(7) ) &
16507  & )
16508 
16509  answer_negative = answer < 0.0
16510  check_negative = check < 0.0
16511  both_negative = answer_negative .and. check_negative
16512  if (.not. negative_support_on) both_negative = .false.
16513 
16514  judge = answer > check
16515  where (both_negative) judge = .not. judge
16516 
16517  judge_rev = .not. judge
16518  err_flag = any(judge_rev)
16519  mask_array = 1
16520  pos = maxloc(mask_array, judge_rev)
16521 
16522  if (err_flag) then
16523 
16524  wrong = check( &
16525  & pos(1), &
16526 
16527  & pos(2), &
16528 
16529  & pos(3), &
16530 
16531  & pos(4), &
16532 
16533  & pos(5), &
16534 
16535  & pos(6), &
16536 
16537  & pos(7) )
16538 
16539  right = answer( &
16540  & pos(1), &
16541 
16542  & pos(2), &
16543 
16544  & pos(3), &
16545 
16546  & pos(4), &
16547 
16548  & pos(5), &
16549 
16550  & pos(6), &
16551 
16552  & pos(7) )
16553 
16554  write(unit=pos_array(1), fmt="(i20)") pos(1)
16555 
16556  write(unit=pos_array(2), fmt="(i20)") pos(2)
16557 
16558  write(unit=pos_array(3), fmt="(i20)") pos(3)
16559 
16560  write(unit=pos_array(4), fmt="(i20)") pos(4)
16561 
16562  write(unit=pos_array(5), fmt="(i20)") pos(5)
16563 
16564  write(unit=pos_array(6), fmt="(i20)") pos(6)
16565 
16566  write(unit=pos_array(7), fmt="(i20)") pos(7)
16567 
16568 
16569  pos_str = '(' // &
16570  & trim(adjustl(pos_array(1))) // ',' // &
16571 
16572  & trim(adjustl(pos_array(2))) // ',' // &
16573 
16574  & trim(adjustl(pos_array(3))) // ',' // &
16575 
16576  & trim(adjustl(pos_array(4))) // ',' // &
16577 
16578  & trim(adjustl(pos_array(5))) // ',' // &
16579 
16580  & trim(adjustl(pos_array(6))) // ',' // &
16581 
16582  & trim(adjustl(pos_array(7))) // ')'
16583 
16584  if ( both_negative( &
16585  & pos(1), &
16586 
16587  & pos(2), &
16588 
16589  & pos(3), &
16590 
16591  & pos(4), &
16592 
16593  & pos(5), &
16594 
16595  & pos(6), &
16596 
16597  & pos(7) ) ) then
16598 
16599  abs_mes = 'ABSOLUTE value of'
16600  else
16601  abs_mes = ''
16602 
16603  end if
16604 
16605  end if
16606  deallocate(mask_array, judge, judge_rev)
16607  deallocate(answer_negative, check_negative, both_negative)
16608 
16609 
16610 
16611 
16612  if (err_flag) then
16613  write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
16614  write(*,*) ''
16615  write(*,*) ' ' // trim(abs_mes) // &
16616  & ' check' // trim(pos_str) // ' = ', wrong
16617  write(*,*) ' is NOT LESS THAN'
16618  write(*,*) ' ' // trim(abs_mes) // &
16619  & ' answer' // trim(pos_str) // ' = ', right
16620 
16621  call abortprogram('')
16622  else
16623  write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
16624  end if
16625 
16626 
dc_types::token
integer, parameter, public token
単語やキーワードを保持する文字型変数の種別型パラメタ
Definition: dc_types.f90:109
dc_types
種別型パラメタを提供します。
Definition: dc_types.f90:49
dc_types::string
integer, parameter, public string
文字列を保持する 文字型変数の種別型パラメタ
Definition: dc_types.f90:118
The documentation for this interface was generated from the following file: