| Class | dc_test |
| In: |
dc_test.f90
|
Fortran 90/95 におけるテストプログラム作成を補助するための モジュールです.
| Verify : | 正答とチェックすべき値とを照合する. |
Verify サブルーチンは以下のように用います. answer に正答を与え, check に照合すべき値を与えます. answer と check には全ての組み込み型の変数および 配列 (1 〜 7次元) を与えることができますが, 2 つの引数の型および次元数は一致している必要があります.
call Verify('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 Verify('Character', answer='foo', check=str1)
int1 = 1
call Verify('Integer', answer=1, check=int1)
numr1(:) = (/0.00123, 0.2/)
call Verify('Float', answer=(/0.00123, 0.2/), check=numr1)
y_n = .true.
call Verify('Logical', answer=.true., check=y_n)
numd1(1,:) = (/19.432d0, 75.3d0, 3.183d0/)
numd1(2,:) = (/0.023d0, 0.9d0, 328.2d0/)
call Verify('Double precision 1', &
& answer=(/19.432d0, 75.3d0, 3.183d0/), check=numd1(1,:))
call Verify('Double precision 2', &
& answer=(/0.023d0, 0.9d0, 238.5d0/), check=numd1(2,:))
end
上記の例では, 最後のテストで敢えて間違った answer を与えているので, 以下のようなメッセージを出力してプログラムは強制終了します.
*** MESSAGE [DCVerify] *** Checking Character OK
*** MESSAGE [DCVerify] *** Checking Integer OK
*** MESSAGE [DCVerify] *** Checking Float OK
*** MESSAGE [DCVerify] *** Checking Logical OK
*** MESSAGE [DCVerify] *** Checking Double precision 1 OK
*** Error [DCVerify] *** 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 DCVerifyChar0(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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyChar0
| Subroutine : | |
| item : | character(*), intent(in) |
| answer : | integer, intent(in) |
| check : | integer, intent(in) |
subroutine DCVerifyInt0(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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyInt0
| Subroutine : | |
| item : | character(*), intent(in) |
| answer : | logical, intent(in) |
| check : | logical, intent(in) |
subroutine DCVerifyLogical0(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 DCVerifyChar0(item, answer_str, check_str)
end subroutine DCVerifyLogical0
| Subroutine : | |
| item : | character(*), intent(in) |
| answer : | real(DP), intent(in) |
| check : | real(DP), intent(in) |
subroutine DCVerifyDouble0(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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyDouble0
| Subroutine : | |
| item : | character(*), intent(in) |
| answer : | real, intent(in) |
| check : | real, intent(in) |
subroutine DCVerifyReal0(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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyReal0
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:) : | character(*), intent(in) |
| check(:) : | character(*), intent(in) |
subroutine DCVerifyChar1(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyChar1
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:) : | integer, intent(in) |
| check(:) : | integer, intent(in) |
subroutine DCVerifyInt1(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyInt1
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:) : | logical, intent(in) |
| check(:) : | logical, intent(in) |
subroutine DCVerifyLogical1(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 DCVerifyChar1(item, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCVerifyLogical1
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:) : | real(DP), intent(in) |
| check(:) : | real(DP), intent(in) |
subroutine DCVerifyDouble1(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyDouble1
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:) : | real, intent(in) |
| check(:) : | real, intent(in) |
subroutine DCVerifyReal1(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyReal1
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:) : | character(*), intent(in) |
| check(:,:) : | character(*), intent(in) |
subroutine DCVerifyChar2(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyChar2
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:) : | integer, intent(in) |
| check(:,:) : | integer, intent(in) |
subroutine DCVerifyInt2(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyInt2
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:) : | logical, intent(in) |
| check(:,:) : | logical, intent(in) |
subroutine DCVerifyLogical2(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 DCVerifyChar2(item, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCVerifyLogical2
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:) : | real(DP), intent(in) |
| check(:,:) : | real(DP), intent(in) |
subroutine DCVerifyDouble2(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyDouble2
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:) : | real, intent(in) |
| check(:,:) : | real, intent(in) |
subroutine DCVerifyReal2(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyReal2
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:) : | character(*), intent(in) |
| check(:,:,:) : | character(*), intent(in) |
subroutine DCVerifyChar3(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyChar3
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:) : | integer, intent(in) |
| check(:,:,:) : | integer, intent(in) |
subroutine DCVerifyInt3(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyInt3
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:) : | logical, intent(in) |
| check(:,:,:) : | logical, intent(in) |
subroutine DCVerifyLogical3(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 DCVerifyChar3(item, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCVerifyLogical3
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:) : | real(DP), intent(in) |
| check(:,:,:) : | real(DP), intent(in) |
subroutine DCVerifyDouble3(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyDouble3
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:) : | real, intent(in) |
| check(:,:,:) : | real, intent(in) |
subroutine DCVerifyReal3(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyReal3
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:) : | character(*), intent(in) |
| check(:,:,:,:) : | character(*), intent(in) |
subroutine DCVerifyChar4(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyChar4
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:) : | integer, intent(in) |
subroutine DCVerifyInt4(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyInt4
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:) : | logical, intent(in) |
| check(:,:,:,:) : | logical, intent(in) |
subroutine DCVerifyLogical4(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 DCVerifyChar4(item, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCVerifyLogical4
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:) : | real(DP), intent(in) |
subroutine DCVerifyDouble4(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyDouble4
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:) : | real, intent(in) |
| check(:,:,:,:) : | real, intent(in) |
subroutine DCVerifyReal4(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyReal4
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:) : | character(*), intent(in) |
| check(:,:,:,:,:) : | character(*), intent(in) |
subroutine DCVerifyChar5(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyChar5
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:,:) : | integer, intent(in) |
subroutine DCVerifyInt5(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyInt5
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:) : | logical, intent(in) |
| check(:,:,:,:,:) : | logical, intent(in) |
subroutine DCVerifyLogical5(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 DCVerifyChar5(item, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCVerifyLogical5
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:,:) : | real(DP), intent(in) |
subroutine DCVerifyDouble5(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyDouble5
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:) : | real, intent(in) |
| check(:,:,:,:,:) : | real, intent(in) |
subroutine DCVerifyReal5(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyReal5
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | character(*), intent(in) |
| check(:,:,:,:,:,:) : | character(*), intent(in) |
subroutine DCVerifyChar6(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyChar6
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:,:,:) : | integer, intent(in) |
subroutine DCVerifyInt6(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyInt6
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | logical, intent(in) |
| check(:,:,:,:,:,:) : | logical, intent(in) |
subroutine DCVerifyLogical6(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 DCVerifyChar6(item, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCVerifyLogical6
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:,:,:) : | real(DP), intent(in) |
subroutine DCVerifyDouble6(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyDouble6
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | real, intent(in) |
| check(:,:,:,:,:,:) : | real, intent(in) |
subroutine DCVerifyReal6(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyReal6
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | character(*), intent(in) |
| check(:,:,:,:,:,:,:) : | character(*), intent(in) |
subroutine DCVerifyChar7(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyChar7
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:,:,:,:) : | integer, intent(in) |
subroutine DCVerifyInt7(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyInt7
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | logical, intent(in) |
| check(:,:,:,:,:,:,:) : | logical, intent(in) |
subroutine DCVerifyLogical7(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 DCVerifyChar7(item, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCVerifyLogical7
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:,:,:,:) : | real(DP), intent(in) |
subroutine DCVerifyDouble7(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyDouble7
| Subroutine : | |
| item : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | real, intent(in) |
| check(:,:,:,:,:,:,:) : | real, intent(in) |
subroutine DCVerifyReal7(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 [DCVerify] *** 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 [DCVerify] *** 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 [DCVerify] *** Checking ' // trim(item) // ' OK'
end if
end subroutine DCVerifyReal7