| Class | dc_test |
| In: |
dc_test.f90
|
Fortran 90/95 におけるテストプログラム作成を補助するための モジュールです.
| Compare : | 正答とチェックすべき値とを照合する. |
Compare サブルーチンは以下のように用います. answer に正答を与え, check に照合すべき値を与えます. answer と check には文字型, 整数型, 単精度実数型, 倍精度実数型, 論理型の変数および 配列 (1 〜 7次元) を与えることができます. 2 つの引数の型および次元数は一致している必要があります.
call Compare('Title', answer='foo', check=str1)
もしも answer と check の値, もしくは配列のサイズが異なる場合, テストプログラムはエラーを返して終了します.
具体例は以下の通りです.
use dc_types
use dc_test
character(STRING):: str1
integer:: int1
real:: numr1(2)
real(DP):: numd1(2,3)
logical:: y_n
str1 = "foo"
call Compare('Character', answer='foo', check=str1)
int1 = 1
call Compare('Integer', answer=1, check=int1)
numr1(:) = (/0.00123, 0.2/)
call Compare('Float', answer=(/0.00123, 0.2/), check=numr1)
y_n = .true.
call Compare('Logical', answer=.true., check=y_n)
numd1(1,:) = (/19.432d0, 75.3d0, 3.183d0/)
numd1(2,:) = (/0.023d0, 0.9d0, 328.2d0/)
call Compare('Double precision 1', &
& answer=(/19.432d0, 75.3d0, 3.183d0/), check=numd1(1,:))
call Compare('Double precision 2', &
& answer=(/0.023d0, 0.9d0, 238.5d0/), check=numd1(2,:))
end
上記の例では, 最後のテストで敢えて間違った answer を与えているので, 以下のようなメッセージを出力してプログラムは強制終了します.
*** MESSAGE [DCCompare] *** Checking Character OK
*** MESSAGE [DCCompare] *** Checking Integer OK
*** MESSAGE [DCCompare] *** Checking Float OK
*** MESSAGE [DCCompare] *** Checking Logical OK
*** MESSAGE [DCCompare] *** Checking Double precision 1 OK
*** Error [DCCompare] *** Checking Double precision 2 FAILURE
check(3) = 328.2
is INCORRECT
Correct answer is answer(3) = 238.5
| Subroutine : | |
| item : | character(*), intent(in) |
| answer : | character(*), intent(in) |
| check : | character(*), intent(in) |
subroutine DCCompareChar0(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareChar0
| Subroutine : | |
| item : | character(*), intent(in) |
| answer : | integer, intent(in) |
| check : | integer, intent(in) |
subroutine DCCompareInt0(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareInt0
| Subroutine : | |
| item : | character(*), intent(in) |
| answer : | logical, intent(in) |
| check : | logical, intent(in) |
subroutine DCCompareLogical0(item, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: item
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 DCCompareChar0(item, answer_str, check_str)
end subroutine DCCompareLogical0
| Subroutine : | |
| item : | character(*), intent(in) |
| answer : | real(DP), intent(in) |
| check : | real(DP), intent(in) |
subroutine DCCompareDouble0(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareDouble0
| Subroutine : | |
| item : | character(*), intent(in) |
| answer : | real, intent(in) |
| check : | real, intent(in) |
subroutine DCCompareReal0(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareReal0
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:) : | character(*), intent(in) |
| check(:) : | character(*), intent(in) |
subroutine DCCompareChar1(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareChar1
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:) : | integer, intent(in) |
| check(:) : | integer, intent(in) |
subroutine DCCompareInt1(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareInt1
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:) : | logical, intent(in) |
| check(:) : | logical, intent(in) |
subroutine DCCompareLogical1(item, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: item
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 DCCompareChar1(item, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCCompareLogical1
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:) : | real(DP), intent(in) |
| check(:) : | real(DP), intent(in) |
subroutine DCCompareDouble1(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareDouble1
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:) : | real, intent(in) |
| check(:) : | real, intent(in) |
subroutine DCCompareReal1(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareReal1
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:) : | character(*), intent(in) |
| check(:,:) : | character(*), intent(in) |
subroutine DCCompareChar2(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareChar2
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:) : | integer, intent(in) |
| check(:,:) : | integer, intent(in) |
subroutine DCCompareInt2(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareInt2
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:) : | logical, intent(in) |
| check(:,:) : | logical, intent(in) |
subroutine DCCompareLogical2(item, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: item
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 DCCompareChar2(item, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCCompareLogical2
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:) : | real(DP), intent(in) |
| check(:,:) : | real(DP), intent(in) |
subroutine DCCompareDouble2(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareDouble2
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:) : | real, intent(in) |
| check(:,:) : | real, intent(in) |
subroutine DCCompareReal2(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareReal2
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:) : | character(*), intent(in) |
| check(:,:,:) : | character(*), intent(in) |
subroutine DCCompareChar3(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareChar3
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:) : | integer, intent(in) |
| check(:,:,:) : | integer, intent(in) |
subroutine DCCompareInt3(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareInt3
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:) : | logical, intent(in) |
| check(:,:,:) : | logical, intent(in) |
subroutine DCCompareLogical3(item, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: item
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 DCCompareChar3(item, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCCompareLogical3
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:) : | real(DP), intent(in) |
| check(:,:,:) : | real(DP), intent(in) |
subroutine DCCompareDouble3(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareDouble3
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:) : | real, intent(in) |
| check(:,:,:) : | real, intent(in) |
subroutine DCCompareReal3(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareReal3
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:) : | character(*), intent(in) |
| check(:,:,:,:) : | character(*), intent(in) |
subroutine DCCompareChar4(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareChar4
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:) : | integer, intent(in) |
subroutine DCCompareInt4(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareInt4
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:) : | logical, intent(in) |
| check(:,:,:,:) : | logical, intent(in) |
subroutine DCCompareLogical4(item, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: item
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 DCCompareChar4(item, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCCompareLogical4
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:) : | real(DP), intent(in) |
subroutine DCCompareDouble4(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareDouble4
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:) : | real, intent(in) |
| check(:,:,:,:) : | real, intent(in) |
subroutine DCCompareReal4(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareReal4
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:) : | character(*), intent(in) |
| check(:,:,:,:,:) : | character(*), intent(in) |
subroutine DCCompareChar5(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareChar5
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:,:) : | integer, intent(in) |
subroutine DCCompareInt5(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareInt5
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:) : | logical, intent(in) |
| check(:,:,:,:,:) : | logical, intent(in) |
subroutine DCCompareLogical5(item, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: item
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 DCCompareChar5(item, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCCompareLogical5
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:,:) : | real(DP), intent(in) |
subroutine DCCompareDouble5(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareDouble5
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:) : | real, intent(in) |
| check(:,:,:,:,:) : | real, intent(in) |
subroutine DCCompareReal5(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareReal5
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | character(*), intent(in) |
| check(:,:,:,:,:,:) : | character(*), intent(in) |
subroutine DCCompareChar6(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareChar6
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:,:,:) : | integer, intent(in) |
subroutine DCCompareInt6(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareInt6
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | logical, intent(in) |
| check(:,:,:,:,:,:) : | logical, intent(in) |
subroutine DCCompareLogical6(item, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: item
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 DCCompareChar6(item, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCCompareLogical6
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:,:,:) : | real(DP), intent(in) |
subroutine DCCompareDouble6(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareDouble6
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | real, intent(in) |
| check(:,:,:,:,:,:) : | real, intent(in) |
subroutine DCCompareReal6(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareReal6
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | character(*), intent(in) |
| check(:,:,:,:,:,:,:) : | character(*), intent(in) |
subroutine DCCompareChar7(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareChar7
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:,:,:,:) : | integer, intent(in) |
subroutine DCCompareInt7(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareInt7
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | logical, intent(in) |
| check(:,:,:,:,:,:,:) : | logical, intent(in) |
subroutine DCCompareLogical7(item, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: item
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 DCCompareChar7(item, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCCompareLogical7
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:,:,:,:) : | real(DP), intent(in) |
subroutine DCCompareDouble7(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareDouble7
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | real, intent(in) |
| check(:,:,:,:,:,:,:) : | real, intent(in) |
subroutine DCCompareReal7(item, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: item
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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' 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 [DCCompare] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCCompareReal7