| Class | dc_test |
| In: |
dc_test.f90
|
Fortran 90/95 におけるテストプログラム作成を補助するための モジュールです.
オブジェクト指向スクリプト言語 Ruby の Test::Unit クラス の機能の一部を模倣しています.
| AssertEqual : | 正答とチェックすべき値とを照合する. |
AssertEqual サブルーチンは以下のように用います. message にはテストプログラムを実行した際に表示する 任意の長さの文字列を与えます. そして, answer には正答を, check には照合すべき値を与えます. answer と check にはそれぞれ文字型, 整数型, 単精度実数型, 倍精度実数型, 論理型の変数および 配列 (1 〜 7次元) を与えることができます. 2 つの引数の型および次元数は一致している必要があります.
program test
use dc_test, only: AssertEqual
implicit none
character(32) :: str1
str1 = 'foo'
call AssertEqual(message='String test', answer='foo', check=str1)
end program test
もしも answer と check の値, もしくは配列のサイズが異なる場合, テストプログラムはエラーを返して終了します.
具体例は以下の通りです.
program test_sample
use dc_types, only: STRING, DP
use dc_test, only: AssertEqual
character(STRING):: str1
integer:: int1
real:: numr1(2)
real(DP):: numd1(2,3)
logical:: y_n
str1 = "foo"
call AssertEqual('Character test', answer='foo', check=str1)
int1 = 1
call AssertEqual('Integer test', answer=1, check=int1)
numr1(:) = (/0.00123, 0.2/)
call AssertEqual('Float test', answer=(/0.00123, 0.2/), check=numr1)
y_n = .true.
call AssertEqual('Logical test', answer=.true., check=y_n)
numd1(1,:) = (/19.432d0, 75.3d0, 3.183d0/)
numd1(2,:) = (/0.023d0, 0.9d0, 328.2d0/)
call AssertEqual('Double precision test 1', &
& answer=(/19.432d0, 75.3d0, 3.183d0/), check=numd1(1,:))
call AssertEqual('Double precision test 2', &
& answer=(/0.023d0, 0.9d0, 238.5d0/), check=numd1(2,:))
end program test_sample
上記の例では, 最後のテストで敢えて間違った answer を与えているので, 以下のようなメッセージを出力してプログラムは強制終了します.
*** MESSAGE [DCAssertEqual] *** Checking Character test OK
*** MESSAGE [DCAssertEqual] *** Checking Integer test OK
*** MESSAGE [DCAssertEqual] *** Checking Float test OK
*** MESSAGE [DCAssertEqual] *** Checking Logical test OK
*** MESSAGE [DCAssertEqual] *** Checking Double precision test 1 OK
*** Error [DCAssertEqual] *** Checking Double precision test 2 FAILURE
check(3) = 328.2
is INCORRECT
Correct answer is answer(3) = 238.5
| Subroutine : | |
| message : | character(*), intent(in) |
| answer : | character(*), intent(in) |
| check : | character(*), intent(in) |
subroutine DCAssertEqualChar0(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
character(*), intent(in):: answer
character(*), intent(in):: check
logical :: err_flag
character(STRING) :: pos_str
character(STRING) :: wrong, right
continue
err_flag = .false.
err_flag = .not. trim(answer) == trim(check)
wrong = check
right = answer
pos_str = ''
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', trim(right)
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualChar0
| Subroutine : | |
| message : | character(*), intent(in) |
| answer : | integer, intent(in) |
| check : | integer, intent(in) |
subroutine DCAssertEqualInt0(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer
integer, intent(in):: check
logical :: err_flag
character(STRING) :: pos_str
integer :: wrong, right
continue
err_flag = .false.
err_flag = .not. answer == check
wrong = check
right = answer
pos_str = ''
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualInt0
| Subroutine : | |
| message : | character(*), intent(in) |
| answer : | logical, intent(in) |
| check : | logical, intent(in) |
subroutine DCAssertEqualLogical0(message, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: message
logical, intent(in):: answer
logical, intent(in):: check
character(STRING) :: answer_str
character(STRING) :: check_str
continue
if (answer) then
answer_str = ".true."
else
answer_str = ".false."
end if
if (check) then
check_str = ".true."
else
check_str = ".false."
end if
call DCAssertEqualChar0(message, answer_str, check_str)
end subroutine DCAssertEqualLogical0
| Subroutine : | |
| message : | character(*), intent(in) |
| answer : | real(DP), intent(in) |
| check : | real(DP), intent(in) |
subroutine DCAssertEqualDouble0(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer
real(DP), intent(in):: check
logical :: err_flag
character(STRING) :: pos_str
real(DP) :: wrong, right
continue
err_flag = .false.
err_flag = .not. answer == check
wrong = check
right = answer
pos_str = ''
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualDouble0
| Subroutine : | |
| message : | character(*), intent(in) |
| answer : | real, intent(in) |
| check : | real, intent(in) |
subroutine DCAssertEqualReal0(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer
real, intent(in):: check
logical :: err_flag
character(STRING) :: pos_str
real :: wrong, right
continue
err_flag = .false.
err_flag = .not. answer == check
wrong = check
right = answer
pos_str = ''
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualReal0
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:) : | character(*), intent(in) |
| check(:) : | character(*), intent(in) |
subroutine DCAssertEqualChar1(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
character(*), intent(in):: answer(:)
character(*), intent(in):: check(:)
logical :: err_flag
character(STRING) :: pos_str
character(STRING) :: wrong, right
integer :: answer_shape(1), check_shape(1), pos(1)
logical :: consist_shape(1)
character(TOKEN) :: pos_array(1)
integer, allocatable :: mask_array(:)
logical, allocatable :: judge(:)
logical, allocatable :: judge_rev(:)
character(STRING), allocatable :: answer_fixed_length(:)
character(STRING), allocatable :: check_fixed_length(:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1) ) )
allocate( judge ( answer_shape(1) ) )
allocate( judge_rev ( answer_shape(1) ) )
allocate( answer_fixed_length ( answer_shape(1) ) )
allocate( check_fixed_length ( check_shape(1) ) )
answer_fixed_length = answer
check_fixed_length = check
judge = answer_fixed_length == check_fixed_length
deallocate(answer_fixed_length, check_fixed_length)
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1) )
right = answer ( pos(1) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
pos_str = '(' // trim(adjustl(pos_array(1))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', trim(right)
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualChar1
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:) : | integer, intent(in) |
| check(:) : | integer, intent(in) |
subroutine DCAssertEqualInt1(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:)
integer, intent(in):: check(:)
logical :: err_flag
character(STRING) :: pos_str
integer :: wrong, right
integer :: answer_shape(1), check_shape(1), pos(1)
logical :: consist_shape(1)
character(TOKEN) :: pos_array(1)
integer, allocatable :: mask_array(:)
logical, allocatable :: judge(:)
logical, allocatable :: judge_rev(:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1) ) )
allocate( judge ( answer_shape(1) ) )
allocate( judge_rev ( answer_shape(1) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1) )
right = answer ( pos(1) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
pos_str = '(' // trim(adjustl(pos_array(1))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualInt1
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:) : | logical, intent(in) |
| check(:) : | logical, intent(in) |
subroutine DCAssertEqualLogical1(message, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: message
logical, intent(in):: answer(:)
logical, intent(in):: check(:)
integer :: answer_shape(1), check_shape(1), i
logical, allocatable :: answer_tmp(:), check_tmp(:)
character(STRING), allocatable :: answer_str_tmp(:), check_str_tmp(:)
character(STRING), allocatable :: answer_str(:)
character(STRING), allocatable :: check_str(:)
continue
allocate(answer_tmp(size(answer)))
allocate(check_tmp(size(check)))
allocate(answer_str_tmp(size(answer)))
allocate(check_str_tmp(size(check)))
answer_tmp = pack(answer, .true.)
check_tmp = pack(check, .true.)
do i = 1, size(answer_tmp)
if (answer_tmp(i)) then
answer_str_tmp(i) = '.true.'
else
answer_str_tmp(i) = '.false.'
end if
end do
do i = 1, size(check_tmp)
if (check_tmp(i)) then
check_str_tmp(i) = '.true.'
else
check_str_tmp(i) = '.false.'
end if
end do
answer_shape = shape(answer)
check_shape = shape(check)
allocate( answer_str ( answer_shape(1) ) )
allocate( check_str ( check_shape(1) ) )
answer_str = reshape(answer_str_tmp, answer_shape)
check_str = reshape(check_str_tmp, check_shape)
call DCAssertEqualChar1(message, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCAssertEqualLogical1
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:) : | real(DP), intent(in) |
| check(:) : | real(DP), intent(in) |
subroutine DCAssertEqualDouble1(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:)
real(DP), intent(in):: check(:)
logical :: err_flag
character(STRING) :: pos_str
real(DP) :: wrong, right
integer :: answer_shape(1), check_shape(1), pos(1)
logical :: consist_shape(1)
character(TOKEN) :: pos_array(1)
integer, allocatable :: mask_array(:)
logical, allocatable :: judge(:)
logical, allocatable :: judge_rev(:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1) ) )
allocate( judge ( answer_shape(1) ) )
allocate( judge_rev ( answer_shape(1) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1) )
right = answer ( pos(1) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
pos_str = '(' // trim(adjustl(pos_array(1))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualDouble1
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:) : | real, intent(in) |
| check(:) : | real, intent(in) |
subroutine DCAssertEqualReal1(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:)
real, intent(in):: check(:)
logical :: err_flag
character(STRING) :: pos_str
real :: wrong, right
integer :: answer_shape(1), check_shape(1), pos(1)
logical :: consist_shape(1)
character(TOKEN) :: pos_array(1)
integer, allocatable :: mask_array(:)
logical, allocatable :: judge(:)
logical, allocatable :: judge_rev(:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1) ) )
allocate( judge ( answer_shape(1) ) )
allocate( judge_rev ( answer_shape(1) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1) )
right = answer ( pos(1) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
pos_str = '(' // trim(adjustl(pos_array(1))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualReal1
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:) : | character(*), intent(in) |
| check(:,:) : | character(*), intent(in) |
subroutine DCAssertEqualChar2(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
character(*), intent(in):: answer(:,:)
character(*), intent(in):: check(:,:)
logical :: err_flag
character(STRING) :: pos_str
character(STRING) :: wrong, right
integer :: answer_shape(2), check_shape(2), pos(2)
logical :: consist_shape(2)
character(TOKEN) :: pos_array(2)
integer, allocatable :: mask_array(:,:)
logical, allocatable :: judge(:,:)
logical, allocatable :: judge_rev(:,:)
character(STRING), allocatable :: answer_fixed_length(:,:)
character(STRING), allocatable :: check_fixed_length(:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2) ) )
allocate( judge ( answer_shape(1), answer_shape(2) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2) ) )
allocate( answer_fixed_length ( answer_shape(1), answer_shape(2) ) )
allocate( check_fixed_length ( check_shape(1), check_shape(2) ) )
answer_fixed_length = answer
check_fixed_length = check
judge = answer_fixed_length == check_fixed_length
deallocate(answer_fixed_length, check_fixed_length)
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2) )
right = answer ( pos(1), pos(2) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', trim(right)
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualChar2
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:) : | integer, intent(in) |
| check(:,:) : | integer, intent(in) |
subroutine DCAssertEqualInt2(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:)
integer, intent(in):: check(:,:)
logical :: err_flag
character(STRING) :: pos_str
integer :: wrong, right
integer :: answer_shape(2), check_shape(2), pos(2)
logical :: consist_shape(2)
character(TOKEN) :: pos_array(2)
integer, allocatable :: mask_array(:,:)
logical, allocatable :: judge(:,:)
logical, allocatable :: judge_rev(:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2) ) )
allocate( judge ( answer_shape(1), answer_shape(2) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2) )
right = answer ( pos(1), pos(2) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualInt2
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:) : | logical, intent(in) |
| check(:,:) : | logical, intent(in) |
subroutine DCAssertEqualLogical2(message, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: message
logical, intent(in):: answer(:,:)
logical, intent(in):: check(:,:)
integer :: answer_shape(2), check_shape(2), i
logical, allocatable :: answer_tmp(:), check_tmp(:)
character(STRING), allocatable :: answer_str_tmp(:), check_str_tmp(:)
character(STRING), allocatable :: answer_str(:,:)
character(STRING), allocatable :: check_str(:,:)
continue
allocate(answer_tmp(size(answer)))
allocate(check_tmp(size(check)))
allocate(answer_str_tmp(size(answer)))
allocate(check_str_tmp(size(check)))
answer_tmp = pack(answer, .true.)
check_tmp = pack(check, .true.)
do i = 1, size(answer_tmp)
if (answer_tmp(i)) then
answer_str_tmp(i) = '.true.'
else
answer_str_tmp(i) = '.false.'
end if
end do
do i = 1, size(check_tmp)
if (check_tmp(i)) then
check_str_tmp(i) = '.true.'
else
check_str_tmp(i) = '.false.'
end if
end do
answer_shape = shape(answer)
check_shape = shape(check)
allocate( answer_str ( answer_shape(1), answer_shape(2) ) )
allocate( check_str ( check_shape(1), check_shape(2) ) )
answer_str = reshape(answer_str_tmp, answer_shape)
check_str = reshape(check_str_tmp, check_shape)
call DCAssertEqualChar2(message, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCAssertEqualLogical2
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:) : | real(DP), intent(in) |
| check(:,:) : | real(DP), intent(in) |
subroutine DCAssertEqualDouble2(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:)
real(DP), intent(in):: check(:,:)
logical :: err_flag
character(STRING) :: pos_str
real(DP) :: wrong, right
integer :: answer_shape(2), check_shape(2), pos(2)
logical :: consist_shape(2)
character(TOKEN) :: pos_array(2)
integer, allocatable :: mask_array(:,:)
logical, allocatable :: judge(:,:)
logical, allocatable :: judge_rev(:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2) ) )
allocate( judge ( answer_shape(1), answer_shape(2) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2) )
right = answer ( pos(1), pos(2) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualDouble2
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:) : | real, intent(in) |
| check(:,:) : | real, intent(in) |
subroutine DCAssertEqualReal2(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:)
real, intent(in):: check(:,:)
logical :: err_flag
character(STRING) :: pos_str
real :: wrong, right
integer :: answer_shape(2), check_shape(2), pos(2)
logical :: consist_shape(2)
character(TOKEN) :: pos_array(2)
integer, allocatable :: mask_array(:,:)
logical, allocatable :: judge(:,:)
logical, allocatable :: judge_rev(:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2) ) )
allocate( judge ( answer_shape(1), answer_shape(2) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2) )
right = answer ( pos(1), pos(2) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualReal2
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:) : | character(*), intent(in) |
| check(:,:,:) : | character(*), intent(in) |
subroutine DCAssertEqualChar3(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
character(*), intent(in):: answer(:,:,:)
character(*), intent(in):: check(:,:,:)
logical :: err_flag
character(STRING) :: pos_str
character(STRING) :: wrong, right
integer :: answer_shape(3), check_shape(3), pos(3)
logical :: consist_shape(3)
character(TOKEN) :: pos_array(3)
integer, allocatable :: mask_array(:,:,:)
logical, allocatable :: judge(:,:,:)
logical, allocatable :: judge_rev(:,:,:)
character(STRING), allocatable :: answer_fixed_length(:,:,:)
character(STRING), allocatable :: check_fixed_length(:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( answer_fixed_length ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( check_fixed_length ( check_shape(1), check_shape(2), check_shape(3) ) )
answer_fixed_length = answer
check_fixed_length = check
judge = answer_fixed_length == check_fixed_length
deallocate(answer_fixed_length, check_fixed_length)
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3) )
right = answer ( pos(1), pos(2), pos(3) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', trim(right)
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualChar3
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:) : | integer, intent(in) |
| check(:,:,:) : | integer, intent(in) |
subroutine DCAssertEqualInt3(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:,:)
integer, intent(in):: check(:,:,:)
logical :: err_flag
character(STRING) :: pos_str
integer :: wrong, right
integer :: answer_shape(3), check_shape(3), pos(3)
logical :: consist_shape(3)
character(TOKEN) :: pos_array(3)
integer, allocatable :: mask_array(:,:,:)
logical, allocatable :: judge(:,:,:)
logical, allocatable :: judge_rev(:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3) )
right = answer ( pos(1), pos(2), pos(3) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualInt3
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:) : | logical, intent(in) |
| check(:,:,:) : | logical, intent(in) |
subroutine DCAssertEqualLogical3(message, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: message
logical, intent(in):: answer(:,:,:)
logical, intent(in):: check(:,:,:)
integer :: answer_shape(3), check_shape(3), i
logical, allocatable :: answer_tmp(:), check_tmp(:)
character(STRING), allocatable :: answer_str_tmp(:), check_str_tmp(:)
character(STRING), allocatable :: answer_str(:,:,:)
character(STRING), allocatable :: check_str(:,:,:)
continue
allocate(answer_tmp(size(answer)))
allocate(check_tmp(size(check)))
allocate(answer_str_tmp(size(answer)))
allocate(check_str_tmp(size(check)))
answer_tmp = pack(answer, .true.)
check_tmp = pack(check, .true.)
do i = 1, size(answer_tmp)
if (answer_tmp(i)) then
answer_str_tmp(i) = '.true.'
else
answer_str_tmp(i) = '.false.'
end if
end do
do i = 1, size(check_tmp)
if (check_tmp(i)) then
check_str_tmp(i) = '.true.'
else
check_str_tmp(i) = '.false.'
end if
end do
answer_shape = shape(answer)
check_shape = shape(check)
allocate( answer_str ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( check_str ( check_shape(1), check_shape(2), check_shape(3) ) )
answer_str = reshape(answer_str_tmp, answer_shape)
check_str = reshape(check_str_tmp, check_shape)
call DCAssertEqualChar3(message, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCAssertEqualLogical3
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:) : | real(DP), intent(in) |
| check(:,:,:) : | real(DP), intent(in) |
subroutine DCAssertEqualDouble3(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:)
real(DP), intent(in):: check(:,:,:)
logical :: err_flag
character(STRING) :: pos_str
real(DP) :: wrong, right
integer :: answer_shape(3), check_shape(3), pos(3)
logical :: consist_shape(3)
character(TOKEN) :: pos_array(3)
integer, allocatable :: mask_array(:,:,:)
logical, allocatable :: judge(:,:,:)
logical, allocatable :: judge_rev(:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3) )
right = answer ( pos(1), pos(2), pos(3) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualDouble3
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:) : | real, intent(in) |
| check(:,:,:) : | real, intent(in) |
subroutine DCAssertEqualReal3(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:)
real, intent(in):: check(:,:,:)
logical :: err_flag
character(STRING) :: pos_str
real :: wrong, right
integer :: answer_shape(3), check_shape(3), pos(3)
logical :: consist_shape(3)
character(TOKEN) :: pos_array(3)
integer, allocatable :: mask_array(:,:,:)
logical, allocatable :: judge(:,:,:)
logical, allocatable :: judge_rev(:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3) )
right = answer ( pos(1), pos(2), pos(3) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualReal3
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:) : | character(*), intent(in) |
| check(:,:,:,:) : | character(*), intent(in) |
subroutine DCAssertEqualChar4(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
character(*), intent(in):: answer(:,:,:,:)
character(*), intent(in):: check(:,:,:,:)
logical :: err_flag
character(STRING) :: pos_str
character(STRING) :: wrong, right
integer :: answer_shape(4), check_shape(4), pos(4)
logical :: consist_shape(4)
character(TOKEN) :: pos_array(4)
integer, allocatable :: mask_array(:,:,:,:)
logical, allocatable :: judge(:,:,:,:)
logical, allocatable :: judge_rev(:,:,:,:)
character(STRING), allocatable :: answer_fixed_length(:,:,:,:)
character(STRING), allocatable :: check_fixed_length(:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( answer_fixed_length ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( check_fixed_length ( check_shape(1), check_shape(2), check_shape(3), check_shape(4) ) )
answer_fixed_length = answer
check_fixed_length = check
judge = answer_fixed_length == check_fixed_length
deallocate(answer_fixed_length, check_fixed_length)
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4) )
right = answer ( pos(1), pos(2), pos(3), pos(4) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', trim(right)
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualChar4
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:) : | integer, intent(in) |
subroutine DCAssertEqualInt4(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:,:,:)
integer, intent(in):: check(:,:,:,:)
logical :: err_flag
character(STRING) :: pos_str
integer :: wrong, right
integer :: answer_shape(4), check_shape(4), pos(4)
logical :: consist_shape(4)
character(TOKEN) :: pos_array(4)
integer, allocatable :: mask_array(:,:,:,:)
logical, allocatable :: judge(:,:,:,:)
logical, allocatable :: judge_rev(:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4) )
right = answer ( pos(1), pos(2), pos(3), pos(4) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualInt4
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:) : | logical, intent(in) |
| check(:,:,:,:) : | logical, intent(in) |
subroutine DCAssertEqualLogical4(message, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: message
logical, intent(in):: answer(:,:,:,:)
logical, intent(in):: check(:,:,:,:)
integer :: answer_shape(4), check_shape(4), i
logical, allocatable :: answer_tmp(:), check_tmp(:)
character(STRING), allocatable :: answer_str_tmp(:), check_str_tmp(:)
character(STRING), allocatable :: answer_str(:,:,:,:)
character(STRING), allocatable :: check_str(:,:,:,:)
continue
allocate(answer_tmp(size(answer)))
allocate(check_tmp(size(check)))
allocate(answer_str_tmp(size(answer)))
allocate(check_str_tmp(size(check)))
answer_tmp = pack(answer, .true.)
check_tmp = pack(check, .true.)
do i = 1, size(answer_tmp)
if (answer_tmp(i)) then
answer_str_tmp(i) = '.true.'
else
answer_str_tmp(i) = '.false.'
end if
end do
do i = 1, size(check_tmp)
if (check_tmp(i)) then
check_str_tmp(i) = '.true.'
else
check_str_tmp(i) = '.false.'
end if
end do
answer_shape = shape(answer)
check_shape = shape(check)
allocate( answer_str ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( check_str ( check_shape(1), check_shape(2), check_shape(3), check_shape(4) ) )
answer_str = reshape(answer_str_tmp, answer_shape)
check_str = reshape(check_str_tmp, check_shape)
call DCAssertEqualChar4(message, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCAssertEqualLogical4
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:) : | real(DP), intent(in) |
subroutine DCAssertEqualDouble4(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:,:)
real(DP), intent(in):: check(:,:,:,:)
logical :: err_flag
character(STRING) :: pos_str
real(DP) :: wrong, right
integer :: answer_shape(4), check_shape(4), pos(4)
logical :: consist_shape(4)
character(TOKEN) :: pos_array(4)
integer, allocatable :: mask_array(:,:,:,:)
logical, allocatable :: judge(:,:,:,:)
logical, allocatable :: judge_rev(:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4) )
right = answer ( pos(1), pos(2), pos(3), pos(4) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualDouble4
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:) : | real, intent(in) |
| check(:,:,:,:) : | real, intent(in) |
subroutine DCAssertEqualReal4(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:,:)
real, intent(in):: check(:,:,:,:)
logical :: err_flag
character(STRING) :: pos_str
real :: wrong, right
integer :: answer_shape(4), check_shape(4), pos(4)
logical :: consist_shape(4)
character(TOKEN) :: pos_array(4)
integer, allocatable :: mask_array(:,:,:,:)
logical, allocatable :: judge(:,:,:,:)
logical, allocatable :: judge_rev(:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4) )
right = answer ( pos(1), pos(2), pos(3), pos(4) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualReal4
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:) : | character(*), intent(in) |
| check(:,:,:,:,:) : | character(*), intent(in) |
subroutine DCAssertEqualChar5(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
character(*), intent(in):: answer(:,:,:,:,:)
character(*), intent(in):: check(:,:,:,:,:)
logical :: err_flag
character(STRING) :: pos_str
character(STRING) :: wrong, right
integer :: answer_shape(5), check_shape(5), pos(5)
logical :: consist_shape(5)
character(TOKEN) :: pos_array(5)
integer, allocatable :: mask_array(:,:,:,:,:)
logical, allocatable :: judge(:,:,:,:,:)
logical, allocatable :: judge_rev(:,:,:,:,:)
character(STRING), allocatable :: answer_fixed_length(:,:,:,:,:)
character(STRING), allocatable :: check_fixed_length(:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( answer_fixed_length ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( check_fixed_length ( check_shape(1), check_shape(2), check_shape(3), check_shape(4), check_shape(5) ) )
answer_fixed_length = answer
check_fixed_length = check
judge = answer_fixed_length == check_fixed_length
deallocate(answer_fixed_length, check_fixed_length)
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', trim(right)
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualChar5
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:,:) : | integer, intent(in) |
subroutine DCAssertEqualInt5(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:,:,:,:)
integer, intent(in):: check(:,:,:,:,:)
logical :: err_flag
character(STRING) :: pos_str
integer :: wrong, right
integer :: answer_shape(5), check_shape(5), pos(5)
logical :: consist_shape(5)
character(TOKEN) :: pos_array(5)
integer, allocatable :: mask_array(:,:,:,:,:)
logical, allocatable :: judge(:,:,:,:,:)
logical, allocatable :: judge_rev(:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualInt5
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:) : | logical, intent(in) |
| check(:,:,:,:,:) : | logical, intent(in) |
subroutine DCAssertEqualLogical5(message, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: message
logical, intent(in):: answer(:,:,:,:,:)
logical, intent(in):: check(:,:,:,:,:)
integer :: answer_shape(5), check_shape(5), i
logical, allocatable :: answer_tmp(:), check_tmp(:)
character(STRING), allocatable :: answer_str_tmp(:), check_str_tmp(:)
character(STRING), allocatable :: answer_str(:,:,:,:,:)
character(STRING), allocatable :: check_str(:,:,:,:,:)
continue
allocate(answer_tmp(size(answer)))
allocate(check_tmp(size(check)))
allocate(answer_str_tmp(size(answer)))
allocate(check_str_tmp(size(check)))
answer_tmp = pack(answer, .true.)
check_tmp = pack(check, .true.)
do i = 1, size(answer_tmp)
if (answer_tmp(i)) then
answer_str_tmp(i) = '.true.'
else
answer_str_tmp(i) = '.false.'
end if
end do
do i = 1, size(check_tmp)
if (check_tmp(i)) then
check_str_tmp(i) = '.true.'
else
check_str_tmp(i) = '.false.'
end if
end do
answer_shape = shape(answer)
check_shape = shape(check)
allocate( answer_str ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( check_str ( check_shape(1), check_shape(2), check_shape(3), check_shape(4), check_shape(5) ) )
answer_str = reshape(answer_str_tmp, answer_shape)
check_str = reshape(check_str_tmp, check_shape)
call DCAssertEqualChar5(message, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCAssertEqualLogical5
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:,:) : | real(DP), intent(in) |
subroutine DCAssertEqualDouble5(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:,:,:)
real(DP), intent(in):: check(:,:,:,:,:)
logical :: err_flag
character(STRING) :: pos_str
real(DP) :: wrong, right
integer :: answer_shape(5), check_shape(5), pos(5)
logical :: consist_shape(5)
character(TOKEN) :: pos_array(5)
integer, allocatable :: mask_array(:,:,:,:,:)
logical, allocatable :: judge(:,:,:,:,:)
logical, allocatable :: judge_rev(:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualDouble5
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:) : | real, intent(in) |
| check(:,:,:,:,:) : | real, intent(in) |
subroutine DCAssertEqualReal5(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:,:,:)
real, intent(in):: check(:,:,:,:,:)
logical :: err_flag
character(STRING) :: pos_str
real :: wrong, right
integer :: answer_shape(5), check_shape(5), pos(5)
logical :: consist_shape(5)
character(TOKEN) :: pos_array(5)
integer, allocatable :: mask_array(:,:,:,:,:)
logical, allocatable :: judge(:,:,:,:,:)
logical, allocatable :: judge_rev(:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualReal5
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | character(*), intent(in) |
| check(:,:,:,:,:,:) : | character(*), intent(in) |
subroutine DCAssertEqualChar6(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
character(*), intent(in):: answer(:,:,:,:,:,:)
character(*), intent(in):: check(:,:,:,:,:,:)
logical :: err_flag
character(STRING) :: pos_str
character(STRING) :: wrong, right
integer :: answer_shape(6), check_shape(6), pos(6)
logical :: consist_shape(6)
character(TOKEN) :: pos_array(6)
integer, allocatable :: mask_array(:,:,:,:,:,:)
logical, allocatable :: judge(:,:,:,:,:,:)
logical, allocatable :: judge_rev(:,:,:,:,:,:)
character(STRING), allocatable :: answer_fixed_length(:,:,:,:,:,:)
character(STRING), allocatable :: check_fixed_length(:,:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( answer_fixed_length ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( check_fixed_length ( check_shape(1), check_shape(2), check_shape(3), check_shape(4), check_shape(5), check_shape(6) ) )
answer_fixed_length = answer
check_fixed_length = check
judge = answer_fixed_length == check_fixed_length
deallocate(answer_fixed_length, check_fixed_length)
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
write(unit=pos_array(6), fmt="(i20)") pos(6)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ',' // trim(adjustl(pos_array(6))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', trim(right)
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualChar6
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:,:,:) : | integer, intent(in) |
subroutine DCAssertEqualInt6(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:,:,:,:,:)
integer, intent(in):: check(:,:,:,:,:,:)
logical :: err_flag
character(STRING) :: pos_str
integer :: wrong, right
integer :: answer_shape(6), check_shape(6), pos(6)
logical :: consist_shape(6)
character(TOKEN) :: pos_array(6)
integer, allocatable :: mask_array(:,:,:,:,:,:)
logical, allocatable :: judge(:,:,:,:,:,:)
logical, allocatable :: judge_rev(:,:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
write(unit=pos_array(6), fmt="(i20)") pos(6)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ',' // trim(adjustl(pos_array(6))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualInt6
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | logical, intent(in) |
| check(:,:,:,:,:,:) : | logical, intent(in) |
subroutine DCAssertEqualLogical6(message, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: message
logical, intent(in):: answer(:,:,:,:,:,:)
logical, intent(in):: check(:,:,:,:,:,:)
integer :: answer_shape(6), check_shape(6), i
logical, allocatable :: answer_tmp(:), check_tmp(:)
character(STRING), allocatable :: answer_str_tmp(:), check_str_tmp(:)
character(STRING), allocatable :: answer_str(:,:,:,:,:,:)
character(STRING), allocatable :: check_str(:,:,:,:,:,:)
continue
allocate(answer_tmp(size(answer)))
allocate(check_tmp(size(check)))
allocate(answer_str_tmp(size(answer)))
allocate(check_str_tmp(size(check)))
answer_tmp = pack(answer, .true.)
check_tmp = pack(check, .true.)
do i = 1, size(answer_tmp)
if (answer_tmp(i)) then
answer_str_tmp(i) = '.true.'
else
answer_str_tmp(i) = '.false.'
end if
end do
do i = 1, size(check_tmp)
if (check_tmp(i)) then
check_str_tmp(i) = '.true.'
else
check_str_tmp(i) = '.false.'
end if
end do
answer_shape = shape(answer)
check_shape = shape(check)
allocate( answer_str ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( check_str ( check_shape(1), check_shape(2), check_shape(3), check_shape(4), check_shape(5), check_shape(6) ) )
answer_str = reshape(answer_str_tmp, answer_shape)
check_str = reshape(check_str_tmp, check_shape)
call DCAssertEqualChar6(message, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCAssertEqualLogical6
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:,:,:) : | real(DP), intent(in) |
subroutine DCAssertEqualDouble6(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:,:,:,:)
real(DP), intent(in):: check(:,:,:,:,:,:)
logical :: err_flag
character(STRING) :: pos_str
real(DP) :: wrong, right
integer :: answer_shape(6), check_shape(6), pos(6)
logical :: consist_shape(6)
character(TOKEN) :: pos_array(6)
integer, allocatable :: mask_array(:,:,:,:,:,:)
logical, allocatable :: judge(:,:,:,:,:,:)
logical, allocatable :: judge_rev(:,:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
write(unit=pos_array(6), fmt="(i20)") pos(6)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ',' // trim(adjustl(pos_array(6))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualDouble6
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | real, intent(in) |
| check(:,:,:,:,:,:) : | real, intent(in) |
subroutine DCAssertEqualReal6(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:,:,:,:)
real, intent(in):: check(:,:,:,:,:,:)
logical :: err_flag
character(STRING) :: pos_str
real :: wrong, right
integer :: answer_shape(6), check_shape(6), pos(6)
logical :: consist_shape(6)
character(TOKEN) :: pos_array(6)
integer, allocatable :: mask_array(:,:,:,:,:,:)
logical, allocatable :: judge(:,:,:,:,:,:)
logical, allocatable :: judge_rev(:,:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
write(unit=pos_array(6), fmt="(i20)") pos(6)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ',' // trim(adjustl(pos_array(6))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualReal6
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | character(*), intent(in) |
| check(:,:,:,:,:,:,:) : | character(*), intent(in) |
subroutine DCAssertEqualChar7(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
character(*), intent(in):: answer(:,:,:,:,:,:,:)
character(*), intent(in):: check(:,:,:,:,:,:,:)
logical :: err_flag
character(STRING) :: pos_str
character(STRING) :: wrong, right
integer :: answer_shape(7), check_shape(7), pos(7)
logical :: consist_shape(7)
character(TOKEN) :: pos_array(7)
integer, allocatable :: mask_array(:,:,:,:,:,:,:)
logical, allocatable :: judge(:,:,:,:,:,:,:)
logical, allocatable :: judge_rev(:,:,:,:,:,:,:)
character(STRING), allocatable :: answer_fixed_length(:,:,:,:,:,:,:)
character(STRING), allocatable :: check_fixed_length(:,:,:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( answer_fixed_length ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( check_fixed_length ( check_shape(1), check_shape(2), check_shape(3), check_shape(4), check_shape(5), check_shape(6), check_shape(7) ) )
answer_fixed_length = answer
check_fixed_length = check
judge = answer_fixed_length == check_fixed_length
deallocate(answer_fixed_length, check_fixed_length)
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
write(unit=pos_array(6), fmt="(i20)") pos(6)
write(unit=pos_array(7), fmt="(i20)") pos(7)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ',' // trim(adjustl(pos_array(6))) // ',' // trim(adjustl(pos_array(7))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', trim(right)
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualChar7
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:,:,:,:) : | integer, intent(in) |
subroutine DCAssertEqualInt7(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:,:,:,:,:,:)
integer, intent(in):: check(:,:,:,:,:,:,:)
logical :: err_flag
character(STRING) :: pos_str
integer :: wrong, right
integer :: answer_shape(7), check_shape(7), pos(7)
logical :: consist_shape(7)
character(TOKEN) :: pos_array(7)
integer, allocatable :: mask_array(:,:,:,:,:,:,:)
logical, allocatable :: judge(:,:,:,:,:,:,:)
logical, allocatable :: judge_rev(:,:,:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
write(unit=pos_array(6), fmt="(i20)") pos(6)
write(unit=pos_array(7), fmt="(i20)") pos(7)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ',' // trim(adjustl(pos_array(6))) // ',' // trim(adjustl(pos_array(7))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualInt7
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | logical, intent(in) |
| check(:,:,:,:,:,:,:) : | logical, intent(in) |
subroutine DCAssertEqualLogical7(message, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: message
logical, intent(in):: answer(:,:,:,:,:,:,:)
logical, intent(in):: check(:,:,:,:,:,:,:)
integer :: answer_shape(7), check_shape(7), i
logical, allocatable :: answer_tmp(:), check_tmp(:)
character(STRING), allocatable :: answer_str_tmp(:), check_str_tmp(:)
character(STRING), allocatable :: answer_str(:,:,:,:,:,:,:)
character(STRING), allocatable :: check_str(:,:,:,:,:,:,:)
continue
allocate(answer_tmp(size(answer)))
allocate(check_tmp(size(check)))
allocate(answer_str_tmp(size(answer)))
allocate(check_str_tmp(size(check)))
answer_tmp = pack(answer, .true.)
check_tmp = pack(check, .true.)
do i = 1, size(answer_tmp)
if (answer_tmp(i)) then
answer_str_tmp(i) = '.true.'
else
answer_str_tmp(i) = '.false.'
end if
end do
do i = 1, size(check_tmp)
if (check_tmp(i)) then
check_str_tmp(i) = '.true.'
else
check_str_tmp(i) = '.false.'
end if
end do
answer_shape = shape(answer)
check_shape = shape(check)
allocate( answer_str ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( check_str ( check_shape(1), check_shape(2), check_shape(3), check_shape(4), check_shape(5), check_shape(6), check_shape(7) ) )
answer_str = reshape(answer_str_tmp, answer_shape)
check_str = reshape(check_str_tmp, check_shape)
call DCAssertEqualChar7(message, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCAssertEqualLogical7
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:,:,:,:) : | real(DP), intent(in) |
subroutine DCAssertEqualDouble7(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:,:,:,:,:)
real(DP), intent(in):: check(:,:,:,:,:,:,:)
logical :: err_flag
character(STRING) :: pos_str
real(DP) :: wrong, right
integer :: answer_shape(7), check_shape(7), pos(7)
logical :: consist_shape(7)
character(TOKEN) :: pos_array(7)
integer, allocatable :: mask_array(:,:,:,:,:,:,:)
logical, allocatable :: judge(:,:,:,:,:,:,:)
logical, allocatable :: judge_rev(:,:,:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
write(unit=pos_array(6), fmt="(i20)") pos(6)
write(unit=pos_array(7), fmt="(i20)") pos(7)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ',' // trim(adjustl(pos_array(6))) // ',' // trim(adjustl(pos_array(7))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualDouble7
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | real, intent(in) |
| check(:,:,:,:,:,:,:) : | real, intent(in) |
subroutine DCAssertEqualReal7(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:,:,:,:,:)
real, intent(in):: check(:,:,:,:,:,:,:)
logical :: err_flag
character(STRING) :: pos_str
real :: wrong, right
integer :: answer_shape(7), check_shape(7), pos(7)
logical :: consist_shape(7)
character(TOKEN) :: pos_array(7)
integer, allocatable :: mask_array(:,:,:,:,:,:,:)
logical, allocatable :: judge(:,:,:,:,:,:,:)
logical, allocatable :: judge_rev(:,:,:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
write(unit=pos_array(6), fmt="(i20)") pos(6)
write(unit=pos_array(7), fmt="(i20)") pos(7)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ',' // trim(adjustl(pos_array(6))) // ',' // trim(adjustl(pos_array(7))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [DCAssertEqual] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is INCORRECT'
write(*,*) ' Correct answer is answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [DCAssertEqual] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCAssertEqualReal7