| 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', 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', answer='foo', check=str1)
int1 = 1
call AssertEqual('Integer', answer=1, check=int1)
numr1(:) = (/0.00123, 0.2/)
call AssertEqual('Float', answer=(/0.00123, 0.2/), check=numr1)
y_n = .true.
call AssertEqual('Logical', 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 1', &
& answer=(/19.432d0, 75.3d0, 3.183d0/), check=numd1(1,:))
call AssertEqual('Double precision 2', &
& answer=(/0.023d0, 0.9d0, 238.5d0/), check=numd1(2,:))
end program test_sample
上記の例では, 最後のテストで敢えて間違った answer を与えているので, 以下のようなメッセージを出力してプログラムは強制終了します.
*** MESSAGE [DCAssertEqual] *** Checking Character OK
*** MESSAGE [DCAssertEqual] *** Checking Integer OK
*** MESSAGE [DCAssertEqual] *** Checking Float OK
*** MESSAGE [DCAssertEqual] *** Checking Logical OK
*** MESSAGE [DCAssertEqual] *** Checking Double precision 1 OK
*** Error [DCAssertEqual] *** Checking Double precision 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