| Class | dc_test |
| In: |
dc_test.f90
|
Note that Japanese and English are described in parallel.
Fortran 90/95 におけるテストプログラム作成を補助するための モジュールです.
オブジェクト指向スクリプト言語 Ruby の Test::Unit クラス の機能の一部を模倣しています.
This module supports making Fortran 90/95 test programs.
A part of Test::Unit class in Object-oriented programming language Ruby is imitated.
| AssertEqual : | 正答とチェックすべき値が等しいことをチェックする. |
| AssertGreaterThan : | ある値よりもチェックすべき値が大きいことをチェックする. |
| AssertLessThan : | ある値よりもチェックすべき値が小さいことをチェックする. |
| ———— : | ———— |
| AssertEqual : | It is verified that a examined value is equal to a right answer. |
| AssertGreaterThan : | It is verified that examined value is greater than a certain value. |
| AssertLessThan : | It is verified that examined value is less than a certain value. |
AssertEqual サブルーチンの使用例として, 以下に簡単な テストプログラムを記します. message にはテストプログラムを実行した際に表示する 任意の長さの文字列を与えます. そして, answer には正答を, check には照合すべき値を与えます. answer と check にはそれぞれ文字型, 整数型, 単精度実数型, 倍精度実数型, 論理型の変数および 配列 (1 〜 7次元) を与えることができます. 2 つの引数の型および次元数は一致している必要があります.
A simple test program is showed as an example of how "AssertEqual" subroutine is used as follows. Give arbitrary length string to message. This string is displayed when the test program is execute. And give the right answer to answer, examined value to check. Character, integer, simple precision real, double precision real, logical variables and arrays (rank 1 - 7) are allowed to give to answer and check. The types of answer and check must be same.
program test
use dc_test, only: AssertEqual
implicit none
character(32):: str1
real:: r1(2)
str1 = 'foo'
r1 = (/ 1.0, 2.0 /)
call AssertEqual(message='String test', answer='foo', check=str1)
call AssertEqual(message='Float test', &
& answer=(/1.0, 2.0/), check=r1)
end program test
check と answer との値, および配列のサイズが一致する場合に テストプログラムは「Checking <message に与えられた文字> OK」 というメッセージを表示します. プログラムは続行します. AssertEqual の代わりに AssertGreaterThan を使用する場合には check が answer よりも大きい場合, AssertLessThan を使用する場合には check が answer よりも小さい場合に プログラムは続行します.
一方で answer と check の値, もしくは配列のサイズが異なる場合には, テストプログラムは「Checking <message に与えられた文字> FAILURE」 というメッセージを表示します. プログラムはエラーを発生させて終了します. AssertEqual の代わりに AssertGreaterThan を使用する場合には check が answer よりも大きくない場合, AssertLessThan を使用する場合には check が answer よりも 小さくない場合にプログラムは終了します.
When the values and array sizes of check and answer are same, the test program displays a message "Checking <string given to message> OK", and the program continues. Using "AssertGreaterThan" instead of "AssertEqual", the program continues when check is greater than answer. Using "AssertLessThan", the program continues when check is less than answer.
On the other hand, when the values or array sizes of check and answer are different, the test program displays a message "Checking <string given to message> FAILURE", and the program aborts. Using "AssertGreaterThan" instead of "AssertEqual", the program aborts when check is not greater than answer. Using "AssertLessThan", the program aborts when check is not less than answer.
単精度実数型, 倍精度実数型同士の比較において, 丸め誤差や情報落ち誤差を考慮したい場合には, 引数 significant_digits, ignore_digits に整数型を与えてください. significant_digits には有効数字の桁数を, ignore_digits には 無視するオーダーを与えます. 以下の例では, 有効数字の桁数を 7 とし, 1.0e-6 以下の数値を無視して値の比較を行っています.
About comparison of single precision reals or double precision reals, in order to consider rounding errors and information loss errors, specify integer to significant_digits, ignore_digits arguments. Specify significant digits to significant_digits, and negligible order to ignore_digits. In the following example, significant digits is 7, and numerical value less than 1.0e-6 is ignored.
program test2
use dc_test, only: AssertEqual
implicit none
real:: numd1(2,3)
numd1 = reshape((/-19.432, 75.3, 3.183, &
& 0.023, -0.9, 328.2/), &
& (/2,3/))
call AssertEqual( 'Float (single precision) test', &
& answer = numd1, &
& check = ( numd1 / 3.0 ) * 3.0, &
& significant_digits = 7, ignore_digits = -6 )
end program test2
比較される answer の値と check の値が両方とも負の場合, AssertGreaterThan および AssertLessThan は 2 つの値の絶対値の 比較を行います. エラーメッセージは以下のようになります. オプショナル引数 negative_support に .false. を与える場合, 絶対値での比較を行いません.
"AssertGreaterThan" and "AssertLessThan" compare absolute values of answer and check when both compared two values are negative. In this case, error message is as follows. When an optional argument negative_support is .false., the comparison with absolute values is not done.
ABSOLUTE value of check(14,1) = -1.189774221E-09
is NOT LESS THAN
ABSOLUTE value of answer(14,1) = -1.189774405E-09
使用例は以下の通りです.
Example of use is showed as follows.
program test_sample
use dc_types, only: STRING, DP
use dc_test, only: AssertEqual, AssertGreaterThan, AssertLessThan
implicit none
character(STRING):: str1, str2
real:: r1(2)
integer:: int1
real:: numr1(2)
real(DP):: numd1(2,3), numd2(2,3)
logical:: y_n
continue
str1 = 'foo'
r1 = (/ 1.0_DP, 2.0_DP /)
call AssertEqual( message = 'String test', answer = 'foo', check = str1 )
call AssertEqual( message = 'Float test', &
& answer = (/1.0e0, 2.0e0/), check = r1 )
str2 = "foo"
call AssertEqual( 'Character test', answer = 'foo', check = str2 )
int1 = 1
call AssertEqual( 'Integer test', answer = 1, check = int1 )
numr1(:) = (/ 0.001235423, 0.248271 /)
call AssertGreaterThan( 'Float test 1', &
& answer = (/ 0.00061771142, 0.1241354 /), check = numr1 / 2.0 )
call AssertLessThan( 'Float test 2', &
& answer = (/ 0.00061771158, 0.1241358 /), check = numr1 / 2.0 )
y_n = .true.
call AssertEqual( 'Logical test', answer = .true., check = y_n )
numd1 = reshape( (/ -19.432_DP, 75.3_DP, 3.183_DP, &
& 0.023_DP, -0.9_DP, 328.2_DP /), &
& (/ 2,3 /) )
call AssertGreaterThan( 'Double precision test 1', &
& answer = reshape( (/ -38.8639_DP, 150.5999_DP, 6.365999_DP, &
& 0.0459999_DP, -1.7999_DP, 656.3999_DP /), &
& (/ 2,3 /) ), &
& check = numd1*2.0_DP )
call AssertLessThan( 'Double precision test 2', &
& answer = reshape( (/ -38.86401_DP, 150.60001_DP, 6.3660001_DP, &
& 0.04600001_DP, -1.8000001_DP, 656.6_DP /), &
& (/ 2,3 /) ), &
& check = numd1*2.0_DP, negative_support=.true. )
call AssertEqual( 'Double precision test 3', &
& answer = numd1, &
& check = ( numd1 / 3.0_DP ) * 3.0_DP, &
& significant_digits = 10, ignore_digits = -10 )
numd2 = reshape( (/ 19.4e+7_DP, 75.3_DP, 3.18e-7_DP, &
& 0.023e-7_DP, 0.9e+7_DP, 328.2_DP /), &
& (/ 2,3 /) )
call AssertEqual( 'Double precision test 4', &
& answer = numd2, &
& check = ( ( ( numd2 + 0.008_DP - 0.008_DP ) / 1.5_DP ) * 3.0_DP ) / 2.0_DP, &
& significant_digits = 10, ignore_digits = -15 )
call AssertEqual( 'Double precision test 5', &
& answer = numd2, &
& check = ( ( ( numd2 + 0.008_DP - 0.008_DP ) / 1.5_DP ) * 3.0_DP ) / 2.0_DP, &
& significant_digits = 15, ignore_digits = -19 )
end program test_sample
上記の例では, 最後のテストで敢えて小さすぎる値を無視するオーダー として設定しているため, 以下のようなメッセージを出力して プログラムは強制終了します.
In above example, too small negligible order is specified on purpose in the last test. Then the program displays a following message, and aborts.
*** MESSAGE [AssertEQ] *** Checking String test OK
*** MESSAGE [AssertEQ] *** Checking Float test OK
*** MESSAGE [AssertEQ] *** Checking Character test OK
*** MESSAGE [AssertEQ] *** Checking Integer test OK
*** MESSAGE [AssertGT] *** Checking Float test 1 OK
*** MESSAGE [AssertLT] *** Checking Float test 2 OK
*** MESSAGE [AssertEQ] *** Checking Logical test OK
*** MESSAGE [AssertGT] *** Checking Double precision test 1 OK
*** MESSAGE [AssertLT] *** Checking Double precision test 2 OK
*** MESSAGE [AssertEQ] *** Checking Double precision test 3 OK
*** MESSAGE [AssertEQ] *** Checking Double precision test 4 OK
*** Error [AssertEQ] *** Checking Double precision test 5 FAILURE
check(1,2) = 3.179999999991523E-07
is NOT EQUAL to
3.179999999998997E-07 <
answer(1,2) < 3.180000000001004E-07
| Subroutine : | |
| message : | character(*), intent(in) |
| answer : | character(*), intent(in) |
| check : | character(*), intent(in) |
subroutine DCTestAssertEqualChar0(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
character(*), intent(in):: answer
character(*), intent(in):: check
logical:: err_flag
character(STRING):: pos_str
character(STRING):: wrong, right
continue
err_flag = .false.
err_flag = .not. trim(answer) == trim(check)
wrong = check
right = answer
pos_str = ''
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualChar0
| Subroutine : | |
| message : | character(*), intent(in) |
| answer : | integer, intent(in) |
| check : | integer, intent(in) |
subroutine DCTestAssertEqualInt0(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer
integer, intent(in):: check
logical:: err_flag
character(STRING):: pos_str
integer:: wrong, right
continue
err_flag = .false.
err_flag = .not. answer == check
wrong = check
right = answer
pos_str = ''
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualInt0
| Subroutine : | |
| message : | character(*), intent(in) |
| answer : | logical, intent(in) |
| check : | logical, intent(in) |
subroutine DCTestAssertEqualLogical0(message, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: message
logical, intent(in):: answer
logical, intent(in):: check
character(STRING):: answer_str
character(STRING):: check_str
continue
if (answer) then
answer_str = ".true."
else
answer_str = ".false."
end if
if (check) then
check_str = ".true."
else
check_str = ".false."
end if
call DCTestAssertEqualChar0(message, answer_str, check_str)
end subroutine DCTestAssertEqualLogical0
| Subroutine : | |
| message : | character(*), intent(in) |
| answer : | real(DP), intent(in) |
| check : | real(DP), intent(in) |
subroutine DCTestAssertEqualDouble0(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer
real(DP), intent(in):: check
logical:: err_flag
character(STRING):: pos_str
real(DP):: wrong, right
continue
err_flag = .false.
err_flag = .not. answer == check
wrong = check
right = answer
pos_str = ''
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualDouble0
| Subroutine : | |
| message : | character(*), intent(in) |
| answer : | real, intent(in) |
| check : | real, intent(in) |
subroutine DCTestAssertEqualReal0(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer
real, intent(in):: check
logical:: err_flag
character(STRING):: pos_str
real:: wrong, right
continue
err_flag = .false.
err_flag = .not. answer == check
wrong = check
right = answer
pos_str = ''
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualReal0
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:) : | character(*), intent(in) |
| check(:) : | character(*), intent(in) |
subroutine DCTestAssertEqualChar1(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
character(*), intent(in):: answer(:)
character(*), intent(in):: check(:)
logical:: err_flag
character(STRING):: pos_str
character(STRING):: wrong, right
integer:: answer_shape(1), check_shape(1), pos(1)
logical:: consist_shape(1)
character(TOKEN):: pos_array(1)
integer, allocatable:: mask_array(:)
logical, allocatable:: judge(:)
logical, allocatable:: judge_rev(:)
character(STRING), allocatable:: answer_fixed_length(:)
character(STRING), allocatable:: check_fixed_length(:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1) ) )
allocate( judge ( answer_shape(1) ) )
allocate( judge_rev ( answer_shape(1) ) )
allocate( answer_fixed_length ( answer_shape(1) ) )
allocate( check_fixed_length ( check_shape(1) ) )
answer_fixed_length = answer
check_fixed_length = check
judge = answer_fixed_length == check_fixed_length
deallocate(answer_fixed_length, check_fixed_length)
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1) )
right = answer ( pos(1) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
pos_str = '(' // trim(adjustl(pos_array(1))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualChar1
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:) : | integer, intent(in) |
| check(:) : | integer, intent(in) |
subroutine DCTestAssertEqualInt1(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:)
integer, intent(in):: check(:)
logical:: err_flag
character(STRING):: pos_str
integer:: wrong, right
integer:: answer_shape(1), check_shape(1), pos(1)
logical:: consist_shape(1)
character(TOKEN):: pos_array(1)
integer, allocatable:: mask_array(:)
logical, allocatable:: judge(:)
logical, allocatable:: judge_rev(:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1) ) )
allocate( judge ( answer_shape(1) ) )
allocate( judge_rev ( answer_shape(1) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1) )
right = answer ( pos(1) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
pos_str = '(' // trim(adjustl(pos_array(1))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualInt1
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:) : | logical, intent(in) |
| check(:) : | logical, intent(in) |
subroutine DCTestAssertEqualLogical1(message, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: message
logical, intent(in):: answer(:)
logical, intent(in):: check(:)
integer:: answer_shape(1), check_shape(1), i
logical, allocatable:: answer_tmp(:), check_tmp(:)
character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
character(STRING), allocatable:: answer_str(:)
character(STRING), allocatable:: check_str(:)
continue
allocate(answer_tmp(size(answer)))
allocate(check_tmp(size(check)))
allocate(answer_str_tmp(size(answer)))
allocate(check_str_tmp(size(check)))
answer_tmp = pack(answer, .true.)
check_tmp = pack(check, .true.)
do i = 1, size(answer_tmp)
if (answer_tmp(i)) then
answer_str_tmp(i) = '.true.'
else
answer_str_tmp(i) = '.false.'
end if
end do
do i = 1, size(check_tmp)
if (check_tmp(i)) then
check_str_tmp(i) = '.true.'
else
check_str_tmp(i) = '.false.'
end if
end do
answer_shape = shape(answer)
check_shape = shape(check)
allocate( answer_str ( answer_shape(1) ) )
allocate( check_str ( check_shape(1) ) )
answer_str = reshape(answer_str_tmp, answer_shape)
check_str = reshape(check_str_tmp, check_shape)
call DCTestAssertEqualChar1(message, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCTestAssertEqualLogical1
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:) : | real(DP), intent(in) |
| check(:) : | real(DP), intent(in) |
subroutine DCTestAssertEqualDouble1(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:)
real(DP), intent(in):: check(:)
logical:: err_flag
character(STRING):: pos_str
real(DP):: wrong, right
integer:: answer_shape(1), check_shape(1), pos(1)
logical:: consist_shape(1)
character(TOKEN):: pos_array(1)
integer, allocatable:: mask_array(:)
logical, allocatable:: judge(:)
logical, allocatable:: judge_rev(:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1) ) )
allocate( judge ( answer_shape(1) ) )
allocate( judge_rev ( answer_shape(1) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1) )
right = answer ( pos(1) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
pos_str = '(' // trim(adjustl(pos_array(1))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualDouble1
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:) : | real, intent(in) |
| check(:) : | real, intent(in) |
subroutine DCTestAssertEqualReal1(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:)
real, intent(in):: check(:)
logical:: err_flag
character(STRING):: pos_str
real:: wrong, right
integer:: answer_shape(1), check_shape(1), pos(1)
logical:: consist_shape(1)
character(TOKEN):: pos_array(1)
integer, allocatable:: mask_array(:)
logical, allocatable:: judge(:)
logical, allocatable:: judge_rev(:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1) ) )
allocate( judge ( answer_shape(1) ) )
allocate( judge_rev ( answer_shape(1) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1) )
right = answer ( pos(1) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
pos_str = '(' // trim(adjustl(pos_array(1))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualReal1
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:) : | character(*), intent(in) |
| check(:,:) : | character(*), intent(in) |
subroutine DCTestAssertEqualChar2(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
character(*), intent(in):: answer(:,:)
character(*), intent(in):: check(:,:)
logical:: err_flag
character(STRING):: pos_str
character(STRING):: wrong, right
integer:: answer_shape(2), check_shape(2), pos(2)
logical:: consist_shape(2)
character(TOKEN):: pos_array(2)
integer, allocatable:: mask_array(:,:)
logical, allocatable:: judge(:,:)
logical, allocatable:: judge_rev(:,:)
character(STRING), allocatable:: answer_fixed_length(:,:)
character(STRING), allocatable:: check_fixed_length(:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2) ) )
allocate( judge ( answer_shape(1), answer_shape(2) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2) ) )
allocate( answer_fixed_length ( answer_shape(1), answer_shape(2) ) )
allocate( check_fixed_length ( check_shape(1), check_shape(2) ) )
answer_fixed_length = answer
check_fixed_length = check
judge = answer_fixed_length == check_fixed_length
deallocate(answer_fixed_length, check_fixed_length)
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2) )
right = answer ( pos(1), pos(2) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualChar2
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:) : | integer, intent(in) |
| check(:,:) : | integer, intent(in) |
subroutine DCTestAssertEqualInt2(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:)
integer, intent(in):: check(:,:)
logical:: err_flag
character(STRING):: pos_str
integer:: wrong, right
integer:: answer_shape(2), check_shape(2), pos(2)
logical:: consist_shape(2)
character(TOKEN):: pos_array(2)
integer, allocatable:: mask_array(:,:)
logical, allocatable:: judge(:,:)
logical, allocatable:: judge_rev(:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2) ) )
allocate( judge ( answer_shape(1), answer_shape(2) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2) )
right = answer ( pos(1), pos(2) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualInt2
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:) : | logical, intent(in) |
| check(:,:) : | logical, intent(in) |
subroutine DCTestAssertEqualLogical2(message, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: message
logical, intent(in):: answer(:,:)
logical, intent(in):: check(:,:)
integer:: answer_shape(2), check_shape(2), i
logical, allocatable:: answer_tmp(:), check_tmp(:)
character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
character(STRING), allocatable:: answer_str(:,:)
character(STRING), allocatable:: check_str(:,:)
continue
allocate(answer_tmp(size(answer)))
allocate(check_tmp(size(check)))
allocate(answer_str_tmp(size(answer)))
allocate(check_str_tmp(size(check)))
answer_tmp = pack(answer, .true.)
check_tmp = pack(check, .true.)
do i = 1, size(answer_tmp)
if (answer_tmp(i)) then
answer_str_tmp(i) = '.true.'
else
answer_str_tmp(i) = '.false.'
end if
end do
do i = 1, size(check_tmp)
if (check_tmp(i)) then
check_str_tmp(i) = '.true.'
else
check_str_tmp(i) = '.false.'
end if
end do
answer_shape = shape(answer)
check_shape = shape(check)
allocate( answer_str ( answer_shape(1), answer_shape(2) ) )
allocate( check_str ( check_shape(1), check_shape(2) ) )
answer_str = reshape(answer_str_tmp, answer_shape)
check_str = reshape(check_str_tmp, check_shape)
call DCTestAssertEqualChar2(message, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCTestAssertEqualLogical2
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:) : | real(DP), intent(in) |
| check(:,:) : | real(DP), intent(in) |
subroutine DCTestAssertEqualDouble2(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:)
real(DP), intent(in):: check(:,:)
logical:: err_flag
character(STRING):: pos_str
real(DP):: wrong, right
integer:: answer_shape(2), check_shape(2), pos(2)
logical:: consist_shape(2)
character(TOKEN):: pos_array(2)
integer, allocatable:: mask_array(:,:)
logical, allocatable:: judge(:,:)
logical, allocatable:: judge_rev(:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2) ) )
allocate( judge ( answer_shape(1), answer_shape(2) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2) )
right = answer ( pos(1), pos(2) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualDouble2
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:) : | real, intent(in) |
| check(:,:) : | real, intent(in) |
subroutine DCTestAssertEqualReal2(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:)
real, intent(in):: check(:,:)
logical:: err_flag
character(STRING):: pos_str
real:: wrong, right
integer:: answer_shape(2), check_shape(2), pos(2)
logical:: consist_shape(2)
character(TOKEN):: pos_array(2)
integer, allocatable:: mask_array(:,:)
logical, allocatable:: judge(:,:)
logical, allocatable:: judge_rev(:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2) ) )
allocate( judge ( answer_shape(1), answer_shape(2) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2) )
right = answer ( pos(1), pos(2) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualReal2
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:) : | character(*), intent(in) |
| check(:,:,:) : | character(*), intent(in) |
subroutine DCTestAssertEqualChar3(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
character(*), intent(in):: answer(:,:,:)
character(*), intent(in):: check(:,:,:)
logical:: err_flag
character(STRING):: pos_str
character(STRING):: wrong, right
integer:: answer_shape(3), check_shape(3), pos(3)
logical:: consist_shape(3)
character(TOKEN):: pos_array(3)
integer, allocatable:: mask_array(:,:,:)
logical, allocatable:: judge(:,:,:)
logical, allocatable:: judge_rev(:,:,:)
character(STRING), allocatable:: answer_fixed_length(:,:,:)
character(STRING), allocatable:: check_fixed_length(:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( answer_fixed_length ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( check_fixed_length ( check_shape(1), check_shape(2), check_shape(3) ) )
answer_fixed_length = answer
check_fixed_length = check
judge = answer_fixed_length == check_fixed_length
deallocate(answer_fixed_length, check_fixed_length)
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3) )
right = answer ( pos(1), pos(2), pos(3) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualChar3
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:) : | integer, intent(in) |
| check(:,:,:) : | integer, intent(in) |
subroutine DCTestAssertEqualInt3(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:,:)
integer, intent(in):: check(:,:,:)
logical:: err_flag
character(STRING):: pos_str
integer:: wrong, right
integer:: answer_shape(3), check_shape(3), pos(3)
logical:: consist_shape(3)
character(TOKEN):: pos_array(3)
integer, allocatable:: mask_array(:,:,:)
logical, allocatable:: judge(:,:,:)
logical, allocatable:: judge_rev(:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3) )
right = answer ( pos(1), pos(2), pos(3) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualInt3
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:) : | logical, intent(in) |
| check(:,:,:) : | logical, intent(in) |
subroutine DCTestAssertEqualLogical3(message, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: message
logical, intent(in):: answer(:,:,:)
logical, intent(in):: check(:,:,:)
integer:: answer_shape(3), check_shape(3), i
logical, allocatable:: answer_tmp(:), check_tmp(:)
character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
character(STRING), allocatable:: answer_str(:,:,:)
character(STRING), allocatable:: check_str(:,:,:)
continue
allocate(answer_tmp(size(answer)))
allocate(check_tmp(size(check)))
allocate(answer_str_tmp(size(answer)))
allocate(check_str_tmp(size(check)))
answer_tmp = pack(answer, .true.)
check_tmp = pack(check, .true.)
do i = 1, size(answer_tmp)
if (answer_tmp(i)) then
answer_str_tmp(i) = '.true.'
else
answer_str_tmp(i) = '.false.'
end if
end do
do i = 1, size(check_tmp)
if (check_tmp(i)) then
check_str_tmp(i) = '.true.'
else
check_str_tmp(i) = '.false.'
end if
end do
answer_shape = shape(answer)
check_shape = shape(check)
allocate( answer_str ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( check_str ( check_shape(1), check_shape(2), check_shape(3) ) )
answer_str = reshape(answer_str_tmp, answer_shape)
check_str = reshape(check_str_tmp, check_shape)
call DCTestAssertEqualChar3(message, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCTestAssertEqualLogical3
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:) : | real(DP), intent(in) |
| check(:,:,:) : | real(DP), intent(in) |
subroutine DCTestAssertEqualDouble3(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:)
real(DP), intent(in):: check(:,:,:)
logical:: err_flag
character(STRING):: pos_str
real(DP):: wrong, right
integer:: answer_shape(3), check_shape(3), pos(3)
logical:: consist_shape(3)
character(TOKEN):: pos_array(3)
integer, allocatable:: mask_array(:,:,:)
logical, allocatable:: judge(:,:,:)
logical, allocatable:: judge_rev(:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3) )
right = answer ( pos(1), pos(2), pos(3) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualDouble3
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:) : | real, intent(in) |
| check(:,:,:) : | real, intent(in) |
subroutine DCTestAssertEqualReal3(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:)
real, intent(in):: check(:,:,:)
logical:: err_flag
character(STRING):: pos_str
real:: wrong, right
integer:: answer_shape(3), check_shape(3), pos(3)
logical:: consist_shape(3)
character(TOKEN):: pos_array(3)
integer, allocatable:: mask_array(:,:,:)
logical, allocatable:: judge(:,:,:)
logical, allocatable:: judge_rev(:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3) )
right = answer ( pos(1), pos(2), pos(3) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualReal3
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:) : | character(*), intent(in) |
| check(:,:,:,:) : | character(*), intent(in) |
subroutine DCTestAssertEqualChar4(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
character(*), intent(in):: answer(:,:,:,:)
character(*), intent(in):: check(:,:,:,:)
logical:: err_flag
character(STRING):: pos_str
character(STRING):: wrong, right
integer:: answer_shape(4), check_shape(4), pos(4)
logical:: consist_shape(4)
character(TOKEN):: pos_array(4)
integer, allocatable:: mask_array(:,:,:,:)
logical, allocatable:: judge(:,:,:,:)
logical, allocatable:: judge_rev(:,:,:,:)
character(STRING), allocatable:: answer_fixed_length(:,:,:,:)
character(STRING), allocatable:: check_fixed_length(:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( answer_fixed_length ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( check_fixed_length ( check_shape(1), check_shape(2), check_shape(3), check_shape(4) ) )
answer_fixed_length = answer
check_fixed_length = check
judge = answer_fixed_length == check_fixed_length
deallocate(answer_fixed_length, check_fixed_length)
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4) )
right = answer ( pos(1), pos(2), pos(3), pos(4) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualChar4
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:) : | integer, intent(in) |
subroutine DCTestAssertEqualInt4(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:,:,:)
integer, intent(in):: check(:,:,:,:)
logical:: err_flag
character(STRING):: pos_str
integer:: wrong, right
integer:: answer_shape(4), check_shape(4), pos(4)
logical:: consist_shape(4)
character(TOKEN):: pos_array(4)
integer, allocatable:: mask_array(:,:,:,:)
logical, allocatable:: judge(:,:,:,:)
logical, allocatable:: judge_rev(:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4) )
right = answer ( pos(1), pos(2), pos(3), pos(4) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualInt4
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:) : | logical, intent(in) |
| check(:,:,:,:) : | logical, intent(in) |
subroutine DCTestAssertEqualLogical4(message, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: message
logical, intent(in):: answer(:,:,:,:)
logical, intent(in):: check(:,:,:,:)
integer:: answer_shape(4), check_shape(4), i
logical, allocatable:: answer_tmp(:), check_tmp(:)
character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
character(STRING), allocatable:: answer_str(:,:,:,:)
character(STRING), allocatable:: check_str(:,:,:,:)
continue
allocate(answer_tmp(size(answer)))
allocate(check_tmp(size(check)))
allocate(answer_str_tmp(size(answer)))
allocate(check_str_tmp(size(check)))
answer_tmp = pack(answer, .true.)
check_tmp = pack(check, .true.)
do i = 1, size(answer_tmp)
if (answer_tmp(i)) then
answer_str_tmp(i) = '.true.'
else
answer_str_tmp(i) = '.false.'
end if
end do
do i = 1, size(check_tmp)
if (check_tmp(i)) then
check_str_tmp(i) = '.true.'
else
check_str_tmp(i) = '.false.'
end if
end do
answer_shape = shape(answer)
check_shape = shape(check)
allocate( answer_str ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( check_str ( check_shape(1), check_shape(2), check_shape(3), check_shape(4) ) )
answer_str = reshape(answer_str_tmp, answer_shape)
check_str = reshape(check_str_tmp, check_shape)
call DCTestAssertEqualChar4(message, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCTestAssertEqualLogical4
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:) : | real(DP), intent(in) |
subroutine DCTestAssertEqualDouble4(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:,:)
real(DP), intent(in):: check(:,:,:,:)
logical:: err_flag
character(STRING):: pos_str
real(DP):: wrong, right
integer:: answer_shape(4), check_shape(4), pos(4)
logical:: consist_shape(4)
character(TOKEN):: pos_array(4)
integer, allocatable:: mask_array(:,:,:,:)
logical, allocatable:: judge(:,:,:,:)
logical, allocatable:: judge_rev(:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4) )
right = answer ( pos(1), pos(2), pos(3), pos(4) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualDouble4
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:) : | real, intent(in) |
| check(:,:,:,:) : | real, intent(in) |
subroutine DCTestAssertEqualReal4(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:,:)
real, intent(in):: check(:,:,:,:)
logical:: err_flag
character(STRING):: pos_str
real:: wrong, right
integer:: answer_shape(4), check_shape(4), pos(4)
logical:: consist_shape(4)
character(TOKEN):: pos_array(4)
integer, allocatable:: mask_array(:,:,:,:)
logical, allocatable:: judge(:,:,:,:)
logical, allocatable:: judge_rev(:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4) )
right = answer ( pos(1), pos(2), pos(3), pos(4) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualReal4
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:) : | character(*), intent(in) |
| check(:,:,:,:,:) : | character(*), intent(in) |
subroutine DCTestAssertEqualChar5(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
character(*), intent(in):: answer(:,:,:,:,:)
character(*), intent(in):: check(:,:,:,:,:)
logical:: err_flag
character(STRING):: pos_str
character(STRING):: wrong, right
integer:: answer_shape(5), check_shape(5), pos(5)
logical:: consist_shape(5)
character(TOKEN):: pos_array(5)
integer, allocatable:: mask_array(:,:,:,:,:)
logical, allocatable:: judge(:,:,:,:,:)
logical, allocatable:: judge_rev(:,:,:,:,:)
character(STRING), allocatable:: answer_fixed_length(:,:,:,:,:)
character(STRING), allocatable:: check_fixed_length(:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( answer_fixed_length ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( check_fixed_length ( check_shape(1), check_shape(2), check_shape(3), check_shape(4), check_shape(5) ) )
answer_fixed_length = answer
check_fixed_length = check
judge = answer_fixed_length == check_fixed_length
deallocate(answer_fixed_length, check_fixed_length)
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualChar5
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:,:) : | integer, intent(in) |
subroutine DCTestAssertEqualInt5(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:,:,:,:)
integer, intent(in):: check(:,:,:,:,:)
logical:: err_flag
character(STRING):: pos_str
integer:: wrong, right
integer:: answer_shape(5), check_shape(5), pos(5)
logical:: consist_shape(5)
character(TOKEN):: pos_array(5)
integer, allocatable:: mask_array(:,:,:,:,:)
logical, allocatable:: judge(:,:,:,:,:)
logical, allocatable:: judge_rev(:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualInt5
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:) : | logical, intent(in) |
| check(:,:,:,:,:) : | logical, intent(in) |
subroutine DCTestAssertEqualLogical5(message, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: message
logical, intent(in):: answer(:,:,:,:,:)
logical, intent(in):: check(:,:,:,:,:)
integer:: answer_shape(5), check_shape(5), i
logical, allocatable:: answer_tmp(:), check_tmp(:)
character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
character(STRING), allocatable:: answer_str(:,:,:,:,:)
character(STRING), allocatable:: check_str(:,:,:,:,:)
continue
allocate(answer_tmp(size(answer)))
allocate(check_tmp(size(check)))
allocate(answer_str_tmp(size(answer)))
allocate(check_str_tmp(size(check)))
answer_tmp = pack(answer, .true.)
check_tmp = pack(check, .true.)
do i = 1, size(answer_tmp)
if (answer_tmp(i)) then
answer_str_tmp(i) = '.true.'
else
answer_str_tmp(i) = '.false.'
end if
end do
do i = 1, size(check_tmp)
if (check_tmp(i)) then
check_str_tmp(i) = '.true.'
else
check_str_tmp(i) = '.false.'
end if
end do
answer_shape = shape(answer)
check_shape = shape(check)
allocate( answer_str ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( check_str ( check_shape(1), check_shape(2), check_shape(3), check_shape(4), check_shape(5) ) )
answer_str = reshape(answer_str_tmp, answer_shape)
check_str = reshape(check_str_tmp, check_shape)
call DCTestAssertEqualChar5(message, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCTestAssertEqualLogical5
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:,:) : | real(DP), intent(in) |
subroutine DCTestAssertEqualDouble5(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:,:,:)
real(DP), intent(in):: check(:,:,:,:,:)
logical:: err_flag
character(STRING):: pos_str
real(DP):: wrong, right
integer:: answer_shape(5), check_shape(5), pos(5)
logical:: consist_shape(5)
character(TOKEN):: pos_array(5)
integer, allocatable:: mask_array(:,:,:,:,:)
logical, allocatable:: judge(:,:,:,:,:)
logical, allocatable:: judge_rev(:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualDouble5
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:) : | real, intent(in) |
| check(:,:,:,:,:) : | real, intent(in) |
subroutine DCTestAssertEqualReal5(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:,:,:)
real, intent(in):: check(:,:,:,:,:)
logical:: err_flag
character(STRING):: pos_str
real:: wrong, right
integer:: answer_shape(5), check_shape(5), pos(5)
logical:: consist_shape(5)
character(TOKEN):: pos_array(5)
integer, allocatable:: mask_array(:,:,:,:,:)
logical, allocatable:: judge(:,:,:,:,:)
logical, allocatable:: judge_rev(:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualReal5
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | character(*), intent(in) |
| check(:,:,:,:,:,:) : | character(*), intent(in) |
subroutine DCTestAssertEqualChar6(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
character(*), intent(in):: answer(:,:,:,:,:,:)
character(*), intent(in):: check(:,:,:,:,:,:)
logical:: err_flag
character(STRING):: pos_str
character(STRING):: wrong, right
integer:: answer_shape(6), check_shape(6), pos(6)
logical:: consist_shape(6)
character(TOKEN):: pos_array(6)
integer, allocatable:: mask_array(:,:,:,:,:,:)
logical, allocatable:: judge(:,:,:,:,:,:)
logical, allocatable:: judge_rev(:,:,:,:,:,:)
character(STRING), allocatable:: answer_fixed_length(:,:,:,:,:,:)
character(STRING), allocatable:: check_fixed_length(:,:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( answer_fixed_length ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( check_fixed_length ( check_shape(1), check_shape(2), check_shape(3), check_shape(4), check_shape(5), check_shape(6) ) )
answer_fixed_length = answer
check_fixed_length = check
judge = answer_fixed_length == check_fixed_length
deallocate(answer_fixed_length, check_fixed_length)
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
write(unit=pos_array(6), fmt="(i20)") pos(6)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ',' // trim(adjustl(pos_array(6))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualChar6
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:,:,:) : | integer, intent(in) |
subroutine DCTestAssertEqualInt6(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:,:,:,:,:)
integer, intent(in):: check(:,:,:,:,:,:)
logical:: err_flag
character(STRING):: pos_str
integer:: wrong, right
integer:: answer_shape(6), check_shape(6), pos(6)
logical:: consist_shape(6)
character(TOKEN):: pos_array(6)
integer, allocatable:: mask_array(:,:,:,:,:,:)
logical, allocatable:: judge(:,:,:,:,:,:)
logical, allocatable:: judge_rev(:,:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
write(unit=pos_array(6), fmt="(i20)") pos(6)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ',' // trim(adjustl(pos_array(6))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualInt6
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | logical, intent(in) |
| check(:,:,:,:,:,:) : | logical, intent(in) |
subroutine DCTestAssertEqualLogical6(message, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: message
logical, intent(in):: answer(:,:,:,:,:,:)
logical, intent(in):: check(:,:,:,:,:,:)
integer:: answer_shape(6), check_shape(6), i
logical, allocatable:: answer_tmp(:), check_tmp(:)
character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
character(STRING), allocatable:: answer_str(:,:,:,:,:,:)
character(STRING), allocatable:: check_str(:,:,:,:,:,:)
continue
allocate(answer_tmp(size(answer)))
allocate(check_tmp(size(check)))
allocate(answer_str_tmp(size(answer)))
allocate(check_str_tmp(size(check)))
answer_tmp = pack(answer, .true.)
check_tmp = pack(check, .true.)
do i = 1, size(answer_tmp)
if (answer_tmp(i)) then
answer_str_tmp(i) = '.true.'
else
answer_str_tmp(i) = '.false.'
end if
end do
do i = 1, size(check_tmp)
if (check_tmp(i)) then
check_str_tmp(i) = '.true.'
else
check_str_tmp(i) = '.false.'
end if
end do
answer_shape = shape(answer)
check_shape = shape(check)
allocate( answer_str ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( check_str ( check_shape(1), check_shape(2), check_shape(3), check_shape(4), check_shape(5), check_shape(6) ) )
answer_str = reshape(answer_str_tmp, answer_shape)
check_str = reshape(check_str_tmp, check_shape)
call DCTestAssertEqualChar6(message, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCTestAssertEqualLogical6
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:,:,:) : | real(DP), intent(in) |
subroutine DCTestAssertEqualDouble6(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:,:,:,:)
real(DP), intent(in):: check(:,:,:,:,:,:)
logical:: err_flag
character(STRING):: pos_str
real(DP):: wrong, right
integer:: answer_shape(6), check_shape(6), pos(6)
logical:: consist_shape(6)
character(TOKEN):: pos_array(6)
integer, allocatable:: mask_array(:,:,:,:,:,:)
logical, allocatable:: judge(:,:,:,:,:,:)
logical, allocatable:: judge_rev(:,:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
write(unit=pos_array(6), fmt="(i20)") pos(6)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ',' // trim(adjustl(pos_array(6))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualDouble6
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | real, intent(in) |
| check(:,:,:,:,:,:) : | real, intent(in) |
subroutine DCTestAssertEqualReal6(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:,:,:,:)
real, intent(in):: check(:,:,:,:,:,:)
logical:: err_flag
character(STRING):: pos_str
real:: wrong, right
integer:: answer_shape(6), check_shape(6), pos(6)
logical:: consist_shape(6)
character(TOKEN):: pos_array(6)
integer, allocatable:: mask_array(:,:,:,:,:,:)
logical, allocatable:: judge(:,:,:,:,:,:)
logical, allocatable:: judge_rev(:,:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
write(unit=pos_array(6), fmt="(i20)") pos(6)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ',' // trim(adjustl(pos_array(6))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualReal6
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | character(*), intent(in) |
| check(:,:,:,:,:,:,:) : | character(*), intent(in) |
subroutine DCTestAssertEqualChar7(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
character(*), intent(in):: answer(:,:,:,:,:,:,:)
character(*), intent(in):: check(:,:,:,:,:,:,:)
logical:: err_flag
character(STRING):: pos_str
character(STRING):: wrong, right
integer:: answer_shape(7), check_shape(7), pos(7)
logical:: consist_shape(7)
character(TOKEN):: pos_array(7)
integer, allocatable:: mask_array(:,:,:,:,:,:,:)
logical, allocatable:: judge(:,:,:,:,:,:,:)
logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
character(STRING), allocatable:: answer_fixed_length(:,:,:,:,:,:,:)
character(STRING), allocatable:: check_fixed_length(:,:,:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( answer_fixed_length ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( check_fixed_length ( check_shape(1), check_shape(2), check_shape(3), check_shape(4), check_shape(5), check_shape(6), check_shape(7) ) )
answer_fixed_length = answer
check_fixed_length = check
judge = answer_fixed_length == check_fixed_length
deallocate(answer_fixed_length, check_fixed_length)
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
write(unit=pos_array(6), fmt="(i20)") pos(6)
write(unit=pos_array(7), fmt="(i20)") pos(7)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ',' // trim(adjustl(pos_array(6))) // ',' // trim(adjustl(pos_array(7))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', trim(wrong)
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', trim(right)
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualChar7
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:,:,:,:) : | integer, intent(in) |
subroutine DCTestAssertEqualInt7(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:,:,:,:,:,:)
integer, intent(in):: check(:,:,:,:,:,:,:)
logical:: err_flag
character(STRING):: pos_str
integer:: wrong, right
integer:: answer_shape(7), check_shape(7), pos(7)
logical:: consist_shape(7)
character(TOKEN):: pos_array(7)
integer, allocatable:: mask_array(:,:,:,:,:,:,:)
logical, allocatable:: judge(:,:,:,:,:,:,:)
logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
write(unit=pos_array(6), fmt="(i20)") pos(6)
write(unit=pos_array(7), fmt="(i20)") pos(7)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ',' // trim(adjustl(pos_array(6))) // ',' // trim(adjustl(pos_array(7))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualInt7
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | logical, intent(in) |
| check(:,:,:,:,:,:,:) : | logical, intent(in) |
subroutine DCTestAssertEqualLogical7(message, answer, check)
use dc_types, only: STRING
implicit none
character(*), intent(in):: message
logical, intent(in):: answer(:,:,:,:,:,:,:)
logical, intent(in):: check(:,:,:,:,:,:,:)
integer:: answer_shape(7), check_shape(7), i
logical, allocatable:: answer_tmp(:), check_tmp(:)
character(STRING), allocatable:: answer_str_tmp(:), check_str_tmp(:)
character(STRING), allocatable:: answer_str(:,:,:,:,:,:,:)
character(STRING), allocatable:: check_str(:,:,:,:,:,:,:)
continue
allocate(answer_tmp(size(answer)))
allocate(check_tmp(size(check)))
allocate(answer_str_tmp(size(answer)))
allocate(check_str_tmp(size(check)))
answer_tmp = pack(answer, .true.)
check_tmp = pack(check, .true.)
do i = 1, size(answer_tmp)
if (answer_tmp(i)) then
answer_str_tmp(i) = '.true.'
else
answer_str_tmp(i) = '.false.'
end if
end do
do i = 1, size(check_tmp)
if (check_tmp(i)) then
check_str_tmp(i) = '.true.'
else
check_str_tmp(i) = '.false.'
end if
end do
answer_shape = shape(answer)
check_shape = shape(check)
allocate( answer_str ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( check_str ( check_shape(1), check_shape(2), check_shape(3), check_shape(4), check_shape(5), check_shape(6), check_shape(7) ) )
answer_str = reshape(answer_str_tmp, answer_shape)
check_str = reshape(check_str_tmp, check_shape)
call DCTestAssertEqualChar7(message, answer_str, check_str)
deallocate(answer_str, answer_tmp, answer_str_tmp)
deallocate(check_str, check_tmp, check_str_tmp)
end subroutine DCTestAssertEqualLogical7
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:,:,:,:) : | real(DP), intent(in) |
subroutine DCTestAssertEqualDouble7(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:,:,:,:,:)
real(DP), intent(in):: check(:,:,:,:,:,:,:)
logical:: err_flag
character(STRING):: pos_str
real(DP):: wrong, right
integer:: answer_shape(7), check_shape(7), pos(7)
logical:: consist_shape(7)
character(TOKEN):: pos_array(7)
integer, allocatable:: mask_array(:,:,:,:,:,:,:)
logical, allocatable:: judge(:,:,:,:,:,:,:)
logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
write(unit=pos_array(6), fmt="(i20)") pos(6)
write(unit=pos_array(7), fmt="(i20)") pos(7)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ',' // trim(adjustl(pos_array(6))) // ',' // trim(adjustl(pos_array(7))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualDouble7
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | real, intent(in) |
| check(:,:,:,:,:,:,:) : | real, intent(in) |
subroutine DCTestAssertEqualReal7(message, answer, check)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:,:,:,:,:)
real, intent(in):: check(:,:,:,:,:,:,:)
logical:: err_flag
character(STRING):: pos_str
real:: wrong, right
integer:: answer_shape(7), check_shape(7), pos(7)
logical:: consist_shape(7)
character(TOKEN):: pos_array(7)
integer, allocatable:: mask_array(:,:,:,:,:,:,:)
logical, allocatable:: judge(:,:,:,:,:,:,:)
logical, allocatable:: judge_rev(:,:,:,:,:,:,:)
continue
err_flag = .false.
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
judge = answer == check
judge_rev = .not. judge
err_flag = any(judge_rev)
mask_array = 1
pos = maxloc(mask_array, judge_rev)
if (err_flag) then
wrong = check ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) )
right = answer ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) )
write(unit=pos_array(1), fmt="(i20)") pos(1)
write(unit=pos_array(2), fmt="(i20)") pos(2)
write(unit=pos_array(3), fmt="(i20)") pos(3)
write(unit=pos_array(4), fmt="(i20)") pos(4)
write(unit=pos_array(5), fmt="(i20)") pos(5)
write(unit=pos_array(6), fmt="(i20)") pos(6)
write(unit=pos_array(7), fmt="(i20)") pos(7)
pos_str = '(' // trim(adjustl(pos_array(1))) // ',' // trim(adjustl(pos_array(2))) // ',' // trim(adjustl(pos_array(3))) // ',' // trim(adjustl(pos_array(4))) // ',' // trim(adjustl(pos_array(5))) // ',' // trim(adjustl(pos_array(6))) // ',' // trim(adjustl(pos_array(7))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
if (err_flag) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualReal7
| Subroutine : | |
| message : | character(*), intent(in) |
| answer : | real(DP), intent(in) |
| check : | real(DP), intent(in) |
| significant_digits : | integer, intent(in) |
| ignore_digits : | integer, intent(in) |
subroutine DCTestAssertEqualDouble0Digits( message, answer, check, significant_digits, ignore_digits )
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer
real(DP), intent(in):: check
integer, intent(in):: significant_digits
integer, intent(in):: ignore_digits
logical:: err_flag
character(STRING):: pos_str
real(DP):: wrong, right_max, right_min
character(STRING):: pos_str_space
integer:: pos_str_len
real(DP):: right_tmp
real(DP):: answer_max
real(DP):: answer_min
continue
err_flag = .false.
if ( significant_digits < 1 ) then
write(*,*) ' *** Error [AssertEQ] *** '
write(*,*) ' Specify a number more than 1 to "significant_digits"'
call AbortProgram('')
end if
if ( answer < 0.0_DP .and. check < 0.0_DP ) then
answer_max = answer * ( 1.0_DP - 0.1_DP ** significant_digits ) + 0.1_DP ** (- ignore_digits)
answer_min = answer * ( 1.0_DP + 0.1_DP ** significant_digits ) - 0.1_DP ** (- ignore_digits)
else
answer_max = answer * ( 1.0_DP + 0.1_DP ** significant_digits ) + 0.1_DP ** (- ignore_digits)
answer_min = answer * ( 1.0_DP - 0.1_DP ** significant_digits ) - 0.1_DP ** (- ignore_digits)
end if
wrong = check
right_max = answer_max
right_min = answer_min
if ( right_max < right_min ) then
right_tmp = right_max
right_max = right_min
right_min = right_tmp
end if
err_flag = .not. (answer_max > check .and. check > answer_min)
pos_str = ''
if (err_flag) then
pos_str_space = ''
pos_str_len = len_trim(pos_str)
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' ' // pos_str_space(1:pos_str_len) // ' ', right_min, ' < '
write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualDouble0Digits
| Subroutine : | |
| message : | character(*), intent(in) |
| answer : | real, intent(in) |
| check : | real, intent(in) |
| significant_digits : | integer, intent(in) |
| ignore_digits : | integer, intent(in) |
subroutine DCTestAssertEqualReal0Digits( message, answer, check, significant_digits, ignore_digits )
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer
real, intent(in):: check
integer, intent(in):: significant_digits
integer, intent(in):: ignore_digits
logical:: err_flag
character(STRING):: pos_str
real:: wrong, right_max, right_min
character(STRING):: pos_str_space
integer:: pos_str_len
real:: right_tmp
real:: answer_max
real:: answer_min
continue
err_flag = .false.
if ( significant_digits < 1 ) then
write(*,*) ' *** Error [AssertEQ] *** '
write(*,*) ' Specify a number more than 1 to "significant_digits"'
call AbortProgram('')
end if
if ( answer < 0.0 .and. check < 0.0 ) then
answer_max = answer * ( 1.0 - 0.1 ** significant_digits ) + 0.1 ** (- ignore_digits)
answer_min = answer * ( 1.0 + 0.1 ** significant_digits ) - 0.1 ** (- ignore_digits)
else
answer_max = answer * ( 1.0 + 0.1 ** significant_digits ) + 0.1 ** (- ignore_digits)
answer_min = answer * ( 1.0 - 0.1 ** significant_digits ) - 0.1 ** (- ignore_digits)
end if
wrong = check
right_max = answer_max
right_min = answer_min
if ( right_max < right_min ) then
right_tmp = right_max
right_max = right_min
right_min = right_tmp
end if
err_flag = .not. (answer_max > check .and. check > answer_min)
pos_str = ''
if (err_flag) then
pos_str_space = ''
pos_str_len = len_trim(pos_str)
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' ' // pos_str_space(1:pos_str_len) // ' ', right_min, ' < '
write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualReal0Digits
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:) : | real(DP), intent(in) |
| check(:) : | real(DP), intent(in) |
| significant_digits : | integer, intent(in) |
| ignore_digits : | integer, intent(in) |
subroutine DCTestAssertEqualDouble1Digits( message, answer, check, significant_digits, ignore_digits )
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:)
real(DP), intent(in):: check(:)
integer, intent(in):: significant_digits
integer, intent(in):: ignore_digits
logical:: err_flag
character(STRING):: pos_str
real(DP):: wrong, right_max, right_min
character(STRING):: pos_str_space
integer:: pos_str_len
real(DP):: right_tmp
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(:)
logical, allocatable:: answer_negative(:)
logical, allocatable:: check_negative(:)
logical, allocatable:: both_negative(:)
real(DP), allocatable:: answer_max(:)
real(DP), allocatable:: answer_min(:)
continue
err_flag = .false.
if ( significant_digits < 1 ) then
write(*,*) ' *** Error [AssertEQ] *** '
write(*,*) ' Specify a number more than 1 to "significant_digits"'
call AbortProgram('')
end if
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1) ) )
allocate( judge ( answer_shape(1) ) )
allocate( judge_rev ( answer_shape(1) ) )
allocate( answer_negative ( answer_shape(1) ) )
allocate( check_negative ( answer_shape(1) ) )
allocate( both_negative ( answer_shape(1) ) )
allocate( answer_max ( answer_shape(1) ) )
allocate( answer_min ( answer_shape(1) ) )
answer_negative = answer < 0.0_DP
check_negative = check < 0.0_DP
both_negative = answer_negative .and. check_negative
where (both_negative)
answer_max = answer * ( 1.0_DP - 0.1_DP ** significant_digits ) + 0.1_DP ** (- ignore_digits)
answer_min = answer * ( 1.0_DP + 0.1_DP ** significant_digits ) - 0.1_DP ** (- ignore_digits)
elsewhere
answer_max = answer * ( 1.0_DP + 0.1_DP ** significant_digits ) + 0.1_DP ** (- ignore_digits)
answer_min = answer * ( 1.0_DP - 0.1_DP ** significant_digits ) - 0.1_DP ** (- ignore_digits)
end where
judge = answer_max > check .and. check > answer_min
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_max = answer_max ( pos(1) )
right_min = answer_min ( pos(1) )
if ( right_max < right_min ) then
right_tmp = right_max
right_max = right_min
right_min = right_tmp
end if
write(unit=pos_array(1), fmt="(i20)") pos(1)
pos_str = '(' // trim(adjustl(pos_array(1))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
deallocate(answer_max, answer_min)
if (err_flag) then
pos_str_space = ''
pos_str_len = len_trim(pos_str)
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' ' // pos_str_space(1:pos_str_len) // ' ', right_min, ' < '
write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualDouble1Digits
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:) : | real, intent(in) |
| check(:) : | real, intent(in) |
| significant_digits : | integer, intent(in) |
| ignore_digits : | integer, intent(in) |
subroutine DCTestAssertEqualReal1Digits( message, answer, check, significant_digits, ignore_digits )
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:)
real, intent(in):: check(:)
integer, intent(in):: significant_digits
integer, intent(in):: ignore_digits
logical:: err_flag
character(STRING):: pos_str
real:: wrong, right_max, right_min
character(STRING):: pos_str_space
integer:: pos_str_len
real:: right_tmp
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(:)
logical, allocatable:: answer_negative(:)
logical, allocatable:: check_negative(:)
logical, allocatable:: both_negative(:)
real, allocatable:: answer_max(:)
real, allocatable:: answer_min(:)
continue
err_flag = .false.
if ( significant_digits < 1 ) then
write(*,*) ' *** Error [AssertEQ] *** '
write(*,*) ' Specify a number more than 1 to "significant_digits"'
call AbortProgram('')
end if
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1) ) )
allocate( judge ( answer_shape(1) ) )
allocate( judge_rev ( answer_shape(1) ) )
allocate( answer_negative ( answer_shape(1) ) )
allocate( check_negative ( answer_shape(1) ) )
allocate( both_negative ( answer_shape(1) ) )
allocate( answer_max ( answer_shape(1) ) )
allocate( answer_min ( answer_shape(1) ) )
answer_negative = answer < 0.0
check_negative = check < 0.0
both_negative = answer_negative .and. check_negative
where (both_negative)
answer_max = answer * ( 1.0 - 0.1 ** significant_digits ) + 0.1 ** (- ignore_digits)
answer_min = answer * ( 1.0 + 0.1 ** significant_digits ) - 0.1 ** (- ignore_digits)
elsewhere
answer_max = answer * ( 1.0 + 0.1 ** significant_digits ) + 0.1 ** (- ignore_digits)
answer_min = answer * ( 1.0 - 0.1 ** significant_digits ) - 0.1 ** (- ignore_digits)
end where
judge = answer_max > check .and. check > answer_min
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_max = answer_max ( pos(1) )
right_min = answer_min ( pos(1) )
if ( right_max < right_min ) then
right_tmp = right_max
right_max = right_min
right_min = right_tmp
end if
write(unit=pos_array(1), fmt="(i20)") pos(1)
pos_str = '(' // trim(adjustl(pos_array(1))) // ')'
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
deallocate(answer_max, answer_min)
if (err_flag) then
pos_str_space = ''
pos_str_len = len_trim(pos_str)
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' ' // pos_str_space(1:pos_str_len) // ' ', right_min, ' < '
write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualReal1Digits
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:) : | real(DP), intent(in) |
| check(:,:) : | real(DP), intent(in) |
| significant_digits : | integer, intent(in) |
| ignore_digits : | integer, intent(in) |
subroutine DCTestAssertEqualDouble2Digits( message, answer, check, significant_digits, ignore_digits )
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:)
real(DP), intent(in):: check(:,:)
integer, intent(in):: significant_digits
integer, intent(in):: ignore_digits
logical:: err_flag
character(STRING):: pos_str
real(DP):: wrong, right_max, right_min
character(STRING):: pos_str_space
integer:: pos_str_len
real(DP):: right_tmp
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(:,:)
logical, allocatable:: answer_negative(:,:)
logical, allocatable:: check_negative(:,:)
logical, allocatable:: both_negative(:,:)
real(DP), allocatable:: answer_max(:,:)
real(DP), allocatable:: answer_min(:,:)
continue
err_flag = .false.
if ( significant_digits < 1 ) then
write(*,*) ' *** Error [AssertEQ] *** '
write(*,*) ' Specify a number more than 1 to "significant_digits"'
call AbortProgram('')
end if
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2) ) )
allocate( judge ( answer_shape(1), answer_shape(2) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2) ) )
allocate( answer_max ( answer_shape(1), answer_shape(2) ) )
allocate( answer_min ( answer_shape(1), answer_shape(2) ) )
answer_negative = answer < 0.0_DP
check_negative = check < 0.0_DP
both_negative = answer_negative .and. check_negative
where (both_negative)
answer_max = answer * ( 1.0_DP - 0.1_DP ** significant_digits ) + 0.1_DP ** (- ignore_digits)
answer_min = answer * ( 1.0_DP + 0.1_DP ** significant_digits ) - 0.1_DP ** (- ignore_digits)
elsewhere
answer_max = answer * ( 1.0_DP + 0.1_DP ** significant_digits ) + 0.1_DP ** (- ignore_digits)
answer_min = answer * ( 1.0_DP - 0.1_DP ** significant_digits ) - 0.1_DP ** (- ignore_digits)
end where
judge = answer_max > check .and. check > answer_min
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_max = answer_max ( pos(1), pos(2) )
right_min = answer_min ( pos(1), pos(2) )
if ( right_max < right_min ) then
right_tmp = right_max
right_max = right_min
right_min = right_tmp
end if
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)
deallocate(answer_negative, check_negative, both_negative)
deallocate(answer_max, answer_min)
if (err_flag) then
pos_str_space = ''
pos_str_len = len_trim(pos_str)
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' ' // pos_str_space(1:pos_str_len) // ' ', right_min, ' < '
write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualDouble2Digits
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:) : | real, intent(in) |
| check(:,:) : | real, intent(in) |
| significant_digits : | integer, intent(in) |
| ignore_digits : | integer, intent(in) |
subroutine DCTestAssertEqualReal2Digits( message, answer, check, significant_digits, ignore_digits )
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:)
real, intent(in):: check(:,:)
integer, intent(in):: significant_digits
integer, intent(in):: ignore_digits
logical:: err_flag
character(STRING):: pos_str
real:: wrong, right_max, right_min
character(STRING):: pos_str_space
integer:: pos_str_len
real:: right_tmp
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(:,:)
logical, allocatable:: answer_negative(:,:)
logical, allocatable:: check_negative(:,:)
logical, allocatable:: both_negative(:,:)
real, allocatable:: answer_max(:,:)
real, allocatable:: answer_min(:,:)
continue
err_flag = .false.
if ( significant_digits < 1 ) then
write(*,*) ' *** Error [AssertEQ] *** '
write(*,*) ' Specify a number more than 1 to "significant_digits"'
call AbortProgram('')
end if
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2) ) )
allocate( judge ( answer_shape(1), answer_shape(2) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2) ) )
allocate( answer_max ( answer_shape(1), answer_shape(2) ) )
allocate( answer_min ( answer_shape(1), answer_shape(2) ) )
answer_negative = answer < 0.0
check_negative = check < 0.0
both_negative = answer_negative .and. check_negative
where (both_negative)
answer_max = answer * ( 1.0 - 0.1 ** significant_digits ) + 0.1 ** (- ignore_digits)
answer_min = answer * ( 1.0 + 0.1 ** significant_digits ) - 0.1 ** (- ignore_digits)
elsewhere
answer_max = answer * ( 1.0 + 0.1 ** significant_digits ) + 0.1 ** (- ignore_digits)
answer_min = answer * ( 1.0 - 0.1 ** significant_digits ) - 0.1 ** (- ignore_digits)
end where
judge = answer_max > check .and. check > answer_min
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_max = answer_max ( pos(1), pos(2) )
right_min = answer_min ( pos(1), pos(2) )
if ( right_max < right_min ) then
right_tmp = right_max
right_max = right_min
right_min = right_tmp
end if
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)
deallocate(answer_negative, check_negative, both_negative)
deallocate(answer_max, answer_min)
if (err_flag) then
pos_str_space = ''
pos_str_len = len_trim(pos_str)
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' ' // pos_str_space(1:pos_str_len) // ' ', right_min, ' < '
write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualReal2Digits
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:) : | real(DP), intent(in) |
| check(:,:,:) : | real(DP), intent(in) |
| significant_digits : | integer, intent(in) |
| ignore_digits : | integer, intent(in) |
subroutine DCTestAssertEqualDouble3Digits( message, answer, check, significant_digits, ignore_digits )
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:)
real(DP), intent(in):: check(:,:,:)
integer, intent(in):: significant_digits
integer, intent(in):: ignore_digits
logical:: err_flag
character(STRING):: pos_str
real(DP):: wrong, right_max, right_min
character(STRING):: pos_str_space
integer:: pos_str_len
real(DP):: right_tmp
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(:,:,:)
logical, allocatable:: answer_negative(:,:,:)
logical, allocatable:: check_negative(:,:,:)
logical, allocatable:: both_negative(:,:,:)
real(DP), allocatable:: answer_max(:,:,:)
real(DP), allocatable:: answer_min(:,:,:)
continue
err_flag = .false.
if ( significant_digits < 1 ) then
write(*,*) ' *** Error [AssertEQ] *** '
write(*,*) ' Specify a number more than 1 to "significant_digits"'
call AbortProgram('')
end if
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( answer_max ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( answer_min ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
answer_negative = answer < 0.0_DP
check_negative = check < 0.0_DP
both_negative = answer_negative .and. check_negative
where (both_negative)
answer_max = answer * ( 1.0_DP - 0.1_DP ** significant_digits ) + 0.1_DP ** (- ignore_digits)
answer_min = answer * ( 1.0_DP + 0.1_DP ** significant_digits ) - 0.1_DP ** (- ignore_digits)
elsewhere
answer_max = answer * ( 1.0_DP + 0.1_DP ** significant_digits ) + 0.1_DP ** (- ignore_digits)
answer_min = answer * ( 1.0_DP - 0.1_DP ** significant_digits ) - 0.1_DP ** (- ignore_digits)
end where
judge = answer_max > check .and. check > answer_min
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_max = answer_max ( pos(1), pos(2), pos(3) )
right_min = answer_min ( pos(1), pos(2), pos(3) )
if ( right_max < right_min ) then
right_tmp = right_max
right_max = right_min
right_min = right_tmp
end if
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)
deallocate(answer_negative, check_negative, both_negative)
deallocate(answer_max, answer_min)
if (err_flag) then
pos_str_space = ''
pos_str_len = len_trim(pos_str)
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' ' // pos_str_space(1:pos_str_len) // ' ', right_min, ' < '
write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualDouble3Digits
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:) : | real, intent(in) |
| check(:,:,:) : | real, intent(in) |
| significant_digits : | integer, intent(in) |
| ignore_digits : | integer, intent(in) |
subroutine DCTestAssertEqualReal3Digits( message, answer, check, significant_digits, ignore_digits )
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:)
real, intent(in):: check(:,:,:)
integer, intent(in):: significant_digits
integer, intent(in):: ignore_digits
logical:: err_flag
character(STRING):: pos_str
real:: wrong, right_max, right_min
character(STRING):: pos_str_space
integer:: pos_str_len
real:: right_tmp
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(:,:,:)
logical, allocatable:: answer_negative(:,:,:)
logical, allocatable:: check_negative(:,:,:)
logical, allocatable:: both_negative(:,:,:)
real, allocatable:: answer_max(:,:,:)
real, allocatable:: answer_min(:,:,:)
continue
err_flag = .false.
if ( significant_digits < 1 ) then
write(*,*) ' *** Error [AssertEQ] *** '
write(*,*) ' Specify a number more than 1 to "significant_digits"'
call AbortProgram('')
end if
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( answer_max ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( answer_min ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
answer_negative = answer < 0.0
check_negative = check < 0.0
both_negative = answer_negative .and. check_negative
where (both_negative)
answer_max = answer * ( 1.0 - 0.1 ** significant_digits ) + 0.1 ** (- ignore_digits)
answer_min = answer * ( 1.0 + 0.1 ** significant_digits ) - 0.1 ** (- ignore_digits)
elsewhere
answer_max = answer * ( 1.0 + 0.1 ** significant_digits ) + 0.1 ** (- ignore_digits)
answer_min = answer * ( 1.0 - 0.1 ** significant_digits ) - 0.1 ** (- ignore_digits)
end where
judge = answer_max > check .and. check > answer_min
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_max = answer_max ( pos(1), pos(2), pos(3) )
right_min = answer_min ( pos(1), pos(2), pos(3) )
if ( right_max < right_min ) then
right_tmp = right_max
right_max = right_min
right_min = right_tmp
end if
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)
deallocate(answer_negative, check_negative, both_negative)
deallocate(answer_max, answer_min)
if (err_flag) then
pos_str_space = ''
pos_str_len = len_trim(pos_str)
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' ' // pos_str_space(1:pos_str_len) // ' ', right_min, ' < '
write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualReal3Digits
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:) : | real(DP), intent(in) |
| significant_digits : | integer, intent(in) |
| ignore_digits : | integer, intent(in) |
subroutine DCTestAssertEqualDouble4Digits( message, answer, check, significant_digits, ignore_digits )
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:,:)
real(DP), intent(in):: check(:,:,:,:)
integer, intent(in):: significant_digits
integer, intent(in):: ignore_digits
logical:: err_flag
character(STRING):: pos_str
real(DP):: wrong, right_max, right_min
character(STRING):: pos_str_space
integer:: pos_str_len
real(DP):: right_tmp
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(:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:)
real(DP), allocatable:: answer_max(:,:,:,:)
real(DP), allocatable:: answer_min(:,:,:,:)
continue
err_flag = .false.
if ( significant_digits < 1 ) then
write(*,*) ' *** Error [AssertEQ] *** '
write(*,*) ' Specify a number more than 1 to "significant_digits"'
call AbortProgram('')
end if
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( answer_max ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( answer_min ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
answer_negative = answer < 0.0_DP
check_negative = check < 0.0_DP
both_negative = answer_negative .and. check_negative
where (both_negative)
answer_max = answer * ( 1.0_DP - 0.1_DP ** significant_digits ) + 0.1_DP ** (- ignore_digits)
answer_min = answer * ( 1.0_DP + 0.1_DP ** significant_digits ) - 0.1_DP ** (- ignore_digits)
elsewhere
answer_max = answer * ( 1.0_DP + 0.1_DP ** significant_digits ) + 0.1_DP ** (- ignore_digits)
answer_min = answer * ( 1.0_DP - 0.1_DP ** significant_digits ) - 0.1_DP ** (- ignore_digits)
end where
judge = answer_max > check .and. check > answer_min
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_max = answer_max ( pos(1), pos(2), pos(3), pos(4) )
right_min = answer_min ( pos(1), pos(2), pos(3), pos(4) )
if ( right_max < right_min ) then
right_tmp = right_max
right_max = right_min
right_min = right_tmp
end if
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)
deallocate(answer_negative, check_negative, both_negative)
deallocate(answer_max, answer_min)
if (err_flag) then
pos_str_space = ''
pos_str_len = len_trim(pos_str)
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' ' // pos_str_space(1:pos_str_len) // ' ', right_min, ' < '
write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualDouble4Digits
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:) : | real, intent(in) |
| check(:,:,:,:) : | real, intent(in) |
| significant_digits : | integer, intent(in) |
| ignore_digits : | integer, intent(in) |
subroutine DCTestAssertEqualReal4Digits( message, answer, check, significant_digits, ignore_digits )
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:,:)
real, intent(in):: check(:,:,:,:)
integer, intent(in):: significant_digits
integer, intent(in):: ignore_digits
logical:: err_flag
character(STRING):: pos_str
real:: wrong, right_max, right_min
character(STRING):: pos_str_space
integer:: pos_str_len
real:: right_tmp
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(:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:)
real, allocatable:: answer_max(:,:,:,:)
real, allocatable:: answer_min(:,:,:,:)
continue
err_flag = .false.
if ( significant_digits < 1 ) then
write(*,*) ' *** Error [AssertEQ] *** '
write(*,*) ' Specify a number more than 1 to "significant_digits"'
call AbortProgram('')
end if
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( answer_max ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( answer_min ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
answer_negative = answer < 0.0
check_negative = check < 0.0
both_negative = answer_negative .and. check_negative
where (both_negative)
answer_max = answer * ( 1.0 - 0.1 ** significant_digits ) + 0.1 ** (- ignore_digits)
answer_min = answer * ( 1.0 + 0.1 ** significant_digits ) - 0.1 ** (- ignore_digits)
elsewhere
answer_max = answer * ( 1.0 + 0.1 ** significant_digits ) + 0.1 ** (- ignore_digits)
answer_min = answer * ( 1.0 - 0.1 ** significant_digits ) - 0.1 ** (- ignore_digits)
end where
judge = answer_max > check .and. check > answer_min
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_max = answer_max ( pos(1), pos(2), pos(3), pos(4) )
right_min = answer_min ( pos(1), pos(2), pos(3), pos(4) )
if ( right_max < right_min ) then
right_tmp = right_max
right_max = right_min
right_min = right_tmp
end if
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)
deallocate(answer_negative, check_negative, both_negative)
deallocate(answer_max, answer_min)
if (err_flag) then
pos_str_space = ''
pos_str_len = len_trim(pos_str)
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' ' // pos_str_space(1:pos_str_len) // ' ', right_min, ' < '
write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualReal4Digits
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:,:) : | real(DP), intent(in) |
| significant_digits : | integer, intent(in) |
| ignore_digits : | integer, intent(in) |
subroutine DCTestAssertEqualDouble5Digits( message, answer, check, significant_digits, ignore_digits )
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:,:,:)
real(DP), intent(in):: check(:,:,:,:,:)
integer, intent(in):: significant_digits
integer, intent(in):: ignore_digits
logical:: err_flag
character(STRING):: pos_str
real(DP):: wrong, right_max, right_min
character(STRING):: pos_str_space
integer:: pos_str_len
real(DP):: right_tmp
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(:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:)
real(DP), allocatable:: answer_max(:,:,:,:,:)
real(DP), allocatable:: answer_min(:,:,:,:,:)
continue
err_flag = .false.
if ( significant_digits < 1 ) then
write(*,*) ' *** Error [AssertEQ] *** '
write(*,*) ' Specify a number more than 1 to "significant_digits"'
call AbortProgram('')
end if
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( answer_max ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( answer_min ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
answer_negative = answer < 0.0_DP
check_negative = check < 0.0_DP
both_negative = answer_negative .and. check_negative
where (both_negative)
answer_max = answer * ( 1.0_DP - 0.1_DP ** significant_digits ) + 0.1_DP ** (- ignore_digits)
answer_min = answer * ( 1.0_DP + 0.1_DP ** significant_digits ) - 0.1_DP ** (- ignore_digits)
elsewhere
answer_max = answer * ( 1.0_DP + 0.1_DP ** significant_digits ) + 0.1_DP ** (- ignore_digits)
answer_min = answer * ( 1.0_DP - 0.1_DP ** significant_digits ) - 0.1_DP ** (- ignore_digits)
end where
judge = answer_max > check .and. check > answer_min
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_max = answer_max ( pos(1), pos(2), pos(3), pos(4), pos(5) )
right_min = answer_min ( pos(1), pos(2), pos(3), pos(4), pos(5) )
if ( right_max < right_min ) then
right_tmp = right_max
right_max = right_min
right_min = right_tmp
end if
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)
deallocate(answer_negative, check_negative, both_negative)
deallocate(answer_max, answer_min)
if (err_flag) then
pos_str_space = ''
pos_str_len = len_trim(pos_str)
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' ' // pos_str_space(1:pos_str_len) // ' ', right_min, ' < '
write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualDouble5Digits
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:) : | real, intent(in) |
| check(:,:,:,:,:) : | real, intent(in) |
| significant_digits : | integer, intent(in) |
| ignore_digits : | integer, intent(in) |
subroutine DCTestAssertEqualReal5Digits( message, answer, check, significant_digits, ignore_digits )
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:,:,:)
real, intent(in):: check(:,:,:,:,:)
integer, intent(in):: significant_digits
integer, intent(in):: ignore_digits
logical:: err_flag
character(STRING):: pos_str
real:: wrong, right_max, right_min
character(STRING):: pos_str_space
integer:: pos_str_len
real:: right_tmp
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(:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:)
real, allocatable:: answer_max(:,:,:,:,:)
real, allocatable:: answer_min(:,:,:,:,:)
continue
err_flag = .false.
if ( significant_digits < 1 ) then
write(*,*) ' *** Error [AssertEQ] *** '
write(*,*) ' Specify a number more than 1 to "significant_digits"'
call AbortProgram('')
end if
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( answer_max ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( answer_min ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
answer_negative = answer < 0.0
check_negative = check < 0.0
both_negative = answer_negative .and. check_negative
where (both_negative)
answer_max = answer * ( 1.0 - 0.1 ** significant_digits ) + 0.1 ** (- ignore_digits)
answer_min = answer * ( 1.0 + 0.1 ** significant_digits ) - 0.1 ** (- ignore_digits)
elsewhere
answer_max = answer * ( 1.0 + 0.1 ** significant_digits ) + 0.1 ** (- ignore_digits)
answer_min = answer * ( 1.0 - 0.1 ** significant_digits ) - 0.1 ** (- ignore_digits)
end where
judge = answer_max > check .and. check > answer_min
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_max = answer_max ( pos(1), pos(2), pos(3), pos(4), pos(5) )
right_min = answer_min ( pos(1), pos(2), pos(3), pos(4), pos(5) )
if ( right_max < right_min ) then
right_tmp = right_max
right_max = right_min
right_min = right_tmp
end if
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)
deallocate(answer_negative, check_negative, both_negative)
deallocate(answer_max, answer_min)
if (err_flag) then
pos_str_space = ''
pos_str_len = len_trim(pos_str)
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' ' // pos_str_space(1:pos_str_len) // ' ', right_min, ' < '
write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualReal5Digits
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:,:,:) : | real(DP), intent(in) |
| significant_digits : | integer, intent(in) |
| ignore_digits : | integer, intent(in) |
subroutine DCTestAssertEqualDouble6Digits( message, answer, check, significant_digits, ignore_digits )
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:,:,:,:)
real(DP), intent(in):: check(:,:,:,:,:,:)
integer, intent(in):: significant_digits
integer, intent(in):: ignore_digits
logical:: err_flag
character(STRING):: pos_str
real(DP):: wrong, right_max, right_min
character(STRING):: pos_str_space
integer:: pos_str_len
real(DP):: right_tmp
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(:,:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:,:)
real(DP), allocatable:: answer_max(:,:,:,:,:,:)
real(DP), allocatable:: answer_min(:,:,:,:,:,:)
continue
err_flag = .false.
if ( significant_digits < 1 ) then
write(*,*) ' *** Error [AssertEQ] *** '
write(*,*) ' Specify a number more than 1 to "significant_digits"'
call AbortProgram('')
end if
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( answer_max ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( answer_min ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
answer_negative = answer < 0.0_DP
check_negative = check < 0.0_DP
both_negative = answer_negative .and. check_negative
where (both_negative)
answer_max = answer * ( 1.0_DP - 0.1_DP ** significant_digits ) + 0.1_DP ** (- ignore_digits)
answer_min = answer * ( 1.0_DP + 0.1_DP ** significant_digits ) - 0.1_DP ** (- ignore_digits)
elsewhere
answer_max = answer * ( 1.0_DP + 0.1_DP ** significant_digits ) + 0.1_DP ** (- ignore_digits)
answer_min = answer * ( 1.0_DP - 0.1_DP ** significant_digits ) - 0.1_DP ** (- ignore_digits)
end where
judge = answer_max > check .and. check > answer_min
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_max = answer_max ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) )
right_min = answer_min ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) )
if ( right_max < right_min ) then
right_tmp = right_max
right_max = right_min
right_min = right_tmp
end if
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)
deallocate(answer_negative, check_negative, both_negative)
deallocate(answer_max, answer_min)
if (err_flag) then
pos_str_space = ''
pos_str_len = len_trim(pos_str)
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' ' // pos_str_space(1:pos_str_len) // ' ', right_min, ' < '
write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualDouble6Digits
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | real, intent(in) |
| check(:,:,:,:,:,:) : | real, intent(in) |
| significant_digits : | integer, intent(in) |
| ignore_digits : | integer, intent(in) |
subroutine DCTestAssertEqualReal6Digits( message, answer, check, significant_digits, ignore_digits )
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:,:,:,:)
real, intent(in):: check(:,:,:,:,:,:)
integer, intent(in):: significant_digits
integer, intent(in):: ignore_digits
logical:: err_flag
character(STRING):: pos_str
real:: wrong, right_max, right_min
character(STRING):: pos_str_space
integer:: pos_str_len
real:: right_tmp
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(:,:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:,:)
real, allocatable:: answer_max(:,:,:,:,:,:)
real, allocatable:: answer_min(:,:,:,:,:,:)
continue
err_flag = .false.
if ( significant_digits < 1 ) then
write(*,*) ' *** Error [AssertEQ] *** '
write(*,*) ' Specify a number more than 1 to "significant_digits"'
call AbortProgram('')
end if
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( answer_max ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( answer_min ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
answer_negative = answer < 0.0
check_negative = check < 0.0
both_negative = answer_negative .and. check_negative
where (both_negative)
answer_max = answer * ( 1.0 - 0.1 ** significant_digits ) + 0.1 ** (- ignore_digits)
answer_min = answer * ( 1.0 + 0.1 ** significant_digits ) - 0.1 ** (- ignore_digits)
elsewhere
answer_max = answer * ( 1.0 + 0.1 ** significant_digits ) + 0.1 ** (- ignore_digits)
answer_min = answer * ( 1.0 - 0.1 ** significant_digits ) - 0.1 ** (- ignore_digits)
end where
judge = answer_max > check .and. check > answer_min
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_max = answer_max ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) )
right_min = answer_min ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) )
if ( right_max < right_min ) then
right_tmp = right_max
right_max = right_min
right_min = right_tmp
end if
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)
deallocate(answer_negative, check_negative, both_negative)
deallocate(answer_max, answer_min)
if (err_flag) then
pos_str_space = ''
pos_str_len = len_trim(pos_str)
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' ' // pos_str_space(1:pos_str_len) // ' ', right_min, ' < '
write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualReal6Digits
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:,:,:,:) : | real(DP), intent(in) |
| significant_digits : | integer, intent(in) |
| ignore_digits : | integer, intent(in) |
subroutine DCTestAssertEqualDouble7Digits( message, answer, check, significant_digits, ignore_digits )
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:,:,:,:,:)
real(DP), intent(in):: check(:,:,:,:,:,:,:)
integer, intent(in):: significant_digits
integer, intent(in):: ignore_digits
logical:: err_flag
character(STRING):: pos_str
real(DP):: wrong, right_max, right_min
character(STRING):: pos_str_space
integer:: pos_str_len
real(DP):: right_tmp
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(:,:,:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:,:,:)
real(DP), allocatable:: answer_max(:,:,:,:,:,:,:)
real(DP), allocatable:: answer_min(:,:,:,:,:,:,:)
continue
err_flag = .false.
if ( significant_digits < 1 ) then
write(*,*) ' *** Error [AssertEQ] *** '
write(*,*) ' Specify a number more than 1 to "significant_digits"'
call AbortProgram('')
end if
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( answer_max ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( answer_min ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
answer_negative = answer < 0.0_DP
check_negative = check < 0.0_DP
both_negative = answer_negative .and. check_negative
where (both_negative)
answer_max = answer * ( 1.0_DP - 0.1_DP ** significant_digits ) + 0.1_DP ** (- ignore_digits)
answer_min = answer * ( 1.0_DP + 0.1_DP ** significant_digits ) - 0.1_DP ** (- ignore_digits)
elsewhere
answer_max = answer * ( 1.0_DP + 0.1_DP ** significant_digits ) + 0.1_DP ** (- ignore_digits)
answer_min = answer * ( 1.0_DP - 0.1_DP ** significant_digits ) - 0.1_DP ** (- ignore_digits)
end where
judge = answer_max > check .and. check > answer_min
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_max = answer_max ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) )
right_min = answer_min ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) )
if ( right_max < right_min ) then
right_tmp = right_max
right_max = right_min
right_min = right_tmp
end if
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)
deallocate(answer_negative, check_negative, both_negative)
deallocate(answer_max, answer_min)
if (err_flag) then
pos_str_space = ''
pos_str_len = len_trim(pos_str)
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' ' // pos_str_space(1:pos_str_len) // ' ', right_min, ' < '
write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualDouble7Digits
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | real, intent(in) |
| check(:,:,:,:,:,:,:) : | real, intent(in) |
| significant_digits : | integer, intent(in) |
| ignore_digits : | integer, intent(in) |
subroutine DCTestAssertEqualReal7Digits( message, answer, check, significant_digits, ignore_digits )
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:,:,:,:,:)
real, intent(in):: check(:,:,:,:,:,:,:)
integer, intent(in):: significant_digits
integer, intent(in):: ignore_digits
logical:: err_flag
character(STRING):: pos_str
real:: wrong, right_max, right_min
character(STRING):: pos_str_space
integer:: pos_str_len
real:: right_tmp
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(:,:,:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:,:,:)
real, allocatable:: answer_max(:,:,:,:,:,:,:)
real, allocatable:: answer_min(:,:,:,:,:,:,:)
continue
err_flag = .false.
if ( significant_digits < 1 ) then
write(*,*) ' *** Error [AssertEQ] *** '
write(*,*) ' Specify a number more than 1 to "significant_digits"'
call AbortProgram('')
end if
answer_shape = shape(answer)
check_shape = shape(check)
consist_shape = answer_shape == check_shape
if (.not. all(consist_shape)) then
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( answer_max ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( answer_min ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
answer_negative = answer < 0.0
check_negative = check < 0.0
both_negative = answer_negative .and. check_negative
where (both_negative)
answer_max = answer * ( 1.0 - 0.1 ** significant_digits ) + 0.1 ** (- ignore_digits)
answer_min = answer * ( 1.0 + 0.1 ** significant_digits ) - 0.1 ** (- ignore_digits)
elsewhere
answer_max = answer * ( 1.0 + 0.1 ** significant_digits ) + 0.1 ** (- ignore_digits)
answer_min = answer * ( 1.0 - 0.1 ** significant_digits ) - 0.1 ** (- ignore_digits)
end where
judge = answer_max > check .and. check > answer_min
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_max = answer_max ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) )
right_min = answer_min ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) )
if ( right_max < right_min ) then
right_tmp = right_max
right_max = right_min
right_min = right_tmp
end if
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)
deallocate(answer_negative, check_negative, both_negative)
deallocate(answer_max, answer_min)
if (err_flag) then
pos_str_space = ''
pos_str_len = len_trim(pos_str)
write(*,*) ' *** Error [AssertEQ] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT EQUAL to'
write(*,*) ' ' // pos_str_space(1:pos_str_len) // ' ', right_min, ' < '
write(*,*) ' answer' // trim(pos_str) // ' < ', right_max
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertEQ] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertEqualReal7Digits
| Subroutine : | |
| message : | character(*), intent(in) |
| answer : | integer, intent(in) |
| check : | integer, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanInt0( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer
integer, intent(in):: check
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
integer:: wrong, right
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
err_flag = .false.
err_flag = .not. answer < check
abs_mes = ''
if ( answer < 0 .and. check < 0 .and. negative_support_on ) then
err_flag = .not. err_flag
abs_mes = 'ABSOLUTE value of'
end if
wrong = check
right = answer
pos_str = ''
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanInt0
| Subroutine : | |
| message : | character(*), intent(in) |
| answer : | real(DP), intent(in) |
| check : | real(DP), intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanDouble0( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer
real(DP), intent(in):: check
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
real(DP):: wrong, right
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
err_flag = .false.
err_flag = .not. answer < check
abs_mes = ''
if ( answer < 0.0_DP .and. check < 0.0_DP .and. negative_support_on ) then
err_flag = .not. err_flag
abs_mes = 'ABSOLUTE value of'
end if
wrong = check
right = answer
pos_str = ''
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanDouble0
| Subroutine : | |
| message : | character(*), intent(in) |
| answer : | real, intent(in) |
| check : | real, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanReal0( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer
real, intent(in):: check
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
real:: wrong, right
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
err_flag = .false.
err_flag = .not. answer < check
abs_mes = ''
if ( answer < 0.0 .and. check < 0.0 .and. negative_support_on ) then
err_flag = .not. err_flag
abs_mes = 'ABSOLUTE value of'
end if
wrong = check
right = answer
pos_str = ''
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanReal0
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:) : | integer, intent(in) |
| check(:) : | integer, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanInt1( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:)
integer, intent(in):: check(:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:)
logical, allocatable:: answer_negative(:)
logical, allocatable:: check_negative(:)
logical, allocatable:: both_negative(:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1) ) )
allocate( judge ( answer_shape(1) ) )
allocate( judge_rev ( answer_shape(1) ) )
allocate( answer_negative ( answer_shape(1) ) )
allocate( check_negative ( answer_shape(1) ) )
allocate( both_negative ( answer_shape(1) ) )
answer_negative = answer < 0
check_negative = check < 0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer < check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanInt1
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:) : | real(DP), intent(in) |
| check(:) : | real(DP), intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanDouble1( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:)
real(DP), intent(in):: check(:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:)
logical, allocatable:: answer_negative(:)
logical, allocatable:: check_negative(:)
logical, allocatable:: both_negative(:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1) ) )
allocate( judge ( answer_shape(1) ) )
allocate( judge_rev ( answer_shape(1) ) )
allocate( answer_negative ( answer_shape(1) ) )
allocate( check_negative ( answer_shape(1) ) )
allocate( both_negative ( answer_shape(1) ) )
answer_negative = answer < 0.0_DP
check_negative = check < 0.0_DP
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer < check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanDouble1
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:) : | real, intent(in) |
| check(:) : | real, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanReal1( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:)
real, intent(in):: check(:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:)
logical, allocatable:: answer_negative(:)
logical, allocatable:: check_negative(:)
logical, allocatable:: both_negative(:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1) ) )
allocate( judge ( answer_shape(1) ) )
allocate( judge_rev ( answer_shape(1) ) )
allocate( answer_negative ( answer_shape(1) ) )
allocate( check_negative ( answer_shape(1) ) )
allocate( both_negative ( answer_shape(1) ) )
answer_negative = answer < 0.0
check_negative = check < 0.0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer < check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanReal1
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:) : | integer, intent(in) |
| check(:,:) : | integer, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanInt2( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:)
integer, intent(in):: check(:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:)
logical, allocatable:: answer_negative(:,:)
logical, allocatable:: check_negative(:,:)
logical, allocatable:: both_negative(:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2) ) )
allocate( judge ( answer_shape(1), answer_shape(2) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2) ) )
answer_negative = answer < 0
check_negative = check < 0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer < check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanInt2
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:) : | real(DP), intent(in) |
| check(:,:) : | real(DP), intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanDouble2( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:)
real(DP), intent(in):: check(:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:)
logical, allocatable:: answer_negative(:,:)
logical, allocatable:: check_negative(:,:)
logical, allocatable:: both_negative(:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2) ) )
allocate( judge ( answer_shape(1), answer_shape(2) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2) ) )
answer_negative = answer < 0.0_DP
check_negative = check < 0.0_DP
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer < check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanDouble2
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:) : | real, intent(in) |
| check(:,:) : | real, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanReal2( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:)
real, intent(in):: check(:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:)
logical, allocatable:: answer_negative(:,:)
logical, allocatable:: check_negative(:,:)
logical, allocatable:: both_negative(:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2) ) )
allocate( judge ( answer_shape(1), answer_shape(2) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2) ) )
answer_negative = answer < 0.0
check_negative = check < 0.0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer < check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanReal2
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:) : | integer, intent(in) |
| check(:,:,:) : | integer, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanInt3( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:,:)
integer, intent(in):: check(:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:)
logical, allocatable:: answer_negative(:,:,:)
logical, allocatable:: check_negative(:,:,:)
logical, allocatable:: both_negative(:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
answer_negative = answer < 0
check_negative = check < 0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer < check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanInt3
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:) : | real(DP), intent(in) |
| check(:,:,:) : | real(DP), intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanDouble3( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:)
real(DP), intent(in):: check(:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:)
logical, allocatable:: answer_negative(:,:,:)
logical, allocatable:: check_negative(:,:,:)
logical, allocatable:: both_negative(:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
answer_negative = answer < 0.0_DP
check_negative = check < 0.0_DP
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer < check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanDouble3
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:) : | real, intent(in) |
| check(:,:,:) : | real, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanReal3( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:)
real, intent(in):: check(:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:)
logical, allocatable:: answer_negative(:,:,:)
logical, allocatable:: check_negative(:,:,:)
logical, allocatable:: both_negative(:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
answer_negative = answer < 0.0
check_negative = check < 0.0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer < check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanReal3
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:) : | integer, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanInt4( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:,:,:)
integer, intent(in):: check(:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
answer_negative = answer < 0
check_negative = check < 0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer < check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanInt4
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:) : | real(DP), intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanDouble4( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:,:)
real(DP), intent(in):: check(:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
answer_negative = answer < 0.0_DP
check_negative = check < 0.0_DP
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer < check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanDouble4
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:) : | real, intent(in) |
| check(:,:,:,:) : | real, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanReal4( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:,:)
real, intent(in):: check(:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
answer_negative = answer < 0.0
check_negative = check < 0.0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer < check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanReal4
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:,:) : | integer, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanInt5( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:,:,:,:)
integer, intent(in):: check(:,:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
answer_negative = answer < 0
check_negative = check < 0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer < check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4), pos(5) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanInt5
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:,:) : | real(DP), intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanDouble5( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:,:,:)
real(DP), intent(in):: check(:,:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
answer_negative = answer < 0.0_DP
check_negative = check < 0.0_DP
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer < check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4), pos(5) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanDouble5
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:) : | real, intent(in) |
| check(:,:,:,:,:) : | real, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanReal5( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:,:,:)
real, intent(in):: check(:,:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
answer_negative = answer < 0.0
check_negative = check < 0.0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer < check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4), pos(5) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanReal5
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:,:,:) : | integer, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanInt6( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:,:,:,:,:)
integer, intent(in):: check(:,:,:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
answer_negative = answer < 0
check_negative = check < 0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer < check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanInt6
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:,:,:) : | real(DP), intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanDouble6( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:,:,:,:)
real(DP), intent(in):: check(:,:,:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
answer_negative = answer < 0.0_DP
check_negative = check < 0.0_DP
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer < check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanDouble6
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | real, intent(in) |
| check(:,:,:,:,:,:) : | real, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanReal6( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:,:,:,:)
real, intent(in):: check(:,:,:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
answer_negative = answer < 0.0
check_negative = check < 0.0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer < check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanReal6
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:,:,:,:) : | integer, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanInt7( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:,:,:,:,:,:)
integer, intent(in):: check(:,:,:,:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
answer_negative = answer < 0
check_negative = check < 0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer < check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanInt7
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:,:,:,:) : | real(DP), intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanDouble7( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:,:,:,:,:)
real(DP), intent(in):: check(:,:,:,:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
answer_negative = answer < 0.0_DP
check_negative = check < 0.0_DP
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer < check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanDouble7
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | real, intent(in) |
| check(:,:,:,:,:,:,:) : | real, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertGreaterThanReal7( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:,:,:,:,:)
real, intent(in):: check(:,:,:,:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
answer_negative = answer < 0.0
check_negative = check < 0.0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer < check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanReal7
| Subroutine : | |
| message : | character(*), intent(in) |
| answer : | integer, intent(in) |
| check : | integer, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanInt0( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer
integer, intent(in):: check
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
integer:: wrong, right
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
err_flag = .false.
err_flag = .not. answer > check
abs_mes = ''
if ( answer < 0 .and. check < 0 .and. negative_support_on ) then
err_flag = .not. err_flag
abs_mes = 'ABSOLUTE value of'
end if
wrong = check
right = answer
pos_str = ''
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanInt0
| Subroutine : | |
| message : | character(*), intent(in) |
| answer : | real(DP), intent(in) |
| check : | real(DP), intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanDouble0( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer
real(DP), intent(in):: check
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
real(DP):: wrong, right
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
err_flag = .false.
err_flag = .not. answer > check
abs_mes = ''
if ( answer < 0.0_DP .and. check < 0.0_DP .and. negative_support_on ) then
err_flag = .not. err_flag
abs_mes = 'ABSOLUTE value of'
end if
wrong = check
right = answer
pos_str = ''
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanDouble0
| Subroutine : | |
| message : | character(*), intent(in) |
| answer : | real, intent(in) |
| check : | real, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanReal0( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer
real, intent(in):: check
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
real:: wrong, right
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
err_flag = .false.
err_flag = .not. answer > check
abs_mes = ''
if ( answer < 0.0 .and. check < 0.0 .and. negative_support_on ) then
err_flag = .not. err_flag
abs_mes = 'ABSOLUTE value of'
end if
wrong = check
right = answer
pos_str = ''
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanReal0
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:) : | integer, intent(in) |
| check(:) : | integer, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanInt1( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:)
integer, intent(in):: check(:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:)
logical, allocatable:: answer_negative(:)
logical, allocatable:: check_negative(:)
logical, allocatable:: both_negative(:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1) ) )
allocate( judge ( answer_shape(1) ) )
allocate( judge_rev ( answer_shape(1) ) )
allocate( answer_negative ( answer_shape(1) ) )
allocate( check_negative ( answer_shape(1) ) )
allocate( both_negative ( answer_shape(1) ) )
answer_negative = answer < 0
check_negative = check < 0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer > check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanInt1
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:) : | real(DP), intent(in) |
| check(:) : | real(DP), intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanDouble1( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:)
real(DP), intent(in):: check(:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:)
logical, allocatable:: answer_negative(:)
logical, allocatable:: check_negative(:)
logical, allocatable:: both_negative(:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1) ) )
allocate( judge ( answer_shape(1) ) )
allocate( judge_rev ( answer_shape(1) ) )
allocate( answer_negative ( answer_shape(1) ) )
allocate( check_negative ( answer_shape(1) ) )
allocate( both_negative ( answer_shape(1) ) )
answer_negative = answer < 0.0_DP
check_negative = check < 0.0_DP
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer > check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanDouble1
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:) : | real, intent(in) |
| check(:) : | real, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanReal1( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:)
real, intent(in):: check(:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:)
logical, allocatable:: answer_negative(:)
logical, allocatable:: check_negative(:)
logical, allocatable:: both_negative(:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1) ) )
allocate( judge ( answer_shape(1) ) )
allocate( judge_rev ( answer_shape(1) ) )
allocate( answer_negative ( answer_shape(1) ) )
allocate( check_negative ( answer_shape(1) ) )
allocate( both_negative ( answer_shape(1) ) )
answer_negative = answer < 0.0
check_negative = check < 0.0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer > check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanReal1
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:) : | integer, intent(in) |
| check(:,:) : | integer, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanInt2( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:)
integer, intent(in):: check(:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:)
logical, allocatable:: answer_negative(:,:)
logical, allocatable:: check_negative(:,:)
logical, allocatable:: both_negative(:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2) ) )
allocate( judge ( answer_shape(1), answer_shape(2) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2) ) )
answer_negative = answer < 0
check_negative = check < 0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer > check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanInt2
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:) : | real(DP), intent(in) |
| check(:,:) : | real(DP), intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanDouble2( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:)
real(DP), intent(in):: check(:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:)
logical, allocatable:: answer_negative(:,:)
logical, allocatable:: check_negative(:,:)
logical, allocatable:: both_negative(:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2) ) )
allocate( judge ( answer_shape(1), answer_shape(2) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2) ) )
answer_negative = answer < 0.0_DP
check_negative = check < 0.0_DP
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer > check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanDouble2
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:) : | real, intent(in) |
| check(:,:) : | real, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanReal2( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:)
real, intent(in):: check(:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:)
logical, allocatable:: answer_negative(:,:)
logical, allocatable:: check_negative(:,:)
logical, allocatable:: both_negative(:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2) ) )
allocate( judge ( answer_shape(1), answer_shape(2) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2) ) )
answer_negative = answer < 0.0
check_negative = check < 0.0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer > check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanReal2
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:) : | integer, intent(in) |
| check(:,:,:) : | integer, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanInt3( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:,:)
integer, intent(in):: check(:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:)
logical, allocatable:: answer_negative(:,:,:)
logical, allocatable:: check_negative(:,:,:)
logical, allocatable:: both_negative(:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
answer_negative = answer < 0
check_negative = check < 0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer > check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanInt3
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:) : | real(DP), intent(in) |
| check(:,:,:) : | real(DP), intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanDouble3( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:)
real(DP), intent(in):: check(:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:)
logical, allocatable:: answer_negative(:,:,:)
logical, allocatable:: check_negative(:,:,:)
logical, allocatable:: both_negative(:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
answer_negative = answer < 0.0_DP
check_negative = check < 0.0_DP
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer > check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanDouble3
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:) : | real, intent(in) |
| check(:,:,:) : | real, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanReal3( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:)
real, intent(in):: check(:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:)
logical, allocatable:: answer_negative(:,:,:)
logical, allocatable:: check_negative(:,:,:)
logical, allocatable:: both_negative(:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3) ) )
answer_negative = answer < 0.0
check_negative = check < 0.0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer > check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanReal3
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:) : | integer, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanInt4( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:,:,:)
integer, intent(in):: check(:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
answer_negative = answer < 0
check_negative = check < 0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer > check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanInt4
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:) : | real(DP), intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanDouble4( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:,:)
real(DP), intent(in):: check(:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
answer_negative = answer < 0.0_DP
check_negative = check < 0.0_DP
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer > check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanDouble4
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:) : | real, intent(in) |
| check(:,:,:,:) : | real, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanReal4( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:,:)
real, intent(in):: check(:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4) ) )
answer_negative = answer < 0.0
check_negative = check < 0.0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer > check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanReal4
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:,:) : | integer, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanInt5( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:,:,:,:)
integer, intent(in):: check(:,:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
answer_negative = answer < 0
check_negative = check < 0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer > check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4), pos(5) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanInt5
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:,:) : | real(DP), intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanDouble5( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:,:,:)
real(DP), intent(in):: check(:,:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
answer_negative = answer < 0.0_DP
check_negative = check < 0.0_DP
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer > check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4), pos(5) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanDouble5
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:) : | real, intent(in) |
| check(:,:,:,:,:) : | real, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanReal5( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:,:,:)
real, intent(in):: check(:,:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5) ) )
answer_negative = answer < 0.0
check_negative = check < 0.0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer > check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4), pos(5) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanReal5
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:,:,:) : | integer, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanInt6( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:,:,:,:,:)
integer, intent(in):: check(:,:,:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
answer_negative = answer < 0
check_negative = check < 0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer > check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanInt6
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:,:,:) : | real(DP), intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanDouble6( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:,:,:,:)
real(DP), intent(in):: check(:,:,:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
answer_negative = answer < 0.0_DP
check_negative = check < 0.0_DP
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer > check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanDouble6
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:) : | real, intent(in) |
| check(:,:,:,:,:,:) : | real, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanReal6( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:,:,:,:)
real, intent(in):: check(:,:,:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6) ) )
answer_negative = answer < 0.0
check_negative = check < 0.0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer > check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanReal6
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | integer, intent(in) |
| check(:,:,:,:,:,:,:) : | integer, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanInt7( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
integer, intent(in):: answer(:,:,:,:,:,:,:)
integer, intent(in):: check(:,:,:,:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
answer_negative = answer < 0
check_negative = check < 0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer > check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanInt7
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | real(DP), intent(in) |
| check(:,:,:,:,:,:,:) : | real(DP), intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanDouble7( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real(DP), intent(in):: answer(:,:,:,:,:,:,:)
real(DP), intent(in):: check(:,:,:,:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
answer_negative = answer < 0.0_DP
check_negative = check < 0.0_DP
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer > check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanDouble7
| Subroutine : | |
| message : | character(*), intent(in) |
| answer(:,:,:,:,:,:,:) : | real, intent(in) |
| check(:,:,:,:,:,:,:) : | real, intent(in) |
| negative_support : | logical, intent(in), optional |
subroutine DCTestAssertLessThanReal7( message, answer, check, negative_support)
use sysdep, only: AbortProgram
use dc_types, only: STRING, TOKEN
implicit none
character(*), intent(in):: message
real, intent(in):: answer(:,:,:,:,:,:,:)
real, intent(in):: check(:,:,:,:,:,:,:)
logical, intent(in), optional:: negative_support
logical:: err_flag
logical:: negative_support_on
character(STRING):: pos_str
character(TOKEN):: abs_mes
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(:,:,:,:,:,:,:)
logical, allocatable:: answer_negative(:,:,:,:,:,:,:)
logical, allocatable:: check_negative(:,:,:,:,:,:,:)
logical, allocatable:: both_negative(:,:,:,:,:,:,:)
continue
if (present(negative_support)) then
negative_support_on = negative_support
else
negative_support_on = .true.
end if
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' shape of check is (', check_shape, ')'
write(*,*) ' is INCORRECT'
write(*,*) ' Correct shape of answer is (', answer_shape, ')'
call AbortProgram('')
end if
allocate( mask_array ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( judge_rev ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( answer_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( check_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
allocate( both_negative ( answer_shape(1), answer_shape(2), answer_shape(3), answer_shape(4), answer_shape(5), answer_shape(6), answer_shape(7) ) )
answer_negative = answer < 0.0
check_negative = check < 0.0
both_negative = answer_negative .and. check_negative
if (.not. negative_support_on) both_negative = .false.
judge = answer > check
where (both_negative) judge = .not. judge
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))) // ')'
if ( both_negative ( pos(1), pos(2), pos(3), pos(4), pos(5), pos(6), pos(7) ) ) then
abs_mes = 'ABSOLUTE value of'
else
abs_mes = ''
end if
end if
deallocate(mask_array, judge, judge_rev)
deallocate(answer_negative, check_negative, both_negative)
if (err_flag) then
write(*,*) ' *** Error [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' ' // trim(abs_mes) // ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' ' // trim(abs_mes) // ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanReal7