!--
! *** Caution!! ***
!
! This file is generated from "dc_test.rb2f90" by Ruby 1.8.2.
! Please do not edit this file directly.
!
! [JAPANESE]
!
! ※※※ 注意!!! ※※※
!
! このファイルは "dc_test.rb2f90" から Ruby 1.8.2
! によって自動生成されたファイルです.
! このファイルを直接編集しませんようお願い致します.
!
!
!++
!
!= テストプログラム作成支援
!
!= Support making test programs
!
! Authors:: Yasuhiro MORIKAWA
! Version:: $Id: dc_test.f90,v 1.15 2007/06/16 08:56:23 morikawa Exp $
! Tag Name:: $Name: gt4f90io-20070616 $
! Copyright:: Copyright (C) GFD Dennou Club, 2005-2007. All rights reserved.
! License:: See COPYRIGHT[link:../../COPYRIGHT]
!
module dc_test
!
!= テストプログラム作成支援
!
!= Support making test programs
!
! Note that Japanese and English are described in parallel.
!
! Fortran 90/95 におけるテストプログラム作成を補助するための
! モジュールです.
!
! {オブジェクト指向スクリプト言語 Ruby}[http://www.ruby-lang.org/]
! の {Test::Unit クラス}[http://www.ruby-lang.org/ja/man/?cmd=view;name=Test%3A%3AUnit]
! の機能の一部を模倣しています.
!
! This module supports making Fortran 90/95 test programs.
!
! A part of {Test::Unit class}[http://www.ruby-lang.org/ja/man/?cmd=view;name=Test%3A%3AUnit]
! in {Object-oriented programming language Ruby}[http://www.ruby-lang.org/]
! is imitated.
!
!== Procedures List
!
! 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.
!
!== Usage
!
! 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.0d0, 2.0d0/)
! call AssertEqual(message='String test', answer='foo', check=str1)
! call AssertEqual(message='Float test', &
! & answer=(/1.0e0, 2.0e0/), 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 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 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*.
!
!
!=== Example
!
! 使用例は以下の通りです.
!
! Example of use is showed as follows.
!
!
! program test_sample
! use dc_types, only: STRING, DP
! use dc_test, only: AssertEqual, AssertGreaterThan, AssertLessThan
! character(STRING):: str1
! integer:: int1
! real:: numr1(2)
! real(DP):: numd1(2,3)
! logical:: y_n
!
! str1 = "foo"
! call AssertEqual('Character test', answer='foo', check=str1)
! int1 = 1
! call AssertEqual('Integer test', answer=1, check=int1)
! numr1(:) = (/0.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.432d0, 75.3d0, 3.183d0, &
! & 0.023d0, 0.9d0, 328.2d0/), &
! & (/2,3/))
! call AssertGreaterThan('Double precision test 1', &
! & answer=reshape((/ 38.8639d0, 150.5999d0, 6.365999d0, &
! & 0.0459999d0, 1.7999d0, 656.3999d0/), &
! & (/2,3/)), &
! & check=numd1*2.0d0)
! call AssertLessThan('Double precision test 2', &
! & answer=reshape((/ 38.86401d0, 150.60001d0, 6.3660001d0, &
! & 0.04600001d0, 1.8000001d0, 656.3d0/), &
! & (/2,3/)), &
! & check=numd1*2.0d0)
! end program test_sample
!
!
! 上記の例では, 最後のテストで敢えて間違った answer を与えているので,
! 以下のようなメッセージを出力してプログラムは強制終了します.
!
! In above example, wrong "answer" is given on purpose in the last
! test. Then the program displays a following message, and aborts.
!
! *** 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
! *** Error [AssertLT] *** Checking Double precision test 2 FAILURE
!
! check(2,3) = 656.4000000000000
! is NOT LESS THAN
! answer(2,3) = 656.3000000000000
!
!
use dc_types, only : STRING, DP
implicit none
private
public AssertEqual, AssertGreaterThan, AssertLessThan
interface AssertEqual
module procedure DCTestAssertEqualChar0
module procedure DCTestAssertEqualChar1
module procedure DCTestAssertEqualChar2
module procedure DCTestAssertEqualChar3
module procedure DCTestAssertEqualChar4
module procedure DCTestAssertEqualChar5
module procedure DCTestAssertEqualChar6
module procedure DCTestAssertEqualChar7
module procedure DCTestAssertEqualInt0
module procedure DCTestAssertEqualInt1
module procedure DCTestAssertEqualInt2
module procedure DCTestAssertEqualInt3
module procedure DCTestAssertEqualInt4
module procedure DCTestAssertEqualInt5
module procedure DCTestAssertEqualInt6
module procedure DCTestAssertEqualInt7
module procedure DCTestAssertEqualReal0
module procedure DCTestAssertEqualReal1
module procedure DCTestAssertEqualReal2
module procedure DCTestAssertEqualReal3
module procedure DCTestAssertEqualReal4
module procedure DCTestAssertEqualReal5
module procedure DCTestAssertEqualReal6
module procedure DCTestAssertEqualReal7
module procedure DCTestAssertEqualDouble0
module procedure DCTestAssertEqualDouble1
module procedure DCTestAssertEqualDouble2
module procedure DCTestAssertEqualDouble3
module procedure DCTestAssertEqualDouble4
module procedure DCTestAssertEqualDouble5
module procedure DCTestAssertEqualDouble6
module procedure DCTestAssertEqualDouble7
module procedure DCTestAssertEqualLogical0
module procedure DCTestAssertEqualLogical1
module procedure DCTestAssertEqualLogical2
module procedure DCTestAssertEqualLogical3
module procedure DCTestAssertEqualLogical4
module procedure DCTestAssertEqualLogical5
module procedure DCTestAssertEqualLogical6
module procedure DCTestAssertEqualLogical7
end interface
interface AssertGreaterThan
module procedure DCTestAssertGreaterThanInt0
module procedure DCTestAssertGreaterThanInt1
module procedure DCTestAssertGreaterThanInt2
module procedure DCTestAssertGreaterThanInt3
module procedure DCTestAssertGreaterThanInt4
module procedure DCTestAssertGreaterThanInt5
module procedure DCTestAssertGreaterThanInt6
module procedure DCTestAssertGreaterThanInt7
module procedure DCTestAssertGreaterThanReal0
module procedure DCTestAssertGreaterThanReal1
module procedure DCTestAssertGreaterThanReal2
module procedure DCTestAssertGreaterThanReal3
module procedure DCTestAssertGreaterThanReal4
module procedure DCTestAssertGreaterThanReal5
module procedure DCTestAssertGreaterThanReal6
module procedure DCTestAssertGreaterThanReal7
module procedure DCTestAssertGreaterThanDouble0
module procedure DCTestAssertGreaterThanDouble1
module procedure DCTestAssertGreaterThanDouble2
module procedure DCTestAssertGreaterThanDouble3
module procedure DCTestAssertGreaterThanDouble4
module procedure DCTestAssertGreaterThanDouble5
module procedure DCTestAssertGreaterThanDouble6
module procedure DCTestAssertGreaterThanDouble7
end interface
interface AssertLessThan
module procedure DCTestAssertLessThanInt0
module procedure DCTestAssertLessThanInt1
module procedure DCTestAssertLessThanInt2
module procedure DCTestAssertLessThanInt3
module procedure DCTestAssertLessThanInt4
module procedure DCTestAssertLessThanInt5
module procedure DCTestAssertLessThanInt6
module procedure DCTestAssertLessThanInt7
module procedure DCTestAssertLessThanReal0
module procedure DCTestAssertLessThanReal1
module procedure DCTestAssertLessThanReal2
module procedure DCTestAssertLessThanReal3
module procedure DCTestAssertLessThanReal4
module procedure DCTestAssertLessThanReal5
module procedure DCTestAssertLessThanReal6
module procedure DCTestAssertLessThanReal7
module procedure DCTestAssertLessThanDouble0
module procedure DCTestAssertLessThanDouble1
module procedure DCTestAssertLessThanDouble2
module procedure DCTestAssertLessThanDouble3
module procedure DCTestAssertLessThanDouble4
module procedure DCTestAssertLessThanDouble5
module procedure DCTestAssertLessThanDouble6
module procedure DCTestAssertLessThanDouble7
end interface
contains
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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 DCTestAssertGreaterThanInt0(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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanInt0
subroutine DCTestAssertGreaterThanInt1(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 [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) ) &
& )
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanInt1
subroutine DCTestAssertGreaterThanInt2(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 [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) ) &
& )
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanInt2
subroutine DCTestAssertGreaterThanInt3(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 [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) ) &
& )
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanInt3
subroutine DCTestAssertGreaterThanInt4(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 [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) ) &
& )
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanInt4
subroutine DCTestAssertGreaterThanInt5(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 [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) ) &
& )
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanInt5
subroutine DCTestAssertGreaterThanInt6(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 [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) ) &
& )
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanInt6
subroutine DCTestAssertGreaterThanInt7(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 [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) ) &
& )
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanInt7
subroutine DCTestAssertGreaterThanReal0(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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanReal0
subroutine DCTestAssertGreaterThanReal1(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 [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) ) &
& )
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanReal1
subroutine DCTestAssertGreaterThanReal2(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 [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) ) &
& )
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanReal2
subroutine DCTestAssertGreaterThanReal3(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 [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) ) &
& )
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanReal3
subroutine DCTestAssertGreaterThanReal4(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 [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) ) &
& )
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanReal4
subroutine DCTestAssertGreaterThanReal5(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 [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) ) &
& )
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanReal5
subroutine DCTestAssertGreaterThanReal6(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 [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) ) &
& )
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanReal6
subroutine DCTestAssertGreaterThanReal7(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 [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) ) &
& )
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanReal7
subroutine DCTestAssertGreaterThanDouble0(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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanDouble0
subroutine DCTestAssertGreaterThanDouble1(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 [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) ) &
& )
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanDouble1
subroutine DCTestAssertGreaterThanDouble2(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 [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) ) &
& )
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanDouble2
subroutine DCTestAssertGreaterThanDouble3(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 [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) ) &
& )
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanDouble3
subroutine DCTestAssertGreaterThanDouble4(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 [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) ) &
& )
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanDouble4
subroutine DCTestAssertGreaterThanDouble5(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 [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) ) &
& )
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanDouble5
subroutine DCTestAssertGreaterThanDouble6(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 [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) ) &
& )
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanDouble6
subroutine DCTestAssertGreaterThanDouble7(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 [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) ) &
& )
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 [AssertGT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT GREATER THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertGT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertGreaterThanDouble7
subroutine DCTestAssertLessThanInt0(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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanInt0
subroutine DCTestAssertLessThanInt1(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 [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) ) &
& )
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanInt1
subroutine DCTestAssertLessThanInt2(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 [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) ) &
& )
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanInt2
subroutine DCTestAssertLessThanInt3(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 [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) ) &
& )
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanInt3
subroutine DCTestAssertLessThanInt4(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 [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) ) &
& )
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanInt4
subroutine DCTestAssertLessThanInt5(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 [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) ) &
& )
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanInt5
subroutine DCTestAssertLessThanInt6(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 [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) ) &
& )
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanInt6
subroutine DCTestAssertLessThanInt7(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 [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) ) &
& )
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanInt7
subroutine DCTestAssertLessThanReal0(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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanReal0
subroutine DCTestAssertLessThanReal1(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 [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) ) &
& )
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanReal1
subroutine DCTestAssertLessThanReal2(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 [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) ) &
& )
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanReal2
subroutine DCTestAssertLessThanReal3(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 [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) ) &
& )
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanReal3
subroutine DCTestAssertLessThanReal4(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 [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) ) &
& )
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanReal4
subroutine DCTestAssertLessThanReal5(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 [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) ) &
& )
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanReal5
subroutine DCTestAssertLessThanReal6(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 [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) ) &
& )
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanReal6
subroutine DCTestAssertLessThanReal7(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 [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) ) &
& )
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanReal7
subroutine DCTestAssertLessThanDouble0(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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanDouble0
subroutine DCTestAssertLessThanDouble1(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 [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) ) &
& )
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanDouble1
subroutine DCTestAssertLessThanDouble2(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 [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) ) &
& )
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanDouble2
subroutine DCTestAssertLessThanDouble3(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 [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) ) &
& )
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanDouble3
subroutine DCTestAssertLessThanDouble4(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 [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) ) &
& )
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanDouble4
subroutine DCTestAssertLessThanDouble5(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 [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) ) &
& )
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanDouble5
subroutine DCTestAssertLessThanDouble6(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 [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) ) &
& )
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanDouble6
subroutine DCTestAssertLessThanDouble7(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 [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) ) &
& )
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 [AssertLT] *** Checking ' // trim(message) // ' FAILURE'
write(*,*) ''
write(*,*) ' check' // trim(pos_str) // ' = ', wrong
write(*,*) ' is NOT LESS THAN'
write(*,*) ' answer' // trim(pos_str) // ' = ', right
call AbortProgram('')
else
write(*,*) ' *** MESSAGE [AssertLT] *** Checking ' // trim(message) // ' OK'
end if
end subroutine DCTestAssertLessThanDouble7
end module dc_test
!--
! vi:set readonly sw=4 ts=8:
!
!Local Variables:
!mode: f90
!buffer-read-only: t
!End:
!
!++